"Fossies" - the Fresh Open Source Software Archive

Member "lapack-3.9.1/TESTING/EIG/alarqg.f" (25 Mar 2021, 6142 Bytes) of package /linux/misc/lapack-3.9.1.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Fortran 77 source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "alarqg.f": 3.9.0_vs_3.9.1.

    1 *> \brief \b ALARQG
    2 *
    3 *  =========== DOCUMENTATION ===========
    4 *
    5 * Online html documentation available at
    6 *            http://www.netlib.org/lapack/explore-html/
    7 *
    8 *  Definition:
    9 *  ===========
   10 *
   11 *       SUBROUTINE ALARQG( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
   12 *
   13 *       .. Scalar Arguments ..
   14 *       CHARACTER*3        PATH
   15 *       INTEGER            NIN, NMATS, NOUT, NTYPES
   16 *       ..
   17 *       .. Array Arguments ..
   18 *       LOGICAL            DOTYPE( * )
   19 *       ..
   20 *
   21 *
   22 *> \par Purpose:
   23 *  =============
   24 *>
   25 *> \verbatim
   26 *>
   27 *> ALARQG handles input for the LAPACK test program.  It is called
   28 *> to evaluate the input line which requested NMATS matrix types for
   29 *> PATH.  The flow of control is as follows:
   30 *>
   31 *> If NMATS = NTYPES then
   32 *>    DOTYPE(1:NTYPES) = .TRUE.
   33 *> else
   34 *>    Read the next input line for NMATS matrix types
   35 *>    Set DOTYPE(I) = .TRUE. for each valid type I
   36 *> endif
   37 *> \endverbatim
   38 *
   39 *  Arguments:
   40 *  ==========
   41 *
   42 *> \param[in] PATH
   43 *> \verbatim
   44 *>          PATH is CHARACTER*3
   45 *>          An LAPACK path name for testing.
   46 *> \endverbatim
   47 *>
   48 *> \param[in] NMATS
   49 *> \verbatim
   50 *>          NMATS is INTEGER
   51 *>          The number of matrix types to be used in testing this path.
   52 *> \endverbatim
   53 *>
   54 *> \param[out] DOTYPE
   55 *> \verbatim
   56 *>          DOTYPE is LOGICAL array, dimension (NTYPES)
   57 *>          The vector of flags indicating if each type will be tested.
   58 *> \endverbatim
   59 *>
   60 *> \param[in] NTYPES
   61 *> \verbatim
   62 *>          NTYPES is INTEGER
   63 *>          The maximum number of matrix types for this path.
   64 *> \endverbatim
   65 *>
   66 *> \param[in] NIN
   67 *> \verbatim
   68 *>          NIN is INTEGER
   69 *>          The unit number for input.  NIN >= 1.
   70 *> \endverbatim
   71 *>
   72 *> \param[in] NOUT
   73 *> \verbatim
   74 *>          NOUT is INTEGER
   75 *>          The unit number for output.  NOUT >= 1.
   76 *> \endverbatim
   77 *
   78 *  Authors:
   79 *  ========
   80 *
   81 *> \author Univ. of Tennessee
   82 *> \author Univ. of California Berkeley
   83 *> \author Univ. of Colorado Denver
   84 *> \author NAG Ltd.
   85 *
   86 *> \ingroup aux_eig
   87 *
   88 *  =====================================================================
   89       SUBROUTINE ALARQG( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
   90 *
   91 *  -- LAPACK test routine --
   92 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
   93 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
   94 *
   95 *     .. Scalar Arguments ..
   96       CHARACTER*3        PATH
   97       INTEGER            NIN, NMATS, NOUT, NTYPES
   98 *     ..
   99 *     .. Array Arguments ..
  100       LOGICAL            DOTYPE( * )
  101 *     ..
  102 *
  103 * ======================================================================
  104 *
  105 *     .. Local Scalars ..
  106       LOGICAL            FIRSTT
  107       CHARACTER          C1
  108       CHARACTER*10       INTSTR
  109       CHARACTER*80       LINE
  110       INTEGER            I, I1, IC, J, K, LENP, NT
  111 *     ..
  112 *     .. Local Arrays ..
  113       INTEGER            NREQ( 100 )
  114 *     ..
  115 *     .. Intrinsic Functions ..
  116       INTRINSIC          LEN
  117 *     ..
  118 *     .. Data statements ..
  119       DATA               INTSTR / '0123456789' /
  120 *     ..
  121 *     .. Executable Statements ..
  122 *
  123       IF( NMATS.GE.NTYPES ) THEN
  124 *
  125 *        Test everything if NMATS >= NTYPES.
  126 *
  127          DO 10 I = 1, NTYPES
  128             DOTYPE( I ) = .TRUE.
  129    10    CONTINUE
  130       ELSE
  131          DO 20 I = 1, NTYPES
  132             DOTYPE( I ) = .FALSE.
  133    20    CONTINUE
  134          FIRSTT = .TRUE.
  135 *
  136 *        Read a line of matrix types if 0 < NMATS < NTYPES.
  137 *
  138          IF( NMATS.GT.0 ) THEN
  139             READ( NIN, FMT = '(A80)', END = 90 )LINE
  140             LENP = LEN( LINE )
  141             I = 0
  142             DO 60 J = 1, NMATS
  143                NREQ( J ) = 0
  144                I1 = 0
  145    30          CONTINUE
  146                I = I + 1
  147                IF( I.GT.LENP ) THEN
  148                   IF( J.EQ.NMATS .AND. I1.GT.0 ) THEN
  149                      GO TO 60
  150                   ELSE
  151                      WRITE( NOUT, FMT = 9995 )LINE
  152                      WRITE( NOUT, FMT = 9994 )NMATS
  153                      GO TO 80
  154                   END IF
  155                END IF
  156                IF( LINE( I: I ).NE.' ' .AND. LINE( I: I ).NE.',' ) THEN
  157                   I1 = I
  158                   C1 = LINE( I1: I1 )
  159 *
  160 *              Check that a valid integer was read
  161 *
  162                   DO 40 K = 1, 10
  163                      IF( C1.EQ.INTSTR( K: K ) ) THEN
  164                         IC = K - 1
  165                         GO TO 50
  166                      END IF
  167    40             CONTINUE
  168                   WRITE( NOUT, FMT = 9996 )I, LINE
  169                   WRITE( NOUT, FMT = 9994 )NMATS
  170                   GO TO 80
  171    50             CONTINUE
  172                   NREQ( J ) = 10*NREQ( J ) + IC
  173                   GO TO 30
  174                ELSE IF( I1.GT.0 ) THEN
  175                   GO TO 60
  176                ELSE
  177                   GO TO 30
  178                END IF
  179    60       CONTINUE
  180          END IF
  181          DO 70 I = 1, NMATS
  182             NT = NREQ( I )
  183             IF( NT.GT.0 .AND. NT.LE.NTYPES ) THEN
  184                IF( DOTYPE( NT ) ) THEN
  185                   IF( FIRSTT )
  186      $               WRITE( NOUT, FMT = * )
  187                   FIRSTT = .FALSE.
  188                   WRITE( NOUT, FMT = 9997 )NT, PATH
  189                END IF
  190                DOTYPE( NT ) = .TRUE.
  191             ELSE
  192                WRITE( NOUT, FMT = 9999 )PATH, NT, NTYPES
  193  9999          FORMAT( ' *** Invalid type request for ', A3, ', type  ',
  194      $               I4, ': must satisfy  1 <= type <= ', I2 )
  195             END IF
  196    70    CONTINUE
  197    80    CONTINUE
  198       END IF
  199       RETURN
  200 *
  201    90 CONTINUE
  202       WRITE( NOUT, FMT = 9998 )PATH
  203  9998 FORMAT( /' *** End of file reached when trying to read matrix ',
  204      $      'types for ', A3, /' *** Check that you are requesting the',
  205      $      ' right number of types for each path', / )
  206  9997 FORMAT( ' *** Warning:  duplicate request of matrix type ', I2,
  207      $      ' for ', A3 )
  208  9996 FORMAT( //' *** Invalid integer value in column ', I2,
  209      $      ' of input', ' line:', /A79 )
  210  9995 FORMAT( //' *** Not enough matrix types on input line', /A79 )
  211  9994 FORMAT( ' ==> Specify ', I4, ' matrix types on this line or ',
  212      $      'adjust NTYPES on previous line' )
  213       WRITE( NOUT, FMT = * )
  214       STOP
  215 *
  216 *     End of ALARQG
  217 *
  218       END