These are sample FORTRAN programs used in part (6) or in whole throughout this document. In addition to these programs, there may be additional sample FORTRAN programs distributed with the Optimization Library code. Note that these simple driver programs are only samples that show how an application program that uses Optimization Library modules should be organized. They should not be used for production work or for evaluating performance.
C***********************************************************************
C
C EXQSLV
C
C This program reads a quadratic problem from MPS files, solves
C the problem, and prints the solution.
C
C***********************************************************************
C
PROGRAM MAIN
C
C Allocate dspace.
IMPLICIT NONE
INTEGER*4 MAXSPC,RTCOD
PARAMETER (MAXSPC=100000)
REAL*8 DSPACE(MAXSPC)
COMMON/BIG/DSPACE
C
C Describe application and specify that there is 1 model.
CALL EKKDSCA(RTCOD,DSPACE,MAXSPC,1)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCA',RTCOD)
C
C Describe the model. Minimum of 5 blocks are needed for QP.
CALL EKKDSCM(RTCOD,DSPACE,1,5)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCM',RTCOD)
C
C Read linear model data from MPS file on unit 98.
CALL EKKMPS(RTCOD,DSPACE,98,2,0)
IF (RTCOD.GT.0) CALL CHKRT('EKKMPS ',RTCOD)
C
C Read quadratic matrix from file on unit 10.
CALL EKKQMPS(RTCOD,DSPACE,10,2)
IF (RTCOD.GT.0) CALL CHKRT('EKKQMPS',RTCOD)
C
C Solve quadratic problem using primal algorithm.
CALL EKKQSLV(RTCOD,DSPACE,1,1)
IF (RTCOD.GT.0) CALL CHKRT('EKKQSLV',RTCOD)
C
C Print the solution.
CALL EKKPRTS(RTCOD,DSPACE)
IF (RTCOD.GT.0) CALL CHKRT('EKKPRTS',RTCOD)
C
STOP
END
C
C***********************************************************************
C This subroutine prints the character string RTNAME and the return
C code RTCOD and stops if RTCOD is large enough to indicate that an
C error or severe error has occured.
C***********************************************************************
C
SUBROUTINE CHKRT(RTNAME,RTCOD)
CHARACTER*7 RTNAME
INTEGER*4 RTCOD
C
WRITE(6,9000) RTNAME,RTCOD
IF (RTCOD.GE.200) STOP 16
RETURN
9000 FORMAT (1X,'********** ',A7,' return code of ',I4,' **********')
END
You can run this program using "Sample Linear Programming Model Data 1" and "Sample Quadratic Programming Model Data 1".
C***********************************************************************
C
C EXROW
C
C This program solves the following problem:
C
C Maximize 4*x4 + 0.1*x5 + 6*x10 + 0.15*x11 + 8*x16 + 0.15*x17
C + 6*x22 + 0.15*x23 + 3*x26 + 0.1*x27
C + 3*x29 + 0.1*x30
C
C Subject to Dx = b; x = 0
C
C where trans(b) = (0,0,0,0,0,0,0,0,0,0,100,50)
C
C and the matrix D has the form:
C
C -------+-------
C | | A |
C | B | |
C | |------+-------
C | | | A |
C -------| B | |
C | |------+-------
C | | | A |
C -------| B | |
C | |------+---------
C | | | |
C -------| B | C |
C | | |
C | | |
C -----------------
C --------
C | A |
C | |
C --------
C
C Here A is a 2 X 6 matrix:
C
C __ __
C | 1 1 1 1 0 0 |
C A = | |
C | 3 0 0 0 1 1 |
C -- --
C
C B is a 4 X 6 matrix:
C
C __ __
C | 0 0 -1 0 0 0 |
C | |
C | 0 0 0 0 0 -1 |
C B = | |
C |-4 -1 0 0 0 0 |
C | |
C | 0 -10 0 0 0 0 |
C -- --
C
C C is a 4 X 6 matrix:
C
C __ __
C | 1 1 0 0 0 0 |
C | |
C | 0 0 1 1 0 0 |
C C = | |
C |-1 0 0 0 1 0 |
C | |
C | 0 0 0 -1 0 1 |
C -- --
C
C NROW is the total number of rows in the composite matrix.
C NCOL is the total number of columns in the composite matrix.
C NA is the number of elements in A.
C NACOL is the number of columns in A.
C A is the matrix elements of block A.
C IA is the row indices of block A.
C JA is the column indices of block A.
C NB is the number of elements in B.
C NBCOL is the number of columns in B.
C B is the matrix elements of block B.
C IB is the row indices of block B.
C JB is the column starts of block B.
C DOBJ is the objective row.
C DRLO is the row lower bounds.
C DRUP is the row upper bounds.
C DCLO is the column lower bounds.
C DCUP is the column upper bounds.
C
C To illustrate the use of EKKROW and EKKCOL, this program
C first builds a matrix (D') which is D, but missing the last
C occurrence of A and the occurrence of C. This last A block is added
C by using EKKROW twice (once for each row) and C is added using
C EKKCOL 6 times (once for each column).
C
C***********************************************************************
C
PROGRAM MAIN
C
C Bring in include files with control variable definitions.
INCLUDE (OSLI)
INCLUDE (OSLR)
INCLUDE (OSLN)
C
C Allocate dspace and other arrays.
PARAMETER (MAXSPC=15000)
REAL*8 DSPACE(MAXSPC)
INTEGER*4 IA(10),JA(10),IB(10),JB(10),RTCOD
REAL*8 A(10),B(10),DRLO(12),DRUP(12),DCLO(30),DCUP(30),DOBJ(30)
C
DATA NROW,NCOL/12,30/NACOL,NA,IATYPE/6,7,1/NBCOL,NB,IBTYPE/6,5,2/
C
C Columns to add.
REAL*8 CC1(2),CC2(1),CC3(1),CC4(2),CC5(1),CC6(1)
DATA CC1 /1.0D0,-1.0D0/ CC2 /1.0D0/ CC3 /1.0D0/
DATA CC4 /1.0D0,-1.0D0/ CC5 /1.0D0/ CC6 /1.0D0/
C
C Indices of columns to add.
INTEGER*4 ICC1(2),ICC2(1),ICC3(1),ICC4(2),ICC5(1),ICC6(1)
DATA ICC1 /7,9/ ICC2 /7/ ICC3 /8/
DATA ICC4 /8,10/ICC5 /9/ ICC6 /10/
C
C Rows to add.
REAL*8 AR1(4),AR2(3)
DATA AR1 /4*1.0D0/ AR2 /3.0D0,2*1.0D0/
C
C Indices of rows to add.
INTEGER*4 IAR1(4), IAR2(3)
DATA IAR1 /1,2,3,4/ IAR2 /1,5,6/
C
C Matrix elements.
DATA A /1.0D0,3.0D0,5*1.0D0,3*0.0D0/
DATA B /-4.0D0,-1.0D0,-1.0D1,2*-1.0D0,5*0.0D0/
C
C Row indices.
DATA IA/1,2,3*1,2*2,3*0/ IB/3,3,4,1,2,5*0/
C
C Column indices (starts).
DATA JA/1,1,2,3,4,5,6,3*0/ JB/1,2,4,5,5,5,6,3*0/
C
C Lower and upper bounds on row activities.
DATA DRLO/12*0.0D0/DRUP/12*0.0D0/
C
C Lower and upper bounds on columns.
DATA DCLO/30*0.0D0/DCUP/24*1.0D31,6*0.0D0/
C
C Objective function coefficients.
C (Leave off those applying to block "C"; they'll be added later.)
DATA DOBJ /3*0.0D0,4.0D0,1.0D-1,4*0.0D0,6.0D0,1.5D-1,
+ 4*0.0D0,8.0D0,1.5D-1,4*0.0D0,6.0D0,1.5D-1,0.0D0,
+ 6*0.0D0/
C
C
C Describe application and specify that there is 1 model.
CALL EKKDSCA(RTCOD,DSPACE,MAXSPC,1)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCA',RTCOD)
C
C Describe model as having 7 blocks.
CALL EKKDSCM(RTCOD,DSPACE,1,7)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCM',RTCOD)
C
C Set to maximization problem.
CALL EKKRGET(RTCOD,DSPACE,OSLR,OSLRLN)
IF (RTCOD.GT.0) CALL CHKRT('EKKRGET',RTCOD)
RMAXMIN=-1.0D0
CALL EKKRSET(RTCOD,DSPACE,OSLR,OSLRLN)
IF (RTCOD.GT.0) CALL CHKRT('EKKRSET',RTCOD)
C
C Set up the model.
CALL EKKLMDL(RTCOD,DSPACE,1,NROW,NCOL,0,DOBJ,DRLO,DRUP,
+ DCLO,DCUP,0,0,0)
IF (RTCOD.GT.0) CALL CHKRT('EKKLMDL',RTCOD)
C
C Describe A block.
CALL EKKDSCB(RTCOD,DSPACE,IATYPE,1,IA,JA,A,0,6,NACOL,NA)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCB',RTCOD)
C
C Describe B block.
CALL EKKDSCB(RTCOD,DSPACE,IBTYPE,2,IB,JB,B,0,0,NBCOL,NB)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCB',RTCOD)
C
C Repeat A block.
CALL EKKDSCB(RTCOD,DSPACE,IATYPE,3,IA,JA,A,2,12,NACOL,NA)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCB',RTCOD)
C
CALL EKKDSCB(RTCOD,DSPACE,IATYPE,4,IA,JA,A,4,18,NACOL,NA)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCB',RTCOD)
C
C Repeat B block.
CALL EKKDSCB(RTCOD,DSPACE,IBTYPE,5,IB,JB,B,2,6,NBCOL,NB)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCB',RTCOD)
C
CALL EKKDSCB(RTCOD,DSPACE,IBTYPE,6,IB,JB,B,4,12,NBCOL,NB)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCB',RTCOD)
C
CALL EKKDSCB(RTCOD,DSPACE,IBTYPE,7,IB,JB,B,6,18,NBCOL,NB)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCB',RTCOD)
C
C We have now finished building D'; now we add the last A
C block and the C block.
C
C Add the necessary rows to add the last A block.
CALL EKKROW(RTCOD,DSPACE,1,11,4,AR1,IAR1)
IF (RTCOD.GT.0) CALL CHKRT('EKKROW1',RTCOD)
CALL EKKROW(RTCOD,DSPACE,1,12,3,AR2,IAR2)
IF (RTCOD.GT.0) CALL CHKRT('EKKROW2',RTCOD)
C
C Add the bounds on the newly added rows.
CALL EKKNGET(RTCOD,DSPACE,OSLN,OSLNLN)
IF (RTCOD.GT.0) CALL CHKRT('EKKNGET',RTCOD)
C Lower bounds.
DSPACE(NROWLOWER+10)=1.0D2
DSPACE(NROWLOWER+11)=0.5D2
C Upper bounds.
DSPACE(NROWUPPER+10)=1.0D2
DSPACE(NROWUPPER+11)=0.5D2
C
C Add the necessary columns to add the C block.
CALL EKKCOL(RTCOD,DSPACE,1,25,2,CC1,ICC1)
IF (RTCOD.GT.0) CALL CHKRT('EKKCOL1',RTCOD)
CALL EKKCOL(RTCOD,DSPACE,1,26,1,CC2,ICC2)
IF (RTCOD.GT.0) CALL CHKRT('EKKCOL2',RTCOD)
CALL EKKCOL(RTCOD,DSPACE,1,27,1,CC3,ICC3)
IF (RTCOD.GT.0) CALL CHKRT('EKKCOL3',RTCOD)
CALL EKKCOL(RTCOD,DSPACE,1,28,2,CC4,ICC4)
IF (RTCOD.GT.0) CALL CHKRT('EKKCOL4',RTCOD)
CALL EKKCOL(RTCOD,DSPACE,1,29,1,CC5,ICC5)
IF (RTCOD.GT.0) CALL CHKRT('EKKCOL5',RTCOD)
CALL EKKCOL(RTCOD,DSPACE,1,30,1,CC6,ICC6)
IF (RTCOD.GT.0) CALL CHKRT('EKKCOL6',RTCOD)
C
C Add the lower/upper bounds on the newly added columns.
CALL EKKNGET(RTCOD,DSPACE,OSLN,OSLNLN)
IF (RTCOD.GT.0) CALL CHKRT('EKKNGET',RTCOD)
DO I = 24,29
DSPACE(NCOLLOWER+I)=0.0D0
DSPACE(NCOLUPPER+I)=1.0D31
ENDDO
C
C Add contribution to objective function of newly added columns.
DSPACE(NOBJECTIVE+24)=0.0D0
DSPACE(NOBJECTIVE+25)=3.0D0
DSPACE(NOBJECTIVE+26)=1.0D-1
DSPACE(NOBJECTIVE+27)=0.0D0
DSPACE(NOBJECTIVE+28)=3.0D0
DSPACE(NOBJECTIVE+29)=1.0D-1
C
C Create a new copy of the matrix.
CALL EKKNWMT(RTCOD,DSPACE,3)
IF (RTCOD.GT.0) CALL CHKRT('EKKNWMT',RTCOD)
C
C Solve the LP using the simplex method.
CALL EKKSSLV(RTCOD,DSPACE,1,2)
IF (RTCOD.GT.0) CALL CHKRT('EKKSSLV',RTCOD)
C
C Set to print only columns with nonzero activities.
CALL EKKIGET(RTCOD,DSPACE,OSLI,OSLILN)
IF (RTCOD.GT.0) CALL CHKRT('EKKIGET',RTCOD)
ISOLMASK=6
CALL EKKISET(RTCOD,DSPACE,OSLI,OSLILN)
IF (RTCOD.GT.0) CALL CHKRT('EKKISET',RTCOD)
C
C Print the solution.
CALL EKKPRTS(RTCOD,DSPACE)
IF (RTCOD.GT.0) CALL CHKRT('EKKPRTS',RTCOD)
C
STOP
END
C
C
C***********************************************************************
C This subroutine prints the character string RTNAME and the return
C code RTCOD and stops if RTCOD is large enough to indicate that an
C error or severe error has occured.
C***********************************************************************
C
SUBROUTINE CHKRT(RTNAME,RTCOD)
CHARACTER*7 RTNAME
INTEGER*4 RTCOD
C
WRITE(6,9000) RTNAME,RTCOD
IF (RTCOD.GE.200) STOP 16
RETURN
9000 FORMAT (1X,'********** ',A7,' return code of ',I4,' **********')
END
No input data is required to run this program.
C***********************************************************************
C
C EXRPTB
C
C This program solves the same maximization problem as in sample
C program EXDSCB. However, EKKRPTB is used here to input the
C blocks multiple times.
C
C***********************************************************************
C
PROGRAM MAIN
C
C Bring in include files with control variable definitions.
INCLUDE (OSLI)
INCLUDE (OSLN)
INCLUDE (OSLR)
C
C Allocate dspace.
PARAMETER (MAXSPC=15000)
REAL*8 DSPACE(MAXSPC)
INTEGER*4 IA(10),JA(10),IB(10),JB(10),IC(10),JC(10),RTCOD
REAL*8 A(10),B(10),C(10)
REAL*8 DRLO(15), DRUP(15), DCLO(30), DCUP(30), DOBJ(30)
C
DATA NROW,NCOL/12,30/NACOL,NA,IATYPE/6,7,1/
DATA NBCOL,NB,IBTYPE/6,5,2/NCCOL,NC,ICTYPE/6,8,1/
C
C Matrix elements. The third element of block B will be changed
C after the block is input.
DATA A/1.0D0,3.0D0,5*1.0D0,3*0.0D0/
DATA B/-4.0D0,-1.0D0,-9.0D0,2*-1.0D0,5*0.0D0/
DATA C/1.0D0,-1.0D0,3*1.0D0,-1.0D0,2*1.0D0,2*0.0D0/
C
C Row indices.
DATA IA/1,2,3*1,2*2,3*0/IB/3,3,4,1,2,5*0/IC/1,3,1,2,2,4,3,4,2*0/
C
C Column indices (starts).
DATA JA/1,1,2,3,4,5,6,3*0/JB/1,2,4,5,5,5,6,3*0/
DATA JC/1,1,2,3,4,4,5,6,2*0/
C
C Lower/upper bounds on row cctivities.
DATA DRLO/1.0D02,5.0D01,13*0.0D0/DRUP/1.0D02,5.0D01,13*0.0D0/
C
C Lower/upper bounds on columns.
DATA DCLO /30*0.0D0/DCUP/30*1.0D31/
C
C Objective function coefficients.
DATA DOBJ /3*0.0D0,4.0D0,1.0D-1,4*0.0D0,6.0D0,1.5D-1,
+ 4*0.0D0,8.0D0,1.5D-1,4*0.0D0,6.0D0,1.5D-1,
+ 2*0.0D0,3.0D0,1.0D-1,0.0D0,3.0D0,1.0D-1/
C
C New third element for block B.
REAL*8 NEWELEM
DATA NEWELEM/-1.0D1/
C
C Pointer to original block B elements so pointer copies can
C be changed globally.
INTEGER*4 BLOCKBELS
C
C
C Describe application and specify that there is 1 model.
CALL EKKDSCA(RTCOD,DSPACE,MAXSPC,1)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCA',RTCOD)
C
C Describe the model as having 9 blocks.
CALL EKKDSCM(RTCOD,DSPACE,1,9)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCM',RTCOD)
C
C Set to maximization problem.
CALL EKKRGET(RTCOD,DSPACE,OSLR,OSLRLN)
IF (RTCOD.GT.0) CALL CHKRT('EKKRGET',RTCOD)
RMAXMIN=-1.0D0
CALL EKKRSET(RTCOD,DSPACE,OSLR,OSLRLN)
IF (RTCOD.GT.0) CALL CHKRT('EKKRSET',RTCOD)
C
C Set up the model.
CALL EKKLMDL(RTCOD,DSPACE,1,NROW,NCOL,0,DOBJ,DRLO,DRUP,
+ DCLO,DCUP,0,0,0)
IF (RTCOD.GT.0) CALL CHKRT('EKKLMDL',RTCOD)
C
C Describe first A block.
CALL EKKDSCB(RTCOD,DSPACE,IATYPE,0,IA,JA,A,0,0,NACOL,NA)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCB',RTCOD)
C
C Save the pointers to this block.
CALL EKKRGET(RTCOD,DSPACE,OSLR,OSLRLN)
IF (RTCOD.GT.0) CALL CHKRT('EKKRGET',RTCOD)
C
C Describe other A blocks. These blocks will be copied explicitly.
DO I=2,4
CALL EKKRPTB(RTCOD,DSPACE,1,1,0,(I-1)*2,(I-1)*6,1)
IF (RTCOD.GT.0) CALL CHKRT('EKKRPTB',RTCOD)
ENDDO
C
C Describe first B block.
CALL EKKDSCB(RTCOD,DSPACE,IBTYPE,0,IB,JB,B,2,0,NBCOL,NB)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCB',RTCOD)
C
C Save the pointer to elements for this block.
CALL EKKNGET(RTCOD,DSPACE,OSLN,OSLNLN)
IF (RTCOD.GT.0) CALL CHKRT('EKKNGET',RTCOD)
BLOCKBELS=NBLOCKELEM
C
C Describe other B blocks. These blocks will not be copied explicitly.
DO I=2,4
CALL EKKRPTB(RTCOD,DSPACE,0,0,I+4,I*2,(I-1)*6,0)
IF (RTCOD.GT.0) CALL CHKRT('EKKRPTB',RTCOD)
ENDDO
C
C Describe C block.
CALL EKKDSCB(RTCOD,DSPACE,ICTYPE,0,IC,JC,C,8,24,NCCOL,NC)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCB',RTCOD)
C
C Change the third element in the first B block. Since the
C copies of this block were made via pointers, this change
C will affect all B blocks.
DSPACE(BLOCKBELS+2) = NEWELEM
C
C Create a column copy of the matrix.
CALL EKKNWMT(RTCOD,DSPACE,2)
IF (RTCOD.GT.0) CALL CHKRT('EKKNWMT',RTCOD)
C
C Write the model to a file on unit 18 in MPS format.
CALL EKKBCDO(RTCOD,DSPACE,18,1,2)
IF (RTCOD.GT.0) CALL CHKRT('EKKBCDO',RTCOD)
C
C Solve LP using simplex method.
CALL EKKSSLV(RTCOD,DSPACE,1,2)
IF (RTCOD.GT.0) CALL CHKRT('EKKSSLV',RTCOD)
C
C Set to print columns with nonzero activities.
CALL EKKIGET(RTCOD,DSPACE,OSLI,OSLILN)
IF (RTCOD.GT.0) CALL CHKRT('EKKIGET',RTCOD)
ISOLMASK=6
CALL EKKISET(RTCOD,DSPACE,OSLI,OSLILN)
IF (RTCOD.GT.0) CALL CHKRT('EKKISET',RTCOD)
C
C Print the solution.
CALL EKKPRTS(RTCOD,DSPACE)
IF (RTCOD.GT.0) CALL CHKRT('EKKPRTS',RTCOD)
C
STOP
END
C
C***********************************************************************
C This subroutine prints the character string RTNAME and the return
C code RTCOD and stops if RTCOD is large enough to indicate that an
C error or severe error has occured.
C***********************************************************************
C
SUBROUTINE CHKRT(RTNAME,RTCOD)
CHARACTER*7 RTNAME
INTEGER*4 RTCOD
C
WRITE(6,9000) RTNAME,RTCOD
IF (RTCOD.GE.200) STOP 16
RETURN
9000 FORMAT (1X,'********** ',A7,' return code of ',I4,' **********')
END
No input data is required to run this program.
C***********************************************************************
C
C EXRVIS
C
C This program will read in a problem from an MPS file, solve the
C problem with the simplex method, read in a file to perform
C changes similar to the MPSX/370 function REVISE, and output
C the results after changing the matrix. A subroutine follows
C that performs the task of reading the REVISE MPS file and
C changing the matrix. Limitations on this REVISE-like subroutine
C are noted.
C
C***********************************************************************
C
PROGRAM MAIN
C
C Bring in include files with control variable definitions.
INCLUDE (OSLI)
INCLUDE (OSLR)
C
C Allocate dspace.
INTEGER*4 MAXSPC, RTCOD
PARAMETER (MAXSPC = 150000)
REAL*8 DSPACE(MAXSPC)
COMMON /BIG/DSPACE
C
C Define constants representing actions to be performed by
C REVISE-like subroutine. The action to be performed is the third
C parameter passed to the subroutine, where:
C
C < 0 - causes matrix to print in sorted format.
C 0 - indicates a new model is being revised.
C = 0 - indicates a previously revised model is being revised again.
INTEGER*4 IPRINT, IREVISE, IREVAGAIN
PARAMETER (IPRINT = -1)
PARAMETER (IREVISE = 1)
PARAMETER (IREVAGAIN = 0)
C
C Describe application and specify that there is one model.
CALL EKKDSCA (RTCOD,DSPACE,MAXSPC,1)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCA',RTCOD)
C
C Describe model as having 2 blocks. The second block will be
C used to describe changes in the model resulting from REVISE.
CALL EKKDSCM (RTCOD,DSPACE,1,2)
IF (RTCOD.GT.0) CALL CHKRT('EKKDSCM',RTCOD)
C
C Set integer control variables to allow for extra rows and columns
C resulting from REVISE.
CALL EKKIGET (RTCOD,DSPACE,OSLI,OSLILN)
IF (RTCOD.GT.0) CALL CHKRT('EKKIGET',RTCOD)
IMAXCOLS = -2000
IMAXROWS = -2000
IEXTRABLK = 2000
IPRTINFOMASK = 1023
CALL EKKISET (RTCOD,DSPACE,OSLI,OSLILN)
IF (RTCOD.GT.0) CALL CHKRT('EKKISET',RTCOD)
C
C Set to maximization problem.
CALL EKKRGET (RTCOD,DSPACE,OSLR,OSLRLN)
IF (RTCOD.GT.0) CALL CHKRT('EKKRGET',RTCOD)
RMAXMIN = -1.0D0
CALL EKKRSET (RTCOD,DSPACE,OSLR,OSLRLN)
IF (RTCOD.GT.0) CALL CHKRT('EKKRSET',RTCOD)
C
C Read model data from MPS file on unit 98.
CALL EKKMPS (RTCOD,DSPACE,98,2,0)
IF (RTCOD.GT.0) CALL CHKRT('EKKMPS ',RTCOD)
C
C Solve problem using simplex method.
CALL EKKSSLV (RTCOD,DSPACE,1,2)
IF (RTCOD.GT.0) CALL CHKRT('EKKSSLV',RTCOD)
C
C Read REVISE data on unit 98.
CALL REVISE (RTCOD,DSPACE,IREVISE,98)
C
C Solve again to get BFS solution to revised problem.
CALL EKKSSLV (RTCOD,DSPACE,1,3)
IF (RTCOD.GT.0) CALL CHKRT('EKKSSLV',RTCOD)
C
C Print the solution.
CALL EKKPRTS (RTCOD,DSPACE)
IF (RTCOD.GT.0) CALL CHKRT('EKKPRTS',RTCOD)
C
C Print revised matrix in sorted format.
CALL REVISE (RTCOD,DSPACE,IPRINT,98)
C
C Output model in MPS format on unit 10.
CALL EKKBCDO(RTCOD,DSPACE,10,1,2)
IF (RTCOD.GT.0) CALL CHKRT('EKKBCDO',RTCOD)
C
STOP
END
C
C***********************************************************************
C This subroutine prints the character string RTNAME and the return
C code RTCOD and stops if RTCOD is large enough to indicate that an
C error or severe error has occured.
C***********************************************************************
C
SUBROUTINE CHKRT(RTNAME,RTCOD)
CHARACTER*7 RTNAME
INTEGER*4 RTCOD
C
WRITE(6,9000) RTNAME,RTCOD
IF (RTCOD.GE.200) STOP 16
RETURN
9000 FORMAT (1X,'********** ',A7,' return code of ',I4,' **********')
END
C
C***********************************************************************
C This subroutine will perform changes similar to the MPSX/370
C function REVISE. Due to differences between the Optimization
C Library and MPSX/370, the following limitations exist:
C
C 1) Since Optimization Library input and model creation modules
C permit only one RHS, RANGE, and BOUND vector for a model,
C RHS, RANGE, and BOUND vectors cannot be added or deleted in
C an application using such modules. Similarly, the objective
C row cannot be added or deleted, in an application using
C library modules. However, it can be modified in the
C COLUMNS section.
C 2) Although RHS and RANGE values may be modified, the ROW must
C be defined in the REVISE MPS file in the MODIFY section.
C 3) Rows or columns that are deleted are actually zeroed out
C mathematically. The row or column still remains in the
C matrix, so the number of rows or columns will not change.
C 4) Rows or columns that are added are actually added at the
C end of the matrix in another block. They are not inserted
C before or after rows or columns as indicated in the BEFORE
C or AFTER sections.
C
C In addition, you should not scale your matrix before revisions.
C Code to handle scaled matrices using the index control variables
C Nrowscale and Ncolscale could be added.
C
C Fixed format input is assumed.
C
C The unit on which the REVISE MPS file resides is NOT rewound
C when REVISE is completed.
C
C Revision of integer variables, quadratic part of matrix, and
C LP parametric vectors is not supported.
C***********************************************************************
C
SUBROUTINE REVISE(IRTCOD,DSPACE,REVOPT,REVUNIT)
INTEGER*4 IRTCOD, REVOPT, REVUNIT
REAL*8 DSPACE(*)
SAVE NRFIRST, KRPOINT, NCFIRST, KCPOINT
IF (REVOPT.GE.0) THEN
C Revise the current model.
CALL REVMODEL(IRTCOD,DSPACE,DSPACE,DSPACE,REVOPT,REVUNIT,
+ NRFIRST,KRPOINT,NCFIRST,KCPOINT,
+ NROWORIG,NCOLORIG,NELSORIG)
ELSE
C Print the current model with rows and columns sorted.
CALL PRTMODEL(DSPACE,DSPACE,DSPACE,NRFIRST,DSPACE(KRPOINT),
+ NCFIRST,DSPACE(KCPOINT),NROWORIG,NCOLORIG,
+ NELSORIG)
ENDIF
RETURN
END
C
C***********************************************************************
C This subroutine performs the work of reading in the REVISE MPS file
C and calling the subroutines to perform the appropriate actions.
C***********************************************************************
C
SUBROUTINE REVMODEL(IRTCOD,DSPACE,MSPACE,CSPACE,INEWMODEL,
+ REVUNIT,NRFIRST,KRPOINT,NCFIRST,KCPOINT,
+ NROWORIG,NCOLORIG,NELSORIG)
INTEGER*4 IRTCOD, MSPACE(*), INEWMODEL, REVUNIT, NRFIRST,
+ KRPOINT, NCFIRST, KCPOINT, NROWORIG,
+ NCOLORIG, NELSORIG
REAL*8 DSPACE(*)
CHARACTER*8 CSPACE(*)
C Bring in include files with control variable definitions.
INCLUDE (OSLC)
INCLUDE (OSLI)
INCLUDE (OSLN)
REAL*8 COEFF
CHARACTER*80 CARD
CHARACTER*2 FIELD1
CHARACTER*8 FIELD2, FIELD3, FIELD5
CHARACTER*12 FIELD4, FIELD6
CHARACTER*8 NAME, PENDNAME, NAME1, NAME2, NAME3
C Set up equivalences for fixed format input.
EQUIVALENCE (FIELD1, CARD( 2:3))
EQUIVALENCE (FIELD2, CARD( 5:12), NAME1)
EQUIVALENCE (FIELD3, CARD(15:22), NAME2)
EQUIVALENCE (FIELD4, CARD(25:36))
EQUIVALENCE (FIELD5, CARD(40:47), NAME3)
EQUIVALENCE (FIELD6, CARD(50:61))
CHARACTER*8 BLANK
PARAMETER (BLANK = ' ')
C Set up mnemonics for section being processed.
INTEGER*4 ISECTION, ROWS, COLUMNS, RHS, RANGES, BOUNDS, ENDATA
PARAMETER (ROWS = 1)
PARAMETER (COLUMNS = 2)
PARAMETER (RHS = 3)
PARAMETER (RANGES = 4)
PARAMETER (BOUNDS = 5)
PARAMETER (ENDATA = 6)
C Set up mnemonics for action being performed.
INTEGER*4 IACTION, MODIFY, DELETE, BEFORE, AFTER, INVALID, NONE
PARAMETER (MODIFY = 1)
PARAMETER (DELETE = 2)
PARAMETER (BEFORE = 3)
PARAMETER (AFTER = 4)
PARAMETER (INVALID = 0)
PARAMETER (NONE = 0)
C Set up mnemonics for row type.
INTEGER*4 NEUTRAL, GREATER, LESS, EQUAL
PARAMETER (NEUTRAL = 1)
PARAMETER (GREATER = 2)
PARAMETER (LESS = 3)
PARAMETER (EQUAL = 4)
C Set up mnemonics for bound type.
INTEGER*4 LO, UP, FX, FR, MI, PL
PARAMETER (LO = 1)
PARAMETER (UP = 2)
PARAMETER (FX = 3)
PARAMETER (FR = 4)
PARAMETER (MI = 5)
PARAMETER (PL = 6)
SAVE INIT, KROWBNDS, KRTYPE
DATA INIT / 0 /
PRINT *
PRINT *, '******** ENTERING REVISE SUBROUTINE'
C ------------------------------------------------------------------
C | Allocate space and initialize tables.
C ------------------------------------------------------------------
C Save matrix information.
CALL EKKCGET(IRTCOD,DSPACE,OSLC,OSLCLN)
CALL EKKIGET(IRTCOD,DSPACE,OSLI,OSLILN)
CALL EKKNGET(IRTCOD,DSPACE,OSLN,OSLNLN)
NROW = INUMROWS
NROWMAX = IMAXROWS
NROWORIG = INUMROWS
NCOL = INUMCOLS
NCOLMAX = IMAXCOLS
NCOLORIG = INUMCOLS
NELSORIG = INUMELS
NELS = INUMELS
C Restore storage if required.
IF ((INEWMODEL.GT.0).AND.(INIT.NE.0)) THEN
CALL EKKPOPS(IRTCOD,DSPACE)
INIT = 0
ENDIF
IF (INIT.EQ.0) THEN
C Reserve high space for hash tables and forward/backward pointers:
C
C Krhash - Pointer to row name hash table
C Kchash - Pointer to column name hash table
C Krpoint - Pointer to table that keeps track of order of rows
C Kcpoint - Pointer to table that keeps track of order of columns
C Krowbnds - Pointer to row bounds
C Krtype - Pointer to row types
NWORDS = 2*NCOLMAX + 6.5*NROWMAX + 1
CALL EKKPSHS(IRTCOD,DSPACE)
CALL EKKHIS(IRTCOD,DSPACE,NWORDS,ISTART)
NTOP = ISTART + NWORDS - 1
KRHASH = NTOP - NROWMAX
KCHASH = KRHASH - NCOLMAX
KRPOINT = KCHASH - NROWMAX
KCPOINT = KRPOINT - NCOLMAX
KROWBNDS = KCPOINT - 2 * NROWMAX
KRTYPE = KROWBNDS - 1.5 * NROWMAX + 1
IF (KRTYPE.LT.ISTART) THEN
PRINT *, '******** REVISE: HIGH MEMORY EXHAUSTED'
PRINT *, '******** REVISE: INCREASE SIZE OF DSPACE'
STOP 16
ENDIF
C Hash row and column names.
CALL HASHALL(NROW,NROWMAX,DSPACE(KRHASH),
+ DSPACE(NROWNAMES),IRHASH)
CALL HASHALL(NCOL,NCOLMAX,DSPACE(KCHASH),
+ DSPACE(NCOLNAMES),ICHASH)
C Initialize pointers.
NRFIRST = 1
NCFIRST = 1
CALL INITPOINT(NROW,NROWMAX,DSPACE(KRPOINT))
CALL INITPOINT(NCOL,NCOLMAX,DSPACE(KCPOINT))
INIT = 1
C Initialize counters.
IMODROW = 0
NCARD = 0
NROWDEL = 0
NROWADD = 0
NCOLDEL = 0
NCOLADD = 0
ENDIF
C Allows pointers to be used in manipulating order of names.
NRORIG = NRFIRST
NCORIG = NCFIRST
C Reserve temporary space to build matrix block for new elements.
KNEWROW = NFIRSTFREE
KNEWCOL = KNEWROW + (NROWMAX - NROW)
KNEWELEM = KNEWCOL + (NCOLMAX - NCOL)
IF ((KNEWELEM + IEXTRABLK).GT.NLASTFREE) THEN
PRINT *, '******** REVISE: LOW MEMORY EXHAUSTED'
PRINT *, '******** REVISE: INCREASE SIZE OF DSPACE'
STOP 16
ENDIF
C ------------------------------------------------------------------
C | Start reading revise deck (fixed format assumed).
C ------------------------------------------------------------------
NNEWELS = NONE
NMODELS = NONE
NSRTPTR = NONE
PENDNAME = BLANK
ISECTION = NONE
IACTION = NONE
C Format for card read and field 3 and field 5 read.
800 FORMAT(F12.0)
900 FORMAT(A)
1000 READ(UNIT=REVUNIT,FMT=900,END=7000) CARD
NCARD = NCARD + 1
C Check for comment and NAME cards.
IF (CARD(1:1).EQ.'*') THEN
GOTO 1000
ELSEIF (CARD(1:4).NE.'NAME') THEN
PRINT *, '******** REVISE: NO NAME CARD FOUND'
PRINT *, '******** ', NCARD, CARD
STOP 16
ENDIF
1010 READ(UNIT=REVUNIT,FMT=900,END=7000) CARD
NCARD = NCARD + 1
C Check for comment, SCALE, and MARKER cards. (SCALE is not
C supported; MARKER is not supported in this program.)
IF (CARD(1:1).EQ.'*') THEN
GOTO 1010
ELSEIF (FIELD3.EQ.'''SCALE''') THEN
PRINT *, '******** REVISE: SCALE NOT SUPPORTED; CARD IGNORED'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
ELSEIF (FIELD3.EQ.'''MARKER''') THEN
PRINT *, '******** REVISE: MARKER NOT SUPPORTED; CARD IGNORED'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
ENDIF
C Check if card defines a new action (modify, delete, before,
C or after).
IF ((CARD(1:6).EQ.'MODIFY').OR.(CARD(3:8).EQ.'MODIFY')) THEN
IACTION = MODIFY
NSRTPTR = NONE
GOTO 1010
ELSEIF ((CARD(1:6).EQ.'DELETE').OR.(CARD(3:8).EQ.'DELETE')) THEN
IACTION = DELETE
NSRTPTR = NONE
C Save name if field3 (Name2) is not a comment (and not blank).
IF ((NAME2.EQ.BLANK).OR.(NAME2(1:1).EQ.'$')) THEN
PENDNAME = BLANK
ELSE
PENDNAME = NAME2
GOTO 1030
ENDIF
GOTO 1010
ELSEIF ((CARD(1:6).EQ.'BEFORE').OR.(CARD(3:8).EQ.'BEFORE')) THEN
IACTION = BEFORE
NSRTPTR = NONE
C Save name if field3 (Name2) is not a comment (and not blank).
IF ((NAME2.EQ.BLANK).OR.(NAME2(1:1).EQ.'$')) THEN
PENDNAME = BLANK
ELSE
PENDNAME = NAME2
ENDIF
GOTO 1010
ELSEIF ((CARD(1:5).EQ.'AFTER').OR.(CARD(3:7).EQ.'AFTER')) THEN
IACTION = AFTER
NSRTPTR = NONE
C Save name if field3 (Name2) is not a comment (and not blank).
IF ((NAME2.EQ.BLANK).OR.(NAME2(1:1).EQ.'$')) THEN
PENDNAME = BLANK
ELSE
PENDNAME = NAME2
ENDIF
GOTO 1010
ENDIF
C Check if card defines a new section (ROWS, COLUMNS, RHS, RANGES,
C BOUNDS). (In practice, singular names are used.)
IF (CARD(1:3).EQ.'ROW') THEN
ISECTION = ROWS
IACTION = NONE
GOTO 1010
ELSEIF (CARD(1:6).EQ.'COLUMN') THEN
ISECTION = COLUMNS
IACTION = NONE
GOTO 1010
ELSEIF (CARD(1:3).EQ.'RHS') THEN
ISECTION = RHS
IACTION = NONE
GOTO 1010
ELSEIF (CARD(1:5).EQ.'RANGE') THEN
ISECTION = RANGES
IACTION = NONE
GOTO 1010
ELSEIF (CARD(1:5).EQ.'BOUND') THEN
ISECTION = BOUNDS
IACTION = NONE
GOTO 1010
ELSEIF (CARD(1:6).EQ.'ENDATA') THEN
ISECTION = ENDATA
GOTO 7000
ENDIF
C Card is a data record, so jump according to the section.
1030 GOTO (2000,3000,4000,5000,6000) ISECTION
PRINT *, '******** REVISE: INVALID SECTION'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
C ------------------------------------------------------------------
C | ROWS section
C ------------------------------------------------------------------
C Hash row name.
2000 IF (PENDNAME.EQ.BLANK) THEN
CALL HASHONE(INDEX,NROWMAX,NAME1,DSPACE(KRHASH),
+ DSPACE(NROWNAMES))
NAME = NAME1
ELSE
CALL HASHONE(INDEX,NROWMAX,PENDNAME,DSPACE(KRHASH),
+ DSPACE(NROWNAMES))
NAME = PENDNAME
PENDNAME = BLANK
NSRTPTR = INDEX
ENDIF
C Check to see if row name is objective function. Addition or
C deletion of objective row not supported. Modification of
C objective row is done in COLUMNS section.
IF (COBJECTIVE.EQ.NAME) THEN
PRINT *, '******** REVISE: ACTION NOT SUPPORTED FOR',
+ ' FOR OBJECTIVE ROW'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
ENDIF
C Handle action for ROWS section.
GOTO (2010,2020,2030,2040) IACTION
PRINT *, '******** REVISE: INVALID ACTION'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
C Determine row type.
2010 IRTYPE = NONE
IF (FIELD1(1:1).EQ.'D') THEN
PRINT *, '******** REVISE: D-TYPE ROWS NOT SUPPORTED'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
ELSEIF ((FIELD1.EQ.'N ').OR.(FIELD1.EQ.' N')) THEN
IRTYPE = NEUTRAL
ELSEIF ((FIELD1.EQ.'G ').OR.(FIELD1.EQ.' G')) THEN
IRTYPE = GREATER
ELSEIF ((FIELD1.EQ.'L ').OR.(FIELD1.EQ.' L')) THEN
IRTYPE = LESS
ELSEIF ((FIELD1.EQ.'E ').OR.(FIELD1.EQ.' E')) THEN
IRTYPE = EQUAL
ELSE
PRINT *, '******** REVISE: INVALID ROW TYPE ', FIELD1
PRINT *, '******** ', NCARD, CARD
GOTO 1010
ENDIF
C Modify a row.
CALL MODROW(IRTCOD,INDEX,ISECTION,IRTYPE,DSPACE(KRTYPE),COEFF,
+ DSPACE(KROWBNDS),DSPACE(NROWLOWER),
+ DSPACE(NROWUPPER),IMODROW,NROWMAX,NROWORIG)
IF (IRTCOD.NE.0) THEN
PRINT *, '******** REVISE: ROW MODIFY NOT SUCCESSFUL'
PRINT *, '******** ', NCARD, CARD
ENDIF
GOTO 1010
C Delete a row.
2020 IF (INDEX.EQ.NONE) THEN
PRINT *, '******** REVISE: ROW DELETE FOR NONEXISTENT ROW'
PRINT *, '******** ', NCARD, CARD
ELSE
CALL DELVECT(IRTCOD,INDEX,DSPACE(KRPOINT))
IF (IRTCOD.NE.0) THEN
PRINT *, '******** REVISE: ROW ALREADY DELETED'
PRINT *, '******** ', NCARD, CARD
ELSE
NROWDEL = NROWDEL + 1
C Zero upper and lower bounds.
DSPACE(NROWLOWER + INDEX - 1) = 0
DSPACE(NROWUPPER + INDEX - 1) = 0
ENDIF
ENDIF
GOTO 1010
C Insert a row before an existing row.
2030 CALL NSRTBFR(INDEX,NRFIRST,NRORIG,NSRTPTR,NROW,NROWMAX,
+ DSPACE(KRPOINT),NAME1, DSPACE(KRHASH),
+ DSPACE(NROWNAMES),IRHASH,NROWADD)
GOTO 2010
C Insert a row after an existing row.
2040 CALL NSRTAFT(INDEX,NRFIRST,NSRTPTR,NROW,NROWMAX,
+ DSPACE(KRPOINT),NAME1, DSPACE(KRHASH),
+ DSPACE(NROWNAMES),IRHASH,NROWADD)
GOTO 2010
C ------------------------------------------------------------------
C | COLUMNS section
C ------------------------------------------------------------------
C Hash column name.
3000 IF (PENDNAME.EQ.BLANK) THEN
CALL HASHONE(ICOLNDX,NCOLMAX,NAME1,DSPACE(KCHASH),
+ DSPACE(NCOLNAMES))
NAME = NAME1
ELSE
CALL HASHONE(NSRTPTR,NCOLMAX,PENDNAME,DSPACE(KCHASH),
+ DSPACE(NCOLNAMES))
NAME = PENDNAME
PENDNAME = BLANK
ICOLNDX = NSRTPTR
ENDIF
C Hash row name and read coefficient value.
CALL HASHONE(IROWNDX,NROWMAX,NAME2,DSPACE(KRHASH),
+ DSPACE(NROWNAMES))
READ (FIELD4,800) COEFF
C Handle action for COLUMNS section.
3005 GOTO (3010,3020,3030,3040) IACTION
PRINT *, '******** REVISE: INVALID ACTION'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
C Modify a column.
3010 IF (ICOLNDX.EQ.NONE) THEN
PRINT *, '******** REVISE: COLUMN NAME DOES NOT EXIST'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
ENDIF
IF (IROWNDX.EQ.NONE) THEN
C Check to see if row name is objective function.
IF (COBJECTIVE.EQ.NAME2) THEN
DSPACE(NOBJECTIVE + ICOLNDX - 1) = COEFF
ELSE
PRINT *, '******** REVISE: ROW NAME DOES NOT EXIST'
PRINT *, '******** ', NCARD, CARD
ENDIF
ELSE
CALL MODELEM(IROWNDX,ICOLNDX,COEFF,
+ MSPACE(NBLOCKROW),MSPACE(NBLOCKCOL),
+ DSPACE(NBLOCKELEM),
+ NNEWELS,DSPACE(KNEWROW),
+ DSPACE(KNEWCOL),DSPACE(KNEWELEM))
ENDIF
C Check if a second row/coeffiecient pair is defined.
IF ((NAME3.NE.BLANK).AND.(NAME3(1:1).NE.'$')) THEN
C Hash second row name and read second coefficient value.
CALL HASHONE(IROWNDX,NROWMAX,NAME3,DSPACE(KRHASH),
+ DSPACE(NROWNAMES))
READ (FIELD6,800) COEFF
IF (IROWNDX.EQ.NONE) THEN
C Check to see if row name is objective function.
IF (COBJECTIVE.EQ.NAME3) THEN
DSPACE(NOBJECTIVE + ICOLNDX - 1) = COEFF
ELSE
PRINT *, '******** REVISE: ROW NAME DOES NOT EXIST'
PRINT *, '******** ', NCARD, CARD
ENDIF
ELSE
CALL MODELEM(IROWNDX,ICOLNDX,COEFF,
+ MSPACE(NBLOCKROW),MSPACE(NBLOCKCOL),
+ DSPACE(NBLOCKELEM),
+ NNEWELS,DSPACE(KNEWROW),
+ DSPACE(KNEWCOL),DSPACE(KNEWELEM))
ENDIF
ENDIF
GOTO 1010
C Delete a column.
3020 IF (ICOLNDX.EQ.NONE) THEN
PRINT *, '******** REVISE: COLUMN DELETE FOR NONEXISTENT',
+ ' COLUMN'
PRINT *, '******** ', NCARD, CARD
ELSE
CALL DELVECT(IRTCOD,ICOLNDX,DSPACE(KCPOINT))
IF (IRTCOD.NE.0) THEN
PRINT *, '******** REVISE: COLUMN ALREADY DELETED'
PRINT *, '******** ', NCARD, CARD
ELSE
NCOLDEL = NCOLDEL + 1
C Zero matrix elements and bounds.
CALL DELCOL(ICOLNDX,MSPACE(NBLOCKCOL),MSPACE(NBLOCKROW),
+ DSPACE(NBLOCKELEM),DSPACE(NCOLLOWER),
+ DSPACE(NCOLUPPER))
ENDIF
ENDIF
GOTO 1010
C Insert a column before an existing column.
3030 CALL NSRTBFR(ICOLNDX,NCFIRST,NCORIG,NSRTPTR,NCOL,NCOLMAX,
+ DSPACE(KCPOINT),NAME1, DSPACE(KCHASH),
+ DSPACE(NCOLNAMES),ICHASH,NCOLADD)
GOTO 3010
C Insert a column after an existing column.
3040 CALL NSRTAFT(ICOLNDX,NCFIRST,NSRTPTR,NCOL,NCOLMAX,
+ DSPACE(KCPOINT),NAME1, DSPACE(KCHASH),
+ DSPACE(NCOLNAMES),ICHASH,NCOLADD)
GOTO 3010
C ------------------------------------------------------------------
C | RHS section
C ------------------------------------------------------------------
C Check RHS name.
4000 IF (CRHS.NE.NAME1) THEN
PRINT *, '******** REVISE: RHS NAME ', NAME1, 'DOES NOT',
+ ' MATCH CURRENT RHS ', CRHS
PRINT *, '******** CARD IS IGNORED'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
ENDIF
C Hash row name and read coefficient value.
CALL HASHONE(INDEX,NROWMAX,NAME2,DSPACE(KRHASH),
+ DSPACE(NROWNAMES))
IF (INDEX.EQ.0) THEN
PRINT *, '******** REVISE: ROW NAME NOT FOUND'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
ENDIF
READ (FIELD4,800) COEFF
C Handle action for RHS section.
GOTO (4010) IACTION
PRINT *, '******** REVISE: INVALID ACTION'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
C Modify RHS.
4010 CALL MODROW(IRTCOD,INDEX,ISECTION,ITYPE,DSPACE(KRTYPE),COEFF,
+ DSPACE(KROWBNDS),DSPACE(NROWLOWER),
+ DSPACE(NROWUPPER),IMODROW,NROWMAX,NROWORIG)
IF (IRTCOD.NE.0) THEN
PRINT *, '******** REVISE: RHS MODIFY NOT SUCCESSFUL'
PRINT *, '******** ', NCARD, CARD
ENDIF
C Check if second row/coefficient pair specified.
IF ((NAME3.NE.BLANK).AND.(NAME3(1:1).NE.'$')) THEN
C Hash second row name and read second coefficient value.
CALL HASHONE(INDEX,NROWMAX,NAME3,DSPACE(KRHASH),
+ DSPACE(NROWNAMES))
IF (INDEX.EQ.0) THEN
PRINT *, '******** REVISE: ROW NAME DOES NOT EXIST'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
ENDIF
READ (FIELD6,800) COEFF
CALL MODROW(IRTCOD,INDEX,ISECTION,ITYPE,DSPACE(KRTYPE),COEFF,
+ DSPACE(KROWBNDS),DSPACE(NROWLOWER),
+ DSPACE(NROWUPPER),IMODROW,NROWMAX,NROWORIG)
IF (IRTCOD.NE.0) THEN
PRINT *, '******** REVISE: RHS MODIFY NOT SUCCESSFUL'
PRINT *, '******** ', NCARD, CARD
ENDIF
ENDIF
GOTO 1010
C ------------------------------------------------------------------
C | RANGES section
C ------------------------------------------------------------------
C Check RANGES name.
5000 IF (CRANGE.NE.NAME1) THEN
PRINT *, '******** REVISE: RANGE NAME ', NAME1, 'DOES NOT',
+ ' MATCH CURRENT RANGE ', CRANGE
PRINT *, '******** CARD IS IGNORED'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
ENDIF
C Hash row name and read coefficient value.
CALL HASHONE(INDEX,NROWMAX,NAME2,DSPACE(KRHASH),
+ DSPACE(NROWNAMES))
IF (INDEX.EQ.0) THEN
PRINT *, '******** REVISE: ROW NAME NOT FOUND'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
ENDIF
READ (FIELD4,800) COEFF
C Handle action for RANGES section.
GOTO (5010) IACTION
PRINT *, '******** REVISE: INVALID ACTION'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
C Modify RANGE.
5010 CALL MODROW(IRTCOD,INDEX,ISECTION,ITYPE,DSPACE(KRTYPE),COEFF,
+ DSPACE(KROWBNDS),DSPACE(NROWLOWER),
+ DSPACE(NROWUPPER),IMODROW,NROWMAX,NROWORIG)
IF (IRTCOD.NE.0) THEN
PRINT *, '******** REVISE: RANGE MODIFY NOT SUCCESSFUL'
PRINT *, '******** ', NCARD, CARD
ENDIF
C Check if second row/coefficient pair specified.
IF ((NAME3.NE.BLANK).AND.(NAME3(1:1).NE.'$')) THEN
C Hash second row name and read second coefficient value.
CALL HASHONE(INDEX,NROWMAX,NAME3,DSPACE(KRHASH),
+ DSPACE(NROWNAMES))
IF (INDEX.EQ.0) THEN
PRINT *, '******** REVISE: ROW NAME DOES NOT EXIST'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
ENDIF
READ (FIELD6,800) COEFF
CALL MODROW(IRTCOD,INDEX,ISECTION,ITYPE,DSPACE(KRTYPE),COEFF,
+ DSPACE(KROWBNDS),DSPACE(NROWLOWER),
+ DSPACE(NROWUPPER),IMODROW,NROWMAX,NROWORIG)
IF (IRTCOD.NE.0) THEN
PRINT *, '******** REVISE: RANGE MODIFY NOT SUCCESSFUL'
PRINT *, '******** ', NCARD, CARD
ENDIF
ENDIF
GOTO 1010
C ------------------------------------------------------------------
C | BOUNDS section
C ------------------------------------------------------------------
C Check BOUNDS name.
6000 IF (CBOUND.NE.NAME1) THEN
PRINT *, '******** REVISE: BOUND NAME ', NAME1, 'DOES NOT',
+ ' MATCH CURRENT BOUND ', CBOUND
PRINT *, '******** CARD IS IGNORED'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
ENDIF
C Hash column name and read coefficient value.
CALL HASHONE(INDEX,NCOLMAX,NAME2,DSPACE(KCHASH),
+ DSPACE(NCOLNAMES))
IF (INDEX.EQ.0) THEN
PRINT *, '******** REVISE: COLUMN NAME NOT FOUND'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
ENDIF
READ (FIELD4,800) COEFF
C Handle action for BOUNDS section.
GOTO (6010) IACTION
PRINT *, '******** REVISE: INVALID ACTION'
PRINT *, '******** ', NCARD, CARD
GOTO 1010
C Determine bound type.
6010 ICTYPE = NONE
IF (FIELD1.EQ.'LO') THEN
ICTYPE = LO
ELSEIF (FIELD1.EQ.'UP') THEN
ICTYPE = UP
ELSEIF (FIELD1.EQ.'FX') THEN
ICTYPE = FX
ELSEIF (FIELD1.EQ.'FR') THEN
ICTYPE = FR
ELSEIF (FIELD1.EQ.'MI') THEN
ICTYPE = MI
ELSEIF (FIELD1.EQ.'PL') THEN
ICTYPE = PL
ELSE
PRINT *, '******** REVISE: INVALID BOUND TYPE ', FIELD1
PRINT *, '******** ', NCARD, CARD
ENDIF
C Modify BOUND.
CALL MODBND(ICTYPE,INDEX,COEFF,DSPACE(NCOLLOWER),
+ DSPACE(NCOLUPPER))
GOTO 1010
C ENDATA card found or end of file reached.
7000 IF (ISECTION.NE.ENDATA) THEN
PRINT *, '******** REVISE: EOF REACHED BEFORE ENDATA CARD'
PRINT *, '******** ', NCARD+1
ENDIF
C Convert RHS and RANGE values to upper and lower limits.
CALL MODROW(IRTCOD,INDEX,ISECTION,ITYPE,DSPACE(KRTYPE),COEFF,
+ DSPACE(KROWBNDS),DSPACE(NROWLOWER),
+ DSPACE(NROWUPPER),IMODROW,NROWMAX,NROWORIG)
C Zero matrix elements for all deleted rows.
CALL DELROWS(NELS,DSPACE(KRPOINT),MSPACE(NBLOCKROW),
+ DSPACE(NBLOCKELEM))
C Update the number of rows and columns.
CALL EKKIGET(IRTCOD,DSPACE,OSLI,OSLILN)
INUMCOLS = NCOL
INUMROWS = NROW
CALL EKKISET(IRTCOD,DSPACE,OSLI,OSLILN)
C Add new elements to matrix by adding them to a block.
NNEWCOL = NNEWELS
CALL EKKDSCB(IRTCOD,DSPACE,1,2,
+ DSPACE(KNEWROW),DSPACE(KNEWCOL),DSPACE(KNEWELEM),
+ 0,0,NNEWCOL,NNEWELS)
CALL EKKNWMT(IRTCOD,DSPACE,2)
PRINT *
PRINT *, '******** ', NROWADD, 'ROWS ADDED'
PRINT *, '******** ', NROWDEL, 'ROWS DELETED'
PRINT *, '******** ', NCOLADD, 'COLUMNS ADDED'
PRINT *, '******** ', NCOLDEL, 'COLUMNS DELETED'
PRINT *, '******** ', NNEWELS, 'ELEMENTS ADDED'
PRINT *
PRINT *, '******** LEAVING REVISE SUBROUTINE'
PRINT *
RETURN
END
C
C
SUBROUTINE INITPOINT(NNOW,NMAX,MPOINT)
INTEGER*4 MPOINT(2,*)
C Initialize pointers.
DO I = 1, NNOW
MPOINT(1,I) = I - 1
MPOINT(2,I) = I + 1
ENDDO
C Pointers are circular (first points to last, last points to first).
MPOINT(1,1) = NNOW
MPOINT(2,NNOW) = 1
C Clear pointers at the top for future additions to the table.
DO I = NNOW + 1, NMAX
MPOINT(1,I) = 0
MPOINT(2,I) = 0
ENDDO
RETURN
END
C
C
SUBROUTINE HASHALL(NNOW,NMAX,MLINK,HNAMES,IPUT)
INTEGER*4 MLINK(2,*), MMULT(4)
INTEGER*2 HNAMES(4,*)
DATA MMULT/3,11,53,7/
C Clear hash table.
DO I = 1, NMAX
MLINK(1,I) = 0
MLINK(2,I) = 0
ENDDO
C Do the easy ones first (no "crashes").
DO I = 1, NNOW
INT = 0
DO J = 1, 4
INT = INT + MMULT(J) * HNAMES(J,I)
ENDDO
INT = IABS(INT)
IPOS = MOD(INT,NMAX) + 1
IF (MLINK(1,IPOS).EQ.0) THEN
MLINK(1,IPOS) = I
ENDIF
ENDDO
C Now do the rest (resolve "crashes").
IPUT = 0
DO 1900 I = 1, NNOW
INT = 0
DO J = 1, 4
INT = INT + MMULT(J) * HNAMES(J,I)
ENDDO
INT = IABS(INT)
IPOS = MOD(INT,NMAX) + 1
1050 J1 = MLINK(1,IPOS)
IF (J1.EQ.I) GOTO 1900
DO J = 1, 4
IF (HNAMES(J,J1).NE.HNAMES(J,I)) GOTO 1080
ENDDO
C Duplicate name found.
PRINT 1070, (HNAMES(J,I), J = 1, 4)
1070 FORMAT(' ******* REVISE: DUPLICATE NAME FOUND ', 4A2)
GOTO 1900
1080 K = MLINK(2,IPOS)
IF (K.EQ.0) THEN
1100 IPUT = IPUT + 1
IF (IPUT.GT.NNOW) THEN
PRINT *, '******** REVISE: MEMORY OVERWRITTEN'
STOP 16
ENDIF
IF (MLINK(1,IPUT).NE.0) GOTO 1100
MLINK(2,IPOS) = IPUT
MLINK(1,IPUT) = I
ELSE
IPOS = K
GOTO 1050
ENDIF
1900 CONTINUE
RETURN
END
C
C
SUBROUTINE HASHNADD(IRTCOD,INDEX,NNOW,NMAX,HNAME,MLINK,HNAMES,
+ IPUT)
INTEGER*4 MLINK(2,*), MMULT(4)
INTEGER*2 HNAMES(4,*), HNAME(4)
DATA MMULT/3,11,53,7/
IRTCOD = 0
INDEX = 0
IF (NNOW.GE.NMAX) THEN
PRINT *, '******** REVISE: MEMORY OVERWRITTEN'
STOP 16
ENDIF
NNOW = NNOW + 1
INT = 0
DO J = 1, 4
INT = INT + MMULT(J)*HNAME(J)
ENDDO
INT = IABS(INT)
IPOS = MOD(INT,NMAX) + 1
J1 = MLINK(1,IPOS)
IF (J1.EQ.0) THEN
MLINK(1,IPOS) = NNOW
GOTO 1900
ENDIF
1050 J1 = MLINK(1,IPOS)
IF (J1.EQ.NNOW) GOTO 1900
DO J = 1, 4
IF (HNAMES(J,J1).NE.HNAME(J)) GOTO 1080
ENDDO
C Duplicate name found.
INDEX = J1
NNOW = NNOW - 1
IRTCOD = 1
GOTO 3000
1080 K = MLINK(2,IPOS)
IF (K.EQ.0) THEN
1100 IPUT = IPUT + 1
IF (IPUT.GT.NNOW) THEN
PRINT *, '******** REVISE: MEMORY OVERWRITTEN'
STOP 16
ENDIF
IF (MLINK(1,IPUT).NE.0) GOTO 1100
MLINK (2,IPOS) = IPUT
MLINK(1,IPUT) = NNOW
ELSE
IPOS = K
GOTO 1050
ENDIF
1900 INDEX = NNOW
DO J = 1, 4
HNAMES(J,INDEX) = HNAME(J)
ENDDO
3000 RETURN
END
C
C
SUBROUTINE HASHONE(INDEX,NMAX,HNAME,MLINK,HNAMES)
INTEGER*4 MLINK(2,*), MMULT(4)
INTEGER*2 HNAMES(4,*), HNAME(4)
DATA MMULT /3,11,53,7/
INT = 0
INDEX = 0
DO J = 1, 4
INT = INT + MMULT(J) * HNAME(J)
ENDDO
INT = IABS(INT)
IPOS = MOD(INT,NMAX) + 1
2050 J1 = MLINK(1,IPOS)
DO J = 1, 4
IF (HNAMES(J,J1).NE.HNAME(J)) GOTO 2080
ENDDO
INDEX = J1
GOTO 3000
2080 K = MLINK(2,IPOS)
IF (K.NE.0) THEN
IPOS = K
GOTO 2050
ENDIF
3000 RETURN
END
C
C
SUBROUTINE MODELEM(NROW,NCOL,COEFF,IROWS,ICSTARTS,ELEM,
+ NCNT,IROWSNEW,ICOLSNEW,ELEMNEW)
C***********************************************************************
C Assumes that row and column exist, but element may or may not.
C The routine first determines whether the element exists. If it
C does, then the existing matrix is updated; if it does not exist,
C then the element is added to the new block in index format.
C***********************************************************************
INTEGER*4 IROWS(*), ICSTARTS(*), IROWSNEW(*), ICOLSNEW(*)
REAL*8 COEFF, ELEM(*), ELEMNEW(*)
C Checks if column exists.
J1 = ICSTARTS(NCOL)
J2 = ICSTARTS(NCOL+1) - 1
IF (J2.LT.J1) GOTO 2000
C Checks if row exists and updates element.
DO I = J1, J2
IF (IROWS(I).EQ.NROW) THEN
ELEM(I) = COEFF
GOTO 3000
ENDIF
ENDDO
C Adds new element to block.
2000 NCNT = NCNT + 1
ELEMNEW(NCNT) = COEFF
IROWSNEW(NCNT) = NROW
ICOLSNEW(NCNT) = NCOL
3000 RETURN
END
C
C
SUBROUTINE MODROW(IRTCOD,INDEX,ISECTION,ITYPE,KTYPES,COEFF,
+ ROWBNDS,ROWLOWER,ROWUPPER,NCNT,NMAX,NORIG)
C***********************************************************************
C Keeps track of row, RHS, and RANGE info and updates row bounds
C***********************************************************************
REAL*8 ROWBNDS(2,*), ROWUPPER(*), ROWLOWER(*), COEFF
INTEGER*4 KTYPES(4,*), NCNT, NMAX, NORIG
REAL*8 INF
PARAMETER (INF = 1.0D31)
C ------------------------------------------------------------------
C | Ktypes(1,index) = 0, indicates no row type has been specified
C | Ktypes(1,index) = +/- Ncnt, indicates row type has been set and
C | points to the location where index, RHS, and Range are stored.
C | This scheme prevents doing an exhaustive search of all rows
C | to accomplish updates.
C | Ktypes(2,Ncnt) = the row type of the Ncnt'th row
C | Ktypes(3,Ncnt) = the row index of Ncnt'th row
C | Ktypes(4,Ncnt) = flag to indicate if RHS or Range or both have
C | been changed for Ncnt'th row
C ------------------------------------------------------------------
IRTCOD = 0
C Zero row types pointer table.
IF (NCNT.EQ.0) THEN
DO I = 1, NMAX
KTYPES(1,I) = 0
ENDDO
ENDIF
C Handle action for section.
C Valid sections are: ROWS, RHS, RANGES, ENDATA.
GOTO (1000,999,3000,4000,999,6000) ISECTION
999 IRTCOD = 100
PRINT *, '******** REVISE: INVALID SECTION'
RETURN
C ------------------------------------------------------------------
C | ROWS - Sets row type and initializes row bounds table.
C | Ncnt is used as a flag to see if RHS or RNG has been set.
C | A negative value indicates only the row type has been set.
C | A neutral row implies the bounds of +/- inf so Ncnt is positive.
C ------------------------------------------------------------------
1000 NCNT = NCNT + 1
C Check if row type is neutral.
IF (ITYPE.EQ.1) THEN
KTYPES(1,INDEX) = NCNT
ELSE
KTYPES(1,INDEX) = -NCNT
ENDIF
KTYPES(2,NCNT) = ITYPE
KTYPES(3,NCNT) = INDEX
KTYPES(4,NCNT) = 0
ROWBNDS(1,NCNT) = 0
ROWBNDS(2,NCNT) = 0
RETURN
C ------------------------------------------------------------------
C | RHS - Save RHS value and update flag (absolute value of Ncnt).
C ------------------------------------------------------------------
3000 I = IABS(KTYPES(1,INDEX))
KTYPES(1,INDEX) = I
IF (I.EQ.0) THEN
PRINT *, '******** REVISE: ROW TYPE UNKNOWN ', INDEX
IRTCOD = 101
ENDIF
ROWBNDS(1,I) = COEFF
KTYPES(4,I) = IOR(1,KTYPES(4,I))
RETURN
C ------------------------------------------------------------------
C | RANGES - Save RANGE value and update flag (absolute value of Ncnt)
C ------------------------------------------------------------------
4000 I = IABS(KTYPES(1,INDEX))
KTYPES(1,INDEX) = I
IF (I.EQ.0) THEN
PRINT *, '******** REVISE: ROW TYPE UNKNOWN ', INDEX
IRTCOD = 102
ENDIF
ROWBNDS(2,I) = COEFF
KTYPES(4,I) = IOR(2,KTYPES(4,I))
RETURN
C ------------------------------------------------------------------
C | ENDATA - converts row type, RHS, and Range information into row
C | upper and lower bounds. This can only be done after all the ROW,
C | RHS and Range information has been gathered.
C ------------------------------------------------------------------
6000 DO I = 1, NCNT
ITYPE = KTYPES(2,I)
INDEX = KTYPES(3,I)
ICHG = KTYPES(4,I)
C Set row bound defaults for new rows.
IF (INDEX.GT.NORIG) THEN
C N-type (unconstrained) row
IF (ITYPE.EQ.1) THEN
ROWLOWER(INDEX) = -INF
ROWUPPER(INDEX) = +INF
C G-type row
ELSEIF (ITYPE.EQ.2) THEN
ROWLOWER(INDEX) = 0
ROWUPPER(INDEX) = +INF
C L-type row
ELSEIF (ITYPE.EQ.3) THEN
ROWLOWER(INDEX) = -INF
ROWUPPER(INDEX) = 0
C E-type row
ELSEIF (ITYPE.EQ.4) THEN
ROWLOWER(INDEX) = 0
ROWUPPER(INDEX) = 0
ELSE
PRINT *, '******** REVISE: INVALID ROW TYPE ',
+ KTYPES(3,I), ITYP
IRTCOD = 103
ENDIF
ENDIF
C Now only consider rows whose RHS or Range has been updated.
IF (KTYPES(1,INDEX).GT.0) THEN
C N-type (unconstrained) row
IF (ITYPE.EQ.1) THEN
ROWLOWER(INDEX) = -INF
ROWUPPER(INDEX) = +INF
C G-type row
ELSEIF (ITYPE.EQ.2) THEN
IF (IAND(1,ICHG).NE.0) ROWLOWER(INDEX) = ROWBNDS(1,I)
IF (IAND(2,ICHG).NE.0) ROWUPPER(INDEX) =
+ ROWLOWER(INDEX) + ABS(ROWBNDS(2,I))
C L-type row
ELSEIF (ITYPE.EQ.3) THEN
IF (IAND(1,ICHG).NE.0) ROWUPPER(INDEX) = ROWBNDS(1,I)
IF (IAND(2,ICHG).NE.0) ROWLOWER(INDEX) =
+ ROWUPPER(INDEX) - ABS(ROWBNDS(2,I))
C E-type row
ELSEIF (ITYPE.EQ.4) THEN
C See description of MPS format in the Guide & Reference.
IF (ROWBNDS(2,I).GT.0) THEN
ROWLOWER(INDEX) = ROWBNDS(1,I)
ROWUPPER(INDEX) = ROWBNDS(1,I) + ABS(ROWBNDS(2,I))
ELSE
ROWLOWER(INDEX) = ROWBNDS(1,I) + ABS(ROWBNDS(2,I))
ROWUPPER(INDEX) = ROWBNDS(1,I)
ENDIF
ELSE
PRINT *, '******** REVISE: INVALID ROW TYPE ',
+ KTYPES(3,I),ITYP
IRTCOD = 103
ENDIF
ENDIF
ENDDO
RETURN
END
C
C
SUBROUTINE MODBND(ITYPE,INDEX,VALUE,LOWER,UPPER)
C***********************************************************************
C Sets variable upper and lower bounds.
C***********************************************************************
REAL*8 LOWER(*), UPPER(*), VALUE
INTEGER*4 ITYPE, INDEX
REAL*8 INF
PARAMETER (INF = 1.0D31)
C Handle action for type of bound.
GOTO (1000,2000,3000,4000,5000,6000) ITYPE
PRINT *, '******** REVISE: INVALID BOUND TYPE'
RETURN
C LO - Lower bound. If upper bound not set, then default to infinity.
1000 LOWER(INDEX) = VALUE
IF (UPPER(INDEX).EQ.0) UPPER(INDEX) = +INF
RETURN
C UP - Upper bound. If upper = lower = 0, then lower = -infinity.
2000 UPPER(INDEX) = VALUE
IF ((VALUE.EQ.0).AND.(LOWER(INDEX).EQ.0)) LOWER(INDEX) = -INF
RETURN
C FX - Fixed value.
3000 LOWER(INDEX) = VALUE
UPPER(INDEX) = VALUE
RETURN
C FR - Free (unconstrained) variable.
4000 LOWER(INDEX) = -INF
UPPER(INDEX) = +INF
RETURN
C MI - Minus Infinity. Lower bound = -infinity.
5000 LOWER(INDEX) = -INF
RETURN
C PL - Plus Infinity. Upper bound = +infinity.
6000 UPPER(INDEX) = +INF
RETURN
END
C
C
SUBROUTINE NSRTAFT(INDEX,NFIRST,NAFTER,NNOW,NMAX,PTRS,
+ NAME,KHASH,NAMES,IHASH,NADD)
C***********************************************************************
C Adds a new row/column after an existing row/column.
C***********************************************************************
INTEGER*4 PTRS(2,*)
CHARACTER*8 NAME, NAMES(*)
PARAMETER (PREV = 1)
PARAMETER (NEXT = 2)
NADD = NADD + 1
C Add name to names list and assign an index.
CALL HASHNADD (IRTCOD,INDEX,NNOW,NMAX,NAME,KHASH,NAMES,IHASH)
IF (IRTCOD.NE.0) THEN
C Duplicate name was found.
IF (PTRS(NEXT,INDEX).EQ.0) THEN
C Name was deleted but remains in names list.
PRINT *,'******** REVISE: DELETED NAME RESTORED ',
+ NAME, INDEX
ELSE
C Name exists and is active, so cannot be inserted.
NADD = NADD - 1
PRINT *,'******** REVISE: DUPLICATE NAME IGNORED ',
+ NAME, INDEX
RETURN
ENDIF
ENDIF
C Update pointers.
NLAST = PTRS(PREV,NFIRST)
IF (NAFTER.EQ.0) NAFTER = NLAST
1000 INEXT = PTRS(NEXT,NAFTER)
IPREV = PTRS(PREV,INEXT)
C If name has been deleted, find new reference point.
IF (INEXT.EQ.0) THEN
NAFTER = NAFTER - 1
IF (NBEFORE.EQ.0) NAFTER = NMAX
GOTO 1000
ENDIF
PTRS(NEXT,NAFTER) = INDEX
PTRS(PREV,INEXT) = INDEX
PTRS(NEXT,INDEX) = INEXT
PTRS(PREV,INDEX) = IPREV
NAFTER = INDEX
RETURN
END
C
C
SUBROUTINE NSRTBFR(INDEX,NFIRST,NORIG,NBEFORE,NNOW,NMAX,PTRS,
+ NAME,KHASH,NAMES,IHASH,NADD)
C***********************************************************************
C Adds a new row/column before an existing row/column.
C***********************************************************************
INTEGER*4 PTRS(2,*)
CHARACTER*8 NAME, NAMES(*)
PARAMETER (PREV = 1)
PARAMETER (NEXT = 2)
NADD = NADD + 1
C Add name to names list and assign an index.
CALL HASHNADD (IRTCOD,INDEX,NNOW,NMAX,NAME,KHASH,NAMES,IHASH)
IF (IRTCOD.NE.0) THEN
C Duplicate name was found.
IF (PTRS(NEXT,INDEX).EQ.0) THEN
C Name was deleted but remains in names list.
PRINT *,'******** REVISE: DELETED NAME RESTORED ',
+ NAME, INDEX
ELSE
C Name exists and is active, so cannot be inserted.
NADD = NADD - 1
PRINT *,'******** REVISE: DUPLICATE NAME IGNORED ',
+ NAME, INDEX
RETURN
ENDIF
ENDIF
C Update pointers.
1000 IF (NBEFORE.EQ.0) THEN
NBFR = NORIG
ELSE
NBFR = NBEFORE
ENDIF
IF (NBFR.EQ.NFIRST) NFIRST = INDEX
IPREV = PTRS(PREV,NBFR)
INEXT = PTRS(NEXT,IPREV)
C If name has been deleted, find new reference point.
IF (IPREV.EQ.0) THEN
NBEFORE = NBEFORE + 1
IF (NBEFORE.GT.NMAX) NBEFORE = 0
GOTO 1000
ENDIF
PTRS(PREV,NBFR) = INDEX
PTRS(NEXT,IPREV) = INDEX
PTRS(PREV,INDEX) = IPREV
PTRS(NEXT,INDEX) = INEXT
RETURN
END
C
C
SUBROUTINE DELVECT(IRTCOD,INDEX,PTRS)
C***********************************************************************
C Delete row/col by updating pointers.
C***********************************************************************
INTEGER*4 PTRS(2,*), PREV, NEXT
PARAMETER (PREV = 1)
PARAMETER (NEXT = 2)
C Update pointers.
IPREV = PTRS(PREV,INDEX)
INEXT = PTRS(NEXT,INDEX)
C Check if row/col has already been deleted.
IF (IPREV.EQ.0) THEN
IRTCOD = 1
RETURN
ENDIF
PTRS(PREV,INDEX) = 0
PTRS(NEXT,INDEX) = 0
PTRS(PREV,INEXT) = IPREV
PTRS(NEXT,IPREV) = INEXT
C ------------------------------------------------------------------
C | Blank name.
C | Could blank name, but this is checked for in NSRTBFR & NSRTAFT.
C | If a name is added back in that was previously deleted then
C | a warning message is printed. If you don't care about the message,
C | then blank the name.
C ------------------------------------------------------------------
C Names(index) = ' '
RETURN
END
C
C
SUBROUTINE DELCOL(NCOL,ICSTARTS,IROWS,ELEMS,LOWER,UPPER)
C***********************************************************************
C Zero matrix elements and bounds for a deleted column.
C***********************************************************************
INTEGER*4 ICSTARTS(*), IROWS(*)
REAL*8 ELEMS(*), LOWER(*), UPPER(*)
J1 = ICSTARTS(NCOL)
J2 = ICSTARTS(NCOL + 1) - 1
IF (J2.LT.J1) THEN
PRINT *, '******** REVISE: COLUMN NAME DOES NOT EXIST'
GOTO 2000
ENDIF
DO J = J1, J2
ELEMS(J) = 0
ENDDO
LOWER(NCOL) = 0
UPPER(NCOL) = 0
2000 RETURN
END
C
C
SUBROUTINE DELROWS(NELS,PTRS,IROWS,ELEMS)
C***********************************************************************
C Zero matrix elements for all deleted rows.
C***********************************************************************
INTEGER*4 PTRS(2,*), IROWS(*)
REAL*8 ELEMS(*)
DO I = 1, NELS
NROW = IROWS(I)
C If pointer is zero, row has been marked for deletion.
IF (PTRS(1,NROW).EQ.0) THEN
C Now zero the element.
ELEMS(I) = 0
ENDIF
ENDDO
RETURN
END
C
C
SUBROUTINE PRTMODEL(DSPACE,MSPACE,CSPACE,
+ NRFIRST,KRPOINT,NCFIRST,KCPOINT,
+ NROWORIG,NCOLORIG,NELSORIG)
C***********************************************************************
C Example of how to print sorted matrix after a revise.
C***********************************************************************
REAL*8 DSPACE(*)
INTEGER*4 MSPACE(*), KRPOINT(2,*), KCPOINT(2,*)
CHARACTER*8 CSPACE(*), ROWNAME, COLNAME
INCLUDE (OSLI)
INCLUDE (OSLR)
INCLUDE (OSLN)
CALL EKKNGET (IRTCOD,DSPACE,OSLN,OSLNLN)
CALL EKKIGET (IRTCOD,DSPACE,OSLI,OSLILN)
PRINT *
PRINT *, '******** REVISE: ROWS SECTION:', INUMROWS, ' ROWS'
PRINT *, '******** ---------------------------------------------'
PRINT 3100
PRINT 3200
PRINT *, '******** ---------------------------------------------'
I = NRFIRST
NRCNT = 1
1000 IF (I.GT.NROWORIG) THEN
PRINT 3305,NRCNT,'ADDED',CSPACE(NROWNAMES+I-1),
+ DSPACE(NROWLOWER+I-1),DSPACE(NROWUPPER+I-1)
ELSE
PRINT 3300,NRCNT,I,CSPACE(NROWNAMES+I-1),
+ DSPACE(NROWLOWER+I-1),DSPACE(NROWUPPER+I-1)
ENDIF
I = KRPOINT(2,I)
NRCNT = NRCNT + 1
IF ((NRCNT-1).GT.INUMROWS) THEN
PRINT *, '******** REVISE: POINTERS ARE INVALID'
STOP 16
ENDIF
IF (I.NE.NRFIRST) GOTO 1000
PRINT *
PRINT *, '******** REVISE: COLUMNS SECTION:', INUMCOLS,
+ ' COLUMNS'
PRINT *, '******** ---------------------------------------------'
PRINT 3100
PRINT 3200
PRINT *, '******** ---------------------------------------------'
J = NCFIRST
NCCNT = 1
2000 IF (J.GT.NCOLORIG) THEN
PRINT 3305,NCCNT,'ADDED',CSPACE(NCOLNAMES+J-1),
+ DSPACE(NCOLLOWER+J-1),DSPACE(NCOLUPPER+J-1)
ELSE
PRINT 3300,NCCNT,J,CSPACE(NCOLNAMES+J-1),
+ DSPACE(NCOLLOWER+J-1),DSPACE(NCOLUPPER+J-1)
ENDIF
J = KCPOINT(2,J)
NCCNT = NCCNT + 1
IF ((NCCNT-1).GT.INUMCOLS) THEN
PRINT *, '******** REVISE: POINTERS ARE INVALID'
STOP 16
ENDIF
IF (J.NE.NCFIRST) GOTO 2000
3100 FORMAT ( ' NEW OLD LOWER',
+ ' UPPER')
3200 FORMAT ( ' INDEX INDEX NAME LIMIT',
+ ' LIMIT')
3300 FORMAT(2(I6,2X),A8,2(3X,D12.4))
3305 FORMAT(I6,2X,A6,2X,A8,2(3X,D12.4))
RETURN
END
You can run this program using "Sample Linear Programming Model Data 8".
Sample input files that may be used with the sample programs can be found in Sample MPS Input Files The files that may be used with a particular sample program are indicated after each program. In addition to these files, there may be additional sample input files distributed with the Optimization Library code.
(6) There is one major difference between these sample programs and the code fragments throughout this document. The sample programs all have return code checking after each Optimization Libarary subroutine call. While this is not necessary, it is highly recommended for actual application programs (as opposed to examples), because it can save significant time in debugging.
[ Top of Page | Previous Page | Next Page | Table of Contents ]