LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ cchk1()

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 402 of file cblat3.f.

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