*DECK DPLPUP SUBROUTINE DPLPUP (DUSRMT, MRELAS, NVARS, PRGOPT, DATTRV, BL, BU, + IND, INFO, AMAT, IMAT, SIZEUP, ASMALL, ABIG) C***BEGIN PROLOGUE DPLPUP C***SUBSIDIARY C***PURPOSE Subsidiary to DSPLP C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (SPLPUP-S, DPLPUP-D) C***AUTHOR (UNKNOWN) C***DESCRIPTION C C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. C C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. C /REAL (12 BLANKS)/DOUBLE PRECISION/. C C REVISED 810613-1130 C REVISED YYMMDD-HHMM C C THIS SUBROUTINE COLLECTS INFORMATION ABOUT THE BOUNDS AND MATRIX C FROM THE USER. IT IS PART OF THE DSPLP( ) PACKAGE. C C***SEE ALSO DSPLP C***ROUTINES CALLED DPCHNG, DPNNZR, XERMSG C***REVISION HISTORY (YYMMDD) C 811215 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890605 Corrected references to XERRWV. (WRB) C 890605 Removed unreferenced labels. (WRB) C 891009 Removed unreferenced variables. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900328 Added TYPE section. (WRB) C 900510 Convert XERRWV calls to XERMSG calls, changed do-it-yourself C DO loops to DO loops. (RWC) C 900602 Get rid of ASSIGNed GOTOs. (RWC) C***END PROLOGUE DPLPUP DOUBLE PRECISION ABIG,AIJ,AMAT(*),AMN,AMX,ASMALL,BL(*), * BU(*),DATTRV(*),PRGOPT(*),XVAL,ZERO INTEGER IFLAG(10),IMAT(*),IND(*) LOGICAL SIZEUP,FIRST CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3, XERN4 C C***FIRST EXECUTABLE STATEMENT DPLPUP ZERO = 0.D0 C C CHECK USER-SUPPLIED BOUNDS C C CHECK THAT IND(*) VALUES ARE 1,2,3 OR 4. C ALSO CHECK CONSISTENCY OF UPPER AND LOWER BOUNDS. C DO 10 J=1,NVARS IF (IND(J).LT.1 .OR. IND(J).GT.4) THEN WRITE (XERN1, '(I8)') J CALL XERMSG ('SLATEC', 'DPLPUP', * 'IN DSPLP, INDEPENDENT VARIABLE = ' // XERN1 // * ' IS NOT DEFINED.', 10, 1) INFO = -10 RETURN ENDIF C IF (IND(J).EQ.3) THEN IF (BL(J).GT.BU(J)) THEN WRITE (XERN1, '(I8)') J WRITE (XERN3, '(1PE15.6)') BL(J) WRITE (XERN4, '(1PE15.6)') BU(J) CALL XERMSG ('SLATEC', 'DPLPUP', * 'IN DSPLP, LOWER BOUND = ' // XERN3 // * ' AND UPPER BOUND = ' // XERN4 // * ' FOR INDEPENDENT VARIABLE = ' // XERN1 // * ' ARE NOT CONSISTENT.', 11, 1) RETURN ENDIF ENDIF 10 CONTINUE C DO 20 I=NVARS+1,NVARS+MRELAS IF (IND(I).LT.1 .OR. IND(I).GT.4) THEN WRITE (XERN1, '(I8)') I-NVARS CALL XERMSG ('SLATEC', 'DPLPUP', * 'IN DSPLP, DEPENDENT VARIABLE = ' // XERN1 // * ' IS NOT DEFINED.', 12, 1) INFO = -12 RETURN ENDIF C IF (IND(I).EQ.3) THEN IF (BL(I).GT.BU(I)) THEN WRITE (XERN1, '(I8)') I WRITE (XERN3, '(1PE15.6)') BL(I) WRITE (XERN4, '(1PE15.6)') BU(I) CALL XERMSG ('SLATEC', 'DPLPUP', * 'IN DSPLP, LOWER BOUND = ' // XERN3 // * ' AND UPPER BOUND = ' // XERN4 // * ' FOR DEPENDANT VARIABLE = ' // XERN1 // * ' ARE NOT CONSISTENT.',13,1) INFO = -13 RETURN ENDIF ENDIF 20 CONTINUE C C GET UPDATES OR DATA FOR MATRIX FROM THE USER C C GET THE ELEMENTS OF THE MATRIX FROM THE USER. IT WILL BE STORED C BY COLUMNS USING THE SPARSE STORAGE CODES OF RJ HANSON AND C JA WISNIEWSKI. C IFLAG(1) = 1 C C KEEP ACCEPTING ELEMENTS UNTIL THE USER IS FINISHED GIVING THEM. C LIMIT THIS LOOP TO 2*NVARS*MRELAS ITERATIONS. C ITMAX = 2*NVARS*MRELAS+1 ITCNT = 0 FIRST = .TRUE. C C CHECK ON THE ITERATION COUNT. C 30 ITCNT = ITCNT+1 IF (ITCNT.GT.ITMAX) THEN CALL XERMSG ('SLATEC', 'DPLPUP', + 'IN DSPLP, MORE THAN 2*NVARS*MRELAS ITERATIONS DEFINING ' // + 'OR UPDATING MATRIX DATA.', 7, 1) INFO = -7 RETURN ENDIF C AIJ = ZERO CALL DUSRMT(I,J,AIJ,INDCAT,PRGOPT,DATTRV,IFLAG) IF (IFLAG(1).EQ.1) THEN IFLAG(1) = 2 GO TO 30 ENDIF C C CHECK TO SEE THAT THE SUBSCRIPTS I AND J ARE VALID. C IF (I.LT.1 .OR. I.GT.MRELAS .OR. J.LT.1 .OR. J.GT.NVARS) THEN C C CHECK ON SIZE OF MATRIX DATA C RECORD THE LARGEST AND SMALLEST(IN MAGNITUDE) NONZERO ELEMENTS. C IF (IFLAG(1).EQ.3) THEN IF (SIZEUP .AND. ABS(AIJ).NE.ZERO) THEN IF (FIRST) THEN AMX = ABS(AIJ) AMN = ABS(AIJ) FIRST = .FALSE. ELSEIF (ABS(AIJ).GT.AMX) THEN AMX = ABS(AIJ) ELSEIF (ABS(AIJ).LT.AMN) THEN AMN = ABS(AIJ) ENDIF ENDIF GO TO 40 ENDIF C WRITE (XERN1, '(I8)') I WRITE (XERN2, '(I8)') J CALL XERMSG ('SLATEC', 'DPLPUP', * 'IN DSPLP, ROW INDEX = ' // XERN1 // ' OR COLUMN INDEX = ' * // XERN2 // ' IS OUT OF RANGE.', 8, 1) INFO = -8 RETURN ENDIF C C IF INDCAT=0 THEN SET A(I,J)=AIJ. C IF INDCAT=1 THEN ACCUMULATE ELEMENT, A(I,J)=A(I,J)+AIJ. C IF (INDCAT.EQ.0) THEN CALL DPCHNG(I,AIJ,IPLACE,AMAT,IMAT,J) ELSEIF (INDCAT.EQ.1) THEN INDEX = -(I-1) CALL DPNNZR(INDEX,XVAL,IPLACE,AMAT,IMAT,J) IF (INDEX.EQ.I) AIJ=AIJ+XVAL CALL DPCHNG(I,AIJ,IPLACE,AMAT,IMAT,J) ELSE WRITE (XERN1, '(I8)') INDCAT CALL XERMSG ('SLATEC', 'DPLPUP', * 'IN DSPLP, INDICATION FLAG = ' // XERN1 // * ' FOR MATRIX DATA MUST BE EITHER 0 OR 1.', 9, 1) INFO = -9 RETURN ENDIF C C CHECK ON SIZE OF MATRIX DATA C RECORD THE LARGEST AND SMALLEST(IN MAGNITUDE) NONZERO ELEMENTS. C IF (SIZEUP .AND. ABS(AIJ).NE.ZERO) THEN IF (FIRST) THEN AMX = ABS(AIJ) AMN = ABS(AIJ) FIRST = .FALSE. ELSEIF (ABS(AIJ).GT.AMX) THEN AMX = ABS(AIJ) ELSEIF (ABS(AIJ).LT.AMN) THEN AMN = ABS(AIJ) ENDIF ENDIF IF (IFLAG(1).NE.3) GO TO 30 C 40 IF (SIZEUP .AND. .NOT. FIRST) THEN IF (AMN.LT.ASMALL .OR. AMX.GT.ABIG) THEN CALL XERMSG ('SLATEC', 'DPLPUP', + 'IN DSPLP, A MATRIX ELEMENT''S SIZE IS OUT OF THE ' // + 'SPECIFIED RANGE.', 22, 1) INFO = -22 RETURN ENDIF ENDIF RETURN END