C----------------------------------------------------------------------
	SUBROUTINE READGSAS2(dname,pname,filform,nfil,STATUS)
C----------------------------------------------------------------------
C Read in file in GSAS format
C	THIS ROUTINE READS FROM A GSAS HISTOGRAM FILE. It must be linked
C	to the the GSAS object library so it is not included by 
C	default in the distribution version of the PS package.
C----------------------------------------------------------------------
C histogram flags:
C	1: P	Powder
C	   S	Single xtal
C	   R    soft constraints (type 'RSN ')
C
C	2: N	Neutron
C	   X	X-ray
C
C	3: T	Time of flight
C	   C	CW
C
C	4: D	Dummy
C	   	(blank) use in least squares
C	   *	exclude from  least squares
C	   F,G,I,N	SCD data
C	   R	powder data to be read
C	   X	not yet processed by POWPREF
C----------------------------------------------------------------------
	LOGICAL status
	INTEGER nfil
	character*(*) dname,pname,filform
	CHARACTER*8 thisform/'GSASHIST'/

	include 'shared$common'
	include '[-.shared]flabel.common'

	LOGICAL exist
	character	line*80
C
	INTEGER*4 IUPRF,IUREF
	INTEGER*4 READPRF,REDREFP
	INTEGER   LENCH

	CHARACTER*60 TEMP
	INTEGER*4 IHIST, IREC, IP, IREAD, MCHANS, NHIST, NCHAN, IHOLD
	INTEGER*4 ICLMP, NCHANS, ICHK, NPNT, MIN1, MIN2, NPH, NRECL, NREF
	INTEGER*4 IFOBS, KREF
	INTEGER I, J, K, j1, j3

	CHARACTER*4 hhead(99),HTYPE
	CHARACTER*4 label*20
	INTEGER*4 EFLAG
	CHARACTER*6 KEY,HSTKEY
	LOGICAL NORM,IANS
	REAL*4 TTOF,YO,YC,YI,YB,YB1,YW,CHWDT
	REAL*4 DIFC,DIFA,ZERO
	INTEGER*4 MUL,ICODE
	real*4 HKL(3)
	real*4 INCDNT,DSP,LAM,FOSQ,SIGFO,FOTSQ,FCSQ,FCTSQ,PHAS,TRANS,
	1	EXTCOR,WTFO,TOF
	INTEGER PFLAG(9)
	CHARACTER*1 digit(0:9)/'0','1','2','3','4','5','6','7','8','9'/

	REAL TMAX, BCOF(12), DMIN
	INTEGER IBAK, NCOF
	
C
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 Is there a datafile name?
	IF (dname .eq. ' ')  RETURN
C   First, Does the file exist?
	INQUIRE(FILE=dname,EXIST=exist,NAME=cfilnam(nfil),
	1	defaultfile='.exp;')
	IF (.not. exist) goto 200
C test the file format
	INQUIRE(FILE=cfilnam(nfil),KEYED=TEMP)
	IF (temp(1:3) .ne. 'YES') goto 200
	INQUIRE(FILE=cfilnam(nfil),ORGANIZATION=TEMP)
	IF (temp(1:7) .ne. 'INDEXED') goto 200
C now let GSAS open it
	call OPNEXP('SHARED','KEEP',cfilnam(nfil),IN,EFLAG)

	if (EFLAG .ne. 0) then 
	  write (lo,'(/2a)') ' GSAS2 ERROR -- Unable to reopen file: ',
	1	cfilnam(nfil)
	  write (lo,'(a,I)') ' ERROR CODE',EFLAG
	  goto 210
	endif

	write (LO,'(A)') ' Processing GSAS EXP File '//
	1	cfilnam(nfil)(:lench(cfilnam(nfil)))

     	ATITLE(nfil) = ' '
	call readexp(IN,'      DESCR ',ATITLE(nfil))

C Get # of histograms in experiment
	TEMP = 'NONE'
	call readexp(IN,' EXPR  NHST ',temp)
	IF (TEMP .EQ. 'NONE') GOTO 220
	READ(TEMP,'(I5)',err=220) NHIST

	IF (NHIST .eq. 1) THEN
	  WRITE (lo,'(2x,A)') 'There is 1 histogram on this file'
	ELSE
	  WRITE (lo,'(2x,A,i5,a)') 'There are',NHIST,
	1	' histograms on this file'
	ENDIF


C get the histogram flags
105	TEMP = 'NONE'
	do i=1,nhist,12
	  write (key,'(i1)') 1+(I-1)/12
	  call readexp(IN,' EXPR  HTYP'//key(1:1),temp)
	  IF (TEMP .NE. 'NONE') then
	    READ(TEMP,'(2x,12(a4,1x))') (hhead(j),j=I,MIN(I+11,nhist))
	  ELSE
	    write (lo,'(A)') ' Missing EXP  HTYP'//key(1:1)//' card'
	    goto 220
	  ENDIF
	  DO J=I,MIN(I+11,nhist)
	    HTYPE = hhead(j)
	    if (HTYPE(1:1) .eq. 'P') THEN
	      if (HTYPE(3:3) .eq. 'T') THEN
	        label = 'TOF'
	      elseif (HTYPE(3:3) .eq. 'C') THEN
	        label = 'CW '
	      ELSE
	        label = ' ? '
	      ENDIF
	      if (HTYPE(2:2) .eq. 'N') THEN
	        label(4:) = ' Neutron'
	      ELSEif (HTYPE(2:2) .eq. 'X') THEN
	        label(4:) = ' X-ray  '
	      ELSE
	        label(4:) = '   ?    '
	      ENDIF
	      if (HTYPE(4:4) .eq. 'D') THEN
	        label(12:) = ' Dummy'
	      ELSEif (HTYPE(4:4) .eq. '*') THEN
	        label(12:) = ' Excluded'
	      ELSEif (HTYPE(4:4) .eq. 'R') THEN
	        label(12:) = ' To be read'
	      ELSEif (HTYPE(4:4) .eq. 'X') THEN
	        label(12:) = ' Not Proc''d'
	      ELSEif (HTYPE(4:4) .eq. ' ') THEN
	        label(12:) = '  (OK)'
	      ELSE
	        label(12:) = '   ?'
	      ENDIF
	    ELSE
	      label = 'Not Powder'
	    ENDIF
	   WRITE (lo,'(4x,A,i3,2x,a,4x,a)') 'Histogram',J,HTYPE,label
	  ENDDO
	ENDDO

C Choose the histogram
110	IF (NHIST .LE. 0) goto 210
	IF (NHIST .EQ. 1) THEN
	  IHIST = 1
	ELSE
	  WRITE (lo,'(A)') '$  Enter histogram number (0 to exit): '
	  READ (li,'(I)',end=200,err=105) IHIST
	  IF (IHIST .LE. 0) goto 200
	  IF (IHIST .GT. NHIST .or. IHIST .EQ. 0) goto 105
	ENDIF
	HTYPE = hhead(IHIST)
	IF (HTYPE(1:1) .ne. 'P') THEN
	  write (lo,'(A)') ' Histogram is not powder data'
	  GOTO 105
	ENDIF
	IF (HTYPE(4:4) .eq. '*') THEN
	  write (lo,'(A)') ' WARNING: Histogram is excluded from LS'
	ELSEIF (HTYPE(4:4) .eq. 'D') THEN
	  write (lo,'(A)') ' WARNING: Histogram is dummy-type'
	ELSEIF (HTYPE(4:4) .ne. ' ') THEN
	  write (lo,'(2A)') ' Histogram is not appropriate status: ',
	1	HTYPE
	  GOTO 105
	ENDIF

	KEY = HSTKEY(IHIST)
	TEMP = 'NONE'
	call readexp(IN,key,temp)
	IF (TEMP .EQ. 'NONE') THEN
	  WRITE (lo,*) 'HISTOGRAM NOT PRESENT'
	  GOTO 105
	ENDIF

	TEMP = 'NONE'
	call readexp(IN,key//'  HNAM',temp)
	WRITE (lo,'(4x,2a)')  'Histogram title: ',temp(:LENCH(TEMP))
	TEMP = 'NONE'
	call readexp(IN,key//'  HFIL',temp)
	WRITE (lo,'(4x,2a)')  'Original data file: ',temp(:LENCH(TEMP))
	TEMP = 'NONE'
	call readexp(IN,key//' BANK',temp)
	WRITE (lo,'(4x,2a)')  'bank # ',temp(:LENCH(TEMP))

C Get histogram parameters
	TEMP = 'NONE'
	call readexp(IN,key//' ICONS',temp)
	IF (TEMP .EQ. 'NONE') THEN
	  WRITE(lo,'(A)') 
	1	' Warning -- no HST hh CONS record on .EXP file'
	  goto 210
	ENDIF

	zero = 0.0
	if (HTYPE(3:3) .ne. 'T') THEN
	  READ(TEMP,'(3F10.0,9x,i1)',err=220) 
	1		WKA1(nfil),WKA2(nfil),zero,i
C convert to degrees
	  ZERO = ZERO/100.
	  WAVE(nfil) = WKA1(nfil)
	  MONO(nfil)= .true.
	  if (i .gt. 0.0) THEN
	    MONO(nfil)= .false.
	    WAVE(nfil) = (i*WKA1(nfil) + WKA2(nfil)) / (i + 1.)
	  ENDIF	    
	  TEMP = 'NONE'
	  call readexp(IN,key//' IRAD ',temp)
	  IF (TEMP .NE. 'NONE') THEN
	    READ(TEMP,'(I5)',err=220) k
	    IF (k .EQ. 1) THEN
	      IRAD(nfil) = 'CR'
	    ELSEIF (k .EQ. 2) THEN
	      IRAD(nfil) = 'FE'
	    ELSEIF (k .EQ. 3) THEN
	      IRAD(nfil) = 'CU'
	    ELSEIF (k .EQ. 4) THEN
	      IRAD(nfil) = 'MO'
	    ELSEIF (k .EQ. 5) THEN
	      IRAD(nfil) = 'AG'
	    ENDIF
	  ELSEif (HTYPE(2:2) .eq. 'N') THEN
	    IRAD(nfil) = 'NU'
	  ELSE
	    IRAD(nfil) = 'SY'
	  ENDIF
	  FXTYP(nfil) = XTYP_TT
	ELSE
	  FXTYP(nfil) = XTYP_D
	  READ(TEMP,'(3F10.0)',err=220) DIFC,DIFA,ZERO
C convert to millsec
	  DIFC = DIFC/1000.
	  DIFA = DIFA/1000.
	  ZERO = ZERO/1000.
	  IRAD(nfil) = 'NU'
	  WAVE(nfil) = 0.0
	  WKA1(nfil) = 0.0
	  WKA2(nfil) = 0.0
	ENDIF

C Open HISTOGRAM file
	CALL GETUNIT(IUPRF)
	call OPNPRF(IN,ihist,NCHAN,'SHARED',.FALSE.,IUPRF)

	call readexp(IN,key//' CHANS',temp)
	READ(TEMP,'(5I10)',err=220) ihold,iclmp,nchans,ichk,mchans

	WRITE(lo,'(2x,A)') 'Choose the code for the desired operation: ',
	2	' 	1) read Observed histogram',
	3	' 	2) read Computed histogram',
	3	' 	3) read Background histogram',
	3	' 	4) read Observed-Background',
	3	' 	5) read Computed w/o Background',
	3	' 	6) read Observed-Computed'
	WRITE(lo,'(A)') '$ Enter a number (1-6): '
	READ (li,'(I)',err=110,end=200) iread
	IF (iread .lt. 1 .or. iread .gt. 6) goto 110

	ZEROP = 0.0
	IF (ZERO .ne. 0. .and. HTYPE(3:3) .ne. 'T') THEN
	  WRITE(lo,'(A)') '$Apply zero correction ([Y]/N)? '
	  read (li,'(A1)',err=210) ians
	  if (ians .eq. 'n' .or. ians .eq. 'N') ZEROp = zero
	  if (ians .eq. 'n' .or. ians .eq. 'N') ZERO = 0.0
	ENDIF
C READ FROM HISTOGRAM FILE
	norm = .false.
	npnt = 0
	IF (iread .ge. 3 .and. iread .le. 5) THEN
C get the max d value
	  TMAX = 180.0
	  IF (HTYPE(3:3).EQ.'T' ) THEN
	    call readexp(IN,key//'I ITYP',temp)
	    READ(temp,'(15X,F10.4)') TMAX
	    TMAX = 180.0/TMAX
	  ENDIF
C Get BACKGROUND parameters
	  DO I=1,12
	    BCOF(I) = 0.0
	  END DO
	  call readexp(IN,key//'BAKGD ',temp)
	  READ(temp,'(2I5)') IBAK,NCOF
	  j1 = 1
	  DO j3 = 1, (NCOF-1)/4+1
	    call readexp(IN,key//'BAKGD'//digit(j3),temp)
	    READ(temp,'(4E15.6)') (BCOF(I),I=j1,MIN(j1+3,NCOF))
	    j1 = j1+4
	  ENDDO
	ENDIF
	DO IREC=1,MIN(M$PTS,nchans)
	  I = READPRF(IUPRF,IREC,ICODE,TTOF,YO,YC,YI,YB,YW,CHWDT,MIN1,MIN2)
	  IF (I .NE. 0) GOTO 220
	  BESD(npnt+1,nfil) = 1.
	  IF (YW .gt. 0) BESD(npnt+1,nfil) = 1./SQRT(YW)

	  IF (HTYPE(3:3) .eq. 'T') THEN
C convert from microsec
	    TTOF = TTOF / 1000.
C compute the d-space from time of flight
	    IF (DIFA.NE.0.0 ) THEN
              BX(npnt+1,nfil) = 2.0*(TTOF-ZERO)/
	1		(DIFC+SQRT(DIFC**2+4.0*DIFA*(TTOF-ZERO)))
	    ELSE
              BX(npnt+1,nfil) = (TTOF-ZERO)/DIFC
	    ENDIF
	  ELSE
C convert from centidegrees
	    TTOF = TTOF / 100.
	    BX(npnt+1,nfil) =  TTOF-ZERO
	  ENDIF

	  IF (iread .ge. 3 .and. iread .le. 5) THEN
C compute the background
	    CALL CALCBAK(HTYPE,TMAX,DIFC,WKA1(nfil),IBAK,NCOF,
	1	BCOF,TTOF,YB1)
C add the fixed and computed background
	    yb = yb + yb1
	  ENDIF
	  IF (iread .eq. 1) THEN
	    B(npnt+1,nfil) = YO
	  ELSEIF (iread .eq. 2) THEN
	    B(npnt+1,nfil) = YC
	  ELSEIF (iread .eq. 3) THEN
	    B(npnt+1,nfil) = YB
	  ELSEIF (iread .eq. 4) THEN
	    B(npnt+1,nfil) = YO - YB
	  ELSEIF (iread .eq. 5) THEN
	    B(npnt+1,nfil) = YC - YB
	  ELSEIF (iread .eq. 6) THEN
	    B(npnt+1,nfil) = YO - YC
	  ENDIF

	  IF (IREC .eq. 1 .and. YI .ne. 1. .and. YI .gt. 0) THEN
	    WRITE(lo,'(A)') '$Normalize by incident spectrum (Y/[N]): '
	    read (li,'(A1)',err=210) ians
	    if (ians .eq. 'Y' .or. ians .eq. 'y') norm = .true.
	  ENDIF
	  IF (norm .and. YI .gt. 0.0) THEN
	    B(npnt+1,nfil) = B(npnt+1,nfil) * YI
	  ENDIF
	  npnt = npnt + 1
	ENDDO

	IF (iread .eq. 1) THEN
	  FYTYP(nfil) = YTYP_cnt
	ELSEIF (iread .eq. 2) THEN
	  FYTYP(nfil) = YTYP_cal
	ELSEIF (iread .eq. 3) THEN
	  FYTYP(nfil) = YTYP_bk
	ELSEIF (iread .eq. 4) THEN
	  FYTYP(nfil) = YTYP_cnt + 64
	ELSEIF (iread .eq. 5) THEN
	  FYTYP(nfil) = YTYP_cal + 64
	ELSEIF (iread .eq. 6) THEN
	  FYTYP(nfil) = YTYP_omc
	ENDIF
	IF (norm) FYTYP(nfil) = FYTYP(nfil) + 512
C----------------------------------------------------------------------
C Get peak parameters
130	nph = 0
	TEMP = 'NONE'
	call readexp(IN,key//' NPHAS',temp)
	READ (temp,'(9i5)',err=150) pflag
	write(lo,'(3x,A)') 
	1	'The following phase(s) are present in this histogram'
	J = 0
	DO I=1,9
	  IF (pflag(I) .gt. 0) THEN
	    temp = '   no name   '
	    call readexp(IN,'CRS'//digit(I)//'    PNAM',temp)
	    write (lo,'(3x,i4,2x,A40)') I,temp
	    J = J + 1
	  ENDIF
	ENDDO
	if (j .gt. 1) then
	  write (lo,'(2a)') 
	1	'$ Enter the number of a phase or -1 (no peaks)',
	1	' [default=0 (all)]: '
	  read (li,'(i)',err=130) nph
	  IF (nph .lt. 0) GOTO 150
	  IF (nph .ne. 0 .and. pflag(nph) .le. 0) then
	    write (lo,'(a)') ' *** Invalid Phase number, try again'
	    goto 130
	  ENDIF
	ENDIF

C Open REFLECTION file
	CALL GETUNIT(IUREF)
	call opNREFP(IN,.FALSE.,IUREF,ihist,nrecl)

	call readexp(IN,key//' NREF ',temp)
	READ(TEMP,'(I5,F10.0,4X,A1)') NREF,DMIN,IFOBS
	NPKS(nfil) = 0
	DO J=1,min(m$pks,NREF)
	  KREF = ihist*100000 + J
	  I = REDREFP(IN,KREF,HKL,MUL,ICODE,INCDNT,DSP,LAM,FOSQ,
	1	SIGFO,FOTSQ,FCSQ,FCTSQ,PHAS,TRANS,EXTCOR,WTFO,TOF)
	  IF (I .NE. 0) GOTO 150
	  k = NPKS(nfil) + 1

	  IH(K,nfil) = IFIX(HKL(1))
	  IK(K,nfil) = IFIX(HKL(2))
	  IL(K,nfil) = IFIX(HKL(3))
	  dspace(K,nfil) = DSP
	  FINTEG(K,nfil) = MUL * FOSQ
	  IF (HTYPE(3:3) .eq. 'T') THEN
	    TT(K,nfil) = DSP
	  ELSE
!	    TT(K,nfil) = (TOF-ZERO) / 100.
	    TT(K,nfil) = (TOF+zerop) / 100.
	    IWAVE(K,nfil) = 0
	    IF (.not. MONO(nfil)) IWAVE(K,nfil) = MOD(ICODE/100,10) + 1
	  ENDIF
	  ip = ICODE/1000
	  IF (IP .eq. nph .or. nph .EQ. 0) THEN
	    WRITE(COMMT1(K,nfil),'(a2,i2.2)') 'PH',ip
	    NPKS(nfil) = NPKS(nfil) + 1
	  ENDIF
	ENDDO
	ymax = FINTEG(1,nfil)
	do j=2,NPKS(nfil)
	  ymax = max(ymax,FINTEG(J,nfil))
	enddo
	do j=1,NPKS(nfil)
	  IF (ymax .gt. 0) PKHT(J,nfil) = 1000.*FINTEG(J,nfil)/ymax
	enddo
C----------------------------------------------------------------------
150	close(unit=IN)
	CLOSE (IUPRF)
	CLOSE (IUREF)
	INST(nfil)='  '
	SOURCE(nfil)='GS'
	START(nfil) = BX(1,nfil)
	FINISH(nfil) = BX(npnt,nfil)
	DELTA(nfil) = 0.0
	IF (BX(2,nfil)-BX(1,nfil) .eq. BX(npnt,nfil)-BX(npnt-1,nfil)) 
	1	DELTA(nfil) = BX(2,nfil)-BX(1,nfil) 
C set the date to now since we have no better choice
	CALL IDATE(DATE(1,nfil),DATE(2,nfil),DATE(3,nfil))
	IF (npnt .le. 0) goto 200
	write (LO,'(A)') ' File '//cfilnam(nfil)(:lench(cfilnam(nfil)))
	1		//' read from GSAS Histogram'
	NPOINT(nfil) = min(m$pts,NPNT)
	filform = thisform
	STATUS = .true.
	RETURN
C----------------------------------------------------------------------------
220	WRITE(lo,'(/A/)') 'GSAS2 ERROR -- unexpected error reading file'
210	call PS_PAUSE(PROMPT)
200	close(unit=IN)
	CLOSE (IUPRF)
	CLOSE (IUREF)
	RETURN
	END
