CBD07S GUTTMAN SCALES NO. 2 - PART 2 OCTOBER 22, 1965 DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2 37),KONTER(25,7),DUMMY3(1),KSTEP(6), KDUMY6(2),REF(25),NN1(6),NN2(6 4),NN3(6) COMMON JOBNMB COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV 1AR,INDRNK,INDKOL,ISCALE,LESTN,LEAVE,IERROR,KANEND,KOMPER,KORDER,IN 2DTEM,IDAY,IYEAR,NUMPGE,JOYCAE,MAXLOC,N1,N2,DUMMY3,LASTRD,NDREDK,L, 3IFINAL,ILAST,IFIRST,IXTRA,KK,ICHNGE,NFIRST,L1,IEND,MCOMB,IPUNCH,NP 4ER,KDUMY6,INDEX3 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK DOUBLE PRECISION DUM,QCTR C EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD) 1,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR 2),(ERROR,KONTER),(YES,IYES) C DATA QCTR/8H* / DATA DUM/8HFORCOM / DATA IYES/4HYES / IT1=1 CALL USAGEB('BMD07S') C C BMD07S USES THE FOLLOWING SUBROUTINES FOUND IN BMD04S, C COMBIN DECTER FNDCMB FRSTCM C MOVE MOVFOR ORDER ORQUES C REORDR C C THIS PROGRAM REQUIRES THE TAPE UNIT DESIGNATED IT4 IN BMD06S. C IT4 IS THE SAVE TAPE WITH ALL OF COMMON STORAGE WRITTEN ON IT. C C IT1 IS THE TAPE WHICH CONTAINS THE ORIGINAL WEIGHTED RESPONSES. C LOPE=0 IT4=4 C 4515 FORMAT('1BMD07S - GUTTMAN SCALE NUMBER 2, PART 2 - REVISED ', 1'SEPTEMBER 23, 1968'/ 23X,40HHEALTH SCIENCES COMPUTING FACILITY, UCLA) C REWIND IT4 READ(IT4) J READ(IT4) (REF(I),I=1,25) NPOINT=(J+127)/128 IF (NPOINT.LE.1) GO TO 9991 DO 9001 I=1,NPOINT-1 NI=(I-1)*128+1 NII=I*128 9001 READ(IT4)(A(K),K=NI,NII) 9991 NI=(NPOINT-1)*128+1 READ(IT4)(A(K),K=NI,J) DO 9992 I=1,4 NI=(I-1)*128+1 NII=I*128 9992 READ(IT4)(LVAR(K),K=NI,NII) READ(IT4)(LVAR(K),K=513,558),INDEX3 READ(IT4) JOBNMB,(DUMMY2(I),I=1,27),FRSTMO,SECMON,(KDUMY6(J) 1,J=1,2) REWIND IT4 C C KDUMY6(1)=DUM C DUMMY3(17) HAS THE SAME LOCATION AS KDUMY6(1). THUS WE CAN USE IT C FOR THE FIXED POINT SUBTRACTION PRIOR TO FORTRAN STATEMENT NUMBER C 2029. C FKEEP=0.0 IELIM=2 KTIMES=0 LAST=1 KONE=1 ASSIGN 445 TO INCKTM ASSIGN 3876 TO KOFPR ASSIGN 451 TO JTIMES ASSIGN 2006 TO LTIMES FLPTN2=LASTNO FLPTN3=NCASE KTEST=NVAR*5 LL=1 KSTEP(1)=3 WRITE (6,4515) 2019 NCARDS=(MCOMB+5)/6 MCARDS=NCARDS IF(NCARDS)2018,2018,2021 2018 KTIMES=1 GO TO 2011 C 2020 IF(NCARDS)2001,2001,2021 2021 NCARDS=NCARDS-1 READ (5,1000)KCHECK,(KSTEP(I),NN1(I),NN2(I),NN3(I),I=1,6) IF(KCHECK.NE.KDUMY6(1)) GO TO 940 2029 ILL=1 2022 LL=ILL 20222 IF(KSTEP(LL))2030,2030,2122 2122 IF((KSTEP(LL)-KONE)-KTIMES)920,2023,2001 2023 DO 2025 I=1,NVAR IF(NN1(LL)-LVAR(I))2025,2024,2025 2025 CONTINUE GO TO 19 2024 M=LVAR(I) IF(MCOMB)2127,2127,2128 2127 LL=6 GO TO 2124 2128 MCOMB=MCOMB-1 N1(M)=NN2(LL) N2(M) =NN3(LL) CALL CHECK(M) NCOMB(M)=NCOMB(M)+1 CALL COMBIN(I,N1,N2(1)) IF(KOMPER)998,2124,998 2124 ITIMES=6 IF(LL-6)2125,2120,2120 2125 IF(KSTEP(LL+1)-1)2126,2026,2123 2120 IF(1-KSTEP(LL))2123,2126,2126 2123 CALL DECTER 2126 GO TO INCKTM,(445,450) C 2026 IF(M-NN1(LL+1))2030,2126,2030 C 19 N=NVAR+1 DO 20 I=N,25 IF(NN1(LL)-LVAR(I))20,25,20 20 CONTINUE GO TO 930 25 N=MCARDS-NCARDS WRITE (6,4019)NN1(LL),N MCOMB=MCOMB-1 GO TO 2124 C 2027 IF(KTIMES-1)2028,2028,2030 2028 KTIMES=0 2030 LL=LL+1 IF(LL.LE.6)GO TO 20222 GO TO 2020 C 2001 IF(MCOMB)2011,2011,2012 2011 ASSIGN 2031 TO KONTIN LL=1 KSTEP(1)=KTEST IF(IEND.EQ.IYES) GO TO 2014 2013 LAST=2 GO TO 2014 C 2012 ASSIGN 202 TO KONTIN 2014 ILL=LL GO TO LTIMES,(2006,2010,4655,4915,5207) C C COMBINE THOSE RESPONSES WHICH HAVE LESS THAN NPER PERCENT C OF THE TOTAL NUMBER OF RESPONDENTS, IF DESIRED. C 2006 CONTINUE 2135 ITIMES=5 KTIMES=1 ASSIGN 2010 TO LTIMES IF(NFIRST.NE.IYES) GO TO 2003 2002 CALL FRSTCM(NPER) IF(L-INDKOL)2003,2003,2005 2003 ITIMES=1 IF(KOMPER)998,2009,998 2009 IF((KSTEP(LL)-1)-KTIMES)920,2022,2010 C 2005 ASSIGN 449 TO JTIMES GO TO 450 C 2010 CONTINUE 7005 ITIMES=1 C C RANK RESPONDENTS USING CORNELL TECHNIQUE C 201 INDEX2=0 GO TO KONTIN,(202,2022,2031) 202 ASSIGN 2022 TO KONTIN 2031 K=INDRNK+1 DO 204 JRNK=K,INDKOL RANKSM(JRNK)=0.0 INDEX1=INDEX2+1 INDEX2=INDEX2+NVAR DO 203 I=INDEX1,INDEX2 RANKSM(JRNK)=RANKSM(JRNK)+A(I) 203 CONTINUE 204 CONTINUE C C ORDER ACCORDING TO HIGHEST RANK SCORE C 240 CALL ORDER C C ORDER QUESTIONS IN INCREASING FREQUENCY OF SCORE 7 C CALL ORQUES(0) C C REORDER THOSE INDIVIDUALS WITH THE SAME TOTAL SCORE C 275 CALL REORDR 7009 IF (KOMPER)998,3305,998 C 3305 GO TO (334,465,555),LAST C C DETERMINE CUTTING POINTS AND ERRORS FOR EACH QUESTION C 334 KK=1 336 CALL DECTER 380 IF(IFINAL.NE.IYES) GO TO 384 325 MINPR=1 MAXPR=0 INDEX2=0 NDIFF=NCASE 5010 IF(NDIFF-50)5020,5020,5030 5020 MAXPR=NCASE NDIFF=0 GO TO 5040 C 5030 MAXPR=MAXPR+50 NDIFF=NDIFF-50 5040 NUMPGE=NUMPGE+1 WRITE (6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE 326 WRITE (6,4002) WRITE (6,4008) 2662 WRITE (6,4504)NCASE,NVAR WRITE (6,4506)KTIMES WRITE (6,4505) DO 2663 I=1,NVAR M=LVAR(I) HOLD(I)=REF(M) 2663 CONTINUE WRITE (6,4508)(LVAR(J),HOLD(J),J=1,NVAR) 327 WRITE (6,4500) DO 267 I=MINPR,MAXPR INDEX1=INDEX2+1 INDEX2=INDEX2+NVAR JRNK=I+INDRNK INDIDV=I+LASTNO 2665 WRITE (6,4003)I,INDIVD(INDIDV),RANKSM(JRNK),(A(J),J=INDEX1,INDEX2) 267 CONTINUE GO TO (268,5050),IELIM 268 WRITE (6,4030) 5050 MINPR=MINPR+50 IF(NDIFF) 384, 384,5010 C C PRINT OUT ERRORS, IF DESIRED C 384 FLPTN1=MAXERR COFREP=1.0-(FLPTN1/FLPTN2) KSUM=0 DO 3874 M=1,NVAR I=LVAR(M) KEST=0 DO 3873 J=1,7 IF(KEST-MFREQ(I,J))3871,3873,3873 3871 KEST=MFREQ(I,J) 3873 CONTINUE KSUM=KSUM+KEST 3874 CONTINUE SUM=KSUM FMINMR=SUM/FLPTN2 IF(IERROR.NE.IYES) GO TO 390 385 NUMPGE=NUMPGE+1 386 WRITE (6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE WRITE (6,4004) WRITE (6,4504)NCASE,NVAR WRITE (6,4506)KTIMES WRITE (6,4500) WRITE (6,4505) DO 3861 I=1,NVAR M=LVAR(I) HOLD(I)=REF(M) 3861 CONTINUE WRITE (6,4509)(LVAR(J),HOLD(J),J=1,NVAR) ASSIGN 388 TO MTIMES 3862 WRITE (6,4500) DO 387 I=1,7 DO 3865 J=1,NVAR M=LVAR(J) KOLHLD(J)=KONTER(M,I) 3865 CONTINUE WRITE (6,4005)I,(KOLHLD(J),J=1,NVAR) 387 CONTINUE K=0 DO 3877 I=1,NVAR M=LVAR(I) KOLHLD(I)=0 DO 3875 J=1,7 KOLHLD(I)=KOLHLD(I)+KONTER(M,J) 3875 CONTINUE K=K+KOLHLD(I) 3877 CONTINUE J=FLPTN2 WRITE (6,4024)(KOLHLD(I),I=1,NVAR) WRITE (6,4025)K,J GO TO KOFPR,(3876,3878) 3878 WRITE (6,4501) WRITE (6,4018)COFREP WRITE (6,4021)FMINMR IF(COFREP-FKEEP)3872,3870,3870 3872 WRITE (6,4013) 3870 FKEEP=COFREP 3876 GO TO (3880,3879),IELIM 3880 WRITE (6,4030) 3879 GO TO MTIMES,(388,475) 388 WRITE (6,4502) WRITE (6,4006) WRITE (6,4500) I=0 DO 389 JJ=1,NVAR K=26 DO 3895 L=1,NVAR M=LVAR(L) IF(M-K)3891,3895,3895 3891 IF(I-M)3893,3895,3895 3893 K=M 3895 CONTINUE I=K WRITE (6,4007)I,REF(I),(MFREQ(I,J),J=1,8) 389 CONTINUE C C DETERMINE COMBINATIONS OF RESPONSES IN EACH QUESTION C 390 GO TO (395,520,462,495,612,580),ITIMES 395 KK=2 CALL FNDCMB(FLPTN2) IF(KOMPER)998,425,998 425 IF(L1)445,462,445 445 KTIMES=KTIMES+1 450 NUMPGE=NUMPGE+1 WRITE (6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE WRITE (6,4009) GO TO JTIMES,(449 ,451) 449 WRITE (6,4014)NPER ASSIGN 451 TO JTIMES 451 WRITE (6,4504)NCASE,NVAR WRITE (6,4506)KTIMES 452 WRITE (6,4510) J=0 DO 457 JJ=1,NVAR K=26 DO 4526 L=1,NVAR M=LVAR(L) IF(M-K)4522,4526,4526 4522 IF(J-M)4524,4526,4526 4524 K=M 4526 CONTINUE J=K IF(NCOMB(J))456,457,456 456 WRITE(6,4010) J,REF(J),NCOMB(J),N1(J),N2(J),KVAR(J),MVAR(J) 4569 N1(J)=0 N2(J)=0 457 CONTINUE GO TO(4573,4577),IELIM 4573 WRITE (6,4030) 4577 CONTINUE 458 GO TO (459,674,675,551,2002,2027),ITIMES 459 IF(KTIMES-KTEST)201,990,990 C C DETERMINE ERROR FOR FINAL COMPUTATIONS C 462 IF(LEAVE.NE.IYES) GO TO 465 463 LAST=2 465 KK=3 KTIMES=KTIMES+1 IF((-MCOMB))4653,4654,4654 4653 KONE=0 ASSIGN 4655 TO LTIMES ASSIGN 450 TO INCKTM GO TO 2022 C 4654 CALL DECTER 4655 NUMPGE=NUMPGE+1 WRITE (6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE WRITE (6,4012) WRITE (6,4504)NCASE,NVAR WRITE (6,4506)KTIMES WRITE (6,4505) DO 466 I=1,NVAR M=LVAR(I) HOLD(I)=REF(M) 466 CONTINUE WRITE (6,4509)(LVAR(J),HOLD(J),J=1,NVAR) ASSIGN 475 TO MTIMES GO TO 3862 C C CHECK TO SEE IF CHANGING RANK OF INDIVIDUALS REDUCES ERROR C 475 MAXERR=0 DO 480 I=1,NVAR MAXERR=MAXERR+KOLHLD(I) 480 CONTINUE 485 CALL ORQUES(1) CALL RKCHNG(MAXERR) KK=3 IF(KOMPER)998,490,998 490 KTIMES=KTIMES+1 IF((-MCOMB))491,492,492 491 ASSIGN 4915 TO LTIMES GO TO 2022 C 4915 MAXERR =0 DO 494 M=1,NVAR I=LVAR(M) DO 493 J=1,7 MAXERR=MAXERR+KONTER(I,J) 493 CONTINUE 494 CONTINUE 492 ITIMES=4 ASSIGN 3878 TO KOFPR GO TO 380 C C CHECK TO SEE IF FURTHER POSSIBLE COMBINATIONS MAY REDUCE THE ERROR C TO GIVE A GOOD COEFFICIENT OF REPRODUCIBILITY. C 495 GO TO (496, 580),LAST 496 FLPTN1=MAXERR REPERR=FLPTN1/FLPTN2 IF(0.1-REPERR)497,500,500 497 KING=1 GO TO 520 C 500 IF(NDREDK)499,499,498 499 KING=3 GO TO 520 C 498 IF(NDREDK-20)512,512,499 512 IF(LASTRD-1)499,510,499 510 KING=2 520 IF((-MCOMB))5205,525,525 5205 KONE=1 ASSIGN 445 TO INCKTM ASSIGN 5207 TO LTIMES GO TO 2022 C 5207 MAXERR =0 DO 5209 I=1,NVAR DO 5208 J=1,7 MAXERR=MAXERR+KONTER(I,J) 5208 CONTINUE 5209 CONTINUE 5206 IF((-MCOMB))521,525,525 521 CALL ENDCMB(NDREDK,KING,MAXERR,LASTRD) IF(KOMPER-50)522,5595,522 522 IF(KOMPER-25)998,550,998 550 KOMPER=0 ITIMES=4 GO TO 445 C 525 IF(IEND.EQ.IYES) GO TO 521 GO TO 614 C 551 LAST=3 ITIMES=2 GO TO 201 C 555 KK=3 CALL DECTER 556 MAXERR=0 DO 559 M=1,NVAR I=LVAR(M) DO 558 J=1,7 MAXERR=MAXERR+KONTER(I,J) 558 CONTINUE 559 CONTINUE CALL ORQUES(I) KK=3 CALL RKCHNG(MAXERR) KTIMES=KTIMES+1 ICHNGE=ICHNGE+1 IF(ICHNGE-20)5591,5591,5592 5591 IF(KOMPER)998,380,998 C 5592 ICHNGE=20 GO TO 5591 C 5595 KOMPER=0 IF(ICHNGE-5)5599,5599,5597 5599 ICHNGE=10 5596 ITIMES=6 GO TO 555 C 5597 ICHNGE=20 GO TO 5596 C 560 KOMPER=0 K=INDTEM+25 DO 565 I=1,NVAR J=K+I IF(KOLSKR(J))565,565,567 565 CONTINUE GO TO 575 C 567 FLPTN1=MAXERR COFREP=1.0-(FLPTN1/FLPTN2) NUMPGE=NUMPGE+1 KTIMES=KTIMES+1 WRITE (6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE WRITE (6,4016) WRITE (6,4504)NCASE,NVAR WRITE (6,4506)KTIMES WRITE (6,4018)COFREP WRITE (6,4021)FMINMR WRITE (6,4511) DO 570 I=1,NVAR M=LVAR(I) INDEX1=K+I IF(KOLSKR(INDEX1))570,570,563 563 N=KOLSKR(INDEX1) N2(M)=KOLSKR(INDEX1-25)/8 N1(M)=KOLSKR(INDEX1-25)-(N2(M)*8) WRITE (6,4017)M,REF(M),N1(M),N2(M),N,RANKSM(INDEX1+25) 570 CONTINUE 575 GO TO(600,576,600,700),LAST 576 LAST=4 CALL ORQUES(LAST) KK=3 CALL RKCHNG(MAXERR) ITIMES=6 KTIMES=KTIMES+1 GO TO 380 C 580 KK=4 CALL FNDCMB(FLPTN2) 581 IF(KOMPER)998,560,998 C C ELIMINATE SOME QUESTIONS,IF DESIRED. C 600 IF(LESTN)700,610,610 610 LESTN=NVAR-LESTN ASSIGN 685 TO KIND IF(LESTN)910,614,615 612 IF(LESTN)910,614,615 614 LAST=2 GO TO 580 C 615 DO 620 M=1,NVAR I=LVAR(M) IF(MVAR(I)-2)620,620,625 620 CONTINUE GO TO 650 C 625 KK=4 CALL FNDCMB(FLPTN2) 6255 IF(KOMPER)998,626,998 626 KTEST=0 K=0 INDEX2=INDTEM+25 DO 635 I=1,NVAR M=LVAR(I) INDEX1=INDEX2+I IF(KOLSKR(INDEX1))627,628,630 627 KOLSKR(INDEX1)=0 628 IF(MVAR(M)-2)629,629,630 629 IF(MFREQ(M,1))630,630,6295 6295 KOLSKR(INDEX1)=KONTER(M,7)+KONTER(M,1) 630 IF(KTEST-KOLSKR(INDEX1))631,635,635 631 KTEST=KOLSKR(INDEX1) K=I 635 CONTINUE IF((-K))6355,680,680 6355 L=LVAR(K) IF(MVAR(L)-2)661,661,636 636 INDEX1=INDTEM+K N2(L)=KOLSKR(INDEX1)/8 N1(L)=KOLSKR(INDEX1)-(N2(L)*8) NCOMB(L)=NCOMB(L)+1 CALL COMBIN(K,N1,N2(1)) IF(KOMPER)998,637,998 637 ITIMES=3 GO TO 445 C 650 KK=3 CALL DECTER 651 KTEST=0 L=0 DO 660 I=1,NVAR KOLHLD(I)=0 M=LVAR(I) KOLHLD(I)=KOLHLD(I)+KONTER(M,7)+KONTER(M,1) IF(KTEST-KOLHLD(I))656,660,660 656 KTEST=KOLHLD(I) K=I L=M 660 CONTINUE IF((-L))661,690,690 661 MFREQ(L,7)=0 MFREQ(L,1)=0 MFREQ(L,8)=0 NCOMB(L)=NCOMB(L)+1 N1(L)=1 N2(L)=7 MVAR(L)=1 REF(L)=QCTR IELIM=1 ITIMES=2 665 INDEX1=LASTNO-NVAR+K DO 670 I=K,INDEX1,NVAR A(I)=0.0 670 CONTINUE I=L GO TO 445 C 674 MVAR(I)=2 FLPTN2=FLPTN2-FLPTN3 LESTN=LESTN-1 675 ITIMES=5 LAST=3 16755 CONTINUE GO TO 201 C 680 GO TO KIND,(685,690) 685 ASSIGN 690 TO KIND NDREDK=0 GO TO 615 C 690 WRITE (6,4031) GO TO 614 C 700 WRITE(IT4) MAXERR,COFREP,FMINMR WRITE(IT4) (REF(I),I=1,25) DO 9003 K=1,4 NK=(K-1)*128+1 NKK=K*128 9003 WRITE(IT4)(LVAR(KKK),KKK=NK,NKK) WRITE(IT4)(LVAR(KKK),KKK=513,558),INDEX3 WRITE(IT4) JOBNMB,(DUMMY2(I),I=1,27),FRSTMO,SECMON,(KDUMY6(J) 1,J=1,2) MAXPR=0 DO 725 I=1,NCASE MINPR=MAXPR+1 MAXPR=MAXPR+NVAR NPOINT=(MAXPR-MINPR+128)/128 NWED=MINPR-1 IF (NPOINT.LE.1) GO TO 7726 DO 7727 J=1,NPOINT-1 NJ=(J-1)*128+NWED+1 NJJ=J*128+NWED 7727 WRITE(IT4)(A(JJJ),JJJ=NJ,NJJ) 7726 NJ=(NPOINT-1)*128+NWED+1 WRITE(IT4)(A(JJJ),JJJ=NJ,MAXPR) 725 CONTINUE DO 750 I=1,4 MINPR=MAXPR+1 MAXPR=MAXPR+NCASE NPOINT=(MAXPR-MINPR+128)/128 NWED=MINPR-1 IF (NPOINT.LE.1) GO TO 7732 DO 7731 J=1,NPOINT-1 NJ=(J-1)*128+NWED+1 NJJ=J*128+NWED 7731 WRITE(IT4)(A(JJJ),JJJ=NJ, NJJ) 7732 NJ=(NPOINT-1)*128+NWED+1 WRITE(IT4)(A(JJJ),JJJ=NJ,MAXPR) 750 CONTINUE END FILE IT4 REWIND IT4 998 STOP C 910 WRITE (6,4910) GO TO 998 C 920 KTIMES=KTIMES+1 WRITE (6,4029)KSTEP(LL),KTIMES GO TO 998 C 930 NCARDS=MCARDS-NCARDS WRITE (6,4028)NN1(LL),NCARDS GO TO 998 C 940 WRITE (6,4940) GO TO 998 C 990 NUMPGE=NUMPGE+1 WRITE (6,4011)NUMPGE ITIMES=3 GO TO 201 C C 8000 FORMAT(20A4) 1000 FORMAT(A6,6(I4,3I2)) C 4002 FORMAT(1H ,41X,28HRESPONDENTS AND SCALE SCORES/37X,37HRANKED ACCOR 1DING TO CORNELL TECHNIQUE) 4003 FORMAT(1H ,I4,I5,2F5.0,24F4.0) 4004 FORMAT(1H ,40X,30HERRORS AND NUMBER OF RESPONSES/42X,27HTO THE VAR 1IOUS SCALE SCORES) 4005 FORMAT(1H ,5X,I3,6X,25I4) 4006 FORMAT(1H0,3X,8HVARIABLE,19X,55HFREQUENCY OF OCCURRENCE OF SCORES 11 TO 7 AND SCORE ZERO/7X,2HOR,44X,5HSCORE/4X,8HQUESTION,13X,1H1,9X 2,1H2,9X,1H3,9X,1H4,9X,1H5,9X,1H6,9X,1H7,4X,11HNO RESPONSE) 4007 FORMAT(1H ,5X,I3,A1,6X,8I10) 4008 FORMAT(1H ,26X,57HWITH QUESTIONS ORDERED IN INCREASING FREQUENCY O 1F SCORE 7) 4009 FORMAT(1H ,45X,25HCOMBINATIONS IN QUESTIONS) 4010 FORMAT(1H0,I10,A1,I16,I17,5H AND,I3,I14,I8) 4011 FORMAT(1H1,105X,4HPAGE,I4//117HAFTER COMBINING AS MANY OF THE RESP 1PONSES IN EACH QUESTION AS POSSIBLE, SOME QUESTIONS STILL HAVE RAT 2IOS OF ERRORS TO/39HNON-ERRORS WHICH ARE GREATER THAN 0.50./6X,112 3HIT SEEMS UNLIKELY THAT THE RESULTING SCALE WHICH THE PROGRAM WILL 4 NOW COMPUTE IS GOOD. PLEASE CHECK THE PREVIOUS/114HPAGES OF OUTPU 5T AND EITHER ELIMINATE SOME QUESTIONS AND/OR RESPONDENTS OR DETERM 6INE THOSE RESPONSES WHICH YOU FEEL/74HSHOULD BE COMBINED AND USE T 7HE FORCED COMBINATION FEATURE OF THIS PROGRAM.) 4012 FORMAT(1H ,42X,27HERRORS FOR EACH SCALE SCORE/50X,11HFINAL STEPS) 4013 FORMAT(1H0,16X,84HTHE COEFFICIENT OF REPRODUCIBILITY DECREASED IN 1THIS LAST STEP. IT IS SUGGESTED THAT//15X,86HYOU MAKE A DIFFERENT 2COMBINATION USING THE FORCED COMBINATION FEATURE OF THIS PROGRAM.) 4014 FORMAT(32X29HTHE FIRST SCORE HAS LESS THANI3,23H PERCENT OF RESPON 1DENTS) 4016 FORMAT(1H ,34X,41HPOSSIBLE COMBINATIONS WHICH WILL INCREASE/25X,61 1HTHE COEFFICIENT OF REPRODUCIBILITY AND THE AMOUNT OF INCREASE) 4017 FORMAT(1H016XI3,A1,16XI3,5H AND,I3,19X,I4,20X,F5.4) 4018 FORMAT(1H ,36X,33HCOEFFICIENT OF REPRODUCIBILITY = ,F7.5) 4019 FORMAT(1H0,12X,8HQUESTIONI3,61H NO LONGER INCLUDED IN STUDY. FORCE 1D COMBINATION READ ON CARDI3,17H WILL BE IGNORED.) 4021 FORMAT(1H0,34X,35HMINIMAL MARGINAL REPRODUCIBILITY = ,F7.5) 4024 FORMAT(1H0,14HQUESTION ERROR,25I4) 4025 FORMAT(1H0,36X,11HTOTAL ERROR I6,5X,15HTOTAL RESPONSES I6) 4028 FORMAT(1H0,24X,37HTHERE IS NO QUESTION CORRESPONDING TO,I4,26H WHI 1CH WAS READ IN ON CARD,I4) 4029 FORMAT(1H0,18X,31HTHE COMBINATION DESIRED AT STEP,I4,20H WAS READ 1IN AT STEP,I4,21H TOO LATE TO BE DONE.) 4030 FORMAT(1H0,45H* INDICATES THIS QUESTION HAS BEEN ELIMINATED) 4031 FORMAT(1H0,6X,103HNO MORE COMBINATIONS OR ELIMINATIONS WILL REDUCE 1 THE ERROR. HENCE, NO MORE QUESTIONS WILL BE ELIMINATED) 4500 FORMAT(1H ) 4501 FORMAT(1H0) 4502 FORMAT(1H0//) 4503 FORMAT(1H1,15H PROBLEM NUMBER,2X,A6,57X,2A6,I3,1H,,I5,3X,4HPAGE, 1I4) 4504 FORMAT(1H ,18X,23HNUMBER OF RESPONDENTS =,I5,22X,21HNUMBER OF VARI 1ABLES =,I3) 4505 FORMAT(1H ,44X,22HVARIABLES OR QUESTIONS) 4506 FORMAT(1H ,54X,4HSTEP,I4) 4508 FORMAT(1H ,15HRANK RESP SCOR ,25(I3,A1)) 4509 FORMAT(1H ,3X,8HSCORE OF,4X,25(I3,A1)) 4510 FORMAT(1H0,5X,8HQUESTION,6X,15HTOTAL NUMBER OF,6X,15HSCORES COMBIN 1ED,6X,15HNUMBER OF PARTS/18X,19HCOMBINATIONS SO FAR,7X,9HTHIS TIME 2,9X,15HORIGINAL NOW) 4511 FORMAT(1H0,64X,8HDECREASE,15X,11HAPPROXIMATE/15X,8HQUESTION,15X,11 1HCOMBINATION,15X, 10HIN NUMBER,14X,11HINCREASE IN/64X,10HOF ERRO 2RS,12X,15HREPRODUCIBILITY) 4910 FORMAT(1H0,21X,70HTHE MINIMUM QUESTIONS DESIRED IS GREATER THAN TH 1E NUMBER OF QUESTIONS./26X,62HNO QUESTIONS WILL BE ELIMINATED BUT 2SAVE TAPE WILL BE WRITTEN.) 4940 FORMAT(1H1,32X,52HCONTROL CARDS OUT OF ORDER. PROGRAM CANNOT CONTI 1NUE.) C END CCHECK SUBROUTINE CHECK FOR BMD07S DECEMBER 13, 1963 SUBROUTINE CHECK(M) C DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2 37),KONTER(25,7),DUMMY3(8) COMMON JOBNMB COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN 2DTEM,IDAY,IYEAR,NUMPGE,JOYCEA,MAXLOC,N1,N2,DUMMY3,KK,ICHNGE C DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD) 1,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR 2),(ERROR,KONTER) C 25000 THETA=0.0 MTIMES=MVAR(M) C N=N1(M) NN=N2(M) IF(N)920,920,1 1 IF(NN)920,920,2 2 IF(N-7)3,3,920 3 IF(NN-7)4,4,920 4 IF(MTIMES)900,900,5 5 IF(MTIMES-7)10,10,900 10 GO TO (900,920,30,40,50,60,70),MTIMES C 30 GO TO (31,920,920,34,920,920,37),N C 31 GO TO (920,920,920,800,920,920,920),NN C 34 GO TO (800,920,920,920,920,920,800),NN C 37 GO TO (920,920,920,800,920,920,920),NN C 40 GO TO (41,920,43,920,45,920,47),N C 41 GO TO (920,920,800,920,920,920,920),NN C 43 GO TO (800,920,920,920,800,920,920),NN C 45 GO TO (920,920,800,920,920,920,800),NN C 47 GO TO (920,920,920,920,800,920,920),NN C 50 GO TO (51,52,920,54,920,56,57),N C 51 GO TO (920,800,920,920,920,920,920),NN C 52 GO TO (800,920,920,800,920,920,920),NN C 54 GO TO (920,800,920,920,920,800,920),NN C 56 GO TO (920,920,920,800,920,920,800),NN C 57 GO TO (920,920,920,920,920,800,920),NN C 60 GO TO (51,62,63,920,65,66,57),N C 62 GO TO (800,920,800,920,920,920,920),NN C 63 GO TO (920,800,920,920,800,920,920),NN C 65 GO TO (920,920,800,920,920,800,920),NN C 66 GO TO (920,920,920,920,800,920,800),NN C 70 GO TO (51,62,73,74,75,66,57),N C 73 GO TO (920,800,920,800,920,920,920),NN C 74 GO TO (920,920,800,920,800,920,920),NN C 75 GO TO (920,920,920,800,920,800,920),NN C 800 RETURN C 900 WRITE (6,4000)M,MTIMES KOMPER=1 GO TO 800 C 920 WRITE (6,4020)M,MTIMES,N1(M),N2(M) KOMPER=1 GO TO 800 C 4000 FORMAT(1H0,12X,31HTHE NUMBER OF PARTS TO QUESTION,I3,3H IS,I3,51H 1A VALUE NOT PERMITTED. THIS OCCURRED IN SUB CHECK.) C 4020 FORMAT(1H0,6X,8HQUESTION,I3,4H HAS,I3,14H PARTS. SCORES,I3,4H AND, 1I3,63H WERE TO BE COMBINED BUT ONE OR BOTH OF THEM IS(ARE) INCORRE 2CT.) C END CCOMBIN SUBROUTINE COMBIN FOR BMD04S, 05S AND 07S JUNE 3, 1963 SUBROUTINE COMBIN(I,N1,N2) C DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25) DIMENSION DUMMY2(27) COMMON JOBNMB COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD) EQUIVALENCE(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR) 25000 THETA=0.0 M=LVAR(I) C INDEX1=I+LASTNO-NVAR FLPTN1=N1(M) FLPTN2=N2(M) DO 25 J=I,INDEX1,NVAR IF(A(J)-FLPTN1)25,10,25 10 A(J)=FLPTN2 25 CONTINUE L1=N1(M) L2=N2(M) MFREQ(M,L2)=MFREQ(M,L2)+MFREQ(M,L1) MFREQ(M,L1)=0 IF(MVAR(M)-6)27,60,70 27 IF(MVAR(M)-4)28,40,50 28 IF(MVAR(M)-2)900,900,30 30 IF(MFREQ(M,1))910,31,32 31 MFREQ(M,1)=MFREQ(M,4) SCORE2=1.0 310 SCORE1=4.0 MFREQ(M,4)=0 LTIMES=1 GO TO 500 32 IF(MFREQ(M,4))910,600,33 33 MFREQ(M,7)=MFREQ(M,4) SCORE2=7.0 GO TO 310 40 IF(MFREQ(M,1))910,41,43 41 LTIMES=2 SCORE1=3.0 MFREQ(M,1)=MFREQ(M,3) MFREQ(M,3)=0 410 SCORE2=1.0 GO TO 500 42 SCORE1=5.0 MFREQ(M,4)=MFREQ(M,5) MFREQ(M,5)=0 425 LTIMES=1 SCORE2=4.0 GO TO 500 43 IF(MFREQ(M,3))910,42,44 44 IF(MFREQ(M,5))910,45,46 45 SCORE1=3.0 MFREQ(M,4)=MFREQ(M,3) MFREQ(M,3)=0 GO TO 425 46 LTIMES=3 SCORE1=5.0 MFREQ(M,7)=MFREQ(M,5) MFREQ(M,5)=0 465 SCORE2=7.0 GO TO 500 50 IF(MFREQ(M,1))910,51,54 51 LTIMES=4 515 SCORE1=2.0 MFREQ(M,1)=MFREQ(M,2) MFREQ(M,2)=0 GO TO 410 52 LTIMES=5 521 SCORE1=4.0 MFREQ(M,3)=MFREQ(M,4) MFREQ(M,4)=0 525 SCORE2=3.0 GO TO 500 53 LTIMES=1 SCORE1=6.0 MFREQ(M,5)=MFREQ(M,6) MFREQ(M,6)=0 535 SCORE2=5.0 GO TO 500 54 IF(MFREQ(M,2))910,52,55 55 IF(MFREQ(M,4))910,56,57 56 LTIMES=5 565 SCORE1=2.0 MFREQ(M,3)=MFREQ(M,2) MFREQ(M,2)=0 GO TO 525 57 IF(MFREQ(M,6))910,58,590 58 LTIMES=6 581 SCORE1=4.0 MFREQ(M,5)=MFREQ(M,4) MFREQ(M,4)=0 GO TO 535 59 LTIMES=1 GO TO 565 590 LTIMES=7 591 SCORE1=6.0 MFREQ(M,7)=MFREQ(M,6) MFREQ(M,6)=0 GO TO 465 60 IF(MFREQ(M,1))910,61,63 61 LTIMES=8 GO TO 515 62 LTIMES=2 621 SCORE1=3.0 SCORE2=2.0 MFREQ(M,2)=MFREQ(M,3) MFREQ(M,3)=0 GO TO 500 63 IF(MFREQ(M,2))910,62,64 64 IF(MFREQ(M,3))910,42,65 65 IF(MFREQ(M,5))910,45,66 66 IF(MFREQ(M,6))910,67,68 67 LTIMES=3 671 SCORE1=5.0 SCORE2=6.0 MFREQ(M,6)=MFREQ(M,5) MFREQ(M,5)=0 GO TO 500 68 LTIMES=9 GO TO 591 70 IF(MFREQ(M,1))910,71,74 71 LTIMES=10 GO TO 515 72 LTIMES=11 GO TO 621 73 LTIMES=1 GO TO 521 74 IF(MFREQ(M,2))910,72,75 75 IF(MFREQ(M,3))910,73,76 76 IF(MFREQ(M,4))910,600,77 77 IF(MFREQ(M,5))910,78,79 78 LTIMES=1 GO TO 581 79 IF(MFREQ(M,6))910,80,81 80 LTIMES=12 GO TO 671 81 LTIMES=13 GO TO 591 500 DO 510 JJ=I,INDEX1,NVAR IF(A(JJ)-SCORE1)510,505,510 505 A(JJ)=SCORE2 510 CONTINUE GO TO (600,42,45,52,53,59,58,62,67,72,73,78,80),LTIMES 600 MVAR(M)=MVAR(M)-1 610 RETURN 900 L=2 WRITE (6,4000)I,N1(M),N2(M),M,L KOMPER=1 GO TO 610 910 WRITE (6,4010)I,N1(M),N2(M),M KOMPER=1 GO TO 610 4000 FORMAT(1H ,20X,54HMACHINE ERROR. UPON ENTRY TO SUBROUTINE COMBIN W 1ITH I=,I3,7H N1(M)=,I3,7H N2(M)=,I3/10X,9H QUESTION,I3,9H HAS ONLY 2,I2,77H PARTS, WHEREAS IT MUST HAVE AT LEAST 3 PARTS IN ORDER TO H 3AVE A COMBINATION.) 4010 FORMAT(1H ,20X,54HMACHINE ERROR. UPON ENTRY TO SUBROUTINE COMBIN W 1ITH I=,I3,7H N1(M)=,I3,7H N2(M)=,I3/22X,48H ONE OF THE FREQUENCIES 2 OF RESPONSES TO QUESTION,I3,14H WAS NEGATIVE.) END CENDCMB SUBROUTINE ENDCMB FOR BMD07S JUNE 3, 1963 C SUBROUTINE ENDCMB(NDREDK,K,MAXERR,LASTRD) C DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2 37),KONTER(25,7),DUMMY3(7) COMMON JOBNMB COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN 2DTEM,IDAY,IYEAR,NUMPGE,JOYCAE,MAXLOC,N1,N2,I,DUMMY3,KK DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK C EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD) 1,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR 2),(ERROR,KONTER) C MINRED=((LASTNO+199)/200)*NDREDK C FLPTN1=MAXERR FLPTN2=LASTNO REPERR=FLPTN1/FLPTN2 KK=4 10 CALL FNDCMB(FLPTN2) IF(KOMPER)500,100,500 100 GO TO (150,155,490),K 150 IF(REPERR-0.1)151,151,155 151 K=2 155 INDEX1=INDTEM+1 INDEX2=INDTEM+NVAR M=0 J=0 DO 170 L=INDEX1,INDEX2 N=KOLSKR(L+25) IF(N)900,157,1565 1565 GO TO (159,156,490),K 156 IF(N-MINRED)157,159,159 157 KOLSKR(L)=0 KOLSKR(L+25)=0 N=0 159 IF(M-N)160,170,170 160 M=N J=L 170 CONTINUE IF(J)180,180,250 180 K=3 GO TO 10 250 N=M L=J-INDTEM M=LVAR(L) N2(M)=KOLSKR(J)/8 N1(M)=KOLSKR(J)-(N2(M)*8) NCOMB(M)=NCOMB(M)+1 CALL COMBIN(L,N1,N2(1)) IF(KOMPER)500,300,500 300 I=L CALL DECTER MAXERR=MAXERR-N 480 KOMPER=25 GO TO 500 490 KOMPER=50 500 RETURN 900 KOMPER=1 WRITE (6,4900) GO TO 500 4900 FORMAT(1H0,9X,91H* MACHINE ERROR * THE REDUCTION IN ERROR DUE TO A 1 POSSIBLE COMBINATION IN SUBROUTINE ENDCMB/18X,74HIS NEGATIVE. THI 2S IS NOT POSSIBLE IN THIS PROGRAM. PROGRAM CANNOT PROCEED.) END CFNDCMB SUBROUTINE FNDCMB FOR BMD04S, 05S AND 07S JUNE 3, 1963 C SUBROUTINE FNDCMB(FLPTN2) C DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2 37),KONTER(25,7),DUMMY3(7),DUMMY4(2) COMMON JOBNMB COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN 2DTEM,IDAY,IYEAR,NUMPGE,JOYCAE,MAXLOC,N1,N2,I,DUMMY3,KK,DUMMY4,L1 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK C EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD) 1,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR 2),(ERROR,KONTER) C 25000 THETA=0.0 11 DO 300 II=1,NVAR C INDEX2=INDTEM+II INDEXK=LASTNO+II-NVAR M=LVAR(II) MTIMES=MVAR(M) IF(MTIMES-2)200,200,12 12 GO TO (915,1250,915,14),KK 1250 IF(MTIMES-3)200,200,14 14 ITIMES=1 KOLHLD(24)=0 DO 15 J=1,7 KOLHLD(J)=KONTER(M,J) KOLHLD(24)=KOLHLD(24)+KONTER(M,J) KOLHLD(J+7)=MFREQ(M,J) 15 CONTINUE K=INDKOL DO 30 INDEX=II,INDEXK,NVAR K=K+1 HOLDA(K)=A(INDEX) 30 CONTINUE GO TO (915,31,915,32),KK 31 GO TO (295,295,295,60,90,125,155),MTIMES 32 GO TO (295,295,355,61,91,91,91),MTIMES 355 N1(M)=7 36 N2(M)=4 37 CALL COMBIN(II,N1,N2(1)) IF(KOMPER)360,38,360 38 I=II CALL DECTER MVAR(M)=MVAR(M)+1 KOLHLD(25)=0 DO 40 J=1,7 KOLHLD(25)=KOLHLD(25)+KONTER(M,J) GO TO (915,387,915,384),KK 384 IF(MFREQ(M,J))387,387,385 385 IF(MFREQ(M,J)-(KONTER(M,J)+KONTER(M,J)))386,387,387 386 KOLHLD(25)=KOLHLD(24) 387 MFREQ(M,J)=KOLHLD(J+7) 40 CONTINUE 42 K=INDKOL DO 45 INDEX=II,INDEXK,NVAR K=K+1 A(INDEX)=HOLDA(K) 45 CONTINUE GO TO (295,295,405,69,98,131,162),MTIMES 405 GO TO (41,47),ITIMES 41 N1(M)=1 455 ITIMES=2 N=KOLHLD(25) GO TO (295,295,36,62,92,92,92),MTIMES 47 IF(KOLHLD(25))900,475,475 475 IF(N)900,477,477 477 IF(KOLHLD(25)-N)48,55,58 48 N=KOLHLD(24)-KOLHLD(25) L=1 482 K=4 485 GO TO (915,486,915,1000),KK 486 IF(N)295,295,49 49 IF(KOLHLD(24)-10)51,51,50 50 IF(N-((KOLHLD(24)+9)/10))295,51,51 51 KOLSKR(INDEX2)=(K*8)+L KOLSKR(INDEX2+25)=N GO TO 296 55 GO TO (915,295,915,58),KK 58 N=KOLHLD(24)-N L=7 GO TO 482 60 L=0 IF(MFREQ(M,7)-(2*KOLHLD(7)))61,63,63 61 N1(M)=7 62 N2(M)=5 GO TO 37 63 IF(MFREQ(M,5)-(2*KOLHLD(5)))61,65,65 65 IF(MFREQ(M,3)-(2*KOLHLD(3)))61,67,67 67 IF(MFREQ(M,1)-(KOLHLD(1)+KOLHLD(1)))85,295,295 69 GO TO (695,70,80),ITIMES 695 N1(M)=3 GO TO 455 70 IF(KOLHLD(25))900,71,71 71 IF(N)900,72,72 72 IF(KOLHLD(25)-N)73,73,745 73 L=2 N=KOLHLD(25) 74 ITIMES=3 N1(M)=1 742 N2(M)=3 GO TO 37 745 L=1 GO TO 74 80 IF(KOLHLD(25))900,81,81 81 IF(KOLHLD(25)-N)82,87,83 82 N=KOLHLD(24)-KOLHLD(25) K=3 825 L=1 GO TO 485 83 N=KOLHLD(24)-N IF(L-2)84,845,84 84 L=7 842 K=5 GO TO 485 845 L=3 GO TO 842 85 N=KOLHLD(24) GO TO 74 87 GO TO (915,295,915,83),KK 90 N=1 GO TO 126 91 N1(M)=7 92 N2(M)=6 GO TO 37 96 IF(MFREQ(M,1)-(KOLHLD(1)+KOLHLD(1)))120,295,295 98 GO TO (99,100,106,111),ITIMES 99 N1(M)=4 GO TO 455 100 IF(KOLHLD(25))900,101,101 101 IF(N)900,102,102 102 IF(KOLHLD(25)-N)103,105,105 103 L=2 N=KOLHLD(25) 104 ITIMES=3 N1(M)=4 1045 N2(M)=2 GO TO 37 105 L=1 GO TO 104 106 IF(KOLHLD(25))900,107,107 107 IF(KOLHLD(25)-N)108,110,109 108 L=3 N=KOLHLD(25) 109 ITIMES=4 1090 N1(M)=1 GO TO 1045 110 IF(L-2)108,109,108 111 IF(KOLHLD(25))900,112,112 112 IF(KOLHLD(25)-N)113,114,114 113 N=KOLHLD(24)-KOLHLD(25) K=2 GO TO 825 114 IF(L-2)115,118,119 115 K=7 116 L=6 117 N=KOLHLD(24)-N GO TO 485 118 K=4 GO TO 116 119 L=2 K=4 GO TO 117 120 N=KOLHLD(24) GO TO 109 125 N=2 126 L=0 DO 128 JJ=2,7 IF((KOLHLD(JJ)+KOLHLD(JJ))-MFREQ(M,JJ))128,128,91 128 CONTINUE 129 GO TO (96,130,161),N 130 IF(MFREQ(M,1)-(KOLHLD(1)+KOLHLD(1)))121,295,295 121 N=KOLHLD(24) GO TO 146 131 GO TO(132,133,139,143,148),ITIMES 132 N1(M)=5 GO TO 455 133 IF(KOLHLD(25))900,134,134 134 IF(N)900,135,135 135 IF(KOLHLD(25)-N)136,138,138 136 L=2 N=KOLHLD(25) 137 ITIMES=3 N1(M)=5 GO TO 742 138 L=1 GO TO 137 139 IF(KOLHLD(25))900,140,140 140 IF(KOLHLD(25)-N)141,141,142 141 L=3 N=KOLHLD(25) 142 ITIMES=4 N1(M)=2 GO TO 742 143 IF(KOLHLD(25))900,144,144 144 IF(KOLHLD(25)-N)145,147,146 145 L=4 N=KOLHLD(25) 146 ITIMES=5 GO TO 1090 147 IF(L-2)146,145,146 148 IF(KOLHLD(25))900,149,149 149 IF(KOLHLD(25)-N)113,150,150 150 IF(L-4)151,154,154 151 IF(L-2)115,152,153 152 K=5 GO TO 116 153 K=5 GO TO 1545 154 K=2 1545 L=3 GO TO 117 155 N=3 GO TO 126 161 IF(MFREQ(M,1)-(KOLHLD(1)+KOLHLD(1)))189,295,295 162 GO TO(132,163,169,173,178,183),ITIMES 163 IF(KOLHLD(25))900,164,164 164 IF(N)900,165,165 165 IF(KOLHLD(25)-N)166,168,168 166 L=2 N=KOLHLD(25) 167 ITIMES=3 N1(M)=5 1675 N2(M)=4 GO TO 37 168 L=1 GO TO 167 169 IF(KOLHLD(25))900,170,170 170 IF(KOLHLD(25)-N)171,171,172 171 L=3 N=KOLHLD(25) 172 ITIMES=4 N1(M)=3 GO TO 1675 173 IF(KOLHLD(25))900,174,174 174 IF(KOLHLD(25)-N)175,177,176 175 L=4 N=KOLHLD(25) 176 ITIMES=5 N1(M)=3 GO TO 1045 177 IF(L-2)175,175,176 178 IF(KOLHLD(25))900,179,179 179 IF(KOLHLD(25)-N)180,182,181 180 L=5 N=KOLHLD(25) 181 ITIMES=6 GO TO 1090 182 IF(L-2)180,181,181 183 IF(KOLHLD(25))900,184,184 184 IF(KOLHLD(25)-N)113,185,185 185 IF(L-4)186,188,154 186 IF(L-2)115,152,187 187 L=4 K=5 GO TO 117 188 K=4 GO TO 1545 189 N=KOLHLD(24) GO TO 181 1000 IF(N)295,295,1010 1010 SCORE1=N KOLSKR(INDEX2)=L+(K*8) KOLSKR(INDEX2+25)=N RANKSM(INDEX2+50)=SCORE1/FLPTN2 GO TO 296 200 KOLSKR(INDEX2)=0 KOLSKR(INDEX2+25)=0 GO TO 300 295 KOLSKR(INDEX2)=0 KOLSKR(INDEX2+25)=0 296 DO 297 J=1,7 KONTER(M,J)=KOLHLD(J) 297 CONTINUE N1(M)=0 N2(M)=0 300 CONTINUE GO TO (915,301,915,360),KK 301 L1=0 DO 350 II=1,NVAR INDEX2=INDTEM+II+25 IF(KOLSKR(INDEX2))910,350,310 310 IF(L1-KOLSKR(INDEX2))315,350,350 315 L1=KOLSKR(INDEX2) J=II 350 CONTINUE IF(L1)357,360,357 357 INDEX2=INDTEM+J M=LVAR(J) L2=KOLSKR(INDEX2) N1(M)=L2/8 N2(M)=L2-(8*N1(M)) NCOMB(M)=NCOMB(M)+1 CALL COMBIN(J,N1,N2(1)) I=J KK=2 CALL DECTER 360 RETURN 900 KOMPER=1 WRITE (6,4900) GO TO 360 910 KOMPER=1 I=INDEX2-INDTEM M=LVAR(I) WRITE (6,4910)M GO TO 360 915 KOMPER=1 WRITE (6,4915) GO TO 360 4900 FORMAT(1H0,25X,56H* MACHINE ERROR * TOTAL ERROR IN SUB FNDCMB IS N 1EGATIVE.) 4910 FORMAT(1H0,18X,59H* MACHINE ERROR* THE ERROR DUE TO A COMBINATION 1IN QUESTION,I3,13H RESULTS IN A/41X,29HNEGATIVE ERROR IN SUB FNDCM 2B.) 4915 FORMAT(1H0,12X,86H* MACHINE ERROR * SUBROUTINE FNDCMB WAS ENTERED 1WITH AN INCORRECT VALUE OF A CONSTANT.) END CFRSTCM SUBROUTINE FRSTCM FOR BMD07S OCTOBER 1, 1964 SUBROUTINE FRSTCM(NPER) C DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(5),DUMMYX(3) DIMENSION DUMMY2(27) COMMON JOBNMB COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN 2DTEM,DUMMY1,N1,N2,DUMMYX,L DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK C EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD) EQUIVALENCE(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR) C MINPR=(NPER*NCASE+99)/100 C 10 L=INDKOL DO 100 I=1,NVAR M=LVAR(I) IF(MVAR(M)-2)100,100,12 12 DO 75 J=1,7 IF(MFREQ(M,J))75,75,15 15 IF(MFREQ(M,J)-MINPR)25,75,75 25 L=L+1 KOLSKR(L)=M+(64*J) 75 CONTINUE 100 CONTINUE 125 IF(L-INDKOL)150,150,175 150 RETURN C 160 L=LL GO TO 150 C 175 K=INDKOL MM=0 LL=L 176 K=K+1 IF(K-LL)177,177,160 177 J=KOLSKR(K)/64 I=KOLSKR(K)-(64*J) IF(I-MM)178,160,178 178 MM=I DO 179 I=1,NVAR IF(LVAR(I)-MM)179,1795,179 179 CONTINUE 1795 MTIMES=MVAR(I)-2 GO TO (180,195,205,215,230),MTIMES 180 IF(J-4)185,190,191 185 N2(MM)=1 186 N1(MM)=4 187 NCOMB(MM)=NCOMB(MM)+1 CALL COMBIN(I,N1,N2(1)) GO TO 176 C 190 IF(MFREQ(MM,7)-MFREQ(MM,1))191,191,185 191 N2(MM)=7 GO TO 186 C 195 IF(J-5)196,199,200 196 IF(J-3)197,221,221 197 N1(MM)=1 198 N2(MM)=3 GO TO 187 C 199 N1(MM)=5 GO TO 198 C 200 N1(MM)=7 GO TO 222 C 205 IF(J-6)206,211,213 206 IF(J-2)207,209,210 207 N1(MM)=1 208 N2(MM)=2 GO TO 187 C 209 N1(MM)=2 GO TO 212 C 210 IF(MFREQ(MM,2)-MFREQ(MM,6))2105,2105,2110 2105 N1(MM)=4 GO TO 208 C 2110 N1(MM)=4 GO TO 214 C 211 N1(MM)=6 212 N2(MM)=4 GO TO 187 C 213 N1(MM)=7 214 N2(MM)=6 GO TO 187 C 215 IF(J-6)216,225,213 216 IF(J-3)217,220,223 217 IF(J-2)207,218,220 218 IF(MFREQ(MM,1)-MFREQ(MM,3))2180,2180,2185 2180 N1(MM)=2 2181 N2(MM)=1 GO TO 187 C 2185 N1(MM)=2 GO TO 198 C 219 N1(MM)=3 GO TO 208 C 220 IF(MFREQ(MM,2)-MFREQ(MM,5))219,219,221 221 N1(MM)=3 222 N2(MM)=5 GO TO 187 C 223 IF(MFREQ(MM,3)-MFREQ(MM,6))199,199,2235 2235 N1(MM)=5 GO TO 214 C 224 N1(MM)=6 GO TO 222 C 225 IF(MFREQ(MM,5)-MFREQ(MM,7))224,224,2250 2250 N1(MM)=6 N2(MM)=7 GO TO 187 C 230 IF(J-6)231,225,213 231 IF(J-4)232,236,238 232 IF(J-2)207,218,233 233 IF(MFREQ(MM,2)-MFREQ(MM,4))219,219,234 234 N1(MM)=3 GO TO 212 C 236 IF(MFREQ(MM,3)-MFREQ(MM,5))2360,2360,2370 2360 N2(MM)=3 GO TO 186 C 2370 N2(MM)=5 GO TO 186 C 237 N1(MM)=5 GO TO 212 C C 238 IF(MFREQ(MM,4).LE.MFREQ(MM,6)) GO TO 237 9000 GO TO 2235 END CORDER SUBROUTINE ORDER FOR BMD04S, 05S AND 07S JUNE 3, 1963 SUBROUTINE ORDER C DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25) DIMENSION DUMMY2(27) COMMON JOBNMB COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN 2DTEM,IDAY,IYEAR,NUMPGE,JOYDAC,MAXLOC,N1,N2 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK EQUIVALENCE(A,INDIVD,KOLSKR,HOLDA,RANKSM),(INV,LVAR),(HOLD,KOLHLD) EQUIVALENCE(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR) 211 I=0 C BIGY=176.0 IJJ=INDKOL+1 L=INDRNK+1 212 Y=0.0 M=INDKOL J=L+I DO 225 JRNK=J,INDKOL IF(Y-RANKSM(JRNK))215,220,225 215 IF(RANKSM(JRNK)-BIGY)216,225,225 216 Y=RANKSM(JRNK) M=INDKOL 220 M=M+1 KOLSKR(M)=JRNK 225 CONTINUE BIGY=Y DO 230 JJ=IJJ,M I=I+1 MOVFRM=KOLSKR(JJ)-INDRNK CALL MOVE(MOVFRM,I) 230 CONTINUE IF(NCASE -I)235,235,212 235 RETURN END CORQSCP SUBROUTINE ORQUES FOR BMD07S DECEMBER 16, 1964 SUBROUTINE ORQUES(L) C DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(7) DIMENSION DUMMY2(27) DIMENSION DUMMZ(11) COMMON JOBNMB COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN 2DTEM,IDAY,IYEAR,NUMPGE,JOYDAC,MAXLOC,N1,N2,LL,DUMMY1,NN COMMON DUMMZ,INDEX3 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD) EQUIVALENCE(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR) 25000 THETA=0.0 ASSIGN 218 TO KSKIP KK=NVAR+1 JJ=INDKOL+1 IF(L)1,30,1 1 NN=4 INDEX1=INDTEM+75 ASSIGN 212 TO KSKIP LL=1 1000 M=LVAR(LL) KOLSKR(INDEX1+1)=0 IF(MFREQ(M,7))4,5,4 4 CALL DECTER 5 KOLHLD (LL)=KOLSKR(INDEX1+1) LL=LL+1 IF(LL.LE.NVAR)GO TO 1000 0 INDEX=INDEX1 DO 10 J=1,25 INDEX=INDEX+1 10 KOLSKR(INDEX)=MFREQ(J,7) K=0 MM=INDKOL LGEN=0 11 N=NCASE+1 DO 15 J=1,NVAR IF(KOLHLD (J)-N)12,14,15 12 IF(LGEN-KOLHLD (J))13,15,15 13 N=KOLHLD(J) MM=INDKOL 14 MM=MM+1 KOLSKR(MM)=J 15 CONTINUE LGEN=N DO 20 J=JJ,MM I=KOLSKR(J) M=LVAR(I) K=K+1 20 MFREQ(M,7)=K IF(NVAR-K)30,30,11 30 LGEN=NCASE+1 40 N=0 MM=INDKOL DO 150 I=1,NVAR M=LVAR(I) IF(N-MFREQ(M,7))50,220,150 50 IF(MFREQ(M,7)-LGEN)55,150,150 55 N=MFREQ(M,7) MM=INDKOL 60 MM=MM+1 KOLSKR(MM)=I 150 CONTINUE LGEN=N DO 200 J=JJ,MM KK=KK-1 I=KOLSKR(J) IF(KK-I)175,200,175 175 IJJ=KK KOLHLD(1)=LVAR(I) LVAR(I)=LVAR(KK) LVAR(KK)=KOLHLD(1) K=LASTNO-NVAR+I DO 190 INDEX=I,K,NVAR HOLD(1)=A(INDEX) A(INDEX)=A(IJJ) A(IJJ)=HOLD(1) IJJ=IJJ+NVAR 190 CONTINUE 200 CONTINUE IF(KK-1)210,210,40 210 GO TO KSKIP,(212,218) 212 DO 215 J=1,25 INDEX1=INDEX1+1 215 MFREQ(J,7)=KOLSKR(INDEX1) 218 RETURN C 220 IF(MM-(INDKOL+1))60,230,60 230 J=KOLSKR(MM) IF(LVAR(J)-M)240,60,60 240 KOLSKR(MM+1)=J KOLSKR(MM)=I MM=MM+1 GO TO 150 C END CREORDR SUBROUTINE REORDR FOR BMD07S AUGUST 19, 1964 SUBROUTINE REORDR C DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2 37),KONTER(25,7) COMMON JOBNMB COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN 2DTEM,IDAY,IYEAR,NUMPGE,JOYCDA,MAXLOC,N1,N2,I DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK C EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD) 1,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR 2),(ERROR,KONTER) C 25000 THETA=0.0 IT2=2 C C TWO SCRATCH TAPES MAY BE CALLED IN THIS PROGRAM IF THE DATA C REQUIRES MOST OF THE STORAGE LOCATIONS. THEY ARE DESIGNATED HERE C BY IT2 AND IT3. IF THE NUMBER OF CASES=N AND THE NUMBER OF C QUESTIONS =P, THEN IT3 WILL BE USED IF NP+6N IS GREATER THAN C 20,000. IT2 AND IT3 WILL BOTH BE USED IF NP+5N IS GREATER THAN C 20,000. C IT3=3 C ASSIGN 26 TO KOMPLT IMEMRY=1 INDEX=INDTEM+NCASE+NCASE INDEXK=INDEX+NCASE IF(INDEXK-8000) 9,9,4 4 IF(INDEX-8000) 7,7,6 6 IMEMRY=3 REWIND IT2 GO TO 8 C 7 IMEMRY=2 8 REWIND IT3 9 INDEXK=INDTEM+NCASE JRNK=INDRNK+1 TOT=RANKSM(JRNK) NVARHF=NVAR/2+1 M=0 L=INDKOL+1 K=INDKOL DO 25 I=JRNK,K IF(RANKSM(I)-TOT)10,20,900 10 TOT=RANKSM(I) 11 IF(1-M)21,25,25 21 J=I-INDRNK KOLSKR(L)=J-M KOLSKR(L+1)=J-1 L=L+2 M=0 20 M=M+1 25 CONTINUE GO TO KOMPLT,(26,29) 26 ASSIGN 29 TO KOMPLT I=K+1 GO TO 11 29 IF((INDKOL+1)-L)30,321,905 30 NUMPRS=(L-INDKOL-1)/2 L1=INDKOL-1 INDXT1=LASTNO+1 INDXT2=INDKOL IREADT=1 GO TO (370,306,305),IMEMRY 305 NPOINT=(INDRNK-INDXT1+128)/128 NWED=INDXT1-1 IF (NPOINT.LE.1) GO TO 3330 DO 3331 J=1,NPOINT-1 NJ=(J-1)*128+NWED+1 NJJ=J*128+NWED 3331 WRITE(IT2)(INDIVD(JJJ),JJJ=NJ,NJJ) 3330 NJ=(NPOINT-1)*128+NWED+1 WRITE(IT2)(INDIVD(JJJ),JJJ=NJ,INDRNK) ENDFILE IT2 306 GO TO (307,308),IREADT 307 NPOINT=(INDXT2-JRNK+128)/128 NWED=JRNK-1 IF (NPOINT.LE.1) GO TO 3337 DO 3338 J=1,NPOINT-1 NJ=(J-1)*128+NWED+1 NJJ=J*128+NWED 3338 WRITE(IT3)(RANKSM(JJJ),JJJ=NJ,NJJ) 3337 NJ=(NPOINT-1)*128+NWED+1 WRITE(IT3)(RANKSM(JJJ),JJJ=NJ,INDXT2) END FILE IT3 REWIND IT3 GO TO (31,350,308),IMEMRY 308 REWIND IT2 31 L1=L1+2 K1=KOLSKR(L1) K2=KOLSKR(L1+1) MOVETO=K1-1 NUMSAM=K2-K1+1 INDEX2=K1*NVAR INDEX3=K2*NVAR L=INDRNK 35 DO 50 I=INDEX2,INDEX3,NVAR L=L+1 RANKSM(L)=0.0 INDEX1=I-NVAR+NVARHF 40 DO 45 J=INDEX1,I RANKSM(L)=RANKSM(L)+A(J) 45 CONTINUE 50 CONTINUE BIGY=92.0 I=INDTEM INDEX2=INDRNK+NUMSAM 51 Y=0.0 L=LASTNO DO 55 J=JRNK,INDEX2 IF(Y-RANKSM(J))52,54,55 52 IF(RANKSM(J)-BIGY)53,55,55 53 Y=RANKSM(J) L=LASTNO 54 L=L+1 INDIVD(L)=J-INDRNK 55 CONTINUE BIGY=Y DO 60 JJ=INDXT1,L I=I+1 INDIVD(I)=INDIVD(JJ) 60 CONTINUE IF((NUMSAM+INDTEM)-I)64,64,51 64 GO TO (390,390,65),IMEMRY 65 NPOINT=(INDRNK-INDXT1+128)/128 NWED=INDXT1-1 IF (NPOINT.LE.1) GO TO 6665 DO 6666 J=1,NPOINT-1 NJ=(J-1)*128+NWED+1 NJJ=J*128+NWED 6666 READ(IT2)(INDIVD(JJJ),JJJ=NJ,NJJ) 6665 NJ=(NPOINT-1)*128+NWED+1 READ(IT2)(INDIVD(JJJ),JJJ=NJ,INDRNK) 66 REWIND IT2 67 DO 70 J=JRNK,INDEX2 INDIVD(J)=0 70 CONTINUE INDEX1=INDTEM+1 INDEX2=INDTEM+NUMSAM DO 75 JJ=INDEX1,INDEX2 L=INDIVD(JJ) LL=L+INDRNK MOVETO=MOVETO+1 MOVFRM=L+INDIVD(LL)+K1-1 IF(MOVFRM-MOVETO)71,75,71 71 KK=2 CALL MOVFOR(MOVFRM,MOVETO,KK) JRNK=INDRNK+1 DO 74 I=JRNK,LL INDIVD(I)=INDIVD(I)+1 74 CONTINUE 75 CONTINUE NUMPRS=NUMPRS-1 IF(NUMPRS)905,100,80 80 IREADT=2 INDEXK=INDTEM+NCASE GO TO (350,350,305),IMEMRY C 100 GO TO (400,105,105),IMEMRY 105 NPOINT=(INDXT2-JRNK+128)/128 NWED=JRNK-1 IF (NPOINT.LE.1) GO TO 1115 DO 1116 J=1,NPOINT-1 NJ=(J-1)*128+NWED+1 NJJ=J*128+NWED 1116 READ(IT3)(RANKSM(JJJ),JJJ=NJ,NJJ) 1115 NJ=(NPOINT-1)*128+NWED+1 READ(IT3)(RANKSM(JJJ),JJJ=NJ,INDXT2) 200 REWIND IT3 321 RETURN C 350 MM=INDEXK DO 360 J=INDXT1,INDRNK MM=MM+1 INDIVD(MM)=INDIVD(J) 360 CONTINUE GO TO 31 C 370 MM=INDEX DO 380 J=JRNK,INDXT2 MM=MM+1 HOLDA(MM)=RANKSM(J) 380 CONTINUE GO TO 350 C 390 MM=INDEXK DO 395 J=INDXT1,INDRNK MM=MM+1 INDIVD(J)=INDIVD(MM) 395 CONTINUE GO TO 67 C 400 MM=INDEX DO 405 J=JRNK,INDXT2 MM=MM+1 RANKSM(J)=HOLDA(MM) 405 CONTINUE GO TO 321 C 900 KOMPER=1 J=LASTNO+I-INDRNK I=INDIVD(J) WRITE (6,4900)I GO TO 321 C 905 KOMPER=1 WRITE (6,4905) GO TO 321 C 8000 FORMAT(20A4) 4900 FORMAT(1H ,52X,13HMACHINE ERROR/30X,10HRESPONDENT,I5,39H WAS FOUND 1 OUT OF ORDER IN SUB REORDER.) 4905 FORMAT(1H ,52X,13HMACHINE ERROR/29X,60HA COUNT WHICH SHOULD BE POS 1ITIVE IN SUB REORDER IS NEGATIVE.) C END CRKCHNG SUBROUTINE RKCHNG FOR BMD07S OCTOBER 22, 1965 C SUBROUTINE RKCHNG(MAXERR) C DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2 37),KONTER(25,7),DUMMY3(5),DUMMY4(1),DUMMY5(10) COMMON JOBNMB COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN 2DTEM,IDAY,IYEAR,NUMPGE,JOYCAE,MAXLOC,N1,N2,KK,DUMMY3,IFIRST,DUMMY4 3,NN,ICHNGE,DUMMY5,INDEX3 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK C EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD) 1,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR 2),(ERROR,KONTER) C 25000 THETA=0.0 IT1=4 C C IT1 IS THE TAPE WHICH CONTAINS THE ORIGINAL WEIGHTED RESPONSES. L2=NVAR+1 C K=1 KIND=INDKOL IF(NCASE-175)400,425,425 400 KIND=INDTEM+500 425 MINERR=MAXERR-(((MAXERR+19)/20)*ICHNGE) IF(MINERR)450,465,465 450 MINERR=0 465 DO 550 N=1,NVAR NN=4 KK=L2-N CALL DECTER INDEX2=LASTNO+KK INDEX3=INDEX3+1 KOLSKR(INDEX3)=NCASE L1=LVAR(KK) IM=MVAR(L1)-1 IL=0 DO 530 JJ=1,7 MM=8-JJ IF(KONTER(L1,MM))915,4655,466 4655 NOUT=7 NIN=MFREQ(L1,MM) IF(NIN)530,530,4665 466 NOUT=KONTER(L1,MM) NIN=MFREQ(L1,MM)-NOUT IF(-NIN) 4665,530,530 4665 FLPTN1=MM IL=IL+1 IF(IL-1)4666,4666,4667 4666 INDEX1=KK GO TO 4677 4667 I=INDTEM+74+IL 4668 INDEX1=(KOLSKR(I)-1)*NVAR+KK 467 INDEX1=INDEX1+NVAR 4677 IF(INDEX1-INDEX2)468,530,530 468 IF(FLPTN1-A(INDEX1))469,4681,469 4681 NIN=NIN-1 IF(NIN)4682,4682,467 4682 GO TO (4671,4684,4685,4686,4687,4688),IM 4684 GO TO (4674,4671,530),IL 4685 GO TO (4675,4673,4671,530),IL 4686 GO TO (4676,4674,4672,4671,530),IL 4687 GO TO (4676,4675,4673,4672,4671,530),IL 4688 GO TO (4676,4675,4674,4673,4672,4671,530),IL 4671 FLPTN1=1.0 GO TO 4678 4672 FLPTN1=2.0 GO TO 4678 4673 FLPTN1=3.0 GO TO 4678 4674 FLPTN1=4.0 GO TO 4678 4675 FLPTN1=5.0 GO TO 4678 4676 FLPTN1=6.0 4678 II=FLPTN1 NIN=MFREQ(L1,II)-KONTER(L1,II) GO TO 467 469 IF(-A(INDEX1))4692,467,467 4692 IK=A(INDEX1) GO TO (200,250,300,350,600,700),IM 200 MOVETO=KOLSKR(INDTEM+76)+1 210 IF(MOVETO)900,900,473 250 GO TO (252,467,467,254,467,467,200),IK 252 MOVETO=KOLSKR(INDTEM+77)+1 GO TO 210 254 IF(MM-1)252,252,200 300 GO TO (301,467,301,467,252,467,200),IK 301 MOVETO=KOLSKR(INDTEM+78)+1 GO TO 210 350 GO TO (351,351,467,301,467,252,200),IK 351 MOVETO=KOLSKR(INDTEM+79)+1 GO TO 210 600 GO TO (601,601,351,467,301,252,200),IK 601 MOVETO=KOLSKR(INDTEM+80)+1 GO TO 210 700 GO TO (701,701,601,351,301,252,200),IK 701 MOVETO=KOLSKR(INDTEM+81)+1 GO TO 210 C 473 MOVFRM=(INDEX1-KK)/NVAR+1 IF(MOVFRM-NCASE)4735,4735,900 4735 IF(MOVETO-NCASE)4737,4737,467 4737 IF(-MOVFRM)4738,900,900 4738 CALL MOVFOR(MOVFRM,MOVETO,K) 474 J=KIND DO 478 II=1,NVAR I=LVAR(II) DO 477 L=1,7 475 J=J+1 KOLSKR(J)=KONTER(I,L) 477 CONTINUE 478 CONTINUE C C DETERMINE NEW ERROR 480 NN=3 CALL DECTER NERROR=0 DO 485 II=1,NVAR I=LVAR(II) DO 484 J=1,7 NERROR=NERROR+KONTER(I,J) 484 CONTINUE 485 CONTINUE IF(MAXERR-NERROR)486,486,495 486 J=KIND DO 490 II=1,NVAR I=LVAR(II) DO 488 L=1,7 J=J+1 KONTER(I,L)=KOLSKR(J) 488 CONTINUE 490 CONTINUE CALL MOVFOR(MOVETO,MOVFRM,K) GO TO 496 C 495 MAXERR=NERROR 496 IF(MINERR-MAXERR)497,555,555 497 CONTINUE C 4975 NN=4 KK=L2-N CALL DECTER INDEX3=INDEX3+1 KOLSKR(INDEX3)=NCASE GO TO 467 C C 0 C 0 530 CONTINUE 550 CONTINUE 555 RETURN C 900 KOMPER=1 WRITE (6,4900)MOVFRM,MOVETO GO TO 555 C 915 KOMPER=1 WRITE (6,4915)L1,MM GO TO 530 C 4900 FORMAT(1H0,104HIN MOVING AN INDIVIDUAL AND HIS RESPONSES IN SUB RK 1CHNG, THE RANK MOVED FROM OR TO IS IN ERROR. THEY ARE,I5,4H ANDI5) 4915 FORMAT(1H ,52X,13HMACHINE ERROR/19X,27HNEGATIVE ERROR FOR QUESTION 1,I3,6H SCORE,I2,25H WAS FOUND IN SUB RKCHNG.) C END CDECTER SUBROUTINE DECTER FOR GUTTMAN SCALES JUNE 15, 1967 SUBROUTINE DECTER C DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA X(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE XQ(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),KONTER(2 X5,7),DUMMY3(5),DUMMY4(7),DUMMY5(11),DUMMY2(27) C COMMON JOBNMB COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV XAR,INDRNK,INDKOL,ISCALE,IRAMK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN XDTEM,DUMMY3,N1,N2,I,DUMMY4,KK,DUMMY5,INDEX3 C EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD) 1,(DUMMY1,MFREQ),(ERROR,KONTER),(DUMMY2,MVAR),(DUMMY2(26),LASTNO), 2(DUMMY2(27),NVAR) C DOUBLE PRECISION DUMMY2, FRSTMO, SECMON, JOBNMB, KDUMY6, REF, KCHECK KTIMES=I INDEX3=INDTEM+75 10 DO 200 I=1,NVAR GO TO (12,11,12,11),KK 11 IF(KTIMES-I)210,12,200 12 INCHCK=LASTNO+I M=LVAR(I) DO 14 J=1,7 KONTER(M,J)=0 14 CONTINUE MTIMES=MVAR(M) J=7 INDEX=I INDEX1=I LTIMES=1 15 NERROR=MFREQ(M,J) L1=0 K=0 LL=0 IJJ=NERROR FLPTN1=J KERROR=0 ITIMES=1 JTIMES=1 20 IF(A(INDEX))25,41,25 25 IF(A(INDEX)-FLPTN1)30,45,30 30 IF(NERROR-MFREQ(M,J))35,42,42 35 GO TO (36,39,48),ITIMES 36 INDEX=INDEX-NVAR IF(-INDEX)37,38,38 37 IF(A(INDEX))375,375,38 375 K=K-1 LL=LL-1 GO TO 36 38 INDEX=INDEX+NVAR 385 IJJ=NERROR L1=L1+K K=0 LL=LL+KERROR KERROR=0 ITIMES=2 JTIMES=1 GO TO 4935 39 KERROR=KERROR+1 IF(KERROR-IJJ)46,46,499 40 INDEX=INDEX+NVAR IF(INDEX-INCHCK)20,55,55 41 K=K+1 42 LL=LL+1 GO TO 40 45 NERROR=NERROR-1 GO TO (46,47,475),ITIMES 46 IF(NERROR)52,52,40 47 ITIMES=3 475 IF(NERROR)477,477,40 477 IF(IJJ-KERROR)499,385,385 48 IF((IJJ-NERROR)-KERROR)49,36,36 49 GO TO (492,494,499),JTIMES 492 JTIMES=2 493 ITIMES=2 4935 IF(NERROR)499,499,39 494 JTIMES=3 GO TO 493 499 INDEX=(MFREQ(M,J)-IJJ+LL-K)*NVAR+INDEX1 50 INDEX1=INDEX 500 GO TO (5005,5005,555,555),KK 5005 KONTER(M,J)=IJJ+LL-L1-K 501 GO TO (509,509,502,502),KK 502 INDEX3=INDEX3+1 KOLSKR(INDEX3)=(INDEX-I)/NVAR 509 IF(INDEX-INCHCK)51,190,190 51 GO TO (1995, 59 ,57,65,70,75,80),MTIMES 52 IJJ=0 INDEX=INDEX+NVAR GO TO 50 55 IF((IJJ-NERROR)-KERROR)499,56,56 555 KONTER(M,J)=IJJ GO TO 501 56 IJJ=NERROR LL=LL+KERROR GO TO 500 57 GO TO (58,59),LTIMES 58 LTIMES=2 585 J=4 GO TO 15 59 K=0 LL=0 INDEX=INDEX-NVAR 60 INDEX=INDEX+NVAR IF(INDEX-INCHCK)61,63,1995 61 IF(A(INDEX)-1.0)60,62,625 62 K=K+1 GO TO 60 625 LL=LL+1 GO TO 60 63 GO TO (635,635,64,64),KK 635 KONTER(M,1)=MFREQ(M,1)-K+LL GO TO 1995 64 LL=0 GO TO 635 65 GO TO (67,68,59),LTIMES 67 LTIMES=2 675 J=5 GO TO 15 68 LTIMES=3 685 J=3 GO TO 15 70 GO TO (72,73,74,59),LTIMES 72 LTIMES=2 725 J=6 GO TO 15 73 LTIMES=3 GO TO 585 74 LTIMES=4 745 J=2 GO TO 15 75 GO TO (72,76,77,78,59),LTIMES 76 LTIMES=3 GO TO 675 77 LTIMES=4 GO TO 685 78 LTIMES=5 GO TO 745 80 GO TO (72,76,81,82,83,59),LTIMES 81 LTIMES=4 GO TO 585 82 LTIMES=5 GO TO 685 83 LTIMES=6 GO TO 745 190 GO TO (1995,193 ,191,194,198,1904,1908),MTIMES 191 GO TO (192,193),LTIMES 192 KONTER(M,4)=MFREQ(M,4) 193 KONTER(M,1)=MFREQ(M,1) GO TO 1995 194 GO TO (195,196,193),LTIMES 195 KONTER(M,5)=MFREQ(M,5) 196 KONTER(M,3)=MFREQ(M,3) GO TO 193 198 GO TO (199,1901,1902,193),LTIMES 199 KONTER(M,6)=MFREQ(M,6) 1901 KONTER(M,4)=MFREQ(M,4) 1902 KONTER(M,2)=MFREQ(M,2) GO TO 193 1904 GO TO (1905,1906,1907,1902,193),LTIMES 1905 KONTER(M,6)=MFREQ(M,6) 1906 KONTER(M,5)=MFREQ(M,5) 1907 KONTER(M,3)=MFREQ(M,3) GO TO 1902 1908 GO TO (1909,1910,1911,1907,1902,193),LTIMES 1909 KONTER(M,6)=MFREQ(M,6) 1910 KONTER(M,5)=MFREQ(M,5) 1911 KONTER(M,4)=MFREQ(M,4) GO TO 1907 1995 GO TO (200,210,200,210),KK 200 CONTINUE 210 RETURN END CMOVE SUBROUTINE MOVE FOR GUTTMAN SCALES PROGRAMS CMOVE SUBROUTINE MOVE FOR GUTTMAN SCALES APRIL 15, 1967 SUBROUTINE MOVE(M1,M2) DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA X(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE XQ(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2 X7),KONTER(25,7),DUMMY3(5),DUMMY4(7),DUMMY5(11) C EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD) X,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR X),(ERROR,KONTER) C COMMON JOBNMB COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV XAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN XDTEM,DUMMY3,N1,N2,I,DUMMY4,KK,DUMMY5 DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK C 25000 YHETA=0.0 IF(M1-M2)5,100,5 C EXCHANGE RESPONSES FOR RANKS M1 AND M2 5 INDEX1=(M1-1)*NVAR INDEX2=((M2-1)*NVAR)+1 INDEX3=INDEX2+NVAR-1 DO 50 I=INDEX2,INDEX3 INDEX1=INDEX1+1 GSABE=A(INDEX1) A(INDEX1)=A(I) A(I)=GSABE 50 CONTINUE C EXCHANGE IDENTIFICATION NUMBERS INDEX1=M1+LASTNO INDEX2=M2+LASTNO KSAVE=INDIVD(INDEX1) INDIVD(INDEX1)=INDIVD(INDEX2) INDIVD(INDEX2)=KSAVE C EXCHANGE RANK SUMS 75 INDEX1=M1+INDRNK INDEX2=M2+INDRNK FSAVE=RANKSM(INDEX1) RANKSM(INDEX1)=RANKSM(INDEX2) RANKSM(INDEX2)=FSAVE 100 RETURN END CMVDATA SUBROUTINE MVDATA FOR GUTTMAN SCALES JUNE 15, 1967 CMVDATA SUBROUTINE MVDATA FOR GUTTMAN SCALES PROGRAMS SUBROUTINE MVDATA(M1,M2) DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA 1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE 2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),KONTER(2 35,7),DUMMY3(5),DUMMY4(7),DUMMY5(9) DIMENSION DUMMY2(27) C COMMON JOBNMB COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV 1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN 3DTEM,DUMMY3,N1,N2,I,DUMMY4,KK,DUMMY5 EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD) 1,(DUMMY1,MFREQ),(ERROR,KONTER) EQUIVALENCE(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR) DOUBLE PRECISION DUMMY2 DOUBLE PRECISION JB,JOBNMB,JBND,REF,REFLEK,SECMON,FRSTMO,BLANKS, 1BND 25000 THETA=0.0 IF(M1-M2)5,100,5 C EXCHANGE RESPONSES FOR RANKS M1 AND M2 5 INDEX1=(M1-1)*NVAR INDEX2=((M2-1)*NVAR)+1 INDEX3=INDEX2+NVAR-1 DO 50 I=INDEX2,INDEX3 INDEX1=INDEX1+1 GSAVE=A(INDEX1) A(INDEX1)=A(I) A(I)=GSAVE 50 CONTINUE C EXCHANGE IDENTIFICATION NUMBERS INDEX1=M1+LASTNO INDEX2=M2+LASTNO KSAVE=INDIVD(INDEX1) INDIVD(INDEX1)=INDIVD(INDEX2) INDIVD(INDEX2)=KSAVE 100 RETURN END CMOVFOR SUBROUTINE MOVFOR FOR GUTTMAN SCALE PROGRAMS SUBROUTINE MOVFOR(M1,M2,KK) DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA X(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE XQ(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2 X7),KONTER(25,7),DUMMY3(5),DUMMY4(7),DUMMY5(9) C EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD) X,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR X),(ERROR,KONTER) C COMMON JOBNMB COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV XAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN XDTEM,DUMMY3,N1,N2,I,DUMMY4,KKP,DUMMY5 DOUBLE PRECISION JOB,JOBNMB,JBND,REF DOUBLE PRECISION SECMON,FRSTMO DOUBLE PRECISION DUMMY2 DOUBLE PRECISION REFLEK DOUBLE PRECISION BLANKS,BND C 25000 THETA=0.0 KK=KK INDEX1=M2*NVAR INDEXK=INDEX1-NVAR INDEX2=M1*NVAR M=INDEX2-NVAR+1 INDEX3=M-1 DO 25 I=1,NVAR INDEX3=INDEX3+1 HOLD(I)=A(INDEX3) 25 CONTINUE JRNK=M1+INDRNK HOLD(NVAR+1)=RANKSM(JRNK) INDIDV=M1+LASTNO IJJ=INDIVD(INDIDV) IF(M2-M1)50,500,300 50 NADD=-NVAR NONE=-1 55 L=M J=M-1+NADD DO 60 I=L,INDEX2 J=J+1 A(I)=A(J) 60 CONTINUE M=L+NADD IND=INDIDV+NONE INDIVD(INDIDV)=INDIVD(IND) INDIDV=IND GO TO (65,70),KK 65 IRNK=JRNK+NONE RANKSM(JRNK)=RANKSM(IRNK) JRNK=IRNK 70 INDEX2=INDEX2+NADD IF(INDEX2-INDEX1)55,100,55 100 DO 125 I=1,NVAR INDEXK=INDEXK+1 A(INDEXK)=HOLD(I) 125 CONTINUE INDIVD(INDIDV)=IJJ GO TO (140,500),KK 140 RANKSM(JRNK)=HOLD(NVAR+1) 500 RETURN 300 NADD=NVAR NONE=1 GO TO 55 END SUBROUTINE REMOVE(N) REWIND N RETURN END