C  @(#)repla.for	19.1 (ESO-DMD) 02/25/03 14:01:45 
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
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 021211		last modif
C	
C--------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER      I,IAV,II,LL,N,M
      INTEGER      NAXIS,NAXISA
      INTEGER      IMNOA,IMNOB1,IMNOB2,IMNOC,IMNOT
      INTEGER      NLIMIT,SIZE,SIZET,STAT
      INTEGER      NPIXA(6),NPIX(6)
      INTEGER      GENNUM,IFNUMB,CLONY
      INTEGER      MAPSIZ,NOFF,NOCO,RMAIND
      INTEGER      UNI(1),NULO,MADRID(1)
      INTEGER*8    PNTRA,PNTRB1,PNTRB2,PNTRC,PNTRT
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 = '  '
      CLONY = 1
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
         CLONY = 1
      ELSE                                    !create new frame ...
         CALL GENBLD(IMNOA,FRAMEC,D_R4_FORMAT,SIZE,IMNOC,CLONY,STAT)
         CALL STFXMP(MAPSIZ,D_R4_FORMAT,PNTRC,STAT)       !map working space
      ENDIF                                   !CLONY = 1 for cloned descr's
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  IF (CLONY.EQ.0) THEN                     !copy descr's + update history
         CALL DSCUPT(IMNOA,IMNOC,' ',STAT)  
      ELSE                                     !only update history
         CALL DSCUPT(IMNOC,IMNOC,' ',STAT)  
      ENDIF
      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
