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.


D-NOMINATE

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



       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