C @(#)midint.for	17.1.1.1 (ES0-DMD) 01/25/02 17:15:08
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 MIDINT.F - an interface between some IRAF F77/VOS routines and MIDAS
C
C Richard Hook, ST-ECF, August 1992
C
C This collection of routines is intended to ease the implementation of an IRAF
C F77/VOS application as a MIDAS program. However it is NOT intended to be a ful
C emulation. Almost all programs will require some 'MIDASification' for them to
C
      SUBROUTINE UMSPUT(STRING,ID1,ID2,ISTAT)
C
C Write out a string
C
      CHARACTER*(*) STRING
      INTEGER ID1,ID2,ISTAT
                           
      CALL STTPUT(STRING,ISTAT)
                               
      RETURN
      END
C
C Keyword reading routines. Note that these are just SCALAR
C versions and the VECTOR capacities of the MIDAS keyword system
C are ignored.
C
      SUBROUTINE UCLGST(KEY,STRING,ISTAT)
C
C Read in a string from a keyword
C
      CHARACTER*(*) KEY,STRING
      INTEGER ISTAT
                   
      INTEGER IACT,KUN,KNUL
                           
      CALL STKRDC(KEY,1,1,LEN(STRING),IACT,STRING,KUN,KNUL,ISTAT)
                                                                 
      RETURN
      END
         
      SUBROUTINE UCLGSI(KEY,VAL,ISTAT)
C
C Read in an integer from a keyword
C
      CHARACTER*(*) KEY
      INTEGER VAL
      INTEGER ISTAT
                   
      INTEGER IACT,KUN,KNUL
                           
      CALL STKRDI(KEY,1,1,IACT,VAL,KUN,KNUL,ISTAT)
                                                  
      RETURN
      END
         
      SUBROUTINE UCLGSR(KEY,VAL,ISTAT)
C
C Read in a real from a keyword
C
      CHARACTER*(*) KEY
      REAL VAL
      INTEGER ISTAT
                   
      INTEGER IACT,KUN,KNUL
                           
      CALL STKRDR(KEY,1,1,IACT,VAL,KUN,KNUL,ISTAT)
                                                  
      RETURN
      END
         
      SUBROUTINE UCLGSD(KEY,VAL,ISTAT)
C
C Read in a double from a keyword
C
      CHARACTER*(*) KEY
      DOUBLE PRECISION VAL
      INTEGER ISTAT
                   
      INTEGER IACT,KUN,KNUL
                           
      CALL STKRDD(KEY,1,1,IACT,VAL,KUN,KNUL,ISTAT)
                                                  
      RETURN
      END
         
      SUBROUTINE UCLGSB(KEY,VAL,ISTAT)
C
C Read in a logical from a keyword
C In this case we fudge things as MIDAS doesn't
C support logical keywords. We read a single character
C and check for y/n
C
      CHARACTER*(*) KEY
      LOGICAL VAL
      INTEGER ISTAT
      CHARACTER*1 TEMP
                      
      INTEGER IACT,KUN,KNUL
                           
      CALL STKRDC(KEY,1,1,1,IACT,TEMP,KUN,KNUL,ISTAT)
                                                     
      IF(TEMP.EQ.'Y' .OR. TEMP.EQ.'y') THEN
         VAL=.TRUE.
      ELSE IF (TEMP.EQ.'N' .OR. TEMP.EQ.'n') THEN
         VAL=.FALSE.
      ELSE
         VAL=.FALSE.
         CALL UMSPUT('Value should be Y/N - assuming N',
     :               1,0,ISTAT)
      ENDIF
           
      RETURN
      END
         
      SUBROUTINE UIMOPN(NAME,MODE,ID,ISTAT)
C
C Open an image, assumed to exist and to be opened readonly.
C
C We also assume that the MIDAS BDF is REAL
C
      IMPLICIT NONE
                   
      CHARACTER*(*) NAME
      INTEGER MODE
      INTEGER ID
      INTEGER ISTAT

      INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST'
      INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST'
                                          
                   
C Open the file
      CALL STFOPN(NAME,D_R4_FORMAT,1,F_IMA_TYPE,ID,ISTAT)
                                                         
      RETURN
      END
         
      SUBROUTINE UDMGET(NVALS,TYPE,POINT,ISTAT)
C
C Allocate a dynamic array of 'nvals' elements of type 'type'.
C
C Note that the array allocated by this routine cannot be
C deallocated except by the closing down of the application.
C The F77/VOS routine udmfre is just a dummy.
C
      IMPLICIT NONE
                                          
      INTEGER NVALS,TYPE,POINT,ISTAT
                   
      INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST'
      INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST'
                                    
      IF(TYPE.EQ.6) THEN
         CALL STFXMP(NVALS,D_R4_FORMAT,POINT,ISTAT)
      ELSE IF(TYPE.EQ.7) THEN
         CALL STFXMP(NVALS,D_R8_FORMAT,POINT,ISTAT)
      ELSE IF(TYPE.EQ.4) THEN
         CALL STFXMP(NVALS,D_I4_FORMAT,POINT,ISTAT)
      ELSE
         ISTAT=100
      ENDIF
           
      RETURN
      END
         
      SUBROUTINE UIGS2D(ID,X1,X2,Y1,Y2,DATA,ISTAT)
C
C Read a subset of a double precision 2d array into a given
C area of memory. We assume that the MIDAS BDF is REAL*4 and
C that it has been opened.
C
      IMPLICIT NONE
                   
      INTEGER MEMD(1)
      COMMON /VMR/MEMD
                                          
      INTEGER ID,X1,X2,Y1,Y2
      DOUBLE PRECISION DATA((X2-X1+1)*(Y2-Y1+1))
      INTEGER ISTAT
                   
      INTEGER NVALS,IACT,TP
                      
      INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST'
      INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST'
                           
      NVALS=(X2-X1+1)*(Y2-Y1+1)
                               
C Map the data into a temporary array as REAL*4s
      CALL STFMAP(ID,F_I_MODE,1,NVALS,IACT,TP,ISTAT)
      IF(ISTAT.NE.0) RETURN
                           
C Convert to double precision
      CALL RTODP(MEMD(TP),NVALS,DATA)
                                     
C Unmap the data and free the temporary array
      CALL STFUNM(ID,ISTAT)
                           
      RETURN
      END
         
      SUBROUTINE RTODP(IN,NVALS,OUT)
C
C Convert an array of numbers from REAL*4 to REAL*8
C
      IMPLICIT NONE
                   
      INTEGER NVALS
      REAL IN(NVALS)
      DOUBLE PRECISION OUT(NVALS)
                                 
      INTEGER I
               
      DO I=1,NVALS
         OUT(I)=DBLE(IN(I))
      ENDDO
           
      RETURN
      END
         
      SUBROUTINE UDMFRE(POINT,TYPE,ISTAT)
C
C Free dynamic memory - this routine is a dummy and
C does nothing at all.
C
      INTEGER POINT,TYPE,ISTAT
                              
      RETURN
      END
         
      SUBROUTINE UIMCLO(ID,ISTAT)
C
C Close an image
C
      INTEGER ID,ISTAT
                      
      CALL STFCLO(ID,ISTAT)
                           
      RETURN
      END
         
      SUBROUTINE UIMGID(ID,DATATYPE,NAXIS,DIMEN,ISTAT)
C
C Get basic information about an open image. Note that
C it is assumed that the image is REAL*4 (datatype=6)
C
      IMPLICIT NONE
                   
      INTEGER ID,DATATYPE,NAXIS,DIMEN(7),ISTAT
      INTEGER IACT,DUN,DNUL
                           
      DATATYPE=6
                
      CALL STDRDI(ID,'NAXIS',1,1,IACT,NAXIS,DUN,DNUL,ISTAT)
      CALL STDRDI(ID,'NPIX',1,NAXIS,IACT,DIMEN,DUN,DNUL,ISTAT)
                                                              
      RETURN
      END
         
      SUBROUTINE UIMCRE(NAME,DATATYPE,NAXIS,DIMEN,ID,ISTAT)
C
C Create an image file on disk. It will always be REAL*4 whatever
C the value of 'datatype' which is specified.
C
      IMPLICIT NONE
                   
      CHARACTER*(*) NAME
      INTEGER DATATYPE,NAXIS,DIMEN(NAXIS),ID,ISTAT
      INTEGER SIZE,I
      DOUBLE PRECISION START(7)

      INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST'
      INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST'
                                          
                               
      SIZE=1
      DO I=1,NAXIS
         SIZE=SIZE*DIMEN(I)
      ENDDO
           
      CALL STFCRE(NAME,D_R4_FORMAT,F_O_MODE,F_IMA_TYPE,
     :            SIZE,ID,ISTAT)
                                
C Now write some descriptors
      CALL STDWRI(ID,'NAXIS',NAXIS,1,1,1,ISTAT)
                                               
      CALL STDWRI(ID,'NPIX',DIMEN,1,NAXIS,1,ISTAT)
                                                  
      DO I=1,NAXIS
         START(I)=1.0D0
      ENDDO
           
      CALL STDWRD(ID,'START',START,1,NAXIS,1,ISTAT)
      CALL STDWRD(ID,'STEP',START,1,NAXIS,1,ISTAT)
                                                  
      CALL STDWRC(ID,'IDENT',1,'No IDENT available',1,18,1,ISTAT)
      CALL STDWRC(ID,'CUNIT',1,'No CUNIT available',1,18,1,ISTAT)
      RETURN
      END
         
      SUBROUTINE UIPS2R(ID,X1,X2,Y1,Y2,DATA,ISTAT)
C
C Write out a 2d subset array of values into what is assumed
C to be a 2d REAL*4 image
C
      IMPLICIT NONE
                                          
      INTEGER MEMD(1)
      COMMON /VMR/MEMD
                      
      INTEGER ID,X1,X2,Y1,Y2
      REAL DATA((X2-X1+1)*(Y2-Y1+1))
                                    
      INTEGER IACT,POINT,ISTAT
                   
      INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST'
      INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST'
                              
C First map the output image
      CALL STFMAP(ID,F_O_MODE,1,(X2-X1+1)*(Y2-Y1+1),IACT,
     :            POINT,ISTAT)
      IF(ISTAT.NE.0) RETURN
                           
C Copy the data from one array to the other
      CALL COPY2R(DATA,(X2-X1+1)*(Y2-Y1+1),MEMD(POINT))
                                                       
C Unmap the data
      CALL STFUNM(ID,ISTAT)
                           
      RETURN
      END
         
      SUBROUTINE UIPS2D(ID,X1,X2,Y1,Y2,DATA,ISTAT)
C
C Write out a 2d subset array of values into what is assumed
C to be a 2d REAL*4 image
C
      IMPLICIT NONE
                                          
      INTEGER MEMD(1)
      COMMON /VMR/MEMD
                      
      INTEGER ID,X1,X2,Y1,Y2
      DOUBLE PRECISION DATA((X2-X1+1)*(Y2-Y1+1))
                                                
      INTEGER IACT,POINT,ISTAT
                   
      INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST'
      INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST'
                              
C First map the output image
      CALL STFMAP(ID,F_O_MODE,1,(X2-X1+1)*(Y2-Y1+1),IACT,
     :            POINT,ISTAT)
      IF(ISTAT.NE.0) RETURN
                           
C Convert the data from double precision to single
      CALL DPTOR(DATA,(X2-X1+1)*(Y2-Y1+1),MEMD(POINT))
                                                      
C Unmap the data
      CALL STFUNM(ID,ISTAT)
                           
      RETURN
      END
         
      SUBROUTINE DPTOR(IN,NVALS,OUT)
C
C Convert an array from double precision to single
C
      INTEGER NVALS
      DOUBLE PRECISION IN(NVALS)
      REAL OUT(NVALS)
                     
      INTEGER I
               
      DO I=1,NVALS
         OUT(I)=SNGL(IN(I))
      ENDDO
           
      RETURN
      END
         
      SUBROUTINE COPY2R(IN,NVALS,OUT)
C
C Convert a real array into another
C
      INTEGER NVALS
      REAL IN(NVALS)
      REAL OUT(NVALS)
                     
      INTEGER I
               
      DO I=1,NVALS
         OUT(I)=IN(I)
      ENDDO
           
      RETURN
      END
         
      SUBROUTINE TIMOTP(CLIST,LIST,ISTAT)
C
C Emulate image list reading in a very crude way - no
C wildcard expansion is permitted.
C
      IMPLICIT NONE
                   
      CHARACTER*80 STRING
      INTEGER CURPOS
                    
      COMMON /TIM/STRING,CURPOS
                               
      CHARACTER*(*) CLIST
      INTEGER LIST,ISTAT
                        
      CURPOS=1
      STRING(1:80)=' '
      STRING=CLIST
                  
      RETURN
      END
         
      SUBROUTINE TIMXTP(LIST,VALUE,ISTAT)
C
C Get the next value from the character string list held
C in COMMON
C
      IMPLICIT NONE
                   
      CHARACTER*80 STRING
      INTEGER CURPOS
                    
      COMMON /TIM/STRING,CURPOS
                               
      INTEGER LIST
      CHARACTER*(*) VALUE
      INTEGER ISTAT
      INTEGER I,J,K
      INTEGER USEOF
                   
      PARAMETER (USEOF=-2)
                          
      I=CURPOS
      J=1
         
C If we start with nothing we are finished
      IF(STRING(CURPOS:CURPOS).EQ.' ') THEN
          ISTAT=USEOF
          RETURN
      ENDIF
           
      DO K=1,100
         IF(I.GT.80) GOTO 88
         IF(STRING(I:I).EQ.' ') THEN
            ISTAT=0
            RETURN
         ELSE IF(STRING(I:I).EQ.',') THEN
            CURPOS=CURPOS+1
            ISTAT=0
            RETURN
         ELSE
            VALUE(J:J)=STRING(I:I)
         ENDIF
              
         I=I+1
         J=J+1
         CURPOS=CURPOS+1
      ENDDO

 88   CONTINUE
           
      ISTAT=USEOF
                 
      RETURN
      END
         
      SUBROUTINE TIMCTP(LIST,ISTAT)
C
C Close the image list stuff - this is a dummy
C
      IMPLICIT NONE
      INTEGER LIST,ISTAT
      RETURN
      END