      SUBROUTINE LANDR(N,LDOBSC,LANMAX,MAXPRS,CONDM,ENDL,ENDR,EV,KAPPA,
     *                 J,NEIG,RITZ,BND,W,NW,IERR,MSGLVL,KPROC)
C
C  .... The program make a Lanczos run using a linear operator that acts
C .... through a user supplied subroutine called OPK in order to compute
C     .... either all eigenvalues outside an interval [endl,endr] or the
C     .... first MAXPRS eigenvalues, whichever occurs first.  The inner
C  .... product is defined implicitly by a user supplied subroutine OPM.
C
C            *****************************************
C            *                                       *
C            *         LANCZOS ALORITHM WITH         *
C            *      SELECTIVE ORTHOGONALIZATION      *
C            *            L  A  N  S  O              *
C            *      (Using Simon's Recurrence)       *
C            *                                       *
C            *****************************************
C
C     .... inputs
C     .... N      dimension of the eigenproblem
C     .... LDOBSC .T. if use (OPK_OBSCOR,OPM_OBSCOR) inst. of (OPK,OPM)
C     .... LANMAX upper limit to the number of Lanczos steps
C     .... MAXPRS upper limit to the number of wanted eigenpairs
C     .... CONDM  estimated condition number of M
C.... ENDL   left end of the interval containing the UNwanted eigenvalues
C.... ENDR   right end of the interval containing the UNwanted eigenvalues
C     .... EV     .LE.0 means eigenvalues only,
C   ....        .GT.0 means both eigenvalues and eigenvectors are wanted
C   ....              and EV becomes the output channel for eigenvectors
C .... KAPPA  relative accuracy of Ritz values acceptable as eigenvalues
C    ....        (KAPPA will not be touched and/or looked at if EV.LE.0)
C     .... NW     length of the work array W
C     .... W      work array of length NW
C
C     .... outputs
C     .... J      number of Lanczos steps actually taken
C     .... NEIG   number of Ritz values stabilized
C     .... RITZ   array to hold the Ritz values
C     .... BND    array to hold the error bounds
C     .... IERR   error flag
C
C     .... subroutines:      MACHAR,LANSO,RITVEC
C
C
C
C     .... MACHAR specific (EPS declared in COMMON/RDATA/)
C
C     %bgn%
C     .. Scalar Arguments ..
      IMPLICIT NONE
      REAL CONDM, ENDL, ENDR, KAPPA
      INTEGER EV, IERR, J, LANMAX, MAXPRS, MSGLVL, N, NEIG, NW
      LOGICAL LDOBSC
      INTEGER KPROC
C     .. Array Arguments ..
      REAL BND(LANMAX), RITZ(LANMAX), W(NW)
C     .. Scalars in Common ..
      REAL ANORM, EPS, EPS1, EPS34, EPSN, RCEPS1, REPS, RNM,
     *                 TOL
C     .. Local Scalars ..
      REAL EPSNEG, XMAX, XMIN
      INTEGER          I, IBETA, IEXP, IRND, IT, L2, L3, L4, L5, LSQ6,
     *                 MACHEP, MAXEXP, MINEXP, MT, N1, NEGEP, NGRD 
C     .. Local Arrays ..
      INTEGER          NQ(4)
      CHARACTER*48     MSGRND(0:5)
      CHARACTER*64     MSGGRD(0:1)
C     .. External Subroutines ..
      EXTERNAL         LANSO, MACHAR, RITVEC
C     .. Intrinsic Functions ..
      INTRINSIC        ABS, REAL, MAX, SQRT
C     .. Common blocks ..
      COMMON           /RDATA/RNM, ANORM, TOL, EPS, EPS1, RCEPS1, EPSN,
     *                 REPS, EPS34
C     .. Data statements ..
      DATA             MSGRND/'chops', 'rounds (non-IEEE style)',
     *                 'rounds (IEEE style)',
     *                 'chops with partial underflow',
     *                 'rounds (non-IEEE style) with partial underflow',
     *                 'rounds (IEEE style) with partial underflow'/
      DATA             MSGGRD/
     *   'rounds/truncates & only IT base-IBETA digits take part in PNS'
     *                 ,
     *     'truncates & more than IT base-IBETA digits take part in PNS'
     *                 /
C     .. Executable Statements ..
C     %end%
C
C     .... check input data
C
      MT = 6*N + 1 + 4*LANMAX
      IF (EV.GT.0) MT = MT + LANMAX*LANMAX
      IERR = 0
      IF (N.LE.0) IERR = IERR + 1
      IF (LANMAX.LE.0) IERR = IERR + 2
      IF (ENDR.LE.ENDL) IERR = IERR + 4
      IF (MAXPRS.LE.0) IERR = IERR + 8
      IF (MAXPRS.GT.LANMAX) IERR = IERR + 16
      IF (LANMAX.GT.N) IERR = IERR + 32
      IF (MT.GT.NW) IERR = IERR + 64
      IF (IERR.GT.0) RETURN
C
C     .... compute machine precision
C
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP,
     *            EPS,EPSNEG,XMIN,XMAX)
C     %bgn%
      IF (MSGLVL.GE.1) THEN
         WRITE(6,99999) IBETA, IT, MSGRND(IRND), MSGGRD(NGRD),
     *     MACHEP, NEGEP, IEXP, MINEXP, MAXEXP
         WRITE(6,99998) EPS, EPSNEG, XMIN, XMAX
      END IF
C     %end%
      EPS1 = EPS*SQRT(REAL(N))
      EPSN = EPS*REAL(N)
      RCEPS1 = SQRT(MAX(ABS(CONDM),1.0E0))*EPS1
      REPS = SQRT(EPS)
      EPS34 = REPS*SQRT(REPS)
C
C     .... set pointers and initialize
C
      NQ(1) = N + 1
      DO 20 I = 2, 4
         NQ(I) = NQ(I-1) + N
   20 CONTINUE
      N1 = 1 + 5*N
      L2 = N + N1
      L3 = LANMAX + L2
      L4 = 1 + LANMAX + L3
      L5 = LANMAX + L4
C     CALL LANSO(...,W,W(N1),W(L2),W(L3),W(L4),W(L5),NQ,IERR,MSGLVL)
      CALL LANSO(N,LDOBSC,LANMAX,MAXPRS,ENDL,ENDR,J,NEIG,RITZ,BND,
     *          W,W(N1),W(L2),W(L3),W(L4),W(L5),NQ,IERR,MSGLVL)
C
C     .... compute eigenvectors
C
      IF (EV.GT.0) THEN
         LSQ6 = LANMAX + L5
C
C        ....    rationalize KAPPA
C
         KAPPA = MAX(ABS(KAPPA),EPS34)
C
C        ....    W(NQ(4)) becomes working storage from this point on
C
C        CALL RITVEC(...,W(LSQ6),W(NQ(4)),W(N1),IERR,MSGLVL)

         CALL RITVEC(N,J,EV,KAPPA,RNM,RITZ,BND,W(L2),W(L3),W(LSQ6),
     *               W(NQ(4)),W(N1),IERR,MSGLVL,KPROC,LDOBSC)
      END IF
      RETURN
C
99999 FORMAT (/1X,'About the underlying floating-point arithmetic...',
     *       /1X,/4X,'IBETA = Radix for the FP representation      =',
     *       I3,/4X,'IT = Number of significant base-IBETA digits =',I3,
     *       /4X,'FP add ',A,/4X,'FP multiply ',A,/4X,'MACHEP = min{k|',
     *       '-(IT+3)<=k<0,1+IBETA**k.NE.1} =',I6,/4X,'NEGEPS = min{k|',
     *       '-(IT+3)<=k<0,1-IBETA**k.NE.1} =',I6,/4X,'IEXP = width in',
     *       ' bits of the exponent field   =',I3,/4X,'MINEXP = min{k|',
     *       'IBETA**k > 0 and normalized}  =',I6,/4X,'MAXEXP = min{k|',
     *       'IBETA**k overflows}           =',I6)
99998 FORMAT (4X,'EPS = min{x|x > 0 and 1+x.NE.1} =',1P,E27.19E3,/4X,
     *       'EPSNEG ~ min{x|x > 0& 1-x.NE.1} =',1P,E27.19E3,/4X,'XMIN',
     *       ' = IBETA**MINEXP            =',1P,E27.19E3,/4X,'XMAX = (',
     *       '1-EPSNEG)*IBETA*MAXEXP  =',1P,E27.19E3)
      END
