Initial commit
This commit is contained in:
196
gen/dat_fullp.f
Normal file
196
gen/dat_fullp.f
Normal file
@ -0,0 +1,196 @@
|
||||
subroutine dat_fullp
|
||||
c --------------------
|
||||
|
||||
external dat_fullp_desc
|
||||
external dat_fullp_opts
|
||||
external dat_fullp_read
|
||||
|
||||
integer dtype/0/
|
||||
|
||||
call dat_init_desc(dtype, dat_fullp_desc)
|
||||
call dat_init_opts(dtype, dat_fullp_opts)
|
||||
call dat_init_read(dtype, dat_fullp_read)
|
||||
end
|
||||
|
||||
|
||||
subroutine dat_fullp_desc(text)
|
||||
! -------------------------------
|
||||
character*(*) text ! (out) description
|
||||
|
||||
! type description
|
||||
! ----------------------------------
|
||||
text='FULLP Fullprof output (Prf=3 like for Kaleida)'
|
||||
end
|
||||
|
||||
|
||||
subroutine dat_fullp_opts
|
||||
! -------------------------
|
||||
print '(x,a)'
|
||||
1,'x: xaxis (2theta,d,Q)'
|
||||
end
|
||||
|
||||
|
||||
subroutine dat_fullp_read
|
||||
1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww)
|
||||
! ----------------------------------------------------
|
||||
implicit none
|
||||
|
||||
integer lun ! (in) logical unit number (file will be closed if successful)
|
||||
integer forced ! 0: read only if type is sure; 1: forced read
|
||||
integer nread ! (out) >=0: = number of points read, file closed
|
||||
! -1: not correct type, file rewinded
|
||||
! -2: correct type, but unreadable, file rewinded
|
||||
external putval ! (in) subroutine to put name/value pairs.
|
||||
! for numeric data: call putval('name', value) ! value must be real
|
||||
! for character data: call putval('name=text', 0.0)
|
||||
integer nmax ! max. number of points
|
||||
real xx(*) ! x-values
|
||||
real yy(*) ! y-values
|
||||
real ss(*) ! sigma
|
||||
real ww(*) ! weights (original monitor)
|
||||
|
||||
! local
|
||||
real none
|
||||
parameter (none=-8.7654e29)
|
||||
real x, y4(4), ymax, dmax, shift, lambda, nan_value, diffshift
|
||||
integer i,j,jex,npeak,nphase,npkt,nexcl,ntic(8),nlin(8)
|
||||
real fact
|
||||
integer istyle(5)
|
||||
real excl1(30),excl2(30)
|
||||
character title*132, line*132
|
||||
character xaxis*64
|
||||
|
||||
|
||||
read(lun,'(a)', err=100, end=100) title
|
||||
if (title(1:1) .eq. ' ') title=title(2:)
|
||||
read(lun,*, err=100, end=100) nphase, npkt, lambda
|
||||
if (nphase .gt. 8) goto 100
|
||||
read(lun,*, err=100, end=100) (ntic(j),j=1,nphase)
|
||||
1 ,(nlin(j),j=1,nphase),nexcl
|
||||
do j=1,nphase
|
||||
do i=1,nlin(j)
|
||||
read(lun,*,err=100,end=100) ! skip propagation vectors
|
||||
enddo
|
||||
enddo
|
||||
do j=1,nexcl
|
||||
read(lun,*,err=100,end=100) excl1(min(j,30)), excl2(min(j,30))
|
||||
enddo
|
||||
read(lun,'(a)', err=100, end=100) line
|
||||
i=index(line, 'Yobs')
|
||||
if (i .eq. 0) goto 100
|
||||
i=index(line, 'Ycal')
|
||||
if (i .eq. 0) goto 100
|
||||
i=index(line, 'Backg')
|
||||
if (i .eq. 0) goto 100
|
||||
i=index(line, char(9))
|
||||
if (i .le. 1) goto 100
|
||||
|
||||
call dat_start_options
|
||||
xaxis=' '
|
||||
call dat_str_option('x', xaxis)
|
||||
|
||||
if (line(2:i-1) .eq. '2Theta') then
|
||||
call dat_powder_init(lambda, '2theta', xaxis)
|
||||
if (xaxis .eq. ' ') then
|
||||
call putval('XAxis='//line(2:i-1), 0.0)
|
||||
else
|
||||
call putval('XAxis='//xaxis, 0.0)
|
||||
endif
|
||||
else
|
||||
call dat_powder_init(0.0, ' ', ' ')
|
||||
endif
|
||||
|
||||
npeak=0
|
||||
do j=1,nphase
|
||||
npeak=npeak+ntic(j) ! calc number of peaks
|
||||
enddo
|
||||
|
||||
ymax=0.0
|
||||
nread=npeak+npkt
|
||||
if (nread .ge. nmax) goto 99
|
||||
|
||||
call gra_get_nan_value(nan_value)
|
||||
|
||||
jex=1
|
||||
dmax=-1.0e30
|
||||
do i=1,npkt
|
||||
read(lun,*, err=99, end=99) x,y4
|
||||
if (i .eq. 1) then
|
||||
shift=y4(2)-y4(4)
|
||||
diffshift=y4(3)
|
||||
endif
|
||||
fact=1.0
|
||||
call dat_powder_trf(x, xx(npeak+i), fact)
|
||||
yy(npeak+i)=y4(1)*fact ! obs
|
||||
ss(npeak+i)=1 ! we do not have the error
|
||||
ww(npeak+i)=1
|
||||
ymax=max(ymax,yy(npeak+i))
|
||||
y4(1)=(y4(4)+shift)*fact ! unshifted background
|
||||
y4(2)=y4(2)*fact ! cal
|
||||
y4(3)=(y4(3)-diffshift)*fact ! unshifted diff
|
||||
dmax=max(dmax,y4(3))
|
||||
|
||||
10 if (jex .le. nexcl) then
|
||||
if (x .ge. excl2(jex)) then
|
||||
jex=jex+1
|
||||
goto 10
|
||||
endif
|
||||
if (x .gt. excl1(jex)) then ! value is within excl. region
|
||||
if (yy(nread) .eq. nan_value) goto 15
|
||||
y4(1)=nan_value
|
||||
y4(2)=nan_value
|
||||
y4(3)=nan_value
|
||||
endif
|
||||
endif
|
||||
do j=1,3
|
||||
nread=nread+1
|
||||
if (nread .gt. nmax) then
|
||||
print *,'too much data'
|
||||
goto 99
|
||||
endif
|
||||
xx(nread)=xx(npeak+i)
|
||||
yy(nread)=y4(j)
|
||||
ss(nread)=1
|
||||
ww(nread)=1
|
||||
enddo
|
||||
15 continue
|
||||
enddo
|
||||
do i=1,npeak
|
||||
read(lun,*, err=99, end=99) x, yy(i)
|
||||
call dat_powder_trf(x, xx(i), fact)
|
||||
yy(i)=(yy(i)-ymax/32)*0.5
|
||||
ss(i)=ymax/100
|
||||
ww(i)=1
|
||||
enddo
|
||||
close(lun)
|
||||
shift=-nphase*ymax/32-dmax
|
||||
do i=npeak+npkt+3,nread,3 ! shift diff
|
||||
if (yy(i) .ne. nan_value) then
|
||||
yy(i)=yy(i)+shift
|
||||
endif
|
||||
enddo
|
||||
call fit_dat_table(1,1,npeak)
|
||||
call fit_dat_table(2,1,npkt)
|
||||
call fit_dat_table(3,3,(nread-npeak-npkt)/3)
|
||||
|
||||
call dat_group(1, putval)
|
||||
call putval('Title='//title, 0.0)
|
||||
call putval('lambda', lambda)
|
||||
call putval('Monitor', 0.0)
|
||||
istyle(1)=8
|
||||
istyle(2)=6
|
||||
istyle(3)=-10
|
||||
istyle(4)=-10
|
||||
istyle(5)=-10
|
||||
call fit_style(5, istyle)
|
||||
call fit_legend('|obs|bgr|cal|dif')
|
||||
call fit_colors(999)
|
||||
return
|
||||
|
||||
99 print *,'DAT_FULLP: error during read'
|
||||
nread=-2
|
||||
return
|
||||
|
||||
100 nread=-1
|
||||
rewind lun
|
||||
end
|
||||
Reference in New Issue
Block a user