; $Id: satoma.pro,v 1.2 2002/01/14 20:59:26 amunter Exp $
pro getspars_event,ev
common satopars,vgw,xf,zf,txt1,txt2
widget_control,ev.id,get_value=value,get_uvalue=uvalue
type=tag_names(ev,/structure)
if (type eq 'WIDGET_BUTTON') then begin
  widget_control,txt1,get_value=vgw
  vgw=vgw(0)
  if (txt2 ne 0) then begin
    widget_control,txt2,get_value=tilt
    zf=sin(!pi*tilt(0)/180)
    xf=cos(!pi*tilt(0)/180)
    endif
  widget_control,ev.top,/destroy
  endif else if (uvalue eq 'tilt') then begin
    zf=sin(!pi*value(0)/180)
    xf=cos(!pi*value(0)/180)
    endif else begin
      vgw=value(0)
    endelse
end

pro getspars
common fitp,ngau,nlor,a,vary,pnames,gw,ufunct,nufun
common satopars,vgw,xf,zf,txt1,txt2
common data,xax,yax,fit,symboln,index,d,xmin,xmax,ymin,ymax,pcomm
if (gw eq 0) then vgw=0 else vgw=0.14/1.18
txt2=0
satbase=widget_base(title='Fit details',/column)
lab1=widget_label(satbase,value='Vertical resolution :')
txt1=widget_text(satbase,/editable,value=strcompress(vgw),uvalue='vgw')
if (tasid('L',d) eq -1) then begin
  lab2=widget_label(satbase,value='Tilt angle :')
  txt2=widget_text(satbase,/editable,value='6.8',uvalue='tilt')
  endif else begin
    xf=1.0
    zf=d.data(tasid('L',d),0)/d.data(tasid('H',d),0)
    endelse
button=widget_button(satbase,value='OK')
widget_control,satbase,/realize
xmanager,'getspars',satbase,/modal
end

pro satoma,x,par,y,pdpar,i,reset=reset,destroy=destroy
; user function for fitting with TASXP this is a modified lorentzian
; squared, appropriate for itinerant incommensurate antiferromagents
common fitp,ngau,nlor,a,vary,pnames,gw,ufunct,nufun
common satopars,vgw,xf,zf,txt1,txt2
if keyword_set(reset) then begin                ; set-up starting parameters
  nufun=3
  nvary=[vary(0:2+3*(ngau+nlor)),1,0,1]
  na=[a(0:2+3*(ngau+nlor)),50.0,0.24,0.05]
  npnames=[pnames,'SI','SP','SW']
  vary=intarr(3+3*(ngau+nlor)+nufun)
  vary=nvary
  a=fltarr(3+3*(ngau+nlor)+nufun)
  a=na
  pnames=strarr(9+nufun)
  pnames=npnames
  getspars
  return
  endif
if keyword_set(destroy) then begin              ; remove parameters
  nvary=vary(0:2+3*(ngau+nlor))
  vary=intarr(3+3*(ngau+nlor))
  vary=nvary
  na=a(0:2+3*(ngau+nlor))
  a=fltarr(3+3*(ngau+nlor))
  a=na
  npnames=pnames(0:8)
  pnames=strarr(9)
  pnames=npnames
  nufun=0
  return
  endif
if (gw ne 0.0) then begin
  xgh=[0.3811869902,1.1571937124,1.9816567566,2.9306374202]
  wgh=[6.6114701255e-1,2.0780232581e-1,1.7077983007e-2,1.9960407221e-4]
  xgh=xgh*vgw/(2.*alog(2.)^0.5)
  wgh=wgh/!pi^0.5
  end
if (gw eq 0.0) then begin
  qx=!pi*(x*xf-x*zf)-!pi
  qy=!pi*(x*xf+x*zf)-!pi
  r=(((qx-qy)^2-(!pi*par(1))^2)^2+((qx+qy)^2-(!pi*par(1))^2)^2)/(8*(3.8*!pi*par(1))^2)
  smz=par(2)^4/(par(2)^2+r)^2
 endif else begin           ; do a Gauss-Hermite vertical convolution as well
  smz=fltarr(n_elements(x))
  temp1=fltarr(n_elements(x))
  temp2=fltarr(n_elements(x))
  for gh=0,3 do begin
    qx=!pi*((x*xf-xgh(gh)*zf)-(x*zf+xgh(gh)*xf))-!pi
    qy=!pi*((x*xf-xgh(gh)*zf)+(x*zf+xgh(gh)*xf))-!pi
    r=(((qx-qy)^2-(!pi*par(1))^2)^2+((qx+qy)^2-(!pi*par(1))^2)^2)/(8*(3.8*!pi*par(1))^2)
    y=par(2)^4/(par(2)^2+r)^2
    smz=smz+wgh(gh)*y
    if (n_params() gt 3) then begin
      dr=-2*r/par(1)-!pi^2*par(1)*((qx-qy)^2-(!pi*par(1))^2+(qx+qy)^2-(!pi*par(1))^2)/(2*(3.8*!pi*par(1))^2)
      temp1=temp1-wgh(gh)*2*y/(par(2)^2+r)*dr
      temp2=temp2+wgh(gh)*4*(y/par(2)-par(2)*y/(par(2)^2+r))
      endif
    qx=!pi*((x*xf+xgh(gh)*zf)-(x*zf-xgh(gh)*xf))-!pi
    qy=!pi*((x*xf+xgh(gh)*zf)+(x*zf-xgh(gh)*xf))-!pi
    r=(((qx-qy)^2-(!pi*par(1))^2)^2+((qx+qy)^2-(!pi*par(1))^2)^2)/(8*(3.8*!pi*par(1))^2)
    y=par(2)^4/(par(2)^2+r)^2
    smz=smz+wgh(gh)*y
    if (n_params() gt 3) then begin
      dr=-2*r/par(1)-!pi^2*par(1)*((qx-qy)^2-(!pi*par(1))^2+(qx+qy)^2-(!pi*par(1))^2)/(2*(3.8*!pi*par(1))^2)
      temp1=temp1-wgh(gh)*2*y/(par(2)^2+r)*dr
      temp2=temp2+wgh(gh)*4*(y/par(2)-par(2)*y/(par(2)^2+r))
      endif
    endfor
  endelse
y=par(0)*smz
if n_params(0) le 3 then return
pdpar(*,3*i)=smz
if (gw eq 0.0) then begin
  dr=-2*r/par(1)-!pi^2*par(1)*((qx-qy)^2-(!pi*par(1))^2+(qx+qy)^2-(!pi*par(1))^2)/(2*(3.8*!pi*par(1))^2)
  pdpar(*,3*i+1)=-2*y/(par(2)^2+r)*dr
  pdpar(*,3*i+2)=4*(y/par(2)-par(2)*y/(par(2)^2+r))
  endif else begin
  pdpar(*,3*i+1)=temp1
  pdpar(*,3*i+2)=temp2
  endelse
return
end
