176 lines
4.4 KiB
Fortran
176 lines
4.4 KiB
Fortran
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
|