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

Go to the source code of this file.

Functions/Subroutines

program zblat2
subroutine zchk1 (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, iorder)
subroutine zchk2 (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, iorder)
subroutine zchk3 (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, iorder)
subroutine zchk4 (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, iorder)
subroutine zchk5 (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, iorder)
subroutine zchk6 (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, iorder)
subroutine zmvch (trans, m, n, alpha, a, nmax, x, incx, beta, y, incy, yt, g, yy, eps, err, fatal, nout, mv)
logical function lze (ri, rj, lr)
logical function lzeres (type, uplo, m, n, aa, as, lda)
complex *16 function zbeg (reset)
double precision function ddiff (x, y)
subroutine zmake (type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)

Function/Subroutine Documentation

◆ ddiff()

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

Definition at line 2731 of file c_zblat2.f.

2732*
2733* Auxiliary routine for test program for Level 2 Blas.
2734*
2735* -- Written on 10-August-1987.
2736* Richard Hanson, Sandia National Labs.
2737*
2738* .. Scalar Arguments ..
2739 DOUBLE PRECISION X, Y
2740* .. Executable Statements ..
2741 ddiff = x - y
2742 RETURN
2743*
2744* End of DDIFF.
2745*
ddiff
double precision function ddiff(x, y)
Definition c_zblat2.f:2732

◆ lze()

logical function lze ( complex*16, dimension( * ) ri,
complex*16, dimension( * ) rj,
integer lr )

Definition at line 2589 of file c_zblat2.f.

2590*
2591* Tests if two arrays are identical.
2592*
2593* Auxiliary routine for test program for Level 2 Blas.
2594*
2595* -- Written on 10-August-1987.
2596* Richard Hanson, Sandia National Labs.
2597* Jeremy Du Croz, NAG Central Office.
2598*
2599* .. Scalar Arguments ..
2600 INTEGER LR
2601* .. Array Arguments ..
2602 COMPLEX*16 RI( * ), RJ( * )
2603* .. Local Scalars ..
2604 INTEGER I
2605* .. Executable Statements ..
2606 DO 10 i = 1, lr
2607 IF( ri( i ).NE.rj( i ) )
2608 $ GO TO 20
2609 10 CONTINUE
2610 lze = .true.
2611 GO TO 30
2612 20 CONTINUE
2613 lze = .false.
2614 30 RETURN
2615*
2616* End of LZE.
2617*
lze
logical function lze(ri, rj, lr)
Definition c_zblat2.f:2590

◆ lzeres()

logical function lzeres ( character*2 type,
character*1 uplo,
integer m,
integer n,
complex*16, dimension( lda, * ) aa,
complex*16, dimension( lda, * ) as,
integer lda )

Definition at line 2619 of file c_zblat2.f.

2620*
2621* Tests if selected elements in two arrays are equal.
2622*
2623* TYPE is 'ge', 'he' or 'hp'.
2624*
2625* Auxiliary routine for test program for Level 2 Blas.
2626*
2627* -- Written on 10-August-1987.
2628* Richard Hanson, Sandia National Labs.
2629* Jeremy Du Croz, NAG Central Office.
2630*
2631* .. Scalar Arguments ..
2632 INTEGER LDA, M, N
2633 CHARACTER*1 UPLO
2634 CHARACTER*2 TYPE
2635* .. Array Arguments ..
2636 COMPLEX*16 AA( LDA, * ), AS( LDA, * )
2637* .. Local Scalars ..
2638 INTEGER I, IBEG, IEND, J
2639 LOGICAL UPPER
2640* .. Executable Statements ..
2641 upper = uplo.EQ.'U'
2642 IF( type.EQ.'ge' )THEN
2643 DO 20 j = 1, n
2644 DO 10 i = m + 1, lda
2645 IF( aa( i, j ).NE.as( i, j ) )
2646 $ GO TO 70
2647 10 CONTINUE
2648 20 CONTINUE
2649 ELSE IF( type.EQ.'he' )THEN
2650 DO 50 j = 1, n
2651 IF( upper )THEN
2652 ibeg = 1
2653 iend = j
2654 ELSE
2655 ibeg = j
2656 iend = n
2657 END IF
2658 DO 30 i = 1, ibeg - 1
2659 IF( aa( i, j ).NE.as( i, j ) )
2660 $ GO TO 70
2661 30 CONTINUE
2662 DO 40 i = iend + 1, lda
2663 IF( aa( i, j ).NE.as( i, j ) )
2664 $ GO TO 70
2665 40 CONTINUE
2666 50 CONTINUE
2667 END IF
2668*
2669 60 CONTINUE
2670 lzeres = .true.
2671 GO TO 80
2672 70 CONTINUE
2673 lzeres = .false.
2674 80 RETURN
2675*
2676* End of LZERES.
2677*
lzeres
logical function lzeres(type, uplo, m, n, aa, as, lda)
Definition c_zblat2.f:2620

◆ zbeg()

complex*16 function zbeg ( logical reset)

Definition at line 2679 of file c_zblat2.f.

2680*
2681* Generates complex numbers as pairs of random numbers uniformly
2682* distributed between -0.5 and 0.5.
2683*
2684* Auxiliary routine for test program for Level 2 Blas.
2685*
2686* -- Written on 10-August-1987.
2687* Richard Hanson, Sandia National Labs.
2688* Jeremy Du Croz, NAG Central Office.
2689*
2690* .. Scalar Arguments ..
2691 LOGICAL RESET
2692* .. Local Scalars ..
2693 INTEGER I, IC, J, MI, MJ
2694* .. Save statement ..
2695 SAVE i, ic, j, mi, mj
2696* .. Intrinsic Functions ..
2697 INTRINSIC dcmplx
2698* .. Executable Statements ..
2699 IF( reset )THEN
2700* Initialize local variables.
2701 mi = 891
2702 mj = 457
2703 i = 7
2704 j = 7
2705 ic = 0
2706 reset = .false.
2707 END IF
2708*
2709* The sequence of values of I or J is bounded between 1 and 999.
2710* If initial I or J = 1,2,3,6,7 or 9, the period will be 50.
2711* If initial I or J = 4 or 8, the period will be 25.
2712* If initial I or J = 5, the period will be 10.
2713* IC is used to break up the period by skipping 1 value of I or J
2714* in 6.
2715*
2716 ic = ic + 1
2717 10 i = i*mi
2718 j = j*mj
2719 i = i - 1000*( i/1000 )
2720 j = j - 1000*( j/1000 )
2721 IF( ic.GE.5 )THEN
2722 ic = 0
2723 GO TO 10
2724 END IF
2725 zbeg = dcmplx( ( i - 500 )/1001.0, ( j - 500 )/1001.0 )
2726 RETURN
2727*
2728* End of ZBEG.
2729*
zbeg
complex *16 function zbeg(reset)
Definition c_zblat2.f:2680

◆ zblat2()

program zblat2

Definition at line 1 of file c_zblat2.f.

◆ zchk1()

subroutine zchk1 ( character*12 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,
complex*16, dimension( nalf ) alf,
integer nbet,
complex*16, dimension( nbet ) bet,
integer ninc,
integer, dimension( ninc ) inc,
integer nmax,
integer incmax,
complex*16, dimension( nmax, nmax ) a,
complex*16, dimension( nmax*nmax ) aa,
complex*16, dimension( nmax*nmax ) as,
complex*16, dimension( nmax ) x,
complex*16, dimension( nmax*incmax ) xx,
complex*16, dimension( nmax*incmax ) xs,
complex*16, dimension( nmax ) y,
complex*16, dimension( nmax*incmax ) yy,
complex*16, dimension( nmax*incmax ) ys,
complex*16, dimension( nmax ) yt,
double precision, dimension( nmax ) g,
integer iorder )

Definition at line 462 of file c_zblat2.f.

466*
467* Tests CGEMV and CGBMV.
468*
469* Auxiliary routine for test program for Level 2 Blas.
470*
471* -- Written on 10-August-1987.
472* Richard Hanson, Sandia National Labs.
473* Jeremy Du Croz, NAG Central Office.
474*
475* .. Parameters ..
476 COMPLEX*16 ZERO, HALF
477 parameter( zero = ( 0.0d0, 0.0d0 ),
478 $ half = ( 0.5d0, 0.0d0 ) )
479 DOUBLE PRECISION RZERO
480 parameter( rzero = 0.0d0 )
481* .. Scalar Arguments ..
482 DOUBLE PRECISION EPS, THRESH
483 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
484 $ NOUT, NTRA, IORDER
485 LOGICAL FATAL, REWI, TRACE
486 CHARACTER*12 SNAME
487* .. Array Arguments ..
488 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
489 $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ),
490 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
491 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
492 $ YY( NMAX*INCMAX )
493 DOUBLE PRECISION G( NMAX )
494 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
495* .. Local Scalars ..
496 COMPLEX*16 ALPHA, ALS, BETA, BLS, TRANSL
497 DOUBLE PRECISION ERR, ERRMAX
498 INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
499 $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA,
500 $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK,
501 $ NL, NS
502 LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN
503 CHARACTER*1 TRANS, TRANSS
504 CHARACTER*14 CTRANS
505 CHARACTER*3 ICH
506* .. Local Arrays ..
507 LOGICAL ISAME( 13 )
508* .. External Functions ..
509 LOGICAL LZE, LZERES
510 EXTERNAL lze, lzeres
511* .. External Subroutines ..
512 EXTERNAL czgbmv, czgemv, zmake, zmvch
513* .. Intrinsic Functions ..
514 INTRINSIC abs, max, min
515* .. Scalars in Common ..
516 INTEGER INFOT, NOUTC
517 LOGICAL OK
518* .. Common blocks ..
519 COMMON /infoc/infot, noutc, ok
520* .. Data statements ..
521 DATA ich/'NTC'/
522* .. Executable Statements ..
523 full = sname( 9: 9 ).EQ.'e'
524.EQ. BANDED = SNAME( 9: 9 )'b'
525* Define the number of arguments.
526 IF( FULL )THEN
527 NARGS = 11
528 ELSE IF( BANDED )THEN
529 NARGS = 13
530 END IF
531*
532 NC = 0
533 RESET = .TRUE.
534 ERRMAX = RZERO
535*
536 DO 120 IN = 1, NIDIM
537 N = IDIM( IN )
538 ND = N/2 + 1
539*
540 DO 110 IM = 1, 2
541.EQ. IF( IM1 )
542 $ M = MAX( N - ND, 0 )
543.EQ. IF( IM2 )
544 $ M = MIN( N + ND, NMAX )
545*
546 IF( BANDED )THEN
547 NK = NKB
548 ELSE
549 NK = 1
550 END IF
551 DO 100 IKU = 1, NK
552 IF( BANDED )THEN
553 KU = KB( IKU )
554 KL = MAX( KU - 1, 0 )
555 ELSE
556 KU = N - 1
557 KL = M - 1
558 END IF
559* Set LDA to 1 more than minimum value if room.
560 IF( BANDED )THEN
561 LDA = KL + KU + 1
562 ELSE
563 LDA = M
564 END IF
565.LT. IF( LDANMAX )
566 $ LDA = LDA + 1
567* Skip tests if not enough room.
568.GT. IF( LDANMAX )
569 $ GO TO 100
570 LAA = LDA*N
571.LE..OR..LE. NULL = N0M0
572*
573* Generate the matrix A.
574*
575 TRANSL = ZERO
576 CALL ZMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX, AA,
577 $ LDA, KL, KU, RESET, TRANSL )
578*
579 DO 90 IC = 1, 3
580 TRANS = ICH( IC: IC )
581.EQ. IF (TRANS'n')THEN
582 CTRANS = ' cblasnotrans'
583.EQ. ELSE IF (TRANS't')THEN
584 CTRANS = ' cblastrans'
585 ELSE
586 CTRANS = 'cblasconjtrans'
587 END IF
588.EQ. TRAN = TRANS't.OR..EQ.'TRANS'c'
589*
590 IF( TRAN )THEN
591 ML = N
592 NL = M
593 ELSE
594 ML = M
595 NL = N
596 END IF
597*
598 DO 80 IX = 1, NINC
599 INCX = INC( IX )
600 LX = ABS( INCX )*NL
601*
602* Generate the vector X.
603*
604 TRANSL = HALF
605 CALL ZMAKE( 'ge', ' ', ' ', 1, NL, X, 1, XX,
606 $ ABS( INCX ), 0, NL - 1, RESET, TRANSL )
607.GT. IF( NL1 )THEN
608 X( NL/2 ) = ZERO
609 XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO
610 END IF
611*
612 DO 70 IY = 1, NINC
613 INCY = INC( IY )
614 LY = ABS( INCY )*ML
615*
616 DO 60 IA = 1, NALF
617 ALPHA = ALF( IA )
618*
619 DO 50 IB = 1, NBET
620 BETA = BET( IB )
621*
622* Generate the vector Y.
623*
624 TRANSL = ZERO
625 CALL ZMAKE( 'ge', ' ', ' ', 1, ML, Y, 1,
626 $ YY, ABS( INCY ), 0, ML - 1,
627 $ RESET, TRANSL )
628*
629 NC = NC + 1
630*
631* Save every datum before calling the
632* subroutine.
633*
634 TRANSS = TRANS
635 MS = M
636 NS = N
637 KLS = KL
638 KUS = KU
639 ALS = ALPHA
640 DO 10 I = 1, LAA
641 AS( I ) = AA( I )
642 10 CONTINUE
643 LDAS = LDA
644 DO 20 I = 1, LX
645 XS( I ) = XX( I )
646 20 CONTINUE
647 INCXS = INCX
648 BLS = BETA
649 DO 30 I = 1, LY
650 YS( I ) = YY( I )
651 30 CONTINUE
652 INCYS = INCY
653*
654* Call the subroutine.
655*
656 IF( FULL )THEN
657 IF( TRACE )
658 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
659 $ CTRANS, M, N, ALPHA, LDA, INCX, BETA,
660 $ INCY
661 IF( REWI )
662 $ REWIND NTRA
663 CALL CZGEMV( IORDER, TRANS, M, N,
664 $ ALPHA, AA, LDA, XX, INCX,
665 $ BETA, YY, INCY )
666 ELSE IF( BANDED )THEN
667 IF( TRACE )
668 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
669 $ CTRANS, M, N, KL, KU, ALPHA, LDA,
670 $ INCX, BETA, INCY
671 IF( REWI )
672 $ REWIND NTRA
673 CALL CZGBMV( IORDER, TRANS, M, N, KL,
674 $ KU, ALPHA, AA, LDA, XX,
675 $ INCX, BETA, YY, INCY )
676 END IF
677*
678* Check if error-exit was taken incorrectly.
679*
680.NOT. IF( OK )THEN
681 WRITE( NOUT, FMT = 9993 )
682 FATAL = .TRUE.
683 GO TO 130
684 END IF
685*
686* See what data changed inside subroutines.
687*
688* IF(TRANS .NE. 'C' .OR. (INCX .GT. 0 .AND. INCY .GT. 0)) THEN
689.EQ. ISAME( 1 ) = TRANSTRANSS
690.EQ. ISAME( 2 ) = MSM
691.EQ. ISAME( 3 ) = NSN
692 IF( FULL )THEN
693.EQ. ISAME( 4 ) = ALSALPHA
694 ISAME( 5 ) = LZE( AS, AA, LAA )
695.EQ. ISAME( 6 ) = LDASLDA
696 ISAME( 7 ) = LZE( XS, XX, LX )
697.EQ. ISAME( 8 ) = INCXSINCX
698.EQ. ISAME( 9 ) = BLSBETA
699 IF( NULL )THEN
700 ISAME( 10 ) = LZE( YS, YY, LY )
701 ELSE
702 ISAME( 10 ) = LZERES( 'ge', ' ', 1,
703 $ ML, YS, YY,
704 $ ABS( INCY ) )
705 END IF
706.EQ. ISAME( 11 ) = INCYSINCY
707 ELSE IF( BANDED )THEN
708.EQ. ISAME( 4 ) = KLSKL
709.EQ. ISAME( 5 ) = KUSKU
710.EQ. ISAME( 6 ) = ALSALPHA
711 ISAME( 7 ) = LZE( AS, AA, LAA )
712.EQ. ISAME( 8 ) = LDASLDA
713 ISAME( 9 ) = LZE( XS, XX, LX )
714.EQ. ISAME( 10 ) = INCXSINCX
715.EQ. ISAME( 11 ) = BLSBETA
716 IF( NULL )THEN
717 ISAME( 12 ) = LZE( YS, YY, LY )
718 ELSE
719 ISAME( 12 ) = LZERES( 'ge', ' ', 1,
720 $ ML, YS, YY,
721 $ ABS( INCY ) )
722 END IF
723.EQ. ISAME( 13 ) = INCYSINCY
724 END IF
725*
726* If data was incorrectly changed, report
727* and return.
728*
729 SAME = .TRUE.
730 DO 40 I = 1, NARGS
731.AND. SAME = SAMEISAME( I )
732.NOT. IF( ISAME( I ) )
733 $ WRITE( NOUT, FMT = 9998 )I
734 40 CONTINUE
735.NOT. IF( SAME )THEN
736 FATAL = .TRUE.
737 GO TO 130
738 END IF
739*
740.NOT. IF( NULL )THEN
741*
742* Check the result.
743*
744 CALL ZMVCH( TRANS, M, N, ALPHA, A,
745 $ NMAX, X, INCX, BETA, Y,
746 $ INCY, YT, G, YY, EPS, ERR,
747 $ FATAL, NOUT, .TRUE. )
748 ERRMAX = MAX( ERRMAX, ERR )
749* If got really bad answer, report and
750* return.
751 IF( FATAL )
752 $ GO TO 130
753 ELSE
754* Avoid repeating tests with M.le.0 or
755* N.le.0.
756 GO TO 110
757 END IF
758* END IF
759*
760 50 CONTINUE
761*
762 60 CONTINUE
763*
764 70 CONTINUE
765*
766 80 CONTINUE
767*
768 90 CONTINUE
769*
770 100 CONTINUE
771*
772 110 CONTINUE
773*
774 120 CONTINUE
775*
776* Report result.
777*
778.LT. IF( ERRMAXTHRESH )THEN
779 WRITE( NOUT, FMT = 9999 )SNAME, NC
780 ELSE
781 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
782 END IF
783 GO TO 140
784*
785 130 CONTINUE
786 WRITE( NOUT, FMT = 9996 )SNAME
787 IF( FULL )THEN
788 WRITE( NOUT, FMT = 9994 )NC, SNAME, CTRANS, M, N, ALPHA, LDA,
789 $ INCX, BETA, INCY
790 ELSE IF( BANDED )THEN
791 WRITE( NOUT, FMT = 9995 )NC, SNAME, CTRANS, M, N, KL, KU,
792 $ ALPHA, LDA, INCX, BETA, INCY
793 END IF
794*
795 140 CONTINUE
796 RETURN
797*
798 9999 FORMAT(' ',A12, ' passed the computational tests(', I6, ' call',
799 $ 's)' )
800 9998 FORMAT(' ******* fatal error - PARAMETER number ', i2, ' WAS CH',
801 $ 'ANGED INCORRECTLY *******' )
802 9997 FORMAT(' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
803 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
804 $ ' - SUSPECT *******' )
805 9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
806 9995 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', 4( i3, ',' ), '(',
807 $ f4.1, ',', f4.1, '), A,',/ 10x, i3, ', X,', i2, ',(',
808 $ f4.1, ',', f4.1, '), Y,', i2, ') .' )
809 9994 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', 2( i3, ',' ), '(',
810 $ f4.1, ',', F4.1, '), a,',/ 10x, I3, ', x,', I2, ',(',
811 $ F4.1, ',', F4.1, '), y,', I2, ') .' )
812 9993 FORMAT(' ******* fatal error - error-EXIT taken on valid CALL *',
813 $ '******' )
814*
815* End of ZCHK1.
816*
zmvch
subroutine zmvch(trans, m, n, alpha, a, nmax, x, incx, beta, y, incy, yt, g, yy, eps, err, fatal, nout, mv)
Definition c_zblat2.f:2459
zmake
subroutine zmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition c_zblat2.f:2749
the
end diagonal values have been computed in the(sparse) matrix id.SOL
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
fatal
void fatal(char *msg)
Definition sys_pipes_c.c:76

◆ zchk2()

subroutine zchk2 ( character*12 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,
complex*16, dimension( nalf ) alf,
integer nbet,
complex*16, dimension( nbet ) bet,
integer ninc,
integer, dimension( ninc ) inc,
integer nmax,
integer incmax,
complex*16, dimension( nmax, nmax ) a,
complex*16, dimension( nmax*nmax ) aa,
complex*16, dimension( nmax*nmax ) as,
complex*16, dimension( nmax ) x,
complex*16, dimension( nmax*incmax ) xx,
complex*16, dimension( nmax*incmax ) xs,
complex*16, dimension( nmax ) y,
complex*16, dimension( nmax*incmax ) yy,
complex*16, dimension( nmax*incmax ) ys,
complex*16, dimension( nmax ) yt,
double precision, dimension( nmax ) g,
integer iorder )

Definition at line 818 of file c_zblat2.f.

822*
823* Tests CHEMV, CHBMV and CHPMV.
824*
825* Auxiliary routine for test program for Level 2 Blas.
826*
827* -- Written on 10-August-1987.
828* Richard Hanson, Sandia National Labs.
829* Jeremy Du Croz, NAG Central Office.
830*
831* .. Parameters ..
832 COMPLEX*16 ZERO, HALF
833 parameter( zero = ( 0.0d0, 0.0d0 ),
834 $ half = ( 0.5d0, 0.0d0 ) )
835 DOUBLE PRECISION RZERO
836 parameter( rzero = 0.0d0 )
837* .. Scalar Arguments ..
838 DOUBLE PRECISION EPS, THRESH
839 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
840 $ NOUT, NTRA, IORDER
841 LOGICAL FATAL, REWI, TRACE
842 CHARACTER*12 SNAME
843* .. Array Arguments ..
844 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
845 $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ),
846 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
847 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
848 $ YY( NMAX*INCMAX )
849 DOUBLE PRECISION G( NMAX )
850 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
851* .. Local Scalars ..
852 COMPLEX*16 ALPHA, ALS, BETA, BLS, TRANSL
853 DOUBLE PRECISION ERR, ERRMAX
854 INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
855 $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY,
856 $ N, NARGS, NC, NK, NS
857 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
858 CHARACTER*1 UPLO, UPLOS
859 CHARACTER*14 CUPLO
860 CHARACTER*2 ICH
861* .. Local Arrays ..
862 LOGICAL ISAME( 13 )
863* .. External Functions ..
864 LOGICAL LZE, LZERES
865 EXTERNAL lze, lzeres
866* .. External Subroutines ..
867 EXTERNAL czhbmv, czhemv, czhpmv, zmake, zmvch
868* .. Intrinsic Functions ..
869 INTRINSIC abs, max
870* .. Scalars in Common ..
871 INTEGER INFOT, NOUTC
872 LOGICAL OK
873* .. Common blocks ..
874 COMMON /infoc/infot, noutc, ok
875* .. Data statements ..
876 DATA ich/'UL'/
877* .. Executable Statements ..
878 full = sname( 9: 9 ).EQ.'e'
879 banded = sname( 9: 9 ).EQ.'b'
880 packed = sname( 9: 9 ).EQ.'p'
881* Define the number of arguments.
882 IF( full )THEN
883 nargs = 10
884 ELSE IF( banded )THEN
885 nargs = 11
886 ELSE IF( packed )THEN
887 nargs = 9
888 END IF
889*
890 nc = 0
891 reset = .true.
892 errmax = rzero
893*
894 DO 110 in = 1, nidim
895 n = idim( in )
896*
897 IF( banded )THEN
898 nk = nkb
899 ELSE
900 nk = 1
901 END IF
902 DO 100 ik = 1, nk
903 IF( banded )THEN
904 k = kb( ik )
905 ELSE
906 k = n - 1
907 END IF
908* Set LDA to 1 more than minimum value if room.
909 IF( banded )THEN
910 lda = k + 1
911 ELSE
912 lda = n
913 END IF
914 IF( lda.LT.nmax )
915 $ lda = lda + 1
916* Skip tests if not enough room.
917 IF( lda.GT.nmax )
918 $ GO TO 100
919 IF( packed )THEN
920 laa = ( n*( n + 1 ) )/2
921 ELSE
922 laa = lda*n
923 END IF
924 null = n.LE.0
925*
926 DO 90 ic = 1, 2
927 uplo = ich( ic: ic )
928 IF (uplo.EQ.'U')THEN
929 cuplo = ' CblasUpper'
930 ELSE
931 cuplo = ' CblasLower'
932 END IF
933*
934* Generate the matrix A.
935*
936 transl = zero
937 CALL zmake( sname( 8: 9 ), uplo, ' ', n, n, a, nmax, aa,
938 $ lda, k, k, reset, transl )
939*
940 DO 80 ix = 1, ninc
941 incx = inc( ix )
942 lx = abs( incx )*n
943*
944* Generate the vector X.
945*
946 transl = half
947 CALL zmake( 'ge', ' ', ' ', 1, n, x, 1, xx,
948 $ abs( incx ), 0, n - 1, reset, transl )
949 IF( n.GT.1 )THEN
950 x( n/2 ) = zero
951 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
952 END IF
953*
954 DO 70 iy = 1, ninc
955 incy = inc( iy )
956 ly = abs( incy )*n
957*
958 DO 60 ia = 1, nalf
959 alpha = alf( ia )
960*
961 DO 50 ib = 1, nbet
962 beta = bet( ib )
963*
964* Generate the vector Y.
965*
966 transl = zero
967 CALL zmake( 'ge', ' ', ' ', 1, n, y, 1, yy,
968 $ abs( incy ), 0, n - 1, reset,
969 $ transl )
970*
971 nc = nc + 1
972*
973* Save every datum before calling the
974* subroutine.
975*
976 uplos = uplo
977 ns = n
978 ks = k
979 als = alpha
980 DO 10 i = 1, laa
981 as( i ) = aa( i )
982 10 CONTINUE
983 ldas = lda
984 DO 20 i = 1, lx
985 xs( i ) = xx( i )
986 20 CONTINUE
987 incxs = incx
988 bls = beta
989 DO 30 i = 1, ly
990 ys( i ) = yy( i )
991 30 CONTINUE
992 incys = incy
993*
994* Call the subroutine.
995*
996 IF( full )THEN
997 IF( trace )
998 $ WRITE( ntra, fmt = 9993 )nc, sname,
999 $ cuplo, n, alpha, lda, incx, beta, incy
1000 IF( rewi )
1001 $ rewind ntra
1002 CALL czhemv( iorder, uplo, n, alpha, aa,
1003 $ lda, xx, incx, beta, yy,
1004 $ incy )
1005 ELSE IF( banded )THEN
1006 IF( trace )
1007 $ WRITE( ntra, fmt = 9994 )nc, sname,
1008 $ cuplo, n, k, alpha, lda, incx, beta,
1009 $ incy
1010 IF( rewi )
1011 $ rewind ntra
1012 CALL czhbmv( iorder, uplo, n, k, alpha,
1013 $ aa, lda, xx, incx, beta,
1014 $ yy, incy )
1015 ELSE IF( packed )THEN
1016 IF( trace )
1017 $ WRITE( ntra, fmt = 9995 )nc, sname,
1018 $ cuplo, n, alpha, incx, beta, incy
1019 IF( rewi )
1020 $ rewind ntra
1021 CALL czhpmv( iorder, uplo, n, alpha, aa,
1022 $ xx, incx, beta, yy, incy )
1023 END IF
1024*
1025* Check if error-exit was taken incorrectly.
1026*
1027 IF( .NOT.ok )THEN
1028 WRITE( nout, fmt = 9992 )
1029 fatal = .true.
1030 GO TO 120
1031 END IF
1032*
1033* See what data changed inside subroutines.
1034*
1035 isame( 1 ) = uplo.EQ.uplos
1036 isame( 2 ) = ns.EQ.n
1037 IF( full )THEN
1038 isame( 3 ) = als.EQ.alpha
1039 isame( 4 ) = lze( as, aa, laa )
1040 isame( 5 ) = ldas.EQ.lda
1041 isame( 6 ) = lze( xs, xx, lx )
1042 isame( 7 ) = incxs.EQ.incx
1043 isame( 8 ) = bls.EQ.beta
1044 IF( null )THEN
1045 isame( 9 ) = lze( ys, yy, ly )
1046 ELSE
1047 isame( 9 ) = lzeres( 'ge', ' ', 1, n,
1048 $ ys, yy, abs( incy ) )
1049 END IF
1050 isame( 10 ) = incys.EQ.incy
1051 ELSE IF( banded )THEN
1052 isame( 3 ) = ks.EQ.k
1053 isame( 4 ) = als.EQ.alpha
1054 isame( 5 ) = lze( as, aa, laa )
1055 isame( 6 ) = ldas.EQ.lda
1056 isame( 7 ) = lze( xs, xx, lx )
1057 isame( 8 ) = incxs.EQ.incx
1058 isame( 9 ) = bls.EQ.beta
1059 IF( null )THEN
1060 isame( 10 ) = lze( ys, yy, ly )
1061 ELSE
1062 isame( 10 ) = lzeres( 'ge', ' ', 1, n,
1063 $ ys, yy, abs( incy ) )
1064 END IF
1065 isame( 11 ) = incys.EQ.incy
1066 ELSE IF( packed )THEN
1067 isame( 3 ) = als.EQ.alpha
1068 isame( 4 ) = lze( as, aa, laa )
1069 isame( 5 ) = lze( xs, xx, lx )
1070 isame( 6 ) = incxs.EQ.incx
1071 isame( 7 ) = bls.EQ.beta
1072 IF( null )THEN
1073 isame( 8 ) = lze( ys, yy, ly )
1074 ELSE
1075 isame( 8 ) = lzeres( 'ge', ' ', 1, n,
1076 $ ys, yy, abs( incy ) )
1077 END IF
1078 isame( 9 ) = incys.EQ.incy
1079 END IF
1080*
1081* If data was incorrectly changed, report and
1082* return.
1083*
1084 same = .true.
1085 DO 40 i = 1, nargs
1086 same = same.AND.isame( i )
1087 IF( .NOT.isame( i ) )
1088 $ WRITE( nout, fmt = 9998 )i
1089 40 CONTINUE
1090 IF( .NOT.same )THEN
1091 fatal = .true.
1092 GO TO 120
1093 END IF
1094*
1095 IF( .NOT.null )THEN
1096*
1097* Check the result.
1098*
1099 CALL zmvch( 'N', n, n, alpha, a, nmax, x,
1100 $ incx, beta, y, incy, yt, g,
1101 $ yy, eps, err, fatal, nout,
1102 $ .true. )
1103 errmax = max( errmax, err )
1104* If got really bad answer, report and
1105* return.
1106 IF( fatal )
1107 $ GO TO 120
1108 ELSE
1109* Avoid repeating tests with N.le.0
1110 GO TO 110
1111 END IF
1112*
1113 50 CONTINUE
1114*
1115 60 CONTINUE
1116*
1117 70 CONTINUE
1118*
1119 80 CONTINUE
1120*
1121 90 CONTINUE
1122*
1123 100 CONTINUE
1124*
1125 110 CONTINUE
1126*
1127* Report result.
1128*
1129 IF( errmax.LT.thresh )THEN
1130 WRITE( nout, fmt = 9999 )sname, nc
1131 ELSE
1132 WRITE( nout, fmt = 9997 )sname, nc, errmax
1133 END IF
1134 GO TO 130
1135*
1136 120 CONTINUE
1137 WRITE( nout, fmt = 9996 )sname
1138 IF( full )THEN
1139 WRITE( nout, fmt = 9993 )nc, sname, cuplo, n, alpha, lda, incx,
1140 $ beta, incy
1141 ELSE IF( banded )THEN
1142 WRITE( nout, fmt = 9994 )nc, sname, cuplo, n, k, alpha, lda,
1143 $ incx, beta, incy
1144 ELSE IF( packed )THEN
1145 WRITE( nout, fmt = 9995 )nc, sname, cuplo, n, alpha, incx,
1146 $ beta, incy
1147 END IF
1148*
1149 130 CONTINUE
1150 RETURN
1151*
1152 9999 FORMAT(' ',a12, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1153 $ 'S)' )
1154 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1155 $ 'ANGED INCORRECTLY *******' )
1156 9997 FORMAT(' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1157 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1158 $ ' - SUSPECT *******' )
1159 9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
1160 9995 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', i3, ',(', f4.1, ',',
1161 $ f4.1, '), AP, X,',/ 10x, i2, ',(', f4.1, ',', f4.1,
1162 $ '), Y,', i2, ') .' )
1163 9994 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', 2( i3, ',' ), '(',
1164 $ f4.1, ',', f4.1, '), A,', i3, ', X,',/ 10x, i2, ',(',
1165 $ f4.1, ',', f4.1, '), Y,', i2, ') .' )
1166 9993 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', i3, ',(', f4.1, ',',
1167 $ f4.1, '), A,', i3, ', X,',/ 10x, i2, ',(', f4.1, ',',
1168 $ f4.1, '), ', 'Y,', i2, ') .' )
1169 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1170 $ '******' )
1171*
1172* End of CZHK2.
1173*
alpha
#define alpha
Definition eval.h:35

◆ zchk3()

subroutine zchk3 ( character*12 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,
complex*16, dimension( nmax, nmax ) a,
complex*16, dimension( nmax*nmax ) aa,
complex*16, dimension( nmax*nmax ) as,
complex*16, dimension( nmax ) x,
complex*16, dimension( nmax*incmax ) xx,
complex*16, dimension( nmax*incmax ) xs,
complex*16, dimension( nmax ) xt,
double precision, dimension( nmax ) g,
complex*16, dimension( nmax ) z,
integer iorder )

Definition at line 1175 of file c_zblat2.f.

1178*
1179* Tests ZTRMV, ZTBMV, ZTPMV, ZTRSV, ZTBSV and ZTPSV.
1180*
1181* Auxiliary routine for test program for Level 2 Blas.
1182*
1183* -- Written on 10-August-1987.
1184* Richard Hanson, Sandia National Labs.
1185* Jeremy Du Croz, NAG Central Office.
1186*
1187* .. Parameters ..
1188 COMPLEX*16 ZERO, HALF, ONE
1189 parameter( zero = ( 0.0d0, 0.0d0 ),
1190 $ half = ( 0.5d0, 0.0d0 ),
1191 $ one = ( 1.0d0, 0.0d0 ) )
1192 DOUBLE PRECISION RZERO
1193 parameter( rzero = 0.0d0 )
1194* .. Scalar Arguments ..
1195 DOUBLE PRECISION EPS, THRESH
1196 INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA,
1197 $ IORDER
1198 LOGICAL FATAL, REWI, TRACE
1199 CHARACTER*12 SNAME
1200* .. Array Arguments ..
1201 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ),
1202 $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
1203 $ XT( NMAX ), XX( NMAX*INCMAX ), Z( NMAX )
1204 DOUBLE PRECISION G( NMAX )
1205 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
1206* .. Local Scalars ..
1207 COMPLEX*16 TRANSL
1208 DOUBLE PRECISION ERR, ERRMAX
1209 INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
1210 $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
1211 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
1212 CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
1213 CHARACTER*14 CUPLO,CTRANS,CDIAG
1214 CHARACTER*2 ICHD, ICHU
1215 CHARACTER*3 ICHT
1216* .. Local Arrays ..
1217 LOGICAL ISAME( 13 )
1218* .. External Functions ..
1219 LOGICAL LZE, LZERES
1220 EXTERNAL lze, lzeres
1221* .. External Subroutines ..
1222 EXTERNAL zmake, zmvch, cztbmv, cztbsv, cztpmv,
1223 $ cztpsv, cztrmv, cztrsv
1224* .. Intrinsic Functions ..
1225 INTRINSIC abs, max
1226* .. Scalars in Common ..
1227 INTEGER INFOT, NOUTC
1228 LOGICAL OK
1229* .. Common blocks ..
1230 COMMON /infoc/infot, noutc, ok
1231* .. Data statements ..
1232 DATA ichu/'UL'/, icht/'NTC'/, ichd/'UN'/
1233* .. Executable Statements ..
1234 full = sname( 9: 9 ).EQ.'r'
1235 banded = sname( 9: 9 ).EQ.'b'
1236 packed = sname( 9: 9 ).EQ.'p'
1237* Define the number of arguments.
1238 IF( full )THEN
1239 nargs = 8
1240 ELSE IF( banded )THEN
1241 nargs = 9
1242 ELSE IF( packed )THEN
1243 nargs = 7
1244 END IF
1245*
1246 nc = 0
1247 reset = .true.
1248 errmax = rzero
1249* Set up zero vector for ZMVCH.
1250 DO 10 i = 1, nmax
1251 z( i ) = zero
1252 10 CONTINUE
1253*
1254 DO 110 in = 1, nidim
1255 n = idim( in )
1256*
1257 IF( banded )THEN
1258 nk = nkb
1259 ELSE
1260 nk = 1
1261 END IF
1262 DO 100 ik = 1, nk
1263 IF( banded )THEN
1264 k = kb( ik )
1265 ELSE
1266 k = n - 1
1267 END IF
1268* Set LDA to 1 more than minimum value if room.
1269 IF( banded )THEN
1270 lda = k + 1
1271 ELSE
1272 lda = n
1273 END IF
1274 IF( lda.LT.nmax )
1275 $ lda = lda + 1
1276* Skip tests if not enough room.
1277 IF( lda.GT.nmax )
1278 $ GO TO 100
1279 IF( packed )THEN
1280 laa = ( n*( n + 1 ) )/2
1281 ELSE
1282 laa = lda*n
1283 END IF
1284 null = n.LE.0
1285*
1286 DO 90 icu = 1, 2
1287 uplo = ichu( icu: icu )
1288 IF (uplo.EQ.'U')THEN
1289 cuplo = ' CblasUpper'
1290 ELSE
1291 cuplo = ' CblasLower'
1292 END IF
1293*
1294 DO 80 ict = 1, 3
1295 trans = icht( ict: ict )
1296 IF (trans.EQ.'N')THEN
1297 ctrans = ' CblasNoTrans'
1298 ELSE IF (trans.EQ.'T')THEN
1299 ctrans = ' CblasTrans'
1300 ELSE
1301 ctrans = 'CblasConjTrans'
1302 END IF
1303*
1304 DO 70 icd = 1, 2
1305 diag = ichd( icd: icd )
1306 IF (diag.EQ.'N')THEN
1307 cdiag = ' CblasNonUnit'
1308 ELSE
1309 cdiag = ' CblasUnit'
1310 END IF
1311*
1312* Generate the matrix A.
1313*
1314 transl = zero
1315 CALL zmake( sname( 8: 9 ), uplo, diag, n, n, a,
1316 $ nmax, aa, lda, k, k, reset, transl )
1317*
1318 DO 60 ix = 1, ninc
1319 incx = inc( ix )
1320 lx = abs( incx )*n
1321*
1322* Generate the vector X.
1323*
1324 transl = half
1325 CALL zmake( 'ge', ' ', ' ', 1, n, x, 1, xx,
1326 $ abs( incx ), 0, n - 1, reset,
1327 $ transl )
1328 IF( n.GT.1 )THEN
1329 x( n/2 ) = zero
1330 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1331 END IF
1332*
1333 nc = nc + 1
1334*
1335* Save every datum before calling the subroutine.
1336*
1337 uplos = uplo
1338 transs = trans
1339 diags = diag
1340 ns = n
1341 ks = k
1342 DO 20 i = 1, laa
1343 as( i ) = aa( i )
1344 20 CONTINUE
1345 ldas = lda
1346 DO 30 i = 1, lx
1347 xs( i ) = xx( i )
1348 30 CONTINUE
1349 incxs = incx
1350*
1351* Call the subroutine.
1352*
1353 IF( sname( 10: 11 ).EQ.'mv' )THEN
1354 IF( full )THEN
1355 IF( trace )
1356 $ WRITE( ntra, fmt = 9993 )nc, sname,
1357 $ cuplo, ctrans, cdiag, n, lda, incx
1358 IF( rewi )
1359 $ rewind ntra
1360 CALL cztrmv( iorder, uplo, trans, diag,
1361 $ n, aa, lda, xx, incx )
1362 ELSE IF( banded )THEN
1363 IF( trace )
1364 $ WRITE( ntra, fmt = 9994 )nc, sname,
1365 $ cuplo, ctrans, cdiag, n, k, lda, incx
1366 IF( rewi )
1367 $ rewind ntra
1368 CALL cztbmv( iorder, uplo, trans, diag,
1369 $ n, k, aa, lda, xx, incx )
1370 ELSE IF( packed )THEN
1371 IF( trace )
1372 $ WRITE( ntra, fmt = 9995 )nc, sname,
1373 $ cuplo, ctrans, cdiag, n, incx
1374 IF( rewi )
1375 $ rewind ntra
1376 CALL cztpmv( iorder, uplo, trans, diag,
1377 $ n, aa, xx, incx )
1378 END IF
1379 ELSE IF( sname( 10: 11 ).EQ.'sv' )THEN
1380 IF( full )THEN
1381 IF( trace )
1382 $ WRITE( ntra, fmt = 9993 )nc, sname,
1383 $ cuplo, ctrans, cdiag, n, lda, incx
1384 IF( rewi )
1385 $ rewind ntra
1386 CALL cztrsv( iorder, uplo, trans, diag,
1387 $ n, aa, lda, xx, incx )
1388 ELSE IF( banded )THEN
1389 IF( trace )
1390 $ WRITE( ntra, fmt = 9994 )nc, sname,
1391 $ cuplo, ctrans, cdiag, n, k, lda, incx
1392 IF( rewi )
1393 $ rewind ntra
1394 CALL cztbsv( iorder, uplo, trans, diag,
1395 $ n, k, aa, lda, xx, incx )
1396 ELSE IF( packed )THEN
1397 IF( trace )
1398 $ WRITE( ntra, fmt = 9995 )nc, sname,
1399 $ cuplo, ctrans, cdiag, n, incx
1400 IF( rewi )
1401 $ rewind ntra
1402 CALL cztpsv( iorder, uplo, trans, diag,
1403 $ n, aa, xx, incx )
1404 END IF
1405 END IF
1406*
1407* Check if error-exit was taken incorrectly.
1408*
1409 IF( .NOT.ok )THEN
1410 WRITE( nout, fmt = 9992 )
1411 fatal = .true.
1412 GO TO 120
1413 END IF
1414*
1415* See what data changed inside subroutines.
1416*
1417 isame( 1 ) = uplo.EQ.uplos
1418 isame( 2 ) = trans.EQ.transs
1419 isame( 3 ) = diag.EQ.diags
1420 isame( 4 ) = ns.EQ.n
1421 IF( full )THEN
1422 isame( 5 ) = lze( as, aa, laa )
1423 isame( 6 ) = ldas.EQ.lda
1424 IF( null )THEN
1425 isame( 7 ) = lze( xs, xx, lx )
1426 ELSE
1427 isame( 7 ) = lzeres( 'ge', ' ', 1, n, xs,
1428 $ xx, abs( incx ) )
1429 END IF
1430 isame( 8 ) = incxs.EQ.incx
1431 ELSE IF( banded )THEN
1432 isame( 5 ) = ks.EQ.k
1433 isame( 6 ) = lze( as, aa, laa )
1434 isame( 7 ) = ldas.EQ.lda
1435 IF( null )THEN
1436 isame( 8 ) = lze( xs, xx, lx )
1437 ELSE
1438 isame( 8 ) = lzeres( 'ge', ' ', 1, n, xs,
1439 $ xx, abs( incx ) )
1440 END IF
1441 isame( 9 ) = incxs.EQ.incx
1442 ELSE IF( packed )THEN
1443 isame( 5 ) = lze( as, aa, laa )
1444 IF( null )THEN
1445 isame( 6 ) = lze( xs, xx, lx )
1446 ELSE
1447 isame( 6 ) = lzeres( 'ge', ' ', 1, n, xs,
1448 $ xx, abs( incx ) )
1449 END IF
1450 isame( 7 ) = incxs.EQ.incx
1451 END IF
1452*
1453* If data was incorrectly changed, report and
1454* return.
1455*
1456 same = .true.
1457 DO 40 i = 1, nargs
1458 same = same.AND.isame( i )
1459 IF( .NOT.isame( i ) )
1460 $ WRITE( nout, fmt = 9998 )i
1461 40 CONTINUE
1462 IF( .NOT.same )THEN
1463 fatal = .true.
1464 GO TO 120
1465 END IF
1466*
1467 IF( .NOT.null )THEN
1468 IF( sname( 10: 11 ).EQ.'mv' )THEN
1469*
1470* Check the result.
1471*
1472 CALL zmvch( trans, n, n, one, a, nmax, x,
1473 $ incx, zero, z, incx, xt, g,
1474 $ xx, eps, err, fatal, nout,
1475 $ .true. )
1476 ELSE IF( sname( 10: 11 ).EQ.'sv' )THEN
1477*
1478* Compute approximation to original vector.
1479*
1480 DO 50 i = 1, n
1481 z( i ) = xx( 1 + ( i - 1 )*
1482 $ abs( incx ) )
1483 xx( 1 + ( i - 1 )*abs( incx ) )
1484 $ = x( i )
1485 50 CONTINUE
1486 CALL zmvch( trans, n, n, one, a, nmax, z,
1487 $ incx, zero, x, incx, xt, g,
1488 $ xx, eps, err, fatal, nout,
1489 $ .false. )
1490 END IF
1491 errmax = max( errmax, err )
1492* If got really bad answer, report and return.
1493 IF( fatal )
1494 $ GO TO 120
1495 ELSE
1496* Avoid repeating tests with N.le.0.
1497 GO TO 110
1498 END IF
1499*
1500 60 CONTINUE
1501*
1502 70 CONTINUE
1503*
1504 80 CONTINUE
1505*
1506 90 CONTINUE
1507*
1508 100 CONTINUE
1509*
1510 110 CONTINUE
1511*
1512* Report result.
1513*
1514 IF( errmax.LT.thresh )THEN
1515 WRITE( nout, fmt = 9999 )sname, nc
1516 ELSE
1517 WRITE( nout, fmt = 9997 )sname, nc, errmax
1518 END IF
1519 GO TO 130
1520*
1521 120 CONTINUE
1522 WRITE( nout, fmt = 9996 )sname
1523 IF( full )THEN
1524 WRITE( nout, fmt = 9993 )nc, sname, cuplo, ctrans, cdiag, n,
1525 $ lda, incx
1526 ELSE IF( banded )THEN
1527 WRITE( nout, fmt = 9994 )nc, sname, cuplo, ctrans, cdiag, n, k,
1528 $ lda, incx
1529 ELSE IF( packed )THEN
1530 WRITE( nout, fmt = 9995 )nc, sname, cuplo, ctrans, cdiag, n,
1531 $ incx
1532 END IF
1533*
1534 130 CONTINUE
1535 RETURN
1536*
1537 9999 FORMAT(' ',a12, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1538 $ 'S)' )
1539 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1540 $ 'ANGED INCORRECTLY *******' )
1541 9997 FORMAT(' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1542 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1543 $ ' - SUSPECT *******' )
1544 9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
1545 9995 FORMAT(1x, i6, ': ',a12, '(', 3( a14, ',' ),/ 10x, i3, ', AP, ',
1546 $ 'X,', i2, ') .' )
1547 9994 FORMAT(1x, i6, ': ',a12, '(', 3( a14, ',' ),/ 10x, 2( i3, ',' ),
1548 $ ' A,', i3, ', X,', i2, ') .' )
1549 9993 FORMAT( 1x, i6, ': ',a12, '(', 3( a14, ',' ),/ 10x, i3, ', A,',
1550 $ i3, ', X,', i2, ') .' )
1551 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1552 $ '******' )
1553*
1554* End of ZCHK3.
1555*

◆ zchk4()

subroutine zchk4 ( character*12 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,
complex*16, dimension( nalf ) alf,
integer ninc,
integer, dimension( ninc ) inc,
integer nmax,
integer incmax,
complex*16, dimension( nmax, nmax ) a,
complex*16, dimension( nmax*nmax ) aa,
complex*16, dimension( nmax*nmax ) as,
complex*16, dimension( nmax ) x,
complex*16, dimension( nmax*incmax ) xx,
complex*16, dimension( nmax*incmax ) xs,
complex*16, dimension( nmax ) y,
complex*16, dimension( nmax*incmax ) yy,
complex*16, dimension( nmax*incmax ) ys,
complex*16, dimension( nmax ) yt,
double precision, dimension( nmax ) g,
complex*16, dimension( nmax ) z,
integer iorder )

Definition at line 1557 of file c_zblat2.f.

1561*
1562* Tests ZGERC and ZGERU.
1563*
1564* Auxiliary routine for test program for Level 2 Blas.
1565*
1566* -- Written on 10-August-1987.
1567* Richard Hanson, Sandia National Labs.
1568* Jeremy Du Croz, NAG Central Office.
1569*
1570* .. Parameters ..
1571 COMPLEX*16 ZERO, HALF, ONE
1572 parameter( zero = ( 0.0d0, 0.0d0 ),
1573 $ half = ( 0.5d0, 0.0d0 ),
1574 $ one = ( 1.0d0, 0.0d0 ) )
1575 DOUBLE PRECISION RZERO
1576 parameter( rzero = 0.0d0 )
1577* .. Scalar Arguments ..
1578 DOUBLE PRECISION EPS, THRESH
1579 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
1580 $ IORDER
1581 LOGICAL FATAL, REWI, TRACE
1582 CHARACTER*12 SNAME
1583* .. Array Arguments ..
1584 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1585 $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
1586 $ XX( NMAX*INCMAX ), Y( NMAX ),
1587 $ YS( NMAX*INCMAX ), YT( NMAX ),
1588 $ YY( NMAX*INCMAX ), Z( NMAX )
1589 DOUBLE PRECISION G( NMAX )
1590 INTEGER IDIM( NIDIM ), INC( NINC )
1591* .. Local Scalars ..
1592 COMPLEX*16 ALPHA, ALS, TRANSL
1593 DOUBLE PRECISION ERR, ERRMAX
1594 INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
1595 $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
1596 $ NC, ND, NS
1597 LOGICAL CONJ, NULL, RESET, SAME
1598* .. Local Arrays ..
1599 COMPLEX*16 W( 1 )
1600 LOGICAL ISAME( 13 )
1601* .. External Functions ..
1602 LOGICAL LZE, LZERES
1603 EXTERNAL lze, lzeres
1604* .. External Subroutines ..
1605 EXTERNAL czgerc, czgeru, zmake, zmvch
1606* .. Intrinsic Functions ..
1607 INTRINSIC abs, dconjg, max, min
1608* .. Scalars in Common ..
1609 INTEGER INFOT, NOUTC
1610 LOGICAL OK
1611* .. Common blocks ..
1612 COMMON /infoc/infot, noutc, ok
1613* .. Executable Statements ..
1614 conj = sname( 11: 11 ).EQ.'c'
1615* Define the number of arguments.
1616 nargs = 9
1617*
1618 nc = 0
1619 reset = .true.
1620 errmax = rzero
1621*
1622 DO 120 in = 1, nidim
1623 n = idim( in )
1624 nd = n/2 + 1
1625*
1626 DO 110 im = 1, 2
1627 IF( im.EQ.1 )
1628 $ m = max( n - nd, 0 )
1629 IF( im.EQ.2 )
1630 $ m = min( n + nd, nmax )
1631*
1632* Set LDA to 1 more than minimum value if room.
1633 lda = m
1634 IF( lda.LT.nmax )
1635 $ lda = lda + 1
1636* Skip tests if not enough room.
1637 IF( lda.GT.nmax )
1638 $ GO TO 110
1639 laa = lda*n
1640 null = n.LE.0.OR.m.LE.0
1641*
1642 DO 100 ix = 1, ninc
1643 incx = inc( ix )
1644 lx = abs( incx )*m
1645*
1646* Generate the vector X.
1647*
1648 transl = half
1649 CALL zmake( 'ge', ' ', ' ', 1, m, x, 1, xx, abs( incx ),
1650 $ 0, m - 1, reset, transl )
1651 IF( m.GT.1 )THEN
1652 x( m/2 ) = zero
1653 xx( 1 + abs( incx )*( m/2 - 1 ) ) = zero
1654 END IF
1655*
1656 DO 90 iy = 1, ninc
1657 incy = inc( iy )
1658 ly = abs( incy )*n
1659*
1660* Generate the vector Y.
1661*
1662 transl = zero
1663 CALL zmake( 'ge', ' ', ' ', 1, n, y, 1, yy,
1664 $ abs( incy ), 0, n - 1, reset, transl )
1665 IF( n.GT.1 )THEN
1666 y( n/2 ) = zero
1667 yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
1668 END IF
1669*
1670 DO 80 ia = 1, nalf
1671 alpha = alf( ia )
1672*
1673* Generate the matrix A.
1674*
1675 transl = zero
1676 CALL zmake(sname( 8: 9 ), ' ', ' ', m, n, a, nmax,
1677 $ aa, lda, m - 1, n - 1, reset, transl )
1678*
1679 nc = nc + 1
1680*
1681* Save every datum before calling the subroutine.
1682*
1683 ms = m
1684 ns = n
1685 als = alpha
1686 DO 10 i = 1, laa
1687 as( i ) = aa( i )
1688 10 CONTINUE
1689 ldas = lda
1690 DO 20 i = 1, lx
1691 xs( i ) = xx( i )
1692 20 CONTINUE
1693 incxs = incx
1694 DO 30 i = 1, ly
1695 ys( i ) = yy( i )
1696 30 CONTINUE
1697 incys = incy
1698*
1699* Call the subroutine.
1700*
1701 IF( trace )
1702 $ WRITE( ntra, fmt = 9994 )nc, sname, m, n,
1703 $ alpha, incx, incy, lda
1704 IF( conj )THEN
1705 IF( rewi )
1706 $ rewind ntra
1707 CALL czgerc( iorder, m, n, alpha, xx, incx,
1708 $ yy, incy, aa, lda )
1709 ELSE
1710 IF( rewi )
1711 $ rewind ntra
1712 CALL czgeru( iorder, m, n, alpha, xx, incx,
1713 $ yy, incy, aa, lda )
1714 END IF
1715*
1716* Check if error-exit was taken incorrectly.
1717*
1718 IF( .NOT.ok )THEN
1719 WRITE( nout, fmt = 9993 )
1720 fatal = .true.
1721 GO TO 140
1722 END IF
1723*
1724* See what data changed inside subroutine.
1725*
1726 isame( 1 ) = ms.EQ.m
1727 isame( 2 ) = ns.EQ.n
1728 isame( 3 ) = als.EQ.alpha
1729 isame( 4 ) = lze( xs, xx, lx )
1730 isame( 5 ) = incxs.EQ.incx
1731 isame( 6 ) = lze( ys, yy, ly )
1732 isame( 7 ) = incys.EQ.incy
1733 IF( null )THEN
1734 isame( 8 ) = lze( as, aa, laa )
1735 ELSE
1736 isame( 8 ) = lzeres( 'ge', ' ', m, n, as, aa,
1737 $ lda )
1738 END IF
1739 isame( 9 ) = ldas.EQ.lda
1740*
1741* If data was incorrectly changed, report and return.
1742*
1743 same = .true.
1744 DO 40 i = 1, nargs
1745 same = same.AND.isame( i )
1746 IF( .NOT.isame( i ) )
1747 $ WRITE( nout, fmt = 9998 )i
1748 40 CONTINUE
1749 IF( .NOT.same )THEN
1750 fatal = .true.
1751 GO TO 140
1752 END IF
1753*
1754 IF( .NOT.null )THEN
1755*
1756* Check the result column by column.
1757*
1758 IF( incx.GT.0 )THEN
1759 DO 50 i = 1, m
1760 z( i ) = x( i )
1761 50 CONTINUE
1762 ELSE
1763 DO 60 i = 1, m
1764 z( i ) = x( m - i + 1 )
1765 60 CONTINUE
1766 END IF
1767 DO 70 j = 1, n
1768 IF( incy.GT.0 )THEN
1769 w( 1 ) = y( j )
1770 ELSE
1771 w( 1 ) = y( n - j + 1 )
1772 END IF
1773 IF( conj )
1774 $ w( 1 ) = dconjg( w( 1 ) )
1775 CALL zmvch( 'N', m, 1, alpha, z, nmax, w, 1,
1776 $ one, a( 1, j ), 1, yt, g,
1777 $ aa( 1 + ( j - 1 )*lda ), eps,
1778 $ err, fatal, nout, .true. )
1779 errmax = max( errmax, err )
1780* If got really bad answer, report and return.
1781 IF( fatal )
1782 $ GO TO 130
1783 70 CONTINUE
1784 ELSE
1785* Avoid repeating tests with M.le.0 or N.le.0.
1786 GO TO 110
1787 END IF
1788*
1789 80 CONTINUE
1790*
1791 90 CONTINUE
1792*
1793 100 CONTINUE
1794*
1795 110 CONTINUE
1796*
1797 120 CONTINUE
1798*
1799* Report result.
1800*
1801 IF( errmax.LT.thresh )THEN
1802 WRITE( nout, fmt = 9999 )sname, nc
1803 ELSE
1804 WRITE( nout, fmt = 9997 )sname, nc, errmax
1805 END IF
1806 GO TO 150
1807*
1808 130 CONTINUE
1809 WRITE( nout, fmt = 9995 )j
1810*
1811 140 CONTINUE
1812 WRITE( nout, fmt = 9996 )sname
1813 WRITE( nout, fmt = 9994 )nc, sname, m, n, alpha, incx, incy, lda
1814*
1815 150 CONTINUE
1816 RETURN
1817*
1818 9999 FORMAT(' ',a12, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1819 $ 'S)' )
1820 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1821 $ 'ANGED INCORRECTLY *******' )
1822 9997 FORMAT(' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1823 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1824 $ ' - SUSPECT *******' )
1825 9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
1826 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1827 9994 FORMAT(1x, i6, ': ',a12, '(', 2( i3, ',' ), '(', f4.1, ',', f4.1,
1828 $ '), X,', i2, ', Y,', i2, ', A,', i3, ') .' )
1829 9993 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1830 $ '******' )
1831*
1832* End of ZCHK4.
1833*

◆ zchk5()

subroutine zchk5 ( character*12 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,
complex*16, dimension( nalf ) alf,
integer ninc,
integer, dimension( ninc ) inc,
integer nmax,
integer incmax,
complex*16, dimension( nmax, nmax ) a,
complex*16, dimension( nmax*nmax ) aa,
complex*16, dimension( nmax*nmax ) as,
complex*16, dimension( nmax ) x,
complex*16, dimension( nmax*incmax ) xx,
complex*16, dimension( nmax*incmax ) xs,
complex*16, dimension( nmax ) y,
complex*16, dimension( nmax*incmax ) yy,
complex*16, dimension( nmax*incmax ) ys,
complex*16, dimension( nmax ) yt,
double precision, dimension( nmax ) g,
complex*16, dimension( nmax ) z,
integer iorder )

Definition at line 1835 of file c_zblat2.f.

1839*
1840* Tests ZHER and ZHPR.
1841*
1842* Auxiliary routine for test program for Level 2 Blas.
1843*
1844* -- Written on 10-August-1987.
1845* Richard Hanson, Sandia National Labs.
1846* Jeremy Du Croz, NAG Central Office.
1847*
1848* .. Parameters ..
1849 COMPLEX*16 ZERO, HALF, ONE
1850 parameter( zero = ( 0.0d0, 0.0d0 ),
1851 $ half = ( 0.5d0, 0.0d0 ),
1852 $ one = ( 1.0d0, 0.0d0 ) )
1853 DOUBLE PRECISION RZERO
1854 parameter( rzero = 0.0d0 )
1855* .. Scalar Arguments ..
1856 DOUBLE PRECISION EPS, THRESH
1857 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
1858 $ IORDER
1859 LOGICAL FATAL, REWI, TRACE
1860 CHARACTER*12 SNAME
1861* .. Array Arguments ..
1862 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1863 $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
1864 $ XX( NMAX*INCMAX ), Y( NMAX ),
1865 $ YS( NMAX*INCMAX ), YT( NMAX ),
1866 $ YY( NMAX*INCMAX ), Z( NMAX )
1867 DOUBLE PRECISION G( NMAX )
1868 INTEGER IDIM( NIDIM ), INC( NINC )
1869* .. Local Scalars ..
1870 COMPLEX*16 ALPHA, TRANSL
1871 DOUBLE PRECISION ERR, ERRMAX, RALPHA, RALS
1872 INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
1873 $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS
1874 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
1875 CHARACTER*1 UPLO, UPLOS
1876 CHARACTER*14 CUPLO
1877 CHARACTER*2 ICH
1878* .. Local Arrays ..
1879 COMPLEX*16 W( 1 )
1880 LOGICAL ISAME( 13 )
1881* .. External Functions ..
1882 LOGICAL LZE, LZERES
1883 EXTERNAL lze, lzeres
1884* .. External Subroutines ..
1885 EXTERNAL czher, czhpr, zmake, zmvch
1886* .. Intrinsic Functions ..
1887 INTRINSIC abs, dcmplx, dconjg, max, dble
1888* .. Scalars in Common ..
1889 INTEGER INFOT, NOUTC
1890 LOGICAL OK
1891* .. Common blocks ..
1892 COMMON /infoc/infot, noutc, ok
1893* .. Data statements ..
1894 DATA ich/'UL'/
1895* .. Executable Statements ..
1896 full = sname( 9: 9 ).EQ.'e'
1897 packed = sname( 9: 9 ).EQ.'p'
1898* Define the number of arguments.
1899 IF( full )THEN
1900 nargs = 7
1901 ELSE IF( packed )THEN
1902 nargs = 6
1903 END IF
1904*
1905 nc = 0
1906 reset = .true.
1907 errmax = rzero
1908*
1909 DO 100 in = 1, nidim
1910 n = idim( in )
1911* Set LDA to 1 more than minimum value if room.
1912 lda = n
1913 IF( lda.LT.nmax )
1914 $ lda = lda + 1
1915* Skip tests if not enough room.
1916 IF( lda.GT.nmax )
1917 $ GO TO 100
1918 IF( packed )THEN
1919 laa = ( n*( n + 1 ) )/2
1920 ELSE
1921 laa = lda*n
1922 END IF
1923*
1924 DO 90 ic = 1, 2
1925 uplo = ich( ic: ic )
1926 IF (uplo.EQ.'U')THEN
1927 cuplo = ' CblasUpper'
1928 ELSE
1929 cuplo = ' CblasLower'
1930 END IF
1931 upper = uplo.EQ.'U'
1932*
1933 DO 80 ix = 1, ninc
1934 incx = inc( ix )
1935 lx = abs( incx )*n
1936*
1937* Generate the vector X.
1938*
1939 transl = half
1940 CALL zmake( 'ge', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
1941 $ 0, n - 1, reset, transl )
1942 IF( n.GT.1 )THEN
1943 x( n/2 ) = zero
1944 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1945 END IF
1946*
1947 DO 70 ia = 1, nalf
1948 ralpha = dble( alf( ia ) )
1949 alpha = dcmplx( ralpha, rzero )
1950 null = n.LE.0.OR.ralpha.EQ.rzero
1951*
1952* Generate the matrix A.
1953*
1954 transl = zero
1955 CALL zmake( sname( 8: 9 ), uplo, ' ', n, n, a, nmax,
1956 $ aa, lda, n - 1, n - 1, reset, transl )
1957*
1958 nc = nc + 1
1959*
1960* Save every datum before calling the subroutine.
1961*
1962 uplos = uplo
1963 ns = n
1964 rals = ralpha
1965 DO 10 i = 1, laa
1966 as( i ) = aa( i )
1967 10 CONTINUE
1968 ldas = lda
1969 DO 20 i = 1, lx
1970 xs( i ) = xx( i )
1971 20 CONTINUE
1972 incxs = incx
1973*
1974* Call the subroutine.
1975*
1976 IF( full )THEN
1977 IF( trace )
1978 $ WRITE( ntra, fmt = 9993 )nc, sname, cuplo, n,
1979 $ ralpha, incx, lda
1980 IF( rewi )
1981 $ rewind ntra
1982 CALL czher( iorder, uplo, n, ralpha, xx,
1983 $ incx, aa, lda )
1984 ELSE IF( packed )THEN
1985 IF( trace )
1986 $ WRITE( ntra, fmt = 9994 )nc, sname, cuplo, n,
1987 $ ralpha, incx
1988 IF( rewi )
1989 $ rewind ntra
1990 CALL czhpr( iorder, uplo, n, ralpha,
1991 $ xx, incx, aa )
1992 END IF
1993*
1994* Check if error-exit was taken incorrectly.
1995*
1996 IF( .NOT.ok )THEN
1997 WRITE( nout, fmt = 9992 )
1998 fatal = .true.
1999 GO TO 120
2000 END IF
2001*
2002* See what data changed inside subroutines.
2003*
2004 isame( 1 ) = uplo.EQ.uplos
2005 isame( 2 ) = ns.EQ.n
2006 isame( 3 ) = rals.EQ.ralpha
2007 isame( 4 ) = lze( xs, xx, lx )
2008 isame( 5 ) = incxs.EQ.incx
2009 IF( null )THEN
2010 isame( 6 ) = lze( as, aa, laa )
2011 ELSE
2012 isame( 6 ) = lzeres( sname( 8: 9 ), uplo, n, n, as,
2013 $ aa, lda )
2014 END IF
2015 IF( .NOT.packed )THEN
2016 isame( 7 ) = ldas.EQ.lda
2017 END IF
2018*
2019* If data was incorrectly changed, report and return.
2020*
2021 same = .true.
2022 DO 30 i = 1, nargs
2023 same = same.AND.isame( i )
2024 IF( .NOT.isame( i ) )
2025 $ WRITE( nout, fmt = 9998 )i
2026 30 CONTINUE
2027 IF( .NOT.same )THEN
2028 fatal = .true.
2029 GO TO 120
2030 END IF
2031*
2032 IF( .NOT.null )THEN
2033*
2034* Check the result column by column.
2035*
2036 IF( incx.GT.0 )THEN
2037 DO 40 i = 1, n
2038 z( i ) = x( i )
2039 40 CONTINUE
2040 ELSE
2041 DO 50 i = 1, n
2042 z( i ) = x( n - i + 1 )
2043 50 CONTINUE
2044 END IF
2045 ja = 1
2046 DO 60 j = 1, n
2047 w( 1 ) = dconjg( z( j ) )
2048 IF( upper )THEN
2049 jj = 1
2050 lj = j
2051 ELSE
2052 jj = j
2053 lj = n - j + 1
2054 END IF
2055 CALL zmvch( 'N', lj, 1, alpha, z( jj ), lj, w,
2056 $ 1, one, a( jj, j ), 1, yt, g,
2057 $ aa( ja ), eps, err, fatal, nout,
2058 $ .true. )
2059 IF( full )THEN
2060 IF( upper )THEN
2061 ja = ja + lda
2062 ELSE
2063 ja = ja + lda + 1
2064 END IF
2065 ELSE
2066 ja = ja + lj
2067 END IF
2068 errmax = max( errmax, err )
2069* If got really bad answer, report and return.
2070 IF( fatal )
2071 $ GO TO 110
2072 60 CONTINUE
2073 ELSE
2074* Avoid repeating tests if N.le.0.
2075 IF( n.LE.0 )
2076 $ GO TO 100
2077 END IF
2078*
2079 70 CONTINUE
2080*
2081 80 CONTINUE
2082*
2083 90 CONTINUE
2084*
2085 100 CONTINUE
2086*
2087* Report result.
2088*
2089 IF( errmax.LT.thresh )THEN
2090 WRITE( nout, fmt = 9999 )sname, nc
2091 ELSE
2092 WRITE( nout, fmt = 9997 )sname, nc, errmax
2093 END IF
2094 GO TO 130
2095*
2096 110 CONTINUE
2097 WRITE( nout, fmt = 9995 )j
2098*
2099 120 CONTINUE
2100 WRITE( nout, fmt = 9996 )sname
2101 IF( full )THEN
2102 WRITE( nout, fmt = 9993 )nc, sname, cuplo, n, ralpha, incx, lda
2103 ELSE IF( packed )THEN
2104 WRITE( nout, fmt = 9994 )nc, sname, cuplo, n, ralpha, incx
2105 END IF
2106*
2107 130 CONTINUE
2108 RETURN
2109*
2110 9999 FORMAT(' ',a12, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
2111 $ 'S)' )
2112 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2113 $ 'ANGED INCORRECTLY *******' )
2114 9997 FORMAT(' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
2115 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2116 $ ' - SUSPECT *******' )
2117 9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
2118 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2119 9994 FORMAT(1x, i6, ': ',a12, '(', a14, ',', i3, ',', f4.1, ', X,',
2120 $ i2, ', AP) .' )
2121 9993 FORMAT(1x, i6, ': ',a12, '(', a14, ',', i3, ',', f4.1, ', X,',
2122 $ i2, ', A,', i3, ') .' )
2123 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2124 $ '******' )
2125*
2126* End of CZHK5.
2127*

◆ zchk6()

subroutine zchk6 ( character*12 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,
complex*16, dimension( nalf ) alf,
integer ninc,
integer, dimension( ninc ) inc,
integer nmax,
integer incmax,
complex*16, dimension( nmax, nmax ) a,
complex*16, dimension( nmax*nmax ) aa,
complex*16, dimension( nmax*nmax ) as,
complex*16, dimension( nmax ) x,
complex*16, dimension( nmax*incmax ) xx,
complex*16, dimension( nmax*incmax ) xs,
complex*16, dimension( nmax ) y,
complex*16, dimension( nmax*incmax ) yy,
complex*16, dimension( nmax*incmax ) ys,
complex*16, dimension( nmax ) yt,
double precision, dimension( nmax ) g,
complex*16, dimension( nmax, 2 ) z,
integer iorder )

Definition at line 2129 of file c_zblat2.f.

2133*
2134* Tests ZHER2 and ZHPR2.
2135*
2136* Auxiliary routine for test program for Level 2 Blas.
2137*
2138* -- Written on 10-August-1987.
2139* Richard Hanson, Sandia National Labs.
2140* Jeremy Du Croz, NAG Central Office.
2141*
2142* .. Parameters ..
2143 COMPLEX*16 ZERO, HALF, ONE
2144 parameter( zero = ( 0.0d0, 0.0d0 ),
2145 $ half = ( 0.5d0, 0.0d0 ),
2146 $ one = ( 1.0d0, 0.0d0 ) )
2147 DOUBLE PRECISION RZERO
2148 parameter( rzero = 0.0d0 )
2149* .. Scalar Arguments ..
2150 DOUBLE PRECISION EPS, THRESH
2151 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
2152 $ IORDER
2153 LOGICAL FATAL, REWI, TRACE
2154 CHARACTER*12 SNAME
2155* .. Array Arguments ..
2156 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
2157 $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
2158 $ XX( NMAX*INCMAX ), Y( NMAX ),
2159 $ YS( NMAX*INCMAX ), YT( NMAX ),
2160 $ YY( NMAX*INCMAX ), Z( NMAX, 2 )
2161 DOUBLE PRECISION G( NMAX )
2162 INTEGER IDIM( NIDIM ), INC( NINC )
2163* .. Local Scalars ..
2164 COMPLEX*16 ALPHA, ALS, TRANSL
2165 DOUBLE PRECISION ERR, ERRMAX
2166 INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
2167 $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
2168 $ NARGS, NC, NS
2169 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
2170 CHARACTER*1 UPLO, UPLOS
2171 CHARACTER*14 CUPLO
2172 CHARACTER*2 ICH
2173* .. Local Arrays ..
2174 COMPLEX*16 W( 2 )
2175 LOGICAL ISAME( 13 )
2176* .. External Functions ..
2177 LOGICAL LZE, LZERES
2178 EXTERNAL lze, lzeres
2179* .. External Subroutines ..
2180 EXTERNAL czher2, czhpr2, zmake, zmvch
2181* .. Intrinsic Functions ..
2182 INTRINSIC abs, dconjg, max
2183* .. Scalars in Common ..
2184 INTEGER INFOT, NOUTC
2185 LOGICAL OK
2186* .. Common blocks ..
2187 COMMON /infoc/infot, noutc, ok
2188* .. Data statements ..
2189 DATA ich/'UL'/
2190* .. Executable Statements ..
2191 full = sname( 9: 9 ).EQ.'e'
2192 packed = sname( 9: 9 ).EQ.'p'
2193* Define the number of arguments.
2194 IF( full )THEN
2195 nargs = 9
2196 ELSE IF( packed )THEN
2197 nargs = 8
2198 END IF
2199*
2200 nc = 0
2201 reset = .true.
2202 errmax = rzero
2203*
2204 DO 140 in = 1, nidim
2205 n = idim( in )
2206* Set LDA to 1 more than minimum value if room.
2207 lda = n
2208 IF( lda.LT.nmax )
2209 $ lda = lda + 1
2210* Skip tests if not enough room.
2211 IF( lda.GT.nmax )
2212 $ GO TO 140
2213 IF( packed )THEN
2214 laa = ( n*( n + 1 ) )/2
2215 ELSE
2216 laa = lda*n
2217 END IF
2218*
2219 DO 130 ic = 1, 2
2220 uplo = ich( ic: ic )
2221 IF (uplo.EQ.'U')THEN
2222 cuplo = ' CblasUpper'
2223 ELSE
2224 cuplo = ' CblasLower'
2225 END IF
2226 upper = uplo.EQ.'U'
2227*
2228 DO 120 ix = 1, ninc
2229 incx = inc( ix )
2230 lx = abs( incx )*n
2231*
2232* Generate the vector X.
2233*
2234 transl = half
2235 CALL zmake( 'ge', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
2236 $ 0, n - 1, reset, transl )
2237 IF( n.GT.1 )THEN
2238 x( n/2 ) = zero
2239 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
2240 END IF
2241*
2242 DO 110 iy = 1, ninc
2243 incy = inc( iy )
2244 ly = abs( incy )*n
2245*
2246* Generate the vector Y.
2247*
2248 transl = zero
2249 CALL zmake( 'ge', ' ', ' ', 1, n, y, 1, yy,
2250 $ abs( incy ), 0, n - 1, reset, transl )
2251 IF( n.GT.1 )THEN
2252 y( n/2 ) = zero
2253 yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
2254 END IF
2255*
2256 DO 100 ia = 1, nalf
2257 alpha = alf( ia )
2258 null = n.LE.0.OR.alpha.EQ.zero
2259*
2260* Generate the matrix A.
2261*
2262 transl = zero
2263 CALL zmake( sname( 8: 9 ), uplo, ' ', n, n, a,
2264 $ nmax, aa, lda, n - 1, n - 1, reset,
2265 $ transl )
2266*
2267 nc = nc + 1
2268*
2269* Save every datum before calling the subroutine.
2270*
2271 uplos = uplo
2272 ns = n
2273 als = alpha
2274 DO 10 i = 1, laa
2275 as( i ) = aa( i )
2276 10 CONTINUE
2277 ldas = lda
2278 DO 20 i = 1, lx
2279 xs( i ) = xx( i )
2280 20 CONTINUE
2281 incxs = incx
2282 DO 30 i = 1, ly
2283 ys( i ) = yy( i )
2284 30 CONTINUE
2285 incys = incy
2286*
2287* Call the subroutine.
2288*
2289 IF( full )THEN
2290 IF( trace )
2291 $ WRITE( ntra, fmt = 9993 )nc, sname, cuplo, n,
2292 $ alpha, incx, incy, lda
2293 IF( rewi )
2294 $ rewind ntra
2295 CALL czher2( iorder, uplo, n, alpha, xx, incx,
2296 $ yy, incy, aa, lda )
2297 ELSE IF( packed )THEN
2298 IF( trace )
2299 $ WRITE( ntra, fmt = 9994 )nc, sname, cuplo, n,
2300 $ alpha, incx, incy
2301 IF( rewi )
2302 $ rewind ntra
2303 CALL czhpr2( iorder, uplo, n, alpha, xx, incx,
2304 $ yy, incy, aa )
2305 END IF
2306*
2307* Check if error-exit was taken incorrectly.
2308*
2309 IF( .NOT.ok )THEN
2310 WRITE( nout, fmt = 9992 )
2311 fatal = .true.
2312 GO TO 160
2313 END IF
2314*
2315* See what data changed inside subroutines.
2316*
2317 isame( 1 ) = uplo.EQ.uplos
2318 isame( 2 ) = ns.EQ.n
2319 isame( 3 ) = als.EQ.alpha
2320 isame( 4 ) = lze( xs, xx, lx )
2321 isame( 5 ) = incxs.EQ.incx
2322 isame( 6 ) = lze( ys, yy, ly )
2323 isame( 7 ) = incys.EQ.incy
2324 IF( null )THEN
2325 isame( 8 ) = lze( as, aa, laa )
2326 ELSE
2327 isame( 8 ) = lzeres( sname( 8: 9 ), uplo, n, n,
2328 $ as, aa, lda )
2329 END IF
2330 IF( .NOT.packed )THEN
2331 isame( 9 ) = ldas.EQ.lda
2332 END IF
2333*
2334* If data was incorrectly changed, report and return.
2335*
2336 same = .true.
2337 DO 40 i = 1, nargs
2338 same = same.AND.isame( i )
2339 IF( .NOT.isame( i ) )
2340 $ WRITE( nout, fmt = 9998 )i
2341 40 CONTINUE
2342 IF( .NOT.same )THEN
2343 fatal = .true.
2344 GO TO 160
2345 END IF
2346*
2347 IF( .NOT.null )THEN
2348*
2349* Check the result column by column.
2350*
2351 IF( incx.GT.0 )THEN
2352 DO 50 i = 1, n
2353 z( i, 1 ) = x( i )
2354 50 CONTINUE
2355 ELSE
2356 DO 60 i = 1, n
2357 z( i, 1 ) = x( n - i + 1 )
2358 60 CONTINUE
2359 END IF
2360 IF( incy.GT.0 )THEN
2361 DO 70 i = 1, n
2362 z( i, 2 ) = y( i )
2363 70 CONTINUE
2364 ELSE
2365 DO 80 i = 1, n
2366 z( i, 2 ) = y( n - i + 1 )
2367 80 CONTINUE
2368 END IF
2369 ja = 1
2370 DO 90 j = 1, n
2371 w( 1 ) = alpha*dconjg( z( j, 2 ) )
2372 w( 2 ) = dconjg( alpha )*dconjg( z( j, 1 ) )
2373 IF( upper )THEN
2374 jj = 1
2375 lj = j
2376 ELSE
2377 jj = j
2378 lj = n - j + 1
2379 END IF
2380 CALL zmvch( 'N', lj, 2, one, z( jj, 1 ),
2381 $ nmax, w, 1, one, a( jj, j ), 1,
2382 $ yt, g, aa( ja ), eps, err, fatal,
2383 $ nout, .true. )
2384 IF( full )THEN
2385 IF( upper )THEN
2386 ja = ja + lda
2387 ELSE
2388 ja = ja + lda + 1
2389 END IF
2390 ELSE
2391 ja = ja + lj
2392 END IF
2393 errmax = max( errmax, err )
2394* If got really bad answer, report and return.
2395 IF( fatal )
2396 $ GO TO 150
2397 90 CONTINUE
2398 ELSE
2399* Avoid repeating tests with N.le.0.
2400 IF( n.LE.0 )
2401 $ GO TO 140
2402 END IF
2403*
2404 100 CONTINUE
2405*
2406 110 CONTINUE
2407*
2408 120 CONTINUE
2409*
2410 130 CONTINUE
2411*
2412 140 CONTINUE
2413*
2414* Report result.
2415*
2416 IF( errmax.LT.thresh )THEN
2417 WRITE( nout, fmt = 9999 )sname, nc
2418 ELSE
2419 WRITE( nout, fmt = 9997 )sname, nc, errmax
2420 END IF
2421 GO TO 170
2422*
2423 150 CONTINUE
2424 WRITE( nout, fmt = 9995 )j
2425*
2426 160 CONTINUE
2427 WRITE( nout, fmt = 9996 )sname
2428 IF( full )THEN
2429 WRITE( nout, fmt = 9993 )nc, sname, cuplo, n, alpha, incx,
2430 $ incy, lda
2431 ELSE IF( packed )THEN
2432 WRITE( nout, fmt = 9994 )nc, sname, cuplo, n, alpha, incx, incy
2433 END IF
2434*
2435 170 CONTINUE
2436 RETURN
2437*
2438 9999 FORMAT(' ',a12, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
2439 $ 'S)' )
2440 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2441 $ 'ANGED INCORRECTLY *******' )
2442 9997 FORMAT(' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
2443 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2444 $ ' - SUSPECT *******' )
2445 9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
2446 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2447 9994 FORMAT(1x, i6, ': ',a12, '(', a14, ',', i3, ',(', f4.1, ',',
2448 $ f4.1, '), X,', i2, ', Y,', i2, ', AP) .' )
2449 9993 FORMAT(1x, i6, ': ',a12, '(', a14, ',', i3, ',(', f4.1, ',',
2450 $ f4.1, '), X,', i2, ', Y,', i2, ', A,', i3, ') .' )
2451 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2452 $ '******' )
2453*
2454* End of ZCHK6.
2455*

◆ zmake()

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

Definition at line 2747 of file c_zblat2.f.

2749*
2750* Generates values for an M by N matrix A within the bandwidth
2751* defined by KL and KU.
2752* Stores the values in the array AA in the data structure required
2753* by the routine, with unwanted elements set to rogue value.
2754*
2755* TYPE is 'ge', 'gb', 'he', 'hb', 'hp', 'tr', 'tb' OR 'tp'.
2756*
2757* Auxiliary routine for test program for Level 2 Blas.
2758*
2759* -- Written on 10-August-1987.
2760* Richard Hanson, Sandia National Labs.
2761* Jeremy Du Croz, NAG Central Office.
2762*
2763* .. Parameters ..
2764 COMPLEX*16 ZERO, ONE
2765 parameter( zero = ( 0.0d0, 0.0d0 ),
2766 $ one = ( 1.0d0, 0.0d0 ) )
2767 COMPLEX*16 ROGUE
2768 parameter( rogue = ( -1.0d10, 1.0d10 ) )
2769 DOUBLE PRECISION RZERO
2770 parameter( rzero = 0.0d0 )
2771 DOUBLE PRECISION RROGUE
2772 parameter( rrogue = -1.0d10 )
2773* .. Scalar Arguments ..
2774 COMPLEX*16 TRANSL
2775 INTEGER KL, KU, LDA, M, N, NMAX
2776 LOGICAL RESET
2777 CHARACTER*1 DIAG, UPLO
2778 CHARACTER*2 TYPE
2779* .. Array Arguments ..
2780 COMPLEX*16 A( NMAX, * ), AA( * )
2781* .. Local Scalars ..
2782 INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK
2783 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2784* .. External Functions ..
2785 COMPLEX*16 ZBEG
2786 EXTERNAL zbeg
2787* .. Intrinsic Functions ..
2788 INTRINSIC dcmplx, dconjg, max, min, dble
2789* .. Executable Statements ..
2790 gen = TYPE( 1: 1 ).EQ.'g'
2791 sym = TYPE( 1: 1 ).EQ.'h'
2792 tri = TYPE( 1: 1 ).EQ.'t'
2793 upper = ( sym.OR.tri ).AND.uplo.EQ.'U'
2794 lower = ( sym.OR.tri ).AND.uplo.EQ.'L'
2795 unit = tri.AND.diag.EQ.'U'
2796*
2797* Generate data in array A.
2798*
2799 DO 20 j = 1, n
2800 DO 10 i = 1, m
2801 IF( gen.OR.( upper.AND.i.LE.j ).OR.( lower.AND.i.GE.j ) )
2802 $ THEN
2803 IF( ( i.LE.j.AND.j - i.LE.ku ).OR.
2804 $ ( i.GE.j.AND.i - j.LE.kl ) )THEN
2805 a( i, j ) = zbeg( reset ) + transl
2806 ELSE
2807 a( i, j ) = zero
2808 END IF
2809 IF( i.NE.j )THEN
2810 IF( sym )THEN
2811 a( j, i ) = dconjg( a( i, j ) )
2812 ELSE IF( tri )THEN
2813 a( j, i ) = zero
2814 END IF
2815 END IF
2816 END IF
2817 10 CONTINUE
2818 IF( sym )
2819 $ a( j, j ) = dcmplx( dble( a( j, j ) ), rzero )
2820 IF( tri )
2821 $ a( j, j ) = a( j, j ) + one
2822 IF( unit )
2823 $ a( j, j ) = one
2824 20 CONTINUE
2825*
2826* Store elements in array AS in data structure required by routine.
2827*
2828 IF( type.EQ.'ge' )THEN
2829 DO 50 j = 1, n
2830 DO 30 i = 1, m
2831 aa( i + ( j - 1 )*lda ) = a( i, j )
2832 30 CONTINUE
2833 DO 40 i = m + 1, lda
2834 aa( i + ( j - 1 )*lda ) = rogue
2835 40 CONTINUE
2836 50 CONTINUE
2837 ELSE IF( type.EQ.'gb' )THEN
2838 DO 90 j = 1, n
2839 DO 60 i1 = 1, ku + 1 - j
2840 aa( i1 + ( j - 1 )*lda ) = rogue
2841 60 CONTINUE
2842 DO 70 i2 = i1, min( kl + ku + 1, ku + 1 + m - j )
2843 aa( i2 + ( j - 1 )*lda ) = a( i2 + j - ku - 1, j )
2844 70 CONTINUE
2845 DO 80 i3 = i2, lda
2846 aa( i3 + ( j - 1 )*lda ) = rogue
2847 80 CONTINUE
2848 90 CONTINUE
2849 ELSE IF( type.EQ.'he'.OR.type.EQ.'tr' )THEN
2850 DO 130 j = 1, n
2851 IF( upper )THEN
2852 ibeg = 1
2853 IF( unit )THEN
2854 iend = j - 1
2855 ELSE
2856 iend = j
2857 END IF
2858 ELSE
2859 IF( unit )THEN
2860 ibeg = j + 1
2861 ELSE
2862 ibeg = j
2863 END IF
2864 iend = n
2865 END IF
2866 DO 100 i = 1, ibeg - 1
2867 aa( i + ( j - 1 )*lda ) = rogue
2868 100 CONTINUE
2869 DO 110 i = ibeg, iend
2870 aa( i + ( j - 1 )*lda ) = a( i, j )
2871 110 CONTINUE
2872 DO 120 i = iend + 1, lda
2873 aa( i + ( j - 1 )*lda ) = rogue
2874 120 CONTINUE
2875 IF( sym )THEN
2876 jj = j + ( j - 1 )*lda
2877 aa( jj ) = dcmplx( dble( aa( jj ) ), rrogue )
2878 END IF
2879 130 CONTINUE
2880 ELSE IF( type.EQ.'hb'.OR.type.EQ.'tb' )THEN
2881 DO 170 j = 1, n
2882 IF( upper )THEN
2883 kk = kl + 1
2884 ibeg = max( 1, kl + 2 - j )
2885 IF( unit )THEN
2886 iend = kl
2887 ELSE
2888 iend = kl + 1
2889 END IF
2890 ELSE
2891 kk = 1
2892 IF( unit )THEN
2893 ibeg = 2
2894 ELSE
2895 ibeg = 1
2896 END IF
2897 iend = min( kl + 1, 1 + m - j )
2898 END IF
2899 DO 140 i = 1, ibeg - 1
2900 aa( i + ( j - 1 )*lda ) = rogue
2901 140 CONTINUE
2902 DO 150 i = ibeg, iend
2903 aa( i + ( j - 1 )*lda ) = a( i + j - kk, j )
2904 150 CONTINUE
2905 DO 160 i = iend + 1, lda
2906 aa( i + ( j - 1 )*lda ) = rogue
2907 160 CONTINUE
2908 IF( sym )THEN
2909 jj = kk + ( j - 1 )*lda
2910 aa( jj ) = dcmplx( dble( aa( jj ) ), rrogue )
2911 END IF
2912 170 CONTINUE
2913 ELSE IF( type.EQ.'hp'.OR.type.EQ.'tp' )THEN
2914 ioff = 0
2915 DO 190 j = 1, n
2916 IF( upper )THEN
2917 ibeg = 1
2918 iend = j
2919 ELSE
2920 ibeg = j
2921 iend = n
2922 END IF
2923 DO 180 i = ibeg, iend
2924 ioff = ioff + 1
2925 aa( ioff ) = a( i, j )
2926 IF( i.EQ.j )THEN
2927 IF( unit )
2928 $ aa( ioff ) = rogue
2929 IF( sym )
2930 $ aa( ioff ) = dcmplx( dble( aa( ioff ) ), rrogue )
2931 END IF
2932 180 CONTINUE
2933 190 CONTINUE
2934 END IF
2935 RETURN
2936*
2937* End of ZMAKE.
2938*

◆ zmvch()

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

Definition at line 2457 of file c_zblat2.f.

2459*
2460* Checks the results of the computational tests.
2461*
2462* Auxiliary routine for test program for Level 2 Blas.
2463*
2464* -- Written on 10-August-1987.
2465* Richard Hanson, Sandia National Labs.
2466* Jeremy Du Croz, NAG Central Office.
2467*
2468* .. Parameters ..
2469 COMPLEX*16 ZERO
2470 parameter( zero = ( 0.0d0, 0.0d0 ) )
2471 DOUBLE PRECISION RZERO, RONE
2472 parameter( rzero = 0.0d0, rone = 1.0d0 )
2473* .. Scalar Arguments ..
2474 COMPLEX*16 ALPHA, BETA
2475 DOUBLE PRECISION EPS, ERR
2476 INTEGER INCX, INCY, M, N, NMAX, NOUT
2477 LOGICAL FATAL, MV
2478 CHARACTER*1 TRANS
2479* .. Array Arguments ..
2480 COMPLEX*16 A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * )
2481 DOUBLE PRECISION G( * )
2482* .. Local Scalars ..
2483 COMPLEX*16 C
2484 DOUBLE PRECISION ERRI
2485 INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
2486 LOGICAL CTRAN, TRAN
2487* .. Intrinsic Functions ..
2488 INTRINSIC abs, dimag, dconjg, max, dble, sqrt
2489* .. Statement Functions ..
2490 DOUBLE PRECISION ABS1
2491* .. Statement Function definitions ..
2492 abs1( c ) = abs( dble( c ) ) + abs( dimag( c ) )
2493* .. Executable Statements ..
2494 tran = trans.EQ.'T'
2495 ctran = trans.EQ.'C'
2496 IF( tran.OR.ctran )THEN
2497 ml = n
2498 nl = m
2499 ELSE
2500 ml = m
2501 nl = n
2502 END IF
2503 IF( incx.LT.0 )THEN
2504 kx = nl
2505 incxl = -1
2506 ELSE
2507 kx = 1
2508 incxl = 1
2509 END IF
2510 IF( incy.LT.0 )THEN
2511 ky = ml
2512 incyl = -1
2513 ELSE
2514 ky = 1
2515 incyl = 1
2516 END IF
2517*
2518* Compute expected result in YT using data in A, X and Y.
2519* Compute gauges in G.
2520*
2521 iy = ky
2522 DO 40 i = 1, ml
2523 yt( iy ) = zero
2524 g( iy ) = rzero
2525 jx = kx
2526 IF( tran )THEN
2527 DO 10 j = 1, nl
2528 yt( iy ) = yt( iy ) + a( j, i )*x( jx )
2529 g( iy ) = g( iy ) + abs1( a( j, i ) )*abs1( x( jx ) )
2530 jx = jx + incxl
2531 10 CONTINUE
2532 ELSE IF( ctran )THEN
2533 DO 20 j = 1, nl
2534 yt( iy ) = yt( iy ) + dconjg( a( j, i ) )*x( jx )
2535 g( iy ) = g( iy ) + abs1( a( j, i ) )*abs1( x( jx ) )
2536 jx = jx + incxl
2537 20 CONTINUE
2538 ELSE
2539 DO 30 j = 1, nl
2540 yt( iy ) = yt( iy ) + a( i, j )*x( jx )
2541 g( iy ) = g( iy ) + abs1( a( i, j ) )*abs1( x( jx ) )
2542 jx = jx + incxl
2543 30 CONTINUE
2544 END IF
2545 yt( iy ) = alpha*yt( iy ) + beta*y( iy )
2546 g( iy ) = abs1( alpha )*g( iy ) + abs1( beta )*abs1( y( iy ) )
2547 iy = iy + incyl
2548 40 CONTINUE
2549*
2550* Compute the error ratio for this result.
2551*
2552 err = zero
2553 DO 50 i = 1, ml
2554 erri = abs( yt( i ) - yy( 1 + ( i - 1 )*abs( incy ) ) )/eps
2555 IF( g( i ).NE.rzero )
2556 $ erri = erri/g( i )
2557 err = max( err, erri )
2558 IF( err*sqrt( eps ).GE.rone )
2559 $ GO TO 60
2560 50 CONTINUE
2561* If the loop completes, all results are at least half accurate.
2562 GO TO 80
2563*
2564* Report fatal error.
2565*
2566 60 fatal = .true.
2567 WRITE( nout, fmt = 9999 )
2568 DO 70 i = 1, ml
2569 IF( mv )THEN
2570 WRITE( nout, fmt = 9998 )i, yt( i ),
2571 $ yy( 1 + ( i - 1 )*abs( incy ) )
2572 ELSE
2573 WRITE( nout, fmt = 9998 )i,
2574 $ yy( 1 + ( i - 1 )*abs( incy ) ), yt( i )
2575 END IF
2576 70 CONTINUE
2577*
2578 80 CONTINUE
2579 RETURN
2580*
2581 9999 FORMAT(' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2582 $ 'F ACCURATE *******', /' EXPECTED RE',
2583 $ 'SULT COMPUTED RESULT' )
2584 9998 FORMAT( 1x, i7, 2( ' (', g15.6, ',', g15.6, ')' ) )
2585*
2586* End of ZMVCH.
2587*
nl
character *2 function nl()
Definition message.F:2354