C @(#)setopto.for 17.1.1.1 (ES0-DMD) 01/25/02 17:55: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 @(#)setopto.for 17.1.1.1 (ESO-IPG) 17:55:14 01/25/02 PROGRAM SETOP C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.IDENTIFICATION: setopto.for C.PURPOSE: set OPTOPUS parameters according to the comand: C SET/OPTO parameter=value ... C set plate center (RA and DEC) C set original and new equinox (OLDEQ and NEWEQ) C set label to be put on top of graphics C set date (YEAR,MONTH,DAY) C set exposure time in minutes C set wavelength range in angstrom C set observation slot in sidereal time C set optimal sidereal time C set automatic center determination flag C set center precession flag C set automatic optimal ST determination flag C set E-W flip flag C.AUTHOR: Alessandra Gemmo Padova Department of Astronomy C.VERSION: 910522 AG Creation C.VERSION: 910719 AG Modified to set RA and DEC in HH,MM,SS and DD,PP,AA C format, taking care of "-00" case. C 910827 AG Modified to introduce character flags (Y or N). C------------------------------------------------------------------------------- IMPLICIT NONE C C *** C INTEGER KUN,KNUL INTEGER NPAR,IST,IPAR INTEGER MADRID(1) INTEGER IACT,I,II INTEGER NEL,ISTAT INTEGER IVAL(10) INTEGER INDX,LEN,ILEN,N INTEGER CSIGN,IND,IND1,IND2 C C *** C REAL RVAL(10), RDUM(10) C C *** C DOUBLE PRECISION DVAL(10),PLTC(2),EPP C C *** C CHARACTER*80 CVAL,INPUT,NAME,VALUE,VALU1 CHARACTER*8 PNAME,FORM CHARACTER*80 DECCHA(3) CHARACTER*72 CINPUT C C *** C INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST' COMMON /VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST' C C *** C DATA CSIGN/0/ C C *** start the code C CALL STSPRO('SET_OPTO') C C *** do the work C CALL STKRDI('PCOUNT',1,1,IACT,NPAR,KUN,KNUL,IST) !get number of param. CVAL = ' ' !to be modified DO 10 IPAR=1,NPAR WRITE(PNAME,9000)IPAR 9000 FORMAT('P',I1) CALL STKRDC(PNAME,1,1,80,IACT,INPUT,KUN,KNUL,IST) CALL UPCAS(INPUT,INPUT) !convert to uppercase II = INDEX(INPUT,'=') IF(II.EQ.0)THEN NAME = INPUT VALUE = ' ' ELSE NAME = INPUT(1:II-1) VALUE = INPUT(II+1:) C IF(NAME(1:3).EQ.'OLD'.OR.NAME(1:3).EQ.'NEW'.OR. 1 NAME(1:3).EQ.'DAT')THEN IF(VALUE(1:2).EQ.'19')THEN VALU1 = VALUE(3:80) ELSE IF(VALUE(1:2).NE.'19')THEN VALU1 = VALUE(1:80) ENDIF ELSE VALU1 = VALUE(1:80) ENDIF ENDIF C IF(NAME(1:3).EQ.'DEF')THEN CALL STSEPI !default setting; done in .prg ELSE C C *** character-number conversion C CALL DECAG(NAME,CINPUT,VALU1,FORM,IVAL,RVAL,CVAL,INDX,LEN,IST) IF(IST.NE.0)CALL STETER(IST,'*** FATAL: Wrong syntax ... ') C IF(NAME(1:3).EQ.'OLD'.OR.NAME(1:3).EQ.'NEW'.OR. 1 NAME(1:3).EQ.'DAT')THEN IF(VALUE(1:2).EQ.'19'.OR.CINPUT(1:2).EQ.'19')THEN DVAL(1) = DBLE(RVAL(1)) + 1900. ELSE IF(VALUE(1:2).NE.'19'.OR.CINPUT(1:2).NE.'19')THEN DVAL(1) = DBLE(RVAL(1)) ENDIF ELSE DVAL(1) = DBLE(RVAL(1)) ENDIF C DO I=2,10 DVAL(I) = DBLE(RVAL(I)) ENDDO C ENDIF C C *** do some checking C IF(NAME(1:2).EQ.'CR')THEN !consistency of coord. values ILEN = NEL(RVAL,3) IF(ILEN.LT.3)THEN !not enough input CALL STETER(ISTAT,'*** FATAL: Specify hours,min,sec of RA') ELSE IF(RVAL(1).LT.0..OR.RVAL(1).GT.24.)THEN CALL STETER(ISTAT,'*** FATAL: Wrong RA-hours value!!') ELSE IF(RVAL(2).LT.0..OR.RVAL(2).GT.60.)THEN CALL STETER(ISTAT,'*** FATAL: Wrong RA-min value!!') ELSE IF(RVAL(3).LT.0..OR.RVAL(3).GT.60.)THEN CALL STETER(ISTAT,'*** FATAL: Wrong RA-sec value!!') ELSE PLTC(1) = DVAL(1)+DVAL(2)/60.+DVAL(3)/3600. CALL STKWRD('PLATEC1',PLTC(1),1,1,KUN,IST) CALL STKWRD('PLATECEN',DVAL(1),1,1,KUN,IST) CALL STKWRD('PLATECEN',DVAL(2),2,1,KUN,IST) CALL STKWRD('PLATECEN',DVAL(3),3,1,KUN,IST) ENDIF C ELSE IF(NAME(1:2).EQ.'CD')THEN IND1 = INDEX(CVAL,',') IND2 = INDEX(CVAL(IND1+1:80),',') + IND1 DECCHA(1) = CVAL(1:IND1-1) DECCHA(2) = CVAL(IND1+1:IND2-1) DECCHA(3) = CVAL(IND2+1:80) C C *** decode character DECCHA to real array C CALL USRINP(RVAL(1),80,'R',DECCHA(1)) CALL USRINP(RVAL(2),80,'R',DECCHA(2)) CALL USRINP(RVAL(3),80,'R',DECCHA(3)) C DVAL(1) = DBLE(RVAL(1)) DVAL(2) = DBLE(RVAL(2)) DVAL(3) = DBLE(RVAL(3)) C ILEN = NEL(RVAL,3) IND = INDEX(CVAL,'-') IF(ILEN.LT.3)THEN !not enough input CALL STETER(ISTAT,'*** FATAL: Specify deg,amin,asec of DEC') ELSE IF(RVAL(1).LT.-90..OR.RVAL(1).GT.90.)THEN CALL STETER(ISTAT,'*** FATAL: Wrong DEC-degrees value!!') ELSE IF(RVAL(2).GT.60.)THEN CALL STETER(ISTAT,'*** FATAL: Wrong DEC-arcmin value!!') ELSE IF (RVAL(3).GT.60.)THEN CALL STETER(ISTAT,'*** FATAL: Wrong DEC-arcsec value!!') ELSE IF(IND.NE.0)CSIGN = 1 DVAL(1) = DABS(DVAL(1)) DVAL(2) = DABS(DVAL(2)) DVAL(3) = DABS(DVAL(3)) PLTC(2) = DVAL(1)+DVAL(2)/60.+DVAL(3)/3600. IF(CSIGN.EQ.1)PLTC(2)=-PLTC(2) CALL STKWRD('PLATEC1',PLTC(2),2,1,KUN,IST) CALL STKWRC('PLATECHA',1,CVAL,1,80,KUN,IST) CALL STKWRD('PLATECEN',DVAL(1),4,1,KUN,IST) CALL STKWRD('PLATECEN',DVAL(2),5,1,KUN,IST) CALL STKWRD('PLATECEN',DVAL(3),6,1,KUN,IST) ENDIF C ELSE IF(NAME(1:2).EQ.'OL')THEN IF(DVAL(1).LT.1800..OR.DVAL(1).GT.2100.)THEN CALL STETER(ISTAT,'*** FATAL: Value of equinox0 not allowed') ELSE CALL STKWRD('EQUINOX',DVAL(1),1,1,KUN,IST) ENDIF C ELSE IF(NAME(1:2).EQ.'NE')THEN IF(DVAL(1).LT.1800..OR.DVAL(1).GT.2100.)THEN CALL STETER(ISTAT,'*** FATAL: Value of equinox1 not allowed') ELSE CALL STKWRD('EQUINOX',DVAL(1),2,1,KUN,IST) ENDIF C ELSE IF (NAME(1:2).EQ.'LA')THEN CALL STKWRC('LABEL',1,CVAL,INDX,LEN,KUN,IST) C ELSE IF (NAME(1:2).EQ.'DA')THEN DO 991, N=1,10 !double -> real RDUM(N) = DVAL(N) 991 CONTINUE ILEN = NEL(RDUM,3) DO 992, N=1,10 !double -> real DVAL(N) = RDUM(N) 992 CONTINUE IF(ILEN.LT.3)THEN !not enough input CALL STETER(ISTAT,'*** FATAL: Specify year,month,day') ELSE IF(DVAL(1).LT.1980.)THEN CALL STETER(ISTAT,'*** FATAL: Wrong year value') ELSE IF(DVAL(2).LT.0..OR.DVAL(2).GT.12.)THEN CALL STETER(ISTAT,'*** FATAL: Wrong month value') ELSE IF(DVAL(3).LT.0..OR.DVAL(3).GT.31.)THEN CALL STETER(ISTAT,'*** FATAL: Wrong day value') ELSE CALL STKWRD('DATE',DVAL(1),1,1,KUN,IST) CALL STKWRD('DATE',DVAL(2),2,1,KUN,IST) CALL STKWRD('DATE',DVAL(3),3,1,KUN,IST) C C *** calculate epoch from date C CALL EPOCH(DVAL(1),DVAL(2),DVAL(3),EPP) C C *** write epoch in keyword C CALL STKWRD('EPOCH',EPP,1,1,KUN,ISTAT) C ENDIF C ELSE IF(NAME(1:2).EQ.'EX')THEN IF(DVAL(1).LT.0.)THEN CALL STETER(ISTAT,'*** FATAL: Exposure time can`t be < 0 !!') ELSE CALL STKWRD('EXPTIME',DVAL(1),1,1,KUN,IST) ENDIF C ELSE IF(NAME(1:2).EQ.'WR')THEN ILEN = NEL(RVAL,2) IF(ILEN.LT.2)THEN !not enough input CALL STETER(ISTAT,'*** FATAL: Specify start and end of range') ELSE CALL STKWRD('LAMBDA',DVAL(1),1,1,KUN,IST) CALL STKWRD('LAMBDA',DVAL(2),2,1,KUN,IST) ENDIF C ELSE IF(NAME(1:2).EQ.'SI')THEN ILEN = NEL(RVAL,2) IF(ILEN.LT.2)THEN !not enough input CALL STETER(ISTAT,'*** FATAL: Specify start and end of observa 1tion slot') ELSE IF(RVAL(1).LT.0..OR.RVAL(1).GT.24.)THEN CALL STETER(ISTAT,'*** FATAL: Absurd start ST value!!') ELSE IF(RVAL(2).LT.0..OR.RVAL(2).GT.24.)THEN CALL STETER(ISTAT,'*** FATAL: Absurd end ST value!!') ELSE CALL STKWRD('STSLOT',DVAL(1),1,1,KUN,IST) CALL STKWRD('STSLOT',DVAL(2),2,1,KUN,IST) ENDIF C ELSE IF(NAME(1:2).EQ.'OS')THEN IF(RVAL(1).LT.0..OR.RVAL(1).GT.24.)THEN CALL STETER(ISTAT,'*** FATAL: ST must be in range 0 - 24 !') ELSE CALL STKWRD('SIDTIME',DVAL(1),1,1,KUN,IST) ENDIF C ELSE IF (NAME(1:2).EQ.'AC')THEN IF(CVAL(1:1).NE.'Y'.AND.CVAL(1:1).NE.'N')THEN CALL STETER(ISTAT, 2 '*** FATAL: AC-flag can be only either Y or N !!') ELSE CALL STKWRC('ACFLAG',1,CVAL(1:1),1,1,KUN,IST) ENDIF C ELSE IF (NAME(1:2).EQ.'PF')THEN IF(CVAL(1:1).NE.'Y'.AND.CVAL(1:1).NE.'N')THEN CALL STETER(ISTAT, 2 '*** FATAL: PREC-flag can be only either Y or N !!') ELSE CALL STKWRC('PFLAG',1,CVAL(1:1),1,1,KUN,IST) ENDIF C ELSE IF (NAME(1:2).EQ.'AS')THEN IF(CVAL(1:1).NE.'Y'.AND.CVAL(1:1).NE.'N')THEN CALL STETER(ISTAT, 2 '*** FATAL: AST-flag can be only either Y or N !!') ELSE CALL STKWRC('ASTFLAG',1,CVAL(1:1),1,1,KUN,IST) ENDIF C ELSE IF(NAME(1:2).EQ.'EW')THEN IF(CVAL(1:1).NE.'Y'.AND.CVAL(1:1).NE.'N')THEN CALL STETER(ISTAT, 2 '*** FATAL: EW-flag can be only either Y or N !!') ELSE CALL STKWRC('EWFLAG',1,CVAL(1:1),1,1,KUN,IST) ENDIF C ENDIF 10 CONTINUE C C *** over and out C CALL STSEPI END C C *** C SUBROUTINE DECAG(NAME,CINPUT,VALU1,FORM, 1 IVAL,RVAL,CVAL,INDX,LEN,IST) C+++ C.PURPOSE: Decode parameter in the contents C.AUTHOR: J.D Ponz, ESO-Garching C.COMMENTS: none C.VERSION: ?????? JDP creation C.VERSION: 890117 RHW convert to ST interfaces C.VERSION: 910621 AG modified for Optopus context C--- IMPLICIT NONE CHARACTER*(*) NAME ! IN: par name CHARACTER*(*) VALU1 ! IN: par value (blanks if defaulted) CHARACTER*(*) FORM ! IN: format CHARACTER*(*) CVAL ! OUT: character output REAL RVAL(10) ! OUT: real output INTEGER INDX ! OUT: array index INTEGER LEN ! OUT: output length INTEGER IVAL(10) ! OUT: integer output C C *** definition INTEGER NP PARAMETER (NP=14) INTEGER I, I1, IST INTEGER IND(NP) ! -- output index INTEGER LENGTH(NP) ! -- parameter length INTEGER MINL(NP) ! -- minimum matching length INTEGER NR CHARACTER*20 CDEF(NP) ! -- parameter defaults CHARACTER*1 FORM1(NP) ! -- parameter format CHARACTER*8 TEMPL(NP) ! -- parameter names CHARACTER*72 CINPUT,CINPU1 C DATA TEMPL/'CRA ','CDEC ','OLDEQ ', 5 'NEWEQ ','LABEL ','DATE ','EXTIM ', 6 'WRANGE ','SITSLT ','OST ','ACFLAG ', 7 'ASTFLAG ','EWFLAG ','PFLAG '/ DATA FORM1/'R' ,'C' ,'R', 5 'R' ,'C' ,'R' ,'R', 6 'R' ,'R' ,'R' ,'C', 7 'C' ,'C' ,'C'/ DATA MINL/ 2 ,2 ,2, 5 1 ,1 ,1 ,2, 6 1 ,2 ,2 ,2, 7 2 ,2 ,2/ DATA IND/ 1 ,4 ,1, 5 2 ,1 ,1 ,1, 6 1 ,1 ,1 ,1, 7 1 ,1 ,1/ DATA LENGTH/3 ,3 ,1, 5 1 ,40 ,3 ,1, 6 2 ,2 ,1 ,1, 7 1 ,1 ,1/ DATA CDEF/ '0.,0.,0.','0.,0.,0.','1950. ', 5 '2000. ','Optopus Plate','1999.,12.,31.', 6 '0. ','3800.,8000. ','0.,0. ', 7 '0. ','Y ','Y ','N ', 8 'Y '/ C C *** iterate on parameter names (minimum match) DO 10 I = 1,NP I1 = MINL(I) IF (NAME(1:I1).EQ.TEMPL(I)(1:I1)) THEN ! matching found FORM = FORM1(I) INDX = IND(I) LEN = LENGTH(I) IF (VALU1(1:1).EQ.' ') THEN CINPUT = CDEF(I) IF(NAME(1:2).EQ.'OL'.OR.NAME(1:2).EQ.'NE'.OR. 1 NAME(1:2).EQ.'DA')THEN IF(CINPUT(1:2).EQ.'19')THEN CINPU1 = CINPUT(3:72) ELSE IF(CINPUT(1:2).NE.'19')THEN CINPU1 = CINPUT(1:72) ENDIF ELSE CINPU1 = CINPUT(1:72) ENDIF ELSE CINPU1 = VALU1 ENDIF C IF (FORM(1:1).EQ.'C') THEN CVAL = CINPU1 IF (NAME(1:2).EQ.'XA') THEN IF (CVAL(1:1).NE.'A') THEN CVAL = 'MANU' CALL USRINP(RVAL,LEN,'R',CINPU1) ENDIF ELSE IF (NAME(1:2).EQ.'YA') THEN IF (CVAL(1:1).NE.'A') THEN CVAL = 'MANU' CALL USRINP(RVAL,LEN,'R',CINPU1) ENDIF ENDIF C ELSE IF (FORM(1:1).EQ.'I') THEN CALL USRINP(RVAL,LEN,'R',CINPU1) DO NR = 1,LEN IVAL(NR) = INT(RVAL(NR)) ENDDO C ELSE CALL USRINP(RVAL,LEN,'R',CINPU1) ENDIF RETURN ENDIF C 10 CONTINUE CALL STTPUT('*** FATAL: Illegal parameter name ... ',IST) IST = 1 C RETURN END C------------------------------------------------------------------------------- SUBROUTINE EPOCH(YEAR,MONTH,DAY,EPP) C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.PURPOSE: Calculate epoch from year, month and day. C.AUTHOR: Alessandra Gemmo Padova Department of Astronomy C.VERSION: 910827 AG Creation C.------------------------------------------------------------------------------ IMPLICIT NONE C C *** C DOUBLE PRECISION YEAR,MONTH,DAY DOUBLE PRECISION DAY1 DOUBLE PRECISION EPP,NDAYS DOUBLE PRECISION RES0,RES1 C C *** C DATA NDAYS/365./ C C *** C IF(YEAR.NE.0..AND.MONTH.EQ.0..AND.DAY.EQ.0.)THEN DAY1 = 0. ELSE IF(YEAR.NE.0..AND.MONTH.EQ.0..AND.DAY.NE.0.)THEN CALL STETER(9, 2 '*** FATAL: MONTH can`t be 0 if date not in decimals of year !') ELSE IF(YEAR.NE.0..AND.MONTH.NE.0..AND.DAY.EQ.0.)THEN CALL STETER(9, 2 '*** FATAL: DAY can`t be 0 if date not in decimals of year!') ENDIF IF(MONTH.EQ.1.)DAY1 = 0. + DAY IF(MONTH.EQ.2.)DAY1 = 31. + DAY IF(MONTH.EQ.3.)DAY1 = 59. + DAY IF(MONTH.EQ.4.)DAY1 = 90. + DAY IF(MONTH.EQ.5.)DAY1 = 120.+ DAY IF(MONTH.EQ.6.)DAY1 = 151.+ DAY IF(MONTH.EQ.7.)DAY1 = 181.+ DAY IF(MONTH.EQ.8.)DAY1 = 212.+ DAY IF(MONTH.EQ.9.)DAY1 = 243.+ DAY IF(MONTH.EQ.10.)DAY1= 273.+ DAY IF(MONTH.EQ.11.)DAY1= 304.+ DAY IF(MONTH.EQ.12.)DAY1= 334.+ DAY C RES0 = DMOD(YEAR,4.0D0) RES1 = DMOD(YEAR,4.0D2) IF(RES0.EQ.0..AND.RES1.NE.0.)NDAYS= 366. C EPP = DAY1/NDAYS+YEAR RETURN END C-------------------------------------------------------------------------------