alareq.f

来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 166 行

      SUBROUTINE ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER*3        PATH
      INTEGER            NIN, NMATS, NOUT, NTYPES
*     ..
*     .. Array Arguments ..
      LOGICAL            DOTYPE( * )
*     ..
*
*  Purpose
*  =======
*
*  ALAREQ 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
*  endif
*
*  Arguments
*  =========
*
*  PATH    (input) CHARACTER*3
*          An LAPACK path name for testing.
*
*  NMATS   (input) INTEGER
*          The number of matrix types to be used in testing this path.
*
*  DOTYPE  (output) LOGICAL array, dimension (NTYPES)
*          The vector of flags indicating if each type will be tested.
*
*  NTYPES  (input) INTEGER
*          The maximum number of matrix types for this path.
*
*  NIN     (input) INTEGER
*          The unit number for input.  NIN >= 1.
*
*  NOUT    (input) INTEGER
*          The unit number for output.  NOUT >= 1.
*
*  =====================================================================
*
*     .. 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 ALAREQ
*
      END