LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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  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 430 of file c_zblat3.f.

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