LAPACK  3.9.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 410 of file zblat3.f.

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