subroutine dat_frm c ------------------ external dat_frm_desc external dat_frm_opts external dat_frm_read integer dtype/0/ call dat_init_desc(dtype, dat_frm_desc) call dat_init_opts(dtype, dat_frm_opts) call dat_init_read(dtype, dat_frm_read) end subroutine dat_frm_desc(text) ! ----------------------------- character*(*) text ! (out) description ! type description ! ---------------------------------- text='FRM PUMA & PANDA at FRM2 Munich' end subroutine dat_frm_opts ! ----------------------- print '(x,a)' 1,'x: x-axis (default: first column or first variable' 1,' with step in Qscan)' 1,'y: y-axis (default: last column)' 1,'mon: monitor (default: mon1)' end subroutine dat_frm_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 integer mcol parameter (mcol=64) real y,s,r,f,ymon,values(mcol) integer i,j,l,errcnt,ncol integer xcol,ycol,mncol integer iostat character line*1024 character xaxis*16, yaxis*16, moncol*16, col1*16 integer headcnt real qh,qk,ql,en,dh,dk,dl,de headcnt=0 1 read(lun,'(a)',err=100,end=100) line headcnt=headcnt+1 if (line(1:15) .eq. 'filename : ') then goto 1 else if (line(1:15) .eq. 'created at : ') then call putval('Date='//line(16:), 0.0) goto 1 else if (line(1:15) .eq. 'instrument : ') then call putval('Instrument='//line(16:), 0.0) goto 1 else if (line(1:15) .eq. 'user : ') then call putval('User='//line(16:), 0.0) goto 1 else if (line(14:15) .eq. ': ') then goto 1 endif if (headcnt .lt. 3 .and. forced .le. 0) goto 100 call dat_start_options xaxis=' ' call dat_str_option('x', xaxis) yaxis=' ' call dat_str_option('y', yaxis) moncol=' ' call dat_str_option('mon', moncol) if (moncol .eq. ' ') then moncol='mon1' elseif (moncol .gt. '0' .and. moncol .le. '9') then moncol='mon'//moncol(1:) endif 2 read(lun,'(a)',err=100,end=100) line if (line(1:10) .ne. 'scan data:') goto 2 nread=0 errcnt=0 read(lun, '(a)', err=99,end=99) line if (xaxis .eq. ' ') then i = index(line, 'Qscan') if (i .ne. 0 .and. xaxis .eq. ' ') then line=line(i+5:) i=index(line,'(') if (i .ne. 0) line(i:i)=' ' i=index(line,')') if (i .ne. 0) line(i:i)=' ' read(line, *, iostat=iostat) qh,qk,ql,en,dh,dk,dl,de call putval('QH', qh) call putval('QK', qk) call putval('QL', ql) call putval('EN', en) call putval('DQH', qh) call putval('DQK', dk) call putval('DQL', dl) call putval('DEN', de) if (dh .ne. 0) then xaxis='h' elseif (dk .ne. 0) then xaxis='k' elseif (dl .ne. 0) then xaxis='l' elseif (de .ne. 0) then xaxis='E' endif else ! ignore other scan types endif endif read(lun,'(a)',err=99,end=99) line i=1 line(len(line):len(line))=' ' ncol=0 xcol=0 ycol=0 mncol=0 31 do while (line(i:i) .eq. ' ') i=i+1 if (i .gt. len(line)) goto 39 enddo l=i do while (line(i:i) .ne. ' ') i=i+1 enddo if (line(l:i) .eq. ';') goto 31 ncol=ncol+1 if (ncol .eq. 1) col1=line(l:i) if (line(l:i) .eq. yaxis .and. ycol .eq. 0) then ycol=ncol elseif (line(l:i) .eq. xaxis .and. xcol .eq. 0) then xcol=ncol elseif (line(l:i) .eq. moncol .and. mncol .eq. 0) then mncol=ncol endif goto 31 39 if (ycol .eq. 0) then ycol=ncol yaxis=line(l:) endif if (xcol .eq. 0) then xcol=1 xaxis=col1 endif call putval('XAxis='//xaxis, 0.0) call putval('YAxis='//yaxis, 0.0) ! ignore units read(lun, '(a)', err=99,end=99) line ymon=0 l=min(mcol,max(xcol,ycol,mncol)) 40 read(lun,'(a)',end=88,err=88) line if (line(2:5) .eq. '****') goto 88 i=index(line,';') if (i .ne. 0) line(i:i)=' ' read(line,*,err=99,end=99) (values(j),j=1,l) if (nread .ge. nmax) goto 29 if (mncol .eq. 0) then if (ymon .eq. 0) ymon=1. r=ymon else r=values(mncol) if (r .gt. 0) then if (ymon .eq. 0) ymon=r else if (ymon .eq. 0) ymon=1. r=ymon endif endif f=ymon/r if (f .le. 0.0) f=1.0 nread=nread+1 xx(nread)=values(xcol) y=values(ycol) if (y .gt. 0) then s=sqrt(y) ! statistical error of detector else s=1 endif yy(nread)=y*f ss(nread)=s*f ww(nread)=r goto 40 29 print *,'too many points - truncated' 88 close(lun) call putval('NP', nread*1.0) call putval('Monitor', ymon) return 99 nread=-2 rewind lun print *,'DAT_FRM: error during read' call putval('Monitor', 0.0) return 100 nread=-1 rewind lun call putval('Monitor', 0.0) end