Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
CBMDO4S REVISED FOR SYSTEM 360 ON APRIL 15, 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
XQ(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2
X7),KONTER(25,7),DUMMY3(1),DUMMY5(2),DUMMY6(6) ,REF(25)
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),(YES,IYES),(BND,JBND)
C
COMMON JOBNMB
COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
XAR,INDRNK,INDKOL,ISCALE,LESTN,LEAVE,IERROR,KANEND,KOMPER,KORDER,IN
XDTEM,IDAY,IYEAR,NUMPGE,JOYCEA,MAXLOC,N1,N2,DUMMY3,LASTRD,NDREDK,L,
XIFINAL,ILAST,IFIRST,NPER,KK,DUMMY5,L1,DUMMY6,INDEX3
DOUBLE PRECISION JOB,JOBNMB,JBND,REF
DOUBLE PRECISION SECMON,FRSTMO
DOUBLE PRECISION REFLEK
DOUBLE PRECISION DUMMY2
DOUBLE PRECISION BLANKS,BND
DOUBLE PRECISION FNSHE
DOUBLE PRECISION ZERO
C
DATA AP/4HANDP/
DATA ZERO/6H /
DATA FNSHE/8HFINISH /
DATA IYES/4HYES /
C
BP=AP
CALL USAGEB('BMD04S')
BND=FNSHE
BLANKS=ZERO
ILOV=0
4515 FORMAT(1H1,2X,65HBMD04S--GUTTMAN SCALE PREPROCESSOR - VERSION OF
XAPRIL 15, 1967 /
X3X,40HHEALTH SCIENCES COMPUTING FACILITY, UCLA)
IDAY=-25
4 NUMPGE=0
KOMPER=0
ITIMES=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
CALL REDPRE(BLANKS,JBND,REF)
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
KTIMES=1
GO TO 5000
C
175 WRITE(6,4000)
WRITE(6,4504)NCASE,NVAR
WRITE(6,4505)
WRITE(6,4506)KTIMES
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
201 IF(IFIRST.EQ.IYES) GO TO 2100
2011 IF(IERROR.EQ.IYES) GO TO 2015
GO TO 2009
2100 CALL FRSTCM(NPER)
IF(L-INDKOL) 2003,2003,430
2003 IF(KOMPER)998,2009,998
2009 IF(ILAST.NE.IYES) GO TO 465
2015 INDEX2=0
C
C RANK RESPONDENTS USING CORNELL TECHNIQUE
C
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
C
C REORDER THOSE INDIVIDUALS WITH THE SAME TOTAL SCORE
C
275 CALL REORDR
IF (KOMPER)998,276,998
276 IF(IFINAL.NE.IYES) GO TO 465
325 NTIMES=2
KTIMES=KTIMES+1
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),NTIMES
2665 WRITE(6,4003)I,INDIVD(INDIDV),RANKSM(JRNK),(A(J),J=INDEX1,INDEX2)
267 CONTINUE
GO TO 5050
C
430 KTIMES=KTIMES+1
450 NUMPGE=NUMPGE+1
WRITE(6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE
WRITE(6,4009)
449 WRITE(6,4014)NPER
451 WRITE(6,4504)NCASE,NVAR
WRITE(6,4506)KTIMES
452 WRITE(6,4510)
DO 457 J=1,NVAR
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 2100
C
C DETERMINE ERROR FOR FINAL COMPUTATIONS
C
465 KK=3
CALL DECTER
IF(IERROR.NE.IYES) GO TO 505
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
MAXERR=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
MAXERR=MAXERR+KOLHLD(I)
3877 CONTINUE
WRITE(6,4024)(KOLHLD(I),I=1,NVAR)
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
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 998
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
998 GO TO (4,999),KANEND
999 STOP
C
900 WRITE(6,4015)NVAR
IF(KOMPER-99)998,999,998
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
XDING 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
X1 TO 7 AND SCORE ZERO/7X,2HOR,44X,5HSCORE/4X,8HQUESTION,13X,1H1,9X
X,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
XF SCORE 7)
4009 FORMAT(1H ,45X,25HCOMBINATIONS IN QUESTIONS)
4010 FORMAT(1H0,I10,A1,I16,I17,5H AND,I3,I14,I8)
4012 FORMAT(1H ,42X,27HERRORS FOR EACH SCALE SCORE/50X,11HFINAL STEPS)
4014 FORMAT(1H0,31X,29HTHE FIRST SCORE HAS LESS THAN,I3,23H PERCENT OF
XRESPONDENTS)
4015 FORMAT(1H0,4X,89HTHE MAXIMUM NUMBER OF VARIABLES OR QUESTIONS ALLO
XWED IN THIS PROGRAM IS 25. YOU HAVE USED,I4,9H AND THUS//30X,53HTH
XE PROGRAM WILL GO TO THE NEXT PROBLEM OR TERMINATE.)
4016 FORMAT(1H ,34X,41HPOSSIBLE COMBINATIONS WHICH WILL INCREASE/25X,61
XHTHE 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)
4021 FORMAT(1H0,34X,35HMINIMAL MARGINAL REPRODUCIBILITY = ,F7.5)
4024 FORMAT(1H0,14H TOTAL ERROR ,25I4)
4500 FORMAT(1H )
4502 FORMAT(1H0//)
4503 FORMAT(1H1,15H PROBLEM NUMBER,2X,A8,57X,2A6,I3,1H,,I5,3X,4HPAGE,I4
1)
4504 FORMAT(1H ,18X,23HNUMBER OF RESPONDENTS =,I5,22X,21HNUMBER OF VARI
XABLES =,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))
4510 FORMAT(1H0,5X,8HQUESTION,6X,15HTOTAL NUMBER OF,6X,15HSCORES COMBIN
XED,6X,15HNUMBER OF PARTS/18X,19HCOMBINATIONS SO FAR,7X,9HTHIS TIME
X,9X,15HORIGINAL NOW)
4511 FORMAT(1H0,64X,8HDECREASE,15X,11HAPPROXIMATE/15X,8HQUESTION,15X,11
XHCOMBINATION,15X, 10HIN NUMBER,14X,11HINCREASE IN/64X,10HOF ERRO
XRS,12X,15HREPRODUCIBILITY)
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
C
5030 MAXPR=MAXPR+50
NDIFF=NDIFF-50
5040 NUMPGE=NUMPGE+1
WRITE(6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE
GO TO (175,326),NTIMES
C
5050 MINPR=MINPR+50
IF(NDIFF)5060,5060,5010
5060 GO TO (200,465),NTIMES
STOP
END
CCOMBIN SUBROUTINE COMBIN FOR BMDO4S,O5S ANDO7S APRIL 15, 1967
SUBROUTINE COMBIN(I,N1,N2)
C
DIMENSION DUMMY2(27)
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)
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
EQUIVALENCE(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR)
COMMON JOBNMB
COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
XAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER
DOUBLE PRECISION JOB,JOBNMB,JBND,REF
DOUBLE PRECISION SECMON,FRSTMO
C
DOUBLE PRECISION REFLEK
DOUBLE PRECISION DUMMY2
DOUBLE PRECISION BLANKS,BND
C
M=LVAR(I)
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
XITH I=,I3,7H N1(M)=,I3,7H N2(M)=,I3/10X,9H QUESTION,I3,9H HAS ONLY
X,I2,77H PARTS, WHEREAS IT MUST HAVE AT LEAST 3 PARTS IN ORDER TO H
XAVE A COMBINATION.)
4010 FORMAT(1H ,20X,54HMACHINE ERROR. UPON ENTRY TO SUBROUTINE COMBIN W
XITH I=,I3,7H N1(M)=,I3,7H N2(M)=,I3/22X,48H ONE OF THE FREQUENCIES
X OF RESPONSES TO QUESTION,I3,14H WAS NEGATIVE.)
END
CCONFRM SUBROUTINE CONFRM FOR BMDO4S APRIL 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
XQ(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2
X7),KONTER(25,7)
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,IDAY,IYEAR,NUMPGE,JYANML,MAXLOC,N1,N2
C
DOUBLE PRECISION JOB,JOBNMB,JBND,REF
DOUBLE PRECISION SECMON,FRSTMO
DOUBLE PRECISION REFLEK
DOUBLE PRECISION DUMMY2
DOUBLE PRECISION BLANKS,BND
KORDER=0
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
XREI2,12H OF QUESTIONI3,37H IS NEGATIVE. PROGRAM CANNOT PROCEED.)
4910 FORMAT(1H04X52HMACHINE ERROR. THE TOTAL NUMBER OF PARTS TO QUESTIO
XNI3,54H IS GREATER THAN THAT READ IN. PROGRAM CANNOT PROCEED.)
4920 FORMAT(1H0,5X,52HMACHINE ERROR. AN INDEX WHICH SHOULD BE GREATER T
XHAN,I6,49H IS LESS THAN THIS VALUE. PROGRAM CANNOT PROCEED.)
4930 FORMAT(1H0,3X,36HTHE RESPONSES INDICATE THAT QUESTION,I3,9H HAS ON
XLY,I2,54H PARTS, WHEREAS THE CONTROL CARD INDICATES THAT IT HAS,I2
X,7H PARTS.//11X,98HTHE PROGRAM ASSUMES THE FORMER IS CORRECT AND P
XROCEEDS FROM THERE. PLEASE CHECK THE RESPONSE CARD.)
4940 FORMAT(1H0, 50HMACHINE ERROR. THE NUMBER OF RESPONSES TO QUESTIO
XN,I3,58H SHOULD BE LESS THAN 7 BUT GREATER THAN 1. THE MACHINE HAS
X,I2,1H.)
4950 FORMAT(1H1,15H PROBLEM NUMBER,A8,21X,20HCHANGE OF RESPONSES,15X,2A
X6,I3,1H,,I5,3X,4HPAGE,I4/19X,23HNUMBER OF RESPONDENTS =,I5,22X,21H
XNUMBER 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)
X,LTIMES
C
GO TO 211
END
CDECTER SUBROUTINE DECTER FOR GUTTMAN SCALES APRIL 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),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,KK,DUMMY5,INDEX3
C
DOUBLE PRECISION JOB,JOBNMB,JBND,REF
DOUBLE PRECISION SECMON,FRSTMO
DOUBLE PRECISION DUMMY2
DOUBLE PRECISION REFLEK
DOUBLE PRECISION BLANKS,BND
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 BMDO4S,O5S AND O7S APRIL 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
XQ(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2
X7),KONTER(25,7),DUMMY3(7),DUMMY4(2)
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,IDAY,IYEAR,NUMPGE,JOECOR,MAXLOC,N1,N2,I,DUMMY3,KK,DUMMY4,L1
C
DOUBLE PRECISION JOB,JOBNMB,JBND,REF
DOUBLE PRECISION SECMON,FRSTMO
DOUBLE PRECISION DUMMY2
DOUBLE PRECISION REFLEK
DOUBLE PRECISION BLANKS,BND
11 DO 300 II=1,NVAR
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)
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)
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
XEGATIVE.)
4910 FORMAT(1H0,18X,59H* MACHINE ERROR* THE ERROR DUE TO A COMBINATION
XIN QUESTION,I3,13H RESULTS IN A/41X,29HNEGATIVE ERROR IN SUB FNDCM
XB.)
4915 FORMAT(1H0,12X,86H* MACHINE ERROR * SUBROUTINE FNDCMB WAS ENTERED
XWITH AN INCORRECT VALUE OF A CONSTANT.)
END
CFRSTCM SUBROUTINE FRSTCM FOR BMDO4S AND BMDO7S APRIL 15, 196
SUBROUTINE FRSTCM(NPER)
C
DIMENSION DUMMY2(27)
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(5),DUMMYX(3)
C
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
C
EQUIVALENCE(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR)
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,DUMMY1,N1,N2,DUMMYX,L
C
DOUBLE PRECISION JOB,JOBNMB,JBND,REF
DOUBLE PRECISION SECMON,FRSTMO
DOUBLE PRECISION DUMMY2
DOUBLE PRECISION REFLEK
DOUBLE PRECISION BLANKS,BND
MINPR=(NPER*NCASE+99)/100
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(I,J))75,75,15
15 IF(MFREQ(I,J)-MINPR)25,75,75
25 L=L+1
KOLSKR(L)=I+(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(MM)-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)
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
238 IF(MFREQ(MM,4)-MFREQ(MM,6))237,237,2235
C
237 N1(MM)=5
GO TO 212
C
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
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),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,KK,DUMMY5
DOUBLE PRECISION DUMMY2
DOUBLE PRECISION JOB,JOBNMB,JBND,REF
DOUBLE PRECISION SECMON,FRSTMO
DOUBLE PRECISION REFLEK
DOUBLE PRECISION BLANKS,BND
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
CORDER SUBROUTINE ORDER FOR BMD04S, 05S AND 07S APRIL 15,1967
SUBROUTINE ORDER
C
DIMENSION DUMMY2(27)
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)
EQUIVALENCE(A,INDIVD,KOLSKR,HOLDA,RANKSM),(INV,LVAR),(HOLD,KOLHLD)
EQUIVALENCE(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR)
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,IDAY,IYEAR,NUMPGE,JJLKMN,MAXLOC,N1,N2
C
DOUBLE PRECISION JOB,JOBNMB,JBND,REF
DOUBLE PRECISION SECMON,FRSTMO
DOUBLE PRECISION DUMMY2
DOUBLE PRECISION REFLEK
DOUBLE PRECISION BLANKS,BND
211 I=0
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 SUB ORQUES FOR BMD04S, 05S, 07S AND 08S APRIL 15,1967
SUBROUTINE ORQUES
C
DIMENSION DUMMY2(27)
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)
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
EQUIVALENCE(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR)
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,IDAY,IYEAR,NUMPGE,JJLKMR,MAXLOC,N1,N2
C
DOUBLE PRECISION JOB,JOBNMB,JBND,REF
DOUBLE PRECISION SECMON,FRSTMO
DOUBLE PRECISION DUMMY2
DOUBLE PRECISION REFLEK
DOUBLE PRECISION BLANKS,BND
KK=NVAR+1
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
CREDPRE SUBROUTINE REDPRE FOR BMD04S APRIL 15,1967
SUBROUTINE REDPRE(BLANKS,JBND,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
XQ(25,8),ERROR(25,7),MVAR(25),N1(25),N2(25),NCOMB(25),DUMMY1(200),D
XUMMY2(27),KONTER(25,7),DUMMY3(1),FMT(120)
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,FMT),(YES,IYES)
C
COMMON JOBNMB
COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
XAR,INDRNK,INDKOL,ISCALE,LESTN,LEAVE,IERROR,KANEND,KOMPER,KORDER,IN
XDTEM,IDAY,IYEAR,NUMPGE,JOYFOR,MAXLOC,N1,N2,I,LASTRD,NDREDK,DUMMY3,
XIFINAL,ILAST,IFIRST,NPER,KK
C
DOUBLE PRECISION JOB,JOBNMB,JBND,REF
DOUBLE PRECISION RFG,PROB,RESP,RELIC
DOUBLE PRECISION SECMON,FRSTMO
DOUBLE PRECISION DUMMY2
DOUBLE PRECISION REFLEK
DOUBLE PRECISION BLANKS,BND
DOUBLE PRECISION AJAN,UARY,FEBR,RUARY,AMAR,APR,AMAY,AJUNE,AJULY,
1AUGUST,SEPT
DOUBLE PRECISION TEMB,OCT,OMBER,ANOV,AMBER,DEC,EMBER
DOUBLE PRECISION PAN
DOUBLE PRECISION BAN
DATA PAN/6HABCDEF/
DATA AJAN,UARY,FEBR,RUARY/6H J,6HANUARY,6H FE,6HBRUARY/
DATA AMAR,APR,AMAY,AJUNE/6H MARCH,6H APRIL,6H MAY,6H JUNE/
DATA AJULY,AUGUST,SEPT,TEMB/6H JULY,6HAUGUST,6H SEP,6HTEMBER/
DATAOCT,OMBER,ANOV,AMBER/6H O,6HCTOBER,6H NO,6HVEMBER/
DATA DEC,EMBER/6H DE,6HCEMBER/
DATA PROB/8HPROBLM /
DATA RESP/8HRESPON /
DATA RELIC/8HRFLECT /
DATA RFG/8HR /
DATA AFFR/4HYES /
BAN=PAN
REFLEK=RFG
DUMMY2(1)=PROB
DUMMY2(2)=RESP
DUMMY2(3)=RELIC
YES=AFFR
IF(IDAY)4,5,5
4 NTAPE=5
5 READ(5,1000)JOB,JOBNMB,IMON,IDAY,IYEAR,NVAR,NCASE,INVERS,ISCALE,
XIFIRST,ILAST,IFINAL,IERROR,NPER,MTAPE,MATVAR
KOMPER=0
IF (JOB.EQ.JBND) GO TO 999
10 IF(JOB.NE.PROB) GO TO 955
15 READ(5,1001)JOB,(KVAR(J),J=1,NVAR)
IF(JOB.NE.RESP) GO TO 955
155 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)
X,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)JOB,(INV(J),J=1,NVAR)
IF(JOB.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)
60 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
946 KANEND=2
GO TO 171
C
955 WRITE(6,4955)
956 KOMPER=1
GO TO 946
C
966 WRITE(6,4966)
GO TO 956
C
999 KOMPER=99
GO TO 173
C
1000 FORMAT(2A6,I3,2I2,I3,I5,6A3,I2,21X2I2)
1001 FORMAT(A6,25I2)
1002 FORMAT(18A4)
4900 FORMAT(1H1,30X,57HMAXIMUM DATA STORAGE EXCEEDED. SCALE WILL BE COM
XPUTED 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
XION,I3)
4935 FORMAT(1H0,9X,47HTHERE MUST BE AT LEAST 2 RESPONSES FOR QUESTION,I
X3,52H BUT NO MORE THAN 7. PLEASE CHECK THE RESPONSE CARD.)
4955 FORMAT(1H1,34X48HCONTROL CARDS OUT OF ORDER. JOB CANNOT CONTINUE.)
4966 FORMAT(1H038X42HTAPE NUMBER IN ERROR. JOB CANNOT CONTINUE.)
C
END
SUBROUTINE REMOVE(N)
REWIND N
RETURN
END
CREORDR SUBROUTINE REORDR FOR BMDO4S APRIL 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
XQ(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2
X7),KONTER(25,7)
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,IDAY,IYEAR,NUMPGE,JBNMZR,MAXLOC,N1,N2,I
DOUBLE PRECISION JOB,JOBNMB,JBND,REF
DOUBLE PRECISION SECMON,FRSTMO
DOUBLE PRECISION DUMMY2
DOUBLE PRECISION REFLEK
DOUBLE PRECISION BLANKS,BND
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
IT2=2
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 1002
DO 1003 J=1,NMON-1
N430=(J-1)*128+INDXT1
N431=J*128+INDXT1-1
1003 WRITE(IT2)(INDIVD(N432),N432=N430,N431)
1002 N430=(NMON-1)*128+INDXT1
WRITE(IT2)(INDIVD(J),J=N430,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 2002
DO 2003 J=1,NMON-1
N430=(J-1)*128+JRNK
N431=J*128+JRNK-1
2003 WRITE(IT3)(RANKSM(N432),N432=N430,N431)
2002 N430=(NMON-1)*128+JRNK
WRITE(IT3)(RANKSM(J),J=N430,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 1060
READ(IT2)(INDIVD(J),J=INDXT1,INDRNK)
GO TO 66
1060 NMON=(NMON+127)/128
IF (NMON.LE.1) GO TO 1061
DO 1062 J=1,NMON-1
N430=(J-1)*128+INDXT1
N431=J*128+INDXT1-1
1062 READ(IT2)(INDIVD(N432),N432=N430,N431)
1061 N430=(NMON-1)*128+INDXT1
READ(IT2)(INDIVD(J),J=N430,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 1070
READ(IT3)(RANKSM(J),J=JRNK,INDXT2)
GO TO 200
1070 NMON=(NMON+127)/128
IF (NMON.LE.1) GO TO 1071
DO 1072 J=1,NMON-1
N430=(J-1)*128+JRNK
N431=J*128+JRNK-1
1072 READ(IT3)(RANKSM(N432),N432=N430,N431)
1071 N430=(NMON-1)*128+JRNK
READ(IT3)(RANKSM(J),J=N430,INDXT2)
9500 FORMAT(20A4)
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
4900 FORMAT(1H ,52X,13HMACHINE ERROR/30X,10HRESPONDENT,I5,39H WAS FOUND
X OUT OF ORDER IN SUB REORDER.)
4905 FORMAT(1H ,52X,13HMACHINE ERROR/29X,60HA COUNT WHICH SHOULD BE POS
XITIVE IN SUB REORDER IS NEGATIVE.)
C
END
CVFCHCK SUBROUTINE VFCHCK FOR BMDO4S APRIL 15, 1967
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
XIED, ASSUMED TO BE 1.)
C
50 RETURN
END
CMOVFOR SUBROUTINE MOVFOR FOR GUTTMAN SCALES APRIL 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),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
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