C----------------------------------------------------------------------
	SUBROUTINE READPHV(dname,pname,filform,nfil,STATUS)
C----------------------------------------------------------------------
C Read in a raw data file in Philips APD 3720 system running under VAX/VMS 
C----------------------------------------------------------------------
	LOGICAL status
	INTEGER nfil
	character*(*) dname,pname,filform
	CHARACTER*6 thisform/'APDVAX'/

	include 'shared$common'
	include '[-.shared]flabel.common'
C
	INTEGER ln,npnt
	character temp*7

	REAL*4 UPKAN,UPCOUNT
	LOGICAL exist

	logical*1 rec1(512),id,irev
	equivalence (rec1(1),irev)
	equivalence (rec1(2),id)

	integer*2 rec1w(256),itype,KV,MA,MM,IFLG,intstd(2),itemp,izp
	integer*2 istrt,ifin,icnt,ianode,ititle(40)
	equivalence (rec1(1),rec1w(1))
	real*4 wavl1
	equivalence (rec1w(2),itype)
	equivalence (rec1w(8),wavl1)
	equivalence (rec1w(10),KV)
	equivalence (rec1w(11),MA)
	equivalence (rec1w(12),MM)
	equivalence (rec1w(13),IFLG)
	equivalence (rec1w(14),intstd(1))
	equivalence (rec1w(16),itemp)
	equivalence (rec1w(17),izp)
	equivalence (rec1w(19),idat)
	equivalence (rec1w(27),istrt)
	equivalence (rec1w(28),ifin)
	equivalence (rec1w(156),ianode)
	equivalence (rec1w(177),ititle)
	integer*2 mpk,ith(51),iwd(51),iht(51),ibk(51),pflg(51)
	integer*2 iang,iss,icntm,ienan,itmp1,itmp2,cnts(250)

	INTEGER NDAT(3),ITIM(3)

C Assume that the read was not successful
	STATUS = .false.

C check the file format qualifier, if one exists
	IF (filform .ne. ' ') THEN
	  I = LENCH(filform)
	  IF (filform(:I) .ne. thisform(:I)) RETURN
	ENDIF
C-------------------------------------------------------------------
C Is there a datafile name?
	IF (dname .eq. ' ') GOTO 201

	count = 0.0
C   First, Does the file exist?
	INQUIRE(FILE=dname,EXIST=exist,NAME=cfilnam(nfil),defaultfile='.rd')
	IF (.not. exist) goto 111
C if the file can be opened with recl=128 it is very likely to be APD 3720
	OPEN(UNIT=IN,FILE=cfilnam(nfil),TYPE='OLD',ERR=111,
	1	readonly,shared,ACCESS='DIRECT',RECL=128,
	2	FORM='UNFORMATTED',RECORDTYPE='FIXED')

	READ(IN,rec=1,err=111) rec1w
	IF (IREV .ne. '2' .or. ID .ne. 'D' .or. itype .ne. 'DR') goto 111
C read the title
	DO I=1,40
	  j = 2*I - 1
	  WRITE(ATITLE(nfil)(j:j+1),'(a2)') ititle(I)
	enddo
c DECODE THE ANODE
	IF (ianode .eq. 1) then
	  IRAD(nfil) = 'CU'
	ELSEIF (ianode .eq. 2) then
	  IRAD(nfil) = 'MO'
	ELSEIF (ianode .eq. 3) then
	  IRAD(nfil) = 'CO'
	ELSEIF (ianode .eq. 4) then
	  IRAD(nfil) = 'FE'
	ELSEIF (ianode .eq. 5) then
	  IRAD(nfil) = 'CR'
	ENDIF
	CALL WAVESET(IRAD(nfil),WAVE(nfil),WKA1(nfil),WKA2(nfil),*33)
33	MONO(nfil) = .false.
	NPKS(nfil) = 0
	NBKGP(nfil) = 0
	INST(nfil) ='DI'
	SOURCE(nfil) = 'PH'
C set the date 
	DATE(3,nfil) = idat/512
	DATE(1,nfil) = mod(idat,512)/32
	DATE(2,nfil) = mod(idat,32)

	NPNT = 0
	DO i=1,10000	! read each record 
	  READ(IN,rec=i+1,err=121) iang,iss,icntm,ienan,
	1	itmp1,itmp2,cnts
C convert angles
	  sang = UPKAN(iang)
	  eang = UPKAN(ienan)
	  step = UPKAN(iss)
	  if (i .eq. 1) then 
	    START(nfil) = sang
	    DELTA(nfil) = step
	    FINISH(nfil) = eang
	  endif
	  if (DELTA(nfil) .ne. step) DELTA(nfil) = 0.0
	  if (icntm .lt. 0) then 
	    count = -50. * icntm / 1000.
	  Else
	    count = icntm / 1000.
	  ENDIF
	  nstep = ABS((eang - sang)/step + 1.5)
	  IF (NSTEP .gt. 250) type *,'Illegal NSTEP for record #',i
	  DO j=1,MIN(250,nstep)
	    IF (NPNT.ge.M$PTS) then
	      WRITE (LI,'(A,i6)') 
	1	' WARNING -- NUMBER OF DATA POINTS WILL BE LIMITED TO ',
	2	M$PTS
	      NPNT = M$PTS
	      goto 121
	    ELSE
	      NPNT = NPNT + 1
	    ENDIF
C convert to CPS in case different step sizes are used for different scans
	    tc = UPCOUNT(cnts(j))
	    B(npnt,nfil) = tc/count
	    BESD(npnt,nfil) = sqrt(max(1.,tc))/count
	    bx(npnt,nfil) = Sang + (j-1.)*step
	    START(nfil) = min(bx(npnt,nfil),START(nfil))
	    FINISH(nfil) = max(bx(npnt,nfil),FINISH(nfil))
	  enddo
	enddo

121	if (npnt .gt. 0) then
	  ln = lench(cfilnam(nfil))
	  write (LO,'(A)')
	1	' File read in Philips APD 3720 (VAX) raw data format:',
	2	'   '//cfilnam(nfil)(:ln)

	  FXTYP(nfil) = xtyp_tt
	  FYTYP(nfil) = 2	! counts per second
	  NPOINT(nfil) = npnt
	  filform = thisform
	  STATUS = .true.
C remove the file extension from the peak name, if one was specified
	  call remext(pname)
	endif
111	close(unit=IN)
C----------------------------------------------------------------------------
C   First, Does the file exist?
201	IF (pname .eq. ' ') RETURN
	INQUIRE(FILE=pname,EXIST=exist,defaultfile='.di')
	IF (.not. exist) goto 211
C if the file can be opened with recl=128 it is very likely to be APD 3720
	OPEN(UNIT=IN,FILE=pname,TYPE='OLD',ERR=211,defaultfile='.di',
	1	readonly,shared,ACCESS='DIRECT',RECL=128,
	2	FORM='UNFORMATTED',RECORDTYPE='FIXED')
C now try to read an APD binary format peak file
	READ(IN,rec=1,err=211) rec1w
	IF (IREV .ne. '2' .or. ID .ne. 'D' .or. itype .ne. 'ID') goto 211
C read the title
	DO I=1,40
	  j = 2*I - 1
	  WRITE(ATITLE(nfil)(j:j+1),'(a2)') ititle(I)
	enddo
c DECODE THE ANODE
	IF (ianode .eq. 1) then
	  IRAD(nfil) = 'CU'
	ELSEIF (ianode .eq. 2) then
	  IRAD(nfil) = 'MO'
	ELSEIF (ianode .eq. 3) then
	  IRAD(nfil) = 'CO'
	ELSEIF (ianode .eq. 4) then
	  IRAD(nfil) = 'FE'
	ELSEIF (ianode .eq. 5) then
	  IRAD(nfil) = 'CR'
	ENDIF
	CALL WAVESET(IRAD(nfil),WAVE(nfil),WKA1(nfil),WKA2(nfil),*133)
133	MONO(nfil) = .false.
	NPKS(nfil) = 0
	do k1=1,M$PKS
	  READ(IN,rec=k1+1,err=211) mpk,
	1	(ith(i),iwd(i),iht(i),ibk(i),pflg(i),i=1,min(mpk,51))
	  do k=1,MPK
	    IF (NPKS(nfil).ge.M$PKS) then
	      WRITE (LI,'(A,i6)') 
	1	' WARNING -- NUMBER OF PEAKS WILL BE LIMITED TO ',
	2	M$PKS
	      NPKS(nfil) = M$PKS
	      goto 211
	    ELSE
	      NPKS(nfil) = NPKS(nfil) + 1
	    ENDIF
	    J = NPKS(nfil)
	    TT(J,nfil) = upkan(ith(k))
	    FWHM(J,nfil) = upkan(iwd(k))
	    IF (Mod(pflg(k)/2,2) .eq. 1 .and. Mod(pflg(k),2) .eq. 1) then
	      IWAVE(J,nfil) = 2
	    elseIF (Mod(pflg(k)/2,2) .eq. 1) then
	      IWAVE(J,nfil) = 3
	    else
	      IWAVE(J,nfil) = 1
	    endif
	    call TTTOd(DSPACE(J,nfil),TT(J,nfil),wave(nfil))
C counts ==> counts per second, use count from last record. N.B. this may 
C not be correct, but if the count times vary between records in the peak 
C file we may be stuck!
	    IF (count .gt. 0) then
	      PKHT(J,nfil) = UPcount(iht(k))/count
	      BKG(J,nfil) = UPcount(ibk(k))/count
	    ELSE
	      PKHT(J,nfil) = UPcount(iht(k))
	      BKG(J,nfil) = UPcount(ibk(k))
	    ENDIF
	  enddo
	enddo
211    	IF (NPKS(nfil) .gt. 0) then
C  CALCULATE THE RELATIVE INTENSITIES
     	  DUMY = PKHT(1,nfil)
     	  DO J=2,NPKS(nfil)
     	    DUMY = MAX(PKHT(J,nfil),DUMY)
     	  ENDDO
     	  DO J=1, NPKS(nfil)
	    RELINT(J,nfil) = 100.0*PKHT(J,nfil)/DUMY
     	  ENDDO
	  INQUIRE(UNIT=IN,NAME=pname)
	  ln = lench(pname)
	  write (LO,'(I5,A)') NPKS(nfil),
	1	' Peaks read from APD 3720 binary file '//pname(:ln)
	  filform = thisform
	  IF (FYTYP(nfil) .eq. 0) FYTYP(nfil) = 2
	  IF (FXTYP(nfil) .eq. 0) FXTYP(nfil) = XTYP_TT
	  STATUS = .true.
	  close(unit=IN)
	  RETURN
	ENDIF
	close(unit=IN)
C----------------------------------------------------------------------------
C now try to read an APD 3720 ASCII format peak file
	INQUIRE(FILE=dname,EXIST=exist,defaultfile='.aplis')
	IF (.not. exist) goto 311
	OPEN(UNIT=IN,FILE=pname,TYPE='OLD',ERR=311,FORM='FORMATTED'
	1	,readonly,shared,defaultfile='.aplis')
C
C  READ THE FILE HEADER INFORMATION...
C
	READ(IN,'(5(/),1X,a7)',ERR=311) temp
	IF (temp .ne. 'APD3720') goto 311
	READ(IN,'(4(/),28x,i2,1x,a3,1x,i2)',ERR=311) date(2,nfil),
	1	temp,date(3,nfil)
	If (temp .eq. 'JAN') THEN 
	  date(1,nfil) = 1
	ELSEIf (temp .eq. 'FEB') THEN 
	  date(1,nfil) = 2
	ELSEIf (temp .eq. 'MAR') THEN 
	  date(1,nfil) = 3
	ELSEIf (temp .eq. 'APR') THEN 
	  date(1,nfil) = 4
	ELSEIf (temp .eq. 'MAY') THEN 
	  date(1,nfil) = 5
	ELSEIf (temp .eq. 'JUN') THEN 
	  date(1,nfil) = 6
	ELSEIf (temp .eq. 'JUL') THEN 
	  date(1,nfil) = 7
	ELSEIf (temp .eq. 'AUG') THEN 
	  date(1,nfil) = 8
	ELSEIf (temp .eq. 'SEP') THEN 
	  date(1,nfil) = 9
	ELSEIf (temp .eq. 'OCT') THEN 
	  date(1,nfil) = 10
	ELSEIf (temp .eq. 'NOV') THEN 
	  date(1,nfil) = 11
	else
	  date(1,nfil) = 12
	endif
	READ(IN,'(2(/),39x,F6.0)',ERR=311) COUNT
	READ(IN,'(//,a5)',ERR=311) temp
	IF (temp .ne. '     ') goto 311
C
C  READ THE PEAK LIST...
C
     	DO J=1, M$PKS
C skip over lines without a peak number in the first three columns
321	  READ(IN,'(i4,f10.0,f7.0,f10.0,f7.0,2f8.0,4x,a1,2x,a1)',
	1	ERR=321,END=301)
	2	i,TT(J,nfil),FWHM(J,nfil),PKHT(J,nfil),bkg(J,nfil),
	3	DSPACE(J,nfil),RELINT(J,nfil),i1,i2
C skip over blank lines
	  IF (I .eq. 0) goto 321
	  IF (i2 .eq. 'X' .and. i1 .eq. 'X') then
	      IWAVE(J,nfil) = 2
	  elseIF (i2 .eq. 'X') then
	    IWAVE(J,nfil) = 3
	  else
	    IWAVE(J,nfil) = 1
	  endif
C change counts to counts per second
	  PKHT(J,nfil) = PKHT(J,nfil)/count
	  bkg(J,nfil) = bkg(J,nfil)/count
	  NPKS(nfil) = J
     	ENDDO

301	IF (NPKS(nfil).gt.0) then
	  INQUIRE(UNIT=IN,NAME=pname)
	  ATITLE(nfil) = PNAME
	  IF (FYTYP(nfil) .eq. 0) FYTYP(nfil) = 2
	  IF (FXTYP(nfil) .eq. 0) FXTYP(nfil) = XTYP_TT
	  ln = lench(pname)
	  write (LO,'(I5,A)') NPKS(nfil),
	1	' Peaks read from APD ASCII peak file '//pname(:ln)
	  filform = thisform
	  STATUS = .true.
	ENDIF
311	close(unit=IN)
	RETURN
	END
C**************************************************************************
	REAL*4 FUNCTION UPKAN(iang)
C**************************************************************************
C unpack an APD angle to a real angle
C		coded 4/89 by B. H. Toby
	integer*2 iang
C**************************************************************************
	IF (iang .lt. 0) then 
	  UPKAN = (1.5-iang) * 0.005
	ELSE
	  UPKAN = iang * 0.005
	ENDIF
	RETURN
	END
C**************************************************************************
	REAL*4 FUNCTION UPcount(icnt)
C**************************************************************************
C unpack an APD count to a real count
C		coded 4/89 by B. H. Toby
C  N.B. there is a logical inconsistancy in the APD documentation:
C  it specifies that integers between 64536 and 65536 are mapped to 
C  -1 to -1000, however there are 1001 values in that range. Also the
C  direction of mapping is somewhat confusing. 
C  This routine maps 64536 to i2cnt = -1
C  and  	      65536 to i2cnt = -1001
	integer*2 icnt
C**************************************************************************
	real*4 cnt
C convert negative values to unsigned positive values
	IF (iang .ge. 0) then 
	  cnt = icnt
	else
	  cnt = 64536 + icnt
	endif
C now unpack. 
	IF (i2cnt .le. 64535) then 
	  UPcount = cnt*cnt/100.
	ELSE
	  UPcount = 64535 - i2cnt 
	ENDIF
	RETURN
	END
