|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE SCHKGL( NIN, NOUT ) 00002 * 00003 * -- LAPACK test routine (version 3.1) -- 00004 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00005 * November 2006 00006 * 00007 * .. Scalar Arguments .. 00008 INTEGER NIN, NOUT 00009 * .. 00010 * 00011 * Purpose 00012 * ======= 00013 * 00014 * SCHKGL tests SGGBAL, a routine for balancing a matrix pair (A, B). 00015 * 00016 * Arguments 00017 * ========= 00018 * 00019 * NIN (input) INTEGER 00020 * The logical unit number for input. NIN > 0. 00021 * 00022 * NOUT (input) INTEGER 00023 * The logical unit number for output. NOUT > 0. 00024 * 00025 * ===================================================================== 00026 * 00027 * .. Parameters .. 00028 INTEGER LDA, LDB, LWORK 00029 PARAMETER ( LDA = 20, LDB = 20, LWORK = 6*LDA ) 00030 REAL ZERO 00031 PARAMETER ( ZERO = 0.0E+0 ) 00032 * .. 00033 * .. Local Scalars .. 00034 INTEGER I, IHI, IHIIN, ILO, ILOIN, INFO, J, KNT, N, 00035 $ NINFO 00036 REAL ANORM, BNORM, EPS, RMAX, VMAX 00037 * .. 00038 * .. Local Arrays .. 00039 INTEGER LMAX( 5 ) 00040 REAL A( LDA, LDA ), AIN( LDA, LDA ), B( LDB, LDB ), 00041 $ BIN( LDB, LDB ), LSCALE( LDA ), LSCLIN( LDA ), 00042 $ RSCALE( LDA ), RSCLIN( LDA ), WORK( LWORK ) 00043 * .. 00044 * .. External Functions .. 00045 REAL SLAMCH, SLANGE 00046 EXTERNAL SLAMCH, SLANGE 00047 * .. 00048 * .. External Subroutines .. 00049 EXTERNAL SGGBAL 00050 * .. 00051 * .. Intrinsic Functions .. 00052 INTRINSIC ABS, MAX 00053 * .. 00054 * .. Executable Statements .. 00055 * 00056 LMAX( 1 ) = 0 00057 LMAX( 2 ) = 0 00058 LMAX( 3 ) = 0 00059 NINFO = 0 00060 KNT = 0 00061 RMAX = ZERO 00062 * 00063 EPS = SLAMCH( 'Precision' ) 00064 * 00065 10 CONTINUE 00066 * 00067 READ( NIN, FMT = * )N 00068 IF( N.EQ.0 ) 00069 $ GO TO 90 00070 DO 20 I = 1, N 00071 READ( NIN, FMT = * )( A( I, J ), J = 1, N ) 00072 20 CONTINUE 00073 * 00074 DO 30 I = 1, N 00075 READ( NIN, FMT = * )( B( I, J ), J = 1, N ) 00076 30 CONTINUE 00077 * 00078 READ( NIN, FMT = * )ILOIN, IHIIN 00079 DO 40 I = 1, N 00080 READ( NIN, FMT = * )( AIN( I, J ), J = 1, N ) 00081 40 CONTINUE 00082 DO 50 I = 1, N 00083 READ( NIN, FMT = * )( BIN( I, J ), J = 1, N ) 00084 50 CONTINUE 00085 * 00086 READ( NIN, FMT = * )( LSCLIN( I ), I = 1, N ) 00087 READ( NIN, FMT = * )( RSCLIN( I ), I = 1, N ) 00088 * 00089 ANORM = SLANGE( 'M', N, N, A, LDA, WORK ) 00090 BNORM = SLANGE( 'M', N, N, B, LDB, WORK ) 00091 * 00092 KNT = KNT + 1 00093 * 00094 CALL SGGBAL( 'B', N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, 00095 $ WORK, INFO ) 00096 * 00097 IF( INFO.NE.0 ) THEN 00098 NINFO = NINFO + 1 00099 LMAX( 1 ) = KNT 00100 END IF 00101 * 00102 IF( ILO.NE.ILOIN .OR. IHI.NE.IHIIN ) THEN 00103 NINFO = NINFO + 1 00104 LMAX( 2 ) = KNT 00105 END IF 00106 * 00107 VMAX = ZERO 00108 DO 70 I = 1, N 00109 DO 60 J = 1, N 00110 VMAX = MAX( VMAX, ABS( A( I, J )-AIN( I, J ) ) ) 00111 VMAX = MAX( VMAX, ABS( B( I, J )-BIN( I, J ) ) ) 00112 60 CONTINUE 00113 70 CONTINUE 00114 * 00115 DO 80 I = 1, N 00116 VMAX = MAX( VMAX, ABS( LSCALE( I )-LSCLIN( I ) ) ) 00117 VMAX = MAX( VMAX, ABS( RSCALE( I )-RSCLIN( I ) ) ) 00118 80 CONTINUE 00119 * 00120 VMAX = VMAX / ( EPS*MAX( ANORM, BNORM ) ) 00121 * 00122 IF( VMAX.GT.RMAX ) THEN 00123 LMAX( 3 ) = KNT 00124 RMAX = VMAX 00125 END IF 00126 * 00127 GO TO 10 00128 * 00129 90 CONTINUE 00130 * 00131 WRITE( NOUT, FMT = 9999 ) 00132 9999 FORMAT( 1X, '.. test output of SGGBAL .. ' ) 00133 * 00134 WRITE( NOUT, FMT = 9998 )RMAX 00135 9998 FORMAT( 1X, 'value of largest test error = ', E12.3 ) 00136 WRITE( NOUT, FMT = 9997 )LMAX( 1 ) 00137 9997 FORMAT( 1X, 'example number where info is not zero = ', I4 ) 00138 WRITE( NOUT, FMT = 9996 )LMAX( 2 ) 00139 9996 FORMAT( 1X, 'example number where ILO or IHI wrong = ', I4 ) 00140 WRITE( NOUT, FMT = 9995 )LMAX( 3 ) 00141 9995 FORMAT( 1X, 'example number having largest error = ', I4 ) 00142 WRITE( NOUT, FMT = 9994 )NINFO 00143 9994 FORMAT( 1X, 'number of examples where info is not 0 = ', I4 ) 00144 WRITE( NOUT, FMT = 9993 )KNT 00145 9993 FORMAT( 1X, 'total number of examples tested = ', I4 ) 00146 * 00147 RETURN 00148 * 00149 * End of SCHKGL 00150 * 00151 END
1.7.3 
