module deconv_dsb_commons
  use gildas_def
  use class_types
  !-------------------------------------------------------------------
  !
  ! Common block definitions used in XCLASS
  ! for the Maximum Entropy Method deconvolution algorithm.
  !
  ! hogm stands for High Order Gain Modification: done by PH while
  ! visiting Bonn 05/2009
  !
  !-------------------------------------------------------------------
  !
  ! Related to DSB spectra.
  type(header)    :: dsb_head      ! Header of one DSB spectra
  integer(kind=4) :: dsb_system    ! Coordinate system - DSB header - CC 4.7.2013
  real(kind=8)    :: dsb_time      ! Integration time from first DSB scan - CC 4.7.2013
  integer(kind=4) :: dsb_counter   ! Effective number of DSB spectra
  integer(kind=4) :: dsb_size      ! Logical size of DSB array, in channels
  real(kind=8)    :: sigma_weight  !
  integer(kind=4), allocatable, dimension(:) :: single_size ! Logical size of single DSB spectra
  real(kind=8),    allocatable, dimension(:) :: dsb_weight  ! Weight for each spectrum (time/tsys^2)
  integer(kind=4), allocatable, dimension(:) :: dsb_pointer ! Array pointing to index of spectrum for each channel
  logical         :: hifi          !
  !
  !
  ! To each DSB channel i correspond two original SSB frequencies:
  ! dsb_signal(i) (for the upper side band) and dsb_image(i) (for the
  ! lower side band).
  real(kind=4), allocatable, dimension(:) :: dsb_signal   ! Linear array of ALL DSB spectra; rest freq information
  real(kind=4), allocatable, dimension(:) :: dsb_image    ! Linear array of ALL DSB spectra; image freq information
  real(kind=4), allocatable, dimension(:) :: dsb_spectrum ! Linear array of ALL DSB spectra; power information
  real(kind=8), allocatable, dimension(:) :: ddsb_spectrum! Double precision array
  !
  ! Related to final SSB spectrum
  integer(kind=4)            :: ssb_size       ! Size of SSB array, in channels.
  real(kind=4)               :: ssb_voff       ! [km/s] Velocity at reference channel
  integer(kind=4), parameter :: max_og=100     ! Maximum order of the gain
  integer(kind=4)            :: o_gain         ! Effective order of the gain
  logical                    :: variable_gain  ! 2 options: variable gain through the IF / piecewise constant gain
  ! assumption is zeroth order signal gain, zeroth order image gain, first order signal gain,....
  real(kind=4), allocatable, dimension(:) :: gain ! Vector containing Signal (USB) and Image (LSB) gains
  ! Need to store these quantities to calculate the position in the IF
  real(kind=4),    allocatable, dimension(:) :: dsb_Rrestf
  real(kind=4),    allocatable, dimension(:) :: dsb_Rimage
  integer(kind=4), allocatable, dimension(:) :: dsb_Rrchan
  integer(kind=4), allocatable, dimension(:) :: dsb_Cnchan
  !
  ! Standing waves before mixing for SSB.
  ! one_out_of_f : Used with psw_bm in order to have a parameter close to 1
  !                during the deconvolution. The derivative of
  !                the chisquare in regard with the pulsation causes the SSB
  !                frequency to get out of the sin(). Because the SSB
  !                frequencies are relatively high (something like 10^6),
  !                this contribution to the derivative is too high and
  !                the algorithm fails. In order to have something close to
  !                1 getting out of the sin(), we choosed to introduce a
  !                constant which will get out the sin() in the same time
  !                that SSB frequency and which has a value compensating
  !                the SSB frequency : 1 / mean(SSB frequency).
  !                So, instead of having d(sin(wf))/dw = f.sin(wf),
  !                we'll have d(sin(w0fF))/dw0 = fF.sin(w0fF), and fF is
  !                close to 1 because F = 1/mean(f).
  !                You can see that w0 = w / F. It is that w0 we call
  !                psw_bm.
  real(kind=4) :: one_out_of_f
  real(kind=4), allocatable, dimension(:,:) :: asw_bm  ! amplitude.
  real(kind=4), allocatable, dimension(:,:) :: psw_bm  ! pulsation / one_out_of_f.
  real(kind=4), allocatable, dimension(:,:) :: phsw_bm ! phase.
  !
  ! Theoretically, ssb_freq(i) = ssb_first+(i-1)*ssb_width.
  real(kind=4) :: ssb_first  ! Frequency of first channel for SSB array.
  real(kind=4) :: ssb_width  ! Frequency width of SSB array - should be equal to dsb_width.
  !
  integer(kind=4), parameter :: max_model_lines=3000
  ! Assumption is zeroth order signal gain, zeroth order image gain, first order signal gain,....
  real(kind=4)                            :: sum_model      ! Sum of ssb_model(i)
  character(len=filename_length)          :: ssb_model_file !
  real(kind=4)                            :: cont_offset    ! Continuum offset needed for model, to prevent argument < 0 in the entropy calculation
  real(kind=4), allocatable, dimension(:) :: gain_model
  real(kind=4), allocatable, dimension(:) :: gain_model_input
  real(kind=8), allocatable, dimension(:) :: norm_gain_model
  real(kind=4), allocatable, dimension(:) :: ssb_spectrum   ! final ssb spectrum, spectral power information.
  real(kind=4), allocatable, dimension(:) :: ssb_freq       ! SSB frequency scale (for checks).
  real(kind=4), allocatable, dimension(:) :: ssb_model      ! Model of SSB_DAT, also first guess
  real(kind=8), allocatable, dimension(:) :: norm_ssb_model ! ssb_model / sum_model
  !
  ! Standing waves before mixing.
  logical :: no_bmswA,no_bmswP,no_bmswPh
  integer(kind=4) :: n_sw_bm                  ! Effective number of standing waves.
  integer(kind=4), parameter :: n_sw_bm_max=8 ! Maximum number of standing waves.
  integer(kind=4), parameter :: maxchi=3
  real(kind=4), allocatable, dimension(:,:)  :: asw_bm_model       ! model's swbm amplitude.
  real(kind=4), allocatable, dimension(:,:)  :: psw_bm_model       ! model's swbm pulsation.
  real(kind=4), allocatable, dimension(:,:)  :: phsw_bm_model      ! model's swbm phase.
  real(kind=8), allocatable, dimension(:,:)  :: norm_asw_bm_model  !
  real(kind=8), allocatable, dimension(:,:)  :: norm_psw_bm_model  !
  real(kind=8), allocatable, dimension(:,:)  :: norm_phsw_bm_model !
  !
  ! Frequency switch.
  logical :: freq_switch
  integer(kind=4), allocatable, dimension(:,:) :: chan_throw  ! modified to accomodate variable frequency throw (HIFI) - CC Jul2011
  real(kind=4),    allocatable, dimension(:,:) :: freq_throw  ! modified to accomodate variable frequency throw (HIFI) - CC Jul2011
  real(kind=4),    allocatable, dimension(:,:) :: throw_poids ! modified to accomodate variable "poids" (HIFI), needed?? - CC Jul2011
  !
  ! Related to the function to minimize
  ! Minimize Chi^2 - lambda1 * entrop_ssb
  !                - lambda2 * entrop_gain
  !                - lambda3 * entrop_sw
  real(kind=8) :: lambda1  ! SSB entropy weight in the function to minimize
  real(kind=8) :: lambda2  ! Gain entropy weight in the function to minimize
  real(kind=8) :: lambda3  ! Standing waves entropy weight in the function to minimize
  !
  ! Related to deconvolution behaviour.
  logical :: no_channels ! Do not try to fit channels during deconvolution
! logical :: no_gain     ! Do not try to fit sideband gains during deconvolution
  logical :: fit_gains   ! Fit sideband gains during deconvolution           !! CC 19.6.2013 no_gain is now default
                                                                             !! removed /NOGAIN option
                                                                             !! replaced with /GAIN [firstGuess]
  logical :: use_deriv   ! Use derivatives in the linear minimization
  logical :: debug=.false.
  !
  ! Miscealeneous.
  integer(kind=4) :: n_lws
  real(kind=4)    :: lws_resolution
  real(kind=4)    :: big_F
  real(kind=4)    :: small_f
  real(kind=4)    :: delta_angle
  real(kind=4)    :: airy_width
  real(kind=4)    :: gap
  real(kind=4)    :: lambda0
  real(kind=4)    :: lambda
  !
end module deconv_dsb_commons
!
!
module f1_commons
  integer(kind=4) :: mem_ncom
  real(kind=8), allocatable, dimension(:) :: mem_pcom
  real(kind=8), allocatable, dimension(:) :: mem_xicom
end module f1_commons
!
!
!
subroutine deconv_allocate(key,error)
  use gbl_message
  use classcore_dependencies_interfaces
  use classcore_interfaces, except_this=>deconv_allocate
  use deconv_dsb_commons
  use f1_commons
  !-------------------------------------------------------------------
  ! @ private
  ! Check memory allocation for SSB, DSB, ALL arrays
  ! * Allocate non-allocated arrays
  ! * Check size of allocated arrays
  !-------------------------------------------------------------------
  character(len=*), intent(in)  :: key   ! SSB, DSB or ALL
  logical,          intent(out) :: error ! Output flag
  ! Local
  character(len=*), parameter :: rname='deconv_allocate'
  integer(kind=4) :: ier
  logical :: noalloc,ssb,dsb
  !
  error = .false.
  ssb   = key.eq.'SSB'
  dsb   = key.eq.'DSB'
  !
  ! Check if SSB or DSB arrays are already allocated
  if (ssb) then
     noalloc = .not.(allocated(ssb_spectrum))
  else if (dsb) then
     noalloc = .not.(&
          allocated(single_size).and.&
          allocated(dsb_pointer).and.&
          allocated(asw_bm))
  else ! key='ALL' : check if all arrays are allocated. If not, exit.
     error = .not.(&
          allocated(ssb_spectrum).and.&
          allocated(mem_pcom).and.&
          allocated(single_size).and.&
          allocated(dsb_pointer))
     if (error) then
        call class_message(seve%e,rname,'Arrays are not allocated. See INITIALIZE.')
        return
     endif
!!$     write(*,*) allocated(ssb_spectrum),size(ssb_spectrum)
!!$     write(*,*) allocated(dsb_spectrum),size(dsb_spectrum)
     noalloc = .false.
  endif
  !
  !
  ! Allocate memory if needed
  if (noalloc) then
     if (ssb) then
        if (ssb_size.le.0) goto 100
        allocate(&
             ssb_spectrum(ssb_size),&
             ssb_freq(ssb_size),&
             ssb_model(ssb_size),&
             norm_ssb_model(ssb_size),&
             stat=ier)
        if (failed_allocate(rname,'Global SSB arrays',ier,error)) return
     else
        if (dsb_counter.le.0.or.dsb_size.le.0) goto 100
        allocate(&
             single_size(dsb_counter),&
             dsb_weight(dsb_counter),&
             gain(2*dsb_counter*max_og),&
             gain_model(2*dsb_counter*max_og),&
             gain_model_input(2*dsb_counter*max_og),&
             norm_gain_model(2*dsb_counter*max_og),&
             chan_throw(dsb_counter,2),freq_throw(dsb_counter,2),throw_poids(dsb_counter,2),&
             dsb_pointer(dsb_size),dsb_signal(dsb_size),dsb_image(dsb_size),&
             dsb_spectrum(dsb_size),ddsb_spectrum(dsb_size),&
             dsb_rrestf(dsb_counter),dsb_rimage(dsb_counter),&
             dsb_rrchan(dsb_counter),dsb_cnchan(dsb_counter),&
             stat=ier)
        if (failed_allocate(rname,"Global DSB arrays",ier,error)) return
     endif
     call class_message(seve%i,rname,'Memory allocation successful for '//key)
  else
     ! Already allocated: check sizes
     ! If already allocated, check if of the correct size
     if (ssb.and.size(ssb_spectrum).ne.ssb_size) then
        call class_message(seve%e,rname,'New initialization needed for '//key)
        error = .true.
        return
     endif
     if (dsb.and.size(single_size).ne.dsb_counter) then
        call class_message(seve%e,rname,'New initialization needed for '//key)
        error = .true.
        return
     endif
     call class_message(seve%i,rname,'Arrays already allocated.')
  endif
  return
  !
100 call class_message(seve%e,rname,'Can not allocate negative size arrays')
  error = .true.
  return
end subroutine deconv_allocate
!
!
!
subroutine deconv_dealloc(error)
  use classcore_interfaces, except_this=>deconv_dealloc
  use deconv_dsb_commons
  use gbl_message
  use f1_commons
  !-------------------------------------------------------------------
  ! @ private
  ! Free allocated memory
  !-------------------------------------------------------------------
  logical, intent(out) :: error ! Output flag
  ! Local
  character(len=*), parameter :: rname='DECONV_DEALLOC'
  integer(kind=4) :: ier
  !
  ier = 0
  ! Spectra arrays
  if (allocated(single_size)) then
     deallocate(single_size,dsb_weight,&
          gain,gain_model,gain_model_input,norm_gain_model,&
          chan_throw,freq_throw,throw_poids,&
          stat=ier)
  endif
  if (allocated(dsb_pointer)) then
     deallocate(dsb_pointer,dsb_signal,dsb_image,dsb_spectrum,ddsb_spectrum,stat=ier)
     deallocate(dsb_rrestf,dsb_rimage,dsb_rrchan,dsb_cnchan,stat=ier)
  endif
  ! Standing wave arrays
  if (allocated(asw_bm)) then
     deallocate(asw_bm,psw_bm,phsw_bm,stat=ier)
     deallocate(asw_bm_model,psw_bm_model,phsw_bm_model,stat=ier)
     deallocate(norm_asw_bm_model,norm_psw_bm_model,norm_phsw_bm_model,stat=ier)
  endif
  ! SSB arrays
  if (allocated(ssb_spectrum)) then
     deallocate(ssb_spectrum,ssb_freq,ssb_model,norm_ssb_model,stat=ier)
  endif
  ! Minimization arrays
  if (allocated(mem_pcom)) then
     deallocate(mem_pcom,mem_xicom,stat=ier)
  endif
  !
  if (ier.ne.0) then
     call class_message(seve%e,rname,'Problem during deallocation of DECONV arrays.')
     error = .true.
  endif
end subroutine deconv_dealloc
!
!
!
!
!
subroutine deconv_init(set,line,r,error,user_function)
  use gildas_def
  use gbl_constant
  use gbl_message
  use classcore_dependencies_interfaces
  use classcore_interfaces, except_this=>deconv_init
  use class_index
  use class_types
  use deconv_dsb_commons
  !-------------------------------------------------------------------
  ! @ public
  ! Support routine for command
  !
  ! INITIALIZE [cont_offset]
  ! 1          [/MODEL file]
  ! 2          [/SIMULATE file noise]
  ! 3          [/WEIGHT weight]
  ! 4          [/BMSW n [a p ph [...]]
  !
  ! Initializes the deconvolution process.
  !
  ! - read the DSB scans from the opened input CLASS file.
  ! - contatenate all these DSB scan into a single vector called
  !   dsb_spectrum
  ! - determine information about the output SSB from information
  !   about the DSB : number of channels,frequency resolution,min and
  !   max frequencies...
  ! - It sets up a flat null model.
  ! - Allocate global arrays
  !-------------------------------------------------------------------
  type(class_setup_t), intent(in)    :: set            !
  character(len=*),    intent(in)    :: line           ! Input command line
  type(observation),   intent(inout) :: r              !
  logical,             intent(out)   :: error          ! Error flag
  logical,             external      :: user_function  ! External function, intent(in)
  ! Local
  character(len=*), parameter :: rname='DECONV_INIT'
  type (observation) :: obs
  logical :: use_weight,use_model,use_simulate,use_bmsw
  integer(kind=4) :: i,ii,j,scan,blanked,ier,nc
  integer(kind=entry_length) :: entry_num
  real(kind=4) :: decal,weight
  real(kind=4) :: ssb_last
  real(kind=4) :: dsb_width                 ! [ MHz] maximum DSB frequency resolution
  !?????? PH: problem with this when channel width is not an integer
  !  integer :: image_first,image_last,signal_first,signal_last ! In MHz.
  real(kind=4) :: image_first,image_last    ! [ MHz]
  real(kind=4) :: signal_first,signal_last  ! [ MHz]
  real(kind=8) :: x_signal,x_image          ! [ MHz]
  real(kind=4) :: mean_freq                 ! [ MHz]
  real(kind=4), parameter :: fres_tol=0.01  ! [    ] Relative tolerance on DSB channel width
  character(len=25) :: check
  character(len=80) :: mess    ! Error or debug or info messages.
  !
  check = ">>>>>>>>>>>>>>"//rname
  !
  ! Decode input line arguments
  use_model    = sic_present(1,0)
  use_simulate = sic_present(2,0)
  use_weight   = sic_present(3,0)
  use_bmsw     = sic_present(4,0)
  !
  !
  cont_offset = 1.e-3  ! 0.0 causes failure of MEM deconvolution
  call sic_r4(line,0,1,cont_offset,.false.,error)
  if (error) return
  write(mess,'(a,g12.4)') "Continuum offset: ",cont_offset
  call class_message(seve%i,rname,mess)
  if (use_weight) then
     call sic_r4(line,3,1,sigma_weight,.true.,error)
     if (error) return
  endif
  !
  !>> hogm 3bis
  ! Distinguish between spacially (within the IF) varying gain or
  ! piecewise constant gain (within the IF) take care this MUST be
  ! defined in deconv_init because of the gain initialisation
  variable_gain=.false.
  print*,check,'variable gain ',variable_gain
  !<< hogm 3bis
  if (use_model) then
     write(mess,*) "/MODEL Not yet implemented"
     call class_message(seve%i,rname,mess)
     return
  endif
  if (use_simulate) then
     write(mess,*) "/SIMULATE Not yet implemented"
     call class_message(seve%i,rname,mess)
     return
  endif
  !
  ! Sanity checks
  !
  ! Verify if any input file
  if (.not.filein_opened(rname,error))  return
  if (cx%next.le.1) then
     call class_message(seve%e,rname,'Index is empty')
     error = .true.
     return
  endif
  !
  ! Free memory if any already allocated
  call deconv_dealloc(error)
  if (error) return
  !
  ! Read the first observation into OBS
  knext= 1
  call init_obs(obs)
  call get_first(set,obs,user_function,error)
  if (error) return
  dsb_counter = cx%next-1
  dsb_size    = 0 ! dsb_spectrum is empty at the beginning.
  blanked     = 0 ! Number of blanked channels. Not used,but could be
  !
  ! Read the first guesses for these standing waves.
  n_sw_bm = 0
  if (use_bmsw) then
     call sic_i4(line,4,1,n_sw_bm,.true.,error)
     allocate( asw_bm(dsb_counter,n_sw_bm),stat=ier)
     allocate( psw_bm(dsb_counter,n_sw_bm),stat=ier)
     allocate(phsw_bm(dsb_counter,n_sw_bm),stat=ier)
     allocate(asw_bm_model(dsb_counter,n_sw_bm),stat=ier)       ! model's swbm amplitude.
     allocate(psw_bm_model(dsb_counter,n_sw_bm),stat=ier)       ! model's swbm pulsation.
     allocate(phsw_bm_model(dsb_counter,n_sw_bm),stat=ier)      ! model's swbm phase.
     allocate(norm_asw_bm_model(dsb_counter,n_sw_bm),stat=ier)  !
     allocate(norm_psw_bm_model(dsb_counter,n_sw_bm),stat=ier)  !
     allocate(norm_phsw_bm_model(dsb_counter,n_sw_bm),stat=ier) !
     if (failed_allocate(rname,'Standing wave arrays',ier,error))  goto 100
     asw_bm  = 0.0
     psw_bm  = 0.0
     phsw_bm = 0.0
     do i = 1,n_sw_bm
        call sic_r4(line,4,3*i-1,asw_bm(1,i) ,.true.,error)
        if (error) goto 100
        call sic_r4(line,4,3*i  ,psw_bm(1,i) ,.true.,error)
        if (error) goto 100
        call sic_r4(line,4,3*i+1,phsw_bm(1,i),.true.,error)
        if (error) goto 100
        write(mess,'(a,i2,3g12.4)') 'BMSW: ',i,asw_bm(1,i),psw_bm(1,i),phsw_bm(1,i)
        call class_message(seve%i,rname,mess)
        do j=2,dsb_counter
           asw_bm(j,i)  =  asw_bm(1,i)
           psw_bm(j,i)  =  psw_bm(1,i)
           phsw_bm(j,i) =  phsw_bm(1,i)
        enddo
     enddo
  endif
  !
  ! Go through the index to compute dsb_size
  dsb_size = 0
  do scan=1,dsb_counter
     entry_num = cx%ind(scan) ! Take the observation number of the scan^th observation in the index.
     call get_it(set,obs,entry_num,user_function,error)
     if (error) goto 100
     nc = count(obs%spectre(1:obs%cnchan).ne.obs%head%spe%bad)
     dsb_size = dsb_size+nc
  enddo
  !
  ! Memory allocation of DSB arrays
  ! Zero-size array are legitimate objects
  call deconv_allocate('DSB',error)
  if (error) goto 100
  !
  ! Initialization from 1st DBS observation
  ! Store 1st DBS observation header to be copied into the SSB header
  call get_it(set,obs,cx%ind(1),user_function,error)
  if (error) goto 100
  dsb_head = obs%head
  dsb_width = abs(obs%head%spe%fres)
  ssb_voff  = obs%head%spe%voff
  write (mess,'(A,F9.6)') 'Frequency resolution (MHz) = ',dsb_width
  call class_message(seve%i,rname,mess)
  write (mess,'(A,F9.6)') 'Velocity at ref. chan (km/s) = ',ssb_voff
  call class_message(seve%i,rname,mess)
  !
  ! Check telescope (needed to assess usage of sideband gain correction later)
  call sic_upper(obs%head%gen%teles)
  hifi = index(obs%head%gen%teles,'HIF-').ne.0
  ! Store variables from GENERAL section of header
  dsb_system = obs%head%pos%system
  dsb_time = obs%head%gen%time
  !
  ! Read the DSB scans from the CLASS index.
  dsb_size = 0
  ii = 0
  do scan=1,dsb_counter
     single_size(scan) = 0
     entry_num = cx%ind(scan) ! Take the observation number of the scan^th observation in the index.
     call get_it(set,obs,entry_num,user_function,error)
     if (error) goto 100
!!$     if (scan.eq.1) then
!!$        dsb_width = abs(obs%head%spe%fres)
!!$        ssb_voff  = obs%head%spe%voff
!!$        dsb_telescope = obs%head%gen%teles
!!$        dsb_source = obs%head%pos%sourc
!!$        write (mess,'(A,F9.6)') 'Frequency resolution (MHz) = ',dsb_width
!!$        call class_message(seve%i,rname,mess)
!!$        write (mess,'(A,F9.6)') 'Velocity at ref. chan (km/s) = ',ssb_voff
!!$        call class_message(seve%i,rname,mess)
!!$     else if (abs(abs(obs%head%spe%fres)-dsb_width).gt.epsilon) then
!!$        write(mess,'(a,f12.4,1x,f12.4)') 'Changing channel widths: ',dsb_width,abs(obs%head%spe%fres)
!!$        call class_message(seve%i,rname,mess)
!!$     endif
     if (abs(obs%head%spe%fres/dsb_width-1.d0).gt.fres_tol) then
        dsb_width = abs(obs%head%spe%fres)
        write(mess,'(a,f12.4,1x,f12.4)') 'Changing channel widths: ',dsb_width,abs(obs%head%spe%fres)
        call class_message(seve%i,rname,mess)
     endif
     ! Frequency Switch: obs%head%swi%swmod.eq.mod_freq is not a
     ! sufficient test because FSWITCH mode has mod_freq=0 and any
     ! value initialized to 0 would match the criterium.
     freq_switch = r%head%presec(class_sec_swi_id).and.&
          obs%head%swi%swmod.eq.mod_freq.and.    &
          r%head%swi%nphas.gt.1
     if (freq_switch) then
        do i=1,2
           freq_throw(scan,i) = obs%head%swi%decal(i)
           decal              = freq_throw(scan,i)/obs%head%spe%fres
!!$           chan_throw(scan,i) = int(freq_throw(scan,i)/obs%head%spe%fres)
           if (decal.ge.0) then
              chan_throw(scan,i) = int(decal)
           else
              chan_throw(scan,i) = int(decal)-1
           endif
           ! Why is the weight rounded to the nearest integer ???? PHB
           throw_poids(scan,i) = anint(obs%head%swi%poids(i))
           print *,check,'scan,i,chan_throw(scan,i):',scan,i,chan_throw(scan,i),freq_throw(scan,i),throw_poids(scan,i)
        enddo
     else
        do i=1,2
           freq_throw(scan,i) = 0.
           chan_throw(scan,i) = 0.
        enddo
     endif
     ! ?????????????????? should be modified
     !
     ! Copy the DSB spectrum from CLASS to XCLASS.
     !>> hogm 5
     ! Store these quantities to calculate the position of the channels
     dsb_rrestf(scan) = obs%head%spe%restf
     dsb_rimage(scan) = obs%head%spe%image
     dsb_rrchan(scan) = obs%head%spe%rchan
     dsb_cnchan(scan) = obs%cnchan
     !<< hogm 5
     !
     !
     !Store gain information for signal sideband  CC 19.6.2013
     if (obs%head%cal%gaini.eq.0.000) then
        gain_model_input(scan) = 1.0
     else
        if (hifi) then
           gain_model_input(scan) = obs%head%cal%gaini/0.5 ! HIFI works with relative gains
        else
           gain_model_input(scan) = obs%head%cal%gaini
        endif
     endif
     ! Loop over current observation channels
     do i=1,obs%cnchan
        if (obs%spectre(i).eq.obs%head%spe%bad) then
           blanked = blanked+1
        else
           single_size(scan) = single_size(scan)+1
           dsb_size          = dsb_size+1
           if (debug.and.i.eq.1)  print*,check,i,obs%cnchan,&
                obs%head%spe%rchan,obs%head%spe%fres,obs%head%spe%restf,obs%head%spe%image
           dsb_signal(dsb_size) =  (i-obs%head%spe%rchan)*dsb_width+obs%head%spe%restf
           dsb_image (dsb_size) = -(i-obs%head%spe%rchan)*dsb_width+obs%head%spe%image
!!$           dsb_signal(dsb_size) =  (i-obs%head%spe%rchan)*obs%head%spe%fres+obs%head%spe%restf
!!$           dsb_image (dsb_size) = -(i-obs%head%spe%rchan)*obs%head%spe%fres+obs%head%spe%image
           dsb_pointer(dsb_size) = scan
!           dsb_spectrum(dsb_size) = obs%spectre(i) ! Fill in DSB spectrum
           if (hifi) then  !CC 19.6.2013
              dsb_spectrum(dsb_size) = obs%spectre(i)*gain_model_input(scan) ! remove HIFI gain correction
                                                                             ! before deconvolving
           else  ! how other observatories use GAINIMAG must still be verified. In the meantime: do nothing
              dsb_spectrum(dsb_size) = obs%spectre(i)
           endif
           if (debug.and.mod(ii,100).eq.0.) then
              ii = dsb_size
              x_signal = (dsb_signal(ii)-dsb_rrestf(dsb_pointer(ii)))/dsb_width
              x_signal = (x_signal+dsb_rrchan(dsb_pointer(ii))-dsb_cnchan(dsb_pointer(ii))/2.)/dsb_cnchan(dsb_pointer(ii))
              x_image  = (dsb_image(ii)-dsb_rimage(dsb_pointer(ii)))/dsb_width
              x_image  = (-x_image+dsb_rrchan(dsb_pointer(ii))-dsb_cnchan(dsb_pointer(ii))/2.)/dsb_cnchan(dsb_pointer(ii))
              print*,check,i, ii, x_signal, x_image,dsb_width,obs%head%spe%fres
           endif
        endif
     enddo
     !
     ! Now, dsb_size has its definitive value. It really represents
     ! the number of channels in dsb_spectrum, the sum of all
     ! single_size.
     if (use_weight) then
        dsb_weight(scan) = sigma_weight
     else
        call obs_weight_time(rname,obs,weight,error)
        if (error)  goto 100
        ! Why weight is used as a divider?
        dsb_weight(scan) = obs%head%cal%beeff**2 / (weight*1e6)
     endif
     dsb_weight(scan) = 1.d0 ! ???????????????? PH
  enddo
  ! Fill in gain_model_input information for image sideband:
  !   gLSB + gUSB = 2
  do i = dsb_counter+1, 2*dsb_counter
     gain_model_input(i) = 2.-gain_model_input(i-dsb_counter)
  enddo
  !
  ! SSB and model X axis (channels,frequencies...).
  ! Frequency resolution.
  ssb_width = dsb_width
  ! Find first and last frequencies of the SSB frequency scale.
  signal_first = dsb_signal(1) ! Signal freq of the first channel.
  signal_last  = dsb_signal(1) ! Signal freq of the last  channel.
  image_first  = dsb_image(1)  ! Image  freq of the first channel.
  image_last   = dsb_image(1)  ! Image  freq of the last  channel.
  do i=1,dsb_size
     if (dsb_signal(i).lt.signal_first) signal_first = dsb_signal(i)
     if (dsb_signal(i).gt.signal_last ) signal_last  = dsb_signal(i)
     if (dsb_image(i) .lt.image_first ) image_first  = dsb_image(i)
     if (dsb_image(i) .gt.image_last  ) image_last   = dsb_image(i)
  enddo
  ssb_first = min(signal_first,image_first)
  ssb_last  = max(signal_last, image_last )
  !
  ! Determine the number of channels for that SSB.
  ssb_size = (ssb_last-ssb_first)/ssb_width+1
  !
  ! Ensure the number of channel is an integer.
  if (((ssb_last-ssb_first)/(1.*ssb_width)+1).ne.(1.*ssb_size)) then
     write(mess,'(a,f12.4,1x,i12,f12.4,f12.4)') 'Non-integer number of channels: ',&
          (ssb_last-ssb_first)/ssb_width+1.0,ssb_size
!!$     write(*,'(a,f12.4,1x,i12,f12.4,f12.4)') 'Non-integer number of channels: ',&
!!$          (ssb_last-ssb_first)/ssb_width+1.0,ssb_size,ssb_last,ssb_first
     call class_message(seve%w,rname,mess)
     ! Shrink the spectrum so that the number of channels of the final SSB is an integer.
     ! PHB ???????????????
     ssb_last = ssb_first+(ssb_size-1)*ssb_width
     write(mess,'(a,f12.4,1x,i12,f12.4,f12.4)') 'Set to integer number of channels: ',&
          (ssb_last-ssb_first)/ssb_width+1.0,ssb_size
     call class_message(seve%i,rname,mess)
!!$     ssb_size=ssb_size+1
     !ph removes this line while working with CC 13/05/09
     !phb put back this line 25/08/2009
!!$     error = .true. !Stop here ???? PHB 24/03/09
!!$     goto 100
  endif
  !
  ! Memory allocation of SSB arrays
  call deconv_allocate('SSB',error)
  if (error) goto 100
  !
  ! Creates the frequency axis of the SSB.
  call class_message(seve%i,rname,'Creates frequency axis of the ssb')

  !  do i = 1,ssb_size
  !     ssb_freq(i)  = ssb_first + ssb_width * (i - 1)
  !  enddo
  ! If no model is wanted, use a flat one.
  !========================================
  ! The only places where the model is used is entropy calculations and
  ! SSB initialization.
  ! So,we can make here some processing on the model in order to
  ! spare CPU later.
  ! 1: For entropy calculation,it is not the model that is reqired,but
  !    the model divided by its sum. We call this "normalized model".
  ! 2: In order to avoid negative parameters into log,an offset is added
  !    the the vector used for entropy calculation. Because the model
  !    won't change during all the deconvolution,we can add this offset
  !    here,instead of adding it every time a entropy is calculated.
  ! 3: There are two expression for the entropy equation. One with model
  !    and one without model. When we look closer,we realize that the
  !    expression of the entropy without model is a particular case
  !    of the expression of the entropy with model: the case where the
  !    normalized model equals 1.
  ! 4: Only the normalized model is used for entropy calculations,but
  !    some people might want to have a look at the non normalized model.
  !    So,we give it a value here. You can get it from XCLASS to CLASS
  !    using the XCLASS command MAKEMODEL on SIC command line.
  !    Plus,the non-normalized model is used to initialize the SSB. It
  !    worths keeping.
  do i = 1,ssb_size
     ssb_model(i)      = cont_offset
     norm_ssb_model(i) = 1.0
     ssb_freq(i)       = ssb_first+ssb_width*(i-1)
  enddo
  !
  ! sum_model is set to 0 but it has no meaning: it won't be used.
  sum_model = 0.0 ! sum_model : mem.inc,/mem_data/
  !
  ! SSB model gains
  do i=1,2*dsb_counter
     gain_model(i)   = 1.0 ! 1 everywhere : no sideband imbalances.
     ! hogm : this has to be modified to take into account the high order gain fitting
     norm_gain_model(i) = 1.0/dsb_counter ! PHB ???????
  enddo
  !>> hogm 6
  ! set to zero the high order gain coefficient
  if (variable_gain) then
     do i=2*dsb_counter+1,max_og*2*dsb_counter
        gain_model(i)   = 0. ! 1 everywhere : no sideband imbalances.
     enddo
  else
     do i=2*dsb_counter+1,max_og*2*dsb_counter
        gain_model(i)   = 1. ! 1 everywhere : no sideband imbalances.
     enddo
  endif
  !<< hogm 6
  !
  ! SSB model standing waves.
  ! Everything is given the value 1.0. When these values can be read from
  ! a file, we will have to give the value 1.0 only when use_model=.FALSE..
  ! The value 1.0 is required by the entropy() function in chisquare.f.
  do i = 1,n_sw_bm
     do j = 1,dsb_counter
        norm_asw_bm_model(j,i) = 1.d0
        norm_psw_bm_model(j,i) = 1.d0
        ! This initialization of the normalized model of the phase has no
        ! real meaning. It won't be used.
     enddo
  enddo
  !
  ! Before-mixing standing waves.
  ! one_out_of_f : Used with psw_bm in order to have a parameter close
  ! to 1 during the deconvolution. The derivative of the chisquare
  ! with respect to the pulsation causes the SSB frequency to get out
  ! of the sin(). Because the SSB frequencies are relatively high
  ! (something like 10^6), this contribution to the derivative is too
  ! high and the algorithm fails. In order to have something close to
  ! 1 getting out of the sin(),we choosed to introduce a constant
  ! which will get out the sin() in the same time that SSB frequency
  ! and which has a value compensating the SSB frequency : 1 /
  ! mean(SSB frequency).  So,instead of having d(sin(wf))/dw =
  ! f.cos(wf), we'll have d(sin(w0fF))/dw0 = fF.cos(w0fF),and fF is
  ! close to 1 because F = 1/mean(f).  You can see that w0 = w / F. It
  ! is that w0 we call psw_bm.
  mean_freq    = (ssb_first+ssb_last)/2.0 ! Mean (SSB frequencies).
  one_out_of_f = 1.0/mean_freq
  do i=1,n_sw_bm
     do j=1,dsb_counter
        psw_bm(j,i) = psw_bm(j,i)/one_out_of_f
     enddo
  enddo
  !
  ! Initialize the SSB.
  do i=1,ssb_size    ! usemodel=.FALSE.,ssb_model(i) = cont_offset.
     ssb_spectrum(i) = cont_offset    ! See at the end of model creation.
  enddo
  !
  ! Gains
  do i=1,2*dsb_counter
     gain(i) = gain_model(i)
  enddo
  !
  !>> hogm 7
  ! for high order gain coefficient
  do i=2*dsb_counter+1,max_og*2*dsb_counter
     gain(i) = gain_model(i)
  enddo
  !<< hogm 7
  !
  ! Free memory
  call free_obs(obs)
  return
100 call free_obs(obs)
  call deconv_dealloc(error)
end subroutine deconv_init
!
!
!
!
!
subroutine deconv(set,line,r,error,user_function)
  use gildas_def
  use gbl_message
  use gbl_constant
  use classcore_dependencies_interfaces
  use classcore_interfaces, except_this=>deconv
  use class_types
  use deconv_dsb_commons
  use f1_commons
  !-------------------------------------------------------------------
  ! @ public
  ! Support routine for command
  !
  ! DECONVOLVE tolerance itmax [lambda1 [lambda2 [lambda3]]]
  ! 1          [/GAIN [first_guess]]      !!CC 19.6.2013
  ! 2          [/DERIV]
  ! 3          [/BMSW n [NOA] [NOP] [NOPH]]
  ! 4          [/NOCHANNELS]
  ! 5          [/KEEP]
  !
  !-------------------------------------------------------------------
  type(class_setup_t), intent(in)    :: set
  character(len=*),    intent(in)    :: line
  type(observation),   intent(inout) :: r
  logical,             intent(out)   :: error
  logical,             external      :: user_function
  ! Local
  character(len=*), parameter :: rname='DECONV'
  logical :: use_bmsw,keep
  integer(kind=4) :: nkey,itmax,i,vect_size,ier,larg
  integer(kind=4) :: gain_first_guess
  real(kind=8) :: ftol
  integer(kind=4), parameter :: mvocab=3               ! Size of set vocabulary
  character(len=20)  :: arg,chain
  character(len=256) :: mess
  character(len=20), dimension(mvocab) :: vocab
  data vocab /'NOAMPLITUDE','NOPULSATION','NOPHASE'/
  character(len=25) :: check
  !
  check = ">>>>>>>>>>>"//rname
  !
  ! Decode input line arguments
  ftol        = 1.e-4 ! Default value
  itmax       = 1000  ! Default value
  error=.false.
  call sic_r8(line,0,1,ftol,   .true. ,error)
  if (error) goto 100
  call sic_i4(line,0,2,itmax,  .true. ,error)
  if (error) goto 100
  call sic_r8(line,0,3,lambda1,.false.,error)
  if (error) goto 100
  call sic_r8(line,0,4,lambda2,.false.,error)
  if (error) goto 100
  call sic_r8(line,0,5,lambda3,.false.,error)
  if (error) goto 100
  fit_gains   = sic_present(1,0)   !! CC 19.6.2013
  gain_first_guess = 1  ! Default: do not use GAINIMAG information as first guess for gain fitting
  call sic_i4(line,1,1,gain_first_guess,.false.,error)
  if (error) goto 100
  if (gain_first_guess.eq.0) then   !use gain input as first guess for gain fitting
     do i=1,2*dsb_counter
        gain(i) = gain_model_input(i)
     enddo
  endif
  use_deriv   = sic_present(2,0)
  use_bmsw    = sic_present(3,0)
  no_channels = sic_present(4,0)
  keep        = sic_present(5,0)
  no_bmswa    = .false.
  no_bmswp    = .false.
  no_bmswph   = .false.
  !
  !>> hogm 4
  ! set by hand the gain order
  ! this should be changed and read from the class script
  if (.not.fit_gains) then     !! CC 19.6.2013
     print*,'Not fitting the gains'
     o_gain = 1
     print*,'o_gain ',o_gain
  else
     print*,'Fitting the gains'
     o_gain = 1
     print*,'o_gain ',o_gain
  endif
  print*,check,'variable gain ',variable_gain
  !<< hogm 4
  !
  ! Finish memory allocation
  ! Depends on o_gain: if o_gain always 1, then do it in deconv_init ???????????? PHB
  vect_size = ssb_size+2*dsb_counter*o_gain+3*dsb_counter*n_sw_bm
  if (allocated(mem_pcom)) then
     deallocate(mem_pcom,mem_xicom,stat=ier)
     if (ier.ne.0) then
        call class_message(seve%e,rname,'Could not deallocate minimization arrays.')
        error = .true.
        return
     endif
  endif
  allocate(mem_pcom(vect_size),mem_xicom(vect_size),stat=ier)
  if (failed_allocate(rname,"Global minimization arrays",ier,error)) return
  !
  ! Sanity check
  ! Check for allocated arrays
  call deconv_allocate('ALL',error)
  if (error) return
  !
  ! Before-mixing standing waves first guesses.
  if (use_bmsw) then
     ! read the number of standing waves.
     if (sic_present(4,1)) then
        call sic_i4(line,4,1,i,.true.,error)
        if (error) goto 100
        if (i.gt.n_sw_bm) then
           write(mess,*) "Required number of standing waves larger than supplied."
           error = .true.
           goto 100
        endif
        ! Read "NOA","NOP" and "NOPH" to block them in delta_chi().
        do i=2,4
           if (.not.sic_present(4,i)) exit
           call sic_ke(line,4,i,arg,larg,.false.,error)
           call sic_ambigs(rname,arg,chain,nkey,vocab,mvocab,error)
           if (error) goto 100
           select case(chain)
           case('NOAMPLITUDE')
              no_bmswA  = .true.
           case('NOPULSATION')
              no_bmswP  = .true.
           case('NOPHASE')
              no_bmswPh = .true.
           end select
        enddo
     endif
  endif
  !
  !
  ! Write deconvolution parameters on screen.
  write (mess,*) 'Tolerance : ',ftol
  call class_message(seve%i,rname,mess)
  write (mess,*) 'Maximum number of iterations : ',itmax
  call class_message(seve%i,rname,mess)
  write (mess,*) 'Lambda1 = ',lambda1,'  Lambda2 = ',lambda2,'  Lambda3 = ',lambda3
  call class_message(seve%i,rname,mess)
  !
  write(mess,*) 'Sideband imbalances: ',fit_gains   !! CC 19.6.2013
  call class_message(seve%i,rname,mess)
  write(mess,*) 'Derivatives: ',use_deriv
  call class_message(seve%i,rname,mess)
  write(mess,*) 'Before-mixing standing waves: ',use_bmsw
  call class_message(seve%i,rname,mess)
  if (use_bmsw) then
     write (mess,*) 'Number of standing waves: ',n_sw_bm
     call class_message(seve%i,rname,mess)
     write(mess,*) 'BMSW Amplitude locked:',no_bmswa
     call class_message(seve%i,rname,mess)
     write(mess,*) 'BMSW Pulsation locked:',no_bmswp
     call class_message(seve%i,rname,mess)
     write(mess,*) 'BMSW Phase     locked:',no_bmswph
     call class_message(seve%i,rname,mess)
  endif
  !
  ! Do the job
  call deconvolve(ftol,itmax,error)
  if (error) goto 100
  call deconv_makessb(set,r,error,user_function)
  if (error) goto 100
  !
  ! Free allocated memory
  if (.not.keep) then
     call deconv_dealloc(error)
  endif
  return
100 call deconv_dealloc(error)
end subroutine deconv
!
!
!
!
!
subroutine deconvolve(ftol,itmax,error)
  use gildas_def
  use phys_const
  use gbl_message
  use classcore_dependencies_interfaces
  use classcore_interfaces, except_this=>deconvolve
  use f1_commons
  use deconv_dsb_commons
  !-------------------------------------------------------------------
  ! @ private
  ! This subroutine prepares the deconvolution process by initializing variables.
  ! deconvolve() gives frprmn() the parameters it needs to really calculate the
  ! deconvolution. frprmn() is supposed to return a SSB spectrum which minimizes
  ! the chisquare() function.
  !
  ! Convergence criterium: If the chisquare() evolution between two iterations of
  ! frprmn() is lower than ftol,frprmn() considers it has
  ! achieved convergence. If iter > IT_MAX (as defined in frprmn()),
  ! it means that frprmn() had not finised its convergence.
  !
  ! The information printed on screen at the end is not fundamental,but can be
  ! of any interest. It prints:
  ! - the value found for chisquare() (named min_chi);
  ! - the number of iteration frprmn() required to achieve it (named iter);
  ! - the LSB and USB gains found for each of the dsb_counter DSB scans (gain).
  ! After the deconvolution performed by frprmn(), ssb_spectrum stays in memory
  ! and can be transfered into CLASS.
  !-------------------------------------------------------------------
  real(kind=8),    intent(in)  :: ftol  ! Tolerance on chisqare evolution
  integer(kind=4), intent(in)  :: itmax ! Maximum iteration for frprmn
  logical,         intent(out) :: error ! Error flag
  ! Local
  character(len=*), parameter :: rname='DECONVOLVE'
  character(len=80) :: mess
  ! These vectors contain a copy of ssb_spectrum gain and SW, but in double precision.
  real(kind=8) :: dssb_spectrum(ssb_size)
  !<< hogm 9
  !  real(kind=8) :: dgain(2 * dsb_counter)
  ! the size of the gain array should be modified
  real(kind=8) :: dgain(2*o_gain*dsb_counter)
  !>> hogm 9
  !
  real(kind=8) :: dasw_bm (dsb_counter,n_sw_bm)
  real(kind=8) :: dpsw_bm (dsb_counter,n_sw_bm)
  real(kind=8) :: dphsw_bm(dsb_counter,n_sw_bm)
  ! This vector is used to transport dssb_spectrum and dgain in a single vector.
  !<< hogm 8
  ! PH changed this. There was a bug there.
  ! real(kind=8)  :: vect(ssb_size+2*dsb_counter+3*dsb_counter*n_sw_bm_max)
  ! replace this line by
  real(kind=8), allocatable, dimension(:) :: vect
  ! to take the high order gain extension
  !>> hogm 8
  integer(kind=4) :: vect_size ! Logical nb of elements of vect: ssb_size + 2 * dsb_counter.
  real(kind=8) :: min_chi      ! chisquare() value of the SSB which minimizes chisquare().
  integer(kind=4) :: iter      ! Number of iterations made by frprmn() to achieve
  integer(kind=4) :: i,j,ier
  !
  ! Initialization
  min_chi   = 1.
  iter      = 0
  error     = .false.
  !<< hogm 8bis
  !  vect_size = ssb_size+2*dsb_counter+3*dsb_counter*n_sw_bm_max ! size of the array vect
!!$  vect_size = ssb_size+2*dsb_counter*o_gain+3*dsb_counter*n_sw_bm_max ! size of the array vect
  !>> hogm 8bis
  !
  ! Memory allocation
  vect_size = ssb_size+2*dsb_counter*o_gain+3*dsb_counter*n_sw_bm
  allocate(vect(vect_size),stat=ier)
  if (failed_allocate(rname,'Concatenated array',ier,error)) return
  !
  ! Double-ization of vectors.
  do i=1,dsb_size
     ddsb_spectrum(i) = dble(dsb_spectrum(i))
  enddo
  do i=1,ssb_size
     dssb_spectrum(i) = dble(ssb_spectrum(i))
  enddo
  do i=1,2*dsb_counter
     dgain(i) = dble(gain(i))
     do j=1,n_sw_bm
        dasw_bm (i,j) = dble(asw_bm (i,j))
        dpsw_bm (i,j) = dble(psw_bm (i,j))
        dphsw_bm(i,j) = dble(phsw_bm(i,j))
     enddo
  enddo
  !hogm 9
  !convert the high order gain coefficient in double precision
  do i=2*dsb_counter+1,2*dsb_counter*o_gain
     dgain(i) = dble(gain(i))
  enddo
  !hogm 9
  do i=1,vect_size
     vect(i) = 0.
  enddo
  !
  call class_message(seve%i,rname,'Start deconvolution')
  !
  ! Concatenation of SSB vectors.
  call vect_contract(vect,dssb_spectrum,dgain,dAsw_bm,dpsw_bm,dphsw_bm)
  !
  ! Do the real job: minimization of X2 - l1*F_ssb - l2*F_gain - l3*F_sw.
  ! It returns vect,iter and min_chi.
  !      print*,'enter in delta_chi'
  !      call delta_chi(vect, xi, vect_size)
  !      print*,'enter in chi from deconv'
  !      fp = chisquare(vect, vect_size)
  !      print*,'delta_chi ok'
  call frprmn(vect,vect_size,ftol,itmax,iter,min_chi,error)
  if (error) return
  !
  ! Expansion of SSB vectors.
  call vect_expand(vect,dssb_spectrum,dgain,dAsw_bm,dpsw_bm,dphsw_bm,vect_size)
  !
  ! Constraints phase between -pi and pi
  do i=1,dsb_counter
     do j=1,n_sw_bm
        do while (dphsw_bm(i,j).gt.pi)
           dphsw_bm(i,j) = dphsw_bm(i,j)-pi*2
        enddo
        do while (dphsw_bm(i,j).le.-pi)
           dphsw_bm(i,j) = dphsw_bm(i,j)+pi*2
        enddo
     enddo
  enddo
  !
  ! Single-ization of vectors.
  do i = 1,ssb_size
     ssb_spectrum(i) = sngl(dssb_spectrum(i))
     ! Set blanked channels to BAD, not to cont_offset
     if (abs(ssb_spectrum(i)).eq.cont_offset) then
        ssb_spectrum(i) = dsb_head%spe%bad
     endif
  enddo
  do i = 1,2*dsb_counter
     gain(i) = sngl(dgain(i))
     do j = 1,n_sw_bm
        asw_bm (i,j) = sngl(dasw_bm (i,j))
        psw_bm (i,j) = sngl(dpsw_bm (i,j))
        phsw_bm(i,j) = sngl(dphsw_bm(i,j))
     enddo
  enddo
  !
  ! Print results.
  write (mess,'(a,g10.4,a,i5)') 'Min Chisquare = ',min_chi,' iterations=',iter
  call class_message(seve%i,rname,mess)
  call class_message(seve%i,rname,'    DSB   Input_gain(sig)   Input_gain(im)   Output_gain(sig)    Output_gain(im) ')
  do i=2*dsb_counter+1,2*o_gain*dsb_counter
     gain(i) = sngl(dgain(i))
  enddo
  !hogm 9bis
  !hogm 10
  do j=1,o_gain
     do i=1,dsb_counter
        write(mess,'(2i3,4g17.3)') i,j,gain_model_input(i+(j-1)*2*dsb_counter), &    ! CC 19.6.2013 writes out initial guess gains and fitted gains
             gain_model_input(i+dsb_counter+(j-1)*2*dsb_counter), &
             gain(i+(j-1)*2*dsb_counter),gain(i+dsb_counter+(j-1)*2*dsb_counter)
        call class_message(seve%i,rname,mess)
     enddo
  enddo
  !hogm 10
  !
  deallocate(vect)
  call class_message(seve%i,rname,'Deconvolution done')
end subroutine deconvolve
!
!
!
!
!
subroutine deconv_makessb(set,r,error,user_function)
  use gildas_def
  use phys_const
  use gbl_constant
  use gbl_message
  use classcore_dependencies_interfaces
  use classcore_interfaces, except_this=>deconv_makessb
  use class_types
  use deconv_dsb_commons
  !-------------------------------------------------------------------
  ! @ private
  ! This subroutine copies the deconvolved SSB spectrum ssb_spectrum
  ! into the CLASS R-memory.
  !-------------------------------------------------------------------
  type(class_setup_t), intent(in)    :: set            !
  type(observation),   intent(inout) :: r              !
  logical,             intent(inout) :: error          ! Error flag
  logical,             external      :: user_function  !
  ! Local
  character(len=*), parameter :: rname="MAKE_SSB"
  !
  ! Initialize R header
  call rzero(r,'NULL',user_function)
  !
  ! Compute X axis
  r%cnchan         = ssb_size
  r%head%spe%nchan = r%cnchan
  r%head%spe%rchan = 1                                            ! [    ] Reference channel
  r%head%spe%restf = ssb_first                                    ! [ MHz] Rest frequency
  r%head%spe%fres  = ssb_width                                    ! [ MHz] Frequency resolution
  r%head%spe%vres  = -clight_kms*r%head%spe%fres/r%head%spe%restf ! [km/s] Velocity resolution
  r%head%spe%voff  = ssb_voff                                     ! [km/s] Velocity offset
  if (r%head%spe%restf.eq.0) r%head%spe%restf  =  3.0d5
  if (r%head%spe%fres.eq.0)  r%head%spe%fres   = -1.0
  if (r%head%spe%vres.eq.0)  r%head%spe%vres   = -clight_kms*r%head%spe%fres/r%head%spe%restf
  if (r%head%spe%bad.eq.0)   r%head%spe%bad    = -1000.0
  r%cbad = r%head%spe%bad
  r%head%spe%line = 'DECONV-SSB'
  r%head%gen%teles = dsb_head%gen%teles
  r%head%pos%sourc = dsb_head%pos%sourc
  r%head%gen%kind = kind_spec
  r%head%presec(class_sec_xcoo_id) = .false.    ! Regularly sampled X-axis
  !
  call reallocate_obs(r,r%cnchan,error)
  if (error) return
  call abscissa(set,r,error)
  if (error) return
  !
  ! Copy the XCLASS vector ssb_spectrum into the CLASS R-memory.
  call r4tor4(ssb_spectrum,r%data1,r%head%spe%nchan)
  !
  ! Fill in header
  call sic_gagdate(r%head%gen%dobs)
  !
  !Fill in source information ! CC 4.7.2013
  r%head%pos%system = dsb_head%pos%system
  r%head%pos%equinox = dsb_head%pos%equinox
  r%head%pos%lam = dsb_head%pos%lam
  r%head%pos%bet = dsb_head%pos%bet
  !
  ! Fill in GENERAL section ! CC 4.7.2013
  r%head%gen%dobs    = dsb_head%gen%dobs
  r%head%gen%qual    = qual_unknown
  r%head%gen%tsys    = 1
  r%head%gen%time    = dsb_head%gen%time
  r%head%presec(class_sec_gen_id) = .true.     ! if .false., spectrum can't be written out CC 4.7.2013
  r%head%presec(class_sec_pos_id) = .true.     ! if .false., spectrum can't be written out CC 4.7.2013
  r%head%presec(class_sec_spe_id) = .true.    ! if .false., spectrum can't be written out cc 4.7.2013
!
  r%head%presec(class_sec_desc_id) = .false.     ! Not an OTF spectrum
  r%head%des%ndump=1
  r%head%xnum  = -1                      ! Modeled observation will be in memory but was not red from a file
  !
  ! Finish
  call newdat(set,r,error)
  call class_message(seve%i,rname,'Deconvolved SSB array in R buffer')
end subroutine deconv_makessb
!
!
!
!
subroutine vect_expand(pvect,pssb,pgain,pAsw_bm,ppsw_bm,pphsw_bm,psize)
  use gildas_def
  use gbl_message
  use classcore_interfaces
  use deconv_dsb_commons
  !-------------------------------------------------------------------
  ! @ no-interface (because of dummy dimension using parameters)
  ! The variables given to vect_expand() have a "p" as first letter,
  ! meaning they are Parameters of the subroutine. So, they won't
  ! be confused with other variables in common blocs which could have
  ! a similar name (ssb, gain, ...).
  !-------------------------------------------------------------------
  integer(kind=4), intent(in)  :: psize
  real(kind=8),    intent(in)  :: pvect(psize)
  real(kind=8),    intent(out) :: pssb(ssb_size)                ! contains the spectral power information of the SSB
  real(kind=8),    intent(out) :: pgain(2*dsb_counter*o_gain)   ! contains the lower and upper side band gains
  real(kind=8),    intent(out) :: pasw_bm (dsb_counter,n_sw_bm) ! amplitude of SW before mixing
  real(kind=8),    intent(out) :: ppsw_bm (dsb_counter,n_sw_bm) ! pulsation of SW before mixing
  real(kind=8),    intent(out) :: pphsw_bm(dsb_counter,n_sw_bm) ! phase     of SW before mixing
  ! Local
  character(len=*), parameter :: rname='VECT_EXPAND'
  integer(kind=4) :: j,i,i_offset_A,i_offset_p,i_offset_ph,debug_index
  !
  debug_index = 0
  ! Copy the spectral power, gain, and SW informations
  do i = 1, ssb_size
     pssb(i) = pvect(i)
  enddo
  do i=1,2*o_gain*dsb_counter
     pgain(i) = pvect(ssb_size+i)
  enddo
  i_offset_A  = ssb_size+2*o_gain*dsb_counter+1
  i_offset_p  = i_offset_A+n_sw_bm*dsb_counter
  i_offset_ph = i_offset_p+n_sw_bm*dsb_counter
  do j=1,n_sw_bm
     do i=1,dsb_counter
        pAsw_bm (i,j) = pvect(i_offset_A )
        ppsw_bm (i,j) = pvect(i_offset_p )
        pphsw_bm(i,j) = pvect(i_offset_ph)
        i_offset_A    = i_offset_A+1
        i_offset_p    = i_offset_p+1
        i_offset_ph   = i_offset_ph+1
        debug_index   = debug_index+1
     enddo
  enddo
end  subroutine vect_expand
!
!
!
!
!
subroutine vect_contract(pvect,pssb,pgain,pAsw_bm,ppsw_bm,pphsw_bm)
  use gildas_def
  use gbl_message
  use classcore_interfaces
  use deconv_dsb_commons
  !-------------------------------------------------------------------
  ! @ no-interface (because of dummy dimension using parameters)
  ! The variables given to vect_contract() have a "p" as first letter,
  ! meaning they are Parameters of the subroutine. So, they won't
  ! be confused with other variables in common blocs which could have
  ! a similar name (ssb, gain, ...).
  !-------------------------------------------------------------------
  real(kind=8), intent(out) :: pvect(ssb_size+2*dsb_counter*o_gain+3*dsb_counter*n_sw_bm)
  real(kind=8), intent(in)  :: pssb(ssb_size)                ! contains the spectral power information of the SSB
  real(kind=8), intent(in)  :: pgain(2*dsb_counter*o_gain)   ! contains the lower and upper side band gains
  real(kind=8), intent(in)  :: pasw_bm (dsb_counter,n_sw_bm) ! amplitude of SW before mixing
  real(kind=8), intent(in)  :: ppsw_bm (dsb_counter,n_sw_bm) ! pulsation of SW before mixing
  real(kind=8), intent(in)  :: pphsw_bm(dsb_counter,n_sw_bm) ! phase     of SW before mixing
  ! Local
  character(len=*), parameter :: rname='VECT_CONTRACT'
  integer(kind=4) :: j,i,i_offset_A,i_offset_p,i_offset_ph
  !
  !  call class_message(seve%i,rname,'Starting vector concatenation')
  ! Copy the spectral power, gain and SW informations
  do i=1,ssb_size
     pvect(i) = pssb(i)
  enddo
  do i=1,2*o_gain*dsb_counter
     pvect(ssb_size+i) = pgain(i)
  enddo
  i_offset_A  = ssb_size+2*o_gain*dsb_counter+1
  i_offset_p  = i_offset_A+n_sw_bm*dsb_counter
  i_offset_ph = i_offset_p+n_sw_bm*dsb_counter
  do j=1,n_sw_bm
     do i=1,dsb_counter
        pvect(i_offset_A ) = pAsw_bm (i,j)
        pvect(i_offset_p ) = ppsw_bm (i,j)
        pvect(i_offset_ph) = pphsw_bm(i,j)
        i_offset_A  = i_offset_A +1
        i_offset_p  = i_offset_p +1
        i_offset_ph = i_offset_ph+1
     enddo
  enddo
end subroutine vect_contract
!
!
!
!
!
subroutine frprmn(p,n,ftol,itmax,iter,fret,error)
  use gildas_def
  use gbl_message
  use classcore_dependencies_interfaces
  use classcore_interfaces, except_this=>frprmn
  use deconv_dsb_commons
  !-------------------------------------------------------------------
  ! @ private
  ! Fletcher-Reeves-Polak-Ribiere minimization (Numerical Recipes)
  ! Requires the calculation of derivatives for the function.
  !-------------------------------------------------------------------
  integer(kind=4), intent(in)    :: n     ! Size of p
  real(kind=8),    intent(in)    :: ftol  ! Tolerance on MEM deconvolution
  integer(kind=4), intent(in)    :: itmax ! Maximal number of iteration before returing
  integer(kind=4), intent(out)   :: iter  ! Iterations counter
  real(kind=8),    intent(out)   :: fret  ! X^2 - lambda1 * Sspectrum - lambda2 * Sgain
  logical,         intent(out)   :: error ! Logical error flag
  real(kind=8),    intent(inout) :: p(n)  ! Vector to deconvolve
  ! Local
  character(len=*), parameter :: rname='FRPRMN'
  real(kind=8), parameter :: eps=1.d-20
  integer(kind=4)           :: its,j
  real(kind=8)            :: dgg,fp,gam,gg
  real(kind=8)            :: g(n),h(n),xi(n)
  character(len=80) :: mess
  !
  ! Initializations.
  error = .false.
  fp = chisquare(p,n)
  !
  call delta_chi(p,xi,n)
  do j=1,n
     g(j)  = -xi(j)
     h(j)  =   g(j)
     xi(j) =   h(j)
  enddo
  !
  ! Loop over iterations.
  do its=1,itmax
     write (mess,'(a,i3,a,es15.6)') 'Iter = ', its,' ; Chisquare = ',fp
     call class_message(seve%i,rname,mess)
     iter = its
     if (debug) then
        print*,'p(1:2) ',p(1:2)
        print*,'p(ssb_size-1:ssb_size) ',p(ssb_size-1:ssb_size)
        print*,'p(ssb_size+1:ssb_size+2) ',p(ssb_size+1:ssb_size+2)
        print*,'p(ssb_size+2*dsb_counter-1:ssb_size+2*dsb_counter) ', p(ssb_size+2*dsb_counter-1:ssb_size+2*dsb_counter)
        if (o_gain .gt. 1) then
           print*,'p(ssb_size+2*dsb_counter+1:ssb_size+2*dsb_counter+2) ',p(ssb_size+1+2*dsb_counter:ssb_size+2+2*dsb_counter)
           print*,'p(ssb_size+2*dsb_counter-1:ssb_size+2*dsb_counter) ', p(ssb_size+4*dsb_counter-1:ssb_size+4*dsb_counter)
        endif
        print*,'xi(1:2) ',xi(1:2)
        print*,'xi(ssb_size-1:ssb_size) ',xi(ssb_size-1:ssb_size)
        print*,'xi(ssb_size+1:ssb_size+2) ',xi(ssb_size+1:ssb_size+2)
        print*,'xi(ssb_size+2*dsb_counter-1:ssb_size+2*dsb_counter) ', xi(ssb_size+2*dsb_counter-1:ssb_size+2*dsb_counter)
        if (o_gain .gt. 1) then
           print*,'xi(ssb_size+2*dsb_counter+1:ssb_size+2*dsb_counter+2) ',xi(ssb_size+2*dsb_counter+1:ssb_size+2*dsb_counter+2)
           print*,'xi(ssb_size+4*dsb_counter-1:ssb_size+4*dsb_counter) ', xi(ssb_size+4*dsb_counter-1:ssb_size+4*dsb_counter)
        endif
     endif
     !
     call mem_linmin(p,xi,n,fret,use_deriv,error)
     if (error) return
     ! Next statement is the normal return :
     if (2.d0*abs(fret-fp).le.ftol*(abs(fret)+abs(fp)+eps)) then
        ! fret-fp : chisquare variation between last iter (fp) and new (fret).
        ! (fp+fret)/2 is almost equal to fp. And Epsilon is just here to
        ! avoid a zero on the right.
        write(mess,'(a,es12.3,es12.3)') 'Chi^2 variation smaller than ftol: ',fp,fret
        call class_message(seve%e,rname,mess)
        return
     endif
     fp = chisquare(p,n)
     call delta_chi(p,xi,n)
     gg  = 0.d0
     dgg = 0.d0
     do j = 1,n
        gg  = gg+g(j)**2
        !         dgg = dgg + xi(j)         **2 ! This statement for Fletcher-Reeves.
        dgg = dgg+(xi(j)+g(j))*xi(j) ! This one for Polak-Ribiere.
     enddo
     if (gg.eq.0.d0) return ! If gradient is exactly zero then we are already done.
     gam = dgg/gg
     do j=1,n
        g(j)  = -xi(j)
        h(j)  =   g(j)+gam*h(j)
        xi(j) =   h(j)
     enddo
     if (sic_ctrlc()) then
        call class_message(seve%e,rname,'Aborted by ^C')
        error = .true.
        return
     endif
  enddo
  call class_message(seve%e,rname,'Maximum iterations exceeded.')
end subroutine frprmn
!
!
!
!
!
subroutine mem_linmin(xp,xi,n,fret,use_deriv,error)
  use classcore_interfaces, except_this=>mem_linmin
  use f1_commons
  !-------------------------------------------------------------------
  ! @ private
  ! Finds the minimum of a N-dimensional function along vector xi from
  ! a specific point P, both defined in N-space. 'linmin' does the
  ! bookkeeping required to treat the function as a function of
  ! position along this line, and minimizes the function with
  ! conventional 1-D minimization routine.
  !-------------------------------------------------------------------
  integer(kind=4), intent(in)    :: n         ! Size of p and xi.
  real(kind=8),    intent(out)   :: fret      !
  real(kind=8),    intent(inout) :: xp(n)     !
  real(kind=8),    intent(inout) :: xi(n)     !
  logical,         intent(in)    :: use_deriv !
  logical,         intent(out)   :: error     ! Logical error flag
  ! Local
  real(kind=8), parameter :: tol=1.d-4
  integer(kind=4) :: j
  real(kind=8) :: ax,bx,fa,fb,fx,mem_xmin,xx
  !
  mem_ncom=n
  do j=1,n
     mem_pcom(j)  = xp(j)
     mem_xicom(j) = xi(j)
  enddo
  ax = 0.d0
  xx = 1.d0
  bx = 2.d0
  !
  call mem_mnbrak(ax,xx,bx,fa,fx,fb,mem_f1dim,error)
  !
  ! Choose between brent and dbrent:
  if (use_deriv) then
     fret = mem_dbrent(ax,xx,bx,mem_f1dim,mem_df1dim,tol,mem_xmin)
  else
     fret = mem_brent(ax,xx,bx,mem_f1dim,tol,mem_xmin)
  endif
  do j=1,n
     xi(j) = mem_xmin*xi(j)
     xp(j) = xp(j)+xi(j)
  enddo
end subroutine mem_linmin
!
!
!
!
!
subroutine mem_mnbrak(ax,bx,cx,fa,fb,fc,func,error)
  use gbl_message
  use classcore_interfaces, except_this=>mem_mnbrak
  !-------------------------------------------------------------------
  ! @ private
  ! Search a given function for a minimum. Given two values 'ax' and
  ! 'bx' of abscissa, searches in the downward direction until it can
  ! find 3 new valies 'ax', 'bx,' and 'cx' that bracket a
  ! minimum. 'fa', 'fb', 'fc' are the values of the function at these
  ! points.
  !-------------------------------------------------------------------
  real(kind=8), intent(inout) :: ax
  real(kind=8), intent(inout) :: bx
  real(kind=8), intent(out)   :: cx
  real(kind=8), intent(out)   :: fa
  real(kind=8), intent(out)   :: fb
  real(kind=8), intent(out)   :: fc
  real(kind=8), external      :: func
  logical,      intent(out)   :: error
  ! Local
  character(len=*), parameter :: rname='MEM_MNBRAK'
  real(kind=8), parameter :: gold=1.618034d0 ! Gold number.
  real(kind=8), parameter :: glimit=100.d0   !
  real(kind=8), parameter :: tiny=1.d-20     ! Used to avoid divisions by zero.
  real(kind=8) :: fac
  integer(kind=4) :: iter1,iter2
  real(kind=8) :: dum
  real(kind=8) :: qq,rr
  real(kind=8) :: uu,ulim,fu
  !
  ! Initializations.
  error = .false.
  iter1 = 0
  iter2 = 0
  fac   = 1.d0
  fa    = func(ax)
  fb    = func(bx)
  !
  ! Switch role of A and B so that we can go downhill in the direction from A to B.
  if (fb.gt.fa) then
     dum = ax
     ax  = bx
     bx  = dum
     dum = fb
     fb  = fa
     fa  = dum
  endif
  cx = bx+gold*(bx-ax) ! First guess for C.
  fc = func(cx)
  !
  ! "do while": keep returning here until we bracket.
  ! Either fb <  fc: found a minimum between b and c,
  !        fb >= fc: continue to go downhill until find a cx for which fb < fc.
  do iter1=1,100
     iter2 = iter2+1
     if (iter2.ge.10) then
        fac   = fac/2.d0
        iter2 = 0
     endif
     !
     if (fb.ge.fc) then ! we have to go downhill:
        ! Compute U by parabolic interpolation from A, B and C.
        ! U is at the minimum of this parabole.
        rr   = (bx-ax)*(fb-fc)
        qq   = (bx-cx)*(fb-fa)
        uu   = bx-((bx-cx)*qq-(bx-ax)*rr)/(2.d0*sign(max(abs(qq-rr),tiny),qq-rr))
        ulim = bx+glimit*fac*(cx-bx)  ! We won't go further than ulim.
        ! Now, test various possibilities.
        ! U is between B and C.
        if ((bx-uu)*(uu-cx).gt.0.d0) then
           fu = func(uu)
           if (fu.lt.fc) then ! we have a minimum between B and C:
              ! Zoom bracketting. Present (B, U, C) => future (A, B, C).
              ax = bx
              fa = fb
              bx = uu
              fb = fu
!!$              return
              exit
           else if (fu.gt.fb) then ! we have a min between B and U:
              ! Zoom bracketting. Present (A, B, U) => future (A, B, C).
              cx = uu
              fc = fu
!!$              return
              exit
           endif
           ! Parabolic fit was no use, use default magnification.
           uu = cx+gold*(cx-bx)
           fu = func(uu)
           ! U between C and its limit.
        else if ((cx-uu)*(uu-ulim).gt.0.d0) then
           fu = func(uu)
           if (fu.lt.fc) then
              bx = cx
              cx = uu
              uu = cx+gold*(cx-bx)
              fb = fc
              fc = fu
              fu = func(uu)
           endif
           ! U beyond its limit value.
        else if ((uu-ulim)*(ulim-cx).ge.0.d0) then
           uu = ulim
           fu = func(uu)
           ! Reject parabolic U, use default magnification.
        else
           uu = cx+gold*(cx-bx)
           fu = func(uu)
        endif
        ! Eliminate oldest points and continue.
        ax = bx
        bx = cx
        cx = uu
        fa = fb
        fb = fc
        fc = fu
     endif
  enddo
end subroutine mem_mnbrak
!
!
!
!
!
function mem_brent(ax,bx,cx,func,tol,xmin)
  use gbl_message
  use classcore_interfaces, except_this=>mem_brent
  !-------------------------------------------------------------------
  ! @ private
  !
  !-------------------------------------------------------------------
  real(kind=8) :: mem_brent  ! Function value on return
  real(kind=8), intent(in) :: ax
  real(kind=8), intent(in) :: bx
  real(kind=8), intent(in) :: cx
  real(kind=8), external   :: func
  real(kind=8), intent(in) :: tol
! real(kind=8), intent(in) :: xmin
  real(kind=8)             :: xmin
  ! Local
  character(len=*), parameter :: rname='BRENT'
  integer(kind=4), parameter :: itmax=100        ! Maximal allowed number of iterations
  real(kind=8), parameter :: cgold=.3819660d0 ! Golden ratio
  real(kind=8), parameter :: zeps=1.d-10      ! a small number which protects against trying to achieve
  ! fractional accuracy for a minimum that happens to be exactly zero
  integer(kind=4) :: iter
  real(kind=8) :: a,b,d,e,etemp,fu,fv,fw,fx,p,q,r,tol1,tol2
  real(kind=8) :: u,v,w,x,xm
  !
  !     A and B sorting (must be in ascending order, though the input abscissas need not)
  a = min(ax,cx)
  b = max(ax,cx)
  !     Initializations.
  v = bx
  w = v
  x = v
  !     E will be the distance moved on the step before last.
  e = 0.d0
  fx = func(x)
  fv = fx
  fw = fx
  !     Main program loop.
  do iter = 1,itmax
     xm = 0.5d0*(a+b)
     tol1 = tol*abs(x)+zeps
     tol2 = 2.d0*tol1
     if (abs(x-xm).le.(tol2-.5d0*(b-a))) goto 3
     if (abs(e).gt.tol1) then
        !         Construct a trial parabolic fit.
        r = (x-w)*(fx-fv)
        q = (x-v)*(fx-fw)
        p = (x-v)*q-(x-w)*r
        q = 2.d0*(q-r)
        if (q.gt.0.d0) p=-p
        q = abs(q)
        etemp = e
        e = d
        !         This condition determines the acceptability of the parabolic fit:
        if (abs(p).ge.abs(.5*q*etemp).or.p.le.q*(a-x).or.p.ge.q*(b-x)) goto 1
        !         Here, it is OK: Take the parabolic step.
        d = p / q
        u = x + d
        !         Skip over the golden section step?
        if((u-a).lt.tol2.or.(b-u).lt.tol2)  d=sign(tol1,xm-x)
        goto 2
     endif
     !       We arrive here for a golden section step, which we take into the larger of the two segments.
1    if (x.ge.xm) then
        e = a-x
     else
        e = b-x
     endif
     !       Take the golden section step.
     d = CGOLD * e
     !       Arrive here with D computed either from parabolic fit, or else from golden section.
2    if (abs(d).ge.tol1) then
        u = x + d
     else
        u = x + sign(tol1,d)
     endif
     !       This is the one function evaluation per iteration.
     !       And we have to decide what to do with our function evaluation.
     !       Housekeeping follows:
     fu = func(u)
     if (fu.le.fx) then
        if (u.ge.x) then
           a = x
        else
           b = x
        endif
        v  = w
        fv = fw
        w  = x
        fw = fx
        x  = u
        fx = fu
     else
        if(u.lt.x) then
           a = u
        else
           b = u
        endif
        if(fu.le.fw .or. w.eq.x) then
           v  = w
           fv = fw
           w  = u
           fw = fu
        else if(fu.le.fv .or. v.eq.x .or. v.eq.w) then
           v  = u
           fv = fu
        endif
     endif
     !       Done with housekeeping. Back for another iteration.
  enddo
  call class_message(seve%e,rname,'mem_brent exceeded maximum iterations')
  !     Arrive here ready to exit with best values.
3 xmin = x ! ?????? PHB
  mem_brent = fx
  return
end function mem_brent
!
!
!
!
!
function mem_dbrent(ax,bx,cx,func,df,tol,xmin)
  use gbl_message
  use classcore_interfaces, except_this=>mem_dbrent
  !-------------------------------------------------------------------
  ! @ private
  ! --> Uses first derivative
  ! From Numerical Recipes
  !
  !-------------------------------------------------------------------
  real(kind=8) :: mem_dbrent  ! Function value on return
  real(kind=8), intent(in) :: ax    !
  real(kind=8), intent(in) :: bx    !
  real(kind=8), intent(in) :: cx    !
  real(kind=8), external   :: func  !
  real(kind=8), external   :: df    !
  real(kind=8), intent(in) :: tol   !
! real(kind=8), intent(in) :: xmin  !
  real(kind=8)             :: xmin  !
  ! Local
  character(len=*), parameter :: rname='DBRENT'
  integer(kind=4), parameter :: itmax=100
  real(kind=8),  parameter :: zeps=1.0d-10
  logical :: ok1,ok2 ! flags for wether proposed steps are acceptable or not.
  real(kind=8)  :: a,b,olde,e,x,u,v,w,fx,fu,fv,fw,dx,dv,dw
  real(kind=8)  :: xm,d,du,d1,d2,tol1,tol2,u1,u2
  integer(kind=4) :: iter
  !
  !
  a  = min(ax,cx)
  b  = max(ax,cx)
  v  = bx
  w  = v
  x  = v
  e  = 0.d0
  fx = func(x)
  fv = fx
  fw = fx

  dx = df(x)
  dv = dx
  dw = dx

  do iter = 1,itmax
     xm = 0.5 * (a + b)
     tol1 = tol * abs(x) + zeps
     tol2 = 2 * tol1
     if (abs(x - xm).le.(tol2 - .5 * (b-a))) goto 3
     if (abs(e).gt.tol1) then
        d1 = 2. * (b - a)
        d2 = d1
        ! Secant method.
        if (dw.ne.dx) d1 = (w - x) * dx / (dx - dw)
        ! Secant method with the other stored point.
        if (dv.ne.dx) d2 = (v - x) * dx / (dx - dv)
        ! Which of these two estimates of D shall we take?
        ! We will insist that they be within the bracket, and on the side
        ! pointed to by the derivative at X:
        u1  = x + d1
        u2  = x + d2
        ok1 = (((a - u1) * (u1 - b)).gt.0).and.((dx * d1).le.0)
        ok2 = (((a - u2) * (u2 - b)).gt.0).and.((dx * d2).le.0)
        ! Movement on the step before last.
        olde = e
        e    = d
        ! Take only an acceptable D: if both are acceptable, then take the smallest one.
        if (.not.(ok1.or.ok2)) then
           goto 1
        else if (ok1.and.ok2) then
           if (abs(d1).lt.abs(d2)) then
              d = d1
           else
              d = d2
           endif
        else if (ok1) then
           d = d1
        else
           d = d2
        endif
        if (abs(d).gt.abs(0.5 * olde))  goto 1
        u = x + d
        if (((u - a).lt.tol2) .or. ((b - u).lt.tol2))  d = sign(tol1,xm - x)
        goto 2
     endif
     ! Decide which segment by the sign of the derivative.
1    if (dx.ge.0) then
        e = a - x
     else
        e = b - x
     endif
     ! Bissect, not golden section.
     d = 0.5 * e
2    if (abs(d).ge.tol1) then
        u  = x + d
        fu = func(u)
     else
        u = x + sign(tol1,d)
        fu = func(u)
        ! If the minimum step in the downhill direction takes us uphill, then we are done.
        if (fu.gt.fx)  goto 3
     endif
     ! Now, all the housekeeping.
     du = df(u)
     if (fu.le.fx) then
        if (u.ge.x) then
           a = x
        else
           b = x
        endif
        v  = w
        fv = fw
        dv = dw
        w  = x
        fw = fx
        dw = dx
        x  = u
        fx = fu
        dx = du
     else
        if (u.lt.x) then
           a = u
        else
           b = u
        endif
        if ((fu.le.fw) .or. (w.eq.x)) then
           v  = w
           fv = fw
           dv = dw
           w  = u
           fw = fu
           dw = du
        else if ((fu.le.fv).or.(v.eq.x).or.(v.eq.w)) then
           v  = u
           fv = fu
           dv = du
        endif
     endif
  enddo
  call class_message(seve%e,rname,'DBRENT exceeded maximum iterations.')
3 xmin = x  ! ?????? PHB
  mem_dbrent = fx
end function mem_dbrent
!
!
!
!
!
function mem_f1dim(xx)
  use f1_commons
  use classcore_interfaces, except_this=>mem_f1dim
  !-------------------------------------------------------------------
  ! @ private
  ! Make the N-dimensional function effectively a 1-D function along a
  ! given line in N-space.
  !-------------------------------------------------------------------
  real(kind=8) :: mem_f1dim  ! Function value on return
  real(kind=8), intent(in) :: xx
  ! Local
  real(kind=8), dimension(mem_ncom) :: xt ! ???????? ph changed this
  integer(kind=4) :: j
  !
  do j=1,mem_ncom
     xt(j) = mem_pcom(j)+xx*mem_xicom(j)
  enddo
  mem_f1dim = chisquare(xt,mem_ncom)
end function mem_f1dim
!
!
!
!
!
function mem_df1dim(xx)
  use f1_commons
  use classcore_interfaces, except_this=>mem_df1dim
  !-------------------------------------------------------------------
  ! @ private
  ! Make the N-dimensional function effectively a 1-D function along a
  ! given line in N-space.
  !-------------------------------------------------------------------
  real(kind=8) :: mem_df1dim  ! Function value on return
  real(kind=8), intent(in) :: xx
  ! Local
  integer(kind=4) :: j
  real(kind=8), dimension(mem_ncom) :: xt,df      ! ???????? ph changed this
  !
  do j=1,mem_ncom
     xt(j) = mem_pcom(j)+xx*mem_xicom(j)
  enddo
  call delta_chi(xt,df,mem_ncom)
  mem_df1dim = 0.d0
  do j=1,mem_ncom
     mem_df1dim = mem_df1dim+df(j)*mem_xicom(j)
  enddo
end function mem_df1dim
!
!
!
!
!
! Parameter variables.
!======================
!
! vect      IO : A vector in which are concatenated the SSB spectrum
!                temperatures and the signal and image gains of the DSB spectra.
! vect_size I- : Number of elements in vector vect.
!
!
!
! Read from common block:
!-------------------------
! dsb_counter   I- : Number of DSB scans.
! ssb_size      I- : Number of channels of our SSB spectrum lssb.
! dsb_size      I- : Number of channels in our DSB spectra.
! ddsb_spectrum I- : DSB spectrum measured from the sky (concatenation of
!                    the dsb_counter DSB scans).
! dsb_weight    I- : Kind of quality quantifier for DSB scans.
!                    dsb_weight = IntegrationTime / SystemTemperature.
!                    The higher dsb_weight, the lower the noise in the scan.
! one_out_of_f  I- : Related to standing waves modulation. This factor is used
!                    to bring the variable we want to fit into a range close to
!                    1. Otherwise, the variable has very high values which
!                    unbalances the algorithm. Instead of fitting F, you fit
!                    f, and you know that F = one_out_of_f * f.
!
!
! As its name does not say, chisquare() does not calculate the X2 (Chi square)
! of the spectrum given in the parameter vect. It calculates the value we want
! to minimize as a criterium for a good deconvolution. For us, a good
! deconvolution must have a small X2 for sure, but should have an entropy
! high enough (the higher the entropy, the less structure in the spectrum,
! it avoids us to fit the noise as if it was important). The balance between
! X2 and entropy weights in chisquare() is set by the lambda1 and lambda2
! values : chisquare = X2 - lambda1 * entropy_ssb - lambda2 * entropy_gain.
! If lambda1 = lambda2 = 0 then chisquare = X2
! With a high lambda1, chisquare will decrease faster with an entropy_ssb
! variation than with a X2 variation, and the deconvolution algorithm will
! naturally converge in that direction, a direction in which spectra have a
! high entropy.
!
! This function calculates four things :
!   1 : X2 of the SSB spectrum given in parameter (through vect) ;
!   2 : entropy of the SSB spectrum ;
!   3 : entropy of the gain vector ;
!   4 : the sum of 1, 2 and 3, weighted by lambda1 and lambda2.
!
! The entropy calculations does not require a lot of information. You just
! have to give one vector, and the entropy function gives you its entropy (the
! higher the entropy, the flatter the spectrum).
!
! X2 calculation is a bit more subtle: it requires two vectors. Indeed, a X2
! is a measure representing the amount of differences between two vectors. One
! of these vectors could be the SSB spectrum given to deconvolve() through vect.
! But where can we find another SSB spectrum to which the first one could be
! compared ? Ideally, that second SSB spectrum is the spectrum of the signal
! we get from the sky, but if we had it, deconvolution would be useless! We
! don't have this ideal SSB spectrum. But we have the DSB spectrum measured
! from the sky. This DSB spectrum results from the mixing of the sky signal
! and a local oscilator signal. The Lower side band (image band) and the
! upper side band (signal band) of the sky are convolved to give the DSB
! spectrum. Convolving is an easy operation. So we won't calculate the X2
! between two SSB spectra, but between two DSB spectra : the one measured
! from the sky, and the other convolved here from the SSB given in vect.

function chisquare(vect,vect_size)
  use gildas_def
  use classcore_interfaces, except_this=>chisquare
  use deconv_dsb_commons
  !-------------------------------------------------------------------
  ! @ private
  ! Calculates the value we want to minimize as a criterium for
  ! a good deconvolution
  ! vect: ssb(ssb_size)+gain(2*dsb_counter)
  !-------------------------------------------------------------------
  real(kind=8) :: chisquare  ! Function value on return
  integer(kind=4), intent(in)    :: vect_size        ! The logical size of vect
  real(kind=8),    intent(inout) :: vect(vect_size)  ! The vector you want to compute the chisquare
  ! Local
  integer(kind=4)                                  :: i,j,maxthrow,i1,i2,s1,s2
  logical                                          :: signal_in,image_in
  integer(kind=4)                                  :: index_weight              ! Index in weight vector.
  integer(kind=4)                                  :: index_signal,index_image  ! Index for lssb.
  integer(kind=4)                                  :: signal_gain,image_gain    ! Indices for lgain.
  real(kind=8), dimension(ssb_size)                :: lssb                      ! Local SSB spectrum vector.
  real(kind=8), dimension(ssb_size)                :: ssb_int                   ! Contains the product of lssb by lgain.
  real(kind=8), dimension(ssb_size)                :: ssb_interm                ! Intermediate vector - TEST
  real(kind=8)                                     :: entrop_ssb                ! Entropy of lssb.
  real(kind=8), dimension(2*o_gain*dsb_counter)    :: lgain                     ! Image and signal gains of the scans.
  real(kind=8)                                     :: entrop_gain               ! Entropy of lgain.
  real(kind=8), dimension(dsb_counter,n_sw_bm_max) :: lAsw_bm                   ! Amplitude.
  real(kind=8), dimension(dsb_counter,n_sw_bm_max) :: lpsw_bm                   ! Pulsation (2 * pi * freq).
  real(kind=8), dimension(dsb_counter,n_sw_bm_max) :: lphsw_bm                  ! Phase.
  real(kind=8), dimension(dsb_counter)             :: sw_int,mod_int
  real(kind=8)                                     :: entrop_sw
  real(kind=8), dimension(dsb_size)                :: dsb_int                   ! Contains the mixed lssb leading to a DSB.
  real(kind=8)                                     :: x_signal,x_image
  real(kind=8)                                     :: val_gain_signal,val_gain_image !value of the gains
  integer(kind=4)                                  :: l,ind_gain_sig,ind_gain_ima
  !
  ! Initialization
  chisquare = 0.d0
  !
  ! Extract ssb's spectrum, gain and sw bm from vect.
  call vect_expand(vect,lssb,lgain,lasw_bm,lpsw_bm,lphsw_bm,vect_size)
  !
  ! PART 1: Chi-square calculation.
  ! Start the loop on all the DSB channels.
  ! Main actions are :
  ! - convolution of SSB into a DSB;
  !   - modulation by before-mixing standing waves;
  !   - gain multiplication;
  !   - mixing;
  ! - X^2 (chi-square) calculation.
  do i=1,ssb_size
     ssb_interm(i) = lssb(i)
  enddo
  !
  ! Convolution of SSB into a DSB.
  do i=1,dsb_size
     ! Find SSB channels corresponding to the DSB channel i.
     index_signal = (dsb_signal(i)-ssb_first)/ssb_width+1
     index_image  = (dsb_image(i)-ssb_first)/ssb_width+1
     signal_gain  = dsb_pointer(i)                        ! Signal gain index for vector lgain.
     image_gain   = signal_gain + dsb_counter             ! Image gain index
     index_weight = dsb_pointer(i)                        ! Observation number associated to this channel.
     ssb_int(index_signal) = lssb(index_signal)
     ssb_int(index_image ) = lssb(index_image )
     !
     ! Determine the position of the channel in the IF. The value is between -0.5 and 0.5
     x_signal = dble( (dsb_signal(i) - dsb_Rrestf(dsb_pointer(i)))/ssb_width)
     x_signal = dble((x_signal + dsb_Rrchan(dsb_pointer(i)) - dsb_Cnchan(dsb_pointer(i))/2.) / dsb_Cnchan(dsb_pointer(i)) )
     x_image = dble( (dsb_image(i) - dsb_Rimage(dsb_pointer(i)))/ssb_width)
     x_image = dble((-x_image + dsb_Rrchan(dsb_pointer(i)) - dsb_Cnchan(dsb_pointer(i))/2.) / dsb_Cnchan(dsb_pointer(i)) )
     !
     ! 1st step : Modulation by before-mixing standing waves.
     ! Formula is taken from "HIFI Standing Waves and their Impact on
     ! Sideband Deconvolution, A First Report" by Steve Lord.
!!! Careful !!!!!
!!! is there not a bug here when n_sw_bm gt 1 ?????
     do j=1,n_sw_bm ! Loop over all before-mixing SW.
        ssb_int(index_signal) = ssb_int(index_signal) * &
             (1.d0+lasw_bm(index_weight,j)*             &
             sin(ssb_freq(index_signal)*one_out_of_f*lpsw_bm(index_weight,j)+lphsw_bm(index_weight,j)))
        ssb_int(index_image ) = ssb_int(index_image ) * &
             (1.d0+lasw_bm(index_weight,j)*             &
             sin(ssb_freq(index_image) *one_out_of_f*lpsw_bm(index_weight,j)+lphsw_bm(index_weight,j)))
     enddo
     ! 2nd step : multiply lssb by the gain.
     if (freq_switch) then
        maxthrow  = maxval(abs(chan_throw(index_weight,:)))
        signal_in = (index_signal-maxthrow).ge.1.and.(index_signal+maxthrow).le.ssb_size
        image_in  = (index_image-maxthrow).ge.1.and.(index_image+maxthrow).le.ssb_size
        if (signal_in.and.image_in) then
!!$        if ((index_signal-chan_throw(index_weight,1)).ge.1               &
!!$             .and.(index_signal-chan_throw(index_weight,2)).ge.1         &
!!$             .and.(index_signal-chan_throw(index_weight,1)).le.ssb_size  &
!!$             .and.(index_signal-chan_throw(index_weight,2)).le.ssb_size  &
!!$             .and.(index_image-chan_throw(index_weight,1)).ge.1           &
!!$             .and.(index_image-chan_throw(index_weight,2)).ge.1          &
!!$             .and.(index_image-chan_throw(index_weight,1)).le.ssb_size   &
!!$             .and.(index_image-chan_throw(index_weight,2)).le.ssb_size) then
!!$           ssb_int(index_signal) = (throw_poids(index_weight,1)*ssb_interm(index_signal-chan_throw(index_weight,1)) &
!!$                + throw_poids(index_weight,2)*ssb_interm(index_signal-chan_throw(index_weight,2)))                  &
!!$                * lgain(signal_gain)
!!$           ssb_int(index_image ) = (throw_poids(index_weight,1)*ssb_interm(index_image-chan_throw(index_weight,1)) &
!!$                + throw_poids(index_weight,2)*ssb_interm(index_image-chan_throw(index_weight,2)))               &
!!$                * lgain(image_gain)
           s1 = index_signal-chan_throw(index_weight,1)
           s2 = index_signal-chan_throw(index_weight,2)
           i1 = index_image-chan_throw(index_weight,1)
           i2 = index_image-chan_throw(index_weight,2)
           ssb_int(index_signal) = (throw_poids(index_weight,1)*ssb_interm(s1) &
                + throw_poids(index_weight,2)*ssb_interm(s2))* lgain(signal_gain)
           ssb_int(index_image ) = (throw_poids(index_weight,1)*ssb_interm(i1) &
                + throw_poids(index_weight,2)*ssb_interm(i2))               &
                * lgain(image_gain)
        endif
     else
        if (variable_gain) then
           val_gain_signal= 0.d0
           val_gain_image = 0.d0
           do l=1,o_gain
              val_gain_signal = val_gain_signal+lgain(signal_gain+(l-1)*2*dsb_counter)*(x_signal)**(l-1)
              val_gain_image  = val_gain_image +lgain( image_gain+(l-1)*2*dsb_counter)*(x_image )**(l-1)
           enddo
        else
           ind_gain_sig  = 2*dsb_counter*int(o_gain*(x_signal+0.5D0-1.d-4))+signal_gain
           ind_gain_ima = ind_gain_sig + dsb_counter
           val_gain_signal = lgain(ind_gain_sig)
           val_gain_image =  lgain(ind_gain_ima)
        endif
        ssb_int(index_signal) = ssb_int(index_signal)*val_gain_signal
        ssb_int(index_image ) = ssb_int(index_image )*val_gain_image
     endif
     ! 3rd step : do the mixing.
     dsb_int(i) = ssb_int(index_signal)+ssb_int(index_image)
     ! Post-mixing standing wave will have to go here.
     !
     ! Calculate chisquare contribution:
     ! chi^2= 1/v Sum_{i=1,v} [ (yi0 - yi)^2 / si^2]
     ! v   : Number of channels in y and y* (dsb_size).
     ! y0  : DSB spectrum measured from the sky (ddsb_spectrum).
     ! y   : DSB spectrum convolved from lssb (dsb_int).
     ! si^2: Variance. Channels can vary with time, it is a kind of noise
     !       measurement.
     chisquare = chisquare + &
          (ddsb_spectrum(i)-dsb_int(i))**2/(dsb_weight(index_weight)*abs(dsb_size-ssb_size-2*dsb_counter))
  enddo
  !
  ! PART 2: Beginning of the entropy calculation.
  ! lssb entropy.
  if (lambda1.ne.0.) then
     entrop_ssb  = entropythreshold(lssb,norm_ssb_model,ssb_size)
  else
     entrop_ssb = 0.d0
  endif
  ! Gain entropy.
  if ((fit_gains).and.(lambda2.gt.0.d0)) then      !! CC 19.6.2013
     !hogm this should be modified                 !! must look into this, never used it so far CC 20.11.2013
     if (o_gain.lt.1) then
        print*,'entropy with high order gain is not considered yet'
        stop
     endif
     entrop_gain = entropythreshold(lgain,norm_gain_model,2*dsb_counter)
  else
     entrop_gain = 0.d0
  endif
  ! Standing waves before mixing entropy.
  entrop_sw  = 0.d0
  if (lambda3.gt.0.d0) then
     ! Loop over all before-mixing standing waves.
     do i = 1, n_sw_bm
        ! Contribution of Amplitude to the entropy.
        do j = 1, dsb_counter
           sw_int(j)  = lasw_bm(j,i)
           mod_int(j) = norm_asw_bm_model(j,i)
        enddo
        entrop_sw = entrop_sw + entropy(sw_int,mod_int,dsb_counter)
        ! Contribution of pulsation to the entropy.
        do j = 1, dsb_counter
           sw_int(j)  = lpsw_bm(j,i)*one_out_of_f
           mod_int(j) = norm_psw_bm_model(j,i)
        enddo
        entrop_sw = entrop_sw+entropy(sw_int,mod_int,dsb_counter)
        ! Contribution of the phase to the entropy.
        ! None because no model can be provided:
        ! The phase jumps 'randomly' from one scan to another, because each
        ! scan is taken at a different time.
     enddo
  endif
  ! Finally add the different contributions.
  chisquare = chisquare-lambda1*entrop_ssb-lambda2*entrop_gain-lambda3*entrop_sw
  ! Propagation of modifications introduced by entropythreshold().
  call vect_contract(vect,lssb,lgain,lasw_bm,lpsw_bm,lphsw_bm)
end function chisquare
!
!
!
!
!
function entropy(x,M,n)
  use gildas_def
  use classcore_interfaces, except_this=>entropy
  use deconv_dsb_commons
  use gbl_message
  !-------------------------------------------------------------------
  ! @ private
  ! Calculate the entropy of a set of data and model of size n.
  ! The formula is:
  ! entropy = - Sum_{i=1,n} (xi/xtot) * log(xi/xtot/Mi)
  ! where xtot = sum(x). It is therefore assumed that Mi = mi / mtot.
  ! If no model is used then Mi = 1. (See init_mem.f.)
  !
  ! Add a continuum offset to x to avoid a negative argument in the
  ! log. Since the offset is the same during all the deconvolution
  ! process, we still can try to maximize the entropy. The model m
  ! must be shifted up by the same cont_offset. It is taken into
  ! account when M is calculated in init_mem():
  ! Mi = (mi+cont_offset) / sum(mi + cont_offset).
  ! -------------------------------------------------------------------
  real(kind=8) :: entropy  ! Function value on return
  integer(kind=4), intent(in)    :: n    ! The number of elements of x and M
  real(kind=8),    intent(in)    :: M(n) ! A normalized model (M = m / sum(m))
  real(kind=8),    intent(inout) :: x(n) ! The vector we want to compute the entropy
  !
  ! Local variables.
  integer(kind=4) :: i,j
  real(kind=8)  :: xtot       ! sum(x)
  real(kind=8)  :: x_xtot(n)  ! x / xtot
  real(kind=4)  :: f_array    ! Entropy terms. F = -sum(f_array).
  !
  ! Initialization
  xtot    = 0.d0
  entropy = 0.d0
  do i=1,n
     ! x(i) and M(i) must be positive.
     if (x(i)+cont_offset.le.0.d0.or.m(i).le.0.d0) then
        call class_message(seve%e,'ENTROPY','vect or model is 0 or negative.')
        do j=i-10,i+10
           if (j.ge.1.and.j.le.n) then
              print *, '  j, vect, model ', j, x(j), M(j)
           endif
        enddo
        stop
     endif
     xtot = xtot+x(i)+cont_offset
  enddo
  ! Calculate the entropy.
  do i=1,n
     x_xtot(i) = (x(i)+cont_offset)/xtot
     f_array   = x_xtot(i)*log(x_xtot(i)/M(i))
     entropy   = entropy-f_array
  enddo
end function entropy
!
!
!
!
!
function entropythreshold(x,M,n)
  use gildas_def
  use classcore_interfaces, except_this=>entropythreshold
  use deconv_dsb_commons
  use gbl_message
  !-------------------------------------------------------------------
  ! @ private
  ! Calculate the entropy of a set of data and model of size n.
  ! The formula is: entropy = -sum ( (xi/xtot) * log( (xi/xtot) / Mi),
  ! where xtot = sum(x). It is therefore assumed that Mi = mi / mtot.
  ! If no model is used then Mi = 1. (See init_mem.f.)
  ! Same as entropy(), but if a channel of vect is lower than epsilon, it is set
  ! to epsilon.
  !
  ! Add a continuum offset to x to avoid a negative argument in the
  ! log. Since the offset is the same during all the deconvolution
  ! process, we still can try to maximize the entropy. The model m
  ! must be shifted up by the same cont_offset. It is taken into
  ! account when M is calculated in init_mem():
  ! Mi = (mi+cont_offset) / sum(mi+cont_offset).
  !-------------------------------------------------------------------
  real(kind=8) :: entropythreshold  ! Function value on return
  integer(kind=4), intent(in)    :: n ! The number of elements of x and M
  real(kind=8),    intent(in)    :: M(n) ! A normalized model (M = m / sum(m))
  real(kind=8),    intent(inout) :: x(n) ! The vector we want to compute the entropy
  ! Local
  integer(kind=4)              :: i,j
  real(kind=8), parameter    :: epsilon=1.d-10
  real(kind=8)               :: xtot       ! Sum(x)
  real(kind=8)               :: x_xtot(n)  ! x / xtot
  real(kind=4)               :: f_array    ! Entropy terms. F = -sum(f_array).
  !
  !
  ! Initialization
  xtot = 0.d0
  entropythreshold = 0.d0
  !
  do i=1,n
     ! make x(i) greater than 0.
     if (x(i)+cont_offset.lt.epsilon) x(i)=epsilon-cont_offset
     ! model must be positive.
     if (m(i).le.0.) then
        call class_message(seve%f,'entropythreshold','model is 0 or negative.')
        do j=max(1,i-10),min(i+10,n)
           print *, '  j, model ', j, m(j)
        enddo
        stop
     endif
     xtot = xtot+x(i)+cont_offset
  enddo
  ! calculate the entropy.
  do i=1,n
     x_xtot(i) = (x(i)+cont_offset)/xtot
     f_array   = x_xtot(i)*log(x_xtot(i)/m(i))
     entropythreshold = entropythreshold-f_array
  enddo
end function entropythreshold
!
!
!
!
!
subroutine delta_chi(vect,delta_chisquare,vect_size)
  use gildas_def
  use phys_const
  use classcore_interfaces, except_this=>delta_chi
  use deconv_dsb_commons
  !-------------------------------------------------------------------
  ! @ private
  ! vect contains (in this order) :
  ! - lssb    : Single side band spectrum only:                        size = ssb_size.
  ! - lgain   : Contains the signal band gain and the image band gain: size = 2 * dsb_counter.
  ! - lAsw_bm : Amplitude of the standing waves before mixing:         size = (dsb_counter, n_sw_bm).
  ! - lpsw_bm : Pulsation of the standing waves before mixing:         size = (dsb_counter, n_sw_bm).
  ! - lphsw_bm: Phase of the standing waves before mixing:             size = (dsb_counter, n_sw_bm).
  !-------------------------------------------------------------------
  integer(kind=4), intent(in)    :: vect_size        ! size of vect
  real(kind=8),    intent(inout) :: vect(vect_size)  ! The vector you want to compute the chisquare
  real(kind=8),    intent(out)   :: delta_chisquare(vect_size)
  ! Local
  real(kind=8), dimension(ssb_size) :: lssb
  real(kind=8), dimension(2*o_gain*dsb_counter) :: lgain       ! Image and signal gains of the scans.
  real(kind=8)                      :: modula_signal_prod,modula_image_prod
  real(kind=8)                      :: dchi
  real(kind=8), dimension(ssb_size) :: dchi_ssb
  real(kind=8), dimension(n_sw_bm)  :: modula_signal
  real(kind=8), dimension(n_sw_bm)  :: modula_image
  real(kind=8), dimension(dsb_counter,n_sw_bm) :: lasw_bm,lpsw_bm,lphsw_bm  ! amplitude, pulsation (2*pi*freq), phase.
  real(kind=8), dimension(2*o_gain*dsb_counter) :: dchi_gain
  real(kind=8), dimension(dsb_counter,n_sw_bm) :: dchi_asw_bm,dchi_psw_bm,dchi_phsw_bm  ! amplitude, pulsation (2*pi*freq), phase.
  real(kind=8), dimension(ssb_size)      :: dent_ssb
  !hogm should be modified at some stage
  real(kind=8), dimension(2*dsb_counter) :: dent_gain
  real(kind=8), dimension(2*dsb_counter) :: dgain
  real(kind=8), dimension(dsb_counter)   :: dent_sw
  real(kind=8), dimension(dsb_counter)   :: sw_int
  real(kind=8), dimension(dsb_counter)   :: mod_int
  real(kind=8), dimension(dsb_size)      :: dsb_int      ! mixed lssb leading to a dsb and its product by postmixing sw.
  real(kind=8), dimension(ssb_size)      :: ssb_int      ! product of lssb by the sw and the gain.
  real(kind=8), dimension(ssb_size)      :: ssb_interm   ! intermediate vector - test
  real(kind=8)                           :: x_signal     ! coordinate of the channel in the IF
  real(kind=8)                           :: x_image      ! coordinate of the channel in the IF
  real(kind=8)                           :: phase,sin_phase,amp_cos_phase,dchi_sw
  real(kind=8)                           :: val_gain_signal, val_gain_image
  integer(kind=4)                        :: l,ind_gain_sig,ind_gain_ima
  integer(kind=4)                        :: i,j,k
  integer(kind=4)                        :: index_signal,index_image,num_scan
  integer(kind=4)                        :: signal_gain,image_gain
  integer(kind=4)                        :: maxthrow,i1,i2,s1,s2
  logical                                :: signal_in,image_in
  !
  ! Initialize the variables.
  call vect_expand(vect,lssb,lgain,lasw_bm,lpsw_bm,lphsw_bm,vect_size)
  ! constraints phase between -pi and pi.
  do j=1,n_sw_bm
     do i=1,dsb_counter
        do while (lphsw_bm(i,j).gt.pi)
           lphsw_bm(i,j) = lphsw_bm(i,j)-pi*2
        enddo
        do while (lphsw_bm(i,j).lt.-pi)
           lphsw_bm(i,j) = lphsw_bm(i,j)+pi*2
        enddo
     enddo
  enddo
  ! Zero derivative spectrum, gain and standing waves before mixing.
  do i=1,ssb_size
     dchi_ssb(i) = 0.d0
  enddo
  do i=1,2*o_gain*dsb_counter
     dchi_gain(i) = 0.d0
  enddo
  do j=1,n_sw_bm
     do i=1,dsb_counter
        dchi_Asw_bm(i, j)  = 0.d0 ! SW BM amplitude.
        dchi_psw_bm(i, j)  = 0.d0 ! SW BM pulsation.
        dchi_phsw_bm(i, j) = 0.d0 ! SW BM phase.
     enddo
  enddo
  do i=1,ssb_size
     ssb_interm(i) = lssb(i)
  enddo
  ! PART 1: Derivative of chi calculation.
  ! Start the loop on all the channels.
  ! Main calculations are derivative of chi with respect to:
  ! - ssb
  ! - gain
  ! - amplitude, pulsation and phase of SW
  do i=1,dsb_size
     index_signal = (dsb_signal(i)-ssb_first)/ssb_width+1
     index_image  = (dsb_image(i)-ssb_first)/ssb_width+1
     !hogm 23
     !calculate the position of the channel in the IF. The value is between -0.5 and 0.5
     num_scan     = dsb_pointer(i)
     x_signal     = dble((dsb_signal(i)-dsb_rrestf(num_scan))/ssb_width)
     x_signal     = dble((x_signal+dsb_rrchan(num_scan)-dsb_cnchan(num_scan)/2.d0)/dsb_cnchan(num_scan))
     x_image      = dble((dsb_signal(i)-dsb_rimage(num_scan))/ssb_width)
     x_image      = dble((-x_image+dsb_rrchan(num_scan)-dsb_cnchan(num_scan)/2.d0)/dsb_cnchan(num_scan))
     signal_gain  = num_scan
     image_gain   = signal_gain+dsb_counter
     ssb_int(index_signal) = lssb(index_signal)
     ssb_int(index_image ) = lssb(index_image )
     !
     ! FIRST STEP : Convolve lssb by the premixing SW.
     ! Formula is taken from HIFI Standing Waves and their Impact on
     ! Sideband Deconvolution, A First Report by Steve Lord.
     modula_signal_prod = 1.d0
     modula_image_prod  = 1.d0
     do j = 1, n_sw_bm  !loops over all premixing SW
        modula_signal(j)      = 1.d0+lAsw_bm(num_scan,j)*&
             sin(ssb_freq(index_signal)*one_out_of_f*lpsw_bm(num_scan,j)+lphsw_bm(num_scan,j))
        modula_signal_prod    = modula_signal_prod * modula_signal(j)
        ssb_int(index_signal) = ssb_int(index_signal)*modula_signal(j)
        modula_image(j)       = 1.d0+lasw_bm(num_scan,j)*&
             sin(ssb_freq(index_image)*one_out_of_f*lpsw_bm(num_scan,j)+lphsw_bm(num_scan,j))
        modula_image_prod     = modula_image_prod * modula_image(j)
        ssb_int(index_image ) = ssb_int(index_image )*modula_image(j)
     enddo
     !
     ! SECOND STEP : multiply lssb by the gain.
     if (freq_switch) then
        maxthrow  = maxval(abs(chan_throw(num_scan,:)))
        signal_in = (index_signal-maxthrow).ge.1.and.(index_signal+maxthrow).le.ssb_size
        image_in  = (index_image-maxthrow).ge.1.and.(index_image+maxthrow).le.ssb_size
        if (signal_in.and.image_in) then
!!$        if ((index_signal-chan_throw(num_scan,1)).ge.1               &  ! modified to accomodate HIFI throw - CC Jul2011
!!$             .and.(index_signal-chan_throw(num_scan,2)).ge.1         &
!!$             .and.(index_signal-chan_throw(num_scan,1)).le.ssb_size  &
!!$             .and.(index_signal-chan_throw(num_scan,2)).le.ssb_size  &
!!$             .and.(index_image-chan_throw(num_scan,1)).ge.1           &
!!$             .and.(index_image-chan_throw(num_scan,2)).ge.1          &
!!$             .and.(index_image-chan_throw(num_scan,1)).le.ssb_size   &
!!$             .and.(index_image-chan_throw(num_scan,2)).le.ssb_size) then
           ! modified to accomodate HIFI throw - CC Jul2011
           s1 = index_signal-chan_throw(num_scan,1)
           s2 = index_signal-chan_throw(num_scan,2)
           i1 = index_image-chan_throw(num_scan,1)
           i2 = index_image-chan_throw(num_scan,2)
           ssb_int(index_signal) = (throw_poids(num_scan,1)*ssb_interm(s1) &
                + throw_poids(num_scan,2)*ssb_interm(s2))                  &
                * lgain(signal_gain)
           ssb_int(index_image ) = (throw_poids(num_scan,1)*ssb_interm(i1) &
                + throw_poids(num_scan,2)*ssb_interm(i2))                  &
                * lgain(image_gain)
        endif
     else
        if (variable_gain) then
           val_gain_signal= 0.d0
           val_gain_image = 0.d0
           do l=1,o_gain
              val_gain_signal = val_gain_signal+lgain(signal_gain+(l-1)*2*dsb_counter)*(x_signal)**(l-1)
              val_gain_image  = val_gain_image +lgain( image_gain+(l-1)*2*dsb_counter)*(x_image )**(l-1)
           enddo
        else
           ind_gain_sig  = 2*dsb_counter*int(o_gain*(x_signal+0.5D0-1.d-4))+signal_gain
           ind_gain_ima = ind_gain_sig+dsb_counter
           val_gain_signal = lgain(ind_gain_sig)
           val_gain_image  = lgain(ind_gain_ima)
        endif
        ssb_int(index_signal) = ssb_int(index_signal)*val_gain_signal
        ssb_int(index_image ) = ssb_int(index_image )*val_gain_image
     endif
     !
     ! THIRD STEP : do the mixing.
     dsb_int(i) = ssb_int(index_signal) + ssb_int(index_image)
     if ((index_signal.lt.1).or.(index_signal.gt.ssb_size).or.(index_image.lt.1).or.(index_image .gt.ssb_size)) then
        print *,'DELTA_CHI: index out of limits: ', i
        print *,'index_signal, index_image <1 or >ssb_size',index_signal, index_image, ssb_size
        print *, 'ssb_first, ssb_width = ', ssb_first, ssb_width
        print *, 'dsb_sig, dsb_img = ', dsb_signal(i), dsb_image(i)
        ! What to do in this case ???????? PHB
     endif
     ! Calculate dchi.
     dchi = -2.d0*(ddsb_spectrum(i)-dsb_int(i))/(dsb_weight(num_scan)*abs(dsb_size-ssb_size-2*dsb_counter*o_gain))
     ! Derivative of chi with respect to SSB.
     if (no_channels) then
        print *,'NO_CHANNELS'
        dchi_ssb(index_signal) = 0.d0
        dchi_ssb(index_image ) = 0.d0
     else
        if (freq_switch) then
           ! Test was already done above in FREQ_SWITCH case
           ! Shifted SIGNAL and IMAGE channels (s1, s2, i1, i2) are also kept from above
           if (signal_in.and.image_in) then
!!$           if ((index_signal-chan_throw(num_scan,1)).ge.1               &  ! modified according to ssb_int above - CC Jul2011
!!$             .and.(index_signal-chan_throw(num_scan,2)).ge.1         &
!!$             .and.(index_signal-chan_throw(num_scan,1)).le.ssb_size  &
!!$             .and.(index_signal-chan_throw(num_scan,2)).le.ssb_size  &
!!$             .and.(index_image-chan_throw(num_scan,1)).ge.1           &
!!$             .and.(index_image-chan_throw(num_scan,2)).ge.1          &
!!$             .and.(index_image-chan_throw(num_scan,1)).le.ssb_size   &
!!$             .and.(index_image-chan_throw(num_scan,2)).le.ssb_size) then
              dchi_ssb(s1) = dchi_ssb(s1)+throw_poids(num_scan,1)*modula_signal_prod*lgain(signal_gain)*dchi
              dchi_ssb(s2) = dchi_ssb(s2)+throw_poids(num_scan,2)*modula_signal_prod*lgain(signal_gain)*dchi
              dchi_ssb(i1) = dchi_ssb(i1)+throw_poids(num_scan,1)*modula_signal_prod*lgain(image_gain)*dchi
              dchi_ssb(i2) = dchi_ssb(i2)+throw_poids(num_scan,2)*modula_signal_prod*lgain(image_gain)*dchi
!!$                 dchi_ssb(index_signal-chan_throw(num_scan,1)) =       &
!!$                      dchi_ssb(index_signal-chan_throw(num_scan,1)) +  &
!!$                      throw_poids(num_scan,1)*modula_signal_prod * lgain(signal_gain) * dchi
!!$                 dchi_ssb(index_signal-chan_throw(num_scan,2)) =       &
!!$                      dchi_ssb(index_signal-chan_throw(num_scan,2)) +  &
!!$                      throw_poids(num_scan,2)*modula_signal_prod * lgain(signal_gain) * dchi
!!$                 dchi_ssb(index_image-chan_throw(num_scan,1)) =        &
!!$                      dchi_ssb(index_image-chan_throw(num_scan,1)) +   &
!!$                      throw_poids(num_scan,1)*modula_signal_prod * lgain(image_gain) * dchi
!!$                 dchi_ssb(index_image-chan_throw(num_scan,2)) =        &
!!$                      dchi_ssb(index_image-chan_throw(num_scan,2)) +   &
!!$                      throw_poids(num_scan,2)*modula_signal_prod * lgain(image_gain) * dchi
           endif
        else
           if (variable_gain) then
              val_gain_signal= 0.d0
              val_gain_image = 0.d0
              do l=1, o_gain
                 val_gain_signal = val_gain_signal+lgain(signal_gain+(l-1)*2*dsb_counter)*(x_signal)**(l-1)
                 val_gain_image  = val_gain_image +lgain( image_gain+(l-1)*2*dsb_counter)*(x_image )**(l-1)
              enddo
           else
              ind_gain_sig    = 2*dsb_counter*int(o_gain*(x_signal+0.5D0-1.d-4))+signal_gain
              ind_gain_ima    = ind_gain_sig + dsb_counter
              val_gain_signal = lgain(ind_gain_sig)
              val_gain_image  = lgain(ind_gain_ima)
           endif
           val_gain_signal = val_gain_signal*modula_signal_prod*dchi
           val_gain_image  = val_gain_image*modula_image_prod*dchi
           dchi_ssb(index_signal) = dchi_ssb(index_signal)+val_gain_signal
           dchi_ssb(index_image ) = dchi_ssb(index_image )+val_gain_image
        endif
     endif
     ! Derivative of chi with respect to gain parameters.
     if (.not.fit_gains) then     !! CC 19.6.2013
        !hogm it assumed that if no_gain then o_gain = 1
        dchi_gain(signal_gain) = 0.d0
        dchi_gain(image_gain ) = 0.d0
     else
        if (freq_switch) then
           if (signal_in.and.image_in) then
!!$           if ((index_signal-chan_throw(num_scan,1)).ge.1               &  ! modified according to ssb_int above - CC Jul2011
!!$             .and.(index_signal-chan_throw(num_scan,2)).ge.1         &
!!$             .and.(index_signal-chan_throw(num_scan,1)).le.ssb_size  &
!!$             .and.(index_signal-chan_throw(num_scan,2)).le.ssb_size  &
!!$             .and.(index_image-chan_throw(num_scan,1)).ge.1           &
!!$             .and.(index_image-chan_throw(num_scan,2)).ge.1          &
!!$             .and.(index_image-chan_throw(num_scan,1)).le.ssb_size   &
!!$             .and.(index_image-chan_throw(num_scan,2)).le.ssb_size) then
!!$              dchi_gain(signal_gain) = dchi_gain(signal_gain) +      &
!!$                   (throw_poids(num_scan,1)*ssb_interm(index_signal-chan_throw(num_scan,1)) +  &
!!$                   throw_poids(num_scan,2) *ssb_interm(index_signal-chan_throw(num_scan,2)))*   &
!!$                   modula_signal_prod * dchi
!!$              dchi_gain(image_gain ) = dchi_gain(image_gain ) +      &
!!$                   (throw_poids(num_scan,1)*ssb_interm(index_image-chan_throw(num_scan,1)) +    &
!!$                   throw_poids(num_scan,2)*ssb_interm(index_image-chan_throw(num_scan,2)))*  &
!!$                   modula_image_prod * dchi
              dchi_gain(signal_gain) = dchi_gain(signal_gain) + &
                   (throw_poids(num_scan,1)*ssb_interm(s1) +  &
                   throw_poids(num_scan,2) *ssb_interm(s2))*   &
                   modula_signal_prod * dchi
              dchi_gain(image_gain ) = dchi_gain(image_gain ) +      &
                   (throw_poids(num_scan,1)*ssb_interm(i1) +    &
                   throw_poids(num_scan,2)*ssb_interm(i2))*  &
                   modula_image_prod * dchi
           endif
        else
           if( variable_gain ) then
              do l=  1,o_gain
                 dchi_gain(signal_gain+(l-1)*2*dsb_counter) = dchi_gain(signal_gain+(l-1)*2*dsb_counter) +&
                      lssb(index_signal)*((x_signal)**(l-1))*modula_signal_prod*dchi
                 dchi_gain(image_gain +(l-1)*2*dsb_counter) = dchi_gain(image_gain +(l-1)*2*dsb_counter) +&
                      lssb(index_image )*((x_image )**(l-1))*modula_image_prod *dchi
              enddo
           else
              ind_gain_sig  = 2*dsb_counter*int(o_gain*(x_signal+0.5D0-1.d-4))+signal_gain
              ind_gain_ima = ind_gain_sig + dsb_counter
              dchi_gain(ind_gain_sig) = dchi_gain(ind_gain_sig) + lssb(index_signal)*modula_signal_prod*dchi
              dchi_gain(ind_gain_ima) = dchi_gain(ind_gain_ima) + lssb(index_image )*modula_image_prod *dchi
           endif
        endif
     endif
     !
     ! Derivative of chi with respect to SW parameters.
     ! The formulae should be coherent with what has been used in chisquare().
     !
     ! hogm take care not compatible with o_gain larger than 1 since
     ! it is rather unclear whether SW should be corrected here not
     ! clear that this should be done
     !
     do j=1,n_sw_bm  !loops over all premixing SW
        ! Contribution of the signal (upper side) band.
        ! Define some intermediate variables to spare CPU.
        phase = ssb_freq(index_signal)*one_out_of_f*lpsw_bm(num_scan,j)+lphsw_bm(num_scan,j)
        sin_phase = sin(phase)
        amp_cos_phase = lAsw_bm(num_scan, j) * cos(phase)
        dchi_sw = dchi * lssb(index_signal) * lgain(signal_gain)
        do k=1,n_sw_bm
           if (k.ne.j) then
              dchi_sw = dchi_sw*modula_signal(k)
           endif
        enddo
        ! derivation : amplitude.
        if (no_bmswa) then
           dchi_asw_bm(num_scan,j) = 0.d0
        else
           dchi_asw_bm(num_scan,j) = dchi_asw_bm(num_scan,j)+sin_phase*dchi_sw
        endif
        ! Derivation : Pulsation.
        if (no_bmswP) then
           dchi_Psw_bm(num_scan,j) = 0.d0
        else
           dchi_Psw_bm(num_scan,j) = dchi_Psw_bm(num_scan, j) +   &
                ssb_freq(index_signal)*one_out_of_f*amp_cos_phase*dchi_sw
        endif
        ! Derivation : Phase.
        if (no_bmswPh) then
           dchi_Phsw_bm(num_scan,j) = 0.d0
        else
           dchi_Phsw_bm(num_scan,j) = dchi_Phsw_bm(num_scan,j)+amp_cos_phase*dchi_sw
        endif
        ! Contribution of the image (lower side) band.
        ! Define some intermediate variables to spare CPU.
        phase         = ssb_freq(index_image)*one_out_of_f*lpsw_bm(num_scan,j)+lphsw_bm(num_scan,j)
        sin_phase     = sin(phase)
        amp_cos_phase = lAsw_bm(num_scan,j)*cos(phase)
        dchi_sw       = dchi*lssb(index_image)*lgain(image_gain)
        do k = 1, n_sw_bm
           if (k.ne.j) then
              dchi_sw = dchi_sw * modula_image(k)
           endif
        enddo
        ! Derivation : Amplitude.
        if (no_bmswA) then
           dchi_Asw_bm(num_scan,j) = 0.d0
        else
           dchi_Asw_bm(num_scan,j) = dchi_Asw_bm(num_scan, j)+sin_phase*dchi_sw
        endif
        ! Derivation : Pulsation.
        if (no_bmswP) then
           dchi_Psw_bm(num_scan, j) = 0.d0
        else
           dchi_psw_bm(num_scan, j) = dchi_psw_bm(num_scan, j)+     &
                ssb_freq(index_image )*one_out_of_f*amp_cos_phase*dchi_sw
        endif
        ! Derivation : Phase.
        if (no_bmswPh) then
           dchi_Phsw_bm(num_scan, j) = 0.d0
        else
           dchi_phsw_bm(num_scan,j) = dchi_phsw_bm(num_scan,j)+amp_cos_phase*dchi_sw
        endif
     enddo ! do j = 1, n_sw_bm  !loops over all premixing SW
  enddo ! do i = 1, dsb_size
  ! PART 2: Derivative of the entropy.
  ! SSB.
  if (lambda1.ne.0.d0) then
     call derentrop(lssb,norm_ssb_model,ssb_size,dent_ssb)
     do i=1,ssb_size
        dchi_ssb(i) = dchi_ssb(i)-lambda1*dent_ssb(i)
     enddo
  endif
  ! Gain.
  if ((fit_gains).and.(lambda2.gt.0.d0)) then     !! CC 19.6.2013
     !hogm this should be modified to take into account high order gain fitting with entropy
     print*,'calculate the entropy for the gain, not compatible with high order gain fitting'
     dgain(:) = gain(:) ! *** PATCH SB 11-jan-2012
     call derentrop(dgain,norm_gain_model,2*dsb_counter,dent_gain)
     do i=1,2*dsb_counter
        dchi_ssb(i) = dchi_ssb(i)-lambda2*dent_gain(i)
     enddo
  endif
  ! Standing waves before mixing.
  if (lambda3.gt.0.d0) then
     do i = 1, n_sw_bm
        ! Amplitude.
        do j = 1, dsb_counter
           sw_int(j) = lAsw_bm(j,i)
           mod_int(j) = norm_Asw_bm_model(j,i)
        enddo
        call derentrop(sw_int,mod_int,dsb_counter,dent_sw)
        do j = 1,dsb_counter
           dchi_Asw_bm(j,i) = dchi_Asw_bm(j,i)-lambda3*dent_sw(j)
        enddo
        ! Pulsation.
        do j = 1,dsb_counter
           sw_int(j) = lpsw_bm(j,i)
           mod_int(j) = norm_psw_bm_model(j,i)
        enddo
        call derentrop(sw_int,mod_int,dsb_counter,dent_sw)
        do j = 1,dsb_counter
           dchi_psw_bm(j,i) = dchi_psw_bm(j,i)-lambda3*dent_sw(j)
        enddo
        ! Phase.
        ! Entropy is not defined for phase,because no model can be provided.
        do j = 1,dsb_counter
           dchi_phsw_bm(j,i) = dchi_phsw_bm(j,i)-lambda3*dent_sw(j)
        enddo
     enddo
  endif ! Standing waves.
  ! Finally put everything in delta_chisquare.
  call vect_contract(delta_chisquare,dchi_ssb,dchi_gain,dchi_Asw_bm,dchi_psw_bm,dchi_phsw_bm)
  call vect_contract(vect,lssb,lgain,lAsw_bm,lpsw_bm,lphsw_bm)
end subroutine delta_chi
!
!
!
!
!
subroutine derentrop(px,pm,pn,pds)
  use classcore_interfaces, except_this=>derentrop
  use deconv_dsb_commons
  !-------------------------------------------------------------------
  ! @ private
  ! Calculate the entropy derivative of a set of data x and model m of size n.
  ! The formula is: entropy = S = sum ((xi/X) * log((xi/X) / Mi)).
  ! Where X = sum(xi). It is therefore assumed that Mi = mi / M. M = sum(mi).
  ! If no model is used then Mi = 1. (see init_mem()).
  ! The derivative of the entropy is:
  ! dS_dvect(i) = 1. / X * (log(xi / X / Mi) - S)
  !
  ! ??????????????? PHB: is it definitive ?
  ! Presently (10/02/05), wherever the model is used, its values are
  ! divided by sum(ssb_model). In order to spare CPU, we (PH and BD)
  ! have decided to divide it once for all. The sum must be kept in
  ! memory because makemodel() should be able to restore ssb_model's
  ! original value. The division is made in put_model() or init_mem()
  ! and need not to be done once again just before calling derentrop().
  !-------------------------------------------------------------------
  integer(kind=4), intent(in)    :: pn      ! logical size of px and pm.
  real(kind=8),    intent(inout) :: px(pn)  ! x
  real(kind=8),    intent(in)    :: pm(pn)  ! m
  real(kind=8),    intent(out)   :: pds(pn)
  ! Local
  integer(kind=4) :: i,j
  real(kind=8), parameter :: epsilon=1.d-10
  real(kind=8), dimension(pn) :: log_xi_x_mi
  real(kind=8)  :: sumx,xi_x,xs ! Sum of px, px(i)/x, entropy.
  !
  ! Sum of px.
  sumx = 0.d0
  do i=1,pn
     if (px(i).le.epsilon) px(i)=epsilon
     if ((px(i).le.0.d0).or.(pm(i).le.0.d0)) then
        print*, 'Error DERENTROP: model is 0 or negative.'
        do j = i - 15, i + 15
           if (j.ge.1 .and. j.le.pn) then
              print*, 'i, data, model ', i, px(i), pm(i)
           endif
        enddo
        STOP
     endif
     sumx = sumx+px(i)
  enddo
  ! Entropy.
  xs = 0.d0
  do i=1,pn
     xi_x           = px(i)/sumx
     log_xi_x_mi(i) = log(xi_x/pm(i))
     xs             = xs+xi_x*log_xi_x_mi(i)
  enddo
  ! Derivative.
  do i=1,pn
     pds(i) = (log_xi_x_mi(i)-xs)/sumx
  enddo
end subroutine derentrop
