C @(#)iodev.for	17.1.1.1 (ES0-DMD) 01/25/02 17:57:37
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  (c)   1988   European Southern Observatory
C.IDENT      iodev.for
C.LANGUAGE   VAX/VMS FORTRAN-77
C.AUTHOR     P.Grosbol      ESO/IPG
C.KEYWORDS   VMS QIO, tape I/O
C.ENVIRON    VAX/VMS
C.COMMENT    Ref. to VAX/VMS I/O User's Guide Vol.1, Chap.7 for
C            status codes etc.
C.VERSION    1.0    1989-Mar-11 : Creation,  PJG
C--------------------------------------------------------------------
      INTEGER FUNCTION  IOOPEN(DEVICE,MODE,DEN)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.PURPOSE    Assign I/O channel to device
C.RETURN     I/O channel of OK else -1 if assign error
C--------------------------------------------------------------------
      INCLUDE    '($SYSSRVNAM)/NOLIST'
      INCLUDE    '($MNTDEF)/NOLIST'
      INCLUDE    '($IODEF)/NOLIST'
      INCLUDE    '($SSDEF)/NOLIST'
C
      CHARACTER*(*)   DEVICE
      CHARACTER*32    DEV
      INTEGER         MODE
      INTEGER         DEN
C
      INTEGER         STATUS
      INTEGER         TDEN,FLAG,SIZ
      INTEGER*2       QIO_CHAN
      INTEGER*2       W_L1,W_L2,W_L3,W_L4,W_L5,W_L6,W_L7
      INTEGER*2       W_F1,W_F2,W_F3,W_F4,W_F5,W_F6,W_F7
      INTEGER         L_A1,L_A2,L_A3,L_A4,L_A5,L_A6,L_A7
      INTEGER         L_T1,L_T2,L_T3,L_T4,L_T5,L_T6,L_T7
      COMMON /MNTL/
     1             W_L1,W_F1,L_A1,L_T1,
     2             W_L2,W_F2,L_A2,L_T2,
     3             W_L3,W_F3,L_A3,L_T3,
     4             W_L4,W_F4,L_A4,L_T4,
     5             W_L5,W_F5,L_A5,L_T5,
     6             W_L6,W_F6,L_A6,L_T6,
     7             W_L7,W_F7,L_A7,L_T7
      COMMON /DEVNAM/DEV
C
C     CHECK IF DEVICE NAME HAS A ':' ELSE INSERT ONE
C
      N = INDEX(DEVICE,' ')
      IF (DEVICE(N-1:N-1).NE.':') DEVICE(N:N) = ':'
      DEV = DEVICE(1:N)
C
C     SETUP PARAMETERS FOR MOUNT
C
      SIZ = 32000
      TDEN = DEN
      FLAG = IOR(MNT$M_FOREIGN,MNT$M_NOLABEL)
      W_L1 = N
      W_F1 = MNT$_DEVNAM
      L_A1 = %LOC(DEVICE)
      L_T1 = 0
      W_L2 = 4
      W_F2 = MNT$_FLAGS
      L_A2 = %LOC(FLAG)
      L_T2 = 0
      W_L3 = 4
      W_F3 = MNT$_DENSITY
      L_A3 = %LOC(TDEN)
      L_T3 = 0
      W_L4 = 4
      W_F4 = MNT$_BLOCKSIZE
      L_A4 = %LOC(SIZ)
      L_T4 = 0
      W_L5 = 4
      W_F5 = MNT$_RECORDSIZ
      L_A5 = %LOC(SIZ)
      L_T5 = 0
      W_L6 = 0
      W_F6 = 0
      L_A6 = 0
      L_T6 = 0
      W_L7 = 0
      W_F7 = 0
      L_A7 = 0
      L_T7 = 0
C
C     MOUNT DEVICE
C
      STATUS = SYS$MOUNT(W_L1)
      STATUS = IAND(STATUS,'FFFF'X)
      IF (STATUS.NE.SS$_NORMAL.AND.STATUS.NE.SS$_DEVMOUNT) THEN
         IOOPEN = -1
         RETURN
      ENDIF
      IF (STATUS.EQ.SS$_DEVMOUNT) THEN
         WRITE(6,600)
  600    FORMAT(' Warning: Device already mounted')
      ENDIF
C
C     ASSIGN TAPE TO CHANNEL
C
      STATUS = SYS$ASSIGN(DEVICE(1:N),QIO_CHAN,,)
      IF (STATUS.EQ.SS$_NORMAL) THEN
         IOOPEN = QIO_CHAN
      ELSE
         IOOPEN = -1
      ENDIF
      RETURN
      END
C-------------------------------------------------------------------
      INTEGER FUNCTION  IOCLOSE(FD)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.PURPOSE    Deassign or close I/O channel to device
C.RETURN     0: OK ,else  -1: error
C--------------------------------------------------------------------
      INCLUDE    '($SYSSRVNAM)/NOLIST'
      INCLUDE    '($DMTDEF)/NOLIST'
      INCLUDE    '($IODEF)/NOLIST'
      INCLUDE    '($SSDEF)/NOLIST'
C
      CHARACTER*32  DEV
      INTEGER       FD
C
      INTEGER       STATUS
      INTEGER*2     QIO_CHAN,IOSB(4)
C
      COMMON /DEVNAM/DEV
C
      QIO_CHAN = FD
      STATUS = SYS$QIOW(,%VAL(QIO_CHAN),%VAL(IO$_REWIND),
     ,                  IOSB,,,,,,,,)
      STATUS = SYS$DASSGN(%VAL(QIO_CHAN))
      IF (STATUS.NE.SS$_NORMAL) THEN
         IOCLOSE = -1
         RETURN
      ENDIF
      STATUS = SYS$DISMOU(DEV,%VAL(DMT$M_NOUNLOAD))
      IOCLOSE = 0
      RETURN
      END
C-------------------------------------------------------------------
      INTEGER FUNCTION  IOREAD(FD,BUF,NO)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.PURPOSE    Read data from a VMS I/O-channel
C.RETURN     no. of bytes read if OK 
C            else 0: EOF, -2: QIO error
C--------------------------------------------------------------------
      INCLUDE    '($SYSSRVNAM)/NOLIST'
      INCLUDE    '($IODEF)/NOLIST'
      INCLUDE    '($SSDEF)/NOLIST'
C
      INTEGER     FD
      LOGICAL*1   BUF
      INTEGER     NO
C
      INTEGER     STATUS
      INTEGER*2   QIO_CHAN,IOSB(4)
C
      QIO_CHAN = FD
      STATUS = SYS$QIOW(,%VAL(QIO_CHAN),%VAL(IO$_READLBLK),
     ,                  IOSB,,,BUF,%VAL(NO),,,,)
      IOREAD = IOSB(2)
      IF (IOSB(1).EQ.SS$_ENDOFFILE) IOREAD = 0
      IF (STATUS.NE.SS$_NORMAL) IOREAD = -1
      RETURN
      END
C-----------------------------------------------------------------
      INTEGER FUNCTION  IOWRITE(FD,BUF,NO)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.PURPOSE    Write data to a VMS I/O-channel
C.RETURN     no. of bytes written if OK 
C            else -1: EOT, -2: QIO error, -3: Timeout
C-------------------------------------------------------------------
      INCLUDE    '($SYSSRVNAM)/NOLIST'
      INCLUDE    '($IODEF)/NOLIST'
      INCLUDE    '($SSDEF)/NOLIST'
C
      INTEGER     FD
      LOGICAL*1   BUF
      INTEGER     NO
C
      INTEGER     STATUS
      INTEGER*2   QIO_CHAN,IOSB(4)
C
      QIO_CHAN = FD
      STATUS = SYS$QIOW(,%VAL(QIO_CHAN),%VAL(IO$_WRITELBLK),
     ,                  IOSB,,,BUF,%VAL(NO),,,,)
      IOWRITE = IOSB(2)
      IF (STATUS.NE.SS$_NORMAL.OR.
     .    IOSB(1).EQ.SS$_ENDOFTAPE.OR.
     .    IOSB(1).EQ.SS$_TIMEOUT) IOWRITE = -1
      RETURN
      END
C-----------------------------------------------------------------
      INTEGER FUNCTION  IOWEOF(FD)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.PURPOSE    Write EOF's on tape assigned to a VMS I/O-channel
C.RETURN     0: OK ,else -1: QIO error, -2: EOT
C-------------------------------------------------------------------
      INCLUDE    '($SYSSRVNAM)/NOLIST'
      INCLUDE    '($IODEF)/NOLIST'
      INCLUDE    '($SSDEF)/NOLIST'
C
      INTEGER     FD
C
      INTEGER     STATUS
      INTEGER*2   QIO_CHAN,IOSB(4)
C
      QIO_CHAN = FD
      STATUS = SYS$QIOW(,%VAL(QIO_CHAN),%VAL(IO$_WRITEOF),
     ,                  IOSB,,,,,,,,)
      IOWEOF = 0
      IF (STATUS.NE.SS$_NORMAL.OR.
     .    IOSB(1).EQ.SS$_ENDOFTAPE) IOWEOF = -1
      RETURN
      END
C-------------------------------------------------------------------
      INTEGER FUNCTION  IOREW(FD)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.PURPOSE    Rewind tape assigned to a VMS I/O-channel.
C.RETURN     0: OK , -1: QIO error
C-------------------------------------------------------------------
      INCLUDE    '($SYSSRVNAM)/NOLIST'
      INCLUDE    '($IODEF)/NOLIST'
      INCLUDE    '($SSDEF)/NOLIST'
C
      INTEGER     FD
C
      INTEGER     STATUS
      INTEGER*2   QIO_CHAN,IOSB(4)
C
      QIO_CHAN = FD
      STATUS = SYS$QIOW(,%VAL(QIO_CHAN),%VAL(IO$_REWIND),
     ,                  IOSB,,,,,,,,)
      IOREW = 0
      IF (STATUS.NE.SS$_NORMAL) IOREW = -1
      RETURN
      END
C-------------------------------------------------------------------
      INTEGER FUNCTION  IOSF(FD,NO)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.PURPOSE    Skip files on tape assigned to a VMS I/O-channel
C.RETURN     0: OK , -1: QIO error
C-------------------------------------------------------------------
      INCLUDE    '($SYSSRVNAM)/NOLIST'
      INCLUDE    '($IODEF)/NOLIST'
      INCLUDE    '($SSDEF)/NOLIST'
C
      INTEGER     FD
      INTEGER     NO
C
      INTEGER     STATUS
      INTEGER*2   QIO_CHAN,IOSB(4)
C
      QIO_CHAN = FD
      STATUS = SYS$QIOW(,%VAL(QIO_CHAN),%VAL(IO$_SKIPFILE),
     ,                  IOSB,,,%VAL(NO),,,,,)
      IOSF = 0
      IF (STATUS.NE.SS$_NORMAL) IOSF = -1
      RETURN
      END
C-------------------------------------------------------------------
      INTEGER FUNCTION  IOSR(FD,NO)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.PURPOSE    Skip files on tape assigned to a VMS I/O-channel
C.RETURN     0: OK , -1: QIO error
C-------------------------------------------------------------------
      INCLUDE    '($SYSSRVNAM)/NOLIST'
      INCLUDE    '($IODEF)/NOLIST'
      INCLUDE    '($SSDEF)/NOLIST'
C
      INTEGER     FD
      INTEGER     NO
C
      INTEGER     STATUS
      INTEGER*2   QIO_CHAN,IOSB(4)
C
      QIO_CHAN = FD
      STATUS = SYS$QIOW(,%VAL(QIO_CHAN),%VAL(IO$_SKIPRECORD),
     ,                  IOSB,,,%VAL(NO),,,,,)
      IOSR = 0
      IF (STATUS.NE.SS$_NORMAL) IOSR = -1
      RETURN
      END
C-------------------------------------------------------------------
      INTEGER FUNCTION IOFSF(FD,NO)
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.PURPOSE    Forward Skip Files on tape assigned to a VMS I/O-channel
C.RETURN     0: OK , -1: QIO error
C--------------------------------------------------------------------
      INTEGER     FD
      INTEGER     NO
C
      IOFSF = IOSF(FD,NO)
      RETURN
      END
C-------------------------------------------------------------------
      INTEGER FUNCTION IOBSF(FD,NO)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.PURPOSE    Backward Skip Files on tape assigned to a VMS I/O-channel
C.RETURN     0: OK , -1: QIO error
C-------------------------------------------------------------------
      INTEGER     FD
      INTEGER     NO
C
      IOBSF = IOSF(FD,-NO)
      RETURN
      END
C-------------------------------------------------------------------
      INTEGER FUNCTION IOFSR(FD,NO)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.PURPOSE    Forward Skip Files on tape assigned to a VMS I/O-channel
C.RETURN     0: OK , -1: QIO error
C-------------------------------------------------------------------
      INTEGER     FD
      INTEGER     NO
C
      IOFSR = IOSR(FD,NO)
      RETURN
      END
C-------------------------------------------------------------------
      INTEGER FUNCTION IOBSR(FD,NO)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.PURPOSE    Bachward Skip Record on tape assigned to a VMS I/O-channel
C.RETURN     0: OK , -1: QIO error
C---------------------------------------------------------------------
      INTEGER     FD
      INTEGER     NO
C
      IOBSR = IOSR(FD,-NO)
      RETURN
      END