Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0137/bmd/bmd07s.for
There is 1 other file named bmd07s.for in the archive. Click here to see a list.
00100 CBD07S GUTTMAN SCALES NO. 2 - PART 2 OCTOBER 22, 1965
00200 DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
00300 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
00400 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2
00500 37),KONTER(25,7),DUMMY3(1),KSTEP(6), KDUMY6(2),REF(25),NN1(6),NN2(6
00600 4),NN3(6)
00700 COMMON JOBNMB
00800 COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
00900 1AR,INDRNK,INDKOL,ISCALE,LESTN,LEAVE,IERROR,KANEND,KOMPER,KORDER,IN
01000 2DTEM,IDAY,IYEAR,NUMPGE,JOYCAE,MAXLOC,N1,N2,DUMMY3,LASTRD,NDREDK,L,
01100 3IFINAL,ILAST,IFIRST,IXTRA,KK,ICHNGE,NFIRST,L1,IEND,MCOMB,IPUNCH,NP
01200 4ER,KDUMY6,INDEX3
01300 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK
01400 DOUBLE PRECISION DUM,QCTR
01500 C
01600 EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
01700 1,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR
01800 2),(ERROR,KONTER),(YES,IYES)
01900 C
02000 DATA QCTR/8H* /
02100 DATA DUM/8HFORCOM /
02200 DATA IYES/4HYES /
02300 IT1=1
02400 CALL USAGEB('BMD07S')
02500 C
02600 C BMD07S USES THE FOLLOWING SUBROUTINES FOUND IN BMD04S,
02700 C COMBIN DECTER FNDCMB FRSTCM
02800 C MOVE MOVFOR ORDER ORQUES
02900 C REORDR
03000 C
03100 C THIS PROGRAM REQUIRES THE TAPE UNIT DESIGNATED IT4 IN BMD06S.
03200 C IT4 IS THE SAVE TAPE WITH ALL OF COMMON STORAGE WRITTEN ON IT.
03300 C
03400 C IT1 IS THE TAPE WHICH CONTAINS THE ORIGINAL WEIGHTED RESPONSES.
03500 C
03600 LOPE=0
03700 IT4=4
03800 C
03900 4515 FORMAT('1BMD07S - GUTTMAN SCALE NUMBER 2, PART 2 - REVISED ',
04000 1'SEPTEMBER 23, 1968'/
04100 23X,40HHEALTH SCIENCES COMPUTING FACILITY, UCLA)
04200 C
04300 REWIND IT4
04400 READ(IT4) J
04500 READ(IT4) (REF(I),I=1,25)
04600 NPOINT=(J+127)/128
04700 IF (NPOINT.LE.1) GO TO 9991
04800 DO 9001 I=1,NPOINT-1
04900 NI=(I-1)*128+1
05000 NII=I*128
05100 9001 READ(IT4)(A(K),K=NI,NII)
05200 9991 NI=(NPOINT-1)*128+1
05300 READ(IT4)(A(K),K=NI,J)
05400 DO 9992 I=1,4
05500 NI=(I-1)*128+1
05600 NII=I*128
05700 9992 READ(IT4)(LVAR(K),K=NI,NII)
05800 READ(IT4)(LVAR(K),K=513,558),INDEX3
05900 READ(IT4) JOBNMB,(DUMMY2(I),I=1,27),FRSTMO,SECMON,(KDUMY6(J)
06000 1,J=1,2)
06100 REWIND IT4
06200 C
06300 C
06400 KDUMY6(1)=DUM
06500 C DUMMY3(17) HAS THE SAME LOCATION AS KDUMY6(1). THUS WE CAN USE IT
06600 C FOR THE FIXED POINT SUBTRACTION PRIOR TO FORTRAN STATEMENT NUMBER
06700 C 2029.
06800 C
06900 FKEEP=0.0
07000 IELIM=2
07100 KTIMES=0
07200 LAST=1
07300 KONE=1
07400 ASSIGN 445 TO INCKTM
07500 ASSIGN 3876 TO KOFPR
07600 ASSIGN 451 TO JTIMES
07700 ASSIGN 2006 TO LTIMES
07800 FLPTN2=LASTNO
07900 FLPTN3=NCASE
08000 KTEST=NVAR*5
08100 LL=1
08200 KSTEP(1)=3
08300 WRITE (6,4515)
08400 2019 NCARDS=(MCOMB+5)/6
08500 MCARDS=NCARDS
08600 IF(NCARDS)2018,2018,2021
08700 2018 KTIMES=1
08800 GO TO 2011
08900 C
09000 2020 IF(NCARDS)2001,2001,2021
09100 2021 NCARDS=NCARDS-1
09200 READ (5,1000)KCHECK,(KSTEP(I),NN1(I),NN2(I),NN3(I),I=1,6)
09300 IF(KCHECK.NE.KDUMY6(1)) GO TO 940
09400 2029 ILL=1
09500 2022 LL=ILL
09600 20222 IF(KSTEP(LL))2030,2030,2122
09700 2122 IF((KSTEP(LL)-KONE)-KTIMES)920,2023,2001
09800 2023 DO 2025 I=1,NVAR
09900 IF(NN1(LL)-LVAR(I))2025,2024,2025
10000 2025 CONTINUE
10100 GO TO 19
10200 2024 M=LVAR(I)
10300 IF(MCOMB)2127,2127,2128
10400 2127 LL=6
10500 GO TO 2124
10600 2128 MCOMB=MCOMB-1
10700 N1(M)=NN2(LL)
10800 N2(M) =NN3(LL)
10900 CALL CHECK(M)
11000 NCOMB(M)=NCOMB(M)+1
11100 CALL COMBIN(I,N1,N2(1))
11200 IF(KOMPER)998,2124,998
11300 2124 ITIMES=6
11400 IF(LL-6)2125,2120,2120
11500 2125 IF(KSTEP(LL+1)-1)2126,2026,2123
11600 2120 IF(1-KSTEP(LL))2123,2126,2126
11700 2123 CALL DECTER
11800 2126 GO TO INCKTM,(445,450)
11900 C
12000 2026 IF(M-NN1(LL+1))2030,2126,2030
12100 C
12200 19 N=NVAR+1
12300 DO 20 I=N,25
12400 IF(NN1(LL)-LVAR(I))20,25,20
12500 20 CONTINUE
12600 GO TO 930
12700 25 N=MCARDS-NCARDS
12800 WRITE (6,4019)NN1(LL),N
12900 MCOMB=MCOMB-1
13000 GO TO 2124
13100 C
13200 2027 IF(KTIMES-1)2028,2028,2030
13300 2028 KTIMES=0
13400 2030 LL=LL+1
13500 IF(LL.LE.6)GO TO 20222
13600 GO TO 2020
13700 C
13800 2001 IF(MCOMB)2011,2011,2012
13900 2011 ASSIGN 2031 TO KONTIN
14000 LL=1
14100 KSTEP(1)=KTEST
14200 IF(IEND.EQ.IYES) GO TO 2014
14300 2013 LAST=2
14400 GO TO 2014
14500 C
14600 2012 ASSIGN 202 TO KONTIN
14700 2014 ILL=LL
14800 GO TO LTIMES,(2006,2010,4655,4915,5207)
14900 C
15000 C COMBINE THOSE RESPONSES WHICH HAVE LESS THAN NPER PERCENT
15100 C OF THE TOTAL NUMBER OF RESPONDENTS, IF DESIRED.
15200 C
15300 2006 CONTINUE
15400 2135 ITIMES=5
15500 KTIMES=1
15600 ASSIGN 2010 TO LTIMES
15700 IF(NFIRST.NE.IYES) GO TO 2003
15800 2002 CALL FRSTCM(NPER)
15900 IF(L-INDKOL)2003,2003,2005
16000 2003 ITIMES=1
16100 IF(KOMPER)998,2009,998
16200 2009 IF((KSTEP(LL)-1)-KTIMES)920,2022,2010
16300 C
16400 2005 ASSIGN 449 TO JTIMES
16500 GO TO 450
16600 C
16700 2010 CONTINUE
16800 7005 ITIMES=1
16900 C
17000 C RANK RESPONDENTS USING CORNELL TECHNIQUE
17100 C
17200 201 INDEX2=0
17300 GO TO KONTIN,(202,2022,2031)
17400 202 ASSIGN 2022 TO KONTIN
17500 2031 K=INDRNK+1
17600 DO 204 JRNK=K,INDKOL
17700 RANKSM(JRNK)=0.0
17800 INDEX1=INDEX2+1
17900 INDEX2=INDEX2+NVAR
18000 DO 203 I=INDEX1,INDEX2
18100 RANKSM(JRNK)=RANKSM(JRNK)+A(I)
18200 203 CONTINUE
18300 204 CONTINUE
18400 C
18500 C ORDER ACCORDING TO HIGHEST RANK SCORE
18600 C
18700 240 CALL ORDER
18800 C
18900 C ORDER QUESTIONS IN INCREASING FREQUENCY OF SCORE 7
19000 C
19100 CALL ORQUES(0)
19200 C
19300 C REORDER THOSE INDIVIDUALS WITH THE SAME TOTAL SCORE
19400 C
19500 275 CALL REORDR
19600 7009 IF (KOMPER)998,3305,998
19700 C
19800 3305 GO TO (334,465,555),LAST
19900 C
20000 C DETERMINE CUTTING POINTS AND ERRORS FOR EACH QUESTION
20100 C
20200 334 KK=1
20300 336 CALL DECTER
20400 380 IF(IFINAL.NE.IYES) GO TO 384
20500 325 MINPR=1
20600 MAXPR=0
20700 INDEX2=0
20800 NDIFF=NCASE
20900 5010 IF(NDIFF-50)5020,5020,5030
21000 5020 MAXPR=NCASE
21100 NDIFF=0
21200 GO TO 5040
21300 C
21400 5030 MAXPR=MAXPR+50
21500 NDIFF=NDIFF-50
21600 5040 NUMPGE=NUMPGE+1
21700 WRITE (6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE
21800 326 WRITE (6,4002)
21900 WRITE (6,4008)
22000 2662 WRITE (6,4504)NCASE,NVAR
22100 WRITE (6,4506)KTIMES
22200 WRITE (6,4505)
22300 DO 2663 I=1,NVAR
22400 M=LVAR(I)
22500 HOLD(I)=REF(M)
22600 2663 CONTINUE
22700 WRITE (6,4508)(LVAR(J),HOLD(J),J=1,NVAR)
22800 327 WRITE (6,4500)
22900 DO 267 I=MINPR,MAXPR
23000 INDEX1=INDEX2+1
23100 INDEX2=INDEX2+NVAR
23200 JRNK=I+INDRNK
23300 INDIDV=I+LASTNO
23400 2665 WRITE (6,4003)I,INDIVD(INDIDV),RANKSM(JRNK),(A(J),J=INDEX1,INDEX2)
23500 267 CONTINUE
23600 GO TO (268,5050),IELIM
23700 268 WRITE (6,4030)
23800 5050 MINPR=MINPR+50
23900 IF(NDIFF) 384, 384,5010
24000 C
24100 C PRINT OUT ERRORS, IF DESIRED
24200 C
24300 384 FLPTN1=MAXERR
24400 COFREP=1.0-(FLPTN1/FLPTN2)
24500 KSUM=0
24600 DO 3874 M=1,NVAR
24700 I=LVAR(M)
24800 KEST=0
24900 DO 3873 J=1,7
25000 IF(KEST-MFREQ(I,J))3871,3873,3873
25100 3871 KEST=MFREQ(I,J)
25200 3873 CONTINUE
25300 KSUM=KSUM+KEST
25400 3874 CONTINUE
25500 SUM=KSUM
25600 FMINMR=SUM/FLPTN2
25700 IF(IERROR.NE.IYES) GO TO 390
25800 385 NUMPGE=NUMPGE+1
25900 386 WRITE (6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE
26000 WRITE (6,4004)
26100 WRITE (6,4504)NCASE,NVAR
26200 WRITE (6,4506)KTIMES
26300 WRITE (6,4500)
26400 WRITE (6,4505)
26500 DO 3861 I=1,NVAR
26600 M=LVAR(I)
26700 HOLD(I)=REF(M)
26800 3861 CONTINUE
26900 WRITE (6,4509)(LVAR(J),HOLD(J),J=1,NVAR)
27000 ASSIGN 388 TO MTIMES
27100 3862 WRITE (6,4500)
27200 DO 387 I=1,7
27300 DO 3865 J=1,NVAR
27400 M=LVAR(J)
27500 KOLHLD(J)=KONTER(M,I)
27600 3865 CONTINUE
27700 WRITE (6,4005)I,(KOLHLD(J),J=1,NVAR)
27800 387 CONTINUE
27900 K=0
28000 DO 3877 I=1,NVAR
28100 M=LVAR(I)
28200 KOLHLD(I)=0
28300 DO 3875 J=1,7
28400 KOLHLD(I)=KOLHLD(I)+KONTER(M,J)
28500 3875 CONTINUE
28600 K=K+KOLHLD(I)
28700 3877 CONTINUE
28800 J=FLPTN2
28900 WRITE (6,4024)(KOLHLD(I),I=1,NVAR)
29000 WRITE (6,4025)K,J
29100 GO TO KOFPR,(3876,3878)
29200 3878 WRITE (6,4501)
29300 WRITE (6,4018)COFREP
29400 WRITE (6,4021)FMINMR
29500 IF(COFREP-FKEEP)3872,3870,3870
29600 3872 WRITE (6,4013)
29700 3870 FKEEP=COFREP
29800 3876 GO TO (3880,3879),IELIM
29900 3880 WRITE (6,4030)
30000 3879 GO TO MTIMES,(388,475)
30100 388 WRITE (6,4502)
30200 WRITE (6,4006)
30300 WRITE (6,4500)
30400 I=0
30500 DO 389 JJ=1,NVAR
30600 K=26
30700 DO 3895 L=1,NVAR
30800 M=LVAR(L)
30900 IF(M-K)3891,3895,3895
31000 3891 IF(I-M)3893,3895,3895
31100 3893 K=M
31200 3895 CONTINUE
31300 I=K
31400 WRITE (6,4007)I,REF(I),(MFREQ(I,J),J=1,8)
31500 389 CONTINUE
31600 C
31700 C DETERMINE COMBINATIONS OF RESPONSES IN EACH QUESTION
31800 C
31900 390 GO TO (395,520,462,495,612,580),ITIMES
32000 395 KK=2
32100 CALL FNDCMB(FLPTN2)
32200 IF(KOMPER)998,425,998
32300 425 IF(L1)445,462,445
32400 445 KTIMES=KTIMES+1
32500 450 NUMPGE=NUMPGE+1
32600 WRITE (6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE
32700 WRITE (6,4009)
32800 GO TO JTIMES,(449 ,451)
32900 449 WRITE (6,4014)NPER
33000 ASSIGN 451 TO JTIMES
33100 451 WRITE (6,4504)NCASE,NVAR
33200 WRITE (6,4506)KTIMES
33300 452 WRITE (6,4510)
33400 J=0
33500 DO 457 JJ=1,NVAR
33600 K=26
33700 DO 4526 L=1,NVAR
33800 M=LVAR(L)
33900 IF(M-K)4522,4526,4526
34000 4522 IF(J-M)4524,4526,4526
34100 4524 K=M
34200 4526 CONTINUE
34300 J=K
34400 IF(NCOMB(J))456,457,456
34500 456 WRITE(6,4010) J,REF(J),NCOMB(J),N1(J),N2(J),KVAR(J),MVAR(J)
34600 4569 N1(J)=0
34700 N2(J)=0
34800 457 CONTINUE
34900 GO TO(4573,4577),IELIM
35000 4573 WRITE (6,4030)
35100 4577 CONTINUE
35200 458 GO TO (459,674,675,551,2002,2027),ITIMES
35300 459 IF(KTIMES-KTEST)201,990,990
35400 C
35500 C DETERMINE ERROR FOR FINAL COMPUTATIONS
35600 C
35700 462 IF(LEAVE.NE.IYES) GO TO 465
35800 463 LAST=2
35900 465 KK=3
36000 KTIMES=KTIMES+1
36100 IF((-MCOMB))4653,4654,4654
36200 4653 KONE=0
36300 ASSIGN 4655 TO LTIMES
36400 ASSIGN 450 TO INCKTM
36500 GO TO 2022
36600 C
36700 4654 CALL DECTER
36800 4655 NUMPGE=NUMPGE+1
36900 WRITE (6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE
37000 WRITE (6,4012)
37100 WRITE (6,4504)NCASE,NVAR
37200 WRITE (6,4506)KTIMES
37300 WRITE (6,4505)
37400 DO 466 I=1,NVAR
37500 M=LVAR(I)
37600 HOLD(I)=REF(M)
37700 466 CONTINUE
37800 WRITE (6,4509)(LVAR(J),HOLD(J),J=1,NVAR)
37900 ASSIGN 475 TO MTIMES
38000 GO TO 3862
38100 C
38200 C CHECK TO SEE IF CHANGING RANK OF INDIVIDUALS REDUCES ERROR
38300 C
38400 475 MAXERR=0
38500 DO 480 I=1,NVAR
38600 MAXERR=MAXERR+KOLHLD(I)
38700 480 CONTINUE
38800 485 CALL ORQUES(1)
38900 CALL RKCHNG(MAXERR)
39000 KK=3
39100 IF(KOMPER)998,490,998
39200 490 KTIMES=KTIMES+1
39300 IF((-MCOMB))491,492,492
39400 491 ASSIGN 4915 TO LTIMES
39500 GO TO 2022
39600 C
39700 4915 MAXERR =0
39800 DO 494 M=1,NVAR
39900 I=LVAR(M)
40000 DO 493 J=1,7
40100 MAXERR=MAXERR+KONTER(I,J)
40200 493 CONTINUE
40300 494 CONTINUE
40400 492 ITIMES=4
40500 ASSIGN 3878 TO KOFPR
40600 GO TO 380
40700 C
40800 C CHECK TO SEE IF FURTHER POSSIBLE COMBINATIONS MAY REDUCE THE ERROR
40900 C TO GIVE A GOOD COEFFICIENT OF REPRODUCIBILITY.
41000 C
41100 495 GO TO (496, 580),LAST
41200 496 FLPTN1=MAXERR
41300 REPERR=FLPTN1/FLPTN2
41400 IF(0.1-REPERR)497,500,500
41500 497 KING=1
41600 GO TO 520
41700 C
41800 500 IF(NDREDK)499,499,498
41900 499 KING=3
42000 GO TO 520
42100 C
42200 498 IF(NDREDK-20)512,512,499
42300 512 IF(LASTRD-1)499,510,499
42400 510 KING=2
42500 520 IF((-MCOMB))5205,525,525
42600 5205 KONE=1
42700 ASSIGN 445 TO INCKTM
42800 ASSIGN 5207 TO LTIMES
42900 GO TO 2022
43000 C
43100 5207 MAXERR =0
43200 DO 5209 I=1,NVAR
43300 DO 5208 J=1,7
43400 MAXERR=MAXERR+KONTER(I,J)
43500 5208 CONTINUE
43600 5209 CONTINUE
43700 5206 IF((-MCOMB))521,525,525
43800 521 CALL ENDCMB(NDREDK,KING,MAXERR,LASTRD)
43900 IF(KOMPER-50)522,5595,522
44000 522 IF(KOMPER-25)998,550,998
44100 550 KOMPER=0
44200 ITIMES=4
44300 GO TO 445
44400 C
44500 525 IF(IEND.EQ.IYES) GO TO 521
44600 GO TO 614
44700 C
44800 551 LAST=3
44900 ITIMES=2
45000 GO TO 201
45100 C
45200 555 KK=3
45300 CALL DECTER
45400 556 MAXERR=0
45500 DO 559 M=1,NVAR
45600 I=LVAR(M)
45700 DO 558 J=1,7
45800 MAXERR=MAXERR+KONTER(I,J)
45900 558 CONTINUE
46000 559 CONTINUE
46100 CALL ORQUES(I)
46200 KK=3
46300 CALL RKCHNG(MAXERR)
46400 KTIMES=KTIMES+1
46500 ICHNGE=ICHNGE+1
46600 IF(ICHNGE-20)5591,5591,5592
46700 5591 IF(KOMPER)998,380,998
46800 C
46900 5592 ICHNGE=20
47000 GO TO 5591
47100 C
47200 5595 KOMPER=0
47300 IF(ICHNGE-5)5599,5599,5597
47400 5599 ICHNGE=10
47500 5596 ITIMES=6
47600 GO TO 555
47700 C
47800 5597 ICHNGE=20
47900 GO TO 5596
48000 C
48100 560 KOMPER=0
48200 K=INDTEM+25
48300 DO 565 I=1,NVAR
48400 J=K+I
48500 IF(KOLSKR(J))565,565,567
48600 565 CONTINUE
48700 GO TO 575
48800 C
48900 567 FLPTN1=MAXERR
49000 COFREP=1.0-(FLPTN1/FLPTN2)
49100 NUMPGE=NUMPGE+1
49200 KTIMES=KTIMES+1
49300 WRITE (6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE
49400 WRITE (6,4016)
49500 WRITE (6,4504)NCASE,NVAR
49600 WRITE (6,4506)KTIMES
49700 WRITE (6,4018)COFREP
49800 WRITE (6,4021)FMINMR
49900 WRITE (6,4511)
50000 DO 570 I=1,NVAR
50100 M=LVAR(I)
50200 INDEX1=K+I
50300 IF(KOLSKR(INDEX1))570,570,563
50400 563 N=KOLSKR(INDEX1)
50500 N2(M)=KOLSKR(INDEX1-25)/8
50600 N1(M)=KOLSKR(INDEX1-25)-(N2(M)*8)
50700 WRITE (6,4017)M,REF(M),N1(M),N2(M),N,RANKSM(INDEX1+25)
50800 570 CONTINUE
50900 575 GO TO(600,576,600,700),LAST
51000 576 LAST=4
51100 CALL ORQUES(LAST)
51200 KK=3
51300 CALL RKCHNG(MAXERR)
51400 ITIMES=6
51500 KTIMES=KTIMES+1
51600 GO TO 380
51700 C
51800 580 KK=4
51900 CALL FNDCMB(FLPTN2)
52000 581 IF(KOMPER)998,560,998
52100 C
52200 C ELIMINATE SOME QUESTIONS,IF DESIRED.
52300 C
52400 600 IF(LESTN)700,610,610
52500 610 LESTN=NVAR-LESTN
52600 ASSIGN 685 TO KIND
52700 IF(LESTN)910,614,615
52800 612 IF(LESTN)910,614,615
52900 614 LAST=2
53000 GO TO 580
53100 C
53200 615 DO 620 M=1,NVAR
53300 I=LVAR(M)
53400 IF(MVAR(I)-2)620,620,625
53500 620 CONTINUE
53600 GO TO 650
53700 C
53800 625 KK=4
53900 CALL FNDCMB(FLPTN2)
54000 6255 IF(KOMPER)998,626,998
54100 626 KTEST=0
54200 K=0
54300 INDEX2=INDTEM+25
54400 DO 635 I=1,NVAR
54500 M=LVAR(I)
54600 INDEX1=INDEX2+I
54700 IF(KOLSKR(INDEX1))627,628,630
54800 627 KOLSKR(INDEX1)=0
54900 628 IF(MVAR(M)-2)629,629,630
55000 629 IF(MFREQ(M,1))630,630,6295
55100 6295 KOLSKR(INDEX1)=KONTER(M,7)+KONTER(M,1)
55200 630 IF(KTEST-KOLSKR(INDEX1))631,635,635
55300 631 KTEST=KOLSKR(INDEX1)
55400 K=I
55500 635 CONTINUE
55600 IF((-K))6355,680,680
55700 6355 L=LVAR(K)
55800 IF(MVAR(L)-2)661,661,636
55900 636 INDEX1=INDTEM+K
56000 N2(L)=KOLSKR(INDEX1)/8
56100 N1(L)=KOLSKR(INDEX1)-(N2(L)*8)
56200 NCOMB(L)=NCOMB(L)+1
56300 CALL COMBIN(K,N1,N2(1))
56400 IF(KOMPER)998,637,998
56500 637 ITIMES=3
56600 GO TO 445
56700 C
56800 650 KK=3
56900 CALL DECTER
57000 651 KTEST=0
57100 L=0
57200 DO 660 I=1,NVAR
57300 KOLHLD(I)=0
57400 M=LVAR(I)
57500 KOLHLD(I)=KOLHLD(I)+KONTER(M,7)+KONTER(M,1)
57600 IF(KTEST-KOLHLD(I))656,660,660
57700 656 KTEST=KOLHLD(I)
57800 K=I
57900 L=M
58000 660 CONTINUE
58100 IF((-L))661,690,690
58200 661 MFREQ(L,7)=0
58300 MFREQ(L,1)=0
58400 MFREQ(L,8)=0
58500 NCOMB(L)=NCOMB(L)+1
58600 N1(L)=1
58700 N2(L)=7
58800 MVAR(L)=1
58900 REF(L)=QCTR
59000 IELIM=1
59100 ITIMES=2
59200 665 INDEX1=LASTNO-NVAR+K
59300 DO 670 I=K,INDEX1,NVAR
59400 A(I)=0.0
59500 670 CONTINUE
59600 I=L
59700 GO TO 445
59800 C
59900 674 MVAR(I)=2
60000 FLPTN2=FLPTN2-FLPTN3
60100 LESTN=LESTN-1
60200 675 ITIMES=5
60300 LAST=3
60400 16755 CONTINUE
60500 GO TO 201
60600 C
60700 680 GO TO KIND,(685,690)
60800 685 ASSIGN 690 TO KIND
60900 NDREDK=0
61000 GO TO 615
61100 C
61200 690 WRITE (6,4031)
61300 GO TO 614
61400 C
61500 700 WRITE(IT4) MAXERR,COFREP,FMINMR
61600 WRITE(IT4) (REF(I),I=1,25)
61700 DO 9003 K=1,4
61800 NK=(K-1)*128+1
61900 NKK=K*128
62000 9003 WRITE(IT4)(LVAR(KKK),KKK=NK,NKK)
62100 WRITE(IT4)(LVAR(KKK),KKK=513,558),INDEX3
62200 WRITE(IT4) JOBNMB,(DUMMY2(I),I=1,27),FRSTMO,SECMON,(KDUMY6(J)
62300 1,J=1,2)
62400 MAXPR=0
62500 DO 725 I=1,NCASE
62600 MINPR=MAXPR+1
62700 MAXPR=MAXPR+NVAR
62800 NPOINT=(MAXPR-MINPR+128)/128
62900 NWED=MINPR-1
63000 IF (NPOINT.LE.1) GO TO 7726
63100 DO 7727 J=1,NPOINT-1
63200 NJ=(J-1)*128+NWED+1
63300 NJJ=J*128+NWED
63400 7727 WRITE(IT4)(A(JJJ),JJJ=NJ,NJJ)
63500 7726 NJ=(NPOINT-1)*128+NWED+1
63600 WRITE(IT4)(A(JJJ),JJJ=NJ,MAXPR)
63700 725 CONTINUE
63800 DO 750 I=1,4
63900 MINPR=MAXPR+1
64000 MAXPR=MAXPR+NCASE
64100 NPOINT=(MAXPR-MINPR+128)/128
64200 NWED=MINPR-1
64300 IF (NPOINT.LE.1) GO TO 7732
64400 DO 7731 J=1,NPOINT-1
64500 NJ=(J-1)*128+NWED+1
64600 NJJ=J*128+NWED
64700 7731 WRITE(IT4)(A(JJJ),JJJ=NJ, NJJ)
64800 7732 NJ=(NPOINT-1)*128+NWED+1
64900 WRITE(IT4)(A(JJJ),JJJ=NJ,MAXPR)
65000 750 CONTINUE
65100 END FILE IT4
65200 REWIND IT4
65300 998 STOP
65400 C
65500 910 WRITE (6,4910)
65600 GO TO 998
65700 C
65800 920 KTIMES=KTIMES+1
65900 WRITE (6,4029)KSTEP(LL),KTIMES
66000 GO TO 998
66100 C
66200 930 NCARDS=MCARDS-NCARDS
66300 WRITE (6,4028)NN1(LL),NCARDS
66400 GO TO 998
66500 C
66600 940 WRITE (6,4940)
66700 GO TO 998
66800 C
66900 990 NUMPGE=NUMPGE+1
67000 WRITE (6,4011)NUMPGE
67100 ITIMES=3
67200 GO TO 201
67300 C
67400 C
67500 8000 FORMAT(20A4)
67600 1000 FORMAT(A6,6(I4,3I2))
67700 C
67800 4002 FORMAT(1H ,41X,28HRESPONDENTS AND SCALE SCORES/37X,37HRANKED ACCOR
67900 1DING TO CORNELL TECHNIQUE)
68000 4003 FORMAT(1H ,I4,I5,2F5.0,24F4.0)
68100 4004 FORMAT(1H ,40X,30HERRORS AND NUMBER OF RESPONSES/42X,27HTO THE VAR
68200 1IOUS SCALE SCORES)
68300 4005 FORMAT(1H ,5X,I3,6X,25I4)
68400 4006 FORMAT(1H0,3X,8HVARIABLE,19X,55HFREQUENCY OF OCCURRENCE OF SCORES
68500 11 TO 7 AND SCORE ZERO/7X,2HOR,44X,5HSCORE/4X,8HQUESTION,13X,1H1,9X
68600 2,1H2,9X,1H3,9X,1H4,9X,1H5,9X,1H6,9X,1H7,4X,11HNO RESPONSE)
68700 4007 FORMAT(1H ,5X,I3,A1,6X,8I10)
68800 4008 FORMAT(1H ,26X,57HWITH QUESTIONS ORDERED IN INCREASING FREQUENCY O
68900 1F SCORE 7)
69000 4009 FORMAT(1H ,45X,25HCOMBINATIONS IN QUESTIONS)
69100 4010 FORMAT(1H0,I10,A1,I16,I17,5H AND,I3,I14,I8)
69200 4011 FORMAT(1H1,105X,4HPAGE,I4//117HAFTER COMBINING AS MANY OF THE RESP
69300 1PONSES IN EACH QUESTION AS POSSIBLE, SOME QUESTIONS STILL HAVE RAT
69400 2IOS OF ERRORS TO/39HNON-ERRORS WHICH ARE GREATER THAN 0.50./6X,112
69500 3HIT SEEMS UNLIKELY THAT THE RESULTING SCALE WHICH THE PROGRAM WILL
69600 4 NOW COMPUTE IS GOOD. PLEASE CHECK THE PREVIOUS/114HPAGES OF OUTPU
69700 5T AND EITHER ELIMINATE SOME QUESTIONS AND/OR RESPONDENTS OR DETERM
69800 6INE THOSE RESPONSES WHICH YOU FEEL/74HSHOULD BE COMBINED AND USE T
69900 7HE FORCED COMBINATION FEATURE OF THIS PROGRAM.)
70000 4012 FORMAT(1H ,42X,27HERRORS FOR EACH SCALE SCORE/50X,11HFINAL STEPS)
70100 4013 FORMAT(1H0,16X,84HTHE COEFFICIENT OF REPRODUCIBILITY DECREASED IN
70200 1THIS LAST STEP. IT IS SUGGESTED THAT//15X,86HYOU MAKE A DIFFERENT
70300 2COMBINATION USING THE FORCED COMBINATION FEATURE OF THIS PROGRAM.)
70400 4014 FORMAT(32X29HTHE FIRST SCORE HAS LESS THANI3,23H PERCENT OF RESPON
70500 1DENTS)
70600 4016 FORMAT(1H ,34X,41HPOSSIBLE COMBINATIONS WHICH WILL INCREASE/25X,61
70700 1HTHE COEFFICIENT OF REPRODUCIBILITY AND THE AMOUNT OF INCREASE)
70800 4017 FORMAT(1H016XI3,A1,16XI3,5H AND,I3,19X,I4,20X,F5.4)
70900 4018 FORMAT(1H ,36X,33HCOEFFICIENT OF REPRODUCIBILITY = ,F7.5)
71000 4019 FORMAT(1H0,12X,8HQUESTIONI3,61H NO LONGER INCLUDED IN STUDY. FORCE
71100 1D COMBINATION READ ON CARDI3,17H WILL BE IGNORED.)
71200 4021 FORMAT(1H0,34X,35HMINIMAL MARGINAL REPRODUCIBILITY = ,F7.5)
71300 4024 FORMAT(1H0,14HQUESTION ERROR,25I4)
71400 4025 FORMAT(1H0,36X,11HTOTAL ERROR I6,5X,15HTOTAL RESPONSES I6)
71500 4028 FORMAT(1H0,24X,37HTHERE IS NO QUESTION CORRESPONDING TO,I4,26H WHI
71600 1CH WAS READ IN ON CARD,I4)
71700 4029 FORMAT(1H0,18X,31HTHE COMBINATION DESIRED AT STEP,I4,20H WAS READ
71800 1IN AT STEP,I4,21H TOO LATE TO BE DONE.)
71900 4030 FORMAT(1H0,45H* INDICATES THIS QUESTION HAS BEEN ELIMINATED)
72000 4031 FORMAT(1H0,6X,103HNO MORE COMBINATIONS OR ELIMINATIONS WILL REDUCE
72100 1 THE ERROR. HENCE, NO MORE QUESTIONS WILL BE ELIMINATED)
72200 4500 FORMAT(1H )
72300 4501 FORMAT(1H0)
72400 4502 FORMAT(1H0//)
72500 4503 FORMAT(1H1,15H PROBLEM NUMBER,2X,A6,57X,2A6,I3,1H,,I5,3X,4HPAGE,
72600 1I4)
72700 4504 FORMAT(1H ,18X,23HNUMBER OF RESPONDENTS =,I5,22X,21HNUMBER OF VARI
72800 1ABLES =,I3)
72900 4505 FORMAT(1H ,44X,22HVARIABLES OR QUESTIONS)
73000 4506 FORMAT(1H ,54X,4HSTEP,I4)
73100 4508 FORMAT(1H ,15HRANK RESP SCOR ,25(I3,A1))
73200 4509 FORMAT(1H ,3X,8HSCORE OF,4X,25(I3,A1))
73300 4510 FORMAT(1H0,5X,8HQUESTION,6X,15HTOTAL NUMBER OF,6X,15HSCORES COMBIN
73400 1ED,6X,15HNUMBER OF PARTS/18X,19HCOMBINATIONS SO FAR,7X,9HTHIS TIME
73500 2,9X,15HORIGINAL NOW)
73600 4511 FORMAT(1H0,64X,8HDECREASE,15X,11HAPPROXIMATE/15X,8HQUESTION,15X,11
73700 1HCOMBINATION,15X, 10HIN NUMBER,14X,11HINCREASE IN/64X,10HOF ERRO
73800 2RS,12X,15HREPRODUCIBILITY)
73900 4910 FORMAT(1H0,21X,70HTHE MINIMUM QUESTIONS DESIRED IS GREATER THAN TH
74000 1E NUMBER OF QUESTIONS./26X,62HNO QUESTIONS WILL BE ELIMINATED BUT
74100 2SAVE TAPE WILL BE WRITTEN.)
74200 4940 FORMAT(1H1,32X,52HCONTROL CARDS OUT OF ORDER. PROGRAM CANNOT CONTI
74300 1NUE.)
74400 C
74500 END
74600 CCHECK SUBROUTINE CHECK FOR BMD07S DECEMBER 13, 1963
74700 SUBROUTINE CHECK(M)
74800 C
74900 DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
75000 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
75100 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2
75200 37),KONTER(25,7),DUMMY3(8)
75300 COMMON JOBNMB
75400 COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
75500 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN
75600 2DTEM,IDAY,IYEAR,NUMPGE,JOYCEA,MAXLOC,N1,N2,DUMMY3,KK,ICHNGE
75700 C
75800 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK
75900 EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
76000 1,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR
76100 2),(ERROR,KONTER)
76200 C
76300 25000 THETA=0.0
76400 MTIMES=MVAR(M)
76500 C
76600 N=N1(M)
76700 NN=N2(M)
76800 IF(N)920,920,1
76900 1 IF(NN)920,920,2
77000 2 IF(N-7)3,3,920
77100 3 IF(NN-7)4,4,920
77200 4 IF(MTIMES)900,900,5
77300 5 IF(MTIMES-7)10,10,900
77400 10 GO TO (900,920,30,40,50,60,70),MTIMES
77500 C
77600 30 GO TO (31,920,920,34,920,920,37),N
77700 C
77800 31 GO TO (920,920,920,800,920,920,920),NN
77900 C
78000 34 GO TO (800,920,920,920,920,920,800),NN
78100 C
78200 37 GO TO (920,920,920,800,920,920,920),NN
78300 C
78400 40 GO TO (41,920,43,920,45,920,47),N
78500 C
78600 41 GO TO (920,920,800,920,920,920,920),NN
78700 C
78800 43 GO TO (800,920,920,920,800,920,920),NN
78900 C
79000 45 GO TO (920,920,800,920,920,920,800),NN
79100 C
79200 47 GO TO (920,920,920,920,800,920,920),NN
79300 C
79400 50 GO TO (51,52,920,54,920,56,57),N
79500 C
79600 51 GO TO (920,800,920,920,920,920,920),NN
79700 C
79800 52 GO TO (800,920,920,800,920,920,920),NN
79900 C
80000 54 GO TO (920,800,920,920,920,800,920),NN
80100 C
80200 56 GO TO (920,920,920,800,920,920,800),NN
80300 C
80400 57 GO TO (920,920,920,920,920,800,920),NN
80500 C
80600 60 GO TO (51,62,63,920,65,66,57),N
80700 C
80800 62 GO TO (800,920,800,920,920,920,920),NN
80900 C
81000 63 GO TO (920,800,920,920,800,920,920),NN
81100 C
81200 65 GO TO (920,920,800,920,920,800,920),NN
81300 C
81400 66 GO TO (920,920,920,920,800,920,800),NN
81500 C
81600 70 GO TO (51,62,73,74,75,66,57),N
81700 C
81800 73 GO TO (920,800,920,800,920,920,920),NN
81900 C
82000 74 GO TO (920,920,800,920,800,920,920),NN
82100 C
82200 75 GO TO (920,920,920,800,920,800,920),NN
82300 C
82400 800 RETURN
82500 C
82600 900 WRITE (6,4000)M,MTIMES
82700 KOMPER=1
82800 GO TO 800
82900 C
83000 920 WRITE (6,4020)M,MTIMES,N1(M),N2(M)
83100 KOMPER=1
83200 GO TO 800
83300 C
83400 4000 FORMAT(1H0,12X,31HTHE NUMBER OF PARTS TO QUESTION,I3,3H IS,I3,51H
83500 1A VALUE NOT PERMITTED. THIS OCCURRED IN SUB CHECK.)
83600 C
83700 4020 FORMAT(1H0,6X,8HQUESTION,I3,4H HAS,I3,14H PARTS. SCORES,I3,4H AND,
83800 1I3,63H WERE TO BE COMBINED BUT ONE OR BOTH OF THEM IS(ARE) INCORRE
83900 2CT.)
84000 C
84100 END
84200 CCOMBIN SUBROUTINE COMBIN FOR BMD04S, 05S AND 07S JUNE 3, 1963
84300 SUBROUTINE COMBIN(I,N1,N2)
84400 C
84500 DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
84600 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
84700 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25)
84800 DIMENSION DUMMY2(27)
84900 COMMON JOBNMB
85000 COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
85100 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER
85200 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK
85300 EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
85400 EQUIVALENCE(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR)
85500 25000 THETA=0.0
85600 M=LVAR(I)
85700 C
85800 INDEX1=I+LASTNO-NVAR
85900 FLPTN1=N1(M)
86000 FLPTN2=N2(M)
86100 DO 25 J=I,INDEX1,NVAR
86200 IF(A(J)-FLPTN1)25,10,25
86300 10 A(J)=FLPTN2
86400 25 CONTINUE
86500 L1=N1(M)
86600 L2=N2(M)
86700 MFREQ(M,L2)=MFREQ(M,L2)+MFREQ(M,L1)
86800 MFREQ(M,L1)=0
86900 IF(MVAR(M)-6)27,60,70
87000 27 IF(MVAR(M)-4)28,40,50
87100 28 IF(MVAR(M)-2)900,900,30
87200 30 IF(MFREQ(M,1))910,31,32
87300 31 MFREQ(M,1)=MFREQ(M,4)
87400 SCORE2=1.0
87500 310 SCORE1=4.0
87600 MFREQ(M,4)=0
87700 LTIMES=1
87800 GO TO 500
87900 32 IF(MFREQ(M,4))910,600,33
88000 33 MFREQ(M,7)=MFREQ(M,4)
88100 SCORE2=7.0
88200 GO TO 310
88300 40 IF(MFREQ(M,1))910,41,43
88400 41 LTIMES=2
88500 SCORE1=3.0
88600 MFREQ(M,1)=MFREQ(M,3)
88700 MFREQ(M,3)=0
88800 410 SCORE2=1.0
88900 GO TO 500
89000 42 SCORE1=5.0
89100 MFREQ(M,4)=MFREQ(M,5)
89200 MFREQ(M,5)=0
89300 425 LTIMES=1
89400 SCORE2=4.0
89500 GO TO 500
89600 43 IF(MFREQ(M,3))910,42,44
89700 44 IF(MFREQ(M,5))910,45,46
89800 45 SCORE1=3.0
89900 MFREQ(M,4)=MFREQ(M,3)
90000 MFREQ(M,3)=0
90100 GO TO 425
90200 46 LTIMES=3
90300 SCORE1=5.0
90400 MFREQ(M,7)=MFREQ(M,5)
90500 MFREQ(M,5)=0
90600 465 SCORE2=7.0
90700 GO TO 500
90800 50 IF(MFREQ(M,1))910,51,54
90900 51 LTIMES=4
91000 515 SCORE1=2.0
91100 MFREQ(M,1)=MFREQ(M,2)
91200 MFREQ(M,2)=0
91300 GO TO 410
91400 52 LTIMES=5
91500 521 SCORE1=4.0
91600 MFREQ(M,3)=MFREQ(M,4)
91700 MFREQ(M,4)=0
91800 525 SCORE2=3.0
91900 GO TO 500
92000 53 LTIMES=1
92100 SCORE1=6.0
92200 MFREQ(M,5)=MFREQ(M,6)
92300 MFREQ(M,6)=0
92400 535 SCORE2=5.0
92500 GO TO 500
92600 54 IF(MFREQ(M,2))910,52,55
92700 55 IF(MFREQ(M,4))910,56,57
92800 56 LTIMES=5
92900 565 SCORE1=2.0
93000 MFREQ(M,3)=MFREQ(M,2)
93100 MFREQ(M,2)=0
93200 GO TO 525
93300 57 IF(MFREQ(M,6))910,58,590
93400 58 LTIMES=6
93500 581 SCORE1=4.0
93600 MFREQ(M,5)=MFREQ(M,4)
93700 MFREQ(M,4)=0
93800 GO TO 535
93900 59 LTIMES=1
94000 GO TO 565
94100 590 LTIMES=7
94200 591 SCORE1=6.0
94300 MFREQ(M,7)=MFREQ(M,6)
94400 MFREQ(M,6)=0
94500 GO TO 465
94600 60 IF(MFREQ(M,1))910,61,63
94700 61 LTIMES=8
94800 GO TO 515
94900 62 LTIMES=2
95000 621 SCORE1=3.0
95100 SCORE2=2.0
95200 MFREQ(M,2)=MFREQ(M,3)
95300 MFREQ(M,3)=0
95400 GO TO 500
95500 63 IF(MFREQ(M,2))910,62,64
95600 64 IF(MFREQ(M,3))910,42,65
95700 65 IF(MFREQ(M,5))910,45,66
95800 66 IF(MFREQ(M,6))910,67,68
95900 67 LTIMES=3
96000 671 SCORE1=5.0
96100 SCORE2=6.0
96200 MFREQ(M,6)=MFREQ(M,5)
96300 MFREQ(M,5)=0
96400 GO TO 500
96500 68 LTIMES=9
96600 GO TO 591
96700 70 IF(MFREQ(M,1))910,71,74
96800 71 LTIMES=10
96900 GO TO 515
97000 72 LTIMES=11
97100 GO TO 621
97200 73 LTIMES=1
97300 GO TO 521
97400 74 IF(MFREQ(M,2))910,72,75
97500 75 IF(MFREQ(M,3))910,73,76
97600 76 IF(MFREQ(M,4))910,600,77
97700 77 IF(MFREQ(M,5))910,78,79
97800 78 LTIMES=1
97900 GO TO 581
98000 79 IF(MFREQ(M,6))910,80,81
98100 80 LTIMES=12
98200 GO TO 671
98300 81 LTIMES=13
98400 GO TO 591
98500 500 DO 510 JJ=I,INDEX1,NVAR
98600 IF(A(JJ)-SCORE1)510,505,510
98700 505 A(JJ)=SCORE2
98800 510 CONTINUE
98900 GO TO (600,42,45,52,53,59,58,62,67,72,73,78,80),LTIMES
99000 600 MVAR(M)=MVAR(M)-1
99100 610 RETURN
99200 900 L=2
99300 WRITE (6,4000)I,N1(M),N2(M),M,L
99400 KOMPER=1
99500 GO TO 610
99600 910 WRITE (6,4010)I,N1(M),N2(M),M
99700 KOMPER=1
99800 GO TO 610
99900 4000 FORMAT(1H ,20X,54HMACHINE ERROR. UPON ENTRY TO SUBROUTINE COMBIN W
00100 1ITH I=,I3,7H N1(M)=,I3,7H N2(M)=,I3/10X,9H QUESTION,I3,9H HAS ONLY
00200 2,I2,77H PARTS, WHEREAS IT MUST HAVE AT LEAST 3 PARTS IN ORDER TO H
00300 3AVE A COMBINATION.)
00400 4010 FORMAT(1H ,20X,54HMACHINE ERROR. UPON ENTRY TO SUBROUTINE COMBIN W
00500 1ITH I=,I3,7H N1(M)=,I3,7H N2(M)=,I3/22X,48H ONE OF THE FREQUENCIES
00600 2 OF RESPONSES TO QUESTION,I3,14H WAS NEGATIVE.)
00700 END
00800 CENDCMB SUBROUTINE ENDCMB FOR BMD07S JUNE 3, 1963
00900 C
01000 SUBROUTINE ENDCMB(NDREDK,K,MAXERR,LASTRD)
01100 C
01200 DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
01300 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
01400 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2
01500 37),KONTER(25,7),DUMMY3(7)
01600 COMMON JOBNMB
01700 COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
01800 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN
01900 2DTEM,IDAY,IYEAR,NUMPGE,JOYCAE,MAXLOC,N1,N2,I,DUMMY3,KK
02000 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK
02100 C
02200 EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
02300 1,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR
02400 2),(ERROR,KONTER)
02500 C
02600 MINRED=((LASTNO+199)/200)*NDREDK
02700 C
02800 FLPTN1=MAXERR
02900 FLPTN2=LASTNO
03000 REPERR=FLPTN1/FLPTN2
03100 KK=4
03200 10 CALL FNDCMB(FLPTN2)
03300 IF(KOMPER)500,100,500
03400 100 GO TO (150,155,490),K
03500 150 IF(REPERR-0.1)151,151,155
03600 151 K=2
03700 155 INDEX1=INDTEM+1
03800 INDEX2=INDTEM+NVAR
03900 M=0
04000 J=0
04100 DO 170 L=INDEX1,INDEX2
04200 N=KOLSKR(L+25)
04300 IF(N)900,157,1565
04400 1565 GO TO (159,156,490),K
04500 156 IF(N-MINRED)157,159,159
04600 157 KOLSKR(L)=0
04700 KOLSKR(L+25)=0
04800 N=0
04900 159 IF(M-N)160,170,170
05000 160 M=N
05100 J=L
05200 170 CONTINUE
05300 IF(J)180,180,250
05400 180 K=3
05500 GO TO 10
05600 250 N=M
05700 L=J-INDTEM
05800 M=LVAR(L)
05900 N2(M)=KOLSKR(J)/8
06000 N1(M)=KOLSKR(J)-(N2(M)*8)
06100 NCOMB(M)=NCOMB(M)+1
06200 CALL COMBIN(L,N1,N2(1))
06300 IF(KOMPER)500,300,500
06400 300 I=L
06500 CALL DECTER
06600 MAXERR=MAXERR-N
06700 480 KOMPER=25
06800 GO TO 500
06900 490 KOMPER=50
07000 500 RETURN
07100 900 KOMPER=1
07200 WRITE (6,4900)
07300 GO TO 500
07400 4900 FORMAT(1H0,9X,91H* MACHINE ERROR * THE REDUCTION IN ERROR DUE TO A
07500 1 POSSIBLE COMBINATION IN SUBROUTINE ENDCMB/18X,74HIS NEGATIVE. THI
07600 2S IS NOT POSSIBLE IN THIS PROGRAM. PROGRAM CANNOT PROCEED.)
07700 END
07800 CFNDCMB SUBROUTINE FNDCMB FOR BMD04S, 05S AND 07S JUNE 3, 1963
07900 C
08000 SUBROUTINE FNDCMB(FLPTN2)
08100 C
08200 DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
08300 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
08400 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2
08500 37),KONTER(25,7),DUMMY3(7),DUMMY4(2)
08600 COMMON JOBNMB
08700 COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
08800 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN
08900 2DTEM,IDAY,IYEAR,NUMPGE,JOYCAE,MAXLOC,N1,N2,I,DUMMY3,KK,DUMMY4,L1
09000 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK
09100 C
09200 EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
09300 1,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR
09400 2),(ERROR,KONTER)
09500 C
09600 25000 THETA=0.0
09700 11 DO 300 II=1,NVAR
09800 C
09900 INDEX2=INDTEM+II
10000 INDEXK=LASTNO+II-NVAR
10100 M=LVAR(II)
10200 MTIMES=MVAR(M)
10300 IF(MTIMES-2)200,200,12
10400 12 GO TO (915,1250,915,14),KK
10500 1250 IF(MTIMES-3)200,200,14
10600 14 ITIMES=1
10700 KOLHLD(24)=0
10800 DO 15 J=1,7
10900 KOLHLD(J)=KONTER(M,J)
11000 KOLHLD(24)=KOLHLD(24)+KONTER(M,J)
11100 KOLHLD(J+7)=MFREQ(M,J)
11200 15 CONTINUE
11300 K=INDKOL
11400 DO 30 INDEX=II,INDEXK,NVAR
11500 K=K+1
11600 HOLDA(K)=A(INDEX)
11700 30 CONTINUE
11800 GO TO (915,31,915,32),KK
11900 31 GO TO (295,295,295,60,90,125,155),MTIMES
12000 32 GO TO (295,295,355,61,91,91,91),MTIMES
12100 355 N1(M)=7
12200 36 N2(M)=4
12300 37 CALL COMBIN(II,N1,N2(1))
12400 IF(KOMPER)360,38,360
12500 38 I=II
12600 CALL DECTER
12700 MVAR(M)=MVAR(M)+1
12800 KOLHLD(25)=0
12900 DO 40 J=1,7
13000 KOLHLD(25)=KOLHLD(25)+KONTER(M,J)
13100 GO TO (915,387,915,384),KK
13200 384 IF(MFREQ(M,J))387,387,385
13300 385 IF(MFREQ(M,J)-(KONTER(M,J)+KONTER(M,J)))386,387,387
13400 386 KOLHLD(25)=KOLHLD(24)
13500 387 MFREQ(M,J)=KOLHLD(J+7)
13600 40 CONTINUE
13700 42 K=INDKOL
13800 DO 45 INDEX=II,INDEXK,NVAR
13900 K=K+1
14000 A(INDEX)=HOLDA(K)
14100 45 CONTINUE
14200 GO TO (295,295,405,69,98,131,162),MTIMES
14300 405 GO TO (41,47),ITIMES
14400 41 N1(M)=1
14500 455 ITIMES=2
14600 N=KOLHLD(25)
14700 GO TO (295,295,36,62,92,92,92),MTIMES
14800 47 IF(KOLHLD(25))900,475,475
14900 475 IF(N)900,477,477
15000 477 IF(KOLHLD(25)-N)48,55,58
15100 48 N=KOLHLD(24)-KOLHLD(25)
15200 L=1
15300 482 K=4
15400 485 GO TO (915,486,915,1000),KK
15500 486 IF(N)295,295,49
15600 49 IF(KOLHLD(24)-10)51,51,50
15700 50 IF(N-((KOLHLD(24)+9)/10))295,51,51
15800 51 KOLSKR(INDEX2)=(K*8)+L
15900 KOLSKR(INDEX2+25)=N
16000 GO TO 296
16100 55 GO TO (915,295,915,58),KK
16200 58 N=KOLHLD(24)-N
16300 L=7
16400 GO TO 482
16500 60 L=0
16600 IF(MFREQ(M,7)-(2*KOLHLD(7)))61,63,63
16700 61 N1(M)=7
16800 62 N2(M)=5
16900 GO TO 37
17000 63 IF(MFREQ(M,5)-(2*KOLHLD(5)))61,65,65
17100 65 IF(MFREQ(M,3)-(2*KOLHLD(3)))61,67,67
17200 67 IF(MFREQ(M,1)-(KOLHLD(1)+KOLHLD(1)))85,295,295
17300 69 GO TO (695,70,80),ITIMES
17400 695 N1(M)=3
17500 GO TO 455
17600 70 IF(KOLHLD(25))900,71,71
17700 71 IF(N)900,72,72
17800 72 IF(KOLHLD(25)-N)73,73,745
17900 73 L=2
18000 N=KOLHLD(25)
18100 74 ITIMES=3
18200 N1(M)=1
18300 742 N2(M)=3
18400 GO TO 37
18500 745 L=1
18600 GO TO 74
18700 80 IF(KOLHLD(25))900,81,81
18800 81 IF(KOLHLD(25)-N)82,87,83
18900 82 N=KOLHLD(24)-KOLHLD(25)
19000 K=3
19100 825 L=1
19200 GO TO 485
19300 83 N=KOLHLD(24)-N
19400 IF(L-2)84,845,84
19500 84 L=7
19600 842 K=5
19700 GO TO 485
19800 845 L=3
19900 GO TO 842
20000 85 N=KOLHLD(24)
20100 GO TO 74
20200 87 GO TO (915,295,915,83),KK
20300 90 N=1
20400 GO TO 126
20500 91 N1(M)=7
20600 92 N2(M)=6
20700 GO TO 37
20800 96 IF(MFREQ(M,1)-(KOLHLD(1)+KOLHLD(1)))120,295,295
20900 98 GO TO (99,100,106,111),ITIMES
21000 99 N1(M)=4
21100 GO TO 455
21200 100 IF(KOLHLD(25))900,101,101
21300 101 IF(N)900,102,102
21400 102 IF(KOLHLD(25)-N)103,105,105
21500 103 L=2
21600 N=KOLHLD(25)
21700 104 ITIMES=3
21800 N1(M)=4
21900 1045 N2(M)=2
22000 GO TO 37
22100 105 L=1
22200 GO TO 104
22300 106 IF(KOLHLD(25))900,107,107
22400 107 IF(KOLHLD(25)-N)108,110,109
22500 108 L=3
22600 N=KOLHLD(25)
22700 109 ITIMES=4
22800 1090 N1(M)=1
22900 GO TO 1045
23000 110 IF(L-2)108,109,108
23100 111 IF(KOLHLD(25))900,112,112
23200 112 IF(KOLHLD(25)-N)113,114,114
23300 113 N=KOLHLD(24)-KOLHLD(25)
23400 K=2
23500 GO TO 825
23600 114 IF(L-2)115,118,119
23700 115 K=7
23800 116 L=6
23900 117 N=KOLHLD(24)-N
24000 GO TO 485
24100 118 K=4
24200 GO TO 116
24300 119 L=2
24400 K=4
24500 GO TO 117
24600 120 N=KOLHLD(24)
24700 GO TO 109
24800 125 N=2
24900 126 L=0
25000 DO 128 JJ=2,7
25100 IF((KOLHLD(JJ)+KOLHLD(JJ))-MFREQ(M,JJ))128,128,91
25200 128 CONTINUE
25300 129 GO TO (96,130,161),N
25400 130 IF(MFREQ(M,1)-(KOLHLD(1)+KOLHLD(1)))121,295,295
25500 121 N=KOLHLD(24)
25600 GO TO 146
25700 131 GO TO(132,133,139,143,148),ITIMES
25800 132 N1(M)=5
25900 GO TO 455
26000 133 IF(KOLHLD(25))900,134,134
26100 134 IF(N)900,135,135
26200 135 IF(KOLHLD(25)-N)136,138,138
26300 136 L=2
26400 N=KOLHLD(25)
26500 137 ITIMES=3
26600 N1(M)=5
26700 GO TO 742
26800 138 L=1
26900 GO TO 137
27000 139 IF(KOLHLD(25))900,140,140
27100 140 IF(KOLHLD(25)-N)141,141,142
27200 141 L=3
27300 N=KOLHLD(25)
27400 142 ITIMES=4
27500 N1(M)=2
27600 GO TO 742
27700 143 IF(KOLHLD(25))900,144,144
27800 144 IF(KOLHLD(25)-N)145,147,146
27900 145 L=4
28000 N=KOLHLD(25)
28100 146 ITIMES=5
28200 GO TO 1090
28300 147 IF(L-2)146,145,146
28400 148 IF(KOLHLD(25))900,149,149
28500 149 IF(KOLHLD(25)-N)113,150,150
28600 150 IF(L-4)151,154,154
28700 151 IF(L-2)115,152,153
28800 152 K=5
28900 GO TO 116
29000 153 K=5
29100 GO TO 1545
29200 154 K=2
29300 1545 L=3
29400 GO TO 117
29500 155 N=3
29600 GO TO 126
29700 161 IF(MFREQ(M,1)-(KOLHLD(1)+KOLHLD(1)))189,295,295
29800 162 GO TO(132,163,169,173,178,183),ITIMES
29900 163 IF(KOLHLD(25))900,164,164
30000 164 IF(N)900,165,165
30100 165 IF(KOLHLD(25)-N)166,168,168
30200 166 L=2
30300 N=KOLHLD(25)
30400 167 ITIMES=3
30500 N1(M)=5
30600 1675 N2(M)=4
30700 GO TO 37
30800 168 L=1
30900 GO TO 167
31000 169 IF(KOLHLD(25))900,170,170
31100 170 IF(KOLHLD(25)-N)171,171,172
31200 171 L=3
31300 N=KOLHLD(25)
31400 172 ITIMES=4
31500 N1(M)=3
31600 GO TO 1675
31700 173 IF(KOLHLD(25))900,174,174
31800 174 IF(KOLHLD(25)-N)175,177,176
31900 175 L=4
32000 N=KOLHLD(25)
32100 176 ITIMES=5
32200 N1(M)=3
32300 GO TO 1045
32400 177 IF(L-2)175,175,176
32500 178 IF(KOLHLD(25))900,179,179
32600 179 IF(KOLHLD(25)-N)180,182,181
32700 180 L=5
32800 N=KOLHLD(25)
32900 181 ITIMES=6
33000 GO TO 1090
33100 182 IF(L-2)180,181,181
33200 183 IF(KOLHLD(25))900,184,184
33300 184 IF(KOLHLD(25)-N)113,185,185
33400 185 IF(L-4)186,188,154
33500 186 IF(L-2)115,152,187
33600 187 L=4
33700 K=5
33800 GO TO 117
33900 188 K=4
34000 GO TO 1545
34100 189 N=KOLHLD(24)
34200 GO TO 181
34300 1000 IF(N)295,295,1010
34400 1010 SCORE1=N
34500 KOLSKR(INDEX2)=L+(K*8)
34600 KOLSKR(INDEX2+25)=N
34700 RANKSM(INDEX2+50)=SCORE1/FLPTN2
34800 GO TO 296
34900 200 KOLSKR(INDEX2)=0
35000 KOLSKR(INDEX2+25)=0
35100 GO TO 300
35200 295 KOLSKR(INDEX2)=0
35300 KOLSKR(INDEX2+25)=0
35400 296 DO 297 J=1,7
35500 KONTER(M,J)=KOLHLD(J)
35600 297 CONTINUE
35700 N1(M)=0
35800 N2(M)=0
35900 300 CONTINUE
36000 GO TO (915,301,915,360),KK
36100 301 L1=0
36200 DO 350 II=1,NVAR
36300 INDEX2=INDTEM+II+25
36400 IF(KOLSKR(INDEX2))910,350,310
36500 310 IF(L1-KOLSKR(INDEX2))315,350,350
36600 315 L1=KOLSKR(INDEX2)
36700 J=II
36800 350 CONTINUE
36900 IF(L1)357,360,357
37000 357 INDEX2=INDTEM+J
37100 M=LVAR(J)
37200 L2=KOLSKR(INDEX2)
37300 N1(M)=L2/8
37400 N2(M)=L2-(8*N1(M))
37500 NCOMB(M)=NCOMB(M)+1
37600 CALL COMBIN(J,N1,N2(1))
37700 I=J
37800 KK=2
37900 CALL DECTER
38000 360 RETURN
38100 900 KOMPER=1
38200 WRITE (6,4900)
38300 GO TO 360
38400 910 KOMPER=1
38500 I=INDEX2-INDTEM
38600 M=LVAR(I)
38700 WRITE (6,4910)M
38800 GO TO 360
38900 915 KOMPER=1
39000 WRITE (6,4915)
39100 GO TO 360
39200 4900 FORMAT(1H0,25X,56H* MACHINE ERROR * TOTAL ERROR IN SUB FNDCMB IS N
39300 1EGATIVE.)
39400 4910 FORMAT(1H0,18X,59H* MACHINE ERROR* THE ERROR DUE TO A COMBINATION
39500 1IN QUESTION,I3,13H RESULTS IN A/41X,29HNEGATIVE ERROR IN SUB FNDCM
39600 2B.)
39700 4915 FORMAT(1H0,12X,86H* MACHINE ERROR * SUBROUTINE FNDCMB WAS ENTERED
39800 1WITH AN INCORRECT VALUE OF A CONSTANT.)
39900 END
40000 CFRSTCM SUBROUTINE FRSTCM FOR BMD07S OCTOBER 1, 1964
40100 SUBROUTINE FRSTCM(NPER)
40200 C
40300 DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
40400 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
40500 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(5),DUMMYX(3)
40600 DIMENSION DUMMY2(27)
40700 COMMON JOBNMB
40800 COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
40900 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN
41000 2DTEM,DUMMY1,N1,N2,DUMMYX,L
41100 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK
41200 C
41300 EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
41400 EQUIVALENCE(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR)
41500 C
41600 MINPR=(NPER*NCASE+99)/100
41700 C
41800 10 L=INDKOL
41900 DO 100 I=1,NVAR
42000 M=LVAR(I)
42100 IF(MVAR(M)-2)100,100,12
42200 12 DO 75 J=1,7
42300 IF(MFREQ(M,J))75,75,15
42400 15 IF(MFREQ(M,J)-MINPR)25,75,75
42500 25 L=L+1
42600 KOLSKR(L)=M+(64*J)
42700 75 CONTINUE
42800 100 CONTINUE
42900 125 IF(L-INDKOL)150,150,175
43000 150 RETURN
43100 C
43200 160 L=LL
43300 GO TO 150
43400 C
43500 175 K=INDKOL
43600 MM=0
43700 LL=L
43800 176 K=K+1
43900 IF(K-LL)177,177,160
44000 177 J=KOLSKR(K)/64
44100 I=KOLSKR(K)-(64*J)
44200 IF(I-MM)178,160,178
44300 178 MM=I
44400 DO 179 I=1,NVAR
44500 IF(LVAR(I)-MM)179,1795,179
44600 179 CONTINUE
44700 1795 MTIMES=MVAR(I)-2
44800 GO TO (180,195,205,215,230),MTIMES
44900 180 IF(J-4)185,190,191
45000 185 N2(MM)=1
45100 186 N1(MM)=4
45200 187 NCOMB(MM)=NCOMB(MM)+1
45300 CALL COMBIN(I,N1,N2(1))
45400 GO TO 176
45500 C
45600 190 IF(MFREQ(MM,7)-MFREQ(MM,1))191,191,185
45700 191 N2(MM)=7
45800 GO TO 186
45900 C
46000 195 IF(J-5)196,199,200
46100 196 IF(J-3)197,221,221
46200 197 N1(MM)=1
46300 198 N2(MM)=3
46400 GO TO 187
46500 C
46600 199 N1(MM)=5
46700 GO TO 198
46800 C
46900 200 N1(MM)=7
47000 GO TO 222
47100 C
47200 205 IF(J-6)206,211,213
47300 206 IF(J-2)207,209,210
47400 207 N1(MM)=1
47500 208 N2(MM)=2
47600 GO TO 187
47700 C
47800 209 N1(MM)=2
47900 GO TO 212
48000 C
48100 210 IF(MFREQ(MM,2)-MFREQ(MM,6))2105,2105,2110
48200 2105 N1(MM)=4
48300 GO TO 208
48400 C
48500 2110 N1(MM)=4
48600 GO TO 214
48700 C
48800 211 N1(MM)=6
48900 212 N2(MM)=4
49000 GO TO 187
49100 C
49200 213 N1(MM)=7
49300 214 N2(MM)=6
49400 GO TO 187
49500 C
49600 215 IF(J-6)216,225,213
49700 216 IF(J-3)217,220,223
49800 217 IF(J-2)207,218,220
49900 218 IF(MFREQ(MM,1)-MFREQ(MM,3))2180,2180,2185
50000 2180 N1(MM)=2
50100 2181 N2(MM)=1
50200 GO TO 187
50300 C
50400 2185 N1(MM)=2
50500 GO TO 198
50600 C
50700 219 N1(MM)=3
50800 GO TO 208
50900 C
51000 220 IF(MFREQ(MM,2)-MFREQ(MM,5))219,219,221
51100 221 N1(MM)=3
51200 222 N2(MM)=5
51300 GO TO 187
51400 C
51500 223 IF(MFREQ(MM,3)-MFREQ(MM,6))199,199,2235
51600 2235 N1(MM)=5
51700 GO TO 214
51800 C
51900 224 N1(MM)=6
52000 GO TO 222
52100 C
52200 225 IF(MFREQ(MM,5)-MFREQ(MM,7))224,224,2250
52300 2250 N1(MM)=6
52400 N2(MM)=7
52500 GO TO 187
52600 C
52700 230 IF(J-6)231,225,213
52800 231 IF(J-4)232,236,238
52900 232 IF(J-2)207,218,233
53000 233 IF(MFREQ(MM,2)-MFREQ(MM,4))219,219,234
53100 234 N1(MM)=3
53200 GO TO 212
53300 C
53400 236 IF(MFREQ(MM,3)-MFREQ(MM,5))2360,2360,2370
53500 2360 N2(MM)=3
53600 GO TO 186
53700 C
53800 2370 N2(MM)=5
53900 GO TO 186
54000 C
54100 237 N1(MM)=5
54200 GO TO 212
54300 C
54400 C
54500 238 IF(MFREQ(MM,4).LE.MFREQ(MM,6)) GO TO 237
54600 9000 GO TO 2235
54700 END
54800 CORDER SUBROUTINE ORDER FOR BMD04S, 05S AND 07S JUNE 3, 1963
54900 SUBROUTINE ORDER
55000 C
55100 DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
55200 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
55300 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25)
55400 DIMENSION DUMMY2(27)
55500 COMMON JOBNMB
55600 COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
55700 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN
55800 2DTEM,IDAY,IYEAR,NUMPGE,JOYDAC,MAXLOC,N1,N2
55900 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK
56000 EQUIVALENCE(A,INDIVD,KOLSKR,HOLDA,RANKSM),(INV,LVAR),(HOLD,KOLHLD)
56100 EQUIVALENCE(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR)
56200 211 I=0
56300 C
56400 BIGY=176.0
56500 IJJ=INDKOL+1
56600 L=INDRNK+1
56700 212 Y=0.0
56800 M=INDKOL
56900 J=L+I
57000 DO 225 JRNK=J,INDKOL
57100 IF(Y-RANKSM(JRNK))215,220,225
57200 215 IF(RANKSM(JRNK)-BIGY)216,225,225
57300 216 Y=RANKSM(JRNK)
57400 M=INDKOL
57500 220 M=M+1
57600 KOLSKR(M)=JRNK
57700 225 CONTINUE
57800 BIGY=Y
57900 DO 230 JJ=IJJ,M
58000 I=I+1
58100 MOVFRM=KOLSKR(JJ)-INDRNK
58200 CALL MOVE(MOVFRM,I)
58300 230 CONTINUE
58400 IF(NCASE -I)235,235,212
58500 235 RETURN
58600 END
58700 CORQSCP SUBROUTINE ORQUES FOR BMD07S DECEMBER 16, 1964
58800 SUBROUTINE ORQUES(L)
58900 C
59000 DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
59100 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
59200 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(7)
59300 DIMENSION DUMMY2(27)
59400 DIMENSION DUMMZ(11)
59500 COMMON JOBNMB
59600 COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
59700 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN
59800 2DTEM,IDAY,IYEAR,NUMPGE,JOYDAC,MAXLOC,N1,N2,LL,DUMMY1,NN
59900 COMMON DUMMZ,INDEX3
60000 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK
60100 EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
60200 EQUIVALENCE(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR)
60300 25000 THETA=0.0
60400 ASSIGN 218 TO KSKIP
60500 KK=NVAR+1
60600 JJ=INDKOL+1
60700 IF(L)1,30,1
60800 1 NN=4
60900 INDEX1=INDTEM+75
61000 ASSIGN 212 TO KSKIP
61100 LL=1
61200 1000 M=LVAR(LL)
61300 KOLSKR(INDEX1+1)=0
61400 IF(MFREQ(M,7))4,5,4
61500 4 CALL DECTER
61600 5 KOLHLD (LL)=KOLSKR(INDEX1+1)
61700 LL=LL+1
61800 IF(LL.LE.NVAR)GO TO 1000
61900 INDEX=INDEX1
62000 DO 10 J=1,25
62100 INDEX=INDEX+1
62200 10 KOLSKR(INDEX)=MFREQ(J,7)
62300 K=0
62400 MM=INDKOL
62500 LGEN=0
62600 11 N=NCASE+1
62700 DO 15 J=1,NVAR
62800 IF(KOLHLD (J)-N)12,14,15
62900 12 IF(LGEN-KOLHLD (J))13,15,15
63000 13 N=KOLHLD(J)
63100 MM=INDKOL
63200 14 MM=MM+1
63300 KOLSKR(MM)=J
63400 15 CONTINUE
63500 LGEN=N
63600 DO 20 J=JJ,MM
63700 I=KOLSKR(J)
63800 M=LVAR(I)
63900 K=K+1
64000 20 MFREQ(M,7)=K
64100 IF(NVAR-K)30,30,11
64200 30 LGEN=NCASE+1
64300 40 N=0
64400 MM=INDKOL
64500 DO 150 I=1,NVAR
64600 M=LVAR(I)
64700 IF(N-MFREQ(M,7))50,220,150
64800 50 IF(MFREQ(M,7)-LGEN)55,150,150
64900 55 N=MFREQ(M,7)
65000 MM=INDKOL
65100 60 MM=MM+1
65200 KOLSKR(MM)=I
65300 150 CONTINUE
65400 LGEN=N
65500 DO 200 J=JJ,MM
65600 KK=KK-1
65700 I=KOLSKR(J)
65800 IF(KK-I)175,200,175
65900 175 IJJ=KK
66000 KOLHLD(1)=LVAR(I)
66100 LVAR(I)=LVAR(KK)
66200 LVAR(KK)=KOLHLD(1)
66300 K=LASTNO-NVAR+I
66400 DO 190 INDEX=I,K,NVAR
66500 HOLD(1)=A(INDEX)
66600 A(INDEX)=A(IJJ)
66700 A(IJJ)=HOLD(1)
66800 IJJ=IJJ+NVAR
66900 190 CONTINUE
67000 200 CONTINUE
67100 IF(KK-1)210,210,40
67200 210 GO TO KSKIP,(212,218)
67300 212 DO 215 J=1,25
67400 INDEX1=INDEX1+1
67500 215 MFREQ(J,7)=KOLSKR(INDEX1)
67600 218 RETURN
67700 C
67800 220 IF(MM-(INDKOL+1))60,230,60
67900 230 J=KOLSKR(MM)
68000 IF(LVAR(J)-M)240,60,60
68100 240 KOLSKR(MM+1)=J
68200 KOLSKR(MM)=I
68300 MM=MM+1
68400 GO TO 150
68500 C
68600 END
68700 CREORDR SUBROUTINE REORDR FOR BMD07S AUGUST 19, 1964
68800 SUBROUTINE REORDR
68900 C
69000 DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
69100 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
69200 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2
69300 37),KONTER(25,7)
69400 COMMON JOBNMB
69500 COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
69600 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN
69700 2DTEM,IDAY,IYEAR,NUMPGE,JOYCDA,MAXLOC,N1,N2,I
69800 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK
69900 C
70000 EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
70100 1,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR
70200 2),(ERROR,KONTER)
70300 C
70400 25000 THETA=0.0
70500 IT2=2
70600 C
70700 C TWO SCRATCH TAPES MAY BE CALLED IN THIS PROGRAM IF THE DATA
70800 C REQUIRES MOST OF THE STORAGE LOCATIONS. THEY ARE DESIGNATED HERE
70900 C BY IT2 AND IT3. IF THE NUMBER OF CASES=N AND THE NUMBER OF
71000 C QUESTIONS =P, THEN IT3 WILL BE USED IF NP+6N IS GREATER THAN
71100 C 20,000. IT2 AND IT3 WILL BOTH BE USED IF NP+5N IS GREATER THAN
71200 C 20,000.
71300 C
71400 IT3=3
71500 C
71600 ASSIGN 26 TO KOMPLT
71700 IMEMRY=1
71800 INDEX=INDTEM+NCASE+NCASE
71900 INDEXK=INDEX+NCASE
72000 IF(INDEXK-8000) 9,9,4
72100 4 IF(INDEX-8000) 7,7,6
72200 6 IMEMRY=3
72300 REWIND IT2
72400 GO TO 8
72500 C
72600 7 IMEMRY=2
72700 8 REWIND IT3
72800 9 INDEXK=INDTEM+NCASE
72900 JRNK=INDRNK+1
73000 TOT=RANKSM(JRNK)
73100 NVARHF=NVAR/2+1
73200 M=0
73300 L=INDKOL+1
73400 K=INDKOL
73500 DO 25 I=JRNK,K
73600 IF(RANKSM(I)-TOT)10,20,900
73700 10 TOT=RANKSM(I)
73800 11 IF(1-M)21,25,25
73900 21 J=I-INDRNK
74000 KOLSKR(L)=J-M
74100 KOLSKR(L+1)=J-1
74200 L=L+2
74300 M=0
74400 20 M=M+1
74500 25 CONTINUE
74600 GO TO KOMPLT,(26,29)
74700 26 ASSIGN 29 TO KOMPLT
74800 I=K+1
74900 GO TO 11
75000 29 IF((INDKOL+1)-L)30,321,905
75100 30 NUMPRS=(L-INDKOL-1)/2
75200 L1=INDKOL-1
75300 INDXT1=LASTNO+1
75400 INDXT2=INDKOL
75500 IREADT=1
75600 GO TO (370,306,305),IMEMRY
75700 305 NPOINT=(INDRNK-INDXT1+128)/128
75800 NWED=INDXT1-1
75900 IF (NPOINT.LE.1) GO TO 3330
76000 DO 3331 J=1,NPOINT-1
76100 NJ=(J-1)*128+NWED+1
76200 NJJ=J*128+NWED
76300 3331 WRITE(IT2)(INDIVD(JJJ),JJJ=NJ,NJJ)
76400 3330 NJ=(NPOINT-1)*128+NWED+1
76500 WRITE(IT2)(INDIVD(JJJ),JJJ=NJ,INDRNK)
76600 ENDFILE IT2
76700 306 GO TO (307,308),IREADT
76800 307 NPOINT=(INDXT2-JRNK+128)/128
76900 NWED=JRNK-1
77000 IF (NPOINT.LE.1) GO TO 3337
77100 DO 3338 J=1,NPOINT-1
77200 NJ=(J-1)*128+NWED+1
77300 NJJ=J*128+NWED
77400 3338 WRITE(IT3)(RANKSM(JJJ),JJJ=NJ,NJJ)
77500 3337 NJ=(NPOINT-1)*128+NWED+1
77600 WRITE(IT3)(RANKSM(JJJ),JJJ=NJ,INDXT2)
77700 END FILE IT3
77800 REWIND IT3
77900 GO TO (31,350,308),IMEMRY
78000 308 REWIND IT2
78100 31 L1=L1+2
78200 K1=KOLSKR(L1)
78300 K2=KOLSKR(L1+1)
78400 MOVETO=K1-1
78500 NUMSAM=K2-K1+1
78600 INDEX2=K1*NVAR
78700 INDEX3=K2*NVAR
78800 L=INDRNK
78900 35 DO 50 I=INDEX2,INDEX3,NVAR
79000 L=L+1
79100 RANKSM(L)=0.0
79200 INDEX1=I-NVAR+NVARHF
79300 40 DO 45 J=INDEX1,I
79400 RANKSM(L)=RANKSM(L)+A(J)
79500 45 CONTINUE
79600 50 CONTINUE
79700 BIGY=92.0
79800 I=INDTEM
79900 INDEX2=INDRNK+NUMSAM
80000 51 Y=0.0
80100 L=LASTNO
80200 DO 55 J=JRNK,INDEX2
80300 IF(Y-RANKSM(J))52,54,55
80400 52 IF(RANKSM(J)-BIGY)53,55,55
80500 53 Y=RANKSM(J)
80600 L=LASTNO
80700 54 L=L+1
80800 INDIVD(L)=J-INDRNK
80900 55 CONTINUE
81000 BIGY=Y
81100 DO 60 JJ=INDXT1,L
81200 I=I+1
81300 INDIVD(I)=INDIVD(JJ)
81400 60 CONTINUE
81500 IF((NUMSAM+INDTEM)-I)64,64,51
81600 64 GO TO (390,390,65),IMEMRY
81700 65 NPOINT=(INDRNK-INDXT1+128)/128
81800 NWED=INDXT1-1
81900 IF (NPOINT.LE.1) GO TO 6665
82000 DO 6666 J=1,NPOINT-1
82100 NJ=(J-1)*128+NWED+1
82200 NJJ=J*128+NWED
82300 6666 READ(IT2)(INDIVD(JJJ),JJJ=NJ,NJJ)
82400 6665 NJ=(NPOINT-1)*128+NWED+1
82500 READ(IT2)(INDIVD(JJJ),JJJ=NJ,INDRNK)
82600 66 REWIND IT2
82700 67 DO 70 J=JRNK,INDEX2
82800 INDIVD(J)=0
82900 70 CONTINUE
83000 INDEX1=INDTEM+1
83100 INDEX2=INDTEM+NUMSAM
83200 DO 75 JJ=INDEX1,INDEX2
83300 L=INDIVD(JJ)
83400 LL=L+INDRNK
83500 MOVETO=MOVETO+1
83600 MOVFRM=L+INDIVD(LL)+K1-1
83700 IF(MOVFRM-MOVETO)71,75,71
83800 71 KK=2
83900 CALL MOVFOR(MOVFRM,MOVETO,KK)
84000 JRNK=INDRNK+1
84100 DO 74 I=JRNK,LL
84200 INDIVD(I)=INDIVD(I)+1
84300 74 CONTINUE
84400 75 CONTINUE
84500 NUMPRS=NUMPRS-1
84600 IF(NUMPRS)905,100,80
84700 80 IREADT=2
84800 INDEXK=INDTEM+NCASE
84900 GO TO (350,350,305),IMEMRY
85000 C
85100 100 GO TO (400,105,105),IMEMRY
85200 105 NPOINT=(INDXT2-JRNK+128)/128
85300 NWED=JRNK-1
85400 IF (NPOINT.LE.1) GO TO 1115
85500 DO 1116 J=1,NPOINT-1
85600 NJ=(J-1)*128+NWED+1
85700 NJJ=J*128+NWED
85800 1116 READ(IT3)(RANKSM(JJJ),JJJ=NJ,NJJ)
85900 1115 NJ=(NPOINT-1)*128+NWED+1
86000 READ(IT3)(RANKSM(JJJ),JJJ=NJ,INDXT2)
86100 200 REWIND IT3
86200 321 RETURN
86300 C
86400 350 MM=INDEXK
86500 DO 360 J=INDXT1,INDRNK
86600 MM=MM+1
86700 INDIVD(MM)=INDIVD(J)
86800 360 CONTINUE
86900 GO TO 31
87000 C
87100 370 MM=INDEX
87200 DO 380 J=JRNK,INDXT2
87300 MM=MM+1
87400 HOLDA(MM)=RANKSM(J)
87500 380 CONTINUE
87600 GO TO 350
87700 C
87800 390 MM=INDEXK
87900 DO 395 J=INDXT1,INDRNK
88000 MM=MM+1
88100 INDIVD(J)=INDIVD(MM)
88200 395 CONTINUE
88300 GO TO 67
88400 C
88500 400 MM=INDEX
88600 DO 405 J=JRNK,INDXT2
88700 MM=MM+1
88800 RANKSM(J)=HOLDA(MM)
88900 405 CONTINUE
89000 GO TO 321
89100 C
89200 900 KOMPER=1
89300 J=LASTNO+I-INDRNK
89400 I=INDIVD(J)
89500 WRITE (6,4900)I
89600 GO TO 321
89700 C
89800 905 KOMPER=1
89900 WRITE (6,4905)
90000 GO TO 321
90100 C
90200 8000 FORMAT(20A4)
90300 4900 FORMAT(1H ,52X,13HMACHINE ERROR/30X,10HRESPONDENT,I5,39H WAS FOUND
90400 1 OUT OF ORDER IN SUB REORDER.)
90500 4905 FORMAT(1H ,52X,13HMACHINE ERROR/29X,60HA COUNT WHICH SHOULD BE POS
90600 1ITIVE IN SUB REORDER IS NEGATIVE.)
90700 C
90800 END
90900 CRKCHNG SUBROUTINE RKCHNG FOR BMD07S OCTOBER 22, 1965
91000 C
91100 SUBROUTINE RKCHNG(MAXERR)
91200 C
91300 DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
91400 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
91500 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2
91600 37),KONTER(25,7),DUMMY3(5),DUMMY4(1),DUMMY5(10)
91700 COMMON JOBNMB
91800 COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
91900 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN
92000 2DTEM,IDAY,IYEAR,NUMPGE,JOYCAE,MAXLOC,N1,N2,KK,DUMMY3,IFIRST,DUMMY4
92100 3,NN,ICHNGE,DUMMY5,INDEX3
92200 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK
92300 C
92400 EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
92500 1,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR
92600 2),(ERROR,KONTER)
92700 C
92800 25000 THETA=0.0
92900 IT1=4
93000 C
93100 C IT1 IS THE TAPE WHICH CONTAINS THE ORIGINAL WEIGHTED RESPONSES.
93200 L2=NVAR+1
93300 C
93400 K=1
93500 KIND=INDKOL
93600 IF(NCASE-175)400,425,425
93700 400 KIND=INDTEM+500
93800 425 MINERR=MAXERR-(((MAXERR+19)/20)*ICHNGE)
93900 IF(MINERR)450,465,465
94000 450 MINERR=0
94100 465 DO 550 N=1,NVAR
94200 NN=4
94300 KK=L2-N
94400 CALL DECTER
94500 INDEX2=LASTNO+KK
94600 INDEX3=INDEX3+1
94700 KOLSKR(INDEX3)=NCASE
94800 L1=LVAR(KK)
94900 IM=MVAR(L1)-1
95000 IL=0
95100 DO 530 JJ=1,7
95200 MM=8-JJ
95300 IF(KONTER(L1,MM))915,4655,466
95400 4655 NOUT=7
95500 NIN=MFREQ(L1,MM)
95600 IF(NIN)530,530,4665
95700 466 NOUT=KONTER(L1,MM)
95800 NIN=MFREQ(L1,MM)-NOUT
95900 IF(-NIN) 4665,530,530
96000 4665 FLPTN1=MM
96100 IL=IL+1
96200 IF(IL-1)4666,4666,4667
96300 4666 INDEX1=KK
96400 GO TO 4677
96500 4667 I=INDTEM+74+IL
96600 4668 INDEX1=(KOLSKR(I)-1)*NVAR+KK
96700 467 INDEX1=INDEX1+NVAR
96800 4677 IF(INDEX1-INDEX2)468,530,530
96900 468 IF(FLPTN1-A(INDEX1))469,4681,469
97000 4681 NIN=NIN-1
97100 IF(NIN)4682,4682,467
97200 4682 GO TO (4671,4684,4685,4686,4687,4688),IM
97300 4684 GO TO (4674,4671,530),IL
97400 4685 GO TO (4675,4673,4671,530),IL
97500 4686 GO TO (4676,4674,4672,4671,530),IL
97600 4687 GO TO (4676,4675,4673,4672,4671,530),IL
97700 4688 GO TO (4676,4675,4674,4673,4672,4671,530),IL
97800 4671 FLPTN1=1.0
97900 GO TO 4678
98000 4672 FLPTN1=2.0
98100 GO TO 4678
98200 4673 FLPTN1=3.0
98300 GO TO 4678
98400 4674 FLPTN1=4.0
98500 GO TO 4678
98600 4675 FLPTN1=5.0
98700 GO TO 4678
98800 4676 FLPTN1=6.0
98900 4678 II=FLPTN1
99000 NIN=MFREQ(L1,II)-KONTER(L1,II)
99100 GO TO 467
99200 469 IF(-A(INDEX1))4692,467,467
99300 4692 IK=A(INDEX1)
99400 GO TO (200,250,300,350,600,700),IM
99500 200 MOVETO=KOLSKR(INDTEM+76)+1
99600 210 IF(MOVETO)900,900,473
99700 250 GO TO (252,467,467,254,467,467,200),IK
99800 252 MOVETO=KOLSKR(INDTEM+77)+1
99900 GO TO 210
00100 254 IF(MM-1)252,252,200
00200 300 GO TO (301,467,301,467,252,467,200),IK
00300 301 MOVETO=KOLSKR(INDTEM+78)+1
00400 GO TO 210
00500 350 GO TO (351,351,467,301,467,252,200),IK
00600 351 MOVETO=KOLSKR(INDTEM+79)+1
00700 GO TO 210
00800 600 GO TO (601,601,351,467,301,252,200),IK
00900 601 MOVETO=KOLSKR(INDTEM+80)+1
01000 GO TO 210
01100 700 GO TO (701,701,601,351,301,252,200),IK
01200 701 MOVETO=KOLSKR(INDTEM+81)+1
01300 GO TO 210
01400 C
01500 473 MOVFRM=(INDEX1-KK)/NVAR+1
01600 IF(MOVFRM-NCASE)4735,4735,900
01700 4735 IF(MOVETO-NCASE)4737,4737,467
01800 4737 IF(-MOVFRM)4738,900,900
01900 4738 CALL MOVFOR(MOVFRM,MOVETO,K)
02000 474 J=KIND
02100 DO 478 II=1,NVAR
02200 I=LVAR(II)
02300 DO 477 L=1,7
02400 475 J=J+1
02500 KOLSKR(J)=KONTER(I,L)
02600 477 CONTINUE
02700 478 CONTINUE
02800 C
02900 C DETERMINE NEW ERROR
03000 480 NN=3
03100 CALL DECTER
03200 NERROR=0
03300 DO 485 II=1,NVAR
03400 I=LVAR(II)
03500 DO 484 J=1,7
03600 NERROR=NERROR+KONTER(I,J)
03700 484 CONTINUE
03800 485 CONTINUE
03900 IF(MAXERR-NERROR)486,486,495
04000 486 J=KIND
04100 DO 490 II=1,NVAR
04200 I=LVAR(II)
04300 DO 488 L=1,7
04400 J=J+1
04500 KONTER(I,L)=KOLSKR(J)
04600 488 CONTINUE
04700 490 CONTINUE
04800 CALL MOVFOR(MOVETO,MOVFRM,K)
04900 GO TO 496
05000 C
05100 495 MAXERR=NERROR
05200 496 IF(MINERR-MAXERR)497,555,555
05300 497 CONTINUE
05400 C
05500 4975 NN=4
05600 KK=L2-N
05700 CALL DECTER
05800 INDEX3=INDEX3+1
05900 KOLSKR(INDEX3)=NCASE
06000 GO TO 467
06100 C
06200 C 0
06300 C 0
06400 530 CONTINUE
06500 550 CONTINUE
06600 555 RETURN
06700 C
06800 900 KOMPER=1
06900 WRITE (6,4900)MOVFRM,MOVETO
07000 GO TO 555
07100 C
07200 915 KOMPER=1
07300 WRITE (6,4915)L1,MM
07400 GO TO 530
07500 C
07600 4900 FORMAT(1H0,104HIN MOVING AN INDIVIDUAL AND HIS RESPONSES IN SUB RK
07700 1CHNG, THE RANK MOVED FROM OR TO IS IN ERROR. THEY ARE,I5,4H ANDI5)
07800 4915 FORMAT(1H ,52X,13HMACHINE ERROR/19X,27HNEGATIVE ERROR FOR QUESTION
07900 1,I3,6H SCORE,I2,25H WAS FOUND IN SUB RKCHNG.)
08000 C
08100 END
08200 CDECTER SUBROUTINE DECTER FOR GUTTMAN SCALES JUNE 15, 1967
08300 SUBROUTINE DECTER
08400 C
08500 DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
08600 X(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
08700 XQ(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),KONTER(2
08800 X5,7),DUMMY3(5),DUMMY4(7),DUMMY5(11),DUMMY2(27)
08900 C
09000 COMMON JOBNMB
09100 COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
09200 XAR,INDRNK,INDKOL,ISCALE,IRAMK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN
09300 XDTEM,DUMMY3,N1,N2,I,DUMMY4,KK,DUMMY5,INDEX3
09400 C
09500 EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
09600 1,(DUMMY1,MFREQ),(ERROR,KONTER),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),
09700 2(DUMMY2(27),NVAR)
09800 C
09900 DOUBLE PRECISION DUMMY2, FRSTMO, SECMON, JOBNMB, KDUMY6, REF, KCHECK
10000 KTIMES=I
10100 INDEX3=INDTEM+75
10200 10 DO 200 I=1,NVAR
10300 GO TO (12,11,12,11),KK
10400 11 IF(KTIMES-I)210,12,200
10500 12 INCHCK=LASTNO+I
10600 M=LVAR(I)
10700 DO 14 J=1,7
10800 KONTER(M,J)=0
10900 14 CONTINUE
11000 MTIMES=MVAR(M)
11100 J=7
11200 INDEX=I
11300 INDEX1=I
11400 LTIMES=1
11500 15 NERROR=MFREQ(M,J)
11600 L1=0
11700 K=0
11800 LL=0
11900 IJJ=NERROR
12000 FLPTN1=J
12100 KERROR=0
12200 ITIMES=1
12300 JTIMES=1
12400 20 IF(A(INDEX))25,41,25
12500 25 IF(A(INDEX)-FLPTN1)30,45,30
12600 30 IF(NERROR-MFREQ(M,J))35,42,42
12700 35 GO TO (36,39,48),ITIMES
12800 36 INDEX=INDEX-NVAR
12900 IF(-INDEX)37,38,38
13000 37 IF(A(INDEX))375,375,38
13100 375 K=K-1
13200 LL=LL-1
13300 GO TO 36
13400 38 INDEX=INDEX+NVAR
13500 385 IJJ=NERROR
13600 L1=L1+K
13700 K=0
13800 LL=LL+KERROR
13900 KERROR=0
14000 ITIMES=2
14100 JTIMES=1
14200 GO TO 4935
14300 39 KERROR=KERROR+1
14400 IF(KERROR-IJJ)46,46,499
14500 40 INDEX=INDEX+NVAR
14600 IF(INDEX-INCHCK)20,55,55
14700 41 K=K+1
14800 42 LL=LL+1
14900 GO TO 40
15000 45 NERROR=NERROR-1
15100 GO TO (46,47,475),ITIMES
15200 46 IF(NERROR)52,52,40
15300 47 ITIMES=3
15400 475 IF(NERROR)477,477,40
15500 477 IF(IJJ-KERROR)499,385,385
15600 48 IF((IJJ-NERROR)-KERROR)49,36,36
15700 49 GO TO (492,494,499),JTIMES
15800 492 JTIMES=2
15900 493 ITIMES=2
16000 4935 IF(NERROR)499,499,39
16100 494 JTIMES=3
16200 GO TO 493
16300 499 INDEX=(MFREQ(M,J)-IJJ+LL-K)*NVAR+INDEX1
16400 50 INDEX1=INDEX
16500 500 GO TO (5005,5005,555,555),KK
16600 5005 KONTER(M,J)=IJJ+LL-L1-K
16700 501 GO TO (509,509,502,502),KK
16800 502 INDEX3=INDEX3+1
16900 KOLSKR(INDEX3)=(INDEX-I)/NVAR
17000 509 IF(INDEX-INCHCK)51,190,190
17100 51 GO TO (1995, 59 ,57,65,70,75,80),MTIMES
17200 52 IJJ=0
17300 INDEX=INDEX+NVAR
17400 GO TO 50
17500 55 IF((IJJ-NERROR)-KERROR)499,56,56
17600 555 KONTER(M,J)=IJJ
17700 GO TO 501
17800 56 IJJ=NERROR
17900 LL=LL+KERROR
18000 GO TO 500
18100 57 GO TO (58,59),LTIMES
18200 58 LTIMES=2
18300 585 J=4
18400 GO TO 15
18500 59 K=0
18600 LL=0
18700 INDEX=INDEX-NVAR
18800 60 INDEX=INDEX+NVAR
18900 IF(INDEX-INCHCK)61,63,1995
19000 61 IF(A(INDEX)-1.0)60,62,625
19100 62 K=K+1
19200 GO TO 60
19300 625 LL=LL+1
19400 GO TO 60
19500 63 GO TO (635,635,64,64),KK
19600 635 KONTER(M,1)=MFREQ(M,1)-K+LL
19700 GO TO 1995
19800 64 LL=0
19900 GO TO 635
20000 65 GO TO (67,68,59),LTIMES
20100 67 LTIMES=2
20200 675 J=5
20300 GO TO 15
20400 68 LTIMES=3
20500 685 J=3
20600 GO TO 15
20700 70 GO TO (72,73,74,59),LTIMES
20800 72 LTIMES=2
20900 725 J=6
21000 GO TO 15
21100 73 LTIMES=3
21200 GO TO 585
21300 74 LTIMES=4
21400 745 J=2
21500 GO TO 15
21600 75 GO TO (72,76,77,78,59),LTIMES
21700 76 LTIMES=3
21800 GO TO 675
21900 77 LTIMES=4
22000 GO TO 685
22100 78 LTIMES=5
22200 GO TO 745
22300 80 GO TO (72,76,81,82,83,59),LTIMES
22400 81 LTIMES=4
22500 GO TO 585
22600 82 LTIMES=5
22700 GO TO 685
22800 83 LTIMES=6
22900 GO TO 745
23000 190 GO TO (1995,193 ,191,194,198,1904,1908),MTIMES
23100 191 GO TO (192,193),LTIMES
23200 192 KONTER(M,4)=MFREQ(M,4)
23300 193 KONTER(M,1)=MFREQ(M,1)
23400 GO TO 1995
23500 194 GO TO (195,196,193),LTIMES
23600 195 KONTER(M,5)=MFREQ(M,5)
23700 196 KONTER(M,3)=MFREQ(M,3)
23800 GO TO 193
23900 198 GO TO (199,1901,1902,193),LTIMES
24000 199 KONTER(M,6)=MFREQ(M,6)
24100 1901 KONTER(M,4)=MFREQ(M,4)
24200 1902 KONTER(M,2)=MFREQ(M,2)
24300 GO TO 193
24400 1904 GO TO (1905,1906,1907,1902,193),LTIMES
24500 1905 KONTER(M,6)=MFREQ(M,6)
24600 1906 KONTER(M,5)=MFREQ(M,5)
24700 1907 KONTER(M,3)=MFREQ(M,3)
24800 GO TO 1902
24900 1908 GO TO (1909,1910,1911,1907,1902,193),LTIMES
25000 1909 KONTER(M,6)=MFREQ(M,6)
25100 1910 KONTER(M,5)=MFREQ(M,5)
25200 1911 KONTER(M,4)=MFREQ(M,4)
25300 GO TO 1907
25400 1995 GO TO (200,210,200,210),KK
25500 200 CONTINUE
25600 210 RETURN
25700 END
25800 CMOVE SUBROUTINE MOVE FOR GUTTMAN SCALES PROGRAMS
25900 CMOVE SUBROUTINE MOVE FOR GUTTMAN SCALES APRIL 15, 1967
26000 SUBROUTINE MOVE(M1,M2)
26100 DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
26200 X(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
26300 XQ(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2
26400 X7),KONTER(25,7),DUMMY3(5),DUMMY4(7),DUMMY5(11)
26500 C
26600 EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
26700 X,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR
26800 X),(ERROR,KONTER)
26900 C
27000 COMMON JOBNMB
27100 COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
27200 XAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN
27300 XDTEM,DUMMY3,N1,N2,I,DUMMY4,KK,DUMMY5
27400 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK
27500 C
27600 25000 YHETA=0.0
27700 IF(M1-M2)5,100,5
27800 C EXCHANGE RESPONSES FOR RANKS M1 AND M2
27900 5 INDEX1=(M1-1)*NVAR
28000 INDEX2=((M2-1)*NVAR)+1
28100 INDEX3=INDEX2+NVAR-1
28200 DO 50 I=INDEX2,INDEX3
28300 INDEX1=INDEX1+1
28400 GSABE=A(INDEX1)
28500 A(INDEX1)=A(I)
28600 A(I)=GSABE
28700 50 CONTINUE
28800 C EXCHANGE IDENTIFICATION NUMBERS
28900 INDEX1=M1+LASTNO
29000 INDEX2=M2+LASTNO
29100 KSAVE=INDIVD(INDEX1)
29200 INDIVD(INDEX1)=INDIVD(INDEX2)
29300 INDIVD(INDEX2)=KSAVE
29400 C EXCHANGE RANK SUMS
29500 75 INDEX1=M1+INDRNK
29600 INDEX2=M2+INDRNK
29700 FSAVE=RANKSM(INDEX1)
29800 RANKSM(INDEX1)=RANKSM(INDEX2)
29900 RANKSM(INDEX2)=FSAVE
30000 100 RETURN
30100 END
30200 CMVDATA SUBROUTINE MVDATA FOR GUTTMAN SCALES JUNE 15, 1967
30300 CMVDATA SUBROUTINE MVDATA FOR GUTTMAN SCALES PROGRAMS
30400 SUBROUTINE MVDATA(M1,M2)
30500 DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
30600 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
30700 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),KONTER(2
30800 35,7),DUMMY3(5),DUMMY4(7),DUMMY5(9)
30900 DIMENSION DUMMY2(27)
31000 C
31100 COMMON JOBNMB
31200 COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
31300 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN
31400 3DTEM,DUMMY3,N1,N2,I,DUMMY4,KK,DUMMY5
31500 EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
31600 1,(DUMMY1,MFREQ),(ERROR,KONTER)
31700 EQUIVALENCE(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR)
31800 DOUBLE PRECISION DUMMY2
31900 DOUBLE PRECISION JB,JOBNMB,JBND,REF,REFLEK,SECMON,FRSTMO,BLANKS,
32000 1BND
32100 25000 THETA=0.0
32200 IF(M1-M2)5,100,5
32300 C EXCHANGE RESPONSES FOR RANKS M1 AND M2
32400 5 INDEX1=(M1-1)*NVAR
32500 INDEX2=((M2-1)*NVAR)+1
32600 INDEX3=INDEX2+NVAR-1
32700 DO 50 I=INDEX2,INDEX3
32800 INDEX1=INDEX1+1
32900 GSAVE=A(INDEX1)
33000 A(INDEX1)=A(I)
33100 A(I)=GSAVE
33200 50 CONTINUE
33300 C EXCHANGE IDENTIFICATION NUMBERS
33400 INDEX1=M1+LASTNO
33500 INDEX2=M2+LASTNO
33600 KSAVE=INDIVD(INDEX1)
33700 INDIVD(INDEX1)=INDIVD(INDEX2)
33800 INDIVD(INDEX2)=KSAVE
33900 100 RETURN
34000 END
34100 CMOVFOR SUBROUTINE MOVFOR FOR GUTTMAN SCALE PROGRAMS
34200 SUBROUTINE MOVFOR(M1,M2,KK)
34300 DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
34400 X(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
34500 XQ(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2
34600 X7),KONTER(25,7),DUMMY3(5),DUMMY4(7),DUMMY5(9)
34700 C
34800 EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
34900 X,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR
35000 X),(ERROR,KONTER)
35100 C
35200 COMMON JOBNMB
35300 COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
35400 XAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN
35500 XDTEM,DUMMY3,N1,N2,I,DUMMY4,KKP,DUMMY5
35600 DOUBLE PRECISION JOB,JOBNMB,JBND,REF
35700 DOUBLE PRECISION SECMON,FRSTMO
35800 DOUBLE PRECISION DUMMY2
35900 DOUBLE PRECISION REFLEK
36000 DOUBLE PRECISION BLANKS,BND
36100 C
36200 25000 THETA=0.0
36300 KK=KK
36400 INDEX1=M2*NVAR
36500 INDEXK=INDEX1-NVAR
36600 INDEX2=M1*NVAR
36700 M=INDEX2-NVAR+1
36800 INDEX3=M-1
36900 DO 25 I=1,NVAR
37000 INDEX3=INDEX3+1
37100 HOLD(I)=A(INDEX3)
37200 25 CONTINUE
37300 JRNK=M1+INDRNK
37400 HOLD(NVAR+1)=RANKSM(JRNK)
37500 INDIDV=M1+LASTNO
37600 IJJ=INDIVD(INDIDV)
37700 IF(M2-M1)50,500,300
37800 50 NADD=-NVAR
37900 NONE=-1
38000 55 L=M
38100 J=M-1+NADD
38200 DO 60 I=L,INDEX2
38300 J=J+1
38400 A(I)=A(J)
38500 60 CONTINUE
38600 M=L+NADD
38700 IND=INDIDV+NONE
38800 INDIVD(INDIDV)=INDIVD(IND)
38900 INDIDV=IND
39000 GO TO (65,70),KK
39100 65 IRNK=JRNK+NONE
39200 RANKSM(JRNK)=RANKSM(IRNK)
39300 JRNK=IRNK
39400 70 INDEX2=INDEX2+NADD
39500 IF(INDEX2-INDEX1)55,100,55
39600 100 DO 125 I=1,NVAR
39700 INDEXK=INDEXK+1
39800 A(INDEXK)=HOLD(I)
39900 125 CONTINUE
40000 INDIVD(INDIDV)=IJJ
40100 GO TO (140,500),KK
40200 140 RANKSM(JRNK)=HOLD(NVAR+1)
40300 500 RETURN
40400 300 NADD=NVAR
40500 NONE=1
40600 GO TO 55
40700 END
40800 SUBROUTINE REMOVE(N)
40900 REWIND N
41000 RETURN
41100 END
41200
41300
41400
41500
41600
41700
41800
41900
42000
42100
42200
42300
42400
42500
42600
42700
42800
42900
43000
43100
43200
43300
43400
43500
43600
43700
43800
43900
44000
44100
44200
44300
44400
44500
44600
44700
44800
44900
45000
45100
45200
45300
45400
45500
45600
45700
45800
45900
46000
46100
46200
46300
46400
46500