LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cchk1 ( character*12  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,
integer  IORDER 
)

Definition at line 429 of file c_cblat3.f.

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

Here is the call graph for this function: