C @(#)dtasubs.for	17.1.1.1 (ES0-DMD) 01/25/02 17:14:07
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=======================================================================
C
C This file contains VAX/VMS specific subroutines relating to the
C input and output of data from Keith Shortridge's old Caltech
C DTA_-style images.
C
C Peter B. Stetson                         1991 April 18
C
C***********************************************************************
C
C Current contents (A * designates a subroutine called directly by
C      a DAOPHOT command.  The others are called from within other
C      subroutines.)
C
C * ATTACH  interprets an ATTACH command and opens a picture.
C
C    CLPIC  closes a picture file.
C
C  COPYPIC  creates a new picture file that is an exact copy of the
C           currently open picture file, and opens the copy.
C
C  DELEPIC  deletes a disk picture file.
C
C *   LIST  allows the user to examine the contents of a picture
C           file header.  
C              *** Written by Keith Shortridge, Caltech ***
C
C   RDARAY  reads a rectangular data subarray from a picture file.
C
C   WRARAY  writes a rectangular data subarray into a picture file.
C
C   INFILE  opens a disk data file for reading only.
C
C  OUTFILE  creates a new disk data file and opens it for writing.
C
C   CLFILE  closes a disk data file.
C
C   RDHEAD  reads the header from a disk data file.
C
C   WRHEAD  writes a header into a disk data file.
C
C***********************************************************************
C
      SUBROUTINE  ATTACH (NAFILE, OPEN)
C
C=======================================================================
C 
C VAX/VMS-specific subroutine for opening a disk file containing a
C CCD picture.  Uses Shortridge's DTA_ routines, and assumes that
C the picture is in a Shortridge-Caltechesque data structure.
C
C Arguments
C
C NAFILE (INPUT/OUTPUT) is the VMS filename of the desired input 
C        picture.  If the character string NAFILE does not contain a 
C        filename extension, the filename extension '.DST' will be 
C        supplied.
C
C   OPEN (INPUT/OUTPUT) is a logical variable.  It is .TRUE. while
C        a picture file is open.
C
C When the file 'NAFILE' is opened, the structure it contains is given 
C the top-level name 'IMAGE'
C
C=======================================================================
C
      CHARACTER*64 ERROR, OBJECT
      CHARACTER*30 NAFILE, COOFILE, MAGFILE, PSFFILE, PROFILE, EXTEND
      CHARACTER*30 GRPFILE, SWITCH
      CHARACTER*1 BELL
      REAL*4 DATA(2)
      LOGICAL*1 NAMED, OPEN
      COMMON /FILENAM/ COOFILE, MAGFILE, PSFFILE, PROFILE, GRPFILE
      COMMON /SIZE/ NCOL, NROW
      DATA BELL / 7 /
C
C-----------------------------------------------------------------------
C
      IF (OPEN) THEN
         CALL DTA_FCLOSE ('DATA', ISTAT)
         OPEN=.FALSE.
      END IF
C
C If NAFILE wasn't defined in the ATTACH command line, ask for it here.
C
      IF (NAFILE .EQ. ' ') CALL TBLANK              ! Type a blank line
      IF (NAFILE .EQ. ' ') CALL GETNAME ('Enter file name:', NAFILE)
      IF (NAFILE .EQ. 'END OF FILE') RETURN         ! CTRL-Z was entered
C
C If no filename extension is specified, provide the filename extension
C '.DST'.
C
C Open the file.
C
      CALL DTA_ASFNAM ('DATA', EXTEND(NAFILE, 'DST'), 'OLD', 0, 
     .     'IMAGE', ISTAT)
      IF (ISTAT .NE. 0) GO TO 9100
      OPEN=.TRUE.
C
C Assign initial default filenames for use later.
C
      COOFILE=SWITCH(NAFILE, '.COO')
      MAGFILE=SWITCH(NAFILE, '.AP')
      PSFFILE=SWITCH(NAFILE, '.PSF')
      PROFILE=SWITCH(NAFILE, '.NST')
      GRPFILE=SWITCH(NAFILE, '.GRP')
C
C Read object designation from file.  If object DATA.OBS.COMMENT does 
C not exist, try DATA.OBS.OBJECT.
C
      CALL DTA_RDVARC ('DATA.OBS.COMMENT', 70, OBJECT, ISTAT)
      IF (ISTAT .NE. 0) CALL DTA_RDVARC ('DATA.OBS.OBJECT', 70, 
     .     OBJECT, ISTAT)
      IF (ISTAT .EQ. 0) WRITE (6,610) OBJECT
  610 FORMAT (/9X, A64/)
C
C Read image dimensions from file.
C
      CALL DTA_RDVARI ('DATA.Z.NAXIS1', 1, NCOL, ISTAT)
      IF (ISTAT .NE. 0) GO TO 9000
      CALL DTA_RDVARI ('DATA.Z.NAXIS2', 1, NROW, ISTAT)
      IF (ISTAT .NE. 0) GO TO 9000
      WRITE (6,611) NCOL, NROW
  611 FORMAT (38X, 'Picture size: ', 2I5)
      RETURN                                             ! Normal return
C
C-----------------------------------------------------------------------
C
C Minor problem:  file header appears to contain no information on 
C picture size.
C
 9000 CALL GETDATA ('Picture size (columns, rows):', DATA, 2)
      IF ((DATA(1) .LE. 0.) .OR. (DATA(2) .LE. 0)) GO TO 9200
      NCOL=JNINT(DATA(1))
      NROW=JNINT(DATA(2))
      RETURN                                             ! Normal return
C
C-----------------------------------------------------------------------
C
C Irrecoverable errors.
C
C Unable to open picture file.
C
 9100 CALL DTA_ERROR (ISTAT, ERROR)
      WRITE (6,691) BELL, ERROR
  691 FORMAT (/1X, A1, A70)
      RETURN
C
C Invalid picture size.
C
 9200 CALL DTA_FCLOSE ('DATA', ISTAT)
      OPEN=.FALSE.
      RETURN
C
      END!
C
C#######################################################################
C
      SUBROUTINE  CLPIC (ENVIRO)
C
C=======================================================================
C
C VAX/VMS-specific subroutine for closing a Shortridge/Caltech data
C structure.
C
C Argument
C
C ENVIRO (INPUT) is the top-level environment name of the file.
C
C=======================================================================
C
      CHARACTER*70 ERROR
      CHARACTER*4 ENVIRO
      CHARACTER*1 BELL
      DATA BELL / 7 /
C
C-----------------------------------------------------------------------
C
      CALL DTA_FCLOSE (ENVIRO, ISTAT)
      IF (ISTAT .NE. 0) GO TO 9100
      RETURN                                             ! Normal return
C
C-----------------------------------------------------------------------
C
C Irrecoverable error:  unable to close the file.
C
 9100 CALL DTA_ERROR (ISTAT, ERROR)
      WRITE (6,691) BELL, ERROR
  691 FORMAT (1X, A1, A70)
      RETURN
C
      END!
C
C#######################################################################
C
      SUBROUTINE  COPYPIC (NEWPICT, IST)
C
C=======================================================================
C
C DTA_ compatible subroutine for making an exact copy of a data 
C structure in a new disk file.
C
C Arguments
C
C NEWPICT (INPUT) is a character string containing the filename for 
C         the new copy of the picture.
C
C     IST (OUTPUT) is an error flag.  If all goes well IST = 0, 
C         otherwise not.
C
C The original CCD picture has the environment name DATA.
C 
C=======================================================================
C
      CHARACTER*70 ERROR
      CHARACTER*30 NEWPICT, EXTEND
      CHARACTER*6 ROUTINE
      CHARACTER*5 TYPE
      CHARACTER*1 BELL
      COMMON /SIZE/ NCOL, NROW
      DATA BELL / 7 /
C
C-----------------------------------------------------------------------
C
C Determine whether the source picture contains INTEGER*2, INTEGER*4, 
C or REAL*4 data.
C
      CALL DTA_TYVAR ('DATA.Z.DATA', TYPE, ISTAT)
      IST=ISTAT
      IF (ISTAT .NE. 0) GO TO 9100
      IF (TYPE .EQ. 'SHORT') THEN
         NBYTES=2
      ELSE IF (TYPE .EQ. 'INT') THEN
         NBYTES=4
      ELSE IF (TYPE .EQ. 'FLOAT') THEN
         NBYTES=4 
      ELSE 
         GO TO 9200
      END IF
      NBLOCKS=(NBYTES*NCOL*NROW+511)/512+15
      CALL DTA_ASFNAM ('COPY', EXTEND(NEWPICT, 'DST'), 'NEW', NBLOCKS, 
     .     'IMAGE', ISTAT)
      IST=ISTAT
      IF (ISTAT .NE. 0) THEN
         ROUTINE='ASFNAM'
         GO TO 9100
      END IF
      CALL DTA_CYVAR ('DATA', 'COPY', ISTAT)
      IST=ISTAT
      IF (ISTAT .NE. 0) THEN
         ROUTINE=' CYVAR'
         GO TO 9100
      END IF
      RETURN                                             ! Normal return
C
C-----------------------------------------------------------------------
C
C Irrecoverable error.
C
 9100 CALL DTA_ERROR (ISTAT, ERROR)
      WRITE (6,691) ROUTINE, BELL, ERROR
  691 FORMAT (/1X, 'COPYPIC:', A6, A1, A65)
      ACCEPT *
      RETURN
 9200 WRITE (6,692) BELL, TYPE
  692 FORMAT (/1X, 'Data are not INTEGER*2, INTEGER*4, nor REAL*4: ', 
     .     A1, A5/)
      IST=999
      RETURN
C
      END!
C
C#######################################################################
C
      SUBROUTINE  DELEPIC (FILE, IFLAG)
C
C=======================================================================
C
C Simple subroutine to delete a disk picture file.  File must be closed
C before DELEPIC is called.
C
C Arguments
C
C  FILE (INPUT) is the disk filename of the file to be deleted.
C
C IFLAG (OUTPUT) is an error flag.  If all goes well IFLAG = 0,
C       otherwise not.
C
C=======================================================================
C
      CHARACTER*30 FILE
C
C-----------------------------------------------------------------------
C
      IFLAG=0
      OPEN (9, FILE=FILE, STATUS='OLD', ERR=9100)
      CLOSE (9, STATUS='DELETE', ERR=9100)
      RETURN                                             ! Normal return
C
C-----------------------------------------------------------------------
C
C Irrecoverable error.
C
 9100 IFLAG=1
      RETURN
C
      END!
C
C#######################################################################
C
      SUBROUTINE  LIST(FILE)
C
C VAX/VMS-specific routine for examining the file header of a
C Shortridge/Caltech data structure.
C
      IMPLICIT NONE
      CHARACTER FILE*30,ENVIRO*64,TYPE*16
C======================================================================
      INTEGER NEXT
C
C+
C     D T A _ T C O N 
C
C     Conversion type codes for the various supported
C     VAX data types.  These are the same codes as used
C     by STL_FMTCON, the Starlink general type conversion
C     routine.
C
C     Also type codes for the various types supported by
C     the data structure routines, as defined in Starlink
C     paper SGP18.
C
C                                   KS / CIT  26th Oct 1982
C
C I have changed some I/O for appearance and consistency with DAOPHOT.
C                                         Peter B. Stetson
C+
      INTEGER TYP_BYTE,TYP_WORD,TYP_LONG,TYP_REAL
      INTEGER TYP_DBLE,TYP_CHAR
      PARAMETER (TYP_BYTE=1,TYP_WORD=2,TYP_LONG=3,
     :           TYP_REAL=4,TYP_DBLE=5,TYP_CHAR=0)
C
      INTEGER TYP_DSBIT,TYP_DSBYTE,TYP_DSSHORT,TYP_DSINT
      INTEGER TYP_DSLONG,TYP_DSFLOAT,TYP_DSDOUBLE
      INTEGER TYP_DSCHAR,TYP_DSFILE,TYP_DSTRUCT
      PARAMETER (TYP_DSBIT=1,TYP_DSBYTE=2,TYP_DSSHORT=3,
     :           TYP_DSINT=4,TYP_DSLONG=5,TYP_DSFLOAT=6,
     :           TYP_DSDOUBLE=7,TYP_DSCHAR=8,TYP_DSFILE=9,
     :           TYP_DSTRUCT=0)
C+
C     D T A _ T Y P E S
C
C     Definitions for possible data types.
C
C     TYPES   (Character) Type names
C     TSIZE   (Integer)   Type sizes in bytes.
C     TCODES  (Integer)   Type code for conversion
C
C     Note that the code for each type is its position
C     in the names array, but these do not map in a one-to-
C     one manner to the type conversion codes.
C
C                                     KS / CIT 25th Oct 1982
C+
      INTEGER NTYPES
      PARAMETER (NTYPES=9)
C
      CHARACTER*(6) TYPES(NTYPES)
      INTEGER TSIZE(NTYPES),TCODE(NTYPES)
C
      DATA TYPES/'BIT      ','BYTE     ','SHORT    ','INT      ',
     :           'LONG     ','FLOAT    ','DOUBLE   ','CHAR     ',
     :           'FILE     '/
      DATA TSIZE/ 1         , 1         , 2         , 4         ,
     :            4         , 4         , 8         , 1         ,
     :            1/
      DATA TCODE/ TYP_BYTE  , TYP_BYTE  , TYP_WORD  , TYP_LONG  ,
     :            TYP_LONG  , TYP_REAL  , TYP_DBLE  , TYP_CHAR  ,
     :            TYP_CHAR/
C
C
C     Functions
C
      INTEGER ICH_DELIM,ICH_VERIF,INDEX,LEN,ICH_LEN,MIN
C
C     Local variables
C
      INTEGER IST,LST,NPRINT
      INTEGER STATUS,NDIM,DIMS(10),ITYPE,I,ITEMS,IPOS
      CHARACTER CNAME*16,ERROR*64
C
C     Data buffer
C
      DOUBLE PRECISION DBUFF(40)
      REAL FBUFF(40)
      INTEGER IBUFF(40)
      INTEGER*2 SBUFF(40)
      BYTE BBUFF(40)
      EQUIVALENCE (FBUFF(1),DBUFF(1)),(IBUFF(1),DBUFF(1))
      EQUIVALENCE (SBUFF(1),DBUFF(1)),(BBUFF(1),DBUFF(1))
C======================================================================
 	WRITE (6,600) FILE
 600	FORMAT(/'      File = ', A30)
 	ENVIRO='DATA'
 1000	 CALL DTA_TYVAR(ENVIRO,TYPE,STATUS)
      IF (STATUS.NE.0) GO TO 999
      CALL DTA_SZVAR(ENVIRO,10,NDIM,DIMS,STATUS)
      IF (STATUS.NE.0)  GO TO 999
      IF (NDIM.NE.0) THEN
         ITEMS=MIN(5,NDIM)
      END IF
C
C     Values. First get type code.
C
      DO I=1,NTYPES
         IF (TYPE.EQ.TYPES(I)) THEN
            ITYPE=I
            GO TO 320
         END IF
      END DO
      ITYPE=TYP_DSTRUCT
  320 CONTINUE
C
C     Max number of elements?
C
      ITEMS=1
      IF (NDIM.GT.0) THEN
         DO I=1,NDIM
            ITEMS=ITEMS*DIMS(I)
         END DO
      END IF
      ITEMS=MIN(ITEMS,40)
C
C     If a specific element was given, only use that one
C
c      IF (INDEX(ENVIRO,'[').NE.0) ITEMS=1
C
C     If object is a structure, treat it differently
C
      IF (ITYPE.EQ.TYP_DSTRUCT) THEN
         STATUS=0
         IPOS=1
         DO WHILE (STATUS.EQ.0)
            CALL DTA_NMVAR(ENVIRO,IPOS,CNAME,STATUS)
            IF (STATUS.EQ.0) THEN
               IF (IPOS.EQ.1) THEN
 	WRITE(6,605)CNAME
 605	FORMAT(/' Components: ',A16)
               ELSE
 	WRITE(6,606)CNAME
 606	FORMAT ('             ',A16)
               END IF
               IPOS=IPOS+1
             END IF
         END DO
      ELSE
C
C     For ordinary data, list values
C
         CALL DTA_RDVAR(ENVIRO,ITEMS,ITYPE,DBUFF,STATUS)
         IF (STATUS.NE.0)  GO TO 999
C
C        List format depends on type
C
         GO TO(360, 360,  370,380, 380,  390,   401, 410, 410),ITYPE
C              bit byte short int long float double char file
C
C        Bits / bytes
C
  360    CONTINUE
         NPRINT=MIN(ITEMS,8)
 	WRITE(6,607)(BBUFF(I),I=1,NPRINT)
 607	FORMAT(/'             ',8I4)
         IF(ITEMS.GT.8)WRITE(6,608)(BBUFF(I),I=9,ITEMS)
 608	FORMAT('             ',8I4)
         GO TO 450
C
C        Short
C
  370    CONTINUE
         NPRINT=MIN(ITEMS,6)
 	WRITE(6,609)(SBUFF(I),I=1,NPRINT)
 609	FORMAT (/'             ',6I7)
         IF (ITEMS.GT.6)WRITE(6,610)(SBUFF(I),I=7,ITEMS)
 610	FORMAT ('             ',6I7)
         GO TO 450
C
C        Int / long
C
  380    CONTINUE
         NPRINT=MIN(ITEMS,4)
         WRITE(6,611)(IBUFF(I),I=1,NPRINT)
 611	FORMAT (/'             ',4I12)
         IF (ITEMS.GT.4)WRITE(6,612)(IBUFF(I),I=5,ITEMS)
 612	FORMAT ('             ',4I12)
         GO TO 450
C
C        Float
C
  390    CONTINUE
         NPRINT=MIN(ITEMS,4)
 	WRITE(6,613)(FBUFF(I),I=1,NPRINT)
 613	FORMAT (/'             ',4G13.4)
         IF (ITEMS.GT.4)WRITE(6,614)(FBUFF(I),I=5,ITEMS)
 614	FORMAT ('             ',4G13.4)
         GO TO 450
C
C        Double
C
  401    CONTINUE
         NPRINT=MIN(ITEMS,4)
 	WRITE(6,613)(DBUFF(I),I=1,NPRINT)
         IF (ITEMS.GT.4)WRITE(6,614)(DBUFF(I),I=5,ITEMS)
         GO TO 450
C
C        Char / File
C
  410    CONTINUE
         CALL ICN_CLEAN(BBUFF,40)
 	WRITE(6,615)(BBUFF(I),I=1,ITEMS)
 615	FORMAT (/'             ',40A1)
C
  450    CONTINUE
      END IF
C
C     Normal end
C
 6001	WRITE(6,616)
 616	FORMAT(/'$LIST> ')
 	READ(5,500,ERR=6001,END=9999)ENVIRO
 500	FORMAT(A64)
 	IF(ENVIRO(1:4).EQ.'    ')GO TO 9600
        ENVIRO='DATA.'//ENVIRO
      GO TO 1000
C
C     Status error from DTA_ routine
C
  999 CONTINUE
      CALL DTA_ERROR(STATUS,ERROR)
      PRINT *
      PRINT *,ERROR
      GO TO 6001
C
 9600 CONTINUE
 9999 RETURN
      END!
C
C#######################################################################
C
      SUBROUTINE  RDARAY (ENVIRO, LX, LY, MX, MY, NX, FUNC, IFLAG)
C
C=======================================================================
C
C Read a rectangular subarray from the CCD picture and return it to
C the main program in the two-dimensional array FUNC.
C
C Input arguments:
C
C ENVIRO  top-level environment name from which data are to be taken.
C
C LX, LY  desired coordinates in big picture of corner of subarray-- 
C         smallest value of X and smallest value of Y.
C
C MX, MY  desired number of columns and rows in the subarray.
C
C     NX  maximum number of columns in big picture; needed for DIMENSION
C         statement.
C
C Output arguments:
C
C LX, LY, MX, MY will be changed if their input values would run beyond 
C         the bounds of the big picture.
C
C   FUNC  is the name of the output array.
C
C  IFLAG  is an error flag.  IFLAG=0 if all goes well.  Not if 
C         otherwise.
C
C=======================================================================
C
      CHARACTER*70 ERROR
      CHARACTER*64 DATA
      CHARACTER*30 FILE
      CHARACTER*4 ENVIRO
      CHARACTER*1 BELL
      REAL*4 FUNC(NX,1)
      INTEGER*4 IDIMS(2)
      COMMON /SIZE/ NCOL, NROW
      DATA BELL / 7 /
C
C-----------------------------------------------------------------------
C
C Check whether the desired subarray is wholly within the original
C picture.  If not, reset LX, LY, MX, and/or MY accordingly.
C
      MX=LX+MX-1                                      ! Upper limit in X
      MY=LY+MY-1                                      ! Upper limit in Y
      IF (LX .LT. 1) LX=1
      IF (LY .LT. 1) LY=1
      IF (MX .GT. NCOL) MX=NCOL
      IF (MY .GT. NROW) MY=NROW
      MX=MX-LX+1                                 ! Number of pixels in X
      MY=MY-LY+1                                 ! Number of pixels in Y
      IF ((MX .LE. 0) .OR. (MY .LE. 0)) RETURN
C
C Now read in the subarray using Shortridge's DTA_ routines.
C The array is read in one row at a time.
C
      IDIMS(1)=LX
      DO 1020 J=1,MY
      IDIMS(2)=LY+J-1
      LOCATE=12
      CALL DTA_CRNAM (ENVIRO, 'Z', 0, IDIMS, DATA, IF)
      CALL DTA_CRNAM (DATA, 'DATA', 2, IDIMS, DATA, IF)
      IF (IF .LE. 0) GO TO 1010
      GO TO 1900
 1010 LOCATE=13
      CALL DTA_RDVARF (DATA, MX, FUNC(1,J), IF)
      IF (IF .LE. 0) GO TO 1020
      GO TO 1900
 1020 CONTINUE
 1900 IFLAG=IF
C
C If everything is OK, RETURN.  Otherwise, type out an error message,
C then RETURN.
C
      IF (IF .LE. 0) RETURN                              ! Normal return
C
C-----------------------------------------------------------------------
C
C Irrecoverable error.
C
      CALL DTA_ERROR (IF, ERROR)
      WRITE (6,691) LOCATE, BELL, ERROR
  691 FORMAT (/I5, A1, 3X, A70)
      RETURN
C
      END!
C
C#######################################################################
C
      SUBROUTINE  WRARAY (ENVIRO, LX, LY, MX, MY, NX, FUNC, IFLAG)
C
C=======================================================================
C
C Write a rectangular subarray into a big picture.
C
C Same as RDARAY.
C
C=======================================================================
C
      CHARACTER ERROR*70, DATA*64, FILE*30, ENVIRO*4, TYPE*5
      REAL*4 FUNC(NX,1)
      INTEGER*4 IDIMS(2)
      COMMON /SIZE/ NCOL, NROW
C
C-----------------------------------------------------------------------
C
C Check whether the desired subarray is wholly within the original
C picture.  If not, reset LX, LY, MX, and/or MY accordingly.
C
      MX=LX+MX-1                                      ! Upper limit in X
      MY=LY+MY-1                                      ! Upper limit in Y
      IF (LX .LT. 1) LX=1
      IF (LY .LT. 1) LY=1
      IF (MX .GT. NCOL) MX=NCOL
      IF (MY .GT. NROW) MY=NROW
      MX=MX-LX+1                                 ! Number of pixels in X
      MY=MY-LY+1                                 ! Number of pixels in Y
C
      CALL DTA_TYVAR ('DATA.Z.DATA', TYPE, IF)
      IF (TYPE .EQ. 'SHORT') THEN
         DO J=1,MY
            DO I=1,MX
               FUNC(I,J)=MAX(-32768., MIN(32767., FUNC(I,J)))
            END DO
         END DO
      END IF
C
C Write subarray into picture file.
C
      IDIMS(1)=LX
      DO 1020 J=1,MY
      IDIMS(2)=LY+J-1
      LOCATE=22
      CALL DTA_CRNAM (ENVIRO, 'Z', 0, IDIMS, DATA, IF)
      CALL DTA_CRNAM (DATA, 'DATA', 2, IDIMS, DATA, IF)
      IF (IF .LE. 0) GO TO 1010
      GO TO 1900
 1010 LOCATE=23
      CALL DTA_WRVARF (DATA, MX, FUNC(1,J), IF)
      IF (IF .LE. 0) GO TO 1020
      GO TO 1900
 1020 CONTINUE
 1900 IFLAG=IF
C
C Check for errors and RETURN.
C
      IF (IF .LE. 0) RETURN                              ! Normal return
C
C-----------------------------------------------------------------------
C
C Irrecoverable error.
C
      CALL DTA_ERROR (IF, ERROR)
      WRITE (6,691) LOCATE, ERROR
  691 FORMAT (I5, 3X, A70)
      RETURN
C
      END!
C
C#######################################################################
C
      CHARACTER*80 FUNCTION MESSAGE (ISTAT)
      CHARACTER*80 ERROR
      CALL DTA_ERROR (ISTAT, ERROR)
      MESSAGE = ERROR
      RETURN
      END!