C  @(#)descr.for	17.1.1.2 (ESO-DMD) 02/25/02 17:44:44 
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 Massachusetts Ave, Cambridge, 
C MA 02139, USA.
C
C Correspondence 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
      PROGRAM DESCR
C
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
C                                         all rights reserved
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: K.Banse
C
C.IDENTIFICATION
C  program DESCR 	  version 3.50	861003
C 
C.KEYWORDS
C  descriptors
C
C.PURPOSE
C  read/write or delete descriptors
C
C.ALGORITHM
C  use MIDAS interfaces to do the job
C
C.INPUT/OUTPUT
C  the following keys are used:
C  IN_A/C/1/80          name of data frame (input)
C                    	"cleaned" name (output)
C  ACTION/C/1/2         (1) up to 6 different action flags
C                    	  = R, for reading a complete descriptor
C                    	  = W, for writing a descriptor
C                   	  = D, for deleting a descriptor
C                   	  = P, for printing a complete descriptor
C                   	  = C, for copying all descriptors
C                   	  = S, for showing all existing descriptors
C                  	(2) display flag for READ option
C                    	  = F, for full display
C                    	  = B, for brief display
C                    	  = H, for display of data only (no header line)
C                  	or hidden flag for SHOW option
C                    	  = H, for hidden display
C  P2/C/1/60            for (W) descriptor/type/1.elem./novals	
C  or as default        descriptor => has to exist
C                       1.elem. = 1 + fill as much as is there
C                  	for (C) *,MASK with MASK as defined in STDCOP
C                    	only descriptor(s) separated by a comma (R,D,P)LINE
C  P3/C/1/60            data values in ASCII (W)
C  P4/C/1/3             = ALL, if complete descr. should be filled (W)
C  INPUTI/I/10/1        cleanup_flag for dest_descr's, 1/0 = Yes/No
C  OUT_A/C/1/80         name of output frame (C)
C
C  for option READ, PRINT + SHOW the integer keyword OUTPUTI(1-4) is set to
C  (1) 1/0 if descr exists or not
C  (2) 1/2/3/4 for int, real, char, double descr.
C  (3) noelem, (4) bytelem of descr
C 
C.VERSIONS
C  see SCCS
C 
C 011203		last modification
C 
C--------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER      ACTVAL,BYTELM,DSCMSK,DSCVERS
      INTEGER      FIRST,FLAG,I,IAV,IOFF
      INTEGER      LL,N,NOELEM,CLEN
      INTEGER      SLEN,START,STAT,MAXNO
      INTEGER*8    WPNTR2
      INTEGER      IMNO,RIMNO,ALLFLG
      INTEGER      EC,EL,ED
      INTEGER      UNIT(1),NULLO,MADRID(1)
C
      CHARACTER    LINE*80,OUTPUT*80,ACTION*2
      CHARACTER    FRAME*80,RESFRA*80,DSCR*80,TYPE*20
      CHARACTER    INSTRM*1,COMPAR(6)*1,DTYPE*1
C
      INTEGER      IBUF(65535)                    !descr data buffers
      REAL         RBUF(65535)
      CHARACTER    CBUF*65535
      DOUBLE PRECISION  DBUF(65535)
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
C
      COMMON  /VMR/ MADRID
C
      EQUIVALENCE      (IBUF,DBUF),(RBUF,DBUF)
C
      DATA      COMPAR /'R','W','D','P','C','S'/
C
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
C  get into MIDAS
      CALL STSPRO('DESCR ')
C
C  get frame + open it (do not extract subframe data...)
      CALL STKRDC('IN_A',1,1,80,IAV,FRAME,UNIT,NULLO,STAT)
      CALL STFINF(FRAME,9,IBUF,IOFF)               !save IOFF for later
      IF (IBUF(2).EQ.F_TBL_TYPE) THEN
         CALL TBTOPN(FRAME,F_I_MODE,IMNO,STAT)
      ELSE
         CALL STFOPN(FRAME,D_OLD_FORMAT,0,F_OLD_TYPE,IMNO,STAT)
      ENDIF
      IF (IOFF .NE. 0)                     !ERR_NORMAL not in ST_DEF header...
     +   CALL STETER(5,'could not read FITS file header...')
      IBUF(1) = IMNO
      CALL STFINF(FRAME,-6,IBUF,STAT)   !we reuse IMNO with flag < 0
      DSCVERS = IBUF(3)                 !get descr. format version
C
C  get action flag              ( ACTION(2:2) = display flag )
      CALL STKRDC('ACTION',1,1,2,IAV,ACTION,UNIT,NULLO,STAT)
      CALL UPCAS(ACTION,ACTION)
      DO 50, N=1,6
         IF (ACTION(1:1).EQ.COMPAR(N)) THEN
            FLAG = N
            GOTO 200
         ENDIF
50    CONTINUE
      CALL STETER(23,'module DESCR: invalid option...')
C
C  branch according to desired action
200   GOTO (1000,2000,3500,1000,5000,1000),FLAG
C
C  read, show or print descriptor (all values)
C
1000  CALL STKRDC('P2',1,1,80,IAV,LINE,UNIT,NULLO,STAT)
      IF (ACTION(2:2).NE.'H') CALL FRAMOU(FRAME)     !show frame and data type 
C
      IF (LINE(1:1).EQ.'*') THEN                     !all descriptors?
         IF ((LINE(2:2).EQ.' ') .OR. (LINE(2:2).EQ.','))
     +      LINE(1:1) = ' '
         CALL DSCLIS(IMNO,LINE,IBUF,RBUF,CBUF,DBUF,ACTION,DSCVERS)
         GOTO 8000
      ENDIF
C
      CALL LOWCAS(LINE,LINE)                         !check for ASCII file
      N = INDEX(LINE,'.ascii')
      IF (N.GT.1) THEN
         N = INDEX(LINE,' ') - 1                     !cut off trailing blanks
         IF (N.LT.1) N = LEN(LINE)
         OPEN(UNIT=33,FILE=LINE(1:N),STATUS='OLD',ERR=1090)
C 
1050     LINE(1:) = ' '
         READ(33,10000,END=1080) LINE
         START = 1
1060     CALL EXTRSS(LINE,',',START,DSCR,SLEN)
         IF (SLEN.GT.0) THEN
            CALL DSCLIS(IMNO,DSCR,IBUF,RBUF,CBUF,DBUF,ACTION,DSCVERS)
            GOTO 1060
         ELSE
            GOTO 1050                                !read next line
         ENDIF
C 
1080     CLOSE(UNIT=33)
         GOTO 8000
1090     CALL STETER(4,'could not open ASCII file...')
         GOTO 8000
      ENDIF
C 
C  extract descriptor(s) separated by a comma from single line
      START = 1
1100  CALL EXTRSS(LINE,',',START,DSCR,SLEN)
      IF (SLEN.LE.0) THEN
         GOTO 8000
      ELSE
         CALL DSCLIS(IMNO,DSCR,IBUF,RBUF,CBUF,DBUF,ACTION,DSCVERS)
         GOTO 1100
      ENDIF
C
C  write descriptor (not necessarily all values)
C
2000  CALL STKRDC('P2',1,1,80,IAV,LINE,UNIT,NULLO,STAT)
      CALL STKRDC('P4',1,1,1,IAV,CBUF,UNIT,NULLO,STAT)
      IF ((CBUF(1:1).EQ.'A') .OR.
     +    (CBUF(1:1).EQ.'a')) THEN
         ALLFLG = 1
      ELSE
         ALLFLG = 0
      ENDIF
      CBUF(1:81) = ' '                                   !we need [81] if "..."
      CALL STKRDC('P3',1,1,80,IAV,CBUF,UNIT,NULLO,STAT)       !get data string
C
C  either use defaults (1. element,...)
C   		                                     test, if default is used
      LL = INDEX(LINE,'/')
      IF (LL.LE.0) THEN
         START = 0            !set START to the "wrong" value = 0, to remember
         DSCR = LINE
         FIRST = 1
         CALL STDFND(IMNO,DSCR,DTYPE,NOELEM,BYTELM,STAT)

         IF (DTYPE.EQ.' ') CALL STETER
     +     (1,'default option invalid - descriptor does not exist... ')
C
C  or extract specific info about starting element, etc.
      ELSE
         START = 1
         CALL EXTRSS(LINE,'/',START,DSCR,SLEN)
         CALL EXTRSS(LINE,'/',START,TYPE,SLEN)
         CALL DTCHK(TYPE,DTYPE,BYTELM,MAXNO)
C                                                         wrong type given...
         IF (DTYPE.EQ.' ') GOTO 8900
C
         CALL EXTRSS(LINE,'/',START,OUTPUT,SLEN)
         CALL GENCNV(OUTPUT,1,1,FIRST,RBUF,DBUF,LL)
         IF (LL.LT.1) GOTO 8900
         CALL EXTRSS(LINE,'/',START,OUTPUT,SLEN)
         CALL GENCNV(OUTPUT,1,1,NOELEM,RBUF,DBUF,LL)
         IF (LL.LT.1) GOTO 8900
         IF (NOELEM .GT. MAXNO) THEN
            NOELEM = MAXNO
            WRITE(OUTPUT,10005) NOELEM
            CALL STTPUT(OUTPUT,STAT)
         ENDIF
      ENDIF
C 
C  get input stream
      CALL STKRDC('MID$IN',1,1,80,IAV,OUTPUT,UNIT,NULLO,STAT)  
      INSTRM = OUTPUT(1:1)
      IF (INSTRM.EQ.'F') GOTO 2660
C
C  integer descriptor
      IF (DTYPE.EQ.'I') THEN
         IF (ALLFLG.EQ.1) THEN
            CALL GENCNV(CBUF(1:20),1,1,IBUF,RBUF,DBUF,LL)
            IF (LL.LE.0) GOTO 8800
            ACTVAL = NOELEM
            DO 2250 N=2,ACTVAL
               IBUF(N) = IBUF(1)
2250        CONTINUE
         ELSE
            CALL GENCNV(CBUF(1:80),1,NOELEM,IBUF,RBUF,DBUF,ACTVAL)
            IF (ACTVAL.LE.0) GOTO 8800
         ENDIF
         CALL STDWRI(IMNO,DSCR,IBUF,FIRST,ACTVAL,UNIT,STAT)
C
C  real descriptor
      ELSE IF (DTYPE.EQ.'R') THEN
         IF (ALLFLG.EQ.1) THEN
            CALL GENCNV(CBUF(1:20),2,1,IBUF,RBUF,DBUF,LL)
            IF (LL.LE.0) GOTO 8800
            ACTVAL = NOELEM
            DO 2280, N=2,ACTVAL
               RBUF(N) = RBUF(1)
2280        CONTINUE
         ELSE
            CALL GENCNV(CBUF(1:80),2,NOELEM,IBUF,RBUF,DBUF,ACTVAL)
            IF (ACTVAL.LE.0) GOTO 8800
         ENDIF
         CALL STDWRR(IMNO,DSCR,RBUF,FIRST,ACTVAL,UNIT,STAT)
C
C  character descriptor 
      ELSE IF ((DTYPE.EQ.'C') .OR. (DTYPE.EQ.'H')) THEN
         LL = 80                                    !cut off trailing blanks
         DO 2300, I=LL,1,-1
            IF (CBUF(I:I).NE.' ') THEN
               CLEN = I
               GOTO 2310
            ENDIF
2300     CONTINUE
         CLEN = 1
2310     IF ((START.EQ.0) .AND. (ALLFLG.EQ.0)) NOELEM = CLEN 
C 
C  now look for " ... "
         IOFF = 1
         IF ((CBUF(1:1).EQ.'"')       .AND.
     +       (CBUF(CLEN:CLEN).EQ.'"') .AND.
     +       (CLEN.GT.2)) THEN                  !only possible for CLEN > 2
            IOFF = 2
            CBUF(CLEN:CLEN) = ' '
            IF ((START.EQ.0) .AND. (ALLFLG.EQ.0)) 
     +         NOELEM = NOELEM - 2
         ENDIF
C
C  character array
         IF (BYTELM.GT.1) THEN
            IF (ALLFLG.EQ.1) THEN
C		                   this makes it work for only 1 element, too
               LL = 1
               DO 2320, N=1,NOELEM 
                  CBUF(LL:LL+BYTELM-1) = CBUF(IOFF:IOFF+BYTELM-1)
                  LL = LL + BYTELM
2320           CONTINUE
               IOFF = 1
            ENDIF
            CALL STDWRC(IMNO,DSCR,BYTELM,CBUF(IOFF:),FIRST,NOELEM,
     +                  UNIT,STAT)
C
C  flat character string
         ELSE
            IF (ALLFLG.EQ.1) THEN
               DO 2330, N=1,NOELEM
                  CBUF(N:N) = CBUF(IOFF:IOFF)
2330           CONTINUE
               IOFF = 1
            ENDIF
            IF (DTYPE.EQ.'H') THEN
               CALL STDWRH(IMNO,DSCR,CBUF(IOFF:),FIRST,NOELEM,STAT)
            ELSE
               CALL STDWRC(IMNO,DSCR,1,CBUF(IOFF:),FIRST,NOELEM,
     +                     UNIT,STAT)
            ENDIF

         ENDIF
C
C  double prec. descriptor
      ELSE IF (DTYPE.EQ.'D') THEN
         IF (ALLFLG.EQ.1) THEN
            CALL GENCNV(CBUF(1:40),4,1,IBUF,RBUF,DBUF,LL)
            IF (LL.LE.0) GOTO 8800
            ACTVAL = NOELEM
            DO 2350, N=2,ACTVAL
               DBUF(N) = DBUF(1)
2350        CONTINUE
         ELSE
            CALL GENCNV(CBUF(1:80),4,NOELEM,IBUF,RBUF,DBUF,ACTVAL)
            IF (ACTVAL.LE.0) GOTO 8800
         ENDIF
         CALL STDWRD(IMNO,DSCR,DBUF,FIRST,ACTVAL,UNIT,STAT)
C 
C  logical descriptor
      ELSE IF (DTYPE.EQ.'L') THEN
         IF (ALLFLG.EQ.1) THEN
            IF ((CBUF(1:1).EQ.'T') .OR. (CBUF(1:1).EQ.'t')) THEN
               IBUF(1) = 1
            ELSE IF ((CBUF(1:1).EQ.'F') .OR. (CBUF(1:1).EQ.'f')) THEN
               IBUF(1) = 0
            ELSE
               CALL GENCNV(CBUF(1:20),1,1,IBUF,RBUF,DBUF,LL)
               IF (LL.LE.0) GOTO 8800
            ENDIF
            ACTVAL = NOELEM
            DO 2400, N=2,ACTVAL
               IBUF(N) = IBUF(1)
2400        CONTINUE
         ELSE
            ACTVAL = 1           !for single value, also T(rue), F(alse) is o.k.
            IF ((CBUF(1:1).EQ.'T') .OR. (CBUF(1:1).EQ.'t')) THEN
               IBUF(1) = 1
            ELSE IF ((CBUF(1:1).EQ.'F') .OR. (CBUF(1:1).EQ.'f')) THEN
               IBUF(1) = 0
            ELSE
               CALL GENCNV(CBUF(1:80),1,NOELEM,IBUF,RBUF,DBUF,ACTVAL)
               IF (ACTVAL.LE.0) GOTO 8800
            ENDIF
         ENDIF
         CALL STDWRL(IMNO,DSCR,IBUF,FIRST,ACTVAL,UNIT,STAT)
      ENDIF
      GOTO 8000
C
C  come here, if we read the data from file
C  get data from file used as input stream in MIDAS into temporary buffer
2660  ACTVAL = 1
      ALLFLG = 0
C
C  integer descr
      IF (DTYPE.EQ.'I') THEN
         CALL CNTDAT(OUTPUT(3:),'NUM',ACTVAL)            !count data in file
         IF (ACTVAL.LE.0)
     +      CALL STETER(22,'Invalid integer input file...')
C 
         CALL STFXMP(ACTVAL,D_I4_FORMAT,WPNTR2,STAT)
         CALL DATFIL(OUTPUT(3:),1,ACTVAL,MADRID(WPNTR2),MADRID(WPNTR2),
     +               0,RBUF(1),RBUF(2))              !now get the integer data
         CALL STDWRI(IMNO,DSCR,MADRID(WPNTR2),FIRST,ACTVAL,UNIT,STAT)
C
C  real descr
      ELSE IF (DTYPE.EQ.'R') THEN
         CALL CNTDAT(OUTPUT(3:),'NUM',ACTVAL)            !count data in file
         IF (ACTVAL.LE.0) CALL STETER(22,'Invalid real input file...')
C
         CALL STFXMP(ACTVAL,D_R4_FORMAT,WPNTR2,STAT)
         CALL DATFIL(OUTPUT(3:),2,ACTVAL,MADRID(WPNTR2),MADRID(WPNTR2),
     +               0,RBUF(1),RBUF(2))              !now get the real data
         CALL STDWRR(IMNO,DSCR,MADRID(WPNTR2),FIRST,ACTVAL,UNIT,STAT)
C
C  character descr
      ELSE IF ((DTYPE.EQ.'C') .OR. (DTYPE.EQ.'H')) THEN
         CALL CNTDAT(OUTPUT(3:),'CHAR',ACTVAL)            !count chars. in file
         IF (ACTVAL.LE.0) CALL STETER(22,'Invalid char. input file...')
C 
         N = ACTVAL/4 + 1
         CALL STFXMP(N,D_I4_FORMAT,WPNTR2,STAT)
         CALL CARFIL(OUTPUT(3:),ACTVAL,MADRID(WPNTR2))   !now get the characters
         IF (DTYPE.EQ.'H') THEN
            CALL STDWRH(IMNO,DSCR,MADRID(WPNTR2),FIRST,ACTVAL,STAT)
         ELSE
            CALL STDWRC(IMNO,DSCR,BYTELM,MADRID(WPNTR2),
     +                  FIRST,ACTVAL,UNIT,STAT)
         ENDIF
C
C  double prec. descr
      ELSE IF (DTYPE.EQ.'D') THEN
         CALL CNTDAT(OUTPUT(3:),'NUM',ACTVAL)            !count data in file
         IF (ACTVAL.LE.0) CALL STETER(22,'Invalid double input file...')
C
         CALL STFXMP(ACTVAL,D_R8_FORMAT,WPNTR2,STAT)
         CALL DATFIL(OUTPUT(3:),4,ACTVAL,MADRID(WPNTR2),MADRID(WPNTR2),
     +               0,RBUF(1),RBUF(2))              !now get the real data
         CALL STDWRD(IMNO,DSCR,MADRID(WPNTR2),FIRST,ACTVAL,UNIT,STAT)
C
C  logical descr
      ELSE IF (DTYPE.EQ.'L') THEN
         CALL CNTDAT(OUTPUT(3:),'NUM',ACTVAL)            !count data in file
         IF (ACTVAL.LE.0)
     +      CALL STETER(22,'Invalid logical input file...')
C 
         CALL STFXMP(ACTVAL,D_I4_FORMAT,WPNTR2,STAT)
         CALL DATFIL(OUTPUT(3:),1,ACTVAL,MADRID(WPNTR2),MADRID(WPNTR2),
     +               0,RBUF(1),RBUF(2))              !now get the integer data
         CALL STDWRL(IMNO,DSCR,MADRID(WPNTR2),FIRST,ACTVAL,UNIT,STAT)
      ENDIF
      GOTO 8000
C
C  delete descriptors
C
3500  CALL STKRDC('P2',1,1,80,IAV,DSCR,UNIT,NULLO,STAT)
      CALL STKRDC('P3',1,1,4,IAV,TYPE,UNIT,NULLO,STAT)       !TYPE = stopflag
      IF (TYPE(1:1).EQ.'n') TYPE(1:1) = 'N'
      IF (DSCR(1:2).EQ.'* ') THEN
         CALL STDDEL(IMNO,DSCR,STAT)
C 
      ELSE
         CALL STECNT('GET',EC,EL,ED)
         IF (TYPE(1:1).EQ.'N') CALL STECNT('PUT',1,0,0)
C
C  extract descriptor(s) separated by a comma from single line
         START = 1
         ACTVAL = 0
3550     CALL EXTRSS(DSCR,',',START,OUTPUT,SLEN)
         IF (SLEN.GT.0) THEN
            N = INDEX(OUTPUT,'*')
            IF (N.GT.0) THEN                           !we have a pattern
               CALL DSCDEL(IMNO,OUTPUT,DSCVERS,IAV)
               ACTVAL = ACTVAL + IAV
            ELSE
               CALL STDDEL(IMNO,OUTPUT,STAT)           !delete single descr
               ACTVAL = ACTVAL + 1
            ENDIF
            GOTO 3550
         ENDIF
         CALL STECNT('PUT',EC,EL,ED)
         CALL STKWRI('OUTPUTI',ACTVAL,1,1,UNIT,STAT) 
      ENDIF
      GOTO 8000
C
C  copy descriptors
C 
5000  CALL STKRDC('OUT_A',1,1,80,IAV,RESFRA,UNIT,NULLO,STAT)
      CALL STFOPN(RESFRA,D_OLD_FORMAT,0,F_OLD_TYPE,RIMNO,STAT)
C                                   get *,1 *,2 *,3, ...  or just *
      CALL STKRDC('P2',1,1,100,IAV,CBUF,UNIT,NULLO,STAT)
      DSCMSK = 1
      LL = INDEX(CBUF(1:100),' ')              !find end of buffer
      IF (LL.LT.1) LL = 100
      IF (CBUF(2:2).EQ.',') THEN
         CALL GENCNV(CBUF(3:3),1,1,DSCMSK,RBUF,DBUF,IAV)
         IF (IAV.NE.1)
     +      CALL STETER(12,'wrong flag in COPY/DD ...')

         IF (CBUF(4:4).EQ.',') THEN            !*,n,descrNOT,descrNOT,...
            CBUF(1:LL) = CBUF(5:LL) //' '               
            DSCMSK = DSCMSK + 5                !update the copy-mask
         ELSE
            CBUF(1:LL) = ' '
         ENDIF
C 
      ELSE IF (CBUF(1:1).EQ.'?') THEN
         CBUF(1:LL) = CBUF(2:LL)//' '
         DSCMSK = 4                         !we have descnames or patterns
5100     N = INDEX(CBUF(1:LL),'*') 
         IF (N .GT. 0) THEN              
            IAV = INDEX(CBUF(1:LL),',')
            IF (IAV.GT.1) THEN
               CBUF(101:200) = CBUF(1:IAV-1)//' '
               CBUF(1:LL) = CBUF(IAV+1:LL)//' '
               CALL STDCOP(IMNO,RIMNO,DSCMSK,CBUF(101:200),STAT)
               LL = INDEX(CBUF(1:),' ')                  !we do have a ' '
               GOTO 5100
            ENDIF
         ENDIF
      ENDIF
C                                                    now copy all descriptors
      CALL STKRDI('INPUTI',10,1,IAV,N,UNIT,NULLO,STAT)
      IF (N.EQ.1) DSCMSK = DSCMSK + 100            !include cleanup flag
      CALL STDCOP(IMNO,RIMNO,DSCMSK,CBUF(1:LL),STAT)
C
C  we're done without problems
C
8000  CALL STSEPI
C
C  here, if syntax error in data string
8800  CALL STETER(2,'wrong syntax in data string... ')
C
C  here for syntax errors detected while reading stuff...
8900  CALL STETER(3,'wrong syntax in descriptor string... ')
C
C 
10000 FORMAT(A)
10005 FORMAT('Warning: only ',I5,
     +       ' descriptor elements written in one go ...')
C 
      END

      SUBROUTINE DSCLIS(IMNO,INDSC,IVALS,RVALS,CVALS,DVALS,FLAG,DVERS)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine DSCLIS			version 3.30	850926
C  K. Banse                  		ESO - Garching
C
C.KEYWORDS
C  descriptors
C
C.PURPOSE
C  display contents of one or all descriptors of a bulk data frame
C
C.ALGORITHM
C  read all existing descriptor names + display their contents
C
C.INPUT/OUTPUT
C  call as DSCLIS(IMNO,INDSC,IVALS,RVALS,CVALS,DVALS,FLAG)
C
C  IMNO:      I*4         frame no. of data frame
C  INDSC:     char.exp.   descriptor to be displayed
C                   	  if = ' ', all descriptors are displayed
C  IVALS:     I*4 array   integer buffer
C  RVALS:     R*4 array   real buffer
C  CVALS:     char.exp.   character buffer
C  DVALS:     R*8 array   double precision buffer
C  FLAG:      char.exp.   2-char. flag:
C			  (1) = R(ead), P(rint) or S(how)
C			  (2) = F(ull), B(rief) or H(idden)
C  DVERS:     I*4         Descr format: 0 = old format,
C			                1 = new large format
C			                2 = new format with name+help
C
C-------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER      IMNO,IVALS(*),DVERS
      INTEGER      LIM(6)
      INTEGER      BYTELM,NOELEM,NPOS
      INTEGER      DSCNO(2),DSCLEN,IAV,IOFF,ITY,L,LL,M,MM,N,KCASE
      INTEGER      NDOFF,NDI,NDLIM,STAT,IJK(5),NPT
      INTEGER      EL1,NEL2,NOTDS,HNC
      INTEGER      DIROFF,OPTIO,UNIT(1),NULLO,XLONG
C
      CHARACTER*(*)  INDSC
      CHARACTER*(*)  CVALS
      CHARACTER*(*)  FLAG
      CHARACTER      DIRBUF*32760
      CHARACTER      LF*1,TYPE*1
      CHARACTER      DISCR*80,DSCDIR*24,DSCTYP*24
      CHARACTER      NOTDSC(4)*72,OUTPUT*80,CCC*14,CBUF*80
      CHARACTER      CC(6)*12,CTYPE*4,CHTYP*14,BLANK*20
C
      REAL           RVALS(*)
C
      DOUBLE PRECISION DVALS(*)
C 
      DATA      CC/'integer ','real ','character ','double prec.',
     +		   ' ','logical '/
      DATA      CHTYP /'character* '/
      DATA      LIM      /6,4,60,2,1,10/
      DATA      BLANK /' '/, CCC /' '/
C
      LF = CHAR(10)                   !LineFeed character ( \n in C)
      DSCNO(1) = 0                    !for descriptor
      DSCNO(2) = -1                   !for help text of descriptor
      NPOS = 1
      NDI = 0
      IF (DVERS.NE.0) THEN            !for DSC_FLAG = 'Y' or 'Z'
         DSCDIR = 'DESCRIPTOR.DIRECTORY'
      ELSE
         DSCDIR = 'DIRECTORY.MIDAS'
      ENDIF
      EL1 = 1
      NEL2 = 0
C
C  clean + convert to uppercase
      DISCR(1:) = ' '
      CALL UPCAS(INDSC,DISCR)
      IF (DISCR.EQ.DSCDIR) THEN
         OPTIO = -1                   !descr. directory
         NOELEM = 0
C
         IF (DVERS.NE.0) THEN
            CALL STDRDZ(IMNO,NOELEM,DSCNO(1),STAT) 
            RETURN
C 
         ELSE
            NDLIM = 1500             !process old descr format
            NDOFF = 1
88          CALL STDRDC(IMNO,DSCDIR,1,NDOFF,NDLIM,LL,
     +                  DIRBUF,UNIT,NULLO,STAT)
            NOELEM = NOELEM + LL
            IAV = LL/30
            DSCNO(1) = DSCNO(1) + IAV
C
            IF (NOELEM.GT.0) THEN
               DO 100, N=1,NOELEM,60
                  IF (N+30.GT.NOELEM) THEN
                     OUTPUT(1:) = '   '//DIRBUF(N:N+14)//'   '
     +                               //DIRBUF(N+15:N+15)//' '
                  ELSE
                     OUTPUT(1:) = '   '//DIRBUF(N:N+14)//'   '
     +                               //DIRBUF(N+15:N+15)//'       '
     +                               //DIRBUF(N+30:N+44)//'   '
     +                               //DIRBUF(N+45:N+45)//' '
                  ENDIF
                  CALL STTPUT(OUTPUT,STAT)
100            CONTINUE
            ENDIF
C
            IF (NOELEM.EQ.NDLIM) THEN
               NDOFF = NDOFF + NDLIM
               GOTO 88                              !look for more
            ELSE
               WRITE(OUTPUT,33000) NOELEM,DSCNO(1)
               CALL STTPUT(OUTPUT,STAT)
               RETURN
            ENDIF
         ENDIF
C
      ELSE IF (DISCR(1:1).EQ.' ') THEN
         IF ((DISCR(2:2).EQ.',') .OR.              !descriptor NOT to display
     +       (DISCR(2:2).EQ.'|')) THEN
            NOTDS = 1
            DISCR(2:2) = ' '
110         N = INDEX(DISCR,',')
            IF (N.GT.1) THEN
               NOTDSC(NOTDS)(1:) = DISCR(3:N-1)//' ' 
               DISCR(3:) = DISCR(N+1:)
               IF (NOTDS.LT.4) THEN
                  NOTDS = NOTDS + 1
                  GOTO 110 
               ENDIF
            ELSE
               NOTDSC(NOTDS)(1:) = DISCR(3:)
               IF (NOTDS.EQ.1) THEN
                  N = INDEX(NOTDSC(1),'*')
                  IF (N.GT.0) THEN
                     CALL PATTST(1,NOTDSC(1),STAT)
                     NOTDS = -1
                  ENDIF
               ENDIF
            ENDIF
         ELSE
            NOTDS = 0
         ENDIF
         OPTIO = 1                    !all descriptors
         DISCR(1:) = ' '
         IF (DVERS.NE.0) THEN
            CALL STDRDX(IMNO,1,DISCR,DSCTYP,BYTELM,NOELEM,HNC,STAT)  !get dscdir
            CALL STDRDX(IMNO,10,DISCR,DSCTYP,BYTELM,NOELEM,HNC,STAT) !get 1.dsc
            IF (DISCR(1:1).EQ.' ') GOTO 9000
            DSCNO(1) = 2                 !at least 1 descr. + directory
C 
         ELSE
            NDLIM = 32760       !old descr format, only for max. 32760 descr...
            CALL STDRDC(IMNO,DSCDIR,1,1,NDLIM,NOELEM,
     +                  DIRBUF,UNIT,NULLO,STAT)
            IAV = NOELEM/30
            DSCNO(1) = DSCNO(1) + IAV
C
            DIROFF = 31                  !omit directory output
            NDI = NDI + 1
            DISCR(1:) = DIRBUF(DIROFF:DIROFF+14)//' '
            CALL STDFND(IMNO,DISCR,DSCTYP,NOELEM,BYTELM,STAT)
         ENDIF
C 
      ELSE
         N = INDEX(DISCR,'*') 
         IF (N.GT.0) THEN                  !we have a pattern
            N = INDEX(DISCR,'|')
            IF (N.GT.1) THEN               !is it incl-patrn | excl-patrn?
               OPTIO = 3
               CALL PATTST(1,DISCR(1:N-1),STAT)    !save the two patterns
               CALL PATTST(11,DISCR(N+1:),STAT)
            ELSE
               OPTIO = 2
               CALL PATTST(1,DISCR,STAT)
            ENDIF
            NPT = 0
C 
            IF (DVERS.EQ.0) THEN               !old descr. format
               NDLIM = 32760    !old descr format, only for max. 32760 descr...
               CALL STDRDC(IMNO,DSCDIR,1,1,NDLIM,NOELEM,
     +                     DIRBUF,UNIT,NULLO,STAT)
               IAV = NOELEM/30
               DSCNO(1) = DSCNO(1) + IAV
               DIROFF = 1
            ELSE
               CALL STDRDX(IMNO,1,DISCR,DSCTYP,BYTELM,NOELEM,HNC,STAT) 
            ENDIF
C 
            NPOS = 0
            GOTO 8000
         ENDIF
C 
         OPTIO = 0                 !single descriptor 
         DSCNO(1) = 1         
         N = INDEX(DISCR,'/')                  !see, if it's descr/type/f/no
         IF (N.GT.1) THEN
            CBUF(1:) = DISCR(N+1:)
            DISCR(N:) = ' '
         ENDIF
         CALL STDFND(IMNO,DISCR,DSCTYP,NOELEM,BYTELM,STAT)
C 
         IF (N.GT.1) THEN
            N = INDEX(CBUF,'/')               !skip type
            IF (N.GT.1) THEN
               CBUF(1:) = CBUF(N+1:)
               DO 440,N=1,30
                  IF (CBUF(N:N).EQ.'/') THEN
                     CBUF(N:N) = ','
                     CALL GENCNV(CBUF,1,2,IVALS,RVALS,DVALS,LL)
                     IF (LL.EQ.2) THEN
                        EL1 = IVALS(1)
                        NEL2 = IVALS(2)
                        GOTO 500
                     ENDIF
                  ENDIF
440            CONTINUE
            ENDIF
         ENDIF
C 
      ENDIF
C
C
C  loop through descr. list
C
500   IF (OPTIO.GE.2) THEN                          !we have pattern(s)
         CALL PATTST(2,DISCR,STAT)
         IF (STAT.EQ.0) GOTO 8000                   !no match
C 
         IF (OPTIO.EQ.3) THEN
            CALL PATTST(12,DISCR,STAT)
            IF (STAT.EQ.1) GOTO 8000                !it's an excluded descr
         ENDIF
         NPT = NPT + 1                              !matching descr. found
C 
      ELSE IF (OPTIO.EQ.1) THEN
         IF (NOTDS.NE.0) THEN 
            IF (NOTDS.GT.0) THEN                    !loop thru excluded descrs
               DO 550, N=1,NOTDS
                  IF (DISCR.EQ.NOTDSC(N)) THEN
                     DSCNO(1) = DSCNO(1) - 1
                     GOTO 8000
                  ENDIF
550            CONTINUE
            ELSE 
               CALL PATTST(2,DISCR,STAT)
               IF (STAT.EQ.1) THEN
                  DSCNO(1) = DSCNO(1) - 1
                  GOTO 8000
               ENDIF
            ENDIF
         ENDIF
      ENDIF
C 
      IF (NEL2.GT.0) NOELEM = NEL2
C 
      DSCLEN = INDEX(DISCR,' ') - 1              !real length of descr name
      TYPE = DSCTYP(1:1)
      IF (TYPE.EQ.' ') THEN
         IJK(1) = 0
         IF (FLAG(2:2).NE.'H') THEN
            OUTPUT(1:) = 'descriptor '//DISCR(1:DSCLEN)//
     +                   ' not present... '
            CALL STTPUT(OUTPUT,STAT)
         ENDIF
         GOTO 8000
      ENDIF
C 
      IJK(1) = 1
      STAT = 0
      XLONG = 0
      IF (NOELEM.GT.65535) THEN
         XLONG = NOELEM - 65535
         NOELEM = 65535                   !ojo: synchronize with MAIN ...
      ENDIF
C
C  get integer data
700   IF (TYPE.EQ.'I') THEN
         ITY = 1
         IF (FLAG(1:1).NE.'S') CALL STDRDI
     +   (IMNO,DISCR,EL1,NOELEM,IAV,IVALS,UNIT,NULLO,STAT)
C
C  get real data
      ELSE IF (TYPE.EQ.'R') THEN
         ITY = 2
         IF (FLAG(1:1).NE.'S') CALL STDRDR
     +   (IMNO,DISCR,EL1,NOELEM,IAV,RVALS,UNIT,NULLO,STAT)
C
C  get character data
      ELSE IF (TYPE.EQ.'C') THEN
         IF (BYTELM.GT.1) THEN
            ITY = 5
            WRITE(CTYPE,30000) BYTELM
C                                                     omit leading blanks...
            DO 800 LL=1,3
               IF (CTYPE(LL:LL).NE.' ') GOTO 1000
800         CONTINUE
            LL = 4
1000        CHTYP(11:) = CTYPE(LL:)
            IF (FLAG(1:1).NE.'S')
     +         CALL STDRDC(IMNO,DISCR,BYTELM,EL1,NOELEM,
     +                     IAV,CVALS,UNIT,NULLO,STAT)
         ELSE
            ITY = 3
            IF (FLAG(1:1).NE.'S')
     +         CALL STDRDC(IMNO,DISCR,1,EL1,NOELEM,
     +                     IAV,CVALS,UNIT,NULLO,STAT)
         ENDIF
C
C  get double prec. data
      ELSE IF (TYPE.EQ.'D') THEN
         ITY = 4
         IF (FLAG(1:1).NE.'S') 
     +      CALL STDRDD(IMNO,DISCR,EL1,NOELEM,
     +                  IAV,DVALS,UNIT,NULLO,STAT)
C
C  get logical data
      ELSE IF (TYPE.EQ.'L') THEN
         ITY = 6
         IF (FLAG(1:1).NE.'S') 
     +      CALL STDRDL(IMNO,DISCR,EL1,NOELEM,
     +                  IAV,IVALS,UNIT,NULLO,STAT)
      ENDIF
C 
C  return, if problems with reading descriptors
      IF (STAT.NE.0) THEN
         WRITE(OUTPUT,10000) DISCR(1:DSCLEN)
         CALL STTPUT(OUTPUT,STAT)
         GOTO 8000
      ENDIF
C
C  fill header line
      IF (ITY.NE.5) THEN
         IJK(2) = ITY
         CCC = CC(ITY)
      ELSE
         IJK(2) = 3
         CCC = CHTYP
      ENDIF
C
C  display header line - except for display_flag = H or B
      IF (FLAG(2:2).EQ.'H') THEN
         IF (FLAG(1:1) .EQ. 'S') THEN 
            GOTO 8000                !nothing to do for SHOW/DESCR
         ELSE
            GOTO (5500,5600,5700,5800,5700,5900),ITY      !only display data
         ENDIF
C 
      ELSE IF (FLAG(2:2).NE.'B') THEN
         IF (DSCLEN .LE. 15) THEN
            WRITE(OUTPUT,10001) DISCR(1:15)        !help text begins at 15
         ELSE
            WRITE(OUTPUT,10001) DISCR(1:DSCLEN)
         ENDIF
         MM = INDEX(OUTPUT,'( ') + 1               !find end of text
         IF (MM .GT. 72) THEN
            OUTPUT(MM-1:) = '    '
            CALL STTPUT(OUTPUT,STAT)
            OUTPUT(1:) = '( '
            MM = 2
         ENDIF
         LL = 77 - MM                              !LL = 53 for short descr
C 
         CALL STDRDH(IMNO,DISCR,1,72,IAV,CBUF,HNC,STAT)
         IF (HNC.GT.0) THEN                     !Yes, there is help
            DO 1600, M=IAV,1,-1                 !get rid of trailing blanks
               IF (CBUF(M:M) .NE. ' ') THEN
                  IAV = M
                  GOTO 1660
               ENDIF
1600        CONTINUE
1660        IF (IAV.GT.LL) THEN
               OUTPUT(MM-1:) = '    '
               CALL STTPUT(OUTPUT,STAT)         !print name on one line
               OUTPUT(1:) = '( '                !help text on next line
               MM = 2
            ENDIF
            OUTPUT(MM:) = CBUF(1:IAV)//') '
         ELSE
            OUTPUT(MM:) = '...) '
         ENDIF
         DSCNO(2) = HNC                         !save size of help text
         CALL STTPUT(OUTPUT,STAT)
         IF (NOELEM .GT. 99999) THEN
            WRITE(OUTPUT,10004) CCC,NOELEM
         ELSE
            WRITE(OUTPUT,10005) CCC,NOELEM
         ENDIF
         CALL STTPUT(OUTPUT,STAT)
C
         IF (FLAG(1:1).EQ.'S') THEN                !SHOW/DESCR
            GOTO 8000
         ELSE                                      !READ/DESCR
            GOTO (5500,5600,5700,5800,5700,5900),ITY
         ENDIF
      ELSE
C
C  short display
         IF ((TYPE.EQ.'C') .AND.
     +       (DISCR(1:6).EQ.'IDENT ')) THEN        !truncate IDENT
            MM = 0
            LL = MIN(NOELEM,72)
            DO 3000, M=LL,1,-1
               IF (CVALS(M:M).NE.' ') THEN
                  MM = M                           !mark last char.
                  GOTO 3050
               ENDIF
3000        CONTINUE
3050        IF (MM.EQ.0) THEN                      !only blanks
               NOELEM = 1
            ELSE
               NOELEM = MM
            ENDIF
         ENDIF
C
         DISCR(DSCLEN+1:) = ': '
         IF ( (DSCLEN .GT. 15) .OR.
     +        (NOELEM.GT.LIM(ITY)) .OR.
     +        (ITY.EQ.5) ) THEN
             CALL STTPUT(DISCR,STAT)
             GOTO (5500,5600,5700,5800,5700,5900),ITY
         ELSE                                      !brief display
             GOTO (5550,5650,5790,5850,5790,5950),ITY
         ENDIF
      ENDIF
C
C here the output of the descr. values
C 
5500  DO 5510, M=1,NOELEM,8
         MM = MIN(NOELEM,M+7)
         WRITE(OUTPUT,10002) (IVALS(L),L=M,MM)
         CALL STTPUT(OUTPUT,STAT)
5510  CONTINUE
      GOTO 7700
C
5550  WRITE(OUTPUT,10002) (IVALS(L),L=1,NOELEM)
      LL = NOELEM*10
      CBUF(1:) = DISCR(1:17)//OUTPUT(1:LL)//' '
      CALL STTPUT(CBUF,STAT)
      GOTO 7700
C
5600  DO 5610, M=1,NOELEM,5
         MM = MIN(NOELEM,M+4)
         WRITE(OUTPUT,20002) (RVALS(L),L=M,MM)
         CALL STTPUT(OUTPUT,STAT)
5610  CONTINUE
      GOTO 7700
C
5650  WRITE(OUTPUT,20002) (RVALS(L),L=1,NOELEM)
      LL = NOELEM*15
      CBUF(1:) = DISCR(1:17)//OUTPUT(1:LL)//' '
      CALL STTPUT(CBUF,STAT)
      GOTO 7700
C
C  character data has to be treated specially
5700  IF (BYTELM.GT.1) THEN
         LL = 1
         MM = BYTELM
         DO 5720, L=1,NOELEM
            DO 5710, IOFF=LL,MM,80
               M = IOFF + 79
               IF (M.GT.MM) M = MM
               OUTPUT(1:) = CVALS(IOFF:M)//' '
               CALL STTPUT(OUTPUT,STAT)
5710        CONTINUE
            LL = LL + BYTELM
            MM = MM + BYTELM
5720     CONTINUE
      ELSE
C 
         M = 1                            !chop up in pieces of 80 chars
5730     MM = M + 79
         IF (MM.GE.NOELEM) THEN
            KCASE = 0                     !indicate that we reached the end
            MM = NOELEM
         ELSE
            KCASE = 1
         ENDIF
C
C  look for \n character in string
         LL = MM - M + 1
         DO 5740, N=1,LL
            L = M + N - 1
            IF (CVALS(L:L).EQ.LF) THEN
               MM = L
               KCASE = 1
               IF (N.EQ.1) THEN
                  GOTO 5760
               ELSE
                  OUTPUT(1:) = CVALS(M:L-1)//' '
                  GOTO 5750
               ENDIF
            ENDIF
5740     CONTINUE
         OUTPUT(1:) = CVALS(M:MM)//' '
5750     CALL STTPUT(OUTPUT,STAT)
5760     IF (KCASE.EQ.1) THEN
            M = MM + 1                     !move to after current end
            IF (M.LE.NOELEM) GOTO 5730
         ENDIF
      ENDIF
      GOTO 7700
C
5790  OUTPUT(1:) = DISCR(1:17)//CVALS(1:NOELEM)//' '
      CALL STTPUT(OUTPUT,STAT)
      GOTO 7700
C
5800  DO 5810, M=1,NOELEM,3
         MM = MIN(NOELEM,M+2)
         WRITE(OUTPUT,20003) (DVALS(L),L=M,MM)
         CALL STTPUT(OUTPUT,STAT)
5810  CONTINUE
      GOTO 7700
C
5850  WRITE(OUTPUT,20004) (DVALS(L),L=1,NOELEM)
      LL = NOELEM*24
      CBUF(1:) = DISCR(1:17)//OUTPUT(1:LL)//' '
      CALL STTPUT(CBUF,STAT)
      GOTO 7700
C 
5900  DO 5910, M=1,NOELEM,8
         MM = MIN(NOELEM,M+7)
         WRITE(OUTPUT,10002) (IVALS(L),L=M,MM)
         CALL STTPUT(OUTPUT,STAT)
5910  CONTINUE
      GOTO 7700
C
5950  WRITE(OUTPUT,10002) (IVALS(L),L=1,NOELEM)
      LL = NOELEM*10
      CBUF(1:) = DISCR(1:17)//OUTPUT(1:LL)//' '
      CALL STTPUT(CBUF,STAT)
      GOTO 7700
C 
7700  IF (XLONG.GT.0) THEN
         EL1 = EL1 + 65535
         IF (XLONG.LE.65535) NOELEM = XLONG
         XLONG = XLONG - 65535
         DISCR(DSCLEN+1:) = '  '             !remove ':' again
         GOTO 700
      ENDIF
C
C  increment counter + loop if there are more descriptors
C 
8000  DISCR(1:) = ' '
      IF (DVERS.NE.0) THEN                   !new descr format
         IF (OPTIO.NE.0) THEN
            CALL STDRDX(IMNO,10,DISCR,DSCTYP,BYTELM,NOELEM,HNC,STAT)
            IF (DISCR(1:1).NE.' ') THEN
               DSCNO(1) = DSCNO(1) + 1
               GOTO 500
            ENDIF
         ENDIF
      ELSE                                   !old descr format
         NDI = NDI + 1
8080     IF (NDI.LT.DSCNO(1)) THEN
            DIROFF = DIROFF + 30
            IF (DIRBUF(DIROFF+15:DIROFF+15) .EQ. 'H') THEN
               DSCNO(1) = DSCNO(1) - 1
               GOTO 8080
            ELSE
               DISCR(1:) = DIRBUF(DIROFF:DIROFF+14)//' '
               CALL STDFND(IMNO,DISCR,DSCTYP,NOELEM,BYTELM,STAT)
               GOTO 500                      !display next descriptor
            ENDIF
         ENDIF
      ENDIF
C
C
9000  IF (OPTIO.EQ.0) THEN                   !single descriptor
         IF (IJK(1).EQ.1) THEN
            IJK(3) = NOELEM
            IJK(4) = BYTELM
            IJK(5) = DSCNO(2)
         ENDIF
         CALL STKWRI('OUTPUTI',IJK,1,5,UNIT,STAT) 
      ELSE   
         IF (OPTIO.EQ.1) THEN                !all descr's
            DSCNO(1) = DSCNO(1) - 1          !avoid descr. directory itself
         ELSE 
            DSCNO(1) = NPT
         ENDIF
         WRITE(OUTPUT,40000) DSCNO(1)
         CALL STTPUT(OUTPUT,STAT)
         CALL STKWRI('OUTPUTI',DSCNO,1,1,UNIT,STAT) 
      ENDIF
C
C  That's it folks ...
      RETURN
C
C  formats
10000 FORMAT('Problems reading descriptor: ',A)
10001 FORMAT('name: ',A,' ( ')
10002 FORMAT(8I10)
10004 FORMAT('type: ',A,'  no. of elements:',I8)
10005 FORMAT('type: ',A,'  no. of elements:',I5)
20002 FORMAT(5G15.7)
20003 FORMAT(3G24.14)
20004 FORMAT(2G24.14)
30000 FORMAT(I4)
33000 FORMAT('Descriptor directory: total length =',I8,
     +       '   => no. of decriptors =',I6)   
40000 FORMAT('total no. of descriptors:',I6)
      END

      SUBROUTINE DTCHK(INTYP,OUTTYP,BYTELM,MAXNO)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine DTCHK			version 1.50	841114
C  K. Banse 				ESO - Garching
C  1.60	    860226	1.70	871027		1.80	900215
C
C.KEYWORDS
C  keyword data base
C
C.PURPOSE
C  check given data type + return cleaned type and no. of bytes per element
C
C.ALGORITHM
C  straight forward
C
C.INPUT/OUTPUT
C  call as DTCHK(INTYP,OUTTYP,BYTELM,MAXNO)
C
C  input par:
C  INTYP:	char.exp.	type of keyword/descr
C
C  output par:
C  OUTTYP:	char*1		type of keyword/descr
C				currently I,R,C,D,H, L are recognized for
C				I*4,R*4,CHAR*n,R*8 or Double or HELP
C				set to ' ', if invalid INTYP given
C  BYTELM:	I*4		no. of bytes per element of keyword/descr data
C  MAXNO:	I*4 		max. no. of elements which can be written
C				(= size of internal buffer)
C
C.VERSIONS
C  1.60		also allow LOGICAL*4 type - will be converted to I*4
C  1.70		add output par. MAXNO
C
C----------------------------------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER      BYTELM
      INTEGER      LL,MAXNO
      INTEGER      LIMES(3)
C 
      REAL  RR
C 
      DOUBLE PRECISION  DD
C
      CHARACTER*(*)  INTYP
      CHARACTER      OUTTYP*1,TEST*1
C
      DATA   LIMES /65535,65535,65535/
C                                   
      MAXNO = 0                        !default to no_success ...
      OUTTYP = ' '
      CALL UPCAS(INTYP(1:1),TEST)
C
C  first look for type CHAR*len
      IF (TEST.EQ.'C') THEN
         LL = INDEX(INTYP,'*')
         IF (LL.LE.0) THEN
            BYTELM = 1
            OUTTYP = 'C'
         ELSE
            CALL GENCNV(INTYP(LL+1:),1,1,BYTELM,RR,DD,LL)
            IF (LL.GT.0) OUTTYP = 'C'
         ENDIF
         MAXNO = LIMES(3) / BYTELM
C
C  then for integer, real + double precision
      ELSE IF (TEST.EQ.'I') THEN
         BYTELM = 4
         OUTTYP = 'I'
         MAXNO = LIMES(2)
      ELSE IF (TEST.EQ.'R') THEN
         IF (INDEX(INTYP,'*8').GT.0) THEN
            BYTELM = 8
            OUTTYP = 'D'
            MAXNO = LIMES(1)
         ELSE
            BYTELM = 4
            OUTTYP = 'R'
            MAXNO = LIMES(2)
         ENDIF
      ELSE IF (TEST.EQ.'D') THEN
         BYTELM = 8
         OUTTYP = 'D'
         MAXNO = LIMES(1)
      ELSE IF (TEST.EQ.'H') THEN
         BYTELM = 1
         OUTTYP = 'H'
         MAXNO = LIMES(2)
      ELSE IF (TEST.EQ.'L') THEN
         BYTELM = 4
         OUTTYP = 'L'
         MAXNO = LIMES(2)
      ENDIF
C
C OUTTYP only set, if correct type was entered
      RETURN
      END

      SUBROUTINE PATTST(FLAG,STR,STAT)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine PATTST		version 1.0	980421
C  K. Banse			ESO - Garching
C
C.KEYWORDS
C  pattern matching
C
C.PURPOSE
C  check if descriptor name matches a given pattern
C
C.ALGORITHM
C  straight forward
C  support two patterns patternA, patternB
C
C.INPUT/OUTPUT
C  call as  PATTST(FLAG,STR,STAT)
C
C  input par:
C  FLAG:	I*4		flag = 1 (11), for saving patternA/B
C  				     = 2 (12), for checking patternA/B
C				< 10 for patternA, > 10 for patternB
C  STR:		char.exp.	pattern string (FLAG=1,11)
C				descr. name (FLAG=2,12)
C
C  output par:
C  STAT:	I*4		= 1, if matching, else = 0
C
C.VERSIONS
C  see SCCS
C
C----------------------------------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER    FLAG,STAT
      INTEGER    N,M
      INTEGER    IPT,IPTA,PATFLG
      INTEGER    JPT,JPTA,QATFLG
C 
      CHARACTER*(*) STR
      CHARACTER  PATTRN*80,PATTRA*80
      CHARACTER  QATTRN*80,QATTRA*80
C 
      SAVE       PATTRN,PATTRA
      SAVE       QATTRN,QATTRA
      SAVE       PATFLG,IPT,IPTA
      SAVE       QATFLG,JPT,JPTA

C 
      STAT = 0
      IF (FLAG.LT.10) THEN
         IF (FLAG.EQ.1) THEN
C 
C extract pattern for patternA
C 
            M = INDEX(STR,' ') - 1              !real length
            IF (M.LT.1) M = LEN(STR)
C 
            N = INDEX(STR,'*')
            IF (N.EQ.1) THEN
               IF (STR(M:M).EQ.'*') THEN  
                  PATTRN(1:) = STR(2:M-1)//' '
                  IPT = M - 2
                  PATFLG = 4                    ! = 4, for checking *pattern*
               ELSE
                  PATTRN(1:) = STR(2:)//' '      
                  IPT = INDEX(PATTRN,' ') - 1
                  IF (IPT.LT.1) IPT = LEN(PATTRN)
                  PATFLG = 1                    ! = 1, for checking *pattern
               ENDIF
            ELSE
               IF ((M.EQ.N) .OR. (STR(N+1:N+1).EQ.' ')) THEN
                  IPT = N - 1
                  PATTRN(1:) = STR(1:IPT)//' '       
                  PATFLG = 2                    ! = 2, for checking pattern*
               ELSE
                  PATTRN(1:) = STR(1:N-1)//' '
                  IPT = INDEX(PATTRN,' ') - 1
                  IF (IPT.LT.1) IPT = LEN(PATTRN)
                  PATTRA(1:) = STR(N+1:)//' '
                  IPTA = INDEX(PATTRA,' ') - 1
                  IF (IPTA.LT.1) IPTA = LEN(PATTRA)
                  PATFLG = 3                 ! = 3, for checking pattr1*pattr2
               ENDIF
            ENDIF
C 
C match patternA
C 
         ELSE
            N = INDEX(STR,' ') - 1
            IF (N.LT.1) N = LEN(STR)
C 
            IF (PATFLG.EQ.1) THEN                            !*pattern
               IF (N.GE.IPT) THEN
                  M = N - IPT + 1
                  IF (STR(M:N).EQ.PATTRN(1:IPT)) STAT = 1
               ENDIF
            ELSE IF (PATFLG.EQ.2) THEN                       !pattern*
               IF (STR(1:IPT).EQ.PATTRN(1:IPT)) STAT = 1
            ELSE IF (PATFLG.EQ.3) THEN                       !pattr1*pattr2
               IF (N.GE.(IPT+IPTA)) THEN
                  M = N - IPTA + 1
                  IF ((STR(1:IPT).EQ.PATTRN(1:IPT)) .AND.
     +                (STR(M:N).EQ.PATTRA(1:IPTA))) STAT = 1
               ENDIF
            ELSE                                             !*pattern*
               IF (INDEX(STR,PATTRN(1:IPT)).GT.0) STAT = 1
            ENDIF
         ENDIF
C 
      ELSE
         IF (FLAG.EQ.11) THEN
C
C extract pattern for patternB
C
            M = INDEX(STR,' ') - 1              !real length
            IF (M.LT.1) M = LEN(STR)
C
            N = INDEX(STR,'*')
            IF (N.EQ.1) THEN
               IF (STR(M:M).EQ.'*') THEN 
                  QATTRN(1:) = STR(2:M-1)//' '
                  JPT = M - 2
                  QATFLG = 4                    ! = 4, for checking *pattern*
               ELSE
                  QATTRN(1:) = STR(2:)//' '
                  JPT = INDEX(QATTRN,' ') - 1
                  IF (JPT.LT.1) JPT = LEN(QATTRN)
                  QATFLG = 1                    ! = 1, for checking *pattern
               ENDIF
            ELSE
               IF ((M.EQ.N) .OR. (STR(N+1:N+1).EQ.' ')) THEN
                  JPT = N - 1
                  QATTRN(1:) = STR(1:JPT)//' '      
                  QATFLG = 2                    ! = 2, for checking pattern*
               ELSE
                  QATTRN(1:) = STR(1:N-1)//' '
                  JPT = INDEX(QATTRN,' ') - 1
                  IF (JPT.LT.1) JPT = LEN(QATTRN)
                  QATTRA(1:) = STR(N+1:)//' '
                  JPTA = INDEX(QATTRA,' ') - 1
                  IF (JPTA.LT.1) JPTA = LEN(QATTRA)
                  QATFLG = 3                 ! = 3, for checking pattr1*pattr2
               ENDIF
            ENDIF
C
C match patternB
C
         ELSE
            N = INDEX(STR,' ') - 1
            IF (N.LT.1) N = LEN(STR)
C
            IF (QATFLG.EQ.1) THEN                            !*pattern
               IF (N.GE.JPT) THEN
                  M = N - JPT + 1
                  IF (STR(M:N).EQ.QATTRN(1:JPT)) STAT = 1
               ENDIF
            ELSE IF (QATFLG.EQ.2) THEN                       !pattern*
               IF (STR(1:JPT).EQ.QATTRN(1:JPT)) STAT = 1
            ELSE IF (QATFLG.EQ.3) THEN                       !pattr1*pattr2
               IF (N.GE.(JPT+JPTA)) THEN
                  M = N - JPTA + 1
                  IF ((STR(1:JPT).EQ.QATTRN(1:JPT)) .AND.
     +                (STR(M:N).EQ.QATTRA(1:JPTA))) STAT = 1
               ENDIF
            ELSE                                             !*pattern*
               IF (INDEX(STR,QATTRN(1:JPT)).GT.0) STAT = 1
            ENDIF
         ENDIF
      ENDIF
C 
      RETURN
      END

      SUBROUTINE DSCDEL(IMNO,INDSC,DVERS,DELCNT)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine DSCDEL                    990114
C  K. Banse                             ESO - Garching
C
C.KEYWORDS
C  descriptors
C
C.PURPOSE
C  delete descriptors matching a pattern
C
C.ALGORITHM
C  read all existing descriptors + delete if pattern match
C
C.INPUT/OUTPUT
C  call as DSCDEL(IMNO,INDSC,DVERS,DELCNT)
C
C input:
C  IMNO:      I*4         frame no. of data frame
C  INDSC:     char.exp.   pattern of descriptors to be deleted
C  DVERS:     I*4         Descr format: 0 = old format, 1 = new large format
C output:
C  DELCNT:    I*4         no. of deleted descriptors
C
C-------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER      IMNO,DVERS,DELCNT
      INTEGER      DSCNO,IAV,NPOS,HNC
      INTEGER      NDI,NDLIM,STAT,NOELEM,BYTELM
      INTEGER      DIROFF,UNIT(1),NULLO
C 
      CHARACTER*(*)  INDSC
      CHARACTER      DIRBUF*32762
      CHARACTER      DISCR*80,DSCTYP*24
C 
      NPOS = 0
      DISCR(1:) = ' '
      CALL UPCAS(INDSC,DISCR)
C 
      CALL PATTST(1,DISCR,STAT)                !store the pattern(s)
      DELCNT = 0
C
      IF (DVERS.EQ.0) THEN                     !old descr. format
         NDI = 0
         NDLIM = 32760    !old descr format, only for max. 32760 descr...
         CALL STDRDC(IMNO,'DIRECTORY.MIDAS',1,1,NDLIM,NOELEM,
     +               DIRBUF,UNIT,NULLO,STAT)
         IAV = NOELEM/30
         DSCNO = IAV                           !max available descrs
         DIROFF = 1
      ELSE
         CALL STDRDX(IMNO,1,DISCR,DSCTYP,BYTELM,NOELEM,HNC,STAT)
         CALL STDRDX(IMNO,10,DISCR,DSCTYP,BYTELM,NOELEM,HNC,STAT)   !skip dscdir
      ENDIF
      GOTO 8000
C
C  prepare loop through descr. list
C
500   CALL PATTST(2,DISCR,STAT)
      IF (STAT.NE.0) THEN    
         DELCNT = DELCNT + 1                   !matching descr. found
         CALL STDDEL(IMNO,DISCR,STAT)
         NPOS = NPOS - 1                       !it's updated internally
      ENDIF
C 
C  increment counter + loop if there are more descriptors
C
8000  IF (DVERS.NE.0) THEN                   !new descr format
         DISCR(1:) = ' '
         CALL STDRDX(IMNO,10,DISCR,DSCTYP,BYTELM,NOELEM,HNC,STAT)
         IF (DISCR(1:1).NE.' ') THEN
            GOTO 500
         ENDIF
C 
      ELSE                                   !old descr format
         NDI = NDI + 1
8080     IF (NDI.LT.DSCNO) THEN
            DIROFF = DIROFF + 30
            IF (DIRBUF(DIROFF+15:DIROFF+15) .EQ. 'H') THEN
               DSCNO = DSCNO - 1
               GOTO 8080
            ELSE
               DISCR(1:) = DIRBUF(DIROFF:DIROFF+14)//' '
               GOTO 500                      !check next descriptor
            ENDIF
         ENDIF
      ENDIF
C
C  That's it folks ...
      RETURN
      END