rdbsbr()

subroutine rdbsbr	(	integer	memused,
		integer, dimension(memlen)	mem,
		integer	memlen,
		integer	cmemused,
		character*1, dimension(cmemlen)	cmem,
		integer	cmemlen,
		integer	outnum
	)

Definition at line 1912 of file blacstest.f.

*
*  -- BLACS tester (version 1.0) --
*  University of Tennessee
*  December 15, 1994
*
*
*     .. Scalar Arguments ..
      INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM
*     ..
*     .. Array Arguments ..
      CHARACTER*1 CMEM(CMEMLEN)
      INTEGER MEM(MEMLEN)
*     ..
*
*     Purpose
*     =======
*     RDBSBR:  Read and process the input file BSBR.dat.
*
*     Arguments
*     =========
*     MEMUSED  (output) INTEGER
*              Number of elements in MEM that this subroutine ends up using.
*
*     MEM      (output) INTEGER array of dimension memlen
*              On output, holds information read in from sdrv.dat.
*
*     MEMLEN   (input) INTEGER
*              Number of elements of MEM that this subroutine
*              may safely write into.
*
*     CMEMUSED (output) INTEGER
*              Number of elements in CMEM that this subroutine ends up using.
*
*     CMEM     (output) CHARACTER*1 array of dimension cmemlen
*              On output, holds the values for UPLO and DIAG.
*
*     CMEMLEN  (input) INTEGER
*              Number of elements of CMEM that this subroutine
*              may safely write into.
*
*     OUTNUM   (input) INTEGER
*              Unit number of the output file.
*
*     =================================================================
*
*     .. Parameters ..
      INTEGER SDIN
      parameter( sdin = 12 )
*     ..
*     .. External Functions ..
      LOGICAL  LSAME
      EXTERNAL lsame
*     ..
*     .. Local Scalars ..
      INTEGER NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID, I, J
      INTEGER SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR
      INTEGER LDSPTR, LDDPTR, RSRCPTR, CSRCPTR, PPTR, QPTR
*     ..
*     .. Executable Statements
*
*     Open and read the file bsbr.dat.  The expected format is
*     below.
*
*------
*integer                         Number of scopes
*array of CHAR*1's               Values for Scopes
*integer                         Number of topologies
*array of CHAR*1's               Values for TOP
*integer                         number of shapes of the matrix
*array of CHAR*1's               UPLO
*array of CHAR*1's               DIAG: unit diagonal or not?
*integer                         number of nmat
*array of integers               M: number of rows in matrix
*array of integers               N: number of columns in matrix
*integer                         LDA: leading dimension on source proc
*integer                         LDA: leading dimension on dest proc
*integer                         number of source/dest pairs
*array of integers               RSRC: process row of message source
*array of integers               CSRC: process column of msg. src.
*integer                         Number of grids
*array of integers               NPROW: number of rows in process grid
*array of integers               NPCOL: number of col's in proc. grid
*------
*  note: UPLO stands for 'upper or lower trapezoidal or general
*        rectangular.'
*  note: the text descriptions as shown above are present in
*             the sample bsbr.dat included with this distribution,
*             but are not required.
*
*     Read input file
*
      memused = 1
      cmemused = 1
      OPEN(unit = sdin, file = 'bsbr.dat', status = 'OLD')
*
*     Read in scopes and topologies
*
      READ(sdin, *) nscope
      scopeptr = cmemused
      cmemused = scopeptr + nscope
      IF ( cmemused .GT. cmemlen ) THEN
         WRITE(outnum, 1000) cmemlen, nscope, 'SCOPES.'
         IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
         stop
      ELSE IF( nscope .LT. 1 ) THEN
         WRITE(outnum, 2000) 'SCOPE.'
         IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
         stop
      END IF
*
      READ(sdin, *) ( cmem(scopeptr+i), i = 0, nscope-1 )
      DO 20 i = 0, nscope-1
         IF( lsame(cmem(scopeptr+i), 'R') ) THEN
            cmem(scopeptr+i) = 'R'
         ELSE IF( lsame(cmem(scopeptr+i), 'C') ) THEN
            cmem(scopeptr+i) = 'C'
         ELSE IF( lsame(cmem(scopeptr+i), 'A') ) THEN
            cmem(scopeptr+i) = 'A'
         ELSE
            WRITE(outnum, 3000) 'SCOPE', cmem(scopeptr+i)
            IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
            stop
         END IF
   20 CONTINUE
*
      READ(sdin, *) ntop
      topptr = cmemused
      cmemused = topptr + ntop
      IF ( cmemused .GT. cmemlen ) THEN
         WRITE(outnum, 1000) cmemlen, ntop, 'TOPOLOGIES.'
         IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
         stop
      ELSE IF( ntop .LT. 1 ) THEN
         WRITE(outnum, 2000) 'TOPOLOGY.'
         IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
         stop
      END IF
      READ(sdin, *) ( cmem(topptr+i), i = 0, ntop-1 )
*
*
*     Read in number of shapes, and values of UPLO and DIAG
*
      READ(sdin, *) nshape
      uploptr = cmemused
      diagptr = uploptr + nshape
      cmemused = diagptr + nshape
      IF ( cmemused .GT. cmemlen ) THEN
         WRITE(outnum, 1000) cmemlen, nshape, 'MATRIX SHAPES.'
         IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
         stop
      ELSE IF( nshape .LT. 1 ) THEN
         WRITE(outnum, 2000) 'MATRIX SHAPE.'
         IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
         stop
      END IF
*
*     Read in, upcase, and fatal error if UPLO/DIAG not recognized
*
      READ(sdin, *) ( cmem(uploptr+i), i = 0, nshape-1 )
      DO 30 i = 0, nshape-1
         IF( lsame(cmem(uploptr+i), 'G') ) THEN
            cmem(uploptr+i) = 'G'
         ELSE IF( lsame(cmem(uploptr+i), 'U') ) THEN
            cmem(uploptr+i) = 'U'
         ELSE IF( lsame(cmem(uploptr+i), 'L') ) THEN
            cmem(uploptr+i) = 'L'
         ELSE
            WRITE(outnum, 3000) 'UPLO ', cmem(uploptr+i)
            IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
            stop
         END IF
   30 CONTINUE
*
      READ(sdin, *) ( cmem(diagptr+i), i = 0, nshape-1 )
      DO 40 i = 0, nshape-1
         IF( cmem(uploptr+i) .NE. 'G' ) THEN
            IF( lsame(cmem(diagptr+i), 'U') ) THEN
               cmem( diagptr+i ) = 'U'
            ELSE IF( lsame(cmem(diagptr+i), 'N') ) THEN
               cmem(diagptr+i) = 'N'
            ELSE
               WRITE(outnum, 3000) 'DIAG ', cmem(diagptr+i)
               IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
               stop
            END IF
         END IF
   40 CONTINUE
*
*     Read in number of matrices, and values for M, N, LDASRC, and LDADEST
*
      READ(sdin, *) nmat
      mptr = memused
      nptr = mptr + nmat
      ldsptr = nptr + nmat
      lddptr = ldsptr + nmat
      memused = lddptr + nmat
      IF( memused .GT. memlen ) THEN
         WRITE(outnum, 1000) memlen, nmat, 'MATRICES.'
         IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
         stop
      ELSE IF( nmat .LT. 1 ) THEN
         WRITE(outnum, 2000) 'MATRIX.'
         IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
         stop
      END IF
      READ(sdin, *) ( mem( mptr+i ), i = 0, nmat-1 )
      READ(sdin, *) ( mem( nptr+i ), i = 0, nmat-1 )
      READ(sdin, *) ( mem( ldsptr+i ), i = 0, nmat-1 )
      READ(sdin, *) ( mem( lddptr+i ), i = 0, nmat-1 )
*
*     Make sure matrix values are legal
*
      CALL chkmatdat( outnum, 'BSBR.dat', .false., nmat, mem(mptr),
     $                mem(nptr), mem(ldsptr), mem(lddptr), mem(lddptr) )
*
*     Read in number of src pairs, and values of src
*
      READ(sdin, *) nsrc
      rsrcptr  = memused
      csrcptr  = rsrcptr  + nsrc
      memused  = csrcptr + nsrc
      IF( memused .GT. memlen ) THEN
         WRITE(outnum, 1000) memlen, nmat, 'SRC.'
         IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
         stop
      ELSE IF( nsrc .LT. 1 ) THEN
         WRITE(outnum, 2000) 'SRC.'
         IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
         stop
      END IF
      READ(sdin, *) ( mem(rsrcptr+i), i = 0, nsrc-1 )
      READ(sdin, *) ( mem(csrcptr+i), i = 0, nsrc-1 )
*
*     Read in number of grids pairs, and values of P (process rows) and
*     Q (process columns)
*
      READ(sdin, *) ngrid
      pptr = memused
      qptr = pptr + ngrid
      memused = qptr + ngrid
      IF( memused .GT. memlen ) THEN
         WRITE(outnum, 1000) memlen, ngrid, 'PROCESS GRIDS.'
         IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
         stop
      ELSE IF( ngrid .LT. 1 ) THEN
         WRITE(outnum, 2000) 'PROCESS GRID'
         IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE( outnum )
         stop
      END IF
*
      READ(sdin, *) ( mem(pptr+i), i = 0, ngrid-1 )
      READ(sdin, *) ( mem(qptr+i), i = 0, ngrid-1 )
      IF( sdin .NE. 6 .AND. sdin .NE. 0 ) CLOSE( sdin )
*
*     Fatal error if we've got an illegal grid
*
      DO 70 j = 0, ngrid-1
         IF( mem(pptr+j).LT.1 .OR. mem(qptr+j).LT.1 ) THEN
            WRITE(outnum, 4000) mem(pptr+j), mem(qptr+j)
            IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
            stop
         END IF
   70 CONTINUE
*
*     Prepare output variables
*
      mem(memused)   = nscope
      mem(memused+1) = ntop
      mem(memused+2) = nshape
      mem(memused+3) = nmat
      mem(memused+4) = nsrc
      mem(memused+5) = ngrid
      memused = memused + 5
      cmemused = cmemused - 1
*
 1000 FORMAT('Mem too short (',i4,') to handle',i4,' ',a20)
 2000 FORMAT('Must have at least one ',a20)
 3000 FORMAT('UNRECOGNIZABLE ',a5,' ''', a1, '''.')
 4000 FORMAT('Illegal process grid: {',i3,',',i3,'}.')
*
      RETURN
*
*     End of RDBSBR.
*

Here is the call graph for this function:

Here is the caller graph for this function: