C @(#)repla.for 13.1.1.2 (ESO-DMD) 03/30/99 09:15:18 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 REPLA C C++++++++++++++++++++++++++++++++++++++++++++++++++ C C.IDENTIFICATION C program REPLA version 1.00 880902 C K. Banse ESO - Garching C 1.10 890508 1.20 900116 1.30 910418 C C.KEYWORDS C pixels C C.PURPOSE C replace pixels in a given interval by another value C C.ALGORITHM C get the names of input + output frames from IN_A + IN_B, C get the low + hi limits of replacement interval and replacing value from P3 C in the form low,hi=repla or low=repla, if interval is only 1 value C C copy descriptor LHCUTS to output frame to keep same colours at same pixels! C C.INPUT/OUTPUT C the following keys are used: C C IN_A/C/1/80 input frame C OUT_A/C/1/80 output frame C P3/C/1/100 interval and replacing value in the form: C test_frame/low,hi=in_fram1'op'val1[,in_fram2'op'val2] C with op = +,-.* or / C or test_frame/low,hi=value C if test_frame/ is omitted, main input frame is used C C.VERSIONS C C 010606 last modif C C-------------------------------------------------- C IMPLICIT NONE C INTEGER I,IAV,II,LL,N,M INTEGER NAXIS,NAXISA INTEGER*8 PNTRA,PNTRB1,PNTRB2,PNTRC,PNTRT INTEGER IMNOA,IMNOB1,IMNOB2,IMNOC,IMNOT INTEGER NLIMIT,SIZE,SIZET,STAT INTEGER NPIXA(6),NPIX(6) INTEGER GENNUM,IFNUMB INTEGER MAPSIZ,NOFF,NOCO,RMAIND INTEGER UNI(1),NULO,MADRID(1) C CHARACTER*80 FRAMEA,FRAMB1,FRAMB2,FRAMET,FRAMEC CHARACTER STRING*100,LOSTR*40,HISTR*40,VALSTR*40 CHARACTER RSIDE*60,RSIDEA*60,RSIDEB*60 CHARACTER NEWSTR*100,XSTR*40 CHARACTER OP*2,OPS(4)*1,ETEST*1 C REAL LOVAL,HIVAL,VALUE(2) C DOUBLE PRECISION DVAL C COMMON /VMR/ MADRID C INCLUDE 'MID_INCLUDE:ST_DEF.INC' C DATA OPS /'+','-','*','/'/ DATA LOVAL /0./, HIVAL /0./, VALUE /0.,0./ DATA IMNOA /-1/, IMNOC /-1/ DATA IMNOT /-1/, IMNOB1 /-1/, IMNOB2 /-1/ DATA PNTRA /-1/, PNTRC /-1/ DATA PNTRT /-1/, PNTRB1 /-1/, PNTRB2 /-1/ C INCLUDE 'MID_INCLUDE:ST_DAT.INC' C C set up MIDAS environment + enable automatic error abort CALL STSPRO('REPLA') OP = ' ' C C get input + result frame + map them CALL STKRDC('IN_A',1,1,80,IAV,FRAMEA,UNI,NULO,STAT) CALL STKRDC('OUT_A',1,1,80,IAV,FRAMEC,UNI,NULO,STAT) STRING(1:) = ' ' CALL STKRDC('P3',1,1,100,IAV,STRING,UNI,NULO,STAT) CALL STFOPN(FRAMEA,D_R4_FORMAT,0,F_IMA_TYPE,IMNOA,STAT) CALL STDRDI(IMNOA,'NAXIS',1,1,IAV,NAXISA,UNI,NULO,STAT) CALL STDRDI(IMNOA,'NPIX',1,NAXISA,IAV,NPIXA,UNI,NULO,STAT) C C get total size SIZE = 1 DO 400, N=1,NAXISA SIZE = SIZE * NPIXA(N) 400 CONTINUE C C create buffer space CALL STKRDI('MONITPAR',20,1,IAV,MAPSIZ,UNI,NULO,STAT) MAPSIZ = MAPSIZ * MAPSIZ !org_val = NPIX of square image IF (MAPSIZ .LT. 1000) MAPSIZ = 40000 NOCO = SIZE / MAPSIZ !get chunk size N = NOCO * MAPSIZ RMAIND = SIZE - N !remainder CALL STFXMP(MAPSIZ,D_R4_FORMAT,PNTRA,STAT) C CALL GENEQF(FRAMEA,FRAMEC,STAT) IF (STAT.EQ.1) THEN !if equal, just update ... IMNOC = IMNOA PNTRC = PNTRA ELSE !create new frame ... CALL STFCRE(FRAMEC,D_R4_FORMAT,F_O_MODE,F_IMA_TYPE, + SIZE,IMNOC,STAT) CALL STDCOP(IMNOA,IMNOC,2,VALSTR,STAT) !copy all standard descr's CALL STFXMP(MAPSIZ,D_R4_FORMAT,PNTRC,STAT) ENDIF C C isolate expression after the `=' sign II = INDEX(STRING,'=') IF (II.LE.1) + CALL STETER(5,'no replacement string found...') RSIDE = STRING(II+1:)//' ' STRING(II:) = ' ' C C get the other parameters I = INDEX(STRING,'/') !look for test_frame... IF (I.GT.0) THEN !yes. FRAMET = STRING(1:I-1)//' ' CALL CLNFRA(FRAMET,FRAMET,0) C CALL GENEQF(FRAMEA,FRAMET,STAT) IF (STAT.NE.1) THEN CALL STFOPN(FRAMET,D_R4_FORMAT,0,F_IMA_TYPE,IMNOT,STAT) CALL STDRDI(IMNOT,'NAXIS',1,1,IAV,NAXIS,UNI,NULO,STAT) CALL STDRDI(IMNOT,'NPIX',1,NAXIS,IAV,NPIX,UNI,NULO,STAT) SIZET = 1 DO 600, N=1,NAXIS SIZET = SIZET*NPIX(N) 600 CONTINUE IF (SIZET.NE.SIZE) GOTO 9800 CALL STFXMP(MAPSIZ,D_R4_FORMAT,PNTRT,STAT) ELSE IMNOT = IMNOA PNTRT = PNTRA ENDIF NEWSTR = STRING(I+1:)//' ' ELSE IMNOT = IMNOA !use basic input frame PNTRT = PNTRA NEWSTR = STRING ENDIF C C process the replacement interval NLIMIT = 0 !default to full interval I = INDEX(NEWSTR,',') IF ((I.LE.1).OR.(I.GT.31)) + CALL STETER(5,'low replacement interval invalid...') C LOSTR = NEWSTR(1:I-1)//' ' IF (LOSTR.EQ.'<') THEN NLIMIT = -1 ELSE CALL GENCNV(LOSTR,4,1,IAV,LOVAL,DVAL,LL) IF (LL.LE.0) GOTO 9900 LOVAL = SNGL(DVAL) ENDIF C HISTR = NEWSTR(I+1:II-1)//' ' IF (HISTR.EQ.'>') THEN IF (NLIMIT.EQ.0) THEN NLIMIT = 1 ELSE GOTO 9900 ENDIF ELSE CALL GENCNV(HISTR,4,1,IAV,HIVAL,DVAL,LL) IF (LL.LE.0) GOTO 9900 HIVAL = SNGL(DVAL) ENDIF C C look for separating comma in right hand expression I = INDEX(RSIDE,',') IF (I.LE.0) THEN RSIDEA(1:) = RSIDE(1:) RSIDEB(1:) = ' ' ELSE IF (I.EQ.1) THEN CALL STETER(5,'wrong syntax ...') ELSE RSIDEA(1:) = RSIDE(1:I-1)//' ' RSIDEB(1:) = RSIDE(I+1:)//' ' ENDIF C C now let's analyze the right side(s) C I = INDEX(RSIDEA,'(') IF (I.GT.1) THEN !frame`op'(xxx) XSTR(1:) = RSIDEA(I+1:) RSIDEA(I:) = '0 ' !put in a 0 as place holder I = INDEX(XSTR,')') !and cut off closing ')' IF (I.LT.2) GOTO 9900 XSTR(I:I) = ' ' ELSE XSTR(1:1) = ' ' ENDIF C DO 1000, N=1,4 I = INDEX(RSIDEA,OPS(N)) IF (I.GT.1) THEN IF ((N.LE.2) .AND. (GENNUM(RSIDEA).EQ.1)) THEN !test if 123.E+05 ETEST = RSIDEA(I-1:I-1) !get char. before + or - IF ((ETEST.EQ.'E') .OR. (ETEST.EQ.'e')) THEN LL = I + 2 !skip past `+' or `-' DO 900, M=1,4 II = INDEX(RSIDEA(LL:),OPS(M)) !check for operands IF (II.GT.0) + CALL STETER(2,'first operand must be a frame...') 900 CONTINUE GOTO 1100 ENDIF ENDIF OP(1:1) = OPS(N) GOTO 2000 ENDIF 1000 CONTINUE C C only constant or frame 1100 IF (GENNUM(RSIDEA).EQ.1) THEN OP(1:1) = 'C' IF (XSTR(1:1) .EQ. ' ') THEN VALSTR(1:) = RSIDEA(1:) ELSE VALSTR(1:) = XSTR(1:) ENDIF PNTRB1 = PNTRA !use basic in frame as 2. input frame IMNOB1 = IMNOA GOTO 3000 ELSE OP(1:1) = 'F' CALL CLNFRA(RSIDEA,RSIDEA,0) CALL STFOPN(RSIDEA,D_R4_FORMAT,0,F_IMA_TYPE,IMNOB1,STAT) CALL STDRDI(IMNOB1,'NAXIS',1,1,IAV,NAXIS,UNI,NULO,STAT) CALL STDRDI(IMNOB1,'NPIX',1,NAXIS,IAV,NPIX,UNI,NULO,STAT) SIZET = 1 DO 1200, N=1,NAXIS SIZET = SIZET*NPIX(N) 1200 CONTINUE IF (SIZET.NE.SIZE) GOTO 9800 IF (IMNOB1.EQ.IMNOA) THEN PNTRB1 = PNTRA ELSE CALL STFXMP(MAPSIZ,D_R4_FORMAT,PNTRB1,STAT) ENDIF C GOTO 3333 ENDIF C C we have another input frame 2000 FRAMB1(1:) = RSIDEA(1:I-1)//' ' IF (GENNUM(FRAMB1).EQ.1) + CALL STETER(2,'first operand must be a frame...') C CALL CLNFRA(FRAMB1,FRAMB1,0) CALL STFOPN(FRAMB1,D_R4_FORMAT,0,F_IMA_TYPE,IMNOB1,STAT) CALL STDRDI(IMNOB1,'NAXIS',1,1,IAV,NAXIS,UNI,NULO,STAT) CALL STDRDI(IMNOB1,'NPIX',1,NAXIS,IAV,NPIX,UNI,NULO,STAT) SIZET = 1 DO 2400, N=1,NAXIS SIZET = SIZET*NPIX(N) 2400 CONTINUE IF (SIZET.NE.SIZE) GOTO 9800 IF (IMNOB1.EQ.IMNOA) THEN PNTRB1 = PNTRA ELSE CALL STFXMP(MAPSIZ,D_R4_FORMAT,PNTRB1,STAT) ENDIF IF (XSTR(1:1) .EQ. ' ') THEN VALSTR = RSIDEA(I+1:) ELSE VALSTR(1:) = XSTR(1:) ENDIF C 3000 CALL GENCNV(VALSTR,2,1,VALUE(1),VALUE(1),VALUE(1),LL) IF (LL.LE.0) GOTO 9900 C C look, if we have an alternative for the IF clause (if not we use FRAME) 3333 IF (RSIDEB(1:1).EQ.' ') GOTO 8000 C I = INDEX(RSIDEB,'(') IF (I.GT.1) THEN !frame`op'(xxx) XSTR(1:) = RSIDEB(I+1:) RSIDEB(I:) = '0 ' !put in a 0 as place holder I = INDEX(XSTR,')') !and cut off closing ')' IF (I.LT.2) GOTO 9900 XSTR(I:I) = ' ' ELSE XSTR(1:1) = ' ' ENDIF C DO 4000, N=1,4 I = INDEX(RSIDEB,OPS(N)) IF (I.GT.1) THEN IF ((N.LE.2) .AND. (GENNUM(RSIDEB).EQ.1)) THEN !test for 123.E+05 ETEST = RSIDEB(I-1:I-1) !get char. before + or - IF ((ETEST.EQ.'E') .OR. (ETEST.EQ.'e')) THEN LL = I + 2 !skip past `+' or `-' DO 3900, M=1,4 II = INDEX(RSIDEB(LL:),OPS(M)) !check for operands IF (II.GT.0) + CALL STETER(2,'first operand must be a frame...') 3900 CONTINUE GOTO 4100 ENDIF ENDIF OP(2:2) = OPS(N) GOTO 5000 ENDIF 4000 CONTINUE C C only constant or frame 4100 IF (GENNUM(RSIDEB).EQ.1) THEN OP(2:2) = 'C' IF (XSTR(1:1) .EQ. ' ') THEN VALSTR(1:) = RSIDEB(1:) ELSE VALSTR(1:) = XSTR(1:) ENDIF PNTRB2 = PNTRA !use basic inframe as 2. input frame IMNOB2 = IMNOA GOTO 6000 ELSE OP(2:2) = 'F' CALL CLNFRA(RSIDEB,RSIDEB,0) CALL STFOPN(RSIDEB,D_R4_FORMAT,0,F_IMA_TYPE,IMNOB2,STAT) CALL STDRDI(IMNOB2,'NAXIS',1,1,IAV,NAXIS,UNI,NULO,STAT) CALL STDRDI(IMNOB2,'NPIX',1,NAXIS,IAV,NPIX,UNI,NULO,STAT) SIZET = 1 DO 4200, N=1,NAXIS SIZET = SIZET*NPIX(N) 4200 CONTINUE IF (SIZET.NE.SIZE) GOTO 9800 IF (IMNOB2.EQ.IMNOA) THEN PNTRB2 = PNTRA ELSE CALL STFXMP(MAPSIZ,D_R4_FORMAT,PNTRB2,STAT) ENDIF GOTO 8000 ENDIF C C we have another input frame 5000 FRAMB2(1:) = RSIDEB(1:I-1)//' ' IF (GENNUM(FRAMB2).EQ.1) + CALL STETER(2,'first operand must be a frame...') C CALL CLNFRA(FRAMB2,FRAMB2,0) CALL STFOPN(FRAMB2,D_R4_FORMAT,0,F_IMA_TYPE,IMNOB2,STAT) CALL STDRDI(IMNOB2,'NAXIS',1,1,IAV,NAXIS,UNI,NULO,STAT) CALL STDRDI(IMNOB2,'NPIX',1,NAXIS,IAV,NPIX,UNI,NULO,STAT) SIZET = 1 DO 5400, N=1,NAXIS SIZET = SIZET*NPIX(N) 5400 CONTINUE IF (SIZET.NE.SIZE) GOTO 9800 IF (IMNOB2.EQ.IMNOA) THEN PNTRB2 = PNTRA ELSE CALL STFXMP(MAPSIZ,D_R4_FORMAT,PNTRB2,STAT) ENDIF IF (XSTR(1:1) .EQ. ' ') THEN VALSTR(1:) = RSIDEB(I+1:) ELSE VALSTR(1:) = XSTR(1:) ENDIF C 6000 CALL GENCNV(VALSTR,2,1,VALUE(2),VALUE(2),VALUE(2),LL) IF (LL.LE.0) GOTO 9900 C C now do replacements C 8000 NOFF = 1 IFNUMB = 0 C 8080 IF (NOCO.GT.0) THEN SIZET = MAPSIZ ELSE IF (RMAIND.GT.0) THEN SIZET = RMAIND RMAIND = 0 ELSE GOTO 9000 ENDIF C LL = 0 CALL STFGET(IMNOA,NOFF,SIZET,IAV,MADRID(PNTRA),STAT) IF (IMNOT.NE.IMNOA) + CALL STFGET(IMNOT,NOFF,SIZET,IAV,MADRID(PNTRT),STAT) IF ((IMNOB1.GE.0) .AND. (IMNOB1.NE.IMNOA)) + CALL STFGET(IMNOB1,NOFF,SIZET,IAV,MADRID(PNTRB1),STAT) IF ((IMNOB2.GE.0) .AND. (IMNOB2.NE.IMNOA)) + CALL STFGET(IMNOB2,NOFF,SIZET,IAV,MADRID(PNTRB2),STAT) C IF (OP(1:1).EQ.'C') THEN CALL IREPLA(MADRID(PNTRA),MADRID(PNTRT),MADRID(PNTRB1), + MADRID(PNTRB2),MADRID(PNTRC),LL, + OP,SIZET,LOVAL,HIVAL,NLIMIT,VALUE) ELSE IF (OP(1:1).EQ.'+') THEN CALL IREPLB(MADRID(PNTRA),MADRID(PNTRT),MADRID(PNTRB1), + MADRID(PNTRB2),MADRID(PNTRC),LL, + OP,SIZET,LOVAL,HIVAL,NLIMIT,VALUE) ELSE IF (OP(1:1).EQ.'-') THEN CALL IREPLC(MADRID(PNTRA),MADRID(PNTRT),MADRID(PNTRB1), + MADRID(PNTRB2),MADRID(PNTRC),LL, + OP,SIZET,LOVAL,HIVAL,NLIMIT,VALUE) ELSE IF (OP(1:1).EQ.'*') THEN CALL IREPLD(MADRID(PNTRA),MADRID(PNTRT),MADRID(PNTRB1), + MADRID(PNTRB2),MADRID(PNTRC),LL, + OP,SIZET,LOVAL,HIVAL,NLIMIT,VALUE) ELSE IF (OP(1:1).EQ.'/') THEN CALL IREPLE(MADRID(PNTRA),MADRID(PNTRT),MADRID(PNTRB1), + MADRID(PNTRB2),MADRID(PNTRC),LL, + OP,SIZET,LOVAL,HIVAL,NLIMIT,VALUE) ELSE CALL IREPLF(MADRID(PNTRA),MADRID(PNTRT),MADRID(PNTRB1), + MADRID(PNTRB2),MADRID(PNTRC),LL, + OP,SIZET,LOVAL,HIVAL,NLIMIT,VALUE) ENDIF C CALL STFPUT(IMNOC,NOFF,IAV,MADRID(PNTRC),STAT) IFNUMB = IFNUMB + LL NOCO = NOCO - 1 NOFF = NOFF + IAV GOTO 8080 !work on next chunk C C take care of descriptors 9000 CALL DSCUPT(IMNOA,IMNOC,' ',STAT) CC CALL STDCOP(IMNOA,IMNOC,4,'LHCUTS',STAT) !copy descr LHCUTS WRITE(STRING,10000) IFNUMB CALL STTPUT(STRING,STAT) CALL STKWRI('OUTPUTI',IFNUMB,15,1,NULO,STAT) C C free data + exit CALL STSEPI C C wrong input 9800 CALL STETER + (4,'input/test frames must all have same dimensions...') C 9900 CALL STETER(1,'invalid parameters...') C 10000 FORMAT(I8,' pixels in given interval replaced ...') END