* ======================================================================
* NIST Guide to Available Math Software.
* Fullsource for module SPLP from package CMLIB.
* Retrieved from CAMSUN on Thu Mar 17 16:23:07 1994.
* ======================================================================
      SUBROUTINE SPLPMN(USRMAT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV,
     * BL,BU,IND,INFO,PRIMAL,DUALS,AMAT,
     * CSC,COLNRM,ERD,ERP,BASMAT,
     * WR,RZ,RG,RPRIM,RHS,
     * WW,LMX,LBM,IBASIS,IBB,IMAT,
     * IBRC,IPR,IWR)
C***BEGIN PROLOGUE  SPLPMN
C***REFER TO  SPLP
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     REAL (12 BLANKS)/DOUBLE PRECISION/,/SASUM/DASUM/,/SDOT/DDOT/,
C     /SCOPY/DCOPY/,/ABS(/DABS(/,/AMAX1/DMAX1/,/AMIN1/DMIN1/,
C     /SVOUT/DVOUT/.
C
C     MARVEL OPTION(S).. OUTPUT=YES/NO TO ELIMINATE PRINTED OUTPUT.
C     THIS DOES NOT APPLY TO THE CALLS TO THE ERROR PROCESSOR.
C
C     MAIN SUBROUTINE FOR SPLP(*) PACKAGE.
C***ROUTINES CALLED  CLOSM,IVOUT,LA05BS,PINITM,PNNZRS,PRWPGE,DASUM,
C                    DCOPY,DDOT,SPINCW,SPINIT,SPLPCE,SPLPDM,SPLPFE,
C                    SPLPFL,SPLPMU,SPLPUP,SPOPT,DVOUT,USRMAT,XERROR,
C                    XERRWV
C***COMMON BLOCKS    LA05DS
C***END PROLOGUE  SPLPMN
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION ABIG,AIJ,AMAT(*),ANORM,ASMALL,BASMAT(*),
     * BL(*),BU(*),COLNRM(*),COSTS(*),COSTSC,CSC(*),DATTRV(*),
     * DIRNRM,DUALS(*),DULNRM,EPS,TUNE,ERD(*),ERDNRM,ERP(*),FACTOR,GG,
     * ONE,PRGOPT(*),PRIMAL(*),RESNRM,RG(*),RHS(*),RHSNRM,ROPT(07),
     * RPRIM(*),RPRNRM,RZ(*),RZJ,R1,R2,SCALR,SCOSTS,SIZE,SMALL,THETA,
     * TOLLS,TWO,UPBND,UU,WR(*),WW(*),XLAMDA,XVAL,ZERO,RDUM(01),TOLABS
C
      INTEGER IBASIS(*),IBB(*),IBRC(LBM,2),IMAT(*),IND(*),
     * IPR(*),IWR(*),INTOPT(08),IDUM(01)
C
C     ARRAY LOCAL VARIABLES
C     NAME(LENGTH)          DESCRIPTION
C
C     COSTS(NVARS)          COST COEFFICIENTS
C     PRGOPT( )             OPTION VECTOR
C     DATTRV( )             DATA TRANSFER VECTOR
C     PRIMAL(NVARS+MRELAS)  AS OUTPUT IT IS PRIMAL SOLUTION OF LP.
C                           INTERNALLY, THE FIRST NVARS POSITIONS HOLD
C                           THE COLUMN CHECK SUMS.  THE NEXT MRELAS
C                           POSITIONS HOLD THE CLASSIFICATION FOR THE
C                           BASIC VARIABLES  -1 VIOLATES LOWER
C                           BOUND; 0 FEASIBLE; +1 VIOLATES UPPER BOUND
C     DUALS(MRELAS+NVARS)   DUAL SOLUTION. INTERNALLY HOLDS R.H. SIDE
C                           AS FIRST MRELAS ENTRIES.
C     AMAT(LMX)             SPARSE FORM OF DATA MATRIX
C     IMAT(LMX)             SPARSE FORM OF DATA MATRIX
C     BL(NVARS+MRELAS)      LOWER BOUNDS FOR VARIBALES
C     BU(NVARS+MRELAS)      UPPER BOUNDS FOR VARIABLES
C     IND(NVARS+MRELAS)     INDICATOR FOR VARIABLES
C     CSC(NVARS)            COLUMN SCALING
C     IBASIS(NVARS+MRELAS)  COLS. 1-MRELAS ARE BASIC, REST ARE NON-BASIC
C     IBB(NVARS+MRELAS)     INDICATOR FOR NON-BASIC VARS., POLARITY OF
C                           VARS., AND POTENTIALLY INFINITE VARS.
C                           IF IBB(J).LT.0, VARIABLE J IS BASIC
C                           IF IBB(J).GT.0, VARIABLE J IS NON-BASIC
C                           IF IBB(J).EQ.0, VARIABLE J HAS TO BE IGNORED
C                           BECAUSE IT WOULD CAUSE UNBOUNDED SOLN.
C                           WHEN MOD(IBB(J),2).EQ.0, VARIABLE IS AT ITS
C                           UPPER BOUND; OTHERWISE IT IS AT ITS LOWER
C                           BOUND
C     COLNRM(NVARS)         NORM OF COLUMNS
C     ERD(MRELAS)           ERRORS IN DUAL VARIABLES
C     ERP(MRELAS)           ERRORS IN PRIMAL VARIABLES
C     BASMAT(LBM)           BASIS MATRIX FOR HARWELL SPARSE CODE
C     IBRC(LBM,2)           ROW AND COLUMN POINTERS FOR BASMAT(*)
C     IPR(2*MRELAS)         WORK ARRAY FOR HARWELL SPARSE CODE
C     IWR(8*MRELAS)         WORK ARRAY FOR HARWELL SPARSE CODE
C     WR(MRELAS)            WORK ARRAY FOR HARWELL SPARSE CODE
C     RZ(NVARS+MRELAS)      REDUCED COSTS
C     RPRIM(MRELAS)         INTERNAL PRIMAL SOLUTION
C     RG(NVARS+MRELAS)      COLUMN WEIGHTS
C     WW(MRELAS)            WORK ARRAY
C     RHS(MRELAS)           HOLDS TRANSLATED RIGHT HAND SIDE
C
C     SCALAR LOCAL VARIABLES
C     NAME       TYPE         DESCRIPTION
C
C     LMX        INTEGER      LENGTH OF AMAT(*)
C     LPG        INTEGER      LENGTH OF PAGE FOR AMAT(*)
C     EPS        REAL         MACHINE PRECISION
C     TUNE       REAL         PARAMETER TO SCALE ERROR ESTIMATES
C     TOLLS      REAL         RELATIVE TOLERANCE FOR SMALL RESIDUALS
C     TOLABS     REAL         ABSOLUTE TOLERANCE FOR SMALL RESIDUALS.
C                             USED IF RELATIVE ERROR TEST FAILS.
C                             IN CONSTRAINT EQUATIONS
C     FACTOR     REAL         .01--DETERMINES IF BASIS IS SINGULAR
C                             OR COMPONENT IS FEASIBLE.  MAY NEED TO
C                             BE INCREASED TO 1.D0 ON SHORT WORD
C                             LENGTH MACHINES.
C     ASMALL     REAL         LOWER BOUND FOR NON-ZERO MAGN. IN AMAT(*)
C     ABIG       REAL         UPPER BOUND FOR NON-ZERO MAGN. IN AMAT(*)
C     MXITLP     INTEGER      MAXIMUM NUMBER OF ITERATIONS FOR LP
C     ITLP       INTEGER      ITERATION COUNTER FOR TOTAL LP ITERS
C     COSTSC     REAL         COSTS(*) SCALING
C     SCOSTS     REAL         TEMP LOC. FOR COSTSC.
C     XLAMDA     REAL         WEIGHT PARAMETER FOR PEN. METHOD.
C     ANORM      REAL         NORM OF DATA MATRIX AMAT(*)
C     RPRNRM     REAL         NORM OF THE SOLUTION
C     DULNRM     REAL         NORM OF THE DUALS
C     ERDNRM     REAL         NORM OF ERROR IN DUAL VARIABLES
C     DIRNRM     REAL         NORM OF THE DIRECTION VECTOR
C     RHSNRM     REAL         NORM OF TRANSLATED RIGHT HAND SIDE VECTOR
C     RESNRM     REAL         NORM OF RESIDUAL VECTOR FOR CHECKING
C                             FEASIBILITY
C     NZBM       INTEGER      NUMBER OF NON-ZEROS IN BASMAT(*)
C     LBM        INTEGER      LENGTH OF BASMAT(*)
C     SMALL      REAL         EPS*ANORM  USED IN HARWELL SPARSE CODE
C     LP         INTEGER      USED IN HARWELL LA05*() PACK AS OUTPUT
C                             FILE NUMBER. SET=I1MACH(4) NOW.
C     UU         REAL         0.1--USED IN HARWELL SPARSE CODE
C                             FOR RELATIVE PIVOTING TOLERANCE.
C     GG         REAL         OUTPUT INFO FLAG IN HARWELL SPARSE CODE
C     IPLACE     INTEGER      INTEGER USED BY SPARSE MATRIX CODES
C     IENTER     INTEGER      NEXT COLUMN TO ENTER BASIS
C     NREDC      INTEGER      NO. OF FULL REDECOMPOSTIONS
C     KPRINT     INTEGER      LEVEL OF OUTPUT, =0-3
C     IDG        INTEGER      FORMAT AND PRECISION OF OUTPUT
C     ITBRC      INTEGER      NO. OF ITERS. BETWEEN RECALCULATING
C                             THE ERROR IN THE PRIMAL SOLUTION.
C     NPP        INTEGER      NO. OF NEGATIVE REDUCED COSTS REQUIRED
C                             IN PARTIAL PRICING
C     JSTRT      INTEGER      STARTING PLACE FOR PARTIAL PRICING.
C
      LOGICAL COLSCP,SAVEDT,CONTIN,CSTSCP,UNBND,
     *        FEAS,FINITE,FOUND,MINPRB,REDBAS,
     *        SINGLR,SIZEUP,STPEDG,TRANS,USRBAS,ZEROLV,LOPT(08)
      EQUIVALENCE (CONTIN,LOPT(1)),(USRBAS,LOPT(2)),
     *  (SIZEUP,LOPT(3)),(SAVEDT,LOPT(4)),(COLSCP,LOPT(5)),
     *  (CSTSCP,LOPT(6)),(MINPRB,LOPT(7)),(STPEDG,LOPT(8)),
     *  (IDG,INTOPT(1)),(IPAGEF,INTOPT(2)),(ISAVE,INTOPT(3)),
     *  (MXITLP,INTOPT(4)),(KPRINT,INTOPT(5)),(ITBRC,INTOPT(6)),
     *  (NPP,INTOPT(7)),(LPRG,INTOPT(8)),(EPS,ROPT(1)),(ASMALL,ROPT(2)),
     *  (ABIG,ROPT(3)),(COSTSC,ROPT(4)),(TOLLS,ROPT(5)),(TUNE,ROPT(6)),
     *   (TOLABS,ROPT(7))
C
C     COMMON BLOCK USED BY LA05 () PACKAGE..
      COMMON/LA05DS/SMALL,LP,LENL,LENU,NCP,LROW,LCOL
      EXTERNAL USRMAT
C
C     SET LP=0 SO NO ERROR MESSAGES WILL PRINT WITHIN LA05 () PACKAGE.
C***FIRST EXECUTABLE STATEMENT  SPLPMN
      LP=0
C
C     THE VALUES ZERO, ONE, AND TWO.
      ZERO=0.D0
      ONE=1.D0
      TWO=2.D0
      FACTOR=0.01D0
      LPG=LMX-(NVARS+4)
      IOPT=1
      INFO=0
      UNBND=.FALSE.
      JSTRT=1
C
C     PROCESS USER OPTIONS IN PRGOPT(*).
C     CHECK THAT ANY USER-GIVEN CHANGES ARE WELL-DEFINED.
      CALL SPOPT(PRGOPT,MRELAS,NVARS,INFO,CSC,IBASIS,ROPT,INTOPT,LOPT)
      IF (.NOT.(INFO.LT.0)) GO TO 20002
      ASSIGN 20002 TO NPR001
      GO TO 30001
20002 IF (.NOT.(CONTIN)) GO TO 20003
      GO TO 30002
20006 GO TO 20004
C
C     INITIALIZE SPARSE DATA MATRIX, AMAT(*) AND IMAT(*).
20003 CALL PINITM(MRELAS,NVARS,AMAT,IMAT,LMX,IPAGEF)
C
C     UPDATE MATRIX DATA AND CHECK BOUNDS FOR CONSISTENCY.
20004 CALL SPLPUP(USRMAT,MRELAS,NVARS,PRGOPT,DATTRV,
     *     BL,BU,IND,INFO,AMAT,IMAT,SIZEUP,ASMALL,ABIG)
      IF (.NOT.(INFO.LT.0)) GO TO 20007
      ASSIGN 20007 TO NPR001
      GO TO 30001
C
C++  CODE FOR OUTPUT=YES IS ACTIVE
20007 IF (.NOT.(KPRINT.GE.1)) GO TO 20008
      GO TO 30003
20011 CONTINUE
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
C
C     INITIALIZATION. SCALE DATA, NORMALIZE BOUNDS, FORM COLUMN
C     CHECK SUMS, AND FORM INITIAL BASIS MATRIX.
20008 CALL SPINIT(MRELAS,NVARS,COSTS,BL,BU,IND,PRIMAL,INFO,
     * AMAT,CSC,COSTSC,COLNRM,XLAMDA,ANORM,RHS,RHSNRM,
     * IBASIS,IBB,IMAT,LOPT)
      IF (.NOT.(INFO.LT.0)) GO TO 20012
      ASSIGN 20012 TO NPR001
      GO TO 30001
C
20012 NREDC=0
      ASSIGN 20013 TO NPR004
      GO TO 30004
20013 IF (.NOT.(SINGLR)) GO TO 20014
      NERR=23
      CALL XERROR('SPLP( ).  A SINGULAR INITIAL BASIS WAS ENCOUNTERED.',
     * 50,NERR,IOPT)
      INFO=-NERR
      ASSIGN 20017 TO NPR001
      GO TO 30001
20017 CONTINUE
20014 ASSIGN 20018 TO NPR005
      GO TO 30005
20018 ASSIGN 20019 TO NPR006
      GO TO 30006
20019 ASSIGN 20020 TO NPR007
      GO TO 30007
20020 IF (.NOT.(USRBAS)) GO TO 20021
      ASSIGN 20024 TO NPR008
      GO TO 30008
20024 IF (.NOT.(.NOT.FEAS)) GO TO 20025
      NERR=24
      CALL XERROR('SPLP( ). AN INFEASIBLE INITIAL BASIS WAS ENCOUNTERED.
     *',53,NERR,IOPT)
      INFO=-NERR
      ASSIGN 20028 TO NPR001
      GO TO 30001
20028 CONTINUE
20025 CONTINUE
20021 ITLP=0
C
C     LAMDA HAS BEEN SET TO A CONSTANT; PERFORM PENALTY METHOD.
      ASSIGN 20029 TO NPR009
      GO TO 30009
20029 ASSIGN 20030 TO NPR010
      GO TO 30010
20030 ASSIGN 20031 TO NPR006
      GO TO 30006
20031 ASSIGN 20032 TO NPR008
      GO TO 30008
20032 IF (.NOT.(.NOT.FEAS)) GO TO 20033
C
C     SET LAMDA TO INFINITY BY SETTING COSTSC TO ZERO (SAVE THE VALUE OF
C     COSTSC) AND PERFORM STANDARD PHASE-1.
      IF(KPRINT.GE.2)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-1'')',
     *IDG)
      SCOSTS=COSTSC
      COSTSC=ZERO
      ASSIGN 20036 TO NPR007
      GO TO 30007
20036 ASSIGN 20037 TO NPR009
      GO TO 30009
20037 ASSIGN 20038 TO NPR010
      GO TO 30010
20038 ASSIGN 20039 TO NPR006
      GO TO 30006
20039 ASSIGN 20040 TO NPR008
      GO TO 30008
20040 IF (.NOT.(FEAS)) GO TO 20041
C
C     SET LAMDA TO ZERO; COSTSC=SCOSTS; PERFORM STANDARD PHASE-2.
      IF(KPRINT.GT.1)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-2'')',
     *IDG)
      XLAMDA=ZERO
      COSTSC=SCOSTS
      ASSIGN 20044 TO NPR009
      GO TO 30009
20044 CONTINUE
20041 GO TO 20034
C     CHECK IF ANY BASIC VARIABLES ARE STILL CLASSIFIED AS
C     INFEASIBLE.  IF ANY ARE, THEN THIS MAY NOT YET BE AN
C     OPTIMAL POINT.  THEREFORE SET LAMDA TO ZERO AND TRY
C     TO PERFORM MORE SIMPLEX STEPS.
20033 I=1
      N20046=MRELAS
      GO TO 20047
20046 I=I+1
20047 IF ((N20046-I).LT.0) GO TO 20048
      IF (PRIMAL(I+NVARS).NE.ZERO) GO TO 20045
      GO TO 20046
20048 GO TO 20035
20045 XLAMDA=ZERO
      ASSIGN 20050 TO NPR009
      GO TO 30009
20050 CONTINUE
20034 CONTINUE
C
20035 ASSIGN 20051 TO NPR011
      GO TO 30011
20051 IF (.NOT.(FEAS.AND.(.NOT.UNBND))) GO TO 20052
      INFO=1
      GO TO 20053
20052 IF (.NOT.((.NOT.FEAS).AND.(.NOT.UNBND))) GO TO 10001
      NERR=1
      CALL XERROR('SPLP( ). THE PROBLEM APPEARS TO BE INFEASIBLE',
     *45,NERR,IOPT)
      INFO=-NERR
      GO TO 20053
10001 IF (.NOT.(FEAS .AND. UNBND)) GO TO 10002
      NERR=2
      CALL XERROR('SPLP( ). THE PROBLEM APPEARS TO HAVE NO FINITE SOLN.'
     *,55,NERR,IOPT)
      INFO=-NERR
      GO TO 20053
10002 IF (.NOT.((.NOT.FEAS).AND.UNBND)) GO TO 10003
      NERR=3
      CALL XERROR(  'SPLP( ). THE PROBLEM APPEARS TO BE INFEASIBLE AND T
     *O HAVE NO FINITE SOLN.',73,NERR,IOPT)
      INFO=-NERR
10003 CONTINUE
20053 CONTINUE
C
20054 IF (.NOT.(INFO.EQ.(-1) .OR. INFO.EQ.(-3))) GO TO 20055
      SIZE=DASUM(NVARS,PRIMAL,1)*ANORM
      SIZE=SIZE/DASUM(NVARS,CSC,1)
      SIZE=SIZE+DASUM(MRELAS,PRIMAL(NVARS+1),1)
      I=1
      N20058=NVARS+MRELAS
      GO TO 20059
20058 I=I+1
20059 IF ((N20058-I).LT.0) GO TO 20060
      NX0066=IND(I)
      IF (NX0066.LT.1.OR.NX0066.GT.4) GO TO 20066
      GO TO (20062,20063,20064,20065), NX0066
20062 IF (.NOT.(SIZE+DABS(PRIMAL(I)-BL(I))*FACTOR.EQ.SIZE)) GO TO 20068
      GO TO 20058
20068 IF (.NOT.(PRIMAL(I).GT.BL(I))) GO TO 10004
      GO TO 20058
10004 IND(I)=-4
20069 GO TO 20067
20063 IF (.NOT.(SIZE+DABS(PRIMAL(I)-BU(I))*FACTOR.EQ.SIZE)) GO TO 20071
      GO TO 20058
20071 IF (.NOT.(PRIMAL(I).LT.BU(I))) GO TO 10005
      GO TO 20058
10005 IND(I)=-4
20072 GO TO 20067
20064 IF (.NOT.(SIZE+DABS(PRIMAL(I)-BL(I))*FACTOR.EQ.SIZE)) GO TO 20074
      GO TO 20058
20074 IF (.NOT.(PRIMAL(I).LT.BL(I))) GO TO 10006
      IND(I)=-4
      GO TO 20075
10006 IF (.NOT.(SIZE+DABS(PRIMAL(I)-BU(I))*FACTOR.EQ.SIZE)) GO TO 10007
      GO TO 20058
10007 IF (.NOT.(PRIMAL(I).GT.BU(I))) GO TO 10008
      IND(I)=-4
      GO TO 20075
10008 GO TO 20058
20075 GO TO 20067
20065 GO TO 20058
20066 CONTINUE
20067 GO TO 20058
20060 CONTINUE
20055 CONTINUE
C
20056 IF (.NOT.(INFO.EQ.(-2) .OR. INFO.EQ.(-3))) GO TO 20077
      J=1
      N20080=NVARS
      GO TO 20081
20080 J=J+1
20081 IF ((N20080-J).LT.0) GO TO 20082
      IF (.NOT.(IBB(J).EQ.0)) GO TO 20084
      NX0091=IND(J)
      IF (NX0091.LT.1.OR.NX0091.GT.4) GO TO 20091
      GO TO (20087,20088,20089,20090), NX0091
20087 BU(J)=BL(J)
      IND(J)=-3
      GO TO 20092
20088 BL(J)=BU(J)
      IND(J)=-3
      GO TO 20092
20089 GO TO 20080
20090 BL(J)=ZERO
      BU(J)=ZERO
      IND(J)=-3
20091 CONTINUE
20092 CONTINUE
20084 GO TO 20080
20082 CONTINUE
20077 CONTINUE
C++  CODE FOR OUTPUT=YES IS ACTIVE
20078 IF (.NOT.(KPRINT.GE.1)) GO TO 20093
      ASSIGN 20096 TO NPR012
      GO TO 30012
20096 CONTINUE
20093 CONTINUE
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
20094 ASSIGN 20097 TO NPR001
      GO TO 30001
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
20097 CONTINUE
C     PROCEDURE (COMPUTE RIGHT HAND SIDE)
30010 RHS(1)=ZERO
      CALL DCOPY(MRELAS,RHS,0,RHS,1)
      J=1
      N20098=NVARS+MRELAS
      GO TO 20099
20098 J=J+1
20099 IF ((N20098-J).LT.0) GO TO 20100
      NX0106=IND(J)
      IF (NX0106.LT.1.OR.NX0106.GT.4) GO TO 20106
      GO TO (20102,20103,20104,20105), NX0106
20102 SCALR=-BL(J)
      GO TO 20107
20103 SCALR=-BU(J)
      GO TO 20107
20104 SCALR=-BL(J)
      GO TO 20107
20105 SCALR=ZERO
20106 CONTINUE
20107 IF (.NOT.(SCALR.NE.ZERO)) GO TO 20108
      IF (.NOT.(J.LE.NVARS)) GO TO 20111
      I=0
20114 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.LE.0)) GO TO 20116
      GO TO 20115
20116 RHS(I)=RHS(I)+AIJ*SCALR
      GO TO 20114
20115 GO TO 20112
20111 RHS(J-NVARS)=RHS(J-NVARS)-SCALR
20112 CONTINUE
20108 GO TO 20098
20100 J=1
      N20119=NVARS+MRELAS
      GO TO 20120
20119 J=J+1
20120 IF ((N20119-J).LT.0) GO TO 20121
      SCALR=ZERO
      IF(IND(J).EQ.3.AND.MOD(IBB(J),2).EQ.0) SCALR=BU(J)-BL(J)
      IF (.NOT.(SCALR.NE.ZERO)) GO TO 20123
      IF (.NOT.(J.LE.NVARS)) GO TO 20126
      I=0
20129 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.LE.0)) GO TO 20131
      GO TO 20130
20131 RHS(I)=RHS(I)-AIJ*SCALR
      GO TO 20129
20130 GO TO 20127
20126 RHS(J-NVARS)=RHS(J-NVARS)+SCALR
20127 CONTINUE
20123 GO TO 20119
20121 CONTINUE
31010 GO TO NPR010, (20030,20038)
C     PROCEDURE (PERFORM SIMPLEX STEPS)
30009 ASSIGN 20134 TO NPR013
      GO TO 30013
20134 ASSIGN 20135 TO NPR014
      GO TO 30014
20135 IF (.NOT.(KPRINT.GT.2)) GO TO 20136
      CALL DVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG)
      CALL DVOUT(NVARS+MRELAS,RZ,'('' REDUCED COSTS'')',IDG)
20136 CONTINUE
20139 ASSIGN 20141 TO NPR015
      GO TO 30015
20141 IF (.NOT.(.NOT. FOUND)) GO TO 20142
      GO TO 30016
20145 CONTINUE
20142 IF (.NOT.(FOUND)) GO TO 20146
      IF (KPRINT.GE.3) CALL DVOUT(MRELAS,WW,'('' SEARCH DIRECTION'')',
     *IDG)
      GO TO 30017
20149 IF (.NOT.(FINITE)) GO TO 20150
      GO TO 30018
20153 ASSIGN 20154 TO NPR005
      GO TO 30005
20154 GO TO 20151
20150 UNBND=.TRUE.
      IBB(IBASIS(IENTER))=0
20151 GO TO 20147
20146 GO TO 20140
20147 ITLP=ITLP+1
      GO TO 30019
20155 GO TO 20139
20140 CONTINUE
31009 GO TO NPR009, (20029,20037,20044,20050)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (RETRIEVE SAVED DATA FROM FILE ISAVE)
30002 LPR=NVARS+4
      REWIND ISAVE
      READ(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR)
      KEY=2
      IPAGE=1
      GO TO 20157
20156 IF (NP.LT.0) GO TO 20158
20157 LPR1=LPR+1
      READ(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX)
      CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT)
      NP=IMAT(LMX-1)
      IPAGE=IPAGE+1
      GO TO 20156
20158 NPARM=NVARS+MRELAS
      READ(ISAVE) (IBASIS(I),I=1,NPARM)
      REWIND ISAVE
31002 GO TO 20006
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (SAVE DATA ON FILE ISAVE)
C
C     SOME PAGES MAY NOT BE WRITTEN YET.
30020 IF (.NOT.(AMAT(LMX).EQ.ONE)) GO TO 20159
      AMAT(LMX)=ZERO
      KEY=2
      IPAGE=IDABS(IMAT(LMX-1))
      CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT)
C
C     FORCE PAGE FILE TO BE OPENED ON RESTARTS.
20159 KEY=AMAT(4)
      AMAT(4)=ZERO
      LPR=NVARS+4
      WRITE(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR)
      AMAT(4)=KEY
      IPAGE=1
      KEY=1
      GO TO 20163
20162 IF (NP.LT.0) GO TO 20164
20163 CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT)
      LPR1=LPR+1
      WRITE(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX)
      NP=IMAT(LMX-1)
      IPAGE=IPAGE+1
      GO TO 20162
20164 NPARM=NVARS+MRELAS
      WRITE(ISAVE) (IBASIS(I),I=1,NPARM)
      ENDFILE ISAVE
C
C     CLOSE FILE, IPAGEF, WHERE PAGES ARE STORED. THIS IS NEEDED SO THAT
C     THE PAGES MAY BE RESTORED AT A CONTINUATION OF SPLP().
31020 GO TO 20317
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (DECOMPOSE BASIS MATRIX)
C++  CODE FOR OUTPUT=YES IS ACTIVE
30004 IF (.NOT.(KPRINT.GE.2)) GO TO 20165
      CALL IVOUT(MRELAS,IBASIS,
     *'('' SUBSCRIPTS OF BASIC VARIABLES DURING REDECOMPOSITION'')',
     *IDG)
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
C
C     SET RELATIVE PIVOTING FACTOR FOR USE IN LA05 () PACKAGE.
20165 UU=0.1
      CALL SPLPDM(
     *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IOPT,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ANORM,EPS,UU,GG,
     *AMAT,BASMAT,CSC,WR,
     *SINGLR,REDBAS)
      IF (.NOT.(INFO.LT.0)) GO TO 20168
      ASSIGN 20171 TO NPR001
      GO TO 30001
20171 CONTINUE
20168 CONTINUE
31004 GO TO NPR004, (20013,20204,20242)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (CLASSIFY VARIABLES)
C
C     DEFINE THE CLASSIFICATION OF THE BASIC VARIABLES
C     -1 VIOLATES LOWER BOUND; 0 FEASIBLE; +1 VIOLATES UPPER BOUND.
C     (THIS INFO IS STORED IN PRIMAL(NVARS+1)-PRIMAL(NVARS+MRELAS))
C     TRANSLATE VARIABLE TO ITS UPPER BOUND, IF .GT. UPPER BOUND
30007 PRIMAL(NVARS+1)=ZERO
      CALL DCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1)
      I=1
      N20172=MRELAS
      GO TO 20173
20172 I=I+1
20173 IF ((N20172-I).LT.0) GO TO 20174
      J=IBASIS(I)
      IF (.NOT.(IND(J).NE.4)) GO TO 20176
      IF (.NOT.(RPRIM(I).LT.ZERO)) GO TO 20179
      PRIMAL(I+NVARS)=-ONE
      GO TO 20180
20179 IF (.NOT.(IND(J).EQ.3)) GO TO 10009
      UPBND=BU(J)-BL(J)
      IF (J.LE.NVARS) UPBND=UPBND/CSC(J)
      IF (.NOT.(RPRIM(I).GT.UPBND)) GO TO 20182
      RPRIM(I)=RPRIM(I)-UPBND
      IF (.NOT.(J.LE.NVARS)) GO TO 20185
      K=0
20188 CALL PNNZRS(K,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(K.LE.0)) GO TO 20190
      GO TO 20189
20190 RHS(K)=RHS(K)-UPBND*AIJ*CSC(J)
      GO TO 20188
20189 GO TO 20186
20185 RHS(J-NVARS)=RHS(J-NVARS)+UPBND
20186 PRIMAL(I+NVARS)=ONE
20182 CONTINUE
20183 CONTINUE
10009 CONTINUE
20180 CONTINUE
20176 GO TO 20172
20174 CONTINUE
31007 GO TO NPR007, (20020,20036)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL SYSTEMS)
30005 NTRIES=1
      GO TO 20195
20194 NTRIES=NTRIES+1
20195 IF ((2-NTRIES).LT.0) GO TO 20196
      CALL SPLPCE(
     *MRELAS,NVARS,LMX,LBM,ITLP,ITBRC,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ERDNRM,EPS,TUNE,GG,
     *AMAT,BASMAT,CSC,WR,WW,PRIMAL,ERD,ERP,
     *SINGLR,REDBAS)
      IF (.NOT.(.NOT. SINGLR)) GO TO 20198
C++  CODE FOR OUTPUT=YES IS ACTIVE
      IF (.NOT.(KPRINT.GE.3)) GO TO 20201
      CALL DVOUT(MRELAS,ERP,'('' EST. ERROR IN PRIMAL COMPS.'')',IDG)
      CALL DVOUT(MRELAS,ERD,'('' EST. ERROR IN DUAL COMPS.'')',IDG)
20201 CONTINUE
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
20202 GO TO 20193
20198 IF (NTRIES.EQ.2) GO TO 20197
      ASSIGN 20204 TO NPR004
      GO TO 30004
20204 CONTINUE
20199 GO TO 20194
20196 CONTINUE
20197 NERR=26
      CALL XERROR('SPLP( ). MOVED TO A SINGULAR POINT. THIS SHOULD NOT H
     *APPEN.',59,NERR,IOPT)
      INFO=-NERR
      ASSIGN 20205 TO NPR001
      GO TO 30001
20205 CONTINUE
20193 CONTINUE
31005 GO TO NPR005, (20018,20154,20243)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (CHECK FEASIBILITY)
C
C     SEE IF NEARBY FEASIBLE POINT SATISFIES THE CONSTRAINT
C     EQUATIONS.
C
C     COPY RHS INTO WW(*), THEN UPDATE WW(*).
30008 CALL DCOPY(MRELAS,RHS,1,WW,1)
      J=1
      N20206=MRELAS
      GO TO 20207
20206 J=J+1
20207 IF ((N20206-J).LT.0) GO TO 20208
      IBAS=IBASIS(J)
      XVAL=RPRIM(J)
C
C     ALL VARIABLES BOUNDED BELOW HAVE ZERO AS THAT BOUND.
      IF (IND(IBAS).LE.3) XVAL=DMAX1(ZERO,XVAL)
C
C     IF THE VARIABLE HAS AN UPPER BOUND, COMPUTE THAT BOUND.
      IF (.NOT.(IND(IBAS).EQ.3)) GO TO 20210
      UPBND=BU(IBAS)-BL(IBAS)
      IF (IBAS.LE.NVARS) UPBND=UPBND/CSC(IBAS)
      XVAL=DMIN1(UPBND,XVAL)
20210 CONTINUE
C
C     SUBTRACT XVAL TIMES COLUMN VECTOR FROM RIGHT-HAND SIDE IN WW(*)
20211 IF (.NOT.(XVAL.NE.ZERO)) GO TO 20213
      IF (.NOT.(IBAS.LE.NVARS)) GO TO 20216
      I=0
20219 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,IBAS)
      IF (.NOT.(I.LE.0)) GO TO 20221
      GO TO 20220
20221 WW(I)=WW(I)-XVAL*AIJ*CSC(IBAS)
      GO TO 20219
20220 GO TO 20217
20216 IF (.NOT.(IND(IBAS).EQ.2)) GO TO 20224
      WW(IBAS-NVARS)=WW(IBAS-NVARS)-XVAL
      GO TO 20225
20224 WW(IBAS-NVARS)=WW(IBAS-NVARS)+XVAL
20225 CONTINUE
20226 CONTINUE
20217 CONTINUE
20213 CONTINUE
20214 GO TO 20206
C
C   COMPUTE NORM OF DIFFERENCE AND CHECK FOR FEASIBILITY.
20208 RESNRM=DASUM(MRELAS,WW,1)
      FEAS=RESNRM.LE.TOLLS*(RPRNRM*ANORM+RHSNRM)
C
C     TRY AN ABSOLUTE ERROR TEST IF THE RELATIVE TEST FAILS.
      IF(.NOT. FEAS)FEAS=RESNRM.LE.TOLABS
      IF (.NOT.(FEAS)) GO TO 20227
      PRIMAL(NVARS+1)=ZERO
      CALL DCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1)
20227 CONTINUE
31008 GO TO NPR008, (20024,20032,20040)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (INITIALIZE REDUCED COSTS AND STEEPEST EDGE WEIGHTS)
30014 CALL SPINCW(
     *MRELAS,NVARS,LMX,LBM,NPP,JSTRT,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *COSTSC,GG,ERDNRM,DULNRM,
     *AMAT,BASMAT,CSC,WR,WW,RZ,RG,COSTS,COLNRM,DUALS,
     *STPEDG)
C
31014 GO TO NPR014, (20135,20246)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (CHECK AND RETURN WITH EXCESS ITERATIONS)
30019 IF (.NOT.(ITLP.GT.MXITLP)) GO TO 20230
      NERR=25
      ASSIGN 20233 TO NPR011
      GO TO 30011
C++  CODE FOR OUTPUT=YES IS ACTIVE
20233 IF (.NOT.(KPRINT.GE.1)) GO TO 20234
      ASSIGN 20237 TO NPR012
      GO TO 30012
20237 CONTINUE
20234 CONTINUE
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
20235 IDUM(1)=0
      IF(SAVEDT) IDUM(1)=ISAVE
      CALL XERRWV('SPLP( ). MAX. ITERS. (I1) TAKEN. UP-TO-DATE RESULTS S
     *AVED ON FILE (I2). IF (I2)=0, NO SAVE.',72,NERR,IOPT,2,MXITLP,IDUM
     *,0,R1,R2)
      INFO=-NERR
      ASSIGN 20238 TO NPR001
      GO TO 30001
20238 CONTINUE
20230 CONTINUE
31019 GO TO 20155
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (REDECOMPOSE BASIS MATRIX AND TRY AGAIN)
30016 IF (.NOT.(.NOT.REDBAS)) GO TO 20239
      ASSIGN 20242 TO NPR004
      GO TO 30004
20242 ASSIGN 20243 TO NPR005
      GO TO 30005
20243 ASSIGN 20244 TO NPR006
      GO TO 30006
20244 ASSIGN 20245 TO NPR013
      GO TO 30013
20245 ASSIGN 20246 TO NPR014
      GO TO 30014
20246 CONTINUE
C
C     ERASE NON-CYCLING MARKERS NEAR COMPLETION.
20239 I=MRELAS+1
      N20247=MRELAS+NVARS
      GO TO 20248
20247 I=I+1
20248 IF ((N20247-I).LT.0) GO TO 20249
      IBASIS(I)=IDABS(IBASIS(I))
      GO TO 20247
20249 ASSIGN 20251 TO NPR015
      GO TO 30015
20251 CONTINUE
31016 GO TO 20145
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (COMPUTE NEW PRIMAL)
C
C     COPY RHS INTO WW(*), SOLVE SYSTEM.
30006 CALL DCOPY(MRELAS,RHS,1,WW,1)
      TRANS = .FALSE.
      CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
      CALL DCOPY(MRELAS,WW,1,RPRIM,1)
      RPRNRM=DASUM(MRELAS,RPRIM,1)
31006 GO TO NPR006, (20019,20031,20039,20244,20275)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (COMPUTE NEW DUALS)
C
C     SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*).
30013 I=1
      N20252=MRELAS
      GO TO 20253
20252 I=I+1
20253 IF ((N20252-I).LT.0) GO TO 20254
      J=IBASIS(I)
      IF (.NOT.(J.LE.NVARS)) GO TO 20256
      DUALS(I)=COSTSC*COSTS(J)*CSC(J) + XLAMDA*PRIMAL(I+NVARS)
      GO TO 20257
20256 DUALS(I)=XLAMDA*PRIMAL(I+NVARS)
20257 CONTINUE
20258 GO TO 20252
C
20254 TRANS=.TRUE.
      CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,DUALS,TRANS)
      DULNRM=DASUM(MRELAS,DUALS,1)
31013 GO TO NPR013, (20134,20245,20267)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (FIND VARIABLE TO ENTER BASIS AND GET SEARCH DIRECTION)
30015 CALL SPLPFE(
     *MRELAS,NVARS,LMX,LBM,IENTER,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ERDNRM,EPS,GG,DULNRM,DIRNRM,
     *AMAT,BASMAT,CSC,WR,WW,BL,BU,RZ,RG,COLNRM,DUALS,
     *FOUND)
31015 GO TO NPR015, (20141,20251)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS)
30017 CALL SPLPFL(
     *MRELAS,NVARS,IENTER,ILEAVE,
     *IBASIS,IND,IBB,
     *THETA,DIRNRM,RPRNRM,
     *CSC,WW,BL,BU,ERP,RPRIM,PRIMAL,
     *FINITE,ZEROLV)
31017 GO TO 20149
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (MAKE MOVE AND UPDATE)
30018 CALL SPLPMU(
     *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IENTER,ILEAVE,IOPT,NPP,JSTRT,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ANORM,EPS,UU,GG,RPRNRM,ERDNRM,DULNRM,THETA,COSTSC,XLAMDA,RHSNRM,
     *AMAT,BASMAT,CSC,WR,RPRIM,WW,BU,BL,RHS,ERD,ERP,RZ,RG,COLNRM,COSTS,
     *PRIMAL,DUALS,SINGLR,REDBAS,ZEROLV,STPEDG)
      IF (.NOT.(INFO.EQ.(-26))) GO TO 20259
      ASSIGN 20262 TO NPR001
      GO TO 30001
20262 CONTINUE
C++  CODE FOR OUTPUT=YES IS ACTIVE
20259 IF (.NOT.(KPRINT.GE.2)) GO TO 20263
      GO TO 30021
20266 CONTINUE
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
20263 CONTINUE
31018 GO TO 20153
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE(RESCALE AND REARRANGE VARIABLES)
C
C     RESCALE THE DUAL VARIABLES.
30011 ASSIGN 20267 TO NPR013
      GO TO 30013
20267 IF (.NOT.(COSTSC.NE.ZERO)) GO TO 20268
      I=1
      N20271=MRELAS
      GO TO 20272
20271 I=I+1
20272 IF ((N20271-I).LT.0) GO TO 20273
      DUALS(I)=DUALS(I)/COSTSC
      GO TO 20271
20273 CONTINUE
20268 ASSIGN 20275 TO NPR006
      GO TO 30006
C
C     REAPPLY COLUMN SCALING TO PRIMAL.
20275 I=1
      N20276=MRELAS
      GO TO 20277
20276 I=I+1
20277 IF ((N20276-I).LT.0) GO TO 20278
      J=IBASIS(I)
      IF (.NOT.(J.LE.NVARS)) GO TO 20280
      SCALR=CSC(J)
      IF(IND(J).EQ.2)SCALR=-SCALR
      RPRIM(I)=RPRIM(I)*SCALR
20280 GO TO 20276
C
C     REPLACE TRANSLATED BASIC VARIABLES INTO ARRAY PRIMAL(*)
20278 PRIMAL(1)=ZERO
      CALL DCOPY(NVARS+MRELAS,PRIMAL,0,PRIMAL,1)
      J=1
      N20283=NVARS+MRELAS
      GO TO 20284
20283 J=J+1
20284 IF ((N20283-J).LT.0) GO TO 20285
      IBAS=IDABS(IBASIS(J))
      XVAL=ZERO
      IF (J.LE.MRELAS) XVAL=RPRIM(J)
      IF (IND(IBAS).EQ.1) XVAL=XVAL+BL(IBAS)
      IF (IND(IBAS).EQ.2) XVAL=BU(IBAS)-XVAL
      IF (.NOT.(IND(IBAS).EQ.3)) GO TO 20287
      IF (MOD(IBB(IBAS),2).EQ.0) XVAL=BU(IBAS)-BL(IBAS)-XVAL
      XVAL = XVAL+BL(IBAS)
20287 PRIMAL(IBAS)=XVAL
      GO TO 20283
C
C     COMPUTE DUALS FOR INDEPENDENT VARIABLES WITH BOUNDS.
C     OTHER ENTRIES ARE ZERO.
20285 J=1
      N20290=NVARS
      GO TO 20291
20290 J=J+1
20291 IF ((N20290-J).LT.0) GO TO 20292
      RZJ=ZERO
      IF (.NOT.(IBB(J).GT.ZERO .AND. IND(J).NE.4)) GO TO 20294
      RZJ=COSTS(J)
      I=0
20297 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.LE.0)) GO TO 20299
      GO TO 20298
20299 CONTINUE
20300 RZJ=RZJ-AIJ*DUALS(I)
      GO TO 20297
20298 CONTINUE
20294 DUALS(MRELAS+J)=RZJ
      GO TO 20290
20292 CONTINUE
31011 GO TO NPR011, (20051,20233)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C++  CODE FOR OUTPUT=YES IS ACTIVE
C     PROCEDURE (PRINT PROLOGUE)
30003 IDUM(1)=MRELAS
      CALL IVOUT(1,IDUM,'(''1NUM. OF DEPENDENT VARS., MRELAS'')',IDG)
      IDUM(1)=NVARS
      CALL IVOUT(1,IDUM,'('' NUM. OF INDEPENDENT VARS., NVARS'')',IDG)
      CALL IVOUT(1,IDUM,'('' DIMENSION OF COSTS(*)='')',IDG)
      IDUM(1)=NVARS+MRELAS
      CALL IVOUT(1,IDUM, '('' DIMENSIONS OF BL(*),BU(*),IND(*)''
     */'' PRIMAL(*),DUALS(*) ='')',IDG)
      CALL IVOUT(1,IDUM,'('' DIMENSION OF IBASIS(*)='')',IDG)
      IDUM(1)=LPRG+1
      CALL IVOUT(1,IDUM,'('' DIMENSION OF PRGOPT(*)='')',IDG)
      CALL IVOUT(0,IDUM,
     * '('' 1-NVARS=INDEPENDENT VARIABLE INDICES.''/
     * '' (NVARS+1)-(NVARS+MRELAS)=DEPENDENT VARIABLE INDICES.''/
     * '' CONSTRAINT INDICATORS ARE 1-4 AND MEAN'')',IDG)
      CALL IVOUT(0,IDUM,
     * '('' 1=VARIABLE HAS ONLY LOWER BOUND.''/
     * '' 2=VARIABLE HAS ONLY UPPER BOUND.''/
     * '' 3=VARIABLE HAS BOTH BOUNDS.''/
     * '' 4=VARIABLE HAS NO BOUNDS; IT IS FREE.'')',IDG)
      CALL DVOUT(NVARS,COSTS,'('' ARRAY OF COSTS'')',IDG)
      CALL IVOUT(NVARS+MRELAS,IND,
     * '('' CONSTRAINT INDICATORS'')',IDG)
      CALL DVOUT(NVARS+MRELAS,BL,
     *'('' LOWER BOUNDS FOR VARIABLES  (IGNORE UNUSED ENTRIES.)'')',IDG)
      CALL DVOUT(NVARS+MRELAS,BU,
     *'('' UPPER BOUNDS FOR VARIABLES  (IGNORE UNUSED ENTRIES.)'')',IDG)
      IF (.NOT.(KPRINT.GE.2)) GO TO 20302
      CALL IVOUT(0,IDUM,
     * '(''0NON-BASIC INDICES THAT ARE NEGATIVE SHOW VARIABLES''
     * '' EXCHANGED AT A ZERO''/'' STEP LENGTH'')',IDG)
      CALL IVOUT(0,IDUM,
     * '('' WHEN COL. NO. LEAVING=COL. NO. ENTERING, THE ENTERING ''
     * ''VARIABLE MOVED''/'' TO ITS BOUND.  IT REMAINS NON-BASIC.''/
     * '' WHEN COL. NO. OF BASIS EXCHANGED IS NEGATIVE, THE LEAVING''/
     * '' VARIABLE IS AT ITS UPPER BOUND.'')',IDG)
20302 CONTINUE
31003 GO TO 20011
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (PRINT SUMMARY)
30012 IDUM(1)=INFO
      CALL IVOUT(1,IDUM,'('' THE OUTPUT VALUE OF INFO IS'')',IDG)
      IF (.NOT.(MINPRB)) GO TO 20305
      CALL IVOUT(0,IDUM,'('' THIS IS A MINIMIZATION PROBLEM.'')',IDG)
      GO TO 20306
20305 CALL IVOUT(0,IDUM,'('' THIS IS A MAXIMIZATION PROBLEM.'')',IDG)
20306 IF (.NOT.(STPEDG)) GO TO 20308
      CALL IVOUT(0,IDUM,'('' STEEPEST EDGE PRICING WAS USED.'')',IDG)
      GO TO 20309
20308 CALL IVOUT(0,IDUM,'('' MINIMUM REDUCED COST PRICING WAS USED.'')',
     * IDG)
20309 RDUM(1)=DDOT(NVARS,COSTS,1,PRIMAL,1)
      CALL DVOUT(1,RDUM,
     * '('' OUTPUT VALUE OF THE OBJECTIVE FUNCTION'')',IDG)
      CALL DVOUT(NVARS+MRELAS,PRIMAL,
     * '('' THE OUTPUT INDEPENDENT AND DEPENDENT VARIABLES'')',IDG)
      CALL DVOUT(MRELAS+NVARS,DUALS,
     * '('' THE OUTPUT DUAL VARIABLES'')',IDG)
      CALL IVOUT(NVARS+MRELAS,IBASIS,
     * '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG)
      IDUM(1)=ITLP
      CALL IVOUT(1,IDUM,'('' NO. OF ITERATIONS'')',IDG)
      IDUM(1)=NREDC
      CALL IVOUT(1,IDUM,'('' NO. OF FULL REDECOMPS'')',IDG)
31012 GO TO NPR012, (20096,20237)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (PRINT ITERATION SUMMARY)
30021 IDUM(1)=ITLP+1
      CALL IVOUT(1,IDUM,'(''0ITERATION NUMBER'')',IDG)
      IDUM(1)=IBASIS(IDABS(ILEAVE))
      CALL IVOUT(1,IDUM,
     * '('' INDEX OF VARIABLE ENTERING THE BASIS'')',IDG)
      IDUM(1)=ILEAVE
      CALL IVOUT(1,IDUM,'('' COLUMN OF THE BASIS EXCHANGED'')',IDG)
      IDUM(1)=IBASIS(IENTER)
      CALL IVOUT(1,IDUM,
     * '('' INDEX OF VARIABLE LEAVING THE BASIS'')',IDG)
      RDUM(1)=THETA
      CALL DVOUT(1,RDUM,'('' LENGTH OF THE EXCHANGE STEP'')',IDG)
      IF (.NOT.(KPRINT.GE.3)) GO TO 20311
      CALL DVOUT(MRELAS,RPRIM,'('' BASIC (INTERNAL) PRIMAL SOLN.'')',
     * IDG)
      CALL IVOUT(NVARS+MRELAS,IBASIS,
     * '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG)
      CALL IVOUT(NVARS+MRELAS,IBB,'('' IBB ARRAY'')',IDG)
      CALL DVOUT(MRELAS,RHS,'('' TRANSLATED RHS'')',IDG)
      CALL DVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG)
20311 CONTINUE
31021 GO TO 20266
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (RETURN TO USER)
30001 IF (.NOT.(SAVEDT)) GO TO 20314
      GO TO 30020
20317 CONTINUE
20314 IF(IMAT(LMX-1).NE.(-1)) CALL CLOSM(IPAGEF)
C
C     THIS TEST IS THERE ONLY TO AVOID DIAGNOSTICS ON SOME FORTRAN
C     COMPILERS.
      IF(.TRUE.) RETURN
31001 GO TO NPR001, (20002,20007,20012,20017,20028,20097,20171,20205,202
     *38,20262)
      END
      SUBROUTINE SPLPMU(
     *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IENTER,ILEAVE,IOPT,NPP,JSTRT,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ANORM,EPS,UU,GG,RPRNRM,ERDNRM,DULNRM,THETA,COSTSC,XLAMDA,RHSNRM,
     *AMAT,BASMAT,CSC,WR,RPRIM,WW,BU,BL,RHS,ERD,ERP,RZ,RG,COLNRM,COSTS,
     *PRIMAL,DUALS,SINGLR,REDBAS,ZEROLV,STPEDG)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  SPLPMU
C***REFER TO  SPLP
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/,/DABS(/DDABS(/,/DMAX1/DMAX1/,
C     /DASUM/DASUM/,/DCOPY/DCOPY/,/DDOT/DDOT/,
C     /.E0/.D0/
C
C     THIS SUBPROGRAM IS FROM THE SPLP( ) PACKAGE.  IT PERFORMS THE
C     TASKS OF UPDATING THE PRIMAL SOLUTION, EDGE WEIGHTS, REDUCED
C     COSTS, AND MATRIX DECOMPOSITION.
C     IT IS THE MAIN PART OF THE PROCEDURE (MAKE MOVE AND UPDATE).
C
C     REVISED 821122-1100
C     REVISED YYMMDD
C***ROUTINES CALLED  IPLOC,LA05BS,LA05CS,PNNZRS,PRWPGE,DASUM,DCOPY,
C                    DDOT,SPLPDM,XERROR
C***COMMON BLOCKS    LA05DS
C***END PROLOGUE  SPLPMU
      INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*)
      DOUBLE PRECISION AIJ,ALPHA,ANORM,COSTSC,ERDNRM,DULNRM,EPS,GAMMA,
     * GG,GQ,ONE,RPRNRM,RZJ,SCALR,SMALL,THETA,TWO,UU,WP,XLAMDA,RHSNRM,
     * ZERO,AMAT(*),BASMAT(*),CSC(*),WR(*),RPRIM(*),WW(*),BU(*),BL(*),
     * RHS(*),ERD(*),ERP(*),RZ(*),RG(*),COSTS(*),PRIMAL(*),DUALS(*),
     * COLNRM(*),RCOST,DASUM,DDOT
      LOGICAL SINGLR,REDBAS,PAGEPL,TRANS,ZEROLV,STPEDG
C
C     COMMON BLOCK USED BY LA05 () PACKAGE..
      COMMON/LA05DS/SMALL,LP,LENL,LENU,NCP,LROW,LCOL
C
C***FIRST EXECUTABLE STATEMENT  SPLPMU
      ZERO=0.D0
      ONE=1.D0
      TWO=2.D0
      LPG=LMX-(NVARS+4)
C
C     UPDATE THE PRIMAL SOLUTION WITH A MULTIPLE OF THE SEARCH
C     DIRECTION.
      I=1
      N20002=MRELAS
      GO TO 20003
20002 I=I+1
20003 IF ((N20002-I).LT.0) GO TO 20004
      RPRIM(I)=RPRIM(I)-THETA*WW(I)
      GO TO 20002
C
C     IF EJECTED VARIABLE IS LEAVING AT AN UPPER BOUND,  THEN
C     TRANSLATE RIGHT HAND SIDE.
20004 IF (.NOT.(ILEAVE.LT.0)) GO TO 20006
      IBAS=IBASIS(IDABS(ILEAVE))
      SCALR=RPRIM(IDABS(ILEAVE))
      ASSIGN 20009 TO NPR001
      GO TO 30001
20009 IBB(IBAS)=IDABS(IBB(IBAS))+1
C
C     IF ENTERING VARIABLE IS RESTRICTED TO ITS UPPER BOUND, TRANSLATE
C     RIGHT HAND SIDE.  IF THE VARIABLE DECREASED FROM ITS UPPER
C     BOUND, A SIGN CHANGE IS REQUIRED IN THE TRANSLATION.
20006 IF (.NOT.(IENTER.EQ.ILEAVE)) GO TO 20010
      IBAS=IBASIS(IENTER)
      SCALR=THETA
      IF (MOD(IBB(IBAS),2).EQ.0) SCALR=-SCALR
      ASSIGN 20013 TO NPR001
      GO TO 30001
20013 IBB(IBAS)=IBB(IBAS)+1
      GO TO 20011
20010 IBAS=IBASIS(IENTER)
C
C     IF ENTERING VARIABLE IS DECREASING FROM ITS UPPER BOUND,
C     COMPLEMENT ITS PRIMAL VALUE.
      IF (.NOT.(IND(IBAS).EQ.3.AND.MOD(IBB(IBAS),2).EQ.0)) GO TO 20014
      SCALR=-(BU(IBAS)-BL(IBAS))
      IF (IBAS.LE.NVARS) SCALR=SCALR/CSC(IBAS)
      ASSIGN 20017 TO NPR001
      GO TO 30001
20017 THETA=-SCALR-THETA
      IBB(IBAS)=IBB(IBAS)+1
20014 CONTINUE
20015 RPRIM(IDABS(ILEAVE))=THETA
      IBB(IBAS)=-IDABS(IBB(IBAS))
      I=IBASIS(IDABS(ILEAVE))
      IBB(I)=IDABS(IBB(I))
      IF(PRIMAL(IDABS(ILEAVE)+NVARS).GT.ZERO) IBB(I)=IBB(I)+1
C
C     INTERCHANGE COLUMN POINTERS TO NOTE EXCHANGE OF COLUMNS.
20011 IBAS=IBASIS(IENTER)
      IBASIS(IENTER)=IBASIS(IDABS(ILEAVE))
      IBASIS(IDABS(ILEAVE))=IBAS
C
C     IF VARIABLE WAS EXCHANGED AT A ZERO LEVEL, MARK IT SO THAT
C     IT CAN'T BE BROUGHT BACK IN.  THIS IS TO HELP PREVENT CYCLING.
      IF(ZEROLV) IBASIS(IENTER)=-IDABS(IBASIS(IENTER))
      RPRNRM=DMAX1(RPRNRM,DASUM(MRELAS,RPRIM,1))
      K=1
      N20018=MRELAS
      GO TO 20019
20018 K=K+1
20019 IF ((N20018-K).LT.0) GO TO 20020
C
C     SEE IF VARIABLES THAT WERE CLASSIFIED AS INFEASIBLE HAVE NOW
C     BECOME FEASIBLE.  THIS MAY REQUIRED TRANSLATING UPPER BOUNDED
C     VARIABLES.
      IF (.NOT.(PRIMAL(K+NVARS).NE.ZERO .AND.
     *          DABS(RPRIM(K)).LE.RPRNRM*ERP(K))) GO TO 20022
      IF (.NOT.(PRIMAL(K+NVARS).GT.ZERO)) GO TO 20025
      IBAS=IBASIS(K)
      SCALR=-(BU(IBAS)-BL(IBAS))
      IF(IBAS.LE.NVARS)SCALR=SCALR/CSC(IBAS)
      ASSIGN 20028 TO NPR001
      GO TO 30001
20028 RPRIM(K)=-SCALR
      RPRNRM=RPRNRM-SCALR
20025 PRIMAL(K+NVARS)=ZERO
20022 CONTINUE
20023 GO TO 20018
C
C     UPDATE REDUCED COSTS, EDGE WEIGHTS, AND MATRIX DECOMPOSITION.
20020 IF (.NOT.(IENTER.NE.ILEAVE)) GO TO 20029
C
C     THE INCOMING VARIABLE IS ALWAYS CLASSIFIED AS FEASIBLE.
      PRIMAL(IDABS(ILEAVE)+NVARS)=ZERO
C
      WP=WW(IDABS(ILEAVE))
      GQ=DDOT(MRELAS,WW,1,WW,1)+ONE
C
C     COMPUTE INVERSE (TRANSPOSE) TIMES SEARCH DIRECTION.
      TRANS=.TRUE.
      CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
C
C     UPDATE THE MATRIX DECOMPOSITION.  COL. IDABS(ILEAVE) IS LEAVING.
C     THE ARRAY DUALS(*) CONTAINS INTERMEDIATE RESULTS FOR THE
C     INCOMING COLUMN.
      CALL LA05CS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,DUALS,GG,UU,
     * IDABS(ILEAVE))
      REDBAS=.FALSE.
      IF (.NOT.(GG.LT.ZERO)) GO TO 20032
C
C     REDECOMPOSE BASIS MATRIX WHEN AN ERROR RETURN FROM
C     LA05CS( ) IS NOTED.  THIS WILL PROBABLY BE DUE TO
C     SPACE BEING EXHAUSTED, GG=-7.
      CALL SPLPDM(
     *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IOPT,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ANORM,EPS,UU,GG,
     *AMAT,BASMAT,CSC,WR,
     *SINGLR,REDBAS)
      IF (.NOT.(SINGLR)) GO TO 20035
      NERR=26
      CALL XERROR(  'SPLP( ). MOVED TO A SINGULAR POINT. THIS SHOULD NOT
     * HAPPEN.',59,NERR,IOPT)
      INFO=-NERR
      RETURN
20035 CONTINUE
      GO TO 30002
20038 CONTINUE
20032 CONTINUE
C
C     IF STEEPEST EDGE PRICING IS USED, UPDATE REDUCED COSTS
C     AND EDGE WEIGHTS.
20033 IF (.NOT.(STPEDG)) GO TO 20039
C
C     COMPUTE COL. IDABS(ILEAVE) OF THE NEW INVERSE (TRANSPOSE) MATRIX
C     HERE IDABS(ILEAVE) POINTS TO THE EJECTED COLUMN.
C     USE ERD(*) FOR TEMP. STORAGE.
      CALL DCOPY(MRELAS,ZERO,0,ERD,1)
      ERD(IDABS(ILEAVE))=ONE
      TRANS=.TRUE.
      CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,ERD,TRANS)
C
C     COMPUTE UPDATED DUAL VARIABLES IN DUALS(*).
      ASSIGN 20042 TO NPR003
      GO TO 30003
C
C     COMPUTE THE DOT PRODUCT OF COL. J OF THE NEW INVERSE (TRANSPOSE)
C     WITH EACH NON-BASIC COLUMN.  ALSO COMPUTE THE DOT PRODUCT OF THE
C     INVERSE (TRANSPOSE) OF NON-UPDATED MATRIX (TIMES) THE
C     SEARCH DIRECTION WITH EACH NON-BASIC COLUMN.
C     RECOMPUTE REDUCED COSTS.
20042 PAGEPL=.TRUE.
      CALL DCOPY(NVARS+MRELAS,ZERO,0,RZ,1)
      NNEGRC=0
      J=JSTRT
20043 IF (.NOT.(IBB(J).LE.0)) GO TO 20045
      PAGEPL=.TRUE.
      RG(J)=ONE
      GO TO 20046
C
C     NONBASIC INDEPENDENT VARIABLES (COLUMN IN SPARSE MATRIX STORAGE)
20045 IF (.NOT.(J.LE.NVARS)) GO TO 20048
      RZJ=COSTS(J)*COSTSC
      ALPHA=ZERO
      GAMMA=ZERO
C
C     COMPUTE THE DOT PRODUCT OF THE SPARSE MATRIX NONBASIC COLUMNS
C     WITH THREE VECTORS INVOLVED IN THE UPDATING STEP.
      IF (.NOT.(J.EQ.1)) GO TO 20051
      ILOW=NVARS+5
      GO TO 20052
20051 ILOW=IMAT(J+3)+1
20052 IF (.NOT.(PAGEPL)) GO TO 20054
      IL1=IPLOC(ILOW,AMAT,IMAT)
      IF (.NOT.(IL1.GE.LMX-1)) GO TO 20057
      ILOW=ILOW+2
      IL1=IPLOC(ILOW,AMAT,IMAT)
20057 CONTINUE
20058 IPAGE=IDABS(IMAT(LMX-1))
      GO TO 20055
20054 IL1=IHI+1
20055 IHI=IMAT(J+4)-(ILOW-IL1)
20060 IU1=MIN0(LMX-2,IHI)
      IF (.NOT.(IL1.GT.IU1)) GO TO 20062
      GO TO 20061
20062 CONTINUE
20063 DO 10 I=IL1,IU1
      RZJ=RZJ-AMAT(I)*DUALS(IMAT(I))
      ALPHA=ALPHA+AMAT(I)*ERD(IMAT(I))
      GAMMA=GAMMA+AMAT(I)*WW(IMAT(I))
10    CONTINUE
      IF (.NOT.(IHI.LE.LMX-2)) GO TO 20065
      GO TO 20061
20065 CONTINUE
20066 IPAGE=IPAGE+1
      KEY=1
      CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT)
      IL1=NVARS+5
      IHI=IHI-LPG
      GO TO 20060
20061 PAGEPL=IHI.EQ.(LMX-2)
      RZ(J)=RZJ*CSC(J)
      ALPHA=ALPHA*CSC(J)
      GAMMA=GAMMA*CSC(J)
      RG(J)=DMAX1(RG(J)-TWO*ALPHA*GAMMA+ALPHA**2*GQ,ONE+ALPHA**2)
C
C     NONBASIC DEPENDENT VARIABLES (COLUMNS DEFINED IMPLICITLY)
      GO TO 20049
20048 PAGEPL=.TRUE.
      SCALR=-ONE
      IF(IND(J).EQ.2) SCALR=ONE
      I=J-NVARS
      ALPHA=SCALR*ERD(I)
      RZ(J)=-SCALR*DUALS(I)
      GAMMA=SCALR*WW(I)
      RG(J)=DMAX1(RG(J)-TWO*ALPHA*GAMMA+ALPHA**2*GQ,ONE+ALPHA**2)
20049 CONTINUE
20050 CONTINUE
20046 CONTINUE
C
20047 RCOST=RZ(J)
      IF (MOD(IBB(J),2).EQ.0) RCOST=-RCOST
      IF (.NOT.(IND(J).EQ.3)) GO TO 20068
      IF(BU(J).EQ.BL(J)) RCOST=ZERO
20068 CONTINUE
20069 IF (IND(J).EQ.4) RCOST=-DABS(RCOST)
      CNORM=ONE
      IF (J.LE.NVARS) CNORM=COLNRM(J)
      IF (RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO) NNEGRC=NNEGRC+1
      J=MOD(J,MRELAS+NVARS)+1
      IF (.NOT.(NNEGRC.GE.NPP .OR. J.EQ.JSTRT)) GO TO 20071
      GO TO 20044
20071 CONTINUE
20072 GO TO 20043
20044 JSTRT=J
C
C     UPDATE THE EDGE WEIGHT FOR THE EJECTED VARIABLE.
      RG(IDABS(IBASIS(IENTER)))= GQ/WP**2
C
C     IF MINIMUM REDUCED COST (DANTZIG) PRICING IS USED,
C     CALCULATE THE NEW REDUCED COSTS.
      GO TO 20040
C
C     COMPUTE THE UPDATED DUALS IN DUALS(*).
20039 ASSIGN 20074 TO NPR003
      GO TO 30003
20074 CALL DCOPY(NVARS+MRELAS,ZERO,0,RZ,1)
      NNEGRC=0
      J=JSTRT
      PAGEPL=.TRUE.
C
20075 IF (.NOT.(IBB(J).LE.0)) GO TO 20077
      PAGEPL=.TRUE.
      GO TO 20078
C
C     NONBASIC INDEPENDENT VARIABLE (COLUMN IN SPARSE MATRIX STORAGE)
20077 IF (.NOT.(J.LE.NVARS)) GO TO 20080
      RZ(J)=COSTS(J)*COSTSC
      IF (.NOT.(J.EQ.1)) GO TO 20083
      ILOW=NVARS+5
      GO TO 20084
20083 ILOW=IMAT(J+3)+1
20084 CONTINUE
20085 IF (.NOT.(PAGEPL)) GO TO 20086
      IL1=IPLOC(ILOW,AMAT,IMAT)
      IF (.NOT.(IL1.GE.LMX-1)) GO TO 20089
      ILOW=ILOW+2
      IL1=IPLOC(ILOW,AMAT,IMAT)
20089 CONTINUE
20090 IPAGE=IDABS(IMAT(LMX-1))
      GO TO 20087
20086 IL1=IHI+1
20087 CONTINUE
20088 IHI=IMAT(J+4)-(ILOW-IL1)
20092 IU1=MIN0(LMX-2,IHI)
      IF (.NOT.(IU1.GE.IL1 .AND.MOD(IU1-IL1,2).EQ.0)) GO TO 20094
      RZ(J)=RZ(J)-AMAT(IL1)*DUALS(IMAT(IL1))
      IL1=IL1+1
20094 CONTINUE
20095 IF (.NOT.(IL1.GT.IU1)) GO TO 20097
      GO TO 20093
20097 CONTINUE
C
C     UNROLL THE DOT PRODUCT LOOP TO A DEPTH OF TWO.  (THIS IS DONE
C     FOR INCREASED EFFICIENCY).
20098 DO 40 I=IL1,IU1,2
      RZ(J)=RZ(J)-AMAT(I)*DUALS(IMAT(I))-AMAT(I+1)*DUALS(IMAT(I+1))
40    CONTINUE
      IF (.NOT.(IHI.LE.LMX-2)) GO TO 20100
      GO TO 20093
20100 CONTINUE
20101 IPAGE=IPAGE+1
      KEY=1
      CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT)
      IL1=NVARS+5
      IHI=IHI-LPG
      GO TO 20092
20093 PAGEPL=IHI.EQ.(LMX-2)
      RZ(J)=RZ(J)*CSC(J)
C
C     NONBASIC DEPENDENT VARIABLES (COLUMNS DEFINED IMPLICITLY)
      GO TO 20081
20080 PAGEPL=.TRUE.
      SCALR=-ONE
      IF(IND(J).EQ.2) SCALR=ONE
      I=J-NVARS
      RZ(J)=-SCALR*DUALS(I)
20081 CONTINUE
20082 CONTINUE
20078 CONTINUE
C
20079 RCOST=RZ(J)
      IF (MOD(IBB(J),2).EQ.0) RCOST=-RCOST
      IF (.NOT.(IND(J).EQ.3)) GO TO 20103
      IF(BU(J).EQ.BL(J)) RCOST=ZERO
20103 CONTINUE
20104 IF (IND(J).EQ.4) RCOST=-DABS(RCOST)
      CNORM=ONE
      IF (J.LE.NVARS) CNORM=COLNRM(J)
      IF (RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO) NNEGRC=NNEGRC+1
      J=MOD(J,MRELAS+NVARS)+1
      IF (.NOT.(NNEGRC.GE.NPP .OR. J.EQ.JSTRT)) GO TO 20106
      GO TO 20076
20106 CONTINUE
20107 GO TO 20075
20076 JSTRT=J
20040 CONTINUE
20041 GO TO 20030
C
C     THIS IS NECESSARY ONLY FOR PRINTING OF INTERMEDIATE RESULTS.
20029 ASSIGN 20109 TO NPR003
      GO TO 30003
20109 CONTINUE
20030 RETURN
C     PROCEDURE (TRANSLATE RIGHT HAND SIDE)
C
C     PERFORM THE TRANSLATION ON THE RIGHT-HAND SIDE.
30001 IF (.NOT.(IBAS.LE.NVARS)) GO TO 20110
      I=0
20113 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,IBAS)
      IF (.NOT.(I.LE.0)) GO TO 20115
      GO TO 20114
20115 CONTINUE
20116 RHS(I)=RHS(I)-SCALR*AIJ*CSC(IBAS)
      GO TO 20113
20114 GO TO 20111
20110 I=IBAS-NVARS
      IF (.NOT.(IND(IBAS).EQ.2)) GO TO 20118
      RHS(I)=RHS(I)-SCALR
      GO TO 20119
20118 RHS(I)=RHS(I)+SCALR
20119 CONTINUE
20120 CONTINUE
20111 CONTINUE
20112 RHSNRM=DMAX1(RHSNRM,DASUM(MRELAS,RHS,1))
      GO TO NPR001, (20009,20013,20017,20028)
C     PROCEDURE (COMPUTE NEW PRIMAL)
C
C     COPY RHS INTO WW(*), SOLVE SYSTEM.
30002 CALL DCOPY(MRELAS,RHS,1,WW,1)
      TRANS = .FALSE.
      CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
      CALL DCOPY(MRELAS,WW,1,RPRIM,1)
      RPRNRM=DASUM(MRELAS,RPRIM,1)
      GO TO 20038
C     PROCEDURE (COMPUTE NEW DUALS)
C
C     SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*).
30003 I=1
      N20121=MRELAS
      GO TO 20122
20121 I=I+1
20122 IF ((N20121-I).LT.0) GO TO 20123
      J=IBASIS(I)
      IF (.NOT.(J.LE.NVARS)) GO TO 20125
      DUALS(I)=COSTSC*COSTS(J)*CSC(J) + XLAMDA*PRIMAL(I+NVARS)
      GO TO 20126
20125 DUALS(I)=XLAMDA*PRIMAL(I+NVARS)
20126 CONTINUE
20127 GO TO 20121
C
20123 TRANS=.TRUE.
      CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,DUALS,TRANS)
      DULNRM=DASUM(MRELAS,DUALS,1)
      GO TO NPR003, (20042,20074,20109)
      END
      SUBROUTINE SPLPUP(USRMAT,MRELAS,NVARS,PRGOPT,DATTRV,
     *     BL,BU,IND,INFO,AMAT,IMAT,SIZEUP,ASMALL,ABIG)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  SPLPUP
C***REFER TO  SPLP
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/,/DABS(/DDABS(/.
C
C     REVISED 810613-1130
C     REVISED YYMMDD-HHMM
C
C     THIS SUBROUTINE COLLECTS INFORMATION ABOUT THE BOUNDS AND MATRIX
C     FROM THE USER.  IT IS PART OF THE SPLP( ) PACKAGE.
C***ROUTINES CALLED  PCHNGS,PNNZRS,XERROR,XERRWV
C***END PROLOGUE  SPLPUP
      DOUBLE PRECISION ABIG,AIJ,AMAT(*),AMN,AMX,ASMALL,BL(*),
     * BU(*),DATTRV(*),PRGOPT(*),R1,R2,XVAL,ZERO
      INTEGER IFLAG(10),IMAT(*),IND(*)
      LOGICAL SIZEUP,FIRST
C
C***FIRST EXECUTABLE STATEMENT  SPLPUP
      IOPT=1
      ZERO=0.D0
      GO TO 30001
20002 CONTINUE
      GO TO 30002
20003 IF (.NOT.(SIZEUP .AND. .NOT. FIRST)) GO TO 20004
      IF (.NOT.(AMN.LT.ASMALL .OR. AMX.GT.ABIG)) GO TO 20007
      NERR=22
      CALL XERROR( 'SPLP( ). A MATRIX ELEMENT''S SIZE IS OUT OF THE SPEC
     *IFIED RANGE.',63,NERR,IOPT)
      INFO=-NERR
      RETURN
20007 CONTINUE
20008 CONTINUE
20004 CONTINUE
C
20005 RETURN
C
C     PROCEDURE (CHECK USER-SUPPLIED BOUNDS)
C
C     CHECK THAT IND(*) VALUES ARE 1,2,3 OR 4.
C     ALSO CHECK CONSISTENCY OF UPPER AND LOWER BOUNDS.
30001 J=1
      N20010=NVARS
      GO TO 20011
20010 J=J+1
20011 IF ((N20010-J).LT.0) GO TO 20012
      IF (.NOT.(IND(J).LT.1 .OR. IND(J).GT.4)) GO TO 20014
      NERR=10
      CALL XERRWV('SPLP( ). INDEPENDENT VARIABLE (I1) IS NOT DEFINED.',
     *50,NERR,IOPT,1,J,I2,0,R1,R2)
      INFO=-NERR
      RETURN
20014 IF (.NOT.(IND(J).EQ.3)) GO TO 10001
      IF (.NOT.(BL(J).GT.BU(J))) GO TO 20017
      NERR=11
      CALL  XERRWV(   'SPLP( ).  LOWER BOUND (R1) AND UPPER BOUND (R2) F
     *OR INDEP. VARIABLE   (I1) ARE NOT CONSISTENT.', 94,NERR,IOPT,1,J,
     * I2, 2,BL(J),BU(J))
      INFO=-NERR
      RETURN
20017 CONTINUE
20018 CONTINUE
10001 CONTINUE
20015 GO TO 20010
20012 I=NVARS+1
      N20020=NVARS+MRELAS
      GO TO 20021
20020 I=I+1
20021 IF ((N20020-I).LT.0) GO TO 20022
      IF (.NOT.(IND(I).LT.1 .OR. IND(I).GT.4)) GO TO 20024
      NERR=12
      CALL XERRWV('SPLP( ). DEPENDENT VARIABLE (I1) IS NOT DEFINED.',
     * 48,NERR,IOPT,1,I-NVARS,I2,0,R1,R2)
      INFO=-NERR
      RETURN
20024 IF (.NOT.(IND(I).EQ.3)) GO TO 10002
      IF (.NOT.(BL(I).GT.BU(I))) GO TO 20027
      NERR=13
      CALL XERRWV(  'SPLP( ).  LOWER BOUND (R1) AND UPPER BOUND (R2) FOR
     * DEP. VARIABLE (I1) ARE NOT CONSISTENT.',90,NERR,IOPT,1,I,I2,2,
     * BL(I),BU(I))
      INFO=-NERR
      RETURN
20027 CONTINUE
20028 CONTINUE
10002 CONTINUE
20025 GO TO 20020
20022 CONTINUE
31001 GO TO 20002
C     PROCEDURE (GET UPDATES OR DATA FOR MATRIX FROM THE USER)
C
C     GET THE ELEMENTS OF THE MATRIX FROM THE USER.  IT WILL BE STORED
C     BY COLUMNS USING THE SPARSE STORAGE CODES OF RJ HANSON AND
C     JA WISNIEWSKI.
30002 IFLAG(1)=1
C
C     KEEP ACCEPTING ELEMENTS UNTIL THE USER IS FINISHED GIVING THEM.
C     LIMIT THIS LOOP TO 2*NVARS*MRELAS ITERATIONS.
      ITMAX=2*NVARS*MRELAS+1
      ITCNT=0
      FIRST=.TRUE.
C
C     CHECK ON THE ITERATION COUNT.
20030 ITCNT=ITCNT+1
      IF (.NOT.(ITCNT.GT.ITMAX)) GO TO 20032
      NERR=07
      CALL XERROR(  'SPLP( ). MORE THAN 2*NVARS*MRELAS ITERS. DEFINING O
     *R UPDATING MATRIX  DATA.',75,NERR,IOPT)
      INFO=-NERR
      RETURN
20032 AIJ=ZERO
      CALL USRMAT(I,J,AIJ,INDCAT,PRGOPT,DATTRV,IFLAG)
      IF (.NOT.(IFLAG(1).EQ.1)) GO TO 20035
      IFLAG(1)=2
      GO TO 20030
C
C     CHECK TO SEE THAT THE SUBSCRIPTS I AND J ARE VALID.
20035 IF (.NOT.(I.LT.1 .OR. I.GT.MRELAS .OR. J.LT.1 .OR. J.GT.NVARS)) GO
     * TO 20038
      IF (.NOT.(IFLAG(1).EQ.3)) GO TO 20041
      ASSIGN 20044 TO NPR003
      GO TO 30003
20044 GO TO 20031
20041 CONTINUE
20042 NERR=08
      CALL XERRWV(  'SPLP( ). ROW INDEX (I1) OR COLUMN INDEX (I2) IS OUT
     * OF RANGE.',61,NERR,IOPT,2,I,J,0,R1,R2)
      INFO=-NERR
      RETURN
C
C    IF INDCAT=0 THEN SET A(I,J)=AIJ.
C    IF INDCAT=1 THEN ACCUMULATE ELEMENT, A(I,J)=A(I,J)+AIJ.
20038 IF (.NOT.(INDCAT.EQ.0)) GO TO 20045
      CALL PCHNGS(I,AIJ,IPLACE,AMAT,IMAT,J)
      GO TO 20046
20045 IF (.NOT.(INDCAT.EQ.1)) GO TO 10003
      INDEX=-(I-1)
      CALL PNNZRS(INDEX,XVAL,IPLACE,AMAT,IMAT,J)
      IF (INDEX.EQ.I) AIJ=AIJ+XVAL
      CALL PCHNGS(I,AIJ,IPLACE,AMAT,IMAT,J)
      GO TO 20046
10003 NERR=09
      CALL XERRWV(  'SPLP( ). INDICATION FLAG (I1) FOR MATRIX DATA MUST
     *BE EITHER 0 OR 1.',68,NERR,IOPT,1,INDCAT,I2,0,R1,R2)
      INFO=-NERR
      RETURN
20046 ASSIGN 20048 TO NPR003
      GO TO 30003
20048 IF (.NOT.(IFLAG(1).EQ.3)) GO TO 20049
      GO TO 20031
20049 GO TO 20030
20031 CONTINUE
31002 GO TO 20003
C     PROCEDURE (CHECK ON SIZE OF MATRIX DATA)
C
C     RECORD THE LARGEST AND SMALLEST(IN MAGNITUDE) NONZERO ELEMENTS.
30003 IF (.NOT.(SIZEUP .AND. DABS(AIJ).NE.ZERO)) GO TO 20052
      IF (.NOT.(FIRST)) GO TO 20055
      AMX=DABS(AIJ)
      AMN=DABS(AIJ)
      IAMX=I
      JAMX=J
      IAMN=I
      JAMN=J
      FIRST=.FALSE.
      GO TO 20056
20055 IF (.NOT.(DABS(AIJ).GT.AMX)) GO TO 10004
      AMX=DABS(AIJ)
      IAMX=I
      JAMX=J
      GO TO 20056
10004 IF (.NOT.(DABS(AIJ).LT.AMN)) GO TO 10005
      AMN=DABS(AIJ)
      IAMN=I
      JAMN=J
10005 CONTINUE
20056 CONTINUE
20052 CONTINUE
20053 CONTINUE
31003 GO TO NPR003, (20044,20048)
      END
      SUBROUTINE SPOPT(PRGOPT,MRELAS,NVARS,INFO,CSC,IBASIS,ROPT,
     * INTOPT,LOPT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  SPOPT
C***REFER TO  SPLP
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/,/ABS(/DABS(/,/AMAX1/
C     DMAX1/,/SQRT/DDSQRT/,/R1MACH/D1MACH/,/AMIN1/DMIN1/,/D0/D0/
C
C     REVISED 821122-1045
C     REVISED YYMMDD-HHMM
C
C     THIS SUBROUTINE PROCESSES THE OPTION VECTOR, PRGOPT(*),
C     AND VALIDATES ANY MODIFIED DATA.
C***ROUTINES CALLED  D1MACH,XERROR
C***END PROLOGUE  SPOPT
      DOUBLE PRECISION ABIG,ASMALL,COSTSC,CSC(*),EPS,ONE,PRGOPT(*),
     * ROPT(07),TOLLS,TUNE,ZERO,ABS,DMIN1,DMAX1,D1MACH,DSQRT,TOLABS
      INTEGER IBASIS(*),INTOPT(08)
      LOGICAL CONTIN,USRBAS,SIZEUP,SAVEDT,COLSCP,CSTSCP,MINPRB,
     * STPEDG,LOPT(8)
C
C***FIRST EXECUTABLE STATEMENT  SPOPT
      IOPT=1
      ZERO=0.D0
      ONE=1.D0
      GO TO 30001
20002 CONTINUE
      GO TO 30002
C
20003 LOPT(1)=CONTIN
      LOPT(2)=USRBAS
      LOPT(3)=SIZEUP
      LOPT(4)=SAVEDT
      LOPT(5)=COLSCP
      LOPT(6)=CSTSCP
      LOPT(7)=MINPRB
      LOPT(8)=STPEDG
C
      INTOPT(1)=IDG
      INTOPT(2)=IPAGEF
      INTOPT(3)=ISAVE
      INTOPT(4)=MXITLP
      INTOPT(5)=KPRINT
      INTOPT(6)=ITBRC
      INTOPT(7)=NPP
      INTOPT(8)=LPRG
C
      ROPT(1)=EPS
      ROPT(2)=ASMALL
      ROPT(3)=ABIG
      ROPT(4)=COSTSC
      ROPT(5)=TOLLS
      ROPT(6)=TUNE
      ROPT(7)=TOLABS
      RETURN
C
C
C     PROCEDURE (INITIALIZE PARAMETERS AND PROCESS USER OPTIONS)
30001 CONTIN = .FALSE.
      USRBAS = .FALSE.
      SIZEUP = .FALSE.
      SAVEDT = .FALSE.
      COLSCP = .FALSE.
      CSTSCP = .FALSE.
      MINPRB = .TRUE.
      STPEDG = .TRUE.
C
C     GET THE MACHINE REL. FLOATING POINT ACCURACY VALUE FROM THE
C     PORT LIBRARY SUBPROGRAM, D1MACH( ).
      EPS=D1MACH(4)
      TOLLS=D1MACH(4)
      TUNE=ONE
      TOLABS=ZERO
C
C     DEFINE NOMINAL FILE NUMBERS FOR MATRIX PAGES AND DATA SAVING.
      IPAGEF=1
      ISAVE=2
      ITBRC=10
      MXITLP=3*(NVARS+MRELAS)
      KPRINT=0
      IDG=-4
      NPP=NVARS
      LPRG=0
C
      LAST = 1
      IADBIG=10000
      ICTMAX=1000
      ICTOPT= 0
20004 NEXT=PRGOPT(LAST)
      IF (.NOT.(NEXT.LE.0 .OR. NEXT.GT.IADBIG)) GO TO 20006
C
C     THE CHECKS FOR SMALL OR LARGE VALUES OF NEXT ARE TO PREVENT
C     WORKING WITH UNDEFINED DATA.
      NERR=14
      CALL XERROR('SPLP( ). THE USER OPTION ARRAY HAS UNDEFINED DATA.',
     * 50,NERR,IOPT)
      INFO=-NERR
      RETURN
20006 IF (.NOT.(NEXT.EQ.1)) GO TO 10001
      GO TO 20005
10001 IF (.NOT.(ICTOPT.GT.ICTMAX)) GO TO 10002
      NERR=15
      CALL XERROR('SPLP( ). OPTION ARRAY PROCESSING IS CYCLING.',
     *44,NERR,IOPT)
      INFO=-NERR
      RETURN
10002 CONTINUE
20007 KEY = PRGOPT(LAST+1)
C
C     IF KEY = 50, THIS IS TO BE A MAXIMIZATION PROBLEM
C     INSTEAD OF A MINIMIZATION PROBLEM.
      IF (.NOT.(KEY.EQ.50)) GO TO 20010
      MINPRB = PRGOPT(LAST+2).EQ.ZERO
      LDS=3
      GO TO 20009
20010 CONTINUE
C
C     IF KEY = 51, THE LEVEL OF OUTPUT IS BEING MODIFIED.
C     KPRINT = 0, NO OUTPUT
C            = 1, SUMMARY OUTPUT
C            = 2, LOTS OF OUTPUT
C            = 3, EVEN MORE OUTPUT
20011 IF (.NOT.(KEY.EQ.51)) GO TO 20013
      KPRINT=PRGOPT(LAST+2)
      LDS=3
      GO TO 20009
20013 CONTINUE
C
C     IF KEY = 52, REDEFINE THE FORMAT AND PRECISION USED
C     IN THE OUTPUT.
20014 IF (.NOT.(KEY.EQ.52)) GO TO 20016
      IF (PRGOPT(LAST+2).NE.ZERO) IDG=PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20016 CONTINUE
C
C     IF KEY = 53, THE ALLOTED SPACE FOR THE SPARSE MATRIX
C     STORAGE AND/OR SPARSE EQUATION SOLVING HAS BEEN CHANGED.
C     (PROCESSED IN SPLP(). THIS IS TO COMPUTE THE LENGTH OF PRGOPT(*).)
20017 IF (.NOT.(KEY.EQ.53)) GO TO 20019
      LDS=5
      GO TO 20009
20019 CONTINUE
C
C     IF KEY = 54, REDEFINE THE FILE NUMBER WHERE THE PAGES
C     FOR THE SPARSE MATRIX ARE STORED.
20020 IF (.NOT.(KEY.EQ.54)) GO TO 20022
      IF(PRGOPT(LAST+2).NE.ZERO) IPAGEF = PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20022 CONTINUE
C
C     IF KEY = 55,  A CONTINUATION FOR A PROBLEM MAY BE REQUESTED.
20023 IF (.NOT.(KEY .EQ. 55)) GO TO 20025
      CONTIN = PRGOPT(LAST+2).NE.ZERO
      LDS=3
      GO TO 20009
20025 CONTINUE
C
C     IF KEY = 56, REDEFINE THE FILE NUMBER WHERE THE SAVED DATA
C     WILL BE STORED.
20026 IF (.NOT.(KEY.EQ.56)) GO TO 20028
      IF(PRGOPT(LAST+2).NE.ZERO) ISAVE = PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20028 CONTINUE
C
C     IF KEY = 57, SAVE DATA (ON EXTERNAL FILE)  AT MXITLP ITERATIONS OR
C     THE OPTIMUM, WHICHEVER COMES FIRST.
20029 IF (.NOT.(KEY.EQ.57)) GO TO 20031
      SAVEDT=PRGOPT(LAST+2).NE.ZERO
      LDS=3
      GO TO 20009
20031 CONTINUE
C
C     IF KEY = 58,  SEE IF PROBLEM IS TO RUN ONLY A GIVEN
C     NUMBER OF ITERATIONS.
20032 IF (.NOT.(KEY.EQ.58)) GO TO 20034
      IF (PRGOPT(LAST+2).NE.ZERO) MXITLP = PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20034 CONTINUE
C
C     IF KEY = 59,  SEE IF USER PROVIDES THE BASIS INDICES.
20035 IF (.NOT.(KEY .EQ. 59)) GO TO 20037
      USRBAS = PRGOPT(LAST+2) .NE. ZERO
      IF (.NOT.(USRBAS)) GO TO 20040
      I=1
      N20043=MRELAS
      GO TO 20044
20043 I=I+1
20044 IF ((N20043-I).LT.0) GO TO 20045
      IBASIS(I) = PRGOPT(LAST+2+I)
      GO TO 20043
20045 CONTINUE
20040 CONTINUE
20041 LDS=MRELAS+3
      GO TO 20009
20037 CONTINUE
C
C     IF KEY = 60,  SEE IF USER HAS PROVIDED SCALING OF COLUMNS.
20038 IF (.NOT.(KEY .EQ. 60)) GO TO 20047
      COLSCP = PRGOPT(LAST+2).NE.ZERO
      IF (.NOT.(COLSCP)) GO TO 20050
      J=1
      N20053=NVARS
      GO TO 20054
20053 J=J+1
20054 IF ((N20053-J).LT.0) GO TO 20055
      CSC(J)=DABS(PRGOPT(LAST+2+J))
      GO TO 20053
20055 CONTINUE
20050 CONTINUE
20051 LDS=NVARS+3
      GO TO 20009
20047 CONTINUE
C
C     IF KEY = 61,  SEE IF USER HAS PROVIDED SCALING OF COSTS.
20048 IF (.NOT.(KEY .EQ. 61)) GO TO 20057
      CSTSCP = PRGOPT(LAST+2).NE.ZERO
      IF (CSTSCP) COSTSC = PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20057 CONTINUE
C
C     IF KEY = 62,  SEE IF SIZE PARAMETERS ARE PROVIDED WITH THE DATA.
C     THESE WILL BE CHECKED AGAINST THE MATRIX ELEMENT SIZES LATER.
20058 IF (.NOT.(KEY .EQ. 62)) GO TO 20060
      SIZEUP = PRGOPT(LAST+2).NE.ZERO
      IF (.NOT.(SIZEUP)) GO TO 20063
      ASMALL = PRGOPT(LAST+3)
      ABIG = PRGOPT(LAST+4)
20063 CONTINUE
20064 LDS=5
      GO TO 20009
20060 CONTINUE
C
C     IF KEY = 63, SEE IF TOLERANCE FOR LINEAR SYSTEM RESIDUAL ERROR IS
C     PROVIDED.
20061 IF (.NOT.(KEY .EQ. 63)) GO TO 20066
      IF (PRGOPT(LAST+2).NE.ZERO) TOLLS = DMAX1(EPS,PRGOPT(LAST+3))
      LDS=4
      GO TO 20009
20066 CONTINUE
C
C     IF KEY = 64,  SEE IF MINIMUM REDUCED COST OR STEEPEST EDGE
C     DESCENT IS TO BE USED FOR SELECTING VARIABLES TO ENTER BASIS.
20067 IF (.NOT.(KEY.EQ.64)) GO TO 20069
      STPEDG = PRGOPT(LAST+2).EQ.ZERO
      LDS=3
      GO TO 20009
20069 CONTINUE
C
C     IF KEY = 65, SET THE NUMBER OF ITERATIONS BETWEEN RECALCULATING
C     THE ERROR IN THE PRIMAL SOLUTION.
20070 IF (.NOT.(KEY.EQ.65)) GO TO 20072
      IF (PRGOPT(LAST+2).NE.ZERO) ITBRC=DMAX1(ONE,PRGOPT(LAST+3))
      LDS=4
      GO TO 20009
20072 CONTINUE
C
C     IF KEY = 66, SET THE NUMBER OF NEGATIVE REDUCED COSTS TO BE FOUND
C     IN THE PARTIAL PRICING STRATEGY.
20073 IF (.NOT.(KEY.EQ.66)) GO TO 20075
      IF (.NOT.(PRGOPT(LAST+2).NE.ZERO)) GO TO 20078
      NPP=DMAX1(PRGOPT(LAST+3),ONE)
      NPP=MIN0(NPP,NVARS)
20078 CONTINUE
20079 LDS=4
      GO TO 20009
20075 CONTINUE
C     IF KEY = 67, CHANGE THE TUNING PARAMETER TO APPLY TO THE ERROR
C     ESTIMATES FOR THE PRIMAL AND DUAL SYSTEMS.
20076 IF (.NOT.(KEY.EQ.67)) GO TO 20081
      IF (.NOT.(PRGOPT(LAST+2).NE.ZERO)) GO TO 20084
      TUNE=DABS(PRGOPT(LAST+3))
20084 CONTINUE
20085 LDS=4
      GO TO 20009
20081 CONTINUE
20082 IF (.NOT.(KEY.EQ.68)) GO TO 20087
      LDS=6
      GO TO 20009
20087 CONTINUE
C
C     RESET THE ABSOLUTE TOLERANCE TO BE USED ON THE FEASIBILITY
C     DECISION PROVIDED THE RELATIVE ERROR TEST FAILED.
20088 IF (.NOT.(KEY.EQ.69)) GO TO 20090
      IF(PRGOPT(LAST+2).NE.ZERO)TOLABS=PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20090 CONTINUE
20091 CONTINUE
C
20009 ICTOPT = ICTOPT+1
      LAST = NEXT
      LPRG=LPRG+LDS
      GO TO 20004
20005 CONTINUE
31001 GO TO 20002
C
C     PROCEDURE (VALIDATE OPTIONALLY MODIFIED DATA)
C
C     IF USER HAS DEFINED THE BASIS, CHECK FOR VALIDITY OF INDICES.
30002 IF (.NOT.(USRBAS)) GO TO 20093
      I=1
      N20096=MRELAS
      GO TO 20097
20096 I=I+1
20097 IF ((N20096-I).LT.0) GO TO 20098
      ITEST=IBASIS(I)
      IF (.NOT.(ITEST.LE.0 .OR.ITEST.GT.(NVARS+MRELAS))) GO TO 20100
      NERR=16
      CALL XERROR(  'SPLP( ). AN INDEX OF USER-SUPPLIED BASIS IS OUT OF
     *RANGE.',57,NERR,IOPT)
      INFO=-NERR
      RETURN
20100 CONTINUE
20101 GO TO 20096
20098 CONTINUE
20093 CONTINUE
C
C     IF USER HAS PROVIDED SIZE PARAMETERS, MAKE SURE THEY ARE ORDERED
C     AND POSITIVE.
20094 IF (.NOT.(SIZEUP)) GO TO 20103
      IF (.NOT.(ASMALL.LE.ZERO .OR. ABIG.LT.ASMALL)) GO TO 20106
      NERR=17
      CALL XERROR(   'SPLP( ). SIZE PARAMETERS FOR MATRIX MUST BE SMALLE
     *ST AND LARGEST      MAGNITUDES OF NONZERO ENTRIES.',100,NERR,IOPT)
      INFO=-NERR
      RETURN
20106 CONTINUE
20103 CONTINUE
C
C     THE NUMBER OF ITERATIONS OF REV. SIMPLEX STEPS MUST BE POSITIVE.
20104 IF (.NOT.(MXITLP.LE.0)) GO TO 20109
      NERR=18
      CALL XERROR(  'SPLP( ). THE NUMBER OF REVISED SIMPLEX STEPS BETWEE
     *N CHECK-POINTS MUST BE POSITIVE.',83,NERR,IOPT)
      INFO=-NERR
      RETURN
20109 CONTINUE
C
C     CHECK THAT SAVE AND PAGE FILE NUMBERS ARE DEFINED AND NOT EQUAL.
20110 IF (.NOT.(ISAVE.LE.0.OR.IPAGEF.LE.0.OR.(ISAVE.EQ.IPAGEF))) GO TO 2
     *0112
      NERR=19
      CALL XERROR(  'SPLP( ). FILE NUMBERS FOR SAVED DATA AND MATRIX PAG
     *ES MUST BE POSITIVE AND NOT EQUAL.',85 ,NERR,IOPT)
      INFO=-NERR
      RETURN
20112 CONTINUE
20113 CONTINUE
31002 GO TO 20003
      END
      SUBROUTINE DVOUT(N,SX,IFMT,IDIGIT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  DVOUT
C***REFER TO  SPLP
C     REVISED FEB. 27, 1981.
C
C     SINGLE PRECISION VECTOR OUTPUT ROUTINE.
C
C  INPUT..
C
C  N,SX(*) PRINT THE SINGLE PRECISION ARRAY SX(I),I=1,...,N, ON
C          OUTPUT UNIT LOUT. THE HEADING IN THE FORTRAN FORMAT
C          STATEMENT IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST
C          STEP. THE COMPONENTS SX(I) ARE INDEXED, ON OUTPUT,
C          IN A PLEASANT FORMAT.
C  IFMT(*) A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON OUTPUT
C          UNIT LOUT WITH THE VARIABLE FORMAT FORTRAN STATEMENT
C                WRITE(LOUT,IFMT)
C  IDIGIT  PRINT AT LEAST IDABS(IDIGIT) DECIMAL DIGITS PER NUMBER.
C          THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,10 OR 14
C          WHICH WILL PRINT AT LEAST IDABS(IDIGIT) NUMBER OF
C          PLACES.  IF IDIGIT.LT.0, 72 PRINTING COLUMNS ARE UTILIZED
C          TO WRITE EACH LINE OF OUTPUT OF THE ARRAY SX(*). (THIS
C          CAN BE USED ON MOST TIME-SHARING TERMINALS). IF
C          IDIGIT.GE.0, 133 PRINTING COLUMNS ARE UTILIZED. (THIS CAN
C          BE USED ON MOST LINE PRINTERS).
C
C  EXAMPLE..
C
C  PRINT AN ARRAY CALLED (COSTS OF PURCHASES) OF LENGTH 100 SHOWING
C  6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING
C  SYSTEM WITH A 72 COLUMN OUTPUT DEVICE.
C
C     DIMENSION COSTS(100)
C     N = 100
C     IDIGIT = -6
C     CALL DVOUT(N,COSTS,'(''1COSTS OF PURCHASES'')',IDIGIT)
C
C
C
C     AUTHORS    JOHN A. WISNIEWSKI   SANDIA LABS ALBUQUERQUE.
C                RICHARD J. HANSON    SANDIA LABS ALBUQUERQUE.
C     DATE       JULY 27,1978.
C
C***ROUTINES CALLED  I1MACH
C***END PROLOGUE  DVOUT
      DIMENSION SX(*)
      CHARACTER IFMT*(*)
C
C     GET THE UNIT NUMBER WHERE OUTPUTWILL BE WRITTEN.
C***FIRST EXECUTABLE STATEMENT  DVOUT
      J=2
      LOUT=I1MACH(J)
      WRITE(LOUT,IFMT)
      IF(N.LE.0) RETURN
      NDIGIT = IDIGIT
      IF(IDIGIT.EQ.0) NDIGIT = 4
      IF(IDIGIT.GE.0) GO TO 80
C
      NDIGIT = -IDIGIT
      IF(NDIGIT.GT.4) GO TO 20
C
      DO 10 K1=1,N,5
      K2 = MIN0(N,K1+4)
      WRITE(LOUT,1000) K1,K2,(SX(I),I=K1,K2)
   10 CONTINUE
      RETURN
C
   20 CONTINUE
      IF(NDIGIT.GT.6) GO TO 40
C
      DO 30 K1=1,N,4
      K2 = MIN0(N,K1+3)
      WRITE(LOUT,1001) K1,K2,(SX(I),I=K1,K2)
   30 CONTINUE
      RETURN
C
   40 CONTINUE
      IF(NDIGIT.GT.10) GO TO 60
C
      DO 50 K1=1,N,3
      K2=MIN0(N,K1+2)
      WRITE(LOUT,1002) K1,K2,(SX(I),I=K1,K2)
   50 CONTINUE
      RETURN
C
   60 CONTINUE
      DO 70 K1=1,N,2
      K2 = MIN0(N,K1+1)
      WRITE(LOUT,1003) K1,K2,(SX(I),I=K1,K2)
   70 CONTINUE
      RETURN
C
   80 CONTINUE
      IF(NDIGIT.GT.4) GO TO 100
C
      DO 90 K1=1,N,10
      K2 = MIN0(N,K1+9)
      WRITE(LOUT,1000) K1,K2,(SX(I),I=K1,K2)
   90 CONTINUE
      RETURN
C
  100 CONTINUE
      IF(NDIGIT.GT.6) GO TO 120
C
      DO 110 K1=1,N,8
      K2 = MIN0(N,K1+7)
      WRITE(LOUT,1001) K1,K2,(SX(I),I=K1,K2)
  110 CONTINUE
      RETURN
C
  120 CONTINUE
      IF(NDIGIT.GT.10) GO TO 140
C
      DO 130 K1=1,N,6
      K2 = MIN0(N,K1+5)
      WRITE(LOUT,1002) K1,K2,(SX(I),I=K1,K2)
  130 CONTINUE
      RETURN
C
  140 CONTINUE
      DO 150 K1=1,N,5
      K2 = MIN0(N,K1+4)
      WRITE(LOUT,1003) K1,K2,(SX(I),I=K1,K2)
  150 CONTINUE
      RETURN
 1000 FORMAT(1X,I4,' - ',I4,1P10E12.3)
 1001 FORMAT(1X,I4,' - ',I4,1X,1P8E14.5)
 1002 FORMAT(1X,I4,' - ',I4,1X,1P6E18.9)
 1003 FORMAT(1X,I4,' - ',I4,1X,1P5E24.13)
      END
      SUBROUTINE XERROR(MESSG,NMESSG,NERR,LEVEL)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  XERROR
C***DATE WRITTEN   790801   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  R3C
C***KEYWORDS  ERROR,XERROR PACKAGE
C***AUTHOR  JONES, R. E., (SNLA)
C***PURPOSE  Processes an error (diagnostic) message.
C***DESCRIPTION
C     Abstract
C        XERROR processes a diagnostic message, in a manner
C        determined by the value of LEVEL and the current value
C        of the library error control flag, KONTRL.
C        (See subroutine XSETF for details.)
C
C     Description of Parameters
C      --Input--
C        MESSG - the Hollerith message to be processed, containing
C                no more than 72 characters.
C        NMESSG- the actual number of characters in MESSG.
C        NERR  - the error number associated with this message.
C                NERR must not be zero.
C        LEVEL - error category.
C                =2 means this is an unconditionally fatal error.
C                =1 means this is a recoverable error.  (I.e., it is
C                   non-fatal if XSETF has been appropriately called.)
C                =0 means this is a warning message only.
C                =-1 means this is a warning message which is to be
C                   printed at most once, regardless of how many
C                   times this call is executed.
C
C     Examples
C        CALL XERROR('SMOOTH -- NUM WAS ZERO.',23,1,2)
C        CALL XERROR('INTEG  -- LESS THAN FULL ACCURACY ACHIEVED.',
C                    43,2,1)
C        CALL XERROR('ROOTER -- ACTUAL ZERO OF F FOUND BEFORE INTERVAL F
C    1ULLY COLLAPSED.',65,3,0)
C        CALL XERROR('EXP    -- UNDERFLOWS BEING SET TO ZERO.',39,1,-1)
C
C     Latest revision ---  19 MAR 1980
C     Written by Ron Jones, with SLATEC Common Math Library Subcommittee
C***REFERENCES  JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  XERRWV
C***END PROLOGUE  XERROR
      CHARACTER*(*) MESSG
C***FIRST EXECUTABLE STATEMENT  XERROR
      CALL XERRWV(MESSG,NMESSG,NERR,LEVEL,0,0,0,0,0.,0.)
      RETURN
      END
      SUBROUTINE XERRWV(MESSG,NMESSG,NERR,LEVEL,NI,I1,I2,NR,R1,R2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  XERRWV
C***DATE WRITTEN   800319   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  R3C
C***KEYWORDS  ERROR,XERROR PACKAGE
C***AUTHOR  JONES, R. E., (SNLA)
C***PURPOSE  Processes error message allowing 2 integer and two real
C            values to be included in the message.
C***DESCRIPTION
C     Abstract
C        XERRWV processes a diagnostic message, in a manner
C        determined by the value of LEVEL and the current value
C        of the library error control flag, KONTRL.
C        (See subroutine XSETF for details.)
C        In addition, up to two integer values and two real
C        values may be printed along with the message.
C
C     Description of Parameters
C      --Input--
C        MESSG - the Hollerith message to be processed.
C        NMESSG- the actual number of characters in MESSG.
C        NERR  - the error number associated with this message.
C                NERR must not be zero.
C        LEVEL - error category.
C                =2 means this is an unconditionally fatal error.
C                =1 means this is a recoverable error.  (I.e., it is
C                   non-fatal if XSETF has been appropriately called.)
C                =0 means this is a warning message only.
C                =-1 means this is a warning message which is to be
C                   printed at most once, regardless of how many
C                   times this call is executed.
C        NI    - number of integer values to be printed. (0 to 2)
C        I1    - first integer value.
C        I2    - second integer value.
C        NR    - number of real values to be printed. (0 to 2)
C        R1    - first real value.
C        R2    - second real value.
C
C     Examples
C        CALL XERRWV('SMOOTH -- NUM (=I1) WAS ZERO.',29,1,2,
C    1   1,NUM,0,0,0.,0.)
C        CALL XERRWV('QUADXY -- REQUESTED ERROR (R1) LESS THAN MINIMUM (
C    1R2).,54,77,1,0,0,0,2,ERRREQ,ERRMIN)
C
C     Latest revision ---  19 MAR 1980
C     Written by Ron Jones, with SLATEC Common Math Library Subcommittee
C***REFERENCES  JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  FDUMP,I1MACH,J4SAVE,XERABT,XERCTL,XERPRT,XERSAV,
C                    XGETUA
C***END PROLOGUE  XERRWV
      CHARACTER*(*) MESSG
      CHARACTER*20 LFIRST
      CHARACTER*37 FORM
      DIMENSION LUN(5)
C     GET FLAGS
C***FIRST EXECUTABLE STATEMENT  XERRWV
      LKNTRL = J4SAVE(2,0,.FALSE.)
      MAXMES = J4SAVE(4,0,.FALSE.)
C     CHECK FOR VALID INPUT
      IF ((NMESSG.GT.0).AND.(NERR.NE.0).AND.
     1    (LEVEL.GE.(-1)).AND.(LEVEL.LE.2)) GO TO 10
         IF (LKNTRL.GT.0) CALL XERPRT('FATAL ERROR IN...',17)
         CALL XERPRT('XERROR -- INVALID INPUT',23)
         IF (LKNTRL.GT.0) CALL FDUMP
         IF (LKNTRL.GT.0) CALL XERPRT('JOB ABORT DUE TO FATAL ERROR.',
     1  29)
         IF (LKNTRL.GT.0) CALL XERSAV(' ',0,0,0,KDUMMY)
         CALL XERABT('XERROR -- INVALID INPUT',23)
         RETURN
   10 CONTINUE
C     RECORD MESSAGE
      JUNK = J4SAVE(1,NERR,.TRUE.)
      CALL XERSAV(MESSG,NMESSG,NERR,LEVEL,KOUNT)
C     LET USER OVERRIDE
      LFIRST = MESSG
      LMESSG = NMESSG
      LERR = NERR
      LLEVEL = LEVEL
      CALL XERCTL(LFIRST,LMESSG,LERR,LLEVEL,LKNTRL)
C     RESET TO ORIGINAL VALUES
      LMESSG = NMESSG
      LERR = NERR
      LLEVEL = LEVEL
      LKNTRL = MAX0(-2,MIN0(2,LKNTRL))
      MKNTRL = IDABS(LKNTRL)
C     DECIDE WHETHER TO PRINT MESSAGE
      IF ((LLEVEL.LT.2).AND.(LKNTRL.EQ.0)) GO TO 100
      IF (((LLEVEL.EQ.(-1)).AND.(KOUNT.GT.MIN0(1,MAXMES)))
     1.OR.((LLEVEL.EQ.0)   .AND.(KOUNT.GT.MAXMES))
     2.OR.((LLEVEL.EQ.1)   .AND.(KOUNT.GT.MAXMES).AND.(MKNTRL.EQ.1))
     3.OR.((LLEVEL.EQ.2)   .AND.(KOUNT.GT.MAX0(1,MAXMES)))) GO TO 100
         IF (LKNTRL.LE.0) GO TO 20
            CALL XERPRT(' ',1)
C           INTRODUCTION
            IF (LLEVEL.EQ.(-1)) CALL XERPRT
     1('WARNING MESSAGE...THIS MESSAGE WILL ONLY BE PRINTED ONCE.',57)
            IF (LLEVEL.EQ.0) CALL XERPRT('WARNING IN...',13)
            IF (LLEVEL.EQ.1) CALL XERPRT
     1      ('RECOVERABLE ERROR IN...',23)
            IF (LLEVEL.EQ.2) CALL XERPRT('FATAL ERROR IN...',17)
   20    CONTINUE
C        MESSAGE
         CALL XERPRT(MESSG,LMESSG)
         CALL XGETUA(LUN,NUNIT)
         ISIZEI = LOG10(FLOAT(I1MACH(9))) + 1.0
         ISIZEF = LOG10(FLOAT(I1MACH(10))**I1MACH(11)) + 1.0
         DO 50 KUNIT=1,NUNIT
            IUNIT = LUN(KUNIT)
            IF (IUNIT.EQ.0) IUNIT = I1MACH(4)
            DO 22 I=1,MIN(NI,2)
               WRITE (FORM,21) I,ISIZEI
   21          FORMAT ('(11X,21HIN ABOVE MESSAGE, I',I1,'=,I',I2,')   ')
               IF (I.EQ.1) WRITE (IUNIT,FORM) I1
               IF (I.EQ.2) WRITE (IUNIT,FORM) I2
   22       CONTINUE
            DO 24 I=1,MIN(NR,2)
               WRITE (FORM,23) I,ISIZEF+10,ISIZEF
   23          FORMAT ('(11X,21HIN ABOVE MESSAGE, R',I1,'=,E',
     1         I2,'.',I2,')')
               IF (I.EQ.1) WRITE (IUNIT,FORM) R1
               IF (I.EQ.2) WRITE (IUNIT,FORM) R2
   24       CONTINUE
            IF (LKNTRL.LE.0) GO TO 40
C              ERROR NUMBER
               WRITE (IUNIT,30) LERR
   30          FORMAT (15H ERROR NUMBER =,I10)
   40       CONTINUE
   50    CONTINUE
C        TRACE-BACK
         IF (LKNTRL.GT.0) CALL FDUMP
  100 CONTINUE
      IFATAL = 0
      IF ((LLEVEL.EQ.2).OR.((LLEVEL.EQ.1).AND.(MKNTRL.EQ.2)))
     1IFATAL = 1
C     QUIT HERE IF MESSAGE IS NOT FATAL
      IF (IFATAL.LE.0) RETURN
      IF ((LKNTRL.LE.0).OR.(KOUNT.GT.MAX0(1,MAXMES))) GO TO 120
C        PRINT REASON FOR ABORT
         IF (LLEVEL.EQ.1) CALL XERPRT
     1   ('JOB ABORT DUE TO UNRECOVERED ERROR.',35)
         IF (LLEVEL.EQ.2) CALL XERPRT
     1   ('JOB ABORT DUE TO FATAL ERROR.',29)
C        PRINT ERROR SUMMARY
         CALL XERSAV(' ',-1,0,0,KDUMMY)
  120 CONTINUE
C     ABORT
      IF ((LLEVEL.EQ.2).AND.(KOUNT.GT.MAX0(1,MAXMES))) LMESSG = 0
      CALL XERABT(MESSG,LMESSG)
      RETURN
      END
      SUBROUTINE XERSAV(MESSG,NMESSG,NERR,LEVEL,ICOUNT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  XERSAV
C***DATE WRITTEN   800319   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  Z
C***KEYWORDS  ERROR,XERROR PACKAGE
C***AUTHOR  JONES, R. E., (SNLA)
C***PURPOSE  Records that an error occurred.
C***DESCRIPTION
C     Abstract
C        Record that this error occurred.
C
C     Description of Parameters
C     --Input--
C       MESSG, NMESSG, NERR, LEVEL are as in XERROR,
C       except that when NMESSG=0 the tables will be
C       dumped and cleared, and when NMESSG is less than zero the
C       tables will be dumped and not cleared.
C     --Output--
C       ICOUNT will be the number of times this message has
C       been seen, or zero if the table has overflowed and
C       does not contain this message specifically.
C       When NMESSG=0, ICOUNT will not be altered.
C
C     Written by Ron Jones, with SLATEC Common Math Library Subcommittee
C     Latest revision ---  19 Mar 1980
C***REFERENCES  JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  I1MACH,S88FMT,XGETUA
C***END PROLOGUE  XERSAV
      INTEGER LUN(5)
      CHARACTER*(*) MESSG
      CHARACTER*20 MESTAB(10),MES
      DIMENSION NERTAB(10),LEVTAB(10),KOUNT(10)
      SAVE MESTAB,NERTAB,LEVTAB,KOUNT,KOUNTX
C     NEXT TWO DATA STATEMENTS ARE NECESSARY TO PROVIDE A BLANK
C     ERROR TABLE INITIALLY
      DATA KOUNT(1),KOUNT(2),KOUNT(3),KOUNT(4),KOUNT(5),
     1     KOUNT(6),KOUNT(7),KOUNT(8),KOUNT(9),KOUNT(10)
     2     /0,0,0,0,0,0,0,0,0,0/
      DATA KOUNTX/0/
C***FIRST EXECUTABLE STATEMENT  XERSAV
      IF (NMESSG.GT.0) GO TO 80
C     DUMP THE TABLE
         IF (KOUNT(1).EQ.0) RETURN
C        PRINT TO EACH UNIT
         CALL XGETUA(LUN,NUNIT)
         DO 60 KUNIT=1,NUNIT
            IUNIT = LUN(KUNIT)
            IF (IUNIT.EQ.0) IUNIT = I1MACH(4)
C           PRINT TABLE HEADER
            WRITE (IUNIT,10)
   10       FORMAT (32H0          ERROR MESSAGE SUMMARY/
     1      51H MESSAGE START             NERR     LEVEL     COUNT)
C           PRINT BODY OF TABLE
            DO 20 I=1,10
               IF (KOUNT(I).EQ.0) GO TO 30
               WRITE (IUNIT,15) MESTAB(I),NERTAB(I),LEVTAB(I),KOUNT(I)
   15          FORMAT (1X,A20,3I10)
   20       CONTINUE
   30       CONTINUE
C           PRINT NUMBER OF OTHER ERRORS
            IF (KOUNTX.NE.0) WRITE (IUNIT,40) KOUNTX
   40       FORMAT (41H0OTHER ERRORS NOT INDIVIDUALLY TABULATED=,I10)
            WRITE (IUNIT,50)
   50       FORMAT (1X)
   60    CONTINUE
         IF (NMESSG.LT.0) RETURN
C        CLEAR THE ERROR TABLES
         DO 70 I=1,10
   70       KOUNT(I) = 0
         KOUNTX = 0
         RETURN
   80 CONTINUE
C     PROCESS A MESSAGE...
C     SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG,
C     OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL.
      MES = MESSG
      DO 90 I=1,10
         II = I
         IF (KOUNT(I).EQ.0) GO TO 110
         IF (MES.NE.MESTAB(I)) GO TO 90
         IF (NERR.NE.NERTAB(I)) GO TO 90
         IF (LEVEL.NE.LEVTAB(I)) GO TO 90
         GO TO 100
   90 CONTINUE
C     THREE POSSIBLE CASES...
C     TABLE IS FULL
         KOUNTX = KOUNTX+1
         ICOUNT = 1
         RETURN
C     MESSAGE FOUND IN TABLE
  100    KOUNT(II) = KOUNT(II) + 1
         ICOUNT = KOUNT(II)
         RETURN
C     EMPTY SLOT FOUND FOR NEW MESSAGE
  110    MESTAB(II) = MES
         NERTAB(II) = NERR
         LEVTAB(II) = LEVEL
         KOUNT(II)  = 1
         ICOUNT = 1
         RETURN
      END
      SUBROUTINE XGETUA(IUNITA,N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  XGETUA
C***DATE WRITTEN   790801   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  R3C
C***KEYWORDS  ERROR,XERROR PACKAGE
C***AUTHOR  JONES, R. E., (SNLA)
C***PURPOSE  Returns unit number(s) to which error messages are being
C            sent.
C***DESCRIPTION
C     Abstract
C        XGETUA may be called to determine the unit number or numbers
C        to which error messages are being sent.
C        These unit numbers may have been set by a call to XSETUN,
C        or a call to XSETUA, or may be a default value.
C
C     Description of Parameters
C      --Output--
C        IUNIT - an array of one to five unit numbers, depending
C                on the value of N.  A value of zero refers to the
C                default unit, as defined by the I1MACH machine
C                constant routine.  Only IUNIT(1),...,IUNIT(N) are
C                defined by XGETUA.  The values of IUNIT(N+1),...,
C                IUNIT(5) are not defined (for N .LT. 5) or altered
C                in any way by XGETUA.
C        N     - the number of units to which copies of the
C                error messages are being sent.  N will be in the
C                range from 1 to 5.
C
C     Latest revision ---  19 MAR 1980
C     Written by Ron Jones, with SLATEC Common Math Library Subcommittee
C***REFERENCES  JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  J4SAVE
C***END PROLOGUE  XGETUA
      DIMENSION IUNITA(5)
C***FIRST EXECUTABLE STATEMENT  XGETUA
      N = J4SAVE(5,0,.FALSE.)
      DO 30 I=1,N
         INDEX = I+4
         IF (I.EQ.1) INDEX = 3
         IUNITA(I) = J4SAVE(INDEX,0,.FALSE.)
   30 CONTINUE
      RETURN
      END
      SUBROUTINE CLOSM(IPAGE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  CLOSM
C***REFER TO  SPLP
C     1. UNLOAD, RELEASE, OR CLOSE UNIT NUMBER IPAGEF.
C
C     THIS IS FORTRAN 77 STANDARD FOR THE 'CLOSE' STATEMENT.
C***ROUTINES CALLED  XERRWV
C***END PROLOGUE  CLOSM
C***FIRST EXECUTABLE STATEMENT  CLOSM
      IPAGEF=IPAGE
      CLOSE(UNIT=IPAGEF,IOSTAT=IOS,ERR=100,STATUS='KEEP')
      RETURN
 100  CONTINUE
      IOPT=1
      NERR=100
      CALL XERRWV('SPLP( ). CLOSE() HAS ERROR FLAG (I1).',37,NERR,IOPT,
     *1,IOS,IDUM,0,RDUM,RDUM)
      RETURN
      END
      SUBROUTINE FDUMP
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  FDUMP
C***DATE WRITTEN   790801   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  Z
C***KEYWORDS  ERROR,XERROR PACKAGE
C***AUTHOR  JONES, R. E., (SNLA)
C***PURPOSE  Symbolic dump (should be locally written).
C***DESCRIPTION
C        ***Note*** Machine Dependent Routine
C        FDUMP is intended to be replaced by a locally written
C        version which produces a symbolic dump.  Failing this,
C        it should be replaced by a version which prints the
C        subprogram nesting list.  Note that this dump must be
C        printed on each of up to five files, as indicated by the
C        XGETUA routine.  See XSETUA and XGETUA for details.
C
C     Written by Ron Jones, with SLATEC Common Math Library Subcommittee
C     Latest revision ---  23 May 1979
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  FDUMP
C***FIRST EXECUTABLE STATEMENT  FDUMP
      RETURN
      END
      INTEGER FUNCTION I1MACH(I)
C***BEGIN PROLOGUE  I1MACH
C***DATE WRITTEN   750101   (YYMMDD)
C***REVISION DATE  910131   (YYMMDD)
C***CATEGORY NO.  R1
C***KEYWORDS  MACHINE CONSTANTS
C***AUTHOR  FOX, P. A., (BELL LABS)
C           HALL, A. D., (BELL LABS)
C           SCHRYER, N. L., (BELL LABS)
C***PURPOSE  Returns integer machine dependent constants
C***DESCRIPTION
C
C     This is the CMLIB version of I1MACH, the integer machine
C     constants subroutine originally developed for the PORT library.
C
C     I1MACH can be used to obtain machine-dependent parameters
C     for the local machine environment.  It is a function
C     subroutine with one (input) argument, and can be called
C     as follows, for example
C
C          K = I1MACH(I)
C
C     where I=1,...,16.  The (output) value of K above is
C     determined by the (input) value of I.  The results for
C     various values of I are discussed below.
C
C  I/O unit numbers.
C    I1MACH( 1) = the standard input unit.
C    I1MACH( 2) = the standard output unit.
C    I1MACH( 3) = the standard punch unit.
C    I1MACH( 4) = the standard error message unit.
C
C  Words.
C    I1MACH( 5) = the number of bits per integer storage unit.
C    I1MACH( 6) = the number of characters per integer storage unit.
C
C  Integers.
C    assume integers are represented in the S-digit, base-A form
C
C               sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
C
C               where 0 .LE. X(I) .LT. A for I=0,...,S-1.
C    I1MACH( 7) = A, the base.
C    I1MACH( 8) = S, the number of base-A digits.
C    I1MACH( 9) = A**S - 1, the largest magnitude.
C
C  Floating-Point Numbers.
C    Assume floating-point numbers are represented in the T-digit,
C    base-B form
C               sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
C
C               where 0 .LE. X(I) .LT. B for I=1,...,T,
C               0 .LT. X(1), and EMIN .LE. E .LE. EMAX.
C    I1MACH(10) = B, the base.
C
C  Single-Precision
C    I1MACH(11) = T, the number of base-B digits.
C    I1MACH(12) = EMIN, the smallest exponent E.
C    I1MACH(13) = EMAX, the largest exponent E.
C
C  Double-Precision
C    I1MACH(14) = T, the number of base-B digits.
C    I1MACH(15) = EMIN, the smallest exponent E.
C    I1MACH(16) = EMAX, the largest exponent E.
C
C  To alter this function for a particular environment,
C  the desired set of DATA statements should be activated by
C  removing the C from column 1.  Also, the values of
C  I1MACH(1) - I1MACH(4) should be checked for consistency
C  with the local operating system.
C***REFERENCES  FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A
C                 PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  I1MACH
C
      INTEGER IMACH(16),OUTPUT
      EQUIVALENCE (IMACH(4),OUTPUT)
C
C     MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T
C     3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T
C     PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300).
C
C === MACHINE = IEEE.MOST-SIG-BYTE-FIRST
C === MACHINE = IEEE.LEAST-SIG-BYTE-FIRST
C === MACHINE = SUN
C === MACHINE = 68000
C === MACHINE = 8087
C === MACHINE = IBM.PC
C === MACHINE = ATT.3B
C === MACHINE = ATT.7300
C === MACHINE = ATT.6300
       DATA IMACH( 1) /    5 /
       DATA IMACH( 2) /    6 /
       DATA IMACH( 3) /    7 /
       DATA IMACH( 4) /    6 /
       DATA IMACH( 5) /   32 /
       DATA IMACH( 6) /    4 /
       DATA IMACH( 7) /    2 /
       DATA IMACH( 8) /   31 /
       DATA IMACH( 9) / 2147483647 /
       DATA IMACH(10) /    2 /
       DATA IMACH(11) /   24 /
       DATA IMACH(12) / -125 /
       DATA IMACH(13) /  128 /
       DATA IMACH(14) /   53 /
       DATA IMACH(15) / -1021 /
       DATA IMACH(16) /  1024 /
C
C     MACHINE CONSTANTS FOR AMDAHL MACHINES.
C
C === MACHINE = AMDAHL
C      DATA IMACH( 1) /   5 /
C      DATA IMACH( 2) /   6 /
C      DATA IMACH( 3) /   7 /
C      DATA IMACH( 4) /   6 /
C      DATA IMACH( 5) /  32 /
C      DATA IMACH( 6) /   4 /
C      DATA IMACH( 7) /   2 /
C      DATA IMACH( 8) /  31 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /  16 /
C      DATA IMACH(11) /   6 /
C      DATA IMACH(12) / -64 /
C      DATA IMACH(13) /  63 /
C      DATA IMACH(14) /  14 /
C      DATA IMACH(15) / -64 /
C      DATA IMACH(16) /  63 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
C
C === MACHINE = BURROUGHS.1700
C      DATA IMACH( 1) /    7 /
C      DATA IMACH( 2) /    2 /
C      DATA IMACH( 3) /    2 /
C      DATA IMACH( 4) /    2 /
C      DATA IMACH( 5) /   36 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   33 /
C      DATA IMACH( 9) / Z1FFFFFFFF /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   24 /
C      DATA IMACH(12) / -256 /
C      DATA IMACH(13) /  255 /
C      DATA IMACH(14) /   60 /
C      DATA IMACH(15) / -256 /
C      DATA IMACH(16) /  255 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM.
C
C === MACHINE = BURROUGHS.5700
C      DATA IMACH( 1) /   5 /
C      DATA IMACH( 2) /   6 /
C      DATA IMACH( 3) /   7 /
C      DATA IMACH( 4) /   6 /
C      DATA IMACH( 5) /  48 /
C      DATA IMACH( 6) /   6 /
C      DATA IMACH( 7) /   2 /
C      DATA IMACH( 8) /  39 /
C      DATA IMACH( 9) / O0007777777777777 /
C      DATA IMACH(10) /   8 /
C      DATA IMACH(11) /  13 /
C      DATA IMACH(12) / -50 /
C      DATA IMACH(13) /  76 /
C      DATA IMACH(14) /  26 /
C      DATA IMACH(15) / -50 /
C      DATA IMACH(16) /  76 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS.
C
C === MACHINE = BURROUGHS.6700
C === MACHINE = BURROUGHS.7700
C      DATA IMACH( 1) /   5 /
C      DATA IMACH( 2) /   6 /
C      DATA IMACH( 3) /   7 /
C      DATA IMACH( 4) /   6 /
C      DATA IMACH( 5) /  48 /
C      DATA IMACH( 6) /   6 /
C      DATA IMACH( 7) /   2 /
C      DATA IMACH( 8) /  39 /
C      DATA IMACH( 9) / O0007777777777777 /
C      DATA IMACH(10) /   8 /
C      DATA IMACH(11) /  13 /
C      DATA IMACH(12) / -50 /
C      DATA IMACH(13) /  76 /
C      DATA IMACH(14) /  26 /
C      DATA IMACH(15) / -32754 /
C      DATA IMACH(16) /  32780 /
C
C     MACHINE CONSTANTS FOR THE CONVEX C-120 (NATIVE MODE)
C
C === MACHINE = CONVEX.C1
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    0 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   32 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   31 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   24 /
C      DATA IMACH(12) / -127 /
C      DATA IMACH(13) /  127 /
C      DATA IMACH(14) /   53 /
C      DATA IMACH(15) / -1023 /
C      DATA IMACH(16) /  1023 /
C
C     MACHINE CONSTANTS FOR THE CONVEX (NATIVE MODE)
C     WITH -R8 OPTION
C
C === MACHINE = CONVEX.C1.R8
C      DATA IMACH( 1) /     5 /
C      DATA IMACH( 2) /     6 /
C      DATA IMACH( 3) /     0 /
C      DATA IMACH( 4) /     6 /
C      DATA IMACH( 5) /    32 /
C      DATA IMACH( 6) /     4 /
C      DATA IMACH( 7) /     2 /
C      DATA IMACH( 8) /    31 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /     2 /
C      DATA IMACH(11) /    53 /
C      DATA IMACH(12) / -1023 /
C      DATA IMACH(13) /  1023 /
C      DATA IMACH(14) /    53 /
C      DATA IMACH(15) / -1023 /
C      DATA IMACH(16) /  1023 /
C
C     MACHINE CONSTANTS FOR THE CONVEX C-120 (IEEE MODE)
C
C === MACHINE = CONVEX.C1.IEEE
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    0 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   32 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   31 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   24 /
C      DATA IMACH(12) / -125 /
C      DATA IMACH(13) /  128 /
C      DATA IMACH(14) /   53 /
C      DATA IMACH(15) / -1021 /
C      DATA IMACH(16) /  1024 /
C
C     MACHINE CONSTANTS FOR THE CONVEX (IEEE MODE)
C     WITH -R8 OPTION
C
C === MACHINE = CONVEX.C1.IEEE.R8
C      DATA IMACH( 1) /     5 /
C      DATA IMACH( 2) /     6 /
C      DATA IMACH( 3) /     0 /
C      DATA IMACH( 4) /     6 /
C      DATA IMACH( 5) /    32 /
C      DATA IMACH( 6) /     4 /
C      DATA IMACH( 7) /     2 /
C      DATA IMACH( 8) /    31 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /     2 /
C      DATA IMACH(11) /    53 /
C      DATA IMACH(12) / -1021 /
C      DATA IMACH(13) /  1024 /
C      DATA IMACH(14) /    53 /
C      DATA IMACH(15) / -1021 /
C      DATA IMACH(16) /  1024 /
C
C     MACHINE CONSTANTS FOR THE CYBER 170/180 SERIES USING NOS (FTN5).
C
C === MACHINE = CYBER.170.NOS
C === MACHINE = CYBER.180.NOS
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    7 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   60 /
C      DATA IMACH( 6) /   10 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   48 /
C      DATA IMACH( 9) / O"00007777777777777777" /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   48 /
C      DATA IMACH(12) / -974 /
C      DATA IMACH(13) / 1070 /
C      DATA IMACH(14) /   96 /
C      DATA IMACH(15) / -927 /
C      DATA IMACH(16) / 1070 /
C
C     MACHINE CONSTANTS FOR THE CDC 180 SERIES USING NOS/VE
C
C === MACHINE = CYBER.180.NOS/VE
C      DATA IMACH( 1) /     5 /
C      DATA IMACH( 2) /     6 /
C      DATA IMACH( 3) /     7 /
C      DATA IMACH( 4) /     6 /
C      DATA IMACH( 5) /    64 /
C      DATA IMACH( 6) /     8 /
C      DATA IMACH( 7) /     2 /
C      DATA IMACH( 8) /    63 /
C      DATA IMACH( 9) / 9223372036854775807 /
C      DATA IMACH(10) /     2 /
C      DATA IMACH(11) /    47 /
C      DATA IMACH(12) / -4095 /
C      DATA IMACH(13) /  4094 /
C      DATA IMACH(14) /    94 /
C      DATA IMACH(15) / -4095 /
C      DATA IMACH(16) /  4094 /
C
C     MACHINE CONSTANTS FOR THE CYBER 205
C
C === MACHINE = CYBER.205
C      DATA IMACH( 1) /      5 /
C      DATA IMACH( 2) /      6 /
C      DATA IMACH( 3) /      7 /
C      DATA IMACH( 4) /      6 /
C      DATA IMACH( 5) /     64 /
C      DATA IMACH( 6) /      8 /
C      DATA IMACH( 7) /      2 /
C      DATA IMACH( 8) /     47 /
C      DATA IMACH( 9) / X'00007FFFFFFFFFFF' /
C      DATA IMACH(10) /      2 /
C      DATA IMACH(11) /     47 /
C      DATA IMACH(12) / -28625 /
C      DATA IMACH(13) /  28718 /
C      DATA IMACH(14) /     94 /
C      DATA IMACH(15) / -28625 /
C      DATA IMACH(16) /  28718 /
C
C     MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES.
C
C === MACHINE = CDC.6000
C === MACHINE = CDC.7000
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    7 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   60 /
C      DATA IMACH( 6) /   10 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   48 /
C      DATA IMACH( 9) / 00007777777777777777B /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   48 /
C      DATA IMACH(12) / -974 /
C      DATA IMACH(13) / 1070 /
C      DATA IMACH(14) /   96 /
C      DATA IMACH(15) / -927 /
C      DATA IMACH(16) / 1070 /
C
C     MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3.
C     USING THE 46 BIT INTEGER COMPILER OPTION
C
C === MACHINE = CRAY.46-BIT-INTEGER
C      DATA IMACH( 1) /     5 /
C      DATA IMACH( 2) /     6 /
C      DATA IMACH( 3) /   102 /
C      DATA IMACH( 4) /     6 /
C      DATA IMACH( 5) /    64 /
C      DATA IMACH( 6) /     8 /
C      DATA IMACH( 7) /     2 /
C      DATA IMACH( 8) /    46 /
C      DATA IMACH( 9) /  777777777777777777777B /
C      DATA IMACH(10) /     2 /
C      DATA IMACH(11) /    47 /
C      DATA IMACH(12) / -8189 /
C      DATA IMACH(13) /  8190 /
C      DATA IMACH(14) /    94 /
C      DATA IMACH(15) / -8099 /
C      DATA IMACH(16) /  8190 /
C
C     MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3.
C     USING THE 64 BIT INTEGER COMPILER OPTION
C
C === MACHINE = CRAY.64-BIT-INTEGER
C      DATA IMACH( 1) /     5 /
C      DATA IMACH( 2) /     6 /
C      DATA IMACH( 3) /   102 /
C      DATA IMACH( 4) /     6 /
C      DATA IMACH( 5) /    64 /
C      DATA IMACH( 6) /     8 /
C      DATA IMACH( 7) /     2 /
C      DATA IMACH( 8) /    63 /
C      DATA IMACH( 9) /  777777777777777777777B /
C      DATA IMACH(10) /     2 /
C      DATA IMACH(11) /    47 /
C      DATA IMACH(12) / -8189 /
C      DATA IMACH(13) /  8190 /
C      DATA IMACH(14) /    94 /
C      DATA IMACH(15) / -8099 /
C      DATA IMACH(16) /  8190 /C
C     MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
C
C === MACHINE = DATA_GENERAL.ECLIPSE.S/200
C      DATA IMACH( 1) /   11 /
C      DATA IMACH( 2) /   12 /
C      DATA IMACH( 3) /    8 /
C      DATA IMACH( 4) /   10 /
C      DATA IMACH( 5) /   16 /
C      DATA IMACH( 6) /    2 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   15 /
C      DATA IMACH( 9) /32767 /
C      DATA IMACH(10) /   16 /
C      DATA IMACH(11) /    6 /
C      DATA IMACH(12) /  -64 /
C      DATA IMACH(13) /   63 /
C      DATA IMACH(14) /   14 /
C      DATA IMACH(15) /  -64 /
C      DATA IMACH(16) /   63 /
C
C     ELXSI  6400
C
C === MACHINE = ELSXI.6400
C      DATA IMACH( 1) /     5 /
C      DATA IMACH( 2) /     6 /
C      DATA IMACH( 3) /     6 /
C      DATA IMACH( 4) /     6 /
C      DATA IMACH( 5) /    32 /
C      DATA IMACH( 6) /     4 /
C      DATA IMACH( 7) /     2 /
C      DATA IMACH( 8) /    32 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /     2 /
C      DATA IMACH(11) /    24 /
C      DATA IMACH(12) /  -126 /
C      DATA IMACH(13) /   127 /
C      DATA IMACH(14) /    53 /
C      DATA IMACH(15) / -1022 /
C      DATA IMACH(16) /  1023 /
C
C     MACHINE CONSTANTS FOR THE HARRIS 220
C     MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7
C
C === MACHINE = HARRIS.220
C === MACHINE = HARRIS.SLASH6
C === MACHINE = HARRIS.SLASH7
C      DATA IMACH( 1) /       5 /
C      DATA IMACH( 2) /       6 /
C      DATA IMACH( 3) /       0 /
C      DATA IMACH( 4) /       6 /
C      DATA IMACH( 5) /      24 /
C      DATA IMACH( 6) /       3 /
C      DATA IMACH( 7) /       2 /
C      DATA IMACH( 8) /      23 /
C      DATA IMACH( 9) / 8388607 /
C      DATA IMACH(10) /       2 /
C      DATA IMACH(11) /      23 /
C      DATA IMACH(12) /    -127 /
C      DATA IMACH(13) /     127 /
C      DATA IMACH(14) /      38 /
C      DATA IMACH(15) /    -127 /
C      DATA IMACH(16) /     127 /
C
C     MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES.
C     MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
C
C === MACHINE = HONEYWELL.600/6000
C === MACHINE = HONEYWELL.DPS.8/70
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /   43 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   36 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   35 /
C      DATA IMACH( 9) / O377777777777 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   27 /
C      DATA IMACH(12) / -127 /
C      DATA IMACH(13) /  127 /
C      DATA IMACH(14) /   63 /
C      DATA IMACH(15) / -127 /
C      DATA IMACH(16) /  127 /
C
C     MACHINE CONSTANTS FOR THE HP 2100
C     3 WORD DOUBLE PRECISION OPTION WITH FTN4
C
C === MACHINE = HP.2100.3_WORD_DP
C      DATA IMACH(1) /      5/
C      DATA IMACH(2) /      6 /
C      DATA IMACH(3) /      4 /
C      DATA IMACH(4) /      1 /
C      DATA IMACH(5) /     16 /
C      DATA IMACH(6) /      2 /
C      DATA IMACH(7) /      2 /
C      DATA IMACH(8) /     15 /
C      DATA IMACH(9) /  32767 /
C      DATA IMACH(10)/      2 /
C      DATA IMACH(11)/     23 /
C      DATA IMACH(12)/   -128 /
C      DATA IMACH(13)/    127 /
C      DATA IMACH(14)/     39 /
C      DATA IMACH(15)/   -128 /
C      DATA IMACH(16)/    127 /
C
C     MACHINE CONSTANTS FOR THE HP 2100
C     4 WORD DOUBLE PRECISION OPTION WITH FTN4
C
C === MACHINE = HP.2100.4_WORD_DP
C      DATA IMACH(1) /      5 /
C      DATA IMACH(2) /      6 /
C      DATA IMACH(3) /      4 /
C      DATA IMACH(4) /      1 /
C      DATA IMACH(5) /     16 /
C      DATA IMACH(6) /      2 /
C      DATA IMACH(7) /      2 /
C      DATA IMACH(8) /     15 /
C      DATA IMACH(9) /  32767 /
C      DATA IMACH(10)/      2 /
C      DATA IMACH(11)/     23 /
C      DATA IMACH(12)/   -128 /
C      DATA IMACH(13)/    127 /
C      DATA IMACH(14)/     55 /
C      DATA IMACH(15)/   -128 /
C      DATA IMACH(16)/    127 /
C
C     HP 9000
C
C === MACHINE = HP.9000
C      DATA IMACH( 1) /     5 /
C      DATA IMACH( 2) /     6 /
C      DATA IMACH( 3) /     6 /
C      DATA IMACH( 4) /     7 /
C      DATA IMACH( 5) /    32 /
C      DATA IMACH( 6) /     4 /
C      DATA IMACH( 7) /     2 /
C      DATA IMACH( 8) /    32 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /     2 /
C      DATA IMACH(11) /    24 /
C      DATA IMACH(12) /  -126 /
C      DATA IMACH(13) /   127 /
C      DATA IMACH(14) /    53 /
C      DATA IMACH(15) / -1015 /
C      DATA IMACH(16) /  1017 /
C
C     MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
C     THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86 AND
C     THE INTERDATA 3230 AND INTERDATA 7/32.
C
C === MACHINE = IBM.360
C === MACHINE = IBM.370
C === MACHINE = XEROX.SIGMA.5
C === MACHINE = XEROX.SIGMA.7
C === MACHINE = XEROX.SIGMA.9
C === MACHINE = SEL.85
C === MACHINE = SEL.86
C === MACHINE = INTERDATA.3230
C === MACHINE = INTERDATA.7/32
C      DATA IMACH( 1) /   5 /
C      DATA IMACH( 2) /   6 /
C      DATA IMACH( 3) /   7 /
C      DATA IMACH( 4) /   6 /
C      DATA IMACH( 5) /  32 /
C      DATA IMACH( 6) /   4 /
C      DATA IMACH( 7) /   2 /
C      DATA IMACH( 8) /  31 /
C      DATA IMACH( 9) / Z7FFFFFFF /
C      DATA IMACH(10) /  16 /
C      DATA IMACH(11) /   6 /
C      DATA IMACH(12) / -64 /
C      DATA IMACH(13) /  63 /
C      DATA IMACH(14) /  14 /
C      DATA IMACH(15) / -64 /
C      DATA IMACH(16) /  63 /
C
C     MACHINE CONSTANTS FOR THE INTERDATA 8/32
C     WITH THE UNIX SYSTEM FORTRAN 77 COMPILER.
C
C     FOR THE INTERDATA FORTRAN VII COMPILER REPLACE
C     THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S.
C
C === MACHINE = INTERDATA.8/32.UNIX
C      DATA IMACH( 1) /   5 /
C      DATA IMACH( 2) /   6 /
C      DATA IMACH( 3) /   6 /
C      DATA IMACH( 4) /   6 /
C      DATA IMACH( 5) /  32 /
C      DATA IMACH( 6) /   4 /
C      DATA IMACH( 7) /   2 /
C      DATA IMACH( 8) /  31 /
C      DATA IMACH( 9) / Z'7FFFFFFF' /
C      DATA IMACH(10) /  16 /
C      DATA IMACH(11) /   6 /
C      DATA IMACH(12) / -64 /
C      DATA IMACH(13) /  62 /
C      DATA IMACH(14) /  14 /
C      DATA IMACH(15) / -64 /
C      DATA IMACH(16) /  62 /
C
C     MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR).
C
C === MACHINE = PDP-10.KA
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    7 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   36 /
C      DATA IMACH( 6) /    5 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   35 /
C      DATA IMACH( 9) / "377777777777 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   27 /
C      DATA IMACH(12) / -128 /
C      DATA IMACH(13) /  127 /
C      DATA IMACH(14) /   54 /
C      DATA IMACH(15) / -101 /
C      DATA IMACH(16) /  127 /
C
C     MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR).
C
C === MACHINE = PDP-10.KI
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    7 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   36 /
C      DATA IMACH( 6) /    5 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   35 /
C      DATA IMACH( 9) / "377777777777 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   27 /
C      DATA IMACH(12) / -128 /
C      DATA IMACH(13) /  127 /
C      DATA IMACH(14) /   62 /
C      DATA IMACH(15) / -128 /
C      DATA IMACH(16) /  127 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
C     32-BIT INTEGER ARITHMETIC.
C
C === MACHINE = PDP-11.32-BIT
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    7 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   32 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   31 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   24 /
C      DATA IMACH(12) / -127 /
C      DATA IMACH(13) /  127 /
C      DATA IMACH(14) /   56 /
C      DATA IMACH(15) / -127 /
C      DATA IMACH(16) /  127 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
C     16-BIT INTEGER ARITHMETIC. 
C
C === MACHINE = PDP-11.16-BIT
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    7 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   16 /
C      DATA IMACH( 6) /    2 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   15 /
C      DATA IMACH( 9) / 32767 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   24 /
C      DATA IMACH(12) / -127 /
C      DATA IMACH(13) /  127 /
C      DATA IMACH(14) /   56 /
C      DATA IMACH(15) / -127 /
C      DATA IMACH(16) /  127 /
C
C     MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000.
C
C === MACHINE = SEQUENT.BALANCE.8000
C      DATA IMACH( 1) /     0 /
C      DATA IMACH( 2) /     0 /
C      DATA IMACH( 3) /     7 /
C      DATA IMACH( 4) /     0 /
C      DATA IMACH( 5) /    32 /
C      DATA IMACH( 6) /     1 /
C      DATA IMACH( 7) /     2 /
C      DATA IMACH( 8) /    31 /
C      DATA IMACH( 9) /  2147483647 /
C      DATA IMACH(10) /     2 /
C      DATA IMACH(11) /    24 /
C      DATA IMACH(12) /  -125 /
C      DATA IMACH(13) /   128 /
C      DATA IMACH(14) /    53 /
C      DATA IMACH(15) / -1021 /
C      DATA IMACH(16) /  1024 /
C
C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. FTN COMPILER
C
C === MACHINE = UNIVAC.1100
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    1 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   36 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   35 /
C      DATA IMACH( 9) / O377777777777 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   27 /
C      DATA IMACH(12) / -128 /
C      DATA IMACH(13) /  127 /
C      DATA IMACH(14) /   60 /
C      DATA IMACH(15) /-1024 /
C      DATA IMACH(16) / 1023 /
C
C     MACHINE CONSTANTS FOR THE VAX 11/780
C
C === MACHINE = VAX.11/780
C      DATA IMACH(1) /    5 /
C      DATA IMACH(2) /    6 /
C      DATA IMACH(3) /    5 /
C      DATA IMACH(4) /    6 /
C      DATA IMACH(5) /   32 /
C      DATA IMACH(6) /    4 /
C      DATA IMACH(7) /    2 /
C      DATA IMACH(8) /   31 /
C      DATA IMACH(9) /2147483647 /
C      DATA IMACH(10)/    2 /
C      DATA IMACH(11)/   24 /
C      DATA IMACH(12)/ -127 /
C      DATA IMACH(13)/  127 /
C      DATA IMACH(14)/   56 /
C      DATA IMACH(15)/ -127 /
C      DATA IMACH(16)/  127 /
C
C
C***FIRST EXECUTABLE STATEMENT  I1MACH
      IF (I .LT. 1  .OR.  I .GT. 16)
     1   CALL XERROR ( 'I1MACH -- I OUT OF BOUNDS',25,1,2)
C
      I1MACH=IMACH(I)
      RETURN
C
      END
      INTEGER FUNCTION IPLOC(LOC,SX,IX)
C***BEGIN PROLOGUE  IPLOC
C***REFER TO  SPLP
C     RELATIVE ADDRESS DETERMINATION FUNCTION.
C     REVISED 810306-0800
C     REVISED YYMMDD-HHMM
C     AUTHORS  JOHN A. WISNIEWSKI AND R.J. HANSON
C
C
C     GIVEN A VIRTUAL LOCATION, FUNCTION IPLOC() RETURNS THE RELATIVE
C     WORKING MEMORY ADDRESS OF THE VECTOR COMPONENT STORED IN SX(*),
C     IX(*). ANY NECESSARY PAGE SWAPS ARE PERFORMED AUTOMATICALLY
C     FOR THE USER IN THIS FUNCTION SUBPROGRAM.
C
C
C     LOC       IS THE VIRTUAL ADDRESS OF THE DATA TO BE RETRIEVED.
C   SX(*),IX(*) REPRESENT THE MATRIX WHERE THE DATA IS STORED.
C
C     EXTERNAL REFERENCES   PRWPGE,XERROR
C
C***ROUTINES CALLED  PRWPGE,XERROR
C***END PROLOGUE  IPLOC
      DIMENSION IX(*)
      DOUBLE PRECISION SX(*),ONE,ZERO
      DATA ONE,ZERO /1.D0,0.D0/
C***FIRST EXECUTABLE STATEMENT  IPLOC
      IF (.NOT.(LOC.LE.0)) GO TO 20002
      IOPT=1
      NERR=55
      CALL XERROR(  '0IN IPLOC() A VALUE OF LOC(FIRST ARGUMENT) .LE. ZER
     *O WAS ENCOUNTERED',68,NERR,IOPT)
C
C     TWO CASES EXIST:  1.LE.LOC.LE.K.OR.LOC.GT.K.
C
20002 K = IX(3) + 4
      LMX = IX(1)
      LMXM1 = LMX - 1
      IF (.NOT.(LOC.LE.K)) GO TO 20005
      IPLOC = LOC
      GO TO 20006
C
C     COMPUTE LENGTH OF THE PAGE, STARTING ADDRESS OF THE PAGE, PAGE
C     NUMBER AND RELATIVE WORKING MEMORY ADDRESS.
C
20005 LPG = LMX-K
      ITEMP = LOC - K - 1
      IPAGE = ITEMP/LPG + 1
      IPLOC = MOD(ITEMP,LPG) + K + 1
      NP = IDABS(IX(LMXM1))
C
C     DETERMINE IF A PAGE FAULT HAS OCCURRED. IF SO, WRITE PAGE NP AND
C     READ PAGE IPAGE. WRITE THE PAGE ONLY IF IT HAS BEEN MODIFIED.
C
      IF (.NOT.(IPAGE.NE.NP)) GO TO 20008
      IF (.NOT.(SX(LMX).EQ.ONE)) GO TO 20011
      SX(LMX) = ZERO
      KEY = 2
      CALL PRWPGE(KEY,NP,LPG,SX,IX)
20011 KEY = 1
      CALL PRWPGE(KEY,IPAGE,LPG,SX,IX)
20008 CONTINUE
20006 RETURN
      END
      SUBROUTINE IVOUT(N,IX,IFMT,IDIGIT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  IVOUT
C***REFER TO  SPLP
C     REVISED FEB. 27, 1981.
C
C     INTEGER VECTOR OUTPUT ROUTINE.
C
C  INPUT..
C
C  N,IX(*) PRINT THE INTEGER ARRAY IX(I),I=1,...,N, ON OUTPUT
C          UNIT LOUT. THE HEADING IN THE FORTRAN FORMAT
C          STATEMENT IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST
C          STEP. THE COMPONENTS IX(I) ARE INDEXED, ON OUTPUT,
C          IN A PLEASANT FORMAT.
C  IFMT(*) A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON OUTPUT
C          UNIT LOUT WITH THE VARIABLE FORMAT FORTRAN STATEMENT
C                WRITE(LOUT,IFMT)
C  IDIGIT  PRINT UP TO IDABS(IDIGIT) DECIMAL DIGITS PER NUMBER.
C          THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,10 OR 14
C          WHICH WILL PRINT AT LEAST IDABS(IDIGIT) NUMBER OF
C          PLACES.  IF IDIGIT.LT.0, 72 PRINTING COLUMNS ARE UTILIZED
C          TO WRITE EACH LINE OF OUTPUT OF THE ARRAY IX(*). (THIS
C          CAN BE USED ON MOST TIME-SHARING TERMINALS). IF
C          IDIGIT.GE.0, 133 PRINTING COLUMNS ARE UTILIZED. (THIS CAN
C          BE USED ON MOST LINE PRINTERS).
C
C  EXAMPLE..
C
C  PRINT AN ARRAY CALLED (COSTS OF PURCHASES) OF LENGTH 100 SHOWING
C  6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING
C  SYSTEM WITH A 72 COLUMN OUTPUT DEVICE.
C
C     DIMENSION ICOSTS(100)
C     N = 100
C     IDIGIT = -6
C     CALL IVOUT(N,ICOSTS,'(''1COSTS OF PURCHASES'')',IDIGIT)
C
C
C
C     AUTHORS    JOHN A. WISNIEWSKI   SANDIA LABS ALBUQUERQUE.
C                RICHARD J. HANSON    SANDIA LABS ALBUQUERQUE.
C     DATE       JULY 27,1978.
C***ROUTINES CALLED  I1MACH
C***END PROLOGUE  IVOUT
      DIMENSION IX(*)
      CHARACTER IFMT*(*)
C
C     GET THE UNIT NUMBER WHERE OUTPUTWILL BE WRITTEN.
C***FIRST EXECUTABLE STATEMENT  IVOUT
      J=2
      LOUT=I1MACH(J)
      WRITE(LOUT,IFMT)
      IF(N.LE.0) RETURN
      NDIGIT = IDIGIT
      IF(IDIGIT.EQ.0) NDIGIT = 4
      IF(IDIGIT.GE.0) GO TO 80
C
      NDIGIT = -IDIGIT
      IF(NDIGIT.GT.4) GO TO 20
C
      DO 10 K1=1,N,10
      K2 = MIN0(N,K1+9)
      WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2)
   10 CONTINUE
      RETURN
C
   20 CONTINUE
      IF(NDIGIT.GT.6) GO TO 40
C
      DO 30 K1=1,N,7
      K2 = MIN0(N,K1+6)
      WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2)
   30 CONTINUE
      RETURN
C
   40 CONTINUE
      IF(NDIGIT.GT.10) GO TO 60
C
      DO 50 K1=1,N,5
      K2=MIN0(N,K1+4)
      WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2)
   50 CONTINUE
      RETURN
C
   60 CONTINUE
      DO 70 K1=1,N,3
      K2 = MIN0(N,K1+2)
      WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2)
   70 CONTINUE
      RETURN
C
   80 CONTINUE
      IF(NDIGIT.GT.4) GO TO 100
C
      DO 90 K1=1,N,20
      K2 = MIN0(N,K1+19)
      WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2)
   90 CONTINUE
      RETURN
C
  100 CONTINUE
      IF(NDIGIT.GT.6) GO TO 120
C
      DO 110 K1=1,N,15
      K2 = MIN0(N,K1+14)
      WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2)
  110 CONTINUE
      RETURN
C
  120 CONTINUE
      IF(NDIGIT.GT.10) GO TO 140
C
      DO 130 K1=1,N,10
      K2 = MIN0(N,K1+9)
      WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2)
  130 CONTINUE
      RETURN
C
  140 CONTINUE
      DO 150 K1=1,N,7
      K2 = MIN0(N,K1+6)
      WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2)
  150 CONTINUE
      RETURN
 1000 FORMAT(1X,I4,' - ',I4,20(1X,I5))
 1001 FORMAT(1X,I4,' - ',I4,15(1X,I7))
 1002 FORMAT(1X,I4,' - ',I4,10(1X,I11))
 1003 FORMAT(1X,I4,' - ',I4,7(1X,I15))
      END
      FUNCTION J4SAVE(IWHICH,IVALUE,ISET)
C***BEGIN PROLOGUE  J4SAVE
C***REFER TO  XERROR
C     Abstract
C        J4SAVE saves and recalls several global variables needed
C        by the library error handling routines.
C
C     Description of Parameters
C      --Input--
C        IWHICH - Index of item desired.
C                = 1 Refers to current error number.
C                = 2 Refers to current error control flag.
C                 = 3 Refers to current unit number to which error
C                    messages are to be sent.  (0 means use standard.)
C                 = 4 Refers to the maximum number of times any
C                     message is to be printed (as set by XERMAX).
C                 = 5 Refers to the total number of units to which
C                     each error message is to be written.
C                 = 6 Refers to the 2nd unit for error messages
C                 = 7 Refers to the 3rd unit for error messages
C                 = 8 Refers to the 4th unit for error messages
C                 = 9 Refers to the 5th unit for error messages
C        IVALUE - The value to be set for the IWHICH-th parameter,
C                 if ISET is .TRUE. .
C        ISET   - If ISET=.TRUE., the IWHICH-th parameter will BE
C                 given the value, IVALUE.  If ISET=.FALSE., the
C                 IWHICH-th parameter will be unchanged, and IVALUE
C                 is a dummy parameter.
C      --Output--
C        The (old) value of the IWHICH-th parameter will be returned
C        in the function value, J4SAVE.
C
C     Written by Ron Jones, with SLATEC Common Math Library Subcommittee
C    Adapted from Bell Laboratories PORT Library Error Handler
C     Latest revision ---  23 MAY 1979
C***REFERENCES  JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  J4SAVE
      LOGICAL ISET
      INTEGER IPARAM(9)
      SAVE IPARAM
      DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/
      DATA IPARAM(5)/1/
      DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/
C***FIRST EXECUTABLE STATEMENT  J4SAVE
      J4SAVE = IPARAM(IWHICH)
      IF (ISET) IPARAM(IWHICH) = IVALUE
      RETURN
      END
      SUBROUTINE LA05BS(A, IND, IA, N, IP, IW, W, G, B, TRANS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  LA05BS
C***REFER TO  SPLP
C     THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
C     FROM THE C. 1979 AERE HARWELL LIBRARY.  THE NAME OF THE
C     CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
C     THE FINAL LETTER =S= IN THE NAMES USED HERE.
C     REVISED SEP. 13, 1979.
C
C     ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
C     IN THE PACKAGE GIVEN HERE.  ANY PRIMARY USAGE OF THE HARWELL
C     SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
C     THE USER AND AERE-UK.  ANY USAGE OF THE SANDIA WRITTEN CODES
C     SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
C
C IP(I,1),IP(I,2) POINT TO START OF ROW/COLUMN I OF U.
C IW(I,1),IW(I,2) ARE LENGTHS OF ROW/COL I OF U.
C IW(.,3),IW(.,4) HOLD ROW/COL NUMBERS IN PIVOTAL ORDER.
C***ROUTINES CALLED  XERROR,XSETUN
C***COMMON BLOCKS    LA05DS
C***END PROLOGUE  LA05BS
      DOUBLE PRECISION A(IA), B(N), AM, W(N), G, SMALL
      LOGICAL TRANS
      INTEGER IND(IA,2), IW(N,4)
      INTEGER IP(N,2)
      COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL
C***FIRST EXECUTABLE STATEMENT  LA05BS
      IF (G.LT.0.) GO TO 130
      KLL = IA - LENL + 1
      IF (TRANS) GO TO 80
C
C     MULTIPLY VECTOR BY INVERSE OF L
      IF (LENL.LE.0) GO TO 20
      L1 = IA + 1
      DO 10 KK=1,LENL
         K = L1 - KK
         I = IND(K,1)
         IF (B(I).EQ.0.) GO TO 10
         J = IND(K,2)
         B(J) = B(J) + A(K)*B(I)
   10 CONTINUE
   20 DO 30 I=1,N
         W(I) = B(I)
         B(I) = 0.
   30 CONTINUE
C
C     MULTIPLY VECTOR BY INVERSE OF U
      N1 = N + 1
      DO 70 II=1,N
         I = N1 - II
         I = IW(I,3)
         AM = W(I)
         KP = IP(I,1)
         IF (KP.GT.0) GO TO 50
         KP = -KP
         IP(I,1) = KP
         NZ = IW(I,1)
         KL = KP - 1 + NZ
         K2 = KP + 1
         DO 40 K=K2,KL
            J = IND(K,2)
            AM = AM - A(K)*B(J)
   40    CONTINUE
   50    IF (AM.EQ.0.) GO TO 70
         J = IND(KP,2)
         B(J) = AM/A(KP)
         KPC = IP(J,2)
         KL = IW(J,2) + KPC - 1
         IF (KL.EQ.KPC) GO TO 70
         K2 = KPC + 1
         DO 60 K=K2,KL
            I = IND(K,1)
            IP(I,1) = -IDABS(IP(I,1))
   60    CONTINUE
   70 CONTINUE
      GO TO 140
C
C     MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF U
   80 DO 90 I=1,N
         W(I) = B(I)
         B(I) = 0.
   90 CONTINUE
      DO 110 II=1,N
         I = IW(II,4)
         AM = W(I)
         IF (AM.EQ.0.) GO TO 110
         J = IW(II,3)
         KP = IP(J,1)
         AM = AM/A(KP)
         B(J) = AM
         KL = IW(J,1) + KP - 1
         IF (KP.EQ.KL) GO TO 110
         K2 = KP + 1
         DO 100 K=K2,KL
            I = IND(K,2)
            W(I) = W(I) - AM*A(K)
  100    CONTINUE
  110 CONTINUE
C
C     MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF L
      IF (KLL.GT.IA) RETURN
      DO 120 K=KLL,IA
         J = IND(K,2)
         IF (B(J).EQ.0.) GO TO 120
         I = IND(K,1)
         B(I) = B(I) + A(K)*B(J)
  120 CONTINUE
      GO TO 140
C
  130 CALL XSETUN(LP)
      NERR = 0
      IOPT = 1
      IF (LP.GT.0) CALL XERROR(
     * 'LA05BS. EARLIER ENTRY GAVE ERROR RETURN.', 40, NERR, IOPT)
  140 RETURN
      END
      SUBROUTINE LA05CS(A, IND, IA, N, IP, IW, W, G, U, MM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  LA05CS
C***REFER TO  SPLP
C     THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
C     FROM THE C. 1979 AERE HARWELL LIBRARY.  THE NAME OF THE
C     CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
C     THE FINAL LETTER =S= IN THE NAMES USED HERE.
C     REVISED SEP. 13, 1979.
C
C     ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
C     IN THE PACKAGE GIVEN HERE.  ANY PRIMARY USAGE OF THE HARWELL
C     SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
C     THE USER AND AERE-UK.  ANY USAGE OF THE SANDIA WRITTEN CODES
C     SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
C***ROUTINES CALLED  LA05ES,XERROR,XERRWV,XSETUN
C***COMMON BLOCKS    LA05DS
C***END PROLOGUE  LA05CS
      DOUBLE PRECISION A(IA), G, U, AM, W(N), SMALL, AU
      INTEGER IND(IA,2), IW(N,4)
      INTEGER IP(N,2)
      COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL
C***FIRST EXECUTABLE STATEMENT  LA05CS
      CALL XSETUN(LP)
      IF (G.LT.0.) GO TO 620
      JM = MM
C MCP LIMITS THE VALUE OF NCP PERMITTED BEFORE AN ERROR RETURN RESULTS.
      MCP = NCP + 20
C REMOVE OLD COLUMN
      LENU = LENU - IW(JM,2)
      KP = IP(JM,2)
      IM = IND(KP,1)
      KL = KP + IW(JM,2) - 1
      IW(JM,2) = 0
      DO 30 K=KP,KL
         I = IND(K,1)
         IND(K,1) = 0
         KR = IP(I,1)
         NZ = IW(I,1) - 1
         IW(I,1) = NZ
         KRL = KR + NZ
         DO 10 KM=KR,KRL
            IF (IND(KM,2).EQ.JM) GO TO 20
   10    CONTINUE
   20    A(KM) = A(KRL)
         IND(KM,2) = IND(KRL,2)
         IND(KRL,2) = 0
   30 CONTINUE
C
C INSERT NEW COLUMN
      DO 110 II=1,N
         I = IW(II,3)
         IF (I.EQ.IM) M = II
         IF (DABS(W(I)).LE.SMALL) GO TO 100
         LENU = LENU + 1
         LAST = II
         IF (LCOL+LENL.LT.IA) GO TO 40
C COMPRESS COLUMN FILE IF NECESSARY.
         IF (NCP.GE.MCP .OR. LENL+LENU.GE.IA) GO TO 610
         CALL LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.)
   40    LCOL = LCOL + 1
         NZ = IW(JM,2)
         IF (NZ.EQ.0) IP(JM,2) = LCOL
         IW(JM,2) = NZ + 1
         IND(LCOL,1) = I
         NZ = IW(I,1)
         KPL = IP(I,1) + NZ
         IF (KPL.GT.LROW) GO TO 50
         IF (IND(KPL,2).EQ.0) GO TO 90
C NEW ENTRY HAS TO BE CREATED.
   50    IF (LENL+LROW+NZ.LT.IA) GO TO 60
         IF (NCP.GE.MCP .OR. LENL+LENU+NZ.GE.IA) GO TO 610
C COMPRESS ROW FILE IF NECESSARY.
         CALL LA05ES(A, IND(1,2), IP, N, IW, IA, .TRUE.)
   60    KP = IP(I,1)
         IP(I,1) = LROW + 1
         IF (NZ.EQ.0) GO TO 80
         KPL = KP + NZ - 1
         DO 70 K=KP,KPL
            LROW = LROW + 1
            A(LROW) = A(K)
            IND(LROW,2) = IND(K,2)
            IND(K,2) = 0
   70    CONTINUE
   80    LROW = LROW + 1
         KPL = LROW
C PLACE NEW ELEMENT AT END OF ROW.
   90    IW(I,1) = NZ + 1
         A(KPL) = W(I)
         IND(KPL,2) = JM
  100    W(I) = 0.
  110 CONTINUE
      IF (IW(IM,1).EQ.0 .OR. IW(JM,2).EQ.0 .OR. M.GT.LAST) GO TO 590
C
C FIND COLUMN SINGLETONS, OTHER THAN THE SPIKE. NON-SINGLETONS ARE
C     MARKED WITH W(J)=1. ONLY IW(.,3) IS REVISED AND IW(.,4) IS USED
C     FOR WORKSPACE.
      INS = M
      M1 = M
      W(JM) = 1.
      DO 140 II=M,LAST
         I = IW(II,3)
         J = IW(II,4)
         IF (W(J).EQ.0.) GO TO 130
         KP = IP(I,1)
         KL = KP + IW(I,1) - 1
         DO 120 K=KP,KL
            J = IND(K,2)
            W(J) = 1.
  120    CONTINUE
         IW(INS,4) = I
         INS = INS + 1
         GO TO 140
C PLACE SINGLETONS IN NEW POSITION.
  130    IW(M1,3) = I
         M1 = M1 + 1
  140 CONTINUE
C PLACE NON-SINGLETONS IN NEW POSITION.
      IJ = M + 1
      DO 150 II=M1,LAST
         IW(II,3) = IW(IJ,4)
         IJ = IJ + 1
  150 CONTINUE
C PLACE SPIKE AT END.
      IW(LAST,3) = IM
C
C FIND ROW SINGLETONS, APART FROM SPIKE ROW. NON-SINGLETONS ARE MARKED
C     WITH W(I)=2. AGAIN ONLY IW(.,3) IS REVISED AND IW(.,4) IS USED
C     FOR WORKSPACE.
      LAST1 = LAST
      JNS = LAST
      W(IM) = 2.
      J = JM
      DO 180 IJ=M1,LAST
         II = LAST + M1 - IJ
         I = IW(II,3)
         IF (W(I).NE.2.) GO TO 170
         K = IP(I,1)
         IF (II.NE.LAST) J = IND(K,2)
         KP = IP(J,2)
         KL = KP + IW(J,2) - 1
         IW(JNS,4) = I
         JNS = JNS - 1
         DO 160 K=KP,KL
            I = IND(K,1)
            W(I) = 2.
  160    CONTINUE
         GO TO 180
  170    IW(LAST1,3) = I
         LAST1 = LAST1 - 1
  180 CONTINUE
      DO 190 II=M1,LAST1
         JNS = JNS + 1
         I = IW(JNS,4)
         W(I) = 3.
         IW(II,3) = I
  190 CONTINUE
C
C DEAL WITH SINGLETON SPIKE COLUMN. NOTE THAT BUMP ROWS ARE MARKED BY
C    W(I)=3.
      DO 230 II=M1,LAST1
         KP = IP(JM,2)
         KL = KP + IW(JM,2) - 1
         IS = 0
         DO 200 K=KP,KL
            L = IND(K,1)
            IF (W(L).NE.3.) GO TO 200
            IF (IS.NE.0) GO TO 240
            I = L
            KNP = K
            IS = 1
  200    CONTINUE
         IF (IS.EQ.0) GO TO 590
C MAKE A(I,JM) A PIVOT.
         IND(KNP,1) = IND(KP,1)
         IND(KP,1) = I
         KP = IP(I,1)
         DO 210 K=KP,IA
            IF (IND(K,2).EQ.JM) GO TO 220
  210    CONTINUE
  220    AM = A(KP)
         A(KP) = A(K)
         A(K) = AM
         IND(K,2) = IND(KP,2)
         IND(KP,2) = JM
         JM = IND(K,2)
         IW(II,4) = I
         W(I) = 2.
  230 CONTINUE
      II = LAST1
      GO TO 260
  240 IN = M1
      DO 250 IJ=II,LAST1
         IW(IJ,4) = IW(IN,3)
         IN = IN + 1
  250 CONTINUE
  260 LAST2 = LAST1 - 1
      IF (M1.EQ.LAST1) GO TO 570
      DO 270 I=M1,LAST2
         IW(I,3) = IW(I,4)
  270 CONTINUE
      M1 = II
      IF (M1.EQ.LAST1) GO TO 570
C
C CLEAR W
      DO 280 I=1,N
         W(I) = 0.
  280 CONTINUE
C
C PERFORM ELIMINATION
      IR = IW(LAST1,3)
      DO 560 II=M1,LAST1
         IPP = IW(II,3)
         KP = IP(IPP,1)
         KR = IP(IR,1)
         JP = IND(KP,2)
         IF (II.EQ.LAST1) JP = JM
C SEARCH NON-PIVOT ROW FOR ELEMENT TO BE ELIMINATED.
C  AND BRING IT TO FRONT OF ITS ROW
         KRL = KR + IW(IR,1) - 1
         DO 290 KNP=KR,KRL
            IF (JP.EQ.IND(KNP,2)) GO TO 300
  290    CONTINUE
         IF (II-LAST1) 560, 590, 560
C BRING ELEMENT TO BE ELIMINATED TO FRONT OF ITS ROW.
  300    AM = A(KNP)
         A(KNP) = A(KR)
         A(KR) = AM
         IND(KNP,2) = IND(KR,2)
         IND(KR,2) = JP
         IF (II.EQ.LAST1) GO TO 310
         IF (DABS(A(KP)).LT.U*DABS(AM)) GO TO 310
         IF (DABS(AM).LT.U*DABS(A(KP))) GO TO 340
         IF (IW(IPP,1).LE.IW(IR,1)) GO TO 340
C PERFORM INTERCHANGE
  310    IW(LAST1,3) = IPP
         IW(II,3) = IR
         IR = IPP
         IPP = IW(II,3)
         K = KR
         KR = KP
         KP = K
         KJ = IP(JP,2)
         DO 320 K=KJ,IA
            IF (IND(K,1).EQ.IPP) GO TO 330
  320    CONTINUE
  330    IND(K,1) = IND(KJ,1)
         IND(KJ,1) = IPP
  340    IF (A(KP).EQ.0.) GO TO 590
         IF (II.EQ.LAST1) GO TO 560
         AM = -A(KR)/A(KP)
C COMPRESS ROW FILE UNLESS IT IS CERTAIN THAT THERE IS ROOM FOR NEW ROW.
         IF (LROW+IW(IR,1)+IW(IPP,1)+LENL.LE.IA) GO TO 350
         IF (NCP.GE.MCP .OR. LENU+IW(IR,1)+IW(IPP,1)+LENL.GT.IA) GO TO
     *    610
         CALL LA05ES(A, IND(1,2), IP, N, IW, IA, .TRUE.)
         KP = IP(IPP,1)
         KR = IP(IR,1)
  350    KRL = KR + IW(IR,1) - 1
         KQ = KP + 1
         KPL = KP + IW(IPP,1) - 1
C PLACE PIVOT ROW (EXCLUDING PIVOT ITSELF) IN W.
         IF (KQ.GT.KPL) GO TO 370
         DO 360 K=KQ,KPL
            J = IND(K,2)
            W(J) = A(K)
  360    CONTINUE
  370    IP(IR,1) = LROW + 1
C
C TRANSFER MODIFIED ELEMENTS.
         IND(KR,2) = 0
         KR = KR + 1
         IF (KR.GT.KRL) GO TO 430
         DO 420 KS=KR,KRL
            J = IND(KS,2)
            AU = A(KS) + AM*W(J)
            IND(KS,2) = 0
C IF ELEMENT IS VERY SMALL REMOVE IT FROM U.
            IF (DABS(AU).LE.SMALL) GO TO 380
            G = DMAX1(G,DABS(AU))
            LROW = LROW + 1
            A(LROW) = AU
            IND(LROW,2) = J
            GO TO 410
  380       LENU = LENU - 1
C REMOVE ELEMENT FROM COL FILE.
            K = IP(J,2)
            KL = K + IW(J,2) - 1
            IW(J,2) = KL - K
            DO 390 KK=K,KL
               IF (IND(KK,1).EQ.IR) GO TO 400
  390       CONTINUE
  400       IND(KK,1) = IND(KL,1)
            IND(KL,1) = 0
  410       W(J) = 0.
  420    CONTINUE
C
C SCAN PIVOT ROW FOR FILLS.
  430    IF (KQ.GT.KPL) GO TO 520
         DO 510 KS=KQ,KPL
            J = IND(KS,2)
            AU = AM*W(J)
            IF (DABS(AU).LE.SMALL) GO TO 500
            LROW = LROW + 1
            A(LROW) = AU
            IND(LROW,2) = J
            LENU = LENU + 1
C
C CREATE FILL IN COLUMN FILE.
            NZ = IW(J,2)
            K = IP(J,2)
            KL = K + NZ - 1
C IF POSSIBLE PLACE NEW ELEMENT AT END OF PRESENT ENTRY.
            IF (KL.NE.LCOL) GO TO 440
            IF (LCOL+LENL.GE.IA) GO TO 460
            LCOL = LCOL + 1
            GO TO 450
  440       IF (IND(KL+1,1).NE.0) GO TO 460
  450       IND(KL+1,1) = IR
            GO TO 490
C NEW ENTRY HAS TO BE CREATED.
  460       IF (LCOL+LENL+NZ+1.LT.IA) GO TO 470
C COMPRESS COLUMN FILE IF THERE IS NOT ROOM FOR NEW ENTRY.
            IF (NCP.GE.MCP .OR. LENU+LENL+NZ+1.GE.IA) GO TO 610
            CALL LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.)
            K = IP(J,2)
            KL = K + NZ - 1
C TRANSFER OLD ENTRY INTO NEW.
  470       IP(J,2) = LCOL + 1
            DO 480 KK=K,KL
               LCOL = LCOL + 1
               IND(LCOL,1) = IND(KK,1)
               IND(KK,1) = 0
  480       CONTINUE
C ADD NEW ELEMENT.
            LCOL = LCOL + 1
            IND(LCOL,1) = IR
  490       G = DMAX1(G,DABS(AU))
            IW(J,2) = NZ + 1
  500       W(J) = 0.
  510    CONTINUE
  520    IW(IR,1) = LROW + 1 - IP(IR,1)
C
C STORE MULTIPLIER
         IF (LENL+LCOL+1.LE.IA) GO TO 530
C COMPRESS COL FILE IF NECESSARY.
         IF (NCP.GE.MCP) GO TO 610
         CALL LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.)
  530    K = IA - LENL
         LENL = LENL + 1
         A(K) = AM
         IND(K,1) = IPP
         IND(K,2) = IR
C CREATE BLANK IN PIVOTAL COLUMN.
         KP = IP(JP,2)
         NZ = IW(JP,2) - 1
         KL = KP + NZ
         DO 540 K=KP,KL
            IF (IND(K,1).EQ.IR) GO TO 550
  540    CONTINUE
  550    IND(K,1) = IND(KL,1)
         IW(JP,2) = NZ
         IND(KL,1) = 0
         LENU = LENU - 1
  560 CONTINUE
C
C CONSTRUCT COLUMN PERMUTATION AND STORE IT IN IW(.,4)
  570 DO 580 II=M,LAST
         I = IW(II,3)
         K = IP(I,1)
         J = IND(K,2)
         IW(II,4) = J
  580 CONTINUE
      GO TO 630
C
C     THE FOLLOWING INSTRUCTIONS IMPLEMENT THE FAILURE EXITS.
  590 IF (LP.LE.0) GO TO 600
      NERR = -6
      IOPT = 1
      NI = 1
      NR = 0
      CALL XERRWV(
     *'LA05CS. SING. MATRIX AFTER REPLACEMENT OF COL.  HERE I1=INDEX.',
     * 62, NERR, IOPT, NI, MM, IDUMMY, NR, DUMMY, DUMMY)
  600 CONTINUE
      G = -6.
      GO TO 630
  610 CONTINUE
      NERR = -7
      IOPT = 1
      IF (LP.GT.0) CALL XERROR(
     * 'LA05CS. LENGTHS OF ARRAYS A(*) AND IND(*,2) ARE TOO SMALL.',
     * 58, NERR, IOPT)
      G = -7.
      GO TO 630
  620 CONTINUE
      NERR = 0
      IOPT = 1
      IF (LP.GT.0) CALL XERROR(
     * 'LA05CS. EARLIER ENTRY GAVE ERROR RETURN.', 40, NERR, IOPT)
  630 RETURN
      END
      SUBROUTINE LA05ES(A, IRN, IP, N, IW, IA, REALS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  LA05ES
C***REFER TO  SPLP
C     THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
C     FROM THE C. 1979 AERE HARWELL LIBRARY.  THE NAME OF THE
C     CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
C     THE FINAL LETTER =S= IN THE NAMES USED HERE.
C     REVISED SEP. 13, 1979.
C
C     ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
C     IN THE PACKAGE GIVEN HERE.  ANY PRIMARY USAGE OF THE HARWELL
C     SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
C     THE USER AND AERE-UK.  ANY USAGE OF THE SANDIA WRITTEN CODES
C     SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
C***ROUTINES CALLED  (NONE)
C***COMMON BLOCKS    LA05DS
C***END PROLOGUE  LA05ES
      LOGICAL REALS
      DOUBLE PRECISION A(IA)
      INTEGER IRN(IA), IW(N)
      INTEGER IP(N)
      COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL
C***FIRST EXECUTABLE STATEMENT  LA05ES
      NCP = NCP + 1
C     COMPRESS FILE OF POSITIVE INTEGERS. ENTRY J STARTS AT IRN(IP(J))
C  AND CONTAINS IW(J) INTEGERS,J=1,N. OTHER COMPONENTS OF IRN ARE ZERO.
C  LENGTH OF COMPRESSED FILE PLACED IN LROW IF REALS IS .TRUE. OR LCOL
C  OTHERWISE.
C  IF REALS IS .TRUE. ARRAY A CONTAINS A REAL FILE ASSOCIATED WITH IRN
C  AND THIS IS COMPRESSED TOO.
C  A,IRN,IP,IW,IA ARE INPUT/OUTPUT VARIABLES.
C  N,REALS ARE INPUT/UNCHANGED VARIABLES.
C
      DO 10 J=1,N
C STORE THE LAST ELEMENT OF ENTRY J IN IW(J) THEN OVERWRITE IT BY -J.
         NZ = IW(J)
         IF (NZ.LE.0) GO TO 10
         K = IP(J) + NZ - 1
         IW(J) = IRN(K)
         IRN(K) = -J
   10 CONTINUE
C KN IS THE POSITION OF NEXT ENTRY IN COMPRESSED FILE.
      KN = 0
      IPI = 0
      KL = LCOL
      IF (REALS) KL = LROW
C LOOP THROUGH THE OLD FILE SKIPPING ZERO (DUMMY) ELEMENTS AND
C     MOVING GENUINE ELEMENTS FORWARD. THE ENTRY NUMBER BECOMES
C     KNOWN ONLY WHEN ITS END IS DETECTED BY THE PRESENCE OF A NEGATIVE
C     INTEGER.
      DO 30 K=1,KL
         IF (IRN(K).EQ.0) GO TO 30
         KN = KN + 1
         IF (REALS) A(KN) = A(K)
         IF (IRN(K).GE.0) GO TO 20
C END OF ENTRY. RESTORE IRN(K), SET POINTER TO START OF ENTRY AND
C     STORE CURRENT KN IN IPI READY FOR USE WHEN NEXT LAST ENTRY
C     IS DETECTED.
         J = -IRN(K)
         IRN(K) = IW(J)
         IP(J) = IPI + 1
         IW(J) = KN - IPI
         IPI = KN
   20    IRN(KN) = IRN(K)
   30 CONTINUE
      IF (REALS) LROW = KN
      IF (.NOT.REALS) LCOL = KN
      RETURN
      END
      SUBROUTINE PCHNGS(II,XVAL,IPLACE,SX,IX,IRCX)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  PCHNGS
C***REFER TO  SPLP
C     THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LCHNGS,
C     SANDIA LABS. REPT. SAND78-0785.
C     PCHNGS LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME.
C     MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON
C     REVISED 811130-1000
C     REVISED YYMMDD-HHMM
C     SPARSE MATRIX ELEMENT ALTERATION SUBROUTINE.
C     AUTHORS JOHN A. WISNIEWSKI AND R.J. HANSON
C
C     SUBROUTINE PCHNGS() CHANGES ELEMENT II IN VECTOR +/- IRCX TO THE
C     VALUE XVAL.
C
C            II THE ABSOLUTE VALUE OF THIS INTEGER IS THE SUBSCRIPT FOR
C               THE ELEMENT TO BE CHANGED.
C          XVAL NEW VALUE OF THE MATRIX ELEMENT BEING CHANGED.
C     IPLACE POINTER INFORMATION WHICH IS MAINTAINED BY THE PACKAGE.
C   SX(*),IX(*) THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE
C               MATRIX. THESE ARRAYS ARE AUTOMATICALLY MAINTAINED BY THE
C               PACKAGE FOR THE USER.
C          IRCX POINTS TO THE VECTOR OF THE MATRIX BEING UPDATED.
C               A NEGATIVE VALUE OF IRCX INDICATES THAT ROW -IRCX IS
C               BEING UPDATED.  A POSITIVE VALUE OF IRCX INDICATES THAT
C               COLUMN IRCX IS BEING UPDATED.  A ZERO VALUE OF IRCX IS
C               AN ERROR.
C
C     SINCE DATA ITEMS ARE KEPT SORTED IN THE SEQUENTIAL DATA STRUCTURE,
C     CHANGING A MATRIX ELEMENT CAN REQUIRE THE MOVEMENT OF ALL THE DATA
C     ITEMS IN THE MATRIX. FOR THIS REASON, IT IS SUGGESTED THAT DATA
C     ITEMS BE ADDED A COL. AT A TIME, IN ASCENDING COL. SEQUENCE.
C     FURTHERMORE, SINCE DELETING ITEMS FROM THE DATA STRUCTURE MAY ALSO
C     REQUIRE MOVING LARGE AMOUNTS OF DATA, ZERO ELEMENTS ARE EXPLICITLY
C     STORED IN THE MATRIX.
C
C***ROUTINES CALLED  IPLOC,PRWPGE,XERROR
C***END PROLOGUE  PCHNGS
      DIMENSION IX(*)
      INTEGER IPLOC
      DOUBLE PRECISION SX(*),XVAL,ZERO,ONE,SXLAST,SXVAL
      DATA ZERO,ONE /0.D0,1.D0/
C***FIRST EXECUTABLE STATEMENT  PCHNGS
      IOPT=1
C
C     DETERMINE NULL-CASES..
      IF(II.EQ.0) RETURN
C
C     CHECK VALIDITY OF ROW/COL. INDEX.
C
      IF (.NOT.(IRCX.EQ.0)) GO TO 20002
      NERR=55
      CALL XERROR('0IN PCHNGS(), IRCX=0.',21,NERR,IOPT)
20002 LMX = IX(1)
C
C     LMX IS THE LENGTH OF THE IN-MEMORY STORAGE AREA.
C
      IF (.NOT.(IRCX.LT.0)) GO TO 20005
C
C     CHECK SUBSCRIPTS OF THE ROW. THE ROW NUMBER MUST BE .LE. M AND
C     THE INDEX MUST BE .LE. N.
C
      IF (.NOT.(IX(2).LT.-IRCX .OR. IX(3).LT.IDABS(II))) GO TO 20008
      NERR=55
      CALL XERROR(  '0IN PCHNGS() SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACC
     *ESSED WERE OUT OF BOUNDS.',76,NERR,IOPT)
20008 GO TO 20006
C
C     CHECK SUBSCRIPTS OF THE COLUMN. THE COL. NUMBER MUST BE .LE. N AND
C     THE INDEX MUST BE .LE. M.
C
20005 IF (.NOT.(IX(3).LT.IRCX .OR. IX(2).LT.IDABS(II))) GO TO 20011
      NERR=55
      CALL XERROR(  '0IN PCHNGS() SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACC
     *ESSED WERE OUT OF BOUNDS.',76,NERR,IOPT)
20011 CONTINUE
C
C     SET I TO BE THE ELEMENT OF ROW/COLUMN J TO BE CHANGED.
C
20006 IF (.NOT.(IRCX.GT.0)) GO TO 20014
      I = IDABS(II)
      J = IDABS(IRCX)
      GO TO 20015
20014 I = IDABS(IRCX)
      J = IDABS(II)
C
C     THE INTEGER LL POINTS TO THE START OF THE MATRIX ELEMENT DATA.
C
20015 LL=IX(3)+4
      II = IDABS(II)
      LPG = LMX - LL
C
C     SET IPLACE TO START OUR SCAN FOR THE ELEMENT AT THE BEGINNING
C     OF THE VECTOR.
C
      IF (.NOT.(J.EQ.1)) GO TO 20017
      IPLACE=LL+1
      GO TO 20018
20017 IPLACE=IX(J+3)+1
C
C     IEND POINTS TO THE LAST ELEMENT OF THE VECTOR TO BE SCANNED.
C
20018 IEND = IX(J+4)
C
C     SCAN THROUGH SEVERAL PAGES, IF NECESSARY, TO FIND MATRIX ELEMENT.
C
      IPL = IPLOC(IPLACE,SX,IX)
      NP = IDABS(IX(LMX-1))
      GO TO 20021
20020 IF (ILAST.EQ.IEND) GO TO 20022
C
C     THE VIRTUAL END OF DATA FOR THIS PAGE IS ILAST.
C
20021 ILAST = MIN0(IEND,NP*LPG+LL-2)
C
C     THE RELATIVE END OF DATA FOR THIS PAGE IS IL.
C     SEARCH FOR A MATRIX VALUE WITH AN INDEX .GE. I ON THE PRESENT
C     PAGE.
C
      IL = IPLOC(ILAST,SX,IX)
      IL = MIN0(IL,LMX-2)
20023 IF (.NOT.(.NOT.(IPL.GE.IL .OR. IX(IPL).GE.I))) GO TO 20024
      IPL=IPL+1
      GO TO 20023
C
C     SET IPLACE AND STORE DATA ITEM IF FOUND.
C
20024 IF (.NOT.(IX(IPL).EQ.I .AND. IPL.LE.IL)) GO TO 20025
      SX(IPL) = XVAL
      SX(LMX) = ONE
      RETURN
C
C     EXIT FROM LOOP IF ITEM WAS FOUND.
C
20025 IF(IX(IPL).GT.I .AND. IPL.LE.IL) ILAST = IEND
      IF (.NOT.(ILAST.NE.IEND)) GO TO 20028
      IPL = LL + 1
      NP = NP + 1
20028 GO TO 20020
C
C     INSERT NEW DATA ITEM INTO LOCATION AT IPLACE(IPL).
C
20022 IF (.NOT.(IPL.GT.IL.OR.(IPL.EQ.IL.AND.I.GT.IX(IPL)))) GO TO 20031
      IPL = IL + 1
      IF(IPL.EQ.LMX-1) IPL = IPL + 2
20031 IPLACE = (NP-1)*LPG + IPL
C
C     GO TO A NEW PAGE, IF NECESSARY, TO INSERT THE ITEM.
C
      IF (.NOT.(IPL.LE.LMX .OR. IX(LMX-1).GE.0)) GO TO 20034
      IPL=IPLOC(IPLACE,SX,IX)
20034 IEND = IX(LL)
      NP = IDABS(IX(LMX-1))
      SXVAL = XVAL
C
C     LOOP THROUGH ALL SUBSEQUENT PAGES OF THE MATRIX MOVING DATA DOWN.
C     THIS IS NECESSARY TO MAKE ROOM FOR THE NEW MATRIX ELEMENT AND
C     KEEP THE ENTRIES SORTED.
C
      GO TO 20038
20037 IF (IX(LMX-1).LE.0) GO TO 20039
20038 ILAST = MIN0(IEND,NP*LPG+LL-2)
      IL = IPLOC(ILAST,SX,IX)
      IL = MIN0(IL,LMX-2)
      SXLAST = SX(IL)
      IXLAST = IX(IL)
      ISTART = IPL + 1
      IF (.NOT.(ISTART.LE.IL)) GO TO 20040
      K = ISTART + IL
      DO 50 JJ=ISTART,IL
      SX(K-JJ) = SX(K-JJ-1)
      IX(K-JJ) = IX(K-JJ-1)
50    CONTINUE
      SX(LMX) = ONE
20040 IF (.NOT.(IPL.LE.LMX)) GO TO 20043
      SX(IPL) = SXVAL
      IX(IPL) = I
      SXVAL = SXLAST
      I = IXLAST
      SX(LMX) = ONE
      IF (.NOT.(IX(LMX-1).GT.0)) GO TO 20046
      IPL = LL + 1
      NP = NP + 1
20046 CONTINUE
20043 GO TO 20037
20039 NP = IDABS(IX(LMX-1))
C
C     DETERMINE IF A NEW PAGE IS TO BE CREATED FOR THE LAST ELEMENT
C     MOVED DOWN.
C
      IL = IL + 1
      IF (.NOT.(IL.EQ.LMX-1)) GO TO 20049
C
C     CREATE A NEW PAGE.
C
      IX(LMX-1) = NP
C
C     WRITE THE OLD PAGE.
C
      SX(LMX) = ZERO
      KEY = 2
      CALL PRWPGE(KEY,NP,LPG,SX,IX)
      SX(LMX) = ONE
C
C     STORE LAST ELEMENT MOVED DOWN IN A NEW PAGE.
C
      IPL = LL + 1
      NP = NP + 1
      IX(LMX-1) = -NP
      SX(IPL) = SXVAL
      IX(IPL) = I
      GO TO 20050
C
C     LAST ELEMENT MOVED REMAINED ON THE OLD PAGE.
C
20049 IF (.NOT.(IPL.NE.IL)) GO TO 20052
      SX(IL) = SXVAL
      IX(IL) = I
      SX(LMX) = ONE
20052 CONTINUE
C
C     INCREMENT POINTERS TO LAST ELEMENT IN VECTORS J,J+1,... .
C
20050 JSTART = J + 4
      JJ=JSTART
      N20055=LL
      GO TO 20056
20055 JJ=JJ+1
20056 IF ((N20055-JJ).LT.0) GO TO 20057
      IX(JJ) = IX(JJ) + 1
      IF(MOD(IX(JJ)-LL,LPG).EQ.LPG-1) IX(JJ) = IX(JJ) + 2
      GO TO 20055
C
C     IPLACE POINTS TO THE INSERTED DATA ITEM.
C
20057 IPL=IPLOC(IPLACE,SX,IX)
      RETURN
      END
      SUBROUTINE PINITM(M,N,SX,IX,LMX,IPAGEF)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  PINITM
C***REFER TO  SPLP
C     THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LINITM,
C     SANDIA LABS. REPT. SAND78-0785.
C     PINITM LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME.
C     THE MATRIX IS STORED BY COLUMNS.
C     MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON
C     REVISED 811130-1000
C     REVISED YYMMDD-HHMM
C     SPARSE MATRIX INITIALIZATION SUBROUTINE.
C     AUTHORS JOHN A. WISNIEWSKI AND R.J. HANSON
C
C            M=NUMBER OF ROWS OF THE MATRIX.
C            N=NUMBER OF COLUMNS OF THE MATRIX.
C  SX(*),IX(*)=THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE
C              MATRIX.  THESE ARRAYS ARE AUTOMATICALLY MAINTAINED BY
C              THE PACKAGE FOR THE USER.
C          LMX=LENGTH OF THE WORK ARRAY SX(*).
C              LMX MUST BE AT LEAST N+7 WHERE
C              FOR GREATEST EFFICIENCY LMX SHOULD BE AT LEAST N+NZ+6
C              WHERE NZ IS THE MAXIMUM NUMBER OF NONZEROES TO BE
C              STORED IN THE MATRIX.  VALUES OF LMX BETWEEN N+7 AND
C              N+NZ+6 WILL CAUSE DEMAND PAGING TO OCCUR.
C              THIS IS IMPLEMENTED BY THE PACKAGE.
C              IX(*) MUST BE DIMENSIONED AT LEAST LMX
C      IPAGEF=UNIT NUMBER WHERE DEMAND PAGES WILL BE STORED.
C
C     EXTERNAL REFERENCES   XERROR
C
C***ROUTINES CALLED  XERROR
C***END PROLOGUE  PINITM
      DOUBLE PRECISION SX(LMX),ZERO,ONE
      DIMENSION IX(LMX)
      DATA ZERO,ONE /0.D0,1.D0/
C***FIRST EXECUTABLE STATEMENT  PINITM
      IOPT=1
C
C     CHECK FOR INPUT ERRORS.
C
      IF (.NOT.(M.LE.0 .OR. N.LE.0)) GO TO 20002
      NERR=55
      CALL XERROR(  '0IN PINITM() MATRIX DIMENSION M OR N .LE. 0.',44,
     *NERR,IOPT)
C
C     VERIFY IF VALUE OF LMX IS LARGE ENOUGH.
C
20002 IF (.NOT.(LMX.LT.N+7)) GO TO 20005
      NERR=55
      CALL XERROR(  '0IN PINITM() THE VALUE OF LMX IS TOO SMALL.',43,
     *NERR,IOPT)
C
C     INITIALIZE DATA STRUCTURE INDEPENDENT VALUES.
C
20005 SX(1)=ZERO
      SX(2)=ZERO
      SX(3)=IPAGEF
      IX(1)=LMX
      IX(2)=M
      IX(3)=N
      IX(4)=0
      SX(LMX-1)=ZERO
      SX(LMX)=-ONE
      IX(LMX-1)=-1
      LP4=N+4
C
C     INITIALIZE DATA STRUCTURE DEPENDENT VALUES.
C
      I=4
      N20008=LP4
      GO TO 20009
20008 I=I+1
20009 IF ((N20008-I).LT.0) GO TO 20010
      SX(I)=ZERO
      GO TO 20008
20010 I=5
      N20012=LP4
      GO TO 20013
20012 I=I+1
20013 IF ((N20012-I).LT.0) GO TO 20014
      IX(I)=LP4
      GO TO 20012
20014 SX(N+5)=ZERO
      IX(N+5)=0
      IX(LMX)=0
C
C     INITIALIZATION COMPLETE.
C
      RETURN
      END
      SUBROUTINE PNNZRS(I,XVAL,IPLACE,SX,IX,IRCX)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  PNNZRS
C***REFER TO  SPLP
C     THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LNNZRS,
C     SANDIA LABS. REPT. SAND78-0785.
C     PNNZRS LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME.
C     MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON
C     REVISED 811130-1000
C     REVISED YYMMDD-HHMM
C     SPARSE MATRIX NON ZERO RETRIEVAL SUBROUTINE.
C     AUTHORS JOHN A. WISNIEWSKI AND R. J. HANSON
C
C     SUBROUTINE PNNZRS() GETS THE NEXT NONZERO VALUE IN ROW OR COLUMN
C     +/- IRCX WITH AN INDEX GREATER THAN THE VALUE OF I.
C
C             I ABSOLUTE VALUE OF THIS SUBSCRIPT IS TO BE EXCEEDED
C               IN THE SEARCH FOR THE NEXT NONZERO VALUE. A NEGATIVE
C               OR ZERO VALUE OF I CAUSES THE SEARCH TO START AT
C               THE BEGINNING OF THE VECTOR.  A POSITIVE VALUE
C               OF I CAUSES THE SEARCH TO CONTINUE FROM THE LAST PLACE
C               ACCESSED. ON OUTPUT, THE ARGUMENT I
C               CONTAINS THE VALUE OF THE SUBSCRIPT FOUND.  AN OUTPUT
C               VALUE OF I EQUAL TO ZERO INDICATES THAT ALL COMPONENTS
C               WITH AN INDEX GREATER THAN THE INPUT VALUE OF I ARE
C               ZERO.
C          XVAL VALUE OF THE NONZERO ELEMENT FOUND.  ON OUTPUT,
C               XVAL=0. WHENEVER I=0.
C     IPLACE POINTER INFORMATION WHICH IS MAINTAINED BY THE PACKAGE.
C   SX(*),IX(*) THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE
C               MATRIX.  THESE ARRAY CONTENTS ARE AUTOMATICALLY
C               MAINTAINED BY THE PACKAGE FOR THE USER.
C          IRCX POINTS TO THE VECTOR OF THE MATRIX BEING SCANNED.  A
C               NEGATIVE VALUE OF IRCX INDICATES THAT ROW -IRCX IS TO BE
C               SCANNED.  A POSITIVE VALUE OF IRCX INDICATES THAT
C               COLUMN IRCX IS TO BE SCANNED.  A ZERO VALUE OF IRCX IS
C               AN ERROR.
C
C***ROUTINES CALLED  IPLOC,XERROR
C***END PROLOGUE  PNNZRS
      DIMENSION IX(*)
      DOUBLE PRECISION XVAL,SX(*),ZERO
      DATA ZERO /0.D0/
C***FIRST EXECUTABLE STATEMENT  PNNZRS
      IOPT=1
C
C     CHECK VALIDITY OF ROW/COL. INDEX.
C
      IF (.NOT.(IRCX .EQ.0)) GO TO 20002
      NERR=55
      CALL XERROR('0IN PNNZRS(), IRCX=0.',21,NERR,IOPT)
C
C     LMX IS THE LENGTH OF THE IN-MEMORY STORAGE AREA.
C
20002 LMX = IX(1)
      IF (.NOT.(IRCX.LT.0)) GO TO 20005
C
C     CHECK SUBSCRIPTS OF THE ROW. THE ROW NUMBER MUST BE .LE. M AND
C     THE INDEX MUST BE .LE. N.
C
      IF (.NOT.(IX(2).LT.-IRCX .OR. IX(3).LT.IDABS(I))) GO TO 20008
      NERR=55
      CALL XERROR(  '0IN PNNZRS() SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACC
     *ESSED WERE OUT OF BOUNDS.',76,NERR,IOPT)
20008 L=IX(3)
      GO TO 20006
C
C     CHECK SUBSCRIPTS OF THE COLUMN. THE COL. NUMBER MUST BE .LE. N AND
C     THE INDEX MUST BE .LE. M.
C
20005 IF (.NOT.(IRCX.GT.IX(3) .OR. IDABS(I).GT.IX(2))) GO TO 20011
      NERR=55
      CALL XERROR(  '0IN PNNZRS() SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACC
     *ESSED WERE OUT OF BOUNDS.',76,NERR,IOPT)
20011 L=IX(2)
C
C     HERE L IS THE LARGEST POSSIBLE SUBSCRIPT WITHIN THE VECTOR.
C
20006 J=IDABS(IRCX)
      LL=IX(3)+4
      LPG = LMX - LL
      IF (.NOT.(IRCX.GT.0)) GO TO 20014
C
C     SEARCHING FOR THE NEXT NONZERO IN A COLUMN.
C
C     INITIALIZE STARTING LOCATIONS..
      IF (.NOT.(I.LE.0)) GO TO 20017
      IF (.NOT.(J.EQ.1)) GO TO 20020
      IPLACE=LL+1
      GO TO 20021
20020 IPLACE=IX(J+3)+1
20021 CONTINUE
C
C     THE CASE I.LE.0 SIGNALS THAT THE SCAN FOR THE ENTRY
C     IS TO BEGIN AT THE START OF THE VECTOR.
C
20017 I = IDABS(I)
      IF (.NOT.(J.EQ.1)) GO TO 20023
      ISTART = LL+1
      GO TO 20024
20023 ISTART=IX(J+3)+1
20024 IEND = IX(J+4)
C
C     VALIDATE IPLACE. SET TO START OF VECTOR IF OUT OF RANGE.
C
      IF (.NOT.(ISTART.GT.IPLACE .OR. IPLACE.GT.IEND)) GO TO 20026
      IF (.NOT.(J.EQ.1)) GO TO 20029
      IPLACE=LL+1
      GO TO 20030
20029 IPLACE=IX(J+3)+1
20030 CONTINUE
C
C     SCAN THROUGH SEVERAL PAGES, IF NECESSARY, TO FIND MATRIX ENTRY.
C
20026 IPL = IPLOC(IPLACE,SX,IX)
C
C     FIX UP IPLACE AND IPL IF THEY POINT TO PAGING DATA.
C     THIS IS NECESSARY BECAUSE THERE IS CONTROL INFORMATION AT THE
C     END OF EACH PAGE.
C
      IDIFF = LMX - IPL
      IF (.NOT.(IDIFF.LE.1.AND.IX(LMX-1).GT.0)) GO TO 20032
C
C     UPDATE THE RELATIVE ADRESS IN A NEW PAGE.
C
      IPLACE = IPLACE + IDIFF + 1
      IPL = IPLOC(IPLACE,SX,IX)
20032 NP = IDABS(IX(LMX-1))
      GO TO 20036
20035 IF (ILAST.EQ.IEND) GO TO 20037
20036 ILAST = MIN0(IEND,NP*LPG+LL-2)
C
C     THE VIRTUAL END OF THE DATA FOR THIS PAGE IS ILAST.
C
      IL = IPLOC(ILAST,SX,IX)
      IL = MIN0(IL,LMX-2)
C
C     THE RELATIVE END OF DATA FOR THIS PAGE IS IL.
C     SEARCH FOR A NONZERO VALUE WITH AN INDEX .GT. I ON THE PRESENT
C     PAGE.
C
20038 IF (.NOT.(.NOT.(IPL.GE.IL.OR.(IX(IPL).GT.I.AND.SX(IPL).NE.ZERO))))
     * GO TO 20039
      IPL=IPL+1
      GO TO 20038
C
C     TEST IF WE HAVE FOUND THE NEXT NONZERO.
C
20039 IF (.NOT.(IX(IPL).GT.I .AND. SX(IPL).NE.ZERO .AND. IPL.LE.IL)) GO
     *TO 20040
      I = IX(IPL)
      XVAL = SX(IPL)
      IPLACE = (NP-1)*LPG + IPL
      RETURN
C
C     UPDATE TO SCAN THE NEXT PAGE.
20040 IPL = LL + 1
      NP = NP + 1
      GO TO 20035
C
C     NO DATA WAS FOUND. END OF VECTOR ENCOUNTERED.
C
20037 I = 0
      XVAL = ZERO
      IL = IL + 1
      IF(IL.EQ.LMX-1) IL = IL + 2
C
C     IF A NEW ITEM WOULD BE INSERTED, IPLACE POINTS TO THE PLACE
C     TO PUT IT.
C
      IPLACE = (NP-1)*LPG + IL
      RETURN
C
C     SEARCH A ROW FOR THE NEXT NONZERO.
C     FIND ELEMENT J=IDABS(IRCX) IN ROWS IDABS(I)+1,...,L.
C
20014 I=IDABS(I)
C
C     CHECK FOR END OF VECTOR.
C
      IF (.NOT.(I.EQ.L)) GO TO 20043
      I=0
      XVAL=ZERO
      RETURN
20043 I1 = I+1
      II=I1
      N20046=L
      GO TO 20047
20046 II=II+1
20047 IF ((N20046-II).LT.0) GO TO 20048
C
C     INITIALIZE IPPLOC FOR ORTHOGONAL SCAN.
C     LOOK FOR J AS A SUBSCRIPT IN ROWS II, II=I+1,...,L.
C
      IF (.NOT.(II.EQ.1)) GO TO 20050
      IPPLOC = LL + 1
      GO TO 20051
20050 IPPLOC = IX(II+3) + 1
20051 IEND = IX(II+4)
C
C     SCAN THROUGH SEVERAL PAGES, IF NECESSARY, TO FIND MATRIX ENTRY.
C
      IPL = IPLOC(IPPLOC,SX,IX)
C
C     FIX UP IPPLOC AND IPL TO POINT TO MATRIX DATA.
C
      IDIFF = LMX - IPL
      IF (.NOT.(IDIFF.LE.1.AND.IX(LMX-1).GT.0)) GO TO 20053
      IPPLOC = IPPLOC + IDIFF + 1
      IPL = IPLOC(IPPLOC,SX,IX)
20053 NP = IDABS(IX(LMX-1))
      GO TO 20057
20056 IF (ILAST.EQ.IEND) GO TO 20058
20057 ILAST = MIN0(IEND,NP*LPG+LL-2)
      IL = IPLOC(ILAST,SX,IX)
      IL = MIN0(IL,LMX-2)
20059 IF (.NOT.(.NOT.(IPL.GE.IL .OR. IX(IPL).GE.J))) GO TO 20060
      IPL=IPL+1
      GO TO 20059
C
C     TEST IF WE HAVE FOUND THE NEXT NONZERO.
C
20060 IF (.NOT.(IX(IPL).EQ.J .AND. SX(IPL).NE.ZERO .AND. IPL.LE.IL)) GO
     *TO 20061
      I = II
      XVAL = SX(IPL)
      RETURN
20061 IF(IX(IPL).GE.J) ILAST = IEND
      IPL = LL + 1
      NP = NP + 1
      GO TO 20056
20058 GO TO 20046
C
C     ORTHOGONAL SCAN FAILED. THE VALUE J WAS NOT A SUBSCRIPT
C     IN ANY ROW.
C
20048 I=0
      XVAL=ZERO
      RETURN
20015 CONTINUE
      END
      SUBROUTINE PRWPGE(KEY,IPAGE,LPG,SX,IX)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  PRWPGE
C***REFER TO  SPLP
C     THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LRWPGE,
C     SANDIA LABS. REPT. SAND78-0785.
C     PRWPGE LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME.
C     MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON
C     REVISED 811130-1000
C     REVISED YYMMDD-HHMM
C     VIRTUAL MEMORY PAGE READ/WRITE SUBROUTINE.
C     AUTHORS  J. A. WISNIEWSKI AND R.J. HANSON
C
C
C     DEPENDING ON THE VALUE OF KEY, SUBROUTINE PRWPGE() PERFORMS A PAGE
C     READ OR WRITE OF PAGE IPAGE. THE PAGE HAS LENGTH LPG.
C
C     KEY       IS A FLAG INDICATING WHETHER A PAGE READ OR WRITE IS
C               TO BE PERFORMED.
C               IF KEY = 1 DATA IS READ.
C               IF KEY = 2 DATA IS WRITTEN.
C     IPAGE     IS THE PAGE NUMBER OF THE MATRIX TO BE ACCESSED.
C     LPG       IS THE LENGTH OF THE PAGE OF THE MATRIX TO BE ACCESSED.
C   SX(*),IX(*) IS THE MATRIX TO BE ACCESSED.
C
C     EXTERNAL REFERENCES   XERROR,PRWVIR
C
C***ROUTINES CALLED  PRWVIR,XERROR
C***END PROLOGUE  PRWPGE
      DOUBLE PRECISION SX(*)
      DIMENSION IX(*)
C***FIRST EXECUTABLE STATEMENT  PRWPGE
      IOPT=1
C
C     CHECK IF IPAGE IS IN RANGE.
C
      IF (.NOT.(IPAGE.LT.1)) GO TO 20002
      CALL XERROR(  '0IN PRWPGE() THE VALUE OF IPAGE(PAGE NUMBER) WAS NO
     *T IN THE RANGE 1.LE.IPAGE.LE.MAXPGE.',87,NERR,IOPT)
C
C     CHECK IF LPG IS POSITIVE.
C
20002 IF (.NOT.(LPG.LE.0)) GO TO 20005
      NERR=55
      CALL XERROR(  '0IN PRWPGE() THE VALUE OF LPG(PAGE LENGTH) WAS NONP
     *OSITIVE.',59,NERR,IOPT)
C
C     DECIDE IF WE ARE READING OR WRITING.
C
20005 IF (.NOT.(KEY.EQ.1)) GO TO 20008
C
C     CODE TO DO A PAGE READ.
C
      CALL PRWVIR(KEY,IPAGE,LPG,SX,IX)
      GO TO 20009
20008 IF (.NOT.(KEY.EQ.2)) GO TO 10001
C
C     CODE TO DO A PAGE WRITE.
C
      CALL PRWVIR(KEY,IPAGE,LPG,SX,IX)
      GO TO 20009
10001 NERR=55
      CALL XERROR(  '0IN PRWPGE() THE VALUE OF KEY (READ-WRITE FLAG) WAS
     *NOT 0,1 OR 2.',66,NERR,IOPT)
20009 RETURN
      END
      SUBROUTINE PRWVIR(KEY,IPAGE,LPG,SX,IX)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  PRWVIR
C***REFER TO  SPLP
C     THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LRWVIR.
C     PRWVIR LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SPARSE MATRIX
C     STORAGE SCHEME.  THE PAGE STORAGE IS ON RANDOM ACCESS DISK.
C     PRWVIR() IS PART OF THE SPARSE LP PACKAGE, SPLP( ).
C     MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON
C     AUTHORS  J. A. WISNIEWSKI AND R.J. HANSON
C
C     KEY       IS A FLAG WHICH INDICATES WHETHER A READ OR WRITE
C               OPERATION IS TO BE PERFORMED. A VALUE OF KEY=1 INDICATES
C               A READ. A VALUE OF KEY=2 INDICATES A WRITE.
C     IPAGE     IS THE PAGE OF MATRIX MN WE ARE ACCESSING.
C     LPG       IS THE LENGTH OF THE PAGE.
C   SX(*),IX(*) IS THE MATRIX DATA.
C
C***ROUTINES CALLED  SPLPO,READP,WRITP
C***END PROLOGUE  PRWVIR
      DIMENSION IX(*)
      DOUBLE PRECISION SX(*),ZERO,ONE
      LOGICAL FIRST
      DATA ZERO,ONE/0.D0,1.D0/
C***FIRST EXECUTABLE STATEMENT  PRWVIR
      IOPT=1
C
C     COMPUTE STARTING ADDRESS OF PAGE.
C
      LMX = IX(1)
      IPAGEF=SX(3)
      ISTART = IX(3) + 5
C
C     OPEN RANDOM ACCESS FILE NUMBER IPAGEF, IF FIRST PAGE WRITE.
C
      FIRST=SX(4).EQ.ZERO
      IF (.NOT.(FIRST)) GO TO 20002
      CALL SPLPO(IPAGEF,LPG)
      SX(4)=ONE
C
C     PERFORM EITHER A READ OR A WRITE.
C
20002 IADDR = 2*IPAGE - 1
      IF (.NOT.(KEY.EQ.1)) GO TO 20005
      CALL READP(IPAGEF,IX(ISTART),SX(ISTART),LPG,IADDR)
      GO TO 20006
20005 IF (.NOT.(KEY.EQ.2)) GO TO 10001
      CALL WRITP(IPAGEF,IX(ISTART),SX(ISTART),LPG,IADDR)
10001 CONTINUE
20006 RETURN
      END
      DOUBLE PRECISION FUNCTION D1MACH(I)
C***BEGIN PROLOGUE  D1MACH
C***DATE WRITTEN   790101   (YYMMDD)
C***REVISION DATE  910131   (YYMMDD)
C***CATEGORY NO.  R1
C***KEYWORDS  MACHINE CONSTANTS
C***AUTHOR  FOX, P. A., (BELL LABS)
C           HALL, A. D., (BELL LABS)
C           SCHRYER, N. L., (BELL LABS)
C***PURPOSE  Returns single precision machine dependent constants
C***DESCRIPTION
C
C     This is the CMLIB version of D1MACH, the real machine
C     constants subroutine originally developed for the PORT library.
C
C     D1MACH can be used to obtain machine-dependent parameters
C     for the local machine environment.  It is a function
C     subroutine with one (input) argument, and can be called
C     as follows, for example
C
C          A = D1MACH(I)
C
C     where I=1,...,5.  The (output) value of A above is
C     determined by the (input) value of I.  The results for
C     various values of I are discussed below.
C
C  Single-Precision Machine Constants
C  D1MACH(1) = B**(EMIN-1), the smallest positive magnitude.
C  D1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
C  D1MACH(3) = B**(-T), the smallest relative spacing.
C  D1MACH(4) = B**(1-T), the largest relative spacing.
C  D1MACH(5) = LOG10(B)
C***REFERENCES  FOX, P.A., HALL, A.D., SCHRYER, N.L, *FRAMEWORK FOR
C                 A PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHE-
C                 MATICAL SOFTWARE, VOL. 4, NO. 2, JUNE 1978,
C                 PP. 177-188.
C***ROUTINES CALLED  XERROR
C***END PROLOGUE  D1MACH
C
      INTEGER SMALL(2)
      INTEGER LARGE(2)
      INTEGER RIGHT(2)
      INTEGER DIVER(2)
      INTEGER LOG10(2)
C
      DOUBLE PRECISION RMACH(5)
C
      EQUIVALENCE (RMACH(1),SMALL(1))
      EQUIVALENCE (RMACH(2),LARGE(1))
      EQUIVALENCE (RMACH(3),RIGHT(1))
      EQUIVALENCE (RMACH(4),DIVER(1))
      EQUIVALENCE (RMACH(5),LOG10(1))
C
C
C     MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T
C     3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T
C     PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300).
C
C === MACHINE = IEEE.MOST-SIG-BYTE-FIRST
C === MACHINE = IEEE.LEAST-SIG-BYTE-FIRST
C === MACHINE = SUN
C === MACHINE = 68000
C === MACHINE = 8087
C === MACHINE = IBM.PC
C === MACHINE = ATT.3B
C === MACHINE = ATT.6300
C === MACHINE = ATT.7300
       DATA SMALL(1) /     8388608 /
       DATA LARGE(1) /  2139095039 /
       DATA RIGHT(1) /   864026624 /
       DATA DIVER(1) /   872415232 /
       DATA LOG10(1) /  1050288283 /
C
C     MACHINE CONSTANTS FOR AMDAHL MACHINES.
C
C === MACHINE = AMDAHL
C      DATA SMALL(1) /    1048576 /
C      DATA LARGE(1) / 2147483647 /
C      DATA RIGHT(1) /  990904320 /
C      DATA DIVER(1) / 1007681536 /
C      DATA LOG10(1) / 1091781651 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
C
C === MACHINE = BURROUGHS.1700
C      DATA RMACH(1) / Z400800000 /
C      DATA RMACH(2) / Z5FFFFFFFF /
C      DATA RMACH(3) / Z4E9800000 /
C      DATA RMACH(4) / Z4EA800000 /
C      DATA RMACH(5) / Z500E730E8 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS.
C
C === MACHINE = BURROUGHS.5700
C === MACHINE = BURROUGHS.6700
C === MACHINE = BURROUGHS.7700
C      DATA RMACH(1) / O1771000000000000 /
C      DATA RMACH(2) / O0777777777777777 /
C      DATA RMACH(3) / O1311000000000000 /
C      DATA RMACH(4) / O1301000000000000 /
C      DATA RMACH(5) / O1157163034761675 /
C
C     MACHINE CONSTANTS FOR THE CONVEX C-120 (NATIVE MODE)
C
C === MACHINE = CONVEX.C1
C      DATA RMACH(1) / 2.9387360E-39 /
C      DATA RMACH(2) / 1.7014117E+38 /
C      DATA RMACH(3) / 5.9604645E-08 /
C      DATA RMACH(4) / 1.1920929E-07 /
C      DATA RMACH(5) / 3.0102999E-01 /
C
C     MACHINE CONSTANTS FOR THE CONVEX C-120 (NATIVE MODE)
C     WITH -R8 OPTION
C
C === MACHINE = CONVEX.C1.R8
C      DATA RMACH(1) / 5.562684646268007D-309 /
C      DATA RMACH(2) / 8.988465674311577D+307 /
C      DATA RMACH(3) / 1.110223024625157D-016 /
C      DATA RMACH(4) / 2.220446049250313D-016 /
C      DATA RMACH(5) / 3.010299956639812D-001 /
C
C     MACHINE CONSTANTS FOR THE CONVEX C-120 (IEEE MODE)
C
C === MACHINE = CONVEX.C1.IEEE
C      DATA RMACH(1) / 1.1754945E-38 /
C      DATA RMACH(2) / 3.4028234E+38 /
C      DATA RMACH(3) / 5.9604645E-08 /
C      DATA RMACH(4) / 1.1920929E-07 /
C      DATA RMACH(5) / 3.0102999E-01 /
C
C     MACHINE CONSTANTS FOR THE CONVEX C-120 (IEEE MODE)
C     WITH -R8 OPTION
C
C === MACHINE = CONVEX.C1.IEEE.R8
C      DATA RMACH(1) / 2.225073858507202D-308 /
C      DATA RMACH(2) / 1.797693134862315D+308 /
C      DATA RMACH(3) / 1.110223024625157D-016 /
C      DATA RMACH(4) / 2.220446049250313D-016 /
C      DATA RMACH(5) / 3.010299956639812D-001 /
C
C     MACHINE CONSTANTS FOR THE CYBER 170/180 SERIES USING NOS (FTN5).
C
C === MACHINE = CYBER.170.NOS
C === MACHINE = CYBER.180.NOS
C      DATA RMACH(1) / O"00014000000000000000" /
C      DATA RMACH(2) / O"37767777777777777777" /
C      DATA RMACH(3) / O"16404000000000000000" /
C      DATA RMACH(4) / O"16414000000000000000" /
C      DATA RMACH(5) / O"17164642023241175720" /
C
C     MACHINE CONSTANTS FOR THE CDC 180 SERIES USING NOS/VE
C
C === MACHINE = CYBER.180.NOS/VE
C      DATA RMACH(1) / Z"3001800000000000" /
C      DATA RMACH(2) / Z"4FFEFFFFFFFFFFFE" /
C      DATA RMACH(3) / Z"3FD2800000000000" /
C      DATA RMACH(4) / Z"3FD3800000000000" /
C      DATA RMACH(5) / Z"3FFF9A209A84FBCF" /
C
C     MACHINE CONSTANTS FOR THE CYBER 205
C
C === MACHINE = CYBER.205
C      DATA RMACH(1) / X'9000400000000000' /
C      DATA RMACH(2) / X'6FFF7FFFFFFFFFFF' /
C      DATA RMACH(3) / X'FFA3400000000000' /
C      DATA RMACH(4) / X'FFA4400000000000' /
C      DATA RMACH(5) / X'FFD04D104D427DE8' /
C
C     MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES.
C
C === MACHINE = CDC.6000
C === MACHINE = CDC.7000
C      DATA RMACH(1) / 00014000000000000000B /
C      DATA RMACH(2) / 37767777777777777777B /
C      DATA RMACH(3) / 16404000000000000000B /
C      DATA RMACH(4) / 16414000000000000000B /
C      DATA RMACH(5) / 17164642023241175720B /
C
C     MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3.
C
C === MACHINE = CRAY.46-BIT-INTEGER
C === MACHINE = CRAY.64-BIT-INTEGER
C      DATA RMACH(1) / 200034000000000000000B /
C      DATA RMACH(2) / 577767777777777777776B /
C      DATA RMACH(3) / 377224000000000000000B /
C      DATA RMACH(4) / 377234000000000000000B /
C      DATA RMACH(5) / 377774642023241175720B /
C
C     MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
C
C     NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING LINE -
C     STATIC RMACH(5)
C
C === MACHINE = DATA_GENERAL.ECLIPSE.S/200
C      DATA SMALL/20K,0/,LARGE/77777K,177777K/
C      DATA RIGHT/35420K,0/,DIVER/36020K,0/
C      DATA LOG10/40423K,42023K/
C
C     ELXSI 6400
C
C === MACHINE = ELSXI.6400
C      DATA SMALL(1) / '00800000'X /
C      DATA LARGE(1) / '7F7FFFFF'X /
C      DATA RIGHT(1) / '33800000'X /
C      DATA DIVER(1) / '34000000'X /
C      DATA LOG10(1) / '3E9A209B'X /
C
C     MACHINE CONSTANTS FOR THE HARRIS 220
C     MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7
C
C === MACHINE = HARRIS.220
C === MACHINE = HARRIS.SLASH6
C === MACHINE = HARRIS.SLASH7
C      DATA SMALL(1),SMALL(2) / '20000000, '00000201 /
C      DATA LARGE(1),LARGE(2) / '37777777, '00000177 /
C      DATA RIGHT(1),RIGHT(2) / '20000000, '00000352 /
C      DATA DIVER(1),DIVER(2) / '20000000, '00000353 /
C      DATA LOG10(1),LOG10(2) / '23210115, '00000377 /
C
C     MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES.
C     MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
C
C === MACHINE = HONEYWELL.600/6000
C === MACHINE = HONEYWELL.DPS.8/70
C      DATA RMACH(1) / O402400000000 /
C      DATA RMACH(2) / O376777777777 /
C      DATA RMACH(3) / O714400000000 /
C      DATA RMACH(4) / O716400000000 /
C      DATA RMACH(5) / O776464202324 /
C
C     MACHINE CONSTANTS FOR THE HP 2100
C     3 WORD DOUBLE PRECISION WITH FTN4
C
C === MACHINE = HP.2100.3_WORD_DP
C      DATA SMALL(1), SMALL(2) / 40000B,       1 /
C      DATA LARGE(1), LARGE(2) / 77777B, 177776B /
C      DATA RIGHT(1), RIGHT(2) / 40000B,    325B /
C      DATA DIVER(1), DIVER(2) / 40000B,    327B /
C      DATA LOG10(1), LOG10(2) / 46420B,  46777B /
C
C     MACHINE CONSTANTS FOR THE HP 2100
C     4 WORD DOUBLE PRECISION WITH FTN4
C
C === MACHINE = HP.2100.4_WORD_DP
C      DATA SMALL(1), SMALL(2) / 40000B,       1 /
C      DATA LARGE91), LARGE(2) / 77777B, 177776B /
C      DATA RIGHT(1), RIGHT(2) / 40000B,    325B /
C      DATA DIVER(1), DIVER(2) / 40000B,    327B /
C      DATA LOG10(1), LOG10(2) / 46420B,  46777B /
C
C     HP 9000
C
C      D1MACH(1) = 1.17549435E-38
C      D1MACH(2) = 1.70141163E+38
C      D1MACH(3) = 5.960464478E-8
C      D1MACH(4) = 1.119209290E-7
C      D1MACH(5) = 3.01030010E-1
C
C === MACHINE = HP.9000
C      DATA SMALL(1) / 00040000000B /
C      DATA LARGE(1) / 17677777777B /
C      DATA RIGHT(1) / 06340000000B /
C      DATA DIVER(1) / 06400000000B /
C      DATA LOG10(1) / 07646420233B /
C
C     MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
C     THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86 AND
C     THE INTERDATA 3230 AND INTERDATA 7/32.
C
C === MACHINE = IBM.360
C === MACHINE = IBM.370
C === MACHINE = XEROX.SIGMA.5
C === MACHINE = XEROX.SIGMA.7
C === MACHINE = XEROX.SIGMA.9
C === MACHINE = SEL.85
C === MACHINE = SEL.86
C === MACHINE = INTERDATA.3230
C === MACHINE = INTERDATA.7/32
C      DATA RMACH(1) / Z00100000 /
C      DATA RMACH(2) / Z7FFFFFFF /
C      DATA RMACH(3) / Z3B100000 /
C      DATA RMACH(4) / Z3C100000 /
C      DATA RMACH(5) / Z41134413 /
C
C     MACHINE CONSTANTS FOR THE INTERDATA 8/32
C     WITH THE UNIX SYSTEM FORTRAN 77 COMPILER.
C
C     FOR THE INTERDATA FORTRAN VII COMPILER REPLACE
C     THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S.
C
C === MACHINE = INTERDATA.8/32.UNIX
C      DATA RMACH(1) / Z'00100000' /
C      DATA RMACH(2) / Z'7EFFFFFF' /
C      DATA RMACH(3) / Z'3B100000' /
C      DATA RMACH(4) / Z'3C100000' /
C      DATA RMACH(5) / Z'41134413' /
C
C     MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR).
C
C === MACHINE = PDP-10.KA
C === MACHINE = PDP-10.KI
C      DATA RMACH(1) / "000400000000 /
C      DATA RMACH(2) / "377777777777 /
C      DATA RMACH(3) / "146400000000 /
C      DATA RMACH(4) / "147400000000 /
C      DATA RMACH(5) / "177464202324 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
C     32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
C
C === MACHINE = PDP-11.32-BIT
C      DATA SMALL(1) /    8388608 /
C      DATA LARGE(1) / 2147483647 /
C      DATA RIGHT(1) /  880803840 /
C      DATA DIVER(1) /  889192448 /
C      DATA LOG10(1) / 1067065499 /
C
C      DATA RMACH(1) / O00040000000 /
C      DATA RMACH(2) / O17777777777 /
C      DATA RMACH(3) / O06440000000 /
C      DATA RMACH(4) / O06500000000 /
C      DATA RMACH(5) / O07746420233 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
C     16-BIT INTEGERS  (EXPRESSED IN INTEGER AND OCTAL).
C
C === MACHINE = PDP-11.16-BIT
C      DATA SMALL(1),SMALL(2) /   128,     0 /
C      DATA LARGE(1),LARGE(2) / 32767,    -1 /
C      DATA RIGHT(1),RIGHT(2) / 13440,     0 /
C      DATA DIVER(1),DIVER(2) / 13568,     0 /
C      DATA LOG10(1),LOG10(2) / 16282,  8347 /
C
C      DATA SMALL(1),SMALL(2) / O000200, O000000 /
C      DATA LARGE(1),LARGE(2) / O077777, O177777 /
C      DATA RIGHT(1),RIGHT(2) / O032200, O000000 /
C      DATA DIVER(1),DIVER(2) / O032400, O000000 /
C      DATA LOG10(1),LOG10(2) / O037632, O020233 /
C
C     MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000.
C
C === MACHINE = SEQUENT.BALANCE.8000
C      DATA SMALL(1) / $00800000 /
C      DATA LARGE(1) / $7F7FFFFF /
C      DATA RIGHT(1) / $33800000 /
C      DATA DIVER(1) / $34000000 /
C      DATA LOG10(1) / $3E9A209B /
C
C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C
C === MACHINE = UNIVAC.1100
C      DATA RMACH(1) / O000400000000 /
C      DATA RMACH(2) / O377777777777 /
C      DATA RMACH(3) / O146400000000 /
C      DATA RMACH(4) / O147400000000 /
C      DATA RMACH(5) / O177464202324 /
C
C     MACHINE CONSTANTS FOR THE VAX 11/780
C    (EXPRESSED IN INTEGER AND HEXADECIMAL)
C  *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS***
C
C === MACHINE = VAX.11/780
C      DATA SMALL(1) /       128 /
C      DATA LARGE(1) /    -32769 /
C      DATA RIGHT(1) /     13440 /
C      DATA DIVER(1) /     13568 /
C      DATA LOG10(1) / 547045274 /
C
C  ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS***
C
C      DATA SMALL(1) / Z00000080 /
C      DATA LARGE(1) / ZFFFF7FFF /
C      DATA RIGHT(1) / Z00003480 /
C      DATA DIVER(1) / Z00003500 /
C      DATA LOG10(1) / Z209B3F9A /
C
C
C***FIRST EXECUTABLE STATEMENT  D1MACH
      IF (I .LT. 1  .OR.  I .GT. 5)
     1   CALL XERROR ( 'D1MACH -- I OUT OF BOUNDS',25,1,2)
C
      D1MACH = RMACH(I)
      RETURN
C
      END
      SUBROUTINE READP(IPAGE,LIST,RLIST,LPAGE,IREC)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  READP
C***REFER TO  SPLP
C     READ RECORD NUMBER IRECN, OF LENGTH LPG, FROM UNIT
C     NUMBER IPAGEF INTO THE STORAGE ARRAY, LIST(*).
C     READ RECORD  IRECN+1, OF LENGTH LPG, FROM UNIT NUMBER
C     IPAGEF INTO THE STORAGE ARRAY RLIST(*).
C
C     TO CONVERT THIS PROGRAM UNIT TO DOUBLE PRECISION CHANGE
C     /REAL (12 BLANKS)/ TO /DOUBLE PRECISION/.
C***ROUTINES CALLED  XERRWV
C***END PROLOGUE  READP
      INTEGER LIST(*)
      DOUBLE PRECISION RDUM
      DOUBLE PRECISION RLIST(*)
C***FIRST EXECUTABLE STATEMENT  READP
      IPAGEF=IPAGE
      LPG   =LPAGE
      IRECN=IREC
      READ(IPAGEF,REC=IRECN,ERR=100)(LIST(I),I=1,LPG)
      READ(IPAGEF,REC=IRECN+1,ERR=100)(RLIST(I),I=1,LPG)
      RETURN
 100  CONTINUE
      IOPT=1
      NERR=100
      CALL XERRWV('SPLP( ). ERROR IN READP().',26,NERR,IOPT,2,LPG,IRECN,
     * 0,RDUM,RDUM)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DASUM(N,SX,INCX)
C***BEGIN PROLOGUE  DASUM
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A3A
C***KEYWORDS  ADD,BLAS,LINEAR ALGEBRA,MAGNITUDE,SUM,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Sum of magnitudes of s.p vector components
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(S)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C
C     --Output--
C    DASUM  single precision result (zero if N .LE. 0)
C
C     Returns sum of magnitudes of single precision SX.
C     DASUM = sum from 0 to N-1 of  DABS(SX(1+I*INCX))
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  DASUM
C
      DOUBLE PRECISION SX(1)
C***FIRST EXECUTABLE STATEMENT  DASUM
      DASUM = 0.0D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      NS = N*INCX
          DO 10 I=1,NS,INCX
          DASUM = DASUM + DABS(SX(I))
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6.
C
   20 M = MOD(N,6)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DASUM = DASUM + DABS(SX(I))
   30 CONTINUE
      IF( N .LT. 6 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,6
        DASUM = DASUM + DABS(SX(I)) + DABS(SX(I + 1)) + DABS(SX(I + 2))
     1  + DABS(SX(I + 3)) + DABS(SX(I + 4)) + DABS(SX(I + 5))
   50 CONTINUE
      RETURN
      END
      SUBROUTINE DCOPY(N,SX,INCX,SY,INCY)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  DCOPY
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A5
C***KEYWORDS  BLAS,COPY,LINEAR ALGEBRA,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Copy s.p. vector y = x
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C       SY  single precision vector with N elements
C     INCY  storage spacing between elements of SY
C
C     --Output--
C       SY  copy of vector SX (unchanged if N .LE. 0)
C
C     Copy single precision SX to single precision SY.
C     For I = 0 to N-1, copy  SX(LX+I*INCX) to SY(LY+I*INCY),
C     where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is
C     defined in a similar way using INCY.
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  DCOPY
C
      DOUBLE PRECISION SX(1),SY(1)
C***FIRST EXECUTABLE STATEMENT  DCOPY
      IF(N.LE.0)RETURN
      IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60
    5 CONTINUE
C
C        CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS.
C
      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
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7.
C
   20 M = MOD(N,7)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        SY(I) = SX(I)
   30 CONTINUE
      IF( N .LT. 7 ) RETURN
   40 MP1 = M + 1
      DO 50 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)
   50 CONTINUE
      RETURN
C
C        CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS.
C
   60 CONTINUE
      NS = N*INCX
          DO 70 I=1,NS,INCX
          SY(I) = SX(I)
   70     CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION DDOT(N,SX,INCX,SY,INCY)
C***BEGIN PROLOGUE  DDOT
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A4
C***KEYWORDS  BLAS,INNER PRODUCT,LINEAR ALGEBRA,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  S.P. inner product of s.p. vectors
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C       SY  single precision vector with N elements
C     INCY  storage spacing between elements of SY
C
C     --Output--
C     DDOT  single precision dot product (zero if N .LE. 0)
C
C     Returns the dot product of single precision SX and SY.
C     DDOT = sum for I = 0 to N-1 of  SX(LX+I*INCX) * SY(LY+I*INCY),
C     where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is
C     defined in a similar way using INCY.
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  DDOT
C
      DOUBLE PRECISION SX(1),SY(1)
C***FIRST EXECUTABLE STATEMENT  DDOT
      DDOT = 0.0D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.INCY) IF(INCX-1)5,20,60
    5 CONTINUE
C
C        CODE FOR UNEQUAL INCREMENTS OR NONPOSITIVE INCREMENTS.
C
      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
        DDOT = DDOT + SX(IX)*SY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5.
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DDOT = DDOT + SX(I)*SY(I)
   30 CONTINUE
      IF( N .LT. 5 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DDOT = DDOT + SX(I)*SY(I) + SX(I + 1)*SY(I + 1) +
     1   SX(I + 2)*SY(I + 2) + SX(I + 3)*SY(I + 3) + SX(I + 4)*SY(I + 4)
   50 CONTINUE
      RETURN
C
C        CODE FOR POSITIVE EQUAL INCREMENTS .NE.1.
C
   60 CONTINUE
      NS=N*INCX
      DO 70 I=1,NS,INCX
        DDOT = DDOT + SX(I)*SY(I)
   70   CONTINUE
      RETURN
      END
      SUBROUTINE SPINCW(
     *MRELAS,NVARS,LMX,LBM,NPP,JSTRT,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *COSTSC,GG,ERDNRM,DULNRM,
     *AMAT,BASMAT,CSC,WR,WW,RZ,RG,COSTS,COLNRM,DUALS,
     *STPEDG)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  SPINCW
C***REFER TO  SPLP
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/,
C     REAL (12 BLANKS)/DOUBLE PRECISION/,/DCOPY/DCOPY/,/DDOT/DDOT/.
C
C     THIS SUBPROGRAM IS PART OF THE SPLP( ) PACKAGE.
C     IT IMPLEMENTS THE PROCEDURE (INITIALIZE REDUCED COSTS AND
C     STEEPEST EDGE WEIGHTS).
C***ROUTINES CALLED  IPLOC,LA05BS,PRWPGE,DCOPY,DDOT
C***END PROLOGUE  SPINCW
      INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*)
      DOUBLE PRECISION AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),RZ(*),RG(*),
     * COSTS(*),COLNRM(*),DUALS(*),COSTSC,ERDNRM,DULNRM,GG,ONE,RZJ,
     * SCALR,ZERO,RCOST
      LOGICAL STPEDG,PAGEPL,TRANS
C***FIRST EXECUTABLE STATEMENT  SPINCW
      LPG=LMX-(NVARS+4)
      ZERO=0.
      ONE=1.
C
C     FORM REDUCED COSTS, RZ(*), AND STEEPEST EDGE WEIGHTS, RG(*).
      PAGEPL=.TRUE.
      RZ(1)=ZERO
      CALL DCOPY(NVARS+MRELAS,RZ,0,RZ,1)
      RG(1)=ONE
      CALL DCOPY(NVARS+MRELAS,RG,0,RG,1)
      NNEGRC=0
      J=JSTRT
20002 IF (.NOT.(IBB(J).LE.0)) GO TO 20004
      PAGEPL=.TRUE.
      GO TO 20005
C
C     THESE ARE NONBASIC INDEPENDENT VARIABLES. THE COLS. ARE IN SPARSE
C     MATRIX FORMAT.
20004 IF (.NOT.(J.LE.NVARS)) GO TO 20007
      RZJ=COSTSC*COSTS(J)
      WW(1)=ZERO
      CALL DCOPY(MRELAS,WW,0,WW,1)
      IF (.NOT.(J.EQ.1)) GO TO 20010
      ILOW=NVARS+5
      GO TO 20011
20010 ILOW=IMAT(J+3)+1
20011 CONTINUE
20012 IF (.NOT.(PAGEPL)) GO TO 20013
      IL1=IPLOC(ILOW,AMAT,IMAT)
      IF (.NOT.(IL1.GE.LMX-1)) GO TO 20016
      ILOW=ILOW+2
      IL1=IPLOC(ILOW,AMAT,IMAT)
20016 CONTINUE
20017 IPAGE=IDABS(IMAT(LMX-1))
      GO TO 20014
20013 IL1=IHI+1
20014 CONTINUE
20015 IHI=IMAT(J+4)-(ILOW-IL1)
20019 IU1=MIN0(LMX-2,IHI)
      IF (.NOT.(IL1.GT.IU1)) GO TO 20021
      GO TO 20020
20021 CONTINUE
20022 DO 60 I=IL1,IU1
      RZJ=RZJ-AMAT(I)*DUALS(IMAT(I))
      WW(IMAT(I))=AMAT(I)*CSC(J)
60    CONTINUE
      IF (.NOT.(IHI.LE.LMX-2)) GO TO 20024
      GO TO 20020
20024 CONTINUE
20025 IPAGE=IPAGE+1
      KEY=1
      CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT)
      IL1=NVARS+5
      IHI=IHI-LPG
      GO TO 20019
20020 PAGEPL=IHI.EQ.(LMX-2)
      RZ(J)=RZJ*CSC(J)
      IF (.NOT.(STPEDG)) GO TO 20027
      TRANS=.FALSE.
      CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
      RG(J)=DDOT(MRELAS,WW,1,WW,1)+ONE
20027 CONTINUE
C
C     THESE ARE NONBASIC DEPENDENT VARIABLES. THE COLS. ARE IMPLICITLY
C     DEFINED.
20028 GO TO 20008
20007 PAGEPL=.TRUE.
      WW(1)=ZERO
      CALL DCOPY(MRELAS,WW,0,WW,1)
      SCALR=-ONE
      IF (IND(J).EQ.2) SCALR=ONE
      I=J-NVARS
      RZ(J)=-SCALR*DUALS(I)
      WW(I)=SCALR
      IF (.NOT.(STPEDG)) GO TO 20030
      TRANS=.FALSE.
      CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
      RG(J)=DDOT(MRELAS,WW,1,WW,1)+ONE
20030 CONTINUE
20031 CONTINUE
20008 CONTINUE
C
20005 RCOST=RZ(J)
      IF (MOD(IBB(J),2).EQ.0) RCOST=-RCOST
      IF (IND(J).EQ.4) RCOST=-DABS(RCOST)
      CNORM=ONE
      IF (J.LE.NVARS) CNORM=COLNRM(J)
      IF (RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO) NNEGRC=NNEGRC+1
      J=MOD(J,MRELAS+NVARS)+1
      IF (.NOT.(NNEGRC.GE.NPP .OR. J.EQ.JSTRT)) GO TO 20033
      GO TO 20003
20033 GO TO 20002
20003 JSTRT=J
      RETURN
      END
      SUBROUTINE SPINIT(MRELAS,NVARS,COSTS,BL,BU,IND,PRIMAL,INFO,
     * AMAT,CSC,COSTSC,COLNRM,XLAMDA,ANORM,RHS,RHSNRM,
     * IBASIS,IBB,IMAT,LOPT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  SPINIT
C***REFER TO  SPLP
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/,/DABS(/DDABS(/,/DMAX1/DMAX1/,
C     /DCOPY/DCOPY/.
C     REVISED 810519-0900
C     REVISED YYMMDD-HHMM
C
C     INITIALIZATION SUBROUTINE FOR SPLP(*) PACKAGE.
C***ROUTINES CALLED  PNNZRS,DASUM,DCOPY
C***END PROLOGUE  SPINIT
      DOUBLE PRECISION AIJ,AMAT(*),ANORM,BL(*),BU(*),CMAX,
     * COLNRM(*),COSTS(*),COSTSC,CSC(*),CSUM,ONE,PRIMAL(*),
     * RHS(*),RHSNRM,SCALR,TESTSC,XLAMDA,ZERO
      INTEGER IBASIS(*),IBB(*),IMAT(*),IND(*)
      LOGICAL CONTIN,USRBAS,COLSCP,CSTSCP,MINPRB,LOPT(8)
C
C***FIRST EXECUTABLE STATEMENT  SPINIT
      IOPT=1
      ZERO=0.
      ONE=1.
      CONTIN=LOPT(1)
      USRBAS=LOPT(2)
      COLSCP=LOPT(5)
      CSTSCP=LOPT(6)
      MINPRB=LOPT(7)
C
C     SCALE DATA. NORMALIZE BOUNDS. FORM COLUMN CHECK SUMS.
      GO TO 30001
C
C     INITIALIZE ACTIVE BASIS MATRIX.
20002 CONTINUE
      GO TO 30002
20003 RETURN
C
C     PROCEDURE (SCALE DATA. NORMALIZE BOUNDS. FORM COLUMN CHECK SUMS)
C
C     DO COLUMN SCALING IF NOT PROVIDED BY THE USER.
30001 IF (.NOT.(.NOT. COLSCP)) GO TO 20004
      J=1
      N20007=NVARS
      GO TO 20008
20007 J=J+1
20008 IF ((N20007-J).LT.0) GO TO 20009
      CMAX=ZERO
      I=0
20011 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.EQ.0)) GO TO 20013
      GO TO 20012
20013 CONTINUE
20014 CMAX=DMAX1(CMAX,DABS(AIJ))
      GO TO 20011
20012 IF (.NOT.(CMAX.EQ.ZERO)) GO TO 20016
      CSC(J)=ONE
      GO TO 20017
20016 CSC(J)=ONE/CMAX
20017 CONTINUE
20018 GO TO 20007
20009 CONTINUE
C
C     FORM CHECK SUMS OF COLUMNS. COMPUTE MATRIX NORM OF SCALED MATRIX.
20004 ANORM = ZERO
      J=1
      N20019=NVARS
      GO TO 20020
20019 J=J+1
20020 IF ((N20019-J).LT.0) GO TO 20021
      PRIMAL(J)=ZERO
      CSUM = ZERO
      I=0
20023 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.LE.0)) GO TO 20025
      GO TO 20024
20025 CONTINUE
20026 PRIMAL(J)=PRIMAL(J)+AIJ
      CSUM = CSUM+DABS(AIJ)
      GO TO 20023
20024 IF (IND(J).EQ.2) CSC(J)=-CSC(J)
      PRIMAL(J)=PRIMAL(J)*CSC(J)
      COLNRM(J)=DABS(CSC(J)*CSUM)
      ANORM = DMAX1(ANORM,COLNRM(J))
      GO TO 20019
C
C     IF THE USER HAS NOT PROVIDED COST VECTOR SCALING THEN SCALE IT
C     USING THE MAX. NORM OF THE TRANSFORMED COST VECTOR, IF NONZERO.
20021 TESTSC=ZERO
      J=1
      N20028=NVARS
      GO TO 20029
20028 J=J+1
20029 IF ((N20028-J).LT.0) GO TO 20030
      TESTSC=DMAX1(TESTSC,DABS(CSC(J)*COSTS(J)))
      GO TO 20028
20030 IF (.NOT.(.NOT.CSTSCP)) GO TO 20032
      IF (.NOT.(TESTSC.GT.ZERO)) GO TO 20035
      COSTSC=ONE/TESTSC
      GO TO 20036
20035 COSTSC=ONE
20036 CONTINUE
20037 CONTINUE
20032 XLAMDA=(COSTSC+COSTSC)*TESTSC
      IF (XLAMDA.EQ.ZERO) XLAMDA=ONE
C
C     IF MAXIMIZATION PROBLEM, THEN CHANGE SIGN OF COSTSC AND LAMDA
C     =WEIGHT FOR PENALTY-FEASIBILITY METHOD.
      IF (.NOT.(.NOT.MINPRB)) GO TO 20038
      COSTSC=-COSTSC
20038 GO TO 20002
C:CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (INITIALIZE RHS(*),IBASIS(*), AND IBB(*))
C
C     INITIALLY SET RIGHT-HAND SIDE VECTOR TO ZERO.
30002 CALL DCOPY(MRELAS,ZERO,0,RHS,1)
C
C     TRANSLATE RHS ACCORDING TO CLASSIFICATION OF INDEPENDENT VARIABLES
      J=1
      N20041=NVARS
      GO TO 20042
20041 J=J+1
20042 IF ((N20041-J).LT.0) GO TO 20043
      IF (.NOT.(IND(J).EQ.1)) GO TO 20045
      SCALR=-BL(J)
      GO TO 20046
20045 IF (.NOT.(IND(J).EQ.2)) GO TO 10001
      SCALR=-BU(J)
      GO TO 20046
10001 IF (.NOT.(IND(J).EQ.3)) GO TO 10002
      SCALR=-BL(J)
      GO TO 20046
10002 IF (.NOT.(IND(J).EQ.4)) GO TO 10003
      SCALR=ZERO
10003 CONTINUE
20046 CONTINUE
20047 IF (.NOT.(SCALR.NE.ZERO)) GO TO 20048
      I=0
20051 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.LE.0)) GO TO 20053
      GO TO 20052
20053 CONTINUE
20054 RHS(I)=SCALR*AIJ+RHS(I)
      GO TO 20051
20052 CONTINUE
20048 CONTINUE
20049 GO TO 20041
C
C     TRANSLATE RHS ACCORDING TO CLASSIFICATION OF DEPENDENT VARIABLES.
20043 I=NVARS+1
      N20056=NVARS+MRELAS
      GO TO 20057
20056 I=I+1
20057 IF ((N20056-I).LT.0) GO TO 20058
      IF (.NOT.(IND(I).EQ.1)) GO TO 20060
      SCALR=BL(I)
      GO TO 20061
20060 IF (.NOT.(IND(I).EQ.2)) GO TO 10004
      SCALR=BU(I)
      GO TO 20061
10004 IF (.NOT.(IND(I).EQ.3)) GO TO 10005
      SCALR=BL(I)
      GO TO 20061
10005 IF (.NOT.(IND(I).EQ.4)) GO TO 10006
      SCALR=ZERO
10006 CONTINUE
20061 CONTINUE
20062 RHS(I-NVARS)=RHS(I-NVARS)+SCALR
      GO TO 20056
20058 RHSNRM=DASUM(MRELAS,RHS,1)
C
C     IF THIS IS NOT A CONTINUATION OR THE USER HAS NOT PROVIDED THE
C     INITIAL BASIS, THEN THE INITIAL BASIS IS COMPRISED OF THE
C     DEPENDENT VARIABLES.
      IF (.NOT.(.NOT.(CONTIN .OR. USRBAS))) GO TO 20063
      J=1
      N20066=MRELAS
      GO TO 20067
20066 J=J+1
20067 IF ((N20066-J).LT.0) GO TO 20068
      IBASIS(J)=NVARS+J
      GO TO 20066
20068 CONTINUE
C
C     DEFINE THE ARRAY IBB(*)
20063 J=1
      N20070=NVARS+MRELAS
      GO TO 20071
20070 J=J+1
20071 IF ((N20070-J).LT.0) GO TO 20072
      IBB(J)=1
      GO TO 20070
20072 J=1
      N20074=MRELAS
      GO TO 20075
20074 J=J+1
20075 IF ((N20074-J).LT.0) GO TO 20076
      IBB(IBASIS(J))=-1
      GO TO 20074
C
C     DEFINE THE REST OF IBASIS(*)
20076 IP=MRELAS
      J=1
      N20078=NVARS+MRELAS
      GO TO 20079
20078 J=J+1
20079 IF ((N20078-J).LT.0) GO TO 20080
      IF (.NOT.(IBB(J).GT.0)) GO TO 20082
      IP=IP+1
      IBASIS(IP)=J
20082 GO TO 20078
20080 GO TO 20003
      END
      SUBROUTINE SPLPCE(
     *MRELAS,NVARS,LMX,LBM,ITLP,ITBRC,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ERDNRM,EPS,TUNE,GG,
     *AMAT,BASMAT,CSC,WR,WW,PRIMAL,ERD,ERP,
     *SINGLR,REDBAS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  SPLPCE
C***REFER TO  SPLP
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/,/DABS(/DDABS(/,/DMAX1/
C     DMAX1/,/DASUM/DASUM/,/DCOPY/,DCOPY/.
C
C     REVISED 811219-1630
C     REVISED YYMMDD-HHMM
C
C     THIS SUBPROGRAM IS FROM THE SPLP( ) PACKAGE.  IT CALCULATES
C     THE APPROXIMATE ERROR IN THE PRIMAL AND DUAL SYSTEMS.  IT IS
C     THE MAIN PART OF THE PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL
C     SYSTEMS).
C***ROUTINES CALLED  IPLOC,LA05BS,PRWPGE,DASUM,DCOPY
C***END PROLOGUE  SPLPCE
      INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*)
      DOUBLE PRECISION AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),PRIMAL(*),
     * ERD(*),ERP(*),EPS,ERDNRM,FACTOR,GG,ONE,ZERO,TEN,TUNE
      LOGICAL SINGLR,REDBAS,TRANS,PAGEPL
C***FIRST EXECUTABLE STATEMENT  SPLPCE
      ZERO=0.D0
      ONE=1.D0
      TEN=10.D0
      LPG=LMX-(NVARS+4)
      SINGLR=.FALSE.
      FACTOR=0.01
C
C     COPY COLSUMS IN WW(*), AND SOLVE TRANSPOSED SYSTEM.
      I=1
      N20002=MRELAS
      GO TO 20003
20002 I=I+1
20003 IF ((N20002-I).LT.0) GO TO 20004
      J=IBASIS(I)
      IF (.NOT.(J.LE.NVARS)) GO TO 20006
      WW(I) = PRIMAL(J)
      GO TO 20007
20006 IF (.NOT.(IND(J).EQ.2)) GO TO 20009
      WW(I)=ONE
      GO TO 20010
20009 WW(I)=-ONE
20010 CONTINUE
20007 CONTINUE
20008 GO TO 20002
C
C     PERTURB RIGHT-SIDE IN UNITS OF LAST BITS TO BETTER REFLECT
C     ERRORS IN THE CHECK SUM SOLNS.
20004 I=1
      N20012=MRELAS
      GO TO 20013
20012 I=I+1
20013 IF ((N20012-I).LT.0) GO TO 20014
      WW(I)=WW(I)+TEN*EPS*WW(I)
      GO TO 20012
20014 TRANS = .TRUE.
      CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
      I=1
      N20016=MRELAS
      GO TO 20017
20016 I=I+1
20017 IF ((N20016-I).LT.0) GO TO 20018
      ERD(I)=DMAX1(DABS(WW(I)-ONE),EPS)*TUNE
C
C     SYSTEM BECOMES SINGULAR WHEN ACCURACY OF SOLUTION IS .GT. FACTOR.
C     THIS VALUE (FACTOR) MIGHT NEED TO BE CHANGED.
      SINGLR=SINGLR.OR.(ERD(I).GE.FACTOR)
      GO TO 20016
20018 ERDNRM=DASUM(MRELAS,ERD,1)
C
C     RECALCULATE ROW CHECK SUMS EVERY ITBRC ITERATIONS OR WHEN
C     A REDECOMPOSITION HAS OCCURED.
      IF (.NOT.(MOD(ITLP,ITBRC).EQ.0 .OR. REDBAS)) GO TO 20020
C
C     COMPUTE ROW SUMS, STORE IN WW(*), SOLVE PRIMAL SYSTEM.
      WW(1)=ZERO
      CALL DCOPY(MRELAS,WW,0,WW,1)
      PAGEPL=.TRUE.
      J=1
      N20023=NVARS
      GO TO 20024
20023 J=J+1
20024 IF ((N20023-J).LT.0) GO TO 20025
      IF (.NOT.(IBB(J).GE.ZERO)) GO TO 20027
C
C     THE VARIABLE IS NON-BASIC.
      PAGEPL=.TRUE.
      GO TO 20023
20027 IF (.NOT.(J.EQ.1)) GO TO 20030
      ILOW=NVARS+5
      GO TO 20031
20030 ILOW=IMAT(J+3)+1
20031 IF (.NOT.(PAGEPL)) GO TO 20033
      IL1=IPLOC(ILOW,AMAT,IMAT)
      IF (.NOT.(IL1.GE.LMX-1)) GO TO 20036
      ILOW=ILOW+2
      IL1=IPLOC(ILOW,AMAT,IMAT)
20036 CONTINUE
20037 IPAGE=IDABS(IMAT(LMX-1))
      GO TO 20034
20033 IL1=IHI+1
20034 IHI=IMAT(J+4)-(ILOW-IL1)
20039 IU1=MIN0(LMX-2,IHI)
      IF (.NOT.(IL1.GT.IU1)) GO TO 20041
      GO TO 20040
20041 CONTINUE
20042 DO 20 I=IL1,IU1
      WW(IMAT(I))=WW(IMAT(I))+AMAT(I)*CSC(J)
20    CONTINUE
      IF (.NOT.(IHI.LE.LMX-2)) GO TO 20044
      GO TO 20040
20044 CONTINUE
20045 IPAGE=IPAGE+1
      KEY=1
      CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT)
      IL1=NVARS+5
      IHI=IHI-LPG
      GO TO 20039
20040 PAGEPL=IHI.EQ.(LMX-2)
      GO TO 20023
20025 L=1
      N20047=MRELAS
      GO TO 20048
20047 L=L+1
20048 IF ((N20047-L).LT.0) GO TO 20049
      J=IBASIS(L)
      IF (.NOT.(J.GT.NVARS)) GO TO 20051
      I=J-NVARS
      IF (.NOT.(IND(J).EQ.2)) GO TO 20054
      WW(I)=WW(I)+ONE
      GO TO 20055
20054 WW(I)=WW(I)-ONE
20055 CONTINUE
20056 CONTINUE
20051 CONTINUE
20052 GO TO 20047
C
C     PERTURB RIGHT-SIDE IN UNITS OF LAST BIT POSITIONS.
20049 I=1
      N20057=MRELAS
      GO TO 20058
20057 I=I+1
20058 IF ((N20057-I).LT.0) GO TO 20059
      WW(I)=WW(I)+TEN*EPS*WW(I)
      GO TO 20057
20059 TRANS = .FALSE.
      CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
      I=1
      N20061=MRELAS
      GO TO 20062
20061 I=I+1
20062 IF ((N20061-I).LT.0) GO TO 20063
      ERP(I)=DMAX1(DABS(WW(I)-ONE),EPS)*TUNE
C
C     SYSTEM BECOMES SINGULAR WHEN ACCURACY OF SOLUTION IS .GT. FACTOR.
C     THIS VALUE (FACTOR) MIGHT NEED TO BE CHANGED.
      SINGLR=SINGLR.OR.(ERP(I).GE.FACTOR)
      GO TO 20061
20063 CONTINUE
C
20020 RETURN
      END
      SUBROUTINE SPLPDM(
     *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IOPT,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ANORM,EPS,UU,GG,
     *AMAT,BASMAT,CSC,WR,
     *SINGLR,REDBAS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  SPLPDM
C***REFER TO  SPLP
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/.
C
C     THIS SUBPROGRAM IS FROM THE SPLP( ) PACKAGE.  IT PERFORMS THE
C     TASK OF DEFINING THE ENTRIES OF THE BASIS MATRIX AND
C     DECOMPOSING IT USING THE LA05 PACKAGE.
C     IT IS THE MAIN PART OF THE PROCEDURE (DECOMPOSE BASIS MATRIX).
C
C     REVISED 811123-1500
C     REVISED YYMMDD-HHMM
C***ROUTINES CALLED  LA05AS,PNNZRS,DASUM,XERROR,XERRWV
C***COMMON BLOCKS    LA05DS
C***END PROLOGUE  SPLPDM
      INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*)
      DOUBLE PRECISION AMAT(*),BASMAT(*),CSC(*),WR(*),ANORM,EPS,GG,
     * ONE,SMALL,UU,ZERO
      LOGICAL SINGLR,REDBAS
C
C     COMMON BLOCK USED BY LA05 () PACKAGE..
      COMMON/LA05DS/SMALL,LP,LENL,LENU,NCP,LROW,LCOL
C
C***FIRST EXECUTABLE STATEMENT  SPLPDM
      ZERO=0.D0
      ONE=1.D0
      LPG=LMX-(NVARS+4)
C
C     DEFINE BASIS MATRIX BY COLUMNS FOR SPARSE MATRIX EQUATION SOLVER.
C     THE LA05AS() SUBPROGRAM REQUIRES THE NONZERO ENTRIES OF THE MATRIX
C     TOGETHER WITH THE ROW AND COLUMN INDICES.
      NZBM=0
C
C     DEFINE DEPENDENT VARIABLE COLUMNS. THESE ARE
C     COLS. OF THE IDENTITY MATRIX AND IMPLICITLY GENERATED.
      K=1
      N20002=MRELAS
      GO TO 20003
20002 K=K+1
20003 IF ((N20002-K).LT.0) GO TO 20004
      J = IBASIS(K)
      IF (.NOT.(J.GT.NVARS)) GO TO 20006
      NZBM=NZBM+1
      IF (.NOT.(IND(J).EQ.2)) GO TO 20009
      BASMAT(NZBM)=ONE
      GO TO 20010
20009 BASMAT(NZBM)=-ONE
20010 IBRC(NZBM,1)=J-NVARS
      IBRC(NZBM,2)=K
      GO TO 20007
C
C     DEFINE THE INDEP. VARIABLE COLS.  THIS REQUIRES RETRIEVING
C     THE COLS. FROM THE SPARSE MATRIX DATA STRUCTURE.
20006 I=0
20012 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.LE.0)) GO TO 20014
      GO TO 20013
20014 CONTINUE
20015 NZBM=NZBM+1
      BASMAT(NZBM)=AIJ*CSC(J)
      IBRC(NZBM,1)=I
      IBRC(NZBM,2)=K
      GO TO 20012
20013 CONTINUE
20007 GO TO 20002
C
20004 SINGLR = .FALSE.
C
C     RECOMPUTE MATRIX NORM USING CRUDE NORM = SUM OF MAGNITUDES.
      ANORM=DASUM(NZBM,BASMAT,1)
      SMALL = EPS*ANORM
C
C     GET AN L-U FACTORIZATION OF THE BASIS MATRIX.
      NREDC=NREDC+1
      REDBAS=.TRUE.
      CALL LA05AS(BASMAT,IBRC,NZBM,LBM,MRELAS,IPR,IWR,WR,GG,UU)
C
C     CHECK RETURN VALUE OF ERROR FLAG, GG.
      IF (.NOT.(GG.LT.ZERO)) GO TO 20017
      IF (.NOT.(GG.EQ.(-7.))) GO TO 20020
      NERR=28
      CALL XERROR(    'SPLP( ). SHORT ON STORAGE FOR LA05*( ) PACKAGE. U
     *E PRGOPT(*) TO GIVE MORE.',075,NERR,IOPT)
      INFO=-NERR
      RETURN
20020 IF (.NOT.(GG.EQ.(-5.))) GO TO 10001
      SINGLR = .TRUE.
      GO TO 20021
10001 NERR=27
      CALL XERRWV('SPLP( ). LA05A( ) RETURNED ERROR FLAG (R1) BELOW.',
     *49,NERR,IOPT,
     * 0,I1,I2,1,GG,R2)
      INFO=-NERR
      RETURN
20021 CONTINUE
C
20017 RETURN
      END
      SUBROUTINE SPLPFE(
     *MRELAS,NVARS,LMX,LBM,IENTER,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ERDNRM,EPS,GG,DULNRM,DIRNRM,
     *AMAT,BASMAT,CSC,WR,WW,BL,BU,RZ,RG,COLNRM,DUALS,
     *FOUND)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  SPLPFE
C***REFER TO  SPLP
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/,/DABS(/DDABS(/,/DASUM/DASUM/,
C     /DCOPY/DCOPY/.
C
C     THIS SUBPROGRAM IS PART OF THE SPLP( ) PACKAGE.
C     IT IMPLEMENTS THE PROCEDURE (FIND VARIABLE TO ENTER BASIS
C     AND GET SEARCH DIRECTION).
C     REVISED 811130-1100
C     REVISED YYMMDD-HHMM
C***ROUTINES CALLED  IPLOC,LA05BS,PRWPGE,DASUM,DCOPY
C***END PROLOGUE  SPLPFE
      INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*)
      DOUBLE PRECISION AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),BL(*),BU(*),
     * RZ(*),RG(*),COLNRM(*),DUALS(*),CNORM,DIRNRM,DULNRM,EPS,ERDNRM,GG,
     * ONE,RATIO,RCOST,RMAX,ZERO
      LOGICAL FOUND,TRANS
C***FIRST EXECUTABLE STATEMENT  SPLPFE
      LPG=LMX-(NVARS+4)
      ZERO=0.D0
      ONE=1.D0
      RMAX=ZERO
      FOUND=.FALSE.
      I=MRELAS+1
      N20002=MRELAS+NVARS
      GO TO 20003
20002 I=I+1
20003 IF ((N20002-I).LT.0) GO TO 20004
      J=IBASIS(I)
C
C     IF J=IBASIS(I) .LT. 0 THEN THE VARIABLE LEFT AT A ZERO LEVEL
C     AND IS NOT CONSIDERED AS A CANDIDATE TO ENTER.
      IF (.NOT.(J.GT.0)) GO TO 20006
C
C     DO NOT CONSIDER VARIABLES CORRESPONDING TO UNBOUNDED STEP LENGTHS.
      IF (.NOT.(IBB(J).EQ.0)) GO TO 20009
      GO TO 20002
20009 CONTINUE
C
C     IF A VARIABLE CORRESPONDS TO AN EQUATION(IND=3 AND BL=BU),
C     THEN DO NOT CONSIDER IT AS A CANDIDATE TO ENTER.
20010 IF (.NOT.(IND(J).EQ.3)) GO TO 20012
      IF (.NOT.((BU(J)-BL(J)).LE.EPS*(DABS(BL(J))+DABS(BU(J))))) 
     * GO TO 20015
      GO TO 20002
20015 CONTINUE
20016 CONTINUE
20012 CONTINUE
20013 RCOST=RZ(J)
C
C     IF VARIABLE IS AT UPPER BOUND IT CAN ONLY DECREASE.  THIS
C     ACCOUNTS FOR THE POSSIBLE CHANGE OF SIGN.
      IF(MOD(IBB(J),2).EQ.0) RCOST=-RCOST
C
C     IF THE VARIABLE IS FREE, USE THE NEGATIVE MAGNITUDE OF THE
C     REDUCED COST FOR THAT VARIABLE.
      IF(IND(J).EQ.4) RCOST=-DABS(RCOST)
      CNORM=ONE
      IF(J.LE.NVARS)CNORM=COLNRM(J)
C
C     TEST FOR NEGATIVITY OF REDUCED COSTS.
      IF (.NOT.(RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO)) GO TO 20018
      FOUND=.TRUE.
      RATIO=RCOST**2/RG(J)
      IF (.NOT.(RATIO.GT.RMAX)) GO TO 20021
      RMAX=RATIO
      IENTER=I
20021 CONTINUE
20022 CONTINUE
20018 CONTINUE
20019 CONTINUE
20006 GO TO 20002
C
C     USE COL. CHOSEN TO COMPUTE SEARCH DIRECTION.
20004 IF (.NOT.(FOUND)) GO TO 20024
      J=IBASIS(IENTER)
      WW(1)=ZERO
      CALL DCOPY(MRELAS,WW,0,WW,1)
      IF (.NOT.(J.LE.NVARS)) GO TO 20027
      IF (.NOT.(J.EQ.1)) GO TO 20030
      ILOW=NVARS+5
      GO TO 20031
20030 ILOW=IMAT(J+3)+1
20031 CONTINUE
20032 IL1=IPLOC(ILOW,AMAT,IMAT)
      IF (.NOT.(IL1.GE.LMX-1)) GO TO 20033
      ILOW=ILOW+2
      IL1=IPLOC(ILOW,AMAT,IMAT)
20033 CONTINUE
20034 IPAGE=IDABS(IMAT(LMX-1))
      IHI=IMAT(J+4)-(ILOW-IL1)
20036 IU1=MIN0(LMX-2,IHI)
      IF (.NOT.(IL1.GT.IU1)) GO TO 20038
      GO TO 20037
20038 CONTINUE
20039 DO 30 I=IL1,IU1
      WW(IMAT(I))=AMAT(I)*CSC(J)
30    CONTINUE
      IF (.NOT.(IHI.LE.LMX-2)) GO TO 20041
      GO TO 20037
20041 CONTINUE
20042 IPAGE=IPAGE+1
      KEY=1
      CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT)
      IL1=NVARS+5
      IHI=IHI-LPG
      GO TO 20036
20037 GO TO 20028
20027 IF (.NOT.(IND(J).EQ.2)) GO TO 20044
      WW(J-NVARS)=ONE
      GO TO 20045
20044 WW(J-NVARS)=-ONE
20045 CONTINUE
20046 CONTINUE
C
C     COMPUTE SEARCH DIRECTION.
20028 TRANS=.FALSE.
      CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
C
C     THE SEARCH DIRECTION REQUIRES THE FOLLOWING SIGN CHANGE IF EITHER
C     VARIABLE ENTERING IS AT ITS UPPER BOUND OR IS FREE AND HAS
C     POSITIVE REDUCED COST.
      IF (.NOT.(MOD(IBB(J),2).EQ.0.OR.(IND(J).EQ.4 .AND. RZ(J).GT.ZERO))
     *) GO TO 20047
      I=1
      N20050=MRELAS
      GO TO 20051
20050 I=I+1
20051 IF ((N20050-I).LT.0) GO TO 20052
      WW(I)=-WW(I)
      GO TO 20050
20052 CONTINUE
20047 DIRNRM=DASUM(MRELAS,WW,1)
C
C     COPY CONTENTS OF WR(*) TO DUALS(*) FOR USE IN
C     ADD-DROP (EXCHANGE) STEP, LA05CS( ).
      CALL DCOPY(MRELAS,WR,1,DUALS,1)
20024 RETURN
      END
      SUBROUTINE SPLPFL(
     *MRELAS,NVARS,IENTER,ILEAVE,
     *IBASIS,IND,IBB,
     *THETA,DIRNRM,RPRNRM,
     *CSC,WW,BL,BU,ERP,RPRIM,PRIMAL,
     *FINITE,ZEROLV)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  SPLPFL
C***REFER TO  SPLP
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/,/DABS(/DDABS(/.
C
C     THIS SUBPROGRAM IS PART OF THE SPLP( ) PACKAGE.
C     IT IMPLEMENTS THE PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS).
C     REVISED 811130-1045
C     REVISED YYMMDD-HHMM
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  SPLPFL
      INTEGER IBASIS(*),IND(*),IBB(*)
      DOUBLE PRECISION CSC(*),WW(*),BL(*),BU(*),ERP(*),RPRIM(*),
     * PRIMAL(*),BOUND,DIRNRM,RATIO,RPRNRM,THETA,ZERO
      LOGICAL FINITE,ZEROLV
C***FIRST EXECUTABLE STATEMENT  SPLPFL
      ZERO=0.D0
C
C     SEE IF THE ENTERING VARIABLE IS RESTRICTING THE STEP LENGTH
C     BECAUSE OF AN UPPER BOUND.
      FINITE=.FALSE.
      J=IBASIS(IENTER)
      IF (.NOT.(IND(J).EQ.3)) GO TO 20002
      THETA=BU(J)-BL(J)
      IF(J.LE.NVARS)THETA=THETA/CSC(J)
      FINITE=.TRUE.
      ILEAVE=IENTER
C
C     NOW USE THE BASIC VARIABLES TO POSSIBLY RESTRICT THE STEP
C     LENGTH EVEN FURTHER.
20002 I=1
      N20005=MRELAS
      GO TO 20006
20005 I=I+1
20006 IF ((N20005-I).LT.0) GO TO 20007
      J=IBASIS(I)
C
C     IF THIS IS A FREE VARIABLE, DO NOT USE IT TO
C     RESTRICT THE STEP LENGTH.
      IF (.NOT.(IND(J).EQ.4)) GO TO 20009
      GO TO 20005
C
C     IF DIRECTION COMPONENT IS ABOUT ZERO, IGNORE IT FOR COMPUTING
C     THE STEP LENGTH.
20009 IF (.NOT.(DABS(WW(I)).LE.DIRNRM*ERP(I))) GO TO 20012
      GO TO 20005
20012 IF (.NOT.(WW(I).GT.ZERO)) GO TO 20015
C
C     IF RPRIM(I) IS ESSENTIALLY ZERO, SET RATIO TO ZERO AND EXIT LOOP.
      IF (.NOT.(DABS(RPRIM(I)).LE.RPRNRM*ERP(I))) GO TO 20018
      THETA=ZERO
      ILEAVE=I
      FINITE=.TRUE.
      GO TO 20008
C
C     THE VALUE OF RPRIM(I) WILL DECREASE ONLY TO ITS LOWER BOUND OR
C     ONLY TO ITS UPPER BOUND.  IF IT DECREASES TO ITS
C     UPPER BOUND, THEN RPRIM(I) HAS ALREADY BEEN TRANSLATED
C     TO ITS UPPER BOUND AND NOTHING NEEDS TO BE DONE TO IBB(J).
20018 IF (.NOT.(RPRIM(I).GT.ZERO)) GO TO 10001
      RATIO=RPRIM(I)/WW(I)
      IF (.NOT.(.NOT.FINITE)) GO TO 20021
      ILEAVE=I
      THETA=RATIO
      FINITE=.TRUE.
      GO TO 20022
20021 IF (.NOT.(RATIO.LT.THETA)) GO TO 10002
      ILEAVE=I
      THETA=RATIO
10002 CONTINUE
20022 CONTINUE
20023 GO TO 20019
C
C     THE VALUE RPRIM(I).LT.ZERO WILL NOT RESTRICT THE STEP.
10001 CONTINUE
C
C     THE DIRECTION COMPONENT IS NEGATIVE; THEREFORE THE VARIABLE WILL
C     INCREASE.
20019 GO TO 20016
C
C     IF THE VARIABLE IS LESS THAN ITS LOWER BOUND, IT CAN
C     INCREASE ONLY TO ITS LOWER BOUND.
20015 IF (.NOT.(PRIMAL(I+NVARS).LT.ZERO)) GO TO 20024
      RATIO=RPRIM(I)/WW(I)
      IF (RATIO.LT.ZERO) RATIO=ZERO
      IF (.NOT.(.NOT.FINITE)) GO TO 20027
      ILEAVE=I
      THETA=RATIO
      FINITE=.TRUE.
      GO TO 20028
20027 IF (.NOT.(RATIO.LT.THETA)) GO TO 10003
      ILEAVE=I
      THETA=RATIO
10003 CONTINUE
20028 CONTINUE
C
C     IF THE BASIC VARIABLE IS FEASIBLE AND IS NOT AT ITS UPPER BOUND,
C     THEN IT CAN INCREASE TO ITS UPPER BOUND.
20029 GO TO 20025
20024 IF (.NOT.(IND(J).EQ.3 .AND. PRIMAL(I+NVARS).EQ.ZERO)) GO TO 10004
      BOUND=BU(J)-BL(J)
      IF(J.LE.NVARS) BOUND=BOUND/CSC(J)
      RATIO=(BOUND-RPRIM(I))/(-WW(I))
      IF (.NOT.(.NOT.FINITE)) GO TO 20030
      ILEAVE=-I
      THETA=RATIO
      FINITE=.TRUE.
      GO TO 20031
20030 IF (.NOT.(RATIO.LT.THETA)) GO TO 10005
      ILEAVE=-I
      THETA=RATIO
10005 CONTINUE
20031 CONTINUE
20032 CONTINUE
10004 CONTINUE
20025 CONTINUE
20016 GO TO 20005
20007 CONTINUE
C
C     IF STEP LENGTH IS FINITE, SEE IF STEP LENGTH IS ABOUT ZERO.
20008 IF (.NOT.(FINITE)) GO TO 20033
      ZEROLV=.TRUE.
      I=1
      N20036=MRELAS
      GO TO 20037
20036 I=I+1
20037 IF ((N20036-I).LT.0) GO TO 20038
      ZEROLV=ZEROLV.AND. DABS(THETA*WW(I)).LE.ERP(I)*RPRNRM
      IF (.NOT.(.NOT. ZEROLV)) GO TO 20040
      GO TO 20039
20040 GO TO 20036
20038 CONTINUE
20039 CONTINUE
20033 CONTINUE
20034 RETURN
      END
      SUBROUTINE SPLPO(IPAGE,LPAGE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     1. OPEN UNIT NUMBER IPAGEF AS A RANDOM ACCESS FILE.
C
C     2. THE RECORD LENGTH IS CONSTANT=LPG.
C
C     THIS IS FORTRAN 77 STANDARD FOR THE 'OPEN' STATEMENT.
      IPAGEF=IPAGE
      LPG   =LPAGE
      OPEN(UNIT=IPAGEF,IOSTAT=IOS,ERR=100,STATUS='UNKNOWN',
     *ACCESS='DIRECT',FORM='UNFORMATTED',RECL=LPG)
      RETURN
 100  CONTINUE
      IOPT=1
      NERR=100
      CALL XERRWV('SPLP( ). OPEN() HAS ERROR FLAG (I1).',36,NERR,IOPT,
     *1,IOS,IDUM,0,RDUM,RDUM)
      RETURN
      END
      SUBROUTINE WRITP(IPAGE,LIST,RLIST,LPAGE,IREC)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  WRITP
C***REFER TO  SPLP
C     WRITE RECORD NUMBER IRECN, OF LENGTH LPG, FROM STORAGE
C     ARRAY LIST(*) ONTO UNIT NUMBER IPAGEF.
C     WRITE RECORD NUMBER IRECN+1, OF LENGTH LPG, ONTO UNIT
C     NUMBER IPAGEF FROM THE STORAGE ARRAY RLIST(*).
C
C     TO CHANGE THIS PROGRAM UNIT TO DOUBLE PRECISION CHANGE
C     /REAL (12 BLANKS)/ TO /DOUBLE PRECISION/.
C***ROUTINES CALLED  XERRWV
C***END PROLOGUE  WRITP
      INTEGER LIST(*)
      DOUBLE PRECISION RDUM
      DOUBLE PRECISION RLIST(*)
C***FIRST EXECUTABLE STATEMENT  WRITP
      IPAGEF=IPAGE
      LPG   =LPAGE
      IRECN =IREC
      WRITE(IPAGEF,REC=IRECN,ERR=100)(LIST(I),I=1,LPG)
      WRITE(IPAGEF,REC=IRECN+1,ERR=100)(RLIST(I),I=1,LPG)
      RETURN
 100  CONTINUE
      IOPT=1
      NERR=100
      CALL XERRWV('SPLP( ). ERROR IN WRITP().',27,NERR,IOPT,2,LPG,IRECN,
     * 0,RDUM,RDUM)
      RETURN
      END
      SUBROUTINE XERABT(MESSG,NMESSG)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  XERABT
C***DATE WRITTEN   790801   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  R3C
C***KEYWORDS  ERROR,XERROR PACKAGE
C***AUTHOR  JONES, R. E., (SNLA)
C***PURPOSE  Aborts program execution and prints error message.
C***DESCRIPTION
C     Abstract
C        ***Note*** machine dependent routine
C        XERABT aborts the execution of the program.
C        The error message causing the abort is given in the calling
C        sequence, in case one needs it for printing on a dayfile,
C        for example.
C
C     Description of Parameters
C        MESSG and NMESSG are as in XERROR, except that NMESSG may
C        be zero, in which case no message is being supplied.
C
C     Written by Ron Jones, with SLATEC Common Math Library Subcommittee
C     Latest revision ---  19 MAR 1980
C***REFERENCES  JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  XERABT
      CHARACTER*(*) MESSG
C***FIRST EXECUTABLE STATEMENT  XERABT
      STOP
      END
      SUBROUTINE XERCTL(MESSG1,NMESSG,NERR,LEVEL,KONTRL)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  XERCTL
C***DATE WRITTEN   790801   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  R3C
C***KEYWORDS  ERROR,XERROR PACKAGE
C***AUTHOR  JONES, R. E., (SNLA)
C***PURPOSE  Allows user control over handling of individual errors.
C***DESCRIPTION
C     Abstract
C        Allows user control over handling of individual errors.
C        Just after each message is recorded, but before it is
C        processed any further (i.e., before it is printed or
C        a decision to abort is made), a call is made to XERCTL.
C        If the user has provided his own version of XERCTL, he
C        can then override the value of KONTROL used in processing
C        this message by redefining its value.
C        KONTRL may be set to any value from -2 to 2.
C        The meanings for KONTRL are the same as in XSETF, except
C        that the value of KONTRL changes only for this message.
C        If KONTRL is set to a value outside the range from -2 to 2,
C        it will be moved back into that range.
C
C     Description of Parameters
C
C      --Input--
C        MESSG1 - the first word (only) of the error message.
C        NMESSG - same as in the call to XERROR or XERRWV.
C        NERR   - same as in the call to XERROR or XERRWV.
C        LEVEL  - same as in the call to XERROR or XERRWV.
C        KONTRL - the current value of the control flag as set
C                 by a call to XSETF.
C
C      --Output--
C        KONTRL - the new value of KONTRL.  If KONTRL is not
C                 defined, it will remain at its original value.
C                 This changed value of control affects only
C                 the current occurrence of the current message.
C***REFERENCES  JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  XERCTL
      CHARACTER*20 MESSG1
C***FIRST EXECUTABLE STATEMENT  XERCTL
      RETURN
      END
      SUBROUTINE XERPRT(MESSG,NMESSG)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  XERPRT
C***DATE WRITTEN   790801   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  Z
C***KEYWORDS  ERROR,XERROR PACKAGE
C***AUTHOR  JONES, R. E., (SNLA)
C***PURPOSE  Prints error messages.
C***DESCRIPTION
C     Abstract
C        Print the Hollerith message in MESSG, of length NMESSG,
C        on each file indicated by XGETUA.
C     Latest revision ---  19 MAR 1980
C***REFERENCES  JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  I1MACH,S88FMT,XGETUA
C***END PROLOGUE  XERPRT
      INTEGER LUN(5)
      CHARACTER*(*) MESSG
C     OBTAIN UNIT NUMBERS AND WRITE LINE TO EACH UNIT
C***FIRST EXECUTABLE STATEMENT  XERPRT
      CALL XGETUA(LUN,NUNIT)
      LENMES = LEN(MESSG)
      DO 20 KUNIT=1,NUNIT
         IUNIT = LUN(KUNIT)
         IF (IUNIT.EQ.0) IUNIT = I1MACH(4)
         DO 10 ICHAR=1,LENMES,72
            LAST = MIN0(ICHAR+71 , LENMES)
            WRITE (IUNIT,'(1X,A)') MESSG(ICHAR:LAST)
   10    CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE XSETUN(IUNIT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  XSETUN
C***DATE WRITTEN   790801   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  R3B
C***KEYWORDS  ERROR,XERROR PACKAGE
C***AUTHOR  JONES, R. E., (SNLA)
C***PURPOSE  Sets output file to which error messages are to be sent.
C***DESCRIPTION
C     Abstract
C        XSETUN sets the output file to which error messages are to
C        be sent.  Only one file will be used.  See XSETUA for
C        how to declare more than one file.
C
C     Description of Parameter
C      --Input--
C        IUNIT - an input parameter giving the logical unit number
C                to which error messages are to be sent.
C
C     Written by Ron Jones, with SLATEC Common Math Library Subcommittee
C     Latest revision ---  7 June 1978
C***REFERENCES  JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR-
C                 HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES,
C                 1982.
C***ROUTINES CALLED  J4SAVE
C***END PROLOGUE  XSETUN
C***FIRST EXECUTABLE STATEMENT  XSETUN
      JUNK = J4SAVE(3,IUNIT,.TRUE.)
      JUNK = J4SAVE(5,1,.TRUE.)
      RETURN
      END
      SUBROUTINE LA05AS(A, IND, NZ, IA, N, IP, IW, W, G, U)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  LA05AS
C***REFER TO  SPLP
C     THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
C     FROM THE C. 1979 AERE HARWELL LIBRARY.  THE NAME OF THE
C     CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
C     THE FINAL LETTER =S= IN THE NAMES USED HERE.
C     REVISIONS MADE BY R J HANSON, SNLA, AUGUST, 1979.
C     REVISED SEP. 13, 1979.
C
C     ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
C     IN THE PACKAGE GIVEN HERE.  ANY PRIMARY USAGE OF THE HARWELL
C     SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
C     THE USER AND AERE-UK.  ANY USAGE OF THE SANDIA WRITTEN CODES
C     SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
C
C IP(I,1),IP(I,2) POINT TO THE START OF ROW/COL I.
C IW(I,1),IW(I,2) HOLD THE NUMBER OF NON-ZEROS IN ROW/COL I.
C DURING THE MAIN BODY OF THIS SUBROUTINE THE VECTORS IW(.,3),IW(.,5),
C     IW(.,7) ARE USED TO HOLD DOUBLY LINKED LISTS OF ROWS THAT HAVE
C     NOT BEEN PIVOTAL AND HAVE EQUAL NUMBERS OF NON-ZEROS.
C IW(.,4),IW(.,6),IW(.,8) HOLD SIMILAR LISTS FOR THE COLUMNS.
C IW(I,3),IW(I,4) HOLD FIRST ROW/COLUMN TO HAVE I NON-ZEROS
C     OR ZERO IF THERE ARE NONE.
C IW(I,5), IW(I,6) HOLD ROW/COL NUMBER OF ROW/COL PRIOR TO ROW/COL I
C     IN ITS LIST, OR ZERO IF NONE.
C IW(I,7), IW(I,8) HOLD ROW/COL NUMBER OF ROW/COL AFTER ROW/COL I
C     IN ITS LIST, OR ZERO IF NONE.
C FOR ROWS/COLS THAT HAVE BEEN PIVOTAL IW(I,5),IW(I,6) HOLD NEGATION OF
C     POSITION OF ROW/COL I IN THE PIVOTAL ORDERING.
C
C***ROUTINES CALLED  LA05ES,MC20AS,XERROR,XERRWV,XSETUN
C***COMMON BLOCKS    LA05DS
C***END PROLOGUE  LA05AS
      INTEGER IP(N,2)
      INTEGER IND(IA,2), IW(N,8)
      DOUBLE PRECISION A(IA), AMAX, AU, AM, G, U, SMALL, W(N)
      COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL
C EPS IS THE RELATIVE ACCURACY OF FLOATING-POINT COMPUTATION
C***FIRST EXECUTABLE STATEMENT  LA05AS
      DATA EPS /0./
      IF (EPS.NE.0.) GO TO 30
      EPS=1.
   10 CONTINUE
      IF (EPS+1..EQ.1.) GO TO 20
      EPS = EPS*0.5
      GO TO 10
   20 EPS = EPS + EPS
   30 CONTINUE
C
C     SET THE OUTPUT UNIT NUMBER FOR THE ERROR PROCESSOR.
C     THE USAGE OF THIS ERROR PROCESSOR IS DOCUMENTED IN THE
C     SANDIA LABS. TECH. REPT. SAND78-1189, BY R E JONES.
      CALL XSETUN(LP)
      IF (U.GT.1.) U = 1.
      IF (U.LT.EPS) U = EPS
      IF (N.LT.1) GO TO 670
      G = 0.
      DO 50 I=1,N
         W(I) = 0.
         DO 40 J=1,5
            IW(I,J) = 0
   40    CONTINUE
   50 CONTINUE
C
C FLUSH OUT SMALL ENTRIES, COUNT ELEMENTS IN ROWS AND COLUMNS
      L = 1
      LENU = NZ
      DO 80 IDUMMY=1,NZ
         IF (L.GT.LENU) GO TO 90
         DO 60 K=L,LENU
            IF (DABS(A(K)).LE.SMALL) GO TO 70
            I = IND(K,1)
            J = IND(K,2)
            G = DMAX1(DABS(A(K)),G)
            IF (I.LT.1 .OR. I.GT.N) GO TO 680
            IF (J.LT.1 .OR. J.GT.N) GO TO 680
            IW(I,1) = IW(I,1) + 1
            IW(J,2) = IW(J,2) + 1
   60    CONTINUE
         GO TO 90
   70    L = K
         A(L) = A(LENU)
         IND(L,1) = IND(LENU,1)
         IND(L,2) = IND(LENU,2)
         LENU = LENU - 1
   80 CONTINUE
C
   90 LENL = 0
      LROW = LENU
      LCOL = LROW
C MCP IS THE MAXIMUM NUMBER OF COMPRESSES PERMITTED BEFORE AN
C     ERROR RETURN RESULTS.
      MCP = MAX0(N/10,20)
      NCP = 0
C CHECK FOR NULL ROW OR COLUMN AND INITIALIZE IP(I,2) TO POINT
C     JUST BEYOND WHERE THE LAST COMPONENT OF COLUMN I OF A WILL
C     BE STORED.
      K = 1
      DO 110 IR=1,N
         K = K + IW(IR,2)
         IP(IR,2) = K
         DO 100 L=1,2
            IF (IW(IR,L).LE.0) GO TO 700
  100    CONTINUE
  110 CONTINUE
C REORDER BY ROWS
C CHECK FOR DOUBLE ENTRIES WHILE USING THE NEWLY CONSTRUCTED
C     ROW FILE TO CONSTRUCT THE COLUMN FILE. NOTE THAT BY PUTTING
C    THE ENTRIES IN BACKWARDS AND DECREASING IP(J,2) EACH TIME IT
C     IS USED WE AUTOMATICALLY LEAVE IT POINTING TO THE FIRST ELEMENT.
      CALL MC20AS(N, LENU, A, IND(1,2), IP, IND(1,1), 0)
      KL = LENU
      DO 130 II=1,N
         IR = N + 1 - II
         KP = IP(IR,1)
         DO 120 K=KP,KL
            J = IND(K,2)
            IF (IW(J,5).EQ.IR) GO TO 660
            IW(J,5) = IR
            KR = IP(J,2) - 1
            IP(J,2) = KR
            IND(KR,1) = IR
  120    CONTINUE
         KL = KP - 1
  130 CONTINUE
C
C SET UP LINKED LISTS OF ROWS AND COLS WITH EQUAL NUMBERS OF NON-ZEROS.
      DO 150 L=1,2
         DO 140 I=1,N
            NZ = IW(I,L)
            IN = IW(NZ,L+2)
            IW(NZ,L+2) = I
            IW(I,L+6) = IN
            IW(I,L+4) = 0
            IF (IN.NE.0) IW(IN,L+4) = I
  140    CONTINUE
  150 CONTINUE
C
C
C START OF MAIN ELIMINATION LOOP.
      DO 590 IPV=1,N
C FIND PIVOT. JCOST IS MARKOWITZ COST OF CHEAPEST PIVOT FOUND SO FAR,
C     WHICH IS IN ROW IPP AND COLUMN JP.
         JCOST = N*N
C LOOP ON LENGTH OF COLUMN TO BE SEARCHED
         DO 240 NZ=1,N
            IF (JCOST.LE.(NZ-1)**2) GO TO 250
            J = IW(NZ,4)
C SEARCH COLUMNS WITH NZ NON-ZEROS.
            DO 190 IDUMMY=1,N
               IF (J.LE.0) GO TO 200
               KP = IP(J,2)
               KL = KP + IW(J,2) - 1
               DO 180 K=KP,KL
                  I = IND(K,1)
                  KCOST = (NZ-1)*(IW(I,1)-1)
                  IF (KCOST.GE.JCOST) GO TO 180
                  IF (NZ.EQ.1) GO TO 170
C FIND LARGEST ELEMENT IN ROW OF POTENTIAL PIVOT.
                  AMAX = 0.
                  K1 = IP(I,1)
                  K2 = IW(I,1) + K1 - 1
                  DO 160 KK=K1,K2
                     AMAX = DMAX1(AMAX,DABS(A(KK)))
                     IF (IND(KK,2).EQ.J) KJ = KK
  160             CONTINUE
C PERFORM STABILITY TEST.
                  IF (DABS(A(KJ)).LT.AMAX*U) GO TO 180
  170             JCOST = KCOST
                  IPP = I
                  JP = J
                  IF (JCOST.LE.(NZ-1)**2) GO TO 250
  180          CONTINUE
               J = IW(J,8)
  190       CONTINUE
C SEARCH ROWS WITH NZ NON-ZEROS.
  200       I = IW(NZ,3)
            DO 230 IDUMMY=1,N
               IF (I.LE.0) GO TO 240
               AMAX = 0.
               KP = IP(I,1)
               KL = KP + IW(I,1) - 1
C FIND LARGEST ELEMENT IN THE ROW
               DO 210 K=KP,KL
                  AMAX = DMAX1(DABS(A(K)),AMAX)
  210          CONTINUE
               AU = AMAX*U
               DO 220 K=KP,KL
C PERFORM STABILITY TEST.
                  IF (DABS(A(K)).LT.AU) GO TO 220
                  J = IND(K,2)
                  KCOST = (NZ-1)*(IW(J,2)-1)
                  IF (KCOST.GE.JCOST) GO TO 220
                  JCOST = KCOST
                  IPP = I
                  JP = J
                  IF (JCOST.LE.(NZ-1)**2) GO TO 250
  220          CONTINUE
               I = IW(I,7)
  230       CONTINUE
  240    CONTINUE
C
C PIVOT FOUND.
C REMOVE ROWS AND COLUMNS INVOLVED IN ELIMINATION FROM ORDERING VECTORS.
  250    KP = IP(JP,2)
         KL = IW(JP,2) + KP - 1
         DO 290 L=1,2
            DO 280 K=KP,KL
               I = IND(K,L)
               IL = IW(I,L+4)
               IN = IW(I,L+6)
               IF (IL.EQ.0) GO TO 260
               IW(IL,L+6) = IN
               GO TO 270
  260          NZ = IW(I,L)
               IW(NZ,L+2) = IN
  270          IF (IN.GT.0) IW(IN,L+4) = IL
  280       CONTINUE
            KP = IP(IPP,1)
            KL = KP + IW(IPP,1) - 1
  290    CONTINUE
C STORE PIVOT
         IW(IPP,5) = -IPV
         IW(JP,6) = -IPV
C ELIMINATE PIVOTAL ROW FROM COLUMN FILE AND FIND PIVOT IN ROW FILE.
         DO 320 K=KP,KL
            J = IND(K,2)
            KPC = IP(J,2)
            IW(J,2) = IW(J,2) - 1
            KLC = KPC + IW(J,2)
            DO 300 KC=KPC,KLC
               IF (IPP.EQ.IND(KC,1)) GO TO 310
  300       CONTINUE
  310       IND(KC,1) = IND(KLC,1)
            IND(KLC,1) = 0
            IF (J.EQ.JP) KR = K
  320    CONTINUE
C BRING PIVOT TO FRONT OF PIVOTAL ROW.
         AU = A(KR)
         A(KR) = A(KP)
         A(KP) = AU
         IND(KR,2) = IND(KP,2)
         IND(KP,2) = JP
C
C PERFORM ELIMINATION ITSELF, LOOPING ON NON-ZEROS IN PIVOT COLUMN.
         NZC = IW(JP,2)
         IF (NZC.EQ.0) GO TO 550
         DO 540 NC=1,NZC
            KC = IP(JP,2) + NC - 1
            IR = IND(KC,1)
C SEARCH NON-PIVOT ROW FOR ELEMENT TO BE ELIMINATED.
            KR = IP(IR,1)
            KRL = KR + IW(IR,1) - 1
            DO 330 KNP=KR,KRL
               IF (JP.EQ.IND(KNP,2)) GO TO 340
  330       CONTINUE
C BRING ELEMENT TO BE ELIMINATED TO FRONT OF ITS ROW.
  340       AM = A(KNP)
            A(KNP) = A(KR)
            A(KR) = AM
            IND(KNP,2) = IND(KR,2)
            IND(KR,2) = JP
            AM = -A(KR)/A(KP)
C COMPRESS ROW FILE UNLESS IT IS CERTAIN THAT THERE IS ROOM FOR NEW ROW.
            IF (LROW+IW(IR,1)+IW(IPP,1)+LENL.LE.IA) GO TO 350
            IF (NCP.GE.MCP .OR. LENU+IW(IR,1)+IW(IPP,1)+LENL.GT.IA) GO
     *       TO 710
            CALL LA05ES(A, IND(1,2), IP, N, IW, IA, .TRUE.)
            KP = IP(IPP,1)
            KR = IP(IR,1)
  350       KRL = KR + IW(IR,1) - 1
            KQ = KP + 1
            KPL = KP + IW(IPP,1) - 1
C PLACE PIVOT ROW (EXCLUDING PIVOT ITSELF) IN W.
            IF (KQ.GT.KPL) GO TO 370
            DO 360 K=KQ,KPL
               J = IND(K,2)
               W(J) = A(K)
  360       CONTINUE
  370       IP(IR,1) = LROW + 1
C
C TRANSFER MODIFIED ELEMENTS.
            IND(KR,2) = 0
            KR = KR + 1
            IF (KR.GT.KRL) GO TO 430
            DO 420 KS=KR,KRL
               J = IND(KS,2)
               AU = A(KS) + AM*W(J)
               IND(KS,2) = 0
C IF ELEMENT IS VERY SMALL REMOVE IT FROM U.
               IF (DABS(AU).LE.SMALL) GO TO 380
               G = DMAX1(G,DABS(AU))
               LROW = LROW + 1
               A(LROW) = AU
               IND(LROW,2) = J
               GO TO 410
  380          LENU = LENU - 1
C REMOVE ELEMENT FROM COL FILE.
               K = IP(J,2)
               KL = K + IW(J,2) - 1
               IW(J,2) = KL - K
               DO 390 KK=K,KL
                  IF (IND(KK,1).EQ.IR) GO TO 400
  390          CONTINUE
  400          IND(KK,1) = IND(KL,1)
               IND(KL,1) = 0
  410          W(J) = 0.
  420       CONTINUE
C
C SCAN PIVOT ROW FOR FILLS.
  430       IF (KQ.GT.KPL) GO TO 520
            DO 510 KS=KQ,KPL
               J = IND(KS,2)
               AU = AM*W(J)
               IF (DABS(AU).LE.SMALL) GO TO 500
               LROW = LROW + 1
               A(LROW) = AU
               IND(LROW,2) = J
               LENU = LENU + 1
C
C CREATE FILL IN COLUMN FILE.
               NZ = IW(J,2)
               K = IP(J,2)
               KL = K + NZ - 1
               IF (NZ .EQ. 0) GO TO 460
C IF POSSIBLE PLACE NEW ELEMENT AT END OF PRESENT ENTRY.
               IF (KL.NE.LCOL) GO TO 440
               IF (LCOL+LENL.GE.IA) GO TO 460
               LCOL = LCOL + 1
               GO TO 450
  440          IF (IND(KL+1,1).NE.0) GO TO 460
  450          IND(KL+1,1) = IR
               GO TO 490
C NEW ENTRY HAS TO BE CREATED.
  460          IF (LCOL+LENL+NZ+1.LT.IA) GO TO 470
C COMPRESS COLUMN FILE IF THERE IS NOT ROOM FOR NEW ENTRY.
               IF (NCP.GE.MCP .OR. LENU+LENL+NZ+1.GE.IA) GO TO 710
               CALL LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.)
               K = IP(J,2)
               KL = K + NZ - 1
C TRANSFER OLD ENTRY INTO NEW.
  470          IP(J,2) = LCOL + 1
               IF (KL .LT. K) GO TO 485
               DO 480 KK=K,KL
                  LCOL = LCOL + 1
                  IND(LCOL,1) = IND(KK,1)
                  IND(KK,1) = 0
  480          CONTINUE
  485          CONTINUE
C ADD NEW ELEMENT.
               LCOL = LCOL + 1
               IND(LCOL,1) = IR
  490          G = DMAX1(G,DABS(AU))
               IW(J,2) = NZ + 1
  500          W(J) = 0.
  510       CONTINUE
  520       IW(IR,1) = LROW + 1 - IP(IR,1)
C
C STORE MULTIPLIER
            IF (LENL+LCOL+1.LE.IA) GO TO 530
C COMPRESS COL FILE IF NECESSARY.
            IF (NCP.GE.MCP) GO TO 710
            CALL LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.)
  530       K = IA - LENL
            LENL = LENL + 1
            A(K) = AM
            IND(K,1) = IPP
            IND(K,2) = IR
            LENU = LENU - 1
  540    CONTINUE
C
C INSERT ROWS AND COLUMNS INVOLVED IN ELIMINATION IN LINKED LISTS
C     OF EQUAL NUMBERS OF NON-ZEROS.
  550    K1 = IP(JP,2)
         K2 = IW(JP,2) + K1 - 1
         IW(JP,2) = 0
         DO 580 L=1,2
            IF (K2.LT.K1) GO TO 570
            DO 560 K=K1,K2
               IR = IND(K,L)
               IF (L.EQ.1) IND(K,L) = 0
               NZ = IW(IR,L)
               IF (NZ.LE.0) GO TO 720
               IN = IW(NZ,L+2)
               IW(IR,L+6) = IN
               IW(IR,L+4) = 0
               IW(NZ,L+2) = IR
               IF (IN.NE.0) IW(IN,L+4) = IR
  560       CONTINUE
  570       K1 = IP(IPP,1) + 1
            K2 = IW(IPP,1) + K1 - 2
  580    CONTINUE
  590 CONTINUE
C
C RESET COLUMN FILE TO REFER TO U AND STORE ROW/COL NUMBERS IN
C     PIVOTAL ORDER IN IW(.,3),IW(.,4)
      DO 600 I=1,N
         J = -IW(I,5)
         IW(J,3) = I
         J = -IW(I,6)
         IW(J,4) = I
         IW(I,2) = 0
  600 CONTINUE
      DO 620 I=1,N
         KP = IP(I,1)
         KL = IW(I,1) + KP - 1
         DO 610 K=KP,KL
            J = IND(K,2)
            IW(J,2) = IW(J,2) + 1
  610    CONTINUE
  620 CONTINUE
      K = 1
      DO 630 I=1,N
         K = K + IW(I,2)
         IP(I,2) = K
  630 CONTINUE
      LCOL = K - 1
      DO 650 II=1,N
         I = IW(II,3)
         KP = IP(I,1)
         KL = IW(I,1) + KP - 1
         DO 640 K=KP,KL
            J = IND(K,2)
            KN = IP(J,2) - 1
            IP(J,2) = KN
            IND(KN,1) = I
  640    CONTINUE
  650 CONTINUE
      GO TO 760
C
C     THE FOLLOWING INSTRUCTIONS IMPLEMENT THE FAILURE EXITS.
  660 CONTINUE
      NERR = -4
      IOPT = 1
      NI = 2
      NR = 0
      IF (LP.GT.0) CALL XERRWV(
     *   'LA05AS. MORE THAN ONE MATRIX ENTRY.  HERE I1=ROW, I2=COL.',
     * 57, NERR, IOPT, NI, IR, J, NR, DUMMY, DUMMY)
      G = -4.
      GO TO 760
  670 CONTINUE
      NERR = -1
      IOPT = 1
      IF (LP.GT.0) CALL XERROR(
     *   'LA05AS. THE ORDER OF THE SYSTEM, N, IS NOT POSITIVE.', 52,
     * NERR, IOPT)
      G = -1.
      GO TO 760
  680 CONTINUE
      NERR = -3
      IOPT = 1
      NI = 1
      NR = 0
      IF (LP.LE.0) GO TO 690
      CALL XERRWV('LA05AS. ELEMENT K IS OUT OF BOUNDS.  HERE I1=K.',
     * 47, NERR, IOPT, NI, K, IDUMMY, NR, DUMMY, DUMMY)
      NI = 2
      CALL XERRWV('LA05AS.  HERE I1=ROW, I2=COL.', 29, NERR, IOPT, NI,
     * I, J, NR, DUMMY, DUMMY)
  690 CONTINUE
      G = -3.
      GO TO 760
  700 CONTINUE
      NERR = -2
      IOPT = 1
      NI = 1
      NR = 0
      IF (LP.GT.0) CALL XERRWV(
     * 'LA05AS. ROW OR COL HAS NO ELEMENTS.  HERE I1=INDEX.', 51,
     * NERR, IOPT, NI, L, IDUMMY, NR, DUMMY, DUMMY)
      G = -2.
      GO TO 760
  710 CONTINUE
      NERR = -7
      IOPT = 1
      IF (LP.GT.0) CALL XERROR(
     * 'LA05AS. LENGTHS OF ARRAYS A(*) AND IND(*,2) ARE TOO SMALL.',
     * 58, NERR, IOPT)
      G = -7.
      GO TO 760
  720 IPV = IPV + 1
      IW(IPV,1) = IR
      DO 730 I=1,N
         II = -IW(I,L+4)
         IF (II.GT.0) IW(II,1) = I
  730 CONTINUE
      IF (LP.LE.0) GO TO 750
      NERR = -5
      IOPT = 1
      NI = 1
      NR = 0
      CALL XERRWV(
     * 'LA05AS. DEPENDENT ROWS OR COLS.  HERE I1=1 (ROWS), =2 (COLS)',
     * 60, NERR, IOPT, NI, L, IDUMMY, NR, DUMMY, DUMMY)
      I = 1
      NI = 2
  740 CONTINUE
      IF (I+1.GT.IPV) NI = 1
      CALL XERRWV('LA05AS. DEPENDENT VECTOR INDICES ARE I1 AND I2.',
     * 47, NERR, IOPT, NI, IW(I,1), IW(I+1,1), NR, DUMMY, DUMMY)
      I = I + 2
      IF (I.LE.IPV) GO TO 740
  750 CONTINUE
      G = -5.
  760 RETURN
      END
      SUBROUTINE MC20AS(NC, MAXA, A, INUM, JPTR, JNUM, JDISP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***BEGIN PROLOGUE  MC20AS
C***REFER TO  SPLP
C     THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
C     FROM THE C. 1979 AERE HARWELL LIBRARY.  THE NAME OF THE
C     CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
C     THE FINAL LETTER =S= IN THE NAMES USED HERE.
C     REVISED SEP. 13, 1979.
C
C     ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
C     IN THE PACKAGE GIVEN HERE.  ANY PRIMARY USAGE OF THE HARWELL
C     SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
C     THE USER AND AERE-UK.  ANY USAGE OF THE SANDIA WRITTEN CODES
C     SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  MC20AS
      INTEGER INUM(MAXA), JNUM(MAXA)
      DOUBLE PRECISION A(MAXA)
      DIMENSION JPTR(NC)
C***FIRST EXECUTABLE STATEMENT  MC20AS
      NULL = -JDISP
C**      CLEAR JPTR
      DO 10 J=1,NC
         JPTR(J) = 0
   10 CONTINUE
C**      COUNT THE NUMBER OF ELEMENTS IN EACH COLUMN.
      DO 20 K=1,MAXA
         J = JNUM(K) + JDISP
         JPTR(J) = JPTR(J) + 1
   20 CONTINUE
C**      SET THE JPTR ARRAY
      K = 1
      DO 30 J=1,NC
         KR = K + JPTR(J)
         JPTR(J) = K
         K = KR
   30 CONTINUE
C
C**      REORDER THE ELEMENTS INTO COLUMN ORDER.  THE ALGORITHM IS AN
C        IN-PLACE SORT AND IS OF ORDER MAXA.
      DO 50 I=1,MAXA
C        ESTABLISH THE CURRENT ENTRY.
         JCE = JNUM(I) + JDISP
         IF (JCE.EQ.0) GO TO 50
         ACE = A(I)
         ICE = INUM(I)
C        CLEAR THE LOCATION VACATED.
         JNUM(I) = NULL
C        CHAIN FROM CURRENT ENTRY TO STORE ITEMS.
         DO 40 J=1,MAXA
C        CURRENT ENTRY NOT IN CORRECT POSITION.  DETERMINE CORRECT
C        POSITION TO STORE ENTRY.
            LOC = JPTR(JCE)
            JPTR(JCE) = JPTR(JCE) + 1
C        SAVE CONTENTS OF THAT LOCATION.
            ACEP = A(LOC)
            ICEP = INUM(LOC)
            JCEP = JNUM(LOC)
C        STORE CURRENT ENTRY.
            A(LOC) = ACE
            INUM(LOC) = ICE
            JNUM(LOC) = NULL
C        CHECK IF NEXT CURRENT ENTRY NEEDS TO BE PROCESSED.
            IF (JCEP.EQ.NULL) GO TO 50
C        IT DOES.  COPY INTO CURRENT ENTRY.
            ACE = ACEP
            ICE = ICEP
            JCE = JCEP + JDISP
   40    CONTINUE
C
   50 CONTINUE
C
C**      RESET JPTR VECTOR.
      JA = 1
      DO 60 J=1,NC
         JB = JPTR(J)
         JPTR(J) = JA
         JA = JB
   60 CONTINUE
      RETURN
      END

