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

◆ zchk1()

subroutine zchk1 ( 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,
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 404 of file zblat3.f.

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