C ***  PROGRAM: RIQAS - INTERACTIVE SETUP FOR RIETVELD/QUANT DATABASE SYSTEM
C ***  VERSION: 890911 (YYMMDD)
C ***  AUTHORS: SCOTT A. HOWARD
C *             KIMBERLY D. PRESTON
C *             DEPARTMENT OF CERAMIC ENGINEERING
C *             UNIVERSITY OF MISSOURI- ROLLA
C *             ROLLA, MO  65401   USA
C *
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QOPT*1, QBELL*1
C *
C *  SET LOGICAL UNIT NUMBERS
      ITTI  =  5
      ITTO  =  6
      IDFI  = 10
      IDFO  = 11
      INDXI = 20
      INDXO = 21
      IRETI = 30
      IRETO = 31
      ISCR  = 40
C *
C **  SAY HELLO
C *
1000  WRITE(ITTO,1010) KVERSN
1010  FORMAT(
     1' *** RIQAS - Rietveld/database management program  V ',I6,/)
CSAH 1' *** RIQAS - Rietveld/database management program  V ',I6,
CSAH 1 //,' Developed at the Department of Ceramic Engineering',/,
CSAH 1    '                  University of Missouri- Rolla',/)
C *
C **  READ THE DEFAULT PARAMETER FILE
C *
      CALL GETDFT
C *
C *  SET DATABASE FILE TYPE TO THAT READ FROM THE DEFAULT FILE
      KBIN = KVDEF(01)
C *
C *  INITIALIZE PARAMETERS
      QBELL = CHAR(7)
C *
C **  OPEN THE DATABASE AND INDEX FILES NOW...
C *
C *  OPEN THE FILES
1100  IF(KBIN.EQ.1) THEN
        OPEN(UNIT=IDFI,FILE='RIQAS.XTL',STATUS='OLD',FORM='UNFORMATTED',
     1   ERR=1110)
       ELSE
        OPEN(UNIT=IDFI,FILE='RIQAS.XTL',STATUS='OLD',FORM='FORMATTED',
     1   ERR=1110)
      ENDIF
      OPEN(UNIT=INDXI,FILE='RIQAS.IDX',STATUS='OLD',ERR=1150)
      GO TO 1200
C *
C *  THE DATABASE WAS NOT FOUND
1110  WRITE(ITTO,1120) QBELL
1120  FORMAT(/,1X,A1,
     1'--The database file (RIQAS.XTL) could not be found.')
      WRITE(ITTO,1122)
1122  FORMAT(/,
     1'  One of the following conditions may',
     1' have caused this problem:',//,
     1'   ...The file in not in the current directory',/,
     1'   ...A Set/Assign statement was incorrectly specified',/,
     1'   ...The file does not yet exist',//,
     1'   You have two options:',//,
     1'   1 - Exit the program to correct an external error, or',/,
     1'   2 - Have the program create an empty file',//,
     1'$Choice? <1> ')
      READ(ITTI,1130) QOPT
1130  FORMAT(A1)
      IF(QOPT.EQ.'2') THEN
        IF(KBIN.EQ.1) THEN
          OPEN(UNIT=IDFI,FILE='RIQAS.XTL',STATUS='NEW',
     1     FORM='UNFORMATTED',ERR=1140)
          CLOSE(UNIT=IDFI)
          OPEN(UNIT=IDFI,FILE='RIQAS.XTL',STATUS='OLD',
     1     FORM='UNFORMATTED',ERR=1140)
         ELSE
          OPEN(UNIT=IDFI,FILE='RIQAS.XTL',STATUS='NEW',
     1     FORM='FORMATTED',ERR=1140)
          CLOSE(UNIT=IDFI)
          OPEN(UNIT=IDFI,FILE='RIQAS.XTL',STATUS='OLD',
     1     FORM='FORMATTED',ERR=1140)
        ENDIF
        CALL INDEX
        GO TO 1200
       ELSE
        STOP '--Could not find the database file (RIQAS.XTL)'
      ENDIF
1140  STOP '--Can not open the new database file (RIQAS.XTL): aborting'
C *
C *  THE DATABASE WAS NOT FOUND
1150  WRITE(ITTO,1160) QBELL
1160  FORMAT(/,1X,A1,
     1'--The database index file (RIQAS.IDX) could not be found.')
      WRITE(ITTO,1122)
      READ(ITTI,1130) QOPT
      IF(QOPT.EQ.'2') THEN
        CALL INDEX
       ELSE
        STOP '--Could not find the database index file (RIQAS.IDX)'
      ENDIF
C *
C *  FILES ARE OPEN
1200  WRITE(ITTO,1210)
1210  FORMAT(/,
     1 ' The database and index files were successfully opened.')
C *
C **  MAIN PROGRAM MENU
C *
2000  WRITE(ITTO,2010)
2010  FORMAT(//,' *** The following submenus are available',//,
     1'    R - Rietveld control file functions',/,
     1'    D - Database functions',/,
     1'    P - Powder pattern calculation',//,
     1'    X - Exit the program',//,
     1'$Choice? ')
      READ(ITTI,2020) QOPT
2020  FORMAT(A1)
      IF( QOPT.EQ.'D' .OR. QOPT.EQ.'d' ) GO TO 3000
      IF( QOPT.EQ.'R' .OR. QOPT.EQ.'r' ) GO TO 4000
      IF( QOPT.EQ.'P' .OR. QOPT.EQ.'p' ) GO TO 7000
      IF( QOPT.EQ.'X' .OR. QOPT.EQ.'x' ) GO TO 9000
      WRITE(ITTO,2030) QBELL
2030  FORMAT(/,1X,A1,'-Please enter a choice from the menu.')
      GO TO 2000
C *
C **  DATABASE FUNCTIONS MENU
C *
3000  WRITE(ITTO,3010)
3010  FORMAT(//,' DATABASE management options:',//,
     1'    L - List the available phases',/,
     1'    R - Retrieve a data set from the data base',//,
     1'    A - Add a new phase to the data base',/,
     1'    E - Edit an entry for a phase',/,
     1'    D - Delete a phase from the data base',//,
     1'    I - (Re)build the index file',//,
     1'    Z - Reformat a database file',//,
     1'    X - Exit this section',//,
     1'$Choice? ')
      READ(ITTI,2020) QOPT
      IF( QOPT.EQ.'L' .OR. QOPT.EQ.'l' ) GO TO 3200
      IF( QOPT.EQ.'R' .OR. QOPT.EQ.'r' ) GO TO 3300
      IF( QOPT.EQ.'I' .OR. QOPT.EQ.'i' ) GO TO 3400
      IF( QOPT.EQ.'A' .OR. QOPT.EQ.'a' ) GO TO 3500
      IF( QOPT.EQ.'E' .OR. QOPT.EQ.'e' ) GO TO 3600
      IF( QOPT.EQ.'D' .OR. QOPT.EQ.'d' ) GO TO 3700
      IF( QOPT.EQ.'Z' .OR. QOPT.EQ.'z' ) GO TO 3800
      IF( QOPT.EQ.'X' .OR. QOPT.EQ.'x' ) GO TO 2000
      WRITE(ITTO,2030) QBELL
      GO TO 3000
C *
C *  GIVE A LIST OF THE PHASES CURRENTLY IN THE DATA BASE
3200  CALL LIST( 0 )
      GO TO 3000
C *
C *  RETRIEVE A DATA SET FROM THE DATA BASE
C *  USE THE SCRATCH PHASE AREA
3300  IPH = MAXPHS
      CALL RETRIV( NPHAS )
      IF(NPHAS.GT.0) CALL RWDBPH( 'W', 0, IEOF )
      GO TO 3000
C *
C *  BUILD THE INDEX FILE
3400  CALL INDEX
      GO TO 3000
C *
C *  ADD NEW PHASE INFORMATION TO THE DATA BASE
3500  CALL ADDATA
      GO TO 3000
C *
C *  EDIT AN EXISTING PHASE I* THE DATA BASE
3600  CALL DBEDIT
      GO TO 3000
C *
C *  DELETE AN EXISTING PHASE FROM THE DATA BASE
3700  CALL DELETE( 1 )
      GO TO 3000
C *
C *  CONVER A DATABASE FILE BETWEEN FORMATTED/UNFORMATTED FORM
3800  CALL DBCONV
      GO TO 3000
C *
C **  RIETVELD CONTROL FILE MENU
C *
4000  WRITE(ITTO,4010)
4010  FORMAT(//,' RIETVELD control file management options:',//,
     1'    R - Read a Rietveld file',/,
     1'    W - Write a Rietveld file',//,
     1'    Z - Clear control & phase data (begin new problem)',/,
     1'    C - Edit control flags and global parameters',/,
     1'    E - Edit phase data in memory',/,
     1'    A - Edit refinement algorithm',/,
     1'    D - Delete a phase from memory',//,
     1'    G - Get phase data from database',/,
     1'    P - Put phase data into database',//,
     1'    X - Exit this section',//,
     1'$Choice? ')
      READ(ITTI,2020) QOPT
      IF( QOPT.EQ.'R' .OR. QOPT.EQ.'r' ) GO TO 4300
      IF( QOPT.EQ.'W' .OR. QOPT.EQ.'w' ) GO TO 4200
      IF( QOPT.EQ.'Z' .OR. QOPT.EQ.'z' ) GO TO 5000
      IF( QOPT.EQ.'C' .OR. QOPT.EQ.'c' ) GO TO 4500
      IF( QOPT.EQ.'E' .OR. QOPT.EQ.'e' ) GO TO 4400
      IF( QOPT.EQ.'A' .OR. QOPT.EQ.'a' ) GO TO 4900
      IF( QOPT.EQ.'D' .OR. QOPT.EQ.'d' ) GO TO 4800
      IF( QOPT.EQ.'G' .OR. QOPT.EQ.'g' ) GO TO 4600
      IF( QOPT.EQ.'P' .OR. QOPT.EQ.'p' ) GO TO 4700
      IF( QOPT.EQ.'X' .OR. QOPT.EQ.'x' ) GO TO 2000
      WRITE(ITTO,2030) QBELL
      GO TO 4000
C *
C *  WRITE A CONTROL FILE
4200  CALL WRRIET
      GO TO 4000
C *
C *  READ A CONTROL FILE
4300  CALL RDRIET
      GO TO 4000
C *
C *  EDIT A PHASE IN MEMORY
4400  CALL ERETPH
      GO TO 4000
C *
C *  EDIT THE CONTROL FILE HEADER INFORMATION
4500  CALL EDRETH
      GO TO 4000
C *
C *  GET PHASE DATA FROM THE DATABASE
4600  CALL GRETPH
      GO TO 4000
C *
C *  PUT PHASE DATA INTO THE DATABASE
4700  CALL PRETPH
      GO TO 4000
C *
C *  DELETE A PHASE FROM MEMORY
4800  CALL DRETPH
      GO TO 4000
C *
C *  EDIT THE REFINEMENT ALGORITHM
4900  CALL ERETCW( 0 )
      GO TO 4000
C *
C *  RESET THE CONTROL AND PHASE DATA TO BEGIN NEW PROBLEM
5000  CALL ZRETCP
      GO TO 4000
C *
C **  CALCULATE A POWDER PATTERN
C *
7000  CALL CALPAT
      GO TO 2000
C *
C **  CLOSE ANY ACTIVE FILES AND EXIT
C *
9000  CLOSE(UNIT=IDFI)
      CLOSE(UNIT=INDXI)
C *
      STOP '* * Normal termination of RIQAS * *'
      END
C ***  GETDFT - GET DEFAULTS FROM THE RIQAS.DFT FILE
C *
      SUBROUTINE GETDFT
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      PARAMETER ( NDFT = 1  )
      CHARACTER QD(NDFT)*16
      CHARACTER QLIN40*40, QLIN01*1, QLIN16*16, QLINC*1, QLINN*10
      DIMENSION NT(NDFT), NV(NDFT), RV(NDFT)
      EQUIVALENCE ( QLIN40, QLIN01 ), ( QLIN40(2:17), QLIN16 )
      EQUIVALENCE ( QLIN40(18:18), QLINC ), ( QLIN40(18:27), QLINN )
      EQUIVALENCE ( NV, RV )
      DATA IDEBUG /0/
C *
C *  Codewords, formats and defaults:
C *
C *  Format: .........IIIIIIIIII
C *  *DBase form               0
      DATA QD(01),NT(01) / 'DBase form      ', 1 /
      DATA NV(01) /  0 /
C *
C *  SET THE DEFAULTS FOR ALL PARAMETERS
900   DO 910 I=1,NDFT
      IF(NT(I).EQ.1) THEN
        KVDEF(I) = NV(I)
       ELSE
        RVDEF(I) = RV(I)
      ENDIF
910   CONTINUE
C *
C *  OPEN THE FILE CONTAINING THE DEFAULT PARAMETERS
1000  OPEN(UNIT=ISCR,FILE='RIQAS.DFT',STATUS='OLD',ERR=1010)
      GO TO 1100
1010  WRITE(ITTO,1020)
1020  FORMAT(/,
     1' --Can not find the file containing the RIQAS program',
     1' defaults.',/,
     1'   Copy the RIQAS.DFT file from your distribution disk to',
     1' your working',/,
     1'   disk.  Edit RIQAS.DFT to reflect your needs.')
      GO TO 9000
C *
C *  SEARCH FOR LINES CONTAINING THE CORRECT KEYWORDS
1100  READ(ISCR,1110,END=1900) QLIN40
1110  FORMAT(A40)
C      WRITE(ITTO,1112) QLIN40
C1112  FORMAT(1X,A40)
      IF(QLIN01.NE.'*') GO TO 1100
C *
C *  MARKER FOUND.  GET SUSPECT STRING AND CHECK KEYWORD LIST FOR MATCH
1200  IF(IDEBUG.NE.0) WRITE(ITTO,1202) QLIN16
1202  FORMAT(/,' GETDFT: Looking for a keyword in "',A16,'"')
      DO 1210 I=1,NDFT
1210  IF(QD(I).EQ.QLIN16) GO TO 1300
      WRITE(ITTO,1220) QLIN16
1220  FORMAT(' --ERROR WHILE READING SHADOW.DFT:',
     1'  Unrecognizable keyword "',A16,'"')
      GO TO 1100
C *
C *  KEYWORD FROM LIST FOUND.  OBTAIN THE PARAMETER VALUE.
1300  IF(IDEBUG.NE.0) WRITE(ITTO,1302) QLIN16
1302  FORMAT(' Keyword parsed from line = ',A16)
      IF(NT(I).EQ.1) THEN
        READ(QLINN,1310,ERR=1390) RSVP
1310    FORMAT(F10.0)
        KVDEF(I) = NINT( RSVP )
       ELSE IF(NT(I).EQ.2) THEN
        READ(QLINN,1310,ERR=1390) RSVP
        RVDEF(I) = RSVP
      ENDIF
      IF(IDEBUG.NE.0) WRITE(ITTO,1312) RSVP
1312  FORMAT(' Parameter value = ',F14.7)
      GO TO 1100
1390  WRITE(ITTO,1392) QLIN40
1392  FORMAT(
     1' --The value for the keyword in the following phrase could not',
     1' be parsed:',/,
     13X,'"',A40,'"  Please check the SHADOW.DFT',/,
     1'   file and make the value correspond to the given format.')
      GO TO 1100
C *
C *  EOF HIT.  CLOSE FILE
1900  CLOSE(UNIT=ISCR)
C *
C **  CHECK THE LIMITS ON THE PARAMETERS
C *
C *  DATABASE FORMAT
2000  IF( KVDEF(01).NE.0 .AND. KVDEF(01).NE.1 ) THEN
        WRITE(ITTO,2010) QD(01),NV(01)
2010    FORMAT(
     1  ' -ERROR WHILE READING RIQAS.DFT:  The value for "',A16,'"',/,
     1  '  was out of range.  Using default = ',I10)
        KVDEF(01) = NV(01)
      ENDIF
C *
C *  EXIT STAGE LEFT
9000  RETURN
      END
C ***   SUPPORT SUBROUTINES FOR THE RIQAS SYSTEM
C *
C *
C **  INDEX - INDEX CREATES AN INDEX OF ALL PHASES IN DATA BASE
C *
      SUBROUTINE INDEX
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      PARAMETER ( MLCMX=512 )
      CHARACTER QJUNK*1, QSTR(MLCMX)*76, QSTRL*76
      LOGICAL LEXIST
C *
C **  DETERMINE THE NUMBER OF UNUSED PHASE AREAS IN MEMORY
C *
1000  IF(NPHS.LT.MAXPHS) GO TO 1100
      WRITE(ITTO,1010) MAXPHS
1010  FORMAT(/,
     1' --Phase ',I2,' was overwritten and deleted by the indexing',
     1' operation.')
      NPHS = MAXPHS - 1
C *
C **  ERASE THE CURRENT INDEX FILE IF IT EXISTS
C *
C *  DETERMINE IF INDEX FILE ALREADY EXISTS
1100  INQUIRE(FILE='RIQAS.IDX',EXIST=LEXIST)
      IF (LEXIST) THEN
        WRITE(ITTO,1110)
1110    FORMAT(/,' -Erasing current index file.')
        CLOSE(UNIT=INDXI)
        OPEN(UNIT=INDXI,FILE='RIQAS.IDX',STATUS='OLD')
        CLOSE(UNIT=INDXI,STATUS='DELETE')
      ENDIF
      WRITE(ITTO,1120)
1120  FORMAT(' -Opening new index file.')
CIBM
      OPEN(UNIT=INDXO,FILE='RIQAS.IDX',STATUS='NEW')
CIBM
CVAX
C     OPEN(UNIT=INDXO,FILE='RIQAS.IDX',STATUS='NEW',
C    1     CARRIAGECONTROL='LIST')
CVAX
C *
C **  SEQUENTIAL READ THROUGH DATABASE TO GET PHASE HEADER DATA
C *
C *  REWIND TO TOP OF DATABASE FILE AND RESET COUNTERS
2000  WRITE(ITTO,2002)
2002  FORMAT(' -Reading phase information from the database file.')
      REWIND(IDFI)
C *
C *  USE THE SCRATCH PHASE AREA
      IPH = MAXPHS
C *
C *  INITIALIZE POINTER INTO SCRATCH ARRAY
      N = 0
C *
C *  GET THE NEXT SET OF PHASE DATA FROM THE DATABASE
2010  CALL RWDBPH( 'R', 0, IEOF )
C *
C *  TEST FOR EOF ON DTABASE
      IF(IEOF.EQ.1) GO TO 3000
C *
C *  RECORD THE PHASE NAME IN THE INDEX LIST
      N = N + 1
      IF(N.GT.MLCMX) THEN
        WRITE(6,2020) MLCMX
2020    FORMAT(/,
     1' --INDEX: The number of phases in the database file exceeds the',
     1' number of',/,
     1'   records allocated for sorting (',I4,').  The database-index',
     1' file is incomlete.',/,
     1'   Please increase the value of the parameter MLCMX in',
     1' subroutine INDEX.')
        N = N - 1
        GO TO 3000
       ELSE
        QSTR(N)( 1:32) = QPHSNM(IPH)
        QSTR(N)(33:34) = '  '
        QSTR(N)(35:54) = QFORM(IPH)(1:20)
        QSTR(N)(55:56) = '  '
        QSTR(N)(57:76) = QXTALS(IPH)
      ENDIF
C *
C *  REPEAT FOR THE NEXT PHASE
      GO TO 2010
C *
C **  SORT THE PHASE NAMES
C *
3000  WRITE(ITTO,3002)
3002  FORMAT(' -Sorting phase names.')
      DO 3010 I=1,N-1
      ILOW = I
      QSTRL = QSTR(ILOW)
      DO 3020 J=I+1,N
      IF( LLT(QSTR(J),QSTRL) ) THEN
        ILOW = J
        QSTRL = QSTR(ILOW)
      ENDIF
3020  CONTINUE
      IF (I.EQ.ILOW) GO TO 3010
      QSTR(ILOW) = QSTR(I)
      QSTR(I) = QSTRL
3010  CONTINUE
C *
C **  WRITE THE SORTED INDEX
C *
4000  WRITE(ITTO,4010)
4010  FORMAT(' -Writing new index file.')
      QSTRL(1:32) = ' '
      DO 4020 I=1,N
      IF( I.GT.1 .AND. QSTR(I)(1:32).EQ.QSTR(I-1)(1:32) .AND.
     1    QSTRL(1:32).NE.QSTR(I)(1:32) ) THEN
        WRITE(ITTO,4040) QSTR(I)(1:32)
4040    FORMAT('  -Phase name appears more than once: ',A32)
        QSTRL(1:32) = QSTR(I)(1:32)
      ENDIF
      WRITE(INDXO,4030) QSTR(I)
4030  FORMAT(A76)
4020  CONTINUE
C *
C **  CLOSE THE NEW INDEX FILE AND REOPEN IT ON INDXI
C *
8000  CLOSE(UNIT=INDXO)
      OPEN(UNIT=INDXI,FILE='RIQAS.IDX',STATUS='OLD')
C *
C **  JOB COMPLETE.... RETURN TO MAIN
9000  RETURN
      END
C **  RETRIV - RETRIEVE PHASE DATA FROM THE DATABASE INTO MEMORY
C *
      SUBROUTINE RETRIV( IDXPHS )
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QBELL*1,QANS*1
C *
C **  GET THE INDEX NUMBER OF THE PHASE FROM THE USER
C *
C *  ASK USER FOR THE NUMBER OF THE PHASE
1000  WRITE(ITTO,1010)
1010  FORMAT(/,
     1'$Index number of the desired phase (-1:List,0:Exit) <0> ')
      IDXPHS = 0
      READ(ITTI,*,ERR=1000) IDXPHS
C *
C *  LIST THE PHASES IF REQUESTED TO DO SO
      IF(IDXPHS.EQ.-1) THEN
        CALL LIST( 1 )
        GO TO 1000
      ENDIF
C *
C *  GO BACK TO MAIN MENU
      IF (IDXPHS.LT.1) THEN
         IDXPHS = 0
         QPHS = ' '
         GO TO 9000
      ENDIF
C *
C *  GET THE PHASE NAME FROM THE INDEX FILE
      REWIND(INDXI)
      DO 1020 K = 1,IDXPHS
      READ(INDXI,1030,END=1100) QPHS
1030  FORMAT(A32)
1020  CONTINUE
      GO TO 2000
C *
C *  EOF HIT... NO SUCH PHASE
1100  WRITE(ITTO,1110)
1110  FORMAT(/,' The requested phase could not be found in the file.')
      GO TO 1000
C *
C **  SCAN THE RECORDS SEQUENTIALLY LOOKING FOR THE DESIRED PHASE
C *
C *  REWIND THE FILE AND START FROM THE BEGINNING
2000  REWIND (IDFI)
C *
C *  READ THE NEXT SET OF PHASE DATA FROM THE DATABASE
2010  CALL RWDBPH( 'R', 0, IEOF )
C *
C *  THERE IS A PROBLEM IF THE DATABASE EOF WAS HIT DURING THE SEARCH...
      IF(IEOF.EQ.1) THEN
        QBELL = CHAR(7)
        WRITE(ITTO,2210) QBELL
2210    FORMAT(/,1X,A1,
     1  '--The phase name found in the index file did not match an',
     1  ' entry in',/,
     1  '   the database.  Please use the INDEX option from the',
     1  ' database menu to',/,
     1  '   rebuild the index file.')
        GO TO 1000
      ENDIF
C *
C *  DETERMINE IF THIS IS THE CORRECT PHASE
      IF(QPHSNM(IPH).NE.QPHS) GO TO 2010
C *
C *  CONFIRM PHASE
2100  WRITE(ITTO,2110) IDXPHS,QPHSNM(IPH)
2110  FORMAT(/,
     1' Phase ',I4,' is: ',A32,/,
     1 '$ Is this the correct phase? <Y> ')
      READ(ITTI,2120) QANS
2120  FORMAT(A1)
      IF (QANS.EQ.'N' .OR. QANS.EQ.'n' ) THEN
         QPHS = ' '
         GO TO 1000
      ENDIF
      QPHS = QPHSNM(IPH)
C *
C **  JOB COMPLETE.... RETURN TO MAIN
C *
9000  RETURN
      END
C **  GTDBPI - GET INDEX NUMBER FOR A PHASE IN THE DATABASE
C *
      SUBROUTINE GTDBPI( QDBPHS, IDXPHS )
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QDBPHS*32,QSRPHS*32
C *
C *  START AT THE TOP OF THE FILE
      REWIND(INDXI)
C *
C *  SEARCH THE NAME LIST
      IDXPHS = 0
1010  READ(INDXI,1020,END=1100) QSRPHS
1020  FORMAT(A32)
      IDXPHS = IDXPHS + 1
      IF(QSRPHS.EQ.QDBPHS) GO TO 9000
      GO TO 1010
C *
C *  PHASE NOT FOUND
1100  IDXPHS = 0
C *
C *  TASK COMPLETE
9000  RETURN
      END
C **  LIST - LIST THE PHASES IN THE DATABASE
C *
      SUBROUTINE LIST( IFLAG )
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      LOGICAL LEXIST
      CHARACTER QANS*1,QN*32,QF*20,QLFILE*48
C *
C *  SET THE DEFAULT OUTPUT TO GO TO THE TERMINAL
      IOUTPT = ITTO
C *
C **  GET THE LISTING DESTINATION
C *
C *  TEST IF OUTPUT IS TO BE AT THE TERMINAL
      IF( IFLAG.EQ.1 ) GO TO 1100
C *
C *  PROMPT THE USER FOR THE LISTING DESTINATION
1000  WRITE(ITTO,1010)
1010  FORMAT(/,'$Listing file name? <TERMINAL> ')
      READ(ITTI,1020) QLFILE
1020  FORMAT(A48)
      IF ( QLFILE.EQ.' '        .OR. QLFILE .EQ.'/' .OR.
     1     QLFILE.EQ.'TERMINAL' .OR. QLFILE .EQ.'terminal' ) GO TO 1100
C *
C *  OPEN LIST FILE
      IOUTPT = ISCR
      INQUIRE(FILE=QLFILE,EXIST=LEXIST)
      IF (LEXIST) THEN
         OPEN(UNIT=IOUTPT,FILE=QLFILE,STATUS='OLD')
         CLOSE(UNIT=IOUTPT,STATUS='DELETE')
      ENDIF
CIBM
      OPEN(UNIT=IOUTPT,FILE=QLFILE,STATUS='NEW')
CIBM
CVAX
C     OPEN(UNIT=IOUTPT,FILE=QLFILE,STATUS='NEW',
C    1     CARRIAGECONTROL='LIST')
CVAX
C *
C **  READ AND ECHO THE LISTING FILE
C *
C *  REWIND TO TOP OF FILE
1100  REWIND(INDXI)
C *
C *  INITIALIZE COUNTERS.
      NTRM = 0
      NTOT = 0
C *
      WRITE(IOUTPT,1110)
1110  FORMAT(
     1' Index  Phase Name                       Chemical Formula',/,
     1' -----  -------------------------------  --------------------')
C *
C *  READ THE PHASE NAME AND FORMULA FROM THE INDEX FILE
1200  READ(INDXI,1210,END=8000) QN,QF
1210  FORMAT(A32,2X,A20)
C *
C *  WRITE THE PHASE NAME AND NUMBER TO THE SCREEN
      NTOT = NTOT + 1
      WRITE(IOUTPT,1220) NTOT,QN,QF
1220  FORMAT(1X,I5,2X,A32,2X,A20)
C *
C *  REPEAT FOR THE NEXT PHASE
      NTRM = NTRM + 1
      IF( IOUTPT.EQ.ITTO .AND. NTRM.EQ.20 ) THEN
        NTRM = 0
        WRITE(IOUTPT,1230)
1230    FORMAT(/,'$Press <ENTER> to continue or Q to end listing...')
        READ(ITTI,1240) QANS
1240    FORMAT(A1)
        IF( QANS.EQ.'Q' .OR. QANS.EQ.'q' ) GO TO 9000
        WRITE(IOUTPT,1110)
      ENDIF
      GO TO 1200
C *
C *  HALT TERMINAL SCROLL OR CLOSE THE OUTPUT FILE
8000  IF(IOUTPT.EQ.ITTO) THEN
        IF(NTRM.GT.0) THEN
          WRITE(IOUTPT,1232)
1232      FORMAT(/,'$...Press <ENTER> to continue')
          READ(ITTI,1240) QANS
        ENDIF
       ELSE
        CLOSE(UNIT=IOUTPT)
      ENDIF
C *
C **  JOB COMPLETE.... RETURN TO MAIN
9000  RETURN
      END
C **  EDIT - ALLOWS CHANGES TO BE MADE TO A PHASE IN MEMORY
C *
      SUBROUTINE EDIT( LPARM, LCODE, LDBASE )
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      LOGICAL LPARM,LCODE,LDBASE,LRIET
      CHARACTER QANS*1,QSTR*80,QSTR1*1,QBELL*1,QPSF(3)*21
      CHARACTER*25 QINDRF,QATMPF,QMAGSF
      DIMENSION KKRND(5,20),CCSHFT(20)
      EQUIVALENCE ( QSTR, QSTR1 )
      DATA QPSF(1) /'Gaussian             '/
      DATA QPSF(2) /'Pseudo-Voigt         '/
      DATA QPSF(3) /'Pearson VII          '/
C *
1000  QBELL = CHAR(7)
      LRIET = .NOT.LDBASE
C *
C **  ECHO THE INFORMATION TO THE USER TO MAKE CHANGES
C *
11000 IF(.NOT.LPARM) GO TO 12000
      ASSIGN 11000 TO IERLBL
      WRITE(ITTO,11010) QPHSNM(IPH),QFORM(IPH),QCMNT(IPH)
11010 FORMAT(/,
     1'  Phase name       - ',A32,/,
     1'  Chemical formula - ',A32,/,
     1'  Reference        - ',/,4X,A72)
      WRITE(ITTO,11020)
11020 FORMAT(/,'$Change the information? (y/n/e) <n> ')
      READ(ITTI,11030) QANS
11030 FORMAT(A1)
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
         WRITE(ITTO,11040)
11040    FORMAT(/,'$ Phase name (A32): ')
         READ(ITTI,11050) QSTR(1:32)
11050    FORMAT(A32)
         IF( QSTR1.NE.' ' .AND. QSTR1.NE.'/' ) QPHSNM(IPH) = QSTR(1:32)
         WRITE(ITTO,11060)
11060    FORMAT(/,'$ Formula (A32): ')
         READ(ITTI,11070) QSTR(1:32)
11070    FORMAT(A32)
         IF( QSTR1.NE.' ' .AND. QSTR1.NE.'/' ) QFORM(IPH) = QSTR(1:32)
         WRITE(ITTO,11080)
11080    FORMAT('$ Reference (A72): ')
         READ(ITTI,11090) QSTR(1:72)
11090    FORMAT(A72)
         IF( QSTR1.NE.' ' .AND. QSTR1.NE.'/' ) QCMNT(IPH) = QSTR(1:72)
         GO TO 11000
      ENDIF
      IF( QPHSNM(IPH).EQ.' ' .OR. QPHSNM(IPH).EQ.'N/A' ) THEN
        WRITE(ITTO,11100) QBELL,'Phase name          '
11100   FORMAT(/,1X,A1,' -Please supply the following item: ',A20)
        GO TO 11000
      ENDIF
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
C *
12000 IF(.NOT.LPARM) GO TO 13000
      ASSIGN 12000 TO IERLBL
      WRITE(ITTO,12010)
12010 FORMAT(/,' *** Phase Control Parameters *** ')
12020 IF(KINDRF(IPH).EQ.1) THEN
        QINDRF = 'Individual reflections   '
       ELSE IF(KINDRF(IPH).EQ.2) THEN
        QINDRF = 'Based on Friedel pairing '
       ELSE
        QINDRF = 'Based on Laue symmetry   '
        KINDRF(IPH) = 0
      ENDIF
      QATMPF   = 'Values in beta(i,j)      '
      KATMPF(IPH) = 0
      IF( KMAGSF(IPH).EQ.1 ) THEN
        QMAGSF   = 'Johnson.  Following cell.'
       ELSE
        QMAGSF   = 'Inactive                 '
        KMAGSF(IPH) = 0
      ENDIF
      WRITE(ITTO,12030) QSGP(IPH),QXTALS(IPH),NATOM(IPH),QINDRF,
     1  QATMPF,QMAGSF
12030 FORMAT(/,
     1'  Space group         -  ',A20,/,
     1'  Crystal system      -  ',A20,/,
     1'  Number of atoms     - ',I4,/,
     1'  Reflection symmetry -  ',A25,/,
     1'  Aniso temp factors  -  ',A25,/,
     1'  Magnetic form       -  ',A25)
      WRITE(ITTO,11020)
      READ(ITTI,11030) QANS
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
         WRITE(ITTO,12040)
12040    FORMAT('$ Space group (A20): ')
         READ(ITTI,12050) QSTR(1:20)
12050    FORMAT(A20)
         IF( QSTR1.NE.' ' .AND. QSTR1.NE.'/' ) QSGP(IPH) = QSTR(1:20)
12060    QSTR1 = ' '
         IF( QXTALS(IPH) .EQ. 'Cubic'               ) QSTR1 = '1'
         IF( QXTALS(IPH) .EQ. 'Tetragonal'          ) QSTR1 = '2'
         IF( QXTALS(IPH) .EQ. 'Hexagonal'           ) QSTR1 = '3'
         IF( QXTALS(IPH) .EQ. 'Orthorhombic'        ) QSTR1 = '4'
         IF( QXTALS(IPH) .EQ. 'Trigonal on Rhomb.'  ) QSTR1 = '5'
         IF( QXTALS(IPH) .EQ. 'Trigonal on Hexag.'  ) QSTR1 = '6'
         IF( QXTALS(IPH) .EQ. 'Monoclinic b unique' ) QSTR1 = '7'
         IF( QXTALS(IPH) .EQ. 'Triclinic'           ) QSTR1 = '8'
         WRITE(ITTO,12070) QSTR1
12070    FORMAT(/,
     1'    1 - Cubic               5 - Trigonal on Rhombohedral axes',/,
     1'    2 - Tetragonal          6 - Trigonal on Hexagonal axes',/,
     1'    3 - Hexagonal           7 - Monoclinic',/,
     1'    4 - Orthorhombic        8 - Triclinic',//,
     1'$ Crystal system? (1-8) <',A1,'> ')
         READ(ITTI,11030) QANS
         IF( QANS.EQ.' ' .OR. QANS.EQ.'/' ) QANS = QSTR1
         IF( LGE(QANS,'1') .AND. LLE(QANS,'8') ) THEN
           IF(QANS.EQ.'1') QXTALS(IPH) = 'Cubic'
           IF(QANS.EQ.'2') QXTALS(IPH) = 'Tetragonal'
           IF(QANS.EQ.'3') QXTALS(IPH) = 'Hexagonal'
           IF(QANS.EQ.'4') QXTALS(IPH) = 'Orthorhombic'
           IF(QANS.EQ.'5') QXTALS(IPH) = 'Trigonal on Rhomb.'
           IF(QANS.EQ.'6') QXTALS(IPH) = 'Trigonal on Hexag.'
           IF(QANS.EQ.'7') QXTALS(IPH) = 'Monoclinic b unique'
           IF(QANS.EQ.'8') QXTALS(IPH) = 'Triclinic'
          ELSE
           WRITE(IITO,12080) QBELL
12080      FORMAT(1X,A1,'-Please designate the correct crystal system')
           GO TO 12060
         ENDIF
12090    WRITE(ITTO,12100)
12100    FORMAT('$ Number of atoms: ')
         ITEMP1 = 0
         READ(ITTI,*,ERR=7000) ITEMP1
         IF(ITEMP1.GT.0) NATOM(IPH) = ITEMP1
         IF (NATOM(IPH).LT.1) THEN
            WRITE(ITTI,12110) QBELL
12110       FORMAT(1X,A1,'-Number of atoms must be 1 or greater.',/)
            GO TO 12090
         ENDIF
         WRITE(ITTO,12120) KINDRF(IPH)
12120    FORMAT('  Handling of line multiplicities:',//,
     1'    0 - Based on Laue symmetry',/,
     1'    1 - All individual reflections: all multiplicities = 1',/,
     1'    2 - Based on Friedel pairing',/,
     1'$ Choice? <',I1,'> ')
         READ(ITTI,11030) QANS
         IF(QANS.EQ.'0') KINDRF(IPH) = 0
         IF(QANS.EQ.'1') KINDRF(IPH) = 1
         IF(QANS.EQ.'2') KINDRF(IPH) = 2
         WRITE(ITTO,12130) KMAGSF(IPH)
12130    FORMAT('  Formulation of magnetic structure factor:',//,
     1'    0 - Inactive',/,
     1'    1 - Based on Halpern/Johnson',/,
     1'$ Choice? <',I1,'> ')
         READ(ITTI,11030) QANS
         IF(QANS.EQ.'0') KMAGSF(IPH) = 0
         IF(QANS.EQ.'1') KMAGSF(IPH) = 1
         GO TO 12020
      ENDIF
      IF( QSGP(IPH).EQ.' '  .OR. QSGP(IPH).EQ.'N/A' ) THEN
        WRITE(ITTO,11100) QBELL,'Space group         '
        GO TO 12000
      ENDIF
      IF( QXTALS(IPH).EQ.' '  .OR. QXTALS(IPH).EQ.'N/A' ) THEN
        WRITE(ITTO,11100) QBELL,'Crystal system      '
        GO TO 12000
      ENDIF
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
C *
13000 IF(.NOT.LPARM) GO TO 13500
      ASSIGN 13000 TO IERLBL
      WRITE(ITTO,13010)
13010 FORMAT(/,' *** Atomic Structure Parameters *** ')
      DO 13020 IATM = 1,NATOM(IPH)
      IF(KMAGSI(IATM,IPH).EQ.1) THEN
        QMAGSF(1:3) = 'Yes'
       ELSE
        QMAGSF(1:3) = 'No '
        KMAGSI(IATM,IPH) = 0
      ENDIF
13030 WRITE(ITTO,13040) QATOM(IATM,IPH),QMAGSF(1:3),QSCAT(IATM,IPH),
     1 (PAXYZ(J,IATM,IPH),J=1,3),PBISO(IATM,IPH),POCCU(IATM,IPH),
     1 (PBAIS(J,IATM,IPH),J=1,6),QASPG(IATM,IPH)
13040 FORMAT(/,
     1'  Atom label                - ',3X,A8,/,
     1'  Magnetic atom             - ',3X,A3,/,
     1'  Atom oxidation state      - ',3X,A4,/,
     1'  X,Y,Z atomic coordinates  - ',2X,3F8.5,/,
     1'  Iso temp parameter        - ',2X,F8.5,/,
     1'  Occupancy factor          - ',2X,F8.5,/,
     1'  Aniso temp parameters     - ',/,
     1   8X,6F8.5,/,
     1'  Site point-group symmetry - ',3X,A20)
      IF(KMAGSI(IATM,IPH).EQ.1) THEN
        WRITE(ITTO,13050)(PVMAG(J,IATM,IPH),J=1,3)
      ENDIF
13050 FORMAT('  Magnetic vector KX,KY,KZ  - ',2X,3F8.5)
      WRITE(ITTO,11020)
      READ(ITTI,11030) QANS
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
         WRITE(ITTO,13060)
13060    FORMAT(/,'$ Atom label (A8): ')
         READ(ITTI,13070) QSTR(1:8)
13070    FORMAT(A8)
         IF(QSTR1.NE.' '.AND.QSTR1.NE.'/') QATOM(IATM,IPH) = QSTR(1:8)
         WRITE(ITTO,13080)
13080    FORMAT('$ Atom oxidation state (A4): ')
         READ(ITTI,13090) QSTR(1:4)
13090    FORMAT(A4)
         IF(QSTR1.NE.' '.AND.QSTR1.NE.'/') QSCAT(IATM,IPH) = QSTR(1:4)
         WRITE(ITTO,13100)
13100    FORMAT('$ X,Y,Z, atomic coordinates: ')
         TEMP1 = -9.0
         TEMP2 = -9.0
         TEMP3 = -9.0
         READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
         IF( TEMP1.GT.-1.0 .AND. TEMP1.LT.1.0 ) PAXYZ(1,IATM,IPH)= TEMP1
         IF( TEMP2.GT.-1.0 .AND. TEMP2.LT.1.0 ) PAXYZ(2,IATM,IPH)= TEMP2
         IF( TEMP3.GT.-1.0 .AND. TEMP3.LT.1.0 ) PAXYZ(3,IATM,IPH)= TEMP3
         WRITE(ITTO,13110)
13110    FORMAT('$ Iso temp parameter: ')
         TEMP1 = -9.0
         READ(ITTI,*,ERR=7000) TEMP1
         IF(TEMP1.GE.0.0 ) PBISO(IATM,IPH) = TEMP1
         WRITE(ITTO,13120)
13120    FORMAT('$ Occupancy factor: ')
         TEMP1 = -9.0
         READ(ITTI,*,ERR=7000) TEMP1
         IF(TEMP1.GE.0.0) POCCU(IATM,IPH) = TEMP1
         WRITE(ITTO,13130)
13130    FORMAT('$ Aniso temp parameters: ')
         TEMP1 = -9.0
         TEMP2 = -9.0
         TEMP3 = -9.0
         TEMP4 = -9.0
         TEMP5 = -9.0
         TEMP6 = -9.0
         READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6
         IF(TEMP1.NE.-9.0) PBAIS(1,IATM,IPH) = TEMP1
         IF(TEMP2.NE.-9.0) PBAIS(2,IATM,IPH) = TEMP2
         IF(TEMP3.NE.-9.0) PBAIS(3,IATM,IPH) = TEMP3
         IF(TEMP4.NE.-9.0) PBAIS(4,IATM,IPH) = TEMP4
         IF(TEMP5.NE.-9.0) PBAIS(5,IATM,IPH) = TEMP5
         IF(TEMP6.NE.-9.0) PBAIS(6,IATM,IPH) = TEMP6
         WRITE(ITTO,13140)
13140    FORMAT('$ Site point-group symmetry (A20): ')
         READ(ITTI,13150) QSTR(1:20)
13150    FORMAT(A20)
         IF(QSTR1.NE.' '.AND.QSTR1.NE.'/') QASPG(IATM,IPH) = QSTR(1:20)
         WRITE(ITTO,13160)
13160    FORMAT('$ Magnetic atom (0/1): ')
         ITEMP = -9
         READ(ITTI,*,ERR=7000) ITEMP
         IF( ITEMP.EQ.0 .OR. ITEMP.EQ.1 ) KMAGSI(IATM,IPH) = ITEMP
         IF(KMAGSI(IATM,IPH).EQ.1) THEN
           WRITE(ITTO,13170)
13170      FORMAT('$ Magnetic vector: ')
           TEMP1 = -99.0
           TEMP2 = -99.0
           TEMP3 = -99.0
           READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
           IF(TEMP1.NE.-99.0) PVMAG(1,IATM,IPH) = TEMP1
           IF(TEMP2.NE.-99.0) PVMAG(2,IATM,IPH) = TEMP2
           IF(TEMP3.NE.-99.0) PVMAG(3,IATM,IPH) = TEMP3
         ENDIF
         GO TO 13030
      ENDIF
      IF( QATOM(IATM,IPH).EQ.' '  .OR. QATOM(IATM,IPH).EQ.'N/A' ) THEN
        WRITE(ITTO,11100) QBELL,'Atom label          '
        GO TO 13030
      ENDIF
      IF( QSCAT(IATM,IPH).EQ.' ' .OR. QSCAT(IATM,IPH).EQ.'N/A' ) THEN
        WRITE(ITTO,11100) QBELL,'Scattering code     '
        GO TO 13030
      ENDIF
C     IF( QASPG(IATM,IPH).EQ.' ' .OR. QASPG(IATM,IPH).EQ.'N/A' ) THEN
C       WRITE(ITTO,11100) QBELL,'Site point-group    '
C       GO TO 13030
C     ENDIF
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
13020 CONTINUE
C *
13500 IF( LDBASE .OR. .NOT.LCODE ) GO TO 14000
      ASSIGN 13500 TO IERLBL
      WRITE(ITTO,13510)
13510 FORMAT(/,' *** Fractional shifts for the Atomic Parameters *** ')
      DO 13520 IATM = 1,NATOM(IPH)
13530 CALL KWDEKO( KAXYZ(1,IATM,IPH), 3, KKRND(1,1), CCSHFT(1) )
      CALL KWDEKO( KBISO(  IATM,IPH), 1, KKRND(1,4), CCSHFT(4) )
      CALL KWDEKO( KOCCU(  IATM,IPH), 1, KKRND(1,5), CCSHFT(5) )
      CALL KWDEKO( KBAIS(1,IATM,IPH), 6, KKRND(1,6), CCSHFT(6) )
      WRITE(ITTO,13540) QATOM(IATM,IPH),(CCSHFT(J),J=1,11)
13540 FORMAT(/,
     1'  Atom: ',A8,/,
     1'  X,Y,Z, atomic coordinates - ',3F8.2,/,
     1'  Iso temp parameter        - ',F8.2,/,
     1'  Occupancy factor          - ',F8.2,/,
     1'  Aniso temp parameters     - ',/,
     1   6X,6F8.2)
      IF(KMAGSI(IATM,IPH).EQ.1) THEN
        CALL KWDEKO( KVMAG(1,IATM,IPH), 3, KKRND(1,12), CCSHFT(12) )
        WRITE(ITTO,13550) (CCSHFT(J),J=12,14)
13550   FORMAT(/,'  Magnetic vector KX,KY,KZ  - ',2X,3F8.2)
      ENDIF
      WRITE(ITTO,11020)
      READ(ITTI,11030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
         WRITE(ITTO,13100)
         TEMP1 = -9.0
         TEMP2 = -9.0
         TEMP3 = -9.0
         READ(ITTI,*,ERR=7000) TEMP1,TEM2,TEMP3
         IF( TEMP1.GT.-1.0 .AND. TEMP1.LT.1.0 ) CCSHFT(1) = TEMP1
         IF( TEMP2.GT.-1.0 .AND. TEMP2.LT.1.0 ) CCSHFT(2) = TEMP2
         IF( TEMP3.GT.-1.0 .AND. TEMP3.LT.1.0 ) CCSHFT(3) = TEMP3
         CALL KWKODE( KAXYZ(1,IATM,IPH), 3, KKRND(1,1), CCSHFT(1) )
         WRITE(ITTO,13110)
         TEMP1 = -9.0
         READ(ITTI,*,ERR=7000) TEMP1
         IF(TEMP1.GE.0.0 ) CCSHFT(4) = TEMP1
         CALL KWKODE( KBISO(  IATM,IPH), 1, KKRND(1,4), CCSHFT(4) )
         WRITE(ITTO,13120)
         TEMP1 = -9.0
         READ(ITTI,*,ERR=7000) TEMP1
         IF(TEMP1.GE.0.0) CCSHFT(5) = TEMP1
         CALL KWKODE( KOCCU(  IATM,IPH), 1, KKRND(1,5), CCSHFT(5) )
         WRITE(ITTO,13130)
         TEMP1 = -9.0
         TEMP2 = -9.0
         TEMP3 = -9.0
         TEMP4 = -9.0
         TEMP5 = -9.0
         TEMP6 = -9.0
         READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6
         IF(TEMP1.NE.-9.0) CCSHFT(6)  = TEMP1
         IF(TEMP2.NE.-9.0) CCSHFT(7)  = TEMP2
         IF(TEMP3.NE.-9.0) CCSHFT(8)  = TEMP3
         IF(TEMP4.NE.-9.0) CCSHFT(9)  = TEMP4
         IF(TEMP5.NE.-9.0) CCSHFT(10) = TEMP5
         IF(TEMP6.NE.-9.0) CCSHFT(11) = TEMP6
         CALL KWDEKO( KBAIS(1,IATM,IPH), 6, KKRND(1,6), CCSHFT(6) )
         IF(KMAGSI(IATM,IPH).EQ.1) THEN
           WRITE(ITTO,13170)
           TEMP1 = -9.0
           TEMP2 = -9.0
           TEMP3 = -9.0
           READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
           IF(TEMP1.NE.-9.0) CCSHFT(12) = TEMP1
           IF(TEMP2.NE.-9.0) CCSHFT(13) = TEMP2
           IF(TEMP3.NE.-9.0) CCSHFT(14) = TEMP3
           CALL KWKODE( KVMAG(1,IATM,IPH), 3, KKRND(1,12), CCSHFT(12) )
         ENDIF
        GO TO 13530
      ENDIF
13520 CONTINUE
C *
14000 IF( LDBASE .OR. .NOT.LPARM ) GO TO 14500
      ASSIGN 13500 TO IERLBL
      WRITE(ITTO,14010) PSCALE(IPH),POVISO(IPH),PABSCO(IPH)
14010 FORMAT(/,
     1'  Scale factor               - ',F10.5,/,
     1'  Overall iso temp parameter - ',F10.5,/,
     1'  Absorption correction      - ',F10.5)
      WRITE(ITTO,11020)
      READ(ITTI,11030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
        WRITE(ITTO,14020)
14020   FORMAT(/,'$ Scale factor: ')
        TEMP1 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1
        IF(TEMP1.GE.0.0) PSCALE(IPH) = TEMP1
        WRITE(ITTO,14030)
14030   FORMAT('$ Overall iso temp parameter: ')
        TEMP1 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1
        IF(TEMP1.GE.0.0) POVISO(IPH) = TEMP1
        WRITE(ITTO,14040)
14040   FORMAT('$ Absorption correction factor: ')
        TEMP1 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1
        IF(TEMP1.GE.0.0) PABSCO(IPH) = TEMP1
        GO TO 13500
      ENDIF
C *
14500 IF( LDBASE .OR. .NOT.LCODE ) GO TO 15000
      ASSIGN 14500 TO IERLBL
      CALL KWDEKO( KSCALE(IPH), 1, KKRND(1,1), CCSHFT(1) )
      CALL KWDEKO( KOVISO(IPH), 2, KKRND(1,2), CCSHFT(2) )
      CALL KWDEKO( KABSCO(IPH), 3, KKRND(1,3), CCSHFT(3) )
      WRITE(ITTO,14510) (CCSHFT(J),J=1,3)
14510 FORMAT(/,
     1'  Scale factor               - ',F8.2,/,
     1'  Overall iso temp parameter - ',F8.2,/,
     1'  Absorption correction      - ',F8.2)
      WRITE(ITTO,11020)
      READ(ITTI,11030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' )  THEN
        TEMP1 = -9.0
        WRITE(ITTO,14520)
14520   FORMAT('$ Scale factor: ')
        READ(ITTI,*,ERR=7000) TEMP1
        IF(TEMP1.GE.0.0) CCSHFT(1) = TEMP1
        CALL KWKODE( KSCALE(IPH), 1, KKRND(1,1), CCSHFT(1) )
        WRITE(ITTO,14530)
14530   FORMAT('$ Overall iso temp parameter: ')
        TEMP1 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1
        IF(TEMP1.GE.0.0) CCSHFT(2) = TEMP1
        CALL KWKODE( KOVISO(IPH), 2, KKRND(1,2), CCSHFT(2) )
        WRITE(ITTO,14540)
14540   FORMAT('$ Absorption correction: ')
        TEMP1 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1
        IF(TEMP1.GE.0.0) CCSHFT(3) = TEMP1
        CALL KWKODE( KABSCO(IPH), 3, KKRND(1,3), CCSHFT(3) )
        GO TO 14500
      ENDIF
C *
15000 IF(.NOT.LPARM) GO TO 15500
      ASSIGN 15000 TO IERLBL
      WRITE(ITTO,15010)
15010 FORMAT(/,' *** Lattice Parameters *** ')
15020 WRITE(ITTO,15030) (PCELL(J,IPH),J=1,6)
15030 FORMAT(/,
     1'  Cell edge lengths a, b and c      - ',3F10.4,/,
     1'  Cell angles alpha, beta and gamma - ',3F10.4)
      WRITE(ITTO,11020)
      READ(ITTI,11030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
        WRITE(ITTO,15040)
15040   FORMAT(/,'$ Cell edge lengths a, b, and c: ')
        TEMP1 = -9.0
        TEMP2 = -9.0
        TEMP3 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
        IF(TEMP1.GT.0.0) PCELL(1,IPH) = TEMP1
        IF(TEMP2.GT.0.0) PCELL(2,IPH) = TEMP2
        IF(TEMP3.GT.0.0) PCELL(3,IPH) = TEMP3
        WRITE(ITTO,15050)
15050   FORMAT('$Cell angles alpha, beta, and gamma: ')
        TEMP1 = -9.0
        TEMP2 = -9.0
        TEMP3 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
        IF(TEMP1.GT.0.0) PCELL(4,IPH) = TEMP1
        IF(TEMP2.GT.0.0) PCELL(5,IPH) = TEMP2
        IF(TEMP3.GT.0.0) PCELL(6,IPH) = TEMP3
        GO TO 15020
      ENDIF
C *
15500 IF( LDBASE .OR. .NOT.LCODE ) GO TO 16000
      ASSIGN 15500 TO IERLBL
      WRITE(ITTO,15110)
15110 FORMAT(/,' *** Fractional shifts for the Lattice Parameters *** ')
15120 CALL KWDEKO( KCELL(1,IPH), 6, KKRND(1,1), CCSHFT(1) )
      WRITE(ITTO,15130) (CCSHFT(J),J=1,6)
15130 FORMAT(/,
     1'  Cell edge lengths a, b and c      - ',3F8.2,/,
     1'  Cell angles alpha, beta and gamma - ',3F8.2)
      WRITE(ITTO,11020)
      READ(ITTI,11030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
        WRITE(ITTO,15140)
15140   FORMAT(/,'$ Cell edge lengths a, b, and c: ')
        TEMP1 = -9.0
        TEMP2 = -9.0
        TEMP3 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
        IF(TEMP1.GE.0.0) CCSHFT(1) = TEMP1
        IF(TEMP2.GE.0.0) CCSHFT(2) = TEMP2
        IF(TEMP3.GE.0.0) CCSHFT(3) = TEMP3
        WRITE(ITTO,15150)
15150   FORMAT('$ Cell angles alpha, beta, and gamma: ')
        TEMP1 = -9.0
        TEMP2 = -9.0
        TEMP3 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
        IF(TEMP1.GE.0.0) CCSHFT(4) = TEMP1
        IF(TEMP2.GE.0.0) CCSHFT(5) = TEMP2
        IF(TEMP3.GE.0.0) CCSHFT(6) = TEMP3
        CALL KWKODE( KCELL(1,IPH), 6, KKRND(1,1), CCSHFT(1) )
        GO TO 15120
      ENDIF
C *
16000 IF( LDBASE .OR. .NOT.LPARM ) GO TO 16500
      ASSIGN 16000 TO IERLBL
      WRITE(ITTO,16010)
16010 FORMAT(/,' *** Profile-Shape-Function Parameters *** ')
      IF( KPSF(1,IPH).LT.1 .OR. KPSF(1,IPH).GT.3 ) KPSF(1,IPH) = 3
      IF( KPSF(2,IPH).LT.0 .OR. KPSF(2,IPH).GT.3 ) KPSF(2,IPH) = 0
16020 IF( KPSF(2,IPH).EQ.2 .OR. KPSF(2,IPH).EQ.3 ) THEN
        WRITE(ITTO,16030) KPSF(1,IPH),QPSF(KPSF(1,IPH)),KPSF(2,IPH),
     1   'Low angle ',(PPSFC(J,1,IPH),J=1,3),
     1   'High angle',(PPSFC(J,2,IPH),J=1,3),
     1   RLIM(IPH),PASYP(IPH)
       ELSE
        WRITE(ITTO,16030) KPSF(1,IPH),QPSF(KPSF(1,IPH)),KPSF(2,IPH),
     1   'Symmetric ',(PPSFC(J,1,IPH),J=1,3),
     1   'Not used  ',(PPSFC(J,2,IPH),J=1,3),
     1   RLIM(IPH),PASYP(IPH)
      ENDIF
16030 FORMAT(/,
     1'  Profile-shape-function            - ',I3,3X,A21,/,
     1'  Split profile                     - ',I3,3X,
     1'0-No  1-FWHM  2-Shape  3-Both',//,
     1'  Profile coefficients (',A10,') - ',3F8.4,/,
     1'                       (',A10,') - ',3F8.4,//,
     1'  Angle for asymmetry parameter     - ',F8.4,/,
     1'  Asymmetry parameter               - ',F8.4)
      WRITE(ITTO,11020)
      READ(ITTI,11030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
        WRITE(ITTO,16040) (I,QPSF(I),I=1,3)
16040   FORMAT(3(/,2X,I1,' - ',A21),//,'$ Profile-shape-function: ')
        ITEMP1 = -9
        READ(ITTI,*,ERR=7000) ITEMP1
        IF( ITEMP1.GT.0 .AND. ITEMP1.LT.4 ) KPSF(1,IPH) = ITEMP1
        WRITE(ITTO,16050)
16050   FORMAT(/,2X,'0-No  1-FWHM  2-Shape  3-Both',//,
     1  '$ Split function: ')
        ITEMP1 = -9
        READ(ITTI,*,ERR=7000) ITEMP1
        IF( ITEMP1.GE.0 .AND. ITEMP1.LE.3 ) THEN
          IF( ( ITEMP1.EQ.1      .OR. ITEMP1.EQ.3      ) .AND.
     1        ( KPSF(2,IPH).EQ.0 .OR. KPSF(2,IPH).EQ.2 )       ) THEN
            PUVW(1,2,IPH) = PUVW(1,1,IPH)
            PUVW(2,2,IPH) = PUVW(2,1,IPH)
            PUVW(3,2,IPH) = PUVW(3,1,IPH)
          ENDIF
          IF( ( ITEMP1.EQ.2      .OR. ITEMP1.EQ.3      ) .AND.
     1        ( KPSF(2,IPH).EQ.0 .OR. KPSF(2,IPH).EQ.1 )       ) THEN
            PPSFC(1,2,IPH) = PPSFC(1,1,IPH)
            PPSFC(2,2,IPH) = PPSFC(2,1,IPH)
            PPSFC(3,2,IPH) = PPSFC(3,1,IPH)
          ENDIF
          KPSF(2,IPH) = ITEMP1
        ENDIF
        IF( KPSF(2,IPH).EQ.2 .OR. KPSF(2,IPH).EQ.3 ) THEN
          WRITE(ITTO,16060) 'Low angle '
         ELSE
          WRITE(ITTO,16060) 'Symmetric '
        ENDIF
16060   FORMAT('  Profile coefficients (',A10,'): ')
        TEMP1 = -9.0
        TEMP2 = -9.0
        TEMP3 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
        IF(TEMP1.NE.-9.0) PPSFC(1,1,IPH) = TEMP1
        IF(TEMP2.NE.-9.0) PPSFC(2,1,IPH) = TEMP2
        IF(TEMP2.NE.-9.0) PPSFC(3,1,IPH) = TEMP3
        IF( KPSF(2,IPH).EQ.2 .OR. KPSF(2,IPH).EQ.3 ) THEN
          WRITE(ITTO,16060) 'High angle'
          TEMP1 = -9.0
          TEMP2 = -9.0
          TEMP3 = -9.0
          READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
          IF(TEMP1.NE.-9.0) PPSFC(1,2,IPH) = TEMP1
          IF(TEMP2.NE.-9.0) PPSFC(2,2,IPH) = TEMP2
          IF(TEMP2.NE.-9.0) PPSFC(3,2,IPH) = TEMP3
        ENDIF
        WRITE(ITTO,16070)
16070   FORMAT('$ Asymmetry parameter angle, value: ')
        TEMP1 = -9.0
        TEMP2 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1,TEMP2
        IF(TEMP1.GE.0.0) RLIM(IPH) = TEMP1
        IF(TEMP2.NE.-9.0) PASYP(IPH) = TEMP2
        GO TO 16020
      ENDIF
C *
16500 IF( LDBASE .OR. .NOT.LCODE ) GO TO 17000
      ASSIGN 16500 TO IERLBL
      WRITE(ITTO,16510)
16510 FORMAT(/,
     1' *** Fractional shifts for the Profile-Shape-Function',
     1' Parameters *** ')
      CALL KWDEKO( KPSFC(1,1,IPH), 3, KKRND(1,1), CCSHFT(1) )
      CALL KWDEKO( KPSFC(1,2,IPH), 3, KKRND(1,4), CCSHFT(4) )
      CALL KWDEKO( KASYP         , 1, KKRND(1,7), CCSHFT(7) )
16520 IF( KPSF(2,IPH).EQ.2 .OR. KPSF(2,IPH).EQ.3 ) THEN
        WRITE(ITTO,16530) 'Low angle ',(CCSHFT(J),J=1,3),
     1   'High angle',(CCSHFT(J),J=4,6),CCSHFT(7)
       ELSE
        WRITE(ITTO,16530) 'Symmetric ',(CCSHFT(J),J=1,3),
     1   'Not used  ',(CCSHFT(J),J=1,3),CCSHFT(7)
      ENDIF
16530 FORMAT(/,
     1'  Profile coefficients (',A10,') - ',3F8.2,/,
     1'                       (',A10,') - ',3F8.2,/,
     1'  Asymmetry parameter               - ',F8.2)
      WRITE(ITTO,11020)
      READ(ITTI,11030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
        IF( KPSF(2,IPH).EQ.2 .OR. KPSF(2,IPH).EQ.3 ) THEN
          WRITE(ITTO,16060) 'Low angle '
         ELSE
          WRITE(ITTO,16060) 'Symmetric '
        ENDIF
        TEMP1 = -9.0
        TEMP2 = -9.0
        TEMP3 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
        IF(TEMP1.NE.-9.0) CCSHFT(1) = TEMP1
        IF(TEMP2.NE.-9.0) CCSHFT(2) = TEMP2
        IF(TEMP2.NE.-9.0) CCSHFT(3) = TEMP3
        CALL KWKODE( KPSFC(1,1,IPH), 3, KKRND(1,1), CCSHFT(1) )
        IF( KPSF(2,IPH).EQ.2 .OR. KPSF(2,IPH).EQ.3 ) THEN
          WRITE(ITTO,16060) 'High angle'
          TEMP1 = -9.0
          TEMP2 = -9.0
          TEMP3 = -9.0
          READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
          IF(TEMP1.NE.-9.0) CCSHFT(4) = TEMP1
          IF(TEMP2.NE.-9.0) CCSHFT(5) = TEMP2
          IF(TEMP2.NE.-9.0) CCSHFT(6) = TEMP3
          CALL KWKODE( KPSFC(1,2,IPH), 3, KKRND(1,4), CCSHFT(4) )
        ENDIF
        WRITE(ITTO,16540)
16540   FORMAT('$ Asymmetry parameter: ')
        TEMP1 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1
        IF(TEMP1.NE.-9.0) CCSHFT(7) = TEMP1
        CALL KWKODE( KASYP, 1, KKRND(1,7), CCSHFT(7) )
        GO TO 16520
      ENDIF
C *
17000 IF( LDBASE .OR. .NOT.LPARM ) GO TO 17500
      ASSIGN 17000 TO IERLBL
      WRITE(ITTO,17010)
17010 FORMAT(/,' *** Profile Broadening Parameters *** ')
17020 IF( KPSF(2,IPH).EQ.1 .OR. KPSF(2,IPH).EQ.3 ) THEN
        WRITE(ITTO,17030) 'Low Angle ',(PUVW(J,1,IPH),J=1,3),
     1   'High Angle',(PUVW(J,2,IPH),J=1,3)
       ELSE
        WRITE(ITTO,17030) 'Symmetric ',(PUVW(J,1,IPH),J=1,3),
     1   'Not used  ',(PUVW(J,2,IPH),J=1,3)
      ENDIF
17030 FORMAT(/,
     1 '  Hk parameters U, V and W (',A10,') - ',3F8.5,/,
     1 '  Hk parameters U, V and W (',A10,') - ',3F8.5)
      WRITE(ITTO,11020)
      READ(ITTI,11030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
        IF( KPSF(2,IPH).EQ.1 .OR. KPSF(2,IPH).EQ.3 ) THEN
          WRITE(ITTO,17040) 'Low Angle '
17040     FORMAT('$ Hk parameters U,V, and W (',A10,'): ')
         ELSE
          WRITE(ITTO,17040) 'Symmetric '
        ENDIF
        TEMP1 = -9.0
        TEMP2 = -9.0
        TEMP3 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
        IF(TEMP1.NE.-9.0) PUVW(1,1,IPH) = TEMP1
        IF(TEMP2.NE.-9.0) PUVW(2,1,IPH) = TEMP2
        IF(TEMP3.NE.-9.0) PUVW(3,1,IPH) = TEMP3
        IF( KPSF(2,IPH).EQ.1 .OR. KPSF(2,IPH).EQ.3 ) THEN
          WRITE(ITTO,17040) 'High Angle'
          TEMP1 = -9.0
          TEMP2 = -9.0
          TEMP3 = -9.0
          READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
          IF(TEMP1.NE.-9.0) PUVW(1,2,IPH) = TEMP1
          IF(TEMP2.NE.-9.0) PUVW(2,2,IPH) = TEMP2
          IF(TEMP3.NE.-9.0) PUVW(3,2,IPH) = TEMP3
        ENDIF
        GO TO 17020
      ENDIF
C *
17500 IF( LDBASE .OR. .NOT.LCODE ) GO TO 18000
      ASSIGN 17500 TO IERLBL
      WRITE(ITTO,17510)
17510 FORMAT(/,
     1' *** Fractional shifts for the Profile Broadening',
     1' Parameters *** ')
17520 CALL KWDEKO( KUVW(1,1,IPH), 3, KKRND(1,1), CCSHFT(1) )
      CALL KWDEKO( KUVW(1,2,IPH), 3, KKRND(1,4), CCSHFT(4) )
      IF( KPSF(2,IPH).EQ.1 .OR. KPSF(2,IPH).EQ.3 ) THEN
        WRITE(ITTO,17530) 'Low Angle ',(CCSHFT(J),J=1,3),
     1   'High Angle',(CCSHFT(J),J=1,3)
       ELSE
        WRITE(ITTO,17530) 'Symmetric ',(CCSHFT(J),J=1,3),
     1   'Not used  ',(CCSHFT(J),J=1,3)
      ENDIF
17530   FORMAT(/,
     1  '  Hk parameters U, V and W (',A10,') - ',3F8.2,/,
     1  '  Hk parameters U, V and W (',A10,') - ',3F8.2)
      WRITE(ITTO,11020)
      READ(ITTI,11030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
        IF( KPSF(2,IPH).EQ.1 .OR. KPSF(2,IPH).EQ.3 ) THEN
          WRITE(ITTO,17540) 'Low angle '
17540     FORMAT('$ Hk parameters U,V, and W (',A10,'): ')
         ELSE
          WRITE(ITTO,17540) 'Symmetric '
        ENDIF
        TEMP1 = -9.0
        TEMP2 = -9.0
        TEMP3 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
        IF(TEMP1.NE.-9.0) CCSHFT(1) = TEMP1
        IF(TEMP2.NE.-9.0) CCSHFT(2) = TEMP2
        IF(TEMP3.NE.-9.0) CCSHFT(3) = TEMP3
        CALL KWKODE( KUVW(1,1,IPH), 3, KKRND(1,1), CCSHFT(1) )
        IF( KPSF(2,IPH).EQ.1 .OR. KPSF(2,IPH).EQ.3 ) THEN
          WRITE(ITTO,17540) 'High Angle'
          TEMP1 = -9.0
          TEMP2 = -9.0
          TEMP3 = -9.0
          READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
          IF(TEMP1.NE.-9.0) CUVW(1,2,IPH) = TEMP1
          IF(TEMP2.NE.-9.0) CUVW(2,2,IPH) = TEMP2
          IF(TEMP3.NE.-9.0) CUVW(3,2,IPH) = TEMP3
          CALL KWKODE( KUVW(1,2,IPH), 3, KKRND(1,4), CCSHFT(4) )
        ENDIF
        GO TO 17520
      ENDIF
C *
18000 IF(.NOT.LPARM) GO TO 18500
      ASSIGN 18000 TO IERLBL
      WRITE(ITTO,18010)
18010 FORMAT(/,' *** Preferred Orientation Parameters *** ')
18020 IF(KPOCT(1,IPH).EQ.0) THEN
        WRITE(ITTO,18030) 'None                '
18030   FORMAT(/,' Correction applied: ',A20)
       ELSE IF(KPOCT(1,IPH).EQ.1) THEN
        WRITE(ITTO,18030) 'Rietveld            '
       ELSE IF(KPOCT(1,IPH).EQ.2) THEN
        WRITE(ITTO,18030) 'March function      '
       ELSE
        WRITE(ITTO,18030) 'Unknown: Set to none'
        KPOCT(1,IPH) = 0
      ENDIF
      WRITE(ITTO,18040) KPOCT(2,IPH)+1
18040 FORMAT(/,' Number of preferred orientation vectors: ',I1)
      WRITE(ITTO,18050) 1,(POVEC(J,1,IPH),J=1,3),(PPREF(J,1,IPH),J=1,2)
18050 FORMAT(/,
     1'  Vector ',I1,'           - ',3F8.4,/,
     1'  Parameters 1 and 2 - ',2F8.4)
      IF(KPOCT(2,IPH).EQ.1) THEN
        WRITE(ITTO,18050) 2,(POVEC(J,2,IPH),J=1,3),
     1   (PPREF(J,2,IPH),J=1,2)
      ENDIF
      WRITE(ITTO,11020)
      READ(ITTI,11030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
        WRITE(ITTO,18060)
18060   FORMAT(/,
     1   '$ Correction type? (0) None (1) Rietveld (2) March: ')
        ITEMP = KPOCT(1,IPH)
        READ(ITTI,*,ERR=7000) ITEMP
        IF( ITEMP.GE.0 .AND. ITEMP.LE.2 ) KPOCT(1,IPH) = ITEMP
        WRITE(ITTO,18070)
18070   FORMAT(/,'$ Number of preferred orientation vectors: ')
        ITEMP = KPOCT(2,IPH) + 1
        READ(ITTI,*,ERR=7000) ITEMP
        IF( ITEMP.GE.1 .AND. ITEMP.LE.2 ) KPOCT(2,IPH) = ITEMP - 1
        DO 18080 IVEC=1,KPOCT(2,IPH)+1
        WRITE(ITTO,18090) IVEC
18090   FORMAT(/,'$ Vector ',I1,': ')
        TEMP1 = -9.0
        TEMP2 = -9.0
        TEMP3 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1,TEMP2,TEMP3
        IF(TEMP1.NE.-9.0) POVEC(1,IVEC,IPH) = TEMP1
        IF(TEMP2.NE.-9.0) POVEC(2,IVEC,IPH) = TEMP2
        IF(TEMP3.NE.-9.0) POVEC(3,IVEC,IPH) = TEMP3
        WRITE(ITTO,18100)
18100   FORMAT('$ Parameters 1 and 2: ')
        TEMP1 = -9.0
        TEMP2 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1,TEMP2
        IF(TEMP1.NE.-9.0) PPREF(1,IVEC,IPH) = TEMP1
        IF(TEMP1.NE.-9.0) PPREF(2,IVEC,IPH) = TEMP2
18080   CONTINUE
        GO TO 18020
      ENDIF
C *
18500 IF( LDBASE .OR. .NOT.LCODE ) GO TO 9000
      ASSIGN 18500 TO IERLBL
      WRITE(ITTO,18510)
18510 FORMAT(/,
     1' *** Fractional shifts for the Preferred Orientation',
     1' Parameters *** ')
18520 CALL KWDEKO( KPREF(1,1,IPH), 2, KKRND(1,1), CCSHFT(1) )
      CALL KWDEKO( KPREF(1,2,IPH), 2, KKRND(1,3), CCSHFT(3) )
      WRITE(ITTO,18530) (CCSHFT(J),J=1,2)
18530 FORMAT(/,
     1'  Preferred orientation vector 1. Parameters 1 and 2 - ',2F8.2)
      IF(KPOCT(1,IPH).EQ.1) THEN
        WRITE(ITTO,18540) (CCSHFT(J),J=3,4)
18540   FORMAT(
     1  '  Preferred orientation vector 2. Parameters 1 and 2 - ',2F8.2)
      ENDIF
      WRITE(ITTO,11020)
      READ(ITTI,11030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
        DO 18550 IVEC=1,KPOCT(2,IPH)+1
        WRITE(ITTO,18560) IVEC
18560   FORMAT(/,
     1  '$ Preferred orientation vector ',I1,'. Parameters 1 and 2: ')
        TEMP1 = -9.0
        TEMP2 = -9.0
        READ(ITTI,*,ERR=7000) TEMP1,TEMP2
        IF(TEMP1.NE.-9.0) CCSHFT((IVEC-1)*2+1) = TEMP1
        IF(TEMP2.NE.-9.0) CCSHFT((IVEC-1)*2+2) = TEMP2
18550   CONTINUE
        CALL KWKODE( KPREF(1,1,IPH), 2, KKRND(1,1), CCSHFT(1) )
        CALL KWKODE( KPREF(1,2,IPH), 2, KKRND(1,3), CCSHFT(3) )
        GO TO 18520
      ENDIF
C *
      GO TO 9000
C *
C **  INPUT ERROR RECOVERY ROUTINE
C *
7000  WRITE(ITTO,7010) QBELL,QBELL
7010  FORMAT(//,1X,A1,
     1'Your input could not be read.  Please re-read the prompt and',
     1' enter the',/,
     1' appropriate information.  (The most likely problem was a mis-',
     1'placed decimal)',A1)
      GO TO IERLBL
C *
C **  JOB COMPLETE ..... RETURN TO MAIN
9000  RETURN
      END
C **  RWDBPH - READ FROM/ WRITE TO THE DATABASE
C *
      SUBROUTINE RWDBPH( QACT, IOUTD, IEOF )
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      LOGICAL LBIN
      CHARACTER QACT*1
C *
C *  DATABASE FILE TYPE: FORMATTED (LBIN=.FALSE.) OR UNFORMATTED (LBIN=.TRUE)
      LBIN = KBIN.EQ.1
C *
C **  DETERMINE WHETHER TO READ OR WRITE THE DESIRED PHASE INFORMATION
C *
C *   ... A READ STARTING ON RECORD IRECRD
1000  IF (QACT.EQ.'R') THEN
         GO TO 2000
        ELSE IF (QACT.EQ.'W') THEN
         GO TO 4000
      ENDIF
      STOP '--RWDBPH: Value of QACT passed was not W/R'
C *
C **  READ PHASE INFORMATION FROM DATABASE
C *
C *  TURN OFF END-OF-FILE HIT FLAG
2000  IEOF = 0
C *
C *  CHECK SOURCE OF READ
      IF (IOUTD.EQ.0) THEN
        IINPT = IDFI
        GO TO 2100
       ELSE IF (IOUTD.EQ.1) THEN
        IINPT = ISCR
        GO TO 2100
       ELSE
        STOP '--RWDBPH: Bad value of IOUTD passed for read operation'
      ENDIF
C *
C *  READ PARAMETER VALUES
C *
2100  IF(LBIN) THEN
        READ(IINPT,END=2900) QPHSNM(IPH),QFORM(IPH)
        READ(IINPT) QCMNT(IPH)
        READ(IINPT) QSGP(IPH),QXTALS(IPH)
        READ(IINPT) NATOM(IPH),KATMPF(IPH),KMAGSF(IPH)
       ELSE
        READ(IINPT,2110,END=2900) QPHSNM(IPH),QFORM(IPH)
2110    FORMAT(A32,A32)
        READ(IINPT,2120) QCMNT(IPH)
2120    FORMAT(A72)
        READ(IINPT,2130) QSGP(IPH),QXTALS(IPH)
2130    FORMAT(A20,A20)
        READ(IINPT,2140) NATOM(IPH),KATMPF(IPH),KMAGSF(IPH)
2140    FORMAT(3I4)
      ENDIF
      IF(QXTALS(IPH).EQ.' ') QXTALS(IPH) = 'N/A'
C *
C *  TEST FOR EXCEEDING LIMIT ON NUMBER OF ATOMS
      IF(NATOM(IPH).GT.MAXATM) THEN
        WRITE(ITTO,2150) QPHSNM(IPH),NATOM(IPH),MAXATM
2150    FORMAT(/,
     1' --The number of atoms for the phase :',A32,/,
     1'   is ',I4,' which exceeds the program limit of ',I4,'.'/,
     1'   Increase the value of * MAXATM * on all parameter',
     1' statements.')
        STOP '--Number of atoms for phase exceeds program limit.'
      ENDIF
C *
C *  ATOM PARAMETERS
      IF(LBIN) THEN
        DO 2160 IATM = 1,NATOM(IPH)
        READ(IINPT) QATOM(IATM,IPH),QSCAT(IATM,IPH),KMAGSI(IATM,IPH),
     1   (PAXYZ(J,IATM,IPH),J=1,3),PBISO(IATM,IPH),POCCU(IATM,IPH),
     1   QASPG(IATM,IPH),(PBAIS(J,IATM,IPH),J=1,6)
        IF(QASPG(IATM,IPH).EQ.' ') QASPG(IATM,IPH) = 'N/A'
        IF(KMAGSI(IATM,IPH).EQ.1) THEN
          READ(IINPT) (PVMAG(J,IATM,IPH),J=1,3)
        ENDIF
2160    CONTINUE
       ELSE
        DO 2170 IATM = 1,NATOM(IPH)
        READ(IINPT,2180) QATOM(IATM,IPH),QSCAT(IATM,IPH),
     1   KMAGSI(IATM,IPH),(PAXYZ(J,IATM,IPH),J=1,3),
     1   PBISO(IATM,IPH),POCCU(IATM,IPH),
     1   QASPG(IATM,IPH),(PBAIS(J,IATM,IPH),J=1,6)
2180    FORMAT(A8,A4,I4,8X,5F8.0,/,A20,4X,6F8.0)
        IF(QASPG(IATM,IPH).EQ.' ') QASPG(IATM,IPH) = 'N/A'
        IF(KMAGSI(IATM,IPH).EQ.1) THEN
          READ(IINPT,2190) (PVMAG(J,IATM,IPH),J=1,3)
2190      FORMAT(24X,3F8.5)
        ENDIF
2170    CONTINUE
      ENDIF
C *
C *  OVERALL SCALE AND ISO TEMP FACTORS
      IF(LBIN) THEN
        READ(IINPT) PSCALE(IPH),POVISO(IPH),PABSCO(IPH)
       ELSE
        READ(IINPT,2200) PSCALE(IPH),POVISO(IPH),PABSCO(IPH)
2200    FORMAT(3F8.0)
      ENDIF
C *
C *  LATTICE PARAMETERS
      IF(LBIN) THEN
        READ(IINPT) (PCELL(J,IPH),J=1,6)
       ELSE
        READ(IINPT,2210) (PCELL(J,IPH),J=1,6)
2210    FORMAT(6F8.0)
      ENDIF
C *
C *  PREFERRED ORIENTATION
      IF(LBIN) THEN
        READ(IINPT) KPOCT(1,IPH),KPOCT(2,IPH),(POVEC(J,1,IPH),J=1,3)
       ELSE
        READ(IINPT,2220)KPOCT(1,IPH),KPOCT(2,IPH),(POVEC(J,1,IPH),J=1,3)
2220    FORMAT(2I4,3F8.0)
      ENDIF
      IF(KPOCT(1,IPH).NE.2) THEN
        PPREF(1,1,IPH) = 0.0
        PPREF(2,1,IPH) = 0.0
       ELSE
        PPREF(1,1,IPH) = 1.0
        PPREF(2,1,IPH) = 0.0
      ENDIF
      IF(KPOCT(2,IPH).EQ.1) THEN
        IF(LBIN) THEN
          READ(IINPT) (POVEC(J,2,IPH),J=1,3)
         ELSE
          READ(IINPT,2230) (POVEC(J,2,IPH),J=1,3)
2230      FORMAT(8X,3F8.0)
        ENDIF
      ENDIF
      IF(KPOCT(1,IPH).NE.2) THEN
        PPREF(1,2,IPH) = 0.0
        PPREF(2,2,IPH) = 0.0
       ELSE
        PPREF(1,2,IPH) = 1.0
        PPREF(2,2,IPH) = 0.0
      ENDIF
C *
C *  INITIALIZE PARAMETERS NOT ON THE DATABASE
C *
C *  ASSIGN PROFILE-SHAPE-FUNCTION PARAMETERS
2400  KPSF(1,IPH) = 3
      KPSF(2,IPH) = 0
      PPSFC(1,1,IPH) = 1.3
      PPSFC(2,1,IPH) = 0.0
      PPSFC(3,1,IPH) = 0.0
      PPSFC(1,2,IPH) = 1.3
      PPSFC(2,2,IPH) = 0.0
      PPSFC(3,2,IPH) = 0.0
      RLIM(IPH)   = 0.0
      PASYP(IPH)  = 0.0
C *
C *  PROFILE BROADENING COEFFICIENTS
      PUVW(1,1,IPH) = 0.0
      PUVW(2,1,IPH) = 0.0
      PUVW(3,1,IPH) = 0.01
      PUVW(1,2,IPH) = 0.0
      PUVW(2,2,IPH) = 0.0
      PUVW(3,2,IPH) = 0.01
C *
C *  INITIALIZE CODEWORDS SINCE THEY ARE NOT ON THE DATABASE
C *
C *  ATOM PARAMETERS
2500  DO 2510 IATM = 1,NATOM(IPH)
      CAXYZ(1,IATM,IPH) = 0.0
      CAXYZ(2,IATM,IPH) = 0.0
      CAXYZ(3,IATM,IPH) = 0.0
      CBISO(IATM,IPH) = 0.0
      COCCU(IATM,IPH) = 0.0
      CVMAG(1,IATM,IPH) = 0.0
      CVMAG(2,IATM,IPH) = 0.0
      CVMAG(3,IATM,IPH) = 0.0
      DO 2510 J=1,6
      CBAIS(J,IATM,IPH) = 0.0
2510  CONTINUE
C *
C *  OVERALL SCALE, ISO TEMP AND ABSORPTION FACTORS
      CSCALE(IPH) = 0.0
      COVISO(IPH) = 0.0
      CABSCO(IPH) = 0.0
C *
C *  PROFILE-SHAPE-FUNCTION PARAMETERS
      CASYP(IPH)  = 0.0
      CPSFC(1,1,IPH) = 0.0
      CPSFC(2,1,IPH) = 0.0
      CPSFC(3,1,IPH) = 0.0
      CPSFC(1,2,IPH) = 0.0
      CPSFC(2,2,IPH) = 0.0
      CPSFC(3,2,IPH) = 0.0
C *
C *  PROFILE BROADENING COEFFICIENTS
      CUVW(1,1,IPH)  = 0.0
      CUVW(2,1,IPH)  = 0.0
      CUVW(3,1,IPH)  = 0.0
      CUVW(1,2,IPH)  = 0.0
      CUVW(2,2,IPH)  = 0.0
      CUVW(3,2,IPH)  = 0.0
C *
C *  LATTICE PARAMETERS
      CCELL(1,IPH) = 0.0
      CCELL(2,IPH) = 0.0
      CCELL(3,IPH) = 0.0
      CCELL(4,IPH) = 0.0
      CCELL(5,IPH) = 0.0
      CCELL(6,IPH) = 0.0
C *
C *  PREFERRED ORIENTATION AND ASYMMETRY PARAMETERS
      CPREF(1,1,IPH) = 0.0
      CPREF(2,1,IPH) = 0.0
      CPREF(1,2,IPH) = 0.0
      CPREF(2,2,IPH) = 0.0
C *
C *  READ OF PHASE DATA READ COMPLETE
      GO TO 9000
C *
C *  EOF WAS HIT... SET FLAG AND RETURN
C *
2900  IEOF = 1
      GO TO 9000
C *
C **  WRITE THE PHASE INFORMATION
C *
C *  DETERMINE WHERE OUTPUT IS TO BE DIRECTED
C *
C *  WRITE TO: SCREEN, SCRATCH FILE, NEW DATABASE.
4000  IF (IOUTD.EQ.0) THEN
        GO TO 5000
       ELSE IF (IOUTD.EQ.1) THEN
        IOUTPT = ISCR
        GO TO 4100
       ELSE IF (IOUTD.EQ.2) THEN
        IOUTPT = IDFO
        GO TO 4100
       ELSE
        STOP '--RWDBPH: Bad value of IOUTD passed for write operation'
      ENDIF
C *
C *  WRITE PARAMETER VALUES ON FILE
C *
C *  WRITE THE DESIRED SET OF PHASE DATA TO THE OUTPUT FILE
4100  IF(LBIN) THEN
        WRITE(IOUTPT) QPHSNM(IPH),QFORM(IPH)
        WRITE(IOUTPT) QCMNT(IPH)
        WRITE(IOUTPT) QSGP(IPH),QXTALS(IPH)
        WRITE(IOUTPT) NATOM(IPH),KATMPF(IPH),KMAGSF(IPH)
       ELSE
        WRITE(IOUTPT,4110) QPHSNM(IPH),QFORM(IPH)
4110    FORMAT(A32,A32)
        WRITE(IOUTPT,4120) QCMNT(IPH)
4120    FORMAT(A72)
        WRITE(IOUTPT,4130) QSGP(IPH),QXTALS(IPH)
4130    FORMAT(A20,A20)
        WRITE(IOUTPT,4140) NATOM(IPH),KATMPF(IPH),KMAGSF(IPH)
4140    FORMAT(3I4)
      ENDIF
C *
C *  ATOM PARAMETERS
      IF(LBIN) THEN
        DO 4150 IATM = 1,NATOM(IPH)
        WRITE(IOUTPT) QATOM(IATM,IPH),QSCAT(IATM,IPH),
     1   KMAGSI(IATM,IPH),(PAXYZ(J,IATM,IPH),J=1,3),PBISO(IATM,IPH),
     1   POCCU(IATM,IPH),QASPG(IATM,IPH),(PBAIS(J,IATM,IPH),J=1,6)
        IF(KMAGSI(IATM,IPH).EQ.1) THEN
          WRITE(IOUTPT) (PVMAG(J,IATM,IPH),J=1,3)
        ENDIF
4150    CONTINUE
       ELSE
        DO 4160 IATM = 1,NATOM(IPH)
        WRITE(IOUTPT,4170) QATOM(IATM,IPH),QSCAT(IATM,IPH),
     1   KMAGSI(IATM,IPH),(PAXYZ(J,IATM,IPH),J=1,3),PBISO(IATM,IPH),
     1   POCCU(IATM,IPH),QASPG(IATM,IPH),(PBAIS(J,IATM,IPH),J=1,6)
4170    FORMAT(A8,A4,I4,8X,5F8.5,/,A20,4X,6F8.5)
        IF(KMAGSI(IATM,IPH).EQ.1) THEN
          WRITE(IOUTPT,4180) (PVMAG(J,IATM,IPH),J=1,3)
4180      FORMAT(24X,3F8.5)
        ENDIF
4160    CONTINUE
      ENDIF
C *
C *  OVERALL SCALE, ISO TEMP FACTORS AND ABSORPTION
      IF(LBIN) THEN
        WRITE(IOUTPT) PSCALE(IPH),POVISO(IPH),PABSCO(IPH)
       ELSE
        WRITE(IOUTPT,4190) PSCALE(IPH),POVISO(IPH),PABSCO(IPH)
4190    FORMAT(F8.3,F8.4,F8.4)
      ENDIF
C *
C *  LATTICE PARAMETERS
      IF(LBIN) THEN
        WRITE(IOUTPT) (PCELL(J,IPH),J=1,6)
       ELSE
        WRITE(IOUTPT,4200) (PCELL(J,IPH),J=1,6)
4200    FORMAT(3F8.4,3F8.4)
      ENDIF
C *
C *  PREFERRED ORIENTATION
      IF(LBIN) THEN
        WRITE(IOUTPT) KPOCT(1,IPH),KPOCT(2,IPH),
     1   (POVEC(J,1,IPH),J=1,3)
        IF(KPOCT(2,IPH).EQ.1) THEN
          WRITE(IOUTPT) (POVEC(J,2,IPH),J=1,3)
        ENDIF
       ELSE
        WRITE(IOUTPT,4210) KPOCT(1,IPH),KPOCT(2,IPH),
     1   (POVEC(J,1,IPH),J=1,3)
4210    FORMAT(2I4,3F8.4)
        IF(KPOCT(2,IPH).EQ.1) THEN
          WRITE(IOUTPT,4220) (POVEC(J,2,IPH),J=1,3)
        ENDIF
4220    FORMAT(8X,3F8.4)
      ENDIF
C *
      GO TO 9000
C *
C **  WRITE THE DESIRED SET OF PHASE DATA TO THE SCREEN
C *
5000  WRITE(ITTO,5010) QPHSNM(IPH),QFORM(IPH)
5010  FORMAT(1X,A32,A32)
      WRITE(ITTO,5020) QSGP(IPH),QXTALS(IPH)
5020  FORMAT(1X,A20,A20)
      WRITE(ITTO,5030) NATOM(IPH),KATMPF(IPH),KMAGSF(IPH)
5030  FORMAT(1X,3I4)
C *
C *  ATOM PARAMETERS
      DO 5040 IATM = 1,NATOM(IPH)
      WRITE(ITTO,5050) QATOM(IATM,IPH),QSCAT(IATM,IPH),KMAGSI(IATM,IPH),
     1 (PAXYZ(J,IATM,IPH),J=1,3),PBISO(IATM,IPH),POCCU(IATM,IPH),
     1 QASPG(IATM,IPH),(PBAIS(J,IATM,IPH),J=1,6)
5050  FORMAT(1X,A8,A4,I4,8X,5F8.5,/,1X,A20,4X,6F8.5)
      IF(KMAGSI(IATM,IPH).EQ.1) THEN
        WRITE(ITTO,5052) (PVMAG(J,IATM,IPH),J=1,3)
5052    FORMAT(25X,3F8.5)
      ENDIF
5040  CONTINUE
C *
C *  OVERALL SCALE, ISO TEMP AND ABSORPTION FACTORS
      WRITE(ITTO,5060) PSCALE(IPH),POVISO(IPH),PABSCO(IPH)
5060  FORMAT(1X,F8.3,2F8.4)
C *
C *  LATTICE PARAMETERS
      WRITE(ITTO,5080) (PCELL(J,IPH),J=1,6)
5080  FORMAT(1X,3F8.4,3F8.4)
C *
C *  PREFERRED ORIENTATION PARAMETERS
      WRITE(ITTO,5090) KPOCT(1,IPH),KPOCT(2,IPH),(POVEC(J,1,IPH),J=1,3)
5090  FORMAT(1X,2I4,3F8.4)
      IF(KPOCT(2,IPH).EQ.1) THEN
        WRITE(ITTO,5092) (POVEC(J,2,IPH),J=1,3)
5092    FORMAT(1X,8X,3F8.4)
      ENDIF
C *
C **  JOB COMPLETE.... RETURN TO PREVIOUS SUBROUTINE
9000  RETURN
      END
C **  SWITCH - SWITCH COPIES THE SCRATCH FILE INTO RIQAS.XTL
C *
      SUBROUTINE SWITCH
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QRECL*80,QRECL1(80)*1
      EQUIVALENCE (QRECL, QRECL1)
C *
C *  CLOSE DATA FILE WITH DELETE OPTION AND RE-OPEN AS A NEW FILE
C *
      CLOSE(UNIT=IDFI,STATUS='DELETE')
      IF(KBIN.EQ.1) THEN
CIBM
        OPEN(UNIT=IDFO,FILE='RIQAS.XTL',STATUS='NEW',FORM='UNFORMATTED')
CIBM
CVAX
C       OPEN(UNIT=IDFO,FILE='RIQAS.XTL',STATUS='NEW',FORM='UNFORMATTED',
C    2   CARRIAGECONTROL='LIST')
CVAX
       ELSE
CIBM
        OPEN(UNIT=IDFO,FILE='RIQAS.XTL',STATUS='NEW',FORM='FORMATTED')
CIBM
CVAX
C       OPEN(UNIT=IDFO,FILE='RIQAS.XTL',STATUS='NEW',FORM='FORMATTED',
C    2   CARRIAGECONTROL='LIST')
CVAX
      ENDIF
C *
1000  WRITE(ITTO,1010)
1010  FORMAT(/,' *** COPYING DATA TO NEW FILE ... PLEASE WAIT *** ')
C *
C *  TEST FOR NECESSARY OVERWRITE OF PHASE IN MAXPHS AREA
      IF(NPHS.LT.MAXPHS) GO TO 2000
      WRITE(ITTO,1020) MAXPHS
1020  FORMAT(/,
     1' --Data for phase ',I2,' was overwritten and deleted in the',
     1' copying operation.')
      NPHS = MAXPHS - 1
C *
C *  REWIND THE SCRATCH FILE AND COPY RECORDS INTO NEW DATABASE FILE
2000  REWIND (ISCR)
C *
C *  READ PHASES FROM THE DATABASE FILE
2100  DO 2110 IPH=NPHS+1,MAXPHS
      CALL RWDBPH( 'R', 1, IREOF )
C *
C *  CHECK FOR THE EOF HIT
      IF(IREOF.EQ.1) GO TO 2120
C *
C *  NEXT INPUT PHASE
2110  CONTINUE
      IPH  = MAXPHS + 1
2120  NOUT = IPH - 1
C *
C *  WRITE THE PHASES TO THE OUTPUT FILE
      DO 2130 IPH=NPHS+1,NOUT
      CALL RWDBPH( 'W', 2, IWEOF )
2130  CONTINUE
C *
C *  PROCESS MORE PHASES IF THE EOF HAS NOT BEEN HIT
      IF(IREOF.NE.1) GO TO 2100
C *
C ** CLOSE AND REOPEN DATA FILE FOR READ OPERATIONS
C *
3000  CLOSE(UNIT=IDFO)
      IF(KBIN.EQ.1) THEN
        OPEN(UNIT=IDFI,FILE='RIQAS.XTL',STATUS='OLD',FORM='UNFORMATTED')
       ELSE
        OPEN(UNIT=IDFI,FILE='RIQAS.XTL',STATUS='OLD',FORM='FORMATTED')
      ENDIF
C *
C **  JOB COMPLETE.... RETURN TO MAIN
9000  RETURN
      END
C *  DEFINE DEFAULT RIETVELD CONTROL-FILE HEADER VALUES
C *
      BLOCK DATA GLOBAL
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
C *  PARAMETER MULTIPLES USED FOR INITIALIZATION
      PARAMETER ( MATMP  = MAXATM * MAXPHS     )
      PARAMETER ( MATMP3 = MAXATM * MAXPHS * 3 )
      PARAMETER ( MATMP6 = MAXATM * MAXPHS * 6 )
      PARAMETER ( MST9   = MAXSCA * 9          )
C *
C *  DATABASE PHASE FORMULA AND REFERENCE
C *
      DATA QFORM                          / MAXPHS * ' '               /
      DATA QCMNT                          / MAXPHS * ' '               /
C *
C *  RIETVELD CONTROL AND OUTPUT FLAGS
C *
      DATA JOBXN,NBCKGD,KWSGON            / 1, 0, 0                    /
      DATA NEXCRG,NSCAT                   / 0, 0                       /
      DATA KINTSF,KAMOR                   / 0, 0                       /
      DATA KAUTOV,KAUTOR                  / 20 * 0, 20 * 3             /
      DATA KINTSN,RINTSQ                  / 0, 0.0                     /
      DATA KINTSA,RINTSA                  / 3 * 0, 3 * 0.0             /
      DATA IOUT,IPLT,IPCH,MAT             / 0, 0, 0, 0                 /
      DATA NXT,LST1,LST2,LST3             / 1, 0, 0, 0                 /
      DATA ISYM,IPLT2                     / 0, 1                       /
      DATA KCLRCW                         / 0                          /
      DATA QRFILE                         / ' '                        /
      DATA KHCPLT                         / 6 * 1                      /
C *
C *  RIETVELD CONTROL PARAMETERS
C *
      DATA WAVE1,WAVE2,RATIO              / 1.5406, 1.5443, 0.50       /
      DATA WDT,CTHM                       / 20.000, 1.0000             /
      DATA THMIN,STEP,THMAX               / 0.0000, 0.0000, 0.0000     /
      DATA RELAX,EPS                      / 4 * 1.00, 0.3              /
C *
C *  DATA FOR EXTRAPOLATED BACKGROUND
      DATA POS,BCK                        / MAXBCK * 0.0, MAXBCK * 0.0 /
C *
C *  DATA FOR EXCLUDED REGIONS
      DATA ALOW,AHIGH                     / MAXEXC * 0.0, MAXEXC * 0.0 /
C *
C *  DATA FOR SCATTERING FACTORS
      DATA QSCNAM                         / MAXSCA * '    '            /
      DATA DFP,DFPP                       / MAXSCA * 0.0, MAXSCA * 0.0 /
      DATA POSI                           / MAXSEN * 0.0               /
      DATA SCAT                           / MAXSEN * 0.0               /
      DATA AC                             / MST9   * 0.0               /
C *
C *  ATOM, PHASE AND GLOBAL PARAMETERS
C *
C *  DATA FOR CONTROL FILE TITLE
      DATA QTITLE                          / ' '                       /
C *
C *  PHASE HEADER
      DATA QSGP                            / MAXPHS * ' '              /
      DATA QXTALS                          / MAXPHS * ' '              /
      DATA QPHSNM                          / MAXPHS * ' '              /
      DATA KINDRF                          / MAXPHS * 0                /
      DATA NATOM                           / MAXPHS * 0                /
      DATA KATMPF                          / MAXPHS * 0                /
      DATA KMAGSF                          / MAXPHS * 0                /
C *
      DATA PAXYZ                           / MATMP3 * 0.0              /
      DATA POCCU                           / MATMP  * 0.0              /
      DATA PBISO                           / MATMP  * 0.0              /
      DATA PBAIS                           / MATMP6 * 0.0              /
      DATA KAXYZ                           / MATMP3 * 0                /
      DATA KOCCU                           / MATMP  * 0                /
      DATA KBISO                           / MATMP  * 0                /
      DATA KBAIS                           / MATMP6 * 0                /
      DATA QASPG                           / MATMP  * ' '              /
      DATA KMAGSI                          / MATMP  * 0                /
      DATA ((PVMAG(1,J,I),J=1,MAXATM),I=1,MAXPHS)
     1                                     / MATMP  * 0.0              /
      DATA ((PVMAG(2,J,I),J=1,MAXATM),I=1,MAXPHS)
     1                                     / MATMP  * 0.0              /
      DATA ((PVMAG(3,J,I),J=1,MAXATM),I=1,MAXPHS)
     1                                     / MATMP  * 0.0              /
C *
      DATA PSCALE                          / MAXPHS * 5.0              /
      DATA POVISO                          / MAXPHS * 0.0              /
      DATA PABSCO                          / MAXPHS * 0.0              /
      DATA KSCALE                          / MAXPHS * 1                /
      DATA KOVISO                          / MAXPHS * 0                /
      DATA KABSCO                          / MAXPHS * 0                /
C *
      DATA (KPSF(1,J),J=1,MAXPHS)          / MAXPHS * 3                /
      DATA (KPSF(2,J),J=1,MAXPHS)          / MAXPHS * 0                /
      DATA (PPSFC(1,1,J),J=1,MAXPHS)       / MAXPHS * 1.0              /
      DATA (PPSFC(2,1,J),J=1,MAXPHS)       / MAXPHS * 0.0              /
      DATA (PPSFC(3,1,J),J=1,MAXPHS)       / MAXPHS * 0.0              /
      DATA (PPSFC(1,2,J),J=1,MAXPHS)       / MAXPHS * 1.0              /
      DATA (PPSFC(2,2,J),J=1,MAXPHS)       / MAXPHS * 0.0              /
      DATA (PPSFC(3,2,J),J=1,MAXPHS)       / MAXPHS * 0.0              /
      DATA (KPSFC(1,1,J),J=1,MAXPHS)       / MAXPHS * 4                /
      DATA (KPSFC(2,1,J),J=1,MAXPHS)       / MAXPHS * 0                /
      DATA (KPSFC(3,1,J),J=1,MAXPHS)       / MAXPHS * 0                /
      DATA (KPSFC(1,2,J),J=1,MAXPHS)       / MAXPHS * 4                /
      DATA (KPSFC(2,2,J),J=1,MAXPHS)       / MAXPHS * 0                /
      DATA (KPSFC(3,2,J),J=1,MAXPHS)       / MAXPHS * 0                /
      DATA PASYP                           / MAXPHS * 0.0              /
      DATA KASYP                           / MAXPHS * 0                /
C *
      DATA (PUVW(1,1,J),J=1,MAXPHS)        / MAXPHS * 0.0              /
      DATA (PUVW(2,1,J),J=1,MAXPHS)        / MAXPHS * 0.0              /
      DATA (PUVW(3,1,J),J=1,MAXPHS)        / MAXPHS * 0.0100           /
      DATA (PUVW(1,2,J),J=1,MAXPHS)        / MAXPHS * 0.0              /
      DATA (PUVW(2,2,J),J=1,MAXPHS)        / MAXPHS * 0.0              /
      DATA (PUVW(3,2,J),J=1,MAXPHS)        / MAXPHS * 0.0100           /
      DATA (KUVW(1,1,J),J=1,MAXPHS)        / MAXPHS * 4                /
      DATA (KUVW(2,1,J),J=1,MAXPHS)        / MAXPHS * 3                /
      DATA (KUVW(3,1,J),J=1,MAXPHS)        / MAXPHS * 2                /
      DATA (KUVW(1,2,J),J=1,MAXPHS)        / MAXPHS * 4                /
      DATA (KUVW(2,2,J),J=1,MAXPHS)        / MAXPHS * 3                /
      DATA (KUVW(3,2,J),J=1,MAXPHS)        / MAXPHS * 2                /
C *
      DATA (KCELL(1,J),J=1,MAXPHS)         / MAXPHS * 2                /
      DATA (KCELL(2,J),J=1,MAXPHS)         / MAXPHS * 0                /
      DATA (KCELL(3,J),J=1,MAXPHS)         / MAXPHS * 0                /
      DATA (KCELL(4,J),J=1,MAXPHS)         / MAXPHS * 0                /
      DATA (KCELL(5,J),J=1,MAXPHS)         / MAXPHS * 0                /
      DATA (KCELL(6,J),J=1,MAXPHS)         / MAXPHS * 0                /
C *
      DATA (PPREF(1,1,J),J=1,MAXPHS)       / MAXPHS * 0.0              /
      DATA (PPREF(1,2,J),J=1,MAXPHS)       / MAXPHS * 0.0              /
      DATA (PPREF(2,1,J),J=1,MAXPHS)       / MAXPHS * 0.0              /
      DATA (PPREF(2,2,J),J=1,MAXPHS)       / MAXPHS * 0.0              /
      DATA (KPREF(1,1,J),J=1,MAXPHS)       / MAXPHS * 0                /
      DATA (KPREF(1,2,J),J=1,MAXPHS)       / MAXPHS * 0                /
      DATA (KPREF(2,1,J),J=1,MAXPHS)       / MAXPHS * 0                /
      DATA (KPREF(2,2,J),J=1,MAXPHS)       / MAXPHS * 0                /
C *
      DATA PZERPT,PDISP                    / 0.0, 0.0                  /
      DATA KZERPT,KDISP                    / 0, 3                      /
      DATA PAMORP                          / 3 * 0.0                   /
      DATA KAMORP                          / 2, 3, 3                   /
      DATA PBKG                            / 6 * 0.0                   /
      DATA KBKG                            / 1, 2, 3, 4, 0, 0          /
C *
C *  MEMORY MANAGEMENT PARAMETERS
C *
      DATA NPHS,IPH,CWRDOS                 / 0, MAXPHS, 1.0            /
C *
      END
C **  ADDATA - ADD PHASE DATA TO THE DATABASE
C *
      SUBROUTINE ADDATA
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QRECL*80, QRECL1(80)*1
      EQUIVALENCE (QRECL,QRECL1)
C *
C **  TELL THE USER WE WILL BE ADDING PHASE DATA
C *
1000  WRITE(ITTO,1001)
1001  FORMAT(//,' *** PHASE ENTRY *** ',//,
     1' Change the following information to reflect you data.')
C *
C *  SET THE PHASE SUBSCRIPT TO SCRATCH AREA
      IPH = MAXPHS
C *
C *  CALL STPDEF TO SET DEFAULT PHASE PARAMETERS
      CALL STPDEF
C *
C *  CALL EDIT TO ALLOW FOR CHANGING THE PARAMETERS
      CALL EDIT( .TRUE., .FALSE., .TRUE. )
C *
C **  WRITE THE DATA TO THE SCRATCH FILE, COPY EXISTING DATA, REWRITE FILE
C *
C *  OPEN THE SCRATCH UNIT NEW FOR DATABASE OUTPUT
4000  IF(KBIN.EQ.1) THEN
        OPEN(UNIT=ISCR,STATUS='SCRATCH',FORM='UNFORMATTED')
       ELSE
        OPEN(UNIT=ISCR,STATUS='SCRATCH',FORM='FORMATTED')
      ENDIF
C *
C *  WRITE THE CURRENT SET OF DATA TO THE SCRATCH FILE
      CALL RWDBPH( 'W', 1, IEOF )
C *
C *  REWIND THE EXISTING DATABASE TO ENSURE THAT WE ARE AT THE TOP OF THE FILE
      REWIND(IDFI)
C *
C *  READ THE NEXT PHASE FROM THE FILE
4010  CALL RWDBPH( 'R', 0, IEOF )
C *
C *  IF THE EOF WAS HIT THEN ALL PHASES ARE COPIED
      IF(IEOF.EQ.1) GO TO 4100
C *
C *  WRITE TO THE SCRATCH FILE
      CALL RWDBPH( 'W', 1, IEOF )
C *
C *  GET THE NEXT PHASE
      GO TO 4010
C *
C *   WRITE PRESERVED DATA FROM THE SCRATCH FILE TO IDFI
4100  CALL SWITCH
C *
C *  CLOSE SCRATCH FILE
      CLOSE(UNIT=ISCR,STATUS='DELETE')
C *
C **  UPDATE INDEX FILE
C *
4700  CALL INDEX
C *
C **  JOB COMPLETE.... RETURN TO MAIN
C *
9000  RETURN
      END
C ***  STPDEF - SET PARAMETER AND CODEWORD DEFAULTS FOR PHASES IN MEMORY
C *
      SUBROUTINE STPDEF
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
C **  REPEAT FOR PHASE IPH IN COMMON
C *
      QPHSNM(IPH) = 'N/A'
      QFORM(IPH)  = 'N/A'
      QCMNT(IPH)  = 'N/A'
C *
      QSGP(IPH)   = 'N/A'
      QXTALS(IPH) = 'N/A'
C *
      NATOM(IPH) = 1
      KATMPF(IPH) = 0
      KMAGSF(IPH) = 0
C *
C *  SET THE ATOM PARAMETERS
C *
      DO 110 LOOP = 1,MAXATM
C *
      QATOM(LOOP,IPH) = 'N/A'
      QSCAT(LOOP,IPH) = 'N/A'
      PAXYZ(1,LOOP,IPH) = 0.0
      PAXYZ(2,LOOP,IPH) = 0.0
      PAXYZ(3,LOOP,IPH) = 0.0
      PBISO(LOOP,IPH) = 0.0
      POCCU(LOOP,IPH) = 0.0
      DO 112 J=1,6
      PBAIS(J,LOOP,IPH) = 0.0
112   CONTINUE
      DO 114 J=1,3
      PVMAG(J,LOOP,IPH) = 0.0
114   CONTINUE
      QASPG(LOOP,IPH) = 'N/A'
C *
110   CONTINUE
C *
      PSCALE(IPH) = 5.0
      POVISO(IPH) = 0.0
      PABSCO(IPH) = 0.0
C *
      KPSF(1,IPH) = 3
      KPSF(2,IPH) = 0
      PASYP(IPH)  = 0.0
      RLIM(IPH)   = 0.0
      PPSFC(1,1,IPH) = 1.0
      PPSFC(2,1,IPH) = 0.0
      PPSFC(3,1,IPH) = 0.0
      PPSFC(1,2,IPH) = 1.0
      PPSFC(2,2,IPH) = 0.0
      PPSFC(3,2,IPH) = 0.0
C *
      PUVW(1,1,IPH) = 0.0
      PUVW(2,1,IPH) = 0.0
      PUVW(3,1,IPH) = 0.01
      PUVW(1,2,IPH) = 0.0
      PUVW(2,2,IPH) = 0.0
      PUVW(3,2,IPH) = 0.01
C *
      PCELL(1,IPH) = 0.0
      PCELL(2,IPH) = 0.0
      PCELL(3,IPH) = 0.0
      PCELL(4,IPH) = 0.0
      PCELL(5,IPH) = 0.0
      PCELL(6,IPH) = 0.0
C *
      KPOCT(1,IPH)   =   0
      KPOCT(2,IPH)   =   0
      POVEC(1,1,IPH) = 0.0
      POVEC(2,1,IPH) = 0.0
      POVEC(3,1,IPH) = 0.0
      PPREF(1,1,IPH) = 0.0
      PPREF(2,1,IPH) = 0.0
      POVEC(1,2,IPH) = 0.0
      POVEC(2,2,IPH) = 0.0
      POVEC(3,2,IPH) = 0.0
      PPREF(1,2,IPH) = 0.0
      PPREF(2,2,IPH) = 0.0
C *
      DO 130 LOOP = 1,MAXATM
C *
      CAXYZ(1,LOOP,IPH) = 0.0
      CAXYZ(2,LOOP,IPH) = 0.0
      CAXYZ(3,LOOP,IPH) = 0.0
      CBISO(LOOP,IPH) = 0.0
      COCCU(LOOP,IPH) = 0.0
      DO 132 J=1,6
      CBAIS(J,LOOP,IPH) = 0.0
132   CONTINUE
      DO 134 J=1,3
      CVMAG(J,LOOP,IPH) = 0.0
134   CONTINUE
C *
130   CONTINUE
C *
C *  SET THE GLOBAL PARAMETER CODEWORDS
C *
      CSCALE(IPH) = 0.0
      COVISO(IPH) = 0.0
      CABSCO(IPH) = 0.0
C *
      CPSFC(1,1,IPH) = 0.0
      CPSFC(2,1,IPH) = 0.0
      CPSFC(3,1,IPH) = 0.0
      CPSFC(1,2,IPH) = 0.0
      CPSFC(2,2,IPH) = 0.0
      CPSFC(3,2,IPH) = 0.0
      CASYP(IPH)     = 0.0
C *
      CUVW(1,1,IPH) = 0.0
      CUVW(2,1,IPH) = 0.0
      CUVW(3,1,IPH) = 0.0
      CUVW(1,2,IPH) = 0.0
      CUVW(2,2,IPH) = 0.0
      CUVW(3,2,IPH) = 0.0
C *
      CCELL(1,IPH) = 0.0
      CCELL(2,IPH) = 0.0
      CCELL(3,IPH) = 0.0
      CCELL(4,IPH) = 0.0
      CCELL(5,IPH) = 0.0
      CCELL(6,IPH) = 0.0
C *
      CPREF(1,1,IPH) = 0.0
      CPREF(2,1,IPH) = 0.0
      CPREF(1,2,IPH) = 0.0
      CPREF(2,2,IPH) = 0.0
C *
C *  JOB COMPLETE
9000  RETURN
      END
C **  DBEDIT - ALLOWS CHANGES TO BE MADE TO AN EXISTING DATABASE PHASE
C *
      SUBROUTINE DBEDIT
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QANS*1,QSTR*80
C *
C *  USE THE SCRATCH PHASE AREA
1000  IPH = MAXPHS
C *
C *  GET THE NAME OF THE PHASE AND READ THE DESIRED INFORMATION
      CALL RETRIV( NPHAS )
C *
C *  IF NO PHASE WAS SPECIFIED THEN EXIT NOW
      IF (NPHAS.EQ.0) GO TO 9000
C *
C *  CALL EDIT TO EDIT PHASE DATA
      CALL EDIT( .TRUE., .FALSE., .TRUE. )
C *
C **  MAKE CORRECTIONS TO DATA BASE
C *
C * OPEN SCRATCH FILE
8000  IF(KBIN.EQ.1) THEN
        OPEN(UNIT=ISCR,STATUS='SCRATCH',FORM='UNFORMATTED')
       ELSE
        OPEN(UNIT=ISCR,STATUS='SCRATCH',FORM='FORMATTED')
      ENDIF
C *
C *  WRITE CURRENT PHASE DATA TO THE SCRATCH FILE
      CALL RWDBPH( 'W', 1, IEOF )
C *
C *  DELETE THE OLD DATA
      CALL DELETE( 0 )
C *
C *  CLOSE SCRATCH FILE
      CLOSE(UNIT=ISCR,STATUS='DELETE')
C *
C **  JOB COMPLETE ..... RETURN TO MAIN
9000  RETURN
      END
C **  DELETE - DELETE PHASE DATA FROM THE DATA BASE
C *
      SUBROUTINE DELETE( IFIND )
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      LOGICAL LFIRST
      CHARACTER QANS*1,QJUNK*1
C *
C *  DETERMINE IF THERE IS UNSED SPACE IN MEMORY TO DO THIS
C *
      IF(NPHS.GE.MAXPHS) THEN
        WRITE(ITTO,110)
110     FORMAT(/,
     1 ' --There is no room in memory for scratch phases.  Please exit',
     1 ' the program and',/,
     1 '   start this operation again.')
        GO TO 9000
      ENDIF
C *
C *  EITHER FIND THE PHASE NAME IF NOT KNOWN OR ...
      IF (IFIND.EQ.1) GO TO 1000
C *
C *  ... GO DIRECTLY TO DELETION IF PHASE NAME IS KNOWN
      IF (IFIND.EQ.0) GO TO 2000
C *
C *  ... NO OPTION PASSED.  BETTER ABORT
      STOP'--DELETE: Unknown option coded passed'
C *
C **  GET PHASE TO BE DELETED FROM THE USER
C *
C *  USE THE SCRATCH AREA
1000  IPH = MAXPHS
C *
C *  QUERY FOR THE PHASE TO BE DELETED
      CALL RETRIV( NPHAS )
C *
C *  GO TO MAIN MENU IF NO DELETE DESIRED
      IF (NPHAS.EQ.0) GO TO 9000
C *
C *  ENSURE THAT A DELETION IS WANTED
      WRITE(ITTO,1010)
1010  FORMAT('$ARE YOU SURE YOU WANT TO DELETE THIS DATA? (y/n) <n> ')
      READ(ITTI,1020) QANS
1020  FORMAT(A1)
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) GO TO 9000
C *
C **  DELETE INDICATED PHASE FROM FILE
C *
C *  OPEN THE SCRATCH FILE
2000  IF(KBIN.EQ.1) THEN
        OPEN(UNIT=ISCR,STATUS='SCRATCH',FORM='UNFORMATTED')
       ELSE
        OPEN(UNIT=ISCR,STATUS='SCRATCH',FORM='FORMATTED')
      ENDIF
C *
C * REWIND DATA BASE
      REWIND(IDFI)
C *
C *  JUST DELETE FIRST PHASE WITH THE INDICATED NAME
      LFIRST = .TRUE.
C *
C *  READ PHASE DATA FROM THE FILE
2010  DO 2020 IPH=NPHS+1,MAXPHS
      CALL RWDBPH( 'R', 0, IREOF )
C *
C *  TEST IF THE EOF WAS HIT
      IF(IREOF.EQ.1) GO TO 2030
C *
C *  READ NEXT PHASE
2020  CONTINUE
      IPH  = MAXPHS + 1
2030  NOUT = IPH - 1
C *
C *  WRITE THE PHASE.  SKIP THE INDICATED PHASE
      DO 2040 IPH=NPHS+1,NOUT
      IF( QPHSNM(IPH).EQ.QPHS .AND. LFIRST ) THEN
        LFIRST = .FALSE.
       ELSE
        CALL RWDBPH( 'W', 1, IEOF )
      ENDIF
2040  CONTINUE
C *
C *  READ NEXT SET OF PHASE DATA
      IF(IREOF.NE.1) GO TO 2010
C *
C *   WRITE PRESERVED DATA FROM THE SCRATCH FILE TO THE NEW DATABASE
      CALL SWITCH
C *
C *  CLOSE THE SCRATCH FILE
      CLOSE(UNIT=ISCR,STATUS='DELETE')
C *
C *  UPDATE THE INDEX FILE
      CALL INDEX
C *
C **  JOB COMPLETE ..... RETURN TO MAIN
9000  RETURN
      END
C **  DBCONV - CONVERT A DATABASE FORMAT
C *
      SUBROUTINE DBCONV
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      LOGICAL LEXIST
C *
C *  TELL THE USER THE CURRENT FORM OF THE DATABASE
1000  IF(KBIN.EQ.1) THEN
        WRITE(ITTO,1010) 'UNFORMATTED','FORMATTED  '
       ELSE
        WRITE(ITTO,1010) 'FORMATTED  ','UNFORMATTED'
      ENDIF
1010    FORMAT(/,' ***  Convert database format',//,
     1  ' The database currently in use is ',A11,/,
     1  '  The new database will be written ',A11)
C *
C *  DETERMINE THE NUMBER OF UNUSED PHASE AREAS IN MEMORY
      IF(NPHS.LT.MAXPHS) GO TO 1100
      WRITE(ITTO,1020)
1020  FORMAT(/,
     1' --There is no room in memory for scratch phases.  Please exit',
     1' the program and',/,
     1'   start this operation again.')
      GO TO 9000
C *
C *  GET THE OUTPUT FILE NAME
1100  WRITE(ITTO,1110)
1110  FORMAT(/,'$Name for the output file? (file.ext/EXIT) <EXIT> ')
      READ(ITTI,1030) QFILE
1030  FORMAT(A64)
      IF( QFILE.EQ.' ' .OR. QFILE.EQ.'/' .OR. QFILE.EQ.'EXIT' .OR.
     1    QFILE.EQ.'exit' ) GO TO 9000
C *
C *  OPEN THE OUTPUT FILE
2000  INQUIRE(FILE=QFILE,EXIST=LEXIST)
      IF(LEXIST) THEN
        WRITE(ITTO,2010)
2010    FORMAT(/,' Deleting existing file with same name...')
        OPEN(UNIT=IDFO,FILE=QFILE,STATUS='OLD')
        CLOSE(UNIT=IDFO,STATUS='DELETE')
      ENDIF
      IF(KBIN.EQ.1) THEN
        OPEN(UNIT=IDFO,FILE=QFILE,STATUS='NEW',FORM='FORMATTED')
       ELSE
        OPEN(UNIT=IDFO,FILE=QFILE,STATUS='NEW',FORM='UNFORMATTED')
      ENDIF
C *
C *  REWIND THE DATABASE FILE
      REWIND(IDFI)
C *
C *  REMEMBER THE ORIGINAL FORM OF THE DATABASE
      KBINST = KBIN
C *
C *  READ PHASES FROM THE DATABASE FILE
2100  DO 2110 IPH=NPHS+1,MAXPHS
      CALL RWDBPH( 'R', 0, IREOF )
C *
C *  CHECK FOR THE EOF HIT
      IF(IREOF.EQ.1) GO TO 2120
C *
C *  NEXT INPUT PHASE
2110  CONTINUE
      IPH  = MAXPHS + 1
2120  NOUT = IPH - 1
C *
C *  CHANGE FILE FORMAT TYPE
2200  IF(KBINST.EQ.1) THEN
        KBIN = 0
       ELSE
        KBIN = 1
      ENDIF
C *
C *  WRITE THE PHASES TO THE OUTPUT FILE
      DO 2210 IPH=NPHS+1,NOUT
      CALL RWDBPH( 'W', 2, IWEOF )
2210  CONTINUE
C *
C *  RETURN THE FILE FORMAT TO ITS ORIGINAL FORM
      KBIN = KBINST
C *
C *  PROCESS MORE PHASES IF THE EOF HAS NOT BEEN HIT
      IF(IREOF.NE.1) GO TO 2100
C *
C *  CLOSE THE CONVERTED FILE
3000  CLOSE(UNIT=IDFO,STATUS='KEEP')
C *
C **  JOB COMPLETE ..... RETURN TO MAIN
9000  RETURN
      END
C **  CALPAT - EASY SETUP FOR CALCULATING A POWDER PATTERN
C *
      SUBROUTINE CALPAT
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QOPT*1, QANS*1
C *
C **  INITIALIZE PARAMETERS FOR THE CALCULATED PATTERN
C *
C *  RESET NUMBER OF PHASES IN MEMORY TO 0
1000  NPHS = 0
C *
C **  GET PHASE DATA
C *
2000   DO 2010 IPH=1,MAXPHS-1
C *
C *  DETERMINE INFORMATION SOURCE
2020  WRITE(ITTO,2030) IPH
2030  FORMAT(/,' ***  PHASE ',I2,' parameters.',//,
     1'   (I)nput the data at the terminal',/,
     1'   (R)etrieve phase data from the database',/,
     1'   (E)nd of phase entry',//,
     1'$Choice? ')
      READ(ITTI,2040) QOPT
2040  FORMAT(A1)
C *
      IF ( QOPT.EQ.'I' .OR. QOPT.EQ.'i' ) THEN
        CALL STPDEF
        CALL EDIT( .TRUE., .FALSE., .FALSE. )
        GO TO 2010
      ENDIF
C *
      IF ( QOPT.EQ.'R' .OR. QOPT.EQ.'r' ) THEN
        CALL RETRIV( NPHAS )
        IF(NPHAS.EQ.0) GO TO 2020
        GO TO 2010
      END IF
C *
      IF ( QOPT.EQ.'E' .OR. QOPT.EQ.'e' )GO TO 2100
C *
      GO TO 2020
C *
C *  END OF PHASE LOOP
2010  CONTINUE
      IPH = MAXPHS
C *
C *  CHECK AND SET NUMBER OF PHASES IN MEMORY
2100  NPHS = IPH - 1
      IF(NPHS.EQ.0) THEN
        WRITE(ITTO,2110)
2110    FORMAT(/,' --No phase data entered: Problem skipped.')
        GO TO 9000
      ENDIF
C *
C **  DETERMINE EXTENT OF CHANGES TO BE MADE FROM THE DEFAULTS
C *
C *  CODEWORDS GET CLEARED FOR PHASE
3000  CALL IRETCW( 0 )
C *
C *  INITIALIZE THE RIETVELD HEADER AND VARIOUS PHASE PARAMETERS
      CALL INITCP
C *
C *  SET SCALE FACTOR CODEWORDS FOR PHASES AND REFINEMENT CONTROL
C *  VARIABLES SO THE RIETVELD CODEWORD CHECK WILL NOT KILL JOB
      DO 3002 I=1,NPHS
3002  KSCALE(I) = I*10 + 1
      NRND = 1
      KAUTOV(1) = NPHS
      KAUTOR(1) =   1
C *
      WRITE(ITTO,3010)
3010  FORMAT(//,' ***  ACCEPT OR EDIT DEFAULT PARAMETERS')
      WRITE(ITTO,3012)
3012  FORMAT(/,'$Do you want to accept the default parameters? <Y> ')
      READ(ITTI,2040) QANS
      IF( QANS.NE.'N' .AND. QANS.NE.'n' ) GO TO 3200
C *
C *  USER CHOOSES TO USE OTHER THAN DEFAULTS
C *
3100  WRITE(ITTO,3010)
      WRITE(ITTO,3110)
3110  FORMAT(/,'$Edit the control flags and global parameters? <N> ')
      READ(ITTI,2040) QANS
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) CALL EDRETH
C *
      WRITE(ITTO,3010)
      WRITE(ITTO,3120)
3120  FORMAT(/,'$Edit the data for a phase? <N> ')
      READ(ITTI,2040) QANS
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) CALL ERETPH
C *
      GO TO 4000
C *
C *  USER CHOOSES TO USE ALL DEFAULTS
C *
C *  ASK FOR TITLE
3200  WRITE(ITTO,3210)
3210  FORMAT(/,
     1' Enter a descriptive title for the problem:',/)
      READ(ITTI,3220) QTITLE
3220  FORMAT(A80)
C *
C **  CONSTRUCT RIETVELD INPUT FILE
C *
4000  CALL WRRIET
C *
C **  JOB COMPLETE.... RETURN TO MAIN
C *
9000  RETURN
      END
C *  DEFINE DEFAULTS FOR CALCULATED POWDER PATTERN
C *
      SUBROUTINE INITCP
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
C *  DATA THEM THAR VARIABLES (OZARK LINGO... I SLIP WONCE IN A WHAAL)
C *
C *  JOB CONTROL PARAMETERS
20000 JOBXN  = 3
      NBCKGD = 0
      NEXCRG = 0
      NSCAT  = 0
      KINTSF = 0
      KAMOR  = 0
C *
C *  OUTPUT CONTROL FLAGS
      IOUT   = 0
      IPLT   = 0
      IPCH   = 0
      MAT    = 0
      NXT    = 0
      LST1   = 1
      LST2   = 0
      LST3   = 0
      ISYM   = 0
      IPLT2  = 1
      KCLRCW = 0
C *
C *  RADIATION-RELATED PARAMETERS
      WAVE1 =  1.5406
      WAVE2 =  1.5443
      RATIO =  0.5000
      WDT   = 20.0000
      CTHM  =  1.0000
C *
C *  PATTERN PARAMETERS
      THMIN = 20.00
      THMAX = 80.00
      STEP  = 0.03
C *
C *  RELAXATION AND OPTIMIZATION CONVERGENCE PARAMETERS
      RELAX(1) = 1.00
      RELAX(2) = 1.00
      RELAX(3) = 1.00
      RELAX(4) = 1.00
      EPS      = 0.33
C *
C *  INITIALIZE VALUES FOR INTERPOLATED BACKGROUND
      DO 2020 I=1,MAXBCK
      POS(I) = 0.0
      BCK(I) = 0.0
2020  CONTINUE
C *
C *  INITIALIZE VALUES FOR EXCLUDED REGIONS
      DO 2030 I=1,MAXEXC
      ALOW(I)  = 0.0
      AHIGH(I) = 0.0
2030  CONTINUE
C *
C *  USER-SUPPLIED SCATTERING FACTORS
      DO 2040 I=1,MAXSCA
      QSCNAM(I) = '    '
      DFP(I)  = 0.0
      DFPP(I) = 0.0
      DO 2050 J=1,9
      AC(J,I) = 0.0
2050  CONTINUE
      DO 2060 J=1,20
      POSI(J,I) = 0.0
      SCAT(J,I) = 0.0
2060  CONTINUE
2040  CONTINUE
C *
C *  QUANTITATIVE ANALYSIS
      KINTSN    = 0
      RINTSQ    = 0.0
      KINTSA(1) = 0
      KINTSA(2) = 0
      KINTSA(3) = 0
      RINTSA(1) = 0.0
      RINTSA(2) = 0.0
      RINTSA(3) = 0.0
C *
C *  AMORPHOUS PROFILE PARAMETERS
      PAMORP(1) = 0.0
      PAMORP(2) = 0.0
      PAMORP(3) = 0.0
C *
C *  REPEAT FOR EACH PHASE
C *
3000  DO 3010 I=1,NPHS
C *
C *  HANDLING OF LINE MULTIPLICITIES
      KINDRF(I) = 0
C *
3010  CONTINUE
C *
C *  GLOBAL PARAMETERS
C *
C *  TWO-THETA ERROR CORRECTION
      PZERPT = 0.0
      PDISP  = 0.0
C *
C *  BACKGROUND
      PBKG(1) = 5.0
      PBKG(2) = 0.0
      PBKG(3) = 0.0
      PBKG(4) = 0.0
      PBKG(5) = 0.0
      PBKG(6) = 0.0
C *
C *  PLOT CONTROL FLAGS
      KHCPLT(1) = 0
      KHCPLT(2) = 1
      KHCPLT(3) = 0
      KHCPLT(4) = 0
      KHCPLT(5) = 1
      KHCPLT(6) = 0
      KLPPLT(1) = 0
      KLPPLT(2) = 0
C *
C *  THAT'S IT...
9000  RETURN
      END
C **  ZRETCP - RESET THE CONTROL AND PHASE PARAMETERS FOR NEW PROBLEM
C *
      SUBROUTINE ZRETCP
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
C *  SET THE NUMBER OF PHASES IN MEMORY TO ZERO
1000  NPHS   = 0
      NBCKGD = 0
      NEXCRG = 0
      NSCAT  = 0
      KINTSF = 0
      KAMOR  = 0
      KWSGON = 0
      IOUT   = 0
      IPLT   = 0
      IPCH   = 0
      MAT    = 0
      NXT    = 0
      LST1   = 0
      LST2   = 0
      LST3   = 0
      ISYM   = 0
      IPLT2  = 0
      KCLRCW = 0
      KCONCW = 0
      NRND   = 0
      QTITLE = ' '
      WAVE1  = 1.5405981
      WAVE2  = 1.5443
      RATIO  = 0.50
      WDT    = 15.0
      CTHM   = 1.0
      THMIN  = 20.0
      STEP   = 0.02
      THMAX  = 90.0
      EPS    = 0.3
      RELAX(1) = 1.0
      RELAX(2) = 1.0
      RELAX(3) = 1.0
      RELAX(4) = 1.0
      PZERPT  = 0.0
      CZERPT  = 0.0
      PDISP   = 0.0
      CDISP   = 0.0
      PBKG(1) = 0.0
      PBKG(2) = 0.0
      PBKG(3) = 0.0
      PBKG(4) = 0.0
      PBKG(5) = 0.0
      PBKG(6) = 0.0
      CBKG(1) = 0.0
      CBKG(2) = 0.0
      CBKG(3) = 0.0
      CBKG(4) = 0.0
      CBKG(5) = 0.0
      PBKG(6) = 0.0
      WRITE(ITTO,1010)
1010  FORMAT(/,' -Control and phase data reset.')
C *
9000  RETURN
      END
C **  RDRIET - READ A RIETVELD CONTROL FILE
C *
      SUBROUTINE RDRIET
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QANS*1,QBELL*1
      LOGICAL LEXIST
C *
      QBELL = CHAR(7)
C *
C *  IF THERE ARE ALREADY PHASES IN MEMORY, DETERMINE IF THE PHASES FROM THE
C *  NEW FILE ARE TO REPLACE OR ADD TO THOSE IN MEMORY
C *
C *   DISPLAY PHASE LIST CURRENTLY IN MEMORY
2000  IF(NPHS.EQ.0) THEN
        WRITE(ITTO,2010)
2010    FORMAT(/,' ** There are no phase data currently in memory.')
        NPHSL  = 0
        GO TO 2100
      ENDIF
      WRITE(ITTO,2020) (I,QPHSNM(I),I=1,NPHS)
2020  FORMAT(/,' ** The phase data currently in memory:',//,
     1 (4X,I2,' - ',A32))
      WRITE(ITTO,2030)
2030  FORMAT(/,'$(R)eplace current phases or (A)dd new phases? <A> ')
      READ(ITTI,2040) QANS
2040  FORMAT(A1)
      IF( QANS.EQ.'R' .OR. QANS.EQ.'r' ) THEN
        NPHSL = 0
       ELSE
        NPHSL = NPHS
      ENDIF
C *
C **  OPEN REFINEMENT INPUT FILE
C *
2100  WRITE(ITTO,2110)
2110  FORMAT(/,'$Rietveld control file name? (File.rie/EXIT) <EXIT> ')
      READ(ITTI,2120) QFILE
2120  FORMAT(A64)
      IF ( QFILE.EQ.' '    .OR. QFILE.EQ.'/'    .OR.
     1     QFILE.EQ.'EXIT' .OR. QFILE.EQ.'exit'      ) THEN
        GO TO 9000
       ELSE
        QRFILE = QFILE
      ENDIF
C *
C *  SET THE ROUND/CYCLE RESET FLAG TO INCLUDE ALL VARIABLES ON FIRST ROUND
C *  IF REQUESTED TO DO SO.
2200  IREST = 0
      DO 2210 I=64,1,-1
      IF( QRFILE(I:I).NE.' ' ) GO TO 2220
2210  CONTINUE
      GO TO 2100
2220  IF(I.LT.3) GO TO 2300
      IF( QRFILE(I-1:I).EQ.'/R' .OR. QRFILE(I-1:I).EQ.'/r' ) THEN
        IREST = 1
        QRFILE(I-1:I) = '  '
      ENDIF
C *
C *  OPEN THE FILE IF IT EXISTS
2300  INQUIRE(FILE=QRFILE,EXIST=LEXIST)
      IF (.NOT.LEXIST) THEN
2310    WRITE(ITTO,2320) QBELL
2320    FORMAT(1X,A1,' -That file does not exist: try again.')
        GO TO 2100
      END IF
      OPEN(UNIT=IRETI,FILE=QRFILE,STATUS='OLD',ERR=2310)
C *
C *  SET PHASE INDEX TO NEXT MEMORY POSITION
3000  IPH = NPHSL + 1
C *
C *  DETERMINE VALUE FOR CODEWORD OFFSET.  IF IPH IS 1 THEN WE ARE READING
C *  NEW PHASES.  OTHERWISE, SET OFFSET TO SKIP CW VALUES IN MEMORY.
      IF(IPH.EQ.1) THEN
        CWRDOS = 0
       ELSE
        CWRDOS = 10.0 * REAL( KAUTOV(NRND) )
      ENDIF
C *
C *  CALL RWRETH TO READ THE HEADER INFORMATION FROM THE CONTROL FILE
      CALL RWRETH( 0 )
C *
C *  RESET PARAMETER/CYCLE VARIABLES IF REQUESTED
3100  IF(IREST.EQ.1) THEN
        WRITE(ITTO,3110)
3110    FORMAT(/,' -Resetting parameter/cycle values.')
        KAUTOV(1) = KAUTOV(NRND)
        KAUTOR(1) = KAUTOR(NRND)
        NRND = 1
      ENDIF
C *
C *  SET NUMBER OF PHASES TO BE CURRENT PLUS THOSE TO BE READ
      NPHS = NPHSL + NPHS
C *
C *  READ THE PHASE DATA SETS
3200  WRITE(ITTO,3210)
3210  FORMAT(/,' Phases read from the control file:')
      DO 3220 IPH = NPHSL+1,NPHS
      CALL RWRETP( 0 )
      WRITE(ITTO,3230) (IPH-NPHSL),QPHSNM(IPH)
3230  FORMAT(4X,I2,' - ',A32)
3220  CONTINUE
C *
      CLOSE(UNIT=IRETI)
C *
C *  ASSIGN THE ROUND FLAGS BASED ON FILE PARAMETERS
C *
C *  SET VARIABLE/CYCLE FLAGS FOR PHASES-ADDED HANDLING
3300  IF(CWRDOS.GT.0.0) THEN
        NRND = NRND + 1
        KAUTOV(NRND) = 999
        KAUTOR(NRND) = 6
      ENDIF
C *
C *  CALL SR TO CODE AND DECODE RIETVELD ASSIGNMENTS
      CALL IRETCW( 1 )
C *
C *  CALL SR TO SET INTERNAL ASSIGNMENTS
      CALL ARETCW( IFLAG )
C *
      WRITE(ITTO,3310)
3310  FORMAT(/,' ...Press <ENTER> to continue')
      READ(ITTI,2040) QANS
C *
C **  JOB COMPLETE ..... RETURN TO MAIN
9000  RETURN
      END
C **  WRRIET - WRITE DATA IN MEMORY TO A RIETVELD CONTROL FILE
C *
      SUBROUTINE WRRIET
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QANS*1,QBELL*1,QFMT*48,QFMTNN*2
      LOGICAL LEXIST
      EQUIVALENCE ( QFMT(41:42), QFMTNN )
      DATA QFMT
     1  /'(//,''$Rietveld file (File.rie/EXIT) <'',ANN,''> '')'/
C *
      QBELL = CHAR(7)
C *
C *   DISPLAY PHASE LIST CURRENTLY IN MEMORY
1100  IF(NPHS.EQ.0) THEN
        WRITE(ITTO,1110) QBELL
1110    FORMAT(1X,A1,
     1'--There is no phase information to write.  Either get phase',
     1' data from the',/,
     1'   database (option G) or from another Rietveld file',
     1' (option R).')
        GO TO 9000
      ENDIF
C *
C **  CALL ARETCW TO ASSIGN RIETVELD CODEWORDS
C *
3000  CALL ARETCW( IFLAG )
      IF(IFLAG.NE.0) GO TO 9000
C *
C **  OPEN REFINEMENT OUTPUT FILE
C *
4000  DO 4002 I=64,1,-1
      IF(QRFILE(I:I).NE.' ') GO TO 4004
4002  CONTINUE
      QRFILE = 'RIETVELD.RIE'
      I = 12
4004  WRITE(QFMTNN,'(I2)') I
      WRITE(ITTO,QFMT) QRFILE(1:I)
      READ(ITTI,4020) QFILE
4020  FORMAT(A64)
      IF ( QFILE.EQ.'EXIT' .OR. QFILE.EQ.'exit' ) GO TO 9000
      IF ( QFILE.EQ.' '    .OR. QFILE.EQ.'/'    ) QFILE = QRFILE
C *
C *  DETERMINE IF FILE NAME IS ALREADY USED
      INQUIRE(FILE=QFILE,EXIST=LEXIST)
      IF (LEXIST) THEN
         WRITE(ITTO,4030)
4030     FORMAT('$-That file already exists.  Overwrite it? <N> ')
         READ(ITTI,4040) QANS
4040     FORMAT(A1)
         IF( QANS.EQ.' ' .OR. QANS.EQ.'/' ) QANS = 'N'
         IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) GO TO 4000
         OPEN(UNIT=IRETO,FILE=QFILE,STATUS='OLD')
         CLOSE(UNIT=IRETO,STATUS='DELETE')
      END IF
CIBM
      OPEN(UNIT=IRETO,FILE=QFILE,STATUS='NEW')
CIBM
CVAX
C     OPEN(UNIT=IRETO,FILE=QFILE,STATUS='NEW',CARRIAGECONTROL='LIST')
CVAX
C *
C *  CALL RWRETH TO WRITE THE HEADER INFORMATION TO THE CONTROL FILE
      CALL RWRETH( 1 )
C *
C *  WRITE PHASE DATA SETS TO RIETVELD CONTROL FILE
      DO 4280 IPH = 1,NPHS
      CALL RWRETP( 1 )
4280  CONTINUE
C *
      CLOSE(UNIT=IRETO)
C *
C **  JOB COMPLETE ..... RETURN TO MAIN
9000  RETURN
      END
C **  RWRETH - READ/WRITE RIETVELD CONTROL FILE HEADER INFORMATION
C *
      SUBROUTINE RWRETH( IRW )
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QANS*1,QBELL*1
      LOGICAL LREAD,LWRITE,LMEM
C *
      QBELL = CHAR(7)
C *
C **  DETERMINE IF THIS IS A READ OR A WRITE TO A RIETVELD FILE
C *
1000  LREAD = IRW .EQ. 0
      LWRITE = .NOT.LREAD
      LMEM  = NPHS .EQ. 0
C *
C **  READ/WRITE HEADER INFORMATION TO REFINEMENT INPUT FILE
C *
2000  IF(LREAD) THEN
        IF(LMEM) THEN
          READ(IRETI,2010) QTITLE
         ELSE
          READ(IRETI,2011) QANS
        ENDIF
      ENDIF
      IF(LWRITE) THEN
        WRITE(IRETO,2010) QTITLE
      ENDIF
2010  FORMAT(A80)
2011  FORMAT(A1)
C *
      IF(LREAD) THEN
        IF(LMEM) THEN
          READ(IRETI,2020) JOBXN,NPHS,NBCKGD,NEXCRG,NSCAT,
     1     KINTSF,KAMOR,KWSGON
          JBCKGD = NBCKGD
          JEXCRG = NEXCRG
          JSCAT  = NSCAT
          JINTSF = KINTSF
          JAMOR  = KAMOR
         ELSE
          READ(IRETI,2020) JFILL,NPHS,JBCKGD,JEXCRG,JSCAT,
     1     JINTSF,JAMOR,JWSGON
        ENDIF
      ENDIF
      IF(LWRITE) THEN
        WRITE(IRETO,2020) JOBXN,NPHS,NBCKGD,NEXCRG,NSCAT,
     1   KINTSF,KAMOR,KWSGON
        JBCKGD = NBCKGD
        JEXCRG = NEXCRG
        JSCAT  = NSCAT
        JINTSF = KINTSF
        JAMOR  = KAMOR
      ENDIF
2020  FORMAT(8I4)
C *
      IF(LREAD) THEN
        IF(LMEM) THEN
          READ(IRETI,2030) IOUT,IPLT,IPCH,MAT,NXT,LST1,LST2,LST3,
     1     ISYM,IPLT2,KCLRCW,KCONCW
          JPLT  = IPLT
          JPLT2 = IPLT2
         ELSE
          READ(IRETI,2030) JFILL,JPLT,JFILL,JFILL,JFILL,JFILL,JFILL,
     1     JFILL,JFILL,JPLT2
        ENDIF
      ENDIF
      IF(LWRITE) THEN
        WRITE(IRETO,2030) IOUT,IPLT,IPCH,MAT,NXT,LST1,LST2,LST3,
     1   ISYM,IPLT2,KCLRCW,KCONCW
        JPLT  = IPLT
        JPLT2 = IPLT2
      ENDIF
2030  FORMAT(12I4)
C *
C *  SET CYCLE CONTROL VALUES
      IF(LREAD) THEN
        IF(LMEM) THEN
          NRND = 20
          READ(IRETI,2040) (KAUTOV(I),I=1,NRND)
          READ(IRETI,2040) (KAUTOR(I),I=1,NRND)
          DO 2042 I=1,20
          IF( KAUTOV(I).EQ.0 .OR. KAUTOR(I).EQ.0 ) GO TO 2044
2042      CONTINUE
          I = 21
2044      NRND = I - 1
         ELSE
          READ(IRETI,2011) QANS
          READ(IRETI,2011) QANS
        ENDIF
      ENDIF
      IF(LWRITE) THEN
        WRITE(IRETO,2040) (KAUTOV(I),I=1,NRND)
        WRITE(IRETO,2040) (KAUTOR(I),I=1,NRND)
      ENDIF
2040  FORMAT(20I4)
C *
      IF(LREAD) THEN
        IF(LMEM) THEN
          READ(IRETI,2050) WAVE1,WAVE2,RATIO,WDT,CTHM,THMIN,STEP,THMAX
         ELSE
          READ(IRETI,2011) QANS
        ENDIF
      ENDIF
      IF(LWRITE) THEN
        WRITE(IRETO,2050) WAVE1,WAVE2,RATIO,WDT,CTHM,THMIN,STEP,THMAX
      ENDIF
2050  FORMAT(2F8.5,6F8.4)
C *
      IF(LREAD) THEN
        IF(LMEM) THEN
          READ(IRETI,2060) EPS,RELAX
         ELSE
          READ(IRETI,2011) QANS
        ENDIF
      ENDIF
      IF(LWRITE) THEN
        WRITE(IRETO,2060) EPS,RELAX
      ENDIF
2060  FORMAT(5F8.4)
C *
      IF(LREAD) THEN
        IF(LMEM) THEN
          READ(IRETI,2070) PZERPT,PDISP,CZERPT,CDISP
         ELSE
          READ(IRETI,2011) QANS
          READ(IRETI,2011) QANS
        ENDIF
      ENDIF
      IF(LWRITE) THEN
        WRITE(IRETO,2070) PZERPT,PDISP,CZERPT,CDISP
      ENDIF
2070  FORMAT(8X,2F8.5,/,8X,2F8.2)
C *
      IF (JBCKGD.EQ.0) THEN
        IF(LREAD) THEN
          IF(LMEM) THEN
            READ(IRETI,2080) (PBKG(I),I=1,6),(CBKG(J),J=1,6)
           ELSE
            READ(IRETI,2011) QANS
            READ(IRETI,2011) QANS
          ENDIF
        ENDIF
        IF(LWRITE) THEN
          WRITE(IRETO,2080) (PBKG(I),I=1,6),(CBKG(J),J=1,6)
        ENDIF
2080    FORMAT(1P,6E12.5,/,0P,6(F8.2,4X))
      ENDIF
      IF (JBCKGD.GT.1) THEN
        IF(LREAD) THEN
          NTOGET = JBCKGD
          IF(LMEM) NBCKGD = 0
          DO 2082 I=1,NTOGET
          READ(IRETI,2090) TEMP1,TEMP2
          IF(TEMP1.EQ.-100.0) GO TO 2084
          IF(LMEM) THEN
            NBCKGD = NBCKGD + 1
            POS(NBCKGD) = TEMP1
            BCK(NBCKGD) = TEMP2
          ENDIF
2082      CONTINUE
2084      CONTINUE
        ENDIF
        IF(LWRITE) THEN
          WRITE(IRETO,2090) (POS(I),BCK(I),I=1,NBCKGD)
        ENDIF
2090    FORMAT(2F8.2)
      ENDIF
C *
2900  IF (JEXCRG.GT.0) THEN
        IF(LREAD) THEN
          IF(LMEM) THEN
            READ(IRETI,2910) (ALOW(I),AHIGH(I),I=1,NEXCRG)
           ELSE
            READ(IRETI,2011) (QANS,I=1,NEXCRG)
          ENDIF
        ENDIF
        IF(LWRITE) THEN
          WRITE(IRETO,2910) (ALOW(I),AHIGH(I),I=1,NEXCRG)
        ENDIF
2910    FORMAT(2F8.2)
      ENDIF
C *
3000  IF (JSCAT.EQ.0) GO TO 3100
      DO 3010 LOOP = 1,JSCAT
      IF(LREAD) THEN
        IF(LMEM) THEN
          READ(IRETI,3020) QSCNAM(LOOP),DFP(LOOP),DFPP(LOOP)
3020      FORMAT(A4,4X,2F8.4)
         ELSE
          READ(IRETI,2011) QANS
        ENDIF
        IF(LMEM) THEN
          READ(IRETI,3030) (AC(J,LOOP),J=1,9)
3030      FORMAT(9F8.5)
          TEMP3 = AC(3,LOOP)
          NVSCA(LOOP) = 0
         ELSE
          READ(IRETI,3030) TEMP1,TEMP2,TEMP3
        ENDIF
        IF(TEMP3.EQ.0.0) THEN
          IF(LMEM) THEN
            IPOINT = 1
            POSI(IPOINT,LOOP) = AC(1,LOOP)
            SCAT(IPOINT,LOOP) = AC(2,LOOP)
            NVSCA(LOOP) = IPOINT
          ENDIF
3040      READ(IRETI,3030) TEMP1,TEMP2
          IF(TEMP1.NE.-100.0) THEN
            IF(LMEM) THEN
              IPOINT = IPOINT + 1
              POSI(IPOINT,LOOP) = TEMP1
              SCAT(IPOINT,LOOP) = TEMP2
              NVSCA(LOOP) = IPOINT
            ENDIF
            GO TO 3040
          ENDIF
        ENDIF
      ENDIF
      IF(LWRITE) THEN
        WRITE(IRETO,3020) QSCNAM(LOOP),DFP(LOOP),DFPP(LOOP)
        IF(NVSCA(LOOP).EQ.0) THEN
          WRITE(IRETO,3030) (AC(J,LOOP),J=1,9)
         ELSE
          DO 3050 I=1,NVSCA(LOOP)
3050      WRITE(IRETO,3030) POSI(I,LOOP),SCAT(I,LOOP)
          WRITE(IRETO,3052)
3052      FORMAT('  -100.0     0.0')
        ENDIF
      ENDIF
3010  CONTINUE
C *
3100  IF (JINTSF.EQ.1) THEN
        IF(LREAD) THEN
          IF(LMEM) THEN
            READ(IRETI,3110) KINTSN,RINTSQ,KINTSA(1),RINTSA(1),
     1                     KINTSA(2),RINTSA(2),KINTSA(3),RINTSA(3)
           ELSE
            READ(IRETI,2011) QANS
          ENDIF
        ENDIF
        IF(LWRITE) THEN
          WRITE(IRETO,3110) KINTSN,RINTSQ,KINTSA(1),RINTSA(1),
     1                   KINTSA(2),RINTSA(2),KINTSA(3),RINTSA(3)
        ENDIF
3110    FORMAT(4(I8,F8.4))
      ENDIF
C *
3200  IF (JAMOR.EQ.1) THEN
        IF(LREAD) THEN
          IF(LMEM) THEN
            READ(IRETI,3210) (PAMORP(I),I=1,3),(CAMORP(I),I=1,3)
           ELSE
            READ(IRETI,2011) QANS
          ENDIF
        ENDIF
        IF(LWRITE) THEN
          WRITE(IRETO,3210) (PAMORP(I),I=1,3),(CAMORP(I),I=1,3)
        ENDIF
3210    FORMAT(8X,F8.4,F8.2,F8.4,/,8X,3F8.2)
      ENDIF
C *
3300  IF(JPLT.EQ.1) THEN
        IF(LREAD) THEN
          IF(LMEM) THEN
            READ(IRETI,3310) (KLPPLT(I),I=1,2)
           ELSE
            READ(IRETI,2011) QANS
          ENDIF
        ENDIF
        IF(LWRITE) THEN
          WRITE(IRETO,3310) (KLPPLT(I),I=1,2)
        ENDIF
3310    FORMAT(6I4)
      ENDIF
C *
3400  IF(JPLT2.EQ.1) THEN
        IF(LREAD) THEN
          IF(LMEM) THEN
            READ(IRETI,3310) (KHCPLT(I),I=1,6)
           ELSE
            READ(IRETI,2011) QANS
          ENDIF
        ENDIF
        IF(LWRITE) THEN
          WRITE(IRETO,3310) (KHCPLT(I),I=1,6)
        ENDIF
      ENDIF
C *
C **  JOB COMPLETE ..... RETURN TO MAIN
9000  RETURN
      END
C **  RWRETP - READ/WRITE RIETVELD CONTROL FILE PHASE DATA
C *
      SUBROUTINE RWRETP( IRW )
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      LOGICAL LREAD
C *
C *  DETERMINE WHETHER TO READ OR WRITE THE DESIRED PHASE INFORMATION
C *
      LREAD = IRW .EQ. 0
C *
C *  PARAMETER VALUES
C *
1000  IF(LREAD) THEN
        READ(IRETI,1010) QPHSNM(IPH)
        QFORM(IPH) = 'N/A'
        QCMNT(IPH) = 'N/A'
       ELSE
        WRITE(IRETO,1010) QPHSNM(IPH)
      ENDIF
1010  FORMAT(A32)
C *
      IF(LREAD) THEN
        READ(IRETI,1020) QSGP(IPH),QXTALS(IPH)
        QCMNT(IPH) = 'N/A'
        QFORM(IPH) = 'N/A'
       ELSE
        WRITE(IRETO,1020) QSGP(IPH),QXTALS(IPH)
      ENDIF
1020  FORMAT(A20,A20)
C *
      IF(LREAD) THEN
        READ(IRETI,1030) NATOM(IPH),KINDRF(IPH),KATMPF(IPH),KMAGSF(IPH)
       ELSE
        WRITE(IRETO,1030) NATOM(IPH),KINDRF(IPH),KATMPF(IPH),KMAGSF(IPH)
      ENDIF
1030  FORMAT(4I4)
C *
C *  ATOM PARAMETERS
      DO 1040 LOOP = 1,NATOM(IPH)
      IF(LREAD) THEN
        READ(IRETI,1050) QATOM(LOOP,IPH),QSCAT(LOOP,IPH),
     1  KMAGSI(LOOP,IPH),(PAXYZ(J,LOOP,IPH),J=1,3),PBISO(LOOP,IPH),
     1  POCCU(LOOP,IPH),(CAXYZ(J,LOOP,IPH),J=1,3),CBISO(LOOP,IPH),
     1  COCCU(LOOP,IPH)
        DO 1042 J=1,3
        IF(CAXYZ(J,LOOP,IPH).NE.0.0) THEN
          CAXYZ(J,LOOP,IPH) =
     1       CAXYZ(J,LOOP,IPH) + CWRDOS*SIGN(1.0,CAXYZ(J,LOOP,IPH))
        ENDIF
1042    CONTINUE
        IF(CBISO(LOOP,IPH).NE.0.0) THEN
          CBISO(LOOP,IPH) =
     1       CBISO(LOOP,IPH) + CWRDOS*SIGN(1.0,CBISO(LOOP,IPH))
        ENDIF
        IF(COCCU(LOOP,IPH).NE.0.0) THEN
          COCCU(LOOP,IPH) =
     1       COCCU(LOOP,IPH) + CWRDOS*SIGN(1.0,COCCU(LOOP,IPH))
        ENDIF
        READ(IRETI,1052) QASPG(LOOP,IPH),(PBAIS(J,LOOP,IPH),J=1,6),
     1  (CBAIS(J,LOOP,IPH),J=1,6)
        DO 1044 J=1,6
        IF(CBAIS(J,LOOP,IPH).NE.0.0) THEN
          CBAIS(J,LOOP,IPH) =
     1       CBAIS(J,LOOP,IPH) + CWRDOS*SIGN(1.0,CBAIS(J,LOOP,IPH))
        ENDIF
1044    CONTINUE
        IF(KMAGSI(LOOP,IPH).EQ.1) THEN
          READ(IRETI,1054) (PVMAG(J,LOOP,IPH),J=1,3),
     1    (CVMAG(J,LOOP,IPH),J=1,3)
          DO 1046 J=1,3
          IF(CVMAG(J,LOOP,IPH).NE.0.0) THEN
            CVMAG(J,LOOP,IPH) =
     1         CVMAG(J,LOOP,IPH) + CWRDOS*SIGN(1.0,CVMAG(J,LOOP,IPH))
          ENDIF
1046      CONTINUE
        ENDIF
       ELSE
        WRITE(IRETO,1050) QATOM(LOOP,IPH),QSCAT(LOOP,IPH),
     1  KMAGSI(LOOP,IPH),(PAXYZ(J,LOOP,IPH),J=1,3),PBISO(LOOP,IPH),
     1  POCCU(LOOP,IPH),(CAXYZ(J,LOOP,IPH),J=1,3),CBISO(LOOP,IPH),
     1  COCCU(LOOP,IPH)
        WRITE(IRETO,1052) QASPG(LOOP,IPH),(PBAIS(J,LOOP,IPH),J=1,6),
     1  (CBAIS(J,LOOP,IPH),J=1,6)
        IF(KMAGSI(LOOP,IPH).EQ.1) THEN
          WRITE(IRETO,1054) (PVMAG(J,LOOP,IPH),J=1,3),
     1    (CVMAG(J,LOOP,IPH),J=1,3)
        ENDIF
      ENDIF
1040  CONTINUE
1050  FORMAT(A8,A4,I4,8X,5F8.5,/,24X,5F8.2)
1052  FORMAT(A20,4X,6F8.5,/,24X,6F8.2)
1054  FORMAT(24X,3F8.5,/,24X,3F8.2)
C *
C *  OVERALL SCALE AND ISO TEMP FACTORS
      IF(LREAD) THEN
        READ(IRETI,1060) PSCALE(IPH),POVISO(IPH),PABSCO(IPH),
     1                   CSCALE(IPH),COVISO(IPH),CABSCO(IPH)
        IF(CSCALE(IPH).NE.0.0) THEN
          CSCALE(IPH) =
     1       CSCALE(IPH) + CWRDOS*SIGN(1.0,CSCALE(IPH))
        ENDIF
        IF(COVISO(IPH).NE.0.0) THEN
          CSCALE(IPH) =
     1       COVISO(IPH) + CWRDOS*SIGN(1.0,COVISO(IPH))
        ENDIF
        IF(CABSCO(IPH).NE.0.0) THEN
          CABSCO(IPH) =
     1       CABSCO(IPH) + CWRDOS*SIGN(1.0,CABSCO(IPH))
        ENDIF
       ELSE
        WRITE(IRETO,1060) PSCALE(IPH),POVISO(IPH),PABSCO(IPH),
     1                    CSCALE(IPH),COVISO(IPH),CABSCO(IPH)
      ENDIF
1060  FORMAT(F8.2,2F8.4,/,3F8.2)
C *
C *  PROFILE-SHAPE-FUNCTION PARAMETERS
      IF(LREAD) THEN
        READ(IRETI,1070) KPSF(1,IPH),KPSF(2,IPH),RLIM(IPH),PASYP(IPH),
     1   (PPSFC(J,1,IPH),J=1,3),CASYP(IPH),(CPSFC(J,1,IPH),J=1,3)
        DO 1062 J=1,3
        IF(CPSFC(J,1,IPH).NE.0.0) THEN
          CPSFC(J,1,IPH) =
     1       CPSFC(J,1,IPH) + CWRDOS*SIGN(1.0,CPSFC(J,1,IPH))
        ENDIF
1062    CONTINUE
        IF(CASYP(IPH).NE.0.0) THEN
          CASYP(IPH) =
     1       CASYP(IPH) + CWRDOS*SIGN(1.0,CASYP(IPH))
        ENDIF
        IF( KPSF(2,IPH).EQ.2 .OR. KPSF(2,IPH).EQ.3 ) THEN
          READ(IRETI,1072) (PPSFC(J,2,IPH),J=1,3),(CPSFC(J,2,IPH),J=1,3)
          DO 1064 J=1,3
          IF(CPSFC(J,2,IPH).NE.0.0) THEN
            CPSFC(J,2,IPH) =
     1         CPSFC(J,2,IPH) + CWRDOS*SIGN(1.0,CPSFC(J,2,IPH))
          ENDIF
1064      CONTINUE
         ELSE
          PPSFC(1,2,IPH) = 0.0
          PPSFC(2,2,IPH) = 0.0
          PPSFC(3,2,IPH) = 0.0
          CPSFC(1,2,IPH) = 0.0
          CPSFC(2,2,IPH) = 0.0
          CPSFC(3,2,IPH) = 0.0
        ENDIF
       ELSE
        WRITE(IRETO,1070) KPSF(1,IPH),KPSF(2,IPH),RLIM(IPH),PASYP(IPH),
     1   (PPSFC(J,1,IPH),J=1,3),CASYP(IPH),(CPSFC(J,1,IPH),J=1,3)
        IF( KPSF(2,IPH).EQ.2 .OR. KPSF(2,IPH).EQ.3 ) THEN
          WRITE(IRETO,1072)(PPSFC(J,2,IPH),J=1,3),(CPSFC(J,2,IPH),J=1,3)
        ENDIF
      ENDIF
1070  FORMAT(2I4,2F8.4,3F8.5,/,16X,4F8.2)
1072  FORMAT(24X,3F8.5,/,24X,3F8.2)
C *
C *  PROFILE BROADENING COEFFICIENTS
      IF(LREAD) THEN
        READ(IRETI,1074) (PUVW(J,1,IPH),J=1,3),(CUVW(J,1,IPH),J=1,3)
          DO 1076 J=1,3
          IF(CUVW(J,1,IPH).NE.0.0) THEN
            CUVW(J,1,IPH) =
     1         CUVW(J,1,IPH) + CWRDOS*SIGN(1.0,CUVW(J,1,IPH))
          ENDIF
1076      CONTINUE
        IF( KPSF(2,IPH).EQ.1 .OR. KPSF(2,IPH).EQ.3 ) THEN
          READ(IRETI,1074) (PUVW(J,2,IPH),J=1,3),(CUVW(J,2,IPH),J=1,3)
          DO 1078 J=1,3
          IF(CUVW(J,2,IPH).NE.0.0) THEN
            CUVW(J,2,IPH) =
     1         CUVW(J,2,IPH) + CWRDOS*SIGN(1.0,CUVW(J,2,IPH))
          ENDIF
1078      CONTINUE
        ENDIF
       ELSE
        WRITE(IRETO,1074) (PUVW(J,1,IPH),J=1,3),(CUVW(J,1,IPH),J=1,3)
        IF( KPSF(2,IPH).EQ.1 .OR. KPSF(2,IPH).EQ.3 ) THEN
          WRITE(IRETO,1074) (PUVW(J,2,IPH),J=1,3),(CUVW(J,2,IPH),J=1,3)
        ENDIF
      ENDIF
1074  FORMAT(4X,4X,3F8.5,/,8X,3F8.2)
C *
C *  LATTICE PARAMETERS
      IF(LREAD) THEN
        READ(IRETI,1080) (PCELL(J,IPH),J=1,6),(CCELL(J,IPH),J=1,6)
        DO 1082 J=1,6
        IF(CCELL(J,IPH).NE.0.0) THEN
          CCELL(J,IPH) =
     1       CCELL(J,IPH) + CWRDOS*SIGN(1.0,CCELL(J,IPH))
        ENDIF
1082    CONTINUE
       ELSE
        WRITE(IRETO,1080) (PCELL(J,IPH),J=1,6),(CCELL(J,IPH),J=1,6)
      ENDIF
1080  FORMAT(3F8.5,3F8.4,/,6F8.2)
C *
C *  PREFERRED ORIENTATION
      IF(LREAD) THEN
        READ(IRETI,1090) KPOCT(1,IPH),KPOCT(2,IPH),
     1   (POVEC(J,1,IPH),J=1,3),(PPREF(J,1,IPH),J=1,2),
     1   (CPREF(J,1,IPH),J=1,2)
        DO 1092 J=1,2
        IF(CPREF(J,1,IPH).NE.0.0) THEN
          CPREF(J,1,IPH) =
     1       CPREF(J,1,IPH) + CWRDOS*SIGN(1.0,CPREF(J,1,IPH))
        ENDIF
1092    CONTINUE
        IF(KPOCT(2,IPH).EQ.1) THEN
          READ(IRETI,1094) (POVEC(J,2,IPH),J=1,3),
     1     (PPREF(J,2,IPH),J=1,2),(CPREF(J,2,IPH),J=1,2)
          DO 1096 J=1,2
          IF(CPREF(J,2,IPH).NE.0.0) THEN
            CPREF(J,2,IPH) =
     1         CPREF(J,2,IPH) + CWRDOS*SIGN(1.0,CPREF(J,2,IPH))
          ENDIF
1096      CONTINUE
        ENDIF
       ELSE
        WRITE(IRETO,1090) KPOCT(1,IPH),KPOCT(2,IPH),
     1   (POVEC(J,1,IPH),J=1,3),(PPREF(J,1,IPH),J=1,2),
     1   (CPREF(J,1,IPH),J=1,2)
        IF(KPOCT(2,IPH).EQ.1) THEN
          WRITE(IRETO,1094) (POVEC(J,2,IPH),J=1,3),
     1     (PPREF(J,2,IPH),J=1,2),(CPREF(J,2,IPH),J=1,2)
        ENDIF
      ENDIF
1090  FORMAT(2I4,5F8.4,/,32X,2F8.2)
1094  FORMAT(8X,5F8.4,/,32X,2F8.2)
C *
C **  JOB COMPLETE.... RETURN TO PREVIOUS SUBROUTINE
9000  RETURN
      END
C **  GRETPH - GET A SET OF PHASE DATA FROM THE DATABASE
C *
      SUBROUTINE GRETPH
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QANS*1,QBELL*1
C *
C *  DETERMINE IF THESE PHASES ARE TO REPLACE OR ADD TO THOSE IN MEMORY
C *
C *   DISPLAY PHASE LIST CURRENTLY IN MEMORY
4100  IF(NPHS.EQ.0) THEN
        WRITE(ITTO,4110)
4110    FORMAT(/,' ** There is no phase data currently in memory.')
        NPHSL = 0
        GO TO 4200
      ENDIF
      WRITE(ITTO,4120) (I,QPHSNM(I),I=1,NPHS)
4120  FORMAT(/,' ** The phases currently in memory include:',//,
     1 (4X,I2,' - ',A32))
      WRITE(ITTO,4130)
4130  FORMAT(/,'$(R)eplace current phases or (A)dd new phase? <A> ')
      READ(ITTI,4140) QANS
4140  FORMAT(A1)
      IF( QANS.EQ.'R' .OR. QANS.EQ.'r' ) THEN
        NPHSL = 0
       ELSE
        NPHSL = NPHS
      ENDIF
C *
C *  SET PHASE INDEX TO NEXT MEMORY POSITION
4200  IPH = NPHSL + 1
C *
C *  GET PHASE DATA FROM DATABASE
      CALL RETRIV( NPHAS )
C *
C *  SET NEW NUMBER OF PHASES
      IF(NPHAS.NE.0) NPHS = NPHSL + 1
C *
C **  JOB COMPLETE ..... RETURN TO MAIN
9000  RETURN
      END
C **  PRETPH - COPY A SET OF PHASE DATA FROM MEMORY INTO THE DATABASE
C *
      SUBROUTINE PRETPH
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      LOGICAL LWRIPH,LFIRST,LDELPH,LKEEPH
      CHARACTER QANS*1
C *
C *  DETERMINE THE NUMBER OF UNUSED PHASE AREAS IN MEMORY
1000  IF(NPHS.LT.MAXPHS) GO TO 1100
      WRITE(ITTO,1010)
1010  FORMAT(/,
     1' --There is no room in memory for scratch phases.  Please exit',
     1' the program and',/,
     1'   start this operation again.')
      GO TO 9000
C *
C *  INITIALIZE WRITE-PHASE, FIRST-PHASE, DELETE-PHASE, KEEP-PHASE FLAGS
1100  LWRIPH = .TRUE.
      LFIRST = .TRUE.
      LDELPH = .FALSE.
      LKEEPH = .FALSE.
C *
C *   DISPLAY PHASE LIST CURRENTLY IN MEMORY
C *
      IF(NPHS.EQ.0) THEN
        WRITE(ITTO,1110) (I,QPHSNM(I),I=1,NPHS)
1110    FORMAT(/,' ** There is no phase data currently in memory.')
        GO TO 9000
      ENDIF
      WRITE(ITTO,1120) (I,QPHSNM(I),I=1,NPHS)
1120  FORMAT(/,' ** The phases currently in memory include:',//,
     1 (4X,I2,' - ',A32))
      WRITE(ITTO,1130)
1130  FORMAT(/,'$Which set of data is to be added? <0:Exit> ')
      IWRIT = 0
      READ(ITTI,*) IWRIT
      IF(IWRIT.EQ.0) GO TO 9000
      IF( IWRIT.LT.1 .OR. IWRIT.GT.NPHS ) GO TO 1100
C *
C **  CHECK FOR PHASE WITH SAME NAME
C *
C *  CHECK INDEX FILE FOR PHASE WITH SAME NAME
2000  CALL GTDBPI( QPHSNM(IWRIT), IDXPHS )
      IF(IDXPHS.EQ.0) GO TO 3000
C *
C *  A PHASE WITH THE SAME NAME IS ALREADY ON THE DATABASE
2100  WRITE(ITTO,2110)
2110  FORMAT(/,
     1' A phase with the same name was found in the database.  Your',
     1' options are:',//,
     1'  R - Replace the phase data in the database',/,
     1'  N - Give the current phase a new name and store it',/,
     1'  X - Do not put the phase data into the database',//,
     1'$Choice? ')
      READ(ITTI,2120) QANS
2120  FORMAT(A1)
      IF( QANS.EQ.'R' .OR. QANS.EQ.'r' ) GO TO 2200
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 2300
      IF( QANS.EQ.'X' .OR. QANS.EQ.'x' ) GO TO 9000
      GO TO 2100
C *
C *  CHOSEN OPTION WAS TO REPLACE EXISTING PHASE
C *
C *  DETERMINE IF FORMULA AND REFERENCE ARE TO BE REPLACED
2200  WRITE(ITTO,2210)
2210  FORMAT(/,
     1' A chemical formula and a reference are stored on the',
     1' database.',//,
     1'  R - Replace with new data',/,
     1'  K - Keep the data currently in the database',//,
     1'$Choice? ')
      READ(ITTI,2120) QANS
      IF( QANS.EQ.'R' .OR. QANS.EQ.'r' ) GO TO 2220
      IF( QANS.EQ.'K' .OR. QANS.EQ.'k' ) GO TO 2280
      GO TO 2200
C *
C *  GET THE OTHER INFORMATION STORED ON THE DATABASE
2220  WRITE(ITTO,2230)
2230  FORMAT(/,
     1' Please enter the following information for the database',
     1' records')
      WRITE(ITTO,2240)
2240  FORMAT(/,'$ Formula (A32): ')
      READ(ITTI,2320) QFORM(IWRIT)
      WRITE(ITTO,2250)
2250  FORMAT('$ Reference (A72): ')
      READ(ITTI,2260) QCMNT(IWRIT)
2260  FORMAT(A72)
C *
C *  SET THE NAME OF THE PHASE TO BE SKIPPED AND DELETE-PHASE FLAG
      QPHS = QPHSNM(IWRIT)
      LDELPH = .TRUE.
C *
C *  GO WRITE THE PHASE INFORMATION
      GO TO 3000
C *
C *  OPTION WAS TO KEEP PHASE HEADER INFORMATION ON FILE
2280  QPHS = QPHSNM(IWRIT)
      LWRIPH = .FALSE.
      LKEEPH = .TRUE.
C *
C *  GO WRITE THE PHASE INFORMATION
      GO TO 3000
C *
C *  CHOSEN OPTION WAS TO DESIGNATE A NEW NAME AND STORE THE DATA
C *
C *  GET THE NEW NAME
2300  WRITE(ITTO,2310)
2310  FORMAT(/,'$New name for phase? ')
      READ(ITTI,2320) QPHS
2320  FORMAT(A32)
C *
C *  CHECK INDEX FILE FOR PHASE WITH SAME NAME
      CALL GTDBPI( QPHS, IDXPHS )
      IF(IDXPHS.NE.0) GO TO 2100
C *
C *  PHASE NAME IS OK.  CHANGE PHASE NAME TO INDICATED NAME
      QPHSNM(IWRIT) = QPHS
C *
C *  GET THE OTHER INFORMATION STORED ON THE DATABASE
      WRITE(ITTO,2230)
      WRITE(ITTO,2240)
      READ(ITTI,2320) QFORM(IWRIT)
      WRITE(ITTO,2250)
      READ(ITTI,2260) QCMNT(IWRIT)
C *
C **  PUT THE PHASE INTO THE DATABASE
C *
C *  OPEN THE SCRATCH FILE FOR DATABASE OUTPUT
3000  IF(KBIN.EQ.1) THEN
        OPEN(UNIT=ISCR,STATUS='SCRATCH',FORM='UNFORMATTED')
       ELSE
        OPEN(UNIT=ISCR,STATUS='SCRATCH',FORM='FORMATTED')
      ENDIF
C *
C *  WRITE THE INDICATED PHASE IF DIRECTED
      IF(LWRIPH) THEN
        IPH = IWRIT
        CALL RWDBPH( 'W', 1, IWEOF )
      ENDIF
C *
C *  REWIND DATA BASE
      REWIND(IDFI)
C *
C *  READ PHASES FROM THE DATABASE FILE
3100  DO 3110 IPH=NPHS+1,MAXPHS
      CALL RWDBPH( 'R', 0, IREOF )
C *
C *  CHECK FOR THE EOF HIT
      IF(IREOF.EQ.1) GO TO 3120
C *
C *  NEXT INPUT PHASE
3110  CONTINUE
      IPH  = MAXPHS + 1
3120  NOUT = IPH - 1
C *
C *  WRITE THE PHASES TO THE OUTPUT FILE
      DO 3210 IOUTPH=NPHS+1,NOUT
      IF( LDELPH .AND. LFIRST .AND. QPHS.EQ.QPHSNM(IOUTPH) ) THEN
        LFIRST = .FALSE.
        GO TO 3210
      ENDIF
      IF( LKEEPH .AND. QPHS.EQ.QPHSNM(IOUTPH) ) THEN
        QCMNT(IWRIT) = QCMNT(IOUTPH)
        QFORM(IWRIT) = QFORM(IOUTPH)
        IPH = IWRIT
        CALL RWDBPH( 'W', 1, IWEOF )
        GO TO 3210
      ENDIF
      IPH = IOUTPH
      CALL RWDBPH( 'W', 1, IWEOF )
3210  CONTINUE
C *
C *  PROCESS MORE PHASES IF THE EOF HAS NOT BEEN HIT
      IF(IREOF.NE.1) GO TO 3100
C *
C *   WRITE PRESERVED DATA FROM THE SCRATCH FILE TO IDFI
      CALL SWITCH
C *
C *  CLOSE THE SCRATCH FILE
      CLOSE(UNIT=ISCR,STATUS='DELETE')
C *
C *  UPDATE THE INDEX FILE
      CALL INDEX
C *
C **  JOB COMPLETE ..... RETURN TO MAIN
9000  RETURN
      END
C **  DRETPH - DELETE A PHASE FROM MEMORY
C *
      SUBROUTINE DRETPH
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QANS*1,QBELL*1
C *
C *  DETERMINE WHICH PHASE IS TO BE DELETED
C *
C *   DISPLAY PHASE LIST CURRENTLY IN MEMORY
1000  IF(NPHS.EQ.0) THEN
        WRITE(ITTO,1010) (I,QPHSNM(I),I=1,NPHS)
1010    FORMAT(/,' ** There is no phase data currently in memory.')
        GO TO 9000
      ENDIF
      WRITE(ITTO,1020) (I,QPHSNM(I),I=1,NPHS)
1020  FORMAT(/,' ** The phases currently in memory include:',//,
     1 (4X,I2,' - ',A32))
      WRITE(ITTO,1030)
1030  FORMAT(/,'$Which set of data is to be deleted? <0:Exit> ')
      IDEL = 0
      READ(ITTI,*) IDEL
      IF(IDEL.EQ.0) GO TO 9000
      IF( IDEL.LT.1 .OR. IDEL.GT.NPHS ) GO TO 1000
C *
C **  DELETE THE PHASE
C *
C *  IF IT IS THE LAST PHASE IN MEMORY SIMPLY DECREMENT COUNTER
2000  IF(IDEL.EQ.NPHS) GO TO 2190
C *
C *  MOVE ALL PHASE DATA DOWN OVER UNDESIRED PHASE
C *
      DO 2010 I=IDEL,NPHS-1
      IP1 = I + 1
C *
      QPHSNM(I) = QPHSNM(IP1)
      QFORM(I)  = QFORM(IP1)
      QCMNT(I)  = QCMNT(IP1)
C *
      QSGP(I)   = QSGP(IP1)
      QXTALS(I) = QXTALS(IP1)
C *
      NATOM(I)  = NATOM(IP1)
      KATMPF(I) = KATMPF(IP1)
      KMAGSF(I) = KMAGSF(IP1)
C *
      DO 2020 IATM = 1,MAXATM
      QATOM(IATM,I)   = QATOM(IATM,IP1)
      QSCAT(IATM,I)   = QSCAT(IATM,IP1)
      KMAGSI(IATM,I)  = KMAGSI(IATM,IP1)
      PAXYZ(1,IATM,I) = PAXYZ(1,IATM,IP1)
      PAXYZ(2,IATM,I) = PAXYZ(2,IATM,IP1)
      PAXYZ(3,IATM,I) = PAXYZ(3,IATM,IP1)
      CAXYZ(1,IATM,I) = CAXYZ(1,IATM,IP1)
      CAXYZ(2,IATM,I) = CAXYZ(2,IATM,IP1)
      CAXYZ(3,IATM,I) = CAXYZ(3,IATM,IP1)
      KAXYZ(1,IATM,I) = KAXYZ(1,IATM,IP1)
      KAXYZ(2,IATM,I) = KAXYZ(2,IATM,IP1)
      KAXYZ(3,IATM,I) = KAXYZ(3,IATM,IP1)
      PBISO(IATM,I)   = PBISO(IATM,IP1)
      CBISO(IATM,I)   = CBISO(IATM,IP1)
      KBISO(IATM,I)   = KBISO(IATM,IP1)
      POCCU(IATM,I)   = POCCU(IATM,IP1)
      COCCU(IATM,I)   = COCCU(IATM,IP1)
      KOCCU(IATM,I)   = KOCCU(IATM,IP1)
      DO 2030 J=1,6
      PBAIS(J,IATM,I) = PBAIS(J,IATM,IP1)
      CBAIS(J,IATM,I) = CBAIS(J,IATM,IP1)
      KBAIS(J,IATM,I) = KBAIS(J,IATM,IP1)
2030  CONTINUE
      QASPG(IATM,I)   = QASPG(IATM,IP1)
      DO 2032 J=1,3
      PVMAG(J,IATM,I) = PVMAG(J,IATM,IP1)
      CVMAG(J,IATM,I) = CVMAG(J,IATM,IP1)
      KVMAG(J,IATM,I) = KVMAG(J,IATM,IP1)
2032  CONTINUE
2020  CONTINUE
C *
      PSCALE(I) = PSCALE(IP1)
      CSCALE(I) = CSCALE(IP1)
      KSCALE(I) = KSCALE(IP1)
      POVISO(I) = POVISO(IP1)
      COVISO(I) = COVISO(IP1)
      KOVISO(I) = KOVISO(IP1)
      PABSCO(I) = PABSCO(IP1)
      CABSCO(I) = CABSCO(IP1)
      KABSCO(I) = KABSCO(IP1)
C *
      PCELL(1,I) = PCELL(1,IP1)
      PCELL(2,I) = PCELL(2,IP1)
      PCELL(3,I) = PCELL(3,IP1)
      PCELL(4,I) = PCELL(4,IP1)
      PCELL(5,I) = PCELL(5,IP1)
      PCELL(6,I) = PCELL(6,IP1)
      CCELL(1,I) = CCELL(1,IP1)
      CCELL(2,I) = CCELL(2,IP1)
      CCELL(3,I) = CCELL(3,IP1)
      CCELL(4,I) = CCELL(4,IP1)
      CCELL(5,I) = CCELL(5,IP1)
      CCELL(6,I) = CCELL(6,IP1)
      KCELL(1,I) = KCELL(1,IP1)
      KCELL(2,I) = KCELL(2,IP1)
      KCELL(3,I) = KCELL(3,IP1)
      KCELL(4,I) = KCELL(4,IP1)
      KCELL(5,I) = KCELL(5,IP1)
      KCELL(6,I) = KCELL(6,IP1)
C *
      KPSF(1,I)    = KPSF(1,IP1)
      KPSF(2,I)    = KPSF(2,IP1)
      PASYP(I)     = PASYP(IP1)
      CASYP(I)     = CASYP(IP1)
      KASYP(I)     = KASYP(IP1)
      RLIM(I)      = RLIM(IP1)
      PPSFC(1,1,I) = PPSFC(1,1,IP1)
      PPSFC(2,1,I) = PPSFC(2,1,IP1)
      PPSFC(3,1,I) = PPSFC(3,1,IP1)
      CPSFC(1,1,I) = CPSFC(1,1,IP1)
      CPSFC(2,1,I) = CPSFC(2,1,IP1)
      CPSFC(3,1,I) = CPSFC(3,1,IP1)
      KPSFC(1,1,I) = KPSFC(1,1,IP1)
      KPSFC(2,1,I) = KPSFC(2,1,IP1)
      KPSFC(3,1,I) = KPSFC(3,1,IP1)
      PPSFC(1,2,I) = PPSFC(1,2,IP1)
      PPSFC(2,2,I) = PPSFC(2,2,IP1)
      PPSFC(3,2,I) = PPSFC(3,2,IP1)
      CPSFC(1,2,I) = CPSFC(1,2,IP1)
      CPSFC(2,2,I) = CPSFC(2,2,IP1)
      CPSFC(3,2,I) = CPSFC(3,2,IP1)
      KPSFC(1,2,I) = KPSFC(1,2,IP1)
      KPSFC(2,2,I) = KPSFC(2,2,IP1)
      KPSFC(3,2,I) = KPSFC(3,2,IP1)
C *
      PUVW(1,1,I)  = PUVW(1,1,IP1)
      PUVW(2,1,I)  = PUVW(2,1,IP1)
      PUVW(3,1,I)  = PUVW(3,1,IP1)
      CUVW(1,1,I)  = CUVW(1,1,IP1)
      CUVW(2,1,I)  = CUVW(2,1,IP1)
      CUVW(3,1,I)  = CUVW(3,1,IP1)
      KUVW(1,1,I)  = KUVW(1,1,IP1)
      KUVW(2,1,I)  = KUVW(2,1,IP1)
      KUVW(3,1,I)  = KUVW(3,1,IP1)
      PUVW(1,2,I)  = PUVW(1,2,IP1)
      PUVW(2,2,I)  = PUVW(2,2,IP1)
      PUVW(3,2,I)  = PUVW(3,2,IP1)
      CUVW(1,2,I)  = CUVW(1,2,IP1)
      CUVW(2,2,I)  = CUVW(2,2,IP1)
      CUVW(3,2,I)  = CUVW(3,2,IP1)
      KUVW(1,2,I)  = KUVW(1,2,IP1)
      KUVW(2,2,I)  = KUVW(2,2,IP1)
      KUVW(3,2,I)  = KUVW(3,2,IP1)
C *
      KPOCT(1,I)   = KPOCT(1,IP1)
      KPOCT(2,I)   = KPOCT(2,IP1)
      POVEC(1,1,I) = POVEC(1,1,IP1)
      POVEC(2,1,I) = POVEC(2,1,IP1)
      POVEC(3,1,I) = POVEC(3,1,IP1)
      PPREF(1,1,I) = PPREF(1,1,IP1)
      PPREF(2,1,I) = PPREF(2,1,IP1)
      CPREF(1,1,I) = CPREF(1,1,IP1)
      CPREF(2,1,I) = CPREF(2,1,IP1)
      KPREF(1,1,I) = KPREF(1,1,IP1)
      KPREF(2,1,I) = KPREF(2,1,IP1)
      POVEC(1,2,I) = POVEC(1,2,IP1)
      POVEC(2,2,I) = POVEC(2,2,IP1)
      POVEC(3,2,I) = POVEC(3,2,IP1)
      PPREF(1,2,I) = PPREF(1,2,IP1)
      PPREF(2,2,I) = PPREF(2,2,IP1)
      CPREF(1,2,I) = CPREF(1,2,IP1)
      CPREF(2,2,I) = CPREF(2,2,IP1)
      KPREF(1,2,I) = KPREF(1,2,IP1)
      KPREF(2,2,I) = KPREF(2,2,IP1)
C *
2010  CONTINUE
C *
C *  DECREMENT NUMBER OF PHASES IN MEMORY
2190  NPHS = NPHS - 1
C *
C **  JOB COMPLETE ..... RETURN TO MAIN
9000  RETURN
      END
C **  EDRETH - EDIT RIETVELD CONTROL FILE HEADER INFORMATION
C *
      SUBROUTINE EDRETH
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QANS*1,QBELL*1,QSTR*80,QSTR4*4
C *
      QBELL = CHAR(7)
C *
C **  READ/WRITE HEADER INFORMATION TO REFINEMENT INPUT FILE
C *
2000  WRITE(ITTO,2010) QTITLE(1:78)
2010  FORMAT(/,' The title for the problem is:',/,1X,A78,//,
     1         '$Enter new title <no change> ')
      READ(ITTI,2020) QSTR
2020  FORMAT(A80)
      IF( QSTR.NE.' ' .AND. QSTR.NE.'/' ) QTITLE = QSTR
C *
C *  JOB DESCRIPTION CARD
C *
3000  ASSIGN 3000 TO IERLBL
      WRITE(ITTO,3010) JOBXN,NPHS,NBCKGD,NEXCRG,NSCAT,
     1                  KINTSF,KAMOR
3010  FORMAT(/,
     1'   Job type:           ',I2,
     1    '   N  Refinement:          1 X-ray, 2 Neutron',/,
     1    27X,'    Pattern Calculation: 3 X-ray, 4 Neutron',/,
     1'   Phases in problem  :',I2,
     1    '   *  This parameter set by program only.',/,
     1'   Background handling:',I2,
     1    '   0  Polynomial background to be refined',/,
     1    27X,' 1  Background is to be read from a file',/,
     1    27X,' N  Interpolation between N given points',/,
     1'   Excluded regions:   ',I2,
     1    '   N  N regions will be entered',/,
     1'   Scattering sets:    ',I2,
     1    '   N  N scattering sets will be entered',/,
     1'   Internal std flag:  ',I2,
     1    '   1  Internal std data will be entered',/,
     1'   Amorphous profile:  ',I2,
     1    '   1  Profile description will be entered')
      WRITE(ITTO,3020)
3020  FORMAT(/,'$Change the information? (y/n/e) <n> ')
      READ(ITTI,3030) QANS
3030  FORMAT(A1)
      IF( QANS.EQ.'E' .OR.  QANS.EQ.'e' ) GO TO 9000
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) GO TO 4000
 
3100  WRITE(ITTO,3110) JOBXN
3110  FORMAT(/,
     1'   Job type:  Refinement:          1 X-ray, 2 Neutron',/,
     1'              Pattern Calculation: 3 X-ray, 4 Neutron',//,
     1'$Choice? <',I1,'> ')
      ITEMP = JOBXN
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.LT.1 .OR. ITEMP.GT.4 ) GO TO 3100
      JOBXN = ITEMP
C *
3200  WRITE(ITTO,3210) NBCKGD
3210  FORMAT(/,
     1'   Background:  0  Polynomial background to be refined',/,
     1 16X,           '1  Background is to be read from a file',/,
     1 16X,           'N  Interpolation between N given points',//,
     1'$Choice? <',I1,'> ')
      ITEMP = NBCKGD
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.LT.0 ) THEN
        GO TO 3200
       ELSE IF( ITEMP.GT.MAXBCK ) THEN
        WRITE(ITTO,3220) QBELL,MAXBCK
3220    FORMAT(1X,A1,'-Maximum number of points allowed is ',I4)
        GO TO 3200
       ELSE IF(ITEMP.GT.1) THEN
        WRITE(ITTO,3230) ITEMP
3230    FORMAT(/,'$Enter the ',I2,' points as  2theta,intensity:')
        DO 3240 I=1,ITEMP
        WRITE(ITTO,3250) I
3250    FORMAT('$Enter the values for point ',I2,' <0,0> ')
        POS(I) = 0.0
        BCK(I) = 0.0
        READ(ITTI,*,ERR=70000) POS(I),BCK(I)
3240    CONTINUE
        NBCKGD = ITEMP
       ELSE
        NBCKGD = ITEMP
      ENDIF
C *
3300  WRITE(ITTO,3310) NEXCRG
3310  FORMAT(/,
     1'$Number of excluded regions? <',I2,'> ')
      ITEMP = NEXCRG
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.LT.0 ) THEN
        GO TO 3300
       ELSE IF( ITEMP.GT.MAXEXC ) THEN
        WRITE(ITTO,3220) QBELL,MAXEXC
        GO TO 3300
       ELSE IF(ITEMP.GT.0) THEN
        WRITE(ITTO,3320) ITEMP
3320    FORMAT(/,'$Enter the ',I2,' points as  2theta-LOW,2theta-HIGH:')
        DO 3330 I=1,ITEMP
        WRITE(ITTO,3340) I
3340    FORMAT('$Enter the values for point ',I2,' <0,0> ')
        ALOW(I)  = 0.0
        AHIGH(I) = 0.0
        READ(ITTI,*,ERR=70000) ALOW(I),AHIGH(I)
3330    CONTINUE
        NEXCRG = ITEMP
      ENDIF
C *
3400  WRITE(ITTO,3410) NSCAT
3410  FORMAT(/,
     1'$Number of user-supplied scattering set entries? <',I2,'> ')
      ITEMP = NSCAT
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.LT.0 ) THEN
        GO TO 3400
       ELSE IF( ITEMP.GT.MAXSCA ) THEN
        WRITE(ITTO,3220) QBELL,MAXSCA
        GO TO 3400
       ELSE IF(ITEMP.GT.1) THEN
        WRITE(ITTO,3415) ITEMP
3415    FORMAT(/,'$Enter the ',I2,' scattering set entries:')
        DO 3420 I=1,NSCAT
        WRITE(ITTO,3430) QSCNAM(I)
3430    FORMAT('$Name for scatterer ',I2,'? (A4) <',A4,'>  ')
        READ(ITTI,3440) QSTR4
3440    FORMAT(A4)
        IF( QSTR4.NE.' ' .AND. QSTR4.NE.'/' ) QSCNAM(I) = QSTR4
        IF( JOBXN.EQ.1 .OR. JOBXN.EQ.3 ) THEN
          WRITE(ITTO,3450) DFP(I),DFPP(I)
3450      FORMAT('$Enter f'',f'''' for ',A4,' <',F6.4,',',F6.4,'> ')
          RTEMP  = DFP(I)
          RTEMP1 = DFPP(I)
          READ(ITTI,*,ERR=70000) RTEMP,RTEMP1
          DFP(I)  = RTEMP
          DFPP(I) = RTEMP1
          WRITE(ITTO,3460)
3460      FORMAT(/,'  Enter 9 scattering coefficients.',/,
     1    '  Defaults: ',8(F6.4,','),F6.4,/,'$Values? <Use above> ')
          READ(ITTI,*,ERR=70000) (AC(J,I),J=1,9)
         ELSE
          WRITE(ITTO,3462) DFP(I)
3462      FORMAT('$Enter scattering length <',F6.4,'> ')
          READ(ITTI,*,ERR=70000) RTEMP
          DFP(I)  = RTEMP
          DFPP(I) = 0.0
          DO 3464 J=1,9
3464      AC(J,I) = 0.0
        ENDIF
3420    CONTINUE
        NSCAT = ITEMP
      ENDIF
C *
3500  WRITE(ITTO,3510) KINTSF
3510  FORMAT(/,
     1'$Do you want to supply internal standard data? (0/1) <',I1,'> ')
      ITEMP = KINTSF
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.LT.0 .OR. ITEMP.GT. 1 ) GO TO 3500
      IF(ITEMP.EQ.0 ) THEN
        KINTSF = ITEMP
        GO TO 3600
      ENDIF
      IF(KINTSF.EQ.1) WRITE(ITTO,3520)
3520  FORMAT(/,'   Current quantitative analysis data:')
      WRITE(ITTO,3530) KINTSN,RINTSQ,KINTSA(1),RINTSA(1),
     1                 KINTSA(2),RINTSA(2),KINTSA(3),RINTSA(3)
3530  FORMAT('     The wgt fraction of phase ',I2,
     1' in the specimen is ',F6.4,/,
     1('     Scale factor correction for phase ',I2,' is ',F6.4))
      WRITE(ITTO,3540) KINTSN,RINTSQ
3540  FORMAT(/,
     1'$Enter number of standard phase, wgt fraction <',
     1 I2,',',F6.4,'> ')
      ITEMP = KINTSN
      RTEMP = RINTSQ
      READ(ITTI,*,ERR=70000) ITEMP,RTEMP
      IF( ITEMP.GT.0 .AND. ITEMP.LE.NPHS ) KINTSN = ITEMP
      IF( RTEMP.GE.0.0 .AND. RTEMP.LE.1.0 ) RINTSQ = RTEMP
      DO 3550 I=1,3
      WRITE(ITTO,3560) KINTSA(I),RINTSA(I)
3560  FORMAT(
     1 '$Enter phase number for SF correction, factor <',
     1 I2,',',F6.4,'> ')
      ITEMP = KINTSA(I)
      RTEMP = RINTSA(I)
      READ(ITTI,*,ERR=70000) ITEMP,RTEMP
      IF( ITEMP.GT.0 .AND. ITEMP.LE.NPHS ) KINTSA(I) = ITEMP
      IF( RTEMP.GE.0.0 .AND. RTEMP.LE.1.0 ) RINTSA(I) = RTEMP
3550  CONTINUE
      KINTSF = 1
C *
3600  WRITE(ITTO,3610) KAMOR
3610  FORMAT(/,
     1'$Do you want to include an amorphous profile? (0/1) <',I1,'> ')
      ITEMP = KAMOR
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.LT.0 .OR. ITEMP.GT. 1 ) GO TO 3600
      IF(ITEMP.EQ.0 ) THEN
        KAMOR = ITEMP
        GO TO 3000
      ENDIF
      IF(KAMOR.EQ.1) WRITE(ITTO,3620) (PAMORP(I),I=1,3)
3620  FORMAT(/,'   Current amorphous profile position  ',F8.4,/,
     1        29X,                        'intensity ',F8.2,/,
     1        29X,                        'FWHM      ',F8.4)
      WRITE(ITTO,3630) (PAMORP(I),I=1,3)
3630  FORMAT(/,'$Enter 2theta,Intensity,FWHM <',
     1 F6.2,',',F6.1,',',F4.1,'> ')
      RTEMP = PAMORP(1)
      RTEMP2 = PAMORP(2)
      RTEMP3 = PAMORP(3)
      READ(ITTI,*,ERR=70000) RTEMP,RTEMP2,RTEMP3
      IF( RTEMP.GT.0.0 .AND. RTEMP.LT.180.0 ) PAMORP(1) = RTEMP
      IF( RTEMP2.GT.0.0 ) PAMORP(2) = RTEMP2
      IF( RTEMP3.GT.0.0 ) PAMORP(3) = RTEMP3
      KAMOR = 1
C *
      GO TO 3000
C *
C *  OUTPUT CONTROL FLAGS
C *
4000  ASSIGN 4000 TO IERLBL
      WRITE(ITTO,4010) IOUT,IPLT,IPCH,MAT,NXT,LST1,LST2,LST3,
     1                  ISYM,IPLT2,KCLRCW
4010  FORMAT(/,' Output control flags  ( 0 Off 1 On ):',//,
     1'   Intensities         ',I2,
     1    '   Obs. and Calc. intensities',/,
     1'   Line printer plot   ',I2,
     1    '   Generates a plot',/,
     1'   Structure factors   ',I2,
     1    '   Obs. and Calc. F values',/,
     1'   Correlation matrix  ',I2,
     1    '   Parameter correlation matrix',/,
     1'   New input file      ',I2,
     1    '   Write refined parameters to a file',/,
     1'   Line listing        ',I2,
     1    '   List lines for each phase',/,
     1'   Corrected intens.   ',I2,
     1    '   Output corrected intensities',/,
     1'   Merged list         ',I2,
     1    '   Composite list of reflections',/,
     1'   Symmetry operators  ',I2,
     1    '   List operators for space group',/,
     1'   Plot file           ',I2,
     1    '   Write plot data to file',/,
     1'   Clear codewords     ',I2,
     1    '   Zero unused codewords')
      WRITE(ITTO,3020)
      READ(ITTI,3030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) GO TO 5000
C *
C *   IOUT,IPLT,IPCH,MAT,NXT,LST1,LST2,LST3,ISYM,IPLT2,KCLRCW
4100  WRITE(ITTO,4110) IOUT
4110  FORMAT('$Obs. and Calc. intensities (0/1) <',I1,'> ')
      ITEMP = IOUT
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.EQ.0 .OR. ITEMP.EQ.1 ) IOUT = ITEMP
      WRITE(ITTO,4115) IPLT
4115  FORMAT('$Line printer plot (0/1) <',I1,'> ')
      ITEMP = IPLT
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.EQ.0 .OR. ITEMP.EQ.1 ) IPLT = ITEMP
      WRITE(ITTO,4120) IPCH
4120  FORMAT('$Obs. and Calc. F values (0/1) <',I1,'> ')
      ITEMP = IPCH
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.EQ.0 .OR. ITEMP.EQ.1 ) IPCH = ITEMP
      WRITE(ITTO,4125) MAT
4125  FORMAT('$Parameter correlation matrix (0/1) <',I1,'> ')
      ITEMP = MAT
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.EQ.0 .OR. ITEMP.EQ.1 ) MAT = ITEMP
      WRITE(ITTO,4130) NXT
4130  FORMAT('$Write refined parameters to a file (0/1) <',I1,'> ')
      ITEMP = NXT
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.EQ.0 .OR. ITEMP.EQ.1 ) NXT = ITEMP
      WRITE(ITTO,4135) LST1
4135  FORMAT('$List lines for each phase (0/1) <',I1,'> ')
      ITEMP = LST1
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.EQ.0 .OR. ITEMP.EQ.1 ) LST1 = ITEMP
      WRITE(ITTO,4140) LST2
4140  FORMAT('$Output corrected intensities (0/1) <',I1,'> ')
      ITEMP = LST2
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.EQ.0 .OR. ITEMP.EQ.1 ) LST2 = ITEMP
      WRITE(ITTO,4145) LST3
4145  FORMAT('$Composite list of reflections (0/1) <',I1,'> ')
      ITEMP = LST3
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.EQ.0 .OR. ITEMP.EQ.1 ) LST3 = ITEMP
      WRITE(ITTO,4150) ISYM
4150  FORMAT('$List operators for space group (0/1) <',I1,'> ')
      ITEMP = ISYM
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.EQ.0 .OR. ITEMP.EQ.1 ) ISYM = ITEMP
      WRITE(ITTO,4155) IPLT2
4155  FORMAT('$Write plot data to file (0/1) <',I1,'> ')
      ITEMP = IPLT2
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.EQ.0 .OR. ITEMP.EQ.1 ) IPLT2 = ITEMP
      WRITE(ITTO,4160) KCLRCW
4160  FORMAT('$Zero unused codewords (0/1) <',I1,'> ')
      ITEMP = KCLRCW
      READ(ITTI,*,ERR=70000) ITEMP
      IF( ITEMP.EQ.0 .OR. ITEMP.EQ.1 ) KCLRCW = ITEMP
C *
      GO TO 4000
C *
5000  ASSIGN 5000 TO IERLBL
      WRITE(ITTO,5010) WAVE1,WAVE2,RATIO,WDT,CTHM
5010  FORMAT(/,
     1'   Wavelength(s)       ',F8.5,
     1'  Enter 0.0 for the second wavelength if only',/,
     1'                       ',F8.5,
     1'   one wavelength in radiation spectrum',/,
     1'   A2:A1 ratio         ',F8.5,
     1'  Set to 0.0 if only 1 wavelength present',/,
     1'   Line width          ',F8.5,
     1'  Range of lines in units of FWHM',/,
     1'   Mono. Correction    ',F8.5,
     1'  Set to 1.0 if no monochromator used')
      WRITE(ITTO,3020)
      READ(ITTI,3030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) GO TO 8000
C *
C *   WAVE1,WAVE2,RATIO,WDT,CTHM
5100  WRITE(ITTO,5110) WAVE1,WAVE2,RATIO
5110  FORMAT('$ Wavelengths A1, A2, Ratio? <',
     1  F8.6,',',F8.6,',',F6.4,'> ')
      RTEMP = WAVE1
      RTEMP1 = WAVE2
      RTEMP2 = RATIO
      READ(ITTI,*,ERR=70000) RTEMP,RTEMP1,RTEMP2
      IF(RTEMP.GT.0.0) WAVE1 = RTEMP
      IF(RTEMP1.GE.0.0) WAVE2 = RTEMP1
      IF(RTEMP2.GE.0.0) RATIO = RTEMP2
C *
5200  WRITE(ITTO,5210) WDT
5210  FORMAT('$ Extent of tails in units of FWHM? <',F5.2,'> ')
      RTEMP = WDT
      READ(ITTI,*,ERR=70000) RTEMP
      IF(RTEMP.GT.0.0) WDT = RTEMP
C *
5300  WRITE(ITTO,5310) CTHM
5310  FORMAT('$ Monochromator correction (1.0 for none) <',F6.4,'> ')
      RTEMP = CTHM
      READ(ITTI,*,ERR=70000) RTEMP
      IF(RTEMP.GE.0.0) CTHM = RTEMP
C *
      GO TO 5000
C *
C *  PATTERN PARAMETERS
C *
8000  ASSIGN 8000 TO IERLBL
      WRITE(ITTO,8010) THMIN,THMAX,STEP
8010  FORMAT(/,
     1'   Pattern angles:  Low ',F6.2,'  High ',F6.2,
     1'  Increment ',F7.4)
      WRITE(ITTO,3020)
      READ(ITTI,3030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) GO TO 6000
C *
8100  RTEMP  = THMIN
      RTEMP1 = THMAX
      RTEMP2 = STEP
      IF( JOBXN.EQ.1 .OR. JOBXN.EQ.2 ) THEN
        WRITE(ITTO,8140) THMIN,THMAX
8140    FORMAT(
     1  '$Enter 2theta Low,High (Inc. fixed by pattern) <',
     1  F6.2,',',F6.2,'> ')
        READ(ITTI,*,ERR=70000) RTEMP,RTEMP1
       ELSE
        WRITE(ITTO,8110) THMIN,THMAX,STEP
8110    FORMAT('$Enter 2theta Low,High,Increment <',
     1  F6.2,',',F6.2,',',F7.4,'> ')
        READ(ITTI,*,ERR=70000) RTEMP,RTEMP1,RTEMP2
      ENDIF
      IF(RTEMP1.LE.RTEMP) THEN
        WRITE(ITTO,8120) QBELL
8120    FORMAT(1X,A1,'--High angle must be > Low angle: Try again.')
        GO TO 8000
      ENDIF
      IF( ( JOBXN.EQ.3 .OR. JOBXN.EQ.4 ) .AND. RTEMP2.LE.0.0 ) THEN
        WRITE(ITTO,8130) QBELL
8130    FORMAT(1X,A1,'--Increment must be > 0.0: Try again.')
        GO TO 8000
      ENDIF
      IF( RTEMP .GT.0.0 ) THMIN = RTEMP
      IF( RTEMP1.GT.0.0 ) THMAX = RTEMP1
      IF( RTEMP2.GT.0.0 ) STEP  = RTEMP2
C *
      GO TO 8000
C *
C *  CONVERGENCE AND RELAXATION PARAMETERS
C *
6000  ASSIGN 6000 TO IERLBL
      WRITE(ITTO,6010) EPS,RELAX
6010  FORMAT(/,' Convergence test parameter and relaxation factors:',//,
     1'   Eps value           ',F6.4,'  Convergence parameter',/,
     1'   Relax: Atoms        ',F6.4,
     1    '  Atom coords, iso thermal, occupancies',/,
     1'   Relax: Atom ansio   ',F6.4,
     1    '  Anisotropic thermal parameters',/,
     1'   Relax: Phase params ',F6.4,
     1    '  Scale, overal iso thermal, all profile-related',/,
     1 32X,'params, lattice params, pref. orient. params',/,
     1'   Relax: Global       ',F6.4,
     1    '  Zero pt, spec. disp., bkg, amorph. prof. params')
      WRITE(ITTO,3020)
      READ(ITTI,3030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) GO TO 7000
C *
6100  WRITE(ITTO,6110) EPS
6110  FORMAT(/,'$Enter convergence parameter EPS <',F4.2,'> ')
      RTEMP = EPS
      READ(ITTI,*,ERR=70000) RTEMP
      IF(RTEMP.GT.0.0) EPS = RTEMP
C *
6200  WRITE(ITTO,6210) RELAX(1)
6210  FORMAT('$Relax for atom parameters? <',F4.2,'> ')
      RTEMP = RELAX(1)
      READ(ITTI,*,ERR=70000) RTEMP
      IF(RTEMP.GT.0.0) RELAX(1) = RTEMP
      WRITE(ITTO,6220) RELAX(2)
6220  FORMAT('$Relax for atom aniso therm parameters? <',F4.2,'> ')
      RTEMP = RELAX(2)
      READ(ITTI,*,ERR=70000) RTEMP
      IF(RTEMP.GT.0.0) RELAX(2) = RTEMP
      WRITE(ITTO,6230) RELAX(3)
6230  FORMAT('$Relax for phase-related parameters? <',F4.2,'> ')
      RTEMP = RELAX(3)
      READ(ITTI,*,ERR=70000) RTEMP
      IF(RTEMP.GT.0.0) RELAX(3) = RTEMP
      WRITE(ITTO,6240) RELAX(4)
6240  FORMAT('$Relax for atom parameters? <',F4.2,'> ')
      RTEMP = RELAX(4)
      READ(ITTI,*,ERR=70000) RTEMP
      IF(RTEMP.GT.0.0) RELAX(4) = RTEMP
C *
      GO TO 6000
C *
C *  ZERO POINT AND SPECIMEN DISPLACEMENT
C *
7000  ASSIGN 7000 TO IERLBL
      WRITE(ITTO,7010) PZERPT,PDISP
7010  FORMAT(/,
     1'   Zero point offset   ',F6.4,'  Added to calc. line postions',/,
     1'   Spec. displacement  ',F6.4,'  Value of S/R')
      WRITE(ITTO,3020)
      READ(ITTI,3030) QANS
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) GO TO 9000
C *
7100  WRITE(ITTO,7110) PZERPT
7110  FORMAT('$Zero-pt displacement? <',F4.2,'> ')
      RTEMP = PZERPT
      READ(ITTI,*,ERR=70000) RTEMP
      IF(RTEMP.GE.0.0) PZERPT = RTEMP
C *
7200  WRITE(ITTO,7210) PDISP
7210  FORMAT('$Specimen displacement? <',F4.2,'> ')
      RTEMP = PDISP
      READ(ITTI,*,ERR=70000) RTEMP
      IF(RTEMP.GE.0.0) PDISP = RTEMP
C *
      GO TO 7000
C *
C **  INPUT ERROR RECOVERY ROUTINE
C *
70000 WRITE(ITTO,70010) QBELL,QBELL
70010 FORMAT(//,1X,A1,
     1'Your input could not be read.  Please re-read the prompt and',
     1' enter the',/,
     1' appropriate information.  (The most likely problem was a mis-',
     1'placed decimal)',A1)
      GO TO IERLBL
C *
C **  JOB COMPLETE ..... RETURN TO MAIN
C
9000  RETURN
      END
C **  ERETPH - CHANGE PHASE DATA IN MEMORY
C *
      SUBROUTINE ERETPH
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      LOGICAL   LPARM,LCODE
      CHARACTER QANS*1,QSTR*80,QBELL*1
C *
1000  QBELL = CHAR(7)
C *
C *   DISPLAY PHASE LIST CURRENTLY IN MEMORY
1005  IF(NPHS.EQ.0) THEN
        WRITE(ITTO,1010) (I,QPHSNM(I),I=1,NPHS)
1010    FORMAT(/,' ** There are no phase data currently in memory.')
        GO TO 9000
      ENDIF
      WRITE(ITTO,1020) (I,QPHSNM(I),I=1,NPHS)
1020  FORMAT(/,' ** The phases currently in memory include:',//,
     1 (4X,I2,' - ',A32))
      WRITE(ITTO,1030)
1030  FORMAT(/,'$Number of the phase to edit? <0:Exit> ')
      IEDPH = 0
      READ(ITTI,*) IEDPH
      IF(IEDPH.EQ.0) GO TO 9000
      IF( IEDPH.LT.1 .OR. IEDPH.GT.NPHS ) GO TO 1005
      IPH = IEDPH
C *
C *  DETERINE WHAT IS TO BE CHANGED
      WRITE(ITTO,1040)
1040  FORMAT(/,
     1'$Edit (P)arameter values, (F)ractional shifts or (B)oth? <P> ')
      READ(ITTI,1050) QANS
1050  FORMAT(A1)
      IF( QANS.EQ.' ' .OR. QANS.EQ.'/' ) QANS = 'P'
      LPARM = QANS.EQ.'P'.OR.QANS.EQ.'p' .OR. QANS.EQ.'B'.OR.QANS.EQ.'b'
      LCODE = QANS.EQ.'F'.OR.QANS.EQ.'f' .OR. QANS.EQ.'B'.OR.QANS.EQ.'b'
C *
C **  CALL EDIT TO EDIT PHASE DATA
C *
      CALL EDIT( LPARM, LCODE, .FALSE. )
C *
C *  RETURN FOR NEXT PHASE TO CHANGE
      GO TO 1005
C *
C **  JOB COMPLETE ..... RETURN TO MAIN
9000  RETURN
      END
C **  ERETCW - EDIT CODEWORDS FOR RIETVELD REFINEMENT ALGORITHM
C *
      SUBROUTINE ERETCW( IACT )
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QANS*1,QBELL*1
      DIMENSION KCNEW(20),KKRND(5,20),CCSHFT(20)
C *
      QBELL = CHAR(7)
C *
C *  ACTION BASED ON VALUE OF IFLAG
      IF(IACT.EQ.0) GO TO 1000
      IF(IACT.EQ.1) GO TO 2000
      IF(IACT.EQ.2) GO TO 3000
      STOP '--ERETCW: BAD VALUE OF IACT'
C *
C **  DETERMINE IF THE DEFAULTS ARE SUFFICIENT
C *
1000  WRITE(ITTO,1010)
1010  FORMAT(/,' ***  DEFINITION OF REFINEMENT ALGORITHM')
      WRITE(ITTO,1020)
1020  FORMAT(/,'$Do you want the default algorithm? <N> ')
      READ(ITTI,1030) QANS
1030  FORMAT(A1)
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) GO TO 3000
C *
C **  INITIALIZE CODEWORDS WITH DEFAULT PARAMETERS
C *
C *  INITIALIZE ZEROPT AND DISPLACEMENT PARAMETERS AND CODEWORDS
2000  PZERPT = 0.0
      KZERPT =   0
      PDISP  = 0.0
      KDISP  =   3
C *
C *  AMORPHOUS PROFILE PARAMETERS
      KAMORP(1) = 2
      KAMORP(2) = 3
      KAMORP(3) = 3
C *
C *  INITIALIZE BACKGROUND CODEWORDS AND PARAMETERS
      PBKG(1) = 1.0
      PBKG(2) = 0.0
      PBKG(3) = 0.0
      PBKG(4) = 0.0
      PBKG(5) = 0.0
      PBKG(6) = 0.0
      KBKG(1) =   1
      KBKG(2) =   1
      KBKG(3) =   2
      KBKG(4) =   3
      KBKG(5) =   0
      KBKG(6) =   0
C *
C *  INITIALIZE PARAMETERS AND CODEWORDS FOR ALL PHASES
C *
C *  REPEAT FOR ALL PHASES
      DO 2010 IPH = 1,NPHS
C *
C *  REPEAT FOR ALL ATOMS
C      DO 2020 IATM=1,NATOM(IPH)
C      KAXYZ(1,IATM,IPH) = 0
C      KAXYZ(2,IATM,IPH) = 0
C      KAXYZ(3,IATM,IPH) = 0
C      KOCCU(IATM,IPH) = 0
C      KBISO(IATM,IPH) = 0
C      DO 2030 J=1,6
C2030  KBAIS(J,IATM,IPH) = 0
C      DO 2040 J=1,3
C2040  KVMAG(J,IATM,IPH) = 0
C2020  CONTINUE
C *
C *  PROFILE-SHAPE-FUNCTION PARAMETERS AND CODEWORDS
      PPSFC(1,1,IPH) = 1.0
      PPSFC(2,1,IPH) = 0.0
      PPSFC(3,1,IPH) = 0.0
      IF(KPSF(1,IPH).GT.1) THEN
        KPSFC(1,1,IPH) =   4
        KPSFC(2,1,IPH) =   0
        KPSFC(3,1,IPH) =   0
       ELSE
        KPSFC(1,1,IPH) =   0
        KPSFC(2,1,IPH) =   0
        KPSFC(3,1,IPH) =   0
      ENDIF
      PPSFC(1,2,IPH) = 1.0
      PPSFC(2,2,IPH) = 0.0
      PPSFC(3,2,IPH) = 0.0
      IF(KPSF(1,IPH).GT.1) THEN
        KPSFC(1,2,IPH) =   4
        KPSFC(2,2,IPH) =   0
        KPSFC(3,2,IPH) =   0
       ELSE
        KPSFC(1,2,IPH) =   0
        KPSFC(2,2,IPH) =   0
        KPSFC(3,2,IPH) =   0
      ENDIF
      PASYP(IPH)     = 0.0
      KASYP(IPH)     =   0
C *
C *  PROFILE BROADENING PARAMETERS
      PUVW(3,1,IPH) = 0.010
      PUVW(2,1,IPH) = 0.000
      PUVW(1,1,IPH) = 0.000
      KUVW(3,1,IPH) =     2
      KUVW(2,1,IPH) =     3
      KUVW(1,1,IPH) =     4
      PUVW(3,2,IPH) = 0.010
      PUVW(2,2,IPH) = 0.000
      PUVW(1,2,IPH) = 0.000
      KUVW(3,2,IPH) =     2
      KUVW(2,2,IPH) =     3
      KUVW(1,2,IPH) =     4
C *
C *  PREFERRED ORIENTATION PARAMETERS
      KPREF(1,1,IPH) = 0
      KPREF(2,1,IPH) = 0
      KPREF(1,2,IPH) = 0
      KPREF(2,2,IPH) = 0
C *
C *  SCALE AND OVERALL ISOTROPIC TEMPERATURE PARAMETERS
      KSCALE(IPH) = 1
      KOVISO(IPH) = 0
      KABSCO(IPH) = 0
C *
C *  LATTICE PARAMETERS
      KCELL(1,IPH) = 2
      KCELL(2,IPH) = 2
      KCELL(3,IPH) = 2
      KCELL(4,IPH) = 2
      KCELL(5,IPH) = 2
      KCELL(6,IPH) = 2
C *
2010  CONTINUE
C *
C *  CYCLES PER ROUND SET TO 3
      DO 2050 I=1,20
2050  KAUTOR(I) = 3
C *
      GO TO 9000
C *
C **  DEFINE REFINEMENT ALGORITHM
C *
C *  GIVE INSTRUCTIONS...
3000  WRITE(ITTO,3010)
3010  FORMAT(/,
     1'$Change the (R)ound assignments or (N)umber of cycles/round?',
     1' <R> ')
      READ(ITTI,1030) QANS
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 8000
C *
C *  INITIALIZE PROFILE-RELATED PARAMETERS AND CODEWORDS FOR ALL PHASES
C *
3100  WRITE(ITTO,3102)
3102  FORMAT(//,
     1' **  Assignment of parameters to refinement rounds:',//,
     1' Enter the round on which to begin refinement on the',
     1' parameter.',/,
     1' A value of 0 means the parameter is not to be refined.')
C *
C *  REPEAT FOR EACH PHASE
      DO 3110 IPH = 1,NPHS
C *
      WRITE(ITTO,3120) IPH,QPHSNM(IPH)
3120  FORMAT(//,' * Parameters for phase ',I2,':',1X,A32)
C *
      IF(NPHS.GT.1) THEN
        WRITE(ITTO,3122)
3122    FORMAT(/,
     1'$Do you want to change the assignments for this phase <N> ')
        READ(ITTI,1030) QANS
        IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) GO TO 3110
      ENDIF
C *
4000  WRITE(ITTO,4010)
4010  FORMAT(/,
     1'$Reset profile parameters (UVW,P1,P2,ASY) for phase <N> ')
      READ(ITTI,1030) QANS
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
        PPSFC(1,1,IPH) = 1.0
        PPSFC(2,1,IPH) = 0.0
        PPSFC(3,1,IPH) = 0.0
        PPSFC(1,2,IPH) = 1.0
        PPSFC(2,2,IPH) = 0.0
        PPSFC(3,2,IPH) = 0.0
        PASYP(IPH)     = 0.0
        PUVW(1,1,IPH)  = 0.00
        PUVW(2,1,IPH)  = 0.00
        PUVW(3,1,IPH)  = 0.01
        PUVW(1,2,IPH)  = 0.00
        PUVW(2,2,IPH)  = 0.00
        PUVW(3,2,IPH)  = 0.01
      ENDIF
C *
4100  ASSIGN 4100 TO IERLBL
      CALL KWDEKO( KSCALE(IPH), 1, KKRND(1,1), CCSHFT(1) )
      CALL KWDEKO( KOVISO(IPH), 1, KKRND(1,2), CCSHFT(2) )
      CALL KWDEKO( KABSCO(IPH), 1, KKRND(1,3), CCSHFT(3) )
      WRITE(ITTO,4110) (KKRND(1,J),J=1,3)
4110  FORMAT(/,
     1 '$Scale factor, Overall iso. temp., Absorption factors',
     1 ' <',I2,',',I2,',',I2,'> ')
      READ(ITTI,*,ERR=70000) (KKRND(1,J),J=1,3)
      CALL KWKODE( KSCALE(IPH), 1, KKRND(1,1), CCSHFT(1) )
      CALL KWKODE( KOVISO(IPH), 1, KKRND(1,2), CCSHFT(2) )
      CALL KWKODE( KABSCO(IPH), 1, KKRND(1,3), CCSHFT(3) )
C *
4200  ASSIGN 4200 TO IERLBL
      IF( KPSF(2,IPH).EQ.2 .OR. KPSF(2,IPH).EQ.3 ) THEN
        CALL KWDEKO( KPSFC(1,1,IPH), 3, KKRND(1,1), CCSHFT(1) )
        WRITE(ITTO,4210) 'Low angle ',(KKRND(1,J),J=1,3)
4210    FORMAT(
     1  '$Profile coefficients P1,P2 and P3 (',A10,') <',
     1  I2,',',I2,',',I2,'> ')
        READ(ITTI,*,ERR=70000) (KKRND(1,J),J=1,3)
        CALL KWKODE( KPSFC(1,1,IPH), 3, KKRND(1,1), CCSHFT(1) )
        CALL KWDEKO( KPSFC(1,2,IPH), 3, KKRND(1,1), CCSHFT(1) )
        WRITE(ITTO,4210) 'High angle',(KKRND(1,J),J=1,3)
        READ(ITTI,*,ERR=70000) (KKRND(1,J),J=1,3)
        CALL KWKODE( KPSFC(1,2,IPH), 3, KKRND(1,1), CCSHFT(1) )
       ELSE
        CALL KWDEKO( KPSFC(1,1,IPH), 3, KKRND(1,1), CCSHFT(1) )
        WRITE(ITTO,4210) 'Symmetric ',(KKRND(1,J),J=1,3)
        READ(ITTI,*,ERR=70000) (KKRND(1,J),J=1,3)
        CALL KWKODE( KPSFC(1,1,IPH), 3, KKRND(1,1), CCSHFT(1) )
        KPSFC(1,2,IPH) = 0
        KPSFC(2,2,IPH) = 0
        KPSFC(3,2,IPH) = 0
      ENDIF
      CALL KWDEKO( KASYP, 1, KKRND(1,1), CCSHFT(1) )
      WRITE(ITTO,4220) KKRND(1,1)
4220  FORMAT('$Asymmetry parameter <',I2,'> ')
      READ(ITTI,*,ERR=70000) KKRND(1,1)
      CALL KWKODE( KASYP, 1, KKRND(1,1), CCSHFT(1) )
C *
4300  ASSIGN 4300 TO IERLBL
      IF( KPSF(2,IPH).EQ.1 .OR. KPSF(2,IPH).EQ.3 ) THEN
        CALL KWDEKO( KUVW(1,1,IPH), 3, KKRND(1,1), CCSHFT(1) )
        WRITE(ITTO,4310) 'Low angle ',(KKRND(1,J),J=3,1,-1)
4310    FORMAT(
     1'$FHWM parameters W,V,U  (',A10,')  <',I2,',',I2,',',I2,'> ')
        READ(ITTI,*,ERR=70000) (KKRND(1,J),J=3,1,-1)
        CALL KWKODE( KUVW(1,1,IPH), 3, KKRND(1,1), CCSHFT(1) )
        CALL KWDEKO( KUVW(1,2,IPH), 3, KKRND(1,1), CCSHFT(1) )
        WRITE(ITTO,4310) 'High angle',(KKRND(1,J),J=3,1,-1)
        READ(ITTI,*,ERR=70000) (KKRND(1,J),J=3,1,-1)
        CALL KWKODE( KUVW(1,2,IPH), 3, KKRND(1,1), CCSHFT(1) )
       ELSE
        CALL KWDEKO( KUVW(1,1,IPH), 3, KKRND(1,1), CCSHFT(1) )
        WRITE(ITTO,4310) 'Symmetric ',(KKRND(1,J),J=3,1,-1)
        READ(ITTI,*,ERR=70000) (KKRND(1,J),J=3,1,-1)
        CALL KWKODE( KUVW(1,1,IPH), 3, KKRND(1,1), CCSHFT(1) )
        KUVW(1,2,IPH) = 0
        KUVW(2,2,IPH) = 0
        KUVW(3,2,IPH) = 0
      ENDIF
C *
4400  ASSIGN 4400 TO IERLBL
      CALL KWDEKO( KCELL(1,IPH), 1, KKRND(1,1), CCSHFT(1) )
      WRITE(ITTO,4410) KKRND(1,1)
4410  FORMAT('$Lattice parameters <',I2,'> ')
      READ(ITTI,*,ERR=70000) KKRND(1,1)
      CALL KWKODE( KCELL(1,IPH), 1, KKRND(1,1), CCSHFT(1) )
C *
4500  ASSIGN 4500 TO IERLBL
      CALL KWDEKO( KPREF(1,1,IPH), 2, KKRND(1,1), CCSHFT(1) )
      WRITE(ITTO,4510) (KKRND(1,J),J=1,2)
4510  FORMAT(
     1'$Preferred orientation vector 1.  Coefficients B1,B2 <',
     1 I2,',',I2,'> ')
      READ(ITTI,*,ERR=70000) (KKRND(1,J),J=1,2)
      CALL KWKODE( KPREF(1,1,IPH), 2, KKRND(1,1), CCSHFT(1) )
      IF(KPOCT(2,IPH).EQ.1) THEN
        CALL KWDEKO( KPREF(1,2,IPH), 2, KKRND(1,1), CCSHFT(1) )
        WRITE(ITTO,4520) (KKRND(1,J),J=1,2)
4520    FORMAT(
     1  '$Preferred orientation vector 2.  Coefficients B1,B2 <',
     1  I2,',',I2,'> ')
        READ(ITTI,*,ERR=70000) (KKRND(1,J),J=1,2)
        CALL KWKODE( KPREF(1,2,IPH), 2, KKRND(1,1), CCSHFT(1) )
      ENDIF
C *
3110  CONTINUE
C *
C *  INITIALIZE ZEROPT, DISPLACEMENT AND BACKGROUND VALUES
5000  WRITE(ITTO,5010)
5010  FORMAT(//,' * Global parameters',//,
     1'$Initialize Zero pt., Specimen disp. and Bkg values? <N> ')
      READ(ITTI,1030) QANS
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
        PZERPT  = 0.0
        PDISP   = 0.0
        PBKG(1) = 0.0
        PBKG(2) = 0.0
        PBKG(3) = 0.0
        PBKG(4) = 0.0
        PBKG(5) = 0.0
        PBKG(6) = 0.0
      ENDIF
C *
C *  INITIALIZE ZEROPT AND DISPLACEMENT CODEWORDS
5100  ASSIGN 5100 TO IERLBL
      CALL KWDEKO( KZERPT, 1, KKRND(1,1), CCSHFT(1) )
      CALL KWDEKO( KDISP , 1, KKRND(1,2), CCSHFT(2) )
      WRITE(ITTO,5110) (KKRND(1,J),J=1,2)
5110  FORMAT(/,
     1'$Zero point and specimen displacement <',I2,',',I2,'> ')
      READ(ITTI,*,ERR=70000) (KKRND(1,J),J=1,2)
      CALL KWKODE( KZERPT, 1, KKRND(1,1), CCSHFT(1) )
      CALL KWKODE( KDISP , 1, KKRND(1,2), CCSHFT(2) )
C *
C *  INITIALIZE AMORPHOUS PROFILE CODEWORDS
5200  ASSIGN 5200 TO IERLBL
      IF(KAMOR.EQ.1) THEN
        CALL KWDEKO( KAMORP(1), 3, KKRND(1,1), CCSHFT(1) )
        WRITE(ITTO,5210) (KKRND(1,J),J=1,3)
5210    FORMAT(
     1  '$Amorphous profile 2theta, ints, width <',2(I2,','),I2,'> ')
        READ(ITTI,*,ERR=70000) (KKRND(1,J),J=1,3)
        CALL KWKODE( KAMORP(1), 3, KKRND(1,1), CCSHFT(1) )
      ENDIF
C *
C *  INITIALIZE BACKGROUND CODEWORDS
5300  ASSIGN 5300 TO IERLBL
      IF(NBCKGD.EQ.0) THEN
        CALL KWDEKO( KBKG(1), 6, KKRND(1,1), CCSHFT(1) )
        WRITE(ITTO,5310) (KKRND(1,J),J=1,6)
5310    FORMAT('$Background parameters <',5(I2,','),I2,'> ')
        READ(ITTI,*,ERR=70000) (KKRND(1,J),J=1,6)
        CALL KWKODE( KBKG(1), 6, KKRND(1,1), CCSHFT(1) )
      ENDIF
C *
C *  REPEAT FOR EACH PHASE AND SET OF ATOM PARAMETERS
C *
6000  DO 6010 IPH=1,NPHS
      WRITE(ITTO,6020) IPH,QPHSNM(IPH)
6020  FORMAT(//,' * Atom parameters for phase ',I2,':',1X,A32,//,
     1  '$Do you want to edit the atom round assignments? <N> ')
      READ(ITTI,1030) QANS
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) GO TO 6010
C *
C *  REPEAT FOR EACH ATOM
      DO 6030 IATM = 1,NATOM(IPH)
C *
7000  ASSIGN 7000 TO IERLBL
      CALL KWDEKO( KAXYZ(1,IATM,IPH), 3, KKRND(1,1), CCSHFT(1) )
      WRITE(ITTO,7010) IATM,QATOM(IATM,IPH),(KKRND(1,J),J=1,3)
7010  FORMAT(/,
     1'$Atom ',I2,' (',A8,')  x,y,z <',I2,',',I2,',',I2,'> ')
      READ(ITTI,*,ERR=70000) (KKRND(1,J),J=1,3)
      CALL KWKODE( KAXYZ(1,IATM,IPH), 3, KKRND(1,1), CCSHFT(1) )
      CALL KWDEKO( KBISO(IATM,IPH), 1, KKRND(1,1), CCSHFT(1) )
      CALL KWDEKO( KOCCU(IATM,IPH), 1, KKRND(1,2), CCSHFT(2) )
      WRITE(ITTO,7020) (KKRND(1,J),J=1,2)
7020  FORMAT(
     1'$  Isotropic B and occupancy factor <',I2,',',I2,'> ')
      READ(ITTI,*,ERR=70000) (KKRND(1,J),J=1,2)
      CALL KWKODE( KBISO(IATM,IPH), 1, KKRND(1,1), CCSHFT(1) )
      CALL KWKODE( KOCCU(IATM,IPH), 1, KKRND(1,2), CCSHFT(2) )
      CALL KWDEKO( KBAIS(1,IATM,IPH), 6, KKRND(1,1), CCSHFT(1) )
      WRITE(ITTO,7030) (KKRND(1,J),J=1,6)
7030  FORMAT(
     1'$  Anisotropic thermal parameters <',I2,5(',',I2),'> ')
      READ(ITTI,*,ERR=70000) (KKRND(1,J),J=1,6)
      CALL KWKODE( KBAIS(1,IATM,IPH), 6, KKRND(1,1), CCSHFT(1) )
      IF(KMAGSI(IATM,IPH).EQ.1) THEN
        CALL KWDEKO( KVMAG(1,IATM,IPH), 3, KKRND(1,1), CCSHFT(1) )
        WRITE(ITTO,7040) (KKRND(1,J),J=1,3)
7040    FORMAT(
     1  '$  Magnetic vector <',I2,2(',',I2),'> ')
        READ(ITTI,*,ERR=70000) (KKRND(1,J),J=1,3)
        CALL KWKODE( KVMAG(1,IATM,IPH), 3, KKRND(1,1), CCSHFT(1) )
      ENDIF
C *
6030  CONTINUE
C *
C *  NEXT PHASE
6010  CONTINUE
C *
C **  CHECK ASSIGNMENT AND NUMBER OF CYCLES PER ROUND
C *
8000  CALL ARETCW( IFLAG )
C *
C *  EXIT NOW IF AN ERROR WAS ENCOUNTERED
      IF(IFLAG.NE.0) THEN
        WRITE(ITTO,8010)
8010    FORMAT(/,
     1' --An error occurred during the assignment of the codewords.',/,
     1'   Please edit the phase data and correct the problem.')
        GO TO 9000
      ENDIF
C *
C *  ASK IF THE NUMBER OF CYCLES PER ROUND IS TO BE CHANGED
8100  ASSIGN 8100 TO IERLBL
      DO 8105 I=1,20
      KCNEW(I) = KAUTOR(I)
8105  CONTINUE
      WRITE(ITTO,8110)
8110  FORMAT(/,
     1'$Enter new number of cycles per round if necessary <No change> ')
      READ(ITTI,*,ERR=70000) KCNEW
      ICHNG = 0
      DO 8115 I=1,20
      IF(KCNEW(I).NE.KAUTOR(I)) ICHNG = 1
      KAUTOR(I) = KCNEW(I)
8115  CONTINUE
      IF(ICHNG.EQ.0) GO TO 9000
      WRITE(ITTO,8120)
8120  FORMAT(//,
     1' Refinement algorithm for current problem:',//,
     1' Round:        1   2   3   4   5   6   7   8   9  10  11  12',
     1'  13  14  15',/,
     1'             --- --- --- --- --- --- --- --- --- --- --- ---',
     1' --- --- ---')
      WRITE(ITTO,8130) (KAUTOV(I),I=1,NRND)
8130  FORMAT(' Variables: ',20I4)
      WRITE(ITTO,8140) (KAUTOR(I),I=1,NRND)
8140  FORMAT(' Cycles:    ',20I4)
      GO TO 8100
C *
C **  INPUT ERROR RECOVERY ROUTINE
C *
70000 WRITE(ITTO,70010) QBELL,QBELL
70010 FORMAT(//,1X,A1,
     1'Your input could not be read.  Please re-read the prompt and',
     1' enter the',/,
     1' appropriate information.  (The most likely problem was a mis-',
     1'placed decimal)',A1)
      GO TO IERLBL
C *
C **  ASSIGNMENT COMPLETE
C *
9000  RETURN
      END
C **  IRETCW - INITIALIZE KODEWORDS BASED ON RIETVELD CODEWORDS
C *
C *  IZERO: 0 - SET ALL CODEWORDS AND ROUND FLAGS TO 0
C *         1 - ASSIGN CODEWORD ROUND FLAGS BASED ON KAUTOR,KAUTOV
C *
      SUBROUTINE IRETCW( IZERO )
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      LOGICAL LZERO
      CHARACTER QANS*1,QBELL*1
      DIMENSION KKMAT(20),KKRND(5,20),CCSHFT(20)
C *
      QBELL = CHAR(7)
      LZERO = IZERO.NE.1
C *
C *  REPEAT FOR EACH ROUND
C *
1000  MAXVN = 0
      DO 1010 IRND=1,NRND
      MINVN = MAXVN + 1
      MAXVN = KAUTOV(IRND)
C *
C *  REPEAT FOR EACH PHASE
C *
2000  DO 2010 IPH = 1,NPHS
C *
C *  REPEAT FOR EACH ATOM
2100  DO 2110 IATM = 1,NATOM(IPH)
C *
C *  ATOM X,Y,Z COORDINATES
      DO 2112 J=1,3
      CALL CWDEKO( CAXYZ(J,IATM,IPH), 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
         KAXYZ(J,IATM,IPH) = 0
       ELSE IF( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
         CALL KWKODE( KAXYZ(J,IATM,IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
         KKRND(1,1) = IRND
         CALL CWCKDA( 'CAXYZ ', CAXYZ(J,IATM,IPH), KKRND )
         CALL KWKODE( KAXYZ(J,IATM,IPH), 1, KKRND, CCSHFT )
      ENDIF
2112  CONTINUE
C *
C *  ATOM ISOTROPIC THERMAL PARAMETERS
      CALL CWDEKO( CBISO(IATM,IPH), 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
         KBISO(IATM,IPH) = 0
       ELSE IF ( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
         CALL KWKODE( KBISO(IATM,IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
         KKRND(1,1) = IRND
         CALL CWCKDA( 'CBISO ', CBISO(IATM,IPH), KKRND )
         CALL KWKODE( KBISO(IATM,IPH), 1, KKRND, CCSHFT )
      ENDIF
C *
C *  ATOM OCCUPANCIES
      CALL CWDEKO( COCCU(IATM,IPH), 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
         KOCCU(IATM,IPH) = 0
       ELSE IF ( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
         CALL KWKODE( KOCCU(IATM,IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
         KKRND(1,1) = IRND
         CALL CWCKDA( 'COCCU ', COCCU(IATM,IPH), KKRND )
         CALL KWKODE( KOCCU(IATM,IPH), 1, KKRND, CCSHFT )
      ENDIF
C *
C *  ATOM ANISOTROPIC THERMAL PARAMETERS
      DO 2120 J=1,6
      CALL CWDEKO( CBAIS(J,IATM,IPH), 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
        KBAIS(J,IATM,IPH) = 0
       ELSE IF( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KBAIS(J,IATM,IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CBAIS ', CBAIS(J,IATM,IPH), KKRND )
        CALL KWKODE( KBAIS(J,IATM,IPH), 1, KKRND, CCSHFT )
      ENDIF
2120  CONTINUE
C *
C *  ATOM MAGNETIC VECTOR
      DO 2122 J=1,3
      CALL CWDEKO( CVMAG(J,IATM,IPH), 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
        KVMAG(J,IATM,IPH) = 0
       ELSE IF( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KVMAG(J,IATM,IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CVMAG ', CBAIS(J,IATM,IPH), KKRND )
        CALL KWKODE( KVMAG(J,IATM,IPH), 1, KKRND, CCSHFT )
      ENDIF
2122  CONTINUE
C *
C *  END OF ATOMS LOOP
2110  CONTINUE
C *
C *  SCALE FACTOR CODEWORDS
      CALL CWDEKO( CSCALE(IPH), 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
        KSCALE(IPH) = 0
       ELSE IF ( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KSCALE(IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CSCALE', CSCALE(IPH), KKRND )
        CALL KWKODE( KSCALE(IPH), 1, KKRND, CCSHFT )
      ENDIF
C *
C *  OVERALL ISOTROPIC TEMPERATURE
      CALL CWDEKO( COVISO(IPH), 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
        KOVISO(IPH) = 0
       ELSE IF ( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KOVISO(IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'COVISO', COVISO(IPH), KKRND )
        CALL KWKODE( KOVISO(IPH), 1, KKRND, CCSHFT )
      ENDIF
C *
C *  ABSORPTION CORRECTION FACTOR
      CALL CWDEKO( CABSCO(IPH), 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
        KABSCO(IPH) = 0
       ELSE IF ( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KABSCO(IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CABSCO', CABSCO(IPH), KKRND )
        CALL KWKODE( KABSCO(IPH), 1, KKRND, CCSHFT )
      ENDIF
C *
C *  PROFILE COEFFICIENT(S)
      DO 2130 J=1,3
      CALL CWDEKO( CPSFC(J,1,IPH), 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
        KPSFC(J,1,IPH) = 0
       ELSE IF( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KPSFC(J,1,IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CPSFC ', CPSFC(J,1,IPH), KKRND )
        CALL KWKODE( KPSFC(J,1,IPH), 1, KKRND, CCSHFT )
      ENDIF
      CALL CWDEKO( CPSFC(J,2,IPH), 1, KKMAT, KKRND, CCSHFT )
      IF( KPSF(2,IPH).NE.2 .AND. KPSF(2,IPH).NE.3 ) KKMAT(1) = 0
      IF( LZERO ) THEN
        KPSFC(J,2,IPH) = 0
       ELSE IF( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KPSFC(J,2,IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CPSFC ', CPSFC(J,2,IPH), KKRND )
        CALL KWKODE( KPSFC(J,2,IPH), 1, KKRND, CCSHFT )
      ENDIF
2130  CONTINUE
C *
C *  ASYMMETRY
      CALL CWDEKO( CASYP(IPH), 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
        KASYP(IPH) = 0
       ELSE IF ( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KASYP(IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CASYP ', CASYP(IPH), KKRND )
        CALL KWKODE( KASYP(IPH), 1, KKRND, CCSHFT )
      ENDIF
C *
C *  PROFILE BROADENING COEFFICIENTS
      DO 2140 J=1,3
      CALL CWDEKO( CUVW(J,1,IPH), 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
        KUVW(J,1,IPH) = 0
       ELSE IF ( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KUVW(J,1,IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CUVW  ', CUVW(J,1,IPH), KKRND )
        CALL KWKODE( KUVW(J,1,IPH), 1, KKRND, CCSHFT )
      ENDIF
      CALL CWDEKO( CUVW(J,2,IPH), 1, KKMAT, KKRND, CCSHFT )
      IF( KPSF(2,IPH).NE.1 .AND. KPSF(2,IPH).NE.3 ) KKMAT(1) = 0
      IF( LZERO ) THEN
        KUVW(J,2,IPH) = 0
       ELSE IF ( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KUVW(J,2,IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CUVW  ', CUVW(J,2,IPH), KKRND )
        CALL KWKODE( KUVW(J,2,IPH), 1, KKRND, CCSHFT )
      ENDIF
2140  CONTINUE
C *
C *  LATTICE PARAMETERS
      DO 2150 J=1,6
      CALL CWDEKO( CCELL(J,IPH), 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
        KCELL(J,IPH) = 0
       ELSE IF ( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KCELL(J,IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CCELL ', CCELL(J,IPH), KKRND )
        CALL KWKODE( KCELL(J,IPH), 1, KKRND, CCSHFT )
      ENDIF
2150  CONTINUE
C *
C *  PREFERRED ORIENTATION
      DO 2160 J=1,2
      CALL CWDEKO( CPREF(J,1,IPH), 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
        KPREF(J,1,IPH) = 0
       ELSE IF ( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KPREF(J,1,IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CPREF ', CPREF(J,1,IPH), KKRND )
        CALL KWKODE( KPREF(J,1,IPH), 1, KKRND, CCSHFT )
      ENDIF
      CALL CWDEKO( CPREF(J,2,IPH), 1, KKMAT, KKRND, CCSHFT )
      IF(KPOCT(2,IPH).LT.1) KKMAT(1) = 0
      IF( LZERO ) THEN
        KPREF(J,2,IPH) = 0
       ELSE IF ( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KPREF(J,2,IPH), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CPREF ', CPREF(J,2,IPH), KKRND )
        CALL KWKODE( KPREF(J,2,IPH), 1, KKRND, CCSHFT )
      ENDIF
2160  CONTINUE
C *
C *  NEXT PHASE
2010  CONTINUE
C *
C *  SPECIMEN DISPLACEMENT CODEWORD
      CALL CWDEKO( CDISP, 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
        KDISP = 0
       ELSE IF( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KDISP, 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CDISP ', CDISP, KKRND )
        CALL KWKODE( KDISP, 1, KKRND, CCSHFT )
      ENDIF
C *
C *  ZERO PT DISPLACEMENT CODEWORD
      CALL CWDEKO( CZERPT, 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
        KZERPT = 0
       ELSE IF ( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KZERPT, 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CZERPT', CZERPT, KKRND )
        CALL KWKODE( KZERPT, 1, KKRND, CCSHFT )
      ENDIF
C *
C *  AMORPHOUS PROFILE CODEWORDS
      DO 3020 J=1,3
      CALL CWDEKO( CAMORP(J), 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
        KAMORP(J) = 0
       ELSE IF ( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KAMORP(J), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CAMORP', CAMORP(J), KKRND )
        CALL KWKODE( KAMORP(J), 1, KKRND, CCSHFT )
      ENDIF
3020  CONTINUE
C *
C *  CODEWORDS FOR BACKGROUND
      DO 3030 J=1,6
      CALL CWDEKO( CBKG(J), 1, KKMAT, KKRND, CCSHFT )
      IF( LZERO ) THEN
        KBKG(J) = 0
       ELSE IF ( KKMAT(1).EQ.0 .OR. KKMAT(1).GT.MAXVN ) THEN
        CALL KWKODE( KBKG(J), 1, KKRND, CCSHFT )
       ELSE IF ( KKMAT(1).GE.MINVN .AND. KKMAT(1).LE.MAXVN ) THEN
        KKRND(1,1) = IRND
        CALL CWCKDA( 'CBKG  ', CBKG(J), KKRND )
        CALL KWKODE( KBKG(J), 1, KKRND, CCSHFT )
      ENDIF
3030  CONTINUE
C *
C *  NEXT ROUND
C *
1010  CONTINUE
C *
C **  ASSIGNMENT COMPLETE
C *
9000  RETURN
      END
C **  ARETCW - ASSIGN CODEWORDS FOR RIETVELD CONTROL FILE
C *
      SUBROUTINE ARETCW( IFLAG )
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QANS*1,QBELL*1
      DIMENSION KKMAT(20),KKRND(5,20),CCSHFT(20)
C *
      IFLAG = 0
      QBELL = CHAR(7)
C *
C *  INITIALIZE CODEWORD VALUE (Y) AND ROUND POINTERS
1000  KMAT   = 0
      KMLAST = KMAT
      NRND   = 1
C *
C **  ASSIGNMENTS OF PARAMETERS OTHER THAN THOSE FOR ATOMS
C *
C *  REPEAT FOR TOTAL NUMBER OF POSSIBLE ROUND ASSIGNMENTS (20)
      DO 1010 IMAX20=1,20
C *
C *  ASSIGNMENT OF PHASE RELATED CODEWORDS
C *
C *  REPEAT FOR EACH PHASE
1100  DO 1110 IPH = 1,NPHS
C *
C *  SCALE FACTOR CODEWORDS
      CALL KWDEKO( KSCALE(IPH), 1, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.IMAX20) THEN
        KKRND(1,1) = NRND
        CALL KWKODE( KSCALE(IPH), 1, KKRND, CCSHFT )
        CSCALE(IPH) = 0.0
        CALL KWCKDA( 'KSCALE', KKRND, KMAT, KKMAT )
        CALL CWKODE( CSCALE(IPH), 1, KKMAT, KKRND, CCSHFT )
       ELSE IF(KKRND(1,1).EQ.0) THEN
        CSCALE(IPH) = 0.0
      ENDIF
C *
C *  OVERALL ISOTROPIC TEMPERATURE
      CALL KWDEKO( KOVISO(IPH), 1, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.IMAX20) THEN
        KKRND(1,1) = NRND
        CALL KWKODE( KOVISO(IPH), 1, KKRND, CCSHFT )
        COVISO(IPH) = 0.0
        CALL KWCKDA( 'KOVISO', KKRND, KMAT, KKMAT )
        CALL CWKODE( COVISO(IPH), 1, KKMAT, KKRND, CCSHFT )
       ELSE IF(KKRND(1,1).EQ.0) THEN
        COVISO(IPH) = 0.0
      ENDIF
C *
C *  ABSORPTION CORRECTION FACTOR
      CALL KWDEKO( KABSCO(IPH), 1, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.IMAX20) THEN
        KKRND(1,1) = NRND
        CALL KWKODE( KABSCO(IPH), 1, KKRND, CCSHFT )
        CABSCO(IPH) = 0.0
        CALL KWCKDA( 'KABSCO', KKRND, KMAT, KKMAT )
        CALL CWKODE( CABSCO(IPH), 1, KKMAT, KKRND, CCSHFT )
       ELSE IF(KKRND(1,1).EQ.0) THEN
        CABSCO(IPH) = 0.0
      ENDIF
C *
C *  LATTICE PARAMETERS
      CALL KWDEKO( KCELL(1,IPH), 6, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.0) THEN
        CCELL(1,IPH) = 0.0
        CCELL(2,IPH) = 0.0
        CCELL(3,IPH) = 0.0
        CCELL(4,IPH) = 0.0
        CCELL(5,IPH) = 0.0
        CCELL(6,IPH) = 0.0
        GO TO 230
       ELSE IF (KKRND(1,1).NE.IMAX20) THEN
        GO TO 230
       ELSE
        KKRND(1,1) = NRND
        CALL KWKODE( KCELL(1,IPH), 1, KKRND, CCSHFT )
      ENDIF
C *
      IF (QXTALS(IPH).EQ.'Cubic') THEN
        KKMAT(1) = KMAT + 1
        KKMAT(2) = KMAT + 1
        KKMAT(3) = KMAT + 1
        KKMAT(4) = 0
        KKMAT(5) = 0
        KKMAT(6) = 0
        CALL KWCKDA( 'KCELL ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CCELL(1,IPH), 6, KKMAT, KKRND, CCSHFT )
        KMAT = KMAT + 1
        GO TO 230
      ENDIF
C *
      IF (QXTALS(IPH).EQ.'Tetragonal') THEN
        KKMAT(1) = KMAT + 1
        KKMAT(2) = KMAT + 1
        KKMAT(3) = KMAT + 2
        KKMAT(4) = 0
        KKMAT(5) = 0
        KKMAT(6) = 0
        CALL KWCKDA( 'KCELL ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CCELL(1,IPH), 6, KKMAT, KKRND, CCSHFT )
        KMAT = KMAT + 2
        GO TO 230
      ENDIF
C *
      IF ( QXTALS(IPH).EQ.'Hexagonal' .OR.
     1     QXTALS(IPH).EQ.'Trigonal on Hexag.' ) THEN
        KKMAT(1) = KMAT + 1
        KKMAT(2) = KMAT + 1
        KKMAT(3) = KMAT + 2
        KKMAT(4) = 0
        KKMAT(5) = 0
        KKMAT(6) = KMAT + 1
        CALL KWCKDA( 'KCELL ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CCELL(1,IPH), 6, KKMAT, KKRND, CCSHFT )
        KMAT = KMAT + 2
        GO TO 230
      ENDIF
C *
      IF (QXTALS(IPH).EQ.'Orthorhombic') THEN
        KKMAT(1) = KMAT + 1
        KKMAT(2) = KMAT + 2
        KKMAT(3) = KMAT + 3
        KKMAT(4) = 0
        KKMAT(5) = 0
        KKMAT(6) = 0
        CALL KWCKDA( 'KCELL ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CCELL(1,IPH), 6, KKMAT, KKRND, CCSHFT )
        KMAT = KMAT + 3
        GO TO 230
      ENDIF
C *
      IF (QXTALS(IPH).EQ.'Trigonal on Rhomb.') THEN
        KKMAT(1) = KMAT + 1
        KKMAT(2) = KMAT + 1
        KKMAT(3) = KMAT + 1
        KKMAT(4) = KMAT + 2
        KKMAT(5) = KMAT + 2
        KKMAT(6) = KMAT + 2
        CALL KWCKDA( 'KCELL ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CCELL(1,IPH), 6, KKMAT, KKRND, CCSHFT )
        KMAT = KMAT + 2
        GO TO 230
      ENDIF
C *
      IF (QXTALS(IPH).EQ.'Monoclinic b unique') THEN
        KKMAT(1) = KMAT + 1
        KKMAT(2) = KMAT + 2
        KKMAT(3) = KMAT + 3
        KKMAT(4) = 0
        KKMAT(5) = KMAT + 4
        KKMAT(6) = 0
        CALL KWCKDA( 'KCELL ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CCELL(1,IPH), 6, KKMAT, KKRND, CCSHFT )
        KMAT = KMAT + 4
        GO TO 230
      ENDIF
C *
      IF (QXTALS(IPH).EQ.'Triclinic') THEN
        KKMAT(1) = KMAT + 1
        KKMAT(2) = KMAT + 2
        KKMAT(3) = KMAT + 3
        KKMAT(4) = KMAT + 4
        KKMAT(5) = KMAT + 5
        KKMAT(6) = KMAT + 6
        CALL KWCKDA( 'KCELL ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CCELL(1,IPH), 6, KKMAT, KKRND, CCSHFT )
        KMAT = KMAT + 6
        GO TO 230
      ENDIF
C *
      WRITE(ITTO,232) QBELL,QPHSNM(IPH),QXTALS(IPH)
232   FORMAT(//,1X,A1,
     1 '-The crystal system for phase: ',A32,/,
     1 '    is given as: ',A20,//,
     1'  Please edit the entry for this phase and supply the correct',
     1' crystal system.',/,
     1'  The setup for this refinement is halted.  Sorry.')
      WRITE(ITTO,234)
234   FORMAT(/,' ...Press <ENTER> to continue ')
      READ(ITTI,236) QANS
236   FORMAT(A1)
      IFLAG = 1
      GO TO 9000
C *
C *  PROFILE BROADENING COEFFICIENTS
230   DO 240 J=3,1,-1
      CALL KWDEKO( KUVW(J,1,IPH), 1, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.IMAX20) THEN
        KKRND(1,1) = NRND
        CALL KWKODE( KUVW(J,1,IPH), 1, KKRND, CCSHFT )
        CUVW(J,1,IPH) = 0.0
        CALL KWCKDA( 'KUVW  ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CUVW(J,1,IPH), 1, KKMAT, KKRND, CCSHFT )
       ELSE IF (KKRND(1,1).EQ.0) THEN
        CUVW(J,1,IPH) = 0.0
      ENDIF
      IF( KPSF(2,IPH).EQ.1 .OR. KPSF(2,IPH).EQ.3 ) THEN
        CALL KWDEKO( KUVW(J,2,IPH), 1, KKRND, CCSHFT )
        IF (KKRND(1,1).EQ.IMAX20) THEN
          KKRND(1,1) = NRND
          CALL KWKODE( KUVW(J,2,IPH), 1, KKRND, CCSHFT )
          CUVW(J,2,IPH) = 0.0
          CALL KWCKDA( 'KUVW  ', KKRND, KMAT, KKMAT )
          CALL CWKODE( CUVW(J,2,IPH), 1, KKMAT, KKRND, CCSHFT )
        ELSE IF (KKRND(1,1).EQ.0) THEN
          CUVW(J,2,IPH) = 0.0
        ENDIF
      ENDIF
240   CONTINUE
C *
C *  PROFILE SHAPE COEFFICIENTS
      DO 250 J=1,3
      CALL KWDEKO( KPSFC(J,1,IPH), 1, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.IMAX20) THEN
        KKRND(1,1) = NRND
        CALL KWKODE( KPSFC(J,1,IPH), 1, KKRND, CCSHFT )
        CPSFC(J,1,IPH) = 0.0
        CALL KWCKDA( 'KPSFC ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CPSFC(J,1,IPH), 1, KKMAT, KKRND, CCSHFT )
       ELSE IF (KKRND(1,1).EQ.0) THEN
        CPSFC(J,1,IPH) = 0.0
      ENDIF
      IF( KPSF(2,IPH).EQ.2 .OR. KPSF(2,IPH).EQ.3 ) THEN
        CALL KWDEKO( KPSFC(J,2,IPH), 1, KKRND, CCSHFT )
        IF (KKRND(1,1).EQ.IMAX20) THEN
          KKRND(1,1) = NRND
          CALL KWKODE( KPSFC(J,2,IPH), 1, KKRND, CCSHFT )
          CPSFC(J,2,IPH) = 0.0
          CALL KWCKDA( 'KPSFC ', KKRND, KMAT, KKMAT )
          CALL CWKODE( CPSFC(J,2,IPH), 1, KKMAT, KKRND, CCSHFT )
         ELSE IF (KKRND(1,1).EQ.0) THEN
           CPSFC(J,2,IPH) = 0.0
        ENDIF
      ENDIF
250   CONTINUE
C *
C *  ASYMMETRY
      CALL KWDEKO( KASYP(IPH), 1, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.IMAX20) THEN
        KKRND(1,1) = NRND
        CALL KWKODE( KASYP(IPH), 1, KKRND, CCSHFT )
        CASYP(IPH) = 0.0
        CALL KWCKDA( 'KASYP ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CASYP(IPH), 1, KKMAT, KKRND, CCSHFT )
       ELSE IF (KKRND(1,1).EQ.0) THEN
        CASYP(IPH) = 0.0
      ENDIF
C *
C *  PREFERRED ORIENTATION
      DO 260 J=1,2
      CALL KWDEKO( KPREF(J,1,IPH), 1, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.IMAX20) THEN
        KKRND(1,1) = NRND
        CALL KWKODE( KPREF(J,1,IPH), 1, KKRND, CCSHFT )
        CPREF(J,1,IPH) = 0.0
        CALL KWCKDA( 'KPREF ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CPREF(J,1,IPH), 1, KKMAT, KKRND, CCSHFT )
       ELSE IF (KKRND(1,1).EQ.0) THEN
        CPREF(J,1,IPH) = 0.0
      ENDIF
      CALL KWDEKO( KPREF(J,2,IPH), 1, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.IMAX20) THEN
        KKRND(1,1) = NRND
        CALL KWKODE( KPREF(J,2,IPH), 1, KKRND, CCSHFT )
        CPREF(J,2,IPH) = 0.0
        CALL KWCKDA( 'KPREF ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CPREF(J,2,IPH), 1, KKMAT, KKRND, CCSHFT )
       ELSE IF (KKRND(1,1).EQ.0) THEN
        CPREF(J,2,IPH) = 0.0
      ENDIF
260   CONTINUE
C *
C *  NEXT PHASE
1110  CONTINUE
C *
C *  ASSIGNMENT OF GLOBAL PARAMETER CODEWORDS
C *
C *  SPECIMEN DISPLACEMENT CODEWORD
      CALL KWDEKO( KDISP, 1, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.IMAX20) THEN
        KKRND(1,1) = NRND
        CALL KWKODE( KDISP, 1, KKRND, CCSHFT )
        CDISP = 0.0
        CALL KWCKDA( 'KDISP ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CDISP, 1, KKMAT, KKRND, CCSHFT )
       ELSE IF (KKRND(1,1).EQ.0) THEN
        CDISP = 0.0
      ENDIF
C *
C *  ZERO PT DISPLACEMENT CODEWORD
      CALL KWDEKO( KZERPT, 1, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.IMAX20) THEN
        KKRND(1,1) = NRND
        CALL KWKODE( KZERPT, 1, KKRND, CCSHFT )
        CZERPT = 0.0
        CALL KWCKDA( 'KZERPT', KKRND, KMAT, KKMAT )
        CALL CWKODE( CZERPT, 1, KKMAT, KKRND, CCSHFT )
       ELSE IF (KKRND(1,1).EQ.0) THEN
        CZERPT = 0.0
      ENDIF
C *
C *  AMORPHOUS PROFILE CODEWORDS
      IF(KAMOR.EQ.1) THEN
        DO 112 J=1,3
        CALL KWDEKO( KAMORP(J), 1, KKRND, CCSHFT )
        IF (KKRND(1,1).EQ.IMAX20) THEN
          KKRND(1,1) = NRND
          CALL KWKODE( KAMORP(J), 1, KKRND, CCSHFT )
          CAMORP(J) = 0.0
          CALL KWCKDA( 'KAMORP', KKRND, KMAT, KKMAT )
          CALL CWKODE( CAMORP(J), 1, KKMAT, KKRND, CCSHFT )
         ELSE IF (KKRND(1,1).EQ.0) THEN
          CAMORP(J) = 0.0
        ENDIF
112     CONTINUE
      ENDIF
C *
C *  CODEWORDS FOR BACKGROUND
      IF(NBCKGD.EQ.0) THEN
        DO 114 J=1,6
        CALL KWDEKO( KBKG(J), 1, KKRND, CCSHFT )
        IF (KKRND(1,1).EQ.IMAX20) THEN
          KKRND(1,1) = NRND
          CALL KWKODE( KBKG(J), 1, KKRND, CCSHFT )
          CBKG(J) = 0.0
          CALL KWCKDA( 'KBKG  ', KKRND, KMAT, KKMAT )
          CALL CWKODE( CBKG(J), 1, KKMAT, KKRND, CCSHFT )
         ELSE IF (KKRND(1,1).EQ.0) THEN
          CBKG(J) = 0.0
        ENDIF
114     CONTINUE
      ENDIF
C *
C **  ASSIGNMENT OF ATOM PARAMETERS
C *
C *  REPEAT FOR EACH PHASE
4000  DO 4020 IPH=1,NPHS
C *
C *  REPEAT FOR EACH ATOM
      DO 4030 IATM=1,NATOM(IPH)
C *
C *  ATOM X,Y,Z COORDINATES
4100  DO 4110 J=1,3
      CALL KWDEKO( KAXYZ(J,IATM,IPH), 1, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.IMAX20) THEN
        KKRND(1,1) = NRND
        CALL KWKODE( KAXYZ(J,IATM,IPH), 1, KKRND, CCSHFT )
        CAXYZ(J,IATM,IPH) = 0.0
        CALL KWCKDA( 'KAXYZ ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CAXYZ(J,IATM,IPH), 1, KKMAT, KKRND, CCSHFT )
       ELSE IF(KKRND(1,1).EQ.0) THEN
        CAXYZ(J,IATM,IPH) = 0.0
      ENDIF
4110  CONTINUE
C *
C *  ATOM OCCUPANCY
      CALL KWDEKO( KOCCU(IATM,IPH), 1, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.IMAX20) THEN
        KKRND(1,1) = NRND
        CALL KWKODE( KOCCU(IATM,IPH), 1, KKRND, CCSHFT )
        COCCU(IATM,IPH) = 0.0
        CALL KWCKDA( 'KOCCU ', KKRND, KMAT, KKMAT )
        CALL CWKODE( COCCU(IATM,IPH), 1, KKMAT, KKRND, CCSHFT )
       ELSE IF(KKRND(1,1).EQ.0) THEN
        COCCU(IATM,IPH) = 0.0
      ENDIF
C *
C *  ATOM ISOTROPIC THERMAL PARAMETER
      CALL KWDEKO( KBISO(IATM,IPH), 1, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.IMAX20) THEN
        KKRND(1,1) = NRND
        CALL KWKODE( KBISO(IATM,IPH), 1, KKRND, CCSHFT )
        CBISO(IATM,IPH) = 0.0
        CALL KWCKDA( 'KBISO ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CBISO(IATM,IPH), 1, KKMAT, KKRND, CCSHFT )
       ELSE IF(KKRND(1,1).EQ.0) THEN
        CBISO(IATM,IPH) = 0.0
      ENDIF
C *
C *  ATOM ANISOTROPIC THERMAL PARAMETERS
      DO 4120 J=1,6
      CALL KWDEKO( KBAIS(J,IATM,IPH), 1, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.IMAX20) THEN
        KKRND(1,1) = NRND
        CALL KWKODE( KBAIS(J,IATM,IPH), 1, KKRND, CCSHFT )
        CBAIS(J,IATM,IPH) = 0.0
        CALL KWCKDA( 'KBAIS ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CBAIS(J,IATM,IPH), 1, KKMAT, KKRND, CCSHFT )
       ELSE IF(KKRND(1,1).EQ.0) THEN
        CBAIS(J,IATM,IPH) = 0.0
      ENDIF
4120  CONTINUE
C *
C *  ATOM MAGNETIC VECTOR
      DO 4122 J=1,3
      CALL KWDEKO( KVMAG(J,IATM,IPH), 1, KKRND, CCSHFT )
      IF (KKRND(1,1).EQ.IMAX20) THEN
        KKRND(1,1) = NRND
        CALL KWKODE( KVMAG(J,IATM,IPH), 1, KKRND, CCSHFT )
        CVMAG(J,IATM,IPH) = 0.0
        CALL KWCKDA( 'KVMAG ', KKRND, KMAT, KKMAT )
        CALL CWKODE( CVMAG(J,IATM,IPH), 1, KKMAT, KKRND, CCSHFT )
       ELSE IF(KKRND(1,1).EQ.0) THEN
        CVMAG(J,IATM,IPH) = 0.0
      ENDIF
4122  CONTINUE
C *
C *  NEXT ATOM
4030  CONTINUE
C *
C *  NEXT PHASE
4020  CONTINUE
C *
C *  TEST FOR NEW VARIABLES ON THIS CYCLE...
C *
      IF(KMAT.GT.KMLAST) THEN
        KMLAST = KMAT
        KAUTOV(NRND) = KMAT
        IF(KAUTOR(NRND).EQ.0) KAUTOR(NRND) = 1
        NRND = NRND + 1
      ENDIF
C *
C *  END OF CYCLES FOR TESTING ROUNDS
1010  CONTINUE
C *
C *  SET NRND TO INDICATE ACTUAL NUMBER OF ROUNDS
C *
7000  NRND = NRND - 1
C *
C *  INDICATE CYCLE CONTROL VALUES
C *
8000  IF( JOBXN.EQ.1 .OR. JOBXN.EQ.2 ) THEN
        WRITE(ITTO,8010)
8010    FORMAT(//,
     1  ' Refinement algorithm for current problem:',//,
     1  ' Round:        1   2   3   4   5   6   7   8   9  10  11  12',
     1  '  13  14  15',/,
     1  '             --- --- --- --- --- --- --- --- --- --- --- ---',
     1  ' --- --- ---')
        WRITE(ITTO,8020) (KAUTOV(I),I=1,NRND)
8020    FORMAT(' Variables: ',20I4)
        WRITE(ITTO,8030) (KAUTOR(I),I=1,NRND)
8030    FORMAT(' Cycles:    ',20I4)
      ENDIF
C *
C **  ASSIGNMENT COMPLETE
C *
9000  RETURN
      END
C ***  CWCKDA - CHECK RIETVELD CODEWORDS FOR DUPLICATE ASSIGNMENT
C *
C *    ATOM POSITIONS
C *
      SUBROUTINE CWCKDA( QPARM, CWTMP, KKRND )
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QPARM*6
      DIMENSION KKRND(5,20)
C *
      IF( QPARM.EQ.'CAXYZ ' ) GO TO 10000
      IF( QPARM.EQ.'CBISO ' ) GO TO 11000
      IF( QPARM.EQ.'COCCU ' ) GO TO 12000
      IF( QPARM.EQ.'CBAIS ' ) GO TO 13000
      IF( QPARM.EQ.'CVMAG ' ) GO TO 14000
      IF( QPARM.EQ.'CSCALE' ) GO TO 15000
      IF( QPARM.EQ.'COVISO' ) GO TO 16000
      IF( QPARM.EQ.'CABSCO' ) GO TO 17000
      IF( QPARM.EQ.'CPSFC ' ) GO TO 18000
      IF( QPARM.EQ.'CASYP ' ) GO TO 19000
      IF( QPARM.EQ.'CUVW  ' ) GO TO 20000
      IF( QPARM.EQ.'CCELL ' ) GO TO 21000
      IF( QPARM.EQ.'CPREF ' ) GO TO 22000
      IF( QPARM.EQ.'CDISP ' ) GO TO 23000
      IF( QPARM.EQ.'CZERPT' ) GO TO 24000
      IF( QPARM.EQ.'CAMORP' ) GO TO 25000
      IF( QPARM.EQ.'CBKG  ' ) GO TO 26000
      STOP '--CWCKDA: Unknown pointer passed'
C *
C **  ATOM COORDINATES
C *
10000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      IMAT = NINT( ABS(CWTMP/10.0) )
      DO 10010 ITATM=1,NATOM(IPH)
      DO 10010 J=1,3
      IMAT2 = NINT( ABS( CAXYZ(J,ITATM,IPH)/10.0 ) )
      IF(IMAT2.NE.IMAT) GO TO 10020
      KKRND(2,1) = ITATM
      KKRND(3,1) = J
      GO TO 9000
10020 CONTINUE
10010 CONTINUE
      GO TO 9000
C *
C **  ATOM ISOTROPIC TEMPERATURE PARAMETERS
C *
11000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      IMAT = NINT( ABS(CWTMP/10.0) )
      DO 11010 ITATM=1,NATOM(IPH)
      IMAT2 = NINT( ABS( CBISO(ITATM,IPH)/10.0 ) )
      IF(IMAT2.NE.IMAT) GO TO 11010
      KKRND(2,1) = ITATM
      KKRND(3,1) = 1
      GO TO 9000
11010 CONTINUE
      GO TO 9000
C *
C **  ATOM OCCUPANCIES
C *
12000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      IMAT = NINT( ABS(CWTMP/10.0) )
      DO 12010 ITATM=1,NATOM(IPH)
      IMAT2 = NINT( ABS( COCCU(ITATM,IPH)/10.0 ) )
      IF(IMAT2.NE.IMAT) GO TO 12010
      KKRND(2,1) = ITATM
      KKRND(3,1) = 1
      GO TO 9000
12010 CONTINUE
      GO TO 9000
C *
C **  ATOM ANISOTROPIC THERMAL PARAMETERS
C *
13000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      IMAT = NINT( ABS(CWTMP/10.0) )
      DO 13010 ITATM=1,NATOM(IPH)
      DO 13020 J=1,6
      IMAT2 = NINT( ABS( CBAIS(J,ITATM,IPH)/10.0 ) )
      IF(IMAT2.NE.IMAT) GO TO 13020
      KKRND(2,1) = ITATM
      KKRND(3,1) = J
      GO TO 9000
13020 CONTINUE
13010 CONTINUE
      GO TO 9000
C *
C **  MAGNETIC VECTOR
C *
14000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      IMAT = NINT( ABS(CWTMP/10.0) )
      DO 14010 ITATM=1,NATOM(IPH)
      DO 14020 J=1,3
      IMAT2 = NINT( ABS( CVMAG(J,ITATM,IPH)/10.0 ) )
      IF(IMAT2.NE.IMAT) GO TO 14020
      KKRND(2,1) = ITATM
      KKRND(3,1) = J
      GO TO 9000
14020 CONTINUE
14010 CONTINUE
      GO TO 9000
C *
C **  SCALE FACTORS
C *
15000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      IMAT = NINT( ABS(CWTMP/10.0) )
      DO 15010 ITPH=1,IPH
      IMAT2 = NINT( ABS( CSCALE(ITPH)/10.0 ) )
      IF(IMAT2.NE.IMAT) GO TO 15010
      KKRND(2,1) = ITPH
      KKRND(3,1) = 1
      GO TO 9000
15010 CONTINUE
      GO TO 9000
C *
C **  OVERALL TEMPERATURE FACTORS
C *
16000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      IMAT = NINT( ABS(CWTMP/10.0) )
      DO 16010 ITPH=1,IPH
      IMAT2 = NINT( ABS( COVISO(ITPH)/10.0 ) )
      IF(IMAT2.NE.IMAT) GO TO 16010
      KKRND(2,1) = ITPH
      KKRND(3,1) = 1
      GO TO 9000
16010 CONTINUE
      GO TO 9000
C *
C **  ABSORPTION FACTORS
C *
17000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      IMAT = NINT( ABS(CWTMP/10.0) )
      DO 17010 ITPH=1,IPH
      IMAT2 = NINT( ABS( CABSCO(ITPH)/10.0 ) )
      IF(IMAT2.NE.IMAT) GO TO 17010
      KKRND(2,1) = ITPH
      KKRND(3,1) = 1
      GO TO 9000
17010 CONTINUE
      GO TO 9000
C *
C **  PROFILE-SHAPE-COEFFICIENTS
C *
18000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      IMAT = NINT( ABS(CWTMP/10.0) )
      DO 18010 ITPH=1,IPH
      DO 18020 ISIDE=1,2
      DO 18030 IPRM=1,3
      IMAT2 = NINT( ABS( CPSFC(IPRM,ISIDE,ITPH)/10.0 ) )
      IF(IMAT2.NE.IMAT) GO TO 18030
      KKRND(2,1) = ITPH
      KKRND(3,1) = IPRM*2 + (ISIDE-1)
      GO TO 9000
18030 CONTINUE
18020 CONTINUE
18010 CONTINUE
      GO TO 9000
C *
C **  ASYMMETRY COEFFICIENTS
C *
19000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      IMAT = NINT( ABS(CWTMP/10.0) )
      DO 19010 ITPH=1,IPH
      IMAT2 = NINT( ABS( CASYP(ITPH)/10.0 ) )
      IF(IMAT2.NE.IMAT) GO TO 19010
      KKRND(2,1) = ITPH
      KKRND(3,1) = 1
      GO TO 9000
19010 CONTINUE
      GO TO 9000
C *
C **  PROFILE BROADENING COEFFICIENTS
C *
20000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      IMAT = NINT( ABS(CWTMP/10.0) )
      DO 20010 ITPH=1,IPH
      DO 20020 ISIDE=1,2
      DO 20030 IPRM=1,3
      IMAT2 = NINT( ABS( CUVW(IPRM,ISIDE,ITPH)/10.0 ) )
      IF(IMAT2.NE.IMAT) GO TO 20030
      KKRND(2,1) = ITPH
      KKRND(3,1) = IPRM*2 + (ISIDE-1)
      GO TO 9000
20030 CONTINUE
20020 CONTINUE
20010 CONTINUE
      GO TO 9000
C *
C **  LATTICE PARAMETERS
C *
21000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      IMAT = NINT( ABS(CWTMP/10.0) )
      DO 21010 ITPH=1,IPH
      DO 21020 IPRM=1,6
      IMAT2 = NINT( ABS( CCELL(IPRM,ITPH)/10.0 ) )
      IF(IMAT2.NE.IMAT) GO TO 21020
      KKRND(2,1) = ITPH
      KKRND(3,1) = IPRM
      GO TO 9000
21020 CONTINUE
21010 CONTINUE
      GO TO 9000
C *
C **  PREFERRED ORIENTATION COEFFICIENTS
C *
22000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      IMAT = NINT( ABS(CWTMP/10.0) )
      DO 22010 ITPH=1,IPH
      DO 22020 IVEC=1,2
      DO 22030 IPRM=1,3
      IMAT2 = NINT( ABS( CPREF(IPRM,IVEC,ITPH)/10.0 ) )
      IF(IMAT2.NE.IMAT) GO TO 22030
      KKRND(2,1) = ITPH
      KKRND(3,1) = IPRM*2 + (IVEC-1)
      GO TO 9000
22030 CONTINUE
22020 CONTINUE
22010 CONTINUE
      GO TO 9000
C *
C **  DISPLACEMENT - NO CONSTRAINTS
C *
23000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      GO TO 9000
C *
C **  ZERO POINT - NO CONSTRAINTS
C *
24000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      GO TO 9000
C *
C **  AMORPHOUS PROFILE PARAMETERS - NO CONSTRAINTS
C *
25000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      GO TO 9000
C *
C **  BACKGROUND - NO CONSTRAINTS
C *
26000 KKRND(2,1) = 0
      KKRND(3,1) = 0
      GO TO 9000
C *
C *  FINISHED
9000  RETURN
      END
C ***  KWCKDA - CHECK RIQAS KODEWORDS FOR DUPLICATE ASSIGNMENT
C *
C *    ATOM POSITIONS
C *
      SUBROUTINE KWCKDA( QPARM, KKRND, KMAT, KMASS )
C *
C *  REFERENCE COMMON BLOCK
      INCLUDE 'QRCOM.FOR'
C *
      CHARACTER QPARM*6
      DIMENSION KKRND(5,20),KMASS(20)
C *
      IF( QPARM.EQ.'KAXYZ ' ) GO TO 10000
      IF( QPARM.EQ.'KBISO ' ) GO TO 11000
      IF( QPARM.EQ.'KOCCU ' ) GO TO 12000
      IF( QPARM.EQ.'KBAIS ' ) GO TO 13000
      IF( QPARM.EQ.'KVMAG ' ) GO TO 14000
      IF( QPARM.EQ.'KSCALE' ) GO TO 15000
      IF( QPARM.EQ.'KOVISO' ) GO TO 16000
      IF( QPARM.EQ.'KABSCO' ) GO TO 17000
      IF( QPARM.EQ.'KPSFC ' ) GO TO 18000
      IF( QPARM.EQ.'KASYP ' ) GO TO 19000
      IF( QPARM.EQ.'KUVW  ' ) GO TO 20000
      IF( QPARM.EQ.'KCELL ' ) GO TO 21000
      IF( QPARM.EQ.'KPREF ' ) GO TO 22000
      IF( QPARM.EQ.'KDISP ' ) GO TO 23000
      IF( QPARM.EQ.'KZERPT' ) GO TO 24000
      IF( QPARM.EQ.'KAMORP' ) GO TO 25000
      IF( QPARM.EQ.'KBKG  ' ) GO TO 26000
      STOP '--KWCKDA: Unknown pointer passed'
C *
C **  ATOM COORDINATES
C *
10000 ITATM = KKRND(2,1)
      IPRM  = KKRND(3,1)
      IF( ITATM.EQ.0 .OR. IPRM.EQ.0 ) THEN
        KMAT = KMAT + 1
        KMASS(1) = KMAT
        GO TO 9000
      ENDIF
      K = NINT( ABS(CAXYZ(IPRM,ITATM,IPH))/10.0 )
      IF(K.GT.0) THEN
        KMASS(1) = K
       ELSE
        KMAT = KMAT + 1
        KMASS(1) = KMAT
      ENDIF
      GO TO 9000
C *
C **  ATOM ISOTROPIC TEMPERATURE PARAMETERS
C *
11000 ITATM = KKRND(2,1)
      IF( ITATM.EQ.0 ) THEN
        KMAT = KMAT + 1
        KMASS(1) = KMAT
        GO TO 9000
      ENDIF
      K = NINT( ABS(CBISO(ITATM,IPH))/10.0 )
      IF(K.GT.0) THEN
        KMASS(1) = K
       ELSE
        KMAT = KMAT + 1
        KMASS(1) = KMAT
      ENDIF
      GO TO 9000
C *
C **  ATOM OCCUPANCIES
C *
12000 ITATM = KKRND(2,1)
      IF( ITATM.EQ.0 ) THEN
        KMAT = KMAT + 1
        KMASS(1) = KMAT
        GO TO 9000
      ENDIF
      K = NINT( ABS(COCCU(ITATM,IPH))/10.0 )
      IF(K.GT.0) THEN
        KMASS(1) = K
       ELSE
        KMAT = KMAT + 1
        KMASS(1) = KMAT
      ENDIF
      GO TO 9000
C *
C **  ATOM ANISOTROPIC THERMAL PARAMETERS
C *
13000 ITATM = KKRND(2,1)
      IPRM  = KKRND(3,1)
      IF( ITATM.EQ.0 .OR. IPRM.EQ.0 ) THEN
        KMAT = KMAT + 1
        KMASS(1) = KMAT
        GO TO 9000
      ENDIF
      K = NINT( ABS(CBAIS(IPRM,ITATM,IPH))/10.0 )
      IF(K.GT.0) THEN
        KMASS(1) = K
       ELSE
        KMAT = KMAT + 1
        KMASS(1) = KMAT
      ENDIF
      GO TO 9000
C *
C **  MAGNETIC VECTOR
C *
14000 ITATM = KKRND(2,1)
      IPRM  = KKRND(3,1)
      IF( ITATM.EQ.0 .OR. IPRM.EQ.0 ) THEN
        KMAT = KMAT + 1
        KMASS(1) = KMAT
        GO TO 9000
      ENDIF
      K = NINT( ABS(CVMAG(IPRM,ITATM,IPH))/10.0 )
      IF(K.GT.0) THEN
        KMASS(1) = K
       ELSE
        KMAT = KMAT + 1
        KMASS(1) = KMAT
      ENDIF
      GO TO 9000
C *
C **  SCALE FACTORS
C *
15000 ITPH = KKRND(2,1)
      IF( ITPH.EQ.0 ) THEN
        KMAT = KMAT + 1
        KMASS(1) = KMAT
        GO TO 9000
      ENDIF
      K = NINT( ABS(CSCALE(ITPH))/10.0 )
      IF(K.GT.0) THEN
        KMASS(1) = K
       ELSE
        KMAT = KMAT + 1
        KMASS(1) = KMAT
      ENDIF
      GO TO 9000
C *
C **  OVERALL TEMPERATURE FACTORS
C *
16000 ITPH = KKRND(2,1)
      IF( ITPH.EQ.0 ) THEN
        KMAT = KMAT + 1
        KMASS(1) = KMAT
        GO TO 9000
      ENDIF
      K = NINT( ABS(COVISO(ITPH))/10.0 )
      IF(K.GT.0) THEN
        KMASS(1) = K
       ELSE
        KMAT = KMAT + 1
        KMASS(1) = KMAT
      ENDIF
      GO TO 9000
C *
C **  ABSORPTION FACTORS
C *
17000 ITPH = KKRND(2,1)
      IF( ITPH.EQ.0 ) THEN
        KMAT = KMAT + 1
        KMASS(1) = KMAT
        GO TO 9000
      ENDIF
      K = NINT( ABS(CABSCO(ITPH))/10.0 )
      IF(K.GT.0) THEN
        KMASS(1) = K
       ELSE
        KMAT = KMAT + 1
        KMASS(1) = KMAT
      ENDIF
      GO TO 9000
C *
C **  PROFILE-SHAPE-COEFFICIENTS
C *
18000 ITPH  = KKRND(2,1)
      ISIDE = IAND( KKRND(3,1), 1 ) + 1
      IPRM  = IAND( KKRND(3,1)/2, 3 )
      IF( ITPH.EQ.0 .OR. ISIDE.EQ.0 .OR. IPRM.EQ.0 ) THEN
        KMAT = KMAT + 1
        KMASS(1) = KMAT
        GO TO 9000
      ENDIF
      K = NINT( ABS(CPSFC(IPRM,ISIDE,ITPH))/10.0 )
      IF(K.GT.0) THEN
        KMASS(1) = K
       ELSE
        KMAT = KMAT + 1
        KMASS(1) = KMAT
      ENDIF
      GO TO 9000
C *
C **  ASYMMETRY COEFFICIENTS
C *
19000 ITPH = KKRND(2,1)
      IF( ITPH.EQ.0 ) THEN
        KMAT = KMAT + 1
        KMASS(1) = KMAT
        GO TO 9000
      ENDIF
      K = NINT( ABS(CASYP(ITPH))/10.0 )
      IF(K.GT.0) THEN
        KMASS(1) = K
       ELSE
        KMAT = KMAT + 1
        KMASS(1) = KMAT
      ENDIF
      GO TO 9000
C *
C **  PROFILE BROADENING COEFFICIENTS
C *
20000 ITPH  = KKRND(2,1)
      ISIDE = IAND( KKRND(3,1), 1 ) + 1
      IPRM  = IAND( KKRND(3,1)/2, 3 )
      IF( ITPH.EQ.0 .OR. ISIDE.EQ.0 .OR. IPRM.EQ.0 ) THEN
        KMAT = KMAT + 1
        KMASS(1) = KMAT
        GO TO 9000
      ENDIF
      K = NINT( ABS(CUVW(IPRM,ISIDE,ITPH))/10.0 )
      IF(K.GT.0) THEN
        KMASS(1) = K
       ELSE
        KMAT = KMAT + 1
        KMASS(1) = KMAT
      ENDIF
      GO TO 9000
C *
C **  LATTICE PARAMETERS
C *
C21000 ITPH = KKRND(2,1)
C     IPRM = KKRND(3,1)
C     IF( ITPH.EQ.0 .OR. IPRM.EQ.0 ) THEN
C       KMAT = KMAT + 1
C       KMASS(1) = KMAT
C       GO TO 9000
C     ENDIF
C     K = NINT( ABS(CCELL(IPRM,ITPH))/10.0 )
C     IF(K.GT.0) THEN
C       KMASS(1) = K
C      ELSE
C       KMAT = KMAT + 1
C       KMASS(1) = KMAT
C     ENDIF
21000 GO TO 9000
C *
C **  PREFERRED ORIENTATION COEFFICIENTS
C *
22000 ITPH = KKRND(2,1)
      IVEC = IAND( KKRND(3,1), 1 ) + 1
      IPRM = IAND( KKRND(3,1)/2, 3 )
      IF( ITPH.EQ.0 .OR. IVEC.EQ.0 .OR. IPRM.EQ.0 ) THEN
        KMAT = KMAT + 1
        KMASS(1) = KMAT
        GO TO 9000
      ENDIF
      K = NINT( ABS(CPREF(IPRM,ISIDE,ITPH))/10.0 )
      IF(K.GT.0) THEN
        KMASS(1) = K
       ELSE
        KMAT = KMAT + 1
        KMASS(1) = KMAT
      ENDIF
      GO TO 9000
C *
C **  DISPLACEMENT - NO CONSTRAINTS
C *
23000 KMAT = KMAT + 1
      KMASS(1) = KMAT
      GO TO 9000
C *
C **  ZERO POINT - NO CONSTRAINTS
C *
24000 KMAT = KMAT + 1
      KMASS(1) = KMAT
      GO TO 9000
C *
C **  AMORPHOUS PROFILE PARAMETERS - NO CONSTRAINTS
C *
25000 KMAT = KMAT + 1
      KMASS(1) = KMAT
      GO TO 9000
C *
C **  BACKGROUND - NO CONSTRAINTS
C *
26000 KMAT = KMAT + 1
      KMASS(1) = KMAT
      GO TO 9000
C *
C *  FINISHED
9000  RETURN
      END
C **  CWDEKO - DECODE RIETVELD CODWORDS
C *
      SUBROUTINE CWDEKO( CWCODE, N, KKMAT, KKRND, CCSHFT )
      DIMENSION CWCODE(N),KKMAT(N),KKRND(5,N),CCSHFT(N)
C *
      DO 1010 J=1,N
      KKRND(1,J) = 0
      KKRND(2,J) = 0
      KKRND(3,J) = 0
      ABSCW      = ABS( CWCODE(J) )
      KKMAT(J)   = NINT( ABSCW/10.0 )
      CCSHFT(J)  = ABSCW - REAL(KKMAT(J)*10)
      IF(CCSHFT(J).EQ.0.0) CCSHFT(J) = 1.0
      KKRND(4,J) = IAND( NINT(ABS(CCSHFT(J)*100.0)), 1023 )
      IF(CWCODE(J).LT.0) THEN
        KKRND(5,J) = 1
        CCSHFT(J)  = -CCSHFT(J)
       ELSE
        KKRND(5,J) = 0
      ENDIF
1010  CONTINUE
C *
      RETURN
      END
C **  CWKODE - CODE RIETVELD CODWORDS
C *
      SUBROUTINE CWKODE( CWCODE, N, KKMAT, KKRND, CCSHFT )
      DIMENSION CWCODE(N),KKMAT(N),KKRND(5,N),CCSHFT(N)
C *
      DO 1010 J=1,N
      IF( KKMAT(J).LT.1 ) THEN
        CWCODE(J) = 0.0
       ELSE
        IF( CCSHFT(J).EQ.0.0 ) CCSHFT(J) = 1.0
        CWCODE(J) = REAL(KKMAT(J))*10 + ABS( CCSHFT(J) )
        IF(KKRND(5,J).EQ.1) CWCODE(J) = - CWCODE(J)
      ENDIF
1010  CONTINUE
C *
      RETURN
      END
C **  KWKODE - CODE RIQAS CODEWORDS
C *
C *   KKRND(1,J) = ROUND
C *   KKRND(2,J) = PHASE ID OR ATOM ID PARAMETER IS TIED TO
C *   KKRND(3,J) = PARAMETER ID FOR TIED TO PHASE OR ATOM
C *   KKRND(4,J) = FRACTION SHIFT IN THOUSANDTHS
C *   KKRND(5,J) = SIGN FOR SHIFT, 0 POSITIVE, 1 NEGATIVE
C *
C *   PARAMETERS CODED INTO KKCODE IN THE FOLLOWING WAY:
C *
C *           2       2       2       1       1
C *           8       4       0       6       2       8       4     1
C *   0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
C *          2827----------------1817--------1211---------6 5-------1
C *          S   FRACTION SHIFT      PHS PRM       PHS TIE    ROUND
C *          +-  IN HUNDREDTHS       0-31          0-31       0-31
C *
      SUBROUTINE KWKODE( KKCODE, N, KKRND, CCSHFT )
C *
      DIMENSION KKCODE(N), KKRND(5,N),CCSHFT(N)
C *
      DO 1010 J=1,N
      KSHIFT  = NINT( ABS(CCSHFT(J)*100.0) )
      IF(CCSHFT(J).LT.0) THEN
        KSIGN = 1
       ELSE
        KSIGN = 0
      ENDIF
      KKCODE(J) = IAND( KKRND(1,J),   31 )
     1          + IAND( KKRND(2,J),   31 )*2**5
     1          + IAND( KKRND(3,J),   31 )*2**11
     1          + IAND( KSHIFT    , 1023 )*2**17
     1          + IAND( KSIGN     ,    1 )*2**27
1010  CONTINUE
C *
      RETURN
      END
C **  KWDEKO - DECODE RIQAS CODEWORDS
C *
      SUBROUTINE KWDEKO( KKCODE, N, KKRND, CCSHFT )
C *
      DIMENSION KKCODE(N), KKRND(5,N),CCSHFT(N)
C *
      DO 1010 J=1,N
      KKRND(1,J) = IAND( KKCODE(J)      ,   31 )
      KKRND(2,J) = IAND( KKCODE(J)/2**5 ,   31 )
      KKRND(3,J) = IAND( KKCODE(J)/2**11,   31 )
      KKRND(4,J) = IAND( KKCODE(J)/2**17, 1023 )
      KKRND(5,J) = IAND( KKCODE(J)/2**27,    1 )
      CCSHFT(J)  = REAL(KKRND(4,J))/100.0
      IF(KKRND(5,J).EQ.1) CCSHFT(J) = -CCSHFT(J)
1010  CONTINUE
C *
      RETURN
      END
