Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-04 - decus/20-0101/remder.for
There is 1 other file named remder.for in the archive. Click here to see a list.
      SUBROUTINE READIN (KTOU,IDENT, Y, X, EQU, BI, NPROB, B, DIFZ,     02RD0010
     1 SIGNS,MODEL, KTINED, KTIN, JOMIT, MNOMIT, NVARX, NOBMAX, NEQUNO, 02RD0020
     2 NBINO, NNPROB, NOB, NOIND, NPLOT, NCMAX)                         02RD0030
C                                                                       02RD0040
      IMPLICIT REAL*8 (A-H,O-Z)                                         02RD0050
      COMMON /DATA02/ STOPSS, STOPCR, FLAM, FNU, MIT, NC, NEQU,         02RD0060
     1                NOMIT, NFOUND                                     02RD0070
C                                                                       02RD0080
C                                                                       02RD0090
      REAL*8 IDENT, AEND, BLANK, JOMIT(MNOMIT)                          02RD0100
      REAL*4 FMT(18)                                                    02RD0110
C                                                                       02RD0120
      DIMENSION IDENT(NOBMAX), Y(NOBMAX), X(NVARX,NOBMAX), EQU(NEQUNO), 02RD0130
     1    BI(NBINO), NPROB(NNPROB), B(NCMAX), DIFZ(NCMAX), SIGNS(NCMAX) 02RD0140
C                                                                       02RD0150
      DATA AEND /8HEND     /, BLANK /6H      /                          02RD0160
C --                                                                    02RD0170
    1 N      = 0                                                        02RD0180
      MNOMTC = MNOMIT/7                                                 02RD0190
      MXNEQU = NEQUNO/18                                                02RD0200
C ---                                                                   02RD0210
      READ(KTIN,100,END=1000) NPROB, JSAME, NC, NFILE, NOIND, MODEL,    02RD0220
     1 FLAM, FNU, MIT, DIFF, STOPSS, STOPCR, NEQU, NAMEBI, NPLOT,NOMITC 02RD0230
  100 FORMAT( 5A4,I1  ,1X,3I2,2X,I2,F4.2,F4.0,1X,I3,F4.3,2F8.7,2I2,2I1) 02RD0240
C ---                                                                   02RD0250
      WRITE(KTOU, 101) NVARX, NCMAX,  NOBMAX, NPROB                     02RD0260
  101 FORMAT(1H1,42X,45HNONLINEAR LEAST-SQUARES CURVE-FITTING PROGRAM// 02RD0270
     1 31H 1979 VERSION OF THE NONLINWOOD,I3,10H VARIABLE,,I3,          02RD0280
     2 13H COEFFICIENT,,I4,20H OBSERVATION PROGRAM//                    02RD0290
     3 55H REFER TO FITTING EQUATIONS TO DATA BY DANIEL AND WOOD,,      02RD0300
     4 33H SECOND EDITION, WILEY PUBLISHER,/                            02RD0310
     5 49H FOR GLOSSARY OF TERMS, USER'S MANUAL, DETAILS OF,            02RD0320
     6 44H CALCULATIONS AND INTERPRETATION OF RESULTS.// 1H0,5A4/)      02RD0330
C -                                                                     02RD0340
C --- CONTROL CARD AND ORDER OF CARD INFORMATION IN 600 FORMATS.        02RD0350
C -                                                                     02RD0360
      WRITE(KTOU, 600 )                                                 02RD0370
  600 FORMAT(1H0,25X, 24HCONTROL CARD INFORMATION,                      02RD0380
     1 39X,14HORDER OF CARDS                                         ,  02RD0390
     1//1X, 49HCOL.  INPUT  MAX ITEM   (NOTE: BLANK ON CARD = 0),20X ,  02RD0400
     2 13HFIRST PROBLEM                                        / 2X  ,  02RD0410
     3  4H1-20,12X,26HIDENTIFICATION OF PROBLEM.               ,26X  ,  02RD0420
     3 16H1  CONTROL CARD.                                           )  02RD0430
      WRITE(KTOU, 602) JSAME                                            02RD0440
  602 FORMAT(1H ,3X,2H21,I3,9X,                                         02RD0450
     1 40H0  OBSERVATIONS READ FROM CARDS OR FILE.             ,12X  ,  02RD0460
     1 53H2  FORMAT CARD (72 COLUMNS, ORDER: IDENT, Y, X(I)'S),/18X  ,  02RD0470
     2 36H1  REUSE DATA FROM PREVIOUS PROBLEM.                 ,20X  ,  02RD0480
     2 31HE.G. (A6, F6.0, (NOIND*F6.0) ).                            )  02RD0490
      WRITE(KTOU, 604) NC, NCMAX                                        02RD0500
  604 FORMAT(1H ,5H23-24,I3,5X,I3,1X,                                   02RD0510
     1 39HNUMBER OF COEFFICIENTS TO BE ESTIMATED.              ,13X  ,  02RD0520
     1 39H3  DELETE-OBSERVATIONS CARD(S), IF ANY.                    )  02RD0530
      WRITE(KTOU, 606) NFILE                                            02RD0540
  606 FORMAT(1H ,5H25-26,I3,9X,                                         02RD0550
     1 41HFILE NUMBER IF DATA ARE TO BE READ FROM A            ,11X  ,  02RD0560
     1 45H4  STARTING VALUES (GUESSES) OF COEFFICIENTS         /19X  ,  02RD0570
     2 42HSEPARATE FILE.  NO END CARD(S) IF ONLY ONE           ,13X  ,  02RD0580
     2 50H(10 COLUMNS / COEFFICIENT, 7 COEFFICIENTS / CARD).   /19X  ,  02RD0590
     3 28HSET OF DATA IS ON EACH FILE.                         ,23X  ,  02RD0600
     3 42H5  INFORMATION CARDS FOR PRINTOUT, IF ANY.                 )  02RD0610
      WRITE(KTOU, 608) NOIND, NVARX                                     02RD0620
  608 FORMAT(1H ,5H27-28,I3,5X,I3,1X,                                   02RD0630
     1 46HNUMBER OF INDEPENDENT VARIABLES TO BE READ IN.       , 6X  ,  02RD0640
     1 54H6  NAMES OF COEFFICIENTS CARD(S) FOR PRINTOUT, IF ANY.     )  02RD0650
      WRITE(KTOU, 610) MODEL                                            02RD0660
  610 FORMAT(1H ,5H31-32,I3,9X,                                         02RD0670
     1 30HNUMBER OF EQUATION TO BE USED.                       ,22X  ,  02RD0680
     1 40H7  DATA CARDS (IF NOT READ FROM A FILE).             /70X  ,  02RD0690
     2 51H8  END CARD (END IN COLUMNS 1 - 3 OF IDENTIFICATION        )  02RD0700
      WRITE(KTOU, 612) FLAM                                             02RD0710
  612 FORMAT(1H ,5H33-36,F7.3,5X,                                       02RD0720
     1 44HSTARTING VALUE FOR LAMBDA, F4.2, (E.G. 0.1),         ,12X  ,  02RD0730
     1 47HFIELD).  THE NUMBER OF END CARDS MUST EQUAL THE      /19X  ,  02RD0740
     2 42HUSED AS A MULTIPLIER TO SCALE THE SPACE OR            13X  ,  02RD0750
     2 44HNUMBER OF CARDS PER OBSERVATION.  (END CARDS         /19X  ,  02RD0760
     3 20HSIZE OF STEPS TAKEN.                                 ,35X  ,  02RD0770
     3 45HARE NOT NEEDED IF DATA ARE READ FROM A FILE).              )  02RD0780
      WRITE(KTOU, 614) FNU                                              02RD0790
  614 FORMAT(1H ,5H37-40,F7.3,5X,                                       02RD0800
     1 30HVALUE OF NU, F4.0, (E.G. 10.).                       /19X  ,  02RD0810
     2 40HDIVISOR AND MULTIPLIER TO CHANGE SIZE OF              11X  ,  02RD0820
     2 14HSECOND PROBLEM                                       /19X  ,  02RD0830
     3 45HLAMBDA DEPENDING ON WHETHER SUM OF SQUARES OF        , 9X  ,  02RD0840
     3 38HIF DATA ARE REUSED FROM FIRST PROBLEM,               /19X  ,  02RD0850
     4 38HITERATION IS NEAR OR FAR FROM MINIMUM.               ,19X  ,  02RD0860
     4 38HDELETE THE FORMAT, DATA AND END CARDS.                     )  02RD0870
      WRITE(KTOU, 616) MIT                                              02RD0880
  616 FORMAT(1H ,5H43-44,I3,9X,                                         02RD0890
     1 44HMAXIMUM NUMBER OF ITERATIONS, I2, (E.G. 20).         ,11X  ,  02RD0900
     1 18HIF DIFFERENT DATA,                                         )  02RD0910
      WRITE(KTOU, 618) DIFF                                             02RD0920
  618 FORMAT(1H ,5H45-48,F7.3,5X,                                       02RD0930
     1 37HMULTIPLIER USED TO INCREMENT VALUE OF                ,21X  ,  02RD0940
     1 19HREPEAT 1 - 8 ABOVE.                                  /19X  ,  02RD0950
     2 31HCOEFFICIENTS, F4.3 (E.G. 0.01).                     //18X  ,  02RD0960
     3 48HNOTE: IF VALUES IN COLUMNS 33-48 ARE NOT DEFINED     /24X  ,  02RD0970
     4 41HON THE CONTROL CARD.  THEIR LEVEL WILL BE            /24X  ,  02RD0980
     5 43HSET AUTOMATICALLY TO THE ABOVE E.G. VALUES.         //18X  ,  02RD0990
     6 42HCRITERIA FOR ENDING CONVERGING ITERATIONS.                 )  02RD1000
      WRITE(KTOU, 620) STOPSS                                           02RD1010
  620 FORMAT(1H ,5H49-56,1PE9.1,3X                                      02RD1020
     1 31HSUM OF SQUARES CRITERION, F8.7,                      /19X  ,  02RD1030
     2 45H(E.G. 0.0001, A CHANGE OF LESS THAN 0.0001 IN        /19X  ,  02RD1040
     3 29HTHE RESIDUAL SUM OF SQUARES).                              )  02RD1050
      WRITE(KTOU, 622) STOPCR                                           02RD1060
  622 FORMAT(1H ,5H57-64,1PE9.1,3X,                                     02RD1070
     1 38HRATIO OF COEFFICIENTS CRITERION, F8.7,               /19X  ,  02RD1080
     2 43H(E.G. 0.001, A CHANGE OF LESS THAN 0.001 IN          /19X  ,  02RD1090
     3 43HTHE RATIOS OF ALL COMPARABLE COEFFICIENTS).         //18X  ,  02RD1100
     4 47HNOTE: VALUES IN COLUMNS 49-64 CAN BE SET AT 0.0      /24X  ,  02RD1110
     5 44HIF CONTROL OF EITHER OR BOTH IS NOT DESIRED.         /     )  02RD1120
      WRITE(KTOU, 624) NEQU, MXNEQU                                     02RD1130
  624 FORMAT(1H ,5H65-66,I3,5X,I3,1X,                                   02RD1140
     1 50HNUMBER OF INFORMATION CARDS TO BE READ FOR DISPLAY   /19X  ,  02RD1150
     2 40HON PRINTOUT IF DESIRED, 72 COLUMNS EACH.                   )  02RD1160
      WRITE(KTOU, 626) NAMEBI                                           02RD1170
  626 FORMAT(1H ,3X,2H68,I3,9X                                          02RD1180
     1 44H1  READ NAMES OF COEFFICIENTS FROM CARDS FOR         /21X  ,  02RD1190
     2 42HDISPLAY ON PRINTOUT, 1ST 6 OF 10 COLUMNS /           /21X  ,  02RD1200
     3 23HCOEFFICIENT,  7 / CARD.                                    )  02RD1210
      WRITE(KTOU, 628) NPLOT                                            02RD1220
  628 FORMAT(1H ,3X,2H69,I3,9X                                          02RD1230
     1 48H3  PLOT RESIDUALS VS. EACH INDEPENDENT VARIABLE.           )  02RD1240
      WRITE(KTOU, 630) NOMITC, MNOMTC                                   02RD1250
  630 FORMAT(1H ,3X,2H70,I3,5X,I3,1X,                                   02RD1260
     1 48HNUMBER OF DELETE-OBSERVATIONS CARDS, OBSERVATION     /19X  ,  02RD1270
     2 48HIDENTIFICATION IN 1ST 6 OF 10 COLUMNS, 7 / CARD.           )  02RD1280
C -                                                                     02RD1290
      WRITE(KTOU, 500) MODEL                                            02RD1300
  500 FORMAT(1H0,16X,35HSUBROUTINE ARGUMENTS AND DIMENSIONS/1H ,        02RD1310
     1 16HSUBROUTINE MODEL,I1,35H (NPROB, B, FY, NOB, NC, X, NVARX, ,   02RD1320
     2 20HNOBMAX, NCMAX, KTOU)/1X,33HDIMENSION  B(NCMAX), FY(NOBMAX), , 02RD1330
     3 15HX(NVARX,NOBMAX)//)                                            02RD1340
C ---                                                                   02RD1350
C ---      SET VALUES OF FLAM, FNU, MIT AND DIFF IF NOT GIVEN.          02RD1360
C ---                                                                   02RD1370
      IF(FLAM.EQ.0.) FLAM =  0.1                                        02RD1380
      IF(FNU .EQ.0.) FNU  = 10.                                         02RD1390
      IF(MIT .EQ.0 ) MIT  = 20                                          02RD1400
      IF(DIFF.EQ.0.) DIFF  =  0.01                                      02RD1410
C --- TRAP IF NUMBER OF COEFFICIENTS ARE GREATER THAN DIMENSIONS        02RD1420
      IF(NCMAX.LT.NC) GO TO 3                                           02RD1430
      DO 2  I = 1, NC                                                   02RD1440
C ---           SIGNS(I) SIGN OF COEFFICENTS ARE POSITIVE.              02RD1450
      SIGNS(I) = 1.0                                                    02RD1460
C ---            DIFZ(I) VECTOR OF DIFFERENCES IN TH                    02RD1470
    2 DIFZ(I)  =  DIFF                                                  02RD1480
    3 IF(JSAME.EQ.1) GO TO 470                                          02RD1490
C --                                                                    02RD1500
C ---      READ DATA FORMAT CARD                                        02RD1510
C ---    COL. 1-72 E.G. (A6, F6.0, (NOIND*F6.0)                         02RD1520
C --                                                                    02RD1530
      READ(KTIN,114) FMT                                                02RD1540
  114 FORMAT(18A4)                                                      02RD1550
      IF (NFILE .EQ. 0) NFILE = KTIN                                    02RD1560
C                                                                       02RD1570
C --                                                                    02RD1580
C --- READ DELETE OBSERVATION CARDS.                                    02RD1590
C --                                                                    02RD1600
      NOMIT = 0                                                         02RD1610
      IF(NOMITC.EQ.0) GO TO 468                                         02RD1620
      JC = MNOMTC                                                       02RD1630
      IF(NOMITC.LE.JC) JC = NOMITC                                      02RD1640
      DO 460 J = 1, JC                                                  02RD1650
      NOMIT = NOMIT + 7                                                 02RD1660
      J1    = NOMIT - 6                                                 02RD1670
  460 READ(KTIN,461) (JOMIT(I),I=J1,NOMIT)                              02RD1680
  461 FORMAT( 7(A6,4X) )                                                02RD1690
  462 IF(JOMIT(NOMIT).NE.BLANK) GO TO 464                               02RD1700
      NOMIT = NOMIT - 1                                                 02RD1710
      IF(NOMIT.NE.0) GO TO 462                                          02RD1720
      WRITE(KTOU, 463) NOMITC                                           02RD1730
  463 FORMAT(1H0//1X,6H******,I2, 32H DELETE CARD(S) WITH (7(A6,4X)) ,  02RD1740
     1 55HFORMAT REQUESTED, NO OBSERVATION IDENTIFICATION FOUND. ,      02RD1750
     2 6H******//)                                                      02RD1760
  464 IF(NOMITC.LE.MNOMTC) GO TO 468                                    02RD1770
      JC = JC + 1                                                       02RD1780
      DO 466 J = JC, NOMITC                                             02RD1790
  466 READ(KTIN,467) J2                                                 02RD1800
  467 FORMAT(A6)                                                        02RD1810
  468 NFOUND = 0                                                        02RD1820
      GO TO 4                                                           02RD1830
  470 IF(NOMITC.EQ.0) GO TO 4                                           02RD1840
      DO 471 J=1, NOMITC                                                02RD1850
  471 READ(KTIN,467) J2                                                 02RD1860
      WRITE(KTOU, 472   )                                               02RD1870
  472 FORMAT(1H0//1X,6H******,35HDATA SAME AS PREVIOUS PROBLEM, NEW ,   02RD1880
     1 31HDELETE CARDS READ BUT NOT USED.,6H******//)                   02RD1890
C --                                                                    02RD1900
C --- STARTING VALUES (GUESSES) OF COEFFICENTS, 7/ CARD.                02RD1910
C ---    COL.01-72  B(I),I=1 TO NC,   NC*F10.0 .                        02RD1920
C --                                                                    02RD1930
C --- TRAP IF NUMBER OF COEFFICIENTS ARE GREATER THAN DIMENSIONS        02RD1940
    4 IF(NC.LE.NCMAX) GO TO 6                                           02RD1950
      READ(KTIN,112) (DUM, I=1,NC)                                      02RD1960
      GO TO 7                                                           02RD1970
    6 J2 = 0                                                            02RD1980
    5 J2 = J2 + 7                                                       02RD1990
      J1 = J2 - 6                                                       02RD2000
      IF(J2.GT.NC) J2 = NC                                              02RD2010
      READ(KTIN,112) ( B(JZ), JZ = J1,J2 )                              02RD2020
  112 FORMAT ( 7F10.0 )                                                 02RD2030
      IF(J2.LT.NC)  GO TO 5                                             02RD2040
C --                                                                    02RD2050
C ---      READ INFORMATION (EQUATION) CARDS FOR PRINTOUT IF DESIRED.   02RD2060
C --                                                                    02RD2070
    7 IF(NEQU.EQ.0) GO TO 105                                           02RD2080
C --- TRAP IF NUMBER OF INFORMATION CARDS GT. DIMENSIONS.               02RD2090
      JC = MXNEQU                                                       02RD2100
      J2 = NEQU                                                         02RD2110
      IF(NEQU.LE.JC) JC = NEQU                                          02RD2120
      NEQU = JC*18                                                      02RD2130
      READ(KTIN,104) (EQU(I), I=1,NEQU)                                 02RD2140
  104 FORMAT( 18A4)                                                     02RD2150
      IF(J2.LE.MXNEQU) GO TO 105                                        02RD2160
      JC = J2 - MXNEQU                                                  02RD2170
      DO 103 J = 1, JC                                                  02RD2180
  103 READ(KTIN,467) J2                                                 02RD2190
  105 NBI =  2*NC                                                       02RD2200
      IF(NAMEBI.NE.1) GO TO 108                                         02RD2210
C --                                                                    02RD2220
C ---      READ NAMES OF COEFFICIENTS FOR PRINT OUT IF DESIRED.         02RD2230
C --                                                                    02RD2240
C --- TRAP IF NUMBER OF COEFFICIENTS ARE GREATER THAN DIMENSIONS        02RD2250
      IF(NC.LE.NCMAX) GO TO 8                                           02RD2260
      READ(KTIN,106) (DUM, I=1,NBI)                                     02RD2270
      GO TO 110                                                         02RD2280
    8 READ(KTIN,106) (BI(I),I=1,NBI)                                    02RD2290
  106 FORMAT( 7(A4,A2,4X) )                                             02RD2300
      GO TO 110                                                         02RD2310
  108 DO 109 I = 1, NBI                                                 02RD2320
  109 BI(I) = BLANK                                                     02RD2330
C --                                                                    02RD2340
C ---      PRINT INFORMATION (EQUATION) CARDS                           02RD2350
C --                                                                    02RD2360
  110 IF(NEQU.EQ.0) GO TO 118                                           02RD2370
      WRITE(KTOU, 117) (EQU(I), I=1, NEQU )                             02RD2380
  117 FORMAT(1H ,      18A4 )                                           02RD2390
C --                                                                    02RD2400
C ---      PRINT FORMAT CARD.                                           02RD2410
C --                                                                    02RD2420
  118 IF (JSAME.EQ.1) GO TO 220                                         02RD2430
      WRITE(KTOU,  122) FMT                                             02RD2440
  122 FORMAT(13H0DATA FORMAT , 18A4//                                   02RD2450
     1      24H OBSV. NO.  IDENT.  SEQ., 2X,  107H 1-11-21    2-12-22   02RD2460
     2 3-13-23    4-14-24    5-15-25    6-16-26    7-17-27    8-18-28   02RD2470
     3 9-19-29   10-20-30 )                                             02RD2480
      IF(NVARX - NOIND) 73,75,75                                        02RD2490
   73 WRITE(KTOU,   74) NVARX, NOIND                                    02RD2500
   74 FORMAT(1H0//////1X,39H******WARNING--THIS VERSION OF PROGRAM ,    02RD2510
     115HDIMENSIONED FOR,I3,11H VARIABLES,,I3,16H REQUESTED******//////)02RD2520
   75 IF(NOIND -  9)  76, 66, 66                                        02RD2530
   76 MNO = NOIND                                                       02RD2540
      GO TO 10                                                          02RD2550
   66 MNO = 9                                                           02RD2560
C --                                                                    02RD2570
C ---      READ DATA                                                    02RD2580
   10 N = N + 1                                                         02RD2590
      READ(NFILE,FMT,END=190) IDENT(N), Y(N), (X(I,N), I=1,NOIND)       02RD2600
      IF (IDENT(N) .EQ. AEND .OR. X(1,N) .EQ. 999.) GO TO 200           02RD2610
C --                                                                    02RD2620
C ---      DELETE NOMIT OBSERVATIONS IF REQUESTED                       02RD2630
C --                                                                    02RD2640
      IF((NOMIT - NFOUND).EQ.0) GO TO 310                               02RD2650
      J = NFOUND + 1                                                    02RD2660
      IF(JOMIT(J).NE.IDENT(N)) GO TO 310                                02RD2670
      NFOUND = NFOUND + 1                                               02RD2680
      N = N - 1                                                         02RD2690
      GO TO 10                                                          02RD2700
C --                                                                    02RD2710
C ---      SET UP INDEX TO WRITE FIRST CARD OF DATA GROUP               02RD2720
C --                                                                    02RD2730
  310 ISEQ = 1                                                          02RD2740
      WRITE(KTOU, 124) N, IDENT(N), ISEQ, Y(N), (X(I,N),I=1,MNO)        02RD2750
  124 FORMAT(1H ,2X,I4,5X,A6,1X,I4,10F11.3)                             02RD2760
      KKK = 9                                                           02RD2770
  170 IF (NOIND-KKK) 10, 10, 148                                        02RD2780
C ---      SET UP INDEX TO LIST OTHER VARIABLES IN OBSERVATION.         02RD2790
  148 KONE = KKK + 1                                                    02RD2800
      IF(NOIND-(KKK+10)) 166,166,165                                    02RD2810
  165 KTWO = KKK + 10                                                   02RD2820
      GO TO 167                                                         02RD2830
  166 KTWO = NOIND                                                      02RD2840
  167 ISEQ = ISEQ + 1                                                   02RD2850
      WRITE(KTOU, 126)  ISEQ, (X(I,N), I= KONE, KTWO )                  02RD2860
  126 FORMAT( 19X, I4, 10F11.3 )                                        02RD2870
      KKK = KKK + 10                                                    02RD2880
      GO TO 170                                                         02RD2890
C --                                                                    02RD2900
  190 IF (NFILE .NE. KTIN) REWIND NFILE                                 02RD2910
  200 NOB = N - 1                                                       02RD2920
      IF(NOB.LE.NOBMAX) GO TO 312                                       02RD2930
      WRITE(KTOU, 55555) NOBMAX, N                                      02RD2940
55555 FORMAT( 1H1 //24H0PROGRAM DIMENSIONED FOR,I4,16H OBSERVATIONS.  , 02RD2950
     1 I4, 8H READ IN/ 17H0PROBLEM SKIPPED. )                           02RD2960
      GO TO 1                                                           02RD2970
  220 WRITE(KTOU, 222 )                                                 02RD2980
  222 FORMAT( 1H0,  42HOBSERVATIONS THE SAME AS PREVIOUS PROBLEM.)      02RD2990
      GO TO 66666                                                       02RD3000
C --                                                                    02RD3010
C --- TRAP IF NUMBER OF COEFFICIENTS ARE GREATER THAN DIMENSIONS        02RD3020
C --                                                                    02RD3030
  312 IF(NC.LE.NCMAX) GO TO 320                                         02RD3040
      WRITE(KTOU, 314) NCMAX, NC                                        02RD3050
  314 FORMAT(1H0//////1X,  45H******THIS VERSION OF PROGRAM DIMENSIONED 02RD3060
     1FOR,I3,14H COEFFICIENTS,,I3,11H REQUESTED./17H0PROBLEM SKIPPED.)  02RD3070
      GO TO 1                                                           02RD3080
C --                                                                    02RD3090
C ---      LIST DELETED OBSERVATIONS, IF ANY.                           02RD3100
C --                                                                    02RD3110
  320 IF(NOMIT.EQ.0) GO TO 66666                                        02RD3120
      IF(NOMITC.LE.MNOMTC) GO TO 323                                    02RD3130
      WRITE(KTOU,      322) MNOMTC, NOMITC                              02RD3140
  322 FORMAT(1H0//////1X,  45H******THIS VERSION OF PROGRAM DIMENSIONED 02RD3150
     1FOR,I2,26H DELETE OBSERVATION CARDS,,I2,  42H REQUESTED.  NOT ALL 02RD3160
     2OBSERVATIONS DELETED.,6H******//////)                             02RD3170
  323 IF(NFOUND.EQ.0) GO TO 329                                         02RD3180
      WRITE(KTOU,      327)                                             02RD3190
  327 FORMAT(21H0OBSERVATIONS DELETED)                                  02RD3200
      WRITE(KTOU,      328) (JOMIT(JZ),JZ=1,NFOUND)                     02RD3210
  328 FORMAT(    10(6X,A6) )                                            02RD3220
      IF((NOMIT-NFOUND).EQ.0) GO TO 66666                               02RD3230
  329 WRITE(KTOU,      330  )                                           02RD3240
  330 FORMAT(23H0OBSERVATIONS NOT FOUND )                               02RD3250
      J = NFOUND + 1                                                    02RD3260
      WRITE(KTOU,      328) (JOMIT(JZ),JZ=J,NOMIT)                      02RD3270
      GO TO 66666                                                       02RD3280
C --                                                                    02RD3290
 1000 KTINED = 1                                                        02RD3300
66666 RETURN                                                            02RD3310
      END                                                               02RD3320
      SUBROUTINE MODEL1 (NPROB, B, FY, NOB, NC, X, NVARX, NOBMAX, NCMAX,04M10010
     1 KTOU)                                                            04M10011
      IMPLICIT REAL*8 (A-H,O-Z)                                         04M10020
      DIMENSION B(NCMAX), FY(NOBMAX), X(NVARX,NOBMAX)                   04M10030
C                                                                       04M10040
C *** BLANK MODEL1 SUBROUTINE  -  PRINTS MESSAGE AND STOPS              04M10050
C                                                                       04M10060
      IF(NC-0) 99, 99, 1                                                04M10070
    1 WRITE(KTOU,2)                                                     04M10080
    2 FORMAT(///52H0***** MODEL 1 SPECIFIED BUT FORTRAN SOURCE WAS NOT ,04M10090
     1          52HMADE AVAILABLE FOR THIS RUN.  EXECUTION STOPS. *****)04M10100
      STOP                                                              04M10110
C                                                                       04M10120
   99 RETURN                                                            04M10130
      END                                                               04M10140
      SUBROUTINE MODEL2 (NPROB, B, FY, NOB, NC, X, NVARX, NOBMAX, NCMAX,05M20010
     1 KTOU)                                                            05M10011
      IMPLICIT REAL*8 (A-H,O-Z)                                         05M20020
      DIMENSION B(NCMAX), FY(NOBMAX), X(NVARX,NOBMAX)                   05M20030
C                                                                       05M20040
C *** BLANK MODEL2 SUBROUTINE  -  PRINTS MESSAGE AND STOPS              05M20050
C                                                                       05M20060
      IF(NC-0) 99, 99, 1                                                05M20070
    1 WRITE(KTOU,2)                                                     05M10080
    2 FORMAT(///52H0***** MODEL 2 SPECIFIED BUT FORTRAN SOURCE WAS NOT ,05M20090
     1          52HMADE AVAILABLE FOR THIS RUN.  EXECUTION STOPS. *****)05M20100
      STOP                                                              05M20110
C                                                                       05M20120
   99 RETURN                                                            05M20130
      END                                                               05M20140
      SUBROUTINE MODEL3 (NPROB, B, FY, NOB, NC, X, NVARX, NOBMAX, NCMAX,06M30010
     1 KTOU)                                                            06M10011
      IMPLICIT REAL*8 (A-H,O-Z)                                         06M30020
      DIMENSION B(NCMAX), FY(NOBMAX), X(NVARX,NOBMAX)                   06M30030
C                                                                       06M30040
C *** BLANK MODEL3 SUBROUTINE  -  PRINTS MESSAGE AND STOPS              06M30050
C                                                                       06M30060
      IF(NC-0) 99, 99, 1                                                06M30070
    1 WRITE(KTOU,2)                                                     06M10080
    2 FORMAT(///52H0***** MODEL 3 SPECIFIED BUT FORTRAN SOURCE WAS NOT ,06M30090
     1          52HMADE AVAILABLE FOR THIS RUN.  EXECUTION STOPS. *****)06M30100
      STOP                                                              06M30110
C                                                                       06M30120
   99 RETURN                                                            06M30130
      END                                                               06M30140
      SUBROUTINE MODEL4 (NPROB, B, FY, NOB, NC, X, NVARX, NOBMAX, NCMAX,07M40010
     1 KTOU)                                                            07M10011
      IMPLICIT REAL*8 (A-H,O-Z)                                         07M40020
      DIMENSION B(NCMAX), FY(NOBMAX), X(NVARX,NOBMAX)                   07M40030
C                                                                       07M40040
C *** BLANK MODEL4 SUBROUTINE  -  PRINTS MESSAGE AND STOPS              07M40050
C                                                                       07M40060
      IF(NC-0) 99, 99, 1                                                07M40070
    1 WRITE(KTOU,2)                                                     07M10080
    2 FORMAT(///52H0***** MODEL 4 SPECIFIED BUT FORTRAN SOURCE WAS NOT ,07M40090
     1          52HMADE AVAILABLE FOR THIS RUN.  EXECUTION STOPS. *****)07M40100
      STOP                                                              07M40110
C                                                                       07M40120
   99 RETURN                                                            07M40130
      END                                                               07M40140
      SUBROUTINE MODEL5 (NPROB, B, FY, NOB, NC, X, NVARX, NOBMAX, NCMAX,08M50010
     1 KTOU)                                                            08M10011
      IMPLICIT REAL*8 (A-H,O-Z)                                         08M50020
      DIMENSION B(NCMAX), FY(NOBMAX), X(NVARX,NOBMAX)                   08M50030
C                                                                       08M50040
C *** BLANK MODEL5 SUBROUTINE  -  PRINTS MESSAGE AND STOPS              08M50050
C                                                                       08M50060
      IF(NC-0) 99, 99, 1                                                08M50070
    1 WRITE(KTOU,2)                                                     08M10080
    2 FORMAT(///52H0***** MODEL 5 SPECIFIED BUT FORTRAN SOURCE WAS NOT ,08M50090
     1          52HMADE AVAILABLE FOR THIS RUN.  EXECUTION STOPS. *****)08M50100
      STOP                                                              08M50110
C                                                                       08M50120
   99 RETURN                                                            08M50130
      END                                                               08M50140
      SUBROUTINE EIGENJ(H,U,D,NP,NS)                                    09EG0010
      IMPLICIT REAL*8(A-H,O-Z)                                          09EG0020
      DIMENSION H(2),U(2)                                               09EG0030
      NDX=NP*NS                                                         09EG0040
      NPR=NS+1                                                          09EG0050
      LP=NP-1                                                           09EG0060
      XN2=NP*NP                                                         09EG0070
      DO 1 I=1,NP                                                       09EG0080
      DO 1 J=I,NDX,NS                                                   09EG0090
    1 U(J)=0.0                                                          09EG0100
      DO 2 I=1,NDX,NPR                                                  09EG0110
    2 U(I)=1.0                                                          09EG0120
      E=D/XN2                                                           09EG0130
      ASSIGN 18 TO IND1                                                 09EG0140
   14 S2=0.0                                                            09EG0150
      J11=1                                                             09EG0160
      J12=0                                                             09EG0170
      DO 8 I=2,NP                                                       09EG0180
      J11=J11+NS                                                        09EG0190
      J12=J12+NS+1                                                      09EG0200
      DO 8 K=J11,J12                                                    09EG0210
    8 S2=S2+H(K)*H(K)                                                   09EG0220
      GO TO IND1,(18,15)                                                09EG0230
   18 J1=-NS                                                            09EG0240
      DO 5 J=1,LP                                                       09EG0250
      J1=J1+NS                                                          09EG0260
      JJ=J1+J                                                           09EG0270
      I=J+1                                                             09EG0280
      K1=J1                                                             09EG0290
      DO 5 K=I,NP                                                       09EG0300
      K1=K1+NS                                                          09EG0310
      KK=K1+K                                                           09EG0320
      JK=K1+J                                                           09EG0330
      KJ=J1+K                                                           09EG0340
      IF(H(JK)*H(JK)-E)5,5,13                                           09EG0350
   13 E1=H(JJ)                                                          09EG0360
      E2=H(KK)                                                          09EG0370
      E3=H(JK)                                                          09EG0380
      Y=E2-E1                                                           09EG0390
      R=DSQRT(Y*Y+4.0*E3*E3)                                            09EG0400
      IF(Y)21,22,22                                                     09EG0410
   21 R=-R                                                              09EG0420
   22 COS2=Y/R                                                          09EG0430
      SIN2=2.0*E3/R                                                     09EG0440
      COSS=DSQRT(0.5*(1.0+COS2))                                        09EG0450
      SINS=0.5*SIN2/COSS                                                09EG0460
      A=0.5*(E1+E2)                                                     09EG0470
      B=0.5*COS2*(E1-E2)-E3*SIN2                                        09EG0480
      H(JJ)=A+B                                                         09EG0490
      H(KK)=A-B                                                         09EG0500
      H(JK)=0.0                                                         09EG0510
      H(KJ)=0.0                                                         09EG0520
      N1=K-NS                                                           09EG0530
      L1=J-NS                                                           09EG0540
      N=K1                                                              09EG0550
      L=J1                                                              09EG0560
      DO 10 M=1,NP                                                      09EG0570
      N=N+1                                                             09EG0580
      L=L+1                                                             09EG0590
      N1=N1+NS                                                          09EG0600
      L1=L1+NS                                                          09EG0610
      U1=U(L)*COSS-U(N)*SINS                                            09EG0620
      U(N)=U(L)*SINS+U(N)*COSS                                          09EG0630
      U(L)=U1                                                           09EG0640
      IF((J-M)*(K-M))7,10,7                                             09EG0650
    7 H1=H(L)*COSS-H(N)*SINS                                            09EG0660
      H(N)=H(L)*SINS+H(N)*COSS                                          09EG0670
      H(L)=H1                                                           09EG0680
      H(N1)=H(N)                                                        09EG0690
      H(L1)=H1                                                          09EG0700
   10 CONTINUE                                                          09EG0710
    5 CONTINUE                                                          09EG0720
      ASSIGN 15 TO IND1                                                 09EG0730
      GO TO 14                                                          09EG0740
   15 IF(S2-D)17,17,18                                                  09EG0750
   17 RETURN                                                            09EG0760
      END                                                               09EG0770
      SUBROUTINE MATINV(A,NVAR,B,NB,DETERM,MA)                          10IN0010
      IMPLICIT REAL*8(A-H,O-Z)                                          10IN0020
      DIMENSION A(MA,MA),B(MA,NB),INDEX(100,2)                          10IN0030
      EQUIVALENCE (T,SWAP,PIVOT),(K,L1)                                 10IN0040
C                                                                       10IN0050
C     INITIALIZATION                                                    10IN0060
C                                                                       10IN0070
      DETERM=1.0                                                        10IN0080
      DO 20 J=1,100                                                     10IN0090
   20 INDEX(J,1)=0                                                      10IN0100
C                                                                       10IN0110
C     SEARCH FOR PIVOT ELEMENT                                          10IN0120
C                                                                       10IN0130
      I=0                                                               10IN0140
      IRANK=0                                                           10IN0150
   40 AMAX=-1.0                                                         10IN0160
      DO 105 J=1,NVAR                                                   10IN0170
      IF(INDEX(J,1))105,60,105                                          10IN0180
   60 DO 100 K=1,NVAR                                                   10IN0190
      IF(INDEX(K,1))100,80,100                                          10IN0200
   80 T=DABS(A(J,K))                                                    10IN0210
      IF(T.LE.AMAX) GO TO 100                                           10IN0220
      IROW=J                                                            10IN0230
      ICOLUM=K                                                          10IN0240
      AMAX=T                                                            10IN0250
  100 CONTINUE                                                          10IN0260
  105 CONTINUE                                                          10IN0270
      IF(AMAX)720,720,110                                               10IN0280
  110 INDEX(ICOLUM,1)=IROW                                              10IN0290
C                                                                       10IN0300
C     INTERCHANGE ROWS TO PUT PIVOT ELEMENT ON DIAGONAL                 10IN0310
C                                                                       10IN0320
      IF(IROW.EQ.ICOLUM) GO TO 310                                      10IN0330
      DETERM=-DETERM                                                    10IN0340
      DO 200 L=1,NVAR                                                   10IN0350
      SWAP=A(IROW,L)                                                    10IN0360
      A(IROW,L)=A(ICOLUM,L)                                             10IN0370
  200 A(ICOLUM,L)=SWAP                                                  10IN0380
      DO 250 L=1,NB                                                     10IN0390
      SWAP=B(IROW,L)                                                    10IN0400
      B(IROW,L)=B(ICOLUM,L)                                             10IN0410
  250 B(ICOLUM,L)=SWAP                                                  10IN0420
      I=I+1                                                             10IN0430
      INDEX(I,2)=ICOLUM                                                 10IN0440
  310 PIVOT=A(ICOLUM,ICOLUM)                                            10IN0450
      DETERM=PIVOT*DETERM                                               10IN0460
      IRANK=IRANK+1                                                     10IN0470
C                                                                       10IN0480
C     DIVIDE PIVOT ROW BY PIVOT ELEMENT                                 10IN0490
C                                                                       10IN0500
      A(ICOLUM,ICOLUM)=1.0                                              10IN0510
      PIVOT=A(ICOLUM,ICOLUM)/PIVOT                                      10IN0520
      DO 350 L=1,NVAR                                                   10IN0530
  350 A(ICOLUM,L)=A(ICOLUM,L)*PIVOT                                     10IN0540
      DO 370 L=1,NB                                                     10IN0550
  370 B(ICOLUM,L)=B(ICOLUM,L)*PIVOT                                     10IN0560
C                                                                       10IN0570
C     REDUCE NON-PIVOT ROWS                                             10IN0580
C                                                                       10IN0590
      DO 550 L1=1,NVAR                                                  10IN0600
      IF(L1.EQ.ICOLUM) GO TO 550                                        10IN0610
      T=A(L1,ICOLUM)                                                    10IN0620
      A(L1,ICOLUM)=0.0                                                  10IN0630
      DO 450 L=1,NVAR                                                   10IN0640
  450 A(L1,L)=A(L1,L)-A(ICOLUM,L)*T                                     10IN0650
      DO 500 L=1,NB                                                     10IN0660
  500 B(L1,L)=B(L1,L)-B(ICOLUM,L)*T                                     10IN0670
  550 CONTINUE                                                          10IN0680
      GO TO 40                                                          10IN0690
C                                                                       10IN0700
C     INTERCHANGE COLUMS                                                10IN0710
C                                                                       10IN0720
  630 ICOLUM=INDEX(I,2)                                                 10IN0730
      IROW=INDEX(ICOLUM,1)                                              10IN0740
      DO 705 K=1,NVAR                                                   10IN0750
      SWAP=A(K,IROW)                                                    10IN0760
      A(K,IROW)=A(K,ICOLUM)                                             10IN0770
  705 A(K,ICOLUM)=SWAP                                                  10IN0780
      I=I-1                                                             10IN0790
  720 IF(I)630,740,630                                                  10IN0800
  740 NB=NVAR-IRANK                                                     10IN0810
      RETURN                                                            10IN0820
      END                                                               10IN0830
      FUNCTION TTEST(IDF)                                               11TT0010
      IMPLICIT REAL*8(A-H,O-Z)                                          11TT0020
      DIMENSION TA(30)                                                  11TT0030
      DATA TA/12.706,4.303,3.182,2.776,2.571,2.447,2.365,2.306,2.262,   11TT0040
     12.228,2.201,2.179,2.160,2.145,2.131,2.120,2.110,2.101,2.093,2.086,11TT0050
     22.080,2.074,2.069,2.064,2.060,2.056,2.052,2.048,2.045,2.042/      11TT0060
      IF(IDF-30)10,10,11                                                11TT0070
   10 TTEST=TA(IDF)                                                     11TT0080
      RETURN                                                            11TT0090
   11 IF(IDF-120)12,12,13                                               11TT0100
   13 TTEST=1.96                                                        11TT0110
      RETURN                                                            11TT0120
   12 IF(IDF-40)14,14,15                                                11TT0130
   14 TTEST=2.042-0.021*FLOAT(IDF-30)/10.0                              11TT0140
      RETURN                                                            11TT0150
   15 IF(IDF-60)16,16,17                                                11TT0160
   16 TTEST=2.021-0.021*FLOAT(IDF-40)/20.0                              11TT0170
      RETURN                                                            11TT0180
   17 TTEST=2.000-0.002*FLOAT(IDF-60)/60.0                              11TT0190
      RETURN                                                            11TT0200
      END                                                               11TT0210
      SUBROUTINE SORT (IDENT, Y, NPROB, F, R, LSORT, YCMIN, YCMAX,      12SR0010
     1 NOBMAX, NNPROB, NOB, KTOU)                                       12SR0011
C --- SUBROUTINE SORTS AND PRINTS RESIDUALS IN CHRONOLOGICAL            12SR0020
C --- AND ASCENDING ORDER, THEN CALLS PITCHA TO PLOT RESIDUALS.         12SR0030
      IMPLICIT REAL*8(A-H,O-Z)                                          12SR0040
C                                                                       12SR0050
C                                                                       12SR0060
      REAL*8 IDENT                                                      12SR0070
      DIMENSION IDENT(NOBMAX), Y(NOBMAX), NPROB(NNPROB), F(NOBMAX),     12SR0080
     1    R(NOBMAX), LSORT(1)                                           12SR0090
      YCMIN = 1E32                                                      12SR0100
      YCMAX = -YCMIN                                                    12SR0110
      DO  10 IB =1, NOB                                                 12SR0120
      CALL MINMAX(YCMIN,YCMAX,F(IB) )                                   12SR0130
   10 CONTINUE                                                          12SR0140
      LSORT(1)  = 1                                                     12SR0150
      DO 16 ISA = 2, NOB                                                12SR0160
      TEMP = R(ISA)                                                     12SR0170
      ISAX = ISA - 1                                                    12SR0180
      DO 11 ISB = 1, ISAX                                               12SR0190
      IBB  = LSORT(ISB)                                                 12SR0200
      IF(TEMP - R(IBB) ) 12,12,11                                       12SR0210
   11 CONTINUE                                                          12SR0220
      LSORT(ISA) = ISA                                                  12SR0230
      GO TO 16                                                          12SR0240
   12 KSA  = ISA                                                        12SR0250
   13 KSA  = KSA - 1                                                    12SR0260
      LSORT(KSA + 1) = LSORT(KSA)                                       12SR0270
      IF(KSA - ISB) 15,15,13                                            12SR0280
   15 LSORT(ISB) = ISA                                                  12SR0290
   16 CONTINUE                                                          12SR0300
      WRITE(6, 1000   )                                                     12SR
 1000 FORMAT(1H0,44H---------ORDERED BY COMPUTER INPUT----------,       12SR0320
     1 10X,53H----------------ORDERED BY RESIDUALS-----------------/    12SR0330
     2      9H OBS. NO., 4X, 6HOBS. Y, 5X, 8HFITTED Y, 5X,              12SR0340
     3  8HRESIDUAL, 10X, 8HOBS. NO., 4X, 6HOBS. Y, 5X, 8HFITTED Y,      12SR0350
     4 2X,20HORDERED RESID.  SEQ. )                                     12SR0360
      NOB1 = NOB + 1                                                    12SR0370
      DO 20 IC = 1, NOB                                                 12SR0380
      IA = NOB1 - IC                                                    12SR0390
      JC = LSORT(IA)                                                    12SR0400
      WRITE(KTOU,1002),IDENT(IC), Y(IC), F(IC), R(IC),IDENT(JC), Y(JC), 12SR0410
     1 F(JC), R(JC), IC                                                 12SR0420
 1002 FORMAT(1H ,1X,A6,F11.3,2F13.3,11X,A6,F11.3,2F13.3,3X,I4)          12SR0430
   20 CONTINUE                                                          12SR0440
      RETURN                                                            12SR0450
      END                                                               12SR0460
      SUBROUTINE MINMAX(TMIN,TMAX,T )                                   13MM0010
C                                                                       13MM0020
C          SUBROUTINE TO FIND MINIMUM AND MAXIMUM OF ANY GIVEN ARRAY    13MM0030
C                                                                       13MM0040
      IMPLICIT REAL*8(A-H,O-Z)                                          13MM0050
      IF (T-TMIN)  2,3,3                                                13MM0060
    2 TMIN = T                                                          13MM0070
    3 IF (T-TMAX)  5,5,4                                                13MM0080
    4 TMAX = T                                                          13MM0090
    5 RETURN                                                            13MM0100
      END                                                               13MM0110
      SUBROUTINE PITCHA (X, EQU, BI, YYCC, DELTA, LSORT, NP, YCMIN,     14PC0010
     1    YCMAX, GRIDA, GRIDB, KTOU,                                    14PC0020
     2 NVARX, NOBMAX, NEQUNO, NBINO, NNPROB, NOB, NOIND, NPLOT)         14PC0021
C                                                                       14PC0030
C          SUBROUTINE PLOTS CUMULATIVE FREQUENCY OF RESIDUALS AND       14PC0040
C     RESIDUALS VS. FITTED Y                                            14PC0050
C                                                                       14PC0060
C                                                                       14PC0070
C                                                                       14PC0080
C                                                                       14PC0090
      DOUBLE PRECISION X(NVARX,NOBMAX), EQU(NEQUNO), BI(NBINO),         14PC0100
     1    YYCC(NOBMAX), DELTA(NOBMAX), YCMIN, YCMAX                     14PC0110
      DOUBLE PRECISION YCAVG, DELP, XMIN, XMAX, YIW, XIW, XAVG, XUQ,    14PC0120
     1    XLQ                                                           14PC0130
C                                                                       14PC0140
      DOUBLE PRECISION AMIN(20), AMAX(20)                               14PC0141
      DIMENSION NP(NNPROB), LSORT(1)                                    14PC0150
      DIMENSION GRIDA(53,26), GRIDB(53,26), NEG(8),                     14PC0160
     1          POS(8), PRAX(51), RESID(9)                              14PC0170
C                                                                       14PC0180
      DATA RESID/1HR,1HE,1HS,1HI,1HD,1HU,1HA,1HL,1HS/                   14PC0190
      DATA POS/1HP,1HO,1HS,1HI,1HT,1HI,1HV,1HE/                         14PC0200
      DATA NEG/1HN,1HE,1HG,1HA,1HT,1HI,1HV,1HE/                         14PC0210
      DATA IPLUS/5H+++++/                                               14PC0220
      DATA PRAX/.000233,  .000302,  .000390,  .000501,  .000641,        14PC0230
     1          .000816,  .001035,  .001306,  .001641,  .002052,        14PC0240
     2          .002555,  .003167,  .003907,  .004797,  .005868,        14PC0250
     3          .007143,  .008656,  .010444,  .012545,  .015003,        14PC0260
     4          .017864,  .021178,  .025588,  .029379,  .034380,        14PC0270
     5          .040059,  .046479,  .053699,  .061780,  .070781,        14PC0280
     6          .080757,  .091759,  .103835,  .117023,  .131357,        14PC0290
     7          .146859,  .163543,  .181411,  .200454,  .220650,        14PC0300
     8          .241964,  .264347,  .287740,  .312067,  .337243,        14PC0310
     9          .363169,  .389739,  .416834,  .444330,  .472097,        14PC0320
     A          .500000/                                                14PC0330
C                                                                       14PC0340
C --- IDENTIFICATION OF KTOU WRITE FILE.                                14PC0350
C                                                                       14PC0360
      NOOBSV = NOB                                                      14PC0370
      KTOU = 6                                                          14PC0380
      ITYPE = 1                                                         14PC0390
      XNP=NOOBSV                                                        14PC0400
      JJC=LSORT(NOOBSV)                                                 14PC0410
      DELP=DELTA(JJC)                                                   14PC0420
      IIC=LSORT(1)                                                      14PC0430
      YIW=(1.005D0*(DELP-DELTA(IIC)))/51.                               14PC0440
      XIW=(1.005D0*(YCMAX-YCMIN))/101.                                  14PC0450
      DO 2 IA=1,NOOBSV                                                  14PC0460
      JAC=LSORT(IA)                                                     14PC0470
      IF(DELTA(JAC).LT.0.) GO TO 2                                      14PC0480
      L1 = IDINT((DELP-DELTA(JAC))/YIW)+2                               14PC0490
      GO TO 4                                                           14PC0500
    2 CONTINUE                                                          14PC0510
    4 CALL GRID(GRIDA,GRIDB,L1,ITYPE)                                   14PC0520
      DO 30 IA=1,NOOBSV                                                 14PC0530
      JAC=LSORT(IA)                                                     14PC0540
      LINE = IDINT((DELP-DELTA(JAC))/YIW)+2                             14PC0550
      IF(LINE.LT.2.OR.LINE.GT.52) GO TO 30                              14PC0560
      LOCX1=IDINT((YYCC(JAC)-YCMIN)/XIW)+1                              14PC0570
      IF(LOCX1.LT.1.OR.LOCX1.GT.101) GO TO 10                           14PC0580
      IF(LOCX1.EQ.1) LOCX1=2                                            14PC0590
      LOCX2=LOCX1+4                                                     14PC0600
      LCHAR=MOD(LOCX2,4)                                                14PC0610
      LWORD=LOCX2/4                                                     14PC0620
      IF(LCHAR) 8,6,8                                                   14PC0630
    6 LCHAR=4                                                           14PC0640
      LWORD=LWORD-1                                                     14PC0650
    8 CALL PACK(GRIDA(LINE,LWORD),LCHAR,IPLUS)                          14PC0660
   10 PRLOC=(IA-0.5)/XNP                                                14PC0670
      IF(PRLOC-0.5) 12,12,18                                            14PC0680
   12 DO 14 IB=1,51                                                     14PC0690
      IF(PRLOC-PRAX(IB)) 16,16,14                                       14PC0700
   14 CONTINUE                                                          14PC0710
      IB=51                                                             14PC0720
   16 LOCP1=IB                                                          14PC0730
      GO TO 24                                                          14PC0740
   18 DO 20 IB=1,51                                                     14PC0750
      IC=52-IB                                                          14PC0760
      IF(PRLOC+PRAX(IC)-1.) 22,22,20                                    14PC0770
   20 CONTINUE                                                          14PC0780
   22 LOCP1=IB+50                                                       14PC0790
   24 LOCP2=LOCP1+4                                                     14PC0800
      LCHAR=MOD(LOCP2,4)                                                14PC0810
      LWORD=LOCP2/4                                                     14PC0820
      IF(LCHAR) 28,26,28                                                14PC0830
   26 LCHAR=4                                                           14PC0840
      LWORD=LWORD-1                                                     14PC0850
   28 CALL PACK(GRIDB(LINE,LWORD),LCHAR,IPLUS)                          14PC0860
   30 CONTINUE                                                          14PC0870
      WRITE(KTOU,34) NP                                                 14PC0880
   34 FORMAT(1H1,     1X,5A4, 33X,                                      14PC0890
     136HCUMULATIVE DISTRIBUTION OF RESIDUALS)                          14PC0900
      WRITE(KTOU,36)                                                    14PC0910
   36 FORMAT(1H ,17X,101H.0002  .001  .005  .01 .02   .05  .1    .2    314PC0920
     1  .4  .5  .6  .7   .8    .9   .95  .98 .99 .995   .999)           14PC0930
      WRITE(KTOU,38) ((GRIDB(IA,JZ),JZ=1,26),IA=1,3)                    14PC0940
   38 FORMAT(1H ,19X,25A4,A2)                                           14PC0950
      WRITE(KTOU,40) (POS(IA-3),(GRIDB(IA,JZ),JZ=1,26),IA=4,11)         14PC0960
   40 FORMAT(1H ,17X,A1,1X,25A4,A2)                                     14PC0970
      DO 46 IA=12,22                                                    14PC0980
      IF(IA.EQ.L1) GO TO 42                                             14PC0990
      WRITE(KTOU,38) (GRIDB(IA,JZ),JZ=1,26)                             14PC1000
      GO TO 46                                                          14PC1010
   42 WRITE(KTOU,44) (GRIDB(IA,JZ),JZ=1,26)                             14PC1020
   44 FORMAT(1H ,17X,1H0,1X,25A4,A2)                                    14PC1030
   46 CONTINUE                                                          14PC1040
      DO 54 IA=23,31                                                    14PC1050
      IF(IA.EQ.L1) GO TO 50                                             14PC1060
      WRITE(KTOU,48) RESID(IA-22),(GRIDB(IA,JZ),JZ=1,26)                14PC1070
   48 FORMAT(1H ,5X,A1,13X,25A4,A2)                                     14PC1080
      GO TO 54                                                          14PC1090
   50 WRITE(KTOU,52) RESID(IA-22),(GRIDB(IA,JZ),JZ=1,26)                14PC1100
   52 FORMAT(1H ,5X,A1,11X,1H0,1X,25A4,A2)                              14PC1110
   54 CONTINUE                                                          14PC1120
      DO 58 IA=32,42                                                    14PC1130
      IF(IA.EQ.L1) GO TO 56                                             14PC1140
      WRITE(KTOU,38) (GRIDB(IA,JZ),JZ=1,26)                             14PC1150
      GO TO 58                                                          14PC1160
   56 WRITE(KTOU,44) (GRIDB(IA,JZ),JZ=1,26)                             14PC1170
   58 CONTINUE                                                          14PC1180
      WRITE(KTOU,40) (NEG(IA-42),(GRIDB(IA,JZ),JZ=1,26),IA=43,50)       14PC1190
      WRITE(KTOU,38) ((GRIDB(IA,JZ),JZ=1,26),IA=51,53)                  14PC1200
      WRITE(KTOU,36)                                                    14PC1210
      WRITE(KTOU,60)                                                    14PC1220
   60 FORMAT(1H ,54X,33HCUMULATIVE FREQUENCY, NORMAL GRID)              14PC1230
      IF(YCMAX.EQ.YCMIN) GO TO 80                                       14PC1231
      WRITE(KTOU,62) NP                                                 14PC1240
   62 FORMAT(1H1,     1X,5A4, 39X, 21HRESIDUAL VS. FITTED Y )           14PC1250
      YCAVG = (YCMAX + YCMIN) / 2.                                      14PC1260
      WRITE(KTOU,64) YCMIN, YCAVG, YCMAX                                14PC1270
   64 FORMAT(1H ,13X, F10.3, 40X, F10.3, 40X, F10.3)                    14PC1280
      WRITE(KTOU,38) ((GRIDA(IA,JZ),JZ=1,26),IA=1,3)                    14PC1290
      WRITE(KTOU,40) (POS(IA-3),(GRIDA(IA,JZ),JZ=1,26),IA=4,11)         14PC1300
      DO 68 IA=12,22                                                    14PC1310
      IF(IA.EQ.L1) GO TO 66                                             14PC1320
      WRITE(KTOU,38) (GRIDA(IA,JZ),JZ=1,26)                             14PC1330
      GO TO 68                                                          14PC1340
   66 WRITE(KTOU,44) (GRIDA(IA,JZ),JZ=1,26)                             14PC1350
   68 CONTINUE                                                          14PC1360
      DO 72 IA=23,31                                                    14PC1370
      IF(IA.EQ.L1) GO TO 70                                             14PC1380
      WRITE(KTOU,48) RESID(IA-22),(GRIDA(IA,JZ),JZ=1,26)                14PC1390
      GO TO 72                                                          14PC1400
   70 WRITE(KTOU,52) RESID(IA-22),(GRIDA(IA,JZ),JZ=1,26)                14PC1410
   72 CONTINUE                                                          14PC1420
      DO 76 IA=32,42                                                    14PC1430
      IF(IA.EQ.L1) GO TO 74                                             14PC1440
      WRITE(KTOU,38) (GRIDA(IA,JZ),JZ=1,26)                             14PC1450
      GO TO 76                                                          14PC1460
   74 WRITE(KTOU,44) (GRIDA(IA,JZ),JZ=1,26)                             14PC1470
   76 CONTINUE                                                          14PC1480
      WRITE(KTOU,40) (NEG(IA-42),(GRIDA(IA,JZ),JZ=1,26),IA=43,50)       14PC1490
      WRITE(KTOU,38) ((GRIDA(IA,JZ),JZ=1,26),IA=51,53)                  14PC1500
      WRITE(KTOU,64) YCMIN, YCAVG, YCMAX                                14PC1510
      WRITE(KTOU,78)                                                    14PC1520
   78 FORMAT(1H ,66X,8HFITTED Y)                                        14PC1530
C                                                                       14PC1540
C----    PLOT RESIDUALS VS. EACH INDEPENDENT VARIABLES.                 14PC1550
C                                                                       14PC1560
   80 IF (NPLOT .NE. 3) GO TO 9999                                      14PC1570
      ITYPE = 3                                                         14PC1580
      DO 200 I=1,NOIND                                                  14PC1590
      XMIN=1E32                                                         14PC1600
      XMAX=-XMIN                                                        14PC1610
      DO 100 J = 1, NOOBSV                                              14PC1620
      XMIN = DMIN1 (XMIN,X(I,J))                                        14PC1630
  100 XMAX = DMAX1 (XMAX,X(I,J))                                        14PC1640
      AMIN(I)=XMIN                                                      14PC1650
200   AMAX(I)=XMAX                                                      14PC1660
      M = 0                                                             14PC1670
      DO 500 I = 1, NOIND                                               14PC1680
      IF(XMIN.EQ.XMAX) GO TO 500                                        14PC1681
      M = M + 1                                                         14PC1690
      YIW=(1.0005D0*(DELP-DELTA(IIC)))/51.                              14PC1691
      XMIN = AMIN(I)                                                    14PC1692
      XMAX = AMAX(I)                                                    14PC1693
      IF (XMAX .GT. 0.0) GO TO 220                                      14PC1700
      XIW=(1.0005D0*(XMAX-XMIN))/101.                                   14PC1710
      GO TO 240                                                         14PC1720
  220 XIW=(1.0005D0*(XMAX-XMIN))/101.                                   14PC1730
  240 CALL GRID (GRIDA, GRIDB, L1, ITYPE)                               14PC1740
      DO 300 IA = 1, NOOBSV                                             14PC1750
      JAC = LSORT(IA)                                                   14PC1760
      LINE = IDINT((DELP-DELTA(JAC)) / YIW) +2                          14PC1770
      IF (LINE .LT. 2 .OR. LINE .GT. 52) GO TO 300                      14PC1780
      LOCX1 = IDINT((X(M,JAC)-XMIN) / XIW) + 1                          14PC1790
      IF (LOCX1 .LT. 1 .OR. LOCX1 .GT. 101) GO TO 300                   14PC1800
      IF (LOCX1 .EQ. 1) LOCX1 = 2                                       14PC1810
      LOCX2 = LOCX1 +4                                                  14PC1820
      LCHAR = MOD(LOCX2,4)                                              14PC1830
      LWORD = LOCX2/4                                                   14PC1840
      IF (LCHAR) 280, 260, 280                                          14PC1850
  260 LCHAR = 4                                                         14PC1860
      LWORD = LWORD -1                                                  14PC1870
  280 CALL PACK (GRIDA(LINE,LWORD), LCHAR, IPLUS)                       14PC1880
  300 CONTINUE                                                          14PC1890
      J = I*2 -1                                                        14PC1900
      WRITE (KTOU,320) NP, I                                            14PC1910
  320 FORMAT(1H1,1X,5A4,30X,35HRESIDUALS VS. INDEPENDENT VARIABLE ,I2)  14PC1920
      XAVG = (XMAX + XMIN) / 2.                                         14PC1930
      XUQ  = (XMAX + XAVG) / 2.                                         14PC1940
      XLQ  = (XMIN + XAVG) / 2.                                         14PC1950
      WRITE (KTOU,340) XMIN, XLQ, XAVG, XUQ, XMAX                       14PC1960
  340 FORMAT(1H ,13X,F10.3,2(14X,F10.3,16X,F10.3))                      14PC1970
      WRITE (KTOU,38) ((GRIDA(IA,JZ),JZ=1,26),IA=1,3)                   14PC1980
      WRITE (KTOU,40) (POS(IA-3), (GRIDA(IA,JZ),JZ=1,26),IA=4,11)       14PC1990
      DO 380 IA = 12, 22                                                14PC2000
      IF (IA .EQ. L1) GO TO 360                                         14PC2010
      WRITE (KTOU,38) (GRIDA(IA,JZ),JZ=1,26)                            14PC2020
      GO TO 380                                                         14PC2030
  360 WRITE (KTOU,44) (GRIDA(IA,JZ),JZ=1,26)                            14PC2040
  380 CONTINUE                                                          14PC2050
      DO 420 IA = 23, 31                                                14PC2060
      IF (IA .EQ. L1) GO TO 400                                         14PC2070
      WRITE (KTOU,48) RESID(IA-22), (GRIDA(IA,JZ),JZ=1,26)              14PC2080
      GO TO 420                                                         14PC2090
  400 WRITE (KTOU,52) RESID(IA-22), (GRIDA(IA,JZ),JZ=1,26)              14PC2100
  420 CONTINUE                                                          14PC2110
      DO 460 IA = 32, 42                                                14PC2120
      IF (IA .EQ. L1) GO TO 440                                         14PC2130
      WRITE (KTOU,38) (GRIDA(IA,JZ),JZ=1,26)                            14PC2140
      GO TO 460                                                         14PC2150
  440 WRITE (KTOU,44) (GRIDA(IA,JZ),JZ=1,26)                            14PC2160
  460 CONTINUE                                                          14PC2170
      WRITE (KTOU,40) (NEG(IA-42), (GRIDA(IA,JZ),JZ=1,26),IA=43,50)     14PC2180
      WRITE (KTOU,38) ((GRIDA(IA,JZ),JZ=1,26),IA=51,53)                 14PC2190
      WRITE (KTOU,340) XMIN, XLQ, XAVG, XUQ, XMAX                       14PC2200
      WRITE (KTOU,480) I                                                14PC2210
  480 FORMAT(1H0,58X,20HINDEPENDENT VARIABLE, I2 )                      14PC2220
  500 CONTINUE                                                          14PC2230
 9999 RETURN                                                            14PC2240
      END                                                               14PC2250
      SUBROUTINE GRID (GRIDA, GRIDB, L1, ITYPE)                         15GR0010
C                                                                       15GR0020
C     SUBROUTINE MAKES GRIDA FOR RESIDUALS VS. FITTED Y.                15GR0030
C     SUBROUTINE MAKES GRIDB FOR CUMULATIVE DISTRIBUTION OF RESIDULS.   15GR0040
C         GRIDA IS ALSO USED TO PLOT COMPONENT-PLUS RESIDUALS VS. EACH  15GR0050
C         INDEPENDENT VARIABLE.                                         15GR0060
C         WHEN ITYPE = 1 - BOTH GRIDA AND GRIDB PLOTS ARE MADE.         15GR0070
C                      2 - GRIDA ALONE IS MADE                          15GR0080
C                      3 - THE PLOT AREA IS BLANKED OUT, REUSING THE    15GR0090
C                          OUTLINE FROM A PREVIOUS PLOT                 15GR0100
C         L1 IS THE LINE AT WHICH THE RESIDUALS CROSS 0, WHEN L1 = 99,  15GR0110
C         THE ZERO LINE IS NOT PLOTTED.                                 15GR0120
C                                                                       15GR0130
      DIMENSION GRIDA(53,26),GRIDB(53,26),GRDA(7),GRDB(4)               15GR0140
      DATA GRDA/4H*---,4H-*--,4H--*-,4H---*,4H----,2H*-,2H--/           15GR0150
      DATA GRDB/4HI   ,2H I,4HI---,2H-I/                                15GR0160
      DATA BLANK/4H    /,BLINK/4H   '/                                  15GR0170
      GO TO (1, 21, 23), ITYPE                                          15GR0180
    1 DO 2 IA = 1, 5                                                    15GR0190
      DO 2 IB=1,5                                                       15GR0200
      IC=(IA-1)*5+IB                                                    15GR0210
      GRIDA(1,IC)=GRDA(IB)                                              15GR0220
      GRIDA(53,IC)=GRDA(IB)                                             15GR0230
    2 CONTINUE                                                          15GR0240
      GRIDA(1,26)=GRDA(6)                                               15GR0250
      GRIDA(53,26)=GRDA(6)                                              15GR0260
      GRIDB(1, 1)=GRDA(1)                                               15GR0270
      GRIDB(1, 2)=GRDA(3)                                               15GR0280
      GRIDB(1, 3)=GRDA(5)                                               15GR0290
      GRIDB(1, 4)=GRDA(3)                                               15GR0300
      GRIDB(1, 5)=GRDA(2)                                               15GR0310
      GRIDB(1, 6)=GRDA(2)                                               15GR0320
      GRIDB(1, 7)=GRDA(4)                                               15GR0330
      GRIDB(1, 8)=GRDA(5)                                               15GR0340
      GRIDB(1, 9)=GRDA(1)                                               15GR0350
      GRIDB(1,10)=GRDA(3)                                               15GR0360
      GRIDB(1,11)=GRDA(4)                                               15GR0370
      GRIDB(1,12)=GRDA(4)                                               15GR0380
      GRIDB(1,13)=GRDA(4)                                               15GR0390
      GRIDB(1,14)=GRDA(4)                                               15GR0400
      GRIDB(1,15)=GRDA(4)                                               15GR0410
      GRIDB(1,16)=GRDA(5)                                               15GR0420
      GRIDB(1,17)=GRDA(1)                                               15GR0430
      GRIDB(1,18)=GRDA(3)                                               15GR0440
      GRIDB(1,19)=GRDA(4)                                               15GR0450
      GRIDB(1,20)=GRDA(5)                                               15GR0460
      GRIDB(1,21)=GRDA(2)                                               15GR0470
      GRIDB(1,22)=GRDA(2)                                               15GR0480
      GRIDB(1,23)=GRDA(1)                                               15GR0490
      GRIDB(1,24)=GRDA(5)                                               15GR0500
      GRIDB(1,25)=GRDA(1)                                               15GR0510
      GRIDB(1,26)=GRDA(7)                                               15GR0520
      DO 4 IA=1,26                                                      15GR0530
      GRIDB(53,IA)=GRIDB(1,IA)                                          15GR0540
    4 CONTINUE                                                          15GR0550
      DO 8 IA=2,52                                                      15GR0560
      DO 6 IB=2,25                                                      15GR0570
      GRIDA(IA,IB)=BLANK                                                15GR0580
      GRIDB(IA,IB)=BLANK                                                15GR0590
    6 CONTINUE                                                          15GR0600
      GRIDB(IA,13)=BLINK                                                15GR0610
    8 CONTINUE                                                          15GR0620
      DO 10 IA=2,52                                                     15GR0630
      GRIDA(IA,1)=GRDB(1)                                               15GR0640
      GRIDA(IA,26)=GRDB(2)                                              15GR0650
      GRIDB(IA,1)=GRDB(1)                                               15GR0660
      GRIDB(IA,26)=GRDB(2)                                              15GR0670
   10 CONTINUE                                                          15GR0680
      DO 12 IA=2,25                                                     15GR0690
      GRIDA(L1,IA)=GRDA(5)                                              15GR0700
      GRIDB(L1,IA)=GRDA(5)                                              15GR0710
   12 CONTINUE                                                          15GR0720
      GRIDA(L1,1)=GRDB(3)                                               15GR0730
      GRIDA(L1,26)=GRDB(4)                                              15GR0740
      GRIDB(L1,1)= GRDB(3)                                              15GR0750
      GRIDB(L1,26)=GRDB(4)                                              15GR0760
      RETURN                                                            15GR0770
   21 DO 22 IA = 1,5                                                    15GR0780
      DO 22 IB = 1,5                                                    15GR0790
      IC = (IA-1)*5 + IB                                                15GR0800
      GRIDA(1,IC) = GRDA(IB)                                            15GR0810
   22 GRIDA(53,IC) = GRDA(IB)                                           15GR0820
      GRIDA(1,26) = GRDA(6)                                             15GR0830
      GRIDA(53,26) = GRDA(6)                                            15GR0840
   23 DO 24 IA = 2,52                                                   15GR0850
      DO 24 IB = 2,25                                                   15GR0860
   24 GRIDA(IA,IB) = BLANK                                              15GR0870
      IF (L1 .NE. 99) GO TO 28                                          15GR0880
      DO 26 IA = 2,52                                                   15GR0890
      GRIDA(IA,1) = GRDB(1)                                             15GR0900
   26 GRIDA(IA,26) = GRDB(2)                                            15GR0910
      RETURN                                                            15GR0920
   28 DO 29 IA = 2,52                                                   15GR0930
      GRIDA(IA,1) = GRDB(1)                                             15GR0940
   29 GRIDA(IA,26) = GRDB(2)                                            15GR0950
      DO 30 IA = 2,25                                                   15GR0960
   30 GRIDA(L1,IA) = GRDA(5)                                            15GR0970
      GRIDA(L1,1) = GRDB(3)                                             15GR0980
      GRIDA(L1,26) = GRDB(4)                                            15GR0990
      RETURN                                                            15GR1000
      END                                                               15GR1010
      SUBROUTINE PACK(X,N,C)                                            16PK0010
C                                                                       16PK0020
C          SUBROUTINE PLACES THE APPROPRIATE SYMBOLS ON THE PLOTS       16PK0030
C     CHARACTER C IS PLACED IN BYTE N OF WORD X, WHERE WORD X IS        16PK0040
C     A SIMULATE BYTE IBM 360 WORD, WITH BYTES NUMBERED FROM THE LEFT.  16PK0050
C     N TAKES VALUES OF 1, 2, 3 OR 4.  PACK IS CALLED FROM PITCHA.      16PK0060
C                                                                       16PK0070
      Y=X                                                               16PK0110
      CALL DEPSIT(C,N,Y)                                                16PK0120
C                                                                       16PK0130
      X=Y                                                               16PK0140
      RETURN                                                            16PK0150
      END                                                               16PK0160
      SUBROUTINE OPEN                                                   17OP0010
      DOUBLE PRECISION FILIN,FILOU                                      17OP0020
 100  FORMAT(A10)                                                       17OP0030
 101  FORMAT(' INPUT THE NAME OF THE OUTPUT FILE')                      17OP0040
 102  FORMAT(' INPUT THE NAME OF THE INPUT FILE')                       17OP0050
      TYPE 102                                                          17OP0060
      ACCEPT 100,FILIN                                                  17OP0070
      TYPE 101                                                          17OP0080
      ACCEPT 100,FILOU                                                  17OP0090
      OPEN(UNIT=5,DEVICE='DSK:',ACCESS='SEQIN',FILE=FILIN)              17OP0100
      OPEN(UNIT=6,DEVICE='DSK:',ACCESS='SEQINOU',FILE=FILOU)            17OP0110
      RETURN                                                            17OP0120
      END                                                               17OP0130
      SUBROUTINE OUTPUT(IDENT,Y,X,FY,B,NOB,NOIND,NC,NOBMAX,NVARX,NCMAX, 180U0010
     1 KTOU)                                                            180U0011
      IMPLICIT REAL*8 (A-H,O-Z)                                         18OU0020
      REAL*8 IDENT                                                      18OU0030
      DIMENSION Y(NOBMAX),X(NVARX,NOBMAX),FY(NOBMAX),B(NCMAX)           18OU0040
C                                                                       18OU0050
C *** USER MAY DO WHATEVER IS REQUIRED USING AVAILABLE INFORMATION      18OU0060
C *** KTOU IS THE NAME OF THE WRITE FILE.                               18OU0061
C                                                                       18OU0070
      RETURN                                                            18OU0080
      END                                                               18OU0090