LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cchk1 ( character*6  SNAME,
real  EPS,
real  THRESH,
integer  NOUT,
integer  NTRA,
logical  TRACE,
logical  REWI,
logical  FATAL,
integer  NIDIM,
integer, dimension( nidim )  IDIM,
integer  NALF,
complex, dimension( nalf )  ALF,
integer  NBET,
complex, dimension( nbet )  BET,
integer  NMAX,
complex, dimension( nmax, nmax )  A,
complex, dimension( nmax*nmax )  AA,
complex, dimension( nmax*nmax )  AS,
complex, dimension( nmax, nmax )  B,
complex, dimension( nmax*nmax )  BB,
complex, dimension( nmax*nmax )  BS,
complex, dimension( nmax, nmax )  C,
complex, dimension( nmax*nmax )  CC,
complex, dimension( nmax*nmax )  CS,
complex, dimension( nmax )  CT,
real, dimension( nmax )  G 
)

Definition at line 408 of file cblat3.f.

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

Here is the call graph for this function: