dtc---12-aug-1997--- from Alexander/Major / Now on [GYGAX.DEL.PRESS]

c	ortec2psi.for

	program ortec2psi
c idr 25/7/96
	implicit integer*2 (i-n)
	include 'psi_header.inc'
        character*32 fname
        character*80 line
	record /PSI_HEADER/ psi
	character*3 mon(12)
	character*2 y1,y2
	integer*4 psihist(4096)
	integer*4 MAXREC
	parameter (MAXREC=4096)
	real*8 tres

	data mon/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug',
     . 'Sep','Oct','Nov','Dec'/


10      write(*,100)
100	format(' Enter ORTEC file-name: ',$)
        read(*,99) fname
99      format(A)

        open(unit=41,name=fname,status='old',carriagecontrol='list',
     . err=10)

        read(41,99)line
	call str$trim(line,line,i)
        write(*,98) line(1:i)
98	format(' Programme: ',a)

        read(41,*) psi.nrun
        write(*,97) psi.nrun
97	format(' Run Number: ',i)

        read(41,99) psi.target
        write(*,96) psi.target
96	format(' Sample: ',a)

        read(41,99) psi.orient
        write(*,95) psi.orient
95	format(' Orientation: ',a)

        read(41,99) psi.temp
        write(*,94) psi.temp
94	format(' Temperature: ',a)

        read(41,99) psi.field
        write(*,93) psi.field
93	format(' Field: ',a)

        read(41,99)line
	call str$trim(line,line,i)
        write(*,92) line(1:i)
92	format(' Info1: ',a)

        read(41,99)line
	call str$trim(line,line,i)
        write(*,91) line(1:i)
91	format(' Info2: ',a)

        read(41,99) psi.a62txt
        write(*,90) psi.a62txt
90	format(' Info3: ',a)

        read(41,199)id1,im1,y1,psi.tm1
	read(41,199)id2,im2,y2,psi.tm2
 199	format(i2,x,i2, x,a2,x,a8)
!199	format(i2,x,i2,3x,a2,x,a8)

	write(psi.dt1,900)id1,mon(im1),y1
c NB: We have a Year-2000 problem!!
	write(psi.dt2,900)id2,mon(im2),y2
900	format(i2,'-',a3,'-',a2)

        write(*,89) psi.dt1,psi.tm1
89	format(' Start: ',a9,1x,a8)

        write(*,88) psi.dt2,psi.tm2
88	format(' Stop: ',a9,1x,a8)

        read(41,99)line
	call str$trim(line,line,i)
        write(*,87) line(1:i)
87	format(' Separator: ',a)

        read(41,'(i)')nhist
	if (nhist.gt.16) then
	   write(*,*)'Only taking first 16 histograms!'
	   nhist=16
	endif
	psi.numhis=nhist
	psi.totold=0

        write(*,86) psi.numhis
86	format(' Max Hist: ',i)

        read(41,99)line
	call str$trim(line,line,i)
        write(*,85) line(1:i)
85	format(' Separator: ',a)

	psi.frmat='1F'

c	if (nsclr.gt.6) nsclr=6
c	do 105 i=1,nsclr
c	if (idate1(1).ge.90) then
c	   psi.i4scal(i)=jtsc(2,i)
c	   psi.i4scal(i)=psi.i4scal(i)*65536+jtsc(1,i)
c	else
c	   psi.i4scal(i)=jtsc(1,i)
c	   psi.i4scal(i)=psi.i4scal(i)*65536+jtsc(2,i)
c	endif
c105	psi.scalab(i)=sclbl(i)

!!	do i=0,nhist
!!c Note a programming error here -- too many lines written!
!!	   read(41,99)line
!!c just discard these at present...
!!	end do
	do i=1,nhist
	  read(41,1801) psi.cntold(i), psi.nto(i), psi.ntini(i), 
	1               psi.ntfin(i)
 1801     format(i10, 10x, 3i6)
	enddo
	do i=0,0
          read(41,1801) psi.totold
	enddo

	do i=1,nhist
	   read(41,99) psi.hislab(i)
	end do
c histogram labels
	read(41,99)line
c read extra line from programming error

	do i=1,60
	   read(41,99)line
	end do
c skip extra lines & stuff
	call str$trim(line,line,i)
        write(*,85) line(1:i)

	read(41,'(f)') tres

	i=(tres+0.000001)/0.00015625
c find resolution in LeCroy units...
	j=1
	k=1
20	if (i.ne.j) then
	   j=j+j
	   k=k+1
	   goto 20
	endif
	psi.kdtres=k

	read(41,99)line

	ngood=1
c "good" histogram
	do 500 i=1,nhist
	read(41,'(i)') length

	if (length.eq.0) then
	   psi.numhis=psi.numhis-1
	   goto 500
	endif
	write(*,*)ngood,i,psi.hislab(i)
	psi.hislab(ngood)=psi.hislab(i)
	  psi.cntold(ngood)=psi.cntold(i)
	  psi.nto(ngood)=psi.nto(i)
	  psi.ntini(ngood)=psi.ntini(i)
	  psi.ntfin(ngood)=psi.ntfin(i)
	ngood=ngood+1

	if (psi.lenhis .eq. 0) then
	   psi.lenhis=length
	else
	   if (psi.lenhis.ne.length)
     . stop 'Histograms are of unequal lengths!'
	endif

c      write(*,*)'Histogram',i,length,nt0,nt1,nt2,' ',htitl,psi.cntold(i)
c	psi.totold=psi.totold+psi.cntold(i)
c	psi.nto(i)=nt0-1
c	psi.ntini(i)=nt1-1
c	psi.ntfin(i)=nt2-1
c	psi.hislab(i)=htitl(1)
500	continue

	psi.khidaf=1
	length=psi.lenhis
c
c                           KDAFHI is number of disk records and
c                           LENDAF is the length of each.
c                           NUMDAF is total number of disk records.
c                           KHIDAF is number of histograms in a disk record.
c
        psi.kdafhi = 0	! Calculate how many disk records are needed ..
        psi.lendaf = MAXREC + 1     !  .. for a histogram.
        dowhile (psi.lendaf .gt. MAXREC)
          psi.kdafhi = psi.kdafhi + 1
          psi.lendaf = (psi.lenhis + psi.kdafhi - 1)/psi.kdafhi
        enddo
c
c use David's code...

	psi.numdaf=psi.numhis*psi.kdafhi

	write(fname,'(''R'',BZ,I4.4,''.TX'')')psi.nrun
	open(42,file=fname,form='unformatted',recordtype='segmented',
     . status='new',blocksize=2048)

	len=psi.lendaf

	write(42) psi
	do 700 i=1,psi.numhis
	do 720 j=1,psi.kdafhi
	it1=(j-1)*len+1
	it2=it1+len-1
	if(it2.gt.length) it2=length
	it2=it2-it1+1
	read(41,'(i)')(psihist(k),k=1,it2)
c get data into buffer

	if (it2.lt.len) then
	   do 740 k=it2+1,len
740	   psihist(k)=0
	endif
720	write(42)(psihist(k),k=1,len)
700	continue

	close(42)
	close(41)
	stop
	end