C @(#)tddummy.for 17.1.1.2 (ESO-DMD) 02/25/02 17:45:07 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 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.COPYRIGHT: Copyright (c) 1987 European Southern Observatory, C all rights reserved 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 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 LCOUNT = 0 TFLAG = 1 ELSE TFLAG = 0 ENDIF 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