LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ zchk1()

subroutine zchk1 ( character*13 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 nbet,
complex*16, dimension( nbet ) bet,
integer nmax,
complex*16, dimension( nmax, nmax ) a,
complex*16, dimension( nmax*nmax ) aa,
complex*16, dimension( nmax*nmax ) as,
complex*16, dimension( nmax, nmax ) b,
complex*16, dimension( nmax*nmax ) bb,
complex*16, dimension( nmax*nmax ) bs,
complex*16, dimension( nmax, nmax ) c,
complex*16, dimension( nmax*nmax ) cc,
complex*16, dimension( nmax*nmax ) cs,
complex*16, dimension( nmax ) ct,
double precision, dimension( nmax ) g,
integer iorder )

Definition at line 441 of file c_zblat3.f.

445*
446* Tests ZGEMM.
447*
448* Auxiliary routine for test program for Level 3 Blas.
449*
450* -- Written on 8-February-1989.
451* Jack Dongarra, Argonne National Laboratory.
452* Iain Duff, AERE Harwell.
453* Jeremy Du Croz, Numerical Algorithms Group Ltd.
454* Sven Hammarling, Numerical Algorithms Group Ltd.
455*
456* .. Parameters ..
457 COMPLEX*16 ZERO
458 parameter( zero = ( 0.0, 0.0 ) )
459 DOUBLE PRECISION RZERO
460 parameter( rzero = 0.0 )
461* .. Scalar Arguments ..
462 DOUBLE PRECISION EPS, THRESH
463 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
464 LOGICAL FATAL, REWI, TRACE
465 CHARACTER*13 SNAME
466* .. Array Arguments ..
467 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
468 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
469 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
470 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
471 $ CS( NMAX*NMAX ), CT( NMAX )
472 DOUBLE PRECISION G( NMAX )
473 INTEGER IDIM( NIDIM )
474* .. Local Scalars ..
475 COMPLEX*16 ALPHA, ALS, BETA, BLS
476 DOUBLE PRECISION ERR, ERRMAX
477 INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
478 $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
479 $ MA, MB, MS, N, NA, NARGS, NB, NC, NS
480 LOGICAL NULL, RESET, SAME, TRANA, TRANB
481 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB
482 CHARACTER*3 ICH
483* .. Local Arrays ..
484 LOGICAL ISAME( 13 )
485* .. External Functions ..
486 LOGICAL LZE, LZERES
487 EXTERNAL lze, lzeres
488* .. External Subroutines ..
489 EXTERNAL czgemm, zmake, zmmch
490* .. Intrinsic Functions ..
491 INTRINSIC max
492* .. Scalars in Common ..
493 INTEGER INFOT, NOUTC
494 LOGICAL LERR, OK
495* .. Common blocks ..
496 COMMON /infoc/infot, noutc, ok, lerr
497* .. Data statements ..
498 DATA ich/'NTC'/
499* .. Executable Statements ..
500*
501 nargs = 13
502 nc = 0
503 reset = .true.
504 errmax = rzero
505*
506 DO 110 im = 1, nidim
507 m = idim( im )
508*
509 DO 100 in = 1, nidim
510 n = idim( in )
511* Set LDC to 1 more than minimum value if room.
512 ldc = m
513 IF( ldc.LT.nmax )
514 $ ldc = ldc + 1
515* Skip tests if not enough room.
516 IF( ldc.GT.nmax )
517 $ GO TO 100
518 lcc = ldc*n
519 null = n.LE.0.OR.m.LE.0
520*
521 DO 90 ik = 1, nidim
522 k = idim( ik )
523*
524 DO 80 ica = 1, 3
525 transa = ich( ica: ica )
526 trana = transa.EQ.'T'.OR.transa.EQ.'C'
527*
528 IF( trana )THEN
529 ma = k
530 na = m
531 ELSE
532 ma = m
533 na = k
534 END IF
535* Set LDA to 1 more than minimum value if room.
536 lda = ma
537 IF( lda.LT.nmax )
538 $ lda = lda + 1
539* Skip tests if not enough room.
540 IF( lda.GT.nmax )
541 $ GO TO 80
542 laa = lda*na
543*
544* Generate the matrix A.
545*
546 CALL zmake( 'ge', ' ', ' ', ma, na, a, nmax, aa, lda,
547 $ reset, zero )
548*
549 DO 70 icb = 1, 3
550 transb = ich( icb: icb )
551 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
552*
553 IF( tranb )THEN
554 mb = n
555 nb = k
556 ELSE
557 mb = k
558 nb = n
559 END IF
560* Set LDB to 1 more than minimum value if room.
561 ldb = mb
562 IF( ldb.LT.nmax )
563 $ ldb = ldb + 1
564* Skip tests if not enough room.
565 IF( ldb.GT.nmax )
566 $ GO TO 70
567 lbb = ldb*nb
568*
569* Generate the matrix B.
570*
571 CALL zmake( 'ge', ' ', ' ', mb, nb, b, nmax, bb,
572 $ ldb, reset, zero )
573*
574 DO 60 ia = 1, nalf
575 alpha = alf( ia )
576*
577 DO 50 ib = 1, nbet
578 beta = bet( ib )
579*
580* Generate the matrix C.
581*
582 CALL zmake( 'ge', ' ', ' ', m, n, c, nmax,
583 $ cc, ldc, reset, zero )
584*
585 nc = nc + 1
586*
587* Save every datum before calling the
588* subroutine.
589*
590 tranas = transa
591 tranbs = transb
592 ms = m
593 ns = n
594 ks = k
595 als = alpha
596 DO 10 i = 1, laa
597 as( i ) = aa( i )
598 10 CONTINUE
599 ldas = lda
600 DO 20 i = 1, lbb
601 bs( i ) = bb( i )
602 20 CONTINUE
603 ldbs = ldb
604 bls = beta
605 DO 30 i = 1, lcc
606 cs( i ) = cc( i )
607 30 CONTINUE
608 ldcs = ldc
609*
610* Call the subroutine.
611*
612 IF( trace )
613 $ CALL zprcn1(ntra, nc, sname, iorder,
614 $ transa, transb, m, n, k, alpha, lda,
615 $ ldb, beta, ldc)
616 IF( rewi )
617 $ rewind ntra
618 CALL czgemm( iorder, transa, transb, m, n,
619 $ k, alpha, aa, lda, bb, ldb,
620 $ beta, cc, ldc )
621*
622* Check if error-exit was taken incorrectly.
623*
624 IF( .NOT.ok )THEN
625 WRITE( nout, fmt = 9994 )
626 fatal = .true.
627 GO TO 120
628 END IF
629*
630* See what data changed inside subroutines.
631*
632 isame( 1 ) = transa.EQ.tranas
633 isame( 2 ) = transb.EQ.tranbs
634 isame( 3 ) = ms.EQ.m
635 isame( 4 ) = ns.EQ.n
636 isame( 5 ) = ks.EQ.k
637 isame( 6 ) = als.EQ.alpha
638 isame( 7 ) = lze( as, aa, laa )
639 isame( 8 ) = ldas.EQ.lda
640 isame( 9 ) = lze( bs, bb, lbb )
641 isame( 10 ) = ldbs.EQ.ldb
642 isame( 11 ) = bls.EQ.beta
643 IF( null )THEN
644 isame( 12 ) = lze( cs, cc, lcc )
645 ELSE
646 isame( 12 ) = lzeres( 'ge', ' ', m, n, cs,
647 $ cc, ldc )
648 END IF
649 isame( 13 ) = ldcs.EQ.ldc
650*
651* If data was incorrectly changed, report
652* and return.
653*
654 same = .true.
655 DO 40 i = 1, nargs
656 same = same.AND.isame( i )
657 IF( .NOT.isame( i ) )
658 $ WRITE( nout, fmt = 9998 )i
659 40 CONTINUE
660 IF( .NOT.same )THEN
661 fatal = .true.
662 GO TO 120
663 END IF
664*
665 IF( .NOT.null )THEN
666*
667* Check the result.
668*
669 CALL zmmch( transa, transb, m, n, k,
670 $ alpha, a, nmax, b, nmax, beta,
671 $ c, nmax, ct, g, cc, ldc, eps,
672 $ err, fatal, nout, .true. )
673 errmax = max( errmax, err )
674* If got really bad answer, report and
675* return.
676 IF( fatal )
677 $ GO TO 120
678 END IF
679*
680 50 CONTINUE
681*
682 60 CONTINUE
683*
684 70 CONTINUE
685*
686 80 CONTINUE
687*
688 90 CONTINUE
689*
690 100 CONTINUE
691*
692 110 CONTINUE
693*
694* Report result.
695*
696 IF( errmax.LT.thresh )THEN
697 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
698 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
699 ELSE
700 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
701 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
702 END IF
703 GO TO 130
704*
705 120 CONTINUE
706 WRITE( nout, fmt = 9996 )sname
707 CALL zprcn1(nout, nc, sname, iorder, transa, transb,
708 $ m, n, k, alpha, lda, ldb, beta, ldc)
709*
710 130 CONTINUE
711 RETURN
712*
71310003 FORMAT( ' ', a13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
714 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
715 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
71610002 FORMAT( ' ', a13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
717 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
718 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
71910001 FORMAT( ' ', a13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
720 $ ' (', i6, ' CALL', 'S)' )
72110000 FORMAT( ' ', a13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
722 $ ' (', i6, ' CALL', 'S)' )
723 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
724 $ 'ANGED INCORRECTLY *******' )
725 9996 FORMAT( ' ******* ', a13,' FAILED ON CALL NUMBER:' )
726 9995 FORMAT( 1x, i6, ': ', a13,'(''', a1, ''',''', a1, ''',',
727 $ 3( i3, ',' ), '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3,
728 $ ',(', f4.1, ',', f4.1, '), C,', i3, ').' )
729 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
730 $ '******' )
731*
732* End of ZCHK1.
733*
zprcn1
subroutine zprcn1(nout, nc, sname, iorder, transa, transb, m, n, k, alpha, lda, ldb, beta, ldc)
Definition c_zblat3.f:738
lze
logical function lze(ri, rj, lr)
Definition zblat2.f:3075
lzeres
logical function lzeres(type, uplo, m, n, aa, as, lda)
Definition zblat2.f:3105
zmake
subroutine zmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition zblat2.f:2751
zmmch
subroutine zmmch(transa, transb, m, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
Definition zblat3.f:3266
Here is the call graph for this function: