Trailing-Edge
-
PDP-10 Archives
-
decuslib10-06
-
43,50422/cmod90.bas
There are 2 other files named cmod90.bas in the archive. Click here to see a list.
00020REM ***************************************************************
00030REM ***************************************************************
00040REM CMOD90 CMOD90 CMOD90 CMOD90 CMOD90 CMOD90
00050REM
00060REM ***************************************************************
00070REM QUOTA-FREE SELECTION
00080REM ***************************************************************
00090X=0
00100 DIM U(4)
00110 E$="REENTER. UTILITY MUST BE GREATER THAN 0 AND LESS THAN 1."
00120 A$="ABCD"
00130 FILES RFILE1,RFILE2,RFILE3
00170RESTORE#1
00171 INPUT# 1,I1,I2,I3
00180SCRATCH#1
00181 PRINT # 1,90,I2,I3
00190X=0
00200GOSUB 6060
00210PRINT L$
00220PRINT " OPTIMAL SELECTION USING THRESHOLD UTILITY"
00230PRINT
00240PRINT "THE THRESHOLD UTILITY MODEL IMPLIES THAT SUCCESS IS AN ALL OR"
00250PRINT "NONE PHENOMENON - EITHER A PERSON IS OR IS NOT SUCCESSFUL WITH"
00260PRINT "RESPECT TO A CRITERION."
00270PRINT
00280GOSUB 370
00290PRINT
00300PRINT "THERE IS A CRITERION VALUE THAT SEPARATES THE SUCCESSFUL FROM"
00310PRINT "THE UNSUCCESSFUL."
00320PRINT
00330PRINT "WHAT IS THIS CRITERION VALUE";
00340GOSUB 9000
00350C7=O1
00360GOTO 420
00370PRINT "IT IS ASSUMED THAT THERE IS ONE PREDICTOR AND THE PREDICTION "
00380PRINT "EQUATION IS LINEAR. THE PREDICTOR IS ASSUMED TO BE NORMALLY"
00390PRINT "DISTRIBUTED."
00400GOSUB 1820
00410RETURN
00420PRINT L$
00430PRINT "THIS TABLE SHOWS THE UTILITY STRUCTURE."
00440S7=1
00450GOSUB 470
00460GOSUB 790
00470PRINT
00480:CRITERION =#######.##
00490PRINT " I---------- DECISION -----------I"
00500PRINT " I REJECT I ACCEPT I"
00510PRINT "I---OUTCOME---I--------------I----------------I"
00520PRINT "I I I I"
00530IF S7=1 THEN 570
00540:I SUCCESSFUL I ##.## I ##.## I
00550PRINT USING 540,B,A
00560GOTO 580
00570PRINT "I SUCCESSFUL I B I A I"
00580PRINT "I I I I"
00590PRINT "I I--------------I----------------I"
00600PRINT "I I I I"
00610IF S7=1 THEN 650
00620:I UNSUCCESSFULI ##.## I ##.## I
00630PRINT USING 620,C,D
00640GOTO 660
00650PRINT "I UNSUCCESSFULI C I D I"
00660PRINT "I I I I"
00670PRINT "I-------------I--------------I----------------I"
00680PRINT
00690IF S7=0 THEN 780
00700GOTO 750
00710PRINT " A = UTILITY OF ACCEPTING SUCCESSFUL APPLICANT"
00720PRINT " B = UTILITY OF REJECTING SUCCESSFUL APPLICANT"
00730PRINT " C = UTILITY OF REJECTING UNSUCCESSFUL APPLICANT"
00740PRINT " D = UTILITY OF ACCEPTING UNSUCCESSFUL APPLICANT"
00750PRINT "CONSTRAINTS: A GREATER THAN B A GREATER THAN D"
00760PRINT " C GREATER THAN B C GREATER THAN D"
00770PRINT
00780RETURN
00790PRINT "TYPE THE APPROPRIATE NUMBER TO INDICATE IF A OR C IS GREATER."
00800MAT U=CON
00810MAT U=(7)*U
00820PRINT "A IS GREATER = 1 C IS GREATER = 2 A AND C ARE THE SAME = 3";
00830GOSUB 9000
00840IF O1=3 THEN 890
00850IF O1=1 THEN 940
00860IF O1=2 THEN 920
00870PRINT "REENTER. INPUT MUST BE THE NUMBER OF OPTION."
00880GOTO 830
00890U(1)=1
00900U(3)=1
00910GOTO 950
00920U(3)=1
00930GOTO 950
00940U(1)=1
00950PRINT
00960PRINT "TYPE THE APPROPRIATE NUMBER TO INDICATE IF B OR D IS GREATER."
00970PRINT "B IS GREATER = 1 D IS GREATER = 2 B AND D ARE THE SAME = 3";
00980GOSUB 9000
00990IF O1=1 THEN 1070
01000IF O1=2 THEN 1090
01010IF O1=3 THEN 1040
01020PRINT "REENTER. INPUT MUST BE NUMBER OF OPTION."
01030GOTO 980
01040U(2)=0
01050U(4)=0
01055IF U(1) <> 1 THEN 1100
01056IF U(3) <> 1 THEN 1100
01060GOTO 1290
01070U(4)=0
01080GOTO 1100
01090U(2)=0
01100PRINT L$
01110PRINT "LET THE FOLLOWING VALUES BE ASSIGNED."
01120FOR I=1 TO 4
01130IF U(I)=0 THEN 1160
01140IF U(I) <> 1 THEN 1170
01150: ' =##.##
01160 PRINT USING 1150,MID$(A$,I,I-(I)+1),U(I)
01170NEXT I
01180FOR I=1 TO 4
01190IF U(I)=0 THEN 1280
01200IF U(I)=1 THEN 1280
01210 PRINT "INPUT THE VALUE OF ";MID$(A$,I,I-(I)+1);" (BETWEEN 0 AND 1).";
01220GOSUB 9000
01230IF O1>0 THEN 1260
01240 PRINT E$;
01250GOTO 1220
01260IF O1 >= 1 THEN 1240
01270U(I)=O1
01280NEXT I
01290A=(U(1))
01300B=(U(2))
01310C=(U(3))
01320D=(U(4))
01330IF A>B THEN 1380
01340IF D>A THEN 1350
01350PRINT "REENTER. OBSERVE CONSTRAINTS A>B A>D C>B C>D"
01360GOTO 1180
01370CHAIN "RSTRT"
01380IF C <= D THEN 1350
01390IF C <= B THEN 1350
01400PRINT L$
01410S7=0
01420GOSUB 470
01430P4=(A-B)/(C-D+A-B)
01440:THRESHOLD CRITERION VALUE #######.##
01450PRINT USING 1440,C7
01460:REQUIRED PROBABILITY OF SUCCESS ##.##
01470PRINT USING 1460,1-P4
01480GOSUB 2350
01490IF P6=1 THEN 1780
01500IF P6=0 THEN 1760
01510G=2000
01520J6=(X6-X5)/D6
01530J2=ABS(J6)
01540GOSUB 6000
01550IF J6 >= 0 THEN 1580
01560P=1-P
01570:PREDICTOR CUT SCORE #######.##
01580PRINT USING 1570,X6
01590:PERCENTAGE OF APPLICANTS ACCEPTED ####
01600PRINT USING 1590,100-100*P
01610PRINT
01620PRINT "IF YOU WANT TO CHANGE THE UTILITIES TYPE '1', ELSE '0'.";
01630GOSUB 9000
01640IF O1=1 THEN 790
01650PRINT "IF YOU WANT TO CHANGE THE CRITERION VALUE TYPE '1', ELSE '0'.";
01660GOSUB 9000
01670IF O1=1 THEN 1720
01680PRINT "IF YOU WANT TO CHANGE THE DATA SET TYPE '1', ELSE '0'.";
01690GOSUB 9000
01700IF O1=1 THEN 1800
01710CHAIN "RSTRT"
01720PRINT "WHAT IS THE NEW CRITERION VALUE";
01730GOSUB 9000
01740C7=O1
01750GOTO 1400
01760PRINT "ALL APPLICANTS SHOULD BE ACCEPTED."
01770GOTO 1610
01780PRINT "ALL APPLICANTS SHOULD BE REJECTED."
01790GOTO 1610
01800GOSUB 1820
01810GOTO 1400
01820PRINT
01830PRINT "THERE IS A DEMONSTRATION DATA SET."
01840PRINT
01850PRINT "IF YOU WANT TO USE THE DEMONSTRATION DATA TYPE '1', ELSE '0'.";
01860GOSUB 9000
01870Z8=O1
01880I=1
01890GOSUB 2710
01900X=0
01910X5=P(2,1)
01920Y6=P(4,1)
01930B6=P(5,1)*P(6,1)/P(3,1)
01940W6=P(1,1)
01950V6=W6*P(3,1)*P(3,1)
01960S5=P(5,1)*P(5,1)*(1-P(6,1)*P(6,1))*W6
01970D6=P(3,1)
01980G=W6-2
01990PRINT L$
02000PRINT "HERE ARE THE SAMPLE DATA."
02010PRINT
02020:1. SAMPLE SIZE N ######
02030PRINT USING 2020,P(1,1)
02040:2. MEAN OF PREDICTOR X. ######.####
02050PRINT USING 2040,P(2,1)
02060:3. ST. DEV. OF PREDICTOR S.D.X######.####
02070PRINT USING 2060,P(3,1)
02080:4. MEAN OF CRITERION Y. ######.####
02090PRINT USING 2080,P(4,1)
02100:5. ST. DEV. OF CRITERION S.D.Y######.####
02110PRINT USING 2100,P(5,1)
02120:6. CORRELATION COEFFICIENT R ######.####
02130PRINT USING 2120,P(6,1)
02140PRINT
02150PRINT "IF THESE ARE THE DATA YOU WANT TYPE '1', ELSE '0'.";
02160GOSUB 9000
02170IF O1=0 THEN 1850
02180IF O1=1 THEN 2200
02190 GOTO 2150
02200RETURN
02210REM
02220REM FINDING THE PREDICTIVE DISTRIBUTION FOR GROUP 1
02230REM
02240M6=Y6+B6*(X6-X5)
02250S6=S5*(1+1/W6+(X6-X5)*(X6-X5)/V6)
02260G=W6-2
02270J6=(C7-M6)/SQR(S6/G)
02280IF Z7=1 THEN 2530
02290J2=ABS(J6)
02300GOSUB 6000
02310IF J6 >= 0 THEN 2330
02320P=1-P
02330RETURN
02340REM LOOKING FOR P4
02350Z7=1
02360P2=P4
02370G=W6-2
02380GOSUB 5000
02390Q2=J2
02400E0=X5-4*D6
02410E1=X5+4*D6
02420IF P4>.5 THEN 2470
02430E0=B6*X5-Y6+C7-Q2*SQR(S5/W6+S5/W6/W6)
02440E0=E0/B6
02450X6=E0+.001*(E1-E0)
02460GOTO 2520
02470E1=B6*X5-Y6+C7-Q2*SQR(S5/W6+S5/W6/W6)
02480E1=E1/B6
02490X6=E0+.995*(E1-E0)
02500GOTO 2520
02510X6=E0+.5*(E1-E0)
02520GOTO 2240
02530IF ABS(Q2-J6)<.0005 THEN 2690
02540IF Q2>J6 THEN 2640
02550E0=X6
02560IF E0<X5+4*D6 THEN 2630
02570P6=1
02580RETURN
02590G=1000
02600GOSUB 5000
02610X8=X7+J2*D8
02620RETURN
02630GOTO 2510
02640E1=X6
02650IF E1>X5-4*D6 THEN 2680
02660P6=0
02670RETURN
02680GOTO 2510
02690Z7=0
02700RETURN
02710PRINT L$
02720IF Z8 <> 1 THEN 2800
02730P(1,1)=2182
02740P(2,1)=19.03
02750P(3,1)=5.2763
02760P(4,1)=2.07
02770P(5,1)=1.0148
02780P(6,1)=.3732
02790GOTO 3140
02800PRINT "INPUT THE DATA FOR GROUP ";I
02810PRINT
02820PRINT "SAMPLE SIZE (N) =";
02830GOSUB 9000
02840IF O1>6 THEN 2870
02850PRINT "REENTER. MUST BE GREATER THAN 6."
02860GOTO 2830
02870P(1,I)=O1
02880PRINT "MEAN OF PREDICTOR (X.) =";
02890GOSUB 9000
02900P(2,I)=O1
02910PRINT "ST. DEV. OF PREDICTOR (S.D.X) =";
02920GOSUB 9000
02930IF O1>0 THEN 2960
02940PRINT "REENTER. STANDARD DEVIATION MUST BE GREATER THAN 0."
02950GOTO 2920
02960P(3,I)=O1
02970PRINT "MEAN OF CRITERION (Y.) =";
02980GOSUB 9000
02990P(4,I)=O1
03000PRINT "ST. DEV. OF CRITERION (S.D.Y) =";
03010GOSUB 9000
03020IF O1>0 THEN 3050
03030PRINT "REENTER. STANDARD DEVIATION MUST BE GREATER THAN 0."
03040GOTO 3010
03050P(5,I)=O1
03060PRINT "CORRELATION COEFFICIENT (R) =";
03070GOSUB 9000
03080IF O1>0 THEN 3120
03090PRINT "REENTER. CORRELATION COEFFICIENT MUST BE GREATER THAN 0"
03100PRINT "BUT NOT GGREATER THAN 1."
03110GOTO 3070
03120IF O1>1 THEN 3090
03130P(6,I)=O1
03140RETURN
05000REM********************** PERCENTILE FINDER **************************
05001P0=P4
05005P5=2
05010P6=2
05015P2=P0
05020GOSUB 5150
05025IF ABS(P-P0)<.0009 THEN 5145
05030IF P>P0 THEN 5065
05035E5=J2
05040P5=P
05045IF P6 <> 2 THEN 5095
05050P2=P2+.001
05055GOTO 5020
05060GOTO 5025
05065E6=J2
05070P6=P
05075IF P5 <> 2 THEN 5095
05080P2=P2-.001
05085GOTO 5020
05090GOTO 5025
05095J6=.5*(E6+E5)
05096J2=ABS(J6)
05100GOSUB 6000
05102IF J6 >= 0 THEN 5105
05103P=1-P
05104J2=-J2
05105IF ABS(P-P0)<.0009 THEN 5145
05110IF P>P0 THEN 5130
05115P5=P
05120E5=J6
05125GOTO 5095
05130E6=J6
05135P6=P
05140GOTO 5095
05145RETURN
05150P3=P2
05155IF P2 <= .5 THEN 5165
05160P2=1-P2
05165A1=SQR(LOG(1/P2/P2))
05170A2=2.51552+.802853*A1+.010328*A1*A1
05175A2=A2/(1+1.43279*A1+.189269*A1*A1+.001308*A1*A1*A1)
05180A2=A1-A2
05185J2=SQR(G*EXP(A2*(G-5/6)*A2/(G-2/3+.1/G)/(G-2/3+.1/G))-G)
05190GOSUB 6000
05195IF P3 <= .5 THEN 5210
05200P2=P3
05205GOTO 5220
05210J2=-J2
05215P=1-P
05220RETURN
05850REM ****************************************************
05852REM LOG GAMMA ROUTINE
05853REM INPUT G9
05854REM OUTPUT G0
05860G5=G9
05863IF G9 <= 1.E+30 THEN 5872
05866G0=1.E+38
05869RETURN
05872IF G9>1.E-09 THEN 5881
05875G0=0
05878RETURN
05881IF G9<1.E+10 THEN 5890
05884G0=G9*(LOG(G9)-1)
05887RETURN
05890G6=1
05893IF 18<G5 THEN 5905
05896G6=G6*G5
05899G5=G5+1
05902GOTO 5893
05905R8=1/G5/G5
05908G0=(G5-.5)*LOG(G5)-G5+.918939-LOG(G6)
05911C1=8.33333E-02
05914C2=2.77778E-03
05917C3=7.93651E-04
05920C4=5.95238E-04
05923G0=G0+1/G5*(C1-(R8*(C2+(R8*(C3-(R8*(C4)))))))
05926RETURN
05927REM END OF LOG GAMMA ROUTINE
05928REM ****************************************************
06000REM****************************************************************
06002REM STUDENT'S T CDF ROUTINE
06004REM INPUT G J2
06006REM OUTPUT P
06007REM PRIOR GOSUB 6060
06008P=0
06009IF J2=0 THEN 6056
06010GOTO 6015
06011IF J2<6 THEN 6016
06012P=1
06014GOTO 6058
06015IF J2>12 THEN 6012
06016 DIM W(16),O(16)
06018Y3=J2
06019GOTO 6026
06020IF G<10 THEN 6026
06021Y3=(G-2/3+.1/G)*SQR(ABS(LOG(1+J2*J2/G))/(G-5/6))
06022GOSUB 8000
06024GOTO 6058
06025REM PEIZER PRATT APPROXIMATION
06026IF G=1 THEN 6098
06028J1=0
06030N=G
06032P=0
06034GOSUB 6084
06036D0=(J2-J1)*.5
06038D1=(J1+J2)*.5
06040FOR I1=1 TO 16
06042D9=D0*O(I1)+D1
06044IF D9=0 THEN 6050
06046IF D9=1 THEN 6050
06048P=P+W(I1)*(EXP(-(N+1)/2*LOG(1+D9*D9/N)))
06050NEXT I1
06052P=P*F0
06054P=P*D0
06056P=P+.5
06058RETURN
06060FOR I1=1 TO 16
06062READ W(I1),O(I1)
06064NEXT I1
06066DATA 2.71525E-02,-.989401
06068DATA 6.22535E-02,-.944575,9.51585E-02,-.865631
06070DATA .124629,-.755404,.149596,-.617876
06072DATA .169156,-.458017,.182603,-.281604,.189451,-9.50125E-02
06074DATA .189451,9.50125E-02,.182603,.281604,.169156,.458017
06076DATA .149596,.617876,.124629,.755404
06078DATA 9.51585E-02,.865631,6.22535E-02,.944575,2.71525E-02
06080DATA .989401
06082RETURN
06084G9=(N+1)/2
06086GOSUB 5850
06088F0=G0
06090G9=N/2
06092GOSUB 5850
06094F0=EXP(F0-G0)/SQR(3.14159*N)
06096RETURN
06098REM FOLLOWING FOR NU=1
06100P=.5+1/3.14159*ATN(Y3)
06102RETURN
06104REM END OF STUDENT'S T CDF ROUTINE
06106REM*************************************************************
08000REM
08001REM ROUTINE CALCULATES THE CDF FOR NORMAL DISTRIBUTION
08002REM INPUT Y3
08003REM OUTPUT P
08004REM
08005Y4=ABS(Y3)
08010X1=X
08015X=Y3
08020T=1/(1+.231642*Y4)
08021IF X*X/2<80 THEN 8025
08022D=0
08023GOTO 8030
08025D=.398942*EXP(-X*X/2)
08030C1=1.33027
08035C2=1.82126
08040C3=1.78148
08045C4=.356564
08050C5=.319382
08055P=1-D*T*((((C1*T-C2)*T+C3)*T-C4)*T+C5)
08060IF X >= 0 THEN 8070
08065P=1-P
08070X=X1
08075RETURN
08076REM
08077REM END OF NORMAL CDF ROUTINE
08078REM **********************************************************
09000REM--SUBROUTINE THAT DETERMINES IF RESTART HAS BEEN REQUESTED.
09005INPUT O1
09015IF O1=-9999 THEN 9025
09020RETURN
09025CHAIN "RSTRT"
09035REM*************END ROUTINE
09050REM--SUBROUTINE THAT DETERMINES IF RESTART HAS BEEN REQUESTED. 2 INPUTS
09055INPUT O1,O2
09065IF O1=-9999 THEN 9080
09070IF O2=-9999 THEN 9080
09075RETURN
09080CHAIN "RSTRT"
09090REM*************END ROUTINE
09100REM--SUBROUTINE THAT DETERMINES IF RESTART HAS BEEN REQUESTED. 3 INPUTS
09105INPUT O1,O2,O3
09115IF O1=-9999 THEN 9135
09120IF O2=-9999 THEN 9135
09125IF O3=-9999 THEN 9135
09130RETURN
09135CHAIN "RSTRT"
09145REM*************END ROUTINE
09150REM--SUBROUTINE THAT DETERMINES IF RESTART HAS BEEN REQUESTED
09160REM--4 INPUTS
09170INPUT O1,O2,O3,O4
09200IF O1=-9999 THEN 9250
09210IF O2=-9999 THEN 9250
09220IF O3=-9999 THEN 9250
09230IF O4=-9999 THEN 9250
09240RETURN
09250RESTORE#1
09251 INPUT# 1,Z$
09255CHAIN "RSTRT"
09270REM*************END ROUTINE
09999 END