OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dblat2.f File Reference

Go to the source code of this file.

Functions/Subroutines

program dblat2
 DBLAT2
subroutine dchk1 (sname, eps, thresh, nout, ntra, trace, rewi, fatal, nidim, idim, nkb, kb, nalf, alf, nbet, bet, ninc, inc, nmax, incmax, a, aa, as, x, xx, xs, y, yy, ys, yt, g)
subroutine dchk2 (sname, eps, thresh, nout, ntra, trace, rewi, fatal, nidim, idim, nkb, kb, nalf, alf, nbet, bet, ninc, inc, nmax, incmax, a, aa, as, x, xx, xs, y, yy, ys, yt, g)
subroutine dchk3 (sname, eps, thresh, nout, ntra, trace, rewi, fatal, nidim, idim, nkb, kb, ninc, inc, nmax, incmax, a, aa, as, x, xx, xs, xt, g, z)
subroutine dchk4 (sname, eps, thresh, nout, ntra, trace, rewi, fatal, nidim, idim, nalf, alf, ninc, inc, nmax, incmax, a, aa, as, x, xx, xs, y, yy, ys, yt, g, z)
subroutine dchk5 (sname, eps, thresh, nout, ntra, trace, rewi, fatal, nidim, idim, nalf, alf, ninc, inc, nmax, incmax, a, aa, as, x, xx, xs, y, yy, ys, yt, g, z)
subroutine dchk6 (sname, eps, thresh, nout, ntra, trace, rewi, fatal, nidim, idim, nalf, alf, ninc, inc, nmax, incmax, a, aa, as, x, xx, xs, y, yy, ys, yt, g, z)
subroutine dchke (isnum, srnamt, nout)
subroutine dmake (type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
subroutine dmvch (trans, m, n, alpha, a, nmax, x, incx, beta, y, incy, yt, g, yy, eps, err, fatal, nout, mv)
logical function lde (ri, rj, lr)
logical function lderes (type, uplo, m, n, aa, as, lda)
double precision function dbeg (reset)
double precision function ddiff (x, y)
subroutine chkxer (srnamt, infot, nout, lerr, ok)
subroutine xerbla (srname, info)

Function/Subroutine Documentation

◆ chkxer()

subroutine chkxer ( character*6 srnamt,
integer infot,
integer nout,
logical lerr,
logical ok )

Definition at line 3092 of file dblat2.f.

3093*
3094* Tests whether XERBLA has detected an error when it should.
3095*
3096* Auxiliary routine for test program for Level 2 Blas.
3097*
3098* -- Written on 10-August-1987.
3099* Richard Hanson, Sandia National Labs.
3100* Jeremy Du Croz, NAG Central Office.
3101*
3102* .. Scalar Arguments ..
3103 INTEGER INFOT, NOUT
3104 LOGICAL LERR, OK
3105 CHARACTER*6 SRNAMT
3106* .. Executable Statements ..
3107 IF( .NOT.lerr )THEN
3108 WRITE( nout, fmt = 9999 )infot, srnamt
3109 ok = .false.
3110 END IF
3111 lerr = .false.
3112 RETURN
3113*
3114 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', i2, ' NOT D',
3115 $ 'ETECTED BY ', a6, ' *****' )
3116*
3117* End of CHKXER
3118*

◆ dbeg()

double precision function dbeg ( logical reset)

Definition at line 3030 of file dblat2.f.

3031*
3032* Generates random numbers uniformly distributed between -0.5 and 0.5.
3033*
3034* Auxiliary routine for test program for Level 2 Blas.
3035*
3036* -- Written on 10-August-1987.
3037* Richard Hanson, Sandia National Labs.
3038* Jeremy Du Croz, NAG Central Office.
3039*
3040* .. Scalar Arguments ..
3041 LOGICAL RESET
3042* .. Local Scalars ..
3043 INTEGER I, IC, MI
3044* .. Save statement ..
3045 SAVE i, ic, mi
3046* .. Intrinsic Functions ..
3047 INTRINSIC dble
3048* .. Executable Statements ..
3049 IF( reset )THEN
3050* Initialize local variables.
3051 mi = 891
3052 i = 7
3053 ic = 0
3054 reset = .false.
3055 END IF
3056*
3057* The sequence of values of I is bounded between 1 and 999.
3058* If initial I = 1,2,3,6,7 or 9, the period will be 50.
3059* If initial I = 4 or 8, the period will be 25.
3060* If initial I = 5, the period will be 10.
3061* IC is used to break up the period by skipping 1 value of I in 6.
3062*
3063 ic = ic + 1
3064 10 i = i*mi
3065 i = i - 1000*( i/1000 )
3066 IF( ic.GE.5 )THEN
3067 ic = 0
3068 GO TO 10
3069 END IF
3070 dbeg = dble( i - 500 )/1001.0d0
3071 RETURN
3072*
3073* End of DBEG
3074*
dbeg
double precision function dbeg(reset)
Definition dblat2.f:3031

◆ dchk1()

subroutine dchk1 ( character*6 sname,
double precision eps,
double precision thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nkb,
integer, dimension( nkb ) kb,
integer nalf,
double precision, dimension( nalf ) alf,
integer nbet,
double precision, dimension( nbet ) bet,
integer ninc,
integer, dimension( ninc ) inc,
integer nmax,
integer incmax,
double precision, dimension( nmax, nmax ) a,
double precision, dimension( nmax*nmax ) aa,
double precision, dimension( nmax*nmax ) as,
double precision, dimension( nmax ) x,
double precision, dimension( nmax*incmax ) xx,
double precision, dimension( nmax*incmax ) xs,
double precision, dimension( nmax ) y,
double precision, dimension( nmax*incmax ) yy,
double precision, dimension( nmax*incmax ) ys,
double precision, dimension( nmax ) yt,
double precision, dimension( nmax ) g )

Definition at line 427 of file dblat2.f.

431*
432* Tests DGEMV and DGBMV.
433*
434* Auxiliary routine for test program for Level 2 Blas.
435*
436* -- Written on 10-August-1987.
437* Richard Hanson, Sandia National Labs.
438* Jeremy Du Croz, NAG Central Office.
439*
440* .. Parameters ..
441 DOUBLE PRECISION ZERO, HALF
442 parameter( zero = 0.0d0, half = 0.5d0 )
443* .. Scalar Arguments ..
444 DOUBLE PRECISION EPS, THRESH
445 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
446 $ NOUT, NTRA
447 LOGICAL FATAL, REWI, TRACE
448 CHARACTER*6 SNAME
449* .. Array Arguments ..
450 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
451 $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
452 $ X( NMAX ), XS( NMAX*INCMAX ),
453 $ XX( NMAX*INCMAX ), Y( NMAX ),
454 $ YS( NMAX*INCMAX ), YT( NMAX ),
455 $ YY( NMAX*INCMAX )
456 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
457* .. Local Scalars ..
458 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
459 INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
460 $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA,
461 $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK,
462 $ NL, NS
463 LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN
464 CHARACTER*1 TRANS, TRANSS
465 CHARACTER*3 ICH
466* .. Local Arrays ..
467 LOGICAL ISAME( 13 )
468* .. External Functions ..
469 LOGICAL LDE, LDERES
470 EXTERNAL lde, lderes
471* .. External Subroutines ..
472 EXTERNAL dgbmv, dgemv, dmake, dmvch
473* .. Intrinsic Functions ..
474 INTRINSIC abs, max, min
475* .. Scalars in Common ..
476 INTEGER INFOT, NOUTC
477 LOGICAL LERR, OK
478* .. Common blocks ..
479 COMMON /infoc/infot, noutc, ok, lerr
480* .. Data statements ..
481 DATA ich/'NTC'/
482* .. Executable Statements ..
483 full = sname( 3: 3 ).EQ.'E'
484 banded = sname( 3: 3 ).EQ.'B'
485* Define the number of arguments.
486 IF( full )THEN
487 nargs = 11
488 ELSE IF( banded )THEN
489 nargs = 13
490 END IF
491*
492 nc = 0
493 reset = .true.
494 errmax = zero
495*
496 DO 120 in = 1, nidim
497 n = idim( in )
498 nd = n/2 + 1
499*
500 DO 110 im = 1, 2
501 IF( im.EQ.1 )
502 $ m = max( n - nd, 0 )
503 IF( im.EQ.2 )
504 $ m = min( n + nd, nmax )
505*
506 IF( banded )THEN
507 nk = nkb
508 ELSE
509 nk = 1
510 END IF
511 DO 100 iku = 1, nk
512 IF( banded )THEN
513 ku = kb( iku )
514 kl = max( ku - 1, 0 )
515 ELSE
516 ku = n - 1
517 kl = m - 1
518 END IF
519* Set LDA to 1 more than minimum value if room.
520 IF( banded )THEN
521 lda = kl + ku + 1
522 ELSE
523 lda = m
524 END IF
525 IF( lda.LT.nmax )
526 $ lda = lda + 1
527* Skip tests if not enough room.
528 IF( lda.GT.nmax )
529 $ GO TO 100
530 laa = lda*n
531 null = n.LE.0.OR.m.LE.0
532*
533* Generate the matrix A.
534*
535 transl = zero
536 CALL dmake( sname( 2: 3 ), ' ', ' ', m, n, a, nmax, aa,
537 $ lda, kl, ku, reset, transl )
538*
539 DO 90 ic = 1, 3
540 trans = ich( ic: ic )
541 tran = trans.EQ.'T'.OR.trans.EQ.'C'
542*
543 IF( tran )THEN
544 ml = n
545 nl = m
546 ELSE
547 ml = m
548 nl = n
549 END IF
550*
551 DO 80 ix = 1, ninc
552 incx = inc( ix )
553 lx = abs( incx )*nl
554*
555* Generate the vector X.
556*
557 transl = half
558 CALL dmake( 'GE', ' ', ' ', 1, nl, x, 1, xx,
559 $ abs( incx ), 0, nl - 1, reset, transl )
560 IF( nl.GT.1 )THEN
561 x( nl/2 ) = zero
562 xx( 1 + abs( incx )*( nl/2 - 1 ) ) = zero
563 END IF
564*
565 DO 70 iy = 1, ninc
566 incy = inc( iy )
567 ly = abs( incy )*ml
568*
569 DO 60 ia = 1, nalf
570 alpha = alf( ia )
571*
572 DO 50 ib = 1, nbet
573 beta = bet( ib )
574*
575* Generate the vector Y.
576*
577 transl = zero
578 CALL dmake( 'GE', ' ', ' ', 1, ml, y, 1,
579 $ yy, abs( incy ), 0, ml - 1,
580 $ reset, transl )
581*
582 nc = nc + 1
583*
584* Save every datum before calling the
585* subroutine.
586*
587 transs = trans
588 ms = m
589 ns = n
590 kls = kl
591 kus = ku
592 als = alpha
593 DO 10 i = 1, laa
594 as( i ) = aa( i )
595 10 CONTINUE
596 ldas = lda
597 DO 20 i = 1, lx
598 xs( i ) = xx( i )
599 20 CONTINUE
600 incxs = incx
601 bls = beta
602 DO 30 i = 1, ly
603 ys( i ) = yy( i )
604 30 CONTINUE
605 incys = incy
606*
607* Call the subroutine.
608*
609 IF( full )THEN
610 IF( trace )
611 $ WRITE( ntra, fmt = 9994 )nc, sname,
612 $ trans, m, n, alpha, lda, incx, beta,
613 $ incy
614 IF( rewi )
615 $ rewind ntra
616 CALL dgemv( trans, m, n, alpha, aa,
617 $ lda, xx, incx, beta, yy,
618 $ incy )
619 ELSE IF( banded )THEN
620 IF( trace )
621 $ WRITE( ntra, fmt = 9995 )nc, sname,
622 $ trans, m, n, kl, ku, alpha, lda,
623 $ incx, beta, incy
624 IF( rewi )
625 $ rewind ntra
626 CALL dgbmv( trans, m, n, kl, ku, alpha,
627 $ aa, lda, xx, incx, beta,
628 $ yy, incy )
629 END IF
630*
631* Check if error-exit was taken incorrectly.
632*
633 IF( .NOT.ok )THEN
634 WRITE( nout, fmt = 9993 )
635 fatal = .true.
636 GO TO 130
637 END IF
638*
639* See what data changed inside subroutines.
640*
641 isame( 1 ) = trans.EQ.transs
642 isame( 2 ) = ms.EQ.m
643 isame( 3 ) = ns.EQ.n
644 IF( full )THEN
645 isame( 4 ) = als.EQ.alpha
646 isame( 5 ) = lde( as, aa, laa )
647 isame( 6 ) = ldas.EQ.lda
648 isame( 7 ) = lde( xs, xx, lx )
649 isame( 8 ) = incxs.EQ.incx
650 isame( 9 ) = bls.EQ.beta
651 IF( null )THEN
652 isame( 10 ) = lde( ys, yy, ly )
653 ELSE
654 isame( 10 ) = lderes( 'GE', ' ', 1,
655 $ ml, ys, yy,
656 $ abs( incy ) )
657 END IF
658 isame( 11 ) = incys.EQ.incy
659 ELSE IF( banded )THEN
660 isame( 4 ) = kls.EQ.kl
661 isame( 5 ) = kus.EQ.ku
662 isame( 6 ) = als.EQ.alpha
663 isame( 7 ) = lde( as, aa, laa )
664 isame( 8 ) = ldas.EQ.lda
665 isame( 9 ) = lde( xs, xx, lx )
666 isame( 10 ) = incxs.EQ.incx
667 isame( 11 ) = bls.EQ.beta
668 IF( null )THEN
669 isame( 12 ) = lde( ys, yy, ly )
670 ELSE
671 isame( 12 ) = lderes( 'GE', ' ', 1,
672 $ ml, ys, yy,
673 $ abs( incy ) )
674 END IF
675 isame( 13 ) = incys.EQ.incy
676 END IF
677*
678* If data was incorrectly changed, report
679* and return.
680*
681 same = .true.
682 DO 40 i = 1, nargs
683 same = same.AND.isame( i )
684 IF( .NOT.isame( i ) )
685 $ WRITE( nout, fmt = 9998 )i
686 40 CONTINUE
687 IF( .NOT.same )THEN
688 fatal = .true.
689 GO TO 130
690 END IF
691*
692 IF( .NOT.null )THEN
693*
694* Check the result.
695*
696 CALL dmvch( trans, m, n, alpha, a,
697 $ nmax, x, incx, beta, y,
698 $ incy, yt, g, yy, eps, err,
699 $ fatal, nout, .true. )
700 errmax = max( errmax, err )
701* If got really bad answer, report and
702* return.
703 IF( fatal )
704 $ GO TO 130
705 ELSE
706* Avoid repeating tests with M.le.0 or
707* N.le.0.
708 GO TO 110
709 END IF
710*
711 50 CONTINUE
712*
713 60 CONTINUE
714*
715 70 CONTINUE
716*
717 80 CONTINUE
718*
719 90 CONTINUE
720*
721 100 CONTINUE
722*
723 110 CONTINUE
724*
725 120 CONTINUE
726*
727* Report result.
728*
729 IF( errmax.LT.thresh )THEN
730 WRITE( nout, fmt = 9999 )sname, nc
731 ELSE
732 WRITE( nout, fmt = 9997 )sname, nc, errmax
733 END IF
734 GO TO 140
735*
736 130 CONTINUE
737 WRITE( nout, fmt = 9996 )sname
738 IF( full )THEN
739 WRITE( nout, fmt = 9994 )nc, sname, trans, m, n, alpha, lda,
740 $ incx, beta, incy
741 ELSE IF( banded )THEN
742 WRITE( nout, fmt = 9995 )nc, sname, trans, m, n, kl, ku,
743 $ alpha, lda, incx, beta, incy
744 END IF
745*
746 140 CONTINUE
747 RETURN
748*
749 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
750 $ 'S)' )
751 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
752 $ 'ANGED INCORRECTLY *******' )
753 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
754 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
755 $ ' - SUSPECT *******' )
756 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
757 9995 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', 4( i3, ',' ), f4.1,
758 $ ', A,', i3, ', X,', i2, ',', f4.1, ', Y,', i2, ') .' )
759 9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', 2( i3, ',' ), f4.1,
760 $ ', A,', i3, ', X,', i2, ',', f4.1, ', Y,', i2,
761 $ ') .' )
762 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
763 $ '******' )
764*
765* End of DCHK1
766*
dmvch
subroutine dmvch(trans, m, n, alpha, a, nmax, x, incx, beta, y, incy, yt, g, yy, eps, err, fatal, nout, mv)
Definition dblat2.f:2826
lde
logical function lde(ri, rj, lr)
Definition dblat2.f:2942
lderes
logical function lderes(type, uplo, m, n, aa, as, lda)
Definition dblat2.f:2972
dmake
subroutine dmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition dblat2.f:2650
alpha
#define alpha
Definition eval.h:35
dgemv
subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
DGEMV
Definition dgemv.f:156
dgbmv
subroutine dgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy)
DGBMV
Definition dgbmv.f:185
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
nl
character *2 function nl()
Definition message.F:2354
fatal
void fatal(char *msg)
Definition sys_pipes_c.c:76

◆ dchk2()

subroutine dchk2 ( character*6 sname,
double precision eps,
double precision thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nkb,
integer, dimension( nkb ) kb,
integer nalf,
double precision, dimension( nalf ) alf,
integer nbet,
double precision, dimension( nbet ) bet,
integer ninc,
integer, dimension( ninc ) inc,
integer nmax,
integer incmax,
double precision, dimension( nmax, nmax ) a,
double precision, dimension( nmax*nmax ) aa,
double precision, dimension( nmax*nmax ) as,
double precision, dimension( nmax ) x,
double precision, dimension( nmax*incmax ) xx,
double precision, dimension( nmax*incmax ) xs,
double precision, dimension( nmax ) y,
double precision, dimension( nmax*incmax ) yy,
double precision, dimension( nmax*incmax ) ys,
double precision, dimension( nmax ) yt,
double precision, dimension( nmax ) g )

Definition at line 768 of file dblat2.f.

772*
773* Tests DSYMV, DSBMV and DSPMV.
774*
775* Auxiliary routine for test program for Level 2 Blas.
776*
777* -- Written on 10-August-1987.
778* Richard Hanson, Sandia National Labs.
779* Jeremy Du Croz, NAG Central Office.
780*
781* .. Parameters ..
782 DOUBLE PRECISION ZERO, HALF
783 parameter( zero = 0.0d0, half = 0.5d0 )
784* .. Scalar Arguments ..
785 DOUBLE PRECISION EPS, THRESH
786 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
787 $ NOUT, NTRA
788 LOGICAL FATAL, REWI, TRACE
789 CHARACTER*6 SNAME
790* .. Array Arguments ..
791 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
792 $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
793 $ X( NMAX ), XS( NMAX*INCMAX ),
794 $ XX( NMAX*INCMAX ), Y( NMAX ),
795 $ YS( NMAX*INCMAX ), YT( NMAX ),
796 $ YY( NMAX*INCMAX )
797 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
798* .. Local Scalars ..
799 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
800 INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
801 $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY,
802 $ N, NARGS, NC, NK, NS
803 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
804 CHARACTER*1 UPLO, UPLOS
805 CHARACTER*2 ICH
806* .. Local Arrays ..
807 LOGICAL ISAME( 13 )
808* .. External Functions ..
809 LOGICAL LDE, LDERES
810 EXTERNAL lde, lderes
811* .. External Subroutines ..
812 EXTERNAL dmake, dmvch, dsbmv, dspmv, dsymv
813* .. Intrinsic Functions ..
814 INTRINSIC abs, max
815* .. Scalars in Common ..
816 INTEGER INFOT, NOUTC
817 LOGICAL LERR, OK
818* .. Common blocks ..
819 COMMON /infoc/infot, noutc, ok, lerr
820* .. Data statements ..
821 DATA ich/'UL'/
822* .. Executable Statements ..
823 full = sname( 3: 3 ).EQ.'Y'
824 banded = sname( 3: 3 ).EQ.'B'
825 packed = sname( 3: 3 ).EQ.'P'
826* Define the number of arguments.
827 IF( full )THEN
828 nargs = 10
829 ELSE IF( banded )THEN
830 nargs = 11
831 ELSE IF( packed )THEN
832 nargs = 9
833 END IF
834*
835 nc = 0
836 reset = .true.
837 errmax = zero
838*
839 DO 110 in = 1, nidim
840 n = idim( in )
841*
842 IF( banded )THEN
843 nk = nkb
844 ELSE
845 nk = 1
846 END IF
847 DO 100 ik = 1, nk
848 IF( banded )THEN
849 k = kb( ik )
850 ELSE
851 k = n - 1
852 END IF
853* Set LDA to 1 more than minimum value if room.
854 IF( banded )THEN
855 lda = k + 1
856 ELSE
857 lda = n
858 END IF
859 IF( lda.LT.nmax )
860 $ lda = lda + 1
861* Skip tests if not enough room.
862 IF( lda.GT.nmax )
863 $ GO TO 100
864 IF( packed )THEN
865 laa = ( n*( n + 1 ) )/2
866 ELSE
867 laa = lda*n
868 END IF
869 null = n.LE.0
870*
871 DO 90 ic = 1, 2
872 uplo = ich( ic: ic )
873*
874* Generate the matrix A.
875*
876 transl = zero
877 CALL dmake( sname( 2: 3 ), uplo, ' ', n, n, a, nmax, aa,
878 $ lda, k, k, reset, transl )
879*
880 DO 80 ix = 1, ninc
881 incx = inc( ix )
882 lx = abs( incx )*n
883*
884* Generate the vector X.
885*
886 transl = half
887 CALL dmake( 'GE', ' ', ' ', 1, n, x, 1, xx,
888 $ abs( incx ), 0, n - 1, reset, transl )
889 IF( n.GT.1 )THEN
890 x( n/2 ) = zero
891 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
892 END IF
893*
894 DO 70 iy = 1, ninc
895 incy = inc( iy )
896 ly = abs( incy )*n
897*
898 DO 60 ia = 1, nalf
899 alpha = alf( ia )
900*
901 DO 50 ib = 1, nbet
902 beta = bet( ib )
903*
904* Generate the vector Y.
905*
906 transl = zero
907 CALL dmake( 'GE', ' ', ' ', 1, n, y, 1, yy,
908 $ abs( incy ), 0, n - 1, reset,
909 $ transl )
910*
911 nc = nc + 1
912*
913* Save every datum before calling the
914* subroutine.
915*
916 uplos = uplo
917 ns = n
918 ks = k
919 als = alpha
920 DO 10 i = 1, laa
921 as( i ) = aa( i )
922 10 CONTINUE
923 ldas = lda
924 DO 20 i = 1, lx
925 xs( i ) = xx( i )
926 20 CONTINUE
927 incxs = incx
928 bls = beta
929 DO 30 i = 1, ly
930 ys( i ) = yy( i )
931 30 CONTINUE
932 incys = incy
933*
934* Call the subroutine.
935*
936 IF( full )THEN
937 IF( trace )
938 $ WRITE( ntra, fmt = 9993 )nc, sname,
939 $ uplo, n, alpha, lda, incx, beta, incy
940 IF( rewi )
941 $ rewind ntra
942 CALL dsymv( uplo, n, alpha, aa, lda, xx,
943 $ incx, beta, yy, incy )
944 ELSE IF( banded )THEN
945 IF( trace )
946 $ WRITE( ntra, fmt = 9994 )nc, sname,
947 $ uplo, n, k, alpha, lda, incx, beta,
948 $ incy
949 IF( rewi )
950 $ rewind ntra
951 CALL dsbmv( uplo, n, k, alpha, aa, lda,
952 $ xx, incx, beta, yy, incy )
953 ELSE IF( packed )THEN
954 IF( trace )
955 $ WRITE( ntra, fmt = 9995 )nc, sname,
956 $ uplo, n, alpha, incx, beta, incy
957 IF( rewi )
958 $ rewind ntra
959 CALL dspmv( uplo, n, alpha, aa, xx, incx,
960 $ beta, yy, incy )
961 END IF
962*
963* Check if error-exit was taken incorrectly.
964*
965 IF( .NOT.ok )THEN
966 WRITE( nout, fmt = 9992 )
967 fatal = .true.
968 GO TO 120
969 END IF
970*
971* See what data changed inside subroutines.
972*
973 isame( 1 ) = uplo.EQ.uplos
974 isame( 2 ) = ns.EQ.n
975 IF( full )THEN
976 isame( 3 ) = als.EQ.alpha
977 isame( 4 ) = lde( as, aa, laa )
978 isame( 5 ) = ldas.EQ.lda
979 isame( 6 ) = lde( xs, xx, lx )
980 isame( 7 ) = incxs.EQ.incx
981 isame( 8 ) = bls.EQ.beta
982 IF( null )THEN
983 isame( 9 ) = lde( ys, yy, ly )
984 ELSE
985 isame( 9 ) = lderes( 'GE', ' ', 1, n,
986 $ ys, yy, abs( incy ) )
987 END IF
988 isame( 10 ) = incys.EQ.incy
989 ELSE IF( banded )THEN
990 isame( 3 ) = ks.EQ.k
991 isame( 4 ) = als.EQ.alpha
992 isame( 5 ) = lde( as, aa, laa )
993 isame( 6 ) = ldas.EQ.lda
994 isame( 7 ) = lde( xs, xx, lx )
995 isame( 8 ) = incxs.EQ.incx
996 isame( 9 ) = bls.EQ.beta
997 IF( null )THEN
998 isame( 10 ) = lde( ys, yy, ly )
999 ELSE
1000 isame( 10 ) = lderes( 'GE', ' ', 1, n,
1001 $ ys, yy, abs( incy ) )
1002 END IF
1003 isame( 11 ) = incys.EQ.incy
1004 ELSE IF( packed )THEN
1005 isame( 3 ) = als.EQ.alpha
1006 isame( 4 ) = lde( as, aa, laa )
1007 isame( 5 ) = lde( xs, xx, lx )
1008 isame( 6 ) = incxs.EQ.incx
1009 isame( 7 ) = bls.EQ.beta
1010 IF( null )THEN
1011 isame( 8 ) = lde( ys, yy, ly )
1012 ELSE
1013 isame( 8 ) = lderes( 'GE', ' ', 1, n,
1014 $ ys, yy, abs( incy ) )
1015 END IF
1016 isame( 9 ) = incys.EQ.incy
1017 END IF
1018*
1019* If data was incorrectly changed, report and
1020* return.
1021*
1022 same = .true.
1023 DO 40 i = 1, nargs
1024 same = same.AND.isame( i )
1025 IF( .NOT.isame( i ) )
1026 $ WRITE( nout, fmt = 9998 )i
1027 40 CONTINUE
1028 IF( .NOT.same )THEN
1029 fatal = .true.
1030 GO TO 120
1031 END IF
1032*
1033 IF( .NOT.null )THEN
1034*
1035* Check the result.
1036*
1037 CALL dmvch( 'N', n, n, alpha, a, nmax, x,
1038 $ incx, beta, y, incy, yt, g,
1039 $ yy, eps, err, fatal, nout,
1040 $ .true. )
1041 errmax = max( errmax, err )
1042* If got really bad answer, report and
1043* return.
1044 IF( fatal )
1045 $ GO TO 120
1046 ELSE
1047* Avoid repeating tests with N.le.0
1048 GO TO 110
1049 END IF
1050*
1051 50 CONTINUE
1052*
1053 60 CONTINUE
1054*
1055 70 CONTINUE
1056*
1057 80 CONTINUE
1058*
1059 90 CONTINUE
1060*
1061 100 CONTINUE
1062*
1063 110 CONTINUE
1064*
1065* Report result.
1066*
1067 IF( errmax.LT.thresh )THEN
1068 WRITE( nout, fmt = 9999 )sname, nc
1069 ELSE
1070 WRITE( nout, fmt = 9997 )sname, nc, errmax
1071 END IF
1072 GO TO 130
1073*
1074 120 CONTINUE
1075 WRITE( nout, fmt = 9996 )sname
1076 IF( full )THEN
1077 WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, lda, incx,
1078 $ beta, incy
1079 ELSE IF( banded )THEN
1080 WRITE( nout, fmt = 9994 )nc, sname, uplo, n, k, alpha, lda,
1081 $ incx, beta, incy
1082 ELSE IF( packed )THEN
1083 WRITE( nout, fmt = 9995 )nc, sname, uplo, n, alpha, incx,
1084 $ beta, incy
1085 END IF
1086*
1087 130 CONTINUE
1088 RETURN
1089*
1090 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' call',
1091 $ 's)' )
1092 9998 FORMAT( ' ******* fatal error - PARAMETER number ', I2, ' was ch',
1093 $ 'anged incorrectly *******' )
1094 9997 FORMAT( ' ', A6, ' completed the computational tests(', I6, ' c',
1095 $ 'alls)', /' ******* but with maximum test ratio', F8.2,
1096 $ ' - suspect *******' )
1097 9996 FORMAT( ' ******* ', A6, ' failed on CALL number:' )
1098 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', ap',
1099 $ ', x,', I2, ',', F4.1, ', y,', I2, ') .' )
1100 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1,
1101 $ ', a,', I3, ', x,', I2, ',', F4.1, ', y,', I2,
1102 $ ') .' )
1103 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', a,',
1104 $ I3, ', x,', I2, ',', F4.1, ', y,', I2, ') .' )
1105 9992 FORMAT( ' ******* fatal error - error-EXIT taken on valid CALL *',
1106 $ '******' )
1107*
1108* End of DCHK2
1109*
the
end diagonal values have been computed in the(sparse) matrix id.SOL
dsymv
subroutine dsymv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
DSYMV
Definition dsymv.f:152
dsbmv
subroutine dsbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
DSBMV
Definition dsbmv.f:184
dspmv
subroutine dspmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
DSPMV
Definition dspmv.f:147

◆ dchk3()

subroutine dchk3 ( character*6 sname,
double precision eps,
double precision thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nkb,
integer, dimension( nkb ) kb,
integer ninc,
integer, dimension( ninc ) inc,
integer nmax,
integer incmax,
double precision, dimension( nmax, nmax ) a,
double precision, dimension( nmax*nmax ) aa,
double precision, dimension( nmax*nmax ) as,
double precision, dimension( nmax ) x,
double precision, dimension( nmax*incmax ) xx,
double precision, dimension( nmax*incmax ) xs,
double precision, dimension( nmax ) xt,
double precision, dimension( nmax ) g,
double precision, dimension( nmax ) z )

Definition at line 1111 of file dblat2.f.

1114*
1115* Tests DTRMV, DTBMV, DTPMV, DTRSV, DTBSV and DTPSV.
1116*
1117* Auxiliary routine for test program for Level 2 Blas.
1118*
1119* -- Written on 10-August-1987.
1120* Richard Hanson, Sandia National Labs.
1121* Jeremy Du Croz, NAG Central Office.
1122*
1123* .. Parameters ..
1124 DOUBLE PRECISION ZERO, HALF, ONE
1125 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0 )
1126* .. Scalar Arguments ..
1127 DOUBLE PRECISION EPS, THRESH
1128 INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA
1129 LOGICAL FATAL, REWI, TRACE
1130 CHARACTER*6 SNAME
1131* .. Array Arguments ..
1132 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ),
1133 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1134 $ XS( NMAX*INCMAX ), XT( NMAX ),
1135 $ XX( NMAX*INCMAX ), Z( NMAX )
1136 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
1137* .. Local Scalars ..
1138 DOUBLE PRECISION ERR, ERRMAX, TRANSL
1139 INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
1140 $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
1141 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
1142 CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
1143 CHARACTER*2 ICHD, ICHU
1144 CHARACTER*3 ICHT
1145* .. Local Arrays ..
1146 LOGICAL ISAME( 13 )
1147* .. External Functions ..
1148 LOGICAL LDE, LDERES
1149 EXTERNAL lde, lderes
1150* .. External Subroutines ..
1151 EXTERNAL dmake, dmvch, dtbmv, dtbsv, dtpmv, dtpsv,
1152 $ dtrmv, dtrsv
1153* .. Intrinsic Functions ..
1154 INTRINSIC abs, max
1155* .. Scalars in Common ..
1156 INTEGER INFOT, NOUTC
1157 LOGICAL LERR, OK
1158* .. Common blocks ..
1159 COMMON /infoc/infot, noutc, ok, lerr
1160* .. Data statements ..
1161 DATA ichu/'UL'/, icht/'NTC'/, ichd/'UN'/
1162* .. Executable Statements ..
1163 full = sname( 3: 3 ).EQ.'R'
1164 banded = sname( 3: 3 ).EQ.'B'
1165 packed = sname( 3: 3 ).EQ.'P'
1166* Define the number of arguments.
1167 IF( full )THEN
1168 nargs = 8
1169 ELSE IF( banded )THEN
1170 nargs = 9
1171 ELSE IF( packed )THEN
1172 nargs = 7
1173 END IF
1174*
1175 nc = 0
1176 reset = .true.
1177 errmax = zero
1178* Set up zero vector for DMVCH.
1179 DO 10 i = 1, nmax
1180 z( i ) = zero
1181 10 CONTINUE
1182*
1183 DO 110 in = 1, nidim
1184 n = idim( in )
1185*
1186 IF( banded )THEN
1187 nk = nkb
1188 ELSE
1189 nk = 1
1190 END IF
1191 DO 100 ik = 1, nk
1192 IF( banded )THEN
1193 k = kb( ik )
1194 ELSE
1195 k = n - 1
1196 END IF
1197* Set LDA to 1 more than minimum value if room.
1198 IF( banded )THEN
1199 lda = k + 1
1200 ELSE
1201 lda = n
1202 END IF
1203 IF( lda.LT.nmax )
1204 $ lda = lda + 1
1205* Skip tests if not enough room.
1206 IF( lda.GT.nmax )
1207 $ GO TO 100
1208 IF( packed )THEN
1209 laa = ( n*( n + 1 ) )/2
1210 ELSE
1211 laa = lda*n
1212 END IF
1213 null = n.LE.0
1214*
1215 DO 90 icu = 1, 2
1216 uplo = ichu( icu: icu )
1217*
1218 DO 80 ict = 1, 3
1219 trans = icht( ict: ict )
1220*
1221 DO 70 icd = 1, 2
1222 diag = ichd( icd: icd )
1223*
1224* Generate the matrix A.
1225*
1226 transl = zero
1227 CALL dmake( sname( 2: 3 ), uplo, diag, n, n, a,
1228 $ nmax, aa, lda, k, k, reset, transl )
1229*
1230 DO 60 ix = 1, ninc
1231 incx = inc( ix )
1232 lx = abs( incx )*n
1233*
1234* Generate the vector X.
1235*
1236 transl = half
1237 CALL dmake( 'GE', ' ', ' ', 1, n, x, 1, xx,
1238 $ abs( incx ), 0, n - 1, reset,
1239 $ transl )
1240 IF( n.GT.1 )THEN
1241 x( n/2 ) = zero
1242 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1243 END IF
1244*
1245 nc = nc + 1
1246*
1247* Save every datum before calling the subroutine.
1248*
1249 uplos = uplo
1250 transs = trans
1251 diags = diag
1252 ns = n
1253 ks = k
1254 DO 20 i = 1, laa
1255 as( i ) = aa( i )
1256 20 CONTINUE
1257 ldas = lda
1258 DO 30 i = 1, lx
1259 xs( i ) = xx( i )
1260 30 CONTINUE
1261 incxs = incx
1262*
1263* Call the subroutine.
1264*
1265 IF( sname( 4: 5 ).EQ.'MV' )THEN
1266 IF( full )THEN
1267 IF( trace )
1268 $ WRITE( ntra, fmt = 9993 )nc, sname,
1269 $ uplo, trans, diag, n, lda, incx
1270 IF( rewi )
1271 $ rewind ntra
1272 CALL dtrmv( uplo, trans, diag, n, aa, lda,
1273 $ xx, incx )
1274 ELSE IF( banded )THEN
1275 IF( trace )
1276 $ WRITE( ntra, fmt = 9994 )nc, sname,
1277 $ uplo, trans, diag, n, k, lda, incx
1278 IF( rewi )
1279 $ rewind ntra
1280 CALL dtbmv( uplo, trans, diag, n, k, aa,
1281 $ lda, xx, incx )
1282 ELSE IF( packed )THEN
1283 IF( trace )
1284 $ WRITE( ntra, fmt = 9995 )nc, sname,
1285 $ uplo, trans, diag, n, incx
1286 IF( rewi )
1287 $ rewind ntra
1288 CALL dtpmv( uplo, trans, diag, n, aa, xx,
1289 $ incx )
1290 END IF
1291 ELSE IF( sname( 4: 5 ).EQ.'SV' )THEN
1292 IF( full )THEN
1293 IF( trace )
1294 $ WRITE( ntra, fmt = 9993 )nc, sname,
1295 $ uplo, trans, diag, n, lda, incx
1296 IF( rewi )
1297 $ rewind ntra
1298 CALL dtrsv( uplo, trans, diag, n, aa, lda,
1299 $ xx, incx )
1300 ELSE IF( banded )THEN
1301 IF( trace )
1302 $ WRITE( ntra, fmt = 9994 )nc, sname,
1303 $ uplo, trans, diag, n, k, lda, incx
1304 IF( rewi )
1305 $ rewind ntra
1306 CALL dtbsv( uplo, trans, diag, n, k, aa,
1307 $ lda, xx, incx )
1308 ELSE IF( packed )THEN
1309 IF( trace )
1310 $ WRITE( ntra, fmt = 9995 )nc, sname,
1311 $ uplo, trans, diag, n, incx
1312 IF( rewi )
1313 $ rewind ntra
1314 CALL dtpsv( uplo, trans, diag, n, aa, xx,
1315 $ incx )
1316 END IF
1317 END IF
1318*
1319* Check if error-exit was taken incorrectly.
1320*
1321 IF( .NOT.ok )THEN
1322 WRITE( nout, fmt = 9992 )
1323 fatal = .true.
1324 GO TO 120
1325 END IF
1326*
1327* See what data changed inside subroutines.
1328*
1329 isame( 1 ) = uplo.EQ.uplos
1330 isame( 2 ) = trans.EQ.transs
1331 isame( 3 ) = diag.EQ.diags
1332 isame( 4 ) = ns.EQ.n
1333 IF( full )THEN
1334 isame( 5 ) = lde( as, aa, laa )
1335 isame( 6 ) = ldas.EQ.lda
1336 IF( null )THEN
1337 isame( 7 ) = lde( xs, xx, lx )
1338 ELSE
1339 isame( 7 ) = lderes( 'GE', ' ', 1, n, xs,
1340 $ xx, abs( incx ) )
1341 END IF
1342 isame( 8 ) = incxs.EQ.incx
1343 ELSE IF( banded )THEN
1344 isame( 5 ) = ks.EQ.k
1345 isame( 6 ) = lde( as, aa, laa )
1346 isame( 7 ) = ldas.EQ.lda
1347 IF( null )THEN
1348 isame( 8 ) = lde( xs, xx, lx )
1349 ELSE
1350 isame( 8 ) = lderes( 'GE', ' ', 1, n, xs,
1351 $ xx, abs( incx ) )
1352 END IF
1353 isame( 9 ) = incxs.EQ.incx
1354 ELSE IF( packed )THEN
1355 isame( 5 ) = lde( as, aa, laa )
1356 IF( null )THEN
1357 isame( 6 ) = lde( xs, xx, lx )
1358 ELSE
1359 isame( 6 ) = lderes( 'GE', ' ', 1, n, xs,
1360 $ xx, abs( incx ) )
1361 END IF
1362 isame( 7 ) = incxs.EQ.incx
1363 END IF
1364*
1365* If data was incorrectly changed, report and
1366* return.
1367*
1368 same = .true.
1369 DO 40 i = 1, nargs
1370 same = same.AND.isame( i )
1371 IF( .NOT.isame( i ) )
1372 $ WRITE( nout, fmt = 9998 )i
1373 40 CONTINUE
1374 IF( .NOT.same )THEN
1375 fatal = .true.
1376 GO TO 120
1377 END IF
1378*
1379 IF( .NOT.null )THEN
1380 IF( sname( 4: 5 ).EQ.'MV' )THEN
1381*
1382* Check the result.
1383*
1384 CALL dmvch( trans, n, n, one, a, nmax, x,
1385 $ incx, zero, z, incx, xt, g,
1386 $ xx, eps, err, fatal, nout,
1387 $ .true. )
1388 ELSE IF( sname( 4: 5 ).EQ.'SV' )THEN
1389*
1390* Compute approximation to original vector.
1391*
1392 DO 50 i = 1, n
1393 z( i ) = xx( 1 + ( i - 1 )*
1394 $ abs( incx ) )
1395 xx( 1 + ( i - 1 )*abs( incx ) )
1396 $ = x( i )
1397 50 CONTINUE
1398 CALL dmvch( trans, n, n, one, a, nmax, z,
1399 $ incx, zero, x, incx, xt, g,
1400 $ xx, eps, err, fatal, nout,
1401 $ .false. )
1402 END IF
1403 errmax = max( errmax, err )
1404* If got really bad answer, report and return.
1405 IF( fatal )
1406 $ GO TO 120
1407 ELSE
1408* Avoid repeating tests with N.le.0.
1409 GO TO 110
1410 END IF
1411*
1412 60 CONTINUE
1413*
1414 70 CONTINUE
1415*
1416 80 CONTINUE
1417*
1418 90 CONTINUE
1419*
1420 100 CONTINUE
1421*
1422 110 CONTINUE
1423*
1424* Report result.
1425*
1426 IF( errmax.LT.thresh )THEN
1427 WRITE( nout, fmt = 9999 )sname, nc
1428 ELSE
1429 WRITE( nout, fmt = 9997 )sname, nc, errmax
1430 END IF
1431 GO TO 130
1432*
1433 120 CONTINUE
1434 WRITE( nout, fmt = 9996 )sname
1435 IF( full )THEN
1436 WRITE( nout, fmt = 9993 )nc, sname, uplo, trans, diag, n, lda,
1437 $ incx
1438 ELSE IF( banded )THEN
1439 WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, diag, n, k,
1440 $ lda, incx
1441 ELSE IF( packed )THEN
1442 WRITE( nout, fmt = 9995 )nc, sname, uplo, trans, diag, n, incx
1443 END IF
1444*
1445 130 CONTINUE
1446 RETURN
1447*
1448 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1449 $ 'S)' )
1450 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1451 $ 'ANGED INCORRECTLY *******' )
1452 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1453 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1454 $ ' - SUSPECT *******' )
1455 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1456 9995 FORMAT( 1x, i6, ': ', a6, '(', 3( '''', a1, ''',' ), i3, ', AP, ',
1457 $ 'X,', i2, ') .' )
1458 9994 FORMAT( 1x, i6, ': ', a6, '(', 3( '''', a1, ''',' ), 2( i3, ',' ),
1459 $ ' A,', i3, ', X,', i2, ') .' )
1460 9993 FORMAT( 1x, i6, ': ', a6, '(', 3( '''', a1, ''',' ), i3, ', A,',
1461 $ i3, ', X,', i2, ') .' )
1462 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1463 $ '******' )
1464*
1465* End of DCHK3
1466*
dtrsv
subroutine dtrsv(uplo, trans, diag, n, a, lda, x, incx)
DTRSV
Definition dtrsv.f:143
dtbmv
subroutine dtbmv(uplo, trans, diag, n, k, a, lda, x, incx)
DTBMV
Definition dtbmv.f:186
dtrmv
subroutine dtrmv(uplo, trans, diag, n, a, lda, x, incx)
DTRMV
Definition dtrmv.f:147
dtpsv
subroutine dtpsv(uplo, trans, diag, n, ap, x, incx)
DTPSV
Definition dtpsv.f:144
dtbsv
subroutine dtbsv(uplo, trans, diag, n, k, a, lda, x, incx)
DTBSV
Definition dtbsv.f:189
dtpmv
subroutine dtpmv(uplo, trans, diag, n, ap, x, incx)
DTPMV
Definition dtpmv.f:142

◆ dchk4()

subroutine dchk4 ( character*6 sname,
double precision eps,
double precision thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nalf,
double precision, dimension( nalf ) alf,
integer ninc,
integer, dimension( ninc ) inc,
integer nmax,
integer incmax,
double precision, dimension( nmax, nmax ) a,
double precision, dimension( nmax*nmax ) aa,
double precision, dimension( nmax*nmax ) as,
double precision, dimension( nmax ) x,
double precision, dimension( nmax*incmax ) xx,
double precision, dimension( nmax*incmax ) xs,
double precision, dimension( nmax ) y,
double precision, dimension( nmax*incmax ) yy,
double precision, dimension( nmax*incmax ) ys,
double precision, dimension( nmax ) yt,
double precision, dimension( nmax ) g,
double precision, dimension( nmax ) z )

Definition at line 1468 of file dblat2.f.

1472*
1473* Tests DGER.
1474*
1475* Auxiliary routine for test program for Level 2 Blas.
1476*
1477* -- Written on 10-August-1987.
1478* Richard Hanson, Sandia National Labs.
1479* Jeremy Du Croz, NAG Central Office.
1480*
1481* .. Parameters ..
1482 DOUBLE PRECISION ZERO, HALF, ONE
1483 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0 )
1484* .. Scalar Arguments ..
1485 DOUBLE PRECISION EPS, THRESH
1486 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1487 LOGICAL FATAL, REWI, TRACE
1488 CHARACTER*6 SNAME
1489* .. Array Arguments ..
1490 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1491 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1492 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
1493 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
1494 $ YY( NMAX*INCMAX ), Z( NMAX )
1495 INTEGER IDIM( NIDIM ), INC( NINC )
1496* .. Local Scalars ..
1497 DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
1498 INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
1499 $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
1500 $ NC, ND, NS
1501 LOGICAL NULL, RESET, SAME
1502* .. Local Arrays ..
1503 DOUBLE PRECISION W( 1 )
1504 LOGICAL ISAME( 13 )
1505* .. External Functions ..
1506 LOGICAL LDE, LDERES
1507 EXTERNAL lde, lderes
1508* .. External Subroutines ..
1509 EXTERNAL dger, dmake, dmvch
1510* .. Intrinsic Functions ..
1511 INTRINSIC abs, max, min
1512* .. Scalars in Common ..
1513 INTEGER INFOT, NOUTC
1514 LOGICAL LERR, OK
1515* .. Common blocks ..
1516 COMMON /infoc/infot, noutc, ok, lerr
1517* .. Executable Statements ..
1518* Define the number of arguments.
1519 nargs = 9
1520*
1521 nc = 0
1522 reset = .true.
1523 errmax = zero
1524*
1525 DO 120 in = 1, nidim
1526 n = idim( in )
1527 nd = n/2 + 1
1528*
1529 DO 110 im = 1, 2
1530 IF( im.EQ.1 )
1531 $ m = max( n - nd, 0 )
1532 IF( im.EQ.2 )
1533 $ m = min( n + nd, nmax )
1534*
1535* Set LDA to 1 more than minimum value if room.
1536 lda = m
1537 IF( lda.LT.nmax )
1538 $ lda = lda + 1
1539* Skip tests if not enough room.
1540 IF( lda.GT.nmax )
1541 $ GO TO 110
1542 laa = lda*n
1543 null = n.LE.0.OR.m.LE.0
1544*
1545 DO 100 ix = 1, ninc
1546 incx = inc( ix )
1547 lx = abs( incx )*m
1548*
1549* Generate the vector X.
1550*
1551 transl = half
1552 CALL dmake( 'GE', ' ', ' ', 1, m, x, 1, xx, abs( incx ),
1553 $ 0, m - 1, reset, transl )
1554 IF( m.GT.1 )THEN
1555 x( m/2 ) = zero
1556 xx( 1 + abs( incx )*( m/2 - 1 ) ) = zero
1557 END IF
1558*
1559 DO 90 iy = 1, ninc
1560 incy = inc( iy )
1561 ly = abs( incy )*n
1562*
1563* Generate the vector Y.
1564*
1565 transl = zero
1566 CALL dmake( 'GE', ' ', ' ', 1, n, y, 1, yy,
1567 $ abs( incy ), 0, n - 1, reset, transl )
1568 IF( n.GT.1 )THEN
1569 y( n/2 ) = zero
1570 yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
1571 END IF
1572*
1573 DO 80 ia = 1, nalf
1574 alpha = alf( ia )
1575*
1576* Generate the matrix A.
1577*
1578 transl = zero
1579 CALL dmake( sname( 2: 3 ), ' ', ' ', m, n, a, nmax,
1580 $ aa, lda, m - 1, n - 1, reset, transl )
1581*
1582 nc = nc + 1
1583*
1584* Save every datum before calling the subroutine.
1585*
1586 ms = m
1587 ns = n
1588 als = alpha
1589 DO 10 i = 1, laa
1590 as( i ) = aa( i )
1591 10 CONTINUE
1592 ldas = lda
1593 DO 20 i = 1, lx
1594 xs( i ) = xx( i )
1595 20 CONTINUE
1596 incxs = incx
1597 DO 30 i = 1, ly
1598 ys( i ) = yy( i )
1599 30 CONTINUE
1600 incys = incy
1601*
1602* Call the subroutine.
1603*
1604 IF( trace )
1605 $ WRITE( ntra, fmt = 9994 )nc, sname, m, n,
1606 $ alpha, incx, incy, lda
1607 IF( rewi )
1608 $ rewind ntra
1609 CALL dger( m, n, alpha, xx, incx, yy, incy, aa,
1610 $ lda )
1611*
1612* Check if error-exit was taken incorrectly.
1613*
1614 IF( .NOT.ok )THEN
1615 WRITE( nout, fmt = 9993 )
1616 fatal = .true.
1617 GO TO 140
1618 END IF
1619*
1620* See what data changed inside subroutine.
1621*
1622 isame( 1 ) = ms.EQ.m
1623 isame( 2 ) = ns.EQ.n
1624 isame( 3 ) = als.EQ.alpha
1625 isame( 4 ) = lde( xs, xx, lx )
1626 isame( 5 ) = incxs.EQ.incx
1627 isame( 6 ) = lde( ys, yy, ly )
1628 isame( 7 ) = incys.EQ.incy
1629 IF( null )THEN
1630 isame( 8 ) = lde( as, aa, laa )
1631 ELSE
1632 isame( 8 ) = lderes( 'GE', ' ', m, n, as, aa,
1633 $ lda )
1634 END IF
1635 isame( 9 ) = ldas.EQ.lda
1636*
1637* If data was incorrectly changed, report and return.
1638*
1639 same = .true.
1640 DO 40 i = 1, nargs
1641 same = same.AND.isame( i )
1642 IF( .NOT.isame( i ) )
1643 $ WRITE( nout, fmt = 9998 )i
1644 40 CONTINUE
1645 IF( .NOT.same )THEN
1646 fatal = .true.
1647 GO TO 140
1648 END IF
1649*
1650 IF( .NOT.null )THEN
1651*
1652* Check the result column by column.
1653*
1654 IF( incx.GT.0 )THEN
1655 DO 50 i = 1, m
1656 z( i ) = x( i )
1657 50 CONTINUE
1658 ELSE
1659 DO 60 i = 1, m
1660 z( i ) = x( m - i + 1 )
1661 60 CONTINUE
1662 END IF
1663 DO 70 j = 1, n
1664 IF( incy.GT.0 )THEN
1665 w( 1 ) = y( j )
1666 ELSE
1667 w( 1 ) = y( n - j + 1 )
1668 END IF
1669 CALL dmvch( 'N', m, 1, alpha, z, nmax, w, 1,
1670 $ one, a( 1, j ), 1, yt, g,
1671 $ aa( 1 + ( j - 1 )*lda ), eps,
1672 $ err, fatal, nout, .true. )
1673 errmax = max( errmax, err )
1674* If got really bad answer, report and return.
1675 IF( fatal )
1676 $ GO TO 130
1677 70 CONTINUE
1678 ELSE
1679* Avoid repeating tests with M.le.0 or N.le.0.
1680 GO TO 110
1681 END IF
1682*
1683 80 CONTINUE
1684*
1685 90 CONTINUE
1686*
1687 100 CONTINUE
1688*
1689 110 CONTINUE
1690*
1691 120 CONTINUE
1692*
1693* Report result.
1694*
1695 IF( errmax.LT.thresh )THEN
1696 WRITE( nout, fmt = 9999 )sname, nc
1697 ELSE
1698 WRITE( nout, fmt = 9997 )sname, nc, errmax
1699 END IF
1700 GO TO 150
1701*
1702 130 CONTINUE
1703 WRITE( nout, fmt = 9995 )j
1704*
1705 140 CONTINUE
1706 WRITE( nout, fmt = 9996 )sname
1707 WRITE( nout, fmt = 9994 )nc, sname, m, n, alpha, incx, incy, lda
1708*
1709 150 CONTINUE
1710 RETURN
1711*
1712 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1713 $ 'S)' )
1714 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1715 $ 'ANGED INCORRECTLY *******' )
1716 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1717 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1718 $ ' - SUSPECT *******' )
1719 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1720 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1721 9994 FORMAT( 1x, i6, ': ', a6, '(', 2( i3, ',' ), f4.1, ', X,', i2,
1722 $ ', Y,', i2, ', A,', i3, ') .' )
1723 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1724 $ '******' )
1725*
1726* End of DCHK4
1727*
dger
subroutine dger(m, n, alpha, x, incx, y, incy, a, lda)
DGER
Definition dger.f:130

◆ dchk5()

subroutine dchk5 ( character*6 sname,
double precision eps,
double precision thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nalf,
double precision, dimension( nalf ) alf,
integer ninc,
integer, dimension( ninc ) inc,
integer nmax,
integer incmax,
double precision, dimension( nmax, nmax ) a,
double precision, dimension( nmax*nmax ) aa,
double precision, dimension( nmax*nmax ) as,
double precision, dimension( nmax ) x,
double precision, dimension( nmax*incmax ) xx,
double precision, dimension( nmax*incmax ) xs,
double precision, dimension( nmax ) y,
double precision, dimension( nmax*incmax ) yy,
double precision, dimension( nmax*incmax ) ys,
double precision, dimension( nmax ) yt,
double precision, dimension( nmax ) g,
double precision, dimension( nmax ) z )

Definition at line 1729 of file dblat2.f.

1733*
1734* Tests DSYR and DSPR.
1735*
1736* Auxiliary routine for test program for Level 2 Blas.
1737*
1738* -- Written on 10-August-1987.
1739* Richard Hanson, Sandia National Labs.
1740* Jeremy Du Croz, NAG Central Office.
1741*
1742* .. Parameters ..
1743 DOUBLE PRECISION ZERO, HALF, ONE
1744 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0 )
1745* .. Scalar Arguments ..
1746 DOUBLE PRECISION EPS, THRESH
1747 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1748 LOGICAL FATAL, REWI, TRACE
1749 CHARACTER*6 SNAME
1750* .. Array Arguments ..
1751 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1752 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1753 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
1754 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
1755 $ YY( NMAX*INCMAX ), Z( NMAX )
1756 INTEGER IDIM( NIDIM ), INC( NINC )
1757* .. Local Scalars ..
1758 DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
1759 INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
1760 $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS
1761 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
1762 CHARACTER*1 UPLO, UPLOS
1763 CHARACTER*2 ICH
1764* .. Local Arrays ..
1765 DOUBLE PRECISION W( 1 )
1766 LOGICAL ISAME( 13 )
1767* .. External Functions ..
1768 LOGICAL LDE, LDERES
1769 EXTERNAL lde, lderes
1770* .. External Subroutines ..
1771 EXTERNAL dmake, dmvch, dspr, dsyr
1772* .. Intrinsic Functions ..
1773 INTRINSIC abs, max
1774* .. Scalars in Common ..
1775 INTEGER INFOT, NOUTC
1776 LOGICAL LERR, OK
1777* .. Common blocks ..
1778 COMMON /infoc/infot, noutc, ok, lerr
1779* .. Data statements ..
1780 DATA ich/'UL'/
1781* .. Executable Statements ..
1782 full = sname( 3: 3 ).EQ.'Y'
1783 packed = sname( 3: 3 ).EQ.'P'
1784* Define the number of arguments.
1785 IF( full )THEN
1786 nargs = 7
1787 ELSE IF( packed )THEN
1788 nargs = 6
1789 END IF
1790*
1791 nc = 0
1792 reset = .true.
1793 errmax = zero
1794*
1795 DO 100 in = 1, nidim
1796 n = idim( in )
1797* Set LDA to 1 more than minimum value if room.
1798 lda = n
1799 IF( lda.LT.nmax )
1800 $ lda = lda + 1
1801* Skip tests if not enough room.
1802 IF( lda.GT.nmax )
1803 $ GO TO 100
1804 IF( packed )THEN
1805 laa = ( n*( n + 1 ) )/2
1806 ELSE
1807 laa = lda*n
1808 END IF
1809*
1810 DO 90 ic = 1, 2
1811 uplo = ich( ic: ic )
1812 upper = uplo.EQ.'U'
1813*
1814 DO 80 ix = 1, ninc
1815 incx = inc( ix )
1816 lx = abs( incx )*n
1817*
1818* Generate the vector X.
1819*
1820 transl = half
1821 CALL dmake( 'GE', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
1822 $ 0, n - 1, reset, transl )
1823 IF( n.GT.1 )THEN
1824 x( n/2 ) = zero
1825 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1826 END IF
1827*
1828 DO 70 ia = 1, nalf
1829 alpha = alf( ia )
1830 null = n.LE.0.OR.alpha.EQ.zero
1831*
1832* Generate the matrix A.
1833*
1834 transl = zero
1835 CALL dmake( sname( 2: 3 ), uplo, ' ', n, n, a, nmax,
1836 $ aa, lda, n - 1, n - 1, reset, transl )
1837*
1838 nc = nc + 1
1839*
1840* Save every datum before calling the subroutine.
1841*
1842 uplos = uplo
1843 ns = n
1844 als = alpha
1845 DO 10 i = 1, laa
1846 as( i ) = aa( i )
1847 10 CONTINUE
1848 ldas = lda
1849 DO 20 i = 1, lx
1850 xs( i ) = xx( i )
1851 20 CONTINUE
1852 incxs = incx
1853*
1854* Call the subroutine.
1855*
1856 IF( full )THEN
1857 IF( trace )
1858 $ WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
1859 $ alpha, incx, lda
1860 IF( rewi )
1861 $ rewind ntra
1862 CALL dsyr( uplo, n, alpha, xx, incx, aa, lda )
1863 ELSE IF( packed )THEN
1864 IF( trace )
1865 $ WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
1866 $ alpha, incx
1867 IF( rewi )
1868 $ rewind ntra
1869 CALL dspr( uplo, n, alpha, xx, incx, aa )
1870 END IF
1871*
1872* Check if error-exit was taken incorrectly.
1873*
1874 IF( .NOT.ok )THEN
1875 WRITE( nout, fmt = 9992 )
1876 fatal = .true.
1877 GO TO 120
1878 END IF
1879*
1880* See what data changed inside subroutines.
1881*
1882 isame( 1 ) = uplo.EQ.uplos
1883 isame( 2 ) = ns.EQ.n
1884 isame( 3 ) = als.EQ.alpha
1885 isame( 4 ) = lde( xs, xx, lx )
1886 isame( 5 ) = incxs.EQ.incx
1887 IF( null )THEN
1888 isame( 6 ) = lde( as, aa, laa )
1889 ELSE
1890 isame( 6 ) = lderes( sname( 2: 3 ), uplo, n, n, as,
1891 $ aa, lda )
1892 END IF
1893 IF( .NOT.packed )THEN
1894 isame( 7 ) = ldas.EQ.lda
1895 END IF
1896*
1897* If data was incorrectly changed, report and return.
1898*
1899 same = .true.
1900 DO 30 i = 1, nargs
1901 same = same.AND.isame( i )
1902 IF( .NOT.isame( i ) )
1903 $ WRITE( nout, fmt = 9998 )i
1904 30 CONTINUE
1905 IF( .NOT.same )THEN
1906 fatal = .true.
1907 GO TO 120
1908 END IF
1909*
1910 IF( .NOT.null )THEN
1911*
1912* Check the result column by column.
1913*
1914 IF( incx.GT.0 )THEN
1915 DO 40 i = 1, n
1916 z( i ) = x( i )
1917 40 CONTINUE
1918 ELSE
1919 DO 50 i = 1, n
1920 z( i ) = x( n - i + 1 )
1921 50 CONTINUE
1922 END IF
1923 ja = 1
1924 DO 60 j = 1, n
1925 w( 1 ) = z( j )
1926 IF( upper )THEN
1927 jj = 1
1928 lj = j
1929 ELSE
1930 jj = j
1931 lj = n - j + 1
1932 END IF
1933 CALL dmvch( 'N', lj, 1, alpha, z( jj ), lj, w,
1934 $ 1, one, a( jj, j ), 1, yt, g,
1935 $ aa( ja ), eps, err, fatal, nout,
1936 $ .true. )
1937 IF( full )THEN
1938 IF( upper )THEN
1939 ja = ja + lda
1940 ELSE
1941 ja = ja + lda + 1
1942 END IF
1943 ELSE
1944 ja = ja + lj
1945 END IF
1946 errmax = max( errmax, err )
1947* If got really bad answer, report and return.
1948 IF( fatal )
1949 $ GO TO 110
1950 60 CONTINUE
1951 ELSE
1952* Avoid repeating tests if N.le.0.
1953 IF( n.LE.0 )
1954 $ GO TO 100
1955 END IF
1956*
1957 70 CONTINUE
1958*
1959 80 CONTINUE
1960*
1961 90 CONTINUE
1962*
1963 100 CONTINUE
1964*
1965* Report result.
1966*
1967 IF( errmax.LT.thresh )THEN
1968 WRITE( nout, fmt = 9999 )sname, nc
1969 ELSE
1970 WRITE( nout, fmt = 9997 )sname, nc, errmax
1971 END IF
1972 GO TO 130
1973*
1974 110 CONTINUE
1975 WRITE( nout, fmt = 9995 )j
1976*
1977 120 CONTINUE
1978 WRITE( nout, fmt = 9996 )sname
1979 IF( full )THEN
1980 WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, incx, lda
1981 ELSE IF( packed )THEN
1982 WRITE( nout, fmt = 9994 )nc, sname, uplo, n, alpha, incx
1983 END IF
1984*
1985 130 CONTINUE
1986 RETURN
1987*
1988 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1989 $ 'S)' )
1990 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1991 $ 'ANGED INCORRECTLY *******' )
1992 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1993 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1994 $ ' - SUSPECT *******' )
1995 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1996 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1997 9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', X,',
1998 $ i2, ', AP) .' )
1999 9993 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', X,',
2000 $ i2, ', A,', i3, ') .' )
2001 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2002 $ '******' )
2003*
2004* End of DCHK5
2005*
dsyr
subroutine dsyr(uplo, n, alpha, x, incx, a, lda)
DSYR
Definition dsyr.f:132
dspr
subroutine dspr(uplo, n, alpha, x, incx, ap)
DSPR
Definition dspr.f:127

◆ dchk6()

subroutine dchk6 ( character*6 sname,
double precision eps,
double precision thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nalf,
double precision, dimension( nalf ) alf,
integer ninc,
integer, dimension( ninc ) inc,
integer nmax,
integer incmax,
double precision, dimension( nmax, nmax ) a,
double precision, dimension( nmax*nmax ) aa,
double precision, dimension( nmax*nmax ) as,
double precision, dimension( nmax ) x,
double precision, dimension( nmax*incmax ) xx,
double precision, dimension( nmax*incmax ) xs,
double precision, dimension( nmax ) y,
double precision, dimension( nmax*incmax ) yy,
double precision, dimension( nmax*incmax ) ys,
double precision, dimension( nmax ) yt,
double precision, dimension( nmax ) g,
double precision, dimension( nmax, 2 ) z )

Definition at line 2007 of file dblat2.f.

2011*
2012* Tests DSYR2 and DSPR2.
2013*
2014* Auxiliary routine for test program for Level 2 Blas.
2015*
2016* -- Written on 10-August-1987.
2017* Richard Hanson, Sandia National Labs.
2018* Jeremy Du Croz, NAG Central Office.
2019*
2020* .. Parameters ..
2021 DOUBLE PRECISION ZERO, HALF, ONE
2022 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0 )
2023* .. Scalar Arguments ..
2024 DOUBLE PRECISION EPS, THRESH
2025 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
2026 LOGICAL FATAL, REWI, TRACE
2027 CHARACTER*6 SNAME
2028* .. Array Arguments ..
2029 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
2030 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
2031 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
2032 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
2033 $ YY( NMAX*INCMAX ), Z( NMAX, 2 )
2034 INTEGER IDIM( NIDIM ), INC( NINC )
2035* .. Local Scalars ..
2036 DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
2037 INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
2038 $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
2039 $ NARGS, NC, NS
2040 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
2041 CHARACTER*1 UPLO, UPLOS
2042 CHARACTER*2 ICH
2043* .. Local Arrays ..
2044 DOUBLE PRECISION W( 2 )
2045 LOGICAL ISAME( 13 )
2046* .. External Functions ..
2047 LOGICAL LDE, LDERES
2048 EXTERNAL lde, lderes
2049* .. External Subroutines ..
2050 EXTERNAL dmake, dmvch, dspr2, dsyr2
2051* .. Intrinsic Functions ..
2052 INTRINSIC abs, max
2053* .. Scalars in Common ..
2054 INTEGER INFOT, NOUTC
2055 LOGICAL LERR, OK
2056* .. Common blocks ..
2057 COMMON /infoc/infot, noutc, ok, lerr
2058* .. Data statements ..
2059 DATA ich/'UL'/
2060* .. Executable Statements ..
2061 full = sname( 3: 3 ).EQ.'Y'
2062 packed = sname( 3: 3 ).EQ.'P'
2063* Define the number of arguments.
2064 IF( full )THEN
2065 nargs = 9
2066 ELSE IF( packed )THEN
2067 nargs = 8
2068 END IF
2069*
2070 nc = 0
2071 reset = .true.
2072 errmax = zero
2073*
2074 DO 140 in = 1, nidim
2075 n = idim( in )
2076* Set LDA to 1 more than minimum value if room.
2077 lda = n
2078 IF( lda.LT.nmax )
2079 $ lda = lda + 1
2080* Skip tests if not enough room.
2081 IF( lda.GT.nmax )
2082 $ GO TO 140
2083 IF( packed )THEN
2084 laa = ( n*( n + 1 ) )/2
2085 ELSE
2086 laa = lda*n
2087 END IF
2088*
2089 DO 130 ic = 1, 2
2090 uplo = ich( ic: ic )
2091 upper = uplo.EQ.'U'
2092*
2093 DO 120 ix = 1, ninc
2094 incx = inc( ix )
2095 lx = abs( incx )*n
2096*
2097* Generate the vector X.
2098*
2099 transl = half
2100 CALL dmake( 'GE', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
2101 $ 0, n - 1, reset, transl )
2102 IF( n.GT.1 )THEN
2103 x( n/2 ) = zero
2104 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
2105 END IF
2106*
2107 DO 110 iy = 1, ninc
2108 incy = inc( iy )
2109 ly = abs( incy )*n
2110*
2111* Generate the vector Y.
2112*
2113 transl = zero
2114 CALL dmake( 'GE', ' ', ' ', 1, n, y, 1, yy,
2115 $ abs( incy ), 0, n - 1, reset, transl )
2116 IF( n.GT.1 )THEN
2117 y( n/2 ) = zero
2118 yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
2119 END IF
2120*
2121 DO 100 ia = 1, nalf
2122 alpha = alf( ia )
2123 null = n.LE.0.OR.alpha.EQ.zero
2124*
2125* Generate the matrix A.
2126*
2127 transl = zero
2128 CALL dmake( sname( 2: 3 ), uplo, ' ', n, n, a,
2129 $ nmax, aa, lda, n - 1, n - 1, reset,
2130 $ transl )
2131*
2132 nc = nc + 1
2133*
2134* Save every datum before calling the subroutine.
2135*
2136 uplos = uplo
2137 ns = n
2138 als = alpha
2139 DO 10 i = 1, laa
2140 as( i ) = aa( i )
2141 10 CONTINUE
2142 ldas = lda
2143 DO 20 i = 1, lx
2144 xs( i ) = xx( i )
2145 20 CONTINUE
2146 incxs = incx
2147 DO 30 i = 1, ly
2148 ys( i ) = yy( i )
2149 30 CONTINUE
2150 incys = incy
2151*
2152* Call the subroutine.
2153*
2154 IF( full )THEN
2155 IF( trace )
2156 $ WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
2157 $ alpha, incx, incy, lda
2158 IF( rewi )
2159 $ rewind ntra
2160 CALL dsyr2( uplo, n, alpha, xx, incx, yy, incy,
2161 $ aa, lda )
2162 ELSE IF( packed )THEN
2163 IF( trace )
2164 $ WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
2165 $ alpha, incx, incy
2166 IF( rewi )
2167 $ rewind ntra
2168 CALL dspr2( uplo, n, alpha, xx, incx, yy, incy,
2169 $ aa )
2170 END IF
2171*
2172* Check if error-exit was taken incorrectly.
2173*
2174 IF( .NOT.ok )THEN
2175 WRITE( nout, fmt = 9992 )
2176 fatal = .true.
2177 GO TO 160
2178 END IF
2179*
2180* See what data changed inside subroutines.
2181*
2182 isame( 1 ) = uplo.EQ.uplos
2183 isame( 2 ) = ns.EQ.n
2184 isame( 3 ) = als.EQ.alpha
2185 isame( 4 ) = lde( xs, xx, lx )
2186 isame( 5 ) = incxs.EQ.incx
2187 isame( 6 ) = lde( ys, yy, ly )
2188 isame( 7 ) = incys.EQ.incy
2189 IF( null )THEN
2190 isame( 8 ) = lde( as, aa, laa )
2191 ELSE
2192 isame( 8 ) = lderes( sname( 2: 3 ), uplo, n, n,
2193 $ as, aa, lda )
2194 END IF
2195 IF( .NOT.packed )THEN
2196 isame( 9 ) = ldas.EQ.lda
2197 END IF
2198*
2199* If data was incorrectly changed, report and return.
2200*
2201 same = .true.
2202 DO 40 i = 1, nargs
2203 same = same.AND.isame( i )
2204 IF( .NOT.isame( i ) )
2205 $ WRITE( nout, fmt = 9998 )i
2206 40 CONTINUE
2207 IF( .NOT.same )THEN
2208 fatal = .true.
2209 GO TO 160
2210 END IF
2211*
2212 IF( .NOT.null )THEN
2213*
2214* Check the result column by column.
2215*
2216 IF( incx.GT.0 )THEN
2217 DO 50 i = 1, n
2218 z( i, 1 ) = x( i )
2219 50 CONTINUE
2220 ELSE
2221 DO 60 i = 1, n
2222 z( i, 1 ) = x( n - i + 1 )
2223 60 CONTINUE
2224 END IF
2225 IF( incy.GT.0 )THEN
2226 DO 70 i = 1, n
2227 z( i, 2 ) = y( i )
2228 70 CONTINUE
2229 ELSE
2230 DO 80 i = 1, n
2231 z( i, 2 ) = y( n - i + 1 )
2232 80 CONTINUE
2233 END IF
2234 ja = 1
2235 DO 90 j = 1, n
2236 w( 1 ) = z( j, 2 )
2237 w( 2 ) = z( j, 1 )
2238 IF( upper )THEN
2239 jj = 1
2240 lj = j
2241 ELSE
2242 jj = j
2243 lj = n - j + 1
2244 END IF
2245 CALL dmvch( 'N', lj, 2, alpha, z( jj, 1 ),
2246 $ nmax, w, 1, one, a( jj, j ), 1,
2247 $ yt, g, aa( ja ), eps, err, fatal,
2248 $ nout, .true. )
2249 IF( full )THEN
2250 IF( upper )THEN
2251 ja = ja + lda
2252 ELSE
2253 ja = ja + lda + 1
2254 END IF
2255 ELSE
2256 ja = ja + lj
2257 END IF
2258 errmax = max( errmax, err )
2259* If got really bad answer, report and return.
2260 IF( fatal )
2261 $ GO TO 150
2262 90 CONTINUE
2263 ELSE
2264* Avoid repeating tests with N.le.0.
2265 IF( n.LE.0 )
2266 $ GO TO 140
2267 END IF
2268*
2269 100 CONTINUE
2270*
2271 110 CONTINUE
2272*
2273 120 CONTINUE
2274*
2275 130 CONTINUE
2276*
2277 140 CONTINUE
2278*
2279* Report result.
2280*
2281 IF( errmax.LT.thresh )THEN
2282 WRITE( nout, fmt = 9999 )sname, nc
2283 ELSE
2284 WRITE( nout, fmt = 9997 )sname, nc, errmax
2285 END IF
2286 GO TO 170
2287*
2288 150 CONTINUE
2289 WRITE( nout, fmt = 9995 )j
2290*
2291 160 CONTINUE
2292 WRITE( nout, fmt = 9996 )sname
2293 IF( full )THEN
2294 WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, incx,
2295 $ incy, lda
2296 ELSE IF( packed )THEN
2297 WRITE( nout, fmt = 9994 )nc, sname, uplo, n, alpha, incx, incy
2298 END IF
2299*
2300 170 CONTINUE
2301 RETURN
2302*
2303 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
2304 $ 'S)' )
2305 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2306 $ 'ANGED INCORRECTLY *******' )
2307 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
2308 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2309 $ ' - SUSPECT *******' )
2310 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
2311 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2312 9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', X,',
2313 $ i2, ', Y,', i2, ', AP) .' )
2314 9993 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', X,',
2315 $ i2, ', Y,', i2, ', A,', i3, ') .' )
2316 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2317 $ '******' )
2318*
2319* End of DCHK6
2320*
dspr2
subroutine dspr2(uplo, n, alpha, x, incx, y, incy, ap)
DSPR2
Definition dspr2.f:142
dsyr2
subroutine dsyr2(uplo, n, alpha, x, incx, y, incy, a, lda)
DSYR2
Definition dsyr2.f:147

◆ dchke()

subroutine dchke ( integer isnum,
character*6 srnamt,
integer nout )

Definition at line 2322 of file dblat2.f.

2323*
2324* Tests the error exits from the Level 2 Blas.
2325* Requires a special version of the error-handling routine XERBLA.
2326* ALPHA, BETA, A, X and Y should not need to be defined.
2327*
2328* Auxiliary routine for test program for Level 2 Blas.
2329*
2330* -- Written on 10-August-1987.
2331* Richard Hanson, Sandia National Labs.
2332* Jeremy Du Croz, NAG Central Office.
2333*
2334* .. Scalar Arguments ..
2335 INTEGER ISNUM, NOUT
2336 CHARACTER*6 SRNAMT
2337* .. Scalars in Common ..
2338 INTEGER INFOT, NOUTC
2339 LOGICAL LERR, OK
2340* .. Local Scalars ..
2341 DOUBLE PRECISION ALPHA, BETA
2342* .. Local Arrays ..
2343 DOUBLE PRECISION A( 1, 1 ), X( 1 ), Y( 1 )
2344* .. External Subroutines ..
2345 EXTERNAL chkxer, dgbmv, dgemv, dger, dsbmv, dspmv, dspr,
2346 $ dspr2, dsymv, dsyr, dsyr2, dtbmv, dtbsv, dtpmv,
2347 $ dtpsv, dtrmv, dtrsv
2348* .. Common blocks ..
2349 COMMON /infoc/infot, noutc, ok, lerr
2350* .. Executable Statements ..
2351* OK is set to .FALSE. by the special version of XERBLA or by CHKXER
2352* if anything is wrong.
2353 ok = .true.
2354* LERR is set to .TRUE. by the special version of XERBLA each time
2355* it is called, and is then tested and re-set by CHKXER.
2356 lerr = .false.
2357 GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
2358 $ 90, 100, 110, 120, 130, 140, 150,
2359 $ 160 )isnum
2360 10 infot = 1
2361 CALL dgemv( '/', 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2362 CALL chkxer( srnamt, infot, nout, lerr, ok )
2363 infot = 2
2364 CALL dgemv( 'N', -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2365 CALL chkxer( srnamt, infot, nout, lerr, ok )
2366 infot = 3
2367 CALL dgemv( 'N', 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2368 CALL chkxer( srnamt, infot, nout, lerr, ok )
2369 infot = 6
2370 CALL dgemv( 'N', 2, 0, alpha, a, 1, x, 1, beta, y, 1 )
2371 CALL chkxer( srnamt, infot, nout, lerr, ok )
2372 infot = 8
2373 CALL dgemv( 'N', 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2374 CALL chkxer( srnamt, infot, nout, lerr, ok )
2375 infot = 11
2376 CALL dgemv( 'N', 0, 0, alpha, a, 1, x, 1, beta, y, 0 )
2377 CALL chkxer( srnamt, infot, nout, lerr, ok )
2378 GO TO 170
2379 20 infot = 1
2380 CALL dgbmv( '/', 0, 0, 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2381 CALL chkxer( srnamt, infot, nout, lerr, ok )
2382 infot = 2
2383 CALL dgbmv( 'N', -1, 0, 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2384 CALL chkxer( srnamt, infot, nout, lerr, ok )
2385 infot = 3
2386 CALL dgbmv( 'N', 0, -1, 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2387 CALL chkxer( srnamt, infot, nout, lerr, ok )
2388 infot = 4
2389 CALL dgbmv( 'N', 0, 0, -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2390 CALL chkxer( srnamt, infot, nout, lerr, ok )
2391 infot = 5
2392 CALL dgbmv( 'N', 2, 0, 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2393 CALL chkxer( srnamt, infot, nout, lerr, ok )
2394 infot = 8
2395 CALL dgbmv( 'N', 0, 0, 1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2396 CALL chkxer( srnamt, infot, nout, lerr, ok )
2397 infot = 10
2398 CALL dgbmv( 'N', 0, 0, 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2399 CALL chkxer( srnamt, infot, nout, lerr, ok )
2400 infot = 13
2401 CALL dgbmv( 'N', 0, 0, 0, 0, alpha, a, 1, x, 1, beta, y, 0 )
2402 CALL chkxer( srnamt, infot, nout, lerr, ok )
2403 GO TO 170
2404 30 infot = 1
2405 CALL dsymv( '/', 0, alpha, a, 1, x, 1, beta, y, 1 )
2406 CALL chkxer( srnamt, infot, nout, lerr, ok )
2407 infot = 2
2408 CALL dsymv( 'U', -1, alpha, a, 1, x, 1, beta, y, 1 )
2409 CALL chkxer( srnamt, infot, nout, lerr, ok )
2410 infot = 5
2411 CALL dsymv( 'U', 2, alpha, a, 1, x, 1, beta, y, 1 )
2412 CALL chkxer( srnamt, infot, nout, lerr, ok )
2413 infot = 7
2414 CALL dsymv( 'U', 0, alpha, a, 1, x, 0, beta, y, 1 )
2415 CALL chkxer( srnamt, infot, nout, lerr, ok )
2416 infot = 10
2417 CALL dsymv( 'U', 0, alpha, a, 1, x, 1, beta, y, 0 )
2418 CALL chkxer( srnamt, infot, nout, lerr, ok )
2419 GO TO 170
2420 40 infot = 1
2421 CALL dsbmv( '/', 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2422 CALL chkxer( srnamt, infot, nout, lerr, ok )
2423 infot = 2
2424 CALL dsbmv( 'U', -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2425 CALL chkxer( srnamt, infot, nout, lerr, ok )
2426 infot = 3
2427 CALL dsbmv( 'U', 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2428 CALL chkxer( srnamt, infot, nout, lerr, ok )
2429 infot = 6
2430 CALL dsbmv( 'U', 0, 1, alpha, a, 1, x, 1, beta, y, 1 )
2431 CALL chkxer( srnamt, infot, nout, lerr, ok )
2432 infot = 8
2433 CALL dsbmv( 'U', 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2434 CALL chkxer( srnamt, infot, nout, lerr, ok )
2435 infot = 11
2436 CALL dsbmv( 'U', 0, 0, alpha, a, 1, x, 1, beta, y, 0 )
2437 CALL chkxer( srnamt, infot, nout, lerr, ok )
2438 GO TO 170
2439 50 infot = 1
2440 CALL dspmv( '/', 0, alpha, a, x, 1, beta, y, 1 )
2441 CALL chkxer( srnamt, infot, nout, lerr, ok )
2442 infot = 2
2443 CALL dspmv( 'U', -1, alpha, a, x, 1, beta, y, 1 )
2444 CALL chkxer( srnamt, infot, nout, lerr, ok )
2445 infot = 6
2446 CALL dspmv( 'U', 0, alpha, a, x, 0, beta, y, 1 )
2447 CALL chkxer( srnamt, infot, nout, lerr, ok )
2448 infot = 9
2449 CALL dspmv( 'U', 0, alpha, a, x, 1, beta, y, 0 )
2450 CALL chkxer( srnamt, infot, nout, lerr, ok )
2451 GO TO 170
2452 60 infot = 1
2453 CALL dtrmv( '/', 'N', 'N', 0, a, 1, x, 1 )
2454 CALL chkxer( srnamt, infot, nout, lerr, ok )
2455 infot = 2
2456 CALL dtrmv( 'U', '/', 'N', 0, a, 1, x, 1 )
2457 CALL chkxer( srnamt, infot, nout, lerr, ok )
2458 infot = 3
2459 CALL dtrmv( 'U', 'N', '/', 0, a, 1, x, 1 )
2460 CALL chkxer( srnamt, infot, nout, lerr, ok )
2461 infot = 4
2462 CALL dtrmv( 'U', 'N', 'N', -1, a, 1, x, 1 )
2463 CALL chkxer( srnamt, infot, nout, lerr, ok )
2464 infot = 6
2465 CALL dtrmv( 'U', 'N', 'N', 2, a, 1, x, 1 )
2466 CALL chkxer( srnamt, infot, nout, lerr, ok )
2467 infot = 8
2468 CALL dtrmv( 'U', 'N', 'N', 0, a, 1, x, 0 )
2469 CALL chkxer( srnamt, infot, nout, lerr, ok )
2470 GO TO 170
2471 70 infot = 1
2472 CALL dtbmv( '/', 'N', 'N', 0, 0, a, 1, x, 1 )
2473 CALL chkxer( srnamt, infot, nout, lerr, ok )
2474 infot = 2
2475 CALL dtbmv( 'U', '/', 'N', 0, 0, a, 1, x, 1 )
2476 CALL chkxer( srnamt, infot, nout, lerr, ok )
2477 infot = 3
2478 CALL dtbmv( 'U', 'N', '/', 0, 0, a, 1, x, 1 )
2479 CALL chkxer( srnamt, infot, nout, lerr, ok )
2480 infot = 4
2481 CALL dtbmv( 'U', 'N', 'N', -1, 0, a, 1, x, 1 )
2482 CALL chkxer( srnamt, infot, nout, lerr, ok )
2483 infot = 5
2484 CALL dtbmv( 'U', 'N', 'N', 0, -1, a, 1, x, 1 )
2485 CALL chkxer( srnamt, infot, nout, lerr, ok )
2486 infot = 7
2487 CALL dtbmv( 'U', 'N', 'N', 0, 1, a, 1, x, 1 )
2488 CALL chkxer( srnamt, infot, nout, lerr, ok )
2489 infot = 9
2490 CALL dtbmv( 'U', 'N', 'N', 0, 0, a, 1, x, 0 )
2491 CALL chkxer( srnamt, infot, nout, lerr, ok )
2492 GO TO 170
2493 80 infot = 1
2494 CALL dtpmv( '/', 'N', 'N', 0, a, x, 1 )
2495 CALL chkxer( srnamt, infot, nout, lerr, ok )
2496 infot = 2
2497 CALL dtpmv( 'U', '/', 'N', 0, a, x, 1 )
2498 CALL chkxer( srnamt, infot, nout, lerr, ok )
2499 infot = 3
2500 CALL dtpmv( 'U', 'N', '/', 0, a, x, 1 )
2501 CALL chkxer( srnamt, infot, nout, lerr, ok )
2502 infot = 4
2503 CALL dtpmv( 'U', 'N', 'N', -1, a, x, 1 )
2504 CALL chkxer( srnamt, infot, nout, lerr, ok )
2505 infot = 7
2506 CALL dtpmv( 'U', 'N', 'N', 0, a, x, 0 )
2507 CALL chkxer( srnamt, infot, nout, lerr, ok )
2508 GO TO 170
2509 90 infot = 1
2510 CALL dtrsv( '/', 'N', 'N', 0, a, 1, x, 1 )
2511 CALL chkxer( srnamt, infot, nout, lerr, ok )
2512 infot = 2
2513 CALL dtrsv( 'U', '/', 'N', 0, a, 1, x, 1 )
2514 CALL chkxer( srnamt, infot, nout, lerr, ok )
2515 infot = 3
2516 CALL dtrsv( 'U', 'N', '/', 0, a, 1, x, 1 )
2517 CALL chkxer( srnamt, infot, nout, lerr, ok )
2518 infot = 4
2519 CALL dtrsv( 'U', 'N', 'N', -1, a, 1, x, 1 )
2520 CALL chkxer( srnamt, infot, nout, lerr, ok )
2521 infot = 6
2522 CALL dtrsv( 'U', 'N', 'N', 2, a, 1, x, 1 )
2523 CALL chkxer( srnamt, infot, nout, lerr, ok )
2524 infot = 8
2525 CALL dtrsv( 'U', 'N', 'N', 0, a, 1, x, 0 )
2526 CALL chkxer( srnamt, infot, nout, lerr, ok )
2527 GO TO 170
2528 100 infot = 1
2529 CALL dtbsv( '/', 'n', 'n', 0, 0, A, 1, X, 1 )
2530 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2531 INFOT = 2
2532 CALL DTBSV( 'u', '/', 'n', 0, 0, A, 1, X, 1 )
2533 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2534 INFOT = 3
2535 CALL DTBSV( 'u', 'n', '/', 0, 0, A, 1, X, 1 )
2536 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2537 INFOT = 4
2538 CALL DTBSV( 'u', 'n', 'n', -1, 0, A, 1, X, 1 )
2539 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2540 INFOT = 5
2541 CALL DTBSV( 'u', 'n', 'n', 0, -1, A, 1, X, 1 )
2542 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2543 INFOT = 7
2544 CALL DTBSV( 'u', 'n', 'n', 0, 1, A, 1, X, 1 )
2545 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2546 INFOT = 9
2547 CALL DTBSV( 'u', 'n', 'n', 0, 0, A, 1, X, 0 )
2548 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2549 GO TO 170
2550 110 INFOT = 1
2551 CALL DTPSV( '/', 'n', 'n', 0, A, X, 1 )
2552 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2553 INFOT = 2
2554 CALL DTPSV( 'u', '/', 'n', 0, A, X, 1 )
2555 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2556 INFOT = 3
2557 CALL DTPSV( 'u', 'n', '/', 0, A, X, 1 )
2558 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2559 INFOT = 4
2560 CALL DTPSV( 'u', 'n', 'n', -1, A, X, 1 )
2561 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2562 INFOT = 7
2563 CALL DTPSV( 'u', 'n', 'n', 0, A, X, 0 )
2564 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2565 GO TO 170
2566 120 INFOT = 1
2567 CALL DGER( -1, 0, ALPHA, X, 1, Y, 1, A, 1 )
2568 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2569 INFOT = 2
2570 CALL DGER( 0, -1, ALPHA, X, 1, Y, 1, A, 1 )
2571 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2572 INFOT = 5
2573 CALL DGER( 0, 0, ALPHA, X, 0, Y, 1, A, 1 )
2574 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2575 INFOT = 7
2576 CALL DGER( 0, 0, ALPHA, X, 1, Y, 0, A, 1 )
2577 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2578 INFOT = 9
2579 CALL DGER( 2, 0, ALPHA, X, 1, Y, 1, A, 1 )
2580 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2581 GO TO 170
2582 130 INFOT = 1
2583 CALL DSYR( '/', 0, ALPHA, X, 1, A, 1 )
2584 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2585 INFOT = 2
2586 CALL DSYR( 'u', -1, ALPHA, X, 1, A, 1 )
2587 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2588 INFOT = 5
2589 CALL DSYR( 'u', 0, ALPHA, X, 0, A, 1 )
2590 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2591 INFOT = 7
2592 CALL DSYR( 'u', 2, ALPHA, X, 1, A, 1 )
2593 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2594 GO TO 170
2595 140 INFOT = 1
2596 CALL DSPR( '/', 0, ALPHA, X, 1, A )
2597 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2598 INFOT = 2
2599 CALL DSPR( 'u', -1, ALPHA, X, 1, A )
2600 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2601 INFOT = 5
2602 CALL DSPR( 'u', 0, ALPHA, X, 0, A )
2603 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2604 GO TO 170
2605 150 INFOT = 1
2606 CALL DSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 )
2607 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2608 INFOT = 2
2609 CALL DSYR2( 'u', -1, ALPHA, X, 1, Y, 1, A, 1 )
2610 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2611 INFOT = 5
2612 CALL DSYR2( 'u', 0, ALPHA, X, 0, Y, 1, A, 1 )
2613 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2614 INFOT = 7
2615 CALL DSYR2( 'u', 0, ALPHA, X, 1, Y, 0, A, 1 )
2616 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2617 INFOT = 9
2618 CALL DSYR2( 'u', 2, ALPHA, X, 1, Y, 1, A, 1 )
2619 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2620 GO TO 170
2621 160 INFOT = 1
2622 CALL DSPR2( '/', 0, ALPHA, X, 1, Y, 1, A )
2623 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2624 INFOT = 2
2625 CALL DSPR2( 'u', -1, ALPHA, X, 1, Y, 1, A )
2626 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2627 INFOT = 5
2628 CALL DSPR2( 'u', 0, ALPHA, X, 0, Y, 1, A )
2629 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2630 INFOT = 7
2631 CALL DSPR2( 'u', 0, ALPHA, X, 1, Y, 0, A )
2632 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2633*
2634 170 IF( OK )THEN
2635 WRITE( NOUT, FMT = 9999 )SRNAMT
2636 ELSE
2637 WRITE( NOUT, FMT = 9998 )SRNAMT
2638 END IF
2639 RETURN
2640*
2641 9999 FORMAT( ' ', A6, ' passed the tests of error-exits' )
2642 9998 FORMAT( ' ******* ', A6, ' failed the tests of error-exits *****',
2643 $ '**' )
2644*
2645* End of DCHKE
2646*
chkxer
subroutine chkxer(srnamt, infot, nout, lerr, ok)
Definition dblat2.f:3093

◆ ddiff()

double precision function ddiff ( double precision x,
double precision y )

Definition at line 3076 of file dblat2.f.

3077*
3078* Auxiliary routine for test program for Level 2 Blas.
3079*
3080* -- Written on 10-August-1987.
3081* Richard Hanson, Sandia National Labs.
3082*
3083* .. Scalar Arguments ..
3084 DOUBLE PRECISION X, Y
3085* .. Executable Statements ..
3086 ddiff = x - y
3087 RETURN
3088*
3089* End of DDIFF
3090*
ddiff
double precision function ddiff(x, y)
Definition dblat2.f:3077

◆ dmake()

subroutine dmake ( character*2 type,
character*1 uplo,
character*1 diag,
integer m,
integer n,
double precision, dimension( nmax, * ) a,
integer nmax,
double precision, dimension( * ) aa,
integer lda,
integer kl,
integer ku,
logical reset,
double precision transl )

Definition at line 2648 of file dblat2.f.

2650*
2651* Generates values for an M by N matrix A within the bandwidth
2652* defined by KL and KU.
2653* Stores the values in the array AA in the data structure required
2654* by the routine, with unwanted elements set to rogue value.
2655*
2656* TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'.
2657*
2658* Auxiliary routine for test program for Level 2 Blas.
2659*
2660* -- Written on 10-August-1987.
2661* Richard Hanson, Sandia National Labs.
2662* Jeremy Du Croz, NAG Central Office.
2663*
2664* .. Parameters ..
2665 DOUBLE PRECISION ZERO, ONE
2666 parameter( zero = 0.0d0, one = 1.0d0 )
2667 DOUBLE PRECISION ROGUE
2668 parameter( rogue = -1.0d10 )
2669* .. Scalar Arguments ..
2670 DOUBLE PRECISION TRANSL
2671 INTEGER KL, KU, LDA, M, N, NMAX
2672 LOGICAL RESET
2673 CHARACTER*1 DIAG, UPLO
2674 CHARACTER*2 TYPE
2675* .. Array Arguments ..
2676 DOUBLE PRECISION A( NMAX, * ), AA( * )
2677* .. Local Scalars ..
2678 INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK
2679 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2680* .. External Functions ..
2681 DOUBLE PRECISION DBEG
2682 EXTERNAL dbeg
2683* .. Intrinsic Functions ..
2684 INTRINSIC max, min
2685* .. Executable Statements ..
2686 gen = TYPE( 1: 1 ).EQ.'G'
2687 sym = TYPE( 1: 1 ).EQ.'S'
2688 tri = TYPE( 1: 1 ).EQ.'T'
2689 upper = ( sym.OR.tri ).AND.uplo.EQ.'U'
2690 lower = ( sym.OR.tri ).AND.uplo.EQ.'L'
2691 unit = tri.AND.diag.EQ.'U'
2692*
2693* Generate data in array A.
2694*
2695 DO 20 j = 1, n
2696 DO 10 i = 1, m
2697 IF( gen.OR.( upper.AND.i.LE.j ).OR.( lower.AND.i.GE.j ) )
2698 $ THEN
2699 IF( ( i.LE.j.AND.j - i.LE.ku ).OR.
2700 $ ( i.GE.j.AND.i - j.LE.kl ) )THEN
2701 a( i, j ) = dbeg( reset ) + transl
2702 ELSE
2703 a( i, j ) = zero
2704 END IF
2705 IF( i.NE.j )THEN
2706 IF( sym )THEN
2707 a( j, i ) = a( i, j )
2708 ELSE IF( tri )THEN
2709 a( j, i ) = zero
2710 END IF
2711 END IF
2712 END IF
2713 10 CONTINUE
2714 IF( tri )
2715 $ a( j, j ) = a( j, j ) + one
2716 IF( unit )
2717 $ a( j, j ) = one
2718 20 CONTINUE
2719*
2720* Store elements in array AS in data structure required by routine.
2721*
2722 IF( type.EQ.'GE' )THEN
2723 DO 50 j = 1, n
2724 DO 30 i = 1, m
2725 aa( i + ( j - 1 )*lda ) = a( i, j )
2726 30 CONTINUE
2727 DO 40 i = m + 1, lda
2728 aa( i + ( j - 1 )*lda ) = rogue
2729 40 CONTINUE
2730 50 CONTINUE
2731 ELSE IF( type.EQ.'GB' )THEN
2732 DO 90 j = 1, n
2733 DO 60 i1 = 1, ku + 1 - j
2734 aa( i1 + ( j - 1 )*lda ) = rogue
2735 60 CONTINUE
2736 DO 70 i2 = i1, min( kl + ku + 1, ku + 1 + m - j )
2737 aa( i2 + ( j - 1 )*lda ) = a( i2 + j - ku - 1, j )
2738 70 CONTINUE
2739 DO 80 i3 = i2, lda
2740 aa( i3 + ( j - 1 )*lda ) = rogue
2741 80 CONTINUE
2742 90 CONTINUE
2743 ELSE IF( type.EQ.'SY'.OR.type.EQ.'TR' )THEN
2744 DO 130 j = 1, n
2745 IF( upper )THEN
2746 ibeg = 1
2747 IF( unit )THEN
2748 iend = j - 1
2749 ELSE
2750 iend = j
2751 END IF
2752 ELSE
2753 IF( unit )THEN
2754 ibeg = j + 1
2755 ELSE
2756 ibeg = j
2757 END IF
2758 iend = n
2759 END IF
2760 DO 100 i = 1, ibeg - 1
2761 aa( i + ( j - 1 )*lda ) = rogue
2762 100 CONTINUE
2763 DO 110 i = ibeg, iend
2764 aa( i + ( j - 1 )*lda ) = a( i, j )
2765 110 CONTINUE
2766 DO 120 i = iend + 1, lda
2767 aa( i + ( j - 1 )*lda ) = rogue
2768 120 CONTINUE
2769 130 CONTINUE
2770 ELSE IF( type.EQ.'SB'.OR.type.EQ.'TB' )THEN
2771 DO 170 j = 1, n
2772 IF( upper )THEN
2773 kk = kl + 1
2774 ibeg = max( 1, kl + 2 - j )
2775 IF( unit )THEN
2776 iend = kl
2777 ELSE
2778 iend = kl + 1
2779 END IF
2780 ELSE
2781 kk = 1
2782 IF( unit )THEN
2783 ibeg = 2
2784 ELSE
2785 ibeg = 1
2786 END IF
2787 iend = min( kl + 1, 1 + m - j )
2788 END IF
2789 DO 140 i = 1, ibeg - 1
2790 aa( i + ( j - 1 )*lda ) = rogue
2791 140 CONTINUE
2792 DO 150 i = ibeg, iend
2793 aa( i + ( j - 1 )*lda ) = a( i + j - kk, j )
2794 150 CONTINUE
2795 DO 160 i = iend + 1, lda
2796 aa( i + ( j - 1 )*lda ) = rogue
2797 160 CONTINUE
2798 170 CONTINUE
2799 ELSE IF( type.EQ.'SP'.OR.type.EQ.'TP' )THEN
2800 ioff = 0
2801 DO 190 j = 1, n
2802 IF( upper )THEN
2803 ibeg = 1
2804 iend = j
2805 ELSE
2806 ibeg = j
2807 iend = n
2808 END IF
2809 DO 180 i = ibeg, iend
2810 ioff = ioff + 1
2811 aa( ioff ) = a( i, j )
2812 IF( i.EQ.j )THEN
2813 IF( unit )
2814 $ aa( ioff ) = rogue
2815 END IF
2816 180 CONTINUE
2817 190 CONTINUE
2818 END IF
2819 RETURN
2820*
2821* End of DMAKE
2822*

◆ dmvch()

subroutine dmvch ( character*1 trans,
integer m,
integer n,
double precision alpha,
double precision, dimension( nmax, * ) a,
integer nmax,
double precision, dimension( * ) x,
integer incx,
double precision beta,
double precision, dimension( * ) y,
integer incy,
double precision, dimension( * ) yt,
double precision, dimension( * ) g,
double precision, dimension( * ) yy,
double precision eps,
double precision err,
logical fatal,
integer nout,
logical mv )

Definition at line 2824 of file dblat2.f.

2826*
2827* Checks the results of the computational tests.
2828*
2829* Auxiliary routine for test program for Level 2 Blas.
2830*
2831* -- Written on 10-August-1987.
2832* Richard Hanson, Sandia National Labs.
2833* Jeremy Du Croz, NAG Central Office.
2834*
2835* .. Parameters ..
2836 DOUBLE PRECISION ZERO, ONE
2837 parameter( zero = 0.0d0, one = 1.0d0 )
2838* .. Scalar Arguments ..
2839 DOUBLE PRECISION ALPHA, BETA, EPS, ERR
2840 INTEGER INCX, INCY, M, N, NMAX, NOUT
2841 LOGICAL FATAL, MV
2842 CHARACTER*1 TRANS
2843* .. Array Arguments ..
2844 DOUBLE PRECISION A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ),
2845 $ YY( * )
2846* .. Local Scalars ..
2847 DOUBLE PRECISION ERRI
2848 INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
2849 LOGICAL TRAN
2850* .. Intrinsic Functions ..
2851 INTRINSIC abs, max, sqrt
2852* .. Executable Statements ..
2853 tran = trans.EQ.'T'.OR.trans.EQ.'C'
2854 IF( tran )THEN
2855 ml = n
2856 nl = m
2857 ELSE
2858 ml = m
2859 nl = n
2860 END IF
2861 IF( incx.LT.0 )THEN
2862 kx = nl
2863 incxl = -1
2864 ELSE
2865 kx = 1
2866 incxl = 1
2867 END IF
2868 IF( incy.LT.0 )THEN
2869 ky = ml
2870 incyl = -1
2871 ELSE
2872 ky = 1
2873 incyl = 1
2874 END IF
2875*
2876* Compute expected result in YT using data in A, X and Y.
2877* Compute gauges in G.
2878*
2879 iy = ky
2880 DO 30 i = 1, ml
2881 yt( iy ) = zero
2882 g( iy ) = zero
2883 jx = kx
2884 IF( tran )THEN
2885 DO 10 j = 1, nl
2886 yt( iy ) = yt( iy ) + a( j, i )*x( jx )
2887 g( iy ) = g( iy ) + abs( a( j, i )*x( jx ) )
2888 jx = jx + incxl
2889 10 CONTINUE
2890 ELSE
2891 DO 20 j = 1, nl
2892 yt( iy ) = yt( iy ) + a( i, j )*x( jx )
2893 g( iy ) = g( iy ) + abs( a( i, j )*x( jx ) )
2894 jx = jx + incxl
2895 20 CONTINUE
2896 END IF
2897 yt( iy ) = alpha*yt( iy ) + beta*y( iy )
2898 g( iy ) = abs( alpha )*g( iy ) + abs( beta*y( iy ) )
2899 iy = iy + incyl
2900 30 CONTINUE
2901*
2902* Compute the error ratio for this result.
2903*
2904 err = zero
2905 DO 40 i = 1, ml
2906 erri = abs( yt( i ) - yy( 1 + ( i - 1 )*abs( incy ) ) )/eps
2907 IF( g( i ).NE.zero )
2908 $ erri = erri/g( i )
2909 err = max( err, erri )
2910 IF( err*sqrt( eps ).GE.one )
2911 $ GO TO 50
2912 40 CONTINUE
2913* If the loop completes, all results are at least half accurate.
2914 GO TO 70
2915*
2916* Report fatal error.
2917*
2918 50 fatal = .true.
2919 WRITE( nout, fmt = 9999 )
2920 DO 60 i = 1, ml
2921 IF( mv )THEN
2922 WRITE( nout, fmt = 9998 )i, yt( i ),
2923 $ yy( 1 + ( i - 1 )*abs( incy ) )
2924 ELSE
2925 WRITE( nout, fmt = 9998 )i,
2926 $ yy( 1 + ( i - 1 )*abs( incy ) ), yt( i )
2927 END IF
2928 60 CONTINUE
2929*
2930 70 CONTINUE
2931 RETURN
2932*
2933 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2934 $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
2935 $ 'TED RESULT' )
2936 9998 FORMAT( 1x, i7, 2g18.6 )
2937*
2938* End of DMVCH
2939*

◆ lde()

logical function lde ( double precision, dimension( * ) ri,
double precision, dimension( * ) rj,
integer lr )

Definition at line 2941 of file dblat2.f.

2942*
2943* Tests if two arrays are identical.
2944*
2945* Auxiliary routine for test program for Level 2 Blas.
2946*
2947* -- Written on 10-August-1987.
2948* Richard Hanson, Sandia National Labs.
2949* Jeremy Du Croz, NAG Central Office.
2950*
2951* .. Scalar Arguments ..
2952 INTEGER LR
2953* .. Array Arguments ..
2954 DOUBLE PRECISION RI( * ), RJ( * )
2955* .. Local Scalars ..
2956 INTEGER I
2957* .. Executable Statements ..
2958 DO 10 i = 1, lr
2959 IF( ri( i ).NE.rj( i ) )
2960 $ GO TO 20
2961 10 CONTINUE
2962 lde = .true.
2963 GO TO 30
2964 20 CONTINUE
2965 lde = .false.
2966 30 RETURN
2967*
2968* End of LDE
2969*

◆ lderes()

logical function lderes ( character*2 type,
character*1 uplo,
integer m,
integer n,
double precision, dimension( lda, * ) aa,
double precision, dimension( lda, * ) as,
integer lda )

Definition at line 2971 of file dblat2.f.

2972*
2973* Tests if selected elements in two arrays are equal.
2974*
2975* TYPE is 'GE', 'SY' or 'SP'.
2976*
2977* Auxiliary routine for test program for Level 2 Blas.
2978*
2979* -- Written on 10-August-1987.
2980* Richard Hanson, Sandia National Labs.
2981* Jeremy Du Croz, NAG Central Office.
2982*
2983* .. Scalar Arguments ..
2984 INTEGER LDA, M, N
2985 CHARACTER*1 UPLO
2986 CHARACTER*2 TYPE
2987* .. Array Arguments ..
2988 DOUBLE PRECISION AA( LDA, * ), AS( LDA, * )
2989* .. Local Scalars ..
2990 INTEGER I, IBEG, IEND, J
2991 LOGICAL UPPER
2992* .. Executable Statements ..
2993 upper = uplo.EQ.'U'
2994 IF( type.EQ.'GE' )THEN
2995 DO 20 j = 1, n
2996 DO 10 i = m + 1, lda
2997 IF( aa( i, j ).NE.as( i, j ) )
2998 $ GO TO 70
2999 10 CONTINUE
3000 20 CONTINUE
3001 ELSE IF( type.EQ.'SY' )THEN
3002 DO 50 j = 1, n
3003 IF( upper )THEN
3004 ibeg = 1
3005 iend = j
3006 ELSE
3007 ibeg = j
3008 iend = n
3009 END IF
3010 DO 30 i = 1, ibeg - 1
3011 IF( aa( i, j ).NE.as( i, j ) )
3012 $ GO TO 70
3013 30 CONTINUE
3014 DO 40 i = iend + 1, lda
3015 IF( aa( i, j ).NE.as( i, j ) )
3016 $ GO TO 70
3017 40 CONTINUE
3018 50 CONTINUE
3019 END IF
3020*
3021 lderes = .true.
3022 GO TO 80
3023 70 CONTINUE
3024 lderes = .false.
3025 80 RETURN
3026*
3027* End of LDERES
3028*

◆ xerbla()

subroutine xerbla ( character*6 srname,
integer info )

Definition at line 3120 of file dblat2.f.

3121*
3122* This is a special version of XERBLA to be used only as part of
3123* the test program for testing error exits from the Level 2 BLAS
3124* routines.
3125*
3126* XERBLA is an error handler for the Level 2 BLAS routines.
3127*
3128* It is called by the Level 2 BLAS routines if an input parameter is
3129* invalid.
3130*
3131* Auxiliary routine for test program for Level 2 Blas.
3132*
3133* -- Written on 10-August-1987.
3134* Richard Hanson, Sandia National Labs.
3135* Jeremy Du Croz, NAG Central Office.
3136*
3137* .. Scalar Arguments ..
3138 INTEGER INFO
3139 CHARACTER*6 SRNAME
3140* .. Scalars in Common ..
3141 INTEGER INFOT, NOUT
3142 LOGICAL LERR, OK
3143 CHARACTER*6 SRNAMT
3144* .. Common blocks ..
3145 COMMON /infoc/infot, nout, ok, lerr
3146 COMMON /srnamc/srnamt
3147* .. Executable Statements ..
3148 lerr = .true.
3149 IF( info.NE.infot )THEN
3150 IF( infot.NE.0 )THEN
3151 WRITE( nout, fmt = 9999 )info, infot
3152 ELSE
3153 WRITE( nout, fmt = 9997 )info
3154 END IF
3155 ok = .false.
3156 END IF
3157 IF( srname.NE.srnamt )THEN
3158 WRITE( nout, fmt = 9998 )srname, srnamt
3159 ok = .false.
3160 END IF
3161 RETURN
3162*
3163 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', i6, ' INSTEAD',
3164 $ ' OF ', i2, ' *******' )
3165 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', a6, ' INSTE',
3166 $ 'AD OF ', a6, ' *******' )
3167 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', i6,
3168 $ ' *******' )
3169*
3170* End of XERBLA
3171*