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