C @(#)getlst.for	17.1.1.1 (ES0-DMD) 01/25/02 17:15:41
C===========================================================================
C Copyright (C) 1995 European Southern Observatory (ESO)
C
C This program is free software; you can redistribute it and/or 
C modify it under the terms of the GNU General Public License as 
C published by the Free Software Foundation; either version 2 of 
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public 
C License along with this program; if not, write to the Free 
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
C MA 02139, USA.
C
C Corresponding concerning ESO-MIDAS should be addressed as follows:
C	Internet e-mail: midas@eso.org
C	Postal address: European Southern Observatory
C			Data Management Division 
C			Karl-Schwarzschild-Strasse 2
C			D 85748 Garching bei Muenchen 
C			GERMANY
C===========================================================================
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.IDENTIFICATION
C  subroutine GETLST         version 1.0        880901
C  A. Kruszewski             Warsaw U. Obs.
C.PURPOSE
C  Find an object less distant to L-th object then LDIS.
C  Only objects listed after LACT are considered.
C  Number of found object is returned as LACT and DONE is .TRUE.
C  otherwise DONE is .FALSE.
C.INPUT/OUTPUT
C  Input parameters
C  L        integer*4          object's number
C  L0       integer*4          offset to catalog buffer
C  L1       integer*4          last object in catalog buffer
C  LDIS     integer*4          looks for objects closer than that
C  LSTP     integer*4 array    limits of regions
C  NREG     integer*4          number of regional linked lists
C  NCAT     integer*4 array    integer catalog
C  PMTR     real*4 array       real catalog
C  PRCT     real*4 array       catalog of profiles
C  NP       integer*4          dimension of catalog buffers
C  LACT     integer*4          searching starts with that object
C  NCT      integer*4 array    small integer buffer
C  PMT      real*4 array       small real buffer
C  Output parameters
C  LACT     integer*4          found object
C  DONE     logical            .true. if found
C-----------------------------------------------------------------------
      SUBROUTINE GETLST(L, L0, L1, LDIS, NREG,
     &                    LSTP, NCAT, PMTR, PRCT, LACT,
     &                    NCT, PMT, PRC, DONE)
C
      IMPLICIT  NONE
      INCLUDE   'MID_REL_INCL:INVENT.INC/NOLIST'
C
      INTEGER   L
      INTEGER   L0
      INTEGER   L1
      INTEGER   LDIS
      INTEGER   NREG
      INTEGER   LSTP(0:4,0:NREG)
      INTEGER   NCAT(NIPAR,MAXCNT)
      REAL      PMTR(NRPAR,MAXCNT)
      REAL      PRCT(0:MAXSUB,MAXCNT)
      INTEGER   LACT
      INTEGER   NCT(NIPAR)
      REAL      PMT(NRPAR)
      REAL      PRC(0:MAXSUB)
      LOGICAL   DONE
C
      INTEGER   LDIS2
      INTEGER   LZ
      INTEGER   I, J
      INTEGER   IREG
      INTEGER   LLZ
      INTEGER   IA, JA
      LOGICAL   NEAR
C
      DONE = .FALSE.
      LDIS2 = LDIS * LDIS
C      IF ( L .GT. L0 .AND. L .LE. L1 ) THEN
          LZ = L - L0
          I = NCAT(1,LZ)
          J = NCAT(2,LZ)
C      ELSE
C          READ ( ISF , REC=L ) NCT , PMT , PRC
C          I = NCT(1)
C          J = NCT(2)
C      ENDIF
      IREG = 0
   30 CONTINUE
      IF ( LACT .EQ. 0 ) THEN
C
C ***     Look for nearby region.
C
   10     CONTINUE
C
C ***     Pick up next region.
C
          IREG = IREG + 1
          IF ( IREG .GT. NREG ) RETURN
C
C ***     Check if region is sufficiently nearby.
C
          NEAR = .FALSE.
          CALL IFNEAR( NREG , LSTP , IREG , I , J , LDIS , NEAR )
          IF ( NEAR ) THEN
              LACT = LSTP(0,IREG)
              IF ( LACT .NE. 0 ) GOTO 20
          ENDIF
          GOTO 10
      ELSE
C
C ***     Pick object next to LACT.
C
C          IF ( LACT .GT. L0 .AND. LACT .LE. L1 ) THEN
              LLZ = LACT - L0
              IREG = NCAT(7,LLZ)
              LACT = NCAT(8,LLZ)
C          ELSE
C              READ ( ISF , REC = LACT ) NCT , PMT , PRC
C              IREG = NCT(7)
C              LACT = NCT(8)
C          ENDIF
      ENDIF
   20 CONTINUE
C
C *** Try again when LACT = 0 or LACT = L or when
C *** an object is not sufficiently close.
C
      IF ( LACT .EQ. 0 .OR. LACT .EQ. L ) GOTO 30
C      IF ( LACT .GT. L0 .AND. LACT .LE. L1 ) THEN
          LLZ = LACT - L0
          IA = NCAT(1,LLZ)
          JA = NCAT(2,LLZ)
          PMT(2) = PMTR(2,LLZ)
C      ELSE
C          READ ( ISF , REC = LACT ) NCT , PMT , PRC
C          IA = NCT(1)
C          JA = NCT(2)
C      ENDIF
      IF ( (IA-I)*(IA-I)+(JA-J)*(JA-J) .GT. LDIS2 ) GOTO 30
      DONE = .TRUE.
C
      RETURN
C
      END
C