Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
C DESCRIPTION OF STRATA WITH HISTOGRAMS MAY 20, 1966
C
C UCLA MEDICAL CENTER - HEALTH SCIENCES COMPUTING FACILITY
C THIS IS A SIFTED VERSION OF BMD07D ORIGINALLY WRITTEN IN
C FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE
C AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.
C
DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
3 XMN(100), SX(10), DX(10), XL(10), SXX(100,10)
DIMENSION FNG(10)
DIMENSION OUT(17)
DOUBLE PRECISION OCC,FRMT(120),PROBLM,FINISH,SPVALU,GRPDIV,COB,JBCD
DOUBLE PRECISION TRYME(10), BLANK
DATA OUT(1),OUT(2),OUT(4),OUT(5),OUT(6),OUT(7),OUT(8),OUT(10),
* OUT(11),OUT(12),OUT(14),OUT(15),OUT(16),OUT(17) / 4H(16X, 4H, ,
* 4H('GR, 4HOUP', 4H,I3,, 4H3X)/, 4H16X,,4H(A8,, 4H3X)/, 4H15X,,
* 4H('.., 4H...., 4H...., 4H+')) / , YES / 3HYES /
DATA FNG/'1','2','3','4','5','6','7','8','9','10'/
DATA BLANK / ' ' /
DATA PROBLM,FINISH,SPVALU,GRPDIV,SPCVAL/6HPROBLM,6HFINISH,6HSPCVAL
1,6HGRPDIV,4H-7CV/
COMMON / LABS / TRYME
COMMON ZZ , X
COMMON NVAR , NCAS , NTR , CP , IGR , NCP
COMMON NCI , KCICP , NERR , NG , NADD , IPNT
EQUIVALENCE (ZZ(101),BIGX), (ZZ(202),SMLX), (ZZ(30
13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
C
C CP GROUP CUT POINTS
C IPNT PRINT CORRELATION MATRIX
C IAO PRINT ALL OF ORDERED DATA
C IPA PRINT ALL OF INPUT DATA
C IPO PRINT PART OF ORDERED INPUT
C IPP PRINT PART OF INPUT DATA
C ISV NO. OF VARIABLE WITH SPECIAL VALUE
C IVF NO. OF VARIABLE FORMAT CARDS
C JBCD PROBLEM NAME
C NADD NO. OF VARIABLES ADDED IN TRANSGENERATION
C NCAS NO. OF CASES
C NCI NO. OF CLASS INTERVALS
C NCP NO. OF GROUP CUT POINTS
C NNC NO. OF NAME CARDS OR VARIABLES WITH SPECIFIED NAMES
C NSVC NO. OF SPECIAL VALUE CARDS
C NTR NO. OF TRANS GENERATOR CARDS
C NVAB NO. OF BASE VARIABLE FOR GROUP DIVISION
C NVAR NO. OF VARIABLES
C
C
17 FORMAT ('1BMD07D - DESCRIPTION OF STRATA WITH HISTOGRAMS',
* ' - REVISED MAY 10, 1968' /
241H HEALTH SCIENCES COMPUTING FACILITY, UCLA//)
NTAPE=5
CALL USAGEB('BMD07D')
C
998 READ (5,10)COB,JBCD,NVAR,NSVC,NNC,NCAS,NG,NCP,NCI,NTR, NADD, PA, P
1P,AO,PO,PNT,SNGLE,NULABS,MTAPE,IVF
IF(COB.EQ.FINISH)GO TO 999
IF(COB.EQ.PROBLM)GO TO 50
WRITE(6,10012)
10012 FORMAT(49H PROBLEM CARD OUT OF ORDER OR INCORRECTLY PUNCHED)
999 IF(5-NTAPE)9998,9999,9999
9998 REWIND NTAPE
9999 STOP
50 CALL TPWD(MTAPE,NTAPE)
3 IF(IVF .GT. 0.AND. IVF .LE. 10) GO TO 1152
WRITE (6,888)
IVF=1
1152 IVF = IVF*12
READ (5,12)(FRMT(I),I=1,IVF)
53 L1=1
1153 IF(NG-10)1155,1155,10000
10000 WRITE(6,10001)
10001 FORMAT(28H NUMBER OF GROUPS EXCEEDS 10)
GO TO 1151
1155 IF(NCI-30)1156,1156,10002
10002 WRITE(6,10003)
10003 FORMAT(47H NUMBER OF CLASSES SPECIFIED IS GREATER THAN 30)
GO TO 1151
1156 IF(NCI-5)1157,1158,1158
1157 IF(NCI)10004,1158,10004
10004 WRITE(6,10005)
10005 FORMAT(43H NUMBER OF CLASSES SPECIFIED IS LESS THAN 5)
GO TO 1151
1158 L2 = NVAR
IF(-NADD)2158,2158,1150
2158 L3=1+NADD
NVAR=NVAR+NADD
IF(NCAS*NVAR-4000)1159,1159,11006
11006 WRITE(6,11007)
11007 FORMAT(' DATA MATRIX IS TOO LARGE, CANNOT EXCEED 16,000')
GO TO 999
10006 WRITE(6,10007)
10007 FORMAT(19H TOO MANY VARIABLES)
GO TO 999
1159 IF(NVAR-100)1154,1154,10006
1154 DO 531 J=1,NCAS
READ (NTAPE,FRMT)(X(I),I=L1,L2)
L1=L2+L3
L2=L2+NVAR
531 CONTINUE
DO 533 I=1,NVAR
OCC(I) =0 .0
BIGX(I) =0.0
SMLX(I) =0.0
NS(I)=0
DO 532 J=1,5
SPV(I,J)=0.0
532 CONTINUE
533 CONTINUE
IF (NSVC) 5305, 5305, 54
54 IF(NSVC-NVAR)541,541,10010
10010 WRITE(6,10011)
10011 FORMAT(' NUMBER OF SPECIAL VALUES INCORRECTLY SPECIFIED')
GO TO 1151
C
C READ IN SPECIAL VALUE CARDS
C
541 DO 55 I=1,NSVC
READ (5,1300)COB,KM,NVIV,(SPV(KM,K), K=1,NVIV)
IF(COB.NE.SPVALU)GO TO 10013
555 IF(NVIV-5)556,556,20014
20014 WRITE(6,10011)
GO TO 1151
10013 WRITE(6,10014)
10014 FORMAT(55H SPECIAL VALUE CARD OUT OF ORDER OR INCORRECTLY PUNCHED
1)
GO TO 999
556 ISKIP=1
IF(SNGLE.NE.YES)GO TO 5567
5563 ISKIP=2
5567 IF(KM-100)557,557,10016
10016 WRITE(6,10017)
10017 FORMAT(50H INDEX OF VARIABLE WITH SPECIAL VALUES EXCEEDS 100)
GO TO 1151
557 NS(KM)=NVIV
DO 5460 II = 1, NVIV
DO 5450 J = II, NVIV
IF(SPV(KM,II).GE.SPV(KM,J))GO TO 5450
5425 HOLD = SPV(KM,II)
SPV(KM,II) = SPV(KM,J)
SPV(KM,J) = HOLD
5450 CONTINUE
5460 CONTINUE
55 CONTINUE
GO TO (5305,5500),ISKIP
5500 DO 5501 I=1,NVAR
NS(I)=NVIV
DO 5501 J=1,NVIV
5501 SPV(I,J)=SPV(KM,J)
5305 IF(NG)10018,5315,5306
10018 WRITE(6,10019)
10019 FORMAT(36H NUMBER OF GROUPS CANNOT BE NEGATIVE)
GO TO 1151
5315 IF(-NCP)560,275,10020
10020 WRITE(6,10021)
10021 FORMAT(46H NUMBER OF GROUP CUT POINTS CANNOT BE NEGATIVE)
GO TO 1151
C
C READ IN GROUP DIVISION CARD
C
560 READ (5,14)COB,NVAB,(CP(I),I=1,NCP)
IF(COB.NE.GRPDIV)GO TO 20020
565 IF(NVAB-100)570,570,10022
10022 WRITE(6,10023)
10023 FORMAT(41H NO. OF BASE VARIABLE IS GREATER THAN 100)
GO TO 1151
20020 WRITE(6,20021)
20021 FORMAT(47H GROUP DIVISION CARD OUT OF ORDER OR MISPUNCHED)
GO TO 999
570 GO TO (572,571),ISKIP
571 NS(NVAB)=0
572 IF(NS(NVAB))5306,5306,270
5306 WRITE (6,17)
IF (NG) 101, 100, 101
101 WRITE (6,19)NCAS
GO TO 105
C
100 WRITE (6,18)NVAB, NCAS, NCP
DO 1001 I=1,NCP
WRITE (6,45)I, CP(I)
1001 CONTINUE
105 WRITE (6,20)
WRITE (6,21)JBCD,NCAS,NVAR,NG,NCP,NSVC,NCI,NNC, PA, PP, AO, PO, P
1NT
WRITE(6,35000)(FRMT(I),I=1,IVF)
35000 FORMAT(' VARIABLE FORMAT CARD(S)'/10(1X,12A6/))
IF (NTR) 56,56,5300
5300 IF(NTR-99)5301,5301,10024
10024 WRITE(6,10025)
10025 FORMAT(48H NO. OF TRANSGENERATION CARDS IS GREATER THAN 99)
GO TO 999
5301 CALL TVA
IF(-NERR)56,56,999
56 NVNC=NVAR*NCAS
205 IF(PA.NE.YES)GO TO 225
210 WRITE (6,41)
ASSIGN 5302 TO KBRNCH
214 L4=NCAS
215 WRITE (6,47)
L3=1
L1=1
L2=NVAR
220 DO 2110 J=L3,L4
WRITE (6,40)J,(X(I),I=L1,L2)
L1=L2+1
L2=L2+NVAR
2110 CONTINUE
GO TO KBRNCH,(5302,240,71,249)
C
C PRINT FIRST AND LAST TEN ROWS OF INPUT MATRIX AFTER
C TRANSGENERATION, IF DESIRED
C
225 IF(PP.NE.YES)GO TO 5302
230 IF(20-NCAS)236,210,210
236 WRITE (6,41)
ASSIGN 240 TO KBRNCH
238 WRITE (6,43)
L4=10
GO TO 215
C
240 ASSIGN 5302 TO KBRNCH
242 WRITE (6,42)
L1=NVNC-(10*NVAR)+1
L2=L1+NVAR-1
L3=NCAS-9
L4=NCAS
GO TO 220
C
5302 IF(-NG)60,63,63
60 NC=NCAS
NCP=NG-1
NGG=NG
DO 61 I=1,NG
IGR(I)=NC/(NGG)
NC=NC-IGR(I)
NGG=NGG-1
61 CONTINUE
GO TO 70
C
63 CALL DIVIDE (NVAB)
C
C PRINT ORDERED MATRIX, IF DESIRED
C
70 IF(AO.NE.YES)GO TO 325
212 WRITE (6,46)
ASSIGN 71 TO KBRNCH
GO TO 214
C
C PRINT FIRST AND LAST TEN ROWS OF ORDERED MATRIX, IF DESIRED
C
325 IF(PO.NE.YES)GO TO 71
330 IF(20-NCAS)248,212,212
248 WRITE (6,46)
ASSIGN 249 TO KBRNCH
GO TO 238
C
249 ASSIGN 71 TO KBRNCH
GO TO 242
C
71 DO 3681 IZQ=1,10
3681 TRYME(IZQ) = BLANK
CALL RDLBL(NNC,NVAR,OCC)
IF (NULABS.LE.0) GO TO 74
READ (5,8912) TRYME
8912 FORMAT (10A8)
74 NG=NCP+1
DO 997 I=1,10
INTEG(I)=I
997 CONTINUE
DO 900 NV=1, NVAR
NCICP(NV)=0
CALL MAMIN(NV)
KCICP=0
CALL CLINT(NV)
IF(KCICP)999,106,999
106 IF(OCC(NV)-0.0)75,76,75
75 WRITE (6,22)NV, OCC(NV)
GO TO 78
C
76 WRITE (6,23)NV
78 WRITE (6,16)
L=NG
OUT(3) = FNG(L)
OUT(9) = FNG(L)
OUT(13) = FNG(L)
79 WRITE (6,OUT) (I,I=1,NG), (TRYME(I), I=1,NG)
90 JY=NS(NV)
J=NCICP(NV)
IF(-JY)91,911,911
C
C NTR IS USED TO GIVE RITE THE NUMBER OF THE VARIABLE
C
91 NTR = NV
WRITE (6,1112)
NABC = 1
CALL PLUG (NV,NABC)
DO 910 JJ = 1, JY
CALL RITE (JJ,NG,NABC)
910 CONTINUE
911 WRITE (6,1111)
NABC=2
CALL PLUG(NV,NABC)
GO TO 93
92 J=J-1
93 CALL RITE(J,NG,NABC)
IF (J-1) 95, 95, 92
95 R=0.0
S=0.0
CAS=NCAS
CAS1=CAS-1.0
YMN=0.0
YSD=0.0
DO 9100 I=1,NG
SX(I)=0.0
DX(I)=0.0
XL(I)=0.0
9100 CONTINUE
J1=1
SSW=0.0
DO 9200 I=1,NG
II=I-1
IG=IGR(I)
GI=IGR(I)
IF(-II)9106,9107,9107
9106 J1=J1+IGR(II)
9107 IG1=J1+IG-1
IF(-IG)9104,9200,9200
9104 DO 9150 J=J1,IG1
K=(J -1)*NVAR+NV
IF(-JY)9110,9125,9125
9110 IF(X(K).EQ.SPCVAL)GO TO 9119
9125 SX(I)=SX(I)+X(K)
GO TO 9150
C
9119 XL(I)=XL(I)+1.0
9150 CONTINUE
IF (GI.EQ.XL(I)) SX(I) = 0.0
IF (GI.NE.XL(I)) SX(I) = SX(I)/(GI-XL(I))
C
C MEAN OF GROUP I IN SX(I)---SPECIAL VALUES EXCLUDED
C
DO 9175 J=J1,IG1
K=(J -1)*NVAR+NV
IF (JY) 9170, 9170, 9160
9160 IF(X(K).EQ.SPCVAL)GO TO 9175
9170 DX(I)=DX(I)+(X(K)-SX(I))**2
9175 CONTINUE
SSW=SSW+DX(I)
IF (GI.LE.XL(I)+1.0) DX(I) = 0.0
IF (GI.GT.XL(I)+1.0) DX(I) = SQRT(DX(I)/(GI-XL(I)-1.0))
C
C STANDARD DEVIATION OF GROUP I IN DX(I)
C
9200 CONTINUE
DO 125 J=1,NCAS
K=(J-1)*NVAR+NV
IF (JY) 109, 121, 109
109 IF(X(K).EQ.SPCVAL)GO TO 110
121 YMN=YMN+X(K)
GO TO 125
C
110 R=R+1.0
125 CONTINUE
YMN=YMN/(CAS-R)
XMN(NV)=YMN
DO 145 J=1,NCAS
K=(J-1)*NVAR+NV
IF(-JY)128,141,141
128 IF(X(K).EQ.SPCVAL)GO TO 130
141 YSD=YSD+(X(K)-YMN)**2
GO TO 145
C
130 S=S+1.0
145 CONTINUE
IDFT=CAS1-S
IDFG=NG-1
IDFW=IDFT-IDFG
SST=YSD
SSG=SST-SSW
IF(IDFG.NE.0) SGM=SSG/IDFG
IF(IDFG.EQ.0) SGM=0.0
IF(IDFW.NE.0) SWM=SSW/IDFW
IF(IDFW.EQ.0) SWM=0.0
IF (SWM.EQ.0) FST = 0.0
IF (SWM.NE.0) FST = SGM/SWM
IF(CAS1.NE.S) YSD=SQRT(YSD/(CAS1-S))
IF(CAS1.EQ.S) YSD=0.0
WRITE (6,36)( SX(I), I=1,NG)
WRITE (6,37)( DX(I), I=1,NG)
DO 150 I=1,NG
LX=XL(I)
XL(I)=IGR(I)-LX
150 CONTINUE
WRITE (6,38)( XL(I), I=1,NG)
WRITE (6,1010)YMN,SSG,IDFG,SGM,FST,YSD,SSW,IDFW,SWM,BIGX(NV),SST,I
1DFT,SMLX(NV)
900 CONTINUE
250 IF(PNT.NE.YES)GO TO 998
255 CALL CORR
GO TO 998
C
270 WRITE (6,15)NS(NVAB)
GO TO 999
C
275 WRITE (6,24)
GO TO 999
C
1150 WRITE (6,1501)
1151 WRITE (6,1500)
GO TO 999
C
10 FORMAT(2A6,3I3,I4,I2,I1,3I2,6A3,15X,I1,2I2)
11 FORMAT (1H1)
12 FORMAT(12A6)
14 FORMAT(A6,I3,9F7.0)
15 FORMAT(1H0,9HTHERE ARE,I4,86H SPECIAL VALUES FOR THE VARIABLE ON W
1HICH DATA IS STRATIFIED. PROGRAM CANNOT CONTINUE.)
16 FORMAT(75X32HLOWER LIMITS OF CLASS INTERVALS)//)
18 FORMAT(1H034HDATA STRATIFIED ON VARIABLE NUMBERI4,1H,I5,6H CASES/I
16,21H CUT POINTS SPECIFIED//)
19 FORMAT(1H0,34HDATA STRATIFIED BY ORDER OF ENTRY.I5,6H CASES)
20 FORMAT(13H0PROBLEM CARD)
21 FORMAT(1H0,8X,12HPROBLEM NAME25XA6/9X15HNUMBER OF CASES21XI7/9X19H
1NUMBER OF VARIABLES17XI7/9X26HNUMBER OF GROUPS SPECIFIED10XI7/9X26
2 HNUMBER OF GROUP CUT POINTS,I17/9X29HNUMBER OF SPECIAL VALUE CARD
3S7XI7/9X35HNUMBER OF CLASS INTERVALS SPECIFIED3XI5/9X30HNUMBER OF
4VARIABLES WITH NAMES,6X,I7,//9X25HPRINT ENTIRE INPUT MATRIX15XA3/9
5X37HPRINT FIRST AND LAST 10 ROWS OF INPUT3XA3/9X27HPRINT ENTIRE OR
6DERED MATRIX13XA3/9X40HPRINT FIRST AND LAST 10 ROWS OF ORDERED A3/
79X24HPRINT CORRELATION MATRIX16XA3)
22 FORMAT(1H1/40X8HVARIABLEI4,2X2H( A6,2H )10X34H(PRINTED INTERVAL DE
1SIGNATIONS ARE)
23 FORMAT(1H1/40X8HVARIABLEI4,22X34H(PRINTED INTERVAL DESIGNATIONS AR
1E)
24 FORMAT(1H0,11X,94HBOTH THE NUMBER OF GROUPS AND THE NUMBER OF GROU
1P CUT POINTS ARE ZERO. PROGRAM CANNOT PROCEED.)
36 FORMAT(1H05X5HMEAN 10F11.3)
37 FORMAT(6X5HS DEV10F11.3)
38 FORMAT(7X1HN10F11.0,//)
40 FORMAT(I5,8F14.5,/(5X,8F14.5))
41 FORMAT(1H136X37HINPUT MATRIX (AFTER TRANSGENERATION))
42 FORMAT(3(3X1H./)/)
43 FORMAT(41X29H-FIRST AND LAST 10 ROWS ONLY-)
45 FORMAT(1H I4,1H.F14.4)
46 FORMAT(1H136X47HINPUT MATRIX (ORDERED - AFTER TRANSGENERATION))
47 FORMAT(3X3HROW//)
1010 FORMAT(46H-ALL GROUPS COMBINED (SPECIAL VALUES EXCLUDED) 20X,46HSU
1M OF SQUARES DF MEAN SQUARE F RATIO/1H0,13X,7HMEAN F12.
24,24X,7HBETWEENF13.4,I9,F14.4,F11.4/13X,8H S DEV F12.4,24X,7HWITH
3IN F13.4,I9,F14.4/13X,8H MAXIMUMF12.4,24X,7HTOTAL F13.4,I9/13X,8H
4 MINIMUMF12.4)
1111 FORMAT (1H013X,64HTABULATIONS AND COMPUTATIONS WHICH FOLLOW EXCLUD
1E SPECIAL VALUES /6X8HINTERVAL//)
1112 FORMAT(1H 5X7HSPECIAL/7X6HVALUES//)
1300 FORMAT(A6,I3,I1,5F7.0)
1500 FORMAT(1H0,12X75HCONTROL CARDS OUT OF ORDER OR NOT PROPERLY PUNCHE
1D. PROGRAM CANNOT PROCEED.)
1501 FORMAT(1H036X45HNUMBER OF VARIABLES ADDED CANNOT BE NEGATIVE.)
888 FORMAT(1H0,23X,71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPEC
1IFIED, ASSUMED TO BE 1.)
C
END
C SUBROUTINE CLINT FOR BMD07D MAY 20, 1966
SUBROUTINE CLINT (NV)
DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
3 XMN(100), SX(10), DX(10), XL(10), SXX(100,10)
COMMON ZZ
COMMON X , NVAR , NCAS , NTR , CP , IGR
COMMON NCP , NCI , KCICP , NERR , NG , NADD
EQUIVALENCE (ZZ(101),BIGX), (ZZ(202),SMLX), (ZZ(30
13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
C
C
IF(NCI)10,10,11
10 FNCA=NCAS
G=NG
CIN=10.0*ALOG10(FNCA/G)
NCI=CIN
11 IF(NCI-5)12,15,15
12 NCI=5
15 FNCI=NCI-1
IF(30-NCI)16,18,18
16 NCI=30
FNCI=29.0
18 IF(SMLX(NV)-BIGX(NV))185,22,185
185 CALL SCALE1(SMLX(NV),BIGX(NV),FNCI,XMIN,XIJ)
ICI=NCI
19 NCICP(NV)=ICI
CICP(1)=XMIN
ICI=ICI+1
DO 20 J=2,ICI
CICP(J)=CICP(J-1)+XIJ
20 CONTINUE
RETURN
22 ICI=5
XIJ=0.5
XMIN=SMLX(NV)-1.0
C
C PRINT ALL OF INPUT MATRIX AFTER TRANSGENERATION, IF DESIRED
C
GO TO 19
END
SUBROUTINE SCALE1(YMIN,YMAX,YINT,TYMIN,YIJ)
DIMENSION C(10)
DATA C/1.0,1.5,2.0,3.0,4.0,5.0,7.5,10.0,15.0,20.0/
TEST=1.0/(2.0**20)
50 YR=YMAX-YMIN
TT=YR/YINT
J=ALOG10(TT)+TEST
E=10.0**J
TT=TT/E
I=0
IF(TT-1.0+TEST)205,201,201
205 TT=TT*10.0
E=E/10.0
201 I=I+1
IF(10-I)1,2,2
1 E=E*10.0
TT=TT/10.0
I=1
2 IF(TT-C(I))233,202,201
233 YIJ=C(I)*E
GO TO 203
202 Y=YMIN/C(I)
J=Y
T=J
IF(0.0001-ABS(T-Y))204,233,233
204 YIJ=C(I+1)*E
203 X=((YMAX+YMIN)/YIJ-YINT )/2.0+.00001
K=X
IF(K)235,234,240
235 Y=K
IF(X-Y)236,240,236
236 K=K-1
240 TYMIN=K
TYMIN=YIJ*TYMIN
TYMAX=TYMIN + YINT*YIJ
IF(YMAX-TYMAX-TEST)10,10,201
234 IF(YMIN)235,240,240
10 RETURN
END
C SUBROUTINE CORR FOR BMD07D MAY 20, 1966
SUBROUTINE CORR
C
DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
3XMN(100),SX(10),DX(10),XL(10),SXX(100,10)
DOUBLE PRECISION TRYME(10), BLANK
COMMON / LABS / TRYME
DATA BLANK / ' ' /
COMMON ZZ , X
COMMON NVAR , NCAS , NTR , CP , IGR , NCP
COMMON NCI , KCICP , NERR , NG , NADD , IPNT
EQUIVALENCE (ZZ(101),BIGX), (ZZ(202),SMLX), (ZZ(30
13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
C
C SUBROUTINE CORR COMPUTES CORRELATION COEFFICIENTS FOR EACH
C GROUP AND PRINTS THEM OUT IN THE FORM OF THE LOWER TRIANGLE
C INCLUDING THE PRINCIPAL DIAGONAL. SPECIAL VALUES ARE EXCLUDED
C FROM THE COMPUTATIONS.
C
DATA SPCVAL/4H-7CV/
C
85 IGF = 1
LAST = (NVAR*(1+NVAR))/2
WRITE (6,9101)NG
ASSIGN 100 TO KSKIP
DO 40 NV=1,NG
DO 810 I = 1,LAST
ZZ(I) = 0.0
810 CONTINUE
811 IG = IGR(NV)
KKK = (IGF - 1)*NVAR
IKK = KKK
IGF = IG + IGF
255 IF (IG) 256,256,7
256 IF (TRYME(NV).EQ.BLANK ) WRITE(6,1000) NV
IF (TRYME(NV).NE.BLANK ) WRITE(6,1001) NV,TRYME(NV)
ASSIGN 105 TO KSKIP
GO TO 40
C
7 KK=(IGF-2)*NVAR
JKK = KK
8 M=0
DO 1 I = 1, NVAR
SUMX = 0.0
SUMSQX = 0.0
XIG=0.0
KK = KK + 1
KKK = KKK + 1
DO 6 K = KKK,KK,NVAR
IF(X(K).EQ.SPCVAL)GO TO 6
15 SUMX = X(K) + SUMX
SUMSQX = X(K)**2 + SUMSQX
17 XIG=XIG+1.0
6 CONTINUE
DO 2 J = 1, I
SUMX1=SUMX
60 SUMY1=0.0
SUMY = 0.0
SUMSQY = 0.0
SUMXY = 0.0
YIG=0.0
XYIG=0.0
IK = I + IKK
JKIG = J + JKK
KKJ = J + IKK
DO 5 K = KKJ,JKIG,NVAR
IF(X(K).EQ.SPCVAL)GO TO 705
65 SUMY = X(K) + SUMY
SUMSQY = X(K)**2 + SUMSQY
68 YIG=YIG+1.0
IF(X(IK).EQ.SPCVAL)GO TO 715
71 SUMXY = X(IK)*X(K) + SUMXY
72 XYIG=XYIG+1.0
GO TO 75
C
705 IF(X(IK).EQ.SPCVAL)GO TO 75
710 SUMX1=SUMX1-X(IK)
GO TO 75
C
715 SUMY1=SUMY1+X(K)
75 IK = IK + NVAR
5 CONTINUE
SUMY1=SUMY-SUMY1
50 M = M + 1
IF(XIG*YIG*XYIG)51,505,51
51 A=SQRT((SUMSQX-(SUMX**2)/XIG)*(SUMSQY-(SUMY**2)/YIG))
IF(A)515,505,515
515 IF(XYIG-1.0)550,505,550
550 ZZ(M)=((SUMXY-(SUMX1*SUMY1)/XYIG)* (SQRT((XIG-1.0)*(YIG-1.0))))/(A
1*(XYIG-1.0))
GO TO 2
C
505 ZZ(M)=99.0
2 CONTINUE
1 CONTINUE
NPAGE = 0
KVAR = (NVAR+7)/8
ISTART = 1
LLL = 0
GO TO KSKIP,(100,105)
100 ASSIGN 105 TO KSKIP
GO TO 110
C
105 WRITE (6,9105)
110 DO912 II = 1, KVAR
IF(II-1)90,900,90
90 WRITE (6,9105)
900 KOUNT = LLL
LL = LLL + 9
NPAGE = NPAGE + 1
WRITE (6,9103) TRYME(NV), NV, NPAGE
KK = II-1
KK = KK-5*(KK/5)
IF(-KK)99,913,913
99 DO 97 III= 1, KK
WRITE (6,9104)
97 CONTINUE
913 I = ISTART
IBEGN = KOUNT+1
IFINSH = MIN0(NVAR,IBEGN+7)
WRITE (6,9136) (MXL, MXL=IBEGN,IFINSH)
9136 FORMAT (I16,7I14)
DO91 IJ = 1, 8
K = IJ + I- 1
KOUNT = KOUNT+1
WRITE (6,9102) KOUNT, (ZZ(N),N=I, K)
I = KOUNT + I
IF (KOUNT - NVAR) 91,40,40
91 CONTINUE
ISTART = K + LL
GO TO 92
C
910 DO 93 L = 1, 8
JK = I + 7
KOUNT = KOUNT+1
WRITE (6,9102) KOUNT, (ZZ(N),N=I,JK)
I = I + KOUNT
IF ( KOUNT - NVAR ) 93,911,911
93 CONTINUE
92 IF (40 - KOUNT) 914,94,910
914 IF ( KOUNT - 80) 910,94,910
94 NPAGE = NPAGE + 1
WRITE (6,9105)
WRITE (6,9103) TRYME(NV), NV, NPAGE
IBEGN = KOUNT+1
IFINSH = MIN0(NVAR,IBEGN+7)
WRITE (6,9136)(MXL,MXL=IBEGN,IFINSH)
GO TO910
C
911 LLL = LLL+8
912 CONTINUE
40 CONTINUE
RETURN
C
1000 FORMAT(1H0,5HGROUPI3,41H IS EMPTY, THEREFORE, THERE IS NO MATRIX.)
1001 FORMAT(1X,'GROUP',I3,', ',A8,', IS EMPTY, THEREFORE, THERE IS NO
*MATRIX.')
9101 FORMAT (1H1 40X, 22HCORRELATION MATRICES ( I3,1H)//10X,102HTHESE A
1RE SYMMETRIC MATRICES AND THEREFORE ARE PRINTED IN HALF FORM, INCL
2UDING THE PRINCIPAL DIAGONAL./10X86HA VALUE OF 99.0 INDICATES THE
3COEFFICIENT IS NOT COMPUTABLE DUE TO A ZERO DENOMINATOR.//)
9102 FORMAT(I4,8F14.4)
9103 FORMAT (7X,A8,' GROUP',I3,6X,'(PAGE',I3,')'//)
9104 FORMAT (1H ////////)
9105 FORMAT(1H1/////)
END
C SUBROUTINE DESQ FOR BMD07D MAY 20, 1966
SUBROUTINE DESQ (L1, DEVSQ)
DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
3XMN(100),SX(10),DX(10),XL(10),SXX(100,10)
COMMON ZZ , X
COMMON NVAR , NCAS , NTR , CP , IGR , NCP
COMMON NCI , KCICP , NERR , NG , NADD
EQUIVALENCE (ZZ(101),BIGX), (ZZ(202),SMLX), (ZZ(30
13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
EXTERNAL SIGN
CAS=NCAS-1
CALL YMEAN (L1, YMEA )
L=NS(L1)
SUM=0.0
DO 100 J=1,NCAS
I=(J-1)*NVAR+L1
IF (L) 52, 52, 45
45 DO 50 K=1,L
IF(X(I)-SPV(L1,K))50,46,50
46 B=SIGN(1.0,SPV(L1,K))
C=SIGN(1.0, X(I))
IF(B+C)55,50,55
50 CONTINUE
52 SUM=SUM+(X(I)-YMEA)**2
GO TO 100
C
55 CAS=CAS-1.0
100 CONTINUE
DEVSQ=SQRT((1.0/CAS)*SUM)
RETURN
END
C SUBROUTINE DIVIDE FOR BMD07D MAY 20, 1966
SUBROUTINE DIVIDE (NVAB)
DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
3 XMN(100), SX(10), DX(10), XL(10), SXX(100,10)
COMMON ZZ
COMMON X , NVAR , NCAS , NTR , CP , IGR
COMMON NCP , NCI , KCICP , NERR , NG , NADD
EQUIVALENCE (ZZ(101),BIGX), (ZZ(202),SMLX), (ZZ(30
13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
C
C MATRIX ORDERING BASED ON ONE VARIABLE - NVAB
C
NVNC=NVAR*NCAS
NVN=NVNC-NVAR-NVAR+NVAB
DO 1000 K=NVAB,NVN,NVAR
KK=K+NVAR
L=K-NVAB+1
M=L
CHECK=X(K)
75 IF(X(KK)-CHECK)100,115,115
100 M=KK-NVAB+1
CHECK=X(KK)
115 KK=KK+NVAR
110 IF(NVNC-KK)200,75,75
200 IF(M-L)201,1000,201
201 DO 205 J=1,NVAR
DUM=X(L)
X(L)=X(M)
X(M)=DUM
L=L+1
M=M+1
205 CONTINUE
1000 CONTINUE
K=NCP+1
M=K
CP(K)=10.0**6
DO 63 I=1,K
IGP(I)=0
63 CONTINUE
I=NVN+NVAR
64 DO 66 J=NVAB,I,NVAR
IF (X(J)-CP(K)) 65, 66, 66
65 IGP(K)=IGP(K)+1
66 CONTINUE
K=K-1
IF (K) 67, 67, 64
67 DO 68 K=2,M
L=K-1
IGR(K)=IGP(K)-IGP(L)
68 CONTINUE
IGR(1)=IGP(1)
RETURN
END
C SUBROUTINE MAMIN FOR BMD07D MAY 20, 1966
SUBROUTINE MAMIN (NV)
DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
3 XMN(100), SX(10), DX(10), XL(10), SXX(100,10)
COMMON ZZ
COMMON X , NVAR , NCAS , NTR , CP , IGR
COMMON NCP , NCI , KCICP , NERR , NG , NADD
EQUIVALENCE (ZZ(101),BIGX), (ZZ(202),SMLX), (ZZ(30
13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
EXTERNAL SIGN
TENSIX=10.0**6
SMLX(NV)=TENSIX
BIGX(NV)=-SMLX(NV)
JJ=NS(NV)
IF(JJ)10,10,15
10 ASSIGN 52 TO JTIMES
GO TO 20
C
15 ASSIGN 50 TO JTIMES
20 J=((NCAS-1)*NVAR)+NV
DO 60 K=NV,J,NVAR
GO TO JTIMES,(52,50)
50 DO 51 I=1,JJ
IF (X(K)-SPV(NV,I)) 51, 501, 51
501 B=SIGN(1.0, SPV(NV,I))
C=SIGN(1.0, X(K))
IF (B+C) 60, 51, 60
51 CONTINUE
52 BIGX(NV)=AMAX1(BIGX(NV),X(K))
SMLX(NV)=AMIN1(SMLX(NV), X(K))
60 CONTINUE
IF(SMLX(NV)-TENSIX)100,70,100
70 IF(BIGX(NV)+TENSIX)100,80,100
80 SMLX(NV)=0.0
BIGX(NV)=0.0
100 RETURN
END
C SUBROUTINE PLUG FOR BMD07D MAY 20, 1966
SUBROUTINE PLUG (NV,NABC)
DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
3XMN(100),SX(10),DX(10),XL(10),SXX(100,10)
COMMON ZZ , X
COMMON NVAR , NCAS , NTR , CP , IGR , NCP
COMMON NCI , KCICP , NERR , NG , NADD
EQUIVALENCE (ZZ(101),BIGX), (ZZ(202),SMLX), (ZZ(30
13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
4XL), (ZZ(1353), IGP), (ZZ(3500),SXX)
C
DATA SPCVAL/4H-7CV/
EXTERNAL SIGN
C
ASSIGN 86 TO KSKIP
JR=NS(NV)
IF (NABC - 1) 10,10,15
10 ASSIGN 88 TO KSKIP
IF(-JR)15,998,998
15 DO 50 I=1,10
DO 50 J=1,30
K000FX(I,J)=0
50 CONTINUE
KKP=NCICP(NV)+1
KOUNT=0
KOU=0
DO 200 K=1,NG
MN=IGR(K)
IF(-MN)80,200,200
80 DO 150 J=1,MN
L=1
I=NVAR*(KOUNT+J-1)+NV
IF(-JR)85,100,100
85 GO TO KSKIP,(86,88)
86 IF(X(I).EQ.SPCVAL)GO TO 140
100 IF ((CICP(L)-X(I))-.00001) 101,101,110
101 L=L+1
IF (L-KKP) 100, 100, 200
C
88 DO 90 JS=1,JR
IF(X(I).NE.SPV(NV,JS))GO TO 90
89 B=SIGN(1.0, SPV(NV,JS))
C=SIGN(1.0, X(I))
897 IF(B+C) 899,90,899
899 K000FX(K,JS) = K000FX(K,JS) + 1
X(I)=SPCVAL
90 CONTINUE
GO TO 140
C
110 LL=L-1
K000FX(K,LL)=K000FX(K,LL)+1
140 KOU=KOU+1
150 CONTINUE
KOUNT=KOU
200 CONTINUE
998 RETURN
END
C SUBROUTINE RDLBL FOR BMD07D MAY 20, 1966
C SUBROUTINE TO READ IN LABELS CARDS, STORE THEM IN ARRAY,
C AND SUBSTITUTE ZEROS FOR UNLABELED VARIABLES
C NVAR IS TOTAL NUMBER OF VARIABLES
C NLBVAR IS NUMBER OF LABELED VARIABLES EXPECTED
C
SUBROUTINE RDLBL(NLBVAR,NVAR,ARRAY)
DOUBLE PRECISION DUMY,ARRAY
DIMENSION ARRAY(1),IDUM(7),DUMY(7)
DATA ALABEL/'LAB'/
C CLEAR VARIABLES
DO 1 I=1,NVAR
1 ARRAY(I)=0.0
C IF NO LABELS, RETURN
IF(-NLBVAR)2,9,9
2 N=0
C READ 1 LABELS CARD
20 READ (5,3) TEST,(IDUM(J),DUMY(J),J=1,7)
3 FORMAT(A3,3X,7(I4,A6))
C TEST FOR 'LAB' IN FIRST 3 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)
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)10,8,11
10 IF(K-NVAR) 7,7,11
11 WRITE (6,12)K,DUMY(J)
12 FORMAT('0LABELS CARD INDEX',I7,' INCORRECT. LABEL ',A8,'IGNORED.')
C
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 RITE (L,NG,NABC)
DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
3 XMN(100), SX(10), DX(10), XL(10), SXX(100,10),OC(10)
DATA OC/1H ,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA ZERO / '0' /
COMMON ZZ
COMMON X , NVAR , NCAS , NTR , CP , IGR
COMMON NCP , NCI , KCICP , NERR , QZ , NADD
EQUIVALENCE (ZZ(101),BIGX), (ZZ(202),SMLX), (ZZ(30
13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
C
J=L
NABC = NABC
DATA STAR /1H*/
DO 700 K=2,113
VEC(K) = OC(1)
700 CONTINUE
DO 799 I=1,NG
NN=K000FX(I,J)
IF(-NN)711,799,799
711 MA=((I-1)*11)+2
MB=MA+(NN-1)
MC=MA+8
MD=MA+9
ME=MA+10
MF=MA+7
MG=MA+6
IF (NN-10) 712, 712, 714
712 DO 713 K=MA,MB
VEC(K)=STAR
713 CONTINUE
GO TO 799
C
714 IF (NN-99) 715, 715, 717
715 NNN=1
DO 716 K=MA,MC
VEC(K)=STAR
716 CONTINUE
NN1=NN/10
NN2=NN-(10*NN1)
GO TO 750
C
717 IF (NN-999) 718, 718, 720
718 NNN=2
DO 719 K=MA,MF
VEC(K)=STAR
719 CONTINUE
KNN=NN/10
NN1=NN/100
NN2=KNN-(10*NN1)
NN3=NN-(10*KNN)
GO TO 750
C
720 IF (NN-9999) 721, 721, 799
721 NNN=3
DO 722 K=MA, MG
VEC(K)=STAR
722 CONTINUE
NN1=NN/1000
INN=NN/100
JNN=NN/10
NN2=INN-(10*NN1)
NN3=JNN-(10*INN)
NN4=NN-(10*JNN)
750 IF (NNN-2) 751, 756, 771
751 MZ=MD
IJ=2
7511 IF(-NN1)752,760,760
752 GO TO (761, 762, 763, 764, 765, 766, 767, 768, 769), NN1
753 IJ=IJ-1
IF(-IJ)754,799,799
754 MZ=ME
7541 IF(-NN2)755,760,760
755 GO TO (761, 762, 763, 764, 765, 766, 767, 768, 769), NN2
756 IJ=2
MZ=MC
IF (NN1) 760, 760, 752
C
757 IJ=IJ-1
IF(-IJ)758,759,799
758 MZ=MD
IF (NN2) 760, 760, 755
C
759 MZ=ME
7591 IF(-NN3)770,760,760
770 GO TO (761, 762, 763, 764, 765, 766, 767, 768, 769), NN3
C
771 IJ=2
IJK=2
MZ=MF
GO TO 7511
C
772 IJ=IJ-1
IF(-IJ)773,774,775
773 MZ=MC
GO TO 7541
C
774 MZ=MD
GO TO 7591
C
775 IJK=IJK-1
IF(-IJK)776,799,799
776 MZ=ME
IF(-NN4)777,760,760
777 GO TO (761, 762, 763, 764, 765, 766, 767, 768, 769), NN4
C
760 VEC(MZ) = ZERO
GO TO (753, 757, 772), NNN
C
761 VEC(MZ) = OC(2)
GO TO (753, 757, 772), NNN
C
762 VEC(MZ) = OC(3)
GO TO (753, 757, 772), NNN
C
763 VEC(MZ) = OC(4)
GO TO (753, 757, 772), NNN
C
764 VEC(MZ) = OC(5)
GO TO (753, 757, 772), NNN
C
765 VEC(MZ) = OC(6)
GO TO (753, 757, 772), NNN
C
766 VEC(MZ) = OC(7)
GO TO (753, 757, 772), NNN
C
767 VEC(MZ) = OC(8)
GO TO (753, 757, 772), NNN
C
768 VEC(MZ) = OC(9)
GO TO (753, 757, 772), NNN
C
769 VEC(MZ) = OC(10)
GO TO (753, 757, 772), NNN
C
799 CONTINUE
HOLD = CICP(J)
GO TO (4001,4002), NABC
4001 CICP(J) = SPV(NTR,J)
GO TO 4004
C
4002 IF(CICP(J))4004,4003,4004
4003 CICP(J)=0.0
4004 WRITE (6,4000)CICP(J), (VEC(MM), MM = 2, 113)
CICP(J) = HOLD
RETURN
4000 FORMAT(1H ,F12.3,2H )113A1)
END
C SUBROUTINE TEST FOR BMD07D MAY 20, 1966
SUBROUTINE TEST(N1,N2,N3,C)
C
DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
3XMN(100),SX(10),DX(10),XL(10),SXX(100,10)
COMMON ZZ , X
COMMON NVAR , NCAS , NTR , CP , IGR , NCP
COMMON NCI , KCICP , NERR , NG , NADD
EQUIVALENCE (ZZ(101),BIGX), (ZZ(202),SMLX), (ZZ(30
13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
EXTERNAL SIGN
IF(N3)600,600,100
100 DO 500 L=1,N3
IF(X(N1).EQ.SPV(N2,L))GO TO 1000
500 CONTINUE
600 C=1.0
RETURN
C
1000 IF(X(N1))1050,1025,1050
1025 B=SIGN(1.0,SPV(N2,L))
C=SIGN(1.0,X(N1))
IF(B+C)1050,500,1050
1050 C=0.0
2000 RETURN
END
C SUBROUTINE TPWD FOR BMD07D MAY 20, 1966
SUBROUTINE TPWD(NT1,NT2)
IF(NT1)40,10,12
10 NT1=5
12 IF(NT1 .EQ. NT2) GO TO 19
IF(NT2.EQ.5)GO TO 18
17 REWIND NT2
19 IF(NT1 .EQ. 5) GO TO 24
18 IF(NT1 .EQ. 6) GO TO 40
REWIND NT1
24 NT2=NT1
RETURN
40 WRITE (6,49)
49 FORMAT(25H ERROR ON TAPE ASSIGNMENT)
STOP
END
C SUBROUTINE TVA FOR BMD07D MAY 20, 1966
SUBROUTINE TVA
C
DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
3XMN(100),SX(10),DX(10),XL(10),SXX(100,10)
COMMON ZZ , X
COMMON NVAR , NCAS , NTR , CP , IGR , NCP
COMMON NCI , KCICP , NERR , NG , NADD
ASN(XX) = ATAN(XX/SQRT(1.0-XX**2))
C
DOUBLE PRECISION TRNGEN,COB
EQUIVALENCE (ZZ(101),BIGX), (ZZ(202),SMLX), (ZZ(30
13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
DATA TRNGEN/6HTRNGEN/
C
ON=NCAS+1
NORM=0
WRITE (6,10)
WRITE (6,11)
NERR=0
DO 1000 I=1,NTR
READ (5,12)COB,NE,NC,NV,CO
IF(COB.NE.TRNGEN)GO TO 250
45 WRITE (6,13)I, NE, NC, NV, CO
IF(NE-NVAR)50,50,290
50 NSN=NS(NV)
NTIMES=1
LL=CO
IF(NV-NVAR)5005,5005,290
5005 IF(10-NC)51,59,59
51 IF(15-NC)52,59,55
52 IF(16-NC)53,55,59
53 IF(NC-23)59,55,275
55 NSM=NS(LL)
NTIMES=2
IF(LL-NVAR)59,59,290
59 IF(-NC)60,1000,275
60 IF(-NERR)605,605,1000
605 NVNC=NVAR*(NCAS-1)+NV
KK=NE-NVAR
KKK=LL-NVAR
DO 910 K=NV,NVNC,NVAR
D1=X(K)
KK=KK+NVAR
KKK=KKK+NVAR
IF (NSN) 61, 61, 64
61 GO TO (75,62),NTIMES
62 IF(-NSM)63,75,75
63 CALL TEST(KKK,LL,NSM,CHECK)
IF(CHECK)75,70,75
64 CALL TEST(K,NV,NSN,CHECK)
IF(CHECK)61,70,61
70 IF (NS(NE)) 71, 71, 72
71 NS(NE)=1
SPV(NE, 1) = -9909.9909
72 D2=SPV(NE,1)
GO TO 900
C
75 GO TO (100, 105, 110, 115, 120, 125, 130, 135, 140, 145, 150, 155,
1160, 165, 170, 175, 180, 185, 190, 195, 200, 205, 210 ), NC
100 IF(-D1)102,101,300
102 D2=SQRT(D1)
GO TO 900
101 D2=0.0
GO TO 900
105 IF(-D1)107,106,300
107 D2=SQRT(D1)+SQRT(D1+1.0)
GO TO 900
106 D2=1.0
GO TO 900
110 IF(-D1)111,300,300
111 D2=ALOG10(D1)
GO TO 900
115 D2=EXP(D1)
GO TO 900
120 IF(-D1)121,101,300
121 IF(D1-1.0)123,122,300
123 D2=ASN(SQRT(D1))
GO TO 900
122 D2=1.57079632
GO TO 900
125 A=D1/ON
B=A+1.0/ON
IF(-A)128,126,300
128 IF(-B)1290,129,300
1290 A=SQRT(A)
B=SQRT(B)
D2=ASN(A)+ASN(B)
GO TO 900
126 IF(-B)127,101,300
127 D2=ASN(SQRT(B))
GO TO 900
129 D2=ASN(SQRT(A))
GO TO 900
130 IF(D1)131,300,131
131 D2=1.0/D1
GO TO 900
135 D2=D1+CO
GO TO 900
140 D2=D1*CO
GO TO 900
145 DO 146 JJJ=1,15
AB=ABS(CO*2.0**JJJ)
IF (AB-.5) 146, 147, 146
146 CONTINUE
GO TO 148
147 IF(-D1)148,101,300
148 D2=D1**CO
GO TO 900
150 D2=D1+X(KKK)
GO TO 900
155 D2=D1-X(KKK)
GO TO 900
160 D2=D1*X(KKK)
GO TO 900
165 IF(X(KKK))166,300,166
166 D2=D1/X(KKK)
GO TO 900
170 IF(D1-CO)101,106,106
175 IF(D1-X(KKK))101,106,106
180 IF(-D1)181,300,300
181 D2=ALOG(D1)
GO TO 900
185 GO TO(186,187),LTIMES
186 LTIMES=2
CALL YMEAN (NV, YMEA)
187 D2=D1-YMEA
GO TO 900
190 GO TO (191,192),LTIMES
191 LTIMES=2
CALL DESQ(NV,DEVSQ)
192 D2=D1/DEVSQ
GO TO 900
195 D2=SIN(D1)
GO TO 900
200 D2=COS(D1)
GO TO 900
205 D2=ATAN(D1)
GO TO 900
210 DO 211 JJJ=1,15
AC=ABS(X(KKK)*2.0**JJJ)
IF (AC-.5) 211, 212, 211
211 CONTINUE
GO TO 213
212 IF(-D1)213,101,300
213 IF(X(KKK))214,214,215
214 IF(D1)215,300,215
215 D2=D1**X(KKK)
900 X(KK)=D2
910 CONTINUE
IF (NORM) 2000, 1000, 1000
C
250 NERR=-999
WRITE (6,17)
GO TO 2000
C
275 WRITE (6,18)I
280 NERR=-999
GO TO 1000
290 WRITE (6,19)
GO TO 280
C
300 NORM=-999
NERR=-999
WRITE (6,14)I
WRITE (6,15)K
1000 CONTINUE
IF (NERR) 2000, 3000, 3000
2000 WRITE (6,16)
3000 RETURN
C
10 FORMAT (1H06X, 23HTRANS GENERATOR CARD(S))
11 FORMAT (46H0CARD NEW TRANS ORIG. ORIG. VAR(B)/45H NO.
1 VARIABLE CODE VAR(A) OR CONSTANT )
12 FORMAT(A6,I3,I2,I3,F6.0)
13 FORMAT(I4,I8,2I9,4XF10.5)
14 FORMAT (55H0THE INSTRUCTIONS INDICATED ON TRANS GENERATOR CARD NO.
1 I2, 1X, 3HRE-/60H SULTED IN THE VIOLATION OF A RESTRICTION FOR TH
2IS TRANSFOR-/58H MATION. THE VIOLATION OCCURED FOR THE ITEMS LISTE
3D BELOW.)
15 FORMAT (10H0ITEM NO. I5)
16 FORMAT (41H0PROGRAM CANNOT CONTINUE FOR THIS PROBLEM )
17 FORMAT(33H0TRANSGENERATOR CARD OUT OF ORDER)
18 FORMAT(1H039X19HTRANSGENERATOR CARDI3,18H HAS ILLEGAL CODE.)
19 FORMAT(1H0,26X,65HVARIABLE INDEX ON ABOVE TRANSGENERATION CARD IS
1GREATER THAN P+Q.)
END
C SUBROUTINE YMEAN FOR BMD07D MAY 20, 1966
SUBROUTINE YMEAN (M1,YMEA)
C
DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
3XMN(100),SX(10),DX(10),XL(10),SXX(100,10)
COMMON ZZ
COMMON X , NVAR , NCAS , NTR , CP , IGR
COMMON NCP , NCI , KCICP , NERR , NG , NADD
EQUIVALENCE (ZZ(101),BIGX), (ZZ(202),SMLX), (ZZ(30
13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
EXTERNAL SIGN
C
L=NS(M1)
CAS=NCAS
XNN=0
DO 100 J=1,NCAS
I=(J-1)*NVAR+M1
IF (L) 51, 51, 45
45 DO 50 K=1,L
IF(X(I)-SPV(M1,K))50,55,50
55 IF (SIGN(1.0,X(I))-SIGN(1.0,SPV(M1,K))) 50,57,50
50 CONTINUE
51 XNN=XNN+X(I)
GO TO 100
57 CAS = CAS-1.0
100 CONTINUE
YMEA=XNN/CAS
RETURN
END