Initial commit

gen/dat_ida.f

@@ -0,0 +1,165 @@
+	subroutine dat_ida
+c	------------------
+
+	external dat_ida_desc
+	external dat_ida_opts
+	external dat_ida_read
+
+	integer dtype/0/
+
+	call dat_init_desc(dtype, dat_ida_desc)
+	call dat_init_opts(dtype, dat_ida_opts)
+	call dat_init_read(dtype, dat_ida_read)
+	end
+
+
+	subroutine dat_ida_desc(text)
+!	-----------------------------
+	character*(*) text  ! (out) description
+
+!             type    description
+!             ----------------------------------
+	text='IDA     IDA output files'
+	end
+
+
+	subroutine dat_ida_opts
+!	-----------------------
+	print '(x,a)'
+	1,'from,to: dataset range'
+	end
+
+
+	subroutine dat_ida_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 i, i1, i2, j, idx, m, j0, ipdp, iset, nspec
+	real x, y, s, z
+	character line*132
+
+	read(lun, '(a)',err=100,end=100) line
+	if (line .ne. 'ASCII-96') goto 100
+1	read(lun, '(a)', err=100, end=100) line
+	if (line(1:4) .ne. 'x') goto 1
+	call putval('XAxis='//line(5:28),0.0)
+	read(lun, '(a)', err=100, end=100) line
+	if (line(1:4) .ne. 'y') then
+	  print *,'missing line starting with "y"'
+	  goto 99
+	endif
+	call putval('YAxis='//line(5:28),0.0)
+	read(lun, '(a)', err=99, end=99) line
+	if (line(1:4) .eq. 'z1') then
+	  call putval('ZAxis='//line(5:28),0.0)
+	  call fit_dat_pdp_idx(line(5:28), ipdp)
+	else
+	  ipdp=0
+	endif
+2	read(lun, '(a)', err=99, end=99) line
+	if (line(1:4) .ne. '&eob') goto 2
+	read(lun, '(a)', err=99, end=99) line
+	if (line(1:5) .eq. '(a80)') then
+	  read(lun, '(a)', err=99, end=99) line
+	  i=index(line,char(0))
+	  if (i .gt. 1) then
+	    call putval('Instrument='//line(1:i-1), 0.0)
+	  endif
+	  read(lun, '(a)', err=99, end=99) line
+	  i=index(line,char(0))
+	  if (i .gt. 2) then
+	    call putval('Title='//line(2:i-1), 0.0)
+	  endif
+	endif
+
+	call dat_start_options
+	i1=0
+	call dat_int_option('from', i1)
+	i2=0
+	call dat_int_option('to', i2)
+
+	if (i2 .eq. 0) then
+	  if (i1 .eq. 0) then
+	    i1=1
+	    i2=999999
+	  else
+	    i2=i1
+	  endif
+	endif
+	call dat_get_index(idx)
+	if (idx .ne. 0) then
+	  i1=i1+idx-1
+	  i2=i1
+	endif
+
+3	read(lun, '(a)', err=99, end=99) line
+	if (line(1:9) .ne. '&spectrum') goto 3
+	j=0
+	iset=1
+	m=0
+4	read(lun, '(a)', err=99, end=99) line
+	if (ipdp .ne. 0) then
+	  read(line, *, err=99, end=99) nspec,z
+	else
+	  read(line, *, err=99, end=99) nspec
+	endif
+
+	j0=j
+	do i=1,nspec
+	  read(lun, *, err=20,end=29) x,y,s
+	  if (s .gt. 0.0 .and. iset .ge. i1) then
+	    if (j .ge. nmax) then
+	      i2=iset
+	      print *,'DAT_IDA: too many data points, truncated'
+	      goto 29
+	    endif
+	    j=j+1
+	    ww(j)=1.0
+	    ss(j)=s
+	    yy(j)=y
+	    xx(j)=x
+	  endif
+20	  continue
+	enddo
+29	if (j .gt. j0) then
+	  m=m+1
+	  if (ipdp .ne. 0) then
+	    call fit_dat_pdp_set(ipdp, m, z)
+	  endif
+	  call fit_dat_table(m, 1, j-j0)
+	endif
+	read(lun, '(a)', err=50, end=50) line
+	if (line(1:9) .eq. '&spectrum' .and. iset .lt. i2) then
+	  iset=iset+1
+	  goto 4
+	endif
+
+50	nread=j	
+	call putval('Monitor', 0.0)
+	close(lun)
+	return
+
+99	print *,'DAT_IDA: error during read'
+98	nread=-2
+	rewind lun
+	return
+
+100	nread=-1
+	rewind lun
+	end