Google
 

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