alarqg.f

Go to the documentation of this file.

*> \brief \b ALARQG
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ALARQG( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
*       .. Scalar Arguments ..
*       CHARACTER*3        PATH
*       INTEGER            NIN, NMATS, NOUT, NTYPES
*       ..
*       .. Array Arguments ..
*       LOGICAL            DOTYPE( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ALARQG handles input for the LAPACK test program.  It is called
*> to evaluate the input line which requested NMATS matrix types for
*> PATH.  The flow of control is as follows:
*>
*> IF NMATS = NTYPES THEN
*>    DOTYPE(1:NTYPES) = .TRUE.
*> ELSE
*>    Read the next input line for NMATS matrix types
*>    Set DOTYPE(I) = .TRUE. for each valid type I
*> END IF
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] PATH
*> \verbatim
*>          PATH is CHARACTER*3
*>          An LAPACK path name for testing.
*> \endverbatim
*>
*> \param[in] NMATS
*> \verbatim
*>          NMATS is INTEGER
*>          The number of matrix types to be used in testing this path.
*> \endverbatim
*>
*> \param[out] DOTYPE
*> \verbatim
*>          DOTYPE is LOGICAL array, dimension (NTYPES)
*>          The vector of flags indicating if each type will be tested.
*> \endverbatim
*>
*> \param[in] NTYPES
*> \verbatim
*>          NTYPES is INTEGER
*>          The maximum number of matrix types for this path.
*> \endverbatim
*>
*> \param[in] NIN
*> \verbatim
*>          NIN is INTEGER
*>          The unit number for input.  NIN >= 1.
*> \endverbatim
*>
*> \param[in] NOUT
*> \verbatim
*>          NOUT is INTEGER
*>          The unit number for output.  NOUT >= 1.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup aux_eig
*
*  =====================================================================
      SUBROUTINE alarqg( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
*  -- LAPACK test routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER*3        PATH
      INTEGER            NIN, NMATS, NOUT, NTYPES
*     ..
*     .. Array Arguments ..
      LOGICAL            DOTYPE( * )
*     ..
*
* ======================================================================
*
*     .. Local Scalars ..
      LOGICAL            FIRSTT
      CHARACTER          C1
      CHARACTER*10       INTSTR
      CHARACTER*80       LINE
      INTEGER            I, I1, IC, J, K, LENP, NT
*     ..
*     .. Local Arrays ..
      INTEGER            NREQ( 100 )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          len
*     ..
*     .. Data statements ..
      DATA               intstr / '0123456789' /
*     ..
*     .. Executable Statements ..
*
      IF( nmats.GE.ntypes ) THEN
*
*        Test everything if NMATS >= NTYPES.
*
         DO 10 i = 1, ntypes
            dotype( i ) = .true.
   10    CONTINUE
      ELSE
         DO 20 i = 1, ntypes
            dotype( i ) = .false.
   20    CONTINUE
         firstt = .true.
*
*        Read a line of matrix types if 0 < NMATS < NTYPES.
*
         IF( nmats.GT.0 ) THEN
            READ( nin, fmt = '(A80)', END = 90 )line
            lenp = len( line )
            i = 0
            DO 60 j = 1, nmats
               nreq( j ) = 0
               i1 = 0
   30          CONTINUE
               i = i + 1
               IF( i.GT.lenp ) THEN
                  IF( j.EQ.nmats .AND. i1.GT.0 ) THEN
                     GO TO 60
                  ELSE
                     WRITE( nout, fmt = 9995 )line
                     WRITE( nout, fmt = 9994 )nmats
                     GO TO 80
                  END IF
               END IF
               IF( line( i: i ).NE.' ' .AND. line( i: i ).NE.',' ) THEN
                  i1 = i
                  c1 = line( i1: i1 )
*
*              Check that a valid integer was read
*
                  DO 40 k = 1, 10
                     IF( c1.EQ.intstr( k: k ) ) THEN
                        ic = k - 1
                        GO TO 50
                     END IF
   40             CONTINUE
                  WRITE( nout, fmt = 9996 )i, line
                  WRITE( nout, fmt = 9994 )nmats
                  GO TO 80
   50             CONTINUE
                  nreq( j ) = 10*nreq( j ) + ic
                  GO TO 30
               ELSE IF( i1.GT.0 ) THEN
                  GO TO 60
               ELSE
                  GO TO 30
               END IF
   60       CONTINUE
         END IF
         DO 70 i = 1, nmats
            nt = nreq( i )
            IF( nt.GT.0 .AND. nt.LE.ntypes ) THEN
               IF( dotype( nt ) ) THEN
                  IF( firstt )
     $               WRITE( nout, fmt = * )
                  firstt = .false.
                  WRITE( nout, fmt = 9997 )nt, path
               END IF
               dotype( nt ) = .true.
            ELSE
               WRITE( nout, fmt = 9999 )path, nt, ntypes
 9999          FORMAT( ' *** Invalid type request for ', a3, ', type  ',
     $               i4, ': must satisfy  1 <= type <= ', i2 )
            END IF
   70    CONTINUE
   80    CONTINUE
      END IF
      RETURN
*
   90 CONTINUE
      WRITE( nout, fmt = 9998 )path
 9998 FORMAT( /' *** End of file reached when trying to read matrix ',
     $      'types for ', a3, /' *** Check that you are requesting the',
     $      ' right number of types for each path', / )
 9997 FORMAT( ' *** Warning:  duplicate request of matrix type ', i2,
     $      ' for ', a3 )
 9996 FORMAT( //' *** Invalid integer value in column ', i2,
     $      ' of input', ' line:', /a79 )
 9995 FORMAT( //' *** Not enough matrix types on input line', /a79 )
 9994 FORMAT( ' ==> Specify ', i4, ' matrix types on this line or ',
     $      'adjust NTYPES on previous line' )
      WRITE( nout, fmt = * )
      stop
*
*     End of ALARQG
*
      END