Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - 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