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

◆ cchk1()

subroutine cchk1 ( character*7 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 409 of file cblat3.f.

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