C @(#)fittable.for 17.1.1.1 (ES0-DMD) 01/25/02 17:11:05 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.2 ESO-FORTRAN Conversion, AA 14:17 - 19 NOV 1989 C C.LANGUAGE: F77+ESOext C C.AUTHOR: J.D.PONZ C C.IDENTIFICATION: C PROGRAM fittable C C.PURPOSE C C Copy fit file into table format for editing C C.KEYWORDS C C ARITHMETIC OPERATS, TABLES. C C.ALGORITHM C C USE TABLE INTERFACE ROUTINES C C----------------------------------------------------------- C PROGRAM FITTBL IMPLICIT NONE C C CHARACTER*72 LINE CHARACTER*60 FILENA, TABLE CHARACTER*80 SPEC CHARACTER*60 FUNC, PARM CHARACTER*16 LABEL1, LABEL2, UNIT CHARACTER*10 FORM INTEGER KUN, KNUL, STAT, IC, TID, NROW, I, II INTEGER INDEX, NW, NC, IFILE, J INTEGER MADRID(1) C INCLUDE 'MID_INCLUDE:ST_DEF.INC' INCLUDE 'MID_INCLUDE:FITI.INC' INCLUDE 'MID_INCLUDE:FITC.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' DATA FILENA/' '/ DATA LABEL1/'FUNCTIONS '/ DATA LABEL2/'PARAMETERS '/ DATA UNIT/' '/ DATA FORM/'A60 '/ C C ... GET INTO MIDAS C CALL STSPRO('TOPERTBL') CALL FITBL C C ... GET COMMAND FORM ENVIRONMENT C CALL STKRDC('IN_A',1,1,60,I,FILENA,KUN,KNUL,STAT) CALL STKRDI('INPUTI',1,1,I,IFILE,KUN,KNUL,STAT) C C ... INITIALIZE FIT FILE C IF (IFILE .EQ. 0) THEN CALL STTPUT(' Info: New fit file ', STAT) CALL FTINI1(STAT) ELSE CALL STTPUT(' Info: Fit file already exists ', STAT) CALL FTINIT(FILENA, STAT) ENDIF C C ... INITIALIZE TABLE FILE C I = INDEX(FILENA,'.') IF (I .EQ. 0) I = INDEX(FILENA,' ') I = I - 1 TABLE = FILENA(1:I)//'_fit ' CALL STKWRC('OUT_A',1,TABLE,1,60,KUN,STAT) NC = 60 NROW = 20 NW = NC/2 CALL TBTINI(TABLE, F_TRANS, F_O_MODE, NW, NROW, TID, STAT) CALL TBCINI(TID, D_C_FORMAT, NC, FORM, UNIT, LABEL1, IC, STAT) CALL TBCINI(TID, D_C_FORMAT, NC, FORM, UNIT, LABEL2, IC, STAT) C C ... INITIALIZE TABLE DATA C DO 10 I = 1, NROW IF (I .LE. FZNFUN ) THEN CALL FTRDFN(I, SPEC, STAT) II = INDEX(SPEC,')') FUNC = SPEC(1:II) II = II + 1 DO 5 J = II, 80 IF (SPEC(J:J) .NE. ' ') GOTO 6 5 CONTINUE C C ... END OF STRUCTURED CODE C 6 PARM = SPEC(J:) C C ELSE FUNC = ' ' PARM = ' ' ENDIF CALL TBEWRC(TID, I, 1, FUNC, STAT) CALL TBEWRC(TID, I, 2, PARM, STAT) 10 CONTINUE CALL TBTCLO(TID, STAT) FZMAPPED = 0 IF (IFILE .EQ. 0) THEN CALL FTEXT1(FILENA, STAT) ELSE CALL FTEXIT(FILENA, STAT) ENDIF C C ... EXIT FROM MIDAS C CALL STSEPI END C BLOCK DATA C INCLUDE 'MID_INCLUDE:FITI.INC' C INCLUDE 'MID_INCLUDE:FITC.INC' C INCLUDE 'MID_INCLUDE:FITD.INC' C END