C @(#)fitsele.for 17.1.1.1 (ESO-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 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.COPYRIGHT: Copyright (c) 1987 European Southern Observatory, C all rights reserved C C.VERSION: 1.0 ESO-FORTRAN Conversion, AA 16:01 - 20 DEC 1987 C C.LANGUAGE: F77+ESOext C C.AUTHOR: J.D.PONZ C C.IDENTIFICATION C C program FUNCREA.FOR C C.PURPOSE C C Execute the commands C SELECT/FUNCTION function number[,...] C C SELECT BASIC FUNCTION COMPONENTS C THE SELECTED FUNCTIONS ARE USED IN COMPUTE/FIT AND COMPUTE/FUNCTION C THE COMPLETE SET IS USED IN FIT/IMAGE OR /TABLE C C.KEYWORDS C C SELECT, FIT C C.INPUT/OUTPUT C C P1 - P2 contain input parameters C C.ALGORITHM C C Use fit interface routines C C 000605 C----------------------------------------------------------- C IMPLICIT NONE C C ... define variables C INTEGER IFUN(20),ISELE(20),STATUS INTEGER I,II,II1,IAV,IP,KUN,KNUL,ISTAT,DUN INTEGER MADRID(1),NAMLEN C CHARACTER*80 P1,NAME CHARACTER*16 MSG C INCLUDE 'MID_INCLUDE:FITI.INC/NOLIST' INCLUDE 'MID_INCLUDE:ST_DEF.INC' INCLUDE 'MID_INCLUDE:FITC.INC/NOLIST' C COMMON/VMR/MADRID C INCLUDE 'MID_INCLUDE:ST_DAT.INC' C DATA NAMLEN/80/ DATA ISELE/0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ DATA MSG/'ERR:FUNCREAxxxx'/ C C ... get into MIDAS C CALL STSPRO('FITSELE') CALL FITBL C C ... read parameters C CALL STKRDC('P1',1,1,NAMLEN,IAV,P1,KUN,KNUL,ISTAT) CALL STKRDI('INPUTI',1,16,IAV,IFUN,KUN,KNUL,ISTAT) DO 10, I=1,16 II = IFUN(I) IF (II.NE.0) THEN IF (II.GT.0 .AND. II.LE.16) THEN ISELE(II) = 1 ELSE CALL STTPUT(' Error in function number... ',ISTAT) GO TO 30 END IF ELSE GO TO 20 END IF 10 CONTINUE C C ... write selection C 20 II1 = INDEX(P1,'.') IF (II1.NE.0) THEN NAME = P1 ELSE II = INDEX(P1,' ') - 1 NAME = P1(1:II)//'.fit' END IF CALL STFOPN(NAME,D_R4_FORMAT,0,F_FIT_TYPE,IP,ISTAT) CALL STDWRI(IP,'FITSELE',ISELE,1,20,DUN,ISTAT) C C ... end C 30 IF (ISTAT.NE.0) THEN WRITE (MSG(13:16),9000) ISTAT CALL TDERRR(ISTAT,MSG,STATUS) END IF CALL STSEPI 9000 FORMAT (I4) END