dchkrfp.f

Go to the documentation of this file.

*> \brief \b DCHKRFP
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at 
*            http://www.netlib.org/lapack/explore-html/ 
*
*  Definition:
*  ===========
*
*       PROGRAM DCHKRFP
* 
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DCHKRFP is the main test program for the DOUBLE PRECISION linear
*> equation routines with RFP storage format
*>
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \verbatim
*>  MAXIN   INTEGER
*>          The number of different values that can be used for each of
*>          M, N, or NB
*>
*>  MAXRHS  INTEGER
*>          The maximum number of right hand sides
*>
*>  NTYPES  INTEGER
*>
*>  NMAX    INTEGER
*>          The maximum allowable value for N.
*>
*>  NIN     INTEGER
*>          The unit number for input
*>
*>  NOUT    INTEGER
*>          The unit number for output
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee 
*> \author Univ. of California Berkeley 
*> \author Univ. of Colorado Denver 
*> \author NAG Ltd. 
*
*> \date April 2012
*
*> \ingroup double_lin
*
*  =====================================================================
      PROGRAM dchkrfp
*
*  -- LAPACK test routine (version 3.4.1) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     April 2012
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            MAXIN
      parameter                ( maxin = 12 )
      INTEGER            NMAX
      parameter                ( nmax =  50 )
      INTEGER            MAXRHS
      parameter                ( maxrhs = 16 )
      INTEGER            NTYPES
      parameter                ( ntypes = 9 )
      INTEGER            NIN, NOUT
      parameter                ( nin = 5, nout = 6 )
*     ..
*     .. Local Scalars ..
      LOGICAL            FATAL, TSTERR
      INTEGER            VERS_MAJOR, VERS_MINOR, VERS_PATCH
      INTEGER            I, NN, NNS, NNT
      DOUBLE PRECISION   EPS, S1, S2, THRESH

*     ..
*     .. Local Arrays ..
      INTEGER            NVAL( maxin ), NSVAL( maxin ), NTVAL( ntypes )
      DOUBLE PRECISION   WORKA( nmax, nmax )
      DOUBLE PRECISION   WORKASAV( nmax, nmax )
      DOUBLE PRECISION   WORKB( nmax, maxrhs )
      DOUBLE PRECISION   WORKXACT( nmax, maxrhs )
      DOUBLE PRECISION   WORKBSAV( nmax, maxrhs )
      DOUBLE PRECISION   WORKX( nmax, maxrhs )
      DOUBLE PRECISION   WORKAFAC( nmax, nmax )
      DOUBLE PRECISION   WORKAINV( nmax, nmax )
      DOUBLE PRECISION   WORKARF( (nmax*(nmax+1))/2 )
      DOUBLE PRECISION   WORKAP( (nmax*(nmax+1))/2 )
      DOUBLE PRECISION   WORKARFINV( (nmax*(nmax+1))/2 )
      DOUBLE PRECISION   D_WORK_DLATMS( 3 * nmax )
      DOUBLE PRECISION   D_WORK_DPOT01( nmax )
      DOUBLE PRECISION   D_TEMP_DPOT02( nmax, maxrhs )
      DOUBLE PRECISION   D_TEMP_DPOT03( nmax, nmax )
      DOUBLE PRECISION   D_WORK_DLANSY( nmax )
      DOUBLE PRECISION   D_WORK_DPOT02( nmax )
      DOUBLE PRECISION   D_WORK_DPOT03( nmax )
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DSECND
      EXTERNAL           dlamch, dsecnd
*     ..
*     .. External Subroutines ..
      EXTERNAL           ilaver, ddrvrfp, ddrvrf1, ddrvrf2, ddrvrf3,
     +                   ddrvrf4
*     ..
*     .. Executable Statements ..
*
      s1 = dsecnd( )
      fatal = .false.
*
*     Read a dummy line.
*
      READ( nin, fmt = * )
*
*     Report LAPACK version tag (e.g. LAPACK-3.2.0)
*
      CALL ilaver( vers_major, vers_minor, vers_patch )
      WRITE( nout, fmt = 9994 ) vers_major, vers_minor, vers_patch
*
*     Read the values of N
*
      READ( nin, fmt = * )nn
      IF( nn.LT.1 ) THEN
         WRITE( nout, fmt = 9996 )' NN ', nn, 1
         nn = 0
         fatal = .true.
      ELSE IF( nn.GT.maxin ) THEN
         WRITE( nout, fmt = 9995 )' NN ', nn, maxin
         nn = 0
         fatal = .true.
      END IF
      READ( nin, fmt = * )( nval( i ), i = 1, nn )
      DO 10 i = 1, nn
         IF( nval( i ).LT.0 ) THEN
            WRITE( nout, fmt = 9996 )' M  ', nval( i ), 0
            fatal = .true.
         ELSE IF( nval( i ).GT.nmax ) THEN
            WRITE( nout, fmt = 9995 )' M  ', nval( i ), nmax
            fatal = .true.
         END IF
   10 CONTINUE
      IF( nn.GT.0 )
     $   WRITE( nout, fmt = 9993 )'N   ', ( nval( i ), i = 1, nn )
*
*     Read the values of NRHS
*
      READ( nin, fmt = * )nns
      IF( nns.LT.1 ) THEN
         WRITE( nout, fmt = 9996 )' NNS', nns, 1
         nns = 0
         fatal = .true.
      ELSE IF( nns.GT.maxin ) THEN
         WRITE( nout, fmt = 9995 )' NNS', nns, maxin
         nns = 0
         fatal = .true.
      END IF
      READ( nin, fmt = * )( nsval( i ), i = 1, nns )
      DO 30 i = 1, nns
         IF( nsval( i ).LT.0 ) THEN
            WRITE( nout, fmt = 9996 )'NRHS', nsval( i ), 0
            fatal = .true.
         ELSE IF( nsval( i ).GT.maxrhs ) THEN
            WRITE( nout, fmt = 9995 )'NRHS', nsval( i ), maxrhs
            fatal = .true.
         END IF
   30 CONTINUE
      IF( nns.GT.0 )
     $   WRITE( nout, fmt = 9993 )'NRHS', ( nsval( i ), i = 1, nns )
*
*     Read the matrix types
*
      READ( nin, fmt = * )nnt
      IF( nnt.LT.1 ) THEN
         WRITE( nout, fmt = 9996 )' NMA', nnt, 1
         nnt = 0
         fatal = .true.
      ELSE IF( nnt.GT.ntypes ) THEN
         WRITE( nout, fmt = 9995 )' NMA', nnt, ntypes
         nnt = 0
         fatal = .true.
      END IF
      READ( nin, fmt = * )( ntval( i ), i = 1, nnt )
      DO 320 i = 1, nnt
         IF( ntval( i ).LT.0 ) THEN
            WRITE( nout, fmt = 9996 )'TYPE', ntval( i ), 0
            fatal = .true.
         ELSE IF( ntval( i ).GT.ntypes ) THEN
            WRITE( nout, fmt = 9995 )'TYPE', ntval( i ), ntypes
            fatal = .true.
         END IF
  320 CONTINUE
      IF( nnt.GT.0 )
     $   WRITE( nout, fmt = 9993 )'TYPE', ( ntval( i ), i = 1, nnt )
*
*     Read the threshold value for the test ratios.
*
      READ( nin, fmt = * )thresh
      WRITE( nout, fmt = 9992 )thresh
*
*     Read the flag that indicates whether to test the error exits.
*
      READ( nin, fmt = * )tsterr
*
      IF( fatal ) THEN
         WRITE( nout, fmt = 9999 )
         stop
      END IF
*
      IF( fatal ) THEN
         WRITE( nout, fmt = 9999 )
         stop
      END IF
*
*     Calculate and print the machine dependent constants.
*
      eps = dlamch( 'Underflow threshold' )
      WRITE( nout, fmt = 9991 )'underflow', eps
      eps = dlamch( 'Overflow threshold' )
      WRITE( nout, fmt = 9991 )'overflow ', eps
      eps = dlamch( 'Epsilon' )
      WRITE( nout, fmt = 9991 )'precision', eps
      WRITE( nout, fmt = * )
*
*     Test the error exit of:
*
      IF( tsterr )
     $   CALL derrrfp( nout )
*
*     Test the routines: dpftrf, dpftri, dpftrs (as in DDRVPO).
*     This also tests the routines: dtfsm, dtftri, dtfttr, dtrttf.
*
      CALL ddrvrfp( nout, nn, nval, nns, nsval, nnt, ntval, thresh,
     $              worka, workasav, workafac, workainv, workb,
     $              workbsav, workxact, workx, workarf, workarfinv,
     $              d_work_dlatms, d_work_dpot01, d_temp_dpot02,
     $              d_temp_dpot03, d_work_dlansy, d_work_dpot02,
     $              d_work_dpot03 )
*
*     Test the routine: dlansf
*
      CALL ddrvrf1( nout, nn, nval, thresh, worka, nmax, workarf,
     +              d_work_dlansy )
*
*     Test the convertion routines:
*       dtfttp, dtpttf, dtfttr, dtrttf, dtrttp and dtpttr.
*
      CALL ddrvrf2( nout, nn, nval, worka, nmax, workarf,
     +              workap, workasav )
*
*     Test the routine: dtfsm
*
      CALL ddrvrf3( nout, nn, nval, thresh, worka, nmax, workarf,
     +              workainv, workafac, d_work_dlansy,
     +              d_work_dpot03, d_work_dpot01 )
*
*
*     Test the routine: dsfrk
*
      CALL ddrvrf4( nout, nn, nval, thresh, worka, workafac, nmax,
     +              workarf, workainv, nmax, d_work_dlansy)
*
      CLOSE ( nin )
      s2 = dsecnd( )
      WRITE( nout, fmt = 9998 )
      WRITE( nout, fmt = 9997 )s2 - s1
*
 9999 FORMAT( / ' Execution not attempted due to input errors' )
 9998 FORMAT( / ' End of tests' )
 9997 FORMAT( ' Total time used = ', f12.2, ' seconds', / )
 9996 FORMAT( ' !! Invalid input value: ', a4, '=', i6, '; must be >=',
     $      i6 )
 9995 FORMAT( ' !! Invalid input value: ', a4, '=', i6, '; must be <=',
     $      i6 )
 9994 FORMAT( /  ' Tests of the DOUBLE PRECISION LAPACK RFP routines ',
     $      / ' LAPACK VERSION ', i1, '.', i1, '.', i1,
     $      / / ' The following parameter values will be used:' )
 9993 FORMAT( 4x, a4, ':  ', 10i6, / 11x, 10i6 )
 9992 FORMAT( / ' Routines pass computational tests if test ratio is ',
     $      'less than', f8.2, / )
 9991 FORMAT( ' Relative machine ', a, ' is taken to be', d16.6 )
*
*     End of DCHKRFP
*
      END