C @(#)vcopy.for	19.1 (ESO-DMD) 02/25/03 14:00:31 
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 VCOPY
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C program VCOPY				version 1.00 	881028
C  K. Banse				ESO - Garching
C  1.10    890622
C
C.KEYWORDS
C ImageDisplay, Hardcopy
C
C.PURPOSE
C  read Image display
C
C.ALGORITHM
C  use RDMON to build up the greycopy
C
C.INPUT/OUTPUT
C  the following keywords are used:
C  INPUTI/I/1/2		(1) termination flag: 
C			    1 go all the way
C			    0 stop after filling mask with display data
C			(2) save flag: 
C			    1 = save image in "screen.bdf"
C			    0 = no
C
C.VERSIONS
C  see SCCS for later versions than 1.10
C
C 011130	last modif
C 
C----------------------------------------------------------------------------
C
      IMPLICIT NONE
C      
      CHARACTER    IDENT*72,FRAME*60
      CHARACTER    CUNIT*48,TYPE*4,PRMODE*6
C
      INTEGER*8    PNTR
      INTEGER      IMNOI,IMNOK,BITS8
      INTEGER      N1,N2,I,STAT,NDIM,IAV
      INTEGER      IBUF(800)
      INTEGER      NPIX(2),CHANL,KDEVR(20)
      INTEGER      SECTN,LUTSZ,PLOTCL,PACKF
      INTEGER      UNI(1),NULO,MADRID(1)
C
      DOUBLE PRECISION START(2),STEP(2),END(2)
C 
      REAL         CUTS(4),RINF(8),RBUF(800),RQ(768),PBUF(30)
C      
      INCLUDE      'MID_INCLUDE:ST_DEF.INC'
C 
      INCLUDE  'MID_INCLUDE:IDIDEV.INC'
      INCLUDE  'MID_INCLUDE:IDIMEM.INC'
C 
      COMMON  /VMR/  MADRID
C 
      DATA      START    /0.D0,0.D0/
      DATA      STEP     /1.D0,1.D0/
      DATA      PLOTCL   /9/                       !no. of plot colours
C               Ojo: PBUF must have size = 3*PLOTCL
C 
      INCLUDE      'MID_INCLUDE:ST_DAT.INC'
C      
C  initialize MIDAS
      CALL STSPRO('VCOPY')
C
C  read main control block of Image Display
      CALL DTOPEN(1,STAT)
C
      CUNIT(1:16) = 'Screen pixels '
      CUNIT(17:32) = CUNIT(1:16)
      CUNIT(33:48) = 'Screen intens. '
      CALL STKRDC('DEFAULT',1,1,1,IAV,TYPE,UNI,NULO,STAT)
C
C..  create + init screen output file of e.g. 512x512 pixels
C
      NPIX(1) = QDSZX
      NPIX(2) = QDSZY
      NDIM = NPIX(1) * NPIX(2)
      LUTSZ = QLUTSZ
      FRAME = 'vcopy.bdf '
      IDENT(1:) = ' '
      CHANL = QIMCH
      CALL STKRDI('DAZDEVR',1,20,IAV,KDEVR,UNI,NULO,STAT)
      QRGBFL = KDEVR(18)
      CALL STKRDI('IDIDEV',1,20,IAV,IBUF,UNI,NULO,STAT)
      SECTN = 0                              !temporarily set LUT section to 0
      IF ((QRGBFL .EQ. 0) .AND.(QDDEP .EQ. 8)) THEN
         BITS8 = 1
      ELSE
         BITS8 = 0                           !take care of 16, 24-bit displays
      ENDIF
C 
C  get current LUT (avoid extrapolation)
      IF (BITS8.EQ.1) THEN
         CALL RDLUT(QDSPNO,SECTN,1,QLUTSZ,RQ,STAT)
         CALL MAKLUT(2,QLUTSZ,RQ,256,RBUF)         !to fill the LUT all the way 
         CALL MAKLUT(2,QLUTSZ,RQ,QLUTSZ,RBUF) 
      ENDIF
C      
C  X11 environment
      IF (IDINUM.NE.11) THEN
         CALL STETER(13,'WE only support X-Windows...')
         CALL STSEPI
      ENDIF
C 
      IF (TYPE(1:1).EQ.'Z') THEN          !we want to copy the zoom-window
         CALL DTOPEN(3,STAT)              !that sets ZDSPNO ...
         CHANL = 0
         NPIX(1) = IBUF(19)
         NPIX(2) = IBUF(20)
         NDIM = NPIX(1) * NPIX(2)
      ELSE
         ZDSPNO = -1
      ENDIF
C 
      IF (BITS8 .EQ. 1)  THEN            !PseudoColor
         CALL STIPUT(FRAME,D_I1_FORMAT,F_O_MODE,F_IMA_TYPE,2,
     +            NPIX,START,STEP,IDENT,CUNIT,PNTR,IMNOI,STAT)
         PACKF = 4
      ELSE                                !RGB mode
         CALL STIPUT(FRAME,D_I4_FORMAT,F_O_MODE,F_IMA_TYPE,2,
     +            NPIX,START,STEP,IDENT,CUNIT,PNTR,IMNOI,STAT)
         PACKF = 1
      ENDIF
C 
      IF (ZDSPNO.LT.0) THEN
         CALL 
     +      IIDSNP(QDSPNO,0,NDIM,0,0,QMDEP,PACKF,MADRID(PNTR),STAT)
      ELSE
         CALL 
     +      IIDSNP(ZDSPNO,0,NDIM,0,0,QMDEP,PACKF,MADRID(PNTR),STAT)
         CALL DTCLOS(ZDSPNO)
      ENDIF
C 
      IF (BITS8 .EQ. 1)  THEN 
         CALL RDLUT(QDSPNO,99,1,PLOTCL,RQ,STAT)    !get plot colours
         CALL MAKLUT(2,PLOTCL,RQ,PLOTCL,PBUF)
         N1 = 3 * QLUTSZ
         N2 = PLOTCL*3 - 2
         DO 300,I=1,N2,3                         !and add them in the end
            RBUF(N1+I) = PBUF(I)
            RBUF(N1+I+1) = PBUF(I+1)
            RBUF(N1+I+2) = PBUF(I+2)
300      CONTINUE
         LUTSZ = QLUTSZ + PLOTCL
      ELSE
         LUTSZ = 256
      ENDIF
C 
C  check PrintMode, if we really need originally loaded frame
      CALL STKRDC('P6',1,1,5,IAV,PRMODE,UNI,NULO,STAT)
      CALL UPCAS(PRMODE,PRMODE)
      IF (PRMODE(5:5).NE.'Z') THEN               !T/Z = Text/NoText
C 
C  copy info of displayed frame
         CALL DTGICH(QDSPNO,CHANL,FRAME,RINF,STAT)
         CALL STFOPN(FRAME,D_OLD_FORMAT,0,F_IMA_TYPE,IMNOK,STAT)
         CALL STDWRC(IMNOI,'ROOT_FRAME',1,FRAME,1,60,UNI,STAT)
         CALL STDWRR(IMNOI,'ROOT_CUTS',RINF(5),1,2,UNI,STAT)     !original cuts
C 
         CALL STDCOP(IMNOK,IMNOI,4,'IDENT',STAT)
         CALL STDCOP(IMNOK,IMNOI,4,'STEP',STAT)
         START(1) = RINF(1)
         START(2) = RINF(2)
         CALL STDWRD(IMNOI,'START',START,1,2,UNI,STAT)     !start as in display
         END(1) = RINF(3)
         END(2) = RINF(4)
         CALL STDWRD(IMNOI,'END',END,1,2,UNI,STAT)         !end as in display
C 
         IF (BITS8 .EQ. 1) THEN
            CALL STDFND(IMNOK,'MIDAS_ITT',TYPE,N1,N2,STAT)
            IF (TYPE(1:1).EQ.'I') THEN
               CALL STDRDI(IMNOK,'MIDAS_ITT',1,N1,IAV,IBUF,UNI,
     +                     NULO,STAT)
               CALL STDWRI(IMNOI,'MIDAS_ITT',IBUF,1,N1,UNI,STAT)
            ELSE IF (TYPE(1:1).EQ.'R') THEN
               CALL STDRDR(IMNOK,'MIDAS_ITT',1,N1,IAV,RBUF,UNI,
     +                     NULO,STAT)
               CALL STDWRR(IMNOI,'MIDAS_ITT',RBUF,1,N1,UNI,STAT)
            ENDIF
            CALL STDFND(IMNOK,'MIDAS_LUT',TYPE,N1,N2,STAT)
            IF (TYPE(1:1).EQ.'I') THEN
               CALL STDRDI(IMNOK,'MIDAS_LUT',1,N1,IAV,IBUF,UNI,
     +                     NULO,STAT)
               CALL STDWRI(IMNOI,'MIDAS_LUT',IBUF,1,N1,UNI,STAT)
            ELSE IF (TYPE(1:1).EQ.'R') THEN
               CALL STDRDR(IMNOK,'MIDAS_LUT',1,N1,IAV,RBUF,UNI,
     +                     NULO,STAT)
               CALL STDWRR(IMNOI,'MIDAS_LUT',RBUF,1,N1,UNI,STAT)
            ENDIF
         ENDIF
      ELSE
         FRAME(1:) = 'None '
         CALL STDWRC(IMNOI,'ROOT_FRAME',1,FRAME,1,60,UNI,STAT)
         RINF(5) = 0.
         RINF(6) = 255.
         CALL STDWRR(IMNOI,'ROOT_CUTS',RINF(5),1,2,UNI,STAT)     !original cuts
         START(1) = 0.
         START(2) = 0.
         CALL STDWRD(IMNOI,'START',START,1,2,UNI,STAT)     !start as in display
         END(1) = 512.
         END(2) = 512.
         CALL STDWRD(IMNOI,'END',END,1,2,UNI,STAT)         !end as in display
      ENDIF
C
C  now store the LUT in `middumml.lut'
      IDENT(1:) = 'MID_WORK:middumml '
      CALL BLDLUT(IDENT,RBUF,STAT)     !create table and fill it with LUT
C 
      CUTS(1) = 0.
      CUTS(2) = LUTSZ - 1.
      CUTS(3) = CUTS(1)
      CUTS(4) = CUTS(2)
      CALL STDWRR(IMNOI,'LHCUTS',CUTS,1,4,UNI,STAT)
      CALL STDWRI(IMNOI,'VCOPY-LUTSIZE',LUTSZ,1,1,UNI,STAT)
C
      CALL DTCLOS(QDSPNO)
      CALL STSEPI
C      
      END
