!
!  
!
      INTEGER NSTIMULI,NSELFPOS,NMISSING,POLARITY,                   &
                NRESPONDENTS,EXITSTATUS,IDRESP(1421)
      DOUBLE PRECISION XMISSING(3),RESPDATA(1421*5),STIMCOORDS(4),   &
                RESPCOORDS(1421*4),EIGENVALUES(4),FITS(5)
      CHARACTER*13 NAMES(5)
!
      OPEN(1,FILE='OLS68AA.DAT',STATUS='OLD')
      OPEN(25,FILE='CHECK_AM.DAT')
!
!  FORMAT FOR 1968 VIETNAM SCALE
!
!  100 FORMAT(I5,39X,5F3.0)
!
!  FORMAT FOR 1968 URBAN UNREST SCALE
!
  100 FORMAT(I5,24X,5F3.0)
  300 FORMAT(' FITS',5F10.4)
  301 FORMAT(I5,2F10.4,1X,A13)
  302 FORMAT(2I6,4F12.4)
!
!      NRESPONDENTS=1259
      NRESPONDENTS=1421
      NSTIMULI=4
      NSELFPOS=5
      NMISSING=3
      XMISSING(1)=0.0
      XMISSING(2)=8.0
      XMISSING(3)=9.0
      POLARITY=1
      EXITSTATUS=0
!
      NAMES(1)='LBJ          '
      NAMES(2)='HHH          '
      NAMES(3)='NIXON        '
      NAMES(4)='WALLACE      '
      NAMES(5)='INDIVIDUAL   '
!
!      READ(1,KFMT,END=10)I1,(A(J),J=1,NNQ)
!
      DO 1 I=1,NRESPONDENTS
      READ(1,100)IDRESP(I),                                          &
          (RESPDATA(J+(I-1)*(NSTIMULI+1)),J=1,NSTIMULI+1)
  1   CONTINUE
!
        CALL MCKALNEW(NRESPONDENTS,NSTIMULI,NSELFPOS,NMISSING,       &
           XMISSING,POLARITY,STIMCOORDS,FITS,EIGENVALUES,RESPDATA,   &
           RESPCOORDS,NAMES,IDRESP,EXITSTATUS)
!
!  CHECK OUTPUT
!
      WRITE(25,300)(FITS(J),J=1,5)
      DO 2 I=1,NSTIMULI
      WRITE(25,301)I,EIGENVALUES(I),STIMCOORDS(I),NAMES(I)
  2   CONTINUE
      DO 3 I=1,NRESPONDENTS
      KK=(I-1)*4
      WRITE(25,302)I,IDRESP(I),(RESPCOORDS(KK+J),J=1,4)
  3   CONTINUE
      STOP
      END
!
!  &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
!  &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
!
!  **************************************************************************
!
!   MCKALNEW.F95 -- 27 MARCH 2009                            
!
!             LAST UPDATE OF FORTRAN IV VERSION:  10 JULY 1996
!
!   ALDRICH-MCKELVEY SCALING PROGRAM
!
!
!   WRITTEN BY KEITH T. POOLE AT THE UNIVERSITY OF OREGON
!   OCTOBER 1978.  FOR THE THEORY OF THE PROGRAM SEE
!   ALDRICH AND MCKELVEY, "A METHOD OF SCALING WITH APPLICATIONS
!   TO THE 1968 AND 1972 PRESIDENTIAL ELECTIONS," AMERICAN
!   POLITICAL SCIENCE REVIEW, 1977, PP. 111-130
!
!   MODIFIED FOR USE ON IBM PC'S BY KEITH T. POOLE AT THE
!   GRADUATE SCHOOL OF INDUSTRIAL ADMINISTRATION, NOVEMBER, 1986.
!                
!                REVISED, JULY, 1996.
!
!   NQ=# OF STIMULI
!   NRESP= THE POSITION THE RESPONDENT IS IN THE DATA
!          IF NRESP=0, ONLY THE STIMULI CONFIGURATION WILL BE
!          COMPUTED
!   NMISS=# OF MISSING DATA VALUES
!   NLEFT=# OF THE STIMULUS WHICH SHOULD BE RECOVERED FURTHEST TO THE
!         LEFT OF THE DIMENSION.
!   XMISS IS AN ARRAY CONTAINING THE MISSING VALUES
!   KFMT IS AN ARRAY CONTAINING THE FORMAT OF THE INPUT DATA
!   KNAM IS AN ARRAY CONTAINING TITLES OF THE STIMULI.  UP TO 13 LETTERS
!        MAY BE USED.  ALWAYS PLACE "INDIV" AT END.
!   
!
!   UP TO 5 MISSING DATA VALUES MAY BE USED
!
!   
!   SAMPLE CONTROL CARDS
!
!   1011 4 7
!   (2X,I4,70X,F2.0,9(1X,F2.0),8X,F2.0)
!    00.0 97.0 98.0 99.0
!   SFIO
!   ALLRP
!   CENDM
!   PSU
!   REPIN
!   MRP
!   PCF
!   RAD
!   UNR
!   FGDS
!   INDIV
!
!
!   UNIT 21 IS USED TO READ IN THE CONTROL CARDS
!   UNIT 1 IS USED TO READ IN THE DATA SET
!   UNIT 20 IS USED FOR SCRATCH (NO LONGER USED)
!   UNIT 23 IS USED TO WRITE OUT THE INDIVIDUAL COORDINATES
!   UNIT 24 IS USED TO WRITE OUT THE OLD-FASHIONED PRINTER OUTPUT OF THE RUN
!
!
      SUBROUTINE MCKALNEW(NRESPONDENTS,NSTIMULI,NSELFPOS,NMISSING,   &
           XMISSING,POLARITY,STIMCOORDS,FITS,EIGENVALUES,RESPDATA,   &
           RESPCOORDS,NAMES,IDRESP,EXITSTATUS)
!
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NSTIMULI,NSELFPOS,NMISSING,POLARITY,                   &
                NRESPONDENTS,EXITSTATUS,IDRESP(NRESPONDENTS)
      DOUBLE PRECISION XMISSING(NMISSING),                           &
             RESPDATA(NRESPONDENTS*(NSTIMULI+1)),                    &  
             STIMCOORDS(NSTIMULI),FITS(5),EIGENVALUES(NSTIMULI),     &
             RESPCOORDS(NRESPONDENTS*4)
      CHARACTER*13 NAMES(NSTIMULI+1)
!      DIMENSION A(400),awv(20,20),ZZ(20),XMISS(5),                   &
!                B(20),D(20),WK(400),ZSUM(20),                        &
!                KDEGO(20),KDATA(99999,2),XDATA(99999,25)
      CHARACTER*13 KNAM(NSTIMULI+1)
      INTEGER, ALLOCATABLE :: KDATA(:,:)
      INTEGER, ALLOCATABLE :: KDEGO(:)
      DOUBLE PRECISION, ALLOCATABLE :: A(:)
      DOUBLE PRECISION, ALLOCATABLE :: ZZ(:)
      DOUBLE PRECISION, ALLOCATABLE :: XMISS(:)
      DOUBLE PRECISION, ALLOCATABLE :: B(:)
      DOUBLE PRECISION, ALLOCATABLE :: D(:)
      DOUBLE PRECISION, ALLOCATABLE :: WK(:)
      DOUBLE PRECISION, ALLOCATABLE :: ZSUM(:)
      DOUBLE PRECISION, ALLOCATABLE :: AWV(:,:)
      DOUBLE PRECISION, ALLOCATABLE :: XDATA(:,:)
!
      ALLOCATE(KDATA(NRESPONDENTS,2))
      ALLOCATE(KDEGO(3*NSTIMULI))
      ALLOCATE(A(NSTIMULI*NSTIMULI))
      ALLOCATE(ZZ(3*NSTIMULI))
      ALLOCATE(XMISS(NMISSING))
      ALLOCATE(B(3*NSTIMULI))
      ALLOCATE(D(3*NSTIMULI))
      ALLOCATE(WK(3*NSTIMULI))
      ALLOCATE(ZSUM(3*NSTIMULI))
      ALLOCATE(AWV(NSTIMULI,NSTIMULI))
      ALLOCATE(XDATA(NRESPONDENTS,NSTIMULI+1))

  301 FORMAT(8F9.4/8F9.4/8F9.4)
  303 FORMAT(4X,8(A13,4X)/4x,8(A13,4x)/4x,8(A13,4x))
!      open(23,file='VIET_COORDS.DAT')
!      open(24,file='VIET.TXT')
      NQ=NSTIMULI
      NRESP=NSELFPOS
      NMISS=NMISSING
      NLEFT=POLARITY
      IF(NLEFT.EQ.0)NLEFT=1
      IF(NMISS.GT.0)THEN
         DO 89 JJ=1,NMISS
         XMISS(JJ)=XMISSING(JJ)
  89     CONTINUE
      ENDIF
      NNQ=NQ+1
      IF(NRESP.EQ.0)NNQ=NQ
      DO 1 I=1,NNQ
      KDEGO(I)=0
  1   KNAM(I)=NAMES(I)
!
!
!      open(21,file='VIET68.CTL',status='old')
!      call gettim(itim1,itim2,itim3,itim4)
!      write(24,3)
  3   FORMAT(1X,78('*'))
!
      NP=0
      XNQ=NQ
      XKNTL=.01
      KK=1
      KDEGN=0
      KDEGM=0
      DO 27 K=1,NQ
      ZSUM(K)=0.0
      DO 27 L=1,NQ
!      WV(K,L)=0.0
      awv(k,l)=0.0
!      A(KK)=0.0
!      Q(KK)=0.0
  27  KK=KK+1
      I=0
      ZZSUM=0.0
  9   CONTINUE
      I=I+1
      IF(I.GT.NRESPONDENTS)GO TO 10
      DO 88 JJ=1,NNQ
      A(JJ)=RESPDATA(JJ+(I-1)*NNQ)
      I1=IDRESP(I)
  88  CONTINUE
!      READ(1,100)IDRESP(I),                                          
!          (RESPDATA(J+(I-1)*(NSTIMULI+1)),J=1,NSTIMULI+1)
!      READ(1,KFMT,END=10)I1,(A(J),J=1,NNQ)
      SUM=0.0
      KXX=1
      DO 22 JJ=1,NNQ
      B(JJ)=A(JJ)
      IF(NRESP.EQ.1)KXX=2
      IF(NRESP.EQ.JJ)GO TO 22
      SUM=SUM+ABS(A(JJ)-A(KXX))
  22  CONTINUE
  678 FORMAT(2I5,F9.4,10F4.1)
      IF(SUM.GT.XKNTL)GO TO 99
!      WRITE(24,678)I,KXX,SUM,(A(JX),JX=1,NNQ)
      IF(NMISS.EQ.0)KDEGN=KDEGN+1
      IF(NMISS.EQ.0)GO TO 9
      DO 98 II=1,NMISS
      IF(A(KXX).EQ.XMISS(II))KDEGM=KDEGM+1
      IF(A(KXX).EQ.XMISS(II))GO TO 9
  98  CONTINUE
      KDEGN=KDEGN+1
      GO TO 9
  99  IF(NMISS.EQ.0)GO TO 997
      KERR=0
      DO 100 II=1,NMISS
      KK=0
      DO 100 K=1,NNQ
      IF(K.EQ.NRESP)GO TO 100
      KK=KK+1
      AA=ABS(A(K)-XMISS(II))
      IF(AA.LE.XKNTL)KDEGO(KK)=KDEGO(KK)+1
      IF(AA.LE.XKNTL)KERR=1
  100 CONTINUE
  997 CONTINUE
      IF(KERR.EQ.1)GO TO 9
!      WRITE(20)I,I1,(A(JJ),JJ=1,NNQ)
      NP=NP+1
      KDATA(NP,1)=I
      KDATA(NP,2)=I1
      DO 617 JJ=1,NNQ
      XDATA(NP,JJ)=A(JJ)
  617 CONTINUE
      KK=0
      DO 60 II=1,NNQ
      IF(II.EQ.NRESP)GO TO 60
      KK=KK+1
      A(KK)=B(II)
  60  CONTINUE
      ASUM=0.0
      BSUM=0.0
      DO 4 II=1,NQ
      ASUM=ASUM+A(II)
      BSUM=BSUM+A(II)*A(II)
      ZSUM(II)=ZSUM(II)+A(II)
   4  CONTINUE
      ZZSUM=ZZSUM+ASUM
      DET=1.0/(XNQ*BSUM-ASUM*ASUM)
      DO 7 II=1,NQ
      DO 8 J=1,II
      aWV(II,J)=aWV(II,J)+DET*(BSUM-A(II)*ASUM+XNQ*A(II)*            &
                       a(j)-a(j)*asum)
   8  CONTINUE
  7   CONTINUE
      GO TO 9
  10  CONTINUE
      I=I-1
      XNP=NP
!      write(24,12)
!      write(*,12)
  12  FORMAT(' NUMBER OF CASES')
!      write(*,13) NP,I
!      write(24,13) NP,I
  13  FORMAT(2I10)
!      write(24,97)
!      write(*,97)
  97  FORMAT(' MISSING CASES')
!      write(24,96)
!      write(*,96)
  96  FORMAT(' DEGENERATE--MISS  NOMISS')
!      write(24,13)KDEGM,KDEGN
!      write(*,13)KDEGM,KDEGN
!      write(*,333)(KNAM(I),I=1,NQ)
!      write(24,333)(KNAM(I),I=1,NQ)
!      write(*,94)(KDEGO(J),J=1,NQ)
!      write(24,94)(KDEGO(J),J=1,NQ)
  94  FORMAT(1X,20I7)
  333 FORMAT(3X,20(A13,2X))
!      write(24,3)
      NN=I
      KK=1
      BTSUM=0.0
      ZZSUM=ZZSUM/(XNQ*XNP)
      DO 14 I=1,NQ
      aWV(I,I)=aWV(I,I)-XNP
      ZSUM(I)=(ZSUM(I)/XNP)-ZZSUM
      BTSUM=BTSUM+ZSUM(I)**2
      DO 15 J=1,I
      A(KK)=aWV(I,J)
      KK=KK+1
  15  CONTINUE
  14  CONTINUE
      BTSUM=SQRT(BTSUM)
!      write(24,30)
  30  FORMAT(' X(XPRIMEX)-1XPRIME-NI MATRIX')
      DO 24 I=1,NQ
      ZSUM(I)=ZSUM(I)/BTSUM
      K7=I+(I-1)*(I-2)/2
      K8=I+I*(I-1)/2
!      write(24,25)(A(II),II=K7,K8)
  25  FORMAT(60F12.4)
  24  CONTINUE
      LWORK=400
!      write(24,3)
      CALL DSYEV('V','L', NQ, AWV, NQ, D, WK, LWORK, INFO )
!      call rs(20,nq,awv,d,1,wv,wk,a,ier)
!      write(*,833)INFO
!      write(24,833)INFO
  833 FORMAT(' PERFORMANCE INDEX=',I5)
!      write(*,16)
!      write(24,16)
  16  FORMAT(' EIGENVALUES')
      DO 17 I=1,NQ
!
!  TRANSFER EIGENVALUES HERE
!
      EIGENVALUES(I)=D(I)
!      write(24,18) D(I)
!      write(*,18) D(I)
  18  FORMAT(F12.4)
  17  CONTINUE
      XROOT=D(NQ-1)
!      write(24,3)
      A1=XNP*XROOT*(-1.0)
      A2=XNQ*((XNP+XROOT)**2)
      XSIGM=A1/A2
!
!  TRANSFER CORRECTED GOODNESS OF FIT HERE
!
      FITS(1)=XSIGM
      XWV=AWV(NLEFT,NQ-1)
      DO 42 J=1,NQ
  42  IF(XWV.GT.0.0)AWV(J,NQ-1)=-AWV(J,NQ-1)
!      write(24,3)
!      write(*,19)
!      write(24,19)
  19  FORMAT(' STIMULUS COORDINATES')
!      write(*,303)(KNAM(I),I=1,NQ)
!      write(24,303)(KNAM(I),I=1,NQ)
!      write(24,301)(AWV(J,NQ-1),J=1,NQ)
!      write(*,301)(AWV(J,NQ-1),J=1,NQ)
!      write(*,199)
!      write(24,199)
  199 FORMAT(' STIMULUS COORDINATES RAW DATA')
!      write(24,301)(ZSUM(J),J=1,NQ)
!      write(*,301)(ZSUM(J),J=1,NQ)
!      write(24,3)
      DO 40 I=1,NQ
!
!  TRANSFER STIMULUS COORDINATES HERE
!
      STIMCOORDS(I)=AWV(I,NQ-1)
      ZZ(I)=AWV(I,NQ-1)*(XNP/(XNP+XROOT))
  40  CONTINUE
!      REWIND 20
      CALL REG(NRESPONDENTS,NP,NQ,NRESP,NMISS,ZZ,XMISS,KNAM,BTSUM,   &
               ZZSUM,ZSUM,XSIGM,KDATA,XDATA,FITS,RESPCOORDS)
  41  CONTINUE
        DEALLOCATE(KDATA)
        DEALLOCATE(KDEGO)
        DEALLOCATE(A)
        DEALLOCATE(ZZ)
        DEALLOCATE(XMISS)
        DEALLOCATE(B)
        DEALLOCATE(D)
        DEALLOCATE(WK)
        DEALLOCATE(ZSUM)
        DEALLOCATE(AWV)
        DEALLOCATE(XDATA)
!
      EXITSTATUS=1
!
      RETURN
      END
!
!  *****************************************************************
!     SUBROUTINE REG -- DOES SIMPLE OLS TO RECOVER THE INDIVIDUAL
!                       TRANSFORMATION
!  *****************************************************************
!
!
      SUBROUTINE REG(NRESPONDENTS,NN,NQ,NRESP,NMISS,ZZ,XMISS,KNAM,   &
                     BTSUM,ZZSUM,ZTSUM,XSIGM,KDATA,XDATA,FITS,       &
                     RESPCOORDS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION ZZ(3*NQ),RESPCOORDS(NRESPONDENTS*4),                 &
                XMISS(NMISS),                                        &
                ZTSUM(3*NQ),FITS(5),                                 &
                KDATA(NRESPONDENTS,2),XDATA(NRESPONDENTS,NQ+1)
      CHARACTER*13 KNAM(NQ+1)
      DOUBLE PRECISION, ALLOCATABLE :: A(:)
      DOUBLE PRECISION, ALLOCATABLE :: XSUM(:)
      DOUBLE PRECISION, ALLOCATABLE :: YSUM(:)
      DOUBLE PRECISION, ALLOCATABLE :: ZSUM(:)
      DOUBLE PRECISION, ALLOCATABLE :: Q(:)
      DOUBLE PRECISION, ALLOCATABLE :: QQ(:)
      DOUBLE PRECISION, ALLOCATABLE :: QQQ(:)
      DOUBLE PRECISION, ALLOCATABLE :: XV(:,:)
      DOUBLE PRECISION, ALLOCATABLE :: YV(:,:)
      DOUBLE PRECISION, ALLOCATABLE :: ZV(:,:)
!
      ALLOCATE(A(NQ+1))
      ALLOCATE(XSUM(2*NQ))
      ALLOCATE(YSUM(NQ+1))
      ALLOCATE(ZSUM(NQ+1))
      ALLOCATE(Q(NN+NQ))
      ALLOCATE(QQ(NN+NQ))
      ALLOCATE(QQQ(NN+NQ))
      ALLOCATE(XV(NQ,2))
      ALLOCATE(YV(NQ,2))
      ALLOCATE(ZV(2,NQ))
!
      NP=0
      XNQ=NQ
      NNQ=NQ+1
      IF(NRESP.EQ.0)NNQ=NQ
      XKNTL=.001
      XMAX=-99.0
      TMAX=-99.0
      ASUM=0.0
      BSUM=0.0
      CSUM=0.0
      DSUM=0.0
      ESUM=0.0
      TSUM=0.0
      TTSUM=0.0
      DO 111 I=1,NQ
      TMAX=AMAX1(TMAX,ABS(ZZ(I)))
      Q(I)=ZZ(I)
      QQ(I)=ZZ(I)
      QQQ(I)=ZZ(I)
      XSUM(I)=0.0
      ZSUM(I)=0.0
  111 XSUM(I+NQ)=0.0
  3   FORMAT(1X,78('*'))
      IK=0
      IPOS=0
      INEG=0
      SSE=0.0
  2   CONTINUE
      IK=IK+1
      IF(IK.GT.NN)GO TO 10
!      READ(20)IC,I1,(A(J),J=1,NNQ)
      IC=KDATA(IK,1)
      I1=KDATA(IK,2)
      DO 617 J=1,NNQ
      A(J)=XDATA(IK,J)
  617 CONTINUE
      IF(NRESP.EQ.0)GO TO 101
      IF(NMISS.EQ.0)GO TO 1011
      DO 100 I=1,NMISS
      AA=ABS(A(NRESP)-XMISS(I))
  100 IF(AA.LE.XKNTL)GO TO 2
 1011 XRES1=A(NRESP)
  101 CONTINUE
      KK=0
      NP=NP+1
      DO 8 I=1,NNQ
      IF(I.EQ.NRESP)GO TO 8
      KK=KK+1
      XV(KK,1)=1.0
      XV(KK,2)=A(I)
      SSE=SSE+(((A(I)-ZZSUM)/BTSUM)-ZTSUM(KK))**2
  8   CONTINUE
      DO 9 K=1,2
      DO 11 J=1,2
      SUM=0.0
      DO 12 I=1,NQ
      SUM=SUM+XV(I,K)*XV(I,J)
  12  CONTINUE
      YV(K,J)=SUM
  11  CONTINUE
  9   CONTINUE
      DET=1.0/(YV(1,1)*YV(2,2)-YV(1,2)*YV(2,1))
      AA=YV(1,1)
      YV(1,1)=YV(2,2)*DET
      YV(2,2)=AA*DET
      YV(1,2)=YV(1,2)*(-1.0)*DET
      YV(2,1)=YV(2,1)*(-1.0)*DET
      DO 13 K=1,NQ
      DO 14 I=1,2
      SUM=0.0
      DO 15 J=1,2
      SUM=SUM+YV(I,J)*XV(K,J)
  15  CONTINUE
      ZV(I,K)=SUM
  14  CONTINUE
  13  CONTINUE
      DO 16 I=1,2
      SUM=0.0
      DO 17 J=1,NQ
      SUM=SUM+ZV(I,J)*ZZ(J)
  17  CONTINUE
      A(I)=SUM
  16  CONTINUE
      SUMA=0.0
      SUMB=0.0
      SUMC=0.0
      SUMD=0.0
      SUME=0.0
      DO 22 J=1,NQ
      AA=A(1)+A(2)*XV(J,2)
      SUMA=SUMA+AA*ZZ(J)
      SUMB=SUMB+AA
      SUMC=SUMC+ZZ(J)
      SUMD=SUMD+AA*AA
  22  SUME=SUME+ZZ(J)*ZZ(J)
      AA=XNQ*SUMA-SUMB*SUMC
      BB=XNQ*SUMD-SUMB*SUMB
      CC=XNQ*SUME-SUMC*SUMC
      rsqrt=aa/sqrt(abs(bb*cc))
      if(a(2).lt.0.0)rsqrt=-rsqrt
      RR=(AA*AA)/(BB*CC)
      IF(NP.GT.1)GO TO 63
!      if(nresp.ne.0)write(23,64)
  64  FORMAT('      LINE #   CASE #  R POS   ALPHA    BETA',4X,      &
               'SCALED POS',4X,'RSQ')
!      if(nresp.eq.0)write(23,644)
  644 FORMAT('      LINE #   CASE #    ALPHA      BETA',6X,'RSQ',5X, &
               'RAW CORR')
  63  CONTINUE
      AA=A(1)+A(2)*XRES1
      TSUM=TSUM+AA
      TTSUM=TTSUM+AA*AA
  31  FORMAT(2I10,F6.1,5f10.4)
  311 FORMAT(2I10,4F10.4)
!      IF(NRESP.NE.0)WRITE(23,31)IC,I1,XRES1,A(1),A(2),AA,RR,rsqrt
!      IF(NRESP.EQ.0)WRITE(23,311)IC,I1,A(1),A(2),RR,RSQRT
      IF(NRESP.NE.0)Q(NQ+NP)=AA
!
!  TRANSFER RESPONDENT COORDINATES
!
         RESPCOORDS(((KDATA(IK,1)-1)*4)+1)=A(1)
         RESPCOORDS(((KDATA(IK,1)-1)*4)+2)=A(2)
         RESPCOORDS(((KDATA(IK,1)-1)*4)+3)=AA
         RESPCOORDS(((KDATA(IK,1)-1)*4)+4)=RR
!
      IF(A(2).GE.0.0)IPOS=IPOS+1
      IF(A(2).GE.0.0)QQ(IPOS+NQ)=AA
      IF(A(2).LT.0.0)INEG=INEG+1
      IF(A(2).LT.0.0)QQQ(INEG+NQ)=AA
      DO 43 II=1,NQ
      AA=A(1)+XV(II,2)*A(2)
      XSUM(II)=XSUM(II)+AA
      XSUM(II+NQ)=XSUM(II+NQ)+AA*AA
      XCAND=ZZ(II)
      ASUM=ASUM+AA
      BSUM=BSUM+XCAND
      CSUM=CSUM+AA*AA
      DSUM=DSUM+XCAND*XCAND
      ESUM=ESUM+AA*XCAND
  43  CONTINUE
      GO TO 2
  10  CONTINUE
      XNP=NP
      SSE=SQRT(SSE/(XNP*XNQ))
      YSUM(NQ+1)=SQRT((TTSUM-(TSUM*TSUM)/XNP)/(XNP))
      DO 200 I=1,NQ
      ZSUM(I)=XSUM(I)/XNP
  200 YSUM(I)=SQRT((XSUM(I+NQ)-(XSUM(I)*XSUM(I))/XNP)/(XNP))
      ZSUM(NQ+1)=TSUM/XNP
!      write(*,50)
!      write(24,50)
  50  FORMAT(' CORRECTED GOODNESS OF FIT AND RAW FIT')
!      write(*,18)XSIGM,SSE
!      write(24,18)XSIGM,SSE
  18  FORMAT(2F12.4)
!      write(24,3)
!      write(*,19)
!      write(24,19)
  19  FORMAT(' TOTAL CASES--NUMBER POSITIVE  NUMBER NEGATIVE')
!      write(*,20) NP,IPOS,INEG
!      write(24,20) NP,IPOS,INEG
  20  FORMAT(1X,I8,7X,I8,7X,I10)
!
!  TRANSFER CASE NUMBERS HERE
!
      FITS(3)=NP
      FITS(4)=IPOS
      FITS(5)=INEG
!
!      write(24,3)
      RA=XNP*ESUM-ASUM*BSUM
      RB=XNP*CSUM-ASUM*ASUM
      RC=XNP*DSUM-BSUM*BSUM
      R1=RA/(SQRT(RB*RC))
      R1S=R1*R1
!
!  TRANSFER R-SQUARE HERE
!
      FITS(2)=R1S
!
!      write(*,40)
!      write(24,40)
  40  FORMAT(' R AND R-SQUARE')
!      write(*,41) R1,R1S
!      write(24,41) R1,R1S
  41  FORMAT(2F10.4)
!      write(*,302)
!      write(24,302)
  302 FORMAT(' STIMULUS COORDINATES FROM COMPUTED BETA WEIGHTS')
!      write(*,303)(KNAM(I),I=1,NNQ)
!      write(24,303)(KNAM(I),I=1,NNQ)
  303 FORMAT(4X,8(A13,4X)/4x,8(a13,4x)/4x,8(a13,4x))
!      write(*,301)(ZSUM(J),J=1,NNQ)
!      write(24,301)(ZSUM(J),J=1,NNQ)
!      write(*,300)
!      write(24,300)
  300 FORMAT(' STANDARD DEVIATIONS')
!      write(*,301)(YSUM(J),J=1,NNQ)
!      write(24,301)(YSUM(J),J=1,NNQ)
  301 FORMAT(8F9.4/8F9.4/8F9.4)
!      write(24,3)
!
!
        DEALLOCATE(A)
        DEALLOCATE(XSUM)
        DEALLOCATE(YSUM)
        DEALLOCATE(ZSUM)
        DEALLOCATE(Q)
        DEALLOCATE(QQ)
        DEALLOCATE(QQQ)
        DEALLOCATE(XV)
        DEALLOCATE(YV)
        DEALLOCATE(ZV)
      RETURN
      END
