|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE SCKGLM( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH, 00002 $ NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT, 00003 $ INFO ) 00004 * 00005 * -- LAPACK test routine (version 3.1) -- 00006 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00007 * November 2006 00008 * 00009 * .. Scalar Arguments .. 00010 INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT 00011 REAL THRESH 00012 * .. 00013 * .. Array Arguments .. 00014 INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * ) 00015 REAL A( * ), AF( * ), B( * ), BF( * ), RWORK( * ), 00016 $ WORK( * ), X( * ) 00017 * .. 00018 * 00019 * Purpose 00020 * ======= 00021 * 00022 * SCKGLM tests SGGGLM - subroutine for solving generalized linear 00023 * model problem. 00024 * 00025 * Arguments 00026 * ========= 00027 * 00028 * NN (input) INTEGER 00029 * The number of values of N, M and P contained in the vectors 00030 * NVAL, MVAL and PVAL. 00031 * 00032 * MVAL (input) INTEGER array, dimension (NN) 00033 * The values of the matrix column dimension M. 00034 * 00035 * PVAL (input) INTEGER array, dimension (NN) 00036 * The values of the matrix column dimension P. 00037 * 00038 * NVAL (input) INTEGER array, dimension (NN) 00039 * The values of the matrix row dimension N. 00040 * 00041 * NMATS (input) INTEGER 00042 * The number of matrix types to be tested for each combination 00043 * of matrix dimensions. If NMATS >= NTYPES (the maximum 00044 * number of matrix types), then all the different types are 00045 * generated for testing. If NMATS < NTYPES, another input line 00046 * is read to get the numbers of the matrix types to be used. 00047 * 00048 * ISEED (input/output) INTEGER array, dimension (4) 00049 * On entry, the seed of the random number generator. The array 00050 * elements should be between 0 and 4095, otherwise they will be 00051 * reduced mod 4096, and ISEED(4) must be odd. 00052 * On exit, the next seed in the random number sequence after 00053 * all the test matrices have been generated. 00054 * 00055 * THRESH (input) REAL 00056 * The threshold value for the test ratios. A result is 00057 * included in the output file if RESID >= THRESH. To have 00058 * every test ratio printed, use THRESH = 0. 00059 * 00060 * NMAX (input) INTEGER 00061 * The maximum value permitted for M or N, used in dimensioning 00062 * the work arrays. 00063 * 00064 * A (workspace) REAL array, dimension (NMAX*NMAX) 00065 * 00066 * AF (workspace) REAL array, dimension (NMAX*NMAX) 00067 * 00068 * B (workspace) REAL array, dimension (NMAX*NMAX) 00069 * 00070 * BF (workspace) REAL array, dimension (NMAX*NMAX) 00071 * 00072 * X (workspace) REAL array, dimension (4*NMAX) 00073 * 00074 * RWORK (workspace) REAL array, dimension (NMAX) 00075 * 00076 * WORK (workspace) REAL array, dimension (NMAX*NMAX) 00077 * 00078 * NIN (input) INTEGER 00079 * The unit number for input. 00080 * 00081 * NOUT (input) INTEGER 00082 * The unit number for output. 00083 * 00084 * INFO (output) INTEGER 00085 * = 0 : successful exit 00086 * > 0 : If SLATMS returns an error code, the absolute value 00087 * of it is returned. 00088 * 00089 * ===================================================================== 00090 * 00091 * .. Parameters .. 00092 INTEGER NTYPES 00093 PARAMETER ( NTYPES = 8 ) 00094 * .. 00095 * .. Local Scalars .. 00096 LOGICAL FIRSTT 00097 CHARACTER DISTA, DISTB, TYPE 00098 CHARACTER*3 PATH 00099 INTEGER I, IINFO, IK, IMAT, KLA, KLB, KUA, KUB, LDA, 00100 $ LDB, LWORK, M, MODEA, MODEB, N, NFAIL, NRUN, P 00101 REAL ANORM, BNORM, CNDNMA, CNDNMB, RESID 00102 * .. 00103 * .. Local Arrays .. 00104 LOGICAL DOTYPE( NTYPES ) 00105 * .. 00106 * .. External Functions .. 00107 REAL SLARND 00108 EXTERNAL SLARND 00109 * .. 00110 * .. External Subroutines .. 00111 EXTERNAL ALAHDG, ALAREQ, ALASUM, SGLMTS, SLATB9, SLATMS 00112 * .. 00113 * .. Intrinsic Functions .. 00114 INTRINSIC ABS 00115 * .. 00116 * .. Executable Statements .. 00117 * 00118 * Initialize constants. 00119 * 00120 PATH( 1: 3 ) = 'GLM' 00121 INFO = 0 00122 NRUN = 0 00123 NFAIL = 0 00124 FIRSTT = .TRUE. 00125 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) 00126 LDA = NMAX 00127 LDB = NMAX 00128 LWORK = NMAX*NMAX 00129 * 00130 * Check for valid input values. 00131 * 00132 DO 10 IK = 1, NN 00133 M = MVAL( IK ) 00134 P = PVAL( IK ) 00135 N = NVAL( IK ) 00136 IF( M.GT.N .OR. N.GT.M+P ) THEN 00137 IF( FIRSTT ) THEN 00138 WRITE( NOUT, FMT = * ) 00139 FIRSTT = .FALSE. 00140 END IF 00141 WRITE( NOUT, FMT = 9997 )M, P, N 00142 END IF 00143 10 CONTINUE 00144 FIRSTT = .TRUE. 00145 * 00146 * Do for each value of M in MVAL. 00147 * 00148 DO 40 IK = 1, NN 00149 M = MVAL( IK ) 00150 P = PVAL( IK ) 00151 N = NVAL( IK ) 00152 IF( M.GT.N .OR. N.GT.M+P ) 00153 $ GO TO 40 00154 * 00155 DO 30 IMAT = 1, NTYPES 00156 * 00157 * Do the tests only if DOTYPE( IMAT ) is true. 00158 * 00159 IF( .NOT.DOTYPE( IMAT ) ) 00160 $ GO TO 30 00161 * 00162 * Set up parameters with SLATB9 and generate test 00163 * matrices A and B with SLATMS. 00164 * 00165 CALL SLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, KLB, KUB, 00166 $ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB, 00167 $ DISTA, DISTB ) 00168 * 00169 CALL SLATMS( N, M, DISTA, ISEED, TYPE, RWORK, MODEA, CNDNMA, 00170 $ ANORM, KLA, KUA, 'No packing', A, LDA, WORK, 00171 $ IINFO ) 00172 IF( IINFO.NE.0 ) THEN 00173 WRITE( NOUT, FMT = 9999 )IINFO 00174 INFO = ABS( IINFO ) 00175 GO TO 30 00176 END IF 00177 * 00178 CALL SLATMS( N, P, DISTB, ISEED, TYPE, RWORK, MODEB, CNDNMB, 00179 $ BNORM, KLB, KUB, 'No packing', B, LDB, WORK, 00180 $ IINFO ) 00181 IF( IINFO.NE.0 ) THEN 00182 WRITE( NOUT, FMT = 9999 )IINFO 00183 INFO = ABS( IINFO ) 00184 GO TO 30 00185 END IF 00186 * 00187 * Generate random left hand side vector of GLM 00188 * 00189 DO 20 I = 1, N 00190 X( I ) = SLARND( 2, ISEED ) 00191 20 CONTINUE 00192 * 00193 CALL SGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, X, 00194 $ X( NMAX+1 ), X( 2*NMAX+1 ), X( 3*NMAX+1 ), 00195 $ WORK, LWORK, RWORK, RESID ) 00196 * 00197 * Print information about the tests that did not 00198 * pass the threshold. 00199 * 00200 IF( RESID.GE.THRESH ) THEN 00201 IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN 00202 FIRSTT = .FALSE. 00203 CALL ALAHDG( NOUT, PATH ) 00204 END IF 00205 WRITE( NOUT, FMT = 9998 )N, M, P, IMAT, 1, RESID 00206 NFAIL = NFAIL + 1 00207 END IF 00208 NRUN = NRUN + 1 00209 * 00210 30 CONTINUE 00211 40 CONTINUE 00212 * 00213 * Print a summary of the results. 00214 * 00215 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 ) 00216 * 00217 9999 FORMAT( ' SLATMS in SCKGLM INFO = ', I5 ) 00218 9998 FORMAT( ' N=', I4, ' M=', I4, ', P=', I4, ', type ', I2, 00219 $ ', test ', I2, ', ratio=', G13.6 ) 00220 9997 FORMAT( ' *** Invalid input for GLM: M = ', I6, ', P = ', I6, 00221 $ ', N = ', I6, ';', / ' must satisfy M <= N <= M+P ', 00222 $ '(this set of values will be skipped)' ) 00223 RETURN 00224 * 00225 * End of SCKGLM 00226 * 00227 END
1.7.3 
