C===========================================================================
C Copyright (C) 1995-2005 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 DATA
C
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  program DATA            	version 3.30	850719
C  K. Banse     		ESO - Garching
C
C.KEYWORDS
C  bulk data frame
C
C.PURPOSE
C  manipulate pixels of a bulk data frame
C
C.ALGORITHM
C  straight forward
C
C.INPUT/OUTPUT
C  the following keys are used:
C
C  IN_A/C/1/60          name of data frame
C  ACTION/C/1/1         = R, for reading pixel values (max. 4096)
C              		= P, for printing pixel values (max. 4096)
C              		= W, for writing pixel values (max. 20)
C  IN_B/C/1/60          start coordinates (as real coords. or as pixel no's.),
C            		no. of values
C            		or
C            		subarea as [.,.:.,.]
C            		or
C            		= CURSOR, to indicate that we use cursor window
C            		or an ASCII name of a table
C  INPUTC/C/1/80        values to write to pixels (W)
C            		in case of CURSOR window, only one value will
C            		be written to all pixels inside the window
C  HIDEHEAD/C/1/1	hide_header_flag = H or ?, for READ, PRINT/IMAGE
C			to control printing of frame header + lines
C  P4/C/1/1             all_flag = A or ?, for WRITE/IMAGE 
C  PROCESS/C/1/1        process_flag = S(tore), A(dd) or M(ultiply)
C
C  INPUTI/I/1/1		no. of values per line to display (default = 5/3)
C
C			that keyword
C  OUTPUTR/R/1/20       for R, P the first 20 values are also stored in 
C			that keyword
C
C.VERSIONS
C 051017		last modif
C 
C--------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER      IAV,N,STAT,M1,M2,M3,M4
      INTEGER      NAXIS,NPIX(3)
      INTEGER      IMNOW,SIZE,MAPSIZ,MAXNO
      INTEGER*8    WPNTR
      INTEGER      UNIT(1),NULLO,IMNO,DATFMT,CVFLAG
      INTEGER      MADRID(1)
      INTEGER      PRFLAG,IBUF(5),MONSIZ,NOHEAD
C 
      REAL         CUTS(4)
C
      CHARACTER    FRAME*80,CBUF*80
      CHARACTER    INPUTC*80,AC*4
C
      DOUBLE PRECISION START(3),STEP(3)
      DOUBLE PRECISION DMIN,DMAX
C 
      INCLUDE  'MID_INCLUDE:ST_DEF.INC'
C 
      INCLUDE  'MID_INCLUDE:IDIDEV.INC'
      INCLUDE  'MID_INCLUDE:IDIMEM.INC'
C 
      COMMON    /VMR/ MADRID
      COMMON    /SVCUTS/  CUTS,DMIN,DMAX
      COMMON    /WSPACE/  IMNOW,MAPSIZ,NOHEAD
      COMMON    /IMINFO/  IMNO,DATFMT,CVFLAG,MAXNO,NAXIS,NPIX
      COMMON    /ALLOC/  WPNTR
C
      DATA      NPIX      /3*1/
      DATA      INPUTC    /' '/
C
      INCLUDE  'MID_INCLUDE:ST_DAT.INC'
C 
C  get into MIDAS 
      CALL STSPRO('DATA')
C
C  get action flag, frame, boundaries for data + hide_header_flag
      CALL STKRDC('ACTION',1,1,1,IAV,AC,UNIT,NULLO,STAT)
      CALL STKRDC('IN_A',1,1,80,IAV,INPUTC,UNIT,NULLO,STAT)
      CALL CLNFRA(INPUTC,FRAME,0)
      CALL STKRDC('IN_B',1,1,80,IAV,INPUTC,UNIT,NULLO,STAT)
      CALL UPCAS(INPUTC,INPUTC)
      CALL STKRDC('HIDEHEAD',1,1,1,IAV,CBUF,UNIT,NULLO,STAT)
      IF ((CBUF(1:1).EQ.'H').OR.(CBUF(1:1).EQ.'h')) THEN
         NOHEAD = 1
      ELSE
         NOHEAD = 0
      ENDIF
      PRFLAG = 0
      IF (AC(1:1).EQ.'W') THEN
         CALL STKRDC('PROCESS',1,1,1,IAV,CBUF,UNIT,NULLO,STAT)
         IF ((CBUF(1:1).EQ.'A').OR.(CBUF(1:1).EQ.'a')) THEN
            PRFLAG = 1            !set the data-proc-flag (set, add, multiply)
         ELSE IF ((CBUF(1:1).EQ.'M').OR.(CBUF(1:1).EQ.'m')) THEN
            PRFLAG = 2
         ENDIF
      ENDIF
      CALL STKRDI('INPUTI',1,1,IAV,MAXNO,UNIT,NULLO,STAT)
C 
C  get info of data frame
      CALL STFINF(FRAME,2,IBUF,STAT)
      DATFMT = D_R4_FORMAT
      CVFLAG = 2
      IF (IBUF(2) .EQ. D_I1_FORMAT) THEN
         AC(2:2) = '1'
      ELSE IF (IBUF(2) .EQ. D_I2_FORMAT) THEN
         AC(2:2) = '2'
      ELSE IF (IBUF(2) .EQ. D_I4_FORMAT) THEN
         AC(2:2) = '4'
      ELSE IF (IBUF(2) .EQ. D_R8_FORMAT) THEN
         IF (INPUTC(1:5).EQ.'_CUR_') THEN        !we need single prec. here...
            AC(2:2) = '0'
         ELSE
            DATFMT = D_R8_FORMAT
            AC(2:2) = '8'
            CVFLAG = 4
         ENDIF
      ELSE
         AC(2:2) = '0'                        !default to real data
      ENDIF
      IF (MAXNO.LT.1) THEN                    !test, if nopix-per-line given
         IF (CVFLAG.EQ.2) THEN
            MAXNO = 5
         ELSE
            MAXNO = 3
         ENDIF
      ELSE
         IF (MAXNO.GT.20) MAXNO = 20          !FORMAT supports max. 20 values
      ENDIF
C 
      CALL STFOPN(FRAME,DATFMT,0,F_IMA_TYPE,IMNO,STAT)
      CALL STDRDI(IMNO,'NAXIS',1,1,IAV,NAXIS,UNIT,NULLO,STAT)
      CALL STDRDI(IMNO,'NPIX',1,NAXIS,IAV,NPIX,UNIT,NULLO,STAT)
C 
C  process Rn-m (row n-m) and Cn-m (column n-m)
      IF (INPUTC(1:1).EQ.'R') THEN            !Rn-m (row n till row m)
         M1 = INDEX(INPUTC,'-')
         M2 = INDEX(INPUTC,' ')
         IF (M1.LT.1) THEN                    !single row
            WRITE (CBUF,20123) INPUTC(2:M2-1),INPUTC(2:M2-1)
         ELSE
            WRITE (CBUF,20123) INPUTC(2:M1-1),INPUTC(M1+1:M2-1)
         ENDIF
         INPUTC(1:) = CBUF(1:)
      ELSE IF (INPUTC(1:1).EQ.'C') THEN       !Cn-m (column n till row m)
         M1 = INDEX(INPUTC,'-')
         M2 = INDEX(INPUTC,' ')
         IF (M1.LT.1) THEN                    !single column
            WRITE (CBUF,20124) INPUTC(2:M2-1),INPUTC(2:M2-1)
         ELSE
            WRITE (CBUF,20124) INPUTC(2:M1-1),INPUTC(M1+1:M2-1)
         ENDIF
         INPUTC(1:) = CBUF(1:)
      ENDIF
      IF (NAXIS.GT.3) THEN
         CALL STTPUT('Warning: max 3 dims of frame used ...',STAT)
         NAXIS = 3
         M1 = INDEX(INPUTC,',')
         IF (M1.GT.1) THEN
            INPUTC(M1:M1) = ' '
            M2 = INDEX(INPUTC,',')
            IF (M2.GT.1) THEN
               INPUTC(M2:M2) = ' '
               M3 = INDEX(INPUTC,',')
               IF (M3.GT.1) THEN
                  INPUTC(M3:M3) = ' '
111               M4 = INDEX(INPUTC,',')
                  IF (M4.GT.1) THEN                !get rid of commata...
                     INPUTC(M3+1:) = INPUTC(M4+1:)//' '
                     GOTO 111
                  ENDIF
                  INPUTC(M3:M3) = ','
               ENDIF
               INPUTC(M2:M2) = ','
            ENDIF
            INPUTC(M1:M1) = ','
         ENDIF
      ENDIF
C 
      CALL STDRDD(IMNO,'START',1,NAXIS,IAV,START,UNIT,NULLO,STAT)
      CALL STDRDD(IMNO,'STEP',1,NAXIS,IAV,STEP,UNIT,NULLO,STAT)
      CALL STDRDR(IMNO,'LHCUTS',1,4,IAV,CUTS,UNIT,NULLO,STAT)
      DMIN = DBLE(CUTS(3))
      DMAX = DBLE(CUTS(4))
C 
      SIZE = 1                                      !get total size of frame
      DO 200 N=1,NAXIS
         SIZE = SIZE * NPIX(N)
200   CONTINUE
C 
C  map working space for data windows
      CALL STKRDI('MONITPAR',20,1,IAV,MONSIZ,UNIT,NULLO,STAT)
      MAPSIZ = MONSIZ * MONSIZ
      IF (NPIX(3).GT.1) MAPSIZ = 3 * MAPSIZ
      IF (MAPSIZ.GT.SIZE) MAPSIZ = SIZE
      CALL STFCRE('wworrkfr',DATFMT,F_X_MODE,F_IMA_TYPE,
     +            MAPSIZ,IMNOW,STAT)
      CALL STFMAP(IMNOW,F_X_MODE,1,MAPSIZ,IAV,WPNTR,STAT)
C 
C  branch according to input mode
      IF (INPUTC(1:5).EQ.'_CUR_') THEN
         AC(3:3) = INPUTC(6:6)              !C or 1,2 for no. of cursors
         IF (AC(1:1).EQ.'W') THEN
            IF (CUTS(1).GE.CUTS(2)) THEN
               CUTS(1) = CUTS(3)
               CUTS(2) = CUTS(4)
            ENDIF
         ENDIF
         CALL DATACU(FRAME,SIZE,AC,PRFLAG)
C
      ELSE
         IF ((AC(1:1).NE.'W') .AND.
     +       (NOHEAD.EQ.0)) CALL FRAMOU(FRAME)
         CALL UPCAS(INPUTC(1:80),CBUF)
         IAV = INDEX(CBUF,',T')                  !look for xyz,table
         IF (IAV .GT. 1) THEN
            INPUTC(IAV:) = ' '                   !clean up table name
            CALL DATATB(FRAME,START,STEP,AC,INPUTC,PRFLAG)
         ELSE
            IF (INPUTC(1:7).EQ.'<,<,20 ') THEN         !adapt default to NAXIS
               IF (NAXIS.EQ.1) THEN
                  INPUTC(1:) = '<,20 '
               ELSE IF (NAXIS.EQ.3) THEN
                  INPUTC(1:) = '<,<,<,20 '
               ENDIF
            ENDIF
            CALL DATALN(FRAME,START,STEP,SIZE,AC,INPUTC,PRFLAG)
         ENDIF
      ENDIF
C  
C  for WRITE/IMAGE update descr. HISTORY and if necessary LHCUTS 
      IF (AC(1:1).EQ.'W') THEN
         CALL DSCUPT(IMNO,IMNO,' ',STAT)
         CUTS(3) = SNGL(DMIN)
         CUTS(4) = SNGL(DMAX)
         CALL STDWRR(IMNO,'LHCUTS',CUTS(3),3,2,UNIT,STAT)
      ENDIF
C  
C that's it folks ...
C 
      CALL STSEPI
C 
20123 FORMAT('[<,@',A,':>,@',A,']')
20124 FORMAT('[@',A,',<:@',A,',>]')
C 
      END

      SUBROUTINE DATALN(FRAME,START,STEP,SIZE,AC,INPUTC,PRFLAG)
C
      IMPLICIT NONE
C
      INTEGER      PRFLAG,ACTVAL,COPTIO(3)
      INTEGER      IAV,NOVAL,CVFLAG,MAXNO,IBUF(1)
      INTEGER      N,N1,N2,N3,N4,N5
      INTEGER      NAXIS,NLINES,NO,NOOUT,NREM
      INTEGER*8    WPNTR,WPNTR2,WREST
      INTEGER      IMNOW,MAPSIZ,NOHEAD
      INTEGER      OFFSET,REST
      INTEGER      SIZE,SLEN,STA,STAT,SUBDIM
      INTEGER      XOFF,YOFF
      INTEGER      NPIX(3),DATFMT
      INTEGER      PIXELS(3,2),PIXLS1(3,2),PIXLS2(3,2),PIXLS3(3,2),
     +             PIXLS4(3,2),PIXLS5(3,2)
      INTEGER      SUBLO(3),SUBHI(3)
      INTEGER      UNIT(1),NULLO,IMNO
      INTEGER      MADRID(1)
C
      CHARACTER    FRAME*(*),AC*(*),INPUTC*(*)
      CHARACTER    RWOPT*1,NEWSTR*80
      CHARACTER    ALLFLG*1,INSTRM*1,VALBUF*15
      CHARACTER    ATOM(4)*15
C
      DOUBLE PRECISION  START(3),STEP(3)
      DOUBLE PRECISION  DBUF(80),DVAL
C 
      REAL         RBUF(80),RVAL
C
      INCLUDE  'MID_INCLUDE:ST_DEF.INC'
C 
      COMMON    /VMR/ MADRID
      COMMON    /WSPACE/  IMNOW,MAPSIZ,NOHEAD
      COMMON    /IMINFO/  IMNO,DATFMT,CVFLAG,MAXNO,NAXIS,NPIX
      COMMON    /ALLOC/  WPNTR
C
      DATA      SUBLO     /3*1/
      DATA      SUBHI     /3*1/
      DATA      PIXELS    /6*1/
      DATA      PIXLS1    /6*1/, PIXLS2 /6*1/
      DATA      PIXLS3    /6*1/, PIXLS4 /6*1/, PIXLS5 /6*1/
C
      INCLUDE  'MID_INCLUDE:ST_DAT.INC'
C 
C  extract window   or     start coords. + no. of values
C 
      RWOPT = 'W'                                  ! default to window option
      IF (INPUTC(1:1).EQ.'[') THEN
         CALL EXTCOO(IMNO,INPUTC,3,SUBDIM,SUBLO,SUBHI,STAT)
         IF (STAT.NE.0) GOTO 9900
C 
         NOVAL = (SUBHI(1)-SUBLO(1)+1) * (SUBHI(2)-SUBLO(2)+1)
     +                                 * (SUBHI(3)-SUBLO(3)+1)
         DO 400,N=1,3 
            PIXELS(N,1) = SUBLO(N)
            PIXELS(N,2) = SUBHI(N)
400      CONTINUE
C 
      ELSE     
         STA = 1
         CALL EXTRSS(INPUTC,',',STA,ATOM(1),SLEN)
         CALL EXTRSS(INPUTC,',',STA,ATOM(2),SLEN)
         CALL EXTRSS(INPUTC,',',STA,ATOM(3),SLEN)
         IF (SLEN.LE.0) THEN
            SUBDIM = 1                                  !x,value
         ELSE
            CALL EXTRSS(INPUTC,',',STA,ATOM(4),SLEN)
            IF (SLEN.LE.0) THEN
               SUBDIM = 2                               !x,y,value
            ELSE
               SUBDIM = 3                               !x,y,z,value
            ENDIF
         ENDIF
         IF (SUBDIM.NE.NAXIS) THEN
            IF (SUBDIM.EQ.(NAXIS-1)) THEN
               CALL STTPUT
     +         ('No. of values missing, defaulted to 20...',STAT)
               SUBDIM = SUBDIM + 1
               VALBUF = '20 '
            ELSE
               CALL STETER(21,
     +              'No. of start_coords not equal to NAXIS...')
            ENDIF
         ELSE
            VALBUF = ATOM(SUBDIM+1)
         ENDIF
C
C  build [x,y,z] string
         IF (SUBDIM.GT.NAXIS) GOTO 9900
         NEWSTR(1:) = '[ '
         N1 = 1
         DO 770, N=1,SUBDIM
            N1 = N1 + 1
            NEWSTR(N1:) = ATOM(N)
            N1 = INDEX(NEWSTR,' ')
            NEWSTR(N1:N1) = ','
770      CONTINUE
         NEWSTR(N1:) = '] '
C 
         CALL EXTCO1(IMNO,NEWSTR,3,SUBDIM,SUBLO,STAT)
         IF (STAT.NE.0) GOTO 9900
         DO 780, N=1,SUBDIM
            PIXELS(N,1) = SUBLO(N)
            PIXELS(N,2) = SUBLO(N)
780      CONTINUE
C
C  make sure, no. of values remains in limits
         OFFSET = (PIXELS(2,1)-1)*NPIX(1) + PIXELS(1,1) - 1  
         IF (VALBUF.EQ.'ALL') THEN
            NOVAL = SIZE
         ELSE
            CALL GENCNV(VALBUF,1,1,NOVAL,RVAL,DVAL,IAV)
            IF (IAV.LT.1) GOTO 9900
         ENDIF
C                                                keep in right interval...
         IF (NOVAL.LT.1) NOVAL = 1
         N = SIZE - OFFSET
         IF (NOVAL.GT.N) NOVAL = N
C
C  now determine N1, N2, N3, N4, N5
         XOFF = PIXELS(1,1) - 1
         YOFF = PIXELS(2,1) - 1
C                                              remaining pixels on this line
         N1 = NPIX(1) - XOFF                 
         IF (NOVAL.LE.N1) THEN
            PIXELS(1,2) = PIXELS(1,1) + NOVAL - 1
            GOTO 900
         ENDIF
C 
C  sequential reading/writing
C  split up rest into no. of full lines more, pixels on last line, 
C  remaining lines on this plane, full lines on this plane, 
C  number of full planes and full lines on last plane
C 
         RWOPT = 'S'                       
         REST = NOVAL - N1                    
         NLINES = REST/NPIX(1)                 
         N5 = REST - (NLINES*NPIX(1))                 
         YOFF = YOFF + 1
         NREM = NPIX(2) - YOFF                 
         N2 = MIN(NREM,NLINES)                 
         NLINES = NLINES - N2
         REST = NLINES * NPIX(1)
         N3 = NLINES/NPIX(2)                       
         N4 = NLINES - N3*NPIX(2)                 
C
C  set up for 1. line
         PIXLS1(1,1) = PIXELS(1,1)                 
         PIXLS1(2,1) = PIXELS(2,1)
         PIXLS1(3,1) = PIXELS(3,1)
         PIXLS1(1,2) = PIXLS1(1,1) + N1 - 1
         PIXLS1(2,2) = PIXLS1(2,1)
         PIXLS1(3,2) = PIXLS1(3,1)
C
C  use 1. pixel on next line in same plane
         IF (N2.GT.0) THEN
            PIXLS2(1,1) = 1               
            PIXLS2(2,1) = PIXLS1(2,2) + 1 
            PIXLS2(3,1) = PIXELS(3,1)        
            PIXLS2(1,2) = NPIX(1)
            PIXLS2(2,2) = PIXLS1(2,2) + N2
            PIXLS2(3,2) = PIXLS2(3,1)
         ENDIF
C
C  use 1. pixel on first line in next plane
         IF (N3.GT.0) THEN
            PIXLS3(1,1) = 1         
            PIXLS3(2,1) = 1          
            PIXLS3(3,1) = PIXELS(3,1) + 1 
            PIXLS3(1,2) = NPIX(1)
            PIXLS3(2,2) = NPIX(2)
            PIXLS3(3,2) = PIXELS(3,1) + N3
         ENDIF
C
C  use 1. pixel on first line in last plane
         IF (N4.GT.0) THEN
            PIXLS4(1,1) = 1                
            PIXLS4(2,1) = 1               
            PIXLS4(3,1) = PIXELS(3,1) + N3 + 1  
            PIXLS4(1,2) = NPIX(1)
            PIXLS4(2,2) = N4
            PIXLS4(3,2) = PIXLS4(3,1)
         ENDIF
C
         IF (N5.GT.0) THEN
            PIXLS5(1,1) = 1                 
C
C  use 1. pixel on last line
            IF ((N3.GT.0).OR.(N4.GT.0)) THEN      
               PIXLS5(2,1) = N4 + 1                
               PIXLS5(3,1) = PIXELS(3,1) + N3 + 1
            ELSE
               PIXLS5(2,1) = PIXLS1(2,1) + N2 + 1   
               PIXLS5(3,1) = PIXELS(3,1)           
            ENDIF
            PIXLS5(1,2) = N5
            PIXLS5(2,2) = PIXLS5(2,1)
            PIXLS5(3,2) = PIXLS5(3,1)
         ENDIF
C
      ENDIF
C
C  branch according to desired action
900   IF (AC(1:1).EQ.'W') GOTO 2000
C
C  read or print data
C
      IF (CVFLAG.EQ.4) THEN
         IF (RWOPT.EQ.'W') THEN                          !window option?
            CALL R4READ(RBUF,MADRID(WPNTR),PIXELS,SUBDIM,SLEN)
            IF (SLEN.GT.0) THEN             !we need more virtual memory...
               CALL XTNDW(SLEN)
               CALL R4READ(RBUF,MADRID(WPNTR),PIXELS,SUBDIM,SLEN)
            ENDIF
C
         ELSE
            CALL R4READ(RBUF,MADRID(WPNTR),PIXLS1,SUBDIM,SLEN)
            IF (SLEN.GT.0) THEN
               CALL XTNDW(SLEN)
               CALL
     +         R4READ(RBUF,MADRID(WPNTR),PIXLS1,SUBDIM,SLEN)
            ENDIF
            IF (N2.GT.0) THEN
               CALL R4READ(RBUF,MADRID(WPNTR),PIXLS2,SUBDIM,SLEN)
               IF (SLEN.GT.0) THEN
                  CALL XTNDW(SLEN)
                  CALL R4READ(RBUF,MADRID(WPNTR),PIXLS2,SUBDIM,SLEN)
               ENDIF
            ENDIF
            IF (N3.GT.0) THEN
               CALL R4READ(RBUF,MADRID(WPNTR),PIXLS3,SUBDIM,SLEN)
               IF (SLEN.GT.0) THEN
                  CALL XTNDW(SLEN)
                  CALL R4READ(RBUF,MADRID(WPNTR),PIXLS3,SUBDIM,SLEN)
               ENDIF
            ENDIF
            IF (N4.GT.0) THEN
               CALL R4READ(RBUF,MADRID(WPNTR),PIXLS4,SUBDIM,SLEN)
               IF (SLEN.GT.0) THEN
                  CALL XTNDW(SLEN)
                  CALL R4READ(RBUF,MADRID(WPNTR),PIXLS4,SUBDIM,SLEN)
               ENDIF
            ENDIF
            IF (N5.GT.0) THEN
               CALL R4READ(RBUF,MADRID(WPNTR),PIXLS5,SUBDIM,SLEN)
               IF (SLEN.GT.0) THEN
                  CALL XTNDW(SLEN)
                  CALL R4READ(RBUF,MADRID(WPNTR),PIXLS5,SUBDIM,SLEN)
               ENDIF
            ENDIF
         ENDIF
      ELSE
         IF (RWOPT.EQ.'W') THEN                          !window option?
            CALL R4READ(MADRID(WPNTR),DBUF,PIXELS,SUBDIM,SLEN)
            IF (SLEN.GT.0) THEN             !we need more virtual memory...
               CALL XTNDW(SLEN)
               CALL R4READ(MADRID(WPNTR),DBUF,PIXELS,SUBDIM,SLEN)
            ENDIF
C
         ELSE
            CALL R4READ(MADRID(WPNTR),DBUF,PIXLS1,SUBDIM,SLEN)
            IF (SLEN.GT.0) THEN
               CALL XTNDW(SLEN)
               CALL
     +         R4READ(MADRID(WPNTR),DBUF,PIXLS1,SUBDIM,SLEN)
            ENDIF
            IF (N2.GT.0) THEN
               CALL R4READ(MADRID(WPNTR),DBUF,PIXLS2,SUBDIM,SLEN)
               IF (SLEN.GT.0) THEN
                  CALL XTNDW(SLEN)
                  CALL R4READ(MADRID(WPNTR),DBUF,PIXLS2,SUBDIM,SLEN)
               ENDIF
            ENDIF
            IF (N3.GT.0) THEN
               CALL R4READ(MADRID(WPNTR),DBUF,PIXLS3,SUBDIM,SLEN)
               IF (SLEN.GT.0) THEN
                  CALL XTNDW(SLEN)
                  CALL R4READ(MADRID(WPNTR),DBUF,PIXLS3,SUBDIM,SLEN)
               ENDIF
            ENDIF
            IF (N4.GT.0) THEN
               CALL R4READ(MADRID(WPNTR),DBUF,PIXLS4,SUBDIM,SLEN)
               IF (SLEN.GT.0) THEN
                  CALL XTNDW(SLEN)
                  CALL R4READ(MADRID(WPNTR),DBUF,PIXLS4,SUBDIM,SLEN)
               ENDIF
            ENDIF
            IF (N5.GT.0) THEN
               CALL R4READ(MADRID(WPNTR),DBUF,PIXLS5,SUBDIM,SLEN)
               IF (SLEN.GT.0) THEN
                  CALL XTNDW(SLEN)
                  CALL R4READ(MADRID(WPNTR),DBUF,PIXLS5,SUBDIM,SLEN)
               ENDIF
            ENDIF
         ENDIF
      ENDIF
      RETURN
C
C  write data
C
2000  CALL STKRDC('MID$IN',1,1,20,IAV,INPUTC,UNIT,NULLO,STAT)
      INSTRM = INPUTC(1:1)
      COPTIO(1) = 0
      COPTIO(3) = PRFLAG
C
      IF (INSTRM.NE.'F') THEN
         CALL STKRDC('INPUTC',1,1,80,IAV,INPUTC,UNIT,NULLO,STAT)
         CALL GENCNV(INPUTC,CVFLAG,40,IBUF,RBUF,DBUF,ACTVAL)
         IF (ACTVAL.LE.0) CALL STETER(1,'invalid data format...')      
         CALL STKRDC('P4',1,1,1,IAV,ALLFLG,UNIT,NULLO,STAT)
         IF ((ALLFLG.EQ.'A').OR.(ALLFLG.EQ.'a')) COPTIO(1) = 1
         COPTIO(2) = ACTVAL                !save max. input values
         CALL MAXDAT(RBUF,DBUF,ACTVAL)
      ELSE
C
C  get data from file used as input stream in MIDAS into temporary buffer
         CALL STFXMP(NOVAL,DATFMT,WPNTR2,STAT)
         CALL DATFIL(INPUTC(3:),CVFLAG,NOVAL,MADRID(WPNTR2),
     +               MADRID(WPNTR2),0,RBUF(1),RBUF(2))
         COPTIO(2) = NOVAL
         IF (CVFLAG.EQ.2) THEN
            CALL MAXDAT(MADRID(WPNTR2),DBUF,NOVAL)
         ELSE
            CALL MAXDAT(RBUF,MADRID(WPNTR2),NOVAL)
         ENDIF
      ENDIF
C
C  write a window
      IF (RWOPT.EQ.'W') THEN         
         IF(CVFLAG.EQ.2) THEN
            IF (INSTRM.NE.'F') THEN
               CALL R4WRIT(MADRID(WPNTR),PIXELS,RBUF,NOOUT,COPTIO,SLEN)
               IF (SLEN .GT. 0) THEN
                  CALL XTNDW(SLEN)
                  CALL R4WRIT(MADRID(WPNTR),PIXELS,RBUF,NOOUT,
     +                        COPTIO,SLEN)
               ENDIF
            ELSE
               CALL R4WRIT(MADRID(WPNTR),PIXELS,MADRID(WPNTR2),
     +                     NOOUT,COPTIO,SLEN)
               IF (SLEN .GT. 0) THEN
                  CALL XTNDW(SLEN)
                  CALL R4WRIT(MADRID(WPNTR),PIXELS,MADRID(WPNTR2),
     +                        NOOUT,COPTIO,SLEN)
               ENDIF
            ENDIF
         ELSE
            IF (INSTRM.NE.'F') THEN
               CALL R8WRIT(MADRID(WPNTR),PIXELS,DBUF,NOOUT,COPTIO,SLEN)
               IF (SLEN .GT. 0) THEN
                  CALL XTNDW(SLEN)
                  CALL R8WRIT(MADRID(WPNTR),PIXELS,DBUF,NOOUT,
     +                        COPTIO,SLEN)
               ENDIF
            ELSE
               CALL R8WRIT(MADRID(WPNTR),PIXELS,MADRID(WPNTR2),
     +                     NOOUT,COPTIO,SLEN)
               IF (SLEN .GT. 0) THEN
                  CALL XTNDW(SLEN)
                  CALL R8WRIT(MADRID(WPNTR),PIXELS,MADRID(WPNTR2),
     +                        NOOUT,COPTIO,SLEN)
               ENDIF
            ENDIF
         ENDIF
C
C  write sequentially
      ELSE
         IF(CVFLAG.EQ.2) THEN
            IF (INSTRM.NE.'F') THEN                 !data from command line
               NO = 0     
               CALL R4WRIT(MADRID(WPNTR),PIXLS1,RBUF,NOOUT,
     +                        COPTIO,SLEN)
               IF (SLEN .GT. 0) THEN
                  CALL XTNDW(SLEN)
                  CALL R4WRIT(MADRID(WPNTR),PIXLS1,RBUF,NOOUT,
     +                        COPTIO,SLEN)
               ENDIF
               IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               IF (N2.GT.0) THEN
                  CALL R4WRIT(MADRID(WPNTR),PIXLS2,RBUF(NO+1),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R4WRIT(MADRID(WPNTR),PIXLS2,RBUF(NO+1),NOOUT,
     +                           COPTIO,SLEN)
                  ENDIF
                  IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               ENDIF
               IF (N3.GT.0) THEN
                  CALL R4WRIT(MADRID(WPNTR),PIXLS3,RBUF(NO+1),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R4WRIT(MADRID(WPNTR),PIXLS3,RBUF(NO+1),NOOUT,
     +                           COPTIO,SLEN)
                  ENDIF
                  IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               ENDIF
               IF (N4.GT.0) THEN
                  CALL R4WRIT(MADRID(WPNTR),PIXLS4,RBUF(NO+1),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R4WRIT(MADRID(WPNTR),PIXLS4,RBUF(NO+1),NOOUT,
     +                           COPTIO,SLEN)
                  ENDIF
                  IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               ENDIF
               IF (N5.GT.0) THEN
                  CALL R4WRIT(MADRID(WPNTR),PIXLS5,RBUF(NO+1),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R4WRIT(MADRID(WPNTR),PIXLS5,RBUF(NO+1),NOOUT,
     +                           COPTIO,SLEN)
                  ENDIF
               ENDIF
C
            ELSE                                    !data come from file
               NO = 0                     
               WREST = WPNTR2              
               CALL R4WRIT(MADRID(WPNTR),PIXLS1,MADRID(WREST),NOOUT,
     +                     COPTIO,SLEN)
               IF (SLEN .GT. 0) THEN
                  CALL XTNDW(SLEN)
                  CALL R4WRIT(MADRID(WPNTR),PIXLS1,MADRID(WREST),NOOUT,
     +                        COPTIO,SLEN)
               ENDIF
               IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               IF (N2.GT.0) THEN
                  WREST = WPNTR2 + NO
                  CALL R4WRIT(MADRID(WPNTR),PIXLS2,MADRID(WREST),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R4WRIT(MADRID(WPNTR),PIXLS2,MADRID(WREST),
     +                           NOOUT,COPTIO,SLEN)
                  ENDIF
                  IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               ENDIF
               IF (N3.GT.0) THEN
                  WREST = WPNTR2 + NO
                  CALL R4WRIT(MADRID(WPNTR),PIXLS3,MADRID(WREST),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R4WRIT(MADRID(WPNTR),PIXLS3,MADRID(WREST),
     +                           NOOUT,COPTIO,SLEN)
                  ENDIF
                  IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               ENDIF
               IF (N4.GT.0) THEN
                  WREST = WPNTR2 + NO
                  CALL R4WRIT(MADRID(WPNTR),PIXLS4,MADRID(WREST),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R4WRIT(MADRID(WPNTR),PIXLS4,MADRID(WREST),
     +                           NOOUT,COPTIO,SLEN)
                  ENDIF
                  IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               ENDIF
               IF (N5.GT.0) THEN
                  WREST = WPNTR2 + NO
                  CALL R4WRIT(MADRID(WPNTR),PIXLS5,MADRID(WREST),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R4WRIT(MADRID(WPNTR),PIXLS5,MADRID(WREST),
     +                           NOOUT,COPTIO,SLEN)
                  ENDIF
               ENDIF
            ENDIF
C
C process double data
C 
         ELSE
            IF (INSTRM.NE.'F') THEN                 !data from command line
               NO = 0
               CALL R8WRIT(MADRID(WPNTR),PIXLS1,DBUF,NOOUT,COPTIO,
     +                     SLEN)
               IF (SLEN .GT. 0) THEN
                  CALL XTNDW(SLEN)
                  CALL R8WRIT(MADRID(WPNTR),PIXLS1,DBUF,NOOUT,COPTIO,
     +                        SLEN)
               ENDIF
               IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               IF (N2.GT.0) THEN
                  CALL R8WRIT(MADRID(WPNTR),PIXLS2,DBUF(NO+1),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R8WRIT(MADRID(WPNTR),PIXLS2,DBUF(NO+1),
     +                           NOOUT,COPTIO,SLEN)
                  ENDIF
                  IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               ENDIF
               IF (N3.GT.0) THEN
                  CALL R8WRIT(MADRID(WPNTR),PIXLS3,DBUF(NO+1),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R8WRIT(MADRID(WPNTR),PIXLS3,DBUF(NO+1),NOOUT,
     +                           COPTIO,SLEN)
                  ENDIF
                  IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               ENDIF
               IF (N4.GT.0) THEN
                  CALL R8WRIT(MADRID(WPNTR),PIXLS4,DBUF(NO+1),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R8WRIT(MADRID(WPNTR),PIXLS4,DBUF(NO+1),NOOUT,
     +                           COPTIO,SLEN)
                  ENDIF
                  IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               ENDIF
               IF (N5.GT.0) THEN
                  CALL R8WRIT(MADRID(WPNTR),PIXLS5,DBUF(NO+1),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R8WRIT(MADRID(WPNTR),PIXLS5,DBUF(NO+1),NOOUT,
     +                           COPTIO,SLEN)
                  ENDIF
               ENDIF
C
            ELSE                                    !data come from file
               NO = 0
               WREST = WPNTR2
               CALL R8WRIT(MADRID(WPNTR),PIXLS1,MADRID(WREST),NOOUT,
     +                     COPTIO,SLEN)
               IF (SLEN .GT. 0) THEN
                  CALL XTNDW(SLEN)
                  CALL R8WRIT(MADRID(WPNTR),PIXLS1,MADRID(WREST),NOOUT,
     +                        COPTIO,SLEN)
               ENDIF
               IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               IF (N2.GT.0) THEN
                  WREST = WPNTR2 + 2*NO              !double data...
                  CALL R8WRIT(MADRID(WPNTR),PIXLS2,MADRID(WREST),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R8WRIT(MADRID(WPNTR),PIXLS2,MADRID(WREST),
     +                           NOOUT,COPTIO,SLEN)
                  ENDIF
                  IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               ENDIF
               IF (N3.GT.0) THEN
                  WREST = WPNTR2 + 2*NO              !double data...
                  CALL R8WRIT(MADRID(WPNTR),PIXLS3,MADRID(WREST),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R8WRIT(MADRID(WPNTR),PIXLS3,MADRID(WREST),
     +                           NOOUT,COPTIO,SLEN)
                  ENDIF
                  IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               ENDIF
               IF (N4.GT.0) THEN
                  WREST = WPNTR2 + 2*NO              !double data...
                  CALL R8WRIT(MADRID(WPNTR),PIXLS4,MADRID(WREST),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R8WRIT(MADRID(WPNTR),PIXLS4,MADRID(WREST),
     +                           NOOUT,COPTIO,SLEN)
                  ENDIF
                  IF (COPTIO(1).EQ.0) NO = NO + NOOUT
               ENDIF
               IF (N5.GT.0) THEN
                  WREST = WPNTR2 + 2*NO              !double data...
                  CALL R8WRIT(MADRID(WPNTR),PIXLS5,MADRID(WREST),NOOUT,
     +                        COPTIO,SLEN)
                  IF (SLEN .GT. 0) THEN
                     CALL XTNDW(SLEN)
                     CALL R8WRIT(MADRID(WPNTR),PIXLS5,MADRID(WREST),
     +                           NOOUT,COPTIO,SLEN)
                  ENDIF
               ENDIF
            ENDIF
         ENDIF
      ENDIF
      RETURN
C
C  here for syntax errors from reading
9900  CALL STETER
     + (2,'invalid pixel specification - check syntax or dimensions')
      RETURN
C
      END

      SUBROUTINE DATATB(FRAME,START,STEP,AC,INPUTC,PRFLAG)
C 
C   AC(1:1) = W(rite) or R(ead)
C
      IMPLICIT NONE
C
      INTEGER      PRFLAG,COPTIO(3)
      INTEGER      N,COOCNT,COOMAX,COLMX
      INTEGER      IMNO,NAXIS,DATFMT,CVFLAG,MAXNO
      INTEGER*8    WPNTR
      INTEGER      IMNOW,MAPSIZ,NOHEAD
      INTEGER      STAT,NOOUT,FIRTIM,IBUF(1)
      INTEGER      NPIX(3),SUBDIM,SIZFLG
      INTEGER      PIXELS(3,2)
      INTEGER      TID,TABNUL(5),COLNUM(5)
      INTEGER      MADRID(1),IAV,UNIT(1),NULLO
C
      CHARACTER    FRAME*(*),INPUTC*(*),AC*(*)
      CHARACTER    OUTPUT*200
      CHARACTER    TABLE*80,TLABEL(6)*16
C
      DOUBLE PRECISION START(3),STEP(3)
      DOUBLE PRECISION DBUF(10),DCONST
      DOUBLE PRECISION DMIN,DMAX
C 
      REAL         RBUF(10),RCONST
      REAL         CUTS(4)
C 
      LOGICAL      SELFLG
C 
      INCLUDE  'MID_INCLUDE:ST_DEF.INC'
C 
      COMMON    /VMR/ MADRID
      COMMON    /SVCUTS/  CUTS,DMIN,DMAX
      COMMON    /WSPACE/  IMNOW,MAPSIZ,NOHEAD
      COMMON    /IMINFO/  IMNO,DATFMT,CVFLAG,MAXNO,NAXIS,NPIX
      COMMON    /ALLOC/  WPNTR
C
      DATA      PIXELS    /6*1/
      DATA      TLABEL
     +          /'XSTART ','YSTART ','XEND ','YEND ','VALUE1 ',
     +           'VALUE '/
C
      INCLUDE  'MID_INCLUDE:ST_DAT.INC'
C 
      COOCNT = 0
      SUBDIM = 2
      FIRTIM = 1
C 
C  subframes are input via table
C 
      CALL CLNTAB(INPUTC(1:60),TABLE,0)
      CALL TBTOPN(TABLE,F_I_MODE,TID,STAT)
      CALL TBIGET(TID,N,COOMAX,N,N,N,STAT)          !COOMAX total no. of rows
C 
      COPTIO(3) = PRFLAG
      DO 300, N=1,4
         CALL TBLSER(TID,TLABEL(N),COLNUM(N),STAT)
         IF (COLNUM(N).LE.0) THEN
            OUTPUT(1:) = 'column '//TLABEL(N)//
     +                   ' missing in table '//TABLE
            CALL STETER(9,OUTPUT)
         ENDIF
300   CONTINUE
C 
      COLMX = 4
      IF (AC(1:1).EQ.'W') THEN                      !check for column VALUE1
         CALL STKRDC('INPUTC',1,1,80,IAV,INPUTC,UNIT,NULLO,STAT)
         CALL GENCNV(INPUTC,4,1,IBUF,RBUF,DBUF,IAV)
C 
         IF (IAV.LE.0) THEN                        !no input data, try :VALUE1
            CALL TBLSER(TID,TLABEL(5),COLNUM(5),STAT)
            IF (COLNUM(5).GT.0) THEN
               COLMX = 5
            ELSE                                   !try :VALUE
               CALL TBLSER(TID,TLABEL(6),COLNUM(5),STAT)
               IF (COLNUM(5).GT.0) THEN
                  COLMX = 5
               ELSE
                  CALL STETER(11,'missing column :VALUE...')      
               ENDIF
            ENDIF
         ELSE
            IF (CVFLAG.EQ.2) THEN
               RCONST = RBUF(1)
            ELSE
               DCONST = DBUF(1)
            ENDIF
         ENDIF
      ENDIF
C
C  read from table
C
500   IF (COOCNT.GE.COOMAX) THEN
         CALL TBTCLO(TID,STAT)
         RETURN
      ENDIF

C
C  handle input from a table
      N = COOCNT + 1
      CALL TBSGET(TID,N,SELFLG,STAT)
C 
C  process selected rows
      IF (SELFLG) THEN
         CALL TBRRDR(TID,N,COLMX,COLNUM(1),RBUF,TABNUL,STAT)
         PIXELS(1,1) = NINT( (RBUF(1) - START(1)) / STEP(1) ) + 1
         IF ((PIXELS(1,1).LE.0) .OR.(PIXELS(1,1).GT.NPIX(1))) GOTO 9090
         PIXELS(1,2) = NINT( (RBUF(3) - START(1)) / STEP(1) ) + 1
         IF ((PIXELS(1,2).LE.0) .OR.(PIXELS(1,2).GT.NPIX(1))) GOTO 9090
         PIXELS(2,1) = NINT( (RBUF(2) - START(2)) / STEP(2) ) + 1
         IF ((PIXELS(2,1).LE.0) .OR.(PIXELS(2,1).GT.NPIX(2))) GOTO 9090
         PIXELS(2,2) = NINT( (RBUF(4) - START(2)) / STEP(2) ) + 1
         IF ((PIXELS(2,2).LE.0) .OR.(PIXELS(2,2).GT.NPIX(2))) GOTO 9090
C
C  read or print data
C
         IF (AC(1:1).NE.'W') THEN
            CALL R4READ(MADRID(WPNTR),DBUF,PIXELS,SUBDIM,SIZFLG)
            IF (SIZFLG.GT.0) THEN
               CALL XTNDW(SIZFLG)
               CALL R4READ(MADRID(WPNTR),DBUF,PIXELS,SUBDIM,
     +                     SIZFLG)
            ENDIF
C
C  write data
C
         ELSE
            IF (FIRTIM .EQ. 1) THEN
               FIRTIM = 0
               OUTPUT(1:) = '  frame pixels(x,y) '
               OUTPUT(23:) = 'world coords(x,y) '
               OUTPUT(45:) = 'value '
               CALL STTPUT(OUTPUT,STAT)
            ENDIF
C 
            RBUF(6) = PIXELS(1,1)
            RBUF(7) = PIXELS(2,1)
            IF (COLMX.EQ.5) THEN                   !value from table
               WRITE(OUTPUT,10005) 
     +               RBUF(6),RBUF(7),RBUF(1),RBUF(2),RBUF(5)
               IF (CVFLAG.EQ.2) THEN
                  RBUF(1) = RBUF(5)
               ELSE
                  DBUF(1) = DBLE(RBUF(5))
               ENDIF
            ELSE                                   !value from command line
               IF (CVFLAG.EQ.2) THEN
                  WRITE(OUTPUT,10005) 
     +                  RBUF(6),RBUF(7),RBUF(1),RBUF(2),RCONST
                  RBUF(1) = RCONST
               ELSE
                  WRITE(OUTPUT,10015) 
     +                  RBUF(6),RBUF(7),RBUF(1),RBUF(2),DCONST
                  DBUF(1) = DCONST
               ENDIF
            ENDIF
            CALL STTPUT(OUTPUT,STAT)
            RBUF(6) = PIXELS(1,2)
            RBUF(7) = PIXELS(2,2)
            WRITE(OUTPUT,10006) RBUF(6),RBUF(7),RBUF(3),RBUF(4)
            CALL STTPUT(OUTPUT,STAT)
            OUTPUT(1:) = ' '
            CALL STTPUT(OUTPUT,STAT)
C 
            COPTIO(1) = 1
            IF (CVFLAG.EQ.2) THEN                !single prec.
               IF (RBUF(1).LT.CUTS(3)) THEN
                  CUTS(3) = RBUF(1)
               ELSE IF (RBUF(1).GT.CUTS(4)) THEN
                  CUTS(4) = RBUF(1)
               ENDIF
            ELSE                                  !double prec.
               IF (DBUF(1).LT.DMIN) THEN
                  DMIN = DBUF(1)
               ELSE IF (DBUF(1).GT.DMAX) THEN
                  DMAX = DBUF(1)
               ENDIF
            ENDIF
            IF (CVFLAG.EQ.2) THEN                !single prec.
               CALL R4WRIT(MADRID(WPNTR),PIXELS,RBUF,NOOUT,COPTIO,
     +                     SIZFLG)
               IF (SIZFLG .GT. 0) THEN
                  CALL XTNDW(SIZFLG)
                  CALL R4WRIT(MADRID(WPNTR),PIXELS,RBUF,NOOUT,
     +                        COPTIO,SIZFLG)
               ENDIF
            ELSE
               CALL R8WRIT(MADRID(WPNTR),PIXELS,DBUF,NOOUT,COPTIO,
     +                     SIZFLG)
               IF (SIZFLG .GT. 0) THEN
                  CALL XTNDW(SIZFLG)
                  CALL R8WRIT(MADRID(WPNTR),PIXELS,DBUF,NOOUT,
     +                        COPTIO,SIZFLG)
               ENDIF
            ENDIF
         ENDIF
      ENDIF
C
      IF (CVFLAG.EQ.2) THEN                !single prec.
         DMIN = CUTS(3)
         DMAX = CUTS(4)
      ENDIF
C 
      COOCNT = COOCNT + 1
      GOTO 500
C
C  here for coordinates out of range 
9090  CALL STETER(3,'wrong coordinates in table ...')
      RETURN
C 
10005 FORMAT(2F8.1,4X,2G12.6,1X,G12.6)
10006 FORMAT(2F8.1,4X,2G12.6)
10015 FORMAT(2F8.1,4X,2G12.6,1X,G20.13)
      END

      SUBROUTINE DATACU(FRAME,SIZE,AC,PRFLAG)
C
      IMPLICIT NONE
C
      INTEGER      PRFLAG,ACTVAL,COPTIO(3)
      INTEGER      IMNO,NAXIS,NPIX(3),SIZE,IOFF,DATFMT
      INTEGER*8    WPNTR
      INTEGER      IMNOW,MAPSIZ,NOHEAD,CVFLAG,MAXNO
      INTEGER      IAV,COOCNT,COOMAX,COOFF
      INTEGER      STAT,LFLAGS(2),ST1,ST2,NOOUT
      INTEGER      FIRTIM,SIZFLG,IBUF(1)
      INTEGER      PIXELS(3,2),NOLIN,INPUTI(2)
      INTEGER      CHNL,XY1(2),XY2(2),WW(4)
      INTEGER      KPIX(2),COOS(4),XFIGU(5),YFIGU(5)
      INTEGER      UNIT(1),NULLO
      INTEGER      MADRID(1)
C
      CHARACTER    FRAME*(*),OUTPUT*200,COCO*8,STR*40
      CHARACTER    INPUTC*80,AC*4,CBUF*60
C
      DOUBLE PRECISION DBUF(10)
      DOUBLE PRECISION DMIN,DMAX
C 
      REAL         RBUF(10)
      REAL         PIXL1(6),PIXL2(6)
      REAL         TEMP(2)
      REAL         CUTS(4)
C 
      INCLUDE  'MID_INCLUDE:ST_DEF.INC'
C 
      INCLUDE  'MID_INCLUDE:IDIDEV.INC'
      INCLUDE  'MID_INCLUDE:IDIMEM.INC'
C 
      COMMON    /VMR/ MADRID
      COMMON    /SVCUTS/  CUTS,DMIN,DMAX
      COMMON    /WSPACE/  IMNOW,MAPSIZ,NOHEAD
      COMMON    /IMINFO/  IMNO,DATFMT,CVFLAG,MAXNO,NAXIS,NPIX
      COMMON    /ALLOC/  WPNTR
C
      DATA      PIXELS   /6*1/
      DATA      CHNL     /0/
      DATA      COOS     /-1,-1,-1,-1/
C
      INCLUDE  'MID_INCLUDE:ST_DAT.INC'
C 
      COOCNT = 0
      FIRTIM = 1
      NOLIN = 1
      LFLAGS(1) = -99                        !indicate main display window
      LFLAGS(2) = D_R4_FORMAT                !we opened frame as R*4
C 
      CALL STKRDI('INPUTI',1,2,IAV,INPUTI,UNIT,NULLO,STAT)
      IF (INPUTI(1).EQ.0) THEN
         OUTPUT(1:) = 'press ENTER to '
      ELSE
         OUTPUT(1:) = 'move Cursor to '
      ENDIF
      IOFF = 16
      IF (AC(1:1).NE.'W') THEN
         OUTPUT(IOFF:) = 'read '
         IOFF = 21
      ELSE
         OUTPUT(IOFF:) = 'write '
         IOFF = 22
      ENDIF
      CVFLAG = 2                             !always set to single float
C
C  get Image Display unit + attach it, get max. coord readings
      CALL DTOPEN(1,STAT)
      CBUF(1:) = ' '
      CALL STKRDI('CURSOR',1,1,IAV,COOMAX,UNIT,NULLO,STAT)
      IF (AC(3:3).EQ.'2') THEN
         CALL SETCUR(QDSPNO,2,1,2,COOS,STAT)
         OUTPUT(IOFF:) = 'pixels inside cursor window '
      ELSE
         CALL SETCUR(QDSPNO,0,3,2,COOS,STAT)
         IF (AC(3:3).EQ.'1') THEN
            OUTPUT(IOFF:) = 'pixel with cursor '
         ELSE
            NOLIN = INPUTI(2)
            IF (NOLIN.LT.1) NOLIN = 1
            NOLIN = NOLIN/2
            ST2 = 2*NOLIN + 1           !make sure it's odd no. of lines
            SIZFLG = ST2*NPIX(1)        !we have a fixed window
            IF (SIZFLG.GT.MAPSIZ)
     +         CALL XTNDW(SIZFLG)       !extend if necessary
            OUTPUT(IOFF:) = '5*'
            WRITE(STR,10007) ST2
            ST1 = 1
            IF (STR(1:1).EQ.' ') THEN
               IF (STR(2:2).EQ.' ') THEN
                  ST1 = 3
               ELSE
                  ST1 = 2
               ENDIF
            ENDIF
            OUTPUT(IOFF+2:) = STR(ST1:)
         ENDIF
      ENDIF
      CALL STTDIS(OUTPUT,0,STAT)
      IF (INPUTI(1).EQ.0) THEN
         COCO(1:) = 'NNYY?C0 '                !wait for ENTER button
      ELSE
         COCO(1:) = 'NNYZ?C0 '                !get cursor coord continuously
      ENDIF
C 
      IF (AC(1:1).EQ.'W') THEN
         CALL STKRDC('INPUTC',1,1,80,IAV,INPUTC,UNIT,NULLO,STAT)
         CALL GENCNV(INPUTC,CVFLAG,1,IBUF,RBUF,DBUF,ACTVAL)
         IF (ACTVAL.LE.0) CALL STETER(1,'invalid data format...')      
         COPTIO(1) = 1
         COPTIO(3) = PRFLAG
         IF (CVFLAG.EQ.2) THEN
            IF (RBUF(1).LT.CUTS(3)) THEN
               CUTS(3) = RBUF(1)
            ELSE IF (RBUF(1).GT.CUTS(4)) THEN
               CUTS(4) = RBUF(1)
            ENDIF
            DMIN = CUTS(3)
            DMAX = CUTS(4)
         ELSE
            IF (DBUF(1).LT.DMIN) THEN
               DMIN = DBUF(1)
            ELSE IF (DBUF(1).GT.DMAX) THEN
               DMAX = DBUF(1)
            ENDIF
         ENDIF
      ENDIF
      COOFF = 0
C
C  read cursor positions
C
500   IF (COOCNT.GE.COOMAX) GOTO 9000
      CALL GETCUR(COCO,CBUF,
     +            XY1,PIXL1(3),PIXL1(5),RBUF(10),ST1,
     +            XY2,PIXL2(3),PIXL2(5),RBUF(10),ST2)
C
C  if cursors are not switched on initially, display info message
      IF ((ST1.EQ.0).AND.(ST2.EQ.0)) THEN
         IF ((COOCNT.EQ.0) .AND. (COOFF.EQ.0)) THEN
            CBUF(1:) = ' '                    !reinitialize in GETCUR
            CALL STTPUT
     +      ('switch cursor(s) on - next time we exit...',STAT)
            COOFF = 1
            GOTO 500
         ELSE
            IF ((AC(3:3).EQ.'C').AND.(FIRTIM.NE.1))
     +         CALL IIGPLY(QDSPNO,QOVCH,XFIGU,YFIGU,5,99,1,STAT)
            IF (AC(1:1).NE.'W') 
     +         CALL R4CNTR(MADRID(WPNTR),PIXELS,'X',SIZFLG)
            GOTO 9000
         ENDIF
      ELSE
         COOCNT = COOCNT + 1
      ENDIF
C 
      IF (AC(3:3) .EQ. 'C') THEN 
         IF (FIRTIM.NE.1)
     +      CALL IIGPLY(QDSPNO,QOVCH,XFIGU,YFIGU,5,99,1,STAT)
      ENDIF
      FIRTIM = 0
      ST1 = PIXL1(3)
      ST2 = PIXL1(4)
      IF (AC(3:3) .EQ. 'C') THEN 
         PIXELS(1,1) = ST1 - 2
         IF (PIXELS(1,1).LT.1) PIXELS(1,1) = 1
         PIXELS(2,1) = ST2 - NOLIN
         IF (PIXELS(2,1).LT.1) PIXELS(2,1) = 1
         PIXELS(1,2) = ST1 + 2
         IF (PIXELS(1,2).GT.NPIX(1)) PIXELS(1,2) = NPIX(1)
         PIXELS(2,2) = ST2 + NOLIN
         IF (PIXELS(2,2).GT.NPIX(2)) PIXELS(2,2) = NPIX(2)
      ENDIF
C 
      IF (AC(1:1).EQ.'W') THEN
         IF (AC(3:3).EQ.'1') THEN
            WRITE(OUTPUT,10004) ST1,ST2
         ELSEIF (AC(3:3).EQ.'C') THEN
            WRITE(OUTPUT,10005) 
     +            PIXELS(1,1),PIXELS(2,1),PIXELS(1,2),PIXELS(2,2)
         ELSE
            WW(1) = PIXL2(3)
            WW(2) = PIXL2(4)
            WRITE(OUTPUT,10005) ST1,ST2,WW(1),WW(2)
         ENDIF
         CALL STTPUT(OUTPUT,STAT)
      ENDIF
C 
C  setup boundaries of data window
      IF (AC(3:3) .EQ. '1') THEN
         PIXELS(1,1) = ST1                  !1 cursor, single pixel
         PIXELS(2,1) = ST2
         PIXELS(1,2) = ST1
         PIXELS(2,2) = ST2
         XFIGU(1) = XY1(1)
         YFIGU(2) = XY1(2)
      ELSEIF (AC(3:3) .EQ. 'C') THEN        !1 cursor, 5*NOLIN pixel window
         IF (SCALX .LT. 0) THEN
            IAV = 2 * (-SCALX)
         ELSEIF (SCALX .GT. 1) THEN
            IAV = 2 / SCALX
         ELSE 
            IAV = 2
         ENDIF
         COOS(1) = XY1(1) - IAV
         COOS(3) = XY1(1) + IAV
         IF (SCALY .LT. 0) THEN
            IAV = NOLIN * (-SCALX)
         ELSEIF (SCALY .GT. 1) THEN
            IAV = NOLIN / SCALX
         ELSE 
            IAV = NOLIN
         ENDIF
         COOS(2) = XY1(2) - IAV
         COOS(4) = XY1(2) + IAV
         TEMP(1) = -1.0
         TEMP(1) = -1.0
         CALL BLDGRA('REC',COOS,TEMP,XFIGU,YFIGU,5,IAV)
      ELSE
         PIXELS(1,1) = ST1                  !2 cursors => pixel window
         PIXELS(2,1) = ST2
         PIXELS(1,2) = PIXL2(3)  
         PIXELS(2,2) = PIXL2(4)
         XFIGU(1) = XY1(1)
         YFIGU(2) = XY1(2)
      ENDIF
C
C  read or print data
C
      IF (AC(1:1).NE.'W') THEN
         IF (AC(3:3) .EQ. 'C') 
     +      CALL IIGPLY(QDSPNO,QOVCH,XFIGU,YFIGU,5,99,1,STAT)
         CALL R4CNTR(MADRID(WPNTR),PIXELS,AC(3:3),SIZFLG)
         IF (SIZFLG.GT.0) THEN
            CALL XTNDW(SIZFLG)
            CALL R4CNTR(MADRID(WPNTR),PIXELS,AC(3:3),SIZFLG)
         ENDIF
         FIRTIM = 0
C
C  write data
C
      ELSE
         CALL R4WRIT(MADRID(WPNTR),PIXELS,RBUF,NOOUT,COPTIO,SIZFLG)
         IF (SIZFLG .GT. 0) THEN
            CALL XTNDW(SIZFLG)
            CALL R4WRIT(MADRID(WPNTR),PIXELS,RBUF,NOOUT,COPTIO,SIZFLG)
         ENDIF
         KPIX(1) = PIXELS(1,2) - PIXELS(1,1) + 1
         KPIX(2) = PIXELS(2,2) - PIXELS(2,1) + 1
         XY2(1) = PIXELS(1,1)
         XY2(2) = PIXELS(2,1)
         WW(1) = XFIGU(1)
         WW(2) = YFIGU(1)
         WW(3) = SCALX
         WW(4) = SCALY
         IF (CVFLAG.EQ.2)                         !not for double data
     +      CALL LOADWN(LFLAGS,IMNO,NPIX,XY2,KPIX,WW,CUTS)
         IF (AC(3:3) .EQ. 'C') 
     +      CALL IIGPLY(QDSPNO,QOVCH,XFIGU,YFIGU,5,99,1,STAT)
      ENDIF
      GOTO 500
C
9000  CALL DTCLOS(QDSPNO)
      RETURN
C 
10004 FORMAT('frame pixels(x,y): ',I6,',',I6)
10005 FORMAT('frame pixels(x,y): ',I6,',',I6,' to: ',I6,',',I6)
10006 FORMAT('central line =',I6,', central pixel = ',I6)
10007 FORMAT(I3,' pixel window around cursor ')
      END

      SUBROUTINE XTNDW(SIZFLG)
C
      IMPLICIT NONE
C
      INTEGER      NAXIS,NPIX(3)
      INTEGER      SIZFLG,IMNO,DATFMT,CVFLAG,MAXNO
      INTEGER*8    WPNTR
      INTEGER      STAT,IAV,IMNOW,MAPSIZ,NOHEAD
C
      INCLUDE  'MID_INCLUDE:ST_DEF.INC'
C
      COMMON    /WSPACE/  IMNOW,MAPSIZ,NOHEAD
      COMMON    /IMINFO/  IMNO,DATFMT,CVFLAG,MAXNO,NAXIS,NPIX
      COMMON    /ALLOC/  WPNTR
C
      INCLUDE  'MID_INCLUDE:ST_DAT.INC'
C
      CALL STFCLO(IMNOW,STAT)
      MAPSIZ = SIZFLG
      CALL STFCRE('wworrkfr',DATFMT,F_X_MODE,F_IMA_TYPE,
     +            MAPSIZ,IMNOW,STAT)
      CALL STFMAP(IMNOW,F_X_MODE,1,MAPSIZ,IAV,WPNTR,STAT)
C 
      RETURN
      END

      SUBROUTINE R4CNTR(ARRAY,PIX,FLAG,SIZFLG)
C
      IMPLICIT NONE
C
      INTEGER      IMNO,NAXIS,PIX(3,2),NPIX(3),SIZFLG,DATFMT,CVFLAG
      INTEGER      HIX,LOWX,HIY,LOWY,CNTY,LOWZ,N,NN,NNN,NX,NY,NZ
      INTEGER      LINBEG,K,M,OFF,STAT
      INTEGER      IMNOW,MAPSIZ,NOHEAD,MAXNO
C
      REAL         ARRAY(*)
      REAL         TEMP(5)
C
      CHARACTER    FLAG*1
      CHARACTER*80 OUTPUT
C 
      COMMON    /WSPACE/  IMNOW,MAPSIZ,NOHEAD
      COMMON    /IMINFO/  IMNO,DATFMT,CVFLAG,MAXNO,NAXIS,NPIX
C
C  init + setup bounds
      NX = PIX(1,2) - PIX(1,1) + 1
      NY = PIX(2,2) - PIX(2,1) + 1
      NZ = PIX(3,2) - PIX(3,1) + 1
      LOWX = PIX(1,1)
      HIX = LOWX + NX - 1
      LOWY = PIX(2,1)
      CNTY = LOWY + NY/2
      LOWZ = PIX(3,1)
      HIY = LOWY + NY - 1
C 
C  check for cleanup 
      IF (FLAG.EQ.'X') THEN
         IF (NX.GT.20) NX = 20
         OFF = 0                                   !just set it to something...
         CALL STKWRR('OUTPUTR',ARRAY,1,NX,OFF,STAT)
         RETURN
      ENDIF
C
C  total size we have to read in
      NNN = NY*NPIX(1) + (NZ-1)*NPIX(1)*NPIX(2)
      IF (NNN.GT.MAPSIZ) THEN
         SIZFLG = NNN
         RETURN
      ELSE
         SIZFLG = 0
      ENDIF
C
      IF (FLAG.EQ.'1') THEN
         WRITE(OUTPUT,10001) HIY,HIX
      ELSE
         WRITE(OUTPUT,10002) HIY,LOWY,LOWX,HIX
      ENDIF
      CALL STTPUT(OUTPUT,STAT)
C 
      OFF = LOWX + (LOWY-1)*NPIX(1) + (LOWZ-1)*NPIX(1)*NPIX(2)
      CALL STFGET(IMNO,OFF,NNN,K,ARRAY,STAT)
      IF (FLAG.EQ.'C') THEN
         GOTO 2000
      ELSEIF (FLAG.EQ.'1') THEN
         WRITE(OUTPUT,10003) ARRAY(1)
         CALL STTPUT(OUTPUT,STAT)
         RETURN
      ENDIF
C
C  display contents of 2-dim ARRAY
      OFF = (NY-1) * NPIX(1)
      IF (NX.GT.5) THEN
         NNN = 1
      ELSE
         NNN = 0
      ENDIF
      DO 1200, NN=HIY,LOWY,-1
         K = 0
         LINBEG = NNN
         DO 1100, N=1,NX
            K = K + 1
            TEMP(K) = ARRAY(OFF+N)
            IF (K.EQ.5) THEN
               IF (LINBEG.EQ.1) THEN
                  WRITE(OUTPUT,10004) (TEMP(M),M=1,5)
                  LINBEG = 0
               ELSE
                  WRITE(OUTPUT,10000) (TEMP(M),M=1,5)
               ENDIF
               CALL STTPUT(OUTPUT,STAT)
               K = 0
            ENDIF
1100     CONTINUE
         IF (K.GT.0) THEN
            WRITE(OUTPUT,10000) (TEMP(M),M=1,K)
            CALL STTPUT(OUTPUT,STAT)
            K = 0
         ENDIF
         OFF = OFF - NPIX(1)
1200  CONTINUE
      RETURN
C 
C  display contents of 2-dim ARRAY
2000  OFF = (NY-1) * NPIX(1)
      DO 2200, NN=HIY,CNTY+1,-1
         DO 2100, N=1,5
            TEMP(N) = ARRAY(OFF+N)
2100     CONTINUE
         WRITE(OUTPUT,10000) (TEMP(K),K=1,5)
         CALL STTPUT(OUTPUT,STAT)
         OFF = OFF - NPIX(1)
2200  CONTINUE
C 
      DO 2500, N=1,5                      !handle central line
         TEMP(N) = ARRAY(OFF+N)
2500  CONTINUE
      WRITE(OUTPUT,10010) (TEMP(K),K=1,5)
      CALL STTPUT(OUTPUT,STAT)
      OFF = OFF - NPIX(1)
C 
      DO 3200, NN=CNTY-1,LOWY,-1
         DO 3100, N=1,5
            TEMP(N) = ARRAY(OFF+N)
3100     CONTINUE
         WRITE(OUTPUT,10000) (TEMP(K),K=1,5)
         CALL STTPUT(OUTPUT,STAT)
         OFF = OFF - NPIX(1)
3200  CONTINUE
      RETURN
C 
10000 FORMAT(5G15.7)
10001 FORMAT('line',I5,', pixel',I5)
10002 FORMAT('line',I5,' -> ',I4,',   pixels',I5,' -> ',I4)
10003 FORMAT(G15.7)
10004 FORMAT('>',G14.7,4G15.7)
10010 FORMAT(2G15.7,'>',G14.7,'<',G14.7,G15.7)
      END

      SUBROUTINE R4READ(ARRAY,DARRAY,PIX,SUBDIM,SIZFLG)
C
      IMPLICIT NONE
C
      INTEGER      IMNO,NAXIS,SUBDIM,SIZFLG,DATFMT,CVFLAG
      INTEGER      PIX(3,2),NPIX(3)
      INTEGER      HIX,K,LOWX,LOWY,LOWZ,N,NN,NNN,NX,NY,NZ
      INTEGER      OFF,OFF1,STAT,MAXNO
      INTEGER      IFIRST,UNIT(1)
      INTEGER      IMNOW,MAPSIZ,NOHEAD
C
      REAL         ARRAY(*),TEMP(20),FIRST(25)
C
      DOUBLE PRECISION DARRAY(*),DTEMP(20),DFIRST(25)
C
      CHARACTER*200 OUTPUT
C 
      COMMON    /WSPACE/  IMNOW,MAPSIZ,NOHEAD
      COMMON    /IMINFO/  IMNO,DATFMT,CVFLAG,MAXNO,NAXIS,NPIX
C
C  init + setup bounds
      NX = PIX(1,2) - PIX(1,1) + 1
      NY = PIX(2,2) - PIX(2,1) + 1
      NZ = PIX(3,2) - PIX(3,1) + 1
      LOWX = PIX(1,1)
      HIX = LOWX + NX - 1
      LOWY = PIX(2,1)
      LOWZ = PIX(3,1)
C 
C  total size we have to read in
      NNN = NY*NPIX(1) + (NZ-1)*NPIX(1)*NPIX(2)
      IF (NNN.GT.MAPSIZ) THEN
         SIZFLG = NNN
         RETURN
      ELSE
         SIZFLG = 0
      ENDIF
C 
      OFF = (LOWX-1) + (LOWY-1)*NPIX(1) + (LOWZ-1)*NPIX(1)*NPIX(2)
      IF (CVFLAG.EQ.4) THEN                     !double prec. data
         CALL STFGET(IMNO,OFF+1,NNN,IFIRST,DARRAY,STAT)
      ELSE
         CALL STFGET(IMNO,OFF+1,NNN,IFIRST,ARRAY,STAT)
      ENDIF
      IFIRST = 1                                !reset IFIRST
C
C  branch according to dimension of subframe
      GOTO (1000,2000,3000),SUBDIM
C
C  display contents of 1-dim ARRAY
1000  IF (NOHEAD.EQ.0) THEN
         IF (HIX .GT. LOWX) THEN
            WRITE(OUTPUT,10021) LOWX,HIX
         ELSE
            WRITE(OUTPUT,10022) LOWX
         ENDIF
         CALL STTPUT(OUTPUT,STAT)
      ENDIF
      K = 0
      IF (CVFLAG.EQ.2) THEN
         DO 1100, N=1,NX
            K = K + 1
            TEMP(K) = ARRAY(N)
            IF (K.EQ.MAXNO) CALL R4WROU(TEMP,K,FIRST,IFIRST)
1100     CONTINUE
         IF (K.GT.0) CALL R4WROU(TEMP,K,FIRST,IFIRST)
      ELSE
         DO 1200, N=1,NX
            K = K + 1
            DTEMP(K) = DARRAY(N)
            IF (K.EQ.MAXNO) CALL R8WROU(DTEMP,K,DFIRST,IFIRST)
1200     CONTINUE
         IF (K.GT.0) CALL R8WROU(DTEMP,K,DFIRST,IFIRST)
      ENDIF
      GOTO 5000
C
C  display contents of 2-dim ARRAY
2000  OFF = 0
      DO 2200, NN=1,NY
         IF (NOHEAD.EQ.0) THEN
            IF (HIX .GT. LOWX) THEN
               WRITE(OUTPUT,10011) LOWY,LOWX,HIX
            ELSE
               WRITE(OUTPUT,10012) LOWY,LOWX
            ENDIF
            CALL STTPUT(OUTPUT,STAT)
         ENDIF
         K = 0
         IF (CVFLAG.EQ.2) THEN
            DO 2100, N=1,NX
               K = K + 1
               TEMP(K) = ARRAY(OFF+N)
               IF (K.EQ.MAXNO) CALL R4WROU(TEMP,K,FIRST,IFIRST)
2100        CONTINUE
            IF (K.GT.0) CALL R4WROU(TEMP,K,FIRST,IFIRST)
         ELSE
            DO 2120, N=1,NX
               K = K + 1
               DTEMP(K) = DARRAY(N)
               IF (K.EQ.MAXNO) CALL R8WROU(DTEMP,K,DFIRST,IFIRST)
2120        CONTINUE
            IF (K.GT.0) CALL R8WROU(DTEMP,K,DFIRST,IFIRST)
         ENDIF
         OFF = OFF + NPIX(1)
         LOWY = LOWY + 1
2200  CONTINUE
      GOTO 5000
C
C  display contents of 3-dim ARRAY
3000  OFF1 = 0
      DO 3300, NNN=1,NZ
         OFF = OFF1
         DO 3200, NN=1,NY
            IF (NOHEAD.EQ.0) THEN
               WRITE(OUTPUT,10001) LOWZ,LOWY,LOWX,HIX
               CALL STTPUT(OUTPUT,STAT)
            ENDIF
            K = 0
            IF (CVFLAG.EQ.2) THEN
               DO 3100, N=1,NX
                  K = K + 1
                  TEMP(K) = ARRAY(OFF+N)
                  IF (K.EQ.MAXNO) CALL R4WROU(TEMP,K,FIRST,IFIRST)
3100           CONTINUE
               IF (K.GT.0) CALL R4WROU(TEMP,K,FIRST,IFIRST)
            ELSE
               DO 3120, N=1,NX
                  K = K + 1
                  DTEMP(K) = DARRAY(N)
                  IF (K.EQ.MAXNO) CALL R8WROU(DTEMP,K,DFIRST,IFIRST)
3120           CONTINUE
               IF (K.GT.0) CALL R8WROU(DTEMP,K,DFIRST,IFIRST)
            ENDIF
            OFF = OFF + NPIX(1)
            LOWY = LOWY + 1
3200     CONTINUE
         OFF1 = OFF1 + NPIX(1)*NPIX(2)
         LOWZ = LOWZ + 1
3300  CONTINUE
C
C  save first 20 values in keyword OUTPUTR or OUTPUTD
5000  IFIRST = IFIRST - 1
      IF (IFIRST.GT.20) IFIRST = 20
      IF (IFIRST.GT.0) THEN
         IF (CVFLAG.EQ.2) THEN
            CALL STKWRR('OUTPUTR',FIRST,1,IFIRST,UNIT,STAT)
         ELSE
            DO 5500, N=1,IFIRST          !for backwards compatibility...
               FIRST(N) = REAL(DFIRST(N))
5500        CONTINUE
            CALL STKWRR('OUTPUTR',FIRST,1,IFIRST,UNIT,STAT)
            CALL STKWRD('OUTPUTD',DFIRST,1,IFIRST,UNIT,STAT)
         ENDIF
      ENDIF
      RETURN
C
10001      FORMAT('plane =',I6,', line =',I6,', 1.pixel =',I6,
     +             ', last pixel =',I6)
10011      FORMAT('line =',I6,', 1.pixel =',I6,', last pixel =',I6)
10012      FORMAT('line =',I6,', pixel =',I6,'              ')
10021      FORMAT('1.pixel =',I6,', last pixel =',I6)
10022      FORMAT('pixel =',I6,'              ')
      END

      SUBROUTINE R4WROU(TEMP,LIM,FIRST,IFIRST)
C
      IMPLICIT NONE
C
      INTEGER      LIM,IFIRST                  !LIM is max. = 20
      INTEGER      STAT,M
C
      REAL         TEMP(*),FIRST(*)
C
      CHARACTER    OUTPUT*200
C 
      IF (IFIRST.LE.20) THEN
         DO 100, M=1,LIM
            FIRST(IFIRST) = TEMP(M)
            IFIRST = IFIRST + 1
100      CONTINUE
      ENDIF
C
C  reset counter
      WRITE(OUTPUT,10000) (TEMP(M),M=1,LIM)
      CALL STTPUT(OUTPUT,STAT)
      LIM = 0  
C
      RETURN
C
10000 FORMAT(20G15.7)
      END

      SUBROUTINE R8WROU(TEMP,LIM,FIRST,IFIRST)
C
      IMPLICIT NONE
C
      INTEGER      LIM,IFIRST                  !LIM is max. = 20
      INTEGER      STAT,M
C
      DOUBLE PRECISION TEMP(*),FIRST(*)
C
      CHARACTER    OUTPUT*200
C
      IF (IFIRST.LE.20) THEN
         DO 100, M=1,LIM
            FIRST(IFIRST) = TEMP(M)
            IFIRST = IFIRST + 1
100      CONTINUE
      ENDIF
C
C  reset counter
      WRITE(OUTPUT,10000) (TEMP(M),M=1,LIM)
      CALL STTPUT(OUTPUT,STAT)
      LIM = 0 
C
      RETURN
C
10000 FORMAT(20G24.14)
      END

      SUBROUTINE R4WRIT(ARRAY,PIX,DATAS,NOVAL,COPTIO,TOTSIZ)
C
C  COPTIO		(1) = 1 or 0, if ALL or not ALL
C  			(2) = actual no. of data values given
C  			(3) = 1 or 0, if ADD or not ADD
C
      IMPLICIT NONE
C
      INTEGER      IMNO,NAXIS,NPIX(3),DATFMT,CVFLAG,MAXNO
      INTEGER      NOVAL,COPTIO(3),TOTSIZ
      INTEGER      PIX(3,2)
      INTEGER      K,N,NN,NNN,NX,NY,NZ,STAT
      INTEGER      OFFSET,OFF,OFF1,LOWX,LOWY,LOWZ
      INTEGER      IMNOW,MAPSIZ,NOHEAD
C
      REAL         ARRAY(*),DATAS(*)
      REAL         RR,RCONST
      REAL         CUTS(4)
C 
      DOUBLE PRECISION DMIN,DMAX
C 
      COMMON    /SVCUTS/  CUTS,DMIN,DMAX
      COMMON    /WSPACE/  IMNOW,MAPSIZ,NOHEAD
      COMMON    /IMINFO/  IMNO,DATFMT,CVFLAG,MAXNO,NAXIS,NPIX
C 
C  init + setup bounds
      NX = PIX(1,2) - PIX(1,1) + 1
      NY = PIX(2,2) - PIX(2,1) + 1
      NZ = PIX(3,2) - PIX(3,1) + 1
      OFF1 = 0
      LOWX = PIX(1,1)
      LOWY = PIX(2,1)
      LOWZ = PIX(3,1)
C 
C  total size we have to write out
      TOTSIZ = NX + (NY-1)*NPIX(1) + (NZ-1)*NPIX(1)*NPIX(2)
      IF (TOTSIZ.GT.MAPSIZ) RETURN            !tell caller we need more memory
C 
      OFFSET = (LOWX-1) + (LOWY-1)*NPIX(1) + (LOWZ-1)*NPIX(1)*NPIX(2)
      OFFSET = OFFSET + 1                     !point to first pixel
      CALL STFGET(IMNO,OFFSET,TOTSIZ,N,ARRAY,STAT)
C
C  branch according to constant option
      IF (COPTIO(1).NE.0) GOTO 1000
C  
      K = 0
      IF (COPTIO(3).EQ.0) THEN                 !store, add or multiply data
C
C  write contents of ARRAY (up to 3 dimensions)
         DO 300, NNN=1,NZ
            OFF = OFF1
            DO 200, NN=1,NY
               DO 100, N=1,NX
                  K = K + 1
                  RR = DATAS(K)
                  ARRAY(OFF+N) = RR
                  IF (RR.LT.CUTS(3)) THEN             !check min + max
                     CUTS(3) = RR
                  ELSE IF (RR.GT.CUTS(4)) THEN
                     CUTS(4) = RR
                  ENDIF
                  IF (K.EQ.COPTIO(2)) GOTO 2000
100            CONTINUE
               OFF = OFF + NPIX(1)
200         CONTINUE
            OFF1 = OFF1 + NPIX(1)*NPIX(2)
300      CONTINUE
C 
      ELSE IF (COPTIO(3).EQ.1) THEN
C
         DO 600, NNN=1,NZ
            OFF = OFF1
            DO 500, NN=1,NY
               DO 400, N=1,NX
                  K = K + 1
                  RR = ARRAY(OFF+N) + DATAS(K)
                  ARRAY(OFF+N) = RR
                  IF (RR.LT.CUTS(3)) THEN             !check min + max
                     CUTS(3) = RR
                  ELSE IF (RR.GT.CUTS(4)) THEN
                     CUTS(4) = RR
                  ENDIF
                  IF (K.EQ.COPTIO(2)) GOTO 2000
400            CONTINUE
               OFF = OFF + NPIX(1)
500         CONTINUE
            OFF1 = OFF1 + NPIX(1)*NPIX(2)
600      CONTINUE
C
      ELSE 
C
         DO 900, NNN=1,NZ
            OFF = OFF1
            DO 800, NN=1,NY
               DO 700, N=1,NX
                  K = K + 1
                  RR = ARRAY(OFF+N) * DATAS(K)
                  ARRAY(OFF+N) = RR
                  IF (RR.LT.CUTS(3)) THEN             !check min + max
                     CUTS(3) = RR
                  ELSE IF (RR.GT.CUTS(4)) THEN
                     CUTS(4) = RR
                  ENDIF
                  IF (K.EQ.COPTIO(2)) GOTO 2000
700            CONTINUE
               OFF = OFF + NPIX(1)
800         CONTINUE
            OFF1 = OFF1 + NPIX(1)*NPIX(2)
900      CONTINUE
      ENDIF
C
      GOTO 2000
C
C  fill contents of ARRAY (up to 3 dimensions) with constant
1000  RCONST = DATAS(1)
      K = NZ * NY * NX
      IF (COPTIO(3).EQ.0) THEN
         DO 1300, NNN=1,NZ
            OFF = OFF1
            DO 1200, NN=1,NY
               DO 1100, N=1,NX
                  ARRAY(OFF+N) = RCONST
1100           CONTINUE
               OFF = OFF + NPIX(1)
1200        CONTINUE
            OFF1 = OFF1 + NPIX(1)*NPIX(2)
1300     CONTINUE
C 
         IF (RCONST.LT.CUTS(3)) THEN                  !check min + max
            CUTS(3) = RCONST
         ELSE IF (RCONST.GT.CUTS(4)) THEN
            CUTS(4) = RCONST
         ENDIF
C 
      ELSE IF (COPTIO(3).EQ.1) THEN
         DO 1600, NNN=1,NZ
            OFF = OFF1
            DO 1500, NN=1,NY
               DO 1400, N=1,NX
                  RR = ARRAY(OFF+N) + RCONST
                  ARRAY(OFF+N) = RR
                  IF (RR.LT.CUTS(3)) THEN             !check min + max
                     CUTS(3) = RR
                  ELSE IF (RR.GT.CUTS(4)) THEN
                     CUTS(4) = RR
                  ENDIF
1400           CONTINUE
               OFF = OFF + NPIX(1)
1500        CONTINUE
            OFF1 = OFF1 + NPIX(1)*NPIX(2)
1600     CONTINUE
C 
      ELSE 
         DO 1900, NNN=1,NZ
            OFF = OFF1
            DO 1800, NN=1,NY
               DO 1700, N=1,NX
                  RR = ARRAY(OFF+N) * RCONST
                  ARRAY(OFF+N) = RR
                  IF (RR.LT.CUTS(3)) THEN             !check min + max
                     CUTS(3) = RR
                  ELSE IF (RR.GT.CUTS(4)) THEN
                     CUTS(4) = RR
                  ENDIF
1700           CONTINUE
               OFF = OFF + NPIX(1)
1800        CONTINUE
            OFF1 = OFF1 + NPIX(1)*NPIX(2)
1900     CONTINUE
      ENDIF
C 
C 
2000  DMIN = CUTS(3)
      DMAX = CUTS(4)
      NOVAL = K
      CALL STFPUT(IMNO,OFFSET,TOTSIZ,ARRAY,STAT)
      TOTSIZ = 0
      RETURN
C
      END

      SUBROUTINE R8WRIT(ARRAY,PIX,DATAS,NOVAL,COPTIO,TOTSIZ)
C
C  COPTIO               (1) = 1 or 0, if ALL or not ALL
C                       (2) = actual no. of data values given
C                       (3) = 1 or 0, if ADD or not ADD
C
      IMPLICIT NONE
C
      INTEGER      IMNO,NAXIS,NPIX(3),DATFMT,CVFLAG,MAXNO
      INTEGER      NOVAL,COPTIO(3),TOTSIZ
      INTEGER      PIX(3,2)
      INTEGER      K,N,NN,NNN,NX,NY,NZ,STAT
      INTEGER      OFFSET,OFF,OFF1,LOWX,LOWY,LOWZ
      INTEGER      IMNOW,MAPSIZ,NOHEAD
C
      REAL         CUTS(4)
C 
      DOUBLE PRECISION ARRAY(*),DATAS(*)
      DOUBLE PRECISION DD,DCONST
      DOUBLE PRECISION DMIN,DMAX
C
      COMMON    /SVCUTS/  CUTS,DMIN,DMAX
      COMMON    /WSPACE/  IMNOW,MAPSIZ,NOHEAD
      COMMON    /IMINFO/  IMNO,DATFMT,CVFLAG,MAXNO,NAXIS,NPIX
C
C  init + setup bounds
      NX = PIX(1,2) - PIX(1,1) + 1
      NY = PIX(2,2) - PIX(2,1) + 1
      NZ = PIX(3,2) - PIX(3,1) + 1
      OFF1 = 0
      LOWX = PIX(1,1)
      LOWY = PIX(2,1)
      LOWZ = PIX(3,1)
C
C  total size we have to write out
      TOTSIZ = NX + (NY-1)*NPIX(1) + (NZ-1)*NPIX(1)*NPIX(2)
      IF (TOTSIZ.GT.MAPSIZ) RETURN            !tell caller we need more memory
C
      OFFSET = (LOWX-1) + (LOWY-1)*NPIX(1) + (LOWZ-1)*NPIX(1)*NPIX(2)
      OFFSET = OFFSET + 1                     !point to first pixel
      CALL STFGET(IMNO,OFFSET,TOTSIZ,N,ARRAY,STAT)
C
C  branch according to constant option
      IF (COPTIO(1).NE.0) GOTO 1000
C 
      K = 0
      IF (COPTIO(3).EQ.0) THEN                 !store, add or multiply data
C
C  write contents of ARRAY (up to 3 dimensions)
         DO 300, NNN=1,NZ
            OFF = OFF1
            DO 200, NN=1,NY
               DO 100, N=1,NX
                  K = K + 1
                  DD = DATAS(K)
                  ARRAY(OFF+N) = DD
                  IF (DD.LT.DMIN) THEN             !check min + max
                     DMIN = DD
                  ELSE IF (DD.GT.DMAX) THEN
                     DMAX = DD
                  ENDIF
                  IF (K.EQ.COPTIO(2)) GOTO 2000
100            CONTINUE
               OFF = OFF + NPIX(1)
200         CONTINUE
            OFF1 = OFF1 + NPIX(1)*NPIX(2)
300      CONTINUE
C
      ELSE IF (COPTIO(3).EQ.1) THEN
C
         DO 600, NNN=1,NZ
            OFF = OFF1
            DO 500, NN=1,NY
               DO 400, N=1,NX
                  K = K + 1
                  DD = ARRAY(OFF+N) + DATAS(K)
                  ARRAY(OFF+N) = DD
                  IF (DD.LT.DMIN) THEN             !check min + max
                     DMIN = DD
                  ELSE IF (DD.GT.DMAX) THEN
                     DMAX = DD
                  ENDIF
                  IF (K.EQ.COPTIO(2)) GOTO 2000
400            CONTINUE
               OFF = OFF + NPIX(1)
500         CONTINUE
            OFF1 = OFF1 + NPIX(1)*NPIX(2)
600      CONTINUE
C
      ELSE
C
         DO 900, NNN=1,NZ
            OFF = OFF1
            DO 800, NN=1,NY
               DO 700, N=1,NX
                  K = K + 1
                  DD = ARRAY(OFF+N) * DATAS(K)
                  ARRAY(OFF+N) = DD
                  IF (DD.LT.DMIN) THEN             !check min + max
                     DMIN = DD
                  ELSE IF (DD.GT.DMAX) THEN
                     DMAX = DD
                  ENDIF
                  IF (K.EQ.COPTIO(2)) GOTO 2000
700            CONTINUE
               OFF = OFF + NPIX(1)
800         CONTINUE
            OFF1 = OFF1 + NPIX(1)*NPIX(2)
900      CONTINUE
      ENDIF
C
      GOTO 2000
C
C  fill contents of ARRAY (up to 3 dimensions) with constant
1000  DCONST = DATAS(1)
      K = NZ * NY * NX
      IF (COPTIO(3).EQ.0) THEN
         DO 1300, NNN=1,NZ
            OFF = OFF1
            DO 1200, NN=1,NY
               DO 1100, N=1,NX
                  ARRAY(OFF+N) = DCONST
1100           CONTINUE
               OFF = OFF + NPIX(1)
1200        CONTINUE
            OFF1 = OFF1 + NPIX(1)*NPIX(2)
1300     CONTINUE
C
         IF (DD.LT.DMIN) THEN             !check min + max
            DMIN = DD
         ELSE IF (DD.GT.DMAX) THEN
            DMAX = DD
         ENDIF
C
      ELSE IF (COPTIO(3).EQ.1) THEN
         DO 1600, NNN=1,NZ
            OFF = OFF1
            DO 1500, NN=1,NY
               DO 1400, N=1,NX
                  DD = ARRAY(OFF+N) + DCONST
                  ARRAY(OFF+N) = DD
                  IF (DD.LT.DMIN) THEN             !check min + max
                     DMIN = DD
                  ELSE IF (DD.GT.DMAX) THEN
                     DMAX = DD
                  ENDIF
1400           CONTINUE
               OFF = OFF + NPIX(1)
1500        CONTINUE
            OFF1 = OFF1 + NPIX(1)*NPIX(2)
1600     CONTINUE
C
      ELSE
         DO 1900, NNN=1,NZ
            OFF = OFF1
            DO 1800, NN=1,NY
               DO 1700, N=1,NX
                  DD = ARRAY(OFF+N) * DCONST
                  ARRAY(OFF+N) = DD
                  IF (DD.LT.DMIN) THEN             !check min + max
                     DMIN = DD
                  ELSE IF (DD.GT.DMAX) THEN
                     DMAX = DD
                  ENDIF
1700           CONTINUE
               OFF = OFF + NPIX(1)
1800        CONTINUE
            OFF1 = OFF1 + NPIX(1)*NPIX(2)
1900     CONTINUE
      ENDIF
C
C
2000  NOVAL = K
      CALL STFPUT(IMNO,OFFSET,TOTSIZ,ARRAY,STAT)
      TOTSIZ = 0
      RETURN
C
      END

      SUBROUTINE MAXDAT(ARRAY,DARRAY,NP)
C 
      IMPLICIT NONE
C 
      INTEGER   NP,N
      INTEGER   IMNO,DATFMT,NAXIS,NPIX(3),CVFLAG,MAXNO
C 
      REAL      ARRAY(*),CUTS(4)
C 
      DOUBLE PRECISION   DARRAY(*)
      DOUBLE PRECISION DMIN,DMAX
C 
      COMMON    /SVCUTS/  CUTS,DMIN,DMAX
      COMMON    /IMINFO/  IMNO,DATFMT,CVFLAG,MAXNO,NAXIS,NPIX
C 
C  double precision data
      IF (CVFLAG.EQ.4) THEN
         DO 100, N=1,NP
            IF (DARRAY(N).LT.DMIN) THEN
               DMIN = DARRAY(N)
            ELSE IF (DARRAY(N).GT.DMAX) THEN
               DMAX = DARRAY(N)
            ENDIF
100      CONTINUE
C 
C  single precision data
      ELSE
         DO 1000, N=1,NP
            IF (ARRAY(N).LT.CUTS(3)) THEN
               CUTS(3) = ARRAY(N)
            ELSE IF (ARRAY(N).GT.CUTS(4)) THEN
               CUTS(4) = ARRAY(N)
            ENDIF
1000     CONTINUE
         DMIN = DBLE(CUTS(3))
         DMAX = DBLE(CUTS(4))
      ENDIF
C 
      RETURN
      END
