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

◆ schk1()

subroutine schk1 ( character*13 sname,
real eps,
real thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nalf,
real, dimension( nalf ) alf,
integer nbet,
real, dimension( nbet ) bet,
integer nmax,
real, dimension( nmax, nmax ) a,
real, dimension( nmax*nmax ) aa,
real, dimension( nmax*nmax ) as,
real, dimension( nmax, nmax ) b,
real, dimension( nmax*nmax ) bb,
real, dimension( nmax*nmax ) bs,
real, dimension( nmax, nmax ) c,
real, dimension( nmax*nmax ) cc,
real, dimension( nmax*nmax ) cs,
real, dimension( nmax ) ct,
real, dimension( nmax ) g,
integer iorder )

Definition at line 434 of file c_sblat3.f.

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