C @(#)setopto.for	19.1 (ES0-DMD) 02/25/03 14:27:54
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	19.1 (ESO-IPG) 14:27:54 02/25/03
      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-------------------------------------------------------------------------------






