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