	SUBROUTINE HUNTMN( N, X, DX, Y, FN, FF)
C
C     THIS IS MK V, APRIL 1988
C
	DIMENSION X(25), Y(25), DX(25), DXB(25)
	COMMON /HNTBLK/ NHUNT(25)
	DATA NHUNT/25*1/
C
C
	DO 3 I = 1,25
    3	Y(I) = X(I)
	DO 1 I = 1,N
	   DXB(I) = 0.
	   Y(I) = X(I)
 1	CONTINUE
	CALL FN(Y,F0)
	FM = F0
	DO 2 I = 1,N
	   IF(NHUNT(I).EQ.0) GO TO 2
	   XB = X(I)
	   Y(I) = X(I) + DX(I)
	   CALL FN(Y, F1)
	   IF(F1.GE.FM) GO TO 4
	   FM = F1
	   XB = Y(I)
 4	   Y(I) = X(I) - DX(I)
	   CALL FN(Y,F2)
	   IF(F2.GE.FM) GO TO 8
	   FM = F2
	   XB = Y(I)
 8	   DEN = F1 + F2 - 2.*F0
	   IF(DEN.EQ.0.) GO TO 2
C	   DEN IS SECOND DERIV DIVIDED BY 2.*DX**2.  IF ITS NEGATIVE
C	   THEN THE EXTREMUM IS A MAXIMUM.  IN THAT CASE, GO ONE STEP
C	   BEYOND THE LOWEST POINT.
	   IF(DEN.GT.0.) THEN
	     DEX = -.5*(F1 - F2)/DEN
	   ELSE
	     DEX = SIGN(2.,(F2-F1))
	   ENDIF
	   Y(I) = X(I) + DEX*DX(I)
	   CALL FN(Y,FF)
	   IF(FF.LT.FM) GO TO 18
C		NEW VALUE IS NOT BETTER
	   FF = FM
	   Y(I) = XB
	   IF((F1+F2).LT.3.*F0) GO TO 18
C		DX IS TOO BIG, ADJUST TO GIVE 50 % INCREASE IN F
	   DX(I) = SQRT(ABS(F0/DEN))*DX(I)
	   GO TO 19
 18	   CONTINUE
	   DX(I) = .5*(ABS(DX(I)) + ABS(X(I) - Y(I)))
 19	   DXB(I) = Y(I) - X(I)
	   X(I) = Y(I)
	   F0 = FF
	   FM = FF
 2	CONTINUE
C
C     DO ONE MORE STEP IN DIRECTION OF BEST CHANGE
C
	DO 30 I = 1,N
	   Y(I) = X(I) + DXB(I)
 30	CONTINUE
	CALL FN(Y, F1)
	FM = AMIN1(FM,F1)
	DO 31 I = 1,N
	   Y(I) = X(I) - DXB(I)
 31	CONTINUE
	CALL FN(Y, F2)
	FM = AMIN1(F2,FM)
	DEN = F1 + F2 - 2.*FF
	IF(DEN.EQ.0.) RETURN
	DEX = -.5*(F1 - F2)/DEN
	DO 32 I = 1,N
	   Y(I) = X(I) + DEX*DXB(I)
 32	CONTINUE
	CALL FN(Y, FFP)
	IF(FFP.GT.FM) GO TO 34
	FF = FFP
	DO 33 I = 1,N
	   X(I) = Y(I)
 33	CONTINUE
	RETURN
C
C     ENTRY HERE MEANS THAT F1, F2, OR FF IS SMALLEST
C
 34	IF(FF.LE.F1.AND.FF.LE.F2) RETURN
	DEX = 1.
	IF(F2.LT.F1) DEX = -1.
	DO 35 I = 1,N
	   Y(I) = X(I) + DEX*DXB(I)
	   X(I) = Y(I)
 35	CONTINUE
	FF = AMIN1(F1,F2)
	RETURN
C
C
	END


	SUBROUTINE ZPGEX2( WANTQ, K, N, J, S, A, LDA1, LDA2, Q, LDQ1,
     $                   LDQ2, ZWORK, INFO )
	IMPLICIT NONE
C
C     PURPOSE
C
C     ZPGEX2 swaps adjacent diagonal 1-by-1 blocks in a complex
C     generalized matrix product,
C
C                                 S(2)                 S(K)
C          A(:,:,1)     * A(:,:,2)     * ... * A(:,:,K),
C
C     by unitary equivalence transformations. A must be in periodic
C     Schur form, that is, all factors of A must be upper triangular.
C
C     If WANTQ = .TRUE., then the unitary factors are computed and
C     stored in the array Q so that for S(I) = 1,
C
C                         H
C             Q(:,:,I)(in)   A(:,:,I)(in)   Q(:,:,MOD(I,K)+1)(in)
C                          H                                        (1)
C         =   Q(:,:,I)(out)  A(:,:,I)(out)  Q(:,:,MOD(I,K)+1)(out),
C
C     and for S(I) = -1,
C
C                                  H
C             Q(:,:,MOD(I,K)+1)(in)   A(:,:,I)(in)   Q(:,:,I)(in)
C                                   H                               (2)
C         =   Q(:,:,MOD(I,K)+1)(out)  A(:,:,I)(out)  Q(:,:,I)(out).
C
C     ARGUMEMTS
C
C     Mode Parameters
C
C     WANTQ   (input) LOGICAL
C             = .FALSE.: do not modify Q;
C             = .TRUE. : modify the array Q by the unitary
C                        transformations that are applied to the
C                        matrices in A for reordering.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of factors.  K >= 1.
C
C     N       (input)  INTEGER
C             The order of each factor in A.  N >= 2.
C
C     J       (input) INTEGER
C             The index of the first block to be swapped.  1 <= J < N.
C
C     S       (input)  INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             signatures of the factors. Each entry in S must be either
C             1 or -1. By definition, S(1) must be set to 1.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA1,LDA2,K)
C             On entry, the leading N-by-N-by-K part of this array
C             must contain the factors in periodic Schur form
C             form, that is, all factors are upper triangular.
C             On exit, if INFO = 0, the leading N-by-N-by-K part of
C             this array contains the factors of the reordered periodic
C             Schur form.
C
C     LDA1    (input) INTEGER
C             The first leading dimension of A.  LDA1 >= MAX(1,N).
C
C     LDA2    (input) INTEGER
C             The second leading dimension of A.  LDA2 >= MAX(1,N).
C
C     Q       (input/output) COMPLEX*16 array, dimension (LDQ1,LDQ2,K)
C             On entry, if WANTQ = .TRUE., the leading N-by-N-by-K part
C             of this array must contain the initial unitary factors
C             as described in (1)-(2).
C             On exit, if WANTQ = .TRUE., the leading N-by-N-by-K part
C             of this array contains the modified orthogonal factors as
C             described in (1)-(2).
C
C     LDQ1    (input)  INTEGER
C             The first leading dimension of Q.
C             If WANTQ = .TRUE.,  LDQ1 >= MAX(1,N).
C
C     LDQ2    (input)  INTEGER
C             The second leading dimension of Q.
C             If WANTQ = .TRUE.,  LDQ2 >= MAX(1,N).
C
C     Workspace
C
C     ZWORK   COMPLEX*16 array, dimension (K)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0       : succesful exit;
C             = 1       : the periodic QZ algorithm failed to converge.
C
C     METHOD
C
C     A complex version of the periodic QZ algorithm [1] with one
C     perfect shift is used. For more details see [2]. This is not
C     a safe method. It is advisable to check whether the eigenvalues
C     are really reorderd.
C
C     REFERENCES
C
C     [1] Bojanczyk, A. and Golub, G. H. and Van Dooren, P.
C         The periodic Schur decomposition; algorithm and applications.
C         In Proc. SPIE Conference, pg. 31-42, vol. 1770, 1992.
C
C     [2] Kressner, D.
C         An efficient and reliable implementation of the periodic QZ
C         algorithm. In IFAC Workshop on Periodic Control Systems, 2001.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically backward stable.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, Dec. 2002.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
	PARAMETER         ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      COMPLEX*16        CONE, CZERO
      PARAMETER         ( CONE = ( 1.0D+0, 0.0D+0 ),
     $                  CZERO = ( 0.0D+0, 0.0D+0 ) )
C     .. Scalar Arguments ..
      LOGICAL           WANTQ
      INTEGER           J, K, INFO, LDA1, LDA2, LDQ1, LDQ2, N
C     .. Array Arguments ..
      INTEGER           S(*)
      COMPLEX*16        A(LDA1, LDA2, *), Q(LDQ1, LDQ2, *),
     $                  ZWORK(*)
C     .. Local Scalars ..
      LOGICAL           USEZQ
      INTEGER           JITER, L, LN
      DOUBLE PRECISION  CS, CSF, RHS, SAFMAX, SAFMIN, SMLNUM, ULP
	COMPLEX*16        SN, SNF, TEMP
C     .. Local Arrays ..
      INTEGER           ISEED(4)
	COMPLEX*16        RND(3)
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH
	EXTERNAL          DLAMCH
C     .. External Subroutines ..
      EXTERNAL          DLABAD, ZLARTG, ZROT
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DCONJG, MAX
C
C     .. Executable Statements ..
C
C     Save perfect shift.
C
      DO 10  L = 1, K
      ZWORK(L) = A(J,J,L)
   10 CONTINUE
      INFO = 0
      ISEED(1) = 1
      ISEED(2) = 0
      ISEED(3) = 0
      ISEED(4) = 0
      SAFMIN = DLAMCH( 'SafeMinimum' )
      SAFMAX = ONE / SAFMIN
      ULP = DLAMCH( 'Precision' )
      CALL DLABAD( SAFMIN, SAFMAX )
      SMLNUM = SAFMIN*( 2 / ULP )
C
C     If there are infinite or zero eigenvalues in critical positions,
C     then unshifted ZQ iterations must be used.
C
      USEZQ = .FALSE.
      DO 20  L = 1, K
         USEZQ = ( USEZQ.OR.
     $             ( ( S(L).EQ.1 ).AND.( A(J+1,J+1,L).EQ.CZERO ) ).OR.
     $             ( ( S(L).EQ.-1 ).AND.( A(J,J,L).EQ.CZERO ) ) )
   20 CONTINUE
C
C     Destroy any triangular structure.
C
      CALL ZLARNV( 2, ISEED, 2, RND )
      CALL ZLARTG( RND(1), RND(2), CS, SN, TEMP )
      CSF = CS
      SNF = SN
      DO 30  L = 1, K
         IF ( WANTQ ) THEN
            CALL ZROT( N, Q(1,J,L), 1, Q(1,J+1,L), 1, CS, DCONJG( SN ) )
         END IF
         IF ( S(L).EQ.1 ) THEN
            CALL ZROT( N-J+1, A(J,J,L), LDA1, A(J+1,J,L), LDA1, CS, SN )
         ELSE
            CALL ZROT( J+1, A(1,J,L), 1, A(1,J+1,L), 1, CS,
     $                 DCONJG( SN ) )
         END IF
         IF ( L.EQ.K ) THEN
            CS = CSF
            SN = SNF
         ELSE
            CALL ZLARNV( 2, ISEED, 2, RND )
            CALL ZLARTG( RND(1), RND(2), CS, SN, TEMP )
         END IF
         IF ( S(L).EQ.1 ) THEN
            CALL ZROT( J+1, A(1,J,L), 1, A(1,J+1,L), 1, CS,
     $                 DCONJG( SN ) )
         ELSE
            CALL ZROT( N-J+1, A(J,J,L), LDA1, A(J+1,J,L), LDA1, CS, SN )
         END IF
   30 CONTINUE
C
      IF ( USEZQ ) THEN
         DO 50  JITER = 1, 10
            DO 40  L = 1, K
               IF ( S(L).EQ.1 ) THEN
                  TEMP = A(J+1,J+1,L)
                  CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J+1,J+1,L) )
                  A(J+1,J,L) = CZERO
                  CALL ZROT( J, A(1,J+1,L), 1, A(1,J,L), 1, CS, SN )
                  SN = -SN
               ELSE
                  TEMP = A(J,J,L)
                  CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J,J,L) )
                  A(J+1,J,L) = CZERO
                  CALL ZROT( N-J, A(J,J+1,L), LDA1, A(J+1,J+1,L), LDA1,
     $                       CS, SN )
               END IF
               LN = L + 1
               IF ( LN.GT.K )  LN = 1
               IF ( WANTQ ) THEN
                  CALL ZROT( N, Q(1,J,LN), 1, Q(1,J+1,LN), 1, CS,
     $                       DCONJG( SN ) )
               END IF
               IF ( S(LN).EQ.1 ) THEN
                  CALL ZROT( N-J+1, A(J,J,LN), LDA1, A(J+1,J,LN), LDA1,
     $                       CS, SN )
               ELSE
                  CALL ZROT( J+1, A(1,J,LN), 1, A(1,J+1,LN), 1, CS,
     $                       DCONJG( SN ) )
               END IF
   40       CONTINUE
            RHS = MAX( ABS( A(J,J,1) ), ABS( A(J+1,J+1,1) ) )
            IF ( RHS.EQ.ZERO )
     $         RHS = ABS( A(J,J+1,1) )
               RHS = MAX( ULP*RHS, SMLNUM )
            IF ( ABS( A(J+1,J,1) ).LE.RHS ) THEN
               A(J+1,J,1) = CZERO
               GO TO 90
            END IF
   50    CONTINUE
         INFO = 1
         GO TO 90
      END IF

      DO 80  JITER = 1, 42
C
C        Complex single shift.
C
         IF ( ( JITER / 10 )*10.EQ.JITER ) THEN
C
C           Random/exceptional shift.
C
            CALL ZLARNV( 2, ISEED, 2, RND )
            CALL ZLARTG( RND(1), RND(2), CS, SN, TEMP )
         ELSE
            CALL ZLARTG( CONE, CONE, CS, SN, TEMP )
            DO 60  L = K, 2, -1
               IF ( S(L).EQ.1 ) THEN
                  CALL ZLARTG( A(J,J,L)*CS, ZWORK(L)*DCONJG(SN),
     $                         CS, SN, TEMP )
               ELSE
                  CALL ZLARTG( ZWORK(L)*CS, -A(J,J,L)*DCONJG(SN),
     $                         CS, SN, TEMP )
                  SN = -SN
               END IF
   60       CONTINUE
            CALL ZLARTG( A(J,J,1)*CS - DCONJG(SN)*ZWORK(1),
     $                   A(J+1,J,1)*CS, CS, SN, TEMP )
         END IF
C
C        Do one QZ sweep.
C
         CALL ZROT( N-J+1, A(J,J,1), LDA1, A(J+1,J,1), LDA1,
     $              CS, SN )
         IF ( WANTQ ) THEN
            CALL ZROT( N, Q(1,J,1), 1, Q(1,J+1,1), 1, CS,
     $                 DCONJG( SN ) )
         END IF
C
C        Propagate rotation through AK, ..., A2 to A1.
C
         DO 70  L = K, 2, -1
            IF ( S(L).EQ.1 ) THEN
               CALL ZROT( J+1, A(1,J,L), 1, A(1,J+1,L), 1, CS,
     $                    DCONJG( SN ) )
               TEMP = A(J,J,L)
               CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J,J,L) )
               A(J+1,J,L) = CZERO
               CALL ZROT( N-J, A(J,J+1,L), LDA1, A(J+1,J+1,L), LDA1,
     $                    CS, SN )
            ELSE
               CALL ZROT( N-J+1, A(J,J,L), LDA1, A(J+1,J,L), LDA1, CS,
     $                    SN )
               TEMP = A(J+1,J+1,L)
               CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J+1,J+1,L) )
               A(J+1,J,L) = CZERO
               CALL ZROT( J, A(1,J+1,L), 1, A(1,J,L), 1, CS, SN )
               SN = -SN
            END IF
            IF ( WANTQ ) THEN
               CALL ZROT( N, Q(1,J,L), 1, Q(1,J+1,L), 1, CS,
     $                    DCONJG( SN ) )
            END IF
   70    CONTINUE
         CALL ZROT( J+1, A(1,J,1), 1, A(1,J+1,1), 1, CS, DCONJG( SN ) )
C
C        Test for deflation.
C
         RHS = MAX( ABS( A(J,J,1) ), ABS( A(J+1,J+1,1) ) )
         IF ( RHS.EQ.ZERO )
     $      RHS = ABS( A(J,J+1,1) )
            RHS = MAX( ULP*RHS, SMLNUM )
         IF ( ABS( A(J+1,J,1) ).LE.RHS ) THEN
            A(J+1,J,1) = CZERO
            GO TO 90
         END IF
   80 CONTINUE
C
C     Not converged.
C
      INFO = 1
C
   90 CONTINUE
C
C     Check for singular triangular factors.
C
      DO 100  L = 1, K
         RHS = MAX( ABS( A(J,J+1,L) ), ABS( A(J+1,J+1,L) ) )
         RHS = MAX( ULP*RHS, SMLNUM )
         IF ( ABS( A(J,J,L) ).LE.RHS ) THEN
            A(J,J,L) = CZERO
         END IF
         RHS = MAX( ABS( A(J,J+1,L) ), ABS( A(J,J,L) ) )
         RHS = MAX( ULP*RHS, SMLNUM )
         IF ( ABS( A(J+1,J+1,L) ).LE.RHS ) THEN
            A(J+1,J+1,L) = CZERO
         END IF
  100 CONTINUE
C
      RETURN
C
C *** Last line of ZPGEX2***
      END


      subroutine GSRBHELMHOLTZVC2D(
     &           phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1
     &           ,irhshi0,irhshi1
     &           ,nrhscomp
     &           ,iregionlo0,iregionlo1
     &           ,iregionhi0,iregionhi1
     &           ,dx
     &           ,alpha
     &           ,aCoef
     &           ,iaCoeflo0,iaCoeflo1
     &           ,iaCoefhi0,iaCoefhi1
     &           ,naCoefcomp
     &           ,beta
     &           ,bCoef0
     &           ,ibCoef0lo0,ibCoef0lo1
     &           ,ibCoef0hi0,ibCoef0hi1
     &           ,nbCoef0comp
     &           ,bCoef1
     &           ,ibCoef1lo0,ibCoef1lo1
     &           ,ibCoef1hi0,ibCoef1hi1
     &           ,nbCoef1comp
     &           ,lambda
     &           ,ilambdalo0,ilambdalo1
     &           ,ilambdahi0,ilambdahi1
     &           ,nlambdacomp
     &           ,redBlack
     &           )
      implicit none
      integer nphicomp
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1
      integer irhshi0,irhshi1
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           0:nrhscomp-1)
      integer iregionlo0,iregionlo1
      integer iregionhi0,iregionhi1
      REAL*8 dx
      REAL*8 alpha
      integer naCoefcomp
      integer iaCoeflo0,iaCoeflo1
      integer iaCoefhi0,iaCoefhi1
      REAL*8 aCoef(
     &           iaCoeflo0:iaCoefhi0,
     &           iaCoeflo1:iaCoefhi1,
     &           0:naCoefcomp-1)
      REAL*8 beta
      integer nbCoef0comp
      integer ibCoef0lo0,ibCoef0lo1
      integer ibCoef0hi0,ibCoef0hi1
      REAL*8 bCoef0(
     &           ibCoef0lo0:ibCoef0hi0,
     &           ibCoef0lo1:ibCoef0hi1,
     &           0:nbCoef0comp-1)
      integer nbCoef1comp
      integer ibCoef1lo0,ibCoef1lo1
      integer ibCoef1hi0,ibCoef1hi1
      REAL*8 bCoef1(
     &           ibCoef1lo0:ibCoef1hi0,
     &           ibCoef1lo1:ibCoef1hi1,
     &           0:nbCoef1comp-1)
      integer nlambdacomp
      integer ilambdalo0,ilambdalo1
      integer ilambdahi0,ilambdahi1
      REAL*8 lambda(
     &           ilambdalo0:ilambdahi0,
     &           ilambdalo1:ilambdahi1,
     &           0:nlambdacomp-1)
      integer redBlack
      REAL*8 dxinv,lofphi
      integer n,ncomp,indtot,imin,imax
      integer i,j
      ncomp = nphicomp
      if (ncomp .ne. nphicomp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nrhscomp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef0comp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef1comp) then
         call MAYDAYERROR()
      endif
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp - 1
          do j=iregionlo1, iregionhi1
            imin = iregionlo0
            indtot = imin + j
            imin = imin + abs(mod(indtot + redBlack, 2))
            imax = iregionhi0
            do i = imin, imax, 2
              lofphi =
     &            alpha * aCoef(i,j,n) * phi(i,j,n)
     &          - beta  *
     &             (
     &               bCoef0(i+1,j  ,n)
     &               * (phi(i+1,j  ,n)-phi(i  ,j  ,n))
     &             - bCoef0(i  ,j  ,n)
     &               * (phi(i  ,j  ,n)-phi(i-1,j  ,n))
     &             + bCoef1(i  ,j+1,n)
     &               * (phi(i  ,j+1,n)-phi(i  ,j  ,n))
     &             - bCoef1(i  ,j  ,n)
     &               * (phi(i  ,j  ,n)-phi(i  ,j-1,n))
     &             ) * dxinv
              phi(i,j,n) = phi(i,j,n)
     &          - lambda(i,j,n) * (lofphi - rhs(i,j,n))
            enddo
          enddo
      enddo
      return
      end
      subroutine VCCOMPUTEOP2D(
     &           lofphi
     &           ,ilofphilo0,ilofphilo1
     &           ,ilofphihi0,ilofphihi1
     &           ,nlofphicomp
     &           ,phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,nphicomp
     &           ,alpha
     &           ,aCoef
     &           ,iaCoeflo0,iaCoeflo1
     &           ,iaCoefhi0,iaCoefhi1
     &           ,naCoefcomp
     &           ,beta
     &           ,bCoef0
     &           ,ibCoef0lo0,ibCoef0lo1
     &           ,ibCoef0hi0,ibCoef0hi1
     &           ,nbCoef0comp
     &           ,bCoef1
     &           ,ibCoef1lo0,ibCoef1lo1
     &           ,ibCoef1hi0,ibCoef1hi1
     &           ,nbCoef1comp
     &           ,iregionlo0,iregionlo1
     &           ,iregionhi0,iregionhi1
     &           ,dx
     &           )
      implicit none
      integer nlofphicomp
      integer ilofphilo0,ilofphilo1
      integer ilofphihi0,ilofphihi1
      REAL*8 lofphi(
     &           ilofphilo0:ilofphihi0,
     &           ilofphilo1:ilofphihi1,
     &           0:nlofphicomp-1)
      integer nphicomp
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           0:nphicomp-1)
      REAL*8 alpha
      integer naCoefcomp
      integer iaCoeflo0,iaCoeflo1
      integer iaCoefhi0,iaCoefhi1
      REAL*8 aCoef(
     &           iaCoeflo0:iaCoefhi0,
     &           iaCoeflo1:iaCoefhi1,
     &           0:naCoefcomp-1)
      REAL*8 beta
      integer nbCoef0comp
      integer ibCoef0lo0,ibCoef0lo1
      integer ibCoef0hi0,ibCoef0hi1
      REAL*8 bCoef0(
     &           ibCoef0lo0:ibCoef0hi0,
     &           ibCoef0lo1:ibCoef0hi1,
     &           0:nbCoef0comp-1)
      integer nbCoef1comp
      integer ibCoef1lo0,ibCoef1lo1
      integer ibCoef1hi0,ibCoef1hi1
      REAL*8 bCoef1(
     &           ibCoef1lo0:ibCoef1hi0,
     &           ibCoef1lo1:ibCoef1hi1,
     &           0:nbCoef1comp-1)
      integer iregionlo0,iregionlo1
      integer iregionhi0,iregionhi1
      REAL*8 dx
      REAL*8 dxinv
      integer n,ncomp
      integer i,j
      ncomp = nphicomp
      if (ncomp .ne. nlofphicomp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef0comp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef1comp) then
         call MAYDAYERROR()
      endif
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp-1
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          lofphi(i,j,n) =
     &        alpha * aCoef(i,j,n) * phi(i,j,n)
     &      - beta  *
     &         (
     &           bCoef0(i+1,j  ,n)
     &           * (phi(i+1,j  ,n) - phi(i  ,j  ,n))
     &         - bCoef0(i  ,j  ,n)
     &           * (phi(i  ,j  ,n) - phi(i-1,j  ,n))
     &         + bCoef1(i  ,j+1,n)
     &           * (phi(i  ,j+1,n) - phi(i  ,j  ,n))
     &         - bCoef1(i  ,j  ,n)
     &           * (phi(i  ,j  ,n) - phi(i  ,j-1,n))
     &         ) * dxinv
      enddo
      enddo
      enddo
      return
      end
      subroutine VCCOMPUTERES2D(
     &           res
     &           ,ireslo0,ireslo1
     &           ,ireshi0,ireshi1
     &           ,nrescomp
     &           ,phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1
     &           ,irhshi0,irhshi1
     &           ,nrhscomp
     &           ,alpha
     &           ,aCoef
     &           ,iaCoeflo0,iaCoeflo1
     &           ,iaCoefhi0,iaCoefhi1
     &           ,naCoefcomp
     &           ,beta
     &           ,bCoef0
     &           ,ibCoef0lo0,ibCoef0lo1
     &           ,ibCoef0hi0,ibCoef0hi1
     &           ,nbCoef0comp
     &           ,bCoef1
     &           ,ibCoef1lo0,ibCoef1lo1
     &           ,ibCoef1hi0,ibCoef1hi1
     &           ,nbCoef1comp
     &           ,iregionlo0,iregionlo1
     &           ,iregionhi0,iregionhi1
     &           ,dx
     &           )
      implicit none
      integer nrescomp
      integer ireslo0,ireslo1
      integer ireshi0,ireshi1
      REAL*8 res(
     &           ireslo0:ireshi0,
     &           ireslo1:ireshi1,
     &           0:nrescomp-1)
      integer nphicomp
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1
      integer irhshi0,irhshi1
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           0:nrhscomp-1)
      REAL*8 alpha
      integer naCoefcomp
      integer iaCoeflo0,iaCoeflo1
      integer iaCoefhi0,iaCoefhi1
      REAL*8 aCoef(
     &           iaCoeflo0:iaCoefhi0,
     &           iaCoeflo1:iaCoefhi1,
     &           0:naCoefcomp-1)
      REAL*8 beta
      integer nbCoef0comp
      integer ibCoef0lo0,ibCoef0lo1
      integer ibCoef0hi0,ibCoef0hi1
      REAL*8 bCoef0(
     &           ibCoef0lo0:ibCoef0hi0,
     &           ibCoef0lo1:ibCoef0hi1,
     &           0:nbCoef0comp-1)
      integer nbCoef1comp
      integer ibCoef1lo0,ibCoef1lo1
      integer ibCoef1hi0,ibCoef1hi1
      REAL*8 bCoef1(
     &           ibCoef1lo0:ibCoef1hi0,
     &           ibCoef1lo1:ibCoef1hi1,
     &           0:nbCoef1comp-1)
      integer iregionlo0,iregionlo1
      integer iregionhi0,iregionhi1
      REAL*8 dx
      REAL*8 dxinv
      integer n,ncomp
      integer i,j
      ncomp = nphicomp
      if (ncomp .ne. nrescomp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef0comp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef1comp) then
         call MAYDAYERROR()
      endif
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp-1
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          res(i,j,n) =
     &        rhs(i,j,n)
     &      - (alpha * aCoef(i,j,n) * phi(i,j,n)
     &       - beta  *
     &          (
     &            bCoef0(i+1,j  ,n)
     &            * (phi(i+1,j  ,n) - phi(i  ,j  ,n))
     &          - bCoef0(i  ,j  ,n)
     &            * (phi(i  ,j  ,n) - phi(i-1,j  ,n))
     &          + bCoef1(i  ,j+1,n)
     &            * (phi(i  ,j+1,n) - phi(i  ,j  ,n))
     &          - bCoef1(i  ,j  ,n)
     &            * (phi(i  ,j  ,n) - phi(i  ,j-1,n))
     &          ) * dxinv
     &        )
      enddo
      enddo
      enddo
      return
      end
      subroutine RESTRICTRESVC2D(
     &           res
     &           ,ireslo0,ireslo1
     &           ,ireshi0,ireshi1
     &           ,nrescomp
     &           ,phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1
     &           ,irhshi0,irhshi1
     &           ,nrhscomp
     &           ,alpha
     &           ,aCoef
     &           ,iaCoeflo0,iaCoeflo1
     &           ,iaCoefhi0,iaCoefhi1
     &           ,naCoefcomp
     &           ,beta
     &           ,bCoef0
     &           ,ibCoef0lo0,ibCoef0lo1
     &           ,ibCoef0hi0,ibCoef0hi1
     &           ,nbCoef0comp
     &           ,bCoef1
     &           ,ibCoef1lo0,ibCoef1lo1
     &           ,ibCoef1hi0,ibCoef1hi1
     &           ,nbCoef1comp
     &           ,iregionlo0,iregionlo1
     &           ,iregionhi0,iregionhi1
     &           ,dx
     &           )
      implicit none
      integer nrescomp
      integer ireslo0,ireslo1
      integer ireshi0,ireshi1
      REAL*8 res(
     &           ireslo0:ireshi0,
     &           ireslo1:ireshi1,
     &           0:nrescomp-1)
      integer nphicomp
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1
      integer irhshi0,irhshi1
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           0:nrhscomp-1)
      REAL*8 alpha
      integer naCoefcomp
      integer iaCoeflo0,iaCoeflo1
      integer iaCoefhi0,iaCoefhi1
      REAL*8 aCoef(
     &           iaCoeflo0:iaCoefhi0,
     &           iaCoeflo1:iaCoefhi1,
     &           0:naCoefcomp-1)
      REAL*8 beta
      integer nbCoef0comp
      integer ibCoef0lo0,ibCoef0lo1
      integer ibCoef0hi0,ibCoef0hi1
      REAL*8 bCoef0(
     &           ibCoef0lo0:ibCoef0hi0,
     &           ibCoef0lo1:ibCoef0hi1,
     &           0:nbCoef0comp-1)
      integer nbCoef1comp
      integer ibCoef1lo0,ibCoef1lo1
      integer ibCoef1hi0,ibCoef1hi1
      REAL*8 bCoef1(
     &           ibCoef1lo0:ibCoef1hi0,
     &           ibCoef1lo1:ibCoef1hi1,
     &           0:nbCoef1comp-1)
      integer iregionlo0,iregionlo1
      integer iregionhi0,iregionhi1
      REAL*8 dx
      REAL*8 denom,dxinv,lofphi
      integer n,ncomp
      integer i,j
      integer ii,jj
      ncomp = nphicomp
      dxinv = (1.0d0) / (dx*dx)
      denom = 2  *2
      do n = 0, ncomp-1
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          ii = i/2
          jj = j/2
          lofphi =
     &        alpha * aCoef(i,j,n) * phi(i,j,n)
     &      - beta  *
     &         (
     &           bCoef0(i+1,j  ,n)
     &           * (phi(i+1,j  ,n)-phi(i  ,j  ,n))
     &         - bCoef0(i  ,j  ,n)
     &           * (phi(i  ,j  ,n)-phi(i-1,j  ,n))
     &         + bCoef1(i  ,j+1,n)
     &           * (phi(i  ,j+1,n)-phi(i  ,j  ,n))
     &         - bCoef1(i  ,j  ,n)
     &           * (phi(i  ,j  ,n)-phi(i  ,j-1,n))
     &         ) * dxinv
          res(ii,jj,n) = res(ii,jj,n)
     &                            + (rhs(i,j,n) - lofphi) / denom
      enddo
      enddo
      enddo
      return
      end
      subroutine SUMFACES(
     &           lhs
     &           ,ilhslo0,ilhslo1
     &           ,ilhshi0,ilhshi1
     &           ,nlhscomp
     &           ,beta
     &           ,bCoefs
     &           ,ibCoefslo0,ibCoefslo1
     &           ,ibCoefshi0,ibCoefshi1
     &           ,nbCoefscomp
     &           ,iboxlo0,iboxlo1
     &           ,iboxhi0,iboxhi1
     &           ,dir
     &           ,scale
     &           )
      implicit none
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer nlhscomp
      integer ilhslo0,ilhslo1
      integer ilhshi0,ilhshi1
      REAL*8 lhs(
     &           ilhslo0:ilhshi0,
     &           ilhslo1:ilhshi1,
     &           0:nlhscomp-1)
      REAL*8 beta
      integer nbCoefscomp
      integer ibCoefslo0,ibCoefslo1
      integer ibCoefshi0,ibCoefshi1
      REAL*8 bCoefs(
     &           ibCoefslo0:ibCoefshi0,
     &           ibCoefslo1:ibCoefshi1,
     &           0:nbCoefscomp-1)
      integer iboxlo0,iboxlo1
      integer iboxhi0,iboxhi1
      integer dir
      REAL*8 scale
      REAL*8 sumVal
      integer i,j
      integer ii,jj
      integer n
      ii = CHF_ID(0,dir)
      jj = CHF_ID(1,dir)
      do n = 0, nlhscomp-1
      do j = iboxlo1,iboxhi1
      do i = iboxlo0,iboxhi0
          sumVal = bCoefs(i+ii,j+jj,n)
     &           + bCoefs(i   ,j   ,n)
          lhs(i,j,n) = lhs(i,j,n) + scale * beta * sumVal
      enddo
      enddo
      enddo
      return
      end


      subroutine setprob
      implicit double precision (a-h,o-z)
      character*12 fname
      common /comrp/ theta
c
c     # Burgers' equation at an angle theta to the grid,
c     #  u_t + cos(theta)*(0.5*u^2)_x + sin(theta)*(0.5*u^2)_y = 0
c
c     # Set theta for angle
c     # Passed to the Riemann solver rp1.f in a common block
c
c
      iunit = 7
      fname = 'setprob.data'
c     # open the unit with new routine from Clawpack 4.4 to skip over
c     # comment lines starting with #:
      call opendatafile(iunit, fname)

      read(7,*) theta

      return
      end


program define_constants
  IMPLICIT NONE
  integer, parameter :: dp = selected_real_kind(15)
  REAL(dp)           :: var1, var2, var3

  var1 = 10.0_dp
  var2 = 3.1415927 * var1     ! here the literal 3.14... is NOT typed
  var3 = 3.1415927_dp * var1  ! here the literal 3.14... is typed (dp)

  print*, 'var2 = ', var2
  print*, 'var3 = ', var3
end program define_constants


      SUBROUTINE TSTRML	(IERROR)
C
C LATEST REVISION	 JUNE 1984
C
C PURPOSE		 TO PROVIDE A SIMPLE DEMONSTRATION OF
C			 ROUTINE STRMLN.
C
C USAGE			 CALL TSTRML (IERROR)
C
C ARGUMENTS
C
C ON OUTPUT		 IERROR
C			   AN INTEGER VARIABLE
C			   =0 IF THERE IS A NORMAL EXIT	FROM THE
C			      ROUTINE STRMLN.
C			   =1 OTHERWISE
C
C I/O			 IF THERE IS A NORMAL EXIT FROM	THE ROUTINE
C			 STRMLN	THE MESSAGE
C			   STRMLN TEST SUCCESSFUL . . .	SEE PLOT TO
C			   VERIFY PERFORMANCE
C			 IS PRINTED.
C
C PRECISION		 SINGLE
C
C
C LANGUAGE		 FORTRAN
C
C ALGORITHM		 ROUTINE TSTRML	CALLS ROUTINE STRMLN TO
C			 PRODUCE A PLOT	REPRESENTING THE  FLOW AND
C			 MAGNITUDE OF A	VECTOR FIELD.
C
C PORTABILITY		 FORTRAN77
C
C
C
      REAL	      U(21,25)	 ,V(21,25)   ,WRK(1050)
C
C SPECIFY COORDINATES FOR PLOT TITLES.	ON AN ABSTRACT GRID WHERE
C THE INTEGER COORDINATES RANGE	FROM 0.0 TO 1.0, THE VALUES TX AND TY
C DEFINE THE CENTER OF THE TITLE STRING.
C
      DATA TX/.5/,TY/.9765/
C
C     SET DIMENSIONS
C
      DATA NH,NV/21,25/
C
C INITIALIZE ERROR PARAMETER
C
      IERROR = 1
C
C SPECIFY HORIZONTAL AND VERTICAL VECTOR COMPONENTS U AND V ON
C THE RECTANGULAR GRID
C
      TPIMX = 2.*3.14/FLOAT(NH)
      TPJMX = 2.*3.14/FLOAT(NV)
      DO  20 J=1,NV
	 DO  10	I=1,NH
	 U(I,J)	= SIN(TPIMX*(FLOAT(I)-1.))
	 V(I,J)	= SIN(TPJMX*(FLOAT(J)-1.))
   10	 CONTINUE
   20 CONTINUE
C
C SELECT NORMALIZATION TRANSFORMATION 0
C
      CALL GSELNT (0)
C
C CALL WTSTR FOR STRMLN	PLOT TITLE
C
      CALL WTSTR (TX,TY,'DEMONSTRATION PLOT FOR ROUTINE STRMLN',2,
     1		  0,0)
C
C DEFINE NORMALIZATION TRANSFORMATION 1, AND SET UP LOG	SCALING
C
      CALL GSVP	( 1, 0.1, 0.9, 0.1, 0.9	)
      CALL GSWN	( 1, 1.0, 21., 1.0, 25.	)
      CALL SETUSV ( 'LS' , 1 )
C
C SELECT NORMALIZATION TRANSFORMATION 1
C
      CALL GSELNT (1)
C
C     DRAW PERIMETER
C
c     CALL PERIM(1,0,1,0)
C
C CALL STRMLN FOR VECTOR FIELD STREAMLINES PLOT
C
      CALL STRMLN (U,V,WRK,NH,NH,NV,0,IER)
C
c     CALL NEWFM
C
      IERROR = 0
c     WRITE (6,1001)
      RETURN
C
c1001 FORMAT ('	    STRMLN TEST	SUCCESSFUL',24X,
c    1	      'SEE PLOT	TO VERIFY PERFORMANCE')
C
      END


!> \file dictionary_m.f90
!! \brief Module file for dictionary_t

!> Dictionary type that uses strings for the keys and values
!!
!! Design:
!!  - djb2 hash function (D. J. Bernstein, see http://www.cse.yorku.ca/~oz/hash.html)
!!  - The strings are all "character(len=:), allocatable" variables
!!  - There is no linked list nor pointers, only allocatable arrays for the dynamic data structure
!!  - set rewrites existing entries without complaining

module dictionary_m
  implicit none

  private

  public :: dictionary_t

  !> Single entry in the dictionary
  type entry_t
     character(len=:), allocatable :: key
     character(len=:), allocatable :: value
  end type entry_t

  !> A bucket contains several entries
  type bucket_t
     type(entry_t), allocatable :: entries(:)
     integer :: current_size = 0
     integer :: current_idx = 0
   contains
     procedure :: find
  end type bucket_t

  !> The dictionary contains dict_size buckets (defined at run time)
  type dictionary_t
     type(bucket_t), allocatable :: buckets(:)
     integer :: dict_size = 0
   contains
     procedure :: djb2
     procedure :: set
     procedure :: get
     procedure :: init
     procedure :: show
  end type dictionary_t

  integer, parameter :: BUCKET_EMPTY = -2
  integer, parameter :: BUCKET_ENTRY_NOT_FOUND = -4

contains

  !> djb2 hash function
  !!
  !! \param this the dictionary_t object
  !! \param s a string
  !!
  !! \return the hash value between 0 and dict_size-1
  function djb2(this, s) result(r)
    class(dictionary_t), intent(in) :: this
    character(len=*), intent(in) :: s
    integer :: r

    integer :: i, l

    l = len(s)

    r = 5381

    do i = 1, l
       r = r*33 + ichar(s(i:i))
    end do

    r = modulo(r, this%dict_size)

  end function djb2

  !> Add or replace an entry in the dictionary
  !!
  !! \param this the dictionary_t object
  !! \param k the key
  !! \param v the value
  subroutine set(this, k, v)
    class(dictionary_t), intent(inout) :: this
    character(len=*), intent(in) :: k
    character(len=*), intent(in) :: v

    type(bucket_t) :: tmp_bucket

    integer :: h, i, b_idx

    h = this%djb2(k) + 1

    b_idx = this%buckets(h)%find(k)

    if (b_idx == BUCKET_EMPTY) then
       ! allocate bucket for 1 entry
       ! also, means we can take the first entry
       allocate(this%buckets(h)%entries(1))
       this%buckets(h)%current_size = 1
       this%buckets(h)%current_idx = 1
       b_idx = 1
       this%buckets(h)%entries(1)%key = trim(k)
       this%buckets(h)%entries(1)%value = trim(v)
       ! the values are registered, exit
       return
    end if

    if (b_idx == BUCKET_ENTRY_NOT_FOUND) then
       ! copy and grow bucket entries

       allocate(tmp_bucket%entries(this%buckets(h)%current_size + 1))
       tmp_bucket%current_size = this%buckets(h)%current_size + 1
       tmp_bucket%current_idx = this%buckets(h)%current_idx + 1

       do i = 1, this%buckets(h)%current_size
          tmp_bucket%entries(i)%key = this%buckets(h)%entries(i)%key
          tmp_bucket%entries(i)%value = this%buckets(h)%entries(i)%value
       end do

       deallocate(this%buckets(h)%entries)
       allocate(this%buckets(h)%entries, source=tmp_bucket%entries)
       deallocate(tmp_bucket%entries)

       this%buckets(h)%current_size = tmp_bucket%current_size
       this%buckets(h)%current_idx = tmp_bucket%current_idx
       b_idx = this%buckets(h)%current_idx
    end if

    if (b_idx > 0) then
       this%buckets(h)%entries(b_idx)%key = k
       this%buckets(h)%entries(b_idx)%value = v
    end if

  end subroutine set

  !> Initialize a dictionary object
  !!
  !! \param this the dictionary_t object
  !! \param dict_size the size of the hash table
  subroutine init(this, dict_size)
    class(dictionary_t), intent(out) :: this
    integer, intent(in) :: dict_size

    allocate(this%buckets(dict_size))
    this%dict_size = dict_size

  end subroutine init

  !> Display the content of a dictionary
  !!
  !! \param this the dictionary_t object
  subroutine show(this)
    class(dictionary_t), intent(in) :: this

    integer :: i, j, s
    integer :: n

    n = 0
    do i = 1, this%dict_size
       s = this%buckets(i)%current_idx
       if (s > 0) then
             write(*,*) 'bucket   : ', i, ' size ', s
          do j = 1, s
             write(*,*) 'key      : ', this%buckets(i)%entries(j)%key
             write(*,*) 'value    : ', this%buckets(i)%entries(j)%value
          end do
       end if
    end do

  end subroutine show

  !> Find the "in-bucket" index for a given key
  !!
  !! Negative return values correspond to module-defined return codes.
  !!
  !! \param this the bucket_t object
  !! \param k the key
  !!
  !! \return the index (1-based) of the key in the bucket or a return code
  function find(this, k) result(r)
    class(bucket_t), intent(in) :: this
    character(len=*), intent(in) :: k
    integer :: r

    integer :: i

    if (this%current_size == 0) then
       r = BUCKET_EMPTY
       return
    end if

    r = BUCKET_ENTRY_NOT_FOUND
    do i = 1, this%current_size
       if (this%entries(i)%key == trim(k)) then
          r = i
          exit
       end if
    end do

  end function find

  !> Fetch an entry in the dictionary.
  !!
  !! \param this the dictionary_t object
  !! \param k the key
  !!
  !! \return the value if found, an empty string else
  function get(this, k) result(r)
    class(dictionary_t), intent(in) :: this
    character(len=*), intent(in) :: k

    character(len=:), allocatable :: r

    integer :: h, b_idx

    h = this%djb2(k) + 1

    b_idx = this%buckets(h)%find(k)

    if ( (b_idx == BUCKET_EMPTY) .or. &
         (b_idx == BUCKET_ENTRY_NOT_FOUND) ) then
       r = ''
       return
    end if

    if (b_idx>0) then
       r = this%buckets(h)%entries(b_idx)%value
    end if

  end function get

end module dictionary_m


!***********************************/
!	Name:ユーザー指定の時間刻みがCFL条件に抵触する場合，自動的に時間刻みを変更するプログラム
!	Alias:CheckCFL4FixedTime
!	Description:変更された時間刻みは，元の時間刻みの整数分の1になるようにして，なるべく統一時間刻みに戻す
!	Type:
!	Input:
!	Output:
!	Note:
!	Author:Akitaka Toyota
!	Date:2018.02.01
!	Update:
!	Other:
!***********************************/
subroutine CheckCFL4FixedTime(Geom,CC,iSplit)
use StructVar_Mod
use ConstantVar_Mod
implicit none

    type(Geometry),intent(in) :: Geom
    type(CellCenter), intent(inout) :: CC
    integer, intent(inout) :: iSplit

    call CalcTimeWidth(Geom,CC)
    iSplit = ceiling(DefaultTimeStep / minval(CC%TimeWidth(:,1,1),1)) !ceiling:天井= 切り上げ

return
end subroutine CheckCFL4FixedTime


      SUBROUTINE STREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
     $                   LDVR, MM, M, WORK, INFO )
*
*  -- LAPACK routine (instrumented to count operations, version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      CHARACTER          HOWMNY, SIDE
      INTEGER            INFO, LDT, LDVL, LDVR, M, MM, N
*     ..
*     .. Array Arguments ..
      LOGICAL            SELECT( * )
      REAL               T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
     $                   WORK( * )
*     ..
*     Common block to return operation count.
*     OPS is only incremented, OPST is used to accumulate small
*     contributions to OPS to avoid roundoff error
*     .. Common blocks ..
      COMMON             / LATIME / OPS, ITCNT
*     ..
*     .. Scalars in Common ..
      REAL               ITCNT, OPS
*     ..
*
*  Purpose
*  =======
*
*  STREVC computes some or all of the right and/or left eigenvectors of
*  a real upper quasi-triangular matrix T.
*
*  The right eigenvector x and the left eigenvector y of T corresponding
*  to an eigenvalue w are defined by:
*
*               T*x = w*x,     y'*T = w*y'
*
*  where y' denotes the conjugate transpose of the vector y.
*
*  If all eigenvectors are requested, the routine may either return the
*  matrices X and/or Y of right or left eigenvectors of T, or the
*  products Q*X and/or Q*Y, where Q is an input orthogonal
*  matrix. If T was obtained from the real-Schur factorization of an
*  original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of
*  right or left eigenvectors of A.
*
*  T must be in Schur canonical form (as returned by SHSEQR), that is,
*  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
*  2-by-2 diagonal block has its diagonal elements equal and its
*  off-diagonal elements of opposite sign.  Corresponding to each 2-by-2
*  diagonal block is a complex conjugate pair of eigenvalues and
*  eigenvectors; only one eigenvector of the pair is computed, namely
*  the one corresponding to the eigenvalue with positive imaginary part.
*
*  Arguments
*  =========
*
*  SIDE    (input) CHARACTER*1
*          = 'R':  compute right eigenvectors only;
*          = 'L':  compute left eigenvectors only;
*          = 'B':  compute both right and left eigenvectors.
*
*  HOWMNY  (input) CHARACTER*1
*          = 'A':  compute all right and/or left eigenvectors;
*          = 'B':  compute all right and/or left eigenvectors,
*                  and backtransform them using the input matrices
*                  supplied in VR and/or VL;
*          = 'S':  compute selected right and/or left eigenvectors,
*                  specified by the logical array SELECT.
*
*  SELECT  (input/output) LOGICAL array, dimension (N)
*          If HOWMNY = 'S', SELECT specifies the eigenvectors to be
*          computed.
*          If HOWMNY = 'A' or 'B', SELECT is not referenced.
*          To select the real eigenvector corresponding to a real
*          eigenvalue w(j), SELECT(j) must be set to .TRUE..  To select
*          the complex eigenvector corresponding to a complex conjugate
*          pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be
*          set to .TRUE.; then on exit SELECT(j) is .TRUE. and
*          SELECT(j+1) is .FALSE..
*
*  N       (input) INTEGER
*          The order of the matrix T. N >= 0.
*
*  T       (input) REAL array, dimension (LDT,N)
*          The upper quasi-triangular matrix T in Schur canonical form.
*
*  LDT     (input) INTEGER
*          The leading dimension of the array T. LDT >= max(1,N).
*
*  VL      (input/output) REAL array, dimension (LDVL,MM)
*          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
*          contain an N-by-N matrix Q (usually the orthogonal matrix Q
*          of Schur vectors returned by SHSEQR).
*          On exit, if SIDE = 'L' or 'B', VL contains:
*          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
*                           VL has the same quasi-lower triangular form
*                           as T'. If T(i,i) is a real eigenvalue, then
*                           the i-th column VL(i) of VL  is its
*                           corresponding eigenvector. If T(i:i+1,i:i+1)
*                           is a 2-by-2 block whose eigenvalues are
*                           complex-conjugate eigenvalues of T, then
*                           VL(i)+sqrt(-1)*VL(i+1) is the complex
*                           eigenvector corresponding to the eigenvalue
*                           with positive real part.
*          if HOWMNY = 'B', the matrix Q*Y;
*          if HOWMNY = 'S', the left eigenvectors of T specified by
*                           SELECT, stored consecutively in the columns
*                           of VL, in the same order as their
*                           eigenvalues.
*          A complex eigenvector corresponding to a complex eigenvalue
*          is stored in two consecutive columns, the first holding the
*          real part, and the second the imaginary part.
*          If SIDE = 'R', VL is not referenced.
*
*  LDVL    (input) INTEGER
*          The leading dimension of the array VL.  LDVL >= max(1,N) if
*          SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
*
*  VR      (input/output) REAL array, dimension (LDVR,MM)
*          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
*          contain an N-by-N matrix Q (usually the orthogonal matrix Q
*          of Schur vectors returned by SHSEQR).
*          On exit, if SIDE = 'R' or 'B', VR contains:
*          if HOWMNY = 'A', the matrix X of right eigenvectors of T;
*                           VR has the same quasi-upper triangular form
*                           as T. If T(i,i) is a real eigenvalue, then
*                           the i-th column VR(i) of VR  is its
*                           corresponding eigenvector. If T(i:i+1,i:i+1)
*                           is a 2-by-2 block whose eigenvalues are
*                           complex-conjugate eigenvalues of T, then
*                           VR(i)+sqrt(-1)*VR(i+1) is the complex
*                           eigenvector corresponding to the eigenvalue
*                           with positive real part.
*          if HOWMNY = 'B', the matrix Q*X;
*          if HOWMNY = 'S', the right eigenvectors of T specified by
*                           SELECT, stored consecutively in the columns
*                           of VR, in the same order as their
*                           eigenvalues.
*          A complex eigenvector corresponding to a complex eigenvalue
*          is stored in two consecutive columns, the first holding the
*          real part and the second the imaginary part.
*          If SIDE = 'L', VR is not referenced.
*
*  LDVR    (input) INTEGER
*          The leading dimension of the array VR.  LDVR >= max(1,N) if
*          SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
*
*  MM      (input) INTEGER
*          The number of columns in the arrays VL and/or VR. MM >= M.
*
*  M       (output) INTEGER
*          The number of columns in the arrays VL and/or VR actually
*          used to store the eigenvectors.
*          If HOWMNY = 'A' or 'B', M is set to N.
*          Each selected real eigenvector occupies one column and each
*          selected complex eigenvector occupies two columns.
*
*  WORK    (workspace) REAL array, dimension (3*N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  Further Details
*  ===============
*
*  The algorithm used in this program is basically backward (forward)
*  substitution, with scaling to make the the code robust against
*  possible overflow.
*
*  Each eigenvector is normalized so that the element of largest
*  magnitude has magnitude 1; here the magnitude of a complex number
*  (x,y) is taken to be |x| + |y|.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV
      INTEGER            I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2
      REAL               BETA, BIGNUM, EMAX, OPST, OVFL, REC, REMAX,
     $                   SCALE, SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX,
     $                   WI, WR, XNORM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ISAMAX
      REAL               SDOT, SLAMCH
      EXTERNAL           LSAME, ISAMAX, SDOT, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           SAXPY, SCOPY, SGEMV, SLABAD, SLALN2, SSCAL,
     $                   XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
*     ..
*     .. Local Arrays ..
      REAL               X( 2, 2 )
*     ..
*     .. Executable Statements ..
*
*     Decode and test the input parameters
*
      BOTHV = LSAME( SIDE, 'B' )
      RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
      LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
*
      ALLV = LSAME( HOWMNY, 'A' )
      OVER = LSAME( HOWMNY, 'B' )
      SOMEV = LSAME( HOWMNY, 'S' )
*
      INFO = 0
      IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
         INFO = -1
      ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
         INFO = -8
      ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
         INFO = -10
      ELSE
*
*        Set M to the number of columns required to store the selected
*        eigenvectors, standardize the array SELECT if necessary, and
*        test MM.
*
         IF( SOMEV ) THEN
            M = 0
            PAIR = .FALSE.
            DO 10 J = 1, N
               IF( PAIR ) THEN
                  PAIR = .FALSE.
                  SELECT( J ) = .FALSE.
               ELSE
                  IF( J.LT.N ) THEN
                     IF( T( J+1, J ).EQ.ZERO ) THEN
                        IF( SELECT( J ) )
     $                     M = M + 1
                     ELSE
                        PAIR = .TRUE.
                        IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN
                           SELECT( J ) = .TRUE.
                           M = M + 2
                        END IF
                     END IF
                  ELSE
                     IF( SELECT( N ) )
     $                  M = M + 1
                  END IF
               END IF
   10       CONTINUE
         ELSE
            M = N
         END IF
*
         IF( MM.LT.M ) THEN
            INFO = -11
         END IF
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'STREVC', -INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
***
*     Initialize
      OPST = 0
***
*
*     Set the constants to control overflow.
*
      UNFL = SLAMCH( 'Safe minimum' )
      OVFL = ONE / UNFL
      CALL SLABAD( UNFL, OVFL )
      ULP = SLAMCH( 'Precision' )
      SMLNUM = UNFL*( N / ULP )
      BIGNUM = ( ONE-ULP ) / SMLNUM
*
*     Compute 1-norm of each column of strictly upper triangular
*     part of T to control overflow in triangular solver.
*
      WORK( 1 ) = ZERO
      DO 30 J = 2, N
         WORK( J ) = ZERO
         DO 20 I = 1, J - 1
            WORK( J ) = WORK( J ) + ABS( T( I, J ) )
   20    CONTINUE
   30 CONTINUE
***
      OPS = OPS + N*( N-1 ) / 2
***
*
*     Index IP is used to specify the real or complex eigenvalue:
*       IP = 0, real eigenvalue,
*            1, first of conjugate complex pair: (wr,wi)
*           -1, second of conjugate complex pair: (wr,wi)
*
      N2 = 2*N
*
      IF( RIGHTV ) THEN
*
*        Compute right eigenvectors.
*
         IP = 0
         IS = M
         DO 140 KI = N, 1, -1
*
            IF( IP.EQ.1 )
     $         GO TO 130
            IF( KI.EQ.1 )
     $         GO TO 40
            IF( T( KI, KI-1 ).EQ.ZERO )
     $         GO TO 40
            IP = -1
*
   40       CONTINUE
            IF( SOMEV ) THEN
               IF( IP.EQ.0 ) THEN
                  IF( .NOT.SELECT( KI ) )
     $               GO TO 130
               ELSE
                  IF( .NOT.SELECT( KI-1 ) )
     $               GO TO 130
               END IF
            END IF
*
*           Compute the KI-th eigenvalue (WR,WI).
*
            WR = T( KI, KI )
            WI = ZERO
            IF( IP.NE.0 )
     $         WI = SQRT( ABS( T( KI, KI-1 ) ) )*
     $              SQRT( ABS( T( KI-1, KI ) ) )
            SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
*
            IF( IP.EQ.0 ) THEN
*
*              Real right eigenvector
*
               WORK( KI+N ) = ONE
*
*              Form right-hand side
*
               DO 50 K = 1, KI - 1
                  WORK( K+N ) = -T( K, KI )
   50          CONTINUE
*
*              Solve the upper quasi-triangular system:
*                 (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK.
*
               JNXT = KI - 1
               DO 60 J = KI - 1, 1, -1
                  IF( J.GT.JNXT )
     $               GO TO 60
                  J1 = J
                  J2 = J
                  JNXT = J - 1
                  IF( J.GT.1 ) THEN
                     IF( T( J, J-1 ).NE.ZERO ) THEN
                        J1 = J - 1
                        JNXT = J - 2
                     END IF
                  END IF
*
                  IF( J1.EQ.J2 ) THEN
*
*                    1-by-1 diagonal block
*
                     CALL SLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
     $                            LDT, ONE, ONE, WORK( J+N ), N, WR,
     $                            ZERO, X, 2, SCALE, XNORM, IERR )
*
*                    Scale X(1,1) to avoid overflow when updating
*                    the right-hand side.
*
                     IF( XNORM.GT.ONE ) THEN
                        IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
                           X( 1, 1 ) = X( 1, 1 ) / XNORM
                           SCALE = SCALE / XNORM
                        END IF
                     END IF
*
*                    Scale if necessary
*
                     IF( SCALE.NE.ONE )
     $                  CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
                     WORK( J+N ) = X( 1, 1 )
*
*                    Update right-hand side
*
                     CALL SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
     $                           WORK( 1+N ), 1 )
***
*                    Increment op count, ignoring the possible scaling
                     OPST = OPST + ( 2*( J-1 )+6 )
***
*
                  ELSE
*
*                    2-by-2 diagonal block
*
                     CALL SLALN2( .FALSE., 2, 1, SMIN, ONE,
     $                            T( J-1, J-1 ), LDT, ONE, ONE,
     $                            WORK( J-1+N ), N, WR, ZERO, X, 2,
     $                            SCALE, XNORM, IERR )
*
*                    Scale X(1,1) and X(2,1) to avoid overflow when
*                    updating the right-hand side.
*
                     IF( XNORM.GT.ONE ) THEN
                        BETA = MAX( WORK( J-1 ), WORK( J ) )
                        IF( BETA.GT.BIGNUM / XNORM ) THEN
                           X( 1, 1 ) = X( 1, 1 ) / XNORM
                           X( 2, 1 ) = X( 2, 1 ) / XNORM
                           SCALE = SCALE / XNORM
                        END IF
                     END IF
*
*                    Scale if necessary
*
                     IF( SCALE.NE.ONE )
     $                  CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
                     WORK( J-1+N ) = X( 1, 1 )
                     WORK( J+N ) = X( 2, 1 )
*
*                    Update right-hand side
*
                     CALL SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
     $                           WORK( 1+N ), 1 )
                     CALL SAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
     $                           WORK( 1+N ), 1 )
***
*                    Increment op count, ignoring the possible scaling
                     OPST = OPST + ( 4*( J-2 )+24 )
***
                  END IF
   60          CONTINUE
*
*              Copy the vector x or Q*x to VR and normalize.
*
               IF( .NOT.OVER ) THEN
                  CALL SCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 )
*
                  II = ISAMAX( KI, VR( 1, IS ), 1 )
                  REMAX = ONE / ABS( VR( II, IS ) )
                  CALL SSCAL( KI, REMAX, VR( 1, IS ), 1 )
***
                  OPST = OPST + ( 2*KI+1 )
***
*
                  DO 70 K = KI + 1, N
                     VR( K, IS ) = ZERO
   70             CONTINUE
               ELSE
                  IF( KI.GT.1 )
     $               CALL SGEMV( 'N', N, KI-1, ONE, VR, LDVR,
     $                           WORK( 1+N ), 1, WORK( KI+N ),
     $                           VR( 1, KI ), 1 )
*
                  II = ISAMAX( N, VR( 1, KI ), 1 )
                  REMAX = ONE / ABS( VR( II, KI ) )
                  CALL SSCAL( N, REMAX, VR( 1, KI ), 1 )
***
                  OPS = OPS + ( 2*N*KI+1 )
***
               END IF
*
            ELSE
*
*              Complex right eigenvector.
*
*              Initial solve
*                [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0.
*                [ (T(KI,KI-1)   T(KI,KI)   )               ]
*
               IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN
                  WORK( KI-1+N ) = ONE
                  WORK( KI+N2 ) = WI / T( KI-1, KI )
               ELSE
                  WORK( KI-1+N ) = -WI / T( KI, KI-1 )
                  WORK( KI+N2 ) = ONE
               END IF
               WORK( KI+N ) = ZERO
               WORK( KI-1+N2 ) = ZERO
*
*              Form right-hand side
*
               DO 80 K = 1, KI - 2
                  WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 )
                  WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI )
   80          CONTINUE
***
               OPST = OPST + 2*( KI-2 )
***
*
*              Solve upper quasi-triangular system:
*              (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2)
*
               JNXT = KI - 2
               DO 90 J = KI - 2, 1, -1
                  IF( J.GT.JNXT )
     $               GO TO 90
                  J1 = J
                  J2 = J
                  JNXT = J - 1
                  IF( J.GT.1 ) THEN
                     IF( T( J, J-1 ).NE.ZERO ) THEN
                        J1 = J - 1
                        JNXT = J - 2
                     END IF
                  END IF
*
                  IF( J1.EQ.J2 ) THEN
*
*                    1-by-1 diagonal block
*
                     CALL SLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
     $                            LDT, ONE, ONE, WORK( J+N ), N, WR, WI,
     $                            X, 2, SCALE, XNORM, IERR )
*
*                    Scale X(1,1) and X(1,2) to avoid overflow when
*                    updating the right-hand side.
*
                     IF( XNORM.GT.ONE ) THEN
                        IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
                           X( 1, 1 ) = X( 1, 1 ) / XNORM
                           X( 1, 2 ) = X( 1, 2 ) / XNORM
                           SCALE = SCALE / XNORM
                        END IF
                     END IF
*
*                    Scale if necessary
*
                     IF( SCALE.NE.ONE ) THEN
                        CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
                        CALL SSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
                     END IF
                     WORK( J+N ) = X( 1, 1 )
                     WORK( J+N2 ) = X( 1, 2 )
*
*                    Update the right-hand side
*
                     CALL SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
     $                           WORK( 1+N ), 1 )
                     CALL SAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1,
     $                           WORK( 1+N2 ), 1 )
***
*                    Increment op count, ignoring the possible scaling
                     OPST = OPST + ( 4*( J-1 )+24 )
***
*
                  ELSE
*
*                    2-by-2 diagonal block
*
                     CALL SLALN2( .FALSE., 2, 2, SMIN, ONE,
     $                            T( J-1, J-1 ), LDT, ONE, ONE,
     $                            WORK( J-1+N ), N, WR, WI, X, 2, SCALE,
     $                            XNORM, IERR )
*
*                    Scale X to avoid overflow when updating
*                    the right-hand side.
*
                     IF( XNORM.GT.ONE ) THEN
                        BETA = MAX( WORK( J-1 ), WORK( J ) )
                        IF( BETA.GT.BIGNUM / XNORM ) THEN
                           REC = ONE / XNORM
                           X( 1, 1 ) = X( 1, 1 )*REC
                           X( 1, 2 ) = X( 1, 2 )*REC
                           X( 2, 1 ) = X( 2, 1 )*REC
                           X( 2, 2 ) = X( 2, 2 )*REC
                           SCALE = SCALE*REC
                        END IF
                     END IF
*
*                    Scale if necessary
*
                     IF( SCALE.NE.ONE ) THEN
                        CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
                        CALL SSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
                     END IF
                     WORK( J-1+N ) = X( 1, 1 )
                     WORK( J+N ) = X( 2, 1 )
                     WORK( J-1+N2 ) = X( 1, 2 )
                     WORK( J+N2 ) = X( 2, 2 )
*
*                    Update the right-hand side
*
                     CALL SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
     $                           WORK( 1+N ), 1 )
                     CALL SAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
     $                           WORK( 1+N ), 1 )
                     CALL SAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1,
     $                           WORK( 1+N2 ), 1 )
                     CALL SAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1,
     $                           WORK( 1+N2 ), 1 )
***
*                    Increment op count, ignoring the possible scaling
                     OPST = OPST + ( 8*( J-2 )+64 )
***
                  END IF
   90          CONTINUE
*
*              Copy the vector x or Q*x to VR and normalize.
*
               IF( .NOT.OVER ) THEN
                  CALL SCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 )
                  CALL SCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 )
*
                  EMAX = ZERO
                  DO 100 K = 1, KI
                     EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+
     $                      ABS( VR( K, IS ) ) )
  100             CONTINUE
*
                  REMAX = ONE / EMAX
                  CALL SSCAL( KI, REMAX, VR( 1, IS-1 ), 1 )
                  CALL SSCAL( KI, REMAX, VR( 1, IS ), 1 )
***
                  OPST = OPST + ( 4*KI+1 )
***
*
                  DO 110 K = KI + 1, N
                     VR( K, IS-1 ) = ZERO
                     VR( K, IS ) = ZERO
  110             CONTINUE
*
               ELSE
*
                  IF( KI.GT.2 ) THEN
                     CALL SGEMV( 'N', N, KI-2, ONE, VR, LDVR,
     $                           WORK( 1+N ), 1, WORK( KI-1+N ),
     $                           VR( 1, KI-1 ), 1 )
                     CALL SGEMV( 'N', N, KI-2, ONE, VR, LDVR,
     $                           WORK( 1+N2 ), 1, WORK( KI+N2 ),
     $                           VR( 1, KI ), 1 )
                  ELSE
                     CALL SSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 )
                     CALL SSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 )
                  END IF
*
                  EMAX = ZERO
                  DO 120 K = 1, N
                     EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+
     $                      ABS( VR( K, KI ) ) )
  120             CONTINUE
                  REMAX = ONE / EMAX
                  CALL SSCAL( N, REMAX, VR( 1, KI-1 ), 1 )
                  CALL SSCAL( N, REMAX, VR( 1, KI ), 1 )
***
                  OPS = OPS + ( 4*N*( KI-2 )+6*N+1 )
***
               END IF
            END IF
*
            IS = IS - 1
            IF( IP.NE.0 )
     $         IS = IS - 1
  130       CONTINUE
            IF( IP.EQ.1 )
     $         IP = 0
            IF( IP.EQ.-1 )
     $         IP = 1
  140    CONTINUE
      END IF
*
      IF( LEFTV ) THEN
*
*        Compute left eigenvectors.
*
         IP = 0
         IS = 1
         DO 260 KI = 1, N
*
            IF( IP.EQ.-1 )
     $         GO TO 250
            IF( KI.EQ.N )
     $         GO TO 150
            IF( T( KI+1, KI ).EQ.ZERO )
     $         GO TO 150
            IP = 1
*
  150       CONTINUE
            IF( SOMEV ) THEN
               IF( .NOT.SELECT( KI ) )
     $            GO TO 250
            END IF
*
*           Compute the KI-th eigenvalue (WR,WI).
*
            WR = T( KI, KI )
            WI = ZERO
            IF( IP.NE.0 )
     $         WI = SQRT( ABS( T( KI, KI+1 ) ) )*
     $              SQRT( ABS( T( KI+1, KI ) ) )
            SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
*
            IF( IP.EQ.0 ) THEN
*
*              Real left eigenvector.
*
               WORK( KI+N ) = ONE
*
*              Form right-hand side
*
               DO 160 K = KI + 1, N
                  WORK( K+N ) = -T( KI, K )
  160          CONTINUE
*
*              Solve the quasi-triangular system:
*                 (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK
*
               VMAX = ONE
               VCRIT = BIGNUM
*
               JNXT = KI + 1
               DO 170 J = KI + 1, N
                  IF( J.LT.JNXT )
     $               GO TO 170
                  J1 = J
                  J2 = J
                  JNXT = J + 1
                  IF( J.LT.N ) THEN
                     IF( T( J+1, J ).NE.ZERO ) THEN
                        J2 = J + 1
                        JNXT = J + 2
                     END IF
                  END IF
*
                  IF( J1.EQ.J2 ) THEN
*
*                    1-by-1 diagonal block
*
*                    Scale if necessary to avoid overflow when forming
*                    the right-hand side.
*
                     IF( WORK( J ).GT.VCRIT ) THEN
                        REC = ONE / VMAX
                        CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
                        VMAX = ONE
                        VCRIT = BIGNUM
                     END IF
*
                     WORK( J+N ) = WORK( J+N ) -
     $                             SDOT( J-KI-1, T( KI+1, J ), 1,
     $                             WORK( KI+1+N ), 1 )
*
*                    Solve (T(J,J)-WR)'*X = WORK
*
                     CALL SLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
     $                            LDT, ONE, ONE, WORK( J+N ), N, WR,
     $                            ZERO, X, 2, SCALE, XNORM, IERR )
*
*                    Scale if necessary
*
                     IF( SCALE.NE.ONE )
     $                  CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
                     WORK( J+N ) = X( 1, 1 )
                     VMAX = MAX( ABS( WORK( J+N ) ), VMAX )
                     VCRIT = BIGNUM / VMAX
***
*                    Increment op count, ignoring the possible scaling
                     OPST = OPST + ( 2*( J-KI-1 )+6 )
***
*
                  ELSE
*
*                    2-by-2 diagonal block
*
*                    Scale if necessary to avoid overflow when forming
*                    the right-hand side.
*
                     BETA = MAX( WORK( J ), WORK( J+1 ) )
                     IF( BETA.GT.VCRIT ) THEN
                        REC = ONE / VMAX
                        CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
                        VMAX = ONE
                        VCRIT = BIGNUM
                     END IF
*
                     WORK( J+N ) = WORK( J+N ) -
     $                             SDOT( J-KI-1, T( KI+1, J ), 1,
     $                             WORK( KI+1+N ), 1 )
*
                     WORK( J+1+N ) = WORK( J+1+N ) -
     $                               SDOT( J-KI-1, T( KI+1, J+1 ), 1,
     $                               WORK( KI+1+N ), 1 )
*
*                    Solve
*                      [T(J,J)-WR   T(J,J+1)     ]'* X = SCALE*( WORK1 )
*                      [T(J+1,J)    T(J+1,J+1)-WR]             ( WORK2 )
*
                     CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ),
     $                            LDT, ONE, ONE, WORK( J+N ), N, WR,
     $                            ZERO, X, 2, SCALE, XNORM, IERR )
*
*                    Scale if necessary
*
                     IF( SCALE.NE.ONE )
     $                  CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
                     WORK( J+N ) = X( 1, 1 )
                     WORK( J+1+N ) = X( 2, 1 )
*
                     VMAX = MAX( ABS( WORK( J+N ) ),
     $                      ABS( WORK( J+1+N ) ), VMAX )
                     VCRIT = BIGNUM / VMAX
***
*                    Increment op count, ignoring the possible scaling
                     OPST = OPST + ( 4*( J-KI-1 )+24 )
***
*
                  END IF
  170          CONTINUE
*
*              Copy the vector x or Q*x to VL and normalize.
*
               IF( .NOT.OVER ) THEN
                  CALL SCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
*
                  II = ISAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
                  REMAX = ONE / ABS( VL( II, IS ) )
                  CALL SSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
***
                  OPST = OPST + ( 2*( N-KI+1 )+1 )
***
*
                  DO 180 K = 1, KI - 1
                     VL( K, IS ) = ZERO
  180             CONTINUE
*
               ELSE
*
                  IF( KI.LT.N )
     $               CALL SGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL,
     $                           WORK( KI+1+N ), 1, WORK( KI+N ),
     $                           VL( 1, KI ), 1 )
*
                  II = ISAMAX( N, VL( 1, KI ), 1 )
                  REMAX = ONE / ABS( VL( II, KI ) )
                  CALL SSCAL( N, REMAX, VL( 1, KI ), 1 )
***
                  OPS = OPS + ( 2*N*( N-KI+1 )+1 )
***
*
               END IF
*
            ELSE
*
*              Complex left eigenvector.
*
*               Initial solve:
*                 ((T(KI,KI)    T(KI,KI+1) )' - (WR - I* WI))*X = 0.
*                 ((T(KI+1,KI) T(KI+1,KI+1))                )
*
               IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN
                  WORK( KI+N ) = WI / T( KI, KI+1 )
                  WORK( KI+1+N2 ) = ONE
               ELSE
                  WORK( KI+N ) = ONE
                  WORK( KI+1+N2 ) = -WI / T( KI+1, KI )
               END IF
               WORK( KI+1+N ) = ZERO
               WORK( KI+N2 ) = ZERO
*
*              Form right-hand side
*
               DO 190 K = KI + 2, N
                  WORK( K+N ) = -WORK( KI+N )*T( KI, K )
                  WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K )
  190          CONTINUE
***
               OPST = OPST + 2*( N-KI-1 )
***
*
*              Solve complex quasi-triangular system:
*              ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2
*
               VMAX = ONE
               VCRIT = BIGNUM
*
               JNXT = KI + 2
               DO 200 J = KI + 2, N
                  IF( J.LT.JNXT )
     $               GO TO 200
                  J1 = J
                  J2 = J
                  JNXT = J + 1
                  IF( J.LT.N ) THEN
                     IF( T( J+1, J ).NE.ZERO ) THEN
                        J2 = J + 1
                        JNXT = J + 2
                     END IF
                  END IF
*
                  IF( J1.EQ.J2 ) THEN
*
*                    1-by-1 diagonal block
*
*                    Scale if necessary to avoid overflow when
*                    forming the right-hand side elements.
*
                     IF( WORK( J ).GT.VCRIT ) THEN
                        REC = ONE / VMAX
                        CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
                        CALL SSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
                        VMAX = ONE
                        VCRIT = BIGNUM
                     END IF
*
                     WORK( J+N ) = WORK( J+N ) -
     $                             SDOT( J-KI-2, T( KI+2, J ), 1,
     $                             WORK( KI+2+N ), 1 )
                     WORK( J+N2 ) = WORK( J+N2 ) -
     $                              SDOT( J-KI-2, T( KI+2, J ), 1,
     $                              WORK( KI+2+N2 ), 1 )
*
*                    Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2
*
                     CALL SLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
     $                            LDT, ONE, ONE, WORK( J+N ), N, WR,
     $                            -WI, X, 2, SCALE, XNORM, IERR )
*
*                    Scale if necessary
*
                     IF( SCALE.NE.ONE ) THEN
                        CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
                        CALL SSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
                     END IF
                     WORK( J+N ) = X( 1, 1 )
                     WORK( J+N2 ) = X( 1, 2 )
                     VMAX = MAX( ABS( WORK( J+N ) ),
     $                      ABS( WORK( J+N2 ) ), VMAX )
                     VCRIT = BIGNUM / VMAX
***
*                    Increment op count, ignoring the possible scaling
                     OPST = OPST + ( 4*( J-KI-2 )+24 )
***
*
                  ELSE
*
*                    2-by-2 diagonal block
*
*                    Scale if necessary to avoid overflow when forming
*                    the right-hand side elements.
*
                     BETA = MAX( WORK( J ), WORK( J+1 ) )
                     IF( BETA.GT.VCRIT ) THEN
                        REC = ONE / VMAX
                        CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
                        CALL SSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
                        VMAX = ONE
                        VCRIT = BIGNUM
                     END IF
*
                     WORK( J+N ) = WORK( J+N ) -
     $                             SDOT( J-KI-2, T( KI+2, J ), 1,
     $                             WORK( KI+2+N ), 1 )
*
                     WORK( J+N2 ) = WORK( J+N2 ) -
     $                              SDOT( J-KI-2, T( KI+2, J ), 1,
     $                              WORK( KI+2+N2 ), 1 )
*
                     WORK( J+1+N ) = WORK( J+1+N ) -
     $                               SDOT( J-KI-2, T( KI+2, J+1 ), 1,
     $                               WORK( KI+2+N ), 1 )
*
                     WORK( J+1+N2 ) = WORK( J+1+N2 ) -
     $                                SDOT( J-KI-2, T( KI+2, J+1 ), 1,
     $                                WORK( KI+2+N2 ), 1 )
*
*                    Solve 2-by-2 complex linear equation
*                      ([T(j,j)   T(j,j+1)  ]'-(wr-i*wi)*I)*X = SCALE*B
*                      ([T(j+1,j) T(j+1,j+1)]             )
*
                     CALL SLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ),
     $                            LDT, ONE, ONE, WORK( J+N ), N, WR,
     $                            -WI, X, 2, SCALE, XNORM, IERR )
*
*                    Scale if necessary
*
                     IF( SCALE.NE.ONE ) THEN
                        CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
                        CALL SSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
                     END IF
                     WORK( J+N ) = X( 1, 1 )
                     WORK( J+N2 ) = X( 1, 2 )
                     WORK( J+1+N ) = X( 2, 1 )
                     WORK( J+1+N2 ) = X( 2, 2 )
                     VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ),
     $                      ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX )
                     VCRIT = BIGNUM / VMAX
***
*                    Increment op count, ignoring the possible scaling
                     OPST = OPST + ( 8*( J-KI-2 )+64 )
***
*
                  END IF
  200          CONTINUE
*
*              Copy the vector x or Q*x to VL and normalize.
*
  210          CONTINUE
               IF( .NOT.OVER ) THEN
                  CALL SCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
                  CALL SCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ),
     $                        1 )
*
                  EMAX = ZERO
                  DO 220 K = KI, N
                     EMAX = MAX( EMAX, ABS( VL( K, IS ) )+
     $                      ABS( VL( K, IS+1 ) ) )
  220             CONTINUE
                  REMAX = ONE / EMAX
                  CALL SSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
                  CALL SSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 )
***
                  OPST = OPST + ( 4*( N-KI+1 )+1 )
***
*
                  DO 230 K = 1, KI - 1
                     VL( K, IS ) = ZERO
                     VL( K, IS+1 ) = ZERO
  230             CONTINUE
               ELSE
                  IF( KI.LT.N-1 ) THEN
                     CALL SGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
     $                           LDVL, WORK( KI+2+N ), 1, WORK( KI+N ),
     $                           VL( 1, KI ), 1 )
                     CALL SGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
     $                           LDVL, WORK( KI+2+N2 ), 1,
     $                           WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
                  ELSE
                     CALL SSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 )
                     CALL SSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
                  END IF
*
                  EMAX = ZERO
                  DO 240 K = 1, N
                     EMAX = MAX( EMAX, ABS( VL( K, KI ) )+
     $                      ABS( VL( K, KI+1 ) ) )
  240             CONTINUE
                  REMAX = ONE / EMAX
                  CALL SSCAL( N, REMAX, VL( 1, KI ), 1 )
                  CALL SSCAL( N, REMAX, VL( 1, KI+1 ), 1 )
***
                  OPS = OPS + ( 4*N*( N-KI-1 )+6*N+1 )
***
*
               END IF
*
            END IF
*
            IS = IS + 1
            IF( IP.NE.0 )
     $         IS = IS + 1
  250       CONTINUE
            IF( IP.EQ.-1 )
     $         IP = 0
            IF( IP.EQ.1 )
     $         IP = -1
*
  260    CONTINUE
*
      END IF
***
*     Compute final op count
      OPS = OPS + OPST
***
*
      RETURN
*
*     End of STREVC
*
      END


!*==sdisna.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SDISNA
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SDISNA + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SDISNA( JOB, M, N, D, SEP, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOB
!       INTEGER            INFO, M, N
!       ..
!       .. Array Arguments ..
!       REAL               D( * ), SEP( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SDISNA computes the reciprocal condition numbers for the eigenvectors
!> of a real symmetric or complex Hermitian matrix or for the left or
!> right singular vectors of a general m-by-n matrix. The reciprocal
!> condition number is the 'gap' between the corresponding eigenvalue or
!> singular value and the nearest other one.
!>
!> The bound on the error, measured by angle in radians, in the I-th
!> computed vector is given by
!>
!>        SLAMCH( 'E' ) * ( ANORM / SEP( I ) )
!>
!> where ANORM = 2-norm(A) = max( abs( D(j) ) ).  SEP(I) is not allowed
!> to be smaller than SLAMCH( 'E' )*ANORM in order to limit the size of
!> the error bound.
!>
!> SDISNA may also be used to compute error bounds for eigenvectors of
!> the generalized symmetric definite eigenproblem.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOB
!> \verbatim
!>          JOB is CHARACTER*1
!>          Specifies for which problem the reciprocal condition numbers
!>          should be computed:
!>          = 'E':  the eigenvectors of a symmetric/Hermitian matrix;
!>          = 'L':  the left singular vectors of a general matrix;
!>          = 'R':  the right singular vectors of a general matrix.
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix. M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          If JOB = 'L' or 'R', the number of columns of the matrix,
!>          in which case N >= 0. Ignored if JOB = 'E'.
!> \endverbatim
!>
!> \param[in] D
!> \verbatim
!>          D is REAL array, dimension (M) if JOB = 'E'
!>                              dimension (min(M,N)) if JOB = 'L' or 'R'
!>          The eigenvalues (if JOB = 'E') or singular values (if JOB =
!>          'L' or 'R') of the matrix, in either increasing or decreasing
!>          order. If singular values, they must be non-negative.
!> \endverbatim
!>
!> \param[out] SEP
!> \verbatim
!>          SEP is REAL array, dimension (M) if JOB = 'E'
!>                               dimension (min(M,N)) if JOB = 'L' or 'R'
!>          The reciprocal condition numbers of the vectors.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup auxOTHERcomputational
!
!  =====================================================================
      SUBROUTINE SDISNA(Job,M,N,D,Sep,Info)
      IMPLICIT NONE
!*--SDISNA121
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Job
      INTEGER Info , M , N
!     ..
!     .. Array Arguments ..
      REAL D(*) , Sep(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO
      PARAMETER (ZERO=0.0E+0)
!     ..
!     .. Local Scalars ..
      LOGICAL decr , eigen , incr , left , right , sing
      INTEGER i , k
      REAL anorm , eps , newgap , oldgap , safmin , thresh
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      REAL SLAMCH
      EXTERNAL LSAME , SLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX , MIN
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      eigen = LSAME(Job,'E')
      left = LSAME(Job,'L')
      right = LSAME(Job,'R')
      sing = left .OR. right
      IF ( eigen ) THEN
         k = M
      ELSEIF ( sing ) THEN
         k = MIN(M,N)
      ENDIF
      IF ( .NOT.eigen .AND. .NOT.sing ) THEN
         Info = -1
      ELSEIF ( M<0 ) THEN
         Info = -2
      ELSEIF ( k<0 ) THEN
         Info = -3
      ELSE
         incr = .TRUE.
         decr = .TRUE.
         DO i = 1 , k - 1
            IF ( incr ) incr = incr .AND. D(i)<=D(i+1)
            IF ( decr ) decr = decr .AND. D(i)>=D(i+1)
         ENDDO
         IF ( sing .AND. k>0 ) THEN
            IF ( incr ) incr = incr .AND. ZERO<=D(1)
            IF ( decr ) decr = decr .AND. D(k)>=ZERO
         ENDIF
         IF ( .NOT.(incr .OR. decr) ) Info = -4
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('SDISNA',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( k==0 ) RETURN
!
!     Compute reciprocal condition numbers
!
      IF ( k==1 ) THEN
         Sep(1) = SLAMCH('O')
      ELSE
         oldgap = ABS(D(2)-D(1))
         Sep(1) = oldgap
         DO i = 2 , k - 1
            newgap = ABS(D(i+1)-D(i))
            Sep(i) = MIN(oldgap,newgap)
            oldgap = newgap
         ENDDO
         Sep(k) = oldgap
      ENDIF
      IF ( sing ) THEN
         IF ( (left .AND. M>N) .OR. (right .AND. M<N) ) THEN
            IF ( incr ) Sep(1) = MIN(Sep(1),D(1))
            IF ( decr ) Sep(k) = MIN(Sep(k),D(k))
         ENDIF
      ENDIF
!
!     Ensure that reciprocal condition numbers are not less than
!     threshold, in order to limit the size of the error bound
!
      eps = SLAMCH('E')
      safmin = SLAMCH('S')
      anorm = MAX(ABS(D(1)),ABS(D(k)))
      IF ( anorm==ZERO ) THEN
         thresh = eps
      ELSE
         thresh = MAX(eps*anorm,safmin)
      ENDIF
      DO i = 1 , k
         Sep(i) = MAX(Sep(i),thresh)
      ENDDO
!
!
!     End of SDISNA
!
      END SUBROUTINE SDISNA


INTEGER FUNCTION NOTRI(K,L,M)
  !IMPLICIT REAL*8 (A-H,O-Z)
  IMPLICIT NONE
  INTEGER, intent(in) :: K,L,M
  NOTRI=-1
  IF(MOD((K+L+M),2).EQ.1) RETURN
  IF((K+L-M).LT.0) RETURN
  IF((K-L+M).LT.0) RETURN
  IF((M+L-K).LT.0) RETURN
  NOTRI=1
  RETURN
END FUNCTION NOTRI


== Chooses the smaller of `a` and `b`.
==
== Returns: Number
min (a, b) -> a < b ? a : b

== Chooses the greater of `a` and `b`.
==
== Returns: Number
max (a, b) -> a > b ? a : b

== Keeps given `value` in range [`lo`; `hi`].
==
== Returns: Number
==     `lo` if `value` <= `lo`, `hi` if `value` >= `hi`, `value` otherwise.
clamp (lo, hi, value) -> min (max (lo, value), hi)


program fd

! Calculates the the lowest 26 eigenvalues of the double minimum potential
! using the finite difference (FD) method as described in [1].
! The interpolated potential is saved to 'potential_grid.txt'.

! [1] Tobin, F. L., & Hinze, J. (1975). The eigenvalue problem for a double
! minimum potential. The Journal of Chemical Physics, 63(2), 1034.
! doi:10.1063/1.431399

use types, only: dp
use utils, only: stop_error, newunit, savetxt
use mesh, only: mesh_exp
use interpolation, only: spline3, lagrange3interp, hermite5interp, loadtxt
use lapack, only: dstevd
implicit none
real(dp) :: rmin, rmax
integer :: N
real(dp), allocatable :: xe(:), lam(:), U(:)
integer :: i
real(dp) :: mu, E0, au
real(dp), allocatable :: data(:, :)
real(dp) :: E, d
call loadtxt("potential_table.txt", data)

rmin = 0
rmax = 12
N = 100000
au = 219474.62_dp
E0 = -0.625_dp
mu = 1836.12_dp / 2
print *, "     R         D          E         dE/dR"
do i = 1, size(data, 1)
    E = data(i, 2)
    print "(f10.4, f10.1, f12.7, f12.7)", data(i, 1), (E0-E)*au, E, data(i, 3)
end do

d = (rmax-rmin)/(N-1)
allocate(xe(N), U(N), lam(N))
xe = mesh_exp(rmin, rmax, 1._dp, N-1)  ! uniform mesh
U = spline3(data(:, 1), data(:, 2), xe)
!U = lagrange3interp(data(:, 1), data(:, 2), xe)
!U = hermite5interp(data(:, 1), data(:, 2), data(:, 3), .false., xe)
call savetxt("potential_grid.txt", reshape([xe, U], [size(xe), 2]))

print *, "solving"
lam = radial_schroedinger_fd(d, U, mu)
print *, "done"
print *
print *, "N =", N
print "('d =', f10.4)", d
print "('d =', f14.8)", d
print "('d =', f14.8)", xe(2) - xe(1)
print *, "Eigenvalues (n, E [a.u.], D [cm^-1]):"
do i = 1, 26
    E = lam(i)
    write(*,'(1x,i5,":",f18.8, f18.2)') i-1, E, (E0-E)*au
end do

contains

function radial_schroedinger_fd(d, U, mu) result(lam)
! Solves the radial Schroedinger equation with l=0 and potential 'U' given on a
! uniform mesh with element size 'd' using finite differences as described in
! [1]. Returns all eigenvalues in ascending order.
real(dp), intent(in) :: d  ! The element size of a uniform mesh
real(dp), intent(in) :: U(:) ! The potential given on a uniform mesh
real(dp), intent(in) :: mu ! The particle mass in Hartree atomic units (use
                           ! mu=1 for electrons)
real(dp) :: lam(size(U)) ! The eigenvalues
real(dp), allocatable :: work(:), c(:, :)
integer, allocatable :: iwork(:)
integer :: i, info, N
lam = 2*(1 + mu*d**2*U) ! Diagonal
N = size(U)
allocate(work(1 + 4*N), iwork(3 + 5*N))
call dstevd("N", N, lam, [(-1._dp, i=1,N-1)], c, N, work, size(work), iwork, &
    size(iwork), info) ! "N"="Compute eigenvalues only" -> "c" is not referenced
if (info /= 0) then
    print *, "INFO =", info
    call stop_error("info /= 0")
end if
lam = lam / (2*mu*d**2)
end function

end program