Trailing-Edge
-
PDP-10 Archives
-
decuslib10-06
-
43,50402/nln20c.pgm
There are 2 other files named nln20c.pgm in the archive. Click here to see a list.
C --- NONLINWOOD NONLINEAR LEAST-SQUARES CURVE-FITTING PROGRAM 01CT0010
C 01CT0020
C --- 1/80 01CT0030
C 01CT0040
C *** PROGRAM CURRENTLY DIMENSIONED FOR 20 MAX VARIABLES, 20 MAX 01CT0050
C --- COEFFICIENTS, 170 OBSERVATIONS AND 2 DELETE OBSERVATIONS CARDS. 01CT0060
C 01CT0070
C GAUSHAUS PROGRAM WAS ORIGINALLY WRITTEN BY D. A. MEETER, 01CT0080
C UNIV. OF WISCONSIN, USING D. W. MARQUART'S MAXIMUM NEIGHBORHOOD 01CT0090
C METHOD. PROGRAM WAS REVISED AT STANDARD OIL (INDIANA) BY 01CT0100
C F. S. WOOD TO PROVIDE NOMENCLATURE, PRINTOUT AND PLOTS CONSISTENT 01CT0110
C WITH THE LINEAR LEAST-SQUARES CURVE FITTING PROGRAM. IT WAS 01CT0120
C MODIFIED TO ALLOW FOR OVERLAYING BY R. E. HENSCHEL. THE PROGRAM 01CT0130
C IS IN DOUBLE PRECISION FOR IBM 360 AND 370 COMPUTERS (SHARE 01CT0140
C LIBRARY PROGRAM NUMBER 360-13.6.007). 01CT0150
C 01CT0160
C PROGRAM CONVERTED AT UNIV. CAL(BERKELEY) BY N. H. TIMM TO 01CT0170
C SINGLE PRECISION FOR CDC 6000 SERIES COMPUTERS (VIM LIBRARY 01CT0180
C PROGRAM NUMBER G2-CAL-NLWOOD). UPDATED BY TIMM, WOOD, AND 01CT0190
C B. E. FOSTER AND ELI COHEN, NORTHWESTERN UNIVERSITY. 01CT0191
C 01CT0200
C PROGRAM CONVERTED AT ALCOA R&D LABORATORIES BY R. F. KOHM 01CT0210
C FOR DECSYSTEM-10 AND 20 COMPUTERS (DECUS LIBRARY PROGRAM NUMBER 01CT0220
C NONLIN-10-258). PROGRAM ADAPTED FOR INTERACTIVE USE BY 01CT0221
C E. R. ZIEGEL AND UPDATED BY M. P. KELLY, BOTH AT STANDARD OIL. 01CT0222
C PROGRAM FOR DECSYSTEM PDP-11 COMPUTERS CONVERTED AT U.S. NAVAL 01CT0223
C AVIONICS FACILITY, INDIANAPOLIS, INDIANA BY D. F. ZARNOW 01CT0224
C (DECUS LIBRARY PROGRAM NUMBER NONLIN-11-420). 01CT0225
C 01CT0230
C PROGRAM CONVERTED AT UNIV. WISCONSIN BY J. D. MURAT AND 01CT0240
C T. R. ZEISLER FOR BURROUGHS 4700 AND 6700 SYSTEM COMPUTERS (CUBE 01CT0250
C LIBRARY PROGRAM NUMBER WIS/NONLINWOOD). THE PROJECT WAS 01CT0260
C INITIATED BY D. S. RUMSEY OF BURROUGHS. 01CT0261
C 01CT0270
C PROGRAM CONVERTED AT U.S. NAVAL AVIONICS FACILITY, 01CT0271
C INDIANAPOLIS, IN. BY D. F. ZARNOW FOR HONEYWELL 6000/600/66 01CT0272
C COMPUTERS (HLSUA LIBRARY PROGRAM NUMBER GES-1207). 01CT0273
C 01CT0274
C PROGRAM CONVERTED AT JOHNSON SPACE CENTER BY J. E. KEITH 01CT0280
C FOR UNIVAC 1108 AND 1110 COMPUTERS. 01CT0290
C 01CT0300
C 01CT0310
C 01CT0320
C FOR GLOSSARY OF TERMS, DEFINITIONS OF STATISTICS AND 01CT0330
C INTERPRETATION OF RESULTS SEE USER'S MANUAL IN BOOK "FITTING 01CT0340
C EQUATIONS TO DATA" BY C. DANIEL AND F. S. WOOD WITH ASSISTANCE 01CT0350
C OF J. W. GORMAN, WILEY, 2ND EDITION, 1980. 01CT0360
C 01CT0370
C 01CT0380
C 01CT0390
C --- AUXILIARY EQUIPMENT NEEDED TO RUN PROGRAM 01CT0400
C --- CARD READER (UNIT 5), AND PRINTER (UNIT 6). 01CT0410
C 01CT0420
C 01CT0430
C 01CT0440
C 01CT0450
C 01CT0460
C --- USER'S INSTRUCTIONS 01CT0470
C --- 01CT0480
C --- ORDER OF CARDS FOR EACH PROBLEM 01CT0490
C --- 1 CONTROL CARD. 01CT0500
C --- 2 FORMAT CARD (72COL). E.G. (A6,F6.0,(NOIND*F6.0)) TO READ DATA. 01CT0510
C --- 3 DELETE-OBSERVATIONS CARD(S), IF ANY 01CT0511
C --- (1ST 6 OF 10 COLS. / OBSERVATION DELETED, 7 / CARD). 01CT0512
C --- 4 STARTING VALUES (GUESSES) OF COEFFICIENTS (10COL/COEF, 7/CARD). 01CT0520
C --- 5 INFORMATION CARDS FOR PRINTOUT,IF ANY(72COL/CARD, 12 CARDS MAX).01CT0530
C --- 6 NAMES OF COEFFICIENTS CARD(S) FOR PRINTOUT, IF ANY 01CT0540
C --- (1ST 6 OF 10 COLS. / COEFFICIENT, 7 / CARD). 01CT0550
C --- 7 DATA CARDS (IF NOT READ FROM A FILE). 01CT0560
C --- 8 END CARD (END IN FIRST 3 POSITIONS OF IDENTIFICATION). 01CT0570
C --- NOTE: FORMAT, DELETE, DATA AND END CARDS ARE NOT NEEDED IN 01CT0580
C --- SUBSEQUENT PROBLEMS IF SAME INPUT DATA ARE REUSED. 01CT0590
C --- 01CT0600
C --- CONTROL CARD 01CT0610
C --- COL. 1-20 NPROB :IDENTIFICATION OF PROBLEM, 5A4. 01CT0620
C --- 21 JSAME :0 OR BLANK, OBSERVATIONS READ FROM CARDS. 01CT0630
C --- 1, REUSE DATA FROM PREVIOUS PROBLEM. 01CT0640
C --- 23-24 NC :NO. OF COEFFICIENTS TO BE ESTIMATED, I2. 01CT0650
C --- 25-26 NFILE :FILE NUMBER IF DATA ARE TO BE READ FROM 01CT0660
C --- SEPARATE FILE, NO END CARD(S) IF ONLY ONE 01CT0670
C --- SET OF DATA IS ON EACH FILE. 01CT0680
C --- 27-28 NOIND :NO. OF INDEPENDENT VARIABLES TO BE READ IN, I2 01CT0690
C --- 31-32 MODEL :NO. OF THE EQUATION TO BE USED, I2. 01CT0700
C --- 01CT0710
C --- 33-36 FLAM :STARTING VALUE FOR LAMBDA, F4.2, (E.G. 0.1), 01CT0720
C --- USED AS A MULTIPLIER TO SCALE THE SPACE OR 01CT0730
C --- SIZE STEPS TAKEN. 01CT0740
C --- 37-40 FNU :VALUE OF NU, F4.0, (E.G. 10.), 01CT0750
C --- DIVISOR AND MULTIPLIER TO CHANGE SIZE OF 01CT0760
C --- LAMBDA DEPENDING ON WHETHER SUM OF SQUARES OF 01CT0770
C --- ITERATION IS NEAR OR FAR FROM MINIMUM. 01CT0780
C --- 43-44 MIT :MAX NUMBER OF ITERATIONS, I2, (E.G. 20). 01CT0790
C --- 45-48 DIFF :MULTIPLIER USED TO INCREMENT VALUE OF 01CT0800
C --- COEFFICIENTS, F4.3 (E.G. 0.01). 01CT0810
C --- 01CT0811
C --- NOTE: IF FLAM, FNU, MIT, AND DIFF ARE NOT DEFINED 01CT0820
C --- ON THE CONTROL CARD, THEIR LEVEL WILL BE SET 01CT0830
C --- AUTOMATICALLY TO THE ABOVE E.G. VALUES. 01CT0840
C --- 01CT0850
C --- STOP :CRITERIA FOR ENDING CONVERGING ITERATIONS. 01CT0860
C --- 49-56 STOPSS:SUM OF SQUARES CRITERION, F8.7 (E.G. 0.0001, 01CT0870
C --- A CHANGE OF LESS THAN 0.0001 IN THE RESIDUAL 01CT0880
C --- SUM OF SQUARES). 01CT0890
C --- 57-64 STOPRC:RATIO OF COEFFICIENTS CRITERION, F8.7, 01CT0900
C --- (E.G. 0.001 A CHANGE OF LESS THAN 0.001 IN 01CT0910
C --- THE RATIOS OF ALL COMPARABLE COEFFICIENTS). 01CT0920
C --- 01CT0921
C --- NOTE: STOPSS AND STOPRC CAN BE SET AT 0.0 IF CONTROL 01CT0930
C --- OF EITHER OR BOTH IS NOT DESIRED. 01CT0940
C --- 01CT0950
C --- 65-66 NEQU :NO OF INFORMATION CARDS TO BE READ FOR DISPLAY 01CT0960
C --- ON PRINTOUT IF DESIRED, 72 COL.EACH, 12 MAX. 01CT0970
C --- 68 NAMEBI:1 READ NAMES OF COEFFICIENTS FROM CARDS FOR 01CT0980
C --- DISPLAY ON PRINTOUT, 1ST 6 OF 10 COLS. / 01CT0990
C --- COEFFICIENT, 7 / CARD. 01CT1000
C --- 69 NPLOT :3 PLOT RESIDUALS VS. EACH INDEPENDENT VARIABLE.01CT1010
C --- 70 NOMITC:NO OF DELETE OBSERVATION CARDS, OBSERVATION 01CT1011
C --- IDENTIFICATION IN 1ST 6 OF 10 COLS., 7 / CARD. 01CT1012
C -- 01CT1020
C --- FORMAT CARD 01CT1030
C --- COL. 1-72 E.G. (A6, F6.0, (NOIND*F6.0) 01CT1040
C --- IDENT IDENTIFICATION OF OBSERVATION, A6 01CT1050
C --- Y(J) DEPENDENT VARIABLE, J-TH OBSERVATION, F6.0 01CT1060
C --- X(I,J) INDEPENDENT VARIABLE, I-TH VARIABLE, J-TH 01CT1070
C --- OBSERVATION, NOIND*(F6.0) 01CT1080
C -- 01CT1090
C *******************************************************************01CT1100
C -- 01CT1110
C --- EQUATIONS TO BE USED WILL BE WRITTEN IN FORTRAN AND PLACED 01CT1120
C --- IN SUBROUTINE MODEL1, 2, 3, 4, OR 5 AS FOLLOWS: 01CT1130
C --- 01CT1140
C --- SUBROUTINE MODEL1 (NPROB, B, FY, NOB, NC, X, NVARX, NOBMAX, NCMAX)01CT1150
C IMPLICIT REAL*8(A-H,O-Z) 01CT1160
C --- DIMENSION B(NCMAX), FY(NOBMAX), X(NVARX,NOBMAX) 01CT1170
C 01CT1180
C --- DO 10 J=1,NOB 01CT1190
C --- EXAMPLE OF EQUATION 01CT1200
C --- FY(J)=B(1)*X(1,J)**B(2) + B(3) 01CT1210
C --- 01CT1220
C -10 CONTINUE 01CT1230
C --- RETURN 01CT1240
C --- END 01CT1250
C --- NOTE: ALL EQUATIONS ARE TO BE WRITTEN SO THAT THE 01CT1260
C --- COEFFICIENTS ESTIMATED AND CALCULATED WILL BE 01CT1270
C --- POSITIVE. IN SINGLE PRECISION PROGRAMS DELETE 01CT1280
C --- IMPLICIT REAL*(A-H,O-Z) STATEMENTS. 01CT1281
C 01CT1290
C *******************************************************************01CT1300
C * *01CT1310
C * TO PERFORM TRANSFORMATIONS, ADD SUBROUTINE BLOCK DATA AND *01CT1320
C * APPROPRIATE CARDS IN MODEL SUBROUTINE. E.G. *01CT1330
C * *01CT1340
C BLOCK DATA *01CT1350
C IMPLICIT REAL*8(A-H,O-Z) *01CT1360
C COMMON /DATA05/ IOPEN *01CT1370
C DATA IOPEN /0/ *01CT1380
C END *01CT1390
C * *01CT1400
C SUBROUTINE MODEL2 (NPROB, B, FY, NOB, NC, X, NVARX, NOBMAX, NCMAX)01CT1410
C *01CT1420
C IN THIS EXAMPLE THE VALUES OF Y ARE LOGGED AND THE RECIPROCAL *01CT1430
C OF X IS TAKEN INITIALLY AND NOT AGAIN. *01CT1440
C *01CT1450
C IMPLICIT REAL*8(A-H,O-Z) *01CT1460
C COMMON /DATA01/ IDENT(170), Y(170) *01CT1470
C COMMON /DATA05/ IOPEN *01CT1480
C DIMENSION B(NCMAX), FY(NOBMAX), X(NVARX,NOBMAX) *01CT1490
C REAL*8 IDENT *01CT1500
C *01CT1510
C IF (IOPEN .NE. 0) GO TO 7 *01CT1520
C DO 5 J = 1, NOB *01CT1530
C Y(J) = DLOG(Y(J)) *01CT1540
C 5 X(1,J) = (1./X(1,J)) *01CT1550
C *01CT1560
C 7 DO 10 J = 1, NOB *01CT1570
C FY(J) = B(1)*X(1,J)**B(2) + B(3) *01CT1580
C 10 CONTINUE *01CT1590
C *01CT1600
C IOPEN = 1 *01CT1610
C RETURN *01CT1620
C END *01CT1630
C * *01CT1640
C *******************************************************************01CT1650
C 01CT1660
C --- NVARX AND NOBMAX ARE USED TO DIMENSION SUBSEQUENT SUBROUTINES. 01CT1670
C --- THE MAX NUMBER OF VARIABLES(NVARX) AND THE MAX NUMBER OF 01CT1680
C --- OBSERVATIONS(NOBMAX) ARE DEPENDENT ON THE COMPUTER CORE SIZE 01CT1690
C --- AVAILABLE. HOWEVER, ONE CAN BE TRADED FOR THE OTHER BY THE 01CT1700
C --- FOLLOWING EQUATIONS: (UNITS IN WORDS) 01CT1710
C --- CORE AVAILABLE = (CORE LESS BUFFER - PROGRAM EX VARS. AND OBSVS.) 01CT1720
C --- E.G. 48,100CA = ( 61,300CLB - 13,200PROGRAM EX V AND O) 01CT1730
C --- NOBMAX = (CORE AVAILABLE - 8NVARX - 3(NVARX)SQRD) / (4 + 2NVARX) 01CT1740
C --- E.G.(50VAR,386NOB), (60VAR,296NOB), (70VAR,228NOB), (80VAR,172NOB)01CT1741
C --- 01CT1742
C --- DELZ MUST TOTAL 2756+NOBMAX TO PROVIDE SPACE FOR PLOTS IN PITCHA 01CT1743
C 01CT1744
C * * * * * * * * * * * * * * * * * * * * * * * 01CT1750
C * 01CT1751
C * SUGGESTED OVERLAY CARDS TO BE INCLUDED IN THE LINK STEP 01CT1752
C INSERT DATA01,DATA02,DATA04,MINMAX 01CT1753
C OVERLAY AAA 01CT1754
C INSERT READIN 01CT1755
C OVERLAY AAA 01CT1756
C INSERT GAUSHS,TTEST,EIGENJ,MATINV 01CT1757
C OVERLAY BBB 01CT1758
C INSERT MODEL1 01CT1759
C OVERLAY BBB 01CT1760
C INSERT MODEL2 01CT1761
C OVERLAY BBB 01CT1762
C INSERT MODEL3 01CT1763
C OVERLAY BBB 01CT1764
C INSERT MODEL4 01CT1765
C OVERLAY BBB 01CT1766
C INSERT MODEL5 01CT1767
C OVERLAY AAA 01CT1768
C INSERT SORT 01CT1769
C OVERLAY AAA 01CT1770
C INSERT PITCHA,GRID,PACK,FORCE 01CT1771
C ENTRY MAIN 01CT1772
C * 01CT1773
C * * * * * * * * * * * * * * * * * * * * * * * 01CT1774
C 01CT1780
IMPLICIT REAL*8 (A-H,O-Z) 01CT1790
COMMON /DATA01/ IDENT(170), Y(170), X(20,170), B(20), DIFZ(20), 01CT1800
1 SIGNS(20), F(170), R(170), DELZ(170,20) 01CT1810
C 01CT1820
COMMON /DATA02/ STOPSS, STOPCR, FLAM, FNU, MIT, NC, NEQU, 01CT1830
1 NOMIT, NFOUND 01CT1840
C 01CT1850
COMMON /DATA04/ EQU(216), BI( 40), NPROB(5) 01CT1860
REAL*8 IDENT, JOMIT(14) 01CT1870
EXTERNAL MODEL1, MODEL2, MODEL3, MODEL4, MODEL5 01CT1880
DIMENSION LSORT(1) 01CT1890
EQUIVALENCE (LSORT(1), DELZ(1,1)) 01CT1900
C 01CT1910
C *******************************************************************01CT1920
C * *01CT1930
C * TO CHANGE THE NUMBER OF VARIABLES, COEFFICIENTS AND/OR 01CT1940
C * OBSERVATIONS: 01CT1941
C * 1) REPLACE LABEL COMMON DATA01 AND DATA04 IN MAIN *01CT1950
C * 2) INITIALIZE NVARX, NCMAX AND NOBMAX WHERE: *01CT1960
C * NVARX = MAXIMUM NUMBER OF VARIABLES *01CT1970
C * NCMAX = MAXIMUM NUMBER OF COEFFICIENTS *01CT1971
C * NOBMAX= MAXIMUM NUMBER OF OBSERVATIONS *01CT1980
C * 3) REPLACE DIMENSION STATEMENT IN SUBROUTINE GAUSHS *01CT1990
C * IF NCMAX IS CHANGED. *01CT2000
C * *01CT2010
C * EXAMPLE: NUMBER OF VARIABLES = 10, COEFFICIENTS = 15 AND *01CT2020
C * OBSERVATIONS = 200 *01CT2021
C * *01CT2030
C * REPLACE DATA01 COMMON TO *01CT2040
C COMMON /DATA01/ IDENT(200), Y(200), X(10,200), B(15), DIFZ(15), *01CT2050
C 1 SIGNS(15), F(200), R(200), DELZ(200,15) *01CT2060
C * REPLACE DATA04 COMMON WITH DIMENSION OF BI = 2*NCMAX *01CT2061
C COMMON /DATA04/ EQU(216), BI( 30), NPROB(5) *01CT2062
C * *01CT2070
C * AND REPLACE *01CT2080
NVARX = 20 01CT2090
NCMAX = 20 01CT2091
NOBMAX = 170 01CT2100
C * WITH *01CT2110
C NVARX = 10 *01CT2120
C NCMAX = 15 *01CT2121
C NOBMAX = 200 *01CT2130
C * *01CT2140
C * REPLACE DIMENSION STATEMENT IN SUBROUTINE GAUSHS TO: *01CT2150
C DIMENSION E(15), P(15), PHI(15), Q(15), TB(15), A(15,15), *01CT2160
C 1 D(15,15), U(15,15) *01CT2170
C * *01CT2180
C *******************************************************************01CT2190
C * *01CT2191
C * TO CHANGE THE MAXIMUM NUMBER OF DELETE OBSERVATION CARDS *01CT2192
C * READ AND HENCE THE MAXIMUM NUMBER OF DELETE OBSERVATIONS *01CT2193
C * ( 7 PER CARD): CHANGE MNOMTC, MAXIMUM NUMBER OF DELETE CARDS *01CT2194
C * AND DIMENSION OF JOMIT(MNOMTC*7) IN MAIN. *01CT2195
C * *01CT2196
C *******************************************************************01CT2197
NNPROB = 5 01CT2200
C --- MXNEQU = MAXIMUM NUMBER OF INFORMATION (EQUATION) CARDS. 01CT2201
MXNEQU = 12 01CT2202
C --- NEQUNO = DIMENSION OF NEQU. 01CT2203
NEQUNO = MXNEQU*18 01CT2210
C --- MNOMTC = MAXIMUM NUMBER OF DELETE OBSERVATION CARDS. 01CT2211
MNOMTC = 2 01CT2212
C --- MNOMIT = MNOMTC*7 OBSERVATIONS/CARD, 7(A6,4X), IDENT OF 01CT2213
C --- OBSERVATIONS TO BE DELETED, THE DIMENSIONS OF JOMIT. 01CT2214
MNOMIT = MNOMTC*7 01CT2215
C --- NBINO = DIMENSIONS OF BI, THE NAMES OF THE COEFFICIENTS. 01CT2216
NBINO = 2*NCMAX 01CT2220
C --- KTIN = FILE TO READ CONTROL CARDS 01CT2221
KTIN = 5 01CT2222
C --- NFILE = FILE TO READ DATA 01CT2223
C --- NFILE = KTIN UNLESS SPECIFIED ON CONTROL CARD, COLUMN 25-26 01CT2224
C --- KTOU = FILE FOR PRINTOUT OF PLOTS 01CT2225
KTOU = 6 01CT2226
KTINED = 0 01CT2230
100 IERGAU = 0 01CT2240
C 01CT2250
C --- CALL SUBROUTINE READIN TO READ CONTROL CARDS AND DATA. 01CT2260
C 01CT2270
CALL OPEN 01CT2271
200 CALL READIN (KTOU,IDENT, Y, X, EQU, BI, NPROB, B, DIFZ, SIGNS, 01CT2280
1 MODEL, KTINED, KTIN, JOMIT, MNOMIT, NVARX, NOBMAX, NEQUNO, 01CT2290
2 NBINO, NNPROB, NOB, NOIND, NPLOT, NCMAX) 01CT2291
C 01CT2300
IF (KTINED .NE. 0) GO TO 9999 01CT2310
C 01CT2320
C --- DETERMINE WHICH MODEL AND CALL SUBROUTINE GAUSHS. 01CT2330
C 01CT2340
IF (MODEL .GT. 0 .AND. MODEL .LT. 6) GO TO 250 01CT2341
WRITE(KTOU, 240) MODEL 01CT2342
240 FORMAT(1H1,38H***CONTROL CARD ERROR*** MODEL NUMBER ,I2, 01CT2343
1 10H REQUESTED ) 01CT2344
GO TO 200 01CT2345
250 IF (MODEL .EQ. 1) CALL GAUSHS (IDENT, Y, X, EQU, BI, NPROB, B, 01CT2350
1 KTOU, DIFZ, SIGNS, F, R, DELZ, MODEL1, IERGAU, MNOMIT, JOMIT, 01CT2360
2 NVARX, NOBMAX, NEQUNO, NBINO, NNPROB, NOB, NOIND, NPLOT, NCMAX) 01CT2361
IF (MODEL .EQ. 2) CALL GAUSHS (IDENT, Y, X, EQU, BI, NPROB, B, 01CT2370
1 KTOU, DIFZ, SIGNS, F, R, DELZ, MODEL2, IERGAU, MNOMIT, JOMIT, 01CT2380
2 NVARX, NOBMAX, NEQUNO, NBINO, NNPROB, NOB, NOIND, NPLOT, NCMAX) 01CT2381
IF (MODEL .EQ. 3) CALL GAUSHS (IDENT, Y, X, EQU, BI, NPROB, B, 01CT2390
1 KTOU, DIFZ, SIGNS, F, R, DELZ, MODEL3, IERGAU, MNOMIT, JOMIT, 01CT2400
2 NVARX, NOBMAX, NEQUNO, NBINO, NNPROB, NOB, NOIND, NPLOT, NCMAX) 01CT2401
IF (MODEL .EQ. 4) CALL GAUSHS (IDENT, Y, X, EQU, BI, NPROB, B, 01CT2410
1 KTOU, DIFZ, SIGNS, F, R, DELZ, MODEL4, IERGAU, MNOMIT, JOMIT, 01CT2420
2 NVARX, NOBMAX, NEQUNO, NBINO, NNPROB, NOB, NOIND, NPLOT, NCMAX) 01CT2421
IF (MODEL .EQ. 5) CALL GAUSHS (IDENT, Y, X, EQU, BI, NPROB, B, 01CT2430
1 KTOU, DIFZ, SIGNS, F, R, DELZ, MODEL5, IERGAU, MNOMIT, JOMIT, 01CT2440
2 NVARX, NOBMAX, NEQUNO, NBINO, NNPROB, NOB, NOIND, NPLOT, NCMAX) 01CT2441
C 01CT2450
IF (IERGAU .NE. 0) GO TO 100 01CT2460
C 01CT2470
C --- CALL SUBROUTINE SORT TO PRINT AND SORT RESIDUALS IN 01CT2480
C --- CHRONOLOGICAL AND ASCENDING ORDER. 01CT2490
C 01CT2500
CALL SORT (IDENT, Y, NPROB, F, R, DELZ, YCMIN, YCMAX, NOBMAX, 01CT2510
1 NNPROB, NOB, KTOU) 01CT2511
C 01CT2520
C --- CALL SUBROUTINE PITCHA TO PLOT RESIDUALS. 01CT2530
C 01CT2540
CALL PITCHA (X, EQU, BI, F, R, DELZ, NPROB, YCMIN, YCMAX, 01CT2550
1 LSORT(NOBMAX+1), LSORT(NOBMAX+1379), KTOU, 01CT2560
2 NVARX, NOBMAX, NEQUNO, NBINO, NNPROB, NOB, NOIND, NPLOT) 01CT2561
C 01CT2570
C CALL OPTIONAL OUTPUT SUBROUTINE 01CT2571
C 01CT2572
CALL OUTPUT (IDENT,Y,X,F,B,NOB,NOIND,NC,NOBMAX,NVARX,NCMAX,KTOU) 01CT2573
C 01CT2580
TYPE 9000 01CT2581
9000 FORMAT(//1H0,' *** PRINT OUTPUT FILE FOR COMPLETE INFORMATION *** 01CT2582
1 '////) 01CT2583
WRITE(KTOU, 300) NPROB 01CT2584
300 FORMAT(1H1,18HEND OF PROBLEM ,5A4) 01CT2590
GO TO 200 01CT2600
C 01CT2610
9999 STOP 01CT2620
END 01CT2630
SUBROUTINE GAUSHS (IDENT, Y, X, EQU, BI, NPROB, TH, KTOU, DIFZ, 03GH0010
1 SIGNS, F, R, DELZ, MODEL, IERGAU, MNOMIT, JOMIT, 03GH0020
2 NVARX, NOBMAX, NEQUNO, NBINO, NNPROB, NOB, NOIND, NPLOT, NCMAX) 03GH0021
IMPLICIT REAL*8(A-H,O-Z) 03GH0030
COMMON /DATA02/ STOPSS, STOPCR, FLAM, FNU, MIT, NC, NEQU, 03GH0040
1 NOMIT, NFOUND 03GH0050
C 03GH0060
REAL*8 IDENT, JOMIT(MNOMIT) 03GH0070
DIMENSION IDENT(NOBMAX), Y(NOBMAX), X(NVARX,NOBMAX), EQU(NEQUNO), 03GH0080
1 BI(NBINO), NPROB(NNPROB), TH(NCMAX), DIFZ(NCMAX), 03GH0090
2 SIGNS(NCMAX), F(NOBMAX), R(NOBMAX), DELZ(NOBMAX,NCMAX) 03GH0100
C *******************************************************************03GH0110
C * *03GH0120
C * REPLACE THE FOLLOWING DIMENSION STATEMENT WHEN THE MAX NUMBER *03GH0130
C * OF COEFFICIENTS (NCMAX) IS CHANGED. *03GH0140
C * *03GH0150
C *******************************************************************03GH0160
DIMENSION E(20), P(20), PHI(20), Q(20), TB(20), A(20,20), 03GH0170
1 D(20,20), U(20,20) 03GH0180
C 03GH0190
C --- NCMAX DIMENSIONS SUBROUTINES EIGENJ AND MATINV IN THE ARGUMENTS 03GH0200
C --- OF THEIR CALL STATEMENTS. 03GH0210
NP = NC 03GH0220
TYPE 3999 03GH0221
3999 FORMAT(//30H0NONLINWOOD - DEC VERSION 1980/17H0NONLINEAR LEAST-, 03GH0222
1 29HSQUARES CURVE-FITTING PROGRAM //) 03GH0223
TYPE 3998,NPROB,NOB, NP, FLAM, FNU, MIT 03GH0224
3998 FORMAT(31H NONLINEAR ESTIMATION, , 5A4/23H NUMBER OF OBS03GH0225
1ERVATIONS, I5/23H NUMBER OF COEFFICIENTS, I5/16H STARTING LAMBDA, 03GH0226
2 F16.3/15H STARTING NU , F17.3/22H MAX NO. OF ITERATIONS, I6// )03GH0227
WRITE(KTOU, 1000)NPROB,NOB,NP,FLAM,FNU,MIT 03GH0230
1000 FORMAT(31H1NONLINEAR ESTIMATION, , 5A4/23H NUMBER OF OBS03GH0240
1ERVATIONS, I5/23H NUMBER OF COEFFICIENTS, I5/16H STARTING LAMBDA, 03GH0250
2 F16.3/15H STARTING NU , F17.3/22H MAX NO. OF ITERATIONS, I6// )03GH0260
TYPE 1001 03GH0261
WRITE(KTOU, 1001) 03GH0270
1001 FORMAT(35H0INITIAL VALUES OF THE COEFFICIENTS ) 03GH0280
TYPE 4000, (I,I=1,NP) 03GH0281
4000 FORMAT(8(4X,I2,6X)) 03GH0282
WRITE(KTOU, 2000)(I,I=1,NP) 03GH0290
2000 FORMAT(10(4X,I2,6X)) 03GH0300
TYPE 4001, (TH(I),I=1,NP) 03GH0301
4001 FORMAT(1H ,1P6E12.5) 03GH0302
WRITE(KTOU, 2001)(TH(I),I=1,NP) 03GH0310
2001 FORMAT(1H0,1P10E12.5) 03GH0320
WRITE(KTOU, 1002 ) 03GH0330
1002 FORMAT(53H0PROPORTIONS USED IN CALCULATING DIFFERENCE QUOTIENTS ) 03GH0340
WRITE(KTOU, 2000)(I,I=1,NP) 03GH0350
WRITE(KTOU, 2001)(DIFZ(I),I=1,NP) 03GH0360
IF(NOIND - NVARX) 14,14,991 03GH0361
14 IF(NP-NCMAX)15,15,992 03GH0370
15 IF(NP-2)993,16,16 03GH0380
16 GA=FLAM 03GH0390
NIT=1 03GH0400
ASSIGN 225 TO IRAN 03GH0410
ASSIGN 265 TO JORDAN 03GH0420
ASSIGN 180 TO KUWAIT 03GH0430
DELT=1.0E-08*FLOAT(NP*NP/2) 03GH0440
IF(NOB-NOBMAX)18,18,994 03GH0450
18 IF(NOB-NP)995,20,20 03GH0460
20 IF(MIT-100)10,10,996 03GH0470
10 IF(STOPCR)997,40,30 03GH0480
40 IF(STOPSS)997,60,50 03GH0490
60 ASSIGN 270 TO IRAN 03GH0500
GO TO 70 03GH0510
50 ASSIGN 265 TO IRAN 03GH0520
GO TO 70 03GH0530
30 IF(STOPSS)997,80,70 03GH0540
80 ASSIGN 270 TO JORDAN 03GH0550
70 SSQ=0 03GH0560
CALL MODEL(NPROB, TH, F, NOB, NP, X, NVARX, NOBMAX, NCMAX, KTOU) 03GH0570
DO 90 I=1,NOB 03GH0580
R(I)=Y(I)-F(I) 03GH0590
90 SSQ=SSQ+R(I)*R(I) 03GH0600
TYPE 1003, SSQ 03GH0601
WRITE(KTOU, 1003)SSQ 03GH0610
1003 FORMAT(24H0INITIAL SUM OF SQUARES:, 1PE12.4) 03GH0620
C --- BEGIN ITERATION 03GH0630
100 WRITE(KTOU, 1004)NIT 03GH0640
TYPE 1004, NIT 03GH0641
1004 FORMAT(///35X,13HITERATION NO., I4) 03GH0650
GA=GA/FNU 03GH0660
DO 130 J=1,NP 03GH0670
TEMP=TH(J) 03GH0680
TH(J)=TH(J)+DIFZ(J)*TH(J) 03GH0690
Q(J)=0 03GH0700
CALL MODEL(NPROB,TH,DELZ(1,J),NOB,NP,X,NVARX,NOBMAX, NCMAX, KTOU) 03GH0710
DO 120 I=1,NOB 03GH0720
DELZ(I,J)=DELZ(I,J)-F(I) 03GH0730
120 Q(J)=Q(J)+DELZ(I,J)*R(I) 03GH0740
Q(J)=Q(J)/(DIFZ(J)*TH(J)) 03GH0750
C --- Q=XT*R (STEEPEST DESCENT) 03GH0760
130 TH(J)=TEMP 03GH0770
DO 150 I=1,NP 03GH0780
DO 151 J=1,I 03GH0790
SUM=0 03GH0800
DO 160 K=1,NOB 03GH0810
160 SUM=SUM+DELZ(K,I)*DELZ(K,J) 03GH0820
TEMP =SUM/(DIFZ(I)*TH(I)*DIFZ(J)*TH(J)) 03GH0830
C --- D=XT*X (MOMENT MATRIX) 03GH0840
D(J,I)=TEMP 03GH0850
151 D(I,J)=TEMP 03GH0860
150 E(I)=DSQRT(D(I,I)) 03GH0870
GO TO KUWAIT,(225,265,180,270,666) 03GH0880
C --- -ITERATION 1 ONLY- 03GH0890
180 DO 200 I=1,NP 03GH0900
DO 200 J=1,I 03GH0910
SUM =D(I,J) 03GH0920
A(J,I)=SUM 03GH0930
200 A(I,J)=SUM 03GH0940
C --- KOK AND LOL ARE ALTERNATE DIMENSIONS AMD LIMIT VALUES OF 03GH0950
C --- THE MATRIX INVERSION SUBROUTINE MATINV. 03GH0960
KOK=1 03GH0970
LOL=0 03GH0980
CALL EIGENJ(A,U,DELT,NP,NCMAX) 03GH0990
TYPE 1006 03GH0991
WRITE(KTOU, 1006 ) 03GH1000
1006 FORMAT(52H0EIGENVALUES OF MOMENT MATRIX - PRELIMINARY ANALYSIS ) 03GH1010
TYPE 4001, (A(I,I),I=1,NP) 03GH1011
WRITE(KTOU, 2001)(A(I,I),I=1,NP) 03GH1020
ASSIGN 666 TO KUWAIT 03GH1030
C --- -END ITERATION 1- 03GH1040
666 DO 153 I=1,NP 03GH1050
DO 153 J=1,I 03GH1060
C --- A= SCALED MOMENT MATRIX 03GH1070
A(I,J)=D(I,J)/(E(I)*E(J)) 03GH1080
153 A(J,I)=A(I,J) 03GH1090
DO 155 I=1,NP 03GH1100
P(I)=Q(I)/E(I) 03GH1110
PHI(I)=P(I) 03GH1120
155 A(I,I)=A(I,I)+GA 03GH1130
CALL MATINV(A,NP,P,KOK,DET,NCMAX) 03GH1140
C --- P/E = CORRECTION VECTOR 03GH1150
WRITE(KTOU, 1005)DET 03GH1160
1005 FORMAT(13H0DETERMINANT:, 1PE12.4) 03GH1170
STEP=1.0 03GH1180
170 DO 220 I=1,NP 03GH1190
220 TB(I)=P(I)*STEP/E(I)+TH(I) 03GH1200
DO 401 I=1,NP 03GH1210
IF(SIGNS(I))998, 401, 402 03GH1220
402 IF(TH(I)*TB(I))403,403,401 03GH1230
401 CONTINUE 03GH1240
SUMB=0 03GH1250
CALL MODEL(NPROB, TB, F, NOB, NP, X, NVARX, NOBMAX, NCMAX, KTOU) 03GH1260
DO 230 I=1,NOB 03GH1270
R(I)=Y(I)-F(I) 03GH1280
230 SUMB=SUMB+R(I)*R(I) 03GH1290
403 SUM1=0.0 03GH1300
SUM2=0.0 03GH1310
SUM3=0.0 03GH1320
DO 231 I=1,NP 03GH1330
SUM1=SUM1+P(I)*PHI(I) 03GH1340
SUM2=SUM2+P(I)*P(I) 03GH1350
231 SUM3=SUM3+PHI(I)*PHI(I) 03GH1360
ANGLE=57.2957795*DARCOS(SUM1/DSQRT(SUM2*SUM3)) 03GH1370
C --- PRINT ANGLE IN SCALED COORDINATES 03GH1380
WRITE(KTOU, 1041)ANGLE 03GH1390
1041 FORMAT(25H0ANGLE IN SCALED. COORD,=, F5.2, 8H DEGREES ) 03GH1400
DO 2401 I=1,NP 03GH1410
IF(SIGNS(I))998,2401,2402 03GH1420
2402 IF(TH(I)*TB(I))663,663,2401 03GH1430
2401 CONTINUE 03GH1440
IF(SUMB/SSQ-1.0)662,662,663 03GH1450
663 IF(ANGLE-30.0)665,665,664 03GH1460
665 STEP=STEP/2.0 03GH1470
GO TO 170 03GH1480
664 GA=GA*FNU 03GH1490
GO TO 666 03GH1500
C --- PRINT COEFFICIENTS VIA FIT 03GH1510
662 WRITE(KTOU, 1007) 03GH1520
TYPE 1007 03GH1521
1007 FORMAT(23H0VALUES OF COEFFICIENTS ) 03GH1530
DO 669 I=1,NP 03GH1540
669 TH(I)=TB(I) 03GH1550
TYPE 4000,(I,I=1,NP) 03GH1551
WRITE(KTOU, 2000)(I,I=1,NP) 03GH1560
TYPE 4001, (TH(I),I=1,NP) 03GH1561
WRITE(KTOU, 2006)(TH(I),I=1,NP) 03GH1570
2006 FORMAT(1H , 1P10E12.5) 03GH1580
TYPE 4040, SUMB 03GH1581
4040 FORMAT(16H0SUM OF SQUARES:, 1PE12.4) 03GH1582
WRITE(KTOU, 1040)GA,SUMB 03GH1590
1040 FORMAT(8H0LAMBDA:,1PE10.3, 20X,27HSUM OF SQUARES AFTER LEAST-, 03GH1600
1 12HSQUARES FIT:, 1PE12.4) 03GH1610
GO TO IRAN,(225,265,180,270,666) 03GH1620
225 DO 240 I=1,NP 03GH1630
IF(DABS(P(I)*STEP/E(I))/(1.0E-20+DABS(TH(I)))-STOPCR)240,240,250 03GH1640
C --- ITERATION STOPS---RELATIVE CHANGE IN EACH COEFFICIENT. 03GH1650
240 CONTINUE 03GH1660
TYPE 1009, STOPCR 03GH1661
WRITE(KTOU, 1009)STOPCR 03GH1670
1009 FORMAT(54H0ITERATION STOPS - RELATIVE CHANGE IN EACH COEFFICIENT, 03GH1680
1 11H LESS THAN:, 1PE12.4) 03GH1690
GO TO 280 03GH1700
250 GO TO JORDAN,(225,265,180,270,666) 03GH1710
265 IF(SSQ-SUMB-STOPSS)260,260,270 03GH1720
C --- ITERATION STOPS---RELATIVE CHANGE IN SUM OF SQUARES. 03GH1730
260 WRITE(KTOU, 1010)STOPSS 03GH1740
TYPE 1010, STOPSS 03GH1741
1010 FORMAT(63H0ITERATION STOPS ---------- CHANGE IN SUM OF SQUARES LES03GH1750
1S THAN:, 1PE12.4) 03GH1760
GO TO 280 03GH1770
270 SSQ=SUMB 03GH1780
NIT=NIT+1 03GH1790
IF(NIT-MIT)100,100,279 03GH1800
C --- END ITERATION 03GH1810
279 TYPE 4011, MIT 03GH1811
4011 FORMAT(40H0NUMBER OF ITERATIONS EXCEEDS MAXIMUM OF,I4) 03GH1812
280 SSQ=SUMB 03GH1820
IDF=NOB-NP 03GH1830
C --- PRINT CORRELATION MATRIX 03GH1840
TYPE 1015 03GH1841
WRITE(KTOU, 1015 ) 03GH1850
1015 FORMAT(19H0CORRELATION MATRIX ) 03GH1860
CALL MATINV(D,NP,P,LOL,DET,NCMAX) 03GH1870
TYPE 1005, DET 03GH1871
WRITE(KTOU, 1005)DET 03GH1880
DO 7692 I=1,NP 03GH1890
7692 E(I)=DSQRT(D(I,I)) 03GH1900
TYPE 4005, (I,I=1,NP) 03GH1901
4005 FORMAT(3X,7(4X,I2,5X)) 03GH1902
WRITE(KTOU, 2005)(I,I=1,NP) 03GH1910
2005 FORMAT(3X,10(4X,I2,5X)) 03GH1920
DO 390 I=1,NP 03GH1930
DO 340 J=I,NP 03GH1940
A(J,I)=D(J,I)/(E(I)*E(J)) 03GH1950
D(J,I)=D(J,I)/(DIFZ(I)*TH(I)*DIFZ(J)*TH(J)) 03GH1960
D(I,J)=D(J,I) 03GH1970
340 A(I,J)=A(J,I) 03GH1980
TYPE 4009, I,(A(J,I),J=1,I) 03GH1981
4009 FORMAT(I3,7(2X,F7.4,2X)) 03GH1982
390 WRITE(KTOU, 2009)I,(A(J,I),J=1,I) 03GH1990
2009 FORMAT(I3,10(2X,F7.4,2X)) 03GH2000
IF(IDF)995,410,7058 03GH2010
7058 RMS = SSQ/FLOAT(IDF) 03GH2020
SDEV = DSQRT(RMS) 03GH2030
YYMIN = 1E32 03GH2040
YYMAX = -YYMIN 03GH2050
DO 500 I = 1,NOB 03GH2060
CALL MINMAX(YYMIN, YYMAX, Y(I) ) 03GH2070
500 CONTINUE 03GH2080
YW = YYMAX - YYMIN 03GH2090
WRITE(KTOU, 1050) NPROB, YYMIN, YYMAX, YW 03GH2100
1050 FORMAT(1H1,28X,45HNONLINEAR LEAST-SQUARES CURVE-FITTING PROGRAM// 03GH2110
1 1X, 5A4, 2X, 9HDEP.VAR.:, 1X, 7HMIN Y =, 1PE10.3, 03GH2120
2 2X, 8HMAX Y = , 1PE10.3, 2X,10HRANGE Y = , 1PE10.3 / ) 03GH2130
IF(NEQU.EQ.0) GO TO 502 03GH2140
WRITE(KTOU, 1051) (EQU(I), I=1,NEQU ) 03GH2150
1051 FORMAT(1H , 18X, 18A4 ) 03GH2160
502 IF(NOMIT.EQ.0) GO TO 944 03GH2161
IF(NFOUND.EQ.0) GO TO 909 03GH2162
WRITE(KTOU, 907) (JOMIT(JZ),JZ=1,NFOUND) 03GH2163
907 FORMAT(19X,22HOBSERVATIONS DELETED: ,7(A6,2X),7(/41X,7(A6,2X))) 03GH2164
IF((NOMIT-NFOUND).EQ.0) GO TO 944 03GH2165
J = NFOUND + 1 03GH2166
909 WRITE(KTOU, 910) (JOMIT(JZ),JZ=J,NOMIT) 03GH2167
910 FORMAT(19X,24HOBSERVATIONS NOT FOUND: ,7(A6,2X),7(/43X,7(A6,2X))) 03GH2168
944 WRITE(KTOU, 1052 ) 03GH2170
1052 FORMAT(1H0, 62X,21H95% CONFIDENCE LIMITS / 03GH2180
1 1X,10HIND.VAR(I), 3X, 4HNAME, 5X, 9HCOEF.B(I), 6X,10HS.E. COEF , 03GH2190
2 4X, 7HT-VALUE, 4X,22HLOWER UPPER ) 03GH2200
TVAR=TTEST(IDF) 03GH2210
DO 550 I = 1,NP 03GH2220
SECOEF= E(I)*SDEV 03GH2230
TVALUE= TH(I)/SECOEF 03GH2240
TSEC = TVAR*SECOEF 03GH2250
TMCOE = TH(I) - TSEC 03GH2260
TPCOE = TH(I) + TSEC 03GH2270
K = 2*I 03GH2280
J = K - 1 03GH2290
WRITE(KTOU, 2010) I, BI(J), BI(K), TH(I), SECOEF, TVALUE, TMCOE, 03GH2300
1 TPCOE 03GH2310
2010 FORMAT(1H , 4X, I2, 6X, A4, A2, 2X, 1PE12.5, 5X, 1PE9.2, 4X, 03GH2320
1 0PF6.1, 5X, 1PE9.2, 5X, 1PE9.2) 03GH2330
550 CONTINUE 03GH2340
WRITE(KTOU, 1054) NOB 03GH2350
1054 FORMAT(20H0NO. OF OBSERVATIONS, 11X, I5) 03GH2360
WRITE(KTOU, 1056) NP 03GH2370
1056 FORMAT(20H NO. OF COEFFICIENTS, 11X, I5) 03GH2380
NDFR = IDF + 0.01 03GH2390
WRITE(KTOU, 1058) NDFR 03GH2400
1058 FORMAT(28H RESIDUAL DEGREES OF FREEDOM, 4X, I4) 03GH2410
WRITE(KTOU, 1062) SDEV 03GH2420
1062 FORMAT(26H RESIDUAL ROOT MEAN SQUARE, 3X, F16.8) 03GH2430
WRITE(KTOU, 1064) RMS 03GH2440
1064 FORMAT(21H RESIDUAL MEAN SQUARE, 8X, F16.8) 03GH2450
WRITE(KTOU, 1066) SSQ 03GH2460
1066 FORMAT(24H RESIDUAL SUM OF SQUARES, 5X, F16.8) 03GH2470
GO TO 99999 03GH2480
410 WRITE(KTOU, 1033)NPROB 03GH2490
1033 FORMAT(1H1,18HEND OF PROBLEM ,5A4) 03GH2500
GO TO 88888 03GH2510
991 WRITE(KTOU, 3034) NVARX 03GH2511
3034 FORMAT(1H0,11H***ERROR***/32H0EXCESSIVE NUMBER OF VARIABLES. , 03GH2512
1 36H PROGRAM DIMENSIONED FOR MAXIMUM OF , I3 ) 03GH2513
GO TO 410 03GH2514
992 WRITE(KTOU, 3035) NCMAX 03GH2520
3035 FORMAT(1H0,11H***ERROR***/35H0EXCESSIVE NUMBER OF COEFFICIENTS. , 03GH2530
1 36H PROGRAM DIMENSIONED FOR MAXIMUM OF , I3 ) 03GH2540
GO TO 410 03GH2550
993 WRITE(KTOU, 3036 ) 03GH2560
3036 FORMAT(1H0,11H***ERROR***/26H0LESS THAN 2 COEFFICIENTS. ) 03GH2570
GO TO 410 03GH2580
994 WRITE(KTOU, 3037) NOBMAX 03GH2590
3037 FORMAT(1H0,11H***ERROR***/35H0EXCESSIVE NUMBER OF OBSERVATIONS. , 03GH2600
1 36H PROGRAM DIMENSIONED FOR MAXIMUM OF , I4 ) 03GH2610
GO TO 410 03GH2620
995 WRITE(KTOU, 3038 ) 03GH2630
3038 FORMAT(1H0,11H***ERROR***/55H0NUMBER OF COEFFICIENTS EXCEEDS NUMBE03GH2640
1R OF OBSREVATIONS. ) 03GH2650
GO TO 410 03GH2660
996 WRITE(KTOU, 3039 ) 03GH2670
3039 FORMAT(1H0,11H***ERROR***/33H0EXCESSIVE NUMBER OF ITERATIONS. , 03GH2680
1 44H PROGRAM LIMIT SWITCH SET FOR MAXIMUM OF 100 ) 03GH2690
GO TO 410 03GH2700
997 WRITE(KTOU, 3040) STOPSS, STOPCR 03GH2710
3040 FORMAT(1H0,11H***ERROR***/36H0STOP CRITERIA IS NEGATIVE. STOPSS =,03GH2720
1 F12.7,10H, STOPRC =, F12.7 ) 03GH2730
GO TO 410 03GH2740
998 WRITE(KTOU, 3041) I 03GH2750
3041 FORMAT(1H0,11H***ERROR***/12H0COEFFICIENT ,I4,18H HAS NEGATIVE SIG03GH2760
1N ) 03GH2770
GO TO 410 03GH2780
88888 IERGAU = 1 03GH2790
99999 RETURN 03GH2800
END 03GH2810