# to unbundle, sh this file (in an empty directory) echo read.me 1>&2 sed >read.me <<'//GO.SYSIN DD read.me' 's/^-//' - -This bundle includes 10 files: - 1. read.me - 2. input.f - 3. std2mps.f - 4. common6.for - 5. time7.frs - 6. core.mpc - 7. stoch1.frs - 8. stoch2.frs - 9. stoch3.frs - 10. paper.lis - -If the beginning of this bundle makes no sense to you (i.e., if you -are not using a UNIX(R) system), then use your favorite editor to -remove the - at the start of each line and to split this bundle into -the requisite files, each of which starts with a line of the form -"sed >filename ..." and ends with a line of the form -"//GO.SYSIN DD filename". - -Files 2, 3, and 4 are Fortran source files: input5.f is an input -routine for stochastic linear programming problems, stdtomps.f is a -main program that writes an MPS file for the deterministic equivalent -problem, and common5.for is an include file containing all the common -blocks for the .f files. You'll have to include common6.for by hand -(insert it in place of each "include" statement) if your compiler -won't do this for you. - -Compiling and loading stdtomps.f and input5.f together will give you a -program that expects input files on Fortran units 1, 2, and 3. For the -forestry problems STOCFOR1,2,3, time7.frs should be attached to unit 1, -the EMPS output from expanding core.mpc should be attached to unit 2, -and one of the files stoch1.frs, stoch2.frs, or stoch3.frs should be -attached to unit 3 to produce, respectively, problem STOCFOR1, -STOCFOR2, or STOCFOR3. For reasons explained in std2mps.f, parts of -an LP problem are output on Fortran units 11, 12, 13, 14, and 15; -you must concatenate the resulting files in that order to obtain an -MPS file for the problem. (The present version of std2mps.f prints -numerical values to more decimal places than did the version that -generated the STOCFOR1 and STOCFOR2 in netlib's lp/data .) - -paper.lis is a summary of "A Standard Input Format for Multistage -Stochastic Linear Programs" by J.R. Birge, M.A.H. Dempster, H.I. -Gassmann, E.A. Gunn, A.J. King, and S.W. Wallace [COAL Newsletter -No. 17 (Dec. 1987), pp. 1-19]. - -Complain to dmg if this read.me is unclear. Gus Gassmann provided the -other files in this bundle. He says, - - I cannot give any guarantees that the programs will run - correctly, or that they will run at all. If you experience - any problems, I would appreciate hearing about them, on the - off chance that I might be able to assist: - - Gus Gassmann - School of Business Administration - Dalhousie University - Halifax, N.S. B3H 1Z5 - Canada - - ph. (902)-494-7080 - - email: GASSMANN @ earth.sba.dal.ca //GO.SYSIN DD read.me echo input.f 1>&2 sed >input.f <<'//GO.SYSIN DD input.f' 's/^-//' - SUBROUTINE INPUT ( PROBNM, IOBJ1 ) -C -C This subroutine is the top level input routine. It first reads a -C time file in the format laid out in Birge et al. and described in a bit -C more detail below. It then calls further subroutines to read in the core -C file and the stoch file in one of the four formats described in the paper. -C -C ----------------------------------------------------- -C -C A brief description of the input format follows: -C -C All the information is contained in three input files, which are in -C the order they are accessed: -C -C - the TIME FILE which breaks the rows and columns up into periods -C - the CORE FILE which contains information for a 'base scenario' -C - the STOCH FILE which describes the stochastics of the problem -C -C TIME FILE: -C -C The first column and row of each period appear in the first two name -C fields in standard MPSX format. The period is given a name in the -C third name field. -C -C -C CORE FILE: -C -C Standard MPSX format: The ROWS section lists all the rows for the -C entire problem period by period, starting with period 1 and ending -C with period T. The objective row is considered to be part of period 1. -C -C The COLUMNS section is dealt with in the same way, columns are listed -C period by period. The RHS, BOUNDS and RANGES sections follow as in the -C MPSX standard. -C -C -C STOCH FILE: -C -C Four different ways to specify random elements have been implemented -C to date. They are considered mutually exclusive, although a certain -C amount of mixing may be possible. THIS REQUIRES MORE WORK. -C -C Independent random elements are specified with the keyword INDEP, one -C element per data record. -C -C Blocks of random data which vary jointly but exhibit period-to-period -C independence can be specified with the BLOCKS option. -C -C The SCENario option allows dependence across time periods, but assumes -C that all nodes in the decision tree belonging to the same time period -C have identical problem dimensions and sparsity pattern in the -C constraint matrix. -C -C To facilitate varying problem dimensions, trap states, and the like, -C one may use the TREE option, which requires a separate section for -C each node in the decision tree. To avoid duplication, it is possible -C to copy information from one node to another. -C -C -C Not all of these files have to be present. The following table gives -C all possible combinations: -C -C ----------------------------------------------------------------- -C | Time | Core | Stoch | Remarks | -C | file | file | file | | -C ----------------------------------------------------------------- -C | yes | yes | yes | This is the normal case | -C ----------------------------------------------------------------- -C | yes | yes | no | Problem is deterministic | -C ----------------------------------------------------------------- -C | yes | no | yes | Only legal if TREE option is used | -C ----------------------------------------------------------------- -C | yes | no | no | Not enough information to solve | -C ----------------------------------------------------------------- -C | no | yes | yes | Only legal if TREE option is used | -C ----------------------------------------------------------------- -C | no | yes | no | One-period deterministic problem | -C ----------------------------------------------------------------- -C | no | no | yes | Only legal if TREE option is used | -C ----------------------------------------------------------------- -C | no | no | no | Not enough information to solve | -C ----------------------------------------------------------------- -C -C -C In all cases, the program attempts to minimize storage by reducing -C redundancies as much as possible. -C -C Version 5 is intended to read a full lower triangular constraint -C structure, but will detect staircase structure. This marks a first -C step towards implementing a non-markovian solver as used for -C some investment problems. -C -C ----------------------------------------------------------------- -C -C The internal representation is as follows. -C -C DISCRETE distributions: -C -C For each node N in the decision tree, N = 1,...,NODES, -C -C find in array with offset address -C A matrix coefficients A KELMA (KDATA(N)+LMTX) (+) -C A matrix locations IA KELMA (KDATA(N)+LMTX) -C A matrix column pointers LA KCOLA (KDATA(N)+LMTX) -C cost coefficients COST KCOST (N) -C variable names NAMES KNAMES(N) -C upper bounds XUB KBOUND(N) -C lower bound XLB KBOUND(N) -C right hand sides XI KRHS (N) -C decision variables X KROW (N) -C dual variables YPI KCOL (N) -C -C (+) LMTX = 1 for blocks on the main diagonal -C = 2 for blocks immediately to the LEFT of the main diagonal -C > 2 for blocks further away. -C Staircase problems are indicated by MARKOV = .TRUE. -C -C Problem dimensions are in arrays NROW, NCOL (number of columns -C including slacks) and NELMA. -C -C -C Note that the identity matrix for the slack variables is at present -C *NOT* stored as part of the A matrix and that the cost coefficients -C are separated, even if costs are deterministic. -C -C The tree itself is represented by three pointer arrays IANCTR, IDESC, -C IBROTH, which for each node give, respectively, the ancestor node, -C the immediate successor node, and the next node in the same period. -C If IBROTH > 0, then both nodes have the same ancestor, but it has -C proven advantageous to link nodes in the same time period which have -C different ancestors. This is indicated by a negative value for IBROTH, -C and the next node in this case is given by ABS(IBROTH). -C -C The network standard described in the paper has not been implemented yet. -C -C --------------------------------------------------------------------- -C -C CONTINUOUS distributions: -C -C This section is very experimental and largely untested. Only INDEP -C and BLOCK options are allowed, and they can be mixed freely. -C -C Arrays NAME1, NAME2 and NAME3 describe the row, column and period for -C each stochastic element as an eight-character string. -C -C For each random variable, PAR1 and PAR2 give parameter values and -C MDIST describes the distribution type: -C MDIST = 1 for uniform random variables -C MDIST = 2 for normal random variables -C MDIST = 3 for the TWO-PARAMETER beta distribution -C MDIST = 4 for the Gamma distribution -C MDIST = 5 for lognormal random variables -C -C The linking between stochastic elements and random variables is done -C in the `R'-matrix, which has block-diagonal structure and is stored -C in sparse form in arrays ARMTX, IRMTX and LRMTX. The stochastic -C elements are the ROWS of this matrix, and the random variables are the -C columns. -C -C ------------------------------------------------------------------- -C -C Note well that discrete and continuous distributions are mutually -C exclusive with this data structure and CAN NOT BE MIXED. -C -C ---------------------------------------------------------------------- -C -C Development history: -C -C February 1: First attempts to detect the absence of input files -C in certain situations: For deterministic problems -C there is no need to read a stoch file. One period LP -C problems could be specified by a core file only, and -C the NODES structure really does not require anything -C but a stoch file. -C -C April 14: Restructured the construction of the decision tree for -C INDEP and BLOCKS options to detect coefficients which -C may become known in period t but do in fact belong to a -C later period. This is allowed, since information known at -C the outset is not confined to period 1, either. -C -C -C April 29: First coding of the continuous distributions -C -C --------------------------------------------------------------------- -C -C ***DESCRIPTION OF PARAMETERS*** -C -C PROBNM = 8-CHARACTER STRING VARIABLE CONTAINING THE PROBLEM NAME -C IOBJ1 = ORIGINAL OBJECTIVE ROW (MAY BE ZERO) -C THE OBJECTIVE ROW IS INTERCEPTED AND SWAPPED TO -C POSITION 1 FOR EASIER IDENTIFICATION IN SUBPROBLEMS -C IN PERIODS 2, 3, ..., T. -C -C --------------------------------------------------------------------- -C -C This version dated January 5, 1991. -C -C --------------------------------------------------------------------- -C - include 'common6.for' -C - LOGICAL SIMPLE, ERRCOR, ERRTIM - CHARACTER*8 DNAME(3), DBLANK, DSIMPL, DPER1, - * PROBNM, DTIMEC(MXTPER), DTIMER(MXTPER), DOTS, DISCR - DIMENSION IROTYP(MXBNDS) - EQUIVALENCE (IROTYP,E) -C -C The remaining declarations are used for continuous distributions only -C - CHARACTER*8 NAME1(1000), NAME2(1000), NAME3(1000) - CHARACTER*8 PAR1(1000), PAR2(1000), ARMTX(5000) - INTEGER IRMTX(5000), LRMTX(1000), MDIST(1000) -C - EQUIVALENCE ( NAME1, X( 6501 ) ), ( NAME2, X ( 7501 ) ), - * ( NAME3, X( 8501 ) ), ( PAR1 , X ( 9501 ) ), - * ( PAR2 , X( 10501 ) ), ( ARMTX, X ( 11501 ) ), - * ( IRMTX, X( 16501 ) ), ( LRMTX, X ( 19001 ) ), - * ( MDIST, X( 19501 ) ) -C - DATA DBLANK/' '/, DSIMPL/'SIMPLE '/, DOTS /' ... '/, - * DISCR /'DISCRETE'/, DPER1 /'PERIOD1'/ -C -C -------------------------------------------------------------------------- -C -C Set up some name fields first -C (This should probably be read from a SPECS file.) -C - PROBNM = DBLANK - DXI = DOTS - DBOUND = DOTS - DRANGE = DOTS - ERRCOR = .FALSE. - ERRTIM = .FALSE. - NPER = 0 - SIMPLE = .FALSE. - MARKOV = .TRUE. -C -C Next process the time file to get the partitioning into periods -C - NREC = 0 - IENDAT = 0 - IF (NECHO .GE. 2) WRITE (IOLOG, 1100) -C - 100 CONTINUE - READ (IOTIM, 1000, END=101, ERR=102) - * Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - NREC = NREC + 1 - IF (Q1 .EQ. QAST ) GOTO 100 - IF (IENDAT .EQ. 0) IENDAT = 1 - IF (Q1 .EQ. QT .AND. Q2 .EQ. QI) GOTO 105 - IF (Q1 .EQ. QP .AND. Q2 .EQ. QE) GOTO 110 - IF (Q1 .EQ. QE) GOTO 130 - IF (Q1 .EQ. QBL) GOTO 120 - WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1400) - GOTO 9999 -C -C Missing ENDATA card -C - 101 CONTINUE - IF (IENDAT .EQ. 0) GOTO 102 - IF (IENDAT .EQ. 1) GOTO 9050 - WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1700) - GOTO 140 -C -C ERROR WHILE READING THE TIME FILE. TREAT AS MISSING AND PROCEED -C - 102 CONTINUE - IF (Q1 .EQ. QAST) NREC = NREC + 1 - IF (Q1 .EQ. QAST) GOTO 100 - IF (NREC .GT. 0) WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3970) - DTIMEC(1) = DOTS - DTIMER(1) = DOTS - DTIME(1) = DPER1 - ERRTIM = .TRUE. - PROBNM = DOTS - NPER = 1 - GOTO 140 -C -C WE HAVE FOUND A TIME FILE AND A NAME FOR OUR PROBLEM -C - 105 CONTINUE - PROBNM = DNAME(2) - IF (NECHO .GE. 2) WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2) - GOTO 100 - 110 CONTINUE - IENDAT = 2 - IF (DNAME(2) .EQ. DSIMPL) SIMPLE = .TRUE. - IF (NECHO .GE. 5) WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2) - GOTO 100 - 120 CONTINUE - NPER = NPER + 1 - IF (NPER .GT. MXTPER) GOTO 9030 - IF (NECHO .GE. 5) - * WRITE (IOLOG, 2500) NREC,DNAME(3),DNAME(2),DNAME(1) - DTIMEC(NPER) = DNAME(1) - DTIMER(NPER) = DNAME(2) - DTIME(NPER) = DNAME(3) - GOTO 100 -C -C End of TIME file -C - 130 CONTINUE - IF (NECHO .GE. 2) WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2) - 140 CONTINUE - IF (SIMPLE) GOTO 9100 - NREC = 0 - NPSEEN = 0 - IF (NECHO .GE. 2) WRITE (IOLOG, 1800) -C -C ***** READ THE CORE FILE ***** -C - 150 CONTINUE - READ (IOCOR, 1000, END=152, ERR=151) - * Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - NREC = NREC + 1 - IF (Q1 .EQ. QN .AND. Q2. EQ. QA) GOTO 155 - IF (Q1 .EQ. QAST) GOTO 150 - WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 2300) - GOTO 9999 -C -C Error during read or missing CORE file. Keep going. -C - 151 CONTINUE - IF (Q1 .NE. QAST) GOTO 152 - NREC = NREC + 1 - GOTO 150 - 152 CONTINUE - IF (NREC .GT. 0) WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3980) - ERRCOR = .TRUE. - IF (PROBNM .EQ. DBLANK) PROBNM = DOTS - GOTO 450 -C -C WE HAVE FOUND THE PROBLEM NAME. DOES IT MATCH? -C - 155 CONTINUE - IF (PROBNM .EQ. DOTS) PROBNM = DNAME(2) - IF (DNAME(2) .NE. PROBNM) GOTO 9150 - IF (NECHO .GE. 2) WRITE (IOLOG, 1200) NREC,Q1,Q2,Q3,Q4, - * DNAME(1),DNAME(2) - CALL INCORE ( DTIMEC, DTIMER, IROTYP, PROBNM, - * IOBJ1, NPSEEN, IERR, NREC) - -C ***** PROCESS THE STOCH-FILE ***** -C - 450 CONTINUE - JNODES = 1 - NODES = NPER - IIPER = 0 - IPER0 = 0 - PROB(1) = 1.0 - NREC = 0 - IF (NECHO .GE. 2) WRITE (IOLOG, 1900) - 451 CONTINUE - READ (IOSTO, 1000, ERR=454, END=455) - * Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - NREC = NREC + 1 - IF (Q1 .EQ. QAST) GOTO 451 - IF (Q1 .EQ. QS .AND. Q2 .EQ. QT) GOTO 452 - IF (Q1 .EQ. QI .AND. Q2 .EQ. QN) GOTO 460 - IF (Q1 .EQ. QB .AND. Q2 .EQ. QL) GOTO 470 - IF (Q1 .EQ. QS .AND. Q2 .EQ. QC) GOTO 480 - IF (Q1 .EQ. QN .AND. Q2 .EQ. QO) GOTO 490 - WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1600) - GOTO 9999 -C - 452 CONTINUE - IF (PROBNM .EQ. DOTS) PROBNM = DNAME(2) - IF (DNAME(2) .NE. PROBNM) GOTO 9150 - IF (NECHO .GE. 2) WRITE (IOLOG, 1200) NREC,Q1,Q2,Q3,Q4, - * DNAME(1),DNAME(2) - GOTO 451 -C -C Error during read or missing STOCH file - Keep going -C (This means the problem is assumed to be deterministic) -C - 454 CONTINUE - IF (Q1 .NE. QAST) GOTO 455 - NREC = NREC + 1 - GOTO 451 - 455 CONTINUE - IF (NREC .GT. 0) WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3990) - IF (ERRCOR .OR. PROBNM .EQ. DOTS) GOTO 9995 - IF (NPER .EQ. 0) NPER = 1 - NODES = NPER - GOTO 955 -C -C THE RANDOM ELEMENTS ARE INDEPENDENT -C - 460 CONTINUE - IF (ERRCOR .OR. ERRTIM) GOTO 9995 - IF (NPSEEN .NE. NPER ) WRITE (IOLOG, 2000) - NPER = NPSEEN - IF (NECHO .GE. 5 ) WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2) - IF (DNAME(2) .NE. DISCR ) GOTO 500 - L = 1 - CALL INELEM(IROTYP,IIPER,IPER0,JNODES,NREC) - GOTO 900 -C -C HERE WE HAVE BLOCK STRUCTURE AND PERIOD-TO-PERIOD INDEPENDENCE -C - 470 CONTINUE - IF (ERRCOR .OR. ERRTIM) GOTO 9995 - IF (NPSEEN .NE. NPER ) WRITE (IOLOG, 2000) - NPER = NPSEEN - IF (NECHO .GE. 5 ) WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2) - IF (DNAME(2) .NE. DISCR ) GOTO 500 - L = 2 - CALL INBLOK(IROTYP,IIPER,IPER0,JNODES,NREC) - GOTO 900 -C -C TIME DEPENDENCE: SCENARIOS -C - 480 CONTINUE - IF (ERRCOR .OR. ERRTIM) GOTO 9995 - IF (NPSEEN .NE. NPER ) WRITE (IOLOG, 2000) - NPER = NPSEEN - IF (NECHO .GE. 5 ) WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2) - IF (DNAME(2) .NE. DISCR ) GOTO 500 - L = 3 - CALL INSCEN(IROTYP,IIPER,IPER0,JNODES,NREC) - GOTO 900 -C -C TREE OPTION: READ EXPLICIT INFO FOR EACH NODE -C - 490 CONTINUE - IF (DNAME(2) .NE. DISCR) GOTO 500 - NPER = NPSEEN - L = 4 - MULTI = 1 - IF (ERRCOR .OR. NPER .EQ. 0) IERR = 1 - IF (NECHO .GE. 5 ) WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2) - CALL INTREE(IPER0, IERR, NREC) - NP = 0 - DO 491 I=1,MXTPER - IF (IRNGE0(I) .EQ. 0) GOTO 492 - NP = NP + 1 - DO 491 J=1,NP - STOCHA(NP,J) = .TRUE. - 491 CONTINUE - NP = MXTPER - 492 CONTINUE - IF (NP .EQ. NPER) GOTO 900 - WRITE (IOLOG, 2600) NP - NPER = NP - GOTO 900 -C -C The header card is not 'DISCRETE'. Check for continuous distribution -C - 500 CONTINUE - L = 5 - IF (NECHO .GE. 2) - * WRITE (IOLOG, 2700) NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2) - CALL INCONT(Q1, Q2, Q3, Q4, DNAME, ATEMP1, ATEMP2, - * NAME1, NAME2, NAME3, PAR1, PAR2, MDIST, - * ARMTX, IRMTX, LRMTX, NREC) - GOTO 900 -C -C END OF INPUT -C - 900 CONTINUE - IF (NECHO .EQ. 1) WRITE (IOLOG, 2800) PROBNM, NPER - WRITE (IOLOG, 2100) - IF (L .EQ. 4) GOTO 925 - DO 901 I=1,NPER - IRNGE0(I) = I - 901 CONTINUE -C -C NOW LINK TOGETHER ALL NODES OF THE SAME PERIOD -C - 925 CONTINUE - IF (IPER0 .EQ. 0) GOTO 951 - DO 950 IP=IPER0,NPER - ISC1 = IRNGE0(IP) - 930 CONTINUE - IF (IBROTH(ISC1) .EQ. 0) GOTO 940 - ISC1 = IBROTH(ISC1) - GOTO 930 - 940 CONTINUE - IAN = IANCTR(ISC1) - IF (IAN .EQ. 0) GOTO 950 - 942 CONTINUE - IBRO = IABS(IBROTH(IAN)) - IF (IBRO .EQ. 0) GOTO 950 - ISC2 = IDESC(IBRO) - IF (ISC2 .EQ. 0) GOTO 945 - IBROTH(ISC1) = -ISC2 - ISC1 = ISC2 - GOTO 930 - 945 CONTINUE - IAN = IBRO - GOTO 942 - 950 CONTINUE - 951 CONTINUE - IF (L .NE. 3) GOTO 955 -C -C FOR SCENARIOS WE HAVE TO FIND CONDITIONAL PROBABILITIES -C - DO 954 IP=2,NPER - ISC1 = IRNGE0(NPER+2-IP) - 952 CONTINUE - PROB(ISC1) = PROB(ISC1)/PROB(IANCTR(ISC1)) - ISC1 = IABS(IBROTH(ISC1)) - IF (ISC1 .GT. 0) GOTO 952 - 954 CONTINUE -C - 955 CONTINUE - DO 960 IP=1,NPER - NROWS = NROW(IP) - NSCOL = NCOL(IP) - NROWS - RELEM = NELMA(KDATA(IP)+1) - RDENS = RELEM / (NROWS * NSCOL) - IF (NECHO .GE. 2) - * WRITE (IOLOG, 1300) IP, NROWS, NSCOL, RDENS - 960 CONTINUE -C - IF (MULTI .EQ. 3) MULTI = 0 - NEXT = NODES + 1 - NROWS = NROW(NODES) - NCOLS = NCOL(NODES) - MAXCOL = KCOL(NODES) + NCOLS + 1 - MAXROW = KROW(NODES) + NROWS - MAXRHS = LASTR - NCMAX = MIN( MXCUTS, MXCOLS-MAXCOL, MXROWS-MAXROW ) - IF (MAXCOL .GE. MXCOLS .OR. MAXROW .GE. MXROWS) GOTO 9200 - IF (NECHO .GE. 1) WRITE (IOLOG, 1500) NCMAX - KCOL(NEXT) = MAXCOL - KROW(NEXT) = MAXROW - KRHS(NEXT) = LASTR - KCOST(NEXT) = LASTC - KBOUND(NEXT) = LASTBD - KNAMES(NEXT) = LASTNM - KSCALE(NEXT) = LASTSC -C -C Here we provide two dummy bounds for cuts. -C - XLB(LASTBD+1) = 0.D0 - XUB(LASTBD+1) = PLINF - XLB(LASTBD+2) = 0.D0 - XUB(LASTBD+2) = 0.D0 - LASTBD = LASTBD + 2 -C -C COUNT DESCENDANTS FOR EACH PROBLEM AND INITIAL POINTERS -C - DO 999 I=1,NODES - N0 = 0 - I0 = IDESC(I) - NUDATA(I) = .FALSE. - NUDUAL(I) = .FALSE. - INHBT(I) = .FALSE. - NTH(I) = QO - LOOKAT(I) = QO - 995 CONTINUE - IF (I0 .LE. 0) GOTO 998 - I0 = IBROTH(I0) - N0 = N0 + 1 - GOTO 995 - 998 CONTINUE - NDESC(I) = N0 - 999 CONTINUE - RETURN -C -C COME HERE IF ANYTHING WENT WRONG -C - 9030 CONTINUE - WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3030) MXTPER - GOTO 9999 -C - 9050 CONTINUE - WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3050) - GOTO 9999 -C - 9100 CONTINUE - WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3100) - GOTO 9999 -C - 9150 CONTINUE - WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3150) - GOTO 9999 -C - 9200 CONTINUE - WRITE (IOLOG, 1200) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3200) - GOTO 9999 -C - 9995 CONTINUE - WRITE (IOLOG, 3995) - 9999 CONTINUE - CALL STOPIT -C - 1000 FORMAT(4A1,A8,2X,A8,2X,F12.4,3X,A8,2X,F12.4) - 1100 FORMAT(/,' Process TIME file:') - 1200 FORMAT(I8,4X,4A1,A8,2X,A8,2X,F12.4,3X,A8,2X,F12.4) - 1300 FORMAT(' Period',I3,' has',I4,' rows and',I4,' columns.', - * ' Density of constraint matrix:',F6.3) - 1400 FORMAT(' XXX - FATAL - Illegal record in TIME file') - 1500 FORMAT(' There is space for at most',I5,' cuts') - 1600 FORMAT(' XXX - FATAL - Illegal record in STOCH file') - 1700 FORMAT(' XXX - WARNING - Missing ENDATA card') - 1800 FORMAT(/,' Process CORE file:') - 1900 FORMAT(/,' Process STOCH file:') - 2000 FORMAT(' XXX - WARNING - Number of periods in CORE file does not', - * ' match information in TIME file') - 2100 FORMAT(' ') - 2300 FORMAT(' XXX - FATAL - Illegal record in CORE file') - 2500 FORMAT(I8,4X,' Period ',A8,' - first row ',A8,', first column ', - * A8) - 2600 FORMAT(' *** Number of periods has been adjusted to',I3,' ***') - 2700 FORMAT(I8,4X,4A1,A8,2X,A8) - 2800 FORMAT(' Solving problem ',A8,' -- ',I2,' periods') - 3030 FORMAT(' XXX - FATAL - Too many periods specified: Use at most', - * I4) - 3050 FORMAT(' XXX - FATAL - Detected EOF while reading TIME_FILE') - 3100 FORMAT(' XXX - FATAL - Simple recourse has not been', - * ' implemented') - 3150 FORMAT(' XXX - FATAL - Name does not match info in TIME file') - 3200 FORMAT(' XXX - FATAL - Global problem dimensions exceed', - * ' capacity') - 3970 FORMAT(' XXX - WARNING - Error during READ or non-existent TIME', - * ' file') - 3980 FORMAT(' XXX - WARNING - Error during READ or non-existent CORE', - * ' file') - 3990 FORMAT(' XXX - WARNING - Error during READ or non-existent STOCH', - * ' file') - 3995 FORMAT(' XXX - FATAL - Not enough information to solve the', - * ' problem') - END -C -C ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -C -C -C ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -C - SUBROUTINE INBLOK (IROTYP, IIPER, IPER0, JNODES, NREC) -C -C This subroutine reads BLOCK structure, both for staircase and -C full block-triangular problems. -C -C ----------------------------------- -C | Version of June 18, 1989 | -C ----------------------------------- -C - include 'common6.for' -C - CHARACTER*8 DNAME(3), DBLANK, DROW, DCOL, DBLOCK - DIMENSION IROTYP(MXBNDS), LOC1(MXNODE), LOC2(MXNODE) -C - EQUIVALENCE (LOC1,X), (LOC2,IE) -C - DATA DBLANK/' '/ -C - DROW = DBLANK - DCOL = DBLANK - NREALS = 1 - JNODES = 1 - NODES = NPER - IIPER = 0 - IPER0 = 0 - PROB(1) = 1.0 -C -C START WITH SOME BOOK-KEEPING AND FIX THE PERIOD -C - 100 CONTINUE - READ (IOSTO, 1000, ERR=105, END=910) - * Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - NREC = NREC + 1 - IF (Q1 .EQ. QAST) GOTO 100 - IF (Q1 .EQ. QE ) GOTO 900 - IF (Q1 .EQ. QBL ) GOTO 110 - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1600) - GOTO 9999 -C - 105 CONTINUE - IF (Q1 .NE. QAST) GOTO 9990 - NREC = NREC + 1 - GOTO 100 -C - 110 CONTINUE - IF (Q2 .EQ. QB .AND. Q3 .EQ. QL) GOTO 120 - IF (NECHO .GE. 5) WRITE (IOLOG, 1100) NREC,Q1,Q2,Q3,Q4, - * DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - DCOL = DNAME(1) - DROW = DNAME(2) - GOTO 300 -C - 120 CONTINUE - IF (DNAME(1) .EQ. DBLOCK) GOTO 160 -C -C Another BL card has been detected. Find period of this block -C - DBLOCK = DNAME(1) - DO 130 IP=1,NPER - IF (DNAME(2) .EQ. DTIME(IP)) GOTO 140 - 130 CONTINUE - WRITE (IOLOG, 1100) NREC,Q1,Q2,Q3,Q4,DNAME(1), - * DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 2000) - GOTO 9999 -C -C First realization of a new block -C - 140 CONTINUE - IF (IP .LT. IIPER) GOTO 9850 - PROB1 = ATEMP1 - JNODES = JNODES * NREALS - NREALS = 1 - IIPER = IP - NCURR = IRNGE0(IP) - IF (NECHO .LT. 2) GOTO 150 - IF (NECHO .LT. 5) WRITE (IOLOG, 1700) - * NREC, NREALS, DBLOCK - IF (NECHO .GE. 5) WRITE (IOLOG, 1300) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),DNAME(3),NREALS - 150 CONTINUE - PROB(NCURR) = PROB(NCURR) * ATEMP1 - NCURR = IABS(IBROTH(NCURR)) - IF (NCURR .GT. 0) GOTO 150 - GOTO 100 -C -C ANOTHER REALIZATION OF A BLOCK DETECTED BEFORE -C - 160 CONTINUE - NREALS = NREALS + 1 - NREF = IRNGE0(IP) - NMTX = IP - IF (MARKOV .AND. IP .GT. 2) NMTX = 2 - IF (NECHO .LT. 2) GOTO 165 - IF (NECHO .LT. 5) WRITE (IOLOG, 1800) NREC,NREALS - IF (NECHO .GE. 5) WRITE (IOLOG, 1300) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),DNAME(3),NREALS -C -C Duplicate all the nodes existing in the current period -C - 165 CONTINUE - IF (NODES + JNODES .GT. MXNODE) GOTO 9100 - DO 220 I=1,JNODES - REFPRB = PROB(NREF) - NCURR = NODES + I - PROB(NCURR) = REFPRB * ATEMP1 / PROB1 - KROW(NCURR) = KROW(NCURR-1) + NROW(NCURR-1) - KCOL(NCURR) = KCOL(NCURR-1) + NCOL(NCURR-1) + 1 - KNAMES(NCURR) = KNAMES(NREF) - KBOUND(NCURR) = KBOUND(NREF) - KCOST(NCURR) = KCOST(NREF) - KDATA(NCURR) = LASTD - KRHS(NCURR) = KRHS(NREF) - NROW(NCURR) = NROW(IP) - NCOL(NCURR) = NCOL(IP) - NTH(NCURR) = NTH(IP) - NCUT(NCURR) = NCUT(IP) -C - IF (NREALS .LE. 2) GOTO 180 - DO 170 J=1,NREALS-2 - NREF = IABS(IBROTH(NREF)) - 170 CONTINUE - 180 CONTINUE - IANCTR(NCURR) = IANCTR(NREF) - IBROTH(NCURR) = IBROTH(NREF) - IBROTH(NREF) = NCURR - NREF = IABS(IBROTH(NCURR)) -C - NROWS = NROW(NCURR) - NCOLS = NCOL(NCURR) - ICOL = KCOL(NCURR) - IROW = KROW(NCURR) - LASTD = LASTD + NMTX - KDATC = KDATA(NCURR) - KDATI = KDATA(IP) - DO 190 IMTX=1,NMTX - KCOLA(KDATC+IMTX) = KCOLA(KDATI+IMTX) - KELMA(KDATC+IMTX) = KELMA(KDATI+IMTX) - NELMA(KDATC+IMTX) = NELMA(KDATI+IMTX) - 190 CONTINUE - DO 200 J=1,NROWS - JH(IROW+J) = ICOL + J - KINBAS(ICOL+J) = IROW + J - 200 CONTINUE - DO 210 J=NROWS+1,NCOLS+1 - KINBAS(ICOL+J) = 0 - 210 CONTINUE - 220 CONTINUE - NODES = NODES + JNODES - IRNGE2(IP) = NODES -C -C Now duplicate the rest of the tree as well -C - DO 290 JP=IP+1,NPER - NREF = IRNGE0(JP) - NMTX = JP - IF (MARKOV .AND. JP .GT. 2) NMTX = 2 - IF (NODES + JNODES .GT. MXNODE) GOTO 9100 - DO 280 I=1,JNODES - NCURR = NODES + I - PROB(NCURR) = 1.0 - KROW(NCURR) = KROW(NCURR-1) + NROW(NCURR-1) - KCOL(NCURR) = KCOL(NCURR-1) + NCOL(NCURR-1) + 1 - KNAMES(NCURR) = KNAMES(NREF) - KBOUND(NCURR) = KBOUND(NREF) - KCOST(NCURR) = KCOST(NREF) - KDATA(NCURR) = LASTD - KRHS(NCURR) = KRHS(NREF) - NROW(NCURR) = NROW(JP) - NCOL(NCURR) = NCOL(JP) - NTH(NCURR) = NTH(JP) - NCUT(NCURR) = NCUT(JP) -C - IF (NREALS .LE. 2) GOTO 240 - DO 230 J=1,NREALS-2 - NREF = IABS(IBROTH(NREF)) - 230 CONTINUE - 240 CONTINUE - NPREV = NCURR - JNODES - IANCTR(NCURR) = NPREV - IDESC(NPREV) = NCURR - IBROTH(NCURR) = IBROTH(NREF) - IBROTH(NREF) = -NCURR - NREF = IABS(IBROTH(NCURR)) -C - NROWS = NROW(NCURR) - NCOLS = NCOL(NCURR) - ICOL = KCOL(NCURR) - IROW = KROW(NCURR) - LASTD = LASTD + NMTX - KDATC = KDATA(NCURR) - KDATI = KDATA(JP) - DO 250 IMTX=1,NMTX - KCOLA(KDATC+IMTX) = KCOLA(KDATI+IMTX) - KELMA(KDATC+IMTX) = KELMA(KDATI+IMTX) - NELMA(KDATC+IMTX) = NELMA(KDATI+IMTX) - 250 CONTINUE - DO 260 J=1,NROWS - JH(IROW+J) = ICOL + J - KINBAS(ICOL+J) = IROW + J - 260 CONTINUE - DO 270 J=NROWS+1,NCOLS+1 - KINBAS(ICOL+J) = 0 - 270 CONTINUE - 280 CONTINUE - NODES = NODES + JNODES - IRNGE2(JP) = NODES - 290 CONTINUE - GOTO 100 -C -C DETERMINE THE TYPE AND PERIOD OF THE RANDOM ELEMENT BY LOOKING AT -C THE ROW NAME - THIS WORKS UNLESS WE HAVE A RANDOM COST COEFFICIENT -C - 300 CONTINUE - IF (DROW .EQ. NAMES(1)) GOTO 400 - DO 310 LP=IP,NPER - DO 310 LROW=1,NCOL(LP) - IF (DROW .EQ. NAMES(KNAMES(LP)+LROW)) GOTO 330 - 310 CONTINUE -C - DO 320 I=1,NROW(1) - IF (DROW .EQ. NAMES(I) .AND. IROTYP(I) .EQ. 2) - * GOTO 890 - 320 CONTINUE - WRITE (IOLOG, 1100) NREC,Q1,Q2,Q3,Q4,DNAME(1), - * DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1900) - GOTO 9999 -C - 330 CONTINUE - IF (DCOL .EQ. DBOUND ) GOTO 600 - IF (DCOL .EQ. DRANGE ) GOTO 610 - IF (DCOL .EQ. DXI ) GOTO 500 - DO 350 JMTX=1,LP - IF (MARKOV .AND. JMTX .GE. 3) GOTO 360 - JP = LP + 1 - JMTX - JNAME = KNAMES(JP) + NROW(JP) - DO 340 LCOL=1,NCOL(JP)-NROW(JP) - IF (DCOL .EQ. NAMES(JNAME+LCOL)) GOTO 700 - 340 CONTINUE - 350 CONTINUE -C - 360 CONTINUE - LROWS = NROW(1) - DO 370 I=1,LROWS - IF (DROW .EQ. NAMES(I) .AND. IROTYP(I) .EQ. 2) - * GOTO 890 - 370 CONTINUE - GOTO 9875 -C -C HERE WE HAVE A RANDOM COST COEFFICIENT. COPY INFO IF NECESSARY -C FIRST WE HAVE TO DETERMINE THE PERIOD -C - 400 CONTINUE - DO 410 LP=IP,NPER - JNAME = KNAMES(LP) + NROW(LP) - DO 410 LPOSC=1,NCOL(LP)-NROW(LP) - IF (DCOL .EQ. NAMES(JNAME+LPOSC)) GOTO 420 - 410 CONTINUE - WRITE (IOLOG, 1100) NREC,Q1,Q2,Q3,Q4,DNAME(1), - * DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 2100) DCOL - GOTO 9999 -C - 420 CONTINUE - IF (NREALS .GT. 1) GOTO 440 - NREF = IRNGE0(LP) - DO 430 I=1,JNODES - COST(KCOST(NREF)+LPOSC) = ATEMP1 - NREF = IABS(IBROTH(NREF)) - 430 CONTINUE - GOTO 890 -C - 440 CONTINUE - NODE0 = NODES - JNODES*(NPER+1-LP) - IF (KCOST(NODE0+1) .NE. KCOST(IRNGE0(LP))) GOTO 480 -C -C Copy the cost coefficients -C - NREF = IRNGE0(LP) - NCPD = 0 - DO 470 I=1,JNODES - DO 450 JC=1,NCPD - IF (KCOST(NREF) .NE. LOC1(JC)) GOTO 450 - KCOST(NODE0+I) = LOC2(JC) - GOTO 465 - 450 CONTINUE - NCPD = NCPD + 1 - LOC1(NCPD) = KCOST(NREF) - LOC2(NCPD) = LASTC - KCOST(NODE0+I) = LASTC - KCREF = KCOST(NREF) - NCOEFF = NCOL(LP)-NROW(LP) - IF (LASTC + NCOEFF .GT. MXCOST) GOTO 9200 - DO 460 JCOEF=1,NCOEFF - COST(LASTC+JCOEF) = COST(KCREF+JCOEF) - 460 CONTINUE - COST(LASTC+LPOSC) = ATEMP1 - LASTC = LASTC + NCOEFF - 465 CONTINUE - NREF = IABS(IBROTH(NREF)) - IF (NREF .LT. NODE0) GOTO 465 - NREF = IABS(IBROTH(NREF)) - 470 CONTINUE - GOTO 890 -C - 480 CONTINUE - NREF = IRNGE0(LP) - DO 490 I=1,JNODES - COST(KCOST(NODE0+I)+LPOSC) = ATEMP1 - 490 CONTINUE - GOTO 890 -C -C HERE WE HAVE A RANDOM RHS -C - 500 CONTINUE - IF (NREALS .GT. 1) GOTO 540 - NREF = IRNGE0(LP) - DO 530 I=1,JNODES - XI(KRHS(NREF)+LROW) = ATEMP1 - NREF = IABS(IBROTH(NREF)) - 530 CONTINUE - GOTO 890 -C - 540 CONTINUE - NODE0 = NODES - JNODES*(NPER+1-LP) - IF (KRHS(NODE0+1) .NE. KRHS(IRNGE0(LP))) GOTO 580 -C -C Copy the coefficients of the rhs. -C - NREF = IRNGE0(LP) - NCPD = 0 - DO 570 I=1,JNODES - DO 550 JC=1,NCPD - IF (KRHS(NREF) .NE. LOC1(JC)) GOTO 550 - KRHS(NODE0+I) = LOC2(JC) - GOTO 565 - 550 CONTINUE - NCPD = NCPD + 1 - LOC1(NCPD) = KRHS(NREF) - LOC2(NCPD) = LASTR - KRHS(NODE0+I) = LASTR - KCREF = KRHS(NREF) - IF (LASTR + NROW(LP) .GT. MXDRHS) GOTO 9300 - DO 560 JCOEF=1,NROW(LP) - XI(LASTR+JCOEF) = XI(KCREF+JCOEF) - 560 CONTINUE - XI(LASTR+LROW) = ATEMP1 - LASTR = LASTR + NROW(LP) - 565 CONTINUE - NREF = IABS(IBROTH(NREF)) - IF (NREF .LT. NODE0) GOTO 565 - NREF = IABS(IBROTH(NREF)) - 570 CONTINUE - GOTO 890 -C - 580 CONTINUE - NREF = IRNGE0(LP) - DO 590 I=1,JNODES - XI(KRHS(NODE0+I)+LROW) = ATEMP1 - 590 CONTINUE - GOTO 890 -C -C RANDOM BOUND ON A DECISION VARIABLE -C - 600 CONTINUE - JL = 0 - JU = 0 - IF (LROW .LE. NROW(IP)) GOTO 9060 - IF (Q3 .EQ. QP .OR. Q3 .EQ. QX) JU = 1 - IF (Q3 .EQ. QP .OR. Q3 .EQ. QX) TMPU = ATEMP1 - IF (Q3 .EQ. QO .OR. Q3 .EQ. QX) JL = 1 - IF (Q3 .EQ. QO .OR. Q3 .EQ. QX) TMPL = ATEMP1 - IF (Q3 .EQ. QR .OR. Q3 .EQ. QL) JU = 1 - IF (Q3 .EQ. QR .OR. Q3 .EQ. QL) TMPU = PLINF - IF (Q3 .EQ. QL .OR. Q3 .EQ. QI) JL = 1 - IF (Q3 .EQ. QL .OR. Q3 .EQ. QI) TMPL = -PLINF - GOTO 620 -C -C STOCHASTIC RANGE FOR ONE OF THE ROWS -C - 610 CONTINUE - JL = 0 - JU = 0 - IT = IROTYP(KRHS(IP) + LROW) - IF (IT .EQ. -1) GOTO 617 - IF (IT .EQ. 1) GOTO 616 - IF (IT .NE. 0) GOTO 9070 - IF (ATEMP1 .GT. 0.0) GOTO 615 - JL = 1 - TMPL = ATEMP1 - GOTO 620 - 615 CONTINUE - JU = 1 - TMPU = ATEMP1 - GOTO 620 - 616 CONTINUE - JU = 1 - TMPU = DABS(ATEMP1) - GOTO 620 - 617 CONTINUE - JL = 1 - TMPL = -DABS(ATEMP1) -C -C Store the coefficients in arrays XLB and XUB. -C - 620 CONTINUE - IF (NREALS .GT. 1) GOTO 640 - NREF = IRNGE0(LP) - DO 630 I=1,JNODES - IF (JL .EQ. 1) XLB(KBOUND(NREF)+LROW) = TMPL - IF (JU .EQ. 1) XUB(KBOUND(NREF)+LROW) = TMPU - NREF = IABS(IBROTH(NREF)) - 630 CONTINUE - GOTO 890 -C - 640 CONTINUE - NODE0 = NODES - JNODES*(NPER+1-LP) - IF (KBOUND(NODE0+1) .NE. KBOUND(IRNGE0(LP))) - * GOTO 680 -C -C Copy the bounds. -C - NREF = IRNGE0(LP) - NCPD = 0 - DO 670 I=1,JNODES - DO 650 JC=1,NCPD - IF (KBOUND(NREF) .NE. LOC1(JC)) GOTO 650 - KBOUND(NODE0+I) = LOC2(JC) - GOTO 665 - 650 CONTINUE - NCPD = NCPD + 1 - LOC1(NCPD) = KBOUND(NREF) - LOC2(NCPD) = LASTBD - KBOUND(NODE0+I) = LASTBD - KCREF = KBOUND(NREF) - NCOEFF = NCOL(LP) + 1 - IF (LASTBD + NCOEFF .GT. MXBNDS) GOTO 9400 - DO 660 JCOEF=1,NCOEFF - XLB(LASTBD+JCOEF) = XLB(KCREF+JCOEF) - XLB(LASTBD+JCOEF) = XLB(KCREF+JCOEF) - 660 CONTINUE - IF (JL .EQ. 1) XLB(LASTBD+LROW) = TMPL - IF (JU .EQ. 1) XUB(LASTBD+LROW) = TMPU - LASTBD = LASTBD + NCOEFF - 665 CONTINUE - NREF = IABS(IBROTH(NREF)) - IF (NREF .LT. NODE0) GOTO 665 - NREF = IABS(IBROTH(NREF)) - 670 CONTINUE - GOTO 890 -C - 680 CONTINUE - NREF = IRNGE0(LP) - DO 690 I=1,JNODES - IF (JL .EQ. 1) XLB(KBOUND(NODE0+I)+LROW) = TMPL - IF (JU .EQ. 1) XUB(KBOUND(NODE0+I)+LROW) = TMPU - 690 CONTINUE - GOTO 890 -C -C HERE WE HAVE A RANDOM COEFFICIENT IN THE CONSTRAINT MATRIX -C - 700 CONTINUE - IF (MULTI .EQ. 3) MULTI = 1 - STOCHA(LP,JMTX) = .TRUE. - JELMA = KELMA(KDATA(LP)+JMTX) - LL = LA(KCOLA(KDATA(LP)+JMTX)+LCOL) - KK = LA(KCOLA(KDATA(LP)+JMTX)+LCOL+1) - 1 - DO 710 LPOSA=LL,KK - IF (IA(JELMA+LPOSA) .EQ. LROW) GOTO 720 - 710 CONTINUE - WRITE (IOLOG, 1000) NREC,Q1,Q2,Q3,Q4,DNAME(1), - * DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 2200) - GOTO 9999 -C - 720 CONTINUE - IF (NREALS .GT. 1) GOTO 740 - NREF = IRNGE0(LP) - DO 730 I=1,JNODES - A(KELMA(KDATA(NREF)+JMTX)+LPOSA) = ATEMP1 - NREF = IABS(IBROTH(NREF)) - 730 CONTINUE - GOTO 890 -C - 740 CONTINUE - NODE0 = NODES - JNODES*(NPER+1-LP) - IAREF = KDATA(IRNGE0(LP)) + JMTX - IACUR = KDATA(NODE0+1) + JMTX - IF (KELMA(IACUR) .NE. KELMA(IAREF)) GOTO 780 -C -C Copy the A coefficients -C - NREF = IRNGE0(LP) - NCPD = 0 - DO 770 I=1,JNODES - DO 750 JC=1,NCPD - IAREF = KDATA(NREF) + JMTX - IF (KELMA(IAREF) .NE. LOC1(JC)) GOTO 750 - KELMA(KDATA(NODE0+I)+JMTX) = LOC2(JC) - GOTO 765 - 750 CONTINUE - NCPD = NCPD + 1 - LOC1(NCPD) = KELMA(KDATA(NREF)+JMTX) - LOC2(NCPD) = LASTA - KELMA(KDATA(NODE0+I)+JMTX) = LASTA - KCREF = KELMA(KDATA(NREF)+JMTX) - NELMS = NELMA(KDATA(NREF)+JMTX) - IF (LASTA + NELMS .GT. MXALMN) GOTO 9500 - IF ( LASTBL .GE. MXABLK) GOTO 9550 - DO 760 JCOEF=1,NELMS - A(LASTA+JCOEF) = A(KCREF+JCOEF) - IA(LASTA+JCOEF) = IA(KCREF+JCOEF) - 760 CONTINUE - A(LASTA+LPOSA) = ATEMP1 - LASTA = LASTA + NELMS - LASTBL = LASTBL + 1 - 765 CONTINUE - NREF = IABS(IBROTH(NREF)) - IF (NREF .LT. NODE0) GOTO 765 - NREF = IABS(IBROTH(NREF)) - 770 CONTINUE - GOTO 890 -C - 780 CONTINUE - NREF = IRNGE0(LP) - DO 790 I=1,JNODES - A(KELMA(KDATA(NODE0+I)+JMTX)+LPOSA) = ATEMP1 - 790 CONTINUE -C -C THE DATA ROW COULD CONTAIN INFO IN THE THIRD NAME FIELD -C - 890 CONTINUE - IF (DNAME(3) .EQ. DBLANK) GOTO 100 - DROW = DNAME(3) - DNAME(3) = DBLANK - ATEMP1 = ATEMP2 - GOTO 300 -C -C Have found an ENDATA card -C - 900 CONTINUE - JNODES = JNODES * NREALS - IF (NECHO .GE. 2) WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1) - RETURN -C - 910 CONTINUE - JNODES = JNODES * NREALS - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1200) - RETURN -C -C COME HERE IF ANYTHING WENT WRONG -C - 9060 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3060) - GOTO 9999 -C - 9070 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3070) - GOTO 9999 -C - 9100 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3100) MXNODE - GOTO 9999 -C - 9200 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3200) MXCOST - GOTO 9999 -C - 9300 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3300) MXDRHS - GOTO 9999 -C - 9400 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3400) MXBNDS - GOTO 9999 -C - 9500 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3500) MXALMN - GOTO 9999 -C - 9550 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3550) MXABLK - GOTO 9999 -C - 9850 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3850) - GOTO 9999 -C - 9875 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3875) - GOTO 9999 -C - 9990 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3990) - 9999 CONTINUE - CALL STOPIT -C - 1000 FORMAT(4A1,A8,2X,A8,2X,F12.4,3X,A8,2X,F12.4) - 1100 FORMAT(I8,4X,4A1,A8,2X,A8,2X,F12.4,3X,A8,2X,F12.4) - 1200 FORMAT(' XXX - WARNING - Missing ENDATA card') - 1300 FORMAT(I8,4X,4A1,A8,2X,A8,17X,A8,14X,' : Realization',I3) - 1600 FORMAT(' XXX - FATAL - Illegal header card in STOCH file') - 1700 FORMAT(I8,4X,' Found realization number',I4,' of block ',A8) - 1800 FORMAT(I8,4X,' Found realization number',I4) - 1900 FORMAT(' XXX - FATAL - Illegal type of random element') - 2000 FORMAT(' XXX - FATAL - Illegal name for a time period') - 2100 FORMAT(' XXX - FATAL - Column name ',A8,' not matched') - 2200 FORMAT(' XXX - FATAL - Location of random element undefined') - 3060 FORMAT(' XXX - FATAL - Attempt to set explicit bound on logical', - * ' variable') - 3070 FORMAT(' XXX - FATAL - Illegal row type in stochastic RANGES', - * ' section') - 3100 FORMAT(' XXX - FATAL - More than ',I6,' nodes in the tree.', - * ' Increase parameter MXNODE.') - 3200 FORMAT(' XXX - FATAL - More than ',I6,' cost coefficients.', - * ' Increase parameter MXCOST.') - 3300 FORMAT(' XXX - FATAL - More than ',I6,' right hand sides.', - * ' Increase parameter MXDRHS.') - 3400 FORMAT(' XXX - FATAL - More than ',I6,' stochastic bounds.', - * ' Increase parameter MXBNDS.') - 3500 FORMAT(' XXX - FATAL - More than ',I6,' constraint elements.', - * ' Increase parameter MXALMN.') - 3550 FORMAT(' XXX - FATAL - More than ',I6,' blocks in A-matrix.', - * ' Increase parameter MXABLK.') - 3850 FORMAT(' XXX - FATAL - Chronological order violated for random', - * ' elements') - 3875 FORMAT(' XXX - FATAL - Illegal type of random element') - 3990 FORMAT(' XXX - FATAL - Error while reading STOCH_FILE') - END -C -C ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -C - SUBROUTINE INCONT(Q1, Q2, Q3, Q4, DNAME, ATEMP1, ATEMP2, - * NAME1, NAME2, NAME3, PAR1, PAR2, MDIST, - * ARMTX, IRMTX, LRMTX, NREC) -C - include 'common6.for' - CHARACTER*8 DNAME, NAME1, NAME2, NAME3, PAR1, PAR2, ARMTX -C - WRITE (IOLOG, 1800) - CALL STOPIT -C - 1800 FORMAT(' Continuous distributions cannot be handled by this', - * ' version of MSLiP.',/,/, - * ' Sorry for the inconvenience.') -C - END -C -C ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -C - SUBROUTINE INCORE ( DTIMEC, DTIMER, IROTYP, PROBNM, - * IOBJ1, NPSEEN, IERR, NREC) -C -C This subroutine reads the core file in the modified MPS format -C described in the standards paper. -C -C --------------------------------------- -C This version dated November 3, 1987. -C --------------------------------------- -C - include 'common6.for' -C - CHARACTER*8 DNAME(3), DROWNM(MXVNAM), DBLANK, PROBNM, - * DTIMEC(MXTPER), DTIMER(MXTPER), DROW, DCOL, DOTS, OBJNAM - DIMENSION AUX(MXANZB,MXTPER),IAUX(MXANZB,MXTPER), - * LAUX(MXCOLP,MXTPER),LMNS(MXTPER),IROTYP(MXBNDS) -C - EQUIVALENCE (DROWNM,X) -C - DATA DBLANK/' '/, DOTS /' ... '/ -C -C INITIALIZE POINTERS -C - DO 100 I=1,MXTPER - DO 100 J=1,MXTPER - STOCHA(I,J) = .FALSE. - 100 CONTINUE -C - IOBJ = 0 - IOBJ1 = 0 - NPSEEN = 1 - INODE = 1 - KDATA(1) = 0 - KCOLA(1) = 0 - KELMA(1) = 0 - KBOUND(1) = 0 - KROW(1) = 0 - KCOL(1) = 0 - KRHS(1) = 0 - KCOST(1) = 0 - KNAMES(1) = 0 - IANCTR(1) = 0 - IBROTH(1) = 0 - PROB(1) = 1.D0 - IROW = KROW(1) - NROWS = 0 - MAXROW = 0 - OBJNAM = DBLANK - IENDAT = 0 -C -C Now read the core-file. Start with the ROWS section -C - 150 CONTINUE - READ (IOCOR, 1000, ERR=152, END=9000) - * Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - NREC = NREC + 1 - IF (Q1 .EQ. QBL) GOTO 160 - IF (Q1 .EQ. QN .AND. Q2 .EQ. QA) GOTO 155 - IF (Q1 .EQ. QR .AND. Q2 .EQ. QO) GOTO 151 - IF (Q1 .EQ. QC .AND. Q2 .EQ. QO) GOTO 200 - IF (Q1 .EQ. QR .AND. Q2 .EQ. QH) GOTO 9300 - IF (Q1 .EQ. QB) GOTO 9300 - IF (Q1 .EQ. QR .AND. Q2 .EQ. QA) GOTO 9300 - IF (Q1 .EQ. QE) GOTO 9300 - IF (Q1 .EQ. QAST) GOTO 150 - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 2300) - GOTO 9999 -C - 151 CONTINUE - IENDAT = 1 - IF (NECHO .GE. 2) WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1) - GOTO 150 -C - 152 CONTINUE - IF (Q1 .NE. QAST) GOTO 9980 - NREC = NREC + 1 - GOTO 150 -C - 155 CONTINUE - IF (DNAME(2) .NE. PROBNM) GOTO 9150 - GOTO 150 -C - 160 CONTINUE - IF (NECHO .GE. 5) WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1) - IF (DNAME(1) .NE. DTIMER(NPSEEN+1)) GOTO 180 -C -C Here we have the first row of a new time period -C - IF (IOBJ .GT. 0 ) GOTO 165 - IF (NROWS .GE. MXROWP) GOTO 9100 - IF (MAXROW .GE. MXROWS) GOTO 9500 - NROWS = NROWS + 1 - MAXROW = MAXROW + 1 - IOBJ = NROWS - NROW(INODE) = NROWS - NCOL(INODE) = NROWS - DROWNM(NROWS) = DROWNM(1) - DROWNM(1) = DOTS - IROTYP(NROWS) = IROTYP(1) - IROTYP(1) = 2 - 165 CONTINUE - IF (NPSEEN .GE. MXTPER) GOTO 9520 - IF (INODE .GE. MXNODE) GOTO 9530 - NPSEEN = NPSEEN + 1 - IPREV = INODE - INODE = INODE + 1 - IDESC(IPREV) = INODE - IRNGE0(IPREV) = IPREV - IRNGE1(IPREV) = IPREV - IRNGE2(IPREV) = IPREV - IBROTH(INODE) = 0 - IANCTR(INODE) = IPREV - PROB(INODE) = 1.0 - KROW(INODE) = KROW(IPREV) + NROW(IPREV) - KRHS(INODE) = KRHS(IPREV) + NROW(IPREV) - IROW = KROW(INODE) - IF (IROW .GE. MXVNAM) GOTO 9540 - IF (IROW .GE. MXBNDS) GOTO 9550 - DROWNM(IROW+1) = DROWNM(1) - IROTYP(IROW+1) = 2 - NROWS = 1 -C -C Test row type -C - 180 CONTINUE - IF (NROWS .GE. MXROWP) GOTO 9100 - IF (MAXROW .GE. MXROWS) GOTO 9500 - IF (IROW .GE. MXVNAM) GOTO 9540 - IF (IROW .GE. MXBNDS) GOTO 9550 - MAXROW = MAXROW + 1 - NROWS = NROWS + 1 - NROW(INODE) = NROWS - NCOL(INODE) = NROWS - DROWNM(IROW+NROWS) = DNAME(1) - IF ( NROWS .GT. MXROWP) GOTO 9100 - ITYPE = 3 - IF ((Q2 .EQ. QE).OR.(Q3 .EQ. QE)) ITYPE = 0 - IF ((Q2 .EQ. QG).OR.(Q3 .EQ. QG)) ITYPE = -1 - IF ((Q2 .EQ. QL).OR.(Q3 .EQ. QL)) ITYPE = 1 - IF ((Q2 .EQ. QN).OR.(Q3 .EQ. QN)) GOTO 185 - IF (ITYPE .EQ. 3) GOTO 190 - IROTYP(IROW+NROWS) = ITYPE - GOTO 150 -C -C Unbounded row is either the objective or should be ignored -C - 185 CONTINUE - IF (NPSEEN .GT. 1 .OR. IOBJ .GT. 0) GOTO 188 - IF (DNAME(1) .NE. OBJNAM .AND. OBJNAM .NE. DBLANK) - * GOTO 188 - IOBJ = NROWS - IOBJ1 = NROWS - IROTYP(NROWS) = IROTYP(1) - IROTYP(1) = 2 - DROWNM(NROWS) = DROWNM(1) - DROWNM(1) = DNAME(1) - GOTO 150 - 188 CONTINUE - IROTYP(IROW+NROWS) = 2 - GOTO 150 -C -C Unrecognized code in code field. Ignore this row -C - 190 CONTINUE - WRITE (IOLOG, 1400) NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2), - * ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1800) Q2,Q3 - GOTO 150 -C -C Now start the COLUMNS section -C - 200 CONTINUE - IF (NECHO .GE. 2) WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1) - IF (NPSEEN .GT. NPER) GOTO 9200 - IF (IENDAT .EQ. 0) GOTO 9700 - IENDAT = 2 - IDESC(INODE) = 0 - IBROTH(INODE) = 0 - IANCTR(INODE) = INODE - 1 - IRNGE0(NPSEEN) = INODE - IRNGE1(NPSEEN) = INODE - IRNGE2(NPSEEN) = INODE - IPER = 1 - IOBJ = 1 - IROW = 0 - ICOL = 0 - INODE = 1 - ICOLA = 0 - ICOST = 0 - IDATA = 0 - IELMA = 0 - INAMES = 0 - IBOUND = 0 - NROWS = NROW(1) - IROW1 = NROWS - KMTX = 1 - DO 201 JR=1,NROWS - NAMES(JR) = DROWNM(JR) - XLB(JR) = 0.D0 - XUB(JR) = PLINF - IF (IROTYP(JR) .LE. 0) XUB(JR) = 0.D0 - IF (IROTYP(JR) .EQ. 2) XLB(JR) =-PLINF - IF (IROTYP(JR) .EQ.-1) XLB(JR) =-PLINF - 201 CONTINUE - NELEM = 0 - DO 2015 JJ=1,MXTPER - LMNS(JJ) = 0 - 2015 CONTINUE -C - 202 CONTINUE - READ (IOCOR, 1000, ERR=203, END=9000) - * Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - NREC = NREC + 1 - IF (Q1 .EQ. QR .AND. Q2 .EQ. QH) GOTO 260 - IF (Q1 .EQ. QB .AND. Q2 .EQ. QO) GOTO 270 - IF (Q1 .EQ. QR .AND. Q2 .EQ. QA) GOTO 280 - IF (Q1 .EQ. QE ) GOTO 290 - IF (Q1 .EQ. QBL ) GOTO 205 - IF (Q1 .EQ. QAST) GOTO 202 - WRITE (IOLOG, 1400) NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2), - * ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 2300) - GOTO 9999 -C - 203 CONTINUE - IF (Q1 .NE. QAST) GOTO 9980 - NREC = NREC + 1 - GOTO 202 -C - 205 CONTINUE - IF (NECHO .GE. 5) WRITE (IOLOG, 1400) NREC,Q1,Q2,Q3,Q4, - * DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - JNM = 2 - IF (DABS(ATEMP1) .GT. ZTOLZE) GOTO 206 - IF (DABS(ATEMP2) .LE. ZTOLZE) GOTO 202 - JNM = 3 - ATEMP1 = ATEMP2 - 206 CONTINUE - IF (DNAME(1) .EQ. DCOL) GO TO 220 - IF (DNAME(1) .NE. DTIMEC(IPER+1)) GOTO 215 -C -C A new period is coming up. -C - IF (IPER .GE. NPSEEN) GOTO 9200 - KBLOK = 2*IPER + 1 - IF (.NOT. MARKOV) KBLOK = (IPER+1)*(IPER+2)/2 - IF (KBLOK .GT. MXABLK) GOTO 9560 - NCOL(IPER) = NCOLS - NELMA(IDATA+1) = NELEM - LASTA = LASTA + NELEM - LASTCA = LASTCA + NCOLS + 1 -NROW(IPER) - IF (IPER .EQ. NPSEEN) GOTO 211 -C -C Check if problem still has staircase structure. -C - NMTX = NPSEEN - IPER - DO 210 JMTX=1,NMTX - LMNJ = LMNS(JMTX) - IF (LMNJ .EQ. 0 .AND. JMTX .GE. 2 .AND. MARKOV) - * GOTO 210 - IF (LMNJ .EQ. 0 .OR. JMTX .LT. 2 .OR. .NOT. MARKOV) - * GOTO 2105 - IF ((IPER+1)*(IPER+2)/2 .GT. MXABLK) GOTO 9560 - MARKOV = .FALSE. - DO 2101 JAUX = 4,IPER - J = IPER + 4 - JAUX - KDAT2 = J * (J-1)/2 + 3 - KDAT1 = J * 2 - KDATA(J) = KDAT2 - DO 2100 K=1,2 - KCOLA(KDAT2-K) = KCOLA(KDAT1-K) - KELMA(KDAT2-K) = KELMA(KDAT1-K) - NELMA(KDAT2-K) = NELMA(KDAT1-K) - KCOLA(KDAT1-K) = 0 - KELMA(KDAT1-K) = 0 - NELMA(KDAT1-K) = 0 - 2100 CONTINUE - 2101 CONTINUE - DO 2104 JN=1,IPER - NCOLA = NCOL(JN) + 1 - NROW(JN) - DO 2103 JP=3,NPSEEN+1-JN - IF (JN .EQ. IPER .AND. JP .GT. NMTX) - * GOTO 2103 - JAUX = JN + JP - 1 - JDAT = JAUX*(JAUX-1)/2 + JP - KCOLA(JDAT) = LASTCA - KELMA(JDAT) = LASTA - NELMA(JDAT) = 0 - IF (LASTCA + NCOLA .GT. MXACOL) GOTO 9570 - DO 2102 JC=1,NCOLA - LA(LASTCA+JC) = 1 - 2102 CONTINUE - LASTCA = LASTCA + NCOLA - 2103 CONTINUE - 2104 CONTINUE -C -C COPY SUB-DIAGONAL MATRICES OF CURRENT NODE -C - 2105 CONTINUE - JAUX = IPER + JMTX - JLOC = JAUX*(JAUX-1)/2 + JMTX + 1 - IF (MARKOV) JLOC = JAUX*2 + JMTX - 2 - KCOLA(JLOC) = LASTCA - KELMA(JLOC) = LASTA - NELMA(JLOC) = LMNJ - IF (LASTA + LMNS(JMTX) .GT. MXALMN) GOTO 9580 - IF (LASTCA+ NCOLS+1 -NROW(IPER) .GT. MXACOL) GOTO 9570 - DO 209 JC=1,NCOLS-NROW(IPER) - LL = LAUX(JC,JMTX) - KK = LAUX(JC+1,JMTX) - 1 - LA(LASTCA+JC) = LL - DO 208 JR=LL,KK - IA(LASTA+JR) = IAUX(JR,JMTX) - A(LASTA+JR) = AUX(JR,JMTX) - 208 CONTINUE - 209 CONTINUE - LASTA = LASTA + LMNS(JMTX) - LASTCA = LASTCA + NCOLS + 1 - NROW(IPER) - LA(LASTCA) = KK + 1 - 210 CONTINUE -C -C NOW SET THE POINTER VALUES -C - 211 CONTINUE - NMTX = IPER - KMTX = NPSEEN - IPER - IF (MARKOV) KMTX = 1 - IF (MARKOV .AND. IPER .GT. 2) NMTX = 2 - IPREV = IPER - IPER = IPER + 1 - INODE = INODE + 1 - IDATA = KDATA(IPREV) + NMTX - KCOL(IPER) = KCOL(IPREV) + NCOLS + 1 - KCOLA(IDATA+1) = LASTCA - KCOST(IPER) = KCOST(IPREV) + NCOLS - NROW(IPREV) - KELMA(IDATA+1) = LASTA - KBOUND(IPER) = KBOUND(IPREV) + NCOLS + 1 - KNAMES(IPER) = KNAMES(IPREV) + NCOLS + 1 - KDATA(IPER) = IDATA - NELEM = 0 - DO 2115 JJ=1,MXTPER - LMNS(JJ) = 0 - 2115 CONTINUE - ICOL = KCOL(IPER) - IROW = KROW(IPER) - ICOLA = LASTCA - ICOST = KCOST(IPER) - IELMA = LASTA - INAMES = KNAMES(IPER) - IBOUND = KBOUND(IPER) - NROWS = NROW(IPER) - IF (INAMES + NROWS .GT. MXVNAM) GOTO 9540 - IF (IBOUND + NROWS .GT. MXBNDS) GOTO 9550 - DO 213 JR=1,NROWS - NAMES(INAMES+JR) = DROWNM(IROW+JR) - XLB(IBOUND+JR) = 0.D0 - XUB(IBOUND+JR) = PLINF - IF (IROTYP(IROW+JR) .LE. 0) XUB(IBOUND+JR) = 0.D0 - IF (IROTYP(IROW+JR) .EQ. 2) XLB(IBOUND+JR) =-PLINF - IF (IROTYP(IROW+JR) .EQ.-1) XLB(IBOUND+JR) =-PLINF - 213 CONTINUE -C -C START A NEW COLUMN -C - 215 CONTINUE - NCOLS = NCOL(INODE) + 1 - NCOL(INODE) = NCOLS - DCOL = DNAME(1) - ICC = ICOLA + NCOLS - NROWS - JCOST = ICOST + NCOLS - NROWS - IF (NCOLS .GT. MXCOLP) GOTO 9110 - IF (ICC .GE. MXACOL) GOTO 9570 - IF (JCOST .GT. MXCOST) GOTO 9630 - IF (ICOL + NCOLS .GT. MXCOLS) GOTO 9510 - IF (INAMES + NCOLS .GT. MXVNAM) GOTO 9540 - COST(JCOST) = 0.D0 - NAMES(INAMES+NCOLS) = DCOL - LA(ICC) = NELEM + 1 - LA(ICC+1) = NELEM + 1 - IF (IPER .EQ. NPSEEN) GOTO 220 - DO 218 JMTX=1,KMTX - LAUX(NCOLS-NROWS, JMTX) = LMNS(JMTX) + 1 - LAUX(NCOLS-NROWS+1,JMTX) = LMNS(JMTX) + 1 - 218 CONTINUE -C -C TEST FOR ROW MATCH -C - 220 CONTINUE - DROW = DNAME(JNM) - DO 230 I=1,NROWS - IF (DROW .EQ. NAMES(INAMES+I)) GOTO 240 - 230 CONTINUE - IF (IPER .GE. NPER) GOTO 236 - DO 235 JMTX=1,NPER-IPER - JROWS = NROW(IPER+JMTX) - IROW1 = KROW(IPER+JMTX) - DO 235 I=2,JROWS - IF (DROW .EQ. DROWNM(IROW1+I)) GOTO 250 - 235 CONTINUE - 236 CONTINUE -C -C PERHAPS WE ARE DEALING WITH AN ALTERNATIVE OBJECTIVE ROW? -C - LROWS = NROW(1) - DO 237 I=1,LROWS - IF (DROW .EQ. NAMES(I) .AND. IROTYP(I) .EQ. 2) GOTO 255 - 237 CONTINUE -C - WRITE (IOLOG, 1400) NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2), - * ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1100) DROW - GOTO 9999 -C -C MATCHED A COEFFICIENT IN THE A-MATRIX -C - 240 CONTINUE - IF (I .EQ. IOBJ) GOTO 245 - IF (NELEM + IELMA .GT. MXALMN) GOTO 9580 - NELEM = NELEM + 1 - IA(IELMA+NELEM) = I - A(IELMA+NELEM) = ATEMP1 - LA(ICOLA+NCOLS-NROWS+1) = NELEM + 1 - GOTO 255 -C -C COST COEFFICIENTS (EVEN IF FIXED) ARE NOT STORED IN THE A-MATRIX -C - 245 CONTINUE - COST(JCOST) = ATEMP1 - GOTO 255 -C -C WE HAVE FOUND AN ELEMENT OF THE JMTX-th SUBDIAGONAL MATRIX -C - 250 CONTINUE - IF (JMTX .LE. KMTX) GOTO 253 - KMTX = NPSEEN - IPER - DO 252 JJ=2,KMTX - DO 251 JC=1,NCOLS+1-NROWS - LAUX(JC,JJ) = 1 - 251 CONTINUE - 252 CONTINUE - 253 CONTINUE - IF (LMNS(JMTX) .GE. MXANZB) GOTO 9590 - LMNS(JMTX) = LMNS(JMTX) + 1 - LAUX(NCOLS+1-NROWS,JMTX) = LMNS(JMTX) + 1 - IAUX(LMNS(JMTX), JMTX) = I - AUX(LMNS(JMTX), JMTX) = ATEMP1 -C - 255 CONTINUE - IF (JNM .EQ. 3) GOTO 202 - IF (DABS(ATEMP2) .LE. ZTOLZE) GOTO 202 - JNM = 3 - ATEMP1 = ATEMP2 - GOTO 220 -C -C THE COLUMNS SECTION IS DONE. WHAT IS NEXT? -C - 260 CONTINUE - L = 1 - GOTO 300 - 270 CONTINUE - L = 2 - GOTO 300 - 280 CONTINUE - L = 3 - GOTO 300 - 290 CONTINUE - L = 4 -C -C SET RHS AND BOUNDS TO DEFAULT VALUES AND SET INITIAL BASIS -C - 300 CONTINUE - IF (IPER .NE. NPSEEN) GOTO 9200 - LASTA = LASTA + NELEM - LASTC = KCOST(IPER) + NCOLS - NROW(IPER) - LASTCA = LASTCA + 1 + NCOLS - NROW(IPER) - LASTR = KRHS(IPER) + NROW(IPER) - LASTBD = KBOUND(IPER) + NCOLS + 1 - LASTD = 2 * IPER - 1 - IF (.NOT. MARKOV) LASTD = IPER * (IPER+1)/2 - NCOL(IPER) = NCOLS - NELMA(IDATA+1) = NELEM - DEFRHS = 0.D0 - DEFLOB = DEFLB - DEFUPB = DEFUB - DO 301 J=1,MAXROW - XI(J) = DEFRHS - 301 CONTINUE - DO 304 IP=1,NPSEEN - MINC = KBOUND(IP) + NROW(IP) + 1 - MAXC = KBOUND(IP) + NCOL(IP) - IF (MAXC .GT. MXBNDS) GOTO 9550 - DO 302 J=MINC,MAXC - XLB(J) = DEFLOB - XUB(J) = DEFUPB - 302 CONTINUE - NROWS = NROW(IP) - NCOLS = NCOL(IP) - IROW = KROW(IP) - ICOL = KCOL(IP) - DO 303 I=1,NROWS - JH(IROW+I) = ICOL + I - KINBAS(ICOL+I) = IROW + I - 303 CONTINUE - DO 304 I=NROWS+1,NCOLS+1 - KINBAS(ICOL+I) = 0 - 304 CONTINUE - IF (L .EQ. 4) GOTO 450 - IF (NECHO .GE. 2) WRITE (IOLOG, 1400) NREC,Q1,Q2,Q3,Q4, - * DNAME(1) -C -C RHS, BOUNDS AND RANGES -C - 305 CONTINUE - IP0 = 1 - I0 = 1 - 306 CONTINUE - READ (IOCOR, 1000, ERR=308, END=9000) - * Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - NREC = NREC + 1 - IF (Q1 .EQ. QAST) GOTO 306 - IF (Q1 .EQ. QE ) GOTO 450 - IF (Q1 .EQ. QBL ) GOTO 309 - L = 2 - IF (Q1 .EQ. QB .AND. Q2 .EQ. QO) GOTO 307 - L = 3 - IF (Q1 .EQ. QR .AND. Q2 .EQ. QA) GOTO 307 - WRITE (IOLOG,1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 2300) - GOTO 9999 -C - 307 CONTINUE - IF (NECHO .GE. 2) WRITE (IOLOG, 1400) NREC,Q1,Q2,Q3,Q4, - * DNAME(1) - GOTO 305 -C - 308 CONTINUE - IF (Q1 .NE. QAST) GOTO 9980 - NREC = NREC + 1 - GOTO 306 -C - 309 CONTINUE - IF (NECHO .GE. 5) WRITE (IOLOG, 1400) NREC,Q1,Q2,Q3,Q4, - * DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - GOTO (310,350,400,450), L -C - 310 CONTINUE - J = 2 - IF (DABS(ATEMP1) .GT. ZTOLZE) GOTO 312 - IF (DABS(ATEMP2) .LE. ZTOLZE) GOTO 306 - J = 3 - ATEMP1 = ATEMP2 -C -C TEST FOR ROW MATCH -C - 312 CONTINUE - IF (DXI .EQ. DOTS ) DXI = DNAME(1) - IF (DXI .NE. DNAME(1) ) GOTO 306 - DROW = DNAME(J) - IP = IP0 - DO 318 I=I0,NROW(IP) - IF (DROW .EQ. NAMES(KNAMES(IP)+I)) GOTO 330 - 318 CONTINUE - DO 319 I=1,I0 - IF (DROW .EQ. NAMES(KNAMES(IP)+I)) GOTO 330 - 319 CONTINUE - DO 320 IP=IP0+1,NPER - DO 320 I=1,NROW(IP) - IF (DROW .EQ. NAMES(KNAMES(IP)+I)) GOTO 330 - 320 CONTINUE - DO 321 IP=1,NPER - DO 321 I=1,NROW(IP) - IF (DROW .EQ. NAMES(KNAMES(IP)+I)) GOTO 330 - 321 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1200) DROW - GOTO 9999 -C -C MATCHED -C - 330 CONTINUE - IP0 = IP - I0 = I - IF (KRHS(IP)+I .GT. MXDRHS) GOTO 9640 - XI(KRHS(IP)+I) = ATEMP1 - IF (J .EQ. 3) GOTO 306 - IF (DABS(ATEMP2) .LE. ZTOLZE) GOTO 306 - J = 3 - ATEMP1 = ATEMP2 - GOTO 312 -C -C BOUNDS SECTION. MATCH THE COLUMN NAME. -C - 350 CONTINUE - IF (DBOUND .EQ. DOTS ) DBOUND = DNAME(1) - IF (DBOUND .NE. DNAME(1) ) GOTO 306 - DROW = DNAME(2) - IP = IP0 - DO 354 I=I0,NCOL(IP) - IF (DROW .EQ. NAMES(KNAMES(IP)+I)) GOTO 360 - 354 CONTINUE - DO 355 I=1,I0 - IF (DROW .EQ. NAMES(KNAMES(IP)+I)) GOTO 360 - 355 CONTINUE - DO 356 IP=IP0+1,NPER - DO 356 I=1,NCOL(IP) - IF (DROW .EQ. NAMES(KNAMES(IP)+I)) GOTO 360 - 356 CONTINUE - DO 357 IP=1,NPER - DO 357 I=1,NCOL(IP) - IF (DROW .EQ. NAMES(KNAMES(IP)+I)) GOTO 360 - 357 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1300) DROW - GOTO 9999 -C -C MATCHED. NOW DETERMINE THE BOUND TYPE -C - 360 CONTINUE - IP0 = IP - I0 = I - IC = KBOUND(IP) + I - IF (IC .GT. MXBNDS) GOTO 9550 - IF (Q2 .EQ. QL .AND. Q3 .EQ. QO) GOTO 361 - IF (Q2 .EQ. QU .AND. Q3 .EQ. QP) GOTO 366 - IF (Q2 .EQ. QF .AND. Q3 .EQ. QX) GOTO 365 - IF (Q2 .EQ. QF .AND. Q3 .EQ. QR) GOTO 370 - IF (Q2 .EQ. QM .AND. Q3 .EQ. QI) GOTO 368 - IF (Q2 .EQ. QP .AND. Q3 .EQ. QL) GOTO 372 - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1700) - GOTO 9999 -C - 361 CONTINUE - XLB(IC) = ATEMP1 - GOTO 306 - 365 CONTINUE - XLB(IC) = ATEMP1 - 366 CONTINUE - XUB(IC) = ATEMP1 - GOTO 306 - 368 CONTINUE - XLB(IC) = -PLINF - GOTO 306 - 370 CONTINUE - XLB(IC) = -PLINF - 372 CONTINUE - XUB(IC) = PLINF - GOTO 306 -C -C RANGES SECTION. MATCH THE ROW NAME. -C - 400 CONTINUE - IF (DRANGE .EQ. DOTS ) DRANGE = DNAME(1) - IF (DRANGE .NE. DNAME(1) ) GOTO 306 - J = 2 - IF (DABS(ATEMP1) .GT. ZTOLZE) GOTO 412 - IF (DABS(ATEMP2) .LE. ZTOLZE) GOTO 306 - J = 3 - ATEMP1 = ATEMP2 -C -C TEST FOR ROW MATCH -C - 412 CONTINUE - DROW = DNAME(J) - IP = IP0 - DO 418 I=I0,NROW(IP) - IF (DROW .EQ. NAMES(KNAMES(IP)+I)) GOTO 430 - 418 CONTINUE - DO 419 I=1,I0 - IF (DROW .EQ. NAMES(KNAMES(IP)+I)) GOTO 430 - 419 CONTINUE - DO 420 IP=IP0+1,NPER - DO 420 I=1,NROW(IP) - IF (DROW .EQ. NAMES(KNAMES(IP)+I)) GOTO 430 - 420 CONTINUE - DO 421 IP=1,NPER - DO 421 I=1,NROW(IP) - IF (DROW .EQ. NAMES(KNAMES(IP)+I)) GOTO 430 - 421 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1200) DROW - GOTO 9999 -C -C MATCHED -C - 430 CONTINUE - IP0 = IP - I0 = I - IR = KRHS(IP) + I - IT = IROTYP(IR) - IF (KBOUND(IP)+I .GT. MXBNDS) GOTO 9550 - IF (IT .EQ. 1) GOTO 435 - IF (IT .EQ. -1) GOTO 440 - IF (IT .NE. 0) GOTO 9600 - IF (ATEMP1 .GT. 0.) XUB(KBOUND(IP)+I) = ATEMP1 - IF (ATEMP1 .LT. 0.) XLB(KBOUND(IP)+I) =-ATEMP1 - GOTO 442 - 435 CONTINUE - XUB(KBOUND(IP)+I) = DABS(ATEMP1) - GOTO 442 - 440 CONTINUE - XLB(KBOUND(IP)+I) = -DABS(ATEMP1) - 442 CONTINUE - IF (J .EQ. 3) GOTO 306 - IF (DABS(ATEMP2) .LE. ZTOLZE) GOTO 306 - J = 3 - ATEMP1 = ATEMP2 - GOTO 412 -C -C END OF CORE FILE -C - 450 CONTINUE - IF (NECHO .GE. 2) WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1) - LASTNM = KNAMES(NPER) + NCOL(NPER) + 1 - RETURN -C -C COME HERE IF ANYTHING WENT WRONG -C - 9000 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - IF (IENDAT .EQ. 0) GOTO 9020 - IF (IENDAT .EQ. 1 .OR. NPER .NE. NPSEEN) GOTO 9010 - WRITE (IOLOG, 3000) - RETURN -C - 9010 CONTINUE - WRITE (IOLOG, 3010) - GOTO 9999 -C - 9020 CONTINUE - IERR = 1 - WRITE (IOLOG, 3020) - RETURN -C - 9100 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3100) MXROWP,INODE - GOTO 9999 -C - 9110 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3110) MXCOLP,INODE - GOTO 9999 -C - 9150 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3150) - GOTO 9999 -C - 9200 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3200) - GOTO 9999 -C - 9300 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3300) - GOTO 9999 -C - 9500 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3500) MXROWS - GOTO 9999 -C - 9510 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3510) MXCOLS - GOTO 9999 -C - 9520 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3520) MXTPER - GOTO 9999 -C - 9530 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3530) MXNODE - GOTO 9999 -C - 9540 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3540) MXVNAM - GOTO 9999 -C - 9550 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3550) MXBNDS - GOTO 9999 -C - 9560 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3560) MXABLK - GOTO 9999 -C - 9570 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3570) MXACOL - GOTO 9999 -C - 9580 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3580) MXALMN - GOTO 9999 -C - 9590 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3590) MXANZB - GOTO 9999 -C - 9600 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3600) - GOTO 9999 -C - 9630 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3630) MXCOST - GOTO 9999 -C - 9640 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3640) MXDRHS - GOTO 9999 -C - 9700 CONTINUE - WRITE (IOLOG, 1400) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3700) - GOTO 9999 -C - 9980 CONTINUE - WRITE (IOLOG, 3980) - GOTO 9999 -C - 9999 CONTINUE - CALL STOPIT -C - 1000 FORMAT(4A1,A8,2X,A8,2X,F12.4,3X,A8,2X,F12.4) - 1100 FORMAT(' XXX - FATAL - Row ',A8,' was never defined in ' - * 'ROWS section') - 1200 FORMAT(' XXX - FATAL - Unmatched row name ',A8, - * ' in RHS or RANGES section') - 1300 FORMAT(' XXX - FATAL - Unmatched column name ',A8, - * ' in BOUNDS section') - 1400 FORMAT(I8,4X,4A1,A8,2X,A8,2X,F12.4,3X,A8,2X,F12.4) - 1700 FORMAT(' XXX - FATAL - Error in BOUNDS section.') - 1800 FORMAT(' XXX - WARNING - Unrecognized code =',2A1,'= in ROWS', - * ' section. Row ignored.') - 2300 FORMAT(' XXX - FATAL - Illegal header card in CORE file') - 3000 FORMAT(' XXX - WARNING - Missing ENDATA card in CORE file') - 3010 FORMAT(' XXX - FATAL - Detected EOF in CORE file') - 3020 FORMAT(' XXX - WARNING - No information in CORE file') - 3100 FORMAT(' XXX - FATAL - More than ',I6,' rows in node ',I6,'.', - * ' Increase parameter MXROWP.') - 3110 FORMAT(' XXX - FATAL - More than ',I6,' cols in node ',I6,'.', - * ' Increase parameter MXCOLP.') - 3150 FORMAT(' XXX - FATAL - Duplicate NAME card in core file') - 3200 FORMAT(' XXX - FATAL - Number of periods misspecified in ROWS', - * ' or COLUMNS section') - 3300 FORMAT(' XXX - FATAL - No COLUMNS section specified') - 3500 FORMAT(' XXX - FATAL - More than ',I6,' rows altogether.', - * ' Increase parameter MXROWS.') - 3510 FORMAT(' XXX - FATAL - More than ',I6,' cols altogether.', - * ' Increase parameter MXCOLS.') - 3520 FORMAT(' XXX - FATAL - More than ',I6,' time periods.', - * ' Increase parameter MXTPER.') - 3530 FORMAT(' XXX - FATAL - More than ',I6,' nodes in the tree.', - * ' Increase parameter MXNODE.') - 3540 FORMAT(' XXX - FATAL - More than ',I6,' variable names.', - * ' Increase parameter MXVNAM.') - 3550 FORMAT(' XXX - FATAL - More than ',I6,' logical variables.', - * ' Increase parameter MXBNDS.') - 3560 FORMAT(' XXX - FATAL - More than ',I6,' blocks in A-matrix.', - * ' Increase parameter MXABLK.') - 3570 FORMAT(' XXX - FATAL - More than ',I6,' columns in A-matrix.', - * ' Increase parameter MXACOL.') - 3580 FORMAT(' XXX - FATAL - More than ',I6,' nonzeros in A-matrix.', - * ' Increase parameter MXALMN.') - 3590 FORMAT(' XXX - FATAL - More than ',I6,' nonzeros in one block.', - * ' Increase parameter MXANZB.') - 3600 FORMAT(' XXX - FATAL - Illegal row type in RANGES section') - 3630 FORMAT(' XXX - FATAL - More than ',I6,' cost coefficients.', - * ' Increase parameter MXCOST.') - 3640 FORMAT(' XXX - FATAL - More than ',I6,' right hand side values.', - * ' Increase parameter MXDRHS.') - 3700 FORMAT(' XXX - FATAL - ROWS section is non-existent') - 3980 FORMAT(' XXX - FATAL - Error while reading CORE_FILE') - END -C -C ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -C - SUBROUTINE INELEM (IROTYP, IIPER, IPER0, JNODES, NREC) -C -C This subroutine reads the stoch file for independent realizations -C of the random variables. It distinguishes between staircase and -C block-triangular problems by means of the logical variable MARKOV. -C This can be set in INCORE, since the sparsity structure is assumed -C to be the same for all scenarios. -C -C ------------------------------- -C Dated June 14, 1989 -C ------------------------------- -C - include 'common6.for' -C - CHARACTER*8 DNAME(3), DBLANK, DROW, DCOL, DBLOCK - DIMENSION IROTYP(MXBNDS), LOC1(MXNODE), LOC2(MXNODE) -C - EQUIVALENCE (LOC1,X), (LOC2,IE) -C - DATA DBLANK/' '/ -C - DROW = DBLANK - DCOL = DBLANK - NREALS = 1 - JNODES = 1 - NODES = NPER - IIPER = 0 - IPER0 = 0 - PROB(1) = 1.0 -C -C START WITH SOME BOOK-KEEPING AND FIX THE PERIOD -C - 100 CONTINUE - READ (IOSTO, 1000, ERR=105, END=910) - * Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - NREC = NREC + 1 - IF (Q1 .EQ. QAST) GOTO 100 - IF (Q1 .EQ. QE ) GOTO 900 - IF (Q1 .EQ. QBL ) GOTO 110 - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1600) - GOTO 9999 -C - 105 CONTINUE - IF (Q1 .NE. QAST) GOTO 9990 - NREC = NREC + 1 - GOTO 100 -C -C First determine the period of this element -C - 110 CONTINUE - DO 130 IP=1,NPER - IF (DNAME(3) .EQ. DTIME(IP)) GOTO 140 - 130 CONTINUE -C -C Infer the period from the row or column name -C - DBLOCK = DNAME(2) - IF (DBLOCK .EQ. NAMES(1)) DBLOCK = DNAME(1) - DO 138 IP=1,NPER - DO 138 J=1,NCOL(IP) - IF (DBLOCK .EQ. NAMES(KNAMES(IP)+J)) GOTO 140 - 138 CONTINUE - GOTO 9875 -C -C First realization or repeat? -C - 140 CONTINUE - IF (DNAME(1) .EQ. DCOL .AND. DNAME(2) .EQ. DROW .AND. - * IP .EQ. IIPER) GOTO 160 - IF (IP .LT. IIPER) GOTO 9850 - DCOL = DNAME(1) - DROW = DNAME(2) - PROB1 = ATEMP2 - JNODES = JNODES * NREALS - NREALS = 1 - IIPER = IP - NCURR = IRNGE0(IP) - IF (NECHO .GE. 2 .AND. NECHO .LE. 4) - * WRITE (IOLOG, 1700) NREC,NREALS,DROW,DCOL - IF (NECHO .GE. 5) WRITE (IOLOG, 1300) NREC,Q1,Q2,Q3, - * Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2,NREALS - 150 CONTINUE - PROB(NCURR) = PROB(NCURR) * ATEMP2 - NCURR = IABS(IBROTH(NCURR)) - IF (NCURR .GT. 0) GOTO 150 - GOTO 300 -C -C ANOTHER REALIZATION OF AN ELEMENT DETECTED BEFORE -C - 160 CONTINUE - NREALS = NREALS + 1 - NREF = IRNGE0(IP) - NMTX = IP - IF (MARKOV .AND. IP .GT. 2) NMTX = 2 - IF (NECHO .GE. 2 .AND. NECHO .LE. 4) - * WRITE (IOLOG, 1800) NREC,NREALS - IF (NECHO .GE. 5) WRITE (IOLOG, 1300) NREC,Q1,Q2,Q3,Q4, - * DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2,NREALS -C -C Duplicate all the nodes existing in the current period -C - IF (NODES + JNODES .GT. MXNODE) GOTO 9100 - DO 220 I=1,JNODES - REFPRB = PROB(NREF) - NCURR = NODES + I - PROB(NCURR) = REFPRB * ATEMP2 / PROB1 - KROW(NCURR) = KROW(NCURR-1) + NROW(NCURR-1) - KCOL(NCURR) = KCOL(NCURR-1) + NCOL(NCURR-1) + 1 - KNAMES(NCURR) = KNAMES(NREF) - KBOUND(NCURR) = KBOUND(NREF) - KCOST(NCURR) = KCOST(NREF) - KDATA(NCURR) = LASTD - KRHS(NCURR) = KRHS(NREF) - NROW(NCURR) = NROW(IP) - NCOL(NCURR) = NCOL(IP) - NTH(NCURR) = NTH(IP) - NCUT(NCURR) = NCUT(IP) -C - IF (NREALS .LE. 2) GOTO 180 - DO 170 J=1,NREALS-2 - NREF = IABS(IBROTH(NREF)) - 170 CONTINUE - 180 CONTINUE - IANCTR(NCURR) = IANCTR(NREF) - IBROTH(NCURR) = IBROTH(NREF) - IBROTH(NREF) = NCURR - NREF = IABS(IBROTH(NCURR)) -C - NROWS = NROW(NCURR) - NCOLS = NCOL(NCURR) - ICOL = KCOL(NCURR) - IROW = KROW(NCURR) - LASTD = LASTD + NMTX - KDATC = KDATA(NCURR) - KDATI = KDATA(IP) - DO 190 IMTX=1,NMTX - KCOLA(KDATC+IMTX) = KCOLA(KDATI+IMTX) - KELMA(KDATC+IMTX) = KELMA(KDATI+IMTX) - NELMA(KDATC+IMTX) = NELMA(KDATI+IMTX) - 190 CONTINUE - DO 200 J=1,NROWS - JH(IROW+J) = ICOL + J - KINBAS(ICOL+J) = IROW + J - 200 CONTINUE - DO 210 J=NROWS+1,NCOLS+1 - KINBAS(ICOL+J) = 0 - 210 CONTINUE - 220 CONTINUE - NODES = NODES + JNODES - IRNGE2(IP) = NODES -C -C Now duplicate the rest of the tree as well -C - DO 290 JP=IP+1,NPER - NREF = IRNGE0(JP) - NMTX = JP - IF (MARKOV .AND. JP .GT. 2) NMTX = 2 - IF (NODES + JNODES .GT. MXNODE) GOTO 9100 - DO 280 I=1,JNODES - NCURR = NODES + I - PROB(NCURR) = 1.0 - KROW(NCURR) = KROW(NCURR-1) + NROW(NCURR-1) - KCOL(NCURR) = KCOL(NCURR-1) + NCOL(NCURR-1) + 1 - KNAMES(NCURR) = KNAMES(NREF) - KBOUND(NCURR) = KBOUND(NREF) - KCOST(NCURR) = KCOST(NREF) - KDATA(NCURR) = LASTD - KRHS(NCURR) = KRHS(NREF) - NROW(NCURR) = NROW(JP) - NCOL(NCURR) = NCOL(JP) - NTH(NCURR) = NTH(JP) - NCUT(NCURR) = NCUT(JP) -C - IF (NREALS .LE. 2) GOTO 240 - DO 230 J=1,NREALS-2 - NREF = IABS(IBROTH(NREF)) - 230 CONTINUE - 240 CONTINUE - NPREV = NCURR - JNODES - IANCTR(NCURR) = NPREV - IDESC(NPREV) = NCURR - IBROTH(NCURR) = IBROTH(NREF) - IBROTH(NREF) = -NCURR - NREF = IABS(IBROTH(NCURR)) -C - NROWS = NROW(NCURR) - NCOLS = NCOL(NCURR) - ICOL = KCOL(NCURR) - IROW = KROW(NCURR) - LASTD = LASTD + NMTX - KDATC = KDATA(NCURR) - KDATI = KDATA(JP) - DO 250 IMTX=1,NMTX - KCOLA(KDATC+IMTX) = KCOLA(KDATI+IMTX) - KELMA(KDATC+IMTX) = KELMA(KDATI+IMTX) - NELMA(KDATC+IMTX) = NELMA(KDATI+IMTX) - 250 CONTINUE - DO 260 J=1,NROWS - JH(IROW+J) = ICOL + J - KINBAS(ICOL+J) = IROW + J - 260 CONTINUE - DO 270 J=NROWS+1,NCOLS+1 - KINBAS(ICOL+J) = 0 - 270 CONTINUE - 280 CONTINUE - NODES = NODES + JNODES - IRNGE2(JP) = NODES - 290 CONTINUE -C -C FIRST DETERMINE THE TYPE AND PERIOD OF THE RANDOM ELEMENT BY LOOKING -C AT THE ROW NAME - THIS WORKS UNLESS IT IS A COST COEFFICIENT -C - 300 CONTINUE - IF (DROW .EQ. NAMES(1)) GOTO 400 - DO 310 LP=IP,NPER - DO 310 LROW=1,NCOL(LP) - IF (DROW .EQ. NAMES(KNAMES(LP)+LROW)) GOTO 330 - 310 CONTINUE -C - DO 320 I=1,NROW(1) - IF (DROW .EQ. NAMES(I) .AND. IROTYP(I) .EQ. 2) - * GOTO 890 - 320 CONTINUE - GOTO 9875 -C - 330 CONTINUE - IF (DCOL .EQ. DBOUND ) GOTO 600 - IF (DCOL .EQ. DRANGE ) GOTO 610 - IF (DCOL .EQ. DXI ) GOTO 500 - DO 350 JMTX=1,LP - IF (MARKOV .AND. JMTX .GE. 3) GOTO 360 - JP = LP + 1 - JMTX - JNAME = KNAMES(JP) + NROW(JP) - DO 340 LCOL=1,NCOL(JP)-NROW(JP) - IF (DCOL .EQ. NAMES(JNAME+LCOL)) GOTO 700 - 340 CONTINUE - 350 CONTINUE -C - 360 CONTINUE - LROWS = NROW(1) - DO 370 I=1,LROWS - IF (DROW .EQ. NAMES(I) .AND. IROTYP(I) .EQ. 2) - * GOTO 890 - 370 CONTINUE - GOTO 9875 -C -C HERE WE HAVE A RANDOM COST COEFFICIENT. COPY INFO IF NECESSARY -C FIRST WE HAVE TO DETERMINE THE PERIOD -C - 400 CONTINUE - DO 410 LP=IP,NPER - JNAME = KNAMES(LP) + NROW(LP) - DO 410 LPOSC=1,NCOL(LP)-NROW(LP) - IF (DCOL .EQ. NAMES(JNAME+LPOSC)) GOTO 420 - 410 CONTINUE - WRITE (IOLOG, 1100) NREC,Q1,Q2,Q3,Q4,DNAME(1), - * DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 2100) DCOL - GOTO 9999 -C - 420 CONTINUE - IF (NREALS .GT. 1) GOTO 440 - NREF = IRNGE0(LP) - DO 430 I=1,JNODES - COST(KCOST(NREF)+LPOSC) = ATEMP1 - NREF = IABS(IBROTH(NREF)) - 430 CONTINUE - GOTO 890 -C - 440 CONTINUE - NODE0 = NODES - JNODES*(NPER+1-LP) - IF (KCOST(NODE0+1) .NE. KCOST(IRNGE0(LP))) GOTO 480 -C -C Copy the cost coefficients -C - NREF = IRNGE0(LP) - NCPD = 0 - DO 470 I=1,JNODES - DO 450 JC=1,NCPD - IF (KCOST(NREF) .NE. LOC1(JC)) GOTO 450 - KCOST(NODE0+I) = LOC2(JC) - GOTO 465 - 450 CONTINUE - NCPD = NCPD + 1 - LOC1(NCPD) = KCOST(NREF) - LOC2(NCPD) = LASTC - KCOST(NODE0+I) = LASTC - KCREF = KCOST(NREF) - NCOEFF = NCOL(LP) - NROW(LP) - IF (LASTC + NCOEFF .GT. MXCOST) GOTO 9200 - DO 460 JCOEF=1,NCOEFF - COST(LASTC+JCOEF) = COST(KCREF+JCOEF) - 460 CONTINUE - COST(LASTC+LPOSC) = ATEMP1 - LASTC = LASTC + NCOEFF - 465 CONTINUE - NREF = IABS(IBROTH(NREF)) - IF (NREF .LT. NODE0) GOTO 465 - NREF = IABS(IBROTH(NREF)) - 470 CONTINUE - GOTO 890 -C - 480 CONTINUE - NREF = IRNGE0(LP) - DO 490 I=1,JNODES - COST(KCOST(NODE0+I)+LPOSC) = ATEMP1 - 490 CONTINUE - GOTO 890 -C -C HERE WE HAVE A RANDOM RHS -C - 500 CONTINUE - IF (NREALS .GT. 1) GOTO 540 - NREF = IRNGE0(LP) - DO 530 I=1,JNODES - XI(KRHS(NREF)+LROW) = ATEMP1 - NREF = IABS(IBROTH(NREF)) - 530 CONTINUE - GOTO 890 -C - 540 CONTINUE - NODE0 = NODES - JNODES*(NPER+1-LP) - IF (KRHS(NODE0+1) .NE. KRHS(IRNGE0(LP))) GOTO 580 -C -C Copy the coefficients of the rhs. -C - NREF = IRNGE0(LP) - NCPD = 0 - DO 570 I=1,JNODES - DO 550 JC=1,NCPD - IF (KRHS(NREF) .NE. LOC1(JC)) GOTO 550 - KRHS(NODE0+I) = LOC2(JC) - GOTO 565 - 550 CONTINUE - NCPD = NCPD + 1 - LOC1(NCPD) = KRHS(NREF) - LOC2(NCPD) = LASTR - KRHS(NODE0+I) = LASTR - KCREF = KRHS(NREF) - IF (LASTR + NROW(LP) .GT. MXDRHS) GOTO 9300 - DO 560 JCOEF=1,NROW(LP) - XI(LASTR+JCOEF) = XI(KCREF+JCOEF) - 560 CONTINUE - XI(LASTR+LROW) = ATEMP1 - LASTR = LASTR + NROW(LP) - 565 CONTINUE - NREF = IABS(IBROTH(NREF)) - IF (NREF .LT. NODE0) GOTO 565 - NREF = IABS(IBROTH(NREF)) - 570 CONTINUE - GOTO 890 -C - 580 CONTINUE - NREF = IRNGE0(LP) - DO 590 I=1,JNODES - XI(KRHS(NODE0+I)+LROW) = ATEMP1 - 590 CONTINUE - GOTO 890 -C -C RANDOM BOUND ON A DECISION VARIABLE -C - 600 CONTINUE - JL = 0 - JU = 0 - IF (LROW .LE. NROW(IP)) GOTO 9060 - IF (Q3 .EQ. QP .OR. Q3 .EQ. QX) JU = 1 - IF (Q3 .EQ. QP .OR. Q3 .EQ. QX) TMPU = ATEMP1 - IF (Q3 .EQ. QO .OR. Q3 .EQ. QX) JL = 1 - IF (Q3 .EQ. QO .OR. Q3 .EQ. QX) TMPL = ATEMP1 - IF (Q3 .EQ. QR .OR. Q3 .EQ. QL) JU = 1 - IF (Q3 .EQ. QR .OR. Q3 .EQ. QL) TMPU = PLINF - IF (Q3 .EQ. QL .OR. Q3 .EQ. QI) JL = 1 - IF (Q3 .EQ. QL .OR. Q3 .EQ. QI) TMPL = -PLINF - GOTO 620 -C -C STOCHASTIC RANGE FOR ONE OF THE ROWS -C - 610 CONTINUE - JL = 0 - JU = 0 - IT = IROTYP(KRHS(IP) + LROW) - IF (IT .EQ. -1) GOTO 617 - IF (IT .EQ. 1) GOTO 616 - IF (IT .NE. 0) GOTO 9070 - IF (ATEMP1 .GT. 0.0) GOTO 615 - JL = 1 - TMPL = ATEMP1 - GOTO 620 - 615 CONTINUE - JU = 1 - TMPU = ATEMP1 - GOTO 620 - 616 CONTINUE - JU = 1 - TMPU = DABS(ATEMP1) - GOTO 620 - 617 CONTINUE - JL = 1 - TMPL = -DABS(ATEMP1) -C -C Store the coefficients in arrays XLB and XUB. -C - 620 CONTINUE - IF (NREALS .GT. 1) GOTO 640 - NREF = IRNGE0(LP) - DO 630 I=1,JNODES - IF (JL .EQ. 1) XLB(KBOUND(NREF)+LROW) = TMPL - IF (JU .EQ. 1) XUB(KBOUND(NREF)+LROW) = TMPU - NREF = IABS(IBROTH(NREF)) - 630 CONTINUE - GOTO 890 -C - 640 CONTINUE - NODE0 = NODES - JNODES*(NPER+1-LP) - IF (KBOUND(NODE0+1) .NE. KBOUND(IRNGE0(LP))) - * GOTO 680 -C -C Copy the bounds. -C - NREF = IRNGE0(LP) - NCPD = 0 - DO 670 I=1,JNODES - DO 650 JC=1,NCPD - IF (KBOUND(NREF) .NE. LOC1(JC)) GOTO 650 - KBOUND(NODE0+I) = LOC2(JC) - GOTO 665 - 650 CONTINUE - NCPD = NCPD + 1 - LOC1(NCPD) = KBOUND(NREF) - LOC2(NCPD) = LASTBD - KBOUND(NODE0+I) = LASTBD - KCREF = KBOUND(NREF) - NCOEFF = NCOL(LP) + 1 - IF (LASTBD + NCOEFF .GT. MXBNDS) GOTO 9400 - DO 660 JCOEF=1,NCOEFF - XLB(LASTBD+JCOEF) = XLB(KCREF+JCOEF) - XLB(LASTBD+JCOEF) = XLB(KCREF+JCOEF) - 660 CONTINUE - IF (JL .EQ. 1) XLB(LASTBD+LROW) = TMPL - IF (JU .EQ. 1) XUB(LASTBD+LROW) = TMPU - LASTBD = LASTBD + NCOEFF - 665 CONTINUE - NREF = IABS(IBROTH(NREF)) - IF (NREF .LT. NODE0) GOTO 665 - NREF = IABS(IBROTH(NREF)) - 670 CONTINUE - GOTO 890 -C - 680 CONTINUE - NREF = IRNGE0(LP) - DO 690 I=1,JNODES - IF (JL .EQ. 1) XLB(KBOUND(NODE0+I)+LROW) = TMPL - IF (JU .EQ. 1) XUB(KBOUND(NODE0+I)+LROW) = TMPU - 690 CONTINUE - GOTO 890 -C -C HERE WE HAVE A RANDOM COEFFICIENT IN THE CONSTRAINT MATRIX -C - 700 CONTINUE - IF (MULTI .EQ. 3) MULTI =1 - STOCHA(LP,JMTX) = .TRUE. - JELMA = KELMA(KDATA(LP)+JMTX) - LL = LA(KCOLA(KDATA(LP)+JMTX)+LCOL) - KK = LA(KCOLA(KDATA(LP)+JMTX)+LCOL+1) - 1 - DO 710 LPOSA=LL,KK - IF (IA(JELMA+LPOSA) .EQ. LROW) GOTO 720 - 710 CONTINUE - WRITE (IOLOG, 1100) NREC,Q1,Q2,Q3,Q4,DNAME(1), - * DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 2200) - GOTO 9999 -C - 720 CONTINUE - IF (NREALS .GT. 1) GOTO 740 - NREF = IRNGE0(LP) - DO 730 I=1,JNODES - A(KELMA(KDATA(NREF)+JMTX)+LPOSA) = ATEMP1 - NREF = IABS(IBROTH(NREF)) - 730 CONTINUE - GOTO 890 -C - 740 CONTINUE - NODE0 = NODES - JNODES*(NPER+1-LP) - IAREF = KDATA(IRNGE0(LP)) + JMTX - IACUR = KDATA(NODE0+1) + JMTX - IF (KELMA(IACUR) .NE. KELMA(IAREF)) GOTO 780 -C -C Copy the A coefficients -C - NREF = IRNGE0(LP) - NCPD = 0 - DO 770 I=1,JNODES - DO 750 JC=1,NCPD - IAREF = KDATA(NREF) + JMTX - IF (KELMA(IAREF) .NE. LOC1(JC)) GOTO 750 - KELMA(KDATA(NODE0+I)+JMTX) = LOC2(JC) - GOTO 765 - 750 CONTINUE - NCPD = NCPD + 1 - LOC1(NCPD) = KELMA(KDATA(NREF)+JMTX) - LOC2(NCPD) = LASTA - KELMA(KDATA(NODE0+I)+JMTX) = LASTA - KCREF = KELMA(KDATA(NREF)+JMTX) - NELMS = NELMA(KDATA(NREF)+JMTX) - IF (LASTA + NELMS .GT. MXALMN) GOTO 9500 - IF ( LASTBL .GE. MXABLK) GOTO 9550 - LASTBL = LASTBL + 1 - DO 760 JCOEF=1,NELMS - A(LASTA+JCOEF) = A(KCREF+JCOEF) - IA(LASTA+JCOEF) = IA(KCREF+JCOEF) - 760 CONTINUE - A(LASTA+LPOSA) = ATEMP1 - LASTA = LASTA + NELMS - 765 CONTINUE - NREF = IABS(IBROTH(NREF)) - IF (NREF .LT. NODE0) GOTO 765 - NREF = IABS(IBROTH(NREF)) - 770 CONTINUE - GOTO 890 -C - 780 CONTINUE - NREF = IRNGE0(LP) - DO 790 I=1,JNODES - A(KELMA(KDATA(NODE0+I)+JMTX)+LPOSA) = ATEMP1 - 790 CONTINUE -C -C ONLY ONE ELEMENT PER RECORD. GET THE NEXT CASE. -C - 890 CONTINUE - GOTO 100 -C -C Have found an ENDATA card -C - 900 CONTINUE - JNODES = JNODES * NREALS - IF (NECHO .GE. 2) WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1) - RETURN -C - 910 CONTINUE - JNODES = JNODES * NREALS - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1200) - RETURN -C -C COME HERE IF ANYTHING WENT WRONG -C - 9060 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3060) - GOTO 9999 -C - 9070 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3070) - GOTO 9999 -C - 9100 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3100) MXNODE - GOTO 9999 -C - 9200 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3200) MXCOST - GOTO 9999 -C - 9300 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3300) MXDRHS - GOTO 9999 -C - 9400 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3400) MXBNDS - GOTO 9999 -C - 9500 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3500) MXALMN - GOTO 9999 -C - 9550 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3550) MXABLK - GOTO 9999 -C - 9850 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3850) - GOTO 9999 -C - 9875 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3875) - GOTO 9999 -C - 9990 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3990) - 9999 CONTINUE - CALL STOPIT -C - 1000 FORMAT(4A1,A8,2X,A8,2X,F12.4,3X,A8,2X,F12.4) - 1100 FORMAT(I8,4X,4A1,A8,2X,A8,2X,F12.4,3X,A8,2X,F12.4) - 1200 FORMAT(' XXX - WARNING - Missing ENDATA card') - 1300 FORMAT(I8,4X,4A1,A8,2X,A8,2X,F12.4,3X,A8,2X,F12.4, - * ': Realization',I4) - 1600 FORMAT(' XXX - FATAL - Illegal header card in STOCH file') - 1700 FORMAT(I8,4X,' Found realization number',I4,' in location ',A8, - * ' - ',A8) - 1800 FORMAT(I8,4X,' Found realization number',I4) - 2100 FORMAT(' XXX - FATAL - Column name ',A8,' not matched') - 2200 FORMAT(' XXX - FATAL - Location of random element undefined') - 3060 FORMAT(' XXX - FATAL - Attempt to set explicit bound on logical', - * ' variable') - 3070 FORMAT(' XXX - FATAL - Illegal row type in stochastic RANGES', - * ' section') - 3100 FORMAT(' XXX - FATAL - More than ',I6,' nodes in the tree.', - * ' Increase parameter MXNODE.') - 3200 FORMAT(' XXX - FATAL - More than ',I6,' cost coefficients.', - * ' Increase parameter MXCOST.') - 3300 FORMAT(' XXX - FATAL - More than ',I6,' right hand sides.', - * ' Increase parameter MXDRHS.') - 3400 FORMAT(' XXX - FATAL - More than ',I6,' stochastic bounds.', - * ' Increase parameter MXBNDS.') - 3500 FORMAT(' XXX - FATAL - More than ',I6,' constraint elements.', - * ' Increase parameter MXALMN.') - 3550 FORMAT(' XXX - FATAL - More than ',I6,' blocks in A-matrix.', - * ' Increase parameter MXABLK.') - 3850 FORMAT(' XXX - FATAL - Chronological order violated for random', - * ' elements') - 3875 FORMAT(' XXX - FATAL - Illegal type of random element') - 3990 FORMAT(' XXX - FATAL - Error while reading STOCH_FILE') - END -C -C ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -C - SUBROUTINE INSCEN (IROTYP, IIPER, IPER0, JNODES, NREC) -C -C Subroutine to input stoch file in SCENARIO format -C -C --------------------------- -C Version of 14 June 1989 -C --------------------------- -C - include 'common6.for' -C - CHARACTER*8 DNAME(3), DBLANK, DROW, DCOL, DSCNAM(MXNODE) - DIMENSION IROTYP(MXBNDS), LNODE(MXNODE), KREF(MXTPER) - EQUIVALENCE (DSCNAM,X), (LNODE,IE) -C - DATA DBLANK/' '/ -C - DROW = DBLANK - DCOL = DBLANK - QTYP = QBL - NODES = NPER - IIPER = 1 - IPER0 = NPER - PROB(1) = 1.0 - NSCEN = 0 -C - 100 CONTINUE - READ (IOSTO, 1000, ERR=105, END=910) - * Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - NREC = NREC + 1 - IF (Q1 .EQ. QAST) GOTO 100 - IF (Q1 .EQ. QE ) GOTO 900 - IF (Q1 .EQ. QBL ) GOTO 110 - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1600) - GOTO 9999 -C - 105 CONTINUE - IF (Q1 .NE. QAST) GOTO 9990 - NREC = NREC + 1 - GOTO 100 -C - 110 CONTINUE - IF (Q2 .EQ. QS .AND. Q3 .EQ. QC) GOTO 120 - IF (NECHO .GE. 5) WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - DCOL = DNAME(1) - DROW = DNAME(2) - QTYP = Q3 - GOTO 300 -C -C SET UP PROBABILITIES -C - 120 CONTINUE - IF (NECHO .GE. 2) WRITE (IOLOG, 1800) NREC,DNAME(1) - IF (NSCEN .GT. 0) GOTO 140 - DO 130 I=1,NPER - PROB(I) = ATEMP1 - 130 CONTINUE - NSCEN = NSCEN + 1 - DSCNAM(NSCEN) = DNAME(1) - LNODE(NSCEN) = NPER - GOTO 100 -C -C THIS IS NOT SCENARIO 1, FIND THE SCENARIO IT BRANCHES FROM -C - 140 CONTINUE - DO 150 I=1,NSCEN - IF (DNAME(2) .EQ. DSCNAM(I)) GOTO 200 - 150 CONTINUE - WRITE (IOLOG, 1100) NREC, Q1,Q2,Q3,Q4,DNAME(1), - * DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 2000) - GOTO 9999 -C -C GOT IT. -C - 200 CONTINUE - NSCEN = NSCEN + 1 - DSCNAM(NSCEN) = DNAME(1) - LNODE(NSCEN) = NODES + 1 - LASTN = LNODE(I) - IP = NPER - 210 CONTINUE - IF (NODES .GE. MXNODE) GOTO 9100 - NMTX = IP - IF (MARKOV .AND. IP .GT. 2) NMTX = 2 - KREF(IP) = LASTN - NODES = NODES + 1 - IBROTH(NODES) = 0 - IF (IP .EQ. NPER) IDESC(NODES) = 0 - IF (IP .LT. NPER) IDESC(NODES) = NODES - 1 - IF (IP .LT. NPER) IANCTR(NODES-1) = NODES - IRNGE2(IP) = NODES - KROW(NODES) = KROW(NODES-1) + NROW(NODES-1) - KCOL(NODES) = KCOL(NODES-1) + NCOL(NODES-1) + 1 - KCOST(NODES) = KCOST(LASTN) - KDATA(NODES) = LASTD - KBOUND(NODES) = KBOUND(LASTN) - KNAMES(NODES) = KNAMES(LASTN) - KRHS(NODES) = KRHS(LASTN) - NROW(NODES) = NROW(LASTN) - NCOL(NODES) = NCOL(LASTN) - NCUT(NODES) = NCUT(LASTN) - NTH(NODES) = NTH(LASTN) - PROB(NODES) = ATEMP1 -C - NROWS = NROW(NODES) - NCOLS = NCOL(NODES) - IROW = KROW(NODES) - ICOL = KCOL(NODES) - LASTD = LASTD + NMTX - KDATC = KDATA(NODES) - KDATI = KDATA(IP) - DO 220 IMTX=1,NMTX - KCOLA(KDATC+IMTX) = KCOLA(KDATI+IMTX) - KELMA(KDATC+IMTX) = KELMA(KDATI+IMTX) - NELMA(KDATC+IMTX) = NELMA(KDATI+IMTX) - 220 CONTINUE - DO 230 I=1,NROWS - KINBAS(ICOL+I) = IROW + I - JH(IROW+I) = ICOL + I - 230 CONTINUE - DO 240 I=NROWS+1,NCOLS+1 - KINBAS(ICOL+I) = 0 - 240 CONTINUE - IF (DTIME(IP) .EQ. DNAME(3)) GOTO 250 - IF (IP .EQ. 1) GOTO 9040 - IP = IP - 1 - LASTN = IANCTR(LASTN) - GOTO 210 -C - 250 CONTINUE - IANCTR(NODES) = IANCTR(LASTN) - IIPER = IP - IBRO1 = LASTN - 260 CONTINUE - IF (IBROTH(IBRO1) .EQ. 0) GOTO 270 - IBRO1 = IBROTH(IBRO1) - GOTO 260 -C -C FIX THE PROBABILITIES -C - 270 CONTINUE - IBROTH(IBRO1) = NODES - 280 CONTINUE - LASTN = IANCTR(LASTN) - IF (LASTN .EQ. 0) GOTO 100 - PROB(LASTN) = PROB(LASTN) + ATEMP1 - GOTO 280 -C -C FIRST DETERMINE THE PERIOD BY LOOKING AT THE ROW NAME -C (This works unless the random element is a cost coefficient.) -C - 300 CONTINUE - IF (DROW .EQ. NAMES(1)) GOTO 400 - DO 310 IP=IIPER,NPER - DO 310 LROW=1,NCOL(IP) - IF (DROW .EQ. NAMES(KNAMES(IP)+LROW)) GOTO 330 - 310 CONTINUE -C - DO 320 II=1,NROW(1) - IF (DROW .EQ. NAMES(I) .AND. IROTYP(I) .EQ. 2) - * GOTO 890 - 320 CONTINUE - WRITE (IOLOG, 1100) NREC,Q1,Q2,Q3,Q4,DNAME(1), - * DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1900) - GOTO 9999 -C - 330 CONTINUE - NCURR = NODES + IIPER - IP - IF (NSCEN .EQ. 1) NCURR = IP - IF (IPER0 .GT. IP) IPER0 = IP - IF (DCOL .EQ. DBOUND ) GOTO 600 - IF (DCOL .EQ. DRANGE ) GOTO 610 - IF (DCOL .EQ. DXI ) GOTO 500 - DO 350 JMTX=1,IP - IF (MARKOV .AND. JMTX .GE. 3) GOTO 360 - JP = IP + 1 - JMTX - JNAMES = KNAMES(JP) - DO 340 I=NROW(JP)+1,NCOL(JP) - IF (DCOL .EQ. NAMES(JNAMES+I)) GOTO 700 - 340 CONTINUE - 350 CONTINUE -C - 360 CONTINUE - LROWS = NROW(1) - DO 370 I=1,LROWS - IF (DROW .EQ. NAMES(I) .AND. IROTYP(I) .EQ. 2) - * GOTO 890 - 370 CONTINUE - WRITE (IOLOG, 1100) NREC,Q1,Q2,Q3,Q4,DNAME(1), - * DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1900) - GOTO 9999 -C -C HERE WE HAVE A RANDOM COST COEFFICIENT. COPY INFO IF NECESSARY. -C First we have to determine the period. -C - 400 CONTINUE - DO 410 IP=IIPER,NPER - DO 410 I=NROW(IP)+1,NCOL(IP) - IF (DCOL .EQ. NAMES(KNAMES(IP)+I)) - * GOTO 420 - 410 CONTINUE - WRITE (IOLOG, 1100) NREC,Q1,Q2,Q3,Q4,DNAME(1), - * DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG,2100) DCOL - GOTO 9999 -C - 420 CONTINUE - LPOSC = I - NROW(IP) - IF (NSCEN .EQ. 1) GOTO 440 - NREF = KREF(IP) - NCURR = NODES + IIPER - IP - IF (KCOST(NCURR) .NE. KCOST(NREF)) GOTO 440 - NCOEFF = NCOL(IP)-NROW(IP) - IF (LASTC + NCOEFF .GT. MXCOST) GOTO 9200 - DO 430 J=1,NCOEFF - COST(LASTC+J) = COST(KCOST(NREF)+J) - 430 CONTINUE - COST(LASTC+LPOSC) = ATEMP1 - KCOST(NCURR) = LASTC - LASTC = LASTC + NCOEFF - GOTO 890 -C - 440 CONTINUE - COST(KCOST(NCURR)+LPOSC) = ATEMP1 - GOTO 890 -C -C HERE WE HAVE A RANDOM RHS -C - 500 CONTINUE - IF (NSCEN .EQ. 1) GOTO 520 - NREF = KREF(IP) - NCURR = NODES + IIPER - IP - IF (KRHS(NCURR) .NE. KRHS(NREF)) GOTO 520 - IF (LASTR + NROW(IP) .GT. MXDRHS) GOTO 9300 - DO 510 J=1,NROW(IP) - XI(LASTR+J) = XI(KRHS(NREF)+J) - 510 CONTINUE - XI(LASTR+LROW) = ATEMP1 - KRHS(NCURR) = LASTR - LASTR = LASTR + NROW(IP) - GOTO 890 -C - 520 CONTINUE - XI(KRHS(NCURR)+LROW) = ATEMP1 - GOTO 890 -C -C RANDOM BOUND ON A DECISION VARIABLE -C - 600 CONTINUE - JL = 0 - JU = 0 - IF (LROW .LE. NROW(IP)) GOTO 9060 - IF (QTYP .EQ. QP .OR. QTYP .EQ. QX) JU = 1 - IF (QTYP .EQ. QP .OR. QTYP .EQ. QX) TMPU = ATEMP1 - IF (QTYP .EQ. QO .OR. QTYP .EQ. QX) JL = 1 - IF (QTYP .EQ. QO .OR. QTYP .EQ. QX) TMPL = ATEMP1 - IF (QTYP .EQ. QR .OR. QTYP .EQ. QL) JU = 1 - IF (QTYP .EQ. QR .OR. QTYP .EQ. QL) TMPU = PLINF - IF (QTYP .EQ. QL .OR. QTYP .EQ. QI) JL = 1 - IF (QTYP .EQ. QL .OR. QTYP .EQ. QI) TMPL = -PLINF - GOTO 650 -C -C STOCHASTIC RANGE FOR ONE OF THE ROWS -C - 610 CONTINUE - JL = 0 - JU = 0 - IT = IROTYP(KRHS(IP) + LROW) - IF (IT .EQ. -1) GOTO 640 - IF (IT .EQ. 1) GOTO 630 - IF (IT .NE. 0) GOTO 9070 - IF (ATEMP1 .GT. 0.0) GOTO 620 - JL = 1 - TMPL = ATEMP1 - GOTO 650 - 620 CONTINUE - JU = 1 - TMPU = ATEMP1 - GOTO 650 - 630 CONTINUE - JU = 1 - TMPU = DABS(ATEMP1) - GOTO 650 - 640 CONTINUE - JL = 1 - TMPL = -DABS(ATEMP1) -C -C Store information -- same code for BOUNDS and RANGES -C - 650 CONTINUE - IF (NSCEN .EQ. 1) GOTO 670 - NREF = KREF(IP) - NCURR = NODES + IIPER - IP - IF (KBOUND(NCURR) .NE. KBOUND(NREF)) GOTO 670 - IF ( LASTBD + NCOL(IP) .GT. MXBNDS ) GOTO 9400 - DO 660 J=1,NCOL(IP) - XLB(LASTBD+J) = XLB(KBOUND(NREF)+J) - XUB(LASTBD+J) = XUB(KBOUND(NREF)+J) - 660 CONTINUE - IF (JL .EQ. 1) XLB(LASTBD+LROW) = TMPL - IF (JU .EQ. 1) XUB(LASTBD+LROW) = TMPU - GOTO 680 -C - 670 CONTINUE - IF (JL .EQ. 1) XLB(KBOUND(NCURR)+LROW) = TMPL - IF (JU .EQ. 1) XUB(KBOUND(NCURR)+LROW) = TMPU - 680 CONTINUE - IF (LROW .GT. NROW(IP)) GOTO 100 - GOTO 890 -C -C HERE WE HAVE A RANDOM COEFFICIENT IN THE CONSTRAINT MATRIX -C - 700 CONTINUE - IF (MULTI .EQ. 3) MULTI = 1 - STOCHA(IP,JMTX) = .TRUE. - LCOL = I - NROW(JP) - JELMA = KELMA(KDATA(IP)+JMTX) - LL = LA(KCOLA(KDATA(IP)+JMTX)+LCOL) - KK = LA(KCOLA(KDATA(IP)+JMTX)+LCOL+1) - 1 - DO 710 I=LL,KK - IF (IA(JELMA+I) .EQ. LROW) GOTO 720 - 710 CONTINUE - WRITE (IOLOG, 1100) NREC,Q1,Q2,Q3,Q4,DNAME(1), - * DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 2200) - GOTO 9999 -C - 720 CONTINUE - LPOSA = I - IF (NSCEN .EQ. 1) GOTO 740 - NREF = KREF(IP) - NCURR = NODES + IIPER - IP - LMREF = KELMA(KDATA(NREF)+JMTX) - IF (KELMA(KDATA(NCURR)+JMTX) .NE. LMREF) GOTO 740 - NELMS = NELMA(KDATA(IP)+JMTX) - IF (LASTA + NELMS .GT. MXALMN) GOTO 9500 - IF ( LASTBL .GE. MXABLK) GOTO 9550 - LASTBL = LASTBL + 1 - DO 730 J=1,NELMS - A(LASTA+J) = A(LMREF+J) - IA(LASTA+J) = IA(LMREF+J) - 730 CONTINUE - A(LASTA+LPOSA) = ATEMP1 - KELMA(KDATA(NCURR)+JMTX) = LASTA - LASTA = LASTA + NELMS - GOTO 890 -C - 740 CONTINUE - A(KELMA(KDATA(NCURR)+JMTX)+LPOSA) = ATEMP1 - GOTO 890 -C -C THE THIRD NAME FIELD MIGHT CONTAIN MORE INFORMATION -C - 890 CONTINUE - IF (DNAME(3) .EQ. DBLANK) GOTO 100 - DROW = DNAME(3) - DNAME(3) = DBLANK - ATEMP1 = ATEMP2 - GOTO 300 -C -C END OF STOCH FILE -C - 900 CONTINUE - IF (NECHO .GE. 2) WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1) - RETURN -C - 910 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 1200) - RETURN -C -C COME HERE IF ANYTHING WENT WRONG -C - 9040 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3040) - GOTO 9999 -C - 9060 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3060) - GOTO 9999 -C - 9070 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3070) - GOTO 9999 -C - 9100 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3100) MXNODE - GOTO 9999 -C - 9200 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3200) MXCOST - GOTO 9999 -C - 9300 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3300) MXDRHS - GOTO 9999 -C - 9400 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3400) MXBNDS - GOTO 9999 -C - 9500 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3500) MXALMN - GOTO 9999 -C - 9550 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3550) MXABLK - GOTO 9999 -C - 9990 CONTINUE - WRITE (IOLOG, 1100) - * NREC,Q1,Q2,Q3,Q4,DNAME(1),DNAME(2),ATEMP1,DNAME(3),ATEMP2 - WRITE (IOLOG, 3990) - 9999 CONTINUE - CALL STOPIT -C - 1000 FORMAT(4A1,A8,2X,A8,2X,F12.4,3X,A8,2X,F12.4) - 1100 FORMAT(I8,4X,4A1,A8,2X,A8,2X,F12.4,3X,A8,2X,F12.4) - 1200 FORMAT(' XXX - WARNING - Missing ENDATA card') - 1600 FORMAT(' XXX - FATAL - Illegal header card in STOCH file') - 1800 FORMAT(I8,4X,' Found scenario ',A8) - 1900 FORMAT(' XXX - FATAL - Illegal type of random element') - 2000 FORMAT(' XXX - FATAL - Misspecified branch in decision tree') - 2100 FORMAT(' XXX - FATAL - Column name ',A8,' not matched') - 2200 FORMAT(' XXX - FATAL - Location of random element undefined') - 3040 FORMAT(' XXX - FATAL - Period could not be found') - 3060 FORMAT(' XXX - FATAL - Attempt to set explicit bound on logical', - * ' variable') - 3070 FORMAT(' XXX - FATAL - Illegal row type in stochastic RANGES', - * ' section') - 3100 FORMAT(' XXX - FATAL - More than ',I6,' nodes in the tree.', - * ' Increase parameter MXNODE.') - 3200 FORMAT(' XXX - FATAL - More than ',I6,' cost coefficients.', - * ' Increase parameter MXCOST.') - 3300 FORMAT(' XXX - FATAL - More than ',I6,' right hand sides.', - * ' Increase parameter MXDRHS.') - 3400 FORMAT(' XXX - FATAL - More than ',I6,' stochastic bounds.', - * ' Increase parameter MXBNDS.') - 3500 FORMAT(' XXX - FATAL - More than ',I6,' constraint elements.', - * ' Increase parameter MXALMN.') - 3550 FORMAT(' XXX - FATAL - More than ',I6,' blocks in A-matrix.', - * ' Increase parameter MXABLK.') - 3850 FORMAT(' XXX - FATAL - Chronological order violated for random', - * ' elements') - 3875 FORMAT(' XXX - FATAL - Illegal type of random element') - 3990 FORMAT(' XXX - FATAL - Error while reading STOCH_FILE') - END -C -C ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -C - SUBROUTINE INTREE ( IPER0, IERR, NREC ) -C - include 'common6.for' -C - WRITE (IOLOG, 1800) - CALL STOPIT -C - 1800 FORMAT(' This option has not been implemented in the current', - * ' version of MSLiP.',/,/, - * ' Sorry for the inconvenience.') -C - END -C -C ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -C - SUBROUTINE TRIANG(NODE,LMTX) -C -C This subroutine changes from the staircase structure to full -C block-triangular form when invoked from routine INNODE. -C - include 'common6.for' -C - MARKOV = .FALSE. - LDOLD = 0 - LDNEW = 0 -C -C FIRST DETERMINE SPACE REQUIREMENTS FOR POINTER ARRAY KDATA -C - DO 120 I=1,NODES - JNODE=I - IP=1 - 100 CONTINUE - JNODE = IANCTR(JNODE) - IF (JNODE .EQ. 0) GOTO 110 - IP = IP + 1 - GOTO 100 - 110 CONTINUE - LDNEW = LDNEW + IP - LDOLD = LDOLD + MIN0(2,IP) - 120 CONTINUE - LASTD = LDNEW -C -C NOW MOVE KNOWN POINTERS TO THEIR NEW LOCATIONS -C - DO 180 I=1,NODES - INODE = NODES + 1 - I - JNODE = INODE - IP = 1 - 130 CONTINUE - JNODE = IANCTR(JNODE) - IF (JNODE .EQ. 0) GOTO 140 - IP = IP + 1 - GOTO 130 - 140 CONTINUE - LDNEW = LDNEW - IP - NMTX = MIN0(2,IP) - LDOLD = LDOLD - NMTX - KDATA(INODE) = LDNEW - IF (LDOLD .EQ. LDNEW) GOTO 155 - DO 150 K=1,NMTX - INFO1 = LDOLD + NMTX + 1 - K - INFO2 = LDNEW + NMTX + 1 - K - KCOLA(INFO2) = KCOLA(INFO1) - KELMA(INFO2) = KELMA(INFO1) - NELMA(INFO2) = NELMA(INFO1) - KCOLA(INFO1) = 0 - KELMA(INFO1) = 0 - NELMA(INFO1) = 0 - 150 CONTINUE - 155 CONTINUE -