* Last processed by NICE on 12-Jun-2000 15:53:00
* Customized for :  IEEE, LINUX, UNIX, MOTIF, F77
*
* written by r.neri
* modified by a.perrigouard, d.broguiere
*
      SUBROUTINE BASELINE (LINE,ERROR)
*----------------------------------------------------------------------
*       Support routine for command
*
*       BASELINE /CHANNEL /NOISE /BYSUBSCAN /SUPPORT /ORDER /FILE /CORR
*                /PEN
*
* Arguments :
*
*       LINE    C*(*)   Command line                    Input
*       ERROR   L       Logical error flag              Output
*
*----------------------------------------------------------------------
*
      INCLUDE 'inc:xpar.inc'
      INCLUDE 'nic.inc'
      INCLUDE 'parameter.inc'
      INCLUDE 'par.inc'
      INCLUDE 'const.inc'
      INTEGER  MAX_SEG
      PARAMETER (MAX_SEG = 100)
      CHARACTER*(*) LINE
*
      REAL*8  XU(MAX_SEG), YU(MAX_SEG), XS(2), YS(2)
      REAL*8  GONS(MAX_SEG,4), XCOO, YCOO, BOUND(5)
      INTEGER*4 IPMAP,IP
      INTEGER*4 IP_INP_AZ, IP_INP_EL, IP_INP_SI
      INTEGER*4 IP_OUT_AZ, IP_OUT_EL, IP_OUT_SI, IP_TIME
      INTEGER*4 IP_INSIDE, IP_NOISE, IP_WEIGHT
      INTEGER*4 IPWORK_X, IPWORK_Y, IPWORK_WEI, IPWORK_B
      INTEGER*4 IP_SUBFIRST, IP_SUBLAST, SUBSCAN_LIST
      INTEGER*4 POINTER, XYWEIB_BUFFER
*
      REAL*8    EPOCHFR,EPOCHTO,AMAT(9),AVEC(3),BVEC(3)
      REAL*8    RA_FROM_SCAN,DEC_FROM_SCAN,RA_DAY_SCAN,DEC_DAY_SCAN
      REAL*8    LATI
      REAL*8    UNUSED8
*
      REAL      X4COO,Y4COO
      CHARACTER RGDATA*40, RGPLOT*40 ,STRING*80, LIMIT_STRING*40
      CHARACTER SUPPORTFILE*80, SUPPORTNAME*80, PENCIL_TEXT*13
      CHARACTER CODE(MAX_SEG)*1, CODEMOUSE*1
      LOGICAL   GTG_CURS, SIC_PRESENT, ERROR, FILE_READ, FILE_OPT
      LOGICAL   CHANNEL_OPT, PENCIL_OPT
      LOGICAL   EXIST_MDB, OPEN_MDB
      LOGICAL   EXIST_SUPPORT, NEW_SUPPORT
      INTEGER   MAX_SUBREC,N,COLOR
*
      INTEGER*4 DISTMAX, NUMBER
      PARAMETER (DISTMAX=NREC*(NREC-1)/2)
      INTEGER*4 CHAN, I, I1, I2, PNT, DIM(4), NX, NY, NC, K, ICHAN
      INTEGER*4 IER, HOW_MUCH
      INTEGER*4 NPAR, QUALITY
      INTEGER*4 SIC_GETVM
      REAL*4  CORNER_XLOW, CORNER_XUP, CORNER_YLOW, CORNER_YUP
      REAL*4  X4(MAX_SEG), Y4(MAX_SEG), RING
      REAL*4  LIM_INFX, LIM_SUPX, LIM_INFY, LIM_SUPY
      REAL*4  CORRDIST(DISTMAX), CORRCOEF(DISTMAX)
      INTEGER*4  CORRPOIN(DISTMAX)
      INTEGER   BLC(4), TRC(4)
      LOGICAL APPLY, NOISE, PLANE, ORDER, SUPP_OPT, CORRM, DO_FIT
      CHARACTER SNAM*40, OPTION*10, DRAW_TEXT*90
      DATA BLC /0,0,0,0/, TRC /0,0,0,0/
*
*     Mean correlations coefficients for samples of 2^N uncorrelated points
*     Values were obtained via Monte-Carlo with N in the 2..14 range.
*
*         4    .4991764      8    .3118043     16    .2089527
*        32    .1440936     64    .1008142    128    .0708915
*       256    .0502991    512    .0354085   1024    .0248185
*      2048    .0175849   4096    .0124901   8192    .0090767
*     16384    .0059821  32768    .0045598  65536    .0031392
*
*     Fairly good approximated by a -.54 power law
*
      SAVE CORRDIST
      SAVE CORRCOEF
*
* Test if a file has been opened
*
      IF (IADDRRECORD.EQ.0) THEN
         CALL MESSAGE(2,1,'BASE','No input file opened')
         ERROR = .TRUE.
         RETURN
      ENDIF
*
* Test if a file has been opened
*
      IF (SCAN_TYPE.NE.2 .AND. SCAN_TYPE.NE.4) THEN
         CALL MESSAGE(2,1,'BASE',
     $   'Only valid on ON-THE-FLY scans ...')
         RETURN
      ENDIF
*
* Support_origin = 1  still same scan
* Support_origin = 0  new scan read in
*
      SUPP_OPT = SIC_PRESENT(5,0)
      IF (.NOT.SUPP_OPT.AND.REFERENCE_SUPPORT.EQ.'MDB'.AND.
     $SUPPORT_ORIGIN.EQ.0) THEN
         CALL MESSAGE (2,1,'BASE',
     $   'The previous support is not defined on a CNV type.')
         CALL MESSAGE (2,1,'BASE',
     $   'You need to redefine a new one ...')
         RETURN
      ENDIF
      NEW_SUPPORT = .TRUE.               ! default value
      OPEN_MDB = .FALSE.                 ! default value
*
* Option /PENCIL
*
      PENCIL_OPT = SIC_PRESENT(8,0)
      IF (SIC_PRESENT(8,1))
     $CALL SIC_I4 (LINE,8,1,COLOR,.TRUE.,ERROR)
*
* Option /CHANNEL
*
      CHANNEL_OPT = SIC_PRESENT(1,0)
      IF (SIC_PRESENT(1,1).AND.SIC_PRESENT(3,0)) THEN
         CALL MESSAGE (2,1,'BASE',
     $   'NOISE and CHANNEL options are mutually exclusive')
         ERROR = .TRUE.
         RETURN
      ENDIF
      CHAN = 1
      IF (TELESCOPE(1:3).EQ.'CSO') CHAN = 12
      IF (SIC_PRESENT(1,1)) THEN
         CALL SIC_I4 (LINE,1,1,CHAN,.TRUE.,ERROR)
         IF (ERROR) GOTO 99
         IF (CHAN.GT.NCHAN.OR.CHAN.LT.1) THEN
            CALL MESSAGE (2,1,'BASE','Bad channel number ')
            ERROR = .TRUE.
            RETURN
         ENDIF
      ENDIF
*
* Option /ORDER
*
      NPAR = 1
      ORDER = SIC_PRESENT(2,0)
      IF (SIC_PRESENT(2,1)) THEN
         CALL SIC_I4 (LINE,2,1,NPAR,.TRUE.,ERROR)
         IF (ERROR) GOTO 99
         NPAR = NPAR+1
         IF (NPAR.LT.1.OR.NPAR.GT.21) THEN
            CALL MESSAGE (2,1,'BASE','Invalid degree of polynomial')
            ERROR = .TRUE.
            RETURN
         ENDIF
      ENDIF
      IF (ORDER) THEN
         ANY_BASE = .TRUE.
      ELSE
         CALL MESSAGE (2,1,'BASE','No baseline to be removed ...')
      ENDIF
*
* Option /CORR, /NOISE and /BYSUBSCAN
*
      PLANE = .NOT.SIC_PRESENT(4,0)
      APPLY = .NOT.SIC_PRESENT(1,1)
      NOISE = SIC_PRESENT(3,0)
      CORRM = SIC_PRESENT(7,0)
      IF (NOISE.AND..NOT.ANY_BASE) THEN
         CALL MESSAGE (2,1,'BASE','Remove baseline first')
         ERROR = .TRUE.
         RETURN
      ENDIF
      IF (CORRM.AND.NOISE) THEN
         CALL MESSAGE (2,1,'BASE',
     $   'NOISE and CORR options are mutually exclusive')
         RETURN
      ENDIF
      NUMBER = 61
      IF (SIC_PRESENT(3,1)) THEN
         CALL SIC_I4 (LINE,3,1,NUMBER,.TRUE.,ERROR)
         IF (ERROR) GOTO 99
         IF (NUMBER.LT.5) THEN
            CALL MESSAGE (2,1,'BASE','Bad correlation time ')
            ERROR = .TRUE.
            RETURN
         ENDIF
      ENDIF
      IF (SIC_PRESENT(7,1)) THEN
         CALL SIC_I4 (LINE,7,1,NUMBER,.TRUE.,ERROR)
         IF (ERROR) GOTO 99
         IF (NUMBER.LT.5) THEN
            CALL MESSAGE (2,1,'BASE','Bad correlation time ')
            ERROR = .TRUE.
            RETURN
         ENDIF
      ENDIF
      RING = 1E5                         ! more than enough
      IF (SIC_PRESENT(3,2)) THEN
         CALL SIC_R4 (LINE,3,2,RING,.TRUE.,ERROR)
         IF (ERROR) GOTO 99
      ENDIF
      RING = ABS(RING)
*
* Support defined by option /FILE
*
      FILE_OPT = SIC_PRESENT(6,0)
      FILE_READ = .TRUE.
      IF (.NOT.FILE_OPT) FILE_READ = .FALSE.
      IF (FILE_OPT) THEN
         CALL MESSAGE (2,1,'BASE',
     $   'Use the SUPPORT command instead of /FILE')
         SUPPORTFILE = 'nic.pol'
         IF (SIC_PRESENT(6,1)) THEN
            CALL SIC_KE (LINE,6,1,SUPPORTNAME,NC,.FALSE.,ERROR)
            IF (ERROR) GOTO 99
            I = INDEX(SUPPORTNAME,'.')
            IF (I.EQ.0) THEN
               CALL SIC_PARSEF(SUPPORTNAME,SUPPORTFILE,' ','.pol')
            ELSE
               SUPPORTFILE = SUPPORTNAME
            ENDIF
            CALL SIC_LOWER(SUPPORTFILE)
            IF (SIC_PRESENT(6,2)) THEN
               CALL SIC_CH (LINE,6,2,OPTION,NC,.TRUE.,ERROR)
               IF (ERROR) THEN
                  GOTO 99
               ELSE
                  IF (OPTION(1:3).EQ.'NEW') THEN
                     FILE_READ = .FALSE.
                  ELSE
                     IF (SUPP_OPT) THEN
                        CALL MESSAGE (2,1,'BASE',
     $                  'Incompatible FILE options')
                        ERROR = .TRUE.
                        GOTO 99
                     ENDIF
                  ENDIF
               ENDIF
            ENDIF
         ELSE
            CALL MESSAGE (2,1,'BASE','Missing FILE option')
            GOTO 99
         ENDIF
      ENDIF
      IF (FILE_READ) THEN
         CALL READ_SUPPORT(SUPPORTFILE,'mdb',
     $   UNUSED8,UNUSED8,UNUSED8,PNT,XU,YU,0,ERROR)
         IF (ERROR) GOTO 99
      ENDIF
      IF (FILE_READ) GOTO 100
*
*  Support already defined by command NIC\SUPPORT
*
      EXIST_SUPPORT = .FALSE.
      PNT = 0
      IF (IADDR_SUPPORT.NE.0) EXIST_SUPPORT = .TRUE.
      IF (EXIST_SUPPORT .AND. .NOT.SUPP_OPT) THEN
         CALL R4TOR4(MEMORY(IP_MDB_SUPPORT),PNT,1)
         IP = IP_MDB_SUPPORT+1
         CALL R4TOR8(MEMORY(IP),XU,PNT)
         IP = IP_MDB_SUPPORT+1+PNT
         CALL R4TOR8(MEMORY(IP),YU,PNT)
         NEW_SUPPORT = .FALSE.
         GOTO 100
      ENDIF
*
* Support defined by cursor or by option /SUPPORT : find map dimension
*
      SNAM = ' '
      WRITE (SNAM(1:4),'(i4.4)') SCAN_NUMBER
      CALL SIC_PARSEF(SNAM,X_FILE,' ','.mdb')
      INQUIRE (FILE=X_FILE,EXIST=EXIST_MDB)
      IF (.NOT.SUPP_OPT .AND. .NOT.EXIST_MDB) THEN
         WRITE (STRING,'(a,1x,i4.4,a)') 'Cannot find file',
     $   SCAN_NUMBER,'.mdb to define support'
         CALL MESSAGE (2,1,'BASE',STRING)
         ERROR = .TRUE.
         RETURN
      ENDIF
*
      IF (EXIST_MDB) THEN
         CALL GDF_GEIS (X_ISLO,ERROR)    ! reserve slot
         CALL GDF_REIS (X_ISLO,X_TYPE,X_FILE,X_FORM,X_SIZE,ERROR)
         IF (ERROR) THEN
            CALL GDF_FRIS (X_ISLO,ERROR) ! free slot
            RETURN
         ENDIF
         CALL GDF_READX (X_ISLO,ERROR)
         CALL GDF_GEMS (X_MSLO,X_ISLO,BLC,TRC,X_ADDR,X_FORM,ERROR)
         IPMAP = POINTER (X_ADDR,MEMORY)
         OPEN_MDB = .TRUE.
         NX = X_DIM(1)
         NY = X_DIM(2)
         LIM_SUPX = ((NX- X_REF1)*X_INC1+X_VAL1)/SEC_TO_RAD
         LIM_SUPY = ((NY- X_REF2)*X_INC2+X_VAL2)/SEC_TO_RAD
         LIM_INFX = ((1 - X_REF1)*X_INC1+X_VAL1)/SEC_TO_RAD
         LIM_INFY = ((1 - X_REF2)*X_INC2+X_VAL2)/SEC_TO_RAD
      ELSE                               ! find xmin,xmax,ymin,ymax
         CALL FIND_XY_LIMITS(MEMORY(IP_SCAN_COORD),
     $   MEMORY(IP_SCAN_COORD+NRECORD),NRECORD,LIM_INFX,LIM_SUPX,
     $   LIM_INFY,LIM_SUPY)
      ENDIF
      LIMIT_STRING = 'LIM -000.000 +000.000 -000.000 +000.000'
      WRITE (LIMIT_STRING(05:12),'(f8.3)') LIM_INFX
      WRITE (LIMIT_STRING(14:21),'(f8.3)') LIM_SUPX
      WRITE (LIMIT_STRING(23:30),'(f8.3)') LIM_INFY
      WRITE (LIMIT_STRING(32:39),'(f8.3)') LIM_SUPY
*
*     Option /SUPPORT            ! /SUPPORT xmin xmax ymin ymax
*
      IF (SUPP_OPT) THEN
         CALL MESSAGE (2,1,'BASE',
     $   'Use the SUPPORT command instead of /SUPPORT')
         CORNER_XLOW = LIM_INFX+12
         CORNER_XUP  = LIM_SUPX-12
         CORNER_YLOW = LIM_INFY+12
         CORNER_YUP  = LIM_SUPY-12
         IF (SIC_PRESENT(5,1)) THEN
            CALL SIC_R4 (LINE,5,1,CORNER_XLOW,.FALSE.,ERROR)
            IF (ERROR) GOTO 99
            CORNER_YUP  = (LIM_INFY+LIM_SUPY)/2-CORNER_XLOW
            CORNER_YLOW = (LIM_INFY+LIM_SUPY)/2+CORNER_XLOW
            CORNER_XUP  = (LIM_INFX+LIM_SUPX)/2-CORNER_XLOW
            CORNER_XLOW = (LIM_INFX+LIM_SUPX)/2+CORNER_XLOW
         ENDIF
         IF (SIC_PRESENT(5,3)) THEN
            CALL SIC_R4 (LINE,5,3,CORNER_XUP,.FALSE.,ERROR)
            IF (ERROR) GOTO 99
            CORNER_XUP = (LIM_INFX+LIM_SUPX)/2-CORNER_XUP
         ENDIF
         IF (SIC_PRESENT(5,2)) THEN
            CALL SIC_R4 (LINE,5,2,CORNER_YLOW,.FALSE.,ERROR)
            IF (ERROR) GOTO 99
            CORNER_YUP = (LIM_INFY+LIM_SUPY)/2-CORNER_YLOW
            CORNER_YLOW =(LIM_INFY+LIM_SUPY)/2+CORNER_YLOW
         ENDIF
         IF (SIC_PRESENT(5,4)) THEN
            CALL SIC_R4 (LINE,5,4,CORNER_YUP,.FALSE.,ERROR)
            IF (ERROR) GOTO 99
            CORNER_YUP = (LIM_INFY+LIM_SUPY)/2-CORNER_YUP
         ENDIF
         XU(1) = CORNER_XLOW
         YU(1) = CORNER_YLOW
         XU(2) = CORNER_XUP
         YU(2) = CORNER_YLOW
         XU(3) = CORNER_XUP
         YU(3) = CORNER_YUP
         XU(4) = CORNER_XLOW
         YU(4) = CORNER_YUP
         XU(5) = CORNER_XLOW
         YU(5) = CORNER_YLOW
         PNT = 5
         SUPPORT_ORIGIN = 1
         GOTO 100
      ENDIF
*
* Plot data (if defining support with cursor)
*
      IF (EXIST_MDB .AND. .NOT.SUPP_OPT .AND. .NOT.FILE_READ .AND.
     $.NOT.EXIST_SUPPORT) THEN
         IF (.NOT.GTG_CURS()) THEN
            CALL MESSAGE(2,1,'BASE','No cursor available')
            GOTO 99
         ENDIF
         CALL MESSAGE (2,1,'BASE',
     $   'Use the SUPPORT command instead ...')
         DO_FIT = .FALSE.
         CALL SIC_LET_LOGI ('DO_FIT',DO_FIT,ERROR)
         CALL GR_EXEC ('clea pl')
*
         DIM(1)=X_DIM(1)
         DIM(2)=X_DIM(2)
         DIM(3)=NCHAN
         WRITE (RGDATA,'(a,i4.4,a)') 'def ima map ',SCAN_NUMBER,
     $   '.mdb read'
         CALL EXEC_ALL(RGDATA)
         WRITE (RGPLOT,'(a,2f11.2)') 'PLOT /SCAL LIN ',X_RMIN, X_RMAX
         WRITE (RGDATA,'(a,i2.2,a)') 'rgdata map[',CHAN,'] /var'
         CALL GR_EXEC (RGDATA)
         CALL GR_EXEC ('lim /rg')
         CALL GR_EXEC ('set box mat')
         CALL GR_EXEC (RGPLOT)
         CALL GR_EXEC ('rgmap q')
         CALL GR_EXEC ('set exp 1.')
         CALL GR_EXEC (LIMIT_STRING)
         CALL GR_EXEC ('box')
         CALL GR_EXEC ('label "Azimuth (arcsec)" /x')
         CALL GR_EXEC ('label "Elevation (arcsec)" /y')
         CALL EXEC_ALL('DEL /VAR MAP')
*
         CODE(1) = 'R'
         PNT = 1
         DO WHILE (CODE(PNT).NE.'E'.AND.CODE(PNT).NE.'*')
            CALL GR_CURS(XCOO,YCOO,X4COO,Y4COO,CODEMOUSE)
            CODE(PNT) = CODEMOUSE
            X4(PNT) = X4COO
            Y4(PNT) = Y4COO
            IF (CODE(PNT).EQ.'R'.OR.CODE(PNT).EQ.'^') THEN
               CALL RELOCATE (XCOO,YCOO)
               XU(1) = XCOO
               YU(1) = YCOO
               XS(1) = XCOO
               YS(1) = YCOO
               PNT = 2
               CODE(PNT) = 'R'           ! dummy
            ELSEIF (CODE(PNT).EQ.'L'.OR.CODE(PNT).EQ.'&') THEN
               IF (PNT.EQ.1) RETURN
               XU(PNT) = XCOO
               YU(PNT) = YCOO
               XS(2) = XCOO
               YS(2) = YCOO
               CALL GR_SEGM ('base',ERROR)
               CALL GR8_CONNECT (2,XS,YS,0D0,-1D0)
               CALL GR_OUT
               XS(1) = XCOO
               YS(1) = YCOO
               PNT = PNT+1
               CODE(PNT) = 'R'           ! dummy
               IF (PNT.GT.MAX_SEG) THEN
                  CALL MESSAGE (2,1,'BASE',
     $            'Internal limit exceeded')
                  RETURN
               ENDIF
            ENDIF
         ENDDO
         IF (PNT.EQ.1) RETURN
         XU(PNT) = XU(1)
         YU(PNT) = YU(1)
         XS(2) = XU(1)
         YS(2) = YU(1)
         CALL GR_SEGM ('base',ERROR)
         CALL GR8_CONNECT (2,XS,YS,0D0,-1D0)
         CALL GR_OUT
         SUPPORT_ORIGIN = 1
      ENDIF
*
* Initialize GONS and BOUND
*
100   DO I=1,PNT
         GONS(I,1) = XU(I)
         GONS(I,2) = YU(I)
         IF (I.LT.PNT) THEN
            GONS(I,3) = XU(I+1)-XU(I)
            GONS(I,4) = YU(I+1)-YU(I)
         ENDIF
      ENDDO
*     BOUND(1) don't need to be initialized
      BOUND(2)= GONS(1,1)
      BOUND(3)= GONS(1,1)
      BOUND(4)= GONS(1,2)
      BOUND(5)= GONS(1,2)
      DO I=2,PNT
         BOUND(2) = MIN(BOUND(2),GONS(I,1))    ! xmin
         BOUND(3) = MAX(BOUND(3),GONS(I,1))    ! xmax
         BOUND(4) = MIN(BOUND(4),GONS(I,2))    ! ymin
         BOUND(5) = MAX(BOUND(5),GONS(I,2))    ! ymax
      ENDDO
*
* Fix number of points per subscan
*
      IP_INP_AZ = IP_SCAN_COORD          ! Azimuth offsets
      IP_INP_EL = IP_INP_AZ+NRECORD      ! Elevation offsets
      IP_TIME = IPSUBSCAN+2*NSUBSCAN
      IER = SIC_GETVM(2*NSUBSCAN+(4+2*NCHAN)*NRECORD,SUBSCAN_LIST)
      IF (IER.NE.1) THEN
         CALL MESSAGE (2,1,'BASE','Memory allocation failure')
         RETURN
      ENDIF
      IP_SUBFIRST = POINTER (SUBSCAN_LIST,MEMORY)
      IP_SUBLAST  = IP_SUBFIRST+NSUBSCAN
      IP_OUT_SI   = IP_SUBLAST+NSUBSCAN
      IP_OUT_AZ   = IP_OUT_SI+NRECORD
      IP_OUT_EL   = IP_OUT_AZ+NRECORD
*
      IP_WEIGHT   = IP_OUT_EL+NRECORD
      IP_NOISE    = IP_WEIGHT+NRECORD
      IP_INSIDE   = IP_NOISE +NRECORD*NCHAN
*
      CALL R4TOR4(MEMORY(IP_INP_AZ),MEMORY(IP_OUT_AZ),NRECORD)
      CALL R4TOR4(MEMORY(IP_INP_EL),MEMORY(IP_OUT_EL),NRECORD)
*
      IF (APPLY) THEN
         I1=1
         I2=NCHAN
      ELSE
         I1=CHAN
         I2=CHAN
      ENDIF
*
      IF (PLANE) THEN
         HOW_MUCH = 4*NRECORD
         IER = SIC_GETVM (2*HOW_MUCH,XYWEIB_BUFFER)  ! 2 = double precision
      ELSE
         MAX_SUBREC=0
         DO I=1,NSUBSCAN
            CALL R4TOR4(MEMORY(IPSUBREC+I-1),N,1)
            IF (N.GT.MAX_SUBREC) MAX_SUBREC = N
         ENDDO
         HOW_MUCH = 4*MAX_SUBREC         ! 4 work arrays
         IER = SIC_GETVM (2*HOW_MUCH,XYWEIB_BUFFER)  ! 2 = double precision
      ENDIF
      IF (IER.NE.1) THEN
         CALL MESSAGE (2,1,'SOLVE','Memory allocation failure')
         RETURN
      ENDIF
      IPWORK_X   = POINTER (XYWEIB_BUFFER,MEMORY)
      IPWORK_Y   = IPWORK_X   + 2*HOW_MUCH/4
      IPWORK_WEI = IPWORK_Y   + 2*HOW_MUCH/4
      IPWORK_B   = IPWORK_WEI + 2*HOW_MUCH/4
*
      CALL SIC_GET_LOGI ('DO_FIT',DO_FIT,ERROR)
      DO I=I1,I2
         IF (.NOT.RECEIVER_FLAG(I)) THEN
            IP_INP_SI = IP_SIGNAL + (I-1)*NRECORD
            CALL R4TOR4(MEMORY(IP_INP_SI),MEMORY(IP_OUT_SI),NRECORD)
            CALL REMOVE_BASELINE (MEMORY(IP_OUT_AZ),MEMORY(IP_OUT_EL),
     $      MEMORY(IP_TIME),MEMORY(IP_LST),MEMORY(IPSUBREC),
     $      MEMORY(IP_OUT_SI),GONS,PNT,BOUND,NPAR,
     $      MEMORY(IPWORK_X),MEMORY(IPWORK_Y),MEMORY(IPWORK_WEI),
     $      MEMORY(IPWORK_B),MEMORY(IP_EL),MEMORY(IP_AZOFF),
     $      MEMORY(IP_ELOFF),MEMORY(IP_INSIDE+(I-1)*NRECORD),
     $      PLANE,I,CHAN,ERROR,QUALITY,ORDER,EXIST_SUPPORT,DO_FIT)
            IF (QUALITY.EQ.1) THEN
               WRITE (STRING,'(A,I2)') 'Missed supports for channel ',I
               CALL MESSAGE (2,2,'BASE',STRING)
            ELSEIF (QUALITY.EQ.2) THEN
               WRITE (STRING,'(A,I2)') 'Poor supports for channel ',I
               CALL MESSAGE (2,2,'BASE',STRING)
            ENDIF
            CALL R4TOR4(MEMORY(IP_OUT_SI),MEMORY(IP_INP_SI),NRECORD)
         ENDIF
      ENDDO
      DO_FIT = .FALSE.
      CALL SIC_LET_LOGI ('DO_FIT',DO_FIT,ERROR)
      CALL FREE_VM (2*HOW_MUCH,XYWEIB_BUFFER)
*
* IF ((ORDER.OR.NOISE.OR.SUPP_OPT).AND..NOT.CORRM)
* $CALL MESSAGE (2,1,'BASE','Variable CHAN_RMS updated ...')
*
*     NOISE_REMOVAL_FLAG = .FALSE. ! default initialization
      IF ((NOISE.OR.CORRM).AND.SCAN_TYPE.NE.4) THEN
         DO I=1,DISTMAX
            CORRDIST(I) = 0
            CORRCOEF(I) = 0
            CORRPOIN(I) = 0
         ENDDO
         IF (NOISE)
     $   CALL MESSAGE (4,1,'BASE','Noise removal is experimental ...')
         DO I=I1,I2
            IF (.NOT.RECEIVER_FLAG(I)) THEN
               CALL COMPUTE_RMS (MEMORY(IP_SIGNAL+(I-1)*NRECORD),
     $         MEMORY(IP_INSIDE+(I-1)*NRECORD),
     $         MEMORY(IP_RMS+I-1),NRECORD)
            ENDIF
         ENDDO
*
         DO I=I1,I2
            IF (.NOT.RECEIVER_FLAG(I)) THEN
               CALL GET_NOISE (I,MEMORY(IP_INSIDE),
     $         MEMORY(IP_SIGNAL),
     $         MEMORY(IP_NOISE+(I-1)*NRECORD),
     $         MEMORY(IP_WEIGHT),MEMORY(IP_RMS+I-1),
     $         CORRDIST,CORRCOEF,CORRPOIN,NUMBER,RING)
            ENDIF
         ENDDO
         IF (CORRM.OR.NOISE) THEN
            K = 0
            DO WHILE (CORRDIST(K+1).NE.0)
               K = K+1
               IF (CORRPOIN(K).NE.0) THEN
                  CORRCOEF(K) = CORRCOEF(K)/CORRPOIN(K)
               ELSE
                  CORRCOEF(K) = 0
               ENDIF
            ENDDO
            CALL SIC_DELVARIABLE ('corr_coef',.FALSE.,ERROR)
            CALL SIC_DELVARIABLE ('corr_dist',.FALSE.,ERROR)
            DIM(1) = K
            CALL SIC_DEF_REAL ('corr_coef',CORRCOEF(1),
     $      1,DIM,.TRUE.,ERROR)
            CALL SIC_DEF_REAL ('corr_dist',CORRDIST(1),
     $      1,DIM,.TRUE.,ERROR)
            CALL GR_EXEC1 ('PEN 0 /COL 0')
            CALL GR_EXEC1 ('SET EXP 1.0')
            CALL GR_EXEC1
     $      ('LIMIT * * -.05 1.05 /VAR CORR_DIST CORR_COEF')
            CALL GR_EXEC1
     $      ('LIMIT = = < = /VAR CORR_DIST CORR_COEF')
            CALL GR_EXEC1 ('SET BOX 4 26 4 16')
            IF (.NOT.PENCIL_OPT.OR.NOISE) CALL GR_EXEC ('CLEAR PL')
            CALL GR_EXEC1 ('BOX')
            CALL GR_EXEC1
     $      ('LABEL "BEAM SEPARATION (ARCSEC)" /X')
            CALL GR_EXEC1
     $      ('LABEL "MEAN CORRELATION COEFFICIENT" /Y')
            IF (NOISE) THEN
               CALL GR_EXEC1 ('PEN 0 /COL 13')
               CALL GR_EXEC1 ('POINT CORR_DIST CORR_COEF')
            ELSE
               IF (PENCIL_OPT) THEN
                  PENCIL_TEXT = 'PEN 0 /COL xx'
                  WRITE (PENCIL_TEXT(12:13),'(I2)') COLOR
                  CALL GR_EXEC1 (PENCIL_TEXT)
               ENDIF
               CALL GR_EXEC1 ('POINT CORR_DIST CORR_COEF')
            ENDIF
            DRAW_TEXT = 'draw rel user_xmin x.xx /user'
            WRITE (DRAW_TEXT(20:23),'(F4.2)') NUMBER**(-.54)
            CALL GR_EXEC1 (DRAW_TEXT)
            CALL GR_EXEC1 ('pen 0 /dash 3')
            DRAW_TEXT = 'draw lin user_xmax x.xx /user'
            WRITE (DRAW_TEXT(20:23),'(F4.2)') NUMBER**(-.54)
            CALL GR_EXEC1 (DRAW_TEXT)
            CALL GR_EXEC1 ('pen 0 /dash 1 /col 0')
         ENDIF
*
         DO I=I1,I2
            IF (.NOT.RECEIVER_FLAG(I)) THEN
               IF (.NOT.CORRM) THEN
                  CALL REMOVE_NOISE (I,MEMORY(IP_SIGNAL),
     $            MEMORY(IP_NOISE+(I-1)*NRECORD))
                  NOISE_REMOVAL_FLAG = .TRUE.
               ENDIF
            ENDIF
         ENDDO
      ENDIF
*
* Noise suppression for POINTING scans
*
      IF (CORRM.AND.SCAN_TYPE.EQ.4) THEN
         CALL MESSAGE(2,1,'BASE',
     $   'CORR option not available for POINTING scans')
         RETURN
      ENDIF
      IF (NOISE.AND.SCAN_TYPE.EQ.4) THEN
*
* Compute rms
*
         DO I=I1,I2
            IF (.NOT.RECEIVER_FLAG(I)) THEN
               CALL COMPUTE_RMS (MEMORY(IP_SIGNAL +(I-1)*NRECORD),
     $         MEMORY(IP_INSIDE+(I-1)*NRECORD),
     $         MEMORY(IP_RMS+I-1),NRECORD)
            ENDIF
         ENDDO
         DO ICHAN=I1,I2
            IF (.NOT.RECEIVER_FLAG(I)) THEN
               CALL COMPUTE_NOISE_POINTING(MEMORY(IP_SIGNAL),
     $         MEMORY(IP_INSIDE), MEMORY(IP_RMS),
     $         MEMORY(IP_NOISE+(ICHAN-1)*NRECORD),
     $         MEMORY(IP_WEIGHT),ICHAN)
            ENDIF
            CALL REMOVE_NOISE (ICHAN,MEMORY(IP_SIGNAL),
     $      MEMORY(IP_NOISE+(ICHAN-1)*NRECORD))
            NOISE_REMOVAL_FLAG = .TRUE.
         ENDDO
      ENDIF
*
* Compute rms
      DO I=I1,I2
         IF (.NOT.RECEIVER_FLAG(I)) THEN
            CALL COMPUTE_RMS (MEMORY(IP_SIGNAL +(I-1)*NRECORD),
     $      MEMORY(IP_INSIDE+(I-1)*NRECORD),
     $      MEMORY(IP_RMS+I-1),NRECORD)
         ENDIF
      ENDDO
      CALL MESSAGE (2,1,'BASE','Variable CHAN_RMS updated ...')
      IF (NOISE) THEN
         DO I=1,DISTMAX
            CORRDIST(I) = 0
            CORRCOEF(I) = 0
            CORRPOIN(I) = 0
         ENDDO
         DO I=I1,I2
            IF (.NOT.RECEIVER_FLAG(I)) THEN
               CALL GET_NOISE (I,MEMORY(IP_INSIDE),
     $         MEMORY(IP_SIGNAL),
     $         MEMORY(IP_NOISE+(I-1)*NRECORD),
     $         MEMORY(IP_WEIGHT),MEMORY(IP_RMS+I-1),
     $         CORRDIST,CORRCOEF,CORRPOIN,NUMBER,RING)
            ENDIF
         ENDDO
         K = 0
         DO WHILE (CORRDIST(K+1).NE.0)
            K = K+1
            IF (CORRPOIN(K).NE.0) THEN
               CORRCOEF(K) = CORRCOEF(K)/CORRPOIN(K)
            ELSE
               CORRCOEF(K) = 0
            ENDIF
         ENDDO
         CALL SIC_DELVARIABLE ('corr_coef',.FALSE.,ERROR)
         CALL SIC_DELVARIABLE ('corr_dist',.FALSE.,ERROR)
         DIM(1) = K
         CALL SIC_DEF_REAL ('corr_coef',CORRCOEF(1),
     $   1,DIM,.TRUE.,ERROR)
         CALL SIC_DEF_REAL ('corr_dist',CORRDIST(1),
     $   1,DIM,.TRUE.,ERROR)
         CALL GR_EXEC ('SET EXP 1.0')
         CALL GR_EXEC1
     $   ('LIMIT * * -.05 1.05 /VAR CORR_DIST CORR_COEF')
         CALL GR_EXEC1
     $   ('LIMIT = = < = /VAR CORR_DIST CORR_COEF')
         CALL GR_EXEC1 ('SET BOX 4 26 4 16')
         CALL GR_EXEC1 ('BOX')
         CALL GR_EXEC1 ('POINT CORR_DIST CORR_COEF')
         DRAW_TEXT = 'draw text user_xmin user_ymax*1.05 '//
     $   '"\\IGREY before, BLACK after noise removal" 6 /user'
         CALL GR_EXEC1 (DRAW_TEXT)
         DRAW_TEXT = 'draw rel user_xmin x.xx /user'
         WRITE (DRAW_TEXT(20:23),'(F4.2)') NUMBER**(-.54)
         CALL GR_EXEC1 (DRAW_TEXT)
         CALL GR_EXEC1 ('pen 0 /dash 3')
         DRAW_TEXT = 'draw lin user_xmax x.xx /user'
         WRITE (DRAW_TEXT(20:23),'(F4.2)') NUMBER**(-.54)
         CALL GR_EXEC1 (DRAW_TEXT)
         CALL GR_EXEC1 ('pen 0 /dash 1')
      ENDIF
*
* Update support variable (if new support has been defined)
*
      IF (NEW_SUPPORT) THEN
* -- Allocate memory
         IF (IADDR_SUPPORT.NE.0) THEN
            CALL SIC_DELVARIABLE('support_mdb',.FALSE.,ERROR)
            CALL SIC_DELVARIABLE('support_ekh',.FALSE.,ERROR)
            CALL SIC_DELVARIABLE('support_saa',.FALSE.,ERROR)
            CALL SIC_DELVARIABLE('support_cnv',.FALSE.,ERROR)
            CALL SIC_DELVARIABLE('support_mosaic',.FALSE.,ERROR)
            CALL SIC_DELVARIABLE('support',.FALSE.,ERROR)
            CALL FREE_VM(LENGTH_SUPPORT,IADDR_SUPPORT)
         ENDIF
         LENGTH_SUPPORT = 2*PNT+1        ! cnv buffers
         IER = SIC_GETVM(LENGTH_SUPPORT,IADDR_SUPPORT)
         IF (IER.NE.1) THEN
            WRITE(6,*)' *** Unable to allocate memory ***'
         ENDIF
         IP_CNV_SUPPORT = POINTER(IADDR_SUPPORT,MEMORY)
         DIM(1) = PNT
         DIM(2) = 2
         DIM(3) = NCHAN
         CALL SIC_DEF_REAL ('support_cnv',MEMORY(IP_CNV_SUPPORT+1),
     $   2,DIM,.FALSE.,ERROR)
         CALL SIC_DEF_REAL ('support_ekh',MEMORY(IP_EKH_SUPPORT+1),
     $   3,DIM,.FALSE.,ERROR)
         CALL SIC_DEF_REAL ('support_saa',MEMORY(IP_EKH_SUPPORT+1),
     $   3,DIM,.FALSE.,ERROR)
         CALL SIC_DEF_REAL ('support_mdb',MEMORY(IP_MDB_SUPPORT+1),
     $   3,DIM,.FALSE.,ERROR)
         REFERENCE_SUPPORT = 'MDB'
         CALL SIC_DEF_CHAR ('support',REFERENCE_SUPPORT,.TRUE.,ERROR)
*
* -- Compute RA_DAY,DEC_DAY of scan
         RA_FROM_SCAN = SOURCE_LAMBDA + OLAM/DEG_TO_RAD
         DEC_FROM_SCAN = SOURCE_BETA + OBET/DEG_TO_RAD
         EPOCHFR = EPOCH
         CALL R4TOR8(MEMORY(IPSUBSCAN+NSUBSCAN),EPOCHTO,1)
         CALL PRECMAT(EPOCHFR,EPOCHTO,AMAT)    ! compute precession matrix
         CALL DCOSIN(RA_FROM_SCAN,DEC_FROM_SCAN,AVEC)! compute vector
         CALL MATMUL(AMAT,AVEC,BVEC,-9)  ! multiply by precession matrix
         CALL DANGLE(RA_DAY_SCAN,DEC_DAY_SCAN,BVEC)  !
         LATI = SITE_LATITUDE/DEG_TO_RAD
*
* -- Update mdb_support buffer
         CALL R4TOR4(PNT,MEMORY(IP_MDB_SUPPORT),1)
         IF (FILE_READ) THEN
            DO ICHAN=NCHAN,1,-1
               CALL  READ_SUPPORT(SUPPORTFILE,'mdb',UNUSED8,
     $         UNUSED8,UNUSED8,PNT,XU,YU,CHAN,ERROR)
               CALL R8TOR4(XU,
     $         MEMORY(IP_MDB_SUPPORT+1+2*PNT*(ICHAN-1)),PNT)
               CALL R8TOR4(YU,
     $         MEMORY(IP_MDB_SUPPORT+1+PNT+2*PNT*(ICHAN-1)),PNT)
            ENDDO
         ELSE
            CALL SHIFT_MAP (XU, YU, PNT, MEMORY(IP_MDB_SUPPORT+1),
     $      MEMORY(IP_EL),MEMORY(IP_SCAN_COORD+NRECORD),
     $      MEMORY(IP_AZOFF),MEMORY(IP_ELOFF),MEMORY(IPSUBREC),
     $      NCHAN,NSUBSCAN,CHAN,TELESCOPE)
         ENDIF
*     Update ekh_support buffer
         CALL R4TOR4(PNT,MEMORY(IP_EKH_SUPPORT),1)
         CALL R4TOR4(MEMORY(IP_MDB_SUPPORT+1),
     $   MEMORY(IP_EKH_SUPPORT+1),2*PNT*NCHAN)
*     Update cnv_support buffer
         CALL R4TOR4(PNT,MEMORY(IP_CNV_SUPPORT),1)
         CALL TRANSFORM_EKH_TO_CNV(XU,YU,PNT,
     $   MEMORY(IP_CNV_SUPPORT+1),
     $   RA_DAY_SCAN,DEC_DAY_SCAN,LATI,
     $   MEMORY(IP_LST),MEMORY(IP_SCAN_COORD+NRECORD),
     $   MEMORY(IPSUBREC),NCHAN,NSUBSCAN,NRECORD)
*
         RA_FROM_INPUT  = RA_FROM_SCAN
         DEC_FROM_INPUT = DEC_FROM_SCAN
         EPOCHFR_INPUT  = EPOCH
      ENDIF
*
* Consider flagged channels or reference channels
*
      CALL  BLANK_SUPPORT (MEMORY(IP_MDB_SUPPORT+1),
     $MEMORY(IP_EKH_SUPPORT+1),MEMORY(IP_MDB_SUPPORT),
     $MEMORY(IP_EKH_SUPPORT),MEMORY(IP_FLAG),
     $CHANNEL_OPT,CHAN,BLANKING,NCHAN)
*
*
* Save support in file
*
      IF (FILE_OPT.AND..NOT.FILE_READ) THEN
         CALL WRITE_SUPPORT(SUPPORTFILE,LINE,SCAN_NUMBER,'mdb',
     $   UNUSED8,UNUSED8,UNUSED8,
     $   MEMORY(IP_MDB_SUPPORT),MEMORY(IP_MDB_SUPPORT+1),NCHAN)
      ENDIF
*
* Free memory
*
      CALL FREE_VM (2*NSUBSCAN+(4+2*NCHAN)*NRECORD,SUBSCAN_LIST)
      IF (OPEN_MDB) CALL GDF_FRIS (X_ISLO,ERROR)
      RETURN
*
* End
*
99    IF (OPEN_MDB) CALL GDF_FRIS (X_ISLO,ERROR)
      ERROR = .TRUE.
      RETURN
      END
*
********************************************************************
*
      SUBROUTINE REMOVE_BASELINE (SCAN_AZ,SCAN_EL,SUBSCAN_TIME,LST,
     $NSUBREC,SIGNAL,GONS,PNT,BOUND,NPAR,X,Y,
     $WEI,B,EL_RECORD,OA,OE,INSIDE,PLANE,IC,CHAN,ERROR,QUALITY,
     $ORDER,EXIST_SUPPORT,DO_FIT)
*
      INCLUDE 'nic.inc'
      INCLUDE 'parameter.inc'
      INCLUDE 'par.inc'
      INCLUDE 'const.inc'
*
      INTEGER*4  IPU, IPV, IPW, IPC, WORK1, POINTER,IP
      INTEGER*4  BASE, BASEY, IND, DESC(9)
      INTEGER  MAX_SEG, MMAX, BOX(1)
      PARAMETER (MAX_SEG = 100, MMAX = 21)
      REAL*8   GONS(MAX_SEG,4), XCOO, YCOO, BOUND(5), BASE_OFF
      REAL*8   X(NRECORD), Y(NRECORD), WEI(NRECORD), B(NRECORD)
      REAL*8   XMIN, XMAX, XX, CHISQ, A(MMAX), P(MMAX)
      INTEGER  I, J, L, PNT
      INTEGER  NPAR
      LOGICAL  INSIDE(NRECORD), ORDER, FOUND, DO_FIT
      INTEGER  SIC_GETVM, IER, QUALITY
      REAL*4   YMIN, YMAX, YY
      REAL*4   SUBSCAN_TIME(NSUBSCAN), LST(NRECORD)
      REAL*4   SIGNAL(NRECORD)
      REAL*4   SCAN_AZ(NRECORD), SCAN_EL(NRECORD)
      LOGICAL  GR8_IN, IN, ERROR, PLANE, EXIST_SUPPORT, PLOTIT
      REAL*4   EL_RECORD(NRECORD), OA(1), OE(1), EL, SIN_EL, COS_EL
      INTEGER  NSUBREC(NSUBSCAN)
      INTEGER  IC, CHAN, LENGTH,IFIRST,ILAST,NUM
      CHARACTER ERROR_MESS*80, TEXT*20
      EXTERNAL FCHEB
*
*
      QUALITY = 0
*
* --- /BYSUBSCAN option
*
      IF (.NOT.PLANE) THEN
c         CALL FIND_SUBSCAN_RAWLIMIT(SUBSCAN_IFIRST,
c     $   SUBSCAN_ILAST,SCAN_EL,SINT,NSUBSCAN,NRECORD)  ! data not continuous
*                                                       ! on drumbeat files
* Plot baseline, if possible
*
         FOUND = .FALSE.
         CALL SIC_GET_CHAR('COMMAND',TEXT,LENGTH,ERROR)
         IF (.NOT.ERROR.AND.INDEX(TEXT,"SIGNAL").NE.0) THEN
            CALL SIC_GET_CHAR('XTYPE',TEXT,LENGTH,ERROR)
            IF (.NOT.ERROR.AND.INDEX(TEXT,"LST").NE.0) THEN
               CALL SIC_DESCRIPTOR ('BOXES',DESC,FOUND)
               IF (FOUND) THEN
                  IER = SIC_GETVM(NRECORD,BASE)
                  BASEY = POINTER(BASE,MEMORY)
               ENDIF
            ENDIF
         ENDIF
         IFIRST = 1
         DO I=1,NSUBSCAN
            L = 0
            IF (I.NE.1) IFIRST = IFIRST+NSUBREC(I-1)
            ILAST = IFIRST + NSUBREC(I) - 1
            DO J=IFIRST,ILAST
               EL = FIELD_ROTATION*EL_RECORD(J)*DEG_TO_RAD
               COS_EL = COS(EL)
               SIN_EL = SIN(EL)
               IF (TELESCOPE(1:3).EQ.'CSO') THEN
                  COS_EL = 1             ! no rotation
                  SIN_EL = 0
               ENDIF
               XCOO = SCAN_AZ(J)/10D0
     $         -(OA(IC)-OA(CHAN))*COS_EL -(OE(IC)-OE(CHAN))*SIN_EL
               YCOO = SCAN_EL(J)/10D0
     $         +(OA(IC)-OA(CHAN))*SIN_EL -(OE(IC)-OE(CHAN))*COS_EL
               IN = GR8_IN (XCOO,YCOO,MAX_SEG,PNT-1,GONS,BOUND)
               INSIDE(J) = IN
               IF ((IN.EQV..FALSE.) .AND. SIGNAL(J).NE.BLANKING) THEN
                  L = L+1
                  X(L) = LST(J)
                  Y(L) = SIGNAL(J)
                  WEI(L) = 1D0
                  IF (L.NE.1) THEN
*
* 4 arcsec averaging
*
                     IF (LST(J)-X(L-1).LE.0.52) THEN
                        L = L-1
                        X(L) = (X(L)+LST(J))/2
                        Y(L) = (Y(L)+SIGNAL(J))/2
                        WEI(L) = SQRT(2.0)
                     ENDIF
                  ENDIF
               ENDIF
            ENDDO
            IF (.NOT.ORDER) RETURN
*
            IF (L.GE.2) THEN
               XMIN = X(1)
               XMAX = X(L)
               DO  J=1,L
                  X(J) = (2*X(J)-XMIN-XMAX)/(XMAX-XMIN)
               ENDDO
               IER = SIC_GETVM(2*NPAR*(NPAR+L+2)+2,WORK1)
               IF (IER.EQ.1) THEN
                  IPU = POINTER(WORK1,MEMORY)
                  IPV = IPU+2*L*NPAR
                  IPW = IPV+2*NPAR*NPAR
                  IPC = IPW+2*NPAR
                  CALL SVDFIT (X,Y,WEI,L,A,NPAR,MEMORY(IPU),
     $            MEMORY(IPV),MEMORY(IPW),L,NPAR,CHISQ,FCHEB,B,
     $            MEMORY(IPC),ERROR)
                  CALL FREE_VM(2*NPAR*(NPAR+L+2)+2 ,WORK1)
                  IF (ERROR) THEN
                     CALL MESSAGE(6,3,'BASE',
     $               'Error in singular value decomposition')
                     RETURN
                  ENDIF
               ELSE
                  CALL MESSAGE(6,3,'BASE',
     $            'Reduce support area [memory allocation failure]')
                  RETURN
               ENDIF
*
*     Compute baseline value for edges
*
               YMIN = BASE_OFF (-1D0,A,P,NPAR)
               YMAX = BASE_OFF (+1D0,A,P,NPAR)
*
*     Compute polynomial in fitting range, constant value outside that range.
*
               IF (NPAR.GT.2) THEN
*
*     Degree > 1
*
                  DO J= IFIRST,ILAST
                     XX = ((LST(J)-XMIN)-(XMAX-LST(J)))/(XMAX-XMIN)
                     IF (XX.LE.-1D0) THEN
                        YY = YMIN
                     ELSEIF (XX.GE.1D0) THEN
                        YY = YMAX
                     ELSE
                        YY = BASE_OFF(XX,A,P,NPAR)
                     ENDIF
                     IF (SIGNAL(J).NE.BLANKING) THEN
                        SIGNAL(J) = SIGNAL(J)-YY
                     ENDIF
                     IP = BASEY+J-1
                     IF (FOUND) CALL R4TOR4 (YY,MEMORY(IP),1)
                  ENDDO
               ELSE
*
*     Degree 0 or 1 : Compute polynomial everywhere
*
                  DO J=IFIRST,ILAST
                     XX = ((LST(J)-XMIN)-(XMAX-LST(J)))/(XMAX-XMIN)
                     YY = YMIN + (XX+1.0)*(YMAX-YMIN)/2.0
                     IF (SIGNAL(J).NE.BLANKING) THEN
                        SIGNAL(J) = SIGNAL(J) - YY
                     ENDIF
                     IP = BASEY+J-1
                     IF (FOUND) CALL R4TOR4 (YY,MEMORY(IP),1)
                  ENDDO
               ENDIF
               IF (L.LT.5) QUALITY = 2
            ELSE
               QUALITY = 1
            ENDIF
         ENDDO
         IF (FOUND.AND.DO_FIT) THEN
            CALL GR_EXEC ('PEN 1')
            CALL GR_SEGM ('plot',ERROR)
            IND = POINTER(DESC(2), BOX)
            NUM = DESC(5)
            CALL FIX_POS (BOX(IND),NUM,IC,PLOTIT)
            IF (PLOTIT)
     $      CALL GR4_CONNECT(NRECORD,LST,MEMORY(BASEY),0.,-1.)
            CALL GR_OUT
            CALL GR_EXEC ('PEN 0')
            CALL FREE_VM (NRECORD,BASE)
         ENDIF
      ELSE
*
* --- Plane baseline
*
         L = 0
         DO J=1,NRECORD
            EL = FIELD_ROTATION*EL_RECORD(J)*DEG_TO_RAD
            COS_EL = COS(EL)
            SIN_EL = SIN(EL)
            IF (TELESCOPE(1:3).EQ.'CSO') THEN
               COS_EL = 1                ! no rotation
               SIN_EL = 0
            ENDIF
            XCOO = SCAN_AZ(J)/10D0
     $      -(OA(IC)-OA(CHAN))*COS_EL -(OE(IC)-OE(CHAN))*SIN_EL
            YCOO = SCAN_EL(J)/10D0
     $      +(OA(IC)-OA(CHAN))*SIN_EL -(OE(IC)-OE(CHAN))*COS_EL
            IN = GR8_IN (XCOO,YCOO,MAX_SEG,PNT-1,GONS,BOUND)
            INSIDE(J) = IN
            IF ((IN.EQV..FALSE.) .AND. SIGNAL(J).NE.BLANKING) THEN
               L = L+1
               X(L) = LST(J)
               Y(L) = SIGNAL(J)
               WEI(L) = 1.0
*
* 4 arcsec averaging
*
               IF (L.NE.1) THEN
                  IF (LST(J)-X(L-1).LE.0.52) THEN
                     L = L-1
                     X(L) = (X(L)+LST(J))/2
                     Y(L) = (Y(L)+SIGNAL(J))/2
                     WEI(L) = SQRT(2.0)
                  ENDIF
               ENDIF
            ENDIF
         ENDDO
         IF (.NOT.ORDER) RETURN
*
         IF (L.EQ.0) THEN
            ERROR_MESS = 'No point to define '//
     $      'baseline for channel xx. Change support.'
            WRITE(ERROR_MESS(41:42),'(i2)') IC
            CALL MESSAGE(6,3,'BASE',ERROR_MESS)
            ERROR = .TRUE.
            RETURN
         ENDIF
*      write (6,'(i7,a)') 2*NPAR*(NPAR+L+2)/1024,' Kbyte'
*
         XMIN = X(1)
         XMAX = X(L)
         DO J=1,L
            X(J) = (2*X(J)-XMIN-XMAX)/(XMAX-XMIN)
         ENDDO
         IER = SIC_GETVM(2*NPAR*(NPAR+L+2)+2,WORK1)
         IF (IER.EQ.1) THEN
            IPU = POINTER(WORK1,MEMORY)
            IPV = IPU+2*L*NPAR
            IPW = IPV+2*NPAR*NPAR
            IPC = IPW+2*NPAR
            CALL SVDFIT (X,Y,WEI,L,A,NPAR,MEMORY(IPU),
     $      MEMORY(IPV),MEMORY(IPW),L,NPAR,CHISQ,FCHEB,B,
     $      MEMORY(IPC),ERROR)
            CALL FREE_VM(2*NPAR*(NPAR+L+2)+2,WORK1)
            IF (ERROR) THEN
               CALL MESSAGE(6,3,'BASE',
     $         'Error in singular value decomposition')
               RETURN
            ENDIF
         ELSE
            CALL MESSAGE(6,3,'BASE',
     $      'Reduce support area [memory allocation failure]')
            RETURN
         ENDIF
*
*     Compute baseline value for edges
*
         YMIN = BASE_OFF (-1D0,A,P,NPAR)
         YMAX = BASE_OFF (+1D0,A,P,NPAR)
*
         IF (NPAR.GT.2) THEN
*
*     Degree > 1
*     Compute polynomial in fitting range, constant value outside that range.
*
            DO J=1,NRECORD
               IF (SIGNAL(J).NE.BLANKING) THEN
                  XX = ((LST(J)-XMIN)-(XMAX-LST(J)))/(XMAX-XMIN)
                  IF (XX.LE.-1D0) THEN
                     YY = YMIN
                  ELSEIF (XX.GE.1D0) THEN
                     YY = YMAX
                  ELSE
                     YY = BASE_OFF (XX,A,P,NPAR)
                  ENDIF
                  SIGNAL(J) = SIGNAL(J) - YY
               ENDIF
            ENDDO
         ELSE
*
*     Degree 0 or 1 : Compute polynomial everywhere
*
            DO J=1,NRECORD
               IF (SIGNAL(J).NE.BLANKING) THEN
                  XX = ((LST(J)-XMIN)-(XMAX-LST(J)))/(XMAX-XMIN)
                  YY = YMIN + (XX+1.0)*(YMAX-YMIN)/2.0
                  SIGNAL(J) = SIGNAL(J) - YY
               ENDIF
            ENDDO
         ENDIF
*
* Plot baseline, if possible
*
         CALL SIC_GET_CHAR('COMMAND',TEXT,LENGTH,ERROR)
         IF (.NOT.ERROR.AND.INDEX(TEXT,"SIGNAL").NE.0) THEN
            CALL SIC_GET_CHAR('XTYPE',TEXT,LENGTH,ERROR)
            IF (.NOT.ERROR.AND.INDEX(TEXT,"LST").NE.0) THEN
               CALL SIC_DESCRIPTOR ('BOXES',DESC,FOUND)
               IF (FOUND.AND.DO_FIT) THEN
                  IER = SIC_GETVM(NRECORD,BASE)
                  BASEY = POINTER(BASE,MEMORY)
                  DO J=1,NRECORD
                     XX = ((LST(J)-XMIN)-(XMAX-LST(J)))/(XMAX-XMIN)
                     IF (XX.LE.-1D0) THEN
                        YY = YMIN
                     ELSEIF (XX.GE.1D0) THEN
                        YY = YMAX
                     ELSE
                        YY = BASE_OFF (XX,A,P,NPAR)
                     ENDIF
                     IP=BASEY+J-1
                     CALL R4TOR4 (YY,MEMORY(IP),1)
                  ENDDO
                  CALL GR_EXEC ('PEN 1')
                  CALL GR_SEGM ('plot',ERROR)
                  IND = POINTER(DESC(2), BOX)
                  NUM = DESC(5)
                  CALL FIX_POS (BOX(IND),NUM,IC,PLOTIT)
                  IF (PLOTIT) CALL
     $            GR4_CONNECT(NRECORD,LST,MEMORY(BASEY),0.,-1.)
                  CALL GR_OUT
                  CALL GR_EXEC ('PEN 0')
                  CALL FREE_VM (NRECORD,BASE)
               ENDIF
            ENDIF
         ENDIF
      ENDIF
      ERROR = .FALSE.
      RETURN
      END
*-----------------------------------------------------------------------*
C+HPUX
c$OPTIMIZE LEVEL1
C-HPUX
      SUBROUTINE GET_NOISE (CHAN,INSIDE,SIGNAL,NOISE,WEIGHT,RMS,
     $CORRDIST,CORRCOEF,CORRPOIN,NUMBER,RING)
*
      INCLUDE 'nic.inc'
      INCLUDE 'parameter.inc'
      INCLUDE 'par.inc'
      INCLUDE 'const.inc'
*
      INTEGER*4 DISTMAX, NUMBER
      REAL*4    RING
      PARAMETER (DISTMAX=NREC*(NREC-1)/2)
      REAL*4 DAZ, DEL, SEP, RMS(NCHAN), LINCORR, COEFFICIENT
      REAL*4 SIGNAL(1), VAL, NOISE(NRECORD),WEIGHT(NRECORD)
      REAL*4 CORRDIST(DISTMAX), CORRCOEF(DISTMAX), SL1, SL2
**      REAL*4 SLOPE(NREC,2)
      INTEGER*4  CORRPOIN(DISTMAX)
      LOGICAL INSIDE(1)
      INTEGER CHAN, I, J, K, IP1, IP2 , JJ
*
      INTEGER  FIRST_POINT
      COMMON   /LINCORR_COMMON/FIRST_POINT
      SAVE     /LINCORR_COMMON/
*
      DO I=1,NRECORD
         NOISE(I) = 0
         WEIGHT(I) = 0
      ENDDO
*
**      DO I=1,NREC
**         SLOPE(I,1) = 0
**         SLOPE(I,2) = 0
**      ENDDO
      IP1 = IPRECORD+(2+CHAN)*NRECORD
      DO J=1,NCHAN
         IF (.NOT.RECEIVER_FLAG(J).AND.J.NE.CHAN) THEN
*
            DAZ = RECEIVER_AZ_OFFSET(J)-
     $      RECEIVER_AZ_OFFSET(CHAN)
            DEL = RECEIVER_EL_OFFSET(J)-
     $      RECEIVER_EL_OFFSET(CHAN)
            SEP = SQRT(DAZ*DAZ+DEL*DEL)
            K = 1
            DO WHILE (CORRDIST(K).NE.SEP.AND.CORRDIST(K).NE.0)
               K = K+1
            ENDDO
            CORRDIST(K) = SEP
            IP2 = IPRECORD+(2+J)*NRECORD
            FIRST_POINT = 0
*
            DO I=1,NRECORD
               JJ = I+(J-1)*NRECORD
               VAL = SIGNAL(JJ)
               IF (VAL.NE.BLANKING) THEN
                  COEFFICIENT = LINCORR(MEMORY(IP1),MEMORY(IP2),
     $            I,SL1,SL2,NUMBER,INSIDE,J)
**                     SLOPE(J,1)=SL1
**                     SLOPE(J,2)=SL2
**                     if (chan.eq.1) write (23,'(6f12.3)')
**     _                  (slope(k,1),slope(k,2),k=2,4)
                  IF (COEFFICIENT.NE.2) THEN
                     CORRCOEF(K) = CORRCOEF(K)+COEFFICIENT
                     CORRPOIN(K) = CORRPOIN(K)+1
                     IF (SEP.LT.RING) THEN
                        NOISE(I)  = NOISE(I) + SL2*VAL*(SL1*SL2)
                        WEIGHT(I) = WEIGHT(I) + (SL1*SL2)
                     ENDIF
                  ENDIF
               ENDIF
            ENDDO
         ENDIF
      ENDDO
*
      DO I=1,NRECORD
         IF (WEIGHT(I).GT.0) NOISE(I) = NOISE(I)/WEIGHT(I)
*	  if (chan.eq.1) then
*		write (3,*) i, noise(i),weight(i)
*	  endif
      ENDDO
      RETURN
      END
*
*-----------------------------------------------------------------------*
*
      SUBROUTINE REMOVE_NOISE (CHAN,SIGNAL,NOISE)
*
      INCLUDE 'nic.inc'
      INCLUDE 'parameter.inc'
      INCLUDE 'par.inc'
      INCLUDE 'const.inc'
*
      REAL*4 SIGNAL(1), NOISE(NRECORD)
      INTEGER CHAN, I, K
*
      DO I=1,NRECORD
         K = I+(CHAN-1)*NRECORD
         IF (SIGNAL(K).NE.BLANKING) SIGNAL(K) = SIGNAL(K)-NOISE(I)
      ENDDO
c      IF (CHAN.EQ.1) THEN
c         DO I=1,NRECORD   ! copy noise in channel 6 (test)
c            K = I+5*NRECORD
c            SIGNAL(K) = NOISE(I)
c         ENDDO
c      ENDIF
*
      RETURN
      END
*
* Compute baseline offset at position XX
*
      FUNCTION BASE_OFF (XX,A,P,NPAR)
      INTEGER NPAR, K, MMAX
      PARAMETER (MMAX = 21)
      REAL*8 XX, A(MMAX), P(MMAX), BASE_OFF
*
      BASE_OFF = 0
      CALL FCHEB (XX,P,NPAR)
      DO K=1,NPAR
         BASE_OFF = BASE_OFF+A(K)*P(K)
      ENDDO
      RETURN
      END
*
*-----------------------------------------------------------------------*
*
* Compute RMS
*
      SUBROUTINE COMPUTE_RMS(SIGNAL,INSIDE,RMS,NRECORD)
*
      INCLUDE 'parameter.inc'
      INTEGER NRECORD
      REAL    SIGNAL(NRECORD),RMS
      LOGICAL INSIDE(NRECORD)
*
      INTEGER L,I
*
      L = 0
      RMS = 0
      DO I=1,NRECORD
         IF (.NOT.INSIDE(I).AND.SIGNAL(I).NE.BLANKING) THEN
            RMS = RMS+SIGNAL(I)**2
            L = L+1
         ENDIF
      ENDDO
      IF (L.NE.0) RMS = SQRT(RMS/L)
      RETURN
      END
*
*-----------------------------------------------------------------------*
*
      FUNCTION LINCORR (SIGNAL1,SIGNAL2,POINT,SLOPE1,SLOPE2,NUN,
     $INSIDE,CHANNEL)
      INCLUDE 'nic.inc'
      INCLUDE 'parameter.inc'
      REAL SIGNAL1(NRECORD), SIGNAL2(NRECORD)
      REAL*8 DIVIS1, DIVIS2, DIVID, SUM_XY, SUM_X, SUM_Y
      REAL*8 SUM_X2, SUM_Y2
      REAL X, Y, SLOPE1, SLOPE2, LINCORR
      INTEGER POINT, NUN, NUM, I, J, JJ, KK
      INTEGER  FIRST_POINT, CHANNEL, OFFSET, COUNT
      LOGICAL  INSIDE(1)
      COMMON   /LINCORR_COMMON/ FIRST_POINT
      SAVE     /LINCORR_COMMON/
      SAVE     SUM_X, SUM_Y
      SAVE     SUM_X2, SUM_Y2, SUM_XY
*
* Verify correlation of time intervals of "nun" points
* because of symmetry uneven number of intervals "nun"
*
      NUM = NUN-1
      J = POINT-NUM/2
      IF (J.LT.1) J = 1
      IF (J+NUM.GT.NRECORD) J = NRECORD-NUM
*
* Compute linear correlation coefficient
*
      COUNT = 0
      OFFSET = (CHANNEL-1)*NRECORD
      IF (J.EQ.1.OR.J.EQ.NRECORD-NUM) THEN     ! to save computing time ...
         SUM_X  = 0
         SUM_Y  = 0
         SUM_XY = 0
         SUM_X2 = 0
         SUM_Y2 = 0
         DO I=J,J+NUM
            IF (.NOT.INSIDE(I+OFFSET)) THEN
               X = SIGNAL1(I)
               Y = SIGNAL2(I)
               IF (X.NE.BLANKING.AND.Y.NE.BLANKING) THEN
                  SUM_X  = SUM_X  + X
                  SUM_Y  = SUM_Y  + Y
                  SUM_XY = SUM_XY + X*Y
                  SUM_X2 = SUM_X2 + X*X
                  SUM_Y2 = SUM_Y2 + Y*Y
                  COUNT  = COUNT+1
               ENDIF
            ENDIF
         ENDDO
      ELSE
         IF (J.NE.FIRST_POINT) THEN
            IF (J-1.LT.FIRST_POINT+NUM) THEN
               DO JJ = FIRST_POINT,J-1
                  IF (.NOT.INSIDE(JJ+OFFSET)) THEN
                     X = SIGNAL1(JJ)
                     Y = SIGNAL2(JJ)
                     IF (X.NE.BLANKING.AND.Y.NE.BLANKING) THEN
                        SUM_X  = SUM_X  - X
                        SUM_Y  = SUM_Y  - Y
                        SUM_XY = SUM_XY - X*Y
                        SUM_X2 = SUM_X2 - X*X
                        SUM_Y2 = SUM_Y2 - Y*Y
                        COUNT  = COUNT+1
                     ENDIF
                  ENDIF
                  KK = JJ+NUN
                  IF (.NOT.INSIDE(KK+OFFSET)) THEN
                     X = SIGNAL1(KK)
                     Y = SIGNAL2(KK)
                     IF (X.NE.BLANKING.AND.Y.NE.BLANKING) THEN
                        SUM_X  = SUM_X  + X
                        SUM_Y  = SUM_Y  + Y
                        SUM_XY = SUM_XY + X*Y
                        SUM_X2 = SUM_X2 + X*X
                        SUM_Y2 = SUM_Y2 + Y*Y
                        COUNT  = COUNT+1
                     ENDIF
                  ENDIF
               ENDDO
            ELSE
               SUM_X  = 0
               SUM_Y  = 0
               SUM_XY = 0
               SUM_X2 = 0
               SUM_Y2 = 0
               DO I=J,J+NUM
                  IF (.NOT.INSIDE(I+OFFSET)) THEN
                     X = SIGNAL1(I)
                     Y = SIGNAL2(I)
                     IF (X.NE.BLANKING.AND.Y.NE.BLANKING) THEN
                        SUM_X  = SUM_X  + X
                        SUM_Y  = SUM_Y  + Y
                        SUM_XY = SUM_XY + X*Y
                        SUM_X2 = SUM_X2 + X*X
                        SUM_Y2 = SUM_Y2 + Y*Y
                        COUNT  = COUNT+1
                     ENDIF
                  ENDIF
               ENDDO
            ENDIF
         ENDIF
      ENDIF
*
      DIVID  = (NUN*SUM_XY-SUM_X*SUM_Y)
      DIVIS1 = (NUN*SUM_X2-SUM_X*SUM_X)
      DIVIS2 = (NUN*SUM_Y2-SUM_Y*SUM_Y)
      IF (DIVIS1.NE.0.AND.DIVIS2.NE.0.AND.COUNT.GT.1) THEN
         SLOPE1 = DIVID/DIVIS1
         SLOPE2 = DIVID/DIVIS2
         LINCORR = SQRT(SLOPE1*SLOPE2)
      ELSE
         LINCORR = 2
      ENDIF
*
      FIRST_POINT = J                    ! Save parameters for next time
      RETURN
      END
*
      SUBROUTINE FIX_POS(ARRAY,NUM,CHAN,PLOTIT)
      INTEGER I,J,NUM,CHAN
      REAL ARRAY(5,NUM)
      CHARACTER*45 SETBOX
      LOGICAL PLOTIT
*
      SETBOX = 'set box'
      PLOTIT = .FALSE.
      DO I=1,NUM
         IF (ARRAY(1,I).EQ.CHAN) THEN
            WRITE (SETBOX(8:),'(4f9.5)') (ARRAY(J,I),J=2,5)
            CALL GR_EXEC1 (SETBOX)
            PLOTIT = .TRUE.
         ENDIF
      ENDDO
      RETURN
      END
*
*
*
      SUBROUTINE COMPUTE_NOISE_POINTING(SIG,INSIDE,CHAN_RMS,NOISE,
     $WEIGHT,CHAN_SEL)
*
*
      INCLUDE 'nic.inc'
      INCLUDE 'parameter.inc'
      INCLUDE 'par.inc'
*
      REAL     SIG(NRECORD,NCHAN),NOISE(NRECORD)
      LOGICAL  INSIDE(NRECORD,NCHAN)
      REAL     CHAN_RMS(NCHAN)
      REAL     WEIGHT(NRECORD)
      INTEGER  CHAN_SEL
*
      INTEGER  ICHAN,IREC
      REAL     WEIGHT_CHAN
*
      DO IREC=1,NRECORD
         NOISE(IREC) = 0
         WEIGHT(IREC) = 0
      ENDDO
*
      DO ICHAN=1,NCHAN
         IF (.NOT.RECEIVER_FLAG(ICHAN).AND.CHAN_SEL.NE.ICHAN.AND.
     $   REFERENCE_RECEIVER.NE.ICHAN) THEN
            WEIGHT_CHAN =(1./CHAN_RMS(ICHAN))**2
            DO IREC=1,NRECORD
               IF(.NOT.INSIDE(IREC,ICHAN)) THEN
                  IF (ABS(SIG(IREC,ICHAN)-BLANKING).GT.0.5) THEN
                     NOISE(IREC) = NOISE(IREC)
     $               + WEIGHT_CHAN*SIG(IREC,ICHAN)
                     WEIGHT(IREC) = WEIGHT(IREC)+ WEIGHT_CHAN
                  ENDIF
               ENDIF
            ENDDO
         ENDIF
      ENDDO
*
      DO IREC=1,NRECORD
         IF (WEIGHT(IREC).GT.0) THEN
            NOISE(IREC) = NOISE(IREC)/WEIGHT(IREC)
         ENDIF
      ENDDO
      END
