dc/d94/pdgsepreq_8f_source.html

*

*


      SUBROUTINE pdgsepreq( NIN, MEM, MEMSIZE, NOUT, ISEED, NTESTS,

     $                      NSKIPPED, NNOCHECK, NPASSED, INFO )

*

*  -- ScaLAPACK test routine (version 1.7) --

*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,

*     and University of California, Berkeley.

*     October 15, 1999

*

*     .. Scalar Arguments ..

      INTEGER            INFO, MEMSIZE, NIN, NNOCHECK, NOUT, NPASSED,

     $                   nskipped, ntests

*     ..

*     .. Array Arguments ..

      INTEGER            ISEED( 4 )

      DOUBLE PRECISION   MEM( MEMSIZE )

*     ..

*

*  Purpose

*  =======

*

*  PDGSEPREQ performs one request from the input file 'SEP.dat'

*  A request is the cross product of the specifications in the

*  input file.  PDGSEPREQ 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 )

      DOUBLE PRECISION   FIVE

      parameter( five = 5.0d+0 )

      INTEGER            DBLESZ, INTGSZ

      parameter( dblesz = 8, intgsz = 4 )

      INTEGER            MAXSETSIZE

      parameter( maxsetsize = 50 )

*     ..

*     .. Local Scalars ..

      CHARACTER          SUBTESTS

      INTEGER            CONTEXT, IAM, IBTYPE, IMIDPAD, INITCON,

     $                   ipostpad, iprepad, isizesubtst, isizesyevx,

     $                   isizetst, lda, llwork, matsize, mattype, mycol,

     $                   myrow, n, nb, nibtypes, nmatsizes, nmattypes,

     $                   nnodes, np, npcol, npconfigs, nprow, nq,

     $                   nuplos, order, pconfig, ptra, ptrb, ptrcopya,

     $                   ptrcopyb, ptrgap, ptriclus, ptrifail, ptriwrk,

     $                   ptrw, ptrw2, ptrwork, ptrz, res, sizechk,

     $                   sizemqrleft, sizemqrright, sizeqrf, sizeqtq,

     $                   sizesubtst, sizesyevx, sizetms, sizetst, uplo

      DOUBLE PRECISION   ABSTOL, THRESH

*     ..

*     .. Local Arrays ..

      CHARACTER          UPLOS( 2 )

      INTEGER            DESCA( DLEN_ ), MATSIZES( MAXSETSIZE ),

     $                   mattypes( maxsetsize ), nbs( maxsetsize ),

     $                   npcols( maxsetsize ), nprows( maxsetsize )

*     ..

*     .. External Functions ..

      LOGICAL            LSAME

      INTEGER            ICEIL, NUMROC

      EXTERNAL           lsame, iceil, numroc

*     ..

*     .. External Subroutines ..

      EXTERNAL           blacs_abort, blacs_get, blacs_gridexit,

     $                   blacs_gridinfo, blacs_gridinit, blacs_pinfo,

     $                   descinit, pdgseptst, pdlasizegsep, pdsepinfo

*     ..

*     .. 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

*

*        Thresholds must be bigger for the generalized problem.

*

         thresh = thresh*five

*

         DO 50 matsize = 1, nmatsizes

*

            DO 40 pconfig = 1, npconfigs

*

               DO 30 mattype = 1, nmattypes

*

                  DO 20 uplo = 1, nuplos

                     IF( lsame( subtests, 'Y' ) ) THEN

                        nibtypes = 3

                     ELSE

                        nibtypes = 1

                     END IF

                     DO 10 ibtype = 1, nibtypes

*

                        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 pdlasizegsep( desca, iprepad, ipostpad,

     $                                        sizemqrleft, sizemqrright,

     $                                        sizeqrf, sizetms, sizeqtq,

     $                                        sizechk, sizesyevx,

     $                                        isizesyevx, sizesubtst,

     $                                        isizesubtst, sizetst,

     $                                        isizetst )

*

                           ptra = 1

                           ptrz = ptra + lda*nq + iprepad + ipostpad

                           ptrcopyb = ptrz + lda*nq + iprepad + ipostpad

                           ptrb = ptrcopyb + lda*nq + iprepad + ipostpad

                           ptrcopya = ptrb + 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 - ipostpad -

     $                              iprepad + 1

                           ntests = ntests + 1

                           IF( llwork.LT.sizetst ) THEN

                              nskipped = nskipped + 1

                           ELSE

                              CALL pdgseptst( desca, uplos( uplo ), n,

     $                                        mattypes( mattype ),

     $                                        ibtype, subtests, thresh,

     $                                        n, abstol, iseed,

     $                                        mem( ptra ),

     $                                        mem( ptrcopya ),

     $                                        mem( ptrb ),

     $                                        mem( ptrcopyb ),

     $                                        mem( ptrz ), lda,

     $                                        mem( ptrw ), mem( ptrw2 ),

     $                                        mem( ptrifail ),

     $                                        mem( ptriclus ),

     $                                        mem( ptrgap ), iprepad,

     $                                        ipostpad, mem( ptrwork ),

     $                                        llwork, 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 = * )

     $                              ' pDGSEPREQ failed'

                                 CALL blacs_abort( context, -1 )

                              END IF

                              CALL blacs_gridexit( context )

                           END IF

                        END IF

   10                CONTINUE

   20             CONTINUE

   30          CONTINUE

   40       CONTINUE

   50    CONTINUE

      END IF

*

*

      RETURN

*

*     End of PDDGSEPREQ

*


      END

descinit
subroutine descinit(desc, m, n, mb, nb, irsrc, icsrc, ictxt, lld, info)
Definition descinit.f:3

max
#define max(A, B)
Definition pcgemr.c:180

pdgsepreq
subroutine pdgsepreq(nin, mem, memsize, nout, iseed, ntests, nskipped, nnocheck, npassed, info)
Definition pdgsepreq.f:5

pdgseptst
subroutine pdgseptst(desca, uplo, n, mattype, ibtype, subtests, thresh, order, abstol, iseed, a, copya, b, copyb, z, lda, win, wnew, ifail, iclustr, gap, iprepad, ipostpad, work, lwork, iwork, liwork, nout, info)
Definition pdgseptst.f:8

pdlasizegsep
subroutine pdlasizegsep(desca, iprepad, ipostpad, sizemqrleft, sizemqrright, sizeqrf, sizetms, sizeqtq, sizechk, sizesyevx, isizesyevx, sizesubtst, isizesubtst, sizetst, isizetst)
Definition pdlasizegsep.f:8

pdsepinfo
subroutine pdsepinfo(context, iam, nin, nout, maxsetsize, nmatsizes, matsizes, nuplos, uplos, npconfigs, nprows, npcols, nbs, nmattypes, mattypes, maxtype, subtests, thresh, order, abstol, info)
Definition pdsepinfo.f:8