cchkeq.f

来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 454 行 · 第 1/2 页

      RESLTS( 2 ) = RESLTS( 2 ) / EPS
*
*     Test CPOEQU
*
      DO 290 N = 0, NSZ
*
         DO 270 I = 1, NSZ
            DO 260 J = 1, NSZ
               IF( I.LE.N .AND. J.EQ.I ) THEN
                  A( I, J ) = POW( I+J+1 )*( -1 )**( I+J )
               ELSE
                  A( I, J ) = CZERO
               END IF
  260       CONTINUE
  270    CONTINUE
*
         CALL CPOEQU( N, A, NSZ, R, RCOND, NORM, INFO )
*
         IF( INFO.NE.0 ) THEN
            RESLTS( 3 ) = ONE
         ELSE
            IF( N.NE.0 ) THEN
               RESLTS( 3 ) = MAX( RESLTS( 3 ),
     $                       ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
               RESLTS( 3 ) = MAX( RESLTS( 3 ),
     $                       ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
     $                       1 ) ) )
               DO 280 I = 1, N
                  RESLTS( 3 ) = MAX( RESLTS( 3 ),
     $                          ABS( ( R( I )-RPOW( I+1 ) ) / RPOW( I+
     $                          1 ) ) )
  280          CONTINUE
            END IF
         END IF
  290 CONTINUE
      A( MAX( NSZ-1, 1 ), MAX( NSZ-1, 1 ) ) = -CONE
      CALL CPOEQU( NSZ, A, NSZ, R, RCOND, NORM, INFO )
      IF( INFO.NE.MAX( NSZ-1, 1 ) )
     $   RESLTS( 3 ) = ONE
      RESLTS( 3 ) = RESLTS( 3 ) / EPS
*
*     Test CPPEQU
*
      DO 360 N = 0, NSZ
*
*        Upper triangular packed storage
*
         DO 300 I = 1, ( N*( N+1 ) ) / 2
            AP( I ) = CZERO
  300    CONTINUE
         DO 310 I = 1, N
            AP( ( I*( I+1 ) ) / 2 ) = POW( 2*I+1 )
  310    CONTINUE
*
         CALL CPPEQU( 'U', N, AP, R, RCOND, NORM, INFO )
*
         IF( INFO.NE.0 ) THEN
            RESLTS( 4 ) = ONE
         ELSE
            IF( N.NE.0 ) THEN
               RESLTS( 4 ) = MAX( RESLTS( 4 ),
     $                       ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
               RESLTS( 4 ) = MAX( RESLTS( 4 ),
     $                       ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
     $                       1 ) ) )
               DO 320 I = 1, N
                  RESLTS( 4 ) = MAX( RESLTS( 4 ),
     $                          ABS( ( R( I )-RPOW( I+1 ) ) / RPOW( I+
     $                          1 ) ) )
  320          CONTINUE
            END IF
         END IF
*
*        Lower triangular packed storage
*
         DO 330 I = 1, ( N*( N+1 ) ) / 2
            AP( I ) = CZERO
  330    CONTINUE
         J = 1
         DO 340 I = 1, N
            AP( J ) = POW( 2*I+1 )
            J = J + ( N-I+1 )
  340    CONTINUE
*
         CALL CPPEQU( 'L', N, AP, R, RCOND, NORM, INFO )
*
         IF( INFO.NE.0 ) THEN
            RESLTS( 4 ) = ONE
         ELSE
            IF( N.NE.0 ) THEN
               RESLTS( 4 ) = MAX( RESLTS( 4 ),
     $                       ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
               RESLTS( 4 ) = MAX( RESLTS( 4 ),
     $                       ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
     $                       1 ) ) )
               DO 350 I = 1, N
                  RESLTS( 4 ) = MAX( RESLTS( 4 ),
     $                          ABS( ( R( I )-RPOW( I+1 ) ) / RPOW( I+
     $                          1 ) ) )
  350          CONTINUE
            END IF
         END IF
*
  360 CONTINUE
      I = ( NSZ*( NSZ+1 ) ) / 2 - 2
      AP( I ) = -CONE
      CALL CPPEQU( 'L', NSZ, AP, R, RCOND, NORM, INFO )
      IF( INFO.NE.MAX( NSZ-1, 1 ) )
     $   RESLTS( 4 ) = ONE
      RESLTS( 4 ) = RESLTS( 4 ) / EPS
*
*     Test CPBEQU
*
      DO 460 N = 0, NSZ
         DO 450 KL = 0, MAX( N-1, 0 )
*
*           Test upper triangular storage
*
            DO 380 J = 1, NSZ
               DO 370 I = 1, NSZB
                  AB( I, J ) = CZERO
  370          CONTINUE
  380       CONTINUE
            DO 390 J = 1, N
               AB( KL+1, J ) = POW( 2*J+1 )
  390       CONTINUE
*
            CALL CPBEQU( 'U', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
*
            IF( INFO.NE.0 ) THEN
               RESLTS( 5 ) = ONE
            ELSE
               IF( N.NE.0 ) THEN
                  RESLTS( 5 ) = MAX( RESLTS( 5 ),
     $                          ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
                  RESLTS( 5 ) = MAX( RESLTS( 5 ),
     $                          ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
     $                          1 ) ) )
                  DO 400 I = 1, N
                     RESLTS( 5 ) = MAX( RESLTS( 5 ),
     $                             ABS( ( R( I )-RPOW( I+1 ) ) /
     $                             RPOW( I+1 ) ) )
  400             CONTINUE
               END IF
            END IF
            IF( N.NE.0 ) THEN
               AB( KL+1, MAX( N-1, 1 ) ) = -CONE
               CALL CPBEQU( 'U', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
               IF( INFO.NE.MAX( N-1, 1 ) )
     $            RESLTS( 5 ) = ONE
            END IF
*
*           Test lower triangular storage
*
            DO 420 J = 1, NSZ
               DO 410 I = 1, NSZB
                  AB( I, J ) = CZERO
  410          CONTINUE
  420       CONTINUE
            DO 430 J = 1, N
               AB( 1, J ) = POW( 2*J+1 )
  430       CONTINUE
*
            CALL CPBEQU( 'L', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
*
            IF( INFO.NE.0 ) THEN
               RESLTS( 5 ) = ONE
            ELSE
               IF( N.NE.0 ) THEN
                  RESLTS( 5 ) = MAX( RESLTS( 5 ),
     $                          ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
                  RESLTS( 5 ) = MAX( RESLTS( 5 ),
     $                          ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
     $                          1 ) ) )
                  DO 440 I = 1, N
                     RESLTS( 5 ) = MAX( RESLTS( 5 ),
     $                             ABS( ( R( I )-RPOW( I+1 ) ) /
     $                             RPOW( I+1 ) ) )
  440             CONTINUE
               END IF
            END IF
            IF( N.NE.0 ) THEN
               AB( 1, MAX( N-1, 1 ) ) = -CONE
               CALL CPBEQU( 'L', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
               IF( INFO.NE.MAX( N-1, 1 ) )
     $            RESLTS( 5 ) = ONE
            END IF
  450    CONTINUE
  460 CONTINUE
      RESLTS( 5 ) = RESLTS( 5 ) / EPS
      OK = ( RESLTS( 1 ).LE.THRESH ) .AND.
     $     ( RESLTS( 2 ).LE.THRESH ) .AND.
     $     ( RESLTS( 3 ).LE.THRESH ) .AND.
     $     ( RESLTS( 4 ).LE.THRESH ) .AND. ( RESLTS( 5 ).LE.THRESH )
      WRITE( NOUT, FMT = * )
      IF( OK ) THEN
         WRITE( NOUT, FMT = 9999 )PATH
      ELSE
         IF( RESLTS( 1 ).GT.THRESH )
     $      WRITE( NOUT, FMT = 9998 )RESLTS( 1 ), THRESH
         IF( RESLTS( 2 ).GT.THRESH )
     $      WRITE( NOUT, FMT = 9997 )RESLTS( 2 ), THRESH
         IF( RESLTS( 3 ).GT.THRESH )
     $      WRITE( NOUT, FMT = 9996 )RESLTS( 3 ), THRESH
         IF( RESLTS( 4 ).GT.THRESH )
     $      WRITE( NOUT, FMT = 9995 )RESLTS( 4 ), THRESH
         IF( RESLTS( 5 ).GT.THRESH )
     $      WRITE( NOUT, FMT = 9994 )RESLTS( 5 ), THRESH
      END IF
 9999 FORMAT( 1X, 'All tests for ', A3,
     $      ' routines passed the threshold' )
 9998 FORMAT( ' CGEEQU failed test with value ', E10.3, ' exceeding',
     $      ' threshold ', E10.3 )
 9997 FORMAT( ' CGBEQU failed test with value ', E10.3, ' exceeding',
     $      ' threshold ', E10.3 )
 9996 FORMAT( ' CPOEQU failed test with value ', E10.3, ' exceeding',
     $      ' threshold ', E10.3 )
 9995 FORMAT( ' CPPEQU failed test with value ', E10.3, ' exceeding',
     $      ' threshold ', E10.3 )
 9994 FORMAT( ' CPBEQU failed test with value ', E10.3, ' exceeding',
     $      ' threshold ', E10.3 )
      RETURN
*
*     End of CCHKEQ
*
      END