C @(#)data.for 17.1.1.2 (ESO-DMD) 02/25/02 17:45:17 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 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 OUTPUTR/R/1/20 for R, P the first 20 values are also stored in C that keyword C C.VERSIONS C C 020220 last modif C C-------------------------------------------------- C IMPLICIT NONE C INTEGER IAV,N,STAT,M1,M2,M3,M4 INTEGER NAXIS,NPIX(3) INTEGER IMNOW,SIZE,MAPSIZ 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,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 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 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 C CALL STFOPN(FRAME,DATFMT,0,F_IMA_TYPE,IMNO,STAT) CALL STDRDI(IMNO,'NAXIS',1,1,IAV,NAXIS,UNIT,NULLO,STAT) 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 STDRDI(IMNO,'NPIX',1,NAXIS,IAV,NPIX,UNIT,NULLO,STAT) 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 END SUBROUTINE DATALN(FRAME,START,STEP,SIZE,AC,INPUTC,PRFLAG) C IMPLICIT NONE C INTEGER PRFLAG,ACTVAL,COPTIO(3) INTEGER IAV,NOVAL,CVFLAG,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,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 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*80 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,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 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*80,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,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 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(2) 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 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,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 C REAL ARRAY(*) REAL TEMP(5) C CHARACTER FLAG*1 CHARACTER*80 OUTPUT C COMMON /WSPACE/ IMNOW,MAPSIZ,NOHEAD COMMON /IMINFO/ IMNO,DATFMT,CVFLAG,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(5),FIRST(25) C DOUBLE PRECISION DARRAY(*),DTEMP(5),DFIRST(25) C CHARACTER*80 OUTPUT C COMMON /WSPACE/ IMNOW,MAPSIZ,NOHEAD COMMON /IMINFO/ IMNO,DATFMT,CVFLAG,NAXIS,NPIX C C init + setup bounds IF (CVFLAG.EQ.4) THEN MAXNO = 3 ELSE MAXNO = 5 ENDIF 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 (MAXNO.EQ.5) THEN CALL STFGET(IMNO,OFF+1,NNN,IFIRST,ARRAY,STAT) ELSE CALL STFGET(IMNO,OFF+1,NNN,IFIRST,DARRAY,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 (MAXNO.EQ.5) 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 (MAXNO.EQ.5) 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 (MAXNO.EQ.5) 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 IF (IFIRST.GT.21) IFIRST = 21 IF (MAXNO.EQ.5) THEN CALL STKWRR('OUTPUTR',FIRST,1,IFIRST-1,UNIT,STAT) ELSE DO 5500, N=1,IFIRST !for backwards compatibility... FIRST(N) = REAL(DFIRST(N)) 5500 CONTINUE CALL STKWRR('OUTPUTR',FIRST,1,IFIRST-1,UNIT,STAT) CALL STKWRD('OUTPUTD',DFIRST,1,IFIRST-1,UNIT,STAT) 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. = 5 INTEGER STAT,M INTEGER IMNO,DATFMT,NAXIS,NPIX(3),CVFLAG C REAL TEMP(*),FIRST(*) C CHARACTER OUTPUT*80 C COMMON /IMINFO/ IMNO,DATFMT,CVFLAG,NAXIS,NPIX 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 C 10000 FORMAT(5G15.7) END SUBROUTINE R8WROU(TEMP,LIM,FIRST,IFIRST) C IMPLICIT NONE C INTEGER LIM,IFIRST !LIM is max. = 4 INTEGER STAT,M INTEGER IMNO,DATFMT,NAXIS,NPIX(3),CVFLAG C DOUBLE PRECISION TEMP(*),FIRST(*) C CHARACTER OUTPUT*80 C COMMON /IMINFO/ IMNO,DATFMT,CVFLAG,NAXIS,NPIX 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 C 10000 FORMAT(' ',3G24.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 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,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 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,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 C REAL ARRAY(*),CUTS(4) C DOUBLE PRECISION DARRAY(*) DOUBLE PRECISION DMIN,DMAX C COMMON /SVCUTS/ CUTS,DMIN,DMAX COMMON /IMINFO/ IMNO,DATFMT,CVFLAG,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