Initial commit

pgm/addei.f

@@ -0,0 +1,94 @@
+	program addei
+
+	implicit none
+
+	integer i, n, listflag, l, iostat, numor, j, la, lo
+	character*1024 list
+	character*256 filename
+	character*256 outname
+	character line*256, axis*8
+	real fx,kfix,val,en(999),ei
+	
+	call fit_init
+	
+	list=' '
+	call sys_get_cmdpar(list, l)
+	if (list .eq. ' ') then 
+	  call dat_ask_filelist(list,' ')
+	endif
+	listflag=0
+
+c	treat no more than 9999 files
+	do i=1,9999
+
+	  call fit_dat_options('x=en')
+	  call fit_dat_silent
+	  call fit_dat_next(list,listflag)
+c	exit loop when finished
+	  if (listflag.eq.0) goto 999
+	  call fit_get_real('Numor', val)
+	  numor = val
+	  call fit_get_real('FX', fx)
+	  call fit_get_real('KFIX', kfix)
+	  ei=kfix*kfix*2.072
+	  call fit_get_array('x', en, 999, n)
+	  call fit_get_str('File', l, filename)
+	  do j=l,1,-1
+	    if (filename(j:j) .eq. '/') then
+	      outname=filename(j+1:l)
+	      lo=l-j
+	      goto 200
+	    endif
+	  enddo
+	  outname=filename
+	  lo=l
+200	  continue
+	  call fit_get_str('XAxis', la, axis)
+	  if (axis .ne. 'EN') then
+	    print *,outname(1:lo),'(column EN not found)'
+	    goto 900
+	  endif
+	  call sys_open(1, filename(1:l), 'r', iostat)
+	  if (iostat .ne. 0) then
+	    print *,'can not open ',filename(1:l)
+	    goto 999
+	  endif
+	  
+	  if (outname(lo:lo) .eq. 'c') then
+	    outname(lo:lo) = 't'
+	  else
+	    outname(lo:lo) = 'c'
+	  endif
+	  call sys_open(2, outname(1:lo), 'w', iostat)
+	  if (iostat .ne. 0) then
+	    print *,'can not create ',outname(1:lo)
+	    goto 999
+	  endif
+	  print *,outname(1:lo),' created'
+	  read(1, '(a)', iostat=iostat) line
+	  call str_trim(line, line, l)
+	  do while (iostat .eq. 0 .and. line(1:4) .ne. 'DATA')
+	    write(2,'(a)') line(1:l)
+	    read(1, '(a)', iostat=iostat) line
+	  enddo
+	  read(1, '(a)', iostat=iostat) line
+	  call str_trim(line, line, l)
+	  write(2, '(2a)') line(1:l),'    EI'
+	  call str_trim(line, line, l)
+	  do j=1,n
+	    read(1, '(a)', iostat=iostat) line
+	    if (iostat .ne. 0) goto 900
+	    if (fx .eq. 1) then
+	      write(2,'(a,f10.4)') line(1:l),ei
+	    else
+	      write(2,'(a,f10.4)') line(1:l),ei-en(j)
+	    endif
+	  enddo
+	  close(1)
+	  close(2)
+900	  continue
+	enddo
+
+  999	continue
+
+	end