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

◆ zchk1()

subroutine zchk1 ( character*7 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 )

Definition at line 413 of file zblat3.f.

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