C @(#)tdfdecd.for 17.1.1.1 (ES0-DMD) 01/25/02 17:47:14 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.COPYRIGHT: Copyright (c) 1987 European Southern Observatory, C all rights reserved C C.VERSION: 1.0 ESO-FORTRAN Conversion, AA 17:34 - 11 DEC 1987 C C.LANGUAGE: F77+ESOext C C.AUTHOR: J.D.PONZ C C C.IDENTIFICATION TDFDECD.FOR C.KEYWORDS TABLE, APPLICATIONS C.ENVIRONMENT MIDAS C.PURPOSE C DECODE EXTERNAL FORMAT LINE C C C------------------------------------------------------------------ SUBROUTINE TDFDEC(LINE,I1,I2,C,FORM,LABEL,UNIT,STATUS) IMPLICIT NONE CHARACTER*(*) LINE ! IN : input format line INTEGER I1 ! OUT: start position INTEGER I2 ! OUT: end position CHARACTER*(*) C ! OUT: type CHARACTER*8 FORM ! OUT: format CHARACTER*16 LABEL ! OUT: label CHARACTER*16 UNIT ! OUT : unit INTEGER STATUS ! OUT : status C INTEGER COUNT,START,I,IST,FIELD INTEGER FORSKP INTEGER LTOKEN(8) C CHARACTER*1 CC CHARACTER*64 TOKEN(8) CHARACTER*1 SYMILL(9) CHARACTER*80 LINE1 INCLUDE 'MID_INCLUDE:TABLES.INC/NOLIST' INCLUDE 'MID_INCLUDE:TABLED.INC/NOLIST' DATA SYMILL/')','(','+','-','*','/','.','#',':'/ C COUNT = 0 LABEL = ' ' UNIT = ' ' FORM = ' ' START = FORSKP(' ',LINE(1:)) IF (START.LE.0) THEN STATUS = ERRFMT RETURN END IF DO 10 I = 1,8 CALL GENEXT(LINE,' ',START,TOKEN(I),LTOKEN(I)) IF (LTOKEN(I).GT.0 .AND. (TOKEN(I) (1:1).NE.'!')) THEN C C ... TO BE REMOVED C C CALL FORUPC(TOKEN(I),TOKEN(I)) COUNT = COUNT + 1 ELSE GO TO 20 END IF 10 CONTINUE 20 CONTINUE IF (COUNT.LE.3) THEN LINE1 = LINE CALL STTPUT('Wrong definition',IST) CALL STTPUT(LINE1,IST) STATUS = ERRFMT RETURN END IF FIELD = LTOKEN(2) LINE1 = TOKEN(2) C READ(TOKEN(2) (1:LTOKEN(2)),9000) I1 CALL ASCINT(LINE1, FIELD, I1) FIELD = LTOKEN(3) LINE1 = TOKEN(3) C READ(TOKEN(3) (1:LTOKEN(3)),9000) I2 CALL ASCINT(LINE1, FIELD, I2) IF (COUNT.GT.4) THEN DO 30 I = 5,COUNT CC = TOKEN(I) (1:1) IF (CC.EQ.':' .OR. CC.EQ.'#') THEN IF (CC.EQ.':') LABEL = TOKEN(I) (2:LTOKEN(I)) ELSE IF (CC.EQ.'"') THEN UNIT = TOKEN(I) (2:LTOKEN(I)-1) ELSE FORM = TOKEN(I) END IF END IF 30 CONTINUE END IF C = TOKEN(4) DO 40 I = 1,9 IF (INDEX(LABEL,SYMILL(I)).NE.0) THEN LINE1 = ' ' LINE1 = ' Wrong label '//LABEL CALL STTPUT(LINE1,IST) STATUS = ERRPAR END IF 40 CONTINUE RETURN C100 FORMAT(I) C 9000 FORMAT (I4) END SUBROUTINE ASCINT(A, N, I) C C CONVERT ASCII STRING IN TO INTEGER C IMPLICIT NONE CHARACTER*(*) A INTEGER N INTEGER I C CHARACTER*1 T INTEGER J, K C I = 0 DO 10 J = 1, N T = A(J:J) IF (T.GE.'0' .AND. T.LE.'9') THEN READ(T,100) K I = I*10 + K ELSE RETURN ENDIF 10 CONTINUE RETURN 100 FORMAT(I1) END