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