LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine dchk1 ( character*12  SNAME,
double precision  EPS,
double precision  THRESH,
integer  NOUT,
integer  NTRA,
logical  TRACE,
logical  REWI,
logical  FATAL,
integer  NIDIM,
integer, dimension( nidim )  IDIM,
integer  NALF,
double precision, dimension( nalf )  ALF,
integer  NBET,
double precision, dimension( nbet )  BET,
integer  NMAX,
double precision, dimension( nmax, nmax )  A,
double precision, dimension( nmax*nmax )  AA,
double precision, dimension( nmax*nmax )  AS,
double precision, dimension( nmax, nmax )  B,
double precision, dimension( nmax*nmax )  BB,
double precision, dimension( nmax*nmax )  BS,
double precision, dimension( nmax, nmax )  C,
double precision, dimension( nmax*nmax )  CC,
double precision, dimension( nmax*nmax )  CS,
double precision, dimension( nmax )  CT,
double precision, dimension( nmax )  G,
integer  IORDER 
)

Definition at line 420 of file c_dblat3.f.

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

Here is the call graph for this function: