164
165
166
167
168
169
170 LOGICAL TSTERR
171 INTEGER NMAX, NN, NOUT, NRHS
172 REAL THRESH
173
174
175 LOGICAL DOTYPE( * )
176 INTEGER IWORK( * ), NVAL( * )
177 REAL RWORK( * ), S( * )
178 COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ),
179 $ BSAV( * ), WORK( * ), X( * ), XACT( * )
180
181
182
183
184
185 REAL ONE, ZERO
186 parameter( one = 1.0e+0, zero = 0.0e+0 )
187 INTEGER NTYPES
188 parameter( ntypes = 11 )
189 INTEGER NTESTS
190 parameter( ntests = 7 )
191 INTEGER NTRAN
192 parameter( ntran = 3 )
193
194
195 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
196 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
197 CHARACTER*3 PATH
198 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, ITRAN,
199 $ IZERO, K, K1, KL, KU, LDA, LWORK, MODE, N, NB,
200 $ NBMIN, NERRS, NFACT, NFAIL, NIMAT, NRUN, NT
201 REAL AINVNM, AMAX, ANORM, ANORMI, ANORMO, CNDNUM,
202 $ COLCND, RCOND, RCONDC, RCONDI, RCONDO, ROLDC,
203 $ ROLDI, ROLDO, ROWCND, RPVGRW
204
205
206 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
207 INTEGER ISEED( 4 ), ISEEDY( 4 )
208 REAL RDUM( 1 ), RESULT( NTESTS )
209
210
211 LOGICAL LSAME
212 REAL CLANGE, CLANTR, SGET06, SLAMCH
214
215
220
221
222 INTRINSIC abs, cmplx, max
223
224
225 LOGICAL LERR, OK
226 CHARACTER*32 SRNAMT
227 INTEGER INFOT, NUNIT
228
229
230 COMMON / infoc / infot, nunit, ok, lerr
231 COMMON / srnamc / srnamt
232
233
234 DATA iseedy / 1988, 1989, 1990, 1991 /
235 DATA transs / 'N', 'T', 'C' /
236 DATA facts / 'F', 'N', 'E' /
237 DATA equeds / 'N', 'R', 'C', 'B' /
238
239
240
241
242
243 path( 1: 1 ) = 'Complex precision'
244 path( 2: 3 ) = 'GE'
245 nrun = 0
246 nfail = 0
247 nerrs = 0
248 DO 10 i = 1, 4
249 iseed( i ) = iseedy( i )
250 10 CONTINUE
251
252
253
254 IF( tsterr )
255 $
CALL cerrvx( path, nout )
256 infot = 0
257
258
259
260 nb = 1
261 nbmin = 2
264
265
266
267 DO 90 in = 1, nn
268 n = nval( in )
269 lda = max( n, 1 )
270 xtype = 'N'
271 nimat = ntypes
272 IF( n.LE.0 )
273 $ nimat = 1
274
275 DO 80 imat = 1, nimat
276
277
278
279 IF( .NOT.dotype( imat ) )
280 $ GO TO 80
281
282
283
284 zerot = imat.GE.5 .AND. imat.LE.7
285 IF( zerot .AND. n.LT.imat-4 )
286 $ GO TO 80
287
288
289
290
291 CALL clatb4( path, imat, n, n,
TYPE, KL, KU, ANORM, MODE,
292 $ CNDNUM, DIST )
293 rcondc = one / cndnum
294
295 srnamt = 'CLATMS'
296 CALL clatms( n, n, dist, iseed,
TYPE, RWORK, MODE, CNDNUM,
297 $ ANORM, KL, KU, 'No packing', A, LDA, WORK,
298 $ INFO )
299
300
301
302 IF( info.NE.0 ) THEN
303 CALL alaerh( path,
'CLATMS', info, 0,
' ', n, n, -1, -1,
304 $ -1, imat, nfail, nerrs, nout )
305 GO TO 80
306 END IF
307
308
309
310
311 IF( zerot ) THEN
312 IF( imat.EQ.5 ) THEN
313 izero = 1
314 ELSE IF( imat.EQ.6 ) THEN
315 izero = n
316 ELSE
317 izero = n / 2 + 1
318 END IF
319 ioff = ( izero-1 )*lda
320 IF( imat.LT.7 ) THEN
321 DO 20 i = 1, n
322 a( ioff+i ) = zero
323 20 CONTINUE
324 ELSE
325 CALL claset(
'Full', n, n-izero+1, cmplx( zero ),
326 $ cmplx( zero ), a( ioff+1 ), lda )
327 END IF
328 ELSE
329 izero = 0
330 END IF
331
332
333
334 CALL clacpy(
'Full', n, n, a, lda, asav, lda )
335
336 DO 70 iequed = 1, 4
337 equed = equeds( iequed )
338 IF( iequed.EQ.1 ) THEN
339 nfact = 3
340 ELSE
341 nfact = 1
342 END IF
343
344 DO 60 ifact = 1, nfact
345 fact = facts( ifact )
346 prefac =
lsame( fact,
'F' )
347 nofact =
lsame( fact,
'N' )
348 equil =
lsame( fact,
'E' )
349
350 IF( zerot ) THEN
351 IF( prefac )
352 $ GO TO 60
353 rcondo = zero
354 rcondi = zero
355
356 ELSE IF( .NOT.nofact ) THEN
357
358
359
360
361
362
363 CALL clacpy(
'Full', n, n, asav, lda, afac, lda )
364 IF( equil .OR. iequed.GT.1 ) THEN
365
366
367
368
369 CALL cgeequ( n, n, afac, lda, s, s( n+1 ),
370 $ rowcnd, colcnd, amax, info )
371 IF( info.EQ.0 .AND. n.GT.0 ) THEN
372 IF(
lsame( equed,
'R' ) )
THEN
373 rowcnd = zero
374 colcnd = one
375 ELSE IF(
lsame( equed,
'C' ) )
THEN
376 rowcnd = one
377 colcnd = zero
378 ELSE IF(
lsame( equed,
'B' ) )
THEN
379 rowcnd = zero
380 colcnd = zero
381 END IF
382
383
384
385 CALL claqge( n, n, afac, lda, s, s( n+1 ),
386 $ rowcnd, colcnd, amax, equed )
387 END IF
388 END IF
389
390
391
392
393 IF( equil ) THEN
394 roldo = rcondo
395 roldi = rcondi
396 END IF
397
398
399
400 anormo =
clange(
'1', n, n, afac, lda, rwork )
401 anormi =
clange(
'I', n, n, afac, lda, rwork )
402
403
404
405 srnamt = 'CGETRF'
406 CALL cgetrf( n, n, afac, lda, iwork, info )
407
408
409
410 CALL clacpy(
'Full', n, n, afac, lda, a, lda )
411 lwork = nmax*max( 3, nrhs )
412 srnamt = 'CGETRI'
413 CALL cgetri( n, a, lda, iwork, work, lwork, info )
414
415
416
417 ainvnm =
clange(
'1', n, n, a, lda, rwork )
418 IF( anormo.LE.zero .OR. ainvnm.LE.zero ) THEN
419 rcondo = one
420 ELSE
421 rcondo = ( one / anormo ) / ainvnm
422 END IF
423
424
425
426 ainvnm =
clange(
'I', n, n, a, lda, rwork )
427 IF( anormi.LE.zero .OR. ainvnm.LE.zero ) THEN
428 rcondi = one
429 ELSE
430 rcondi = ( one / anormi ) / ainvnm
431 END IF
432 END IF
433
434 DO 50 itran = 1, ntran
435
436
437
438 trans = transs( itran )
439 IF( itran.EQ.1 ) THEN
440 rcondc = rcondo
441 ELSE
442 rcondc = rcondi
443 END IF
444
445
446
447 CALL clacpy(
'Full', n, n, asav, lda, a, lda )
448
449
450
451 srnamt = 'CLARHS'
452 CALL clarhs( path, xtype,
'Full', trans, n, n, kl,
453 $ ku, nrhs, a, lda, xact, lda, b, lda,
454 $ iseed, info )
455 xtype = 'C'
456 CALL clacpy(
'Full', n, nrhs, b, lda, bsav, lda )
457
458 IF( nofact .AND. itran.EQ.1 ) THEN
459
460
461
462
463
464
465 CALL clacpy(
'Full', n, n, a, lda, afac, lda )
466 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
467
468 srnamt = 'CGESV '
469 CALL cgesv( n, nrhs, afac, lda, iwork, x, lda,
470 $ info )
471
472
473
474 IF( info.NE.izero )
475 $
CALL alaerh( path,
'CGESV ', info, izero,
476 $ ' ', n, n, -1, -1, nrhs, imat,
477 $ nfail, nerrs, nout )
478
479
480
481
482 CALL cget01( n, n, a, lda, afac, lda, iwork,
483 $ rwork, result( 1 ) )
484 nt = 1
485 IF( izero.EQ.0 ) THEN
486
487
488
489 CALL clacpy(
'Full', n, nrhs, b, lda, work,
490 $ lda )
491 CALL cget02(
'No transpose', n, n, nrhs, a,
492 $ lda, x, lda, work, lda, rwork,
493 $ result( 2 ) )
494
495
496
497 CALL cget04( n, nrhs, x, lda, xact, lda,
498 $ rcondc, result( 3 ) )
499 nt = 3
500 END IF
501
502
503
504
505 DO 30 k = 1, nt
506 IF( result( k ).GE.thresh ) THEN
507 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
508 $
CALL aladhd( nout, path )
509 WRITE( nout, fmt = 9999 )'CGESV ', n,
510 $ imat, k, result( k )
511 nfail = nfail + 1
512 END IF
513 30 CONTINUE
514 nrun = nrun + nt
515 END IF
516
517
518
519 IF( .NOT.prefac )
520 $
CALL claset(
'Full', n, n, cmplx( zero ),
521 $ cmplx( zero ), afac, lda )
522 CALL claset(
'Full', n, nrhs, cmplx( zero ),
523 $ cmplx( zero ), x, lda )
524 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
525
526
527
528
529 CALL claqge( n, n, a, lda, s, s( n+1 ), rowcnd,
530 $ colcnd, amax, equed )
531 END IF
532
533
534
535
536 srnamt = 'CGESVX'
537 CALL cgesvx( fact, trans, n, nrhs, a, lda, afac,
538 $ lda, iwork, equed, s, s( n+1 ), b,
539 $ lda, x, lda, rcond, rwork,
540 $ rwork( nrhs+1 ), work,
541 $ rwork( 2*nrhs+1 ), info )
542
543
544
545 IF( info.NE.izero )
546 $
CALL alaerh( path,
'CGESVX', info, izero,
547 $ fact // trans, n, n, -1, -1, nrhs,
548 $ imat, nfail, nerrs, nout )
549
550
551
552
553 IF( info.NE.0 .AND. info.LE.n) THEN
554 rpvgrw =
clantr(
'M',
'U',
'N', info, info,
555 $ afac, lda, rdum )
556 IF( rpvgrw.EQ.zero ) THEN
557 rpvgrw = one
558 ELSE
559 rpvgrw =
clange(
'M', n, info, a, lda,
560 $ rdum ) / rpvgrw
561 END IF
562 ELSE
563 rpvgrw =
clantr(
'M',
'U',
'N', n, n, afac, lda,
564 $ rdum )
565 IF( rpvgrw.EQ.zero ) THEN
566 rpvgrw = one
567 ELSE
568 rpvgrw =
clange(
'M', n, n, a, lda, rdum ) /
569 $ rpvgrw
570 END IF
571 END IF
572 result( 7 ) = abs( rpvgrw-rwork( 2*nrhs+1 ) ) /
573 $ max( rwork( 2*nrhs+1 ), rpvgrw ) /
575
576 IF( .NOT.prefac ) THEN
577
578
579
580
581 CALL cget01( n, n, a, lda, afac, lda, iwork,
582 $ rwork( 2*nrhs+1 ), result( 1 ) )
583 k1 = 1
584 ELSE
585 k1 = 2
586 END IF
587
588 IF( info.EQ.0 ) THEN
589 trfcon = .false.
590
591
592
593 CALL clacpy(
'Full', n, nrhs, bsav, lda, work,
594 $ lda )
595 CALL cget02( trans, n, n, nrhs, asav, lda, x,
596 $ lda, work, lda, rwork( 2*nrhs+1 ),
597 $ result( 2 ) )
598
599
600
601 IF( nofact .OR. ( prefac .AND.
lsame( equed,
602 $ 'N' ) ) ) THEN
603 CALL cget04( n, nrhs, x, lda, xact, lda,
604 $ rcondc, result( 3 ) )
605 ELSE
606 IF( itran.EQ.1 ) THEN
607 roldc = roldo
608 ELSE
609 roldc = roldi
610 END IF
611 CALL cget04( n, nrhs, x, lda, xact, lda,
612 $ roldc, result( 3 ) )
613 END IF
614
615
616
617
618 CALL cget07( trans, n, nrhs, asav, lda, b, lda,
619 $ x, lda, xact, lda, rwork, .true.,
620 $ rwork( nrhs+1 ), result( 4 ) )
621 ELSE
622 trfcon = .true.
623 END IF
624
625
626
627
628 result( 6 ) =
sget06( rcond, rcondc )
629
630
631
632
633 IF( .NOT.trfcon ) THEN
634 DO 40 k = k1, ntests
635 IF( result( k ).GE.thresh ) THEN
636 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
637 $
CALL aladhd( nout, path )
638 IF( prefac ) THEN
639 WRITE( nout, fmt = 9997 )'CGESVX',
640 $ fact, trans, n, equed, imat, k,
641 $ result( k )
642 ELSE
643 WRITE( nout, fmt = 9998 )'CGESVX',
644 $ fact, trans, n, imat, k, result( k )
645 END IF
646 nfail = nfail + 1
647 END IF
648 40 CONTINUE
649 nrun = nrun + ntests - k1 + 1
650 ELSE
651 IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
652 $ THEN
653 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
654 $
CALL aladhd( nout, path )
655 IF( prefac ) THEN
656 WRITE( nout, fmt = 9997 )'CGESVX', fact,
657 $ trans, n, equed, imat, 1, result( 1 )
658 ELSE
659 WRITE( nout, fmt = 9998 )'CGESVX', fact,
660 $ trans, n, imat, 1, result( 1 )
661 END IF
662 nfail = nfail + 1
663 nrun = nrun + 1
664 END IF
665 IF( result( 6 ).GE.thresh ) THEN
666 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
667 $
CALL aladhd( nout, path )
668 IF( prefac ) THEN
669 WRITE( nout, fmt = 9997 )'CGESVX', fact,
670 $ trans, n, equed, imat, 6, result( 6 )
671 ELSE
672 WRITE( nout, fmt = 9998 )'CGESVX', fact,
673 $ trans, n, imat, 6, result( 6 )
674 END IF
675 nfail = nfail + 1
676 nrun = nrun + 1
677 END IF
678 IF( result( 7 ).GE.thresh ) THEN
679 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
680 $
CALL aladhd( nout, path )
681 IF( prefac ) THEN
682 WRITE( nout, fmt = 9997 )'CGESVX', fact,
683 $ trans, n, equed, imat, 7, result( 7 )
684 ELSE
685 WRITE( nout, fmt = 9998 )'CGESVX', fact,
686 $ trans, n, imat, 7, result( 7 )
687 END IF
688 nfail = nfail + 1
689 nrun = nrun + 1
690 END IF
691
692 END IF
693
694 50 CONTINUE
695 60 CONTINUE
696 70 CONTINUE
697 80 CONTINUE
698 90 CONTINUE
699
700
701
702 CALL alasvm( path, nout, nfail, nrun, nerrs )
703
704 9999 FORMAT( 1x, a, ', N =', i5, ', type ', i2, ', test(', i2, ') =',
705 $ g12.5 )
706 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', TRANS=''', a1, ''', N=', i5,
707 $ ', type ', i2, ', test(', i1, ')=', g12.5 )
708 9997 FORMAT( 1x, a, ', FACT=''', a1, ''', TRANS=''', a1, ''', N=', i5,
709 $ ', EQUED=''', a1, ''', type ', i2, ', test(', i1, ')=',
710 $ g12.5 )
711 RETURN
712
713
714
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
subroutine cget02(trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CGET02
subroutine clarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
CLARHS
subroutine xlaenv(ispec, nvalue)
XLAENV
subroutine aladhd(iounit, path)
ALADHD
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
subroutine cerrvx(path, nunit)
CERRVX
subroutine cget01(m, n, a, lda, afac, ldafac, ipiv, rwork, resid)
CGET01
subroutine cget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
CGET04
subroutine cget07(trans, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, chkferr, berr, reslts)
CGET07
subroutine clatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
CLATB4
subroutine clatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
CLATMS
subroutine cgeequ(m, n, a, lda, r, c, rowcnd, colcnd, amax, info)
CGEEQU
subroutine cgesv(n, nrhs, a, lda, ipiv, b, ldb, info)
Download CGESV + dependencies <a href="http://www.netlib.org/cgi-bin/netlibfiles....
subroutine cgesvx(fact, trans, n, nrhs, a, lda, af, ldaf, ipiv, equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
CGESVX computes the solution to system of linear equations A * X = B for GE matrices
subroutine cgetrf(m, n, a, lda, ipiv, info)
CGETRF
subroutine cgetri(n, a, lda, ipiv, work, lwork, info)
CGETRI
subroutine clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
real function slamch(cmach)
SLAMCH
real function clange(norm, m, n, a, lda, work)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
real function clantr(norm, uplo, diag, m, n, a, lda, work)
CLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
subroutine claqge(m, n, a, lda, r, c, rowcnd, colcnd, amax, equed)
CLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ.
subroutine claset(uplo, m, n, alpha, beta, a, lda)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
logical function lsame(ca, cb)
LSAME
real function sget06(rcond, rcondc)
SGET06