197 lines
4.7 KiB
Fortran
197 lines
4.7 KiB
Fortran
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
|