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

◆ zchk1()

subroutine zchk1 ( 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,
complex*16, dimension( nalf )  alf,
integer  nbet,
complex*16, dimension( nbet )  bet,
integer  nmax,
complex*16, dimension( nmax, nmax )  a,
complex*16, dimension( nmax*nmax )  aa,
complex*16, dimension( nmax*nmax )  as,
complex*16, dimension( nmax, nmax )  b,
complex*16, dimension( nmax*nmax )  bb,
complex*16, dimension( nmax*nmax )  bs,
complex*16, dimension( nmax, nmax )  c,
complex*16, dimension( nmax*nmax )  cc,
complex*16, dimension( nmax*nmax )  cs,
complex*16, dimension( nmax )  ct,
double precision, dimension( nmax )  g,
integer  iorder 
)

Definition at line 426 of file c_zblat3.f.

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