pdblas2tstchke()

subroutine pdblas2tstchke	(	logical, dimension( * )	ltest,
		integer	inout,
		integer	nprocs
	)

Definition at line 1990 of file pdblas2tst.f.

*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            INOUT, NPROCS
*     ..
*     .. Array Arguments ..
      LOGICAL            LTEST( * )
*     ..
*
*  Purpose
*  =======
*
*  PDBLAS2TSTCHKE tests the error exits of the Level 2 PBLAS.
*
*  Arguments
*  =========
*
*  LTEST   (global input) LOGICAL array
*          On entry, LTEST is an array of dimension at least 7 (NSUBS).
*             If LTEST( 1 ) is .TRUE., PDGEMV will be tested;
*             If LTEST( 2 ) is .TRUE., PDSYMV will be tested;
*             If LTEST( 3 ) is .TRUE., PDTRMV will be tested;
*             If LTEST( 4 ) is .TRUE., PDTRSV will be tested;
*             If LTEST( 5 ) is .TRUE., PDGER  will be tested;
*             If LTEST( 6 ) is .TRUE., PDSYR  will be tested;
*             If LTEST( 7 ) is .TRUE., PDSYR2 will be tested;
*
*  INOUT   (global input) INTEGER
*          On entry,  INOUT  specifies  the unit number for output file.
*          When INOUT is 6, output to screen,  when INOUT = 0, output to
*          stderr. INOUT is only defined in process 0.
*
*  NPROCS  (global input) INTEGER
*          On entry, NPROCS specifies the total number of processes cal-
*          ling this routine.
*
*  Calling sequence encodings
*  ==========================
*
*  code Formal argument list                                Examples
*
*  11   (n,      v1,v2)                                     _SWAP, _COPY
*  12   (n,s1,   v1   )                                     _SCAL, _SCAL
*  13   (n,s1,   v1,v2)                                     _AXPY, _DOT_
*  14   (n,s1,i1,v1   )                                     _AMAX
*  15   (n,u1,   v1   )                                     _ASUM, _NRM2
*
*  21   (     trans,     m,n,s1,m1,v1,s2,v2)                _GEMV
*  22   (uplo,             n,s1,m1,v1,s2,v2)                _SYMV, _HEMV
*  23   (uplo,trans,diag,  n,   m1,v1      )                _TRMV, _TRSV
*  24   (                m,n,s1,v1,v2,m1)                   _GER_
*  25   (uplo,             n,s1,v1,   m1)                   _SYR
*  26   (uplo,             n,u1,v1,   m1)                   _HER
*  27   (uplo,             n,s1,v1,v2,m1)                   _SYR2, _HER2
*
*  31   (          transa,transb,     m,n,k,s1,m1,m2,s2,m3) _GEMM
*  32   (side,uplo,                   m,n,  s1,m1,m2,s2,m3) _SYMM, _HEMM
*  33   (     uplo,trans,               n,k,s1,m1,   s2,m3) _SYRK
*  34   (     uplo,trans,               n,k,u1,m1,   u2,m3) _HERK
*  35   (     uplo,trans,               n,k,s1,m1,m2,s2,m3) _SYR2K
*  36   (     uplo,trans,               n,k,s1,m1,m2,u2,m3) _HER2K
*  37   (                             m,n,  s1,m1,   s2,m3) _TRAN_
*  38   (side,uplo,transa,       diag,m,n,  s1,m1,m2      ) _TRMM, _TRSM
*  39   (          trans,             m,n,  s1,m1,   s2,m3) _GEADD
*  40   (     uplo,trans,             m,n,  s1,m1,   s2,m3) _TRADD
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            NSUBS
      parameter( nsubs = 7 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ABRTSAV
      INTEGER            I, ICTXT, MYCOL, MYROW, NPCOL, NPROW
*     ..
*     .. Local Arrays ..
      INTEGER            SCODE( NSUBS )
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_get, blacs_gridexit, blacs_gridinfo,
     $                   blacs_gridinit, pddimee, pdgemv, pdger,
     $                   pdmatee, pdoptee, pdsymv, pdsyr, pdsyr2,
     $                   pdtrmv, pdtrsv, pdvecee
*     ..
*     .. Common Blocks ..
      LOGICAL            ABRTFLG
      INTEGER            NOUT
      CHARACTER*7        SNAMES( NSUBS )
      COMMON             /snamec/snames
      COMMON             /pberrorc/nout, abrtflg
*     ..
*     .. Data Statements ..
      DATA               scode/21, 22, 23, 23, 24, 25, 27/
*     ..
*     .. Executable Statements ..
*
*     Temporarily define blacs grid to include all processes so
*     information can be broadcast to all processes.
*
      CALL blacs_get( -1, 0, ictxt )
      CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
*
*     Set ABRTFLG to FALSE so that the PBLAS error handler won't abort
*     on errors during these tests and set the output device unit for
*     it.
*
      abrtsav = abrtflg
      abrtflg = .false.
      nout    = inout
*
*     Test PDGEMV
*
      i = 1
      IF( ltest( i ) ) THEN
         CALL pdoptee( ictxt, nout, pdgemv, scode( i ), snames( i ) )
         CALL pddimee( ictxt, nout, pdgemv, scode( i ), snames( i ) )
         CALL pdmatee( ictxt, nout, pdgemv, scode( i ), snames( i ) )
         CALL pdvecee( ictxt, nout, pdgemv, scode( i ), snames( i ) )
      END IF
*
*     Test PDSYMV
*
      i = i + 1
      IF( ltest( i ) ) THEN
         CALL pdoptee( ictxt, nout, pdsymv, scode( i ), snames( i ) )
         CALL pddimee( ictxt, nout, pdsymv, scode( i ), snames( i ) )
         CALL pdmatee( ictxt, nout, pdsymv, scode( i ), snames( i ) )
         CALL pdvecee( ictxt, nout, pdsymv, scode( i ), snames( i ) )
      END IF
*
*     Test PDTRMV
*
      i = i + 1
      IF( ltest( i ) ) THEN
         CALL pdoptee( ictxt, nout, pdtrmv, scode( i ), snames( i ) )
         CALL pddimee( ictxt, nout, pdtrmv, scode( i ), snames( i ) )
         CALL pdmatee( ictxt, nout, pdtrmv, scode( i ), snames( i ) )
         CALL pdvecee( ictxt, nout, pdtrmv, scode( i ), snames( i ) )
      END IF
*
*     Test PDTRSV
*
      i = i + 1
      IF( ltest( i ) ) THEN
         CALL pdoptee( ictxt, nout, pdtrsv, scode( i ), snames( i ) )
         CALL pddimee( ictxt, nout, pdtrsv, scode( i ), snames( i ) )
         CALL pdmatee( ictxt, nout, pdtrsv, scode( i ), snames( i ) )
         CALL pdvecee( ictxt, nout, pdtrsv, scode( i ), snames( i ) )
      END IF
*
*     Test PDGER
*
      i = i + 1
      IF( ltest( i ) ) THEN
         CALL pddimee( ictxt, nout, pdger, scode( i ), snames( i ) )
         CALL pdvecee( ictxt, nout, pdger, scode( i ), snames( i ) )
         CALL pdmatee( ictxt, nout, pdger, scode( i ), snames( i ) )
      END IF
*
*     Test PDSYR
*
      i = i + 1
      IF( ltest( i ) ) THEN
         CALL pdoptee( ictxt, nout, pdsyr, scode( i ), snames( i ) )
         CALL pddimee( ictxt, nout, pdsyr, scode( i ), snames( i ) )
         CALL pdvecee( ictxt, nout, pdsyr, scode( i ), snames( i ) )
         CALL pdmatee( ictxt, nout, pdsyr, scode( i ), snames( i ) )
      END IF
*
*     Test PDSYR2
*
      i = i + 1
      IF( ltest( i ) ) THEN
         CALL pdoptee( ictxt, nout, pdsyr2, scode( i ), snames( i ) )
         CALL pddimee( ictxt, nout, pdsyr2, scode( i ), snames( i ) )
         CALL pdvecee( ictxt, nout, pdsyr2, scode( i ), snames( i ) )
         CALL pdmatee( ictxt, nout, pdsyr2, scode( i ), snames( i ) )
      END IF
*
      IF( myrow.EQ.0 .AND. mycol.EQ.0 )
     $   WRITE( nout, fmt = 9999 )
*
      CALL blacs_gridexit( ictxt )
*
*     Reset ABRTFLG to the value it had before calling this routine
*
      abrtflg = abrtsav
*
 9999 FORMAT( 2x, 'Error-exit tests completed.' )
*
      RETURN
*
*     End of PDBLAS2TSTCHKE
*

Here is the call graph for this function:

Here is the caller graph for this function: