*> \brief \b SGET31
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGET31( RMAX, LMAX, NINFO, KNT )
*
*       .. Scalar Arguments ..
*       INTEGER            KNT, LMAX
*       REAL               RMAX
*       ..
*       .. Array Arguments ..
*       INTEGER            NINFO( 2 )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGET31 tests SLALN2, a routine for solving
*>
*>    (ca A - w D)X = sB
*>
*> where A is an NA by NA matrix (NA=1 or 2 only), w is a real (NW=1) or
*> complex (NW=2) constant, ca is a real constant, D is an NA by NA real
*> diagonal matrix, and B is an NA by NW matrix (when NW=2 the second
*> column of B contains the imaginary part of the solution).  The code
*> returns X and s, where s is a scale factor, less than or equal to 1,
*> which is chosen to avoid overflow in X.
*>
*> If any singular values of ca A-w D are less than another input
*> parameter SMIN, they are perturbed up to SMIN.
*>
*> The test condition is that the scaled residual
*>
*>     norm( (ca A-w D)*X - s*B ) /
*>           ( max( ulp*norm(ca A-w D), SMIN )*norm(X) )
*>
*> should be on the order of 1.  Here, ulp is the machine precision.
*> Also, it is verified that SCALE is less than or equal to 1, and that
*> XNORM = infinity-norm(X).
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[out] RMAX
*> \verbatim
*>          RMAX is REAL
*>          Value of the largest test ratio.
*> \endverbatim
*>
*> \param[out] LMAX
*> \verbatim
*>          LMAX is INTEGER
*>          Example number where largest test ratio achieved.
*> \endverbatim
*>
*> \param[out] NINFO
*> \verbatim
*>          NINFO is INTEGER array, dimension (3)
*>          NINFO(1) = number of examples with INFO less than 0
*>          NINFO(2) = number of examples with INFO greater than 0
*> \endverbatim
*>
*> \param[out] KNT
*> \verbatim
*>          KNT is INTEGER
*>          Total number of examples tested.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup single_eig
*
*  =====================================================================
      SUBROUTINE SGET31( RMAX, LMAX, NINFO, KNT )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            KNT, LMAX
      REAL               RMAX
*     ..
*     .. Array Arguments ..
      INTEGER            NINFO( 2 )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, HALF, ONE
      PARAMETER          ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0 )
      REAL               TWO, THREE, FOUR
      PARAMETER          ( TWO = 2.0E0, THREE = 3.0E0, FOUR = 4.0E0 )
      REAL               SEVEN, TEN
      PARAMETER          ( SEVEN = 7.0E0, TEN = 10.0E0 )
      REAL               TWNONE
      PARAMETER          ( TWNONE = 21.0E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            IA, IB, ICA, ID1, ID2, INFO, ISMIN, ITRANS,
     $                   IWI, IWR, NA, NW
      REAL               BIGNUM, CA, D1, D2, DEN, EPS, RES, SCALE, SMIN,
     $                   SMLNUM, TMP, UNFL, WI, WR, XNORM
*     ..
*     .. Local Arrays ..
      LOGICAL            LTRANS( 0: 1 )
      REAL               A( 2, 2 ), B( 2, 2 ), VAB( 3 ), VCA( 5 ),
     $                   VDD( 4 ), VSMIN( 4 ), VWI( 4 ), VWR( 4 ),
     $                   X( 2, 2 )
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLABAD, SLALN2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
*     ..
*     .. Data statements ..
      DATA               LTRANS / .FALSE., .TRUE. /
*     ..
*     .. Executable Statements ..
*
*     Get machine parameters
*
      EPS = SLAMCH( 'P' )
      UNFL = SLAMCH( 'U' )
      SMLNUM = SLAMCH( 'S' ) / EPS
      BIGNUM = ONE / SMLNUM
      CALL SLABAD( SMLNUM, BIGNUM )
*
*     Set up test case parameters
*
      VSMIN( 1 ) = SMLNUM
      VSMIN( 2 ) = EPS
      VSMIN( 3 ) = ONE / ( TEN*TEN )
      VSMIN( 4 ) = ONE / EPS
      VAB( 1 ) = SQRT( SMLNUM )
      VAB( 2 ) = ONE
      VAB( 3 ) = SQRT( BIGNUM )
      VWR( 1 ) = ZERO
      VWR( 2 ) = HALF
      VWR( 3 ) = TWO
      VWR( 4 ) = ONE
      VWI( 1 ) = SMLNUM
      VWI( 2 ) = EPS
      VWI( 3 ) = ONE
      VWI( 4 ) = TWO
      VDD( 1 ) = SQRT( SMLNUM )
      VDD( 2 ) = ONE
      VDD( 3 ) = TWO
      VDD( 4 ) = SQRT( BIGNUM )
      VCA( 1 ) = ZERO
      VCA( 2 ) = SQRT( SMLNUM )
      VCA( 3 ) = EPS
      VCA( 4 ) = HALF
      VCA( 5 ) = ONE
*
      KNT = 0
      NINFO( 1 ) = 0
      NINFO( 2 ) = 0
      LMAX = 0
      RMAX = ZERO
*
*     Begin test loop
*
      DO 190 ID1 = 1, 4
         D1 = VDD( ID1 )
         DO 180 ID2 = 1, 4
            D2 = VDD( ID2 )
            DO 170 ICA = 1, 5
               CA = VCA( ICA )
               DO 160 ITRANS = 0, 1
                  DO 150 ISMIN = 1, 4
                     SMIN = VSMIN( ISMIN )
*
                     NA = 1
                     NW = 1
                     DO 30 IA = 1, 3
                        A( 1, 1 ) = VAB( IA )
                        DO 20 IB = 1, 3
                           B( 1, 1 ) = VAB( IB )
                           DO 10 IWR = 1, 4
                              IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
     $                            ONE ) THEN
                                 WR = VWR( IWR )*A( 1, 1 )
                              ELSE
                                 WR = VWR( IWR )
                              END IF
                              WI = ZERO
                              CALL SLALN2( LTRANS( ITRANS ), NA, NW,
     $                                     SMIN, CA, A, 2, D1, D2, B, 2,
     $                                     WR, WI, X, 2, SCALE, XNORM,
     $                                     INFO )
                              IF( INFO.LT.0 )
     $                           NINFO( 1 ) = NINFO( 1 ) + 1
                              IF( INFO.GT.0 )
     $                           NINFO( 2 ) = NINFO( 2 ) + 1
                              RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
     $                              X( 1, 1 )-SCALE*B( 1, 1 ) )
                              IF( INFO.EQ.0 ) THEN
                                 DEN = MAX( EPS*( ABS( ( CA*A( 1,
     $                                 1 )-WR*D1 )*X( 1, 1 ) ) ),
     $                                 SMLNUM )
                              ELSE
                                 DEN = MAX( SMIN*ABS( X( 1, 1 ) ),
     $                                 SMLNUM )
                              END IF
                              RES = RES / DEN
                              IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
     $                            ABS( B( 1, 1 ) ).LE.SMLNUM*
     $                            ABS( CA*A( 1, 1 )-WR*D1 ) )RES = ZERO
                              IF( SCALE.GT.ONE )
     $                           RES = RES + ONE / EPS
                              RES = RES + ABS( XNORM-ABS( X( 1, 1 ) ) )
     $                               / MAX( SMLNUM, XNORM ) / EPS
                              IF( INFO.NE.0 .AND. INFO.NE.1 )
     $                           RES = RES + ONE / EPS
                              KNT = KNT + 1
                              IF( RES.GT.RMAX ) THEN
                                 LMAX = KNT
                                 RMAX = RES
                              END IF
   10                      CONTINUE
   20                   CONTINUE
   30                CONTINUE
*
                     NA = 1
                     NW = 2
                     DO 70 IA = 1, 3
                        A( 1, 1 ) = VAB( IA )
                        DO 60 IB = 1, 3
                           B( 1, 1 ) = VAB( IB )
                           B( 1, 2 ) = -HALF*VAB( IB )
                           DO 50 IWR = 1, 4
                              IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
     $                            ONE ) THEN
                                 WR = VWR( IWR )*A( 1, 1 )
                              ELSE
                                 WR = VWR( IWR )
                              END IF
                              DO 40 IWI = 1, 4
                                 IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND.
     $                               CA.EQ.ONE ) THEN
                                    WI = VWI( IWI )*A( 1, 1 )
                                 ELSE
                                    WI = VWI( IWI )
                                 END IF
                                 CALL SLALN2( LTRANS( ITRANS ), NA, NW,
     $                                        SMIN, CA, A, 2, D1, D2, B,
     $                                        2, WR, WI, X, 2, SCALE,
     $                                        XNORM, INFO )
                                 IF( INFO.LT.0 )
     $                              NINFO( 1 ) = NINFO( 1 ) + 1
                                 IF( INFO.GT.0 )
     $                              NINFO( 2 ) = NINFO( 2 ) + 1
                                 RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
     $                                 X( 1, 1 )+( WI*D1 )*X( 1, 2 )-
     $                                 SCALE*B( 1, 1 ) )
                                 RES = RES + ABS( ( -WI*D1 )*X( 1, 1 )+
     $                                 ( CA*A( 1, 1 )-WR*D1 )*X( 1, 2 )-
     $                                 SCALE*B( 1, 2 ) )
                                 IF( INFO.EQ.0 ) THEN
                                    DEN = MAX( EPS*( MAX( ABS( CA*A( 1,
     $                                    1 )-WR*D1 ), ABS( D1*WI ) )*
     $                                    ( ABS( X( 1, 1 ) )+ABS( X( 1,
     $                                    2 ) ) ) ), SMLNUM )
                                 ELSE
                                    DEN = MAX( SMIN*( ABS( X( 1,
     $                                    1 ) )+ABS( X( 1, 2 ) ) ),
     $                                    SMLNUM )
                                 END IF
                                 RES = RES / DEN
                                 IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
     $                               ABS( X( 1, 2 ) ).LT.UNFL .AND.
     $                               ABS( B( 1, 1 ) ).LE.SMLNUM*
     $                               ABS( CA*A( 1, 1 )-WR*D1 ) )
     $                               RES = ZERO
                                 IF( SCALE.GT.ONE )
     $                              RES = RES + ONE / EPS
                                 RES = RES + ABS( XNORM-
     $                                 ABS( X( 1, 1 ) )-
     $                                 ABS( X( 1, 2 ) ) ) /
     $                                 MAX( SMLNUM, XNORM ) / EPS
                                 IF( INFO.NE.0 .AND. INFO.NE.1 )
     $                              RES = RES + ONE / EPS
                                 KNT = KNT + 1
                                 IF( RES.GT.RMAX ) THEN
                                    LMAX = KNT
                                    RMAX = RES
                                 END IF
   40                         CONTINUE
   50                      CONTINUE
   60                   CONTINUE
   70                CONTINUE
*
                     NA = 2
                     NW = 1
                     DO 100 IA = 1, 3
                        A( 1, 1 ) = VAB( IA )
                        A( 1, 2 ) = -THREE*VAB( IA )
                        A( 2, 1 ) = -SEVEN*VAB( IA )
                        A( 2, 2 ) = TWNONE*VAB( IA )
                        DO 90 IB = 1, 3
                           B( 1, 1 ) = VAB( IB )
                           B( 2, 1 ) = -TWO*VAB( IB )
                           DO 80 IWR = 1, 4
                              IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
     $                            ONE ) THEN
                                 WR = VWR( IWR )*A( 1, 1 )
                              ELSE
                                 WR = VWR( IWR )
                              END IF
                              WI = ZERO
                              CALL SLALN2( LTRANS( ITRANS ), NA, NW,
     $                                     SMIN, CA, A, 2, D1, D2, B, 2,
     $                                     WR, WI, X, 2, SCALE, XNORM,
     $                                     INFO )
                              IF( INFO.LT.0 )
     $                           NINFO( 1 ) = NINFO( 1 ) + 1
                              IF( INFO.GT.0 )
     $                           NINFO( 2 ) = NINFO( 2 ) + 1
                              IF( ITRANS.EQ.1 ) THEN
                                 TMP = A( 1, 2 )
                                 A( 1, 2 ) = A( 2, 1 )
                                 A( 2, 1 ) = TMP
                              END IF
                              RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
     $                              X( 1, 1 )+( CA*A( 1, 2 ) )*
     $                              X( 2, 1 )-SCALE*B( 1, 1 ) )
                              RES = RES + ABS( ( CA*A( 2, 1 ) )*
     $                              X( 1, 1 )+( CA*A( 2, 2 )-WR*D2 )*
     $                              X( 2, 1 )-SCALE*B( 2, 1 ) )
                              IF( INFO.EQ.0 ) THEN
                                 DEN = MAX( EPS*( MAX( ABS( CA*A( 1,
     $                                 1 )-WR*D1 )+ABS( CA*A( 1, 2 ) ),
     $                                 ABS( CA*A( 2, 1 ) )+ABS( CA*A( 2,
     $                                 2 )-WR*D2 ) )*MAX( ABS( X( 1,
     $                                 1 ) ), ABS( X( 2, 1 ) ) ) ),
     $                                 SMLNUM )
                              ELSE
                                 DEN = MAX( EPS*( MAX( SMIN / EPS,
     $                                 MAX( ABS( CA*A( 1,
     $                                 1 )-WR*D1 )+ABS( CA*A( 1, 2 ) ),
     $                                 ABS( CA*A( 2, 1 ) )+ABS( CA*A( 2,
     $                                 2 )-WR*D2 ) ) )*MAX( ABS( X( 1,
     $                                 1 ) ), ABS( X( 2, 1 ) ) ) ),
     $                                 SMLNUM )
                              END IF
                              RES = RES / DEN
                              IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
     $                            ABS( X( 2, 1 ) ).LT.UNFL .AND.
     $                            ABS( B( 1, 1 ) )+ABS( B( 2, 1 ) ).LE.
     $                            SMLNUM*( ABS( CA*A( 1,
     $                            1 )-WR*D1 )+ABS( CA*A( 1,
     $                            2 ) )+ABS( CA*A( 2,
     $                            1 ) )+ABS( CA*A( 2, 2 )-WR*D2 ) ) )
     $                            RES = ZERO
                              IF( SCALE.GT.ONE )
     $                           RES = RES + ONE / EPS
                              RES = RES + ABS( XNORM-
     $                              MAX( ABS( X( 1, 1 ) ), ABS( X( 2,
     $                              1 ) ) ) ) / MAX( SMLNUM, XNORM ) /
     $                              EPS
                              IF( INFO.NE.0 .AND. INFO.NE.1 )
     $                           RES = RES + ONE / EPS
                              KNT = KNT + 1
                              IF( RES.GT.RMAX ) THEN
                                 LMAX = KNT
                                 RMAX = RES
                              END IF
   80                      CONTINUE
   90                   CONTINUE
  100                CONTINUE
*
                     NA = 2
                     NW = 2
                     DO 140 IA = 1, 3
                        A( 1, 1 ) = VAB( IA )*TWO
                        A( 1, 2 ) = -THREE*VAB( IA )
                        A( 2, 1 ) = -SEVEN*VAB( IA )
                        A( 2, 2 ) = TWNONE*VAB( IA )
                        DO 130 IB = 1, 3
                           B( 1, 1 ) = VAB( IB )
                           B( 2, 1 ) = -TWO*VAB( IB )
                           B( 1, 2 ) = FOUR*VAB( IB )
                           B( 2, 2 ) = -SEVEN*VAB( IB )
                           DO 120 IWR = 1, 4
                              IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
     $                            ONE ) THEN
                                 WR = VWR( IWR )*A( 1, 1 )
                              ELSE
                                 WR = VWR( IWR )
                              END IF
                              DO 110 IWI = 1, 4
                                 IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND.
     $                               CA.EQ.ONE ) THEN
                                    WI = VWI( IWI )*A( 1, 1 )
                                 ELSE
                                    WI = VWI( IWI )
                                 END IF
                                 CALL SLALN2( LTRANS( ITRANS ), NA, NW,
     $                                        SMIN, CA, A, 2, D1, D2, B,
     $                                        2, WR, WI, X, 2, SCALE,
     $                                        XNORM, INFO )
                                 IF( INFO.LT.0 )
     $                              NINFO( 1 ) = NINFO( 1 ) + 1
                                 IF( INFO.GT.0 )
     $                              NINFO( 2 ) = NINFO( 2 ) + 1
                                 IF( ITRANS.EQ.1 ) THEN
                                    TMP = A( 1, 2 )
                                    A( 1, 2 ) = A( 2, 1 )
                                    A( 2, 1 ) = TMP
                                 END IF
                                 RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
     $                                 X( 1, 1 )+( CA*A( 1, 2 ) )*
     $                                 X( 2, 1 )+( WI*D1 )*X( 1, 2 )-
     $                                 SCALE*B( 1, 1 ) )
                                 RES = RES + ABS( ( CA*A( 1,
     $                                 1 )-WR*D1 )*X( 1, 2 )+
     $                                 ( CA*A( 1, 2 ) )*X( 2, 2 )-
     $                                 ( WI*D1 )*X( 1, 1 )-SCALE*
     $                                 B( 1, 2 ) )
                                 RES = RES + ABS( ( CA*A( 2, 1 ) )*
     $                                 X( 1, 1 )+( CA*A( 2, 2 )-WR*D2 )*
     $                                 X( 2, 1 )+( WI*D2 )*X( 2, 2 )-
     $                                 SCALE*B( 2, 1 ) )
                                 RES = RES + ABS( ( CA*A( 2, 1 ) )*
     $                                 X( 1, 2 )+( CA*A( 2, 2 )-WR*D2 )*
     $                                 X( 2, 2 )-( WI*D2 )*X( 2, 1 )-
     $                                 SCALE*B( 2, 2 ) )
                                 IF( INFO.EQ.0 ) THEN
                                    DEN = MAX( EPS*( MAX( ABS( CA*A( 1,
     $                                    1 )-WR*D1 )+ABS( CA*A( 1,
     $                                    2 ) )+ABS( WI*D1 ),
     $                                    ABS( CA*A( 2,
     $                                    1 ) )+ABS( CA*A( 2,
     $                                    2 )-WR*D2 )+ABS( WI*D2 ) )*
     $                                    MAX( ABS( X( 1,
     $                                    1 ) )+ABS( X( 2, 1 ) ),
     $                                    ABS( X( 1, 2 ) )+ABS( X( 2,
     $                                    2 ) ) ) ), SMLNUM )
                                 ELSE
                                    DEN = MAX( EPS*( MAX( SMIN / EPS,
     $                                    MAX( ABS( CA*A( 1,
     $                                    1 )-WR*D1 )+ABS( CA*A( 1,
     $                                    2 ) )+ABS( WI*D1 ),
     $                                    ABS( CA*A( 2,
     $                                    1 ) )+ABS( CA*A( 2,
     $                                    2 )-WR*D2 )+ABS( WI*D2 ) ) )*
     $                                    MAX( ABS( X( 1,
     $                                    1 ) )+ABS( X( 2, 1 ) ),
     $                                    ABS( X( 1, 2 ) )+ABS( X( 2,
     $                                    2 ) ) ) ), SMLNUM )
                                 END IF
                                 RES = RES / DEN
                                 IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
     $                               ABS( X( 2, 1 ) ).LT.UNFL .AND.
     $                               ABS( X( 1, 2 ) ).LT.UNFL .AND.
     $                               ABS( X( 2, 2 ) ).LT.UNFL .AND.
     $                               ABS( B( 1, 1 ) )+
     $                               ABS( B( 2, 1 ) ).LE.SMLNUM*
     $                               ( ABS( CA*A( 1, 1 )-WR*D1 )+
     $                               ABS( CA*A( 1, 2 ) )+ABS( CA*A( 2,
     $                               1 ) )+ABS( CA*A( 2,
     $                               2 )-WR*D2 )+ABS( WI*D2 )+ABS( WI*
     $                               D1 ) ) )RES = ZERO
                                 IF( SCALE.GT.ONE )
     $                              RES = RES + ONE / EPS
                                 RES = RES + ABS( XNORM-
     $                                 MAX( ABS( X( 1, 1 ) )+ABS( X( 1,
     $                                 2 ) ), ABS( X( 2,
     $                                 1 ) )+ABS( X( 2, 2 ) ) ) ) /
     $                                 MAX( SMLNUM, XNORM ) / EPS
                                 IF( INFO.NE.0 .AND. INFO.NE.1 )
     $                              RES = RES + ONE / EPS
                                 KNT = KNT + 1
                                 IF( RES.GT.RMAX ) THEN
                                    LMAX = KNT
                                    RMAX = RES
                                 END IF
  110                         CONTINUE
  120                      CONTINUE
  130                   CONTINUE
  140                CONTINUE
  150             CONTINUE
  160          CONTINUE
  170       CONTINUE
  180    CONTINUE
  190 CONTINUE
*
      RETURN
*
*     End of SGET31
*
      END


** Copyright (c) 1989, NVIDIA CORPORATION.  All rights reserved.
**
** Licensed under the Apache License, Version 2.0 (the "License");
** you may not use this file except in compliance with the License.
** You may obtain a copy of the License at
**
**     http://www.apache.org/licenses/LICENSE-2.0
**
** Unless required by applicable law or agreed to in writing, software
** distributed under the License is distributed on an "AS IS" BASIS,
** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
** See the License for the specific language governing permissions and
** limitations under the License.

*   Exponentiation operator (**) - exponentiation of integer,
*   real, d.p., or complex values to an integer power,
*   including constant folding.

	implicit double precision (d), complex(c)
	parameter(n = 34)
	integer rslts(n), expect(n), iexpect(12)
	real rrslts(13:18), rexpect(13:18)
	double precision drslts(4), dexpect(4)
	complex crslts(4), cexpect(4)

	equivalence (expect, iexpect), (expect(13), rexpect),
     +              (expect(19), dexpect), (expect(27), cexpect)
	equivalence (rslts(13), rrslts(13)), (rslts(19), drslts),
     +              (rslts(27), crslts)

	parameter(ip1 = 138 ** 1, ip2 = -4 ** 2, ip3 = 5**0,
     +            ip4 = -5**3, ip5 = 1 ** 20, ip6 = 1**(-3),
     +            ip7 = 2 ** (-1), ip8=5**(-2), ip9=2**3**2  )

	parameter(xp1 = 2.0 ** 2, xp2 = 4.0 ** (-1), xp3 = -3.0 ** 3,
     +            xp4 = 2.3 ** 1, xp5 = 2.0 ** (-2) )

	parameter(dp1 = 2.0D0 ** 3, dp2 = 2.3d45**0, dp3=(-2.0d0)**(-2))

	parameter(cp1 = (2.0, 0.0) ** 3, cp2 = (2.3, 2.3) ** 1,
     +            cp3 = (2.3, 2.3) ** 0, cp4 = (1.0, 1.0) ** 2  )

c ----------- tests 1 - 12:    integer ** integer

	data iexpect / ip1, ip2, ip2, ip3, ip4, ip5,
     +                 ip6, ip7, ip8, ip9, ip9, 125  /

	data i138, i4, i2, i3, i5, i20, in3, i1, in2, in1 /
     +        138,  4,  2,  3,  5,  20,  -3,  1,  -2, -1  /

	rslts(1) = i138 ** i1
	rslts(2) = - (i4 ** i2)
	rslts(3) = - i4 ** i2
	rslts(4) = i5 ** (i2 / i3)
	rslts(5) = - i5 ** (i2 + i1)
	rslts(6) = i1 ** i20
	rslts(7) = i1 ** (in3)
	rslts(8) = (i1 * i2) ** (-i1)
	rslts(9) = 5 ** (in2)
	rslts(10) = (-in2) ** if(3) ** 2
	rslts(11) = i2 ** (i3 ** i2)
	rslts(12) = if(5) ** 3

c ------------ tests 13 - 18:   real ** integer

	data rexpect / xp1, xp2, xp3, xp4, xp5, 9.0 /

	data x3, x23, x2 / 3.0, 2.3, 2.0 /

	rrslts(13) = 4.0
	rrslts(14) = 4.0 ** in1
	rrslts(15) = -x3**3
	rrslts(16) = x23 ** (i2 - 1)
	rrslts(17) = x2 ** (- i2)
	rrslts(18) = xf( -x3 ) ** 2

c ------------- tests 19 - 26:   double ** integer

	data dexpect / dp1, dp2, dp3, 4.0D0  /

	data d2 / 2.0d0 /

	drslts(1) = d2 ** i3
	drslts(2) = 2.3D45 ** (i2 - i1 - i1)
	drslts(3) = (-d2) ** (-i2)
	drslts(4) = d2 ** 2

c -------------- tests 27 - 34:  complex ** integer

	data cexpect / cp1, cp2, cp3, cp4 /

	data         c2,        c23,       cn1_1  /
     +       (2.0, 0.0), (2.3, 2.3), (-1.0, 1.0)  /

        crslts(1) = c2 ** i3
        crslts(2) = (2.3, 2.3) ** (i2 - i1)
        crslts(3) = c23 ** 0
        crslts(4) = (c2 + cn1_1) ** 2

c --------------- check results:

	call check(rslts, expect, n)
	end

	integer function if(i)
	common /comif/ ii
	data ii /0/
	if (ii .gt. 1)  stop "'if' called too often"
        ii = ii + 1
	if =  i
	end

	real function xf(x)
	common /comxf/ ii
	data ii /0/
	if (ii .gt. 1)  stop "'xf' called too often"
        ii = ii + 1
	xf = x
	end


      PROGRAM xfred2
C     driver for routine fred2
      INTEGER N
      REAL PI
      PARAMETER(N=8,PI=3.1415927)
      INTEGER i
      REAL a,ak,b,g,t(N),f(N),w(N)
      EXTERNAL g,ak
      a=0.
      b=PI/2.
      call fred2(N,a,b,t,f,w,g,ak)
C     compare with exact solution
      write(*,*) 'Abscissa, Calc soln, True soln'
      do 11 i=1,N
        write(*,100) t(i),f(i),sqrt(t(i))
11    continue
100   format(3f10.6)
      END
      REAL FUNCTION g(t)
      REAL PI
      PARAMETER(PI=3.1415927)
      REAL t
      g=sqrt(t)-(PI/2.)**2.25*t**.75/2.25
      return
      END
      REAL FUNCTION ak(t,s)
      REAL t,s
      ak=(t*s)**.75
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xfred2.for


      subroutine tleapy(yy,qleapy)
c
c     This subroutine determines if the year yy is a leap year. The
c     logical flag qleapy is returned as true if this is the case.
c     Modern era rules apply:
c
c       1. Any year not evenly divisible by 4 is not a leap year.
c       2. If a year is evenly divisible by 100 (i.e., is a "century
c          year"), it is not a leap year, unless it is also evenly
c          divisible by 400.
c
c     Examples:
c
c        1. The year 1998 is not a leap year because it is not evenly
c           divisible by 4.
c        2. Century years like 1700, 1800, and 1900 are not leap years
c           because they are not evenly divisible by 400.
c        3. Century years like 1600 and 2000 are leap years because
c           they are evenly divisible by 400.
c
c     The modern era rules (part of the Gregorian calendar) first
c     applied in 1582. The first leap year of the Gregorian calendar
c     was therefore 1584. This subroutine will not return any prior
c     year as a leap year. Thus, 1580 is not a leap year.
c
c     This subroutine is called by:
c
c       EQLIB/initim.f
c       EQLIB/runtim.f
c
c-----------------------------------------------------------------------
c
c     Input:
c
c       yy     = year, assumed to be an integer up to four digits
c
c     Output:
c
c       qleapy = logical flag, true if yy is a leap year.
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer yy
c
      logical qleapy
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
c     None
c
c-----------------------------------------------------------------------
c
      qleapy = .false.
c
      if (yy .ge. 1584) then
c
c       Have a year sufficiently recent to possibly be a leap year.
c
        if (mod(yy,4) .eq. 0) then
c
c         Have a year evenly divisible by 4. It might be a leap year.
c
          if (mod(yy,100) .eq. 0) then
c
c           Have a century year. It might be a leap year.
c
            if (mod(yy,400) .eq. 0) then
c
c             Have a century year that is evenly divisible by 400.
c             This is a leap year.
c
              qleapy = .true.
            endif
          else
c
c           Have a year evenly divisible by 4, but it is not a
c           century year. This is a leap year.
c
            qleapy = .true.
          endif
        endif
      endif
c
      end


!     This software is Copyright (c) 2012-2015 The Regents of the
!     University of California. All Rights Reserved.
!
!     Permission to copy and modify this software and its documentation
!     for educational, research and non-profit purposes, without fee,
!     and without a written agreement is hereby granted, provided that
!     the above copyright notice, this paragraph and the following three
!     paragraphs appear in all copies.
!
!     Permission to make commercial use of this software may be obtained
!     by contacting:
!
!     Technology Transfer Office
!     9500 Gilman Drive, Mail Code 0910
!     University of California
!     La Jolla, CA 92093-0910
!     (858) 534-5815
!     invent@ucsd.edu
!
!     This software program and documentation are copyrighted by The
!     Regents of the University of California. The software program and
!     documentation are supplied "as is", without any accompanying
!     services from The Regents. The Regents does not warrant that the
!     operation of the program will be uninterrupted or error-free. The
!     end-user understands that the program was developed for research
!     purposes and is advised not to rely exclusively on the program for
!     any reason.
!
!     IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY
!     PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL
!     DAMAGES, INCLUDING LOST PROFITS, ARISING OUT OF THE USE OF THIS
!     SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
!     CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!     THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY
!     WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
!     OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
!     SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND THE
!     UNIVERSITY OF CALIFORNIA HAS NO OBLIGATIONS TO PROVIDE
!     MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.

      SUBROUTINE GE (N, A, B)

      IMPLICIT NONE

      INTEGER, INTENT(IN) :: N
      REAL*8, INTENT(IN) :: A(N,N)
      REAL*8, INTENT(INOUT) :: B(N)

      INTEGER m, ipv, i, j
      REAL*8 pivot, saveEl
      REAL*8, ALLOCATABLE :: C(:,:)

      IF (N .EQ. 2) THEN
         pivot  = A(1,1)*A(2,2) - A(2,1)*A(1,2)
         saveEl = (B(1)*A(2,2) - B(2)*A(1,2))/pivot
         B(2)   = (B(2)*A(1,1) - B(1)*A(2,1))/pivot
         B(1)   = saveEl
         RETURN
      END IF
      ALLOCATE(C(N,N+1))

      C(:N,:N) = A
      C(:,N+1) = B

      DO m=1,N-1
         ipv = m
         pivot = ABS(C(m,m))
         DO i=m+1,N
            IF (ABS(C(i,m)) .GT. pivot) THEN
               ipv = i
               pivot = ABS(C(i,m))
            END IF
         END DO
         IF (pivot .LT. 2D0*EPSILON(pivot)) THEN
            PRINT *, 'Singular matrix'
            STOP
         END IF
         IF (ipv .NE. m) THEN
            DO j=m, N+1
               saveEl = C(m,j)
               C(m,j) = C(ipv,j)
               C(ipv,j) = saveEl
            END DO
            DO j=1, m-1
            END DO
         END IF

         DO i=m+1,N
            saveEl = C(i,m)/C(m,m)
            C(i,m) = 0D0
            DO j=m+1,N+1
               C(i,j) = C(i,j) - saveEl*C(m,j)
            END DO
         END DO
      END DO

      DO j=N,1,-1
         DO i=j+1,N
            C(j,N+1) = C(j,N+1) - C(j,i)*C(i,N+1)
         END DO
         C(j,N+1) = C(j,N+1)/C(j,j)
      END DO

      B = C(:,N+1)

      DEALLOCATE(C)

      RETURN
      END SUBROUTINE GE


      PROGRAM LA_SPBSV_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_PBSV
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Parameters" ..
      REAL(WP), PARAMETER :: ZERO = 0.0_WP, ONE = 1.0_WP
!  .. "Local Scalars" ..
      INTEGER :: KD, I, J, INFO, N, NRHS
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: AB(:,:), B(:,:)
      REAL(WP), ALLOCATABLE :: AA(:,:), BB(:,:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'SPBSV Example Program Results.'
      N = 7; KD = 3; NRHS = 3
      WRITE(*,'(5H N = , I4, 9H; NRHS = , I4)') N, NRHS
      ALLOCATE ( AB(KD+1,N), AA(KD+1,N), B(N,NRHS), BB(N,NRHS) )

      OPEN(UNIT=21,FILE='pbsv.ma',STATUS='UNKNOWN')
      DO I=1,KD+1
         DO J=1,N
         READ(21,'(F3.0)') AB(I,J);
         ENDDO
      ENDDO
      CLOSE(21)

      B(:,1) = ZERO
      DO I = 1, N
         DO J = MAX(1,-N+I+KD+1), KD
         B(I,1) = AB(J,I-J+KD+1) + B(I,1)
         ENDDO
         DO J = MAX(1,KD+2-I), KD+1
         B(I,1) = AB(J,I) + B(I,1)
         ENDDO
      ENDDO

      DO J = 2, NRHS; B(:,J) = B(:,1)*J; ENDDO
      AA = AB; BB = B

      WRITE(*,*) 'AB on entry:'
      DO I = 1,KD+1;
         WRITE (*,'(7(F8.5))') AB(I,:);
      ENDDO

      WRITE(*,*) 'The RHS matrix B:'
      DO J = 1, N; WRITE (*,*) B(J,:);
      ENDDO

      CALL LA_PBSV(AB, B, INFO=INFO)

      WRITE(*,*)'AB on exit :'
      DO I=1,KD+1; WRITE(*,"(10(E12.6))") AB(I,:);
      ENDDO

      WRITE(*,*)'B on exit :'
      DO J=1,N; WRITE(*,"(10(F8.5))") B(J,:);
      ENDDO

      WRITE(*,*)'INFO = ' ,INFO

      END PROGRAM LA_SPBSV_EXAMPLE


cc Copyright (C) 2009: Zydrunas Gimbutas and Hong Xiao
cc Contact: Zydrunas Gimbutas <gimbutas@cims.nyu.edu>
cc          Hong Xiao <hxiao@ucdavis.edu>
cc
cc This software is being released under a modified FreeBSD license
cc (see COPYING in home directory).
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c       Orthogonal polynomials on the standard cube [-1,1]^3
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c       This file contains a set of subroutines for the handling
c       of the evaluation of othogonal polynomials on the standard
c       cube.  It contains 2 user-callable subroutines.
c
c   lege3eva - evaluates at the user-supplied point z
c       a collection of polynomials (of x,y,z) orthogonal on the
c       standard cube
c
c   lege3eva3 - evaluates at the user-supplied point z a collection
c       of polynomials (of x,y,z) orthogonal on the standard cube,
c       together with their derivatives with respect to x, y and z.

c
c
      subroutine lege3eva(mmax,z,pols,w)
c
c     This subroutine evaluates at the user-supplied point z
c     a collection of polynomials (of x,y,z) orthogonal on the
c     standard cube
c
c                   Input parameters:
c
c  mmax - the maximum order to which the polynomials are to be evaluated;
c  z - the location in R^3 where the polynomials are to be evaluated;
c
c  w - the work array. must be at least 3*(mmax+10) long
c
c                   Output parameters:
c
c  pols - the orthogonal polynomials evaluated at the point z
c       ( (mmax+1)*(mmax+2)*(mmax+3)/6 of them things)
c
c       . . . allocate memory for the work arrays
c
      implicit real *8 (a-h,o-z)
      dimension z(2), pols(1), w(1)
      iw1=1
      iw2=iw1+mmax+10
      iw3=iw2+mmax+10
      iw4=iw3+mmax+10
      call lege3eva0(mmax,z,pols,w(iw1),w(iw2),w(iw3))
      return
      end
c
c
c
c
c
      subroutine lege3eva0(mmax,z,pols,f1,f2,f3)
c
c     evaluate the orthonormal polynomials on the cube
c
      implicit real *8 (a-h,o-z)
      dimension z(3),pols(1),f1(1),f2(1),f3(1)
ccc      data init/1/
ccc      save
c
c
      call llegepols1(z(1),mmax,f1)
      call llegepols1(z(2),mmax,f2)
      call llegepols1(z(3),mmax,f3)
c
c
      kk=0
      do 2400 m=0,mmax
         do 2200 n2=0,m
         do 2000 n1=0,n2
         kk=kk+1
c
c     ... evaluate the polynomial (m-n2, n2-n1, n1)
c
         pols(kk)=f1(m-n2+1)*f2(n2-n1+1)*f3(n1+1)
c
c     ... and normalize it
c
         scale=1
         scale=scale*dsqrt((1.0d0+n1+n1)/2)
         scale=scale*dsqrt((1.0d0+n2-n1+n2-n1)/2)
         scale=scale*dsqrt((1.0d0+m-n2+m-n2)/2)
         pols(kk)=pols(kk)*scale
 2000	 continue
 2200 continue
 2400 continue
      return
      end
c
c
c
c
c
      subroutine lege3eva3(mmax,z,pols,dersx,dersy,dersz,w)
c
c     This subroutine evaluates at the user-supplied point z
c     a collection of polynomials (of x,y,z) orthogonal on the
c     standard cube, together with their derivatives with
c     respect to x, y and z.
c
c                   Input parameters:
c
c  mmax - the maximum order to which the polynomials are to be evaluated;
c  z - the location in R^3 where the polynomials are to be evaluated;
c
c  w - the work array. must be at least 6*(mmax+10) long
c
c                   Output parameters:
c
c  pols - the orthogonal polynomials evaluated at the point z
c       ( (mmax+1)*(mmax+2)*(mmax+3)/6 of them things)
c  dersx - the derivatives with respect to x of the polynomials
c       returned in array pols
c  dersy - the derivatives with respect to y of the polynomials
c       returned in array pols
c  dersz - the derivatives with respect to z of the polynomials
c       returned in array pols
c
c
c       . . . allocate memory for the work arrays
c
      implicit real *8 (a-h,o-z)
      dimension z(2), pols(1), w(1)
      iw1=1
      iw2=iw1+mmax+10
      iw3=iw2+mmax+10
      iw4=iw3+mmax+10
      iw5=iw4+mmax+10
      iw6=iw5+mmax+10
      iw7=iw6+mmax+10
      call lege3eva30(mmax,z,pols,dersx,dersy,dersz,
     $     w(iw1),w(iw2),w(iw3),w(iw4),w(iw5),w(iw6))
      return
      end
c
c
c
c
c
      subroutine lege3eva30(mmax,z,pols,dersx,dersy,dersz,
     $     f1,f2,f3,f4,f5,f6)
c
c     evaluate the orthonormal polynomials on the cube,
c     together with their derivatives with respect to x, y and z.
c
      implicit real *8 (a-h,o-z)
      dimension z(3), pols(1), dersx(1), dersy(1), dersz(1)
      dimension f1(1), f2(1)
      dimension f3(1), f4(1)
      dimension f5(1), f6(1)
ccc      data init/1/
ccc      save
c
c
c
      call llegepols2(z(1),mmax,f1,f4)
      call llegepols2(z(2),mmax,f2,f5)
      call llegepols2(z(3),mmax,f3,f6)
c

      kk=0
      do 2400 m=0,mmax
         do 2200 n2=0,m
         do 2000 n1=0,n2
         kk=kk+1
c
c     ... evaluate the polynomial (m-n2, n2-n1, n1)
c
         pols(kk)=f1(m-n2+1)*f2(n2-n1+1)*f3(n1+1)
c
c     ... and the derivatives with respect in x and y
c
         dersx(kk)=f4(m-n2+1)*f2(n2-n1+1)*f3(n1+1)
         dersy(kk)=f1(m-n2+1)*f5(n2-n1+1)*f3(n1+1)
         dersz(kk)=f1(m-n2+1)*f2(n2-n1+1)*f6(n1+1)
c
c     ... and normalize it
c
         scale=1
         scale=scale*dsqrt((1.0d0+n1+n1)/2)
         scale=scale*dsqrt((1.0d0+n2-n1+n2-n1)/2)
         scale=scale*dsqrt((1.0d0+m-n2+m-n2)/2)
         pols(kk)=pols(kk)*scale
         dersx(kk)=dersx(kk)*scale
         dersy(kk)=dersy(kk)*scale
         dersz(kk)=dersz(kk)*scale
 2000	 continue
 2200 continue
 2400 continue

c
      return
      end
c
c
c
c
c
c
c
        subroutine llegepols1(x,n,pols)
        implicit real *8 (a-h,o-z)
        dimension pols(1)
c
c       evaluates a bunch of Legendre polynomials
c       at the user-provided point x
c
c       ... if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
        pols(1)=1
        if(n .eq. 0) return
c
        pols(2)=x
        return
 1200 continue
c
c       n is greater than 1. conduct recursion
c
        pols(1)=1
        pols(2)=x
c
        pkm1=1
        pk=x
c
        pk=1
        pkp1=x
c
        do 2000 k=1,n-1
c
        pkm1=pk
        pk=pkp1
c
        pkp1=( (2*k+1)*x*pk-k*pkm1 )/(k+1)
        pols(k+2)=pkp1
 2000 continue
c
        return
        end
c
c
c
c
c
        subroutine llegepols2(x,n,pols,ders)
        implicit real *8 (a-h,o-z)
        dimension pols(1),ders(1)
c
c       evaluates a bunch of Legendre polynomials (together
c       with their derivatives) at the user-provided point x
c
c       ... if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
        pols(1)=1
        ders(1)=0
        if(n .eq. 0) return
c
        pols(2)=x
        ders(2)=1
        return
 1200 continue
c
c       n is greater than 1. conduct recursion
c
        pols(1)=1
        ders(1)=0
        pols(2)=x
        ders(2)=1
c
        pkm1=1
        pk=x
        dkm1=0
        dk=1
c
        pk=1
        pkp1=x
        dk=0
        dkp1=1
c
        do 2000 k=1,n-1
c
        pkm1=pk
        pk=pkp1
        dkm1=dk
        dk=dkp1
c
        pkp1=( (2*k+1)*x*pk-k*pkm1 )/(k+1)
        dkp1=( (2*k+1)*(x*dk+pk)-k*dkm1 )/(k+1)
        pols(k+2)=pkp1
        ders(k+2)=dkp1
 2000 continue
c
        return
        end

c
        subroutine lege3gauc(n,vert1,vert2,rnodes,
     1      weights,ifinit,w)
        implicit real *8 (a-h,o-z)
        dimension w(1),vert1(1),vert2(1),
     1       rnodes(1),weights(1)
c
c
c       this subroutine constructs a tensor product Gaussian
c       quadrature formula on the cube in the space
c       specified by its vertices.
c

        iw1=1
        iw2=iw1+n+1
        iw3=iw2+n+1
        iw4=iw3+n+1
        iw5=iw4+n+1
        iw5=iw5+n+1
        iw6=iw6+n+1

        call lege3gauc0(n,vert1,vert2,rnodes,
     1      weights,ifinit,w(iw1),w(iw2),w(iw3),w(iw4),w(iw5),w(iw6))

        return
        end

        subroutine lege3gauc0(n,vert1,vert2,rnodes,
     1      weights,ifinit,tsx,wsx,tsy,wsy,tsz,wsz)
        implicit real *8 (a-h,o-z)
        dimension vert1(3),vert2(3)
        dimension rnodes(3,n,n,n),weights(n,n,n)
        dimension tsx(n),wsx(n),tsy(n),wsy(n),tsz(n),wsz(n)
c
c
c       this subroutine constructs a tensor product Gaussian
c       quadrature formula on the square in the plane
c       specified by its vertices.
c

        if( ifinit.eq.1) then
           ifinit = 1
           call legewhts(n,tsx,wsx,ifinit)
           call legewhts(n,tsy,wsy,ifinit)
           call legewhts(n,tsz,wsz,ifinit)
        endif

        u1=(vert2(1)-vert1(1))/2
        v1=(vert2(1)+vert1(1))/2
        u2=(vert2(2)-vert1(2))/2
        v2=(vert2(2)+vert1(2))/2
        u3=(vert2(3)-vert1(3))/2
        v3=(vert2(3)+vert1(3))/2

ccc        call prin2('vert1=*',vert1,2)
ccc        call prin2('vert2=*',vert2,2)

        do i=1,n
        do j=1,n
        do k=1,n
           rnodes(1,i,j,k)=u1*tsx(i)+v1
           rnodes(2,i,j,k)=u2*tsy(j)+v2
           rnodes(3,i,j,k)=u3*tsz(k)+v3
           weights(i,j,k)=abs(u1)*abs(u2)*abs(u3)*wsx(i)*wsy(j)*wsz(k)
        enddo
        enddo
        enddo

        return
        end


      subroutine r8mkherm2(fun,x,nx,y,ny,fherm)
C
C  create a data set for Hermite interpolation, from evaluation of
C  function and derivatives.  function of 2 indep. coordinates.
C
C  input:
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER ny,nx,ix,iy
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 fun,dfdx,dfdy,d2fdxdy
!============
      external fun                      ! passed real function(x,y)
      REAL*8 x(nx)                        ! x coordinate array
      REAL*8 y(ny)                        ! y coordinate array
C
C  the passed function fun must have the interface:
C
C        real function <name>(x,y,dfdx,dfdy,d2fdxdy)
C  where x,y are input, the function returns the function value,
C  and the arguments dfdx and dfdy return as output the function
C  derivative at the point (x,y).
C
C  output:
C
      REAL*8 fherm(0:3,nx,ny)             ! function data & derivatives
C
C  fherm(0,i,j) = function value f at x(i),y(j)
C  fherm(1,i,j) = derivative df/dx at x(i),y(j)
C  fherm(2,i,j) = derivative df/dy at x(i),y(j)
C  fherm(3,i,j) = derivative d2f/dxdy at x(i),y(j)
C
C----------------------------
C
      do ix=1,nx
         do iy=1,ny
            fherm(0,ix,iy)=fun(x(ix),y(iy),dfdx,dfdy,d2fdxdy)
            fherm(1,ix,iy)=dfdx
            fherm(2,ix,iy)=dfdy
            fherm(3,ix,iy)=d2fdxdy
         enddo
      enddo
C
      return
      end


      SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
*
*  -- LAPACK routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGETRI computes the inverse of a matrix using the LU factorization
*  computed by DGETRF.
*
*  This method inverts U and then computes inv(A) by solving the system
*  inv(A)*L = inv(U) for inv(A).
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the factors L and U from the factorization
*          A = P*L*U as computed by DGETRF.
*          On exit, if INFO = 0, the inverse of the original matrix A.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  IPIV    (input) INTEGER array, dimension (N)
*          The pivot indices from DGETRF; for 1<=i<=N, row i of the
*          matrix was interchanged with row IPIV(i).
*
*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*          On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.  LWORK >= max(1,N).
*          For optimal performance LWORK >= N*NB, where NB is
*          the optimal blocksize returned by ILAENV.
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, U(i,i) is exactly zero; the matrix is
*                singular and its inverse could not be computed.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
     $                   NBMIN, NN
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 )
      LWKOPT = N*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -3
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRI', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Form inv(U).  If INFO > 0 from DTRTRI, then U is singular,
*     and the inverse is not computed.
*
      CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
      IF( INFO.GT.0 )
     $   RETURN
*
      NBMIN = 2
      LDWORK = N
      IF( NB.GT.1 .AND. NB.LT.N ) THEN
         IWS = MAX( LDWORK*NB, 1 )
         IF( LWORK.LT.IWS ) THEN
            NB = LWORK / LDWORK
            NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) )
         END IF
      ELSE
         IWS = N
      END IF
*
*     Solve the equation inv(A)*L = inv(U) for inv(A).
*
      IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
*
*        Use unblocked code.
*
         DO 20 J = N, 1, -1
*
*           Copy current column of L to WORK and replace with zeros.
*
            DO 10 I = J + 1, N
               WORK( I ) = A( I, J )
               A( I, J ) = ZERO
   10       CONTINUE
*
*           Compute current column of inv(A).
*
            IF( J.LT.N )
     $         CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
     $                     LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
   20    CONTINUE
      ELSE
*
*        Use blocked code.
*
         NN = ( ( N-1 ) / NB )*NB + 1
         DO 50 J = NN, 1, -NB
            JB = MIN( NB, N-J+1 )
*
*           Copy current block column of L to WORK and replace with
*           zeros.
*
            DO 40 JJ = J, J + JB - 1
               DO 30 I = JJ + 1, N
                  WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
                  A( I, JJ ) = ZERO
   30          CONTINUE
   40       CONTINUE
*
*           Compute current block column of inv(A).
*
            IF( J+JB.LE.N )
     $         CALL DGEMM( 'No transpose', 'No transpose', N, JB,
     $                     N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
     $                     WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
            CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
     $                  ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
   50    CONTINUE
      END IF
*
*     Apply column interchanges.
*
      DO 60 J = N - 1, 1, -1
         JP = IPIV( J )
         IF( JP.NE.J )
     $      CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
   60 CONTINUE
*
      WORK( 1 ) = IWS
      RETURN
*
*     End of DGETRI
*
      END
      SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
*
*  -- LAPACK routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, LDA, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DTRTI2 computes the inverse of a real upper or lower triangular
*  matrix.
*
*  This is the Level 2 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the matrix A is upper or lower triangular.
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  DIAG    (input) CHARACTER*1
*          Specifies whether or not the matrix A is unit triangular.
*          = 'N':  Non-unit triangular
*          = 'U':  Unit triangular
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the triangular matrix A.  If UPLO = 'U', the
*          leading n by n upper triangular part of the array A contains
*          the upper triangular matrix, and the strictly lower
*          triangular part of A is not referenced.  If UPLO = 'L', the
*          leading n by n lower triangular part of the array A contains
*          the lower triangular matrix, and the strictly upper
*          triangular part of A is not referenced.  If DIAG = 'U', the
*          diagonal elements of A are also not referenced and are
*          assumed to be 1.
*
*          On exit, the (triangular) inverse of the original matrix, in
*          the same storage format.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J
      DOUBLE PRECISION   AJJ
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           DSCAL, DTRMV, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRTI2', -INFO )
         RETURN
      END IF
*
      IF( UPPER ) THEN
*
*        Compute inverse of upper triangular matrix.
*
         DO 10 J = 1, N
            IF( NOUNIT ) THEN
               A( J, J ) = ONE / A( J, J )
               AJJ = -A( J, J )
            ELSE
               AJJ = -ONE
            END IF
*
*           Compute elements 1:j-1 of j-th column.
*
            CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
     $                  A( 1, J ), 1 )
            CALL DSCAL( J-1, AJJ, A( 1, J ), 1 )
   10    CONTINUE
      ELSE
*
*        Compute inverse of lower triangular matrix.
*
         DO 20 J = N, 1, -1
            IF( NOUNIT ) THEN
               A( J, J ) = ONE / A( J, J )
               AJJ = -A( J, J )
            ELSE
               AJJ = -ONE
            END IF
            IF( J.LT.N ) THEN
*
*              Compute elements j+1:n of j-th column.
*
               CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J,
     $                     A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
               CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 )
            END IF
   20    CONTINUE
      END IF
*
      RETURN
*
*     End of DTRTI2
*
      END
      SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )
*
*  -- LAPACK routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, LDA, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DTRTRI computes the inverse of a real upper or lower triangular
*  matrix A.
*
*  This is the Level 3 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  A is upper triangular;
*          = 'L':  A is lower triangular.
*
*  DIAG    (input) CHARACTER*1
*          = 'N':  A is non-unit triangular;
*          = 'U':  A is unit triangular.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the triangular matrix A.  If UPLO = 'U', the
*          leading N-by-N upper triangular part of the array A contains
*          the upper triangular matrix, and the strictly lower
*          triangular part of A is not referenced.  If UPLO = 'L', the
*          leading N-by-N lower triangular part of the array A contains
*          the lower triangular matrix, and the strictly upper
*          triangular part of A is not referenced.  If DIAG = 'U', the
*          diagonal elements of A are also not referenced and are
*          assumed to be 1.
*          On exit, the (triangular) inverse of the original matrix, in
*          the same storage format.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*          > 0: if INFO = i, A(i,i) is exactly zero.  The triangular
*               matrix is singular and its inverse can not be computed.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J, JB, NB, NN
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
*     ..
*     .. External Subroutines ..
      EXTERNAL           DTRMM, DTRSM, DTRTI2, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRTRI', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Check for singularity if non-unit.
*
      IF( NOUNIT ) THEN
         DO 10 INFO = 1, N
            IF( A( INFO, INFO ).EQ.ZERO )
     $         RETURN
   10    CONTINUE
         INFO = 0
      END IF
*
*     Determine the block size for this environment.
*
      NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
*        Use unblocked code
*
         CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
      ELSE
*
*        Use blocked code
*
         IF( UPPER ) THEN
*
*           Compute inverse of upper triangular matrix
*
            DO 20 J = 1, N, NB
               JB = MIN( NB, N-J+1 )
*
*              Compute rows 1:j-1 of current block column
*
               CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
     $                     JB, ONE, A, LDA, A( 1, J ), LDA )
               CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
     $                     JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
*
*              Compute inverse of current diagonal block
*
               CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
   20       CONTINUE
         ELSE
*
*           Compute inverse of lower triangular matrix
*
            NN = ( ( N-1 ) / NB )*NB + 1
            DO 30 J = NN, 1, -NB
               JB = MIN( NB, N-J+1 )
               IF( J+JB.LE.N ) THEN
*
*                 Compute rows j+jb:n of current block column
*
                  CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG,
     $                        N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
     $                        A( J+JB, J ), LDA )
                  CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG,
     $                        N-J-JB+1, JB, -ONE, A( J, J ), LDA,
     $                        A( J+JB, J ), LDA )
               END IF
*
*              Compute inverse of current diagonal block
*
               CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
   30       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of DTRTRI
*
      END
      INTEGER          FUNCTION IEEECK( ISPEC, ZERO, ONE )
*
*  -- LAPACK auxiliary routine (version 3.3.1) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*  -- April 2011                                                      --
*
*     .. Scalar Arguments ..
      INTEGER            ISPEC
      REAL               ONE, ZERO
*     ..
*
*  Purpose
*  =======
*
*  IEEECK is called from the ILAENV to verify that Infinity and
*  possibly NaN arithmetic is safe (i.e. will not trap).
*
*  Arguments
*  =========
*
*  ISPEC   (input) INTEGER
*          Specifies whether to test just for inifinity arithmetic
*          or whether to test for infinity and NaN arithmetic.
*          = 0: Verify infinity arithmetic only.
*          = 1: Verify infinity and NaN arithmetic.
*
*  ZERO    (input) REAL
*          Must contain the value 0.0
*          This is passed to prevent the compiler from optimizing
*          away this code.
*
*  ONE     (input) REAL
*          Must contain the value 1.0
*          This is passed to prevent the compiler from optimizing
*          away this code.
*
*  RETURN VALUE:  INTEGER
*          = 0:  Arithmetic failed to produce the correct answers
*          = 1:  Arithmetic produced the correct answers
*
*  =====================================================================
*
*     .. Local Scalars ..
      REAL               NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,
     $                   NEGZRO, NEWZRO, POSINF
*     ..
*     .. Executable Statements ..
      IEEECK = 1
*
      POSINF = ONE / ZERO
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      NEGINF = -ONE / ZERO
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      NEGZRO = ONE / ( NEGINF+ONE )
      IF( NEGZRO.NE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      NEGINF = ONE / NEGZRO
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      NEWZRO = NEGZRO + ZERO
      IF( NEWZRO.NE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      POSINF = ONE / NEWZRO
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      NEGINF = NEGINF*POSINF
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      POSINF = POSINF*POSINF
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
*
*
*
*
*     Return if we were only asked to check infinity arithmetic
*
      IF( ISPEC.EQ.0 )
     $   RETURN
*
      NAN1 = POSINF + NEGINF
*
      NAN2 = POSINF / NEGINF
*
      NAN3 = POSINF / POSINF
*
      NAN4 = POSINF*ZERO
*
      NAN5 = NEGINF*NEGZRO
*
      NAN6 = NAN5*ZERO
*
      IF( NAN1.EQ.NAN1 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      IF( NAN2.EQ.NAN2 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      IF( NAN3.EQ.NAN3 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      IF( NAN4.EQ.NAN4 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      IF( NAN5.EQ.NAN5 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      IF( NAN6.EQ.NAN6 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      RETURN
      END
      INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
*
*  -- LAPACK auxiliary routine (version 3.2.1)                        --
*
*  -- April 2009                                                      --
*
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER*( * )    NAME, OPTS
      INTEGER            ISPEC, N1, N2, N3, N4
*     ..
*
*  Purpose
*  =======
*
*  ILAENV is called from the LAPACK routines to choose problem-dependent
*  parameters for the local environment.  See ISPEC for a description of
*  the parameters.
*
*  ILAENV returns an INTEGER
*  if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC
*  if ILAENV < 0:  if ILAENV = -k, the k-th argument had an illegal value.
*
*  This version provides a set of parameters which should give good,
*  but not optimal, performance on many of the currently available
*  computers.  Users are encouraged to modify this subroutine to set
*  the tuning parameters for their particular machine using the option
*  and problem size information in the arguments.
*
*  This routine will not function correctly if it is converted to all
*  lower case.  Converting it to all upper case is allowed.
*
*  Arguments
*  =========
*
*  ISPEC   (input) INTEGER
*          Specifies the parameter to be returned as the value of
*          ILAENV.
*          = 1: the optimal blocksize; if this value is 1, an unblocked
*               algorithm will give the best performance.
*          = 2: the minimum block size for which the block routine
*               should be used; if the usable block size is less than
*               this value, an unblocked routine should be used.
*          = 3: the crossover point (in a block routine, for N less
*               than this value, an unblocked routine should be used)
*          = 4: the number of shifts, used in the nonsymmetric
*               eigenvalue routines (DEPRECATED)
*          = 5: the minimum column dimension for blocking to be used;
*               rectangular blocks must have dimension at least k by m,
*               where k is given by ILAENV(2,...) and m by ILAENV(5,...)
*          = 6: the crossover point for the SVD (when reducing an m by n
*               matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
*               this value, a QR factorization is used first to reduce
*               the matrix to a triangular form.)
*          = 7: the number of processors
*          = 8: the crossover point for the multishift QR method
*               for nonsymmetric eigenvalue problems (DEPRECATED)
*          = 9: maximum size of the subproblems at the bottom of the
*               computation tree in the divide-and-conquer algorithm
*               (used by xGELSD and xGESDD)
*          =10: ieee NaN arithmetic can be trusted not to trap
*          =11: infinity arithmetic can be trusted not to trap
*          12 <= ISPEC <= 16:
*               xHSEQR or one of its subroutines,
*               see IPARMQ for detailed explanation
*
*  NAME    (input) CHARACTER*(*)
*          The name of the calling subroutine, in either upper case or
*          lower case.
*
*  OPTS    (input) CHARACTER*(*)
*          The character options to the subroutine NAME, concatenated
*          into a single character string.  For example, UPLO = 'U',
*          TRANS = 'T', and DIAG = 'N' for a triangular routine would
*          be specified as OPTS = 'UTN'.
*
*  N1      (input) INTEGER
*  N2      (input) INTEGER
*  N3      (input) INTEGER
*  N4      (input) INTEGER
*          Problem dimensions for the subroutine NAME; these may not all
*          be required.
*
*  Further Details
*  ===============
*
*  The following conventions have been used when calling ILAENV from the
*  LAPACK routines:
*  1)  OPTS is a concatenation of all of the character options to
*      subroutine NAME, in the same order that they appear in the
*      argument list for NAME, even if they are not used in determining
*      the value of the parameter specified by ISPEC.
*  2)  The problem dimensions N1, N2, N3, N4 are specified in the order
*      that they appear in the argument list for NAME.  N1 is used
*      first, N2 second, and so on, and unused problem dimensions are
*      passed a value of -1.
*  3)  The parameter value returned by ILAENV is checked for validity in
*      the calling subroutine.  For example, ILAENV is used to retrieve
*      the optimal blocksize for STRTRI as follows:
*
*      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
*      IF( NB.LE.1 ) NB = MAX( 1, N )
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, IC, IZ, NB, NBMIN, NX
      LOGICAL            CNAME, SNAME
      CHARACTER          C1*1, C2*2, C4*2, C3*3, SUBNAM*6
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CHAR, ICHAR, INT, MIN, REAL
*     ..
*     .. External Functions ..
      INTEGER            IEEECK, IPARMQ
      EXTERNAL           IEEECK, IPARMQ
*     ..
*     .. Executable Statements ..
*
      GO TO ( 10, 10, 10, 80, 90, 100, 110, 120,
     $        130, 140, 150, 160, 160, 160, 160, 160 )ISPEC
*
*     Invalid value for ISPEC
*
      ILAENV = -1
      RETURN
*
   10 CONTINUE
*
*     Convert NAME to upper case if the first character is lower case.
*
      ILAENV = 1
      SUBNAM = NAME
      IC = ICHAR( SUBNAM( 1: 1 ) )
      IZ = ICHAR( 'Z' )
      IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
*
*        ASCII character set
*
         IF( IC.GE.97 .AND. IC.LE.122 ) THEN
            SUBNAM( 1: 1 ) = CHAR( IC-32 )
            DO 20 I = 2, 6
               IC = ICHAR( SUBNAM( I: I ) )
               IF( IC.GE.97 .AND. IC.LE.122 )
     $            SUBNAM( I: I ) = CHAR( IC-32 )
   20       CONTINUE
         END IF
*
      ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
*
*        EBCDIC character set
*
         IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
     $       ( IC.GE.145 .AND. IC.LE.153 ) .OR.
     $       ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
            SUBNAM( 1: 1 ) = CHAR( IC+64 )
            DO 30 I = 2, 6
               IC = ICHAR( SUBNAM( I: I ) )
               IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
     $             ( IC.GE.145 .AND. IC.LE.153 ) .OR.
     $             ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I:
     $             I ) = CHAR( IC+64 )
   30       CONTINUE
         END IF
*
      ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
*
*        Prime machines:  ASCII+128
*
         IF( IC.GE.225 .AND. IC.LE.250 ) THEN
            SUBNAM( 1: 1 ) = CHAR( IC-32 )
            DO 40 I = 2, 6
               IC = ICHAR( SUBNAM( I: I ) )
               IF( IC.GE.225 .AND. IC.LE.250 )
     $            SUBNAM( I: I ) = CHAR( IC-32 )
   40       CONTINUE
         END IF
      END IF
*
      C1 = SUBNAM( 1: 1 )
      SNAME = C1.EQ.'S' .OR. C1.EQ.'D'
      CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'
      IF( .NOT.( CNAME .OR. SNAME ) )
     $   RETURN
      C2 = SUBNAM( 2: 3 )
      C3 = SUBNAM( 4: 6 )
      C4 = C3( 2: 3 )
*
      GO TO ( 50, 60, 70 )ISPEC
*
   50 CONTINUE
*
*     ISPEC = 1:  block size
*
*     In these examples, separate code is provided for setting NB for
*     real and complex.  We assume that NB will take the same value in
*     single or double precision.
*
      NB = 1
*
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
     $            C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'PO' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NB = 32
         ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            NB = 64
         ELSE IF( C3.EQ.'TRD' ) THEN
            NB = 32
         ELSE IF( C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1: 1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NB = 32
            END IF
         ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NB = 32
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1: 1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NB = 32
            END IF
         ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NB = 32
            END IF
         END IF
      ELSE IF( C2.EQ.'GB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'PB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'TR' ) THEN
         IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'LA' ) THEN
         IF( C3.EQ.'UUM' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN
         IF( C3.EQ.'EBZ' ) THEN
            NB = 1
         END IF
      END IF
      ILAENV = NB
      RETURN
*
   60 CONTINUE
*
*     ISPEC = 2:  minimum block size
*
      NBMIN = 2
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ.
     $       'QLF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 8
            ELSE
               NBMIN = 8
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1: 1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NBMIN = 2
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1: 1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NBMIN = 2
            END IF
         END IF
      END IF
      ILAENV = NBMIN
      RETURN
*
   70 CONTINUE
*
*     ISPEC = 3:  crossover point
*
      NX = 0
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ.
     $       'QLF' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NX = 32
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NX = 32
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1: 1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NX = 128
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1: 1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
     $           THEN
               NX = 128
            END IF
         END IF
      END IF
      ILAENV = NX
      RETURN
*
   80 CONTINUE
*
*     ISPEC = 4:  number of shifts (used by xHSEQR)
*
      ILAENV = 6
      RETURN
*
   90 CONTINUE
*
*     ISPEC = 5:  minimum column dimension (not used)
*
      ILAENV = 2
      RETURN
*
  100 CONTINUE
*
*     ISPEC = 6:  crossover point for SVD (used by xGELSS and xGESVD)
*
      ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
      RETURN
*
  110 CONTINUE
*
*     ISPEC = 7:  number of processors (not used)
*
      ILAENV = 1
      RETURN
*
  120 CONTINUE
*
*     ISPEC = 8:  crossover point for multishift (used by xHSEQR)
*
      ILAENV = 50
      RETURN
*
  130 CONTINUE
*
*     ISPEC = 9:  maximum size of the subproblems at the bottom of the
*                 computation tree in the divide-and-conquer algorithm
*                 (used by xGELSD and xGESDD)
*
      ILAENV = 25
      RETURN
*
  140 CONTINUE
*
*     ISPEC = 10: ieee NaN arithmetic can be trusted not to trap
*
*     ILAENV = 0
      ILAENV = 1
      IF( ILAENV.EQ.1 ) THEN
         ILAENV = IEEECK( 1, 0.0, 1.0 )
      END IF
      RETURN
*
  150 CONTINUE
*
*     ISPEC = 11: infinity arithmetic can be trusted not to trap
*
*     ILAENV = 0
      ILAENV = 1
      IF( ILAENV.EQ.1 ) THEN
         ILAENV = IEEECK( 0, 0.0, 1.0 )
      END IF
      RETURN
*
  160 CONTINUE
*
*     12 <= ISPEC <= 16: xHSEQR or one of its subroutines.
*
      ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
      RETURN
*
*     End of ILAENV
*
      END
      INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
*
*  -- LAPACK auxiliary routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            IHI, ILO, ISPEC, LWORK, N
      CHARACTER          NAME*( * ), OPTS*( * )
*
*  Purpose
*  =======
*
*       This program sets problem and machine dependent parameters
*       useful for xHSEQR and its subroutines. It is called whenever
*       ILAENV is called with 12 <= ISPEC <= 16
*
*  Arguments
*  =========
*
*       ISPEC  (input) integer scalar
*              ISPEC specifies which tunable parameter IPARMQ should
*              return.
*
*              ISPEC=12: (INMIN)  Matrices of order nmin or less
*                        are sent directly to xLAHQR, the implicit
*                        double shift QR algorithm.  NMIN must be
*                        at least 11.
*
*              ISPEC=13: (INWIN)  Size of the deflation window.
*                        This is best set greater than or equal to
*                        the number of simultaneous shifts NS.
*                        Larger matrices benefit from larger deflation
*                        windows.
*
*              ISPEC=14: (INIBL) Determines when to stop nibbling and
*                        invest in an (expensive) multi-shift QR sweep.
*                        If the aggressive early deflation subroutine
*                        finds LD converged eigenvalues from an order
*                        NW deflation window and LD.GT.(NW*NIBBLE)/100,
*                        then the next QR sweep is skipped and early
*                        deflation is applied immediately to the
*                        remaining active diagonal block.  Setting
*                        IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a
*                        multi-shift QR sweep whenever early deflation
*                        finds a converged eigenvalue.  Setting
*                        IPARMQ(ISPEC=14) greater than or equal to 100
*                        prevents TTQRE from skipping a multi-shift
*                        QR sweep.
*
*              ISPEC=15: (NSHFTS) The number of simultaneous shifts in
*                        a multi-shift QR iteration.
*
*              ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the
*                        following meanings.
*                        0:  During the multi-shift QR sweep,
*                            xLAQR5 does not accumulate reflections and
*                            does not use matrix-matrix multiply to
*                            update the far-from-diagonal matrix
*                            entries.
*                        1:  During the multi-shift QR sweep,
*                            xLAQR5 and/or xLAQRaccumulates reflections and uses
*                            matrix-matrix multiply to update the
*                            far-from-diagonal matrix entries.
*                        2:  During the multi-shift QR sweep.
*                            xLAQR5 accumulates reflections and takes
*                            advantage of 2-by-2 block structure during
*                            matrix-matrix multiplies.
*                        (If xTRMM is slower than xGEMM, then
*                        IPARMQ(ISPEC=16)=1 may be more efficient than
*                        IPARMQ(ISPEC=16)=2 despite the greater level of
*                        arithmetic work implied by the latter choice.)
*
*       NAME    (input) character string
*               Name of the calling subroutine
*
*       OPTS    (input) character string
*               This is a concatenation of the string arguments to
*               TTQRE.
*
*       N       (input) integer scalar
*               N is the order of the Hessenberg matrix H.
*
*       ILO     (input) INTEGER
*       IHI     (input) INTEGER
*               It is assumed that H is already upper triangular
*               in rows and columns 1:ILO-1 and IHI+1:N.
*
*       LWORK   (input) integer scalar
*               The amount of workspace available.
*
*  Further Details
*  ===============
*
*       Little is known about how best to choose these parameters.
*       It is possible to use different values of the parameters
*       for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR.
*
*       It is probably best to choose different parameters for
*       different matrices and different parameters at different
*       times during the iteration, but this has not been
*       implemented --- yet.
*
*
*       The best choices of most of the parameters depend
*       in an ill-understood way on the relative execution
*       rate of xLAQR3 and xLAQR5 and on the nature of each
*       particular eigenvalue problem.  Experiment may be the
*       only practical way to determine which choices are most
*       effective.
*
*       Following is a list of default values supplied by IPARMQ.
*       These defaults may be adjusted in order to attain better
*       performance in any particular computational environment.
*
*       IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point.
*                        Default: 75. (Must be at least 11.)
*
*       IPARMQ(ISPEC=13) Recommended deflation window size.
*                        This depends on ILO, IHI and NS, the
*                        number of simultaneous shifts returned
*                        by IPARMQ(ISPEC=15).  The default for
*                        (IHI-ILO+1).LE.500 is NS.  The default
*                        for (IHI-ILO+1).GT.500 is 3*NS/2.
*
*       IPARMQ(ISPEC=14) Nibble crossover point.  Default: 14.
*
*       IPARMQ(ISPEC=15) Number of simultaneous shifts, NS.
*                        a multi-shift QR iteration.
*
*                        If IHI-ILO+1 is ...
*
*                        greater than      ...but less    ... the
*                        or equal to ...      than        default is
*
*                                0               30       NS =   2+
*                               30               60       NS =   4+
*                               60              150       NS =  10
*                              150              590       NS =  **
*                              590             3000       NS =  64
*                             3000             6000       NS = 128
*                             6000             infinity   NS = 256
*
*                    (+)  By default matrices of this order are
*                         passed to the implicit double shift routine
*                         xLAHQR.  See IPARMQ(ISPEC=12) above.   These
*                         values of NS are used only in case of a rare
*                         xLAHQR failure.
*
*                    (**) The asterisks (**) indicate an ad-hoc
*                         function increasing from 10 to 64.
*
*       IPARMQ(ISPEC=16) Select structured matrix multiply.
*                        (See ISPEC=16 above for details.)
*                        Default: 3.
*
*     ================================================================
*     .. Parameters ..
      INTEGER            INMIN, INWIN, INIBL, ISHFTS, IACC22
      PARAMETER          ( INMIN = 12, INWIN = 13, INIBL = 14,
     $                   ISHFTS = 15, IACC22 = 16 )
      INTEGER            NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP
      PARAMETER          ( NMIN = 75, K22MIN = 14, KACMIN = 14,
     $                   NIBBLE = 14, KNWSWP = 500 )
      REAL               TWO
      PARAMETER          ( TWO = 2.0 )
*     ..
*     .. Local Scalars ..
      INTEGER            NH, NS
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          LOG, MAX, MOD, NINT, REAL
*     ..
*     .. Executable Statements ..
      IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR.
     $    ( ISPEC.EQ.IACC22 ) ) THEN
*
*        ==== Set the number simultaneous shifts ====
*
         NH = IHI - ILO + 1
         NS = 2
         IF( NH.GE.30 )
     $      NS = 4
         IF( NH.GE.60 )
     $      NS = 10
         IF( NH.GE.150 )
     $      NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) )
         IF( NH.GE.590 )
     $      NS = 64
         IF( NH.GE.3000 )
     $      NS = 128
         IF( NH.GE.6000 )
     $      NS = 256
         NS = MAX( 2, NS-MOD( NS, 2 ) )
      END IF
*
      IF( ISPEC.EQ.INMIN ) THEN
*
*
*        ===== Matrices of order smaller than NMIN get sent
*        .     to xLAHQR, the classic double shift algorithm.
*        .     This must be at least 11. ====
*
         IPARMQ = NMIN
*
      ELSE IF( ISPEC.EQ.INIBL ) THEN
*
*        ==== INIBL: skip a multi-shift qr iteration and
*        .    whenever aggressive early deflation finds
*        .    at least (NIBBLE*(window size)/100) deflations. ====
*
         IPARMQ = NIBBLE
*
      ELSE IF( ISPEC.EQ.ISHFTS ) THEN
*
*        ==== NSHFTS: The number of simultaneous shifts =====
*
         IPARMQ = NS
*
      ELSE IF( ISPEC.EQ.INWIN ) THEN
*
*        ==== NW: deflation window size.  ====
*
         IF( NH.LE.KNWSWP ) THEN
            IPARMQ = NS
         ELSE
            IPARMQ = 3*NS / 2
         END IF
*
      ELSE IF( ISPEC.EQ.IACC22 ) THEN
*
*        ==== IACC22: Whether to accumulate reflections
*        .     before updating the far-from-diagonal elements
*        .     and whether to use 2-by-2 block structure while
*        .     doing it.  A small amount of work could be saved
*        .     by making this choice dependent also upon the
*        .     NH=IHI-ILO+1.
*
         IPARMQ = 0
         IF( NS.GE.KACMIN )
     $      IPARMQ = 1
         IF( NS.GE.K22MIN )
     $      IPARMQ = 2
*
      ELSE
*        ===== invalid value of ispec =====
         IPARMQ = -1
*
      END IF
*
*     ==== End of IPARMQ ====
*
      END
      LOGICAL          FUNCTION LSAME( CA, CB )
*
*  -- LAPACK auxiliary routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          CA, CB
*     ..
*
*  Purpose
*  =======
*
*  LSAME returns .TRUE. if CA is the same letter as CB regardless of
*  case.
*
*  Arguments
*  =========
*
*  CA      (input) CHARACTER*1
*  CB      (input) CHARACTER*1
*          CA and CB specify the single characters to be compared.
*
* =====================================================================
*
*     .. Intrinsic Functions ..
      INTRINSIC          ICHAR
*     ..
*     .. Local Scalars ..
      INTEGER            INTA, INTB, ZCODE
*     ..
*     .. Executable Statements ..
*
*     Test if the characters are equal
*
      LSAME = CA.EQ.CB
      IF( LSAME )
     $   RETURN
*
*     Now test for equivalence if both characters are alphabetic.
*
      ZCODE = ICHAR( 'Z' )
*
*     Use 'Z' rather than 'A' so that ASCII can be detected on Prime
*     machines, on which ICHAR returns a value with bit 8 set.
*     ICHAR('A') on Prime machines returns 193 which is the same as
*     ICHAR('A') on an EBCDIC machine.
*
      INTA = ICHAR( CA )
      INTB = ICHAR( CB )
*
      IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
*
*        ASCII is assumed - ZCODE is the ASCII code of either lower or
*        upper case 'Z'.
*
         IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
         IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
*
      ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
*
*        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
*        upper case 'Z'.
*
         IF( INTA.GE.129 .AND. INTA.LE.137 .OR.
     $       INTA.GE.145 .AND. INTA.LE.153 .OR.
     $       INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
         IF( INTB.GE.129 .AND. INTB.LE.137 .OR.
     $       INTB.GE.145 .AND. INTB.LE.153 .OR.
     $       INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
*
      ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
*
*        ASCII is assumed, on Prime machines - ZCODE is the ASCII code
*        plus 128 of either lower or upper case 'Z'.
*
         IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
         IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
      END IF
      LSAME = INTA.EQ.INTB
*
*     RETURN
*
*     End of LSAME
*
      END
      SUBROUTINE XERBLA( SRNAME, INFO )
*
*  -- LAPACK auxiliary routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER*(*)      SRNAME
      INTEGER            INFO
*     ..
*
*  Purpose
*  =======
*
*  XERBLA  is an error handler for the LAPACK routines.
*  It is called by an LAPACK routine if an input parameter has an
*  invalid value.  A message is printed and execution stops.
*
*  Installers may consider modifying the STOP statement in order to
*  call system-specific exception-handling facilities.
*
*  Arguments
*  =========
*
*  SRNAME  (input) CHARACTER*(*)
*          The name of the routine which called XERBLA.
*
*  INFO    (input) INTEGER
*          The position of the invalid parameter in the parameter list
*          of the calling routine.
*
* =====================================================================
*
*     .. Intrinsic Functions ..
      INTRINSIC          LEN_TRIM
*     ..
*     .. Executable Statements ..
*
      WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO
*
      STOP
*
 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ',
     $      'an illegal value' )
*
*     End of XERBLA
*
      END


program get_offset_1d
  implicit none

  integer,allocatable :: a(:)[:],b(:)
  integer :: me,np,i

  me = this_image()
  np = num_images()

  allocate(a(100)[*],b(10))

  a = (/ (i, i=1,100) /)

  do i=1,100
    a(i) = a(i) + me
  enddo

  sync all

  if(me < np) then
    b(:) = a(21:30)[me+1]
  endif

  if(me == 1) then
    do i=1,10
      if(b(i) /= 20+i+me+1) error stop "get offset 1d failed"
    enddo
  endif
  sync all
  if(me ==1) write(*,*) 'Test passed.'
end program


    Program dgbbrd_example

!     DGBBRD Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dgbbrd
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: vect = 'B'
!     .. Local Scalars ..
      Integer :: i, info, j, kl, ku, ldab, ldb, ldc, ldpt, ldq, m, n, ncc
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: ab(:, :), b(:, :), c(:, :), d(:), e(:), &
        pt(:, :), q(:, :), work(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, max, min
!     .. Executable Statements ..
      Write (nout, *) 'DGBBRD Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n, kl, ku, ncc
      ldab = kl + ku + 1
      ldb = m
      ldc = m
      ldpt = n
      ldq = m
      Allocate (ab(ldab,n), b(ldb,n), c(m,ncc), d(n), e(n-1), pt(ldpt,n), &
        q(ldq,m), work(2*m+2*n))

!     Read A from data file

      Read (nin, *)((ab(ku+1+i-j,j),j=max(i-kl,1),min(i+ku,n)), i=1, m)

!     Reduce A to upper bidiagonal form
      Call dgbbrd(vect, m, n, ncc, kl, ku, ab, ldab, d, e, q, ldq, pt, ldpt, &
        c, ldc, work, info)

!     Print the absolute values of bidiagonal vectors d and e.
!     Any of these can differ by a sign change by combinations of sign
!     changes in columns of Q and P (rows of PT).
      Write (nout, *)
      Write (nout, *) 'Diagonal D:'
      Write (nout, 100) abs(d(1:n))
      Write (nout, *)
      Write (nout, *) 'Off-diagonal E:'
      Write (nout, 100) abs(e(1:n-1))
100   Format (1X, 4(3X,F11.4))

    End Program