home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 September / Simtel20_Sept92.cdr / msdos / fortran / linpkdrv.arc / SP.FOR < prev    next >
Text File  |  1984-01-07  |  17KB  |  613 lines
  1. C     MAIN PROGRAM
  2.       INTEGER LUNIT
  3. C     ALLOW 5000 UNDERFLOWS.
  4. C     CALL TRAPS(0,0,5001,0,0)
  5. C
  6. C     OUTPUT UNIT NUMBER
  7. C
  8.       LUNIT = 6
  9. C
  10.       CALL SPOTS(LUNIT)
  11.       STOP
  12.       END
  13.       SUBROUTINE SPOTS(LUNIT)
  14. C     LUNIT IS THE OUTPUT UNIT NUMBER
  15. C
  16. C     TESTS
  17. C        SPOCO,SPOFA,SPOSL,SPODI,SPPCO,SPPFA,SPPSL,SPPDI
  18. C        SPBCO,SPBFA,SPBSL,SPBDI
  19. C
  20. C     LINPACK.  THIS VERSION DATED 08/14/78 .
  21. C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
  22. C
  23. C     SUBROUTINES AND FUNCTIONS
  24. C
  25. C     LINPACK SPOCO,SPOSL,SPODI,SPPCO,SPPSL,SPPDI
  26. C     LINPACK SPBCO,SPBSL,SPBDI
  27. C     EXTERNAL SPOXX,SMACH
  28. C     BLAS SAXPY,SDOT,SASUM
  29. C     FORTRAN ABS,AMAX1,FLOAT,MAX0
  30. C
  31. C     INTERNAL VARIABLES
  32. C
  33.       REAL A(15,15),AB(15,15),AINV(15,15),ASAVE(15,15)
  34.       REAL AP(120),B(15),SDOT,X(15),XB(15),XEXACT(15)
  35.       REAL XP(15),T,Z(15)
  36.       REAL ANORM,AINORM,COND,COND1,DET(2),DETB(2),DETP(2)
  37.       REAL EN,ENORM,EPS,FNORM,ONEPX,Q(6),QS(6),RCOND,RCONDB
  38.       REAL RCONDP,RNORM,S,SASUM,SMACH,XNORM
  39.       INTEGER I,INFO,INFOB,INFOP,IQ(6),I1,J,JB
  40.       INTEGER K,KASE,KB,KBFAIL,KNPD,KOUNT,KPFAIL
  41.       INTEGER KSUSP(6),LDA,LUNIT,M,N,NPRINT
  42.       LOGICAL KBF,KPF
  43. C
  44.       LDA = 15
  45. C
  46. C     WRITE MATRIX AND SOLUTIONS IF  N .LE. NPRINT
  47. C
  48.       NPRINT = 3
  49. C
  50.       WRITE (LUNIT,560)
  51.       WRITE (LUNIT,1000)
  52. C
  53.       DO 10 I = 1, 6
  54.          KSUSP(I) = 0
  55.    10 CONTINUE
  56.       KNPD = 0
  57.       KPFAIL = 0
  58.       KBFAIL = 0
  59. C
  60. C     SET EPS TO ROUNDING UNIT FOR REAL ARITHMETIC
  61. C
  62.       EPS = SMACH(1)
  63.       WRITE (LUNIT,570) EPS
  64.       WRITE (LUNIT,550)
  65. C
  66. C     START MAIN LOOP
  67. C
  68.       KASE = 1
  69.    20 CONTINUE
  70. C
  71. C        GENERATE TEST MATRIX
  72. C
  73.          CALL SPOXX(A,LDA,N,KASE,LUNIT)
  74. C
  75. C        N = 0 SIGNALS NO MORE TEST MATRICES
  76. C
  77. C     ...EXIT
  78.          IF (N .LE. 0) GO TO 540
  79.          ANORM = 0.0E0
  80.          DO 30 J = 1, N
  81.             ANORM = AMAX1(ANORM,SASUM(N,A(1,J),1))
  82.    30    CONTINUE
  83.          WRITE (LUNIT,720) ANORM
  84. C
  85.          IF (N .GT. NPRINT) GO TO 50
  86.             WRITE (LUNIT,550)
  87.             DO 40 I = 1, N
  88.                WRITE (LUNIT,760) (A(I,J), J = 1, N)
  89.    40       CONTINUE
  90.             WRITE (LUNIT,550)
  91.    50    CONTINUE
  92. C
  93. C        GENERATE EXACT SOLUTION
  94. C
  95.          XEXACT(1) = 1.0E0
  96.          IF (N .GE. 2) XEXACT(2) = 0.0E0
  97.          IF (N .LE. 2) GO TO 70
  98.             DO 60 I = 3, N
  99.                XEXACT(I) = -XEXACT(I-2)
  100.    60       CONTINUE
  101.    70    CONTINUE
  102. C
  103. C        SAVE MATRIX AND GENERATE R.H.S.
  104. C
  105.          DO 90 I = 1, N
  106.             B(I) = 0.0E0
  107.             DO 80 J = 1, N
  108.                ASAVE(I,J) = A(I,J)
  109.                B(I) = B(I) + A(I,J)*XEXACT(J)
  110.    80       CONTINUE
  111.             X(I) = B(I)
  112.             XP(I) = X(I)
  113.             XB(I) = X(I)
  114.    90    CONTINUE
  115. C
  116. C        FACTOR AND ESTIMATE CONDITION
  117. C
  118.          RCOND = -1.0E0
  119.          CALL SPOCO(A,LDA,N,RCOND,Z,INFO)
  120. C
  121. C        OUTPUT NULL VECTOR
  122. C
  123.          IF (N .GT. NPRINT .OR. INFO .NE. 0) GO TO 110
  124.             WRITE (LUNIT,770)
  125.             DO 100 I = 1, N
  126.                WRITE (LUNIT,780) Z(I)
  127.   100       CONTINUE
  128.             WRITE (LUNIT,550)
  129.   110    CONTINUE
  130. C
  131. C        FACTOR PACKED FORM AND COMPARE
  132. C
  133.          KPF = .FALSE.
  134.          K = 0
  135.          DO 130 J = 1, N
  136.             DO 120 I = 1, J
  137.                K = K + 1
  138.                AP(K) = ASAVE(I,J)
  139.   120       CONTINUE
  140.   130    CONTINUE
  141.          RCONDP = -1.0E0
  142.          CALL SPPCO(AP,N,RCONDP,Z,INFOP)
  143.          IF (INFOP .EQ. INFO) GO TO 140
  144.             WRITE (LUNIT,880)
  145.             WRITE (LUNIT,920) INFO,INFOP
  146.             KPF = .TRUE.
  147.   140    CONTINUE
  148.          IF (RCONDP .EQ. RCOND) GO TO 150
  149.             WRITE (LUNIT,880)
  150.             WRITE (LUNIT,930) RCOND,RCONDP
  151.             KPF = .TRUE.
  152.   150    CONTINUE
  153.          K = 0
  154.          KOUNT = 0
  155.          DO 170 J = 1, N
  156.             DO 160 I = 1, J
  157.                K = K + 1
  158.                IF (AP(K) .NE. A(I,J)) KOUNT = KOUNT + 1
  159.   160       CONTINUE
  160.   170    CONTINUE
  161.          IF (KOUNT .EQ. 0) GO TO 180
  162.             WRITE (LUNIT,880)
  163.             WRITE (LUNIT,940) KOUNT
  164.             KPF = .TRUE.
  165.   180    CONTINUE
  166. C
  167. C        FACTOR BAND FORM AND COMPARE
  168. C
  169.          KBF = .FALSE.
  170.          M = 0
  171.          DO 200 J = 1, N
  172.             DO 190 I = 1, J
  173.                IF (ASAVE(I,J) .NE. 0.0E0) M = MAX0(M,J-I)
  174.   190       CONTINUE
  175.   200    CONTINUE
  176. C
  177.          DO 220 J = 1, N
  178.             I1 = MAX0(1,J-M)
  179.             DO 210 I = I1, J
  180.                K = I - J + M + 1
  181.                AB(K,J) = ASAVE(I,J)
  182.   210       CONTINUE
  183.   220    CONTINUE
  184.          WRITE (LUNIT,840) M
  185.          RCONDB = -1.0E0
  186.          CALL SPBCO(AB,LDA,N,M,RCONDB,Z,INFOB)
  187.          IF (INFOB .EQ. INFO) GO TO 230
  188.             WRITE (LUNIT,830)
  189.             WRITE (LUNIT,920) INFO,INFOB
  190.             KBF = .TRUE.
  191.   230    CONTINUE
  192.          IF (RCONDB .EQ. RCOND) GO TO 240
  193.             WRITE (LUNIT,830)
  194.             WRITE (LUNIT,930) RCOND,RCONDB
  195.             KBF = .TRUE.
  196.   240    CONTINUE
  197.          KOUNT = 0
  198.          DO 250 J = 1, N
  199.             IF (AB(M+1,J) .NE. A(J,J)) KOUNT = KOUNT + 1
  200.   250    CONTINUE
  201.          IF (KOUNT .EQ. 0) GO TO 260
  202.             WRITE (LUNIT,830)
  203.             WRITE (LUNIT,940) KOUNT
  204.             KBF = .TRUE.
  205.   260    CONTINUE
  206. C
  207. C        TEST FOR DEFINITENESS
  208. C
  209.          IF (INFO .EQ. 0) GO TO 270
  210.             WRITE (LUNIT,860) INFO
  211.             KNPD = KNPD + 1
  212.          GO TO 530
  213.   270    CONTINUE
  214.             COND = 1.0E0/RCOND
  215.             WRITE (LUNIT,590) COND
  216.             ONEPX = 1.0E0 + RCOND
  217.             IF (ONEPX .EQ. 1.0E0) WRITE (LUNIT,580)
  218. C
  219. C           COMPUTE INVERSE, DETERMINANT AND COND1 = TRUE CONDITION
  220. C
  221.             DO 290 J = 1, N
  222.                DO 280 I = 1, J
  223.                   AINV(I,J) = A(I,J)
  224.   280          CONTINUE
  225.   290       CONTINUE
  226.             CALL SPODI(AINV,LDA,N,DET,11)
  227.             AINORM = 0.0E0
  228.             DO 310 J = 1, N
  229.                DO 300 I = J, N
  230.                   AINV(I,J) = AINV(J,I)
  231.   300          CONTINUE
  232.                AINORM = AMAX1(AINORM,SASUM(N,AINV(1,J),1))
  233.   310       CONTINUE
  234.             COND1 = ANORM*AINORM
  235.             WRITE (LUNIT,600) COND1
  236.             WRITE (LUNIT,800) DET(1)
  237.             WRITE (LUNIT,810) DET(2)
  238. C
  239. C           SOLVE A*X = B
  240. C
  241.             CALL SPOSL(A,LDA,N,X)
  242. C
  243.             IF (N .GT. NPRINT) GO TO 330
  244.                WRITE (LUNIT,610)
  245.                DO 320 I = 1, N
  246.                   WRITE (LUNIT,790) X(I)
  247.   320          CONTINUE
  248.                WRITE (LUNIT,550)
  249.   330       CONTINUE
  250. C
  251. C           MORE PACKED COMPARE
  252. C
  253.             CALL SPPSL(AP,N,XP)
  254.             KOUNT = 0
  255.             DO 340 I = 1, N
  256.                IF (XP(I) .NE. X(I)) KOUNT = KOUNT + 1
  257.   340       CONTINUE
  258.             IF (KOUNT .EQ. 0) GO TO 350
  259.                WRITE (LUNIT,880)
  260.                WRITE (LUNIT,950) KOUNT
  261.                KPF = .TRUE.
  262.   350       CONTINUE
  263.             CALL SPPDI(AP,N,DETP,11)
  264.             IF (DETP(1) .EQ. DET(1) .AND. DETP(2) .EQ. DET(2))
  265.      *         GO TO 360
  266.                WRITE (LUNIT,880)
  267.                WRITE (LUNIT,960) DETP
  268.                KPF = .TRUE.
  269.   360       CONTINUE
  270.             KOUNT = 0
  271.             K = 0
  272.             DO 380 J = 1, N
  273.                DO 370 I = 1, J
  274.                   K = K + 1
  275.                   IF (AP(K) .NE. AINV(I,J)) KOUNT = KOUNT + 1
  276.   370          CONTINUE
  277.   380       CONTINUE
  278.             IF (KOUNT .EQ. 0) GO TO 390
  279.                WRITE (LUNIT,880)
  280.                WRITE (LUNIT,970) KOUNT
  281.                KPF = .TRUE.
  282.   390       CONTINUE
  283. C
  284. C           MORE BAND COMPARE
  285. C
  286.             CALL SPBSL(AB,LDA,N,M,XB)
  287.             KOUNT = 0
  288.             DO 400 I = 1, N
  289.                IF (XB(I) .NE. X(I)) KOUNT = KOUNT + 1
  290.   400       CONTINUE
  291.             IF (KOUNT .EQ. 0) GO TO 410
  292.                WRITE (LUNIT,830)
  293.                WRITE (LUNIT,950) KOUNT
  294.                KBF = .TRUE.
  295.   410       CONTINUE
  296.             CALL SPBDI(AB,LDA,N,M,DETB)
  297.             IF (DETB(1) .EQ. DET(1) .AND. DETB(2) .EQ. DET(2))
  298.      *         GO TO 420
  299.                WRITE (LUNIT,830)
  300.                WRITE (LUNIT,960) DETB
  301.                KBF = .TRUE.
  302.   420       CONTINUE
  303. C
  304. C           RECONSTRUCT  A  FROM TRIANGULAR FACTORS , TRANS(R) AND R
  305. C
  306.             DO 440 JB = 1, N
  307.                J = N + 1 - JB
  308.                DO 430 KB = 1, J
  309.                   K = J + 1 - KB
  310.                   A(K,J) = SDOT(K,A(1,K),1,A(1,J),1)
  311.   430          CONTINUE
  312.   440       CONTINUE
  313. C
  314. C           COMPUTE ERRORS AND RESIDUALS
  315. C              E  =  X - XEXACT
  316. C              R  =  B - A*X
  317. C              F  =  A - TRANS(R)*R
  318. C
  319.             XNORM = SASUM(N,X,1)
  320.             ENORM = 0.0E0
  321.             FNORM = 0.0E0
  322.             DO 460 J = 1, N
  323.                ENORM = ENORM + ABS(X(J)-XEXACT(J))
  324.                T = -X(J)
  325.                CALL SAXPY(N,T,ASAVE(1,J),1,B,1)
  326.                S = 0.0E0
  327.                DO 450 I = 1, J
  328.                   S = S + ABS(ASAVE(I,J)-A(I,J))
  329.   450          CONTINUE
  330.                IF (S .GT. FNORM) FNORM = S
  331.   460       CONTINUE
  332.             RNORM = SASUM(N,B,1)
  333. C
  334. C           A*INV(A) - I
  335. C
  336.             AINORM = 0.0E0
  337.             DO 490 J = 1, N
  338.                DO 470 I = 1, N
  339.                   B(I) = 0.0E0
  340.   470          CONTINUE
  341.                DO 480 K = 1, N
  342.                   T = AINV(K,J)
  343.                   CALL SAXPY(N,T,ASAVE(1,K),1,B,1)
  344.   480          CONTINUE
  345.                B(J) = B(J) - 1.0E0
  346.                AINORM = AMAX1(AINORM,SASUM(N,B,1))
  347.   490       CONTINUE
  348. C
  349.             WRITE (LUNIT,620) ENORM
  350.             WRITE (LUNIT,630) RNORM
  351.             WRITE (LUNIT,730) FNORM
  352.             WRITE (LUNIT,740) AINORM
  353. C
  354. C           COMPUTE TEST RATIOS
  355. C
  356.             Q(1) = COND/COND1
  357.             Q(2) = COND1/COND
  358.             Q(3) = ENORM/(EPS*COND*XNORM)
  359.             Q(4) = RNORM/(EPS*ANORM*XNORM)
  360.             Q(5) = FNORM/(EPS*ANORM)
  361.             Q(6) = AINORM/(EPS*COND)
  362.             WRITE (LUNIT,550)
  363.             WRITE (LUNIT,640)
  364.             WRITE (LUNIT,550)
  365.             WRITE (LUNIT,690)
  366.             WRITE (LUNIT,700)
  367.             WRITE (LUNIT,710)
  368.             WRITE (LUNIT,550)
  369.             WRITE (LUNIT,750) (Q(I), I = 1, 6)
  370.             WRITE (LUNIT,550)
  371. C
  372. C           LOOK FOR SUSPICIOUS RATIOS
  373. C
  374.             QS(1) = 1.0E0 + 4.0E0*EPS
  375.             QS(2) = 10.0E0
  376.             EN = FLOAT(N)
  377.             IF (N .EQ. 1) EN = 2.0E0
  378.             DO 500 I = 3, 6
  379.                QS(I) = EN
  380.   500       CONTINUE
  381.             KOUNT = 0
  382.             DO 520 I = 1, 6
  383.                IQ(I) = 0
  384.                IF (Q(I) .LE. QS(I)) GO TO 510
  385.                   IQ(I) = 1
  386.                   KSUSP(I) = KSUSP(I) + 1
  387.                   KOUNT = KOUNT + 1
  388.   510          CONTINUE
  389.   520       CONTINUE
  390.             IF (KOUNT .EQ. 0) WRITE (LUNIT,980)
  391.             IF (KOUNT .NE. 0) WRITE (LUNIT,990) (IQ(I), I = 1, 6)
  392.             WRITE (LUNIT,550)
  393.   530    CONTINUE
  394. C
  395.          IF (.NOT.KPF) WRITE (LUNIT,870)
  396.          IF (KPF) KPFAIL = KPFAIL + 1
  397.          IF (.NOT.KBF) WRITE (LUNIT,820)
  398.          IF (KBF) KBFAIL = KBFAIL + 1
  399.          WRITE (LUNIT,650)
  400.          KASE = KASE + 1
  401.       GO TO 20
  402.   540 CONTINUE
  403. C
  404. C     FINISH MAIN LOOP
  405. C
  406. C     SUMMARY
  407. C
  408.       WRITE (LUNIT,660)
  409.       KASE = KASE - 1
  410.       WRITE (LUNIT,670) KASE
  411.       WRITE (LUNIT,900) KNPD
  412.       WRITE (LUNIT,890) KPFAIL
  413.       WRITE (LUNIT,850) KBFAIL
  414.       WRITE (LUNIT,680) KSUSP
  415.       WRITE (LUNIT,910)
  416.       RETURN
  417. C
  418. C     MOST FORMATS, ALSO SOME IN SPOXX
  419. C
  420.   550 FORMAT (1H )
  421.   560 FORMAT (36H1LINPACK TESTER, SPO**, SPP**, SPB**)
  422.   570 FORMAT ( / 14H EPSILON     =, 1PE13.5)
  423.   580 FORMAT ( / 16H MAYBE SINGULAR. /)
  424.   590 FORMAT (14H COND        =, 1PE13.5)
  425.   600 FORMAT (14H ACTUAL COND =, 1PE13.5)
  426.   610 FORMAT ( / 4H X =)
  427.   620 FORMAT (14H ERROR NORM  =, 1P2E13.5)
  428.   630 FORMAT (14H RESID NORM  =, 1P2E13.5)
  429.   640 FORMAT (26H TEST RATIOS.. E = EPSILON)
  430.   650 FORMAT ( / 14H ************* /)
  431.   660 FORMAT (8H1SUMMARY)
  432.   670 FORMAT (18H NUMBER OF TESTS =, I4)
  433.   680 FORMAT ( / 30H NUMBER OF SUSPICIOUS RATIOS =, 6I4)
  434.   690 FORMAT (30H     COND     ACTUAL    ERROR ,
  435.      *        30H    RESID   A - RT*R  A*AI - I)
  436.   700 FORMAT (6(10H   -------))
  437.   710 FORMAT (30H    ACTUAL     COND   E*COND*X,
  438.      *        30H    E*A*X      E*A     E*COND )
  439.   720 FORMAT (14H NORM(A)     =, 1PE13.5)
  440.   730 FORMAT (14H NORM(A-RT*R)=, 1PE13.5)
  441.   740 FORMAT (14H NORM(A*AI-I)=, 1PE13.5)
  442.   750 FORMAT (6(1X, F9.4))
  443.   760 FORMAT (1H , 6G11.4)
  444.   770 FORMAT ( / 7H NULL =)
  445.   780 FORMAT (2G14.6)
  446.   790 FORMAT (2G14.6)
  447.   800 FORMAT (14H DET FRACT   =, F9.5)
  448.   810 FORMAT (14H DET EXPON   =, F9.0)
  449.   820 FORMAT ( / 20H BAND ROUTINES AGREE /)
  450.   830 FORMAT ( / 28H BAND ROUTINES DO NOT AGREE,)
  451.   840 FORMAT (5H M  =, I2)
  452.   850 FORMAT (26H NUMBER OF BAND FAILURES =, I4)
  453.   860 FORMAT (30H NOT POSITIVE DEFINITE, INFO =, I2)
  454.   870 FORMAT ( / 22H PACKED ROUTINES AGREE)
  455.   880 FORMAT ( / 30H PACKED ROUTINES DO NOT AGREE,)
  456.   890 FORMAT (28H NUMBER OF PACKED FAILURES =, I4)
  457.   900 FORMAT (34H NUMBER OF NOT POSITIVE DEFINITE =, I4)
  458.   910 FORMAT ( / 12H END OF TEST)
  459.   920 FORMAT (8H INFO  =, 2I3)
  460.   930 FORMAT (8H RCOND =, 1P2E13.5)
  461.   940 FORMAT (12H KOUNT(FA) =, I4)
  462.   950 FORMAT (12H KOUNT(SL) =, I4)
  463.   960 FORMAT (8H DET   =, F9.5, F9.0)
  464.   970 FORMAT (12H KOUNT(DI) =, I4)
  465.   980 FORMAT (21H NO SUSPICIOUS RATIOS)
  466.   990 FORMAT (I8, 5I10 / 7X, 28H1 INDICATES SUSPICIOUS RATIO)
  467.  1000 FORMAT (29H THIS VERSION DATED 08/14/78.)
  468.       END
  469.       SUBROUTINE SPOXX(A,LDA,N,KASE,LUNIT)
  470.       INTEGER LDA,N,KASE,LUNIT
  471.       REAL A(LDA,1)
  472. C
  473. C     GENERATES REAL POSITIVE DEFINITE TEST MATRICES
  474. C
  475. C     EXTERNAL SMACH
  476. C     FORTRAN ABS,FLOAT,IABS,MAX0,MIN0
  477.       REAL T
  478.       REAL TINY,HUGE,SMACH
  479.       INTEGER I,J
  480. C
  481.       GO TO (10, 10, 10, 50, 50, 70, 70, 70, 120, 160, 200, 240, 290,
  482.      *       340), KASE
  483. C
  484. C     KASE 1, 2 AND 3
  485. C
  486.    10 CONTINUE
  487.          N = 5*KASE
  488.          WRITE (LUNIT,20) KASE,N
  489.    20    FORMAT (5H KASE, I3, 3X, 16HHILBERT          / 4H N =, I4)
  490.          T = 1.0E0
  491.          T = SIGN(1.0E0,T)
  492.          DO 40 J = 1, N
  493.             DO 30 I = 1, N
  494.                A(I,J) = T**(I - J)/FLOAT(I+J-1)
  495. C              FOR REAL MATRICES, A(I,J) = 1.0/FLOAT(I+J-1)
  496.    30       CONTINUE
  497.    40    CONTINUE
  498.       GO TO 350
  499. C
  500. C     KASE 4 AND 5
  501. C
  502.    50 CONTINUE
  503.          N = 1
  504.          WRITE (LUNIT,60) KASE,N
  505.    60    FORMAT (5H KASE, I3, 3X, 16HMONOELEMENTAL    / 4H N =, I4)
  506.          IF (KASE .EQ. 4) A(1,1) = 3.0E0
  507.          IF (KASE .EQ. 5) A(1,1) = 0.0E0
  508.       GO TO 350
  509. C
  510. C     KASE 6, 7 AND 8
  511. C
  512.    70 CONTINUE
  513.          N = 15
  514.          IF (KASE .NE. 8) WRITE (LUNIT,80) KASE,N
  515.    80    FORMAT (5H KASE, I3, 3X, 16HTRIDIAGONAL      / 4H N =, I4)
  516.          IF (KASE .EQ. 8) WRITE (LUNIT,90) KASE,N
  517.    90    FORMAT (5H KASE, I3, 3X, 16HDIAGONAL         / 4H N =, I4)
  518.          T = 1.0E0
  519.          IF (KASE .EQ. 7) T = 2.0E0
  520.          IF (KASE .EQ. 8) T = 0.0E0
  521.          DO 110 J = 1, N
  522.             DO 100 I = 1, J
  523.                A(I,J) = 0.0E0
  524.                IF (I .EQ. J) A(I,I) = 4.0E0
  525.                IF (I .EQ. J - 1) A(I,J) = T
  526.                A(J,I) = A(I,J)
  527.   100       CONTINUE
  528.   110    CONTINUE
  529.       GO TO 350
  530. C
  531. C     KASE 9
  532. C
  533.   120 CONTINUE
  534.          N = 5
  535.          WRITE (LUNIT,130) KASE,N
  536.   130    FORMAT (5H KASE, I3, 3X, 16HPENTADIAGONAL    / 4H N =, I4)
  537.          DO 150 J = 1, N
  538.             DO 140 I = 1, N
  539.                A(I,J) = 0.0E0
  540.                IF (IABS(I-J) .LE. 2)
  541.      *            A(I,J) = (5.0E0 - FLOAT(IABS(I-J)))**(10 - I - J)
  542.   140       CONTINUE
  543.   150    CONTINUE
  544.       GO TO 350
  545. C
  546. C     KASE 10
  547. C
  548.   160 CONTINUE
  549.          N = 6
  550.          WRITE (LUNIT,170) KASE,N
  551.   170    FORMAT (5H KASE, I3, 3X, 16HTRIDIAG INVERSE  / 4H N =, I4)
  552.          DO 190 J = 1, N
  553.             DO 180 I = 1, J
  554.                A(I,J) = FLOAT(N+1-J)
  555.                A(J,I) = A(I,J)
  556.   180       CONTINUE
  557.   190    CONTINUE
  558.       GO TO 350
  559. C
  560. C     KASE 11
  561. C
  562.   200 CONTINUE
  563.          N = 15
  564.          WRITE (LUNIT,210) KASE,N
  565.   210    FORMAT (5H KASE, I3, 3X, 16HTEST COND        / 4H N =, I4)
  566.          DO 230 J = 1, N
  567.             DO 220 I = 1, N
  568.                IF (I .EQ. J) A(I,J) = FLOAT(I)
  569.                IF (I .GT. J) A(I,J) = FLOAT(J-2)
  570.                IF (I .LT. J) A(I,J) = FLOAT(I-2)
  571.   220       CONTINUE
  572.   230    CONTINUE
  573.       GO TO 350
  574. C
  575. C     KASE 12
  576. C
  577.   240 CONTINUE
  578.          N = 5
  579.          WRITE (LUNIT,250) KASE,N
  580.   250    FORMAT (5H KASE, I3, 3X, 16HNEAR UNDERFLOW   / 4H N =, I4)
  581.          TINY = SMACH(2)
  582.          WRITE (LUNIT,260) TINY
  583.   260    FORMAT (14H TINY        =, 1PE13.5)
  584.          DO 280 I = 1, N
  585.             DO 270 J = 1, N
  586.                A(I,J) = TINY*FLOAT(MIN0(I,J))/FLOAT(MAX0(I,J))
  587.   270       CONTINUE
  588.   280    CONTINUE
  589.       GO TO 350
  590. C
  591. C     KASE 13
  592. C
  593.   290 CONTINUE
  594.          N = 5
  595.          WRITE (LUNIT,300) KASE,N
  596.   300    FORMAT (5H KASE, I3, 3X, 16HNEAR OVERFLOW    / 4H N =, I4)
  597.          HUGE = SMACH(3)
  598.          WRITE (LUNIT,310) HUGE
  599.   310    FORMAT (14H HUGE        =, 1PE13.5)
  600.          DO 330 I = 1, N
  601.             DO 320 J = 1, N
  602.                A(I,J) = HUGE*FLOAT(MIN0(I,J))/FLOAT(MAX0(I,J))
  603.   320       CONTINUE
  604.   330    CONTINUE
  605.       GO TO 350
  606. C
  607.   340 CONTINUE
  608.          N = 0
  609.   350 CONTINUE
  610.       RETURN
  611. C
  612.       END
  613.