Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
C STEPWISE REGRESSION - MAIN PROGRAM MAY 2, 1966
C
C THIS PROGRAM IS A SIFTED VERSION OF THE ORIGINAL FORTRAN II
C PROGRAM, BMD02R WITH SOME MODIFICATIONS TO MAKE IT OPERABLE.
C IT WAS THEN CONVERTED TO 360 FORTRAN IV (H-LEVEL)
C
C PROBLEM CARD FORMAT
C COL NAME
C 1- 6 XMAN PROBLM
C 10-15 CODE ALPHANUMERIC PROBLEM NAME
C 17-20 N NUMBER OF CASES
C 24-25 NOV NUMBER OF ORIGINAL VARIABLES
C 29-30 NTGC NUMBER OF TRANSGENERATION CARDS
C 34-35 NVA NUMBER OF VARIABLES ADDED BY TRANSGENERATION
C 39-40 NAIT ALTERNATE INPUT TAPE NUMBER
C 44-45 NSPC NUMBER OF SUBPROBLEM CARDS
C 48-49 NLV NUMBER OF LABELED VARIABLES
C 51-53 SDAM YES IF ST. DEV. AND MEANS TO BE PRINTED
C 55-57 COVP YES IF COVARIANCE MATRIX TO BE PRINTED
C 59-61 CORP YES IF CORRELATION MATRIX TO BE PRINTED
C 63-65 ZEROI YES IF ZERO REGRESSION INTERCEPT DESIRED
C 67-69 WIND NO IF ALT. INPUT TAPE NOT TO BE REWOUND
C 71-72 NVFC NUMBER OF VARIABLE FORMAT CARDS
C
C SUB-PROBLEM CARD FORMAT
C
C COL NAME
C 1- 6 WMAN SUBPRO
C 9-10 KDEP DEPENDENT VARIABLE NUMBER
C 13-15 MAXSTP MAXIMUM NUMBER OF STEPS
C 20-25 FINC F FOR INCLUSION
C 30-35 FOUT F FOR DELETION
C 40-45 TOL TOLERANCE
C 49-50 NVIP NUMBER OF VARIABLES TO BE PLOTTED
C 53-55 CDF YES IF CONTROL DELETE CARDS ARE INCLUDED
C 58-60 RESID YES IF RESIDUALS ARE TO BE PRINTED
C 63-65 SUMTAB YES IF SUMMARY TABLE DESIRED
C
COMMON NTGC,TRANS(100),KTRANS(3,100),X(81),A(50,50),IP,FINC,RESDF
1,FOUT,KAY,FLAG,N,NINCS,KDEP,IR,P(50,50),Q(50,50),XN,TOL,DF,LLL(10)
2,B(80),COL(11),PINT(11),QINT(11),RES(275),NVIP,ALPHA,RMAX,RMIN,
3RESID,IVPT(33),NVI,KEEP(5),IS
C
DIMENSION BNAME(80),ALBEL(80),ANAME(80),R(80),FE(80),NIEN(80)
DIMENSION KP(50,50),IQ(50,50),STDEV(80),C(80)
DIMENSION XMIN(80),XMAX(80),BES(5),NUSE(20)
DIMENSION XMEAN(80),D(80),F(80),TOLEV(80),INEN(80)
INTEGER KQ(80),JQ(80)
EQUIVALENCE (P,KP),(Q,IQ),(KTRANS(1),XMIN),(KTRANS(81),XMAX),
1(KTRANS(161),STDEV),(TRANS,C)
C
DOUBLE PRECISION XMAN,CODE,YMAN,ALBEL,WMAN,VMAN,Q009HL,Q010HL,ANAM
1E,BNAME,ENTER,PROBLM,SUBPRO,TRNGEN,CONDEL,DXPLTS,FINISH,DUM
DATA PROBLM,SUBPRO,TRNGEN,CONDEL,YES,DXPLTS,FINISH,XNO/'PROBLM',
1'SUBPRO','TRNGEN','CONDEL','YES','IDXPLT','FINISH',' NO'/
DATA Q009HL/6HREMOVE/
DATA Q010HL/6HENTERE/
DOUBLE PRECISION FIN,FOU,TO
8003 FORMAT('1 BMD02R - STEPWISE REGRESSION - REVISED ',
1'JUNE 26, 1969'/
22X,40HHEALTH SCIENCES COMPUTING FACILITY, UCLA//2X,12HPROBLEM CODE
317XA6/2X15HNUMBER OF CASES16XI4/2X28HNUMBER OF ORIGINAL VARIABLES,
45X,I2/2X,25HNUMBER OF VARIABLES ADDED,8 X,I2/2X,25HTOTAL NUMBER OF
5 VARIABLES, 8X,I2/2X,22HNUMBER OF SUB-PROBLEMS,11X,I2)
MAIT=5
CALL USAGE('BMD02R')
C
C READ PROBLEM CARD
C
1 READ (5,8001)XMAN,CODE,N,NOV,NTGC,NVA,NAIT,NSPC,NLV,SDAM,COVP,CORP
1,ZEROI,WIND,NVFC
8001 FORMAT(A6,3X,A6,1X,I4,5(3X,I2),2X,I2,5(1X,A3),1X,I2)
C
C CHECK PROBLEM CARD FOR VALID PARAMETERS
C
IF(XMAN .EQ. FINISH) GO TO 9001
2 IF(XMAN .NE. PROBLM) GO TO 9002
3 IP = NOV+NVA
WRITE (6,8003)CODE,N,NOV,NVA,IP,NSPC
IF(-NSPC)355,9005,9005
355 IF((NOV-1)*(NOV-81))4,9003,9003
4 IF((IP-1)*(IP-81))5,9003,9003
5 IF(NVFC.GT.0.AND.NVFC.LE.10)GO TO 106
WRITE(6,105)
NVFC=1
105 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIF
1IED, ASSUMED TO BE 1.)
106 IF(NTGC) 108,108,7
C
C READ TRANSGENERATION CARDS
7 DO 1000 I=1,NTGC
READ (5,8002)YMAN,(KTRANS(J,I),J=1,3),TRANS(I)
8002 FORMAT(A6,I3,I2,I3,F6.0)
C
C CHECK TRANSGENERATION PARAMETERS
C
IF(YMAN .NE. TRNGEN) GO TO 9006
7777 KIP=IP
IF(NVA)7780,7778,7778
7780 KIP=NOV
7778 IF(KTRANS(1,I)-KIP)7776,7776,9777
7776 IF(KTRANS(3,I)-KIP)7775,7775,9777
7775 IF(KTRANS(2,I)-24)7779,1000,9775
7779 IF((KTRANS(2,I)-19)*(KTRANS(2,I)-18))1000,9775,1000
9777 WRITE (6,8777)I
8777 FORMAT(///51H VARIABLE NUMBER SPECIFIED ON TRANSGENERATION CARD ,
1 I4,12H EXCEEDS P+Q )
NAIT=-24
GO TO 1000
9775 WRITE (6,8775)KTRANS(2,I)
8775 FORMAT(///29H ILLEGAL TRANSGENERATION CODE I3,10H SPECIFIED)
NAIT=-24
1000 CONTINUE
108 IF(NAIT)9999,107,8
107 NAIT=5
GO TO 9
8 IF(MAIT.NE.5.AND.MAIT.NE.NAIT)REWIND MAIT
MAIT=NAIT
IF(WIND.NE.XNO)REWIND NAIT
C
C READ LABEL CARDS
C
9 CALL RDLBL2(NLV,IP,ALBEL)
C
C READ VARIABLE FORMAT CARDS
C
10 NVFC=NVFC*18
READ (5,8004)(RES(I),I=1,NVFC)
8004 FORMAT(18A4)
WRITE(6,8055) (RES(I), I=1,NVFC)
8055 FORMAT(' THE VARIABLE FORMAT IS ',18A4/(1H ,25X,18A4))
C
C INITIALIZE ACCUMULATORS AND MATRIX A
C
XN=N
DO 3000 I=1,IP
XMEAN(I)=0.0
DO 3000 J=1,IP
A(I,J)=0.0
3000 CONTINUE
C
DO 4000 K=1,N
NINCS=K
READ (NAIT,RES)(X(L),L=1,NOV)
IF(NTGC) 11,11,12
12 CALL TRANGN
11 IF(ZEROI .NE. YES) GO TO 121
122 DO 4100 I=1,IP
XMEAN(I)=XMEAN(I)+X(I)
DO 4100 J=I,IP
A(I,J)=A(I,J)+X(I)*X(J)
4100 CONTINUE
XM=N
GO TO 4300
121 XK=K
DO 4201 I=1,IP
XMEAN(I)=XMEAN(I)+X(I)
4201 CONTINUE
DO 4200 I=1,IP
DO 4200 J=I,IP
IF((XK-1.0) .EQ. 0.0) GO TO 4200
A(I,J)=A(I,J)+(XK*X(J)-XMEAN(J))*(XK*X(I)-XMEAN(I))/(XK*(XK-1.0))
C
4200 CONTINUE
XM=N-1
C
C
4300 WRITE(2)(X(I),I=1,IP)
67890 FORMAT(20A4)
C
C
C
C
4000 CONTINUE
REWIND 2
C
C REPLACE XMEAN WITH MEAN VECTOR, A WITH COVARIANCE MATRIX,AND
C COMPUTE STANDARD DEVIATIONS
C
DO 5000 I=1,IP
XMEAN(I) = XMEAN(I) / XN
DO 5000 J=I,IP
A(I,J) = A(I,J) / XM
5000 CONTINUE
DO 5100 I=1,IP
STDEV(I)=SQRT(A(I,I))
5100 CONTINUE
C
C IF ZERO REGRESSION INTERCEPT IS DESIRED, PRINT WARNING.
C
IF(ZEROI .NE. YES) GO TO 5110
5105 WRITE (6,5120)
5120 FORMAT(1H0,6X, 92HWARNING...WHEN THE ZERO REGRESSION INTERCEPT IS
1CHOSEN, ALL VARIANCES, COVARIANCES, STANDARD/17X84HDEVIATIONS AND
2CORRELATIONS ARE COMPUTED ABOUT THE ORIGIN RATHER THAN ABOUT THE M
3EAN/17X,34H(SEE PROGRAM WRITEUP - SECTION 4).)
C
C WRITE OUT MEANS AND STANDARD DEVIATIONS IF REQUESTED
C
5110 IF(SDAM .NE. YES) GO TO 15
14 WRITE (6,8005)
8005 FORMAT(///// 4X,8HVARIABLE,8X,4HMEAN,7X,18HSTANDARD DEVIATION)
C
16 DO 9000 I=1,IP
WRITE (6,8006)ALBEL(I),I,XMEAN(I),STDEV(I)
8006 FORMAT(3X,A6,I3,2X,F14.5,4X,F14.5)
9000 CONTINUE
C
C
C
C
C
C
C PRINT COVARIANCE MATRIX IF REQUESTED
C
15 IF(COVP .NE. YES) GO TO 19
18 WRITE (6,8008)
8008 FORMAT(19H1 COVARIANCE MATRIX)
CALL AOUT
C
C REPLACE UPPER DIAGONAL SECTION OF MATRIX WITH CORRELATION MATRIX
C
19 DO 11000 I=1,IP
DO 11000 J=I,IP
AAA = STDEV(I) * STDEV(J)
IF(AAA .EQ. 0.0) A(I,J) = 0.0
IF(AAA .NE. 0.0)
1A(I,J) = A(I,J) / AAA
A(J,I)=A(I,J)
11000 CONTINUE
C
C PRINT CORRELATION MATRIX IF REQUESTED
C
IF(CORP .NE. YES) GO TO 824
23 WRITE (6,8009)
8009 FORMAT(20H1 CORRELATION MATRIX)
CALL AOUT
824 IF(ZEROI .EQ. YES) GO TO 242
241 XN=XN-1.0
242 DO 13000 M=1,NSPC
C
C RESTORE THE CORRELATION MATRIX
C
DO 23000 I=1,IP
A(I,I)=1.0
K=I+1
DO 23000 J=K,IP
A(I,J)=A(J,I)
23000 CONTINUE
C
C READ SUB PROBLEM CARD
C
READ(5,8010)WMAN,KDEP,MAXSTP,FIN,FOU,TO,NVIP,CDF,RESID,SUMTAB
8010 FORMAT(A6,2X,I2,2X,I3,3(4X,A6),3X,I2,3(2X,A3))
IF(WMAN .NE. SUBPRO) GO TO 9009
FINC=0.01
CALL ATOF(FIN,6,FINC)
FOUT=0.005
CALL ATOF(FOU,6,FOUT)
TOL=0.001
CALL ATOF(TO,6,TOL)
331 IF(MAXSTP) 332,332,34
332 MAXSTP=IP *2
34 DO 14000 I=1,IP
C(I)=0.0
14000 CONTINUE
WRITE (6,8034)M,KDEP,MAXSTP,FINC,FOUT,TOL
8034 FORMAT(2H1 , 10HSUB-PROBLM,I5/3X,18HDEPENDENT VARIABLE,11X,I2/3X,
123HMAXIMUM NUMBER OF STEPS,5X,I3/3X,21HF-LEVEL FOR INCLUSION,4X,
2F8.6/3X,20HF-LEVEL FOR DELETION,5X,F8.6/3X,15HTOLERANCE LEVEL,10X,
3F8.6)
IF(CDF .NE. YES) GO TO 36
35 IF(IP -66) 351,351,352
351 READ (5,8011)VMAN,(C(I),I=1,IP)
IF(VMAN .NE. CONDEL) GO TO 9010
GO TO 36
352 READ (5,8011)VMAN,(C(I),I=1,66),DUM,(C(J),J=67,IP)
8011 FORMAT(A6,66F1.0)
361 IF(VMAN.NE.CONDEL .OR. DUM.NE.CONDEL) GO TO 9010
36 DO 15000 I=1,IP
IF( C(I)) 37,37,15000
37 C(I)=2.0
15000 CONTINUE
C(KDEP)=1.0
DF=0.0
LKL=0
L=0
39 L=L+1
C CALL SUBROUTINE TO ENTER VARIABLE,CALCULATE VALUES TO BE PRINTED
IF ((DF-XN).EQ.0.0) GO TO 1117
CALL STEPRG
IF(FLAG) 391,1117,392
1117 WRITE (6,9118)
9118 FORMAT(//58H F-LEVEL OR TOLERANCE INSUFFICIENT FOR FURTHER COMPUTA
1TION)
GO TO 117
391 ENTER=(+Q009HL)
GO TO 393
392 ENTER=(+Q010HL)
393 RESDF=XN-DF
RESSS =XN*(STDEV(KDEP)**2)*A(KDEP,KDEP)
RESMS = 0.0
IF(RESDF .NE. 0.0)
1RESMS = RESSS / RESDF
REGDF=DF
REGSS=XN*(STDEV(KDEP)**2)-RESSS
REGMS = 0.0
IF(REGDF .NE. 0.0)
1REGMS = REGSS / REGDF
FRATIO = 0.0
STERR = 0.0
IF(RESMS .GT. 0.0) FRATIO = REGMS / RESMS
IF(RESMS .LT. (ABS(XMEAN(KDEP))*1.E-6)) RESMS = 0.0
IF(RESMS .GT. 0.0) STERR = SQRT(RESMS)
HOLD = 1.0 - A(KDEP,KDEP)
XMULTR = 0.0
IF(HOLD .GT. 0.0)
1XMULTR = SQRT(HOLD)
IDF=DF
IRDF=RESDF
WRITE (6,8012)L,ENTER,KAY,XMULTR,STERR,IDF,REGSS,REGMS,FRATIO,IRDF
1,RESSS,RESMS
8012 FORMAT(////4X,11HSTEP NUMBER,2X,I3/4X,9HVARIABLE ,A6,2HD ,I4//4X,
110HMULTIPLE R,12X,F 9.4/4X,18HSTD. ERROR OF EST.,F13.4 // 4X,
220HANALYSIS OF VARIANCE/27X,2HDF,4X,14HSUM OF SQUARES,4X,11HMEAN S
3QUARE,4X,7HF RATIO/12X,10HREGRESSION,3X,I4,F16.3,F14.3,F12.3
4/12X,8HRESIDUAL,5X,I4,F16.3,F14.3)
C
C A VARIABLE IS IN THE EQUATION IF C(I) IS LESS THAN OR EQUAL TO 0.0
C
NVI=0
NVO=0
ALPHA=XMEAN(KDEP)
DO 16000 I=1,IP
IF(I-KDEP) 441,16000,441
441 IF(C(I)) 41,41,43
C
C COMPUTE MULTIPLE REGRESSION EQUATION COEFFICIENTS,STD.ERROR,
C AND F TO REMOVE, FOR VARIABLES IN THE REGRESSION
C
41 NVI=NVI+1
B(NVI) = 0.0
IF(STDEV(I) .NE. 0.0)
1B(NVI)=STDEV(KDEP)*AF(I,KDEP)/STDEV(I)
D(NVI) = 0.0
IF(STDEV(I).NE.0.0 .AND. A(I,I).LT.0.0)
1D(NVI)=(STERR/STDEV(I))*SQRT(-A(I,I)/XN)
F(NVI) = 0.0
IF(D(NVI) .NE. 0.0)
1F(NVI)=(B(NVI)/D(NVI))**2
ALPHA=ALPHA-B(NVI)*XMEAN(I)
ANAME(NVI)=ALBEL(I)
KQ(NVI)=C(I)+9.0
INEN(NVI)=I
GO TO 16001
C
C A VARIABLE IS OUT OF THE REGRESSION IF C(I) IS GREATER THAN OR
C EQUAL TO 1
C
C
C
C COMPUTE PARTIAL CORRELATION COEFFICIENTS, TOLERANCE, AND
C F TO ENTER FOR VARIABLES OUT OF THE REGRESSION
C
43 NVO=NVO+1
BNAME(NVO)=ALBEL(I)
JQ(NVO)=C(I)
NIEN(NVO)=I
TOLEV(NVO)= A(I,I)
R(NVO) = 0.0
FE(NVO) = 0.0
STORE = A(I,I) * A(KDEP,KDEP)
IF(STORE .LE. 0.0) GO TO 16001
R(NVO) = AF(I,KDEP) / SQRT(STORE)
STORE = A(I,I)*A(KDEP,KDEP)-(AF(I,KDEP)**2)
IF(STORE.GT.0.0 .AND. (RESDF-1.0).GT.0.0)
1FE(NVO)=((AF(I,KDEP)**2)*(RESDF-1.0))/ STORE
16001 IF(I-KAY) 16000,16002,16000
16002 IF(C(I)) 16003,16003,16004
16003 FKAY=F(NVI)
GO TO 16000
16004 FKAY=FE(NVO)
16000 CONTINUE
IF(ZEROI .NE. YES) GO TO 443
442 ALPHA=0.0
C
C WRITE HEADING FOR COEFFICIENTS
C
443 WRITE(6,8013)ALPHA
8013 FORMAT(/60X,'.'/21X,'VARIABLES IN EQUATION',18X,'.',19X,'VARIABLES
1 NOT IN EQUATION'/60X,'.'/6X,'VARIABLE',6X,'COEFFICIENT STD. ERRO
2R F TO REMOVE . VARIABLE PARTIAL CORR. TOLERANCE
3 F TO ENTER'/2(60X,'.'/),6X,'(CONSTANT',5X,F11.5,' )',27X,'.')
C
WRITE(1)L,KAY,FLAG,XMULTR,FKAY,NVI
LKL=LKL+1
C
C PRINT THE REGRESSION ANALYSIS TABLE
C
C
C
C
C
C
IF(FLAG.GT.0.0)CALL WHICHX(KAY,NVI,IS,KEEP)
473 NGO=0
44 IF(NVO)46,46,45
45 IF(NVI.LE.0)GO TO 56
47 LNV=MIN0(NVI,NVO)
C
C NVO AND NVI BOTH POSITIVE,PRINT BOTH SIDES OF TABLE
C
C
49 DO 17000 I=1,LNV
WRITE(6,8014)ANAME(I),INEN(I),B(I),D(I),F(I),KQ(I),BNAME(I),NIEN(I
1),R(I),TOLEV(I),FE(I),JQ(I)
8014 FORMAT(5X,A6,1X,I2,1X,F16.5,1X,F11.5,1X,F11.4,' (',I1,') . ',A6
1,1X,I2,1X,F15.5,1X,F13.4,1X,F12.4,' (',I1,')')
17000 CONTINUE
C
C
C
C
C
C
52 NVI=NVI-LNV
NVO=NVO-LNV
NGO=LNV
GO TO 44
C
C NVO ZERO, PRINT LEFT SIDE ONLY
C
46 IF(NVI.LE.0)GO TO 55
C
53 DO 19000 I=1,NVI
II=I+NGO
WRITE(6,8016)ANAME(II),INEN(II),B(II),D(II),F(II),KQ(II)
8016 FORMAT(5X,A6,1X,I2,1X,F16.5,1X,F11.5,1X,F11.4,' (',I1,') .')
19000 CONTINUE
GO TO 55
C
C
C
C
C
C
C
C NVI ZERO,PRINT RIGHT SIDE ONLY
C
C
56 DO 21000 I=1,NVO
II= I+NGO
WRITE(6,8018)BNAME(II),NIEN(II),R(II),TOLEV(II),FE(II),JQ(II)
8018 FORMAT(60X,'. ',A6,1X,I2,1X,F15.5,1X,F13.4,1X,F12.4,' (',I1,')'
1)
21000 CONTINUE
C
C
C
C
C
C
55 IF(L-MAXSTP) 39 ,552,552
552 WRITE (6,8036)
8036 FORMAT(23H SPECIFIED STEP REACHED )
117 ENDFILE 1
REWIND 1
IF(SUMTAB .NE. YES) GO TO 9605
9606 IF(LKL) 9621,9621,9622
9621 WRITE (6,9632)
9632 FORMAT(////49H0SUMMARY TABLE OMITTED DUE TO LACK OF INFORMATION )
GO TO 9605
9622 WRITE (6,9602)
9602 FORMAT(15H1 SUMMARY TABLE// 5X,4HSTEP,16X,8HVARIABLE,15X,8HMULTIPL
1E,18X,8HINCREASE,10X,10HF VALUE TO,5X,21HNUMBER OF INDEPENDENT/4X,
26HNUMBER,10X,7HENTERED,2X,7HREMOVED,9X,1HR,11X,3HRSQ,15X,6HIN RSQ,
39X,15HENTER OR REMOVE,4X,18HVARIABLES INCLUDED//)
R1SQ=0.0
9609 DO 23310 I=1,LKL
READ(1)LMN,KAY,FLAG,XMULTR,FKAY,NVI
RSQ=XMULTR**2
RSQI=RSQ-R1SQ
R1SQ=RSQ
C
C
C
C
C
C
C
C
9611 IF(FLAG) 23314,23310,23313
23313 WRITE (6,9631)LMN,ALBEL(KAY),KAY,XMULTR,RSQ,RSQI,FKAY, NVI
9631 FORMAT(5X,I3,10X,A6,1X,I2,14X,F9.4,F13.4,6X,F11.4,1X,F19.4,15X,I2)
GO TO 23310
23314 WRITE (6,9612)LMN,ALBEL(KAY),KAY,XMULTR,RSQ,RSQI,FKAY, NVI
9612 FORMAT(5X,I3,20X,A6,1X,I2,4X,F9.4,F13.4,6X,F11.4,1X,F19.4,15X,I2)
23310 CONTINUE
9605 REWIND 1
IF(NVIP)8888,8888,75
8888 IF(RESID.EQ.YES)GO TO 58
GO TO 13000
C
C READ INXPLT CARD
C
75 IF(NVIP .GT. 30) GO TO 9012
READ (5,8032)WMAN,(IVPT(J), J=1,NVIP)
8032 FORMAT(A6,33I2)
IF(WMAN .NE. DXPLTS) GO TO 9011
C
755 DO 31000 K=1,NVIP
IF(IVPT(K)-IP) 31000,31000,9011
31000 CONTINUE
4405 DO 20100 J=1,NVIP
XMIN(J)=+999999.9
XMAX(J)=-999999.9
20100 CONTINUE
RMIN=999999.9
RMAX=-999999.9
58 CALL RESIDS
13000 CONTINUE
GO TO 1
9001 WRITE (6,8020)
8020 FORMAT(///24H FINISH CARD ENCOUNTERED)
9999 WRITE (6,8021)
8021 FORMAT(19H PROGRAM TERMINATED)
2210 STOP
9002 WRITE (6,8022)
8022 FORMAT(43H NEITHER PROBLM NOR FINISH CARD ENCOUNTERED)
GO TO 9999
9003 WRITE (6,8023)
8023 FORMAT(50H0NUMBER OF VARIABLES, P OR P+Q, OUTSIDE OF LIMITS.)
GO TO 9999
9004 WRITE (6,8024)
8024 FORMAT(37H CARD INCORRECTLY PUNCHED OR MISSING.)
GO TO 9999
9005 WRITE (6,8025)
8025 FORMAT(31H NO SUB-PROBLEM CARD SPECIFIED.)
GO TO 9999
9006 WRITE (6,8026)
8026 FORMAT(16H0TRANSGENERATION)
GO TO 9004
9009 WRITE (6,8029)
8029 FORMAT(12H0SUB-PROBLEM)
GO TO 9004
9010 WRITE (6,8030)
8030 FORMAT(15H0CONTROL-DELETE)
GO TO 9004
9011 WRITE (6,8033)
8033 FORMAT(11H0INDEX-PLOT)
GO TO 9004
9012 WRITE(6,8035) NVIP
8035 FORMAT('0HTE NUMBER OF VARIABLES SPECIFIED FOR THE INDEX-PLOT CARD
1NUST NOT EXCEED 30,',I11,' IS TOO LARGE.')
GO TO 9999
END
FUNCTION AF(I,J)
C FUNCTION AF FOR BMD02R MAY 2, 1966
DIMENSION KP(50,50),IQ(50,50),STDEV(80),C(80)
COMMON NTGC,TRANS(100),KTRANS(3,100),X(81),A(50,50),IP,FINC,RESDF
1,FOUT,KAY,FLAG,N,NINCS,KDEP,IR,P(50,50),Q(50,50),XN,TOL,DF,LLL(10)
2,B(80),COL(11),PINT(11),QINT(11),RES(275),NVIP,ALPHA,RMAX,RMIN,
3RESID,IVPT(33),NVI,KEEP(5),IS
C
EQUIVALENCE (P,KP),(Q,IQ),(KTRANS(81),STDEV),(TRANS,C)
KKG=MIN0(I,J)
LLG=MAX0(I,J)
AF=A(KKG,LLG)
RETURN
END
SUBROUTINE AOUT
C SUBROUTINE AOUT FOR BMD02R MAY 2, 1966
COMMON NTGC,TRANS(100),KTRANS(3,100),X(81),A(50,50),IP,FINC,RESDF
1,FOUT,KAY,FLAG,N,NINCS,KDEP,IR,P(50,50),Q(50,50),XN,TOL,DF,LLL(10)
2,B(80),COL(11),PINT(11),QINT(11),RES(275),NVIP,ALPHA,RMAX,RMIN,
3RESID,IVPT(33),NVI,KEEP(5),IS
C
DIMENSION FMT1(4),FMT2(4),AI(9)
DIMENSION KP(50,50),IQ(50,50),STDEV(80),C(80)
EQUIVALENCE (P,KP),(Q,IQ),(KTRANS(81),STDEV),(TRANS,C)
DOUBLE PRECISION FMT1,FMT2,AI,FIRST,TOP,SKIP
C THE FOLLOWING DATA STATEMENTS ARE FORMATS FOR THE CORRELATION
C COEFFICIENTS MATRIX.
C
DATA FMT1/' ','H VARIABLE',',(I7,9I11)',') '/,TOP
1,SKIP/' (1H1,9',' (1H0,9'/
DATA FMT2/'(5X,I2, ',' ','F11.3)) ',' '/,
1FIRST/' 2X,(10'/
DATA AI/' 13X,(9',' 24X,(8',' 35X,(7',' 46X,(6',' 57X,(5',
1' 68X,(4',' 79X,(3',' 90X,(2',' 101X,('/
C
MN=0
KK=0
DO 1000 I=1,IP,10
KK=KK+1
NRTEN=I
M=KK*10-IP
IF(M)1,1,2
1 M=9
MN=(M+1)*KK
GO TO 3
2 M=9-M
MN=MN+M+1
3 MM=M+1
DO 2000 LL=1,MM
LLL(LL)=LL+(KK-1)*10
2000 CONTINUE
IF(KK-1) 4,4,5
4 KTOP=0
FMT1(1)=SKIP
GO TO 6
5 KTOP=1
FMT1(1)=TOP
6 WRITE (6,FMT1)(LLL(LK),LK=1,MM)
WRITE(6,9901)
9901 FORMAT(3X,6HNUMBER/)
FMT2(2)=FIRST
K=NRTEN
DO 3000 J=1,NRTEN
WRITE (6,FMT2)J,(A(J,L),L=K,MN)
3000 CONTINUE
NN=K
ID=NRTEN
IF(M)1000,1000,5000
5000 DO 4000 JK=1,M
FMT2(2)=AI(JK)
NN=NN+1
ID=ID+1
WRITE (6,FMT2)ID,(A(ID,L),L=NN,MN)
4000 CONTINUE
1000 CONTINUE
RETURN
END
SUBROUTINE WHICHX(INDEX,NVI,IS,KEEP)
DIMENSION KEEP(5)
IF(NVI.GT.1)GO TO 10
IS=0
DO 5 I=1,5
5 KEEP(I)=0
10 DO 20 I=1,5
IF(KEEP(I).NE.0)GO TO 20
KEEP(I)=INDEX
IS=IS+1
GO TO 30
20 CONTINUE
30 RETURN
END
SUBROUTINE RDLBL2(NLBVAR,NVAR,ARRAY)
C SUBROUTINE RDLBL2 FOR BMD02R MAY 2, 1966
C SUBROUTINE TO READ IN LABELS CARDS, STORE THEM IN ARRAY,
C AND SUBSTITUTE BLANKS FOR UNLABELED VARIABLES
C NVAR IS TOTAL NUMBER OF VARIABLES
C NLBVAR IS NUMBER OF LABELED VARIABLES EXPECTED
C
DIMENSION ARRAY(1),DUMY(7),IDUM(7)
DOUBLE PRECISION ARRAY,BLANKS,DUMY,TEST,ALABEL
DATA ALABEL/'LABELS'/,BLANKS/' '/
C BLANK VARIABLES
DO 1 I=1,NVAR
1 ARRAY(I)=BLANKS
C IF NO LABELS, RETURN
IF(NLBVAR) 9,9,2
2 N=0
C READ 1 LABELS CARD
20 READ (5,3) TEST,(IDUM(J),DUMY(J),J=1,7)
3 FORMAT(A6,7(I4,A6))
C TEST FOR 'LABELS' IN FIRST 6 COLS.
IF(TEST.EQ.ALABEL)GO TO 6
C ERROR--PRINT MESSAGE AND QUIT
4 WRITE (6,5)
5 FORMAT(36H0LABELS CARD NOT FOUND WHEN EXPECTED)
CALL EXIT
STOP
C EXAMINE 7 FIELDS
6 DO 8 J=1,7
K=IDUM(J)
C TEST INDEX. IF 0, IGNORE. IF ILLEGAL, PRINT MESSAGE AND
C IGNORE EXCEPT TO COUNT
IF(K) 11,8,10
10 IF(K-NVAR) 7,7,11
11 WRITE (6,12)K,DUMY(J)
12 FORMAT(18H0LABELS CARD INDEX,I7,18H INCORRECT. LABEL ,A6,9H IGNORE
1D.)
GO TO 13
C MOVE LABEL TO ARRAY
7 ARRAY(K)=DUMY(J)
C STEP NUMBER OF VARIABLES
13 N=N+1
C TEST FOR END. IF END, RETURN. IF NOT, SCAN OTHER FIELDS.
IF(N-NLBVAR) 8,9,9
8 CONTINUE
GO TO 20
9 RETURN
END
SUBROUTINE RESIDS
C SUBROUTINE RESIDS FOR BMD02R MAY 2, 1966
C THIS SUBROUTINE COMPUTES THE RESIDUALS FOR THE REGRESSION.
COMMON NTGC,TRANS(100),KTRANS(3,100),X(81),A(50,50),IP,FINC,RESDF
1,FOUT,KAY,FLAG,N,NINCS,KDEP,IR,P(50,50),Q(50,50),XN,TOL,DF,LLL(10)
2,B(80),COL(11),PINT(11),QINT(11),PES(275),NVIP,ALPHA,RMAX,RMIN,
3RESID,IVPT(33),NVI,KEEP(5),IS
C
DIMENSION FMT1(6),FMT2(6),FMT3(8),FMT4(4),FMT5(5),FMT6(4)
DIMENSION KP(50,50),IQ(50,50),STDEV(80),C(80),XMIN(80),XMAX(80)
EQUIVALENCE (P,KP),(Q,IQ),(KTRANS(1),XMIN),(KTRANS(81),XMAX),
1(KTRANS(161),STDEV),(TRANS,C)
DOUBLE PRECISION FMT1,FMT2,FMT3,FMT4,FMT5,FMT6,SKPONE,SKPTWO,PREON
1 E,PRETWO,ONEPRE,TWOPRE,SECONE,SECTWO,BEFONE,BEFTWO,Q011HL,Q012HL
DATA DOT,YES/'.','YES'/
C THE FOLLOWING DATA STATEMENTS ARE FORMAT STATEMENTS FOR THE
C PLOT OF THE RESIDUALS.
C
DATA FMT1/' ','(26HPLOT O','F RESIDUAL','S (Y-AXIS)',
1',34X,2H..,','3X )) '/,PREONE,PRETWO/'(2H1 1','(2H1 2'/
DATA FMT2/' ','(14H VS. V','ARIABLE ,I','3,9H (X-AX',
1'IS),34X,2H','.. ,3X)) '/,SKPONE,SKPTWO/'(2X, 1','(2X, 2'/
DATA FMT3/' ','6F10.3,2','H..,1X)/',' ',' F7.3,4',
1'F10.3,5X',',2H..,1X',')) '/,ONEPRE,TWOPRE,SECONE,SECTWO/
2'(1(2X,','(2(2X,','1(10X,','2(10X,'/
DATA FMT4/' ','6X,51A1,','3X,2H..,','1X)) '/
DATA FMT5/' ','1X,F6.2,','2H .,50A','1, 3X2H..',' ,1X)) '/
1,BEFONE,BEFTWO/'(1( ','(2( '/
DATA FMT6/' ','8X,1H.,5','0A1,3X,2','H..,1X))'/
DATA Q011HL/6H /
DATA Q012HL/6H* /
YMIN=999999.9
YMAX=-999999.9
IF(RESID.EQ.YES)WRITE(6,406)
406 FORMAT('1 LIST OF RESIDUALS')
C
DO 24000 I=1,N
READ(2)(X(L),L=1,IP)
67890 FORMAT(20A4)
C
C
SUMB=0.0
NVI=0
DO 25000 J=1,IP
IF(C(J)) 581,581,25000
581 NVI=NVI+1
582 SUMB=SUMB+B(NVI)*X(J)
25000 CONTINUE
YHAT=ALPHA+SUMB
RES=X(KDEP)-YHAT
IF(NVIP.LE.0)GO TO 3030
DO 20200 L=1,NVIP
MM=IVPT(L)
IF(XMIN(L)-X(MM)) 81,81,80
80 XMIN(L)=X(MM)
81 IF(XMAX(L)-X(MM)) 97,20200,20200
97 XMAX(L)=X(MM)
20200 CONTINUE
RMAX=AMAX1(RMAX,RES)
RMIN=AMIN1(RMIN,RES)
YMAX=AMAX1(YMAX,YHAT)
YMIN=AMIN1(YMIN,YHAT)
IF(RESID.NE.YES)GO TO 24000
3030 IF(MOD(I,55).NE.1)GO TO 402
IF(I.NE.1)WRITE(6,410)
410 FORMAT('1')
WRITE(6,407)KDEP,(Q011HL,KEEP(L),L=1,IS)
407 FORMAT(/' CASE',9X,'Y',14X,'Y',11X/' NUMBER X(',I2,')',9X,'C
1OMPUTED',7X,'RESIDUAL',7X,5(A1,'X(',I2,')',9X))
WRITE(6,409)
409 FORMAT(' ')
402 WRITE(6,408)I,X(KDEP),YHAT,RES,(X(KEEP(L)),L=1,IS)
408 FORMAT(1X,I4,8(1X,F14.4))
24000 CONTINUE
REWIND 2
IF(NVIP.LE.0)RETURN
SRS=(RMAX-RMIN)/49.0
DO 20300 I=1,11
AI=1+5*(I-1)
COL(I)=RMIN+SRS*(AI-1.0)
20300 CONTINUE
IIX=0
NVIP=NVIP+1
IVPT(NVIP)=81
XMAX(NVIP)=YMAX
XMIN(NVIP)=YMIN
4409 DO 20400 I=1,NVIP,2
II=IVPT(I)
IF(I+1-NVIP) 98,98,118
118 KKK=1
C THE FOLLOWING FMT- STATEMENTS ARE FOR A SINGLE PLOT ON THE PAGE
FMT1(1)=PREONE
FMT2(1)=SKPONE
FMT3(1)=ONEPRE
FMT3(4)=SECONE
FMT4(1)=ONEPRE
FMT5(1)=BEFONE
FMT6(1)=BEFONE
GO TO 99
98 KKK=2
C THE FOLLOWING FMT- STATEMENTS ARE FOR TWO PLOTS ON THE PAGE
FMT1(1)=PRETWO
FMT2(1)=SKPTWO
FMT3(1)=TWOPRE
FMT3(4)=SECTWO
FMT4(1)=TWOPRE
FMT5(1)=BEFTWO
FMT6(1)=BEFTWO
JJ=IVPT(I+1)
J1=I+1
99 SPI=((XMAX(I )-XMIN(I ))/49.0)
IF(KKK-1) 101,101,102
102 SQI=((XMAX(J1)-XMIN(J1))/49.0)
101 DO 20500 J=1,11
AJ=1+5*(J-1)
PINT(J)=XMIN(I )+SPI*(AJ-1.0)
IF(KKK-1) 20500,20500,104
104 QINT(J)=XMIN(J1)+SQI*(AJ-1.0)
20500 CONTINUE
DO 20600 K=1,50
DO 20600 J=1,50
KP(K,J)=IIX
IQ(K,J)=IIX
20600 CONTINUE
C
C
C
DO 20700 J=1,N
READ(2)(X(L),L=1,IP)
C
C
IR = 1
C
C
NVI=0
RESS=0.0
DO 450JPJ=1,IP
IF(C(JPJ))451,451,450
451 NVI=NVI+1
RESS=RESS+B(NVI)*X(JPJ)
450 CONTINUE
YHAT=RESS+ALPHA
RESS=X(KDEP)-YHAT
IF(I.GE.NVIP-1)X(81)=YHAT
IF(SPI.NE.0.0)IR=(X(II)-XMIN(I))/SPI+1.5
IRES = 1
IF(SRS .NE. 0.0)
1IRES=((RESS-RMIN)/SRS)+1.5
KP(IRES,IR)= KP(IRES,IR)+1
IF(KKK-1) 20700,20700,109
109 JQ = 1
IF(SQI .NE. 0.0)
1JQ=((X(JJ)-XMIN(J1))/SQI)+1.5
IQ(IRES,JQ)=IQ(IRES,JQ)+1
20700 CONTINUE
REWIND 2
WRITE (6,FMT1)
IF(KKK-1) 116,116,110
116 IF(II.LT.81)WRITE(6,FMT2)II
IF(II.EQ.81)WRITE(6,105)
105 FORMAT(' VS. COMPUTED Y (X-AXIS)',34X,'..')
GO TO 111
110 IF(JJ.LT.81)WRITE(6,FMT2)II,JJ
IF(JJ.EQ.81)WRITE(6,100)II
100 FORMAT(' VS. VARIABLE ',I3,' (X-AXIS)',34X,'.. VS. COMPUTED Y
1 (X-AXIS)',34X,'..')
111 XX=(+Q011HL)
XY=(+Q012HL)
WRITE (6,9961)
9961 FORMAT(1H )
IF(KKK-1) 9613,9613,9614
9613 WRITE (6,FMT3)(PINT(K),K=1,11,2),(PINT(L),L=2,11,2)
GO TO 9615
9614 WRITE (6,FMT3)(PINT(K),K=1,11,2),(QINT(L),L=1,11,2), (PINT(M),M=2,
111,2),(QINT(J),J=2,11,2)
9615 IF(KKK-1) 9401,9401,9402
9401 MNMN=51
GO TO 9403
9402 MNMN=102
9403 WRITE (6,FMT4)(DOT,J=1,MNMN)
KLN=0
KLM=5
DO 20800 K=1,50
DO 20900 J=1,50
IF(KP(K,J)) 82,82,83
82 P(K,J)=XX
GO TO 86
83 IF(KP(K,J)-10) 84,85,85
C LEFT ADJUST THE INTEGER IN KP(K,J) WHICH IS LESS THAN 10
84 KP(K,J) = INUMB(KP(K,J))
GO TO 86
85 P(K,J)=XY
86 IF(KKK-1) 20900,20900,112
112 IF(IQ(K,J)) 87,87,88
87 Q(K,J)=XX
GO TO 20900
88 IF(IQ(K,J)-10) 89,91,91
C LEFT ADJUST THE INTEGER IN IQ(K,J) WHICH IS LESS THAN 10
89 IQ(K,J) = INUMB(IQ(K,J))
GO TO 20900
91 Q(K,J)=XY
20900 CONTINUE
KLM=KLM-1
IF(KLM-4) 93,94,94
93 IF(KLM) 95,95,96
94 KLN=KLN+1
IF(KKK-1) 9551,9551,9552
9551 WRITE (6,FMT5)COL(KLN),(P(K,J),J=1,50)
GO TO 20800
9552 WRITE (6,FMT5)COL(KLN),(P(K,J),J=1,50),COL(KLN),(Q(K,L),L=1,50)
GO TO 20800
95 KLM=5
96 IF(KKK-1) 9661,9661,9662
9661 WRITE (6,FMT6)(P(K,J),J=1,50)
GO TO 20800
9662 WRITE (6,FMT6)(P(K,J),J=1,50),(Q(K,L),L=1,50)
20800 CONTINUE
WRITE (6,FMT4)(DOT,J=1,MNMN)
IF(KKK-1) 113,113,114
113 WRITE (6,FMT3)(PINT(K),K=1,11,2),(PINT(L),L=2,11,2)
GO TO 20401
114 WRITE (6,FMT3)(PINT(K),K=1,11,2),(QINT(L),L=1,11,2),(PINT(M),M=2,1
11,2),(QINT(J),J=2,11,2)
20401 REWIND 2
20400 CONTINUE
RETURN
END
SUBROUTINE STEPRG
C SUBROUTINE STEPRG FOR BMD02R MAY 2, 1966
COMMON NTGC,TRANS(100),KTRANS(3,100),X(81),A(50,50),IP,FINC,RESDF
1,FOUT,KAY,FLAG,N,NINCS,KDEP,IR,P(50,50),Q(50,50),XN,TOL,DF,LLL(10)
2,B(80),COL(11),PINT(11),QINT(11),RES(275),NVIP,ALPHA,RMAX,RMIN,
3RESID,IVPT(33),NVI,KEEP(5),IS
C
DIMENSION KP(50,50),IQ(50,50),STDEV(80),C(80)
EQUIVALENCE (P,KP),(Q,IQ),(KTRANS(81),STDEV),(TRANS,C)
CC=A(KDEP,KDEP)
AA=XN-DF
BB=FINC+AA-1.0
VIN=0.0
IF(BB.NE.0.0)VIN=FINC*CC/BB+2.0
VOUT=0.0
IF(AA.NE.0.0)VOUT=FOUT*CC/AA-7.0
VMIN= 9999.9
VMAX=0.0
KMIN=0
KMAX=0
DO 1000 K=1,IP
IF(C(K)-1.0) 9,1000,10
9 VSUBK = C(K)
IF(A(K,K) .NE. 0.0)
1VSUBK = C(K) - (AF(K,KDEP)**2) / A(K,K)
IF(VMIN-VSUBK) 1000,1000,1
1 VMIN=VSUBK
KMIN=K
GO TO 1000
10 IF(A(K,K)-TOL) 1000,8,8
8 VSUBK = C(K)
IF(A(K,K) .NE. 0.0)
1VSUBK=C(K)+AF(K,KDEP)**2/A(K,K)
IF(VSUBK-VMAX) 1000,1000,4
4 IF(XN - DF - 3.0 + C(K)) 1000,1000,45
45 VMAX=VSUBK
KMAX=K
1000 CONTINUE
IF(VOUT-VMIN) 2,2,3
3 C(KMIN)=C(KMIN)+9.0
KAY=KMIN
FLAG= -1.0
GO TO 7
2 IF(CC)6,6,25
25 IF(VMAX - VIN) 6,5,5
5 IF(KMAX)6,6,11
11 C(KMAX)=C(KMAX)-9.0
KAY=KMAX
FLAG=1.0
7 CALL STEP
DF=DF+FLAG
RETURN
6 FLAG= 0.0
RETURN
END
SUBROUTINE STEP
C SUBROUTINE STEP FOR BMD02R MAY 2, 1966
DIMENSION KP(50,50),IQ(50,50),STDEV(80),C(80)
DIMENSION U(81)
COMMON NTGC,TRANS(100),KTRANS(3,100),X(81),A(50,50),IP,FINC,RESDF
1,FOUT,KAY,FLAG,N,NINCS,KDEP,IR,P(50,50),Q(50,50),XN,TOL,DF,LLL(10)
2,B(80),COL(11),PINT(11),QINT(11),RES(275),NVIP,ALPHA,RMAX,RMIN,
3RESID,IVPT(33),NVI,KEEP(5),IS
C
EQUIVALENCE (P,KP),(Q,IQ),(KTRANS(81),STDEV),(TRANS,C)
KAY1=KAY-1
KAY2=KAY+1
XAY3=A(KAY,KAY)
IF(KAY1) 3,3,4
4 DO 1000 I=1,KAY1
U(I)=A(I,KAY)
A(I,KAY)=0.0
1000 CONTINUE
3 U(KAY)=-FLAG
A(KAY,KAY)=0.0
IF(KAY2-IP ) 1,1,2
1 DO 2000 I=KAY2,IP
U(I)=A(KAY,I)
A(KAY,I)=0.0
2000 CONTINUE
2 DO 3000 I=1,IP
DO 3000 J=I,IP
IF(XAY3 .NE. 0.0)
1A(I,J)=A(I,J)-(U(I)*U(J))/XAY3
3000 CONTINUE
RETURN
END
SUBROUTINE TRANGN
C SUBROUTINE TRANGN FOR BMD02R MAY 2, 1966
COMMON NTGC,TRANS(100),KTRANS(3,100),X(81),A(50,50),IP,FINC,RESDF
1,FOUT,KAY,FLAG,L,NINCS,KDEP,IR,P(50,50),Q(50,50),XN,TOL,DF,LLL(10)
2,B(80),COL(11),PINT(11),QINT(11),RES(275),NVIP,ALPHA,RMAX,RMIN,
3RESID,IVPT(33),NVI,KEEP(5),IS
C
DIMENSION KP(50,50),IQ(50,50),STDEV(80),C(80)
EQUIVALENCE (P,KP),(Q,IQ),(KTRANS(81),STDEV),(TRANS,C)
ASN(XX)=ATAN(XX/SQRT(1.0-XX**2))
DO 100 I=1,NTGC
M=KTRANS(1,I)
N=KTRANS(3,I)
NTRANS=KTRANS(2,I)
IF(M-81) 91,91,99
91 IF(N-81) 92,92,99
92 IF((NTRANS-25)*NTRANS)50,99,99
99 WRITE (6,199)I
199 FORMAT(22H TRANSGENERATION CARD ,I3,27H MISPUNCHED OR OUT OF ORDER
1)
GO TO 100
50 GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,99,99,20,21,22,23
1,24),NTRANS
1 IF(X(N)) 198,107,108
107 X(M)=0.0
GO TO 100
108 X(M)= SQRT(X(N))
GO TO 100
2 IF(X(N)) 198,111,112
111 X(M)=1.0
GO TO 100
112 X(M)= SQRT(X(N))+SQRT(X(N)+1.0)
GO TO 100
3 IF(X(N)) 198,198,114
114 X(M) = ALOG10(X(N))
GO TO 100
4 X(M)=EXP(X(N))
GO TO 100
5 IF(X(N)) 198,107,117
117 IF(X(N)-1.0) 118,119,119
118 E=SQRT(X(N))
X(M)=ASN(E)
GO TO 100
119 X(M)=3.14159265/2.0
GO TO 100
6 FN=L
E = 0.0
B(1) = 0.0
IF((FN+1.0) .EQ. 0.0) GO TO 61
E=X(N)/(FN+1.0)
B(1) = E + 1.0 / (FN + 1.0)
61 IF(E) 198,123,124
123 IF(B(1)) 198,107,127
127 X(M)=ASN(SQRT(B(1)))
GO TO 100
124 IF(B(1)) 198,128,129
128 X(M)=ASN(SQRT(E))
GO TO 100
129 E=SQRT(E)
B(1) = SQRT(B(1))
X(M)=ASN(E)+ASN(B(1))
GO TO 100
7 IF(X(N)) 131,198,131
131 X(M)= 1.0/X(N)
GO TO 100
8 X(M)=X(N)+ TRANS( I )
GO TO 100
9 X(M)=X(N)* TRANS( I )
GO TO 100
10 IF(X(N)) 198,107,133
133 X(M)= X(N)**TRANS( I)
GO TO 100
11 NEWB= TRANS( I)
X(M)= X(N)+X(NEWB)
GO TO 100
12 NEWB= TRANS( I)
X(M)=X(N)-X(NEWB)
GO TO 100
13 NEWB= TRANS( I)
X(M)=X(N)*X(NEWB)
GO TO 100
14 NEWB= TRANS( I)
IF(X(NEWB)) 134,197,134
134 X(M)= X(N)/X(NEWB)
GO TO 100
15 IF(X(N)-TRANS( I)) 107,111,111
16 XNEWB=TRANS( I)
IF(X(N)-(XNEWB)) 107,111,111
17 IF(X(N))198,198,163
163 X(M)= ALOG(X(N))
GO TO 100
20 X(M)= SIN(X(N))
GO TO 100
21 X(M)= COS(X(N))
GO TO 100
22 IF(X(N)-1.57079632) 186,186,198
186 IF(X(N)+1.57079632) 198,187,187
187 X(M)=ATAN(X(N))
GO TO 100
23 NEWB= TRANS( I)
IF(X(N)) 198,198,188
188 X(M)=X(N)**X(NEWB)
GO TO 100
24 IF(TRANS(I)) 198,198,189
189 X(M)= TRANS(I)**X(N)
GO TO 100
197 N=NEWB
198 WRITE (6,201)N,NINCS,KTRANS(2,I),M
201 FORMAT(23H THE VALUE OF VARIABLE ,I4, 9H IN CASE ,I5,55H VIOLATED
1THE RESTRICTIONS FOR TRANSGENERATION OF TYPE ,I3,1H./40H THE PROGR
2AM CONTINUED LEAVING VARIABLE ,I4,11H UNCHANGED.)
100 CONTINUE
RETURN
END
FUNCTION INUMB(I)
C
C THE FUNCTION 'INUMB' PLACES A LEFT JUSTIFIED ALPHANUMERIC CHARACTE
C REPRESENTING THE HEXADECIMAL FORM OF 'I' INTO 'INUMB' IF 'I' IS BE
C '0' AND '15' INCLUSIVE. A '*' IS RETURNED IF I FALLS OUTSIDE THES
C
DIMENSION IT(17)
DATA IT/' ','1','2','3','4','5','6','7','8','9','A','B','C','D','E
.','F','*'/
IF (I.LT.0.OR.I.GT.15) GO TO 20
INUMB=IT(I+1)
RETURN
20 INUMB=IT(17)
RETURN
END
SUBROUTINE ATOF(A,N,F)
DIMENSION A(1)
LOGICAL BLANK
BLANK=.TRUE.
S=1.0
NUMB=0
TEN=1.0
DIV=1.0
DO 10 I=1,N
L=INTCHR(A,I)
IF(L.EQ.36) GO TO 10
BLANK=.FALSE.
IF(L.NE.38) GO TO 2
S=-1.0
GO TO 10
2 IF(L.NE.44) GO TO 4
TEN=10.0
GO TO 10
4 IF(L.GT.9) GO TO 9
NUMB=NUMB*10+L
DIV=DIV*TEN
9 CONTINUE
10 CONTINUE
IF(BLANK)RETURN
F=S*FLOAT(NUMB)/DIV
RETURN
END
FUNCTION INTCHR(STRING,N)
DIMENSION SEQ(50),STRING(1),EBCD(5)
DATA SEQ/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,
X 1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
X 1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
X 1HU,1HV,1HW,1HX,1HY,1HZ,1H ,1H+,1H-,1H*,
X 1H/,1H(,1H),1H,,1H.,1H',1H=,1H$,1H ,1H /
DATA EBCD/1H+,1H(,1H),1H',1H=/
CALL GETCHR(STRING,N,CHR)
IF (CHR.NE.SEQ(37)) GO TO 2
INTCHR = 36
GO TO 10
2 DO 1 I=1,48
IF(SEQ(I).EQ.CHR) GO TO 9
1 CONTINUE
I=51
IF(EBCD(1).EQ.CHR) I=38
IF(EBCD(2).EQ.CHR) I=42
IF(EBCD(3).EQ.CHR) I=43
IF(EBCD(4).EQ.CHR) I=46
IF(EBCD(5).EQ.CHR) I=47
9 INTCHR=I-1
10 RETURN
END