      PROGRAM HKLINP
C
C     A PROGRAM TO CREATE AN INPUT FILE FOR THE PROGRAM ALLHKL
C
C     LYNNE B. MCCUSKER, CLARENDON LABORATORY, OXFORD UNIVERSITY
C     NOVEMBER 1987, JULY 1988
C
C     THE STEP SCAN INTENSITY DATA IS ASSUMED TO BE IN THE FORMAT
C     PRODUCED BY STEPCO OF THE XRS-82 RIETVELD REFINEMENT PACKAGE
C     (BACKGROUND SUBTRACTED AND INITIAL ZERO CORRECTION APPLIED)
C
      DIMENSION IH(500),IK(500),IL(500),COUNTS(10000),TTS(3),
     1PWISE(9),ISCREW(3),IGLIDE(3),KI(30),XINT(500),WTS(10000),
     2INTK(600,20)
      CHARACTER*80 JUNK
      CHARACTER*32 TITLE,ATIT
      CHARACTER*20 KI,AKI
      CHARACTER*72 ANS
      CHARACTER*1 ICARD(80),INTK
C
      NDAT = 8
      NTIN2 = 9
      NTIN3 = 11
      NTOUT = 10
      CMAX = 0.0
      NPEAKS = 0
      NPTS = 0
      TTHMIN = 0.0
      TTHMAX = 100.0
      WAVETC = 1.5406
      NLG = 1
      NEXT = 0
      MSTEPU = 1
      NC = 1
      KOUT = 1
      IW = 2
      IRHOMB = 0
      LOT = 1
      NSIDE = 3
      POLRA = 1.0
      SIG = 0.
      REFSIG = 35.
      A = 10.0
      B = 10.0
      C = 10.0
      ALPHA = 90.
      BETA = 90.
      GAMMA = 90.
      PWISE(1) = 1.0
      PWISE(2) = 0.0
      PWISE(3) = 0.0
      PWISE(4) = 0.0
      PWISE(5) = 0.0
      PWISE(6) = 0.0
      PWISE(7) = 0.0
      PWISE(8) = 0.0025
      PWISE(9) = 0.0
      BGO = 0.0
      ALP = 0.5
      AX1 = 0.0
      AX2 = 0.0
      AX3 = 0.0
      ZC2 = 0.0
      ZC3 = 0.0
      FWX = 0.0
      FWY = 0.05
      LATTIS = 1
      ISCREW(1) = 0
      ISCREW(2) = 0
      ISCREW(3) = 0
      IGLIDE(1) = 0
      IGLIDE(2) = 0
      IGLIDE(3) = 0
      DO 3 I = 1,30
      KI(I) = '00000000000000000000'
    3 CONTINUE
      TITLE = '                    '
      DO 5 I=1,80
      ICARD(I) = ' '
    5 CONTINUE
   10 FORMAT(A)
   11 FORMAT(80A1)
C
C     UPDATING AN ALREADY EXISTING FILE
C     
      WRITE(6,800)
  800 FORMAT(/'    Do you want to update an already existing input',
     1' file?  ',$)
      READ(6,10) ANS
      IF(ANS(1:1).EQ.'Y' .OR. ANS(1:1).EQ.'y') THEN
       REWIND NTIN3
       READ(NTIN3,7000) MINPT,MAXPT,NPEAKS,STEP,WAVETC,NLG,NEXT,TITLE
       TTHMIN = FLOAT(MINPT)*STEP
       TTHMAX = FLOAT(MAXPT)*STEP
       READ(NTIN3,7100) MINPT,MAXPT,MSTEPU,POLRA
       READ(NTIN3,7200) NC,NOUT,KOUT,IW,IRHOMB,LOT,NSIDE
       READ(NTIN3,7300) SIG,REFSIG
       READ(NTIN3,7400) A,B,C,ALPHA,BETA,GAMMA
       READ(NTIN3,7500) (PWISE(I),I=1,9),BGO,ALP
       IF(NLG.EQ.3) READ(NTIN3,7500) FWX,FWY
       IF(NLG.EQ.4) READ(NTIN3,7500) AX1,AX2,AX3,ZC2,ZC3
       READ(NTIN3,7600) LATTIS,(ISCREW(I),I=1,3),(IGLIDE(I),I=1,3)
C**** HKL'S
       IF(NPEAKS.GT.0) THEN
        READ(NTIN3,7700) (IH(I),IK(I),IL(I),XINT(I),I=1,NPEAKS)
       END IF
       IF(LOT.EQ.0) THEN
        IF(NLG.LE.2) K15 = 15
        IF(NLG.EQ.3) K15 = 18
        IF(NLG.EQ.4) K15 = 20
        IF(NLG.EQ.5) K15 = 16
        NP = K15 + NPEAKS
        DO 950 I=1,NC
        IF(NLG.LE.2) READ(NTIN3,8000) KI(I),(INTK(J,I),J=K15+1,72)
        IF(NLG.EQ.3) READ(NTIN3,8001) KI(I),(INTK(J,I),J=K15+1,72)
        IF(NLG.EQ.4) READ(NTIN3,8002) KI(I),(INTK(J,I),J=K15+1,72)
        IF(NLG.EQ.5) READ(NTIN3,8003) KI(I),(INTK(J,I),J=K15+1,72)
        IF(NP.GT.72) READ(NTIN3,8004) (INTK(J,I),J=73,NP)
  950   CONTINUE 
       ELSE
        READ(NTIN3,7950) (KI(I),I=1,NC)
       END IF
       GO TO 2040
      ENDIF
C
C     READ STEPSCAN DATA FROM CODPROF.DAT
C      
      WRITE(6,1000) 
 1000 FORMAT(/'    Do you need to create ALLHKL.DAT from CODPROF.DAT?'/
     1 '     (i.e. are you running ALLHKL for the first time on this',
     2' data?)'/ '     (Y/N) > ',$)
      READ(6,10) ANS
      IF(ANS(1:1).EQ.'Y' .OR. ANS(1:1).EQ.'y') THEN 
      DO 400 I=1,50
      READ(NTIN2,1200) JUNK
 1200 FORMAT(A80) 
      IF(JUNK(1:1).EQ.'F') GO TO 500
  400 CONTINUE    
  500 CONTINUE
      J=1
      DO 600 I=1,10000
      READ(NTIN2,1300,END=700) TT,TCTS,SIGM,BGD
 1300 FORMAT(F10.5,F12.0,F12.2,F12.3)
      IF(I.EQ.1) TT1 = TT
      IF(I.EQ.2) THEN
       TT2 = TT
       STEP = TT2 - TT1
      END IF
      IF(I.GE.3) THEN
       DIF = TT - TT3
       IF(DIF.GT.(STEP+.000001)) THEN
        ISTP = NINT(DIF/STEP)
        X = (TCTS-BGD)*1.0 - COUNTS(J-1)
        SX = SIGM*1.0 - WTS(J-1)
        DO 650 K=1,ISTP-1
        COUNTS(J) = COUNTS(J-1) + X/ISTP
        WTS(J) = WTS(J-1) + SX/ISTP
        J=J+1
  650   CONTINUE
       END IF
      END IF
      TT3 = TT
      COUNTS(J)=(TCTS-BGD)*1.0
      WTS(J)=SIGM*1.0
      IF(COUNTS(J).GT.CMAX) CMAX = COUNTS(J)
      NPTS = J
      J=J+1
  600 CONTINUE    
  700 CONTINUE
      STEP = TT2 - TT1
      MINPT = NINT(TT1/STEP)
      MAXPT = NINT(TT3/STEP)
      WRITE(6,660) CMAX
  660 FORMAT(/'    The maximum number of counts (CMAX) in this data is',
     1F7.0,/'    This value will be rescaled to 10000 unless a new',
     2/'    value for CMAX is entered here > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) CMAX = STRING
      CSCL = 10000./CMAX
      DO 699 I = 1,NPTS
      COUNTS(I) = COUNTS(I)*CSCL  
  699 WTS(I) = WTS(I)*CSCL
C   WRITE ALLHKL.DAT FILE
      WRITE(NDAT,1400) TT1,TT3,STEP 
      TTHMIN = TT1
      TTHMAX = TT3
 1400 FORMAT(3F10.3)
      WRITE(NDAT,7800) (COUNTS(I),I=1,NPTS)
      WRITE(NDAT,7850) (WTS(I),I=1,NPTS)
      ELSE
      READ(NDAT,1400) TTHMIN,TTHMAX,STEP
      ENDIF
C
C     ASK FOR INPUT PARAMETERS
C
 2040 WRITE(6,1500) TTHMIN
 1500 FORMAT(/'    Minimum 2 theta? (Def: ',F6.3,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) THEN
        TTHMIN = STRING
        NPEAKS = 0
        LOT = 1
        SIG = 0.0
      ENDIF
      WRITE(6,1600) TTHMAX
 1600 FORMAT(/'    Maximum 2 theta? (Def: ',F7.3,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) THEN
        TTHMAX = STRING
        NPEAKS = 0
        LOT = 1
        SIG = 0.0
      ENDIF
      WRITE(6,2100) TITLE
 2100 FORMAT(/'    Title? (Def: ',A32,') > ',$)
      READ(6,10) ATIT
      IF(ATIT(1:10).NE.'          ') TITLE=ATIT
      WRITE(6,2000) POLRA
 2000 FORMAT(/'    Polarization ratio? (Def: ',F6.4,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) POLRA = STRING
      WRITE(6,2050) WAVETC
 2050 FORMAT(/'    Wavelength? (Def: ',F6.4,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) WAVETC = STRING
      WRITE(6,2075) NLG
 2075 FORMAT(/'    Peak Shape Function?'/
     1'       1. Gaussian'/
     2'       2. Lorentzian'/
     3'       3. Pseudo Voigt'/
     4'       4. Experimental (need STDPEAK.DAT file)'/
     5'       5. Pseudo Voigt, single FWHM function'/
     6'       (Def: ',I2,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) NLG = NINT(STRING)
      IF(NLG.EQ.3. .OR. NLG.EQ.5) THEN
       WRITE(6,2085) ALP
 2085  FORMAT(/'    Fraction of Lorentzian component? ',
     1'(Def: ',F5.3,') > ',$)
       READ(6,11) (ICARD(I),I=1,80)
       CALL ANSWER(ICARD,STRING)
       IF(STRING.GT.1.0E-6) ALP = STRING
      END IF
      IF(NLG.EQ.4) THEN
       WRITE(6,2086) AX1
 2086  FORMAT(/'    Asymmetry parameters: '/,
     1'        a = a1 + a2/tan(theta) + a3/tansq(theta)'/
     2'     a1 (Def: ',F5.3,') > ',$)
       READ(6,11) (ICARD(I),I=1,80)
       CALL ANSWER(ICARD,STRING)
       IF(STRING.GT.1.0E-6) AX1 = STRING
       WRITE(6,2087) AX2
 2087  FORMAT('     a2 (Def: ',F5.3,') > ',$)
       READ(6,11) (ICARD(I),I=1,80)
       CALL ANSWER(ICARD,STRING)
       IF(STRING.GT.1.0E-6) AX2 = STRING
       WRITE(6,2088) AX3
 2088  FORMAT('     a3 (Def: ',F5.3,') > ',$)
       READ(6,11) (ICARD(I),I=1,80)
       CALL ANSWER(ICARD,STRING)
       IF(STRING.GT.1.0E-6) AX3 = STRING
       WRITE(6,2089) PWISE(5)
 2089  FORMAT(/'    2 Theta zero correction: '/,
     1'        zc = zc1 + zc2*2theta + zc3*(2theta)**2'/
     2'     zc1 (Def: ',F5.3,') > ',$)
       READ(6,11) (ICARD(I),I=1,80)
       CALL ANSWER(ICARD,STRING)
       IF(STRING.GT.1.0E-6) PWISE(5) = STRING
       WRITE(6,2090) ZC2
 2090  FORMAT('     zc2 (Def: ',F5.3,') > ',$)
       READ(6,11) (ICARD(I),I=1,80)
       CALL ANSWER(ICARD,STRING)
       IF(STRING.GT.1.0E-6) ZC2 = STRING
       WRITE(6,2091) AX3
 2091  FORMAT('     zc3 (Def: ',F5.3,') > ',$)
       READ(6,11) (ICARD(I),I=1,80)
       CALL ANSWER(ICARD,STRING)
       IF(STRING.GT.1.0E-6) ZC3 = STRING
      END IF
      NEXT = 0
      WRITE(6,2200) NC
 2200 FORMAT(/'    Number of cycles? (Def: ',I2,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) NC = NINT(STRING)
      NOUT = NC
      KOUT = 1
      WRITE(6,2300) IW
 2300 FORMAT(/'    There are four weighting schemes available. '/
     1'       1.  unit weights '/
     2'       2.  1/sigma '/
     3'       3.  1/sigma squared '/
     4'       4.  ABS(YOBS-YCALC) '/
     5'    Which do you want to use? (Def: ',I1,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) IW = NINT(STRING)
      WRITE(6,2400)
 2400 FORMAT(/'    Do you have a rhombohedral cell? (Y/N) > ',$)
      READ(6,10) ANS
      IF(ANS(1:1).EQ.'Y' .OR. ANS(1:1).EQ.'y') IRHOMB = 1
      WRITE(6,2600) SIG
 2600 FORMAT(/'    SIG (Sum of observed stepscan intensities)'/
     1'     If SIG is set to zero, it will be calculated.'/
     2'     (Def: ',F10.0,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) SIG = STRING
      WRITE(6,2700) REFSIG
 2700 FORMAT(/'    REFSIG (Average least-squares error found for the'/
     1'     intensity parameters - not critical)'/
     2'     (Def: ',F4.0,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) REFSIG = STRING
      WRITE(6,2800) A
 2800 FORMAT(/'    Cell Parameters: '/
     1'       a (Def: ',F7.4,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) A = STRING
      WRITE(6,2900)B
 2900 FORMAT('       b (Def: ',F7.4,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) B = STRING
      WRITE(6,3000) C
 3000 FORMAT('       c (Def: ',F7.4,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) C = STRING
      WRITE(6,3100) ALPHA
 3100 FORMAT('       alpha (Def: ',F7.3,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) ALPHA = STRING
      WRITE(6,3200) BETA
 3200 FORMAT('       beta  (Def: ',F7.3,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) BETA = STRING
      WRITE(6,3300) GAMMA
 3300 FORMAT('       gamma (Def: ',F7.3,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) GAMMA = STRING
      WRITE(6,3400) PWISE(1)
 3400 FORMAT(/'    Scale? (Def: ',F5.1,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) PWISE(1) = STRING
      WRITE(6,3500) PWISE(2)
 3500 FORMAT(/'    Flat Background Value (Def: ',F5.1,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6 .OR. STRING.LT.-1.0E-6) PWISE(2) = STRING
      IF(NLG.NE.4) THEN
       WRITE(6,3600) PWISE(5)
 3600  FORMAT(/'    2 Theta Zero Error (Def: ',F6.4,') > ',$)
       READ(6,11) (ICARD(I),I=1,80)
       CALL ANSWER(ICARD,STRING)
       IF(STRING.GT.1.0E-6 .OR. STRING.LT.-1.0E-6) PWISE(5) = STRING
      ENDIF
      WRITE(6,3650)
 3650 FORMAT(/'    Half width parameters: '/
     1'    (For pseudo Voigt (NLG=3) this is the Gausssian FWHM)'/
     1'        FWHM = SQRT(u*tansq(theta) + v*tan(theta) + w)')
      WRITE(6,3700) PWISE(6)
 3700 FORMAT('      u (Def: ',F7.5,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6 .OR. STRING.LT.-1.0E-6) PWISE(6) = STRING
      WRITE(6,3800) PWISE(7)
 3800 FORMAT('      v (Def: ',F7.5,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6 .OR. STRING.LT.-1.0E-6) PWISE(7) = STRING
      WRITE(6,3900) PWISE(8)
 3900 FORMAT('      w (Def: ',F7.5,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6 .OR. STRING.LT.-1.0E-6) PWISE(8) = STRING
      PWISE(9) = 0.
      IF(NLG.EQ.3) THEN
      WRITE(6,3910)
 3910 FORMAT(/'    Half width parameters for the Lorentzian part'/
     1'        FWHM = x*tan(theta) + y/cos(theta)')
      WRITE(6,3920) PWISE(6)
 3920 FORMAT('      x (Def: ',F7.5,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6 .OR. STRING.LT.-1.0E-6) FWX = STRING
      WRITE(6,3930) PWISE(7)
 3930 FORMAT('      y (Def: ',F7.5,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6 .OR. STRING.LT.-1.0E-6) FWY = STRING
      END IF
      WRITE(6,4000) LATTIS
 4000 FORMAT(/'    Laue Group ?'/
     1       '                             P     C     F     I'/
     1       '              1-bar          1'/
     2       '              2/m (y unique) 2     3'/
     3       '              mmm            4     5     6     7'/
     4       '              4/m            8                 9'/
     5       '              4/mmm         10                11'/
     6       '              m3            12          13    14'/
     7       '              m3m           15          16    17'//
     8       '              Rhombohedral:'/
     9       '               R(3-bar), R3, R(3-bar)c :   18'/
     1       '               R32, R3m, R3c, R(3-bar)m :  19'//
     2       '              Hexagonal:'/
     3       '               3-bar :     20'/
     4       '               (3-bar)m :  21'/
     5       '               6/m :       22'/
     6       '               6/mmm :     23'//
     7       '     (Def: ',I2,') > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) LATTIS = NINT(STRING)
      WRITE(6,4050)
 4050 FORMAT(/'    Do you want to go through the symmetry',
     1' conditions? > ',$)
      READ(6,10) ANS
      IF(ANS(1:1).EQ.'Y' .OR. ANS(1:1).EQ.'y') THEN
       WRITE(6,4100)
 4100  FORMAT('    2-fold screw axis along a? > ',$)
       READ(6,10) ANS
       IF(ANS(1:1).EQ.'Y' .OR. ANS(1:1).EQ.'y') ISCREW(1) = 1
       WRITE(6,4200)
 4200  FORMAT('    2-fold screw axis along b? > ',$)
       READ(6,10) ANS
       IF(ANS(1:1).EQ.'Y' .OR. ANS(1:1).EQ.'y') ISCREW(2) = 2
       WRITE(6,4300)
 4300  FORMAT('    2-fold screw axis along c? > ',$)
       READ(6,10) ANS
       IF(ANS(1:1).EQ.'Y' .OR. ANS(1:1).EQ.'y') ISCREW(3) = 3
       WRITE(6,4400)
 4400  FORMAT('    Glide plane perpendicular to a? > ',$)
       READ(6,10) ANS
       IF(ANS(1:1).EQ.'Y' .OR. ANS(1:1).EQ.'y') THEN
         WRITE(6,4500)
 4500    FORMAT('    What type of glide? (a,b,c,n) > ',$)
         READ(6,10) ANS
         IF(ANS(1:1).EQ.'A' .OR. ANS(1:1).EQ.'a') IGLIDE(1) = 1
         IF(ANS(1:1).EQ.'B' .OR. ANS(1:1).EQ.'b') IGLIDE(1) = 2
         IF(ANS(1:1).EQ.'C' .OR. ANS(1:1).EQ.'c') IGLIDE(1) = 3
         IF(ANS(1:1).EQ.'N' .OR. ANS(1:1).EQ.'n') IGLIDE(1) = 4
       END IF
       WRITE(6,4600)
 4600  FORMAT('    Glide plane perpendicular to b? > ',$)
       READ(6,10) ANS
       IF(ANS(1:1).EQ.'Y' .OR. ANS(1:1).EQ.'y') THEN
         WRITE(6,4700)
 4700    FORMAT('    What type of glide? (a,b,c,n) > ',$)
         READ(6,10) ANS
         IF(ANS(1:1).EQ.'A' .OR. ANS(1:1).EQ.'a') IGLIDE(2) = 1
         IF(ANS(1:1).EQ.'B' .OR. ANS(1:1).EQ.'b') IGLIDE(2) = 2
         IF(ANS(1:1).EQ.'C' .OR. ANS(1:1).EQ.'c') IGLIDE(2) = 3
         IF(ANS(1:1).EQ.'N' .OR. ANS(1:1).EQ.'n') IGLIDE(2) = 4
       END IF
       WRITE(6,4800)
 4800  FORMAT('    Glide plane perpendicular to c? > ',$)
       READ(6,10) ANS
       IF(ANS(1:1).EQ.'Y' .OR. ANS(1:1).EQ.'y') THEN
         WRITE(6,4900)
 4900    FORMAT('    What type of glide? (a,b,c,n) > ',$)
         READ(6,10) ANS
         IF(ANS(1:1).EQ.'A' .OR. ANS(1:1).EQ.'a') IGLIDE(3) = 1
         IF(ANS(1:1).EQ.'B' .OR. ANS(1:1).EQ.'b') IGLIDE(3) = 2
         IF(ANS(1:1).EQ.'C' .OR. ANS(1:1).EQ.'c') IGLIDE(3) = 3
         IF(ANS(1:1).EQ.'N' .OR. ANS(1:1).EQ.'n') IGLIDE(3) = 4
       END IF
      END IF
      DO 801 I = 1,NC
      WRITE(6,4999)
 4999 FORMAT(/'   Refinement keys for profile parameters: '/
     1'     For help type H '/)
      IF(NLG.EQ.4) GO TO 5503
 5003 IF(NLG.EQ.3) WRITE(6,5000) I,KI(I)
 5000 FORMAT(59X,'123456789012345678'/
     1'   Refinement key for cycle ',I2,' (Def: ',A18,') > ',$)
      IF(NLG.LT.3) WRITE(6,5100) I,KI(I)
 5100 FORMAT(56X,'123456789012345'/
     1'   Refinement key for cycle ',I2,' (Def: ',A15,') > ',$)
      IF(NLG.EQ.5) WRITE(6,5110) I,KI(I)
 5110 FORMAT(57X,'1234567890123456'/
     1'   Refinement key for cycle ',I2.' (Def: ',A16,') > ',$)
      READ(6,10) AKI
      IF(AKI.EQ.'                ') GO TO 801
      IF(AKI(1:1).EQ.'H' .OR. AKI(1:1).EQ.'h') THEN
        WRITE(6,5001)
 5001   FORMAT(/'    The refinement key consists of 15 (Gaussian',
     1  ' or Lorentzian), 16'/'    (pseudo-Voigt with single FWHM',
     1  ' function), or 18 (pseudo-Voigt with'/'    two FWHM',
     1  ' functions) zeroes and/or ones.  One means the variable'/
     2  '    should be refined, and zero that it should not.'//
     4  '    Generally the first four and the ninth parameters', 
     5  ' are not refined'/'    (i.e. key(1,2,3,4,9) set to zero).'//
     6  '    Only the unit cell parameters that are allowed to vary',
     7  ' in the selected'/'    crystal system should be set to',
     8  ' one.  For example, only a and c would'/'    be set',
     9  ' to one for the tetragonal system.'//
     1  '    If the keyword 000000000000000(000) is selected, only',
     2  ' the intensities of'/'    the reflections will be refined.')
        WRITE(6,5005)
 5005   FORMAT(//'   Press Return to Continue ',$)
        READ(6,10) ANS
        WRITE(6,5004)
 5004   FORMAT(//'    The variables are: '//
     1  '     1) Scale (not usually refined)'/
     2  '     2) Flat background parameter (not',
     2  ' usually refined)'/
     3  '     3) Second background parameter (presently',
     3  ' non-functional)'/
     4  '     4) Third background parameter (presently',
     4  ' non-functional)'/
     5  '     5) 2 Theta zero correction'/
     6  '     6) u (of FWHM function)'/
     7  '     7) v (of FWHM function)'/
     8  '     8) w (of FWHM function)'/
     9  '     9) skewness parameter (presently non-functional)'/
     1  '    10) unit cell dimension a'/
     1  '    11) unit cell dimension b'/
     2  '    12) unit cell dimension c'/
     3  '    13) unit cell angle alpha'/
     4  '    14) unit cell angle beta'/
     5  '    15) unit cell angle gamma'/
     6  '    16) Weighting factor for the Lorentzian component',
     6  '  (for NLG=3 or 5 only)'/
     7  '    17) x of Lorentzian FWHM function (for NLG=3 only)'/
     8  '    18) y of Lorentzian FWHM function (for NLG=3 only)'/)
        GO TO 5003
      END IF
      KI(I) = AKI
      GO TO 801
 5503 WRITE(6,5500) I,KI(I)
 5500 FORMAT(61X,'12345678901234567890'/
     1'   Refinement key for cycle ',I2,' (Def: ',A20,') > ',$)
      READ(6,10) AKI
      IF(AKI.EQ.'                ') GO TO 801
      IF(AKI(1:1).EQ.'H' .OR. AKI(1:1).EQ.'h') THEN
        WRITE(6,5501)
 5501   FORMAT(/'    The refinement key consists of 20 zeroes',
     1  ' and/or ones.'/
     2  '    One means the variable should be refined, and',
     3  ' zero that it should not.'//
     4  '    Generally the first four and the ninth parameters', 
     5  ' are not refined'/'    (i.e. key(1,2,3,4,9) set to zero).'//
     6  '    Only the unit cell parameters that are allowed to vary',
     7  ' in the selected'/'    crystal system should be set to',
     8  ' one.  For example, only a and c would'/'    be set',
     9  ' to one for the tetragonal system.'//
     1  '    If the keyword 00000000000000000000 is selected, only'
     2  ' the intensities'/'    of the reflections will be refined.')
        WRITE(6,5505)
 5505   FORMAT(//'   Press Return to Continue ',$)
        READ(6,10) ANS
        WRITE(6,5504)
 5504   FORMAT(//'    The variables are: '/
     1  '     1) Scale (not usually refined)'/
     2  '     2) Flat background parameter (not',
     2  ' usually refined)'/
     3  '     3) Second background parameter (presently',
     3  ' non-functional)'/
     4  '     4) Third background parameter (presently',
     4  ' non-functional)'/
     5  '     5) 2 Theta zero correction (zc1)'/
     6  '     6) u (of FWHM function)'/
     7  '     7) v (of FWHM function)'/
     8  '     8) w (of FWHM function)'/
     9  '     9) skewness parameter (presently non-functional)'/
     1  '    10) unit cell dimension a'/
     1  '    11) unit cell dimension b'/
     2  '    12) unit cell dimension c'/
     3  '    13) unit cell angle alpha'/
     4  '    14) unit cell angle beta'/
     5  '    15) unit cell angle gamma'/
     6  '    16) asymmetry parameter a1'/
     7  '    17) asymmetry parameter a2'/
     8  '    18) asymmetry parameter a3'/
     9  '    19) 2 theta zero correction (zc2)'/
     1  '    20) 2 theta zero correction (zc3)')
        GO TO 5503
      END IF
      KI(I) = AKI
  801 CONTINUE
      IF(NPEAKS.EQ.0) GO TO 5900
      WRITE(6,5600)
 5600 FORMAT(/'    Do you want to specify the reflections to be',
     1' refined? (Y/N) > ')
      READ(6,10) ANS
      IF(ANS(1:1).EQ.'Y' .OR. ANS(1:1).EQ.'y') THEN
        LOT = 0
        IF(NLG.LE.2) K15 = 15
        IF(NLG.EQ.3) K15 = 18
        IF(NLG.EQ.4) K15 = 20
        IF(NLG.EQ.5) K15 = 16
        NP = NPEAKS + K15
        DO 5890 J=1,NC
 5650   WRITE(6,5700) J
 5700   FORMAT(/'    The following options are available:'/
     1  '     1. Refine all reflections EXCEPT those specified'/
     2  '     2. Refine ONLY those reflections specified'//
     3  '     3. Refine ALTERNATE reflections starting with the'/
     4  '        FIRST reflection'/
     5  '     4. Refine ALTERNATE reflections starting with the'/
     6  '        SECOND reflection'//
     3  '     5. Refine ALTERNATE reflections starting with the'/
     4  '        FIRST reflection EXCEPT those specified'/
     5  '     6. Refine ALTERNATE reflections starting with the'/
     6  '        SECOND reflection EXCEPT those specified'//
     7  '     Which do you want to use for cycle ',I2,' ? > ',$)
      READ(6,11) (ICARD(I),I=1,80)
      CALL ANSWER(ICARD,STRING)
      IF(STRING.GT.1.0E-6) NINTK = NINT(STRING)
      IF(NINTK.LT.1 .OR. NINTK.GT.6) GO TO 5650
      IF(NINTK.EQ.1) THEN
        DO 5710 I=K15+1,NP
 5710   INTK(I,J) = '1'
        WRITE(6,5720)
 5720   FORMAT('    Which reflections should NOT be refined?'/
     1         '     Enter each parameter number followed by <CR>.'/
     2         '     Type -1 to finish.')
 5725   WRITE(6,5730)
 5730   FORMAT('    Parameter number: ',$)
        READ(6,11) (ICARD(I),I=1,80)
        CALL ANSWER(ICARD,STRING)
        IF(STRING.LT.0.0) GO TO 5890
        IF(STRING.LT.0.001) GO TO 5725
        K = NINT(STRING)
        INTK(K,J) = '0'
        GO TO 5725
      ENDIF
      IF(NINTK.EQ.2) THEN
        DO 5750 I=K15+1,NP
 5750   INTK(I,J) = '0'
        WRITE(6,5760)
 5760   FORMAT('    Which reflections SHOULD be refined?'/
     1         '     Enter each parameter number followed by <CR>.'/
     2         '     Type -1 to finish.')
 5765   WRITE(6,5730)
        READ(6,11) (ICARD(I),I=1,80)
        CALL ANSWER(ICARD,STRING)
        IF(STRING.LT.0.0) GO TO 5890
        IF(STRING.LT.0.001) GO TO 5765
        K = NINT(STRING)
        INTK(K,J) = '1'
        GO TO 5765
      ENDIF
      IF(NINTK.EQ.3) THEN
        DO 5790 I=K15+1,NP,2
        INTK(I,J) = '1'
 5790   INTK(I+1,J) = '0'
        GO TO 5890
      ENDIF
      IF(NINTK.EQ.4) THEN
        DO 5800 I=K15+1,NP,2
        INTK(I,J) = '0'
 5800   INTK(I+1,J) = '1'
        GO TO 5890
      ENDIF
      IF(NINTK.EQ.5) THEN
        DO I=K15+1,NP,2
        INTK(I,J) = '1'
        INTK(I+1,J) = '0'
        END DO
        WRITE(6,5720)
 5810   WRITE(6,5730)
        READ(6,11) (ICARD(I),I=1,80)
        CALL ANSWER(ICARD,STRING)
        IF(STRING.LT.0.0) GO TO 5890
        IF(STRING.LT.0.001) GO TO 5810
        K = NINT(STRING)
        INTK(K,J) = '0'
        GO TO 5810
      ENDIF
      IF(NINTK.EQ.6) THEN
        DO I=K15+1,NP,2
        INTK(I,J) = '0'
        INTK(I+1,J) = '1'
        END DO
        WRITE(6,5720)
 5820   WRITE(6,5730)
        READ(6,11) (ICARD(I),I=1,80)
        CALL ANSWER(ICARD,STRING)
        IF(STRING.LT.0.0) GO TO 5890
        IF(STRING.LT.0.001) GO TO 5820
        K = NINT(STRING)
        INTK(K,J) = '0'
        GO TO 5820
      ENDIF
 5890 CONTINUE
      ENDIF
 5900 WRITE(6,6000)
 6000 FORMAT(/'   Do you want to go through the parameters again?',
     1' > ',$)
      READ(6,10) ANS
      IF(ANS(1:1).EQ.'Y' .OR. ANS(1:1).EQ.'y') GO TO 2040
C
C     WRITE ALLHKL.INP FILE
C
      MINPT = NINT(TTHMIN/STEP)
      MAXPT = NINT(TTHMAX/STEP)
      WRITE(NTOUT,7000) MINPT,MAXPT,NPEAKS,STEP,WAVETC,NLG,NEXT,TITLE
 7000 FORMAT(3I8,F8.3,F8.5,2I4,A32)
      WRITE(NTOUT,7100) MINPT,MAXPT,MSTEPU,POLRA
 7100 FORMAT(3I8,F8.4)
      WRITE(NTOUT,7200) NC,NOUT,KOUT,IW,IRHOMB,LOT,NSIDE
 7200 FORMAT(7I3)
      WRITE(NTOUT,7300) SIG,REFSIG
 7300 FORMAT(2F12.2)
      WRITE(NTOUT,7400) A,B,C,ALPHA,BETA,GAMMA
 7400 FORMAT(6F12.5)
      IF(NLG.NE.3.AND.NLG.NE.5) THEN
        WRITE(NTOUT,7500) (PWISE(I),I=1,9),BGO
      ELSE
        WRITE(NTOUT,7500) (PWISE(I),I=1,9),BGO,ALP
      ENDIF
      IF(NLG.EQ.3) WRITE(NTOUT,7500) FWX,FWY
      IF(NLG.EQ.4) WRITE(NTOUT,7500) AX1,AX2,AX3,ZC2,ZC3
 7500 FORMAT(6F12.5)
      WRITE(NTOUT,7600) LATTIS,(ISCREW(I),I=1,3),(IGLIDE(I),I=1,3)
 7600 FORMAT(7I3)
C**** HKL'S
      IF(NPEAKS.EQ.0) GO TO 7750
      WRITE(NTOUT,7700) (IH(I),IK(I),IL(I),XINT(I),I=1,NPEAKS)
      IF(LOT.EQ.0) THEN
        DO 7650 I=1,NC
        IF(NLG.LE.2) WRITE(NTOUT,8000) KI(I),(INTK(J,I),J=K15+1,72)
        IF(NLG.EQ.3) WRITE(NTOUT,8001) KI(I),(INTK(J,I),J=K15+1,72)
        IF(NLG.EQ.4) WRITE(NTOUT,8002) KI(I),(INTK(J,I),J=K15+1,72)
        IF(NLG.EQ.5) WRITE(NTOUT,8003) KI(I),(INTK(J,I),J=K15+1,72)
        IF(NP.GT.72) WRITE(NTOUT,8004) (INTK(J,I),J=73,NP)
 7650   CONTINUE 
 8000 FORMAT(A15,57A1)
 8001 FORMAT(A18,54A1)
 8002 FORMAT(A20,52A1)
 8003 FORMAT(A16,56A1)
 8004 FORMAT(72A1)
      ELSE
 7700 FORMAT(3I3,F12.5)
 7800 FORMAT(10(2X,F6.0))
 7850 FORMAT(10(2X,F6.2))
 7750 IF(NLG.LT.3) WRITE(NTOUT,7900) (KI(I),I=1,NC)
      IF(NLG.EQ.3) WRITE(NTOUT,7925) (KI(I),I=1,NC)
      IF(NLG.EQ.4) WRITE(NTOUT,7950) (KI(I),I=1,NC)
      IF(NLG.EQ.5) WRITE(NTOUT,7975) (KI(I),I=1,NC)
 7900 FORMAT(A15)
 7925 FORMAT(A18)
 7950 FORMAT(A20)
 7975 FORMAT(A16)
      ENDIF
 8100 STOP
      END
C
C=======================================================================
      SUBROUTINE ANSWER(ICARD,STRING)
C
      REAL*4 M, E, CMD(30)
      INTEGER*2 SIGN, ESIGN, DFLAG, EFLAG, N
      INTEGER*2 FOUND, LENGTH, I, J, JSTART, JSTOP, START
      INTEGER*2 MFACT, NFACT, OFACT, ICOM
      CHARACTER*1 ICARD(80)
C
      ICOM = 0
      SIGN = 0
      ESIGN = 0
      DFLAG = 0
      EFLAG = 0
      FOUND = 0
      LENGTH = 0
      JSTART = 0
      JSTOP = 0
      START = 0
      MFACT = 0
      NFACT = 0
      OFACT = 0 
      I = 0
      J = 0
      N = 0
      M = 0.0
      E = 0.0    
      DO 5 I=1,30
      CMD(I) = 0.0
5     CONTINUE
      STRING = 0.0
C
      I = 0
25    LENGTH = 0
30    I = I + 1
      IF(I .GT. 80 .OR. ICOM .GT. 29) GO TO 998
      MFACT = 0
      IF(ICHAR(ICARD(I)) .NE. 32) MFACT=-1
      LENGTH = LENGTH - MFACT
      IF(ICHAR(ICARD(I)) .NE. 32) GO TO 30
      IF(LENGTH .EQ. 0) GO TO 30
      START = I - LENGTH
      IF(LENGTH .GT. 9) LENGTH = 9
100   SIGN = 1
      ESIGN = 1
      DFLAG = 0
      EFLAG = 0
      M = 0.0
      E = 0.0
      JSTART = START
      JSTOP = START + LENGTH
      DO 7 J=JSTART,JSTOP
          N = ICHAR(ICARD(J)) - 48
          IF(N .EQ. -3 .AND. EFLAG .EQ. 0) SIGN = -1
          IF(N .EQ. -3 .AND. EFLAG .EQ. 1) SIGN = -1
          IF(N .EQ. -2) DFLAG = 1
          IF(N .EQ. 21) EFLAG = 1
          IF(N .LT. 0 .OR. N .GT. 9) GO TO 7
          IF(EFLAG .EQ. 1) GOTO 110
          NFACT = 0
          IF(DFLAG .EQ. 0) NFACT = -1
          M = M * 10 ** (-NFACT) + N / 10. ** (DFLAG)
          OFACT = 0
          IF(DFLAG .GT. 0) OFACT = -1
          DFLAG = DFLAG - OFACT
          GO TO 7
110       E=E*10+N
7     CONTINUE
      ICOM=ICOM+1
      CMD(ICOM)=M*SIGN*10.**(E*ESIGN)
      GOTO 25
998   J = ICOM/2
      IF (J .EQ. 0) GO TO 999
      DO 9 I=1,J
          M=CMD(I)
          CMD(I)=CMD(ICOM-I+1)
          CMD(ICOM-I+1)=M
9     CONTINUE
999   STRING = CMD(ICOM)
C   
2000  RETURN
      END
