Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-04 - decus/20-0113/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