OpenLibm/slatec/dpnnzr.f

*DECK DPNNZR
      SUBROUTINE DPNNZR (I, XVAL, IPLACE, SX, IX, IRCX)
C***BEGIN PROLOGUE  DPNNZR
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (PNNZRS-S, DPNNZR-D)
C***AUTHOR  Hanson, R. J., (SNLA)
C           Wisniewski, J. A., (SNLA)
C***DESCRIPTION
C
C     DPNNZR LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME.
C     SPARSE MATRIX NON ZERO RETRIEVAL SUBROUTINE.
C
C     SUBROUTINE DPNNZR() GETS THE NEXT NONZERO VALUE IN ROW OR COLUMN
C     +/- IRCX WITH AN INDEX GREATER THAN THE VALUE OF I.
C
C             I ABSOLUTE VALUE OF THIS SUBSCRIPT IS TO BE EXCEEDED
C               IN THE SEARCH FOR THE NEXT NONZERO VALUE. A NEGATIVE
C               OR ZERO VALUE OF I CAUSES THE SEARCH TO START AT
C               THE BEGINNING OF THE VECTOR.  A POSITIVE VALUE
C               OF I CAUSES THE SEARCH TO CONTINUE FROM THE LAST PLACE
C               ACCESSED. ON OUTPUT, THE ARGUMENT I
C               CONTAINS THE VALUE OF THE SUBSCRIPT FOUND.  AN OUTPUT
C               VALUE OF I EQUAL TO ZERO INDICATES THAT ALL COMPONENTS
C               WITH AN INDEX GREATER THAN THE INPUT VALUE OF I ARE
C               ZERO.
C          XVAL VALUE OF THE NONZERO ELEMENT FOUND.  ON OUTPUT,
C               XVAL=0. WHENEVER I=0.
C     IPLACE POINTER INFORMATION WHICH IS MAINTAINED BY THE PACKAGE.
C   SX(*),IX(*) THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE
C               MATRIX.  THESE ARRAY CONTENTS ARE AUTOMATICALLY
C               MAINTAINED BY THE PACKAGE FOR THE USER.
C          IRCX POINTS TO THE VECTOR OF THE MATRIX BEING SCANNED.  A
C               NEGATIVE VALUE OF IRCX INDICATES THAT ROW -IRCX IS TO BE
C               SCANNED.  A POSITIVE VALUE OF IRCX INDICATES THAT
C               COLUMN IRCX IS TO BE SCANNED.  A ZERO VALUE OF IRCX IS
C               AN ERROR.
C
C     THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LNNZRS,
C     SANDIA LABS. REPT. SAND78-0785.
C     MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON
C     REVISED 811130-1000
C     REVISED YYMMDD-HHMM
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  IDLOC, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Removed unreferenced labels.  (WRB)
C   890606  Changed references from IPLOC to IDLOC.  (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   910403  Updated AUTHOR and DESCRIPTION sections.  (WRB)
C***END PROLOGUE  DPNNZR
      DIMENSION IX(*)
      DOUBLE PRECISION XVAL,SX(*),ZERO
      SAVE ZERO
      DATA ZERO /0.D0/
C***FIRST EXECUTABLE STATEMENT  DPNNZR
      IOPT=1
C
C     CHECK VALIDITY OF ROW/COL. INDEX.
C
      IF (.NOT.(IRCX .EQ.0)) GO TO 20002
      NERR=55
      CALL XERMSG ('SLATEC', 'DPNNZR', 'IRCX=0', NERR, IOPT)
C
C     LMX IS THE LENGTH OF THE IN-MEMORY STORAGE AREA.
C
20002 LMX = IX(1)
      IF (.NOT.(IRCX.LT.0)) GO TO 20005
C
C     CHECK SUBSCRIPTS OF THE ROW. THE ROW NUMBER MUST BE .LE. M AND
C     THE INDEX MUST BE .LE. N.
C
      IF (.NOT.(IX(2).LT.-IRCX .OR. IX(3).LT.ABS(I))) GO TO 20008
      NERR=55
      CALL XERMSG ('SLATEC', 'DPNNZR',
     +   'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' //
     +   'BOUNDS.', NERR, IOPT)
20008 L=IX(3)
      GO TO 20006
C
C     CHECK SUBSCRIPTS OF THE COLUMN. THE COL. NUMBER MUST BE .LE. N AND
C     THE INDEX MUST BE .LE. M.
C
20005 IF (.NOT.(IRCX.GT.IX(3) .OR. ABS(I).GT.IX(2))) GO TO 20011
      NERR=55
      CALL XERMSG ('SLATEC', 'DPNNZR',
     +   'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' //
     +   'BOUNDS', NERR, IOPT)
20011 L=IX(2)
C
C     HERE L IS THE LARGEST POSSIBLE SUBSCRIPT WITHIN THE VECTOR.
C
20006 J=ABS(IRCX)
      LL=IX(3)+4
      LPG = LMX - LL
      IF (.NOT.(IRCX.GT.0)) GO TO 20014
C
C     SEARCHING FOR THE NEXT NONZERO IN A COLUMN.
C
C     INITIALIZE STARTING LOCATIONS..
      IF (.NOT.(I.LE.0)) GO TO 20017
      IF (.NOT.(J.EQ.1)) GO TO 20020
      IPLACE=LL+1
      GO TO 20021
20020 IPLACE=IX(J+3)+1
20021 CONTINUE
C
C     THE CASE I.LE.0 SIGNALS THAT THE SCAN FOR THE ENTRY
C     IS TO BEGIN AT THE START OF THE VECTOR.
C
20017 I = ABS(I)
      IF (.NOT.(J.EQ.1)) GO TO 20023
      ISTART = LL+1
      GO TO 20024
20023 ISTART=IX(J+3)+1
20024 IEND = IX(J+4)
C
C     VALIDATE IPLACE. SET TO START OF VECTOR IF OUT OF RANGE.
C
      IF (.NOT.(ISTART.GT.IPLACE .OR. IPLACE.GT.IEND)) GO TO 20026
      IF (.NOT.(J.EQ.1)) GO TO 20029
      IPLACE=LL+1
      GO TO 20030
20029 IPLACE=IX(J+3)+1
20030 CONTINUE
C
C     SCAN THROUGH SEVERAL PAGES, IF NECESSARY, TO FIND MATRIX ENTRY.
C
20026 IPL = IDLOC(IPLACE,SX,IX)
C
C     FIX UP IPLACE AND IPL IF THEY POINT TO PAGING DATA.
C     THIS IS NECESSARY BECAUSE THERE IS CONTROL INFORMATION AT THE
C     END OF EACH PAGE.
C
      IDIFF = LMX - IPL
      IF (.NOT.(IDIFF.LE.1.AND.IX(LMX-1).GT.0)) GO TO 20032
C
C     UPDATE THE RELATIVE ADDRESS IN A NEW PAGE.
C
      IPLACE = IPLACE + IDIFF + 1
      IPL = IDLOC(IPLACE,SX,IX)
20032 NP = ABS(IX(LMX-1))
      GO TO 20036
20035 IF (ILAST.EQ.IEND) GO TO 20037
20036 ILAST = MIN(IEND,NP*LPG+LL-2)
C
C     THE VIRTUAL END OF THE DATA FOR THIS PAGE IS ILAST.
C
      IL = IDLOC(ILAST,SX,IX)
      IL = MIN(IL,LMX-2)
C
C     THE RELATIVE END OF DATA FOR THIS PAGE IS IL.
C     SEARCH FOR A NONZERO VALUE WITH AN INDEX .GT. I ON THE PRESENT
C     PAGE.
C
20038 IF (.NOT.(.NOT.(IPL.GE.IL.OR.(IX(IPL).GT.I.AND.SX(IPL).NE.ZERO))))
     * GO TO 20039
      IPL=IPL+1
      GO TO 20038
C
C     TEST IF WE HAVE FOUND THE NEXT NONZERO.
C
20039 IF (.NOT.(IX(IPL).GT.I .AND. SX(IPL).NE.ZERO .AND. IPL.LE.IL)) GO
     *TO 20040
      I = IX(IPL)
      XVAL = SX(IPL)
      IPLACE = (NP-1)*LPG + IPL
      RETURN
C
C     UPDATE TO SCAN THE NEXT PAGE.
20040 IPL = LL + 1
      NP = NP + 1
      GO TO 20035
C
C     NO DATA WAS FOUND. END OF VECTOR ENCOUNTERED.
C
20037 I = 0
      XVAL = ZERO
      IL = IL + 1
      IF(IL.EQ.LMX-1) IL = IL + 2
C
C     IF A NEW ITEM WOULD BE INSERTED, IPLACE POINTS TO THE PLACE
C     TO PUT IT.
C
      IPLACE = (NP-1)*LPG + IL
      RETURN
C
C     SEARCH A ROW FOR THE NEXT NONZERO.
C     FIND ELEMENT J=ABS(IRCX) IN ROWS ABS(I)+1,...,L.
C
20014 I=ABS(I)
C
C     CHECK FOR END OF VECTOR.
C
      IF (.NOT.(I.EQ.L)) GO TO 20043
      I=0
      XVAL=ZERO
      RETURN
20043 I1 = I+1
      II=I1
      N20046=L
      GO TO 20047
20046 II=II+1
20047 IF ((N20046-II).LT.0) GO TO 20048
C
C     INITIALIZE IPPLOC FOR ORTHOGONAL SCAN.
C     LOOK FOR J AS A SUBSCRIPT IN ROWS II, II=I+1,...,L.
C
      IF (.NOT.(II.EQ.1)) GO TO 20050
      IPPLOC = LL + 1
      GO TO 20051
20050 IPPLOC = IX(II+3) + 1
20051 IEND = IX(II+4)
C
C     SCAN THROUGH SEVERAL PAGES, IF NECESSARY, TO FIND MATRIX ENTRY.
C
      IPL = IDLOC(IPPLOC,SX,IX)
C
C     FIX UP IPPLOC AND IPL TO POINT TO MATRIX DATA.
C
      IDIFF = LMX - IPL
      IF (.NOT.(IDIFF.LE.1.AND.IX(LMX-1).GT.0)) GO TO 20053
      IPPLOC = IPPLOC + IDIFF + 1
      IPL = IDLOC(IPPLOC,SX,IX)
20053 NP = ABS(IX(LMX-1))
      GO TO 20057
20056 IF (ILAST.EQ.IEND) GO TO 20058
20057 ILAST = MIN(IEND,NP*LPG+LL-2)
      IL = IDLOC(ILAST,SX,IX)
      IL = MIN(IL,LMX-2)
20059 IF (.NOT.(.NOT.(IPL.GE.IL .OR. IX(IPL).GE.J))) GO TO 20060
      IPL=IPL+1
      GO TO 20059
C
C     TEST IF WE HAVE FOUND THE NEXT NONZERO.
C
20060 IF (.NOT.(IX(IPL).EQ.J .AND. SX(IPL).NE.ZERO .AND. IPL.LE.IL)) GO
     *TO 20061
      I = II
      XVAL = SX(IPL)
      RETURN
20061 IF(IX(IPL).GE.J) ILAST = IEND
      IPL = LL + 1
      NP = NP + 1
      GO TO 20056
20058 GO TO 20046
C
C     ORTHOGONAL SCAN FAILED. THE VALUE J WAS NOT A SUBSCRIPT
C     IN ANY ROW.
C
20048 I=0
      XVAL=ZERO
      RETURN
      END