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