submodule (stdlib_stats) stdlib_stats_var

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

contains

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

        real(dp) :: n
        real(dp) :: mean

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

        n = real(size(x, kind = int64), dp)
        mean = sum(x) / n

          res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.)))

      end function var_all_1_rdp_rdp
      module function var_all_2_rdp_rdp(x, mask, corrected) result(res)
        real(dp), intent(in) :: x(:,:)
        logical, intent(in), optional :: mask
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n
        real(dp) :: mean

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

        n = real(size(x, kind = int64), dp)
        mean = sum(x) / n

          res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.)))

      end function var_all_2_rdp_rdp
      module function var_all_3_rdp_rdp(x, mask, corrected) result(res)
        real(dp), intent(in) :: x(:,:,:)
        logical, intent(in), optional :: mask
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n
        real(dp) :: mean

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

        n = real(size(x, kind = int64), dp)
        mean = sum(x) / n

          res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.)))

      end function var_all_3_rdp_rdp
      module function var_all_4_rdp_rdp(x, mask, corrected) result(res)
        real(dp), intent(in) :: x(:,:,:,:)
        logical, intent(in), optional :: mask
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n
        real(dp) :: mean

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

        n = real(size(x, kind = int64), dp)
        mean = sum(x) / n

          res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.)))

      end function var_all_4_rdp_rdp
      module function var_all_1_cdp_cdp(x, mask, corrected) result(res)
        complex(dp), intent(in) :: x(:)
        logical, intent(in), optional :: mask
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n
        complex(dp) :: mean

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

        n = real(size(x, kind = int64), dp)
        mean = sum(x) / n

          res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.)))

      end function var_all_1_cdp_cdp
      module function var_all_2_cdp_cdp(x, mask, corrected) result(res)
        complex(dp), intent(in) :: x(:,:)
        logical, intent(in), optional :: mask
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n
        complex(dp) :: mean

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

        n = real(size(x, kind = int64), dp)
        mean = sum(x) / n

          res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.)))

      end function var_all_2_cdp_cdp
      module function var_all_3_cdp_cdp(x, mask, corrected) result(res)
        complex(dp), intent(in) :: x(:,:,:)
        logical, intent(in), optional :: mask
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n
        complex(dp) :: mean

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

        n = real(size(x, kind = int64), dp)
        mean = sum(x) / n

          res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.)))

      end function var_all_3_cdp_cdp
      module function var_all_4_cdp_cdp(x, mask, corrected) result(res)
        complex(dp), intent(in) :: x(:,:,:,:)
        logical, intent(in), optional :: mask
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n
        complex(dp) :: mean

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

        n = real(size(x, kind = int64), dp)
        mean = sum(x) / n

          res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.)))

      end function var_all_4_cdp_cdp

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

        real(dp) :: n, mean

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

        n = real(size(x, kind = int64), dp)
        mean = sum(real(x, dp)) / n

        res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.)))

      end function var_all_1_iint32_dp
      module function var_all_2_iint32_dp(x, mask, corrected) result(res)
        integer(int32), intent(in) :: x(:,:)
        logical, intent(in), optional :: mask
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n, mean

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

        n = real(size(x, kind = int64), dp)
        mean = sum(real(x, dp)) / n

        res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.)))

      end function var_all_2_iint32_dp
      module function var_all_3_iint32_dp(x, mask, corrected) result(res)
        integer(int32), intent(in) :: x(:,:,:)
        logical, intent(in), optional :: mask
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n, mean

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

        n = real(size(x, kind = int64), dp)
        mean = sum(real(x, dp)) / n

        res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.)))

      end function var_all_3_iint32_dp
      module function var_all_4_iint32_dp(x, mask, corrected) result(res)
        integer(int32), intent(in) :: x(:,:,:,:)
        logical, intent(in), optional :: mask
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n, mean

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

        n = real(size(x, kind = int64), dp)
        mean = sum(real(x, dp)) / n

        res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.)))

      end function var_all_4_iint32_dp

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

        integer :: i
        real(dp) :: n
        real(dp) :: mean

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

        res = 0._dp
        select case(dim)
          case(1)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + (x(i) - mean)**2
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, optval(corrected, .true.)))

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

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

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

        res = 0._dp
        select case(dim)
          case(1)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + (x(i, :) - mean)**2
            end do
          case(2)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + (x(:, i) - mean)**2
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, optval(corrected, .true.)))

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

        integer :: i
        real(dp) :: n
        real(dp) :: mean(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

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

        res = 0._dp
        select case(dim)
          case(1)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + (x(i, :, :) - mean)**2
            end do
          case(2)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + (x(:, i, :) - mean)**2
            end do
          case(3)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + (x(:, :, i) - mean)**2
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, optval(corrected, .true.)))

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

        integer :: i
        real(dp) :: n
        real(dp) :: mean(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

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

        res = 0._dp
        select case(dim)
          case(1)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + (x(i, :, :, :) - mean)**2
            end do
          case(2)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + (x(:, i, :, :) - mean)**2
            end do
          case(3)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + (x(:, :, i, :) - mean)**2
            end do
          case(4)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + (x(:, :, :, i) - mean)**2
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, optval(corrected, .true.)))

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

        integer :: i
        real(dp) :: n
        complex(dp) :: mean

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

        res = 0._dp
        select case(dim)
          case(1)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + abs(x(i) - mean)**2
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, optval(corrected, .true.)))

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

        integer :: i
        real(dp) :: n
        complex(dp) :: mean(merge(size(x, 1), size(x, 2), mask=1<dim))

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

        res = 0._dp
        select case(dim)
          case(1)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + abs(x(i, :) - mean)**2
            end do
          case(2)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + abs(x(:, i) - mean)**2
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, optval(corrected, .true.)))

      end function var_2_cdp_cdp
      module function var_3_cdp_cdp(x, dim, mask, corrected) result(res)
        complex(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: dim
        logical, intent(in), optional :: mask
        logical, intent(in), optional :: corrected
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        integer :: i
        real(dp) :: n
        complex(dp) :: mean(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

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

        res = 0._dp
        select case(dim)
          case(1)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + abs(x(i, :, :) - mean)**2
            end do
          case(2)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + abs(x(:, i, :) - mean)**2
            end do
          case(3)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + abs(x(:, :, i) - mean)**2
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, optval(corrected, .true.)))

      end function var_3_cdp_cdp
      module function var_4_cdp_cdp(x, dim, mask, corrected) result(res)
        complex(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: dim
        logical, intent(in), optional :: mask
        logical, intent(in), optional :: corrected
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        integer :: i
        real(dp) :: n
        complex(dp) :: mean(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x,&
            & 3), size(x, 4), mask=3<dim))

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

        res = 0._dp
        select case(dim)
          case(1)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + abs(x(i, :, :, :) - mean)**2
            end do
          case(2)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + abs(x(:, i, :, :) - mean)**2
            end do
          case(3)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + abs(x(:, :, i, :) - mean)**2
            end do
          case(4)
            n = size(x, dim)
            mean = sum(x, dim) / n
            do i = 1, size(x, dim)
                res = res + abs(x(:, :, :, i) - mean)**2
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, optval(corrected, .true.)))

      end function var_4_cdp_cdp

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

        integer :: i
        real(dp) :: n
        real(dp) :: mean

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

        res = 0._dp
        select case(dim)
          case(1)
            n = size(x, dim)
            mean = sum(real(x, dp), dim) / n
            do i = 1, size(x, dim)
              res = res + (real(x(i), dp) - mean)**2
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, optval(corrected, .true.)))

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

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

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

        res = 0._dp
        select case(dim)
          case(1)
            n = size(x, dim)
            mean = sum(real(x, dp), dim) / n
            do i = 1, size(x, dim)
              res = res + (real(x(i, :), dp) - mean)**2
            end do
          case(2)
            n = size(x, dim)
            mean = sum(real(x, dp), dim) / n
            do i = 1, size(x, dim)
              res = res + (real(x(:, i), dp) - mean)**2
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, optval(corrected, .true.)))

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

        integer :: i
        real(dp) :: n
        real(dp) :: mean(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

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

        res = 0._dp
        select case(dim)
          case(1)
            n = size(x, dim)
            mean = sum(real(x, dp), dim) / n
            do i = 1, size(x, dim)
              res = res + (real(x(i, :, :), dp) - mean)**2
            end do
          case(2)
            n = size(x, dim)
            mean = sum(real(x, dp), dim) / n
            do i = 1, size(x, dim)
              res = res + (real(x(:, i, :), dp) - mean)**2
            end do
          case(3)
            n = size(x, dim)
            mean = sum(real(x, dp), dim) / n
            do i = 1, size(x, dim)
              res = res + (real(x(:, :, i), dp) - mean)**2
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, optval(corrected, .true.)))

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

        integer :: i
        real(dp) :: n
        real(dp) :: mean(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

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

        res = 0._dp
        select case(dim)
          case(1)
            n = size(x, dim)
            mean = sum(real(x, dp), dim) / n
            do i = 1, size(x, dim)
              res = res + (real(x(i, :, :, :), dp) - mean)**2
            end do
          case(2)
            n = size(x, dim)
            mean = sum(real(x, dp), dim) / n
            do i = 1, size(x, dim)
              res = res + (real(x(:, i, :, :), dp) - mean)**2
            end do
          case(3)
            n = size(x, dim)
            mean = sum(real(x, dp), dim) / n
            do i = 1, size(x, dim)
              res = res + (real(x(:, :, i, :), dp) - mean)**2
            end do
          case(4)
            n = size(x, dim)
            mean = sum(real(x, dp), dim) / n
            do i = 1, size(x, dim)
              res = res + (real(x(:, :, :, i), dp) - mean)**2
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, optval(corrected, .true.)))

      end function var_4_iint32_dp

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

        real(dp) :: n
        real(dp) :: mean

        n = real(count(mask, kind = int64), dp)
        mean = sum(x, mask) / n

          res = sum((x - mean)**2, mask) / (n -&
                merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_all_1_rdp_rdp
      module function var_mask_all_2_rdp_rdp(x, mask, corrected) result(res)
        real(dp), intent(in) :: x(:,:)
        logical, intent(in) :: mask(:,:)
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n
        real(dp) :: mean

        n = real(count(mask, kind = int64), dp)
        mean = sum(x, mask) / n

          res = sum((x - mean)**2, mask) / (n -&
                merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_all_2_rdp_rdp
      module function var_mask_all_3_rdp_rdp(x, mask, corrected) result(res)
        real(dp), intent(in) :: x(:,:,:)
        logical, intent(in) :: mask(:,:,:)
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n
        real(dp) :: mean

        n = real(count(mask, kind = int64), dp)
        mean = sum(x, mask) / n

          res = sum((x - mean)**2, mask) / (n -&
                merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_all_3_rdp_rdp
      module function var_mask_all_4_rdp_rdp(x, mask, corrected) result(res)
        real(dp), intent(in) :: x(:,:,:,:)
        logical, intent(in) :: mask(:,:,:,:)
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n
        real(dp) :: mean

        n = real(count(mask, kind = int64), dp)
        mean = sum(x, mask) / n

          res = sum((x - mean)**2, mask) / (n -&
                merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_all_4_rdp_rdp
      module function var_mask_all_1_cdp_cdp(x, mask, corrected) result(res)
        complex(dp), intent(in) :: x(:)
        logical, intent(in) :: mask(:)
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n
        complex(dp) :: mean

        n = real(count(mask, kind = int64), dp)
        mean = sum(x, mask) / n

          res = sum(abs(x - mean)**2, mask) / (n -&
                merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_all_1_cdp_cdp
      module function var_mask_all_2_cdp_cdp(x, mask, corrected) result(res)
        complex(dp), intent(in) :: x(:,:)
        logical, intent(in) :: mask(:,:)
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n
        complex(dp) :: mean

        n = real(count(mask, kind = int64), dp)
        mean = sum(x, mask) / n

          res = sum(abs(x - mean)**2, mask) / (n -&
                merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_all_2_cdp_cdp
      module function var_mask_all_3_cdp_cdp(x, mask, corrected) result(res)
        complex(dp), intent(in) :: x(:,:,:)
        logical, intent(in) :: mask(:,:,:)
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n
        complex(dp) :: mean

        n = real(count(mask, kind = int64), dp)
        mean = sum(x, mask) / n

          res = sum(abs(x - mean)**2, mask) / (n -&
                merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_all_3_cdp_cdp
      module function var_mask_all_4_cdp_cdp(x, mask, corrected) result(res)
        complex(dp), intent(in) :: x(:,:,:,:)
        logical, intent(in) :: mask(:,:,:,:)
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n
        complex(dp) :: mean

        n = real(count(mask, kind = int64), dp)
        mean = sum(x, mask) / n

          res = sum(abs(x - mean)**2, mask) / (n -&
                merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_all_4_cdp_cdp

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

        real(dp) :: n, mean

        n = real(count(mask, kind = int64), dp)
        mean = sum(real(x, dp), mask) / n

        res = sum((real(x, dp) - mean)**2, mask) / (n -&
              merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_all_1_iint32_dp
      module function var_mask_all_2_iint32_dp(x, mask, corrected) result(res)
        integer(int32), intent(in) :: x(:,:)
        logical, intent(in) :: mask(:,:)
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n, mean

        n = real(count(mask, kind = int64), dp)
        mean = sum(real(x, dp), mask) / n

        res = sum((real(x, dp) - mean)**2, mask) / (n -&
              merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_all_2_iint32_dp
      module function var_mask_all_3_iint32_dp(x, mask, corrected) result(res)
        integer(int32), intent(in) :: x(:,:,:)
        logical, intent(in) :: mask(:,:,:)
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n, mean

        n = real(count(mask, kind = int64), dp)
        mean = sum(real(x, dp), mask) / n

        res = sum((real(x, dp) - mean)**2, mask) / (n -&
              merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_all_3_iint32_dp
      module function var_mask_all_4_iint32_dp(x, mask, corrected) result(res)
        integer(int32), intent(in) :: x(:,:,:,:)
        logical, intent(in) :: mask(:,:,:,:)
        logical, intent(in), optional :: corrected
        real(dp) :: res

        real(dp) :: n, mean

        n = real(count(mask, kind = int64), dp)
        mean = sum(real(x, dp), mask) / n

        res = sum((real(x, dp) - mean)**2, mask) / (n -&
              merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_all_4_iint32_dp

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

        integer :: i
        real(dp) :: n
        real(dp) :: mean

        res = 0._dp
        select case(dim)
          case(1)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( (x(i) - mean)**2,&
                                  0._dp,&
                                  mask(i))
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

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

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

        res = 0._dp
        select case(dim)
          case(1)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( (x(i, :) - mean)**2,&
                                  0._dp,&
                                  mask(i, :))
            end do
          case(2)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( (x(:, i) - mean)**2,&
                                  0._dp,&
                                  mask(:, i))
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

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

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))
        real(dp) :: mean(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        res = 0._dp
        select case(dim)
          case(1)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( (x(i, :, :) - mean)**2,&
                                  0._dp,&
                                  mask(i, :, :))
            end do
          case(2)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( (x(:, i, :) - mean)**2,&
                                  0._dp,&
                                  mask(:, i, :))
            end do
          case(3)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( (x(:, :, i) - mean)**2,&
                                  0._dp,&
                                  mask(:, :, i))
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

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

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))
        real(dp) :: mean(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        res = 0._dp
        select case(dim)
          case(1)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( (x(i, :, :, :) - mean)**2,&
                                  0._dp,&
                                  mask(i, :, :, :))
            end do
          case(2)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( (x(:, i, :, :) - mean)**2,&
                                  0._dp,&
                                  mask(:, i, :, :))
            end do
          case(3)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( (x(:, :, i, :) - mean)**2,&
                                  0._dp,&
                                  mask(:, :, i, :))
            end do
          case(4)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( (x(:, :, :, i) - mean)**2,&
                                  0._dp,&
                                  mask(:, :, :, i))
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

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

        integer :: i
        real(dp) :: n
        complex(dp) :: mean

        res = 0._dp
        select case(dim)
          case(1)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( abs(x(i) - mean)**2,&
                                  0._dp,&
                                  mask(i))
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

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

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim))
        complex(dp) :: mean(merge(size(x, 1), size(x, 2), mask=1<dim))

        res = 0._dp
        select case(dim)
          case(1)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( abs(x(i, :) - mean)**2,&
                                  0._dp,&
                                  mask(i, :))
            end do
          case(2)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( abs(x(:, i) - mean)**2,&
                                  0._dp,&
                                  mask(:, i))
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_2_cdp_cdp
      module function var_mask_3_cdp_cdp(x, dim, mask, corrected) result(res)
        complex(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: dim
        logical, intent(in) :: mask(:,:,:)
        logical, intent(in), optional :: corrected
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))
        complex(dp) :: mean(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        res = 0._dp
        select case(dim)
          case(1)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( abs(x(i, :, :) - mean)**2,&
                                  0._dp,&
                                  mask(i, :, :))
            end do
          case(2)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( abs(x(:, i, :) - mean)**2,&
                                  0._dp,&
                                  mask(:, i, :))
            end do
          case(3)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( abs(x(:, :, i) - mean)**2,&
                                  0._dp,&
                                  mask(:, :, i))
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_3_cdp_cdp
      module function var_mask_4_cdp_cdp(x, dim, mask, corrected) result(res)
        complex(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: dim
        logical, intent(in) :: mask(:,:,:,:)
        logical, intent(in), optional :: corrected
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))
        complex(dp) :: mean(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x,&
            & 3), size(x, 4), mask=3<dim))

        res = 0._dp
        select case(dim)
          case(1)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( abs(x(i, :, :, :) - mean)**2,&
                                  0._dp,&
                                  mask(i, :, :, :))
            end do
          case(2)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( abs(x(:, i, :, :) - mean)**2,&
                                  0._dp,&
                                  mask(:, i, :, :))
            end do
          case(3)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( abs(x(:, :, i, :) - mean)**2,&
                                  0._dp,&
                                  mask(:, :, i, :))
            end do
          case(4)
            n = count(mask, dim)
            mean = sum(x, dim, mask) / n
            do i = 1, size(x, dim)
                res = res + merge( abs(x(:, :, :, i) - mean)**2,&
                                  0._dp,&
                                  mask(:, :, :, i))
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_4_cdp_cdp

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

        integer :: i
        real(dp) :: n
        real(dp) :: mean

        res = 0._dp
        select case(dim)
          case(1)
            n = count(mask, dim)
            mean = sum(real(x, dp), dim, mask) / n
            do i = 1, size(x, dim)
              res = res + merge((real(x(i), dp) - mean)**2,&
                                  0._dp, mask(i))
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

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

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

        res = 0._dp
        select case(dim)
          case(1)
            n = count(mask, dim)
            mean = sum(real(x, dp), dim, mask) / n
            do i = 1, size(x, dim)
              res = res + merge((real(x(i, :), dp) - mean)**2,&
                                  0._dp, mask(i, :))
            end do
          case(2)
            n = count(mask, dim)
            mean = sum(real(x, dp), dim, mask) / n
            do i = 1, size(x, dim)
              res = res + merge((real(x(:, i), dp) - mean)**2,&
                                  0._dp, mask(:, i))
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

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

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))
        real(dp) :: mean(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        res = 0._dp
        select case(dim)
          case(1)
            n = count(mask, dim)
            mean = sum(real(x, dp), dim, mask) / n
            do i = 1, size(x, dim)
              res = res + merge((real(x(i, :, :), dp) - mean)**2,&
                                  0._dp, mask(i, :, :))
            end do
          case(2)
            n = count(mask, dim)
            mean = sum(real(x, dp), dim, mask) / n
            do i = 1, size(x, dim)
              res = res + merge((real(x(:, i, :), dp) - mean)**2,&
                                  0._dp, mask(:, i, :))
            end do
          case(3)
            n = count(mask, dim)
            mean = sum(real(x, dp), dim, mask) / n
            do i = 1, size(x, dim)
              res = res + merge((real(x(:, :, i), dp) - mean)**2,&
                                  0._dp, mask(:, :, i))
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

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

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))
        real(dp) :: mean(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        res = 0._dp
        select case(dim)
          case(1)
            n = count(mask, dim)
            mean = sum(real(x, dp), dim, mask) / n
            do i = 1, size(x, dim)
              res = res + merge((real(x(i, :, :, :), dp) - mean)**2,&
                                  0._dp, mask(i, :, :, :))
            end do
          case(2)
            n = count(mask, dim)
            mean = sum(real(x, dp), dim, mask) / n
            do i = 1, size(x, dim)
              res = res + merge((real(x(:, i, :, :), dp) - mean)**2,&
                                  0._dp, mask(:, i, :, :))
            end do
          case(3)
            n = count(mask, dim)
            mean = sum(real(x, dp), dim, mask) / n
            do i = 1, size(x, dim)
              res = res + merge((real(x(:, :, i, :), dp) - mean)**2,&
                                  0._dp, mask(:, :, i, :))
            end do
          case(4)
            n = count(mask, dim)
            mean = sum(real(x, dp), dim, mask) / n
            do i = 1, size(x, dim)
              res = res + merge((real(x(:, :, :, i), dp) - mean)**2,&
                                  0._dp, mask(:, :, :, i))
            end do
          case default
            call error_stop("ERROR (var): wrong dimension")
        end select
        res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0)))

      end function var_mask_4_iint32_dp

end submodule


program print_01
implicit none
integer :: x
x = (2+3)*5
print *, x, 1, 3, x, (2+3)*5+x
write(*,*) x, 1, 3, x, (2+3)*5+x
end program


program test_cond_triangular
  use mod_orrb
  implicit none
  integer(kind=int32) :: n, j, k
  type(error_info) :: error
  real(kind=dp), parameter :: tol=1.0e-15_dp, tol1=10*tol
  character(len=*), parameter :: fmt_sv="(A15, '; SV: ',ES8.2, ', Res1: ', ES8.2, ', Res2: ', ES8.2, ', Res3: ', ES8.2, ', ', A10)"
  character(len=40) :: test_name

  real(kind=dp), dimension(:,:), allocatable :: l_d, r_d
  real(kind=dp), dimension(:), allocatable :: u_d, v_d, res_d, res_d1
  real(kind=dp) :: sigma_d, tmp

  complex(kind=dp), dimension(:,:), allocatable :: l_z, r_z
  complex(kind=dp), dimension(:), allocatable :: u_z, v_z, res_z, res_z1
  real(kind=dp) :: sigma_z

  print *
  print *, "--------------------------------"
  print *
  print *, "Real Triangular Condition Estimation Tests"
  print *

  n=30
  allocate(l_d(n,n),u_d(n),v_d(n),res_d(n),res_d1(n))
  call random_matrix_to(l_d)
  do j=1,n
     do k=j+1,n
        l_d(j,k)=0.0_dp
     end do
  end do
  sigma_d=lower_min_sv(l_d,u_d,v_d,res_d,tol,1000,error)
  tmp=norm2(res_d)
  call lower_left_multiply(l_d,v_d,res_d)
  res_d=res_d-sigma_d*u_d
  call lower_tr_left_multiply(l_d,u_d,res_d1)
  res_d1=res_d1-sigma_d*v_d
  test_name='Lower Min SV'
  call output_result(test_name,sigma_d,tmp,norm2(res_d),norm2(res_d1),tol1,error)

  sigma_d=lower_max_sv(l_d,u_d,v_d,res_d,tol,1000,error)
  tmp=norm2(res_d)
  call lower_left_multiply(l_d,v_d,res_d)
  res_d=res_d-sigma_d*u_d
  call lower_tr_left_multiply(l_d,u_d,res_d1)
  res_d1=res_d1-sigma_d*v_d
  test_name='Lower Max SV'
  call output_result(test_name,sigma_d,tmp,norm2(res_d),norm2(res_d1),tol1,error)

  l_d(5,5)=2.3e-40_dp
  l_d(10,10)=2.3e-40_dp
  sigma_d=lower_min_sv(l_d,u_d,v_d,res_d,tol,1000,error)
  tmp=norm2(res_d)
  call lower_left_multiply(l_d,v_d,res_d)
  res_d=res_d-sigma_d*u_d
  call lower_tr_left_multiply(l_d,u_d,res_d1)
  res_d1=res_d1-sigma_d*v_d
  test_name='Lower Min SV'
  call output_result(test_name,sigma_d,tmp,norm2(res_d),norm2(res_d1),tol1,error)
  deallocate(l_d,u_d,v_d,res_d,res_d1)

  !upper
  n=20
  allocate(r_d(n,n),u_d(n),v_d(n),res_d(n),res_d1(n))
  call random_matrix_to(r_d)
  do j=1,n
     do k=1,j-1
        r_d(j,k)=0.0_dp
     end do
  end do
  sigma_d=upper_min_sv(r_d,u_d,v_d,res_d,tol,1000,error)
  tmp=norm2(res_d)
  call upper_left_multiply(r_d,v_d,res_d)
  res_d=res_d-sigma_d*u_d
  call upper_tr_left_multiply(r_d,u_d,res_d1)
  res_d1=res_d1-sigma_d*v_d
  test_name='Upper Min SV'
  call output_result(test_name,sigma_d,tmp,norm2(res_d),norm2(res_d1),tol1,error)

  sigma_d=upper_max_sv(r_d,u_d,v_d,res_d,tol,1000,error)
  tmp=norm2(res_d)
  call upper_left_multiply(r_d,v_d,res_d)
  res_d=res_d-sigma_d*u_d
  call upper_tr_left_multiply(r_d,u_d,res_d1)
  res_d1=res_d1-sigma_d*v_d

  test_name='Upper Max SV'
  call output_result(test_name,sigma_d,tmp,norm2(res_d),norm2(res_d1),tol1,error)

  r_d(5,5)=2.3e-40_dp
  r_d(10,10)=2.3e-40_dp
  sigma_d=upper_min_sv(r_d,u_d,v_d,res_d,tol,1000,error)
  tmp=norm2(res_d)
  call upper_left_multiply(r_d,v_d,res_d)
  res_d=res_d-sigma_d*u_d
  call upper_tr_left_multiply(r_d,u_d,res_d1)
  res_d1=res_d1-sigma_d*v_d

  test_name='Upper Min SV'
  call output_result(test_name,sigma_d,tmp,norm2(res_d),norm2(res_d1),tol1,error)
  deallocate(r_d,u_d,v_d,res_d,res_d1)

  print *
  print *, "--------------------------------"
  print *
  print *, "Complex Triangular Condition Estimation Tests"
  print *
  n=30
  allocate(l_z(n,n),u_z(n),v_z(n),res_z(n),res_z1(n))
  call random_matrix_to(l_z)
  do j=1,n
     do k=j+1,n
        l_z(j,k)=(0.0_dp,0.0_dp)
     end do
  end do

  sigma_z=lower_min_sv(l_z,u_z,v_z,res_z,1.0e-14_dp,1000,error)

  tmp=norm2(res_z)
  call lower_left_multiply(l_z,v_z,res_z)
  res_z=res_z-sigma_z*u_z
  call lower_tr_left_multiply(l_z,u_z,res_z1)
  res_z1=res_z1-sigma_z*v_z
  test_name='Lower Min SV'
  call output_result(test_name,sigma_z,tmp,norm2(res_z),norm2(res_z1),tol1,error)

  sigma_z=lower_max_sv(l_z,u_z,v_z,res_z,tol,1000,error)
  tmp=norm2(res_z)
  call lower_left_multiply(l_z,v_z,res_z)
  res_z=res_z-sigma_z*u_z
  call lower_tr_left_multiply(l_z,u_z,res_z1)
  res_z1=res_z1-sigma_z*v_z
  test_name='Lower Max SV'
  call output_result(test_name,sigma_z,tmp,norm2(res_z),norm2(res_z1),tol1,error)

  l_z(5,5)=(2.3e-40_dp,5e-40_dp)
  l_z(10,10)=(2.3e-40_dp,5e-40_dp)
  sigma_z=lower_min_sv(l_z,u_z,v_z,res_z,1.0e-14_dp,1000,error)
  tmp=norm2(res_z)
  call lower_left_multiply(l_z,v_z,res_z)
  res_z=res_z-sigma_z*u_z
  call lower_tr_left_multiply(l_z,u_z,res_z1)
  res_z1=res_z1-sigma_z*v_z
  test_name='Lower Min SV'
  call output_result(test_name,sigma_z,tmp,norm2(res_z),norm2(res_z1),tol1,error)
  deallocate(l_z,u_z,v_z,res_z,res_z1)

  !upper
  n=20
  allocate(r_z(n,n),u_z(n),v_z(n),res_z(n),res_z1(n))
  call random_matrix_to(r_z)
  do j=1,n
     do k=1,j-1
        r_z(j,k)=0.0_dp
     end do
  end do
  sigma_z=upper_min_sv(r_z,u_z,v_z,res_z,tol,1000,error)
  tmp=norm2(res_z)
  call upper_left_multiply(r_z,v_z,res_z)
  res_z=res_z-sigma_z*u_z
  call upper_tr_left_multiply(r_z,u_z,res_z1)
  res_z1=res_z1-sigma_z*v_z
  test_name='Upper Min SV'
  call output_result(test_name,sigma_z,tmp,norm2(res_z),norm2(res_z1),tol1,error)

  sigma_z=upper_max_sv(r_z,u_z,v_z,res_z,tol,1000,error)
  tmp=norm2(res_z)
  call upper_left_multiply(r_z,v_z,res_z)
  res_z=res_z-sigma_z*u_z
  call upper_tr_left_multiply(r_z,u_z,res_z1)
  res_z1=res_z1-sigma_z*v_z
  test_name='Upper Max SV'
  call output_result(test_name,sigma_z,tmp,norm2(res_z),norm2(res_z1),tol1,error)

  r_z(5,5)=(2.3e-40_dp,5e-40_dp)
  r_z(10,10)=(2.3e-40_dp,5e-40_dp)
  sigma_z=upper_min_sv(r_z,u_z,v_z,res_z,tol,1000,error)
  tmp=norm2(res_z)
  call upper_left_multiply(r_z,v_z,res_z)
  res_z=res_z-sigma_z*u_z
  call upper_tr_left_multiply(r_z,u_z,res_z1)
  res_z1=res_z1-sigma_z*v_z
  test_name='Upper Min SV'
  call output_result(test_name,sigma_z,tmp,norm2(res_z),norm2(res_z1),tol1,error)
  deallocate(r_z,u_z,v_z,res_z,res_z1)
  print *

contains

  subroutine output_result(name,sv,res1,res2,res3,bnd,error)
    character(len=*) :: name
    real(kind=dp) :: bnd, sv, res1, res2, res3
    type(error_info) :: error
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       if (res1 < bnd .and. res2 < bnd .and. res3 < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt_sv) name, sv, res1, res2, res3, test_result
    end if
  end subroutine output_result

end program test_cond_triangular


function gunc(x)
real*8::x,gunc
gunc=exp(x)
end

program aa
implicit none
external gunc
real*8::a,b,gunc,y
integer*4::n
n=2
a=0.
b=1.
call intgausscuadr2do(gunc,a,b,n,y)

print*, y

end program

subroutine intgausscuadr2do(func,a,b,n,y)
!tendra n+1 puntos, devuelve un valor y
implicit none
real*8::func,a,b,y
REAL*8,ALLOCATABLE,DIMENSION(:)::x,xx,w
integer*4::n,i
allocate(x(n+1),xx(n+1),w(n+1))
if (n==0) then
x(1)=0.
w(1)=2.
else if (n==1) then
x(1)=-(1/3)**(1/2)
x(2)=(1/3)**(1/2)
w(1)=1.
w(2)=1.
else if (n==2) then
x(1)=-(3/5)**(1/2)
x(2)=0.
x(3)=(3/5)**(1/2)
w(1)=5/9.
w(2)=8./9
w(3)=5/9.
end if
!cambio de intervalo
do i=1,n+1
xx(i)=((b-a)/2)*x(i)+((b+a)/2)
end do
y=0
do i=1,n+1
y=y+w(i)*func(xx(i))
end do
y=((b-a)/2)*y
end subroutine


      program p2
      implicit none

      integer fib, fib_last, temp, total
      fib = 1
      fib_last = 1
      total = 0

      do while (fib .lt. 4000000)
            temp = fib
            fib = fib + fib_last
            fib_last = temp

            if (mod(fib, 2) .eq. 0) then
                total = total + fib
            endif
      enddo

      print *, total

      end


!=======================================================================
! Created by
!     Keurfon Luu <keurfon.luu@mines-paristech.fr>
!     MINES ParisTech - Centre de Géosciences
!     PSL - Research University
!=======================================================================

module bspline

  use omp_lib

  implicit none

contains

  recursive function deboor(i, k, x, t) result(db)
    real :: db
    integer, intent(in) :: i, k
    real, intent(in) :: x
    real, dimension(:), intent(in) :: t
    real :: A1, A2

    if ( k .eq. 1 ) then
      if ( x .ne. t(size(t)) ) then
        if ( ( x .ge. t(i) ) .and. ( x .lt. t(i+1) ) ) then
          db = 1.
        else
          db = 0.
        end if
      else
        if ( ( x .ge. t(i) ) .and. ( x .le. t(i+1) ) ) then
          db = 1.
        else
          db = 0.
        end if
      end if
    else
      if ( t(i+k-1) - t(i) .ne. 0. ) then
        A1 = ( x - t(i) ) / ( t(i+k-1) - t(i) )
      else
        A1 = 0.
      end if
      if ( t(i+k) - t(i+1) .ne. 0. ) then
        A2 = ( t(i+k) - x ) / ( t(i+k) - t(i+1) )
      else
        A2 = 0.
      end if
      db = A1 * deboor(i, k-1, x, t) + A2 * deboor(i+1, k-1, x, t)
    end if
    return
  end function deboor

  subroutine bsplrep1(x, y, xq, yq, n, nq, order)
    integer, intent(in) :: n, nq
    real, intent(in) :: x(n), y(n)
    real, intent(out) :: xq(nq), yq(nq)
    integer, intent(in), optional :: order
    integer :: i, iq, j, k
    real :: w
    real, dimension(:), allocatable :: t, t1, t2, t3, y1

    k = 4
    if ( present(order) ) k = order

    allocate(t1(k-1), t3(k-1))
    xq = 0.
    yq = 0.
    t1 = 0.
    t2 = 1. / float(n-k+1) * [ ( i-1, i = 1, n-k+2 ) ]
    t3 = 1.
    t = [ t1, t2, t3 ]
    y1 = 1. / float(nq-1) * [ ( i-1, i = 1, nq ) ]

    do iq = 1, nq
      j = max( k, maxloc( y1(iq) - t, 1, mask = y1(iq) .le. t ) - 1 )
      do i = j-k+1, j
        w = deboor(i, k, y1(iq), t)
        xq(iq) = xq(iq) + x(i) * w
        yq(iq) = yq(iq) + y(i) * w
      end do
    end do
    return
  end subroutine bsplrep1

  function spline1(x, y, xq, n, nq) result(yq)
    integer, intent(in) :: n, nq
    real, intent(in) :: x(n), y(n), xq(nq)
    integer :: i, x1
    real :: yq(nq)
    real, dimension(:), allocatable :: w, h, z, a, b, c, d

    allocate(w(n-1), h(n-1), z(n), a(n-1), b(n-1), c(n-1), d(n-1))

    ! Compute h and b
    do i = 1, n-1
      w(i) = x(i+1) - x(i)
      h(i) = ( y(i+1) - y(i) ) / w(i)
    end do

    ! Compute z
    z(1) = 0.
    do i = 1, n-2
      z(i+1) = 3. * ( h(i+1) - h(i) ) / ( w(i+1) + w(i) )
    end do
    z(n) = 0.

    ! Basis functions
    do i = 1, n-1
      a(i) = ( z(i+1) - z(i) ) / ( 6. * w(i) )
      b(i) = 0.5 * z(i)
      c(i) = h(i) - w(i) * ( z(i+1) + 2.*z(i) ) / 6.
      d(i) = y(i)
    end do

    ! Evaluate
    do i = 1, nq
      x1 = max( 1, minloc( xq(i) - x, 1, mask = xq(i) .gt. x) )
      yq(i) = d(x1) + ( xq(i) - x(x1) ) &
              * ( c(x1) + ( xq(i) - x(x1) ) &
              * ( b(x1) + ( xq(i) - x(x1) ) &
              * a(x1) ) )
    end do
    return
  end function spline1

  function bspline1(x, y, xq, n, nq, order) result(yq)
    integer, intent(in) :: n, nq
    real, intent(in) :: x(n), y(n), xq(nq)
    integer, intent(in), optional :: order
    integer :: k
    real :: yq(nq)
    real, dimension(:), allocatable :: bspl_x, bspl_y

    k = 4
    if ( present(order) ) k = order

    allocate(bspl_x(nq), bspl_y(nq))
    call bsplrep1(x, y, bspl_x, bspl_y, n, nq, k)
    yq = spline1(bspl_x, bspl_y, xq, nq, nq)
    return
  end function bspline1

  function bspline2(x, y, z, xq, yq, m, n, mq, nq, order, n_threads) result(zq)
    integer, intent(in) :: m, n, mq, nq
    real, intent(in) :: x(n), y(m), z(m,n), xq(mq,nq), yq(mq,nq)
    integer, intent(in), optional :: order, n_threads
    integer :: i, k
    real :: zq(mq,nq), tmp(m,nq)

    if ( present(n_threads) ) call omp_set_num_threads(n_threads)

    k = 4
    if ( present(order) ) k = order

    !$omp parallel default(shared)
    !$omp do schedule(runtime)
    do i = 1, m
      tmp(i,:) = bspline1(x, z(i,:), xq(i,:), n, nq, k)
    end do
    !$omp end parallel

    !$omp parallel default(shared)
    !$omp do schedule(runtime)
    do i = 1, nq
      zq(:,i) = bspline1(y, tmp(:,i), yq(:,i), m, mq, k)
    end do
    !$omp end parallel
    return
  end function bspline2

end module bspline


      SUBROUTINE polint(xa,ya,n,x,y,dy)
      ! Polynomial interpolation. Copied form "Numerical Recipes in
      ! FORTRAN 77"
      !
      ! Bo Terp Paulsen, botp@mek.dtu.dk

      INTEGER n,NMAX
      INTEGER, PARAMETER :: long=selected_real_kind(12,99)
      REAL(KIND=long) dy,x,y,xa(n),ya(n)
      PARAMETER (NMAX=10) ! Largest anticipated value of n.
      !Given arrays xa and ya, each of length n, and given a value x, this routine
      !returns a value y, and an error estimate dy. If P (x) is the polynomial of
      !degree N − 1 such that P (xai) = yai , i = 1, . . . , n, then the returned
      !value y = P (x ).
      INTEGER i,m,ns
      REAL(KIND=long) den,dif,dift,ho,hp,w,c(NMAX),d(NMAX)

      ns=1
      dif = abs(x-xa(1))
      DO i=1,n  !Here we find the index ns of the closest table entry,
          dift=abs(x-xa(i))

          IF (dift.lt.dif) THEN
              ns=i
              dif=dift
          ENDIF

          c(i)=ya(i) !and initialize the tableau of c’s and d’s.
          d(i)=ya(i)
      ENDDO

      y=ya(ns) !This is the initial approximation to y.
      ns=ns-1

      DO m=1,n-1 !for each column of the tableau, we loop over the current c’s and d’s and update them.
          DO i=1,n-m
              ho=xa(i)-x
              hp=xa(i+m)-x
              w=c(i+1)-d(i)
              den=ho-hp
              IF(den.eq.0.)then
                 print*, 'failure in polint'
                 stop
              end if
              !This error can occur only if two input xa’s are (to within roundoff) identical.
              den=w/den
              d(i)=hp*den ! Here the c’s and d’s are updated.
              c(i)=ho*den
          ENDDO
          IF (2*ns.lt.n-m)THEN
          !After each column in the tableau is completed, we decide
          !which correction, c or d, we want to add to our accu-
          !mulating value of y, i.e., which path to take through
          !the tableau—forking up or down. We do this in such a
          !way as to take the most “straight line” route through the
          !tableau to its apex, updating ns accordingly to keep track
          !of where we are. This route keeps the partial approxima-
          !tions centered (insofar as possible) on the target x. The
          !last dy added is thus the error indication.
              dy=c(ns+1)
          ELSE
              dy=d(ns)
              ns=ns-1
          ENDIF
      y=y+dy
      ENDDO
      RETURN
      END

      SUBROUTINE polin2(x1a,x2a,ya,m,n,x1,x2,y,dy)
      INTEGER m,n,NMAX,MMAX
      INTEGER, PARAMETER :: long=selected_real_kind(12,99)
      REAL(KIND=long) dy,x1,x2,y,x1a(m),x2a(n),ya(m,n)
      PARAMETER (NMAX=20,MMAX=20)! Maximum expected values of n and m.
    !C USES polint
      !Given arrays x1a(1:m) and x2a(1:n) of independent variables, and an m by n array
      !of function values ya(1:m,1:n), tabulated at the grid points defined by x1a and
      !x2a; and given values x1 and x2 of the independent variables; this routine
      !returns an interpolated function value y, and an accuracy indication dy
      !(based only on the interpolation in the x1 direction, however).
      INTEGER j,k
      REAL(kind=long) ymtmp(MMAX),yntmp(NMAX)
      DO j=1,m
         DO k=1,n
            yntmp(k)=ya(j,k)
         ENDDO
         call polint(x2a,yntmp,n,x2,ymtmp(j),dy)
      ENDDO
         call polint(x1a,ymtmp,m,x1,y,dy)
      return
      END


MODULE m_util
   USE m_juDFT
!     error and warning codes for intgrf function
   INTEGER, PARAMETER :: NO_ERROR = 0
   INTEGER, PARAMETER :: NEGATIVE_EXPONENT_ERROR = 2
!     return type of the pure intgrf function

   INTERFACE derivative
      MODULE PROCEDURE derivative_t, derivative_nt
   END INTERFACE

CONTAINS

    ! Calculates Gaunt coefficients, i.e. the integrals of three spherical harmonics
    ! integral ( conjg(Y(l1,m1)) * Y(l2,m2) * conjg(Y(l3,m3)) )
    ! They are also the coefficients C(l1,l2,l3,m1,m2,m3) in
    ! conjg(Y(l1,m1)) * Y(l2,m2) = sum(l3,m3) C(l1,l2,l3,m1,m2,m3) Y(l3,m3)
    ! fac contains factorial up to maxfac, i.e. fac(i)= i!
    ! sfac contains square root of fac, i.e. sfac(i)= sqrt(i!)

   FUNCTION gaunt(l1, l2, l3, m1, m2, m3, maxfac, fac, sfac)

      USE m_constants, ONLY: pimach

      IMPLICIT NONE

      REAL                  :: gaunt
      INTEGER, INTENT(IN) :: l1, l2, l3, m1, m2, m3, maxfac
      REAL  , INTENT(IN) :: fac(0:maxfac)
      REAL  , INTENT(IN) :: sfac(0:maxfac)

      gaunt = 0
      IF (m3 /= m2 - m1) RETURN
      IF (abs(m1) > l1) RETURN
      IF (abs(m2) > l2) RETURN
      IF (abs(m3) > l3) RETURN
      IF (l3 < abs(l1 - l2) .OR. l3 > l1 + l2) RETURN
      gaunt = (-1)**(m1 + m3)* &
              sqrt((2*l1 + 1)*(2*l2 + 1)*(2*l3 + 1)/pimach()/4)* &
              wigner3j(l1, l2, l3, -m1, m2, -m3, maxfac, fac, sfac)* &
              wigner3j(l1, l2, l3, 0, 0, 0, maxfac, fac, sfac)
   END FUNCTION gaunt

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

!     Calculates the Wigner 3j symbols using Racah's formula

   FUNCTION wigner3j(l1, l2, l3, m1, m2, m3, maxfac, fac, sfac)

      IMPLICIT NONE

      REAL                  :: wigner3j
      INTEGER, INTENT(IN) :: l1, l2, l3, m1, m2, m3, maxfac
      REAL  , INTENT(IN) :: fac(0:maxfac)
      REAL  , INTENT(IN) :: sfac(0:maxfac)
!     - local -
      INTEGER               :: tmin, tmax, t, f1, f2, f3, f4, f5

      wigner3j = 0

!     The following IF clauses should be in the calling routine and commented here.
!      if(-m3.ne.m1+m2)  return
!      if(abs(m1).gt.l1) return
!      if(abs(m2).gt.l2) return
!      if(abs(m3).gt.l3) return
!      if(l3.lt.abs(l1-l2).or.l3.gt.l1+l2) return

      f1 = l3 - l2 + m1
      f2 = l3 - l1 - m2
      f3 = l1 + l2 - l3
      f4 = l1 - m1
      f5 = l2 + m2
      tmin = max(0, -f1, -f2) ! The arguments to fac (see below)
      tmax = min(f3, f4, f5)  ! must not be negative.

! The following line is only for testing and should be removed at a later time.
      IF (tmax - tmin /= min(l1 + m1, l1 - m1, l2 + m2, l2 - m2, l3 + m3, l3 - m3, &
                             l1 + l2 - l3, l1 - l2 + l3, -l1 + l2 + l3)) &
         call judft_error("wigner3j: Number of terms incorrect.")

      IF (tmin <= tmax) THEN
         DO t = tmin, tmax
            wigner3j = wigner3j + (-1)**t/ &
                       (fac(t)*fac(f1 + t)*fac(f2 + t) &
                        *fac(f3 - t)*fac(f4 - t)*fac(f5 - t))
         END DO
         wigner3j = wigner3j*(-1)**(l1 - l2 - m3)*sfac(l1 + l2 - l3) &
                    *sfac(l1 - l2 + l3)*sfac(-l1 + l2 + l3) &
                    /sfac(l1 + l2 + l3 + 1)* &
                    sfac(l1 + m1)*sfac(l1 - m1)* &
                    sfac(l2 + m2)*sfac(l2 - m2)* &
                    sfac(l3 + m3)*sfac(l3 - m3)
      END IF
   END FUNCTION wigner3j

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

!     Calculates the primitive of f, on grid(itypein):

!                   r
!     primf(r) = integral f(r') dr'   ( r = grid point )
!                   0

!     If itypein is negative, the primitive

!                   R
!     primf(r) = integral f(r') dr'   ( R = MT sphere radius )
!                   r

!     is calculated instead.

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

!     Fast calculation of primitive.
!     Only Lagrange integration is used

   SUBROUTINE primitivef(primf, fin, rmsh, dx, jri, jmtd, itypein, ntype)

      USE m_constants

      IMPLICIT NONE

!     - scalars -
      INTEGER, INTENT(IN)   :: itypein, jmtd, ntype

!     - arrays -
      INTEGER, INTENT(IN)   :: jri(ntype)
      REAL, INTENT(OUT)  :: primf(jri(abs(itypein)))
      REAL, INTENT(IN)   :: fin(jri(abs(itypein)))
      REAL, INTENT(IN)   :: rmsh(jmtd, ntype), dx(ntype)

!     - local scalars -
      INTEGER                 :: itype, n, i, n0
      REAL                    :: h, x, h1
      REAL                    :: intgr, r1, a, dr

!     - local arrays -
      REAL                    :: fr(7)
      REAL                    :: f(jri(abs(itypein)))
      REAL                    :: r(jri(abs(itypein)))
      REAL, PARAMETER       :: lagrange(7, 6) = reshape( &
      (/19087., 65112., -46461., 37504., -20211., 6312., -863., &
      -863., 25128., 46989., -16256., 7299., -2088., 271., &
      &               271., -2760., 30819., 37504., -6771., 1608., -191., &
      -191., 1608., -6771., 37504., 30819., -2760., 271., &
      &               271., -2088., 7299., -16256., 46989., 25128., -863., &
      -863., 6312., -20211., 37504., -46461., 65112., 19087./), &
      (/7, 6/))

      itype = abs(itypein)

      primf = 0

      n = jri(itype)
      h = dx(itype)

      IF (itypein > 0) THEN
         r1 = rmsh(1, itype)      ! perform outward integration
         f = fin                ! (from 0 to r)
      ELSE
         r1 = rmsh(jri(itype), itype)         ! perform inward integration
         h = -h                             ! (from MT sphere radius to r)
         f = fin(n:1:-1)                    !
      END IF

! integral from 0 to r1 approximated by leading term in power series expansion (only if h>0)
      IF (h > 0 .AND. f(1)*f(2) > 1e-10) THEN
         IF (f(2) == f(1)) THEN
            intgr = r1*f(1)
         ELSE
            x = (f(3) - f(2))/(f(2) - f(1))
            a = (f(2) - x*f(1))/(1 - x)
            x = log(x)/h
            IF (x < 0) THEN
               IF (x > -1) WRITE (oUnit, '(A,ES9.1)') &
                  '+intgr: Warning! Negative &exponent x in'// &
                  'extrapolation a+c*r**x:', x
               IF (x <= -1) WRITE (oUnit, '(A,ES9.1)') 'intgr: Negative exponent,'// &
                  'x in extrapolation a+c*r**x:', x
               IF (x <= -1) call judft_error("intgr:Negative exponent x in extrapolation")
            END IF
            intgr = r1*(f(1) + x*a)/(x + 1)
         END IF
      ELSE
         intgr = 0
      END IF

      primf(1) = intgr
      dr = exp(h)
      r(1) = r1
      n0 = 1
      h1 = h/60480

! Lagrange integration from r(n0) to r(n0+5)
1     DO i = 2, 7
         r(i) = r(i - 1)*dr
      END DO
      fr = f(n0:n0 + 6)*r(:7)
      DO i = 1, 6
         intgr = intgr + h1*dot_product(lagrange(:, i), fr)
         IF (primf(n0 + i) == 0) primf(n0 + i) = intgr ! avoid double-definition
      END DO
      IF (n0 + 12 <= n) THEN
         r(1) = r(7)
         n0 = n0 + 6
         GOTO 1
      ELSE IF (n0 + 6 < n) THEN
         r(1) = r(n - 5 - n0)
         n0 = n - 6
         intgr = primf(n - 6)
         GOTO 1
      END IF

      IF (itypein < 0) THEN    !
         primf = -primf(n:1:-1) ! Inward integration
      END IF                    !

   END SUBROUTINE primitivef

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

! unction modulo1 maps kpoint into first BZ
   FUNCTION modulo1(kpoint, nkpt3)

      USE m_constants

      IMPLICIT NONE

      INTEGER, INTENT(IN)  :: nkpt3(3)
      REAL  , INTENT(IN)  :: kpoint(3)
      REAL                  :: modulo1(3)
      INTEGER               :: help(3)

      modulo1 = kpoint*nkpt3
      help = nint(modulo1)
      IF (any(abs(help - modulo1) > 1e-10)) THEN
         WRITE (oUnit, '(A,F5.3,2('','',F5.3),A)') 'modulo1: argument (', kpoint, &
            ') is not an element of the k-point set.'
         CALL juDFT_error( &
            'modulo1: argument not an element of k-point set.', &
            calledby='util:modulo1')
      END IF
      modulo1 = modulo(help, nkpt3)*1.0/nkpt3

   END FUNCTION modulo1

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

!     Returns derivative of f in df.

   SUBROUTINE derivative_t(df, f, atoms, itype)
      USE m_types
      IMPLICIT NONE
      REAL, INTENT(IN)   ::   f(:)
      REAL, INTENT(OUT)  ::   df(:)
      TYPE(t_atoms), INTENT(IN)::atoms
      INTEGER, INTENT(IN)   ::   itype

      call derivative_nt(df, f, atoms%jmtd, atoms%jri, atoms%dx, atoms%rmsh, &
                         atoms%ntype, itype)
   END SUBROUTINE

   SUBROUTINE derivative_nt(df, f, jmtd, jri, dx, rmsh, ntype, itype)

      IMPLICIT NONE

      INTEGER, INTENT(IN)   :: ntype, itype, jmtd
      INTEGER, INTENT(IN)   :: jri(ntype)
      REAL, INTENT(IN)   :: dx(ntype), rmsh(jmtd, ntype)
      REAL, INTENT(IN)   :: f(jri(itype))
      REAL, INTENT(OUT)  :: df(jri(itype))
      REAL                   :: x, h, r, d21, d32, d43, d31, d42, d41, df1, df2
      INTEGER                :: i, n

      n = jri(itype)
      h = dx(itype)
      r = rmsh(1, itype)
! use power series expansion a+c**x for first point
      IF (f(2) == f(1)) THEN
         df(1) = 0.0
      ELSE
         x = (f(3) - f(2))/(f(2) - f(1))
         df(1) = (f(2) - f(1))/(x - 1)*log(x)/h/r
      END IF
! use Lagrange interpolation of 3rd order for all other points (and averaging)
      d21 = r*(exp(h) - 1); d32 = d21*exp(h); d43 = d32*exp(h)
      d31 = d21 + d32; d42 = d32 + d43
      d41 = d31 + d43
      df(2) = -d32*d42/(d21*d31*d41)*f(1) &
              + (1.0/d21 - 1.0/d32 - 1.0/d42)*f(2) &
              + d21*d42/(d31*d32*d43)*f(3) &
              - d21*d32/(d41*d42*d43)*f(4)
      df1 = d32*d43/(d21*d31*d41)*f(1) &
            - d31*d43/(d21*d32*d42)*f(2) &
            + (1.0/d31 + 1.0/d32 - 1.0/d43)*f(3) &
            + d31*d32/(d41*d42*d43)*f(4)
      DO i = 3, n - 2
         d21 = d32; d32 = d43; d43 = d43*exp(h)
         d31 = d42; d42 = d42*exp(h)
         d41 = d41*exp(h)
         df2 = -d32*d42/(d21*d31*d41)*f(i - 1) &
               + (1.0/d21 - 1.0/d32 - 1.0/d42)*f(i) &
               + d21*d42/(d31*d32*d43)*f(i + 1) &
               - d21*d32/(d41*d42*d43)*f(i + 2)
         df(i) = (df1 + df2)/2
         df1 = d32*d43/(d21*d31*d41)*f(i - 1) &
               - d31*d43/(d21*d32*d42)*f(i) &
               + (1.0/d31 + 1.0/d32 - 1.0/d43)*f(i + 1) &
               + d31*d32/(d41*d42*d43)*f(i + 2)
      END DO
      df(n - 1) = df1
      df(n) = -d42*d43/(d21*d31*d41)*f(n - 3) &
              + d41*d43/(d21*d32*d42)*f(n - 2) &
              - d41*d42/(d31*d32*d43)*f(n - 1) &
              + (1.0/d41 + 1.0/d42 + 1.0/d43)*f(n)

   END SUBROUTINE derivative_nt

!     Calculates the spherical Bessel functions of orders 0 to l at x
!     by backward recurrence using j_l(x) = (2l+3)/x j_l+1(x) - j_l+2(x) .
!     (Starting points are calculated according to Zhang, Min,
!      "Computation of Special Functions".)
   pure SUBROUTINE sphbessel(sphbes, x, l)

      IMPLICIT NONE

      INTEGER, INTENT(IN)    :: l
      REAL  , INTENT(IN)    :: x
      REAL  , INTENT(INOUT) :: sphbes(0:l)
      REAL                     :: s0, s1, f, f0, f1, cs
      INTEGER                  :: ll, lsta, lmax, msta2

!      IF( x.lt.0 ) THEN
!        call judft_error("sphbes: negative argument (bug?).")
!      ELSE
      IF (x == 0) THEN
         sphbes(0) = 1.0
         DO ll = 1, l
            sphbes(ll) = 0.0
         END DO
         RETURN
      ENDIF
      sphbes(0) = sin(x)/x
      IF (l == 0) RETURN
      sphbes(1) = (sphbes(0) - cos(x))/x
!       IF(l.le.1) RETURN
      s0 = sphbes(0)
      s1 = sphbes(1)
      lsta = lsta1(x, 200)      !
      lmax = l                 !
      IF (lsta < l) THEN       !
         lmax = lsta ! determine starting point lsta
         sphbes(lmax + 1:) = 0.0  ! for backward recurrence
      ELSE                     !
         lsta = lsta2(x, l, 15)   !
      END IF                    !
      f0 = 0.0                                                      !
      f1 = 1e-100                                                   !
      DO ll = lsta, 0, -1                                             ! backward recurrence
         f = f1/x*(2*ll + 3) - f0; IF (ll <= lmax) sphbes(ll) = f ! with arbitrary start values
         f0 = f1                                                     !
         f1 = f                                                      !
      END DO                                                        !
      IF (abs(s0) > abs(s1)) THEN; cs = s0/f   !
      ELSE; cs = s1/f0  ! scale to correct values
      END IF                                      !
      sphbes = cs*sphbes                        !

   CONTAINS

!     Test starting point
      PURE FUNCTION lsta0(x, mp)

         IMPLICIT NONE

         INTEGER               :: lsta0
         INTEGER, INTENT(IN) :: mp
         REAL  , INTENT(IN) :: x
         REAL                  :: f, lgx

         lgx = log10(x)
         lsta0 = 0
         f = lgx
         DO WHILE (f > -mp)
            lsta0 = lsta0 + 1
            f = f + lgx - log10(2.0*lsta0 + 1)
         END DO
      END FUNCTION lsta0

!     Returns starting point lsta1 for backward recurrence such that sphbes(lsta1) approx. 10^(-mp).
      PURE FUNCTION lsta1(x, mp)

         IMPLICIT NONE

         INTEGER               :: lsta1
         INTEGER, INTENT(IN) :: mp
         REAL  , INTENT(IN) :: x
         REAL                  :: f0, f1, f
         INTEGER               :: n0, n1, nn, it

         n0 = int(1.1*x) + 1
         f0 = envj(n0, x) - mp
         n1 = n0 + 5
         f1 = envj(n1, x) - mp
         DO it = 1, 20
            nn = n1 - (n1 - n0)/(1.0 - f0/f1)
            f = envj(nn, x) - mp
            IF (abs(nn - n1) < 1) EXIT
            n0 = n1
            f0 = f1
            n1 = nn
            f1 = f
         END DO
         lsta1 = nn
      END FUNCTION lsta1

!     Returns the starting point lsta2 for backward recurrence such that all sphbes(l) have mp significant digits.
      PURE FUNCTION lsta2(x, l, mp)

         IMPLICIT NONE

         INTEGER               :: lsta2
         INTEGER, INTENT(IN) :: l, mp
         REAL  , INTENT(IN) :: x
         REAL                  :: f0, f1, f, hmp, ejn, obj
         INTEGER               :: n0, n1, nn, it

         hmp = 0.5*mp
         ejn = envj(l, x)
         IF (ejn <= hmp) THEN
            obj = mp
            n0 = int(1.1*x) + 1
         ELSE
            obj = hmp + ejn
            n0 = l
         END IF
         f0 = envj(n0, x) - obj
         n1 = n0 + 5
         f1 = envj(n1, x) - obj
         DO it = 1, 20
            nn = n1 - (n1 - n0)/(1.0 - f0/f1)
            f = envj(nn, x) - obj
            IF (abs(nn - n1) < 1) EXIT
            n0 = n1
            f0 = f1
            n1 = nn
            f1 = f
         END DO
         lsta2 = nn + 10
      END FUNCTION lsta2

      PURE FUNCTION envj(l, x)

         IMPLICIT NONE

         REAL                  :: envj
         REAL  , INTENT(IN) :: x
         INTEGER, INTENT(IN) :: l

         envj = 0.5*log10(6.28*l) - l*log10(1.36*x/l)

      END FUNCTION envj

   END SUBROUTINE sphbessel

!     Returns the spherical harmonics Y_lm(^rvec)
!     for l = 0,...,ll in Y(1,...,(ll+1)**2).

   PURE SUBROUTINE harmonicsr(Y, rvec, ll)

      IMPLICIT NONE

      integer  , intent(in)  :: ll
      real  , intent(in)  :: rvec(3)
      complex, intent(out) :: Y((ll + 1)**2)
      complex               :: c
      real                    :: stheta, ctheta, sphi, cphi, r, rvec1(3)
      integer                 :: l, m, lm
      complex, parameter   :: img = (0.0, 1.0)

      Y(1) = 0.282094791773878
      IF (ll == 0) RETURN

      stheta = 0
      ctheta = 0
      sphi = 0
      cphi = 0
      r = norm2(rvec)
      IF (r > 1e-16) THEN
         rvec1 = rvec/r
         ctheta = rvec1(3)
         stheta = sqrt(rvec1(1)**2 + rvec1(2)**2)
         IF (stheta > 1e-16) THEN
            cphi = rvec1(1)/stheta
            sphi = rvec1(2)/stheta
         END IF
      ELSE
         Y(2:) = 0.0
         RETURN
      END IF

!     define Y,l,-l and Y,l,l
      r = Y(1)
      c = 1
      DO l = 1, ll
         r = r*stheta*sqrt(1.0 + 1.0/(2*l))
         c = c*(cphi + img*sphi)
         Y(l**2 + 1) = r*conjg(c)  ! l,-l
         Y((l + 1)**2) = r*c*(-1)**l ! l,l
      END DO

!     define Y,l,-l+1 and Y,l,l-1
      Y(3) = 0.48860251190292*ctheta
      DO l = 2, ll
         r = sqrt(2.0*l + 1)*ctheta
         Y(l**2 + 2) = r*Y((l - 1)**2 + 1) ! l,-l+1
         Y(l*(l + 2)) = r*Y(l**2)       ! l,l-1
      END DO

!     define Y,l,m, |m|<l-1
      DO l = 2, ll
         lm = l**2 + 2
         DO m = -l + 2, l - 2
            lm = lm + 1
            Y(lm) = sqrt((2.0*l + 1)/(l + m)/(l - m))*( &
                    sqrt(2.0*l - 1)*ctheta*Y(lm - 2*l) - &
                    sqrt((l + m - 1.0)*(l - m - 1)/(2*l - 3))*Y(lm - 4*l + 2))
         END DO
      END DO

   END SUBROUTINE harmonicsr

!     Returns the complex error function.
   FUNCTION cerf(z)

      USE m_constants, ONLY: pimach

      IMPLICIT NONE
      COMPLEX, INTENT(IN) ::  z
      COMPLEX             ::  cerf
      COMPLEX             ::  z1, z2, c, d, delta
      REAL                  ::  pi
      INTEGER               ::  i

      pi = pimach()
      z1 = z
      IF (real(z) < 0) z1 = -z1
      IF (real(z1) < 2.0) THEN ! McLaurin series
         z2 = z1**2
         i = 0
         c = z1
         cerf = z1
         DO
            i = i + 1
            c = -c*z2/i
            cerf = cerf + c/(2*i + 1)
            IF (abs(c/(2*i + 1)) < 1e-20) EXIT
         END DO
         cerf = cerf*2/sqrt(pi)
      ELSE ! continued fraction using Lentz's method
         d = 0.0
         c = z1
         cerf = z1
         i = 0
         DO
            i = i + 1
            c = 2*z1 + i/c
            d = (2*z1 + i*d)**(-1)
            delta = c*d
            cerf = cerf*delta
            IF (abs(1 - delta) < 1e-15) EXIT
            i = i + 1
            c = z1 + i/c
            d = (z1 + i*d)**(-1)
            delta = c*d
            cerf = cerf*delta
            IF (abs(1 - delta) < 1e-15) EXIT
            IF (i == 10000) &
               call judft_error("cerf: Lentz method not converged after 10000 steps.")
         END DO
         cerf = 1 - exp(-z1**2)/cerf/sqrt(pi)
      END IF
      IF (real(z) < 0) cerf = -cerf
   END FUNCTION cerf

   FUNCTION chr(int)

      IMPLICIT NONE

      CHARACTER(5) :: chr
      INTEGER        :: int

      WRITE (chr, '(I5)') int
   END FUNCTION chr

END MODULE m_util


! Legendre - Gauss quadrature ordinates and weights
!
! author ....... Jan Tomec
! copyright .... Copyright 2020, Project THREAD - University of Rijeka, Faculty of Civil Engineering
! credits ...... Jan Tomec, Gordan Jelenić
! license ...... GPL
! version ...... 1.0.0
! maintainer ... Jan Tomec
! email ........ jan.tomec@gradri.uniri.hr
! status ....... Development
! date ......... 06/05/2020
!
! ------------------------------------------------------------------------------

module legendre_gauss

	implicit none

	private

	public :: legauss

	contains

	! evaluate 1st shape function in given points (gauss points)
	pure subroutine legauss (n, x, w)

		implicit none

		integer, intent (in) :: n
		double precision, dimension (n), intent (out) :: x, w
		integer :: m, i, j
		double precision :: z, z1, p1, p2, p3, pp
		double precision, parameter :: TOL = 1.0D-30, PI = 4.0D0 * atan (1.0D0)

		m = (n + 1) / 2
		do i = 1, m
			z = cos (PI * (i-0.25D0) / (n+0.5D0))
			z1 = 0.0D0
			do while (abs (z - z1) .gt. TOL)
				p1 = 1.0D0
				p2 = 0.0D0
				do j = 1, n
					p3 = p2
					p2 = p1
					p1 = ((2.0D0 * j - 1.0D0) * z * p2 - (j - 1.0D0) * p3) / j
				end do
				pp = n * (z * p1 - p2) / (z * z - 1.0D0)
				z1 = z
				z = z1 - p1 / pp
			end do
			x (i) = -z
			x (n+1-i) = z
			w (i) = 2.0D0 / ((1.0D0 - z ** 2) * pp ** 2)
			w (n+1-i) = w(i)
		end do

	end subroutine legauss

end module


C$Procedure      CYLREC ( Cylindrical to rectangular )

      SUBROUTINE CYLREC ( R, LONG, Z,  RECTAN )

C$ Abstract
C
C      Convert from cylindrical to rectangular coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C      CONVERSION,  COORDINATES
C
C$ Declarations

      DOUBLE PRECISION    R
      DOUBLE PRECISION    LONG
      DOUBLE PRECISION    Z
      DOUBLE PRECISION    RECTAN ( 3 )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  -------------------------------------------------
C      R          I   Distance of a point from Z axis.
C      LONG       I   Angle (radians) of a point from XZ plane
C      Z          I   Height of a point above XY plane.
C      RECTAN     O   Rectangular coordinates of the point.
C
C$ Detailed_Input
C
C      R          Distance of the point of interest from Z axis.
C
C      LONG       Cylindrical angle (in radians) of the point of
C                 interest from XZ plane.
C
C      Z          Height of the point above XY plane.
C
C$ Detailed_Output
C
C      RECTAN     Rectangular coordinates of the point of interest.
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      This routine transforms the coordinates of a point from
C      cylindrical to rectangular coordinates.
C
C$ Examples
C
C     Below are two tables.
C
C     Listed in the first table (under R, LONG and Z ) are
C     cylindrical coordinate triples that approximately represent
C     points whose rectangular coordinates are taken from the set
C     {-1, 0, 1}.  (Angular quantities are given in degrees.)
C
C     The result of the code fragment
C
C          Use the SPICELIB routine CONVRT to convert the angular
C          quantities to radians
C
C          CALL CONVRT ( LONG, 'DEGREES', 'RADIANS', LONG )
C
C          CALL CYLREC ( R, LONG, Z, X )
C
C
C     are listed in the second parallel table under X(1), X(2) and X(3).
C
C
C       R         LONG     Z            X(1)       X(2)     X(3)
C       -------------------------       --------------------------
C       0.0000    0.0000   0.0000       0.0000     0.0000   0.0000
C       1.0000    0.0000   0.0000       1.0000     0.0000   0.0000
C       1.0000   90.0000   0.0000       0.0000     1.0000   0.0000
C       0.0000    0.0000   1.0000       0.0000     0.0000   1.0000
C       1.0000  180.0000   0.0000      -1.0000     0.0000   0.0000
C       1.0000  270.0000   0.0000       0.0000    -1.0000   0.0000
C       0.0000    0.0000  -1.0000       0.0000     0.0000  -1.0000
C       1.4142   45.0000   0.0000       1.0000     1.0000   0.0000
C       1.0000    0.0000   1.0000       1.0000     0.0000   1.0000
C       1.0000   90.0000   1.0000       0.0000     1.0000   1.0000
C       1.4142   45.0000   1.0000       1.0000     1.0000   1.0000
C
C
C$ Restrictions
C
C      None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.L. Taber      (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     cylindrical to rectangular
C
C-&

C$ Revisions
C
C-     Beta Version 1.0.1, 1-Feb-1989 (WLT)
C
C      Example section of header upgraded.
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION X
      DOUBLE PRECISION Y

C
C     Convert to rectangular coordinates, storing the results in
C     temporary variables.
C
      X         = R * DCOS(LONG)
      Y         = R * DSIN(LONG)

C
C     Move the results to the output variables.
C
      RECTAN(1) = X
      RECTAN(2) = Y
      RECTAN(3) = Z

      RETURN
      END


      DOUBLE PRECISION FUNCTION slZD (HA, DEC, PHI)
*+
*     - - -
*      Z D
*     - - -
*
*  HA, Dec to Zenith Distance (double precision)
*
*  Given:
*     HA     d     Hour Angle in radians
*     DEC    d     declination in radians
*     PHI    d     observatory latitude in radians
*
*  The result is in the range 0 to pi.
*
*  Notes:
*
*  1)  The latitude must be geodetic.  In critical applications,
*      corrections for polar motion should be applied.
*
*  2)  In some applications it will be important to specify the
*      correct type of hour angle and declination in order to
*      produce the required type of zenith distance.  In particular,
*      it may be important to distinguish between the zenith distance
*      as affected by refraction, which would require the "observed"
*      HA,Dec, and the zenith distance in vacuo, which would require
*      the "topocentric" HA,Dec.  If the effects of diurnal aberration
*      can be neglected, the "apparent" HA,Dec may be used instead of
*      the topocentric HA,Dec.
*
*  3)  No range checking of arguments is done.
*
*  4)  In applications which involve many zenith distance calculations,
*      rather than calling the present routine it will be more efficient
*      to use inline code, having previously computed fixed terms such
*      as sine and cosine of latitude, and perhaps sine and cosine of
*      declination.
*
*  P.T.Wallace   Starlink   3 April 1994
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION HA,DEC,PHI

      DOUBLE PRECISION SH,CH,SD,CD,SP,CP,X,Y,Z

      SH=SIN(HA)
      CH=COS(HA)
      SD=SIN(DEC)
      CD=COS(DEC)
      SP=SIN(PHI)
      CP=COS(PHI)
      X=CH*CD*SP-SD*CP
      Y=SH*CD
      Z=CH*CD*CP+SD*SP
      slZD=ATAN2(SQRT(X*X+Y*Y),Z)

      END