      SUBROUTINE DMREAD
C
C-----INTERACTIVE MODE (DEMAND) INPUT OF REQUIRED PARAMETERS
C
C     PARAMETER (MAXOBS=200)
      common/qmod/qj(3),mmin,mmax,qmodul,qrefin,nq,iqtyp,iq(3)
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ
      COMMON/CADATA/IALF(13),ialfl(13),CSC(8),cscl(8)
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/BLKA/A(54),UO(3),B(9),bb(9,9)
      COMMON/REAL/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/PPDATA/OBSTH(200),DSP(200),IH(200,4),PWL,
     * NUMOBS,INT(200)
      COMMON/PPCON/JTYP,ITYP,TOL,THEMX,RESOLV
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/BLKH/NCYC,AA(7),DLST(200),IOC(200),THTMX
      COMMON/CHKREF/IHA(4),WLC,OBS,WT,HGOOD
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN,prthtse
      COMMON/CBLKG/IHEAD
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CCREAD/ICRYST
      COMMON/BLKJ/TOLMN ,TOLMX
      COMMON/IERRS/ IWARN,IERR
      COMMON/RDGOOD/RGOOD,SYSEXT
      COMMON/PEAKS/NPKS,NPKMX,NPFLG(6,250),PKPRM( 3,250),NPKSQ(250),
     * IHKL(3,250)
      LOGICAL HGOOD,RGOOD,SYSEXT,qmodul,qrefin
      CHARACTER*6 IALF, ialfl
      CHARACTER*68 IHEAD
      CHARACTER*5 CSC,cscl,ICRYST
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN, IT1, refin
      CHARACTER*8 SPGI
      CHARACTER*1 YES
      CHARACTER*40 FILNAM
C
C-----INITIALIZE
C
      R = 180.00/3.14154265
      MAXOBS = 200
      SYSEXT = .FALSE.
      RGOOD  = .TRUE.
      qmodul = .false.
*      ITHT = 2
      NUMOBS = 0
      PWL = 1.5405981
*      SEMULT = 2.0
      OBS = 0.0
      D   = 0.0
*
* set initial values of lattice parameters to zero
*
      DO I=1,3,1
        AO(I) = 0.0
        ALO(I)=0.0
      enddo
C
C-----CRYSTAL SYSTEM INPUT - CHARACTER*5 LABEL
C
 100  WRITE(NTOUT,1) (CSC(I),I=1,8)
 1      FORMAT('0','Enter crystal system code (A5):'/
     * ' ','   allowed codes:',8(A5,2X))
      READ(NTIN,51) ICRYST
 51     FORMAT(A5)
      DO 120 I=1,8,1
        if(i.lt.7)then
          IF( ICRYST(1:1).NE.CSC(I)(1:1).and.
     *     icryst(1:1).ne.cscl(i)(1:1)) GOTO 120
        else
          IF( ICRYST.NE.CSC(I).and.icryst.ne.cscl(i)) GOTO 120
        endif
        if(icryst(1:2).eq.csc(2)(1:2).or.icryst(1:2)
     *     .eq.cscl(2)(1:2))then
          icryst = csc(2)
          go to 110
        endif
        if(icryst(1:2).eq.csc(6)(1:2).or.icryst(1:2)
     *     .eq.cscl(6)(1:2))then
          icryst = csc(6)
          go to 110
        endif
        icryst = csc(i)
 110    WRITE(NTOUT,2) icryst
 2        FORMAT('0','Begin lattice parameter input for 
     *    crystal system ',A5)
        GOTO 130
 120  CONTINUE
      WRITE(NTOUT,3) ICRYST
 3      FORMAT('0','Invalid code ',A5,' entered')
      GOTO 100
C
C-----ENTER LATTICE PARAMETERS AS REQUIRED BY CRYSTAL SYSTEM
C
 130    WRITE(NTOUT,4)
 4       FORMAT('0','Enter a')
      READ(NTIN,52) AO(1)
 52	FORMAT(G)
C
C-----IF CUBIC THEN LATTICE PARAMETER INPUT IS COMPLETE
C
      IF(CSC(1).EQ.ICRYST.or.cscl(1).eq.icryst) GOTO 170
C
C-----IF TETRAG, RHOMB HEXAG, OR HEXAR THEN B=A AND SKIP B INPUT
C
      IF(ICRYST.EQ.CSC(2).or.icryst.eq.cscl(2)) GOTO 140
      IF(ICRYST.EQ.CSC(5).or.icryst.eq.cscl(5)) GOTO 150
      IF(ICRYST.EQ.CSC(7).or.icryst.eq.cscl(7)) GOTO 140
      IF(ICRYST.EQ.CSC(8).or.icryst.eq.cscl(8)) GOTO 140
C
C-----INPUT OF B LATTICE PARAMETER
C
      WRITE(NTOUT,5) 
 5     FORMAT('0','Enter b')
      READ(NTIN,52) AO(2)
C
C-----ENTER C LATTICE PARAMETER
C
 140  WRITE(NTOUT,6)
 6      FORMAT('0','Enter c')
      READ(NTIN,52) AO(3)
C
C-----IF TETRAGONAL, HEXAGONAL, RHOMBOHEDRAL ON H-AXES, OR ORTHORHOMBIC
C-----THEN ALL LATTICE PARMETERS HAVE BEEN INPUT
C
      IF(ICRYST.EQ.CSC(2).or.icryst.eq.cscl(2)) GOTO 170
      IF(ICRYST.EQ.CSC(7).or.icryst.eq.cscl(7)) GOTO 170
      IF(ICRYST.EQ.CSC(8).or.icryst.eq.cscl(8)) GOTO 170
      IF(ICRYST.EQ.CSC(3).or.icryst.eq.cscl(3)) GOTO 170
C
C-----IF MONOCLINIC THEN SKIP TO BETA INPUT
C
      IF(ICRYST.EQ.CSC(4).or.icryst.eq.cscl(4)) GOTO 160
C
C-----ENTER ALPHA LATTICE PARAMETER
C
 150  WRITE(NTOUT,7)
 7      FORMAT('0','Enter alpha')
      READ(NTIN,52) ALO(1)
C
C-----TEST IF RHOMBOHERDAL, IF SO DONE WITH LATTICE PARAMETER INPUT
C
      IF(ICRYST.EQ.CSC(5).or.icryst.eq.cscl(5)) GOTO 170
C
C-----ENTER BETA
C
 160  WRITE(NTOUT,8)
 8      FORMAT('0','Enter beta')
      READ(NTIN,52) ALO(2)
C
C-----IF MONOCLINIC B-UNIQUE THEN DONE WITH LATTICE PARAMETER INPUT
C
      IF(ICRYST.EQ.CSC(4).or.icryst.eq.cscl(4)) GOTO 170
C
C-----ENTER GAMMA ANGLE
C
      WRITE(NTOUT,9)
 9      FORMAT('0','Enter gamma')
      READ(NTIN,52) ALO(3)
*
* request modulation vector coefficients
*
 170  write(ntout,10)
 10     format(' Enter the coefficients of the modulation vector q*'/
     1' The modulation vector is the form:'/
     1' q* = r a* + s b* + t c*'/
     1' If there is no modulation then return.')
      read(ntin,53),(qj(j),j=1,3)
 53    format(3g10.5)
      if(qj(1).ne.0.0.or.qj(2).ne.0.0.or.qj(3).ne.0.0)qmodul = .true.
      if(qmodul)then
        nq = 0
        ii = 1
        do j=1,3
          if(qj(j).ne.0.0)nq = nq + 1
        enddo
        if(qj(1).ne.0.0)then
          iq(ii) = 7
          ii = ii + 1
        endif
        if(qj(2).ne.0.0)then
          iq(ii) = 8
          ii = ii + 1
        endif
        if(qj(3).ne.0.0)then
          iq(ii) = 9
        endif
        write(ntout,11),(qj(j),j=1,3)
 11      format(' The modulated wave vector is:'/
     *      3x'q* = ',f5.3,'a* + ',f5.3,'b* + ',f5.3,'c*')
      else
        write(ntout,12)
 12      format(' There is no structure modulation')
      endif
C
C-----NOW TO REQUEST LEAST-SQUARES CONTROL PARAMETERS
C
 180  WRITE(NTOUT,13)
 13   FORMAT(/' Enter <0> - input d values and perform least squares'/
     *'       1 - just compute allowed d values from input parameters'/
     *'$Enter the function desired: ')
      READ(NTIN,54) II
 54   FORMAT(I)
      IF(II .NE. 0) GO TO 190
      IDOLSQ=1
      WRITE(NTOUT,15)
 15     FORMAT('0','Enter: NCYC, THTMX, TOLMN, TOLMX AND RESOLV'/
     *' Where: NCYC = The number of initial cycles using data with',
     *' angle below THTMX'/6x,'THTMX = The Theta or 2-Theta angle ',
     *'cut off for initial cycles of refinement'/
     *6X,'TOLMN = Minimum tolerance between observed and calculated',
     *' angles'/6x,'TOLMX = Maximum angular error allowed'/
     *6x,'RESOLV = I do not know'/
     *' Defaults are: 2, 40., 0.04, 0.20, 0.075')
      READ(NTIN,55) NCYC,THTMX,TOLMN,TOLMX,RESOLV
 55     format(i2,f6.2,3f5.3)
      IF(THTMX.LT.0.01) THTMX=40.
      IF(TOLMN.LT.0.01) TOLMN=0.04
      IF(TOLMX.LT.0.01) TOLMX=0.20
      IF(RESOLV.LT.0.01) RESOLV=0.075
      IF(NCYC .EQ.0)   NCYC = 2
*      WRITE(NTOUT,16)
* 16     FORMAT('0','Enter IWTYP,IWCYC Where:'/
*     *'  IWTYP = Type of weighting used??'/
*     *'  IWCYC = Total number of weighted least squares cycles??'/
*     *' (defaults are <0,0>. Enter to get defaults)')
*      READ(NTIN,56) IWTYP,IWCYC
* 56     format(2i1)
      GO TO 200
 190  IDOLSQ = 0
 200  CONTINUE
C
C-----ENTER D-GENERATION CONTROL PARAMETERS
C
 205  WRITE(NTOUT,17)
 17   FORMAT('0','Enter: 2-theta-MAX, IXPD, PWL2, Where:'/
     *' 2-theta-MAX = the maximum angle to be used in computation'/
     *'        IXPD = 0 - full output, = 1 limited output'/
     *'        PWL2 = The wavelength to use'/
     *'        MMIN = minimum satellite indice'/
     *'        MMAX = maximum satellite indice'/
     *'        Defaults are: 50.0, 0, 1.540598, 0, 2'/
     *'$Enter values:')
      READ(NTIN,57,err=205) THEMX, IXPD, PWL2, mmin, mmax
 57     format(f6.2,i2,f8.6,2i2)
      IF(THEMX.LE.0.01) THEMX=50.0
      IF(PWL2.GT.0.01) PWL = PWL2
      if(mmax.lt.1) mmax = 2
      if(.not.qmodul) mmax = 0
C
C-----ENTER THE SPACE GROUP, ASPECT SYMBOL OR CENTERING SYMBOL
C
      WRITE(NTOUT,18)
 18    FORMAT('0','Enter space group, aspect or centering symbol.'/
     *' first character capitol, others lower case (A8)')
      READ(NTIN,58) SPGI
 58     FORMAT(A8)
      if(spgi(1:1).eq.' ')spgi = 'Fmmm'
C
C-----IF NOT LEAST SQUARES RUN THEN SKIP REFLECTION INPUT
C
      NUMCRD=0
*      ITHT = MOD(ITHT,2)
      IF(IDOLSQ.EQ.0) GOTO 260
C
C  USE UNIT WEIGHTS AND SKIP ALTERNANE LAMBDA OPTION
C
	WT = 0.0
	WLC = 0.0
*
* get the input data file name
*
	WRITE(NTOUT,19)
 19       FORMAT(/' Enter file name for the d-I data ',
     1 'file (if blank data will be typed)'/
     * ' The default file format is diffrac-11 with extention <.daf>')
	READ(NTIN,59)FILNAM
 59       FORMAT(A40)
	IF(FILNAM(1:1).EQ.' ')GO TO 230
C
	NTIN = 10
      OPEN ( UNIT=NTIN, NAME=FILNAM, defaultfile='.daf',
     +  TYPE='OLD', SHARED,READONLY, FORM='UNFORMATTED', 
     &  ACCESS='DIRECT', RECORDSIZE=1, ASSOCIATEVARIABLE=NEXT)
C
C-----GET HEADING FOR THIS PROBLEM FROM THE FILE
C
C  Read title, operator, time & date
 210  NEXT=1
      DO I=1,45,4
        READ(NTIN'NEXT) IHEAD(I:I+3)
      enddo
      IHEAD(26:28)='   '
      DO 220,I=1,18
        IF(' '.LE.IHEAD(I:I) .AND. IHEAD(I:I).LE.'~') GOTO 220
C  Non ascii garbage detected in first twelve
C  records so this is not Diffrac-11 format.
        WRITE(6,20)
 20       FORMAT(' FILE NOT IN DIFFRAC 11 FORMAT!')
        CALL EXIT
 220  CONTINUE
      READ(NTIN'19) PWL
C
C  Read number of peaks
      READ(NTIN'21) JPEAKS
      NEXT = 41
 230  IF(FILNAM(1:1).NE.' ')GO TO 240
*
* Read data from terminal if no filename given
*
      WRITE(NTOUT,21)
 21     FORMAT('0','Enter 2-theta, Intensity (with decimal),',
     1' h,k,l (0.0=end)')
      NUMCRD = NUMCRD + 1
      READ(5,60) D, PKPRM(1,NUMCRD), (IHA(I),I=1,3)
 60     format(2f10.0,3i5)
      if(d.eq.0.0)go to 260
      OBS = 0.0
      obs = d
      d = 0.0
      GO TO 250
*
* Read data from file in diffrac-11 format
*
 240  NUMCRD = NUMCRD + 1
C
C  WE WILL TEMPORARILY USE THE PKPRM ARRAY TO STORE THE FLOATING PT.
C  INTENSITIES AND THEN CONVERT THEM TO FIXED POINT IN INT(i) ARRAY
C
      IF(NUMCRD .GT. JPEAKS) GO TO 260
      READ(NTIN'NEXT) D
      READ(NTIN'NEXT) PKPRM(1,NUMCRD)
      NEXT = NEXT + 4
      OBS = 0.0
 250  CALL FRCHEK(NUMCRD)
      IF(.NOT. HGOOD) GOTO 230
      CALL PRCHKL(NUMCRD)              !assign read values to obs arrays
      IF(NUMOBS.LE.MAXOBS) GOTO 230
C
C-----MORE THAN MAXOBS REFLECTIONS
C
      WRITE(NTOUT,22) MAXOBS,MAXOBS
 22     FORMAT('0','**WARNING** More than',I4,' reflections input.'
     * ' only the first',I4,' to be used')
      IWARN = IWARN + 1
C
C-----DMREAD INPUT COMPLETED
C
 260  themx = obsth(numobs)
      THTMX = THTMX/2
      TOLMN = TOLMN/2
      RESOLV= RESOLV/2
      TOLMX = TOLMX/2
*      THEMX = THEMX/2
      WRITE(NTOUT,23) NUMOBS
 23    FORMAT('0','Demand input completed.', I5,' reflections read')
	NTIN = 5
C
C  SCALE AND STORE THE INTENSITIES
C
	AMAX = 0.0
	DO I=1,NUMOBS
	  IF(PKPRM(1,I).GT.AMAX)AMAX = PKPRM(1,I)
        enddo
	if(amax.eq.0.)GO TO 280
	DO I=1,NUMOBS
          INT(I) = PKPRM(1,I) * 100. / AMAX
        enddo
C
C  ALLOW OUTPUT TO GO TO A FILE
C
 280  IF(IDOLSQ.EQ.0) GOTO 310
C WE HAVE A FILE NAME so CHANGE EXTENSION
      DO II=1,40
        if( filnam(ii:ii) .eq. ' ')goto 290
        IF( FILNAM(II:II) .EQ. '.')GO TO 300
      enddo
 290  filnam(ii:ii+3) = '.LSQ'
 300  FILNAM(II+1:II+3) = 'LSQ'
      GO TO 320
C  WE ARE IN D CALC MODE - GENERATE A NAME
 310  FILNAM(1:10) = 'OUTPUT.LSQ'
 320  WRITE(NTOUT,24) FILNAM
 24     FORMAT(/' ENTER <0> - OUTPUT TO TERMINAL'/
     1'       1 - OUTPUT TO FILE: ',A40/'$ENTER OUTPUT CODE: ')
      READ(NTIN,61)II
 61     FORMAT(I)
      IF(II .EQ. 0)GO TO 999
      NTOUT = 40
      OPEN(UNIT=NTOUT,NAME=FILNAM,TYPE='UNKNOWN')
999   RETURN
      END

      SUBROUTINE FRCHEK(NUMCRD)
C
C-----SUBROUTINE TO CHECK FOR ERRORS ON REFLECTION CARDS
C
      COMMON/CHKREF/IHA(4),WLC,OBS,WT,HGOOD
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN,prthtse
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      LOGICAL HGOOD
C
C-----INITIALIZE FLAGS
C
      HGOOD = .TRUE.
C
C-----CHECK THAT d-SPACING, ALT. LAMBDA, 2-THETA, AND WEIGHT
C-----ARE NOT NEGATIVE
C
      IF ((D .GE. 0.0) .AND. (WLC .GE. 0.0) .AND. (OBS .GE. 0.0)
     * .AND. (WT .GE. 0.0)) GO TO 100
      WRITE (NTOUT, 1) NUMCRD, D, WLC, OBS, WT
 1    FORMAT (' ', '**ERROR** Card #',I3,'-not used (reflection) ',
     * ' has illegal negative value; none of following ',
     * 'should be negative:' /
     * ' ', 'd-spacing = ', F9.6, '  /  alternate lambda = ',
     * F8.5, '  /  2-theta = ', F9.5, '  /  weight = ', F9.5)
      HGOOD = .FALSE.
C
C-----CHECK THAT BOTH D-SPACING AND 2-THETA ARE NOT BOTH
C-----NON ZERO
C
 100  CONTINUE
      IF((D .LE. 0.0001) .OR. (OBS .LE. 0.0001)) GO TO 110
      WRITE (NTOUT, 2) NUMCRD, D, OBS
 2    FORMAT (' ', '**ERROR** Card #',I3,'-not used (reflection) ',
     * ' has a value for both the ',
     * 'd-spacing (= ', F9.6, ') and 2-theta (= ',
     * F9.5, ')')
      HGOOD = .FALSE.
 110  CONTINUE
C
C-----CHECK THAT BOTH D-SPACING AND 2-THETA ARE NOT BOTH ZERO
C
      IF ((D .GT. 0.0001) .OR. (OBS .GT. 0.0001)) GO TO 999
      WRITE (NTOUT, 3) NUMCRD, D, OBS
 3    FORMAT (' ', '**ERROR** Card #',I3,'-not used (reflection) ',
     * ' neither d-spacing (= ', F9.6,
     * ') nor 2-theta (= ', F9.5, ') is positive')
      HGOOD = .FALSE.
 999  RETURN
      END

      SUBROUTINE PRCHKL(NUMCRD)
C
C-----SUBROUTINE ASSUMES THAT EITHER D OR 2-THETA > 0
C
C     PARAMETER (MAXOBS=200)
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/CHKREF/IHA(4),WLC,OBS,WT,HGOOD
      COMMON/PPDATA/OBSTH(200),DSP(200),IH(200,4),PWL,
     * NUMOBS,INT(200)
      COMMON/CPPDAT/ IHED(200),INTED(200)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN,prthtse
      COMMON/BLKF/SW(200),WL(200)
      COMMON/IO/NTOUT,NTIN,NEXTN
      CHARACTER*1 IHED,INTED
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      LOGICAL HGOOD
      IF(WLC .LT. 0.001) WLC = PWL
      IF (WT.LE.0.0) WT=1.0
      IF (D.GT.0.0) GO TO 100          !input from file in d values
      THOBS=OBS                        !input from terminal as 2-theta
*      IF (ITHT.EQ.0) 
      thobs=0.5*thobs
      IF (THOBS.GE.90.0) GO TO 110
      DOBS=0.5*WLC/SIN(0.017453293*THOBS)
      GO TO 130
 100  CNST=0.5*WLC
      THOBS=THETA(CNST,D)
      IF (THOBS.GT.0.0.AND.THOBS.LT.90.0) GO TO 120
 110  WRITE (NTOUT, 1) NUMCRD, THOBS
 1    FORMAT (' ', '**ERROR** Card #-not used (reflection) ', I3,
     * ' had an ',
     * 'illegal calculated theta of = ', F6.2)
 120  CONTINUE
      DOBS=D
 130  NUMOBS=NUMOBS+1
      OBSTH(NUMOBS)=THOBS
      DSP(NUMOBS)=DOBS
      WL(NUMOBS)=WLC
      IF(IWTYP.EQ.1) WT=1.0
      IF(IWTYP.EQ.2) WT=1.0/SIN(2.0*THOBS/57.3)**2
      SW(NUMOBS)=SQRT(WT)
      DO L=1,4
        IH(NUMOBS,L)=IHA(L)
      enddo
C
C-----FLAG IF NOT READ SO COMPUTER WILL ASSIGN
C
      IHED(NUMOBS) = ITIH(1)
      IF ((IHA(1) .EQ. 0) .AND. (IHA(2) .EQ. 0) .AND.
     * (IHA(3) .EQ. 0)) IHED(NUMOBS) = ITIH(4)
 999  RETURN
      END
