Viewing contents of file '../idllib/contrib/lamp/update.pro'
;*****************
;Update procedures for the embedded Lamp ditribution
;*****************
pro P_DO_THAT ;before starting
;** *********
;**
@lamp.cbk
lamd_dir = sys_dep('GETENV','LAMP_DIR' )
lamd_wind=strlowcase(sys_dep('GETENV','LAMP_WIND'))
while strpos(!path,'..') ge 0 do begin
i1=strpos(!path,'..')
if strpos(!path,'..\..') ge 0 then j1=5 else j1=2
if strpos(!path,'../..') ge 0 then j1=5
if i1 gt 0 then deb=strmid(!path,0,i1-1) else deb=''
!path=deb+lamd_dir +strmid(!path,i1+j1,300)
endwhile
cd, current=mee
if strtrim (!path,2) eq '.' then !path=mee else $
while (strpos(!path,'.\') ge 0) or (strpos(!path,'./') ge 0) do begin
i1=strpos(!path,'.\') & if i1 lt 0 then i1=strpos(!path,'./')
if i1 gt 0 then deb=strmid(!path,0,i1-1) else deb=''
!path=deb+ mee +strmid(!path,i1+1,300)
endwhile
if strtrim (!dir,2) eq '.' then !dir =mee
;a=widget_base (title='test',/column)
;b=widget_label(a,value='current='+mee)
;b=widget_label(a,value='lamp_dir='+lamd_dir)
;b=widget_label(a,value='path='+!path)
;b=widget_label(a,value='dir ='+!dir)
;widget_control,a,/realize
;wait,60.
;!dir='H:\LamP\pf_Win95'
catch,stat & if stat eq 0 then begin pth=sys_dep("NEWSUB",lamd_dir,"work") & cd,pth & endif
if strpos (!path,"lamp_mac") le 0 then begin
pth =sys_dep("NEWSUB" ,lamd_dir,"lamp_mac")
bid =sys_dep("ADDPATH",pth)
endif
if strpos(lamd_wind,'nw') ge 0 then set_plot,'TEK'
if (!D.flags and 65536) eq 0 then set_plot,'TEK'
if sys_dep('STUDENT') then lamp_ziz=600
if (strpos(lamd_wind,'small' ) ge 0) then lamp_ziz=480
if (strpos(lamd_wind,'medium' ) ge 0) then lamp_ziz=600
if (strpos(lamd_wind,'large' ) ge 0) then lamp_ziz=800
if (strpos(lamd_wind,'wide' ) ge 0) then lamp_ziz=1024
GEORGE=0
if (strpos(lamd_wind,'geo') ge 0) then GEORGE =1
end
;*****************************************************************************************
pro SL_RESTSCAN, file, cnt
;** ***********
@lamp.cbk
P_RESTORE,file ,cnt
if cnt gt 0 then begin
sl_lampscan, 'test' ,did_scan,tso
if did_scan ge 0 then ii=execute('scan,1') else cnt=0
endif
end
;*****************************************************************************************
pro myinit
;** ******
@lamp.cbk
common c_did, did_x,did_y,did_wb,did_wd,did_wsp,did_fu,did_curw,did_wsc,did_tio,did_pio,$
did_repr,did_scan,did_surf,did_inib,did_icon,did_lamp,did_pix,did_buf,did_o
if did_scan eq -1 then begin
VV =strtrim(string(sys_dep('VERSION')),2)
VV =strmid (VV,0,1)+strmid (VV,2,1)
pth=sys_dep('NEWSUB',lamp_dir,'lamp_mac')
SL_RESTSCAN,pth+'scan'+VV+'.sav' ,cnt
if cnt le 0 then did_scan=-2 else did_scan=1
endif
end
;*****************************************************************************************
pro Language_Help
online_help
end
;*****************************************************************************************
pro commca ,extxt, prox
;** ******
;**
common for_users, a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z
common c_lamp_par
i1=0L & i2=n_elements(extxt)-1
if n_elements(prox) eq 2 then if prox(0) ge 0 then begin i1=prox(0)
i2=prox(1) & endif
for kk=i1,i2 do begin ij=kk & jj=execute(extxt(ij)) & endfor
end
;*****************************************************************************************
pro show,string_in
;** ****
;**
;
;Handles sho command
;
@lamp.cbk
@dons.cbk
common for_users, a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z
rhs =' '
moan='Cant show '
stat=0 & jjj=1
catch,stat
if (stat ne 0) or (jjj ne 1) then begin
catch,/cancel
P_MUS,'mus_cannon'
if l_message le 0 then print,moan+rhs else $
widget_control,bad_id=iii,l_message,set_value=moan+rhs
print,string(7b)
return
endif else begin
string_in=strtrim(string_in,2)
coma=strpos(string_in,',')
if (coma le 0) then coma=strpos(string_in,' ')
fin =strlen(string_in)
lstr=fin-coma
if (coma le 0) or (coma eq fin-1) then return
rhs =strmid(string_in,coma+1,lstr)
abc=' '
jjj=execute('abc='+rhs)
icheck=n_elements(abc)
if icheck gt 1 then abc=reform(abc,icheck,/overwrite)
if icheck gt 10 then abc=abc(0:9)
ans=string(abc)
if GEORGE then begin
if icheck gt 10 then ans=['!first elements printed ...',ans]
to_don_history,-1,0, ans
endif
if formtxt le 0 then begin
if icheck eq 1 then if l_message le 0 then print,ans else $
widget_control,l_message,bad_id=iii,set_value=ans $
else begin print,ans & ans='!first elements printed ...'
if l_message le 0 then print,ans else $
widget_control,bad_id=iii,l_message,set_value=ans
endelse
endif else begin
if l_message le 0 then begin
print,ans
if icheck gt 10 then print,'Woops - Only first 10 elements given'
endif else begin
widget_control,formtxt,bad_id=iii,set_value=ans,/append
widget_control,formtxt,bad_id=iii,set_value='' ,/append
if icheck gt 10 then begin
i_bust='Woops - Only first 10 elements given'
widget_control,bad_id=iii,l_message,set_value=i_bust
endif else widget_control,bad_id=iii,l_message,set_value=' '
endelse
endelse
endelse
return
end
;*****************************************************************************************
pro P_ICK_LST,ev,uv
;** *********
;**
@lamp.cbk
common c_pick, pk_base,pk_path,pk_pthv,pk_flt ,pk_list,pk_idx,pk_sli,pk_frm,pk_ext,$
pk_hyst,pk_img ,pk_blis,pk_stak
pk_idx=ev.index
if pk_idx ge 0 then begin
fil =pk_list(pk_idx)
pk_hyst='' & w_buf=0
pp2 =-2
if pk_ext(pk_frm-1) eq '_LAMP' then p_did_restore_wrk,fil,pk_pthv,'0',pk_hyst,pp2
if pk_ext(pk_frm-1) eq '.gel' then sl_lampscan, '.gel' ,w_buf,pp2,pk_hyst,0, pk_pthv+fil
; if pk_ext(pk_frm-1) eq '.image' then sl_lampscan, '.image' ,w_buf,pp2,pk_hyst,0, pk_pthv+fil
if pk_ext(pk_frm-1) eq '.WIND' then sl_lampscan, 'restore',w_buf,pp2,pk_hyst,0, pk_pthv+fil
wset,uv(3) & erase
u=-1
if pk_ext(pk_frm-1) eq 'dial_*.pro*' then begin on_ioerror,misdial & str=''
openr,u,pk_pthv+fil,/get_lun
while (1) do begin str = strarr(10) & readf,u,str
pk_hyst=[pk_hyst,str] & endwhile
misdial: if u gt 0 then free_lun,u
pk_hyst=[pk_hyst,str]
endif
if pk_ext(pk_frm-1) eq '*.*' then begin on_ioerror,misread & str=strarr(10)
openr,u,pk_pthv+fil,/get_lun
readf,u,str
misread: if u gt 0 then free_lun,u
for i=0,9 do xyouts,2,173-(19*i),str(i),charsize=1.,/device,color=255
endif else widget_control,bad_id=i,uv(2),set_value=pk_hyst
in=-1
pk_img=0
on_ioerror,mispixf
ext='img'
i =findfile(pk_pthv+fil+'.Z',count=cnt)
if cnt eq 1 then bid=sys_dep ('UN_Z',pk_pthv+fil+'.Z',lamp_dir)
i= strpos(fil,'.htm') & ordur=1
if strpos(fil,'.hdf') ge 0 then cnt=0 else $
if i ge 0 then begin ordur=0 & fil=strmid(fil,0,i)
res=findfile(pk_pthv+fil+'_s.gif',count=cnt)
if cnt eq 0 then $
res=findfile(pk_pthv+fil+'_i.gif',count=cnt)
if cnt eq 0 then $
res=findfile(pk_pthv+fil+'-1.gif',count=cnt)
if cnt gt 0 then fil=res(0)
endif else begin ordur=1 & ii =sys_dep('POT+',fil,ext,1)
res=findfile(pk_pthv+fil ,count=cnt)
if cnt gt 0 then fil=res(0) & endelse
if cnt gt 0 then $
if pp2 eq 10 then READ_GIF,fil,w_buf $
else begin
OPENR,in,fil,/GET_LUN
on_ioerror,mispixm
w_buf=bytarr(uv(4),uv(5))
readu,in,w_buf
endelse
mispixm:
s=size(w_buf)
if (s(1) eq uv(4)) and (s(2) eq uv(5)) then begin
worder=!order & !order=ordur
tvscl,w_buf & !order=worder
pk_img=1
endif
mispixf:if in gt 0 then free_lun,in
p_did_setwin0
w_buf=0
endif
return
end
;*****************************************************************************************
FUNCTION vnorm, w_in, w_van0, ch1, ch2
;******* *****
;**
;For IN4, IN5, IN6 and D7 data
;
;Improved version of Don Kearley's vnorm. Rescales error bars correctly.
;Channels defined to run from 1 to nchannels.
;
;e.g. w8=vnorm(w7,w20,90,110) - normalise data in w7 to vanadium data in w20,
; integrated from time channels 90 to 110
;
; KHA 27/1/99
;
COMMON c_lamp_access, inst
iprint=1 ; if iprint>0, show debugging messages
IF (iprint GT 0) THEN PRINT,'Start vnorm:'
take_datp, datp
take_datp, datvan, /third
;-------------------------------------------------------------------------------
;Check workspace sizes
sw=SIZE(w_in)
IF (iprint GT 0) THEN PRINT,'SIZE(w_in)=',sw
nchannels=sw(1)
IF (sw(0) EQ 1) THEN nspectra=1 ELSE nspectra=sw(2)
e_in=datp.e
se=SIZE(e_in)
IF (iprint GT 0) THEN PRINT,'SIZE(e_in)=',se
IF (se(0) NE sw(0) OR se(1) NE sw(1) OR se(2) NE sw(2)) THEN e_in=SQRT(w_in)
w_van=w_van0 & sv=SIZE(w_van)
e_van=datvan.e
se=SIZE(e_van)
IF (se(0) NE sv(0) OR se(1) NE sv(1) OR se(2) NE sv(2)) THEN e_van=SQRT(w_van)
IF (inst EQ 'D7') THEN BEGIN
nv=sv(2)
IF (iprint GT 0) THEN PRINT,'D7: nspectra=',nspectra,' nv=',nv
IF (nspectra EQ 2*nv) THEN BEGIN
w_van=[[w_van],[w_van]]
e_van=[[e_van],[e_van]]
ENDIF ELSE IF (nspectra EQ 6*nv) THEN BEGIN
w_van=[[w_van],[w_van],[w_van],[w_van],[w_van],[w_van]]
e_van=[[e_van],[e_van],[e_van],[e_van],[e_van],[e_van]]
ENDIF ELSE IF (nv NE nspectra) THEN BEGIN
PRINT,'vnorm: Error - no. of V spectra must be 1,2 or 6 times no. of w_in spectra'
GOTO, finished
ENDIF
zeroed=WHERE(e_in LE -1.,nz) ; zeroed spectrum numbers
IF (iprint GT 0) THEN PRINT,nz/nchannels,' zeroed spectra
ENDIF ELSE IF (sv(0) NE sw(0) OR sv(1) NE sw(1) OR sv(2) NE sw(2)) THEN BEGIN
PRINT,'vnorm: Error - w_in and V data not same format'
GOTO, finished
ENDIF
IF (iprint GT 0) THEN PRINT,'nchannels=',nchannels,' nspectra=',nspectra
;-------------------------------------------------------------------------------------
; Perform normalisation
V=TOTAL(w_van(ch1-1:ch2-1,*),1) & dV=SQRT(TOTAL(e_van(ch1-1:ch2-1,*)^2,1))
Vmean=TOTAL(V)/nspectra
V=V/Vmean & dV=dV/Vmean
V=REFORM(V,1,nspectra) & dV=REFORM(dV,1,nspectra)
V=(FLTARR(nchannels)+1.)#V
dV=(FLTARR(nchannels)+1.)#dV
novan=WHERE(V LE 0., n) & IF (n GE 1) THEN V(novan)=1.
w_out=w_in/V
e_out=SQRT((e_in/V)^2+(w_in*dV/V^2)^2)
IF (n GE 1) THEN w_out(novan)=0.
IF (n GE 1) THEN e_out(novan)=-1.
IF (inst EQ 'D7') THEN BEGIN
w_out(zeroed)=0. & e_out(zeroed)=-1.
ENDIF
IF (iprint GT 0) THEN PRINT,'End of main section'
;-------------------------------------------------------------------------------------
if n_elements(datp.e) eq n_elements(e_out) then datp.e=e_out
PRINT,'vnorm: normalised to V data, channels',ch1,' to',ch2
title=datvan.other_tit
IF (inst EQ 'D7') THEN i=3 ELSE i=4
IF (STRMID(title,i,1) EQ '#') THEN BEGIN
n=STRLEN(title) & title=STRMID(title,i+1,n-i-1)
i=STRPOS(title,' ') & numor=STRMID(title,0,i)
ENDIF ELSE BEGIN
i=RSTRPOS(title,' ') & n=STRLEN(title)
numor=STRMID(title,i+1,n)
IF (STRPOS(numor,'>') EQ -1) THEN $
numor=STRTRIM(STRING(FIX(datvan.p(10))),2)
ENDELSE
s=' -vn('+numor+','+STRTRIM(STRING(ch1),2)+','+STRTRIM(STRING(ch2),2)+')'
datp.other_tit=datp.other_tit+s
give_datp, datp
finished:
RETURN, w_out
END