← Back to branch summary

~ubuntu-branches/debian/jessie/eso-midas/jessie

« back to all changes in this revision

Viewing changes to prim/general/src/descr.for

  • Committer: Package Import Robot
  • Author(s): Ole Streicher
  • Date: 2014-04-22 14:44:58 UTC
  • Revision ID: package-import@ubuntu.com-20140422144458-okiwi1assxkkiz39
Tags: upstream-13.09pl1.2+dfsg
Import upstream version 13.09pl1.2+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
prim/general/src/descr.for
 
1
C===========================================================================
 
2
C Copyright (C) 1995-2010 European Southern Observatory (ESO)
 
3
C                                         all rights reserved
 
4
C
 
5
C This program is free software; you can redistribute it and/or 
 
6
C modify it under the terms of the GNU General Public License as 
 
7
C published by the Free Software Foundation; either version 2 of 
 
8
C the License, or (at your option) any later version.
 
9
C
 
10
C This program is distributed in the hope that it will be useful,
 
11
C but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
13
C GNU General Public License for more details.
 
14
C
 
15
C You should have received a copy of the GNU General Public 
 
16
C License along with this program; if not, write to the Free 
 
17
C Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
 
18
C MA 02139, USA.
 
19
C
 
20
C Correspondence concerning ESO-MIDAS should be addressed as follows:
 
21
C       Internet e-mail: midas@eso.org
 
22
C       Postal address: European Southern Observatory
 
23
C                       Data Management Division 
 
24
C                       Karl-Schwarzschild-Strasse 2
 
25
C                       D 85748 Garching bei Muenchen 
 
26
C                       GERMANY
 
27
C===========================================================================
 
28
C
 
29
      PROGRAM DESCR
 
30
C
 
31
C++++++++++++++++++++++++++++++++++++++++++++++++++
 
32
C
 
33
C.LANGUAGE: F77+ESOext
 
34
C
 
35
C.AUTHOR: K.Banse
 
36
C
 
37
C.IDENTIFICATION
 
38
C  program DESCR          version 3.50  861003
 
39
C 
 
40
C.KEYWORDS
 
41
C  descriptors
 
42
C
 
43
C.PURPOSE
 
44
C  read/write or delete descriptors
 
45
C
 
46
C.ALGORITHM
 
47
C  use MIDAS interfaces to do the job
 
48
C
 
49
C.INPUT/OUTPUT
 
50
C  the following keys are used:
 
51
C  IN_A/C/1/120         name of data frame (input)
 
52
C                       "cleaned" name (output)
 
53
C  ACTION/C/1/2         (1) up to 6 different action flags
 
54
C                         = R, for reading a complete descriptor
 
55
C                         = W, for writing a descriptor
 
56
C                         = D, for deleting a descriptor
 
57
C                         = P, for printing a complete descriptor
 
58
C                         = C, for copying all descriptors
 
59
C                         = S, for showing all existing descriptors
 
60
C                       (2) display flag for READ option
 
61
C                         = F, for full display
 
62
C                         = B, for brief display
 
63
C                         = H, for display of data only (no header line)
 
64
C                       or hidden flag for SHOW option
 
65
C                         = H, for hidden display
 
66
C  P2/C/1/80            for (W) descriptor/type/1.elem./novals  
 
67
C  or as default        descriptor => has to exist
 
68
C                       1.elem. = 1 + fill as much as is there
 
69
C                       for (C) *,MASK with MASK as defined in STDCOP
 
70
C                       only descriptor(s) separated by a comma (R,D,P)LINE
 
71
C  P3/C/1/60            data values in ASCII (W)
 
72
C  P4/C/1/3             = ALL, if complete descr. should be filled (W)
 
73
C  INPUTI/I/10/1        dsc_process_flag for dest_descr's:
 
74
C                       2 = No Overwrite, 1 = clean first exisiting descr
 
75
C                       0 = just copy
 
76
C  OUT_A/C/1/120        name of output frame (C)
 
77
C
 
78
C  for option READ, PRINT + SHOW the integer keyword OUTPUTI(1-4) is set to
 
79
C  (1) 1/0 if descr exists or not
 
80
C  (2) 1/2/3/4 for int, real, char, double descr.
 
81
C  (3) noelem, (4) bytelem of descr
 
82
C 
 
83
C.VERSIONS
 
84
C 
 
85
C 101220        last modif
 
86
C--------------------------------------------------
 
87
C
 
88
      IMPLICIT NONE
 
89
C
 
90
      INTEGER      ACTVAL,BYTELM,DSCMSK,DSCVERS
 
91
      INTEGER      FIRST,FLAG,I,IAV,IOFF
 
92
      INTEGER      LL,N,NOELEM,CLEN
 
93
      INTEGER      SLEN,START,STAT,MAXNO
 
94
      INTEGER*8    WPNTR2
 
95
      INTEGER      IMNO,RIMNO,ALLFLG
 
96
      INTEGER      EC,EL,ED,LINLEN
 
97
      INTEGER      UNIT(1),NULLO,MADRID(1)
 
98
C
 
99
      CHARACTER    LINE*120,OUTPUT*120,ACTION*2
 
100
      CHARACTER    FRAME*120,RESFRA*120,DSCR*80,TYPE*20
 
101
      CHARACTER    INSTRM*1,COMPAR(6)*1,DTYPE*1
 
102
C
 
103
      INTEGER      IBUF(65535)                    !descr data buffers
 
104
      INTEGER*8    SBUF(65535) 
 
105
      REAL         RBUF(65535)
 
106
      CHARACTER    CBUF*65535
 
107
      DOUBLE PRECISION  DBUF(65535)
 
108
C
 
109
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
 
110
C
 
111
      COMMON  /VMR/ MADRID
 
112
C
 
113
      EQUIVALENCE      (IBUF,DBUF),(RBUF,DBUF),(SBUF,DBUF)
 
114
C
 
115
      DATA      COMPAR /'R','W','D','P','C','S'/
 
116
C
 
117
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
 
118
C
 
119
C  get into MIDAS
 
120
      CALL STSPRO('DESCR ')
 
121
      IMNO = -1
 
122
C
 
123
C  get frame + open it (do not extract subframe data...)
 
124
      CALL STKRDC('IN_A',1,1,120,IAV,FRAME,UNIT,NULLO,STAT)
 
125
      CALL STFINF(FRAME,9,IBUF,STAT)
 
126
      IF (STAT .NE. 0) then     
 
127
        CALL STETER(5,'could not read (FITS) file header...')
 
128
      endif
 
129
      IF (IBUF(2).EQ.F_TBL_TYPE) THEN
 
130
         CALL TBTOPN(FRAME,F_I_MODE,IMNO,STAT)
 
131
      ELSE
 
132
         CALL STFOPN(FRAME,D_OLD_FORMAT,0,F_OLD_TYPE,IMNO,STAT)
 
133
      ENDIF
 
134
      IBUF(1) = IMNO
 
135
      CALL STFINF(FRAME,-6,IBUF,STAT)   !we reuse IMNO with flag < 0
 
136
      DSCVERS = IBUF(3)                 !get descr. format version
 
137
C
 
138
C  get action flag              ( ACTION(2:2) = display flag )
 
139
      CALL STKRDC('ACTION',1,1,2,IAV,ACTION,UNIT,NULLO,STAT)
 
140
      CALL UPCAS(ACTION,ACTION)
 
141
      DO 50, N=1,6
 
142
         IF (ACTION(1:1).EQ.COMPAR(N)) THEN
 
143
            FLAG = N
 
144
            GOTO 200
 
145
         ENDIF
 
146
50    CONTINUE
 
147
      CALL STETER(23,'module DESCR: invalid option...')
 
148
C
 
149
C  branch according to desired action
 
150
200   GOTO (1000,2000,3500,1000,5000,1000),FLAG
 
151
C
 
152
C  read, show or print descriptor (all values)
 
153
C
 
154
1000  CALL STKRDC('P2',1,1,80,LINLEN,LINE,UNIT,NULLO,STAT)
 
155
      IF (ACTION(2:2).NE.'H') CALL FRAMOU(FRAME)     !show frame and data type 
 
156
C
 
157
      IF (LINE(1:1).EQ.'*') THEN                     !all descriptors?
 
158
         IF ((LINE(2:2).EQ.' ') .OR. (LINE(2:2).EQ.','))
 
159
     +      LINE(1:1) = ' '
 
160
         IF (DSCVERS.EQ.0) THEN
 
161
            CALL ODSCLS(IMNO,LINE(1:80),IBUF,RBUF,CBUF,DBUF,ACTION)
 
162
         ELSE
 
163
            CALL DSCLIS(IMNO,LINE(1:80),IBUF,RBUF,CBUF,DBUF,SBUF,ACTION)
 
164
         ENDIF
 
165
         GOTO 8000
 
166
      ENDIF
 
167
C
 
168
      CALL LOWCAS(LINE,LINE)                         !check for ASCII file
 
169
      N = INDEX(LINE,'.ascii')
 
170
      IF (N.GT.1) THEN
 
171
         N = INDEX(LINE,' ') - 1                     !cut off trailing blanks
 
172
         IF (N.LT.1) N = LEN(LINE)
 
173
         OPEN(UNIT=33,FILE=LINE(1:N),STATUS='OLD',ERR=1090)
 
174
C 
 
175
1050     LINE(1:) = ' '
 
176
         READ(33,10000,END=1080) LINE
 
177
         START = 1
 
178
1060     CALL EXTRSS(LINE,',',START,DSCR,SLEN)
 
179
         IF (SLEN.GT.0) THEN
 
180
            IF (DSCVERS.EQ.0) THEN
 
181
               CALL ODSCLS(IMNO,LINE,IBUF,RBUF,CBUF,DBUF,ACTION)
 
182
            ELSE
 
183
               CALL DSCLIS(IMNO,LINE,IBUF,RBUF,CBUF,DBUF,SBUF,ACTION)
 
184
            ENDIF
 
185
            GOTO 1060
 
186
         ELSE
 
187
            GOTO 1050                                !read next line
 
188
         ENDIF
 
189
C 
 
190
1080     CLOSE(UNIT=33)
 
191
         GOTO 8000
 
192
1090     CALL STETER(4,'could not open ASCII file...')
 
193
         GOTO 8000
 
194
      ENDIF
 
195
C 
 
196
C  extract descriptor(s) separated by a comma from single line
 
197
      START = 1
 
198
1100  CALL EXTRSS(LINE(1:LINLEN),',',START,DSCR,SLEN)
 
199
      IF (SLEN.LE.0) THEN
 
200
         GOTO 8000
 
201
      ELSE
 
202
         IF (DSCVERS.EQ.0) THEN
 
203
            CALL ODSCLS(IMNO,DSCR,IBUF,RBUF,CBUF,DBUF,ACTION)
 
204
         ELSE
 
205
            CALL DSCLIS(IMNO,DSCR,IBUF,RBUF,CBUF,DBUF,SBUF,ACTION)
 
206
         ENDIF
 
207
         GOTO 1100
 
208
      ENDIF
 
209
C
 
210
C  write descriptor (not necessarily all values)
 
211
C
 
212
2000  CALL STKRDC('P2',1,1,80,IAV,LINE,UNIT,NULLO,STAT)
 
213
      CALL STKRDC('P4',1,1,1,IAV,CBUF,UNIT,NULLO,STAT)
 
214
      IF ((CBUF(1:1).EQ.'A') .OR.
 
215
     +    (CBUF(1:1).EQ.'a')) THEN
 
216
         ALLFLG = 1
 
217
      ELSE
 
218
         ALLFLG = 0
 
219
      ENDIF
 
220
      CBUF(1:81) = ' '                                   !we need [81] if "..."
 
221
      CALL STKRDC('P3',1,1,80,IAV,CBUF,UNIT,NULLO,STAT)       !get data string
 
222
C
 
223
C  either use defaults (1. element,...)
 
224
C                                                    test, if default is used
 
225
      LL = INDEX(LINE,'/')
 
226
      IF (LL.LE.0) THEN
 
227
         START = 0            !set START to the "wrong" value = 0, to remember
 
228
         DSCR = LINE
 
229
         FIRST = 1
 
230
         CALL STDFND(IMNO,DSCR,DTYPE,NOELEM,BYTELM,STAT)
 
231
 
 
232
         IF (DTYPE.EQ.' ') CALL STETER
 
233
     +     (1,'default option invalid - descriptor does not exist... ')
 
234
C
 
235
C  or extract specific info about starting element, etc.
 
236
      ELSE
 
237
         START = 1
 
238
         CALL EXTRSS(LINE,'/',START,DSCR,SLEN)
 
239
         CALL EXTRSS(LINE,'/',START,TYPE,SLEN)
 
240
         CALL DTCHK(TYPE,DTYPE,BYTELM,MAXNO)
 
241
C                                                         wrong type given...
 
242
         IF (DTYPE.EQ.' ') GOTO 8900
 
243
C
 
244
         CALL EXTRSS(LINE,'/',START,OUTPUT,SLEN)
 
245
         CALL GENCNV(OUTPUT,1,1,FIRST,RBUF,DBUF,LL)
 
246
         IF (LL.LT.1) GOTO 8900
 
247
         CALL EXTRSS(LINE,'/',START,OUTPUT,SLEN)
 
248
         CALL GENCNV(OUTPUT,1,1,NOELEM,RBUF,DBUF,LL)
 
249
         IF (LL.LT.1) GOTO 8900
 
250
         IF (NOELEM .GT. MAXNO) THEN
 
251
            NOELEM = MAXNO
 
252
            WRITE(OUTPUT,10005) NOELEM
 
253
            CALL STTPUT(OUTPUT,STAT)
 
254
         ENDIF
 
255
      ENDIF
 
256
C 
 
257
C  get input stream
 
258
      CALL STKRDC('MID$IN',1,1,120,IAV,OUTPUT,UNIT,NULLO,STAT)  
 
259
      INSTRM = OUTPUT(1:1)
 
260
      IF (INSTRM.EQ.'F') GOTO 2660
 
261
C
 
262
C  integer descriptor
 
263
      IF (DTYPE.EQ.'I') THEN
 
264
         IF (ALLFLG.EQ.1) THEN
 
265
            CALL GENCNV(CBUF(1:20),1,1,IBUF,RBUF,DBUF,LL)
 
266
            IF (LL.LE.0) GOTO 8800
 
267
            ACTVAL = NOELEM
 
268
            DO 2250 N=2,ACTVAL
 
269
               IBUF(N) = IBUF(1)
 
270
2250        CONTINUE
 
271
         ELSE
 
272
            CALL GENCNV(CBUF(1:80),1,NOELEM,IBUF,RBUF,DBUF,ACTVAL)
 
273
            IF (ACTVAL.LE.0) GOTO 8800
 
274
         ENDIF
 
275
         CALL STDWRI(IMNO,DSCR,IBUF,FIRST,ACTVAL,UNIT,STAT)
 
276
C
 
277
C  real descriptor
 
278
      ELSE IF (DTYPE.EQ.'R') THEN
 
279
         IF (ALLFLG.EQ.1) THEN
 
280
            CALL GENCNV(CBUF(1:20),2,1,IBUF,RBUF,DBUF,LL)
 
281
            IF (LL.LE.0) GOTO 8800
 
282
            ACTVAL = NOELEM
 
283
            DO 2280, N=2,ACTVAL
 
284
               RBUF(N) = RBUF(1)
 
285
2280        CONTINUE
 
286
         ELSE
 
287
            CALL GENCNV(CBUF(1:80),2,NOELEM,IBUF,RBUF,DBUF,ACTVAL)
 
288
            IF (ACTVAL.LE.0) GOTO 8800
 
289
         ENDIF
 
290
         CALL STDWRR(IMNO,DSCR,RBUF,FIRST,ACTVAL,UNIT,STAT)
 
291
C
 
292
C  character descriptor 
 
293
      ELSE IF ((DTYPE.EQ.'C') .OR. (DTYPE.EQ.'H')) THEN
 
294
         LL = 80                                    !cut off trailing blanks
 
295
         DO 2300, I=LL,1,-1
 
296
            IF (CBUF(I:I).NE.' ') THEN
 
297
               CLEN = I
 
298
               GOTO 2310
 
299
            ENDIF
 
300
2300     CONTINUE
 
301
         CLEN = 1
 
302
2310     IF ((START.EQ.0) .AND. (ALLFLG.EQ.0)) NOELEM = CLEN 
 
303
C 
 
304
C  now look for " ... "
 
305
         IOFF = 1
 
306
         IF ((CBUF(1:1).EQ.'"')       .AND.
 
307
     +       (CBUF(CLEN:CLEN).EQ.'"') .AND.
 
308
     +       (CLEN.GT.2)) THEN                  !only possible for CLEN > 2
 
309
            IOFF = 2
 
310
            CBUF(CLEN:CLEN) = ' '
 
311
            IF ((START.EQ.0) .AND. (ALLFLG.EQ.0)) 
 
312
     +         NOELEM = NOELEM - 2
 
313
         ENDIF
 
314
C
 
315
C  character array
 
316
         IF (BYTELM.GT.1) THEN
 
317
            IF (ALLFLG.EQ.1) THEN
 
318
C                                  this makes it work for only 1 element, too
 
319
               LL = 1
 
320
               DO 2320, N=1,NOELEM 
 
321
                  CBUF(LL:LL+BYTELM-1) = CBUF(IOFF:IOFF+BYTELM-1)
 
322
                  LL = LL + BYTELM
 
323
2320           CONTINUE
 
324
               IOFF = 1
 
325
            ENDIF
 
326
            CALL STDWRC(IMNO,DSCR,BYTELM,CBUF(IOFF:),FIRST,NOELEM,
 
327
     +                  UNIT,STAT)
 
328
C
 
329
C  flat character string
 
330
         ELSE
 
331
            IF (ALLFLG.EQ.1) THEN
 
332
               DO 2330, N=1,NOELEM
 
333
                  CBUF(N:N) = CBUF(IOFF:IOFF)
 
334
2330           CONTINUE
 
335
               IOFF = 1
 
336
            ENDIF
 
337
            IF (DTYPE.EQ.'H') THEN
 
338
               CALL STDWRH(IMNO,DSCR,CBUF(IOFF:),FIRST,NOELEM,STAT)
 
339
            ELSE
 
340
               CALL STDWRC(IMNO,DSCR,1,CBUF(IOFF:),FIRST,NOELEM,
 
341
     +                     UNIT,STAT)
 
342
            ENDIF
 
343
 
 
344
         ENDIF
 
345
C
 
346
C  double prec. descriptor
 
347
      ELSE IF (DTYPE.EQ.'D') THEN
 
348
         IF (ALLFLG.EQ.1) THEN
 
349
            CALL GENCNV(CBUF(1:40),4,1,IBUF,RBUF,DBUF,LL)
 
350
            IF (LL.LE.0) GOTO 8800
 
351
            ACTVAL = NOELEM
 
352
            DO 2350, N=2,ACTVAL
 
353
               DBUF(N) = DBUF(1)
 
354
2350        CONTINUE
 
355
         ELSE
 
356
            CALL GENCNV(CBUF(1:80),4,NOELEM,IBUF,RBUF,DBUF,ACTVAL)
 
357
            IF (ACTVAL.LE.0) GOTO 8800
 
358
         ENDIF
 
359
         CALL STDWRD(IMNO,DSCR,DBUF,FIRST,ACTVAL,UNIT,STAT)
 
360
C 
 
361
C  logical descriptor
 
362
      ELSE IF (DTYPE.EQ.'L') THEN
 
363
         IF (ALLFLG.EQ.1) THEN
 
364
            IF ((CBUF(1:1).EQ.'T') .OR. (CBUF(1:1).EQ.'t')) THEN
 
365
               IBUF(1) = 1
 
366
            ELSE IF ((CBUF(1:1).EQ.'F') .OR. (CBUF(1:1).EQ.'f')) THEN
 
367
               IBUF(1) = 0
 
368
            ELSE
 
369
               CALL GENCNV(CBUF(1:20),1,1,IBUF,RBUF,DBUF,LL)
 
370
               IF (LL.LE.0) GOTO 8800
 
371
            ENDIF
 
372
            ACTVAL = NOELEM
 
373
            DO 2400, N=2,ACTVAL
 
374
               IBUF(N) = IBUF(1)
 
375
2400        CONTINUE
 
376
         ELSE
 
377
            ACTVAL = 1           !for single value, also T(rue), F(alse) is o.k.
 
378
            IF ((CBUF(1:1).EQ.'T') .OR. (CBUF(1:1).EQ.'t')) THEN
 
379
               IBUF(1) = 1
 
380
            ELSE IF ((CBUF(1:1).EQ.'F') .OR. (CBUF(1:1).EQ.'f')) THEN
 
381
               IBUF(1) = 0
 
382
            ELSE
 
383
               CALL GENCNV(CBUF(1:80),1,NOELEM,IBUF,RBUF,DBUF,ACTVAL)
 
384
               IF (ACTVAL.LE.0) GOTO 8800
 
385
            ENDIF
 
386
         ENDIF
 
387
         CALL STDWRL(IMNO,DSCR,IBUF,FIRST,ACTVAL,UNIT,STAT)
 
388
      ENDIF
 
389
      GOTO 8000
 
390
C
 
391
C  come here, if we read the data from file
 
392
C  get data from file used as input stream in MIDAS into temporary buffer
 
393
2660  ACTVAL = 1
 
394
      ALLFLG = 0
 
395
C
 
396
C  integer descr
 
397
      IF (DTYPE.EQ.'I') THEN
 
398
         CALL CNTDAT(OUTPUT(3:),'NUM',ACTVAL)            !count data in file
 
399
         IF (ACTVAL.LE.0)
 
400
     +      CALL STETER(22,'Invalid integer input file...')
 
401
C 
 
402
         CALL STFXMP(ACTVAL,D_I4_FORMAT,WPNTR2,STAT)
 
403
         CALL DATFIL(OUTPUT(3:),1,ACTVAL,MADRID(WPNTR2),MADRID(WPNTR2),
 
404
     +               0,RBUF(1),RBUF(2))              !now get the integer data
 
405
         CALL STDWRI(IMNO,DSCR,MADRID(WPNTR2),FIRST,ACTVAL,UNIT,STAT)
 
406
C
 
407
C  real descr
 
408
      ELSE IF (DTYPE.EQ.'R') THEN
 
409
         CALL CNTDAT(OUTPUT(3:),'NUM',ACTVAL)            !count data in file
 
410
         IF (ACTVAL.LE.0) CALL STETER(22,'Invalid real input file...')
 
411
C
 
412
         CALL STFXMP(ACTVAL,D_R4_FORMAT,WPNTR2,STAT)
 
413
         CALL DATFIL(OUTPUT(3:),2,ACTVAL,MADRID(WPNTR2),MADRID(WPNTR2),
 
414
     +               0,RBUF(1),RBUF(2))              !now get the real data
 
415
         CALL STDWRR(IMNO,DSCR,MADRID(WPNTR2),FIRST,ACTVAL,UNIT,STAT)
 
416
C
 
417
C  character descr
 
418
      ELSE IF ((DTYPE.EQ.'C') .OR. (DTYPE.EQ.'H')) THEN
 
419
         CALL CNTDAT(OUTPUT(3:),'CHAR',ACTVAL)            !count chars. in file
 
420
         IF (ACTVAL.LE.0) CALL STETER(22,'Invalid char. input file...')
 
421
C 
 
422
         N = ACTVAL/4 + 1
 
423
         CALL STFXMP(N,D_I4_FORMAT,WPNTR2,STAT)
 
424
         CALL CARFIL(OUTPUT(3:),ACTVAL,MADRID(WPNTR2))   !now get the characters
 
425
         IF (DTYPE.EQ.'H') THEN
 
426
            CALL STDWRH(IMNO,DSCR,MADRID(WPNTR2),FIRST,ACTVAL,STAT)
 
427
         ELSE
 
428
            CALL STDWRC(IMNO,DSCR,BYTELM,MADRID(WPNTR2),
 
429
     +                  FIRST,ACTVAL,UNIT,STAT)
 
430
         ENDIF
 
431
C
 
432
C  double prec. descr
 
433
      ELSE IF (DTYPE.EQ.'D') THEN
 
434
         CALL CNTDAT(OUTPUT(3:),'NUM',ACTVAL)            !count data in file
 
435
         IF (ACTVAL.LE.0) CALL STETER(22,'Invalid double input file...')
 
436
C
 
437
         CALL STFXMP(ACTVAL,D_R8_FORMAT,WPNTR2,STAT)
 
438
         CALL DATFIL(OUTPUT(3:),4,ACTVAL,MADRID(WPNTR2),MADRID(WPNTR2),
 
439
     +               0,RBUF(1),RBUF(2))              !now get the real data
 
440
         CALL STDWRD(IMNO,DSCR,MADRID(WPNTR2),FIRST,ACTVAL,UNIT,STAT)
 
441
C
 
442
C  logical descr
 
443
      ELSE IF (DTYPE.EQ.'L') THEN
 
444
         CALL CNTDAT(OUTPUT(3:),'NUM',ACTVAL)            !count data in file
 
445
         IF (ACTVAL.LE.0)
 
446
     +      CALL STETER(22,'Invalid logical input file...')
 
447
C 
 
448
         CALL STFXMP(ACTVAL,D_I4_FORMAT,WPNTR2,STAT)
 
449
         CALL DATFIL(OUTPUT(3:),1,ACTVAL,MADRID(WPNTR2),MADRID(WPNTR2),
 
450
     +               0,RBUF(1),RBUF(2))              !now get the integer data
 
451
         CALL STDWRL(IMNO,DSCR,MADRID(WPNTR2),FIRST,ACTVAL,UNIT,STAT)
 
452
      ENDIF
 
453
      GOTO 8000
 
454
C
 
455
C  delete descriptors
 
456
C
 
457
3500  CALL STKRDC('P2',1,1,80,IAV,DSCR,UNIT,NULLO,STAT)
 
458
      CALL STKRDC('P3',1,1,4,IAV,TYPE,UNIT,NULLO,STAT)       !TYPE = stopflag
 
459
      IF (TYPE(1:1).EQ.'n') TYPE(1:1) = 'N'
 
460
      IF (DSCR(1:2).EQ.'* ') THEN
 
461
         CALL STDDEL(IMNO,DSCR,STAT)
 
462
C 
 
463
      ELSE
 
464
         CALL STECNT('GET',EC,EL,ED)
 
465
         IF (TYPE(1:1).EQ.'N') CALL STECNT('PUT',1,0,0)
 
466
C
 
467
C  extract descriptor(s) separated by a comma from single line
 
468
         START = 1
 
469
         ACTVAL = 0
 
470
3550     CALL EXTRSS(DSCR,',',START,OUTPUT,SLEN)
 
471
         IF (SLEN.GT.0) THEN
 
472
            N = INDEX(OUTPUT,'*')
 
473
            IF (N.GT.0) THEN                           !we have a pattern
 
474
               IF (DSCVERS.EQ.0) THEN
 
475
                  CALL ODSCDL(IMNO,OUTPUT,IAV)
 
476
               ELSE
 
477
                  CALL DSCDEL(IMNO,OUTPUT,IAV)
 
478
               ENDIF
 
479
               ACTVAL = ACTVAL + IAV
 
480
            ELSE
 
481
               CALL STDDEL(IMNO,OUTPUT,STAT)           !delete single descr
 
482
               ACTVAL = ACTVAL + 1
 
483
            ENDIF
 
484
            GOTO 3550
 
485
         ENDIF
 
486
         CALL STECNT('PUT',EC,EL,ED)
 
487
         CALL STKWRI('OUTPUTI',ACTVAL,1,1,UNIT,STAT) 
 
488
      ENDIF
 
489
      GOTO 8000
 
490
C
 
491
C  copy descriptors
 
492
C 
 
493
5000  CALL STKRDC('OUT_A',1,1,120,IAV,RESFRA,UNIT,NULLO,STAT)
 
494
      CALL STFOPN(RESFRA,D_OLD_FORMAT,0,F_OLD_TYPE,RIMNO,STAT)
 
495
C                                   get *,1 *,2 *,3, ...  or just *
 
496
      CALL STKRDC('P2',1,1,100,IAV,CBUF,UNIT,NULLO,STAT)
 
497
      DSCMSK = 1
 
498
      LL = INDEX(CBUF(1:100),' ')              !find end of buffer
 
499
      IF (LL.LT.1) LL = 100
 
500
      IF (CBUF(2:2).EQ.',') THEN
 
501
         CALL GENCNV(CBUF(3:3),1,1,DSCMSK,RBUF,DBUF,IAV)
 
502
         IF (IAV.NE.1)
 
503
     +      CALL STETER(12,'wrong flag in COPY/DD ...')
 
504
 
 
505
         IF (CBUF(4:4).EQ.',') THEN            !*,n,descrNOT,descrNOT,...
 
506
            CBUF(1:LL) = CBUF(5:LL) //' '               
 
507
            DSCMSK = DSCMSK + 5                !update the copy-mask
 
508
         ELSE
 
509
            CBUF(1:LL) = ' '
 
510
         ENDIF
 
511
C 
 
512
      ELSE IF (CBUF(1:1).EQ.'?') THEN
 
513
         CBUF(1:LL) = CBUF(2:LL)//' '
 
514
         DSCMSK = 4                         !we have descnames or patterns
 
515
5100     N = INDEX(CBUF(1:LL),'*') 
 
516
         IF (N .GT. 0) THEN              
 
517
            IAV = INDEX(CBUF(1:LL),',')
 
518
            IF (IAV.GT.1) THEN
 
519
               CBUF(101:200) = CBUF(1:IAV-1)//' '
 
520
               CBUF(1:LL) = CBUF(IAV+1:LL)//' '
 
521
               CALL STDCOP(IMNO,RIMNO,DSCMSK,CBUF(101:200),STAT)
 
522
               LL = INDEX(CBUF(1:),' ')                  !we do have a ' '
 
523
               GOTO 5100
 
524
            ENDIF
 
525
         ENDIF
 
526
      ENDIF
 
527
C                         get descr_process_flag and copy all descriptors
 
528
      CALL STKRDI('INPUTI',10,1,IAV,N,UNIT,NULLO,STAT)
 
529
      IF (N.GT.0) DSCMSK = DSCMSK + (N*100)          !include dsc_process_flag
 
530
      CALL STDCOP(IMNO,RIMNO,DSCMSK,CBUF(1:LL),STAT)
 
531
C
 
532
C  we're done without problems
 
533
C
 
534
8000  CALL STSEPI
 
535
C
 
536
C  here, if syntax error in data string
 
537
8800  CALL STETER(2,'wrong syntax in data string... ')
 
538
C
 
539
C  here for syntax errors detected while reading stuff...
 
540
8900  CALL STETER(3,'wrong syntax in descriptor string... ')
 
541
C
 
542
C 
 
543
10000 FORMAT(A)
 
544
10005 FORMAT('Warning: only ',I5,
 
545
     +       ' descriptor elements written in one go ...')
 
546
C 
 
547
      END
 
548
 
 
549
      SUBROUTINE DSCLIS(IMNO,INDSC,IVALS,RVALS,CVALS,DVALS,SVALS,FLAG)
 
550
C
 
551
C+++++++++++++++++++++++++++++++++++++++++++++++++
 
552
C
 
553
C.IDENTIFICATION
 
554
C  subroutine DSCLIS                    version 3.50    090323
 
555
C  K. Banse                             ESO - Garching
 
556
C
 
557
C.KEYWORDS
 
558
C  descriptors
 
559
C
 
560
C.PURPOSE
 
561
C  display contents of one or all descriptors of a bulk data frame
 
562
C
 
563
C.ALGORITHM
 
564
C  read all existing descriptor names + display their contents
 
565
C
 
566
C.INPUT/OUTPUT
 
567
C  call as DSCLIS(IMNO,INDSC,IVALS,RVALS,CVALS,DVALS,SVALS,FLAG)
 
568
C
 
569
C  IMNO:      I*4         frame no. of data frame
 
570
C  INDSC:     char.exp.   descriptor to be displayed
 
571
C                         if = ' ', all descriptors are displayed
 
572
C  IVALS:     I*4 array   integer buffer
 
573
C  RVALS:     R*4 array   real buffer
 
574
C  CVALS:     char.exp.   character buffer
 
575
C  DVALS:     R*8 array   double precision buffer
 
576
C  SVALS:     I*8 array   size_t buffer
 
577
C  FLAG:      char.exp.   2-char. flag:
 
578
C                         (1) = R(ead), P(rint) or S(how)
 
579
C                         (2) = F(ull), B(rief) or H(idden)
 
580
C
 
581
C-------------------------------------------------
 
582
C
 
583
      IMPLICIT NONE
 
584
C
 
585
      INTEGER      IMNO,IVALS(*)
 
586
      INTEGER      LIM(7)
 
587
      INTEGER      BYTELM,NOELEM,NPOS
 
588
      INTEGER      DSCNO(2),DSCLEN,IAV,IOFF,ITY,L,LL,M,MM,N,KCASE
 
589
      INTEGER      NDI,STAT,IJK(5),NPT
 
590
      INTEGER      EL1,NEL2,NOTDS,HNC
 
591
      INTEGER      OPTIO,UNIT(1),NULLO,XLONG
 
592
      INTEGER*8    SVALS(*)
 
593
C
 
594
      CHARACTER*(*)  INDSC
 
595
      CHARACTER*(*)  CVALS
 
596
      CHARACTER*(*)  FLAG
 
597
      CHARACTER      LF*1,TYPE*1
 
598
      CHARACTER      DISCR*80,DSCDIR*24,DSCTYP*24
 
599
      CHARACTER      NOTDSC(4)*72,OUTPUT*80,CCC*14,CBUF*80
 
600
      CHARACTER      CC(7)*12,CTYPE*4,CHTYP*14,BLANK*20
 
601
C
 
602
      REAL           RVALS(*)
 
603
C
 
604
      DOUBLE PRECISION DVALS(*)
 
605
C 
 
606
      DATA      CC/'integer ','real ','character ','double prec.',
 
607
     +             ' ','logical ','size_t '/
 
608
      DATA      CHTYP /'character* '/
 
609
      DATA      LIM      /6,4,60,2,1,10,2/
 
610
      DATA      BLANK /' '/, CCC /' '/
 
611
C
 
612
      LF = CHAR(10)                   !LineFeed character ( \n in C)
 
613
      DSCNO(1) = 0                    !for descriptor
 
614
      DSCNO(2) = -1                   !for help text of descriptor
 
615
      NPOS = 1
 
616
      NDI = 0
 
617
      DSCDIR = 'DESCRIPTOR.DIRECTORY'
 
618
      EL1 = 1
 
619
      NEL2 = 0
 
620
C
 
621
C  clean + convert to uppercase
 
622
      DISCR(1:) = ' '
 
623
      CALL UPCAS(INDSC,DISCR)
 
624
      IF (DISCR.EQ.DSCDIR) THEN
 
625
         OPTIO = -1                                !descr. directory
 
626
         NOELEM = 0
 
627
         CALL STDRDZ(IMNO,NOELEM,DSCNO(1),STAT) 
 
628
         RETURN
 
629
C
 
630
      ELSE IF (DISCR(1:1).EQ.' ') THEN
 
631
         IF ((DISCR(2:2).EQ.',') .OR.              !descriptors NOT to display
 
632
     +       (DISCR(2:2).EQ.'|')) THEN
 
633
            NOTDS = 1
 
634
            DISCR(2:2) = ' '
 
635
110         N = INDEX(DISCR,',')
 
636
            IF (N.GT.1) THEN
 
637
               NOTDSC(NOTDS)(1:) = DISCR(3:N-1)//' ' 
 
638
               DISCR(3:) = DISCR(N+1:)
 
639
               IF (NOTDS.LT.4) THEN
 
640
                  NOTDS = NOTDS + 1
 
641
                  GOTO 110 
 
642
               ENDIF
 
643
            ELSE
 
644
               NOTDSC(NOTDS)(1:) = DISCR(3:)
 
645
               IF (NOTDS.EQ.1) THEN
 
646
                  N = INDEX(NOTDSC(1),'*')
 
647
                  IF (N.GT.0) THEN
 
648
                     CALL PATTST(1,NOTDSC(1),STAT)
 
649
                     NOTDS = -1
 
650
                  ENDIF
 
651
               ENDIF
 
652
            ENDIF
 
653
         ELSE
 
654
            NOTDS = 0
 
655
         ENDIF
 
656
         OPTIO = 1                    !all descriptors
 
657
         DISCR(1:) = ' '
 
658
         CALL STDRDX(IMNO,1,DISCR,DSCTYP,BYTELM,NOELEM,HNC,STAT)  !get dscdir
 
659
         CALL STDRDX(IMNO,10,DISCR,DSCTYP,BYTELM,NOELEM,HNC,STAT) !get 1.dsc
 
660
         IF (DISCR(1:1).EQ.' ') GOTO 9000
 
661
         DSCNO(1) = 2                 !at least 1 descr. + directory
 
662
C 
 
663
      ELSE
 
664
         N = INDEX(DISCR,'*') 
 
665
         IF (N.GT.0) THEN                  !we have a pattern
 
666
            N = INDEX(DISCR,'|')
 
667
            IF (N.GT.1) THEN               !is it incl-patrn | excl-patrn?
 
668
               OPTIO = 3
 
669
               CALL PATTST(1,DISCR(1:N-1),STAT)    !save the two patterns
 
670
               CALL PATTST(11,DISCR(N+1:),STAT)
 
671
            ELSE
 
672
               OPTIO = 2
 
673
               CALL PATTST(1,DISCR,STAT)
 
674
            ENDIF
 
675
            NPT = 0
 
676
            CALL STDRDX(IMNO,1,DISCR,DSCTYP,BYTELM,NOELEM,HNC,STAT) 
 
677
            NPOS = 0
 
678
            GOTO 8000
 
679
         ENDIF
 
680
C 
 
681
         OPTIO = 0                 !single descriptor 
 
682
         DSCNO(1) = 1         
 
683
         N = INDEX(DISCR,'/')                  !see, if it's descr/type/f/no
 
684
         IF (N.GT.1) THEN
 
685
            CBUF(1:) = DISCR(N+1:)
 
686
            DISCR(N:) = ' '
 
687
         ENDIF
 
688
         CALL STDFND(IMNO,DISCR,DSCTYP,NOELEM,BYTELM,STAT)
 
689
C 
 
690
         IF (N.GT.1) THEN
 
691
            N = INDEX(CBUF,'/')               !skip type
 
692
            IF (N.GT.1) THEN
 
693
               CBUF(1:) = CBUF(N+1:)
 
694
               DO 440,N=1,30
 
695
                  IF (CBUF(N:N).EQ.'/') THEN
 
696
                     CBUF(N:N) = ','
 
697
                     CALL GENCNV(CBUF,1,2,IVALS,RVALS,DVALS,LL)
 
698
                     IF (LL.EQ.2) THEN
 
699
                        EL1 = IVALS(1)
 
700
                        NEL2 = IVALS(2)
 
701
                        GOTO 500
 
702
                     ENDIF
 
703
                  ENDIF
 
704
440            CONTINUE
 
705
            ENDIF
 
706
         ENDIF
 
707
C 
 
708
      ENDIF
 
709
C
 
710
C
 
711
C  loop through descr. list
 
712
C
 
713
500   IF (OPTIO.GE.2) THEN                          !we have pattern(s)
 
714
         CALL PATTST(2,DISCR,STAT)
 
715
         IF (STAT.EQ.0) GOTO 8000                   !no match
 
716
C 
 
717
         IF (OPTIO.EQ.3) THEN
 
718
            CALL PATTST(12,DISCR,STAT)
 
719
            IF (STAT.EQ.1) GOTO 8000                !it's an excluded descr
 
720
         ENDIF
 
721
         NPT = NPT + 1                              !matching descr. found
 
722
C 
 
723
      ELSE IF (OPTIO.EQ.1) THEN
 
724
         IF (NOTDS.NE.0) THEN 
 
725
            IF (NOTDS.GT.0) THEN                    !loop thru excluded descrs
 
726
               DO 550, N=1,NOTDS
 
727
                  IF (DISCR.EQ.NOTDSC(N)) THEN
 
728
                     DSCNO(1) = DSCNO(1) - 1
 
729
                     GOTO 8000
 
730
                  ENDIF
 
731
550            CONTINUE
 
732
            ELSE 
 
733
               CALL PATTST(2,DISCR,STAT)
 
734
               IF (STAT.EQ.1) THEN
 
735
                  DSCNO(1) = DSCNO(1) - 1
 
736
                  GOTO 8000
 
737
               ENDIF
 
738
            ENDIF
 
739
         ENDIF
 
740
      ENDIF
 
741
C 
 
742
      IF (NEL2.GT.0) NOELEM = NEL2
 
743
C 
 
744
      DSCLEN = INDEX(DISCR,' ') - 1              !real length of descr name
 
745
      TYPE = DSCTYP(1:1)
 
746
      IF (TYPE.EQ.' ') THEN
 
747
         IJK(1) = 0
 
748
         IF (FLAG(2:2).NE.'H') THEN
 
749
            OUTPUT(1:) = 'descriptor '//DISCR(1:DSCLEN)//
 
750
     +                   ' not present... '
 
751
            CALL STTPUT(OUTPUT,STAT)
 
752
         ENDIF
 
753
         GOTO 8000
 
754
      ENDIF
 
755
C 
 
756
      IJK(1) = 1
 
757
      STAT = 0
 
758
      XLONG = 0
 
759
      IF (NOELEM.GT.65535) THEN
 
760
         XLONG = NOELEM - 65535
 
761
         NOELEM = 65535                   !ojo: synchronize with MAIN ...
 
762
      ENDIF
 
763
C
 
764
C  get integer data
 
765
700   IF (TYPE.EQ.'I') THEN
 
766
         ITY = 1
 
767
         IF (FLAG(1:1).NE.'S') CALL STDRDI
 
768
     +   (IMNO,DISCR,EL1,NOELEM,IAV,IVALS,UNIT,NULLO,STAT)
 
769
C
 
770
C  get real data
 
771
      ELSE IF (TYPE.EQ.'R') THEN
 
772
         ITY = 2
 
773
         IF (FLAG(1:1).NE.'S') CALL STDRDR
 
774
     +   (IMNO,DISCR,EL1,NOELEM,IAV,RVALS,UNIT,NULLO,STAT)
 
775
C
 
776
C  get character data
 
777
      ELSE IF (TYPE.EQ.'C') THEN
 
778
         IF (BYTELM.GT.1) THEN
 
779
            ITY = 5
 
780
            WRITE(CTYPE,30000) BYTELM
 
781
C                                                     omit leading blanks...
 
782
            DO 800 LL=1,3
 
783
               IF (CTYPE(LL:LL).NE.' ') GOTO 1000
 
784
800         CONTINUE
 
785
            LL = 4
 
786
1000        CHTYP(11:) = CTYPE(LL:)
 
787
            IF (FLAG(1:1).NE.'S')
 
788
     +         CALL STDRDC(IMNO,DISCR,BYTELM,EL1,NOELEM,
 
789
     +                     IAV,CVALS,UNIT,NULLO,STAT)
 
790
         ELSE
 
791
            ITY = 3
 
792
            IF (FLAG(1:1).NE.'S')
 
793
     +         CALL STDRDC(IMNO,DISCR,1,EL1,NOELEM,
 
794
     +                     IAV,CVALS,UNIT,NULLO,STAT)
 
795
         ENDIF
 
796
C
 
797
C  get double prec. data
 
798
      ELSE IF (TYPE.EQ.'D') THEN
 
799
         ITY = 4
 
800
         IF (FLAG(1:1).NE.'S') 
 
801
     +      CALL STDRDD(IMNO,DISCR,EL1,NOELEM,
 
802
     +                  IAV,DVALS,UNIT,NULLO,STAT)
 
803
C
 
804
C  get size_t data (as I*4 or I*8)
 
805
      ELSE IF (TYPE.EQ.'S') THEN
 
806
         ITY = 7
 
807
         IF (FLAG(1:1).NE.'S') 
 
808
     +      CALL STDRDS(IMNO,DISCR,EL1,NOELEM,
 
809
     +                  IAV,SVALS,UNIT,NULLO,STAT)
 
810
C
 
811
C  get logical data
 
812
      ELSE IF (TYPE.EQ.'L') THEN
 
813
         ITY = 6
 
814
         IF (FLAG(1:1).NE.'S') 
 
815
     +      CALL STDRDL(IMNO,DISCR,EL1,NOELEM,
 
816
     +                  IAV,IVALS,UNIT,NULLO,STAT)
 
817
      ENDIF
 
818
C 
 
819
C  return, if problems with reading descriptors
 
820
      IF (STAT.NE.0) THEN
 
821
         WRITE(OUTPUT,10000) DISCR(1:DSCLEN)
 
822
         CALL STTPUT(OUTPUT,STAT)
 
823
         GOTO 8000
 
824
      ENDIF
 
825
C
 
826
C  fill header line
 
827
      IF (ITY.NE.5) THEN
 
828
         IJK(2) = ITY
 
829
         CCC = CC(ITY)
 
830
      ELSE
 
831
         IJK(2) = 3
 
832
         CCC = CHTYP
 
833
      ENDIF
 
834
C
 
835
C  display header line - except for display_flag = H or B
 
836
      IF (FLAG(2:2).EQ.'H') THEN
 
837
         IF (FLAG(1:1) .EQ. 'S') THEN 
 
838
            GOTO 8000                !nothing to do for SHOW/DESCR
 
839
         ELSE
 
840
            GOTO (5500,5600,5700,5800,5700,5900),ITY      !only display data
 
841
         ENDIF
 
842
C 
 
843
      ELSE IF (FLAG(2:2).NE.'B') THEN
 
844
         IF (DSCLEN .LE. 15) THEN
 
845
            WRITE(OUTPUT,10001) DISCR(1:15)        !help text begins at 15
 
846
         ELSE
 
847
            WRITE(OUTPUT,10001) DISCR(1:DSCLEN)
 
848
         ENDIF
 
849
         MM = INDEX(OUTPUT,'( ') + 1               !find end of text
 
850
         IF (MM .GT. 72) THEN
 
851
            OUTPUT(MM-1:) = '    '
 
852
            CALL STTPUT(OUTPUT,STAT)
 
853
            OUTPUT(1:) = '( '
 
854
            MM = 2
 
855
         ENDIF
 
856
         LL = 77 - MM                              !LL = 53 for short descr
 
857
C 
 
858
         CALL STDRDH(IMNO,DISCR,1,72,IAV,CBUF,HNC,STAT)
 
859
         IF (HNC.GT.0) THEN                     !Yes, there is help
 
860
            DO 1600, M=IAV,1,-1                 !get rid of trailing blanks
 
861
               IF (CBUF(M:M) .NE. ' ') THEN
 
862
                  IAV = M
 
863
                  GOTO 1660
 
864
               ENDIF
 
865
1600        CONTINUE
 
866
1660        IF (IAV.GT.LL) THEN
 
867
               OUTPUT(MM-1:) = '    '
 
868
               CALL STTPUT(OUTPUT,STAT)         !print name on one line
 
869
               OUTPUT(1:) = '( '                !help text on next line
 
870
               MM = 2
 
871
            ENDIF
 
872
            OUTPUT(MM:) = CBUF(1:IAV)//') '
 
873
         ELSE
 
874
            OUTPUT(MM:) = '...) '
 
875
         ENDIF
 
876
         DSCNO(2) = HNC                         !save size of help text
 
877
         CALL STTPUT(OUTPUT,STAT)
 
878
C 
 
879
         IF (FLAG(1:1).EQ.'S') THEN                !SHOW/DESCR
 
880
            WRITE(OUTPUT,10004) CCC,(XLONG+NOELEM)
 
881
            CALL STTPUT(OUTPUT,STAT)
 
882
            GOTO 8000
 
883
         ELSE                                      !READ/DESCR
 
884
            IF (NOELEM .GT. 99999) THEN
 
885
               WRITE(OUTPUT,10004) CCC,NOELEM
 
886
            ELSE
 
887
               WRITE(OUTPUT,10005) CCC,NOELEM
 
888
            ENDIF
 
889
            CALL STTPUT(OUTPUT,STAT)
 
890
C
 
891
            GOTO (5500,5600,5700,5800,5700,5900,6000),ITY
 
892
         ENDIF
 
893
      ELSE
 
894
C
 
895
C  short display
 
896
         IF ((TYPE.EQ.'C') .AND.
 
897
     +       (DISCR(1:6).EQ.'IDENT ')) THEN        !truncate IDENT
 
898
            MM = 0
 
899
            LL = MIN(NOELEM,72)
 
900
            DO 3000, M=LL,1,-1
 
901
               IF (CVALS(M:M).NE.' ') THEN
 
902
                  MM = M                           !mark last char.
 
903
                  GOTO 3050
 
904
               ENDIF
 
905
3000        CONTINUE
 
906
3050        IF (MM.EQ.0) THEN                      !only blanks
 
907
               NOELEM = 1
 
908
            ELSE
 
909
               NOELEM = MM
 
910
            ENDIF
 
911
         ENDIF
 
912
C
 
913
         DISCR(DSCLEN+1:) = ': '
 
914
         IF ( (DSCLEN .GT. 15) .OR.
 
915
     +        (NOELEM.GT.LIM(ITY)) .OR.
 
916
     +        (ITY.EQ.5) ) THEN
 
917
             CALL STTPUT(DISCR,STAT)
 
918
             GOTO (5500,5600,5700,5800,5700,5900,6000),ITY
 
919
         ELSE                                      !brief display
 
920
             GOTO (5550,5650,5790,5850,5790,5950,6050),ITY
 
921
         ENDIF
 
922
      ENDIF
 
923
C
 
924
C here the output of the descr. values
 
925
C 
 
926
5500  DO 5510, M=1,NOELEM,8
 
927
         MM = MIN(NOELEM,M+7)
 
928
         WRITE(OUTPUT,10002) (IVALS(L),L=M,MM)
 
929
         CALL STTPUT(OUTPUT,STAT)
 
930
5510  CONTINUE
 
931
      GOTO 7700
 
932
C
 
933
5550  WRITE(OUTPUT,10002) (IVALS(L),L=1,NOELEM)
 
934
      LL = NOELEM*10
 
935
      CBUF(1:) = DISCR(1:17)//OUTPUT(1:LL)//' '
 
936
      CALL STTPUT(CBUF,STAT)
 
937
      GOTO 7700
 
938
C
 
939
5600  DO 5610, M=1,NOELEM,5
 
940
         MM = MIN(NOELEM,M+4)
 
941
         WRITE(OUTPUT,20002) (RVALS(L),L=M,MM)
 
942
         CALL STTPUT(OUTPUT,STAT)
 
943
5610  CONTINUE
 
944
      GOTO 7700
 
945
C
 
946
5650  WRITE(OUTPUT,20002) (RVALS(L),L=1,NOELEM)
 
947
      LL = NOELEM*15
 
948
      CBUF(1:) = DISCR(1:17)//OUTPUT(1:LL)//' '
 
949
      CALL STTPUT(CBUF,STAT)
 
950
      GOTO 7700
 
951
C
 
952
C  character data has to be treated specially
 
953
5700  IF (BYTELM.GT.1) THEN
 
954
         LL = 1
 
955
         MM = BYTELM
 
956
         DO 5720, L=1,NOELEM
 
957
            DO 5710, IOFF=LL,MM,80
 
958
               M = IOFF + 79
 
959
               IF (M.GT.MM) M = MM
 
960
               OUTPUT(1:) = CVALS(IOFF:M)//' '
 
961
               CALL STTPUT(OUTPUT,STAT)
 
962
5710        CONTINUE
 
963
            LL = LL + BYTELM
 
964
            MM = MM + BYTELM
 
965
5720     CONTINUE
 
966
      ELSE
 
967
C 
 
968
         M = 1                            !chop up in pieces of 80 chars
 
969
5730     MM = M + 79
 
970
         IF (MM.GE.NOELEM) THEN
 
971
            KCASE = 0                     !indicate that we reached the end
 
972
            MM = NOELEM
 
973
         ELSE
 
974
            KCASE = 1
 
975
         ENDIF
 
976
C
 
977
         OUTPUT(1:) = CVALS(M:MM)//' '
 
978
5750     CALL STTPUT(OUTPUT,STAT)
 
979
5760     IF (KCASE.EQ.1) THEN
 
980
            M = MM + 1                     !move to after current end
 
981
            IF (M.LE.NOELEM) GOTO 5730
 
982
         ENDIF
 
983
      ENDIF
 
984
      GOTO 7700
 
985
C
 
986
5790  OUTPUT(1:) = DISCR(1:17)//CVALS(1:NOELEM)//' '
 
987
      CALL STTPUT(OUTPUT,STAT)
 
988
      GOTO 7700
 
989
C
 
990
5800  DO 5810, M=1,NOELEM,3
 
991
         MM = MIN(NOELEM,M+2)
 
992
         WRITE(OUTPUT,20003) (DVALS(L),L=M,MM)
 
993
         CALL STTPUT(OUTPUT,STAT)
 
994
5810  CONTINUE
 
995
      GOTO 7700
 
996
C
 
997
5850  WRITE(OUTPUT,20004) (DVALS(L),L=1,NOELEM)
 
998
      LL = NOELEM*24
 
999
      CBUF(1:) = DISCR(1:17)//OUTPUT(1:LL)//' '
 
1000
      CALL STTPUT(CBUF,STAT)
 
1001
      GOTO 7700
 
1002
C 
 
1003
5900  DO 5910, M=1,NOELEM,8
 
1004
         MM = MIN(NOELEM,M+7)
 
1005
         WRITE(OUTPUT,10002) (IVALS(L),L=M,MM)
 
1006
         CALL STTPUT(OUTPUT,STAT)
 
1007
5910  CONTINUE
 
1008
      GOTO 7700
 
1009
C
 
1010
5950  WRITE(OUTPUT,10002) (IVALS(L),L=1,NOELEM)
 
1011
      LL = NOELEM*10
 
1012
      CBUF(1:) = DISCR(1:17)//OUTPUT(1:LL)//' '
 
1013
      CALL STTPUT(CBUF,STAT)
 
1014
      GOTO 7700
 
1015
C
 
1016
6000  DO 6010, M=1,NOELEM,3
 
1017
         MM = MIN(NOELEM,M+2)
 
1018
         WRITE(OUTPUT,30003) (SVALS(L),L=M,MM)
 
1019
         CALL STTPUT(OUTPUT,STAT)
 
1020
6010  CONTINUE
 
1021
      GOTO 7700
 
1022
C
 
1023
6050  WRITE(OUTPUT,30004) (SVALS(L),L=1,NOELEM)
 
1024
      LL = NOELEM*12
 
1025
      CBUF(1:) = DISCR(1:17)//OUTPUT(1:LL)//' '
 
1026
      CALL STTPUT(CBUF,STAT)
 
1027
      GOTO 7700
 
1028
C 
 
1029
7700  IF (XLONG.GT.0) THEN
 
1030
         EL1 = EL1 + 65535
 
1031
         IF (XLONG.LE.65535) NOELEM = XLONG
 
1032
         XLONG = XLONG - 65535
 
1033
         DISCR(DSCLEN+1:) = '  '             !remove ':' again
 
1034
         GOTO 700
 
1035
      ENDIF
 
1036
C
 
1037
C  increment counter + loop if there are more descriptors
 
1038
C 
 
1039
8000  DISCR(1:) = ' '
 
1040
      IF (OPTIO.NE.0) THEN
 
1041
         CALL STDRDX(IMNO,10,DISCR,DSCTYP,BYTELM,NOELEM,HNC,STAT)
 
1042
         IF (DISCR(1:1).NE.' ') THEN
 
1043
            DSCNO(1) = DSCNO(1) + 1
 
1044
            GOTO 500
 
1045
         ENDIF
 
1046
      ENDIF
 
1047
C
 
1048
9000  IF (OPTIO.EQ.0) THEN                   !single descriptor
 
1049
         IF (IJK(1).EQ.1) THEN
 
1050
            IJK(3) = NOELEM
 
1051
            IJK(4) = BYTELM
 
1052
            IJK(5) = DSCNO(2)
 
1053
         ENDIF
 
1054
         CALL STKWRI('OUTPUTI',IJK,1,5,UNIT,STAT) 
 
1055
      ELSE   
 
1056
         IF (OPTIO.EQ.1) THEN                !all descr's
 
1057
            DSCNO(1) = DSCNO(1) - 1          !avoid descr. directory itself
 
1058
         ELSE 
 
1059
            DSCNO(1) = NPT
 
1060
         ENDIF
 
1061
         WRITE(OUTPUT,40000) DSCNO(1)
 
1062
         CALL STTPUT(OUTPUT,STAT)
 
1063
         CALL STKWRI('OUTPUTI',DSCNO,1,1,UNIT,STAT) 
 
1064
      ENDIF
 
1065
C
 
1066
C  That's it folks ...
 
1067
      RETURN
 
1068
C
 
1069
C  formats
 
1070
10000 FORMAT('Problems reading descriptor: ',A)
 
1071
10001 FORMAT('name: ',A,' ( ')
 
1072
10002 FORMAT(8I10)
 
1073
10004 FORMAT('type: ',A,'  no. of elements:',I8)
 
1074
10005 FORMAT('type: ',A,'  no. of elements:',I5)
 
1075
20002 FORMAT(5G15.7)
 
1076
20003 FORMAT(3G24.14)
 
1077
20004 FORMAT(2G24.14)
 
1078
30000 FORMAT(I4)
 
1079
30003 FORMAT(3I12)
 
1080
30004 FORMAT(2I12)
 
1081
33000 FORMAT('Descriptor directory: total length =',I8,
 
1082
     +       '   => no. of decriptors =',I6)   
 
1083
40000 FORMAT('total no. of descriptors:',I6)
 
1084
      END
 
1085
 
 
1086
      SUBROUTINE DTCHK(INTYP,OUTTYP,BYTELM,MAXNO)
 
1087
C
 
1088
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
1089
C
 
1090
C.IDENTIFICATION
 
1091
C  subroutine DTCHK                     version 1.50    841114
 
1092
C  K. Banse                             ESO - Garching
 
1093
C  1.60     860226      1.70    871027          1.80    900215
 
1094
C
 
1095
C.KEYWORDS
 
1096
C  keyword data base
 
1097
C
 
1098
C.PURPOSE
 
1099
C  check given data type + return cleaned type and no. of bytes per element
 
1100
C
 
1101
C.ALGORITHM
 
1102
C  straight forward
 
1103
C
 
1104
C.INPUT/OUTPUT
 
1105
C  call as DTCHK(INTYP,OUTTYP,BYTELM,MAXNO)
 
1106
C
 
1107
C  input par:
 
1108
C  INTYP:       char.exp.       type of keyword/descr
 
1109
C
 
1110
C  output par:
 
1111
C  OUTTYP:      char*1          type of keyword/descr
 
1112
C                               currently I,R,C,D,H, L are recognized for
 
1113
C                               I*4,R*4,CHAR*n,R*8 or Double or HELP
 
1114
C                               set to ' ', if invalid INTYP given
 
1115
C  BYTELM:      I*4             no. of bytes per element of keyword/descr data
 
1116
C  MAXNO:       I*4             max. no. of elements which can be written
 
1117
C                               (= size of internal buffer)
 
1118
C
 
1119
C.VERSIONS
 
1120
C  1.60         also allow LOGICAL*4 type - will be converted to I*4
 
1121
C  1.70         add output par. MAXNO
 
1122
C
 
1123
C----------------------------------------------------------------------------
 
1124
C
 
1125
      IMPLICIT NONE
 
1126
C
 
1127
      INTEGER      BYTELM
 
1128
      INTEGER      LL,MAXNO
 
1129
      INTEGER      LIMES(3)
 
1130
C 
 
1131
      REAL  RR
 
1132
C 
 
1133
      DOUBLE PRECISION  DD
 
1134
C
 
1135
      CHARACTER*(*)  INTYP
 
1136
      CHARACTER      OUTTYP*1,TEST*1
 
1137
C
 
1138
      DATA   LIMES /65535,65535,65535/
 
1139
C                                   
 
1140
      MAXNO = 0                        !default to no_success ...
 
1141
      OUTTYP = ' '
 
1142
      CALL UPCAS(INTYP(1:1),TEST)
 
1143
C
 
1144
C  first look for type CHAR*len
 
1145
      IF (TEST.EQ.'C') THEN
 
1146
         LL = INDEX(INTYP,'*')
 
1147
         IF (LL.LE.0) THEN
 
1148
            BYTELM = 1
 
1149
            OUTTYP = 'C'
 
1150
         ELSE
 
1151
            CALL GENCNV(INTYP(LL+1:),1,1,BYTELM,RR,DD,LL)
 
1152
            IF (LL.GT.0) OUTTYP = 'C'
 
1153
         ENDIF
 
1154
         MAXNO = LIMES(3) / BYTELM
 
1155
C
 
1156
C  then for integer, real + double precision
 
1157
      ELSE IF (TEST.EQ.'I') THEN
 
1158
         BYTELM = 4
 
1159
         OUTTYP = 'I'
 
1160
         MAXNO = LIMES(2)
 
1161
      ELSE IF (TEST.EQ.'R') THEN
 
1162
         IF (INDEX(INTYP,'*8').GT.0) THEN
 
1163
            BYTELM = 8
 
1164
            OUTTYP = 'D'
 
1165
            MAXNO = LIMES(1)
 
1166
         ELSE
 
1167
            BYTELM = 4
 
1168
            OUTTYP = 'R'
 
1169
            MAXNO = LIMES(2)
 
1170
         ENDIF
 
1171
      ELSE IF (TEST.EQ.'D') THEN
 
1172
         BYTELM = 8
 
1173
         OUTTYP = 'D'
 
1174
         MAXNO = LIMES(1)
 
1175
      ELSE IF (TEST.EQ.'H') THEN
 
1176
         BYTELM = 1
 
1177
         OUTTYP = 'H'
 
1178
         MAXNO = LIMES(2)
 
1179
      ELSE IF (TEST.EQ.'L') THEN
 
1180
         BYTELM = 4
 
1181
         OUTTYP = 'L'
 
1182
         MAXNO = LIMES(2)
 
1183
      ENDIF
 
1184
C
 
1185
C OUTTYP only set, if correct type was entered
 
1186
      RETURN
 
1187
      END
 
1188
 
 
1189
      SUBROUTINE PATTST(FLAG,STR,STAT)
 
1190
C
 
1191
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
1192
C
 
1193
C.IDENTIFICATION
 
1194
C  subroutine PATTST            version 1.0     980421
 
1195
C  K. Banse                     ESO - Garching
 
1196
C
 
1197
C.KEYWORDS
 
1198
C  pattern matching
 
1199
C
 
1200
C.PURPOSE
 
1201
C  check if descriptor name matches a given pattern
 
1202
C
 
1203
C.ALGORITHM
 
1204
C  straight forward
 
1205
C  support two patterns patternA, patternB
 
1206
C
 
1207
C.INPUT/OUTPUT
 
1208
C  call as  PATTST(FLAG,STR,STAT)
 
1209
C
 
1210
C  input par:
 
1211
C  FLAG:        I*4             flag = 1 (11), for saving patternA/B
 
1212
C                                    = 2 (12), for checking patternA/B
 
1213
C                               < 10 for patternA, > 10 for patternB
 
1214
C  STR:         char.exp.       pattern string (FLAG=1,11)
 
1215
C                               descr. name (FLAG=2,12)
 
1216
C
 
1217
C  output par:
 
1218
C  STAT:        I*4             = 1, if matching, else = 0
 
1219
C
 
1220
C.VERSIONS
 
1221
C  see SCCS
 
1222
C
 
1223
C----------------------------------------------------------------------------
 
1224
C
 
1225
      IMPLICIT NONE
 
1226
C
 
1227
      INTEGER    FLAG,STAT
 
1228
      INTEGER    N,M
 
1229
      INTEGER    IPT,IPTA,PATFLG
 
1230
      INTEGER    JPT,JPTA,QATFLG
 
1231
C 
 
1232
      CHARACTER*(*) STR
 
1233
      CHARACTER  PATTRN*80,PATTRA*80
 
1234
      CHARACTER  QATTRN*80,QATTRA*80
 
1235
C 
 
1236
      SAVE       PATTRN,PATTRA
 
1237
      SAVE       QATTRN,QATTRA
 
1238
      SAVE       PATFLG,IPT,IPTA
 
1239
      SAVE       QATFLG,JPT,JPTA
 
1240
 
 
1241
C 
 
1242
      STAT = 0
 
1243
      IF (FLAG.LT.10) THEN
 
1244
         IF (FLAG.EQ.1) THEN
 
1245
C 
 
1246
C extract pattern for patternA
 
1247
C 
 
1248
            M = INDEX(STR,' ') - 1              !real length
 
1249
            IF (M.LT.1) M = LEN(STR)
 
1250
C 
 
1251
            N = INDEX(STR,'*')
 
1252
            IF (N.EQ.1) THEN
 
1253
               IF (STR(M:M).EQ.'*') THEN  
 
1254
                  PATTRN(1:) = STR(2:M-1)//' '
 
1255
                  IPT = M - 2
 
1256
                  PATFLG = 4                    ! = 4, for checking *pattern*
 
1257
               ELSE
 
1258
                  PATTRN(1:) = STR(2:)//' '      
 
1259
                  IPT = INDEX(PATTRN,' ') - 1
 
1260
                  IF (IPT.LT.1) IPT = LEN(PATTRN)
 
1261
                  PATFLG = 1                    ! = 1, for checking *pattern
 
1262
               ENDIF
 
1263
            ELSE
 
1264
               IF ((M.EQ.N) .OR. (STR(N+1:N+1).EQ.' ')) THEN
 
1265
                  IPT = N - 1
 
1266
                  PATTRN(1:) = STR(1:IPT)//' '       
 
1267
                  PATFLG = 2                    ! = 2, for checking pattern*
 
1268
               ELSE
 
1269
                  PATTRN(1:) = STR(1:N-1)//' '
 
1270
                  IPT = INDEX(PATTRN,' ') - 1
 
1271
                  IF (IPT.LT.1) IPT = LEN(PATTRN)
 
1272
                  PATTRA(1:) = STR(N+1:)//' '
 
1273
                  IPTA = INDEX(PATTRA,' ') - 1
 
1274
                  IF (IPTA.LT.1) IPTA = LEN(PATTRA)
 
1275
                  PATFLG = 3                 ! = 3, for checking pattr1*pattr2
 
1276
               ENDIF
 
1277
            ENDIF
 
1278
C 
 
1279
C match patternA
 
1280
C 
 
1281
         ELSE
 
1282
            N = INDEX(STR,' ') - 1
 
1283
            IF (N.LT.1) N = LEN(STR)
 
1284
C 
 
1285
            IF (PATFLG.EQ.1) THEN                            !*pattern
 
1286
               IF (N.GE.IPT) THEN
 
1287
                  M = N - IPT + 1
 
1288
                  IF (STR(M:N).EQ.PATTRN(1:IPT)) STAT = 1
 
1289
               ENDIF
 
1290
            ELSE IF (PATFLG.EQ.2) THEN                       !pattern*
 
1291
               IF (STR(1:IPT).EQ.PATTRN(1:IPT)) STAT = 1
 
1292
            ELSE IF (PATFLG.EQ.3) THEN                       !pattr1*pattr2
 
1293
               IF (N.GE.(IPT+IPTA)) THEN
 
1294
                  M = N - IPTA + 1
 
1295
                  IF ((STR(1:IPT).EQ.PATTRN(1:IPT)) .AND.
 
1296
     +                (STR(M:N).EQ.PATTRA(1:IPTA))) STAT = 1
 
1297
               ENDIF
 
1298
            ELSE                                             !*pattern*
 
1299
               IF (INDEX(STR,PATTRN(1:IPT)).GT.0) STAT = 1
 
1300
            ENDIF
 
1301
         ENDIF
 
1302
C 
 
1303
      ELSE
 
1304
         IF (FLAG.EQ.11) THEN
 
1305
C
 
1306
C extract pattern for patternB
 
1307
C
 
1308
            M = INDEX(STR,' ') - 1              !real length
 
1309
            IF (M.LT.1) M = LEN(STR)
 
1310
C
 
1311
            N = INDEX(STR,'*')
 
1312
            IF (N.EQ.1) THEN
 
1313
               IF (STR(M:M).EQ.'*') THEN 
 
1314
                  QATTRN(1:) = STR(2:M-1)//' '
 
1315
                  JPT = M - 2
 
1316
                  QATFLG = 4                    ! = 4, for checking *pattern*
 
1317
               ELSE
 
1318
                  QATTRN(1:) = STR(2:)//' '
 
1319
                  JPT = INDEX(QATTRN,' ') - 1
 
1320
                  IF (JPT.LT.1) JPT = LEN(QATTRN)
 
1321
                  QATFLG = 1                    ! = 1, for checking *pattern
 
1322
               ENDIF
 
1323
            ELSE
 
1324
               IF ((M.EQ.N) .OR. (STR(N+1:N+1).EQ.' ')) THEN
 
1325
                  JPT = N - 1
 
1326
                  QATTRN(1:) = STR(1:JPT)//' '      
 
1327
                  QATFLG = 2                    ! = 2, for checking pattern*
 
1328
               ELSE
 
1329
                  QATTRN(1:) = STR(1:N-1)//' '
 
1330
                  JPT = INDEX(QATTRN,' ') - 1
 
1331
                  IF (JPT.LT.1) JPT = LEN(QATTRN)
 
1332
                  QATTRA(1:) = STR(N+1:)//' '
 
1333
                  JPTA = INDEX(QATTRA,' ') - 1
 
1334
                  IF (JPTA.LT.1) JPTA = LEN(QATTRA)
 
1335
                  QATFLG = 3                 ! = 3, for checking pattr1*pattr2
 
1336
               ENDIF
 
1337
            ENDIF
 
1338
C
 
1339
C match patternB
 
1340
C
 
1341
         ELSE
 
1342
            N = INDEX(STR,' ') - 1
 
1343
            IF (N.LT.1) N = LEN(STR)
 
1344
C
 
1345
            IF (QATFLG.EQ.1) THEN                            !*pattern
 
1346
               IF (N.GE.JPT) THEN
 
1347
                  M = N - JPT + 1
 
1348
                  IF (STR(M:N).EQ.QATTRN(1:JPT)) STAT = 1
 
1349
               ENDIF
 
1350
            ELSE IF (QATFLG.EQ.2) THEN                       !pattern*
 
1351
               IF (STR(1:JPT).EQ.QATTRN(1:JPT)) STAT = 1
 
1352
            ELSE IF (QATFLG.EQ.3) THEN                       !pattr1*pattr2
 
1353
               IF (N.GE.(JPT+JPTA)) THEN
 
1354
                  M = N - JPTA + 1
 
1355
                  IF ((STR(1:JPT).EQ.QATTRN(1:JPT)) .AND.
 
1356
     +                (STR(M:N).EQ.QATTRA(1:JPTA))) STAT = 1
 
1357
               ENDIF
 
1358
            ELSE                                             !*pattern*
 
1359
               IF (INDEX(STR,QATTRN(1:JPT)).GT.0) STAT = 1
 
1360
            ENDIF
 
1361
         ENDIF
 
1362
      ENDIF
 
1363
C 
 
1364
      RETURN
 
1365
      END
 
1366
 
 
1367
      SUBROUTINE DSCDEL(IMNO,INDSC,DELCNT)
 
1368
C
 
1369
C+++++++++++++++++++++++++++++++++++++++++++++++++
 
1370
C
 
1371
C.IDENTIFICATION
 
1372
C  subroutine DSCDEL                    990114
 
1373
C  K. Banse                             ESO - Garching
 
1374
C
 
1375
C.KEYWORDS
 
1376
C  descriptors
 
1377
C
 
1378
C.PURPOSE
 
1379
C  delete descriptors matching a pattern
 
1380
C
 
1381
C.ALGORITHM
 
1382
C  read all existing descriptors + delete if pattern match
 
1383
C
 
1384
C.INPUT/OUTPUT
 
1385
C  call as DSCDEL(IMNO,INDSC,DELCNT)
 
1386
C
 
1387
C input:
 
1388
C  IMNO:      I*4         frame no. of data frame
 
1389
C  INDSC:     char.exp.   pattern of descriptors to be deleted
 
1390
C output:
 
1391
C  DELCNT:    I*4         no. of deleted descriptors
 
1392
C
 
1393
C-------------------------------------------------
 
1394
C
 
1395
      IMPLICIT NONE
 
1396
C
 
1397
      INTEGER      IMNO,DELCNT,HNC
 
1398
      INTEGER      STAT,NOELEM,BYTELM
 
1399
C 
 
1400
      CHARACTER*(*)  INDSC
 
1401
      CHARACTER      DISCR*80,DSCTYP*24
 
1402
C 
 
1403
      DISCR(1:) = ' '
 
1404
      CALL UPCAS(INDSC,DISCR)
 
1405
      CALL PATTST(1,DISCR,STAT)                !store the pattern(s)
 
1406
      DELCNT = 0
 
1407
C
 
1408
      CALL STDRDX(IMNO,1,DISCR,DSCTYP,BYTELM,NOELEM,HNC,STAT)
 
1409
      CALL STDRDX(IMNO,10,DISCR,DSCTYP,BYTELM,NOELEM,HNC,STAT)   !skip dscdir
 
1410
C
 
1411
C  loop through descr. list
 
1412
500   DISCR(1:) = ' '
 
1413
      CALL STDRDX(IMNO,10,DISCR,DSCTYP,BYTELM,NOELEM,HNC,STAT)
 
1414
      IF (DISCR(1:1).EQ.' ') RETURN
 
1415
C
 
1416
C  increment counter + loop if there are more descriptors
 
1417
      CALL PATTST(2,DISCR,STAT)
 
1418
      IF (STAT.NE.0) THEN    
 
1419
         DELCNT = DELCNT + 1                   !matching descr. found
 
1420
         CALL STDDEL(IMNO,DISCR,STAT)
 
1421
      ENDIF
 
1422
      GOTO 500                                 !look for more
 
1423
C
 
1424
      END
 
1425