Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0137/bmd/bmd05s.for
There is 1 other file named bmd05s.for in the archive. Click here to see a list.
CBMD05S GUTTMAN SCALES NO. 1 - MAIN PROGRAM JUNE 16,1967
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),KONTER(2
35,7),DUMMY3(1),DUMMY5(2),DUMMY6(6),REF(25)
C
COMMON JOBNMB,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,MVAR,LASTNO,NVAR,INDRNK,INDKOL,ISCALE,LESTN,LEAVE,IERROR,KANEND
2,KOMPER,KORDER,INDTEM,IDAY,IYEAR,NUMPGE,DUMMYZ,MAXLOC,N1,N2,DUMMY3
3,LASTRD,NDREDK,L,IFINAL,ILAST,IFIRST,IXTRA,KK,DUMMY5,L1,DUMMY6,IND
4EX3
C
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
1,(DUMMY1,MFREQ),(ERROR,KONTER),(YES,IYES)
C
DOUBLE PRECISION JB,JOBNMB,JBND,REF,REFLEK,SECMON,FRSTMO,BLANKS,
1BND
DATA IYES/4HYES /
C BMD05S USES THE FOLLOWING SUBROUTINES FOUND IN BMD04S
C
C COMBIN CONFRM DECTER
C FNDCMB MOVE MOVFOR
C ORDER ORQUES REORDR
C
4515 FORMAT(1H1,2X,40HBMD05S--GUTTMAN SCALE NUMBER 1 - REVISED,2X
1,18H MAY 15, 1968 /
23X,40HHEALTH SCIENCES COMPUTING FACILITY, UCLA)
C
IDAY=-25
CALL USAGEB('BMD05S')
4 NUMPGE=0
KOMPER=0
ITIMES=1
JTIMES=1
KTIMES=0
DO 47 I=1,25
DO 43 J=1,7
MFREQ(I,J)=0
ERROR(I,J)=0.0
43 CONTINUE
MFREQ(I,8)=0
NCOMB(I)=0
N1(I)=0
N2(I)=0
LVAR(I)=0
47 CONTINUE
KANEND=1
5 CALL READ(REF(1))
KANEND=KANEND
FLPTN2=LASTNO
IF(NVAR-25)165,165,900
165 IF(KOMPER-99)166,999,166
166 IF(KOMPER)998,169,998
C
C PRINT DATA PROPERLY SCORED, IF DESIRED
C
169 WRITE (6,4515)
IF(ISCALE.NE.IYES) GO TO 200
170 NTIMES=1
GO TO 5000
175 WRITE (6,4000)
WRITE (6,4504)NCASE,NVAR
WRITE (6,4505)
WRITE (6,4507)(LVAR(J),REF(J),J=1,NVAR)
GO TO 327
180 WRITE (6,4001)INDIVD(INDIDV),(A(J),J=INDEX1,INDEX2)
190 GO TO 267
C
C CHECK TO SEE THAT THE RESPONSES GIVEN DO CONFORM TO THE
C KVAR(J), J=1,NVAR, WHICH WERE READ IN.
C
200 CALL CONFRM
IF(KOMPER)998,201,998
C
C RANK RESPONDENTS USING CORNELL TECHNIQUE
C
201 LTIMES=1
2015 KTIMES=KTIMES+1
202 INDEX2=0
DO 204 J=1,NCASE
JRNK=INDRNK+J
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
328 GO TO (275,465,500),LTIMES
C
C REORDER THOSE INDIVIDUALS WITH THE SAME TOTAL SCORE
C
275 CALL REORDR
LTIMES=2
IF (KOMPER)998,276,998
276 IF(IFINAL.NE.IYES) GO TO 328
325 NTIMES=2
GO TO 5000
C
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
GO TO (180,2665,756),NTIMES
2665 WRITE (6,4003)I,INDIVD(INDIDV),RANKSM(JRNK),(A(J),J=INDEX1,INDEX2)
267 CONTINUE
GO TO 5050
C
C DETERMINE ERROR FOR FINAL COMPUTATIONS
C
465 KK=3
CALL DECTER
IF(IERROR.NE.IYES) GO TO 475
466 KTIMES=KTIMES+1
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,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)
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
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
3877 CONTINUE
WRITE (6,4024)(KOLHLD(I),I=1,NVAR)
GO TO (388,505),JTIMES
388 WRITE (6,4502)
WRITE (6,4006)
WRITE (6,4500)
DO 389 I=1,NVAR
WRITE (6,4007)I,(MFREQ(I,J),J=1,8)
389 CONTINUE
C
C CHECK TO SEE IF CHANGING RANK OF INDIVIDUALS REDUCES ERROR
C
475 MAXERR=0
DO 480 I=1,NVAR
DO 480 J=1,7
MAXERR=MAXERR+KONTER(I,J)
480 CONTINUE
485 CALL CHNGRK(MAXERR)
IF(KOMPER)998,490,998
490 KTIMES=KTIMES+1
ITIMES=4
IF(IFINAL.NE.IYES)GO TO 500
495 LTIMES=3
GO TO 325
C
500 JTIMES=2
GO TO 466
C
505 KK=4
CALL FNDCMB(FLPTN2)
IF(KOMPER)998,560,998
560 K=INDTEM+25
KSUM=0
DO 3874 I=1,NVAR
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
FLPTN1=MAXERR
COFREP=1.0-(FLPTN1/FLPTN2)
DO 561 I=1,NVAR
J=K+I
IF(KOLSKR(J))561,561,562
561 CONTINUE
GO TO 600
C
562 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,4500)
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,N1(M),N2(M),N,RANKSM(INDEX1+25)
570 CONTINUE
C
C ASSIGN PROPER RESPONSES TO THE NO RESPONSE SCORES, COMPUTE THE
C COEFFICIENT OF REPRODUCIBILITY, AND ASSIGN THE GUTTMAN SCALE SCORE
C
600 CALL ASSIGN
IF(KOMPER)998,700,998
700 IF(ILAST.NE.IYES) GO TO 760
725 NTIMES=3
GO TO 5000
C
755 WRITE (6,4019)
WRITE (6,4504)NCASE,NVAR
WRITE (6,4018)COFREP
WRITE (6,4021)FMINMR
WRITE (6,4505)
DO 7555 I=1,NVAR
M=LVAR(I)
HOLD(I)=REF(M)
7555 CONTINUE
WRITE (6,4512)(LVAR(J),HOLD(J),J=1,NVAR)
WRITE (6,4023)
GO TO 327
756 WRITE (6,4020)KOLSKR(JRNK),INDIVD(INDIDV),I,(A(J),J=INDEX1,INDEX2)
GO TO 267
C
C MAKE FINAL PRINTOUT AND GO TO NEXT PROBLEM
C
760 IF(IXTRA.NE.IYES) GO TO 890
805 L=0
MINPR=0
KK=0
806 N=INDTEM-1
ASSIGN 816 TO KPASS
8065 MAXPR=131071
K=-1
DO 810 J=1,NCASE
I=LASTNO +J
IF(INDIVD(I)-MAXPR)807,815,810
807 IF(MINPR-INDIVD(I))808,810,810
808 MAXPR=INDIVD(I)
INDEX2=J
INDEXK=I
810 CONTINUE
KK=KK+K+1
MINPR=MAXPR
N=N+2
L=L+1
KOLSKR(N)=INDIVD(INDEXK)
JRNK=INDEX2+INDRNK
KOLSKR(N+1)=KOLSKR(JRNK)
IF(L-NCASE)811,812,812
811 IF((N+1-INDTEM)-768)8065,812,812
812 NUMPGE=NUMPGE+1
WRITE (6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE
WRITE (6,4025)
WRITE (6,4504)NCASE,NVAR
WRITE (6,4500)
WRITE (6,4018)COFREP
WRITE (6,4021)FMINMR
WRITE (6,4514)
N1(1)=INDTEM+1
N2(1)=N+1
N33=N1(1)
N44=N2(1)
WRITE(6,4026)(KOLSKR(I),I=N33,N44)
IF(L-NCASE)806,998,998
C
815 K=K+1
GO TO KPASS,(816,817)
816 NUMPGE=NUMPGE+1
WRITE (6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE
WRITE (6,4500)
ASSIGN 817 TO KPASS
817 INDIVD(I)=131070-KK-K
WRITE (6,4027)MAXPR,INDIVD(I)
GO TO 810
C
890 IF(ILAST.EQ.IYES) GO TO 998
895 ILAST=IYES
IXTRA=0
GO TO 725
C
900 WRITE (6,4015)NVAR
IF(KOMPER-99)998,999,998
998 GO TO (4,999),KANEND
C
4000 FORMAT(1H ,38X,40HINPUT DATA AFTER RECEIVING PROPER SCORES)
4001 FORMAT(1H ,I8,7X,25F4.0)
4002 FORMAT(1H ,41X,28HRESPONDENTS AND SCALE SCORES/37X,37HRANKED ACCOR
1DING TO CORNELL TECHNIQUE)
4003 FORMAT(1H ,I4,I5,2F5.0,24F4.0)
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,7X,8I10)
4008 FORMAT(1H ,26X,57HWITH QUESTIONS ORDERED IN INCREASING FREQUENCY O
1F SCORE 7)
4012 FORMAT(1H ,42X,27HERRORS FOR EACH SCALE SCORE/50X,11HFINAL STEPS)
4015 FORMAT(1H0,4X,89HTHE MAXIMUM NUMBER OF VARIABLES OR QUESTIONS ALLO
1WED IN THIS PROGRAM IS 25. YOU HAVE USED,I4,9H AND THUS//30X,53HTH
2E PROGRAM WILL GO TO THE NEXT PROBLEM OR TERMINATE.)
4016 FORMAT(1H ,34X,41HPOSSIBLE COMBINATIONS WHICH WILL INCREASE/25X,61
1HTHE COEFFICIENT OF REPRODUCIBILITY AND THE AMOUNT OF INCREASE)
4017 FORMAT(1H0,16X,I3,17X,I3,5H AND,I3,19X,I4,20X,F5.4)
4018 FORMAT(1H ,36X,33HCOEFFICIENT OF REPRODUCIBILITY = ,F7.5)
4019 FORMAT(1H ,44X,20HGUTTMAN SCALE SCORES)
4020 FORMAT(1H ,I4,I7,I5,F5.0,24F4.0)
4021 FORMAT(1H0,34X,35HMINIMAL MARGINAL REPRODUCIBILITY = ,F7.5)
4023 FORMAT(7H SCORE)
4024 FORMAT(1H0,14H TOTAL ERROR ,25I4)
4025 FORMAT(1H ,37X,36HRESPONDENTS AND GUTTMAN SCALE SCORES)
4026 FORMAT(1H0,2I6,7(I9,I6)/(I7,I6,I9,I6,I9,I6,I9,I6,I9,I6,I9,I6,I9,I6
1,I9,I6))
4027 FORMAT(1H0,5X,46HTHERE ARE INDIVIDUALS WITH THE SAME ID NUMBER,,I7
1,44H ONE OF THEM HAS BEEN ASSIGNED THE ID NUMBER,I7,1H.)
4500 FORMAT(1H )
4502 FORMAT(1H0//)
4503 FORMAT(1H1,15H PROBLEM NUMBER,2X,A6,57X,2A8,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)
4507 FORMAT(1H ,11H RESPONDENT,4X,25(I3,A1))
4508 FORMAT(1H ,15HRANK RESP SCOR ,25(I3,A1))
4509 FORMAT(1H ,3X,8HSCORE OF,4X,25(I3,A1))
4511 FORMAT(1H0,64X,8HDECREASE,15X,11HAPPROXIMATE/15X,8HQUESTION,15X,11
1HCOMBINATION,15X, 10HIN NUMBER,14X,11HINCREASE IN/64X,10HOF ERRO
2RS,12X,15HREPRODUCIBILITY)
4512 FORMAT(1H ,7HGUTTMAN/18H SCALE RESP RANK ,25(I3,A1))
4514 FORMAT(1H0,7X,7HGUTTMAN,7(8X,7HGUTTMAN)/2X,12HRESP. SCALE,7(3X,12
1HRESP. SCALE)/9X,5HSCORE,7(10X,5HSCORE))
C
5000 MINPR=1
MAXPR=0
INDEX2=0
NDIFF=NCASE
5010 IF(NDIFF-50)5020,5020,5030
5020 MAXPR=NCASE
NDIFF=0
GO TO 5040
5030 MAXPR=MAXPR+50
NDIFF=NDIFF-50
5040 NUMPGE=NUMPGE+1
WRITE (6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE
GO TO (175,326,755),NTIMES
C
5050 MINPR=MINPR+50
IF(NDIFF)5060,5060,5010
5060 GO TO (200,328,760),NTIMES
C
999 STOP
END
CASSIGN SUBROUTINE ASSIGN FOR BMD05S JUNE 15, 1967
SUBROUTINE ASSIGN
C
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),KONTER(2
35,7),DUMMY7(7),DUMMY9(9)
C
COMMON JOBNMB,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,MVAR,LASTNO,NVAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND
2,KOMPER,KORDER,INDTEM,IDAY,IYEAR,NUMPGE,DUMMYZ,MAXLOC,N1,N2,I,
3DUMMY7,KK,DUMMY9,INDEX3
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
1,(DUMMY1,MFREQ),(ERROR,KONTER)
C
DOUBLE PRECISION JB,JOBNMB,JBND,REF,REFLEK,SECMON,FRSTMO,BLANKS,
1BND
605 J=0
C
DO 615 II=1,NVAR
MM=LVAR(II)
IF(MFREQ(MM,8))615,615,610
610 J=J+1
KOLHLD(J)=II
MFREQ(MM,8)=0
615 CONTINUE
IF(J)700,700,620
620 DO 695 L=1,J
MM=KOLHLD(L)
M=LVAR(MM)
MTIMES=MVAR(M)
INDTST=LASTNO+MM-NVAR
I=MM
KK=4
CALL DECTER
INDEXK=MM
INDEX1=INDTEM+76
IFDONE=1
SCORE1=7.0
NN=7
DO 690 K=INDEX1,INDEX3
624 IF(KOLSKR(K)-NCASE)625,625,910
625 INDEX2=(KOLSKR(K)-1)*NVAR+MM
626 DO 630 LL=INDEXK,INDEX2,NVAR
IF(A(LL))627,627,630
627 A(LL)=SCORE1
MFREQ(M,NN)=MFREQ(M,NN)+1
630 CONTINUE
IF(INDEX2-INDTST)631,695,695
631 GO TO (920,637,640,645,650,660,670),MTIMES
637 SCORE1=1.0
NN=1
INDEXK=INDEX2+NVAR
INDEX2=INDTST
GO TO 626
C
640 GO TO (641,637),IFDONE
641 IFDONE=2
6415 SCORE1=4.0
NN=4
642 INDEXK=INDEX2+NVAR
GO TO 690
C
645 GO TO (646,647,637),IFDONE
646 IFDONE=2
6465 SCORE1=5.0
NN=5
GO TO 642
C
647 IFDONE=3
648 SCORE1=3.0
NN=3
GO TO 642
C
650 GO TO (651,652,654,637),IFDONE
651 SCORE1=6.0
IFDONE=2
NN=6
GO TO 642
C
652 IFDONE=3
GO TO 6415
C
654 IFDONE=4
655 SCORE1=2.0
NN=2
GO TO 642
C
660 GO TO (651,661,663,664,637),IFDONE
661 IFDONE=3
GO TO 6465
C
663 IFDONE=4
GO TO 648
C
664 IFDONE=5
GO TO 655
C
670 GO TO (651,661,671,672,673,637),IFDONE
671 IFDONE=4
GO TO 6415
C
672 IFDONE=5
GO TO 648
C
673 IFDONE=6
GO TO 655
C
690 CONTINUE
695 CONTINUE
C
C DETERMINE THE ORDER OF CUTTING POINTS AND ASSIGN THE PROPER
C GUTTMAN SCALE SCORE.
C
700 KK=3
CALL DECTER
J=INDKOL
701 INDEX1=INDTEM+76
INDEX3=INDEX3+1
KOLSKR(INDEX3)=NCASE
MM=0
702 N=NCASE+1
DO 720 I=INDEX1,INDEX3
IF(KOLSKR(I)-N)705,710,720
705 IF(MM-KOLSKR(I))706,720,720
706 N=KOLSKR(I)
GO TO 720
C
710 KOLSKR(I)=NCASE
720 CONTINUE
MM=N
J=J+1
KOLSKR(J)=N
IF(MM-NCASE)702,725,725
725 INDEX1=INDKOL+1
INDEX2=J
INDEXK=INDRNK
L=0
WRITE (6,4000)
DO 750 I=INDEX1,INDEX2
INDEX3=INDEXK+1
INDEXK=INDRNK+KOLSKR(I)
L=L+1
DO 740 J=INDEX3,INDEXK
KOLSKR(J)=L
740 CONTINUE
J=INDEXK-INDEX3+1
FJ=J
FNCASE=NCASE
P=FJ/FNCASE
WRITE (6,4001)L,J,P
750 CONTINUE
INDEX3=INDEX2
760 RETURN
C
910 KOMPER=1
WRITE (6,4910)M,KOLSKR(K)
GO TO 760
C
920 KOMPER=1
WRITE (6,4920)M,MTIMES
GO TO 760
C
4000 FORMAT(2H0 ,46HFREQUENCY DISTRIBUTION OF GUTTMAN SCALE SCORES//9X,
15HSCORE,6X,5HFREQ.,4X,8HFRACTION//)
4001 FORMAT(1H 8X,I4,6X,I5,4X,F8.4)
4910 FORMAT(1H0,5X,91H* MACHINE ERROR * OCCURS IN SUBROUTINE ASSIGN AFT
1ER ENTRY TO SUBROUTINE DECTER FOR QUESTION,I3,4H ONE/14X,83HOF THE
2 CUTTING POINTS IS GREATER THAN THE NUMBER OF CASES. PROGRAM CANNO
3T CONTINUE.)
4920 FORMAT(1H0,12X,47H* MACHINE ERROR * IN SUBROUTINE ASSIGN QUESTION,
1I3,21H APPEARS TO HAVE ONLY,I3,10H RESPONSES/23X,65HWHERE IT MUST
2HAVE AT LEAST 2 RESPONSES. PROGRAM CANNOT CONTINUE.)
C
END
CCHNGRK SUBROUTINE CHNGRK FOR BMD05S JUNE 15, 1967
SUBROUTINE CHNGRK(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),KONTER(2
35,7),DUMMY3(8)
COMMON JOBNMB,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,MVAR,LASTNO,NVAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND
2,KOMPER,KORDER,INDTEM,IDAY,IYEAR,NUMPGE,DUMMYZ,MAXLOC,N1,N2,
3DUMMY3,KK
C
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
1,(DUMMY1,MFREQ),(ERROR,KONTER)
C
DOUBLE PRECISION JB,JOBNMB,JBND,REF,REFLEK,SECMON,FRSTMO,BLANKS,
1BND
L2=NVAR+1
C
K=1
KIND=INDKOL
IF(NCASE-175)400,465,465
400 KIND=INDTEM+500
465 DO 550 N=1,NVAR
LL=L2-N
INDEX2=LASTNO+LL
L1=LVAR(LL)
DO 530 JJ=1,7
MM=8-JJ
IF(KONTER(L1,MM))915,530,466
466 NOUT=KONTER(L1,MM)
NIN=MFREQ(L1,MM)-NOUT
IF(NIN) 530,530,4665
4665 FLPTN1=MM
ASSIGN 471 TO KOUNT
INDEX1=LL-NVAR
467 INDEX1=INDEX1+NVAR
IF(INDEX1-INDEX2)468,530,530
468 IF(A(INDEX1)-FLPTN1)467,470,467
470 GO TO KOUNT,(471,473)
471 NIN=NIN-1
IF(NIN)472,472,467
472 MOVETO=(INDEX1-LL)/NVAR+2
ASSIGN 473 TO KOUNT
IF(MOVETO)900,900,467
C
473 MOVFRM=(INDEX1-LL)/NVAR+1
IF(MOVFRM-NCASE)4735,4735,900
4735 IF(MOVETO-NCASE)4737,4737,900
4737 IF(MOVFRM)900,900,4738
4738 NOUT=NOUT-1
CALL MOVFOR(MOVFRM,MOVETO,K)
474 J=KIND
DO 478 I=1,NVAR
DO 477 L=1,7
475 J=J+1
KOLSKR(J)=KONTER(I,L)
477 CONTINUE
478 CONTINUE
C
C DETERMINE NEW ERROR
C
480 CALL DECTER
NERROR=0
DO 485 I=1,NVAR
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 I=1,NVAR
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 MOVETO=MOVETO+1
MAXERR=NERROR
496 IF(NOUT)530,530,467
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 CH
1NGRK, 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 CHNGRK.)
C
END
CCOMBIN SUBROUTINE COMBIN FOR BMD04S,05S,AND 07S JUNE 15, 1967
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)
COMMON JOBNMB,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,MVAR,LASTNO,NVAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND
2,KOMPER
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
DOUBLE PRECISION JB,JOBNMB,JBND,REF,REFLEK,SECMON,FRSTMO,BLANKS,
1BND
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
CCONFRM SUBROUTINE CONFRM FOR BMD05S JUNE 15, 1967
C
SUBROUTINE CONFRM
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),KONTER(2
35,7)
COMMON JOBNMB,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,MVAR,LASTNO,NVAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND
2,KOMPER,KORDER,INDTEM,IDAY,IYEAR,NUMPGE,DUMMYZ,MAXLOC,N1,N2
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
1,(DUMMY1,MFREQ),(ERROR,KONTER)
DOUBLE PRECISION JB,JOBNMB,JBND,REF,REFLEK,SECMON,FRSTMO,BLANKS,
1BND
C
C
KORDER=0
C
M=INDKOL
DO 210 I=1,NVAR
MVAR(I)=0
DO 206 J=1,7
IF(MFREQ(I,J))905,206,205
205 MVAR(I)=MVAR(I)+1
206 CONTINUE
IF(MVAR(I)-KVAR(I))208,210,910
208 M=M+1
KOLSKR(M)=I
210 CONTINUE
IF(M-INDKOL)920,211,930
2200 DO 2290 J=INDEX1,M
I=KOLSKR(J)
WRITE (6,4930)I,MVAR(I),KVAR(I)
NCOMB(I)=KVAR(I)-MVAR(I)
KTIMES=KVAR(I)
NTIMES=NCOMB(I)
JTIMES=NTIMES
N=1
IF(NTIMES-1)125,125,124
124 NTIMES=2
125 GO TO (950,2201,130,140,150,160,170,950),KTIMES
130 IF(MFREQ(I,1))905,131,132
131 N1(1)=1
132 IF(MFREQ(I,4))905,133,135
133 IF(N1(1))2201,134,2201
134 N1(1)=4
135 IF(MFREQ(I,7))905,136,138
136 IF(N1(1))2201,137,2201
137 N1(1)=7
138 WRITE (6,4970)(N1(N),N=1,JTIMES)
DO 139 N=1,JTIMES
N1(N)=0
139 CONTINUE
GO TO 2201
140 IF(MFREQ(I,1))905,141,142
141 N1(N)=1
GO TO (138,142),NTIMES
142 IF(MFREQ(I,3))905,143,145
143 IF(N1(N))2201,144,1435
1435 N=N+1
144 N1(N)=3
GO TO (138,145),NTIMES
145 IF(MFREQ(I,5))905,146,148
146 IF(N1(N))2201,147,1465
1465 N=N+1
147 N1(N)=5
GO TO (138,148),NTIMES
148 IF(MFREQ(I,7))905,149,138
149 IF(N1(N))2201,1495,1493
1493 N=N+1
1495 N1(N)=7
GO TO 138
150 IF(MFREQ(I,1))905,151,152
151 N1(N)=1
GO TO (138,152),NTIMES
152 IF(MFREQ(I,2))905,153,155
153 IF(N1(N))2201,154,1535
1535 N=N+1
154 N1(N)=2
GO TO (138,155),NTIMES
155 IF(MFREQ(I,4))905,1555,157
1555 IF(N1(N))2201,156,1557
1557 N=N+1
156 N1(N)=4
GO TO (138,157),NTIMES
157 IF(MFREQ(I,6))905,1575,148
1575 IF(N1(N))2201,1585,158
158 N=N+1
1585 N1(N)=6
GO TO (138,148),NTIMES
160 IF(JTIMES-5)1605,2201,2201
1605 IF(MFREQ(I,1))905,161,1615
161 N1(N)=1
GO TO (138,1615),NTIMES
1615 IF(MFREQ(I,2))905,162,163
162 IF(N1(N))2201,1627,1625
1625 N=N+1
1627 N1(N)=2
GO TO (138,163),NTIMES
163 IF(MFREQ(I,3)) 905,1635,1645
1635 IF(N1(N))2201,164,1637
1637 N=N+1
164 N1(N)=3
GO TO (138,1645),NTIMES
1645 IF(MFREQ(I,5))905,165,157
165 IF(N1(N))2201,1657,1655
1655 N=N+1
1657 N1(N)=5
GO TO(138,157),NTIMES
170 IF(JTIMES-6)1705,2201,2201
1705 IF(MFREQ(I,1))905,171,172
171 N1(N)=1
GO TO (138,172),NTIMES
172 IF(MFREQ(I,2))905,173,175
173 IF(N1(N))2201,174,1725
1725 N=N+1
174 N1(N)=2
GO TO (138,175),NTIMES
175 IF(MFREQ(I,3))905,1755,176
1755 IF(N1(N))2201,1757,1756
1756 N=N+1
1757 N1(N)=3
GO TO(138,176),NTIMES
176 IF(MFREQ(I,4))905,1765,1645
1765 IF(N1(N))2201,1769,1767
1767 N=N+1
1769 N1(N)=4
GO TO(138,1645),NTIMES
2201 K=0
DO 2210 L=1,7
KONTER(I,L)=MFREQ(I,L)
IF(MFREQ(I,L))905,2210,2205
2205 K=K+1
KOLHLD(K)=L
MFREQ(I,L)=0
2210 CONTINUE
INDEX2=I+LASTNO-NVAR
MTIMES=MVAR(I)
GO TO (940,2220,2230,2240,2250,2260,940),MTIMES
2220 LTIMES=1
L=KOLHLD(1)
IF(L-1)2225,2224,2225
2225 SCORE2=1.0
JJ=I
GO TO 5500
2224 MFREQ(I,1)=KONTER(I,1)
2226 L=KOLHLD(K)
IF(L-7)2227,2280,2227
2227 LTIMES=2
SCORE2=7.0
JJ=150+I
GO TO 5500
2230 LTIMES=3
L=KOLHLD(1)
IF(L-1)2225,2234,2225
2234 MFREQ(I,1)=KONTER(I,1)
2235 LTIMES=1
L=KOLHLD(2)
IF(L-4)2237,2238,2237
2237 SCORE2=4.0
JJ=75+I
GO TO 5500
2238 MFREQ(I,4)=KONTER(I,4)
GO TO 2226
2240 LTIMES=4
L=KOLHLD(1)
IF(L-1)2225,2244,2225
2244 MFREQ(I,1)=KONTER(I,1)
2245 LTIMES=5
L=KOLHLD(2)
IF(L-3)2246,2243,2246
2246 SCORE2=3.0
JJ=50+I
GO TO 5500
2243 MFREQ(I,3)=KONTER(I,3)
2247 LTIMES=1
L=KOLHLD(3)
IF(L-5)2248,2249,2248
2248 SCORE2=5.0
JJ=100+I
GO TO 5500
2249 MFREQ(I,5)=KONTER(I,5)
GO TO 2226
2250 LTIMES=6
L=KOLHLD(1)
IF(L-1)2225,2252,2225
2252 MFREQ(I,1)=KONTER(I,1)
2255 LTIMES=7
L=KOLHLD(2)
IF(L-2)2256,2253,2256
2256 SCORE2=2.0
JJ=25+I
GO TO 5500
2253 MFREQ(I,2)=KONTER(I,2)
2257 LTIMES=8
L=KOLHLD(3)
IF(L-4)2237,2254,2237
2254 MFREQ(I,4)=KONTER(I,4)
2258 L=KOLHLD(4)
2269 LTIMES=1
IF(L-6)2259,2251,2259
2259 SCORE2=6.0
JJ=125+I
GO TO 5500
2251 MFREQ(I,6)=KONTER(I,6)
GO TO 2226
2260 LTIMES=9
L=KOLHLD(1)
IF(L-1)2225,2261,2225
2261 MFREQ(I,1)=KONTER(I,1)
2265 LTIMES=10
L=KOLHLD(2)
IF(L-2)2256,2262,2256
2262 MFREQ(I,2)=KONTER(I,2)
2266 LTIMES=11
L=KOLHLD(3)
IF(L-3)2246,2263,2246
2263 MFREQ(I,3)=KONTER(I,3)
2267 LTIMES=12
L=KOLHLD(4)
IF(L-5)2248,2264,2248
2264 MFREQ(I,5)=KONTER(I,5)
2268 L=KOLHLD(5)
GO TO 2269
2280 MFREQ(I,7)=KONTER(I,7)
2285 DO 2290 L=1,7
KONTER(I,L)=0
2290 CONTINUE
211 RETURN
C
905 KOMPER=1
WRITE (6,4905)J,I
GO TO 211
C
910 KOMPER=1
WRITE (6,4910)I
GO TO 211
C
920 KOMPER=1
WRITE (6,4920)INDKOL
GO TO 211
C
930 INDEX1=INDKOL+1
NUMPGE=NUMPGE+1
WRITE (6,4950)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE,NCASE,NVAR
GO TO 2200
C
940 WRITE (6,4940)I,MVAR(I)
KOMPER=1
GO TO 211
C
950 MVAR(I)=KVAR(I)
GO TO 940
C
4905 FORMAT(1H0,6X,51HMACHINE ERROR. THE FREQUENCY OF OCCURRENCE OF SCO
1REI2,12H OF QUESTIONI3,37H IS NEGATIVE. PROGRAM CANNOT PROCEED.)
4910 FORMAT(1H04X52HMACHINE ERROR. THE TOTAL NUMBER OF PARTS TO QUESTIO
1NI3,54H IS GREATER THAN THAT READ IN. PROGRAM CANNOT PROCEED.)
4920 FORMAT(1H0,5X,52HMACHINE ERROR. AN INDEX WHICH SHOULD BE GREATER T
1HAN,I6,49H IS LESS THAN THIS VALUE. PROGRAM CANNOT PROCEED.)
4930 FORMAT(1H0,3X,36HTHE RESPONSES INDICATE THAT QUESTION,I3,9H HAS ON
1LY,I2,54H PARTS, WHEREAS THE CONTROL CARD INDICATES THAT IT HAS,I2
2,7H PARTS.//11X,98HTHE PROGRAM ASSUMES THE FORMER IS CORRECT AND P
3ROCEEDS FROM THERE. PLEASE CHECK THE RESPONSE CARD.)
4940 FORMAT(1H0, 50HMACHINE ERROR. THE NUMBER OF RESPONSES TO QUESTIO
1N,I3,58H SHOULD BE LESS THAN 7 BUT GREATER THAN 1. THE MACHINE HAS
2,I2,1H.)
4950 FORMAT(1H1,17H PROBLEM NUMBER ,A8,21X,19HCHANGE OF RESPONSES,15X,
12A6,I3,1H,,I5,3X,4HPAGE,I4/19X,23HNUMBER OF RESPONDENTS =,I5,22X,2
21HNUMBER OF VARIABLES =,I3//52X,6HSTEP 1)
4970 FORMAT(1H0,28X,32HTHE SCORE(S) NOT USED IS(ARE) --,5I4)
C
5500 LL=(L-1)*25+I
MFREQ(JJ,1)=KONTER(LL,1)
SCORE1=L
DO 5510 JJ=I,INDEX2,NVAR
IF(A(JJ)-SCORE1)5510,5505,5510
5505 A(JJ)=SCORE2
5510 CONTINUE
GO TO(2226,2285,2235,2245,2247,2255,2257,2258,2265,2266,2267,2268)
1,LTIMES
C
GO TO 211
END
CDECTER SUBROUTINE DECTER FOR GUTTMAN SCALES JUNE 15, 1967
SUBROUTINE DECTER
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
XQ(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),KONTER(2
X5,7),DUMMY3(5),DUMMY4(7),DUMMY5(9)
C
COMMON JOBNMB,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,MVAR,LASTNO,NVAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND
2,KOMPER,KORDER,INDTEM,DUMMY3,N1,N2,I,DUMMY4,KK,DUMMY5,INDEX3
C
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
1,(DUMMY1,MFREQ),(ERROR,KONTER)
C
DOUBLE PRECISION JB,JOBNMB,JBND,REF,REFLEK,SECMON,FRSTMO,BLANKS,
1BND
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
CFNDCMB SUBROUTINE FNDCMB FOR BMD04S,05S,AND 07S JUNE 15, 1967
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),KONTER(2
35,7),DUMMY3(7),DUMMY4(2)
C
COMMON JOBNMB,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,MVAR,LASTNO,NVAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND
2,KOMPER,KORDER,INDTEM,IDAY,IYEAR,NUMPGE,DUMMYZ,MAXLOC,N1,N2,I,
3DUMMY3,KK,DUMMY4,L1
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
1,(DUMMY1,MFREQ),(ERROR,KONTER)
DOUBLE PRECISION JB,JOBNMB,JBND,REF,REFLEK,SECMON,FRSTMO,BLANKS,
1BND
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
CMOVE SUBROUTINE MOVE FOR GUTTMAN SCALES PROGRAMS
CMOVE SUBROUTINE MOVE FOR GUTTMAN SCALES PRROGRAMS JUNE 15, 1967
SUBROUTINE MOVE(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
XQ(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),KONTER(2
X5,7),DUMMY3(5),DUMMY4(7),DUMMY5(9)
C
COMMON JOBNMB,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,MVAR,LASTNO,NVAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND
2,KOMPER,KORDER,INDTEM,DUMMY3,N1,N2,I,DUMMY4,KK,DUMMY5
C
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
1,(DUMMY1,MFREQ),(ERROR,KONTER)
DOUBLE PRECISION JB,JOBNMB,JBND,REF,REFLEK,SECMON,FRSTMO,BLANKS,
1BND
C
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
SAVE=A(INDEX1)
A(INDEX1)=A(I)
A(I)=SAVE
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
SAVE=RANKSM(INDEX1)
RANKSM(INDEX1)=RANKSM(INDEX2)
RANKSM(INDEX2)=SAVE
100 RETURN
END
CMOVFOR SUBROUTINE MOVFOR FOR GUTTMAN SCALES JUNE 15, 1967
CMOVFOR SUBROUTINE MOVFOR FOR GUTTMAN SCALE PROGRAMS
SUBROUTINE MOVFOR(M1,M2,KK)
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
XQ(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),KONTER(2
X5,7),DUMMY3(5),DUMMY4(7),DUMMY5(9)
C
COMMON JOBNMB,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,MVAR,LASTNO,NVAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND
2,KOMPER,KORDER,INDTEM,DUMMY3,N1,N2,I,DUMMY4,KKP,DUMMY5
C
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
1,(DUMMY1,MFREQ),(ERROR,KONTER)
DOUBLE PRECISION JB,JOBNMB,JBND,REF,REFLEK,SECMON,FRSTMO,BLANKS,
1BND
C
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
CORDER SUBROUTINE ORDER FOR BMD04S,05S AND07S JUNE 15, 1967
SUBROUTINE ORDER
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)
COMMON JOBNMB,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,MVAR,LASTNO,NVAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND
2,KOMPER,KORDER,INDTEM,IDAY,IYEAR,NUMPGE,DUMMYZ,MAXLOC,N1,N2
EQUIVALENCE(A,INDIVD,KOLSKR,HOLDA,RANKSM),(INV,LVAR),(HOLD,KOLHLD)
C
DOUBLE PRECISION JB,JOBNMB,JBND,REF,REFLEK,SECMON,FRSTMO,BLANKS,
1BND
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
CORQUES SUBROUTINE ORQUES FOR BMD04S, 05S,07S, AND 08S JUNE 15,1967
SUBROUTINE ORQUES
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)
COMMON JOBNMB,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,MVAR,LASTNO,NVAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND
2,KOMPER,KORDER,INDTEM,IDAY,IYEAR,NUMPGE,DUMMYZ,MAXLOC,N1,N2
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
DOUBLE PRECISION JB,JOBNMB,JBND,REF,REFLEK,SECMON,FRSTMO,BLANKS,
1BND
KK=NVAR+1
C
JJ=INDKOL+1
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 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
CREAD SUBROUTINE READ FOR BMD05S JUNE 15,1967
SUBROUTINE READ(REF)
C
DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),REF(25),HOLD(26),MFRE
2Q(25,8),ERROR(25,7),MVAR(25),N1(25),N2(25),NCOMB(25),DUMMY1(200),K
3ONTER(25,7),DUMMY3(1),FMT(120)
COMMON JOBNMB,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,MVAR,LASTNO,NVAR,INDRNK,INDKOL,ISCALE,LESTN,LEAVE,IERROR,KANEND
2,KOMPER,KORDER,INDTEM,IDAY,IYEAR,NUMPGE,DUMMYZ,MAXLOC,N1,N2,I,LAST
3RD,NDREDK,DUMMY3,IFINAL,ILAST,IFIRST,IXTRA,KK
C
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
1,(DUMMY1,MFREQ),(ERROR,KONTER,FMT),(JBND,BND),(YES,IYES)
C
DOUBLE PRECISION FNSHE
DOUBLE PRECISION JB,JOBNMB,JBND,REF,REFLEK,SECMON,FRSTMO,BLANKS,
1 BND
DOUBLE PRECISION RFG,PROB,RESP,RELIC
DOUBLE PRECISION AJAN,UARY,FEBR,RUARY,AMAR,APR,AMAY,AJUNE,AJULY,
1AUGUST,SEPT
DOUBLE PRECISION TEMB,OCT,OMBER,ANOV,AMBER,DEC,EMBER
DOUBLE PRECISION OMEGA
DATA OMEGA/6HTHETA /
DATA BLANKS/8H /
DATA AJAN,UARY,FEBR/8H J,8HANUARY ,8H FE/
DATA RUARY,AMAR,APR/8HBRUARY ,8H MARCH ,8H APRIL /
DATA AMAY,AJUNE,AJULY/8H MAY ,8H JUNE ,8H JULY /
DATA AUGUST,SEPT,TEMB/8HAUGUST ,8H SEP,8HTEMBER /
DATA OCT,OMBER,ANOV/8H O,8HCTOBER ,8H NO/
DATA AMBER,DEC,EMBER/8HVEMBER ,8H DE,8HCEMBER /
DATA PROB/8HPROBLM /
DATA RESP/8HRESPON /
DATA RELIC/8HRFLECT /
DATA RFG/8HR /
DATA AFFR/4HYES /
DATA FNSHE/8HFINISH /
OMEGA=BLANKS
BND=FNSHE
REFLEK=RFG
YES=AFFR
C
IF(IDAY)4,5,5
4 NTAPE=5
5 READ (5,1000)JB,JOBNMB,IMON,IDAY,IYEAR,NVAR,NCASE,INVERS,ISCALE,IE
1RROR,IFINAL,ILAST,IXTRA,MTAPE,MATVAR
KOMPER=0
10 IF(JB.EQ.JBND) GO TO 999
15 IF(JB.NE.PROB) GO TO 955
155 READ (5,1001)JB,(KVAR(J),J=1,NVAR)
IF(JB.NE.RESP) GO TO 955
158 LASTNO=NVAR*NCASE
MAXLOC=8000-NCASE-NCASE-NCASE-NCASE
IF(LASTNO-MAXLOC)16,16,900
16 INDRNK=LASTNO+NCASE
INDKOL=INDRNK+NCASE
INDTEM=INDKOL+NCASE
INDIDV=LASTNO
IF(MTAPE)18,18,184
18 MTAPE=5
GO TO 7
C
184 IF(MTAPE-5)185,7,185
185 IF(MTAPE-6)186,966,186
186 REWIND MTAPE
7 IF(MTAPE-NTAPE)187,8,187
187 IF(NTAPE-5)188,189,188
188 CALL REMOVE(NTAPE)
189 NTAPE=MTAPE
C
C CONVERT DATE
C
8 GO TO(2010,2020,2030,2040,2050,2060,2070,2080,2090,2100,2110,2120)
1,IMON
2010 FRSTMO=AJAN
SECMON=UARY
GO TO 2130
C
2020 FRSTMO=FEBR
SECMON=RUARY
GO TO 2130
C
2030 FRSTMO=BLANKS
SECMON=AMAR
GO TO 2130
C
2040 FRSTMO=BLANKS
SECMON=APR
GO TO 2130
C
2050 FRSTMO=BLANKS
SECMON=AMAY
GO TO 2130
C
2060 FRSTMO=BLANKS
SECMON=AJUNE
GO TO 2130
C
2070 FRSTMO=BLANKS
SECMON=AJULY
GO TO 2130
C
2080 FRSTMO=BLANKS
SECMON=AUGUST
GO TO 2130
C
2090 FRSTMO=SEPT
SECMON=TEMB
GO TO 2130
C
2100 FRSTMO=OCT
SECMON=OMBER
GO TO 2130
C
2110 FRSTMO=ANOV
SECMON=AMBER
GO TO 2130
C
2120 FRSTMO=DEC
SECMON=EMBER
2130 IYEAR=IYEAR+1900
NOIN=1
DO 19 J=1,NVAR
IF(KVAR(J)-1)935,935,17
17 IF(KVAR(J)-7)19,19,935
19 CONTINUE
20 IF(INVERS-IYES)26,25,26
25 READ (5,1001)JB,(INV(J),J=1,NVAR)
IF(JB.NE.RELIC) GO TO 955
255 NOIN=2
26 MAX=0
30 CALL VFCHCK(MATVAR)
33 MATVAR=MATVAR*18
35 READ (5,1002)(FMT(J),J=1,MATVAR)
40 MIN=MAX+1
MAX=MAX+NVAR
INDIDV=INDIDV+1
43 IF(MIN-LASTNO)45,45,165
45 READ (NTAPE,FMT)INDIVD(INDIDV),(A(I),I=MIN,MAX)
DO 150 J=1,NVAR
INDEX=MIN+J-1
GO TO (65,64),NOIN
64 IF(INV(J))70,65,70
65 NOINV=1
GO TO 76
C
70 NOINV=2
76 IF(A(INDEX))925,110,77
77 VAR=KVAR(J)
IF(A(INDEX)-VAR)775,775,910
775 GO TO (79,78),NOINV
78 A(INDEX)=VAR+1.0-A(INDEX)
79 NPARTS=KVAR(J)
N1(1)=A(INDEX)
N11=N1(1)
791 GO TO(935,80,85,90,95,100,105),NPARTS
80 GO TO (117,111),N11
C
85 GO TO (117,114,111),N11
C
90 GO TO (117,115,113,111),N11
C
95 GO TO (117,116,114,112,111),N11
C
100 GO TO (117,116,115,113,112,111),N11
C
105 GO TO (117,116,115,114,113,112,111),N11
C
110 L=8
SCORE=0.0
GO TO 120
C
111 SCORE=1.0
L=1
GO TO 120
C
112 SCORE =2.0
L=2
GO TO 120
C
113 SCORE=3.0
L=3
GO TO 120
C
114 SCORE=4.0
L=4
GO TO 120
C
115 SCORE=5.0
L=5
GO TO 120
C
116 SCORE=6.0
L=6
GO TO 120
C
117 SCORE=7.0
L=7
120 A(INDEX)=SCORE
MFREQ(J,L)=MFREQ(J,L)+1
150 CONTINUE
160 GO TO 40
C
165 DO 168 L=1,NVAR
IF(-(INV(L)))166,167,167
166 REF(L)=REFLEK
GO TO 1675
C
167 REF(L)=BLANKS
1675 LVAR(L)=L
168 CONTINUE
171 N1(1)=0
IF(NTAPE-5)172,173,172
172 REWIND NTAPE
173 RETURN
C
900 KANEND=2
NEWKAS=NCASE
901 NEWKAS=NEWKAS-1
MAXLOC=MAXLOC+4
LASTNO=LASTNO-NVAR
IF(LASTNO-MAXLOC)902,902,901
902 WRITE (6,4900)NEWKAS,NCASE
NCASE=NEWKAS
GO TO 16
C
910 WRITE (6,4910)J,INDIVD(INDIDV)
KOMPER=1
GO TO 150
C
925 I=(MAX-1)/NVAR
WRITE (6,4925)I,J
KOMPER=1
GO TO 150
C
935 KOMPER=1
WRITE (6,4935)J,KVAR(J)
KANEND=2
GO TO 150
C
955 WRITE (6,4955)
GO TO 999
C
966 WRITE (6,4966)
999 KOMPER=99
GO TO 173
C
1000 FORMAT(2A6,I3,2I2,I3,I5,6A3,23X2I2)
1001 FORMAT(A6,25I2)
1002 FORMAT(18A4)
4900 FORMAT(1H1,30X,57HMAXIMUM DATA STORAGE EXCEEDED. SCALE WILL BE COM
1PUTED FOR,I4,17H CASES INSTEAD OF,I4,7H CASES.)
4910 FORMAT(1H0,8HQUESTION,I3,14H OF RESPONDENT,I5,14H IS TOO LARGE.)
4925 FORMAT(1H0,33X,37HNEGATIVE SCORE READ IN FOR RESPONDENT,I5,8HQUEST
1ION,I3)
4935 FORMAT(1H0,9X,47HTHERE MUST BE AT LEAST 2 RESPONSES FOR QUESTION,I
13,52H BUT NO MORE THAN 7. PLEASE CHECK THE RESPONSE CARD.)
4955 FORMAT(1H1,32X,52HCONTROL CARDS OUT OF ORDER. PROGRAM CANNOT CONTI
1NUE.)
4966 FORMAT(1H038X42HTAPE NUMBER IN ERROR. JOB CANNOT CONTINUE.)
C
END
SUBROUTINE REMOVE(N)
REWIND N
RETURN
END
CREORDR SUBROUTINE REORDR FOR BMD05S JUNE 15, 1967
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),KONTER(2
35,7)
COMMON JOBNMB,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,MVAR,LASTNO,NVAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND
2,KOMPER,KORDER,INDTEM,IDAY,IYEAR,NUMPGE,DUMMYZ,MAXLOC,N1,N2,I
C
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
1,(DUMMY1,MFREQ),(ERROR,KONTER)
C
DOUBLE PRECISION JB,JOBNMB,JBND,REF,REFLEK,SECMON,FRSTMO,BLANKS,
1BND
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 NMON=INDRNK-INDXT1+1
IF (NMON.GT.128) GO TO 1000
WRITE(IT2)(INDIVD(J),J=INDXT1,INDRNK)
GO TO 1001
1000 NMON=(NMON+127)/128
IF (NMON.LE.1) GO TO 1003
DO 1002 J=1,NMON-1
N300=(J-1)*128+INDXT1
N301=J*128+INDXT-1
1002 WRITE(IT2)(INDIVD(N302),N302=N300,N301)
1003 N300=(NMON-1)*128+INDXT1
WRITE(IT2)(INDIVD(N302),N302=N300,INDRNK)
1001 END FILE IT2
306 GO TO (307,308),IREADT
307 NMON=INDXT2-JRNK+1
IF (NMON.GT.128) GO TO 2000
WRITE(IT3)(RANKSM(J),J=JRNK,INDXT2)
GO TO 2001
2000 NMON=(NMON+127)/128
IF (NMON.LE.1) GO TO 2003
DO 2002 J=1,NMON-1
N300=(J-1)*128+JRNK
N301=J*128+JRNK-1
2002 WRITE(IT3)(RANKSM(N302),N302=N300,N301)
2003 N300=(NMON-1)*128+JRNK
WRITE(IT3)(RANKSM(N302),N302=N300,INDXT2)
2001 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 NMON=INDRNK-INDXT1+1
IF (NMON.GT.128) GO TO 1050
READ(IT2)(INDIVD(J),J=INDXT1,INDRNK)
GO TO 66
1050 NMON=(NMON+127)/128
IF (NMON.LE.1) GO TO 1053
DO 1052 J=1,NMON-1
N300=(J-1)*128+INDXT1
N301=J*128+INDXT1-1
1052 READ(IT2)(INDIVD(N302),N302=N300,N301)
1053 N300=(NMON-1)*128+INDXT1
READ(IT2)(INDIVD(J),J=N300,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 NMON=INDXT2-JRNK+1
IF (NMON.GT.128) GO TO 2050
READ(IT3)(RANKSM(J),J=JRNK,INDXT2)
GO TO 200
2050 NMON=(NMON+127)/128
IF (NMON.LE.1) GO TO 2052
DO 2051 J=1,NMON-1
N300=(J-1)*128+JRNK
N301=J*128+JRNK-1
2051 READ(IT3)(RANKSM(N302),N302=N300,N301)
2052 N300=(NMON-1)*128+JRNK
READ(IT3)(RANKSM(N302),N302=N300,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
9500 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
CVFCHCK SUBROUTINE TO CHECK FOR PROPER NUMBER OF VARIABLE FORMAT CRDS
SUBROUTINE VFCHCK(NVF)
IF(NVF)10,10,20
20 IF(NVF-10)50,50,10
10 WRITE (6,4000)
NVF=1
C
4000 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIF
1IED, ASSUMED TO BE 1.)
C
50 RETURN
END