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