C===========================================================================
C Copyright (C) 1995, 2003 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
      SUBROUTINE ODSCLS(IMNO,INDSC,IVALS,RVALS,CVALS,DVALS,FLAG)
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  subroutine ODSCLS			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-------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER      IMNO,IVALS(*)
      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
      DSCDIR = 'DIRECTORY.MIDAS'
      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
            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
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:) = ' '
            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)
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 
               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
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:) = ' '
         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
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 ODSCDL(IMNO,INDSC,DELCNT)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine ODSCDL                    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,DELCNT)
C
C input:
C  IMNO:      I*4         frame no. of data frame
C  INDSC:     char.exp.   pattern of descriptors to be deleted
C output:
C  DELCNT:    I*4         no. of deleted descriptors
C
C-------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER      IMNO,DELCNT
      INTEGER      DSCNO,IAV,NPOS
      INTEGER      NDI,NDLIM,STAT,NOELEM
      INTEGER      DIROFF,UNIT(1),NULLO
C 
      CHARACTER*(*)  INDSC
      CHARACTER      DIRBUF*32762
      CHARACTER      DISCR*80
C 
      NPOS = 0
      DISCR(1:) = ' '
      CALL UPCAS(INDSC,DISCR)
C 
      CALL PATTST(1,DISCR,STAT)                !store the pattern(s)
      DELCNT = 0
C
         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
      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     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
C
C  That's it folks ...
      RETURN
      END
