Initial commit
This commit is contained in:
223
gen/fit_export.f
Normal file
223
gen/fit_export.f
Normal file
@ -0,0 +1,223 @@
|
||||
subroutine fit_export(steparg, typ, file)
|
||||
! -----------------------------------------
|
||||
|
||||
implicit none
|
||||
|
||||
include 'fit.inc'
|
||||
|
||||
character typ*(*), file*(*)
|
||||
real steparg
|
||||
|
||||
integer ntry
|
||||
parameter (ntry=30)
|
||||
|
||||
character date*20, line*80, filename*256, typup*32, instr*32
|
||||
character sample*80
|
||||
real start, step, endr, q0, q1, xv, dq
|
||||
real sum, suml, stp, xi, best, prec
|
||||
|
||||
integer i,l,n,j,dig,k,jj,nbest,i0
|
||||
integer lun/2/
|
||||
integer iran, iostat
|
||||
|
||||
if (typ .eq. ' ') then
|
||||
write (isyswr,'(/X,A,$)') 'Step size (0: automatic):'
|
||||
read(isysrd,'(f40.0)',err=999,end=999) step
|
||||
write (isyswr,'(/X,A,$)') 'Output file type:'
|
||||
read (isysrd, '(A)',err=999,end=999) typup
|
||||
call str_upcase(typup, typup)
|
||||
else
|
||||
step=steparg
|
||||
call str_upcase(typup, typ)
|
||||
endif
|
||||
if (typup .eq. 'D1A') then
|
||||
prec=1.0e-4
|
||||
else ! DMC, HRPT, LNSP
|
||||
prec=1.0e-3
|
||||
endif
|
||||
call fit_merge(step)
|
||||
start=xval(nxmin)
|
||||
endr=xval(nxmax)
|
||||
if (nxmax .le. nxmin .or. endr .eq. start) then
|
||||
write(isyswr,*) 'not enough points to save'
|
||||
goto 99
|
||||
endif
|
||||
if (step .eq. 0) then ! find best step size
|
||||
nbest=0
|
||||
best=1e30
|
||||
iran=12345 ! make random numbers reproducible
|
||||
k=nxmax-nxmin
|
||||
5 do n=k,2*k ! loop over possible values n
|
||||
stp=(endr-start)/n ! step sizes checked between average step size and one half of average
|
||||
if (k .gt. ntry*2) then ! try statistically
|
||||
sum=0
|
||||
suml=ntry*0.15
|
||||
do j=1,ntry
|
||||
iran=mod(iran*3125,524287) ! quick and dirty random number generator
|
||||
i=mod(iran,k)+nxmin+1
|
||||
xi=(xval(i)-start)/stp
|
||||
sum=sum+abs(xi-nint(xi))
|
||||
if (sum .gt. suml) then
|
||||
sum=sum*ntry/j
|
||||
goto 6
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
sum=0
|
||||
suml=(nxmax-nxmin)*0.1
|
||||
do i=nxmin+1,nxmax
|
||||
xi=(xval(i)-start)/stp
|
||||
sum=sum+abs(xi-nint(xi))
|
||||
if (sum .gt. suml) then
|
||||
sum=sum*k/(i-nxmin)
|
||||
goto 6
|
||||
endif
|
||||
enddo
|
||||
sum=sum/suml
|
||||
if (sum .lt. 1.0) then
|
||||
nbest=n
|
||||
goto 7
|
||||
endif
|
||||
6 if (sum .lt. best) then
|
||||
best=sum
|
||||
nbest=n
|
||||
endif
|
||||
|
||||
continue
|
||||
enddo
|
||||
|
||||
7 continue
|
||||
|
||||
if (nbest .eq. 0) stop 'error in FIT_EXPORT'
|
||||
step=(endr-start)/nbest
|
||||
endif
|
||||
if (step .eq. 0) step=1
|
||||
|
||||
if (file .eq. ' ') then
|
||||
write (isyswr,'(/X,A,$)') 'Output file name:'
|
||||
read (isysrd, '(A)',err=999,end=999) filename
|
||||
else
|
||||
filename=file
|
||||
endif
|
||||
|
||||
step=nint(step/prec)*prec ! correct step for output precision
|
||||
print *,'step used: ',step
|
||||
|
||||
i=nxmin
|
||||
n=nint((endr-start)/step)+1
|
||||
if (npkt+n .gt. maxdat) then
|
||||
write(isyswr,*) 'not enough memory to save all points'
|
||||
n=maxdat-npkt
|
||||
endif
|
||||
i=nxmin+1
|
||||
k=1
|
||||
jj=npkt+1
|
||||
if (endr .lt. 0) then
|
||||
k=-1
|
||||
jj=npkt+n
|
||||
endif
|
||||
do j=0,n-1
|
||||
xv=start+j*step
|
||||
do while (xval(i) .lt. xv .and. i .lt. nxmax)
|
||||
i=i+1
|
||||
enddo
|
||||
c cosmetics for x-axis rounding errors
|
||||
q0=(xval(i)-xv)/(xval(i)-xval(i-1))
|
||||
dq=abs(xv*5E-7/(xval(i)-xval(i-1)))
|
||||
if (q0 .lt. dq) then
|
||||
q0=0
|
||||
elseif (q0 .gt. 1-dq) then
|
||||
q0=1
|
||||
endif
|
||||
q1=1-q0
|
||||
YVAL(jj)=YVAL(i-1)*q0+YVAL(i)*q1
|
||||
call cvt_real_str(line(2:8), i0, YVAL(jj), 7,0,0,0)
|
||||
sig(jj)=sig(i-1)*q0+sig(i)*q1
|
||||
jj=jj+k
|
||||
enddo
|
||||
if (k .lt. 0) then
|
||||
start=-xval(nxmax)
|
||||
endif
|
||||
endr=start+(n-1)*step
|
||||
|
||||
if (typup .eq. 'DMC' .or. typup .eq. 'HRPT'
|
||||
1 .or. typup .eq. 'LNSP') then
|
||||
call sys_parse(filename, l, filename, '.dat', 0)
|
||||
|
||||
call sys_open(lun, filename, 'w', iostat)
|
||||
if (iostat .ne. 0) then
|
||||
print *,'Can not open ',filename(1:l)
|
||||
return
|
||||
endif
|
||||
date=' '
|
||||
call sym_get_str('Date', l, date)
|
||||
call sym_get_str('Instrument', jj, instr)
|
||||
if (instr(1:jj) .ne. 'DMC' .and. instr(1:jj) .ne. 'HRPT')
|
||||
1 call str_trim(instr,typup,jj)
|
||||
call sym_get_str('Title', k, line)
|
||||
write(lun,'(3a)') instr(1:jj),', ',line(1:k)
|
||||
|
||||
write (lun,'(a,f9.5,a,f8.3,a,f7.3,3a)')
|
||||
1 'lambda=',wavlen,', T=',temp,', dT=',dtemp
|
||||
1 ,', Date=''',date(1:l),''''
|
||||
|
||||
line(1:1)=' '
|
||||
call cvt_real_str(line(2:), l, ymon, 8, 0, 6, 1)
|
||||
l=l+1
|
||||
|
||||
call sym_get_str('sample', j, sample)
|
||||
if (sample(1:j) .ne. ' ') then
|
||||
call str_trim(line
|
||||
1 , line(1:l)//', sample="'//sample(1:j)//'"', l)
|
||||
endif
|
||||
write(lun,'(3f8.3,a)') start, step, endr, line(1:l)
|
||||
dig=1
|
||||
elseif (typup .eq. 'D1A') then
|
||||
call sys_parse(filename, l, filename, '.d1a', 0)
|
||||
|
||||
call sys_open(lun, filename, 'w', iostat)
|
||||
if (iostat .ne. 0) then
|
||||
print *,'Can not open ',filename(1:l)
|
||||
return
|
||||
endif
|
||||
|
||||
write(lun,'(a,a68)') 'D1A5 Title: ',itit
|
||||
write(lun,*)
|
||||
write(lun,'(a)') itit
|
||||
write(lun,44) n, temp, 0.0, ymon, 0.0
|
||||
44 format(i6,f11.3,f10.3,' 1',2f10.1)
|
||||
write(lun,'(3f10.4)') start, step, endr
|
||||
dig=2
|
||||
else
|
||||
write(isyswr,*) 'data type ',typup, ' not yet implemented'
|
||||
goto 99
|
||||
endif
|
||||
|
||||
l=0
|
||||
line=' '
|
||||
do j=npkt+1,npkt+n
|
||||
call cvt_real_str(line(l+2:l+8), i, YVAL(j), 7,dig-1,0,0)
|
||||
l=l+8
|
||||
if (l .eq. 80) then
|
||||
write(lun,'(a)') line(1:80)
|
||||
l=0
|
||||
endif
|
||||
enddo
|
||||
if (l .gt. 0) write(lun,'(a)') line(1:l)
|
||||
l=0
|
||||
do j=npkt+1,npkt+n
|
||||
call cvt_real_str(line(l+2:l+8), i, sig(j), 7,dig,0,0)
|
||||
l=l+8
|
||||
if (l .eq. 80) then
|
||||
write(lun,'(a)') line(1:80)
|
||||
l=0
|
||||
endif
|
||||
enddo
|
||||
if (l .gt. 0) write(lun,'(a)') line(1:l)
|
||||
call str_trim(fillis, fillis, l)
|
||||
write(lun, '(x,3a)') 'Filelist=''',fillis(1:l),''''
|
||||
call sym_list(lun, 0, 2
|
||||
1,' file monitor instrument title date lambda '
|
||||
1//'temp dtemp sample ')
|
||||
99 close(lun)
|
||||
999 end
|
||||
Reference in New Issue
Block a user