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
zdrvge.f
Go to the documentation of this file.
1  SUBROUTINE zdrvge( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
2  $ a, afac, asav, b, bsav, x, xact, s, work,
3  $ rwork, iwork, nout )
4 *
5  include 'plasmaf.h'
6 *
7 * -- LAPACK test routine (version 3.1) --
8 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
9 * November 2006
10 *
11 * .. Scalar Arguments ..
12  LOGICAL tsterr
13  INTEGER nmax, nn, nout, nrhs
14  DOUBLE PRECISION thresh
15 * ..
16 * .. Array Arguments ..
17  LOGICAL dotype( * )
18  INTEGER iwork( * ), nval( * )
19  DOUBLE PRECISION rwork( * ), s( * )
20  COMPLEX*16 a( * ), afac( * ), asav( * ), b( * ),
21  $ bsav( * ), work( * ), x( * ), xact( * )
22 * ..
23 *
24 * Purpose
25 * =======
26 *
27 * ZDRVGE tests the driver routines ZGESV and -SVX.
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 * NN (input) INTEGER
38 * The number of values of N contained in the vector NVAL.
39 *
40 * NVAL (input) INTEGER array, dimension (NN)
41 * The values of the matrix column dimension N.
42 *
43 * NRHS (input) INTEGER
44 * The number of right hand side vectors to be generated for
45 * each linear system.
46 *
47 * THRESH (input) DOUBLE PRECISION
48 * The threshold value for the test ratios. A result is
49 * included in the output file if RESULT >= THRESH. To have
50 * every test ratio printed, use THRESH = 0.
51 *
52 * TSTERR (input) LOGICAL
53 * Flag that indicates whether error exits are to be tested.
54 *
55 * NMAX (input) INTEGER
56 * The maximum value permitted for N, used in dimensioning the
57 * work arrays.
58 *
59 * A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
60 *
61 * AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
62 *
63 * ASAV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
64 *
65 * B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
66 *
67 * BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
68 *
69 * X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
70 *
71 * XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
72 *
73 * S (workspace) DOUBLE PRECISION array, dimension (2*NMAX)
74 *
75 * WORK (workspace) COMPLEX*16 array, dimension
76 * (NMAX*max(3,NRHS))
77 *
78 * RWORK (workspace) DOUBLE PRECISION array, dimension (2*NRHS+NMAX)
79 *
80 * IWORK (workspace) INTEGER array, dimension (NMAX)
81 *
82 * NOUT (input) INTEGER
83 * The unit number for output.
84 *
85 * =====================================================================
86 *
87 * .. Parameters ..
88  DOUBLE PRECISION one, zero
89  parameter( one = 1.0d+0, zero = 0.0d+0 )
90  INTEGER ntypes
91  parameter( ntypes = 11 )
92  INTEGER ntests
93  parameter( ntests = 7 )
94  INTEGER ntran
95  parameter( ntran = 1 )
96 * ..
97 * .. Local Scalars ..
98  LOGICAL equil, nofact, prefac, trfcon, zerot
99  CHARACTER dist, equed, fact, trans, type, xtype
100  CHARACTER*3 path
101  INTEGER hl( 2 ), hpiv( 2 ), ib, plasma_trans
102  INTEGER i, iequed, ifact, imat, in, info, ioff, itran,
103  $ izero, k, k1, kl, ku, lda, lwork, mode, n, nb,
104  $ nbmin, nerrs, nfact, nfail, nimat, nrun, nt
105  DOUBLE PRECISION ainvnm, amax, anorm, anormi, anormo, cndnum,
106  $ colcnd, rcond, rcondc, rcondi, rcondo, roldc,
107  $ roldi, roldo, rowcnd, rpvgrw
108 * ..
109 * .. Local Arrays ..
110  CHARACTER equeds( 4 ), facts( 3 ), transs( ntran )
111  INTEGER iseed( 4 ), iseedy( 4 ), plasma_transs( ntran)
112  DOUBLE PRECISION rdum( 1 ), result( ntests )
113 * ..
114 * .. External Functions ..
115  LOGICAL lsame
116  DOUBLE PRECISION dget06, dlamch, zlange, zlantr
117  EXTERNAL lsame, dget06, dlamch, zlange, zlantr
118 * ..
119 * .. External Subroutines ..
120  EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx, zgeequ,
121  $ zgesv, zgesvx, zget02, zget04,
122  $ zgetrf, zgetri, zlacpy, zlaqge, zlarhs, zlaset,
123  $ zlatb4, zlatms
124 * ..
125 * .. Intrinsic Functions ..
126  INTRINSIC abs, dcmplx, max
127 * ..
128 * .. Scalars in Common ..
129  LOGICAL lerr, ok
130  CHARACTER*32 srnamt
131  INTEGER infot, nunit
132 * ..
133 * .. Common blocks ..
134  common / infoc / infot, nunit, ok, lerr
135  common / srnamc / srnamt
136 * ..
137 * .. Data statements ..
138  DATA iseedy / 1988, 1989, 1990, 1991 /
139 * DATA TRANSS / 'N', 'T', 'C' /
140  DATA transs / 'N' /
141  DATA plasma_transs / plasmanotrans /
142  DATA facts / 'F', 'N', 'E' /
143  DATA equeds / 'N', 'R', 'C', 'B' /
144 * ..
145 * .. Executable Statements ..
146 *
147 * Initialize constants and the random number seed.
148 *
149  path( 1: 1 ) = 'Zomplex precision'
150  path( 2: 3 ) = 'GE'
151  rcondo = zero
152  rcondi = zero
153  nrun = 0
154  nfail = 0
155  nerrs = 0
156  DO 10 i = 1, 4
157  iseed( i ) = iseedy( i )
158  10 continue
159 *
160 * Test the error exits
161 *
162  IF( tsterr )
163  $ CALL zerrvx( path, nout )
164  infot = 0
165 *
166 * Set the block size and minimum block size for testing.
167 *
168  nb = 128
169  ib = 32
170  nbmin = 32
171  CALL xlaenv( 1, nb )
172  CALL xlaenv( 2, nbmin )
173  CALL plasma_set( plasma_tile_size, nb, info )
174  CALL plasma_set( plasma_inner_block_size, ib, info )
175 *
176 * Do for each value of N in NVAL
177 *
178  DO 90 in = 1, nn
179  n = nval( in )
180  lda = max( n, 1 )
181  xtype = 'N'
182  nimat = ntypes
183  IF( n.LE.0 )
184  $ nimat = 1
185 *
186 * ALLOCATE L and IPIV
187 *
188 c$$$ CALL PLASMA_ALLOC_WORKSPACE_ZGETRF_INCPIV(
189 c$$$ $ N, N, HL, HPIV, INFO )
190 *
191 *
192  DO 80 imat = 1, nimat
193 *
194 * Do the tests only if DOTYPE( IMAT ) is true.
195 *
196  IF( .NOT.dotype( imat ) )
197  $ go to 80
198 *
199 * Skip types 5, 6, or 7 if the matrix size is too small.
200 *
201  zerot = imat.GE.5 .AND. imat.LE.7
202  IF( zerot .AND. n.LT.imat-4 )
203  $ go to 80
204 *
205 * Set up parameters with ZLATB4 and generate a test matrix
206 * with ZLATMS.
207 *
208  CALL zlatb4( path, imat, n, n, type, kl, ku, anorm, mode,
209  $ cndnum, dist )
210  rcondc = one / cndnum
211 *
212  srnamt = 'ZLATMS'
213  CALL zlatms( n, n, dist, iseed, type, rwork, mode, cndnum,
214  $ anorm, kl, ku, 'No packing', a, lda, work,
215  $ info )
216 *
217 * Check error code from ZLATMS.
218 *
219  IF( info.NE.0 ) THEN
220  CALL alaerh( path, 'ZLATMS', info, 0, ' ', n, n, -1, -1,
221  $ -1, imat, nfail, nerrs, nout )
222  go to 80
223  END IF
224 *
225 * For types 5-7, zero one or more columns of the matrix to
226 * test that INFO is returned correctly.
227 *
228  IF( zerot ) THEN
229  IF( imat.EQ.5 ) THEN
230  izero = 1
231  ELSE IF( imat.EQ.6 ) THEN
232  izero = n
233  ELSE
234  izero = n / 2 + 1
235  END IF
236  ioff = ( izero-1 )*lda
237  IF( imat.LT.7 ) THEN
238  DO 20 i = 1, n
239  a( ioff+i ) = zero
240  20 continue
241  ELSE
242  CALL zlaset( 'Full', n, n-izero+1, dcmplx( zero ),
243  $ dcmplx( zero ), a( ioff+1 ), lda )
244  END IF
245  ELSE
246  izero = 0
247  END IF
248 *
249 * Save a copy of the matrix A in ASAV.
250 *
251  CALL zlacpy( 'Full', n, n, a, lda, asav, lda )
252 *
253  DO 70 iequed = 1, 4
254  equed = equeds( iequed )
255  IF( iequed.EQ.1 ) THEN
256  nfact = 3
257  ELSE
258  nfact = 1
259  END IF
260 *
261  DO 60 ifact = 1, nfact
262  fact = facts( ifact )
263  prefac = lsame( fact, 'F' )
264  nofact = lsame( fact, 'N' )
265  equil = lsame( fact, 'E' )
266 *
267  IF( zerot ) THEN
268  IF( prefac )
269  $ go to 60
270  rcondo = zero
271  rcondi = zero
272 *
273  ELSE IF( .NOT.nofact ) THEN
274 *
275 * Compute the condition number for comparison with
276 * the value returned by ZGESVX (FACT = 'N' reuses
277 * the condition number from the previous iteration
278 * with FACT = 'F').
279 *
280  CALL zlacpy( 'Full', n, n, asav, lda, afac, lda )
281  IF( equil .OR. iequed.GT.1 ) THEN
282 *
283 * Compute row and column scale factors to
284 * equilibrate the matrix A.
285 *
286  CALL zgeequ( n, n, afac, lda, s, s( n+1 ),
287  $ rowcnd, colcnd, amax, info )
288  IF( info.EQ.0 .AND. n.GT.0 ) THEN
289  IF( lsame( equed, 'R' ) ) THEN
290  rowcnd = zero
291  colcnd = one
292  ELSE IF( lsame( equed, 'C' ) ) THEN
293  rowcnd = one
294  colcnd = zero
295  ELSE IF( lsame( equed, 'B' ) ) THEN
296  rowcnd = zero
297  colcnd = zero
298  END IF
299 *
300 * Equilibrate the matrix.
301 *
302  CALL zlaqge( n, n, afac, lda, s, s( n+1 ),
303  $ rowcnd, colcnd, amax, equed )
304  END IF
305  END IF
306 *
307 * Save the condition number of the non-equilibrated
308 * system for use in ZGET04.
309 *
310  IF( equil ) THEN
311  roldo = rcondo
312  roldi = rcondi
313  END IF
314 *
315 * Compute the 1-norm and infinity-norm of A.
316 *
317  anormo = zlange( '1', n, n, afac, lda, rwork )
318  anormi = zlange( 'I', n, n, afac, lda, rwork )
319 *
320 * Factor the matrix A.
321 *
322 c$$$ CALL PLASMA_ZGETRF_INCPIV( N, N, AFAC, LDA,
323 c$$$ $ HL, HPIV, INFO )
324  CALL plasma_zgetrf( n, n, afac, lda,
325  $ iwork, info )
326 *
327  END IF
328 *
329  DO 50 itran = 1, ntran
330 *
331 * Do for each value of TRANS.
332 *
333  trans = transs( itran )
334  plasma_trans = plasma_transs( itran )
335  IF( itran.EQ.1 ) THEN
336  rcondc = rcondo
337  ELSE
338  rcondc = rcondi
339  END IF
340 *
341 * Restore the matrix A.
342 *
343  CALL zlacpy( 'Full', n, n, asav, lda, a, lda )
344 *
345 * Form an exact solution and set the right hand side.
346 *
347  srnamt = 'ZLARHS'
348  CALL zlarhs( path, xtype, 'Full', trans, n, n, kl,
349  $ ku, nrhs, a, lda, xact, lda, b, lda,
350  $ iseed, info )
351  xtype = 'C'
352  CALL zlacpy( 'Full', n, nrhs, b, lda, bsav, lda )
353 *
354  IF( nofact .AND. itran.EQ.1 ) THEN
355 *
356 * --- Test ZGESV ---
357 *
358 * Compute the LU factorization of the matrix and
359 * solve the system.
360 *
361  CALL zlacpy( 'Full', n, n, a, lda, afac, lda )
362  CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
363 *
364  srnamt = 'ZGESV '
365 c$$$ CALL PLASMA_ZGESV_INCPIV( N, NRHS, AFAC, LDA,
366 c$$$ $ HL, HPIV, X, LDA, INFO )
367  CALL plasma_zgesv( n, nrhs, afac, lda,
368  $ iwork, x, lda, info )
369 *
370 * Check error code from ZGESV .
371 *
372  IF( info.NE.izero )
373  $ CALL alaerh( path, 'ZGESV ', info, izero,
374  $ ' ', n, n, -1, -1, nrhs, imat,
375  $ nfail, nerrs, nout )
376 *
377  IF( izero.EQ.0 ) THEN
378 *
379 * Compute residual of the computed solution.
380 *
381  CALL zlacpy( 'Full', n, nrhs, b, lda, work,
382  $ lda )
383  CALL zget02( 'No transpose', n, n, nrhs, a,
384  $ lda, x, lda, work, lda, rwork,
385  $ result( 1 ) )
386 *
387 * Check solution from generated exact solution.
388 *
389  CALL zget04( n, nrhs, x, lda, xact, lda,
390  $ rcondc, result( 2 ) )
391  nt = 2
392  END IF
393 *
394 * Print information about the tests that did not
395 * pass the threshold.
396 *
397  DO 30 k = 1, nt
398  IF( result( k ).GE.thresh ) THEN
399  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
400  $ CALL aladhd( nout, path )
401  WRITE( nout, fmt = 9999 )'ZGESV ', n,
402  $ imat, k, result( k )
403  nfail = nfail + 1
404  END IF
405  30 continue
406  nrun = nrun + nt
407  END IF
408 *
409  50 continue
410  60 continue
411  70 continue
412  80 continue
413 *
414 * DEALLOCATE HL and HPIV
415 *
416 c$$$ CALL PLASMA_DEALLOC_HANDLE( HL, INFO )
417 c$$$ CALL PLASMA_DEALLOC_HANDLE( HPIV, INFO )
418  90 continue
419 *
420 * Print a summary of the results.
421 *
422  CALL alasvm( path, nout, nfail, nrun, nerrs )
423 *
424  9999 format( 1x, a, ', N =', i5, ', type ', i2, ', test(', i2, ') =',
425  $ g12.5 )
426  9998 format( 1x, a, ', FACT=''', a1, ''', TRANS=''', a1, ''', N=', i5,
427  $ ', type ', i2, ', test(', i1, ')=', g12.5 )
428  9997 format( 1x, a, ', FACT=''', a1, ''', TRANS=''', a1, ''', N=', i5,
429  $ ', EQUED=''', a1, ''', type ', i2, ', test(', i1, ')=',
430  $ g12.5 )
431  return
432 *
433 * End of ZDRVGE
434 *
435  END