172
173
174
175
176
177 IMPLICIT NONE
178
179
180 LOGICAL TSTERR
181 INTEGER NN, NNB, NNS, NMAX, NOUT
182 DOUBLE PRECISION THRESH
183
184
185 LOGICAL DOTYPE( * )
186 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
187 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
188 $ WORK( * ), X( * ), XACT( * )
189 DOUBLE PRECISION RWORK( * )
190
191
192
193
194
195 DOUBLE PRECISION ZERO
196 parameter( zero = 0.0d+0 )
197 COMPLEX*16 CZERO
198 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
199 INTEGER NTYPES
200 parameter( ntypes = 10 )
201 INTEGER NTESTS
202 parameter( ntests = 9 )
203
204
205 LOGICAL ZEROT
206 CHARACTER DIST, TYPE, UPLO, XTYPE
207 CHARACTER*3 PATH, MATPATH
208 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
209 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
210 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
211 DOUBLE PRECISION ANORM, CNDNUM
212
213
214 CHARACTER UPLOS( 2 )
215 INTEGER ISEED( 4 ), ISEEDY( 4 )
216 DOUBLE PRECISION RESULT( NTESTS )
217
218
223
224
225 INTRINSIC max, min
226
227
228 LOGICAL LERR, OK
229 CHARACTER*32 SRNAMT
230 INTEGER INFOT, NUNIT
231
232
233 COMMON / infoc / infot, nunit, ok, lerr
234 COMMON / srnamc / srnamt
235
236
237 DATA iseedy / 1988, 1989, 1990, 1991 /
238 DATA uplos / 'U', 'L' /
239
240
241
242
243
244
245
246 path( 1: 1 ) = 'Zomplex precision'
247 path( 2: 3 ) = 'H2'
248
249
250
251 matpath( 1: 1 ) = 'Zomplex precision'
252 matpath( 2: 3 ) = 'HE'
253 nrun = 0
254 nfail = 0
255 nerrs = 0
256 DO 10 i = 1, 4
257 iseed( i ) = iseedy( i )
258 10 CONTINUE
259
260
261
262 IF( tsterr )
263 $
CALL zerrhe( path, nout )
264 infot = 0
265
266
267
268
270
271
272
273 DO 180 in = 1, nn
274 n = nval( in )
275 IF( n .GT. nmax ) THEN
276 nfail = nfail + 1
277 WRITE(nout, 9995) 'M ', n, nmax
278 GO TO 180
279 END IF
280 lda = max( n, 1 )
281 xtype = 'N'
282 nimat = ntypes
283 IF( n.LE.0 )
284 $ nimat = 1
285
286 izero = 0
287
288
289
290 DO 170 imat = 1, nimat
291
292
293
294 IF( .NOT.dotype( imat ) )
295 $ GO TO 170
296
297
298
299 zerot = imat.GE.3 .AND. imat.LE.6
300 IF( zerot .AND. n.LT.imat-2 )
301 $ GO TO 170
302
303
304
305 DO 160 iuplo = 1, 2
306 uplo = uplos( iuplo )
307
308
309
310
311
312
313
314 CALL zlatb4( matpath, imat, n, n,
TYPE, KL, KU,
315 $ ANORM, MODE, CNDNUM, DIST )
316
317
318
319 srnamt = 'ZLATMS'
320 CALL zlatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
321 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
322 $ INFO )
323
324
325
326 IF( info.NE.0 ) THEN
327 CALL alaerh( path,
'ZLATMS', info, 0, uplo, n, n, -1,
328 $ -1, -1, imat, nfail, nerrs, nout )
329
330
331
332 GO TO 160
333 END IF
334
335
336
337
338
339 IF( zerot ) THEN
340 IF( imat.EQ.3 ) THEN
341 izero = 1
342 ELSE IF( imat.EQ.4 ) THEN
343 izero = n
344 ELSE
345 izero = n / 2 + 1
346 END IF
347
348 IF( imat.LT.6 ) THEN
349
350
351
352 IF( iuplo.EQ.1 ) THEN
353 ioff = ( izero-1 )*lda
354 DO 20 i = 1, izero - 1
355 a( ioff+i ) = czero
356 20 CONTINUE
357 ioff = ioff + izero
358 DO 30 i = izero, n
359 a( ioff ) = czero
360 ioff = ioff + lda
361 30 CONTINUE
362 ELSE
363 ioff = izero
364 DO 40 i = 1, izero - 1
365 a( ioff ) = czero
366 ioff = ioff + lda
367 40 CONTINUE
368 ioff = ioff - izero
369 DO 50 i = izero, n
370 a( ioff+i ) = czero
371 50 CONTINUE
372 END IF
373 ELSE
374 IF( iuplo.EQ.1 ) THEN
375
376
377
378 ioff = 0
379 DO 70 j = 1, n
380 i2 = min( j, izero )
381 DO 60 i = 1, i2
382 a( ioff+i ) = czero
383 60 CONTINUE
384 ioff = ioff + lda
385 70 CONTINUE
386 izero = 1
387 ELSE
388
389
390
391 ioff = 0
392 DO 90 j = 1, n
393 i1 = max( j, izero )
394 DO 80 i = i1, n
395 a( ioff+i ) = czero
396 80 CONTINUE
397 ioff = ioff + lda
398 90 CONTINUE
399 END IF
400 END IF
401 ELSE
402 izero = 0
403 END IF
404
405
406
407
408
409
410 CALL zlaipd( n, a, lda+1, 0 )
411
412
413
414 DO 150 inb = 1, nnb
415
416
417
418
419 nb = nbval( inb )
421
422
423
424
425
426 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
427
428
429
430
431
432
433 srnamt = 'ZHETRF_AA_2STAGE'
434 lwork = min(n*nb, 3*nmax*nmax)
436 $ ainv, (3*nb+1)*n,
437 $ iwork, iwork( 1+n ),
438 $ work, lwork,
439 $ info )
440
441
442
443
444 IF( izero.GT.0 ) THEN
445 j = 1
446 k = izero
447 100 CONTINUE
448 IF( j.EQ.k ) THEN
449 k = iwork( j )
450 ELSE IF( iwork( j ).EQ.k ) THEN
451 k = j
452 END IF
453 IF( j.LT.k ) THEN
454 j = j + 1
455 GO TO 100
456 END IF
457 ELSE
458 k = 0
459 END IF
460
461
462
463 IF( info.NE.k ) THEN
464 CALL alaerh( path,
'ZHETRF_AA_2STAGE', info, k,
465 $ uplo, n, n, -1, -1, nb, imat, nfail,
466 $ nerrs, nout )
467 END IF
468
469
470
471
472
473
474
475
476 nt = 0
477
478
479
480
481
482 DO 110 k = 1, nt
483 IF( result( k ).GE.thresh ) THEN
484 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
485 $
CALL alahd( nout, path )
486 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
487 $ result( k )
488 nfail = nfail + 1
489 END IF
490 110 CONTINUE
491 nrun = nrun + nt
492
493
494
495 IF( info.NE.0 ) THEN
496 GO TO 140
497 END IF
498
499
500
501 DO 130 irhs = 1, nns
502 nrhs = nsval( irhs )
503
504
505
506
507
508
509
510 srnamt = 'ZLARHS'
511 CALL zlarhs( matpath, xtype, uplo,
' ', n, n,
512 $ kl, ku, nrhs, a, lda, xact, lda,
513 $ b, lda, iseed, info )
514 CALL zlacpy(
'Full', n, nrhs, b, lda, x, lda )
515
516 srnamt = 'ZHETRS_AA_2STAGE'
517 lwork = max( 1, 3*n-2 )
519 $ ainv, (3*nb+1)*n, iwork, iwork( 1+n ),
520 $ x, lda, info )
521
522
523
524 IF( info.NE.0 ) THEN
525 IF( izero.EQ.0 ) THEN
526 CALL alaerh( path,
'ZHETRS_AA_2STAGE',
527 $ info, 0, uplo, n, n, -1, -1,
528 $ nrhs, imat, nfail, nerrs, nout )
529 END IF
530 ELSE
531
532 CALL zlacpy(
'Full', n, nrhs, b, lda, work, lda
533 $ )
534
535
536
537 CALL zpot02( uplo, n, nrhs, a, lda, x, lda,
538 $ work, lda, rwork, result( 2 ) )
539
540
541
542
543 DO 120 k = 2, 2
544 IF( result( k ).GE.thresh ) THEN
545 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
546 $
CALL alahd( nout, path )
547 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
548 $ imat, k, result( k )
549 nfail = nfail + 1
550 END IF
551 120 CONTINUE
552 END IF
553 nrun = nrun + 1
554
555
556
557 130 CONTINUE
558 140 CONTINUE
559 150 CONTINUE
560 160 CONTINUE
561 170 CONTINUE
562 180 CONTINUE
563
564
565
566 CALL alasum( path, nout, nfail, nrun, nerrs )
567
568 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
569 $ i2, ', test ', i2, ', ratio =', g12.5 )
570 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
571 $ i2, ', test(', i2, ') =', g12.5 )
572 9995 FORMAT( ' Invalid input value: ', a4, '=', i6, '; must be <=',
573 $ i6 )
574 RETURN
575
576
577
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
subroutine xlaenv(ispec, nvalue)
XLAENV
subroutine zlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
ZLARHS
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
subroutine alahd(iounit, path)
ALAHD
subroutine zhetrf_aa_2stage(uplo, n, a, lda, tb, ltb, ipiv, ipiv2, work, lwork, info)
ZHETRF_AA_2STAGE
subroutine zhetrs_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, info)
ZHETRS_AA_2STAGE
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zerrhe(path, nunit)
ZERRHE
subroutine zlaipd(n, a, inda, vinda)
ZLAIPD
subroutine zlatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
ZLATB4
subroutine zlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
ZLATMS
subroutine zpot02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZPOT02