LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ 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:187
lzeres
logical function lzeres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: zblat2.f:3077
zmake
subroutine zmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: zblat2.f:2723
lze
logical function lze(RI, RJ, LR)
Definition: zblat2.f:3047
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: