linse/fit
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit

Browse Source
This commit is contained in:
zolliker
2022-08-19 15:22:33 +02:00
commit d682fae506
545 changed files with 48172 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
pgm/CVS/Entries Normal file
View File

@ -0,0 +1,16 @@
/addchan.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/bose.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/csc.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/deteff.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/deteff2.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/subit.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/ufit.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/zm_fit/1.1.1.1/Tue Nov 2 15:54:57 2004//
/abskor3.f/1.2/Thu Dec 22 16:07:28 2005//
/brows.f/1.2/Tue Aug 8 10:35:11 2006//
/addit.f/1.3/Tue May 15 11:02:38 2012//
/clamp.f/1.3/Tue Mar 8 09:25:31 2011//
/tricslog.f/1.3/Fri Nov 13 14:06:20 2015//
/sumvar.f/1.3/Fri Nov 3 07:22:08 2017//
/trics_ccl.f/1.7/Fri Sep 8 07:59:46 2017//
D

1
pgm/CVS/Repository Normal file
View File

@ -0,0 +1 @@
analysis/fit/pgm

1
pgm/CVS/Root Normal file
View File

@ -0,0 +1 @@
/afs/psi.ch/project/sinq/cvs

175
pgm/abskor3.f Normal file
View File

@ -0,0 +1,175 @@
program abskor3
* absorption correction for full or double-walled cylinders
* replaces old ABSKOR and ABSKOR2
* uses FIT subroutines written by M. Zolliker
* 30.11.01
*
* > myfit abskor3.f
* > mv a.out abskor3
implicit none
integer l
character*256 file, outfile, line
character*32 spec, value
character*5 flag
real mur, rira, rarc
logical found
external extract_option, cvt_ratio
logical extract_option
real cvt_ratio
call sys_get_cmdpar(line, l)
if (line .eq. ' ') then
call fit_init_silent
call sys_getenv('dat_defspec',spec)
if (spec.eq.' ') spec='DMC'
call str_trim(spec,spec,l)
100 write(*,*)
write(*,'(x,a)')'DMC = 1 / HRPT = 2'
write(*,'(x,3a,$)')'Instrument (default: ',spec(1:l),'): '
read(*,'(a)')flag
call str_upcase(flag, flag)
if (flag.eq.'1') flag='DMC'
if (flag.eq.'2') flag='HRPT'
if (flag.ne.' ') then
if (flag.ne.'DMC' .and. flag.ne.'HRPT') goto 100
spec=flag
endif
call sys_setenv('dat_defspec',spec)
file=' '
outfile=' '
else
mur=0
rira=0
rarc=0
if (extract_option('m', line, value)) then
read(value, *, err=999,end=999) mur
endif
if (extract_option('r', line, value)) then
rira=cvt_ratio(value, -1.0)
if (rarc .lt. 0) goto 999
endif
if (extract_option('c', line, value)) then
rarc=cvt_ratio(value, -1.0)
if (rarc .lt. 0) goto 999
endif
found=extract_option(' ', line, file)
found=extract_option('o', line, outfile)
if (line .ne. ' ') goto 999
call fit_init_silent
endif
call fit_dat_merge(file,0.025)
write(*,*)
call fit_abskor2(mur,rira,rarc)
write(*,*)
C call fit_auto_mon
C write(*,*)
C call fit_mon(0)
if (outfile .eq. ' ') then
101 write(*,'(x,a,$)')'Name of output file: '
read(*,'(a)') outfile
if (outfile.eq.' ') goto 101
endif
call fit_export(0.0,'lnsp',outfile)
write(*,*)
write(*,'(x,2a)')'new file: ',outfile
write(*,*)
goto 9999
999 write (*,*) ' '
write (*,*) 'Usage:'
write (*,*) ' '
write (*,'(x,2a)') ' abskor3 -m <m> [ -r <ri>/<ra> ]'
*,' [ -c <ra>/<rc> ] [ -o <out> ] <inp>'
write (*,*) ' '
write (*,*) 'where <m> mu*R'
write (*,*) ' <ri> inner sample radius'
write (*,*) ' <ra> outer sample radius'
write (*,*) ' <rc> radial collimator fwhm'
write (*,*) ' <inp> input file(s) or number of run(s)'
write (*,*) ' <out> output file'
9999 end
logical function extract_option(optchar, line, value)
! extract an option from commandline
! options are single chars preceded by
character optchar*1, line*(*), value*(*)
integer i, state, j
state=0 ! beginning or between options
do i=1,len(line)
if (state .eq. 0) then
if (line(i:i) .le. ' ') then
continue
elseif (line(i:i) .eq. '-') then
state=2 ! option started
elseif (optchar .eq. ' ') then ! argument
state=5 ! argument started
j=i
endif
elseif (state .eq. 2) then
if (line(i:i) .eq. optchar) then
line(i-1:i)=' '
state=3 ! option matches
else
state=1 ! option does not match
endif
elseif (state .eq. 1) then
if (line(i:i) .gt. ' ') then
state=4 ! unmatching option value
elseif (line(i:i) .eq. '-') then
state=2 ! option has started
endif
elseif (state .eq. 4) then
if (line(i:i) .le. ' ') then
state=0 ! between options
endif
elseif (state .eq. 3) then
if (line(i:i) .gt. ' ') then
j=i
state=6
endif
elseif (state .ge. 6) then
if (state .eq. 6) then
if (line(i:i) .eq. '-' .and. len(value) .eq. 1) then
value=' '
extract_option=.true.
return
endif
if (line(i:i) .le. ' ') then
value=line(j:i)
line(j:i)=' '
extract_option=.true.
return
endif
endif
endif
enddo
if (state .lt. 5) then
value=' '
extract_option=.false.
return
endif
value=line(j:)
line(j:)=' '
extract_option=.true.
end

52
pgm/addchan.f Normal file
View File

@ -0,0 +1,52 @@
program addchan
! compile with:
! > myfit -o addchan addchan.f
implicit none
integer j,i,n,listflag
character*256 list
real twoth
integer nmax
parameter (nmax=16000)
real xx(nmax)
call fit_init
call dat_ask_filelist(list,' ')
listflag=0
do j=1,999999
call fit_dat_next_opt(list,listflag,1,0.0)
if (listflag.eq.0) goto 101
call fit_get_real('A4', twoth)
call fit_get_array('X', xx, nmax, n)
print *,'a4 ',twoth,n
do i=1,n
if (xx(i) .le. 500.) then
xx(i)=xx(i)-twoth+1000.
endif
enddo
call fit_put_array('X', xx, n)
if (n+1600 .ge. nmax) then
call fit_merge(0.05)
endif
enddo
101 write(*,*)
call fit_merge(0.05)
call fit_get_array('X', xx, nmax, n)
do i=1,n
xx(i)=xx(i)-1000.
enddo
call fit_put_array('X', xx, n)
call fit_export(0,'lnsp',' ')
end

94
pgm/addei.f Normal file
View File

@ -0,0 +1,94 @@
program addei
implicit none
integer i, n, listflag, l, iostat, numor, j, la, lo
character*1024 list
character*256 filename
character*256 outname
character line*256, axis*8
real fx,kfix,val,en(999),ei
call fit_init
list=' '
call sys_get_cmdpar(list, l)
if (list .eq. ' ') then
call dat_ask_filelist(list,' ')
endif
listflag=0
c treat no more than 9999 files
do i=1,9999
call fit_dat_options('x=en')
call fit_dat_silent
call fit_dat_next(list,listflag)
c exit loop when finished
if (listflag.eq.0) goto 999
call fit_get_real('Numor', val)
numor = val
call fit_get_real('FX', fx)
call fit_get_real('KFIX', kfix)
ei=kfix*kfix*2.072
call fit_get_array('x', en, 999, n)
call fit_get_str('File', l, filename)
do j=l,1,-1
if (filename(j:j) .eq. '/') then
outname=filename(j+1:l)
lo=l-j
goto 200
endif
enddo
outname=filename
lo=l
200 continue
call fit_get_str('XAxis', la, axis)
if (axis .ne. 'EN') then
print *,outname(1:lo),'(column EN not found)'
goto 900
endif
call sys_open(1, filename(1:l), 'r', iostat)
if (iostat .ne. 0) then
print *,'can not open ',filename(1:l)
goto 999
endif
if (outname(lo:lo) .eq. 'c') then
outname(lo:lo) = 't'
else
outname(lo:lo) = 'c'
endif
call sys_open(2, outname(1:lo), 'w', iostat)
if (iostat .ne. 0) then
print *,'can not create ',outname(1:lo)
goto 999
endif
print *,outname(1:lo),' created'
read(1, '(a)', iostat=iostat) line
call str_trim(line, line, l)
do while (iostat .eq. 0 .and. line(1:4) .ne. 'DATA')
write(2,'(a)') line(1:l)
read(1, '(a)', iostat=iostat) line
enddo
read(1, '(a)', iostat=iostat) line
call str_trim(line, line, l)
write(2, '(2a)') line(1:l),' EI'
call str_trim(line, line, l)
do j=1,n
read(1, '(a)', iostat=iostat) line
if (iostat .ne. 0) goto 900
if (fx .eq. 1) then
write(2,'(a,f10.4)') line(1:l),ei
else
write(2,'(a,f10.4)') line(1:l),ei-en(j)
endif
enddo
close(1)
close(2)
900 continue
enddo
999 continue
end

67
pgm/addit.f Normal file
View File

@ -0,0 +1,67 @@
program addit
* replaces "powderplus"
* (23.4.99) rekonstruiert am 7.7.99, geaendert am 15.7.99,28.9.99,7.3.00
*
* > myfit addit.f
* > mv a.out addit
implicit none
integer l
character*36 spec
character*256 file
character*8192 line
character*5 flag
call fit_init
call sys_get_cmdpar(line, l)
call str_lowcase(line, line)
if (line(1:l) .ne. ' ') then
call fit_dat_options(line)
endif
call sys_getenv('dat_defspec',spec)
if (spec.eq.' ') spec='DMC'
call str_trim(spec,spec,l) ! Laenge bestimmen (l)
100 write(*,*)
write(*,'(x,a)')'DMC = 1 / HRPT = 2'
write(*,'(x,3a,$)')'Instrument (default: ',spec(1:l),'): '
read(*,'(a)')flag ! ^ schreibt spec von
! Zeichen 1 bis l
call str_upcase(flag, flag) ! schreibt Inhalt von flag gross
if (flag.eq.'1') flag='DMC'
if (flag.eq.'2') flag='HRPT'
if (flag.ne.' ') then
if (flag.ne.'DMC' .and. flag.ne.'HRPT') goto 100
spec=flag
endif
call sys_setenv('dat_defspec',spec)
C call fit_dat(' ')
C call fit_merge(0.02)
if (spec .eq. 'DMC') then
call fit_dat_merge(' ',0.025) ! ersetzt fit_dat und fit_merge
else
call fit_dat_merge(' ',0.025) ! ersetzt fit_dat und fit_merge
endif
call fit_auto_mon
write(*,*)
call fit_mon(0)
101 write(*,'(x,a,$)')'Name of output file: '
read(*,'(a)')file
if (file.eq.' ') goto 101
call fit_export(0,'lnsp',file)
call str_trim(file, file, l)
write(*,*)
write(*,'(x,2a)')'new file: ',file(1:l)
write(*,*)
end

152
pgm/autofit.f Normal file
View File

@ -0,0 +1,152 @@
program autofit
c ---------------
implicit none
real par(200), err(200)
integer j, i, n, listflag, pos, iostat, ipar
character*8192 list
character*8192 line
integer l, lline
character*128 vars
character*128 outfile
character num*32
character var*32,upvar*32
real value
integer lun, k
real ymon
integer get_par_no
integer iret, fit_dat_opt
call sys_get_cmdpar(line, lline)
pos = 1
call str_get_word(line(1:lline), pos, vars)
call str_get_word(line(1:lline), pos, outfile)
call str_get_word(line(1:lline), pos, list)
if (outfile .eq. ' ') then
print *,' '
print *,'Usage:'
print *,' '
print *,'1) start the ordinary fit program with the first file'
print *,'2) select fit function, and setup fixed pars and correlations'
print *,'3) do a first fit'
print *,'4) use command "exit" to leave and save settings in last.fit3'
print *,'5) start autofit. Example:'
print *,' '
print *,' autofit mf,i1 out.dat 1964-2018'
print *,' '
print *,' fit datafiles with numbers 1964...2018'
print *,' plot using mf as x and fir parameter i1 as y'
print *,' '
print *,'6) plot results:'
print *,' '
print *,' fit -p out.dat'
print *,' '
print *,'7) if in doubt, check fit graphically:'
print *,' '
print *,' gv pgplot.ps'
print *,' '
print *,'Tips:'
print *,'- use "temp" for temperature'
print *,'- use "intexp" for experimental integrated intensity'
print *,'- more than one fit parameter might be specified,'
print *,' resulting in more than 3 columns'
print *,'- in step (2), use commands "win" and "keep y" in fit,'
print *,' if you want to make the fit only in a window'
print *,' '
goto 999
endif
call fit_init
call sys_setenv('CHOOSER_PAN','9') ! 9 plots per page
call sys_setenv('CHOOSER_POPT','A') ! all on one file
c read parameter file from last fit
call fit_load('last.fit3')
call sym_get_real('Monitor', ymon)
if (list .eq. ' ') then
call dat_ask_filelist(list,' ')
call str_trim(list, list, l)
call str_append(line, lline, ' ')
call str_append(line, lline, line(1:l))
endif
listflag=0
call sys_get_lun(lun)
call sys_open(lun, outfile, 'w', iostat)
if (iostat .ne. 0) then
print *,'cannot open ',outfile
goto 999
endif
write(lun,'(2a)') '# created with the following command:'
write(lun,'(2a)') '# autofit ', line(1:lline)
c write header
line = ' '
lline = 0
i=1
do while (.true.)
call str_get_elem(vars, i, var)
if (var .eq. ' ') exit
call str_trim(var, var, l)
if (lline .ne. 0) call str_append(line, lline, ' ')
do k=l,9
call str_append(line, lline, ' ')
enddo
call str_append(line, lline, var(1:l))
call str_upcase(upvar(1:l), var(1:l))
ipar = get_par_no(upvar(1:l))
if (ipar .gt. 0 .or. upvar(1:l) .eq. 'INTEXP') then
call str_append(line, lline, ' err')
endif
enddo
write(lun,'(a)') line(1:lline)
c treat no more than 9999 files
do j=1,9999
call fit_dat_next(list,listflag)
call fit_mon(ymon)
c exit loop when finished
if (listflag.eq.0) goto 101
call fit_fit(0)
c plot it to file
call fit_plot('y')
call fit_get_array('p', par, 100, n)
call fit_get_array('e', err, 100, n)
line = ' '
lline = 0
i = 1
do while (.true.)
call str_get_elem(vars, i, var)
if (var .eq. ' ') exit
if (lline .ne. 0) call str_append(line, lline, ' ')
call str_upcase(upvar, var)
if (upvar .eq. 'INTEXP') then
ipar = n
else
ipar = get_par_no(upvar)
endif
if (ipar .eq. 0) then
c it is a variable like 'temp' or 'mf'
call sym_get_real(var, value)
call cvt_real_str(num, l, value, 10, 0, 7, 1)
call str_append(line, lline, num(1:l))
else
c it is a parameter, we write also the error
call cvt_real_str(num, l, par(ipar), 10, 0, 7, 1)
call str_append(line, lline, num(1:l))
call str_append(line, lline, ' ')
call cvt_real_str(num, l, err(ipar), 10, 0, 7, 1)
call str_append(line, lline, num(1:l))
endif
enddo
write(lun,'(a)') line(1:lline)
enddo
close(lun)
101 write(*,*)
999 end

180
pgm/bose.f Normal file
View File

@ -0,0 +1,180 @@
program BOSE
! ------------
!
! Simple user function example (straight line).
!
implicit none
external BOSE_FUN
character str*32
integer i,l
!---
! Welcome message
call fit_vers(str)
call str_trim(str, str, l)
type '(X,2A)','Program FIT(BOSE) Version ',str(1:l)
do i=1,l
str(i:i)='-'
enddo
type '(X,2A/)','-----------------------------',str(1:l)
!---
! Function title and parameter names
!
call fit_confun('lorenz/bose', bose_fun) ! function title, function
call fit_userpar('BG:Bgr(0)')
call fit_userpar('DB:dBgr/dX')
call fit_userpar('EF:EF')
call fit_userpar('T:Temp')
do i=1,9
write(str, '(2(a,i1))') 'P',i,':Pos',i
call fit_userpar(str)
write(str, '(2(a,i1))') 'I',i,':Int',i
call fit_userpar(str)
write(str, '(2(a,i1))') 'W',i,':Wid',i
call fit_userpar(str)
enddo
call fit_main
end
real function bose_fun(x,p,n,mode,cinfo)
! -------------------------------------------
implicit none
real x ! x-value
integer n ! number of parameters
real p(n) ! parameters
integer mode ! mode
integer cinfo ! calculation information (see below)
integer i,i0,j,k
parameter (i0=7)
real x0,w0,y0,db,bg,kf,l0
real voigt, bose_fact
real xnew(9),ynew(9),wnew(9)
if (mode .eq. 0) then
bose_fun=0
do i=i0,n-2,3
if (p(i+2) .ne. 0) then ! ignore delta functions (treated later)
bose_fun=bose_fun+p(i+1)*voigt(x-p(i), 0.0, p(i+2))
if (p(i+2) .lt. 0) then ! make a mirror peak for negative width
x0=x+p(i)
if (i .gt. i0 .and. p(i0+2) .eq. 0.0) x0=x0-2*p(i0) ! shift zero
bose_fun=bose_fun+p(i+1)*voigt(x0, 0.0, -p(i+2))
endif
endif
enddo
bose_fun=bose_fun*bose_fact(x/p(6))+p(3)+p(4)*x
elseif (mode .eq. 1) then
! x-independent part
do i=i0,n-2,3
if (p(i+2) .eq. 0) then ! treat delta functions
call fit_delta(p(i),p(i+1))
endif
enddo
call fit_limit_xrange(-p(5),1e6)
elseif (mode .eq. 2) then ! transform x -> t
x0=x+2*p(5)
if (x0 .ge. 0) then
bose_fun=sqrt(x0)
else
bose_fun=0
endif
elseif (mode .eq. 3) then ! transform t -> x
bose_fun=x*x-2*p(5)
else
if (nint(x) .eq. -1 .and. n .ge. 7) then ! convert from multi-voigt
print *
if (n .eq. 7) then
print *,'Convert from voigt'
else
print *,'Convert from multi-voigt'
endif
db=p(2)
bg=p(1)-p(3)*db ! different bg definition
j=3
x0=p(3)
y0=p(5)
w0=max(abs(p(6)), abs(p(7)))
l0=p(7)
do i=8,n,5
if (abs(p(i)) .lt. abs(x0)) then
j=i
x0=p(i)
y0=p(i+2)
w0=max(abs(p(i+3)), abs(p(i+4)))
endif
enddo
k=0
do i=3,n,5
if (p(i) .gt. 0 .and. i .ne. j) then
k=k+1
xnew(k)=p(i)
ynew(k)=p(i+2)
wnew(k)=-max(abs(p(i+3)), abs(p(i+4)))
endif
enddo
p(1)=w0
p(2)=w0*0.05
p(3)=bg
p(4)=db
kf=1.55
call fit_get_real('KFIX', kf)
p(5)=2.0723*kf*kf
p(6)=10 ! default Temp
call fit_get_real('Temp', p(6))
p(7)=x0
p(8)=y0
p(9)=l0
i=10
do j=1,k
p(i)=xnew(k)
p(i+1)=ynew(k)/bose_fact(p(i)/p(6))
p(i+2)=wnew(k)
i=i+3
enddo
x=i-1
else
print *
print *,'Up to 9 Lorenzians multiplied with bose_factor'
1 ,', folded with gaussian'
endif
print *,'Negative Wid makes a mirror peak at -Pos'
print *
endif
end
real function bose_fact(wot)
! argument: omega[meV] over T[K]
real wot
real K_meV, x
parameter (K_meV=11.6048)
x=wot*K_meV
if (abs(x) .lt. 1e-5) then
bose_fact=1.0
else if (x .lt. -30) then
bose_fact=0
else
bose_fact=x/(1-exp(-x))
endif
end

216
pgm/brows.f Normal file
View File

@ -0,0 +1,216 @@
program brows
integer pin, pout, n,l
integer nmax
parameter (nmax=9999)
character filelist*256, name*256
real xval(nmax), yval(nmax), sig(nmax), rmon(nmax)
external list_none
external cvtyp
character*4 cvtyp
call sys_get_cmdpar(filelist, l)
name=cvtyp(0) ! init types
if (filelist .eq. ' ') then
call dat_ask_filelist(filelist, ' ')
endif
call dat_silent
pin=0
pout=0
call dat_open_next(filelist, pin, name, pout
& , list_none, nmax, n, xval, yval, sig, rmon)
call dat_get_filename(filelist, l)
call list_file(filelist(1:l))
end
subroutine list_none(name, value)
character name*(*)
real value
end
subroutine list_file(filename)
implicit none
character filename*(*)
include 'napif.inc'
integer fileid(NXhandlesize)
integer status, type, level, l, m, length, j, i
integer rank, dim(32)
integer*4 idata(64)
real*4 val
character cdata*80, name*257, class*257
external cvtyp, cvt_str
character*4 cvtyp
character tab*80/' '/
integer cvt_str
100 format(1x,10a)
level=0
call NXswitchReport(0)
status=NXopen(filename, NXacc_read, fileid)
if (status .ne. NX_ok) then
print *,filename,' is probably not a HDF file'
goto 999
endif
1 status=NXgetnextattr(fileid, name, length, type)
if (status .eq. NX_error) goto 999
if (status .eq. NX_ok) then
call str_trim(name,name,l)
length=256
status=NXgetattr(fileid, name(1:l), idata, length, type)
if (status .ne. NX_ok) goto 999
if (type .eq. nx_char .or.
1 type .eq. nx_uint8 .or. type .eq. nx_int8) then
length=cvt_str(cdata, idata)
elseif (type .eq. NX_INT32) then
length=12
write(cdata(1:12), '(i12)') idata(1)
else
length=4
cdata=cvtyp(type)
endif
write(*,100) tab(1:level*2+1)
1 ,'| ',name(1:l),':',cdata(1:length)
goto 1
endif
2 status=NXgetnextentry(fileid, name, class, type)
if (status .eq. NX_error) goto 999
if (status .eq. NX_ok) then
call str_trim(name, name, l)
call str_trim(class, class, m)
if (class .ne. 'SDS') then
write(*,100) tab(1:level*2+1)
1 ,'Group: ',name(1:l),', class:',class(1:m)
if (class(1:3) .ne. 'CDF') then
status=NXopengroup(fileid, name(1:l), class(1:m))
if (status .ne. NX_ok) goto 999
level=level+1
endif
goto 2
endif
status=NXopendata(fileid, name(1:l))
if (status .ne. NX_ok) goto 999
status=NXgetinfo(fileid, rank, dim, type)
if (status .ne. NX_ok .or. rank .gt. 16) goto 999
if (type .eq. nx_char .or.
& type .eq. nx_uint8 .or. type .eq. nx_int8) then
length=dim(1)
status=NXgetslab(fileid, idata, 1, length)
if (status .ne. NX_ok) goto 999
length=cvt_str(cdata, idata)
else
do i=1,rank
if (dim(i) .gt. 1 ) then
write(cdata,'(a,16i5)') ' array [',(dim(j),j=1,rank)
length=8+5*rank+6
cdata(length-5:length)='] '//cvtyp(type)
goto 29
endif
enddo
if (type .eq. NX_INT32) then
status=NXgetslab(fileid, idata, 1, 1)
if (status .ne. NX_ok) goto 999
length=12
write(cdata(1:12), '(i12)') idata(1)
elseif (type .eq. NX_FLOAT32) then
status=NXgetslab(fileid, val, 1, 1)
if (status .ne. NX_ok) goto 999
length=16
write(cdata(1:16), '(g16.5)') val
else
length=4
cdata=cvtyp(type)
endif
endif
29 write(*,100) tab(1:level*2+1)
1 ,name(1:l),':',cdata(1:length)
3 status=NXgetnextattr(fileid, name, length, type)
if (status .eq. NX_error) goto 999
if (status .eq. NX_ok) then
call str_trim(name,name,l)
length=256
status=NXgetattr(fileid, name(1:l), idata, length, type)
if (status .ne. NX_ok) goto 999
if (type .eq. nx_char .or.
1 type .eq. nx_uint8 .or. type .eq. nx_int8) then
length=cvt_str(cdata, idata)
elseif (type .eq. NX_INT32) then
length=12
write(cdata(1:12), '(i12)') idata(1)
else
length=4
cdata=cvtyp(type)
endif
write(*,100) tab(1:level*2+1)
1 ,'| ',name(1:l),':',cdata(1:length)
goto 3
endif
status=NXclosedata(fileid)
if (status .ne. NX_ok) goto 999
goto 2
endif
if (level .gt. 0) then
level=level-1
status=NXclosegroup(fileid)
if (status .ne. NX_ok) goto 999
goto 2
endif
9 status=NXclose(fileid)
if (status .ne. NX_ok) goto 999
print *,"o.k."
999 call nxlistreport
end
character*4 function cvtyp(type)
integer type
integer i
character*4 t(25)/3*' ','char','f32','f64',13*' ',
& 'i8','u8','i16','u16','i32','u32'/
if (type .le. 0 .or. type .gt. 25) then
do i=1,25
if (t(i) .eq. ' ') write(t(i),'(i2)') i
enddo
if (type .gt. 9999 .or. type .lt. 0) then
cvtyp='????'
else
write(cvtyp, '(i4)') type
endif
else
cvtyp=t(type)
endif
end
integer function cvt_str(cdata, idata)
character cdata*(*)
character str*257
byte idata(*)
integer l
call replace_string(str, idata)
call str_trim(str, str, l)
if (l+2 .gt. len(cdata)) then
cdata='"'//str(1:len(cdata)-5)//'..."'
cvt_str=len(cdata)
else
cdata='"'//str(1:l)//'"'
cvt_str=l+2
endif
end

3
pgm/chooser.f Normal file
View File

@ -0,0 +1,3 @@
program chooser
call cho_choose('?')
end

152
pgm/clamp.f Normal file
View File

@ -0,0 +1,152 @@
program mclamp
* mclamp = multi convert to lamp format
* ^^^^^^ ^ ^ ^^^^
* preparation program for 3d plots in LAMP
* converts all the data formats recognized by FIT into LAMP format
*
* > myfit clamp.f
* > mv a.out clamp
* 6.2.01 LK / 26.8.02 MZ
*
* To be done:
* - if the input files do not have the same x-range, the output may be wrong
* - instead of 'number of files to merge' a tolerance in temperature
* should be given, and clamp should merge automatically
*
implicit none
real int1(4000),tth(4000),step,y(1000),tem(1000)
integer i,j,f,l,n,np,flag,int2(4000)
integer merg, numor1, numor2
real rnum, ymon
character*20 sample
character*1024 list
character*4 yflag
call fit_init
do i=1,4000
int1(i)=0.
enddo
print *,'number of files to merge:'
read(*,'(i20)') merg
if (merg .le. 0) merg=1
print *,'step for merge [0.025]'
read(*,'(f20.0)') step
if (step .eq. 0) step=0.025
open(1,file='LAMPascii',status='unknown')
call dat_ask_filelist(list,' ')
flag=0
np=0
n=0
ymon=0
do f=1,1000*merg
call fit_dat_silent
call fit_dat_next_opt(list,flag,0,step) ! DAT
call fit_get_real('Numor', rnum)
numor1=nint(rnum)
if (flag .eq. 0) goto 100
do j=2,merg
call fit_dat_silent
call fit_dat_next_opt(list,flag,3,step) ! LINK & MERGE
if (flag.eq.0) goto 50
enddo
call fit_get_real('Numor', rnum)
50 numor2=nint(rnum)
print *,'read numors',numor1,' to',numor2
call fit_merge(step)
if (ymon .eq. 0) then
call fit_auto_mon
call fit_get_real('Monitor', ymon)
else
call fit_mon(ymon)
endif
call fit_get_real('temp',tem(f))
call fit_get_str('sample',l,sample)
call fit_get_array('X',tth,4000,np)
call fit_get_array('Y',int1,4000,np)
do i=1,4000
int2(i)=nint(int1(i))
enddo
write(1,'(6i12)')(int2(j),j=1,np)
n=n+1
enddo
100 continue
close(1)
yflag='1'
105 print '(x,a)', 'x-axis: 2Theta'
print '(x,2a)', 'y-axis: File number [1] or Temperature [2]'
& ,' (default: 1): '
read(*,'(a)') yflag
print *
if (yflag.eq.' ') yflag='1'
if ((yflag.ne.'1').and.(yflag.ne.'2')) goto 105
open(3,file='LAMP',status='unknown')
write(3,'(x,a)')'LAMP_FORMAT'
write(3,'(x,a)')'HEADER FILE written by the LAMP APPLICATION'
write(3,*)
write(3,*)
write(3,'(x,a)')'DATA_FILE: LAMPascii'
write(3,'(x,a)')'SOURCE: clamp'
write(3,'(x,a)')'HISTORY: DMC/HRPT'
write(3,*)
write(3,'(x,a,i9)')'X_SIZE:',np
write(3,'(x,a,i9)')'Y_SIZE:',n
write(3,'(x,a,i9)')'Z_SIZE:',1
write(3,'(x,a)')'FORMAT: Ascii'
write(3,'(x,a)')'TYPE: (3 )Long Integer'
write(3,*)
write(3,'(x,a,i4,a,i3,a)')'MIN,MAX VALUES: w 1: Long dim =',np,
& ' * ',n,' min=0 max=9999'
write(3,*)
write(3,'(x,2a)')'TITLES: ',sample
write(3,'(x,a)')' X: 2Theta'
if (yflag.eq.'1') write(3,'(x,a)')' Y: File Number'
if (yflag.eq.'2') write(3,'(x,a)')' Y: Temperature'
write(3,'(x,a)')' Z: Counts'
write(3,*)
write(3,'(x,a)')'PARAMETERS:'
write(3,'(x,a)')'----------'
write(3,'(x,2a)')'Sample Name= ',sample
write(3,'(x,a)')'Temperature= '
write(3,*)
write(3,'(x,a)')'X_COORDINATES:'
write(3,'(x,a)')'-------------'
write(3,'(6f13.4)')(tth(j),j=1,np)
write(3,*)
write(3,'(x,a)')'Y_COORDINATES:'
write(3,'(x,a)')'-------------'
do i=1,n
y(i)=i
enddo
if (yflag.eq.'1') then
write(3,'(6f13.4)')(y(j),j=1,n)
else
write(3,'(6f13.4)')(tem(j),j=1,n)
endif
close(3)
end

210
pgm/csc.f Normal file
View File

@ -0,0 +1,210 @@
program csc
* convert single crystal data
* ^ ^ ^
*
* converts any data format read by FIT to inputfile for
* TVtueb (E2, HMI Berlin)
*
* > myfit -o csc csc.f
*
* Nov.03 L.Keller
* Dec.03 M.Zolliker (merged DMC + HRPT Version, 1 pass)
implicit none
! max. number of files, max. number of points
integer mf,mp
parameter (mf=2000,mp=1600)
real int1(mp),tth(mp)
real tem(mf),omega(mf),mon(mf),tth0(mf)
real lambda,dtth,lasttth,lastint
real reverse,omegasign
integer i,j,f,l,n,np,flag,nfiles,linstr
integer intall(mp,mf), int2(mp)
character*32 sample,owner,date,title,instr
character*1024 list
call fit_init
call dat_ask_filelist(list,' ')
flag=0
call fit_dat_next(list,flag)
call fit_get_real('lambda',lambda)
call fit_get_str('owner',l,owner)
call fit_get_str('sample',l,sample)
call fit_get_str('title',l,title)
call fit_get_str('date',l,date)
call fit_get_str('instrument',linstr,instr)
if (instr .eq. 'DMC') then
omegasign=-1 ! Vorzeichenwechsel von A3
dtth=0.2
reverse=-1 ! for historical reasons, revert output
np=400
elseif (instr .eq. 'HRPT') then
omegasign=1
dtth=0.1
reverse=-1
np=1600
else
write(*,*) 'unknown instrument: ',instr
stop
endif
write(*,*)
write(*,*)'processing ...'
write(*,*)
do f=1,mf
call fit_get_real('a3',omega(f))
call fit_get_real('temp',tem(f))
call fit_get_real('smon',mon(f))
call fit_get_array('X',tth,mp,n)
call fit_get_array('Y',int1,mp,n)
j=0
lasttth=tth(1)
lastint=int1(1)
do i=1,n
do while ((tth(i)-lasttth)/dtth .gt. 1.5) ! step is higher than 1.5 times step
j=j+1
intall(j,f)=nint((lastint+int1(i))*0.5)
lasttth=lasttth+dtth
enddo
j=j+1
lastint=int1(i)
intall(j,f)=nint(lastint)
lasttth=tth(i)
enddo
! check if step and number of points is correct
if (nint((tth(n)-tth(1))/dtth) .ne. np-1 .or. j .ne. np) then
print *,'step ',dtth,' np ',j
print *,'theta-range', tth(1), tth(n)
print *,'mismatch'
stop
endif
tth0(f)=tth(1)
! print '(''+'',i5)',f
print '(a1,i5,a1,$)','+',f,13
call fit_dat_silent
call fit_dat_next(list,flag)
if (flag.eq.0) then
nfiles=f
goto 100
endif
enddo
write(*,*)'too many files - fatal error'
stop
100 continue
write(*,*)
nfiles=f
open(1,file='csc.asc',status='unknown')
print *,'create csc.asc'
write(1,'(a14)')'SYS$SYSDEVICE:'
write(1,*)
write(1,'(a6,a64)')'NUMOR ',list
write(1,*)
write(1,'(3a)')'EXPTYPE ',instr(1:linstr),',SINQ'
write(1,*)
write(1,'(a3,x,a32)')'USN',owner
write(1,*)
write(1,'(a3,x,F6.4)')'WAV',lambda
write(1,*)
write(1,'(a,i6,a)') 'WIND W1= 1,',np,
& ' W2= 0, 0 W3= 0, W4= 0, 0'
write(1,*)
write(1,'(a9)')'PASS TTHS'
write(1,*)
write(1,'(a9)')'PRO T_SAM'
write(1,*)
write(1,'(a8,i12)')'MM1 MON=',nint(mon(1))
write(1,*)
write(1,'(a,e12.5,a,e12.5,a,e12.5)')
& 'RELA TTHS=',1.0*np,',',1.0*np,',',reverse*dtth
write(1,*)
write(1,'(a3,x,a32)')'SAM',sample
write(1,*)
write(1,'(a5,x,a32)')'TITLE',title
write(1,*)
write(1,'(a10,i6,x,a4)')'SETV STEP=',nfiles,'OMGS'
write(1,*)
write(1,'(a12,e12.5)')'READ T_MEAN=',tem(1)
write(1,*)
write(1,'(a4,x,a32)')'DATE',date
write(1,*)
write(1,'(a3,x,a32)')'COM',title
write(1,*)
write(1,*)
do f=1,nfiles
if (reverse .lt. 0) then
j=np
do i=1,np
int2(j)=intall(i,f)
tth(j)=tth0(f)+dtth*(i-1)
j=j-1
enddo
else
do i=1,np
int2(i)=intall(i,f)
tth(i)=tth0(f)+dtth*(i-1)
enddo
endif
write(1,'(a9)')'SETVALUES'
write(1,'(a4,F12.4)')'OMGS',omegasign*omega(f)
write(1,*)
write(1,*)
write(1,'(a14)')'PROTOCOLVALUES'
write(1,'(a5,F12.4)')'T_SAM',tem(f)
write(1,*)
write(1,*)
write(1,'(a13)')'MASTER1VALUES'
write(1,'(a3)')'MM1'
write(1,'(a3,i12)')'MON',nint(mon(f))
write(1,'(a3)')'SL1'
write(1,'(a4,F12.4)')'TTHS',tth0(f)
write(1,'(a4)')'LDET'
write(1,'(a2)')'W1'
do i=1,np,10
write(1,'(x,i4,a1,F7.2,10I12)')i,'/',tth(i),
& (int2(j),j=i,min(np,i+9))
enddo
write(1,'(a18,a27,a15)')'PEAK','BACKGROUND','INTEGRAL'
write(1,'(F12.4,4i12)')0.0,0,0,0,1
write(1,'(a16)')'TIM1 1'
write(1,*)
write(1,*)
write(1,'(a14)')'PROTOCOLVALUES'
write(1,'(a5,F12.4)')'T_SAM',tem(f)
write(1,*)
write(1,*)
enddo
200 continue
write(1,'(a14)')'DATE 01-JAN-01'
write(1,*)
write(1,'(a13)')'TIME 01:01:01'
write(1,*)
close(1)
end

319
pgm/csvsumvar.f Normal file
View File

@ -0,0 +1,319 @@
! Output variables for list of files in comma separated variable format
!
! interactive usage: csvsumvar
! allows specification of output variables, list of files, and output file
!
! non-interactive usage: csvsumvar [list of files] {output filename}
! relies upon environment variables `dat_defspec` and `sumvar` to
! determine which variables are included in output (same as plain sumvar)
! The output filename is optional, if omitted output is sent to STDOUT.
!
! Cobbled together from the guts of sumvar.f by Gregory Tucker -- 2017-11-02
program csvsumvar
! --------------
implicit none
integer nmax
parameter (nmax=10000)
character filelist*2048, files*2048, spec*16, sumvars*256
character var*64, filename*128
integer l, k, km, i, n, pin, pout, lun, iostat
integer first,last
real xval(nmax), yval(nmax), sig(nmax), rmon(nmax)
external list_values, list_vars, list_nix
integer mcols
parameter (mcols=32)
integer ncol, nframes
real cnts, fmt(mcols), vmin(mcols), vmax(mcols)
character line*1024, names(mcols)*32, time*6
character formatted(mcols)*128
common /sum_com/ncol, nframes, cnts, fmt, vmin, vmax
& ,line, names, formatted, time
! call fit_init
call sys_get_cmdpar(files,l) ! l is set by sys_get_cmdpar to the length of returned character variable, but isn't used
call dat_def_options('entry=')
! check if files contains the output filename too
filename=' '
call findfirstlastnonblank(files,first,last)
if (last-first .gt. 0) then
files=files(first:last) ! remove any preceeding or trailing spaces
i=index(files(first:last)," ") ! look for any internal spaces
if (i .gt. 0) then
filename=files(first+i:last) ! after space is filename
files=files(first:first+i-1) ! before space is files specification
endif
endif
if (files .eq. ' ') then
call dat_ask_filelist(filelist, ' ')
if (filelist .eq. ' ') goto 91
call dat_silent
pin=0
pout=0
call dat_open_next(filelist, pin, line, pout
& , list_nix, nmax, n, xval, yval, sig, rmon)
endif
call sys_getenv('dat_defspec', spec)
call sys_getenv('sumvar', sumvars)
if (sumvars .eq. ' ') call sys_getenv('sumvars', sumvars)
if (sumvars .eq. ' ') then
call sys_getenv('sumvar_'//spec, sumvars)
endif
if (sumvars .eq. ' ') then
sumvars=
& 'Numor:5,Date:16,Title:25,Temp:10.3,dTemp:8.3,sMon:10.'
endif
if (files .eq. ' ') then
print *
print *,' Variables listed by default:'
call str_trim(sumvars, sumvars, l)
print '(x,a)',sumvars(1:l)
print *
30 print *,' Enter a new variable list, <ret> for default'
& ,', or ? for help:'
read(*, '(a)', err=91, end=91) line
if (line .eq. '?') then
print *
&,'--------------------------------------------------------------'
print *
&,' You may configure the default with the environment variables'
&,' sumvar or sumvar_',spec
print *
&,' Example (to be typed on the Unix prompt):'
print *
print '(x,3a)'
&,'> setenv sumvars "',sumvars(1:l),'"'
print *
print *
&,' For each column, write the variable name and the column'
&,' width, separated by a colon. For numeric values, give'
&,' also the number of digits after decimal point, separated'
&,' with a point. The columns have to be separated by a comma.'
&,' The column title is right justified, if a point is present.'
print *
print *
&,' List of variables in the first file:'
call dat_silent
pin=0
pout=0
call dat_open_next(filelist, pin, files, pout
& , list_vars, nmax, n, xval, yval, sig, rmon)
call list_vars('*', 0.0)
print *
&,'--------------------------------------------------------------'
goto 30
endif
if (line .ne. ' ') sumvars=line
print *
print *,'Output file name (default: terminal):'
read(*, '(a)', err=91, end=91) filename
else
filelist=files
endif
if (filename .eq. ' ') then
lun=6
else
lun=1
call sys_open(lun, filename, 'w', iostat)
if (iostat .ne. 0) then
print *,'can not open',filename
stop
endif
call findfirstlastnonblank(sumvars,first,last)
print *,"saving output ",sumvars(first:last)
call findfirstlastnonblank(files,first,last)
print *,"from files ",files(first:last)," to ",filename
endif
call str_trim(sumvars, sumvars, last) ! last is the length of sumvars without trailing space(s)
sumvars(min(len(sumvars),last+1):)=','
ncol=0
k=0
line=' '
35 km=index(sumvars(k+1:),',')
if (km .gt. 0) then
if (km .gt. 1 .and. ncol .lt. mcols) then
ncol=ncol+1
var=sumvars(k+1:k+km-1)
i=index(var, ':')
if (i .eq. 0) then
call str_trim(names(ncol), var, n)
fmt(ncol)=16.3
else
call str_trim(names(ncol), var(1:i-1), n)
fmt(ncol)=0
read(var(i+1:),*,err=36) fmt(ncol)
36 if (fmt(ncol) .eq. 0) fmt(ncol)=16.3
endif
call findfirstlastnonblank(names(ncol),first,last)
if (last-first .gt. 0) then
formatted(ncol)='"'//names(ncol)(first:last)//'",' ! stash for output
endif
call str_upcase(names(ncol), names(ncol))
endif
k=k+km
goto 35
endif
38 if (ncol .le. 1) goto 91
call putonline(formatted,ncol,line)
call findfirstlastnonblank(line,first,last)
if (last-first .gt. 1) then
write(lun, '(a)') line(first:last-1) ! cut off the trailing comma
endif
pin=0
pout=0
40 line=' '
call fillspaces(formatted,ncol) ! reset the formatted column strings (only up to the number of columns)
call dat_def_options('entry=*')
call dat_silent
call dat_open_next(filelist, pin, files, pout
& , list_values, nmax, n, xval, yval, sig, rmon) ! this calls subroutine list_values for the pin_th entry of filelist
call putonline(formatted,ncol,line)
call findfirstlastnonblank(line,first,last)
if (last-first .gt. 1) then
write(lun, '(a)') line(first:last-1) ! cut off the trailing comma
endif
if (pin .le. len(filelist)) goto 40
91 end
subroutine list_nix(name, value)
character name*(*)
real value
end
subroutine list_vars(name, value)
character name*(*)
real value
integer l/0/,j
character line*80
save line, l
if (name .eq. 'ShowLevel') return
j=index(name, '=')-1
if (j .le. 0) call str_trim(name, name, j)
if (l+j .ge. 80 .or. name .eq. '*') then
print *,line(1:l)
l=0
endif
if (l .gt. 0) then
line(l+1:l+1)=','
l=l+1
endif
line(l+1:)=name(1:j)
l=min(80,l+j)
end
subroutine list_values(name, value)
character name*(*)
real value
integer i,l,j,first,last
character unam*32, form*8, field*128
real f
integer mcols
parameter (mcols=32)
integer ncol, nframes
real cnts, fmt(mcols), vmin(mcols), vmax(mcols)
character line*1024, names(mcols)*32, time*6
character formatted(mcols)*128
common /sum_com/ncol, nframes, cnts, fmt, vmin, vmax
& ,line, names, formatted, time
if (name .eq. 'ranges') then
nframes=nint(value)
elseif (name .eq. 'Counts') then
cnts=value
elseif (len(name) .gt. 5) then
if (name(1:5) .eq. 'Date=') then
time=name(17:)
endif
endif
j=index(name, '=')
if (j .gt. 1) then ! string
call str_upcase(unam, name(1:j-1))
else
call str_upcase(unam, name)
endif
do i=1,ncol
if (unam .eq. names(i)) then
f=fmt(i)+1
l=int(f+0.001)
if (l .ge. len(field)) l=len(field)
field(1:)=' '
if (j .gt. 0) then ! string
field(1:l)=' '//name(j+1:)
else
if (f-l .lt. 0.04) then
write(form, '(a,I2,a)') '(i',l,')'
write(field(1:l), form) nint(value)
else
write(form, '(a,f5.1,a)') '(f',f,')'
write(field(1:l), form) value
endif
endif
if (field(1:1) .ne. '-') field(1:1)=' '
call findfirstlastnonblank(field,first,last)
formatted(i)='"'//field(first:last)//'",'
endif
enddo
end
subroutine findfirstlastnonblank(field,intf,intl)
character field*(*)
integer intf,intl
intl=LEN(field)
intf=1
if (intl .gt. 0) then
do while (field(intf:intf) .eq. ' ')
intf=intf+1
if (intf .ge. intl) exit
enddo
do while (field(intl:intl) .eq. ' ')
intl=intl-1
if (intl .le. intf) exit
enddo
endif
end
subroutine fillspaces(vecchars,lv)
integer lv
character vecchars(lv)*(*)
integer i
do i=1,lv
vecchars(i)=' '
enddo
end
subroutine putonline(vecchars,lv,outline)
integer lv
character vecchars(lv)*(*), outline*(*)
integer lo,i,first,last,k,thisl
lo=len(outline)
k=0
do i=1,lv
call findfirstlastnonblank(vecchars(i),first,last)
if (last-first .gt. 0) then
if (k .lt. lo) then
thisl=last-first+1
outline(k+1:k+thisl)=vecchars(i)(first:last)
k=k+thisl
endif
endif
if (k .ge. lo) exit ! shortcut if we've run past the end of the outline
enddo
end

97
pgm/datafilepath Executable file
View File

@ -0,0 +1,97 @@
#!/usr/bin/env python3
import os
import sys
import time
USAGE = """
Usage:
datafilepath <proposal> [<instrument>] [<year>]
set current proposal for an instrument for fit
"""
instrument = os.environ.get('dat_defspec', None)
proposal = os.environ.get('dat_proposal', None)
printit = True
filename = '/tmp/.senv_%s.%s' % (os.environ['USER'], os.getppid())
lines = []
envdict = {}
try:
with open(filename, 'r') as f:
for line in f:
if not line.startswith('setenv '):
if line.strip() != '#':
lines.append(line)
continue
head, name, value = line.split()
if value[0] == "'" and value[-1] == "'":
value = value[1:-1]
envdict[name] = value
except FileNotFoundError:
lines = ['test $$ = %s && rm -f %s' % (os.getppid(), filename)]
proposal = os.environ.get('dat_proposal', envdict.get('dat_proposal', None))
if len(sys.argv) > 1:
proposal = sys.argv[1]
elif proposal is None:
if printit:
print(USAGE)
printit = False
proposal = input('proposal: ')
envdict['dat_proposal'] = proposal
instrument = os.environ.get('dat_defspec', envdict.get('dat_defspec', None))
if len(sys.argv) > 2:
instrument = sys.argv[2]
elif instrument is None:
if printit:
print(USAGE)
printit = False
instrument = input('instrument: ')
envdict['dat_defspec'] = instrument
if len(sys.argv) > 3:
envdict['dat_defyear'] = sys.argv[3]
key = 'dat_spec_%s' % instrument
datspec = envdict.get(key, os.environ.get(key, None))
if datspec is None:
if printit:
print(USAGE)
printit = False
datspec = input('file path (containing ****** for numor): ')
elements = []
for spc in datspec.split(','):
res = []
for elm in spc.split('/'):
if elm.startswith(instrument + '%%%%n'):
res[-1] = proposal
res.append(elm)
elements.append('/'.join(res))
datspec = ','.join(elements)
envdict[key] = datspec
with open(filename, 'w') as f:
for key, value in envdict.items():
f.write("setenv %s '%s'\n#%s\n" % (key, value, os.environ.get(key, '')))
f.write('\n'.join(lines))
f.write('\n')
year = envdict.get('dat_defyear', time.strftime('%Y' , time.localtime()))
datspec = datspec.replace('%%%%', year)
if len(sys.argv) < 2:
if printit:
print(USAGE)
printit = False
print('data file path:\n')
last = ''
for element in datspec.split(','):
if '/' not in element:
element = last.rsplit('.', 1)[0] + element
print(element)
last = element

190
pgm/deteff.f Normal file
View File

@ -0,0 +1,190 @@
program deteff
* 1. linearer Fit (A+xB) einer Detektoreichmessung *
* 2. Normierung der Daten mit der verfeinerten Funktion *
* 3. Speicherung im Format fuer deteff.dat *
* 27.4.99 keller, Aenderung 15.7.99,28.9.99 *
* Aenderung 3.11.99: schneidet Punkte die 0 sind weg (HRPT!) *
* 7.3.00, 24.5.02, 9.8.02 *
* *
* > myfit deteff.f *
* > cp a.out deteff *
implicit none
external FIT_LIN_FUN
real par(16),err(16),int(2000),tth(2000),par1,ti,step,tf,lim
integer n,i,nret,l,count
character*36 spec
character*5 flag,flag2
character*78 title
call fit_init
! Function title and parameter names
call fit_userfun('STRAIGHT LINE', fit_lin_fun) ! function title, function
call fit_userpar('Bg(0)') ! first parameter: background at zero
call fit_userpar('dBg/dX') ! second parameter: slope
call fit_dat_options('cal=0') ! turns off calibration of raw data
do i=1,2000
int(i)=0.
enddo
call sys_getenv('dat_defspec',spec)
if (spec.eq.' ') spec='DMC'
call str_trim(spec,spec,l) ! Laenge bestimmen (l)
100 write(*,*)
write(*,'(x,a)')'DMC = 1 / HRPT = 2'
write(*,'(x,3a,$)')'Instrument (default: ',spec(1:l),'): '
read(*,'(a)')flag ! ^ schreibt spec von
! Zeichen 1 bis l
call str_upcase(flag,flag) ! schreibt Inhalt von flag gross
if (flag.eq.'1') flag='DMC'
if (flag.eq.'2') flag='HRPT'
if (flag.ne.' ') then
if (flag.ne.'DMC' .and. flag.ne.'HRPT') goto 100
spec=flag
endif
call sys_setenv('dat_defspec',spec)
C WRITE (*,'(X,A,$)') 'Calibration data files (e.g.: DMC/1999/
C A4-34) : '
C READ (*,'(A)') FILES
C CALL FIT_DAT(FILES)
C call fit_dat(' ')
C call fit_merge(0.02)
call fit_dat_merge(' ',0.02) ! ersetzt fit_dat und fit_merge
call fit_get_array('X',tth,2000,nret)
call fit_get_array('Y',int,2000,nret)
write(*,*)
write(*,'(x,a,$)')'Title of detector efficiency file: '
read(*,'(a)')title
if (title.eq.' ') then
if (nret.eq.400) title='DMC detector efficiency file'
if (nret.eq.1600) title='HRPT detector efficiency file'
endif
if (nret.ne.400) then
if (nret.ne.1600) then
write(*,*)
write(*,*)
write(*,*)
write(*,*)
write(*,*)' **************** WARNING ***************'
write(*,*)
write(*,*)' The number of data points does not match '
write(*,*)' the number of detectors of DMC or HRPT'
write(*,*)
write(*,*)
write(*,'(a,$)')' continue? (y/N): '
read(*,'(a)')flag2
call str_upcase(flag2,flag2)
if (flag2.ne.'Y') then
write(*,'(a)')' program aborted'
goto 102
endif
endif
endif
write(*,*)
write(*,'(x,a,$)')'slope=0 ? (Y/n): '
read(*,'(a)') flag2
call str_upcase(flag2,flag2)
TI=TTH(1)
TF=TTH(NRET)
STEP=(TTH(NRET)-TTH(1))/(NRET-1.)
PAR1=0
DO I=1,NRET
PAR1=PAR1+INT(I)
ENDDO
PAR(1)=PAR1/NRET ! starting value for Bg(0)
PAR(2)=0. ! starting value for slope
ERR(1)=1.
ERR(2)=1.
lim=par(1)/4. ! points below lim are excluded!
call fit_exclude(0.,0.,0.,lim)
CALL FIT_FUN(7,2,PAR,ERR)
if (flag2 .ne. 'N') call fit_fix(2)
CALL FIT_FIT(0)
CALL FIT_FIT(0)
CALL FIT_FIT(0)
CALL FIT_GET_ARRAY('P',PAR,2,N) ! reads fit parameters
CALL FIT_GET_ARRAY('E',ERR,2,N) ! reads parameter errors
OPEN (1,FILE='deteff.dat',STATUS='UNKNOWN')
WRITE (1,'(2A)')'#',TITLE
if (nret.gt.999) write(1,'(I4)')nret
if (nret.lt.1000) write(1,'(I3)')nret
count=0 ! count: # of excluded points
DO 101 I=1,NRET
if (int(i).lt.lim) then
write(1,'(F8.6)')0.0
count=count+1
else
WRITE(1,'(F8.6)')INT(I)/(PAR(1)+((I-1)*STEP+TI)*PAR(2))
endif
101 CONTINUE
CLOSE(1)
call str_trim(spec,spec,l)
WRITE(*,*)
WRITE(*,*)
WRITE(*,*)
WRITE(*,*)
WRITE(*,*)' New detector efficiency file: deteff.dat'
WRITE(*,'(3a)')' Copy this file into the directory /data/
Alnslib/data/',spec(1:l),'/<year>/'
WRITE(*,*)
WRITE(*,*)' Normalization function: P(1)+2th*P(2)'
WRITE(*,'(A,F12.5,A,F10.5,A,F10.5,A,F9.5,A)')' P(1)='
A,PAR(1),'(',ERR(1),'), P(2)=',PAR(2),'(',ERR(2),')'
WRITE(*,*)
if (count.gt.0) write (*,*)' Number of excluded points: ',count
WRITE(*,*)
102 END
real function fit_lin_fun(x,p,n,mode,cinfo)
! -------------------------------------------
implicit none
real x ! x-value
integer n ! number of parameters
real p(n) ! parameters
integer mode ! mode
integer cinfo ! calculation information (see below)
if (mode .eq. 0) then
! Define here your own function
fit_lin_fun=p(1)+x*p(2)
endif
end

203
pgm/deteff2.f Normal file
View File

@ -0,0 +1,203 @@
program deteff
* 1. linearer Fit (A+xB) einer Detektoreichmessung *
* 2. Normierung der Daten mit der verfeinerten Funktion *
* 3. Speicherung im Format fuer deteff.dat *
* 27.4.99 keller, Aenderung 15.7.99,28.9.99 *
* Aenderung 3.11.99: schneidet Punkte die 0 sind weg (HRPT!) *
* 7.3.00,24.5.02,9.8.02 *
* 16.01.03 zolliker (Fragt, ob untergrund flach sein soll) *
* *
* > myfit -o deteff deteff.f *
implicit none
external FIT_LIN_FUN
real par(16),err(16),int(2000),tth(2000),par1,ti,step,tf,lim
integer n,i,nret,l,count
character*36 spec
character*5 flag,flag2
character*78 title
real flat
call fit_init
! Function title and parameter names
call fit_userfun('STRAIGHT LINE', fit_lin_fun) ! function title, function
call fit_userpar('Bg(0)') ! first parameter: background at zero
call fit_userpar('dBg/dX') ! second parameter: slope
call fit_dat_options('cal=0') ! turns off calibration of raw data
do i=1,2000
int(i)=0.
enddo
call sys_getenv('dat_defspec',spec)
if (spec.eq.' ') spec='DMC'
call str_trim(spec,spec,l) ! Laenge bestimmen (l)
100 write(*,*)
write(*,'(x,a)')'DMC = 1 / HRPT = 2'
write(*,'(x,3a,$)')'Instrument (default: ',spec(1:l),'): '
read(*,'(a)')flag ! ^ schreibt spec von
! Zeichen 1 bis l
call str_upcase(flag,flag) ! schreibt Inhalt von flag gross
if (flag.eq.'1') flag='DMC'
if (flag.eq.'2') flag='HRPT'
if (flag.ne.' ') then
if (flag.ne.'DMC' .and. flag.ne.'HRPT') goto 100
spec=flag
endif
write(*,*)
write(*,'(x,a,$)') 'Flat Background [y]'
read(*,'(a)') flat
call str_upcase(flat, flat)
call sys_setenv('dat_defspec',spec)
C WRITE (*,'(X,A,$)') 'Calibration data files (e.g.: DMC/1999/
C A4-34) : '
C READ (*,'(A)') FILES
C CALL FIT_DAT(FILES)
C call fit_dat(' ')
C call fit_merge(0.02)
call fit_dat_merge(' ',0.02) ! ersetzt fit_dat und fit_merge
call fit_get_array('X',tth,2000,nret)
call fit_get_array('Y',int,2000,nret)
write(*,*)
write(*,'(x,a,$)')'Title of detector efficiency file: '
read(*,'(a)')title
if (title.eq.' ') then
if (nret.eq.400) title='DMC detector efficiency file'
if (nret.eq.1600) title='HRPT detector efficiency file'
endif
if (nret.ne.400) then
if (nret.ne.1600) then
write(*,*)
write(*,*)
write(*,*)
write(*,*)
write(*,*)' **************** WARNING ***************'
write(*,*)
write(*,*)' The number of data points does not match '
write(*,*)' the number of detectors of DMC or HRPT'
write(*,*)
write(*,*)
write(*,'(a,$)')' continue? (y/n): '
read(*,'(a)')flag2
call str_upcase(flag2,flag2)
if (flag2.ne.'Y') then
write(*,'(a)')' program aborted'
goto 102
endif
endif
endif
TI=TTH(1)
TF=TTH(NRET)
STEP=(TTH(NRET)-TTH(1))/(NRET-1.)
PAR1=0
DO I=1,NRET
PAR1=PAR1+INT(I)
ENDDO
PAR(1)=PAR1/NRET ! starting value for Bg(0)
PAR(2)=0. ! starting value for slope
ERR(1)=1.
ERR(2)=1.
lim=par(1)/4. ! points below lim are excluded!
call fit_exclude(0.,0.,0.,lim)
CALL FIT_FUN(7,2,PAR,ERR)
if (flat .eq. 'Y') call fit_fix(2) ! fix slope
CALL FIT_FIT(0)
CALL FIT_FIT(0)
CALL FIT_FIT(0)
CALL FIT_GET_ARRAY('P',PAR,2,N) ! reads fit parameters
CALL FIT_GET_ARRAY('E',ERR,2,N) ! reads parameter errors
OPEN (1,FILE='deteff.dat',STATUS='UNKNOWN')
WRITE (1,'(2A)')'#',TITLE
if (nret.gt.999) write(1,'(I4)')nret
if (nret.lt.1000) write(1,'(I3)')nret
count=0 ! count: # of excluded points
DO 101 I=1,NRET
if (int(i).lt.lim) then
write(1,'(F8.6)')0.0
count=count+1
else
WRITE(1,'(F8.6)')INT(I)/(PAR(1)+((I-1)*STEP+TI)*PAR(2))
endif
101 CONTINUE
CLOSE(1)
call str_trim(spec,spec,l)
WRITE(*,*)
WRITE(*,*)
WRITE(*,*)
WRITE(*,*)
WRITE(*,*)' New detector efficiency file: deteff.dat'
WRITE(*,'(3a)')' Copy this file into the directory /data/
Alnslib/data/',spec(1:l),'/<year>/'
WRITE(*,*)
WRITE(*,*)' Normalization function: P(1)+2th*P(2)'
WRITE(*,'(A,F12.5,A,F10.5,A,F10.5,A,F9.5,A)')' P(1)='
A,PAR(1),'(',ERR(1),'), P(2)=',PAR(2),'(',ERR(2),')'
WRITE(*,*)
if (count.gt.0) write (*,*)' Number of excluded points: ',count
WRITE(*,*)
102 END
real function fit_lin_fun(x,p,n,mode,cinfo)
! -------------------------------------------
implicit none
real x ! x-value
integer n ! number of parameters
real p(n) ! parameters
integer mode ! mode
integer cinfo ! calculation information (see below)
if (mode .eq. 0) then
! Define here your own function
fit_lin_fun=p(1)+x*p(2)
elseif (mode .lt. 0) then
! Use this part to do some initialisations.
! (e.g. read files, write out comments on your user function)
! This section is called by FIT_FUN (command FUN)
type *
type *, 'to define your own user function leave FIT and type MYFIT'
type *, 'Example: STRAIGHT LINE'
endif
end

50
pgm/getdatafilepath Executable file
View File

@ -0,0 +1,50 @@
#!/usr/bin/env python3
import os
import sys
import time
from glob import glob
USAGE = """
Usage:
getdatafilepath <instrument> <year> <number>
get datafile path
"""
if len(sys.argv) != 4:
print(USAGE)
sys.exit()
instrument = sys.argv[1]
year = sys.argv[2]
number = int(sys.argv[3])
key = 'dat_spec_%s' % instrument
last = ''
for datspec in os.environ[key].replace('%%%%', year).split(','):
if '/' not in datspec:
datspec = last.rsplit('.', 1)[0]+datspec
last = datspec
for i in range(10,0,-1):
pat = '*' * i
if datspec.find(pat) >= 0:
break
else:
pat = None
if pat:
fmt = '%%.%dd' % len(pat)
datspec = datspec.replace(pat, fmt % number)
if year < '2020':
datspec = datspec.replace('###', '%.3d' % (number // 1000))
if os.path.isfile(datspec):
print(datspec)
break
else:
datspec = datspec.replace('###', '*')
files = glob(datspec)
if len(files) == 1:
print(files[0])
break
else:
print('%s:%s:%d' % (instrument, year, number))

444
pgm/polcal.f Normal file
View File

@ -0,0 +1,444 @@
program polcal
c this program work, because the dat_tasmad_read routine is
c coding the polarisation information into the x-value ip.b
c where i is 1..9 for xx, yx, yz, zy, yy, zy, xz, yz, zz
c p is 1..4 for ++, +-, -+, --
c b is 0 for signal and 1 for background
implicit none
character files*1024
character bfiles*1024
character line*2048
character word*1024
integer l, pos
integer i
real xx(36), yy(36), ss(36)
real cnts(9,4,2), sigma(9,4,2)
integer n
character mukind*20
character single*1024
logical merge,bgr
integer listflag
real numor, mon, lastnumor
integer status
integer iostat
integer summary,sumx,sumy
common summary,sumx,sumy
call sys_get_cmdpar(line, l)
if (line .eq. ' ') then
print *
print *,'polcal calculates polarisation matrices from files ',
1 'measured with the'
print *,'polmat command on TASP/MuPAD'
print *
print *,'Usage:'
print *,
1 'polcal <numors> [-m] [-b <background numors>]'
print *
print *,'Options:'
print *
print *,' -m'
print *,' merge files'
print *,' without this option, for every file a polarisation'
print *,' matrix is calculated'
print *
print *,' -b'
print *,' treat numors given before -b as signal,'
print *,' numors after -b as background.'
print *,' the files are merged even without the -m option.'
print *,' without this option, polcal sorts out automatically'
print *,' signal and background files'
print *
print *,' -f'
print *,' make summary files fort.11 etc. with the'
print *,' matrix elements'
print *
print *,' -f1213'
print *,' make a summary of Pxy vs Pxz (output file fort.1)'
print *
goto 9
endif
c Argument processing
pos=1
files=' '
merge=.false.
summary=0
bgr=.false.
call str_get_word(line, pos, word)
1 do while (word .ne. ' ')
if (word .eq. '-b') then
call str_get_word(line, pos, bfiles)
bgr=.true.
merge=.true.
elseif (word .eq. '-m') then
merge=.true.
elseif (word(1:2) .eq. '-f') then
if (word(3:) .eq. ' ') then
summary=1
else
summary=2
sumx=0
sumy=0
read(word(3:4), *, iostat=iostat) sumx
read(word(5:6), *, iostat=iostat) sumy
endif
else
if (files .eq. ' ') then
files = word
else
call str_trim(files, files, l)
if (l .lt. len(files) - 1) then
l=l+1
files(l:l)=','
files(l+1:) = word
endif
endif
endif
call str_get_word(line, pos, word)
enddo
call sys_setenv('dat_defspec','TASP')
call fit_init_silent
call clr_me(cnts)
call clr_me(sigma)
if (merge) then
if (bgr) then
call fit_dat_silent
call fit_dat(files)
call fit_merge(0.2) ! merge signal and bgr
call fit_get_real('Monitor', mon)
call fit_get_array('X', xx, 36, n)
call fit_get_array('Y', yy, 36, n)
call fit_get_array('S', ss, 36, n)
call fill_me(cnts, xx, yy, n, 1) ! 1 = force to signal
call fill_me(sigma, xx, ss, n, 1)
call calc_pol(cnts, sigma, status)
if (status .eq. 0) then
print *,'NO DATA'
goto 9
else
call info_line(files, 'S', 1)
endif
call fit_dat_silent
call fit_dat(bfiles)
call fit_merge(0.2) ! merge signal and bgr
call fit_mon(mon)
call fit_get_array('X', xx, 36, n)
call fit_get_array('Y', yy, 36, n)
call fit_get_array('S', ss, 36, n)
call fill_me(cnts, xx, yy, n, 2) ! 2 = force to bgr
call fill_me(sigma, xx, ss, n, 2)
call calc_pol(cnts, sigma, status)
if (status .eq. 0) then
print *,'NO DATA'
else
call info_line(bfiles, 'B', 2)
endif
else
call fit_dat_silent
call fit_dat(files)
call fit_merge(0.01) ! do not merge signal and bgr
call fit_get_array('X', xx, 36, n)
call fit_get_array('Y', yy, 36, n)
call fit_get_array('S', ss, 36, n)
call fill_me(cnts, xx, yy, n, 0)
call fill_me(sigma, xx, ss, n, 0)
call calc_pol(cnts, sigma, status)
if (status .eq. 0) then
print *,'NO DATA'
else
call info_line(files, 'S', 1)
if (status .eq. 2) call info_line(files, 'B', 1)
endif
endif
else
listflag=0
lastnumor = -1
do i=1,99999
call fit_dat_silent
call fit_dat_next(files, listflag)
if (listflag .eq. 0) goto 9
mukind=' '
call fit_get_str('mukind', l, mukind)
if (mukind .ne. 'background') then
call clr_me(cnts)
call clr_me(sigma)
if (mukind .eq. ' ') goto 19
endif
call fit_get_array('X', xx, 36, n)
call fit_get_array('Y', yy, 36, n)
call fit_get_array('S', ss, 36, n)
call fill_me(cnts, xx, yy, n, 0)
call fill_me(sigma, xx, ss, n, 0)
call calc_pol(cnts, sigma, status)
if (status .eq. 0) goto 19
call fit_get_real('Numor', numor)
if (mukind .eq. 'background') then
if (lastnumor .eq. -1) then
print *,'WARNING: background only'
call cvtnumor(single, numor)
call info_line(single, ' ', 1)
else
call cvtnumor(single, lastnumor)
call cvtnumor(single, numor)
call info_line(single, 'B', 2)
endif
else
call cvtnumor(single, numor)
call info_line(single, ' ', 1)
lastnumor=numor
endif
19 continue
enddo
endif
9 end
subroutine cvtnumor(result, numor)
character result*(*)
real numor
integer l
write(result,'(f10.0)') numor
call str_first_nonblank(result, l)
result = result(l:9)
end
subroutine info_line(file, type, prthold)
character file*(*), type*(*)
integer prthold
character line1*132/' '/, line2*132/' '/
real vmin(5), vmax(5), mean(5), diff(5)
integer i,l
character line*132, label*4
logical secondline
if (prthold .eq. 2) then
if (line1(1:3) .eq. ' ') line1(1:3)='sig'
call str_trim(line1, line1, l)
print '(x,a)',line1(1:l)
call str_trim(line2, line2, l)
if (l .gt. 1) print '(x,a)',line2(1:l)
endif
do i=1,5
vmin(i)=0
vmax(i)=0
enddo
if (type .eq. 'B') then
call meta_real_range('QH', vmin(1), vmax(1))
call meta_real_range('QH_B', vmin(1), vmax(1))
call meta_real_range('QK', vmin(2), vmax(2))
call meta_real_range('QK_B', vmin(2), vmax(2))
call meta_real_range('QL', vmin(3), vmax(3))
call meta_real_range('QL_B', vmin(3), vmax(3))
call meta_real_range('EN', vmin(4), vmax(4))
call meta_real_range('EN_B', vmin(4), vmax(4))
call meta_real_range('TEMP', vmin(5), vmax(5))
call meta_real_range('TEMP_B', vmin(5), vmax(5))
label='bgr'
else
call meta_real_range('QH', vmin(1), vmax(1))
call meta_real_range('QH_S', vmin(1), vmax(1))
call meta_real_range('QK', vmin(2), vmax(2))
call meta_real_range('QK_S', vmin(2), vmax(2))
call meta_real_range('QL', vmin(3), vmax(3))
call meta_real_range('QL_S', vmin(3), vmax(3))
call meta_real_range('EN', vmin(4), vmax(4))
call meta_real_range('EN_S', vmin(4), vmax(4))
call meta_real_range('TEMP', vmin(5), vmax(5))
call meta_real_range('TEMP_S', vmin(5), vmax(5))
if (type .eq. 'S') then
label='sig'
else
label=' '
endif
endif
do i=1,5
mean(i) = 0.5 * (vmin(i) + vmax(i))
diff(i) = 0.5 * (vmax(i) - vmin(i))
enddo
! temperature tolerance 10 %
secondline = (diff(5) .gt. mean(5) * 0.1)
! q tolerance 0.003
do i=1,3
if (diff(i) .gt. 0.003) secondline = .true.
enddo
! en tolerance 0.01
if (diff(4) .gt. 0.01) secondline = .true.
call str_trim(file, file, l)
write(line1, '(2a,3f8.3,'' en:'',f8.2,'' T:'',f8.3,2a)')
1 label, 'q:', mean, ' file(s): ',file(1:l)
line2=' '
if (secondline) then
line=' '
do i=1,5
if (i .eq. 4) then
write(line(i*8-7:i*8), '(f8.2)') diff(i)
else
write(line(i*8-7:i*8), '(f8.3)') diff(i)
endif
enddo
write(line2,'(7a)') ' +/-',line(1:24),' +/-',line(25:32)
1 ,' +/-',line(33:40),' <-- mixed values!!!'
endif
if (prthold .gt. 0) then
call str_trim(line1, line1, l)
print '(x,a)',line1(1:l)
call str_trim(line2, line2, l)
if (l .gt. 1) print '(x,a)',line2(1:l)
endif
end
subroutine calc_pol(cnts, sigma, status)
implicit none
real cnts(9,4,2), sigma(9,4,2)
integer status
integer i,i1,i2,k,ip,im
real sum2, d2, sum, pij, dpij2, c1, c2, sq1, sq2
character line*80
real pm(3,4), sm(3,4)
logical done,bgr,matoutput
integer l
integer summary,sumx,sumy
common summary,sumx,sumy
real numor
status=0
matoutput = .false.
c k=1: normal polarity, k=2: NEG. polarity
do k=1,2
done = .false.
bgr = .false.
ip=k*2-1
im=k*2
do i1=1,3
sum2 = 0
d2 = 0
line=' '
do i2=1,3
i = (i1-1)*3 + i2
if (cnts(i,ip,2) .gt. 0 .or. cnts(i,im,2) .gt. 0) status=2
c1 = cnts(i, ip, 1) - cnts(i, ip, 2)
c2 = cnts(i, im, 1) - cnts(i, im, 2)
sq1 = sigma(i, ip, 1)**2 + sigma(i, ip, 2)**2
sq2 = sigma(i, im, 1)**2 + sigma(i, im, 2)**2
sum = c1 + c2
if (sum .eq. 0 .or.
1 cnts(i, ip, 1) .eq. 0 .and. cnts(i, im, 1) .eq. 0) then
pij=0
dpij2 = 1
else
done = .true.
pij = (c1 - c2) / sum
dpij2 = ((1-pij)/sum) ** 2 * sq1
dpij2 = dpij2 + ((1+pij)/sum) ** 2 * sq2
endif
pm(i1, i2) = pij
sm(i1, i2) = sqrt(dpij2)
sum2 = sum2 + pij*pij
d2 = d2 + dpij2 * pij * pij
enddo
pm(i1,4) = sqrt(sum2)
if (sum2 .eq. 0) then
sm(i1,4)=1
else
sm(i1,4) = sqrt(d2/sum2)
endif
enddo
if (done) then
matoutput = .true.
if (status .eq. 0) status=1
print *,
1'------------------------------------------------------'
call fit_get_str('Title', l, line)
if (k .eq. 2) then
print *,'NEG. polarity ',line(1:l)
else
print *,'normal polarity ',line(1:l)
endif
print *,' pix sigma piy sigma piz sigma'
1, ' |Pi| sigma'
do i1=1,3
line=' '
if (summary .eq. 1) call fit_get_real('numor', numor)
do i2=1,4
if (pm(i1, i2) .ne. 0 .or. sm(i1, i2) .ne. 1.0) then
write(line(i2*20-19:i2*20), '(2f7.3)') pm(i1, i2), sm(i1, i2)
endif
if (summary .eq. 1) then
write(i1*10+i2,*) numor, pm(i1,i2), sm(i1,i2)
endif
enddo
print *,line(1:78)
if (summary .eq. 2) then
write(1,*) pm(sumx/10, mod(sumx,10))
1 , pm(sumy/10, mod(sumy,10)),sm(sumy/10,mod(sumy,10))
endif
enddo
endif
enddo
if (.not. matoutput) then
print *,'WARNING: zero count matrix can not be calculated'
endif
end
subroutine clr_me(values)
real values(9,4,2)
integer i,j,k
do k=1,2
do j=1,4
do i=1,9
values(i,j,k)=0
enddo
enddo
enddo
end
subroutine fill_me(values, xx, yy, n, mode)
implicit none
integer n
integer mode
real values(9,4,2), xx(n), yy(n)
integer i,j,k,m,dbl
dbl=0
do m=1,n
i = nint(xx(m))
if (mode .ne. 0) then
k = mode
else if (abs(xx(m)-i) .lt. 0.05) then
k = 1
else
k = 2
endif
j=mod(i,10)
i=i/10
if (i .gt. 0 .and. i .le. 9 .and. j .gt. 0 .and. j .le. 4) then
if (values(i,j,k) .ne. 0) then
dbl=1
endif
values(i,j,k) = yy(m)
endif
enddo
if (dbl .ne. 0) then
print *,'WARNING: duplicate points skipped'
endif
end

64
pgm/subit.f Normal file
View File

@ -0,0 +1,64 @@
program subit
* ~= old changei
* range and steps of file2 are interpolated according to file1;
* file2 is scaled with factor mon1/mon2
* 23.4.99 keller, modified 7.3.00
*
* > myfit subit.f
* > cp a.out subit
implicit none
real const
character*78 file1,file2,file3,title
character*16 cc
write(*,*)
write(*,'(x,a)')'____________________________________'
write(*,*)
write(*,'(x,a)')' File1 - (Mon1/Mon2)*File2 + const.'
write(*,'(x,a)')'____________________________________'
write(*,*)
100 write(*,'(x,a,$)')'File1 / file to add: '
read(*,'(a)')file1
if (file1.eq.' ') goto 100
101 write(*,'(x,a,$)')'File2 / file to subtract: '
read(*,'(a)')file2
if (file2.eq.' ') goto 101
write(*,'(x,a,$)')'Value of additive constant (default: 0): '
read(*,'(a)')cc
if (cc.eq.' ') cc='0.'
read(cc,*)const
write(*,'(x,a,$)')'Name of output file: '
read(*,'(a)')file3
if (file3.eq.' ') file3='diff.dat'
write(*,'(x,a,$)')'Title of output file: '
read(*,'(a)')title
if (title.eq.' ') title='difference pattern'
write(*,*)
write(*,*)
call fit_init
call fit_dat(file1)
call fit_subtract(file2)
C write(*,*)
C call fit_mon(0)
call fit_add(const, 0)
call fit_title(title)
call fit_export(0,'dmc',file3)
write(*,*)
write(*,'(x,2a)')'new file: ',file3
write(*,*)
end

271
pgm/sumvar.f Normal file
View File

@ -0,0 +1,271 @@
program sumvar
! --------------
implicit none
integer nmax
parameter (nmax=10000)
character filelist*2048, files*2048, spec*16, sumvars*256
character var*64, filename*128
integer ls, l, k, km, i, n, pin, pout, lun, iostat
real xval(nmax), yval(nmax), sig(nmax), rmon(nmax)
external list_values, list_vars, list_nix
integer mcols
parameter (mcols=32)
integer ncol, nframes
real cnts, fmt(mcols), vmin(mcols), vmax(mcols)
character line*1024, line2*1024, names(mcols)*32, time*6
common /sum_com/ncol, nframes, cnts, fmt, vmin, vmax
& ,line, line2, names, time
! call fit_init
call sys_get_cmdpar(files,l)
call dat_def_options('entry=')
if (files .eq. ' ') then
call dat_ask_filelist(filelist, ' ')
if (filelist .eq. ' ') goto 91
call dat_silent
pin=0
pout=0
call dat_open_next(filelist, pin, line, pout
& , list_nix, nmax, n, xval, yval, sig, rmon)
endif
call sys_getenv('dat_defspec', spec)
call sys_getenv('sumvar', sumvars)
if (sumvars .eq. ' ') call sys_getenv('sumvars', sumvars)
if (sumvars .eq. ' ') then
call sys_getenv('sumvar_'//spec, sumvars)
endif
if (sumvars .eq. ' ') then
sumvars=
& 'Numor:5,Date:16,Title:25,Temp:10.3,dTemp:8.3,sMon:10.'
endif
if (files .eq. ' ') then
print *
print *,' Variables listed by default:'
call str_trim(sumvars, sumvars, l)
print '(x,a)',sumvars(1:l)
print *
30 print *,' Enter a new variable list, <ret> for default'
& ,', or ? for help:'
read(*, '(a)', err=91, end=91) line
if (line .eq. '?') then
print *
&,'--------------------------------------------------------------'
print *
&,' You may configure the default with the environment variables'
&,' sumvar or sumvar_',spec
print *
&,' Example (to be typed on the Unix prompt):'
print *
print '(x,3a)'
&,'> setenv sumvars "',sumvars(1:l),'"'
print *
print *
&,' For each column, write the variable name and the column'
&,' width, separated by a colon. For numeric values, give'
&,' also the number of digits after decimal point, separated'
&,' with a point. The columns have to be separated by a comma.'
&,' The column title is right justified, if a point is present.'
print *
print *
&,' List of variables in the first file:'
call dat_silent
pin=0
pout=0
call dat_open_next(filelist, pin, files, pout
& , list_vars, nmax, n, xval, yval, sig, rmon)
call list_vars('*', 0.0)
print *
&,'--------------------------------------------------------------'
goto 30
endif
if (line .ne. ' ') sumvars=line
print *
print *,'Output file name (default: terminal):'
read(*, '(a)', err=91, end=91) filename
if (filename .eq. ' ') then
lun=6
else
lun=1
call sys_open(lun, filename, 'w', iostat)
if (iostat .ne. 0) then
print *,'can not open',filename
stop
endif
endif
else
filelist=files
lun=6
endif
call str_trim(sumvars, sumvars, ls)
sumvars(min(len(sumvars),ls+1):)=','
ncol=0
k=0
l=0
line=' '
35 km=index(sumvars(k+1:),',')
if (km .gt. 0) then
if (km .gt. 1 .and. ncol .lt. mcols) then
ncol=ncol+1
var=sumvars(k+1:k+km-1)
i=index(var, ':')
if (i .eq. 0) then
call str_trim(names(ncol), var, n)
fmt(ncol)=16.3
else
call str_trim(names(ncol), var(1:i-1), n)
fmt(ncol)=0
read(var(i+1:),*,err=36) fmt(ncol)
36 if (fmt(ncol) .eq. 0) fmt(ncol)=16.3
endif
i=int(fmt(ncol)+0.001)
if (index(var, '.') .eq. 0) then ! left just
line(l+1:l+i)=names(ncol)
else
line(l+max(0,i-n)+1:l+i)=names(ncol)
endif
call str_upcase(names(ncol), names(ncol))
l=l+i+1
endif
k=k+km
goto 35
endif
38 if (l .le. 1) goto 91
l=l-1
print *
write(lun, '(x,a)') line(1:l)
do i=1,l
line(i:i)='-'
enddo
write(lun, '(x,a)') line(1:l)
pin=0
pout=0
40 line=' '
line2=' '
call dat_def_options('entry=*')
call dat_silent
call dat_open_next(filelist, pin, files, pout
& , list_values, nmax, n, xval, yval, sig, rmon)
call str_trim(line, line, l)
if (line(1:l) .ne. ' ') then
write(lun, '(a)') line(1:l)
if (line2(1:l) .ne. ' ')
& write(lun, '(a)') line2(1:l)
endif
if (pin .le. len(filelist)) goto 40
91 end
subroutine list_nix(name, value)
character name*(*)
real value
end
subroutine list_vars(name, value)
character name*(*)
real value
integer l/0/,j
character line*80
save line, l
if (name .eq. 'ShowLevel') return
j=index(name, '=')-1
if (j .le. 0) call str_trim(name, name, j)
if (l+j .ge. 80 .or. name .eq. '*') then
print *,line(1:l)
l=0
endif
if (l .gt. 0) then
line(l+1:l+1)=','
l=l+1
endif
line(l+1:)=name(1:j)
l=min(80,l+j)
end
subroutine list_values(name, value)
character name*(*)
real value
integer k,i,l,j
character unam*32, form*8, field*128
real f
integer mcols
parameter (mcols=32)
integer ncol, nframes
real cnts, fmt(mcols), vmin(mcols), vmax(mcols)
character line*1024, line2*1024, names(mcols)*32, time*6
common /sum_com/ncol, nframes, cnts, fmt, vmin, vmax
& ,line, line2, names, time
if (name .eq. 'ranges') then
nframes=nint(value)
elseif (name .eq. 'Counts') then
cnts=value
elseif (len(name) .gt. 5) then
if (name(1:5) .eq. 'Date=') then
time=name(17:)
endif
endif
j=index(name, '=')
if (j .gt. 1) then ! string
call str_upcase(unam, name(1:j-1))
else
call str_upcase(unam, name)
endif
k=0
do i=1,ncol
f=fmt(i)+1
l=int(f+0.001)
if (l .ge. len(field)) l=len(field)
if (unam .eq. names(i)) then
if (j .gt. 0) then ! string
field(1:l)=' '//name(j+1:)
else
if (f-l .lt. 0.04) then
write(form, '(a,I2,a)') '(i',l,')'
write(field(1:l), form) nint(value)
else
write(form, '(a,f5.1,a)') '(f',f,')'
write(field(1:l), form) value
endif
endif
if (field(1:1) .ne. '-') field(1:1)=' '
if (line(k+1:k+l) .eq. ' ') then
line(k+1:k+l)=field(1:l)
vmin(i)=value
vmax(i)=value
elseif (j .eq. 0) then ! numeric
if (line(k+1:k+l) .ne. field(1:l)) then
if (value .gt. vmax(i)) then
line2(k+1:k+l)=field(1:l)
elseif (value .lt. vmin(i)) then
if (line2(k+1:k+l) .eq. ' ')
& line2(k+1:k+l)=line(k+1:k+l)
line(k+1:k+l)=field(1:l)
endif
endif
elseif (line(k+1:k+l) .ne. field(1:l)) then ! string
line2(k+1:k+l)=field(1:l)
endif
! goto 39
endif
k=k+l
if (k .gt. len(line)) goto 39
enddo
39 continue
end

368
pgm/trics_ccl.f Normal file
View File

@ -0,0 +1,368 @@
program TriCS_CCL
c -----------------
c
c fits data from ccl-files and write *.col file for upals
c and rafin.dat file for position refining
c
c replaces "none"
c 8.5.99/21.6.99/15.7.99 Juerg Schefer
c 29.11.99: Lorentz-Korrektur SJ33
c 10.4.2000: flat background SJ33
c 31.10.2000: transfered to UNIX ZO33
c 22.11.2000: problem with printing is fixed
c 02.02.01: h,k,l may be real ZM33
c 17.06.2010: Lorentz correction for tilt Geometry, SJ33
c
c link ccl,fit4_shr/opt ! attention: check for last fit_n
c
implicit none
integer np_max
parameter (np_max=1000)
real output(20),th2,omega_cal,omega_fit,chi,phi,yint,yy1,
* dint,delta,yoverall,h,k,l,s,temperature,range
real omega_err
real output2(20), xx(np_max),lor_cor,fwhm,radian,degrees
real bgr, wmult
logical plot,iexp,flat_backgr
integer lorentz,comens ! SJ33, June 2010
integer next_flag
integer iall,iincom,icom,icenter
character*1 answer,hard
character*128 input_files
character*128 output_file1
character*128 output_file2
character*128 output_file3 ! SJ33, May 2012
character*128 output_file4 ! SJ33, May 2012
character*16 out
character*2 off,weak
character*30 hkl
character*12 hkl_int
character*18 hkl_float
character*24 datime
integer ldt
integer ntyp,i,j,numor,ii,iout,np
radian=3.14159265/180.00
degrees=1./radian
write(*,1000)
1000 format (/,' FIT CCL Files: Version 2.08, update Jun. 21, 2010',
* //,' Data processing of files *.ccl from TriCS single'
* ,' detector mode')
call sys_setenv('DAT_DEFSPEC', 'TRICS')
call dat_ask_filelist(input_files, ' ')
output_file1=input_files
i=index(output_file1, '.')
if (i .eq. 0) i=index(output_file1, '[')
if (i .eq. 0) i=index(output_file1, ',')
if (i .eq. 0) i=index(output_file1, ' ')
do j=i-1,1,-1
if (output_file1(j:j) .eq. '/') then
goto 1002
endif
enddo
j=0
1002 if (i .gt. j+1) then
output_file2=output_file1(j+1:i-1)//'_rafin.dat'
output_file1=output_file1(j+1:i-1)//'.col'
output_file3=output_file1(j+1:i-1)//'.comm'
output_file4=output_file1(j+1:i-1)//'.incomm'
else
output_file2='rafin.dat'
output_file1='upals.col'
endif
c
write(*,1004)
1004 format (/,' function type to be used (0=gauss[def],6=strange)',
* ' typ = ',$)
read (5,'(i1)') ntyp
if (ntyp .eq. 6) then
write(*,'(/,'' width factor [1.0] = '',$)')
read(5,'(f20.0)') wmult
if (wmult .eq. 0.0) wmult=1.0
else
wmult=1.0
ntyp=0
endif
write(*,1013)
1013 format (/,' Monitor to be standardized , monitor=',$)
read (5,'(f20.0)') yoverall
if (yoverall.le.1.1) yoverall = 100000.
write(*,1015)
1015 format (/,
* ' plots (answer=n [no=def], y [yes,terminal], h [hard] ',$)
read (5,'(a1)') answer
plot = (answer.eq.'y' .or. answer .eq.'h')
if (plot) then
hard='y'
if (answer.eq.'y') hard='n'
endif
write(*,1019)
1019 format (' Flat Background (y/n, default=y) : ',$)
read (5,'(a1)')answer
flat_backgr = (answer.ne.'n' .and. answer .ne.'N')
if (ntyp .eq. 0) then
write(*,1017)
1017 format
* (//,' output intensities: 0=experimental (def), 1=gaussian ',$)
read (5,'(i1)') Iout
iexp= (iout.eq.0)
else
iexp= .true.
endif
if (iexp) then
out='experimental '
else
out='gaussian '
end if
write(*,1018)
1018 format (' Lorentz-Correction to be applied (0 = 4-circle-geometry(default), 1 = tilt-geometry, 2 = not applied) ?: ',$)
read (5,'(I1)') lorentz ! SJ33, June 2010, tilt option added (3 options now, def=0)
if (lorentz.ne.1 .and. lorentz.ne.2) lorentz=0 ! SJ33, June 2010
write(*,1011) input_files,ntyp,wmult,
* output_file1,output_file2,out,yoverall,flat_backgr,lorentz
1011 format (/,' ',78('-'),/,' input from file(s) :',A30,/,
* ' function type ',i3,' width factor ',f6.3,//,
* ' output: for UPALS :',A50,/,
* ' for RAFIN :',A50,/,
* 1X,A16,' intensities used'/,
* ' monitor: ',f12.1,/,
* ' Flat Background (yes/no): ',L33,/,
* ' Lorentz-Correction (options: 0 = 4-circle-mode,',
* ' 1 = tilt-mode, 2 = none)',/,
* ' applied option No. ',i1,/,
* ' No. 0 Icor=Iobs*sin(2theta)',/,
* ' No. 1 Icor=Iobs*sin(Gama)*cos(nu)',/,
* ' ',78('-'),/,' hit return to start ',$)
c
read (5,'(i1)') ii
C if (ii.eq.1) goto 504
c
if (ntyp.ne.0 .and. ntyp.ne.6) ntyp = 0
c
c this ends the input for the program, the rest goes automatic
c ------------------------------------------------------------
if (plot) then
call sys_setenv('CHOOSER_PAN','9') ! 9 plots per page
end if
c
c loop over all data following:
iall =0
iincom =0
icom =0
icenter =0
open (unit=1,file=output_file1,status='unknown')
open (unit=2,file=output_file2,status='unknown')
open (unit=3,file=output_file3,status='unknown')
open (unit=4,file=output_file4,status='unknown')
c write headers for fullprof
c write (3,1027)9.99,0,1,1,0.00,0.00,0.00
c write (4,1028)9.99,0,1,1,0.00,0.00,0.00
c1027 format (' title',/,22H(I6,3I10,2F10.2,4F8.2), /,F7.4,i5,i6,/,i1,3f5.2)
c1028 format (' title',/,24H(I6,3F10.4,2F10.2,4F8.2),/,F7.4,I5,i6,/,i1,3f5.2)
next_flag=0 ! start flag
i=0
call fit_init
c
c ------------------------------------------------------ start loop --
1500 continue
call fit_dat_next(input_files, next_flag)
if (next_flag .eq.0) goto 2222 ! last scan of last file read
i=i+1
call fit_mon(yoverall)
C set limits if peak to narrow:
call fit_get_array('P', output, 20, ii)
call fit_get_array('X', xx, np_max, np)
c get information out of title:
call fit_get_real('two_theta',th2)
call fit_get_real('omega',omega_cal)
call fit_get_real('chi',chi)
call fit_get_real('phi',phi)
call fit_get_real('h',h)
call fit_get_real('k',k)
call fit_get_real('l',l)
call fit_get_real('temp',temperature) ! SJ33, Aug.30,1999
call fit_get_str('date', ldt, datime)
cjs type *,' ***** temp=',temperature
numor=i
if (l.eq.88) then
write(*,1007)
1007 format (' data numor not found, exit')
goto 3000
endif
c
if (ntyp .eq. 6) then
call fit_fun(6,1,wmult,0.0) ! select strange
else
call fit_fun(ntyp,0,0.0,0.0) ! select other (guassian)
endif
if (flat_backgr) call fit_set(2,0.,0.,0.,0.) ! flat background
c range = scan with:
range=xx(np)-xx(1)
cjs type *,'******',output(5),output(6)
if (ntyp .ne. 6) then
if (output(6) .lt. 5.0*range/np) then
c set position to center:
call fit_set(3, (xx(np)+xx(1))/2.0, range/np,
& xx(1)+range/6,xx(np)-range/6)
c set fwhm
fwhm = max(0.2,range/5)
c arbitrary limits: minimal 3 steps, maximal 1 /3 range
call fit_set(6,fwhm,fwhm/10.,3*range/np, range/3)
else
fwhm=max(output(6),5*range/np)
call fit_set(6,fwhm,range/np
1 ,3*range/np,range/3)
endif
endif
call fit_fit(0)
c
if (plot) call fit_plot(hard) ! hardcopy / terminal
c
call fit_get_array('P', output, 20, ii)
call fit_get_array('E', output2, 20, ii)
cjs type *,' output ',output
cjs type *,' output2',output2
c
c
c get results now:
if (ntyp.eq.0) then
c function 1 (gauss: use only background, intensity=sum)
omega_fit = output (3)
omega_err = output2(3)
off = ' '
if (iexp) then
yint = output(8)
dint = output2(8)
else
c modified 14.7.99 sj33
yint = output(5)
dint = output2(5)
endif
bgr=output(1)
fwhm=output(6)
else
c function 6 (strange)
yint = output(7)
dint = output2(7)
omega_fit = output(3)
omega_err = output2(3)
bgr=output(1)
fwhm=output(4)
end if
c
c make notes for easy data inspections:
delta = abs (omega_cal - omega_fit)
if (delta.ge.0.3) off =' *'
if (delta.ge.0.5) off ='**'
weak = ' '
c
c write on output files now:
lor_cor = 1.00000
c L = 1 / SIN (2-Theta), page 156, Schwarzenbach, EPFL:
c L applies to the calculated value of the intensities
c Ical*L = Iobs
c (measured intensity is always bigger than corrected one)
if (lorentz.eq.0) lor_cor = sin (abs(th2)*radian)
c
c June 2010: SJ33
c tilt angle nu is read-in as chi from file *.col
c correction formula: not used (3.59) on page 154, Schwarzenbach/Chapuis Cristallographie, Presses EPFL ! SJ33, June 2010
c used: Arndt and Wills, L=sin(gamma)*cos(nu), where gamma projection 2-theta, nu tilt
yy1=lor_cor
if (lorentz.eq.1) lor_cor =
* sin(abs(th2)*radian)*cos(abs(chi)*radian)
c * sqrt( (sin(abs(th2)*radian))**2 -(sin(abs(chi)*radian))**2 ) ! SJ33, June 2010
c write (6,*)' chi=',chi,th2,radian,sin(chi*radian),sin(th2*radian)
c write (6,*)' Lorentz=',yy1,lor_cor
c
c
if (abs(nint(h)-h) .gt. abs(h)*1e-4 .or.
& abs(nint(k)-k) .gt. abs(k)*1e-4 .or.
& abs(nint(l)-l) .gt. abs(l)*1e-4) then
write(hkl, '(3(x,f9.4))') h, k, l
write(hkl_float,'(3f6.2)') h, k, l
iincom=iincom+1
iall=iall+1
comens=1 ! SJ33-May 2012
else
write(hkl, '(3(x,i9))') nint(h), nint(k), nint(l)
write(hkl_int,'(3i4)') nint(h), nint(k), nint(l)
iall=iall+1
icom=icom+1 ! SJ33-May 2012
comens=0
endif
c
write (1, 1005) numor,hkl,lor_cor*yint,lor_cor*dint,
& Th2/2.,omega_fit,chi,phi,temperature,yoverall/1000.,off,weak
& ,bgr,fwhm,lor_cor,omega_err,datime(1:ldt)
c
if (comens.eq.0) then
write (3, 1025) numor,hkl_int, lor_cor*yint,lor_cor*dint,
* Th2/2,omega_fit,chi,phi ! SJ33-May 2012
else
write (4, 1026) numor,hkl_float,lor_cor*yint,lor_cor*dint,
* Th2/2,omega_fit,chi,phi
endif ! SJ33-May 2012
1025 format (I6,A12,2F10.2,4f8.2) ! SJ33, nuc
1026 format (I4,A18,2F10.2,4F8.2) ! SJ33 mag
1005 format (I6,a,1x,f9.2,1x,f9.3,f7.2,1x,f8.3,1x,f7.2,1x,f7.2,1x,
& F8.3,1x,F6.0,1x,2A2,1x,f6.1,1x,f5.3,1x,f6.4,1x,f6.3,1x,a)
if (dint.ge.1) then
s = yint/dint
if (s.le.3) weak='w ' ! weak
if (s.le.1) weak='vw' ! very weak
if (s.ge.15 .and. yint.ge.100) then ! write strong hkl to rafin.dat
write (2,1009) hkl,Th2,omega_fit,chi,phi,.2,temperature
icenter=icenter+1
end if
c
1009 format (a,f8.2,f8.3,2f8.2,1x,f5.3,f9.3)
end if
C
goto 1500
c -------------------------------------------------------- end loop --
C
2222 write(*,1006)
1006 format (' Bye bye, normal end of program.')
C
C -------------------------------------------
C error exits here, does not pass label 2222:
3000 continue
close (1)
close (2)
close (3) ! SJ33-May 2012
close (4) ! SJ33-May 2012
c
c writing the end message for the user
write (6,2040)
write (6,2042) input_files(1:60)
write (6,2041) iall,output_file1(1:30),icenter,output_file2(1:30),
* icom,output_file3(1:30),iincom,output_file4
2040 format(///,' trics_ccl prepared the following files for YOU:',//)
2042 format(' TriCS-input-file used:',A60,//)
2041 format(i6,' reflections ',a30,' for JANA2006',/
* ,i6,' positions ',a30,' for rafin (to improve your UB using the dataset)',/
* ,I6,' reflections ',a30,' for Fullprof - commensurate data',/
* ,I6,' reflections ',a30,' for Fullprof - incommensurate data',//)
c
call fit_exit
c
end

260
pgm/tricslog.f Normal file
View File

@ -0,0 +1,260 @@
program trilog_pgm
! ------------------
implicit none
integer nmax
parameter (nmax=10000)
character filelist*2048, files*2048
character trilog*1024, trihead*1024, sumvars*1024
character var*64
integer ls, l, k, km, i, n, pin, pout, j, lhead, ltot
real xval(nmax), yval(nmax), sig(nmax), rmon(nmax)
external list_values, list_vars
integer mcols
parameter (mcols=32)
integer ncol, nframes
real cnts, fmt(mcols)
character line*1024, names(mcols)*32, opt*80, time*6
common /sum_com/ncol, nframes, cnts, fmt, line, names, time
! call fit_init
call sys_setenv('dat_defspec', 'TRICS')
call sys_get_cmdpar(files,l)
call sys_getenv('trilog', trilog)
call sys_getenv('trihead', trihead)
if (trilog .eq. ' ') then
trilog=
& 'dTime:5,stt:7.2,om:7.3,chi:7.2,phi:7.2'
& //',dg1:7.2,dg2:7.2,dg3:7.2,Sum1:8.,Sum2:8.,Sum3:8.'
& //',Temp:8.2,sMon:11.,time:7.,bMon:11.'
endif
if (trihead .eq. ' ') then
trihead='Numor:5,Date:16,Title:60,Sample:20,Owner:20'
endif
if (files .eq. ' ') then
call dat_ask_filelist(filelist, ' ')
if (filelist .eq. ' ') goto 91
print *
print *,'Variables listed by default '
& ,'(configure default with setenv trilog / setenv trihead):'
print *
call str_trim(trihead, trihead, l)
print '(x,a)',trihead(1:l)
30 print *
& ,'enter new header variable list, empty line for default'
& ,', ? for a list of variables:'
read(*, '(a)', err=91) line
if (line .eq. '?') then
call dat_silent
print *
pin=0
pout=0
call dat_set_options(
& '1,512,bank=detector1,entry=frame0000,frame=0')
call dat_open_next(filelist, pin, files, pout
& , list_vars, nmax, n, xval, yval, sig, rmon)
call list_vars('*', 0.0)
print *
goto 30
endif
if (line .ne. ' ') trihead=line
call str_trim(trilog, trilog, l)
print '(x,a)',trilog(1:l)
31 print *
& ,'enter new frame variable list, empty line for default'
& ,', ? for a list of variables:'
read(*, '(a)', err=91) line
if (line .eq. '?') then
call dat_silent
print *
pin=0
pout=0
call dat_set_options(
& '1,512,bank=detector1,entry=frame0000,frame=0')
call dat_open_next(filelist, pin, files, pout
& , list_vars, nmax, n, xval, yval, sig, rmon)
call list_vars('*', 0.0)
print *
goto 31
endif
if (line .ne. ' ') trilog=line
else
filelist=files
endif
call str_trim(sumvars, trihead, ls)
sumvars(min(len(sumvars),ls+1):)=','
ncol=0
k=0
l=0
line=' '
lhead=0
35 km=index(sumvars(k+1:),',')
if (km .gt. 0) then
if (km .gt. 1 .and. ncol .lt. mcols) then
ncol=ncol+1
var=sumvars(k+1:k+km-1)
i=index(var, ':')
if (i .eq. 0) then
call str_trim(names(ncol), var, n)
fmt(ncol)=16.3
else
call str_trim(names(ncol), var(1:i-1), n)
fmt(ncol)=0
read(var(i+1:),*,err=36) fmt(ncol)
36 if (fmt(ncol) .eq. 0) fmt(ncol)=16.3
endif
i=int(fmt(ncol)+0.001)
if (index(var, '.') .eq. 0) then ! left just
line(l+1:l+i)=names(ncol)
else
line(l+max(0,i-n)+1:l+i)=names(ncol)
endif
call str_upcase(names(ncol), names(ncol))
l=l+i+1
endif
k=k+km
goto 35
elseif (lhead .eq. 0) then
call str_trim(sumvars, trilog, ls)
sumvars(min(len(sumvars),ls+1):)=','
k=0
lhead=l
goto 35
endif
38 if (l .le. 1) goto 91
ltot=l-1
trihead=line(1:lhead)
trilog=line(lhead+1:ltot)
pin=0
pout=0
nframes=0
40 line=' '
call dat_silent
call dat_set_options(
& '1,512,bank=detector1,entry=frame0000,frame=0')
call dat_open_next(filelist, pin, files, pout, list_values
& , nmax, n, xval, yval, sig, rmon)
if (n .le. 0) goto 39
print *
print '(x,a)',trihead(1:lhead)
print '(x,a)',line(1:lhead)
print *
print '(x,a)',trilog(1:ltot-lhead)
do i=0,nframes-1
line=' '
! call list_values('Frame', 1.0*i)
do j=1,3
cnts=0
write(opt, '(a,i1,a,i4.4,a,i4)')
& '1,512,bank=detector',j,',entry=frame',i,',frame=',i
call dat_set_options(opt)
call dat_read_again(list_values
& , nmax, n, xval, yval, sig, rmon)
call list_values('Sum'//char(48+j), cnts)
enddo
call list_values('dTime='//time, 0.0)
call str_trim(line, line(lhead+1:ltot), l)
if (line(1:l) .ne. ' ') then
print '(x,a)',line(1:l)
endif
enddo
39 if (pin .le. len(filelist)) goto 40
91 end
subroutine list_vars(name, value)
character name*(*)
real value
integer l/0/,j
character line*80
save line, l
if (name .eq. 'ShowLevel') return
j=index(name, '=')-1
if (j .le. 0) call str_trim(name, name, j)
if (l+j .ge. 80 .or. name .eq. '*') then
print *,line(1:l)
l=0
endif
if (l .gt. 0) then
line(l+1:l+1)=','
l=l+1
endif
line(l+1:)=name(1:j)
l=min(80,l+j)
end
subroutine list_values(name, value)
character name*(*)
real value
integer k,i,l,j,k0
character unam*32, form*8
real f
integer mcols
parameter (mcols=32)
integer ncol, nframes
real cnts, fmt(mcols)
character line*1024, names(mcols)*32, time*6
common /sum_com/ncol, nframes, cnts, fmt, line, names, time
if (name .eq. 'ranges') then
nframes=nint(value)
elseif (name .eq. 'Counts') then
cnts=value
elseif (len(name) .gt. 5) then
if (name(1:5) .eq. 'Date=') then
time=name(17:)
endif
endif
j=index(name, '=')
if (j .gt. 1) then ! string
call str_upcase(unam, name(1:j-1))
else
call str_upcase(unam, name)
endif
k=0
do i=1,ncol
l=int(fmt(i)+0.001)
k0=k+l+1
if (unam .eq. names(i)) then
if (j .gt. 0) then ! string
line(k+1:k+l)=name(j+1:)
else
f=fmt(i)
if (value .lt. 0.0 .and. k .gt. 0) then ! allow minus sign left overlow field
k=k-1
l=l+1
f=f+1
endif
if (f-l .lt. 0.04) then
write(form, '(a,i3,a)') '(i',l,')'
write(line(k+1:k+l), form) nint(value)
else
write(form, '(a,f5.1,a)') '(f',f,')'
write(line(k+1:k+l), form) value
endif
endif
! goto 39
endif
k=k0
if (k .gt. len(line)) goto 39
line(k:k)=' '
enddo
39 continue
end

92
pgm/ufit.f Normal file
View File

@ -0,0 +1,92 @@
program ufit ! change FIT to your own program name
! ------------
!
! Simple user function example (straight line).
!
implicit none
external FIT_ufun ! change FIT_ufun to your own function name
!---
! Welcome message
print '(5(/X,A))'
1,'Program UFIT'
1,'------------'
1,'User function: sum of lorentzian folded with meas. resolution'
!---
! Function title and parameter names
!
call fit_userfun('Quasielastic', fit_ufun) ! function title, function
call fit_userpar('B:Bg(0)') ! first parameter: background at zero
call fit_userpar('D:dBg/dX') ! second parameter: slope
call fit_userpar('S:bg.scale') ! background slope
call fit_userpar('G:fwhm gaussian')
call fit_userpar('P:Pos') ! position
call fit_userpar('I1:IntInt 1') ! 1st lorentzian intensity
call fit_userpar('L1:fwhm L 1') ! 1st lorentzian width
call fit_userpar('I2:IntInt 2') ! 2nd lorentzian intensity
call fit_userpar('L2:fwhm L 2') ! 2nd lorentzian width
call fit_userpar('I3:IntInt 3') ! 3rd lorentzian intensity
call fit_userpar('L3:fwhm L 3') ! 3rd lorentzian width
call fit_main
end
real function fit_ufun(x,p,n,mode,cinfo)
! -------------------------------------------
implicit none
real x ! x-value
integer n ! number of parameters
real p(n) ! parameters
integer mode ! mode
integer cinfo ! calculation information (see below)
integer npnt
parameter (npnt=10000)
real xx(npnt), yy(npnt)
real gg,xp,b,q
integer idx/1/, nb/0/
real voigt
if (mode .eq. 0) then
! Define here your own function
xp=x-p(5)
gg=p(4)
fit_ufun=p(1)+xp*p(2)
1 +p(6)*voigt(xp, gg, p(7))
1 +p(8)*voigt(xp, gg, p(9))
1 +p(10)*voigt(xp, gg, p(11))
if (idx .le. 0 .or. idx .ge. nb) stop 'FIT_UFUN: illegal IDX'
10 if (x .gt. xx(idx+1)) then
if (idx .lt. nb-1) then
idx=idx+1
goto 10
endif
else
20 if (x .lt. xx(idx)) then
if (idx .gt. 1) then
idx=idx-1
goto 20
endif
endif
endif
q=(x-xx(idx))/(xx(idx+1)-xx(idx))
b=yy(idx)*(1-q)+q*yy(idx+1)
fit_ufun=fit_ufun+p(3)*b
elseif (mode .lt. 0) then
call fit_sort(0,0) ! sort data
call fit_get_array('X', xx, npnt, nb)
if (nb .ge. npnt) print *,'background points limit reached:',npnt
idx=1
call fit_get_array('Y', yy, npnt, nb)
endif
end

1
pgm/zm_fit Normal file
View File

@ -0,0 +1 @@
this file is used by config