pdsepreq.f

Go to the documentation of this file.

*
*
      SUBROUTINE pdsepreq( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED,
     $                     NTESTS, NSKIPPED, NNOCHECK, NPASSED, INFO )
*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      CHARACTER          HETERO
      INTEGER            INFO, MEMSIZE, NIN, NNOCHECK, NOUT, NPASSED,
     $                   nskipped, ntests
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      DOUBLE PRECISION   MEM( MEMSIZE )
*     ..
*
*  Purpose
*  =======
*
*  PDSEPREQ performs one request from the input file 'SEP.dat'
*  A request is the cross product of the specifications in the
*  input file.  PDSEPREQ prints one line per test.
*
*  Arguments
*  =========
*
*  NIN      (local input) INTEGER
*           The unit number for the input file 'SEP.dat'
*
*  MEM      (local input ) DOUBLE PRECISION ARRAY, dimension MEMSIZE
*           Array encompassing the available single precision memory
*
*  MEMSIZE  (local input)  INTEGER
*           Size of MEM array
*
*  NOUT     (local input) INTEGER
*           The unit number for output file.
*           NOUT = 6, output to screen,
*           NOUT = 0, output to stderr.
*           NOUT = 13, output to file, divide thresh by 10
*           NOUT = 14, output to file, divide thresh by 20
*           Only used on node 0.
*           NOUT = 13, 14 allow the threshold to be tighter for our
*           internal testing which means that when a user reports
*           a threshold error, it is more likely to be significant.
*
*  ISEED    (global input/output) INTEGER array, dimension 4
*           Random number generator seed
*
*  NTESTS   (global input/output) INTEGER
*           NTESTS = NTESTS + tests requested
*
*  NSKIPPED (global input/output) INTEGER
*           NSKIPPED = NSKIPPED + tests skipped
*
*  NNOCHECK (global input/output) INTEGER
*           NNOCHECK = NNOCHECK + tests completed but not checked
*
*  NPASSED  (global input/output) INTEGER
*           NPASSED = NPASSED + tests which passed all checks
*
*
*
*  INFO     (global output) INTEGER
*           0 = test request ran
*           -1 = end of file
*           -2 = incorrect .dat file
*
*
*     .. Parameters ..
*
      INTEGER            BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
     $                   mb_, nb_, rsrc_, csrc_, lld_
      parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
     $                   ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
     $                   rsrc_ = 7, csrc_ = 8, lld_ = 9 )
      INTEGER            DBLESZ, INTGSZ
      parameter( dblesz = 8, intgsz = 4 )
      INTEGER            MAXSETSIZE
      parameter( maxsetsize = 50 )
*     ..
*     .. Local Scalars ..
      CHARACTER          SUBTESTS
      INTEGER            CONTEXT, IAM, IMIDPAD, INITCON, IPOSTPAD,
     $                   iprepad, isizesubtst, isizesyevx, isizetst,
     $                   lda, llwork, matsize, mattype, mycol, myrow, n,
     $                   nb, nmatsizes, nmattypes, nnodes, np, npcol,
     $                   npconfigs, nprow, nq, nuplos, order, pconfig,
     $                   ptra, ptrcopya, ptrgap, ptriclus, ptrifail,
     $                   ptriwrk, ptrw, ptrw2, ptrwork, ptrz, res,
     $                   sizechk, sizemqrleft, sizemqrright, sizeqrf,
     $                   sizeqtq, sizesubtst, sizesyev, sizesyevx,
     $                   sizetms, sizetst, uplo, isizesyevd, sizesyevd
 
      DOUBLE PRECISION   ABSTOL, THRESH
*     ..
*     .. Local Arrays ..
      CHARACTER          UPLOS( 2 )
      INTEGER            DESCA( DLEN_ ), MATSIZES( MAXSETSIZE ),
     $                   mattypes( maxsetsize ), nbs( maxsetsize ),
     $                   npcols( maxsetsize ), nprows( maxsetsize )
*     ..
*     .. External Functions ..
      INTEGER            ICEIL, NUMROC
      EXTERNAL           iceil, numroc
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_abort, blacs_get, blacs_gridexit, 
     $                   blacs_gridinfo, blacs_gridinit, blacs_pinfo, 
     $                   descinit, pdlasizesqp, pdsepinfo, pdseptst
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max
*     ..
*     .. Executable Statements ..
*       This is just to keep ftnchek happy
      IF( block_cyclic_2d*csrc_*ctxt_*dlen_*dtype_*lld_*mb_*m_*nb_*n_*
     $    rsrc_.LT.0 )RETURN
*
      CALL blacs_pinfo( iam, nnodes )
      CALL blacs_get( -1, 0, initcon )
      CALL blacs_gridinit( initcon, 'R', 1, nnodes )
*
      CALL pdsepinfo( initcon, iam, nin, nout, maxsetsize, nmatsizes,
     $                matsizes, nuplos, uplos, npconfigs, nprows,
     $                npcols, nbs, nmattypes, mattypes, 22, subtests,
     $                thresh, order, abstol, info )
*
      CALL blacs_gridexit( initcon )
*
      IF( info.EQ.0 ) THEN
*
*
         DO 40 matsize = 1, nmatsizes
*
            DO 30 pconfig = 1, npconfigs
*
               DO 20 mattype = 1, nmattypes
*
                  DO 10 uplo = 1, nuplos
*
                     n = matsizes( matsize )
                     order = n
*
                     nprow = nprows( pconfig )
                     npcol = npcols( pconfig )
                     nb = nbs( pconfig )
*
                     np = numroc( n, nb, 0, 0, nprow )
                     nq = numroc( n, nb, 0, 0, npcol )
                     iprepad = max( nb, np )
                     imidpad = nb
                     ipostpad = max( nb, nq )
*
                     lda = max( np, 1 ) + imidpad
*
                     CALL blacs_get( -1, 0, context )
                     CALL blacs_gridinit( context, 'R', nprow, npcol )
                     CALL blacs_gridinfo( context, nprow, npcol, myrow,
     $                                    mycol )
*
                     IF( myrow.GE.0 ) THEN
                        CALL descinit( desca, n, n, nb, nb, 0, 0,
     $                                 context, lda, info )
                        CALL pdlasizesqp( desca, iprepad, ipostpad,
     $                                    sizemqrleft, sizemqrright,
     $                                    sizeqrf, sizetms, sizeqtq,
     $                                    sizechk, sizesyevx,
     $                                    isizesyevx, sizesyev,
     $                                    sizesyevd, isizesyevd,
     $                                    sizesubtst, isizesubtst,
     $                                    sizetst, isizetst )
*
                        ptra = 1
                        ptrz = ptra + lda*nq + iprepad + ipostpad
                        ptrcopya = ptrz + lda*nq + iprepad + ipostpad
                        ptrw = ptrcopya + lda*nq + iprepad + ipostpad
                        ptrw2 = ptrw + max( n, 1 ) + iprepad + ipostpad
                        ptrgap = ptrw2 + max( n, 1 ) + iprepad +
     $                           ipostpad
                        ptrifail = ptrgap + nprow*npcol + iprepad +
     $                             ipostpad
                        ptriclus = ptrifail + iceil( n+iprepad+ipostpad,
     $                             dblesz / intgsz )
                        ptriwrk = ptriclus + iceil( 2*nprow*npcol+
     $                            iprepad+ipostpad, dblesz / intgsz )
                        ptrwork = ptriwrk + iceil( isizetst+iprepad+
     $                            ipostpad, dblesz / intgsz )
                        llwork = memsize - ptrwork + 1
C                       LLWORK = MEMSIZE - PTRWORK - IPREPAD -
C    $                           IPOSTPAD + 1
                        ntests = ntests + 1
                        IF( llwork.LT.sizetst ) THEN
                           nskipped = nskipped + 1
                        ELSE
                           CALL pdseptst( desca, uplos( uplo ), n,
     $                                    mattypes( mattype ), subtests,
     $                                    thresh, n, abstol, iseed,
     $                                    mem( ptra ), mem( ptrcopya ),
     $                                    mem( ptrz ), lda, mem( ptrw ),
     $                                    mem( ptrw2 ), mem( ptrifail ),
     $                                    mem( ptriclus ),
     $                                    mem( ptrgap ), iprepad,
     $                                    ipostpad, mem( ptrwork ),
     $                                    llwork, mem( ptriwrk ),
     $                                    isizetst, hetero, nout, res )
*
                           IF( res.EQ.0 ) THEN
                              npassed = npassed + 1
                           ELSE IF( res.EQ.2 ) THEN
                              nnocheck = nnocheck + 1
                           ELSE IF( res.EQ.3 ) THEN
                              nskipped = nskipped + 1
                              WRITE( nout, fmt = * )' PDSEPREQ failed'
                              CALL blacs_abort( context, -1 )
                           END IF
                        END IF
                        CALL blacs_gridexit( context )
                     END IF
   10             CONTINUE
   20          CONTINUE
   30       CONTINUE
   40    CONTINUE
      END IF
*
*
      RETURN
*
*     End of PDDSEPREQ
*
      END