C
C   WNOMJLEWIS.FOR -- THIS PROGRAM IMPLEMENTS JEFF LEWIS'S IDEA
C                     TO OBTAIN STANDARD ERRORS FOR W-NOMINATE
C
C                          29 APRIL 2002
C
C************************************************************************
C************************************************************************
C*  WNOM9707.FOR     JULY 1997                                         **
C*                                                                     **
C*                 MULTI-DIMENSIONAL W-NOMINATE                        **
C*                                                                     **
C*           MULTI-DIMENSIONAL WEIGHTED NOMINAL THREE-STEP ESTIMATION  **
C*                             *        ******  *          *           **
C*           DEVELOPED BY KEITH T. POOLE AND HOWARD ROSENTHAL          **
C*           GRADUATE SCHOOL OF INDUSTRIAL ADMINISTRATION              **
C*           CARNEGIE-MELLON UNIVERSITY, PITTSBURGH, PA. 15213         **
C*                                                                     **
C*           INITIAL PROGRAM DEVELOPED 1982-1984                       **
C*           MULTIDIMENSIONAL PROGRAM DEVELOPED 1986-1987 IN           **
C*              CDC VECTOR FORTRAN                                     **
C*           OS2/SCALAR FORTRAN VERSION WRITTEN BY NOLAN MCCARTY       **
C*              AND KEITH T. POOLE 1991                                **
C*           THE MODIFIED NOMINATE ALGORITHM, W-NOMINATE, DEVELOPED BY **
C*              KEITH T. POOLE SEPTEMBER-NOVEMBER 1992.                **
C*           THIS SCALAR FORTRAN W-VERSION CURRENT AS OF JULY 1997     **
C*                                                                     **
C************************************************************************
C************************************************************************
C
C     THE PARAMETERS BEING ESTIMATED ARE: A SIGNAL TO NOISE RATIO CONSTANT
C     IN UTILITY FUNCTION PHASE--THIS IS BETA AND IS ESTIMATED FOR THE FIRST
C     DIMENSION.  FOR SUBSEQUENT DIMENSIONS, A WEIGHTING PARAMETER, W, IS
C     ESTIMATED--THIS PARAMETER IS IN THE EXPONENT OF THE UTILITY FUNCTION.
C
C     LEGISLATOR COORDINATES (IN LEGISLATOR PHASE).
C
C     MIDPOINT AND DISTANCE BETWEEN THE TWO OUTCOMES IN THE ROLL CALL PHASE.
C     ALL PARAMETERS ARE HELD FIXED EXCEPT DURING THEIR RESPECTIVE PHASES.
C     DURING UTILITY PHASE, LEGISLATOR AND ROLL CALL PARAMETERS ARE HELD FIXED
C     AND ARE STORED IN XDATA(.) AND ZMID(.)/DYN(.) RESPECTIVELY.  DURING
C     ROLL CALL PHASE, THE UTILITY FUNCTION CONSTANT, STORED IN BBB(1), IS
C     HELD FIXED AND THE LEGISLATORS ARE HELD FIXED.  DURING LEGISLATOR PHASE,
C     UTILITY AND ROLL CALL PARAMETERS ARE HELD FIXED.
C
C     THE FOLLOWING TABLE SHOWS WHAT IS STORED WHERE AND WHAT IS HELD CONSTANT
C     DURING EACH PHASE.
C
C       NOBS=# OF LEGISLATORS, NRCALL=# OF ROLL CALLS.
C       NDIM = DIMENSION NUMBER
C
C                     UTILITY PHASE     LEGISLATOR PHASE   ROLL CALL PHASE
C
C     BETA (SIG/NOISE)   B(1)               BBB(1)             BBB(1)
C     WEIGHT             B(1)               BBB(2)             BBB(2)
C
C     LEGISLATOR         XDATA(1,NDIM) TO   B(1)            XDATA(1,NDIM) TO
C       COORDS           XDATA(NOBS,NDIM)                   XDATA(NOBS,NDIM)
C
C     DISTANCE BET.      DYN(1,NDIM) TO     DYN(1,NDIM) TO      B(1)
C       OUTCOMES         DYN(NRCALL,NDIM)   DYN(NRCALL,NDIM)
C
C     MID PTS.           ZMID(1,NDIM) TO    ZMID(1,NDIM) TO     B(2)
C                        ZMID(NRCALL,NDIM)  ZMID(NRCALL,NDIM)
C
C
C     IN THE ROLL CALL PHASE, SUMMING TAKES PLACE OVER THE LEGISLATORS
C     AND ONLY THE PARAMETERS OF ONE ROLL CALL AT A TIME ARE UPDATED
C     AND THESE ARE HELD IN B(1) AND B(2).  LIKEWISE, IN THE LEGISLATOR
C     PHASE SUMMING TAKES PLACE OVER THE ROLL CALLS AND ONLY ONE LEGISLATOR
C     COORDINATE (STORED IN B(1)) IS UPDATED AT A TIME.  IN THE UTILITY PHASE
C     SUMMATION IS OVER ALL THE DATA AND THE ESTIMATE OF BETA (THE SIGNAL TO
C     NOISE RATIO) OR THE WEIGHT (FOR 2ND DIMENSION AND HIGHER) IS HELD
C     IN B(1).
C
C
C
C  FLOW DIAGRAM OF W-NOMINATE PROGRAM-- * INDICATES MAIN DO - LOOP
C
C     MAIN
C      |
C      |---CLEAN
C      |
C      |---ASCORE
C      |
C      |
C      |            |--STAT 
C      |---WHOOPE---|--FOCUSW
C      |            |--FOCUS
C      |            |--STAT  
C      |
C      |---RECODE--JANICE
C      |
C      |            |--NORMZ
C     *|            |          |--FUNNEL
C     *|---MAXLIK---|--BHHH  --|--STEPR --FUNNEL--LOGLIK--ITHOBS
C     *|            |--RPRINT--GRID2
C     *|            |--CROSS
C     *|
C     *|---OUTWRT--CORR
C      |
C      |---CROSS
C      |
C
C
C #$#$#$#$#$#$#$#$#$#$#
C
C   ARRAY SIZES
C  (ROD PROBLEM = 1100; LIZ = 4703)   1799 = # ROWS OF INPUT DATA
C                                     3598 = 2 * # ROWS OF INPUT DATA
C                                     5397 = 3 * # ROWS OF INPUT DATA
C  (ROD PROBLEM = 1650; LIZ =  113)   15599 = # COLUMNS OF INPUT DATA
C  (ROD PROBLEM = 1657; LIZ = 4708)   15999 = DUAL USE VECTORS =
C                                              MAX{# ROWS, # COLUMNS}
C                             WS(.)   33398 > 2*MAX(P,Q)
C
C  DO SEARCH-REPLACE ON THESE ARRAY SIZES BELOW
C
C #$#$#$#$#$#$#$#$#$#$#  
C
      DIMENSION ALP(2),BTA(2),RR(2),ZMAT2(1799,1799),XDATA2(1799,25),
     C          LL(2,2),LMO(15999),XD(1799),ZMAT(1799,1799),
     C          WVEC(1799),WVEC2(1799),XXX(1799),DSTAR(1799,1799),
     C          XDATA3(1799,25),XMAT(1799,25),Y16MIDP(50,50),UUU(50,50),
     C          VVV(50,50),YHAT(50),VCOV(50,50),XSAVE2(1799,25),
     C          FV1(50),FV2(50),XMATNEW(50,50),XSAVE3(1799,25),
     C          PROBMAT(1799,15599),TRUEX(1799,1799),TRUEZMID(15599,25),
     C          TRUEDYN(15599,25),XTARGET(1799,1799),STDDEV(5397,31),
     C          XMEANX(3598,31),XMAT0(1799,25),
     C          ZVEC(15599,25),TRUEX2(1799,1799),
     C          MCUTS(15599,2),WS(33398),LERROR(1799,15599),
     C          LLEGERR(1799,2),LDATA2(1799,15599),
     C          COVX(3598,10,10),COVX2(3598,10,10)
C   ************* POOLE(P,3*Q) ***********  HUGE ARRAY!!!! DEBUGGING PURPOSES ONLY!!!!
C
      CHARACTER*1 KNAME
      CHARACTER*64 TITLE,FMT,FMT2,FMT3,FNAME
      INTEGER*2 ITIM1,ITIM2,ITIM3,ITIM4,JTIM1,JTIM2,JTIM3,JTIM4
      COMMON /MINE/ NS,NDIM,NQ,NRCALL,NSTEP,NEQ,ISENS(1799),
     CJAN,JANLST,JIO,KIO,NOBS,NOPAR,IFDRV,NFEVAL,
     CMAXIT,MAXSQZ
      COMMON /LUCK/ YBIGL(15999),YYBIGL(15999)
      COMMON /ROLL/ KPJP(15999,4),LERIC(15599)
      COMMON /XXCOM/ ZMID(15599,25),XDATA(1799,25),DYN(15599,25),
     CLDATA(1799,15599),PSI(1799,15599,2)
      COMMON /XIME/ NTIME(1200),NITR,MSEC
      COMMON /SAVE/ XSAVE(1799,2,2),ZSAVE(15599,2,2),CSAVE(15599,2)
      COMMON /TCHOIC/ KPTSUM
      COMMON /DELTA/ B(50),TESTB(50),DELTAB(50),GRAD(50),V(25,25)
      COMMON /TOL/ TOLB
      COMMON /BOOK/ BBB(50),BBBB(25)
      COMMON /VOTES/ KAV(15599),KAY(15599),KAN(15599),KNAME(1799,99),JNE
      COMMON /INTGER /IIII
      COMMON /BAD/ KBAD1,KBAD2,SPRM,SPRSD
      COMMON /SENMIN/ SSS(100),KSMIN,KSMAX
      OPEN(4,FILE='NOMSTART_JLEWIS.DAT',STATUS='OLD')
      OPEN(21,FILE='NOM21.DAT')
      OPEN(23,FILE='NOM23.DAT')
      OPEN(31,FILE='NOM31.DAT')
      OPEN(33,FILE='NOM33.DAT')
C      OPEN(34,FILE='NOM34.DAT')
C      OPEN(35,FILE='NOM35.DAT')
      OPEN(36,FILE='NOM36.DAT')
      READ(4,1082)FNAME 
      WRITE(*,1082)FNAME
      OPEN(UNIT=3,FILE=FNAME,STATUS='OLD')
C
C      DATA ISENS/1799*1/
  100 FORMAT(2I5,10F10.4)
  101 FORMAT(10X,10F10.4)
 1082 FORMAT(A64)
 1000 FORMAT(22X,4(I2.2,'.'))
 1001 FORMAT(8I5)
 1002 FORMAT(30X,3F14.4)
 1003 FORMAT(15F8.4)
 1004 FORMAT(20A4)
 1005 FORMAT(1X,19A4)
 1006 FORMAT(F8.4,I5)
 1007 FORMAT(3A4)
 1008 FORMAT(' DATA     ',I6,I7)
 1009 FORMAT(' CLEAN    ',I6,I7)
 1010 FORMAT(' STARTS   ',I6,I7)
 1011 FORMAT(' RECODE   ',I6,I7)
 1015 FORMAT(' SINGULAR VALUE DECOMPOSITION',I5)
 1016 FORMAT(I5,50F7.3)
 1017 FORMAT(' ORTHOGONAL PROCRUSTES ROTATION MATRIX')
 1029 FORMAT(7X,'CONSTRAINED',7X,'UNCONSTRAINED'/1X,'OFF OPPOSITE',
     C3X,'OFF SAME'/2X,I5,9X,I5,9X,I5)
 1036 FORMAT(6I1)
 1037 FORMAT(6I2)
 1038 FORMAT(' NUMBER OF DIMENSIONS RESET TO=',I4)
 1090 FORMAT(' R-SQUARES TRUE VS. REPRODUCED',2I4,2F7.3)
 1111 FORMAT(' ELAPSED TIME OF JOB  ',4(I2.2,'.'))
 2001 FORMAT(3I5,9F7.3)
C
C
      CALL GETTIM(ITIM1,ITIM2,ITIM3,ITIM4)
      MSEC=ITIM1*60*60+ITIM2*60+ITIM3
C
C  CPUTIM RETURNS THE TIME IN SECONDS SINCE THE BEGINNING OF THE PROGRAM
C
      CALL CPUTIM(KTIM1)
      JIO=21
      KIO=23
      NITR=0
      JAN=0
C
C  READ IN PARAMETERS:  JANLST = # OF UNIVERSAL ITERATIONS
C                       NRCALL = # OF ROLL CALLS READ IN FROM DISK
C                       KLSEN  = INTEGER POSITION OF FURTHEST LEFT LEGISLATOR
C                                ALLOWS SETTING LIBERAL TO NEG VALUES
C                       MAXIT  = MAXIMUM NUMBER OF ITERATIONS IN BHHH 
C                                ALGORITHM (ESSENTIALLY NUMBER OF INVERSIONS
C                                OF INFORMATION MATRIX)
C                       MAXSQZ = NUMBER OF FUNCTION EVALUATIONS IN BHHH
C                                ALGORITHM.  BECAUSE OF STEPPING, THERE ARE
C                                MORE FUNCTION EVALUATIONS THAN THERE ARE
C                                ITERATIONS
C                       NS     = NUMBER OF DIMENSIONS TO BE ESTIMATED
C                       NQ     = NUMBER OF CHOICES (2 FOR ROLL CALL MODEL)
C                       JNE    = NUMBER OF CHARACTERS IN READ OF ROLL CALL
C                                MATRIX FORMAT STATEMENT.  THIS NUMBER WILL
C                                MATCH THE NUMBER OF CHARACTERS WRITTEN OUT
C                                IN FORMAT STATEMENT FOR WRITING OUT LEGIS-
C                                LATOR COORDINATES (SEE BELOW)
C
C  ******** EXAMPLE OF CONTROL CARD INPUT ********
C
C          SEN58KH.DTA
C          NOMINAL MULTI-DIMENSIONAL UNFOLDING OF 58TH SENATE
C              3  966    3
C             30   15    2    2   19
C           15.0000  0.5000  0.40
C            0.0500   10
C          (5X,2A1,3X,A1,2X,5A1,2X,11A1,966I1)
C          (1X,I4,5X,5A1,4X,2A1,2X,A1,3X,11A1,1X,4I4,51F7.3)
C  ***********************************************
C
      JANLST=3
      MAXIT=30
      MAXSQZ=10
      NQ=2
      READ(4,'(A)')TITLE
      READ(4,1001)NRCALL,KLSEN,KLSEN2
      READ(4,1001)NS,JNE,NTRIAL
      WRITE(JIO,'(A)')TITLE
      WRITE(JIO,1001)NRCALL,KLSEN,KLSEN2
      WRITE(JIO,1001)NS,JNE,NTRIAL
      WRITE(*,'(A)')TITLE
      WRITE(*,1001)NRCALL,KLSEN,KLSEN2
      WRITE(*,1001)NS,JNE,NTRIAL
      WRITE(KIO,'(A)')TITLE
C
C  READ IN STARTING VALUE FOR BETA AND VALUE FOR WEIGHT FOR ESTIMATING
C  THE UTILITY FUNCTION. THE LEGISLATOR AND ROLL CALL STARTING VALUES ARE
C  GENERATED INTERNALLY IN THE PROGRAM.
C
      TOLB=.40
      READ(4,1003)(BBB(J),J=1,2)
      BBBB(1)=BBB(2)
      WRITE(JIO,1003)(BBB(J),J=1,2)
      WRITE(*,1003)(BBB(J),J=1,2)
C
C  XVMIN IS THE CUTOFF VALUE FOR MINORITY PERCENTAGE OF THE ROLL CALL (USUALLY
C    .05 OR .025) AND KVMIN IS THE MINIMUM NUMBER OF VOTES FOR A LEGISLATOR
C    TO BE INCLUDED IN THE ANALYSIS
C
      READ(4,1006)XVMIN,KVMIN
      WRITE(JIO,1006)XVMIN,KVMIN
      WRITE(*,1006)XVMIN,KVMIN
C
C  READ IN FORMAT OF ROLL CALL MATRIX (SEE EXAMPLE ABOVE)
C
      READ(4,'(A)')FMT
      WRITE(*,'(A)')FMT
      WRITE(JIO,'(A)')FMT
C
C  READ IN FORMAT TO WRITE LEGISLATOR COORDINATES TO DISK (SEE EXAMPLE ABOVE)
C
      READ(4,'(A)')FMT2
      WRITE(*,'(A)')FMT2
      WRITE(JIO,'(A)')FMT2
      READ(4,'(A)')FMT3
      WRITE(*,'(A)')FMT3
      WRITE(JIO,'(A)')FMT3
      KPTSUM=0
      NOB=0
      NBB=0
C
C  READ IN ROLL CALL DATA FROM UNIT 3 USING FORMAT STATEMENT READ IN
C     ABOVE.  NOTE THAT JNE = # A1'S IN FORMAT STATEMENT
C
C     KNAME DESCRIBES NAME, PARTY, STATE ETC. OF THE LEGISLATOR
C
  10  READ(3,FMT,END=20)(KNAME(NOB+1,J),J=1,JNE),
     C                  (LDATA(NOB+1,J),J=1,NRCALL)
      NBB=NBB+1
      ISENS(NBB)=1
      NOB=NOB+1
C
      GO TO 10
  20  NOBS=NOB
      CALL CPUTIM(KTIM1)
      WRITE(JIO,1008)KTIM1,KTIM1
      WRITE(*,1008)KTIM1,KTIM1
      LTIME=KTIM1
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(XVMIN,KVMIN,LDATA2)
      CALL CPUTIM(KTIM1)
      MTIME=KTIM1-LTIME
      WRITE(JIO,1009)KTIM1,MTIME
      WRITE(*,1009)KTIM1,MTIME
      LTIME=KTIM1
C
C  RESET NUMBER OF DIMENSIONS IF IT EXCEEDS NOBS-1
C
      IF(NS.GT.NOBS-1)THEN
         NS=NOBS-1
         WRITE(JIO,1038)NS
         WRITE(*,1038)NS
      ENDIF
C
C  ***************************
C
C  BOOTSTRAP LOOP BEGINS HERE
C
C  ***************************
C
C      NTRIAL=1001
C
      DO 77 K=1,NS
      DO 77 I=1,NOBS
      XMEANX(I,K)=0.0
      STDDEV(I,K)=0.0
      XMEANX(I+NOBS,K)=0.0
      STDDEV(I+NOBS,K)=0.0
      STDDEV(I+2*NOBS,K)=0.0
      DO 77 L=1,NS
      COVX(I,K,L)=0.0
      COVX(I+NOBS,K,L)=0.0
      COVX2(I,K,L)=0.0
      COVX2(I+NOBS,K,L)=0.0
  77  CONTINUE
C
      DO 9988 I999=1,NTRIAL
C
C **&*&*&*&*&*&*&*&*&*&*&*&*&
C  WARNING !!!!!!!!!!!!!
C  IN RECODE SUBROUTINE, THE IIII FLAG IS > 1 ON THE
C  2ND PASS, THAT IS, I999 > 1.  THIS FORTUNATELY DOES
C  NOT AFFECT THE CODE BECAUSE LDATA(.,.) USES "2" 
C  RATHER THAN "6" ON THE SECOND PASS!!!!!!!!!!!!!
C  CODE WAS CHANGED IN RECODE TO USE LDATA2(.,.) --
C  IT ALWAYS USES "1" AND "6"
C **&*&*&*&*&*&*&*&*&*&*&*&*&
C
C
C    INITIALIZE PSI MATRICES OF DIMENSIONAL WEIGHTING FACTORS
C
      BBB(1)=15.0
      BBB(2)=0.5
      DO 69 K=1,2
      DO 69 I=1,NOBS
      ISENS(I)=1
      DO 69 J=1,NRCALL
      DO 68 L=1,NS
      BBBB(L)=BBB(2)
      ZMID(J,L)=0.0
      DYN(J,L)=0.0
  68  CONTINUE
      LERIC(J)=1
 69   PSI(I,J,K) = 1.0
C
C
C  CALL SUBROUTINE ASCORE -- PERFORMS EIGENVALUE/EIGENVECTOR 
C    DECOMPOSITION OF MATRIX OF AGREEMENT SCORES
C
      CALL ASCORE(NOBS,NRCALL,NS,KIO,ZMAT,WVEC,ZMAT2,WVEC2,DSTAR)
C
C
C  NORMALIZE LEGISLATOR COORDINATES FROM EIGENVECTORS
C
      DO 711 I=1,NOBS
      DO 712 K=1,NS
      XDATA2(I,K)=ZMAT(I,NOBS+1-K)*SQRT(ABS(WVEC(NOBS+1-K)))
      XDATA(I,K)=ZMAT2(I,NOBS+1-K)*SQRT(ABS(WVEC2(NOBS+1-K)))
      IF(K.EQ.1)XXX(I)=XDATA(I,1)
  712 CONTINUE
  711 CONTINUE
C
C  NORMALIZE 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,NOBS
  30  SUM=SUM+XDATA2(I,K)
      DO 32 I=1,NOBS
      XDATA2(I,K)=XDATA2(I,K)-SUM/FLOAT(NOBS)
  32  CONTINUE
  31  CONTINUE
      BB=-99.0
      DO 46 I=1,NOBS
      SUM=0.0
      DO 34 K=1,NS
      SUM=SUM+XDATA2(I,K)**2
  34  CONTINUE
      BB=AMAX1(BB,SUM)
  46  CONTINUE
      DO 35 I=1,NOBS
      DO 36 K=1,NS
      XDATA2(I,K)=XDATA2(I,K)*(1.0/SQRT(BB))
  36  CONTINUE
  35  CONTINUE
C
C  WRITE OUT HECKMAN-SNYDER COORDINATES
C
      DO 714 I=1,NOBS
C      WRITE(34,FMT3)I,(KNAME(I,J),J=1,JNE),
C     C                                 (XDATA2(I,J),J=1,NS)
  714 CONTINUE
C
C  PERFORM METRIC SCALING TO INCREASE PRECISION OF STARTING COORDINATES
C
      CALL WHOOPE(NOBS,NS,DSTAR,XXX,XDATA,SSE1,SSE2,KTP)
      DO 71 K=1,NS
      SUM=0.0
      BB=-99.0
      DO 70 I=1,NOBS
      IF(NS.EQ.1)XDATA(I,1)=XXX(I)
  70  SUM=SUM+XDATA(I,K)
      DO 72 I=1,NOBS
      XDATA(I,K)=XDATA(I,K)-SUM/FLOAT(NOBS)
  72  BB=AMAX1(BB,XDATA(I,K))
      DO 73 I=1,NOBS
  73  XDATA(I,K)=XDATA(I,K)/BB
  71  CONTINUE
C
C  NORMALIZE ESTIMATES OF LEGISLATORS TO BE WITHIN THE
C   UNIT HYPERSPHERE WITH CENTROID = 0
C
      DO 51 K=1,NS
      SUM=0.0
      DO 50 I=1,NOBS
  50  SUM=SUM+XDATA(I,K)
      DO 52 I=1,NOBS
      XDATA(I,K)=XDATA(I,K)-SUM/FLOAT(NOBS)
  52  CONTINUE
  51  CONTINUE
      BB=-99.0
      DO 56 I=1,NOBS
      SUM=0.0
      DO 54 K=1,NS
      SUM=SUM+XDATA(I,K)**2
  54  CONTINUE
      BB=AMAX1(BB,SUM)
  56  CONTINUE
      DO 55 I=1,NOBS
      DO 57 K=1,NS
      XDATA(I,K)=XDATA(I,K)*(1.0/SQRT(BB))
      XDATA3(I,K)=XDATA(I,K)
  57  CONTINUE
  55  CONTINUE
C
C  WRITE OUT METRIC SCALING COORDINATES USED AS STARTS
C
      DO 713 I=1,NOBS
C      WRITE(35,FMT3)I,(KNAME(I,J),J=1,JNE),
C     C                                 (XDATA(I,J),J=1,NS)
      DO 713 K=1,NS
      XMAT0(I,K)=XDATA(I,K)
  713 CONTINUE
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
C      CALL CUTPLANE(JJJ,NOBS,NRCALL,NS,XMAT0,ZVEC,WS,
C     C                MCUTS,LERROR,IFIXX,KTT,KT,LDATA2)
C      CALL LEGIS(JJJ,NOBS,NRCALL,NS,XMAT0,LLEGERR,
C     C                  ZVEC,WS,MCUTS,LERROR,LTOTAL,MWRONG,
C     C                  LDATA2)
  620 CONTINUE
C
C  CHECK POLARITY OF OC COORDINATES
C
      XLEFT=XMAT0(KLSEN,1)
      XUP=XMAT0(KLSEN2,2)
      DO 1949 I=1,NOBS
      IF(XLEFT.GT.0.0)THEN
         XMAT0(I,1)=-XMAT0(I,1)
      ENDIF
      IF(XUP.LT.0.0)THEN
         XMAT0(I,2)=-XMAT0(I,2)
      ENDIF
 1949 CONTINUE
      NOISE=1947
C      IF(NOISE.EQ.1947)STOP
      CALL CPUTIM(KTIM1)
      MTIME=KTIM1-LTIME
      WRITE(JIO,1010)KTIM1,MTIME
      WRITE(*,1010)KTIM1,MTIME
      LTIME=KTIM1
C
C  SUBROUTINE RECODE--GENERATES STARTING VALUES FOR ROLL CALL MIDPOINTS
C    ON THE FIRST DIMENSION AND DETERMINES POLARITY OF ROLL CALL
C
      CALL RECODE(NS,NOBS,NRCALL,LDATA2,KLSEN,KLSEN2,KIO)
C
      CALL CPUTIM(KTIM1)
      MTIME=KTIM1-LTIME
      WRITE(JIO,1011)KTIM1,MTIME
      WRITE(*,1011)KTIM1,MTIME
      LTIME=KTIM1
      NTIME(1)=LTIME
C
C   DIMENSIONAL LOOP--ESTIMATES EACH DIMENSION SEPARATELY
C
      DO 2222 NNDIM=1,NS
      NDIM=NNDIM
C
C   FIND MAXIMUM AND MINIMUM LEGISLATORS FOR CURRENT DIMENSION STARTS AND
C       CALCULATE SHRINKAGE PARAMETER FOR CURRENT DIMENSION STARTS TO
C       CONFORM WITH UNIT HYPERSPHERE CONSTRAINT -- ALPHA IS THE SHRINKAGE
C       PARAMETER
C
      AA=99.0
      BB=-99.0
      ASUM=0.0
      BSUM=0.0
      DO 1 I=1,NOBS
      IF(NDIM.GE.2)THEN
          SUM=0.0
          DO 2 K=1,NDIM-1
            SUM=SUM+XDATA(I,K)**2
  2       CONTINUE
          XEPS=SQRT(ABS(1.0-SUM))
          ASUM=ASUM+ABS(XDATA(I,NDIM)*XEPS)
          BSUM=BSUM+XDATA(I,NDIM)**2
      ENDIF
      AA=AMIN1(AA,XDATA(I,NDIM))
      BB=AMAX1(BB,XDATA(I,NDIM))
      IF(ABS(AA-XDATA(I,NDIM)).LE..0001)KSMIN=I
      IF(ABS(BB-XDATA(I,NDIM)).LE..0001)KSMAX=I
  1   CONTINUE
C
C  CORRECT FOR SHRINKAGE
C
      ALPHA=1.0
      IF(NDIM.GE.2)THEN
           ALPHA=AMAX1(XD(1),ABS(XD(NOBS)))
           ALPHA=ALPHA/XDATA(KSMAX,NDIM)
C          ALPHA=ASUM/BSUM
          DO 22 I=1,NOBS
  22      XDATA(I,NDIM)=XDATA(I,NDIM)*ALPHA
      ENDIF
      SSS(1)=XDATA(KSMIN,NDIM)
      SSS(2)=XDATA(KSMAX,NDIM)
C
      WRITE(21,2001)NDIM,KSMIN,KSMAX,ALPHA,SSS(1),SSS(2)
C
C  **UNIVERSAL LOOP**
C     3-STEP ESTIMATION; BETA, ROLL CALLS, LEGISLATORS
C     JANLST IS # OF UNIVERSAL ITERATIONS.
C
      JAN=0
      NITR=0
      DO 9999 IIII=1,JANLST
      JAN=JAN+1
      DO 6666 NSTEP=-1,2
C
C     UTILITY FUNCTION PHASE--BETA ESTIMATED
C
      IF(NSTEP.EQ.0.AND.IIII.GT.1.AND.NNDIM.EQ.1)THEN
           NOPAR=1
           NITR=NITR+1
           CALL MAXLIK
      ENDIF
C
C     ROLL CALL PHASE--MIDPOINT AND DISTANCE BETWEEN TWO OUTCOMES ESTIMATED
C
      IF(NSTEP.EQ.1)THEN
           NOPAR=2
           NITR=NITR+1
           CALL MAXLIK
C
           CALL OUTWRT(NRCALL,NSTEP,JIO,KIO,JAN,999,KPJP,YBIGL,
     C        FMT2,NDIM,NS)
C       IF(NDIM.EQ.2)STOP
      ENDIF
C
C     LEGISLATOR PHASE--COORDINATE ESTIMATED
C
      IF(NSTEP.EQ.2)THEN
           NOPAR=1
           NITR=NITR+1
           CALL MAXLIK
           CALL OUTWRT(NOBS,NSTEP,JIO,KIO,JAN,999,KPJP,YYBIGL,
     C         FMT2,NDIM,NS)
      ENDIF
C
C     UTILITY FUNCTION PHASE--WEIGHT ESTIMATED (S => 2)
C
      IF(NSTEP.EQ.-1.AND.IIII.GT.1.AND.NNDIM.GT.1)THEN
           NOPAR=1
           NITR=NITR+1
           CALL MAXLIK
      ENDIF
 6666 CONTINUE
C
C  CALCULATE NUMBER OF CONSTRAINED ROLL CALLS AND CORRELATION BETWEEN
C  CURRENT PARAMETER ESTIMATES AND THOSE FROM PREVIOUS ITERATIONS
C
      KRSCLL=NRCALL-KBAD1-KBAD2
      CALL CORR(ALP,BTA,RR,0)
      WRITE(KIO,2001)KBAD2,KBAD1,KRSCLL,SPRM,SPRSD,ALP(1),BTA(1),RR(1),
     CSSS(1),SSS(3),SSS(4),SSS(2)
C      WRITE(*,2001)KBAD2,KBAD1,KRSCLL,SPRM,SPRSD,ALP(1),BTA(1),RR(1),
C     CSSS(1),SSS(3),SSS(4),SSS(2)
 9999 CONTINUE
C
C  END OF UNIVERSAL LOOP
C    SETUP PARAMETERS FOR FINAL ESTIMATE OF BETA/WEIGHT AND ROLL CALLS USING
C    FINAL ADJUSTED LEGISLATOR COORDINATES
C
C  FINAL ESTIMATION OF BETA (1ST DIMENSION ONLY)
C
      IF(NDIM.EQ.1)THEN
         JAN=JAN+1
         NSTEP=0
         NOPAR=1
         NITR=NITR+1
         CALL MAXLIK
      ENDIF
C
C  FINAL ESTIMATION OF WEIGHT (2ND DIMENSION AND HIGHER)
C
      IF(NDIM.GT.1)THEN
         JAN=JAN+1
         NSTEP=-1
         NOPAR=1
         NITR=NITR+1
         CALL MAXLIK
      ENDIF
C
C  FINAL ESTIMATION OF ROLL CALL PARAMETERS
C
      NSTEP=1
      NOPAR=2
      NITR=NITR+1
      CALL MAXLIK
      CALL OUTWRT(NRCALL,NSTEP,JIO,KIO,JAN,9999,KPJP,YBIGL,
     C     FMT2,NDIM,NS)
C
C
C
C  SETUP PARAMETERS TO CALCULATE CLASSIFICATIONS FOR LEGISLATORS
C
      NSTEP=2
      DO 3 II=1,NOBS
      LMO(II)=II
      JJ=II
C
C     SUBROUTINE CROSS COMPUTES 2X2 PREDICTIONS FOR ROLL CALLS AND LEGS.
C
      CALL CROSS(JJ,LL)
      JJ=1
      DO 4 I=1,2
      DO 4 J=1,2
      KPJP(II,JJ)=LL(I,J)
  4   JJ=JJ+1
  3   CONTINUE
C
C  WRITE OUT FINAL ESTIMATE OF LEGISLATORS WITH CROSS CLASSIFICATIONS
C
      CALL OUTWRT(NOBS,NSTEP,KIO,KIO,999,999,KPJP,YYBIGL,FMT2,NDIM,NS)
C
C  SORT LEGISLATORS AND WRITE OUT THE 6 MOST EXTREME LEGISLATORS
C
      DO 1041 KK=1,NOBS
      XD(KK)=XDATA(KK,NDIM)
      LMO(I)=I
 1041 CONTINUE
      CALL RSORT(XD,NOBS,LMO)
      WRITE(JIO,1039)
      WRITE(*,1039)
 1039 FORMAT(' SAG IN RECOVERED LEGISLATOR COORDINATES')
 1040 FORMAT(1X,2F7.3)
      DO 102 I=1,NOBS
C
C  WRITE OUT PARTIAL LIST OF LEGISLATOR COORDINATES--NOTE THAT
C    THIS FORMAT IS UNIQUE TO THE ROLL CALL DATA -- FOR DIFFERENT
C    MATRICES, THIS CODE WILL HAVE TO BE COMMENTED OUT -- SEE
C    EXAMPLE BELOW
C
      IF(I.GT.3.AND.I.LT.NOBS-2)GO TO 102
      WRITE(JIO,FMT2)ISENS(LMO(I)),(KNAME(LMO(I),J),J=1,JNE),
     C     (KPJP(LMO(I),J),J=1,4),XD(I)
      WRITE(*,FMT2)ISENS(LMO(I)),(KNAME(LMO(I),J),J=1,JNE),
     C     (KPJP(LMO(I),J),J=1,4),XD(I)
  102 CONTINUE
C
C  SETUP PARAMETERS TO CALCULATE CLASSIFICATIONS FOR ROLL CALLS
C
      NSTEP=1
      DO 5 II=1,NRCALL
      LMO(II)=II
      JJ=II
      CALL CROSS(JJ,LL)
      JJ=1
      DO 6 I=1,2
      DO 6 J=1,2
      KPJP(II,JJ)=LL(I,J)
  6   JJ=JJ+1
  5   CONTINUE
C
C  WRITE OUT FINAL ESTIMATES OF ROLL CALLS WITH CROSS CLASSIFICATIONS
C
      CALL OUTWRT(NRCALL,NSTEP,KIO,KIO,999,999,KPJP,YBIGL,FMT2,NDIM,NS)
C
C  WRITE OUT FINAL NUMBERS OF CONSTRAINED ROLL CALLS
C
      KRSCLL=NRCALL-KBAD1-KBAD2
      WRITE(JIO,1029)KBAD2,KBAD1,KRSCLL
      WRITE(*,1029)KBAD2,KBAD1,KRSCLL
C
C    UPDATE THE PSI MATRICES FOLLOWING THE ESTIMATION OF COORDINATES
C       OF DIMENSION NDIM
C
      DO 1492 I=1,NOBS
      ISENS(I)=1
      DO 1492 J=1,NRCALL
      DY=0.0
      DN=0.0
C      DYY=-(BBB(2)*(XDATA(I,NDIM)-ZMID(J,NDIM)+DYN(J,NDIM)))**2
C      DNN=-(BBB(2)*(XDATA(I,NDIM)-ZMID(J,NDIM)-DYN(J,NDIM)))**2
      DO 1493 K=1,NDIM
      DY=DY+(BBBB(K)*(XDATA(I,K)-ZMID(J,K)+DYN(J,K)))**2
      DN=DN+(BBBB(K)*(XDATA(I,K)-ZMID(J,K)-DYN(J,K)))**2
 1493 CONTINUE
      DY=EXP(-DY/2.0)
      DN=EXP(-DN/2.0)
C      DYY=EXP(DYY/2.0)
C      DNN=EXP(DNN/2.0)
C      IF(DY.NE.DYY.OR.DN.NE.DNN)THEN
C         WRITE(*,1911)I,J,DY,DYY,DN,DNN
C 1911 FORMAT(2I5,4F10.4)
C         STOP
C      ENDIF
      PSI(I,J,1)=DY
      PSI(I,J,2)=DN
 1492 CONTINUE
      BBB(2)=.5
 2222 CONTINUE
C
C
C  COMPUTE PROBABILITY MATRIX FOR CHOICES
C
C
      IF(I999.EQ.1)THEN
         BETA=BBB(1)
C
           DO 109 J=1,NRCALL
           DO 109 I=1,NOBS
           ICH=LDATA(I,J)
C           POOLE(I,J)=-1.0
           IF(ICH.LE.0)GO TO 109
C
           SUMY=0.0
           SUMN=0.0
           DO 96 K=1,NS
           SUMY=SUMY+(BBBB(K)*(XDATA(I,K)-ZMID(J,K)+DYN(J,K)))**2
           SUMN=SUMN+(BBBB(K)*(XDATA(I,K)-ZMID(J,K)-DYN(J,K)))**2
C
C  STORE ESTIMATED ("TRUE") COORDINATES
C
           TRUEX(I,K)=XDATA(I,K)
           TRUEX2(I,K)=XMAT0(I,K)
           TRUEZMID(J,K)=ZMID(J,K)
           TRUEDYN(J,K)=DYN(J,K)
C
   96      CONTINUE
           PART1=EXP(-SUMY/2.0)
           PART2=EXP(-SUMN/2.0)
           SUMY=BETA*EXP(-SUMY/2.0)
           SUMN=BETA*EXP(-SUMN/2.0)
           PIY=EXP(SUMY)/(EXP(SUMY)+EXP(SUMN))
           PROBMAT(I,J)=PIY
           IF(ICH.EQ.1)THEN
C              POOLE(I,J)=PIY
C              POOLE(I,J+NRCALL)=PART1
C              POOLE(I,J+2*NRCALL)=PART2
           ENDIF
           IF(ICH.EQ.2)THEN
C              POOLE(I,J)=1.0-PIY
C              POOLE(I,J+NRCALL)=PART2
C              POOLE(I,J+2*NRCALL)=PART1
           ENDIF
  109      CONTINUE
           DO 659 I=1,NOBS
           DO 659 J=1,NRCALL
C           WRITE(66,660)I,J,(KNAME(I,JJ),JJ=1,JNE),
C     C               POOLE(I,J),POOLE(I,J+NRCALL),POOLE(I,J+2*NRCALL)
  659      CONTINUE
  660 FORMAT(2I5,1X,36A1,2000F8.4)
C
           DO 1427 I=1,NOBS
           DO 1428 J=1,NRCALL
           ICH=LDATA(I,J)
           IF(ICH.LE.0)GO TO 1428
C
           COINFLIP=RNUNF()
C
           IF(COINFLIP.LE.PROBMAT(I,J))THEN
              LDATA(I,J)=1
              LDATA2(I,J)=1
           ENDIF
           IF(COINFLIP.GT.PROBMAT(I,J))THEN
              LDATA(I,J)=2
              LDATA2(I,J)=6
           ENDIF
 1428      CONTINUE
C           WRITE(66,FMT)(KNAME(I,JJ),JJ=1,JNE),
C     C                         (LDATA2(I,JJ),JJ=1,NRCALL)
 1427      CONTINUE           
      ENDIF
C
C  DRAW NEW ROLL CALL MATRIX
C
      IF(I999.GT.1)THEN
C
           DO 108 J=1,NRCALL
           DO 108 I=1,NOBS
           ICH=LDATA(I,J)
           IF(ICH.LE.0)GO TO 108
C
           COINFLIP=RNUNF()
C
           IF(COINFLIP.LE.PROBMAT(I,J))THEN
              LDATA(I,J)=1
              LDATA2(I,J)=1
           ENDIF
           IF(COINFLIP.GT.PROBMAT(I,J))THEN
              LDATA(I,J)=2
              LDATA2(I,J)=6
           ENDIF
  108      CONTINUE           
           DO 107 I=1,NOBS
           DO 107 K=1,NS
           XTARGET(I,K)=XDATA(I,K)
  107      CONTINUE
           CALL ROTATE(NOBS,NS,XTARGET,TRUEX)
           DO 654 I=1,NOBS
           DO 654 K=1,NS
           STDDEV(I,K)=STDDEV(I,K)+(TRUEX(I,K)-XTARGET(I,K))**2
           XMEANX(I,K)=XMEANX(I,K)+XTARGET(I,K)
           DO 6541 L=1,NS
           COVX(I,K,L)=COVX(I,K,L)+XTARGET(I,K)*XTARGET(I,L)
 6541      CONTINUE
  654      CONTINUE
           DO 1070 I=1,NOBS
           DO 1070 K=1,NS
           XTARGET(I,K)=XMAT0(I,K)
 1070      CONTINUE
           CALL ROTATE(NOBS,NS,XTARGET,TRUEX2)
           DO 6540 I=1,NOBS
           DO 6540 K=1,NS
           STDDEV(I+NOBS,K)=STDDEV(I+NOBS,K)+
     C                          (TRUEX2(I,K)-XTARGET(I,K))**2
           STDDEV(I+2*NOBS,K)=STDDEV(I+2*NOBS,K)+
     C                          XTARGET(I,K)**2
           XMEANX(I+NOBS,K)=XMEANX(I+NOBS,K)+XTARGET(I,K)
           DO 6542 L=1,NS
           COVX(I+NOBS,K,L)=COVX(I+NOBS,K,L)+XTARGET(I,K)*XTARGET(I,L)
 6542      CONTINUE
 6540      CONTINUE
      ENDIF

C
C
C  ROTATE HECKMAN-SNYDER COORDINATES AND METRIC SCALING COORDINATES TO
C     BEST FIT THE W-NOMINATE COORDINATES AND CALCULATE FITS
C
      DO 2221 JJJJ=1,2
      DO 785 I=1,NOBS
      DO 784 K=1,NS
      IF(JJJJ.EQ.1)XMAT(I,K)=XDATA2(I,K)
      IF(JJJJ.EQ.2)XMAT(I,K)=XDATA3(I,K)
  784 CONTINUE
  785 CONTINUE
C
C  ROTATE TRUE COORDINATES TO BEST FIT ESTIMATED COORDINATES USING
C    SCHONEMANN'S ORTHOGONAL PROCRUSTES SOLUTION
C
      DO 376 L=1,NS
      DO 377 K=1,NS
      SUM=0.0
      DO 378 I=1,NOBS
      SUM=SUM+XMAT(I,K)*XDATA(I,L)
  378 CONTINUE
      Y16MIDP(K,L)=SUM
  377 CONTINUE
  376 CONTINUE
  
C  CALL SINGULAR VALUE DECOMPOSITION ROUTINE
C
      XTOL=.001
C      CALL LSVRR(NS,NS,Y16MIDP,50,21,XTOL,IRANK,YHAT,UUU,
C     C           50,VVV,50)
      CALL SVDSVD(NS,NS,Y16MIDP,YHAT,UUU,VVV,IRANK)
C
      WRITE(23,1015)IRANK
C
C  COMPUTE ROTATION MATRIX
C
      WRITE(23,1017)
      DO 379 K=1,NS
      DO 380 M=1,NS
      SUM=0.0
      DO 381 L=1,NS
      SUM=SUM+UUU(K,L)*VVV(M,L)
  381 CONTINUE
      VCOV(K,M)=SUM
  380 CONTINUE
      WRITE(23,1016)K,YHAT(K),(VCOV(K,L),L=1,NS) 
  379 CONTINUE
C
C  ROTATE COORDINATES
C
      DO 382 I=1,NOBS
      DO 383 K=1,NS
      SUM=0.0
      DO 384 L=1,NS
      SUM=SUM+XMAT(I,L)*VCOV(L,K)
  384 CONTINUE
      IF(JJJJ.EQ.1)XSAVE2(I,K)=SUM
      IF(JJJJ.EQ.2)XSAVE3(I,K)=SUM
  383 CONTINUE
  382 CONTINUE
      DO 385 I=1,NOBS
      DO 386 K=1,NS
      IF(JJJJ.EQ.1)XMAT(I,K)=XSAVE2(I,K)
      IF(JJJJ.EQ.2)XMAT(I,K)=XSAVE3(I,K)
  386 CONTINUE
  385 CONTINUE
C
C  CALCULATE R-SQUARE BETWEEN ESTIMATED LEGISLATOR COORDINATES AND
C    TRUE COORDINATES
C
      DO 275 JJ=1,50
      FV1(JJ)=0.0
      FV2(JJ)=0.0
      DO 276 JK=1,25
      XMATNEW(JJ,JK)=0.0
  276 CONTINUE
  275 CONTINUE
      DO 270 I=1,NOBS
      DO 271 K=1,NS
      FV1(K)=FV1(K)+XDATA(I,K)
      FV2(K)=FV2(K)+XMAT(I,K)
      FV1(K+NS)=FV1(K+NS)+XDATA(I,K)**2
      FV2(K+NS)=FV2(K+NS)+XMAT(I,K)**2
      DO 272 L=1,NS
      XMATNEW(K,L)=XMATNEW(K,L)+XDATA(I,K)*XMAT(I,L)
  272 CONTINUE
  271 CONTINUE
  270 CONTINUE
      DO 273 K=1,NS
      DO 274 L=1,NS
      AA=FLOAT(NOBS)*XMATNEW(K,L)-FV1(K)*FV2(L)
      AB=FLOAT(NOBS)*FV1(K+NS)-FV1(K)*FV1(K)
      AC=FLOAT(NOBS)*FV2(L+NS)-FV2(L)*FV2(L)
      IF(AB*AC.GT.0.0)RSQR1=(AA*AA)/(AB*AC)
      WRITE(*,1090)K,L,RSQR1
      WRITE(23,1090)K,L,RSQR1
  274 CONTINUE
  273 CONTINUE
 2221 CONTINUE
      DO 2220 I=1,NOBS
      WRITE(36,FMT3)I,(KNAME(I,J),J=1,JNE),(XDATA(I,J),J=1,NS),
     C                 (XSAVE2(I,J),J=1,NS),(XSAVE3(I,J),J=1,NS)
 2220 CONTINUE
C
C  *********************
C
C  END OF BOOTSTRAP LOOP
C
 9988 CONTINUE
C
C  ******************** 
C
C
C  WRITE OUT COORDINATES WITH BOOTSTRAP STANDARD ERRORS
C
      DO 6567 I=1,NOBS
      DO 6568 K=1,NS
      DO 6569 L=1,NS
      AA=FLOAT(NTRIAL-1)*COVX(I,K,L)-XMEANX(I,K)*XMEANX(I,L)
      BB=FLOAT(NTRIAL-1)*COVX(I,K,K)-XMEANX(I,K)*XMEANX(I,K)
      CC=FLOAT(NTRIAL-1)*COVX(I,L,L)-XMEANX(I,L)*XMEANX(I,L)
      AAA1=FLOAT(NTRIAL-1)*COVX(I+NOBS,K,L)-
     C                     XMEANX(I+NOBS,K)*XMEANX(I+NOBS,L)
      BBB1=FLOAT(NTRIAL-1)*COVX(I+NOBS,K,K)-
     C                     XMEANX(I+NOBS,K)*XMEANX(I+NOBS,K)
      CCC1=FLOAT(NTRIAL-1)*COVX(I+NOBS,L,L)-
     C                     XMEANX(I+NOBS,L)*XMEANX(I+NOBS,L)
C      WRITE(99,6549)I,AA,BB,CC,AAA1,BBB1,CCC1
 6549 FORMAT(I6,16F10.4)
      COVX2(I,K,L)=AA/SQRT(BB*CC)
      COVX2(I+NOBS,K,L)=AAA1/SQRT(BBB1*CCC1)
 6569 CONTINUE
 6568 CONTINUE
 6567 CONTINUE
C
      DO 656 K=1,NS
      DO 656 I=1,NOBS
      STDDEV(I,K)=SQRT(STDDEV(I,K)/FLOAT(NTRIAL-2))
      XMEANX(I,K)=XMEANX(I,K)/FLOAT(NTRIAL-1)
      STDDEV(I+NOBS,K)=SQRT(STDDEV(I+NOBS,K)/FLOAT(NTRIAL-2))
      XMEANX(I+NOBS,K)=XMEANX(I+NOBS,K)/FLOAT(NTRIAL-1)
  656 CONTINUE
      DO 657 I=1,NOBS
      WRITE(26,FMT3)I,(KNAME(I,J),J=1,JNE),
     C                (TRUEX(I,K),K=1,NS),
     C                (XMEANX(I,K),K=1,NS),
     C                (STDDEV(I,K),K=1,NS),
     C                ((COVX2(I,K,L),L=1,NS),K=1,NS)
  657 CONTINUE
      DO 6570 I=1,NOBS
      DO 6571 K=1,NS
      FV1(K)=SQRT((STDDEV(I+2*NOBS,K)-FLOAT(NTRIAL-1)*
     C             XMEANX(I+NOBS,K)**2)/FLOAT(NTRIAL-1))
 6571 CONTINUE
      WRITE(56,FMT3)I,(KNAME(I,J),J=1,JNE),
     C                (TRUEX2(I,K),K=1,NS),
     C                (XMEANX(I+NOBS,K),K=1,NS),
     C                (STDDEV(I+NOBS,K),K=1,NS),
     C                (FV1(K),K=1,NS),
     C                ((COVX2(I+NOBS,K,L),L=1,NS),K=1,NS)
 6570 CONTINUE
  658 FORMAT(I4,1X,36A1,80F10.4)
C
C
C
      CALL GETTIM(JTIM1,JTIM2,JTIM3,JTIM4)
      WRITE(JIO,1000)ITIM1,ITIM2,ITIM3,ITIM4
      WRITE(JIO,1111)JTIM1,JTIM2,JTIM3,JTIM4
      WRITE(*,1000)ITIM1,ITIM2,ITIM3,ITIM4
      WRITE(*,1111)JTIM1,JTIM2,JTIM3,JTIM4
      STOP
      END
C
C *********************************************************************
C   SUBROUTINE ROTATE -- IMPLEMENTS SCHONEMANN'S ORTHOGONAL PROCRUSTES
C                             ROTATION SOLUTION
C
C                          XMAT(,) IS ROTATED TO BEST MATCH XTRUE(,)
C
C *********************************************************************
C
      SUBROUTINE ROTATE(NOBS,NS,XMAT,XTRUE)
      DIMENSION XMAT(1799,1799),XTRUE(1799,1799),Y16MIDP(461,461),
     C          YHAT(461),UUU(461,461),VVV(25,25),VCOV(1799,1799),
     C          XSAVE(1799,25),FV1(15599),FV2(15599),XMATNEW(15599,25)
 1015 FORMAT(' SINGULAR VALUE DECOMPOSITION',I5)
 1016 FORMAT(I5,99F7.3)
 1017 FORMAT(' ORTHOGONAL PROCRUSTES ROTATION MATRIX')
 1090 FORMAT(' R-SQUARES TRUE VS. REPRODUCED',2I4,2F7.3)
C
C  ROTATE ESTIMATED COORDINATES TO BEST FIT TRUE COORDINATES USING
C    SCHONEMANN'S ORTHOGONAL PROCRUSTES SOLUTION
C
      DO 376 L=1,NS
      DO 377 K=1,NS
      SUM=0.0
      DO 378 I=1,NOBS
      SUM=SUM+XMAT(I,K)*XTRUE(I,L)
  378 CONTINUE
      Y16MIDP(K,L)=SUM
  377 CONTINUE
  376 CONTINUE
C
C    CALL SINGULAR VALUE DECOMPOSITION ROUTINE
C
      XTOL=.001
      CALL LSVRR(NS,NS,Y16MIDP,461,21,XTOL,IRANK,YHAT,UUU,
     C           461,VVV,25)
C
C      WRITE(*,1015)IRANK
      WRITE(23,1015)IRANK
C
C  COMPUTE ROTATION MATRIX
C
C      WRITE(*,1017)
      WRITE(23,1017)
      DO 379 K=1,NS
      DO 380 M=1,NS
      SUM=0.0
      DO 381 L=1,NS
      SUM=SUM+UUU(K,L)*VVV(M,L)
  381 CONTINUE
      VCOV(K,M)=SUM
  380 CONTINUE
C      WRITE(*,1016)K,YHAT(K),(VCOV(K,L),L=1,NS) 
      WRITE(23,1016)K,YHAT(K),(VCOV(K,L),L=1,NS) 
  379 CONTINUE
C
C  ROTATE OBSERVED COORDINATES
C
      DO 382 I=1,NOBS
      DO 383 K=1,NS
      SUM=0.0
      DO 384 L=1,NS
      SUM=SUM+XMAT(I,L)*VCOV(L,K)
  384 CONTINUE
      XSAVE(I,K)=SUM
  383 CONTINUE
  382 CONTINUE
      DO 385 I=1,NOBS
      DO 386 K=1,NS
      XMAT(I,K)=XSAVE(I,K)
  386 CONTINUE
C      WRITE(*,1016)I,(XMAT(I,K),K=1,NS),(XTRUE(I,K),K=1,NS)
C      WRITE(23,1016)I,(XMAT(I,K),K=1,NS),(XTRUE(I,K),K=1,NS)
  385 CONTINUE
C
C  CALCULATE R-SQUARES FOR ROTATED MATRICES
C
      DO 275 JJ=1,50
      FV1(JJ)=0.0
      FV2(JJ)=0.0
      DO 276 JK=1,25
      XMATNEW(JJ,JK)=0.0
  276 CONTINUE
  275 CONTINUE
      DO 270 I=1,NOBS
      DO 271 K=1,NS
      FV1(K)=FV1(K)+XTRUE(I,K)
      FV2(K)=FV2(K)+XMAT(I,K)
      FV1(K+NS)=FV1(K+NS)+XTRUE(I,K)**2
      FV2(K+NS)=FV2(K+NS)+XMAT(I,K)**2
      DO 272 L=1,NS
      XMATNEW(K,L)=XMATNEW(K,L)+XTRUE(I,K)*XMAT(I,L)
  272 CONTINUE
  271 CONTINUE
  270 CONTINUE
      DO 273 K=1,NS
      DO 274 L=1,NS
      AA=FLOAT(NOBS)*XMATNEW(K,L)-FV1(K)*FV2(L)
      AB=FLOAT(NOBS)*FV1(K+NS)-FV1(K)*FV1(K)
      AC=FLOAT(NOBS)*FV2(L+NS)-FV2(L)*FV2(L)
      IF(AB*AC.GT.0.0)RSQR1=(AA*AA)/(AB*AC)
      WRITE(*,1090)K,L,RSQR1
C      WRITE(24,1090)K,L,RSQR1
  274 CONTINUE
  273 CONTINUE
      RETURN
      END
C
C **************************************************************************
C
C  SUBROUTINE SVDSVD -- PERFORMS SINGULAR VALUE DECOMPOSITION
C                       
C                       
C
C **************************************************************************
C
      SUBROUTINE SVDSVD(NROW,NCOL,Y16MIDP,YHAT,UUU,VVV,IRANK)
      DIMENSION Y16MIDP(50,50),UUU(50,50),VVV(50,50),YHAT(50),
     C          XCOV(50,50),WVEC(50),ZMAT(50,50),FV1(50),FV2(50)
      COMMON /AREA1/ JR,LR 
      COMMON /XXCOM/ ZMID(15599,25),XDATA(1799,25),DYN(15599,25),
     CLDATA(1799,15599),PSI(1799,15599,2)
C
  101 FORMAT(' PERFORMANCE INDEX EIGENVALUE/VECTOR ROUTINE='
     C       ,3I5,I6)
  102 FORMAT(' ACCURACY OF SVD',2F10.4)
  103 FORMAT(10F7.3)
C   
      DO 3 I=1,NROW
      DO 2 L=1,NROW
      SUM=0.0
      DO 1 J=1,NCOL
      SUM=SUM+Y16MIDP(I,J)*Y16MIDP(L,J)
  1   CONTINUE
      XCOV(I,L)=SUM
  2   CONTINUE
  3   CONTINUE
C
C  GET U MATRIX
C
      CALL RS(50,NROW,XCOV,WVEC,1,ZMAT,FV1,FV2,IER)
      WRITE(23,101)IER
      DO 4 I=1,NROW
      DO 5 J=1,NROW
      UUU(I,J)=ZMAT(I,NROW+1-J)
  5   CONTINUE
  4   CONTINUE
C
      DO 6 I=1,NCOL
      DO 7 L=1,NCOL
      SUM=0.0
      DO 8 J=1,NROW
      SUM=SUM+Y16MIDP(J,I)*Y16MIDP(J,L)
  8   CONTINUE
      XCOV(I,L)=SUM
  7   CONTINUE
  6   CONTINUE
C
C  GET V MATRIX
C
      CALL RS(50,NCOL,XCOV,WVEC,1,ZMAT,FV1,FV2,IER)
      WRITE(23,101)IER
      IRANK=0
      DO 9 I=1,NCOL
      YHAT(I)=SQRT(ABS(WVEC(NCOL+1-I)))
      IF(YHAT(I).GE..001)IRANK=IRANK+1
      DO 10 J=1,NCOL
      VVV(I,J)=ZMAT(I,NCOL+1-J)
  10  CONTINUE
  9   CONTINUE
C
C  FORM U'XV TO GET SIGNS
C
      DO 16 L=1,NCOL
      DO 18 J=1,NCOL
      SUM=0.0
      DO 17 I=1,NROW
      SUM=SUM+UUU(I,J)*Y16MIDP(I,L)
  17  CONTINUE
      ZMAT(J,L)=SUM
  18  CONTINUE
  16  CONTINUE
      DO 19 K=1,NCOL
      DO 20 J=1,NCOL
      SUM=0.0
      DO 21 L=1,NCOL
      SUM=SUM+ZMAT(J,L)*VVV(L,K)
  21  CONTINUE
      XCOV(J,K)=SUM
  20  CONTINUE
  19  CONTINUE
      DO 22 I=1,NCOL
      WVEC(I)=1.0
      IF(XCOV(I,I).LT.0.0)WVEC(I)=-1.0
      WRITE(23,103)(XCOV(I,J),J=1,NCOL)
  22  CONTINUE
C
C  DO SIGN CHANGE
C
      DO 23 I=1,NROW
      DO 24 J=1,NCOL
      UUU(I,J)=WVEC(J)*UUU(I,J)
  24  CONTINUE
  23  CONTINUE
C
C  CHECK ACCURACY OF DECOMPOSITION
C
      ESUM=0.0
      DO 11 L=1,NCOL
      FSUM=0.0
      GSUM=0.0
      DO 13 I=1,NROW
      SUM=0.0
      DO 12 J=1,NCOL
      SUM=SUM+UUU(I,J)*YHAT(J)*VVV(L,J)
  12  CONTINUE
      ESUM=ESUM+(Y16MIDP(I,L)-SUM)**2
      XCOV(I,L)=SUM
  13  CONTINUE
  11  CONTINUE
C      DO 15 I=1,NROW
C      WRITE(23,103)(Y16MIDP(I,J),J=1,NCOL),(XCOV(I,J),J=1,NCOL),
C     C             (UUU(I,J),J=1,NCOL),(VVV(I,J),J=1,NCOL),YHAT(I)
C  15  CONTINUE
C
      WRITE(23,102)ESUM,ESUM/FLOAT(NROW*NCOL)
      WRITE(*,102)ESUM,ESUM/FLOAT(NROW*NCOL)
      RETURN
      END
C
C **************************************************************************
C
C  SUBROUTINE ASCORE -- PERFORMS EIGENVALUE-EIGENVECTOR DECOMPOSITION OF
C                       THE MATRIX OF LEGISLATOR BY LEGISLATOR AGREEMENT
C                       SCORES
C
C **************************************************************************
C
      SUBROUTINE ASCORE(NOBS,NRCALL,NS,KIO,ZMAT,WVEC,
     C                  ZMAT2,WVEC2,DSTAR)
      DIMENSION XCOL(15599),XROW(1799),KROW(1799),XCENTER(1799,15599),
     C          XCOV(1799,1799),ZMAT(1799,1799),FV1(1799),FV2(1799),
     C          WVEC(1799),XAGREE(1799,1799),ROWMEAN(1799),
     C          YCENTER(1799,1799),WVEC2(1799),ZMAT2(1799,1799),
     C          DSTAR(1799,1799)
      COMMON /AREA1/ JR,LR 
      COMMON /XXCOM/ ZMID(15599,25),XDATA(1799,25),DYN(15599,25),
     CLDATA(1799,15599),PSI(1799,15599,2)
C
  100 FORMAT(' SINGULAR VALUE DECOMPOSITION: RANK',3I6)
  101 FORMAT(' PERFORMANCE INDEX EIGENVALUE/VECTOR ROUTINE='
     C       ,3I5,I6)
  102 FORMAT(I4,9F10.4)
  103 FORMAT(I4,F10.4)
 1000 FORMAT(3F10.4)
 1011 FORMAT(' BIG ERROR',3I5)
      DO 3 I=1,15599
      XCOL(I)=0.0
  3   CONTINUE
      DO 30 I=1,1799
      XROW(I)=0.0
      KROW(I)=0
      WVEC(I)=0.0
      ROWMEAN(I)=0.0
      DO 31 J=1,1799
      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,NOBS
      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,NOBS
      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(NOBS)
      XMAT=XMAT/FLOAT(KMAT)
      WRITE(*,1000)XCHK1,XCHK2,XMAT
      WRITE(KIO,1000)XCHK1,XCHK2,XMAT
C
C  COMPUTE HECKMAN-SNYDER PSEUDO DOUBLE-CENTER
C
      DO 5 I=1,NOBS
      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,NOBS
      RSUM=0.0
      DO 8 J=1,NOBS
      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
         DSTAR(I,J)=1.0
         GO TO 88
      ENDIF
      XCOV(I,J)=SUM/FLOAT(KK)
      XAGREE(I,J)=(1.0 - (FLOAT(KKK)/FLOAT(KK)))**2
      DSTAR(I,J)=(100.0 - (FLOAT(KKK)/FLOAT(KK))*100.0)/50.0
  88  CONTINUE
      RSUM=RSUM+XAGREE(I,J)
  8   CONTINUE
      ROWMEAN(I)=RSUM/FLOAT(NOBS)
      ALLMEAN=ALLMEAN+ROWMEAN(I)
  7   CONTINUE
      ALLMEAN=ALLMEAN/FLOAT(NOBS)
C
C  SETUP DOUBLE-CENTERED AGREEMENT SCORE MATRIX
C
      DO 33 I=1,NOBS
      DO 34 J=1,NOBS
      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(1799,NOBS,XCOV,WVEC,1,ZMAT,FV1,FV2,IER)
      WRITE(KIO,101)NS,NOBS,IER,KZERO
      WRITE(*,101)NS,NOBS,IER,KZERO
C
C
C  EIGENVECTOR-EIGENVALUE DECOMPOSITION DOUBLE-CENTERED AGREEMENT
C     SCORE MATRIX
C
      CALL RS(1799,NOBS,YCENTER,WVEC2,1,ZMAT2,FV1,FV2,IER)
      WRITE(KIO,101)NS,NOBS,IER,KZERO
      WRITE(*,101)NS,NOBS,IER,KZERO
      SUM=0.0
      SUM2=0.0
      DO 20 I=1,NOBS
      SUM=SUM+ABS(WVEC(I))
      SUM2=SUM2+ABS(WVEC2(I))
  20  CONTINUE
      YPER=0.0
      YPER2=0.0
      DO 10 I=1,20
      XPER=(WVEC(NOBS+1-I)/SUM)*100.0
      YPER=YPER+XPER
      XPER2=(WVEC2(NOBS+1-I)/SUM2)*100.0
      YPER2=YPER2+XPER2
      WRITE(KIO,102)I,WVEC2(NOBS+1-I),XPER2,YPER2,
     C                WVEC(NOBS+1-I),XPER,YPER
      WRITE(*  ,102)I,WVEC2(NOBS+1-I),XPER2,YPER2,
     C                WVEC(NOBS+1-I),XPER,YPER
  10  CONTINUE
      RETURN
      END
C
C
C  *************************************************************************
C   SUBROUTINE WHOOPE---IMPLEMENTS THE CONDITIONAL GLOBAL MINIMUM ALGORITHM
C   DEVELOPED BY POOLE, "LEAST SQUARES METRIC, UNIDIMENSIONAL UNFOLDING,"
C   PSYCHOMETRIKA, 1984.
C  *************************************************************************
C
C
      SUBROUTINE WHOOPE(NQ,NS,DSTAR,ZZZ,XX,SSE1,SSE2,KTP)
      DIMENSION DSTAR(1799,1799),ZZZ(1799),SAVEZ(1799),SAVED(1799),
     C          DAT(20),
     C          XX(1799,25),XXXX(1799,25)
  100 FORMAT(I4,3F12.5,I8)
      KTP=1
      NQQ=NQ-1
      CALL STAT(NQ,NS,DSTAR,ZZZ,XX,SSE1,RRSQ,KK)
      DAT(1)=SSE1
      II=0
      AKKK=0.0
      WRITE(23,100)II,SSE1,RRSQ,AKKK,KK
      WRITE(*,100)II,SSE1,RRSQ,AKKK,KK
      IF(SSE1.LE.0.001)SSE2=0.0
      IF(SSE1.LE.0.001)RETURN
      DO 99 II=1,10
      KTP=II
      DO 98 J=1,NQ
      NQJ=J
      KK=0
      DO 918 JJ=1,NQ
      IF(JJ.EQ.NQJ)GO TO 918
      KK=KK+1
      DO 919 K=1,NS
  919 XXXX(KK,K)=XX(JJ,K)
      SAVEZ(KK)=ZZZ(JJ)
      SAVED(KK)=DSTAR(NQJ,JJ)
  918 CONTINUE
      IF(NS.EQ.1)CALL FOCUSW(NQQ,NQJ,SAVED,SAVEZ,ZZZ)
      IF(NS.GT.1)CALL FOCUS(NQQ,NS,NQJ,SAVED,XX,XXXX)
  98  CONTINUE
      CALL STAT(NQ,NS,DSTAR,ZZZ,XX,SSE2,RRSQ,KK)
      DAT(II+1)=SSE2
      IF(SSE2.EQ.0.0)GO TO 9998
      AKKK=(DAT(II)-DAT(II+1))/DAT(II)
      WRITE(23,100)II,SSE2,RRSQ,AKKK,KK
      WRITE(*,100)II,SSE2,RRSQ,AKKK,KK
      IF(AKKK.LE..001)GO TO 9998
  99  CONTINUE
 9998 CONTINUE
      SUM=0.0
      DO 1 I=1,NQ
  1   SUM=SUM+ZZZ(I)
      DO 2 I=1,NQ
  2   ZZZ(I)=ZZZ(I)-(SUM/FLOAT(NQ))
      RETURN
      END
C
C
C  *********************************************************************
C    SUBROUTINE FOCUSW---PERFORMS LEAST SQUARES METRIC SIMILARITIES
C    ANALYSIS USING THE CONDITIONAL GLOBAL MINIMUM ALGORITHM
C  *********************************************************************
C
C
      SUBROUTINE FOCUSW(NQ,II,D,X,Z)
      DIMENSION D(1799),X(1799),Z(1799),LL(1799),Q(1799),XX(1799,2)
      DO 303 I=1,NQ
      LL(I)=I
  303 Q(I)=X(I)
      CALL RSORT(Q,NQ,LL)
      ASUM=0.0
      BSUM=0.0
      WWSUM=0.0
      DO 66 I=1,NQ
      IF(D(LL(I)).EQ.99.0)GO TO 66
      XX(I,1)=Q(I)-D(LL(I))
      XX(I,2)=Q(I)+D(LL(I))
      WWSUM=WWSUM+1.0
      ASUM=ASUM+XX(I,1)
      BSUM=BSUM+XX(I,1)**2
  66  CONTINUE
      AA=WWSUM*BSUM-ASUM*ASUM
      KK=1
      DO 77 I=1,NQ
      IF(D(LL(I)).EQ.99.0)GO TO 77
      ASUM=ASUM-XX(I,1)+XX(I,2)
      BSUM=BSUM-XX(I,1)**2+XX(I,2)**2
      BB=WWSUM*BSUM-ASUM*ASUM
      CC=AMIN1(AA,BB)
      IF(ABS(CC-AA).LE..00001.AND.KK.GT.1)GO TO 88
      IF(ABS(CC-AA).LE..00001.AND.KK.EQ.1)Z(II)=
     C                     (ASUM+XX(I,1)-XX(I,2))/WWSUM
      IF(ABS(CC-BB).LE..00001)Z(II)=ASUM/WWSUM
  88  AA=CC
      KK=KK+1
  77  CONTINUE
      RETURN
      END
C
C
C
C  **********************************************************************
C     SUBROUTINE STAT--COMPUTES THE SUM OF SQUARED ERROR BETWEEN THE
C         THE INPUT DISTANCE MATRIX AND THE CURRENT DISTANCE MATRIX.
C  **********************************************************************
C
C
      SUBROUTINE STAT(NQ,NS,DSTAR,ZZZ,XX,SSE,RRSQ,KK)
      DIMENSION DSTAR(1799,1799),ZZZ(1799),XX(1799,25)
C      WRITE(*,100)NQ,NS
  100 FORMAT(2I5)
  125 FORMAT(I4,10F7.3)
      SSE=0.0
      ASUM=0.0
      BSUM=0.0
      CSUM=0.0
      DSUM=0.0
      ESUM=0.0
      KK=0
      DO 1 I=1,NQ
C      WRITE(24,125)I,(XX(I,K),K=1,NS)
      DO 2 J=1,I
      IF(I.EQ.J)GO TO 2
      IF(DSTAR(I,J).EQ.99.0)GO TO 2
      KK=KK+1
      IF(NS.EQ.1)AA=ABS(ZZZ(I)-ZZZ(J))
      IF(NS.EQ.1)GO TO 10
      SSUMS=0.0
      DO 11 K=1,NS
  11  SSUMS=SSUMS+(XX(I,K)-XX(J,K))**2
      SSUMS=SQRT(SSUMS)
      AA=SSUMS
C      WRITE(24,125)KK,AA,DSTAR(I,J)
  10  CONTINUE
      ASUM=ASUM+AA
      BSUM=BSUM+DSTAR(I,J)
      CSUM=CSUM+AA*AA
      DSUM=DSUM+DSTAR(I,J)**2
      ESUM=ESUM+AA*DSTAR(I,J)
      SSE=SSE+(DSTAR(I,J)-AA)**2
  2   CONTINUE
  1   CONTINUE
      AA=FLOAT(KK)*ESUM-ASUM*BSUM
      BB=FLOAT(KK)*CSUM-ASUM*ASUM
      CC=FLOAT(KK)*DSUM-BSUM*BSUM
      RRSQ=(AA*AA)/(BB*CC)
      RETURN
      END
C
C
C  *********************************************************************
C    SUBROUTINE FOCUS IS A QUASI-GRADIENT ALGORITHM.  IT COMPUTES THE
C    COORDINATES
C  *********************************************************************
C
C
      SUBROUTINE FOCUS(NP,NS,II,D,XX,XXXX)
      DIMENSION D(1799),XX(1799,25),XXXX(1799,25),ZZZ(100)
      DO 2 J=1,NS
      ZZZ(J)=0.0
  2   CONTINUE
      KK=0
      DO 4 J=1,NP
      IF(D(J).EQ.99.0)GO TO 4
      KK=KK+1
      SUM=0.0
      DO 7 K=1,NS
  7   SUM=SUM+(XXXX(J,K)-XX(II,K))**2
      IF(SUM)50,51,50
  51  XC=1.0
      GO TO 52
  50  XC=D(J)/SQRT(SUM)
  52  CONTINUE
      DO 8 K=1,NS
  8   ZZZ(K)=ZZZ(K)+XXXX(J,K)+XC*(XX(II,K)-XXXX(J,K))
  4   CONTINUE
      IF(KK.EQ.0)WRITE(*,310)II
      IF(KK.EQ.0)STOP
  310 FORMAT(' THIS IS YOUR PROBLEM STUPID!!!',I6)
      DO 1 K=1,NS
  1   XX(II,K)=ZZZ(K)/FLOAT(KK)
      RETURN
      END
C
C  **************************************************************************
C    SUBROUTINE MAXLIK---CALLED BY MAIN.  INITIALIZES VARIABLES FOR
C          ESTIMATION OF PARAMETERS
C  **************************************************************************
C
      SUBROUTINE MAXLIK
      DIMENSION LL(2,2),MM(2,2)
      COMMON /MINE/ NS,NDIM,NQ,NRCALL,NSTEP,NEQ,ISENS(1799),
     CJAN,JANLST,JIO,KIO,NOBS,NOPAR,IFDRV,NFEVAL,
     CMAXIT,MAXSQZ
      COMMON /ROLL/ KPJP(15999,4),LERIC(15599)
      COMMON /XIME/ NTIME(1200),NITR,MSEC
      COMMON /DELTA/ B(50),TESTB(50),DELTAB(50),GRAD(50),V(25,25)
      COMMON /SENMIN/ SSS(100),KSMIN,KSMAX
      COMMON /BOOK/ BBB(50),BBBB(25)
      COMMON /XXCOM/ ZMID(15599,25),XDATA(1799,25),DYN(15599,25),
     CLDATA(1799,15599),PSI(1799,15599,2)
      EXTERNAL FUNNEL
  23  FORMAT(' TOTAL VOTES PREDICTED FOR',I6,1X,'ROLL-CALLS'/13X,
     C'ACTUAL'/7X,'  YEA     NAY  ')
  24  FORMAT(' TOTAL VOTES PREDICTED FOR',I5,1X,'LEGISLATORS'/13X,
     C'ACTUAL'/7X,'  YEA     NAY  ')
  25  FORMAT('   YEA  ',I7,2X,I7/'   NAY  ',I7,2X,I7)
 2626 FORMAT(' PERCENT CLASSIFIED=',F7.3,'    AGGREGATE PRE=',F7.3)
C
C  ***** UTILITY FUNCTION PHASE *****
C    ESTIMATION OF BETA ON FIRST DIMENSION ONLY
C
      IF(NSTEP.EQ.0)THEN
           B(1)=BBB(1)
C
C  CALL SUBROUTINE NORMZ TO NORMALIZE COORDINATES AND CHECK FOR SAG
C    IN LEGISLATOR COORDINATES
C
           CALL NORMZ
C
           NFEVAL=0
           CALL BHHH(FUNNEL,F)
           CALL RPRINT(F,B,V)
      ENDIF
C
C  ***** ROLL CALL PHASE *****
C
      IF(NSTEP.EQ.1)THEN
           DO 22 I=1,2
           DO 22 J=1,2
  22       MM(I,J)=0
           NEQ=0
           JKP=0
           KTP=0
  1        CONTINUE
           NEQ=NEQ+1
           NFEVAL=0
           B(1)=DYN(NEQ,NDIM)
           B(2)=ZMID(NEQ,NDIM)
           IF(NDIM.GT.1)THEN
              B(1)=0.0
              B(2)=0.0
           ENDIF
           IF(LERIC(NEQ).NE.0)THEN
              CALL BHHH(FUNNEL,F)
           ENDIF
           CALL RPRINT(F,B,V)
           CALL CROSS(NEQ,LL)
           JJ=1
           DO 21 I=1,2
           DO 21 J=1,2
           KPJP(NEQ,JJ)=LL(I,J)
           JJ=JJ+1
  21       MM(I,J)=MM(I,J)+LL(I,J)
           LERIC(NEQ)=1
C           IF((LL(1,2)+LL(2,1)).EQ.0)LERIC(NEQ)=0
           LYES=LL(1,1)+LL(2,1)
           LNO =LL(1,2)+LL(2,2)
           JKP=JKP+AMIN0(LYES,LNO)
           KTP=KTP+LL(1,2)+LL(2,1)
           IF(NEQ.LT.NRCALL)GO TO 1
C
C  CALCULATE PERCENT CORRECTLY CLASSIFIED AND OVERALL PRE 
C
           XPER=FLOAT(MM(1,1)+MM(2,2))/
     C              FLOAT(MM(1,1)+MM(1,2)+MM(2,1)+MM(2,2))
           XPER=XPER*100.0
           XPRE=FLOAT(JKP-KTP)/FLOAT(JKP)
           WRITE(JIO,2626)XPER,XPRE
           WRITE(*,2626)XPER,XPRE
           WRITE(KIO,23)NRCALL
           WRITE(KIO,25)((MM(I,J),J=1,2),I=1,2)
      ENDIF
C
C  ***** LEGISLATOR PHASE *****
C
      IF(NSTEP.EQ.2)THEN
           DO 26 I=1,2
           DO 26 J=1,2
  26       MM(I,J)=0
           NEQ=0
  10       CONTINUE
           NEQ=NEQ+1
           NFEVAL=0
           B(1)=XDATA(NEQ,NDIM)
           CALL BHHH(FUNNEL,F)
           CALL RPRINT(F,B,V)
           CALL CROSS(NEQ,LL)
           JJ=1
           DO 27 I=1,2
           DO 27 J=1,2
           KPJP(NEQ,JJ)=LL(I,J)
           JJ=JJ+1
  27       MM(I,J)=MM(I,J)+LL(I,J)
           IF(NEQ.LT.NOBS)GO TO 10
           WRITE(KIO,24)NOBS
           WRITE(KIO,25)((MM(I,J),J=1,2),I=1,2)
      ENDIF
C
C  ***** UTILITY FUNCTION PHASE *****
C     ESTIMATION OF WEIGHT FOR DIMENSIONS 2 AND ABOVE
C
      IF(NSTEP.EQ.-1)THEN
           B(1)=BBB(2)
           NFEVAL=0
           CALL BHHH(FUNNEL,F)
           CALL RPRINT(F,B,V)
      ENDIF
      RETURN
      END
C
C  **************************************************************************
C    SUBROUTINE BHHH--CALLED BY MAXLIK.  IMPLEMENTS THE BHHH ALGORITHM FOR
C       MAXIMIZING LOG-LIKELIHOOD
C  **************************************************************************
C
      SUBROUTINE BHHH(FUNNEL,XLNL)
      COMMON /DELTA/ B(50),TESTB(50),DELTAB(50),GRAD(50),V(25,25)
      COMMON /XIME/ NTIME(1200),NITR,MSEC
      COMMON /LIKE/ SVLNL,FNLNL,ICNVG,ITT,NVAL
      COMMON /MINE/ NS,NDIM,NQ,NRCALL,NSTEP,NEQ,ISENS(1799),
     CJAN,JANLST,JIO,KIO,NOBS,NOPAR,IFDRV,NFEVAL,
     CMAXIT,MAXSQZ
      COMMON /TOL/ TOLB
      DIMENSION AV(25,25),KCONST(20),
     CZMAT(25,25),WVEC(25),FV1(25),FV2(25)
      EXTERNAL FUNNEL
  101 FORMAT(' PERFORMANCE INDEX EIGENVECTOR/VALUE ROUTINE=',I4)
C
      ICNVG=0
      DO 50 I=1,NOPAR
      KCONST(I)=1
      DELTAB(I)=0.0
   50 TESTB(I)=B(I)
C
C          BERNDT, HALL, HALL, AND HAUSMAN METHOD
C
      DO 1000 IT=1,MAXIT
      IFDRV=1
C
C
      XLNL=FUNNEL(0.0)
C
      IF(IT.EQ.1)SVLNL=-XLNL
      IFDRV=0
      IF(NOPAR.EQ.1)GO TO 20
      IF(NSTEP.EQ.0) KCONST(1)=1
      IF(NSTEP.EQ.1) KCONST(1)=1
      IF(NSTEP.EQ.1) KCONST(2)=1
      IF(NSTEP.EQ.1) KCONST(3)=0
      MSUM=KCONST(1)+KCONST(2)+KCONST(3)
      IF(MSUM.EQ.0)GO TO 1200
      IF(MSUM.EQ.1)GO TO 21
      IF(MSUM.EQ.2)GO TO 23
C
C         V11 V12 V13
C     V=  V21 V22 V23
C         V31 V32 V33
C
C     AV = INVERSE-V
C
C  CALCULATE MATRIX INVERSE
C
      CALL RS(25,3,V,WVEC,1,ZMAT,FV1,FV2,IER)
      DO 60 I=1,3
      DO 60 KX=1,3
      SUM=0.0
      DO 61 J=1,3
  61  SUM=SUM+ZMAT(KX,J)*(1.0/WVEC(J))*ZMAT(I,J)
  60  AV(I,KX)=SUM
      DET=V(1,1)*V(2,2)*V(3,3)-V(1,1)*V(2,3)*V(3,2)+V(1,2)*V(2,3)*V(3,1)
      DET=DET-V(1,2)*V(2,1)*V(3,3)+V(1,3)*V(2,1)*V(3,2)-V(1,3)*V(2,2)*
     CV(3,1)
      IF(ABS(DET).LE..00000001)ICNVG=9
      IF(ABS(DET).LE..00000001)RETURN
      DELTAB(1)=(AV(1,1)*GRAD(1)+AV(2,1)*GRAD(2)+AV(3,1)*GRAD(3))
      DELTAB(2)=(AV(1,2)*GRAD(1)+AV(2,2)*GRAD(2)+AV(3,2)*GRAD(3))
      DELTAB(3)=(AV(1,3)*GRAD(1)+AV(2,3)*GRAD(2)+AV(3,3)*GRAD(3))
      DO 77 I=1,3
      DO 77 J=1,3
      V(I,J)=AV(J,I)
77    CONTINUE
      GO TO 22
C
C     WHEN ONE OF THE THREE KCONST'S IS 1.
C
21    IF(KCONST(1).EQ.1.AND.KCONST(2).EQ.0.AND.KCONST(3).EQ.0)GO TO 30
      IF(KCONST(1).EQ.0.AND.KCONST(2).EQ.1.AND.KCONST(3).EQ.0)GO TO 31
      IF(KCONST(1).EQ.0.AND.KCONST(2).EQ.0.AND.KCONST(3).EQ.1)GO TO 32
30    IC=1
      JC=2
      KC=3
      GO TO 35
31    IC=2
      JC=1
      KC=3
      GO TO 35
32    IC=3
      JC=1
      KC=2
35    IF(ABS(V(IC,IC)).LE..00000001)ICNVG=9
      IF(ABS(V(IC,IC)).LE..00000001)RETURN
      DELTAB(IC)=GRAD(IC)/V(IC,IC)
      V(IC,IC)=1.0/V(IC,IC)
      DELTAB(JC)=0.0
      DELTAB(KC)=0.0
      GO TO 22
C
C     WHEN TWO OF THE THREE KCONST'S ARE 1'S.
C
23    IF(KCONST(1).EQ.1.AND.KCONST(2).EQ.1.AND.KCONST(3).EQ.0)GO TO 40
      IF(KCONST(1).EQ.1.AND.KCONST(2).EQ.0.AND.KCONST(3).EQ.1)GO TO 41
      IF(KCONST(1).EQ.0.AND.KCONST(2).EQ.1.AND.KCONST(3).EQ.1)GO TO 42
40    IC=1
      JC=2
      KC=3
      GO TO 45
41    IC=1
      JC=3
      KC=2
      GO TO 45
42    IC=2
      JC=3
      KC=1
45    DET=V(IC,IC)*V(JC,JC)-V(IC,JC)*V(JC,IC)
      IF(ABS(DET).LE..00000001)ICNVG=9
      IF(ABS(DET).LE..00000001)RETURN
      DELTAB(IC)=(V(JC,JC)*GRAD(IC)-V(IC,JC)*GRAD(JC))/DET
      DELTAB(JC)=(V(IC,IC)*GRAD(JC)-V(JC,IC)*GRAD(IC))/DET
      DELTAB(KC)=0.0
      S11=V(IC,IC)
      V(IC,IC)=V(JC,JC)/DET
      V(JC,JC)=S11/DET
      V(IC,JC)=-V(IC,JC)/DET
      V(JC,IC)=-V(JC,IC)/DET
      GO TO 22
  20  IF(ABS(V(1,1)).LE..00000001)ICNVG=9
      IF(ABS(V(1,1)).LE..00000001)RETURN
      DELTAB(1)=GRAD(1)/V(1,1)
      V(1,1)=1.0/V(1,1)
      DELTAB(2)=0.0
      DELTAB(3)=0.0
      GO TO 22
  22  CONTINUE
      COSDG=DELTAB(1)*GRAD(1)+DELTAB(2)*GRAD(2)+DELTAB(3)*
     CGRAD(3)
C
C  AFTER 3 ITERATIONS STEPSIZE DEFAULTS TO PREVIOUS STEPSIZE
C
      IF(IT.LE.3)ALAMB=1.0
      IFBETR=1
      CALL STEPR(XLNL,XLNLNW,ALAMB,IFBETR,MAXSQZ,ISQZ,FUNNEL)
C
C          PRINT ITERATION RESULTS
C
      IF(NSTEP.EQ.0)WRITE(KIO,1918)IT,(TESTB(J),J=1,NOPAR),
     CALAMB,COSDG,XLNL,XLNLNW
 1918 FORMAT(I5,12F13.4/5X,12F13.4)
C
C          CHECK FOR CONVERGENCE OF LIKELIHOOD FUNCTION.
C
C
      IF(COSDG.LT.(TOLB**2))GO TO 1200
      IF(IFBETR.EQ.0)GO TO 1500
      DO 710 I=1,NOPAR
  710 B(I)=TESTB(I)
 1000 CONTINUE
      GO TO 1100
C
C          FAILURE TO CONVERGE
C
 1100 ICNVG=1
      ITT=IT
      GO TO 1206
C
C          CONVERGENCE
C
 1200 ICNVG=0
      ITT=IT
 1206 CONTINUE
 1207 DO 705 I=1,NOPAR
  705 B(I)=TESTB(I)
      XLNL=-FUNNEL(0.0)
      FNLNL=XLNL
      ITT=IT
      NVAL=NFEVAL
      RETURN
C
C          FAILURE TO IMPROVE LNL
C
 1500 ICNVG=2
      DO 650 I=1,NOPAR
  650 TESTB(I)=B(I)
      GO TO 1207
      END
C
C  ***************************************************************************
C    SUBROUTINE STEPR---CALLED BY BHHH.  CALCULATES STEPSIZE FOR GRADIENT
C  ***************************************************************************
C
      SUBROUTINE STEPR(F,F0,R,IFOK,MAXSQZ,NSQZ,FUNNEL)
C
C
      EXTERNAL FUNNEL
C
C
C        IF STEPPING FORWARD REDUCES -LNL, DOUBLE THE STEP.
C        IF NOT, HALVE THE STEP.  ONCE STEPPING TAKES PLACE
C        IN ONE DIRECTION, IT CONTINUES IN THAT DIRECTION
C        UNTIL NO FURTHER IMPROVEMENT OCCURS.
C
C
C
C  THIS SECTION INTIALIZES LOG-LIKELIHOOD--IF IT IS BETTER THAN OLD
C    VALUE THE STEP SIZE IS DOUBLED IN CODE SEGMENT BELOW.  IF IT IS
C    WORSE, THE STEP SIZE IN HALVED IN CODE SEGMENT IMMEDIATELY BELOW
C
      IFB = IFOK
      R0 = R
      NSQZ = 0
      IFOK=1
    2 F0 = FUNNEL(R0)
      IF(F0.LT.F.AND.IFB.EQ.1)GO TO 10
  99  R0=R0/2.
      NSQZ = NSQZ +1
      IF(NSQZ .LE. MAXSQZ) GO TO 2
      IFOK=0
      R = R0
      RETURN
   10 IF(NSQZ .GT. 0) GO TO 13
C
C  IF IMPROVEMENT, STEP SIZE IS DOUBLED
C
   14 R1 = R0 * 2.
      F1 = FUNNEL(R1)
      NSQZ = NSQZ +1
      IF(F1 .GT. F0) GO TO 11
      IF(F1.LT.0.0)GO TO 11
      R0 = R1
      F0 = F1
      IF(NSQZ .LT. MAXSQZ) GO TO 14
      R = R1
      F0 = F1
      RETURN
C
   11 F0 = FUNNEL(R0)
   13 R = R0
      RETURN
      END
C
C  **************************************************************************
C    FUNCTION FUNNEL---CALLED BY STEPR AND BY BHHH WHEN INITIALIZING.  IT
C      CALCULATES THE UPDATED PARAMETER VECTOR AS NOTED BELOW AND CALLS
C      SUBROUTINE LOGLIK WHICH CALCULATES THE CORRESPONDING LOG-LIKELIHOOD
C  **************************************************************************
C
      REAL FUNCTION FUNNEL(XLBA)
      COMMON /MINE/ NS,NDIM,NQ,NRCALL,NSTEP,NEQ,ISENS(1799),
     CJAN,JANLST,JIO,KIO,NOBS,NOPAR,IFDRV,NFEVAL,
     CMAXIT,MAXSQZ
      COMMON /DELTA/ B(50),TESTB(50),DELTAB(50),GRAD(50),V(25,25)
C
C          UPDATE TRIAL PARAMETER VECTOR.
C
C        TESTB = B + XLBA * DELTAB
C
C           WHERE DELTAB = QMAT(INVERSE) * G
C           AND XLBA = STEPSIZE
C
      DO 10 I=1,NOPAR
  10  TESTB(I)=B(I)+XLBA*DELTAB(I)
      CALL LOGLIK(TESTB,FLIKE,GRAD,V)
      FUNNEL=FLIKE
C      IF(NSTEP.EQ.-1)WRITE(21,1000)TESTB(1),B(1),XLBA,GRAD(1),FLIKE
 1000 FORMAT(5F10.4)
      RETURN
      END
C
C  ***************************************************************************
C    SUBROUTINE LOGLIK---CALLED BY FUNNEL.  CALCULATES LOG-LIKELIHOOD.  FOR
C       EACH APPROPRIATE OBSERVATION, IT CALLS SUBROUTINE ITHOBS (ITH
C       OBSERVATION) WHICH RETURNS THE LOG-LIKELIHOOD.  THE SUM IS CUMULATED
C       BELOW.
C  ***************************************************************************
C
      SUBROUTINE LOGLIK(B,FLIKE,GRAD,V)
C
C
      DIMENSION B(50),GRAD(50),V(25,25),G(50),XBIGL(15599)
      COMMON /XXCOM/ ZMID(15599,25),XDATA(1799,25),DYN(15599,25),
     CLDATA(1799,15599),PSI(1799,15599,2)
      COMMON /MINE/ NS,NDIM,NQ,NRCALL,NSTEP,NEQ,ISENS(1799),
     CJAN,JANLST,JIO,KIO,NOBS,NOPAR,IFDRV,NFEVAL,
     CMAXIT,MAXSQZ
      COMMON /LUCK/ YBIGL(15999),YYBIGL(15999)
C
C
      IF(NSTEP.EQ.-1)NNBS=NOBS
      IF(NSTEP.EQ.0) NNBS=NOBS
      IF(NSTEP.EQ.1) NNBS=NOBS
      IF(NSTEP.EQ.2) NNBS=NRCALL
      NFEVAL=NFEVAL+1
      FLIKE=0.0
      IF(NSTEP.EQ.2)YYBIGL(NEQ)=0.0
      IF(NSTEP.NE.1)GO TO 3
      DO 2 J=NEQ,NRCALL
  2   YBIGL(J)=0.0
  3   CONTINUE
      IF(IFDRV.EQ.0)GO TO 202
      DO 201 J=1,NOPAR
      GRAD(J)=0.0
  201 CONTINUE
      DO 101 J=1,NOPAR
      DO 101 I=1,NOPAR
  101 V(I,J)=0.0
  202 CONTINUE
C      IF(NSTEP.LE.0)GO TO 301
C
C          LOOP OVER NUMBER OF OBSERVATIONS NNBS AND SUM LOG LIKELIHOOD
C     AND ITS GRADIENT WITH RESPECT TO B.
C
      I=0
  200 I=I+1
      IF(I.GT.NNBS)GO TO 211
      CALL ITHOBS(I,B,XLNL,G,XBIGL)
      IF(NSTEP.EQ.2)YYBIGL(NEQ)=YYBIGL(NEQ)+XLNL
      IF(NSTEP.EQ.1)YBIGL(NEQ)=YBIGL(NEQ)+XLNL
      XLNL=-XLNL
      FLIKE=FLIKE+XLNL
      IF(IFDRV.EQ.0)GO TO 200
      DO 205 J=1,NOPAR
  205 GRAD(J)=GRAD(J)+G(J)
C
C          EVALUATE QMAT, THE APPROXIMATION TO THE HESSIAN, AS THE
C     OUTER PRODUCT OF THE GRADIENT VECTOR ONLY FOR THE BHHH METHOD.
C
      DO 206 L=1,NOPAR
      DO 206 J=1,NOPAR
  206 V(J,L)=V(J,L)+G(J)*G(L)
      GO TO 200
  211 RETURN
      END
C
C  ***************************************************************************
C    SUBROUTINE ITHOBS--CALLED BY LOGLIK.  CALCULATES THE LOG-LIKELIHOOD FOR
C      EACH OBSERVATION (I.E. THE LOG-LIKELIHOOD FOR ONE COLUMN/ROW IN THE
C      INPUT CHOICE MATRIX.
C  ***************************************************************************
C
      SUBROUTINE ITHOBS(JT,B,XL,G,XBIGL)
      DIMENSION DSQ(4,15599),XB(4,15599),
     CEXB(4,15599),DLDX(4),B(50),G(50),
     CPHI(15599),XBIGL(15599)
      COMMON /MINE/ NS,NDIM,NQ,NRCALL,NSTEP,NEQ,ISENS(1799),
     CJAN,JANLST,JIO,KIO,NOBS,NOPAR,IFDRV,NFEVAL,
     CMAXIT,MAXSQZ
      COMMON /XXCOM/ ZMID(15599,25),XDATA(1799,25),DYN(15599,25),
     CLDATA(1799,15599),PSI(1799,15599,2)
      COMMON /BOOK/ BBB(50),BBBB(25)
C
C   SUBROUTINE TO ESTIMATE MULTINOMIAL LOGIT FOR SPATIAL MODELS
C
C   NP=NUMBER OF INDIVIDUALS=NOBS
C   NS=NUMBER OF DIMENSIONS
C   NQ=NUMBER OF STIMULI
C
C
C   B (PARAMETER VECTOR IN MAXLIK) SHOULD HAVE THE FOLLOWING
C   FORMAT:
C
C    IF NSTEP EQUALS -1
C     B(1) IS THE KTH (K=2,...,S) DIMENSIONAL WEIGHT
C
C
C    IF NSTEP EQUALS  0
C     B(1) IS THE SIGNAL TO NOISE RATIO, BETA
C
C
C    IF NSTEP EQUALS  1
C     B(1) IS THE DISTANCE/2 BETWEEN THE TWO OUTCOMES
C     B(2) IS THE MIDPOINT OF THE OUTCOMES
C
C    IF NSTEP EQUALS  2
C     B(1) IS THE ITH LEGISLATOR'S COORDINATE
C
C
C    LDATA(JT, ... )IS THE CHOICE VARIABLE
C        (E.G. YES=1, NO=2)
C    XDATA(JT) ARE THE INDIVIDUAL COORDINATES
C
C
C
      IF(NSTEP.EQ.-1)THEN
         KRCALL=1
         LRCALL=NRCALL
         BETA=BBB(1)
         WEIGHT=B(1)
      ENDIF
      IF(NSTEP.EQ.0)THEN
         KRCALL=1
         LRCALL=NRCALL
         BETA=B(1)
         WEIGHT=BBB(2)
      ENDIF
      IF(NSTEP.GT.0)THEN
         BETA=BBB(1)
         WEIGHT=BBB(2)
      ENDIF
  11  CONTINUE
      DO 27 JJ=1,5
  27  G(JJ)=0.0
      XL=0.0
C
C  ***** LEGISLATOR PHASE *****
C    COMPUTE DERIVATIVE FOR LEGISLATORS
C
C
      IF(NSTEP.EQ.2)THEN
         WTSQ=WEIGHT**2
         ICH=LDATA(NEQ,JT)
         IF(ICH.LE.0)RETURN
         D2Y=(ABS(B(1)-ZMID(JT,NDIM)+DYN(JT,NDIM)))**2
         D2N=(ABS(B(1)-ZMID(JT,NDIM)-DYN(JT,NDIM)))**2
         XBY=-D2Y*WTSQ/2.0
         XBY=BETA*EXP(XBY)*PSI(NEQ,JT,1)
         EXBY=EXP(XBY)
         XBN=-D2N*WTSQ/2.0
         XBN=BETA*EXP(XBN)*PSI(NEQ,JT,2)
         EXBN=EXP(XBN)
         PHIXI=EXBY+EXBN
         AA=ALOG(PHIXI)
         XL=-AA
         IF(ICH.EQ.1)XL=XL+XBY
         IF(ICH.EQ.2)XL=XL+XBN
         DLDX(1)=B(1)-ZMID(JT,NDIM)+DYN(JT,NDIM)
         DLDX(2)=B(1)-ZMID(JT,NDIM)-DYN(JT,NDIM)
         DLDX(1)=DLDX(1)*WTSQ
         DLDX(2)=DLDX(2)*WTSQ
         IF(ICH.EQ.1)G(1)=-DLDX(1)*XBY
         IF(ICH.EQ.2)G(1)=-DLDX(2)*XBN
         G(1)=G(1)+(DLDX(1)*XBY*EXBY+DLDX(2)*XBN*EXBN)/PHIXI
C
C  IF LEGISLATOR IS CONSTRAINED DUE TO SAG PROBLEM, SET DERIVATIVE TO ZERO
C
         G(1)=G(1)*ISENS(NEQ)
      ENDIF
C
C  ***** ROLL CALL PHASE *****
C  ROLL CALL DERIVATIVES
C
C
      IF(NSTEP.EQ.1)THEN
         XBIGL(NEQ)=0.0
         ICH=LDATA(JT,NEQ)
         IF(ICH.LE.0)RETURN
         DSQ(1,NEQ)=(WEIGHT*(XDATA(JT,NDIM)-B(2)+B(1)))**2
         DSQ(2,NEQ)=(WEIGHT*(XDATA(JT,NDIM)-B(2)-B(1)))**2
C
C   COMPUTE PHI
C
         PHI(NEQ)=0.0
         DO 6 I=1,NQ
         XB(I,NEQ)=-DSQ(I,NEQ)/(2.0)
         IF(XB(I,NEQ).LT.-10.0)GO TO 10
         XB(I,NEQ)=BETA*EXP(XB(I,NEQ))*PSI(JT,NEQ,I)
  10     IF(XB(I,NEQ).LT.-10.0)XB(I,NEQ)=0.0
         EXB(I,NEQ)=EXP(XB(I,NEQ))
  6      PHI(NEQ)=PHI(NEQ)+EXB(I,NEQ)
C
C   COMPUTE LIKELIHOOD
C
         CC=ALOG(PHI(NEQ))
         XL=-CC
         XBIGL(NEQ)=-CC
         IF(ICH.GT.0)XL=XB(ICH,NEQ)+XL
         IF(ICH.GT.0)XBIGL(NEQ)=XBIGL(NEQ)+XB(ICH,NEQ)
C
C    COMPUTE DERIVATIVES FOR ROLL CALL OUTCOMES
C
         WTSQ=WEIGHT**2
         DLDX(1)=XDATA(JT,NDIM)-B(2)+B(1)
         DLDX(2)=XDATA(JT,NDIM)-B(2)-B(1)
         IF(ICH.EQ.1)G(1)=-WTSQ*DLDX(1)*XB(1,NEQ)
         IF(ICH.EQ.2)G(1)= WTSQ*DLDX(2)*XB(2,NEQ)
C         G(1)=WTSQ*(DLDX(2)*XB(2,NEQ)-DLDX(1)*XB(1,NEQ))
         G(1)=G(1)-WTSQ*(DLDX(2)*XB(2,NEQ)*EXB(2,NEQ) -
     C                   DLDX(1)*XB(1,NEQ)*EXB(1,NEQ))/PHI(NEQ)
         G(2)=WTSQ*DLDX(ICH)*XB(ICH,NEQ)
         G(2)=G(2)-WTSQ*(DLDX(1)*XB(1,NEQ)*EXB(1,NEQ)+
     C                   DLDX(2)*XB(2,NEQ)*EXB(2,NEQ))/PHI(NEQ)
      ENDIF
C
C  ***** UTILITY FUNCTION PHASE *****
C  DERIVATIVES FOR BETA
C
C
      IF(NSTEP.EQ.0)THEN
         DO 26 II=KRCALL,LRCALL
         XBIGL(II)=0.0
         ICH=LDATA(JT,II)
         IF(ICH.LE.0)GO TO 26
         DSQ(1,II)=(WEIGHT*(XDATA(JT,NDIM)-ZMID(II,NDIM)+
     C             DYN(II,NDIM)))**2
         DSQ(2,II)=(WEIGHT*(XDATA(JT,NDIM)-ZMID(II,NDIM)-
     C             DYN(II,NDIM)))**2
C
C   COMPUTE PHI
C
         PHI(II)=0.0
         DO 66 I=1,NQ
         XB(I,II)=-DSQ(I,II)/(2.0)
         IF(XB(I,II).LT.-10.0)GO TO 67
         XB(I,II)=BETA*EXP(XB(I,II))*PSI(JT,II,I)
  67     IF(XB(I,II).LT.-10.0)XB(I,II)=0.0
         EXB(I,II)=EXP(XB(I,II))
  66     PHI(II)=PHI(II)+EXB(I,II)
C
C   COMPUTE LIKELIHOOD
C
         CC=ALOG(PHI(II))
         XL=XL-CC
         XBIGL(II)=-CC
         IF(ICH.GT.0)XL=XB(ICH,II)+XL
         IF(ICH.GT.0)XBIGL(II)=XBIGL(II)+XB(ICH,II)
  26     CONTINUE
C
C   COMPUTE FIRST PARTIALS OF BETA
C
         DO 77 II=KRCALL,LRCALL
         ICH=LDATA(JT,II)
         IF(ICH.LE.0) GO TO 77
         DO 7 K=1,NQ
         T=-EXB(K,II)/PHI(II)
         IF(K.EQ.ICH)T=T+1.0
         G(1)=G(1)+T*(1.0/BETA)*XB(K,II)
  7      CONTINUE
  77     CONTINUE
      ENDIF
C
C
C ***UTILITY FUNCTION PHASE
C  DERIVATIVES FOR WEIGHT
C
C
      IF(NSTEP.EQ.-1)THEN
         DO 25 II=KRCALL,LRCALL
         XBIGL(II)=0.0
         ICH=LDATA(JT,II)
         IF(ICH.LE.0)GO TO 25
         DSQ(1,II)=(WEIGHT*(XDATA(JT,NDIM)-ZMID(II,NDIM)+
     C             DYN(II,NDIM)))**2
         DSQ(2,II)=(WEIGHT*(XDATA(JT,NDIM)-ZMID(II,NDIM)-
     C             DYN(II,NDIM)))**2
C
C   COMPUTE PHI
C
         PHI(II)=0.0
         DO 68 I=1,NQ
         XB(I,II)=-DSQ(I,II)/(2.0)
         IF(XB(I,II).LT.-10.0)GO TO 69
         XB(I,II)=BETA*EXP(XB(I,II))*PSI(JT,II,I)
  69     IF(XB(I,II).LT.-10.0)XB(I,II)=0.0
         EXB(I,II)=EXP(XB(I,II))
  68     PHI(II)=PHI(II)+EXB(I,II)
C
C   COMPUTE LIKELIHOOD
C
         CC=ALOG(PHI(II))
         XL=XL-CC
         XBIGL(II)=-CC
         IF(ICH.GT.0)XL=XB(ICH,II)+XL
         IF(ICH.GT.0)XBIGL(II)=XBIGL(II)+XB(ICH,II)
  25     CONTINUE
C
C   COMPUTE FIRST PARTIALS OF WEIGHT (STH DIMENSION)
C
         DO 78 II=KRCALL,LRCALL
         ICH=LDATA(JT,II)
         IF(ICH.LE.0) GO TO 78
         DO 8 K=1,NQ
         T=-EXB(K,II)/PHI(II)
         IF(K.EQ.ICH)T=T+1.0
         G(1)=G(1)-(1.0/WEIGHT)*T*XB(K,II)*DSQ(K,II)
  8      CONTINUE
  78     CONTINUE
      ENDIF
      RETURN
      END
C
C  **************************************************************************
C    SUBROUTINE RPRINT---CALLED BY MAXLIK.  STORES NEW PARAMETER ESTIMATES
C       AND (OPTIONALLY) WRITES PARAMETER ESTIMATES TO DISK.  IN ROLL CALL
C       PHASE, IF CONVERGED ESTIMATES ARE "UNREALISTIC", GRID2
C       SUBROUTINE IS CALLED TO PRODUCED "APPROPRIATE" CONSTRAINED
C       ESTIMATES
C  **************************************************************************
C
      SUBROUTINE RPRINT(F,B,V)
C
C
      DIMENSION SSSE(25),TTTE(25),B(50),V(25,25),ALP(2),BTA(2),RR(2),
     CXSP(50),XNEW(50)
      CHARACTER*1 KNAME
      COMMON /XXCOM/ ZMID(15599,25),XDATA(1799,25),DYN(15599,25),
     CLDATA(1799,15599),PSI(1799,15599,2)
      COMMON /SENMIN/ SSS(100),KSMIN,KSMAX
      COMMON /BOOK/ BBB(50),BBBB(25)
      COMMON /MINE/ NS,NDIM,NQ,NRCALL,NSTEP,NEQ,ISENS(1799),
     CJAN,JANLST,JIO,KIO,NOBS,NOPAR,IFDRV,NFEVAL,
     CMAXIT,MAXSQZ
      COMMON /SAVE/ XSAVE(1799,2,2),ZSAVE(15599,2,2),CSAVE(15599,2)
      COMMON /LIKE/ SVLNL,FNLNL,ICNVG,ITT,NVAL
      COMMON /TCHOIC/ KPTSUM
      COMMON /XIME/ NTIME(1200),NITR,MSEC
      COMMON /STD/ STDDVX(1799,25),STDDVZ(15599,2,25)
      COMMON /VOTES/ KAV(15599),KAY(15599),KAN(15599),KNAME(1799,99),JNE
C
 1001 FORMAT(I5,2F13.4,3I4,4F9.4/34X,5F9.4/25X,6F9.4)
 1002 FORMAT(1X,3I4,2I7,F14.4,4F9.4)
 1003 FORMAT(1X,I4,1X,19A1,1X,2F13.4,3I4,4F9.4)
 1010 FORMAT(1X,I4,2F13.4,3I4,4F9.4/30X,F13.4,4F9.4)
 1011 FORMAT(I5,2F13.4,3I4,4F9.4/34X,5F9.4)
 1012 FORMAT(I5,5X,7F10.4)
 1013 FORMAT(5X,I5,7F10.4)
 1014 FORMAT(10X,7F10.4)
      DO 10 I=1,NOPAR
      SE=SQRT(ABS(V(I,I)))
      T=0.0
      IF(SE.GT.0) T=B(I)/SE
      SSSE(I)=SE
      TTTE(I)=T
   10 CONTINUE
C
C  ***** UTILITY FUNCTION PHASE *****
C    WEIGHT FOR DIMENSIONS 2 AND ABOVE
C
      IF(NSTEP.EQ.-1)THEN
           WRITE(KIO,1011)NEQ,SVLNL,FNLNL,ITT,
     C        NVAL,ICNVG,BBB(2),B(1),SSSE(1),TTTE(1)
           CALL CPUTIM(KTIM1)
           IITIME=KTIM1
           NTIME(NITR)=KTIM1
           JITIME=IITIME
           IF(NITR.GT.1)JITIME=NTIME(NITR)-NTIME(NITR-1)
C
C     KPTSUM=TOTAL # OF CHOICES.
C
           AA=F/FLOAT(KPTSUM)
C
C     AA=EXP(AA) IS GEOMETRIC MEAN PROBABILITY OF UTILITY FUNCTION.
C
           AA=EXP(AA)
           BBB(2)=B(1)
           BBBB(NDIM)=B(1)
           CALL CORR(ALP,BTA,RR,NSTEP)
           WRITE(JIO,1002)NDIM,NITR,NSTEP,IITIME,JITIME,F,AA,
     C       RR(1),BBB(1),BBB(2)
           WRITE(*,1002)NDIM,NITR,NSTEP,IITIME,JITIME,F,AA,
     C       RR(1),BBB(1),BBB(2)
      ENDIF
C
C  ***** UTILITY FUNCTION PHASE *****
C     BETA FOR FIRST DIMENSION
C
      IF(NSTEP.EQ.0)THEN
           WRITE(KIO,1011)NEQ,SVLNL,FNLNL,ITT,
     C     NVAL,ICNVG,BBB(1),B(1),SSSE(1),TTTE(1)
C           WRITE(*,1011)NEQ,SVLNL,FNLNL,ITT,
C     C     NVAL,ICNVG,BBB(1),B(1),SSSE(1),TTTE(1)
           CALL CPUTIM(KTIM1)
           IITIME=KTIM1
           NTIME(NITR)=KTIM1
           JITIME=IITIME
           IF(NITR.GT.1)JITIME=NTIME(NITR)-NTIME(NITR-1)
C
C     KPTSUM=TOTAL # OF CHOICES.
C
           AA=F/FLOAT(KPTSUM)
C
C     AA=EXP(AA) IS GEOMETRIC MEAN PROBABILITY OF UTILITY FUNCTION.
C
           AA=EXP(AA)
           BBB(1)=B(1)
           CALL CORR(ALP,BTA,RR,NSTEP)
           WRITE(JIO,1002)NDIM,NITR,NSTEP,IITIME,JITIME,F,AA,
     C       RR(1),BBB(1),BBB(2)
           WRITE(*,1002)NDIM,NITR,NSTEP,IITIME,JITIME,F,AA,
     C       RR(1),BBB(1),BBB(2)
      ENDIF
C
C  ***** ROLL CALL PHASE *****
C
      IF(NSTEP.EQ.1)THEN
           DYN(NEQ,NDIM)=B(1)
           ZMID(NEQ,NDIM)=B(2)
           IF(NDIM.EQ.1)THEN
C
C     IF THE MIDPOINT < FURTHEST LEFT LEGISLATOR, CALL GRID ROUTINE TO
C        CALCULATE CONSTRAINED ESTIMATES OF MIDPOINT AND YES OUTCOME
C        FOR ROLL CALL
C
C           IF(B(2).LT.SSS(1))CALL GRID2(NOBS,NEQ,34,B,3,NDIM)
C
C     IF THE MIDPOINT > FURTHEST RIGHT LEGISLATOR, CALL GRID ROUTINE TO
C        CALCULATE CONSTRAINED ESTIMATES OF MIDPOINT AND YES OUTCOME
C        FOR ROLL CALL
C
C           IF(B(2).GT.SSS(2))CALL GRID2(NOBS,NEQ,34,B,2,NDIM)
C
C  DO BOTH OF THE ABOVE AS IN THE SUPERCOMPUTER VERSION -- CONSTRAIN
C   AT THE ENDPOINT WITH THE BEST LOG-LIKELIHOOD
C
           IF(B(2).LT.SSS(1).OR.B(2).GT.SSS(2))THEN
              CALL GRID2(NOBS,NEQ,34,B,2,NDIM)
              SAVEB1=B(1)
              SAVEB2=B(2)
              SAVEFNL=FNLNL
              CALL GRID2(NOBS,NEQ,34,B,3,NDIM)
              IF(FNLNL.LT.SAVEFNL)THEN
                 B(1)=SAVEB1
                 B(2)=SAVEB2
                 FNLNL=SAVEFNL
C
C  RESET YBIGL(...)
C
                 CALL GRID2(NOBS,NEQ,34,B,2,NDIM)
              ENDIF
           ENDIF
C
C     IF THE YES/NO OUTCOME IS < FURTHEST LEFT LEGISLATOR AND YES/NO
C         OUTCOME IS > FURTHEST RIGHT LEGISLATOR THEN CALL GRID ROUTINE
C         TO CONSTRAIN THE YES/NO OUTCOMES BUT RETAIN MIDPOINT
C                  IF DYN(.) > 0
C
           IF((B(2)-B(1)).LT.SSS(1).AND.(B(2)+B(1)).GT.SSS(2))
     C                         CALL GRID2(NOBS,NEQ,34,B,1,NDIM)
C
C                  IF DYN(.) < 0
C
           IF((B(2)+B(1)).LT.SSS(1).AND.(B(2)-B(1)).GT.SSS(2))
     C                         CALL GRID2(NOBS,NEQ,34,B,1,NDIM)
C
C  CHECK IF PREVIOUS DIMENSION SET EQUAL TO +1/-1 AND DO GRID SEARCH
C     ALONG TRACKS THROUGH HYPERSHERE
C
           DYN(NEQ,NDIM)=B(1)
           ZMID(NEQ,NDIM)=B(2)
           ENDIF
C
           SUM=0.0
           DO 9 K=1,NDIM
  9        SUM=SUM+ZMID(NEQ,K)**2
           IF(NDIM.GT.1.AND.SUM.GT.1.0)
     C                          CALL GRID2(NOBS,NEQ,34,B,4,NDIM)
           DYN(NEQ,NDIM)=B(1)
           ZMID(NEQ,NDIM)=B(2)
           STDDVZ(NEQ,1,NDIM)=SSSE(1)
           STDDVZ(NEQ,2,NDIM)=SSSE(2)
           ZSAVE(NEQ,2,1)=ZSAVE(NEQ,1,1)
           ZSAVE(NEQ,1,1)=B(1)
           CSAVE(NEQ,2)=CSAVE(NEQ,1)
           CSAVE(NEQ,1)=B(2)
           ZSAVE(NEQ,2,2)=FNLNL
           ZSAVE(NEQ,1,2)=SVLNL
C
      ENDIF
C
C  ***** LEGISLATOR PHASE *****
C
      IF(NSTEP.EQ.2)THEN
           SUM=0.0
C
C  IMPOSE CONSTRAINT THAT LEGISLATOR COORDINATES HAVE TO LIE WITHIN A
C     UNIT HYPERSPHERE
C
           IF(NDIM.GT.1)THEN
              BMAX=-99999999999999.0
              XDATA(NEQ,NDIM)=B(1)
              DO 11 K=1,NDIM
              SUM=SUM+XDATA(NEQ,K)**2
  11          CONTINUE
              IF(SUM.GT.1.0)THEN
C                 WRITE(37,1012)NEQ,(XDATA(NEQ,K),K=1,NDIM),FNLNL
C
C  NORMALIZE LEGISLATOR COORDINATES TO BE ON SURFACE OF HYPERSPHERE
C
                 DO 13 K=1,NDIM
  13             XSP(K)=XDATA(NEQ,K)*(1.0/SQRT(SUM))
C                 WRITE(37,1014)(XSP(K),K=1,NDIM)
                 XDATA(NEQ,NDIM)=0.0
C
C  CREATE POINTS ON HYPERSPHERE SURFACE FROM NEW TO OLD POINT
C
                 WTSQ=BBB(2)**2
                 DO 14 JJ=1,21
                 XLL=0.0
                 XJJ=FLOAT(JJ)
                 ASUM=0.0
                 DO 15 K=1,NDIM
                 XNEW(K)=XSP(K)+((XJJ-1.0)/20.0)*(XDATA(NEQ,K)-XSP(K))
  15             ASUM=ASUM+XNEW(K)**2
                 DO 18 K=1,NDIM
  18             XNEW(K)=XNEW(K)*(1.0/SQRT(ASUM))
                 DO 12 JT=1,NRCALL
                 ICH=LDATA(NEQ,JT)
                 IF(ICH.LE.0)GO TO 12
                 D2Y=0.0
                 D2N=0.0
                 DO 16 K=1,NDIM
                 D2Y=D2Y+(BBBB(K)*(XNEW(K)-ZMID(JT,K)+DYN(JT,K)))**2
                 D2N=D2N+(BBBB(K)*(XNEW(K)-ZMID(JT,K)-DYN(JT,K)))**2
  16             CONTINUE
                 XBY=-D2Y/2.0
                 XBY=BBB(1)*EXP(XBY)
                 EXBY=EXP(XBY)
                 XBN=-D2N/2.0
                 XBN=BBB(1)*EXP(XBN)
                 EXBN=EXP(XBN)
                 PHIXI=EXBY+EXBN
                 AA=ALOG(PHIXI)
                 XL=-AA
                 IF(ICH.EQ.1)XL=XL+XBY
                 IF(ICH.EQ.2)XL=XL+XBN
                 XLL=XLL+XL
  12             CONTINUE
C                 WRITE(37,1013)JJ,(XNEW(K),K=1,NDIM),XLL
                 AMX=AMAX1(XLL,BMAX)
                 IF(ABS(AMX-XLL).LE..00001)KJJ=JJ
                 BMAX=AMX
  14             CONTINUE
                 XJJ=FLOAT(KJJ)
                 ASUM=0.0
                 DO 17 K=1,NDIM
                 XDATA(NEQ,K)=XSP(K)+
     C                    ((XJJ-1.0)/20.0)*(XDATA(NEQ,K)-XSP(K))
  17             ASUM=ASUM+XDATA(NEQ,K)**2
                 DO 19 K=1,NDIM
  19             XDATA(NEQ,K)=XDATA(NEQ,K)*(1.0/SQRT(ASUM))
                 B(1)=XDATA(NEQ,NDIM)
C                 WRITE(37,1013)KJJ,(XDATA(NEQ,K),K=1,NDIM),AMX
                 FNLNL=-AMX
              ENDIF
           ENDIF
           XDATA(NEQ,NDIM)=B(1)
           XSAVE(NEQ,2,1)=XSAVE(NEQ,1,1)
           XSAVE(NEQ,1,1)=B(1)
           XSAVE(NEQ,2,2)=FNLNL
           XSAVE(NEQ,1,2)=SVLNL
           STDDVX(NEQ,NDIM)=SSSE(1)
      ENDIF
      RETURN
      END
C
C  ***************************************************************************
C     SUBROUTINE CROSS---CALLED BY MAXLIK AND MAIN.  CALCULATES CROSS
C        CLASSIFICATIONS USING PREDICTED YES AND NO PROBABILITIES VERSUS
C        ACTUAL CHOICES.
C  ***************************************************************************
C
      SUBROUTINE CROSS(II,LL)
      DIMENSION L(2),LL(2,2)
      COMMON /XXCOM/ ZMID(15599,25),XDATA(1799,25),DYN(15599,25),
     CLDATA(1799,15599),PSI(1799,15599,2)
      COMMON /MINE/ NS,NDIM,NQ,NRCALL,NSTEP,NEQ,ISENS(1799),
     CJAN,JANLST,JIO,KIO,NOBS,NOPAR,IFDRV,NFEVAL,
     CMAXIT,MAXSQZ
      COMMON /BOOK/ BBB(50),BBBB(25)
      COMMON /DELTA/ B(50),TESTB(50),DELTAB(50),GRAD(50),V(25,25)
      BETA=BBB(1)
      WEIGHT=BBB(2)
      WTSQ=WEIGHT*WEIGHT/2.0
      DO 5 I=1,2
      L(I)=0
      DO 5 J=1,2
  5   LL(I,J)=0
C
C  ***** UTILITY FUNCTION PHASE *****
C
      IF(NSTEP.EQ.0)THEN
           DO 100 I=1,NOBS
           ICH=LDATA(I,II)
           IF(ICH.LE.0)GO TO 100
           L(ICH)=L(ICH)+1
           SUMY=0.0
           SUMN=0.0
           DO 96 K=1,NDIM
C           SUMY=SUMY+(XDATA(I,K)-ZMID(II,K)+DYN(II,K))**2
C           SUMN=SUMN+(XDATA(I,K)-ZMID(II,K)-DYN(II,K))**2
           SUMY=SUMY+(BBBB(K)*(XDATA(I,K)-ZMID(II,K)+DYN(II,K)))**2
           SUMN=SUMN+(BBBB(K)*(XDATA(I,K)-ZMID(II,K)-DYN(II,K)))**2
   96      CONTINUE
           SUMY=BETA*EXP(-SUMY/2.0)
           SUMN=BETA*EXP(-SUMN/2.0)
           PIY=EXP(SUMY)/(EXP(SUMY)+EXP(SUMN))
           PIN=1.0-PIY
           IF(PIY.GE.PIN)LL(1,ICH)=LL(1,ICH)+1
           IF(PIY.LT.PIN)LL(2,ICH)=LL(2,ICH)+1
  100      CONTINUE
      ENDIF
C
C  ***** ROLL CALL PHASE *****
C
      IF(NSTEP.EQ.1)THEN
           DO 101 I=1,NOBS
           ICH=LDATA(I,II)
           IF(ICH.LE.0)GO TO 101
           L(ICH)=L(ICH)+1
           SUMY=0.0
           SUMN=0.0
           SUMYY=0.0
           SUMNN=0.0
           DO 97 K=1,NDIM
           SUMYY=SUMYY+((XDATA(I,K)-ZMID(II,K)+DYN(II,K)))**2
           SUMNN=SUMNN+((XDATA(I,K)-ZMID(II,K)-DYN(II,K)))**2
           SUMY=SUMY+(BBBB(K)*(XDATA(I,K)-ZMID(II,K)+DYN(II,K)))**2
           SUMN=SUMN+(BBBB(K)*(XDATA(I,K)-ZMID(II,K)-DYN(II,K)))**2
  97       CONTINUE
           IF(SUMY.LE.SUMN)LL(1,ICH)=LL(1,ICH)+1
           IF(SUMY.GT.SUMN)LL(2,ICH)=LL(2,ICH)+1
C           IF(NDIM.EQ.3.AND.II.EQ.65)THEN
C              WRITE(21,1001)I,II,ICH,SUMY,SUMN,SUMYY,SUMNN,
C     C                      (BBBB(K),K=1,NDIM),(XDATA(I,K),K=1,NDIM),
C     C                      (ZMID(II,K),K=1,NDIM),(DYN(II,K),K=1,NDIM)
C           ENDIF
 1001 FORMAT(3I5,4F10.4/15X,3F10.4/15X,3F10.4/15X,6F10.4)
           SUMY=BETA*EXP(-SUMY/2.0)
           SUMN=BETA*EXP(-SUMN/2.0)
           PIY=EXP(SUMY)/(EXP(SUMY)+EXP(SUMN))
           PIN=1.0-PIY
C           IF(PIY.GE.PIN)LL(1,ICH)=LL(1,ICH)+1
C           IF(PIY.LT.PIN)LL(2,ICH)=LL(2,ICH)+1
  101      CONTINUE
      ENDIF
C
C  ***** LEGISLATOR PHASE *****
C
      IF(NSTEP.EQ.2)THEN
           DO 200 I=1,NRCALL
           ICH=LDATA(II,I)
           IF(ICH.LE.0)GO TO 200
C
C    USE THIS STATEMENT IF, ON THE LAST ITERATION, YOU DESIRE TO CALCULATE
C      THE CLASSIFICATIONS OF UNCONSTRAINED ROLL CALLS ONLY
C           IF(ABS(ZMID(I,K)).EQ.1.0.AND.JANLST.EQ.JAN)GO TO 200
C
           L(ICH)=L(ICH)+1
           SUMY=0.0
           SUMN=0.0
           DO 98 K=1,NDIM
           SUMY=SUMY+(BBBB(K)*(XDATA(II,K)-ZMID(I,K)+DYN(I,K)))**2
           SUMN=SUMN+(BBBB(K)*(XDATA(II,K)-ZMID(I,K)-DYN(I,K)))**2
  98       CONTINUE
           SUMY=BETA*EXP(-SUMY/2.0)
           SUMN=BETA*EXP(-SUMN/2.0)
           PIY=EXP(SUMY)/(EXP(SUMY)+EXP(SUMN))
           PIN=1.0-PIY
           IF(PIY.GE.PIN.AND.ICH.EQ.1)LL(1,1)=LL(1,1)+1
           IF(PIY.GE.PIN.AND.ICH.EQ.2)LL(1,2)=LL(1,2)+1
           IF(PIY.LT.PIN.AND.ICH.EQ.1)LL(2,1)=LL(2,1)+1
           IF(PIY.LT.PIN.AND.ICH.EQ.2)LL(2,2)=LL(2,2)+1
  200      CONTINUE
      ENDIF
      RETURN
      END
C
C  ***************************************************************************
C    SUBROUTINE OUTWRT---CALLED BY MAIN DURING THE ROLL CALL AND LEGISLATOR
C      PHASES ONLY.  CALCULATES NUMBER OF CONSTRAINED ROLL CALLS AND GMP
C      FOR EACH ROLL CALL DURING ROLL CALL PHASE AND, AT THE LAST ITERATION,
C      WRITES ROLL CALL ESTIMATES TO DISK.  FOR LEGISLATOR PHASE, THE GMP
C      FOR EACH LEGISLATOR IS CALCULATED AND, AT THE LAST ITERATION, WRITES
C      LEGISLATOR ESTIMATES TO DISK.  FOR BOTH ROLL CALL AND LEGISLATOR
C      PHASES, THE CPU TIME OF THE PHASE IS CALCULATED, WRITTEN OUT, AND
C      STORED.
C  ***************************************************************************
C
      SUBROUTINE OUTWRT(NRX,NSTEP,JIO,KIO,JAN,JANLST,KPJP,YBIGL,
     C    FMT2,NDIM,NS)
      DIMENSION YBIGL(15999),KPJP(15999,4),ALP(2),BTA(2),RR(2)
      CHARACTER*1 KNAME
      CHARACTER*64 FMT2
      COMMON /XXCOM/ ZMID(15599,25),XDATA(1799,25),DYN(15599,25),
     CLDATA(1799,15599),PSI(1799,15599,2)
      COMMON /XIME/ NTIME(1200),NITR,MSEC
      COMMON /VOTES/ KAV(15599),KAY(15599),KAN(15599),KNAME(1799,99),JNE
      COMMON /STD/ STDDVX(1799,25),STDDVZ(15599,2,25)
      COMMON /BOOK/ BBB(50),BBBB(25)
      COMMON /BAD/ KBAD1,KBAD2,SPRM,SPRSD
 1002 FORMAT(1X,2I6,I2,4X,4I3,1X,101F7.3)
 1003 FORMAT(1X,3I4,2I7,F14.4,3F9.4)
 1004 FORMAT(20A4)
 1005 FORMAT(1X,I4,1X,19A1,4I4,4F10.4)
 1014 FORMAT(1X,2I7,2G20.13)
 1015 FORMAT(1X,I4,5X,5A1,4X,2A1,2X,A1,3X,11A1,1X,3F7.3,4I4)
C
C  ***** ROLL CALL PHASE *****
C
      IF(NSTEP.EQ.1)THEN
           KBAD1=0
           KBAD2=0
           SPRM=0.0
           SPRSD=0.0
           SUM=0.0
           KKSUM=0
           DO 11 I=1,NRX
           KSUM=0
           KVYBAD=0
C
C  KBAD1 IS THE NUMBER OF ROLL CALLS WITH MIDPOINT VECTORS OF LENGTH 1
C
           SUMA=0.0
           SUMY=0.0
           SUMN=0.0
           DO 1 K=1,NDIM
           SUMY=SUMY+(ZMID(I,K)-DYN(I,K))**2
           SUMN=SUMN+(ZMID(I,K)+DYN(I,K))**2
           SUMA=SUMA+ZMID(I,K)**2
  1        CONTINUE
           IF(ABS(1.0-SUMA).LT..001)KBAD1=KBAD1+1
           IF(ABS(1.0-SUMA).LT..001)KVYBAD=1
C
C  KBAD2 IS THE NUMBER OF ROLL CALLS WITH YES AND NO OUTCOMES EXTERIOR
C    TO THE UNIT HYPERSPHERE
C
           IF(SUMY.GT.1.0.AND.SUMN.GT.1.0)KBAD2=KBAD2+1
           SPRM=SPRM+ABS(2.0*DYN(I,NDIM))
           SPRSD=SPRSD+(2.0*DYN(I,NDIM))**2
           DO 12 JJ=1,4
  12       KSUM=KSUM+KPJP(I,JJ)
           KKSUM=KKSUM+KSUM
           SUM=SUM+YBIGL(I)
           IF(KSUM.EQ.0)AA=99.0
           IF(KSUM.EQ.0)GO TO 16
           AA=YBIGL(I)/FLOAT(KSUM)
           AA=EXP(AA)
  16       CONTINUE
           IF(JAN.LT.JANLST.OR.NDIM.LT.NS)GO TO 11
           LYES=KPJP(I,1)+KPJP(I,3)
           LNO =KPJP(I,2)+KPJP(I,4)
           JKP =MIN0(LYES,LNO)
           KTP =KPJP(I,2)+KPJP(I,3)
C           WRITE(21,1119)I,(KPJP(I,J),J=1,4),JKP,KTP
 1119 FORMAT(I4,6I5)
           XPRE=0.0
           IF(JKP.GT.0)THEN
              XPRE=FLOAT(JKP-KTP)/FLOAT(JKP)
           ENDIF
           WRITE(33,1002)I,KAV(I),KVYBAD,(KPJP(I,J),J=1,4),AA,XPRE,
     C     (DYN(I,L),ZMID(I,L),L=1,NS),((STDDVZ(I,J,M),J=1,2),M=1,NS)
C
C
  11       CONTINUE
C
C   SPRM IS THE AVERAGE DISTANCE BETWEEN THE YES AND NO OUTCOMES AND
C      SPRSD IS THE STANDARD DEVIATION OF THE DISTANCE
C
           SPRSD=SQRT(FLOAT(NRX)*SPRSD-SPRM*SPRM)/
     C     FLOAT(NRX)
           SPRM=SPRM/FLOAT(NRX)
      ENDIF
C
C ***** LEGISLATOR PHASE *****
C
      IF(NSTEP.EQ.2)THEN
           SUM=0.0
           KKSUM=0
           DO 13 I=1,NRX
           KSUM=0
           DO 14 JJ=1,4
  14       KSUM=KSUM+KPJP(I,JJ)
           KKSUM=KKSUM+KSUM
           SUM=SUM+YBIGL(I)
           IF(KSUM.EQ.0)AA=99.0
           IF(KSUM.EQ.0)GO TO 166
           AA=YBIGL(I)/FLOAT(KSUM)
           AA=EXP(AA)
 166       CONTINUE
           IF(JAN.LT.JANLST.OR.NDIM.LT.NS)GO TO 13
C
C  WRITE OUT LEGISLATOR COORDINATES--NOTE THAT THIS FORMAT IS UNIQUE
C    TO THE ROLL CALL DATA -- FOR DIFFERENT MATRICES, THIS CODE
C    WILL HAVE TO BE COMMENTED OUT -- SEE EXAMPLE BELOW
C
C
           WRITE(31,FMT2)I,(KNAME(I,J),J=1,JNE),(KPJP(I,J),J=1,4),
     C        AA,(XDATA(I,L),L=1,NS),
     C        (STDDVX(I,M),M=1,NS)
  13       CONTINUE
      ENDIF
C
C  CALCULATE CPU TIME OF CURRENT PHASE
C
      CALL CPUTIM(KTIM1)
      IITIME=KTIM1
      IF(NITR.EQ.1)JITIME=IITIME-NTIME(1)
      NTIME(NITR)=IITIME
      IF(NITR.GT.1)JITIME=NTIME(NITR)-NTIME(NITR-1)
      AA=SUM/FLOAT(KKSUM)
      AA=EXP(AA)
C
C
      CALL CORR(ALP,BTA,RR,NSTEP)
      WRITE(KIO,1014)NRX,KKSUM,SUM,AA
      IF(NSTEP.EQ.2)THEN
           WRITE(JIO,1003)NDIM,NITR,NSTEP,IITIME,JITIME,SUM,AA,RR(1)
           IF(JIO.NE.KIO)WRITE(*,1003)NDIM,NITR,NSTEP,IITIME,JITIME,
     C                                SUM,AA,RR(1)
      ENDIF
      IF(NSTEP.EQ.1)THEN
           WRITE(JIO,1003)NDIM,NITR,NSTEP,IITIME,JITIME,SUM,AA,
     C          RR(1),RR(2)
           IF(JIO.NE.KIO)WRITE(*,1003)NDIM,NITR,NSTEP,IITIME,JITIME,
     C                                SUM,AA,
     C                                RR(1),RR(2)
      ENDIF
      RETURN
      END
C
C  *************************************************************************
C    SUBROUTINE NORMZ---CALLED BY MAXLIK DURING UTILITY FUNCTION PHASE.
C       CHECKS FOR SAG IN LEGISLATOR COORDINATES AND CONSTRAINS "SAGGED"
C       LEGISLATORS FROM BEING FURTHER ESTIMATED.  READJUSTS LEGISLATOR
C       COORDINATES TO LIE BETWEEN -1 AND +1.  READJUSTS ROLL CALL OUTCOME
C       COORDINATES SO THAT SUM OF DYN**2 = SUM OF ABS(XI-ZMID)*DYN.
C  *************************************************************************
C
      SUBROUTINE NORMZ
      DIMENSION XD(1799),LMO(1799)
      COMMON /XXCOM/ ZMID(15599,25),XDATA(1799,25),DYN(15599,25),
     CLDATA(1799,15599),PSI(1799,15599,2)
      COMMON /MINE/ NS,NDIM,NQ,NRCALL,NSTEP,NEQ,ISENS(1799),
     CJAN,JANLST,JIO,KIO,NOBS,NOPAR,IFDRV,NFEVAL,
     CMAXIT,MAXSQZ
      COMMON /SENMIN/ SSS(100),KSMIN,KSMAX
      COMMON /BOOK/ BBB(50),BBBB(25)
 1000 FORMAT(' FURTHEST LEFT LEGISLATOR=',F10.4,2X,
     C'FURTHEST RIGHT LEGISLATOR=',F10.4/14X,'OLD LEFT=',F10.4,
     C15X,'OLD RIGHT=',F10.4/' POSITIONS: LEFT=',I5,3X,'RIGHT=',I5)
 1001 FORMAT('    ADJUSTMENT TO OUTCOME COORDINATES=',2F10.4)
 1002 FORMAT(I6,4F10.4,4I6)
 1111 FORMAT(4F10.4)
C
C  ERROR CATCH FOR NOBS < 20
C
      K7MOA10=10
C
      CC=XDATA(KSMIN,NDIM)
      DD=XDATA(KSMAX,NDIM)
      DO 3 I=1,NOBS
      XD(I)=XDATA(I,NDIM)
  3   LMO(I)=I
      CALL RSORT(XD,NOBS,LMO)
C
C  EXAMINE LEGISLATOR CONFIGURATION FOR SAG.  IF SAG EXISTS, CONSTRAIN
C    ESTIMATION OF LEGISLATOR BY SETTING VALUE OF ISENS(.)=0.
C
C  IF 2ND DIMENSION OR HIGHER, DO NOT INVOKE CONSTRAINTS
C
      IF(NDIM.GT.1.OR.NOBS.LT.20)GO TO 444
C
      DO 99 JJ=1,K7MOA10
      IF(ABS(XD(JJ)-XD(JJ+1)).GT..1)ISENS(LMO(JJ))=0
      IF(ABS(XD(NOBS+1-JJ)-XD(NOBS-JJ)).GT..1)ISENS(LMO(NOBS+1-JJ))=0
      WRITE(KIO,1002)JJ,XD(JJ),XD(JJ+1),XD(NOBS+1-JJ),XD(NOBS-JJ),
     CISENS(LMO(JJ)),ISENS(LMO(JJ+1)),ISENS(LMO(NOBS+1-JJ)),
     CISENS(LMO(NOBS-JJ))
      IF(ISENS(LMO(JJ)).EQ.1.AND.ISENS(LMO(NOBS+1-JJ)).EQ.1)GO TO 999
  99  CONTINUE
  999 CONTINUE
C
  444 CONTINUE
C
C
C  SET MIN AND MAX LEGISLATORS TO FURTHEST LEFT/RIGHT UNCONSTRAINED
C    LEGISLATORS
C
      KSMIN=LMO(1)
      KSMAX=LMO(NOBS)
      DO 77 J=1,K7MOA10
      IF(ISENS(LMO(J)).EQ.0)THEN
         KSMIN=LMO(J+1)
      ENDIF
      IF(ISENS(LMO(NOBS+1-J)).EQ.0)THEN
         KSMAX=LMO(NOBS+1-J-1)
      ENDIF
  77  CONTINUE
C
C  IF 2ND DIMENSION OR HIGHER, DO NOT INVOKE CONSTRAINTS
C
      IF(NDIM.GT.1)GO TO 445
C
      AA=(XDATA(KSMIN,NDIM)+XDATA(KSMAX,NDIM))/2.0
      BB=XDATA(KSMAX,NDIM)-AA
      WRITE(KIO,1111)AA,BB,XDATA(KSMIN,NDIM),XDATA(KSMAX,NDIM)
C
C  SET MIN LEGISLATOR VALUE TO -1 AND MAX LEGISLATOR VALUE TO +1
C    AND NORMALIZE COORDINATES TO RUN FROM -1 TO +1
C
      DO 1 I=1,NOBS
      IF(ISENS(I).EQ.0.AND.XDATA(I,NDIM).LT.0.0)XDATA(I,NDIM)=-1.0
      IF(ISENS(I).EQ.0.AND.XDATA(I,NDIM).GT.0.0)XDATA(I,NDIM)= 1.0
      IF(ISENS(I).EQ.0)GO TO 1
      XDATA(I,NDIM)=(XDATA(I,NDIM)-AA)/BB
      IF(XDATA(I,NDIM).GT.1.0)XDATA(I,NDIM)=1.0
      IF(XDATA(I,NDIM).LT.-1.0)XDATA(I,NDIM)=-1.0
  1   CONTINUE
C
C  APPLY LINEAR TRANSFORMATION TO ROLL CALL COORDINATES
C
      DO 2 J=1,NRCALL
      ZMID(J,NDIM)=(ZMID(J,NDIM)-AA)/BB
  2   CONTINUE
C
C  MULTIPLY WEIGHT BY SCALING FACTOR SO AS TO ACHIEVE CANCELLATION
C    IN EXPONENT OF UTILITY FUNCTION
C
      BBB(2)=BBB(2)*BB
      BBBB(1)=BBB(2)
C
C  SET NEW MIN AND MAX VALUES
C
C
  445 CONTINUE
C
      SSS(1)=XDATA(KSMIN,NDIM)
      SSS(2)=XDATA(KSMAX,NDIM)
      SSS(3)=XDATA(LMO(2),NDIM)
      SSS(4)=XDATA(LMO(NOBS-1),NDIM)
C
      WRITE(KIO,1000)XDATA(KSMIN,NDIM),XDATA(KSMAX,NDIM),CC,DD,
     C    KSMIN,KSMAX
      RETURN
      END
C
C  *************************************************************************
C    SUBROUTINE GRID2---CALLED BY RPRINT.  PERFORMS GRID SEARCH WHEN
C      ESTIMATES OF ROLL CALL PARAMETERS ARE UNREALISTIC.
C             IF KKS = 1 THEN THE YES AND NO OUTCOMES ARE OFF THE
C                        OPPOSITE ENDS OF THE DIMENSION
C             IF KKS = 2 THEN ZMID(.) > FURTHEST RIGHT LEGISLATOR
C             IF KKS = 3 THEN ZMID(.) < FURTHEST LEFT LEGISLATOR
C  *************************************************************************
C
      SUBROUTINE GRID2(NOBS,NEQ,KIO,B,KKS,NDIM)
      DIMENSION ZY(200),B(50),ZN(200),ZM(50,50),PTA(50),
     CPTB(50),PTC(50),CMINUSZ(50),BMINUSA(50)
      COMMON /XXCOM/ ZMID(15599,25),XDATA(1799,25),DYN(15599,25),
     CLDATA(1799,15599),PSI(1799,15599,2)
      COMMON /BOOK/ BBB(50),BBBB(25)
      COMMON /SENMIN/ SSS(100),KSMIN,KSMAX
      COMMON /LUCK/ YBIGL(15999),YYBIGL(15999)
      COMMON /LIKE/ SVLNL,FNLNL,ICNVG,ITT,NVAL
 1000 FORMAT(' OFF OPPOSITE ENDS OUTCOMES'/1X,3I5,4F10.4)
 1001 FORMAT(' NEW ESTIMATES OF DYN AND ZM FROM GRID SEARCH'
     C        /6X,2I5,4F10.4)
 1002 FORMAT(' UNREALISTIC ESTIMATES OF DYN AND ZM'/1X,3I5,4F10.4)
 1003 FORMAT(' UNREALISTIC ESTIMATES OF DYN AND ZM'/1X,3I5/6F10.4/
     C 6F10.4)
 1004 FORMAT(' NEW ESTIMATES OF MIDPOINTS NDIM-1 AND NDIM'/
     C          1X,3I5,4F10.4/16X,6F10.4/16X,6F10.4/16X,6F10.4/
     C          16X,6F10.4)
 1005 FORMAT(' BIZARRE RESULTS'/1X,3I5,3F10.4/16X,6F10.4/
     C          16X,6F10.4/16X,6F10.4/16X,6F10.4)
 1006 FORMAT(' BIG ERROR',3I5,3F10.4/25X,4F10.4)
 1007 FORMAT(' BIZARRE RESULTS2'/1X,3I5,5F10.4)
      NCUT=100
      NCUTCUT=101
      BMAX=-999999999.0
      BMAXY=-999999999.0
      BMAXN=-999999999.0
      WEIGHT=BBB(2)
C
C  TAKE INTO ACCOUNT POLARITY OF ROLL CALL
C
      XSIGN=+1.0
      IF(B(1).LE.0.0)XSIGN=-1.0
C
C  ***** OUTCOMES OFF OPPOSITE ENDS OF DIMENSION *****
C
      IF(KKS.EQ.1)THEN
C           WRITE(KIO,1000)KKS,NDIM,NEQ,B(1),B(2),YBIGL(NEQ),SVLNL
           DYNDYN=ABS(B(1))
           XINC=DYNDYN/FLOAT(NCUT)
C
C  SETUP ANCHOR POINT (ZF) TO START GRID SEARCH SUCH THAT AT LEAST ONE OF THE
C     OUTCOMES IS IN THE INTERIOR OF THE DIMENSION
C
C          ZF/KSMIN--------------0--ZMID-------KSMAX
C
           IF(B(2).GT.0.0)ZF=XDATA(KSMIN,NDIM)
C
C       ZF----KSMIN----ZMID------0-------------KSMAX
C
           IF(B(2).LE.0.0)ZF=B(2)-ABS(XDATA(KSMAX,NDIM)-B(2))
C
C  SETUP NCUT SEARCH POINTS FROM FAR LEFT ANCHOR POINT (ZF) INTO INTERIOR
C
           DO 1 J=1,NCUT
           XJ=FLOAT(J)
  1        ZY(J)=ZF+XINC*(XJ-1.0)
C
C  CALCULATE LOG LIKELIHOOD FOR EACH OF THE NCUT POINTS
C
           DO 2 J=1,NCUT
           XLX=0.0
           DO 3 K=1,NOBS
           ICH=LDATA(K,NEQ)
           IF(ICH.LE.0)GO TO 3
           DY=(WEIGHT*(XDATA(K,NDIM)-ZY(J)))**2
           DN=(WEIGHT*(XDATA(K,NDIM)-2.0*B(2)+ZY(J)))**2
           AA=BBB(1)*EXP(-DY/2.0)*PSI(K,NEQ,1)
           BB=BBB(1)*EXP(-DN/2.0)*PSI(K,NEQ,2)
           PHI=EXP(AA)+EXP(BB)
           CC=ALOG(PHI)
           IF(B(1).GE.0.0)THEN
                IF(ICH.EQ.1)XLX=XLX+AA-CC
                IF(ICH.EQ.2)XLX=XLX+BB-CC
           ENDIF
           IF(B(1).LT.0.0)THEN
                IF(ICH.EQ.2)XLX=XLX+AA-CC
                IF(ICH.EQ.1)XLX=XLX+BB-CC
           ENDIF
  3        CONTINUE
           AMX=AMAX1(XLX,BMAX)
           IF(ABS(AMX-XLX).LE..0001)KJ=J
           BMAX=AMX
  2        CONTINUE
           B(1)=(B(2)-ZY(KJ))*XSIGN
      ENDIF
C
C
C ***** ZMID(.) > FURTHEST RIGHT LEGISLATOR *****
C                    OR
C ***** ZMID(.) < FURTHEST LEFT LEGISLATOR *****
C
C
      IF(KKS.EQ.2.OR.KKS.EQ.3)THEN
C        IF(NDIM.EQ.2)WRITE(21,1002)KKS,NDIM,NEQ,B(1),B(2),YBIGL(NEQ),
C     C                             SVLNL
        IF(NDIM.EQ.1)THEN
C
C  SET MIDPOINT TO FURTHEST RIGHT LEGISLATOR
C
           IF(KKS.EQ.2)B(2)=XDATA(KSMAX,NDIM)
           IF(KKS.EQ.3)B(2)=XDATA(KSMIN,NDIM)
           DYNDYN=1.0
           XINC=DYNDYN/FLOAT(NCUT)
C
C  SET ANCHOR POINT (ZF) FOR GRID SEARCH TO 1 UNIT LEFT OF FURTHEST RIGHT
C     LEGISLATOR/FUTHEST LEFT LEGISLATOR
C
           ZF=B(2)-DYNDYN
           DO 11 J=1,NCUTCUT
           XJ=FLOAT(J)
  11       ZY(J)=ZF+XINC*(XJ-1.0)
           DO 12 J=1,NCUTCUT
           XLX=0.0
           XLX1=0.0
           XLX2=0.0
           DO 13 K=1,NOBS
           ICH=LDATA(K,NEQ)
           IF(ICH.LE.0)GO TO 13
           DY=(WEIGHT*(XDATA(K,NDIM)-ZY(J)))**2
           DN=(WEIGHT*(XDATA(K,NDIM)-2.0*B(2)+ZY(J)))**2
           AA=BBB(1)*EXP(-DY/2.0)*PSI(K,NEQ,1)
           BB=BBB(1)*EXP(-DN/2.0)*PSI(K,NEQ,2)
           PHI=EXP(AA)+EXP(BB)
           CC=ALOG(PHI)
C           IF(B(1).GE.0.0)THEN
                IF(ICH.EQ.1)XLX1=XLX1+AA-CC
                IF(ICH.EQ.2)XLX1=XLX1+BB-CC
C           ENDIF
C           IF(B(1).LT.0.0)THEN
                IF(ICH.EQ.2)XLX2=XLX2+AA-CC
                IF(ICH.EQ.1)XLX2=XLX2+BB-CC
C           ENDIF
  13       CONTINUE
           XLX=AMAX1(XLX1,XLX2)
           IF(J.EQ.1)AMX=XLX
           IF(J.GT.1)AMX=AMAX1(XLX,BMAX)
           IF(ABS(AMX-XLX).LE..0001)THEN
              KJ=J
              IF(ABS(XLX-XLX1).LE..0001)XSIGN=+1.0
              IF(ABS(XLX-XLX2).LE..0001)XSIGN=-1.0
           ENDIF
           BMAX=AMX
  12       CONTINUE
           B(1)=(B(2)-ZY(KJ))*XSIGN
        ENDIF
C
C
        IF(NDIM.GT.1)THEN
C
C  SET MAXIMUM VALUE OF MIDPOINT TO EDGE OF UNIT HYPERSPHERE
C
           SUM=0.0
           NDIMM1=NDIM-1
           DO 33 KK=1,NDIMM1
           SUM=SUM+ZMID(NEQ,KK)**2
  33       CONTINUE
           B2MAX=0.0
           IF(SUM.LT.1.0)THEN
               B2MAX=SQRT(ABS(1.0-SUM))
           ENDIF
           IF(B2MAX.EQ.0.0)THEN
               KKS=4
               GO TO 69
           ENDIF
           KKCUT=10
           KKKCUT=2*KKCUT + 1
           XINC=B2MAX/FLOAT(KKCUT)
C
C  CREATE YEA AND NAY TRACKS THROUGH THE HYPERSPHERE
C
           DO 34 J=1,KKKCUT
           XJ=FLOAT(J)
           ZY(J)=B2MAX-XINC*(XJ-1.0)
  34       ZN(J)=B2MAX-XINC*(XJ-1.0)
C
C  SEARCH FOR THE OPTIMAL PAIR OF OUTCOME COORDINATES
C
C
           XLDEF=0.0
           DO 35 J=1,KKKCUT
           DO 35 L=1,KKKCUT
           XLXY=0.0
           XLXN=0.0
           DO 36 K=1,NOBS
           ICH=LDATA(K,NEQ)
           IF(ICH.LE.0)GO TO 36
C
C  CALCULATE LOG-LIKELIHOOD DUE TO NDIM-1 PREVIOUS DIMENSIONS
C
           IF(J.EQ.KKKCUT.AND.L.EQ.KKKCUT)THEN
               AA=BBB(1)*PSI(K,NEQ,1)
               BB=BBB(1)*PSI(K,NEQ,2)
               PHI=EXP(AA)+EXP(BB)
               CC=ALOG(PHI)
               IF(ICH.EQ.1)XLDEF=XLDEF+AA-CC
               IF(ICH.EQ.2)XLDEF=XLDEF+BB-CC
           ENDIF
           DY=(WEIGHT*(XDATA(K,NDIM)-ZY(J)))**2
           DN=(WEIGHT*(XDATA(K,NDIM)-ZN(L)))**2
           AA=BBB(1)*EXP(-DY/2.0)*PSI(K,NEQ,1)
           BB=BBB(1)*EXP(-DN/2.0)*PSI(K,NEQ,2)
           PHI=EXP(AA)+EXP(BB)
           CC=ALOG(PHI)
C
C  ASSUME YEA ALTERNATIVE IS TO THE LEFT (POSITIVE SPREAD)
C
           IF(ICH.EQ.1)XLXY=XLXY+AA-CC
           IF(ICH.EQ.2)XLXY=XLXY+BB-CC
C
C  ASSUME YEA ALTERNATIVE IS TO THE RIGHT (NEGATIVE SPREAD)
C
           IF(ICH.EQ.2)XLXN=XLXN+AA-CC
           IF(ICH.EQ.1)XLXN=XLXN+BB-CC
  36       CONTINUE
           AMXY=AMAX1(XLXY,BMAXY)
           IF(ABS(AMXY-XLXY).LE..00001)THEN
              KJ=J
              KL=L
           ENDIF
           BMAXY=AMXY
           AMXN=AMAX1(XLXN,BMAXN)
           IF(ABS(AMXN-XLXN).LE..00001)THEN
              LJ=J
              LL=L
           ENDIF
           BMAXN=AMXN
  35       CONTINUE
           IF(AMXY.GT.AMXN)THEN
              B(1)=ABS(ZY(KJ)-ZN(KL))/2.0
              B(2)=(ZY(KJ)+ZN(KL))/2.0
              AMX=AMXY
           ENDIF
           IF(AMXY.LE.AMXN)THEN
              B(1)=ABS(ZY(LJ)-ZN(LL))/2.0
              B(2)=(ZY(LJ)+ZN(LL))/2.0
              AMX=AMXN
           ENDIF
           IF(XLDEF.GE.AMX)THEN
              B(1)=0.0
              B(2)=0.0
              AMX=SVLNL
           ENDIF
           IF(ABS(B(1)).LE.0.01)THEN
              B(1)=0.0
              B(2)=0.0
              AMX=SVLNL
           ENDIF
        ENDIF
      ENDIF
C
C
C  IF NDIM-1 IS AT EDGE OF HYPERSPHERE, CREATE TRACKS PARALLEL TO
C    CUTTING LINE THROUGH HYPERSPHERE AND COMPUTE NDIM-1 & NDIM
C    COORDINATES
C
C
  69  CONTINUE
      IF(KKS.EQ.4)THEN
        BMAX=-9999999999.0
C        IF(NDIM.EQ.2)WRITE(21,1003)KKS,NDIM,NEQ,
C     C                 (DYN(NEQ,JJ),ZMID(NEQ,JJ),JJ=1,NDIM),
C     C                 B(1),B(2),YBIGL(NEQ),SVLNL
C
C  COMPUTE TRACKS THROUGH CENTER OF HYPERSPHERE
C
           SUM=0.0
           DO 54 K=1,NDIM
  54       SUM=SUM+DYN(NEQ,K)**2
           T=1.0/SQRT(SUM)
           XPSI=0.0
           XGAM=0.0
C
C  POINTS A AND B ARE ON THE SURFACE OF THE UNIT HYPERSPHERE ONE UNIT APART
C
           DO 53 K=1,NDIM
           PTA(K)=T*(-DYN(NEQ,K))
           PTB(K)=T*( DYN(NEQ,K))
           XPSI=XPSI+(ZMID(NEQ,K)-PTA(K))**2
  53       XGAM=XGAM+(ZMID(NEQ,K)-PTB(K))**2
           COSB=(XPSI-XGAM-4.0)/(-4.0*SQRT(XGAM))
           COSA=(XGAM-XPSI-4.0)/(-4.0*SQRT(XPSI))
C
C  IF CUTTING LINE DOES NOT INTERSECT HYPERSPHERE SET CURRENT COORDINATES
C    TO ZERO AND RETURN
C
           IF(COSB.LT.0.0.OR.COSA.LT.0.0)THEN
C              WRITE(KIO,1007)KKS,NDIM,NEQ,T,XPSI,XGAM,COSB,COSA
              B(1)=0.0
              B(2)=0.0
              YBIGL(NEQ)=SVLNL
              RETURN
           ENDIF
C
C  CHECK RESULTS
C
           DALPHA=SQRT(XGAM)*COSB
           DBETA =SQRT(XPSI)*COSA
           IF(ABS(2.0-DALPHA-DBETA).GT..001)THEN
C              WRITE(KIO,1006)KKS,NDIM,NEQ,T,XPSI,XGAM,COSB,COSA,
C     C                       DALPHA,DBETA
              STOP
           ENDIF
C
C  FIND POINT C ALONG A TO B LINE THROUGH CENTER OF HYPERSPHERE
C
           DO 52 K=1,NDIM
  52       PTC(K)=PTA(K)+(DBETA/2.0)*(PTB(K)-PTA(K))
C
C  FIND POINTS D AND E -- INTERSECTION OF CUTTING LINE THROUGH
C       THE SURFACE OF THE HYPERSPHERE
C
           AA=0.0
           BB=0.0
           DO 51 K=1,NDIM
           CMINUSZ(K)=PTC(K)-ZMID(NEQ,K)
           BB=BB+2.0*CMINUSZ(K)*ZMID(NEQ,K)
  51       AA=AA+CMINUSZ(K)**2
           CC=0.0
           DO 58 K=1,NDIM-1
  58       CC=CC+ZMID(NEQ,K)**2
           CC=CC+B(2)**2
           CC=CC-1.0
           IF(BB*BB.LT.(4.0*AA*CC))THEN
C              WRITE(KIO,1005)KKS,NDIM,NEQ,AA,BB,CC,
C     C               (DYN(NEQ,JJ),ZMID(NEQ,JJ),JJ=1,NDIM),
C     C               (PTA(JJ),JJ=1,NDIM),(PTB(JJ),JJ=1,NDIM),
C     C               (PTC(JJ),JJ=1,NDIM),
C     C               DALPHA,DBETA,XPSI,XGAM
              B(1)=0.0
              B(2)=0.0
              YBIGL(NEQ)=SVLNL
              RETURN
           ENDIF
           IF(BB*BB.GT.(4.0*AA*CC))THEN
              T1=(-BB + SQRT(BB*BB-4.0*AA*CC))/(2.0*AA)
              T2=(-BB - SQRT(BB*BB-4.0*AA*CC))/(2.0*AA)
              DO 50 K=1,NDIM
              PTA(K)=ZMID(NEQ,K)+T1*CMINUSZ(K)
              PTB(K)=ZMID(NEQ,K)+T2*CMINUSZ(K)
              BMINUSA(K)=PTB(K)-PTA(K)
  50          CONTINUE
           ENDIF
           DO 55 J=1,11
           XJ=FLOAT(J)
           DO 55 K=1,NDIM
           ZM(J,K)=PTA(K)+(1.0-.1*(XJ-1.0))*BMINUSA(K)
  55       CONTINUE
C
C  CALCULATE LOG-LIKELIHOOD
C
           DO 56 L=1,11
           XLX=0.0
           DO 57 K=1,NOBS
           ICH=LDATA(K,NEQ)
           IF(ICH.LE.0)GO TO 57
           DY=0.0
           DN=0.0
           DO 48 KK=1,NDIM
           IF(KK.LE.NDIM-1)THEN
              DY=DY+(BBBB(KK)*(XDATA(K,KK)-ZM(L,KK)+DYN(NEQ,KK)))**2
              DN=DN+(BBBB(KK)*(XDATA(K,KK)-ZM(L,KK)-DYN(NEQ,KK)))**2
           ENDIF
           IF(KK.EQ.NDIM)THEN
              DY=DY+(WEIGHT*(XDATA(K,KK)-ZM(L,KK)+DYN(NEQ,KK)))**2
              DN=DN+(WEIGHT*(XDATA(K,KK)-ZM(L,KK)-DYN(NEQ,KK)))**2
           ENDIF
  48       CONTINUE
           AA=BBB(1)*EXP(-DY/2.0)
           BB=BBB(1)*EXP(-DN/2.0)
           PHI=EXP(AA)+EXP(BB)
           CC=ALOG(PHI)
           IF(ICH.EQ.1)XLX=XLX+AA-CC
           IF(ICH.EQ.2)XLX=XLX+BB-CC
  57       CONTINUE
           AMX=AMAX1(XLX,BMAX)
           IF(ABS(AMX-XLX).LE..00001)THEN
              KL=L
           ENDIF
           BMAX=AMX
  56       CONTINUE
           YBIGL(NEQ)=AMX
           FNLNL=AMX
C           WRITE(KIO,1004)KKS,NDIM,NEQ,(ZM(KL,JJ),JJ=1,NDIM),AMX,
C     C                    (PTC(JJ),JJ=1,NDIM),(CMINUSZ(JJ),JJ=1,NDIM),
C     C                    (PTA(JJ),JJ=1,NDIM),(PTB(JJ),JJ=1,NDIM),
C     C                    T1,T2,XPSI,XGAM,COSA,COSB,DALPHA,DBETA
           DO 47 K=1,NDIM
           ZMID(NEQ,K)=ZM(KL,K)
  47       CONTINUE
           B(2)=ZM(KL,NDIM)
C           IF(NDIM.EQ.2)WRITE(21,1001)NDIM,NEQ,B(1),B(2),AMX
           RETURN
      ENDIF
C
      YBIGL(NEQ)=AMX
      FNLNL=AMX
C      IF(NDIM.EQ.2)WRITE(21,1001)NDIM,NEQ,B(1),B(2),AMX
      RETURN
      END
C
C  ***************************************************************************
C    SUBROUTINE CORR--CALLED BY MAIN, RPRINT, AND OUTWRT.
C       CALCULATES CORRELATION BETWEEN CURRENT
C       SET OF PARAMETERS AND PARAMETERS FROM PREVIOUS ITERATION.
C       IF KHR = 1 CALCULATE CORRELATIONS FOR ROLL CALL PHASE.
C       IF KHR = 2 CALCULATE CORRELATIONS FOR LEGISLATOR PHASE.
C       IF KHR = 0 CALCULATE CORRELATIONS FOR ALL PARAMETERS
C  ***************************************************************************
C
      SUBROUTINE CORR(ALP,BTA,RR,KHR)
      DIMENSION ALP(2),BTA(2),RR(2)
      COMMON /SAVE/ XSAVE(1799,2,2),ZSAVE(15599,2,2),CSAVE(15599,2)
      COMMON /MINE/ NS,NDIM,NQ,NRCALL,NSTEP,NEQ,ISENS(1799),
     CJAN,JANLST,JIO,KIO,NOBS,NOPAR,IFDRV,NFEVAL,
     CMAXIT,MAXSQZ
C
C  CALCULATE CORRELATIONS FOR ROLL CALL PHASE
C
      IF(KHR.EQ.1)THEN
           ASUM=0.0
           BSUM=0.0
           CSUM=0.0
           DSUM=0.0
           ESUM=0.0
           AASUM=0.0
           BBSUM=0.0
           CCSUM=0.0
           DDSUM=0.0
           EESUM=0.0
           DO 3 I=1,NRCALL
           ASUM=ASUM+ZSAVE(I,1,1)
           AASUM=AASUM+CSAVE(I,1)
           BSUM=BSUM+ZSAVE(I,1,1)**2
           BBSUM=BBSUM+CSAVE(I,1)**2
           CSUM=CSUM+ZSAVE(I,2,1)
           CCSUM=CCSUM+CSAVE(I,2)
           DSUM=DSUM+ZSAVE(I,2,1)**2
           DDSUM=DDSUM+CSAVE(I,2)**2
           EESUM=EESUM+CSAVE(I,1)*CSAVE(I,2)
           ESUM=ESUM+ZSAVE(I,1,1)*ZSAVE(I,2,1)
  3        CONTINUE
           XCALL=FLOAT(NRCALL)
           AA=XCALL*ESUM-ASUM*CSUM
           BB=XCALL*BSUM-ASUM*ASUM
           CC=XCALL*DSUM-CSUM*CSUM
           DD=DSUM*ASUM-CSUM*ESUM
C      IF(NDIM.GE.8)WRITE(*,1994)XCALL,AA,BB,CC,DD,
C     C                          ASUM,BSUM,CSUM,DSUM,ESUM
C      IF(NDIM.GE.8)WRITE(21,1994)XCALL,AA,BB,CC,DD,
C     C                          ASUM,BSUM,CSUM,DSUM,ESUM
C 1994 FORMAT(10F10.4)
           ALP(1)=0.0
           IF(CC.GT.0.0)ALP(1)=DD/CC
           BTA(1)=0.0
           IF(CC.GT.0.0)BTA(1)=AA/CC
           RR(1)=0.0
           IF((ABS(BB*CC)).GT.0.0)RR(1)=AA/SQRT(ABS(BB*CC))
           RR(1)=RR(1)*RR(1)
           AA=XCALL*EESUM-AASUM*CCSUM
           BB=XCALL*BBSUM-AASUM*AASUM
           CC=XCALL*DDSUM-CCSUM*CCSUM
           DD=DDSUM*AASUM-CCSUM*EESUM
C      IF(NDIM.GE.8)WRITE(*,1994)XCALL,AA,BB,CC,DD,
C     C                          AASUM,BBSUM,CCSUM,DDSUM,EESUM
C      IF(NDIM.GE.8)WRITE(21,1994)XCALL,AA,BB,CC,DD,
C     C                          AASUM,BBSUM,CCSUM,DDSUM,EESUM
           ALP(2)=0.0
           IF(CC.GT.0.0)ALP(2)=DD/CC
           BTA(2)=0.0
           IF(CC.GT.0.0)BTA(2)=AA/CC
           RR(2)=0.0
           IF((ABS(BB*CC)).GT.0.0)RR(2)=AA/SQRT(ABS(BB*CC))
           RR(2)=RR(2)*RR(2)
      ENDIF
C
C  CALCULATE CORRELATIONS FOR LEGISLATOR PHASE
C
      IF(KHR.EQ.2)THEN
           ASUM=0.0
           BSUM=0.0
           CSUM=0.0
           DSUM=0.0
           ESUM=0.0
           DO 11 I=1,NOBS
           ASUM=ASUM+XSAVE(I,1,1)
           BSUM=BSUM+XSAVE(I,1,1)**2
           CSUM=CSUM+XSAVE(I,2,1)
           DSUM=DSUM+XSAVE(I,2,1)**2
  11       ESUM=ESUM+XSAVE(I,1,1)*XSAVE(I,2,1)
           XNOBS=FLOAT(NOBS)
           AA=XNOBS*ESUM-ASUM*CSUM
           BB=XNOBS*BSUM-ASUM*ASUM
           CC=XNOBS*DSUM-CSUM*CSUM
           DD=DSUM*ASUM-CSUM*ESUM
           ALP(1)=DD/CC
           BTA(1)=AA/CC
           RR(1)=AA/SQRT(BB*CC)
           RR(1)=RR(1)*RR(1)
      ENDIF
C
C  CALCULATE CORRELATION OVER ALL PARAMETERS
C
      IF(KHR.LE.0)THEN
           AASUM=0.0
           BBSUM=0.0
           CCSUM=0.0
           DDSUM=0.0
           EESUM=0.0
           ASUM=0.0
           BSUM=0.0
           CSUM=0.0
           DSUM=0.0
           ESUM=0.0
           DO 21 I=1,NOBS
           ASUM=ASUM+XSAVE(I,1,1)
           BSUM=BSUM+XSAVE(I,1,1)**2
           CSUM=CSUM+XSAVE(I,2,1)
           DSUM=DSUM+XSAVE(I,2,1)**2
  21       ESUM=ESUM+XSAVE(I,1,1)*XSAVE(I,2,1)
           DO 23 I=1,NRCALL
           ASUM=ASUM+ZSAVE(I,1,1)
           AASUM=AASUM+CSAVE(I,1)
           BSUM=BSUM+ZSAVE(I,1,1)**2
           BBSUM=BBSUM+CSAVE(I,1)**2
           CSUM=CSUM+ZSAVE(I,2,1)
           CCSUM=CCSUM+CSAVE(I,2)
           DSUM=DSUM+ZSAVE(I,2,1)**2
           DDSUM=DDSUM+CSAVE(I,2)**2
           EESUM=EESUM+CSAVE(I,1)*CSAVE(I,2)
           ESUM=ESUM+ZSAVE(I,1,1)*ZSAVE(I,2,1)
  23       CONTINUE
           ASUM=ASUM+AASUM
           BSUM=BSUM+BBSUM
           CSUM=CSUM+CCSUM
           DSUM=DSUM+DDSUM
           ESUM=ESUM+EESUM
           XCALL=FLOAT(NOBS+2*NRCALL)
           AA=XCALL*ESUM-ASUM*CSUM
           BB=XCALL*BSUM-ASUM*ASUM
           CC=XCALL*DSUM-CSUM*CSUM
           DD=DSUM*ASUM-CSUM*ESUM
           ALP(1)=DD/CC
           BTA(1)=AA/CC
           RR(1)=AA/SQRT(ABS(BB*CC))
           RR(1)=RR(1)*RR(1)
      ENDIF
      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(XVMIN,KVMIN,LDATA2)
      DIMENSION KKSUM(15599),LLSUM(15599),MMSUM(1799),NNSUM(1799),
     C          KD(15599),KMARG(50),LDATA2(1799,15599)
      CHARACTER*1 KNAME
      CHARACTER*10 LMARG(10)
      COMMON /XXCOM/ ZMID(15599,25),XDATA(1799,25),DYN(15599,25),
     CLDATA(1799,15599),PSI(1799,15599,2)
      COMMON /MINE/ NS,NDIM,NQ,NRCALL,NSTEP,NEQ,ISENS(1799),
     CJAN,JANLST,JIO,KIO,NOBS,NOPAR,IFDRV,NFEVAL,
     CMAXIT,MAXSQZ
      COMMON /VOTES/ KAV(15599),KAY(15599),KAN(15599),KNAME(1799,99),JNE
      COMMON /TCHOIC/ KPTSUM
      DATA KKSUM,LLSUM,KMARG/15599*0,15599*0,50*0/
      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 - 99.5 '
      KPTSUM=0
      NAS=0
      NRS=0
      NOB=0
      NMOB=0
      DO 1 I=1,NOBS
      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,NOBS
      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)KAY(NAS)=KKSUM(J)
      IF(AA.GT.XVMIN)KAN(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)
      LDATA2(NOB,NAS)=KD(J)
      IF(KD(J).NE.0)KPTSUM=KPTSUM+1
 33   CONTINUE
  3   CONTINUE
      WRITE(KIO,1000)NRCALL,NRS,NAS,XVMIN
 1000 FORMAT(' ROLL-CALLS READ=',I6,2X,'NUMBER REJECTED=',I6,2X,
     C'NUMBER ACCEPTED=',I6,2X,'CUTOFF=',F6.3)
      WRITE(KIO,1001)NOBS,NMOB,NOB,KVMIN
 1001 FORMAT(' LEGISLATORS READ=',I4,2X,'NUMBER REJECTED=',I4,2X,
     C'NUMBER ACCEPTED=',I4,2X,'CUTOFF=',I4)
      NRCALL=NAS
      NOBS=NOB
C
C   CALCULATE DISTRIBUTION OF ROLL CALL MARGINS
C
      DO 40 J=1,NRCALL
      KAY(J)=0
      KAN(J)=0
      DO 41 I=1,NOBS
      IF(LDATA(I,J).EQ.1)KAY(J)=KAY(J)+1
      IF(LDATA(I,J).EQ.6)KAN(J)=KAN(J)+1
  41  CONTINUE
  40  CONTINUE
      LLTOT=0
      LLALL=0
      DO 4 J=1,NRCALL
      LL=MAX0(KAY(J),KAN(J))
      LLTOT=LLTOT+LL
      AA=FLOAT(LL)/FLOAT(KAY(J)+KAN(J))
      LLALL=LLALL+KAY(J)+KAN(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..995)KMARG(10)=KMARG(10)+1
  4   CONTINUE
      WRITE(KIO,1003)
 1003 FORMAT('  DISTRIBUTION OF SCALABLE ROLL CALLS')
      DO 5 I=1,10
      AA=FLOAT(KMARG(I))/FLOAT(NRCALL)
      WRITE(KIO,1002)I,LMARG(I),KMARG(I),AA
  5   CONTINUE
 1002 FORMAT(I4,1X,A10,I5,F7.3)
      XSUM=FLOAT(LLTOT)/FLOAT(LLALL)
      WRITE(23,1004)LLTOT,LLALL,XSUM
      WRITE(*,1004)LLTOT,LLALL,XSUM
 1004 FORMAT(' AVERAGE MAJORITY MARGIN= ',2I8,F9.5)
      RETURN
      END
C
C  **************************************************************************
C     SUBROUTINE RECODE--CALLED BY MAIN.  GENERATES STARTING VALUES FOR THE
C       ROLL CALL PARAMETERS.
C  **************************************************************************
C
      SUBROUTINE RECODE(NS,NOBS,NRCALL,LDATA2,KLSEN,KLSEN2,KIO)
      DIMENSION X(1799),KV(1799),LL(1799),LDATA2(1799,15599)
      CHARACTER*1 KNAME
      COMMON /XXCOM/ ZMID(15599,25),XDATA(1799,25),DYN(15599,25),
     CLDATA(1799,15599),PSI(1799,15599,2)
      COMMON /SENMIN/ SSS(100),KSMIN,KSMAX
      COMMON /VOTES/ KAV(15599),KAY(15599),KAN(15599),KNAME(1799,99),JNE
      COMMON /SAVE/ XSAVE(1799,2,2),ZSAVE(15599,2,2),CSAVE(15599,2)
      COMMON /TCHOIC/ KPTSUM
      COMMON /BOOK/ BBB(50),BBBB(25)
      COMMON /TITLE/ TIT2(26,3)
 2000 FORMAT(' NUMBER LEGISLATORS=',I4,1X,'FURTHEST LEFT=',F10.4,1X,
     C'FURTHEST RIGHT=',F10.4/' POSITIONS: LEFT=',I4,2X,'RIGHT=',I4)
      AA=99.0
      BB=-99.0
C
C  SET FURTHEST LEFT LEGISLATOR TO NEGATIVE VALUE CHANGE SIGNS OF LEGISLATORS
C     IF NECESSARY AND FIND MAXIMUM AND MINIMUM LEGISLATORS
C
      XXX=XDATA(KLSEN,1)
      XXXX=XDATA(KLSEN2,2)
      IF(XXX.LT..0)GO TO 40
      DO 41 I=1,NOBS
  41  XDATA(I,1)=-XDATA(I,1)
  40  CONTINUE
      IF(XXXX.GT..0)GO TO 42
      DO 43 I=1,NOBS
  43  XDATA(I,2)=-XDATA(I,2)
  42  CONTINUE
      DO 1 I=1,NOBS
      AA=AMIN1(AA,XDATA(I,1))
      BB=AMAX1(BB,XDATA(I,1))
      IF(ABS(AA-XDATA(I,1)).LE..00001)KSMIN=I
      IF(ABS(BB-XDATA(I,1)).LE..00001)KSMAX=I
  1   CONTINUE
C
C  WRITE OUT MAXIMUM AND MINIMUM LEGISLATORS
C
      WRITE(KIO,2000)NOBS,AA,BB,KSMIN,KSMAX
C
C  TRANSFORM LEGISLATOR CONFIGURATION SO THAT IT RUNS FROM -1 TO +1
C
      AA=(XDATA(KSMIN,1)+XDATA(KSMAX,1))/2.0
      BB=XDATA(KSMAX,1)-AA
      DO 10 I=1,NOBS
      LL(I)=I
      XDATA(I,1)=(XDATA(I,1)-AA)/BB
      XSAVE(I,1,1)=XDATA(I,1)
  10  X(I)=XDATA(I,1)
      CALL RSORT(X,NOBS,LL)
C
C  STORE 4 MOST EXTREME LEGISLATORS IN SSS(.)
      SSS(1)=X(1)
      SSS(2)=X(NOBS)
      SSS(3)=X(2)
      SSS(4)=X(NOBS-1)
C
C  CALL JANICE TO FIND OPTIMAL CUTTING LINE FOR EACH ROLL CALL AND
C    SET ZMID(.) TO THE OPTIMAL CUTTING LINE.  DETERMINE INITIAL
C    POLARITY OF ROLL CALL AND STORE -1.0 OR +1.0 IN DYN(.) DEPENDING
C    UPON POLARITY.
C
      KPTSUM=0
      DO 3 J=1,NRCALL
      SUMY=0.0
      SUMN=0.0
      DO 4 I=1,NOBS
      KV(I)=LDATA2(LL(I),J)
      IF(LDATA2(I,J).EQ.1)SUMY=SUMY+XDATA(I,1)
  4   IF(LDATA2(I,J).EQ.6)SUMN=SUMN+XDATA(I,1)
      SUMY=SUMY/FLOAT(KAY(J))
      SUMN=SUMN/FLOAT(KAN(J))
      SUMM=(SUMN+SUMY)/2.0
      KYES=KAY(J)
      KNO=KAN(J)
      JJJJ=J
C
C  JANICE FINDS OPTIMAL CUTTING POINT AND POLARITY
C
      CALL JANICE(JJJJ,KAV,NOBS,KV,X,KYES,KNO,KIO,KFLIP,ZSAB,YPRE,SUMY,
     CSUMN,SUMM)
      DO 7 I=1,NOBS
      IF(LDATA(I,J).NE.0)KPTSUM=KPTSUM+1
  7   IF(LDATA(I,J).EQ.6)LDATA(I,J)=2
      ZMID(J,1)=ZSAB
      IF(ZSAB.GT.0.0)DT=(ZSAB+1.0)/2.0
      IF(ZSAB.LE.0.0)DT=(1.0-ZSAB)/2.0
      IF(KFLIP.EQ.1)DYN(J,1)=DT
      IF(KFLIP.EQ.2)DYN(J,1)=-DT
      ZSAVE(J,1,1)=DYN(J,1)
      CSAVE(J,1)=ZMID(J,1)
  33  CONTINUE
  3   CONTINUE
      RETURN
      END
C
C  ***************************************************************************
C    SUBROUTINE JANICE---CALLED BY RECODE.  SEARCHES EVERY PAIR OF ADJACENT
C      LEGISLATORS IN ASCENDING ORDER AND CALCULATES CLASSIFICATION ERROR
C      ASSOCIATED WITH USING THE MIDPOINT BETWEEN THE PAIR OF ADJACENT
C      LEGISLATORS AS THE ROLL CALL MIDPOINT.  THIS IS DONE FOR EACH POLARITY
C      OF THE ROLL CALL (LEFT = YES/RIGHT = YES).  PROGRAM RETURNS THE BEST
C      CUTPOINT AND POLARITY OF ROLL CALL.
C  ***************************************************************************
C
      SUBROUTINE JANICE(JJJJ,KAV,NS,KV,X,KYES,KNO,JP,KFLIP,ZSAB,YPRE,
     CSUMY,SUMN,SUMM)
      COMMON /INTGER /IIII
      DIMENSION KV(1799),X(1799),Y(1799),Z(1799),LV(1799),
     C          LVB(1799),LE(1799),
     C          LEB(1799),WK(10),KAV(15599)
  200 FORMAT('         KYES KNO   ZM   #ZM  CH  CL  EH  EL    %      PRE
     C    YES    NO    MID')
  250 FORMAT(1X,4I4,F7.3,5I4,5F7.3)
  260 FORMAT(17X,F7.3,5I4,2F7.3)
C
      NSS=NS-1
      KCUT=1
      LCUT=6
      DO 999 III=1,2
      IF(III.EQ.2)KCUT=6
      IF(III.EQ.2)LCUT=1
C      IF(IIII.GT.1)KCUT=2
C      IF(IIII.GT.1)LCUT=1
      KMARK=1
      KSE=0
      KSV=0
      LSV=0
      LSE=0
      I=0
  10  I=I+1
      IF(I.EQ.NS)GO TO 12
      IF(I.LT.NS)Y(I)=(X(I)+X(I+1))/2.0
      IF(KV(I).EQ.KCUT)KSV=KSV+1
      IF(KV(I).EQ.LCUT)KSE=KSE+1
      IF(KMARK.EQ.1)GO TO 30
      IF(KV(I).EQ.KCUT)LSE=LSE-1
      IF(KV(I).EQ.LCUT)LSV=LSV-1
      GO TO 31
  30  KPDIS=I+1
      DO 3 J=KPDIS,NS
      IF(LCUT-KV(J))33,5,33
  33  IF(KCUT-KV(J))3,6,3
  5   LSV=LSV+1
      GO TO 3
  6   LSE=LSE+1
  3   CONTINUE
      KMARK=0
  31  CONTINUE
      LV(I)=KSV
      LVB(I)=LSV
      LE(I)=KSE
      LEB(I)=LSE
      KT=LV(I)+LE(I)+LVB(I)+LEB(I)
      XKT=KT
      KTT=LE(I)+LEB(I)
      XKE=KTT
      Z(I)=(XKE/XKT)*100.0
      GO TO 10
  12  CONTINUE
      DO 64 J=1,5
      K=J
      AA=Z(J)
      AB=Y(J)
      LA=LV(J)
      LB=LE(J)
      LC=LVB(J)
       LD=LEB(J)
      DO 63 I=J,NSS
      IF(Z(I).GE.AA)GO TO 63
      K=I
      AA=Z(I)
      AB=Y(I)
      LA=LV(I)
      LB=LE(I)
      LC=LVB(I)
      LD=LEB(I)
  63  CONTINUE
      Z(K)=Z(J)
      Z(J)=AA
      Y(K)=Y(J)
      Y(J)=AB
      LV(K)=LV(J)
      LV(J)=LA
      LE(K)=LE(J)
      LE(J)=LB
      LVB(K)=LVB(J)
      LVB(J)=LC
      LEB(K)=LEB(J)
      LEB(J)=LD
  64  CONTINUE
      J=1
      DO 123 I=2,5
      IF(Z(1)-Z(I))123,124,123
  124 J=J+1
  123 CONTINUE
      XMID=0.0
      DO 125 I=1,J
      XMID=XMID+Y(I)
      XFIT=FLOAT(LV(I))*FLOAT(LVB(I))
      YFIT=FLOAT(LE(I))*FLOAT(LEB(I))
      AFIT=FLOAT(LV(I))+FLOAT(LEB(I))
      BFIT=FLOAT(LVB(I))+FLOAT(LE(I))
      IF(AFIT.EQ.0.0.OR.BFIT.EQ.0.0)WK(I)=0.0
      IF(AFIT.EQ.0.0.OR.BFIT.EQ.0.0)GO TO 125
      WK(I)=(XFIT-YFIT)/(AFIT*BFIT)
  125 CONTINUE
      XMID=XMID/FLOAT(J)
      AA=Z(1)
      AB=Y(1)
      AC=WK(1)
      LA=LV(1)
      LB=LE(1)
      LC=LVB(1)
      LD=LEB(1)
      IF(J.EQ.1)GO TO 127
      DO 126 I=2,J
      IF(WK(I).LE.AC)GO TO 126
      AA=Z(I)
      AB=Y(I)
      AC=WK(I)
      LA=LV(I)
      LB=LE(I)
      LC=LVB(I)
      LD=LEB(I)
  126 CONTINUE
  127 JSAVE=J
      KPP=AMIN0(KYES,KNO)
      JKK=LB+LD
      XPRE=FLOAT(KPP-JKK)/FLOAT(KPP)
      NOWRIT=0
      NOWRIT=1
      IF(NOWRIT.EQ.1)GO TO 888
      IF(JJJJ.EQ.1.AND.III.EQ.1)WRITE(88,200)
      IF(III.EQ.1)WRITE(88,250)JJJJ,KAV(JJJJ),KYES,KNO,AB,JSAVE,LA,LC,
     CLB,LD,AA,XPRE,SUMY,SUMN,SUMM
      IF(III.EQ.2)WRITE(88,260)AB,JSAVE,LA,LC,LB,LD,AA,XPRE
  888 IF(III.EQ.2)GO TO 999
      SAB=AB
      SXPRE=XPRE
  999 CONTINUE
      YPRE=AMAX1(SXPRE,XPRE)
      IF(ABS(YPRE-XPRE).LE..00001)THEN
         KFLIP=2
         ZSAB=AB
      ENDIF
      IF(ABS(YPRE-SXPRE).LE..00001)THEN
         KFLIP=1
         ZSAB=SAB
      ENDIF
      RETURN
      END
C
      SUBROUTINE CPUTIM(KTIM1)
      INTEGER*2 ITIM1,ITIM2,ITIM3,ITIM4
      COMMON /XIME/ NTIME(1200),NITR,MSEC
C
      CALL GETTIM(ITIM1,ITIM2,ITIM3,ITIM4)
      MMSEC=ITIM1*60*60+ITIM2*60+ITIM3
      KTIM1=MMSEC-MSEC
C      KTIM1=0
C
      RETURN
      END
C
C
C  ************************************************************************
C    SORT SUBROUTINE--SORTS A VECTOR 'A' OF REAL ELEMENTS INTO ASCENDING
C    ORDER.  'LA' IS THE NUMBER OF ELEMENTS TO BE SORTED AND 'IR' IS A
C    VECTOR OF INTEGERS THAT RECORDS THE PERMUTATIONS--USUALLY SET TO
C    1,2,3,4,...
C  ************************************************************************
C
C
      SUBROUTINE RSORT(A,LA,IR)
      DIMENSION A(LA),IU(21),IL(21),IR(LA)
      IF (LA.LE.0) RETURN
      M = 1
      I = 1
      J = LA
      R = .375
    5 IF (I.EQ.J) GO TO 45
      IF (R.GT..5898437) GO TO 10
      R = R+3.90625E-2
      GO TO 15
   10 R = R-.21875
   15 K = I
C
C SELECT A CENTRAL ELEMENT OF THE  
C ARRAY AND SAVE IT IN LOCATION T  
C
      IJ = I+(J-I)*R 
      T = A(IJ)   
      IT = IR(IJ) 
C
C FIRST ELEMENT OF ARRAY IS GREATER
C THAN T, INTERCHANGE WITH T       
C
      IF (A(I).LE.T) GO TO 20  
      A(IJ) = A(I) 
      A(I) = T     
      T = A(IJ) 
      IR(IJ) = IR(I)  
      IR(I) = IT
      IT = IR(IJ) 
   20 L = J
C
C IF LAST ELEMENT OF ARRAY IS LESS THAN
C T, INTERCHANGE WITH T
C
      IF (A(J).GE.T) GO TO 30
      A(IJ) = A(J)
      A(J) = T
      T = A(IJ)
      IR(IJ) = IR(J)
      IR(J) = IT
      IT = IR(IJ)
C
C IF FIRST ELEMENT OF ARRAY IS GREATER
C THAN T, INTERCHANGE WITH T
C
      IF (A(I).LE.T) GO TO 30
      A(IJ) = A(I)
      A(I) = T
      T = A(IJ)
      IR(IJ) = IR(I)
      IR(I) = IT
      IT = IR(IJ)
      GO TO 30
   25 IF (A(L).EQ.A(K)) GO TO 30
      TT = A(L)
      A(L) = A(K)
      A(K) = TT
      ITT = IR(L)
      IR(L) = IR(K)
      IR(K) = ITT
C
C FIND AN ELEMENT IN THE SECOND HALF OF
C THE ARRAY WHICH IS SMALLER THAN T
C
   30 L = L-1
      IF (A(L).GT.T) GO TO 30
C
C FIND AN ELEMENT IN THE FIRST HALF OF
C THE ARRAY WHICH IS GREATER THAN T
C
   35 K = K+1
      IF (A(K).LT.T) GO TO 35
C
C INTERCHANGE THESE ELEMENTS
C
      IF (K.LE.L) GO TO 25
C
C SAVE UPPER AND LOWER SUBSCRIPTS OF
C THE ARRAY YET TO BE SORTED
C
      IF (L-I.LE.J-K) GO TO 40
      IL(M) = I
      IU(M) = L
      I = K
      M = M+1
      GO TO 50
   40 IL(M) = K
      IU(M) = J
      J = L
      M = M+1
      GO TO 50
C
C BEGIN AGAIN ON ANOTHER PORTION OF
C THE UNSORTED ARRAY
C
   45 M = M-1
      IF (M.EQ.0) RETURN
      I = IL(M)
      J = IU(M)
   50 IF (J-I.GE.11) GO TO 15
      IF (I.EQ.1) GO TO 5
      I = I-1
   55 I = I+1
      IF (I.EQ.J) GO TO 45
      T = A(I+1)
      IT = IR(I+1)
      IF (A(I).LE.T) GO TO 55
      K = I
   60 A(K+1) = A(K)
      IR(K+1) = IR(K)
      K = K-1
      IF (T.LT.A(K)) GO TO 60
      A(K+1) = T
      IR(K+1) = IT
      GO TO 55
      END
C
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
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(1799,25),ZVEC(15599,25),BB(25,15599),
     C          MCUTS(15599,2),WS(33398),LERROR(1799,15599),
     C          LLEGERR(1799,2),LDATA(1799,15599)
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(1799),FV2(1799),
     C          VCOV(25,25),WVEC(25),UL(25,25),
     C          BB(25,15599),
     C          ZVEC(15599,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,1799),XMAT(1799,25),WS(33398),LERROR(1799,15599),
     C          ZVEC(15599,25),MCUTS(15599,2),
     C          ZWRONG(50),XDAT(1799,25),XXZ(15599),LL(15599),
     C          YWRONG(15599,25),YYWRONG(15599,25),LSAVE(15599,25),
     C          XMAT2(25),XXY(15599),YYYWRONG(15599,25),
     C          LDATA(1799,15599)
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,1799),XDAT(1799,25),WS(33398),LERROR(1799,15599),
     C          ZVEC(15599,25),MCUTS(15599,2),XXY(15599),XXZ(15599),
     C          XSAVE(15599,100),MRITE(15599,100),
     C          ZWRONG(50),YWRONG(15599,25),
     C          XALL(33398),KALL(33398),XMAT2(25),
     C          YALL(33398),LALL(33398),LDATA(1799,15599)
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(33398),KA(33398),LV(33398),LVB(33398),
     C          LEB(33398),Z(33398),Y(33398),
     C          LE(33398),LJEP(33398),
     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(1799,25),ZVEC(15599,25),XPROJ(1799,15599),
     C          XXY(15599),
     C          LLL(15599),XXX(1799),MM(15599),MVOTE(15599),WS(33398),
     C          LLV(15599),LLVB(15599),LLE(15599),LLEB(15599),
     C          LERROR(1799,15599),ZS(15599),MCUTS(15599,2),
     C          XJCH(25),XJEH(25),XJCL(25),XJEL(25),
     C          LDATA(1799,15599)
  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(1799,25),ZVEC(15599,25),
     C          XPROJ(1799,15599),WS(33398),XXY(1799),XXX(1799),
     C          MM(1799),
     C          LLL(1799),MVOTE(1799),LLM(1799),LLN(1799),
     C          KKKCUT(1799),LLLCUT(1799),LLV(15599),
     C          LLVB(15599),LLE(15599),LLEB(15599),LERROR(1799,15599),
     C          XJCH(25),XJEH(25),XJCL(25),XJEL(25),
     C          ZS(15599),UUU(1799,25),Y16MIDP(1799,25),
     C          FV1(1799),FV2(1799),SUMX(1799),X16MIDP(1799,25),
     C          YHAT(61913),LWRONG(1799),
     C          VVV(25,25),LDATA(1799,15599)
  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,1799,21,XTOL,IRANK,YHAT,Y16MIDP,
     C           1799,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,1799,21,XTOL,IRANK,YHAT,X16MIDP,
     C           1799,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    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(15599),KA(15599),WS(33398),LV(15599),LVB(15599),
     C          LEB(15599),Z(15599),Y(15599),LLV(15599),LLE(15599),
     C          LLVB(15599),LE(15599),LERROR(1799,15599),LJEP(15599),
     C          LLEB(15599),ZS(15599),LLL(15599),XMAT(1799,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  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
