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