PLASMA  2.4.5
PLASMA - Parallel Linear Algebra for Scalable Multi-core Architectures
 All Data Structures Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros Groups
dchkge.f
Go to the documentation of this file.
1  SUBROUTINE dchkge( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS,
2  $ ibval, nsval, thresh, tsterr, nmax, a, afac,
3  $ ainv, b, x, xact, work, rwork, iwork, nout )
4 *
5  include 'plasmaf.h'
6 *
7 * -- LAPACK test routine (version 3.1.1) --
8 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
9 * January 2007
10 *
11 * .. Scalar Arguments ..
12  LOGICAL tsterr
13  INTEGER nm, nmax, nn, nnb, nns, nout
14  DOUBLE PRECISION thresh
15 * ..
16 * .. Array Arguments ..
17  LOGICAL dotype( * )
18  INTEGER ibval( * ), iwork( * ), mval( * ), nbval( * ),
19  $ nsval( * ), nval( * )
20  DOUBLE PRECISION a( * ), afac( * ), ainv( * ), b( * ),
21  $ rwork( * ), work( * ), x( * ), xact( * )
22 * ..
23 *
24 * Purpose
25 * =======
26 *
27 * DCHKGE tests DGETRF, -TRI, -TRS, -RFS, and -CON.
28 *
29 * Arguments
30 * =========
31 *
32 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
33 * The matrix types to be used for testing. Matrices of type j
34 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
35 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
36 *
37 * NM (input) INTEGER
38 * The number of values of M contained in the vector MVAL.
39 *
40 * MVAL (input) INTEGER array, dimension (NM)
41 * The values of the matrix row dimension M.
42 *
43 * NN (input) INTEGER
44 * The number of values of N contained in the vector NVAL.
45 *
46 * NVAL (input) INTEGER array, dimension (NN)
47 * The values of the matrix column dimension N.
48 *
49 * NNB (input) INTEGER
50 * The number of values of NB contained in the vector NBVAL.
51 *
52 * NBVAL (input) INTEGER array, dimension (NBVAL)
53 * The values of the tile size NB.
54 *
55 * IBVAL (input) INTEGER array, dimension (NBVAL)
56 * The values of the inner block size IB.
57 *
58 * NNS (input) INTEGER
59 * The number of values of NRHS contained in the vector NSVAL.
60 *
61 * NSVAL (input) INTEGER array, dimension (NNS)
62 * The values of the number of right hand sides NRHS.
63 *
64 * THRESH (input) DOUBLE PRECISION
65 * The threshold value for the test ratios. A result is
66 * included in the output file if RESULT >= THRESH. To have
67 * every test ratio printed, use THRESH = 0.
68 *
69 * TSTERR (input) LOGICAL
70 * Flag that indicates whether error exits are to be tested.
71 *
72 * NMAX (input) INTEGER
73 * The maximum value permitted for M or N, used in dimensioning
74 * the work arrays.
75 *
76 * A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
77 *
78 * AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
79 *
80 * AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
81 *
82 * B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
83 * where NSMAX is the largest entry in NSVAL.
84 *
85 * X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
86 *
87 * XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
88 *
89 * WORK (workspace) DOUBLE PRECISION array, dimension
90 * (NMAX*max(3,NSMAX))
91 *
92 * RWORK (workspace) DOUBLE PRECISION array, dimension
93 * (max(2*NMAX,2*NSMAX+NWORK))
94 *
95 * IWORK (workspace) INTEGER array, dimension (2*NMAX)
96 *
97 * NOUT (input) INTEGER
98 * The unit number for output.
99 *
100 * =====================================================================
101 *
102 * .. Parameters ..
103  DOUBLE PRECISION one, zero
104  parameter( one = 1.0d+0, zero = 0.0d+0 )
105  INTEGER ntypes
106  parameter( ntypes = 11 )
107  INTEGER ntests
108  parameter( ntests = 8 )
109 * ONLY NOTRANS SUPPORTED !!!
110  INTEGER ntran
111  parameter( ntran = 1 )
112 * ..
113 * .. Local Scalars ..
114  LOGICAL trfcon, zerot
115  CHARACTER dist, norm, trans, type, xtype
116  CHARACTER*3 path
117  INTEGER i, im, imat, ib, in, inb, info, ioff, irhs,
118  $ itran, izero, k, kl, ku, lda, lwork, m, mode,
119  $ n, nb, nerrs, nfail, nimat, nrhs, nrun, nt
120  DOUBLE PRECISION ainvnm, anorm, anormi, anormo, cndnum, dummy,
121  $ rcond, rcondc, rcondi, rcondo
122  INTEGER hl( 2 ), hpiv( 2 )
123  INTEGER plasma_trans
124 * ..
125 * .. Local Arrays ..
126  CHARACTER transs( ntran )
127  INTEGER iseed( 4 ), iseedy( 4 ), plasma_transs( ntran )
128  DOUBLE PRECISION result( ntests )
129 * ..
130 * .. External Functions ..
131  DOUBLE PRECISION dget06, dlange
132  EXTERNAL dget06, dlange
133 * ..
134 * .. External Subroutines ..
135 *** EXTERNAL ALAERH, ALAHD, ALASUM, DERRGE, DGECON, DGERFS,
136 *** $ DGET01 , DGET02, DGET03, DGET04, DGET07, DGETRF,
137 *** $ DGETRI, DGETRS, DLACPY, DLARHS, DLASET, DLATB4,
138 *** $ DLATMS, DERRGEX, XLAENV
139 * ..
140 * .. Intrinsic Functions ..
141  INTRINSIC max, min
142 * ..
143 * .. Scalars in Common ..
144  LOGICAL lerr, ok
145  CHARACTER*32 srnamt
146  INTEGER infot, nunit
147 * ..
148 * .. Common blocks ..
149  common / infoc / infot, nunit, ok, lerr
150  common / srnamc / srnamt
151 * ..
152 * .. Data statements ..
153  DATA iseedy / 1988, 1989, 1990, 1991 / ,
154 * $ TRANSS / 'N', 'T', 'C' /
155  $ transs / 'N' /,
156  $ plasma_transs / plasmanotrans /
157 * ..
158 * .. Executable Statements ..
159 *
160 * Initialize constants and the random number seed.
161 *
162  path( 1: 1 ) = 'Double precision'
163  path( 2: 3 ) = 'GE'
164  rcondo = zero
165  rcondi = zero
166  nrun = 0
167  nfail = 0
168  nerrs = 0
169  DO 10 i = 1, 4
170  iseed( i ) = iseedy( i )
171  10 continue
172 *
173 * Test the error exits
174 *
175  CALL xlaenv( 1, 1 )
176  IF( tsterr )
177  $ CALL derrge( path, nout )
178  infot = 0
179  CALL xlaenv( 2, 2 )
180 *
181 * Do for each value of M in MVAL
182 *
183  DO 120 im = 1, nm
184  m = mval( im )
185  lda = max( 1, m )
186 *
187 * Do for each value of N in NVAL
188 *
189  DO 110 in = 1, nn
190  n = nval( in )
191  xtype = 'N'
192  nimat = ntypes
193  IF( m.LE.0 .OR. n.LE.0 )
194  $ nimat = 1
195 *
196  DO 100 imat = 1, nimat
197 *
198 * Do the tests only if DOTYPE( IMAT ) is true.
199 *
200  IF( .NOT.dotype( imat ) )
201  $ go to 100
202 *
203 * Skip types 5, 6, or 7 if the matrix size is too small.
204 *
205  zerot = imat.GE.5 .AND. imat.LE.7
206  IF( zerot .AND. n.LT.imat-4 )
207  $ go to 100
208 *
209 * Set up parameters with DLATB4 and generate a test matrix
210 * with DLATMS.
211 *
212  CALL dlatb4( path, imat, m, n, type, kl, ku, anorm, mode,
213  $ cndnum, dist )
214 *
215  srnamt = 'DLATMS'
216  CALL dlatms( m, n, dist, iseed, type, rwork, mode,
217  $ cndnum, anorm, kl, ku, 'No packing', a, lda,
218  $ work, info )
219 *
220 * Check error code from DLATMS.
221 *
222  IF( info.NE.0 ) THEN
223  CALL alaerh( path, 'DLATMS', info, 0, ' ', m, n, -1,
224  $ -1, -1, imat, nfail, nerrs, nout )
225  go to 100
226  END IF
227 *
228 * For types 5-7, zero one or more columns of the matrix to
229 * test that INFO is returned correctly.
230 *
231  IF( zerot ) THEN
232  IF( imat.EQ.5 ) THEN
233  izero = 1
234  ELSE IF( imat.EQ.6 ) THEN
235  izero = min( m, n )
236  ELSE
237  izero = min( m, n ) / 2 + 1
238  END IF
239  ioff = ( izero-1 )*lda
240  IF( imat.LT.7 ) THEN
241  DO 20 i = 1, m
242  a( ioff+i ) = zero
243  20 continue
244  ELSE
245  CALL dlaset( 'Full', m, n-izero+1, zero, zero,
246  $ a( ioff+1 ), lda )
247  END IF
248  ELSE
249  izero = 0
250  END IF
251 *
252 * Do for each blocksize in NBVAL
253 *
254  DO 90 inb = 1, nnb
255  nb = nbval( inb )
256  ib = ibval( inb )
257  CALL xlaenv( 1, nb )
258  IF ( (max(m, n) / 25) .GT. nb ) THEN
259  goto 90
260  END IF
261  CALL plasma_set( plasma_tile_size, nb, info )
262  CALL plasma_set( plasma_inner_block_size, ib, info )
263 *
264 * ALLOCATE HL and HPIV
265 *
266 c$$$ CALL PLASMA_ALLOC_WORKSPACE_DGETRF_INCPIV(
267 c$$$ $ M, N, HL, HPIV, INFO )
268 *
269 * Compute the LU factorization of the matrix.
270 *
271  CALL dlacpy( 'Full', m, n, a, lda, afac, lda )
272  srnamt = 'DGETRF'
273 c$$$ CALL PLASMA_DGETRF_INCPIV( M, N, AFAC, LDA, HL, HPIV,
274 c$$$ $ INFO )
275  CALL plasma_dgetrf( m, n, afac, lda, iwork,
276  $ info )
277 *
278 * Check error code from DGETRF.
279 *
280  IF( info.NE.izero )
281  $ CALL alaerh( path, 'DGETRF', info, izero, ' ', m,
282  $ n, -1, -1, nb, imat, nfail, nerrs,
283  $ nout )
284  trfcon = .false.
285  nt = 0
286 *
287  IF( m.NE.n .OR. info.GT.0 ) THEN
288 *
289 * Do only the condition estimate if INFO > 0.
290 *
291  trfcon = .true.
292  anormo = dlange( 'O', m, n, a, lda, rwork )
293  anormi = dlange( 'I', m, n, a, lda, rwork )
294  rcondo = zero
295  rcondi = zero
296  END IF
297 *
298 * Print information about the tests so far that did not
299 * pass the threshold.
300 *
301  DO 30 k = 1, nt
302  IF( result( k ).GE.thresh ) THEN
303  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
304  $ CALL alahd( nout, path )
305  WRITE( nout, fmt = 9999 )m, n, nb, imat, k,
306  $ result( k )
307  nfail = nfail + 1
308  END IF
309  30 continue
310  nrun = nrun + nt
311 *
312 * Skip the remaining tests if this is not the first
313 * block size or if M .ne. N. Skip the solve tests if
314 * the matrix is singular.
315 *
316 * IF( INB.GT.1 .OR. M.NE.N )
317 * $ GO TO 90
318  IF( trfcon )
319  $ go to 70
320 *
321  DO 60 irhs = 1, nns
322  nrhs = nsval( irhs )
323  xtype = 'N'
324 *
325  DO 50 itran = 1, ntran
326  trans = transs( itran )
327  plasma_trans = plasma_transs( itran )
328  IF( itran.EQ.1 ) THEN
329  rcondc = rcondo
330  ELSE
331  rcondc = rcondi
332  END IF
333 *
334 *+ TEST 3
335 * Solve and compute residual for A * X = B.
336 *
337  srnamt = 'DLARHS'
338  CALL dlarhs( path, xtype, ' ', trans, n, n, kl,
339  $ ku, nrhs, a, lda, xact, lda, b,
340  $ lda, iseed, info )
341  xtype = 'C'
342 *
343  CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
344  srnamt = 'DGETRS'
345 c$$$ CALL PLASMA_DGETRS_INCPIV( PLASMA_TRANS, N,
346 c$$$ $ NRHS, AFAC, LDA, HL, HPIV,
347 c$$$ $ X, LDA, INFO )
348  CALL plasma_dgetrs( plasma_trans, n,
349  $ nrhs, afac, lda, iwork,
350  $ x, lda, info )
351 *
352 * Check error code from DGETRS.
353 *
354  IF( info.NE.0 )
355  $ CALL alaerh( path, 'DGETRS', info, 0, trans,
356  $ n, n, -1, -1, nrhs, imat, nfail,
357  $ nerrs, nout )
358 *
359  CALL dlacpy( 'Full', n, nrhs, b, lda, work,
360  $ lda )
361  CALL dget02( trans, n, n, nrhs, a, lda, x, lda,
362  $ work, lda, rwork, result( 3 ) )
363 
364 *
365 *+ TEST 4
366 * Check solution from generated exact solution.
367 *
368  CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
369  $ result( 4 ) )
370 *
371 * Print information about the tests that did not
372 * pass the threshold.
373 *
374  DO 40 k = 3, 4
375  IF( result( k ).GE.thresh ) THEN
376  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
377  $ CALL alahd( nout, path )
378  WRITE( nout, fmt = 9998 )trans, n, nb,
379  $ nrhs, imat, k, result( k )
380  nfail = nfail + 1
381  END IF
382  40 continue
383  nrun = nrun + 2
384  50 continue
385  60 continue
386 *
387  70 continue
388 *
389 * DEALLOCATE HL and HPIV
390 *
391 c$$$ CALL PLASMA_DEALLOC_HANDLE( HL, INFO )
392 c$$$ CALL PLASMA_DEALLOC_HANDLE( HPIV, INFO )
393  90 continue
394  100 continue
395  110 continue
396  120 continue
397 *
398 * Print a summary of the results.
399 *
400  CALL alasum( path, nout, nfail, nrun, nerrs )
401 *
402  9999 format( ' M = ', i5, ', N =', i5, ', NB =', i4, ', type ', i2,
403  $ ', test(', i2, ') =', g12.5 )
404  9998 format( ' TRANS=''', a1, ''', N =', i5, ', NB =', i4 ,
405 ', $ NRHS=', i3, ',type ', i2, ', test(', i2, ') =', g12.5 )
406  9997 format( ' NORM =''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
407  $ ', test(', i2, ') =', g12.5 )
408  return
409 *
410 * End of DCHKGE
411 *
412  END