pzsepreq.f

Go to the documentation of this file.

*
*
      SUBROUTINE pzsepreq( 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 ..
      INTEGER            INFO, MEMSIZE, NIN, NNOCHECK, NOUT, NPASSED,
     $                   nskipped, ntests
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      COMPLEX*16         MEM( MEMSIZE )
*     ..
*
*  Purpose
*  =======
*
*  PZSEPREQ performs one request from the input file 'SEP.dat'
*  A request is the cross product of the specifications in the
*  input file.  PZSEPREQ prints one line per test.
*
*  Arguments
*  =========
*
*  NIN      (local input) INTEGER
*           The unit number for the input file 'SEP.dat'
*
*  MEM      (local input) COMPLEX*16         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            ZPLXSZ, INTGSZ
      parameter( zplxsz = 16, intgsz = 4 )
      INTEGER            DBLESZ
      parameter( dblesz = 8 )
      INTEGER            MAXSETSIZE
      parameter( maxsetsize = 50 )
*     ..
*     .. Local Scalars ..
      CHARACTER          SUBTESTS
      INTEGER            CONTEXT, IAM, IMIDPAD, INITCON, IPOSTPAD,
     $                   iprepad, isizeheevx, isizesubtst, isizetst,
     $                   lda, llrwork, matsize, mattype, mycol, myrow,
     $                   n, nb, nmatsizes, nmattypes, nnodes, np, npcol,
     $                   npconfigs, nprow, nq, nuplos, order, pconfig,
     $                   ptra, ptrcopya, ptrgap, ptriclus, ptrifail,
     $                   ptriwrk, ptrrwork, ptrw, ptrw2, ptrwork, ptrz,
     $                   res, rsizechk, rsizeheevx, rsizeqtq,
     $                   rsizesubtst, rsizetst, sizeheevx, sizemqrleft,
     $                   sizemqrright, sizeqrf, sizesubtst, sizetms,
     $                   sizetst, uplo, sizeheevd, rsizeheevd,
     $                   isizeheevd
      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, pdsepinfo, pzlasizesep, pzseptst
*     ..
*     .. 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 pzlasizesep( desca, iprepad, ipostpad,
     $                                    sizemqrleft, sizemqrright,
     $                                    sizeqrf, sizetms, rsizeqtq,
     $                                    rsizechk, sizeheevx,
     $                                    rsizeheevx, isizeheevx,
     $                                    sizeheevd, rsizeheevd,
     $                                    isizeheevd,
     $                                    sizesubtst, rsizesubtst,
     $                                    isizesubtst, sizetst,
     $                                    rsizetst, isizetst )
*
                        ptra = 1
                        ptrz = ptra + lda*nq + iprepad + ipostpad
                        ptrcopya = ptrz + lda*nq + iprepad + ipostpad
                        ptrw = ptrcopya + lda*nq + iprepad + ipostpad
                        ptrw2 = ptrw + iceil( max( n, 1 )+iprepad+
     $                          ipostpad, zplxsz / dblesz )
                        ptrwork = ptrw2 + iceil( max( n, 1 )+iprepad+
     $                            ipostpad, zplxsz / dblesz )
                        ptrgap = ptrwork + sizetst + iprepad + ipostpad
                        ptrifail = ptrgap + iceil( nprow*npcol+iprepad+
     $                             ipostpad, zplxsz / dblesz )
                        ptriclus = ptrifail + iceil( n+iprepad+ipostpad,
     $                             zplxsz / intgsz )
                        ptriwrk = ptriclus + iceil( 2*nprow*npcol+
     $                            iprepad+ipostpad, zplxsz / intgsz )
                        ptrrwork = ptriwrk + iceil( isizetst+iprepad+
     $                             ipostpad, zplxsz / intgsz )
                        llrwork = ( memsize-ptrrwork+1 )*zplxsz / dblesz
C                       LLRWORK = ( MEMSIZE-PTRRWORK-IPREPAD-IPOSTPAD+1)
C    $                       *ZPLXSZ / DBLESZ
                        ntests = ntests + 1
                        IF( llrwork.LT.rsizetst ) THEN
                           nskipped = nskipped + 1
                        ELSE
                           CALL pzseptst( 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 ),
     $                                    sizetst, mem( ptrrwork ),
     $                                    llrwork, mem( ptriwrk ),
     $                                    isizetst, 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=* )' PZSEPREQ 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 PZDSEPREQ
*
      SUBROUTINE pzsepreq( NIN, MEM, MEMSIZE, NOUT, ISEED, NTESTS, …
      END