C
C ***********************************************************************
C
C  MATCH_RESP_2008.FOR----READS 2004 ICPSR DATA FILE -- ELEC2004_ONLY_10.DAT
C                  AND ANNENBERG_ONLY_10.DAT AND MATCHES EACH ANNENBERG
C                  RESPONDENT TO NES RESPONDENTS USING THE THERMOMETERS
C
C                           3 MARCH 2008
C
C ***********************************************************************
C
      dimension KTHERM1(82000,100),KTHERM2(82000,100),ID1(82000),
     C          ID2(82000),ID3(82000),XESAVE(2000),LESAVE(2000),
     C          MESAVE(2000),NESAVE(2000),IDXNES(82000),
     C          XNES(82000,2),IDXANN(82000),XANN(82000,2),
     C          XXESAVE(2000),NNESAVE(2000)
      CHARACTER*1 KA(100)
      INTEGER*2 ITIM1,ITIM2,ITIM3,ITIM4,JTIM1,JTIM2,JTIM3,JTIM4
C
      OPEN(1,FILE='C:\ATIME2008_ABRAJANO_POOLE\MARISA_MATCH.DAT')
      OPEN(11,FILE='C:\ATIME2008_ABRAJANO_POOLE\ROSETTA.DAT')
      OPEN(20,FILE='C:\ATIME2008_ABRAJANO_POOLE\ELEC2004_ONLY_10.DAT',
     C              STATUS='OLD')
      open(22,file='C:\ATIME2008_ABRAJANO_POOLE\ANNENBERG_ONLY_10.DAT',
     C              STATUS='OLD')
      OPEN(23,FILE='C:\ATIME2008_ABRAJANO_POOLE\NES2004_10_THERM_COORDS.
     CDAT',STATUS='OLD')
      OPEN(24,FILE='C:\ATIME2008_ABRAJANO_POOLE\ANN_NES2004_10_THERM_COO
     CRDINATES.DAT',STATUS='OLD')
C 
  100 FORMAT(1X,2I4,14X,8I3,3X,2I3)
  150 FORMAT(I10,5I2,8X,4I2,8X,I2)
  200 FORMAT(2X,2I4,1X,15I3)
  201 FORMAT(F10.4,I5,F10.4,2X,2I4,1X,10I3,2X,I5,F10.4,1X,5I3)
  202 FORMAT(1X,I10,1X,I4,1X,I4)
  250 FORMAT(I10,1X,15I3)
  251 FORMAT(F10.4,15X,I10,1X,10I3,18X,5I3)
  260 FORMAT(1X,I10,3X,3F10.4)
  265 FORMAT(20A1)
  270 FORMAT(1X,I6,7X,3F10.4)
  300 FORMAT(' NUMBER OF RECORDS READ NES      ',3I6)
  301 FORMAT(' NUMBER OF SCALED RESP. NES      ',3I6)
  350 FORMAT(' NUMBER OF RECORDS READ ANNENBERG',3I6)
  351 FORMAT(' NUMBER OF SCALED RESP. ANNENBERG',3I6)
  360 FORMAT(' NUMBER OF ANNENBERG CASES MATCHED',I8)
 1000 format(22x,4(i2.2,'.'))
 1001 format(' ELAPSED TIME OF JOB  ',4(i2.2,'.'))
      call gettim(itim1,itim2,itim3,itim4)
C
C BUSH  
C KERRY 
C CHENEY   
C EDWARDS
C NADER 
C ASHCROFT
C LBUSH
C BCLINTON
C HCLINTON
C MCCAIN
C
C
C  READ 2004 ICPSR DATA FILE AND WRITE OUT 10 THERMOMETERS
C     IN SAME ORDER AS ANNENBERG STUDY
C    
      I=0
  500 read(20,200,END=400)ID1(I+1),ID2(I+1),(KTHERM1(I+1,J),J=1,15)
C
      I=I+1
C
      GO TO 500
  400 WRITE(*,300)I
      NNES=I
C
C  READ 2004 RESPONDENT COORDINATES FROM UNFOLDING OF THE 10
C    CANDIDATE THERMOMETERS
C      C:\ATIME2007_ANNENBERG\NES2004_10_THERM_COORDS.DAT
C
C  READ COORDINATES FOR CANDIDATES THAT ARE ON TOP OF THE FILE
C
      DO 11 I=1,10
      READ(23,265)(KA(J),J=1,10)
  11  CONTINUE
      I=0
  515 READ(23,270,END=415)IDXNES(I+1),(XNES(I+1,J),J=1,2)
      I=I+1
      GO TO 515
  415 WRITE(*,301)I
      NXNES=I
C
C  READ ANNENBERG THERMOMETERS
C
      I=0
  550 READ(22,250,END=450)ID3(I+1),(KTHERM2(I+1,J),J=1,15)
C
      I=I+1
C
      GO TO 550
  450 WRITE(*,350)I
      NANNEN=I
C
C  READ 2004 ANNENBERG RESPONDENT COORDINATES FROM EXTERNAL UNFOLDING USING
C    THE NES CANDIDATE COORDINATES
C      C:\ATIME2007_ANNENBERG\ANN_NES2004_10_THERM_COORDINATES.DAT
C
C  READ COORDINATES FOR CANDIDATES THAT ARE ON TOP OF THE FILE
C
      DO 12 I=1,10
      READ(24,265)(KA(J),J=1,10)
  12  CONTINUE
      I=0
  505 READ(24,260,END=405)IDXANN(I+1),(XANN(I+1,J),J=1,2)
      I=I+1
      GO TO 505
  405 WRITE(*,351)I
      NXANN=I
C
C  DO SIMPLE LEAST SQUARES MATCH EACH ANNENBERG RESPONDENT WITH
C    NES RESPONDENTS
C
      ICASEMAT=0
C      DO 999 III=1,20
      DO 999 III=1,NANNEN
C
C  REQUIRE EACH ANNENBERG RESPONDENT HAVE 4 THERMOMETERS
C
      KSUM=0
      DO 1 J=1,10
      IF(KTHERM2(III,J).LE.100)KSUM=KSUM+1
  1   CONTINUE
      IF(KSUM.LT.4)GO TO 999
C
C  DO MATCH WITH NES RESPONDENTS
C
      KSAVE=0
      DO 998 JJJ=1,NNES
      KSUM=0
      ESUM=0
      DO 2 J=1,10
      IF(KTHERM2(III,J).LE.100.AND.KTHERM1(JJJ,J).LE.100)THEN
         KSUM=KSUM+1
C         ESUM=ESUM+(FLOAT(KTHERM2(III,J)-KTHERM1(JJJ,J)))**2
         ESUM=ESUM+ABS(FLOAT(KTHERM2(III,J)-KTHERM1(JJJ,J)))
      ENDIF
  2   CONTINUE
      KKSUM=0
      EESUM=0
      DO 2222 J=11,15
      IF(KTHERM2(III,J).LE.100.AND.KTHERM1(JJJ,J).LE.100)THEN
         KKSUM=KKSUM+1
         EESUM=EESUM+ABS(FLOAT(KTHERM2(III,J)-KTHERM1(JJJ,J)))
      ENDIF
 2222 CONTINUE
      IF(KSUM.GE.4)THEN
         KSAVE=KSAVE+1
C         XESAVE(KSAVE)=SQRT(ESUM)/FLOAT(KSUM)
         XESAVE(KSAVE)=(ESUM)/FLOAT(KSUM)
         XXESAVE(KSAVE)=(EESUM)/FLOAT(KKSUM)
         LESAVE(KSAVE)=KSAVE
         MESAVE(KSAVE)=JJJ
         NESAVE(KSAVE)=KSUM
         NNESAVE(KSAVE)=KKSUM
      ENDIF
  998 CONTINUE
      IF(KSAVE.EQ.0)GO TO 999
      CALL RSORT(XESAVE,KSAVE,LESAVE)
C
C  MATCH UP ANNENBERG COORDINATES
C
      DO 13 IK=1,NXANN
      IF(IDXANN(IK).EQ.ID3(III))THEN
         XANN1=XANN(IK,1)
         XANN2=XANN(IK,2)
         GO TO 1313
      ENDIF
  13  CONTINUE
 1313 CONTINUE
      WRITE(1,251)XANN1,ID3(III),(KTHERM2(III,J),J=1,15)
C
C  MATCH UP NES COORDINATES
C
      DO 3 J=1,5
      ICASE=MESAVE(LESAVE(J))
      JSUM=NESAVE(LESAVE(J))
      JJSUM=NNESAVE(LESAVE(J))
      XXGROUP=XXESAVE(LESAVE(J))
C
      DO 14 IK=1,NXNES
      IF(IDXNES(IK).EQ.ICASE)THEN
         XNES1=XNES(IK,1)
         XNES2=XNES(IK,2)
         GO TO 1414
      ENDIF
  14  CONTINUE
 1414 CONTINUE
C
      WRITE(1,201)XNES1,JSUM,XESAVE(J),ID1(ICASE),ID2(ICASE),
     C            (KTHERM1(ICASE,JX),JX=1,10),
     C            JJSUM,XXGROUP,
     C            (KTHERM1(ICASE,JX),JX=11,15)
C
C  WRITE OUT MATCHED UP ID NUMBERS -- ANNENBERG AND NES
C
      IF(J.EQ.1)WRITE(11,202)ID3(III),ID1(ICASE),ID2(ICASE)
  3   CONTINUE
      ICASEMAT=ICASEMAT+1
  999 CONTINUE
C
      WRITE(*,360)ICASEMAT
C
      call gettim(jtim1,jtim2,jtim3,jtim4)
      write(*,1000)itim1,itim2,itim3,itim4
      write(*,1001)jtim1,jtim2,jtim3,jtim4
      stop
      end
C
C
C  ************************************************************************
C    SORT SUBROUTINE--SORTS A VECTOR 'A' OF REAL ELEMENTS INTO ASCENDING
C    ORDER.  'LA' IS THE NUMBER OF ELEMENTS TO BE SORTED AND 'IR' IS A
C    VECTOR OF INTEGERS THAT RECORDS THE PERMUTATIONS--USUALLY SET TO
C    1,2,3,4,...
C  ************************************************************************
C
C
      SUBROUTINE RSORT(A,LA,IR)
      DIMENSION A(LA),IU(21),IL(21),IR(LA)
      IF (LA.LE.0) RETURN
      M = 1
      I = 1
      J = LA
      R = .375
    5 IF (I.EQ.J) GO TO 45
      IF (R.GT..5898437) GO TO 10
      R = R+3.90625E-2
      GO TO 15
   10 R = R-.21875
   15 K = I
C
C SELECT A CENTRAL ELEMENT OF THE  
C ARRAY AND SAVE IT IN LOCATION T  
C
      IJ = I+(J-I)*R 
      T = A(IJ)   
      IT = IR(IJ) 
C
C FIRST ELEMENT OF ARRAY IS GREATER
C THAN T, INTERCHANGE WITH T       
C
      IF (A(I).LE.T) GO TO 20  
      A(IJ) = A(I) 
      A(I) = T     
      T = A(IJ) 
      IR(IJ) = IR(I)  
      IR(I) = IT
      IT = IR(IJ) 
   20 L = J
C
C IF LAST ELEMENT OF ARRAY IS LESS THAN
C T, INTERCHANGE WITH T
C
      IF (A(J).GE.T) GO TO 30
      A(IJ) = A(J)
      A(J) = T
      T = A(IJ)
      IR(IJ) = IR(J)
      IR(J) = IT
      IT = IR(IJ)
C
C IF FIRST ELEMENT OF ARRAY IS GREATER
C THAN T, INTERCHANGE WITH T
C
      IF (A(I).LE.T) GO TO 30
      A(IJ) = A(I)
      A(I) = T
      T = A(IJ)
      IR(IJ) = IR(I)
      IR(I) = IT
      IT = IR(IJ)
      GO TO 30
   25 IF (A(L).EQ.A(K)) GO TO 30
      TT = A(L)
      A(L) = A(K)
      A(K) = TT
      ITT = IR(L)
      IR(L) = IR(K)
      IR(K) = ITT
C
C FIND AN ELEMENT IN THE SECOND HALF OF
C THE ARRAY WHICH IS SMALLER THAN T
C
   30 L = L-1
      IF (A(L).GT.T) GO TO 30
C
C FIND AN ELEMENT IN THE FIRST HALF OF
C THE ARRAY WHICH IS GREATER THAN T
C
   35 K = K+1
      IF (A(K).LT.T) GO TO 35
C
C INTERCHANGE THESE ELEMENTS
C
      IF (K.LE.L) GO TO 25
C
C SAVE UPPER AND LOWER SUBSCRIPTS OF
C THE ARRAY YET TO BE SORTED
C
      IF (L-I.LE.J-K) GO TO 40
      IL(M) = I
      IU(M) = L
      I = K
      M = M+1
      GO TO 50
   40 IL(M) = K
      IU(M) = J
      J = L
      M = M+1
      GO TO 50
C
C BEGIN AGAIN ON ANOTHER PORTION OF
C THE UNSORTED ARRAY
C
   45 M = M-1
      IF (M.EQ.0) RETURN
      I = IL(M)
      J = IU(M)
   50 IF (J-I.GE.11) GO TO 15
      IF (I.EQ.1) GO TO 5
      I = I-1
   55 I = I+1
      IF (I.EQ.J) GO TO 45
      T = A(I+1)
      IT = IR(I+1)
      IF (A(I).LE.T) GO TO 55
      K = I
   60 A(K+1) = A(K)
      IR(K+1) = IR(K)
      K = K-1
      IF (T.LT.A(K)) GO TO 60
      A(K+1) = T
      IR(K+1) = IT
      GO TO 55
      END
C
