Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/bmd/bmdx70.for
There is 1 other file named bmdx70.for in the archive. Click here to see a list.
C T PROGRAM -- MAIN PROGRAM JUNE 20, 1966
C THIS IS A SIFTED VERSION OF BMDX70 ORIGINALLY WRITTEN IN
C FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE
C AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.
DOUBLE PRECISION FINISH,CODE,TODE
DOUBLE PRECISION PROBLM
DATA FINISH,PROBLM/'FINISH','PROBLM'/
DIMENSION FMT(180),X(200),N(70,2,15),SUM(70,2,15),NTOTL(20),
1SUMSQ(70,2,15),NUSE(100),CAT(20),ICAT(20),NVAL(100)
2,F(3),XM1(3),XM2(3),P(3),ROWNO(20)
COMMON X , NTRG , NADVAR , NI , ROWNO , FAIL
COMMON MISCRD , ERROR , NOW , VALS , NTVAR , NOCASE
COMMON BADVAL , ROWS , NROWS , VARG , CTOT , XL1
COMMON XL2 , F , XM1 , XM2 , P
DATA BLANK/' '/,YES/'YES'/
CALL USAGEB('BMDX70')
XM1(2)=1.0
XM1(3)=1.0
80 READ (5,100)CODE,TODE,NCASE,NVAR,NTRG,NADVAR,MISCRD, NROWS,NWRITE,
1NCARDS,YESP,NIT,NVFC
100 FORMAT (2A6,I5,2I3,I4,3I3,I2,A3,27X,2I2)
P(1)=-0.0
P(2)=-0.0
P(3)=-0.0
IF(CODE.EQ.PROBLM)GO TO 1
IF(CODE.EQ.FINISH)GO TO 900
PRINT 500,CODE
500 FORMAT(' PROGRAM EXPECTED PROBLM OR FINISH CARD INSTEAD READ THE
1FOLLOWING'/1X,A6)
STOP
1 NI=0
NTVAR=NVAR+NADVAR
DO 25 L=1,15
NTOTL(L)=0
DO 24 K=1,2
DO 23 J=1,70
N(J,K,L)=0
SUM(J,K,L)=0.0
SUMSQ(J,K,L)=0.0
23 CONTINUE
24 CONTINUE
25 CONTINUE
WRITE (6,1000)
1000 FORMAT ('1BMDX70 T PROGRAM',
1' - REVISED JUNE 30, 1969')
WRITE (6,1001)
1001 FORMAT (40H HEALTH SCIENCES COMPUTING FACILITY,UCLA )
WRITE (6,819)TODE
819 FORMAT (9H0PROBLEM ,A6)
WRITE (6,820)NCASE,NROWS
820 FORMAT (26H NUMBER OF CASES.........., I6,3X, 20HNO. OF SUB-P
1ROBLEMS. ,I2)
WRITE (6,821)NVAR,NWRITE
821 FORMAT (29H NUMBER OF PUNCHED VARIABLES.,I3,3X,20HTAPE TO WRITE...
1....,I2)
WRITE (6,822)NTRG,NIT
822 FORMAT (29H NUMBER OF TRANSGENERATIONS..,I3,3X,20HINPUT TAPE NUMBE
1R...,I2)
WRITE (6,823)NADVAR
823 FORMAT (29H NUMBER OF VARIABLES ADDED...,I3,3X,18HNUMBER OF VARIAB
1LE )
WRITE (6,824)MISCRD,NVFC
824 FORMAT (29H NUMBER OF MISVAL CARDS......,I3,3X,20HFORMAT CARDS....
1....,I2)
ERROR=0.0
IF(NVAR-200)810,810,501
810 IF(NTRG-100)811,811,503
811 IF(NVAR+NADVAR-100)812,812,505
812 IF(MISCRD-100)813,813,507
813 IF(NROWS-20)814,814,509
814 IF(NVFC.GE.1.AND.NVFC.LE.10)GO TO 816
PRINT 511
511 FORMAT(' NUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIFIED, AS
1SUMED TO BE 1')
NFVC=1
816 IF(NCASE-32000)815,815,513
501 PRINT 502
502 FORMAT(' NUMBER OF ORIGINAL VARIABLES IS GREATER THAN 200')
GO TO 899
503 PRINT 504
504 FORMAT(' NUMBER OF TRANSGENERATION CARDS IS GREATER THAN 100')
GO TO 899
505 PRINT 506
506 FORMAT(' NUMBER OF VARIABLES OUTPUT IS GREATER THAN 100')
GO TO 899
507 PRINT 508
508 FORMAT(' NUMBER OF MISVAL CARDS IS GREATER THAN 100')
GO TO 899
509 PRINT 510
510 FORMAT(' NUMBER OF SUBPROBLM CARDS IS INCORRECTLY SPECIFIED')
GO TO 899
513 PRINT 514
514 FORMAT(' NUMBER OF CASES IS GREATER THAN 32,000')
899 WRITE (6,898)
898 FORMAT (44H0PROBLEM CARD ERROR..PROGRAM CANNOT CONTINUE )
GO TO 900
815 DO 26 J=1,200
X(J)=0.0
26 CONTINUE
NOMEET=0
BADVAL = 0
IF(MISCRD)5,5,4
4 CALL MISVAL
5 IF(NTRG)6,6,55
55 CALL TRANS
6 IF(NROWS)509,7,56
56 CALL BOLSEL
7 READ (5,101)(ICAT(L),CAT(L),L=1,NROWS)
101 FORMAT (8(I3,F6.0))
NI=1
NVFF=NVFC*18
READ (5,102)(FMT(J),J=1,NVFF)
102 FORMAT (18A4)
WRITE (6,122)
122 FORMAT (20H0 VARIABLE FORMAT )
WRITE (6,123)(FMT(J),J=1,NVFF)
123 FORMAT (1X,18A4)
IF(NIT)84,84,85
85 IF(NIT.NE.6)GO TO 81
PRINT 515
515 FORMAT(' INPUT TAPE CANNOT BE ON UNIT 6')
GO TO 899
83 PRINT 516
516 FORMAT(' IT IS ILLEGAL TO WRITE ON TAPE UNITS 5 OR 6')
GO TO 899
84 NIT=5
81 IF(NIT-5)2,70,2
2 REWIND NIT
70 IF(NWRITE.EQ.5.OR.NWRITE.EQ.6)GO TO 83
IF(NWRITE.LE.0)GO TO 71
REWIND NWRITE
DO 74 K=1,NCARDS
DO 73 L=1,NCASE
READ (NIT,300)(NUSE(J),J=1,16)
300 FORMAT (16A5)
WRITE (NWRITE,300)(NUSE(J),J=1,16)
73 CONTINUE
74 CONTINUE
END FILE NWRITE
REWIND NWRITE
NIT=NWRITE
71 DO 110 JKL=1,NCASE
NOCASE=JKL
75 READ (NIT,FMT)(X(J),J=1,NVAR)
IF(MISCRD)756,756,755
755 CALL MISVAL
756 IF(NTRG)77,77,76
76 IF(NADVAR)765,765,761
761 NZER=NVAR+1
DO 764 NZERO=NZER,NTVAR
X(NZERO)=0.0
764 CONTINUE
765 CALL TRANS
77 IF(NROWS)79,78,79
78 ROWS=1.0
ROWNO(1)=1.0
GO TO 757
79 CALL BOLSEL
IF(ROWS)14,14,757
14 NOMEET=NOMEET+1
GO TO 110
757 NNROWS=ROWS+.5
6543 FORMAT(10F7.2)
DO 790 M=1,NNROWS
L=ROWNO(M)+.5
15 ICATL=ICAT(L)
NTOTL(L)=NTOTL(L)+1
IF(X(ICATL)-CAT(L))12,11,11
11 K=1
GO TO 3
12 K=2
3 DO 103 J=1,NTVAR
IF(X(J).EQ.BLANK)GO TO 103
16 N(J,K,L)=N(J,K,L)+1
SUM(J,K,L)=SUM(J,K,L)+X(J)
SUMSQ(J,K,L)=SUMSQ(J,K,L)+(X(J)*X(J))
103 CONTINUE
790 CONTINUE
110 CONTINUE
DO 200 L=1,NROWS
IF(NTOTL(L))700,700,111
700 WRITE (6,112)L,NTOTL(L)
112 FORMAT (19H1SUB-PROBLEM NUMBER ,I3,9H CONTAINS ,I6,6H CASES,29X,
159H* POOLED VARIANCE ESTIMATE * SEPARATE VARIANCE ESTIMATE )
GO TO 200
111 KOUNT=8
DO 199 J=1,NTVAR
XN1=N(J,1,L)
XN2=N(J,2,L)
XBAR=0.
VARX=0.
VAXBAR=0.
YBAR=0.
VARY=0.
VAYBAR=0.
IF(XN1.LE.0.)GO TO 1111
XBAR=SUM(J,1,L)/XN1
IF(XN1.LT.2.)GO TO 1111
VARX=(SUMSQ(J,1,L)-((SUM(J,1,L)*SUM(J,1,L))/XN1))/(XN1-1.0)
SS=SUMSQ(J,1,L)*.00001
IF(SS.GT.VARX)VARX=0.
VAXBAR=VARX/XN1
1111 IF(XN2.LE.0.)GO TO 1112
YBAR=SUM(J,2,L)/XN2
IF(XN2.LT.2.)GO TO 1112
VARY=(SUMSQ(J,2,L)-((SUM(J,2,L)*SUM(J,2,L))/XN2))/(XN2-1.0)
SS=SUMSQ(J,2,L)*.00001
IF(SS.GT.VARY)VARY=0.
VAYBAR=VARY/XN2
1112 IF(VARX-VARY)114,113,113
113 FXY=0.
IF(VARY.GT.0.)FXY=VARX/VARY
XM1(1)=0.0
XM2(1)=0.0
IF(XN1.GT.0.)XM1(1)=XN1-1.
IF(XN2.GT.0.)XM2(1)=XN2-1.
GO TO 115
114 FXY=0.
IF(VARX.GT.0.)FXY=VARY/VARX
XM1(1)=0.0
XM2(1)=0.0
IF(XN2.GT.0.)XM1(1)=XN2-1.
IF(XN1.GT.0.)XM2(1)=XN1-1.
115 SDX=SQRT(VARX)
SDY=SQRT(VARY)
SEXBAR=SQRT(VAXBAR)
SEYBAR=SQRT(VAYBAR)
DENOM=XM1(1)+XM2(1)
TERM2=0.
IF(DENOM.GT.0.)
1TERM2=((VARX*(XN1-1.0))+((XN2-1.0)*VARY))/DENOM
RECIP1=0.
IF(XN1.GT.0.)RECIP1=1./XN1
RECIP2=0.
IF(XN2.GT.0.)RECIP2=1./XN2
DENOM= SQRT(((RECIP1 )+(RECIP2 ))*TERM2)
TP=0.
IF(DENOM.GT.0.)TP=(XBAR-YBAR)/DENOM
DENOM= SQRT(VAXBAR+VAYBAR)
TS=0.
IF(DENOM.GT.0.)TS=(XBAR-YBAR)/DENOM
NDEGP=N(J,1,L)+N(J,2,L)-2
IF(N(J,1,L).LE.0)NDEGP=N(J,2,L)-1
IF(N(J,2,L).LE.0)NDEGP=N(J,1,L)-1
IF(N(J,1,L).LE.0.AND.N(J,2,L).LE.0)NDEGP=0
DEGS=0.
IF(VAXBAR.LE.0..AND.VAYBAR.LE.0.)GO TO 2060
DEGX=0.
IF(VAXBAR.GT.0.)
1DEGX=(1.0/(XN1-1.0))*(VAXBAR/(VAXBAR+VAYBAR))*(VAXBAR/(VAXBAR+VAYB
2AR))
DEGY=0.
IF(VAYBAR.GT.0.)
1DEGY=(1.0/(XN2-1.0))*(VAYBAR/(VAXBAR+VAYBAR))*(VAYBAR/(VAXBAR+VAYB
2AR))
DEGS=1.0/(DEGX+DEGY)
2060 IF(YES.NE.YESP)GO TO 208
207 XM2(2)=NDEGP
XM2(3)=DEGS
NM = N(J,1,L) - 1
NN = N(J,2,L) - 1
IF(FXY) 30,30,31
30 P(1) = 1.0
GO TO 1031
31 P(1)=(1-FCDF(FXY,NM,NN))*2
1031 IF(TP) 33,32,33
32 P(2) = 1.0
GO TO 1033
33 P(2) = (1-TCDF(ABS(TP),NDEGP))*2
1033 IF(TS) 35,34,35
34 P(3) = 1.0
GO TO 208
35 NDEGS = DEGS
P(3) = (1-TCDF(ABS(TS),NDEGS))*2
C
C
208 KOUNT=KOUNT+1
IF(KOUNT-8 )210,210,209
209 WRITE (6,112)L,NTOTL(L)
WRITE (6,120)
WRITE (6,920)
920 FORMAT(131H VARIABLE NUMBER STANDARD STANDARD
1* F P * T DEGREES P * T DEGREE
2S P )
KOUNT=1
WRITE (6,201)
201 FORMAT(132H INDEX OF CASES MEAN DEVIATION ERROR
1* VALUE VALUE * VALUE OF FREEDOM VALUE * VALUE OF FREED
2OM VALUE )
WRITE (6,202)
202 FORMAT (1X,131(1H*))
210 WRITE (6,120)
WRITE (6,120)
120 FORMAT (55X,1H*,16X,1H*,29X,1H*)
SDX=CKZER(SDX)
SEXBAR=CKZER(SEXBAR)
WRITE (6,203)N(J,1,L),XBAR,SDX,SEXBAR
203 FORMAT (1H ,8X,1HX,2X,I5,1X,F12.4,1X,F10.3,1X,F10.3,3X,1H*,16X,1H*
129X,1H*)
FXY=CKZER(FXY)
TP=CKZER(TP)
TS=CKZER(TS)
DEGS=CKZER(DEGS)
IF (YESP.NE.YES) P(1)=9.0E30
WRITE (6,104)J,FXY,P(1),TP,NDEGP,P(2),TS,DEGS,P(3)
104 FORMAT (3X,I3,49X,2H* ,F6.2,2X, F5.3 ,2X,1H*,F7.2,5X,I5,5X, F5.3
1 ,2X,1H*,F7.2,4X,F8.2,5X, F5.3 )
SDY=CKZER(SDY)
SEYBAR=CKZER(SEYBAR)
WRITE (6,105)N(J,2,L),YBAR,SDY,SEYBAR
105 FORMAT (1H ,8X,1HY,2X,I5,1X,F12.4,1X,F10.3,1X,F10.3,3X,1H*,16X,1H*
129X,1H*)
WRITE (6,120)
WRITE (6,121)
121 FORMAT (1X,131(1H-))
199 CONTINUE
200 CONTINUE
WRITE (6,108)NOMEET
108 FORMAT (57H1NUMBER OF CASES NOT INCLUDED IN DESIGNATED SUB-PROBLEM
1S= ,I5)
NBAD=BADVAL+.5
WRITE (6,600)NBAD
600 FORMAT (74H NUMBER OF INSTANCES IN WHICH TRANSGENERATION RESTRICTI
1ONS WERE VIOLATED = ,I5)
IF(NIT-5)901,902,901
901 REWIND NIT
902 IF(NWRITE)80,80,903
903 REWIND NWRITE
904 GO TO 80
900 STOP
END
C SUBROUTINE BOLSEL OF BMDX70 JUNE 20, 1966
SUBROUTINE BOLSEL
DOUBLE PRECISION CON(20,8)
DIMENSION X(200),DATA(200),NBOOL(20),ROWNO(20),NSUB(20,8),REL(20,8
1), OP(20,8),IN(9),WK(9)
2,F(3),XM1(3),XM2(3),P(3)
COMMON X
COMMON NTRG , NADVAR , NI , ROWNO , FAIL , MISCRD
COMMON ERROR , NOW , VALS , NTVAR , NOCASE , BADVAL
COMMON ROWS , NROWS , VARG , CTOT , XL1 , XL2
COMMON F , XM1 , XM2 , P
EQUIVALENCE (X,DATA)
DATA A1,WK ,ASK/1HV,2HGT,2HGE,2HLT,2HLE,2HEQ,2HNE,
1'ERR.','OR','AN','**'/
DATA BLANK /' '/
IF(NI-1)399,502,502
399 DO 500 NB=1,NROWS
NERROR=0
NBGIN=1
NFIN=4
4000 READ (5,401)(NSUB(NB,I),REL(NB,I),CON(NB,I),OP(NB,I),I=NBGIN,NFIN)
401 FORMAT (4(3X,I3,1X,A2, A6,1X,A2))
DO 4004 I=NBGIN,NFIN
INOW=I
415 IF(OP(NB,I).EQ.WK(8))GO TO 4004
416 IF(OP(NB,I).EQ.WK(9))GO TO 4004
417 IF(OP(NB,I).EQ.ASK)GO TO 418
400 NERROR=1
4004 CONTINUE
IF(NFIN-4)4001,4001,4003
4001 NBGIN=5
NFIN=8
GO TO 4000
4003 WRITE (6,4002)NB
4002 FORMAT (49H NO ** OPERATION WAS ENCOUNTERED FOR SUB-PROBLEM ,I2,
151H...PROGRAM WILL READ TWO CARDS FOR THIS SUB-PROBLEM )
418 NBOOL(NB)=INOW
IF(INOW-4)4081,4081,4082
4081 KK=INOW
GO TO 4083
4082 KK=4
4083 WRITE (6,404)NB,(NSUB(NB,I),REL(NB,I),CON(NB,I),OP(NB,I),I=1,KK)
404 FORMAT (37H0CASE WILL BE INCLUDED IN SUB-PROBLEM ,I3,3H IF,
14(2HV(,I3,1H)1X,A2,1X,A6,1X,A2,1X))
IF(INOW-4)4088,4088,4086
4086 KK=INOW
WRITE (6,4041)(NSUB(NB,I),REL(NB,I),CON(NB,I),OP(NB,I),I=5,KK)
4041 FORMAT (43X,4(2HV(,I3,1H),1X,A2, 1X,A6,1X,A2,1X))
4088 DO 420 I=1,KK
REWIND 1
WRITE (1,405)CON(NB,I)
405 FORMAT (A6)
REWIND 1
READ (1,406)PUS
406 FORMAT (A1)
REWIND 1
IF(A1.NE.PUS)GO TO 409
407 READ (5,408)CON(NB,I)
408 FORMAT (3X,F3.0)
IF(CON(NB,I)-200.0)411,411,421
411 CON(NB,I)=CON(NB,I)+100000.0
GO TO 412
409 READ (1,410)CON(NB,I)
410 FORMAT (F6.0)
412 IF(NSUB(NB,I)-200)413,413,421
413 DO 414 J=1,6
IF(REL(NB,I).EQ.WK(J))GO TO 420
414 CONTINUE
GO TO 421
420 CONTINUE
IF(ERROR)500,500,421
421 DO 422 I=1,KK
REL(NB,I)=WK(7)
422 CONTINUE
WRITE (6,423)
423 FORMAT (91H BOOLEAN SELECTION CARD(S) FOR ABOVE SUB-PROBLEM HAS ER
1ROR(S)...SUB-PROBLEM WILL BE SKIPPED )
500 CONTINUE
RETURN
502 M=0
DO 600 NB=1,NROWS
KK=NBOOL(NB)
DO 100 I=1,KK
IS=NSUB(NB,I)
DO 55 J=1,6
IF(REL(NB,I).EQ.WK(J))GO TO 26
55 CONTINUE
GO TO 600
26 CONNB=SNGL(CON(NB,I))
IF(CONNB-100000.0)27,27,28
27 CC=CONNB
GO TO 29
28 K=CONNB-100000.0+.5
CC=DATA(K)
29 CONTINUE
7654 FORMAT(2F15.2)
GO TO (1,2,3,4,5,6),J
1 IF(DATA(IS)-CC) 50,50,20
2 IF(DATA(IS)-CC) 50,20,20
3 IF(DATA(IS)-CC) 20,50,50
4 IF(DATA(IS)-CC) 20,20,50
5 IF(DATA(IS)-CC) 50,20,50
6 IF(DATA(IS)-CC) 20,50,20
20 IN(I)=1
IGOOD=I
GO TO 100
50 IN(I)=0
IGOOD=I
100 CONTINUE
IN(IGOOD+1)=0
NTEST=IN(1)
C
C EXAMINE BOOLEAN OPERATOR FOR OR/AN
C
DO 200 I=1,KK
IF(OP(NB,I).EQ.WK(9))GO TO 223
191 IF(NTEST) 199,199,321
199 NTEST=IN(I+1)
GO TO 200
223 NTEST=NTEST*IN(I+1)
200 CONTINUE
IF(NTEST)600,600,321
321 M=M+1
ROWNO(M)=NB
600 CONTINUE
8765 FORMAT(I3)
ROWS=M
RETURN
END
C FUNCTION CKZER FOR BMDX70 JUNE 20 1966
C IF THE ARGUMENT IS ZERO IT IS FORCED POSITIVE ZERO.
FUNCTION CKZER(X)
IF(X.NE.0.0)GO TO 10
CKZER=0.0
GO TO 15
10 CKZER=X
15 RETURN
END
C SUBROUTINE MISVAL FOR BMDX70 JUNE 20, 1966
SUBROUTINE MISVAL
EXTERNAL SIGN
DIMENSION X(200),NVAR(200),NV(200),VAL(200,10),ROWNO(20),AVAL(10)
1,F(3),XM1(3),XM2(3),P(3)
COMMON X , NTRG , NADVAR , NI , ROWNO , FAIL
COMMON MISCRD , ERROR , NOW , VALS , NTVAR , NOCASE
COMMON BADVAL , ROWS , NROWS , VARG , CTOT , XL1
COMMON XL2 , F , XM1 , XM2 , P
IF(NI)1,1,3
1 WRITE (6,800)
800 FORMAT (20H0 MISSING NUMBER OF )
WRITE (6,801)
801 FORMAT (111H VARIABLE VALUES VALUE 1 VALUE 2 VALUE 3 VALUE
1 4 VALUE 5 VALUE 6 VALUE 7 VALUE 8 VALUE 9 VALUE 10 )
DATA BLANK/' '/
NTOT=NTVAR-NADVAR
DO 10 M=1,MISCRD
READ (5,100)NVAR(M),NV(M),(VAL(M,J),J=1,10)
100 FORMAT (2I4,10F6.0)
IF(NV(M)-10)700,700,701
701 NV(M)=10
PRINT 400
400 FORMAT(' NUMBER OF MISSING VALUES IS INCORRECTLY SPECIFIED, ASSUME
1D TO BE 10')
700 NVV=NV(M)
WRITE (6,802)NVAR(M),NV(M),(VAL(M,J),J=1,NVV)
802 FORMAT (1H0,2X,I3,9X,I2,5X,10(F8.2,1X))
IF(NVAR(M).LE.199)GO TO 41
PRINT 401
401 FORMAT(' VARIABLE INDEX IS GREATER THAN 199')
900 WRITE (6,901)
901 FORMAT (66H ABOVE MISSING VALUE CARD CONTAINS AN ERROR...CARD WILL
1 BE IGNORED )
NVAR(M)=200
GO TO 10
41 IF(NVAR(M))18,18,10
18 IF(MISCRD-1)20,20,900
10 CONTINUE
RETURN
20 DO 25 K=1,NTOT
NV(K)=NV(1)
NVAR(K)=K
NVALL=NV(1)
DO 24 J=1,NVALL
VAL(K,J)=VAL(1,J)
24 CONTINUE
25 CONTINUE
MISCRD=NTOT
RETURN
3 DO 90 M=1,MISCRD
NOW=NVAR(M)
NVNVAR=NV(M)
DO 30 J=1,NVNVAR
14 IF(X(NOW)-VAL(M,J))30,15,30
15 IF(VAL(M,J))80,12,80
12 IF(SIGN(1.0,VAL(M,J)))11,90,13
11 IF(SIGN(1.0,X(NOW)))80,90,30
13 IF(SIGN(1.0,X(NOW)))30,90,80
30 CONTINUE
GO TO 90
80 X(NOW)=BLANK
90 CONTINUE
RETURN
END
C FUNCTION FCDF FOR BMDX70 OCT.2,1968
FUNCTION FCDF(FR,M,N)
F CDF=0.
CON=1.
IF((M-M/2*2).EQ.0)GO TO 80
IF((N-N/2*2).EQ.0)GO TO 60
IF(N.NE.1)GO TO 5
THETA=ATAN(SQRT(N/(M*FR)))
J=M/2
GO TO 7
5 THETA=ATAN(SQRT(M*FR/N))
J=N/2
7 SINE=SIN(THETA)
SINSQ=SINE*SINE
COSQ=1-SINSQ
COSN=SQRT(COSQ)
IF((M.EQ.1).AND.(N.EQ.1))GO TO 50
DO 10 I=1,J
F CDF=F CDF+CON
TWI=2*I
10 CON=CON*TWI*COSQ/(TWI+1)
50 FCDF=1.-2.*(FCDF*SINE*COSN+THETA)/3.14159
IF(N.EQ.1)RETURN
F CDF=1.-F CDF
IF(M.EQ.1)RETURN
FCTR=CON
CON=1.
PFP=0.
NM1=N-1
J=M/2
DO 20 I=1,J
PFP=PFP+CON
TWI=2*I
20 CON=CON*(NM1+TWI)*SINSQ/(TWI+1)
FCDF=FCDF-2.*N*FCTR*SINE*COSN*PFP/3.14159
RETURN
60 X=N/(N+M*FR)
J=N/2
MS2=M-2
GO TO 85
80 X=M*FR/(N+M*FR)
J=M/2
MS2=N-2
85 OWX=1.-X
DO 90 I=1,J
F CDF=F CDF+CON
TWI=2*I
90 CON=CON*(MS2+TWI)*X/TWI
IF(M-M/2*2)100,95,100
95 FCDF=1.-OWX**(N/2.)*FCDF
RETURN
100 FCDF=OWX**(M/2.)*FCDF
RETURN
END
C FUNCTION TCDF FOR BMDX70 OCT.2,1968
FUNCTION TCDF(STT,N)
IF(STT.NE.0.)GO TO 1
TCDF=.5
RETURN
1 T=ABS(STT)
B=N
THETA=ATAN(T/SQRT(B))
C=SIN(THETA)
COSN=COS(THETA)
COSQ=COSN*COSN
TCDF=0.
IF(N.EQ.1)GO TO 20
A=N/2.
NUM=N-N/2*2+1
10 TCDF=TCDF+C
A=A-1.
D=NUM+1.
C=C*NUM*COSQ/D
NUM=NUM+2
IF(A-0.5)30,20,10
20 TCDF =(THETA+TCDF *COSN)/1.570796
30 TCDF=.5+SIGN(.5*TCDF,STT)
RETURN
END
C SUBROUTINE TRANS FOR BMDX70 JUNE 20, 1966
SUBROUTINE TRANS
DOUBLE PRECISION LTRAN
EXTERNAL SIGN
DIMENSION CONS(100,7),CONST(100),X(200),KODE(100),NCON40(100),
1NTRAN(100),NOTRAN(100),DATA(200),ROWNO(20)
2,F(3),XM1(3),XM2(3),P(3)
COMMON X
COMMON NTRG , NADVAR , NI , ROWNO , FAIL , MISCRD
COMMON ERROR , NOW , VALS , NTVAR , NOCASE , BADVAL
COMMON ROWS , NROWS , VARG , CTOT , XL1 , XL2
COMMON F , XM1 , XM2 , P
ASN(XX)=ATAN(XX/SQRT(1.0-XX**2))
EQUIVALENCE (X,DATA)
IF(NI)200,200,299
200 WRITE (6,301)
301 FORMAT (43H0 NEW OLD B VAR. NUMBER OF )
WRITE (6,302)
302 FORMAT (68H VAR. CODE VAR. OR CONST. CONSTANTS TYPE
1 40 CONSTANTS )
DATA BLANK/' '/
DO 210 I=1,NTRG
READ (5,300)LTRAN,NTRAN(I),KODE(I),NOTRAN(I),CONST(I), NCON40(I),(
1CONS(I,J),J=1,7)
300 FORMAT (A6,I3,I2,I3,F6.0,5X,I1,7F6.0)
IF(NCON40(I))307,307,306
306 ICON40=NCON40(I)
WRITE (6,303)NTRAN(I),KODE(I),NOTRAN(I),CONST(I),NCON40(I),(CONS(I
1,J),J=1,ICON40)
303 FORMAT (2X,I3,2(4X,I3),5X,F8.2,7X,I1,8X,7(F8.2,1X))
GO TO 309
307 WRITE (6,308)NTRAN(I),KODE(I),NOTRAN(I),CONST(I)
308 FORMAT(2X,I3,2(4X,I3),5X,F8.2)
309 IF(NTRAN(I)-200)304,304,801
304 IF(NOTRAN(I)-200)305,305,803
305 IF(NCON40(I)-7)310,310,805
801 PRINT 802
802 FORMAT(' INDEX OF NEW VARIABLE IS GREATER THAN 200')
GO TO 800
803 PRINT 804
804 FORMAT(' INDEX OF OLD VARIABLE IS GREATER THAN 200')
GO TO 800
805 PRINT 806
806 FORMAT(' NUMBER OF CONSTANTS IS GREATER THAN 7')
GO TO 800
310 IF(KODE(I)-41)311,311,399
311 K=KODE(I)
GO TO(210,210,210,210,210,399,210,210,210,210,320,320,320,320,
1210,320,210,399,399,210,210,210,320,210,399,399,399,399,399,399,
2399,399,399,399,399,399,399,399,399,210,210 ),K
320 IF(CONST(I)-200.0)210,210,807
807 PRINT 808
808 FORMAT(' INDEX OF VARIABLE B IS GREATER THAN 200')
GO TO 800
399 WRITE (6,398)
398 FORMAT(' ABOVE TRANSGENERATION CARD HAS AN ILLEGAL CODE FOR THIS
1PROBLEM')
GO TO 397
800 WRITE (6,850)
850 FORMAT(' ABOVE TRANSGENERATION CARD HAS AN ERROR')
397 KODE(I)=42
210 CONTINUE
BADVAL=0.0
RETURN
299 DO 1000 I=1,NTRG
N=NOTRAN(I)
M=NTRAN(I)
K=KODE(I)
D1=DATA(N)
IF(D1.NE.BLANK)GO TO 700
600 D2=D1
GO TO 100
700 GO TO(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,
124,197,197,197,197,197,197,197,197,197,197,197,197,197,197,197,40,
241,1000),K
1 IF(D1)198,107,108
107 D2=0.0
GOTO100
108 D2=SQRT(D1)
GOTO100
2 IF(D1)198,111,112
111 D2=1.0
GOTO100
112 D2=SQRT(D1)+SQRT(D1+1.0)
GOTO100
3 IF(-D1)114,198,198
114 D2=ALOG10(D1)
GOTO100
4 D2=EXP(D1)
GOTO100
5 IF(-D1)117,107,198
117 IF(D1-1.0)118,119,119
118 D2=ASN(SQRT(D1))
GOTO100
119 D2=3.14159265/2.0
GOTO100
6 GO TO 197
7 IF(D1)131,198,131
131 D2=1.0/D1
GOTO100
8 D2=D1+CONST(I)
GOTO100
9 D2=D1*CONST(I)
GOTO100
10 IF(-D1)133,107,198
133 D2=D1**CONST(I)
GOTO100
11 NEWB=CONST(I)
D2=D1+DATA(NEWB)
GO TO 205
12 NEWB=CONST(I)
D2=D1-DATA(NEWB)
GO TO 205
13 NEWB=CONST(I)
D2=D1*DATA(NEWB)
GO TO 205
14 NEWB=CONST(I)
IF(DATA(NEWB))134,605,134
134 D2=D1/DATA(NEWB)
GO TO 205
15 IF(D1-CONST(I))107,111,111
16 NEWB=CONST(I)
IF(DATA(NEWB).EQ.BLANK)GO TO 601
602 IF(D1-DATA(NEWB))107,111,111
17 IF(-D1)163,198,198
163 D2=ALOG(D1)
GO TO 100
18 GO TO 197
19 GO TO 197
20 D2=SIN(D1)
GO TO 100
21 D2=COS(D1)
GO TO 100
22 D2=ATAN(D1)
GO TO 100
23 NEWB=CONST(I)
IF(-D1)188,198,198
188 D2=D1**DATA(NEWB)
205 IF(DATA(NEWB).EQ.BLANK)GO TO 601
GO TO 100
24 IF(CONST(I)) 198,198,189
189 D2=CONST(I)**D1
GO TO 100
40 L=NCON40(I)
DO 166 J=1,L
IF(D1-CONS(I,J))166,165,166
165 C=SIGN(1.0,D1)
D=SIGN(1.0,CONS(I,J ))
IF(C+D) 167,166,167
166 CONTINUE
GO TO 1000
41 IF(D1)1000,168,1000
168 C=SIGN(1.0,D1)
D=1.0
IF(C+D)1000,167,1000
167 D2=CONST(I)
GO TO 100
197 GO TO 1000
605 N=NEWB
198 IF(BADVAL-100.0)606,607,607
606 WRITE (6,201)N,NOCASE,K
201 FORMAT (16H VARIABLE NUMBER,I3,8H OF CASE,I5,45H VIOLATED RESTRICT
1ION OF TRANSGENERATION CODE ,I2)
607 BADVAL=BADVAL+1.0
601 D2=BLANK
100 DATA(M)=D2
1000 CONTINUE
RETURN
END