C===========================================================================
C Copyright (C) 1995-2005 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 Massachusetts Ave, Cambridge, 
C MA 02139, USA.
C
C Correspondence 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.VERSION: 1.0  ESO-FORTRAN Conversion, AA  9:51 - 26 NOV 1987
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: K.BANSE
C
C.VERSION
C 051017	last modif
C 


      SUBROUTINE GENEXT(STRING,DELIM,START,SS,SLEN)
C
C++++++++++++++++++++++++++++++++++++++++++++++++++
C      IMPLICIT NONE
C
C.IDENTIFICATION
C  subroutine GENEXT         version 2.50       860217
C  K. Banse                      ESO - Garching
C
C.KEYWORDS
C  character string , parsing
C
C.PURPOSE
C  from a given string extract a substring limited by given
C  delimiters
C
C.ALGORITHM
C  find the given delimiter in the string
C  copy the relevant part into the substring
C  spaces in front or after delimiters are ignored
C
C.INPUT/OUTPUT
C  call as  GENEXT(STRING,DELIM,START,SS,SLEN)
C
C  input par:
C  STRING: char. exp. character string which is to be parsed
C  DELIM: char. exp. delimiter string
C
C  input/output par:
C  START: I*4  starting index within the input
C    string - will be set to the position
C    just following the next delimiter
C    upon return
C
C  output par:
C  SS:  char. exp. extracted substring
C    will be set to spaces, if nothing there
C  SLEN: I*4  length of extracted substring in bytes
C
C--------------------------------------------------
C
C
      INTEGER       SLEN, START, SKIP, SOSS, EOSS,FORSKP
      INTEGER NXTDL1,NEXT1
      CHARACTER*(*) STRING,DELIM,SS
      CHARACTER*200 SDUMMY
C
      SS     = ' '
      SLEN   = 0
C
C  see, if already the end of string reached
      IF (LEN(STRING).LT.START) GO TO 30
C
C  skip leading blanks
      SKIP   = FORSKP(' ',STRING(START:))  !  only blanks
      IF (SKIP.LE.0) GO TO 30
C
C  find begin of substring + next delimiter
      SOSS   = START + SKIP - 1  !  points to next delim. - 1
      SDUMMY = STRING(SOSS:)//DELIM
      NXTDL1 = INDEX(SDUMMY,DELIM) + SOSS - 2  !  1. non-blank character = delimiter
      IF (NXTDL1.LT.SOSS) GO TO 20
C
C  cut off trailing blanks
      IF (DELIM.EQ.' ') THEN
          EOSS   = NXTDL1

      ELSE
          SDUMMY = STRING(SOSS:NXTDL1)//' '
          EOSS   = INDEX(SDUMMY,' ') + SOSS - 2
      END IF
C
C  look for character constants with embedded blanks, ".. .."
      IF ((DELIM.NE.' ') .OR. (STRING(SOSS:SOSS).NE.'"')) GO TO 10
      IF ((SOSS.EQ.EOSS) .OR. (STRING(EOSS:EOSS).NE.'"')) THEN
C    !don't consider first '"' again...
          SDUMMY = STRING(SOSS+1:)//' '
          NEXT1  = INDEX(SDUMMY,'" ')
          IF (NEXT1.GT.0) THEN  !  update end of substring
              EOSS   = NEXT1 + SOSS  !  as well as NXTDL1...
              NXTDL1 = EOSS
          END IF

      END IF
C
C  copy string
   10 SS(1:) = STRING(SOSS:EOSS)
      SLEN   = EOSS - SOSS + 1
   20 START  = NXTDL1 + LEN(DELIM) + 1
      RETURN
C
   30 START  = 0
      RETURN

      END

      SUBROUTINE DISFIL(FILNAM,PREFIX,LABEL,STAT)
C
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine DSPFIL		version 3.03	841213
C  K. Banse			ESO - Garching
C  					3.10	871201
C
C.KEYWORDS
C  display, ASCII files
C
C.PURPOSE
C  display a given section of a file (may be complete file) on the terminal
C  and store it in the logfile
C
C.ALGORITHM
C  search file till line PREFIX//LABEL is found + display all records
C  from there on until line PREFIX//anything is encountered.
C
C.INPUT/OUTPUT
C  call as  DSPFIL(FILNAM,PREFIX,LABEL,USR_LEVL,STAT)
C
C  input par:
C  FILNAM:	char.exp.	FILNAMe
C  PREFIX:	char.exp.	this string marks different section in a file
C  LABEL:	char.exp.	this label determines the start of the
C				file section to be displayed when concatenated
C				to PREFIX
C
C  output par:
C  STAT:	I*4		return status
C
C.VERSIONS
C  3.10		get rid of ERRSIGNAL_ST
C--------------------------------------------------
C
        INTEGER        STAT
        INTEGER        N,LCOUNT,EMODE,ULEVL,IAV
        INTEGER        L0,L1,LL,TFLAG
        INTEGER        NLINES,RECLIM,KUN,KNUL
C        
        CHARACTER*(*)    FILNAM,PREFIX,LABEL
        CHARACTER        LINMS*35,RETURN*1
        CHARACTER        RECORD*80
        CHARACTER        SDUMMY*200
C
        DATA        LINMS /' MIDAS> hit RETURN to continue ... '/
        DATA        NLINES  /18/
        DATA        RECLIM  /100000/
C
C  get user level + execution mode
        CALL STKRDI('MID$MODE',3,1,IAV,EMODE,KUN,KNUL,STAT)
        CALL STKRDI('ERROR',2,1,IAV,ULEVL,KUN,KNUL,STAT)
C
C  set up TFLAG
        IF ((ULEVL.LT.2).AND.(EMODE.NE.1)) THEN
           TFLAG = 1                
        ELSE
           TFLAG = 0                
        ENDIF
        LCOUNT = 0                        
        L0 = 0
C        
C  display contents of a file section, determined by PREFIX//LABEL
        OPEN(UNIT=11,FILE=FILNAM,STATUS='OLD',ERR=8800)
C
C  look for PREFIX//LABEL to find start of file section
        IF (PREFIX.EQ.' ') GOTO 3000        
        L0 = LEN(PREFIX)
        L1 = LEN(LABEL)
        LL = L0 + L1
        SDUMMY = PREFIX//LABEL
        DO 2450 N=1,RECLIM
           READ(11,10000,END=2500) RECORD
           IF (RECORD(1:LL).EQ.SDUMMY) GOTO 3000
2450    CONTINUE
C        
C  desired PREFIX//LABEL not found
2500        STAT = 1
        RETURN
C
C  max. 100 000 records
3000    DO 3900 N=1,RECLIM                        
           RECORD = ' '
           READ(11,10000,END=4000) RECORD
C        
           IF ((PREFIX.NE.' ').AND.(RECORD(1:L0).EQ.PREFIX)) THEN
              GOTO 4000
           ELSE
              CALL STTPUT(RECORD,STAT)
C        
C  if TFLAG set, check no. of lines on terminal screen ...
              IF (TFLAG.EQ.1) THEN
                 LCOUNT = LCOUNT + 1
                 IF (LCOUNT.GT.NLINES) THEN
                    WRITE(*,10002) LINMS
                    READ(*,10000) RETURN        
                    LCOUNT = 0
                 ENDIF
              ENDIF
           ENDIF
C        
3900    CONTINUE
C
C  close message file
4000    CLOSE(UNIT=11)
        STAT = 0
        RETURN
C
C  problems with file opening
8800    STAT = 2
        RETURN
C
C  formats
10000   FORMAT(A)
10002   FORMAT(A)
        END
C
C       UNDEFINED REFERENCES FOR THE MOMENT
C
        SUBROUTINE TZSBAC(STATUS)
C
        INTEGER STATUS
        STATUS = 0
        RETURN
        END
        SUBROUTINE TZSBAD(STATUS)
C
        INTEGER STATUS
        STATUS = 0
        RETURN
        END
        SUBROUTINE TZSBAR(STATUS)
C
        INTEGER STATUS
        STATUS = 0
        RETURN
        END
        SUBROUTINE TZSBDC(STATUS)
C
        INTEGER STATUS
        STATUS = 0
        RETURN
        END
        SUBROUTINE TZSBDR(STATUS)
C
        INTEGER STATUS
        STATUS = 0
        RETURN
        END
        SUBROUTINE TZSBDD(STATUS)
C
        INTEGER STATUS
        STATUS = 0
        RETURN
        END
        SUBROUTINE TZSCSC(STATUS)
C
        INTEGER STATUS
        STATUS = 0
        RETURN
        END
        SUBROUTINE TZSCSD(STATUS)
C
        INTEGER STATUS
        STATUS = 0
        RETURN
        END
        SUBROUTINE TZSCSR(STATUS)
C
        INTEGER STATUS
        STATUS = 0
        RETURN
        END
