      SUBROUTINE USE_VCORR(NFIT,LIST,EL,ALPHA,BETA,
     +     CHI2,SD,ND,TIME,CODE,NP,
     +     REFPIX,REFVAL,VSTEP,SIGMA,VCORR,QUIET,ERROR)
C-------------------------------------------------------------------------
C ORBIT: update the linearised normal equation system, using constraints
C from one velocity profile.
C-------------------------------------------------------------------------
      INCLUDE 'constant.inc'
      INCLUDE 'control.inc'
      INCLUDE 'corrections.inc'
      REAL*8 REFPIX,REFVAL,VSTEP,TIME,EL(MA)
      INTEGER NP,NFIT,LIST(NFIT),CODE
      REAL ALPHA(MA,MA)
      REAL BETA(NFIT)
      REAL SIGMA,SD,CHI2
      INTEGER ND
      REAL VCORR(NP)
      LOGICAL QUIET,ERROR
*
*
      INTEGER I,J,ICOMP,NLINE,ILINE,IC
      INTEGER LINES(2,MORBIT)
      REAL DY,SIG2I
      REAL V(NCOMPONENTS),CORRECTION(MVPNTS)
      REAL B(MA),GG(MA,NCOMPONENTS) !G1(MA),G2(MA),
      REAL VALUE,FLUX
      REAL*8 PARG(3+3*NCOMPONENTS),G(3*NCOMPONENTS),XVEL,FGAUSS
      INTEGER IW(2,MORBIT),IEW(2,MORBIT)
!      real*4 x(MVPNTS),y(MVPNTS),Yc(mvpnts) ! For debugging display only
      INTEGER IORB
      REAL PROFILE_MEAN
*
* Reset everything from possible previous call with more components. Should
* not be needed, but does not cost much...
      DO I=1,3*NCOMPONENTS
         PARG(I+3) = 0
         G(I) = 0
      ENDDO
      DO I=1,NCOMPONENTS
         V(I) = 0 
      ENDDO
      DO I=1,MORBIT
         LINES(1,I) = 0
         LINES(2,I) = 0
      ENDDO
* Initialise residual from gaussian to zero
      DO I=1,NP
         CORRECTION(I) = 0
      ENDDO
* Parameters for dependent gaussians are unused here, set them to their
* default value.
      PARG(1)=1 
      PARG(2)=0 ! to their defaults
      PARG(3)=1
* Determine which parameters apply to current profile, looking first for 
* specific parameters for the current radial velocity origin, and falling 
* back to generic ones if the latter are absent. This is done on a per
* parameter basis.
      CALL SELECT_PROFILE_PARAMETERS(CODE,IEW,IW,ERROR)
      IF (ERROR) GOTO 99
*
* Prepare descriptive parameters for all relevant gaussians
      NLINE = 0
      DO IORB=1,MORBIT
* Compute gradients of velocities relative to orbital elements, and get
* the values for free. 
         DO ICOMP=1,2
            IF (EL(IEW(ICOMP,IORB)).NE.0) THEN ! Area is non-zero, fill in
               IC = (IORB-1)*10+ICOMP
               NLINE = NLINE+1
               LINES(ICOMP,IORB) = NLINE
               CALL GET_GRADVEL(TIME,IC,CODE,V(NLINE),
     +              GG(1,NLINE),ERROR)
               IF (ERROR) GOTO 99
               PARG(3*NLINE+1) = EL(IEW(ICOMP,IORB)) ! Area for star
               PARG(3*NLINE+2) = V(NLINE) ! Center for star 1
               PARG(3*NLINE+3) = EL(IW(ICOMP,IORB)) ! Width for star
* Optionally compute profile deviations from a gaussian
               IF (PROFILE_METHOD.EQ.'CORRECTED') THEN
                  CALL ACCUMULATE_PROFILE_CORRECTION(ICOMP,IORB,
     +                 V(NLINE),NP,REFPIX,REFVAL,VSTEP,
     +                 CORRECTION,ERROR)
                  IF (ERROR) GOTO 99
               ENDIF
            ENDIF
         ENDDO
      ENDDO
* Determine normalisation factor (for Andrei's unnormalised profiles at least)
* Must decide if this should be kept or not. No profile correction at this 
* step, in the hope that it has close to zero mean.
      FLUX = PROFILE_MEAN(NP,REFPIX,REFVAL,VSTEP,VCORR,NLINE,PARG)
*
      SIG2I=1/SIGMA**2
*
* Now, accumulate the contribution of each correlation profile data point
* to the least square process
      DO I=1,NP
         XVEL = REFVAL+(I-REFPIX)*VSTEP
         VALUE = 1-SNGL(FGAUSS(XVEL,NLINE,PARG))
!         x(i) = xvel
!         y(i) = vcorr(i)
!         yc(i) = vcorr(i)-correction(i)
*
         DY=VCORR(I)-CORRECTION(I)-VALUE
         SD=SD+DY*DY
*  Get gradient of the gaussian profile sum relative to its 3*NLINE 
*  descriptive parameters
         CALL DGAUSS (XVEL,NLINE,PARG,G)
* Compute profile gradient relative to the orbital elements from the partial 
* derivatives relative to central velocities, plus the gradients of 
* the velocities relative to the orbital elements.
         DO J=1,MA
            B(J) = 0
            DO ILINE=1,NLINE
               B(J) = B(J) - GG(J,ILINE)*G(3*ILINE+2)
            ENDDO 
            B(J) = FLUX*B(J)
         ENDDO
!         write(6,*) 'flux',flux
!         write(6,*) 'G',G
* Width and area are orbital elements: just copy over the corresponding 
* partial derivatives. 
         DO IORB=1,MORBIT
            DO ICOMP=1,2
               IF (LINES(ICOMP,IORB).NE.0) THEN
                  B(IEW(ICOMP,IORB)) = 
     +                 -FLUX*G(3*LINES(ICOMP,IORB)+1) ! Derivative /Area 
                  B(IW(ICOMP,IORB)) =
     +                 -FLUX*G(3*LINES(ICOMP,IORB)+3) ! Derivative /Width
               ENDIF
            ENDDO
         ENDDO
* Update the normal equations
         CALL COVSUM(NFIT,MA,ALPHA,BETA,B,LIST,DY,CHI2,SIG2I
     +        ,QUIET,ERROR)
         IF (ERROR) THEN
            IF (.NOT.QUIET) THEN
               WRITE(6,*) 
     +              'E-NORMAL, Error using velocity profile information'
            ENDIF
            RETURN
         ENDIF
      ENDDO

      ND = ND+NP
      RETURN
*
 99   ERROR = .TRUE.
      RETURN
      END

      FUNCTION PROFILE_MEAN(NP,REF,VAL,INC,Y,NLINE,PARG)
C----------------------------------------------------------------------------
* Determine normalisation factor (for Andrei's unnormalised profiles at least)
* Must decide if this should be kept or not. No profile correction at this 
* step, in the hope that it has close to zero mean.
C----------------------------------------------------------------------------
      REAL PROFILE_MEAN
      INTEGER NP
      REAL Y(NP)
      REAL*8 REF,VAL,INC
      INTEGER NLINE
      REAL*8 PARG(3*NLINE)
*
      INTEGER I,NF
      REAL*8 FLUX,XVEL,VALUE
      REAL*8 FGAUSS
*
      FLUX=0
      NF=0
      DO I=1,NP
         XVEL = VAL+(I-REF)*INC
         VALUE = 1-SNGL(FGAUSS(XVEL,NLINE,PARG))
         IF (VALUE.GT.0.5) THEN
            FLUX=FLUX+(Y(I)/VALUE)
            NF=NF+1
         ENDIF
      ENDDO
      IF (NF.GT.0) THEN
         PROFILE_MEAN=FLUX/NF
      ELSE
         PROFILE_MEAN=1.
      ENDIF
      END
*
*

      SUBROUTINE SELECT_PROFILE_PARAMETERS(ORIGIN,
     +     IEW,IW,ERROR)
C---------------------------------------------------------------------------
C Determine which parameters apply to current profile, looking first for 
C specific parameters for the current radial velocity origin, and falling 
C back to generic ones if the latter are absent.
C---------------------------------------------------------------------------
      INCLUDE 'constant.inc'
      INTEGER ORIGIN
      INTEGER IEW(2,MORBIT),IW(2,MORBIT)
      LOGICAL ERROR
*
      INCLUDE 'elements.inc'
      INCLUDE 'data.inc'
*
      INTEGER IORB, IORI
*
      DO IORB=1,MORBIT
*
* Check if parameter is defined for current origin
         IF (ELERR(I_EW1+(ORIGIN-1)*4+ELINDX(IORB)).GE.0) THEN
            IEW(1,IORB)  = I_EW1+(ORIGIN-1)*4+ELINDX(IORB)
         ELSE
* Otherwise look for the first origin where it is defined
            DO IORI=1,NVREF
               IF (ELERR(I_EW1+(IORI-1)*4+ELINDX(IORB)).GE.0) THEN
                  IEW(1,IORB)  = I_EW1+(IORI-1)*4+ELINDX(IORB)
                  GOTO 10
               ENDIF
            ENDDO
* As a last resort, fall back to origin 1, to ensure amongst other thing
* that barycenters of higher level binaries get attributed a proper dummy
* profile number
            IEW(1,IORB)  = I_EW1+ELINDX(IORB)
         ENDIF
 10      CONTINUE
         IF (ELERR(I_EW2+(ORIGIN-1)*4+ELINDX(IORB)).GE.0) THEN
            IEW(2,IORB)  = I_EW2+(ORIGIN-1)*4+ELINDX(IORB)
         ELSE
            DO IORI=1,NVREF
               IF (ELERR(I_EW2+(IORI-1)*4+ELINDX(IORB)).GE.0) THEN
                  IEW(2,IORB)  = I_EW2+(IORI-1)*4+ELINDX(IORB)
                  GOTO 20
               ENDIF
            ENDDO
            IEW(2,IORB)  = I_EW2+ELINDX(IORB)
         ENDIF
 20      CONTINUE
         IF (ELERR(I_W1+(ORIGIN-1)*4+ELINDX(IORB)).GE.0) THEN
            IW(1,IORB)  = I_W1+(ORIGIN-1)*4+ELINDX(IORB)
         ELSE
            DO IORI=1,NVREF
               IF (ELERR(I_W1+(IORI-1)*4+ELINDX(IORB)).GE.0) THEN
                  IW(1,IORB)  = I_W1+(IORI-1)*4+ELINDX(IORB)
                  GOTO 30
               ENDIF
            ENDDO
            IW(1,IORB)  = I_W1+ELINDX(IORB)
         ENDIF
 30      CONTINUE
         IF (ELERR(I_W2+(ORIGIN-1)*4+ELINDX(IORB)).GE.0) THEN
            IW(2,IORB)  = I_W2+(ORIGIN-1)*4+ELINDX(IORB)
         ELSE
            DO IORI=1,NVREF
               IF (ELERR(I_W2+(IORI-1)*4+ELINDX(IORB)).GE.0) THEN
                  IW(2,IORB)  = I_W2+(IORI-1)*4+ELINDX(IORB)
                  GOTO 40
               ENDIF
            ENDDO
            IW(2,IORB)  = I_W2+ELINDX(IORB)
         ENDIF
 40      CONTINUE
      ENDDO

      RETURN
      END
*
      SUBROUTINE UPDATE_PROFILE_CORRECTIONS(QUIET,ERROR)
C------------------------------------------------------------------------------
C  Updates the estimate of the residuals of the average correlation profile
C  from a gaussian. To be called before each iteration when fitting to 
C  profiles.
C
C------------------------------------------------------------------------------
      LOGICAL QUIET,ERROR
*
      INCLUDE 'constant.inc'
      INCLUDE 'elements.inc'
      INCLUDE 'corrections.inc'
      INCLUDE 'data.inc'
*
      REAL GAIN 
      PARAMETER (GAIN=0.5)
      INTEGER IORB,I,IC,ICOMP
      REAL TMP(MVPNTS)
      REAL SIGMA,AREA,MAX_AREA
      REAL AMPLITUDE(2,MORBIT),MAX_AMP,FACT,FACTOR
      INTEGER IEW(2,MORBIT),IW(2,MORBIT),ORIGIN
      PARAMETER (ORIGIN=1)
      real x(mvpnts)
      CHARACTER ANSWER*1
*
*
      IF (NVCORR.LE.1) THEN
         RETURN
      ELSEIF (NVCORR.LE.4) THEN
         WRITE(6,*) 'W-CORRECT,  Number of profiles is small, ',
     +        'correction is probably unstable'
      ENDIF
      MAX_AREA = 0.0
*
      CALL SELECT_PROFILE_PARAMETERS(ORIGIN,IEW,IW,ERROR)

      IF (.NOT.QUIET) write(6,*) 'Updating corrections'
      DO IORB=1,MORBIT
         DO ICOMP=1,2
            AMPLITUDE(ICOMP,IORB) = 0.
            IC    = COMPONENTS(ICOMP,IORB)
            AREA = EL(IEW(ICOMP,IORB))
            IF (AREA.EQ.0) THEN ! Store no correction to non-detected comps
               NPNTS_CORRECTED(ICOMP,IORB) = 0
            ELSE
*     Compute the average correlation profile 
               NPNTS_CORRECTED(ICOMP,IORB) = MVPNTS
               CALL AVERAGE_CORREL_PROFILE(IC,
     +              NPNTS_CORRECTED(ICOMP,IORB),
     +              CORRECTED_REF(ICOMP,IORB),
     +              CORRECTED_VAL(ICOMP,IORB),
     +              CORRECTED_INC(ICOMP,IORB),
     +              PROFILE_CORRECTIONS(1,ICOMP,IORB),
     +              TMP,ERROR)
               IF (ERROR) GOTO 99
!!
!               DO I=1,NPNTS_CORRECTED(ICOMP,IORB)
!                  X(I) = CORRECTED_VAL(ICOMP,IORB)+
!     +                 (I-CORRECTED_REF(ICOMP,IORB))
!     +                 *CORRECTED_INC(ICOMP,IORB)
!               ENDDO
!               call DEBUG_PLOT(NPNTS_CORRECTED(ICOMP,IORB),X,
!     +              profile_corrections(1,icomp,IORB),.TRUE.)
!               write(6,*)    NPNTS_CORRECTED(ICOMP,IORB)
!               do i=1,NPNTS_CORRECTED(ICOMP,IORB)
!                  write(6,*) x(i),profile_corrections(i,icomp,IORB)
!               enddo
!               write(6,*) IORB,ICOMP,'Type return to continue'
!               read(5,*)
!
*     Compute its deviation from a gaussian
               CALL GET_MODEL_PROFILE(0,1,IC,.TRUE.,.FALSE.,
     +              NPNTS_CORRECTED(ICOMP,IORB),
     +              CORRECTED_REF(ICOMP,IORB),
     +              CORRECTED_VAL(ICOMP,IORB),
     +              CORRECTED_INC(ICOMP,IORB),
     +              TMP,ERROR)
               IF (ERROR) GOTO 99
               DO I=1,NPNTS_CORRECTED(ICOMP,IORB)
                  PROFILE_CORRECTIONS(I,ICOMP,IORB) = 
     +                 PROFILE_CORRECTIONS(I,ICOMP,IORB)-TMP(I)
               ENDDO

!               call DEBUG_PLOT(NPNTS_CORRECTED(ICOMP,IORB),X,
!     +              TMP,.TRUE.)
!     +              profile_corrections(1,icomp,IORB),.TRUE.)
!               write(6,*)    NPNTS_CORRECTED(ICOMP,IORB)
!               do i=1,NPNTS_CORRECTED(ICOMP,IORB)
!                  IF (tmp(i).ne.tmp(i).or.abs(tmp(i)).gt.1) then
!                     write(6,*) 'profile:',i,x(i),tmp(i)
!                  endif
!               enddo
!               write(6,*) IORB,ICOMP,'Type return to continue'
!               read(5,*)
* Damp down the profile corrections in the core. Avoids transfers between
* gaussian core and correction.
               SIGMA = EL(IW(ICOMP,IORB))
               SIGMA = 5*SIGMA ! Strong damping.
               DO I=1,NPNTS_CORRECTED(ICOMP,IORB)
                  X(I) = CORRECTED_VAL(ICOMP,IORB)+
     +                 (I-CORRECTED_REF(ICOMP,IORB))
     +                 *CORRECTED_INC(ICOMP,IORB)
                  FACTOR = 1-EXP(-(X(I)/SIGMA)**2)
                  PROFILE_CORRECTIONS(I,ICOMP,IORB) = 
     +                 PROFILE_CORRECTIONS(I,ICOMP,IORB)
     +                 *FACTOR
* Compute the L2 norm of the correction for each component, and determine
* the correction norm for the strongest component.
                  AMPLITUDE(ICOMP,IORB) = AMPLITUDE(ICOMP,IORB)+
     +                 PROFILE_CORRECTIONS(I,ICOMP,IORB)**2
               ENDDO
               AMPLITUDE(ICOMP,IORB) = SQRT(AMPLITUDE(ICOMP,IORB)
     +              /NPNTS_CORRECTED(ICOMP,IORB))
!               write(6,*) Icomp, iorb,  AMPLITUDE(ICOMP,IORB)
               IF (ABS(AREA).GT.MAX_AREA) THEN
                  MAX_AREA = ABS(AREA)
                  MAX_AMP  = AMPLITUDE(ICOMP,IORB)
               ENDIF
               ENDIF
            ENDDO
         ENDDO
* Normalise the amplitude of the correction to that of the strongest component,
* so as to avoid introducing noise for weak components. This assumes that the
* PSF is not significantly less gaussian for weak components than for strong
* ones. This hopefully is approximately true when their spectral types are
* not too different.
         DO IORB=1,MORBIT
            DO ICOMP=1,2
               IF (EL(IEW(ICOMP,IORB)).GT.0) THEN
                  FACT = (AMPLITUDE(ICOMP,IORB)/MAX_AMP)/
     +                 (ABS(EL(IEW(ICOMP,IORB)))/MAX_AREA)
                  IF (FACT.LT.1) FACT=1 ! Don't amplify...
                  write(6,*) iorb, icomp, fact
                  DO I=1,NPNTS_CORRECTED(ICOMP,IORB)
                     PROFILE_CORRECTIONS(I,ICOMP,IORB) =
     +                    PROFILE_CORRECTIONS(I,ICOMP,IORB)/FACT
                  ENDDO
!                  write(6,*) 'NORMALISATION: ',fact
! Check during development...
!                  CALL DEBUG_PLOT(NPNTS_CORRECTED(ICOMP,IORB),X,
!     +              profile_corrections(1,icomp,IORB),.TRUE.)
!                  CALL DEBUG_PLOT(NPNTS_CORRECTED(ICOMP,IORB),X,
!     +              TMP,.FALSE.)
!               write(6,*) 'Type return to continue'
!               read(5,*)
* In interactive mode, plot the correction
                  IF (.NOT.QUIET) THEN
                     DO I=1,NPNTS_CORRECTED(ICOMP,IORB)
                        X(I) = CORRECTED_VAL(ICOMP,IORB)+
     +                       (I-CORRECTED_REF(ICOMP,IORB))
     +                       *CORRECTED_INC(ICOMP,IORB)
                        FACTOR = 1-EXP(-(X(I)/SIGMA)**2)
                     ENDDO
                     CALL DEBUG_PLOT(NPNTS_CORRECTED(ICOMP,IORB),X,
     +                    profile_corrections(1,icomp,IORB),.TRUE.)
                     write(6,*) 
     +                    'Correction to gaussian profile'
                     write(6,*) 'Type return to continue, Q to quit'
                     ANSWER = ' '
                     read(5,'(A)') ANSWER
                     IF (ANSWER.EQ.'Q'.OR.ANSWER.EQ.'q') GOTO 99
                     write(6,*) answer
                  ENDIF
            ENDIF
         ENDDO
      ENDDO

      write(6,*) 'Corrections updated'
*
      RETURN
 99   ERROR = .TRUE.
      RETURN
      END



      SUBROUTINE DEBUG_PLOT(N,X,Y,NEW)
      INTEGER N
      REAL X(N),Y(N)
      LOGICAL NEW
*
      CHARACTER CHAIN*32
      INTEGER ICURVE
      SAVE ICURVE
*
      IF (N.EQ.0) RETURN
*
      CALL GR4_GIVE('X',N,X)
      CALL GR4_GIVE('Y',N,Y)
      IF (NEW) THEN
         CALL GR_EXEC('CLEAR PLOT')
         CALL GR_EXEC('LIMITS  ')
         CALL GR_EXEC('SET BOX LANDSCAPE')
         CALL GR_EXEC('BOX')
         CALL GR_EXEC('HISTO')
         ICURVE = 1
      ELSE
         ICURVE = ICURVE+1
         IF (ICURVE.GE.100) THEN
            WRITE(6,*) 'Too many curves'
            RETURN
         ENDIF
         WRITE(CHAIN,1010) ICURVE, ICURVE
 1010    FORMAT('PEN ',I2,' /DASH ',I2)
         CALL GR_EXEC(CHAIN)
         CALL GR_EXEC('CONNECT')
         CALL GR_EXEC('PEN /DEF')
      ENDIF
      RETURN
      END
