Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/bmd/bmd06s.for
There is 1 other file named bmd06s.for in the archive. Click here to see a list.
CBMDO6S GUTTMAN SCALES NO. 2 - - PART 1 MAY 15,1967
DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
2Q(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2
37),KONTER(25,7),DUMMY3(1),KSTEP(6), KDUMY6(2),REF(25),NN1(6),NN2(6
4),NN3(6)
COMMON JOBNMB
COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,INDRNK,INDKOL,ISCALE,LESTN,LEAVE,IERROR,KANEND,KOMPER,KORDER,IN
2DTEM,IDAY,IYEAR,NUMPGE,JOYDEC,MAXLOC,N1,N2,DUMMY3,LASTRD,NDREDK,L,
3IFINAL,ILAST,IFIRST,IXTRA,KK,ICHNGE,NFIRST,L1,IEND,MCOMB,IPUNCH,NP
4ER,KDUMY6,INDEX3
C
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
1,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR
2),(ERROR,KONTER),(YES,IYES)
C
DOUBLE PRECISION DUMMY2,KDUMY6
DOUBLE PRECISION JOB,JOBNMB,JBND,REF,SECMON,FRSTMO,REFLEK,BLANKS,
1BND,JB
DATA AYES/4HYES /
C
4515 FORMAT(1H1,2X,65HBMD06S--GUTTMAN SCALE NUMBER 2, PART 1 - VERSION
1OF JULY 29, 1968 /
23X,40HHEALTH SCIENCES COMPUTING FACILITY, UCLA)
C BMD06S USES THE SUBROUTINE -- CONFORM -- FOUND IN BMD04S
C
C IF PRINT OUT OF THE SCORED INPUT DATA IN THE SAME ORDER AS THE
C FINAL SCALED DATA IS DESIRED, THEN AN ADDITIONAL TAPE UNIT,
C DESIGNATED IT1 HERE, IS NEEDED IN SUBROUTINE READ06.
C
C THIS PROGRAM REQUIRES A SAVE TAPE TO WRITE THE RESULTS OF THE
C PROGRAM UP TO THE POINT OF THE FIRST COMBINATIONS. THIS TAPE,
C DESIGNATED IT4 HERE, IS THEN USED BY BMD07S TO PERFORM
C ALL COMBINATIONS, DETERMINE THE GUTTMAN SCALE AND GIVE THE
C DESIRED OUTPUT.
C
C
IT4=4
CALL USAGEB('BMD06S')
REWIND IT4
C
YES=AYES
4 NUMPGE=0
KOMPER=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
WRITE (6,4515)
5 CALL READ06(REF(1))
IF(NVAR-25)165,165,900
165 IF(KOMPER)998,169,998
C
C PRINT DATA PROPERLY SCORED, IF DESIRED
C
169 IF (ISCALE.NE.IYES) GO TO 200
170 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
175 WRITE (6,4000)
WRITE (6,4504)NCASE,NVAR
WRITE (6,4505)
DO 172 J=1,NVAR
L=LVAR(J)
172 HOLD(J)=REF(L)
WRITE (6,4507)(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
180 WRITE (6,4001)INDIVD(INDIDV),(A(J),J=INDEX1,INDEX2)
267 CONTINUE
5050 MINPR=MINPR+50
IF(NDIFF)200 ,200 ,5010
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,700 ,998
700 J=INDTEM+NCASE
WRITE(IT4) J
WRITE(IT4) (REF(I),I=1,25)
NPOINT=(J+127)/128
IF (NPOINT.LE.1) GO TO 7772
DO 7771 JJ=1,NPOINT-1
NJ=(JJ-1)*128+1
NJJ=JJ*128
7771 WRITE(IT4)(A(JJJ),JJJ=NJ,NJJ)
7772 NJ=(NPOINT-1)*128+1
WRITE(IT4)(A(JJJ),JJJ=NJ,J)
DO 7773 JJ=1,4
NJ=(JJ-1)*128+1
NJJ=JJ*128
7773 WRITE(IT4)(LVAR(K),K=NJ,NJJ)
WRITE(IT4)(LVAR(K),K=513,558),INDEX3
WRITE(IT4) JOBNMB,(DUMMY2(I),I=1,27),FRSTMO,SECMON,(KDUMY6(J)
1,J=1,2)
END FILE IT4
REWIND IT4
998 STOP
C
900 WRITE (6,4015)NVAR
C
4000 FORMAT(1H ,38X,40HINPUT DATA AFTER RECEIVING PROPER SCORES)
4001 FORMAT(1H ,I8,7X,25F4.0)
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//43X,27HTH
2E PROGRAM WILL TERMINATE.)
4500 FORMAT(1H )
4503 FORMAT(1H1,15H PROBLEM NUMBER,2X,A6,57X,2A6,I3,1H,,I5,3X,4HPAGE,
1I4)
4504 FORMAT(1H ,18X,23HNUMBER OF RESPONDENTS =,I5,22X,21HNUMBER OF VARI
1ABLES =,I3)
4505 FORMAT(1H ,44X,22HVARIABLES OR QUESTIONS)
4507 FORMAT(1H ,11H RESPONDENT,4X,25(I3,A1))
C
GO TO 998
END
CCOMFRM SUBROUTINE CONFRM , REVISED FOR SYSTEM 360 ON MAY 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),DUMMY2(2
37),KONTER(25,7)
DOUBLE PRECISION JOB,JOBNMB,JBND,REF,SECMON,FRSTMO,REFLEK,BLANKS,
1BND,JB
DOUBLE PRECISION DUMMY2,KDUMY6
COMMON JOBNMB
COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN
2DTEM,IDAY,IYEAR,NUMPGE,JOYDEC,MAXLOC,N1,N2
C
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
1,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR
2),(ERROR,KONTER)
C
KORDER=0
C
M=INDKOL
DO 210 II=1,NVAR
I=LVAR(II)
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
CREADO6 SUBROUTINE READ06 , REVISED FOR SYSTEM 360 ON MAY 15,1967
C
SUBROUTINE READ06(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),D
3UMMY2(27),KONTER(25,7),DUMMY3(1),FMT(120)
C
COMMON JOBNMB
COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
1AR,INDRNK,INDKOL,ISCALE,LESTN,LEAVE,IERROR,KANEND,KOMPER,KORDER,IN
2DTEM,IDAY,IYEAR,NUMPGE,JOBDEX,MAXLOC,N1,N2,I,LASTRD,NDREDK,DUMMY3,
3IFINAL,ILAST,IFIRST,IXTRA,KK,ICHNGE,NFIRST,L1,IEND,MCOMB,IPUNCH,NP
4ER
C
EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(MDM,LVAR),(HOLD,KOLHLD)
1,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR
2),(ERROR,KONTER,FMT),(YES,IYES)
C
DOUBLE PRECISION JOB,JOBNMB,JBND,REF,SECMON,FRSTMO,REFLEK,BLANKS,
1BND,JB
DOUBLE PRECISION DUMMY2,KDUMY6
DOUBLE PRECISION AJAN,UARY,FEBR,RUARY,AMAR,APR,AMAY,AJUNE,AJULY,
1AUGUST,SEPT
DOUBLE PRECISION TEMB,OCT,OMBER,ANOV,AMBER,DEC,EMBER
DOUBLE PRECISION DLTE
DOUBLE PRECISION RFG,PROB,RESP,RELIC
DOUBLE PRECISION DELET
DOUBLE PRECISION PAN
C
C IF PRINT OUT OF THE SCORED INPUT DATA IN THE SAME ORDER AS THE
C FINAL SCALED DATA IS DESIRED, THEN AN ADDITIONAL TAPE UNIT,
C DESIGNATED IT1 HERE, IS NEEDED.
DATA PROB/8HPROBLM /
DATA RESP/8HRESPON /
DATA RELIC/8HRFLECT /
DATA DLTE/8HDELETE /
DATA RFG/8HR /
DATA BLANKS/8H /
DATA AFFR/4HYES /
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/
REFLEK=RFG
DUMMY2(1)=PROB
DUMMY2(2)=RESP
DUMMY2(3)=RELIC
DUMMY2(4)=DLTE
YES=AFFR
IT1=1
C
IT4=4
C
5 READ (5,1000)JB,JOBNMB,IMON,IDAY,IYEAR,NVAR,NCASE,INVERS,ISCALE,NF
1IRST,NPER,MCOMB,IEND,IFINAL,IERROR,LASTRD,NDREDK,ICHNGE,LEAVE ,LES
2TN,ILAST,IXTRA,IFIRST,IPUNCH,MATVAR,NTAPE,IDELET
KOMPER=0
15 IF(JB.NE.PROB) GO TO 955
152 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 IF(NTAPE)18,18,184
18 NTAPE=5
GO TO 188
C
184 IF(NTAPE-5)185,188,185
C
185 IF(NTAPE-IT1)186,975,186
186 IF(NTAPE-IT4)187,975,187
187 REWIND NTAPE
188 INDRNK=LASTNO+NCASE
INDKOL=INDRNK+NCASE
INDTEM=INDKOL+NCASE
INDIDV=LASTNO
DELET=BLANKS
IF(-IDELET)3,4,4
3 DELET=YES
4 WRITE (6,4980)JOBNMB,NVAR,LESTN,NCASE,INVERS,ISCALE,NFIRST,NPER,MC
1OMB,IEND
WRITE (6,4985)IFINAL,IERROR,ICHNGE,LEAVE,ILAST,IXTRA,IFIRST,IPUNCH
1,DELET
ASSIGN 153 TO KSKIP
IF (IFIRST.EQ.IYES) GO TO 7
6 IFIRST=2
GO TO 8
C
7 REWIND IT1
IFIRST=1
8 IF(-IDELET)1581,1655,1655
1581 READ (5,1003)JB,N3,N1(1),(N2(M),M=1,20)
IF(JB.NE.DLTE) GO TO 955
1582 ASSIGN 1525 TO ISKIP
IF(-N3)1583,1586,1584
1586 N3=NVAR
1583 ASSIGN 151 TO KSKIP
1584 IDELET=N1(1)
IF(-N1(1))1585,1655,1655
1585 ISAVE=IFIRST
IFIRST=1
IT2=IT1
IT1=IT4
REWIND IT1
C
C CONVERT DATE
C
1655 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.NE.IYES) GO TO 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)
DO 36 K=1,NVAR
36 LVAR(K)=K
JB=NCASE
WRITE (6,4002)NTAPE,(FMT(M),M=1,MATVAR)
GO TO(37,40),IFIRST
37 WRITE(IT1) (LVAR(M),M=1,NVAR)
40 MIN=MAX+1
MAX=MAX+NVAR
INDIDV=INDIDV+1
43 IF(MIN-LASTNO)45,45,165
45 READ (NTAPE,FMT)INDIVD(INDIDV),(A(M),M=MIN,MAX)
K=0
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
110 L=8
K=K+1
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
LL=L
MFREQ(J,LL)=MFREQ(J,LL)+1
150 CONTINUE
GO TO KSKIP,(151,153)
151 IF(N3-K)154,154,153
154 GO TO ISKIP,(1525,1530)
1525 ASSIGN 1530 TO ISKIP
WRITE (6,4000)N3,(LVAR(M),M=1,NVAR)
1530 WRITE (6,4001)INDIVD(INDIDV),(A(M),M=MIN,MAX)
LASTNO=LASTNO-NVAR
NCASE=NCASE-1
MM=MIN-1
DO 145 M=1,NVAR
MM=MM+1
IF(A(MM))141,143,141
141 N=A(MM)
GO TO 144
143 N=8
144 MN=LVAR(M)
145 MFREQ(MN,N)=MFREQ(MN,N)-1
GO TO 43
153 GO TO(155,40),IFIRST
155 NPOINT=MAX-MIN+1
IF (NPOINT.GT.127) GO TO 1555
WRITE(IT1)INDIVD(INDIDV),(A(M),M=MIN,MAX)
GO TO 40
1555 WRITE(IT1)INDIVD(INDIDV),(A(M),M=MIN,MIN+126)
NPOINT=(MAX-MIN+1)/128
NWED=MIN+126
IF (NPOINT.LE.1) GO TO 1556
DO 1557 M=1,NPOINT-1
NJ=(M-1)*128+NWED+1
NJJ=M*128+NWED
1557 WRITE(IT1)(A(JJJ),JJJ=NJ,NJJ)
1556 NJ=(NPOINT-1)*128+NWED+1
WRITE(IT1)(A(JJJ),JJJ=NJ,MAX)
160 GO TO 40
C
165 DO 168 L=1,NVAR
IF(-(INV(L)))166,167,167
166 REF(L)=REFLEK
GO TO 168
167 REF(L)=BLANKS
168 CONTINUE
IF(-IDELET)1681, 169,169
C DELETE UNWANTED VARIABLES
1681 NVAR1=NVAR-1
DO 1690 J=1,IDELET
L=N2(J)
DO 1683 K=1,NVAR
IF(LVAR(K)-L)1683,1684,1683
1683 CONTINUE
GO TO 945
1684 DO 1685 II=K,NVAR1
1685 LVAR(II)=LVAR(II+1)
LVAR(NVAR)=L
REF(NVAR)=SAVE
1690 CONTINUE
NVAR1=NVAR
NVAR=NVAR-IDELET
IF(-NVAR)169,945,945
169 II=INDRNK-IDINT(JB+.5D0)
LASTNO=NVAR*NCASE
INDRNK=LASTNO+NCASE
INDKOL=INDRNK+NCASE
INDTEM=INDKOL+NCASE
INDIDV=LASTNO
IF(NCASE-IDINT(JB+.5D0))1692,1691,1691
1692 INDEX=INDIDV
DO 1695 M=1,NCASE
INDEX=INDEX+1
II=II+1
1695 INDIVD(INDEX)=INDIVD(II)
1691 GO TO (170,171),IFIRST
170 END FILE IT1
REWIND IT1
1707 IF(IT1-IT4)171,1711,171
1711 IT1=IT2
IFIRST=ISAVE
WRITE (6,4901)IDELET,NVAR,NVAR1,(N2(M),M=1,IDELET)
INDEX=0
MAX=0
GO TO (1720,1723),IFIRST
1720 WRITE(IT1) (LVAR(M),M=1,NVAR)
1723 READ(IT4) (N1(M),M=1,NVAR1)
DO 1750 J=1,NCASE
INDIDV=INDIDV+1
READ(IT4) INDIVD(INDIDV),(HOLD(M),M=1,NVAR1)
DO 1725 K=1,NVAR
L=LVAR(K)
INDEX=INDEX+1
1725 A(INDEX)=HOLD(L)
GO TO(1730,1750),IFIRST
1730 MIN=MAX+1
MAX=MAX+NVAR
NPOINT=MAX-MIN+1
IF (NPOINT.GT.127) GO TO 1770
WRITE(IT1)INDIVD(INDIDV),(A(M),M=MIN,MAX)
GO TO 1750
1770 WRITE(IT1)INDIVD(INDIDV),(A(M),M=MIN,MIN+126)
NPOINT=(MAX-MIN+1)/128
NWED=MIN+126
IF (NPOINT.LE.1) GO TO 1771
DO 1772 M=1,NPOINT-1
NJ=(M-1)*128+NWED+1
NJJ=M*128+NWED
1772 WRITE(IT1)(A(JJJ),JJJ=NJ,NJJ)
1771 NJ=(NPOINT-1)*128+NWED+1
WRITE(IT1)(A(JJJ),JJJ=NJ,MAX)
1750 CONTINUE
GO TO(1760,1765),IFIRST
1760 END FILE IT1
REWIND IT1
1765 REWIND IT4
171 DO 1713 J=1,25
N1(J)=0
1713 N2(J)=0
IF(NCASE-JB)1705,1714,1705
1705 WRITE (6,4930)NCASE,JB
1714 IF(NTAPE-5)1715,173,172
1715 REWIND NTAPE
GO TO 173
172 CALL REMOVE(NTAPE)
173 RETURN
C
900 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)
GO TO 150
C
945 WRITE (6,4945)
GO TO 946
C
955 WRITE(6,4955)JB
946 KOMPER=1
GO TO 171
C
975 WRITE (6,4975)NTAPE
GO TO 946
C
8000 FORMAT(20A4)
1000 FORMAT(2A6,4I2,I5,3A3,I2,I3,3A3,I1,2I2,A3,I2,4A3,3I2)
1001 FORMAT(A6,25I2)
1002 FORMAT(18A4)
1003 FORMAT(A6,22I3)
C
4000 FORMAT(1H0,20X,22HTHESE RESPONDENTS HAVEI3,52H OR MORE NO RESPONSE
1S AND ARE DELETED FROM THE SCALE //2X,10HRESPONDENT,33X,9HRESPONSE
2S//14X,25I4//)
4001 FORMAT(1H ,3X,I6,5X,25F4.0)
4002 FORMAT(1H0,32X,26HDATA READ IN FROM BCD TAPEI3,27H UNDER THE FOLLO
1WING FORMAT,//(1X,30A4))
4900 FORMAT(1H1,30X,57HMAXIMUM DATA STORAGE EXCEEDED. SCALE WILL BE COM
1PUTED FOR,I4,17H CASES INSTEAD OF,I4,7H CASES.)
4901 FORMAT(1H0,17X,I3,38H QUESTIONS WERE DELETED. THERE ARE NOW,I3,39H
1 QUESTIONS WHERE, INITIALLY, THERE WERE,I3,1H./
26X,27HTHE QUESTIONS DELETED WERE 20I4)
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)
4930 FORMAT(1H0,29X,13HTHERE ARE NOW,I6,33H CASES WHERE INITIALLY THERE
1 WERE,I6,1H.)
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.)
4945 FORMAT(1H0,36X,45HERROR ON DELETE CARD. PROGRAM CANNOT PROCEED.)
4955 FORMAT(1H1,32X,52HCONTROL CARDS OUT OF ORDER. PROGRAM CANNOT CONTI
1NUE.,2X,A6)
4975 FORMAT(32X19HLOGICAL TAPE NUMBERI3,32H VIOLATES RESTRICTION FOR IN
1PUT.)
4980 FORMAT(1H0,15X,26H* * * PROBLEM CARD * * *//19H JOB IDENTIFICATI
1ON 17(1H.1X),A6/21H NUMBER OF QUESTIONS 16(1H.1X),I6/43H LEAST NUM
2BER OF QUESTIONS TO BE CONSIDERED 5(1H.1X),I6/17H NUMBER OF CASES
318(1H.1X),I6/19H REFLECTION DESIRED 17(1H.1X),3X,A3/27H PRINT WEIG
4HTED INPUT DATA 13(1H.1X),3X,A3/43H COMBINE WHEN FREQUENCY LESS TH
5AN N PERCENT 5(1H.1X),3X,A3/37H N FOR COMBINATION ABOVE (IN PERCEN
6T) 8(1H.1X),I6/31H NUMBER OF FORCED COMBINATIONS 11(1H.1X),I6/37H
7PROGRAM TO MAKE FURTHER COMBINATIONS 8(1H.1X),3X,A3)
4985 FORMAT(35H PRINT OUT RANKED DATA AT EACH STEP
1 9(1H.1X),3X,A3/31H PRINT OUT ERRORS AT EACH STE
2P 11(1H.1X),3X,A3/17H Q FOR RERANKING 18(1H.1X),I6/53H TERMINATE W
3HEN QUESTIONS HAVE, AT MOST, 3 RESPONSES 3X,A3/21H PRINT FINAL RAN
4KING 16(1H.1X),3X,A3/43H PRINT ORDERED RESPONDENTS AND SCALE SCORE
5 5(1H.1X),3X,A3/39H PRINT INITIAL RESPONSES IN FINAL ORDER 7(1H.1X
6),3X,A3/23H PUNCHED CARDS DESIRED 15(1H.1X),3X,A3/21H READ IN DELE
7TE CARD 16(1H.1X),3X,A3//)
END
C SUBROUTINE REMOVE
SUBROUTINE REMOVE(N)
REWIND N
RETURN
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