C
C ***************************************************************************
C
C  QUADMD00.FOR---MULTIDIMENSIONAL QUADRATIC UTILITY PROGRAM.  THIS
C                 VERSION IS A STANDALONE PROGRAM THAT GENERATES   
C                 ITS OWN STARTS.                                     
C                         
C               
C                 
C                          1 DECEMBER 2003   
C                                      
C ***************************************************************************
C
C *****ARRAY SIZES BELOW*****
C        LEGISLATORS     1960
C        ROLL CALLS      1701  
C        DUAL USE ARRAYS 5402 > MAX(P,Q)
C        WS(.)           7398 > 2*MAX(P,Q)
C         
C
      DIMENSION LDATA(1960,1701),KAV(1701),LERROR(1960,1701),
     C          WS(7398),XMATSAVE(1960,25),LLEGERR(1960,2),
     C          XMAT(1960,25),MCUTS(1701,2),XRCLOG(1701),KRCLOG(1701),
     C          XLEGLOG(1960),KLEGLOG(1960),OUTXI(1960,25),
     C          ZGAMMA(1701),ZDF(150000,4),CUMNML(150000),YY(150000),
     C          XGAMMA(1960),ZVEC(1701,25),KCUTTER(1701),LCUTTER(1701),
     C          KYES(1701),KNO(1701),XONE(1701),XPT(1701),
     C          KLASSL(1701,2),KLASSRC(1701,2),ZPT(1701),
     C          FV1(20003),FV2(20003),WVEC(1960),ZMAT(1960,1960)
      CHARACTER*1 KNAME(1960,99)
C
      CHARACTER*9 MONTH(100)
      CHARACTER*64 FNAME,FMT,TITLE,FMT1,FMT2
      INTEGER*2 ITIM1,ITIM2,ITIM3,ITIM4,JTIM1,JTIM2,JTIM3,JTIM4,
     C          IYEAR,IMONTH,IDAY
      OPEN(4,FILE='QUADSTRT.DAT',STATUS='OLD')
      OPEN(21,FILE='QUAD0021.DAT')
      OPEN(23,FILE='QUAD0023.DAT')
C      OPEN(26,FILE='QUAD0026.DAT')
C      OPEN(27,FILE='QUAD0027.DAT')
      OPEN(28,FILE='QUAD0028.DAT')
      OPEN(38,FILE='QUAD0038.DAT')
      OPEN(48,FILE='QUAD0048.DAT')
      OPEN(58,FILE='QUAD0058.DAT')
  101 FORMAT(3X,I5,2I2,7A1,I4,2I1,11A1,1600I1)
  102 FORMAT(3X,I5,2I2,7A1,I4,2I1,11A1,1X,10F7.3)
  103 FORMAT(3X,I5,2I2,7A1,I4,2I1,11A1,2I7,30F8.4)
  104 FORMAT(1X,I5,1X,19A1,1X,25F7.3)
  109 FORMAT(1X,I2.2,1X,A9,1X,I4,2X,4(i2.2,'.'))
  200 FORMAT(2I5,2F7.3,10I5)
  201 FORMAT(2I5,8F7.3,20I5)
  202 FORMAT(4F15.6)
  208 FORMAT(5X,I5,2I2,I4,6A1,24X,25F7.3)
C  208 FORMAT(4X,I5,6X,2I3,9X,I4,5X,6A1,5X,F7.3)
C 1002 FORMAT(1X,2I4,I2,4x,4i3,1x,101F7.3)
  209 FORMAT(5X,I4,19X,101F7.3)
  210 FORMAT(6X,I5,2I2,I4,6A1,2F8.3)
  212 FORMAT(I5,1X,I5,2I2,I4,6A1,2I5,50F8.3)
  213 FORMAT(2I5,5I4,25F7.3)
  214 FORMAT(2I5,4I4,F8.3,F12.3,30F8.3)
  250 FORMAT(10I7)
  301 FORMAT(' NOMINATE COORDINATES',I7)
  302 FORMAT(' ROLL CALL MATRIX',2I7)
  303 FORMAT(' ROLL CALL COORDINATES',I7)
  304 FORMAT(' ID MISMATCH',3I7)
  305 FORMAT(' ROLL CALL MISMATCH',3I7)
  306 FORMAT(1X,78('*'))
  310 FORMAT(' NUMBER OF DIMENSIONS',I4)
  316 FORMAT(' AFTER LEGS',3I4,2F7.3,2I3)
  317 FORMAT(' AFTER ZMj ',3I4,2F7.3,2I3)
  318 FORMAT(' AFTER Nj  ',3I4,2F7.3,2I3)
  319 FORMAT(' LEGS: Rs BTWN STARTS & ESTIMATES',2I5,2F8.4)
  323 FORMAT(' NUMBER OF RECORDS READ',3I6)
 1000 FORMAT(22X,4(I2.2,'.'))
 1001 FORMAT(' ELAPSED TIME OF JOB  ',4(I2.2,'.'))
 1002 FORMAT(8I5)
 1003 FORMAT(7I5,F6.3)
 1030 FORMAT(' MAXIMUM SQUARED',F7.3)
 1082 format(A64)
 1097 FORMAT(2I5,5I4,25F7.3)
C
C
      CALL IWKIN(610913)
C
      CALL GETDAT(IYEAR,IMONTH,IDAY)
      call gettim(itim1,itim2,itim3,itim4)
C
      MONTH(1)= 'JANUARY  '
      MONTH(2)= 'FEBRUARY '
      MONTH(3)= 'MARCH    '
      MONTH(4)= 'APRIL    '
      MONTH(5)= 'MAY      '
      MONTH(6)= 'JUNE     '
      MONTH(7)= 'JULY     '
      MONTH(8)= 'AUGUST   '
      MONTH(9)= 'SEPTEMBER'
      MONTH(10)='OCTOBER  '
      MONTH(11)='NOVEMBER '
      MONTH(12)='DECEMBER '
C
      WRITE(*,109)IDAY,MONTH(IMONTH),IYEAR,ITIM1,ITIM2,ITIM3,ITIM4
      WRITE(21,109)IDAY,MONTH(IMONTH),IYEAR,ITIM1,ITIM2,ITIM3,ITIM4
C
      read(4,1082)FNAME 
      write(21,1082)FNAME
      write(*,1082)FNAME
      open(20,file=FNAME,STATUS='OLD')
C
      READ(4,'(A)')TITLE
      WRITE(21,'(A)')TITLE
      WRITE(*,'(A)')TITLE
      READ(4,1003)NS,NRCALL,NLAST,JNE,NLEFT,NUP2,KVMIN,XVMIN
C
C  ERROR CATCH FOR NLEFT, NUP2, KVMIN, AND XVMIN
C
      IF(NLEFT.LE.0)NLEFT=1
      IF(NUP2.LE.0)NUP2=1
      IF(KVMIN.LE.0)KVMIN=10
      IF(XVMIN.LT.0.005)XVMIN=.005
C
      WRITE(21,1003)NS,NRCALL,NLAST,JNE,NLEFT,NUP2,KVMIN,XVMIN
      WRITE(*,1003)NS,NRCALL,NLAST,JNE,NLEFT,NUP2,KVMIN,XVMIN
      READ(4,'(A)')FMT
      WRITE(21,'(A)')FMT
      WRITE(*,'(A)')FMT
      READ(4,'(A)')FMT1
      WRITE(21,'(A)')FMT1
      WRITE(*,'(A)')FMT1
      READ(4,'(A)')FMT2
      WRITE(21,'(A)')FMT2
      WRITE(*,'(A)')FMT2
      WRITE(21,306)
C
C
      KSWITCH=1
C      XVMIN=0.0250
C      KVMIN=25
C
C
C  READ IN CUMULATIVE NORMAL DISTRIBUTION FUNCTION
C
C
      ndevit=50001
      XDEVIT=10000.0
C
      DO 501 I=1,NDEVIT
      YY(I)=FLOAT(I-1)/XDEVIT
      X=(FLOAT(I-1)/XDEVIT)/SQRT(2.0)
      XX=ERF(X)
      XX=XX/2.0 +.5
      CUMNML(I)=XX
 501  CONTINUE
C
      TWOPI=1.0/SQRT(2.0*3.1415926536)
      DO 901 I=1,NDEVIT
      ZDF(I,1)=YY(NDEVIT+1-I)*(-1.0)
      ZDF(I,2)=1.0-CUMNML(NDEVIT+1-I)
      ZDF(I,3)=ALOG(ZDF(I,2))
 901  CONTINUE
      DO 902 I=2,NDEVIT
      ZDF(I-1+NDEVIT,1)=YY(I)
      ZDF(I-1+NDEVIT,2)=CUMNML(I)
      ZDF(I-1+NDEVIT,3)=ALOG(ZDF(I-1+NDEVIT,2))
 902  CONTINUE
      DO 903 I=1,2*NDEVIT-1
      ZDF(I,4)=(TWOPI*EXP((-ZDF(I,1)**2)/2.0))/ZDF(I,2)
C      WRITE(23,202)(ZDF(I,J),J=1,4)
 903  CONTINUE    
C
C     READ THE ROLL CALL MATRIX
C
      I=0
  551 READ(20,FMT,END=451)(KNAME(I+1,J),J=1,JNE),
     C                    (LDATA(I+1,J),J=1,NRCALL)
      I=I+1
      GO TO 551
  451 WRITE(*,302)I
      WRITE(23,302)I
      NP=I
C
C  SUBROUTINE CLEAN--THROWS OUT ALL VOTES WITH LESS THAN XVMIN MAJ. AND
C    ALL LEGISLATORS VOTING LESS THAN KVMIN TIMES
C
      call CLEAN(NP,NRCALL,JNE,XVMIN,KVMIN,LDATA,KNAME,
     C            KAV,KYES,KNO)
C
C
C
C  CALL SUBROUTINE DOUBLEC -- COMPUTES AGREEMENT SCORES AND DOUBLE CENTERS THE
C                             SQUARED DISTANCE MATRIX
C
      CALL DOUBLEC(NP,NRCALL,NS,ZMAT,WVEC,LDATA)
C 
C  SET STARTING VALUE OF LEGISLATOR COORDINATES TO EIGENVECTORS OF AGREEMENT
C    SCORE MATRIX
C
      DO 472 I=1,NP
      DO 471 K=1,NS
      XMAT(I,K)=ZMAT(I,NP+1-K)
  471 CONTINUE
  472 CONTINUE
C
C  NORMALIZE CURRENT ESTIMATES OF LEGISLATORS TO BE WITHIN THE
C   UNIT HYPERSPHERE WITH CENTROID = 0
C
      DO 31 K=1,NS
      SUM=0.0
      DO 30 I=1,NP
  30  SUM=SUM+XMAT(I,K)
      DO 32 I=1,NP
      XMAT(I,K)=XMAT(I,K)-SUM/FLOAT(NP)
  32  CONTINUE
  31  CONTINUE
      BBB=-99.0
      DO 46 I=1,NP
      SUM=0.0
      DO 34 K=1,NS
      SUM=SUM+XMAT(I,K)**2
  34  CONTINUE
      BBB=AMAX1(BBB,SUM)
  46  CONTINUE
      WRITE(*,1030)BBB
      WRITE(23,1030)BBB
C
C  GET PARTY POLARITY
C
      XLEFT=XMAT(NLEFT,1)
      XUP2=XMAT(NUP2,2)
      DO 35 I=1,NP
      DO 36 K=1,NS
      XMAT(I,K)=XMAT(I,K)*(1.0/SQRT(BBB))
  36  CONTINUE
      IF(XLEFT.GT.0.0)XMAT(I,1)=-XMAT(I,1)
      IF(XUP2.LT.0.0)XMAT(I,2)=-XMAT(I,2)
C      WRITE(28,104)I,(KNAME(I,J),J=1,JNE),(XMAT(I,K),K=1,NS)
      DO 37 K=1,NS
      XMATSAVE(I,K)=XMAT(I,K)
  37  CONTINUE
      XONE(I)=XMAT(I,1)
  35  CONTINUE
C
C
C    RUN EDITH TO GET OPTIMAL CLASSIFICATIONS FOR S=1
C
      IF(NS.EQ.1)THEN
         CALL EDITH(NP,NRCALL,NS,XMAT,XONE,XPT,ZPT,XCLASS,KTOTC,
     C           KCUTTER,LCUTTER,LDATA,LERROR)
         DO 617 I=1,NP
         XMAT(I,1)=XPT(I)
  617    CONTINUE
C      
C
         DO 616 JJ=1,NRCALL
         MCUTS(JJ,1)=KCUTTER(JJ)
         MCUTS(JJ,2)=LCUTTER(JJ)
         WS(JJ)=ZPT(JJ)
         ZVEC(JJ,1)=1.0
  616    CONTINUE
      ENDIF
C
C  IF S > 1 RUN CUTTING PLANE AND LEGISLATOR PROCEDURES TO
C    GET OPTIMAL CLASSIFICATION STARTS
C
      IF(NS.GT.1)THEN
C
C  INITIALIZE NORMAL VECTORS TO SQRT(1/S)
C
         DO 618 JJ=1,NRCALL
         DO 619 K=1,NS
         ZVEC(JJ,K)=SQRT(1.0/FLOAT(NS))
  619    CONTINUE
  618    CONTINUE
         IFIXX=1
         DO 620 JJJ=1,5
         CALL CUTPLANE(JJJ,NP,NRCALL,NS,XMAT,ZVEC,WS,
     C                MCUTS,LERROR,IFIXX,KTT,KT,LDATA)
         CALL LEGIS(JJJ,NP,NRCALL,NS,XMAT,LLEGERR,
     C                  ZVEC,WS,MCUTS,LERROR,LTOTAL,MWRONG,
     C                  LDATA)
  620    CONTINUE
C
C  WRITE OUT COORDINATES FROM OPTIMAL CLASSIFICATION PROCEDURE
C
C         WRITE(28,306)
         DO 621 I=1,NP
         IX=I
C
         CALL VOLUME2(IX,NS,NRCALL,LDATA,XMAT,ZVEC,WS,BMAX,KBMAX)
C
         BPER=FLOAT(LLEGERR(I,2)-LLEGERR(I,1))/FLOAT(LLEGERR(I,2))
         WRITE(38,FMT1)I,(KNAME(I,J),J=1,JNE),LLEGERR(I,1),LLEGERR(I,2),
     C                             BPER,BMAX,(XMAT(I,K),K=1,NS)
  621    CONTINUE
C
C         WRITE(28,306)
         DO 441 JX=1,NRCALL
C
C  SET POLARITY ON NORMAL VECTOR
C
         IF(ZVEC(JX,1).LT.0.0)THEN
            DO 908 K=1,NS
            ZVEC(JX,K)=-ZVEC(JX,K)
  908       CONTINUE
            WS(JX)=-WS(JX) 
            KSAVE=MCUTS(JX,1)
            MCUTS(JX,1)=MCUTS(JX,2)
            MCUTS(JX,2)=KSAVE
         ENDIF
         KSUM=0
         KLOW=0
         KHIGH=0
         KYESKYES=0
         KNOKNO=0
         DO 442 I=1,NP
         IF(LERROR(I,JX).EQ.1)KSUM=KSUM+1
         IF(LDATA(I,JX).EQ.1)KYESKYES=KYESKYES+1
         IF(LDATA(I,JX).EQ.6)KNOKNO=KNOKNO+1
C
C      CALCULATE PREDICTED MARGIN
C
         SUM=0.0
         DO 909 K=1,NS
         SUM=SUM+XMAT(I,K)*ZVEC(JX,K)
  909    CONTINUE
         IF(SUM.LT.WS(JX))THEN
            KLOW=KLOW+1
         ENDIF
         IF(SUM.GT.WS(JX))THEN
            KHIGH=KHIGH+1
         ENDIF
  442    CONTINUE
         KYESNO=AMIN0(KYESKYES,KNOKNO)
         XPRE=FLOAT(KYESNO-KSUM)/FLOAT(KYESNO)
C
         WRITE(28,1097)JX,KAV(JX),KYESKYES,KNOKNO,
     C                 KSUM,KLOW,KHIGH,XPRE,WS(JX),
     C                (ZVEC(JX,K),K=1,NS)
  441 CONTINUE
C
      ENDIF
C
      NOISE=867
C      IF(NOISE.EQ.867)STOP
C  INITIALIZE LEGISLATOR VARIANCES TO +1.0
C
      DO 870 I=1,NP
      XGAMMA(I)=1.0
  870 CONTINUE
C
C  MASTER LOOP FOR QUADRATIC UTILITY MODEL
C
      DO 9999 IIII=1,3
C
C  DECOMPOSE THE VARIANCE TERMS
C
      DO 7777 LLLL=1,2
C
C  ESTIMATE  (2*GAMMAj)/SIGMAj TERMS FOR ROLL CALLS
C
      CALL QUADRPS(NS,NP,NRCALL,MCUTS,XMAT,WS,ZVEC,LDATA,
     C              ZGAMMA,XGAMMA,ZDF,NDEVIT,XDEVIT)
C
C  ESTIMATE SIGMAi TERMS FOR LEGISLATORS
C
      CALL QUADRPSL(NS,NP,NRCALL,MCUTS,XMAT,WS,ZVEC,LDATA,
     C              ZGAMMA,XGAMMA,ZDF,NDEVIT,XDEVIT)
 7777 CONTINUE
C
C  ESTIMATE LEGISLATOR COORDINATES
C
      CALL QUADRPL(NS,NP,NRCALL,MCUTS,XMAT,WS,ZVEC,LDATA,
     C         ZGAMMA,XGAMMA,XLEGLOG,KLEGLOG,OUTXI,ZDF,NDEVIT,XDEVIT)
C
C  ESTIMATE ROLL CALL MIDPOINTS
C
      CALL QUADRPC(NS,NP,NRCALL,MCUTS,XMAT,WS,ZVEC,LDATA,
     C             ZGAMMA,XGAMMA,XRCLOG,KRCLOG,ZDF,NDEVIT,XDEVIT)
C
C  ESTIMATE ROLL CALL NORMAL VECTORS
C
      IF(NS.GT.1)THEN
         CALL QUADRPN(NS,NP,NRCALL,MCUTS,XMAT,WS,ZVEC,LDATA,
     C             ZGAMMA,XGAMMA,XRCLOG,KRCLOG,ZDF,NDEVIT,XDEVIT)
      ENDIF
C
 9999 CONTINUE
C
      CALL CLASSIFY(NS,NP,NRCALL,MCUTS,XMAT,WS,ZVEC,LDATA,
     C                    KLASSL,KLASSRC)
C
C  WRITE OUT SIGMAi TERMS FOR LEGISLATORS
C
C      WRITE(28,306)
C
      DO 662 I=1,NP
      GMP=EXP(XLEGLOG(I)/KLEGLOG(I))    
C      WRITE(48,7007)XLEGLOG(I),KLEGLOG(I)
 7007 FORMAT(F12.5,I6)
      BB=FLOAT(KLASSL(I,1))/FLOAT(KLASSL(I,1)+KLASSL(I,2))
      WRITE(48,FMT2)I,(KNAME(I,J),J=1,JNE),
     C                    (KLASSL(I,J),J=1,2),BB,XLEGLOG(I),GMP,
     C                    (XMAT(I,JJ),JJ=1,NS),1.0/XGAMMA(I),
     C                    (OUTXI(I,JJ),JJ=1,NS)
  662 CONTINUE
C
C  WRITE OUT (2*GAMMAj)/SIGMAj TERMS FOR ROLL CALLS
C
      DO 661 I=1,NRCALL
      GMP=EXP(XRCLOG(I)/KRCLOG(I))
C      WRITE(58,7007)XRCLOG(I),KRCLOG(I)
      AA=2.0*ZGAMMA(I)
      BB=FLOAT(KLASSRC(I,1))/FLOAT(KLASSRC(I,1)+KLASSRC(I,2))
      WRITE(58,214)I,KAV(I),KYES(I),KNO(I),(KLASSRC(I,J),J=1,2),BB,
     C     XRCLOG(I),GMP,
     C     WS(I),(ZVEC(I,J),J=1,ns),AA
  661 CONTINUE
C
C  CALCULATE R-SQUARES BETWEEN INPUT AND CONVERGED 
C     LEGISLATOR COORDINATES
C
      DO 663 K=1,NS
      DO 664 I=1,NP
      FV1(I)=XMAT(I,K)
      FV2(I)=XMATSAVE(I,K)
  664 CONTINUE
      CALL SPEARMAN(NP,FV1,FV2,RSPEAR,RPEARS)
      WRITE(21,319)K,NP,RSPEAR,RPEARS
      WRITE(*,319)K,NP,RSPEAR,RPEARS
  663 CONTINUE
C
      CALL GETTIM(JTIM1,JTIM2,JTIM3,JTIM4)
      WRITE(*,1000)ITIM1,ITIM2,ITIM3,ITIM4
      WRITE(*,1001)JTIM1,JTIM2,JTIM3,JTIM4
      WRITE(21,1000)ITIM1,ITIM2,ITIM3,ITIM4
      WRITE(21,1001)JTIM1,JTIM2,JTIM3,JTIM4
      STOP
      END
C
C **************************************************************************
C  SUBROUTINE VOLUME2 -- CALCULATES VOLUME OF REGION CONTAINING LEGISLATOR
C                           POINT
C                       
C **************************************************************************
C
      SUBROUTINE VOLUME2(IX,NS,NRCALL,LDATA,XMAT,ZVEC,WS,BBSAVE,KKSAVE)
      DIMENSION LDATA(1960,1701),XMAT(1960,25),XMAT2(1960,25),
     C          XXY(1701),WS(7398),XXX(1701),
     C          ZVEC(1701,25),TVEC(1701,25)
 1000 FORMAT(3I4,20F7.3)
 1001 FORMAT(' MAX ITER',3I5,F6.3,2X,100F7.3)
C
      call gettim(itim1,itim2,itim3,itim4)
      iseed=1000*itim2+100*itim2+1000*itim3+200*itim4
c
      call rnset(iseed)
C
      KKSAVE=-99 
      BBSAVE=-999.0
C
C PUT POINTS ON CUTTING PLANES CLOSEST TO Xi
C
      DO 777 LM=1,100
      SUM=0.0
      DO 59 K=1,NS
C      TVEC(LM,K)=(URAND(ISEED)-.50)
      TVEC(LM,K)=(RNUNF()-.50)
      SUM=SUM+TVEC(LM,K)**2
  59  CONTINUE
      DO 60 K=1,NS
      TVEC(LM,K)=TVEC(LM,K)/SQRT(SUM)
  60  CONTINUE
      XINC=.002
C
      DO 776 KLM=1,500
      SUMBIG=0.0
      DO 61 K=1,NS
      XMAT2(LM,K)=XMAT(IX,K)+XINC*TVEC(LM,K)
      SUMBIG=SUMBIG+XMAT2(LM,K)**2
  61  CONTINUE
C
C  CHECK IF POINT MOVES OUTSIDE HYPERSPHERE
C
      IF(SUMBIG.GE.1.0)GO TO 933
      DO 93 JX=1,NRCALL
      SUM=0.0
      SUM1=0.0
      DO 90 K=1,NS
      SUM= SUM+ XMAT(IX,K)*ZVEC(JX,K)
      SUM1=SUM1+XMAT2(LM,K)*ZVEC(JX,K)
  90  CONTINUE
      XXY(JX)=SUM
      XXX(JX)=SUM1
C
C  CHECK IF POINT MOVES OUTSIDE POLYTOPE
C
      IF(LDATA(IX,JX).EQ.0)GO TO 108
      IF(XXY(JX).LT.WS(JX))THEN
         IF(XXX(JX).GT.WS(JX))GO TO 933
      ENDIF
      IF(XXY(JX).GT.WS(JX))THEN
         IF(XXX(JX).LT.WS(JX))GO TO 933
      ENDIF
  108 CONTINUE
  93  CONTINUE
      XINC=XINC+.001
  776 CONTINUE
      WRITE(23,1001)IX,KLM,LM,XINC,(XMAT2(LM,K),K=1,NS),
     C                (TVEC(LM,K),K=1,NS),(XMAT(IX,K),K=1,NS)
  933 CONTINUE
      SUM=0.0
      DO 81 K=1,NS
      SUM=SUM+(XMAT2(LM,K)-XMAT(IX,K))**2
  81  CONTINUE
      SUM=SQRT(SUM)
      BBSAVE=AMAX1(BBSAVE,SUM)
      KKSAVE=AMAX0(KKSAVE,KLM)
C
  777 CONTINUE
      RETURN
      END
C
C
C
C *********************************************************************
C   SUBROUTINE LEGIS -- PERFORMS THE LEGISLATIVE PROCEDURE
C                       
C
C                           30 JUNE 1999
C
C *********************************************************************
C
      SUBROUTINE LEGIS(JJJ,NP,NRCALL,NS,XMAT,LLEGERR,
     C                  ZVEC,WS,MCUTS,LERROR,LTOTAL,MWRONG,
     C                  LDATA)
      DIMENSION XMAT(1960,25),ZVEC(1701,25),BB(25,1701),
     C          MCUTS(1701,2),WS(7398),LERROR(1960,1701),
     C          LLEGERR(1960,2),LDATA(1960,1701)
C
C
 1094 FORMAT(' LEG CLASSIFICATION ERROR  ',2I3,2I8,2F10.5)
C
      CALL ZVECINV(NRCALL,NS,ZVEC,BB)
C
      LTOTAL=0
      LWRONG=0
      MWRONG=0
      DO 111 I=1,NP
      IVOT=I
      CALL KTPXI(IVOT,NRCALL,NS,MCUTS,BB,XMAT,ZVEC,WS,
     C            LERROR,KTOTAL,KWRONG,LDATA)
C
      MWRONG=MWRONG+KWRONG
      LTOTAL=LTOTAL+KTOTAL
      LLEGERR(I,1)=KWRONG
      LLEGERR(I,2)=KTOTAL
C
  111 CONTINUE
      IF(LTOTAL.GT.0)THEN
        XERROR=FLOAT(MWRONG)/FLOAT(LTOTAL)
        YERROR=1.0-XERROR
      ENDIF
      WRITE(21,1094)JJJ,NS,MWRONG,LTOTAL,XERROR,YERROR
      WRITE(23,1094)JJJ,NS,MWRONG,LTOTAL,XERROR,YERROR
      WRITE(* ,1094)JJJ,NS,MWRONG,LTOTAL,XERROR,YERROR
      RETURN
      END
C
C **************************************************************************
C  SUBROUTINE ZVECINV -- CALCULATES (Z'Z)-1Z' WHERE Z IS THE NORMAL PLANE
C                        MATRIX
C **************************************************************************
C
      SUBROUTINE ZVECINV(NRCALL,NS,ZVEC,BB)
      DIMENSION VVV(25,25),FV1(1960),FV2(1960),
     C          VCOV(25,25),WVEC(25),UL(25,25),
     C          BB(25,1701),
     C          ZVEC(1701,25)
C
 1011 FORMAT(7F10.4)
 1012 FORMAT(' DECOMPOSITION OF NORMAL VECTOR MATRIX',3I4)
 1091 FORMAT(' INVERSE MATRIX ERROR',F10.4)
C
C
C    (X'X)
C
      DO 38 K=1,NS
      DO 39 L=1,NS
      SUM=0.0
      DO 40 I=1,NRCALL
      SUM=SUM+ZVEC(I,K)*ZVEC(I,L)
  40  CONTINUE
      VCOV(K,L)=SUM
  39  CONTINUE
  38  CONTINUE
C
C  EIGENVECTOR-EIGENVALUE DECOMPOSITION OF NORMAL VECTOR MATRIX
C
      call rs(25,NS,VCOV,WVEC,1,VVV,FV1,FV2,IER)
C      WRITE(21,1012)NS,NRCALL,IER
C      WRITE(*,1012)NS,NRCALL,IER
C      WRITE(21,1011)(WVEC(K),K=1,NS)
C
C  (X'X)-1
C
      DO 83 I=1,NS
      DO 83 K=1,NS
      SUM=0.0
      DO 84 J=1,NS
      IF(ABS(WVEC(NS+1-J)).GT..0001)THEN
          SUM=SUM+VVV(K,NS+1-J)*(1.0/WVEC(NS+1-J))*VVV(I,NS+1-J)
      ENDIF
  84  CONTINUE
  83  UL(I,K)=SUM
C
C
C  MATRIX INVERSION CHECK  (X'X)-1(X'X) = I
C 
      ASUM=0.0
      DO 933 I=1,NS
      DO 933 J=1,NS
      SUM=0.0
      DO 944 K=1,NS
      SUM=SUM+UL(J,K)*VCOV(K,I)
  944 CONTINUE
      IF(I.EQ.J)ASUM=ASUM+ABS(1.0-SUM)
      IF(I.NE.J)ASUM=ASUM+ABS(SUM)
  933 CONTINUE
      IF(ASUM.GT..01)WRITE(*,1091)ASUM
      IF(ASUM.GT..01)WRITE(23,1091)ASUM
C
C  (X'X)-1*X'
C
      DO 85 I=1,NRCALL
      DO 85 J=1,NS
      SUM=0.0
      DO 86 JJ=1,NS
      SUM=SUM+UL(J,JJ)*ZVEC(I,JJ)
  86  CONTINUE
  85  BB(J,I)=SUM
C
      RETURN
      END
C
C **************************************************************************
C  SUBROUTINE KTPXI -- PERFORMS LEGISLATOR FITTING
C **************************************************************************
C
      SUBROUTINE KTPXI(ILEG,NRCALL,NS,MCUTS,BB,XMAT,ZVEC,WS,
     C                        LERROR,KTOTAL,KWRONG,LDATA)
      DIMENSION BB(25,1960),XMAT(1960,25),WS(7398),LERROR(1960,1701),
     C          ZVEC(1701,25),MCUTS(1701,2),
     C          ZWRONG(50),XDAT(1960,25),XXZ(1701),LL(1701),
     C          YWRONG(1701,25),YYWRONG(1701,25),LSAVE(1701,25),
     C          XMAT2(25),XXY(1701),YYYWRONG(1701,25),
     C          LDATA(1960,1701)
C
 1001 FORMAT(I4,2X,I6,I4)
 1011 FORMAT(I4,2I3,I4,12F7.3)
 1012 FORMAT(14X,12F7.3)
 1013 FORMAT(' LEG',2I3,I4,12F7.3)
 1014 FORMAT(' WHOA DUDE',I4,I3,I4)
 1015 FORMAT(' HEY THESE ARE NOT EQUAL!')
 1016 FORMAT(I4,2I3,I4,12F7.3)
 1017 FORMAT(14X,I4,12F7.3)
 1018 FORMAT(10X,2I4,12F7.3)
 1019 FORMAT(16X,12F7.3)
 1020 FORMAT(2I4,3F10.4)
 1021 FORMAT(4I4,12F7.3)
 1022 FORMAT(' TWO  ',3I4,12F7.3)
 1023 FORMAT(' THREE',3I4,12F7.3)
 1024 FORMAT(' FOUR ',3I4,12F7.3)
 1025 FORMAT(4X,4X,12X,12F7.3)
 1026 FORMAT(I4,25F7.3)
C
      NTRIAL2=15
      MZZZ=5
C
C      WRITE(21,1019)(XMAT(ILEG,K),K=1,NS)
      DO 203 K=1,NS
      XDAT(20,K)=XMAT(ILEG,K)
  203 CONTINUE
C
      DO 9887 IIII=1,2
      SUM=0.0
      DO 101 K=1,NS
      XDAT(1,K)=0.0
C      IF(IIII.EQ.2)XDAT(1,K)=0.1
      IF(IIII.EQ.2)XDAT(1,K)=XDAT(20,K)
      XDAT(2,K)=XDAT(1,K)
  101 CONTINUE
C
C      WRITE(21,1019)(XDAT(1,K),K=1,NS)
      KWRONG=0
      K3WRONG=0
C
      DO 9888 III=1,MZZZ
C
      DO 988 II=1,NTRIAL2
      NII=II
      DO 987 KL=1,NS
C
      K3WRONG=KWRONG
      XDAT(2,KL)=0.01
C
C
C  CALCULATE FEASIBLE ALPHA VALUE
C
      ASUM=0.0
      AAA=0.0
      BBB=0.0
      DO 902 ML=1,NS
      ASUM=ASUM+XDAT(1,ML)**2
      AAA=AAA+(XDAT(2,ML)-XDAT(1,ML))**2
      BBB=BBB+2.0*(XDAT(2,ML)-XDAT(1,ML))*XDAT(1,ML)
  902 CONTINUE
      CCC=ASUM - 1.0
      RAD=BBB*BBB-4.0*AAA*CCC
      RADSQ=SQRT(ABS(RAD))
      ROOT1=0.0
      ROOT2=0.0
      IF(AAA.GT..00001)THEN
         ROOT1=(-BBB+RADSQ)/(2.0*AAA)
         ROOT2=(-BBB-RADSQ)/(2.0*AAA)
      ENDIF
C
      CALL KTPXIXJ(NII,ILEG,NRCALL,NS,MCUTS,BB,XDAT,ZVEC,WS,
     C                XXZ,WSSY,XMAT2,ZWRONG,YYWRONG,LERROR,KTOTAL,
     C                KWRONG,ROOT1,ROOT2,LDATA)
C
      LSAVE(II,KL)=KWRONG
      IF(KWRONG.EQ.0)THEN
         LL(1)=II
         DO 668 K=1,NS
         XMAT(ILEG,K)=XMAT2(K)
  668    CONTINUE
         KKNII=NII
         K3WRONG=KWRONG
C         WRITE(21,1021)ILEG,III,II,KWRONG,(XMAT(ILEG,K),K=1,NS)
         GO TO 996
      ENDIF
C
      SUM=0.0
      DO 133 K=1,NS
      SUM=SUM+XMAT2(K)**2
      YWRONG(II,K)=XMAT2(K)
      YYYWRONG(KL,K)=XMAT2(K)
      XDAT(3,K)=XDAT(1,K)
      XDAT(1,K)=XMAT2(K)
      XDAT(2,K)=XMAT2(K)
      XMAT(ILEG,K)=XMAT2(K)
  133 CONTINUE
C
C      WRITE(21,1011)ILEG,II,KL,KWRONG,(XDAT(3,K),K=1,NS)
C      WRITE(21,1012)(XMAT2(K),K=1,NS),(ZWRONG(K),K=1,NS)
C                                      
  987 CONTINUE
C
      SUM=0.0
      KSUM=0
      DO 132 K=1,NS
      IF(II.GT.1)THEN
         SUM=SUM+(YWRONG(II,K)-YWRONG(II-1,K))**2
         KSUM=KSUM+ABS(LSAVE(II,K)-LSAVE(II-1,K))
      ENDIF
  132 CONTINUE
      IF(II.EQ.1)GO TO 988
      IF(SUM.LE..000001)GO TO 986
      IF(II.GT.5.AND.KSUM.EQ.0)GO TO 986
  988 CONTINUE
C
  986 CONTINUE
C      WRITE(21,1021)ILEG,III,II,KWRONG,(XMAT(ILEG,K),K=1,NS)
      KKKNII=NII
      K3WRONG=KWRONG
C
C
C  CALCULATE FEASIBLE ALPHA VALUE
C
      ASUM=0.0
      AAA=0.0
      BBB=0.0
      DO 903 ML=1,NS
      XDAT(1,ML)=XMAT(ILEG,ML)
      XDAT(2,ML)=ZWRONG(K)
      ASUM=ASUM+XDAT(1,ML)**2
      AAA=AAA+(XDAT(2,ML)-XDAT(1,ML))**2
      BBB=BBB+2.0*(XDAT(2,ML)-XDAT(1,ML))*XDAT(1,ML)
  903 CONTINUE
      CCC=ASUM - 1.0
      RAD=BBB*BBB-4.0*AAA*CCC
      RADSQ=SQRT(ABS(RAD))
      ROOT1=0.0
      ROOT2=0.0
      IF(AAA.GT..00001)THEN
         ROOT1=(-BBB+RADSQ)/(2.0*AAA)
         ROOT2=(-BBB-RADSQ)/(2.0*AAA)
      ENDIF
C      ROOT1=(-BBB+RADSQ)/(2.0*AAA)
C      ROOT2=(-BBB-RADSQ)/(2.0*AAA)
C
      CALL KTPXIXJ(NII,ILEG,NRCALL,NS,MCUTS,BB,XDAT,ZVEC,WS,
     C                XXZ,WSSY,XMAT2,ZWRONG,YYWRONG,LERROR,KTOTAL,
     C                KWRONG,ROOT1,ROOT2,LDATA)
C
C      WRITE(21,1021)ILEG,III,II,KWRONG,(XMAT2(K),K=1,NS),WSSY
C
      DO 44 K=1,NS
      XMAT(ILEG,K)=XMAT2(K)
      XDAT(1,K)=XMAT2(K)
      XDAT(2,K)=XMAT2(K)
      IF(IIII.EQ.1)XDAT(10,K)=XMAT2(K)
  44  CONTINUE
      IF(KWRONG.EQ.0)GO TO 996
 9888 CONTINUE
      IF(IIII.EQ.1)KLWRONG=KWRONG
      IF(IIII.EQ.2)THEN
C
C  CALCULATE FEASIBLE ALPHA VALUE
C
         ASUM=0.0
         AAA=0.0
         BBB=0.0
         DO 905 ML=1,NS
         XDAT(1,ML)=XMAT(ILEG,ML)
         XDAT(2,ML)=XDAT(10,ML)
         ASUM=ASUM+XDAT(1,ML)**2
         AAA=AAA+(XDAT(2,ML)-XDAT(1,ML))**2
         BBB=BBB+2.0*(XDAT(2,ML)-XDAT(1,ML))*XDAT(1,ML)
  905    CONTINUE
         CCC=ASUM - 1.0
         RAD=BBB*BBB-4.0*AAA*CCC
         RADSQ=SQRT(ABS(RAD))
         ROOT1=0.0
         ROOT2=0.0
         IF(AAA.GT..00001)THEN
            ROOT1=(-BBB+RADSQ)/(2.0*AAA)
            ROOT2=(-BBB-RADSQ)/(2.0*AAA)
         ENDIF
C         ROOT1=(-BBB+RADSQ)/(2.0*AAA)
C         ROOT2=(-BBB-RADSQ)/(2.0*AAA)
C
         CALL KTPXIXJ(NII,ILEG,NRCALL,NS,MCUTS,BB,XDAT,ZVEC,WS,
     C                XXZ,WSSY,XMAT2,ZWRONG,YYWRONG,LERROR,KTOTAL,
     C                KWRONG,ROOT1,ROOT2,LDATA)
C
C         WRITE(21,1021)ILEG,III,II,KWRONG,(XMAT2(K),K=1,NS),WSSY
C   
         DO 48 K=1,NS
         XMAT(ILEG,K)=XMAT2(K)
  48     CONTINUE
         IF(KWRONG.EQ.0)GO TO 996
      ENDIF
C
 9887 CONTINUE
C
  996 CONTINUE
C
      SUM=0.0
      DO 12 K=1,NS
      SUM=SUM+XMAT(ILEG,K)**2
  12  CONTINUE
      IF(SUM.GT.1.0)THEN
         DO 13 K=1,NS
         XMAT(ILEG,K)=XMAT(ILEG,K)/SQRT(SUM)
  13     CONTINUE
      ENDIF
C
      KKRITE=0
      KKWRONG=0
      KTOTAL=0
      DO 31 JX=1,NRCALL
      LERROR(ILEG,JX)=0
      SUM=0.0
      DO 32 K=1,NS
      SUM=SUM+XMAT(ILEG,K)*ZVEC(JX,K)
  32  CONTINUE
      XXY(JX)=SUM
      DB2B1=WS(JX)-XXY(JX)
C
C  CALCULATE CLASSIFICATION ERROR
C
      IF(LDATA(ILEG,JX).NE.0)THEN
         IF(XXY(JX).LT.WS(JX))THEN
            KTOTAL=KTOTAL+1
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,1))THEN
               KKRITE=KKRITE+1
            ENDIF
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,2))THEN
               LERROR(ILEG,JX)=1
               KKWRONG=KKWRONG+1
            ENDIF
         ENDIF
         IF(XXY(JX).GT.WS(JX))THEN
            KTOTAL=KTOTAL+1
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,2))THEN
               KKRITE=KKRITE+1
            ENDIF
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,1))THEN
               LERROR(ILEG,JX)=1
               KKWRONG=KKWRONG+1
            ENDIF
         ENDIF
      ENDIF
  31  CONTINUE
C      WRITE(21,1001)ILEG,KKRITE,KKWRONG
      IF(KKWRONG.NE.KWRONG)THEN
         WRITE(21,1015)
      ENDIF
      SUM=0.0
      DO 204 K=1,NS
      SUM=SUM+(XDAT(20,K)-XMAT(ILEG,K))**2
  204 CONTINUE
      SUM=SQRT(SUM)
C      WRITE(23,1026)ILEG,SUM
      RETURN
      END
C
C **************************************************************************
C  SUBROUTINE KTPXIXJ -- PERFORMS LEGISLATOR FITTING
C **************************************************************************
C
      SUBROUTINE KTPXIXJ(NII,ILEG,NRCALL,NS,MCUTS,BB,XDAT,ZVEC,WS,
     C                      XXZ,WSSY,XMAT2,ZWRONG,YWRONG,LERROR,KTOTAL,
     C                      KKWRONG,ROOT1,ROOT2,LDATA)
      DIMENSION BB(25,1960),XDAT(1960,25),WS(7398),LERROR(1960,1701),
     C          ZVEC(1701,25),MCUTS(1701,2),XXY(1701),XXZ(1701),
     C          XSAVE(1701,100),MRITE(1701,100),
     C          ZWRONG(50),YWRONG(1701,25),
     C          XALL(7398),KALL(7398),XMAT2(25),
     C          YALL(7398),LALL(7398),LDATA(1960,1701)
C
C
 1012 FORMAT(I4,3I6,7F7.3)
C 1013 FORMAT(2I4,3I6,F12.6,6F7.3/8X,8F7.3/8X,8F7.3)
 1013 FORMAT(2I4,4I6,3F7.3)
 1014 FORMAT(15X,I6,13X,4F7.3)
 1015 FORMAT(I5,4F7.3)
 1016 FORMAT(I5,2F7.3,I3,F7.3)
 1017 FORMAT(I5,2F10.4,3F7.3)
 1018 FORMAT(4X,6I5,F10.4)
 1019 FORMAT(2I4,4I6)
 1020 FORMAT(' INITIAL ERROR',I4,3I6,7F7.3)
 1021 FORMAT(I3,2I5,15F7.3)
 1023 FORMAT(3I4,F15.10)
C
      KWED1=NII
C
C  INITIALIZE AT ZERO
C
      NTRY=2
C
      DO 99 III=1,NTRY
      KTOTAL=0
      KRITE=0
      KWRONG=0
      DO 11 JX=1,NRCALL
      SUM=0.0
      DO 52 K=1,NS
      SUM=SUM+XDAT(III,K)*ZVEC(JX,K)
  52  CONTINUE
      XXY(JX)=SUM
      XSAVE(JX,III)=SUM
      MRITE(JX,III)=0
      DB2B1=WS(JX)-XXY(JX)
      IF(LDATA(ILEG,JX).NE.0)THEN
         KTOTAL=KTOTAL+1
C
C  CALCULATE CLASSIFICATION ERROR
C
         IF(XXY(JX).LT.WS(JX))THEN
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,1))THEN
               KRITE=KRITE+1
               MRITE(JX,III)=1
            ENDIF
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,2))THEN
               KWRONG=KWRONG+1
            ENDIF
         ENDIF
         IF(XXY(JX).GT.WS(JX))THEN
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,1))THEN
               KWRONG=KWRONG+1
            ENDIF
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,2))THEN
               KRITE=KRITE+1
               MRITE(JX,III)=1
            ENDIF
         ENDIF
      ENDIF
  11  CONTINUE
C      WRITE(21,1012)III,KRITE,KWRONG,KTOTAL,(XDAT(III,K),K=1,NS)
  99  CONTINUE
C
C
C  CONSTRUCT PROJECTION VECTOR
C
      JJJ=1
      III=2
      ITOT=0
      KRITE=0
      KWRONG=0
      KTOTAL=0
      XERR=0.0
      XKMAX=+99999.0
      XKMIN=-99999.0
      DO 1 JX=1,NRCALL
C
      DB2B1=WS(JX)-XSAVE(JX,III)
      DENOM=XSAVE(JX,III)-XSAVE(JX,JJJ)
      IF(ABS(DENOM).LE.0.00001)THEN
C         WRITE(23,1023)NII,ILEG,JX,DENOM
         GO TO 1
      ENDIF
      XNUM1=+1.0-XSAVE(JX,JJJ)
      XNUM2=-1.0-XSAVE(JX,JJJ)
      XNUM3=WS(JX)-XSAVE(JX,JJJ)
C
C  CALCULATE CLASSIFICATION ERROR
C
      IF(LDATA(ILEG,JX).NE.0)THEN
         IF(XSAVE(JX,III).LT.WS(JX))THEN
            KTOTAL=KTOTAL+1
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,1))THEN
               KRITE=KRITE+1
C
C  CORRECT TO CORRECT (CASES 3 AND 4)
C
               IF(MRITE(JX,JJJ).EQ.1)THEN
C  CASE 3
                  IF(XSAVE(JX,III).LT.XSAVE(JX,JJJ))THEN
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM2/DENOM
                     KALL(ITOT)=6
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM3/DENOM
                     KALL(ITOT)=1
                  ENDIF
C  CASE 4
                  IF(XSAVE(JX,III).GT.XSAVE(JX,JJJ))THEN
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM3/DENOM
                     KALL(ITOT)=6
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM2/DENOM
                     KALL(ITOT)=1
                  ENDIF
               ENDIF
C
C  INCORRECT TO CORRECT (CASE 11)
C
               IF(MRITE(JX,JJJ).EQ.0)THEN
                  ITOT=ITOT+1
                  XALL(ITOT)=XNUM2/DENOM
                  KALL(ITOT)=6
                  ITOT=ITOT+1
                  XALL(ITOT)=XNUM3/DENOM
                  KALL(ITOT)=1
               ENDIF
            ENDIF
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,2))THEN
               KWRONG=KWRONG+1
C
C  CORRECT TO INCORRECT (CASE 9)
C
               IF(MRITE(JX,JJJ).EQ.1)THEN
                  ITOT=ITOT+1
                  XALL(ITOT)=XNUM3/DENOM
                  KALL(ITOT)=6
                  ITOT=ITOT+1
                  XALL(ITOT)=XNUM1/DENOM
                  KALL(ITOT)=1
               ENDIF
C
C  INCORRECT TO INCORRECT (CASES 7 AND 8)
C
               IF(MRITE(JX,JJJ).EQ.0)THEN
C  CASE 7
                  IF(XSAVE(JX,III).LT.XSAVE(JX,JJJ))THEN
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM3/DENOM
                     KALL(ITOT)=6
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM1/DENOM
                     KALL(ITOT)=1
                  ENDIF
C  CASE 8
                  IF(XSAVE(JX,III).GT.XSAVE(JX,JJJ))THEN
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM1/DENOM
                     KALL(ITOT)=6
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM3/DENOM
                     KALL(ITOT)=1
                  ENDIF
               ENDIF
            ENDIF
         ENDIF
C
C
C
         IF(XSAVE(JX,III).GT.WS(JX))THEN
            KTOTAL=KTOTAL+1
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,2))THEN
               KRITE=KRITE+1
C
C  CORRECT TO CORRECT (CASES 1 AND 2)
C
               IF(MRITE(JX,JJJ).EQ.1)THEN
C  CASE 2
                  IF(XSAVE(JX,III).LT.XSAVE(JX,JJJ))THEN
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM3/DENOM
                     KALL(ITOT)=6
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM1/DENOM
                     KALL(ITOT)=1
                  ENDIF
C  CASE 1
                  IF(XSAVE(JX,III).GT.XSAVE(JX,JJJ))THEN
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM1/DENOM
                     KALL(ITOT)=6
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM3/DENOM
                     KALL(ITOT)=1
                  ENDIF
               ENDIF
C
C  INCORRECT TO CORRECT (CASE 12)
C
               IF(MRITE(JX,JJJ).EQ.0)THEN
                  ITOT=ITOT+1
                  XALL(ITOT)=XNUM1/DENOM
                  KALL(ITOT)=6
                  ITOT=ITOT+1
                  XALL(ITOT)=XNUM3/DENOM
                  KALL(ITOT)=1
               ENDIF
            ENDIF
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,1))THEN
               KWRONG=KWRONG+1
C
C  CORRECT TO INCORRECT (CASE 10)
C
               IF(MRITE(JX,JJJ).EQ.1)THEN
                  ITOT=ITOT+1
                  XALL(ITOT)=XNUM3/DENOM
                  KALL(ITOT)=6
                  ITOT=ITOT+1
                  XALL(ITOT)=XNUM2/DENOM
                  KALL(ITOT)=1
               ENDIF
C
C  INCORRECT TO INCORRECT (CASES 5 AND 6)
C
               IF(MRITE(JX,JJJ).EQ.0)THEN
C  CASE 6
                  IF(XSAVE(JX,III).LT.XSAVE(JX,JJJ))THEN
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM2/DENOM
                     KALL(ITOT)=6
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM3/DENOM
                     KALL(ITOT)=1
                  ENDIF
C  CASE 5
                  IF(XSAVE(JX,III).GT.XSAVE(JX,JJJ))THEN
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM3/DENOM
                     KALL(ITOT)=6
                     ITOT=ITOT+1
                     XALL(ITOT)=XNUM2/DENOM
                     KALL(ITOT)=1
                  ENDIF
               ENDIF
            ENDIF
         ENDIF
      ENDIF
  1   CONTINUE
C
C  IMPOSE RANGE CONSTRAINTS ON ALPHA VECTOR -- ROOT2 IS THE LOWER BOUND
C                                              ROOT1 IS THE UPPER BOUND
C
      KK=0
      DO 363 I=1,ITOT
      IF(XALL(I).GT.ROOT2.AND.XALL(I).LT.ROOT1)THEN
         KK=KK+1
         YALL(KK)=XALL(I)
         LALL(KK)=KALL(I)
      ENDIF
  363 CONTINUE
C
      CALL RSORT(YALL,KK,LALL)
      IROTC=1
      CALL JAN0PT(KK,YALL,LALL,WSSY,JCH,JEH,JCL,JEL,IROTC)
C      WRITE(21,1018)JJJ,JCH,JCL,JEH,JEL,JEH+JEL,WSSY
C
C  (Z'Z)-1*Z'W-HAT
C
C
      DO 3 K=1,NS
      ZWRONG(K)=0.0
      SUMWS=0.0
      DO 4 JJ=1,NRCALL
      SUMWS=SUMWS+BB(K,JJ)*(XSAVE(JJ,JJJ)+
     C                WSSY*(XSAVE(JJ,III)-XSAVE(JJ,JJJ)))
   4  CONTINUE
C
      XMAT2(K)=SUMWS
   3  CONTINUE
C
      KKRITE=0
      KKWRONG=0
      KTOTAL=0
      XERR2=0.0
      DO 31 JX=1,NRCALL
      LERROR(ILEG,JX)=0
      SUM=0.0
      DO 32 K=1,NS
      SUM=SUM+XMAT2(K)*ZVEC(JX,K)
  32  CONTINUE
      XXY(JX)=SUM
      XXZ(JX)=SUM
      DB2B1=WS(JX)-XXY(JX)
C
C  CALCULATE CLASSIFICATION ERROR
C
      IF(LDATA(ILEG,JX).NE.0)THEN
         IF(XXY(JX).LT.WS(JX))THEN
            KTOTAL=KTOTAL+1
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,1))THEN
               KKRITE=KKRITE+1
            ENDIF
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,2))THEN
               LERROR(ILEG,JX)=1
               KKWRONG=KKWRONG+1
               XERR2=XERR2+(XXY(JX)-WS(JX))**2
               XXZ(JX)=+1.0
               DO 62 K=1,NS
               YWRONG(KKWRONG,K)=XMAT2(K)+1.000*DB2B1*ZVEC(JX,K)
               ZWRONG(K)=ZWRONG(K)+XMAT2(K)+
     C                   1.5000*DB2B1*ZVEC(JX,K)
  62           CONTINUE
            ENDIF
         ENDIF
         IF(XXY(JX).GT.WS(JX))THEN
            KTOTAL=KTOTAL+1
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,2))THEN
               KKRITE=KKRITE+1
            ENDIF
            IF(LDATA(ILEG,JX).EQ.MCUTS(JX,1))THEN
               LERROR(ILEG,JX)=1
               KKWRONG=KKWRONG+1
               XERR2=XERR2+(XXY(JX)-WS(JX))**2
               XXZ(JX)=-1.0
               DO 63 K=1,NS
               YWRONG(KKWRONG,K)=XMAT2(K)+1.000*DB2B1*ZVEC(JX,K)
               ZWRONG(K)=ZWRONG(K)+XMAT2(K)+
     C                   1.5000*DB2B1*ZVEC(JX,K)
  63           CONTINUE
            ENDIF
         ENDIF
      ENDIF
  31  CONTINUE
C
      DO 5 K=1,NS
      IF(KKWRONG.GT.0)ZWRONG(K)=ZWRONG(K)/FLOAT(KKWRONG)
  5   CONTINUE
C      IF(ILEG.EQ.5)THEN
C      WRITE(21,1013)NII,ILEG,KKRITE,KKWRONG,JEH+JEL,KTOTAL,
C     C                  (XMAT2(K),K=1,3)
C      ENDIF
C
      RETURN
      END
C
C  **************************************************************************
C    SUBROUTINE JAN0PT -- FINDS OPTIMAL CUTTING POINT FOR ONE DIMENSION
C  **************************************************************************
C
      SUBROUTINE JAN0PT(NP,YSS,KA,WSSY,JCH,JEH,JCL,JEL,IROTC)
     C                   
      DIMENSION YSS(7398),KA(7398),LV(7398),LVB(7398),
     C          LEB(7398),Z(7398),Y(7398),
     C          LE(7398),LJEP(7398),
     C          AAJEP(101),
     C          ABJEP(101),LAJEP(101),LBJEP(101),LCJEP(101),
     C          LDJEP(101),ABABJEP(101),MJEP(101)
C
      NPN=NP+1
      NPP=NP-1
      KCUT=1
      LCUT=6
      NOTE=1
      AA1=0.0
      AB1=0.0
      LA1=0
      LB1=0
      LC1=0
      LD1=0
      AA2=999.0
      AB2=0.0
      LA2=0
      LB2=0
      LC2=0
      LD2=0
      DO 999 III=1,1
      IF(III.EQ.2)THEN
         KCUT=6
         LCUT=1
      ENDIF
C
C  CHECK ALL POSSIBLE INTERIOR CUT POINTS  --  THE NP INPUT POINTS
C      ARE HELD FIXED.  THERE ARE NP POSSIBLE CUT-POINTS BEGINNING
C      WITH CUT-POINT 1 WHICH IS .001 UNITS TO THE LEFT OF POINT 1.
C      CUT-POINT 2 IS BETWEEN POINTS 1 AND 2, ETC.
C
C     1   2   3   4   5   6   7   8   9   10   11 ...... NP-1   NP
C    *  *   *   *   *   *   *   *   *   *    *                *
C    1  2   3   4   5   6   7   8   9  10   11  ...........  NP
C
C  IF KCUT=1 AND LCUT=6, THE FOLLOWING NP PATTERNS ARE TESTED
C
C PATTERN
C   1         6666666666666666666666
C   2         1666666666666666666666
C   3         1166666666666666666666
C   4         1116666666666666666666
C   5         1111666666666666666666
C   6         1111166666666666666666
C   7         1111116666666666666666
C   .           .....
C   .           .....
C   .           .....
C  NP-1       1111111111111111111166
C   NP        1111111111111111111116
C
C  BECAUSE THE PROGRAM TRIES BOTH KCUT=1/LCUT=6 AND KCUT=6/LCUT=1, THIS
C  WILL ALSO TEST THE ONE MISSING PATTERN ABOVE, VIZ., ALL "1"s.
C
C
      KSE=0
      KSV=0
      LSV=0
      LSE=0
      KMARK=1
      I=0
  10  I=I+1
      IF(I-NP-1)61,12,12
  61  Z(I)=999.0
      IF(I.EQ.1)THEN
         Y(I)=YSS(1)-.001
      ENDIF
      IF(I.GT.1)THEN
         Y(I)=(YSS(I)+YSS(I-1))/2.0
      ENDIF
C      IF(KA(I).EQ.9)GO TO 10
      IF(KMARK.EQ.1)THEN
         DO 3 J=I,NP
         IF(KA(J).EQ.9)GO TO 3
         IF(LCUT-KA(J))33,5,33
  33     IF(KCUT-KA(J))3,6,3
  5      LSV=LSV+1
         GO TO 3
  6      LSE=LSE+1
  3      CONTINUE
         KMARK=0
         GO TO 31
      ENDIF
      IF(KA(I-1).EQ.KCUT)THEN
         KSV=KSV+1
         LSE=LSE-1
      ENDIF
      IF(KA(I-1).EQ.LCUT)THEN
         KSE=KSE+1
         LSV=LSV-1
      ENDIF
C
  31  CONTINUE
      LJEP(I)=I
      LV(I)=KSV
      LVB(I)=LSV
      LE(I)=KSE
      LEB(I)=LSE
      KT=LV(I)+LE(I)+LVB(I)+LEB(I)
      Z(I)=FLOAT(LE(I)+LEB(I))/FLOAT(KT)
      GO TO 10
  12  CONTINUE
C
C  FIND BEST CUT POINT
C
      CALL RSORT(Z,NP,LJEP)
      KIN=1
      MJEP(1)=1
      AAJEP(KIN)=Z(1)
      ABJEP(KIN)=Y(LJEP(1))
      ABABJEP(KIN)=ABS(ABJEP(KIN))
      LAJEP(KIN)=LV(LJEP(1))
      LBJEP(KIN)=LE(LJEP(1))
      LCJEP(KIN)=LVB(LJEP(1))
      LDJEP(KIN)=LEB(LJEP(1))
C
C  CHECK IF THERE ARE MULTIPLE CUT-POINTS WITH SAME CLASSIFICATION AND
C    SELECT THAT CUT-POINT CLOSEST TO THE INTERIOR OF THE SPACE
C
      DO 63 I=2,NP
      IF(ABS(Z(1)-Z(I)).LE..000001)THEN
         KIN=KIN+1
         MJEP(KIN)=KIN
         AAJEP(KIN)=Z(I)
         ABJEP(KIN)=Y(LJEP(I))
         ABABJEP(KIN)=ABS(ABJEP(KIN))
         LAJEP(KIN)=LV(LJEP(I))
         LBJEP(KIN)=LE(LJEP(I))
         LCJEP(KIN)=LVB(LJEP(I))
         LDJEP(KIN)=LEB(LJEP(I))
         IF(KIN.GT.100)GO TO 633
         GO TO 63
      ENDIF
      IF(Z(1).LT.Z(I))GO TO 633
  63  CONTINUE
  633 CONTINUE
      IF(KIN.EQ.1)THEN
         AA=AAJEP(1)
         AB=ABJEP(1)
         LA=LAJEP(1)
         LB=LBJEP(1)
         LC=LCJEP(1)
         LD=LDJEP(1)
      ENDIF
      IF(KIN.GT.1)THEN
         CALL RSORT(ABABJEP,KIN,MJEP)
         AA=AAJEP(MJEP(1))
         AB=ABJEP(MJEP(1))
         LA=LAJEP(MJEP(1))
         LB=LBJEP(MJEP(1))
         LC=LCJEP(MJEP(1))
         LD=LDJEP(MJEP(1))
      ENDIF
C
      IF(III.EQ.1)THEN
         AA1=AA
         AB1=AB
         LA1=LA
         LB1=LB
         LC1=LC
         LD1=LD
      ENDIF
      IF(III.EQ.2)THEN
         AA2=AA
         AB2=AB
         LA2=LA
         LB2=LB
         LC2=LC
         LD2=LD
      ENDIF
C
  999 CONTINUE
C
      IF(AA1.LE.AA2)THEN
         KCCUT=1
         LCCUT=6
         AA=AA1
         AB=AB1
         LA=LA1
         LB=LB1
         LC=LC1
         LD=LD1
      ENDIF
      IF(AA1.GT.AA2)THEN
         KCCUT=6
         LCCUT=1
         AA=AA2
         AB=AB2
         LA=LA2
         LB=LB2
         LC=LC2
         LD=LD2
      ENDIF
      IF(IROTC.EQ.1)THEN
         KCCUT=1
         LCCUT=6
         AA=AA1
         AB=AB1
         LA=LA1
         LB=LB1
         LC=LC1
         LD=LD1
      ENDIF
      WSSY=AB
      JCL=LA
      JEL=LB
      JCH=LC
      JEH=LD
C
C
      RETURN
      END
C
C *********************************************************************
C   SUBROUTINE CUTPLANE -- FINDS CUTTING LINE USING THE CUTTING 
C                            PLANE PROCEDURE
C *********************************************************************
C
C
      SUBROUTINE CUTPLANE(JJJ,NP,NRCALL,NS,XMAT,ZVEC,WS,
     C                      MCUTS,LERROR,IFIXX,KTT,KT,LDATA)
      DIMENSION XMAT(1960,25),ZVEC(1701,25),XPROJ(1960,1701),XXY(1701),
     C          LLL(1701),XXX(1960),MM(1701),MVOTE(1701),WS(7398),
     C          LLV(1701),LLVB(1701),LLE(1701),LLEB(1701),
     C          LERROR(1960,1701),ZS(1701),MCUTS(1701,2),
     C          XJCH(25),XJEH(25),XJCL(25),XJEL(25),
     C          LDATA(1960,1701)
  100 FORMAT(5I5)      
 1093 FORMAT(' CLASSIFICATION CHECK  ',I3,I8)
 1094 FORMAT(' RC  CLASSIFICATION ERROR  ',2I3,2I8,2F10.5)
C
C   ESTIMATE PROJECTION VECTORS
C  
      KT=0
      KTT=0
      KTTSAVE=0
      KTSAVE=0
      KCHECK=0
      DO 93 JX=1,NRCALL
C
C  GET YES AND NO COUNTS
C
      KYES=0
      KNO=0
      DO 92 I=1,NP
      IF(LDATA(I,JX).EQ.1)KYES=KYES+1
      IF(LDATA(I,JX).EQ.6)KNO=KNO+1
  92  CONTINUE
C
C
      DO 89 I=1,NP
      SUM=0.0
      DO 90 K=1,NS
      SUM=SUM+XMAT(I,K)*ZVEC(JX,K)
  90  CONTINUE
C
C  SAVE PROJECTION VECTORS -- LEGISLATOR BY ROLL CALL MATRIX
C
      XPROJ(I,JX)=SUM
      XXY(I)=SUM
      LLL(I)=I
      XXX(I)=SUM
      MM(I)=LDATA(I,JX)
      IF(LDATA(I,JX).EQ.0)MM(I)=9
  89  CONTINUE
C
C  SORT PROJECTION VECTOR (Y-HAT)
C
      CALL RSORT(XXX,NP,LLL)
      DO 114 I=1,NP
      MVOTE(I)=MM(LLL(I))
  114 CONTINUE
C
C  
C  CALCULATE CLASSIFICATION ERRORS OF PROJECTION ONTO NORMAL VECTOR
C  
C
      JCH=0
      JEH=0
      JCL=0
      JEL=0
      IROTC=0
      CALL JAN1PT(NP,NRCALL,NS,JX,XMAT,XXX,MVOTE,WS,
     C            LLV,LLVB,LLE,LLEB,LERROR,
     C            ZS,JCH,JEH,JCL,JEL,IROTC,KCUT,LCUT,LLL,
     C            XJCH,XJEH,XJCL,XJEL)
C
C      WRITE(24,3909)JX,KYES,KNO,JCH,JCL,JEH,JEL,
C     C                (ZVEC(1,K),K=1,NS),WS(JX)
C 3909 FORMAT(I3,'***',6I4,10F7.3)
      IF(JEH+JEL.EQ.0)THEN
         KT=KT+JCH+JEH+JCL+JEL
         KTSAVE=KTSAVE+JCH+JEH+JCL+JEL
         IJUST=0
         GO TO 9377
      ENDIF
      IF(IFIXX.EQ.0)THEN
         KT=KT+JCH+JEH+JCL+JEL
         KTSAVE=KTSAVE+JCH+JEH+JCL+JEL
         KTTSAVE=KTTSAVE+JEH+JEL
         GO TO 9377
      ENDIF
C
C  SET-UP FOR GRID SEARCH FOR BEST CUTTING LINE 
C
      NCUT=25
      CALL SEARCH(IIII,JX,NCUT,NS,NP,NRCALL,KCUT,LCUT,KTT,KT,
     C            XMAT,ZVEC,XPROJ,WS,XXY,
     C            KITTY1,KITTY2,KYES,KNO,LDATA)
C
C
      KTTSAVE=KTTSAVE+KITTY1
      KTSAVE=KTSAVE+KITTY2
C
 9377 CONTINUE
C
C  STORE DIRECTIONALITY OF ROLL CALL
C
      MCUTS(JX,1)=KCUT
      MCUTS(JX,2)=LCUT
C
C
C  LOCATE ERRORS -- WS(.) CONTAINS THE OPTIMAL CUTTING POINT ON THE
C                   PROJECTION VECTOR -- IT CAN BE USED TO CALCULATE THE
C                   CLASSIFICATION ERRORS
C
      KSUM=0
      DO 108 I=1,NP
      LERROR(I,JX)=0
      XXX(I)=XXY(I)
      LLL(I)=I
      IF(LDATA(I,JX).EQ.0)GO TO 108
      IF(XXY(I).LT.WS(JX))THEN
         IF(LDATA(I,JX).NE.KCUT)THEN
            LERROR(I,JX)=1
            KCHECK=KCHECK+1
            KSUM=KSUM+1
         ENDIF
      ENDIF
      IF(XXY(I).GT.WS(JX))THEN
         IF(LDATA(I,JX).NE.LCUT)THEN
            LERROR(I,JX)=1
            KCHECK=KCHECK+1
            KSUM=KSUM+1
         ENDIF
      ENDIF
  108 CONTINUE
C
C      WRITE(24,100)JX,KYES,KNO,KITTY1,KITTY2
  93  CONTINUE
C
      KT=KTSAVE
      KTT=KTTSAVE
      KCHECK2=0
      DO 281 JX=1,NRCALL
      DO 282 I=1,NP
      KCHECK2=KCHECK2+LERROR(I,JX)
  282 CONTINUE
  281 CONTINUE
C      WRITE(21,1093)NS,KCHECK
C      WRITE(23,1093)NS,KCHECK
C      WRITE(* ,1093)NS,KCHECK
C      WRITE(21,1093)NS,KCHECK2
C      WRITE(23,1093)NS,KCHECK2
C      WRITE(* ,1093)NS,KCHECK2
      IF(KT.GT.0)THEN
        XERROR=FLOAT(KTT)/FLOAT(KT)
        YERROR=1.0-XERROR
      ENDIF
      WRITE(21,1094)JJJ,NS,KTT,KT,XERROR,YERROR
      WRITE(23,1094)JJJ,NS,KTT,KT,XERROR,YERROR
      WRITE(* ,1094)JJJ,NS,KTT,KT,XERROR,YERROR
      RETURN
      END
C
C  ************************************************************************
C    SUBROUTINE SEARCH
C  ************************************************************************
C
      SUBROUTINE SEARCH(IIII,JX,NCUT,NS,NP,NRCALL,KCUT,LCUT,KTT,KT,
     C                  XMAT,ZVEC,XPROJ,WS,XXY,
     C                  KITTY1,KITTY2,KYES,KNO,LDATA)
      DIMENSION XMAT(1960,25),ZVEC(1701,25),
     C          XPROJ(1960,1701),WS(7398),XXY(1960),XXX(1960),MM(1960),
     C          LLL(1960),MVOTE(1960),LLM(1960),LLN(1960),
     C          KKKCUT(1960),LLLCUT(1960),LLV(1701),
     C          LLVB(1701),LLE(1701),LLEB(1701),LERROR(1960,1701),
     C          XJCH(25),XJEH(25),XJCL(25),XJEL(25),
     C          ZS(1701),UUU(1960,25),Y16MIDP(1960,25),
     C          FV1(1960),FV2(1960),SUMX(1960),X16MIDP(1960,25),
     C          YHAT(61913),LWRONG(1960),
     C          VVV(25,25),LDATA(1960,1701)
  210 FORMAT(I5,10F12.3)
 1091 FORMAT(' INVERSE MATRIX ERROR',I4,I5,I8,2F10.4)
 1099 FORMAT(I3,I5,I3,2I4)
 1103 FORMAT(' MIDPOINT DECOMPOSITION',5I6)
 1212 FORMAT(I3,I5,7I4)
 3909 FORMAT(I5,I3,6I4,2I8,5I5)
C
      DO 1 I=1,50
      SUMX(I)=0.0
  1   CONTINUE
C
C  PHASE 2
C
C      NCUT2=20
C
      DO 999 IJL=1,NCUT
C
C  SET-UP FOR PHASE 2
C
C
      DO 388 K=1,NS
      UUU(IJL,K)=ZVEC(JX,K)
  388 CONTINUE
      DO 389 I=1,NP
      SUM=0.0
      DO 390 K=1,NS
      SUM=SUM+XMAT(I,K)*ZVEC(JX,K)
  390 CONTINUE
C
C  SAVE PROJECTION VECTORS -- LEGISLATOR BY ROLL CALL MATRIX
C
      XPROJ(I,JX)=SUM
      XXY(I)=SUM
      LLL(I)=I
      XXX(I)=SUM
      MM(I)=LDATA(I,JX)
      IF(LDATA(I,JX).EQ.0)MM(I)=9
  389 CONTINUE
C
C  SORT PROJECTION VECTOR (Y-HAT)
C
C
      CALL RSORT(XXX,NP,LLL)
      DO 314 I=1,NP
      MVOTE(I)=MM(LLL(I))
  314 CONTINUE
C
C  
C  CALCULATE CLASSIFICATION ERRORS FOR BEST SOLUTION FROM PHASE 1
C  
C
      JCH=0
      JEH=0
      JCL=0
      JEL=0
      IROTC=0
      CALL JAN1PT(NP,NRCALL,NS,JX,XMAT,XXX,MVOTE,WS,
     C            LLV,LLVB,LLE,LLEB,LERROR,
     C            ZS,JCH,JEH,JCL,JEL,IROTC,KCUT,LCUT,LLL,
     C            XJCH,XJEH,XJCL,XJEL)
C
C      WRITE(21,3909)JX,IJL,KYES,KNO,JCH,JCL,JEH,JEL
C
      LLM(IJL)=IJL
      LLN(IJL)=JEH+JEL
      FV1(IJL)=FLOAT(JEH+JEL)
      FV2(IJL)=WS(JX)
      KKKCUT(IJL)=KCUT
      LLLCUT(IJL)=LCUT
C
      IF(JEH+JEL.EQ.0)THEN
         KT=KT+JCH+JCL+JEH+JEL
         KITTY1=0
         KITTY2=JCH+JCL+JEH+JEL
         IJUST=2
         RETURN
      ENDIF
C
C
      KASTRO=4*(JEH+JEL)
      IF(KASTRO.GT.NP)KASTRO=NP
      IF(KASTRO.LT.4*NS)KASTRO=4*NS
C
      DO 108 I=1,NP
      LWRONG(I)=0
      DB2B1=WS(JX)-XXY(I)
      IF(XXY(I).LT.WS(JX))THEN
C
C  IF CORRECT PLACE LEGISLATOR POINT ON THE CURRENT CUTTING PLANE
C
         IF(LDATA(I,JX).EQ.KCUT)THEN
            DO 109 K=1,NS
            Y16MIDP(I,K)=XMAT(I,K)+DB2B1*ZVEC(JX,K)
  109       CONTINUE
         ENDIF
C
C  IF INCORRECT PUT ACTUAL POINT INTO THE CUTTING CLOUD
C
         IF(LDATA(I,JX).EQ.LCUT)THEN
            LWRONG(I)=1
            DO 110 K=1,NS
            Y16MIDP(I,K)=XMAT(I,K)
  110       CONTINUE
         ENDIF
C
C  IF NOT-VOTING PUT LEGISLATOR POINT ON THE CURRRENT CUTTING PLANE
C
         IF(LDATA(I,JX).EQ.0)THEN
            DO 111 K=1,NS
            Y16MIDP(I,K)=XMAT(I,K)+DB2B1*ZVEC(JX,K)
  111       CONTINUE
         ENDIF
      ENDIF
      IF(XXY(I).GT.WS(JX))THEN
C
C  IF CORRECT PLACE LEGISLATOR POINT ON THE CURRENT CUTTING PLANE
C
         IF(LDATA(I,JX).EQ.LCUT)THEN
            DO 112 K=1,NS
            Y16MIDP(I,K)=XMAT(I,K)+DB2B1*ZVEC(JX,K)
  112       CONTINUE
         ENDIF
C
C  IF INCORRECT PUT ACTUAL POINT INTO THE CUTTING CLOUD
C
         IF(LDATA(I,JX).EQ.KCUT)THEN
            LWRONG(I)=1
            DO 113 K=1,NS
            Y16MIDP(I,K)=XMAT(I,K)
  113       CONTINUE
         ENDIF
C
C  IF NOT-VOTING PUT LEGISLATOR POINT ON THE CURRRENT CUTTING PLANE
C
         IF(LDATA(I,JX).EQ.0)THEN
            DO 214 K=1,NS
            Y16MIDP(I,K)=XMAT(I,K)+DB2B1*ZVEC(JX,K)
  214       CONTINUE
         ENDIF
      ENDIF
C
  108 CONTINUE
C
C  MASS CENTER THE CUTTING PLANE MATRIX (Y16MIDP(,) HAS ALL POINTS)
C
      DO 215 K=1,NS
      SUM=0.0
      DO 216 I=1,NP
      SUM=SUM+Y16MIDP(I,K)
  216 CONTINUE
      DO 217 I=1,NP
      Y16MIDP(I,K)=Y16MIDP(I,K)-SUM/FLOAT(NP)
      SUMX(K)=SUMX(K)+Y16MIDP(I,K)**2
  217 CONTINUE
      SUMX(K)=SUMX(K)/FLOAT(NP)
  215 CONTINUE
C
C  CONSTRUCT PARTIAL CUTTING PLANE MATRIX (X16MIDP(,))
C
      KK=0
      KHIT=0
C
      DO 316 I=1,NP
      IF(LWRONG(I).EQ.1)THEN
         KK=KK+1
         DO 317 K=1,NS
         X16MIDP(KK,K)=Y16MIDP(I,K)
  317    CONTINUE
      ENDIF
  316 CONTINUE
      DO 201 I=1,NP
      IF(LWRONG(I).EQ.0)THEN
         KK=KK+1
         DO 219 K=1,NS
         X16MIDP(KK,K)=Y16MIDP(I,K)
  219    CONTINUE
         IF(KK.EQ.KASTRO)GO TO 203
      ENDIF
  201 CONTINUE
  203 CONTINUE
C
C  MASS CENTER THE PARTIAL CUTTING PLANE MATRIX
C
      DO 815 K=1,NS
      SUM=0.0
      DO 816 I=1,KASTRO
      SUM=SUM+X16MIDP(I,K)
  816 CONTINUE
      DO 817 I=1,KASTRO
      X16MIDP(I,K)=X16MIDP(I,K)-SUM/FLOAT(KASTRO)
      SUMX(K+NS)=SUMX(K+NS)+X16MIDP(I,K)**2
  817 CONTINUE
      SUMX(K+NS)=SUMX(K+NS)/FLOAT(KASTRO)
  815 CONTINUE
C
C  RUN REGRESSION TO ELIMINATE DIMENSION WITH LEAST VARIANCE
C
C
C  CALL SINGULAR VALUE DECOMPOSITION ROUTINE
C
      XTOL=.001
      CALL LSVRR(NP,NS,Y16MIDP,1960,21,XTOL,IRANK,YHAT,Y16MIDP,
     C           1960,VVV,25)
C
      DO 115 K=1,NS
      SUMX(K)=SUMX(K+NS)
      ZVEC(JX,K)=VVV(K,NS)
  115 CONTINUE
C
C      IF(IIII.EQ.1)THEN
C         WRITE(21,3908)JX,IJL,(YHAT(K),K=1,NS),(VVV(K,NS),K=1,NS)
 3908 FORMAT(I5,I3,10F7.3)
C      ENDIF
C
C
C  RUN REGRESSION TO ELIMINATE DIMENSION WITH LEAST VARIANCE
C
      CALL LSVRR(KASTRO,NS,X16MIDP,1960,21,XTOL,IRANK,YHAT,X16MIDP,
     C           1960,VVV,25)
C
      IF(IJL.GT.25)THEN
         DO 114 K=1,NS
         ZVEC(JX,K)=VVV(K,NS)
  114    CONTINUE
      ENDIF
C
C
  999 CONTINUE
C
      CALL RSORT(FV1,NCUT,LLM)
C
      DO 281 JJ=1,NCUT
      IF(FV1(1).LT.FV1(JJ))GO TO 282
  281 CONTINUE
  282 KIN=JJ-1
      LLM(1)=LLM(KIN)
C
      DO 387 K=1,NS
      ZVEC(JX,K)=UUU(LLM(1),K)
  387 CONTINUE
      WS(JX)=FV2(LLM(1))
      KCUT=KKKCUT(LLM(1))
      LCUT=LLLCUT(LLM(1))
      DO 137 I=1,NP
      SUM=0.0
      DO 138 K=1,NS
      SUM=SUM+XMAT(I,K)*ZVEC(JX,K)
  138 CONTINUE
      XPROJ(I,JX)=SUM
      XXY(I)=SUM
  137 CONTINUE      
      KTT=KTT+LLN(LLM(1))
      KITTY1=LLN(LLM(1))
      IJUST=3
      KT=KT+JCH+JCL+JEH+JEL
      KITTY2=JCH+JCL+JEH+JEL
      RETURN
      END
C
C  ************************************************************************
C    EDITH SUBROUTINE--PERFORMS ONE DIMENSION NOMINAL UNFOLDING -- FINDS
C                      OPTIMAL CLASSIFICATIONS FOR MATRIX OF SENATE
C                      PAIRS
C  ************************************************************************
C
      SUBROUTINE EDITH(NP,NRCALL,NS,XMAT,X,XPT,ZPT,AB,KTOTC,
     C                 KCUTTER,LCUTTER,LDATA,LERROR)
      DIMENSION X(1701),XYM(1701),XNM(1701),YSS(1701),XMAT(1960,25),
     C          KA(1701),WS(7398),L(1701),LL(1701),LERROR(1960,1701),
     C          LLV(1701),LLE(1701),LLVB(1701),LLEB(1701),ZS(1701),
     C          KKA(1701),KYES(1701),KNO(1701),XCTL(50),
     C          LV(1701),MM(1701),ZPT(1701),XPT(1701),
     C          YS(1701),KCUTTER(1701),LCUTTER(1701),
     C          XJCH(25),XJEH(25),XJCL(25),XJEL(25),
     C          LDATA(1960,1701)
C
  330 FORMAT(' WARNING--MISMATCH ON NUMBER OF VOTES READ',2I5)
  340 FORMAT(' WARNING--MISMATCH ON ERROR PERCENTAGES',I5,2F7.3)
  825 FORMAT(I4,I5,2I7,6F7.3)
 8250 FORMAT(I3,' ROLL CALLS ',I3,2I8,5F7.3)
 8251 FORMAT(I3,' ROLL CALLS ',I3,2I8,5F9.5)
 8252 FORMAT(I3,' LEGISLATORS',I3,2I8,6F9.5)
 8253 FORMAT(I3,' LEGISLATORS',I3,2I8,6F7.3)
      KSTOPR=1
      KSTOP=50
      DO 1 I=1,NP
      YSS(I)=X(I)
      XPT(I)=X(I)
      L(I)=I
      LL(I)=I
  1   CONTINUE
C
      call rsort(YSS,np,LL)
C
C
      ITR=0
  121 CONTINUE
      ITR=ITR+1
      XLOW=YSS(1)
      XHIGH=YSS(NP)
      KT=0
      KTT=0
      JCH=0
      JEH=0
      JCL=0
      JEL=0
      MSUM=0
      NSUM=0
      IVOT=0
      NUNAM=0
C
C
C  ROLL CALL LOOP -- ESTIMATE BEST CUTTING POINT GIVEN FIXED LEGISLATOR
C                    CONFIGURATION
C
      DO 600 IIII=1,NRCALL
      IVOT=IVOT+1
      ESUM=0.0
      FSUM=0.0
      KSUM=0
      LSUM=0
C
C  RECODE AND COMPUTE YES AND NO MEANS 
C
      DO 16 J=1,NP
      LV(J)=LDATA(J,IVOT)
      IF(LV(J).EQ.1.OR.LV(J).EQ.2.OR.LV(J).EQ.3)KK=1
      IF(LV(J).EQ.4.OR.LV(J).EQ.5.OR.LV(J).EQ.6)KK=6
      IF(LV(J).EQ.0.OR.LV(J).EQ.7.OR.LV(J).EQ.8.OR.LV(J).EQ.9)KK=9
      KKA(J)=KK
      IF(KK.EQ.1)ESUM=ESUM+XPT(J)
      IF(KK.EQ.1)KSUM=KSUM+1
      IF(KK.EQ.6)LSUM=LSUM+1
      IF(KK.EQ.6)FSUM=FSUM+XPT(J)
  16  CONTINUE
      DO 255 J=1,NP
  255 KA(J)=KKA(LL(J))
      KYES(IVOT)=KSUM
      KNO(IVOT)=LSUM
C
C  CHECK FOR UNANIMOUS VOTES AND DISCARD THEM
C
      IF(KSUM.EQ.0.OR.LSUM.EQ.0)XYM(IVOT)=99.0
      IF(KSUM.EQ.0.OR.LSUM.EQ.0)XNM(IVOT)=99.0
      IF(KSUM.EQ.0.OR.LSUM.EQ.0)NUNAM=NUNAM+1
      IF(KSUM.EQ.0.OR.LSUM.EQ.0)GO TO 600
C
C  STORE YES AND NO MEANS
C
      XYM(IVOT)=ESUM/FLOAT(KSUM)
      XNM(IVOT)=FSUM/FLOAT(LSUM)
C
C  CUMULATIVE SUM OF MAJORITY VOTE BY ROLL CALL
C
      IF(KSUM-LSUM)201,202,202
  202 MSUM=MSUM+KSUM
      GO TO 203
  201 MSUM=MSUM+LSUM
  203 CONTINUE
C
C  BEGIN JANICE LOOP FOR ROLL CALLS
C
C  GET ONE POINT RESULTS
C
      JCH=0
      JEH=0
      JCL=0
      JEL=0
      IROTC=0
      CALL JAN1PT(NP,NRCALL,NS,IVOT,XMAT,YSS,KA,WS,LLV,LLVB,LLE,
     C            LLEB,LERROR,
     C            ZS,JCH,JEH,JCL,JEL,IROTC,KCUT,LCUT,LL,XJCH,XJEH,XJCL,
     C            XJEL)
      KT=KT+JCH+JCL+JEH+JEL
      KTT=KTT+JEH+JEL
      KTOTC=KT
      KCUTTER(IVOT)=KCUT
      LCUTTER(IVOT)=LCUT
C
C  END OF ROLL CALL LOOP
C
  600 CONTINUE
C
C
      XT=FLOAT(KT)
      XTT=FLOAT(KTT)
      AB=1.0-(XTT/XT)
      XSUM=float(MSUM)
      XSUM=XSUM/XT
      YSUM=AB-XSUM
      PRE1=YSUM/(1.0-XSUM)
C
C  WRITE OUT: ITERATION #; NUMBER OF VOTES; 
C             TOTAL CHOICES; TOTAL ERROR CHOICES; PERCENT CORRECT; 
C             PERCENT MAJORITY MODEL; PROPORTIONAL REDUCTION IN ERROR
C
      IF(NS.GT.1)THEN
         WRITE(*,825)ITR,IVOT,KT,KTT,AB,XSUM,PRE1,XLOW,XHIGH
         WRITE(23,825)ITR,IVOT,KT,KTT,AB,XSUM,PRE1,XLOW,XHIGH
      ENDIF
      IF(NS.EQ.1)THEN
         WRITE(21,8251)ITR,NS,KTT,KT,1.0-AB,AB,PRE1
         WRITE(*,8250)ITR,NS,KTT,KT,1.0-AB,AB,PRE1
      ENDIF
      IF(IVOT.NE.NRCALL)THEN
         WRITE(*,330)IVOT,NRCALL
         STOP
      ENDIF
      XCTL(ITR)=AB
C
C
C
C  WRITE ROLL CALL MARGINS AND ERRORS TO DISK
C
      DO 130 I=1,NRCALL
      IF(KYES(I).LE.KNO(I))KMIN=KYES(I)
      IF(KYES(I).GT.KNO(I))KMIN=KNO(I)
      KRITE=LLV(I)+LLVB(I)
      KWRONG=LLE(I)+LLEB(I)
      IF((KRITE+KWRONG).GT.0.0)XBAD=FLOAT(KWRONG)/FLOAT(KRITE+KWRONG)
      IF(KYES(I).EQ.0.OR.KNO(I).EQ.0)XBAD=0.0
      IF(KYES(I).EQ.0.OR.KNO(I).EQ.0)ZS(I)=0.0
      XMIN=0.0
      IF((KYES(I)+KNO(I)).GT.0)XMIN=FLOAT(KMIN)/FLOAT(KYES(I)+KNO(I))
      IF(ABS(XBAD-ZS(I)).GT..001)THEN
         WRITE(*,340)I,XBAD,ZS(I)
         STOP
      ENDIF
      AAA=ABS(WS(I)-XLOW)
      BBB=ABS(WS(I)-XHIGH)
      IF(XBAD.GT.XMIN.AND.AAA.LT.BBB)WS(I)=XLOW
      IF(XBAD.GT.XMIN.AND.AAA.GE.BBB)WS(I)=XHIGH
      IF(XBAD.GT.XMIN)XBAD=XMIN
      IF(KYES(I).EQ.0.OR.KNO(I).EQ.0)WS(I)=0.0
      IF(KSTOPR.EQ.1)GO TO 130
C
C  WRITE OUT CONGRESS #, VOTE #, YES #, NO #, PROPORTION IN MINORITY,
C            PROPORTION ERROR, CUT POINT
C
C      WRITE(24,800)I,KYES(I),KNO(I),XMIN,XBAD,WS(I),XYM(I),XNM(I)
  800 FORMAT(I5,2I4,5F7.3)
  130 CONTINUE
C
C
C
C  BEGIN JANICE LOOP FOR LEGISLATORS
C
C
C
      ITR=ITR+1
      DO 124 I=1,NRCALL
      YS(I)=WS(I)
      ZPT(I)=WS(I)
  124 L(I)=I
C
C  SORT ROLL CALL MIDPOINTS
C
      CALL RSORT(YS,NRCALL,L)
C
      KT=0
      KTT=0
      JCH=0
      JCL=0
      JEH=0
      JEL=0
      DO 9999 I=1,NP
      IVOT=I
C
C
      DO 166 J=1,NRCALL
      LV(J)=LDATA(IVOT,J)
      IF(LV(J).EQ.1.OR.LV(J).EQ.2.OR.LV(J).EQ.3)KK=1
      IF(LV(J).EQ.4.OR.LV(J).EQ.5.OR.LV(J).EQ.6)KK=6
      IF(LV(J).EQ.0.OR.LV(J).EQ.7.OR.LV(J).EQ.8.OR.LV(J).EQ.9)KK=9
      IF(XYM(J).EQ.99.0.OR.XNM(J).EQ.99.0)KK=9
      KA(J)=KK
  166 CONTINUE
C
C  DETERMINE DIRECTIONALITY FOR EACH MIDPOINT -- STORE IN MM VECTOR
C
C
C  CUMULATIVE SUM OF MAJORITY VOTE BY INDIVIDUALS
C
      DO 161 J=1,NRCALL
C      IF(XYM(L(J))-XNM(L(J)))163,162,162
C  163 KCUT=1
C      LCUT=6
C      GO TO 164
C  162 KCUT=6
C      LCUT=1
       KCUT=KCUTTER(L(J))
       LCUT=LCUTTER(L(J))
C
C  NOTE THAT THIS CODING OF MM(.) PRODUCES THE PATTERNS
C
C          6666666666...
C          1666666666...
C          1166666666...
C          1116666666...
C          1111666666...
C          1111166666...
C
C  ETC., IF THE LEGISLATOR IS VOTING PERFECTLY
C
  164 IF(KA(L(J)).EQ.KCUT)MM(J)=6
      IF(KA(L(J)).EQ.LCUT)MM(J)=1
      IF(KA(L(J)).EQ.9)MM(J)=9
      IF(KYES(L(J)).LT.KNO(L(J)).AND.KA(L(J)).EQ.6)NSUM=NSUM+1
      IF(KYES(L(J)).GE.KNO(L(J)).AND.KA(L(J)).EQ.1)NSUM=NSUM+1
  161 CONTINUE
C
C  GET ONE POINT RESULTS
C
      JCH=0
      JEH=0
      JCL=0
      JEL=0
      IROTC=1
      CALL JAN1PT(NRCALL,NP,NS,IVOT,XMAT,YS,MM,WS,LLV,LLVB,LLE,
     C            LLEB,LERROR,
     C            ZS,JCH,JEH,JCL,JEL,IROTC,KCUT,LCUT,L,XJCH,XJEH,XJCL,
     C            XJEL)
      KT=KT+JCH+JCL+JEH+JEL
      KTT=KTT+JEH+JEL
C
C  END OF LEGISLATOR LOOP
C
 9999 CONTINUE
C
C  CALCULATE REGRESSION OF PREVIOUS LEGISLATOR CONFIGURATION ON 
C        CURRENT LEGISLATOR CONFIGURATION
C
      ASUM=0.0
      BSUM=0.0
      CSUM=0.0
      DSUM=0.0
      ESUM=0.0
      KKNP=0
      DO 125 I=1,NP
      LL(I)=I
C
      YSS(I)=WS(I)
      KKNP=KKNP+1
      ASUM=ASUM+XPT(I)*WS(I+NP)
      BSUM=BSUM+XPT(I)
      CSUM=CSUM+WS(I+NP)
      DSUM=DSUM+XPT(I)*XPT(I)
      ESUM=ESUM+WS(I+NP)*WS(I+NP)
      XPT(I)=WS(I)
  125 CONTINUE
      AA=FLOAT(KKNP)*ASUM-BSUM*CSUM
      BB=FLOAT(KKNP)*DSUM-BSUM*BSUM
      CC=FLOAT(KKNP)*ESUM-CSUM*CSUM
      IF(BB*CC.GT.0.0)RR=(AA*AA)/(BB*CC)
      BETA=AA/CC
      ALFA=(BSUM-BETA*CSUM)/FLOAT(KKNP)
      XT=FLOAT(KT)
      XTT=FLOAT(KTT)
      AB=1.0-(XTT/XT)
      XSUM=FLOAT(NSUM)/FLOAT(KT)
      YSUM=AB-XSUM
      PRE=YSUM/(1.0-XSUM)
      NUNP=NP-KKNP
C
C  WRITE OUT: ITERATION #; NUMBER OF LEGISLATORS; 
C             TOTAL CHOICES; TOTAL ERROR CHOICES; PERCENT CORRECT; 
C             PERCENT MAJORITY MODEL; PROPORTIONAL REDUCTION IN ERROR
C
      IF(NS.GT.1)THEN
         WRITE(* ,825)ITR,NP,KT,KTT,AB,XSUM,PRE,ALFA,BETA,RR
         WRITE(23,825)ITR,NP,KT,KTT,AB,XSUM,PRE,ALFA,BETA,RR
      ENDIF
      IF(NS.EQ.1)THEN
         WRITE(21,8252)ITR,NS,KTT,KT,1.0-AB,AB,PRE,SQRT(RR)
         WRITE(23,8252)ITR,NS,KTT,KT,1.0-AB,AB,PRE,ALFA,BETA,RR
         WRITE(*,8253)ITR,NS,KTT,KT,1.0-AB,AB,PRE,SQRT(RR)
      ENDIF
      XCTL(ITR)=AB
C      NOISY=69
C      IF(NOISY.EQ.69)STOP
C
C  WRITE LEGISLATOR MARGINS TO DISK
C
      DO 128 I=1,NP
C      WS(I+NP)=WS(I+NP)*BETA+ALFA
C      YSS(I)=YSS(I)*BETA+ALFA
      KHIGH=LLV(I)+LLE(I)
      KLOW=LLVB(I)+LLEB(I)
      IF(KHIGH.LE.KLOW)XMIN=FLOAT(KHIGH)/FLOAT(KHIGH+KLOW)
      IF(KHIGH.GT.KLOW)XMIN=FLOAT(KLOW)/FLOAT(KHIGH+KLOW)
      XBAD=FLOAT(LLE(I)+LLEB(I))/FLOAT(KHIGH+KLOW)
      AAA=ABS(WS(I)-XLOW)
      BBB=ABS(WS(I)-XHIGH)
      IF(XBAD.GT.XMIN.AND.AAA.LT.BBB)WS(I)=XLOW
      IF(XBAD.GT.XMIN.AND.AAA.GE.BBB)WS(I)=XHIGH
      IF(XBAD.GT.XMIN)XBAD=XMIN
  729 CONTINUE
      IF(KSTOPR.EQ.1)GO TO 128
C      WRITE(23,800)I,KHIGH,KLOW,XMIN,XBAD,WS(I)
  128 CONTINUE
      CALL RSORT(YSS,NP,LL)
      AA=(YSS(1)+YSS(NP))/2.0
      BB=YSS(NP)-AA
      DO 730 I=1,NP
      YSS(I)=(YSS(I)-AA)/BB
      XPT(I)=(XPT(I)-AA)/BB
      WS(I)=(WS(I)-AA)/BB
      WS(I+NP)=WS(I)
  730 CONTINUE
      IF(ITR.LE.4)GO TO 121
      IF(KSTOPR.EQ.0)RETURN
      IF((XCTL(ITR)-XCTL(ITR-2)).LE..0005)KSTOPR=0
      IF(ITR.LE.KSTOP)GO TO 121

      RETURN
      END
C
C  **************************************************************************
C    SUBROUTINE JAN1PT -- FINDS OPTIMAL CUTTING POINT FOR ONE DIMENSION
C  **************************************************************************
C
      SUBROUTINE JAN1PT(NP,NRCALL,NS,IVOT,XMAT,YSS,KA,WS,LLV,LLVB,
     C                  LLE,LLEB,
     C                  LERROR,ZS,JCH,JEH,JCL,JEL,IROTC,KCCUT,LCCUT,
     C                  LLL,XJCH,XJEH,XJCL,XJEL)
      DIMENSION YSS(1701),KA(1701),WS(7398),LV(1701),LVB(1701),
     C          LEB(1701),Z(1701),Y(1701),LLV(1701),LLE(1701),
     C          LLVB(1701),LE(1701),LERROR(1960,1701),LJEP(1701),
     C          LLEB(1701),ZS(1701),LLL(1701),XMAT(1960,25),
     C          XJCH(25),XJEH(25),XJCL(25),XJEL(25),AAJEP(101),
     C          ABJEP(101),LAJEP(101),LBJEP(101),LCJEP(101),
     C          LDJEP(101),ABABJEP(101),MJEP(101)
C
      JROTC=1
      IF(IROTC.EQ.2)THEN
         JROTC=0
         IROTC=1
      ENDIF
      NPN=NP+1
      NPP=NP-1
      KCUT=1
      LCUT=6
      NOTE=2
      IF(IROTC.EQ.1)THEN
         NOTE=1
      ENDIF
      AA1=0.0
      AB1=0.0
      LA1=0
      LB1=0
      LC1=0
      LD1=0
      AA2=999.0
      AB2=0.0
      LA2=0
      LB2=0
      LC2=0
      LD2=0
      DO 999 III=1,NOTE
      IF(III.EQ.2)THEN
         KCUT=6
         LCUT=1
      ENDIF
C
C  CHECK ALL POSSIBLE INTERIOR CUT POINTS  --  THE NP INPUT POINTS
C      ARE HELD FIXED.  THERE ARE NP POSSIBLE CUT-POINTS BEGINNING
C      WITH CUT-POINT 1 WHICH IS .001 UNITS TO THE LEFT OF POINT 1.
C      CUT-POINT 2 IS BETWEEN POINTS 1 AND 2, ETC.
C
C     1   2   3   4   5   6   7   8   9   10   11 ...... NP-1   NP
C    *  *   *   *   *   *   *   *   *   *    *                *
C    1  2   3   4   5   6   7   8   9  10   11  ...........  NP
C
C  IF KCUT=1 AND LCUT=6, THE FOLLOWING NP PATTERNS ARE TESTED
C
C PATTERN
C   1         6666666666666666666666
C   2         1666666666666666666666
C   3         1166666666666666666666
C   4         1116666666666666666666
C   5         1111666666666666666666
C   6         1111166666666666666666
C   7         1111116666666666666666
C   .           .....
C   .           .....
C   .           .....
C  NP-1       1111111111111111111166
C   NP        1111111111111111111116
C
C  BECAUSE THE PROGRAM TRIES BOTH KCUT=1/LCUT=6 AND KCUT=6/LCUT=1, THIS
C  WILL ALSO TEST THE ONE MISSING PATTERN ABOVE, VIZ., ALL "1"s.
C
C
      KSE=0
      KSV=0
      LSV=0
      LSE=0
      KMARK=1
      I=0
  10  I=I+1
      IF(I-NP-1)61,12,12
  61  Z(I)=999.0
      IF(I.EQ.1)THEN
         Y(I)=YSS(1)-.001
      ENDIF
      IF(I.GT.1)THEN
         Y(I)=(YSS(I)+YSS(I-1))/2.0
      ENDIF
C      IF(KA(I).EQ.9)GO TO 10
      IF(KMARK.EQ.1)THEN
         DO 3 J=I,NP
         IF(KA(J).EQ.9)GO TO 3
         IF(LCUT-KA(J))33,5,33
  33     IF(KCUT-KA(J))3,6,3
  5      LSV=LSV+1
         GO TO 3
  6      LSE=LSE+1
  3      CONTINUE
         KMARK=0
         GO TO 31
      ENDIF
      IF(KA(I-1).EQ.KCUT)THEN
         KSV=KSV+1
         LSE=LSE-1
      ENDIF
      IF(KA(I-1).EQ.LCUT)THEN
         KSE=KSE+1
         LSV=LSV-1
      ENDIF
C
  31  CONTINUE
      LJEP(I)=I
      LV(I)=KSV
      LVB(I)=LSV
      LE(I)=KSE
      LEB(I)=LSE
      KT=LV(I)+LE(I)+LVB(I)+LEB(I)
      Z(I)=FLOAT(LE(I)+LEB(I))/FLOAT(KT)
C
      IF(JROTC.EQ.0)THEN
         ZS(I)=Y(I)
         LLV(I)=LV(I)
         LLE(I)=LE(I)
         LLVB(I)=LVB(I)
         LLEB(I)=LEB(I)
      ENDIF
      GO TO 10
  12  CONTINUE
C
C  FIND BEST CUT POINT
C
      CALL RSORT(Z,NP,LJEP)
      KIN=1
      MJEP(1)=1
      AAJEP(KIN)=Z(1)
      ABJEP(KIN)=Y(LJEP(1))
      ABABJEP(KIN)=ABS(ABJEP(KIN))
      LAJEP(KIN)=LV(LJEP(1))
      LBJEP(KIN)=LE(LJEP(1))
      LCJEP(KIN)=LVB(LJEP(1))
      LDJEP(KIN)=LEB(LJEP(1))
C
C  CHECK IF THERE ARE MULTIPLE CUT-POINTS WITH SAME CLASSIFICATION AND
C    SELECT THAT CUT-POINT CLOSEST TO THE INTERIOR OF THE SPACE
C
      DO 63 I=2,NP
      IF(ABS(Z(1)-Z(I)).LE..00001)THEN
         KIN=KIN+1
         MJEP(KIN)=KIN
         AAJEP(KIN)=Z(I)
         ABJEP(KIN)=Y(LJEP(I))
         ABABJEP(KIN)=ABS(ABJEP(KIN))
         LAJEP(KIN)=LV(LJEP(I))
         LBJEP(KIN)=LE(LJEP(I))
         LCJEP(KIN)=LVB(LJEP(I))
         LDJEP(KIN)=LEB(LJEP(I))
         IF(KIN.GT.100)GO TO 633
         GO TO 63
      ENDIF
      IF(Z(1).LT.Z(I))GO TO 633
  63  CONTINUE
  633 CONTINUE
      IF(KIN.EQ.1)THEN
         AA=AAJEP(1)
         AB=ABJEP(1)
         LA=LAJEP(1)
         LB=LBJEP(1)
         LC=LCJEP(1)
         LD=LDJEP(1)
      ENDIF
      IF(KIN.GT.1)THEN
         CALL RSORT(ABABJEP,KIN,MJEP)
         AA=AAJEP(MJEP(1))
         AB=ABJEP(MJEP(1))
         LA=LAJEP(MJEP(1))
         LB=LBJEP(MJEP(1))
         LC=LCJEP(MJEP(1))
         LD=LDJEP(MJEP(1))
      ENDIF
C
      IF(III.EQ.1)THEN
         AA1=AA
         AB1=AB
         LA1=LA
         LB1=LB
         LC1=LC
         LD1=LD
      ENDIF
      IF(III.EQ.2)THEN
         AA2=AA
         AB2=AB
         LA2=LA
         LB2=LB
         LC2=LC
         LD2=LD
      ENDIF
C
  999 CONTINUE
C
      IF(AA1.LE.AA2)THEN
         KCCUT=1
         LCCUT=6
         AA=AA1
         AB=AB1
         LA=LA1
         LB=LB1
         LC=LC1
         LD=LD1
      ENDIF
      IF(AA1.GT.AA2)THEN
         KCCUT=6
         LCCUT=1
         AA=AA2
         AB=AB2
         LA=LA2
         LB=LB2
         LC=LC2
         LD=LD2
      ENDIF
      IF(IROTC.EQ.1)THEN
         KCCUT=1
         LCCUT=6
         AA=AA1
         AB=AB1
         LA=LA1
         LB=LB1
         LC=LC1
         LD=LD1
      ENDIF
      WS(IVOT)=AB
      IF(IROTC.EQ.1)WS(IVOT+NRCALL)=AB
      IF(JROTC.EQ.1)THEN
         ZS(IVOT)=AA
         LLV(IVOT)=LA
         LLE(IVOT)=LB
         LLVB(IVOT)=LC
         LLEB(IVOT)=LD
      ENDIF
      JCL=LA
      JEL=LB
      JCH=LC
      JEH=LD
C
      IF(IROTC.EQ.0)THEN
         DO 71 K=1,NS
         XJCH(K)=0.0
         XJEH(K)=0.0
         XJCL(K)=0.0
         XJEL(K)=0.0
  71     CONTINUE
         DO 64 I=1,NP
         IF(KA(I).EQ.9)GO TO 64
         IF(YSS(I).LT.AB)THEN
            IF(KA(I).EQ.KCCUT)THEN
               LERROR(LLL(I),IVOT)=0
               DO 70 K=1,NS
               XJCL(K)=XJCL(K)+XMAT(LLL(I),K)
   70          CONTINUE
            ENDIF
            IF(KA(I).EQ.LCCUT)THEN
               LERROR(LLL(I),IVOT)=1
               DO 72 K=1,NS
               XJEL(K)=XJEL(K)+XMAT(LLL(I),K)
   72          CONTINUE
            ENDIF
         ENDIF
         IF(YSS(I).GT.AB)THEN
            IF(KA(I).EQ.LCCUT)THEN
               LERROR(LLL(I),IVOT)=0
               DO 73 K=1,NS
               XJCH(K)=XJCH(K)+XMAT(LLL(I),K)
   73          CONTINUE
            ENDIF
            IF(KA(I).EQ.KCCUT)THEN
               LERROR(LLL(I),IVOT)=1
               DO 74 K=1,NS
               XJEH(K)=XJEH(K)+XMAT(LLL(I),K)
   74          CONTINUE
            ENDIF
         ENDIF
  64     CONTINUE
         DO 75 K=1,NS
         IF(JCL.GT.0)XJCL(K)=XJCL(K)/FLOAT(JCL)
         IF(JEL.GT.0)XJEL(K)=XJEL(K)/FLOAT(JEL)
         IF(JCH.GT.0)XJCH(K)=XJCH(K)/FLOAT(JCH)
         IF(JEH.GT.0)XJEH(K)=XJEH(K)/FLOAT(JEH)
  75     CONTINUE
      ENDIF
      IF(IROTC.EQ.1)THEN
         DO 65 I=1,NP
         IF(KA(I).EQ.9)GO TO 65
         IF(YSS(I).LT.AB)THEN
            IF(KA(I).EQ.KCCUT)LERROR(IVOT,LLL(I))=0
            IF(KA(I).EQ.LCCUT)LERROR(IVOT,LLL(I))=1
         ENDIF
         IF(YSS(I).GT.AB)THEN
            IF(KA(I).EQ.LCCUT)LERROR(IVOT,LLL(I))=0
            IF(KA(I).EQ.KCCUT)LERROR(IVOT,LLL(I))=1
         ENDIF
  65     CONTINUE
      ENDIF
      RETURN
      END
C
C **************************************************************************
C  SUBROUTINE DOUBLEC -- COMPUTES AGREEMENT SCORES AND DOUBLE CENTERS
C                        THE SQUARED DISTANCE MATRIX TO GET STARTS FOR
C                        THE LEGISLATORS
C **************************************************************************
C
      SUBROUTINE DOUBLEC(NP,NRCALL,NS,ZMAT,WVEC,LDATA)
      DIMENSION XCOL(5402),XROW(5402),KROW(5402),XCENTER(1960,1701),
     C          XCOV(1960,1960),ZMAT(1960,1960),FV1(1960),FV2(1960),
     C          WVEC(1960),XAGREE(1960,1960),ROWMEAN(1960),
     C          YCENTER(1960,1960),WVEC2(1960),ZMAT2(1960,1960),
     C          LDATA(1960,1701)
C
  101 FORMAT(' PERFORMANCE INDEX EIGENVALUE/VECTOR ROUTINE='
     C       ,3I5,I6)
  102 FORMAT(I4,6F10.4)
  103 FORMAT(I4,F10.4)
 1000 FORMAT(3F10.4)
 1001 FORMAT(' HELLO FARTNOCKER!',3I5)
 1011 FORMAT(' BIG ERROR',3I5)
C
C      WRITE(*,1001)NP,NRCALL,NS
      DO 3 I=1,5402
      XCOL(I)=0.0
      XROW(I)=0.0
      KROW(I)=0
  3   CONTINUE
      DO 30 I=1,1960
      WVEC(I)=0.0
      ROWMEAN(I)=0.0
      DO 31 J=1,1960
      ZMAT(I,J)=0.0
  31  CONTINUE
  30  CONTINUE
C
C  PERFORM THE PSEUDO-DOUBLE CENTER
C
C  CALCULATE THE ROLL CALL MEANS (#YEAS/#VOTING)
C
      XMAT=0.0
      KMAT=0
      XCHK1=0.0
      DO 1 J=1,NRCALL
      SUM=0.0
      KK=0
      DO 2 I=1,NP
      IF(LDATA(I,J).NE.0)THEN
         KK=KK+1
         KROW(I)=KROW(I)+1
      ENDIF
      IF(LDATA(I,J).EQ.1)THEN
         SUM=SUM+1.0
         XROW(I)=XROW(I)+1.0
      ENDIF
  2   CONTINUE
      XMAT=XMAT+SUM
      KMAT=KMAT+KK
      XCOL(J)=SUM/FLOAT(KK)
      XCHK1=XCHK1+XCOL(J)
  1   CONTINUE
      XCHK2=0.0
      DO 4 I=1,NP
      XROW(I)=XROW(I)/FLOAT(KROW(I))
      XCHK2=XCHK2+XROW(I)
  4   CONTINUE
C
C  MATRIX MEAN
C
      XCHK1=XCHK1/FLOAT(NRCALL)
      XCHK2=XCHK2/FLOAT(NP)
      XMAT=XMAT/FLOAT(KMAT)
      WRITE(* ,1000)XCHK1,XCHK2,XMAT
      WRITE(23,1000)XCHK1,XCHK2,XMAT
C
C  COMPUTE HECKMAN-SNYDER PSEUDO DOUBLE-CENTER
C
      DO 5 I=1,NP
      DO 6 J=1,NRCALL
      XCENTER(I,J)=0.0
      IF(LDATA(I,J).EQ.0)THEN
         XCENTER(I,J)=XMAT-XCOL(J)
         GO TO 6
      ENDIF
      IF(LDATA(I,J).EQ.1)THEN
         XCENTER(I,J)=1.0-XCOL(J)
      ENDIF
      IF(LDATA(I,J).EQ.6)THEN
         XCENTER(I,J)=0.0-XCOL(J)
      ENDIF
  6   CONTINUE
  5   CONTINUE
C
C
C  COMPUTE HECKMAN-SNYDER COVARIANCE MATRIX
C
      ALLMEAN=0.0
      KZERO=0
      DO 7 I=1,NP
      RSUM=0.0
      DO 8 J=1,NP
      SUM=0.0
      KK=0
      KKK=0
      DO 9 K=1,NRCALL
      IF(LDATA(I,K).EQ.0)GO TO 9
      IF(LDATA(J,K).EQ.0)GO TO 9
      KK=KK+1
C
C  SET UP SYMMETRIC MATRIX OF AGREEMENT SCORES
C
      IF(LDATA(I,K).EQ.LDATA(J,K))THEN
         KKK=KKK+1
      ENDIF
      SUM=SUM+XCENTER(I,K)*XCENTER(J,K)
  9   CONTINUE
      IF(KK.EQ.0)THEN
         ASUM=0.0
         DO 32 KP=1,NRCALL
         ASUM=ASUM+XCENTER(I,KP)*XCENTER(J,KP)
  32     CONTINUE
         XCOV(I,J)=ASUM/FLOAT(NRCALL)
         XAGREE(I,J)=0.25
         GO TO 88
      ENDIF
      XCOV(I,J)=SUM/FLOAT(KK)
      XAGREE(I,J)=(1.0 - (FLOAT(KKK)/FLOAT(KK)))**2
  88  CONTINUE
      RSUM=RSUM+XAGREE(I,J)
  8   CONTINUE
      ROWMEAN(I)=RSUM/FLOAT(NP)
      ALLMEAN=ALLMEAN+ROWMEAN(I)
  7   CONTINUE
      ALLMEAN=ALLMEAN/FLOAT(NP)
C
C  SETUP DOUBLE-CENTERED AGREEMENT SCORE MATRIX
C
      DO 33 I=1,NP
      DO 34 J=1,NP
      YCENTER(I,J)=(XAGREE(I,J)-ROWMEAN(I)-ROWMEAN(J)+ALLMEAN)/(-2.0)
  34  CONTINUE
  33  CONTINUE
C
C  EIGENVECTOR-EIGENVALUE DECOMPOSITION HECKMAN-SNYDER
C
      call rs(1960,NP,XCOV,WVEC2,1,ZMAT2,FV1,FV2,IER)
      WRITE(23,101)NS,NP,IER,KZERO
      WRITE(*,101)NS,NP,IER,KZERO
C
C
C  EIGENVECTOR-EIGENVALUE DECOMPOSITION DOUBLE-CENTERED AGREEMENT
C     SCORE MATRIX
C
      call rs(1960,NP,YCENTER,WVEC,1,ZMAT,FV1,FV2,IER)
      WRITE(23,101)NS,NP,IER,KZERO
      WRITE(*,101)NS,NP,IER,KZERO
      SUM=0.0
      SUM2=0.0
      DO 20 I=1,NP
      SUM=SUM+ABS(WVEC(I))
      SUM2=SUM2+ABS(WVEC2(I))
  20  CONTINUE
      YPER=0.0
      YPER2=0.0
      DO 10 I=1,10
      XPER=(WVEC(NP+1-I)/SUM)*100.0
      YPER=YPER+XPER
      XPER2=(WVEC2(NP+1-I)/SUM2)*100.0
      YPER2=YPER2+XPER2
      WRITE(23,102)I,WVEC(NP+1-I),XPER,YPER,
     C                WVEC2(NP+1-I),XPER2,YPER2
      WRITE(* ,102)I,WVEC(NP+1-I),XPER,YPER,
     C                WVEC2(NP+1-I),XPER2,YPER2
  10  CONTINUE
      RETURN
      END
C
C ****************************************************************************
C  SUBROUTINE CLEAN----CALLED BY MAIN.  THROWS OUT ALL ROLLCALLS BELOW A
C     CUTOFF POINT (XVMIN)--USUALLY .05 OR .025.  THROWS OUT ALL LEGISLATORS
C     WHO HAVE VOTED KVMIN TIMES OR LESS (KVMIN=10 USUALLY).  KNAME(,)--
C     CHARACTER ARRAY HOLDING INFORMATION ON LEGISLATORS IS REARRANGED TO
C     HOLD ONLY INCLUDED LEGISLATORS.  LDATA( , ) IS THEN FILLED WITH THE
C     INCLUDED ROLL CALL VOTES.
C ****************************************************************************
C
      SUBROUTINE CLEAN(NP,NRCALL,JNE,XVMIN,KVMIN,LDATA,KNAME,
     C                 KAV,KYES,KNO)
      DIMENSION KKSUM(1701),LLSUM(1701),MMSUM(1960),NNSUM(1960),
     C          KD(1701),KMARG(1960),LDATA(1960,1701),
     C          KAV(1701),KYES(1701),KNO(1701)
      character*1 KNAME(1960,99)
      CHARACTER*10 LMARG(10)
C
      LMARG(1)= '50 - 55   '
      LMARG(2)= '56 - 60   '
      LMARG(3)= '61 - 65   '
      LMARG(4)= '66 - 70   '
      LMARG(5)= '71 - 75   '
      LMARG(6)= '76 - 80   '
      LMARG(7)= '81 - 85   '
      LMARG(8)= '86 - 90   '
      LMARG(9)= '91 - 95   '
      LMARG(10)='96 - 97.5 '
      DO 34 I=1,1701
      KKSUM(I)=0
      LLSUM(I)=0
  34  CONTINUE
      NAS=0
      NRS=0
      NOB=0
      NMOB=0
      DO 1 I=1,NP
      KMARG(I)=0
      ISUM=0
      JSUM=0
      DO 2 J=1,NRCALL
      KD(J)=LDATA(I,J)
      IF(KD(J).EQ.1.OR.KD(J).EQ.2.OR.KD(J).EQ.3)KKSUM(J)=KKSUM(J)+1
      IF(KD(J).EQ.1.OR.KD(J).EQ.2.OR.KD(J).EQ.3)ISUM=ISUM+1
      IF(KD(J).EQ.4.OR.KD(J).EQ.5.OR.KD(J).EQ.6)LLSUM(J)=LLSUM(J)+1
  2   IF(KD(J).EQ.4.OR.KD(J).EQ.5.OR.KD(J).EQ.6)JSUM=JSUM+1
      MMSUM(I)=ISUM
  1   NNSUM(I)=JSUM
      DO 3 I=1,NP
      LL=MMSUM(I)+NNSUM(I)
      IF(LL.GT.KVMIN)NOB=NOB+1
      IF(LL.LE.KVMIN)NMOB=NMOB+1
      IF(LL.LE.KVMIN)GO TO 3
      do 333 ij=1,jne
  333 kname(nob,ij)=kname(i,ij)
      NAS=0
      NRS=0
      DO 33 J=1,NRCALL
      KD(J)=LDATA(I,J)
      KK=KKSUM(J)+LLSUM(J)
      LL=MIN0(KKSUM(J),LLSUM(J))
      AA=0.0
      IF(KK.GT.0)AA=FLOAT(LL)/FLOAT(KK)
      IF(AA.GT.XVMIN)NAS=NAS+1
      IF(AA.LE.XVMIN)NRS=NRS+1
      IF(AA.GT.XVMIN)KAV(NAS)=J
      IF(AA.GT.XVMIN)KYES(NAS)=KKSUM(J)
      IF(AA.GT.XVMIN)KNO(NAS)=LLSUM(J)
      IF(AA.LE.XVMIN)GO TO 33
      IF(KD(J).EQ.2.OR.KD(J).EQ.3)KD(J)=1
      IF(KD(J).EQ.4.OR.KD(J).EQ.5)KD(J)=6
      IF(KD(J).EQ.7.OR.KD(J).EQ.8.OR.KD(J).EQ.9)KD(J)=0
      LDATA(NOB,NAS)=KD(J)
 33   CONTINUE
  3   CONTINUE
      WRITE(23,1000)NRCALL,NRS,NAS,XVMIN
 1000 FORMAT(' ROLL-CALLS READ=',I4,2X,'NUMBER REJECTED=',I4,2X,
     C'NUMBER ACCEPTED=',I4,2X,'CUTOFF=',F6.3)
      WRITE(23,1001)NP,NMOB,NOB,KVMIN
 1001 FORMAT(' LEGISLATORS READ=',I4,2X,'NUMBER REJECTED=',I4,2X,
     C'NUMBER ACCEPTED=',I4,2X,'CUTOFF=',I4)
      NRCALL=NAS
      NP=NOB
C
C   CALCULATE DISTRIBUTION OF ROLL CALL MARGINS
C
      DO 4 J=1,NRCALL
      LL=MAX0(KYES(J),KNO(J))
      AA=FLOAT(LL)/FLOAT(KYES(J)+KNO(J))
      IF(AA.GE..50.AND.AA.LE..55)KMARG(1)=KMARG(1)+1
      IF(AA.GT..55.AND.AA.LE..60)KMARG(2)=KMARG(2)+1
      IF(AA.GT..60.AND.AA.LE..65)KMARG(3)=KMARG(3)+1
      IF(AA.GT..65.AND.AA.LE..70)KMARG(4)=KMARG(4)+1
      IF(AA.GT..70.AND.AA.LE..75)KMARG(5)=KMARG(5)+1
      IF(AA.GT..75.AND.AA.LE..80)KMARG(6)=KMARG(6)+1
      IF(AA.GT..80.AND.AA.LE..85)KMARG(7)=KMARG(7)+1
      IF(AA.GT..85.AND.AA.LE..90)KMARG(8)=KMARG(8)+1
      IF(AA.GT..90.AND.AA.LE..95)KMARG(9)=KMARG(9)+1
      IF(AA.GT..95.AND.AA.LE..975)KMARG(10)=KMARG(10)+1
  4   CONTINUE
      WRITE(23,1003)
 1003 FORMAT('  DISTRIBUTION OF SCALABLE ROLL CALLS')
      DO 5 I=1,10
      AA=FLOAT(KMARG(I))/FLOAT(NRCALL)
      WRITE(23,1002)I,LMARG(I),KMARG(I),AA
  5   CONTINUE
 1002 FORMAT(I4,1X,A10,I5,F7.3)
      RETURN
      END
C
C
C **************************************************************************
C  SUBROUTINE SPEARMAN -- CALCULATES PEARSON AND SPEARMAN CORRELATIONS 
C                         BETWEEN TWO VECTORS
C                         
C **************************************************************************
C
      SUBROUTINE SPEARMAN(NP,ZRANKD,ZRANKD2,RSPEAR,RPEARS)
      DIMENSION LLL(20003),MM(20003),NN(20003),FV1(20003),
     C          ZRANKD(20003),ZRANKD2(20003),FV2(20003),FV3(20003),
     C          MMM(20003)
 1085 FORMAT(' SPEARMAN AND PEARSON CORRELATIONS',I7,3F7.3)
C
C  CALCULATE THE PEARSON CORRELATION COEFFICIENT
C
      ASUM1=0.0
      BSUM1=0.0
      CSUM1=0.0
      DSUM1=0.0
      ESUM1=0.0
      DO 1 I=1,NP
      ASUM1=ASUM1+ZRANKD(I)
      BSUM1=BSUM1+ZRANKD(I)**2
      CSUM1=CSUM1+ZRANKD2(I)
      DSUM1=DSUM1+ZRANKD2(I)**2
      ESUM1=ESUM1+ZRANKD(I)*ZRANKD2(I)
  1   CONTINUE
      AA=FLOAT(NP)*ESUM1-ASUM1*CSUM1
      BB=FLOAT(NP)*BSUM1-ASUM1*ASUM1
      CC=FLOAT(NP)*DSUM1-CSUM1*CSUM1
      IF(SQRT(BB*CC).GT.0.0)RPEARS=AA/SQRT(BB*CC)
C
C
C  CALCULATE THE SPEARMAN RANK ORDER COEFFICIENTS
C
      DO 391 I=1,NP
      FV1(I)=ZRANKD(I)
      LLL(I)=I
      MM(I)=I
      NN(I)=I
  391 CONTINUE
C
C  RANK ORDER FIRST VECTOR
C
      CALL RSORT(FV1,NP,LLL)
C
C  PUT 2ND VECTOR IN SAME ORDER AS FIRST VECTOR
C
      DO 392 I=1,NP
      FV3(I)=ZRANKD2(LLL(I))
  392 FV2(I)=ZRANKD2(LLL(I))
C
C  NOW SORT 2ND VECTOR (THAT IS IN THE SAME ORDER AS THE FIRST)
C    TO OBTAIN VECTOR OF INTEGERS -- MM(.) -- THAT GIVE THE
C    POSTIONS OF THE 2ND VECTOR CORRESPONDING TO THE 1, 2, 3, ...
C    ETC., POSITIONS OF THE FIRST
C
      CALL RSORT(FV2,NP,MM)
      DO 380 I=1,NP
      MMM(I)=MM(I)
  380 CONTINUE
C
C  NOW SORT MM(.) TO OBTAIN NN(.) -- THE NUMBERS IN NN(.) GIVE
C    THE RANKS OF THE 2ND VECTOR CORRESPONDING TO THE RANKS OF
C    OF THE 1ST VECTOR (WHICH BY CONSTRUCTION, ARE 1, 2, 3, 4, ...)
C
      CALL RSORT(MMM,NP,NN)
      DSUM=0.0
      ASUM1=0.0
      BSUM1=0.0
      CSUM1=0.0
      DSUM1=0.0
      ESUM1=0.0
      DO 393 I=1,NP
C      WRITE(23,1000)I,NN(I)
 1000 FORMAT(2I6)
      DSUM=DSUM+(FLOAT(I)-FLOAT(NN(I)))**2
      ASUM1=ASUM1+FLOAT(I)
      BSUM1=BSUM1+FLOAT(I)**2
      CSUM1=CSUM1+FLOAT(NN(I))
      DSUM1=DSUM1+FLOAT(NN(I))**2
      ESUM1=ESUM1+FLOAT(I)*FLOAT(NN(I))
  393 CONTINUE
      AA=FLOAT(NP)*ESUM1-ASUM1*CSUM1
      BB=FLOAT(NP)*BSUM1-ASUM1*ASUM1
      CC=FLOAT(NP)*DSUM1-CSUM1*CSUM1
      IF(SQRT(BB*CC).GT.0.0)RSPEAR2=AA/SQRT(BB*CC)
      AA=6.0*DSUM
      XNP=FLOAT(NP)
      XBB=XNP*(XNP*XNP - 1.0)
      RSPEAR=1.0-AA/XBB
      WRITE(23,1085)NP,RSPEAR,RSPEAR2,RPEARS
C      WRITE(*,1002)DSUM
 1002 FORMAT(F15.2)
      RETURN
      END
C
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
C  
C  *************************************************************************
C    SUBROUTINE RMEDIAN -- FINDS MEDIAN FROM AN ORDERED VECTOR
C  *************************************************************************
C
C
      subroutine rmedian(xvec,nvec,nmed,xmed)
      dimension xvec(1960)
  300 format(' Fatal Error in Rmedian',2i5)
      kvec=nvec/2
      kcheck=nvec - 2*kvec
      if(kcheck.eq.0)then
         xmed=(xvec(kvec)+xvec(kvec+1))/2.0
         nmed=kvec
      endif
      if(kcheck.eq.1)then
         xmed=xvec(kvec+1)
         nmed=kvec+1
      endif
      if(kcheck.gt.1.or.kcheck.lt.0)then
         write(*,300)kcheck,nvec
         stop
      endif
      return
      end
C
C  **************************************************************************
C    SUBROUTINE JAN11PT -- FINDS OPTIMAL CUTTING POINT FOR ONE DIMENSION
C  **************************************************************************
C
      SUBROUTINE JAN11PT(NP,IVOT,YSS,KA,WS,JCH,JEH,JCL,JEL,KCCUT,
     C                    LCCUT,RICE,Y)
      DIMENSION YSS(1701),KA(1701),WS(7398),LV(1701),LVB(1701),
     C          LEB(1701),Z(1701),Y(1701),
     C          LE(1701),LJEP(1701),RICE(1701),
     C          AAJEP(101),
     C          ABJEP(101),LAJEP(101),LBJEP(101),LCJEP(101),
     C          LDJEP(101),ABABJEP(101),MJEP(101)
C
      NPN=NP+1
      NPP=NP-1
      KCUT=KCCUT
      LCUT=LCCUT
      NOTE=1
      AA1=0.0
      AB1=0.0
      LA1=0
      LB1=0
      LC1=0
      LD1=0
      DO 999 III=1,NOTE
C
C  CHECK ALL POSSIBLE INTERIOR CUT POINTS  --  THE NP INPUT POINTS
C      ARE HELD FIXED.  THERE ARE NP POSSIBLE CUT-POINTS BEGINNING
C      WITH CUT-POINT 1 WHICH IS .001 UNITS TO THE LEFT OF POINT 1.
C      CUT-POINT 2 IS BETWEEN POINTS 1 AND 2, ETC.
C
C     1   2   3   4   5   6   7   8   9   10   11 ...... NP-1   NP
C    *  *   *   *   *   *   *   *   *   *    *                *
C    1  2   3   4   5   6   7   8   9  10   11  ...........  NP
C
C  IF KCUT=1 AND LCUT=6, THE FOLLOWING NP PATTERNS ARE TESTED
C
C PATTERN
C   1         6666666666666666666666
C   2         1666666666666666666666
C   3         1166666666666666666666
C   4         1116666666666666666666
C   5         1111666666666666666666
C   6         1111166666666666666666
C   7         1111116666666666666666
C   .           .....
C   .           .....
C   .           .....
C  NP-1       1111111111111111111166
C   NP        1111111111111111111116
C
C  BECAUSE THE PROGRAM TRIES BOTH KCUT=1/LCUT=6 AND KCUT=6/LCUT=1, THIS
C  WILL ALSO TEST THE ONE MISSING PATTERN ABOVE, VIZ., ALL "1"s.
C
C
      KSE=0
      KSV=0
      LSV=0
      LSE=0
      KMARK=1
      I=0
  10  I=I+1
      IF(I-NP-1)61,12,12
  61  Z(I)=999.0
      IF(I.EQ.1)THEN
         Y(I)=YSS(1)-.001
      ENDIF
      IF(I.GT.1)THEN
         Y(I)=(YSS(I)+YSS(I-1))/2.0
      ENDIF
C      IF(KA(I).EQ.9)GO TO 10
      IF(KMARK.EQ.1)THEN
         DO 3 J=I,NP
         IF(KA(J).EQ.9)GO TO 3
         IF(LCUT-KA(J))33,5,33
  33     IF(KCUT-KA(J))3,6,3
  5      LSV=LSV+1
         GO TO 3
  6      LSE=LSE+1
  3      CONTINUE
         KMARK=0
         GO TO 31
      ENDIF
      IF(KA(I-1).EQ.KCUT)THEN
         KSV=KSV+1
         LSE=LSE-1
      ENDIF
      IF(KA(I-1).EQ.LCUT)THEN
         KSE=KSE+1
         LSV=LSV-1
      ENDIF
C
  31  CONTINUE
      LJEP(I)=I
      LV(I)=KSV
      LVB(I)=LSV
      LE(I)=KSE
      LEB(I)=LSE
      KT=LV(I)+LE(I)+LVB(I)+LEB(I)
      Z(I)=FLOAT(LE(I)+LEB(I))/FLOAT(KT)
      COX1=0.0
      COX2=0.0
      IF(LV(I)+LEB(I).GT.0)COX1=FLOAT(LV(I))/FLOAT(LV(I)+LEB(I))
      IF(LVB(I)+LE(I).GT.0)COX2=FLOAT(LE(I))/FLOAT(LVB(I)+LE(I))
      RICE(I)=COX1-COX2
C      WRITE(21,1001)I,Y(I),KA(I),LVB(I),LEB(I),LV(I),LE(I),RICE(I)
 1001 FORMAT(I4,F7.3,I2,4I4,F7.3)
C
      GO TO 10
  12  CONTINUE
C
C  FIND BEST CUT POINT
C
      CALL RSORT(Z,NP,LJEP)
      KIN=1
      MJEP(1)=1
      AAJEP(KIN)=Z(1)
      ABJEP(KIN)=Y(LJEP(1))
      ABABJEP(KIN)=ABS(ABJEP(KIN))
      LAJEP(KIN)=LV(LJEP(1))
      LBJEP(KIN)=LE(LJEP(1))
      LCJEP(KIN)=LVB(LJEP(1))
      LDJEP(KIN)=LEB(LJEP(1))
C
C  CHECK IF THERE ARE MULTIPLE CUT-POINTS WITH SAME CLASSIFICATION AND
C    SELECT THAT CUT-POINT CLOSEST TO THE INTERIOR OF THE SPACE
C
      DO 63 I=2,NP
      IF(Z(1).EQ.Z(I))THEN
         KIN=KIN+1
         MJEP(KIN)=KIN
         AAJEP(KIN)=Z(I)
         ABJEP(KIN)=Y(LJEP(I))
         ABABJEP(KIN)=ABS(ABJEP(KIN))
         LAJEP(KIN)=LV(LJEP(I))
         LBJEP(KIN)=LE(LJEP(I))
         LCJEP(KIN)=LVB(LJEP(I))
         LDJEP(KIN)=LEB(LJEP(I))
         IF(KIN.GT.100)GO TO 633
         GO TO 63
      ENDIF
      IF(Z(1).LT.Z(I))GO TO 633
  63  CONTINUE
  633 CONTINUE
      IF(KIN.EQ.1)THEN
         AA=AAJEP(1)
         AB=ABJEP(1)
         LA=LAJEP(1)
         LB=LBJEP(1)
         LC=LCJEP(1)
         LD=LDJEP(1)
      ENDIF
      IF(KIN.GT.1)THEN
         CALL RSORT(ABABJEP,KIN,MJEP)
         AA=AAJEP(MJEP(1))
         AB=ABJEP(MJEP(1))
         LA=LAJEP(MJEP(1))
         LB=LBJEP(MJEP(1))
         LC=LCJEP(MJEP(1))
         LD=LDJEP(MJEP(1))
      ENDIF
C
      AA1=AA
      AB1=AB
      LA1=LA
      LB1=LB
      LC1=LC
      LD1=LD
C
  999 CONTINUE
      AA=AA1
      AB=AB1
      LA=LA1
      LB=LB1
      LC=LC1
      LD=LD1
      WS(IVOT)=AB
      JCL=LA
      JEL=LB
      JCH=LC
      JEH=LD
C
      RETURN
      END
C
C
C **************************************************************************
C  SUBROUTINE QUADRPL -- CALCULATES LEGISLATOR COORDINATES FOR THE 
C                          MULTI-DIMENSIONAL QUADRATIC UTILITY MODEL
C                         
C **************************************************************************
C
      SUBROUTINE QUADRPL(NS,NP,NRCALL,MCUTS,XMAT,WS,ZVEC,LDATA,
     C                    ZGAMMA,XXGAMMA,XLEGLOG,KLEGLOG,OUTXI,ZDF,
     C                    NDEVIT,XDEVIT)
      DIMENSION XMAT(1960,25),ZVEC(1701,25),XLEGLOG(1960),
     C          LDATA(1960,1701),WS(7398),KLEGLOG(1960),
     C          MCUTS(1701,2),ZDF(150000,4),
     C          ZLOG(1701),XWIMJ(1960,1701),XXX(1701),
     C          MYES(1701),MNO(1701),YGMP(10000),LLL(10000),
     C          YGAMMA(10000,25),YLOG(10000),KLASS(1701),
     C          ZGAMMA(1701),KLEFT(1960,1701),
     C          LCHECK(1701),XXGAMMA(1960),XMAT2(25),
     C          XXXSAVE(1701,25),XDERV(25),XEXIT1(25),
     C          XEXIT2(25),AADERV(50),OUTX(50,50),
     C          ZMAT(50,50),WVEC(50),FV1(50),FV2(50),
     C          OUTXI(1960,25)
C
  101 FORMAT(' PERFORMANCE INDEX EIGENVALUE/VECTOR ROUTINE=',3I6)
  102 FORMAT(2I6,30F10.4)
  200 FORMAT(3F15.8)
  201 FORMAT(2I5,I2,F12.7,I8,2F15.8)
  202 FORMAT(' LOG-LIKELIHOOD LEGISLATOR PHASE         ',I8,F16.5,F9.5)
  203 FORMAT(I5,I4,I7,F12.5,F8.4,40F8.4)
  204 FORMAT(' LOG-LIKELIHOOD & CLASS LEG PHASE',2I8,F16.5,F9.5)
  205 FORMAT(I5,I4,I7,1X,7A1,1X,I4,1X,11A1,F12.5,10F8.4)
  206 FORMAT(I5,40F8.4)
  307 FORMAT(' YOU SCREWED UP FARTKNOCKER!')
  308 FORMAT(' YOU SCREWED UP BEAVIS!',3I5,25F8.4)
 1109 FORMAT(' INITIAL CLASSIFICATION LEG PHASE',I3,8I8)
C
C
      XTOTLOG=0.0
      KTOT=0
      KCHECK=0
      KCHECK3=0
      KCHECK33=0
      KCHECK333=0
      DO 881 JX=1,NRCALL
C
      KLASS(JX)=0
      ZLOG(JX)=0.0
      ILOG=0
      KYES=0
      KNO=0
      DO 882 I=1,NP
      KLEFT(I,JX)=0
      IF(LDATA(I,JX).EQ.1)KYES=KYES+1
      IF(LDATA(I,JX).EQ.6)KNO=KNO+1
      IWRONG=0
C
C  GET Wi
C
      SUMI=0.0
      DO 90 K=1,NS
      SUMI=SUMI+XMAT(I,K)*ZVEC(JX,K)
  90  CONTINUE
C
C  IF ONE DIMENSION SET Wi = Xi
C
      IF(NS.EQ.1)SUMI=XMAT(I,1)
C
      KCUT=MCUTS(JX,1)
      LCUT=MCUTS(JX,2)
      IF(LDATA(I,JX).EQ.0)GO TO 882
C
C  Xi TO THE LEFT OF THE MIDPOINT
C
      IF(SUMI.LE.WS(JX))THEN
         KLEFT(I,JX)=1
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.KCUT)THEN
            WIMJ=WS(JX)-SUMI
            XWIMJ(I,JX)=WIMJ
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.KCUT)THEN
            KCHECK=KCHECK+1
            IF(ABS(SUMI-WS(JX)).GT..001)KCHECK33=KCHECK33+1
            WIMJ=SUMI-WS(JX)
            XWIMJ(I,JX)=WIMJ
            IWRONG=1
            KLASS(JX)=KLASS(JX)+1
         ENDIF
      ENDIF
C
C  Xi TO THE RIGHT OF THE MIDPOINT
C
      IF(SUMI.GT.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.LCUT)THEN
            WIMJ=SUMI-WS(JX)
            XWIMJ(I,JX)=WIMJ
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.LCUT)THEN
            KCHECK=KCHECK+1
            IF(ABS(SUMI-WS(JX)).GT..001)KCHECK33=KCHECK33+1
            WIMJ=WS(JX)-SUMI
            XWIMJ(I,JX)=WIMJ
            IWRONG=1
            KLASS(JX)=KLASS(JX)+1
         ENDIF
      ENDIF
      WIMJ=WIMJ*2.0*ZGAMMA(JX)*XXGAMMA(I)
      WWIMJ=WIMJ*XDEVIT
      KWIMJ=IFIX(ABS(WWIMJ)+.5)
      IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2
      IF(WIMJ.GE.0.0)THEN
         CDF=ZDF(NDEVIT-1+KWIMJ+1,2)
         CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3)
      ENDIF
      IF(WIMJ.LT.0.0)THEN
         CDF=ZDF(NDEVIT-KWIMJ,2)
         CDFLOG=ZDF(NDEVIT-KWIMJ,3)
      ENDIF
C      WRITE(23,201)JX,I,IWRONG,WIMJ,KWIMJ,CDF,CDFLOG
      IF(WIMJ.LT.0.0)KCHECK333=KCHECK333+1
      ZLOG(JX)=ZLOG(JX)+CDFLOG
      ILOG=ILOG+1
      KTOT=KTOT+1
      XTOTLOG=XTOTLOG+CDFLOG
  882 CONTINUE
      MYES(JX)=KYES
      MNO(JX)=KNO
      GMP=EXP(ZLOG(JX)/FLOAT(ILOG))
c      WRITE(26,202)JX,ZLOG(JX),GMP
  881 CONTINUE
      GMP=EXP(XTOTLOG/FLOAT(KTOT))
      WRITE(23,202)KTOT,XTOTLOG,GMP
C      WRITE(*,202)KTOT,XTOTLOG,GMP
      WRITE(23,1109)NS,KCHECK,KCHECK33,KCHECK333
C      WRITE(* ,1109)NS,KCHECK,KCHECK33,KCHECK333
C
C
C  CALCULATE NEW PROJECTED LEGISLATOR COORDINATE WITH A 
C      SIMPLE GRID SEARCH
C
      NINC=10
      YTOTLOG=0.0
      ITOTLOG=0
      KCHECKT=0
C
      DO 11 I=1,NP
C
      DO 99 IIII=1,10
C
      DO 2 K=1,NS
      XMAT2(K)=XMAT(I,K)
      XXX(K)=0.0
  2   CONTINUE
C
      KCHECK=0
      XTOTLOG=0.0
      ILOG=0
      DO 40 K=1,NS
      XDERV(K)=0.0
      DO 40 JK=1,NS
      OUTX(JK,K)=0.0
  40  CONTINUE
      KITOT=0
      DO 10 JX=1,NRCALL
      IF(LDATA(I,JX).EQ.0)GO TO 10
      KITOT=KITOT+1
C
C  GET Wi
C
      SUMI=0.0
      DO 91 K=1,NS
      SUMI=SUMI+XMAT2(K)*ZVEC(JX,K)
  91  CONTINUE
C
C  IF ONE DIMENSION SET Wi = Xi
C
      IF(NS.EQ.1)SUMI=XMAT2(1)
C
      KCUT=MCUTS(JX,1)
      LCUT=MCUTS(JX,2)
C
C  Xi TO THE LEFT OF THE MIDPOINT
C
      IF(SUMI.LE.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.KCUT)THEN
            WIMJ=WS(JX)-SUMI
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.KCUT)THEN
            KCHECK=KCHECK+1
            WIMJ=SUMI-WS(JX)
         ENDIF
      ENDIF
C
C  Xi TO THE RIGHT OF THE MIDPOINT
C
      IF(SUMI.GT.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.LCUT)THEN
            WIMJ=SUMI-WS(JX)
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.LCUT)THEN
            KCHECK=KCHECK+1
            WIMJ=WS(JX)-SUMI
         ENDIF
      ENDIF
      WIMJ=WIMJ*2.0*ZGAMMA(JX)*XXGAMMA(I)
      WWIMJ=WIMJ*XDEVIT
      KWIMJ=IFIX(ABS(WWIMJ)+.5)
      IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2
C
C  CORRECTLY CLASSIFIED
C
      IF(WIMJ.GE.0.0)THEN
         CDF=ZDF(NDEVIT-1+KWIMJ+1,2)
         CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3)
         DO 41 K=1,NS
         IF(SUMI.GT.WS(JX))THEN
            XDERV(K)=XDERV(K)+ZDF(NDEVIT-1+KWIMJ+1,4)*
     C                         2.0*ZGAMMA(JX)*XXGAMMA(I)*ZVEC(JX,K)
            AADERV(K)=ZDF(NDEVIT-1+KWIMJ+1,4)*
     C                         2.0*ZGAMMA(JX)*XXGAMMA(I)*ZVEC(JX,K)
         ENDIF
         IF(SUMI.LE.WS(JX))THEN
            XDERV(K)=XDERV(K)-ZDF(NDEVIT-1+KWIMJ+1,4)*
     C                         2.0*ZGAMMA(JX)*XXGAMMA(I)*ZVEC(JX,K)
            AADERV(K)=-ZDF(NDEVIT-1+KWIMJ+1,4)*
     C                         2.0*ZGAMMA(JX)*XXGAMMA(I)*ZVEC(JX,K)
         ENDIF
  41     CONTINUE
      ENDIF
C
C  INCORRECTLY CLASSIFIED
C
      IF(WIMJ.LT.0.0)THEN
         CDF=ZDF(NDEVIT-KWIMJ,2)
         CDFLOG=ZDF(NDEVIT-KWIMJ,3)
         DO 42 K=1,NS
         IF(SUMI.GT.WS(JX))THEN
            XDERV(K)=XDERV(K)-ZDF(NDEVIT-KWIMJ,4)*
     C                         2.0*ZGAMMA(JX)*XXGAMMA(I)*ZVEC(JX,K)
            AADERV(K)=-ZDF(NDEVIT-KWIMJ,4)*
     C                         2.0*ZGAMMA(JX)*XXGAMMA(I)*ZVEC(JX,K)
         ENDIF
         IF(SUMI.LE.WS(JX))THEN
            XDERV(K)=XDERV(K)+ZDF(NDEVIT-KWIMJ,4)*
     C                         2.0*ZGAMMA(JX)*XXGAMMA(I)*ZVEC(JX,K)
            AADERV(K)=ZDF(NDEVIT-KWIMJ,4)*
     C                         2.0*ZGAMMA(JX)*XXGAMMA(I)*ZVEC(JX,K)
         ENDIF
  42     CONTINUE
      ENDIF
      ILOG=ILOG+1
      XTOTLOG=XTOTLOG+CDFLOG
C
C  COMPUTE OUTER PRODUCT MATRIX
C
      DO 32 JJK=1,NS
      DO 32 JJJ=1,NS
      OUTX(JJJ,JJK)=OUTX(JJJ,JJK)+AADERV(JJK)*AADERV(JJJ)
  32  CONTINUE
C
  10  CONTINUE
      GMP=EXP(XTOTLOG/FLOAT(ILOG))
      DO 51 K=1,NS
      XXX(K)=XDERV(K)/FLOAT(ILOG)
  51  CONTINUE
C
C  INVERT OUTER PRODUCT MATRIX TO GET STANDARD ERRORS
C
C    ***CONSTANT MODEL***
C
C      WRITE(33,102)I,NS,(OUTX(1,J),J=1,NS)
C      WRITE(33,102)I,NS,(OUTX(2,J),J=1,NS)
      call rs(50,NS,OUTX,wvec,1,ZMAT,fv1,fv2,ier)
C      WRITE(33,101)I,NS,IER
C      WRITE(33,102)I,NS,(WVEC(J),J=1,NS)
C
C  (X'X)-1
C
      DO 60 I8=1,NS
      DO 60 K8=1,NS
      SUM=0.0
      DO 62 J8=1,NS
      IF(ABS(WVEC(NS+1-J8)).GT..0001)THEN
          SUM=SUM+ZMAT(K8,NS+1-J8)*(1.0/WVEC(NS+1-J8))*ZMAT(I8,NS+1-J8)
      ENDIF
  62  CONTINUE
  60  OUTX(I8,K8)=SUM
      DO 61 K8=1,NS
      OUTXI(I,K8)=SQRT(ABS(OUTX(K8,K8)))
  61  CONTINUE
C
C  CALCULATE EXIT & ENTRY POINTS OF UNIT HYPERSPHERE --
C             XMAT(.) + alpha*XDERV(.)
C    USING QUADRATIC FORMULA
C
      SUMA=0.0
      SUMB=0.0
      SUMC=0.0
      DO 4 K=1,NS
      SUMA=SUMA+XXX(K)**2
      SUMB=SUMB+XMAT(I,K)*XXX(K)
      SUMC=SUMC+XMAT(I,K)**2
  4   CONTINUE
      SUMC=SUMC-1.0
      AROOT=SUMB**2 - SUMA*SUMC
      IF(AROOT.LT.0.0)THEN
         WRITE(*,307)
         WRITE(21,206)I,(XMAT(I,K),K=1,NS),(XXX(K),K=1,NS),
     C                SUMA,SUMB,SUMC,AROOT
         STOP
      ENDIF
      QROOT=SQRT(SUMB**2 - SUMA*SUMC)
      ALPHA1=(-SUMB+QROOT)/SUMA
      ALPHA2=(-SUMB-QROOT)/SUMA
      DO 404 K=1,NS
      XEXIT1(K)=XMAT(I,K)+ALPHA1*XXX(K)
      XEXIT2(K)=XMAT(I,K)+ALPHA2*XXX(K)
  404 CONTINUE
C
C  GET THE POSITIVE ALPHA -- THIS IS THE CORRECT DIRECTION
C     SQUARED DISTANCE TO RIM OF HYPERSPHERE IS 
C     (ALPHA**2)*SUMA
C
C  ERROR CATCH IF ONE DIMENSION
C
      DRIM=.01
      IF(ALPHA1.GT.0.0)THEN
         ALPHA=ALPHA1
         DRIM=SQRT(SUMA)*ALPHA
      ENDIF
      IF(ALPHA2.GT.0.0)THEN
         ALPHA=ALPHA2
         DRIM=SQRT(SUMA)*ALPHA
      ENDIF
C
C  CALCULATE STEPSIZE IN .01 UNITS
C
      STEP=(.01)/DRIM
      KSTEP=IFIX(STEP+.5)
C      
C
C      WRITE(28,203)I,I,KCHECK,XTOTLOG,GMP,
C     C              (XMAT(I,K),K=1,NS),(XXX(K),K=1,NS),
C     C              ALPHA1,ALPHA2,ALPHA,DRIM,STEP,
C     C              (XEXIT1(K),K=1,NS),(XEXIT2(K),K=1,NS)
C
C  SEARCH ALONG VECTOR IN BEST DIRECTION
C
C
      DO 242 K=1,NS
      XMAT2(K)=XMAT(I,K)
  242 CONTINUE
C
      XINC=0.0
C
      DO 212 KK=1,NINC
      SUM=0.0
C      WRITE(59,5960)I,IIII,KK,XMAT2(1),XMAT(I,1),XINC,ALPHA,XXX(1),
C     C                        STEP,DRIM
C 5960 FORMAT(3I5,7F12.4)
      DO 24 K=1,NS
      XMAT2(K)=XMAT(I,K)+XINC*ALPHA*XXX(K)
      SUM=SUM+XMAT2(K)**2
  24  CONTINUE
C
C  CHECK TO SEE IF LEGISLATOR POINT OUTSIDE UNIT HYPERSPHERE
C
      IF(SUM.GT.1.0)THEN
         GO TO 2112
      ENDIF
      KCHECK=0
      XTOTLOG=0.0
      ILOG=0
      DO 240 K=1,NS
      XDERV(K)=0.0
  240 CONTINUE
      DO 210 JX=1,NRCALL
      IF(LDATA(I,JX).EQ.0)GO TO 210
C
C  GET Wi
C
      SUMI=0.0
      DO 291 K=1,NS
      SUMI=SUMI+XMAT2(K)*ZVEC(JX,K)
  291 CONTINUE
C
C  IF ONE DIMENSION SET Wi = Xi
C
      IF(NS.EQ.1)SUMI=XMAT2(1)
C
      KCUT=MCUTS(JX,1)
      LCUT=MCUTS(JX,2)
C
C  Xi TO THE LEFT OF THE MIDPOINT
C
      IF(SUMI.LE.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.KCUT)THEN
            WIMJ=WS(JX)-SUMI
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.KCUT)THEN
            KCHECK=KCHECK+1
            WIMJ=SUMI-WS(JX)
         ENDIF
      ENDIF
C
C  Xi TO THE RIGHT OF THE MIDPOINT
C
      IF(SUMI.GT.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.LCUT)THEN
            WIMJ=SUMI-WS(JX)
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.LCUT)THEN
            KCHECK=KCHECK+1
            WIMJ=WS(JX)-SUMI
         ENDIF
      ENDIF
      WIMJ=WIMJ*2.0*ZGAMMA(JX)*XXGAMMA(I)
      WWIMJ=WIMJ*XDEVIT
      KWIMJ=IFIX(ABS(WWIMJ)+.5)
      IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2
C
C  CORRECTLY CLASSIFIED
C
      IF(WIMJ.GE.0.0)THEN
C         WRITE(59,5959)I,IIII,JX,KK,WIMJ,KWIMJ,SUMI,
C     C                                 ZGAMMA(JX),XXGAMMA(I)
C 5959 FORMAT(4I5,F12.4,I5,3F10.4)
         CDF=ZDF(NDEVIT-1+KWIMJ+1,2)
         CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3)
         DO 241 K=1,NS
         IF(SUMI.GT.WS(JX))THEN
            XDERV(K)=XDERV(K)+ZDF(NDEVIT-1+KWIMJ+1,4)*
     C                         2.0*ZGAMMA(JX)*XXGAMMA(I)*ZVEC(JX,K)
         ENDIF
         IF(SUMI.LE.WS(JX))THEN
            XDERV(K)=XDERV(K)-ZDF(NDEVIT-1+KWIMJ+1,4)*
     C                         2.0*ZGAMMA(JX)*XXGAMMA(I)*ZVEC(JX,K)
         ENDIF
  241    CONTINUE
      ENDIF
C
C  INCORRECTLY CLASSIFIED
C
      IF(WIMJ.LT.0.0)THEN
         CDF=ZDF(NDEVIT-KWIMJ,2)
         CDFLOG=ZDF(NDEVIT-KWIMJ,3)
         DO 342 K=1,NS
         IF(SUMI.GT.WS(JX))THEN
            XDERV(K)=XDERV(K)-ZDF(NDEVIT-KWIMJ,4)*
     C                         2.0*ZGAMMA(JX)*XXGAMMA(I)*ZVEC(JX,K)
         ENDIF
         IF(SUMI.LE.WS(JX))THEN
            XDERV(K)=XDERV(K)+ZDF(NDEVIT-KWIMJ,4)*
     C                         2.0*ZGAMMA(JX)*XXGAMMA(I)*ZVEC(JX,K)
         ENDIF
  342    CONTINUE
      ENDIF
      ILOG=ILOG+1
      XTOTLOG=XTOTLOG+CDFLOG
  210 CONTINUE
      GMP=EXP(XTOTLOG/FLOAT(ILOG))
C      WRITE(28,203)I,KK,KCHECK,XTOTLOG,GMP,
C     C              (XMAT2(K),K=1,NS),(XXX(K),K=1,NS),(XDERV(K),K=1,NS)
      YGMP(KK)=GMP
      LLL(KK)=KK
      LCHECK(KK)=KCHECK
      DO 222 K=1,NS
      YGAMMA(KK,K)=XMAT2(K)
      XXXSAVE(KK,K)=XXX(K)
  222 CONTINUE
      YLOG(KK)=XTOTLOG
      XINC=XINC+STEP
  212 CONTINUE
      NNINC=NINC
      GO TO 2113
 2112 NNINC=KK-1
C
C  CHECK FOR FATAL ERROR
C
      IF(NNINC.LE.0)THEN
         WRITE(*,308)I,KK,NNINC,(XMAT(I,K),K=1,NS)
      ENDIF
C
 2113 CONTINUE
C
C  FIND MAXIMUM ON BEST DIRECTION THROUGH THE SPACE
C
      CALL RSORT(YGMP,NNINC,LLL)
      DO 224 K=1,NS
      XMAT(I,K)=YGAMMA(LLL(NNINC),K)
  224 CONTINUE
C
  99  CONTINUE
C
      XLEGLOG(I)=YLOG(LLL(NNINC))
      YTOTLOG=YTOTLOG+YLOG(LLL(NNINC))
      KLEGLOG(I)=KITOT
      KCHECKT=KCHECKT+LCHECK(LLL(NNINC))
      ITOTLOG=ITOTLOG+ILOG
  11  CONTINUE
      GMP=EXP(YTOTLOG/FLOAT(ITOTLOG))
C      WRITE(21,202)ITOTLOG,YTOTLOG,GMP
C      WRITE(*,202)ITOTLOG,YTOTLOG,GMP
      WRITE(21,204)KCHECKT,ITOTLOG,YTOTLOG,GMP
      WRITE(*,204)KCHECKT,ITOTLOG,YTOTLOG,GMP
C
      RETURN
      END
C
C
C **************************************************************************
C  SUBROUTINE QUADRPC -- CALCULATES ROLL CALL MIDPOINTS FOR THE 
C                          MULTI-DIMENSIONAL QUADRATIC UTILITY MODEL
C                         
C **************************************************************************
C
      SUBROUTINE QUADRPC(NS,NP,NRCALL,MCUTS,XMAT,WS,ZVEC,LDATA,
     C               ZGAMMA,XXGAMMA,XRCLOG,KRCLOG,ZDF,NDEVIT,XDEVIT)
      DIMENSION XMAT(1960,25),ZVEC(1701,25),XRCLOG(1701),KRCLOG(1701),
     C          LDATA(1960,1701),WS(7398),
     C          MCUTS(1701,2),ZDF(150000,4),
     C          ZLOG(1701),XWIMJ(1960,1701),
     C          MYES(1701),MNO(1701),YGMP(10000),LLL(10000),
     C          YGAMMA(10000),YLOG(10000),KLASS(1701),
     C          ZGAMMA(1701),KLEFT(1960,1701),
     C          LCHECK(1701),XXGAMMA(1960)
C
  200 FORMAT(3F15.8)
  201 FORMAT(2I5,I2,F12.7,I8,2F15.8)
  202 FORMAT(' LOG-LIKELIHOOD ROLL CALL PHASE          ',I8,F16.5,F9.5)
  203 FORMAT(I5,I4,I7,2F7.3,3F12.5,F8.4)
  204 FORMAT(' LOG-LIKELIHOOD & CLASS RC PHASE ',2I8,F16.5,F9.5)
  205 FORMAT(I5,I4,3I4,1X,2F7.3,F12.5,F8.4)
  206 FORMAT(5I6)
 1109 FORMAT(' INITIAL CLASSIFICATION RC PHASE ',I3,8I8)
C
C
      XTOTLOG=0.0
      KTOT=0
      KCHECK=0
      KCHECK3=0
      KCHECK33=0
      KCHECK333=0
      DO 881 JX=1,NRCALL
C
      KLASS(JX)=0
      ZLOG(JX)=0.0
      ILOG=0
      KYES=0
      KNO=0
      DO 882 I=1,NP
      KLEFT(I,JX)=0
      IF(LDATA(I,JX).EQ.1)KYES=KYES+1
      IF(LDATA(I,JX).EQ.6)KNO=KNO+1
      IWRONG=0
C
C  GET Wi
C
      SUMI=0.0
      DO 90 K=1,NS
      SUMI=SUMI+XMAT(I,K)*ZVEC(JX,K)
  90  CONTINUE
C
C  IF ONE DIMENSION SET Wi = Xi
C
      IF(NS.EQ.1)SUMI=XMAT(I,1)
C
      KCUT=MCUTS(JX,1)
      LCUT=MCUTS(JX,2)
      IF(LDATA(I,JX).EQ.0)GO TO 882
C
C  Xi TO THE LEFT OF THE MIDPOINT
C
      IF(SUMI.LE.WS(JX))THEN
         KLEFT(I,JX)=1
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.KCUT)THEN
            WIMJ=WS(JX)-SUMI
            XWIMJ(I,JX)=WIMJ
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.KCUT)THEN
            KCHECK=KCHECK+1
            IF(ABS(SUMI-WS(JX)).GT..001)KCHECK33=KCHECK33+1
            WIMJ=SUMI-WS(JX)
            XWIMJ(I,JX)=WIMJ
            IWRONG=1
            KLASS(JX)=KLASS(JX)+1
         ENDIF
      ENDIF
C
C  Xi TO THE RIGHT OF THE MIDPOINT
C
      IF(SUMI.GT.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.LCUT)THEN
            WIMJ=SUMI-WS(JX)
            XWIMJ(I,JX)=WIMJ
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.LCUT)THEN
            KCHECK=KCHECK+1
            IF(ABS(SUMI-WS(JX)).GT..001)KCHECK33=KCHECK33+1
            WIMJ=WS(JX)-SUMI
            XWIMJ(I,JX)=WIMJ
            IWRONG=1
            KLASS(JX)=KLASS(JX)+1
         ENDIF
      ENDIF
      WIMJ=WIMJ*2.0*ZGAMMA(JX)*XXGAMMA(I)
      WWIMJ=WIMJ*XDEVIT
      KWIMJ=IFIX(ABS(WWIMJ)+.5)
      IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2
      IF(WIMJ.GE.0.0)THEN
         CDF=ZDF(NDEVIT-1+KWIMJ+1,2)
         CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3)
      ENDIF
      IF(WIMJ.LT.0.0)THEN
         CDF=ZDF(NDEVIT-KWIMJ,2)
         CDFLOG=ZDF(NDEVIT-KWIMJ,3)
      ENDIF
      IF(WIMJ.LT.0.0)KCHECK333=KCHECK333+1
      ZLOG(JX)=ZLOG(JX)+CDFLOG
      ILOG=ILOG+1
      KTOT=KTOT+1
      XTOTLOG=XTOTLOG+CDFLOG
  882 CONTINUE
      MYES(JX)=KYES
      MNO(JX)=KNO
C      WRITE(26,206)JX,MYES(JX),MNO(JX),KLASS(JX),ILOG
C      WRITE(*,206)JX,MYES(JX),MNO(JX),KLASS(JX),ILOG
      GMP=EXP(ZLOG(JX)/FLOAT(ILOG))
C      WRITE(26,202)JX,ZLOG(JX),GMP
  881 CONTINUE
      GMP=EXP(XTOTLOG/FLOAT(KTOT))
      WRITE(23,202)KTOT,XTOTLOG,GMP
C      WRITE(*,202)KTOT,XTOTLOG,GMP
      WRITE(23,1109)NS,KCHECK,KCHECK33,KCHECK333
C      WRITE(* ,1109)NS,KCHECK,KCHECK33,KCHECK333
C
C
C  CALCULATE NEW PROJECTED ROLL CALL MIDPOINT WITH A 
C      SIMPLE GRID SEARCH
C
C
      YTOTLOG=0.0
      ITOTLOG=0
      KCHECKT=0
      DO 11 JX=1,NRCALL
      SAVEZMID=WS(JX)
      XINC=0.01
      NINC=201
      WS(JX)=-1.00
      DO 12 KK=1,NINC
      KCHECK=0
      XTOTLOG=0.0
      ILOG=0
      ZDERV=0.0
      DO 10 I=1,NP
C
C  GET Wi
C
      SUMI=0.0
      DO 290 K=1,NS
      SUMI=SUMI+XMAT(I,K)*ZVEC(JX,K)
  290 CONTINUE
C
C  IF ONE DIMENSION SET Wi = Xi
C
      IF(NS.EQ.1)SUMI=XMAT(I,1)
C
C
      IF(LDATA(I,JX).EQ.0)GO TO 10
C
C
      KCUT=MCUTS(JX,1)
      LCUT=MCUTS(JX,2)
C
C  Xi TO THE LEFT OF THE MIDPOINT
C
      IF(SUMI.LE.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.KCUT)THEN
            WIMJ=WS(JX)-SUMI
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.KCUT)THEN
            KCHECK=KCHECK+1
            WIMJ=SUMI-WS(JX)
         ENDIF
      ENDIF
C
C  Xi TO THE RIGHT OF THE MIDPOINT
C
      IF(SUMI.GT.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.LCUT)THEN
            WIMJ=SUMI-WS(JX)
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.LCUT)THEN
            KCHECK=KCHECK+1
            WIMJ=WS(JX)-SUMI
         ENDIF
      ENDIF
      WIMJ=WIMJ*2.0*ZGAMMA(JX)*XXGAMMA(I)
      WWIMJ=WIMJ*XDEVIT
      KWIMJ=IFIX(ABS(WWIMJ)+.5)
      IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2
C
C  CORRECTLY CLASSIFIED
C
      IF(WIMJ.GE.0.0)THEN
         CDF=ZDF(NDEVIT-1+KWIMJ+1,2)
         CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3)
         IF(SUMI.GT.WS(JX))THEN
            ZDERV=ZDERV-ZDF(NDEVIT-1+KWIMJ+1,4)*
     C                               2.0*ZGAMMA(JX)*XXGAMMA(I)
         ENDIF
         IF(SUMI.LE.WS(JX))THEN
            ZDERV=ZDERV+ZDF(NDEVIT-1+KWIMJ+1,4)*
     C                               2.0*ZGAMMA(JX)*XXGAMMA(I)
         ENDIF
      ENDIF
C
C  INCORRECTLY CLASSIFIED
C
      IF(WIMJ.LT.0.0)THEN
         CDF=ZDF(NDEVIT-KWIMJ,2)
         CDFLOG=ZDF(NDEVIT-KWIMJ,3)
         IF(SUMI.GT.WS(JX))THEN
            ZDERV=ZDERV+ZDF(NDEVIT-KWIMJ,4)*2.0*ZGAMMA(JX)*XXGAMMA(I)
         ENDIF
         IF(SUMI.LE.WS(JX))THEN
            ZDERV=ZDERV-ZDF(NDEVIT-KWIMJ,4)*2.0*ZGAMMA(JX)*XXGAMMA(I)
         ENDIF
      ENDIF
      ILOG=ILOG+1
      XTOTLOG=XTOTLOG+CDFLOG
C
  10  CONTINUE
      GMP=EXP(XTOTLOG/FLOAT(ILOG))
C      IF(JX.EQ.22)THEN
C      WRITE(26,203)JX,KK,KCHECK,SAVEZMID,WS(JX),XTOTLOG,GMP,ZDERV
C      ENDIF
      YGMP(KK)=GMP
      LLL(KK)=KK
      LCHECK(KK)=KCHECK
      YGAMMA(KK)=WS(JX)
      YLOG(KK)=XTOTLOG
      WS(JX)=WS(JX)+XINC
      IF(KK.GT.1)THEN
C
C  POSITVE - NEGATIVE BRACKETING OF ZERO DERIVATIVE
C
         IF(OLDZDERV.GT.0.0.AND.ZDERV.LT.0.0)THEN
            NNINC=KK
            GO TO 1212
         ENDIF
C
C  NEGATIVE - POSITVE BRACKETING OF ZERO DERIVATIVE
C
         IF(OLDZDERV.LT.0.0.AND.ZDERV.GT.0.0)THEN
            NNINC=KK
            GO TO 1212
         ENDIF
      ENDIF
      OLDZDERV=ZDERV
  12  CONTINUE
      NNINC=NINC
 1212 CONTINUE
      CALL RSORT(YGMP,NNINC,LLL)
      WS(JX)=YGAMMA(LLL(NNINC))
C      WRITE(27,205)JX,LLL(NNINC),LCHECK(LLL(NNINC)),MYES(JX),MNO(JX),
C     C       SAVEZMID,YGAMMA(LLL(NNINC)),YLOG(LLL(NNINC)),YGMP(NNINC)
      SAVEZMID=WS(JX)
      SAVELOG=YLOG(LLL(NNINC))
      KCHECKS=LCHECK(LLL(NNINC))
      XINC=0.01
      NINC=201
      WS(JX)=-1.00
      DO 712 KK=1,NINC
      KCHECK=0
      XTOTLOG=0.0
      ILOG=0
      ZDERV=0.0
      DO 710 I=1,NP
C
C  GET Wi
C
      SUMI=0.0
      DO 790 K=1,NS
      SUMI=SUMI+XMAT(I,K)*ZVEC(JX,K)
  790 CONTINUE
C
C  IF ONE DIMENSION SET Wi = Xi
C
      IF(NS.EQ.1)SUMI=XMAT(I,1)
C
C
      IF(LDATA(I,JX).EQ.0)GO TO 710
C
C
      KCUT=MCUTS(JX,2)
      LCUT=MCUTS(JX,1)
C
C  Xi TO THE LEFT OF THE MIDPOINT
C
      IF(SUMI.LE.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.KCUT)THEN
            WIMJ=WS(JX)-SUMI
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.KCUT)THEN
            KCHECK=KCHECK+1
            WIMJ=SUMI-WS(JX)
         ENDIF
      ENDIF
C
C  Xi TO THE RIGHT OF THE MIDPOINT
C
      IF(SUMI.GT.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.LCUT)THEN
            WIMJ=SUMI-WS(JX)
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.LCUT)THEN
            KCHECK=KCHECK+1
            WIMJ=WS(JX)-SUMI
         ENDIF
      ENDIF
      WIMJ=WIMJ*2.0*ZGAMMA(JX)*XXGAMMA(I)
      WWIMJ=WIMJ*XDEVIT
      KWIMJ=IFIX(ABS(WWIMJ)+.5)
      IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2
C
C  CORRECTLY CLASSIFIED
C
      IF(WIMJ.GE.0.0)THEN
         CDF=ZDF(NDEVIT-1+KWIMJ+1,2)
         CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3)
         IF(SUMI.GT.WS(JX))THEN
            ZDERV=ZDERV-ZDF(NDEVIT-1+KWIMJ+1,4)*
     C                               2.0*ZGAMMA(JX)*XXGAMMA(I)
         ENDIF
         IF(SUMI.LE.WS(JX))THEN
            ZDERV=ZDERV+ZDF(NDEVIT-1+KWIMJ+1,4)*
     C                               2.0*ZGAMMA(JX)*XXGAMMA(I)
         ENDIF
      ENDIF
C
C  INCORRECTLY CLASSIFIED
C
      IF(WIMJ.LT.0.0)THEN
         CDF=ZDF(NDEVIT-KWIMJ,2)
         CDFLOG=ZDF(NDEVIT-KWIMJ,3)
         IF(SUMI.GT.WS(JX))THEN
            ZDERV=ZDERV+ZDF(NDEVIT-KWIMJ,4)*2.0*ZGAMMA(JX)*XXGAMMA(I)
         ENDIF
         IF(SUMI.LE.WS(JX))THEN
            ZDERV=ZDERV-ZDF(NDEVIT-KWIMJ,4)*2.0*ZGAMMA(JX)*XXGAMMA(I)
         ENDIF
      ENDIF
      ILOG=ILOG+1
      XTOTLOG=XTOTLOG+CDFLOG
C
  710 CONTINUE
      GMP=EXP(XTOTLOG/FLOAT(ILOG))
C      IF(JX.EQ.22)THEN
C      WRITE(26,203)JX,KK,KCHECK,SAVEZMID,WS(JX),XTOTLOG,GMP,ZDERV
C      ENDIF
      YGMP(KK)=GMP
      LLL(KK)=KK
      LCHECK(KK)=KCHECK
      YGAMMA(KK)=WS(JX)
      YLOG(KK)=XTOTLOG
      WS(JX)=WS(JX)+XINC
      IF(KK.GT.1)THEN
C
C  POSITVE - NEGATIVE BRACKETING OF ZERO DERIVATIVE
C
         IF(OLDZDERV.GT.0.0.AND.ZDERV.LT.0.0)THEN
            NNINC=KK
            GO TO 7272
         ENDIF
C
C  NEGATIVE - POSITVE BRACKETING OF ZERO DERIVATIVE
C
         IF(OLDZDERV.LT.0.0.AND.ZDERV.GT.0.0)THEN
            NNINC=KK
            GO TO 7272
         ENDIF
      ENDIF
      OLDZDERV=ZDERV
  712 CONTINUE
      NNINC=NINC
 7272 CONTINUE
      CALL RSORT(YGMP,NNINC,LLL)
      WS(JX)=YGAMMA(LLL(NNINC))
C      WRITE(27,205)JX,LLL(NNINC),LCHECK(LLL(NNINC)),MYES(JX),MNO(JX),
C     C       SAVEZMID,YGAMMA(LLL(NNINC)),YLOG(LLL(NNINC)),YGMP(NNINC)
      IF(SAVELOG.GT.YLOG(LLL(NNINC)))THEN
         YTOTLOG=YTOTLOG+SAVELOG
         KCHECKT=KCHECKT+KCHECKS
         WS(JX)=SAVEZMID
         XRCLOG(JX)=SAVELOG
         KRCLOG(JX)=ILOG
      ENDIF
      IF(SAVELOG.LE.YLOG(LLL(NNINC)))THEN
         YTOTLOG=YTOTLOG+YLOG(LLL(NNINC))
         KCHECKT=KCHECKT+LCHECK(LLL(NNINC))
         KCUT=MCUTS(JX,1)
         LCUT=MCUTS(JX,2)
         MCUTS(JX,1)=LCUT
         MCUTS(JX,2)=KCUT
         XRCLOG(JX)=YLOG(LLL(NNINC))
         KRCLOG(JX)=ILOG
      ENDIF
      ITOTLOG=ITOTLOG+ILOG
  11  CONTINUE
      GMP=EXP(YTOTLOG/FLOAT(ITOTLOG))
C      WRITE(21,202)ITOTLOG,YTOTLOG,GMP
C      WRITE(*,202)ITOTLOG,YTOTLOG,GMP
      WRITE(21,204)KCHECKT,ITOTLOG,YTOTLOG,GMP
      WRITE(*,204)KCHECKT,ITOTLOG,YTOTLOG,GMP
C
      RETURN
      END
C
C
C **************************************************************************
C  SUBROUTINE QUADRPN -- CALCULATES ROLL CALL NORMAL VECTORS FOR THE 
C                          MULTI-DIMENSIONAL QUADRATIC UTILITY MODEL
C                         
C **************************************************************************
C
      SUBROUTINE QUADRPN(NS,NP,NRCALL,MCUTS,XMAT,WS,ZVEC,LDATA,
     C                 ZGAMMA,XXGAMMA,XRCLOG,KRCLOG,ZDF,NDEVIT,XDEVIT)
      DIMENSION XMAT(1960,25),ZVEC(1701,25),XRCLOG(1701),KRCLOG(1701),
     C          LDATA(1960,1701),WS(7398),
     C          MCUTS(1701,2),ZDF(150000,4),
     C          ZLOG(1701),XWIMJ(1960,1701),XXX(25),
     C          MYES(1701),MNO(1701),YGMP(10000),LLL(10000),
     C          YGAMMA(10000,25),YLOG(10000),KLASS(1701),
     C          ZGAMMA(1701),KLEFT(1960,1701),ZDERV(25),
     C          LCHECK(1701),XXGAMMA(1960),SAVEZVEC(25),
     C          ZVEC2(25)
C
  200 FORMAT(3F15.8)
  201 FORMAT(2I5,I2,F12.7,I8,2F15.8)
  202 FORMAT(' LOG-LIKELIHOOD N-VECTOR PHASE           ',I8,F16.5,F9.5)
  203 FORMAT(I5,I4,I7,F12.5,50F9.4)
  204 FORMAT(' LOG-L & CLASS N-VECTOR PHASE    ',2I8,F16.5,F9.5)
  205 FORMAT(I5,I4,3I4,F12.5,50F9.4)
  206 FORMAT(5I6)
 1109 FORMAT(' INITIAL CLASS. N-VECTOR PHASE   ',I3,8I8)
C
C
      XTOTLOG=0.0
      KTOT=0
      KCHECK=0
      KCHECK3=0
      KCHECK33=0
      KCHECK333=0
      DO 881 JX=1,NRCALL
C
      KLASS(JX)=0
      ZLOG(JX)=0.0
      ILOG=0
      KYES=0
      KNO=0
      DO 882 I=1,NP
      KLEFT(I,JX)=0
      IF(LDATA(I,JX).EQ.1)KYES=KYES+1
      IF(LDATA(I,JX).EQ.6)KNO=KNO+1
      IWRONG=0
C
C  GET Wi
C
      SUMI=0.0
      DO 90 K=1,NS
      SUMI=SUMI+XMAT(I,K)*ZVEC(JX,K)
  90  CONTINUE
C
C  IF ONE DIMENSION SET Wi = Xi
C
      IF(NS.EQ.1)SUMI=XMAT(I,1)
C
      KCUT=MCUTS(JX,1)
      LCUT=MCUTS(JX,2)
      IF(LDATA(I,JX).EQ.0)GO TO 882
C
C  Xi TO THE LEFT OF THE MIDPOINT
C
      IF(SUMI.LE.WS(JX))THEN
         KLEFT(I,JX)=1
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.KCUT)THEN
            WIMJ=WS(JX)-SUMI
            XWIMJ(I,JX)=WIMJ
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.KCUT)THEN
            KCHECK=KCHECK+1
            IF(ABS(SUMI-WS(JX)).GT..001)KCHECK33=KCHECK33+1
            WIMJ=SUMI-WS(JX)
            XWIMJ(I,JX)=WIMJ
            IWRONG=1
            KLASS(JX)=KLASS(JX)+1
         ENDIF
      ENDIF
C
C  Xi TO THE RIGHT OF THE MIDPOINT
C
      IF(SUMI.GT.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.LCUT)THEN
            WIMJ=SUMI-WS(JX)
            XWIMJ(I,JX)=WIMJ
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.LCUT)THEN
            KCHECK=KCHECK+1
            IF(ABS(SUMI-WS(JX)).GT..001)KCHECK33=KCHECK33+1
            WIMJ=WS(JX)-SUMI
            XWIMJ(I,JX)=WIMJ
            IWRONG=1
            KLASS(JX)=KLASS(JX)+1
         ENDIF
      ENDIF
      WIMJ=WIMJ*2.0*ZGAMMA(JX)*XXGAMMA(I)
      WWIMJ=WIMJ*XDEVIT
      KWIMJ=IFIX(ABS(WWIMJ)+.5)
      IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2
      IF(WIMJ.GE.0.0)THEN
         CDF=ZDF(NDEVIT-1+KWIMJ+1,2)
         CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3)
      ENDIF
      IF(WIMJ.LT.0.0)THEN
         CDF=ZDF(NDEVIT-KWIMJ,2)
         CDFLOG=ZDF(NDEVIT-KWIMJ,3)
      ENDIF
      IF(WIMJ.LT.0.0)KCHECK333=KCHECK333+1
      ZLOG(JX)=ZLOG(JX)+CDFLOG
      ILOG=ILOG+1
      KTOT=KTOT+1
      XTOTLOG=XTOTLOG+CDFLOG
  882 CONTINUE
      MYES(JX)=KYES
      MNO(JX)=KNO
C      WRITE(26,206)JX,MYES(JX),MNO(JX),KLASS(JX),ILOG
C      WRITE(*,206)JX,MYES(JX),MNO(JX),KLASS(JX),ILOG
      GMP=EXP(ZLOG(JX)/FLOAT(ILOG))
C      WRITE(26,202)JX,ZLOG(JX),GMP
  881 CONTINUE
      GMP=EXP(XTOTLOG/FLOAT(KTOT))
      WRITE(23,202)KTOT,XTOTLOG,GMP
C      WRITE(*,202)KTOT,XTOTLOG,GMP
      WRITE(23,1109)NS,KCHECK,KCHECK33,KCHECK333
C      WRITE(* ,1109)NS,KCHECK,KCHECK33,KCHECK333
C
C
C  CALCULATE NEW ROLL CALL NORMAL VECTOR WITH A 
C      SIMPLE GRID SEARCH
C
C     INITIALIZE
C
      YTOTLOG=0.0
      ITOTLOG=0
      KCHECKT=0
      NINC=10
      DO 11 JX=1,NRCALL
C
      DO 99 IIII=1,10
C
      DO 40 K=1,NS
      SAVEZVEC(K)=ZVEC(JX,K)
      ZVEC2(K)=ZVEC(JX,K)
      ZDERV(K)=0.0
  40  CONTINUE
C
      KCHECK=0
      XTOTLOG=0.0
      ILOG=0
      DO 10 I=1,NP
C
C  GET Wi
C
      SUMI=0.0
      DO 290 K=1,NS
      SUMI=SUMI+XMAT(I,K)*ZVEC2(K)
  290 CONTINUE
C
C  IF ONE DIMENSION SET Wi = Xi
C
      IF(NS.EQ.1)SUMI=XMAT(I,1)
C
C
      IF(LDATA(I,JX).EQ.0)GO TO 10
C
C
      KCUT=MCUTS(JX,1)
      LCUT=MCUTS(JX,2)
C
C  Xi TO THE LEFT OF THE MIDPOINT
C
      IF(SUMI.LE.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.KCUT)THEN
            WIMJ=WS(JX)-SUMI
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.KCUT)THEN
            KCHECK=KCHECK+1
            WIMJ=SUMI-WS(JX)
         ENDIF
      ENDIF
C
C  Xi TO THE RIGHT OF THE MIDPOINT
C
      IF(SUMI.GT.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.LCUT)THEN
            WIMJ=SUMI-WS(JX)
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.LCUT)THEN
            KCHECK=KCHECK+1
            WIMJ=WS(JX)-SUMI
         ENDIF
      ENDIF
      WIMJ=WIMJ*2.0*ZGAMMA(JX)*XXGAMMA(I)
      WWIMJ=WIMJ*XDEVIT
      KWIMJ=IFIX(ABS(WWIMJ)+.5)
      IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2
C
C  CORRECTLY CLASSIFIED
C
      IF(WIMJ.GE.0.0)THEN
         CDF=ZDF(NDEVIT-1+KWIMJ+1,2)
         CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3)
         DO 51 K=1,NS
         IF(SUMI.GT.WS(JX))THEN
            ZDERV(K)=ZDERV(K)+ZDF(NDEVIT-1+KWIMJ+1,4)*
     C                      2.0*ZGAMMA(JX)*XXGAMMA(I)*
     C                      (XMAT(I,K)-WS(JX)*ZVEC2(K))
         ENDIF
         IF(SUMI.LE.WS(JX))THEN
            ZDERV(K)=ZDERV(K)-ZDF(NDEVIT-1+KWIMJ+1,4)*
     C                      2.0*ZGAMMA(JX)*XXGAMMA(I)*
     C                      (XMAT(I,K)-WS(JX)*ZVEC2(K))
         ENDIF
  51     CONTINUE
      ENDIF
C
C  INCORRECTLY CLASSIFIED
C
      IF(WIMJ.LT.0.0)THEN
         CDF=ZDF(NDEVIT-KWIMJ,2)
         CDFLOG=ZDF(NDEVIT-KWIMJ,3)
         DO 52 K=1,NS
         IF(SUMI.GT.WS(JX))THEN
            ZDERV(K)=ZDERV(K)-ZDF(NDEVIT-KWIMJ,4)*2.0*ZGAMMA(JX)*
     C                      XXGAMMA(I)*(XMAT(I,K)-WS(JX)*ZVEC2(K))
         ENDIF
         IF(SUMI.LE.WS(JX))THEN
            ZDERV(K)=ZDERV(K)+ZDF(NDEVIT-KWIMJ,4)*2.0*ZGAMMA(JX)*
     C                      XXGAMMA(I)*(XMAT(I,K)-WS(JX)*ZVEC2(K))
         ENDIF
  52     CONTINUE
      ENDIF
      ILOG=ILOG+1
      XTOTLOG=XTOTLOG+CDFLOG
C
  10  CONTINUE
      GMP=EXP(XTOTLOG/FLOAT(ILOG))
      DO 751 K=1,NS
      XXX(K)=ZDERV(K)/FLOAT(ILOG)
  751 CONTINUE
C      WRITE(28,203)JX,JX,KCHECK,XTOTLOG,GMP,(SAVEZVEC(K),K=1,NS),
C     C             (ZVEC2(K),K=1,NS),WS(JX),
C     C             (ZDERV(K),K=1,NS)
C
C  STEP THE NORMAL VECTOR ALONG THE SURFACE OF THE UNIT HYPERSPHERE
C    IN THE DIRECTION OF THE FIRST DERIVATIVE
C
C      CALCULATE THE STEPSIZE SO THAT IT IS IN .01 UNITS
C
      SUM=0.0
      DO 62 K=1,NS
      ZVEC2(K)=ZVEC(JX,K)+XXX(K)
      SUM=SUM+ZVEC2(K)**2
  62  CONTINUE
      DRIM=0.0
      DO 63 K=1,NS
      ZVEC2(K)=ZVEC2(K)/SQRT(SUM)
      DRIM=DRIM+(ZVEC(JX,K)-ZVEC2(K))**2
  63  CONTINUE
      DRIM=SQRT(DRIM)
      STEP=(.01)/DRIM
C
      XINC=0.0
C
      DO 12 KK=1,NINC
C
      SUM=0.0
      DO 60 K=1,NS
      ZDERV(K)=0.0
      ZVEC2(K)=ZVEC(JX,K)+XINC*XXX(K)
      SUM=SUM+ZVEC2(K)**2
  60  CONTINUE
C
C  NORMALIZE VECTOR SO THAT N'N = 1
C
      DO 61 K=1,NS
      ZVEC2(K)=ZVEC2(K)/SQRT(SUM)
  61  CONTINUE
      KCHECK=0
      XTOTLOG=0.0
      ILOG=0
      DO 610 I=1,NP
C
C  GET Wi
C
      SUMI=0.0
      DO 790 K=1,NS
      SUMI=SUMI+XMAT(I,K)*ZVEC2(K)
  790 CONTINUE
C
C  IF ONE DIMENSION SET Wi = Xi
C
      IF(NS.EQ.1)SUMI=XMAT(I,1)
C
C
      IF(LDATA(I,JX).EQ.0)GO TO 610
C
C
      KCUT=MCUTS(JX,1)
      LCUT=MCUTS(JX,2)
C
C  Xi TO THE LEFT OF THE MIDPOINT
C
      IF(SUMI.LE.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.KCUT)THEN
            WIMJ=WS(JX)-SUMI
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.KCUT)THEN
            KCHECK=KCHECK+1
            WIMJ=SUMI-WS(JX)
         ENDIF
      ENDIF
C
C  Xi TO THE RIGHT OF THE MIDPOINT
C
      IF(SUMI.GT.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.LCUT)THEN
            WIMJ=SUMI-WS(JX)
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.LCUT)THEN
            KCHECK=KCHECK+1
            WIMJ=WS(JX)-SUMI
         ENDIF
      ENDIF
      WIMJ=WIMJ*2.0*ZGAMMA(JX)*XXGAMMA(I)
      WWIMJ=WIMJ*XDEVIT
      KWIMJ=IFIX(ABS(WWIMJ)+.5)
      IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2
C
C  CORRECTLY CLASSIFIED
C
      IF(WIMJ.GE.0.0)THEN
         CDF=ZDF(NDEVIT-1+KWIMJ+1,2)
         CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3)
         DO 651 K=1,NS
         IF(SUMI.GT.WS(JX))THEN
            ZDERV(K)=ZDERV(K)+ZDF(NDEVIT-1+KWIMJ+1,4)*
     C                      2.0*ZGAMMA(JX)*XXGAMMA(I)*
     C                      (XMAT(I,K)-WS(JX)*ZVEC2(K))
         ENDIF
         IF(SUMI.LE.WS(JX))THEN
            ZDERV(K)=ZDERV(K)-ZDF(NDEVIT-1+KWIMJ+1,4)*
     C                      2.0*ZGAMMA(JX)*XXGAMMA(I)*
     C                      (XMAT(I,K)-WS(JX)*ZVEC2(K))
         ENDIF
  651    CONTINUE
      ENDIF
C
C  INCORRECTLY CLASSIFIED
C
      IF(WIMJ.LT.0.0)THEN
         CDF=ZDF(NDEVIT-KWIMJ,2)
         CDFLOG=ZDF(NDEVIT-KWIMJ,3)
         DO 652 K=1,NS
         IF(SUMI.GT.WS(JX))THEN
            ZDERV(K)=ZDERV(K)-ZDF(NDEVIT-KWIMJ,4)*2.0*ZGAMMA(JX)*
     C                      XXGAMMA(I)*(XMAT(I,K)-WS(JX)*ZVEC2(K))
         ENDIF
         IF(SUMI.LE.WS(JX))THEN
            ZDERV(K)=ZDERV(K)+ZDF(NDEVIT-KWIMJ,4)*2.0*ZGAMMA(JX)*
     C                      XXGAMMA(I)*(XMAT(I,K)-WS(JX)*ZVEC2(K))
         ENDIF
  652    CONTINUE
      ENDIF
      ILOG=ILOG+1
      XTOTLOG=XTOTLOG+CDFLOG
C
  610 CONTINUE
      GMP=EXP(XTOTLOG/FLOAT(ILOG))
C      WRITE(28,203)JX,KK,KCHECK,XTOTLOG,GMP,(SAVEZVEC(K),K=1,NS),
C     C             (ZVEC2(K),K=1,NS),WS(JX),
C     C             (ZDERV(K),K=1,NS)
C
      YGMP(KK)=GMP
      LLL(KK)=KK
      LCHECK(KK)=KCHECK
      DO 66 K=1,NS
      YGAMMA(KK,K)=ZVEC2(K)
  66  CONTINUE
      YLOG(KK)=XTOTLOG
      XINC=XINC+STEP
  12  CONTINUE
      NNINC=NINC
 1212 CONTINUE
      CALL RSORT(YGMP,NNINC,LLL)
      DO 67 K=1,NS
      ZVEC(JX,K)=YGAMMA(LLL(NNINC),K)
  67  CONTINUE
C      WRITE(27,205)JX,LLL(NNINC),LCHECK(LLL(NNINC)),MYES(JX),MNO(JX),
C     C        YLOG(LLL(NNINC)),YGMP(NNINC),
C     C       (SAVEZVEC(K),K=1,NS),(YGAMMA(LLL(NNINC),K),K=1,NS)
      DO 851 K=1,NS
      XXX(K)=ZDERV(K)/FLOAT(ILOG)
  851 CONTINUE
C
  99  CONTINUE
C
      YTOTLOG=YTOTLOG+YLOG(LLL(NNINC))
      KCHECKT=KCHECKT+LCHECK(LLL(NNINC))
      ITOTLOG=ITOTLOG+ILOG
      XRCLOG(JX)=YLOG(LLL(NNINC))
      KRCLOG(JX)=ILOG
  11  CONTINUE
      GMP=EXP(YTOTLOG/FLOAT(ITOTLOG))
C      WRITE(21,202)ITOTLOG,YTOTLOG,GMP
C      WRITE(*,202)ITOTLOG,YTOTLOG,GMP
      WRITE(21,204)KCHECKT,ITOTLOG,YTOTLOG,GMP
      WRITE(*,204)KCHECKT,ITOTLOG,YTOTLOG,GMP
C
      RETURN
      END
C
C
C **************************************************************************
C  SUBROUTINE QUADRPS -- CALCULATES ESTIMATES OF THE (2*GAMMAj)/SIGMAj TERMS
C                         FOR THE QUADRATIC UTILITY MODEL
C                         
C **************************************************************************
C
      SUBROUTINE QUADRPS(NS,NP,NRCALL,MCUTS,XMAT,WS,ZVEC,LDATA,
     C                    ZGAMMA,XXGAMMA,ZDF,NDEVIT,XDEVIT)
      DIMENSION XMAT(1960,25),ZVEC(1701,25),
     C          LDATA(1960,1701),WS(7398),
     C          MCUTS(1701,2),ZDF(150000,4),
     C          ZLOG(1701),XWIMJ(1960,1701),
     C          MYES(1701),MNO(1701),YGMP(10000),LLL(10000),
     C          YGAMMA(10000),YLOG(10000),KLASS(1701),
     C          ZGAMMA(1701),KLEFT(1960,1701),XXGAMMA(1960)
C
  200 FORMAT(3F15.8)
  201 FORMAT(2I5,I2,F12.7,I8,2F15.8)
  202 FORMAT(I8,2F16.5)
  203 FORMAT(I5,3I4,I7,3F12.5,3I5,3F8.4,F12.5)
  204 FORMAT(I5,3I4,I7,4F12.5)
  301 FORMAT(' PRELIMINARY LOG-LIKELIHOOD              ',I8,F16.5,F9.5)
  302 FORMAT(' LOG-LIKELIHOOD 2D/SIGMA PHASE           ',I8,F16.5,F9.5)
  303 FORMAT(' LOG-LIKELIHOOD PARTY PROBABILITIES PHASE',I8,F16.5,F9.5)
 1109 FORMAT(' INITIAL CLASSIFICATION RESULTS  ',I3,8I8)
C
C
C
C  GET ESTIMATES OF THE (2*GAMMAj)/SIGMAj TERMS
C
C
      XTOTLOG=0.0
      KTOT=0
      KCHECK=0
      KCHECK3=0
      KCHECK33=0
      KCHECK333=0
      DO 881 JX=1,NRCALL
C
      KLASS(JX)=0
      ZLOG(JX)=0.0
      ILOG=0
      KYES=0
      KNO=0
      DO 882 I=1,NP
      KLEFT(I,JX)=0
      IF(LDATA(I,JX).EQ.1)KYES=KYES+1
      IF(LDATA(I,JX).EQ.6)KNO=KNO+1
      IWRONG=0
C
C  GET Wi
C
      SUMI=0.0
      DO 90 K=1,NS
      SUMI=SUMI+XMAT(I,K)*ZVEC(JX,K)
  90  CONTINUE
C
C  IF ONE DIMENSION SET Wi = Xi
C
      IF(NS.EQ.1)SUMI=XMAT(I,1)
C
      KCUT=MCUTS(JX,1)
      LCUT=MCUTS(JX,2)
      IF(LDATA(I,JX).EQ.0)GO TO 882
C
C  Xi TO THE LEFT OF THE MIDPOINT
C
      IF(SUMI.LE.WS(JX))THEN
         KLEFT(I,JX)=1
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.KCUT)THEN
            WIMJ=WS(JX)-SUMI
            XWIMJ(I,JX)=WIMJ
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.KCUT)THEN
            KCHECK=KCHECK+1
            IF(ABS(SUMI-WS(JX)).GT..001)KCHECK33=KCHECK33+1
            WIMJ=SUMI-WS(JX)
            XWIMJ(I,JX)=WIMJ
            IWRONG=1
            KLASS(JX)=KLASS(JX)+1
         ENDIF
      ENDIF
C
C  Xi TO THE RIGHT OF THE MIDPOINT
C
      IF(SUMI.GT.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.LCUT)THEN
            WIMJ=SUMI-WS(JX)
            XWIMJ(I,JX)=WIMJ
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.LCUT)THEN
            KCHECK=KCHECK+1
            IF(ABS(SUMI-WS(JX)).GT..001)KCHECK33=KCHECK33+1
            WIMJ=WS(JX)-SUMI
            XWIMJ(I,JX)=WIMJ
            IWRONG=1
            KLASS(JX)=KLASS(JX)+1
         ENDIF
      ENDIF
      WWIMJ=WIMJ*XDEVIT
      KWIMJ=IFIX(ABS(WWIMJ)+.5)
      IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2
      IF(WIMJ.GE.0.0)THEN
         CDF=ZDF(NDEVIT-1+KWIMJ+1,2)
         CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3)
      ENDIF
      IF(WIMJ.LT.0.0)THEN
         CDF=ZDF(NDEVIT-KWIMJ,2)
         CDFLOG=ZDF(NDEVIT-KWIMJ,3)
      ENDIF
C      WRITE(23,201)JX,I,IWRONG,WIMJ,KWIMJ,CDF,CDFLOG
      IF(WIMJ.LT.0.0)KCHECK333=KCHECK333+1
      ZLOG(JX)=ZLOG(JX)+CDFLOG
      ILOG=ILOG+1
      KTOT=KTOT+1
      XTOTLOG=XTOTLOG+CDFLOG
  882 CONTINUE
      MYES(JX)=KYES
      MNO(JX)=KNO
      GMP=EXP(ZLOG(JX)/FLOAT(ILOG))
C      WRITE(26,202)JX,ZLOG(JX),GMP
  881 CONTINUE
      GMP=EXP(XTOTLOG/FLOAT(KTOT))
C      WRITE(26,301)KTOT,XTOTLOG,GMP
C      WRITE(*,301)KTOT,XTOTLOG,GMP
      WRITE(23,1109)NS,KCHECK,KCHECK33,KCHECK333
C      WRITE(* ,1109)NS,KCHECK,KCHECK33,KCHECK333
C
C  CALCULATE GAMMA/VARIANCE PARAMETERS
C
      XINC=0.02
      NINC=300
      XTOTLOG=0.0
      DO 10 JX=1,NRCALL
      XGAMMA=0.5
C
      DO 12 KK=1,NINC
      ZLOG(JX)=0.0
      ZDERV=0.0
      ILOG=0
      KCHECK333=0
      DO 11 I=1,NP
      IF(LDATA(I,JX).EQ.0)GO TO 11
      WIMJ=XWIMJ(I,JX)*2.0*XGAMMA*XXGAMMA(I)
      WWIMJ=WIMJ*XDEVIT
      KWIMJ=IFIX(ABS(WWIMJ)+.5)
      IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2
      IF(WIMJ.GE.0.0)THEN
         CDF=ZDF(NDEVIT-1+KWIMJ+1,2)
         CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3)
         ZDERV=ZDERV+ZDF(NDEVIT-1+KWIMJ+1,4)*XWIMJ(I,JX)*XXGAMMA(I)
      ENDIF
      IF(WIMJ.LT.0.0)THEN
         KCHECK333=KCHECK333+1
         CDF=ZDF(NDEVIT-KWIMJ,2)
         CDFLOG=ZDF(NDEVIT-KWIMJ,3)
         ZDERV=ZDERV+ZDF(NDEVIT-KWIMJ,4)*XWIMJ(I,JX)*XXGAMMA(I)
      ENDIF
      ZLOG(JX)=ZLOG(JX)+CDFLOG
      ILOG=ILOG+1
  11  CONTINUE
      GMP=EXP(ZLOG(JX)/FLOAT(ILOG))
C      WRITE(28,204)JX,MYES(JX),MNO(JX),KCHECK333,KK,XGAMMA,ZLOG(JX),
C     C                 GMP,ZDERV
      YGMP(KK)=GMP
      LLL(KK)=KK
      YGAMMA(KK)=XGAMMA
      YLOG(KK)=ZLOG(JX)
      XGAMMA=XGAMMA+XINC
      IF(KK.GT.1)THEN
C
C  POSITVE - NEGATIVE BRACKETING OF ZERO DERIVATIVE
C
         IF(OLDZDERV.GT.0.0.AND.ZDERV.LT.0.0)THEN
            NNINC=KK
            GO TO 1212
         ENDIF
C
C  NEGATIVE - POSITVE BRACKETING OF ZERO DERIVATIVE
C
         IF(OLDZDERV.LT.0.0.AND.ZDERV.GT.0.0)THEN
            NNINC=KK
            GO TO 1212
         ENDIF
      ENDIF
      OLDZDERV=ZDERV
  12  CONTINUE
      NNINC=NINC
 1212 CONTINUE
      CALL RSORT(YGMP,NNINC,LLL)
      ZGAMMA(JX)=YGAMMA(LLL(NNINC))
C      WRITE(26,203)JX,MYES(JX),MNO(JX),KCHECK333,LLL(NNINC),
C     C                YGAMMA(LLL(NNINC)),YLOG(LLL(NNINC)),YGMP(NNINC)
C      WRITE(27,203)JX,MYES(JX),MNO(JX),KCHECK333,LLL(NNINC),
C     C                YGAMMA(LLL(NNINC)),YLOG(LLL(NNINC)),YGMP(NNINC)
      XTOTLOG=XTOTLOG+YLOG(LLL(NNINC))
      GO TO 10
  10  CONTINUE
      GMP=EXP(XTOTLOG/FLOAT(KTOT))
      WRITE(21,302)KTOT,XTOTLOG,GMP
      WRITE(*,302)KTOT,XTOTLOG,GMP
C
      RETURN
      END
C
C
C **************************************************************************
C  SUBROUTINE QUADRPSL -- CALCULATES ESTIMATES OF THE SIGMAi TERMS
C                         FOR THE QUADRATIC UTILITY MODEL
C                         
C **************************************************************************
C
      SUBROUTINE QUADRPSL(NS,NP,NRCALL,MCUTS,XMAT,WS,ZVEC,LDATA,
     C                    ZGAMMA,XXGAMMA,ZDF,NDEVIT,XDEVIT)
      DIMENSION XMAT(1960,25),ZVEC(1701,25),
     C          LDATA(1960,1701),WS(7398),
     C          MCUTS(1701,2),ZDF(150000,4),
     C          ZLOG(1701),XWIMJ(1960,1701),
     C          MYES(1701),MNO(1701),YGMP(10000),LLL(10000),
     C          YGAMMA(10000),YLOG(10000),KLASS(1701),
     C          ZGAMMA(1701),KLEFT(1960,1701),XXGAMMA(1960)
C
  200 FORMAT(3F15.8)
  201 FORMAT(2I5,I2,F12.7,I8,2F15.8)
  202 FORMAT(I8,2F16.5)
  203 FORMAT(I5,I4,3F12.5,3I5,3F8.4,F12.5)
  204 FORMAT(I5,I4,4F12.5)
  301 FORMAT(' PRELIMINARY LOG-LIKELIHOOD              ',I8,F16.5,F9.5)
  302 FORMAT(' LOG-LIKELIHOOD SIGMAi PHASE             ',I8,F16.5,F9.5)
 1109 FORMAT(' INITIAL CLASSIFICATION RESULTS  ',I3,8I8)
C
C
C
C  GET ESTIMATES OF THE (2*GAMMAj)/SIGMAj TERMS
C
C
      XTOTLOG=0.0
      KTOT=0
      KCHECK=0
      KCHECK3=0
      KCHECK33=0
      KCHECK333=0
      DO 881 JX=1,NRCALL
C
      KLASS(JX)=0
      ZLOG(JX)=0.0
      ILOG=0
      KYES=0
      KNO=0
      DO 882 I=1,NP
      KLEFT(I,JX)=0
      IF(LDATA(I,JX).EQ.1)KYES=KYES+1
      IF(LDATA(I,JX).EQ.6)KNO=KNO+1
      IWRONG=0
C
C  GET Wi
C
      SUMI=0.0
      DO 90 K=1,NS
      SUMI=SUMI+XMAT(I,K)*ZVEC(JX,K)
  90  CONTINUE
C
C  IF ONE DIMENSION SET Wi = Xi
C
      IF(NS.EQ.1)SUMI=XMAT(I,1)
C
      KCUT=MCUTS(JX,1)
      LCUT=MCUTS(JX,2)
      IF(LDATA(I,JX).EQ.0)GO TO 882
C
C  Xi TO THE LEFT OF THE MIDPOINT
C
      IF(SUMI.LE.WS(JX))THEN
         KLEFT(I,JX)=1
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.KCUT)THEN
            WIMJ=WS(JX)-SUMI
            XWIMJ(I,JX)=WIMJ
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.KCUT)THEN
            KCHECK=KCHECK+1
            IF(ABS(SUMI-WS(JX)).GT..001)KCHECK33=KCHECK33+1
            WIMJ=SUMI-WS(JX)
            XWIMJ(I,JX)=WIMJ
            IWRONG=1
            KLASS(JX)=KLASS(JX)+1
         ENDIF
      ENDIF
C
C  Xi TO THE RIGHT OF THE MIDPOINT
C
      IF(SUMI.GT.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.LCUT)THEN
            WIMJ=SUMI-WS(JX)
            XWIMJ(I,JX)=WIMJ
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.LCUT)THEN
            KCHECK=KCHECK+1
            IF(ABS(SUMI-WS(JX)).GT..001)KCHECK33=KCHECK33+1
            WIMJ=WS(JX)-SUMI
            XWIMJ(I,JX)=WIMJ
            IWRONG=1
            KLASS(JX)=KLASS(JX)+1
         ENDIF
      ENDIF
      WWIMJ=WIMJ*XDEVIT
      KWIMJ=IFIX(ABS(WWIMJ)+.5)
      IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2
      IF(WIMJ.GE.0.0)THEN
         CDF=ZDF(NDEVIT-1+KWIMJ+1,2)
         CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3)
      ENDIF
      IF(WIMJ.LT.0.0)THEN
         CDF=ZDF(NDEVIT-KWIMJ,2)
         CDFLOG=ZDF(NDEVIT-KWIMJ,3)
      ENDIF
C      WRITE(23,201)JX,I,IWRONG,WIMJ,KWIMJ,CDF,CDFLOG
      IF(WIMJ.LT.0.0)KCHECK333=KCHECK333+1
      ZLOG(JX)=ZLOG(JX)+CDFLOG
      ILOG=ILOG+1
      KTOT=KTOT+1
      XTOTLOG=XTOTLOG+CDFLOG
  882 CONTINUE
      MYES(JX)=KYES
      MNO(JX)=KNO
      GMP=EXP(ZLOG(JX)/FLOAT(ILOG))
C      WRITE(26,202)JX,ZLOG(JX),GMP
  881 CONTINUE
      GMP=EXP(XTOTLOG/FLOAT(KTOT))
C      WRITE(26,301)KTOT,XTOTLOG,GMP
C      WRITE(*,301)KTOT,XTOTLOG,GMP
      WRITE(23,1109)NS,KCHECK,KCHECK33,KCHECK333
C      WRITE(* ,1109)NS,KCHECK,KCHECK33,KCHECK333
C
C  CALCULATE VARIANCE PARAMETER FOR LEGISLATORS
C
      XINC=0.02
      NINC=300
      XTOTLOG=0.0
      DO 10 I=1,NP
      XGAMMA=0.1
C
      DO 12 KK=1,NINC
      ZLOG(I)=0.0
      ZDERV=0.0
      ILOG=0
      KCHECK333=0
      DO 11 JX=1,NRCALL
      IF(LDATA(I,JX).EQ.0)GO TO 11
      WIMJ=XWIMJ(I,JX)*2.0*ZGAMMA(JX)*XGAMMA
      WWIMJ=WIMJ*XDEVIT
      KWIMJ=IFIX(ABS(WWIMJ)+.5)
      IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2
      IF(WIMJ.GE.0.0)THEN
         CDF=ZDF(NDEVIT-1+KWIMJ+1,2)
         CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3)
         ZDERV=ZDERV+ZDF(NDEVIT-1+KWIMJ+1,4)*XWIMJ(I,JX)*2.0*ZGAMMA(JX)
      ENDIF
      IF(WIMJ.LT.0.0)THEN
         KCHECK333=KCHECK333+1
         CDF=ZDF(NDEVIT-KWIMJ,2)
         CDFLOG=ZDF(NDEVIT-KWIMJ,3)
         ZDERV=ZDERV+ZDF(NDEVIT-KWIMJ,4)*XWIMJ(I,JX)*2.0*ZGAMMA(JX)
      ENDIF
      ZLOG(I)=ZLOG(I)+CDFLOG
      ILOG=ILOG+1
  11  CONTINUE
      GMP=EXP(ZLOG(I)/FLOAT(ILOG))
C      WRITE(28,204)I,KK,XGAMMA,ZLOG(I),
C     C                 GMP,ZDERV
      YGMP(KK)=GMP
      LLL(KK)=KK
      YGAMMA(KK)=XGAMMA
      YLOG(KK)=ZLOG(I)
      XGAMMA=XGAMMA+XINC
      IF(KK.GT.1)THEN
C
C  POSITVE - NEGATIVE BRACKETING OF ZERO DERIVATIVE
C
         IF(OLDZDERV.GT.0.0.AND.ZDERV.LT.0.0)THEN
            NNINC=KK
            GO TO 1212
         ENDIF
C
C  NEGATIVE - POSITVE BRACKETING OF ZERO DERIVATIVE
C
         IF(OLDZDERV.LT.0.0.AND.ZDERV.GT.0.0)THEN
            NNINC=KK
            GO TO 1212
         ENDIF
      ENDIF
      OLDZDERV=ZDERV
  12  CONTINUE
      NNINC=NINC
 1212 CONTINUE
      CALL RSORT(YGMP,NNINC,LLL)
      XXGAMMA(I)=YGAMMA(LLL(NNINC))
C      WRITE(26,203)I,LLL(NNINC),
C     C                YGAMMA(LLL(NNINC)),YLOG(LLL(NNINC)),YGMP(NNINC)
      XTOTLOG=XTOTLOG+YLOG(LLL(NNINC))
  10  CONTINUE
      GMP=EXP(XTOTLOG/FLOAT(KTOT))
      WRITE(21,302)KTOT,XTOTLOG,GMP
      WRITE(*,302)KTOT,XTOTLOG,GMP
C
      RETURN
      END
C
C
C **************************************************************************
C  SUBROUTINE CLASSIFY -- CALCULATES CORRECT CLASSIFICATION
C                         FOR THE QUADRATIC UTILITY MODEL
C                         
C **************************************************************************
C
      SUBROUTINE CLASSIFY(NS,NP,NRCALL,MCUTS,XMAT,WS,ZVEC,LDATA,
     C                    KLASSL,KLASSRC)
      DIMENSION XMAT(1960,25),ZVEC(1701,25),
     C          LDATA(1960,1701),WS(7398),
     C          MCUTS(1701,2),
     C          KLASSL(1701,2),KLASSRC(1701,2)
C
  100 FORMAT(' CLASSIFICATION CHECK AT CONVERGENCE',/4I7,2F8.4)
C
      DO 1 I=1,1701
      KLASSL(I,1)=0
      KLASSRC(I,1)=0
      KLASSL(I,2)=0
      KLASSRC(I,2)=0
  1   CONTINUE
C
      KCHECKR=0
      KCHECKW=0
      KTOT=0
      KPRE=0
      KTSUM=0
      DO 881 JX=1,NRCALL
      KYES=0
      KNO=0
C
      DO 882 I=1,NP
      IF(LDATA(I,JX).EQ.1)KYES=KYES+1
      IF(LDATA(I,JX).EQ.6)KNO=KNO+1
C
C  GET Wi
C
      SUMI=0.0
      DO 90 K=1,NS
      SUMI=SUMI+XMAT(I,K)*ZVEC(JX,K)
  90  CONTINUE
C
C  IF ONE DIMENSION SET Wi = Xi
C
      IF(NS.EQ.1)SUMI=XMAT(I,1)
C
      KCUT=MCUTS(JX,1)
      LCUT=MCUTS(JX,2)
      IF(LDATA(I,JX).EQ.0)GO TO 882
C
C  Xi TO THE LEFT OF THE MIDPOINT
C
      IF(SUMI.LE.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.KCUT)THEN
            KCHECKR=KCHECKR+1
            KLASSRC(JX,1)=KLASSRC(JX,1)+1
            KLASSL(I,1)=KLASSL(I,1)+1
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.KCUT)THEN
            KCHECKW=KCHECKW+1
            KLASSRC(JX,2)=KLASSRC(JX,2)+1
            KLASSL(I,2)=KLASSL(I,2)+1
         ENDIF
      ENDIF
C
C  Xi TO THE RIGHT OF THE MIDPOINT
C
      IF(SUMI.GT.WS(JX))THEN
C
C  CORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).EQ.LCUT)THEN
            KCHECKR=KCHECKR+1
            KLASSRC(JX,1)=KLASSRC(JX,1)+1
            KLASSL(I,1)=KLASSL(I,1)+1
         ENDIF
C
C  INCORRECT CLASSIFICATION
C
         IF(LDATA(I,JX).NE.LCUT)THEN
            KCHECKW=KCHECKW+1
            KLASSRC(JX,2)=KLASSRC(JX,2)+1
            KLASSL(I,2)=KLASSL(I,2)+1
         ENDIF
      ENDIF
      KTOT=KTOT+1
  882 CONTINUE
      KTSUM=KTSUM+KYES+KNO
      KYESNO=AMIN0(KYES,KNO)
      KPRE=KPRE+KYESNO
  881 CONTINUE
      XCOR=FLOAT(KCHECKR)/FLOAT(KCHECKR+KCHECKW)
      XPRE=FLOAT(KPRE-KCHECKW)/FLOAT(KPRE)
C      WRITE( *,100)KCHECKR,KCHECKW,KCHECKR+KCHECKW,KTOT,
C     C             KTSUM,KPRE,XCOR,XPRE
C      WRITE(21,100)KCHECKR,KCHECKW,KCHECKR+KCHECKW,KTOT,
C     C             KTSUM,KPRE,XCOR,XPRE
      WRITE( *,100)KCHECKR,KCHECKW,KCHECKR+KCHECKW,
     C             KPRE,XCOR,XPRE
      WRITE(21,100)KCHECKR,KCHECKW,KCHECKR+KCHECKW,
     C             KPRE,XCOR,XPRE
      RETURN
      END
C
C
C  **************************************************************************
C    EIGENVECTOR/EIGENVALUE DECOMPOSITION SUBROUTINES FOR A SYMMETRIC MATRIX
C    SUBROUTINES ARE FROM EISPACK
C  **************************************************************************
C
      SUBROUTINE RS(NM,N,A,W,MATZ,Z,FV1,FV2,IERR)
C
      INTEGER N,NM,IERR,MATZ
      REAL A(NM,N),W(N),Z(NM,N),FV1(N),FV2(N)
C
C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
C     OF A REAL SYMMETRIC MATRIX.
C
C     ON INPUT
C
C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C        DIMENSION STATEMENT.
C
C        N  IS THE ORDER OF THE MATRIX  A.
C
C        A  CONTAINS THE REAL SYMMETRIC MATRIX.
C
C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
C
C     ON OUTPUT
C
C        W  CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
C
C        Z  CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
C
C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT
C           AND TQL2.  THE NORMAL COMPLETION CODE IS ZERO.
C
C        FV1  AND  FV2  ARE TEMPORARY STORAGE ARRAYS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C     THIS VERSION DATED AUGUST 1983.
C
C     ------------------------------------------------------------------
C
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  TRED1(NM,N,A,W,FV1,FV2)
      CALL  TQLRAT(N,W,FV2,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 CALL  TRED2(NM,N,A,W,FV1,Z)
      CALL  TQL2(NM,N,W,FV1,Z,IERR)
   50 RETURN
      END
      SUBROUTINE TRED1(NM,N,A,D,E,E2)
C
      INTEGER I,J,K,L,N,II,NM,JP1
      REAL A(NM,N),D(N),E(N),E2(N)
      REAL F,G,H,SCALE
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1,
C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX
C     TO A SYMMETRIC TRIDIAGONAL MATRIX USING
C     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.
C
C        N IS THE ORDER OF THE MATRIX.
C
C        A CONTAINS THE REAL SYMMETRIC INPUT MATRIX.  ONLY THE
C          LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C     ON OUTPUT
C
C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
C          FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER
C          TRIANGLE.  THE FULL UPPER TRIANGLE OF A IS UNALTERED.
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO.
C
C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C     THIS VERSION DATED AUGUST 1983.
C
C     ------------------------------------------------------------------
C
      DO 100 I = 1, N
         D(I) = A(N,I)
         A(N,I) = A(I,I)
  100 CONTINUE
C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
      DO 300 II = 1, N
         I = N + 1 - II
         L = I - 1
         H = 0.0E0
         SCALE = 0.0E0
         IF (L .LT. 1) GO TO 130
C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
         DO 120 K = 1, L
  120    SCALE = SCALE + ABS(D(K))
C
         IF (SCALE .NE. 0.0E0) GO TO 140
C
         DO 125 J = 1, L
            D(J) = A(L,J)
            A(L,J) = A(I,J)
            A(I,J) = 0.0E0
  125    CONTINUE
C
  130    E(I) = 0.0E0
         E2(I) = 0.0E0
         GO TO 300
C
  140    DO 150 K = 1, L
            D(K) = D(K) / SCALE
            H = H + D(K) * D(K)
  150    CONTINUE
C
         E2(I) = SCALE * SCALE * H
         F = D(L)
         G = -SIGN(SQRT(H),F)
         E(I) = SCALE * G
         H = H - F * G
         D(L) = F - G
         IF (L .EQ. 1) GO TO 285
C     .......... FORM A*U ..........
         DO 170 J = 1, L
  170    E(J) = 0.0E0
C
         DO 240 J = 1, L
            F = D(J)
            G = E(J) + A(J,J) * F
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
               G = G + A(K,J) * D(K)
               E(K) = E(K) + A(K,J) * F
  200       CONTINUE
C
  220       E(J) = G
  240    CONTINUE
C     .......... FORM P ..........
         F = 0.0E0
C
         DO 245 J = 1, L
            E(J) = E(J) / H
            F = F + E(J) * D(J)
  245    CONTINUE
C
         H = F / (H + H)
C     .......... FORM Q ..........
         DO 250 J = 1, L
  250    E(J) = E(J) - H * D(J)
C     .......... FORM REDUCED A ..........
         DO 280 J = 1, L
            F = D(J)
            G = E(J)
C
            DO 260 K = J, L
  260       A(K,J) = A(K,J) - F * E(K) - G * D(K)
C
  280    CONTINUE
C
  285    DO 290 J = 1, L
            F = D(J)
            D(J) = A(L,J)
            A(L,J) = A(I,J)
            A(I,J) = F * SCALE
  290    CONTINUE
C
  300 CONTINUE
C
      RETURN
      END
      SUBROUTINE TRED2(NM,N,A,D,E,Z)
C
      INTEGER I,J,K,L,N,II,NM,JP1
      REAL A(NM,N),D(N),E(N),Z(NM,N)
      REAL F,G,H,HH,SCALE
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2,
C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A
C     SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING
C     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.
C
C        N IS THE ORDER OF THE MATRIX.
C
C        A CONTAINS THE REAL SYMMETRIC INPUT MATRIX.  ONLY THE
C          LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C     ON OUTPUT
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO.
C
C        Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX
C          PRODUCED IN THE REDUCTION.
C
C        A AND Z MAY COINCIDE.  IF DISTINCT, A IS UNALTERED.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C     THIS VERSION DATED AUGUST 1983.
C
C     ------------------------------------------------------------------
C
      DO 100 I = 1, N
C
         DO 80 J = I, N
   80    Z(J,I) = A(J,I)
C
         D(I) = A(N,I)
  100 CONTINUE
C
      IF (N .EQ. 1) GO TO 510
C     .......... FOR I=N STEP -1 UNTIL 2 DO -- ..........
      DO 300 II = 2, N
         I = N + 2 - II
         L = I - 1
         H = 0.0E0
         SCALE = 0.0E0
         IF (L .LT. 2) GO TO 130
C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
         DO 120 K = 1, L
  120    SCALE = SCALE + ABS(D(K))
C
         IF (SCALE .NE. 0.0E0) GO TO 140
  130    E(I) = D(L)
C
         DO 135 J = 1, L
            D(J) = Z(L,J)
            Z(I,J) = 0.0E0
            Z(J,I) = 0.0E0
  135    CONTINUE
C
         GO TO 290
C
  140    DO 150 K = 1, L
            D(K) = D(K) / SCALE
            H = H + D(K) * D(K)
  150    CONTINUE
C
         F = D(L)
         G = -SIGN(SQRT(H),F)
         E(I) = SCALE * G
         H = H - F * G
         D(L) = F - G
C     .......... FORM A*U ..........
         DO 170 J = 1, L
  170    E(J) = 0.0E0
C
         DO 240 J = 1, L
            F = D(J)
            Z(J,I) = F
            G = E(J) + Z(J,J) * F
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
               G = G + Z(K,J) * D(K)
               E(K) = E(K) + Z(K,J) * F
  200       CONTINUE
C
  220       E(J) = G
  240    CONTINUE
C     .......... FORM P ..........
         F = 0.0E0
C
         DO 245 J = 1, L
            E(J) = E(J) / H
            F = F + E(J) * D(J)
  245    CONTINUE
C
         HH = F / (H + H)
C     .......... FORM Q ..........
         DO 250 J = 1, L
  250    E(J) = E(J) - HH * D(J)
C     .......... FORM REDUCED A ..........
         DO 280 J = 1, L
            F = D(J)
            G = E(J)
C
            DO 260 K = J, L
  260       Z(K,J) = Z(K,J) - F * E(K) - G * D(K)
C
            D(J) = Z(L,J)
            Z(I,J) = 0.0E0
  280    CONTINUE
C
  290    D(I) = H
  300 CONTINUE
C     .......... ACCUMULATION OF TRANSFORMATION MATRICES ..........
      DO 500 I = 2, N
         L = I - 1
         Z(N,L) = Z(L,L)
         Z(L,L) = 1.0E0
         H = D(I)
         IF (H .EQ. 0.0E0) GO TO 380
C
         DO 330 K = 1, L
  330    D(K) = Z(K,I) / H
C
         DO 360 J = 1, L
            G = 0.0E0
C
            DO 340 K = 1, L
  340       G = G + Z(K,I) * Z(K,J)
C
            DO 360 K = 1, L
               Z(K,J) = Z(K,J) - G * D(K)
  360    CONTINUE
C
  380    DO 400 K = 1, L
  400    Z(K,I) = 0.0E0
C
  500 CONTINUE
C
  510 DO 520 I = 1, N
         D(I) = Z(N,I)
         Z(N,I) = 0.0E0
  520 CONTINUE
C
      Z(N,N) = 1.0E0
      E(1) = 0.0E0
      RETURN
      END
      SUBROUTINE TQL2(NM,N,D,E,Z,IERR)
C
      INTEGER I,J,K,L,M,N,II,L1,L2,NM,MML,IERR
      REAL D(N),E(N),Z(NM,N)
      REAL C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2,TST1,TST2,PYTHAG
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2,
C     NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND
C     WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971).
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C     OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD.
C     THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
C     BE FOUND IF  TRED2  HAS BEEN USED TO REDUCE THIS
C     FULL MATRIX TO TRIDIAGONAL FORM.
C
C     ON INPUT
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.
C
C        N IS THE ORDER OF THE MATRIX.
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTION BY  TRED2, IF PERFORMED.  IF THE EIGENVECTORS
C          OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
C          THE IDENTITY MATRIX.
C
C      ON OUTPUT
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
C          UNORDERED FOR INDICES 1,2,...,IERR-1.
C
C        E HAS BEEN DESTROYED.
C
C        Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
C          TRIDIAGONAL (OR FULL) MATRIX.  IF AN ERROR EXIT IS MADE,
C          Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
C          EIGENVALUES.
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     CALLS PYTHAG FOR  SQRT(A*A + B*B) .
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C     THIS VERSION DATED AUGUST 1983.
C
C     ------------------------------------------------------------------
C
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E(I-1) = E(I)
C
      F = 0.0E0
      TST1 = 0.0E0
      E(N) = 0.0E0
C
      DO 240 L = 1, N
         J = 0
         H = ABS(D(L)) + ABS(E(L))
         IF (TST1 .LT. H) TST1 = H
C     .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
         DO 110 M = L, N
            TST2 = TST1 + ABS(E(M))
            IF (TST2 .EQ. TST1) GO TO 120
C     .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP ..........
  110    CONTINUE
C
  120    IF (M .EQ. L) GO TO 220
  130    IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     .......... FORM SHIFT ..........
         L1 = L + 1
         L2 = L1 + 1
         G = D(L)
         P = (D(L1) - G) / (2.0E0 * E(L))
         R = PYTHAG(P,1.0E0)
         D(L) = E(L) / (P + SIGN(R,P))
         D(L1) = E(L) * (P + SIGN(R,P))
         DL1 = D(L1)
         H = G - D(L)
         IF (L2 .GT. N) GO TO 145
C
         DO 140 I = L2, N
  140    D(I) = D(I) - H
C
  145    F = F + H
C     .......... QL TRANSFORMATION ..........
         P = D(M)
         C = 1.0E0
         C2 = C
         EL1 = E(L1)
         S = 0.0E0
         MML = M - L
C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
         DO 200 II = 1, MML
            C3 = C2
            C2 = C
            S2 = S
            I = M - II
            G = C * E(I)
            H = C * P
            R = PYTHAG(P,E(I))
            E(I+1) = S * R
            S = E(I) / R
            C = P / R
            P = C * D(I) - S * G
            D(I+1) = H + S * (C * G + S * D(I))
C     .......... FORM VECTOR ..........
            DO 180 K = 1, N
               H = Z(K,I+1)
               Z(K,I+1) = S * Z(K,I) + C * H
               Z(K,I) = C * Z(K,I) - S * H
  180       CONTINUE
C
  200    CONTINUE
C
         P = -S * S2 * C3 * EL1 * E(L) / DL1
         E(L) = S * P
         D(L) = C * P
         TST2 = TST1 + ABS(E(L))
         IF (TST2 .GT. TST1) GO TO 130
  220    D(L) = D(L) + F
  240 CONTINUE
C     .......... ORDER EIGENVALUES AND EIGENVECTORS ..........
      DO 300 II = 2, N
         I = II - 1
         K = I
         P = D(I)
C
         DO 260 J = II, N
            IF (D(J) .GE. P) GO TO 260
            K = J
            P = D(J)
  260    CONTINUE
C
         IF (K .EQ. I) GO TO 300
         D(K) = D(I)
         D(I) = P
C
         DO 280 J = 1, N
            P = Z(J,I)
            Z(J,I) = Z(J,K)
            Z(J,K) = P
  280    CONTINUE
C
  300 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = L
 1001 RETURN
      END
      SUBROUTINE TQLRAT(N,D,E2,IERR)
C
      INTEGER I,J,L,M,N,II,L1,MML,IERR
      REAL D(N),E2(N)
      REAL B,C,F,G,H,P,R,S,T,EPSLON,PYTHAG
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT,
C     ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C     TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD.
C
C     ON INPUT
C
C        N IS THE ORDER OF THE MATRIX.
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C        E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE
C          INPUT MATRIX IN ITS LAST N-1 POSITIONS.  E2(1) IS ARBITRARY.
C
C      ON OUTPUT
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C          ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C          THE SMALLEST EIGENVALUES.
C
C        E2 HAS BEEN DESTROYED.
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     CALLS PYTHAG FOR  SQRT(A*A + B*B) .
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C     THIS VERSION DATED AUGUST 1983.
C
C     ------------------------------------------------------------------
C
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E2(I-1) = E2(I)
C
      F = 0.0E0
      T = 0.0E0
      E2(N) = 0.0E0
C
      DO 290 L = 1, N
         J = 0
         H = ABS(D(L)) + SQRT(E2(L))
         IF (T .GT. H) GO TO 105
         T = H
         B = EPSLON(T)
         C = B * B
C     .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ..........
  105    DO 110 M = L, N
            IF (E2(M) .LE. C) GO TO 120
C     .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP ..........
  110    CONTINUE
C
  120    IF (M .EQ. L) GO TO 210
  130    IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     .......... FORM SHIFT ..........
         L1 = L + 1
         S = SQRT(E2(L))
         G = D(L)
         P = (D(L1) - G) / (2.0E0 * S)
         R = PYTHAG(P,1.0E0)
         D(L) = S / (P + SIGN(R,P))
         H = G - D(L)
C
         DO 140 I = L1, N
  140    D(I) = D(I) - H
C
         F = F + H
C     .......... RATIONAL QL TRANSFORMATION ..........
         G = D(M)
         IF (G .EQ. 0.0E0) G = B
         H = G
         S = 0.0E0
         MML = M - L
C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
         DO 200 II = 1, MML
            I = M - II
            P = G * H
            R = P + E2(I)
            E2(I+1) = S * R
            S = E2(I) / R
            D(I+1) = H + S * (H + D(I))
            G = D(I) - E2(I) / G
            IF (G .EQ. 0.0E0) G = B
            H = G * P / R
  200    CONTINUE
C
         E2(L) = S * G
         D(L) = H
C     .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST ..........
         IF (H .EQ. 0.0E0) GO TO 210
         IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210
         E2(L) = H * E2(L)
         IF (E2(L) .NE. 0.0E0) GO TO 130
  210    P = D(L) + F
C     .......... ORDER EIGENVALUES ..........
         IF (L .EQ. 1) GO TO 250
C     .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
         DO 230 II = 2, L
            I = L + 2 - II
            IF (P .GE. D(I-1)) GO TO 270
            D(I) = D(I-1)
  230    CONTINUE
C
  250    I = 1
  270    D(I) = P
  290 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = L
 1001 RETURN
      END
      REAL FUNCTION PYTHAG(A,B)
      REAL A,B
C
C     FINDS SQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
C
      REAL P,R,S,T,U
      P = AMAX1(ABS(A),ABS(B))
      IF (P .EQ. 0.0E0) GO TO 20
      R = (AMIN1(ABS(A),ABS(B))/P)**2
   10 CONTINUE
         T = 4.0E0 + R
         IF (T .EQ. 4.0E0) GO TO 20
         S = R/T
         U = 1.0E0 + 2.0E0*S
         P = U*P
         R = (S/U)**2 * R
      GO TO 10
   20 PYTHAG = P
      RETURN
      END
c
      REAL FUNCTION EPSLON (X)
      REAL X
      REAL A,B,C,EPS
      A = 4.0E0/3.0E0
  10  B = A - 1.0E0
      C = B + B + B
      EPS = ABS(C-1.0E0)
      IF(EPS .EQ. 0.0E0)GO TO 10
      EPSLON = EPS*ABS(X)
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  LSVRR/DLSVRR (Single/Double precision version)
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    January 1, 1985
C
C  Purpose:    Compute the singular value decomposition of a real
C              matrix.
C
C  Usage:      CALL LSVRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK,
C                          S, U, LDU, V, LDV)
C
C  Arguments:
C     NRA    - Number of rows of A.  (Input)
C     NCA    - Number of columns of A.  (Input)
C     A      - NRA by NCA matrix whose singular value decomposition
C              is to be computed.  (Input)
C     LDA    - Leading dimension of A exactly as specified in the
C              dimension statement of the calling program.  (Input)
C     IPATH  - Flag used to control the computation of the singular
C              vectors.  (Input)
C              IPATH has the decimal expansion IJ such that:
C                 I = 0 means do not compute the left singular vectors,
C                 I = 1 means return the NCA left singular vectors in U,
C                 I = 2 means return only the MIN(NRA,NCA) left singular
C                       vectors in U,
C                 J = 0 means do not compute the right singular vectors,
C                 J = 1 means return the right singular vectors in V.
C              For example, IPATH = 20 means I = 2 and J = 0.
C     TOL    - Scalar containing the tolerance used to determine when a
C              singular value is negligible.  (Input)
C              If TOL is positive then a singular value SI is considered
C                 negligible if SI .LE. TOL.
C              If TOL is negative then a singular value SI is considered
C                 negligible if SI .LE. ABS(TOL)*(Infinity norm of A).
C                 In this case ABS(TOL) should generally contain an
C                 estimate of the level of relative error in the data.
C     IRANK  - Scalar containing an estimate of the rank of A.  (Output)
C     S      - Vector of length MIN(NRA+1,NCA) containing the singular
C              values of A in descending order of magnitude in the first
C              MIN(NRA,NCA) positions.  (Output)
C     U      - NRA by NCU matrix containing the left singular vectors of
C              A.  (Output)
C              NCU must be equal to NRA if I is equal to 1.
C              NCU must be equal to MIN(NRA,NCA) if I is equal to 2.
C              U will not be referenced if I is equal to zero.  If NRA
C              is less than or equal to NCU, then U can share the same
C              storage locations as A.  See Remarks.
C     LDU    - Leading dimension of U exactly as specified in the
C              dimension statement of the calling program.  (Input)
C     V      - NCA by NCA matrix containing the right singular vectors
C              of A.  (Output)
C              V will not be referenced if J is equal to zero.  V can
C              share the same storage location as A; however U and V
C              cannot both coincide with A simultaneously.
C     LDV    - Leading dimension of V exactly as specified in the
C              dimension statement of the calling program.  (Input)
C
C  Remarks:
C  1. Automatic workspace usage is
C              LSVRR    NRA*NCA + NRA + NCA + MAX(NRA,NCA) - 1 units, or
C              DLSVRR   2*(NRA*NCA + NRA + NCA + MAX(NRA,NCA) - 1)
C                       units.
C     Workspace may be explicitly provided, if desired, by use of
C     L2VRR/DL2VRR.  The reference is
C              CALL L2VRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK,
C                          S, U, LDU, V, LDV, ACOPY, WK)
C     The additional arguments are as follows:
C     ACOPY  - Work vector of length NRA*NCA for the matrix A.  If
C              A is not needed then A and ACOPY may share the same
C              storage locations.
C     WK     - Work vector of length NRA + NCA + MAX(NRA,NCA) - 1.
C
C  2. Informational error
C     Type Code
C       4   1  Convergence cannot be achieved for all the singular
C              values and their corresponding singular vectors.
C
C  3. When NRA is much greater than NCA, it might not be reasonable to
C     store the whole matrix U.  In this case IPATH with I = 2 allows
C     a singular value factorization of A to be computed in which only
C     the first NCA columns of U are computed, and in many applications
C     those are all that are needed.
C
C  Keywords:   Least squares; Complete orthogonal decomposition;
C              Rank estimation
C
C  GAMS:       D6
C
C  Chapters:   MATH/LIBRARY Linear Systems
C              STAT/LIBRARY Mathematical Support
C
C  Copyright:  1985 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE LSVRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK, S, U,
     &                  LDU, V, LDV)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    NRA, NCA, LDA, IPATH, IRANK, LDU, LDV
      REAL       TOL, A(LDA,*), S(*), U(LDU,*), V(LDV,*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    INDA, INDW
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                                  SPECIFICATIONS FOR COMMON /WORKSP/
      REAL       RWKSP(61913)
      REAL       RDWKSP(5000)
      DOUBLE PRECISION DWKSP(2500)
      COMPLEX    CWKSP(2500)
      COMPLEX    CZWKSP(2500)
      COMPLEX    *16 ZWKSP(1250)
      INTEGER    IWKSP(5000)
      LOGICAL    LWKSP(5000)
      EQUIVALENCE (DWKSP(1), RWKSP(1))
      EQUIVALENCE (CWKSP(1), RWKSP(1)), (ZWKSP(1), RWKSP(1))
      EQUIVALENCE (IWKSP(1), RWKSP(1)), (LWKSP(1), RWKSP(1))
      EQUIVALENCE (RDWKSP(1), RWKSP(1)), (CZWKSP(1), RWKSP(1))
      COMMON     /WORKSP/ RWKSP
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  MAX0
      INTRINSIC  MAX0
      INTEGER    MAX0
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   E1MES, E1POP, E1PSH, E1STI, L2VRR
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   I1KGT, N1RCD
      INTEGER    I1KGT, N1RCD
C
      CALL E1PSH ('LSVRR ')
C
      IF (NRA.LE.0 .OR. NCA.LE.0) THEN
         CALL E1STI (1, NRA)
         CALL E1STI (2, NCA)
         CALL E1MES (5, 1, 'Both the number of rows and the '//
     &               'number of columns of the input matrix have to '//
     &               'be positive while NRA = %(I1) and NCA = %(I2) '//
     &               'are given.')
      ELSE
         INDA = I1KGT(NRA*NCA,3)
         INDW = I1KGT(NRA+NCA+MAX0(NCA,NRA)-1,3)
         IF (N1RCD(0) .NE. 0) THEN
            CALL E1MES (5, 2, ' ')
            CALL E1STI (1, NRA)
            CALL E1STI (2, NCA)
            CALL E1MES (5, 2, 'The workspace is based on NRA and NCA '//
     &                  'where NRA = %(I1) and NCA = %(I2) are '//
     &                  'given.')
         ELSE
            CALL L2VRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK, S, U,
     &                  LDU, V, LDV, RDWKSP(INDA), RDWKSP(INDW))
         END IF
      END IF
C
      CALL E1POP ('LSVRR ')
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  L2VRR/DL2VRR (Single/Double precision version)
C
C  Computer:   DGC/SINGLE
C
C  Revised:    January 1, 1985
C
C  Purpose:    Compute the singular value decomposition of a real
C              matrix.
C
C  Usage:      CALL L2VRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK,
C                          S, U, LDU, V, LDV, WKA, WK)
C
C  Arguments:  See LSVRR/DLSVRR.
C
C  Remarks:    See LSVRR/DLSVRR.
C
C  Chapter:    MATH/LIBRARY Linear Systems
C
C  Copyright:  1985 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE L2VRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK, S, U,
     &                  LDU, V, LDV, WKA, WK)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    NRA, NCA, LDA, IPATH, IRANK, LDU, LDV
      REAL       TOL, A(LDA,*), S(*), U(*), V(*), WKA(*), WK(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, INDE, INDW, JOBU, JOBV
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  MOD
      INTRINSIC  MOD
      INTEGER    MOD
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   E1MES, E1POP, E1PSH, E1STI, SCOPY, L3VRR
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   N1RCD
      INTEGER    N1RCD
C
      CALL E1PSH ('L2VRR   ')
C
      IF (NRA.LE.0 .OR. NCA.LE.0) THEN
         CALL E1STI (1, NRA)
         CALL E1STI (2, NCA)
         CALL E1MES (5, 1, 'Both the number of rows and the '//
     &               'number of columns of the input matrix have to '//
     &               'be positive while NRA = %(I1) and NCA = %(I2) '//
     &               'are given.')
      ELSE
         IF (NRA .GT. LDA) THEN
            CALL E1STI (1, NRA)
            CALL E1STI (2, LDA)
            CALL E1MES (5, 2, 'The number of rows of A must be '//
     &                  'less than or equal to its leading dimension '//
     &                  'while NRA = %(I1) and LDA = %(I2) are '//
     &                  'given.')
         END IF
C
         IF (LDU .LE. 0) THEN
            CALL E1STI (1, LDU)
            CALL E1MES (5, 3, 'The leading dimension of U must '//
     &                  'be greater than zero.  LDU = %(I1) is '//
     &                  'given.')
         END IF
C
         IF (LDV .LE. 0) THEN
            CALL E1STI (1, LDV)
            CALL E1MES (5, 4, 'The leading dimension of V must '//
     &                  'be greater than zero.  LDV = %(I1) is '//
     &                  'given.')
         END IF
C
         IF (N1RCD(0) .EQ. 0) THEN
            JOBU = MOD(IPATH,100)/10
            JOBV = MOD(IPATH,10)
            IF ((JOBU.NE.0.AND.JOBU.NE.1.AND.JOBU.NE.2) .OR.
     &          (JOBV.NE.0.AND.JOBV.NE.1)) THEN
               CALL E1STI (1, JOBU)
               CALL E1STI (2, JOBV)
               CALL E1MES (5, 7, 'Error in computation control flag. '//
     &                     'The IJ decimal expansion of IPATH is I = '//
     &                     '%(I1) and J = %(I2).  I must be either '//
     &                     '0, 1 or 2 and J must be either 0 or 1.')
            ELSE
C                                  MAKE A COPY OF A IN WKA AND WORK
C                                  WITH WKA ONLY.
               DO 10  I=1, NCA
                  CALL SCOPY (NRA, A(1,I), 1, WKA((I-1)*NRA+1), 1)
   10          CONTINUE
C
               INDE = 1
               INDW = NCA + 1
               CALL L3VRR (NRA, NCA, WKA, NRA, IPATH, TOL, IRANK, S,
     &                     U, LDU, V, LDV, WK(INDE), WK(INDW))
            END IF
         END IF
      END IF
C
      CALL E1POP ('L2VRR   ')
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  L3VRR/DL3VRR (Single/Double precision version)
C
C  Computer:   DGC/SINGLE
C
C  Revised:    January 1, 1985
C
C  Purpose:    Compute the singular value decomposition of a real
C              matrix.
C
C  Usage:      CALL L3VRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK,
C                          S, U, LDU, V, LDV, E, WORK)
C
C  Arguments:  See LSVRR/DLSVRR
C
C  Remarks:    See LSVRR/DLSVRR.
C
C  Chapter:    MATH/LIBRARY Linear Systems
C
C  Copyright:  1985 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE L3VRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK, S, U,
     &                  LDU, V, LDV, E, WORK)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    NRA, NCA, LDA, IPATH, IRANK, LDU, LDV
      REAL       TOL, A(LDA,*), S(*), U(LDU,*), V(LDV,*), E(*), WORK(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, IEND, INFO, ISTART, ITER, J, JOBU, K, KASE, KK, L,
     &           LL, LLS, LM1, LP1, LS, LU, M, MAXIT, MINMN, MM, MM1,
     &           MP1, NCT, NCTP1, NCU, NRT, NRTP1
      REAL       ANORM, B, C, CS, EL, EMM1, F, G, SCALE, SHIFT, SL,
     &           SM, SMM1, SN, STOL, T, T1, TEST, ZTEST
      LOGICAL    WANTU, WANTV
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  ABS,AMAX1,MAX0,MIN0,MOD,SIGN,SQRT
      INTRINSIC  ABS, AMAX1, MAX0, MIN0, MOD, SIGN, SQRT
      INTEGER    MAX0, MIN0, MOD
      REAL       ABS, AMAX1, SIGN, SQRT
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   E1MES, E1POP, E1PSH, E1STI, SCOPY, SGEMV, SGER, SROT,
     &           SROTG, SSCAL, SSET, SSWAP
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   SASUM, SNRM2
      REAL       SASUM, SNRM2
C
      CALL E1PSH ('L3VRR   ')
C                                  IF TOL.LT.0, COMPUTE THE INFINITY
C                                  NORM OF A AND SINGULAR VALUE
C                                  TOLERANCE FOR RANK ESTIMATION
      IF (TOL .LT. 0.0E0) THEN
         ANORM = 0.0E0
         DO 10  I=1, NRA
            ANORM = AMAX1(ANORM,SASUM(NCA,A(I,1),LDA))
   10    CONTINUE
         STOL = ABS(TOL)*ANORM
      ELSE
         STOL = TOL
      END IF
C                                  SET THE MAXIMUM NUMBER OF
C                                  ITERATIONS.
      MAXIT = 30
C                                  DETERMINE WHAT IS TO BE COMPUTED.
      WANTU = .FALSE.
      WANTV = .FALSE.
      JOBU = MOD(IPATH,100)/10
      NCU = NRA
      IF (JOBU .EQ. 2) NCU = MIN0(NRA,NCA)
      IF (JOBU .NE. 0) WANTU = .TRUE.
      IF (MOD(IPATH,10) .NE. 0) WANTV = .TRUE.
C                                  REDUCE A TO BIDIAGONAL FORM, STORING
C                                  THE DIAGONAL ELEMENTS IN S AND THE
C                                  SUPER-DIAGONAL ELEMENTS IN E.
      INFO = 0
      NCT = MIN0(NRA-1,NCA)
      NRT = MAX0(0,MIN0(NCA-2,NRA))
      LU = MAX0(NCT,NRT)
      IF (LU .GE. 1) THEN
         DO 20  L=1, LU
            LP1 = L + 1
            IF (L .LE. NCT) THEN
C                                  COMPUTE THE TRANSFORMATION FOR THE
C                                  L-TH NCA AND PLACE THE L-TH
C                                  DIAGONAL IN S(L).
               S(L) = SNRM2(NRA-L+1,A(L,L),1)
               IF (S(L) .NE. 0.0E0) THEN
                  IF (A(L,L) .NE. 0.0E0) S(L) = SIGN(S(L),A(L,L))
                  CALL SSCAL (NRA-L+1, 1.0E0/S(L), A(L,L), 1)
                  A(L,L) = 1.0E0 + A(L,L)
               END IF
               S(L) = -S(L)
            END IF
C
            IF (NCA .GE. LP1) THEN
               IF (L.LE.NCT .AND. S(L).NE.0.0E0) THEN
C                                  APPLY THE TRANSFORMATION.
                  CALL SGEMV ('T', NRA-L+1, NCA-LP1+1, -1.0E0/A(L,L),
     &                        A(L,LP1), LDA, A(L,L), 1, 0.0E0,
     &                        WORK(NRA+1), 1)
                  CALL SGER (NRA-L+1, NCA-LP1+1, 1.0E0, A(L,L), 1,
     &                       WORK(NRA+1), 1, A(L,LP1), LDA)
               END IF
C                                  PLACE THE L-TH ROW OF A INTO E FOR
C                                  THE SUBSEQUENT CALCULATION OF THE
C                                  ROW TRANSFORMATION.
               CALL SCOPY (NCA-LP1+1, A(L,LP1), LDA, E(LP1), 1)
            END IF
C                                  PLACE THE TRANSFORMATION IN U FOR
C                                  SUBSEQUENT BACK MULTIPLICATION.
            IF (WANTU .AND. L.LE.NCT) CALL SCOPY (NRA-L+1, A(L,L), 1,
     &          U(L,L), 1)
            IF (L .LE. NRT) THEN
C                                  COMPUTE THE L-TH ROW TRANSFORMATION
C                                  AND PLACE THE L-TH SUPER-DIAGONAL
C                                  IN E(L).
               E(L) = SNRM2(NCA-L,E(LP1),1)
               IF (E(L) .NE. 0.0E0) THEN
                  IF (E(LP1) .NE. 0.0E0) E(L) = SIGN(E(L),E(LP1))
                  CALL SSCAL (NCA-L, 1.0E0/E(L), E(LP1), 1)
                  E(LP1) = 1.0E0 + E(LP1)
               END IF
               E(L) = -E(L)
               IF (LP1.LE.NRA .AND. E(L).NE.0.0E0) THEN
C                                  APPLY THE TRANSFORMATION.
                  CALL SGEMV ('N', NRA-L, NCA-LP1+1, 1.0E0,
     &                        A(LP1,LP1), LDA, E(LP1), 1, 0.0E0,
     &                        WORK(LP1), 1)
                  CALL SGER (NRA-L, NCA-LP1+1, -1.0E0/E(LP1),
     &                       WORK(LP1), 1, E(LP1), 1, A(LP1,LP1), LDA)
               END IF
C                                  PLACE THE TRANSFORMATION IN V FOR
C                                  SUBSEQUENT BACK MULTIPLICATION.
               IF (WANTV) CALL SCOPY (NCA-LP1+1, E(LP1), 1, V(LP1,L),
     &             1)
            END IF
   20    CONTINUE
      END IF
C                                  SET UP THE FINAL BIDIAGONAL MATRIX
C                                  OR ORDER M.
      M = MIN0(NCA,NRA+1)
      NCTP1 = NCT + 1
      NRTP1 = NRT + 1
      IF (NCT .LT. NCA) S(NCTP1) = A(NCTP1,NCTP1)
      IF (NRA .LT. M) S(M) = 0.0E0
      IF (NRTP1 .LT. M) E(NRTP1) = A(NRTP1,M)
      E(M) = 0.0E0
C                                  IF REQUIRED, GENERATE U.
      IF (WANTU) THEN
         IF (NCU .GE. NCTP1) THEN
            DO 30  J=NCTP1, NCU
               CALL SSET (NRA, 0.0E0, U(1,J), 1)
               U(J,J) = 1.0E0
   30       CONTINUE
         END IF
         IF (NCT .GE. 1) THEN
            DO 40  LL=1, NCT
               L = NCT - LL + 1
               IF (S(L) .NE. 0.0E0) THEN
                  LP1 = L + 1
                  IF (NCU .GE. LP1) THEN
                     CALL SGEMV ('T', NRA-L+1, NCU-LP1+1,
     &                           -1.0E0/U(L,L), U(L,LP1), LDU, U(L,L),
     &                           1, 0.0E0, WORK(NRA+1), 1)
                     CALL SGER (NRA-L+1, NCU-LP1+1, 1.0E0, U(L,L), 1,
     &                          WORK(NRA+1), 1, U(L,LP1), LDU)
                  END IF
                  CALL SSCAL (NRA-L+1, -1.0E0, U(L,L), 1)
                  U(L,L) = 1.0E0 + U(L,L)
                  LM1 = L - 1
                  IF (LM1 .GE. 1) CALL SSET (LM1, 0.0E0, U(1,L), 1)
               ELSE
                  CALL SSET (NRA, 0.0E0, U(1,L), 1)
                  U(L,L) = 1.0E0
               END IF
   40       CONTINUE
         END IF
      END IF
C                                  IF IT IS REQUIRED, GENERATE V.
      IF (WANTV) THEN
         DO 50  LL=1, NCA
            L = NCA - LL + 1
            LP1 = L + 1
            IF (L.LE.NRT .AND. E(L).NE.0.0E0) THEN
               CALL SGEMV ('T', NCA-L, NCA-LP1+1, -1.0E0/V(LP1,L),
     &                     V(LP1,LP1), LDV, V(LP1,L), 1, 0.0E0,
     &                     WORK(NRA+1), 1)
               CALL SGER (NCA-L, NCA-LP1+1, 1.0E0, V(LP1,L), 1,
     &                    WORK(NRA+1), 1, V(LP1,LP1), LDV)
            END IF
            CALL SSET (NCA, 0.0E0, V(1,L), 1)
            V(L,L) = 1.0E0
   50    CONTINUE
      END IF
C                                  MAIN ITERATION LOOP FOR THE SINGULAR
C                                  VALUES.
      MM = M
      ITER = 0
   60 CONTINUE
C                                  QUIT IF ALL THE SINGULAR VALUES HAVE
C                                  BEEN FOUND.
      IF (M.NE.0 .AND. ITER.LE.MAXIT) THEN
C                                  THIS SECTION OF THE PROGRAM INSPECTS
C                                  FOR NEGLIGIBLE ELEMENTS IN THE S AND
C                                  E ARRAYS. ON COMPLETION THE VARIABLES
C                                  KASE AND L ARE SET AS FOLLOWS.
C
C                                  KASE = 1     IF S(M) AND E(L-1) ARE
C                                  NEGLIGIBLE AND L.LT.M
C
C                                  KASE = 2     IF S(L) IS NEGLIGIBLE
C                                  AND L.LT.M
C
C                                  KASE = 3     IF E(L-1) IS NEGLIGIBLE,
C                                  L.LT.M, AND S(L), ..., S(M) ARE NOT
C                                  NEGLIGIBLE (QR STEP).
C
C                                  KASE = 4     IF E(M-1) IS NEGLIGIBLE
C                                  (CONVERGENCE).
         DO 70  LL=1, M
            L = M - LL
            IF (L .EQ. 0) GO TO 80
            TEST = ABS(S(L)) + ABS(S(L+1))
            ZTEST = TEST + ABS(E(L))
            IF (ZTEST .EQ. TEST) THEN
               E(L) = 0.0E0
               GO TO 80
            END IF
   70    CONTINUE
   80    CONTINUE
         IF (L .EQ. M-1) THEN
            KASE = 4
         ELSE
            LP1 = L + 1
            MP1 = M + 1
            DO 90  LLS=LP1, MP1
               LS = M - LLS + LP1
               IF (LS .EQ. L) GO TO 100
               TEST = 0.0E0
               IF (LS .NE. M) TEST = TEST + ABS(E(LS))
               IF (LS .NE. L+1) TEST = TEST + ABS(E(LS-1))
               ZTEST = TEST + ABS(S(LS))
               IF (ZTEST .EQ. TEST) THEN
                  S(LS) = 0.0E0
                  GO TO 100
               END IF
   90       CONTINUE
  100       CONTINUE
            IF (LS .EQ. L) THEN
               KASE = 3
            ELSE IF (LS .EQ. M) THEN
               KASE = 1
            ELSE
               KASE = 2
               L = LS
            END IF
         END IF
         L = L + 1
C                                  PERFORM THE TASK INDICATED BY KASE.
         IF (KASE .EQ. 1) THEN
C                                  DEFLATE NEGLIGIBLE S(M).
            MM1 = M - 1
            F = E(M-1)
            E(M-1) = 0.0E0
            DO 110  KK=L, MM1
               K = MM1 - KK + L
               T1 = S(K)
               CALL SROTG (T1, F, CS, SN)
               S(K) = T1
               IF (K .NE. L) THEN
                  F = -SN*E(K-1)
                  E(K-1) = CS*E(K-1)
               END IF
               IF (WANTV) CALL SROT (NCA, V(1,K), 1, V(1,M), 1, CS, SN)
  110       CONTINUE
C                                  SPLIT AT NEGLIGIBLE S(L).
         ELSE IF (KASE .EQ. 2) THEN
            F = E(L-1)
            E(L-1) = 0.0E0
            DO 120  K=L, M
               T1 = S(K)
               CALL SROTG (T1, F, CS, SN)
               S(K) = T1
               F = -SN*E(K)
               E(K) = CS*E(K)
               IF (WANTU) CALL SROT (NRA, U(1,K), 1, U(1,L-1), 1, CS,
     &             SN)
  120       CONTINUE
C                                  PERFORM ONE QR STEP.
         ELSE IF (KASE .EQ. 3) THEN
C                                  CALCULATE THE SHIFT.
            SCALE = AMAX1(ABS(S(M)),ABS(S(M-1)),ABS(E(M-1)),ABS(S(L)),
     &              ABS(E(L)))
            SM = S(M)/SCALE
            SMM1 = S(M-1)/SCALE
            EMM1 = E(M-1)/SCALE
            SL = S(L)/SCALE
            EL = E(L)/SCALE
            B = ((SMM1+SM)*(SMM1-SM)+EMM1**2)/2.0E0
            C = (SM*EMM1)**2
            SHIFT = 0.0E0
            IF (B.NE.0.0E0 .OR. C.NE.0.0E0) THEN
               SHIFT = SQRT(B**2+C)
               IF (B .LT. 0.0E0) SHIFT = -SHIFT
               SHIFT = C/(B+SHIFT)
            END IF
            F = (SL+SM)*(SL-SM) - SHIFT
            G = SL*EL
C                                  CHASE ZEROS.
            MM1 = M - 1
            DO 130  K=L, MM1
               CALL SROTG (F, G, CS, SN)
               IF (K .NE. L) E(K-1) = F
               F = CS*S(K) + SN*E(K)
               E(K) = CS*E(K) - SN*S(K)
               G = SN*S(K+1)
               S(K+1) = CS*S(K+1)
               IF (WANTV) CALL SROT (NCA, V(1,K), 1, V(1,K+1), 1, CS,
     &             SN)
               CALL SROTG (F, G, CS, SN)
               S(K) = F
               F = CS*E(K) + SN*S(K+1)
               S(K+1) = -SN*E(K) + CS*S(K+1)
               G = SN*E(K+1)
               E(K+1) = CS*E(K+1)
               IF (WANTU .AND. K.LT.NRA) CALL SROT (NRA, U(1,K), 1,
     &             U(1,K+1), 1, CS, SN)
  130       CONTINUE
            E(M-1) = F
            ITER = ITER + 1
C                                  CONVERGENCE.
         ELSE IF (KASE .EQ. 4) THEN
C                                  MAKE THE SINGULAR VALUE POSITIVE.
            IF (S(L) .LT. 0.0E0) THEN
               S(L) = -S(L)
               IF (WANTV) CALL SSCAL (NCA, -1.0E0, V(1,L), 1)
            END IF
C                                  ORDER THE SINGULAR VALUE.
  140       IF (L .EQ. MM) GO TO 150
            IF (S(L) .GE. S(L+1)) GO TO 150
            T = S(L)
            S(L) = S(L+1)
            S(L+1) = T
            IF (WANTV .AND. L.LT.NCA) CALL SSWAP (NCA, V(1,L), 1, V(1,
     &          L+1), 1)
            IF (WANTU .AND. L.LT.NRA) CALL SSWAP (NRA, U(1,L), 1, U(1,
     &          L+1), 1)
            L = L + 1
            GO TO 140
  150       CONTINUE
            ITER = 0
            M = M - 1
         END IF
         GO TO 60
      END IF
      IF (ITER .GT. MAXIT) INFO = M
      IF (INFO .EQ. 0) THEN
C                                  ESTIMATE THE RANK OF A
         LS = MIN0(NCA+1,NRA)
         MINMN = MIN0(NCA,NRA)
         IRANK = MINMN
         DO 160  I=1, MINMN
            IF (ABS(S(I)) .LE. STOL) THEN
               IRANK = I - 1
               GO TO 170
            END IF
  160    CONTINUE
  170    CONTINUE
      ELSE
         ISTART = INFO + 1
         IEND = MIN0(NRA,NCA)
         CALL E1STI (1, ISTART)
         CALL E1STI (2, IEND)
C         CALL E1MES (4, 1, 'Convergence can only be obtained '//
C     &               'for the %(I1), ... , %(I2) singular values '//
C     &               'and their corresponding singular vectors.')
      END IF
      CALL E1POP ('L3VRR ')
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  E1MES
C
C  Computer:   DGC/SINGLE
C
C  Revised:    March 2, 1984
C
C  Purpose:    Set an error state for the current level in the stack.
C              The message is printed immediately if the error type is
C              5, 6, or 7 and the print attribute for that type is YES.
C
C  Usage:      CALL E1MES(IERTYP,IERCOD,MSGPKD)
C
C  Arguments:
C     IERTYP - Integer specifying the error type.  (Input)
C                IERTYP=1,  informational/note
C                IERTYP=2,  informational/alert
C                IERTYP=3,  informational/warning
C                IERTYP=4,  informational/fatal
C                IERTYP=5,  terminal
C                IERTYP=6,  PROTRAN/warning
C                IERTYP=7,  PROTRAN/fatal
C     IERCOD - Integer specifying the error code.  (Input)
C     MSGPKD - A character string containing the message.
C              (Input)  Within the message, any of following may appear
C                %(A1),%(A2),...,%(A9) for character arrays
C                %(C1),%(C2),...,%(C9) for complex numbers
C                %(D1),%(D2),...,%(D9) for double precision numbers
C                %(I1),%(I2),...,%(I9) for integer numbers
C                %(K1),%(K2),...,%(K9) for keywords
C                %(L1),%(L2),...,%(L9) for literals (strings)
C                %(R1),%(R2),...,%(R9) for real numbers
C                %(Z1),%(Z2),...,%(Z9) for double complex numbers
C              This provides a way to insert character arrays, strings,
C              numbers, and keywords into the message.  See remarks
C              below.
C
C  Remarks:
C     The number of characters in the message after the insertion of
C     the corresponding strings, etc. should not exceed 255.  If the
C     limit is exceeded, only the first 255 characters will be used.
C     The appropriate strings, etc. need to have been previously stored
C     in common via calls to E1STA, E1STD, etc.  Line breaks may be
C     specified by inserting the two characters '%/' into the message
C     at the desired locations.
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE E1MES (IERTYP, IERCOD, MSGPKD)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    IERTYP, IERCOD
      CHARACTER  MSGPKD*(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    ERTYP2, I, IER, IPLEN, ISUB, LAST, LEN2, LOC, M, MS,
     &           NLOC, NUM, PBEG
      CHARACTER  MSGTMP(255)
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      INTEGER    IFINIT, NFORMS
      CHARACTER  BLNK, DBB(3), FIND(4), FORMS(9), INREF(25), LPAR,
     &           NCHECK(3), PERCNT, RPAR
      SAVE       BLNK, DBB, FIND, FORMS, IFINIT, INREF, LPAR, NCHECK,
     &           NFORMS, PERCNT, RPAR
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                              SPECIFICATIONS FOR COMMON /ERCOM1/
      INTEGER    CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51),
     &           PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7,
     &           IALLOC(51), HDRFMT(7), TRACON(7)
      COMMON     /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE,
     &           PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT,
     &           TRACON
      SAVE       /ERCOM1/
C                              SPECIFICATIONS FOR COMMON /ERCOM2/
      CHARACTER  MSGSAV(255), PLIST(300), RNAME(51)*6
      COMMON     /ERCOM2/ MSGSAV, PLIST, RNAME
      SAVE       /ERCOM2/
C                              SPECIFICATIONS FOR COMMON /ERCOM3/
      DOUBLE PRECISION ERCKSM
      COMMON     /ERCOM3/ ERCKSM
      SAVE       /ERCOM3/
C                              SPECIFICATIONS FOR COMMON /ERCOM4/
      LOGICAL    ISUSER(51)
      COMMON     /ERCOM4/ ISUSER
      SAVE       /ERCOM4/
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  LEN,MIN0
      INTRINSIC  LEN, MIN0
      INTEGER    LEN, MIN0
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   C1TCI, E1INIT, E1PRT, E1UCS, M1VE, M1VECH
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   I1DX
      INTEGER    I1DX
C
      DATA FORMS/'A', 'C', 'D', 'I', 'K', 'L', 'R', 'S', 'Z'/,
     &     NFORMS/9/
      DATA PERCNT/'%'/, LPAR/'('/, RPAR/')'/, BLNK/' '/
      DATA INREF/' ', 'i', 'n', ' ', 'r', 'e', 'f', 'e', 'r',
     &     'e', 'n', 'c', 'e', ' ', 't', 'o', ' ', 'k', 'e',
     &     'y', 'w', 'o', 'r', 'd', ' '/
      DATA NCHECK/'N', '1', '*'/, DBB/'.', ' ', ' '/
      DATA FIND/'*', ' ', ' ', '*'/
      DATA IFINIT/0/
C                                  INITIALIZE ERROR TABLE IF NECESSARY
      IF (IFINIT .EQ. 0) THEN
         CALL E1INIT
         IFINIT = 1
      END IF
C                                  CHECK AND SET ERROR TYPE IF NECESSARY
      IF (IERTYP .NE. -1) THEN
         ERTYPE(CALLVL) = IERTYP
      ELSE IF (IERTYP.LT.-1 .OR. IERTYP.GT.7) THEN
         MSGLEN = 51
         CALL M1VECH ('.  Error from E1MES.  Illegal error type'//
     &                ' specified. ', MSGLEN, MSGSAV, MSGLEN)
         CALL E1PRT
         STOP
      END IF
C
      ERTYP2 = ERTYPE(CALLVL)
C                                  SET ERROR CODE IF NECESSARY
      IF (IERCOD .GT. -1) ERCODE(CALLVL) = IERCOD
      LEN2 = LEN(MSGPKD)
C
      IF (IERTYP.EQ.0 .OR. IERCOD.EQ.0) THEN
C                                  REMOVE THE ERROR STATE
         MSGLEN = 0
      ELSE IF (LEN2.EQ.0 .OR. (LEN2.EQ.1.AND.MSGPKD(1:1).EQ.BLNK)) THEN
         IF (ERTYP2 .EQ. 6) IFERR6 = 1
         IF (ERTYP2 .EQ. 7) IFERR7 = 1
C                                  UPDATE CHECKSUM PARAMETER ERCKSM
         CALL E1UCS
C                                  PRINT MESSAGE IF NECESSARY
         IF (ERTYP2.GE.5 .AND. PRINTB(ERTYP2).EQ.1) CALL E1PRT
      ELSE
C                                  FILL UP MSGSAV WITH EXPANDED MESSAGE
         LEN2 = MIN0(LEN2,255)
         DO 10  I=1, LEN2
            MSGTMP(I) = MSGPKD(I:I)
   10    CONTINUE
         MS = 0
         M = 0
C                                  CHECK PLIST FOR KEYWORD NAME
         NLOC = I1DX(PLIST,PLEN,NCHECK,3)
         IF (NLOC.GT.0 .AND. HDRFMT(ERTYP2).EQ.3) THEN
C                                  M1VE INREF INTO MSGSAV
            CALL M1VE (INREF, 1, 25, 25, MSGSAV, 1, 25, 25, IER)
C                                  GET LENGTH OF KEYWORD NAME
            CALL C1TCI (PLIST(NLOC+3), 3, IPLEN, IER)
            PBEG = NLOC + 3 + IER
C                                  M1VE KEYWORD NAME INTO MSGSAV
            CALL M1VE (PLIST, PBEG, PBEG+IPLEN-1, PLEN, MSGSAV, 26,
     &                 IPLEN+25, 255, IER)
C                                  UPDATE POINTER
            MS = IPLEN + 25
         END IF
C                                  INSERT DOT, BLANK, BLANK
         CALL M1VE (DBB, 1, 3, 3, MSGSAV, MS+1, MS+3, 255, IER)
         MS = MS + 3
C                                  LOOK AT NEXT CHARACTER
   20    M = M + 1
         ISUB = 0
         IF (M .GT. LEN2-4) THEN
            LAST = LEN2 - M + 1
            DO 30  I=1, LAST
   30       MSGSAV(MS+I) = MSGTMP(M+I-1)
            MSGLEN = MS + LAST
            GO TO 40
         ELSE IF (MSGTMP(M).EQ.PERCNT .AND. MSGTMP(M+1).EQ.LPAR .AND.
     &           MSGTMP(M+4).EQ.RPAR) THEN
            CALL C1TCI (MSGTMP(M+3), 1, NUM, IER)
            IF (IER.EQ.0 .AND. NUM.NE.0 .AND. I1DX(FORMS,NFORMS,
     &          MSGTMP(M+2),1).NE.0) THEN
C                                  LOCATE THE ITEM IN THE PARAMETER LIST
               CALL M1VE (MSGTMP(M+2), 1, 2, 2, FIND, 2, 3, 4, IER)
               LOC = I1DX(PLIST,PLEN,FIND,4)
               IF (LOC .GT. 0) THEN
C                                  SET IPLEN = LENGTH OF STRING
                  CALL C1TCI (PLIST(LOC+4), 4, IPLEN, IER)
                  PBEG = LOC + 4 + IER
C                                  ADJUST IPLEN IF IT IS TOO BIG
                  IPLEN = MIN0(IPLEN,255-MS)
C                                  M1VE STRING FROM PLIST INTO MSGSAV
                  CALL M1VE (PLIST, PBEG, PBEG+IPLEN-1, PLEN, MSGSAV,
     &                       MS+1, MS+IPLEN, 255, IER)
                  IF (IER.GE.0 .AND. IER.LT.IPLEN) THEN
C                                  UPDATE POINTERS
                     M = M + 4
                     MS = MS + IPLEN - IER
C                                  BAIL OUT IF NO MORE ROOM
                     IF (MS .GE. 255) THEN
                        MSGLEN = 255
                        GO TO 40
                     END IF
C                                  SET FLAG TO SHOW SUBSTITION WAS MADE
                     ISUB = 1
                  END IF
               END IF
            END IF
         END IF
         IF (ISUB .EQ. 0) THEN
            MS = MS + 1
            MSGSAV(MS) = MSGTMP(M)
         END IF
         GO TO 20
   40    ERTYP2 = ERTYPE(CALLVL)
         IF (ERTYP2 .EQ. 6) IFERR6 = 1
         IF (ERTYP2 .EQ. 7) IFERR7 = 1
C                                  UPDATE CHECKSUM PARAMETER ERCKSM
         CALL E1UCS
C                                  PRINT MESSAGE IF NECESSARY
         IF (ERTYP2.GE.5 .AND. PRINTB(ERTYP2).EQ.1) CALL E1PRT
      END IF
C                                  CLEAR PARAMETER LIST
      PLEN = 1
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  E1POP
C
C  Computer:   DGC/SINGLE
C
C  Revised:    March 13, 1984
C
C  Purpose:    To pop a subroutine name from the error control stack.
C
C  Usage:      CALL E1POP(NAME)
C
C  Arguments:
C     NAME   - A character string of length six specifying the name
C              of the subroutine.  (Input)
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE E1POP (NAME)
C                                  SPECIFICATIONS FOR ARGUMENTS
      CHARACTER  NAME*(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    IERTYP, IR
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                              SPECIFICATIONS FOR COMMON /ERCOM1/
      INTEGER    CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51),
     &           PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7,
     &           IALLOC(51), HDRFMT(7), TRACON(7)
      COMMON     /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE,
     &           PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT,
     &           TRACON
      SAVE       /ERCOM1/
C                              SPECIFICATIONS FOR COMMON /ERCOM2/
      CHARACTER  MSGSAV(255), PLIST(300), RNAME(51)*6
      COMMON     /ERCOM2/ MSGSAV, PLIST, RNAME
      SAVE       /ERCOM2/
C                              SPECIFICATIONS FOR COMMON /ERCOM3/
      DOUBLE PRECISION ERCKSM
      COMMON     /ERCOM3/ ERCKSM
      SAVE       /ERCOM3/
C                              SPECIFICATIONS FOR COMMON /ERCOM4/
      LOGICAL    ISUSER(51)
      COMMON     /ERCOM4/ ISUSER
      SAVE       /ERCOM4/
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   E1MES, E1PRT, E1PSH, E1STI, E1STL, I1KRL
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   I1KST
      INTEGER    I1KST
C
      IF (CALLVL .LE. 1) THEN
         CALL E1PSH ('E1POP ')
         CALL E1STL (1, NAME)
         CALL E1MES (5, 1, 'Error condition in E1POP.  Cannot pop '//
     &               'from %(L1) because stack is empty.')
         STOP
      ELSE IF (NAME .NE. RNAME(CALLVL)) THEN
         CALL E1STL (1, NAME)
         CALL E1STL (2, RNAME(CALLVL))
         CALL E1MES (5, 2, 'Error condition in E1POP.  %(L1) does '//
     &               'not match the name %(L2) in the stack.')
         STOP
      ELSE
         IERTYP = ERTYPE(CALLVL)
         IF (IERTYP .NE. 0) THEN
C                                  M1VE ERROR TYPE AND ERROR CODE TO
C                                    PREVIOUS LEVEL FOR ERROR TYPES 2-7
            IF (IERTYP.GE.2 .AND. IERTYP.LE.7) THEN
               ERTYPE(CALLVL-1) = ERTYPE(CALLVL)
               ERCODE(CALLVL-1) = ERCODE(CALLVL)
            END IF
C                                  CHECK PRINT TABLE TO DETERMINE
C                                    WHETHER TO PRINT STORED MESSAGE
            IF (IERTYP .LE. 4) THEN
               IF (ISUSER(CALLVL-1) .AND. PRINTB(IERTYP).EQ.1)
     &             CALL E1PRT
            ELSE
               IF (PRINTB(IERTYP) .EQ. 1) CALL E1PRT
            END IF
C                                  CHECK STOP TABLE AND ERROR TYPE TO
C                                    DETERMINE WHETHER TO STOP
            IF (IERTYP .LE. 4) THEN
               IF (ISUSER(CALLVL-1) .AND. STOPTB(IERTYP).EQ.1) THEN
                  STOP
               END IF
            ELSE IF (IERTYP .EQ. 5) THEN
               IF (STOPTB(IERTYP) .EQ. 1) THEN
                  STOP
               END IF
            ELSE IF (HDRFMT(IERTYP) .EQ. 1) THEN
               IF (ISUSER(CALLVL-1)) THEN
                  IF (N1RGB(0) .NE. 0) THEN
                     STOP
                  END IF
               END IF
            END IF
         END IF
C                                  SET ERROR TYPE AND CODE
         IF (CALLVL .LT. MAXLEV) THEN
            ERTYPE(CALLVL+1) = -1
            ERCODE(CALLVL+1) = -1
         END IF
C                                  SET IR = AMOUNT OF WORKSPACE
C                                  ALLOCATED AT THIS LEVEL
         IR = I1KST(1) - IALLOC(CALLVL-1)
         IF (IR .GT. 0) THEN
C                                  RELEASE WORKSPACE
            CALL I1KRL (IR)
            IALLOC(CALLVL) = 0
         ELSE IF (IR .LT. 0) THEN
            CALL E1STI (1, CALLVL)
            CALL E1STI (2, IALLOC(CALLVL-1))
            CALL E1STI (3, I1KST(1))
            CALL E1MES (5, 3, 'Error condition in E1POP. '//
     &                  ' The number of workspace allocations at '//
     &                  'level %(I1) is %(I2).  However, the total '//
     &                  'number of workspace allocations is %(I3).')
            STOP
         END IF
C                                  DECREASE THE STACK POINTER BY ONE
         CALLVL = CALLVL - 1
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  E1PSH
C
C  Computer:   DGC/SINGLE
C
C  Revised:    March 2, 1984
C
C  Purpose:    To push a subroutine name onto the error control stack.
C
C  Usage:      CALL E1PSH(NAME)
C
C  Arguments:
C     NAME   - A character string of length six specifing the name of
C              the subroutine.  (Input)
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE E1PSH (NAME)
C                                  SPECIFICATIONS FOR ARGUMENTS
      CHARACTER  NAME*(*)
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      INTEGER    IFINIT
      SAVE       IFINIT
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                              SPECIFICATIONS FOR COMMON /ERCOM1/
      INTEGER    CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51),
     &           PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7,
     &           IALLOC(51), HDRFMT(7), TRACON(7)
      COMMON     /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE,
     &           PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT,
     &           TRACON
      SAVE       /ERCOM1/
C                              SPECIFICATIONS FOR COMMON /ERCOM2/
      CHARACTER  MSGSAV(255), PLIST(300), RNAME(51)*6
      COMMON     /ERCOM2/ MSGSAV, PLIST, RNAME
      SAVE       /ERCOM2/
C                              SPECIFICATIONS FOR COMMON /ERCOM3/
      DOUBLE PRECISION ERCKSM
      COMMON     /ERCOM3/ ERCKSM
      SAVE       /ERCOM3/
C                              SPECIFICATIONS FOR COMMON /ERCOM4/
      LOGICAL    ISUSER(51)
      COMMON     /ERCOM4/ ISUSER
      SAVE       /ERCOM4/
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   E1INIT, E1MES, E1STI
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   I1KST
      INTEGER    I1KST
C
      DATA IFINIT/0/
C                                  INITIALIZE ERROR TABLE IF NECESSARY
      IF (IFINIT .EQ. 0) THEN
         CALL E1INIT
         IFINIT = 1
      END IF
      IF (CALLVL .GE. MAXLEV) THEN
         CALL E1STI (1, MAXLEV)
         CALL E1MES (5, 1, 'Error condition in E1PSH.  Push would '//
     &               'cause stack level to exceed %(I1). ')
         STOP
      ELSE
C                                  STORE ALLOCATION LEVEL
         IALLOC(CALLVL) = I1KST(1)
C                                  INCREMENT THE STACK POINTER BY ONE
         CALLVL = CALLVL + 1
C                                  PUT SUBROUTINE NAME INTO STACK
         RNAME(CALLVL) = NAME
C                                  SET ERROR TYPE AND ERROR CODE
         ERTYPE(CALLVL) = 0
         ERCODE(CALLVL) = 0
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  E1STI
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    March 6, 1984
C
C  Purpose:    To store an integer for subsequent use within an error
C              message.
C
C  Usage:      CALL E1STI(II, IVALUE)
C
C  Arguments:
C     II     - Integer specifying the substitution index.  II must be
C              between 1 and 9.  (Input)
C     IVALUE - The integer to be stored.  (Input)
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE E1STI (II, IVALUE)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    II, IVALUE
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    IBEG, IER, ILEN
      CHARACTER  ARRAY(14)
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      INTEGER    IFINIT
      CHARACTER  BLANK(1)
      SAVE       BLANK, IFINIT
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                              SPECIFICATIONS FOR COMMON /ERCOM1/
      INTEGER    CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51),
     &           PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7,
     &           IALLOC(51), HDRFMT(7), TRACON(7)
      COMMON     /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE,
     &           PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT,
     &           TRACON
      SAVE       /ERCOM1/
C                              SPECIFICATIONS FOR COMMON /ERCOM2/
      CHARACTER  MSGSAV(255), PLIST(300), RNAME(51)*6
      COMMON     /ERCOM2/ MSGSAV, PLIST, RNAME
      SAVE       /ERCOM2/
C                              SPECIFICATIONS FOR COMMON /ERCOM3/
      DOUBLE PRECISION ERCKSM
      COMMON     /ERCOM3/ ERCKSM
      SAVE       /ERCOM3/
C                              SPECIFICATIONS FOR COMMON /ERCOM4/
      LOGICAL    ISUSER(51)
      COMMON     /ERCOM4/ ISUSER
      SAVE       /ERCOM4/
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   C1TIC, E1INIT, E1INPL
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   I1ERIF
      INTEGER    I1ERIF
C
      DATA BLANK/' '/, IFINIT/0/
C                                  INITIALIZE IF NECESSARY
      IF (IFINIT .EQ. 0) THEN
         CALL E1INIT
         IFINIT = 1
      END IF
      CALL C1TIC (IVALUE, ARRAY, 14, IER)
      IBEG = I1ERIF(ARRAY,14,BLANK,1)
      IF (II.GE.1 .AND. II.LE.9 .AND. IER.EQ.0) THEN
         ILEN = 15 - IBEG
         CALL E1INPL ('I', II, ILEN, ARRAY(IBEG))
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  I1KGT
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    January 17, 1984
C
C  Purpose:    Allocate numerical workspace.
C
C  Usage:      I1KGT(NELMTS,ITYPE)
C
C  Arguments:
C     NELMTS - Number of elements of data type ITYPE to be
C              allocated.  (Input)
C     ITYPE  - Data type of array to be allocated.  (Input)
C                 1 - logical
C                 2 - integer
C                 3 - real
C                 4 - double precision
C                 5 - complex
C                 6 - double complex
C     I1KGT  - Integer function.  (Output)  Returns the index of the
C              first element in the current allocation.
C
C  Remarks:
C  1. On return, the array will occupy
C     WKSP(I1KGT), WKSP(I1KGT+1), ..., WKSP(I1KGT+NELMTS-1) where
C     WKSP is an array of data type ITYPE equivalenced to RWKSP.
C
C  2. If I1KGT is negative, the absolute value of I1KGT is the
C     additional workspace needed for the current allocation.
C
C  3. The allocator reserves the first sixteen integer locations of
C     the stack for its own internal bookkeeping.  These are initialized
C     by the function IWKIN upon the first call to the allocation
C     package.
C
C  4. The use of the first ten integer locations is as follows:
C      WKSP( 1) - LOUT    The number of current allocations
C      WKSP( 2) - LNOW    The current active length of the stack
C      WKSP( 3) - LUSED   The maximum value of WKSP(2) achieved
C                         thus far
C      WKSP( 4) - LBND    The lower bound of permanent storage which
C                         is one numeric storage unit more than the
C                         maximum allowed length of the stack.
C      WKSP( 5) - LMAX    The maximum length of the storage array
C      WKSP( 6) - LALC    The total number of allocations handled by
C                         I1KGT
C      WKSP( 7) - LNEED   The number of numeric storage units by which
C                         the array size must be increased for all past
C                         allocations to succeed
C      WKSP( 8) - LBOOK   The number of numeric storage units used for
C                         bookkeeping
C      WKSP( 9) - LCHAR   The pointer to the portion of the permanent
C                         stack which contains the bookkeeping and
C                         pointers for the character workspace
C                         allocation.
C      WKSP(10) - LLCHAR  The length of the array beginning at LCHAR
C                         set aside for character workspace bookkeeping
C                         and pointers.
C                 NOTE -  If character workspace is not being used,
C                         LCHAR and LLCHAR can be ignored.
C  5. The next six integer locations contain values describing the
C     amount of storage allocated by the allocation system to the
C     various data types.
C      WKSP(11) - Numeric storage units allocated to LOGICAL
C      WKSP(12) - Numeric storage units allocated to INTEGER
C      WKSP(13) - Numeric storage units allocated to REAL
C      WKSP(14) - Numeric storage units allocated to DOUBLE PRECISION
C      WKSP(15) - Numeric storage units allocated to COMPLEX
C      WKSP(16) - Numeric storage units allocated to DOUBLE COMPLEX
C
C  Copyright:  1984 by IMSL, Inc. All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      INTEGER FUNCTION I1KGT (NELMTS, ITYPE)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    NELMTS, ITYPE
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, IDUMAL, IGAP, ILEFT, IPA, IPA7, ISA, ISA7,
     &           ISIZE(6), JTYPE, LALC, LBND, LBOOK, LMAX, LNEED,
     &           LNEED1, LNOW, LOUT, LUSED
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      LOGICAL    FIRST
      SAVE       FIRST
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                              SPECIFICATIONS FOR COMMON /ERCOM8/
      INTEGER    PROLVL, XXLINE(10), XXPLEN(10), ICALOC(10), INALOC(10)
      COMMON     /ERCOM8/ PROLVL, XXLINE, XXPLEN, ICALOC, INALOC
      SAVE       /ERCOM8/
C                              SPECIFICATIONS FOR COMMON /ERCOM9/
      CHARACTER  XXPROC(10)*31
      COMMON     /ERCOM9/ XXPROC
      SAVE       /ERCOM9/
C                                  SPECIFICATIONS FOR COMMON /WORKSP/
      REAL       RWKSP(61913)
      REAL       RDWKSP(5000)
      DOUBLE PRECISION DWKSP(2500)
      COMPLEX    CWKSP(2500)
      COMPLEX    CZWKSP(2500)
      COMPLEX    *16 ZWKSP(1250)
      INTEGER    IWKSP(5000)
      LOGICAL    LWKSP(5000)
      EQUIVALENCE (DWKSP(1), RWKSP(1))
      EQUIVALENCE (CWKSP(1), RWKSP(1)), (ZWKSP(1), RWKSP(1))
      EQUIVALENCE (IWKSP(1), RWKSP(1)), (LWKSP(1), RWKSP(1))
      EQUIVALENCE (RDWKSP(1), RWKSP(1)), (CZWKSP(1), RWKSP(1))
      COMMON     /WORKSP/ RWKSP
C                                  SPECIFICATIONS FOR EQUIVALENCE
      EQUIVALENCE (LOUT, IWKSP(1))
      EQUIVALENCE (LNOW, IWKSP(2))
      EQUIVALENCE (LUSED, IWKSP(3))
      EQUIVALENCE (LBND, IWKSP(4))
      EQUIVALENCE (LMAX, IWKSP(5))
      EQUIVALENCE (LALC, IWKSP(6))
      EQUIVALENCE (LNEED, IWKSP(7))
      EQUIVALENCE (LBOOK, IWKSP(8))
      EQUIVALENCE (ISIZE(1), IWKSP(11))
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  IABS,MAX0,MOD
      INTRINSIC  IABS, MAX0, MOD
      INTEGER    IABS, MAX0, MOD
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   E1MES, E1POP, E1POS, E1PSH, E1STI, IWKIN
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   I1KQU
      INTEGER    I1KQU
C
      DATA FIRST/.TRUE./
C
      CALL E1PSH ('I1KGT ')
C
      IF (FIRST) THEN
C                                  INITIALIZE WORKSPACE IF NEEDED
         FIRST = .FALSE.
         CALL IWKIN (0)
      END IF
C                                  NUMBER OF ELEMENTS LESS THAN 0
      IF (NELMTS .LT. 0) THEN
         CALL E1STI (1, NELMTS)
         CALL E1MES (5, 2, 'Number of elements is not positive.%/'//
     &               'NELMTS = %(I1).')
         CALL E1POP ('I1KGT ')
         GO TO 9000
      END IF
C                                  ILLEGAL DATA TYPE REQUESTED
      IF (ITYPE.EQ.0 .OR. IABS(ITYPE).GE.7) THEN
         CALL E1MES (5, 3, 'Illegal data type requested.')
         CALL E1POP ('I1KGT ')
         GO TO 9000
      END IF
C                                  BOOKKEEPING OVERWRITTEN
      IF (LNOW.LT.LBOOK .OR. LNOW.GT.LUSED .OR. LUSED.GT.LMAX .OR.
     &    LNOW.GE.LBND .OR. LOUT.GT.LALC) THEN
         CALL E1MES (5, 4, 'One or more of the first eight '//
     &               'bookkeeping locations in IWKSP have been '//
     &               'overwritten.')
         CALL E1POP ('I1KGT ')
         GO TO 9000
      END IF
C
      CALL E1POP ('I1KGT ')
C                                  DETERMINE NUMBER OF LOCATIONS STILL
C                                  AVAILABLE FOR DATA TYPE ITYPE
C                                  NOTE: I1KQU ALLOWS FOR 2 INTEGER
C                                        POINTERS WHICH MUST BE HANDLED
C                                        ARTIFICIALLY IF ILEFT = 0.
      ILEFT = I1KQU(IABS(ITYPE))
C
      IF (ITYPE .GT. 0) THEN
C                                  RELEASABLE STORAGE
         IF (ILEFT .GE. NELMTS) THEN
            I1KGT = (LNOW*ISIZE(2)-1)/ISIZE(ITYPE) + 2
            I = ((I1KGT-1+NELMTS)*ISIZE(ITYPE)-1)/ISIZE(2) + 3
C                                  IWKSP(I-1) CONTAINS THE DATA TYPE FOR
C                                  THIS ALLOCATION. IWKSP(I) CONTAINS
C                                  LNOW FOR THE PREVIOUS ALLOCATION.
            IWKSP(I-1) = ITYPE
            IWKSP(I) = LNOW
            LOUT = LOUT + 1
            LALC = LALC + 1
            LNOW = I
            LUSED = MAX0(LUSED,LNOW)
            LNEED = 0
         ELSE
C                                  RELEASABLE STORAGE WAS REQUESTED
C                                  BUT THE STACK WOULD OVERFLOW.
C                                  THEREFORE, ALLOCATE RELEASABLE
C                                  SPACE THROUGH THE END OF THE STACK
            IF (LNEED .EQ. 0) THEN
               IDUMAL = (LNOW*ISIZE(2)-1)/ISIZE(ITYPE) + 2
               I = ((IDUMAL-1+ILEFT)*ISIZE(ITYPE)-1)/ISIZE(2) + 3
C                                  ADVANCE COUNTERS AND STORE POINTERS
C                                  IF THERE IS ROOM TO DO SO
               IF (I .LT. LBND) THEN
C                                  IWKSP(I-1) CONTAINS THE DATA TYPE FOR
C                                  THIS ALLOCATION. IWKSP(I) CONTAINS
C                                  LNOW FOR THE PREVIOUS ALLOCATION.
                  IWKSP(I-1) = ITYPE
                  IWKSP(I) = LNOW
                  LOUT = LOUT + 1
                  LALC = LALC + 1
                  LNOW = I
                  LUSED = MAX0(LUSED,LNOW)
               END IF
            END IF
C                                  CALCULATE AMOUNT NEEDED TO ACCOMODATE
C                                  THIS ALLOCATION REQUEST
            LNEED1 = (NELMTS-ILEFT)*ISIZE(ITYPE)
            IF (ILEFT .EQ. 0) THEN
               IGAP = ISIZE(ITYPE) - MOD(LNOW+LNEED,ISIZE(ITYPE))
               IF (IGAP .EQ. ISIZE(ITYPE)) IGAP = 0
               LNEED1 = LNEED1 + 2*ISIZE(2) + IGAP
            END IF
C                                  MODIFY LNEED ACCORDING TO THE SIZE
C                                  OF THE BASE BEING USED (D.P. HERE)
            LNEED = LNEED + ((LNEED1+ISIZE(3)-1)/ISIZE(3))
C                                  SINCE CURRENT ALLOCATION IS ILLEGAL,
C                                  RETURN THE NEGATIVE OF THE ADDITIONAL
C                                  AMOUNT NEEDED TO MAKE IT LEGAL
            I1KGT = -LNEED
         END IF
      ELSE
C                                  PERMANENT STORAGE
         IF (ILEFT .GE. NELMTS) THEN
            JTYPE = -ITYPE
            I1KGT = (LBND*ISIZE(2)-1)/ISIZE(JTYPE) + 1 - NELMTS
            I = ((I1KGT-1)*ISIZE(JTYPE))/ISIZE(2) - 1
C                                  IWKSP(I) CONTAINS LBND FOR PREVIOUS
C                                  PERMANENT STORAGE ALLOCATION.
C                                  IWKSP(I+1) CONTAINS THE DATA TYPE FOR
C                                  THIS ALLOCATION.
            IWKSP(I) = LBND
            IWKSP(I+1) = JTYPE
            LALC = LALC + 1
            LBND = I
            LNEED = 0
         ELSE
C                                  PERMANENT STORAGE WAS REQUESTED
C                                  BUT THE STACK WOULD OVERFLOW,
C                                  THEREFORE, ALLOCATE RELEASABLE
C                                  SPACE THROUGH THE END OF THE STACK
            IF (LNEED .EQ. 0) THEN
               JTYPE = -ITYPE
               IDUMAL = (LNOW*ISIZE(2)-1)/ISIZE(JTYPE) + 2
               I = ((IDUMAL-1+ILEFT)*ISIZE(JTYPE)-1)/ISIZE(2) + 3
C                                  ADVANCE COUNTERS AND STORE POINTERS
C                                  IF THERE IS ROOM TO DO SO
               IF (I .LT. LBND) THEN
C                                  IWKSP(I-1) CONTAINS THE DATA TYPE FOR
C                                  THIS ALLOCATION. IWKSP(I) CONTAINS
C                                  LNOW FOR THE PREVIOUS ALLOCATION.
                  IWKSP(I-1) = JTYPE
                  IWKSP(I) = LNOW
                  LOUT = LOUT + 1
                  LALC = LALC + 1
                  LNOW = I
                  LUSED = MAX0(LUSED,LNOW)
               END IF
            END IF
C                                  CALCULATE AMOUNT NEEDED TO ACCOMODATE
C                                  THIS ALLOCATION REQUEST
            LNEED1 = (NELMTS-ILEFT)*ISIZE(-ITYPE)
            IF (ILEFT .EQ. 0) THEN
               IGAP = ISIZE(-ITYPE) - MOD(LNOW+LNEED,ISIZE(-ITYPE))
               IF (IGAP .EQ. ISIZE(-ITYPE)) IGAP = 0
               LNEED1 = LNEED1 + 2*ISIZE(2) + IGAP
            END IF
C                                  MODIFY LNEED ACCORDING TO THE SIZE
C                                  OF THE BASE BEING USED (D.P. HERE)
            LNEED = LNEED + ((LNEED1+ISIZE(3)-1)/ISIZE(3))
C                                  SINCE CURRENT ALLOCATION IS ILLEGAL,
C                                  RETURN THE NEGATIVE OF THE ADDITIONAL
C                                  AMOUNT NEEDED TO MAKE IT LEGAL
            I1KGT = -LNEED
         END IF
      END IF
C                                  STACK OVERFLOW - UNRECOVERABLE ERROR
 9000 IF (LNEED .GT. 0) THEN
         CALL E1POS (-5, IPA, ISA)
         CALL E1POS (5, 0, 0)
         CALL E1POS (-7, IPA7, ISA7)
         CALL E1POS (7, 0, 0)
         CALL E1PSH ('I1KGT ')
         CALL E1STI (1, LNEED+(LMAX/ISIZE(3)))
         IF (XXLINE(PROLVL).GE.1 .AND. XXLINE(PROLVL).LE.999) THEN
            CALL E1MES (7, 1, 'Insufficient workspace for current '//
     &                  'allocation(s).  Correct by inserting the '//
     &                  'following PROTRAN line: $OPTIONS;WORKSPACE=%'//
     &                  '(I1)')
         ELSE
            CALL E1MES (5, 5, 'Insufficient workspace for current '//
     &                  'allocation(s). Correct by calling IWKIN '//
     &                  'from main program with the three following '//
     &                  'statements:  (REGARDLESS OF PRECISION)%/'//
     &                  '      COMMON /WORKSP/  RWKSP%/      REAL '//
     &                  'RWKSP(%(I1))%/      CALL IWKIN(%(I1))')
         END IF
         CALL E1POP ('I1KGT ')
         CALL E1POS (5, IPA, ISA)
         CALL E1POS (7, IPA7, ISA7)
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  N1RCD
C
C  Computer:   DGC/SINGLE
C
C  Revised:    March 6, 1984
C
C  Purpose:    Retrieve an error code.
C
C  Usage:      N1RCD(IOPT)
C
C  Arguments:
C     IOPT   - Integer specifying the level.  (Input)
C              If IOPT=0 the error code for the current level is
C              returned.  If IOPT=1 the error code for the most
C              recently called routine (last pop) is returned.
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      INTEGER FUNCTION N1RCD (IOPT)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    IOPT
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                              SPECIFICATIONS FOR COMMON /ERCOM1/
      INTEGER    CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51),
     &           PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7,
     &           IALLOC(51), HDRFMT(7), TRACON(7)
      COMMON     /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE,
     &           PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT,
     &           TRACON
      SAVE       /ERCOM1/
C                              SPECIFICATIONS FOR COMMON /ERCOM2/
      CHARACTER  MSGSAV(255), PLIST(300), RNAME(51)*6
      COMMON     /ERCOM2/ MSGSAV, PLIST, RNAME
      SAVE       /ERCOM2/
C                              SPECIFICATIONS FOR COMMON /ERCOM3/
      DOUBLE PRECISION ERCKSM
      COMMON     /ERCOM3/ ERCKSM
      SAVE       /ERCOM3/
C                              SPECIFICATIONS FOR COMMON /ERCOM4/
      LOGICAL    ISUSER(51)
      COMMON     /ERCOM4/ ISUSER
      SAVE       /ERCOM4/
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   E1PRT, M1VECH
C
      IF (IOPT.NE.0 .AND. IOPT.NE.1) THEN
         ERTYPE(CALLVL) = 5
         ERCODE(CALLVL) = 1
         MSGLEN = 47
         CALL M1VECH ('.  The argument passed to N1RCD must be 0 or '//
     &                '1. ', MSGLEN, MSGSAV, MSGLEN)
         CALL E1PRT
         STOP
      ELSE
         N1RCD = ERCODE(CALLVL+IOPT)
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  SASUM (Single precision version)
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    August 9, 1986
C
C  Purpose:    Sum the absolute values of the components of a
C              single precision vector.
C
C  Usage:      SASUM(N, SX, INCX)
C
C  Arguments:
C     N      - Length of vectors X.  (Input)
C     SX     - Real vector of length N*INCX.  (Input)
C     INCX   - Displacement between elements of SX.  (Input)
C              X(I) is defined to be SX(1+(I-1)*INCX). INCX must be
C              greater than 0.
C     SASUM  - Single precision sum from I=1 to N of ABS(X(I)).
C              (Output)
C              X(I) refers to a specific element of SX.
C
C  GAMS:       D1a
C
C  Chapters:   MATH/LIBRARY Basic Matrix/Vector Operations
C              STAT/LIBRARY Mathematical Support
C
C  Copyright:  1986 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      REAL FUNCTION SASUM (N, SX, INCX)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    N, INCX
      REAL       SX(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, M, MP1, NINCX
C                                  SPECIFICATIONS FOR SPECIAL CASES
C     INTRINSIC  MOD
      INTRINSIC  MOD
      INTEGER    MOD
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  ABS
      INTRINSIC  ABS
      REAL       ABS
C
      SASUM = 0.0E0
      IF (N .GT. 0) THEN
         IF (INCX .NE. 1) THEN
C                                  CODE FOR INCREMENT NOT EQUAL TO 1
            NINCX = N*INCX
            DO 10  I=1, NINCX, INCX
               SASUM = SASUM + ABS(SX(I))
   10       CONTINUE
         ELSE
C                                  CODE FOR INCREMENT EQUAL TO 1
            M = MOD(N,6)
C                                  CLEAN-UP LOOP
            DO 30  I=1, M
               SASUM = SASUM + ABS(SX(I))
   30       CONTINUE
            MP1 = M + 1
            DO 40  I=MP1, N, 6
               SASUM = SASUM + ABS(SX(I)) + ABS(SX(I+1)) +
     &                 ABS(SX(I+2)) + ABS(SX(I+3)) + ABS(SX(I+4)) +
     &                 ABS(SX(I+5))
   40       CONTINUE
         END IF
      END IF
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  SCOPY (Single precision version)
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    August 9, 1986
C
C  Purpose:    Copy a vector X to a vector Y, both single precision.
C
C  Usage:      CALL SCOPY (N, SX, INCX, SY, INCY)
C
C  Arguments:
C     N      - Length of vectors X and Y.  (Input)
C     SX     - Real vector of length MAX(N*IABS(INCX),1).  (Input)
C     INCX   - Displacement between elements of SX.  (Input)
C              X(I) is defined to be.. SX(1+(I-1)*INCX) if INCX .GE. 0
C              or SX(1+(I-N)*INCX) if INCX .LT. 0.
C     SY     - Real vector of length MAX(N*IABS(INCY),1).  (Output)
C              SCOPY copies X(I) to Y(I) for I=1,...,N. X(I) and Y(I)
C              refer to specific elements of SX and SY, respectively.
C              See INCX and INCY argument descriptions.
C     INCY   - Displacement between elements of SY.  (Input)
C              Y(I) is defined to be.. SY(1+(I-1)*INCY) if INCY .GE. 0
C              or SY(1+(I-N)*INCY) if INCY .LT. 0.
C
C  GAMS:       D1a
C
C  Chapters:   MATH/LIBRARY Basic Matrix/Vector Operations
C              STAT/LIBRARY Mathematical Support
C
C  Copyright:  1986 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE SCOPY (N, SX, INCX, SY, INCY)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    N, INCX, INCY
      REAL       SX(*), SY(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, IX, IY, M, MP1
C                                  SPECIFICATIONS FOR SPECIAL CASES
C     INTRINSIC  MOD
      INTRINSIC  MOD
      INTEGER    MOD
C
      IF (N .GT. 0) THEN
         IF (INCX.NE.1 .OR. INCY.NE.1) THEN
C                                  CODE FOR UNEQUAL INCREMENTS
            IX = 1
            IY = 1
            IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
            IF (INCY .LT. 0) IY = (-N+1)*INCY + 1
            DO 10  I=1, N
               SY(IY) = SX(IX)
               IX = IX + INCX
               IY = IY + INCY
   10       CONTINUE
         ELSE
C                                  CODE FOR BOTH INCREMENTS EQUAL TO 1
            M = MOD(N,7)
C                                  CLEAN-UP LOOP
            DO 30  I=1, M
               SY(I) = SX(I)
   30       CONTINUE
            MP1 = M + 1
            DO 40  I=MP1, N, 7
               SY(I) = SX(I)
               SY(I+1) = SX(I+1)
               SY(I+2) = SX(I+2)
               SY(I+3) = SX(I+3)
               SY(I+4) = SX(I+4)
               SY(I+5) = SX(I+5)
               SY(I+6) = SX(I+6)
   40       CONTINUE
         END IF
      END IF
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  SGEMV  (Single precision version)
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    July 15, 1986
C
C  Purpose:    Perform the matrix-vector multiplication
C              y = alpha*A*x + beta*y or y = alpha*A'*x + beta*y,
C              all single precision.
C
C  Usage:      CALL SGEMV (TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y,
C                          INCY)
C
C  Arguments:
C     TRANS  - Character specifing the operation to be performed.
C              (Input)
C                 TRANS               Operation
C              'N' or 'n'      y = alpha*A*x + beta*y
C              'T' or 't'      y = alpha*A'*x + beta*y
C              'C' or 'c'      y = alpha*A'*x + beta*y
C     M      - Number of rows in A.  (Input)
C     N      - Number of columns in A.  (Input)
C     ALPHA  - Scalar.  (Input)
C     A      - Array of size M by N.  (Input)
C     LDA    - Leading dimension of A exactly as specified in the
C              calling routine.  (Input)
C     X      - Vector of length (N-1)*IABS(INCX)+1 when TRANS is
C              'N' or 'n' and of length (M-1)*IABS(INCX)+1 otherwise.
C              (Input)
C     INCX   - Displacement between elements of X.  (Input)
C     BETA   - Scalar.  (Input)
C              When BETA is zero, Y is not referenced.
C     Y      - Vector of length (N-1)*IABS(INCY)+1 when TRANS is
C              'M' or 'm' and of length (M-1)*IABS(INCY)+1 otherwise.
C              (Input/Output)
C     INCY   - Displacement between elements of Y.  (Input)
C
C  GAMS:       D1b
C
C  Chapter:    MATH/LIBRARY Basic Matrix/Vector Operations
C
C  Copyright:  1986 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE SGEMV (TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y,
     &                  INCY)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    M, N, LDA, INCX, INCY
      REAL       ALPHA, BETA, X(*), Y(*)
      CHARACTER  TRANS*1
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, IX, IY, KY, LENX, LENY
C                                  SPECIFICATIONS FOR SPECIAL CASES
      REAL       A(*)
      EXTERNAL   SAXPY, SDOT
      INTEGER    KX
      REAL       SDOT
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  IABS
      INTRINSIC  IABS
      INTEGER    IABS
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   SSCAL, SSET
C                                  Quick return if possible
      IF (M.EQ.0 .OR. N.EQ.0 .OR. (ALPHA.EQ.0.0) .AND. (BETA.EQ.1.0))
     &    GO TO 9000
C
      IF (TRANS.EQ.'N' .OR. TRANS.EQ.'n') THEN
         LENX = N
         LENY = M
      ELSE
         LENX = M
         LENY = N
      END IF
C
      IX = 1
      IY = 1
      IF (INCX .LT. 0) IX = (-LENX+1)*INCX + 1
      IF (INCY .LT. 0) IY = (-LENY+1)*INCY + 1
C
      IF (BETA .EQ. 1) THEN
      ELSE IF (INCY .EQ. 0) THEN
         IF (BETA .EQ. 0.0) THEN
            Y(1) = 0.0
         ELSE
            Y(1) = BETA**LENY*Y(1)
         END IF
      ELSE IF (BETA .EQ. 0.0) THEN
         CALL SSET (LENY, 0.0, Y, IABS(INCY))
      ELSE
         CALL SSCAL (LENY, BETA, Y, IABS(INCY))
      END IF
C
      IF (ALPHA .EQ. 0.0) GO TO 9000
C                                  Not transpose
      IF (TRANS.EQ.'N' .OR. TRANS.EQ.'n') THEN
         KX = IX
         DO 10  I=1, N
            CALL SAXPY (M, ALPHA*X(KX), A(LDA*(I-1)+1), 1, Y, INCY)
            KX = KX + INCX
   10    CONTINUE
      ELSE
C                                  Transpose
         KY = IY
         DO 20  I=1, N
            Y(KY) = Y(KY) + ALPHA*SDOT(M,A(LDA*(I-1)+1),1,X,INCX)
            KY = KY + INCY
   20    CONTINUE
      END IF
C
 9000 RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  SGER  (Single precision version)
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    July 15, 1986
C
C  Purpose:    Perform the rank-one matrix update A = alpha*x*y' + A,
C              all single precision.
C
C  Usage:      CALL SGER (M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
C
C  Arguments:
C     M      - Number of rows in A.  (Input)
C     N      - Number of columns in A.  (Input)
C     ALPHA  - Real scalar.  (Input)
C     X      - Real vector of length (M-1)*IABS(INCX)+1.  (Input)
C     INCX   - Displacement between elements of X.  (Input)
C     Y      - Real vector of length (N-1)*IABS(INCY)+1.  (Input)
C     INCY   - Displacement between elements of Y.  (Input)
C     A      - Array of size M by N.  (Input/Output)
C              On input, A contains the matrix to be updated.
C              On output, A contains the updated matrix.
C     LDA    - Leading dimension of A exactly as specified in the
C              calling routine.  (Input)
C
C  GAMS:       D1b
C
C  Chapter:    MATH/LIBRARY Basic Matrix/Vector Operations
C
C  Copyright:  1986 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE SGER (M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    M, N, INCX, INCY, LDA
      REAL       ALPHA, X(*), Y(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    IY, J
C                                  SPECIFICATIONS FOR SPECIAL CASES
      REAL       A(*)
      INTEGER    I1X
      EXTERNAL   SAXPY
C                                  Quick return if possible
      IF (M.EQ.0 .OR. N.EQ.0 .OR. ALPHA.EQ.0.0) GO TO 9000
C
      IY = 1
      IF (INCY .LT. 0) IY = (-N+1)*INCY + 1
C
      I1X = 1
      DO 10  J=1, N
         CALL SAXPY (M, ALPHA*Y(IY), X, INCX, A(I1X), 1)
         IY = IY + INCY
         I1X = I1X + LDA
   10 CONTINUE
C
 9000 RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  SNRM2 (Single precision version)
C
C  Computer:   DGC/SINGLE
C
C  Revised:    August 9, 1986
C
C  Purpose:    Compute the Euclidean length or L2 norm of a
C              single-precision vector.
C
C  Usage:      SNRM2(N, SX, INCX)
C
C  Arguments:
C     N      - Length of vector X.  (Input)
C     SX     - Real vector of length N*INCX.  (Input)
C     INCX   - Displacement between elements of SX.  (Input)
C              X(I) is defined to be SX(1+(I-1)*INCX). INCX must be
C              greater than zero.
C     SNRM2  - Square root of the sum from I=1 to N of X(I)**2.
C              (Output)
C              X(I) refers to a specific element of SX. See INCX
C              argument description.
C
C  GAMS:       D1a3b
C
C  Chapters:   MATH/LIBRARY Basic Matrix/Vector Operations
C              STAT/LIBRARY Mathematical Support
C
C  Copyright:  1986 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      REAL FUNCTION SNRM2 (N, SX, INCX)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    N, INCX
      REAL       SX(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, J, NEXT, NN
      REAL       HITEST, SUM, XMAX
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      REAL       CUTHI, CUTLO, ONE, ZERO
      SAVE       CUTHI, CUTLO, ONE, ZERO
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  ABS,SQRT
      INTRINSIC  ABS, SQRT
      REAL       ABS, SQRT
C
      DATA ZERO/0.0E0/, ONE/1.0E0/
      DATA CUTLO/4.441E-16/, CUTHI/1.304E19/
C
      IF (N .GT. 0) GO TO 10
      SNRM2 = ZERO
      GO TO 140
C
   10 ASSIGN 30 TO NEXT
      SUM = ZERO
      NN = N*INCX
C                                  BEGIN MAIN LOOP
      I = 1
   20 GO TO NEXT, (30, 40, 70, 80)
   30 IF (ABS(SX(I)) .GT. CUTLO) GO TO 110
      ASSIGN 40 TO NEXT
      XMAX = ZERO
C                                  PHASE 1. SUM IS ZERO
   40 IF (SX(I) .EQ. ZERO) GO TO 130
      IF (ABS(SX(I)) .GT. CUTLO) GO TO 110
C                                  PREPARE FOR PHASE 2.
      ASSIGN 70 TO NEXT
      GO TO 60
C                                  PREPARE FOR PHASE 4.
   50 I = J
      ASSIGN 80 TO NEXT
      SUM = (SUM/SX(I))/SX(I)
   60 XMAX = ABS(SX(I))
      GO TO 90
C                                  PHASE 2. SUM IS SMALL. SCALE TO
C                                  AVOID DESTRUCTIVE UNDERFLOW.
   70 IF (ABS(SX(I)) .GT. CUTLO) GO TO 100
C                                  COMMON CODE FOR PHASES 2 AND 4. IN
C                                  PHASE 4 SUM IS LARGE. SCALE TO
C                                  AVOID OVERFLOW.
   80 IF (ABS(SX(I)) .LE. XMAX) GO TO 90
      SUM = ONE + SUM*(XMAX/SX(I))**2
      XMAX = ABS(SX(I))
      GO TO 130
C
   90 SUM = SUM + (SX(I)/XMAX)**2
      GO TO 130
C                                  PREPARE FOR PHASE 3.
  100 SUM = (SUM*XMAX)*XMAX
C                                  FOR REAL OR D.P. SET HITEST =
C                                  CUTHI/N FOR COMPLEX SET HITEST =
C                                  CUTHI/(2*N)
  110 HITEST = CUTHI/N
C                                  PHASE 3. SUM IS MID-RANGE. NO
C                                  SCALING.
      DO 120  J=I, NN, INCX
         IF (ABS(SX(J)) .GE. HITEST) GO TO 50
  120 SUM = SUM + SX(J)*SX(J)
      SNRM2 = SQRT(SUM)
      GO TO 140
C
  130 CONTINUE
      I = I + INCX
      IF (I .LE. NN) GO TO 20
C                                  END OF MAIN LOOP. COMPUTE SQUARE
C                                  ROOT AND ADJUST FOR SCALING.
      SNRM2 = XMAX*SQRT(SUM)
  140 CONTINUE
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  SROT (Single precision version)
C
C  Computer:   DGC/SINGLE
C
C  Revised:    August 9, 1986
C
C  Purpose:    Apply a Givens plane rotation in single precision.
C
C  Usage:      CALL SROT (N, SX, INCX, SY, INCY, C, S)
C
C  Arguments:
C     N      - Length of vectors X and Y.  (Input)
C     SX     - Real vector of length MAX(N*IABS(INCX),1).
C              (Input/Output)
C              SROT replaces X(I) with SC*X(I) + SS*Y(I) for I=1,...,N.
C              X(I) and Y(I) refer to specific elements of SX and SY.
C     INCX   - Displacement between elements of SX.  (Input)
C              X(I) is defined to be
C                 SX(1+(I-1)*INCX) if INCX.GE.0  or
C                 SX(1+(I-N)*INCX) if INCX.LT.0.
C     SY     - Real vector of length MAX(N*IABS(INCY),1).
C              (Input/Output)
C              SROT replaces Y(I) with -SS*X(I) + SC*Y(I) for I=1,...,N.
C              X(I) and Y(I) refer to specific elements of SX and SY.
C     INCY   - Displacement between elements of SY.  (Input)
C              Y(I) is defined to be
C                 SY(1+(I-1)*INCY) if INCY.GE.0  or
C                 SY(1+(I-N)*INCY) if INCY.LT.0.
C     C      - Real scalar containing elements of the rotation matrix.
C              (Input)
C     S      - Real scalar containing elements of the rotation matrix.
C              (Input)
C
C  Remark:
C                  ( SC SS )    (X(1) ... X(N))
C     SROT applies (       ) to (             )
C                  (-SS SC )    (Y(1) ... Y(N))
C
C  GAMS:       D1a8
C
C  Chapters:   MATH/LIBRARY Basic Matrix/Vector Operations
C              STAT/LIBRARY Mathematical Support
C
C  Copyright:  1986 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE SROT (N, SX, INCX, SY, INCY, C, S)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    N, INCX, INCY
      REAL       C, S, SX(*), SY(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, IX, IY
      REAL       STEMP
C
      IF (N .GT. 0) THEN
         IF (INCX.NE.1 .OR. INCY.NE.1) THEN
C                                  CODE FOR UNEQUAL INCREMENTS OR EQUAL
C                                    INCREMENTS NOT EQUAL TO 1
            IX = 1
            IY = 1
            IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
            IF (INCY .LT. 0) IY = (-N+1)*INCY + 1
            DO 10  I=1, N
               STEMP = C*SX(IX) + S*SY(IY)
               SY(IY) = C*SY(IY) - S*SX(IX)
               SX(IX) = STEMP
               IX = IX + INCX
               IY = IY + INCY
   10       CONTINUE
         ELSE
C                                  CODE FOR BOTH INCREMENTS EQUAL TO 1
            DO 20  I=1, N
               STEMP = C*SX(I) + S*SY(I)
               SY(I) = C*SY(I) - S*SX(I)
               SX(I) = STEMP
   20       CONTINUE
         END IF
      END IF
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  SROTG (Single precision version)
C
C  Computer:   DGC/SINGLE
C
C  Revised:    August 9, 1986
C
C  Purpose:    Construct a Givens plane rotation in single precision.
C
C  Usage:      CALL SROTG (SA, SB, SC, SS)
C
C  Arguments:
C     SA     - First element of vector.  (Input/Output)
C              On output, R = (+/-)SQRT(SA**2 + SB**2) overwrites SA.
C     SB     - Second element of vector.  (Input/Output)
C              On output, Z overwrites SB where Z is defined to be
C                SS        if ABS(SA) .GT. ABS(SB)
C                1.0/SC    if ABS(SB) .GE. ABS(SA) and SC .NE. 0.0
C                1.0       if SC .EQ. 0.0.
C     SC     - Real scalar containing elements of the rotation matrix.
C              (Output)
C     SS     - Real scalar containing elements of the rotation matrix.
C              (Output)
C
C  Remark:
C     SROTG constructs the Givens rotation
C                         ( SC  SS )
C                     G = (        ) , SC**2 + SS**2 = 1
C                         (-SS  SC )
C     which zeros the second element of (SA SB)(transpose).
C
C  GAMS:       D1a8
C
C  Chapters:   MATH/LIBRARY Basic Matrix/Vector Operations
C              STAT/LIBRARY Mathematical Support
C
C  Copyright:  1986 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE SROTG (SA, SB, SC, SS)
C                                  SPECIFICATIONS FOR ARGUMENTS
      REAL       SA, SB, SC, SS
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      REAL       R, U, V
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  ABS,SQRT
      INTRINSIC  ABS, SQRT
      REAL       ABS, SQRT
C
      IF (ABS(SA) .GT. ABS(SB)) THEN
C                                  HERE ABS(SA) .GT. ABS(SB)
         U = SA + SA
         V = SB/U
C                                  NOTE THAT U AND R HAVE THE SIGN OF
C                                    SA
         R = SQRT(.25+V**2)*U
C                                  NOTE THAT SC IS POSITIVE
         SC = SA/R
         SS = V*(SC+SC)
         SB = SS
         SA = R
      ELSE
C                                  HERE ABS(SA) .LE. ABS(SB)
         IF (SB .NE. 0.0) THEN
            U = SB + SB
            V = SA/U
C                                  NOTE THAT U AND R HAVE THE SIGN OF
C                                    SB (R IS IMMEDIATELY STORED IN SA)
            SA = SQRT(.25+V**2)*U
C                                  NOTE THAT SS IS POSITIVE
            SS = SB/SA
            SC = V*(SS+SS)
            IF (SC .NE. 0.0) THEN
               SB = 1.0/SC
            ELSE
               SB = 1.0
            END IF
C                                  HERE SA = SB = 0.
         ELSE
            SC = 1.0
            SS = 0.0
            SA = 0.0
            SB = 0.0
         END IF
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  SSCAL (Single precision version)
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    August 9, 1986
C
C  Purpose:    Multiply a vector by a scalar, y = ay, both single
C              precision.
C
C  Usage:      CALL SSCAL (N, SA, SX, INCX)
C
C  Arguments:
C     N      - Length of vector X.  (Input)
C     SA     - Real scalar.  (Input)
C     SX     - Real vector of length N*INCX.  (Input/Output)
C              SSCAL replaces X(I) with SA*X(I) for I=1,...,N. X(I)
C              refers to a specific element of SX. See INCX argument
C              description.
C     INCX   - Displacement between elements of SX.  (Input)
C              X(I) is defined to be SX(1+(I-1)*INCX). INCX must be
C              greater than zero.
C
C  GAMS:       D1a6
C
C  Chapters:   MATH/LIBRARY Basic Matrix/Vector Operations
C              STAT/LIBRARY Mathematical Support
C
C  Copyright:  1986 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE SSCAL (N, SA, SX, INCX)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    N, INCX
      REAL       SA, SX(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, M, MP1, NS
C
      IF (N .GT. 0) THEN
         IF (INCX .NE. 1) THEN
C                                  CODE FOR INCREMENTS NOT EQUAL TO 1.
            NS = N*INCX
            DO 10  I=1, NS, INCX
               SX(I) = SA*SX(I)
   10       CONTINUE
         ELSE
C                                  CODE FOR INCREMENTS EQUAL TO 1.
C                                  CLEAN-UP LOOP SO REMAINING VECTOR
C                                  LENGTH IS A MULTIPLE OF 5.
            M = N - (N/5)*5
            DO 30  I=1, M
               SX(I) = SA*SX(I)
   30       CONTINUE
            MP1 = M + 1
            DO 40  I=MP1, N, 5
               SX(I) = SA*SX(I)
               SX(I+1) = SA*SX(I+1)
               SX(I+2) = SA*SX(I+2)
               SX(I+3) = SA*SX(I+3)
               SX(I+4) = SA*SX(I+4)
   40       CONTINUE
         END IF
      END IF
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  SSET (Single precision version)
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    August 9, 1986
C
C  Purpose:    Set the components of a vector to a scalar, all
C              single precision.
C
C  Usage:      CALL SSET (N, SA, SX, INCX)
C
C  Arguments:
C     N      - Length of vector X.  (Input)
C     SA     - Real scalar.  (Input)
C     SX     - Real vector of length N*INCX.  (Input/Output)
C              SSET replaces X(I) with SA for I=1,...,N. X(I) refers to
C              a specific element of SX. See INCX argument description.
C     INCX   - Displacement between elements of SX.  (Input)
C              X(I) is defined to be SX(1+(I-1)*INCX). INCX must be
C              greater than zero.
C
C  GAMS:       D1a1
C
C  Chapters:   MATH/LIBRARY Basic Matrix/Vector Operations
C              STAT/LIBRARY Mathematical Support
C
C  Copyright:  1986 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE SSET (N, SA, SX, INCX)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    N, INCX
      REAL       SA, SX(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, M, MP1, NINCX
C                                  SPECIFICATIONS FOR SPECIAL CASES
C     INTRINSIC  MOD
      INTRINSIC  MOD
      INTEGER    MOD
C
      IF (N .GT. 0) THEN
         IF (INCX .NE. 1) THEN
C                                  CODE FOR INCREMENT NOT EQUAL TO 1
            NINCX = N*INCX
            DO 10  I=1, NINCX, INCX
               SX(I) = SA
   10       CONTINUE
         ELSE
C                                  CODE FOR INCREMENT EQUAL TO 1
            M = MOD(N,8)
C                                  CLEAN-UP LOOP
            DO 30  I=1, M
               SX(I) = SA
   30       CONTINUE
            MP1 = M + 1
            DO 40  I=MP1, N, 8
               SX(I) = SA
               SX(I+1) = SA
               SX(I+2) = SA
               SX(I+3) = SA
               SX(I+4) = SA
               SX(I+5) = SA
               SX(I+6) = SA
               SX(I+7) = SA
   40       CONTINUE
         END IF
      END IF
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  SSWAP (Single precision version)
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    August 9, 1986
C
C  Purpose:    Interchange vectors X and Y, both single precision.
C
C  Usage:      CALL SSWAP (N, SX, INCX, SY, INCY)
C
C  Arguments:
C     N      - Length of vectors X and Y.  (Input)
C     SX     - Real vector of length MAX(N*IABS(INCX),1).
C              (Input/Output)
C     INCX   - Displacement between elements of SX.  (Input)
C              X(I) is defined to be
C                 SX(1+(I-1)*INCX) if INCX.GE.0  or
C                 SX(1+(I-N)*INCX) if INCX.LT.0.
C     SY     - Real vector of length MAX(N*IABS(INCY),1).
C              (Input/Output)
C     INCY   - Displacement between elements of SY.  (Input)
C              Y(I) is defined to be
C                 SY(1+(I-1)*INCY) if INCY.GE.0  or
C                 SY(1+(I-N)*INCY) if INCY.LT.0.
C
C  GAMS:       D1a5
C
C  Chapters:   MATH/LIBRARY Basic Matrix/Vector Operations
C              STAT/LIBRARY Mathematical Support
C
C  Copyright:  1986 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE SSWAP (N, SX, INCX, SY, INCY)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    N, INCX, INCY
      REAL       SX(*), SY(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, IX, IY, M, MP1
      REAL       STEMP
C                                  SPECIFICATIONS FOR SPECIAL CASES
C     INTRINSIC  MOD
      INTRINSIC  MOD
      INTEGER    MOD
C
      IF (N .GT. 0) THEN
         IF (INCX.NE.1 .OR. INCY.NE.1) THEN
C                                  CODE FOR UNEQUAL INCREMENTS OR EQUAL
C                                    INCREMENTS NOT EQUAL TO 1
            IX = 1
            IY = 1
            IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
            IF (INCY .LT. 0) IY = (-N+1)*INCY + 1
            DO 10  I=1, N
               STEMP = SX(IX)
               SX(IX) = SY(IY)
               SY(IY) = STEMP
               IX = IX + INCX
               IY = IY + INCY
   10       CONTINUE
         ELSE
C                                  CODE FOR BOTH INCREMENTS EQUAL TO 1
            M = MOD(N,3)
C                                  CLEAN-UP LOOP
            DO 30  I=1, M
               STEMP = SX(I)
               SX(I) = SY(I)
               SY(I) = STEMP
   30       CONTINUE
            MP1 = M + 1
            DO 40  I=MP1, N, 3
               STEMP = SX(I)
               SX(I) = SY(I)
               SY(I) = STEMP
               STEMP = SX(I+1)
               SX(I+1) = SY(I+1)
               SY(I+1) = STEMP
               STEMP = SX(I+2)
               SX(I+2) = SY(I+2)
               SY(I+2) = STEMP
   40       CONTINUE
         END IF
      END IF
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  C1TCI
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    August 13, 1984
C
C  Purpose:    Convert character string into corresponding integer
C              form.
C
C  Usage:      CALL C1TCI (CHRSTR, SLEN, NUM, IER)
C
C  Arguments:
C   CHRSTR  - Character array that contains the number description.
C             (Input)
C   SLEN    - Length of the character array.  (Input)
C   NUM     - The answer.  (Output)
C   IER     - Completion code.  (Output)  Where
C                IER =-2  indicates that the number is too large to
C                         be converted;
C                IER =-1  indicates that SLEN <= 0;
C                IER = 0  indicates normal completion;
C                IER > 0  indicates that the input string contains a
C                         nonnumeric character.  IER is the index of
C                         the first nonnumeric character in CHRSTR.
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE C1TCI (CHRSTR, SLEN, NUM, IER)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    SLEN, NUM, IER
      CHARACTER  CHRSTR(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    COUNT, I, IMACH5, J, N, S, SIGN
      CHARACTER  ZERO
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      CHARACTER  BLANK, DIGIT*10, MINUS, PLUS
      SAVE       BLANK, DIGIT, MINUS, PLUS
C                                  SPECIFICATIONS FOR EQUIVALENCE
      EQUIVALENCE (DIGIT, ZERO)
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  INDEX
      INTRINSIC  INDEX
      INTEGER    INDEX
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   IMACH
      INTEGER    IMACH
C
      DATA DIGIT/'0123456789'/
      DATA BLANK/' '/, MINUS/'-'/, PLUS/'+'/
C
C                                  CHECK SLEN
      NUM = 0
      IF (SLEN .LE. 0) THEN
         IER = -1
         GO TO 50
      END IF
C                                  HANDLE LEADING BLANKS
      SIGN = 1
      I = 1
   10 IF (I .LE. SLEN) THEN
         IF (CHRSTR(I) .EQ. BLANK) THEN
            I = I + 1
            GO TO 10
         END IF
      ELSE
         IER = 1
         GO TO 50
      END IF
C                                  CHECK FOR SIGN, IF ANY
      S = I
      IF (CHRSTR(I) .EQ. MINUS) THEN
         SIGN = -1
         I = I + 1
      ELSE IF (CHRSTR(I) .EQ. PLUS) THEN
         I = I + 1
      END IF
   20 IF (I .LE. SLEN) THEN
         IF (CHRSTR(I) .EQ. BLANK) THEN
            I = I + 1
            GO TO 20
         END IF
      ELSE
         IER = S
         GO TO 50
      END IF
C                                  SKIP LEADING ZERO
      J = I
   30 IF (I .LE. SLEN) THEN
         IF (CHRSTR(I) .EQ. ZERO) THEN
            I = I + 1
            GO TO 30
         END IF
      ELSE
         IER = 0
         GO TO 50
      END IF
C                                  CHECK FIRST NONBLANK CHARACTER
      COUNT = 0
C                                  CHECK NUMERIC CHARACTERS
      IMACH5 = IMACH(5)
   40 N = INDEX(DIGIT,CHRSTR(I))
      IF (N .NE. 0) THEN
         COUNT = COUNT + 1
         IF (NUM .GT. ((IMACH5-N)+1)/10) THEN
            IER = -2
            GO TO 50
         ELSE
            NUM = NUM*10 - 1 + N
            I = I + 1
            IF (I .LE. SLEN) GO TO 40
         END IF
      END IF
C
      IF (COUNT .EQ. 0) THEN
         IF (I .GT. J) THEN
            IER = I
         ELSE
            IER = S
         END IF
      ELSE IF (I .GT. SLEN) THEN
         NUM = SIGN*NUM
         IER = 0
      ELSE
         NUM = SIGN*NUM
         IER = I
      END IF
C
   50 CONTINUE
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  E1INIT
C
C  Computer:   DGC/SINGLE
C
C  Revised:    March 13, 1984
C
C  Purpose:    Initialization.
C
C  Usage:      CALL E1INIT
C
C  Arguments:  None
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE E1INIT
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    L
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      INTEGER    ISINIT
      SAVE       ISINIT
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                              SPECIFICATIONS FOR COMMON /ERCOM1/
      INTEGER    CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51),
     &           PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7,
     &           IALLOC(51), HDRFMT(7), TRACON(7)
      COMMON     /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE,
     &           PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT,
     &           TRACON
      SAVE       /ERCOM1/
C                              SPECIFICATIONS FOR COMMON /ERCOM2/
      CHARACTER  MSGSAV(255), PLIST(300), RNAME(51)*6
      COMMON     /ERCOM2/ MSGSAV, PLIST, RNAME
      SAVE       /ERCOM2/
C                              SPECIFICATIONS FOR COMMON /ERCOM3/
      DOUBLE PRECISION ERCKSM
      COMMON     /ERCOM3/ ERCKSM
      SAVE       /ERCOM3/
C                              SPECIFICATIONS FOR COMMON /ERCOM4/
      LOGICAL    ISUSER(51)
      COMMON     /ERCOM4/ ISUSER
      SAVE       /ERCOM4/
C                              SPECIFICATIONS FOR COMMON /ERCOM8/
      INTEGER    PROLVL, XXLINE(10), XXPLEN(10), ICALOC(10), INALOC(10)
      COMMON     /ERCOM8/ PROLVL, XXLINE, XXPLEN, ICALOC, INALOC
      SAVE       /ERCOM8/
C                              SPECIFICATIONS FOR COMMON /ERCOM9/
      CHARACTER  XXPROC(10)*31
      COMMON     /ERCOM9/ XXPROC
      SAVE       /ERCOM9/
C
      DATA ISINIT/0/
C
      IF (ISINIT .EQ. 0) THEN
C                                  INITIALIZE
         CALLVL = 1
         ERCODE(1) = 0
         ERTYPE(1) = 0
         IALLOC(1) = 0
         ISUSER(1) = .TRUE.
         IFERR6 = 0
         IFERR7 = 0
         PLEN = 1
         MAXLEV = 50
         DO 10  L=2, 51
            ERTYPE(L) = -1
            ERCODE(L) = -1
            IALLOC(L) = 0
            ISUSER(L) = .FALSE.
   10    CONTINUE
         DO 20  L=1, 7
            HDRFMT(L) = 1
            TRACON(L) = 1
   20    CONTINUE
         PROLVL = 1
         DO 30  L=1, 10
   30    ICALOC(L) = 0
         XXLINE(1) = 0
         XXPLEN(1) = 1
         XXPROC(1) = '?'
         RNAME(1) = 'USER'
         PRINTB(1) = 0
         PRINTB(2) = 0
         DO 40  L=3, 7
   40    PRINTB(L) = 1
         STOPTB(1) = 0
         STOPTB(2) = 0
         STOPTB(3) = 0
         STOPTB(4) = 1
         STOPTB(5) = 1
         STOPTB(6) = 0
         STOPTB(7) = 1
         ERCKSM = 0.0D0
C                                  SET FLAG TO INDICATE THAT
C                                    INITIALIZATION HAS OCCURRED
         ISINIT = 1
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  E1PRT
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    March 14, 1984
C
C  Purpose:    To print an error message.
C
C  Usage:      CALL E1PRT
C
C  Arguments:  None
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE E1PRT
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    ALL, I, IBEG, IBLOC, IBLOC2, IEND, IER, IHDR, J,
     &           LERTYP, LOC, LOCM1, LOCX, MAXLOC, MAXTMP, MLOC, MOD,
     &           NCBEG, NLOC, NOUT
      CHARACTER  MSGTMP(70), STRING(10)
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      CHARACTER  ATLINE(9), BLANK(1), DBB(3), FROM(6), MSGTYP(8,7),
     &           PERSLA(2), QMARK, UNKNOW(8)
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                              SPECIFICATIONS FOR COMMON /ERCOM1/
      INTEGER    CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51),
     &           PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7,
     &           IALLOC(51), HDRFMT(7), TRACON(7)
      COMMON     /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE,
     &           PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT,
     &           TRACON
      SAVE       /ERCOM1/
C                              SPECIFICATIONS FOR COMMON /ERCOM2/
      CHARACTER  MSGSAV(255), PLIST(300), RNAME(51)*6
      COMMON     /ERCOM2/ MSGSAV, PLIST, RNAME
      SAVE       /ERCOM2/
C                              SPECIFICATIONS FOR COMMON /ERCOM3/
      DOUBLE PRECISION ERCKSM
      COMMON     /ERCOM3/ ERCKSM
      SAVE       /ERCOM3/
C                              SPECIFICATIONS FOR COMMON /ERCOM4/
      LOGICAL    ISUSER(51)
      COMMON     /ERCOM4/ ISUSER
      SAVE       /ERCOM4/
C                              SPECIFICATIONS FOR COMMON /ERCOM8/
      INTEGER    PROLVL, XXLINE(10), XXPLEN(10), ICALOC(10), INALOC(10)
      COMMON     /ERCOM8/ PROLVL, XXLINE, XXPLEN, ICALOC, INALOC
      SAVE       /ERCOM8/
C                              SPECIFICATIONS FOR COMMON /ERCOM9/
      CHARACTER  XXPROC(10)*31
      COMMON     /ERCOM9/ XXPROC
      SAVE       /ERCOM9/
      SAVE       ATLINE, BLANK, DBB, FROM, MSGTYP, PERSLA, QMARK,
     &           UNKNOW
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  MIN0
      INTRINSIC  MIN0
      INTEGER    MIN0
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   C1TIC, M1VE, UMACH
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   I1DX, I1ERIF
      INTEGER    I1DX, I1ERIF
C
      DATA MSGTYP/'N', 'O', 'T', 'E', ' ', ' ', ' ', ' ', 'A',
     &     'L', 'E', 'R', 'T', ' ', ' ', ' ', 'W', 'A', 'R',
     &     'N', 'I', 'N', 'G', ' ', 'F', 'A', 'T', 'A', 'L',
     &     ' ', ' ', ' ', 'T', 'E', 'R', 'M', 'I', 'N', 'A',
     &     'L', 'W', 'A', 'R', 'N', 'I', 'N', 'G', ' ', 'F',
     &     'A', 'T', 'A', 'L', ' ', ' ', ' '/
      DATA UNKNOW/'U', 'N', 'K', 'N', 'O', 'W', 'N', ' '/
      DATA ATLINE/' ', 'a', 't', ' ', 'l', 'i', 'n', 'e', ' '/
      DATA BLANK/' '/, FROM/' ', 'f', 'r', 'o', 'm', ' '/
      DATA DBB/'.', ' ', ' '/, PERSLA/'%', '/'/
      DATA QMARK/'?'/
C
      IF (MSGLEN .LE. 0) RETURN
      CALL UMACH (2, NOUT)
      MAXTMP = 70
      MOD = 0
      LERTYP = ERTYPE(CALLVL)
      IHDR = HDRFMT(LERTYP)
      IF (IHDR .EQ. 3) THEN
         IF (XXPROC(PROLVL)(1:1).EQ.QMARK .AND. XXLINE(PROLVL).EQ.0)
     &       THEN
            IHDR = 1
         END IF
      END IF
      IEND = 0
      IF (IHDR.EQ.1 .AND. ERTYPE(CALLVL).LE.4) THEN
         MSGTMP(1) = BLANK(1)
         IEND = 1
C                                  CONVERT ERROR CODE INTO CHAR STRING
         CALL C1TIC (ERCODE(CALLVL), STRING, 10, IER)
C                                  LOCATE START OF NON-BLANK CHARACTERS
         IBEG = I1ERIF(STRING,10,BLANK,1)
C                                  M1VE IT TO MSGTMP
         CALL M1VE (STRING, IBEG, 10, 10, MSGTMP, IEND+1,
     &              IEND+11-IBEG, MAXTMP, IER)
         IEND = IEND + 11 - IBEG
      END IF
      IF (IHDR .NE. 2) THEN
         CALL M1VE (FROM, 1, 6, 6, MSGTMP, IEND+1, IEND+6, MAXTMP, IER)
         IEND = IEND + 6
      END IF
      IF (IHDR .EQ. 3) THEN
C                                  THIS IS A PROTRAN RUN TIME ERROR MSG.
C                                  RETRIEVE THE PROCEDURE NAME
         CALL M1VE (XXPROC(PROLVL), 1, XXPLEN(PROLVL), 31, MSGTMP,
     &              IEND+1, IEND+XXPLEN(PROLVL), MAXTMP, IER)
         MLOC = IEND + XXPLEN(PROLVL) + 1
         MSGTMP(MLOC) = BLANK(1)
         IEND = IEND + I1DX(MSGTMP(IEND+1),XXPLEN(PROLVL)+1,BLANK,1) -
     &          1
         IF (XXLINE(PROLVL) .GT. 0) THEN
C                                  INSERT ATLINE
            CALL M1VE (ATLINE, 1, 9, 9, MSGTMP, IEND+1, IEND+9,
     &                 MAXTMP, IER)
            IEND = IEND + 9
C                                  CONVERT PROTRAN GLOBAL LINE NUMBER
            CALL C1TIC (XXLINE(PROLVL), STRING, 10, IER)
C                                  LOCATE START OF NON-BLANK CHARACTERS
            IBEG = I1ERIF(STRING,10,BLANK,1)
C                                  M1VE GLOBAL LINE NUMBER TO MSGTMP
            CALL M1VE (STRING, IBEG, 10, 10, MSGTMP, IEND+1,
     &                 IEND+11-IBEG, MAXTMP, IER)
            IEND = IEND + 11 - IBEG
         END IF
      ELSE
C                                  THIS IS EITHER A LIBRARY ERROR MSG
C                                  OR A PROTRAN PREPROCESSOR ERROR MSG
         IF (IHDR .EQ. 1) THEN
C                                  THIS IS A LIBRARY ERROR MESSAGE.
C                                  RETRIEVE ROUTINE NAME
            CALL M1VE (RNAME(CALLVL), 1, 6, 6, MSGTMP, IEND+1, IEND+6,
     &                 MAXTMP, IER)
            MSGTMP(IEND+7) = BLANK(1)
            IEND = IEND + I1DX(MSGTMP(IEND+1),7,BLANK,1) - 1
         END IF
C                                  ADD DOT, BLANK, BLANK IF NEEDED
         IF (I1DX(MSGSAV,3,DBB,3) .NE. 1) THEN
            CALL M1VE (DBB, 1, 3, 3, MSGTMP, IEND+1, IEND+3, MAXTMP,
     &                 IER)
            IEND = IEND + 3
            MOD = 3
         END IF
      END IF
C                                  MSGTMP AND MSGSAV NOW CONTAIN THE
C                                   ERROR MESSAGE IN FINAL FORM.
      NCBEG = 59 - IEND - MOD
      ALL = 0
      IBLOC = I1DX(MSGSAV,MSGLEN,PERSLA,2)
      IF (IBLOC.NE.0 .AND. IBLOC.LT.NCBEG) THEN
         LOCM1 = IBLOC - 1
         LOC = IBLOC + 1
      ELSE IF (MSGLEN .LE. NCBEG) THEN
         LOCM1 = MSGLEN
         ALL = 1
      ELSE
         LOC = NCBEG
C                                  CHECK FOR APPROPRIATE PLACE TO SPLIT
   10    CONTINUE
         IF (MSGSAV(LOC) .NE. BLANK(1)) THEN
            LOC = LOC - 1
            IF (LOC .GT. 1) GO TO 10
            LOC = NCBEG + 1
         END IF
         LOCM1 = LOC - 1
      END IF
C                                  NO BLANKS FOUND IN FIRST NCBEG CHARS
      IF (LERTYP.GE.1 .AND. LERTYP.LE.7) THEN
         WRITE (NOUT,99995) (MSGTYP(I,LERTYP),I=1,8),
     &                     (MSGTMP(I),I=1,IEND), (MSGSAV(I),I=1,LOCM1)
      ELSE
         WRITE (NOUT,99995) (UNKNOW(I),I=1,8), (MSGTMP(I),I=1,IEND),
     &                     (MSGSAV(I),I=1,LOCM1)
      END IF
      IF (ALL .EQ. 0) THEN
C                                  PREPARE TO WRITE CONTINUATION OF
C                                    MESSAGE
C
C                                  FIND WHERE TO BREAK MESSAGE
C                                    LOC = NUMBER OF CHARACTERS OF
C                                          MESSAGE WRITTEN SO FAR
   20    LOCX = LOC + 64
         NLOC = LOC + 1
         IBLOC2 = IBLOC
         MAXLOC = MIN0(MSGLEN-LOC,64)
         IBLOC = I1DX(MSGSAV(NLOC),MAXLOC,PERSLA,2)
         IF (MSGSAV(NLOC).EQ.BLANK(1) .AND. IBLOC2.EQ.0) NLOC = NLOC +
     &       1
         IF (IBLOC .GT. 0) THEN
C                                  PAGE BREAK FOUND AT IBLOC
            LOCX = NLOC + IBLOC - 2
            WRITE (NOUT,99996) (MSGSAV(I),I=NLOC,LOCX)
            LOC = NLOC + IBLOC
            GO TO 20
C                                  DON'T BOTHER LOOKING FOR BLANK TO
C                                    BREAK AT IF LOCX .GE. MSGLEN
         ELSE IF (LOCX .LT. MSGLEN) THEN
C                                  CHECK FOR BLANK TO BREAK THE LINE
   30       CONTINUE
            IF (MSGSAV(LOCX) .EQ. BLANK(1)) THEN
C                                  BLANK FOUND AT LOCX
               WRITE (NOUT,99996) (MSGSAV(I),I=NLOC,LOCX)
               LOC = LOCX
               GO TO 20
            END IF
            LOCX = LOCX - 1
            IF (LOCX .GT. NLOC) GO TO 30
            LOCX = LOC + 64
C                                  NO BLANKS FOUND IN NEXT 64 CHARS
            WRITE (NOUT,99996) (MSGSAV(I),I=NLOC,LOCX)
            LOC = LOCX
            GO TO 20
         ELSE
C                                  ALL THE REST WILL FIT ON 1 LINE
            LOCX = MSGLEN
            WRITE (NOUT,99996) (MSGSAV(I),I=NLOC,LOCX)
         END IF
      END IF
C                                  SET LENGTH OF MSGSAV AND PLEN
C                                    TO SHOW THAT MESSAGE HAS
C                                    ALREADY BEEN PRINTED
 9000 MSGLEN = 0
      PLEN = 1
      IF (TRACON(LERTYP).EQ.1 .AND. CALLVL.GT.2) THEN
C                                  INITIATE TRACEBACK
         WRITE (NOUT,99997)
         DO 9005  J=CALLVL, 1, -1
            IF (J .GT. 1) THEN
               IF (ISUSER(J-1)) THEN
                  WRITE (NOUT,99998) RNAME(J), ERTYPE(J), ERCODE(J)
               ELSE
                  WRITE (NOUT,99999) RNAME(J), ERTYPE(J), ERCODE(J)
               END IF
            ELSE
               WRITE (NOUT,99998) RNAME(J), ERTYPE(J), ERCODE(J)
            END IF
 9005    CONTINUE
      END IF
C
      RETURN
99995 FORMAT (/, ' *** ', 8A1, ' ERROR', 59A1)
99996 FORMAT (' *** ', 9X, 64A1)
99997 FORMAT (14X, 'Here is a traceback of subprogram calls',
     &       ' in reverse order:', /, 14X, '      Routine    Error ',
     &       'type    Error code', /, 14X, '      -------    ',
     &       '----------    ----------')
99998 FORMAT (20X, A6, 5X, I6, 8X, I6)
99999 FORMAT (20X, A6, 5X, I6, 8X, I6, 4X, '(Called internally)')
      END
C-----------------------------------------------------------------------
C  IMSL Name:  E1UCS
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    March 8, 1984
C
C  Purpose:    To update the checksum number for error messages.
C
C  Usage:      CALL E1UCS
C
C  Arguments:  None
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE E1UCS
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, IBEG, IBEG2, IEND, ILOC, IPOS, JLOC, NCODE, NLEN
      DOUBLE PRECISION DNUM
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      DOUBLE PRECISION DMAX
      CHARACTER  BLANK(1), COMMA(1), EQUAL(1), LPAR(1)
      SAVE       BLANK, COMMA, DMAX, EQUAL, LPAR
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                              SPECIFICATIONS FOR COMMON /ERCOM1/
      INTEGER    CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51),
     &           PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7,
     &           IALLOC(51), HDRFMT(7), TRACON(7)
      COMMON     /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE,
     &           PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT,
     &           TRACON
      SAVE       /ERCOM1/
C                              SPECIFICATIONS FOR COMMON /ERCOM2/
      CHARACTER  MSGSAV(255), PLIST(300), RNAME(51)*6
      COMMON     /ERCOM2/ MSGSAV, PLIST, RNAME
      SAVE       /ERCOM2/
C                              SPECIFICATIONS FOR COMMON /ERCOM3/
      DOUBLE PRECISION ERCKSM
      COMMON     /ERCOM3/ ERCKSM
      SAVE       /ERCOM3/
C                              SPECIFICATIONS FOR COMMON /ERCOM4/
      LOGICAL    ISUSER(51)
      COMMON     /ERCOM4/ ISUSER
      SAVE       /ERCOM4/
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  DMOD
      INTRINSIC  DMOD
      DOUBLE PRECISION DMOD
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   S1ANUM
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   ICASE, I1X
      INTEGER    ICASE, I1X
C
      DATA BLANK(1)/' '/, COMMA(1)/','/, LPAR(1)/'('/
      DATA EQUAL(1)/'='/, DMAX/1.0D+9/
C
      IF (MSGLEN .GT. 1) THEN
         IPOS = 0
         IBEG2 = 1
   10    IBEG = IBEG2
         IEND = MSGLEN
C                                  LOOK FOR BLANK, COMMA, LEFT PAREN.,
C                                  OR EQUAL SIGN
         ILOC = I1X(MSGSAV(IBEG),IEND-IBEG+1,BLANK,1)
         JLOC = I1X(MSGSAV(IBEG),IEND-IBEG+1,COMMA,1)
         IF (ILOC.EQ.0 .OR. (JLOC.GT.0.AND.JLOC.LT.ILOC)) ILOC = JLOC
         JLOC = I1X(MSGSAV(IBEG),IEND-IBEG+1,LPAR,1)
         IF (ILOC.EQ.0 .OR. (JLOC.GT.0.AND.JLOC.LT.ILOC)) ILOC = JLOC
         JLOC = I1X(MSGSAV(IBEG),IEND-IBEG+1,EQUAL,1)
         IF (ILOC.EQ.0 .OR. (JLOC.GT.0.AND.JLOC.LT.ILOC)) ILOC = JLOC
         IF (ILOC .GE. 1) THEN
            CALL S1ANUM (MSGSAV(IBEG+ILOC), IEND-IBEG-ILOC+1, NCODE,
     &                   NLEN)
            IF (NCODE.EQ.2 .OR. NCODE.EQ.3) THEN
C                                  FLOATING POINT NUMBER FOUND.
C                                  SET POINTERS TO SKIP OVER IT
               IBEG2 = IBEG + ILOC + NLEN
               IF (IBEG2 .LE. MSGLEN) THEN
                  CALL S1ANUM (MSGSAV(IBEG2), IEND-IBEG2+1, NCODE,
     &                         NLEN)
                  IF ((MSGSAV(IBEG2).EQ.'+'.OR.MSGSAV(IBEG2).EQ.
     &                '-') .AND. NCODE.EQ.1) THEN
C                                  INTEGER IMMEDIATELY FOLLOWS A REAL AS
C                                  WITH SOME CDC NOS. LIKE 1.2345678+123
C                                  SET POINTERS TO SKIP OVER IT
                     IBEG2 = IBEG2 + NLEN
                  END IF
               END IF
            ELSE
               IBEG2 = IBEG + ILOC
            END IF
            IEND = IBEG + ILOC - 1
         END IF
C                                  UPDATE CKSUM USING PART OF MESSAGE
         DO 20  I=IBEG, IEND
            IPOS = IPOS + 1
            DNUM = ICASE(MSGSAV(I))
            ERCKSM = DMOD(ERCKSM+DNUM*IPOS,DMAX)
   20    CONTINUE
C                                  GO BACK FOR MORE IF NEEDED
         IF (IEND.LT.MSGLEN .AND. IBEG2.LT.MSGLEN) GO TO 10
C                                  UPDATE CKSUM USING ERROR TYPE
         DNUM = ERTYPE(CALLVL)
         ERCKSM = DMOD(ERCKSM+DNUM*(IPOS+1),DMAX)
C                                  UPDATE CKSUM USING ERROR CODE
         DNUM = ERCODE(CALLVL)
         ERCKSM = DMOD(ERCKSM+DNUM*(IPOS+2),DMAX)
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  M1VE
C
C  Computer:   DGC/SINGLE
C
C  Revised:    March 5, 1984
C
C  Purpose:    Move a subset of one character array to another.
C
C  Usage:      CALL M1VE(INSTR, INBEG, INEND, INLEN, OUTSTR, OUTBEG,
C                         OUTEND, OUTLEN, IER)
C
C  Arguments:
C     INSTR  - Source character array.  (Input)
C     INBEG  - First element of INSTR to be moved.  (Input)
C     INEND  - Last element of INSTR to be moved.  (Input)
C              The source subset is INSTR(INBEG),...,INSTR(INEND).
C     INLEN  - Length of INSTR.  (Input)
C     OUTSTR - Destination character array.  (Output)
C     IUTBEG - First element of OUTSTR destination.  (Input)
C     IUTEND - Last element of OUTSTR  destination.  (Input)
C              The destination subset is OUTSRT(IUTBEG),...,
C              OUTSTR(IUTEND).
C     IUTLEN - Length of OUTSTR.  (Input)
C     IER    - Completion code.  (Output)
C              IER = -2  indicates that the input parameters, INBEG,
C                        INEND, INLEN, IUTBEG, IUTEND are not
C                        consistent.  One of the conditions
C                        INBEG.GT.0, INEND.GE.INBEG, INLEN.GE.INEND,
C                        IUTBEG.GT.0, or IUTEND.GE.IUTBEG is not
C                        satisfied.
C              IER = -1  indicates that the length of OUTSTR is
C                        insufficient to hold the subset of INSTR.
C                        That is, IUTLEN is less than IUTEND.
C              IER =  0  indicates normal completion
C              IER >  0  indicates that the specified subset of OUTSTR,
C                        OUTSTR(IUTBEG),...,OUTSTR(IUTEND) is not long
C                        enough to hold the subset INSTR(INBEG),...,
C                        INSTR(INEND) of INSTR.  IER is set to the
C                        number of characters that were not moved.
C
C  Remarks:
C  1. If the subset of OUTSTR is longer than the subset of INSTR,
C     trailing blanks are moved to OUTSTR.
C  2. If the subset of INSTR is longer than the subset of OUTSTR,
C     the shorter subset is moved to OUTSTR and IER is set to the number
C     of characters that were not moved to OUTSTR.
C  3. If the length of OUTSTR is insufficient to hold the subset,
C     IER is set to -2 and nothing is moved.
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE M1VE (INSTR, INBEG, INEND, INLEN, OUTSTR, IUTBEG,
     &                 IUTEND, IUTLEN, IER)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    INBEG, INEND, INLEN, IUTBEG, IUTEND, IUTLEN, IER
      CHARACTER  INSTR(*), OUTSTR(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    IUTLAS, KI, KO
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      CHARACTER  BLANK
      SAVE       BLANK
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  MIN0
      INTRINSIC  MIN0
      INTEGER    MIN0
C
      DATA BLANK/' '/
C                                  CHECK INBEG, INEND, INLEN, IUTBEG,
C                                  AND IUTEND
C
      IF (INBEG.LE.0 .OR. INEND.LT.INBEG .OR. INLEN.LT.INEND .OR.
     &    IUTBEG.LE.0 .OR. IUTEND.LT.IUTBEG) THEN
         IER = -2
         RETURN
      ELSE IF (IUTLEN .LT. IUTEND) THEN
         IER = -1
         RETURN
      END IF
C                                  DETERMINE LAST CHARACTER TO M1VE
      IUTLAS = IUTBEG + MIN0(INEND-INBEG,IUTEND-IUTBEG)
C                                  M1VE CHARACTERS
      KI = INBEG
      DO 10  KO=IUTBEG, IUTLAS
         OUTSTR(KO) = INSTR(KI)
         KI = KI + 1
   10 CONTINUE
C                                   SET IER TO NUMBER OF CHARACTERS THAT
C                                   WHERE NOT MOVED
      IER = KI - INEND - 1
C                                   APPEND BLANKS IF NECESSARY
      DO 20  KO=IUTLAS + 1, IUTEND
         OUTSTR(KO) = BLANK
   20 CONTINUE
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  M1VECH
C
C  Computer:   DGC/SINGLE
C
C  Revised:    December 31, 1984
C
C  Purpose:    Character substring assignment.
C
C  Usage:      CALL M1VECH (STR1, LEN1, STR2, LEN2)
C
C  Arguments:
C     STR1   - Source substring.  (Input)
C              The source substring is STR1(1:LEN1).
C     LEN1   - Length of STR1.  (Input)
C     STR2   - Destination substring.  (Output)
C              The destination substring is STR2(1:LEN2).
C     LEN2   - Length of STR2.  (Input)
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE M1VECH (STR1, LEN1, STR2, LEN2)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    LEN1, LEN2
      CHARACTER  STR1*(*), STR2*(*)
C
      STR2(1:LEN2) = STR1(1:LEN1)
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  I1DX (Single precision version)
C
C  Computer:   DGC/SINGLE
C
C  Revised:    September 9, 1985
C
C  Purpose:    Determine the array subscript indicating the starting
C              element at which a key character sequence begins.
C              (Case-insensitive version)
C
C  Usage:      I1DX(CHRSTR, I1LEN, KEY, KLEN)
C
C  Arguments:
C     CHRSTR - Character array to be searched.  (Input)
C     I1LEN  - Length of CHRSTR.  (Input)
C     KEY    - Character array that contains the key sequence.  (Input)
C     KLEN   - Length of KEY.  (Input)
C     I1DX   - Integer function.  (Output)
C
C  Remarks:
C  1. Returns zero when there is no match.
C
C  2. Returns zero if KLEN is longer than ISLEN.
C
C  3. Returns zero when any of the character arrays has a negative or
C     zero length.
C
C  GAMS:       N5c
C
C  Chapter:    MATH/LIBRARY Utilities
C
C  Copyright:  1985 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      INTEGER FUNCTION I1DX (CHRSTR, I1LEN, KEY, KLEN)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    I1LEN, KLEN
      CHARACTER  CHRSTR(*), KEY(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, II, J
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   ICASE, I1CSTR
      INTEGER    ICASE, I1CSTR
C
      I1DX = 0
      IF (KLEN.LE.0 .OR. I1LEN.LE.0) GO TO 9000
      IF (KLEN .GT. I1LEN) GO TO 9000
C
      I = 1
      II = I1LEN - KLEN + 1
   10 IF (I .LE. II) THEN
         IF (ICASE(CHRSTR(I)) .EQ. ICASE(KEY(1))) THEN
            IF (KLEN .NE. 1) THEN
               J = KLEN - 1
               IF (I1CSTR(CHRSTR(I+1),J,KEY(2),J) .EQ. 0) THEN
                  I1DX = I
                  GO TO 9000
               END IF
            ELSE
               I1DX = I
               GO TO 9000
            END IF
         END IF
         I = I + 1
         GO TO 10
      END IF
C
 9000 RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  I1KRL
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    August 9, 1983
C
C  Purpose:    Deallocate the last N allocations made in the workspace.
C              stack by I1KGT
C
C  Usage:      CALL I1KRL(N)
C
C  Arguments:
C     N      - Number of allocations to be released top down (Input)
C
C  Copyright:  1983 by IMSL, Inc.  All Rights Reserved
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE I1KRL (N)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    N
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, IN, LALC, LBND, LBOOK, LMAX, LNEED, LNOW, LOUT,
     &           LUSED, NDX, NEXT
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      LOGICAL    FIRST
      SAVE       FIRST
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                                  SPECIFICATIONS FOR COMMON /WORKSP/
      REAL       RWKSP(61913)
      REAL       RDWKSP(5000)
      DOUBLE PRECISION DWKSP(2500)
      COMPLEX    CWKSP(2500)
      COMPLEX    CZWKSP(2500)
      COMPLEX    *16 ZWKSP(1250)
      INTEGER    IWKSP(5000)
      LOGICAL    LWKSP(5000)
      EQUIVALENCE (DWKSP(1), RWKSP(1))
      EQUIVALENCE (CWKSP(1), RWKSP(1)), (ZWKSP(1), RWKSP(1))
      EQUIVALENCE (IWKSP(1), RWKSP(1)), (LWKSP(1), RWKSP(1))
      EQUIVALENCE (RDWKSP(1), RWKSP(1)), (CZWKSP(1), RWKSP(1))
      COMMON     /WORKSP/ RWKSP
C                                  SPECIFICATIONS FOR EQUIVALENCE
      EQUIVALENCE (LOUT, IWKSP(1))
      EQUIVALENCE (LNOW, IWKSP(2))
      EQUIVALENCE (LUSED, IWKSP(3))
      EQUIVALENCE (LBND, IWKSP(4))
      EQUIVALENCE (LMAX, IWKSP(5))
      EQUIVALENCE (LALC, IWKSP(6))
      EQUIVALENCE (LNEED, IWKSP(7))
      EQUIVALENCE (LBOOK, IWKSP(8))
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   E1MES, E1STI, IWKIN
C
      DATA FIRST/.TRUE./
C
      IF (FIRST) THEN
C                                  INITIALIZE WORKSPACE IF NEEDED
         FIRST = .FALSE.
         CALL IWKIN (0)
      END IF
C                                  CALLING I1KRL(0) WILL CONFIRM
C                                  INTEGRITY OF SYSTEM AND RETURN
      IF (N .LT. 0) THEN
         CALL E1MES (5, 10, 'Error from subroutine I1KRL:  Attempt'//
     &               ' to release a negative number of workspace'//
     &               ' allocations. ')
         GO TO 9000
      END IF
C                                  BOOKKEEPING OVERWRITTEN
      IF (LNOW.LT.LBOOK .OR. LNOW.GT.LUSED .OR. LUSED.GT.LMAX .OR.
     &    LNOW.GE.LBND .OR. LOUT.GT.LALC) THEN
         CALL E1MES (5, 11, 'Error from subroutine I1KRL:  One or '//
     &               'more of the first eight bookkeeping locations '//
     &               'in IWKSP have been overwritten.  ')
         GO TO 9000
      END IF
C                                  CHECK ALL THE POINTERS IN THE
C                                  PERMANENT STORAGE AREA.  THEY MUST
C                                  BE MONOTONE INCREASING AND LESS THAN
C                                  OR EQUAL TO LMAX, AND THE INDEX OF
C                                  THE LAST POINTER MUST BE LMAX+1.
      NDX = LBND
      IF (NDX .NE. LMAX+1) THEN
         DO 10  I=1, LALC
            NEXT = IWKSP(NDX)
            IF (NEXT .EQ. LMAX+1) GO TO 20
C
            IF (NEXT.LE.NDX .OR. NEXT.GT.LMAX) THEN
               CALL E1MES (5, 12, 'Error from subroutine I1KRL:  '//
     &                     'A pointer in permanent storage has been '//
     &                     ' overwritten. ')
               GO TO 9000
            END IF
            NDX = NEXT
   10    CONTINUE
         CALL E1MES (5, 13, 'Error from subroutine I1KRL:  A '//
     &               'pointer in permanent storage has been '//
     &               'overwritten. ')
         GO TO 9000
      END IF
   20 IF (N .GT. 0) THEN
         DO 30  IN=1, N
            IF (LNOW .LE. LBOOK) THEN
               CALL E1MES (5, 14, 'Error from subroutine I1KRL:  '//
     &                     'Attempt to release a nonexistant '//
     &                     'workspace  allocation. ')
               GO TO 9000
            ELSE IF (IWKSP(LNOW).LT.LBOOK .OR. IWKSP(LNOW).GE.LNOW-1)
     &              THEN
C                                  CHECK TO MAKE SURE THE BACK POINTERS
C                                  ARE MONOTONE.
               CALL E1STI (1, LNOW)
               CALL E1MES (5, 15, 'Error from subroutine I1KRL:  '//
     &                     'The pointer at IWKSP(%(I1)) has been '//
     &                     'overwritten.  ')
               GO TO 9000
            ELSE
               LOUT = LOUT - 1
               LNOW = IWKSP(LNOW)
            END IF
   30    CONTINUE
      END IF
C
 9000 RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  I1KST
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    August 9, 1983
C
C  Purpose:    Return control information about the workspace stack.
C
C  Usage:      I1KST(NFACT)
C
C  Arguments:
C     NFACT  - Integer value between 1 and 6 inclusive returns the
C                 following information: (Input)
C                   NFACT = 1 - LOUT: number of current allocations
C                               excluding permanent storage. At the
C                               end of a run, there should be no
C                               active allocations.
C                   NFACT = 2 - LNOW: current active length
C                   NFACT = 3 - LTOTAL: total storage used thus far
C                   NFACT = 4 - LMAX: maximum storage allowed
C                   NFACT = 5 - LALC: total number of allocations made
C                               by I1KGT thus far
C                   NFACT = 6 - LNEED: number of numeric storage units
C                               by which the stack size must be
C                               increased for all past allocations
C                               to succeed
C     I1KST  - Integer function. (Output) Returns a workspace stack
C              statistic according to value of NFACT.
C
C  Copyright:  1983 by IMSL, Inc.  All Rights Reserved
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      INTEGER FUNCTION I1KST (NFACT)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    NFACT
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    ISTATS(7)
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      LOGICAL    FIRST
      SAVE       FIRST
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                                  SPECIFICATIONS FOR COMMON /WORKSP/
      REAL       RWKSP(61913)
      REAL       RDWKSP(5000)
      DOUBLE PRECISION DWKSP(2500)
      COMPLEX    CWKSP(2500)
      COMPLEX    CZWKSP(2500)
      COMPLEX    *16 ZWKSP(1250)
      INTEGER    IWKSP(5000)
      LOGICAL    LWKSP(5000)
      EQUIVALENCE (DWKSP(1), RWKSP(1))
      EQUIVALENCE (CWKSP(1), RWKSP(1)), (ZWKSP(1), RWKSP(1))
      EQUIVALENCE (IWKSP(1), RWKSP(1)), (LWKSP(1), RWKSP(1))
      EQUIVALENCE (RDWKSP(1), RWKSP(1)), (CZWKSP(1), RWKSP(1))
      COMMON     /WORKSP/ RWKSP
C                                  SPECIFICATIONS FOR EQUIVALENCE
      EQUIVALENCE (ISTATS(1), IWKSP(1))
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   E1MES, IWKIN
C
      DATA FIRST/.TRUE./
C
      IF (FIRST) THEN
C                                  INITIALIZE WORKSPACE IF NEEDED
         FIRST = .FALSE.
         CALL IWKIN (0)
      END IF
C
      IF (NFACT.LE.0 .OR. NFACT.GE.7) THEN
         CALL E1MES (5, 9, 'Error from subroutine I1KST:  Argument'//
     &               ' for I1KST must be between 1 and 6 inclusive.')
      ELSE IF (NFACT .EQ. 1) THEN
C                                  LOUT
         I1KST = ISTATS(1)
      ELSE IF (NFACT .EQ. 2) THEN
C                                  LNOW + PERMANENT
         I1KST = ISTATS(2) + (ISTATS(5)-ISTATS(4)+1)
      ELSE IF (NFACT .EQ. 3) THEN
C                                  LUSED + PERMANENT
         I1KST = ISTATS(3) + (ISTATS(5)-ISTATS(4)+1)
      ELSE IF (NFACT .EQ. 4) THEN
C                                  LMAX
         I1KST = ISTATS(5)
      ELSE IF (NFACT .EQ. 5) THEN
C                                  LALC
         I1KST = ISTATS(6)
      ELSE IF (NFACT .EQ. 6) THEN
C                                  LNEED
         I1KST = ISTATS(7)
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  I1KQU
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    January 17, 1984
C
C  Purpose:    Return number of elements of data type ITYPE that
C              remain to be allocated in one request.
C
C  Usage:      I1KQU(ITYPE)
C
C  Arguments:
C     ITYPE  - Type of storage to be checked (Input)
C                 1 - logical
C                 2 - integer
C                 3 - real
C                 4 - double precision
C                 5 - complex
C                 6 - double complex
C     I1KQU  - Integer function. (Output) Returns number of elements
C              of data type ITYPE remaining in the stack.
C
C  Copyright:  1983 by IMSL, Inc.  All Rights Reserved
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      INTEGER FUNCTION I1KQU (ITYPE)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    ITYPE
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    ISIZE(6), LALC, LBND, LBOOK, LMAX, LNEED, LNOW, LOUT,
     &           LUSED
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      LOGICAL    FIRST
      SAVE       FIRST
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                                  SPECIFICATIONS FOR COMMON /WORKSP/
      REAL       RWKSP(61913)
      REAL       RDWKSP(5000)
      DOUBLE PRECISION DWKSP(2500)
      COMPLEX    CWKSP(2500)
      COMPLEX    CZWKSP(2500)
      COMPLEX    *16 ZWKSP(1250)
      INTEGER    IWKSP(5000)
      LOGICAL    LWKSP(5000)
      EQUIVALENCE (DWKSP(1), RWKSP(1))
      EQUIVALENCE (CWKSP(1), RWKSP(1)), (ZWKSP(1), RWKSP(1))
      EQUIVALENCE (IWKSP(1), RWKSP(1)), (LWKSP(1), RWKSP(1))
      EQUIVALENCE (RDWKSP(1), RWKSP(1)), (CZWKSP(1), RWKSP(1))
      COMMON     /WORKSP/ RWKSP
C                                  SPECIFICATIONS FOR EQUIVALENCE
      EQUIVALENCE (LOUT, IWKSP(1))
      EQUIVALENCE (LNOW, IWKSP(2))
      EQUIVALENCE (LUSED, IWKSP(3))
      EQUIVALENCE (LBND, IWKSP(4))
      EQUIVALENCE (LMAX, IWKSP(5))
      EQUIVALENCE (LALC, IWKSP(6))
      EQUIVALENCE (LNEED, IWKSP(7))
      EQUIVALENCE (LBOOK, IWKSP(8))
      EQUIVALENCE (ISIZE(1), IWKSP(11))
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  MAX0
      INTRINSIC  MAX0
      INTEGER    MAX0
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   E1MES, E1POP, E1PSH, IWKIN
C
      DATA FIRST/.TRUE./
C
      CALL E1PSH ('I1KQU ')
C
      IF (FIRST) THEN
C                                  INITIALIZE WORKSPACE IF NEEDED
         FIRST = .FALSE.
         CALL IWKIN (0)
      END IF
C                                  BOOKKEEPING OVERWRITTEN
      IF (LNOW.LT.LBOOK .OR. LNOW.GT.LUSED .OR. LUSED.GT.LMAX .OR.
     &    LNOW.GE.LBND .OR. LOUT.GT.LALC) THEN
         CALL E1MES (5, 7, 'One or more of the first eight '//
     &               'bookkeeping locations in IWKSP have been '//
     &               'overwritten.')
      ELSE IF (ITYPE.LE.0 .OR. ITYPE.GE.7) THEN
C                                  ILLEGAL DATA TYPE REQUESTED
         CALL E1MES (5, 8, 'Illegal data type requested.')
      ELSE
C                                  THIS CALCULATION ALLOWS FOR THE
C                                  TWO POINTER LOCATIONS IN THE STACK
C                                  WHICH ARE ASSIGNED TO EACH ALLOCATION
         I1KQU = MAX0(((LBND-3)*ISIZE(2))/ISIZE(ITYPE)-(LNOW*ISIZE(2)-
     &           1)/ISIZE(ITYPE)-1,0)
      END IF
C
      CALL E1POP ('I1KQU ')
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  IWKIN (Single precision version)
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    January 17, 1984
C
C  Purpose:    Initialize bookkeeping locations describing the
C              workspace stack.
C
C  Usage:      CALL IWKIN (NSU)
C
C  Argument:
C     NSU    - Number of numeric storage units to which the workspace
C              stack is to be initialized
C
C  GAMS:       N4
C
C  Chapters:   MATH/LIBRARY Reference Material
C              STAT/LIBRARY Reference Material
C
C  Copyright:  1984 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE IWKIN (NSU)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    NSU
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    ISIZE(6), LALC, LBND, LBOOK, LMAX, LNEED, LNOW, LOUT,
     &           LUSED, MELMTS, MTYPE
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      LOGICAL    FIRST
      SAVE       FIRST
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                                  SPECIFICATIONS FOR COMMON /WORKSP/
      REAL       RWKSP(61913)
      REAL       RDWKSP(5000)
      DOUBLE PRECISION DWKSP(2500)
      COMPLEX    CWKSP(2500)
      COMPLEX    CZWKSP(2500)
      COMPLEX    *16 ZWKSP(1250)
      INTEGER    IWKSP(5000)
      LOGICAL    LWKSP(5000)
      EQUIVALENCE (DWKSP(1), RWKSP(1))
      EQUIVALENCE (CWKSP(1), RWKSP(1)), (ZWKSP(1), RWKSP(1))
      EQUIVALENCE (IWKSP(1), RWKSP(1)), (LWKSP(1), RWKSP(1))
      EQUIVALENCE (RDWKSP(1), RWKSP(1)), (CZWKSP(1), RWKSP(1))
      COMMON     /WORKSP/ RWKSP
C                                  SPECIFICATIONS FOR EQUIVALENCE
      EQUIVALENCE (LOUT, IWKSP(1))
      EQUIVALENCE (LNOW, IWKSP(2))
      EQUIVALENCE (LUSED, IWKSP(3))
      EQUIVALENCE (LBND, IWKSP(4))
      EQUIVALENCE (LMAX, IWKSP(5))
      EQUIVALENCE (LALC, IWKSP(6))
      EQUIVALENCE (LNEED, IWKSP(7))
      EQUIVALENCE (LBOOK, IWKSP(8))
      EQUIVALENCE (ISIZE(1), IWKSP(11))
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  MAX0
      INTRINSIC  MAX0
      INTEGER    MAX0
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   E1MES, E1STI
C
      DATA FIRST/.TRUE./
C
      IF (.NOT.FIRST) THEN
         IF (NSU .NE. 0) THEN
            CALL E1STI (1, LMAX)
            CALL E1MES (5, 100, 'Error from subroutine IWKIN:  '//
     &                  'Workspace stack has previously been '//
     &                  'initialized to %(I1). Correct by making the '//
     &                  'call to IWKIN the first executable '//
     &                  'statement in the main program.  ')
C
            STOP
C
         ELSE
            RETURN
         END IF
      END IF
C
      IF (NSU .EQ. 0) THEN
C                                  IF NSU=0 USE DEFAULT SIZE 5000
         MELMTS = 5000
      ELSE
         MELMTS = NSU
      END IF
C                                  NUMBER OF ITEMS .LT. 0
      IF (MELMTS .LE. 0) THEN
         CALL E1STI (1, MELMTS)
         CALL E1MES (5, 1, 'Error from subroutine IWKIN:  Number '//
     &               'of numeric storage units is not positive. NSU '//
     &               '= %(I1) ')
      ELSE
C
         FIRST = .FALSE.
C                                  HERE TO INITIALIZE
C
C                                  SET DATA SIZES APPROPRIATE FOR A
C                                  STANDARD CONFORMING FORTRAN SYSTEM
C                                  USING THE FORTRAN
C                                  *NUMERIC STORAGE UNIT* AS THE
C                                  MEASURE OF SIZE.
C
C                                  TYPE IS REAL
         MTYPE = 3
C                                  LOGICAL
         ISIZE(1) = 1
C                                  INTEGER
         ISIZE(2) = 1
C                                  REAL
         ISIZE(3) = 1
C                                  DOUBLE PRECISION
         ISIZE(4) = 2
C                                  COMPLEX
         ISIZE(5) = 2
C                                  DOUBLE COMPLEX
         ISIZE(6) = 4
C                                  NUMBER OF WORDS USED FOR BOOKKEEPING
         LBOOK = 16
C                                  CURRENT ACTIVE LENGTH OF THE STACK
         LNOW = LBOOK
C                                  MAXIMUM VALUE OF LNOW ACHIEVED THUS
C                                  FAR
         LUSED = LBOOK
C                                  MAXIMUM LENGTH OF THE STORAGE ARRAY
         LMAX = MAX0(MELMTS,((LBOOK+2)*ISIZE(2)+ISIZE(3)-1)/ISIZE(3))
C                                  LOWER BOUND OF THE PERMANENT STORAGE
C                                  WHICH IS ONE WORD MORE THAN THE
C                                  MAXIMUM ALLOWED LENGTH OF THE STACK
         LBND = LMAX + 1
C                                  NUMBER OF CURRENT ALLOCATIONS
         LOUT = 0
C                                  TOTAL NUMBER OF ALLOCATIONS MADE
         LALC = 0
C                                  NUMBER OF WORDS BY WHICH THE ARRAY
C                                  SIZE MUST BE INCREASED FOR ALL PAST
C                                  ALLOCATIONS TO SUCCEED
         LNEED = 0
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  I1X (Single precision version)
C
C  Computer:   DGC/SINGLE
C
C  Revised:    August 30, 1985
C
C  Purpose:    Determine the array subscript indicating the starting
C              element at which a key character sequence begins.
C              (Case-sensitive version)
C
C  Usage:      I1X(CHRSTR, I1LEN, KEY, KLEN)
C
C  Arguments:
C     CHRSTR - Character array to be searched.  (Input)
C     I1LEN  - Length of CHRSTR.  (Input)
C     KEY    - Character array that contains the key sequence.  (Input)
C     KLEN   - Length of KEY.  (Input)
C     I1X    - Integer function.  (Output)
C
C  Remarks:
C  1. Returns zero when there is no match.
C
C  2. Returns zero if KLEN is longer than ISLEN.
C
C  3. Returns zero when any of the character arrays has a negative or
C     zero length.
C
C  GAMS:       N5c
C
C  Chapter:    MATH/LIBRARY Utilities
C
C  Copyright:  1985 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      INTEGER FUNCTION I1X (CHRSTR, I1LEN, KEY, KLEN)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    I1LEN, KLEN
      CHARACTER  CHRSTR(*), KEY(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, II, J
C
      I1X = 0
      IF (KLEN.LE.0 .OR. I1LEN.LE.0) GO TO 9000
      IF (KLEN .GT. I1LEN) GO TO 9000
C
      I = 1
      II = I1LEN - KLEN + 1
   10 IF (I .LE. II) THEN
         IF (CHRSTR(I) .EQ. KEY(1)) THEN
            DO 20  J=2, KLEN
               IF (CHRSTR(I+J-1) .NE. KEY(J)) GO TO 30
   20       CONTINUE
            I1X = I
            GO TO 9000
   30       CONTINUE
         END IF
         I = I + 1
         GO TO 10
      END IF
C
 9000 RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  C1TIC
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    March 9, 1984
C
C  Purpose:    Convert an integer to its corresponding character form.
C              (Right justified)
C
C  Usage:      CALL C1TIC(NUM, CHRSTR, SLEN, IER)
C
C  Arguments:
C     NUM    - Integer number.  (Input)
C     CHRSTR - Character array that receives the result.  (Output)
C     SLEN   - Length of the character array.  (Input)
C     IER    - Completion code.  (Output) Where
C                 IER < 0  indicates that SLEN <= 0,
C                 IER = 0  indicates normal completion,
C                 IER > 0  indicates that the character array is too
C                       small to hold the complete number.  IER
C                       indicates how many significant digits are
C                       being truncated.
C
C  Remarks:
C  1. The character array is filled in a right justified manner.
C  2. Leading zeros are replaced by blanks.
C  3. Sign is inserted only for negative number.
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE C1TIC (NUM, CHRSTR, SLEN, IER)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    NUM, SLEN, IER
      CHARACTER  CHRSTR(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, J, K, L
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      CHARACTER  BLANK(1), DIGIT(10), MINUS(1)
      SAVE       BLANK, DIGIT, MINUS
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  IABS
      INTRINSIC  IABS
      INTEGER    IABS
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   M1VE
C
      DATA DIGIT/'0', '1', '2', '3', '4', '5', '6', '7', '8',
     &     '9'/
      DATA BLANK/' '/, MINUS/'-'/
C                                  CHECK SLEN
      IF (SLEN .LE. 0) THEN
         IER = -1
         RETURN
      END IF
C                                  THE NUMBER IS ZERO
      IF (NUM .EQ. 0) THEN
         CALL M1VE (BLANK, 1, 1, 1, CHRSTR, 1, SLEN-1, SLEN, I)
         CHRSTR(SLEN) = DIGIT(1)
         IER = 0
         RETURN
      END IF
C                                  CONVERT NUMBER DIGIT BY DIGIT TO
C                                  CHARACTER FORM
      J = SLEN
      K = IABS(NUM)
   10 IF (K.GT.0 .AND. J.GE.1) THEN
         L = K
         K = K/10
         L = L - K*10
         CHRSTR(J) = DIGIT(L+1)
         J = J - 1
         GO TO 10
      END IF
C
   20 IF (K .EQ. 0) THEN
         IF (NUM .LT. 0) THEN
            CALL M1VE (MINUS, 1, 1, 1, CHRSTR, J, J, SLEN, I)
            IF (I .NE. 0) THEN
               IER = 1
               RETURN
            END IF
            J = J - 1
         END IF
         IER = 0
         CALL M1VE (BLANK, 1, 1, 1, CHRSTR, 1, J, SLEN, I)
         RETURN
      END IF
C                                  DETERMINE THE NUMBER OF SIGNIFICANT
C                                  DIGITS BEING TRUNCATED
      I = 0
   30 IF (K .GT. 0) THEN
         K = K/10
         I = I + 1
         GO TO 30
      END IF
C
      IF (NUM .LT. 0) I = I + 1
      IER = I
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  N1RGB
C
C  Computer:   DGC/SINGLE
C
C  Revised:    March 2, 1984
C
C  Purpose:    Return a positive number as a flag to indicated that a
C              stop should occur due to one or more global errors.
C
C  Usage:      N1RGB(IDUMMY)
C
C  Arguments:
C     IDUMMY - Integer scalar dummy argument.
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      INTEGER FUNCTION N1RGB (IDUMMY)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    IDUMMY
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                              SPECIFICATIONS FOR COMMON /ERCOM1/
      INTEGER    CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51),
     &           PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7,
     &           IALLOC(51), HDRFMT(7), TRACON(7)
      COMMON     /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE,
     &           PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT,
     &           TRACON
      SAVE       /ERCOM1/
C                              SPECIFICATIONS FOR COMMON /ERCOM2/
      CHARACTER  MSGSAV(255), PLIST(300), RNAME(51)*6
      COMMON     /ERCOM2/ MSGSAV, PLIST, RNAME
      SAVE       /ERCOM2/
C                              SPECIFICATIONS FOR COMMON /ERCOM3/
      DOUBLE PRECISION ERCKSM
      COMMON     /ERCOM3/ ERCKSM
      SAVE       /ERCOM3/
C                              SPECIFICATIONS FOR COMMON /ERCOM4/
      LOGICAL    ISUSER(51)
      COMMON     /ERCOM4/ ISUSER
      SAVE       /ERCOM4/
C                                  INITIALIZE FUNCTION
      N1RGB = 0
C                                  CHECK FOR GLOBAL ERROR TYPE 6
      IF (IFERR6 .GT. 0) THEN
         N1RGB = STOPTB(6)
         IFERR6 = 0
      END IF
C                                  CHECK FOR GLOBAL ERROR TYPE 7
      IF (IFERR7 .GT. 0) THEN
         N1RGB = STOPTB(7)
         IFERR7 = 0
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  SDOT (Single precision version)
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    August 9, 1986
C
C  Purpose:    Compute the single-precision dot product x*y.
C
C  Usage:      SDOT(N, SX, INCX, SY, INCY)
C
C  Arguments:
C     N      - Length of vectors X and Y.  (Input)
C     SX     - Real vector of length MAX(N*IABS(INCX),1).  (Input)
C     INCX   - Displacement between elements of SX.  (Input)
C              X(I) is defined to be.. SX(1+(I-1)*INCX) if INCX .GE. 0
C              or SX(1+(I-N)*INCX) if INCX .LT. 0.
C     SY     - Real vector of length MAX(N*IABS(INCY),1).  (Input)
C     INCY   - Displacement between elements of SY.  (Input)
C              Y(I) is defined to be.. SY(1+(I-1)*INCY) if INCY .GE. 0
C              or SY(1+(I-N)*INCY) if INCY .LT. 0.
C     SDOT   - Sum from I=1 to N of X(I)*Y(I).  (Output)
C              X(I) and Y(I) refer to specific elements of SX and SY,
C              respectively.  See INCX and INCY argument descriptions.
C
C  GAMS:       D1a4
C
C  Chapters:   MATH/LIBRARY Basic Matrix/Vector Operations
C              STAT/LIBRARY Mathematical Support
C
C  Copyright:  1986 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      REAL FUNCTION SDOT (N, SX, INCX, SY, INCY)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    N, INCX, INCY
      REAL       SX(*), SY(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, IX, IY, M, MP1
C                                  SPECIFICATIONS FOR SPECIAL CASES
C     INTRINSIC  MOD
      INTRINSIC  MOD
      INTEGER    MOD
C
      SDOT = 0.0E0
      IF (N .GT. 0) THEN
         IF (INCX.NE.1 .OR. INCY.NE.1) THEN
C                                  CODE FOR UNEQUAL INCREMENTS
            IX = 1
            IY = 1
            IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
            IF (INCY .LT. 0) IY = (-N+1)*INCY + 1
            DO 10  I=1, N
               SDOT = SDOT + SX(IX)*SY(IY)
               IX = IX + INCX
               IY = IY + INCY
   10       CONTINUE
         ELSE
C                                  CODE FOR BOTH INCREMENTS EQUAL TO 1
            M = MOD(N,5)
C                                  CLEAN-UP LOOP SO REMAINING VECTOR
            DO 30  I=1, M
               SDOT = SDOT + SX(I)*SY(I)
   30       CONTINUE
            MP1 = M + 1
            DO 40  I=MP1, N, 5
               SDOT = SDOT + SX(I)*SY(I) + SX(I+1)*SY(I+1) +
     &                SX(I+2)*SY(I+2) + SX(I+3)*SY(I+3) +
     &                SX(I+4)*SY(I+4)
   40       CONTINUE
         END IF
      END IF
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  E1POS
C
C  Computer:   DGC/SINGLE
C
C  Revised:    March 2, 1984
C
C  Purpose:    Set or retrieve print and stop attributes.
C
C  Usage:      CALL E1POS(IERTYP,IPATT,ISATT)
C
C  Arguments:
C     IERTYP - Integer specifying the error type for which print and
C              stop attributes are to be set or retrieved.  (Input)  If
C              IERTYP is 0 then the settings apply to all error types.
C              If IERTYP is between 1 and 7, then the settings only
C              apply to that specified error type.  If IERTYP is
C              negative then the current print and stop attributes will
C              be returned in IPATT and ISATT.
C     IPATT  - If IERTYP is positive, IPATT is an integer specifying the
C              desired print attribute as follows: -1 means no change,
C              0 means NO, 1 means YES, and 2 means assign the default
C              setting.  (Input)  If IERTYP is negative, IPATT is
C              returned as 1 if print is YES or 0 if print is NO for
C              error type IABS(IERTYP).  (Output)
C     ISATT  - If IERTYP is positive, ISATT is an integer specifying the
C              desired stop attribute as follows: -1 means no change,
C              0 means NO, 1 means YES, and 2 means assign the default
C              setting.  (Input)  If IERTYP is negative, ISATT is
C              returned as 1 if print is YES or 0 if print is NO for
C              error type IABS(IERTYP).  (Output)
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE E1POS (IERTYP, IPATT, ISATT)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    IERTYP, IPATT, ISATT
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, IER
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      INTEGER    DEFLTP(7), DEFLTS(7), IFINIT
      SAVE       DEFLTP, DEFLTS, IFINIT
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                              SPECIFICATIONS FOR COMMON /ERCOM1/
      INTEGER    CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51),
     &           PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7,
     &           IALLOC(51), HDRFMT(7), TRACON(7)
      COMMON     /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE,
     &           PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT,
     &           TRACON
      SAVE       /ERCOM1/
C                              SPECIFICATIONS FOR COMMON /ERCOM2/
      CHARACTER  MSGSAV(255), PLIST(300), RNAME(51)*6
      COMMON     /ERCOM2/ MSGSAV, PLIST, RNAME
      SAVE       /ERCOM2/
C                              SPECIFICATIONS FOR COMMON /ERCOM3/
      DOUBLE PRECISION ERCKSM
      COMMON     /ERCOM3/ ERCKSM
      SAVE       /ERCOM3/
C                              SPECIFICATIONS FOR COMMON /ERCOM4/
      LOGICAL    ISUSER(51)
      COMMON     /ERCOM4/ ISUSER
      SAVE       /ERCOM4/
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  IABS
      INTRINSIC  IABS
      INTEGER    IABS
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   E1INIT, E1MES, E1STI
C
      DATA IFINIT/0/
      DATA DEFLTP/0, 0, 1, 1, 1, 1, 1/, DEFLTS/0, 0, 0, 1, 1, 0, 1/
C                                  INITIALIZE ERROR TABLE IF NECESSARY
      IF (IFINIT .EQ. 0) THEN
         CALL E1INIT
         IFINIT = 1
      END IF
      IER = 0
      IF (IERTYP .GE. 0) THEN
         IF (IPATT.LT.-1 .OR. IPATT.GT.2) THEN
            CALL E1STI (1, IPATT)
            CALL E1MES (5, 1, 'Invalid value specified for print '//
     &                  'table attribute.  IPATT must be -1, 0, 1, '//
     &                  'or 2.  IPATT = %(I1)')
            IER = 1
         END IF
         IF (ISATT.LT.-1 .OR. ISATT.GT.2) THEN
            CALL E1STI (1, ISATT)
            CALL E1MES (5, 1, 'Invalid value specified for stop '//
     &                  'table attribute.  ISATT must be -1, 0, 1, '//
     &                  'or 2.  ISATT = %(I1)')
            IER = 1
         END IF
      END IF
      IF (IER .EQ. 0) THEN
         IF (IERTYP .EQ. 0) THEN
            IF (IPATT.EQ.0 .OR. IPATT.EQ.1) THEN
               DO 10  I=1, 7
   10          PRINTB(I) = IPATT
            ELSE IF (IPATT .EQ. 2) THEN
C                                  ASSIGN DEFAULT SETTINGS
               DO 20  I=1, 7
   20          PRINTB(I) = DEFLTP(I)
            END IF
            IF (ISATT.EQ.0 .OR. ISATT.EQ.1) THEN
               DO 30  I=1, 7
   30          STOPTB(I) = ISATT
            ELSE IF (ISATT .EQ. 2) THEN
C                                  ASSIGN DEFAULT SETTINGS
               DO 40  I=1, 7
   40          STOPTB(I) = DEFLTS(I)
            END IF
         ELSE IF (IERTYP.GE.1 .AND. IERTYP.LE.7) THEN
            IF (IPATT.EQ.0 .OR. IPATT.EQ.1) THEN
               PRINTB(IERTYP) = IPATT
            ELSE IF (IPATT .EQ. 2) THEN
C                                  ASSIGN DEFAULT SETTING
               PRINTB(IERTYP) = DEFLTP(IERTYP)
            END IF
            IF (ISATT.EQ.0 .OR. ISATT.EQ.1) THEN
               STOPTB(IERTYP) = ISATT
            ELSE IF (ISATT .EQ. 2) THEN
C                                  ASSIGN DEFAULT SETTING
               STOPTB(IERTYP) = DEFLTS(IERTYP)
            END IF
         ELSE IF (IERTYP.LE.-1 .AND. IERTYP.GE.-7) THEN
            I = IABS(IERTYP)
            IPATT = PRINTB(I)
            ISATT = STOPTB(I)
         END IF
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  E1STL
C
C  Computer:   DGC/SINGLE
C
C  Revised:    November 8, 1985
C
C  Purpose:    To store a string for subsequent use within an error
C              message.
C
C  Usage:      CALL E1STL(IL,STRING)
C
C  Arguments:
C     IL     - Integer specifying the substitution index.  IL must be
C              between 1 and 9.  (Input)
C     STRING - A character string.  (Input)
C
C  Copyright:  1985 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE E1STL (IL, STRING)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    IL
      CHARACTER  STRING*(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, LEN2
      CHARACTER  STRGUP(255)
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      INTEGER    IFINIT
      SAVE       IFINIT
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                              SPECIFICATIONS FOR COMMON /ERCOM1/
      INTEGER    CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51),
     &           PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7,
     &           IALLOC(51), HDRFMT(7), TRACON(7)
      COMMON     /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE,
     &           PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT,
     &           TRACON
      SAVE       /ERCOM1/
C                              SPECIFICATIONS FOR COMMON /ERCOM2/
      CHARACTER  MSGSAV(255), PLIST(300), RNAME(51)*6
      COMMON     /ERCOM2/ MSGSAV, PLIST, RNAME
      SAVE       /ERCOM2/
C                              SPECIFICATIONS FOR COMMON /ERCOM3/
      DOUBLE PRECISION ERCKSM
      COMMON     /ERCOM3/ ERCKSM
      SAVE       /ERCOM3/
C                              SPECIFICATIONS FOR COMMON /ERCOM4/
      LOGICAL    ISUSER(51)
      COMMON     /ERCOM4/ ISUSER
      SAVE       /ERCOM4/
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  IABS,LEN,MIN0
      INTRINSIC  IABS, LEN, MIN0
      INTEGER    IABS, LEN, MIN0
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   E1INIT, E1INPL
C
      DATA IFINIT/0/
C                                  INITIALIZE IF NECESSARY
      IF (IFINIT .EQ. 0) THEN
         CALL E1INIT
         IFINIT = 1
      END IF
      LEN2 = LEN(STRING)
      LEN2 = MIN0(LEN2,255)
      DO 10  I=1, LEN2
         STRGUP(I) = STRING(I:I)
   10 CONTINUE
      IF (IABS(IL).GE.1 .AND. IABS(IL).LE.9) THEN
         CALL E1INPL ('L', IL, LEN2, STRGUP)
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  SAXPY (Single precision version)
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    August 9, 1986
C
C  Purpose:    Compute the scalar times a vector plus a vector,
C              y = ax + y, all single precision.
C
C  Usage:      CALL SAXPY (N, SA, SX, INCX, SY, INCY)
C
C  Arguments:
C     N      - Length of vectors X and Y.  (Input)
C     SA     - Real scalar.  (Input)
C     SX     - Real vector of length MAX(N*IABS(INCX),1).  (Input)
C     INCX   - Displacement between elements of SX.  (Input)
C              X(I) is defined to be
C                 SX(1+(I-1)*INCX) if INCX.GE.0  or
C                 SX(1+(I-N)*INCX) if INCX.LT.0.
C     SY     - Real vector of length MAX(N*IABS(INCY),1).
C              (Input/Output)
C              SAXPY replaces Y(I) with SA*X(I) + Y(I) for I=1,...,N.
C              X(I) and Y(I) refer to specific elements of SX and SY.
C     INCY   - Displacement between elements of SY.  (Input)
C              Y(I) is defined to be
C                 SY(1+(I-1)*INCY) if INCY.GE.0  or
C                 SY(1+(I-N)*INCY) if INCY.LT.0.
C
C  GAMS:       D1a7
C
C  Chapters:   MATH/LIBRARY Basic Matrix/Vector Operations
C              STAT/LIBRARY Mathematical Support
C
C  Copyright:  1986 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE SAXPY (N, SA, SX, INCX, SY, INCY)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    N, INCX, INCY
      REAL       SA, SX(*), SY(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, IX, IY, M, MP1
C                                  SPECIFICATIONS FOR SPECIAL CASES
C     INTRINSIC  MOD
      INTRINSIC  MOD
      INTEGER    MOD
C
      IF (N .GT. 0) THEN
         IF (SA .NE. 0.0) THEN
            IF (INCX.NE.1 .OR. INCY.NE.1) THEN
C                                  CODE FOR UNEQUAL INCREMENTS OR EQUAL
C                                  INCREMENTS NOT EQUAL TO 1
               IX = 1
               IY = 1
               IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
               IF (INCY .LT. 0) IY = (-N+1)*INCY + 1
               DO 10  I=1, N
                  SY(IY) = SY(IY) + SA*SX(IX)
                  IX = IX + INCX
                  IY = IY + INCY
   10          CONTINUE
            ELSE
C                                  CODE FOR BOTH INCREMENTS EQUAL TO 1
               M = MOD(N,4)
C                                  CLEAN-UP LOOP
               DO 30  I=1, M
                  SY(I) = SY(I) + SA*SX(I)
   30          CONTINUE
               MP1 = M + 1
               DO 40  I=MP1, N, 4
                  SY(I) = SY(I) + SA*SX(I)
                  SY(I+1) = SY(I+1) + SA*SX(I+1)
                  SY(I+2) = SY(I+2) + SA*SX(I+2)
                  SY(I+3) = SY(I+3) + SA*SX(I+3)
   40          CONTINUE
            END IF
         END IF
      END IF
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  I1ERIF
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    March 13, 1984
C
C  Purpose:    Return the position of the first element of a given
C              character array which is not an element of another
C              character array.
C
C  Usage:      I1ERIF(STR1, LEN1, STR2, LEN2)
C
C  Arguments:
C     STR1   - Character array to be searched.  (Input)
C     LEN1   - Length of STR1.  (Input)
C     STR2   - Character array to be searched for.  (Input)
C     LEN2   - Length of STR2.  (Input)
C     I1ERIF - Integer function.  (Output)
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      INTEGER FUNCTION I1ERIF (STR1, LEN1, STR2, LEN2)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    LEN1, LEN2
      CHARACTER  STR1(*), STR2(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   I1X
      INTEGER    I1X
C                              FIRST EXECUTABLE STATEMENT
      IF (LEN1.LE.0 .OR. LEN2.LE.0) THEN
         I1ERIF = 1
      ELSE
         DO 10  I=1, LEN1
            IF (I1X(STR2,LEN2,STR1(I),1) .EQ. 0) THEN
               I1ERIF = I
               RETURN
            END IF
   10    CONTINUE
         I1ERIF = 0
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  ICASE (Single precision version)
C
C  Computer:   DGC/SINGLE
C
C  Revised:    September 9, 1985
C
C  Purpose:    Convert from character to the integer ASCII value without
C              regard to case.
C
C  Usage:      ICASE(CH)
C
C  Arguments:
C     CH     - Character to be converted.  (Input)
C     ICASE  - Integer ASCII value for CH without regard to the case
C              of CH.  (Output)
C              ICASE returns the same value as IMSL routine IACHAR for
C              all but lowercase letters.  For these, it returns the
C              IACHAR value for the corresponding uppercase letter.
C
C  GAMS:       N3
C
C  Chapter:    MATH/LIBRARY Utilities
C              STAT/LIBRARY Utilities
C
C  Copyright:  1986 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      INTEGER FUNCTION ICASE (CH)
C                                  SPECIFICATIONS FOR ARGUMENTS
      CHARACTER  CH
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   IACHAR
      INTEGER    IACHAR
C
      ICASE = IACHAR(CH)
      IF (ICASE.GE.97 .AND. ICASE.LE.122) ICASE = ICASE - 32
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  S1ANUM
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    March 28, 1984
C
C  Purpose:    Scan a token and identify it as follows: integer, real
C              number (single/double), FORTRAN relational operator,
C              FORTRAN logical operator, or FORTRAN logical constant.
C
C  Usage:      CALL S1ANUM(INSTR, SLEN, CODE, OLEN)
C
C  Arguments:
C     INSTR  - Character string to be scanned.  (Input)
C     SLEN   - Length of INSTR.  (Input)
C     CODE   - Token code.  (Output)  Where
C                 CODE =  0  indicates an unknown token,
C                 CODE =  1  indicates an integer number,
C                 CODE =  2  indicates a (single precision) real number,
C                 CODE =  3  indicates a (double precision) real number,
C                 CODE =  4  indicates a logical constant (.TRUE. or
C                               .FALSE.),
C                 CODE =  5  indicates the relational operator .EQ.,
C                 CODE =  6  indicates the relational operator .NE.,
C                 CODE =  7  indicates the relational operator .LT.,
C                 CODE =  8  indicates the relational operator .LE.,
C                 CODE =  9  indicates the relational operator .GT.,
C                 CODE = 10  indicates the relational operator .GE.,
C                 CODE = 11  indicates the logical operator .AND.,
C                 CODE = 12  indicates the logical operator .OR.,
C                 CODE = 13  indicates the logical operator .EQV.,
C                 CODE = 14  indicates the logical operator .NEQV.,
C                 CODE = 15  indicates the logical operator .NOT..
C     OLEN   - Length of the token as counted from the first character
C              in INSTR.  (Output)  OLEN returns a zero for an unknown
C              token (CODE = 0).
C
C  Remarks:
C  1. Blanks are considered significant.
C  2. Lower and upper case letters are not significant.
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE S1ANUM (INSTR, SLEN, CODE, OLEN)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    SLEN, CODE, OLEN
      CHARACTER  INSTR(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    I, IBEG, IIBEG, J
      LOGICAL    FLAG
      CHARACTER  CHRSTR(6)
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      INTEGER    TABPTR(16), TDCNST, TICNST, TOKEN(13), TRCNST, TZERR
      CHARACTER  DIGIT(10), LETTER(52), MINUS, PERIOD, PLUS, TABLE(38)
      SAVE       DIGIT, LETTER, MINUS, PERIOD, PLUS, TABLE, TABPTR,
     &           TDCNST, TICNST, TOKEN, TRCNST, TZERR
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   I1X, I1CSTR
      INTEGER    I1X, I1CSTR
C
      DATA TOKEN/5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 4, 4/
      DATA TABLE/'D', 'E', 'E', 'Q', 'N', 'E', 'L', 'T', 'L',
     &     'E', 'G', 'T', 'G', 'E', 'A', 'N', 'D', 'O', 'R',
     &     'E', 'Q', 'V', 'N', 'E', 'Q', 'V', 'N', 'O', 'T',
     &     'T', 'R', 'U', 'E', 'F', 'A', 'L', 'S', 'E'/
      DATA TABPTR/1, 2, 3, 5, 7, 9, 11, 13, 15, 18, 20, 23, 27, 30,
     &     34, 39/
      DATA DIGIT/'0', '1', '2', '3', '4', '5', '6', '7', '8',
     &     '9'/
      DATA LETTER/'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
     &     'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S',
     &     'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c',
     &     'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm',
     &     'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
     &     'x', 'y', 'z'/
      DATA PERIOD/'.'/, PLUS/'+'/, MINUS/'-'/
      DATA TZERR/0/, TICNST/1/
      DATA TRCNST/2/, TDCNST/3/
C
      IF (SLEN .LE. 0) THEN
         CODE = 0
         OLEN = 0
         RETURN
      END IF
C                                  STATE 0 - ASSUME ERROR TOKEN
      IBEG = 1
      CODE = TZERR
C                                  CHECK SIGN
      IF (INSTR(IBEG).EQ.MINUS .OR. INSTR(IBEG).EQ.PLUS) THEN
         FLAG = .TRUE.
         IIBEG = IBEG
         IBEG = IBEG + 1
      ELSE
         FLAG = .FALSE.
      END IF
C                                  STATE 1 - ASSUME INTEGER CONSTANT
      IF (I1X(DIGIT,10,INSTR(IBEG),1) .NE. 0) THEN
         CODE = TICNST
         IIBEG = IBEG
         IBEG = IBEG + 1
C
   10    IF (IBEG .LE. SLEN) THEN
C
            IF (I1X(DIGIT,10,INSTR(IBEG),1) .NE. 0) THEN
               IIBEG = IBEG
               IBEG = IBEG + 1
               GO TO 10
C
            END IF
C
         ELSE
            GO TO 80
C
         END IF
C
         IF (INSTR(IBEG) .NE. PERIOD) GO TO 80
      END IF
C                                  STATE 2 - ASSUME REAL CONSTANT
      IF (CODE .EQ. TICNST) THEN
         CODE = TRCNST
         IIBEG = IBEG
         IBEG = IBEG + 1
         IF (IBEG .GT. SLEN) GO TO 80
      ELSE IF (INSTR(IBEG).EQ.PERIOD .AND. SLEN.GE.2) THEN
         IF (I1X(DIGIT,10,INSTR(IBEG+1),1) .NE. 0) THEN
            CODE = TRCNST
            IIBEG = IBEG + 1
            IBEG = IBEG + 2
            IF (IBEG .GT. SLEN) GO TO 80
         END IF
      END IF
C
      IF (I1X(DIGIT,10,INSTR(IBEG),1) .NE. 0) THEN
         CODE = TRCNST
         IIBEG = IBEG
         IBEG = IBEG + 1
C
   20    IF (IBEG .LE. SLEN) THEN
C
            IF (I1X(DIGIT,10,INSTR(IBEG),1) .NE. 0) THEN
               IIBEG = IBEG
               IBEG = IBEG + 1
               GO TO 20
C
            END IF
C
         ELSE
            GO TO 80
C
         END IF
C
      END IF
C
      IF (CODE .EQ. TZERR) THEN
         IF (INSTR(IBEG) .NE. PERIOD) GO TO 80
         IBEG = IBEG + 1
         IF (IBEG .GT. SLEN) GO TO 80
      END IF
C
      IF (I1X(LETTER,52,INSTR(IBEG),1) .EQ. 0) GO TO 80
      CHRSTR(1) = INSTR(IBEG)
C
      DO 30  I=2, 6
         IBEG = IBEG + 1
         IF (IBEG .GT. SLEN) GO TO 80
         IF (I1X(LETTER,52,INSTR(IBEG),1) .EQ. 0) GO TO 40
         CHRSTR(I) = INSTR(IBEG)
   30 CONTINUE
C
      GO TO 80
C
   40 CONTINUE
C
      DO 50  J=1, 15
         IF (I1CSTR(CHRSTR,I-1,TABLE(TABPTR(J)),TABPTR(J+1)-TABPTR(J))
     &        .EQ. 0) GO TO 60
   50 CONTINUE
C
      GO TO 80
C                                  STATE 4 - LOGICAL OPERATOR
   60 IF (J .GT. 2) THEN
C
         IF (CODE .EQ. TRCNST) THEN
C
            IF (INSTR(IBEG) .EQ. PERIOD) THEN
               CODE = TICNST
               IIBEG = IIBEG - 1
            END IF
C
            GO TO 80
C
         ELSE IF (INSTR(IBEG) .NE. PERIOD) THEN
            GO TO 80
C
         ELSE IF (FLAG) THEN
            GO TO 80
C
         ELSE
            CODE = TOKEN(J-2)
            IIBEG = IBEG
            GO TO 80
C
         END IF
C
      END IF
C                                  STATE 5 - DOUBLE PRECISION CONSTANT
      IF (CODE .NE. TRCNST) GO TO 80
      IF (INSTR(IBEG).EQ.MINUS .OR. INSTR(IBEG).EQ.PLUS) IBEG = IBEG +
     &    1
      IF (IBEG .GT. SLEN) GO TO 80
C
      IF (I1X(DIGIT,10,INSTR(IBEG),1) .EQ. 0) THEN
         GO TO 80
C
      ELSE
         IIBEG = IBEG
         IBEG = IBEG + 1
C
   70    IF (IBEG .LE. SLEN) THEN
C
            IF (I1X(DIGIT,10,INSTR(IBEG),1) .NE. 0) THEN
               IIBEG = IBEG
               IBEG = IBEG + 1
               GO TO 70
C
            END IF
C
         END IF
C
      END IF
C
      IF (J .EQ. 1) CODE = TDCNST
C
   80 CONTINUE
C
      IF (CODE .EQ. TZERR) THEN
         OLEN = 0
C
      ELSE
         OLEN = IIBEG
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  IMACH (Single precision version)
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    March 26, 1984
C
C  Purpose:    Retrieve integer machine constants.
C
C  Usage:      IMACH(N)
C
C  Arguments:
C     N      - Index of desired constant.  (Input)
C     IMACH  - Machine constant.  (Output)
C
C  Remark:
C     Following is a description of the assorted integer machine
C     constants.
C
C     Words
C
C        IMACH( 1) = Number of bits per integer storage unit.
C        IMACH( 2) = Number of characters per integer storage unit.
C
C     Integers
C
C        Assume integers are represented in the S-DIGIT, BASE-A form
C        SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
C        where 0 .LE. X(I) .LT. A for I=0,...,S-1.  Then
C
C        IMACH( 3) = A, the base.
C        IMACH( 4) = S, number of BASE-A digits.
C        IMACH( 5) = A**S - 1, largest magnitude.
C
C     Floating-point numbers
C
C        Assume floating-point numbers are represented in the T-DIGIT,
C        BASE-B form SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
C        where 0 .LE. X(I) .LT. B for I=1,...,T,
C        0 .LT. X(1), and EMIN .LE. E .LE. EMAX.  Then
C
C        IMACH( 6) = B, the base.
C
C        Single precision
C
C           IMACH( 7) = T, number of BASE-B digits.
C           IMACH( 8) = EMIN, smallest exponent E.
C           IMACH( 9) = EMAX, largest exponent E.
C
C        Double precision
C
C           IMACH(10) = T, number of BASE-B digits.
C           IMACH(11) = EMIN, smallest exponent E.
C           IMACH(12) = EMAX, largest exponent E.
C
C  GAMS:       R1
C
C  Chapters:   MATH/LIBRARY Reference Material
C              STAT/LIBRARY Reference Material
C              SFUN/LIBRARY Reference Material
C
C  Copyright:  1984 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      INTEGER FUNCTION IMACH (N)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    N
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    NOUT
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      INTEGER    IMACHV(12)
      SAVE       IMACHV
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   UMACH
C                                  DEFINE CONSTANTS
      DATA IMACHV(1)/32/
      DATA IMACHV(2)/4/
      DATA IMACHV(3)/2/
      DATA IMACHV(4)/31/
      DATA IMACHV(5)/2147483647/
      DATA IMACHV(6)/2/
      DATA IMACHV(7)/24/
      DATA IMACHV(8)/-125/
      DATA IMACHV(9)/128/
      DATA IMACHV(10)/53/
      DATA IMACHV(11)/-1021/
      DATA IMACHV(12)/1024/
C
      IF (N.LT.1 .OR. N.GT.12) THEN
C                                  ERROR.  INVALID RANGE FOR N.
         CALL UMACH (2, NOUT)
         WRITE (NOUT,99999) N
99999    FORMAT (/, ' *** TERMINAL ERROR 5 from IMACH.  The argument',
     &          /, ' ***          must be between 1 and 12 inclusive.'
     &          , /, ' ***          N = ', I6, '.', /)
         IMACH = 0
         STOP
C
      ELSE
         IMACH = IMACHV(N)
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  E1INPL
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    March 2, 1984
C
C  Purpose:    To store a character string in the parameter list PLIST
C              for use by the error message handler.
C
C  Usage:      CALL E1INPL(FORM,NUM,SLEN,STRUP)
C
C  Arguments:
C     FORM   - A character string of length one to be inserted into
C              PLIST which specifies the form of the string.  (Input)
C              For example, 'L' for string, 'A' for character array,
C              'I' for integer, 'K' for keyword (PROTRAN only).  An
C              asterisk is inserted into PLIST preceding FORM.
C     NUM    - Integer to be inserted as a character into PLIST
C              immediately following FORM.  (Input)  NUM must be between
C              1 and 9.
C     SLEN   - The number of characters in STRUP.  (Input)  LEN must be
C              less than or equal to 255.  The character representation
C              of SLEN is inserted into PLIST after NUM and an asterisk.
C     STRUP  - A character string of length LEN which is to be inserted
C              into PLIST.  (Input)  Trailing blanks are ignored.
C
C  Copyright:  1984 by IMSL, Inc.  All rights reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE E1INPL (FORM, NUM, SLEN, STRUP)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    NUM, SLEN
      CHARACTER  FORM, STRUP(*)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    IER, L, LEN2, LENCK, LOC, NLEN, NNUM
      CHARACTER  STRNCH(3)
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      CHARACTER  BLANK, PRCNT(1), TEMP(4)
      SAVE       BLANK, PRCNT, TEMP
C                                  SPECIFICATIONS FOR SPECIAL CASES
C                              SPECIFICATIONS FOR COMMON /ERCOM1/
      INTEGER    CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51),
     &           PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7,
     &           IALLOC(51), HDRFMT(7), TRACON(7)
      COMMON     /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE,
     &           PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT,
     &           TRACON
      SAVE       /ERCOM1/
C                              SPECIFICATIONS FOR COMMON /ERCOM2/
      CHARACTER  MSGSAV(255), PLIST(300), RNAME(51)*6
      COMMON     /ERCOM2/ MSGSAV, PLIST, RNAME
      SAVE       /ERCOM2/
C                              SPECIFICATIONS FOR COMMON /ERCOM3/
      DOUBLE PRECISION ERCKSM
      COMMON     /ERCOM3/ ERCKSM
      SAVE       /ERCOM3/
C                              SPECIFICATIONS FOR COMMON /ERCOM4/
      LOGICAL    ISUSER(51)
      COMMON     /ERCOM4/ ISUSER
      SAVE       /ERCOM4/
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  IABS
      INTRINSIC  IABS
      INTEGER    IABS
C                                  SPECIFICATIONS FOR SUBROUTINES
      EXTERNAL   C1TIC, M1VE
C
      DATA TEMP/'*', ' ', ' ', '*'/, PRCNT/'%'/, BLANK/' '/
C
      NNUM = IABS(NUM)
      LENCK = PLEN + SLEN + 8
      IF (NNUM.GE.1 .AND. NNUM.LE.9 .AND. LENCK.LE.300) THEN
         TEMP(2) = FORM
         CALL C1TIC (NNUM, TEMP(3), 1, IER)
         LOC = PLEN + 1
         IF (LOC .EQ. 2) LOC = 1
         CALL M1VE (TEMP, 1, 4, 4, PLIST(LOC), 1, 4, 262, IER)
         LOC = LOC + 4
         IF (NUM .LT. 0) THEN
            LEN2 = SLEN
         ELSE
            DO 10  L=1, SLEN
               LEN2 = SLEN - L + 1
               IF (STRUP(LEN2) .NE. BLANK) GO TO 20
   10       CONTINUE
            LEN2 = 1
   20       CONTINUE
         END IF
         NLEN = 1
         IF (LEN2 .GE. 10) NLEN = 2
         IF (LEN2 .GE. 100) NLEN = 3
         CALL C1TIC (LEN2, STRNCH, NLEN, IER)
         CALL M1VE (STRNCH, 1, NLEN, 3, PLIST(LOC), 1, NLEN, 262, IER)
         LOC = LOC + NLEN
         CALL M1VE (PRCNT, 1, 1, 1, PLIST(LOC), 1, 1, 262, IER)
         LOC = LOC + 1
         CALL M1VE (STRUP, 1, LEN2, LEN2, PLIST(LOC), 1, LEN2, 262,
     &              IER)
         PLEN = LOC + LEN2 - 1
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  UMACH (Single precision version)
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    March 21, 1984
C
C  Purpose:    Set or retrieve input or output device unit numbers.
C
C  Usage:      CALL UMACH (N, NUNIT)
C
C  Arguments:
C     N      - Index of desired unit.  (Input)
C              The values of N are defined as follows:
C              N = 1, corresponds to the standard input unit.
C              N = 2, corresponds to the standard output unit.
C     NUNIT  - I/O unit.  (Input or Output)
C              If the value of N is negative, the unit corresponding
C              to the index is reset to the value given in NUNIT.
C              Otherwise, the value corresponding to the index is
C              returned in NUNIT.
C
C  GAMS:       R1
C
C  Chapters:   MATH/LIBRARY Reference Material
C              STAT/LIBRARY Reference Material
C              SFUN/LIBRARY Reference Material
C
C  Copyright:  1984 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE UMACH (N, NUNIT)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    N, NUNIT
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    NN, NOUT
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      INTEGER    UNIT(2)
      SAVE       UNIT
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  IABS
      INTRINSIC  IABS
      INTEGER    IABS
C
      DATA UNIT(1)/5/
      DATA UNIT(2)/6/
C
      NN = IABS(N)
      IF (NN.NE.1 .AND. NN.NE.2) THEN
C                                  ERROR.  INVALID RANGE FOR N.
         NOUT = UNIT(2)
         WRITE (NOUT,99999) NN
99999    FORMAT (/, ' *** TERMINAL ERROR 5 from UMACH.  The absolute',
     &          /, ' ***          value of the index variable must be'
     &          , /, ' ***          1 or 2.  IABS(N) = ', I6,
     &          '.', /)
         STOP
C                                  CHECK FOR RESET OR RETRIEVAL
      ELSE IF (N .LT. 0) THEN
C                                  RESET
         UNIT(NN) = NUNIT
      ELSE
C                                  RETRIEVE
         NUNIT = UNIT(N)
      END IF
C
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  IACHAR (Single precision version)
C
C  Computer:   PCDSMS/SINGLE
C
C  Revised:    September 9, 1985
C
C  Purpose:    Return the integer ASCII value of a character argument.
C
C  Usage:      IACHAR(CH)
C
C  Arguments:
C     CH     - Character argument for which the integer ASCII value
C              is desired.  (Input)
C     IACHAR - Integer ASCII value for CH.  (Output)
C              The character CH is in the IACHAR-th position of the
C              ASCII collating sequence.
C
C  GAMS:       N3
C
C  Chapter:    MATH/LIBRARY Utilities
C              STAT/LIBRARY Utilities
C
C  Copyright:  1986 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      INTEGER FUNCTION IACHAR (CH)
C                                  SPECIFICATIONS FOR ARGUMENTS
      CHARACTER  CH
C                                  SPECIFICATIONS FOR SAVE VARIABLES
      IACHAR = ICHAR(CH)
      RETURN
      END
C-----------------------------------------------------------------------
C  IMSL Name:  I1CSTR (Single precision version)
C
C  Computer:   DGC/SINGLE
C
C  Revised:    September 10, 1985
C
C  Purpose:    Case insensitive comparison of two character arrays.
C
C  Usage:      I1CSTR(STR1, LEN1, STR2, LEN2)
C
C  Arguments:
C     STR1   - First character array.  (Input)
C     LEN1   - Length of STR1.  (Input)
C     STR2   - Second character array.  (Input)
C     LEN2   - Length of STR2.  (Input)
C     I1CSTR - Integer function.  (Output) Where
C              I1CSTR = -1  if STR1 .LT. STR2,
C              I1CSTR =  0  if STR1 .EQ. STR2,
C              I1CSTR =  1  if STR1 .GT. STR2.
C
C  Remarks:
C  1. If the two arrays, STR1 and STR2,  are of unequal length, the
C     shorter array is considered as if it were extended with blanks
C     to the length of the longer array.
C
C  2. If one or both lengths are zero or negative the I1CSTR output is
C     based on comparison of the lengths.
C
C  GAMS:       N5c
C
C  Chapter:    MATH/LIBRARY Utilities
C
C  Copyright:  1985 by IMSL, Inc.  All Rights Reserved.
C
C  Warranty:   IMSL warrants only that IMSL testing has been applied
C              to this code.  No other warranty, expressed or implied,
C              is applicable.
C
C-----------------------------------------------------------------------
C
      INTEGER FUNCTION I1CSTR (STR1, LEN1, STR2, LEN2)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER    LEN1, LEN2
      CHARACTER  STR1(LEN1), STR2(LEN2)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER    IC1, IC2, ICB, IS, L, LENM
C                                  SPECIFICATIONS FOR INTRINSICS
C     INTRINSIC  ISIGN,MIN0
      INTRINSIC  ISIGN, MIN0
      INTEGER    ISIGN, MIN0
C                                  SPECIFICATIONS FOR FUNCTIONS
      EXTERNAL   ICASE
      INTEGER    ICASE
C
      IF (LEN1.GT.0 .AND. LEN2.GT.0) THEN
C                                  COMPARE FIRST LENM CHARACTERS
         LENM = MIN0(LEN1,LEN2)
         DO 10  L=1, LENM
            IC1 = ICASE(STR1(L))
            IC2 = ICASE(STR2(L))
            IF (IC1 .NE. IC2) THEN
               I1CSTR = ISIGN(1,IC1-IC2)
               RETURN
            END IF
   10    CONTINUE
      END IF
C                                  COMPARISON BASED ON LENGTH OR
C                                  TRAILING BLANKS
      IS = LEN1 - LEN2
      IF (IS .EQ. 0) THEN
         I1CSTR = 0
      ELSE
         IF (LEN1.LE.0 .OR. LEN2.LE.0) THEN
C                                  COMPARISON BASED ON LENGTH
            I1CSTR = ISIGN(1,IS)
         ELSE
C                                  COMPARISON BASED ON TRAILING BLANKS
C                                  TO EXTEND SHORTER ARRAY
            LENM = LENM + 1
            ICB = ICASE(' ')
            IF (IS .GT. 0) THEN
C                                  EXTEND STR2 WITH BLANKS
               DO 20  L=LENM, LEN1
                  IC1 = ICASE(STR1(L))
                  IF (IC1 .NE. ICB) THEN
                     I1CSTR = ISIGN(1,IC1-ICB)
                     RETURN
                  END IF
   20          CONTINUE
            ELSE
C                                  EXTEND STR1 WITH BLANKS
               DO 30  L=LENM, LEN2
                  IC2 = ICASE(STR2(L))
                  IF (ICB .NE. IC2) THEN
                     I1CSTR = ISIGN(1,ICB-IC2)
                     RETURN
                  END IF
   30          CONTINUE
            END IF
C
            I1CSTR = 0
         END IF
      END IF
C
      RETURN
      END
