Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/bmd/bmd08s.for
There is 1 other file named bmd08s.for in the archive. Click here to see a list.
CBMD08S       GUTTMAN SCALES NUMBER 2, PART 3         AUGUST 14, 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),DUMMY2(2
     37),KONTER(25,7),DUMMY3(1),KSTEP(6), KDUMY6(2),REF(25),NN1(6),NN2(6
     4),NN3(6)
      COMMONJOBNMB
      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,FRSTMO,SECMON,JOBNMB,REF,KDUMY6
      DATA AYES/4HYES /
      IT1=1
	CALL USAGEB('BMD08S')
C
C     BMD08S USES THE FOLLOWING SUBROUTINES FOUND IN BMD04S,
C        DECTER        MOVE            ORQUES
C
C     BMD08S USES SUBROUTINE ASSIGN FOUND IN BMD05S.
C
C
C     THIS PROGRAM REQUIRES THE ADDITIONAL TAPE UNITS OF BMD06S, BMD07S.
C         IT1 AND IT4 ARE THE DESIGNATIONS USED HERE.  IT4 IS THE SAVE
C     TAPE WRITTEN BY BMD07S WITH ALL OF COMMON STORAGE WRITTEN ON IT.
C     IT1 IS USED ONLY IF THE INPUT DATA IS DESIRED PRINTED OUT WITH THE
C     INDIVIDUALS RANKED IN THE SAME ORDER AS THE FINAL SCALED RESULTS.
C     THIS TAPE WAS WRITTEN BY BMD06S.
C
      IT4=4
C
 4515 FORMAT('1BMD08S - GUTTMAN SCALE NUMBER 2, PART 3 - REVISED ',
     1'SEPTEMBER 24, 1968'/
     23X,40HHEALTH SCIENCES COMPUTING FACILITY, UCLA//)
C
      REWIND IT4
      READ(IT4) MAXERR,COFREP,FMINMR
      READ(IT4) (REF(I),I=1,25)
	DO 8000 I=1,4
	MON=(I-1)*128+1
	MONDAY=I*128
8000	READ(IT4)(LVAR(J),J=MON,MONDAY)
	READ(IT4)(LVAR(J),J=513,558),INDEX3
      READ(IT4)  JOBNMB,(DUMMY2(I),I=1,27),FRSTMO,SECMON,(KDUMY6(J)
     1,J=1,2)
      MAXPR=0
      DO 550 I=1,NCASE
      MINPR=MAXPR+1
      MAXPR=MAXPR+NVAR
	NPOINT=(MAXPR-MINPR+128)/128
	MON=MINPR-1
	IF (NPOINT.LE.1) GO TO 8888
	MOND=(J-1)*128+MON+1
	MONDAY=J*128+MON
8887	READ(IT4)(A(MONDA),MONDA=MOND,MONDAY)
8888	MOND=(NPOINT-1)*128+MON+1
	READ(IT4)(A(J),J=MOND,MAXPR)
 550  CONTINUE
      DO 575 I=1,4
      MINPR=MAXPR+1
      MAXPR=MAXPR+NCASE
	NPOINT=(MAXPR-MINPR+128)/128
	MON=MINPR-1
	IF (NPOINT.LE.1) GO TO 5550
	DO 5551 J=1,NPOINT-1
	MOND=(J-1)*128+MON+1
	MONDAY=(J-1)*128+MON
5551	READ(IT4)(A(MONDA),MONDA=MOND,MONDAY)
5550	MOND=(NPOINT-1)*128+MON+1
	READ(IT4)(A(J),J=MOND,MAXPR)
 575  CONTINUE
      REWIND IT4
      YES=AYES
      IFIRST=IFIRST
      WRITE (6,4515)
C
C     ASSIGN PROPER RESPONSES TO THE NO RESPONSE SCORES, COMPUTE THE
C     COEFFICIENT OF REPRODUCIBILITY, AND ASSIGN THE GUTTMAN SCALE SCORE
C
605   CALL ASSIGN
      IF(KOMPER)998,700,998
 700  IF(ILAST.NE.IYES) GO TO 760
 725  NTIMES=1
      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)
 327  WRITE (6,4500)
      DO 267 I=MINPR,MAXPR
      INDEX1=INDEX2+1
      INDEX2=INDEX2+NVAR
      JRNK=I+INDRNK
      INDIDV=I+LASTNO
 756  WRITE (6,4020)KOLSKR(JRNK),INDIVD(INDIDV),I,(A(J),J=INDEX1,INDEX2)
 267  CONTINUE
      GO TO 5050
C
C     MAKE FINAL PRINTOUT
C
 760  GO TO (765,800),IFIRST
 765  JJ=0
      REWIND IT1
      READ(IT1)(KVAR(I),I=1,NVAR)
      DO 770 I=1,NCASE
      INDEX1=LASTNO+I
      INDEX2=INDKOL+I
      INDIVD(INDEX2)=INDIVD(INDEX1)
      INDEXK=JJ+1
      JJ=JJ+NVAR
	NPOINT=JJ-INDEXK+1
	IF (NPOINT.GT.127) GO TO 7770
	READ(IT1)KOLSKR(INDEX1),(A(J),J=INDEXK,JJ)
	GO TO 770
7770	READ(IT1)KOLSKR(INDEX1),(A(J),J=INDEXK,INDEXK+126)
	MON=INDEXK+126
	NPOINT=(JJ-INDEXK+1)/128
	IF (NPOINT.LE.1) GO TO 7771
	DO 7772 J=1,NPOINT-1
	MOND=(J-1)*128+MON+1
	MONDAY=J*128+MON
7772	READ(IT1)(A(MONDA),MONDA=MOND,MONDAY)
7771	MOND=(NPOINT-1)*128+MON+1
	READ(IT1)(A(J),J=MOND,JJ)
 770  CONTINUE
      REWIND IT1
      DO 7755 J=1,NCASE
      JJ=INDKOL+J
 771  DO 773 I=J,NCASE
      IJJ=LASTNO+I
      IF(INDIVD(JJ)-INDIVD(IJJ))773,775,773
 773  CONTINUE
 775  CALL MVDATA(I,J)
 7755 CONTINUE
 776  NTIMES=2
      DO 7765 I=1,NVAR
      M=LVAR(I)
      MFREQ(M,7)=I
      LVAR(I)=KVAR(I)
 7765 CONTINUE
      CALL PROQES
      GO TO 5000
C
 777  WRITE (6,4513)
      GO TO 755
C
 800  IF(IXTRA.NE.IYES) GO TO 890
 805  ASSIGN 8105 TO KPUNCH
      ASSIGN 8125 TO KPNCH1
      IF(IPUNCH.EQ.IYES) GO TO 8051
 8055 ASSIGN 8115 TO KPUNCH
 8051 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  N1(1)=INDTEM+1
      N2(1)=N+1
      GO TO KPNCH1,(8125,8105)
 8125 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)
      NO1=N1(1)
      NO2=N2(1)
      WRITE(6,4026)(KOLSKR(I),I=NO1,NO2)
      GO TO KPUNCH,(8105,8115)
 8105 JJ=(N2(1)+1-N1(1))/2
      K=INDTEM-1
      DO 8110 J=1,JJ
      K=K+2
      PUNCH 4516,KOLSKR(K),KOLSKR(K+1),JOBNMB
 8110 CONTINUE
C
 8115 IF(L-NCASE)806,896,896
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(IPUNCH.NE.IYES) GO TO 892
 891  ASSIGN 8105 TO KPNCH1
      GO TO 8051
C
 892  IF(ILAST.EQ.IYES) GO TO 998
 895  ILAST=IYES
      IXTRA=0
      IFIRST=2
      IPUNCH=0
      GO TO 725
C
 896  IF(IXTRA.NE.IYES) GO TO 892
 998  STOP
C
 7000 FORMAT(10A8)
 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)
 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,45H, ONE OF THEM HAS BEEN ASSIGNED THE ID NUMBERI7,1H.)
 4500 FORMAT(1H )
 4503 FORMAT(1H1,15H PROBLEM NUMBER,A8,57X,2A6,I3,1H,,I5,3X,4HPAGE,I4)
 4504 FORMAT(1H ,18X,23HNUMBER OF RESPONDENTS =,I5,22X,21HNUMBER OF VARI
     1ABLES =,I3)
 4505 FORMAT(1H ,44X,22HVARIABLES OR QUESTIONS)
 4512 FORMAT(1H ,7HGUTTMAN/18H  SCALE RESP RANK ,25(I3,A1))
 4513 FORMAT(1H ,44X,20HORIGINAL SCORES WITH)
 4514 FORMAT(1H0,7X,7HGUTTMAN,7(8X,7HGUTTMAN)/2X,12HRESP.  SCALE,7(3X,12
     1HRESP.  SCALE)/9X,5HSCORE,7(10X,5HSCORE))
 4516 FORMAT(I6,I4,64X,A6)
C
 5000 MINPR=1
      MAXPR=0
      INDEX2=0
      NDIFF=NCASE
 5010 IF(NDIFF-50)5020,5020,5030
 5020 MAXPR=NCASE
      NDIFF=0
      GO TO 5040
C
 5030 MAXPR=MAXPR+50
      NDIFF=NDIFF-50
 5040 NUMPGE=NUMPGE+1
      WRITE (6,4503)JOBNMB,FRSTMO,SECMON,IDAY,IYEAR,NUMPGE
      GO TO (755,777),NTIMES
C
 5050 MINPR=MINPR+50
      IF(NDIFF)5060,5060,5010
 5060 IF(NTIMES-2) 760,800,9000
9000  GO TO 998
      END
CASSIGN       SUBROUTINE ASSIGN FOR BMDO8S            AUGUST 14, 1967
C
      SUBROUTINE ASSIGN
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),DUMMY7(7),DUMMY9(11)
      COMMONJOBNMB
      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,JOYCDA,MAXLOC,N1,N2,I,DUMMY7,KK,DUMMY9,INDE
     4X3
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
      DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,REF,KDUMY6
 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
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
      GO TO 760
      END
CORQUES  SUB ORQUES FOR BMD04S, 05S, 07S AND 08S       AUGUST 14, 1967
      SUBROUTINE PROQES
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)
      DIMENSION DUMMY2(27)
      COMMONJOBNMB
      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,JOYDSA,MAXLOC,N1,N2
      EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
      EQUIVALENCE (DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR)
      DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,REF,KDUMY6
      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
CMVDATA    SUBROUTINE MVDATA FOR GUTTMAN SCALE PROGRAMS   APRIL 15, 1967
CMVDATA       SUBROUTINE MVDATA FOR GUTTMAN SCALES PROGRAMS
      SUBROUTINE MVDATA(M1,M2)
      DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
     1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
     XQ(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2
     X7),KONTER(25,7),DUMMY3(5),DUMMY4(7),DUMMY5(11)
C
      EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
     X,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR
     X),(ERROR,KONTER)
C
      COMMON JOBNMB
      COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
     XAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN
     XDTEM,DUMMY3,N1,N2,I,DUMMY4,KK,DUMMY5
      DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,KDUMY6,REF,KCHECK
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
 100  RETURN
      END
CDECTER       SUBROUTINE DECTER FOR GUTTMAN SCALES  APRIL 15, 1967
      SUBROUTINE DECTER
C
      DIMENSION A(8000),RANKSM(8000),INDIVD(8000),KOLSKR(8000),HOLDA
     1(8000),KVAR(25),INV(25),LVAR(25),KOLHLD(25),N2 (25),HOLD(26),MFRE
     XQ(25,8),ERROR(25,7),MVAR(25),N1(25),NCOMB(25),DUMMY1(200),DUMMY2(2
     X7),KONTER(25,7),DUMMY3(5),DUMMY4(7),DUMMY5(11)
C
      EQUIVALENCE(A,RANKSM,INDIVD,KOLSKR,HOLDA),(INV,LVAR),(HOLD,KOLHLD)
     X,(DUMMY1,MFREQ),(DUMMY2,MVAR),(DUMMY2(26),LASTNO),(DUMMY2(27),NVAR
     X),(ERROR,KONTER)
      DOUBLE PRECISION DUMMY2,FRSTMO,SECMON,JOBNMB,REF
C
      COMMON JOBNMB
      COMMON DUMMY2,FRSTMO,SECMON,A,LVAR,MFREQ,ERROR,NCASE,HOLD,NCOMB,KV
     XAR,INDRNK,INDKOL,ISCALE,IRANK,IQUES,IERROR,KANEND,KOMPER,KORDER,IN
     XDTEM,DUMMY3,N1,N2,I,DUMMY4,KK,DUMMY5,INDEX3
C
      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