← Back to branch summary

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

« back to all changes in this revision

Viewing changes to prim/general/libsrc/crthmz.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/libsrc/crthmz.for
 
1
C @(#)crthmz.for        19.2 (ESO-DMD) 05/20/03 09:41:53
 
2
C===========================================================================
 
3
C Copyright (C) 1995 European Southern Observatory (ESO)
 
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
      SUBROUTINE 
 
30
     +COMPUY(RESFMT,EXPRSS,ATOM,APNTRS,UPDA,FRAMEC,CUTS)
 
31
C
 
32
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
33
C
 
34
C.IDENTIFICATION
 
35
C  subroutine COMPUY         version 4.50      880920
 
36
C  K. Banse                  ESO - Garching
 
37
C                                    4.60      890426
 
38
C
 
39
C.KEYWORDS
 
40
C  arithmetic operations, bulk data frames
 
41
C
 
42
C.PURPOSE
 
43
C  evaluate an arithmetic expression involving frames, constants and functions
 
44
C  and store the result into a data frame or key OUTPUTR(1), if used as pocket calculator
 
45
C
 
46
C.ALGORITHM
 
47
C  "clean" the expression by replacing all frame names by F, all constants by C
 
48
C  and all functions by P, convert it to polish (postfix) notation and evaluate it piecewise
 
49
C  intermediate results are stored in OUTPUTR(1) or frame midtempn.bdf
 
50
C  establish special condition handler for arithmetic traps...
 
51
C  copy all descriptors of first frame operand to result frame.
 
52
C
 
53
C.INPUT/OUTPUT
 
54
C      
 
55
C  call as  COMPUY(RESFMT,EXPRSS,ATOM,APNTRS,UPDA,FRAMEC,CUTS)
 
56
C 
 
57
C  input par:
 
58
C  RESFMT:      I*4           data format for result frame 
 
59
C  EXPRSS:      char.exp.     arithmetic expression in polish postfix notation
 
60
C  ATOM:        char. array   holds the operands
 
61
C  APNTRS:      I*4 array     holds the pointers to ATOM
 
62
C  FRAMEC:      char. exp.    name of result frame
 
63
C  UPDA:        I*4           if = 1, result frame is just modified,
 
64
C                             else a new result frame is created
 
65
C      
 
66
C  output par:
 
67
C  CUTS:        R*8 array     min, max of result frame
 
68
C
 
69
C 030516        last modif
 
70
C      
 
71
C-------------------------------------------------------------------------
 
72
C
 
73
      IMPLICIT NONE
 
74
C
 
75
      CHARACTER*(*)    EXPRSS,ATOM(*),FRAMEC
 
76
      CHARACTER*80     FRAMEA,FRAMEB,FRAME
 
77
      CHARACTER*1      DUM(24)
 
78
      CHARACTER        CUNITA*64,CUNITB*64,IDENTA*72,IDENTB*72
 
79
      CHARACTER*60     OPERA,OPERB,OPERC
 
80
      CHARACTER        WORK(2)*50
 
81
      CHARACTER        OPERAT*4,LINE*80,DUMMY*20
 
82
      CHARACTER        ERROR1*40,ERROR2*30,ERROR4*30
 
83
C      
 
84
      DOUBLE PRECISION STEPA(3),STEPB(3),STEPC(3)
 
85
      DOUBLE PRECISION STARTA(3),STARTB(3),STARTC(3)
 
86
      DOUBLE PRECISION BEGIN(3),END(3),DIF,DDUM(1)
 
87
      DOUBLE PRECISION CNSTAB(2),CONST,EPS1,CUTS(2)
 
88
C 
 
89
      REAL         RDUM(1),USRNUL
 
90
C      
 
91
      INTEGER      NULCNT,NNN
 
92
      INTEGER      RESFMT,APNTRS(*),UPDA,IMNOC
 
93
      INTEGER      APIX(3,2),BPIX(3,2),CPIX(3,2)
 
94
      INTEGER      NPIXA(3),NPIXB(3),NPIXC(3)
 
95
      INTEGER      IDUM(1),IDUMMY,LL
 
96
      INTEGER      MAXDIM,N,NAXISA,NAXISB,NAXISC
 
97
      INTEGER      NBRA,P1,P2,P3
 
98
      INTEGER*8    PNTRA,PNTRB,PNTRC
 
99
      INTEGER      PP,SIZE,STAT
 
100
      INTEGER      IMNOA,IMNOB
 
101
      INTEGER      UNI(1),NULO,MADRID(1)
 
102
      INTEGER      APIXDF,BPIXDF,CPIXDF,KK
 
103
C 
 
104
      INCLUDE  'MID_INCLUDE:ST_DEF.INC'
 
105
C 
 
106
      COMMON      /NULCOM/ NULCNT,USRNUL
 
107
      COMMON      /VMR/ MADRID
 
108
C      
 
109
      DATA      
 
110
     +ERROR1 /'Operands do not match in stepsize... '/
 
111
      DATA      ERROR2      /'Operands do not overlap...'/
 
112
      DATA      ERROR4      /'Too many operands...'/
 
113
c 
 
114
      DATA      APIX /6*1/, BPIX /6*1/, CPIX /6*1/
 
115
      DATA      DUM  /'a','b','c','d','e','f','g','h','i','j',
 
116
     +                'k','l','m','n','o','p','q','r','s','t',
 
117
     +                'u','v','w','x'/
 
118
      DATA      IDENTA /' '/,  CUNITA /' '/
 
119
      DATA      IDENTB /' '/,  CUNITB /' '/
 
120
      DATA      NPIXA  /3*1/,    NPIXB /3*1/,     NPIXC /3*1/
 
121
      DATA      STARTA /3*0.D0/, STARTB /3*0.D0/, STARTC /3*0.D0/
 
122
      DATA      STEPA  /3*1.D0/, STEPB  /3*1.D0/, STEPC  /3*1.D0/
 
123
      DATA      DUMMY  /'midtemp   .bdf '/
 
124
C 
 
125
      INCLUDE  'MID_INCLUDE:ST_DAT.INC'
 
126
C      
 
127
C  initialize
 
128
      IDUMMY = 0
 
129
      WORK(1) = EXPRSS
 
130
      CALL STKRDC('MID$SESS',1,11,2,LL,DUMMY(8:),UNI,NULO,STAT)
 
131
C      
 
132
C  extract basic operations
 
133
1000  CALL EXPRDC(WORK(1),WORK(2),OPERAT,PP)
 
134
C      
 
135
C  extract operands
 
136
      P1 = APNTRS(PP)
 
137
      P2 = APNTRS(PP+1)
 
138
      OPERA = ATOM(P1)
 
139
      OPERB = ATOM(P2)
 
140
      IF (OPERAT(1:1).EQ.'Q') THEN                  !treat 2-arg functions...
 
141
         P3 = APNTRS(PP+2)
 
142
         OPERC = ATOM(P3)
 
143
      ENDIF
 
144
C      
 
145
C  find out what kind of OPERA to do
 
146
      IF (INDEX(OPERAT,'C').GT.0) THEN
 
147
         N = INDEX(OPERAT,'F')                  !also F involved...?
 
148
         IF (N.GT.0) GOTO 1600                  !yes. 
 
149
      ELSE
 
150
         IF (OPERAT(1:1).EQ.'P') THEN
 
151
            GOTO 1600                              !handle PF)
 
152
         ELSE
 
153
            GOTO 2000                              !handle FF or QFF)
 
154
         ENDIF
 
155
      ENDIF
 
156
C      
 
157
C  ***
 
158
C  only constants involved, do it right now
 
159
C  ***
 
160
C      
 
161
      IF (OPERAT(1:2).EQ.'CC') THEN
 
162
         LL = INDEX(OPERA,' ') - 1
 
163
         IF (LL.LE.0) LL = 60
 
164
         LINE(1:) = OPERA(1:LL)//','//OPERB
 
165
         CALL GENCNV(LINE(1:61),4,2,IDUM,RDUM,CNSTAB,LL)
 
166
         IF (LL.LE.1) GOTO 9990                              !we need 2 values...
 
167
         CALL DOPCC(OPERAT,CNSTAB(1),CNSTAB(2),CONST)
 
168
      ELSE
 
169
         IF (OPERAT(1:1).EQ.'P') THEN                  !1-arg functions
 
170
            CALL GENCNV(OPERB,4,1,IDUM,RDUM,CNSTAB,LL)
 
171
            IF (LL.LE.0) GOTO 9990
 
172
            CALL DF1C(OPERA(1:5),CNSTAB,CONST)
 
173
         ELSE                                          !2-arg functions
 
174
            LINE(1:41) = OPERB//','//OPERC
 
175
            CALL GENCNV(LINE(1:61),4,2,IDUM,RDUM,CNSTAB,LL)
 
176
            IF (LL.LE.0) GOTO 9990
 
177
            CALL DF2CC(OPERA(1:5),CNSTAB,CONST)
 
178
         ENDIF
 
179
      ENDIF
 
180
C
 
181
C  put resulting constant back into relevant ATOM + goto loopend
 
182
      IF (WORK(2)(2:2).NE.' ') THEN
 
183
         WRITE(ATOM(P1),10000) CONST
 
184
         GOTO 5000
 
185
      ELSE
 
186
         GOTO 9000
 
187
      ENDIF
 
188
C
 
189
C  ***
 
190
C  one operand is a file
 
191
C  ***
 
192
C      
 
193
1600  IF (OPERAT(1:2).EQ.'FC') THEN
 
194
         FRAME = OPERA
 
195
         LINE(1:20) = OPERB
 
196
         NBRA = 1                                    !no function
 
197
         GOTO 1700
 
198
      ENDIF
 
199
C 
 
200
      IF (OPERAT(1:2).EQ.'CF') THEN
 
201
         FRAME = OPERB
 
202
         LINE(1:20) = OPERA
 
203
         NBRA = 1                                    !no function
 
204
         GOTO 1700
 
205
      ENDIF
 
206
C 
 
207
      IF (OPERAT(1:2).EQ.'PF') THEN
 
208
         FRAME = OPERB
 
209
         NBRA = 2                                    !1-arg function
 
210
         GOTO 1800
 
211
      ENDIF
 
212
      NBRA = 3                                    !2-arg function
 
213
C 
 
214
      IF (OPERAT(1:2).NE.'QC') THEN
 
215
         FRAME = OPERB
 
216
         LINE(1:20) = OPERC
 
217
      ELSE
 
218
         FRAME = OPERC
 
219
         LINE(1:20) = OPERB
 
220
      ENDIF
 
221
C      
 
222
1700  CALL GENCNV(LINE(1:20),4,1,IDUM,RDUM,DDUM,LL)
 
223
      CONST = DDUM(1)
 
224
      IF (LL.LE.0) GOTO 9990                     !problems with conversion...
 
225
C      
 
226
1800  CALL CLNFRA(FRAME,FRAMEA,0)                !take care of & and # ...
 
227
C      
 
228
C  now map the result frame
 
229
      IF ( (WORK(2)(2:2).EQ.' ') .AND.
 
230
     +     (FRAMEA.EQ.FRAMEC) ) THEN
 
231
         CALL STIGET(FRAMEA,RESFMT,F_IO_MODE,F_IMA_TYPE,
 
232
     +               3,NAXISC,NPIXC,STARTC,STEPC,IDENTA,
 
233
     +               CUNITA,PNTRA,IMNOA,STAT)
 
234
         SIZE = 1
 
235
C 
 
236
         DO 1805, N=1,NAXISC
 
237
            SIZE = SIZE * NPIXC(N)
 
238
1805     CONTINUE
 
239
         PNTRC = PNTRA
 
240
         IMNOC = IMNOA
 
241
      ELSE
 
242
C      
 
243
C  result frame different from input frames
 
244
         CALL STIGET(FRAMEA,RESFMT,F_I_MODE,F_IMA_TYPE,
 
245
     +               3,NAXISA,NPIXA,STARTA,STEPA,IDENTA,
 
246
     +               CUNITA,PNTRA,IMNOA,STAT)
 
247
         NAXISC = NAXISA
 
248
         SIZE = 1
 
249
C 
 
250
         DO 1810, N=1,NAXISA
 
251
            SIZE = SIZE * NPIXA(N)
 
252
            NPIXC(N) = NPIXA(N)
 
253
            STARTC(N) = STARTA(N)
 
254
            STEPC(N) = STEPA(N)
 
255
1810     CONTINUE
 
256
C      
 
257
C  last operation ?
 
258
         IF (WORK(2)(2:2).EQ.' ') THEN
 
259
            IF (UPDA.EQ.1) THEN         
 
260
               CALL STIGET(FRAMEC,RESFMT,F_IO_MODE,F_IMA_TYPE,
 
261
     +                     3,NAXISC,NPIXC,STARTC,STEPC,IDENTA,
 
262
     +                     CUNITA,PNTRC,IMNOC,STAT)
 
263
C                                            we have to recalculate SIZE
 
264
               SIZE = 1                       
 
265
               DO 1815, N=1,NAXISC
 
266
                  SIZE = SIZE * NPIXC(N)
 
267
1815           CONTINUE
 
268
            ELSE
 
269
               CALL STIPUT(FRAMEC,RESFMT,F_O_MODE,F_IMA_TYPE,
 
270
     +                     NAXISC,NPIXC,STARTC,STEPC,IDENTA,
 
271
     +                     CUNITA,PNTRC,IMNOC,STAT)
 
272
            ENDIF
 
273
         ELSE                                      !use dummy result frame
 
274
C       
 
275
C  no. loop more
 
276
            IDUMMY = IDUMMY + 1                    !increment dummy file counter
 
277
            IF (IDUMMY.GT.24) THEN                 !check operand count
 
278
               CALL STETER(3,ERROR4)
 
279
            ELSE
 
280
               DUMMY(10:10) = DUM(IDUMMY)
 
281
            ENDIF
 
282
            CALL STIPUT(DUMMY,RESFMT,F_O_MODE,F_IMA_TYPE,
 
283
     +                  NAXISC,NPIXC,STARTC,STEPC,IDENTA,
 
284
     +                  CUNITA,PNTRC,IMNOC,STAT)
 
285
         ENDIF
 
286
      ENDIF
 
287
C
 
288
C  now do the actual operation
 
289
      GOTO (1850,1860,1870),NBRA                       
 
290
C 
 
291
1850  CALL DOPFC(OPERAT,MADRID(PNTRA),CONST,MADRID(PNTRC),SIZE,
 
292
     +           USRNUL,NNN)
 
293
      GOTO 1900
 
294
C 
 
295
1860  CALL DFN1F(OPERA(1:5),MADRID(PNTRA),MADRID(PNTRC),SIZE,
 
296
     +           USRNUL,NNN)
 
297
      GOTO 1900
 
298
C 
 
299
1870  CALL DFN2FC(OPERA(1:5),MADRID(PNTRA),CONST,MADRID(PNTRC),SIZE,
 
300
     +           USRNUL,NNN)
 
301
C      
 
302
1900  NULCNT = NULCNT + NNN                 !update null count
 
303
      IF (WORK(2)(2:2).NE.' ') THEN
 
304
         CALL STFCLO(IMNOA,STAT) 
 
305
         GOTO 4400                           
 
306
      ELSE
 
307
         GOTO 9000                           
 
308
      ENDIF
 
309
C
 
310
C  ***
 
311
C  both operands are files 
 
312
C  ***
 
313
C      
 
314
2000  IF (OPERAT(1:1).NE.'Q') THEN
 
315
         CALL CLNFRA(OPERA,FRAMEA,0)
 
316
         CALL CLNFRA(OPERB,FRAMEB,0)
 
317
      ELSE
 
318
         CALL CLNFRA(OPERB,FRAMEA,0)
 
319
         CALL CLNFRA(OPERC,FRAMEB,0)
 
320
      ENDIF
 
321
C      
 
322
C  get first input frame
 
323
      IF ( (WORK(2)(2:2).EQ.' ') .AND.
 
324
     +     (FRAMEA.EQ.FRAMEC) ) THEN
 
325
         CALL STIGET(FRAMEA,RESFMT,F_IO_MODE,F_IMA_TYPE,
 
326
     +               3,NAXISC,NPIXC,STARTC,STEPC,IDENTA,
 
327
     +               CUNITA,PNTRA,IMNOA,STAT)      !map input/result frame
 
328
         NAXISA = NAXISC
 
329
         SIZE = 1
 
330
C 
 
331
         DO 2050, N=1,NAXISC
 
332
            SIZE = SIZE * NPIXC(N)
 
333
            NPIXA(N) = NPIXC(N)
 
334
            STARTA(N) = STARTC(N)
 
335
            STEPA(N) = STEPC(N)
 
336
2050     CONTINUE
 
337
         PNTRC = PNTRA
 
338
         IMNOC = IMNOA
 
339
      ELSE
 
340
         CALL STIGET(FRAMEA,RESFMT,F_I_MODE,F_IMA_TYPE,
 
341
     +               3,NAXISA,NPIXA,STARTA,STEPA,IDENTA,
 
342
     +               CUNITA,PNTRA,IMNOA,STAT)
 
343
      ENDIF
 
344
C      
 
345
C  handle 2. input frame
 
346
      IF (FRAMEA.EQ.FRAMEB) THEN                        !check, if both operands are the same
 
347
         PNTRB = PNTRA
 
348
         IMNOB = IMNOA
 
349
         DO 2100, N=1,NAXISA
 
350
            NPIXB(N) = NPIXA(N)
 
351
            STARTB(N) = STARTA(N)
 
352
            STEPB(N) = STEPA(N)
 
353
2100     CONTINUE
 
354
         NAXISB = NAXISA
 
355
      ELSE
 
356
         CALL STIGET(FRAMEB,RESFMT,F_I_MODE,F_IMA_TYPE,
 
357
     +               3,NAXISB,NPIXB,STARTB,STEPB,IDENTB,
 
358
     +               CUNITB,PNTRB,IMNOB,STAT)
 
359
      ENDIF
 
360
C
 
361
C  see, if stepsizes and origins fit + frames overlap 
 
362
      IF (NAXISB.GT.NAXISA) THEN
 
363
         MAXDIM = NAXISB                        !take maximum
 
364
      ELSE
 
365
         MAXDIM = NAXISA
 
366
      ENDIF
 
367
C 
 
368
      DO 2150, N=1,MAXDIM
 
369
         EPS1 = 0.0001 * ABS(STEPA(N))       !take 0.01% of stepsize as epsilon
 
370
         IF (ABS(STEPA(N)-STEPB(N)).GT.EPS1) 
 
371
     +      CALL STETER(1,ERROR1)
 
372
         CALL OVRLAP(STARTA(N),STEPA(N),NPIXA(N),STARTB(N),
 
373
     +               STEPB(N),NPIXB(N),BEGIN(N),END(N),STAT)
 
374
         IF (STAT.NE.0) CALL STETER(3,ERROR2)        !if STAT = 1, no overlap...
 
375
2150  CONTINUE
 
376
C 
 
377
C  create new result frame with dimension = intersection of input frames
 
378
      IF ( (WORK(2)(2:2).EQ.' ') .AND.
 
379
     +     (FRAMEA.EQ.FRAMEC) ) GOTO 3000            !we already have the result frame
 
380
C      
 
381
      IF (NAXISA.GT.NAXISB) THEN
 
382
         NAXISC = NAXISB
 
383
      ELSE
 
384
         NAXISC = NAXISA
 
385
      ENDIF
 
386
C 
 
387
      SIZE = 1
 
388
      DO 2200, N=1,NAXISC
 
389
         STARTC(N) = BEGIN(N)
 
390
         STEPC(N) = STEPA(N)
 
391
         NPIXC(N) = NINT( (END(N)-BEGIN(N)) / STEPC(N) ) + 1
 
392
         SIZE = SIZE * NPIXC(N)
 
393
2200  CONTINUE
 
394
C      
 
395
C  now map the resulting frame
 
396
      IF (WORK(2)(2:2).EQ.' ') THEN                !use real result frame
 
397
         IF (UPDA.EQ.1) THEN                      !test, if update or new file
 
398
            CALL STIGET(FRAMEC,RESFMT,F_IO_MODE,F_IMA_TYPE,
 
399
     +                  3,NAXISC,NPIXC,STARTC,STEPC,IDENTA,
 
400
     +                  CUNITA,PNTRC,IMNOC,STAT)
 
401
            SIZE = 1                              !we have to recalculate SIZE
 
402
            DO 2250, N=1,NAXISC
 
403
               SIZE = SIZE * NPIXC(N)
 
404
2250        CONTINUE
 
405
         ELSE
 
406
            CALL STIPUT(FRAMEC,RESFMT,F_O_MODE,F_IMA_TYPE,
 
407
     +                  NAXISC,NPIXC,STARTC,STEPC,IDENTA,
 
408
     +                  CUNITA,PNTRC,IMNOC,STAT)
 
409
         ENDIF
 
410
C      
 
411
      ELSE                                         !use dummy result frame
 
412
         IDUMMY = IDUMMY + 1                       !increment dummy file counter
 
413
         IF (IDUMMY.GT.24) THEN                    !check operand count
 
414
            CALL STETER(2,ERROR4)
 
415
         ELSE
 
416
            DUMMY(10:10) = DUM(IDUMMY)
 
417
         ENDIF
 
418
         CALL STIPUT(DUMMY,RESFMT,F_O_MODE,F_IMA_TYPE,
 
419
     +               NAXISC,NPIXC,STARTC,STEPC,IDENTA,
 
420
     +               CUNITA,PNTRC,IMNOC,STAT)
 
421
      ENDIF
 
422
C 
 
423
C  convert start + end of overlap region into pixel no.'s
 
424
3000  DO 3100, N=1,MAXDIM
 
425
         DIF = (BEGIN(N)-STARTA(N))/STEPA(N)
 
426
         APIX(N,1) = NINT(DIF) + 1
 
427
         DIF = (END(N)-STARTA(N))/STEPA(N)
 
428
         APIX(N,2) = NINT(DIF) + 1
 
429
         APIXDF = APIX(N,2)-APIX(N,1)
 
430
         DIF = (BEGIN(N)-STARTB(N))/STEPB(N)
 
431
         BPIX(N,1) = NINT(DIF) + 1
 
432
         DIF = (END(N)-STARTB(N))/STEPB(N)
 
433
         BPIX(N,2) = NINT(DIF) + 1
 
434
         BPIXDF = BPIX(N,2)-BPIX(N,1)
 
435
         DIF = (BEGIN(N)-STARTC(N))/STEPC(N)
 
436
         CPIX(N,1) = NINT(DIF) + 1
 
437
         DIF = (END(N)-STARTC(N))/STEPC(N)
 
438
         CPIX(N,2) = NINT(DIF) + 1
 
439
         CPIXDF = CPIX(N,2)-CPIX(N,1)
 
440
         KK = MIN(APIXDF,BPIXDF,CPIXDF)            !take smallest size
 
441
         APIX(N,2) = APIX(N,1) + KK
 
442
         BPIX(N,2) = BPIX(N,1) + KK
 
443
         CPIX(N,2) = CPIX(N,1) + KK
 
444
3100  CONTINUE
 
445
C 
 
446
C  now do the actual operation
 
447
      IF (OPERAT(1:1).NE.'Q') THEN
 
448
         CALL DOPFW(OPERAT,MADRID(PNTRA),MADRID(PNTRB),
 
449
     +          MADRID(PNTRC),APIX,BPIX,CPIX,NPIXA,NPIXB,NPIXC)
 
450
      ELSE
 
451
         CALL DF2FFW(OPERA(1:5),MADRID(PNTRA),MADRID(PNTRB),
 
452
     +          MADRID(PNTRC),APIX,BPIX,CPIX,NPIXA,NPIXB,NPIXC)
 
453
      ENDIF
 
454
      IF (WORK(2)(2:2).EQ.' ') GOTO 9000
 
455
C      
 
456
      CALL STFCLO(IMNOA,STAT)      !release input frames
 
457
      CALL STFCLO(IMNOB,STAT) 
 
458
C
 
459
C  put resulting frame back into relevant ATOM, if we are not finished yet
 
460
4400  ATOM(P1) = DUMMY
 
461
      CALL STFCLO(IMNOC,STAT)      !release dummy result frame
 
462
C      
 
463
C  loopend for all basic operations
 
464
5000  IF (OPERAT(1:1).NE.'Q') THEN
 
465
         NBRA = 2
 
466
      ELSE
 
467
         NBRA = 3
 
468
      ENDIF
 
469
C 
 
470
      DO 5050, N=PP+1,45                        !update pointers for ATOM
 
471
         APNTRS(N) = APNTRS(N+NBRA)
 
472
5050  CONTINUE
 
473
C 
 
474
      WORK(1) = WORK(2)
 
475
      GOTO 1000                        !get next operation
 
476
C  
 
477
C  ***
 
478
C  we're done. test, if result goes to frame or constant
 
479
C  ***
 
480
C      
 
481
C  calculate new dynamic range of result frame
 
482
9000  CALL DMYMX(MADRID(PNTRC),SIZE,CUTS)
 
483
      CALL STFCLO(IMNOC,STAT)                 !make sure result frame is closed
 
484
C      
 
485
C  delete any dummy frames
 
486
      IF (IDUMMY.GT.0) THEN
 
487
         DO 9100, N=1,IDUMMY
 
488
            DUMMY(10:10) = DUM(N)
 
489
            CALL STFDEL(DUMMY,STAT)
 
490
9100     CONTINUE
 
491
      ENDIF
 
492
C      
 
493
C  That's it folks
 
494
      RETURN
 
495
C      
 
496
C  error with conversion of ASCII to number
 
497
9990  CALL STETER(10,'conversion error of ASCII -> number ...')
 
498
C
 
499
C  formats...
 
500
10000 FORMAT(G15.7)
 
501
      END