C @(#)rarthm.for	13.1.1.2 (ESO-DMD) 02/12/99 19:14:50
C===========================================================================
C Copyright (C) 1995 European Southern Observatory (ESO)
C
C This program is free software; you can redistribute it and/or 
C modify it under the terms of the GNU General Public License as 
C published by the Free Software Foundation; either version 2 of 
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public 
C License along with this program; if not, write to the Free 
C Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
C MA 02139, USA.
C
C Correspondence concerning ESO-MIDAS should be addressed as follows:
C	Internet e-mail: midas@eso.org
C	Postal address: European Southern Observatory
C			Data Management Division 
C			Karl-Schwarzschild-Strasse 2
C			D 85748 Garching bei Muenchen 
C			GERMANY
C===========================================================================
C
      PROGRAM RARTHM
C
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  program    RARTHM				version 1.00	881028
C  K. Banse                  			ESO - Garching
C  1.10		891013		1.70		941206
C
C.KEYWORDS
C  arithmetic operations, rows, columns
C
C.PURPOSE
C  evaluate an arithmetic expression involving rows (columns) of a frame,
C  constants and functions
C  and store the result into a row (column) of same data frame
C
C.ALGORITHM
C  "clean" the expression by replacing all rows by F, all constants by C
C  and all functions by P and Q, convert it to polish (postfix) notation
C  and evaluate it piecewise;
C  intermediate results are stored in OUTPUTR(1) or rows (columns) of
C  temporary frame
C  establish special condition handler for arithmetic traps...
C
C.INPUT/OUTPUT
C  the following keywords are used:
C
C  P1/C/1/80			holds input/result frame + row (column
C				e.g IMAGE.R210 (IMAGE.C12)
C  INPLINE/C/1/160		arithmetic expression,
C				may contain up to 15 operands
C  DEFAULT/C/16/1		R or C, for work on rows or columns
C
C.VERSIONS
C  1.10		created from version 2.25 as of 870601
C  		use FORTRAN 77 + new ST interfaces
C  1.70		support also rows/columns from different frames
C
C--------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER      N,NN,LL,NAXIS
      INTEGER      NULCNT,TSTFLG,COUNT
      INTEGER      IAV,STAT,NSIZE(2),RESROW
      INTEGER*8    PNTRC,PNTRW,PNTRD,PNTR1,PNTR2,ZPNTRA,ZPNTRB
      INTEGER*8    APNTR,BPNTR,RESP,XPNTR,QPNTR(24)
      INTEGER      QIMNO(24)
      INTEGER      IMNOA,IMNOB,IMNOC,OFF
      INTEGER      PP,P1,P2,P3,LOPA,LOPB,LOPC
      INTEGER      IDUM,IDUMMY,K,NBRA
      INTEGER      ROWNOA,ROWNOB
      INTEGER      NPIXW(2),NPIXC(2),NPIXA(2),NPIXB(2)
      INTEGER      LATOM(23),APNTRS(48)                !cf. ARTHMZ subroutine
      INTEGER      APIX(3,2),BPIX(3,2),CPIX(3,2)
      INTEGER      ROWSIZ,ROWLIM,IX,IFA,IFB
      INTEGER      UNI(1),NULO,MADRID(1)
C
      CHARACTER*60   FRAMEC,ROWA,ROWB
      CHARACTER*60   ATOM(23),OPERA,OPERB,OPERC
      CHARACTER      WORK(2)*50
      CHARACTER      OPERAT*4,LINE*256
      CHARACTER      PARMS(8)*2,CBUF*80
      CHARACTER      ERROR1*60,ERROR3*40,ERROR4*40
      CHARACTER      RC*1,RCUP*1,RCT*2,LLINE*256
      CHARACTER      IDENT*20,CUNIT*20
C
      REAL         RDUM,CONSTA(2),CONST,CUTS(4)
      REAL         RNULL(2),USRNUL,EPSP,EPSN
C 
      DOUBLE PRECISION  DDUM
C
      COMMON   /NULCOM/  NULCNT,USRNUL,EPSP,EPSN,TSTFLG
      COMMON   /VMR/  MADRID
      COMMON   /TIMNOS/  QIMNO
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
C
      DATA
     + ERROR1  /'operands do not match in stepsize or origin... '/
      DATA    ERROR3  /'wrong syntax...'/
      DATA    ERROR4  /'too many operands - reduce expression '/
      DATA    APNTRS  /48*-1/
      DATA    APIX    /6*1/,    BPIX /6*1/,    CPIX /6*1/
      DATA    PARMS   /'P1','P2','P3','P4','P5','P6','P7','P8'/
      DATA    IDENT   /' '/,  CUNIT /' '/
C
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
C  set up MIDAS environment + init
      CALL STSPRO('RARTHM')
      DO 50, N=1,24
         QIMNO(N) = -1
50    CONTINUE
      EPSP = 10.E-33
      EPSN = -EPSP
C
C  get null data + row/column option
      CALL STKRDR('NULL',2,2,IAV,RNULL,UNI,NULO,STAT)
      NULCNT = 0
      USRNUL = RNULL(1)
      IF (RNULL(2).GT.0.) THEN
         TSTFLG = 1
      ELSE
         TSTFLG = 0
      ENDIF
      CALL STKRDC('DEFAULT',1,16,1,IAV,RC,UNI,NULO,STAT)
      CALL LOWCAS(RC,RC)                        !need it in lower + upper case
      CALL UPCAS(RC,RCUP)
C
C  get result frame + result row (column)
      CALL STKRDC('P1',1,1,80,IAV,LINE,UNI,NULO,STAT)
      OPERAT(1:4) = '.   '
      OPERAT(2:2) = RC
      N = INDEX(LINE,OPERAT(1:2))
      IF (N.LE.0) THEN
         OPERAT(2:2) = RCUP
         N = INDEX(LINE,OPERAT(1:2))
         IF (N.LE.0) CALL STETER(3,ERROR3)             !invalid result string
      ENDIF
C
      FRAMEC(1:) = LINE(1:N-1)//' '                    !extract frame
      CALL CLNFRA(FRAMEC,FRAMEC,0)                     !and clean it
      CALL STFOPN(FRAMEC,D_R4_FORMAT,0,F_IMA_TYPE,IMNOC,STAT)
      CALL STDRDI(IMNOC,'NAXIS',1,1,IAV,NAXIS,UNI,NULO,STAT)
      CALL STDRDI(IMNOC,'NPIX',1,2,IAV,NPIXC,UNI,NULO,STAT)
C
C  check dimensions + get physical min,max into CUTS(3,4)
      IF (NAXIS.LT.2) NPIXC(2) = 1
      CALL STDRDR(IMNOC,'LHCUTS',3,2,IAV,CUTS(3),UNI,NULO,STAT)
C 
      IF (RC.EQ.'r') THEN
         IX = 2
         RCT = '.r'
         ROWSIZ = NPIXC(1)
      ELSE
         IX = 1
         RCT = '.c'
         ROWSIZ = NPIXC(2)
      ENDIF
      ROWLIM = NPIXC(IX)
C 
C  get working space for two input rows
      CALL STFXMP(ROWSIZ,D_R4_FORMAT,PNTR1,STAT)
      CALL STFXMP(ROWSIZ,D_R4_FORMAT,PNTR2,STAT)
C
C  set up working variables depending upon row/column option
      IF (RC.EQ.'r') THEN
         CALL STFXMP(ROWSIZ,D_R4_FORMAT,PNTRC,STAT)
         RESP = PNTRC
      ELSE
         IF (NAXIS.LT.2) CALL STETER(1,
     +      'COMPUTE/COLUMN does not work with 1-dim result frame ...')
         NN = NPIXC(1) * NPIXC(2)
         CALL STFMAP(IMNOC,F_IO_MODE,1,NN,IAV,PNTRC,STAT)    !map all data
         CALL STFXMP(NN,D_R4_FORMAT,PNTRD,STAT)
         NSIZE(1) = 128                          !transpose rows/columns
         NSIZE(2) = 256
         CALL LINCOL(MADRID(PNTRC),NPIXC,NSIZE,MADRID(PNTRD))
         RESP = PNTRD
      ENDIF
C
C  set APIX, BPIX + CPIX last pixels
      APIX(1,2) = ROWSIZ
      BPIX(1,2) = ROWSIZ
      CPIX(1,2) = ROWSIZ
C
C  check dimension and result row (column) no.
      RESROW = 0
      CALL GENCNV(LINE(N+2:60),1,1,RESROW,RDUM,DDUM,LL)
      CALL TSTROW(1,RESROW,ROWLIM,RC)
C
C  get arithmetic expression
      OFF = 1
      DO 400, N=3,8
         CALL STKRDC(PARMS(N),1,1,80,IAV,CBUF,UNI,NULO,STAT)
         IF (CBUF(1:1).EQ.'?') GOTO 500
C
         IF (N.EQ.8) THEN                  !P8 may have embedded blanks
            LINE(OFF:) = CBUF(1:)//' '
            GOTO 510
         ENDIF
C
         IAV = INDEX(CBUF,' ')             !no blanks in here ...
         IF (IAV.LE.1) IAV = 80
         LINE(OFF:) = CBUF(1:)
         OFF = OFF + IAV - 1
400   CONTINUE
C 
500   LINE(OFF:) = ' '
C
C  check for rows/columns from other frames
510   LLINE(1:) = LINE(1:)
      CALL LOWCAS(LLINE,LLINE)
530   K = INDEX(LLINE,RCT)
      IF (K.GT.1) THEN                     !mark for later 
         LLINE(K:K) = '^'
         LINE(K:K) = '^'
         GOTO 530
      ENDIF
C
C  reduce expression...
      IDUMMY = 60
      CALL EXPCLE(LINE,WORK(2),IDUMMY,COUNT,ATOM,LATOM)  !clean up + fill ATOMS
C
      IF (COUNT.EQ.-1) THEN
         CALL STETER(5,'invalid syntax...')
      ELSE IF (COUNT.EQ.-2) THEN
         CALL STETER(6,'buffer overflow...')
C
C  take care of operand without operation
      ELSE IF (COUNT.EQ.1) THEN
         ATOM(2) = '0.'                            !extend F or C to F+C or C+C
         LATOM(2) = 2
         WORK(2)(2:3) = '+C'
         COUNT = 2
      ENDIF
C
      CALL EXPPOL(WORK(2),WORK(1),STAT)             !convert to polish notation
      IF (STAT.NE.0) CALL STETER(3,ERROR3)
      LL = INDEX(WORK(1),' ') - 1
      IF (LL.GT.45) CALL STETER(8,ERROR4)
C
C  now initialize pointers for ATOM
      K = 1
      DO 800,N=1,LL
         IF ((WORK(1)(N:N).EQ.'C').OR.
     +       (WORK(1)(N:N).EQ.'F').OR.
     +       (WORK(1)(N:N).EQ.'Q').OR.
     +       (WORK(1)(N:N).EQ.'P')) THEN
            APNTRS(N) = K
            K = K + 1
         ENDIF
800   CONTINUE
      IDUMMY = 0                                       !init dummy row counter
C
C  create intermediate work file
      NPIXW(1) = ROWSIZ
      NPIXW(2) = 24                        !max. 24 temporary values...
      NN = NPIXW(1) * NPIXW(2)
      CALL STFXMP(NN,D_R4_FORMAT,PNTRW,STAT)
C
C  extract basic operations
1000  CALL EXPRDC(WORK(1),WORK(2),OPERAT,PP)
      IF (PP .LT. 1) CALL STETER(3,ERROR3)
C
C  extract operands
      P1 = APNTRS(PP)
      P2 = APNTRS(PP+1)
      OPERA = ATOM(P1)
      OPERB = ATOM(P2)
      LOPA = LATOM(P1)
      LOPB = LATOM(P2)
      IF (OPERAT(1:1).EQ.'Q') THEN                !treat 2-arg functions...
         P3 = APNTRS(PP+2)
         OPERC = ATOM(P3)
         LOPC = LATOM(P3)
      ENDIF
C
C  find out what kind of operation to do
      N = INDEX(OPERAT,'C')                       !look for constants
      IF (N.GT.0) THEN
         N = INDEX(OPERAT,'F')                    !also F involved...?
         IF (N.GT.0) THEN
            NBRA = -1                             !yes. indicate C,F via N=-1
         ELSE
            GOTO 1200
         ENDIF
      ELSE
         IF (OPERAT(1:1).EQ.'P') THEN
            NBRA = -1                             !indicate PF)
         ELSE
            NBRA = +1                             !indicate F,F via N = +1
         ENDIF
      ENDIF
C
C  determine next dummy row no.
      IDUMMY = IDUMMY + 1                         !increment dummy file counter
      IF (IDUMMY.GT.24) CALL STETER(4,ERROR4)     !check operand count
C
      XPNTR = PNTRW + (IDUMMY-1)*ROWSIZ
      IF (NBRA.EQ.1) THEN                         !now use NBRA from above...
         GOTO 2000
      ELSE
         GOTO 1600                                !everything else: FC, CF, PF
      ENDIF
C
C  only constants involved, do it right now
1200  IF (OPERAT(1:2).EQ.'CC') THEN
         LINE(1:33) = OPERA(1:LOPA)//','//OPERB(1:LOPB)//', '
         CALL GENCNV(LINE(1:33),2,2,IDUM,CONSTA,DDUM,LL)
         IF (LL.LE.0) CALL STETER(2,'invalid number...')
         CALL OPCC(OPERAT,CONSTA(1),CONSTA(2),CONST)
      ELSE
         IF (OPERAT(1:1).EQ.'P') THEN                  !1-arg functions
            CALL GENCNV(OPERB(1:LOPB),2,1,IDUM,CONSTA,DDUM,LL)
            IF (LL.LE.0) CALL STETER(2,'invalid number...')
            CALL FUN1C(OPERA(1:5),CONSTA,CONST)
         ELSE                                          !2-arg functions
            LINE(1:33) = OPERB(1:LOPB)//','//OPERC(1:LOPC)//', '
            CALL GENCNV(LINE(1:33),2,2,IDUM,CONSTA,DDUM,LL)
            IF (LL.LE.0) CALL STETER(2,'invalid number...')
            CALL FUN2CC(OPERA(1:5),CONSTA,CONST)
         ENDIF
      ENDIF
C
C  put resulting constant back into relevant ATOM + goto loopend
      WRITE(ATOM(P1),10000) CONST
      LATOM(P1) = 15
      GOTO 5000
C
C  constant + row involved
1600  IF (OPERAT(1:2).EQ.'FC') THEN
         ROWA = OPERA(1:LOPA)//' '
         LINE(1:17) = OPERB(1:LOPB)//', '
         NBRA = 1                                    !no function
         GOTO 1700
      ENDIF
      IF (OPERAT(1:2).EQ.'CF') THEN
         ROWA = OPERB(1:LOPB)//' '
         LINE(1:17) = OPERA(1:LOPA)//', '
         NBRA = 1                                    !no function
         GOTO 1700
      ENDIF
      IF (OPERAT(1:2).EQ.'PF') THEN
         ROWA = OPERB(1:LOPB)//' '
         NBRA = 2                                    !1-arg function
         GOTO 1700
      ENDIF
      NBRA = 3                                       !2-arg function
      IF (OPERAT(1:2).NE.'QC') THEN
         ROWA = OPERB(1:LOPB)//' '
         LINE(1:17) = OPERC(1:LOPC)//', '
      ELSE
         ROWA = OPERC(1:LOPC)//' '
         LINE(1:17) = OPERB(1:LOPB)//', '
      ENDIF
C 
C  so we have the row definition in ROWA
1700  IFA = INDEX(ROWA,'^')
      IF (IFA .GT. 1) THEN                     !row from a different frame
         CBUF(1:) = ROWA(1:IFA-1)//' '
         ROWA = ROWA(IFA+1:)//' '
         CALL CLNFRA(CBUF,CBUF,0)               !clean frame name
         CALL STFOPN(CBUF,D_R4_FORMAT,0,F_IMA_TYPE,IMNOA,STAT)
         CALL TRANSP(QPNTR,RC,ROWSIZ,CBUF,IMNOA,NAXIS,NPIXA,ZPNTRA)
         ROWLIM = NPIXA(IX)
      ELSE
         IFA = -1                                    !row of result frame
         IMNOA = IMNOC
         ROWLIM = NPIXC(IX)
         ZPNTRA = RESP
      ENDIF
C 
      IF (NBRA.NE.2) THEN
         CALL GENCNV(LINE(1:17),2,1,IDUM,CONST,DDUM,LL)
         IF (LL.LE.0) CALL STETER(2,'invalid number...')
      ENDIF
C
      ROWNOA = 0
      CALL GENCNV(ROWA(2:),1,1,ROWNOA,RDUM,DDUM,LL)
      CALL TSTROW(0,ROWNOA,ROWLIM,RC)
      NN = (ROWNOA-1)*ROWSIZ                       !get offset for row/column
      IF ((ROWA(1:1).EQ.RC) .OR. (ROWA(1:1).EQ.RCUP)) THEN
         IF (RC.EQ.'c') THEN
            APNTR = ZPNTRA + NN
         ELSE
            APNTR = PNTR1
            NN = NN + 1
            CALL STFGET(IMNOA,NN,ROWSIZ,IAV,MADRID(APNTR),STAT)
         ENDIF
      ELSE
         APNTR = PNTRW + NN             !work row, e.g. x0003
      ENDIF
C
C  now do the actual OPERATion
      GOTO (1850,1860,1870),NBRA                        !branch accordingly...
1850  CALL OPFC(OPERAT,MADRID(APNTR),CONST,MADRID(XPNTR),ROWSIZ)
      GOTO 4400
1860  CALL FUN1F(OPERA(1:5),MADRID(APNTR),MADRID(XPNTR),ROWSIZ)
      GOTO 4400
1870  CALL FUN2FC(OPERA(1:5),MADRID(APNTR),CONST,MADRID(XPNTR),ROWSIZ)
      GOTO 4400
C
C  both operands are rows
2000  IF (OPERAT(1:1).NE.'Q') THEN
         ROWA = OPERA(1:LOPA)//' '
         ROWB = OPERB(1:LOPB)//' '
      ELSE
         ROWA = OPERB(1:LOPB)//' '
         ROWB = OPERC(1:LOPC)//' '
      ENDIF
C 
      IFA = INDEX(ROWA,'^')
      IF (IFA .GT. 1) THEN                     !row from a different frame
         CBUF(1:) = ROWA(1:IFA-1)//' '
         ROWA = ROWA(IFA+1:)//' '
         CALL CLNFRA(CBUF,CBUF,0)               !clean frame name
         CALL STFOPN(CBUF,D_R4_FORMAT,0,F_IMA_TYPE,IMNOA,STAT)
         CALL TRANSP(QPNTR,RC,ROWSIZ,CBUF,IMNOA,NAXIS,NPIXA,ZPNTRA)
         ROWLIM = NPIXA(IX)
      ELSE
         IFA = -1
         IMNOA = IMNOC
         ROWLIM = NPIXC(IX)
         ZPNTRA = RESP
      ENDIF
C
      ROWNOA = 0
      CALL GENCNV(ROWA(2:),1,1,ROWNOA,RDUM,DDUM,LL)
      CALL TSTROW(0,ROWNOA,ROWLIM,RC)
      NN = (ROWNOA-1)*ROWSIZ                       !get offset for row/column
      IF ((ROWA(1:1).EQ.RC) .OR. (ROWA(1:1).EQ.RCUP)) THEN
         IF (RC.EQ.'c') THEN
            APNTR = ZPNTRA + NN
         ELSE
            APNTR = PNTR1
            NN = NN + 1
            CALL STFGET(IMNOA,NN,ROWSIZ,IAV,MADRID(APNTR),STAT)
         ENDIF
      ELSE
         APNTR = PNTRW + NN                           !work row, e.g. x0003
      ENDIF
C 
      IFB = INDEX(ROWB,'^')
      IF (IFB .GT. 1) THEN                     !row from a different frame
         CBUF(1:) = ROWB(1:IFB-1)//' '
         ROWB = ROWB(IFB+1:)//' '
         CALL CLNFRA(CBUF,CBUF,0)               !clean frame name
         CALL STFOPN(CBUF,D_R4_FORMAT,0,F_IMA_TYPE,IMNOB,STAT)
         CALL TRANSP(QPNTR,RC,ROWSIZ,CBUF,IMNOB,NAXIS,NPIXB,ZPNTRB)
         ROWLIM = NPIXB(IX)
      ELSE
         IFB = -1
         IMNOB = IMNOC
         ROWLIM = NPIXC(IX)
         ZPNTRB = RESP
      ENDIF
C 
      ROWNOB = 0
      CALL GENCNV(ROWB(2:),1,1,ROWNOB,RDUM,DDUM,LL)
      CALL TSTROW(0,ROWNOB,ROWLIM,RC)
      NN = (ROWNOB-1)*ROWSIZ                       !get offset for row/column
      IF ((ROWB(1:1).EQ.RC) .OR. (ROWB(1:1).EQ.RCUP)) THEN
         IF (RC.EQ.'c') THEN
            BPNTR = ZPNTRB + NN
         ELSE
            BPNTR = PNTR2
            NN = NN + 1
            CALL STFGET(IMNOB,NN,ROWSIZ,IAV,MADRID(BPNTR),STAT)
         ENDIF
      ELSE
         BPNTR = PNTRW + NN                           !work row, e.g. x0003
      ENDIF
C
C  let CPIX reflect the affected row in the working buffer
      CPIX(2,1) = IDUMMY
      CPIX(2,2) = IDUMMY
C
C  now do the actual OPERAT
      IF (OPERAT(1:1).NE.'Q') THEN
         CALL OPFFW(OPERAT,MADRID(APNTR),MADRID(BPNTR),
     +              MADRID(PNTRW),APIX,BPIX,CPIX,
     +              ROWSIZ,ROWSIZ,ROWSIZ)
      ELSE
         CALL FN2FFW(OPERA(1:5),MADRID(APNTR),MADRID(BPNTR),
     +               MADRID(PNTRW),APIX,BPIX,CPIX,
     +               ROWSIZ,ROWSIZ,ROWSIZ)
      ENDIF
C
C  put resulting row back into relevant ATOM
4400  WRITE(LINE,10001) IDUMMY
      ATOM(P1)(1:) = 'x'//LINE(1:4)
      LATOM(P1) = 5
C
C  loopend for all basic operations
C 
5000  IF (WORK(2)(2:).EQ.' ') GOTO 9000            !finished...
C 
      IF (OPERAT(1:1).NE.'Q') THEN
         NBRA = 2
      ELSE
         NBRA = 3
      ENDIF
      DO 5300,N=PP+1,45                            !update pointers for ATOM
         APNTRS(N) = APNTRS(N+NBRA)
5300  CONTINUE
      WORK(1) = WORK(2)
      GOTO 1000                                    !get next operation
C
C  We made it... test, if frame or constant
C
9000  IF (RC.EQ.'r') THEN
         IF (WORK(2)(1:1).EQ.'C') THEN
            CALL OPFC('FC=',0.,CONST,MADRID(RESP),ROWSIZ)
         ELSE
            APNTR = PNTRW + (IDUMMY-1)*ROWSIZ
            CALL COPYF(MADRID(APNTR),MADRID(RESP),ROWSIZ)
         ENDIF
         NN = (RESROW-1)*ROWSIZ + 1                   !write result row back 
         CALL STFPUT(IMNOC,NN,ROWSIZ,MADRID(RESP),STAT)
C 
      ELSE
         BPNTR = RESP + (RESROW-1)*ROWSIZ 
         IF (WORK(2)(1:1).EQ.'C') THEN
            CALL OPFC('FC=',0.,CONST,MADRID(BPNTR),ROWSIZ)
         ELSE
            APNTR = PNTRW + (IDUMMY-1)*ROWSIZ
            CALL COPYF(MADRID(APNTR),MADRID(BPNTR),ROWSIZ)
         ENDIF
      ENDIF
C
C  calculate new dynamic range of result frame
      CALL MYMX(MADRID(RESP),ROWSIZ,CUTS(1))
      IF (CUTS(1).LT.CUTS(3)) CUTS(3) = CUTS(1)
      IF (CUTS(2).GT.CUTS(4)) CUTS(4) = CUTS(2)
      CALL STDWRR(IMNOC,'LHCUTS',CUTS(3),3,2,UNI,STAT)
C 
C  update descr. HISTORY
      LINE(1:) = ' '
      CALL DSCUPT(IMNOC,IMNOC,LINE,STAT)
C
C  if we worked on columns, transpose result frame back
      IF (RC.EQ.'c') THEN
         NPIXW(1) = NPIXC(2)
         NPIXW(2) = NPIXC(1)
         CALL LINCOL(MADRID(PNTRD),NPIXW,NSIZE,MADRID(PNTRC))
      ENDIF
C
      RNULL(1) = FLOAT(NULCNT)
      CALL STKWRR('NULL',RNULL,1,1,UNI,STAT)
      CALL STSEPI
C
C  formats...
10000 FORMAT(G15.7)
10001 FORMAT(I4.4)
      END

      SUBROUTINE TRANSP(QPNTR,CC,SIZE,FRAME,IMNOA,NAXIS,NPIX,PNTR)
C 
      IMPLICIT NONE
C 
      INTEGER   NAXIS,NPIX(2),SIZE,IMNOA
      INTEGER   IMNO,NS(2),STAT,MM,MQ,N,IAV
      INTEGER*8 PNTR,XPNTR,QPNTR(24)
      INTEGER   QIMNO(24)
      INTEGER   UNI(1),NULO,MADRID(1)
C 
      DOUBLE PRECISION  START(2),STEP(2)
C 
      CHARACTER     CC*1,FRAME*(*)
      CHARACTER     IDENT*20,CUNIT*20
C 
      COMMON   /VMR/  MADRID
      COMMON   /TIMNOS/  QIMNO
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
C
      DATA    IDENT /' '/, CUNIT /' '/
C 
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C 
      CALL STDRDI(IMNOA,'NAXIS',1,1,IAV,NAXIS,UNI,NULO,STAT)
      CALL STDRDI(IMNOA,'NPIX',1,2,IAV,NPIX,UNI,NULO,STAT)
C 
      IF (CC.EQ.'r') THEN
         IF (NAXIS.EQ.1) NPIX(2) = 1
         IF (NPIX(1).NE.SIZE)
     +      CALL STETER(11,'non-matching row size...')
      ELSE
         IF (NAXIS.EQ.1) THEN
            IF (NPIX(1).NE.SIZE)
     +         CALL STETER(11,'non-matching column size...')
C 
            DO 100, N=1,24
               IF (QIMNO(N).LT.0) THEN
                  MQ = N
                  GOTO 200
               ELSE IF (QIMNO(N).EQ.IMNOA) THEN
                  PNTR = QPNTR(N)
                  RETURN
               ENDIF
100         CONTINUE
            CALL STETER(12,'Too many frames in expression...')
C 
200         CALL STIGET(FRAME,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,
     +                  1,NAXIS,NPIX,START,STEP,
     +                  IDENT,CUNIT,PNTR,IMNO,STAT)
            NPIX(2) = NPIX(1)
         ELSE
            IF (NPIX(2).NE.SIZE)
     +         CALL STETER(11,'non-matching column size...')
C 
            DO 400, N=1,24
               IF (QIMNO(N).LT.0) THEN
                  MQ = N
                  GOTO 500
               ELSE IF (QIMNO(N).EQ.IMNOA) THEN
                  PNTR = QPNTR(N)
                  RETURN
               ENDIF
400         CONTINUE
            CALL STETER(12,'Too many frames in expression...')
C 
500         CALL STIGET(FRAME,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,
     +                  2,NAXIS,NPIX,START,STEP,
     +                  IDENT,CUNIT,XPNTR,IMNO,STAT)
            QIMNO(MQ) = IMNO
C 
            MM = NPIX(1)*NPIX(2)
            CALL STFXMP(MM,D_R4_FORMAT,PNTR,STAT)
            NS(1) = 128
            NS(2) = 256
            CALL LINCOL(MADRID(XPNTR),NPIX,NS,MADRID(PNTR))
            QPNTR(MQ) = PNTR
         ENDIF
      ENDIF
C 
      RETURN
      END

      SUBROUTINE TSTROW(FLAG,RNO,ROWMAX,CC)
C 
      IMPLICIT NONE
C 
      INTEGER   FLAG,RNO,ROWMAX
      INTEGER   EFLAG
C 
      CHARACTER*1   CC
      CHARACTER     BUBI*80
C 
      IF ( (RNO.LT.1).OR.(RNO.GT.ROWMAX) ) THEN
         EFLAG = 7
C 
         IF (CC.EQ.'r') THEN                      !problems with rows
            IF (FLAG.EQ.0) THEN
               IF (RNO .EQ. 0) THEN
                  EFLAG = 3
                  BUBI(1:) = 'Invalid row specification... '
               ELSE
                  WRITE(BUBI,10001) RNO
               ENDIF
            ELSE                                  !concerns result row
               IF (RNO .EQ. 0) THEN
                  EFLAG = 3
                  BUBI(1:) = 'Invalid result row specification... '
               ELSE
                  WRITE(BUBI,20001) RNO
               ENDIF
            ENDIF
C 
         ELSE                                     !problems with columns
            IF (FLAG.EQ.0) THEN
               IF (RNO .EQ. 0) THEN
                  EFLAG = 3
                  BUBI(1:) = 'Invalid  column specification... '
               ELSE
                  WRITE(BUBI,10002) RNO
               ENDIF
            ELSE                                  !concerns result column
               IF (RNO .EQ. 0) THEN
                  EFLAG = 3
                  BUBI(1:) = 'Invalid result column specification... '
               ELSE
                  WRITE(BUBI,20002) RNO
               ENDIF
            ENDIF
         ENDIF
C 
         CALL STETER(EFLAG,BUBI)
      ENDIF
C 
      RETURN
C
10001 FORMAT('row ',I4,' not inside frame... ')
10002 FORMAT('column ',I4,' not inside frame... ')
20001 FORMAT('result row ',I4,' not inside frame... ')
20002 FORMAT('result column ',I4,' not inside frame... ')
C 
      END