C @(#)vcopy.for 17.1.1.1 (ESO-DMD) 01/25/02 17:40:03 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