C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE GETDST( NODE1, NODE2, XN, YN, ZN, DIST)
C=======================================================================

C   --*** GETDST *** (MESH) GETS DISTANCE BETWEEN TWO NODES
C   --   Written by RAY J. Meyers 21 June, 1990
C   --
C   -- calculates the distance between two nodes
C   --    (written because of referencing problem using a(xn) directly )
C   --
C   --Parameters:
C   --
C   --   NODE1 - IN - THE INDEX OF FIRST NODE
C   --   NODE2 - IN - THE INDEX OF FIRST NODE
C   --   XN - IN - THE ROTATED, DEFORMED X COORDINATES
C   --   YN - IN - THE ROTATED, DEFORMED Y COORDINATES
C   --   ZN - IN - THE ROTATED, DEFORMED Z COORDINATES
C   --   DIST - OUT - THE DISTANCE BETWEEN NODE1 AND NODE2

C=======================================================================

      REAL XN(*), YN(*), ZN(*)

      COMMON /D3NUMS/ IS3DIM, NNPSUR, NUMNPF, LLNSET
      LOGICAL IS3DIM

      XDIST = XN(NODE2) - XN(NODE1)
      YDIST = YN(NODE2) - YN(NODE1)
      IF(IS3DIM) THEN
         ZDIST = ZN(NODE2) - ZN(NODE1)
      ELSE
         ZDIST = 0
      END IF

      DIST = SQRT( XDIST*XDIST + YDIST*YDIST + ZDIST*ZDIST)

      RETURN
      END


      SUBROUTINE ASYFIL(A,NA,G,NG,H,NH,Q,NQ,R,NR,F,NF,P,NP,IDENT,DISC,N
     1EWT,STABLE,FNULL,ALPHA,IOP,DUMMY)
C
C   PURPOSE:
C      Solve either the continuous or discrete time-invariant asymptotic
C      optimal Kalman-Bucy filter problem.  Computation of both the
C      discrete and continuous versions of the optimal filter problems
C      is performed using duality theory.  No computations involve the
C      matrix W, therefore, no data for W are required.
C
C   REFERENCES:
C      Kwakernaak, Huibert; and Sivan, Raphael: Linear Optimal Control
C        Systems.  John Wiley & Sons, Inc., c.1972.
C
C   Subroutines employed by ASYFIL: ASYREG, EQUATE, LNCNT, PRNT, TRANP
C   Subroutines employing ASYFIL: None
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),G(1),H(1),Q(1),R(1),F(1),P(1),DUMMY(1)
      DIMENSION NA(2),NG(2),NH(2),NQ(2),NR(2),NF(2),NP(2),IOPT(5),NDUM1(
     12),IOP(1)
      LOGICAL  IDENT,DISC,NEWT,STABLE,FNULL
C
      IF( IOP(1) .EQ. 0 ) GO TO 100
      CALL LNCNT(4)
      IF(DISC)  WRITE(6,15)
      IF( .NOT. DISC )  WRITE(6,25)
   15 FORMAT(//' PROGRAM TO SOLVE THE DISCRETE INFINITE-DURATION OPTIMAL
     1 FILTER PROBLEM'/)
   25 FORMAT(//' PROGRAM TO SOLVE THE CONTINUOUS INFINITE-DURATION OPTIM
     1AL FILTER PROBLEM'/)
      CALL PRNT(A,NA,' A  ',1)
      IF( .NOT.  IDENT )  GO TO 35
      CALL LNCNT(3)
      WRITE(6,30)
   30 FORMAT(/' G IS AN IDENTITY MATRIX'/)
      GO TO 40
   35 CONTINUE
      CALL PRNT(G,NG,' G  ',1)
   40 CONTINUE
      CALL PRNT(H,NH,' H  ',1)
      CALL LNCNT(3)
      WRITE(6,45)
   45 FORMAT(/' INTENSITY MATRIX FOR COVARIANCE OF MEASUREMENT NOISE'/)
      CALL PRNT(R,NR,' R  ',1)
C
      IF( .NOT. IDENT ) GO TO 65
      CALL LNCNT(3)
      WRITE(6,55)
   55 FORMAT(/' INTENSITY MATRIX FOR COVARIANCE OF PROCESS NOISE'/)
C
   65 CONTINUE
      CALL PRNT(Q,NQ,' Q  ',1)
C
  100 CONTINUE
      IOPT(1)=IOP(2)
      IOPT(2)=IOP(3)
      IOPT(3)=IOP(4)
      IOPT(4)=IOP(5)
      IOPT(5)=0
      K = 0
C
  200 CONTINUE
      CALL TRANP(A,NA,DUMMY,NA)
      CALL EQUATE(DUMMY,NA,A,NA)
      CALL TRANP(H,NH,DUMMY,NDUM1)
      CALL EQUATE(DUMMY,NDUM1,H,NH)
      IF( IDENT )  GO TO 250
      CALL TRANP(G,NG,DUMMY,NDUM1)
      CALL EQUATE(DUMMY,NDUM1,G,NG)
  250 CONTINUE
      IF ( K .EQ. 1 ) RETURN
C
      K = K+1
      CALL ASYREG(A,NA,H,NH,G,NG,Q,NQ,R,NR,F,NF,P,NP,IDENT,DISC,NEWT,ST
     1ABLE,FNULL,ALPHA,IOPT,DUMMY)
C
      N1=(NA(1)**2)+3*NA(1)+1
      CALL TRANP(F,NF,DUMMY(N1),NDUM1)
      CALL EQUATE(DUMMY(N1),NDUM1,F,NF)
C
      IF( IOP(1) .EQ. 0 ) GO TO 200
C
      IF(IDENT) GO TO 300
      CALL LNCNT(3)
      WRITE(6,55)
      CALL PRNT(Q,NQ,'GQGT',1)
C
  300 CONTINUE
      CALL LNCNT(3)
      WRITE(6,325)
  325 FORMAT(/' FILTER GAIN'/)
      CALL PRNT(F,NF,' F  ',1)
      CALL LNCNT(3)
      WRITE(6,350)
  350 FORMAT(/' STEADY-STATE VARIANCE MATRIX OF RECONSTRUCTION ERROR'/)
      CALL PRNT(P,NP,' P  ',1)
      NDUM1(1)=NP(1)
      NDUM1(2)=1
      CALL LNCNT(3)
      WRITE(6,375)
  375 FORMAT(/' EIGENVALUES OF P '/)
      CALL PRNT(DUMMY,NDUM1,'EVLP',1)
      N1 = NP(1) + 1
      N = NA(1)**2
      N2 = N1 + N + 2*NA(1)
      CALL TRANP(DUMMY(N1),NA,DUMMY(N2),NA)
      CALL PRNT(DUMMY(N2),NA,'A-FH',1)
      N2 = N1 + N
      CALL LNCNT(3)
      WRITE(6,385)
  385 FORMAT(/' EIGENVALUES OF A-FH MATRIX'/)
      NDUM1(1) = NA(1)
      NDUM1(2) =  2
      CALL PRNT(DUMMY(N2),NDUM1,0,3)
C
      GO TO 200
C
      END


! MIT License
!
! Copyright (c) 2010-present David A. Kopriva and other contributors: AUTHORS.md
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!
! HOHQMesh contains code that, to the best of our knowledge, has been released as
! public domain software:
! * `b3hs_hash_key_jenkins`: originally by Rich Townsend,
!    https://groups.google.com/forum/#!topic/comp.lang.fortran/RWoHZFt39ng, 2005
! * `fmin`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
! * `spline`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
! * `seval`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
!
! --- End License
!
!////////////////////////////////////////////////////////////////////////
!
!      Geometry.F95
!      Created: 2010-08-17 14:39:19 -0400
!      By: David Kopriva
!
!////////////////////////////////////////////////////////////////////////
!
      Module Geometry
      USE SMConstants
      USE ProgramGlobals
      IMPLICIT NONE
!
!-------------------------------------------------------------------
!> Define generic geometry operations and constants
!-------------------------------------------------------------------
!
      INTEGER, PARAMETER :: UP = 1, DOWN = -1, CO_LINEAR = 0
      INTEGER, PARAMETER :: CLOCKWISE = 1, COUNTERCLOCKWISE = -1, NO_DIRECTION  = 0
!
!     ========
      CONTAINS
!     ========
!
!////////////////////////////////////////////////////////////////////////
!
      PURE FUNCTION CrossProductDirection(u,v) RESULT(d)
         IMPLICIT NONE
         REAL(KIND=RP), DIMENSION(3), INTENT(IN) :: u, v
         INTEGER                                 :: d
         REAL(KIND=RP)                           :: c
         c = u(1)*v(2) - v(1)*u(2)
         IF( ABS(c) < EPSILON(c)     )   THEN
            d = CO_LINEAR
         ELSE
            d = INT(SIGN( 1.0_RP, c ))
         END IF
      END FUNCTION CrossProductDirection
!
!////////////////////////////////////////////////////////////////////////
!
      FUNCTION Curvature( xPrime, xDoublePrime ) RESULT(c)
         IMPLICIT NONE
         REAL(KIND=RP) :: xPrime(3), xDoublePrime(3), c

         c = ABS( xPrime(1)*xDoublePrime(2) - xPrime(2)*xDoublePrime(1) ) &
                          /(xPrime(1)**2 + xPrime(2)**2)**1.5_RP

      END FUNCTION Curvature
!
!////////////////////////////////////////////////////////////////////////
!
      INTEGER FUNCTION Circulation(x)
         IMPLICIT NONE
         REAL(KIND=RP) :: x(:,:)
         INTEGER       :: N, j
         REAL(KIND=RP) :: s

         N = SIZE(x,2)
         s = 0.0_RP
         DO j = 1,N-1
            s = s + x(1,j)*x(2,j+1) - x(1,j+1)*x(2,j)
         END DO
         s = s + x(1,N)*x(2,1) - x(1,1)*x(2,N)
         IF(s > 0.0_RP) THEN
            Circulation = COUNTERCLOCKWISE
         ELSE IF (s < 0.0_RP)     THEN
            Circulation = CLOCKWISE
         ELSE
            CIRCULATION = NO_DIRECTION
         END IF

      END FUNCTION Circulation
!
!////////////////////////////////////////////////////////////////////////
!
      FUNCTION PointInQuad( nodes, x ) RESULT(r)
         IMPLICIT NONE
         REAL(KIND=RP), DIMENSION(3,4) :: nodes
         REAL(KIND=RP), DIMENSION(3)   :: x
         LOGICAL                       :: r

         REAL(KIND=RP), DIMENSION(3,5) :: cNodes
         INTEGER                       :: k
         REAL(KIND=RP), DIMENSION(3)   :: u, v

         cNodes(:,1:4) = nodes
         cNodes(:,5)   = nodes(:,1)
         r = .true.

         DO k = 1,4
            u = cNodes(:,k+1) - cNodes(:,k)
            v = x - cNodes(:,k)
            IF( CrossProductDirection(u,v) == DOWN )     THEN
               r = .false.
               EXIT
            END IF
         END DO

      END FUNCTION PointInQuad
!
!////////////////////////////////////////////////////////////////////////
!
      LOGICAL FUNCTION Box_IsInsideBox(testBox,box)
         IMPLICIT NONE
!
!        ---------
!        Arguments
!        ---------
!
         REAL(KIND=RP) :: box(6), testBox(6)
!
!        ---------------
!        Local variables
!        ---------------
!
         REAL(KIND=RP) :: p(3)

         Box_IsInsideBox = .true.
!
!        -----------------------------------
!        Check bottom left corner of testBox
!        -----------------------------------
!
         p = [testBox(BBOX_LEFT), testBox(BBOX_BOTTOM), 0.0_RP]
         IF ( .NOT.Point_IsInsideBox(p,box) )     THEN
            Box_IsInsideBox = .false.
            RETURN
         END IF
!
!        -----------------------------------
!        Check upper right corner of testBox
!        -----------------------------------
!
         p = [testBox(BBOX_RIGHT), testBox(BBOX_TOP), 0.0_RP]
         IF ( .NOT.Point_IsInsideBox(p,box) )     THEN
            Box_IsInsideBox = .false.
         END IF

      END FUNCTION Box_IsInsideBox
!
!////////////////////////////////////////////////////////////////////////
!
      PURE LOGICAL FUNCTION Point_IsInsideBox(p,bBox)
         IMPLICIT NONE
         REAL(KIND=RP), INTENT(IN)  :: p(3)
         REAL(KIND=RP), INTENT(IN)  :: bBox(6)

         Point_IsInsideBox = .true.

         IF ( p(1) < bBox(BBOX_LEFT) )     THEN
            Point_IsInsideBox = .false.
            RETURN
         END IF

         IF ( p(1) > bBox(BBOX_RIGHT) )     THEN
            Point_IsInsideBox = .false.
            RETURN
         END IF

         IF ( p(2) > bBox(BBOX_TOP) )     THEN
            Point_IsInsideBox = .false.
            RETURN
         END IF

         IF ( p(2) < bBox(BBOX_BOTTOM) )     THEN
            Point_IsInsideBox = .false.
            RETURN
         END IF

      END FUNCTION Point_IsInsideBox
!
!////////////////////////////////////////////////////////////////////////
!
      PURE REAL(KIND=RP) FUNCTION BoundingBoxArea(bBox)
         IMPLICIT NONE
         REAL(KIND=RP), INTENT(IN) :: bBox(6)
         BoundingBoxArea = (bBox(BBOX_RIGHT) - bBox(BBOX_LEFT))*   &
                           (bBox(BBOX_TOP)   - bBox(BBOX_BOTTOM))
      END FUNCTION BoundingBoxArea
!
!////////////////////////////////////////////////////////////////////////
!
      PURE LOGICAL FUNCTION BBoxIntersects(boxA, boxB)
         IMPLICIT NONE
         REAL(KIND=RP), INTENT(IN) :: boxA(6), boxB(6)

         BBoxIntersects = .TRUE.

         IF( boxB(BBOX_LEFT)   > boxA(BBOX_RIGHT)   .OR. &
             boxB(BBOX_RIGHT)  < boxA(BBOX_LEFT)    .OR. &
             boxB(BBOX_TOP)    < boxA(BBOX_BOTTOM)  .OR. &
             boxB(BBOX_BOTTOM) > boxA(BBOX_TOP)          &
           ) BBoxIntersects = .FALSE.

      END FUNCTION BBoxIntersects
!
!////////////////////////////////////////////////////////////////////////
!
      PURE LOGICAL FUNCTION BBoxIsNested(boxA, boxB)
!
!     ------------------------------
!     Test if boxB is nested in boxA
!     ------------------------------
!
         IMPLICIT NONE
         REAL(KIND=RP), INTENT(IN) :: boxA(6), boxB(6)

         BBoxIsNested = .FALSE.

         IF( boxB(BBOX_LEFT)   > boxA(BBOX_LEFT)     .AND. &
             boxB(BBOX_RIGHT)  < boxA(BBOX_RIGHT)    .AND. &
             boxB(BBOX_TOP)    < boxA(BBOX_TOP)      .AND. &
             boxB(BBOX_BOTTOM) > boxA(BBOX_BOTTOM)         &
           ) BBoxIsNested = .TRUE.

      END FUNCTION BBoxIsNested
!
!////////////////////////////////////////////////////////////////////////
!
      FUNCTION IntersectionOfBBoxes(boxA, boxB) RESULT(newBox)
      IMPLICIT NONE
          REAL(KIND=RP) :: boxA(6), boxB(6), newBox(6)
          newBox = 0.0_RP

          newBox(BBOX_LEFT)   = MAX(boxA(BBOX_LEFT)  , boxB(BBOX_LEFT))
          newBox(BBOX_BOTTOM) = MAX(boxA(BBOX_BOTTOM), boxB(BBOX_BOTTOM))
          newBox(BBOX_TOP)    = MIN(boxA(BBOX_TOP)   , boxB(BBOX_TOP))
          newBox(BBOX_RIGHT)  = MIN(boxA(BBOX_RIGHT) , boxB(BBOX_RIGHT))

      END FUNCTION IntersectionOfBBoxes
!
!////////////////////////////////////////////////////////////////////////
!
      FUNCTION ACWindingFunction( p, curvePoints, N ) RESULT(w)
!
!     ---------------------------------------------------------------------
!>     Find if the the point p(2) is inside of a closed curve discretized by
!!     curvePoints. Closed means that curvePoints(:,N+1) = curvePoints(:,0).
!!     Computes a constant factor (2\Pi) times the winding function using an
!!     axis crossing method. This version sets winding function = 0 if the
!!     point is on the curve. w = 0 => outside. This version uses integer
!!     arithmetic to compute w.
!     ---------------------------------------------------------------------
!
      USE SMConstants
      IMPLICIT NONE
!
!     ---------
!     Arguments
!     ---------
!
      INTEGER       :: N
      REAL(KIND=RP) :: p(3)               ! = (x,y,z)
      REAL(KIND=RP) :: curvePoints(3,0:N) ! = (x_i,y_j,z_j) i = 0, 1, \ldots , N
      INTEGER       :: w
!
!     ---------------
!     local variables
!     ---------------
!
      REAL(KIND=RP) :: v(3,0:N+1)
      INTEGER       :: i
      REAL(KIND=RP) :: r, x, y, xp, yp

      DO i = 0, N
         v(:,i) = curvePoints(:,i) - p
      END DO
      v(:,N+1) = v(:,0)

      w           = 0
      DO i = 0, N
         x           = v(1,i)  ; y  = v(2,i)
         xp          = v(1,i+1); yp = v(2,i+1)

         IF( AlmostEqual(y,0.0_RP) .AND. AlmostEqual(yp,0.0_RP) )     THEN
            IF( x <= 0.0_RP .AND. xp >= 0.0_RP )     THEN ! point is on this segment
               w = 0
               RETURN
            ELSE
               CYCLE
            END IF
         END IF

         IF ( y*yp < 0.0_RP )     THEN
            r = x + y*(xp-x)/(y-yp)
            IF ( r > 0 )     THEN
               IF ( y < 0.0_RP )     THEN
                  w = w + 2
               ELSE
                  w = w - 2
               END IF
            ELSE IF ( AlmostEqual(r,0.0_RP) )     THEN
               w = 0
               RETURN
            END IF
         ELSE IF ( (y == 0.0_RP) .AND. (x > 0.0_RP) )     THEN
            IF ( yp > 0 )     THEN
               w = w + 1
            ELSE
               w = w - 1
            END IF
         ELSE IF ( (yp == 0.0_RP) .AND. (xp > 0.0_RP) )     THEN
            IF ( y < 0 )     THEN
               w = w + 1
            ELSE
               w = w - 1
            END IF
         END IF
      END DO

      END FUNCTION ACWindingFunction
!
!////////////////////////////////////////////////////////////////////////
!
      PURE LOGICAL FUNCTION AlmostEqual( x, y )
      USE SMConstants
      IMPLICIT NONE
      REAL(KIND=RP), INTENT(IN) :: x, y

      AlmostEqual = ABS(x - y) < 100*EPSILON(1.0_RP)

      END FUNCTION AlmostEqual
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE ComputeCentroid(x,centroid)
         IMPLICIT NONE
!
!        ---------
!        Arguments
!        ---------
!
         REAL(KIND=RP) :: x(3,4)
         REAL(KIND=RP) :: centroid(3)
!
!        ---------------
!        Local Variables
!        ---------------
!
         INTEGER       :: i, k
         REAL(KIND=RP) :: area, tmp

         INTEGER, EXTERNAL :: Loop

         centroid = 0.0_RP
         area     = 0.0_RP
         DO i = 1, 4
            k    = Loop(i+1,4)
            tmp  = x(1,i)*x(2,k) - x(1,k)*x(2,i)
            area = area + tmp
            centroid = centroid + (x(:,i) + x(:,k))*tmp
         END DO
         area     = 0.5*area
         centroid = centroid/(6*area)

      END SUBROUTINE ComputeCentroid

      END Module Geometry


!==============================================================================!
  subroutine User_Mod_End_Of_Time_Step(flow, turb, mult, swarm, n, time)
!------------------------------------------------------------------------------!
!   This function is computing benchmark for rising bubble.                    !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Field_Type),      target :: flow
  type(Turb_Type),       target :: turb
  type(Multiphase_Type), target :: mult
  type(Swarm_Type),      target :: swarm
  integer                       :: n     ! time step
  real                          :: time  ! physical time
!--------------------------------[Locals]--------------------------------------!
  type(Grid_Type), pointer :: grid
  type(Var_Type),  pointer :: vof
  integer                  :: c, last_cell
  real                     :: b_volume, surface, rise_velocity,  &
                              circularity, c_position
!==============================================================================!

  ! Take aliases
  grid => flow % pnt_grid
  vof  => mult % vof

  !-------------------!
  !   Bubble volume   !
  !-------------------!
  b_volume = 0.0
  surface = 0.0
  c_position = 0.0
  rise_velocity = 0.0

  do c = 1, grid % n_cells - grid % comm % n_buff_cells
    b_volume = b_volume + grid % vol(c) * vof % n(c)
    surface = surface + sqrt(vof % x(c) ** 2                                  &
                           + vof % y(c) ** 2                                  &
                           + vof % z(c) ** 2) * grid % vol(c)
    c_position = c_position + grid % zc(c) * vof % n(c) * grid % vol(c)
    rise_velocity = rise_velocity + flow % w % n(c) * vof % n(c) * grid % vol(c)
  end do

  call Comm_Mod_Global_Sum_Real(b_volume)
  call Comm_Mod_Global_Sum_Real(surface)
  call Comm_Mod_Global_Sum_Real(c_position)
  call Comm_Mod_Global_Sum_Real(rise_velocity)

  if (this_proc < 2) then
!    !with circularity:
!    open(unit = 70359, file='Bench-data.dat',position='APPEND')
!      write(70359,*) b_volume, 2.0*PI/surface*sqrt(b_volume/PI),              &
!                 c_position/b_volume, rise_velocity/b_volume
!    close(70359)

    !with sphericity:
    open(unit = 70359, file='bench-data.dat',position='APPEND')
      write(70359,*) b_volume, PI**(1.0/3.0)*(6.0*b_volume)**(2.0/3.0)/surface,         &
                 c_position/b_volume, rise_velocity/b_volume
    close(70359)
  end if

  end subroutine


! tests FORALL statements with a mask
program forall_7
  real, dimension (5, 5, 5, 5) :: a, b, c, d

  a (:, :, :, :) = 4
  forall (i = 1:5)
    a (i, i, 6 - i, i) = 7
  end forall
  forall (i = 1:5)
    a (i, 6 - i, i, i) = 7
  end forall
  forall (i = 1:5)
    a (6 - i, i, i, i) = 7
  end forall
  forall (i = 1:5:2)
    a (1, 2, 3, i) = 0
  end forall

  b = a
  c = a
  d = a

  forall (i = 1:5, j = 1:5, k = 1:5, ((a (i, j, k, i) .gt. 6) .or. (a (i, j, k, j) .gt. 6)))
    forall (l = 1:5, a (1, 2, 3, l) .lt. 2)
      a (i, j, k, l) = i - j + k - l + 0.5
    end forall
  end forall

  forall (l = 1:5, b (1, 2, 3, l) .lt. 2)
    forall (i = 1:5, j = 1:5, k = 1:5, ((b (i, j, k, i) .gt. 6) .or. (b (i, j, k, j) .gt. 6)))
      b (i, j, k, l) = i - j + k - l + 0.5
    end forall
  end forall

  forall (i = 1:5, j = 1:5, k = 1:5, ((c (i, j, k, i) .gt. 6) .or. (c (i, j, k, j) .gt. 6)))
    forall (l = 1:5, c (1, 2, 3, l) .lt. 2)
      c (i, j, k, l) = i - j + k - l + 0.5 + c (l, k, j, i)
    end forall
  end forall

  forall (l = 1:5, d (1, 2, 3, l) .lt. 2)
    forall (i = 1:5, j = 1:5, k = 1:5, ((d (i, j, k, i) .gt. 6) .or. (d (i, j, k, j) .gt. 6)))
      d (i, j, k, l) = i - j + k - l + 0.5 + d (l, k, j, i)
    end forall
  end forall

  do i = 1, 5
    do j = 1, 5
      do k = 1, 5
	do l = 1, 5
	  r = 4
	  if ((i == j .and. k == 6 - i) .or. (i == k .and. j == 6 - i)) then
	    if (l /= 2 .and. l /= 4) then
	      r = 1
	    elseif (l == i) then
	      r = 7
	    end if
	  elseif (j == k .and. i == 6 - j) then
	    if (l /= 2 .and. l /= 4) then
	      r = 1
	    elseif (l == j) then
	      r = 7
	    end if
	  elseif (i == 1 .and. j == 2 .and. k == 3 .and. l /= 2 .and. l /= 4) then
	    r = 0
	  end if
	  s = r
	  if (r == 1) then
	    r = i - j + k - l + 0.5
	    if (((l == k .and. j == 6 - l) .or. (l == j .and. k == 6 - l)) .and. (i == l)) then
	      s = r + 7
	    elseif (k == j .and. l == 6 - k .and. i == k) then
	      s = r + 7
	    elseif (l /= 1 .or. k /= 2 .or. j /= 3 .or. i == 2 .or. i == 4) then
	      s = r + 4
	    else
	      s = r
	    end if
	  end if
	  if (a (i, j, k, l) /= r) call abort ()
	  if (c (i, j, k, l) /= s) call abort ()
	end do
      end do
    end do
  end do

  if (any (a /= b .or. c /= d)) call abort ()
end


program visual_tests

    use iso_fortran_env
    use sobseq
    use ogpf

    integer, parameter :: N_samples = 1024

    type(multi_dim_sobol_state) :: md_rng
    type(gpf) :: gp

    real(real64), dimension(:,:), allocatable :: seq

    allocate(seq(N_samples, 4))

    md_rng = multi_dim_sobol_state(4)

    call gp%title("Sobol Sequence Visualization")
    call gp%xlabel("Dimension 1")
    call gp%ylabel("Dimension 2")

    call md_rng%populate(seq)
    call gp%plot(seq(:,1), seq(:,2:), "with points")

    call execute_command_line("rm ogpf_temp_script.gp")

end program visual_tests


      SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, INFO )
*
*  -- LAPACK routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, M, N
*     ..
*     .. Array Arguments ..
      COMPLEX            A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  CUNMR2 overwrites the general complex m-by-n matrix C with
*
*        Q * C  if SIDE = 'L' and TRANS = 'N', or
*
*        Q'* C  if SIDE = 'L' and TRANS = 'C', or
*
*        C * Q  if SIDE = 'R' and TRANS = 'N', or
*
*        C * Q' if SIDE = 'R' and TRANS = 'C',
*
*  where Q is a complex unitary matrix defined as the product of k
*  elementary reflectors
*
*        Q = H(1)' H(2)' . . . H(k)'
*
*  as returned by CGERQF. Q is of order m if SIDE = 'L' and of order n
*  if SIDE = 'R'.
*
*  Arguments
*  =========
*
*  SIDE    (input) CHARACTER*1
*          = 'L': apply Q or Q' from the Left
*          = 'R': apply Q or Q' from the Right
*
*  TRANS   (input) CHARACTER*1
*          = 'N': apply Q  (No transpose)
*          = 'C': apply Q' (Conjugate transpose)
*
*  M       (input) INTEGER
*          The number of rows of the matrix C. M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix C. N >= 0.
*
*  K       (input) INTEGER
*          The number of elementary reflectors whose product defines
*          the matrix Q.
*          If SIDE = 'L', M >= K >= 0;
*          if SIDE = 'R', N >= K >= 0.
*
*  A       (input) COMPLEX array, dimension
*                               (LDA,M) if SIDE = 'L',
*                               (LDA,N) if SIDE = 'R'
*          The i-th row must contain the vector which defines the
*          elementary reflector H(i), for i = 1,2,...,k, as returned by
*          CGERQF in the last k rows of its array argument A.
*          A is modified by the routine but restored on exit.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A. LDA >= max(1,K).
*
*  TAU     (input) COMPLEX array, dimension (K)
*          TAU(i) must contain the scalar factor of the elementary
*          reflector H(i), as returned by CGERQF.
*
*  C       (input/output) COMPLEX array, dimension (LDC,N)
*          On entry, the m-by-n matrix C.
*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
*
*  LDC     (input) INTEGER
*          The leading dimension of the array C. LDC >= max(1,M).
*
*  WORK    (workspace) COMPLEX array, dimension
*                                   (N) if SIDE = 'L',
*                                   (M) if SIDE = 'R'
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            ONE
      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      INTEGER            I, I1, I2, I3, MI, NI, NQ
      COMPLEX            AII, TAUI
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           CLACGV, CLARF, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CONJG, MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
*
*     NQ is the order of Q
*
      IF( LEFT ) THEN
         NQ = M
      ELSE
         NQ = N
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CUNMR2', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
     $   RETURN
*
      IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN
         I1 = 1
         I2 = K
         I3 = 1
      ELSE
         I1 = K
         I2 = 1
         I3 = -1
      END IF
*
      IF( LEFT ) THEN
         NI = N
      ELSE
         MI = M
      END IF
*
      DO 10 I = I1, I2, I3
         IF( LEFT ) THEN
*
*           H(i) or H(i)' is applied to C(1:m-k+i,1:n)
*
            MI = M - K + I
         ELSE
*
*           H(i) or H(i)' is applied to C(1:m,1:n-k+i)
*
            NI = N - K + I
         END IF
*
*        Apply H(i) or H(i)'
*
         IF( NOTRAN ) THEN
            TAUI = CONJG( TAU( I ) )
         ELSE
            TAUI = TAU( I )
         END IF
         CALL CLACGV( NQ-K+I-1, A( I, 1 ), LDA )
         AII = A( I, NQ-K+I )
         A( I, NQ-K+I ) = ONE
         CALL CLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAUI, C, LDC, WORK )
         A( I, NQ-K+I ) = AII
         CALL CLACGV( NQ-K+I-1, A( I, 1 ), LDA )
   10 CONTINUE
      RETURN
*
*     End of CUNMR2
*
      END


module KLresearch
  use utilities
  implicit none

CONTAINS
  ! print statements in this module use # 400-499

  subroutine KL_eigenvaluemain()
  !This subroutine is the interface for 'KL_eigenvalue' so that values can be passed to
  !it by reference.
  use KLvars, only: alphas1,Aks1,Eigs1,numEigss1, alphaa1,Aka1,Eiga1,numEigsa1,&
                    alphas2,Aks2,Eigs2,numEigss2, alphaa2,Aka2,Eiga2,numEigsa2,&
                    fls1, fla1, fls2, fla2, cheftypes1,cheftypea1,cheftypes2,cheftypea2, &
                    eigvecss1,eigvecsa1,eigvecss2,eigvecsa2, lamctypes1,lamctypea1,lamctypes2,lamctypea2,&
                    numNystroms1,numNystroma1,numNystroms2,numNystroma2, &
                    pltEigf, chGausstype
  use genRealzvars, only: lamcs1,lamca1,lamcs2,lamca2, GBaves1,GBavea1,GBaves2,GBavea2,&
                    GBvars1,GBvara1,GBvars2,GBvara2, slen
  use utilities, only: numerical_eigmodesolve

  if(fls1) then
    if(lamctypes1=='Glamc' .or. lamctypes1=='fitlamc') call KL_eigenvalue(alphas1,Aks1,Eigs1,numEigss1,lamcs1)
    if(lamctypes1=='numeric')  call numerical_eigmodesolve(chGausstype,slen,GBaves1,GBvars1,&
                                                   lamcs1,numEigss1,numNystroms1,Eigs1,eigvecss1)
    if(pltEigf(1) .ne. 'noplot') call KL_eigenfunction_plot(Aks1,alphas1,lamcs1,lamctypes1,cheftypes1,&
                                                     numNystroms1,slen,eigvecss1,GBaves1,GBvars1,Eigs1)
  endif
  if(fla1) then
    if(lamctypea1=='Glamc' .or. lamctypea1=='fitlamc') call KL_eigenvalue(alphaa1,Aka1,Eiga1,numEigsa1,lamca1)
    if(lamctypea1=='numeric')  call numerical_eigmodesolve(chGausstype,slen,GBavea1,GBvara1,&
                                                   lamca1,numEigsa1,numNystroma1,Eiga1,eigvecsa1)
    if(pltEigf(1) .ne. 'noplot') call KL_eigenfunction_plot(Aka1,alphaa1,lamca1,lamctypea1,cheftypea1,&
                                                     numNystroma1,slen,eigvecsa1,GBavea1,GBvara1,Eiga1)
  endif
  if(fls2) then
    if(lamctypes2=='Glamc' .or. lamctypes2=='fitlamc') call KL_eigenvalue(alphas2,Aks2,Eigs2,numEigss2,lamcs2)
    if(lamctypes2=='numeric')  call numerical_eigmodesolve(chGausstype,slen,GBaves2,GBvars2,&
                                                   lamcs2,numEigss2,numNystroms2,Eigs2,eigvecss2)
    if(pltEigf(1) .ne. 'noplot') call KL_eigenfunction_plot(Aks2,alphas2,lamcs2,lamctypes2,cheftypes2,&
                                                     numNystroms2,slen,eigvecss2,GBaves2,GBvars2,Eigs2)
  endif
  if(fla2) then
    if(lamctypea2=='Glamc' .or. lamctypea2=='fitlamc') call KL_eigenvalue(alphaa2,Aka2,Eiga2,numEigsa2,lamca2)
    if(lamctypea2=='numeric')  call numerical_eigmodesolve(chGausstype,slen,GBavea2,GBvara2,&
                                                     lamca2,numEigsa2,numNystroma2,Eiga2,eigvecsa2)
    if(pltEigf(1) .ne. 'noplot') call KL_eigenfunction_plot(Aka2,alphaa2,lamca2,lamctypea2,cheftypea2,&
                                                     numNystroma2,slen,eigvecsa2,GBavea2,GBvara2,Eiga2)
  endif

  end subroutine KL_eigenvaluemain

  function Eigenvalue( gam,lamc )
  !Solves value of eigenvalues based on transcendental solution gamma.
  real(8) :: gam, lamc, Eigenvalue
  Eigenvalue = 2d0 * lamc / (gam**2 + 1d0)
  end function Eigenvalue

  subroutine KL_eigenfunction_plot(Ak,alpha,lamc,lamctype,cheftype,numNystrom,s,eigvecs,ave,var,Eig)
  !This subroutine plots for the eigenmode of choice according to options in the input file
  use KLvars,       only: pltEigf, pltEigfwhich, pltEigfnumof, numSlice
  use KLconstruct, only: Eigfunc
  real(8) :: alpha(:),Ak(:),Eig(:),lamc,s,eigvecs(:,:),ave,var
  character(*) :: lamctype,cheftype
  integer :: numNystrom

  integer :: i,j,curEig
  real(8) :: sliceSize
  real(8),allocatable :: Eigfplotarray(:,:)

  allocate(Eigfplotarray(numSlice,numSlice+1))

  sliceSize = s/numSlice
  do i=1,numSlice
    Eigfplotarray(i,1) = sliceSize*i-sliceSize/2
    do j=1,pltEigfnumof
      curEig=pltEigfwhich(j)
      Eigfplotarray(i,j+1) = Eigfunc( Ak(curEig),alpha(curEig),lamc,Eigfplotarray(i,1),0,        &
                                      lamctype,cheftype,numNystrom,s,eigvecs(curEig,:),&
                                      ave,var,Eig(curEig)  )
    enddo
  enddo

  call generic_plotter( numSlice,pltEigfnumof,Eigfplotarray,pltEigf )

  call system("mv genericplot.txt plots/Eigfplot/Eigfplot.txt")
  call system("mv genericplot.ps  plots/Eigfplot/Eigfplot.ps")
  call system("mv genericplot.pdf plots/Eigfplot/Eigfplot.pdf")

  end subroutine KL_eigenfunction_plot

  subroutine KL_eigenvalue(alpha,Ak,Eig,numEigs,lamc)
  !This subroutine: 1) calculates some initial values used here
  !2) Solves the transcendental equation which yields gamma
  !3) From gamma solves: alpha, lambda (Eigenvalue), & the normalization const A_k
  !4) Prints and plots Eigenfunctions if input specifies
  !5) Calculates the percent of mean standard error maintained
  use genRealzvars, only: slen!, chgeomtype, GBaves1, GBavea1, aves1, avea1
  use KLvars,       only: levsrefEig
  use KLconstruct, only: Eigfunc

  real(8) :: alpha(:),Ak(:),Eig(:),lamc
  integer :: numEigs

  real(8) :: stepGam=0 !if 0 code chooses
  integer :: l,level,curEig
  real(8) :: refstepGam,TT,curGam!,tc
  real(8) :: absdiff,absdiff_1=0,absdiff_2=0,testval(numEigs)
  real(8),allocatable :: gam(:)

  TT = slen/lamc
  if( stepGam==0 ) stepGam  =1/TT/50
  allocate(gam(numEigs))
  gam = 0.0d0

  !Initial guesses for Gam
  420 format(i7,"     ",f15.9," ",f19.14)

  write(*,*) " Calculating Eigenvalues for computation and varaince "
  write(*,*) "          Eigindx    Gam vals       Eig vals         tol check         tol "

  !solve gamma approximate values
  curGam = 0.000000001d0
  curEig = 1
  open(unit=11, file="absdiffGam.txt")
  do
    absdiff=abs( tan(curGam*TT)-(2d0*curGam)/(curGam**2-1d0) )
    write(11,420) curEig,curGam,absdiff
    if( absdiff_2>absdiff_1 .and. absdiff>absdiff_1 ) then
      !write(*,420) curEig,curGam,absdiff_1
      gam(curEig)=curGam
      if(curEig==numEigs) exit
      curEig=curEig+1
    endif
    absdiff_2=absdiff_1
    absdiff_1=absdiff
    curGam=curGam+stepGam
  enddo
  close(unit=11)
  call system("mv absdiffGam.txt texts/")

  !refine gamma values and solve eigenvalues
  do curEig=1,numEigs                  !loop each Eigenvalue
    refstepGam=stepGam

    do level=1,levsrefEig                 !loop levels of refinement
      curGam=gam(curEig)-11d0*refstepGam
      refstepGam=refstepGam/10
      absdiff_1=0
      absdiff_2=0

      do l=1,220                            !loop through range & test
        absdiff=abs( tan(curGam*TT)-(2d0*curGam)/(curGam**2-1d0) )
        if( absdiff_2>absdiff_1 .AND. absdiff>absdiff_1 ) then
          !write(*,421) curEig,curGam,absdiff_1,level
          !if(level==levsrefEig) write(*,421) curEig,curGam,absdiff_1,level
          gam(curEig)=curGam
        endif
        absdiff_2=absdiff_1
        absdiff_1=absdiff
        curGam=curGam+refstepGam
      enddo
    enddo
    if(gam(curEig)<0.0001d0) stop 'Very small Fredholm root found, investigate whether correct!'
    Eig(curEig) = Eigenvalue( gam(curEig),lamc )
  enddo

  write(*,*) "     Int test"
  do curEig=1,numEigs
    !Calc other values like alpha, norm const (Ak), eigenvalue, etc.
    alpha(curEig)   =gam(curEig)/lamc
    Ak(curEig)      =sqrt(1d0/(  slen/2d0*(gam(curEig)**2+1d0)+lamc  ))
    !integrate to 1 tests
    427 format("  ",f13.7,"   Ak:",f13.7)
    testval(curEig)=Ak(curEig)**2*0.5d0*( slen*(1+gam(curEig)**2)+&
                    lamc*(2d0- (sin(alpha(curEig)*slen))**2 ) )
    write(*,427) testval(curEig),Ak(curEig)

    !422 format("  curEig:",i4,"   gam:",f16.7,"   alpha:",f16.7)
    !423 format("                 Ak:",f16.7,"   Eig  :",f16.7)
    !write(*,422) curEig,gam(curEig),alpha(curEig)
    !write(*,423) Ak(curEig),Eig(curEig)
    !write(*,*)
  enddo

  write(*,*)
  write(*,*) "    Eigenvalues, their contributions, and KL maintained variance"
  write(*,*) "  Eigindx       Eig vals        sqrt(Eig)     [ differential / cumulative ] % mean sqr err maint"
!  426 format(i7,"     ",f15.9,"  ",f13.9,"     ",f13.9,"  ",f13.9)
!  if(chgeomtype=='binary') then
!    tc = aves1/(aves1+avea1)
!  elseif(chgeomtype=='contin') then
!    tc = GBaves1/(GBaves1+GBavea1)
!  endif
!  do curEig=1,numEigs
!    write(*,426) curEig,Eig(curEig),sqrt(Eig(curEig)),&
!                (   tc   *merge(Eig(curEig),0d0,curEig<=numEigss1) + &
!                 (1d0-tc)*merge(Eig(curEig),0d0,curEig<=numEigsa1)) / s,&
!                (   tc   *sum( Eig(:min(curEig,numEigss1)) ) + &
!                 (1d0-tc)*sum( Eig(:min(curEig,numEigsa1)) )) /s
!  enddo

  428 format("   lamc:           ",f8.3)
  429 format("   TT  :           ",f13.8)
  write(*,428) lamc
  write(*,429) TT
  write(*,*)

  end subroutine KL_eigenvalue

  subroutine KL_collect
  !This subroutine calculates xi values from binary Markov realizations.  It does
  !this by integrating over a variable related only to geometry-based material
  !properties so that it can later be used for any cross section material property.
  use rngvars, only: rngappnum, rngstride, mts
  use genRealzvars, only: sig, numRealz, nummatSegs, lamcs1, matType, matLength, P
  use KLvars, only: alphas1, Aks1, Eigs1, xi, numEigss1
  use MCvars, only: trannprt
  use genRealz, only: genbinaryReal
  use timeman, only: initialize_t1, timeupdate
  use mt_stream, only: init
  integer :: i,j,curEig,lsig,ssig
  real(8) :: xitermtot,xl,xr,xiterm,  hilowterm,aveterm
  character(5) :: flKLtype = 'KLcol'

  call initialize_t1

  write(*,*) "Starting method: ",flKLtype
  lsig = merge(1,2,sig(1)>sig(2))
  ssig = merge(1,2,sig(1)<sig(2))
  !advance rng
  call init( mts , int(rngappnum*rngstride,4) )
  rngappnum = rngappnum + 1

  do j=1,numRealz
    call genbinaryReal( j )
    do curEig=1,numEigss1
      xl       =0d0
      xiterm   =0d0
      xitermtot=0d0

      do i=2,nummatSegs+1
        xl=matLength(i-1)                                         !set xl and xr for calculations
        xr=matLength(i)
        hilowterm = merge(sqrt(P(ssig)/P(lsig)),-sqrt(P(lsig)/P(ssig)),matType(i-1)==lsig)
        aveterm   = 0d0

        xiterm= (hilowterm-aveterm)*&                                  !actual calculation
                (lamcs1*sin(alphas1(curEig)*xr)-cos(alphas1(curEig)*xr)/alphas1(curEig) &
                -lamcs1*sin(alphas1(curEig)*xl)+cos(alphas1(curEig)*xl)/alphas1(curEig))

        xitermtot = xitermtot + xiterm
      enddo
      xi(j,curEig) = (Aks1(curEig)/sqrt(Eigs1(curEig)))*xitermtot     !find resulting xi
    enddo

    if(mod(j,trannprt)==0) call timeupdate( 'KL_collect',j,numRealz )

  enddo

  end subroutine KL_collect

  subroutine KL_binrandvarvals
  !This subroutine puts xi values in bins.  It plots for those chosen in the
  !input file and also makes a .txt file containing PDFs of xi values for
  !each Eigenvalue calculated.
  use genRealzvars, only: numRealz
  use KLvars, only: xi, binPDF, binBounds, pltxiBinswhich, pltxiBinsnumof, binNumof, &
                    numEigss1, mostinBin, binSmallBound, binLargeBound, binSize, pltxiBins, &
                    pltxiBinsgauss
  real(8),allocatable :: binper(:,:)

  integer :: k,j,i,binCounts(binNumof,numEigss1+1),curEig,tnumRealz
  real(8) :: smallestxi,largestxi,xiOneD(numRealz)
  integer :: binCountsplotarray(binNumof,10),binCountsOneD(binNumof)
  real(8) :: probsum,meanxi,varxi
  real(8) :: pi=3.14159265358979d0
  real(8),allocatable :: binPDFplotarray(:,:)

  allocate(binPDF(binNumof,numEigss1+1))
  allocate(binper(binNumof,numEigss1+1))
  allocate(binPDFplotarray(binNumof,pltxiBinsnumof+1))
  allocate(binBounds(binNumof+1))

  binCounts = 0
  binBounds = 0
  mostinBin = 0

  smallestxi=minval(xi)  !get largest and smallest xi values
  largestxi=maxval(xi)

  if( binSmallBound==0 ) then        !set bounds for bins if needed
    binSmallBound=floor(smallestxi)
  endif
  if( binLargeBound==0 ) then
    binLargeBound=ceiling(largestxi)
  endif
  482 format("  smallestxi:",f24.5,"        largestxi:",f24.5)
  write(*,*)
  write(*,*)
  write(*,482) smallestxi,largestxi
  write(*,*)
  binSize = ( binLargeBound - binSmallBound ) / ( binNumof - 1 )
  binCountsplotarray = 0
  binPDFplotarray = 0

  !This section prints (and plots) for Eigs chosen to plot
  if( pltxiBins(1) .NE. 'noplot' ) then  !plot using generic plotter
    do i=1,pltxiBinsnumof  !up to 4 options, collect data to plot
      curEig    = pltxiBinswhich(1,i)
      tnumRealz = pltxiBinswhich(2,i)

      do j=1,numRealz   !prepare xi and binCounts for binner
        xiOneD(j) = xi(j,curEig)
      enddo
      binCountsOneD = 0
      call store_in_bins( binSmallBound,binLargeBound,binNumof,&
                          binCountsOneD,binBounds,xiOneD,tnumRealz )
      do k=1,binNumof    !collect binCounts from binner
        binCountsplotarray(k,i+1) = binCountsOneD(k)
      enddo

      probsum = 0  !transition data to PDF form to plot
      do k=1,binNumof
        binPDFplotarray(k,1)  =binBounds(k)+binSize/2
        binPDFplotarray(k,i+1)=real(binCountsplotarray(k,i+1),8)/&
                               real(tnumRealz,8)/binSize
        if( pltxiBinsgauss .EQ. 'gauss' .AND. i==pltxiBinsnumof ) then
          binPDFplotarray(k,i+1)=exp(-binPDFplotarray(k,1)**2/2)/(sqrt(2*pi))
        endif
        probsum=probsum+binPDFplotarray(k,i+1)*binSize
      enddo
      481 format("  curEig:",i3,"  tnumRealz:",i11,"   probsum:",f6.3)
      write(*,481) curEig,pltxiBinswhich(2,i),probsum
    enddo

    call generic_plotter( binNumof,pltxiBinsnumof,binPDFplotarray,pltxiBins )

    call system("mv genericplot.txt plots/xiBinsplot/xiBinsplot.txt")
    call system("mv genericplot.ps  plots/xiBinsplot/xiBinsplot.ps")
    call system("mv genericplot.pdf plots/xiBinsplot/xiBinsplot.pdf")
  endif

  !This section prints for all Eigs, not only those to plot
  write(*,*)
  do curEig=1,numEigss1
    do j=1,numRealz   !prepare xi and binCounts for binner
      xiOneD(j) = xi(j,curEig)
    enddo
    binCountsOneD = 0
    call store_in_bins( binSmallBound,binLargeBound,binNumof,&
                        binCountsOneD,binBounds,xiOneD,numRealz )
    do k=1,binNumof   !collect binCounts from binner, and track most
      binCounts(k,curEig+1) = binCountsOneD(k)
      if( binCountsOneD(k) > mostinBin) mostinBin = binCountsOneD(k)
    enddo

    probsum = 0
    meanxi  = 0
    varxi   = 0
    do k=1,binNumof
      binPDF(k,1) = binBounds(k)+binSize/2
      binPDF(k,curEig+1) = real(binCounts(k,curEig+1),8)/real(numRealz,8)/binSize
      binper(k,1) = binPDF(k,1)
      binper(k,curEig+1) = real(binCounts(k,curEig+1),8)/real(numRealz,8)*100.0d0
      probsum = probsum + binPDF(k,curEig+1) * binSize
      meanxi  = meanxi  + binPDF(k,curEig+1) * binSize * binPDF(k,1)
      varxi   = varxi   + binPDF(k,cureig+1) * binSize * binPDF(k,1) ** 2
    enddo
    483 format("  curEig:",i3,"   numRealz:",i11,"   probsum:",f6.3,"   meanxi:",f9.4,"   varxi:",f9.4)
    write(*,483) curEig,numRealz,probsum,meanxi,varxi
  enddo
  write(*,*)

  open(unit=1,file="xiBinsAll.txt")  !Print data to file
  open(unit=2,file="xiBinsper.txt")  !Print percentages to file
  do i=1,binNumof
    484 format(f12.6,"     ")
    485 format(f11.5," %    ")
    write(1,484,advance="no") binPDF(i,1)
    write(2,484,advance="no") binper(i,1)
    do j=2,numEigss1+1
      write(1,484,advance="no") binPDF(i,j)
      write(2,485,advance="no") binper(i,j)
    enddo
    write(1,*)
    write(2,*)
  enddo
  close(unit=1)
  close(unit=2)
  call system("mv xiBinsAll.txt plots/xiBinsplot")
  call system("mv xiBinsper.txt plots/xiBinsplot")

  end subroutine KL_binrandvarvals

  subroutine KL_Correlation
  !This subroutine calculates Correlation between two points in a
  !realization based upon the expected value, and the observed
  !value (function of Eigenfunctions and values).
  !It then plots in 3D if user has specified.
  use genRealzvars, only: slen, lamcs1, aves1, avea1, GBaves1, GBavea1, chgeomtype, GBvara1
  use KLvars, only: alphas1, Aks1, Eigs1, Corrnumpoints, Corropts, numEigss1, numEigsa1, &
                    lamctypea1,cheftypea1,numNystroma1,eigvecsa1,Eiga1
  use KLconstruct, only: Eigfunc

  integer :: x,y,curEig
  real(8) :: stepsize,curx,cury,Eigfx,Eigfy,tc
  real(8) :: Correxpect(Corrnumpoints,Corrnumpoints)
  real(8) :: Corryield(Corrnumpoints,Corrnumpoints)
  character(17) :: Corrchar = '"Correlation.txt"'
  character(22) :: Corre    = '"Correlation Expected"'
  character(22) :: Corry    = '"Correlation Yielded "'

  Correxpect = 0  !initialize
  Corryield  = 0

  stepsize = slen/(Corrnumpoints)  !set up stepsize

  if(chgeomtype=='binary') then
    tc = aves1/(aves1+avea1)
  elseif(chgeomtype=='contin') then
    tc = GBaves1/(GBaves1+GBavea1)
  endif

  do x=1,Corrnumpoints  !cycle through x and y
    if(x==1) curx=stepsize/2
    do y=1,Corrnumpoints
      if(y==1) cury=stepsize/2

      !calc Correxpect
      Correxpect(x,y) = exp( - abs(curx-cury)/lamcs1 )

      !sum Eigs to calc Corryield
      do curEig=1,numEigss1
        Eigfx = Eigfunc( Aks1(curEig),alphas1(curEig),lamcs1,curx,0,                &
                         lamctypea1,cheftypea1,numNystroma1,slen,eigvecsa1(curEig,:),&
                         GBavea1,GBvara1,Eiga1(curEig)  )
        Eigfy = Eigfunc( Aks1(curEig),alphas1(curEig),lamcs1,cury,0,                &
                         lamctypea1,cheftypea1,numNystroma1,slen,eigvecsa1(curEig,:),&
                         GBavea1,GBvara1,Eiga1(curEig)  )
        Corryield(x,y) = Corryield(x,y) + &
                         merge(    tc   *(Eigs1(curEig) * Eigfx * Eigfy),0d0,curEig<=numEigss1 ) + &
                         merge( (1d0-tc)*(Eigs1(curEig) * Eigfx * Eigfy),0d0,curEig<=numEigsa1 )
      enddo

      !print Correxpect and Corryield
      210 format("#       x                y            Correxpect        Corryield")
      211 format(" ",f12.6,"     ",f12.6,"     ",f12.6,"     ",f12.6)
      open(unit=15,file="Correlation.txt")
      if(x==1 .AND. y==1) write(15,210)
      write(15,211) curx,cury,Correxpect(x,y),Corryield(x,y)

      cury=cury+stepsize
    enddo !y-cycle
    curx=curx+stepsize
  enddo !x-cycle
  close(unit=15) !close file

  open(unit=16,file="Correlationfirst.gnu") !make custom gnu script
  212 format("set dgrid3d ",i10,",",i10)
  213 format("splot ",A17," using 1:2:3 with lines title ",A22)
  214 format("splot ",A17," using 1:2:4 with lines title ",A22)
  215 format("splot ",A17," using 1:2:3 with lines title ",A22,", ",A17," using 1:2:4 with lines title ",A22)
  219 format(A40)
  write(16,212) Corrnumpoints,Corrnumpoints
  write(16,219)'set view 60,130                         '
  write(16,219)'                                        '
  write(16,219)'set title "Positional Correlation Plots"'
  write(16,219)'set ylabel "\"y\" or \"x2\" position"   '
  write(16,219)'set xlabel "\"x\" or \"x1\" position"   '
  write(16,219)'                                        '
  if(Corropts(2)=='expect')  write(16,213) Corrchar,Corre
  if(Corropts(2)=='yield')   write(16,214) Corrchar,Corry
  if(Corropts(2)=='both')    write(16,215) Corrchar,Corre,Corrchar,Corry
  close(unit=16)

  if(Corropts(1)=='preview') then
    call system("cat Correlationfirst.gnu plots/Correlation/Corrps_pause.txt > Correlation.gnu")
  else
    call system("cat Correlationfirst.gnu plots/Correlation/Corrps.txt > Correlation.gnu")
  endif

  call system("gnuplot Correlation.gnu") !plot using gnuplot

  call system("ps2pdf Correlation.ps")         !convert to pdf

  call system("rm Correlationfirst.gnu")                       !clean up space
  call system("mv Correlation.txt Correlation.ps Correlation.pdf plots/Correlation")
  call system("mv Correlation.gnu plots/Correlation")
  end subroutine KL_Correlation

  subroutine KL_Cochart
  !This subroutine calculates the variance normalized to 1 at each point in the domain.
  !The closer to 1 the ratio is, the more efficient that approximation is.
  use genRealzvars, only: slen, numRealz, P, lamcs1, totLength, chgeomtype, aves1, avea1, &
                          GBaves1, GBavea1, GBvara1
  use KLvars,       only: alphas1, Aks1, Eigs1, pltCowhich, pltConumof, numSlice, &
                          pltCo, numEigss1, numEigsa1, lamctypea1,cheftypea1,numNystroma1,eigvecsa1,Eiga1
  use KLconstruct, only: Eigfunc

  integer :: curCS,curEig,check
  real(8) :: slicesize,cumCo,sliceval(numSlice),CoEff(numEigss1,numSlice)
  real(8) :: totLPer(2),tottotLength
  real(8) :: x,phi,tc
  real(8),allocatable :: Coplotarray(:,:)

  allocate(Coplotarray(numSlice,pltConumof+1))
  Coplotarray = 0

  !This is a statistical test of the reconstructions
  444 format("totLength(1):",f15.2,"    totLength(2):",f15.2,"    tottotLength:",f15.2)
  445 format("expLength(1):",f15.2,"    expLength(2):",f15.2,"    exptotLength:",f15.2)

  totLPer(1)=totLength(1)/(totLength(1)+totLength(2))
  totLPer(2)=totLength(2)/(totLength(1)+totLength(2))
  tottotLength=totLength(1)+totLength(2)
  write(*,*)
  write(*,444) totLength(1),totLength(2),tottotLength
  write(*,445) P(1)*slen*numRealz,P(2)*slen*numRealz,slen*numRealz

  slicesize=slen/numSlice     !prepare the places to slice and measure
  sliceval(1)=slicesize/2
  do curCS=2,numSlice
    sliceval(curCS)=sliceval(curCS-1)+slicesize
  enddo

  if(chgeomtype=='binary') then
    tc = aves1/(aves1+avea1)
  elseif(chgeomtype=='contin') then
    tc = GBaves1/(GBaves1+GBavea1)
  endif

  do curCS=1,numSlice      !calculate Co(ours)/Co; for slices
    cumCo=0
    x=sliceval(curCS)
    do curEig=1,numEigss1
      phi=Eigfunc( Aks1(curEig),alphas1(curEig),lamcs1,x,0,                   &
                   lamctypea1,cheftypea1,numNystroma1,slen,eigvecsa1(curEig,:),&
                   GBavea1,GBvara1,Eiga1(curEig)  )
      cumCo=cumCo+ merge(   tc   *Eigs1(curEig)*phi**2,0d0,curEig<=numEigsa1) &
                 + merge((1d0-tc)*Eigs1(curEig)*phi**2,0d0,curEig<=numEigss1)
      CoEff(curEig,curCS)=cumCo
    enddo
  enddo

  440 format("#    slicenum    sliceval ")
  441 format("     CoEff",i5)
  442 format("     ",i5,"     ",f10.6)
  443 format("     ",f10.6)

  open(unit=14, file="CoEff.txt")
  write(14,440,advance="no")
  do curEig=1,numEigss1
    write(14,441,advance="no") curEig
  enddo
  do curCS=1,numSlice       !print CoEff results to file
    write(14,*)
    write(14,442,advance="no") curCS,sliceval(curCS)
    do curEig=1,numEigss1
      write(14,443,advance="no") CoEff(curEig,curCS)
    enddo
  enddo

  call system("mv CoEff.txt texts/CoEffExp.txt")

  do check=1,pltConumof  !load values to plot according to selected options
    if( pltCo(1) .NE. 'noplot' ) then
      curEig = pltCowhich(check)
      do curCS=1,numSlice
        Coplotarray(curCS,1) = sliceval(curCS)
        Coplotarray(curCS,check+1) = CoEff(curEig,curCS)
      enddo
    endif
  enddo

  call generic_plotter( numSlice,pltConumof,Coplotarray,pltCo ) !plot

  call system("mv genericplot.txt plots/CoEffplot/CoEffplot.txt")
  call system("mv genericplot.ps  plots/CoEffplot/CoEffplot.ps")
  call system("mv genericplot.pdf plots/CoEffplot/CoEffplot.pdf")

  end subroutine KL_Cochart

end module KLresearch


! { dg-do compile }
! { dg-options "-ffrontend-optimize -finline-matmul-limit=0 -Wfunction-elimination" }
! Check the -ffrontend-optimize (in the absence of -O) and
! -Wfunction-elimination options.
program main
  implicit none
  real, dimension(2,2) :: a, b, c, d
  integer :: i
  real :: x, z
  character(60) :: line
  real, external :: ext_func
  interface
     elemental function element(x)
       real, intent(in) :: x
       real :: elem
     end function element
     pure function mypure(x)
       real, intent(in) :: x
       integer :: mypure
     end function mypure
     elemental impure function elem_impure(x)
       real, intent(in) :: x
       real :: elem_impure
     end function elem_impure
  end interface

  data a /2., 3., 5., 7./
  data b /11., 13., 17., 23./
  write (unit=line, fmt='(4F7.2)') matmul(a,b)  & ! { dg-warning "Removing call to function 'matmul'" }
       & + matmul(a,b)
  z = sin(x) + 2.0 + sin(x)  ! { dg-warning "Removing call to function 'sin'" }
  print *,z
  x = ext_func(a) + 23 + ext_func(a)
  print *,d,x
  z = element(x) + element(x) ! { dg-warning "Removing call to function 'element'" }
  print *,z
  i = mypure(x) - mypure(x) ! { dg-warning "Removing call to function 'mypure'" }
  print *,i
  z = elem_impure(x) - elem_impure(x)
  print *,z
end program main


subroutine bilin5(xa        ,ya        ,x0        ,y0        ,w         , &
                & ier       )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  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 version 3.
!
!  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.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: bilin5.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/tools_gpl/lint/packages/lint_f/src/bilin5.f90 $
!!--description-----------------------------------------------------------------
! NONE
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    implicit none
!
! Global variables
!
    integer, intent(out)           :: ier
    real(hp), intent(in)               :: x0
    real(hp), intent(in)               :: y0
    real(hp), dimension(4), intent(out) :: w
    real(hp), dimension(4), intent(in) :: xa
    real(hp), dimension(4), intent(in) :: ya
!
!
! Local variables
!
    real(hp)                           :: a
    real(hp)                           :: a21
    real(hp)                           :: a22
    real(hp)                           :: a31
    real(hp)                           :: a32
    real(hp)                           :: a41
    real(hp)                           :: a42
    real(hp)                           :: b
    real(hp)                           :: c
    real(hp)                           :: det
    real(hp)                           :: discr
    real(hp)                           :: eta
    real(hp)                           :: x
    real(hp)                           :: x1
    real(hp)                           :: x2
    real(hp)                           :: x3
    real(hp)                           :: x3t
    real(hp)                           :: x4
    real(hp)                           :: xi
    real(hp)                           :: xt
    real(hp)                           :: y
    real(hp)                           :: y1
    real(hp)                           :: y2
    real(hp)                           :: y3
    real(hp)                           :: y3t
    real(hp)                           :: y4
    real(hp)                           :: yt
!
!
!! executable statements -------------------------------------------------------
!
    !
    !
    ! Author: H. Petit
    !
    !
    !     read(12,*)x1,y1,f1
    x1 = xa(1)
    y1 = ya(1)
    !     read(12,*)x2,y2,f2
    x2 = xa(2)
    y2 = ya(2)
    !     read(12,*)x3,y3,f3
    x3 = xa(3)
    y3 = ya(3)
    !     read(12,*)x4,y4,f4
    x4 = xa(4)
    y4 = ya(4)
    x = x0
    y = y0
    ! The bilinear interpolation problem is first transformed
    ! to the quadrangle with nodes
    ! (0,0),(1,0),(x3t,y3t),(0,1)
    ! and required location (xt,yt)
    a21 = x2 - x1
    a22 = y2 - y1
    a31 = x3 - x1
    a32 = y3 - y1
    a41 = x4 - x1
    a42 = y4 - y1
    det = a21*a42 - a22*a41
    if (abs(det)<1D-20) then
       ! write (*, *) 'surface is zero'
       ier = 1
       goto 99999
    endif
    x3t = (a42*a31 - a41*a32)/det
    y3t = ( - a22*a31 + a21*a32)/det
    xt = (a42*(x - x1) - a41*(y - y1))/det
    yt = ( - a22*(x - x1) + a21*(y - y1))/det
    if ((x3t<.0_hp) .or. (y3t<.0_hp)) then
       ! write (*, *) 'distorted quadrangle'
       ier = 1
       goto 99999
    endif
    if (abs(x3t - 1.0)<1.0D-7) then
       xi = xt
       if (abs(y3t - 1.0)<1.0D-7) then
          eta = yt
       elseif (abs(1.0_hp + (y3t - 1.0_hp)*xt)<1.0D-6) then
          ! write (*, *) 'extrapolation over too large a distance'
          ier = 1
          goto 99999
       else
          eta = yt/(1.0_hp + (y3t - 1.0_hp)*xt)
       endif
    elseif (abs(y3t - 1.0_hp)<1.0D-6) then
       eta = yt
       if (abs(1.0_hp + (x3t - 1.0_hp)*yt)<1.D-6) then
          ! write (*, *) 'extrapolation over too large a distance'
          ier = 1
          goto 99999
       else
          xi = xt/(1.0_hp + (x3t - 1.0_hp)*yt)
       endif
    else
       a = y3t - 1._hp
       b = 1.0_hp + (x3t - 1.0_hp)*yt - (y3t - 1.0_hp)*xt
       c = -xt
       discr = b*b - 4.0_hp*a*c
       if (discr<1.0D-6) then
          ! write (*, *) 'extrapolation over too large a distance'
          ier = 1
          goto 99999
       endif
       xi = ( - b + sqrt(discr))/(2.0_hp*a)
       eta = ((y3t - 1.0_hp)*(xi - xt) + (x3t - 1.0_hp)*yt)/(x3t - 1.0_hp)
    endif
    w(1) = (1._hp - xi)*(1._hp - eta)
    w(2) = xi*(1._hp - eta)
    w(3) = xi*eta
    w(4) = eta*(1._hp - xi)
    return
99999 continue
end subroutine bilin5


      SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
!
!  -- Reference BLAS level3 routine (version 3.4.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2011
!
!     .. Scalar Arguments ..
      REAL*4           ALPHA,BETA
      INTEGER K,LDA,LDB,LDC,M,N
      CHARACTER TRANSA,TRANSB
!     ..
!     .. Array Arguments ..
      REAL*4           A(LDA,*),B(LDB,*),C(LDC,*)
!     ..
!
!  =====================================================================
!
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX
!     ..
!     .. Local Scalars ..
      REAL*4           TEMP
      INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
      LOGICAL NOTA,NOTB
!     ..
!     .. Parameters ..
      REAL*4           ONE,ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
!     ..
!
!     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
!     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
!     and  columns of  A  and the  number of  rows  of  B  respectively.
!
      NOTA = LSAME(TRANSA,'N')
      NOTB = LSAME(TRANSB,'N')
      IF (NOTA) THEN
          NROWA = M
          NCOLA = K
      ELSE
          NROWA = K
          NCOLA = M
      END IF
      IF (NOTB) THEN
          NROWB = K
      ELSE
          NROWB = N
      END IF
!
!     Test the input parameters.
!
      INFO = 0
      IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. &
          (.NOT.LSAME(TRANSA,'T'))) THEN
          INFO = 1
      ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. &
               (.NOT.LSAME(TRANSB,'T'))) THEN
          INFO = 2
      ELSE IF (M.LT.0) THEN
          INFO = 3
      ELSE IF (N.LT.0) THEN
          INFO = 4
      ELSE IF (K.LT.0) THEN
          INFO = 5
      ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
          INFO = 8
      ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
          INFO = 10
      ELSE IF (LDC.LT.MAX(1,M)) THEN
          INFO = 13
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('SGEMM ',INFO)
          RETURN
      END IF
!
!     Quick return if possible.
!
      IF ((M.EQ.0) .OR. (N.EQ.0) .OR. &
          (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
!
!     And if  alpha.eq.zero.
!
      IF (ALPHA.EQ.ZERO) THEN
          IF (BETA.EQ.ZERO) THEN
              DO 20 J = 1,N
                  DO 10 I = 1,M
                      C(I,J) = ZERO
   10             CONTINUE
   20         CONTINUE
          ELSE
              DO 40 J = 1,N
                  DO 30 I = 1,M
                      C(I,J) = BETA*C(I,J)
   30             CONTINUE
   40         CONTINUE
          END IF
          RETURN
      END IF
!
!     Start the operations.
!
      IF (NOTB) THEN
          IF (NOTA) THEN
!
!           Form  C := alpha*A*B + beta*C.
!
              DO 90 J = 1,N
                  IF (BETA.EQ.ZERO) THEN
                      DO 50 I = 1,M
                          C(I,J) = ZERO
   50                 CONTINUE
                  ELSE IF (BETA.NE.ONE) THEN
                      DO 60 I = 1,M
                          C(I,J) = BETA*C(I,J)
   60                 CONTINUE
                  END IF
                  DO 80 L = 1,K
                      IF (B(L,J).NE.ZERO) THEN
                          TEMP = ALPHA*B(L,J)
                          DO 70 I = 1,M
                              C(I,J) = C(I,J) + TEMP*A(I,L)
   70                     CONTINUE
                      END IF
   80             CONTINUE
   90         CONTINUE
          ELSE
!
!           Form  C := alpha*A**T*B + beta*C
!
              DO 120 J = 1,N
                  DO 110 I = 1,M
                      TEMP = ZERO
                      DO 100 L = 1,K
                          TEMP = TEMP + A(L,I)*B(L,J)
  100                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  110             CONTINUE
  120         CONTINUE
          END IF
      ELSE
          IF (NOTA) THEN
!
!           Form  C := alpha*A*B**T + beta*C
!
              DO 170 J = 1,N
                  IF (BETA.EQ.ZERO) THEN
                      DO 130 I = 1,M
                          C(I,J) = ZERO
  130                 CONTINUE
                  ELSE IF (BETA.NE.ONE) THEN
                      DO 140 I = 1,M
                          C(I,J) = BETA*C(I,J)
  140                 CONTINUE
                  END IF
                  DO 160 L = 1,K
                      IF (B(J,L).NE.ZERO) THEN
                          TEMP = ALPHA*B(J,L)
                          DO 150 I = 1,M
                              C(I,J) = C(I,J) + TEMP*A(I,L)
  150                     CONTINUE
                      END IF
  160             CONTINUE
  170         CONTINUE
          ELSE
!
!           Form  C := alpha*A**T*B**T + beta*C
!
              DO 200 J = 1,N
                  DO 190 I = 1,M
                      TEMP = ZERO
                      DO 180 L = 1,K
                          TEMP = TEMP + A(L,I)*B(J,L)
  180                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  190             CONTINUE
  200         CONTINUE
          END IF
      END IF
!
      RETURN
!
!     End of SGEMM .
!
      END


      include 'VICMAIN_FOR'
      SUBROUTINE MAIN44
      COMMON/C1/HIST(-32768:32767),IBUF(32768)
      INTEGER*4 HIST
      INTEGER*2 IBUF

      COMMON/C2/OBUF(10),OHIST(0:255)	!Histogram record data structure
      INTEGER*4 OHIST
      INTEGER*4 BUF(10)
      EQUIVALENCE (BUF,OBUF)

      LOGICAL XVPTST
      INTEGER*4 SL,SS,EL
      REAL*4 MEAN,SIGMA
      CHARACTER*8 FORMAT
      CHARACTER*80 MSG

  803 FORMAT(' Mean=',F14.8,'   Sigma=',F14.8,
     &   '   Total number of pixels=',I10)

C     ....Get unit number and open input image
      CALL XVUNIT(iunit,'INP',1,IND,' ')
      CALL XVOPEN(IUNIT,IND,'OPEN_ACT','SA','IO_ACT','SA',' ')
      CALL XVSIZE(sl,ss,nl,ns,nli,nsi)
      IF (SL+NL-1 .GT. NLI) GOTO 902
      IF (SS+NS-1 .GT. NSI) GOTO 903
      IF (NS.GT.32768) GOTO 904
      NPTS = NL*NS
C     ....Compute histogram of input image.  If the image is byte
C     ....the histogram is stored directly in OHIST.  If halfword,
C     ....the histogram is first stored in HIST, and then
C     ....compressed into OHIST.

      EL = SL+NL-1
      CALL XVGET(IUNIT,IND,'FORMAT',FORMAT,' ')
      IF (FORMAT.EQ.'BYTE') THEN
         CALL Xvmessage(' ***Test from Fortran', ' ')
         CALL COMPHIST(IUNIT,SL,SS,NL,NS,ohist,ibuf)
         CALL histat(OHIST,NPTS,mean,sigma,maxfreq)
         WRITE (MSG,803) MEAN,SIGMA,NPTS
         Call Xvmessage(msg, ' ')
CCC
         CALL Xvmessage(' ***Test from C', ' ')
         CALL tzCOMPHIST(IUNIT,SL,SS,NL,NS,ohist,ibuf)
         CALL histat(OHIST,NPTS,mean,sigma,maxfreq)
         WRITE (MSG,803) MEAN,SIGMA,NPTS
         Call Xvmessage(msg, ' ')
CCC
      ELSE IF (FORMAT.EQ.'HALF'.OR.FORMAT.EQ.'WORD') THEN
         CALL Xvmessage(' ***Test from Fortran', ' ')
         CALL COMPHIST2(IUNIT,SL,SS,NL,NS,hist,ibuf)
	 IF (.NOT.XVPTST('INCLUDE')) THEN
	    NPTS = NPTS - HIST(-32768)
	    HIST(-32768) = 0
         ENDIF
         CALL histat2(HIST,NPTS,mean,sigma,mindn,maxdn,maxfreq)
         WRITE (MSG,803) MEAN,SIGMA,NPTS
         Call Xvmessage(msg, ' ')
CCC
         CALL Xvmessage(' ***Test from C', ' ')
         CALL tzCOMPHIST2(IUNIT,SL,SS,NL,NS,hist,ibuf)
	 IF (.NOT.XVPTST('INCLUDE')) THEN
	    NPTS = NPTS - HIST(-32768)
	    HIST(-32768) = 0
         ENDIF
         CALL histat2(HIST,NPTS,mean,sigma,mindn,maxdn,maxfreq)
         WRITE (MSG,803) MEAN,SIGMA,NPTS
         Call Xvmessage(msg, ' ')
      ELSE
         GOTO 990
      ENDIF

      RETURN

  902 CALL Xvmessage(' *** # lines requested exceeds input size',' ')
      GOTO 999
  903 CALL Xvmessage(' *** # samples requested exceeds input size', ' ')
      GOTO 999
  904 CALL Xvmessage(' ***Input image #samples exceeds limit', ' ')
      GOTO 999
  990 CALL Xvmessage(' ***Invalid input data format',' ')
      CALL Xvmessage(' ***Inputs must be byte or halfword',' ')
      GOTO 999
  999 CALL Xvmessage(' thistat task cancelled', ' ')
      CALL ABEND
      END


      SUBROUTINE IB01PX( JOB, NOBR, N, M, L, UF, LDUF, UN, LDUN, UL,
     $                   LDUL, PGAL, LDPGAL, K, LDK, R, LDR, X, B, LDB,
     $                   D, LDD, TOL, IWORK, DWORK, LDWORK, IWARN,
     $                   INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To build and solve the least squares problem  T*X = Kv,  and
C     estimate the matrices B and D of a linear time-invariant (LTI)
C     state space model, using the solution  X,  and the singular
C     value decomposition information and other intermediate results,
C     provided by other routines.
C
C     The matrix  T  is computed as a sum of Kronecker products,
C
C        T = T + kron(Uf(:,(i-1)*m+1:i*m),N_i),  for i = 1 : s,
C
C     (with  T  initialized by zero), where  Uf  is the triangular
C     factor of the QR factorization of the future input part (see
C     SLICOT Library routine IB01ND),  N_i  is given by the i-th block
C     row of the matrix
C
C            [ Q_11  Q_12  ...  Q_1,s-2  Q_1,s-1  Q_1s ]   [ I_L  0  ]
C            [ Q_12  Q_13  ...  Q_1,s-1    Q_1s    0   ]   [         ]
C        N = [ Q_13  Q_14  ...    Q_1s      0      0   ] * [         ],
C            [  :     :            :        :      :   ]   [         ]
C            [ Q_1s   0    ...     0        0      0   ]   [  0  GaL ]
C
C     and where
C
C               [   -L_1|1    ]          [ M_i-1 - L_1|i ]
C        Q_11 = [             ],  Q_1i = [               ],  i = 2:s,
C               [ I_L - L_2|1 ]          [     -L_2|i    ]
C
C     are  (n+L)-by-L  matrices, and  GaL  is built from the first  n
C     relevant singular vectors,  GaL = Un(1:L(s-1),1:n),  computed
C     by IB01ND.
C
C     The vector  Kv  is vec(K), with the matrix  K  defined by
C
C        K = [ K_1  K_2  K_3  ...  K_s ],
C
C     where  K_i = K(:,(i-1)*m+1:i*m),  i = 1:s,  is  (n+L)-by-m.
C     The given matrices are  Uf,  GaL,  and
C
C            [ L_1|1  ...  L_1|s ]
C        L = [                   ],   (n+L)-by-L*s,
C            [ L_2|1  ...  L_2|s ]
C
C        M = [ M_1  ...  M_s-1 ],      n-by-L*(s-1),  and
C        K,                            (n+L)-by-m*s.
C
C     Matrix  M  is the pseudoinverse of the matrix  GaL,  computed by
C     SLICOT Library routine IB01PD.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies which of the matrices B and D should be
C             computed, as follows:
C             = 'B':  compute the matrix B, but not the matrix D;
C             = 'D':  compute both matrices B and D.
C
C     Input/Output Parameters
C
C     NOBR    (input) INTEGER
C             The number of block rows,  s,  in the input and output
C             Hankel matrices processed by other routines.  NOBR > 1.
C
C     N       (input) INTEGER
C             The order of the system.  NOBR > N > 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     L       (input) INTEGER
C             The number of system outputs.  L > 0.
C
C     UF      (input/output) DOUBLE PRECISION array, dimension
C             ( LDUF,M*NOBR )
C             On entry, the leading  M*NOBR-by-M*NOBR  upper triangular
C             part of this array must contain the upper triangular
C             factor of the QR factorization of the future input part,
C             as computed by SLICOT Library routine IB01ND.
C             The strict lower triangle need not be set to zero.
C             On exit, the leading  M*NOBR-by-M*NOBR  upper triangular
C             part of this array is unchanged, and the strict lower
C             triangle is set to zero.
C
C     LDUF    INTEGER
C             The leading dimension of the array  UF.
C             LDUF >= MAX( 1, M*NOBR ).
C
C     UN      (input) DOUBLE PRECISION array, dimension ( LDUN,N )
C             The leading  L*(NOBR-1)-by-N  part of this array must
C             contain the matrix  GaL,  i.e., the leading part of the
C             first  N  columns of the matrix  Un  of relevant singular
C             vectors.
C
C     LDUN    INTEGER
C             The leading dimension of the array  UN.
C             LDUN >= L*(NOBR-1).
C
C     UL      (input/output) DOUBLE PRECISION array, dimension
C             ( LDUL,L*NOBR )
C             On entry, the leading  (N+L)-by-L*NOBR  part of this array
C             must contain the given matrix  L.
C             On exit, if  M > 0,  the leading  (N+L)-by-L*NOBR  part of
C             this array is overwritten by the matrix
C             [ Q_11  Q_12  ...  Q_1,s-2  Q_1,s-1  Q_1s ].
C
C     LDUL    INTEGER
C             The leading dimension of the array  UL.  LDUL >= N+L.
C
C     PGAL    (input) DOUBLE PRECISION array, dimension
C             ( LDPGAL,L*(NOBR-1) )
C             The leading  N-by-L*(NOBR-1)  part of this array must
C             contain the pseudoinverse of the matrix  GaL,  computed by
C             SLICOT Library routine IB01PD.
C
C     LDPGAL  INTEGER
C             The leading dimension of the array  PGAL.  LDPGAL >= N.
C
C     K       (input) DOUBLE PRECISION array, dimension ( LDK,M*NOBR )
C             The leading  (N+L)-by-M*NOBR  part of this array must
C             contain the given matrix  K.
C
C     LDK     INTEGER
C             The leading dimension of the array  K.  LDK >= N+L.
C
C     R       (output) DOUBLE PRECISION array, dimension ( LDR,M*(N+L) )
C             The leading  (N+L)*M*NOBR-by-M*(N+L)  part of this array
C             contains details of the complete orthogonal factorization
C             of the coefficient matrix  T  of the least squares problem
C             which is solved for getting the system matrices B and D.
C
C     LDR     INTEGER
C             The leading dimension of the array  R.
C             LDR >= MAX( 1, (N+L)*M*NOBR ).
C
C     X       (output) DOUBLE PRECISION array, dimension
C             ( (N+L)*M*NOBR )
C             The leading  M*(N+L)  elements of this array contain the
C             least squares solution of the system  T*X = Kv.
C             The remaining elements are used as workspace (to store the
C             corresponding part of the vector Kv = vec(K)).
C
C     B       (output) DOUBLE PRECISION array, dimension ( LDB,M )
C             The leading N-by-M part of this array contains the system
C             input matrix.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= N.
C
C     D       (output) DOUBLE PRECISION array, dimension ( LDD,M )
C             If  JOB = 'D',  the leading L-by-M part of this array
C             contains the system input-output matrix.
C             If  JOB = 'B',  this array is not referenced.
C
C     LDD     INTEGER
C             The leading dimension of the array D.
C             LDD >= L, if  JOB = 'D';
C             LDD >= 1, if  JOB = 'B'.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used for estimating the rank of
C             matrices. If the user sets  TOL > 0,  then the given value
C             of  TOL  is used as a lower bound for the reciprocal
C             condition number;  an m-by-n matrix whose estimated
C             condition number is less than  1/TOL  is considered to
C             be of full rank.  If the user sets  TOL <= 0,  then an
C             implicitly computed, default tolerance, defined by
C             TOLDEF = m*n*EPS,  is used instead, where  EPS  is the
C             relative machine precision (see LAPACK Library routine
C             DLAMCH).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension ( M*(N+L) )
C
C     DWORK   DOUBLE PRECISION array, dimension ( LDWORK )
C             On exit, if  INFO = 0,  DWORK(1) returns the optimal value
C             of LDWORK,  and, if  M > 0,  DWORK(2)  contains the
C             reciprocal condition number of the triangular factor of
C             the matrix  T.
C             On exit, if  INFO = -26,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX( (N+L)*(N+L), 4*M*(N+L)+1 ).
C             For good performance,  LDWORK  should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 4:  the least squares problem to be solved has a
C                   rank-deficient coefficient matrix.
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 matrix  T  is computed, evaluating the sum of Kronecker
C     products, and then the linear system  T*X = Kv  is solved in a
C     least squares sense. The matrices  B  and  D  are then directly
C     obtained from the least squares solution.
C
C     REFERENCES
C
C     [1] Verhaegen M., and Dewilde, P.
C         Subspace Model Identification. Part 1: The output-error
C         state-space model identification class of algorithms.
C         Int. J. Control, 56, pp. 1187-1210, 1992.
C
C     [2] Van Overschee, P., and De Moor, B.
C         N4SID: Two Subspace Algorithms for the Identification
C         of Combined Deterministic-Stochastic Systems.
C         Automatica, Vol.30, No.1, pp. 75-93, 1994.
C
C     [3] Van Overschee, P.
C         Subspace Identification : Theory - Implementation -
C         Applications.
C         Ph. D. Thesis, Department of Electrical Engineering,
C         Katholieke Universiteit Leuven, Belgium, Feb. 1995.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Universiteit Leuven, Feb. 2000.
C
C     REVISIONS
C
C     V. Sima, Katholieke Universiteit Leuven, Sep. 2001.
C
C     KEYWORDS
C
C     Identification methods; least squares solutions; multivariable
C     systems; QR decomposition; singular value decomposition.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO  = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   TOL
      INTEGER            INFO, IWARN, L, LDB, LDD, LDK, LDPGAL, LDR,
     $                   LDUF, LDUL, LDUN, LDWORK, M, N, NOBR
      CHARACTER          JOB
C     .. Array Arguments ..
      DOUBLE PRECISION   B(LDB, *), D(LDD, *), DWORK(*), K(LDK, *),
     $                   PGAL(LDPGAL, *), R(LDR, *), UF(LDUF, *),
     $                   UL(LDUL, *), UN(LDUN, *), X(*)
      INTEGER            IWORK( * )
C     .. Local Scalars ..
      DOUBLE PRECISION   RCOND, TOLL
      INTEGER            I, IERR, J, JWORK, LDUN2, LNOBR, LP1, MAXWRK,
     $                   MINWRK, MKRON, MNOBR, NKRON, NP1, NPL, RANK
      LOGICAL            WITHB, WITHD
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL           DGELSY, DGEMM, DLACPY, DLASET, DTRCON, MB01VD,
     $                   XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      WITHD = LSAME( JOB, 'D' )
      WITHB = LSAME( JOB, 'B' ) .OR. WITHD
      MNOBR = M*NOBR
      LNOBR = L*NOBR
      LDUN2 = LNOBR - L
      LP1   = L + 1
      NP1   = N + 1
      NPL   = N + L
      IWARN = 0
      INFO  = 0
C
C     Check the scalar input parameters.
C
      IF( .NOT.WITHB ) THEN
         INFO = -1
      ELSE IF( NOBR.LE.1 ) THEN
         INFO = -2
      ELSE IF( N.GE.NOBR .OR. N.LE.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( L.LE.0 ) THEN
         INFO = -5
      ELSE IF( LDUF.LT.MAX( 1, MNOBR ) ) THEN
         INFO = -7
      ELSE IF( LDUN.LT.LDUN2 ) THEN
         INFO = -9
      ELSE IF( LDUL.LT.NPL ) THEN
         INFO = -11
      ELSE IF( LDPGAL.LT.N ) THEN
         INFO = -13
      ELSE IF( LDK.LT.NPL ) THEN
         INFO = -15
      ELSE IF( LDR.LT.MAX( 1, MNOBR*NPL ) ) THEN
         INFO = -17
      ELSE IF( LDB.LT.N ) THEN
         INFO = -20
      ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L ) ) THEN
         INFO = -22
      ELSE
C
C        Compute workspace.
C        (Note: Comments in the code beginning "Workspace:" describe the
C         minimal amount of workspace needed at that point in the code,
C         as well as the preferred amount for good performance.
C         NB refers to the optimal block size for the immediately
C         following subroutine, as returned by ILAENV.)
C
         MINWRK = MAX( NPL*NPL, 4*M*NPL + 1 )
C
         IF ( LDWORK.LT.MINWRK ) THEN
            INFO = -26
            DWORK( 1 ) = MINWRK
         END IF
      END IF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'IB01PX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( M.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Construct the matrix  [ Q_11  Q_12  ...  Q_1,s-1  Q_1s ]  in  UL.
C
      DO 20 J = 1, L
C
         DO 10 I = 1, NPL
            UL(I,J) = -UL(I,J)
   10    CONTINUE
C
         UL(N+J,J) = ONE + UL(N+J,J)
   20 CONTINUE
C
      DO 50 J = LP1, LNOBR
C
         DO 30 I = 1, N
            UL(I,J) = PGAL(I,J-L) - UL(I,J)
   30    CONTINUE
C
         DO 40 I = NP1, NPL
            UL(I,J) = -UL(I,J)
   40    CONTINUE
C
   50 CONTINUE
C
C     Compute the coefficient matrix T using Kronecker products.
C     Workspace: (N+L)*(N+L).
C     In the same loop, vectorize K in X.
C
      CALL DLASET( 'Full', MNOBR*NPL, M*NPL, ZERO, ZERO, R, LDR )
      CALL DLASET( 'Lower', MNOBR-1, MNOBR-1, ZERO, ZERO, UF(2,1),
     $             LDUF )
      JWORK = NPL*L + 1
C
      DO 60 I = 1, NOBR
         CALL DLACPY( 'Full', NPL, L, UL(1,(I-1)*L+1), LDUL, DWORK,
     $                NPL )
         IF ( I.LT.NOBR ) THEN
            CALL DGEMM ( 'NoTranspose', 'NoTranspose', NPL, N,
     $                   L*(NOBR-I), ONE, UL(1,I*L+1), LDUL, UN, LDUN,
     $                   ZERO, DWORK(JWORK), NPL )
         ELSE
            CALL DLASET( 'Full', NPL, N, ZERO, ZERO, DWORK(JWORK), NPL )
         END IF
         CALL MB01VD( 'NoTranspose', 'NoTranspose', MNOBR, M, NPL,
     $                NPL, ONE, ONE, UF(1,(I-1)*M+1), LDUF, DWORK,
     $                NPL, R, LDR, MKRON, NKRON, IERR )
         CALL DLACPY( 'Full', NPL, M, K(1,(I-1)*M+1), LDK,
     $                X((I-1)*NKRON+1), NPL )
   60 CONTINUE
C
C     Compute the tolerance.
C
      TOLL = TOL
      IF( TOLL.LE.ZERO )
     $   TOLL = MKRON*NKRON*DLAMCH( 'Precision' )
C
C     Solve the least square problem  T*X = vec(K).
C     Workspace:  need   4*M*(N+L)+1;
C                 prefer 3*M*(N+L)+(M*(N+L)+1)*NB.
C
      DO 70 I = 1, NKRON
         IWORK(I) = 0
   70 CONTINUE
C
      CALL DGELSY( MKRON, NKRON, 1, R, LDR, X, MKRON, IWORK, TOLL, RANK,
     $             DWORK, LDWORK, IERR )
      MAXWRK = DWORK(1)
C
C     Compute the reciprocal of the condition number of the triangular
C     factor  R  of  T.
C     Workspace: need 3*M*(N+L).
C
      CALL DTRCON( '1-norm', 'Upper', 'NonUnit', NKRON, R, LDR, RCOND,
     $             DWORK, IWORK, IERR )
C
      IF ( RANK.LT.NKRON ) THEN
C
C        The least squares problem is rank-deficient.
C
         IWARN = 4
      END IF
C
C     Construct the matrix  D,  if needed.
C
      IF ( WITHD )
     $   CALL DLACPY( 'Full', L, M, X, NPL, D, LDD )
C
C     Construct the matrix  B.
C
      CALL DLACPY( 'Full', N, M, X(LP1), NPL, B, LDB )
C
C     Return optimal workspace in DWORK(1) and reciprocal condition
C     number in  DWORK(2).
C
      DWORK(1) = MAX( MINWRK, MAXWRK )
      DWORK(2) = RCOND
C
      RETURN
C
C *** Last line of IB01PX ***
      END


c
c --- Calculate Matrix Values ---
c
      mat(1,1)=-9*m30*p**2*sin(q3)**2+j30z*sin(q3)**2-j30y*sin(q3)**2+18
     . *m30*p**2*cos(q2)*cos(q3)+18*m30*p**2+m10*p**2+j30y+j10y
      mat(1,2)=-9*m30*p**2*sin(q3)**2+j30z*sin(q3)**2-j30y*sin(q3)**2+9*
     . m30*p**2*cos(q2)*cos(q3)+9*m30*p**2+j30y
      mat(1,3)=-9*m30*p**2*sin(q2)*sin(q3)
      mat(2,2)=-9*m30*p**2*sin(q3)**2+j30z*sin(q3)**2-j30y*sin(q3)**2+9*
     . m30*p**2+j30y
      mat(2,3)=0
      mat(3,3)=9*m30*p**2+j30x


*     MB04AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER            NIN, NOUT
      PARAMETER          ( NIN = 5, NOUT = 6 )
      INTEGER            NMAX
      PARAMETER          ( NMAX = 50 )
      INTEGER            LDH, LDQ1, LDQ2, LDT, LDU11, LDU12, LDU21,
     $                   LDU22, LDWORK, LDZ, LIWORK
      PARAMETER          ( LDH = NMAX, LDQ1  = NMAX,   LDQ2 = NMAX,
     $                     LDT = NMAX, LDU11 = NMAX/2, LDU12 = NMAX/2,
     $                     LDU21  = NMAX/2, LDU22 = NMAX/2,
     $                     LDWORK = 3*NMAX*NMAX + MAX( NMAX, 48 ) + 6,
     $                     LDZ = NMAX,  LIWORK = NMAX + 18 )
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
*
*     .. Local Scalars ..
      CHARACTER          COMPQ1, COMPQ2, COMPU1, COMPU2, JOB
      INTEGER            I, INFO, J, M, N
*
*     .. Local Arrays ..
      INTEGER            IWORK( LIWORK )
      DOUBLE PRECISION   ALPHAI( NMAX/2 ), ALPHAR( NMAX/2 ),
     $                   BETA( NMAX/2 ), DWORK( LDWORK ),
     $                   H( LDH, NMAX ), Q1( LDQ1, NMAX ),
     $                   Q2( LDQ2, NMAX ), T( LDT, NMAX ),
     $                   U11( LDU11, NMAX/2 ), U12( LDU12, NMAX/2 ),
     $                   U21( LDU21, NMAX/2 ), U22( LDU22, NMAX/2 ),
     $                   Z( LDZ, NMAX )
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*
*     .. External Subroutines ..
      EXTERNAL           DLASET, MB04AD
*
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*
*     .. Executable Statements ..
*
      WRITE( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ( NIN, FMT = * )
      READ( NIN, FMT = * ) JOB, COMPQ1, COMPQ2, COMPU1, COMPU2, N
      IF( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE( NOUT, FMT = 99998 ) N
      ELSE
         READ( NIN, FMT = * ) ( ( Z( I, J ), J = 1, N ), I = 1, N )
         READ( NIN, FMT = * ) ( ( H( I, J ), J = 1, N ), I = 1, N )
*        Compute the eigenvalues of a real skew-Hamiltonian/Hamiltonian
*        pencil (factored version).
         CALL MB04AD( JOB, COMPQ1, COMPQ2, COMPU1, COMPU2, N, Z, LDZ, H,
     $                LDH, Q1, LDQ1, Q2, LDQ2, U11, LDU11, U12, LDU12,
     $                U21, LDU21, U22, LDU22, T, LDT, ALPHAR, ALPHAI,
     $                BETA, IWORK, LIWORK, DWORK, LDWORK, INFO )
*
         IF( INFO.NE.0 ) THEN
            WRITE( NOUT, FMT = 99997 ) INFO
         ELSE
            M = N/2
            CALL DLASET( 'Full', M, M, ZERO, ZERO, Z( M+1, 1 ), LDZ )
            WRITE( NOUT, FMT = 99996 )
            DO 10 I = 1, N
               WRITE( NOUT, FMT = 99995 ) ( T( I, J ), J = 1, N )
   10       CONTINUE
            WRITE( NOUT, FMT = 99994 )
            DO 20 I = 1, N
               WRITE( NOUT, FMT = 99995 ) ( Z( I, J ), J = 1, N )
   20       CONTINUE
            WRITE( NOUT, FMT = 99993 )
            DO 30 I = 1, N
               WRITE( NOUT, FMT = 99995 ) ( H( I, J ), J = 1, N )
   30       CONTINUE
            IF( LSAME( COMPQ1, 'I' ) ) THEN
               WRITE( NOUT, FMT = 99992 )
               DO 40 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) ( Q1( I, J ), J = 1, N )
   40          CONTINUE
            END IF
            IF( LSAME( COMPQ2, 'I' ) ) THEN
               WRITE( NOUT, FMT = 99991 )
               DO 50 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) ( Q2( I, J ), J = 1, N )
   50          CONTINUE
            END IF
            IF( LSAME( COMPU1, 'I' ) ) THEN
               WRITE( NOUT, FMT = 99990 )
               DO 60 I = 1, M
                  WRITE( NOUT, FMT = 99995 ) ( U11( I, J ), J = 1, M )
   60          CONTINUE
               WRITE( NOUT, FMT = 99989 )
               DO 70 I = 1, M
                  WRITE( NOUT, FMT = 99995 ) ( U12( I, J ), J = 1, M )
   70          CONTINUE
            END IF
            IF( LSAME( COMPU2, 'I' ) ) THEN
               WRITE( NOUT, FMT = 99988 )
               DO 80 I = 1, M
                  WRITE( NOUT, FMT = 99995 ) ( U21( I, J ), J = 1, M )
   80          CONTINUE
               WRITE( NOUT, FMT = 99987 )
               DO 90 I = 1, M
                  WRITE( NOUT, FMT = 99995 ) ( U22( I, J ), J = 1, M )
   90          CONTINUE
            END IF
            WRITE( NOUT, FMT = 99986 )
            WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, M )
            WRITE( NOUT, FMT = 99985 )
            WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, M )
            WRITE( NOUT, FMT = 99984 )
            WRITE( NOUT, FMT = 99995 ) (   BETA( I ), I = 1, M )
         END IF
      END IF
      STOP
*
99999 FORMAT( 'MB04AD EXAMPLE PROGRAM RESULTS', 1X )
99998 FORMAT( 'N is out of range.', /, 'N = ', I5 )
99997 FORMAT( 'INFO on exit from MB04AD = ', I2 )
99996 FORMAT( 'The matrix T on exit is ' )
99995 FORMAT( 50( 1X, F8.4 ) )
99994 FORMAT( 'The matrix Z on exit is ' )
99993 FORMAT( 'The matrix H is ' )
99992 FORMAT( 'The matrix Q1 is ' )
99991 FORMAT( 'The matrix Q2 is ' )
99990 FORMAT( 'The upper left block of the matrix U1 is ' )
99989 FORMAT( 'The upper right block of the matrix U1 is ' )
99988 FORMAT( 'The upper left block of the matrix U2 is ' )
99987 FORMAT( 'The upper right block of the matrix U2 is ' )
99986 FORMAT( 'The vector ALPHAR is ' )
99985 FORMAT( 'The vector ALPHAI is ' )
99984 FORMAT( 'The vector BETA is ' )
      END