LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ 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:2744
lceres
logical function lceres(type, uplo, m, n, aa, as, lda)
Definition cblat2.f:3097
lce
logical function lce(ri, rj, lr)
Definition cblat2.f:3067
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:188
Here is the call graph for this function: