!==============================================================================!
  subroutine Acm(sol, x, b, prec, n_cycles, tol, fin_res, norm)
!------------------------------------------------------------------------------!
!   This is the nucleus of the Additive Correction Multigrid method.           !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Solver_Type), target :: sol
  real                      :: x(-sol % pnt_grid % n_bnd_cells :  &
                                  sol % pnt_grid % n_cells)
  real                      :: b( sol % pnt_grid % n_cells)  ! [A]{x}={b}
  character(len=80)         :: prec                          ! preconditioner
  integer                   :: n_cycles                      ! number of cycles
  real                      :: tol                           ! tolerance
  real                      :: fin_res                       ! final residual
  real, optional            :: norm                          ! normalization
!-----------------------------------[Locals]-----------------------------------!
  type(Grid_Type),   pointer :: grid
  type(Matrix_Type), pointer :: a
  type(Matrix_Type), pointer :: a_lev(:)
  type(Matrix_Type), pointer :: d_lev(:)
  type(Vector_Type), pointer :: x_lev(:)
  type(Vector_Type), pointer :: b_lev(:)
  type(Vector_Type), pointer :: p_lev(:)
  type(Vector_Type), pointer :: r_lev(:)
  integer                    :: lev, c, c_lev, lev_max, cyc
  integer                    :: n_iter, p_iter  ! requested and performed iters
  real                       :: res_rat         ! requested residual ratio
!==============================================================================!

  ! Take aliases first
  grid  => sol % pnt_grid
  a     => sol % a
  a_lev => sol % a_lev
  d_lev => sol % d_lev
  x_lev => sol % x_lev
  b_lev => sol % b_lev
  p_lev => sol % p_lev
  r_lev => sol % r_lev

  ! Set maximum number of levels to perform
  call Control_Mod_V_Cycle_Max_Grid_Levels(lev_max)
  lev_max = min(lev_max, grid % n_levels)

  ! Set number of smoothing iterations
  n_iter = 12  ! 10 or 12 seems to work the best
  call Control_Mod_V_Cycle_Number_Of_Smoothing_Iterations(n_iter)

  ! Set requested residual ration in the level
  res_rat = 0.0001
  call Control_Mod_V_Cycle_Residual_Ratio(res_rat)

  !-------------------------------------------!
  !                                           !
  !   Coarsen system matrix over all levels   !
  !                                           !
  !-------------------------------------------!
  call Acm_Coarsen_Matrix(sol)

  !---------------------------------!
  !   Simply copy the first level   !
  !---------------------------------!
  x_lev(1) % val(1:) = x(1:)
  b_lev(1) % val(1:) = b(1:)
  r_lev(1) % val(1:) = 0.0

  !------------------------------------!
  !                                    !
  !                                    !
  !   Solve on the finest level once   !
  !                                    !
  !    Solve    [A]{x} = b and         !
  !    Compute  {r} = {b} - [A]{x}     !
  !                                    !
  !                                    !
  !------------------------------------!
  call Cg_Level(1,               &  ! level
                a_lev(1),        &  ! system matrix
                d_lev(1),        &  ! preconditioning matrix
                x_lev(1) % val,  &  ! solution
                b_lev(1) % val,  &  ! right hand side
                p_lev(1) % val,  &  ! p1 vector from cg algorith
                r_lev(1) % val,  &  ! residual vector
                prec,            &  ! preconditioner
                1,               &  ! cycle
                n_iter,          &  ! max iterations
                p_iter,          &  ! performed iterations
                tol,             &  ! tolerance
                res_rat,         &  ! residual ratio
                fin_res)            ! final residual

  !--------------------!
  !                    !
  !                    !
  !   Start V cycles   !
  !                    !
  !                    !
  !--------------------!
  do cyc = 1, n_cycles

    !-------------------------!
    !                         !
    !   Go down the V cycle   !
    !                         !
    !-------------------------!
    do lev = 2, lev_max

      !-----------------+
      !   Restriction   !                    !
      !-----------------+--------------------!
      !     +---+---+          +-------+     !
      !     |   |   |          |       |     !
      !     +---+---+   =-->   |       |     !
      !     |   |   |          |       |     !
      !     +---+---+          +-------+     !
      !       lev-1               lev        !
      !--------------------------------------!
      if(p_iter > 0) then  ! restriction only if it did something in the solver
        b_lev(lev) % val(:) = 0.0
        do c = 1, grid % level(lev-1) % n_cells       ! through finer cells
          c_lev = grid % level(lev-1) % coarser_c(c)  ! get coarse cell
          b_lev(lev) % val(c_lev) =  &
          b_lev(lev) % val(c_lev) + r_lev(lev-1) % val(c)
        end do
      end if

      !---------------------------------!
      !   Solve    [A]{x} = b and       !
      !   compute  {r} = {b} - [A]{x}   !
      !---------------------------------!
      call Cg_Level(lev,               &  ! level
                    a_lev(lev),        &  ! system matrix
                    d_lev(lev),        &  ! preconditioning matrix
                    x_lev(lev) % val,  &  ! solution
                    b_lev(lev) % val,  &  ! right hand side
                    p_lev(lev) % val,  &  ! p1 vector from cg algorith
                    r_lev(lev) % val,  &  ! residual vector
                    prec,              &  ! preconditioner
                    1,                 &
                    n_iter,            &  ! max iterations
                    p_iter,            &  ! performed iterations
                    tol,               &  ! tolerance
                    res_rat,           &  ! residual ratio
                    fin_res)              ! final residual

    end do  ! end of going down

                    !----------------------------------!
                    !                                  !
                    !    You reched the rock bottom    !
                    !   solved at the coarsest level   !
                    !                                  !
                    !----------------------------------!

    !-----------------------!
    !                       !
    !   Go up the V cycle   !
    !                       !
    !-----------------------!
    do lev = lev_max-1, 1, -1

      !------------------+
      !   Prolongation   !
      !------------------+-------------------!
      !     +-------+          +---+---+     !
      !     |       |          |   |   |     !
      !     |       |   =-->   +---+---+     !
      !     |       |          |   |   |     !
      !     +-------+          +---+---+     !
      !       lev+1               lev        !
      !--------------------------------------!
      if(p_iter > 0) then  ! prolongation only if it did something in the solver
        do c = 1, grid % level(lev) % n_cells       ! through finer cells
          c_lev = grid % level(lev) % coarser_c(c)  ! get coarse cell
          x_lev(lev) % val(c) =  &
          x_lev(lev) % val(c) + x_lev(lev+1) % val(c_lev)
        end do
      end if

      !---------------------------------!
      !   Solve    [A]{x} = b and       !
      !   compute  {r} = {b} - [A]{x}   !
      !---------------------------------!
      call Cg_Level(lev,               &  ! level
                    a_lev(lev),        &  ! system matrix
                    d_lev(lev),        &  ! preconditioning matrix
                    x_lev(lev) % val,  &  ! solution
                    b_lev(lev) % val,  &  ! right hand side
                    p_lev(lev) % val,  &  ! p1 vector from cg algorith
                    r_lev(lev) % val,  &  ! residual vector
                    prec,              &  ! preconditioner
                    1,                 &  ! cycle
                    n_iter,            &  ! max iterations
                    p_iter,            &  ! performed iterations
                    tol,               &  ! tolerance
                    res_rat,           &  ! residual ratio
                    fin_res)              ! final residual
    end do
  end do

  end subroutine


  subroutine setupQintsData ( photonEG, thetaValues, numElements )

! ======================================================================
!
! Sets up data for the "qintxs" function (i.e. angle bins for interpolation)
!
!
! Written by CMJ, XCP-3, 12/2018
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64

    implicit none
    class(PhotonEventGenerator), intent(inout) :: photonEG
    real(real64),                intent(in   ) :: thetaValues(:)
    integer(int32),              intent(in   ) :: numElements

    integer(int32) :: k
    integer(int32) :: usedElements = 0_int32

! ======================================================================

    ! Ensure array bounds are not exceeded based on user input
    if ( numElements > 0 ) then
       usedElements = min( numElements, size(thetaValues) )
    else
       usedElements = size( thetaValues )
    end if

    ! Allocate memory for the data
10  continue
    if ( .not. allocated(photonEG%data%x11) ) then
       allocate( photonEG%data%theta(usedElements) )
       allocate( photonEG%data%x11(usedElements) )
       allocate( photonEG%data%x22(usedElements) )
       allocate( photonEG%data%x33(usedElements) )
       allocate( photonEG%data%x12(usedElements) )
       allocate( photonEG%data%x23(usedElements) )
       allocate( photonEG%data%x31(usedElements) )
       allocate( photonEG%data%d(usedElements)   )
       photonEG%data%numElements = usedElements
    else
       ! Deallocate and then re-allocate (ensures correct size)
       deallocate( photonEG%data%theta )
       deallocate( photonEG%data%x11 )
       deallocate( photonEG%data%x22 )
       deallocate( photonEG%data%x33 )
       deallocate( photonEG%data%x12 )
       deallocate( photonEG%data%x23 )
       deallocate( photonEG%data%x31 )
       deallocate( photonEG%data%d )
       photonEG%data%numElements = 0
       go to 10
    end if

    ! Initialize data
    photonEG%data%theta(:) = thetaValues(:)
    photonEG%data%x11(:) = zro
    photonEG%data%x22(:) = zro
    photonEG%data%x33(:) = zro
    photonEG%data%x12(:) = zro
    photonEG%data%x23(:) = zro
    photonEG%data%x31(:) = zro
    do k = 2, (photonEG%data%numElements-1)
       photonEG%data%x11(k) = photonEG%data%theta(k-1)**2
       photonEG%data%x22(k) = photonEG%data%theta(k)**2
       photonEG%data%x33(k) = photonEG%data%theta(k+1)**2
       photonEG%data%x12(k) = photonEG%data%theta(k-1) - photonEG%data%theta(k)
       photonEG%data%x31(k) = photonEG%data%theta(k+1) - photonEG%data%theta(k-1)
       photonEG%data%x23(k) = photonEG%data%theta(k)   - photonEG%data%theta(k+1)
       photonEG%data%d(k)   = photonEG%data%x23(k)*photonEG%data%x11(k) + &
            & photonEG%data%x31(k)*photonEG%data%x22(k) + &
            & photonEG%data%x12(k)*photonEG%data%x33(k)
    end do

    return
! ======================================================================
  end subroutine setupQintsData


      SUBROUTINE OpenFoamNearestNeighbourXY(x0)
      ! Nearest Neighbour algorithm: Runs through a structured Cartesian grid in the $x$, $y$ and $z$ direction respectively.
      !
      ! Input: x0:= vector which contains the coordinate $\{x,y,z\}$ of
      ! which the nearest neighbour is wanted.
      !
      ! Output:
      !

      USE GlobalVariables
      IMPLICIT NONE
      REAL(KIND=long) :: dist, temp
      REAL(KIND=long), DIMENSION(:) :: x0(3)
      INTEGER i
      INTEGER, DIMENSION(:), POINTER :: NN

      ! Assign local pointers
      !
      NN => interpolation%NN

      ! Searches the x-direction (positive direction)
      !
      IF (GridX==1) THEN
          dist = 1*10**5 ! Large number infinite distance
          DO i=1,SIZE(FineGrid%x,1)
            temp = ABS(x0(1) - FineGrid%x(i,1))
                   IF (temp < dist) THEN
                     dist = temp
                     NN(1) = i
                   ELSE
                     exit
                   END IF

          END DO
      ELSE
          NN(1) = nint(x0(1)/dx) + GhostGridX + 1
      END IF

      ! Searches the y-direction (positive direction)
      !
      IF(FineGrid%Ny==1) THEN
      NN(2) = 1
      ELSE IF (GridY==0 .AND. FineGrid%Ny>1) THEN
          NN(2) = nint(x0(2)/dy) + GhostGridY + 1
      ELSE
          dist = 1*10**5
          DO i=1,SIZE(FineGrid%y,2)
            temp = ABS(x0(2) - FineGrid%y(1,i))
                   IF (temp < dist) THEN
                     dist = temp
                     NN(2) = i
                   ELSE
                           exit
                  END IF

          END DO
      END IF

      END SUBROUTINE OpenFoamNearestNeighbourXY

      SUBROUTINE OpenFoamNearestNeighbourZ(x0)
      !Nearest Neighbour algorithm: Runs through a structured Cartesian
      !grid in the z direction respectively.
      !
      ! Input: x0:= vector which contains the coordinate $\{x,y,z\}$ of
      ! which the nearest neighbour is wanted.
      !
      ! Output:
      !

      USE GlobalVariables
      IMPLICIT NONE
      REAL(KIND=long) :: dist, temp, sigma
      REAL(KIND=long), DIMENSION(:) :: x0(3)
      INTEGER i
      INTEGER, POINTER :: inOrOut
      INTEGER, DIMENSION(:), POINTER :: NN

      ! Assign local pointers
      !
      NN => interpolation%NN
      inOrOut => interpolation%inOrOut

      ! Transformation of z-physical into sigma
      !
      sigma = (x0(3) ) / &
              (FineGrid%h(NN(1),NN(2)) + Wavefield%E(NN(1),NN(2)))

      ! Identify however the cell is located in or outside the water
      ! column.
      IF(sigma>1.00) THEN

        !Flag indicating the cell is outside the water column
        inOrOut = 1

      ELSE
        ! Flag indicating that the cell is inside the water column
        inOrOut = 0
      ! Searches the $z$-direction (positive direction)
      !
      dist = 1*10**5
      DO i=1,SIZE(FineGrid%z,1)
        temp = ABS(sigma - FineGrid%z(i))
               IF (temp < dist) THEN
                 dist = temp
                 NN(3) = i
               ELSE
                 exit
               END IF

      END DO

      END IF
      END SUBROUTINE OpenFoamNearestNeighbourZ

      !SUBROUTINE NearestNeighbourXY(x0,NN)
      !! Nearest Neighbour algorithm: Runs through a structured Cartesian grid in the $x$, $y$ and $z$ direction respectively.
      !!
      !! Input: x0:= vector which contains the coordinate $\{x,y,z\}$ of
      !! which the nearest neighbour is wanted.
      !!
      !! Output:
      !!

      !USE GlobalVariables
      !IMPLICIT NONE
      !REAL(KIND=long) :: dist, temp
      !REAL(KIND=long), DIMENSION(:) :: x0(3)
      !INTEGER i
      !INTEGER, DIMENSION(:) :: NN(2)

      !! Searches the $x$-direction (positive direction)
      !!
      !dist = 1*10**5 ! Large number infinite distance
      !DO i=1,SIZE(FineGrid%x,1)
        !temp = ABS(x0(1) - FineGrid%x(i,1))
               !IF (temp < dist) THEN
                 !dist = temp
                 !NN(1) = i
               !ELSE
                 !exit
               !END IF

      !END DO

      !! Searches the $y$-direction (positive direction)
      !!
      !dist = 1*10**5
      !DO i=1,SIZE(FineGrid%y,2)
        !temp = ABS(x0(2) - FineGrid%y(1,i))
               !IF (temp < dist) THEN
                 !dist = temp
                 !NN(2) = i
               !ELSE
                       !exit
               !END IF

      !END DO

      !END SUBROUTINE NearestNeighbourXY


module elemFunc
contains
    elemental function multiply(x, y)
        real, intent(in) :: x, y
        real :: multiply
        multiply = x * y
    end function multiply
end module elemFunc


module matmat_mul_module

  use multifab_module
  use ml_layout_module

  implicit none

  private

  public :: matmat_mul

  contains

  subroutine matmat_mul(mla, x, A, nc) ! Computes x=A*x, where A and x are ncXnc matrix

    type(ml_layout), intent(in   ) :: mla
    type(multifab),  intent(inout) :: x
    type(multifab),  intent(in   ) :: A
    integer,         intent(in   ) :: nc

    ! local variables
    real(kind=dp_t), pointer       :: xp(:,:,:,:)
    real(kind=dp_t), pointer       :: ap(:,:,:,:)
    integer                        :: lo(mla%dim), hi(mla%dim), i, dm

    type(bl_prof_timer), save :: bpt

    call build(bpt,"matmat_mul")

    dm = mla%dim

    do i=1,nfabs(x)
       xp  => dataptr(x, i)
       ap  => dataptr(A, i)
       lo(1) = lbound(ap,1)  ! this adjusts lo & hi ghost cells on nodes & faces,
       lo(2) = lbound(ap,2)  ! so in the subroutine loop from lo to hi without ng.
       hi(1) = ubound(ap,1)
       hi(2) = ubound(ap,2)
       !print*, 'matmat', lo(1:2),hi(1:2)

       select case (dm)
         case (2)
             call matmat_mul_2d(xp(:,:,1,:), ap(:,:,1,:), lo, hi, nc)
         case (3)
             lo(3) = lbound(ap,3)
             hi(3) = ubound(ap,3)
             call matmat_mul_3d(xp(:,:,:,:), ap(:,:,:,:), lo, hi, nc)
       end select
    end do

    call destroy(bpt)

  end subroutine matmat_mul

  subroutine matmat_mul_2d(xp, ap, lo, hi, nc)

    integer                        :: lo(:), hi(:)
    real(kind=dp_t), intent(inout) :: xp(lo(1):,lo(2):,:) ! last dimension for nc^2
    real(kind=dp_t), intent(in)    :: ap(lo(1):,lo(2):,:)
    integer                        :: i,j,nc

    do j=lo(2),hi(2)
       do i=lo(1),hi(1)
          call matmat_mul_comp(xp(i,j,:), ap(i,j,:))
       end do
    end do

    contains

    ! Use contained subroutine to do rank conversion and matrix-matrix multiplication
    subroutine matmat_mul_comp(xp_ij, ap_ij)

        real(kind=dp_t), dimension(nc,nc), intent(inout) :: xp_ij
        real(kind=dp_t), dimension(nc,nc), intent(in)    :: ap_ij
        !print*, nc
        xp_ij = matmul(ap_ij, xp_ij)

    end subroutine matmat_mul_comp

  end subroutine matmat_mul_2d

  subroutine matmat_mul_3d(xp, ap, lo, hi, nc)

    integer                        :: lo(:), hi(:)
    real(kind=dp_t), intent(inout) :: xp(lo(1):,lo(2):,lo(3):,:) ! last dimension for nc^2
    real(kind=dp_t), intent(in)    :: ap(lo(1):,lo(2):,lo(3):,:)
    integer                        :: i,j,k,nc

    !print*, lo(1:3), hi(1:3)
    do k=lo(3),hi(3)
       do j=lo(2),hi(2)
          do i=lo(1),hi(1)
             call matmat_mul_comp(xp(i,j,k,:), ap(i,j,k,:))
          end do
       end do
    end do

    contains

    ! Use contained subroutine to do rank conversion and matrix-matrix multiplication
    subroutine matmat_mul_comp(xp_ij, ap_ij)

        real(kind=dp_t), dimension(nc,nc), intent(inout) :: xp_ij
        real(kind=dp_t), dimension(nc,nc), intent(in)    :: ap_ij

        type(bl_prof_timer), save :: bpt

        call build(bpt,"matmat_mul_comp")

        xp_ij = matmul(ap_ij, xp_ij)

        call destroy(bpt)

    end subroutine matmat_mul_comp

  end subroutine matmat_mul_3d

end module matmat_mul_module


      SUBROUTINE SB04ND( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C,
     $                   LDC, TOL, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve for X the continuous-time Sylvester equation
C
C        AX + XB = C,
C
C     with at least one of the matrices A or B in Schur form and the
C     other in Hessenberg or Schur form (both either upper or lower);
C     A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices,
C     respectively.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     ABSCHU  CHARACTER*1
C             Indicates whether A and/or B is/are in Schur or
C             Hessenberg form as follows:
C             = 'A':  A is in Schur form, B is in Hessenberg form;
C             = 'B':  B is in Schur form, A is in Hessenberg form;
C             = 'S':  Both A and B are in Schur form.
C
C     ULA     CHARACTER*1
C             Indicates whether A is in upper or lower Schur form or
C             upper or lower Hessenberg form as follows:
C             = 'U':  A is in upper Hessenberg form if ABSCHU = 'B' and
C                     upper Schur form otherwise;
C             = 'L':  A is in lower Hessenberg form if ABSCHU = 'B' and
C                     lower Schur form otherwise.
C
C     ULB     CHARACTER*1
C             Indicates whether B is in upper or lower Schur form or
C             upper or lower Hessenberg form as follows:
C             = 'U':  B is in upper Hessenberg form if ABSCHU = 'A' and
C                     upper Schur form otherwise;
C             = 'L':  B is in lower Hessenberg form if ABSCHU = 'A' and
C                     lower Schur form otherwise.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The order of the matrix B.  M >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             coefficient matrix A of the equation.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading M-by-M part of this array must contain the
C             coefficient matrix B of the equation.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,M).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,M)
C             On entry, the leading N-by-M part of this array must
C             contain the coefficient matrix C of the equation.
C             On exit, if INFO = 0, the leading N-by-M part of this
C             array contains the solution matrix X of the problem.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,N).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used to test for near singularity in
C             the Sylvester equation. If the user sets TOL > 0, then the
C             given value of TOL is used as a lower bound for the
C             reciprocal condition number; a matrix whose estimated
C             condition number is less than 1/TOL is considered to be
C             nonsingular. If the user sets TOL <= 0, then a default
C             tolerance, defined by TOLDEF = EPS, is used instead, where
C             EPS is the machine precision (see LAPACK Library routine
C             DLAMCH).
C             This parameter is not referenced if ABSCHU = 'S',
C             ULA = 'U', and ULB = 'U'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (2*MAX(M,N))
C             This parameter is not referenced if ABSCHU = 'S',
C             ULA = 'U', and ULB = 'U'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             This parameter is not referenced if ABSCHU = 'S',
C             ULA = 'U', and ULB = 'U'.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK = 0, if ABSCHU = 'S', ULA = 'U', and ULB = 'U';
C             LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if a (numerically) singular matrix T was encountered
C                   during the computation of the solution matrix X.
C                   That is, the estimated reciprocal condition number
C                   of T is less than or equal to TOL.
C
C     METHOD
C
C     Matrices A and B are assumed to be in (upper or lower) Hessenberg
C     or Schur form (with at least one of them in Schur form). The
C     solution matrix X is then computed by rows or columns via the back
C     substitution scheme proposed by Golub, Nash and Van Loan (see
C     [1]), which involves the solution of triangular systems of
C     equations that are constructed recursively and which may be nearly
C     singular if A and -B have close eigenvalues. If near singularity
C     is detected, then the routine returns with the Error Indicator
C     (INFO) set to 1.
C
C     REFERENCES
C
C     [1] Golub, G.H., Nash, S. and Van Loan, C.F.
C         A Hessenberg-Schur method for the problem AX + XB = C.
C         IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.
C
C     NUMERICAL ASPECTS
C                                            2         2
C     The algorithm requires approximately 5M N + 0.5MN  operations in
C                            2         2
C     the worst case and 2.5M N + 0.5MN  operations in the best case
C     (where M is the order of the matrix in Hessenberg form and N is
C     the order of the matrix in Schur form) and is mixed stable (see
C     [1]).
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997.
C     Supersedes Release 2.0 routine SB04BD by M. Vanbegin, and
C     P. Van Dooren, Philips Research Laboratory, Brussels, Belgium.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000.
C
C     KEYWORDS
C
C     Hessenberg form, orthogonal transformation, real Schur form,
C     Sylvester equation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         ABSCHU, ULA, ULB
      INTEGER           INFO, LDA, LDB, LDC, LDWORK, M, N
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*)
C     .. Local Scalars ..
      CHARACTER         ABSCHR
      LOGICAL           LABSCB, LABSCS, LULA, LULB
      INTEGER           FWD, I, IBEG, IEND, INCR, IPINCR, ISTEP, JWORK,
     $                  LDW, MAXMN
      DOUBLE PRECISION  SCALE, TOL1
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DTRSYL, SB04NV, SB04NW, SB04NX, SB04NY,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
      INFO = 0
      MAXMN = MAX( M, N )
      LABSCB = LSAME( ABSCHU, 'B' )
      LABSCS = LSAME( ABSCHU, 'S' )
      LULA   = LSAME( ULA, 'U' )
      LULB   = LSAME( ULB, 'U' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LABSCB .AND. .NOT.LABSCS .AND.
     $    .NOT.LSAME( ABSCHU, 'A' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LULA .AND. .NOT.LSAME( ULA, 'L' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.LULB .AND. .NOT.LSAME( ULB, 'L' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( M.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDWORK.LT.0 .OR. ( .NOT.( LABSCS .AND. LULA .AND. LULB )
     $   .AND. LDWORK.LT.2*MAXMN*( 4 + 2*MAXMN ) ) ) THEN
         INFO = -15
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB04ND', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAXMN.EQ.0 )
     $   RETURN
C
      IF ( LABSCS .AND. LULA .AND. LULB ) THEN
C
C        If both matrices are in a real Schur form, use DTRSYL.
C
         CALL DTRSYL( 'NoTranspose', 'NoTranspose', 1, N, M, A, LDA, B,
     $                LDB, C, LDC, SCALE, INFO )
         IF ( SCALE.NE.ONE )
     $      INFO = 1
         RETURN
      END IF
C
      LDW   = 2*MAXMN
      JWORK = LDW*LDW + 3*LDW + 1
      TOL1 = TOL
      IF ( TOL1.LE.ZERO )
     $   TOL1 = DLAMCH( 'Epsilon' )
C
C     Choose the smallest of both matrices as the one in Hessenberg
C     form when possible.
C
      ABSCHR = ABSCHU
      IF ( LABSCS ) THEN
         IF ( N.GT.M ) THEN
            ABSCHR = 'A'
         ELSE
            ABSCHR = 'B'
         END IF
      END IF
      IF ( LSAME( ABSCHR, 'B' ) ) THEN
C
C        B is in Schur form: recursion on the columns of B.
C
         IF ( LULB ) THEN
C
C           B is upper: forward recursion.
C
            IBEG = 1
            IEND = M
            FWD  = 1
            INCR = 0
         ELSE
C
C           B is lower: backward recursion.
C
            IBEG = M
            IEND = 1
            FWD  = -1
            INCR = -1
         END IF
         I = IBEG
C        WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO
   20    IF ( ( IEND - I )*FWD.GE.0 ) THEN
C
C           Test for 1-by-1 or 2-by-2 diagonal block in the Schur
C           form.
C
            IF ( I.EQ.IEND ) THEN
               ISTEP = 1
            ELSE
               IF ( B(I+FWD,I).EQ.ZERO ) THEN
                  ISTEP = 1
               ELSE
                  ISTEP = 2
               END IF
            END IF
C
            IF ( ISTEP.EQ.1 ) THEN
               CALL SB04NW( ABSCHR, ULB, N, M, C, LDC, I, B, LDB,
     $                      DWORK(JWORK) )
               CALL SB04NY( 'R', ULA, N, A, LDA, B(I,I), DWORK(JWORK),
     $                      TOL1, IWORK, DWORK, LDW, INFO )
               IF ( INFO.EQ.1 )
     $            RETURN
               CALL DCOPY( N, DWORK(JWORK), 1, C(1,I), 1 )
            ELSE
               IPINCR = I + INCR
               CALL SB04NV( ABSCHR, ULB, N, M, C, LDC, IPINCR, B, LDB,
     $                      DWORK(JWORK) )
               CALL SB04NX( 'R', ULA, N, A, LDA, B(IPINCR,IPINCR),
     $                      B(IPINCR+1,IPINCR), B(IPINCR,IPINCR+1),
     $                      B(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1,
     $                      IWORK, DWORK, LDW, INFO )
               IF ( INFO.EQ.1 )
     $            RETURN
               CALL DCOPY( N, DWORK(JWORK), 2, C(1,IPINCR), 1 )
               CALL DCOPY( N, DWORK(JWORK+1), 2, C(1,IPINCR+1), 1 )
            END IF
            I = I + FWD*ISTEP
            GO TO 20
         END IF
C        END WHILE 20
      ELSE
C
C        A is in Schur form: recursion on the rows of A.
C
         IF ( LULA ) THEN
C
C           A is upper: backward recursion.
C
            IBEG = N
            IEND = 1
            FWD  = -1
            INCR = -1
         ELSE
C
C           A is lower: forward recursion.
C
            IBEG = 1
            IEND = N
            FWD  = 1
            INCR = 0
         END IF
         I = IBEG
C        WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO
   40    IF ( ( IEND - I )*FWD.GE.0 ) THEN
C
C           Test for 1-by-1 or 2-by-2 diagonal block in the Schur
C           form.
C
            IF ( I.EQ.IEND ) THEN
               ISTEP = 1
            ELSE
               IF ( A(I,I+FWD).EQ.ZERO ) THEN
                  ISTEP = 1
               ELSE
                  ISTEP = 2
               END IF
            END IF
C
            IF ( ISTEP.EQ.1 ) THEN
               CALL SB04NW( ABSCHR, ULA, N, M, C, LDC, I, A, LDA,
     $                      DWORK(JWORK) )
               CALL SB04NY( 'C', ULB, M, B, LDB, A(I,I), DWORK(JWORK),
     $                      TOL1, IWORK, DWORK, LDW, INFO )
               IF ( INFO.EQ.1 )
     $            RETURN
               CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC )
            ELSE
               IPINCR = I + INCR
               CALL SB04NV( ABSCHR, ULA, N, M, C, LDC, IPINCR, A, LDA,
     $                      DWORK(JWORK) )
               CALL SB04NX( 'C', ULB, M, B, LDB, A(IPINCR,IPINCR),
     $                      A(IPINCR+1,IPINCR), A(IPINCR,IPINCR+1),
     $                      A(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1,
     $                      IWORK, DWORK, LDW, INFO )
               IF ( INFO.EQ.1 )
     $            RETURN
               CALL DCOPY( M, DWORK(JWORK), 2, C(IPINCR,1), LDC )
               CALL DCOPY( M, DWORK(JWORK+1), 2, C(IPINCR+1,1), LDC )
            END IF
            I = I + FWD*ISTEP
            GO TO 40
         END IF
C        END WHILE 40
      END IF
C
      RETURN
C *** Last line of SB04ND ***
      END


      SUBROUTINE REGTST(NSITES,NAMES,LEN,XMOM,A,B,SEED,NSIM,NPROB,PROB,
     *  KPRINT,KOUT,RMOM,D,VOBS,VBAR,VSD,H,Z,PARA)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C*  VERSION 3.03  JUNE 2000                                            *
C*  * CHARACTER variable declarations changed to conform with          *
C*    Fortran-77 standard                                              *
C*                                                                     *
C***********************************************************************
C
C  CALCULATES THREE STATISTICS USEFUL IN REGIONAL FREQUENCY ANALYSIS
C
C  DISCORDANCY MEASURE, D(I), FOR INDIVIDUAL SITES IN A REGION.
C      LARGE VALUES MIGHT BE USED AS A FLAG TO INDICATE POTENTIAL ERRORS
C      IN THE DATA AT THE SITE.  "LARGE" MIGHT BE 3 FOR REGIONS WITH 15
C      OR MORE SITES, BUT LESS (EXACT VALUES IN ARRAY DC1) FOR SMALLER
C      REGIONS.
C
C  HETEROGENEITY MEASURES, H(J), FOR A REGION BASED UPON EITHER:-
C      J=1: THE WEIGHTED S.D. OF THE L-CVS OR
C      J=2: THE AVERAGE DISTANCE FROM THE SITE TO THE REGIONAL AVERAGE
C           ON A GRAPH OF L-CV VS. L-SKEWNESS
C      J=3: THE AVERAGE DISTANCE FROM THE SITE TO THE REGIONAL AVERAGE
C           ON A GRAPH OF L-SKEWNESS VS. L-KURTOSIS
C
C      IN PRACTICE H(1) IS PROBABLY SUFFICIENT.  A VALUE GREATER THAN
C      (SAY) 1.0 SUGGESTS THAT FURTHER SUBDIVISION OF THE REGION SHOULD
C      BE CONSIDERED AS IT MIGHT IMPROVE QUANTILE ESTIMATES.
C
C  GOODNESS-OF-FIT MEASURES, Z(K), FOR 5 CANDIDATE DISTRIBUTIONS:
C      K=1: GENERALIZED LOGISTIC
C      K=2: GENERALIZED EXTREME VALUE
C      K=3: GENERALIZED NORMAL (LOGNORMAL)
C      K=4: PEARSON TYPE III (3-PARAMETER GAMMA)
C      K=5: GENERALIZED PARETO
C
C      PROVIDED THAT THE REGION IS ACCEPTABLY CLOSE TO HOMOGENEOUS,
C      THE FIT MAY BE JUDGED ACCEPTABLE AT 10% SIGNIFICANCE LEVEL
C      IF Z(K) IS LESS THAN 1.645 IN ABSOLUTE VALUE.
C
C  FOR FURTHER DETAILS SEE J.R.M. HOSKING AND J.R. WALLIS (1997),
C  "REGIONAL FREQUENCY ANALYSIS: AN APPROACH BASED ON L-MOMENTS",
C  CAMBRIDGE UNIVERSITY PRESS, CHAPTERS 3-5.
C
C  PARAMETERS OF ROUTINE:
C  NSITES * INPUT* NUMBER OF SITES IN REGION
C  NAMES  * INPUT* CHARACTER*12 ARRAY OF LENGTH NSITES. SITE NAMES.
C  LEN    * INPUT* ARRAY OF LENGTH NSITES. RECORD LENGTHS AT EACH SITE.
C  XMOM   * INPUT* ARRAY OF DIMENSION (5,NSITES). ARRAY CONTAINING
C                  THE FIRST 5 SAMPLE L-MOMENTS FOR EACH SITE, IN THE
C                  ORDER MEAN, L-CV, L-SKEWNESS, L-KURTOSIS, T-5, I.E
C                  XMOM(I,J) CONTAINS THE I'TH L-MOMENT FOR SITE J.
C                    N.B. XMOM(2,.) CONTAINS L-CV, NOT THE USUAL L-2!
C  A      * INPUT* ) PARAMETERS OF
C  B      * INPUT* ) PLOTTING POSITION.
C                  NOTE: A AND B SHOULD BE THE SAME AS THE VALUES USED
C                  TO CALCULATE THE MOMENTS IN THE XMOM ARRAY.
C  SEED   * INPUT* SEED FOR RANDOM NUMBER GENERATOR. SHOULD BE A WHOLE
C                  NUMBER IN THE RANGE 2D0 TO 2147483647D0.
C  NSIM   * INPUT* NUMBER OF SIMULATED WORLDS FOR HETEROGENEITY AND
C                  GOODNESS-OF-FIT TESTS.
C                    NOTE: NSIM=0 WILL FORCE RETURN AT COMPLETION OF
C                  OUTLIER TEST.  NSIM=1 WILL SUPPRESS CALCULATION OF
C                  H AND Z STATISTICS, BUT PARAMETER AND QUANTILE
C                  ESTIMATES WILL BE FOUND.
C  NPROB  * INPUT* NUMBER OF QUANTILES TO BE CALCULATED
C  PROB   * INPUT* ARRAY OF LENGTH NPROB.  PROBABILITIES FOR WHICH
C                  QUANTILES ARE TO BE CALCULATED.
C  KPRINT * INPUT* OUTPUT FLAG. SHOULD BE SET TO
C                  0  TO SUPPRESS OUTPUT
C                  1  TO PRINT OUTPUT
C  KOUT   * INPUT* CHANNEL TO WHICH OUTPUT IS DIRECTED
C  RMOM   *OUTPUT* ARRAY OF LENGTH 5. ON EXIT, CONTAINS THE REGIONAL
C                  WEIGHTED AVERAGE L-MOMENT RATIOS.
C  D      *OUTPUT* ARRAY OF LENGTH NSITES. ON EXIT, CONTAINS THE
C                  DISCORDANCY MEASURE (D STATISTIC) FOR EACH SITE.
C  VOBS   *OUTPUT* ARRAY OF LENGTH 3. ON EXIT, CONTAINS THE REGIONAL
C                  OBSERVED VALUES OF 3 HETEROGENEITY STATISTICS:
C                  (1) WEIGHTED S.D. OF L-CVS;
C                  (2) AVERAGE OF L-CV/L-SKEW DISTANCES;
C                  (3) AVERAGE OF L-SKEW/L-KURTOSIS DISTANCES.
C  VBAR   *OUTPUT* ARRAY OF LENGTH 3. ON EXIT, CONTAINS THE MEAN OF THE
C                  SIMULATED VALUES OF THE 3 HETEROGENEITY STATISTICS.
C  VSD    *OUTPUT* ARRAY OF LENGTH 3. ON EXIT, CONTAINS THE S.D. OF THE
C                  SIMULATED VALUES OF THE 3 HETEROGENEITY STATISTICS.
C  H      *OUTPUT* ARRAY OF LENGTH 3. ON EXIT, CONTAINS HETEROGENEITY
C                  MEASURES (H STATISTICS), I.E. H=(VOBS-VBAR)/VSD.
C  Z      *OUTPUT* ARRAY OF LENGTH 5. ON EXIT, CONTAINS GOODNESS-OF-FIT
C                  MEASURES (Z STATISTICS) FOR 5 DISTRIBUTIONS:
C                  (1) GEN. LOGISTIC, (2) GEN. EXTREME VALUE,
C                  (3) GEN. NORMAL, (4) PEARSON TYPE III,
C                  (5) GEN. PARETO.
C  PARA   *OUTPUT* ARRAY OF DIMENSION (5,6). ON EXIT, IF NSIM.GE.1,
C                  CONTAINS PARAMETERS OF GROWTH CURVES FITTED BY THE
C                  ABOVE 5 DISTRIBUTIONS, PLUS WAKEBY.
C
C  OTHER ROUTINES USED: DERF,DIGAMD,DLGAMA,DURAND,GAMIND,PELGEV,PELGLO,
C    PELGNO,PELGPA,PELKAP,PELPE3,PELWAK,QUAGAM,QUAGEV,QUAGLO,QUAGNO,
C    QUAGPA,QUAKAP,QUAPE3,QUASTN,QUAWAK,SAMLMR,SORT
C
C  QUANTITIES DEFINED IN PARAMETER STATEMENT:
C  MAXNS  - MUST BE AT LEAST AS LARGE AS NSITES
C  MAXREC - MUST BE AT LEAST AS LARGE AS EACH ELEMENT OF ARRAY LEN
C  MAXQ   - MUST BE AT LEAST AS LARGE AS NPROB
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MAXNS=200,MAXQ=30,MAXREC=200)
C
      CHARACTER*1 BLANK,STAR,LOOK1,LOOK2
      CHARACTER*12 NAMES(NSITES)
      CHARACTER*18 DISTRI(6)
      DOUBLE PRECISION D(NSITES),DC1(14),DC2(18),H(3),PARA(5,6),
     *  PROB(NPROB),Q(MAXQ),RMOM(5),RPARA(4),SMAT(3,3),TMOM(4),T4FIT(5),
     *  VBAR(3),VOBS(3),VSD(3),WORK(MAXNS,3),X(MAXREC),XMOM(5,NSITES),
     *  Z(5)
      INTEGER LEN(NSITES)
      DATA BLANK/' '/,STAR/'*'/
      DATA ZERO/0D0/,ONE/1D0/,TWO/2D0/,THREE/3D0/
      DATA DISTRI/
     *  'GEN. LOGISTIC     ','GEN. EXTREME VALUE','GEN. NORMAL       ',
     *  'PEARSON TYPE III  ','GEN. PARETO       ','WAKEBY            '/
C
C         COEFFICIENTS OF POWER-SERIES APPROXIMATIONS OF TAU-4 IN TERMS
C         OF TAU-3, FOR THE FIRST 5 DISTRIBUTIONS IN ARRAY DISTRI
C
      DATA GLOC0,GLOC2/0.16667D0,0.83333D0/
      DATA GEVC0,GEVC1,GEVC2,GEVC3,GEVC4,GEVC5,GEVC6/
     *  0.10701D0, 0.11090D0, 0.84838D0,-0.06669D0,
     *  0.00567D0,-0.04208D0, 0.03763D0/
      DATA GNOC0,GNOC2,GNOC4,GNOC6,GNOC8/
     *  0.12282D0,0.77518D0,0.12279D0,-0.13638D0,0.11368D0/
      DATA PE3C0,PE3C2,PE3C4,PE3C6,PE3C8/
     *  0.12240D0,0.30115D0,0.95812D0,-0.57488D0,0.19383D0/
      DATA GPAC1,GPAC2,GPAC3,GPAC4/
     *  0.20196D0,0.95924D0,-0.20096D0,0.04061D0/
C
C         CRITICAL VALUES FOR D, H AND Z STATISTICS
C
      DATA DC1/4*3D0,1.3330D0,1.6481D0,1.9166D0,2.1401D0,2.3287D0,
     *               2.4906D0,2.6321D0,2.7573D0,2.8694D0,2.9709D0/
      DATA DC2/4*4D0,1.3333D0,1.6648D0,1.9821D0,2.2728D0,2.5337D0,
     *               2.7666D0,2.9748D0,3.1620D0,3.3310D0,3.4844D0,
     *               3.6246D0,3.7532D0,3.8718D0,3.9816D0/
      DATA HCRIT1,HCRIT2/1D0,2D0/
      DATA ZCRIT/1.645D0/
C
C         INITIALIZE ARRAYS
C
      NMAX=0
      SUMLEN=0
      DO 10 I=1,NSITES
      NREC=LEN(I)
      IF(NREC.GT.NMAX)NMAX=NREC
      SUMLEN=SUMLEN+NREC
   10 D(I)=ZERO
      DO 20 K=1,3
      VOBS(K)=ZERO
      VBAR(K)=ZERO
      VSD(K)=ZERO
      H(K)=ZERO
   20 CONTINUE
      DO 30 IDIST=1,5
   30 Z(IDIST)=ZERO
      DO 40 IPARA=1,5
      DO 40 IDIST=1,6
   40 PARA(IPARA,IDIST)=ZERO
      IF(NSITES.GT.MAXNS)GOTO 1000
C
C         CALCULATE THE WEIGHTED MEAN OF L-CV, L-SKEW, L-KURTOSIS
C
      DO 60 K=2,5
      RMOM(K)=ZERO
      DO 50 I=1,NSITES
   50 RMOM(K)=RMOM(K)+LEN(I)*XMOM(K,I)
   60 RMOM(K)=RMOM(K)/SUMLEN
      RMOM(1)=ONE
C
C         CALCULATE SUM OF SQUARES MATRIX
C
      IF(NSITES.LE.3)GOTO 135
      SUM2=ZERO
      SUM3=ZERO
      SUM4=ZERO
      DO 70 I=1,NSITES
      SUM2=SUM2+XMOM(2,I)
      SUM3=SUM3+XMOM(3,I)
      SUM4=SUM4+XMOM(4,I)
   70 CONTINUE
      SUM2=SUM2/NSITES
      SUM3=SUM3/NSITES
      SUM4=SUM4/NSITES
      DO 80 I=1,NSITES
      WORK(I,1)=XMOM(2,I)-SUM2
      WORK(I,2)=XMOM(3,I)-SUM3
      WORK(I,3)=XMOM(4,I)-SUM4
   80 CONTINUE
      DO 100 J=1,3
      DO 100 K=J,3
      SMAT(J,K)=ZERO
      DO 90 I=1,NSITES
   90 SMAT(J,K)=SMAT(J,K)+WORK(I,J)*WORK(I,K)
  100 CONTINUE
C
C         INVERT SUM OF SQUARES MATRIX
C
      DO 110 K=1,3
      IF(SMAT(1,1).LE.ZERO)GOTO 1030
      TEMP0=ONE/SMAT(1,1)
      TEMP1=-SMAT(1,2)*TEMP0
      TEMP2=-SMAT(1,3)*TEMP0
      IF(K.GT.2)TEMP1=-TEMP1
      IF(K.GT.1)TEMP2=-TEMP2
      SMAT(1,1)=SMAT(2,2)+TEMP1*SMAT(1,2)
      SMAT(1,2)=SMAT(2,3)+TEMP1*SMAT(1,3)
      SMAT(2,2)=SMAT(3,3)+TEMP2*SMAT(1,3)
      SMAT(1,3)=TEMP1
      SMAT(2,3)=TEMP2
      SMAT(3,3)=TEMP0
  110 CONTINUE
      SMAT(2,1)=SMAT(1,2)
      SMAT(3,1)=SMAT(1,3)
      SMAT(3,2)=SMAT(2,3)
C
C         CALCULATE DISCORDANCY MEASURES (D STATISTICS)
C
      FACTOR=NSITES/THREE
      DO 130 I=1,NSITES
      DO 120 J=1,3
      DO 120 K=1,3
  120 D(I)=D(I)+WORK(I,J)*WORK(I,K)*SMAT(J,K)
      D(I)=D(I)*FACTOR
      WORK(I,1)=D(I)
  130 CONTINUE
      CALL SORT(WORK(1,1),NSITES)
      GOTO 140
  135 DO 138 I=1,NSITES
  138 D(I)=ONE
C
C         PRINT DISCORDANCY MEASURES
C
  140 CONTINUE
      IF(KPRINT.LE.0)GOTO 160
      WRITE(KOUT,6000)
      DCRIT1=DC1(1)
      DCRIT2=DC2(1)
      IF(NSITES.LE.14)DCRIT1=DC1(NSITES)
      IF(NSITES.LE.18)DCRIT2=DC2(NSITES)
      KSTART=1
      DO 150 I=1,NSITES
      LOOK1=BLANK
      LOOK2=BLANK
      IF(D(I).GE.DCRIT1)LOOK1=STAR
      IF(D(I).GE.DCRIT2)LOOK2=STAR
      IF(D(I).LT.DCRIT1)KSTART=KSTART+1
      WRITE(KOUT,6010)I,LEN(I),NAMES(I),(XMOM(K,I),K=2,4),
     *  D(I),LOOK1,LOOK2
  150 CONTINUE
      WRITE(KOUT,6020)(RMOM(K),K=2,4)
      IF(KSTART.LT.NSITES)WRITE(KOUT,6030)(WORK(K,1),K=KSTART,NSITES)
  160 CONTINUE
C
      IF(NSIM.LE.0)RETURN
      IF(NPROB.GT.MAXQ)GOTO 1010
      IF(NSIM.EQ.1)GOTO 270
      IF(NMAX.GT.MAXREC)GOTO 1020
C
C         FIT KAPPA DISTRIBUTION TO REGIONAL L-MOMENTS
C
      CALL PELKAP(RMOM,RPARA,IFAIL)
      IF(IFAIL.EQ.0)GOTO 180
      CALL PELGLO(RMOM,RPARA)
      RPARA(4)=-ONE
  180 IF(KPRINT.GT.0)WRITE(KOUT,6040)(RPARA(K),K=1,4)
C
C         START THE NSIM REPETITIONS
C
      T4BAR=ZERO
      T4SD=ZERO
      DO 220 ISIM=1,NSIM
      SUM2=ZERO
      SUM3=ZERO
      SUM4=ZERO
C
C         START OF LOOP OVER SITES
C
      DO 200 I=1,NSITES
      NREC=LEN(I)
C
C         GET VECTOR OF UNIFORM RANDOM NUMBERS
C
      CALL DURAND(SEED,NREC,X)
C
C         TRANSFORM FROM UNIFORM TO KAPPA
C
      DO 190 J=1,NREC
      X(J)=QUAKAP(X(J),RPARA)
  190 CONTINUE
C
C         FIND L-MOMENTS OF SIMULATED DATA
C
      CALL SORT(X,NREC)
      CALL SAMLMR(X,NREC,TMOM,4,A,B)
      CV=TMOM(2)/TMOM(1)
      WORK(I,1)=CV
      WORK(I,2)=TMOM(3)
      WORK(I,3)=TMOM(4)
      SUM2=SUM2+NREC*CV
      SUM3=SUM3+NREC*TMOM(3)
      SUM4=SUM4+NREC*TMOM(4)
C
C         END OF LOOP OVER SITES
C
  200 CONTINUE
C
      SUM2=SUM2/SUMLEN
      SUM3=SUM3/SUMLEN
      SUM4=SUM4/SUMLEN
      T4BAR=T4BAR+SUM4
      T4SD=T4SD+SUM4**2
C
C         CALCULATE HETEROGENEITY V-STATISTICS FOR SIMULATED DATA
C
      IF(NSITES.EQ.1)GOTO 215
      V1=ZERO
      V2=ZERO
      V3=ZERO
      DO 210 I=1,NSITES
      NREC=LEN(I)
      TEMP2=(WORK(I,1)-SUM2)**2
      TEMP3=(WORK(I,2)-SUM3)**2
      TEMP4=(WORK(I,3)-SUM4)**2
      V1=V1+NREC*TEMP2
      V2=V2+NREC*DSQRT(TEMP2+TEMP3)
      V3=V3+NREC*DSQRT(TEMP3+TEMP4)
  210 CONTINUE
      V1=DSQRT(V1/SUMLEN)
      V2=V2/SUMLEN
      V3=V3/SUMLEN
      VBAR(1)=VBAR(1)+V1
      VBAR(2)=VBAR(2)+V2
      VBAR(3)=VBAR(3)+V3
      VSD(1)=VSD(1)+V1**2
      VSD(2)=VSD(2)+V2**2
      VSD(3)=VSD(3)+V3**2
  215 CONTINUE
C
C         END OF THE NSIM REPETITIONS
C
  220 CONTINUE
C
C         CALCULATE HETEROGENEITY V-STATISTICS FOR OBSERVED DATA
C
      IF(NSITES.EQ.1)GOTO 235
      V1=ZERO
      V2=ZERO
      V3=ZERO
      DO 225 I=1,NSITES
      NREC=LEN(I)
      TEMP2=(XMOM(2,I)-RMOM(2))**2
      TEMP3=(XMOM(3,I)-RMOM(3))**2
      TEMP4=(XMOM(4,I)-RMOM(4))**2
      V1=V1+NREC*TEMP2
      V2=V2+NREC*DSQRT(TEMP2+TEMP3)
      V3=V3+NREC*DSQRT(TEMP3+TEMP4)
  225 CONTINUE
      VOBS(1)=DSQRT(V1/SUMLEN)
      VOBS(2)=V2/SUMLEN
      VOBS(3)=V3/SUMLEN
C
C         CALCULATE AND PRINT HETEROGENEITY MEASURES (H STATISTICS)
C
      IF(KPRINT.GT.0)WRITE(KOUT,6050)NSIM
      DO 230 J=1,3
      VBAR(J)=VBAR(J)/NSIM
      VSD(J)=DSQRT((VSD(J)-NSIM*VBAR(J)**2)/(NSIM-ONE))
      H(J)=(VOBS(J)-VBAR(J))/VSD(J)
      IF(KPRINT.LE.0)GOTO 230
      LOOK1=BLANK
      LOOK2=BLANK
      IF(H(J).GE.HCRIT1)LOOK1=STAR
      IF(H(J).GE.HCRIT2)LOOK2=STAR
      IF(J.EQ.1)WRITE(KOUT,6060)VOBS(J),VBAR(J),VSD(J),H(J),LOOK1,LOOK2
      IF(J.EQ.2)WRITE(KOUT,6070)VOBS(J),VBAR(J),VSD(J),H(J),LOOK1,LOOK2
      IF(J.EQ.3)WRITE(KOUT,6080)VOBS(J),VBAR(J),VSD(J),H(J),LOOK1,LOOK2
  230 CONTINUE
  235 CONTINUE
C
C         FIND TAU-4 VALUES OF EACH CANDIDATE DISTRIBUTION
C
      S=RMOM(3)
      SS=S*S
      T4FIT(1)=GLOC0+SS*GLOC2
      T4FIT(2)=
     *  GEVC0+S*(GEVC1+S*(GEVC2+S*(GEVC3+S*(GEVC4+S*(GEVC5+S*GEVC6)))))
      T4FIT(3)=GNOC0+SS*(GNOC2+SS*(GNOC4+SS*(GNOC6+SS*GNOC8)))
      T4FIT(4)=PE3C0+SS*(PE3C2+SS*(PE3C4+SS*(PE3C6+SS*PE3C8)))
      T4FIT(5)=S*(GPAC1+S*(GPAC2+S*(GPAC3+S*GPAC4)))
C
C         CALCULATE GOODNESS-OF-FIT MEASURES (Z STATISTICS)
C
      T4BAR=T4BAR/NSIM
      T4SD=DSQRT((T4SD-NSIM*T4BAR**2)/(NSIM-ONE))
      DO 240 IDIST=1,5
      Z(IDIST)=(T4FIT(IDIST)+T4BAR-TWO*RMOM(4))/T4SD
  240 CONTINUE
C
C         PRINT Z STATISTICS
C
      IF(KPRINT.LE.0)GOTO 260
      WRITE(KOUT,6090)NSIM
      DO 250 IDIST=1,5
      LOOK1=BLANK
      IF(DABS(Z(IDIST)).LT.ZCRIT)LOOK1=STAR
  250 WRITE(KOUT,6100)DISTRI(IDIST),T4FIT(IDIST),Z(IDIST),LOOK1
  260 CONTINUE
C
C         FIT DISTRIBUTIONS
C
  270 CONTINUE
      CALL PELGLO(RMOM,PARA(1,1))
      CALL PELGEV(RMOM,PARA(1,2))
      CALL PELGNO(RMOM,PARA(1,3))
      CALL PELPE3(RMOM,PARA(1,4))
      CALL PELGPA(RMOM,PARA(1,5))
      CALL PELWAK(RMOM,PARA(1,6),IFAIL)
C
C         FOR SUCCESSFUL CANDIDATES AND WAKEBY, PRINT PARAMETERS ...
C
      IF(KPRINT.LE.0)GOTO 320
      IF(NSIM.EQ.1)WRITE(KOUT,6110)
      IF(NSIM.GT.1)WRITE(KOUT,6120)
      DO 280 IDIST=1,5
      IF(DABS(Z(IDIST)).LE.ZCRIT)
     *  WRITE(KOUT,6130)DISTRI(IDIST),(PARA(IPARA,IDIST),IPARA=1,3)
  280 CONTINUE
      WRITE(KOUT,6130)DISTRI(6),(PARA(IPARA,6),IPARA=1,5)
C
C         ... AND ESTIMATE AND PRINT QUANTILES
C
      IF(NPROB.EQ.0)GOTO 320
      WRITE(KOUT,6140)PROB
      DO 300 IDIST=1,5
      IF(DABS(Z(IDIST)).GT.ZCRIT)GOTO 300
      DO 290 IQ=1,NPROB
      IF(IDIST.EQ.1)Q(IQ)=QUAGLO(PROB(IQ),PARA(1,1))
      IF(IDIST.EQ.2)Q(IQ)=QUAGEV(PROB(IQ),PARA(1,2))
      IF(IDIST.EQ.3)Q(IQ)=QUAGNO(PROB(IQ),PARA(1,3))
      IF(IDIST.EQ.4)Q(IQ)=QUAPE3(PROB(IQ),PARA(1,4))
      IF(IDIST.EQ.5)Q(IQ)=QUAGPA(PROB(IQ),PARA(1,5))
  290 CONTINUE
      WRITE(KOUT,6150)DISTRI(IDIST),(Q(IQ),IQ=1,NPROB)
  300 CONTINUE
      DO 310 IQ=1,NPROB
  310 Q(IQ)=QUAWAK(PROB(IQ),PARA(1,6))
      WRITE(KOUT,6150)DISTRI(6),(Q(IQ),IQ=1,NPROB)
  320 CONTINUE
C
      RETURN
C
 1000 WRITE(KOUT,7000)'MAXNS'
      RETURN
 1010 WRITE(KOUT,7000)'MAXQ'
      RETURN
 1020 WRITE(KOUT,7000)'MAXREC'
      RETURN
 1030 WRITE(KOUT,7010)
      GOTO 140
C
 6000 FORMAT(/' SITE    N      NAME       L-CV   L-SKEW  L-KURT   D(I)')
 6010 FORMAT(2I5,2X,A12,3F8.4,F7.2,2X,2A1)
 6020 FORMAT(/5X,'WEIGHTED MEANS',5X,6F8.4)
 6030 FORMAT(/' FLAGGED TEST VALUES'/(15F5.1))
 6040 FORMAT(/' PARAMETERS OF REGIONAL KAPPA DISTRIBUTION ',4F8.4)
 6050 FORMAT(//' ***** HETEROGENEITY MEASURES *****'/
     *  ' (NUMBER OF SIMULATIONS  =',I6,')')
 6060 FORMAT(/' OBSERVED     S.D. OF GROUP L-CV          =',F8.4/
     *        ' SIM. MEAN OF S.D. OF GROUP L-CV          =',F8.4/
     *        ' SIM. S.D. OF S.D. OF GROUP L-CV          =',F8.4/
     *        ' STANDARDIZED TEST VALUE H(1)             =',F6.2,2X,2A1)
 6070 FORMAT(/' OBSERVED AVE.  OF L-CV / L-SKEW DISTANCE =',F8.4/
     *        ' SIM. MEAN OF AVE. L-CV / L-SKEW DISTANCE =',F8.4/
     *        ' SIM. S.D. OF AVE. L-CV / L-SKEW DISTANCE =',F8.4/
     *        ' STANDARDIZED TEST VALUE H(2)             =',F6.2,2X,2A1)
 6080 FORMAT(/' OBSERVED AVE.  OF L-SKEW/L-KURT DISTANCE =',F8.4/
     *        ' SIM. MEAN OF AVE. L-SKEW/L-KURT DISTANCE =',F8.4/
     *        ' SIM. S.D. OF AVE. L-SKEW/L-KURT DISTANCE =',F8.4/
     *        ' STANDARDIZED TEST VALUE H(3)             =',F6.2,2X,2A1)
 6090 FORMAT(//' ***** GOODNESS-OF-FIT MEASURES *****'/
     *  ' (NUMBER OF SIMULATIONS  =',I6,')'/)
 6100 FORMAT(1X,A18,2X,' L-KURTOSIS=',F6.3,2X,' Z VALUE=',F6.2,1X,A1)
 6110 FORMAT(//' PARAMETER ESTIMATES'/)
 6120 FORMAT(//' PARAMETER ESTIMATES FOR DISTRIBUTIONS ACCEPTED AT THE',
     *  ' 90% LEVEL'/)
 6130 FORMAT(1X,A18,1X,5F7.3)
 6140 FORMAT(/' QUANTILE ESTIMATES'/19X,(1X,14F7.3))
 6150 FORMAT(1X,A18,(1X,14F7.3))
C
 7000 FORMAT(' *** ERROR *** ROUTINE REGTST :',
     *  ' INSUFFICIENT WORKSPACE - RECOMPILE WITH LARGER VALUE OF ',A6)
 7010 FORMAT(' *** ERROR *** ROUTINE REGTST : UNABLE TO INVERT',
     *  ' SUM-OF-SQUARES MATRIX.'/31X,'D STATISTICS NOT CALCULATED.')
C
      END


      SUBROUTINE GWTLT(SIT,WEIGHT,J,JG)
      IMPLICIT NONE
      INTEGER NNN,JG,K,J,N
      REAL PI,AJ
      PARAMETER(PI=3.14159265359)
      REAL SIT,WEIGHT
      DOUBLE PRECISION HH,TH
      DOUBLE PRECISION ACC,SA,SB,SC,D1,D2,D4,BN,GG,X,AMM,AMN
      DOUBLE PRECISION EM,ANN,RE,A,DD,DLT,DTH
      ACC=1.0D-23
      SA=DSQRT(.5D0)
      SB=DSQRT(1.5D0)
      SC=DSQRT(1.D0/3.D0)
      D1=1.D0
      D2=2.D0
      D4=4.D0
      NNN=JG+JG
      BN=NNN
      GG=D2*BN+D1
      HH=8.*BN*BN
      K=0
      AJ=J
      TH=PI*(2.*AJ-.5)/GG
      DTH=TH+(COS(TH)/SIN(TH))/HH
      X=DCOS(DTH)
54    CONTINUE
      AMM=SA
      AMN=X*SB
      EM=SC
      ANN=D1
      DO 51 N=2,NNN
      ANN=ANN+D1
      RE=DSQRT(D4*ANN*ANN-D1)/ANN
      A=RE*(X*AMN-EM*AMM)
      AMM=AMN
      AMN=A
      EM=D1/RE
51    CONTINUE
      DD=GG*EM*AMM-X*ANN*A
      K=K+1
      DLT=(D1-X*X)*A/DD
      IF (DABS(DLT).LT.ACC) GOTO 52
      IF (K.GT.50) GOTO 53
      X=X-DLT
      GOTO 54
53    CONTINUE
      WRITE (2,105)
105   FORMAT(15H NO CONVERGENCE)
52    CONTINUE
      WEIGHT=REAL(GG*(D1-X*X)/(DD*DD))
      SIT=REAL(X)
      RETURN
      END


C
C**************************  FHUDSE ************************************
C
C  calculate derivative of effective saturation with respect to pressure
C  head using Huyakorn characteristic equation
C
C***********************************************************************
C
      DOUBLE PRECISION FUNCTION FHUDSE(PSI)
C
      IMPLICIT NONE
      INCLUDE 'CATHY.H'
      REAL*8   PAP,LAMBDA,LAMR
      REAL*8   PSI
      INCLUDE 'SOILCHAR.H'
C
      IF (PSI .LT. HUPSIA) THEN
         PAP=HUPSIA - PSI
         LAMBDA=HUALB*(PAP**HUBETA)
         LAMR=1.0D0/(1.0D0 + LAMBDA)
         FHUDSE=(HUGB*LAMBDA/PAP)*(LAMR**HUGAM1)
      ELSE
         FHUDSE=0.0D0
      END IF
C
      RETURN
      END


      SUBROUTINE MB03OD( JOBQR, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU,
     $                   RANK, SVAL, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute (optionally) a rank-revealing QR factorization of a
C     real general M-by-N matrix  A,  which may be rank-deficient,
C     and estimate its effective rank using incremental condition
C     estimation.
C
C     The routine uses a QR factorization with column pivoting:
C        A * P = Q * R,  where  R = [ R11 R12 ],
C                                   [  0  R22 ]
C     with R11 defined as the largest leading submatrix whose estimated
C     condition number is less than 1/RCOND.  The order of R11, RANK,
C     is the effective rank of A.
C
C     MB03OD  does not perform any scaling of the matrix A.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBQR   CHARACTER*1
C             = 'Q':  Perform a QR factorization with column pivoting;
C             = 'N':  Do not perform the QR factorization (but assume
C                     that it has been done outside).
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C             ( LDA, N )
C             On entry with JOBQR = 'Q', the leading M by N part of this
C             array must contain the given matrix A.
C             On exit with JOBQR = 'Q', the leading min(M,N) by N upper
C             triangular part of A contains the triangular factor R,
C             and the elements below the diagonal, with the array TAU,
C             represent the orthogonal matrix Q as a product of
C             min(M,N) elementary reflectors.
C             On entry and on exit with JOBQR = 'N', the leading
C             min(M,N) by N upper triangular part of A contains the
C             triangular factor R, as determined by the QR factorization
C             with pivoting.  The elements below the diagonal of A are
C             not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     JPVT    (input/output) INTEGER array, dimension ( N )
C             On entry with JOBQR = 'Q', if JPVT(i) <> 0, the i-th
C             column of A is an initial column, otherwise it is a free
C             column. Before the QR factorization of A, all initial
C             columns are permuted to the leading positions; only the
C             remaining free columns are moved as a result of column
C             pivoting during the factorization.  For rank determination
C             it is preferable that all columns be free.
C             On exit with JOBQR = 'Q', if JPVT(i) = k, then the i-th
C             column of A*P was the k-th column of A.
C             Array JPVT is not referenced when JOBQR = 'N'.
C
C     RCOND   (input) DOUBLE PRECISION
C             RCOND is used to determine the effective rank of A, which
C             is defined as the order of the largest leading triangular
C             submatrix R11 in the QR factorization with pivoting of A,
C             whose estimated condition number is less than 1/RCOND.
C             RCOND >= 0.
C             NOTE that when SVLMAX > 0, the estimated rank could be
C             less than that defined above (see SVLMAX).
C
C     SVLMAX  (input) DOUBLE PRECISION
C             If A is a submatrix of another matrix B, and the rank
C             decision should be related to that matrix, then SVLMAX
C             should be an estimate of the largest singular value of B
C             (for instance, the Frobenius norm of B).  If this is not
C             the case, the input value SVLMAX = 0 should work.
C             SVLMAX >= 0.
C
C     TAU     (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) )
C             On exit with JOBQR = 'Q', the leading min(M,N) elements of
C             TAU contain the scalar factors of the elementary
C             reflectors.
C             Array TAU is not referenced when JOBQR = 'N'.
C
C     RANK    (output) INTEGER
C             The effective (estimated) rank of A, i.e. the order of
C             the submatrix R11.
C
C     SVAL    (output) DOUBLE PRECISION array, dimension ( 3 )
C             The estimates of some of the singular values of the
C             triangular factor R:
C             SVAL(1): largest singular value of R(1:RANK,1:RANK);
C             SVAL(2): smallest singular value of R(1:RANK,1:RANK);
C             SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1),
C                      if RANK < MIN( M, N ), or of R(1:RANK,1:RANK),
C                      otherwise.
C             If the triangular factorization is a rank-revealing one
C             (which will be the case if the leading columns were well-
C             conditioned), then SVAL(1) will also be an estimate for
C             the largest singular value of A, and SVAL(2) and SVAL(3)
C             will be estimates for the RANK-th and (RANK+1)-st singular
C             values of A, respectively.
C             By examining these values, one can confirm that the rank
C             is well defined with respect to the chosen value of RCOND.
C             The ratio SVAL(1)/SVAL(2) is an estimate of the condition
C             number of R(1:RANK,1:RANK).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension ( LDWORK )
C             On exit, if  INFO = 0,  DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 3*N + 1,                 if JOBQR = 'Q';
C             LDWORK >= max( 1, 2*min( M, N ) ), if JOBQR = 'N'.
C             For good performance when JOBQR = 'Q', LDWORK should be
C             larger. Specifically, LDWORK >= 2*N + ( N + 1 )*NB, where
C             NB is the optimal block size for the LAPACK Library
C             routine DGEQP3.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The routine computes or uses a QR factorization with column
C     pivoting of A,  A * P = Q * R,  with  R  defined above, and then
C     finds the largest leading submatrix whose estimated condition
C     number is less than 1/RCOND, taking the possible positive value of
C     SVLMAX into account.  This is performed using the LAPACK
C     incremental condition estimation scheme and a slightly modified
C     rank decision test.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005,
C     Aug. 2011.
C
C    ******************************************************************
C
C     .. Parameters ..
      INTEGER            IMAX, IMIN
      PARAMETER          ( IMAX = 1, IMIN = 2 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          JOBQR
      INTEGER            INFO, LDA, LDWORK, M, N, RANK
      DOUBLE PRECISION   RCOND, SVLMAX
C     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), SVAL( 3 ), TAU( * ), DWORK( * )
C     .. Local Scalars ..
      LOGICAL            LJOBQR, LQUERY
      INTEGER            I, ISMAX, ISMIN, MAXWRK, MINWRK, MN
      DOUBLE PRECISION   C1, C2, S1, S2, SMAX, SMAXPR, SMIN, SMINPR
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           DGEQP3, DLAIC1, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, INT, MAX, MIN
C     ..
C     .. Executable Statements ..
C
      LJOBQR = LSAME( JOBQR, 'Q' )
      MN = MIN( M, N )
      IF( LJOBQR ) THEN
         MINWRK = 3*N + 1
      ELSE
         MINWRK = MAX( 1, 2*MN )
      END IF
      MAXWRK = MINWRK
C
C     Test the input scalar arguments.
C
      INFO = 0
      IF( .NOT.LJOBQR .AND. .NOT.LSAME( JOBQR, 'N' ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( RCOND.LT.ZERO ) THEN
         INFO = -7
      ELSE IF( SVLMAX.LT.ZERO ) THEN
         INFO = -8
      ELSE
         LQUERY = LDWORK.EQ.-1
         IF ( LJOBQR ) THEN
            CALL DGEQP3( M, N, A, LDA, JPVT, TAU, DWORK, -1, INFO )
            MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
         END IF
         IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY )
     $      INFO = -13
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03OD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK( 1 ) = MAXWRK
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( MN.EQ.0 ) THEN
         RANK = 0
         SVAL(  1 ) = ZERO
         SVAL(  2 ) = ZERO
         SVAL(  3 ) = ZERO
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
      IF ( LJOBQR ) THEN
C
C        Compute QR factorization with column pivoting of A:
C           A * P = Q * R
C        Workspace need   3*N + 1;
C                  prefer 2*N + (N+1)*NB.
C        Details of Householder rotations stored in TAU.
C
         CALL DGEQP3( M, N, A, LDA, JPVT, TAU, DWORK, LDWORK, INFO )
      END IF
C
C     Determine RANK using incremental condition estimation
C
      ISMIN = 1
      ISMAX = MN + 1
      DWORK( ISMIN ) = ONE
      DWORK( ISMAX ) = ONE
      SMAX = ABS( A( 1, 1 ) )
      SMIN = SMAX
      IF( SMAX.EQ.ZERO .OR. SVLMAX*RCOND.GT.SMAX ) THEN
         RANK = 0
         SVAL( 1 ) = SMAX
         SVAL( 2 ) = ZERO
         SVAL( 3 ) = ZERO
      ELSE
         RANK = 1
         SMINPR = SMIN
C
   10    CONTINUE
         IF( RANK.LT.MN ) THEN
            I = RANK + 1
            CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, A( 1, I ),
     $                   A( I, I ), SMINPR, S1, C1 )
            CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, A( 1, I ),
     $                   A( I, I ), SMAXPR, S2, C2 )
C
            IF( SVLMAX*RCOND.LE.SMAXPR ) THEN
               IF( SVLMAX*RCOND.LE.SMINPR ) THEN
                  IF( SMAXPR*RCOND.LE.SMINPR ) THEN
                     DO 20 I = 1, RANK
                        DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 )
                        DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 )
   20                CONTINUE
                     DWORK( ISMIN+RANK ) = C1
                     DWORK( ISMAX+RANK ) = C2
                     SMIN = SMINPR
                     SMAX = SMAXPR
                     RANK = RANK + 1
                     GO TO 10
                  END IF
               END IF
            END IF
         END IF
         SVAL( 1 ) = SMAX
         SVAL( 2 ) = SMIN
         SVAL( 3 ) = SMINPR
      END IF
C
      DWORK( 1 ) = MAXWRK
      RETURN
C *** Last line of MB03OD ***
      END


C SUBROUTINE COLL             (NEXT)
      SUBROUTINE COLL (SUM)
C
C     COLL - CALCULATES THE MUTUAL IMPEDANCE BETWEEN COLINEAR DIPOLE
C        ELEMENTS OF EQUAL LENGTHS.
C     SEE REFERENCES IN SUBROUTINE GAIN AND ALSO THE ARTICLE BY
C     H.E. KING, IRE TRANS. ANT. AND PROP., JULY 1957, P 306.
C
      COMPLEX CSU1, CSU3, CSV2, CSZ1, SUM, ZE
C
      COMMON /CON /D2R, DCL, GAMA, PI, PI2, PIO2, R2D, RO, VOFL
C
      COMMON /CUR /DIJ, EIL, HIJ, KODE
C
C.......................................................................
      UZ = PI2 * 2.0 * (HIJ - EIL)
      U1 = PI2 * 2.0 * HIJ
      V2 = PI2 * 2.0 * (HIJ + 2.0 * EIL)
      U3 = PI2 * 2.0 * (HIJ + EIL)
      V4 = PI2 * 2.0 * (HIJ + 3.0 * EIL)
      CSU1 = CSZ1 (U1)
      CSV2 = CSZ1 (V2)
      CSU3 = CSZ1 (U3)
      HLOG = ALOG (HIJ / (HIJ + EIL))
      H2LOG = ALOG ((HIJ + 2. * EIL) / (HIJ + EIL))
      T = PI2 * (HIJ - EIL)
      ZE = CMPLX (COS (T), SIN (T))
      SUM = ZE * (CSZ1 (UZ) - CSU1) + CONJG (ZE) * ALOG (HIJ / (HIJ - EI
     1L))
      T = PI2 * (HIJ + EIL)
      ZE = CMPLX (COS (T), SIN (T))
      SUM = SUM + ZE * (CSU3 - CSV2) + CONJG (ZE) * H2LOG
      SUM = SUM + ZE * ( - CSU1 + CSU3) + CONJG (ZE) * HLOG
      T = PI2 * (HIJ + 3.0 * EIL)
      ZE = CMPLX (COS (T), SIN (T))
      SUM = SUM + ZE * ( - CSV2 + CSZ1 (V4)) + CONJG (ZE) * ALOG ((HIJ +
     1 2.0 * EIL) / (HIJ + 3.0 * EIL))
      TS = 2.0 * COS (PI2 * EIL)
      T = PI2 * HIJ
      ZE = CMPLX (COS (T), SIN (T))
      SUM = SUM + TS * ZE * ( - CSU1 + CSU3) + TS * CONJG (ZE) * HLOG
      T = PI2 * (HIJ + 2.0 * EIL)
      ZE = CMPLX (COS (T), SIN (T))
      SUM = SUM + TS * ZE * (CSU3 - CSV2) + TS * CONJG (ZE) * H2LOG
      IF (KODE .GT. 0) GO TO 100
      SUM = SUM * 15.0
      GO TO 105
 100  SUM = SUM * 30.0 / (1.0 - COS (2.0 * PI2 * EIL))
 105  RETURN
      END