Ideal Point Talk -- D-NOMINATE, 1986-1989

LEGACY CONTENT. If you are looking for Voteview.com, PLEASE CLICK HERE

This site is an archived version of Voteview.com archived from University of Georgia on May 23, 2017. This point-in-time capture includes all files publicly linked on Voteview.com at that time. We provide access to this content as a service to ensure that past users of Voteview.com have access to historical files. This content will remain online until at least January 1st, 2018. UCLA provides no warranty or guarantee of access to these files.

PROGRAM TOHOU IMPLICIT HALF PRECISION (A-H,O-Z) REAL WK DIMENSION KB(1600),WK(9999),L4(100),D1NO(1000), CD1(40000),D2(9999),LLL(1000),D1YES(1000),XLEG1(40000), CMARKER(100,11),L1(9999),L2(9999),NSTATE(1000),LSAVE(40000), CNPARTY(1000),WTSQ(1000),B(10),KCALM(4),VVV(50), CYLMX(100),YLMN(100),D3(9999),D4(9999),LLLL(1000), CXLEG2(40000),ELIPSE(300),KDIV(50) CHARACTER KAA(9900,11),KDUMMY(9900,11) CHARACTER*80 TITLE BIT ISY,ISN,ISD,IS0(33000),IS1(33000),AY,AN,ANV,BY,BN,BNV, CIS2(1600),JSY,JSN,ISLEG,AH1,AH2,AH3,BH1,BH2,BH3,BH4,CH1,CH2, CDH1,IVYY,IVNN,IVNV,ISLEG2 DESCRIPTOR AY,AN,ANV,BY,BN,BNV,AH1,AH2,AH3,BH1,BH2,BH3,BH4, CCH1,CH2,DH1 COMMON /HUGE/ ISY(12000000),ISN(12000000),JSY(12000000), CJSN(12000000),ISLEG(989901),ISLEG2(989901) COMMON /HUGE2/ XI0(9999),XI1(9999),XI2(9999),XI3(9999), CZML(40000),DL(40000),L2P5RC(40000),LVTRC2(40000), CJLEG(33000,4),JRC(33000,3),XKEEP(9999,12),XEST(9999,3), CJJLEG(9999,5),DLMST(40000),ZMLMST(40000),XLGMST(33000), CJDUMMY(9999,5),JLEGA(40000,4),JRCA(33000,3),LDUMMY(33000), CZKEEP(40000,6),LKEEP(40000,3) COMMON /UTILS/ BETA(100),WTS(3),ICONST(3),MPOLY COMMON /KOFF/ XLEG(1000),IVYY(1000),IVNN(1000),IVNV(1000) COMMON /MSTR/ MASTER,MTOTCH,MPOOP, CXSPHI(50),XSYES(50),XSNO(50),KNOX(50) 1000 FORMAT(10I4) 1001 FORMAT(1X,I4,1X,I2) C1002 FORMAT(1X,I5,I2,1X,I2,1X,I4,12X,5(255I1),125I1) 1002 FORMAT(4X,I5,I2,1X,I2,1X,I4,12X,5(255I1),125I1) 1003 FORMAT(' TOTAL NO. LEGS=',I5,' NO. ACCEPTED=',I5, 1' TOTAL NO. VOTES=',I8) 1004 FORMAT(' NUMBER OF UNIQUE LEGISLATORS=',I5,3I9) C1005 FORMAT(6X,I5,I2,4X,I2,1X,I4,1X,11A1,F10.4) 1005 FORMAT(7X,I5,I2,4X,I2,1X,I4,1X,11A1,3F10.4) C1037 FORMAT(1X,I4,1X,I5,1X,I2,1X,I2,1X,I4,1X,11A1,1X,4F10.4) C1005 FORMAT(7X,I5,I2,1X,I2,1X,I2,1X,I4,1X,11A1,F10.4) C1005 FORMAT(5X,I4,1X,I5,1X,I2,1X,I2,1X,I1,1X,11A1,1X,F7.3) C1005 FORMAT(I5,I2,1X,I2,1X,I4,1X,11A1,3F10.4) 5001 FORMAT(1X,I5,I2,1X,I2,1X,I4,1X,11A1,3F10.4) 1006 FORMAT(I4,3X,10I6) C1007 FORMAT(I5,10F12.4) 1008 FORMAT(' STARTING POSITIONS--UNIQUE LEGISLATORS 1919-1984') 1009 FORMAT(' NUMBER OF STARTING LEGISLATORS READ=',2I6) 1010 FORMAT(8E12.4) 1011 FORMAT(1X,A) 1012 FORMAT(A) 1013 FORMAT(' DATA ',F10.6,1X,F10.6) 1014 FORMAT(10X,'0',5X,'1',5X,'2',5X,'3',5X,'4',5X,'5',5X,'6', C5X,'7',5X,'8',5X,'9') 1015 FORMAT(3I5,1X,11A1) 1016 FORMAT(' NUMBER OF LEGISLATORS NOT IN STARTING FILE=',I5) 1017 FORMAT(1X,I2,1X,I4) 1018 FORMAT(' NUMBER OF CONGRESSES=',I5) 1019 FORMAT(' TRANSP ',F10.6,1X,F10.6) 1020 FORMAT(' COUNTS OF YAYS AND NAYS',6I8) 1022 FORMAT(' NON0 RCS=',I7,' TOTAL YES=',I7,' TOTAL NO=',I7, C' TOTAL ERROR=',I7) 1023 FORMAT(' 2.5% RCS=',I7,' TOTAL YES=',I7,' TOTAL NO=',I7, C' TOTAL ERROR=',I7) 1021 FORMAT(' RECODE ',F10.6,1X,F10.6) 1024 FORMAT(' COUNTS OF LIB AND CONSV',6I8) 1025 FORMAT(' TOTAL ROLL CALLS 1919-1984=',I7) 1026 FORMAT(' TOTAL 2.5% LIB AND CONSV',3I8) 1027 FORMAT(1X,9I8) 1028 FORMAT(1X,I5,9F8.4) 1029 FORMAT(' TOTAL',9F8.4) 1030 FORMAT(' PARTIES',F10.6,1X,F10.6) 1031 FORMAT(1X,' CONG 2-PTY 3-PTY 40+ 2PY 40+ 3PY', C' 2PYCLEV PRP YES PRP MAJ 40+ SPA SPATIAL') 1032 FORMAT(6F6.2) 1033 FORMAT(10I2) 1034 FORMAT(1X,2I2,I3,I2,F6.1,F7.1,F12.3,F6.3,3F7.3/41X,3F7.3,3I5) 1035 FORMAT(' GEOMETRIC MEAN FOR',I7,' ROLL CALLS=',F9.5) 1036 FORMAT(' STARTING ESTIMATES OF LEGISLATOR COORDINATES') 1037 FORMAT(1X,I4,1X,I5,1X,I2,1X,I2,1X,I4,1X,11A1,1X,4F10.4) 1038 FORMAT(' GLOBAL ITERATION',3I3/' GEOMETRIC MEANS BY CONGRESS', C' MINIMUM AND MAXIMUM LEGISLATOR COORDINATES BY CONGRESS') 1039 FORMAT(1X,I4,F12.5,8F10.4) 1040 FORMAT(' TOTAL SENATORS SERVING ALL CONGRESSES=',2I7) 1041 FORMAT(' # OFF NEG END=',I5,' # OFF POS END=',I5,' OFF OPP=',I5) 1042 FORMAT(' GEOMETRIC MEAN FOR',I5,' SENATORS=',F9.5) 1043 FORMAT(1X,2I2,I3,I2,F6.1,F7.1,F12.3,F6.3,3F7.3,I5) 1044 FORMAT(' GEOMETRIC MEAN FOR',I8,' CHOICES=',F9.5) 1045 FORMAT(1X,2I2,I3,I2,F6.1,F7.1,F12.3,F6.3,3F7.3/41X,F7.3) 1046 FORMAT(' INDIVIDUAL IN STARTS TWICE',1X,I5,I2,1X,I2,1X,I4) 1047 FORMAT(' MISMATCH ON UNIQUE LEGISLATORS',2I7) 1048 FORMAT(' UNFOLD ',F10.6,1X,F10.6) 1049 FORMAT(' RESORT OF DATA: TOTAL VOTES=',I10,5X,'TOTAL LEGS=',2I5) 1050 FORMAT(' RESORT ',F10.6,1X,F10.6) 1051 FORMAT(1X,78('*')/1X,78('*')/1X,'ITERATION UNCONSTRAINED CONSTRAI CNED1 CONSTRAINEDALL'/1X,I5,6X,I9,5X,I7,5X,I10) 1058 FORMAT(' DISTRIBUTION OF ROLL CALLS BY MARGIN') 1059 FORMAT(26X,3I7) 1115 FORMAT(' PERCENTAGE PREDICTIONS--LEG-ALL VOTES 40% VOTES ALL'/ C3F12.5) 1222 FORMAT(1X,I2,1X,I5) 1224 FORMAT(80I1) 4444 FORMAT(' WARNING--MISMATCH',3I8) C C Q5MAPIN CALL -- THE LENGTH PARAMETER IS THE NUMBER OF 512 WORD C BLOCKS. TO CALCULATE, MULTIPLY HALF PRECISION C ARRAYS BY 1/2 AND DIVIDE BY 512; SIMPLY DIVIDE C FULL PRECISION ARRAYS BY 512. FOR HUGE COMMON C BLOCK THE FORMULA IS: C C 955 = (350000 X 1/2 +670 X 670 X 1/2 + 5700000 X 1/64)/512 C (ROUNDED UP) C CALL Q5OPEN('LFN=','HUGEFILE','IMP') CALL Q5MAPIN('LFN=','HUGEFILE','VBA=',ISY,'LEN=',1526, C'LPAGE') CALL Q5OPEN('LFN=','HUGEFILF','IMP') CALL Q5MAPIN('LFN=','HUGEFILF','VBA=',XI0,'LEN=',2217, C'LPAGE') C C SET START TIME C ATIME=SECOND() XI0(1;9999)=0.S0 XI1(1;9999)=0.S0 XI2(1;9999)=0.S0 XI3(1;9999)=0.S0 WK(1;9999)=0.0 ZML(1;40000)=0.S0 DL(1;40000)=0.S0 DLMST(1;40000)=0.S0 ZMLMST(1;40000)=0.S0 XLGMST(1;33000)=0.S0 XLEG(1;1000)=0.S0 XLEG1(1;40000)=0.S0 D1YES(1;1000)=0.S0 D1NO(1;1000)=0.S0 D1(1;40000)=0.S0 DO 202 JJ=1,6 ZKEEP(1,JJ;40000)=0.S0 IF(JJ.GT.3)GO TO 202 XEST(1,JJ;9999)=0.S0 LKEEP(1,JJ;40000)=0 202 CONTINUE DO 203 JJ=1,12 203 XKEEP(1,JJ;9999)=0.S0 C C READ IN CONTROL PARAMETERS C READ(4,1000)NS,NYRB,NBEGIN,NEND,IPRNT,NLAST,NEDITH,NMOM READ(4,1032)BETA(1),WTS(1;3),XCRIT READ(4,1033)ICONST(1;3),MPOLY READ(4,1012)TITLE WRITE(21,1011)TITLE WRITE(21,1000)NS,NYRB,NBEGIN,NEND,IPRNT,NLAST,NEDITH,NMOM WRITE(21,1032)BETA(1),WTS(1;3),XCRIT WRITE(21,1033)ICONST(1;3),MPOLY WRITE(22,1011)TITLE WRITE(23,1011)TITLE WRITE(25,1011)TITLE XBETA=BETA(1) BETA(1;100)=XBETA NOISE=133 I=0 535 READ(26,1017,END=435)(MARKER(I+1,J),J=1,2) IF(MARKER(I+1,1).LT.NBEGIN.OR.MARKER(I+1,1).GT. CNEND)GO TO 535 I=I+1 GO TO 535 435 WRITE(23,1018)I NCONG=I C C CONTENTS OF MARKER: COLUMN 1 = CONGRESS NUMBER C COLUMN 2 = TOTAL ROLL CALLS C COLUMN 3 = (NOT USED) C COLUMN 4 = (NOT USED) C COLUMN 5 = # LEGISLATORS FOR CONGRESS C COLUMN 6 = TOTAL CUMULATIVE VOTES BEFORE CONG C COLUMN 7 = # 2.5% ROLL CALLS C COLUMN 8 = # YAYS 2.5% ROLL CALLS C COLUMN 9 = # ERRORS 2.5% ROLL CALLS C COLUMN 10= TOTAL CHOICE 2.5% ROLL CALLS C COLUMN 11= TOTAL CUMULATIVE ROLL CALLS B4 CONG C C C READ IN MEL FILE--- THE FILE CONTAINS TWO RECORDS PER CASE WHERE C A "CASE" IS A SINGLE LEGISLATOR IN A PARTICULAR CONGRESS/YEAR. C THE FIRST RECORD FORMAT IS: 1X,I5,1X,I2,1X,3I4 ; WHERE THE C VARIABLES ARE THE ID#, THE CONG #, # VOTES CONG, C # VOTES YR 1, # VOTES YR 2. C ONLY THE CONGRESS AND THE TOTAL NUMBER OF VOTES ARE READ. C THE SECOND RECORD FORMAT IS: 1X,I5,1X,I2,1X,I2,1X,I1,1X,11A1,1400I1 C WHERE THE VARIABLES ARE THE ID#, THE CONG #, STATE, PARTY, C NAME, ROLL CALLS. C LLL(1;1000)=0 LLLL(1;1000)=0 IF(NOISE.EQ.133)GO TO 9112 KLEG=0 I=0 II=0 500 READ(11,1001,END=400)JRC(I+1,2),JRC(I+1,1) K1=JRC(I+1,2) READ(34,1222,END=400)J80S,J80ID READ(1,1002,END=400)(JLEG(I+1,JJ),JJ=1,4), C(KB(JJ),JJ=1,49) JRECRD=J80S-1 J80SUM=49 III=III+1 DO 1223 JJJ=1,JRECRD READ(1,1224,END=400)(KB(JJ+J80SUM),JJ=1,80) J80SUM=J80SUM+80 III=III+1 1223 CONTINUE IF(J80ID.NE.JLEG(I+1,1))WRITE(21,1027)I,II,J80ID,JLEG(I+1,1) IF(J80ID.NE.JLEG(I+1,1))STOP II=II+1 IF(JRC(I+1,1).LT.NBEGIN.OR.JRC(I+1,1).GT.NEND)GO TO 500 JRC(I+1,3)=KLEG ISY(KLEG+1;K1)=KB(1;K1).EQ.1.OR.KB(1;K1).EQ.2.OR.KB(1;K1).EQ.3 ISN(KLEG+1;K1)=KB(1;K1).EQ.4.OR.KB(1;K1).EQ.5.OR.KB(1;K1).EQ.6 KKA=Q8SCNT(ISY(KLEG+1;K1)) KKB=Q8SCNT(ISN(KLEG+1;K1)) IF(KKA+KKB.LT.25)GO TO 500 I=I+1 IF(JLEG(I,1).EQ.1056.AND.JLEG(I,2).EQ.2.AND.JLEG(I,3).EQ.3) CJLEG(I,1)=91056 IF(JLEG(I,1).EQ.5038.AND.JLEG(I,2).EQ.6.AND.JLEG(I,3).EQ.44) CJLEG(I,1)=95038 IF(JLEG(I,1).EQ.6058.AND.JLEG(I,2).EQ.15.AND.JLEG(I,3).EQ.5) CJLEG(I,1)=6052 IF(JLEG(I,1).EQ.3582.AND.JLEG(I,2).EQ.16.AND.JLEG(I,3).EQ.13) CJLEG(I,1)=93582 IF(JLEG(I,1).EQ.4709.AND.JLEG(I,2).EQ.21.AND.JLEG(I,3).EQ.12) CJLEG(I,1)=4706 IF(JLEG(I,1).EQ.6051.AND.JLEG(I,2).EQ.22.AND.JLEG(I,3).EQ.40) CJLEG(I,1)=6057 IF(JLEG(I,1).EQ.7724.AND.JLEG(I,2).EQ.22)JLEG(I,1)=7720 IF(JLEG(I,1).EQ.9674.AND.JLEG(I,2).EQ.24.AND.JLEG(I,3).EQ.24) CJLEG(I,1)=9679 IF(JLEG(I,1).EQ.2503.AND.JLEG(I,2).EQ.25)JLEG(I,1)=2502 IF(JLEG(I,1).EQ.7720.AND.JLEG(I,2).EQ.26)JLEG(I,1)=7724 IF(JLEG(I,1).EQ.4964.AND.JLEG(I,2).EQ.26.AND.JLEG(I,3).EQ.40) CJLEG(I,1)=4974 IF(JLEG(I,1).EQ.8164.AND.JLEG(I,2).EQ.26.AND.JLEG(I,3).EQ.12) CJLEG(I,1)=98164 IF(JLEG(I,1).EQ.7201.AND.JLEG(I,2).EQ.31.AND.JLEG(I,3).EQ.40) CJLEG(I,1)=97201 IF(JLEG(I,1).EQ.6178.AND.JLEG(I,2).EQ.32.AND.JLEG(I,3).EQ.71) CJLEG(I,1)=96178 IF(JLEG(I,1).EQ.7348.AND.JLEG(I,2).EQ.32.AND.JLEG(I,3).EQ.4) CJLEG(I,1)=97348 IF(JLEG(I,1).EQ.9049.AND.JLEG(I,2).EQ.33)JLEG(I,1)=99049 IF(JLEG(I,1).EQ.5208.AND.JLEG(I,2).EQ.33)JLEG(I,1)=95208 IF(JLEG(I,1).EQ.2914.AND.JLEG(I,2).EQ.33.AND.JLEG(I,3).EQ.51) CJLEG(I,1)=2913 IF(JLEG(I,1).EQ.3789.AND.JLEG(I,2).EQ.33.AND.JLEG(I,3).EQ.24) CJLEG(I,1)=3776 IF(JLEG(I,1).EQ.6044.AND.JLEG(I,2).EQ.33.AND.JLEG(I,3).EQ.43) CJLEG(I,1)=6094 IF(JLEG(I,1).EQ.2914.AND.JLEG(I,2).EQ.34.AND.JLEG(I,3).EQ.51) CJLEG(I,1)=2913 IF(JLEG(I,1).EQ.2416.AND.JLEG(I,2).EQ.35.AND.JLEG(I,3).EQ.3) CJLEG(I,1)=2411 IF(JLEG(I,1).EQ.8798.AND.JLEG(I,2).EQ.35)JLEG(I,1)=8797 IF(JLEG(I,1).EQ.10236.AND.JLEG(I,2).EQ.36)JLEG(I,1)=10231 IF(JLEG(I,1).EQ.1122.AND.JLEG(I,2).EQ.36.AND.JLEG(I,3).EQ.51) CJLEG(I,1)=1123 IF(JLEG(I,1).EQ.4291.AND.JLEG(I,2).EQ.36.AND.JLEG(I,3).EQ.24) CJLEG(I,1)=94291 IF(JLEG(I,1).EQ.4823.AND.JLEG(I,2).EQ.36.AND.JLEG(I,3).EQ.13) CJLEG(I,1)=94823 IF(JLEG(I,1).EQ.5941.AND.JLEG(I,2).EQ.36.AND.JLEG(I,3).EQ.51) CJLEG(I,1)=5940 IF(JLEG(I,1).EQ.7977.AND.JLEG(I,2).EQ.36.AND.JLEG(I,3).EQ.21) CJLEG(I,1)=7976 IF(JLEG(I,1).EQ.9600.AND.JLEG(I,2).EQ.36.AND.JLEG(I,3).EQ.47) CJLEG(I,1)=9601 IF(JLEG(I,1).EQ.2104.AND.JLEG(I,2).EQ.40.AND.JLEG(I,3).EQ.21) CJLEG(I,1)=2014 IF(JLEG(I,1).EQ.5062.AND.JLEG(I,2).EQ.40.AND.JLEG(I,3).EQ.51) CJLEG(I,1)=5063 IF(JLEG(I,1).EQ.7998.AND.JLEG(I,2).EQ.40.AND.JLEG(I,3).EQ.13) CJLEG(I,1)=7993 IF(JLEG(I,1).EQ.206.AND.JLEG(I,2).EQ.41.AND.JLEG(I,3).EQ.41) CJLEG(I,1)=1206 IF(JLEG(I,1).EQ.9032.AND.JLEG(I,2).EQ.41.AND.JLEG(I,3).EQ.52) CJLEG(I,1)=9104 IF(JLEG(I,1).EQ.6272.AND.JLEG(I,2).EQ.42)JLEG(I,1)=96272 IF(JLEG(I,1).EQ.5592.AND.JLEG(I,2).EQ.43.AND.JLEG(I,3).EQ.13) CJLEG(I,1)=8592 IF(JLEG(I,1).EQ.4096.AND.JLEG(I,2).EQ.44.AND.JLEG(I,3).EQ.3) CJLEG(I,1)=4097 IF(JLEG(I,1).EQ.662.AND.JLEG(I,2).EQ.45.AND.JLEG(I,3).EQ.13) CJLEG(I,1)=99662 IF(JLEG(I,1).EQ.9007.AND.JLEG(I,2).EQ.45.AND.JLEG(I,3).EQ.33) CJLEG(I,1)=9009 IF(JLEG(I,1).EQ.9894.AND.JLEG(I,2).EQ.46.AND.JLEG(I,3).EQ.31) CJLEG(I,1)=99894 IF(JLEG(I,1).EQ.7920.AND.JLEG(I,2).EQ.47.AND.JLEG(I,3).EQ.24) CJLEG(I,1)=97920 IF(JLEG(I,1).EQ.8346.AND.JLEG(I,2).EQ.47.AND.JLEG(I,3).EQ.41) CJLEG(I,1)=8436 IF(JLEG(I,1).EQ.8779.AND.JLEG(I,2).EQ.47.AND.JLEG(I,3).EQ.5) CJLEG(I,1)=8799 IF(JLEG(I,1).EQ.9894.AND.JLEG(I,2).EQ.49.AND.JLEG(I,3).EQ.31) CJLEG(I,1)=99894 IF(JLEG(I,1).EQ.9894.AND.JLEG(I,2).EQ.50.AND.JLEG(I,3).EQ.31) CJLEG(I,1)=99894 IF(JLEG(I,1).EQ.6697.AND.JLEG(I,2).EQ.50)JLEG(I,1)=6695 IF(JLEG(I,1).EQ.8900.AND.JLEG(I,2).EQ.50)JLEG(I,1)=8990 IF(JLEG(I,1).EQ.2084.AND.JLEG(I,2).EQ.50.AND.JLEG(I,3).EQ.49) CJLEG(I,1)=2141 IF(JLEG(I,1).EQ.2141.AND.JLEG(I,2).EQ.50.AND.JLEG(I,3).EQ.48) CJLEG(I,1)=2084 IF(JLEG(I,1).EQ.1323.AND.JLEG(I,2).EQ.51.AND.JLEG(I,3).EQ.24) CJLEG(I,1)=1322 IF(JLEG(I,1).EQ.3328.AND.JLEG(I,2).EQ.51)JLEG(I,1)=93328 IF(JLEG(I,1).EQ.3328.AND.JLEG(I,2).EQ.52)JLEG(I,1)=93328 IF(JLEG(I,1).EQ.1875.AND.JLEG(I,2).EQ.52.AND.JLEG(I,3).EQ.25) CJLEG(I,1)=91875 IF(JLEG(I,1).EQ.8991.AND.JLEG(I,2).EQ.53)JLEG(I,1)=8992 IF(JLEG(I,1).EQ.3734.AND.JLEG(I,2).EQ.53)JLEG(I,1)=93734 IF(JLEG(I,1).EQ.5580.AND.JLEG(I,2).EQ.53)JLEG(I,1)=95580 IF(JLEG(I,1).EQ.1441.AND.JLEG(I,2).EQ.56.AND.JLEG(I,3).EQ.64) CJLEG(I,1)=91441 IF(JLEG(I,1).EQ.5494.AND.JLEG(I,2).EQ.56.AND.JLEG(I,3).EQ.48) CJLEG(I,1)=5493 IF(JLEG(I,1).EQ.8706.AND.JLEG(I,2).EQ.59.AND.JLEG(I,3).EQ.49) CJLEG(I,1)=8705 IF(JLEG(I,1).EQ.542.AND.JLEG(I,2).EQ.60.AND.JLEG(I,3).EQ.14) CJLEG(I,1)=90542 IF(JLEG(I,1).EQ.3160.AND.JLEG(I,2).EQ.61)JLEG(I,1)=93160 IF(JLEG(I,1).EQ.9286.AND.JLEG(I,2).EQ.61.AND.JLEG(I,3).EQ.48) CJLEG(I,1)=9287 IF(JLEG(I,1).EQ.6778.AND.JLEG(I,2).EQ.61)JLEG(I,1)=6777 IF(JLEG(I,1).EQ.6636.AND.JLEG(I,2).EQ.62.AND.JLEG(I,3).EQ.14) CJLEG(I,1)=6640 IF(JLEG(I,1).EQ.272.AND.JLEG(I,2).EQ.62)JLEG(I,1)=2720 IF(JLEG(I,1).EQ.7365.AND.JLEG(I,2).EQ.63)JLEG(I,1)=7366 IF(JLEG(I,1).EQ.2177.AND.JLEG(I,2).EQ.63)JLEG(I,1)=2178 IF(JLEG(I,1).EQ.8504.AND.JLEG(I,2).EQ.64)JLEG(I,1)=8505 IF(JLEG(I,1).EQ.8604.AND.JLEG(I,2).EQ.65.AND.JLEG(I,3).EQ.13) CJLEG(I,1)=8605 IF(JLEG(I,1).EQ.5297.AND.JLEG(I,2).EQ.67)JLEG(I,1)=95297 IF(JLEG(I,1).EQ.3559.AND.JLEG(I,2).EQ.69)JLEG(I,1)=3558 IF(JLEG(I,1).EQ.542.AND.JLEG(I,2).EQ.80)JLEG(I,1)=1542 IF(JLEG(I,1).EQ.1723.AND.JLEG(I,2).EQ.82.AND.JLEG(I,3).EQ.21) CJLEG(I,1)=1722 IF(JLEG(I,1).EQ.2587.AND.JLEG(I,2).EQ.83)JLEG(I,1)=2588 IF(JLEG(I,1).EQ.2587.AND.JLEG(I,2).EQ.84)JLEG(I,1)=2588 IF(JLEG(I,1).EQ.2587.AND.JLEG(I,2).EQ.85)JLEG(I,1)=2588 IF(JLEG(I,1).EQ.10584.AND.JLEG(I,2).EQ.88.AND.JLEG(I,3).EQ.49) CJLEG(I,1)=20584 IF(JLEG(I,1).EQ.15125.AND.JLEG(I,2).EQ.99.AND.JLEG(I,3).EQ.51) CJLEG(I,1)=15228 C IF(JLEG(I,1).EQ.7343.AND.JLEG(I,2).EQ.99.AND.JLEG(I,3).EQ.51) C CJLEG(I,1)=15228 IF(JLEG(I,1).EQ.15096.AND.JLEG(I,2).EQ.99.AND.JLEG(I,3).EQ.71) CJLEG(I,1)=14414 NARK=JLEG(I,2)-NYRB DO 1 JJJ=1,10 IS0(1;K1)=KB(1;K1).EQ.JJJ-1 1 LLLL((NARK-1)*10+JJJ)=LLLL((NARK-1)*10+JJJ)+Q8SCNT(IS0(1;K1)) KLEG=KLEG+K1 C WRITE(33,3003)(JLEG(I,JB),JB=1,4),KB(1;K1) C 3003 FORMAT(1X,I5,I2,1X,I2,1X,I4,1X,5(255I1),125I1) GO TO 500 400 WRITE(23,1003)II,I,KLEG NP=I XXTIME=SECOND() XTIME=XXTIME-ATIME WRITE(21,1013)XTIME,XXTIME LDUMMY(1;NP)=1 KLEG=0 LLEG=0 MLEG=0 DO 989 I=1,NP IF(LDUMMY(I).EQ.0)GO TO 989 MLEG=MLEG+1 IS0(1;NP)=JLEG(I,1).EQ.JLEG(1,1;NP) WHERE(IS0(1;NP))LDUMMY(1;NP)=0 KYRS=Q8SCNT(IS0(1;NP)) L1(1;KYRS)=Q8VCMPRS(JRC(1,2;NP),IS0(1;NP);L1(1;KYRS)) L2(1;KYRS)=Q8VCMPRS(JRC(1,3;NP),IS0(1;NP);L2(1;KYRS)) LLL(1;KYRS)=Q8VCMPRS(JRC(1,1;NP),IS0(1;NP);LLL(1;KYRS)) WK(1;KYRS)=VREAL(LLL(1;KYRS);WK(1;KYRS)) L4(1)=1 L4(2)=2 KSUM=0 IF(KYRS.EQ.2.AND.LLL(1).GT.LLL(2))L4(1)=2 IF(KYRS.EQ.2.AND.LLL(1).GT.LLL(2))L4(2)=1 IF(KYRS.GT.2)CALL QSORT(KYRS,WK,L4) DO 970 J=1,KYRS KSUM=KSUM+IABS(L4(J)-J) 970 CONTINUE IF(KSUM.NE.0)WRITE(23,4443)JLEG(I,1),L4(1;KYRS) IF(KSUM.NE.0)WRITE(23,4443)JLEG(I,1),LLL(1;KYRS) 4443 FORMAT(I6,30I3) DO 988 J=1,KYRS JRCA(J+LLEG,1)=LLL(L4(J)) JRCA(J+LLEG,2)=L1(L4(J)) JRCA(J+LLEG,3)=KLEG NV=L1(L4(J)) NTV=L2(L4(J)) JSY(KLEG+1;NV)=ISY(NTV+1;NV) JSN(KLEG+1;NV)=ISN(NTV+1;NV) KLEG=KLEG+NV 988 CONTINUE DO 987 J=1,4 L1(1;KYRS)=Q8VCMPRS(JLEG(1,J;NP),IS0(1;NP);L1(1;KYRS)) DO 986 JJ=1,KYRS 986 JLEGA(JJ+LLEG,J)=L1(L4(JJ)) 987 CONTINUE LLEG=LLEG+KYRS 989 CONTINUE DO 985 I=1,4 JLEG(1,I;NP)=JLEGA(1,I;NP) IF(I.EQ.4)GO TO 985 JRC(1,I;NP)=JRCA(1,I;NP) 985 CONTINUE DO 984 I=1,NP NV=JRC(I,2) NTV=JRC(I,3) ISY(NTV+1;NV)=JSY(NTV+1;NV) 984 ISN(NTV+1;NV)=JSN(NTV+1;NV) WRITE(23,1049)KLEG,LLEG,MLEG C C CONTENTS OF JRC: COLUMN 1 = CONGRESS NUMBER C COLUMN 2 = TOTAL ROLL CALLS FOR THAT CONGRESS C COLUMN 3 = CUMULATIVE TOTAL OF ROLL CALLS C C CONTENTS OF JLEG: COLUMN 1 = ICPSR ID # C COLUMN 2 = CONGRESS NUMBER C COLUMN 3 = STATE C COLUMN 4 = PARTY C C WRITE(25,1014) C DO 2 J=1,NCONG C JJ=J+NYRB C 2 WRITE(25,1006)JJ,LLLL((J-1)*10+1;10) BTIME=SECOND() XTIME=BTIME-XXTIME WRITE(21,1050)XTIME,BTIME KKSUM=0 C ISEED=777777 C ISEED=666666 C ISEED=555555 I=0 525 READ(24,1005,END=425)(JJLEG(I+1,JJ),JJ=2,5),(KAA(I+1,JJ),JJ=1,11), C(XEST(I+1,JJ),JJ=1,NS) IS0(1;NP)=JLEG(1,1;NP).EQ.JJLEG(I+1,2) KK=Q8SCNT(IS0(1;NP)) IF(KK.EQ.0)GO TO 525 JJLEG(I+1,1)=KK KKSUM=KKSUM+KK I=I+1 C CALL RANGET(ISEED) C CALL RANSET(ISEED) C ISEED=ISEED+1 C CALL VRANF(WK,NS) C DO 93 JJ=1,NS C 93 XEST(I,JJ)=HALF(WK(JJ)) IF(I.LT.5)WRITE(21,1005)(JJLEG(I,JJ),JJ=2,5), C(KAA(I,JJ),JJ=1,11),(XEST(I,JJ),JJ=1,NS) L1(I)=I GO TO 525 425 WRITE(23,1009)I,KKSUM NPU=I NOISE=6099 C IF(NOISE.EQ.6099)STOP XI0(1;NPU)=XEST(1,1;NPU) XI1(1;NPU)=XEST(1,2;NPU) XI2(1;NPU)=XEST(1,3;NPU) KSTOPR=1 JXX=0 LDUMMY(1;NP)=1 DO 991 J=1,NP IF(LDUMMY(J).EQ.0)GO TO 991 IS0(1;NP)=JLEG(J,1).EQ.JLEG(1,1;NP) WHERE(IS0(1;NP))LDUMMY(1;NP)=0 IS1(1;NPU)=JLEG(J,1).EQ.JJLEG(1,2;NPU) KK=Q8SCNT(IS1(1;NPU)) IF(KK.EQ.0)WRITE(21,6888)(JLEG(J,JJ),JJ=1,4) IF(KK.EQ.0)KSTOPR=0 IF(KK.EQ.0)GO TO 991 IF(KK.GT.1)WRITE(21,1046)(JLEG(J,JJ),JJ=1,4) IF(KK.GT.1)STOP JXX=JXX+1 L2(1;1)=Q8VCMPRS(L1(1;NPU),IS1(1;NPU);L2(1;1)) JDUMMY(JXX,1;1)=Q8VCMPRS(JJLEG(1,1;NPU),IS1(1;NPU); CJDUMMY(JXX,1;1)) JDUMMY(JXX,2;1)=Q8VCMPRS(JJLEG(1,2;NPU),IS1(1;NPU); CJDUMMY(JXX,2;1)) JDUMMY(JXX,3;1)=Q8VCMPRS(JJLEG(1,3;NPU),IS1(1;NPU); CJDUMMY(JXX,3;1)) JDUMMY(JXX,4;1)=Q8VCMPRS(JJLEG(1,4;NPU),IS1(1;NPU); CJDUMMY(JXX,4;1)) JDUMMY(JXX,5;1)=Q8VCMPRS(JJLEG(1,5;NPU),IS1(1;NPU); CJDUMMY(JXX,5;1)) D2(JXX;1)=Q8VCMPRS(XI0(1;NPU),IS1(1;NPU);D2(JXX;1)) D3(JXX;1)=Q8VCMPRS(XI1(1;NPU),IS1(1;NPU);D3(JXX;1)) D4(JXX;1)=Q8VCMPRS(XI2(1;NPU),IS1(1;NPU);D4(JXX;1)) DO 993 JJ=1,11 993 KDUMMY(JXX,JJ)=KAA(L2(1),JJ) 991 CONTINUE IF(KSTOPR.EQ.0)STOP XI0(1;JXX)=D2(1;JXX) XI1(1;JXX)=D3(1;JXX) XI2(1;JXX)=D4(1;JXX) DO 994 J=1,11 DO 994 JJ=1,JXX 994 KAA(JJ,J)=KDUMMY(JJ,J) DO 992 J=1,5 992 JJLEG(1,J;JXX)=JDUMMY(1,J;JXX) IF(JXX.NE.NPU)WRITE(21,1047)JXX,NPU IF(JXX.NE.NPU)STOP XMAX=Q8SMAX(XI0(1;NPU)) XMIN=Q8SMIN(XI0(1;NPU)) XZ=(XMAX+XMIN)/2.S0 XS=1.S0/(XMAX-XZ) XI0(1;NPU)=XS*XI0(1;NPU)-XS*XZ XI1(1;NPU)=XS*XI1(1;NPU)-XS*XZ XI2(1;NPU)=XS*XI2(1;NPU)-XS*XZ WK(1;NPU)=VREAL(XI0(1;NPU);WK(1;NPU)) XEST(1,1;NPU)=XI0(1;NPU) XEST(1,2;NPU)=XI1(1;NPU) XEST(1,3;NPU)=XI2(1;NPU) XI1(1;NPU)=0.S0 XI2(1;NPU)=0.S0 CALL QSORT(NPU,WK,L1) C WRITE(22,1036) C DO 19 I=1,NPU C 19 WRITE(22,1037)(JJLEG(I,J),J=1,5),(KAA(I,J),J=1,11), C C(XEST(I,J),J=1,2) NOISE=6700 C IF(NOISE.EQ.6700)STOP C C CONTENTS OF JJLEG: COLUMN 1 = TOTAL # CONGRESSES FOR LEGISLATOR C COLUMN 2 = ICPSR ID # C COLUMN 3 = FIRST CONGRESS SERVED IN C COLUMN 4 = STATE C COLUMN 5 = PARTY C 6888 FORMAT(1X,I5,I2,1X,I2,1X,I4) KSUM=0 KTYES=0 KTNO=0 LTYES=0 LTNO=0 MARKER(1,6;100)=0 MARKER(1,11;100)=0 DO 4 II=1,NCONG IS0(1;NP)=JLEG(1,2;NP).EQ.NYRB+II KK=Q8SCNT(IS0(1;NP)) MARKER(II,5)=KK IF(II.EQ.1)MARKER(II,6)=0 IF(II.GT.1)MARKER(II,6)=MARKER(II-1,6)+MARKER(II-1,2)* CMARKER(II-1,5) IF(II.GT.1)MARKER(II,11)=MARKER(II-1,11)+MARKER(II-1,2) L1(1;KK)=Q8VCMPRS(JRC(1,2;NP),IS0(1;NP);L1(1;KK)) L2(1;KK)=Q8VCMPRS(JRC(1,3;NP),IS0(1;NP);L2(1;KK)) DO 5 J=1,KK L11=L1(J) L22=L2(J) IS1(1;L11)=ISY(L22+1;L11) IS2(1;L11)=ISN(L22+1;L11) DO 6 JJ=1,L11 JSY(KSUM+(JJ-1)*KK+J)=IS1(JJ) JSN(KSUM+(JJ-1)*KK+J)=IS2(JJ) 6 CONTINUE 5 CONTINUE KSUM=KSUM+KK*L11 4 CONTINUE DO 7 I=1,NP K1=JRC(I,2) K2=JRC(I,3) LTYES=LTYES+Q8SCNT(ISY(K2+1;K1)) LTNO=LTNO+Q8SCNT(ISN(K2+1;K1)) 7 CONTINUE DO 8 II=1,NCONG KSUM=MARKER(II,6) KK=MARKER(II,5) L11=MARKER(II,2) DO 9 JJ=1,L11 KTYES=KTYES+Q8SCNT(JSY(KSUM+(JJ-1)*KK+1;KK)) KTNO=KTNO+Q8SCNT(JSN(KSUM+(JJ-1)*KK+1;KK)) 9 CONTINUE 8 CONTINUE WRITE(23,1020)KTYES,LTYES,KTNO,LTNO CTIME=SECOND() XTIME=CTIME-BTIME WRITE(21,1019)XTIME,CTIME C C ISY AND ISN BIT VECTORS STORE LEGISLATORS STACKED--LEGISLATOR C 1 CONG 1 ON TOP OF LEGISLATOR 1 CONG 2 ETC. C C JSY AND JSN BIT VECTORS STORE ROLL CALLS STACKED BY CONGRESS. C ROLL CALL 1 CONG 1 ON TOP OF ROLL CALL 2 CONG 1 ETC. C KBIGT=0 DO 10 II=1,NCONG IS0(1;NP)=JLEG(1,2;NP).EQ.NYRB+II NPC=MARKER(II,5) L1(1;NPC)=Q8VCMPRS(JLEG(1,1;NP),IS0(1;NP);L1(1;NPC)) L2(1;NPU)=0 DO 11 J=1,NPC WHERE(JJLEG(1,2;NPU).EQ.L1(J))L2(1;NPU)=1 11 CONTINUE ISLEG((II-1)*NPU+1;NPU)=L2(1;NPU).EQ.1 KBIGT=KBIGT+Q8SCNT(ISLEG((II-1)*NPU+1;NPU)) 10 CONTINUE C C COMPUTE TIME MATRICES C KKK=0 LBIGT=0 DO 22 II=1,NPU IS0(1;NP)=JLEG(1,1;NP).EQ.JJLEG(II,2) KK=Q8SCNT(IS0(1;NP)) IF(KK.NE.JJLEG(II,1))WRITE(21,8700)II,KK,JJLEG(II,1), C(KAA(II,J),J=1,11) 8700 FORMAT(3I5,1X,11A1) JJLEG(II,1)=KK XSTART=-1.S0 IF(KK.GE.2)XINC=2.S0/HALF(KK-1) IF(KK.EQ.1)XINC=0.S0 L2(1;KK)=Q8VCMPRS(JLEG(1,2;NP),IS0(1;NP);L2(1;KK)) D2(1;NCONG)=0.S0 DO 23 JJ=1,NCONG IS1(1;KK)=L2(1;KK).EQ.NYRB+JJ K33=Q8SCNT(IS1(1;KK)) IF(K33.EQ.0)GO TO 23 KKK=KKK+1 D2(JJ)=1.S0 A2=XSTART A3=(3.S0*XSTART**2-1.S0)/2.S0 A4=(5.S0*XSTART**3-3.S0*XSTART)/2.S0 D1(KKK)=XI0(II)+XI1(II)*A2+ C XI2(II)*A3+ C XI3(II)*A4 XSTART=XSTART+XINC 23 CONTINUE ISLEG2((II-1)*NCONG+1;NCONG)=D2(1;NCONG).EQ.1.S0 KCHECK=Q8SCNT(ISLEG2((II-1)*NCONG+1;NCONG)) IF(KCHECK.EQ.0)WRITE(21,1037)II,(JJLEG(II,J),J=1,5), C(KAA(II,J),J=1,11),XI0(II) IF(KCHECK.EQ.0)STOP LBIGT=LBIGT+Q8SCNT(ISLEG2((II-1)*NCONG+1;NCONG)) L4(1;NCONG)=0 WHERE(ISLEG2((II-1)*NCONG+1;NCONG))L4(1;NCONG)=1 C WRITE(25,1939)II,(JJLEG(II,J),J=1,5),(KAA(II,J),J=1,11), C C(L4(J),J=1,NCONG) 1939 FORMAT(1X,2I4,1X,I5,1X,I2,1X,I2,1X,I4,1X,11A1,1X,100I1) 22 CONTINUE C C ISLEG IS A BIT VECTOR WHICH STORES LEGISLATORS STACKED BY CONGRESS-- C ALL 662 FOR CONG 1 ON TOP OF 662 FOR CONG 2 ETC. BIT VECTOR C IS 1 IF LEGISLATOR SERVED THAT CONG, 0 OTHERWISE. C WRITE(23,1040)KBIGT,LBIGT NOISE=133 C IF(NOISE.EQ.133)STOP C C METRIC UNFOLDING PHASE---CONDITIONAL GLOBAL MINIMUM ALGORITHM IS C USED TO IMPROVE THE STARTING LEGISLATOR COORDINATES C IF(NEDITH.EQ.0)GO TO 42 NS=3 XI1(1;NPU)=XEST(1,2;NPU) XI2(1;NPU)=XEST(1,3;NPU) CALL WHOOPE(NS,NCONG,NP,NPU,NYRB,KAA,NEDITH) SUM=Q8SSUM(XI0(1;NPU)) SUM=SUM/HALF(NPU) XI0(1;NPU)=XI0(1;NPU)-SUM SUM=Q8SSUM(XI1(1;NPU)) SUM=SUM/HALF(NPU) XI1(1;NPU)=XI1(1;NPU)-SUM SUM=Q8SSUM(XI2(1;NPU)) SUM=SUM/HALF(NPU) XI2(1;NPU)=XI2(1;NPU)-SUM DO 43 I=1,NPU 43 WRITE(33,5001)(JJLEG(I,J),J=2,5),(KAA(I,J),J=1,11),XI0(I), CXI1(I),XI2(I) CCTIME=SECOND() XTIME=CCTIME-CTIME WRITE(21,1048)XTIME,CCTIME NOISE=1947 IF(NOISE.EQ.1947)STOP C C RECODE PHASE---JANICE ALGORITHM IS USED TO FIND OPTIMAL CUTTING C LINE FOR EACH ROLL CALL (WHICH IS USED AS THE STARTING C ESTIMATE FOR THE MIDPOINT. THE POLARITY OF THE ROLL C CALL IS ALSO DETERMINED IN THIS PROCESS AND THE ISY,ISN, C JSY, AND JSN BIT VECTORS ARE SUITABLY RECODED. C 42 CONTINUE LNON0=-99 CALL RECODE(NCONG,NP,NPU,NYRB,MARKER,KSUMV,LVOTYY,LVOTNN, CLERRTL,L2P5YY,L2P5NN,L2P5RR,K2P5,LNON0) WRITE(23,1025)KSUMV NRCT=KSUMV WRITE(23,1022)LNON0,LVOTYY,LVOTNN,LERRTL WRITE(23,1023)K2P5,L2P5YY,L2P5NN,L2P5RR NOISE=1949 C IF(NOISE.EQ.1949)STOP MTOTCH=L2P5YY+L2P5NN C C NRCT = TOTAL NUMBER OF ROLL CALLS 1919 - 1984 C L2P5RC(1;NRCT) = 1 IF ROLL CALL GE 2.5% MINORITY C = 0 IF ROLL CALL LT 2.5% MINORITY C KTLIB=0 KTCONS=0 LTLIB=0 LTCONS=0 DO 12 I=1,NP K1=JRC(I,2) K2=JRC(I,3) LTLIB=LTLIB+Q8SCNT(ISY(K2+1;K1)) LTCONS=LTCONS+Q8SCNT(ISN(K2+1;K1)) 12 CONTINUE KKK=0 KXTLIB=0 KXTCON=0 MARKER(1,7;100)=0 DO 13 II=1,NCONG KSUM=MARKER(II,6) KK=MARKER(II,5) L11=MARKER(II,2) KIILB=0 KIICV=0 DO 14 JJ=1,L11 KKK=KKK+1 KYY=Q8SCNT(JSY(KSUM+(JJ-1)*KK+1;KK)) KNN=Q8SCNT(JSN(KSUM+(JJ-1)*KK+1;KK)) KTLIB=KTLIB+KYY KTCONS=KTCONS+KNN IF(L2P5RC(KKK).EQ.0)GO TO 14 KXTLIB=KXTLIB+KYY KXTCON=KXTCON+KNN MARKER(II,7)=MARKER(II,7)+1 KIILB=KIILB+KYY KIICV=KIICV+KNN 14 CONTINUE NII0=II+NYRB WRITE(23,1027)NII0,MARKER(II,2),MARKER(II,7),KIILB,KIICV MARKER(II,10)=KIILB+KIICV 13 CONTINUE WRITE(23,1024)KTLIB,LTLIB,KTCONS,LTCONS WRITE(23,1026)KKK,KXTLIB,KXTCON DTIME=SECOND() XTIME=DTIME-CCTIME WRITE(21,1021)XTIME,DTIME C C PARTY PHASE---THE 2 AND 3 PARTY MODELS OF WEISBERG ARE COMPUTED C AS WELL AS A PARTY CLEAVAGE MODEL. C WRITE(23,1031) WRITE(50)ISY WRITE(50)ISN WRITE(50)JSY WRITE(50)JSN WRITE(50)ISLEG WRITE(50)ISLEG2 WRITE(50)XI0 WRITE(50)XI1 WRITE(50)XI2 WRITE(50)XI3 WRITE(50)ZML WRITE(50)DL WRITE(50)L2P5RC WRITE(50)LVTRC2 WRITE(50)JLEG WRITE(50)JRC WRITE(50)XKEEP WRITE(50)XEST WRITE(50)JJLEG WRITE(50)DLMST WRITE(50)ZMLMST WRITE(50)XLGMST WRITE(50)JDUMMY WRITE(50)JLEGA WRITE(50)JRCA WRITE(50)LDUMMY WRITE(50)ZKEEP WRITE(50)LKEEP WRITE(50)MARKER WRITE(50)NSTATE WRITE(50)NPARTY WRITE(50)D1 WRITE(50)KAA NOISE=9870 IF(NOISE.EQ.9870)STOP 9112 CONTINUE READ(50)ISY READ(50)ISN READ(50)JSY READ(50)JSN READ(50)ISLEG READ(50)ISLEG2 READ(50)XI0 READ(50)XI1 READ(50)XI2 READ(50)XI3 READ(50)ZML READ(50)DL READ(50)L2P5RC READ(50)LVTRC2 READ(50)JLEG READ(50)JRC READ(50)XKEEP READ(50)XEST READ(50)JJLEG READ(50)DLMST READ(50)ZMLMST READ(50)XLGMST READ(50)JDUMMY READ(50)JLEGA READ(50)JRCA READ(50)LDUMMY READ(50)ZKEEP READ(50)LKEEP READ(50)MARKER READ(50)NSTATE READ(50)NPARTY READ(50)D1 READ(50)KAA NCONG=99 NP=31306 NPU=9759 NRCT=35826 MTOTCH=8110702 KKK=0 DO 4006 II=1,NCONG NV=MARKER(II,2) DO 4007 J=1,NV KKK=KKK+1 ZKEEP(KKK,1)=0.S0 ZKEEP(KKK,2)=0.S0 ZKEEP(KKK,3)=0.S0 ZKEEP(KKK,4)=0.S0 IF(L2P5RC(KKK).EQ.0)GO TO 4007 C READ(43,4008)(ZKEEP(KKK,JJ),JJ=1,4) C IF(KKK.LT.5)WRITE(21,4008)(ZKEEP(KKK,JJ),JJ=1,4) 4007 CONTINUE 4006 CONTINUE 4008 FORMAT(41X,4F7.3) C DO 4001 I=1,NPU C READ(41,4002)(XKEEP(I,(J8-1)*4+1),J8=1,NS), C C(XKEEP(I,(J8-1)*4+2),J8=1,NS) C IF(I.LT.5)WRITE(21,4002)(XKEEP(I,(J8-1)*4+1),J8=1,NS), C C(XKEEP(I,(J8-1)*4+2),J8=1,NS) C 4001 CONTINUE 4002 FORMAT(46X,4F7.3) MTOTAL=0 M60TOT=0 M2PTY=0 M3PTY=0 M60K2=0 M60K3=0 MCLEV=0 MMARGY=0 MKARGM=0 MSPACE=0 MSPA60=0 MTOT2=0 MTOT60=0 KDIV(1;50)=0 KKK=0 DO 15 II=1,NCONG IS0(1;NP)=JRC(1,1;NP).EQ.NYRB+II NPC=MARKER(II,5) NV=MARKER(II,2) KSUM=MARKER(II,6) NSTATE(1;NPC)=Q8VCMPRS(JLEG(1,3;NP),IS0(1;NP);NSTATE(1;NPC)) NPARTY(1;NPC)=Q8VCMPRS(JLEG(1,4;NP),IS0(1;NP);NPARTY(1;NPC)) ASSIGN AH1,.DYN.NPC ASSIGN AH2,.DYN.NPC ASSIGN AH3,.DYN.NPC ASSIGN BH1,.DYN.NPC ASSIGN BH2,.DYN.NPC ASSIGN BH3,.DYN.NPC ASSIGN BH4,.DYN.NPC ASSIGN CH1,.DYN.NPC ASSIGN CH2,.DYN.NPC ASSIGN DH1,.DYN.NPC AH1=NSTATE(1;NPC).GE.40.AND.NSTATE(1;NPC).LE.49 AH2=NSTATE(1;NPC).EQ.51.OR.NSTATE(1;NPC).EQ.53.OR. CNSTATE(1;NPC).EQ.54 AH3=AH1.OR.AH2 BH1=NPARTY(1;NPC).EQ.100 BH2=NPARTY(1;NPC).EQ.200 BH3=AH3.AND.BH1 BH4=.NOT.AH3 BH4=BH4.AND.BH1 KTOTAL=0 K2PTY=0 K3PTY=0 K60TOT=0 K60K2=0 K60K3=0 KCLEV=0 KMARGM=0 KTOT2=0 KTOT60=0 DO 16 J=1,NV KKK=KKK+1 IF(L2P5RC(KKK).EQ.0)GO TO 16 CH1=JSY(KSUM+(J-1)*NPC+1;NPC) CH2=JSN(KSUM+(J-1)*NPC+1;NPC) KKYES=Q8SCNT(CH1) KKNO=Q8SCNT(CH2) KMARGM=KMARGM+AMAX0(KKYES,KKNO) KTOT2=KTOT2+KKYES+KKNO KMIN=AMIN0(KKYES,KKNO) AA=HALF(KMIN)/HALF(KKYES+KKNO) X05=.50 DO 67 JH=1,10 IF(AA.LE.X05.AND.AA.GT.X05-.05)KDIV(JH)=KDIV(JH)+1 67 X05=X05-.05 DH1=CH1.AND.BH1 KDY=Q8SCNT(DH1) DH1=CH2.AND.BH1 KDN=Q8SCNT(DH1) DH1=CH1.AND.BH2 KRY=Q8SCNT(DH1) DH1=CH2.AND.BH2 KRN=Q8SCNT(DH1) KTOTAL=KTOTAL+KDY+KDN+KRY+KRN IF(AA.GE..4S0)K60TOT=K60TOT+KDY+KDN+KRY+KRN K2PTY=K2PTY+AMAX0(KDY,KDN)+AMAX0(KRY,KRN) IF(AA.GE..4S0)K60K2=K60K2+AMAX0(KDY,KDN)+AMAX0(KRY,KRN) IF(AA.GE..4S0)KTOT60=KTOT60+KKYES+KKNO KKLEV1=KDY+KRN KKLEV2=KDN+KRY KCLEV=KCLEV+AMAX0(KKLEV1,KKLEV2) DH1=CH1.AND.BH3 KSDY=Q8SCNT(DH1) DH1=CH2.AND.BH3 KSDN=Q8SCNT(DH1) DH1=CH1.AND.BH4 KNDY=Q8SCNT(DH1) DH1=CH2.AND.BH4 KNDN=Q8SCNT(DH1) K3PTY=K3PTY+AMAX0(KSDY,KSDN)+AMAX0(KNDY,KNDN)+AMAX0(KRY,KRN) IF(AA.GE..4S0)K60K3=K60K3+AMAX0(KSDY,KSDN)+AMAX0(KNDY,KNDN)+ CAMAX0(KRY,KRN) 16 CONTINUE X2PTY=0.S0 X3PTY=0.S0 X602PY=0.S0 X603PY=0.S0 XCLEV=0.S0 XMARGY=0.S0 XMARGM=0.S0 XSPACE=0.S0 XSPA60=0.S0 IF(KTOTAL.GT.0)X2PTY=HALF(K2PTY)/HALF(KTOTAL) IF(KTOTAL.GT.0)X3PTY=HALF(K3PTY)/HALF(KTOTAL) IF(K60TOT.GT.0)X602PY=HALF(K60K2)/HALF(K60TOT) IF(K60TOT.GT.0)X603PY=HALF(K60K3)/HALF(K60TOT) IF(KTOTAL.GT.0)XCLEV=HALF(KCLEV)/HALF(KTOTAL) IF(KTOT2.GT.0)XMARGY=HALF(MARKER(II,8))/HALF(KTOT2) IF(KTOT2.GT.0)XMARGM=HALF(KMARGM)/HALF(KTOT2) IF(KTOT60.GT.0)XSPA60=HALF(MARKER(II,3))/HALF(KTOT60) XSPA60=1.S0-XSPA60 IF(KTOT2.GT.0)XSPACE=HALF(MARKER(II,9))/HALF(KTOT2) XSPACE=1.S0-XSPACE IJ=II+NYRB WRITE(23,1028)IJ,X2PTY,X3PTY,X602PY,X603PY,XCLEV,XMARGY,XMARGM, CXSPA60,XSPACE MTOTAL=MTOTAL+KTOTAL MTOT2=MTOT2+KTOT2 MTOT60=MTOT60+KTOT60 M60TOT=M60TOT+K60TOT M2PTY=M2PTY+K2PTY M3PTY=M3PTY+K3PTY M60K2=M60K2+K60K2 M60K3=M60K3+K60K3 MCLEV=MCLEV+KCLEV MMARGY=MMARGY+MARKER(II,8) MKARGM=MKARGM+KMARGM MSPACE=MSPACE+MARKER(II,9) MSPA60=MSPA60+MARKER(II,3) 15 CONTINUE IF(MTOTAL.GT.0)X2PTY=HALF(M2PTY)/HALF(MTOTAL) IF(MTOTAL.GT.0)X3PTY=HALF(M3PTY)/HALF(MTOTAL) IF(M60TOT.GT.0)X602PY=HALF(M60K2)/HALF(M60TOT) IF(M60TOT.GT.0)X603PY=HALF(M60K3)/HALF(M60TOT) IF(MTOTAL.GT.0)XCLEV=HALF(MCLEV)/HALF(MTOTAL) IF(MTOT2.GT.0)XMARGY=HALF(MMARGY)/HALF(MTOT2) IF(MTOT2.GT.0)XMARGM=HALF(MKARGM)/HALF(MTOT2) IF(MTOT60.GT.0)XSPA60=HALF(MSPA60)/HALF(MTOT60) XSPA60=1.S0-XSPA60 IF(MTOT2.GT.0)XSPACE=HALF(MSPACE)/HALF(MTOT2) XSPACE=1.S0-XSPACE WRITE(23,1029)X2PTY,X3PTY,X602PY,X603PY,XCLEV,XMARGY,XMARGM, CXSPA60,XSPACE WRITE(23,1058) K50=50 L50=50 DO 68 J=1,10 WRITE(23,1027)J,K50,L50,KDIV(J) K50=K50+5 L50=L50-5 68 CONTINUE ETIME=SECOND() XTIME=ETIME-DTIME WRITE(21,1030)XTIME,ETIME NOISE=69 C IF(NOISE.EQ.69)STOP C C C C *********GLOBAL ESTIMATION OF TIME NOMINATE MODEL********* C C C DO 204 J=1,NS 204 XKEEP(1,(J-1)*4+1;NPU)=XEST(1,J;NPU) ZKEEP(1,1;NRCT)=DL(1;NRCT) ZKEEP(1,2;NRCT)=ZML(1;NRCT) DO 7777 IJKL=1,NMOM LKJI=IJKL NOISEY=7007 IF(NOISEY.EQ.7007)GO TO 7008 C C READ(51)XKEEP C READ(51)ZKEEP C READ(51)D1 C READ(51)BETA C 7008 CONTINUE DO 8888 JJJJ=1,NS JJJK=JJJJ XI0(1;NPU)=XKEEP(1,(JJJJ-1)*4+1;NPU) XI1(1;NPU)=XKEEP(1,(JJJJ-1)*4+2;NPU) XI2(1;NPU)=XKEEP(1,(JJJJ-1)*4+3;NPU) XI3(1;NPU)=XKEEP(1,(JJJJ-1)*4+4;NPU) DL(1;NRCT)=ZKEEP(1,(JJJJ-1)*2+1;NRCT) ZML(1;NRCT)=ZKEEP(1,(JJJJ-1)*2+2;NRCT) LVTRC2(1;40000)=0 JANICE=0 MASTER=0 DO 9999 IIII=1,NLAST ETIME=SECOND() MASTER=MASTER+1 NSTEP=1 XLGMST(1;NP)=D1(1;NP) KKK=0 C C ROLL CALL PHASE C KSUMV=0 XJANS=0.S0 KILBAD=0 LILBAD=0 MILBAD=0 KALL1=0 KALL2=0 KDIAG1=0 KDIAG2=0 WRITE(28,1038)IJKL,JJJJ,IIII ELIPSE(1;300)=0.S0 DO 17 II=1,NCONG MOVE=II YJANS=0.S0 NPC=MARKER(II,5) NV=MARKER(II,2) KSUM=MARKER(II,6) KKJX=0 DO 177 JX=1,NPU D2(1;NCONG)=0.S0 KK=Q8SCNT(ISLEG2((JX-1)*NCONG+1;NCONG)) WHERE(ISLEG2((JX-1)*NCONG+1;NCONG)) D2(1;NCONG)=1.S0 XSTART=-1.S0 IF(KK.GE.2)XINC=2.S0/HALF(KK-1) IF(KK.EQ.1)XINC=0.S0 DO 178 JJ=1,NCONG IF(D2(JJ).EQ.0.S0)GO TO 178 A2=XSTART A3=(3.S0*XSTART**2-1.S0)/2.S0 A4=(5.S0*XSTART**3-3.S0*XSTART)/2.S0 XSTART=XSTART+XINC IF(JJ.EQ.II)GO TO 179 178 CONTINUE GO TO 177 179 KKJX=KKJX+1 XLEG(KKJX)=XI0(JX)+XI1(JX)*A2+XI2(JX)*A3+XI3(JX)*A4 KK=0 DO 205 JEPP=1,NS IF(JEPP.EQ.JJJJ)GO TO 205 KK=KK+1 XLEG1(KKJX+(KK-1)*NPU)=XKEEP(JX,(JEPP-1)*4+1)+ CXKEEP(JX,(JEPP-1)*4+2)*A2+ CXKEEP(JX,(JEPP-1)*4+3)*A3+XKEEP(JX,(JEPP-1)*4+4)*A4 205 CONTINUE 177 CONTINUE IF(KKJX.NE.NPC)WRITE(21,4444)II,KKJX,NPC IF(KKJX.NE.NPC)STOP WK(1;NPC)=VREAL(XLEG(1;NPC);WK(1;NPC)) CALL QSORT(NPC,WK,L1) XLMX=XLEG(L1(NPC)) XLMN=XLEG(L1(1)) YLMX(II)=XLMX YLMN(II)=XLMN WTSQ(1;NPC)=WTS(1)+WTS(2)*XLEG(1;NPC)+WTS(3)*XLEG(1;NPC)**2 WTSQ(1;NPC)=WTSQ(1;NPC)**2 5556 FORMAT(3I8,2F10.4) DO 18 J=1,NV KKK=KKK+1 IF(L2P5RC(KKK).EQ.0)GO TO 18 B(1)=DL(KSUMV+J) B(2)=ZML(KSUMV+J) IVYY(1;NPC)=JSY(KSUM+(J-1)*NPC+1;NPC) IVNN(1;NPC)=JSN(KSUM+(J-1)*NPC+1;NPC) IVNV(1;NPC)=IVYY(1;NPC).OR.IVNN(1;NPC) D1YES(1;NPC)=0.S0 D1NO(1;NPC)=0.S0 AA=0.S0 BIRDTX=0.S0 BIRDTZ=0.S0 IF(IJKL.EQ.1.AND.JJJJ.EQ.1)GO TO 613 KK=0 DO 206 JEPP=1,NS IF(JEPP.EQ.JJJJ)GO TO 206 IF(IJKL.EQ.1.AND.JEPP.GT.JJJJ)GO TO 206 KK=KK+1 D1YES(1;NPC)=D1YES(1;NPC)+(XLEG1((KK-1)*NPU+1;NPC)- CZKEEP(KSUMV+J,(JEPP-1)*2+2)+ZKEEP(KSUMV+J,(JEPP-1)*2+1))**2 D1NO(1;NPC)=D1NO(1;NPC)+(XLEG1((KK-1)*NPU+1;NPC)- CZKEEP(KSUMV+J,(JEPP-1)*2+2)-ZKEEP(KSUMV+J,(JEPP-1)*2+1))**2 BIRDZ=ZKEEP(KSUMV+J,(JEPP-1)*2+2)**2 BIRDX1=Q8SMIN(XLEG1((KK-1)*NPU+1;NPC)) BIRDX2=Q8SMAX(XLEG1((KK-1)*NPU+1;NPC)) BIRDX1=BIRDX1**2 BIRDX2=BIRDX2**2 BIRDX=(BIRDX2+BIRDX1)/2.0 C IF(BIRDX2.LT.BIRDX1)BIRDX=BIRDX1 IF(NCONG.LT.3)BIRDX=1.S0 ELIPSE((JEPP-1)*NCONG+II)=BIRDX BIRDTX=BIRDTX+BIRDX BIRDTZ=BIRDTZ+BIRDZ AA=AA+BIRDZ/BIRDX 206 CONTINUE 613 CONTINUE D1YES(1;NPC)=VHSQRT(D1YES(1;NPC);D1YES(1;NPC)) D1NO(1;NPC)=VHSQRT(D1NO(1;NPC);D1NO(1;NPC)) KPRNT=-99 C IF(KKK.EQ.123.AND.JJJJ.EQ.2)KPRNT=0 C WRITE(21,1409)MOVE,BETA(1;5) C WRITE(21,1408)XLEG(1;5) C WRITE(21,1408)D1YES(1;5) C WRITE(21,1408)D1NO(1;5) C WRITE(21,1408)WTSQ(1;5) C IF(KPRNT.EQ.-99)STOP 1408 FORMAT(5F10.4) 1409 FORMAT(I5,5F10.4) CALL VTFUN(MOVE,NPC,NFUNS,NFUNS3,KONVRG,B,D1YES,D1NO,KPRNT, CSAVLOG,SCURLG,V11,V12,V22,XCRIT,WTSQ) LVTRC2(KKK)=0 IF(B(2).LT.XLMN.OR.B(2).GT.XLMX)LVTRC2(KKK)=1 XUSA=+1.S0 IF(B(1).LT.0.S0)XUSA=-1.S0 IF(B(2).LT.XLMN.OR.B(2).GT.XLMX)B(1)=.5S0*XUSA BIRDX1=XLMN**2 BIRDX2=XLMX**2 BIRDX=(BIRDX2+BIRDX1)/2.0 C IF(BIRDX2.LT.BIRDX1)BIRDX=BIRDX1 IF(NCONG.LT.3)BIRDX=1.S0 ELIPSE((JJJJ-1)*NCONG+II)=BIRDX AAT1=(B(2)**2)/BIRDX AAT=AA+AAT1 XUSA=+1.S0 IF(B(2).LT.0.S0)XUSA=-1.S0 IF((1.S0-AA).GE.0.S0.AND.AAT.GT.1.S0)B(2)=HSQRT((1.S0-AA)* CBIRDX)*XUSA IF((1.S0-AA).GE.0.S0.AND.AAT.GT.1.S0)LVTRC2(KKK)=1 IF((1.S0-AA).LT.0.S0)B(2)=0.S0 IF((1.S0-AA).LT.0.S0)LVTRC2(KKK)=1 IF(LVTRC2(KKK).EQ.1)CALL VTZERO(MOVE,KKK,NPC,NFUNS,NFUNS3,KONVRG, CD1YES,D1NO,B,SAVLOG,SCURLG,V11,V12,V22,WTSQ,KCALM) IF((B(2)+B(1)).GT.XLMX.AND.(B(2)-B(1)).LT.XLMN)LVTRC2(KKK)=2 20 JII=II JJ=J IF(II.EQ.1)IPRNT=1 IF(II.GT.1)IPRNT=1 CALL VTWRT(KKK,JII,JJ,NFUNS,NFUNS3,KONVRG,B,SAVLOG,SCURLG,V11, CV12,V22,IPRNT,TOOT1,TOOT2) IF(LVTRC2(KKK).EQ.1.AND.ZML(KKK).LT.0.S0)KILBAD=KILBAD+1 IF(LVTRC2(KKK).EQ.1.AND.ZML(KKK).GT.0.S0)LILBAD=LILBAD+1 IF(LVTRC2(KKK).EQ.2)MILBAD=MILBAD+1 YJANS=YJANS+SCURLG I9=NYRB+II IF(JJJJ.EQ.1.AND.IIII.LT.NLAST)GO TO 18 C IF(IJKL.EQ.NMOM.AND.JJJJ.EQ.NS.AND.IIII.EQ.NLAST)KCALM(1)=-99 CALL VTZERO(MOVE,KKK,NPC,NFUNS,NFUNS3,KONVRG,D1YES,D1NO, CB,SAVLOG,SCURLG,V11,V12,V22,WTSQ,KCALM) KPHON1=KCALM(1)+KCALM(2)+KCALM(3)+KCALM(4) KPHON2=KCALM(1)+KCALM(3) KPHON3=KCALM(2)+KCALM(4) KPHON4=AMIN0(KPHON2,KPHON3) AA=HALF(KPHON4)/HALF(KPHON1) IF(AA.GE..4S0)KALL1=KALL1+KPHON1 IF(AA.GE..4S0)KDIAG1=KDIAG1+KCALM(1)+KCALM(4) KALL2=KALL2+KPHON1 KDIAG2=KDIAG2+KCALM(1)+KCALM(4) GMPROB=HEXP(SCURLG/HALF(KPHON1)) DLMST(KKK)=GMPROB DO 5092 JAX=1,4 5092 JLEGA(KKK,JAX)=KCALM(JAX) I9=NYRB+II C IF(JJJJ.EQ.2)WRITE(31,1114)I9,J,KKK,LVTRC2(KKK),GMPROB, C CKCALM(1;4),ZML(KKK),DL(KKK),TOOT2,TOOT1 C 1114 FORMAT(1X,I2,1X,I4,1X,I5,1X,I1,1X,F7.3,4I4,4F7.3) 18 CONTINUE XJANS=XJANS+YJANS GMPROB=HEXP(YJANS/HALF(MARKER(II,10))) IIB0=II+NYRB NPC3=NPC-3 WRITE(28,1039)IIB0,GMPROB,(XLEG(L1(JX)),JX=1,4),(XLEG(L1(JX)), CJX=NPC3,NPC) KSUMV=KSUMV+NV 17 CONTINUE C C LVTRC2(1;NRCT) = 0 IF OUTCOMES INTERIOR TO [-1,+1] C = 1 IF MIDPOINT EXTERIOR TO [-1,+1] C = 2 IF OUTCOMES EXTERIOR TO [-1,+1] C GMPROB=HEXP(XJANS/HALF(MTOTCH)) C WRITE(21,5991)GMPROB 5991 FORMAT(' 10-4 GOOD BUDDY',E15.7) CALL RRSQR(IIII,JJJJ,IJKL,NRCT,NP,NRCT,NSTEP,RR1,RR2, CALP1,ALP2,BTA1,BTA2,D1) JANICE=JANICE+1 FTIME=SECOND() XTIME=FTIME-ETIME WRITE(21,1034)JJJK,MASTER,JANICE,NSTEP,XTIME,FTIME,XJANS,GMPROB, CALP1,BTA1,RR1,ALP2,BTA2,RR2,KILBAD,LILBAD,MILBAD C C LEGISLATOR PHASE C NSTEP=2 XJANS=0.S0 LSUM=0 KSUMX=0 KSTRN=0 KDIAG=0 KALL=0 DO 27 I=1,NPU INP=I B(1)=XI0(I) B(2)=XI1(I) B(3)=XI2(I) B(4)=XI3(I) B(5;8)=B(1;4) KK=JJLEG(I,1) IF(KK.GT.MPOLY+1)NPOLY=MPOLY IF(KK.LE.MPOLY+1)NPOLY=KK-2 IF(NPOLY.LT.0)NPOLY=0 KSUM=0 CALL XLGFUN(LKJI,JJJK,NP,NS,NCONG,NYRB,INP,NFUNS,NFUNS3,KONVRG, CB,SAVLOG,SCURLG,VVV,MARKER,KSUM,NPOLY,XCRIT,KCALM) XI0(I)=B(1) XI1(I)=B(2) XI2(I)=B(3) XI3(I)=B(4) C IF(NCONG.LT.3)MSTRN=-99 CALL XLCHCK(LKJI,JJJK,NS,NPU,NCONG,INP,YLMX,YLMN,MSTRN,YMIN, CYMAX,DTOT,ELIPSE) C IF(MSTRN.EQ.-99)GO TO 40 IF(MSTRN.EQ.0)GO TO 40 KSTRN=KSTRN+1 SBVLOG=SAVLOG B(1)=XI0(I) B(2)=XI1(I) B(3)=XI2(I) B(4)=XI3(I) NFUNS3=-99 CALL XLGFUN(LKJI,JJJK,NP,NS,NCONG,NYRB,INP,NFUNS,NFUNS3,KONVRG, CB,SAVLOG,SCURLG,VVV,MARKER,KSUM,NPOLY,XCRIT,KCALM) GMPROB=HEXP(SCURLG/HALF(KSUM)) WRITE(22,1111)INP,(JJLEG(INP,J),J=1,5),(KAA(INP,J),J=1,11), CGMPROB,YMIN,YMAX,DTOT,XI0(INP),SBVLOG,SAVLOG,SCURLG,KOHIO2, CB(1;4) 1111 FORMAT(1X,2I4,1X,I5,1X,I2,1X,I2,1X,I4,1X,11A1,1X,5F7.3, C3F12.5,I6,4F7.3) GO TO 41 40 CONTINUE XI0(I)=B(5) XI1(I)=B(6) XI2(I)=B(7) XI3(I)=B(8) 41 CONTINUE GMPROB=HEXP(SCURLG/HALF(KSUM)) ZMLMST(I)=GMPROB IPRNT=1 CALL XLGWRT(INP,NFUNS,NFUNS3,KONVRG,B,SAVLOG,SCURLG,VVV, CIPRNT,TOOT1,TOOT2,TOOT3,TOOT4) IF(IIII.EQ.NLAST.AND.IJKL.EQ.NMOM)WRITE(25,5007)INP, C(JJLEG(INP,J),J=1,5),(KAA(INP,J),J=1,11),GMPROB,XI0(INP),XI1(INP), CVVV(1;3) C IF(IIII.EQ.NLAST)WRITE(25,1113)INP,(JJLEG(INP,J),J=1,5), C IF(JJJJ.EQ.2)WRITE(25,1113)INP,(JJLEG(INP,J),J=1,5), C C(KAA(INP,J),J=1,11),GMPROB,KCALM(1;4),XI0(INP),XI1(INP), C CXI2(INP),XI3(INP),TOOT1,TOOT2,TOOT3,TOOT4 1113 FORMAT(1X,2I4,1X,I5,1X,I2,1X,I2,1X,I4,1X,11A1,1X,F7.3, C4I6,8F7.3) IF(IIII.EQ.NLAST)KDIAG=KDIAG+KCALM(1)+KCALM(4) IF(IIII.EQ.NLAST)KALL=KALL+KCALM(1)+KCALM(2)+KCALM(3)+KCALM(4) XJANS=XJANS+SCURLG LSUM=LSUM+KSUM DO 30 JJ=1,MPOOP AA=XSYES(JJ)+XSNO(JJ)-XSPHI(JJ) GMPROB=HEXP(AA/HALF(KNOX(JJ))) 30 CONTINUE KSUMX=KSUMX+MPOOP 27 CONTINUE GMPROB=HEXP(XJANS/HALF(MTOTCH)) KKK=0 XLEG1(1;40000)=0.S0 XLEG2(1;40000)=0.S0 DO 28 II=1,NPU C WRITE(22,1037)II,(JJLEG(II,J),J=1,5),(KAA(II,J),J=1,11), C CXI0(II),XI1(II),XI2(II),XI3(II) D2(1;NCONG)=0.S0 KK=Q8SCNT(ISLEG2((II-1)*NCONG+1;NCONG)) WHERE(ISLEG2((II-1)*NCONG+1;NCONG)) D2(1;NCONG)=1.S0 XSTART=-1.S0 IF(KK.GE.2)XINC=2.S0/HALF(KK-1) IF(KK.EQ.1)XINC=0.S0 DO 29 JJ=1,NCONG IF(D2(JJ).EQ.0.S0)GO TO 29 A2=XSTART A3=(3.S0*XSTART**2-1.S0)/2.S0 A4=(5.S0*XSTART**3-3.S0*XSTART)/2.S0 KKK=KKK+1 XIT=XI0(II)+XI1(II)*A2+ C XI2(II)*A3+ C XI3(II)*A4 D1(KKK)=XIT XSTART=XSTART+XINC KSICK=0 DO 2829 L=1,NS IF(L.EQ.JJJJ)GO TO 2829 IF(IJKL.EQ.1.AND.L.GT.JJJJ)GO TO 2829 KSICK=KSICK+1 XIT=XKEEP(II,(L-1)*4+1)+XKEEP(II,(L-1)*4+2)*A2+ C XKEEP(II,(L-1)*4+3)*A3+ C XKEEP(II,(L-1)*4+4)*A4 IF(KSICK.EQ.1)XLEG1(KKK)=XIT IF(KSICK.EQ.2)XLEG2(KKK)=XIT 2829 CONTINUE 29 CONTINUE 28 CONTINUE XTITAN=2.5S0 D2(1;NPU)=XI0(1;NPU) IF(NOISEY.EQ.7007)XLGMST(1;NP)=D1(1;NP) C CALL ONEPLT(NPU,0,1,D2,XTITAN,29) CALL RRSQR(IIII,JJJJ,IJKL,NP,NP,NRCT,NSTEP,RR1,RR2, CALP1,ALP2,BTA1,BTA2,D1) JANICE=JANICE+1 GTIME=SECOND() XTIME=GTIME-FTIME WRITE(21,1043)JJJK,MASTER,JANICE,NSTEP,XTIME,GTIME,XJANS,GMPROB, CALP1,BTA1,RR1,KSTRN NSTEP=0 XBETA=BETA(1) LSAVE(1;NP)=1 MOVE=1 KPRNT=1 YCRIT=1.S0 CALL BTAFUN(LKJI,JJJK,NP,NS,NYRB,NFUNS,NFUNS3,KONVRG,XBETA, CSAVLOG,SCURLG,V11,YCRIT,D1,XLEG1,XLEG2,MARKER,KSUM,LSAVE,KPRNT) CALL BTAWRT(MOVE,NFUNS,NFUNS3,KONVRG,XBETA,SAVLOG,SCURLG,V11) GMPROB=HEXP(SCURLG/HALF(KSUM)) BETA(1;100)=XBETA NPNV=NP+2*NRCT C WRITE(21,5555)NPNV,NP,NRCT,NSTEP 5555 FORMAT(9I8) CALL RRSQR(IIII,JJJJ,IJKL,NPNV,NP,NRCT,NSTEP,RR1,RR2, CALP1,ALP2,BTA1,BTA2,D1) C WRITE(21,5555)NPNV,NP,NRCT,NSTEP JANICE=JANICE+1 HTIME=SECOND() XTIME=HTIME-GTIME WRITE(21,1045)JJJK,MASTER,JANICE,NSTEP,XTIME,HTIME,SCURLG, CGMPROB,ALP1,BTA1,RR1,BETA(1) ZKEEP(1,(JJJJ-1)*2+1;NRCT)=DL(1;NRCT) ZKEEP(1,(JJJJ-1)*2+2;NRCT)=ZML(1;NRCT) XKEEP(1,(JJJJ-1)*4+1;NPU)=XI0(1;NPU) XKEEP(1,(JJJJ-1)*4+2;NPU)=XI1(1;NPU) XKEEP(1,(JJJJ-1)*4+3;NPU)=XI2(1;NPU) XKEEP(1,(JJJJ-1)*4+4;NPU)=XI3(1;NPU) LKEEP(1,JJJJ;NRCT)=LVTRC2(1;NRCT) 9999 CONTINUE A1=HALF(KDIAG)/HALF(KALL) A2=HALF(KDIAG1)/HALF(KALL1) A3=HALF(KDIAG2)/HALF(KALL2) WRITE(21,1027)KDIAG,KDIAG1,KDIAG2,KALL,KALL1,KALL2 WRITE(21,1115)A1,A2,A3 8888 CONTINUE IF(IJKL.LT.NMOM)GO TO 5008 NS2=NS*2 DO 5006 I=1,NPU IF(MPOLY.EQ.0)WRITE(31,5007)I,(JJLEG(I,J),J=1,5), C(KAA(I,J),J=1,11),ZMLMST(I),(XKEEP(I,(J8-1)*4+1),J8=1,NS) IF(MPOLY.EQ.1)WRITE(31,5007)I,(JJLEG(I,J),J=1,5), C(KAA(I,J),J=1,11),ZMLMST(I),(XKEEP(I,(J8-1)*4+1),J8=1,NS), C(XKEEP(I,(J8-1)*4+2),J8=1,NS) IF(MPOLY.EQ.2)WRITE(31,5007)I,(JJLEG(I,J),J=1,5), C(KAA(I,J),J=1,11),ZMLMST(I),(XKEEP(I,(J8-1)*4+1),J8=1,NS), C(XKEEP(I,(J8-1)*4+2),J8=1,NS),(XKEEP(I,(J8-1)*4+3),J8=1,NS) IF(MPOLY.EQ.3)WRITE(31,5007)I,(JJLEG(I,J),J=1,5), C(KAA(I,J),J=1,11),ZMLMST(I),(XKEEP(I,(J8-1)*4+1),J8=1,NS), C(XKEEP(I,(J8-1)*4+2),J8=1,NS),(XKEEP(I,(J8-1)*4+3),J8=1,NS), C(XKEEP(I,(J8-1)*4+4),J8=1,NS) 5006 CONTINUE 5007 FORMAT(1X,2I4,1X,I5,1X,I2,1X,I2,1X,I4,1X,11A1,1X,13F7.3) KKK=0 DO 6006 II=1,NCONG NV=MARKER(II,2) DO 6011 J=1,NV KKK=KKK+1 I9=NYRB+II IF(L2P5RC(KKK).EQ.0)GO TO 6011 K10=KKK/10 K1010=K10*10 C IF(K1010.EQ.KKK)WRITE(33,6007)I9,J,KKK,(LKEEP(KKK,JJ),JJ=1,2), WRITE(33,6007)I9,J,KKK,(LKEEP(KKK,JJ),JJ=1,3), C(JLEGA(KKK,JJ),JJ=1,4),DLMST(KKK),(ZKEEP(KKK,JJ),JJ=1,NS2) 6011 CONTINUE 6006 CONTINUE 6007 FORMAT(I4,I5,I6,3I2,4I3,1X,7F7.3) 5008 KBURP=0 KBURQ=0 KBURR=0 KB(1;NS)=0 DO 6008 I=1,NRCT IF(L2P5RC(I).EQ.0)GO TO 6008 KK=0 DO 6009 J=1,NS IF(LKEEP(I,J).NE.1)KK=KK+1 IF(LKEEP(I,J).NE.1)KB(J)=KB(J)+1 6009 CONTINUE IF(KK.EQ.NS)KBURP=KBURP+1 IF(KK.LT.NS.AND.KK.GE.1)KBURQ=KBURQ+1 IF(KK.EQ.0)KBURR=KBURR+1 6008 CONTINUE WRITE(21,1051)IJKL,KBURP,KBURQ,KBURR WRITE(21,1059)(KB(JJ),JJ=1,NS) C C WRITE(52)XKEEP C WRITE(52)ZKEEP C WRITE(52)D1 C WRITE(52)BETA C 7777 CONTINUE STOP END C *************************SUBROUTINE RECODE************************* C RECODES THE JSY, JSN, ISY, ISN BIT VECTORS TO CORRESPOND C TO THE STARTING ESTIMATE OF THE LEGISLATOR COORDINATES. C IN JSY AND ISY, 1=LIBERAL, 0=OTHERWISE. C IN JSN AND ISN, 1=CONSERVATIVE, 0=OTHERWISE. C ******************************************************************* C C SUBROUTINE RECODE(NCONG,NP,NPU,NYRB,MARKER,KSUMV,LVOTYY, CLVOTNN,LERRTL,L2P5YY,L2P5NN,L2P5RR,K2P5,LNON0) IMPLICIT HALF PRECISION (A-H,O-Z) REAL Q DIMENSION Q(17000),LL(17000),KVT(17000),LVT(17000), CMARKER(100,11),JVT(1600),XX(1000),L2(1000),X(17000), CL3(1600),L4(100) BIT ISY,ISN,JSY,JSN,IVYY(1600),IVNN(1600),AV,BV,CV, CIS0(40000),ISLEG,ISLEG2,IVNV(1600) DESCRIPTOR AV,BV,CV COMMON /HUGE/ ISY(12000000),ISN(12000000),JSY(12000000), CJSN(12000000),ISLEG(989901),ISLEG2(989901) COMMON /HUGE2/ XI0(9999),XI1(9999),XI2(9999),XI3(9999), CZML(40000),DL(40000),L2P5RC(40000),LVTRC2(40000), CJLEG(33000,4),JRC(33000,3),XKEEP(9999,12),XEST(9999,3), CJJLEG(9999,5),DLMST(40000),ZMLMST(40000),XLGMST(33000), CJDUMMY(9999,5),JLEGA(40000,4),JRCA(33000,3),LDUMMY(33000), CZKEEP(40000,6),LKEEP(40000,3) 1022 FORMAT(' ITR=',I2,' NON0 RCS=',I7,' TOTAL YES=',I7, C' TOTAL NO=',I7,' TOTAL ERROR=',I7) 1023 FORMAT(' 2.5 RCS=',I7,' TOTAL YES=',I7, C' TOTAL NO=',I7,' TOTAL ERROR=',I7) KNOISE=LNON0 KSUMV=0 LNON0=0 LVOTYY=0 LVOTNN=0 LERRTL=0 L2P5YY=0 L2P5NN=0 L2P5RR=0 K2P5=0 L40YY=0 L40NN=0 L40RR=0 K40=0 MARKER(1,3;100)=0 KTOTL=0 MARKER(1,8;100)=0 MARKER(1,9;100)=0 DO 9999 II=1,NCONG IS0(1;NP)=JRC(1,1;NP).EQ.NYRB+II NV=MARKER(II,2) NPC=MARKER(II,5) KSUM=MARKER(II,6) C WRITE(21,1900)II,NPU,NV,NPC,KSUM C 1900 FORMAT(5I8) XX(1;NPC)=Q8VCMPRS(XI0(1;NPU),ISLEG((II-1)*NPU+1;NPU); CXX(1;NPC)) L2(1;NPC)=Q8VCMPRS(JRC(1,3;NP),IS0(1;NP);L2(1;NPC)) Q(1;NPC)=VREAL(XX(1;NPC);Q(1;NPC)) CALL QSORT(NPC,Q,LL) X(1;NPC)=Q8VGATHR(XX(1;NPC),LL(1;NPC);X(1;NPC)) C IF(II.GT.1)GO TO 9000 C DO 9001 JJ=1,NPC C 9001 WRITE(22,9002)JJ,XI0(JJ),XX(JJ),Q(JJ),X(JJ) C 9002 FORMAT(I5,4F10.4) C 9000 CONTINUE ASSIGN AV,.DYN.NV ASSIGN BV,.DYN.NV ASSIGN CV,.DYN.NV DO 3 J=1,NV KTOTL=KTOTL+1 L2P5RC(KTOTL)=0 JJJ=J IVYY(1;NPC)=JSY(KSUM+(J-1)*NPC+1;NPC) IVNN(1;NPC)=JSN(KSUM+(J-1)*NPC+1;NPC) NY=Q8SCNT(IVYY(1;NPC)) NN=Q8SCNT(IVNN(1;NPC)) CALL Q8SUM(X'80',,XX(1;NPC),,,IVYY(1;NPC),6) CALL Q8ADDNH(6,,SUMY) CALL Q8SUM(X'80',,XX(1;NPC),,,IVNN(1;NPC),6) CALL Q8ADDNH(6,,SUMN) IF(NY.GT.0)SUMY=SUMY/HALF(NY) IF(NN.GT.0)SUMN=SUMN/HALF(NN) IF(NY.EQ.0.OR.NN.EQ.0)GO TO 9998 LNON0=LNON0+1 WHERE (IVYY(1;NPC).EQV.IVNN(1;NPC)) KVT(1;NPC)=0 WHERE (IVYY(1;NPC)) KVT(1;NPC)=1 WHERE (IVNN(1;NPC)) KVT(1;NPC)=6 LVT(1;NPC)=Q8VGATHR(KVT(1;NPC),LL(1;NPC);LVT(1;NPC)) CALL JANICE(NPC,LVT,X,KFLIP,ZSAB) L3(J)=KFLIP XUSA=+1.S0 IF(KFLIP.EQ.2)XUSA=-1.S0 C IF(SUMY.GE.ZSAB)XUSA=-1.S0 ZML(KSUMV+J)=ZSAB IF(ZSAB.GT.0.S0)DT=(ZSAB+1.S0)*.5S0 IF(ZSAB.LE.0.S0)DT=(1.S0-ZSAB)*.5S0 DL(KSUMV+J)=DT*XUSA GO TO 9997 9998 KFLIP=1 L3(J)=KFLIP ZML(KSUMV+J)=1.S0 DL(KSUMV+J)=0.S0 9997 LERROR=NY+NN-LVT(1) C IF(II.LT.3)WRITE(22,9996)II,J,NY,NN,LERROR,L3(J), C CZML(KSUMV+J),DL(KSUMV+J),SUMY,SUMN 9996 FORMAT(6I4,4F12.5) IF(NY.EQ.0.OR.NN.EQ.0)GO TO 66 LVOTYY=LVOTYY+NY LVOTNN=LVOTNN+NN LERRTL=LERRTL+LERROR MINN=AMIN0(NY,NN) X2P5=HALF(MINN)/HALF(NY+NN) IF(X2P5.LT..025S0)GO TO 66 L2P5RC(KTOTL)=1 L2P5YY=L2P5YY+NY MARKER(II,8)=MARKER(II,8)+NY MARKER(II,9)=MARKER(II,9)+LERROR L2P5NN=L2P5NN+NN L2P5RR=L2P5RR+LERROR K2P5=K2P5+1 IF(X2P5.LT..40S0)GO TO 66 L40YY=L40YY+NY MARKER(II,3)=MARKER(II,3)+LERROR L40NN=L40NN+NN L40RR=L40RR+LERROR L40=L40+1 66 CONTINUE IF(KNOISE.EQ.-99)GO TO 3 IF(KFLIP.EQ.1)GO TO 3 JSY(KSUM+(J-1)*NPC+1;NPC)=KVT(1;NPC).EQ.6 JSN(KSUM+(J-1)*NPC+1;NPC)=KVT(1;NPC).EQ.1 3 CONTINUE IF(KNOISE.EQ.-99)GO TO 4114 BV=L3(1;NV).EQ.2 DO 4 I=1,NPC L22=L2(I) AV=ISY(L22+1;NV) CV=ISN(L22+1;NV) WHERE (AV.EQV.CV)JVT(1;NV)=0 WHERE (AV) JVT(1;NV)=1 WHERE (CV) JVT(1;NV)=6 WHERE (BV.AND.AV) JVT(1;NV)=6 WHERE (BV.AND.CV) JVT(1;NV)=1 ISY(L22+1;NV)=JVT(1;NV).EQ.1 ISN(L22+1;NV)=JVT(1;NV).EQ.6 4 CONTINUE 4114 CONTINUE KSUMV=KSUMV+NV 9999 CONTINUE IS0(1;KTOTL)=L2P5RC(1;KTOTL).EQ.1 KOFFEE=Q8SCNT(IS0(1;KTOTL)) WRITE(22,1000)KTOTL,KSUMV,KOFFEE 1000 FORMAT(3I10) RETURN END C C C *************************SUBROUTINE JANICE************************* C COMPUTES OPTIMAL CUTTING LINE FOR ROLL CALL GIVEN THE LEGISLATOR C CONFIGURATION AND DETERMINES POLARITY. C ******************************************************************* C C SUBROUTINE JANICE(NP,KV,X,KFLIP,ZSAB) IMPLICIT HALF PRECISION(A-H,O-Z) DIMENSION X(17000),KV(17000),KTP(34000),KSRT(50), CLSRT(50),XMID(50),XX(50) BIT U1,U2,U3,U4,U5 DESCRIPTOR U1,U2,U3,U4,U5 ASSIGN U1,.DYN.NP ASSIGN U2,.DYN.NP ASSIGN U3,.DYN.NP ASSIGN U4,.DYN.NP ASSIGN U5,.DYN.NP NP2=NP*2 U3=KV(1;NP).EQ.1 U4=KV(1;NP).EQ.6 DO 1 I=1,NP U1=Q8VMKO(I-1,NP;U1) U2=.NOT.U1 U5=U3.AND.U1 KY1=Q8SCNT(U5) U5=U4.AND.U2 KN1=Q8SCNT(U5) U5=U3.AND.U2 KY2=Q8SCNT(U5) U5=U4.AND.U1 KN2=Q8SCNT(U5) KTP(I)=KY1+KN1 KTP(I+NP)=KY2+KN2 1 CONTINUE JSAVE=1 DO 2 J=1,5 KK=Q8SMAXI(KTP(1;NP2)) KSRT(J)=KTP(KK+1) LSRT(J)=KK+1 KTP(KK+1)=-99 IF(KK.EQ.0)XMID(J)=X(1) IF(KK.EQ.NP)XMID(J)=X(1) IF(KK.GT.0.AND.KK.LT.NP)XMID(J)=(X(KK)+X(KK+1))/2.S0 IF(KK.EQ.NP2-1)XMID(J)=(X(NP)+X(NP-1))/2.S0 IF(KK.GT.NP.AND.KK.LT.NP2-1)XMID(J)=(X(KK-NP)+X(KK+1-NP))/2.S0 IF(J.EQ.1)GO TO 2 IF(KSRT(J).EQ.KSRT(1))JSAVE=JSAVE+1 2 CONTINUE IF(JSAVE.EQ.1)JJSAVE=1 IF(JSAVE.EQ.1)GO TO 4 XX(1;JSAVE)=VHABS(XMID(1;JSAVE);XX(1;JSAVE)) KK=Q8SMINI(XX(1;JSAVE)) JJSAVE=KK+1 4 ZSAB=XMID(JJSAVE) KFLIP=1 IF(LSRT(JJSAVE).GT.NP)KFLIP=2 KV(1)=KSRT(1) RETURN END C C C C **************************SUBROUTINE VTFUN************************** C CALCULATES THE LOG LIKELIHOOD FOR EACH ROLL CALL AND PERFORMS THE C BERNDT, HALL, HALL, AND HAUSMAN MAXIMUM LIKELIHOOD METHOD TO OBTAIN C NEW ESTIMATES OF THE MIDPOINT AND DISTANCE/NOISE PARAMETER FOR EACH C ROLL CALL. C ******************************************************************** C C C SUBROUTINE VTFUN(MOVE,NP,NFUNS,NFUNS3,KONVRG,B,D1YES,D1NO,KPRNT, CSAVLOG,SCURLG,V11,V12,V22,XCRIT,WTSQ) IMPLICIT HALF PRECISION (A-H,O-Z) DIMENSION B(10),DYES(1000),DNO(1000),WTSQ(1000),XY(1000), CXN(1000),XYEXP(1000),XNEXP(1000),XXY(1000),XXN(1000),XXYEXP(1000), CXXNEXP(1000),PHI(1000),XLNPHI(1000),X1(1000),X2(1000),X3(1000), CX4(1000),Y12(1000),Z12(1000),Y1234(1000),Z1234(1000),CROSS(1000), CPHIINV(1000),SAVEB(10),OLDB(10),D1YES(1000),D1NO(1000), CDTYES(1000),DTNO(1000) BIT IVYY,IVNN,IVNV,ISY,ISN,JSY,JSN,ISLEG,ISLEG2 COMMON /HUGE/ ISY(12000000),ISN(12000000),JSY(12000000), CJSN(12000000),ISLEG(989901),ISLEG2(989901) COMMON /HUGE2/ XI0(9999),XI1(9999),XI2(9999),XI3(9999), CZML(40000),DL(40000),L2P5RC(40000),LVTRC2(40000), CJLEG(33000,4),JRC(33000,3),XKEEP(9999,12),XEST(9999,3), CJJLEG(9999,5),DLMST(40000),ZMLMST(40000),XLGMST(33000), CJDUMMY(9999,5),JLEGA(40000,4),JRCA(33000,3),LDUMMY(33000), CZKEEP(40000,6),LKEEP(40000,3) COMMON /UTILS/ BETA(100),WTS(3),ICONST(3),MPOLY COMMON /KOFF/ XLEG(1000),IVYY(1000),IVNN(1000),IVNV(1000) COMMON /MSTR/ MASTER,MTOTCH,MPOOP, CXSPHI(50),XSYES(50),XSNO(50),KNOX(50) C C NFUNS = # OF ITERATIONS (MAX=20) C NFUNS2 = # OF FUNCTION EVALUATIONS PER ITERATION (MAX=20) C NFUNS3 = TOTAL # OF FUNCTION EVALUATIONS C KONVRG = 0 IF CONVERGENCE C KONVRG = 1 IF NFUNS=20 OR NFUNS2=20 C KONVRG = 9 IF DETERMINANT OF INFORMATION MATRIX IS ZERO C IVYY STORES LIBERAL VOTES FOR R.C. INV C IVNN STORES CONSERVATIVE VOTES FOR R.C. INV C IVNV STORES 1 IF I VOTED 0 IF I NOT-VOTED C IF(MOVE.EQ.1)GO TO 629 C WRITE(21,1409)MOVE,BETA(1;3) 1409 FORMAT(I5,3F10.4) C WRITE(21,1408)XLEG(1;5) C WRITE(21,1408)D1YES(1;5) C WRITE(21,1408)D1NO(1;5) C WRITE(21,1408)WTSQ(1;5) 1408 FORMAT(5F10.4) C STOP 629 CONTINUE INV=0 KONVRG=8 VTLOG=0.S0 NFUNS3=0 NFUNS=0 2000 NFUNS=NFUNS+1 IDERV=1 NFUNS2=0 SAVEB(1)=B(1) SAVEB(2)=B(2) 1000 CONTINUE C C CALCULATION OF LOG-LIKEIHOOD C STARTING LNL STORED IN SAVLOG C CURRENT LNL STORED IN SCURLG C NFUNS3=NFUNS3+1 NFUNS2=NFUNS2+1 SVLOG2=VTLOG DYES(1;NP)=XLEG(1;NP)-B(2)+B(1) DNO(1;NP)=XLEG(1;NP)-B(2)-B(1) DTYES(1;NP)=D1YES(1;NP)**2 + DYES(1;NP)**2 DTNO(1;NP)=D1NO(1;NP)**2 + DNO(1;NP)**2 XY(1;NP)=-WTSQ(1;NP)*DTYES(1;NP)*.5S0 XN(1;NP)=-WTSQ(1;NP)*DTNO(1;NP)*.5S0 XYEXP(1;NP)=VHEXP(XY(1;NP);XYEXP(1;NP)) XNEXP(1;NP)=VHEXP(XN(1;NP);XNEXP(1;NP)) XXY(1;NP)=BETA(MOVE)*XYEXP(1;NP) XXN(1;NP)=BETA(MOVE)*XNEXP(1;NP) XXYEXP(1;NP)=VHEXP(XXY(1;NP);XXYEXP(1;NP)) XXNEXP(1;NP)=VHEXP(XXN(1;NP);XXNEXP(1;NP)) PHI(1;NP)=XXYEXP(1;NP)+XXNEXP(1;NP) PHIINV(1;NP)=1.S0/PHI(1;NP) XLNPHI(1;NP)=VHLOG(PHI(1;NP);XLNPHI(1;NP)) CALL Q8SUM(X'80',,XLNPHI(1;NP),,,IVNV(1;NP),6) CALL Q8ADDNH(6,,SMLPHI) CALL Q8SUM(X'80',,XXY(1;NP),,,IVYY(1;NP),6) CALL Q8ADDNH(6,,SUMYES) CALL Q8SUM(X'80',,XXN(1;NP),,,IVNN(1;NP),6) CALL Q8ADDNH(6,,SUMNO) VTLOG=SUMYES+SUMNO-SMLPHI SCURLG=VTLOG IF(NFUNS3.EQ.1)SAVLOG=VTLOG IF(IDERV.EQ.0)GO TO 1001 C C CALCULATION OF THE GRADIENT VECTOR AND INFORMATION MATRIX C X1(1;NP)=WTSQ(1;NP)*DNO(1;NP)*XNEXP(1;NP) X2(1;NP)=WTSQ(1;NP)*DYES(1;NP)*XYEXP(1;NP) Y12(1;NP)=-X2(1;NP) Z12(1;NP)=X2(1;NP) X3(1;NP)=WTSQ(1;NP)*PHIINV(1;NP)*DNO(1;NP)*XNEXP(1;NP)* CXXNEXP(1;NP) X4(1;NP)=WTSQ(1;NP)*PHIINV(1;NP)*DYES(1;NP)*XYEXP(1;NP)* CXXYEXP(1;NP) CALL Q8SUM(X'80',,X1(1;NP),,,IVNN(1;NP),6) CALL Q8ADDNH(6,,S1) CALL Q8SUM(X'80',,X2(1;NP),,,IVYY(1;NP),6) CALL Q8ADDNH(6,,S2) CALL Q8SUM(X'80',,X3(1;NP),,,IVNV(1;NP),6) CALL Q8ADDNH(6,,S3) CALL Q8SUM(X'80',,X4(1;NP),,,IVNV(1;NP),6) CALL Q8ADDNH(6,,S4) G1=BETA(MOVE)*(S1-S2-S3+S4) G2=BETA(MOVE)*(S1+S2-S3-S4) Y12(1;NP)=Q8VCTRL(X1(1;NP),IVNN(1;NP);Y12(1;NP)) Z12(1;NP)=Q8VCTRL(X1(1;NP),IVNN(1;NP);Z12(1;NP)) Y1234(1;NP)=Y12(1;NP)-X3(1;NP)+X4(1;NP) Z1234(1;NP)=Z12(1;NP)-X3(1;NP)-X4(1;NP) CROSS(1;NP)=Y1234(1;NP)*Z1234(1;NP) Y1234(1;NP)=Y1234(1;NP)*Y1234(1;NP) Z1234(1;NP)=Z1234(1;NP)*Z1234(1;NP) CALL Q8SUM(X'80',,Y1234(1;NP),,,IVNV(1;NP),6) CALL Q8ADDNH(6,,V11) CALL Q8SUM(X'80',,Z1234(1;NP),,,IVNV(1;NP),6) CALL Q8ADDNH(6,,V22) CALL Q8SUM(X'80',,CROSS(1;NP),,,IVNV(1;NP),6) CALL Q8ADDNH(6,,V12) V11=V11*BETA(MOVE)*BETA(MOVE) V12=V12*BETA(MOVE)*BETA(MOVE) V22=V22*BETA(MOVE)*BETA(MOVE) DET=V11*V22-V12*V12 IF(DET.EQ.0.S0)KONVRG=9 IF(DET.EQ.0.S0)RETURN DETINV=1.S0/DET C C INVERSE INFO MATRIX TIMES GRADIENT VECTOR C DTST1=(V22*G1-V12*G2)*DETINV DTST2=(V11*G2-V12*G1)*DETINV C C ABOVE RESULT TIMES GRADIENT VECTOR AGAIN C IF INNER PRODUCT IS LESS THAT STOPPING CRITERIA (XCRIT) KONVRG=0 C XSTOP=(DTST1*G1+DTST2*G2) IF(XSTOP.LT.XCRIT)KONVRG=0 IF(KONVRG.EQ.0)GO TO 1011 IDERV=0 IF(NFUNS.LE.3)STEP=1.S0 B(1)=SAVEB(1)+STEP*DTST1 B(2)=SAVEB(2)+STEP*DTST2 SVLOG3=VTLOG IF(INV.NE.KPRNT)GO TO 223 NOISE=1 WRITE(23,222)NFUNS,NFUNS2,NFUNS3,KCTRL,NOISE,STEP,XSTOP,SCURLG, CSVLOG2,SVLOG3,B(1),B(2),SAVEB(1),SAVEB(2) 222 FORMAT(5I3,5E12.4/18X,4E12.4) 223 CONTINUE GO TO 1000 1001 CONTINUE C C STEPPING SECTION C C FIRST A STEP OF SIZE 1 IS PERFORMED (IF NFUNS .GT.3 OLD SIZE IS USED) C IF LNL IMPROVES, STEP SIZE IS DOUBLED UNTIL NO IMPROVEMENT. C IF LNL WORSENS, STEP SIZE IS HALVED UNTIL IMPROVEMENT C NOTE THE ASSYMETRY--YOU ONLY STEP BACKWARDS IF THE FIRST STEP OF C SIZE 1 FAILS C IF(NFUNS2.EQ.2.AND.VTLOG.GT.SVLOG2)STEP=STEP*2.S0 IF(NFUNS2.EQ.2.AND.VTLOG.GT.SVLOG2)KCTRL=1 IF(NFUNS2.EQ.2.AND.VTLOG.GT.SVLOG2)GO TO 1002 IF(NFUNS2.EQ.2.AND.VTLOG.LE.SVLOG2)STEP=STEP*0.5S0 IF(NFUNS2.EQ.2.AND.VTLOG.LE.SVLOG2)KCTRL=2 IF(NFUNS2.EQ.2.AND.KCTRL.EQ.2)VTLOG=SVLOG3 IF(NFUNS2.EQ.2.AND.KCTRL.EQ.2)GO TO 1002 IF(NFUNS2.GT.20)GO TO 1012 IF(KCTRL.EQ.1.AND.VTLOG.GT.SVLOG2)STEP=STEP*2.S0 IF(KCTRL.EQ.1.AND.VTLOG.GT.SVLOG2)GO TO 1002 IF(KCTRL.EQ.1.AND.VTLOG.LE.SVLOG2)GO TO 1010 IF(KCTRL.EQ.2.AND.VTLOG.GT.SVLOG2)GO TO 1010 IF(KCTRL.EQ.2.AND.VTLOG.LE.SVLOG2)STEP=STEP*0.5S0 IF(KCTRL.EQ.2.AND.VTLOG.LE.SVLOG2)VTLOG=SVLOG3 1002 IF(KCTRL.EQ.1)OLDB(1)=B(1) IF(KCTRL.EQ.1)OLDB(2)=B(2) B(1)=SAVEB(1)+STEP*DTST1 B(2)=SAVEB(2)+STEP*DTST2 IF(INV.NE.KPRNT)GO TO 224 NOISE=2 WRITE(23,222)NFUNS,NFUNS2,NFUNS3,KCTRL,NOISE,STEP,XSTOP,SCURLG, CSVLOG2,SVLOG3,B(1),B(2),SAVEB(1),SAVEB(2) 224 CONTINUE GO TO 1000 1010 CONTINUE IF(INV.NE.KPRNT)GO TO 225 NOISE=3 WRITE(23,222)NFUNS,NFUNS2,NFUNS3,KCTRL,NOISE,STEP,XSTOP,SCURLG, CSVLOG2,SVLOG3,B(1),B(2),SAVEB(1),SAVEB(2) 225 CONTINUE IF(KCTRL.EQ.1)B(1)=OLDB(1) IF(KCTRL.EQ.1)B(2)=OLDB(2) IF(NFUNS.LT.20)GO TO 2000 KONVRG=1 ITITR=NFUNS RETURN 1012 KONVRG=9 ITITR=NFUNS RETURN 1011 ITITR=NFUNS IF(INV.NE.KPRNT)GO TO 226 NOISE=4 WRITE(23,222)NFUNS,NFUNS2,NFUNS3,KCTRL,NOISE,STEP,XSTOP,SCURLG, CSVLOG2,SVLOG3,B(1),B(2),SAVEB(1),SAVEB(2) 226 CONTINUE RETURN END C C C C *************************SUBROUTINE VTWRT*************************** C WRITES OUT THE RESULTS FOR THE ROLL CALLS AND STORES NEW PARAMETER C VALUES IN ZML AND DL C ******************************************************************** C C C SUBROUTINE VTWRT(INV,JII,JJ,NFUNS,NFUNS3,KONVRG,B,SAVLOG, CSCURLG,V11,V12,V22,IPRNT,T1,T2) IMPLICIT HALF PRECISION (A-H,O-Z) DIMENSION B(10) COMMON /HUGE2/ XI0(9999),XI1(9999),XI2(9999),XI3(9999), CZML(40000),DL(40000),L2P5RC(40000),LVTRC2(40000), CJLEG(33000,4),JRC(33000,3),XKEEP(9999,12),XEST(9999,3), CJJLEG(9999,5),DLMST(40000),ZMLMST(40000),XLGMST(33000), CJDUMMY(9999,5),JLEGA(40000,4),JRCA(33000,3),LDUMMY(33000), CZKEEP(40000,6),LKEEP(40000,3) DET=V11*V22-V12*V12 IF(DET.EQ.0.S0)SE1=0.S0 IF(DET.EQ.0.S0)SE2=0.S0 IF(DET.EQ.0.S0)GO TO 1 SE1=HSQRT(HABS(V22/DET)) SE2=HSQRT(HABS(V11/DET)) V12=-V12/DET 1 CONTINUE T1=0.S0 T2=0.S0 IF(SE1.GT.0.S0)T1=B(1)/SE1 IF(SE2.GT.0.S0)T2=B(2)/SE2 IF(IPRNT.EQ.1)GO TO 2 WRITE(23,1000)INV,JII,JJ,SAVLOG,SCURLG,LVTRC2(INV),NFUNS,NFUNS3, CKONVRG,DL(INV),B(1),SE1,T1,V12,ZML(INV),B(2),SE2,T2 1000 FORMAT(1X,I5,2I4,2F10.4,2I2,I3,I2,4F9.4/30X,F13.4,4F9.4) 2 DL(INV)=B(1) ZML(INV)=B(2) RETURN END C C C C *************************SUBROUTINE VTZERO************************* C WHEN A ROLL CALL MIDPOINT IS CONSTRAINED TO EITHER -1 OR +1 AT C THE FIRST ITERATION, SUBSEQUENT ITERATIONS CALL THIS SUBROUTINE C WHICH SIMPLY CALCULATES THE LOG-LIKELIHOOD FOR THE CONSTRAINED C ROLL CALL AND SETS THE PARAMETERS TO BE WRITTEN OUT TO ZERO. C THE SUBROUTINE ALSO CALCULATES THE GEOMETRIC MEAN PROBABILITY AND C THE CROSS CLASSIFICATIONS OF CHOICES FOR EACH ROLL CALL. C ******************************************************************* C C C SUBROUTINE VTZERO(MOVE,INV,NP,NFUNS,NFUNS3,KONVRG,D1YES,D1NO, CB,SAVLOG,SCURLG,V11,V12,V22,WTSQ,KCALM) IMPLICIT HALF PRECISION (A-H,O-Z) DIMENSION B(10),DYES(1000),DNO(1000),WTSQ(1000),XY(1000), CXN(1000),XYEXP(1000),XNEXP(1000),XXY(1000),XXN(1000),XXYEXP(1000), CXXNEXP(1000),PHI(1000),XLNPHI(1000),PHIINV(1000),KCALM(4), CPROBY(1000),PROBN(1000),D1YES(1000),D1NO(1000),DTYES(1000), CDTNO(1000),LL(1000) BIT IVYY,IVNN,IVNV,ISY,ISN,JSY,JSN,ISLEG,AV, CBV,CV,DV,EV,ISLEG2 DESCRIPTOR AV,BV,CV,DV,EV COMMON /HUGE/ ISY(12000000),ISN(12000000),JSY(12000000), CJSN(12000000),ISLEG(989901),ISLEG2(989901) COMMON /HUGE2/ XI0(9999),XI1(9999),XI2(9999),XI3(9999), CZML(40000),DL(40000),L2P5RC(40000),LVTRC2(40000), CJLEG(33000,4),JRC(33000,3),XKEEP(9999,12),XEST(9999,3), CJJLEG(9999,5),DLMST(40000),ZMLMST(40000),XLGMST(33000), CJDUMMY(9999,5),JLEGA(40000,4),JRCA(33000,3),LDUMMY(33000), CZKEEP(40000,6),LKEEP(40000,3) COMMON /UTILS/ BETA(100),WTS(3),ICONST(3),MPOLY COMMON /KOFF/ XLEG(1000),IVYY(1000),IVNN(1000),IVNV(1000) ASSIGN AV,.DYN.NP ASSIGN BV,.DYN.NP ASSIGN CV,.DYN.NP ASSIGN DV,.DYN.NP ASSIGN EV,.DYN.NP 1000 FORMAT(I6,1X,250I1,250I1) NFUNS=0 NFUNS3=0 KONVRG=0 V11=0.S0 V12=0.S0 V22=0.S0 KSUM=Q8SCNT(IVNV(1;NP)) DYES(1;NP)=XLEG(1;NP)-B(2)+B(1) DNO(1;NP)=XLEG(1;NP)-B(2)-B(1) DTYES(1;NP)=D1YES(1;NP)**2 + DYES(1;NP)**2 DTNO(1;NP)=D1NO(1;NP)**2 + DNO(1;NP)**2 XY(1;NP)=-WTSQ(1;NP)*DTYES(1;NP)*.5S0 XN(1;NP)=-WTSQ(1;NP)*DTNO(1;NP)*.5S0 XYEXP(1;NP)=VHEXP(XY(1;NP);XYEXP(1;NP)) XNEXP(1;NP)=VHEXP(XN(1;NP);XNEXP(1;NP)) XXY(1;NP)=BETA(MOVE)*XYEXP(1;NP) XXN(1;NP)=BETA(MOVE)*XNEXP(1;NP) XXYEXP(1;NP)=VHEXP(XXY(1;NP);XXYEXP(1;NP)) XXNEXP(1;NP)=VHEXP(XXN(1;NP);XXNEXP(1;NP)) PHI(1;NP)=XXYEXP(1;NP)+XXNEXP(1;NP) PHIINV(1;NP)=1.S0/PHI(1;NP) XLNPHI(1;NP)=VHLOG(PHI(1;NP);XLNPHI(1;NP)) CALL Q8SUM(X'80',,XLNPHI(1;NP),,,IVNV(1;NP),6) CALL Q8ADDNH(6,,SMLPHI) CALL Q8SUM(X'80',,XXY(1;NP),,,IVYY(1;NP),6) CALL Q8ADDNH(6,,SUMYES) CALL Q8SUM(X'80',,XXN(1;NP),,,IVNN(1;NP),6) CALL Q8ADDNH(6,,SUMNO) SCURLG=SUMYES+SUMNO-SMLPHI SAVLOG=SCURLG PROBY(1;NP)=XXYEXP(1;NP)*PHIINV(1;NP) PROBN(1;NP)=XXNEXP(1;NP)*PHIINV(1;NP) AV=PROBY(1;NP).GE.PROBN(1;NP) BV=PROBY(1;NP).LT.PROBN(1;NP) LL(1;NP)=0 WHERE(AV)LL(1;NP)=1 IF(KCALM(1).EQ.-99)WRITE(25,1000)INV,LL(1;NP) DV=IVYY(1;NP) EV=IVNN(1;NP) CV=AV.AND.DV KCALM(1)=Q8SCNT(CV) CV=AV.AND.EV KCALM(2)=Q8SCNT(CV) CV=BV.AND.DV KCALM(3)=Q8SCNT(CV) CV=BV.AND.EV KCALM(4)=Q8SCNT(CV) RETURN END C C C *************************SUBROUTINE XLGFUN************************** C CALCULATES THE LOG LIKELIHOOD FOR EACH LEGISLATOR AND PERFORMS THE C BERNDT, HALL, HALL, AND HAUSMAN MAXIMUM LIKELIHOOD METHOD TO OBTAIN C NEW ESTIMATES OF THE LEGISLATOR'S COORDINATE. C ******************************************************************** C C C SUBROUTINE XLGFUN(LKJI,JJJK,NP,NS,NCONG,NYRB,INP,NFUNS,NFUNS3, CKONVRG,B,SAVLOG,SCURLG,VVV,MARKER,KTOTV,NPOLY,XCRIT,KCALM) IMPLICIT HALF PRECISION (A-H,O-Z) DIMENSION B(10),DYES(1600),DNO(1600),WTSQ(1600),XY(1600), CXN(1600),XYEXP(1600),XNEXP(1600),XXY(1600),XXN(1600), CXXYEXP(1600),L2(100),L3(100),L4(100),TX(100,4),BBETA(100), CVVV(50),X3(1600),CROSS(1600),D1YES(1600),D1NO(1600), CXXNEXP(1600),PHI(1600),XLNPHI(1600),X1(1600),X2(1600), CX4(1600),Y12(1600),Z12(1600),Y1234(1600),Z1234(1600), CPHIINV(1600),SAVEB(10),OLDB(10),WEIGHT(1600),WWW(10), CMARKER(100,11),KCALM(4),PROBY(1600),PROBN(1600) BIT IVYY(1600),IVNN(1600),IVNV(1600),ISY,ISN,JSY,JSN, CIS0(33000),IS1(1600),ISLEG,AV(1600),BV(1600),CV(1600), CISLEG2 COMMON /HUGE/ ISY(12000000),ISN(12000000),JSY(12000000), CJSN(12000000),ISLEG(989901),ISLEG2(989901) COMMON /HUGE2/ XI0(9999),XI1(9999),XI2(9999),XI3(9999), CZML(40000),DL(40000),L2P5RC(40000),LVTRC2(40000), CJLEG(33000,4),JRC(33000,3),XKEEP(9999,12),XEST(9999,3), CJJLEG(9999,5),DLMST(40000),ZMLMST(40000),XLGMST(33000), CJDUMMY(9999,5),JLEGA(40000,4),JRCA(33000,3),LDUMMY(33000), CZKEEP(40000,6),LKEEP(40000,3) COMMON /UTILS/ BETA(100),WTS(3),ICONST(3),MPOLY COMMON /MSTR/ MASTER,MTOTCH,MPOOP, CXSPHI(50),XSYES(50),XSNO(50),KNOX(50) C C INP = # OF LEGISLATOR C NFUNS = # OF ITERATIONS (MAX=20) C NFUNS2 = # OF FUNCTION EVALUATIONS PER ITERATION (MAX=20) C NFUNS3 = TOTAL # OF FUNCTION EVALUATIONS C KONVRG = 0 IF CONVERGENCE C KONVRG = 1 IF NFUNS=20 OR NFUNS2=20 C KONVRG = 9 IF DETERMINANT OF INFORMATION MATRIX IS ZERO C IVYY STORES LIBERAL VOTES FOR LEGISLATOR INV C IVNN STORES CONSERVATIVE VOTES FOR LEGISLATOR INV C IVNV STORES 1 IF I VOTED 0 IF I NOT-VOTED C KRETUR=0 IF(NFUNS3.EQ.-99)KRETUR=1 IS0(1;NP)=JLEG(1,1;NP).EQ.JJLEG(INP,2) KYRS=JJLEG(INP,1) MPOOP=KYRS L2(1;KYRS)=Q8VCMPRS(JRC(1,2;NP),IS0(1;NP);L2(1;KYRS)) L3(1;KYRS)=Q8VCMPRS(JRC(1,3;NP),IS0(1;NP);L3(1;KYRS)) IS1(1;NCONG)=ISLEG2((INP-1)*NCONG+1;NCONG) X1(1;NCONG)=0.S0 WHERE(ISLEG2((INP-1)*NCONG+1;NCONG)) X1(1;NCONG)=1.S0 IF(NFUNS3.NE.-999)GO TO 303 KK=0 DO 302 JJ=1,NCONG IF(X1(JJ).EQ.0.S0)GO TO 302 KK=KK+1 IF(JJ.NE.NFUNS)GO TO 302 L2(1)=L2(KK) L3(1)=L3(KK) KYRS=1 MPOOP=KYRS GO TO 303 302 CONTINUE 303 CONTINUE IF(NFUNS3.EQ.-999)X1(1;NCONG)=0.S0 IF(NFUNS3.EQ.-999)X1(NFUNS)=1.S0 IS1(1;NCONG)=X1(1;NCONG).EQ.1.S0 XSTART=-1.S0 IF(KYRS.GE.2)XINC=2.S0/HALF(KYRS-1) IF(KYRS.EQ.1)XINC=0.S0 KK=0 DO 2 JJ=1,NCONG IF(X1(JJ).EQ.0.S0)GO TO 2 KK=KK+1 BBETA(KK)=BETA(JJ) TX(KK,1)=XSTART TX(KK,2)=(3.S0*XSTART**2-1.S0)/2.S0 TX(KK,3)=(5.S0*XSTART**3-3.S0*XSTART)/2.S0 XSTART=XSTART+XINC 2 CONTINUE IF(KK.NE.KYRS)WRITE(21,1112)INP,KK,KYRS 1112 FORMAT(' XLGFUN',3I8) IF(KK.NE.KYRS)STOP L4(1;KYRS)=Q8VCMPRS(MARKER(1,11;NCONG),IS1(1;NCONG);L4(1;KYRS)) KPRNT=-99 KONVRG=8 VTLOG=0.S0 NFUNS3=0 NFUNS=0 2000 NFUNS=NFUNS+1 IDERV=1 NFUNS2=0 SAVEB(1;4)=B(1;4) 1000 CONTINUE C C CALCULATION OF LOG-LIKELIHOOD C STARTING LNL STORED IN SAVLOG C CURRENT LNL STORED IN SCURLG C NFUNS3=NFUNS3+1 NFUNS2=NFUNS2+1 SVLOG2=VTLOG KTOTV=0 SMLPHI=0.S0 SUMYES=0.S0 SUMNO=0.S0 VVV(1;10)=0.S0 G0=0.S0 G1=0.S0 G2=0.S0 G3=0.S0 C WRITE(21,1111)INP,L2(1;KYRS) C WRITE(21,1111)INP,L3(1;KYRS) C WRITE(21,1111)INP,L4(1;KYRS) C1111 FORMAT(I4,22I6) KCALM(1;4)=0 DO 1 JJ=1,KYRS NV=L2(JJ) NTV=L3(JJ) KB4=L4(JJ) IVNV(1;NV)=L2P5RC(KB4+1;NV).EQ.1 IVYY(1;NV)=ISY(NTV+1;NV).AND.IVNV(1;NV) IVNN(1;NV)=ISN(NTV+1;NV).AND.IVNV(1;NV) IVNV(1;NV)=IVYY(1;NV).OR.IVNN(1;NV) BX=B(1)+B(2)*TX(JJ,1)+B(3)*TX(JJ,2)+B(4)*TX(JJ,3) DYES(1;NV)=BX-ZML(KB4+1;NV)+DL(KB4+1;NV) DNO(1;NV)=BX-ZML(KB4+1;NV)-DL(KB4+1;NV) D1YES(1;NV)=0.S0 D1NO(1;NV)=0.S0 DO 609 L=1,NS IF(JJJK.EQ.L)GO TO 609 IF(LKJI.EQ.1.AND.L.GT.JJJK)GO TO 609 BXX=XKEEP(INP,(L-1)*4+1)+XKEEP(INP,(L-1)*4+2)*TX(JJ,1)+ CXKEEP(INP,(L-1)*4+3)*TX(JJ,2)+XKEEP(INP,(L-1)*4+4)*TX(JJ,3) D1YES(1;NV)=D1YES(1;NV)+(BXX-ZKEEP(KB4+1,(L-1)*2+2;NV)+ CZKEEP(KB4+1,(L-1)*2+1;NV))**2 D1NO(1;NV)=D1NO(1;NV)+(BXX-ZKEEP(KB4+1,(L-1)*2+2;NV)- CZKEEP(KB4+1,(L-1)*2+1;NV))**2 609 CONTINUE D1YES(1;NV)=VHSQRT(D1YES(1;NV);D1YES(1;NV)) D1NO(1;NV)=VHSQRT(D1NO(1;NV);D1NO(1;NV)) WEIGHT(1;NV)=WTS(1)+WTS(2)*BX+WTS(3)*BX*BX WTSQ(1;NV)=WEIGHT(1;NV)*WEIGHT(1;NV) XY(1;NV)=-WTSQ(1;NV)*(DYES(1;NV)*DYES(1;NV)+ CD1YES(1;NV)*D1YES(1;NV))*.5S0 XN(1;NV)=-WTSQ(1;NV)*(DNO(1;NV)*DNO(1;NV)+ CD1NO(1;NV)*D1NO(1;NV))*.5S0 XYEXP(1;NV)=VHEXP(XY(1;NV);XYEXP(1;NV)) XNEXP(1;NV)=VHEXP(XN(1;NV);XNEXP(1;NV)) XXY(1;NV)=BBETA(JJ)*XYEXP(1;NV) XXN(1;NV)=BBETA(JJ)*XNEXP(1;NV) XXYEXP(1;NV)=VHEXP(XXY(1;NV);XXYEXP(1;NV)) XXNEXP(1;NV)=VHEXP(XXN(1;NV);XXNEXP(1;NV)) PHI(1;NV)=XXYEXP(1;NV)+XXNEXP(1;NV) PHIINV(1;NV)=1.S0/PHI(1;NV) XLNPHI(1;NV)=VHLOG(PHI(1;NV);XLNPHI(1;NV)) CALL Q8SUM(X'80',,XLNPHI(1;NV),,,IVNV(1;NV),6) CALL Q8ADDNH(6,,SUM) SMLPHI=SMLPHI+SUM XSPHI(JJ)=SUM CALL Q8SUM(X'80',,XXY(1;NV),,,IVYY(1;NV),6) CALL Q8ADDNH(6,,SUM) SUMYES=SUMYES+SUM XSYES(JJ)=SUM CALL Q8SUM(X'80',,XXN(1;NV),,,IVNN(1;NV),6) CALL Q8ADDNH(6,,SUM) SUMNO=SUMNO+SUM XSNO(JJ)=SUM PROBY(1;NV)=XXYEXP(1;NV)*PHIINV(1;NP) PROBN(1;NV)=XXNEXP(1;NV)*PHIINV(1;NP) AV(1;NV)=PROBY(1;NV).GE.PROBN(1;NV) BV(1;NV)=PROBY(1;NV).LT.PROBN(1;NV) CV(1;NV)=AV(1;NV).AND.IVYY(1;NV) KCALM(1)=KCALM(1)+Q8SCNT(CV(1;NV)) CV(1;NV)=AV(1;NV).AND.IVNN(1;NV) KCALM(2)=KCALM(2)+Q8SCNT(CV(1;NV)) CV(1;NV)=BV(1;NV).AND.IVYY(1;NV) KCALM(3)=KCALM(3)+Q8SCNT(CV(1;NV)) CV(1;NV)=BV(1;NV).AND.IVNN(1;NV) KCALM(4)=KCALM(4)+Q8SCNT(CV(1;NV)) C C CALCULATION OF THE GRADIENT VECTOR AND INFORMATION MATRIX C X1(1;NV)=((DYES(1;NV)*DYES(1;NV)*WEIGHT(1;NV))*(WTS(2)+2.S0* CWTS(3)*BX)+(WTSQ(1;NV)*DYES(1;NV)))*XXY(1;NV) X2(1;NV)=((DNO(1;NV)*DNO(1;NV)*WEIGHT(1;NV))*(WTS(2)+2.S0* CWTS(3)*BX)+(WTSQ(1;NV)*DNO(1;NV)))*XXN(1;NV) X3(1;NV)=X1(1;NV)*XXYEXP(1;NV)*PHIINV(1;NV)+ C X2(1;NV)*XXNEXP(1;NV)*PHIINV(1;NV) Y12(1;NV)=X2(1;NV) Y12(1;NV)=Q8VCTRL(X1(1;NV),IVYY(1;NV);Y12(1;NV)) Z12(1;NV)=(X3(1;NV)-Y12(1;NV))**2 Z1234(1;NV)=X3(1;NV)-Y12(1;NV) CALL Q8SUM(X'80',,Z1234(1;NV),,,IVNV(1;NV),6) CALL Q8ADDNH(6,,SUM) G0=G0+SUM G1=G1+SUM*TX(JJ,1) G2=G2+SUM*TX(JJ,2) G3=G3+SUM*TX(JJ,3) CALL Q8SUM(X'80',,Z12(1;NV),,,IVNV(1;NV),6) CALL Q8ADDNH(6,,SUM) VVV(1)=VVV(1)+SUM VVV(2)=VVV(2)+SUM*TX(JJ,1) VVV(4)=VVV(4)+SUM*TX(JJ,2) VVV(7)=VVV(7)+SUM*TX(JJ,3) VVV(3)=VVV(3)+SUM*TX(JJ,1)*TX(JJ,1) VVV(5)=VVV(5)+SUM*TX(JJ,1)*TX(JJ,2) VVV(8)=VVV(8)+SUM*TX(JJ,1)*TX(JJ,3) VVV(6)=VVV(6)+SUM*TX(JJ,2)*TX(JJ,2) VVV(9)=VVV(9)+SUM*TX(JJ,2)*TX(JJ,3) VVV(10)=VVV(10)+SUM*TX(JJ,3)*TX(JJ,3) NOX=Q8SCNT(IVNV(1;NV)) KTOTV=KTOTV+NOX KNOX(JJ)=NOX 1 CONTINUE VTLOG=SUMYES+SUMNO-SMLPHI SCURLG=VTLOG IF(NFUNS3.EQ.1)SAVLOG=VTLOG IF(KRETUR.EQ.1)RETURN IF(IDERV.EQ.0)GO TO 1001 C C CALCULATION OF THE INVERSE INFORMATION MATRIX C IF(NPOLY.LT.3)GO TO 21 CALL HINVSPD(4,VVV,1,X1,NERR,5) GO TO 22 21 IF(NPOLY.LT.2)GO TO 23 WWW(1;6)=VVV(1;6) VVV(1;10)=0.S0 CALL HINVSPD(3,WWW,1,X1,NERR,5) VVV(1;6)=WWW(1;6) GO TO 22 23 IF(NPOLY.LT.1)GO TO 24 WWW(1;3)=VVV(1;3) VVV(1;10)=0.S0 CALL HINVSPD(2,WWW,1,X1,NERR,5) VVV(1;3)=WWW(1;3) GO TO 22 24 IF(VVV(1).EQ.0.S0)NERR=99 IF(VVV(1).EQ.0.S0)WRITE(23,112) 112 FORMAT(' HOLY MOSES GOOD BUDDY') IF(VVV(1).EQ.0.S0)GO TO 25 VVV(1)=1.S0/VVV(1) NERR=0 25 VVV(2;10)=0.S0 22 CONTINUE IF(NERR.NE.0)KONVRG=9 IF(NERR.NE.0)RETURN C C INVERSE INFO MATRIX TIMES GRADIENT VECTOR C DTST1=VVV(1)*G0+VVV(2)*G1+VVV(4)*G2+VVV(7)*G3 DTST2=VVV(2)*G0+VVV(3)*G1+VVV(5)*G2+VVV(8)*G3 DTST3=VVV(4)*G0+VVV(5)*G1+VVV(6)*G2+VVV(9)*G3 DTST4=VVV(7)*G0+VVV(8)*G1+VVV(9)*G2+VVV(10)*G3 C C ABOVE RESULT TIMES GRADIENT VECTOR AGAIN C IF INNER PRODUCT IS LESS THAT STOPPING CRITERIA (XCRIT) KONVRG=0 C XSTOP=DTST1*G0+DTST2*G1+DTST3*G2+DTST4*G3 IF(XSTOP.LT.XCRIT)KONVRG=0 IF(KONVRG.EQ.0)GO TO 1011 IDERV=0 IF(NFUNS.LE.3)STEP=1.S0 B(1)=SAVEB(1)+STEP*DTST1 B(2)=SAVEB(2)+STEP*DTST2 B(3)=SAVEB(3)+STEP*DTST3 B(4)=SAVEB(4)+STEP*DTST4 SVLOG3=VTLOG IF(INP.NE.KPRNT)GO TO 223 NOISE=1 WRITE(23,222)NFUNS,NFUNS2,NFUNS3,KCTRL,NOISE,STEP,XSTOP,SCURLG, CSVLOG2,SVLOG3,(B(JJJ),JJJ=1,4),(SAVEB(JJJ),JJJ=1,4) 222 FORMAT(5I3,5E12.4/15X,4E12.4/15X,4E12.4) 223 CONTINUE GO TO 1000 1001 CONTINUE C C STEPPING SECTION C C FIRST A STEP OF SIZE 1 IS PERFORMED (IF NFUNS .GT.3 OLD SIZE IS USED) C IF LNL IMPROVES, STEP SIZE IS DOUBLED UNTIL NO IMPROVEMENT. C IF LNL WORSENS, STEP SIZE IS HALVED UNTIL IMPROVEMENT C NOTE THE ASSYMETRY--YOU ONLY STEP BACKWARDS IF THE FIRST STEP OF C SIZE 1 FAILS C IF(NFUNS2.EQ.2.AND.VTLOG.GT.SVLOG2)STEP=STEP*2.S0 IF(NFUNS2.EQ.2.AND.VTLOG.GT.SVLOG2)KCTRL=1 IF(NFUNS2.EQ.2.AND.VTLOG.GT.SVLOG2)GO TO 1002 IF(NFUNS2.EQ.2.AND.VTLOG.LE.SVLOG2)STEP=STEP*0.5S0 IF(NFUNS2.EQ.2.AND.VTLOG.LE.SVLOG2)KCTRL=2 IF(NFUNS2.EQ.2.AND.KCTRL.EQ.2)VTLOG=SVLOG3 IF(NFUNS2.EQ.2.AND.KCTRL.EQ.2)GO TO 1002 IF(NFUNS2.GT.20)GO TO 1012 IF(KCTRL.EQ.1.AND.VTLOG.GT.SVLOG2)STEP=STEP*2.S0 IF(KCTRL.EQ.1.AND.VTLOG.GT.SVLOG2)GO TO 1002 IF(KCTRL.EQ.1.AND.VTLOG.LE.SVLOG2)GO TO 1010 IF(KCTRL.EQ.2.AND.VTLOG.GT.SVLOG2)GO TO 1010 IF(KCTRL.EQ.2.AND.VTLOG.LE.SVLOG2)STEP=STEP*0.5S0 IF(KCTRL.EQ.2.AND.VTLOG.LE.SVLOG2)VTLOG=SVLOG3 1002 IF(KCTRL.EQ.1)OLDB(1)=B(1) IF(KCTRL.EQ.1)OLDB(2)=B(2) IF(KCTRL.EQ.1)OLDB(3)=B(3) IF(KCTRL.EQ.1)OLDB(4)=B(4) B(1)=SAVEB(1)+STEP*DTST1 B(2)=SAVEB(2)+STEP*DTST2 B(3)=SAVEB(3)+STEP*DTST3 B(4)=SAVEB(4)+STEP*DTST4 IF(INP.NE.KPRNT)GO TO 224 NOISE=2 WRITE(23,222)NFUNS,NFUNS2,NFUNS3,KCTRL,NOISE,STEP,XSTOP,SCURLG, CSVLOG2,SVLOG3,(B(JJJ),JJJ=1,4),(SAVEB(JJJ),JJJ=1,4) 224 CONTINUE GO TO 1000 1010 CONTINUE IF(INP.NE.KPRNT)GO TO 225 NOISE=3 WRITE(23,222)NFUNS,NFUNS2,NFUNS3,KCTRL,NOISE,STEP,XSTOP,SCURLG, CSVLOG2,SVLOG3,(B(JJJ),JJJ=1,4),(SAVEB(JJJ),JJJ=1,4) 225 CONTINUE IF(KCTRL.EQ.1)B(1)=OLDB(1) IF(KCTRL.EQ.1)B(2)=OLDB(2) IF(KCTRL.EQ.1)B(3)=OLDB(3) IF(KCTRL.EQ.1)B(4)=OLDB(4) IF(NFUNS.LT.20)GO TO 2000 KONVRG=1 ITITR=NFUNS RETURN 1012 KONVRG=9 ITITR=NFUNS RETURN 1011 ITITR=NFUNS IF(INP.NE.KPRNT)GO TO 226 NOISE=4 WRITE(23,222)NFUNS,NFUNS2,NFUNS3,KCTRL,NOISE,STEP,XSTOP,SCURLG, CSVLOG2,SVLOG3,(B(JJJ),JJJ=1,4),(SAVEB(JJJ),JJJ=1,4) 226 CONTINUE RETURN END C C C C *************************SUBROUTINE XLGWRT************************* C WRITES OUT THE RESULTS FOR THE LEGISLATORS AND STORES THE NEW C COORDINATES IN XLEG C ******************************************************************* C C C SUBROUTINE XLGWRT(INP,NFUNS,NFUNS3,KONVRG,B,SAVLOG,SCURLG,VVV, CIPRNT,T1,T2,T3,T4) IMPLICIT HALF PRECISION (A-H,O-Z) DIMENSION B(10),VVV(10) COMMON /HUGE2/ XI0(9999),XI1(9999),XI2(9999),XI3(9999), CZML(40000),DL(40000),L2P5RC(40000),LVTRC2(40000), CJLEG(33000,4),JRC(33000,3),XKEEP(9999,12),XEST(9999,3), CJJLEG(9999,5),DLMST(40000),ZMLMST(40000),XLGMST(33000), CJDUMMY(9999,5),JLEGA(40000,4),JRCA(33000,3),LDUMMY(33000), CZKEEP(40000,6),LKEEP(40000,3) IF(VVV(1).EQ.0.S0)SE1=0.S0 IF(VVV(3).EQ.0.S0)SE2=0.S0 IF(VVV(6).EQ.0.S0)SE3=0.S0 IF(VVV(10).EQ.0.S0)SE4=0.S0 IF(VVV(1).NE.0.S0)SE1=HSQRT(HABS(VVV(1))) IF(VVV(3).NE.0.S0)SE2=HSQRT(HABS(VVV(3))) IF(VVV(6).NE.0.S0)SE3=HSQRT(HABS(VVV(6))) IF(VVV(10).NE.0.S0)SE4=HSQRT(HABS(VVV(10))) T1=0.S0 T2=0.S0 T3=0.S0 T4=0.S0 IF(SE1.GT.0.S0)T1=B(1)/SE1 IF(SE2.GT.0.S0)T2=B(2)/SE2 IF(SE3.GT.0.S0)T3=B(3)/SE3 IF(SE4.GT.0.S0)T4=B(4)/SE4 IF(IPRNT.EQ.1)GO TO 2 WRITE(23,1000)INP,SAVLOG,SCURLG,NFUNS,NFUNS3,KONVRG,XI0(INP), CB(1),SE1,T1,VVV(2),XI1(INP),B(2),SE2,T2,VVV(4),VVV(5),XI2(INP), CB(3),SE3,T3,VVV(7),VVV(8),VVV(9),XI3(INP),B(4),SE4,T4 1000 FORMAT(1X,I4,2F13.4,3I4,4F9.4/34X,5F9.4/25X,6F9.4/16X,7F9.4) 2 XI0(INP)=B(1) XI1(INP)=B(2) XI2(INP)=B(3) XI3(INP)=B(4) RETURN END C C C C *************************SUBROUTINE ONEPLT************************* C PRODUCES ONE DIMENSIONAL HISTOGRAM. CALLED BY PLOTIT. C ******************************************************************* C C C SUBROUTINE ONEPLT(NP,NQ,NCURR,Q,XMAX,J6) HALF PRECISION Q,XMAX,XINC,AA,AB DIMENSION Q(9999),KOUNT(50),IPOINT(50,75) LOGICAL IPOINT,ICAR,S1,S2,SB DATA SB,S1,S2/1H ,1H#,1H*/ 100 FORMAT(1X,F5.2,'/',F5.2,2X,I3,2X,75A1) 200 FORMAT('1') 210 FORMAT(41X,'PLOT OF DIMENSION',I2,4X,'NUMBER NOT PLOTTED',I4) 220 FORMAT('0') NPQ=NP+NQ ICAR=SB DO 9 I=1,50 KOUNT(I)=0 DO 99 J=1,75 99 IPOINT(I,J)=ICAR 9 CONTINUE XINC=2.S0*XMAX/50.S0 KKK=0 DO 10 J=1,NPQ ICAR=S1 IF(J.GT.NQ)ICAR=S2 IF(Q(J).GT.XMAX.OR.Q(J).LT.-XMAX)KKK=KKK+1 IF(Q(J).GT.XMAX.OR.Q(J).LT.-XMAX)GO TO 10 AA=XMAX KK=1 1 CONTINUE AB=AA-XINC IF(Q(J).LE.AA.AND.Q(J).GT.AB)GO TO 2 KK=KK+1 AA=AB GO TO 1 2 KOUNT(KK)=KOUNT(KK)+1 IF(KOUNT(KK).GT.75)GO TO 10 IPOINT(KK,KOUNT(KK))=ICAR 10 CONTINUE WRITE(J6,200) WRITE(J6,210)NCURR,KKK WRITE(J6,220) AA=-XMAX DO 11 I=1,50 AB=AA+XINC KK=KOUNT(51-I) WRITE(J6,100)AA,AB,KK,(IPOINT(51-I,J),J=1,75) 11 AA=AB RETURN END C C C C *************************SUBROUTINE BTAFUN************************** C CALCULATES THE LOB LIKELIHOOD FOR THE BETA PARAMETER AND PERFORMS C THE BERNDT, HALL, HALL, AND HAUSMAN MAXIMUM LIKELIHOOD METHOD TO C OBTAIN A NEW ESTIMATE OF BETA. THE LOG LIKELIHOOD IS CONVEX IN C BETA. C ******************************************************************** C C SUBROUTINE BTAFUN(LKJI,JJJK,NP,NS,NYRB,NFUNS,NFUNS3,KONVRG, CXBETA,SAVLOG,SCURLG,V11,XCRIT,XLEG,XLEG1,XLEG2,MARKER,KSUM, CLSAVE,KPRNT) IMPLICIT HALF PRECISION (A-H,O-Z) DIMENSION DYES(1600),DNO(1600),WTSQ(1600),XY(1600),XN(1600), CXYEXP(1600),XNEXP(1600),XXY(1600),XXN(1600),XXYEXP(1600), CXXNEXP(1600),PHI(1600),PHIINV(1600),XLNPHI(1600),X1(1600), CX2(1600),X3(1600),X4(1600),X5(1600),XLEG(40000),LSAVE(40000), CMARKER(100,11),XLEG1(40000),XLEG2(40000),D1YES(1600),D1NO(1600) BIT ISY,ISN,JSY,JSN,ISLEG,IVYY(1600),IVNN(1600), CIVNV(1600),ISLEG2 COMMON /HUGE/ ISY(12000000),ISN(12000000),JSY(12000000), CJSN(12000000),ISLEG(989901),ISLEG2(989901) COMMON /HUGE2/ XI0(9999),XI1(9999),XI2(9999),XI3(9999), CZML(40000),DL(40000),L2P5RC(40000),LVTRC2(40000), CJLEG(33000,4),JRC(33000,3),XKEEP(9999,12),XEST(9999,3), CJJLEG(9999,5),DLMST(40000),ZMLMST(40000),XLGMST(33000), CJDUMMY(9999,5),JLEGA(40000,4),JRCA(33000,3),LDUMMY(33000), CZKEEP(40000,6),LKEEP(40000,3) COMMON /UTILS/ BETA(100),WTS(3),ICONST(3),MPOLY KONVRG=8 NFUNS3=0 NFUNS=0 2000 NFUNS=NFUNS+1 IDERV=1 NFUNS2=0 SAVEB=XBETA 1000 CONTINUE C C CALCULATION OF LOG-LIKELIHOOD C STARTING LNL STORED IN SAVLOG C CURRENT LNL STORED IN SCURLG C NFUNS3=NFUNS3+1 NFUNS2=NFUNS2+1 SVLOG2=VTLOG VTLOG=0.S0 G1=0.S0 GSQ1=0.S0 GSQ2=0.S0 KSUM=0 DO 1 I=1,NP IF(LSAVE(I).EQ.0)GO TO 1 K01=JRC(I,1)-NYRB NV=MARKER(K01,2) NICUMV=MARKER(K01,11) K02=JRC(I,3) IVNV(1;NV)=L2P5RC(NICUMV+1;NV).EQ.1 IVYY(1;NV)=ISY(K02+1;NV).AND.IVNV(1;NV) IVNN(1;NV)=ISN(K02+1;NV).AND.IVNV(1;NV) IVNV(1;NV)=IVYY(1;NV).OR.IVNN(1;NV) KSUM=KSUM+Q8SCNT(IVNV(1;NV)) DYES(1;NV)=XLEG(I)-ZML(NICUMV+1;NV)+DL(NICUMV+1;NV) DNO(1;NV)=XLEG(I)-ZML(NICUMV+1;NV)-DL(NICUMV+1;NV) D1YES(1;NV)=0.S0 D1NO(1;NV)=0.S0 LSICK=0 DO 609 L=1,NS IF(L.EQ.JJJK)GO TO 609 IF(LKJI.EQ.1.AND.L.GT.JJJK)GO TO 609 LSICK=LSICK+1 IF(LSICK.EQ.1)D1YES(1;NV)=D1YES(1;NV)+(XLEG1(I)- CZKEEP(NICUMV+1,(L-1)*2+2;NV)+ CZKEEP(NICUMV+1,(L-1)*2+1;NV))**2 IF(LSICK.EQ.1)D1NO(1;NV)=D1NO(1;NV)+(XLEG1(I)- CZKEEP(NICUMV+1,(L-1)*2+2;NV)- CZKEEP(NICUMV+1,(L-1)*2+1;NV))**2 IF(LSICK.EQ.2)D1YES(1;NV)=D1YES(1;NV)+(XLEG2(I)- CZKEEP(NICUMV+1,(L-1)*2+2;NV)+ CZKEEP(NICUMV+1,(L-1)*2+1;NV))**2 IF(LSICK.EQ.2)D1NO(1;NV)=D1NO(1;NV)+(XLEG2(I)- CZKEEP(NICUMV+1,(L-1)*2+2;NV)- CZKEEP(NICUMV+1,(L-1)*2+1;NV))**2 609 CONTINUE D1YES(1;NV)=VHSQRT(D1YES(1;NV);D1YES(1;NV)) D1NO(1;NV)=VHSQRT(D1NO(1;NV);D1NO(1;NV)) WTSQ(1;NV)=(WTS(1)+WTS(2)*XLEG(I)+WTS(3)*XLEG(I)*XLEG(I))**2 XY(1;NV)=-WTSQ(1;NV)*(DYES(1;NV)*DYES(1;NV)+ CD1YES(1;NV)*D1YES(1;NV))*.5S0 XN(1;NV)=-WTSQ(1;NV)*(DNO(1;NV)*DNO(1;NV)+ CD1NO(1;NV)*D1NO(1;NV))*.5S0 XYEXP(1;NV)=VHEXP(XY(1;NV);XYEXP(1;NV)) XNEXP(1;NV)=VHEXP(XN(1;NV);XNEXP(1;NV)) XXY(1;NV)=XBETA*XYEXP(1;NV) XXN(1;NV)=XBETA*XNEXP(1;NV) XXYEXP(1;NV)=VHEXP(XXY(1;NV);XXYEXP(1;NV)) XXNEXP(1;NV)=VHEXP(XXN(1;NV);XXNEXP(1;NV)) PHI(1;NV)=XXYEXP(1;NV)+XXNEXP(1;NV) PHIINV(1;NV)=1.S0/PHI(1;NV) XLNPHI(1;NV)=VHLOG(PHI(1;NV);XLNPHI(1;NV)) CALL Q8SUM(X'80',,XLNPHI(1;NV),,,IVNV(1;NV),6) CALL Q8ADDNH(6,,SMLPHI) CALL Q8SUM(X'80',,XXY(1;NV),,,IVYY(1;NV),6) CALL Q8ADDNH(6,,SUMYES) CALL Q8SUM(X'80',,XXN(1;NV),,,IVNN(1;NV),6) CALL Q8ADDNH(6,,SUMNO) XHELLO=SUMYES+SUMNO-SMLPHI VTLOG=VTLOG+SUMYES+SUMNO-SMLPHI CALL Q8SUM(X'80',,XYEXP(1;NV),,,IVYY(1;NV),6) CALL Q8ADDNH(6,,DUMY) CALL Q8SUM(X'80',,XNEXP(1;NV),,,IVNN(1;NV),6) CALL Q8ADDNH(6,,DUMN) X1(1;NV)=XYEXP(1;NV)*XXYEXP(1;NV)*PHIINV(1;NV) X2(1;NV)=XNEXP(1;NV)*XXNEXP(1;NV)*PHIINV(1;NV) CALL Q8SUM(X'80',,X1(1;NV),,,IVNV(1;NV),6) CALL Q8ADDNH(6,,EUMY) CALL Q8SUM(X'80',,X2(1;NV),,,IVNV(1;NV),6) CALL Q8ADDNH(6,,EUMN) G1=G1+DUMY+DUMN-EUMY-EUMN GSQ1=GSQ1+G1*G1 X3(1;NV)=XNEXP(1;NV) X3(1;NV)=Q8VCTRL(XYEXP(1;NV),IVYY(1;NV);X3(1;NV)) X4(1;NV)=(X3(1;NV)-X1(1;NV)-X2(1;NV))**2 CALL Q8SUM(X'80',,X4(1;NV),,,IVNV(1;NV),6) CALL Q8ADDNH(6,,DUMM) GSQ2=GSQ2+DUMM 1 CONTINUE C WRITE(23,111)VTLOG,G1,GSQ1,GSQ2 111 FORMAT(4E19.10) SCURLG=VTLOG IF(NFUNS3.EQ.1)SAVLOG=VTLOG IF(IDERV.EQ.0)GO TO 1001 V11=GSQ2 IF(V11.EQ.0.S0)KONVRG=9 IF(V11.EQ.0.S0)RETURN C C INVERSE INFO MATRIX (SCALAR) TIMES GRADIENT VECTOR C DTST1=G1/V11 C C ABOVE RESULT TIMES GRADIENT VECTOR AGAIN C IF INNER PRODUCT IS LESS THAT STOPPING CRITERIA (XCRIT) KONVRG=0 C XSTOP=DTST1*G1 IF(XSTOP.LT.XCRIT)KONVRG=0 IF(KONVRG.EQ.0)GO TO 1011 IDERV=0 IF(NFUNS.LE.3)STEP=1.S0 XBETA=SAVEB+STEP*DTST1 SVLOG3=VTLOG IF(KPRNT.NE.1)GO TO 223 NOISE=1 WRITE(23,222)NFUNS,NFUNS2,NFUNS3,KCTRL,NOISE,STEP,XSTOP,SCURLG, CSVLOG2,SVLOG3,XBETA,SAVEB,OLDB 222 FORMAT(5I3,5E12.4/18X,3E12.4) 223 CONTINUE GO TO 1000 1001 CONTINUE C C STEPPING SECTION C C FIRST A STEP OF SIZE 1 IS PERFORMED (IF NFUNS .GT.3 OLD SIZE IS USED) C IF LNL IMPROVES, STEP SIZE IS DOUBLED UNTIL NO IMPROVEMENT. C IF LNL WORSENS, STEP SIZE IS HALVED UNTIL IMPROVEMENT C NOTE THE ASSYMETRY--YOU ONLY STEP BACKWARDS IF THE FIRST STEP OF C SIZE 1 FAILS C IF(NFUNS2.EQ.2.AND.VTLOG.GT.SVLOG2)STEP=STEP*2.S0 IF(NFUNS2.EQ.2.AND.VTLOG.GT.SVLOG2)KCTRL=1 IF(NFUNS2.EQ.2.AND.VTLOG.GT.SVLOG2)GO TO 1002 IF(NFUNS2.EQ.2.AND.VTLOG.LE.SVLOG2)STEP=STEP*0.5S0 IF(NFUNS2.EQ.2.AND.VTLOG.LE.SVLOG2)KCTRL=2 IF(NFUNS2.EQ.2.AND.KCTRL.EQ.2)VTLOG=SVLOG3 IF(NFUNS2.EQ.2.AND.KCTRL.EQ.2)GO TO 1002 IF(NFUNS2.GT.20)GO TO 1012 IF(KCTRL.EQ.1.AND.VTLOG.GT.SVLOG2)STEP=STEP*2.S0 IF(KCTRL.EQ.1.AND.VTLOG.GT.SVLOG2)GO TO 1002 IF(KCTRL.EQ.1.AND.VTLOG.LE.SVLOG2)GO TO 1010 IF(KCTRL.EQ.2.AND.VTLOG.GT.SVLOG2)GO TO 1010 IF(KCTRL.EQ.2.AND.VTLOG.LE.SVLOG2)STEP=STEP*0.5S0 IF(KCTRL.EQ.2.AND.VTLOG.LE.SVLOG2)VTLOG=SVLOG3 1002 IF(KCTRL.EQ.1)OLDB=XBETA XBETA=SAVEB+STEP*DTST1 IF(KPRNT.NE.1)GO TO 224 NOISE=2 WRITE(23,222)NFUNS,NFUNS2,NFUNS3,KCTRL,NOISE,STEP,XSTOP,SCURLG, CSVLOG2,SVLOG3,XBETA,SAVEB,OLDB 224 CONTINUE GO TO 1000 1010 CONTINUE IF(KPRNT.NE.1)GO TO 225 NOISE=3 WRITE(23,222)NFUNS,NFUNS2,NFUNS3,KCTRL,NOISE,STEP,XSTOP,SCURLG, CSVLOG2,SVLOG3,XBETA,SAVEB,OLDB 225 CONTINUE IF(KCTRL.EQ.1)XBETA=OLDB IF(NFUNS.LT.20)GO TO 2000 KONVRG=1 RETURN 1012 KONVRG=9 RETURN 1011 CONTINUE IF(KPRNT.NE.1)GO TO 226 NOISE=4 WRITE(23,222)NFUNS,NFUNS2,NFUNS3,KCTRL,NOISE,STEP,XSTOP,SCURLG, CSVLOG2,SVLOG3,XBETA,SAVEB,OLDB 226 CONTINUE RETURN END C C C C *************************SUBROUTINE BTAWRT************************** C WRITES OUT THE RESULTS FOR THE BETA ESTIMATION AND STORES XBETA IN C BETA C ******************************************************************** C C SUBROUTINE BTAWRT(MOVE,NFUNS,NFUNS3,KONVRG,XBETA,SAVLOG,SCURLG, CV11) IMPLICIT HALF PRECISION (A-H,O-Z) COMMON /UTILS/ BETA(100),WTS(3),ICONST(3),MPOLY IF(V11.EQ.0.S0)SE=0.S0 IF(V11.EQ.0.S0)GO TO 1 SE=HSQRT(HABS(1.S0/V11)) 1 T=0.S0 IF(SE.GT.0.S0)T=XBETA/SE WRITE(23,1000)MOVE,SAVLOG,SCURLG,NFUNS,NFUNS3,KONVRG,BETA(MOVE), CXBETA,SE,T 1000 FORMAT(I4,2F13.4,3I4,4F9.4) BETA(MOVE)=XBETA RETURN END C C C C *************************SUBROUTINE RRSQR************************** C PERFORMS A REGRESSION OF THE CURRENT PARAMETERS ON THE PARAMETERS C OF THE PREVIOUS ITERATION AND REPORTS AN INTERCEPT, A SLOPE, AND C THE R-SQUARE OF THE REGRESSION C ******************************************************************* C C C SUBROUTINE RRSQR(I1,I2,I3,NX,NP,NV,NSTEP,RR1,RR2, CALP1,ALP2,BTA1,BTA2,D1) IMPLICIT HALF PRECISION (A-H,O-Z) DIMENSION D1(40000),SCRAP(40000) COMMON /HUGE2/ XI0(9999),XI1(9999),XI2(9999),XI3(9999), CZML(40000),DL(40000),L2P5RC(40000),LVTRC2(40000), CJLEG(33000,4),JRC(33000,3),XKEEP(9999,12),XEST(9999,3), CJJLEG(9999,5),DLMST(40000),ZMLMST(40000),XLGMST(33000), CJDUMMY(9999,5),JLEGA(40000,4),JRCA(33000,3),LDUMMY(33000), CZKEEP(40000,6),LKEEP(40000,3) AAA=0.S0 BBB=0.S0 CCC=0.S0 DDD=0.S0 EEE=0.S0 IF(NSTEP.EQ.2)GO TO 10 SCRAP(1;NV)=ZKEEP(1,(I2-1)*2+1;NV) IF(I1.EQ.1.AND.I2.GT.1.AND.I3.EQ.1)SCRAP(1;NV)= CZKEEP(1,(I2-2)*2+1;NV) A=Q8SDOT(SCRAP(1;NV),DL(1;NV)) B=Q8SDOT(SCRAP(1;NV),SCRAP(1;NV)) C=Q8SDOT(DL(1;NV),DL(1;NV)) D=Q8SSUM(SCRAP(1;NV)) E=Q8SSUM(DL(1;NV)) IF(NSTEP.EQ.1)GO TO 20 C IF(NSTEP.EQ.0)WRITE(23,1001)A,B,C,D,E 1001 FORMAT(1X,5E15.5) AAA=AAA+A BBB=BBB+B CCC=CCC+C DDD=DDD+D EEE=EEE+E GO TO 30 20 CONTINUE AA=HALF(NX)*A-D*E BB=HALF(NX)*C-E*E CC=HALF(NX)*B-D*D DD=C*D-E*A RR1=(AA*AA)/(BB*CC) ALP1=DD/BB BTA1=AA/BB 30 CONTINUE SCRAP(1;NV)=ZKEEP(1,(I2-1)*2+2;NV) IF(I1.EQ.1.AND.I2.GT.1.AND.I3.EQ.1)SCRAP(1;NV)= CZKEEP(1,(I2-2)*2+2;NV) A=Q8SDOT(SCRAP(1;NV),ZML(1;NV)) B=Q8SDOT(SCRAP(1;NV),SCRAP(1;NV)) C=Q8SDOT(ZML(1;NV),ZML(1;NV)) D=Q8SSUM(SCRAP(1;NV)) E=Q8SSUM(ZML(1;NV)) IF(NSTEP.EQ.1)GO TO 40 C IF(NSTEP.EQ.0)WRITE(23,1001)A,B,C,D,E AAA=AAA+A BBB=BBB+B CCC=CCC+C DDD=DDD+D EEE=EEE+E GO TO 10 40 CONTINUE AA=HALF(NX)*A-D*E BB=HALF(NX)*C-E*E CC=HALF(NX)*B-D*D DD=C*D-E*A RR2=(AA*AA)/(BB*CC) ALP2=DD/BB BTA2=AA/BB RETURN 10 A=Q8SDOT(XLGMST(1;NP),D1(1;NP)) B=Q8SDOT(XLGMST(1;NP),XLGMST(1;NP)) C=Q8SDOT(D1(1;NP),D1(1;NP)) D=Q8SSUM(XLGMST(1;NP)) E=Q8SSUM(D1(1;NP)) C IF(NSTEP.EQ.0)WRITE(23,1001)A,B,C,D,E A=AAA+A B=BBB+B C=CCC+C D=DDD+D E=EEE+E AA=HALF(NX)*A-D*E BB=HALF(NX)*C-E*E CC=HALF(NX)*B-D*D DD=C*D-E*A RR1=(AA*AA)/(BB*CC) ALP1=DD/BB BTA1=AA/BB RETURN END C C ***********************SUBROUTINE XLCHCK************************ C NORMALIZES THE LEGISLATOR COORDINATES TO CONTROL THE SAG C **************************************************************** C C SUBROUTINE XLCHCK(LKJI,JJJK,NS,NPU,NCONG,INP,YLMX,YLMN,MSTRN, CYMIN,YMAX,DTOT,ELIPSE) IMPLICIT HALF PRECISION (A-H,O-Z) DIMENSION D1(100),YLMX(100),YLMN(100),ELIPSE(300),D2(10) BIT ISY,ISN,JSY,JSN,ISLEG,ISLEG2 COMMON /HUGE/ ISY(12000000),ISN(12000000),JSY(12000000), CJSN(12000000),ISLEG(989901),ISLEG2(989901) COMMON /HUGE2/ XI0(9999),XI1(9999),XI2(9999),XI3(9999), CZML(40000),DL(40000),L2P5RC(40000),LVTRC2(40000), CJLEG(33000,4),JRC(33000,3),XKEEP(9999,12),XEST(9999,3), CJJLEG(9999,5),DLMST(40000),ZMLMST(40000),XLGMST(33000), CJDUMMY(9999,5),JLEGA(40000,4),JRCA(33000,3),LDUMMY(33000), CZKEEP(40000,6),LKEEP(40000,3) IF(MSTRN.EQ.-99)RETURN D1(1;NCONG)=0.S0 KYRS=Q8SCNT(ISLEG2((INP-1)*NCONG+1;NCONG)) WHERE(ISLEG2((INP-1)*NCONG+1;NCONG)) D1(1;NCONG)=1.S0 XSTART=-1.S0 IF(KYRS.GE.2)XINC=2.S0/HALF(KYRS-1) IF(KYRS.EQ.1)XINC=0.S0 DTOT=0.S0 D2(1;10)=0.S0 DO 1 JJ=1,NCONG IF(D1(JJ).EQ.0.S0)GO TO 1 A2=XSTART A3=(3.S0*XSTART**2-1.S0)/2.S0 A4=(5.S0*XSTART**3-3.S0*XSTART)/2.S0 DTOT=DTOT+XI0(INP)+XI1(INP)*A2+XI2(INP)*A3+XI3(INP)*A4 DO 200 JEPP=1,NS D2(JEPP+NS)=D2(JEPP+NS)+HSQRT(ELIPSE((JEPP-1)*NCONG+JJ)) IF(JEPP.EQ.JJJK)GO TO 200 D2(JEPP)=D2(JEPP)+XKEEP(INP,(JEPP-1)*4+1)+ C XKEEP(INP,(JEPP-1)*4+2)*A2+ C XKEEP(INP,(JEPP-1)*4+3)*A3+ C XKEEP(INP,(JEPP-1)*4+4)*A4 200 CONTINUE XSTART=XSTART+XINC 1 CONTINUE DTOT=DTOT/HALF(KYRS) DMAX1=0.S0 IF(LKJI.EQ.1.AND.JJJK.EQ.1)GO TO 209 DO 201 JEPP=1,NS IF(JEPP.EQ.JJJK)GO TO 201 IF(LKJI.EQ.1.AND.JEPP.GT.JJJK)GO TO 201 DMAX1=DMAX1+((D2(JEPP)/HALF(KYRS))**2)/ C((D2(JEPP+NS)/HALF(KYRS))**2) 201 CONTINUE 209 CONTINUE DMAX3=(D2(JJJK+NS)/HALF(KYRS))**2 DMAX2=DMAX1+(DTOT**2)/DMAX3 MSTRN=0 IF(DMAX2.LE.1.S0)RETURN MSTRN=1 XUSA=+1.S0 IF(DTOT.LT.0.S0)XUSA=-1.S0 IF((1.S0-DMAX1).GE.0.S0)XI0(INP)=(HSQRT((1.S0-DMAX1)*DMAX3)*XUSA) IF((1.S0-DMAX1).LT.0.S0)XI0(INP)=0.S0 XI1(INP)=0.S0 XI2(INP)=0.S0 XI3(INP)=0.S0 RETURN END C C C C *************************SUBROUTINE WHOOPE************************* C METRIC UNIDIMENSIONAL SCALING USING THE CONDITIONAL GLOBAL MINIMUM C ALGORITHM. THE AGREEMENT SCORE MATRIX OF UNIQUE LEGISLATORS IS C UNFOLDED. C ******************************************************************* C C SUBROUTINE WHOOPE(NS,NCONG,NP,NPU,NYRB,KAA,NEDITH) IMPLICIT HALF PRECISION (A-H,O-Z) DIMENSION L2(100),L3(100),L2A(100),L3A(100),L33(100), CL33A(100),L4(100),D(9999),Z(9999,3),DAT(100,7) CHARACTER KAA(9900,11) BIT ISY,ISN,JSY,JSN,ISLEG,ISLEG2,AV,BV,CV,IS0(40000), CIS1(40000),IS2(1600) DESCRIPTOR AV,BV,CV COMMON /HUGE/ ISY(12000000),ISN(12000000),JSY(12000000), CJSN(12000000),ISLEG(989901),ISLEG2(989901) COMMON /HUGE2/ XI0(9999),XI1(9999),XI2(9999),XI3(9999), CZML(40000),DL(40000),L2P5RC(40000),LVTRC2(40000), CJLEG(33000,4),JRC(33000,3),XKEEP(9999,12),XEST(9999,3), CJJLEG(9999,5),DLMST(40000),ZMLMST(40000),XLGMST(33000), CJDUMMY(9999,5),JLEGA(40000,4),JRCA(33000,3),LDUMMY(33000), CZKEEP(40000,6),LKEEP(40000,3) ASSIGN AV,.DYN.NCONG ASSIGN BV,.DYN.NCONG ASSIGN CV,.DYN.NCONG WRITE(23,1001) 1001 FORMAT(' METRIC SIMILARITIES SCALING OF AGREEMENT SCORES'/ C5X,'SSE R-SQUARE STOP CRITERIA') DO 9999 II=1,NEDITH DO 10 JJ=1,7 10 DAT(II,JJ)=0.S0 DO 9995 I=1,NPU AV=ISLEG2((I-1)*NCONG+1;NCONG) NQI=I IS0(1;NP)=JLEG(1,1;NP).EQ.JJLEG(I,2) KYRS=JJLEG(I,1) L2(1;KYRS)=Q8VCMPRS(JRC(1,2;NP),IS0(1;NP);L2(1;KYRS)) L3(1;KYRS)=Q8VCMPRS(JRC(1,3;NP),IS0(1;NP);L3(1;KYRS)) L2A(1;NCONG)=0 L3A(1;NCONG)=0 L2A(1;NCONG)=Q8VXPND(L2(1;KYRS),AV;L2A(1;NCONG)) L3A(1;NCONG)=Q8VXPND(L3(1;KYRS),AV;L3A(1;NCONG)) KK=0 DO 95 J=1,NPU IF(I.EQ.J)GO TO 95 BV=ISLEG2((J-1)*NCONG+1;NCONG) CV=AV.AND.BV LYRS=Q8SCNT(CV) IF(LYRS.EQ.0)GO TO 95 L4(1;NCONG)=0 WHERE(CV)L4(1;NCONG)=1 IS0(1;NP)=JLEG(1,1;NP).EQ.JJLEG(J,2) KYRS2=JJLEG(J,1) L33(1;KYRS2)=Q8VCMPRS(JRC(1,3;NP),IS0(1;NP);L33(1;KYRS2)) L33A(1;NCONG)=0 L33A(1;NCONG)=Q8VXPND(L33(1;KYRS2),BV;L33A(1;NCONG)) KY=0 KN=0 KT=0 DO 94 JJ=1,NCONG IF(L4(JJ).EQ.0)GO TO 94 NV=L2A(JJ) NTVI=L3A(JJ) NTVJ=L33A(JJ) IS1(1;NV)=ISY(NTVI+1;NV).AND.ISY(NTVJ+1;NV) KY=KY+Q8SCNT(IS1(1;NV)) IS1(1;NV)=ISN(NTVI+1;NV).AND.ISN(NTVJ+1;NV) KN=KN+Q8SCNT(IS1(1;NV)) IS0(1;NV)=ISY(NTVI+1;NV).OR.ISN(NTVI+1;NV) IS1(1;NV)=ISY(NTVJ+1;NV).OR.ISN(NTVJ+1;NV) IS2(1;NV)=IS0(1;NV).AND.IS1(1;NV) KT=KT+Q8SCNT(IS2(1;NV)) 94 CONTINUE KK=KK+1 Z(KK,1)=XI0(J) Z(KK,2)=XI1(J) Z(KK,3)=XI2(J) IF(KT.EQ.0)D(KK)=999.S0 IF(KT.EQ.0)GO TO 95 D(KK)=(100.S0-(HALF(KY+KN)/HALF(KT))*100.S0)/50.S0 95 CONTINUE IS0(1;KK)=D(1;KK).NE.999.S0 KPOOP=Q8SCNT(IS0(1;KK)) IF(KPOOP.EQ.0)STOP IF(NS.EQ.1)CALL FOCUSW(KK,NQI,D,Z,XI0) IF(NS.GT.1)CALL FOCUS(KK,NQI,NS,D,Z,XI0,XI1,XI2) CALL STAT(II,KK,NQI,NS,D,Z,XI0,XI1,XI2,DAT) JBIG=NQI C 9995 CONTINUE C DO 20 JBIG=1,NPU C WRITE(33,1005)(JJLEG(JBIG,J),J=2,5),(KAA(JBIG,J),J=1,11), C CXI0(JBIG),XI1(JBIG),XI2(JBIG) 9995 CONTINUE 1005 FORMAT(7X,I5,I2,4X,I2,1X,I4,1X,11A1,3F10.4) AA=DAT(II,7)*DAT(II,6)-DAT(II,2)*DAT(II,3) BB=DAT(II,7)*DAT(II,4)-DAT(II,2)*DAT(II,2) CC=DAT(II,7)*DAT(II,5)-DAT(II,3)*DAT(II,3) RSQ=(AA*AA)/(BB*CC) AKKK=0.S0 IF(II.GT.1)AKKK=(DAT(II-1,1)-DAT(II,1))/DAT(II-1,1) WRITE(23,1000)II,DAT(II,1),RSQ,AKKK,DAT(II,7) 1000 FORMAT(I5,F14.5,2F10.4,F10.1) IF(II.EQ.1)GO TO 9999 IF(AKKK.LE..01)GO TO 9998 9999 CONTINUE 9998 CONTINUE RETURN END C C C ******************************************************************** C SUBROUTINE STAT--COMPUTES FITS FOR FOCUSW SUBROUTINE C ******************************************************************** C C SUBROUTINE STAT(II,KK,NQI,NS,D,Z,XI0,XI1,XI2,DAT) IMPLICIT HALF PRECISION (A-H,O-Z) DIMENSION D(9999),Z(9999,3),XI0(9999),DAT(100,7),D1(9999), CD2(9999),D3(9999),D4(9999),XI1(9999),XI2(9999),D11(9999), CD111(9999) BIT IS0(9999) D1(1;KK)=Z(1,1;KK)-XI0(NQI) D11(1;KK)=Z(1,2;KK)-XI1(NQI) D111(1;KK)=Z(1,3;KK)-XI2(NQI) D111(1;KK)=D1(1;KK)**2 + D11(1;KK)**2 + D111(1;KK)**2 D1(1;KK)=VHSQRT(D111(1;KK);D1(1;KK)) IS0(1;KK)=D(1;KK).NE.999.S0 D2(1;KK)=(D(1;KK)-D1(1;KK))**2 CALL Q8SUM(X'80',,D2(1;KK),,,IS0(1;KK),6) CALL Q8ADDNH(6,,SSE) DAT(II,1)=DAT(II,1)+SSE CALL Q8SUM(X'80',,D(1;KK),,,IS0(1;KK),6) CALL Q8ADDNH(6,,ASUM) DAT(II,2)=DAT(II,2)+ASUM CALL Q8SUM(X'80',,D1(1;KK),,,IS0(1;KK),6) CALL Q8ADDNH(6,,BSUM) DAT(II,3)=DAT(II,3)+BSUM D3(1;KK)=D(1;KK)*D(1;KK) CALL Q8SUM(X'80',,D3(1;KK),,,IS0(1;KK),6) CALL Q8ADDNH(6,,CSUM) DAT(II,4)=DAT(II,4)+CSUM D3(1;KK)=D1(1;KK)*D1(1;KK) CALL Q8SUM(X'80',,D3(1;KK),,,IS0(1;KK),6) CALL Q8ADDNH(6,,DSUM) DAT(II,5)=DAT(II,5)+DSUM D3(1;KK)=D(1;KK)*D1(1;KK) CALL Q8SUM(X'80',,D3(1;KK),,,IS0(1;KK),6) CALL Q8ADDNH(6,,ESUM) DAT(II,6)=DAT(II,6)+ESUM KKK=Q8SCNT(IS0(1;KK)) DAT(II,7)=DAT(II,7)+HALF(KKK) RETURN END C C C C *************************SUBROUTINE FOCUSW************************* C PERFORMS LEAST SQUARES METRIC SIMILARITIES ANALYSIS USING THE C CONDITIONAL GLOBAL MINIMUM ALGORITHM. C ******************************************************************* C C C SUBROUTINE FOCUSW(NP,NQJ,D,X,Z) IMPLICIT HALF PRECISION (A-H,O-Z) REAL Q DIMENSION D(9999),X(9999,3),Z(9999),XX(9999,2),LL(9999), CQ(9999),XSRT(9999),DSRT(9999),X2(9999) BIT IS0(10000) Q(1;NP)=VREAL(X(1,1;NP);Q(1;NP)) CALL QSORT(NP,Q,LL) XSRT(1;NP)=Q8VGATHR(X(1,1;NP),LL(1;NP);XSRT(1;NP)) DSRT(1;NP)=Q8VGATHR(D(1;NP),LL(1;NP);DSRT(1;NP)) IS0(1;NP)=DSRT(1;NP).NE.999.S0 WHERE (DSRT(1;NP).NE.999.S0) XX(1,1;NP)=XSRT(1;NP)-DSRT(1;NP) WHERE (DSRT(1;NP).NE.999.S0) XX(1,2;NP)=XSRT(1;NP)+DSRT(1;NP) CALL Q8SUM(X'80',,XX(1,1;NP),,,IS0(1;NP),6) CALL Q8ADDNH(6,,ASUM) X2(1;NP)=XX(1,1;NP)*XX(1,1;NP) CALL Q8SUM(X'80',,X2(1;NP),,,IS0(1;NP),6) CALL Q8ADDNH(6,,BSUM) KKNP=Q8SCNT(IS0(1;NP)) AA=HALF(KKNP)*BSUM-ASUM*ASUM Z(NQJ)=ASUM/HALF(KKNP) DO 77 I=1,NP IF(DSRT(I).EQ.999.S0)GO TO 77 ASUM=ASUM-XX(I,1)+XX(I,2) BSUM=BSUM-XX(I,1)**2+XX(I,2)**2 BB=HALF(KKNP)*BSUM-ASUM*ASUM CC=HMIN1(AA,BB) IF(CC.EQ.AA.AND.I.GT.1)GO TO 88 IF(CC.EQ.AA.AND.I.EQ.1)Z(NQJ)=(ASUM+XX(I,1)-XX(I,2))/HALF(KKNP) IF(CC.EQ.BB)Z(NQJ)=ASUM/HALF(KKNP) 88 AA=CC 77 CONTINUE SSQ=CC RETURN END C C C C *************************subroutine foCus************************* C performs multidimensional unfolding/similarites analysis. C ****************************************************************** C C C SUBROUTINE FOCUS(NP,NQI,NS,D,Z,XI0,XI1,XI2) IMPLICIT HALF PRECISION (A-H,O-Z) DIMENSION D(9999),ZZ(3),Z(9999,3),DSRT(9999),XI0(9999), CXI1(9999),XI2(9999),DHAT(9999),DRAT(9999),XZ(9999),XDERV(9999) BIT IS0(10000) ZZ(1)=XI0(NQI) ZZ(2)=XI1(NQI) ZZ(3)=XI2(NQI) IS0(1;NP)=D(1;NP).NE.999.S0 DSRT(1;NP)=D(1;NP) DHAT(1;NP)=0.S0 DO 1 K=1,NS XZ((K-1)*NP+1;NP)=ZZ(K)-Z(1,K;NP) 1 DHAT(1;NP)=DHAT(1;NP)+XZ((K-1)*NP+1;NP)**2 DHAT(1;NP)=VHSQRT(DHAT(1;NP);DHAT(1;NP)) WHERE (DHAT(1;NP).NE.0.S0) DRAT(1;NP)=1.S0/DHAT(1;NP) WHERE (DHAT(1;NP).NE.0.S0) DRAT(1;NP)=DSRT(1;NP)*DRAT(1;NP) WHERE (DHAT(1;NP).LE.0.S0) DRAT(1;NP)=1.S0 KK=Q8SCNT(IS0(1;NP)) DO 2 K=1,NS XDERV((K-1)*NP+1;NP)=Z(1,K;NP)+DRAT(1;NP)* CXZ((K-1)*NP+1;NP) CALL Q8SUM(X'80',,XDERV((K-1)*NP+1;NP),,,IS0(1;NP),6) CALL Q8ADDNH(6,,SUM) ZZ(K)=SUM/HALF(KK) 2 CONTINUE XI0(NQI)=ZZ(1) XI1(NQI)=ZZ(2) XI2(NQI)=ZZ(3) RETURN END

D-NOMINATE Vector FORTRAN code written by Keith T. Poole, 1986-1988, for the Cyber-205 SuperComputer, Purdue University

D-NOMINATE

Vector FORTRAN code written by Keith T. Poole, 1986-1988, for the Cyber-205 SuperComputer, Purdue University