C---  PROGRAM: RIETVELD (RIET00) - RIETVELD STRUCTURE REFINEMENT
C---  VERSION: 890911  (YYMMDD)
C---
C-    ORIGINAL PROGRAM DBW 3.2 (WILES AND YOUNG, J.APPL.CRYST. X 1982)
C-    MODIFIED BY S. A. HOWARD
C-    DEPARTMENT OF CERAMIC ENGINEERING
C-    UNIVERSITY OF MISSOURI- ROLLA
C-    ROLLA MO, 65401  USA
C-
      PROGRAM RIETVELD
      INCLUDE 'RIETCOM.FOR'
      DIMENSION TIMES(4), KLGLB(19),KLPHS(26,MPHAS),KLA(11,MATMS)
C-
C--  ASSIGN I/O LOGICAL UNITS HERE
C-
      IOTTI =  5
      IOTTO =  6
      IODCF = 10
      IOPTN = 11
      IOBKG = 12
      IOALT =  7
      IOPLT = 13
      IONEW = 14
C-
C--  PERFORM THE PATTERN REFINEMENT
C-
1000  TIMES(1) = CPUSEC(     -1.0 )
C-
C-  INITIAL PROGRAM INPUT, GENERATION OF NECESSARY OPERATORS
C-
1100  CALL INPTR
      CALL PHYCON( 1 )
      CALL QUANT
      TIMES(1) = CPUSEC(      0.0 )
C-
C-  COMPILATION OF LINE LIST
C-
1200  CALL ASSIGN
      TIMES(2) = CPUSEC( TIMES(1) )
C-
C-  REFINEMENT OF VARIABLES, CHECK FOR AUTOPILOT
C-
1300  IF(JOBXN.LT.3) THEN
        KMXRND = KAUTON
       ELSE
        KMXRND = 1
      ENDIF
C-
      DO 1310 I=1,19
      KLGLB(I) = LGLB(I)
      LGLB(I)  = 0
1310  CONTINUE
      DO 1320 IPHASE=1,NPHASE
      KLPHS( 1,IPHASE) = LPHSCA(IPHASE)
      KLPHS( 2,IPHASE) = LPHOIT(IPHASE)
      KLPHS( 3,IPHASE) = LPHABS(IPHASE)
      KLPHS( 4,IPHASE) = LPHPSF(1,1,IPHASE)
      KLPHS( 5,IPHASE) = LPHPSF(2,1,IPHASE)
      KLPHS( 6,IPHASE) = LPHPSF(3,1,IPHASE)
      KLPHS( 7,IPHASE) = LPHPSF(1,2,IPHASE)
      KLPHS( 8,IPHASE) = LPHPSF(2,2,IPHASE)
      KLPHS( 9,IPHASE) = LPHPSF(3,2,IPHASE)
      KLPHS(10,IPHASE) = LPHASY(IPHASE)
      KLPHS(11,IPHASE) = LPHUVW(1,1,IPHASE)
      KLPHS(12,IPHASE) = LPHUVW(2,1,IPHASE)
      KLPHS(13,IPHASE) = LPHUVW(3,1,IPHASE)
      KLPHS(14,IPHASE) = LPHUVW(1,2,IPHASE)
      KLPHS(15,IPHASE) = LPHUVW(2,2,IPHASE)
      KLPHS(16,IPHASE) = LPHUVW(3,2,IPHASE)
      KLPHS(17,IPHASE) = LPHLAT(1,IPHASE)
      KLPHS(18,IPHASE) = LPHLAT(2,IPHASE)
      KLPHS(19,IPHASE) = LPHLAT(3,IPHASE)
      KLPHS(20,IPHASE) = LPHLAT(4,IPHASE)
      KLPHS(21,IPHASE) = LPHLAT(5,IPHASE)
      KLPHS(22,IPHASE) = LPHLAT(6,IPHASE)
      KLPHS(23,IPHASE) = LPOPAR(1,1,IPHASE)
      KLPHS(24,IPHASE) = LPOPAR(2,1,IPHASE)
      KLPHS(25,IPHASE) = LPOPAR(1,2,IPHASE)
      KLPHS(26,IPHASE) = LPOPAR(2,2,IPHASE)
      LPHSCA(IPHASE)     = 0
      LPHOIT(IPHASE)     = 0
      LPHABS(IPHASE)     = 0
      LPHPSF(1,1,IPHASE) = 0
      LPHPSF(2,1,IPHASE) = 0
      LPHPSF(3,1,IPHASE) = 0
      LPHPSF(1,2,IPHASE) = 0
      LPHPSF(2,2,IPHASE) = 0
      LPHPSF(3,2,IPHASE) = 0
      LPHASY(IPHASE)     = 0
      LPHUVW(1,1,IPHASE) = 0
      LPHUVW(2,1,IPHASE) = 0
      LPHUVW(3,1,IPHASE) = 0
      LPHUVW(1,2,IPHASE) = 0
      LPHUVW(2,2,IPHASE) = 0
      LPHUVW(3,2,IPHASE) = 0
      LPHLAT(1,IPHASE)   = 0
      LPHLAT(2,IPHASE)   = 0
      LPHLAT(3,IPHASE)   = 0
      LPHLAT(4,IPHASE)   = 0
      LPHLAT(5,IPHASE)   = 0
      LPHLAT(6,IPHASE)   = 0
      LPOPAR(1,1,IPHASE) = 0
      LPOPAR(2,1,IPHASE) = 0
      LPOPAR(1,2,IPHASE) = 0
      LPOPAR(2,2,IPHASE) = 0
1320  CONTINUE
      DO 1330 I=1,(NATM(1,NPHASE)+NATM(2,NPHASE)-1)
      DO 1330 J=1,11
      KLA(J,I) = LATOM(J,I)
      LATOM(J,I)  = 0
1330  CONTINUE
C-
      DO 1390 KCURND=1,KMXRND
      IF(JOBXN.LT.3) THEN
        KMXVAR = KAUTOV(KCURND)
        KMXCYC = KAUTOR(KCURND)
       ELSE
        KMXVAR = 0
        KMXCYC = 1
      ENDIF
      DO 1340 I=1,19
1340  IF(KLGLB(I).LE.KMXVAR) LGLB(I) = KLGLB(I)
      DO 1350 IPHASE=1,NPHASE
      IF(KLPHS( 1,IPHASE).LE.KMXVAR) LPHSCA(IPHASE)   = KLPHS( 1,IPHASE)
      IF(KLPHS( 2,IPHASE).LE.KMXVAR) LPHOIT(IPHASE)   = KLPHS( 2,IPHASE)
      IF(KLPHS( 3,IPHASE).LE.KMXVAR) LPHABS(IPHASE)   = KLPHS( 3,IPHASE)
      IF(KLPHS( 4,IPHASE).LE.KMXVAR) LPHPSF(1,1,IPHASE)=KLPHS( 4,IPHASE)
      IF(KLPHS( 5,IPHASE).LE.KMXVAR) LPHPSF(2,1,IPHASE)=KLPHS( 5,IPHASE)
      IF(KLPHS( 6,IPHASE).LE.KMXVAR) LPHPSF(3,1,IPHASE)=KLPHS( 6,IPHASE)
      IF(KLPHS( 7,IPHASE).LE.KMXVAR) LPHPSF(1,2,IPHASE)=KLPHS( 7,IPHASE)
      IF(KLPHS( 8,IPHASE).LE.KMXVAR) LPHPSF(2,2,IPHASE)=KLPHS( 8,IPHASE)
      IF(KLPHS( 9,IPHASE).LE.KMXVAR) LPHPSF(3,2,IPHASE)=KLPHS( 9,IPHASE)
      IF(KLPHS(10,IPHASE).LE.KMXVAR) LPHASY(IPHASE)   = KLPHS(10,IPHASE)
      IF(KLPHS(11,IPHASE).LE.KMXVAR) LPHUVW(1,1,IPHASE)=KLPHS(11,IPHASE)
      IF(KLPHS(12,IPHASE).LE.KMXVAR) LPHUVW(2,1,IPHASE)=KLPHS(12,IPHASE)
      IF(KLPHS(13,IPHASE).LE.KMXVAR) LPHUVW(3,1,IPHASE)=KLPHS(13,IPHASE)
      IF(KLPHS(14,IPHASE).LE.KMXVAR) LPHUVW(1,2,IPHASE)=KLPHS(14,IPHASE)
      IF(KLPHS(15,IPHASE).LE.KMXVAR) LPHUVW(2,2,IPHASE)=KLPHS(15,IPHASE)
      IF(KLPHS(16,IPHASE).LE.KMXVAR) LPHUVW(3,2,IPHASE)=KLPHS(16,IPHASE)
      IF(KLPHS(17,IPHASE).LE.KMXVAR) LPHLAT(1,IPHASE) = KLPHS(17,IPHASE)
      IF(KLPHS(18,IPHASE).LE.KMXVAR) LPHLAT(2,IPHASE) = KLPHS(18,IPHASE)
      IF(KLPHS(19,IPHASE).LE.KMXVAR) LPHLAT(3,IPHASE) = KLPHS(19,IPHASE)
      IF(KLPHS(20,IPHASE).LE.KMXVAR) LPHLAT(4,IPHASE) = KLPHS(20,IPHASE)
      IF(KLPHS(21,IPHASE).LE.KMXVAR) LPHLAT(5,IPHASE) = KLPHS(21,IPHASE)
      IF(KLPHS(22,IPHASE).LE.KMXVAR) LPHLAT(6,IPHASE) = KLPHS(22,IPHASE)
      IF(KLPHS(23,IPHASE).LE.KMXVAR) LPOPAR(1,1,IPHASE)=KLPHS(23,IPHASE)
      IF(KLPHS(24,IPHASE).LE.KMXVAR) LPOPAR(2,1,IPHASE)=KLPHS(24,IPHASE)
      IF(KLPHS(25,IPHASE).LE.KMXVAR) LPOPAR(1,2,IPHASE)=KLPHS(25,IPHASE)
      IF(KLPHS(26,IPHASE).LE.KMXVAR) LPOPAR(2,2,IPHASE)=KLPHS(26,IPHASE)
1350  CONTINUE
      DO 1360 I=1,(NATM(1,NPHASE)+NATM(2,NPHASE)-1)
      DO 1360 J=1,11
1360  IF(KLA(J,I).LE.KMXVAR) LATOM(J,I) = KLA(J,I)
      CALL ITER
1390  CONTINUE
C-
      CALL QUANT
      TIMES(3) = CPUSEC( TIMES(2) )
C-
C-  WRITING OF RESULTS
C-
1400  CALL EXPUT
      TIMES(4) = CPUSEC( TIMES(3) )
C-
C--  GIVE TIMING STATISTICS
C-
2000  TTIME = TIMES(1) + TIMES(2) + TIMES(3) + TIMES(4)
      TFACT = 100 / AMAX1( TTIME, 1.0 )
      WRITE(IOTTO,2010) (NINT(TIMES(I)),NINT(TIMES(I)*TFACT),I=1,4),
     1  NINT(TTIME)
2010  FORMAT(/,' Run time statistics:',//,
     1 '  Process                 Seconds   Percentage',/,
     1 '  --------------------    -------   ----------',/,
     1 '  Setup                   ',I7,'      ',I3,/,
     1 '  Reflections             ',I7,'      ',I3,/,
     1 '  Refinement              ',I7,'      ',I3,/,
     1 '  Rewrite, Plotting       ',I7,'      ',I3,/,
     1 '  TOTAL EXECUTION TIME    ',I7)
C-
C--  ENSURE ALL DATA FILES ARE CLOSED
C-
3000  IF(QLSTFN.NE.'TERMINAL') CLOSE(UNIT=IOTTO)
C-
9000  IOTTO = 6
      WRITE(IOTTO,9010)
9010  FORMAT(/,' * *  NORMAL COMPLETION * *')
C-
      STOP
      END
C ***  FUNCTION CPUSEC - RETURNS CPU EXECUTION TIME IN SECONDS
C *
C *  FIRST CALL:  START IS -VE, THE TIMER IS INITIALIZED
C *  NEXT CALLS:  START IS USED FOR DELTA TIME INTERVALS
C *  NOTE:  KEEP THIS SR IN MAIN.
C *
      FUNCTION CPUSEC( START )
C *
CVAX
      IF(START.LT.0.0) THEN
        IADDR = 0
        ISTAT = LIB$INIT_TIMER( IADDR )
      ENDIF
      ISTAT = LIB$STAT_TIMER( 2, ITIME, IADDR )
      CPUSEC = ( REAL( ITIME ) / 100.0 ) - START
CVAX
CIBM
C      CPUSEC = 0.0
CIBM
CIBMPC
c       INTEGER*2 IH,IM,IS,IHS
c       SAVE TKEEP
c       CALL GETTIM( IH, IM, IS, IHS )
c       CPUSEC = REAL(IHS)/100.0+REAL(IS)+REAL(IM)*60.0+REAL(IH)*3600.0
c       IF(START.LT.0.0) THEN
c         TKEEP = CPUSEC
c         CPUSEC = 0.0
c        ELSE
c         CPUSEC = CPUSEC - TKEEP
c         IF(CPUSEC.LT.START) CPUSEC = CPUSEC + ( 24.0 * 3600.0 )
c         CPUSEC = CPUSEC - START
c       ENDIF
CIBMPC
C *
      RETURN
      END
C ***  DATE - DUMMY ROUTINE
C *    LIMIT TO 9 CHARACTERS.  USED ONLY AS A TIME STAMP.
C *
      SUBROUTINE DATE( QDATE )
      CHARACTER QDATE*9
CIBM
C     QDATE = 'DD-MMM-YY'
CIBM
CIBMPC
c      INTEGER*2 IYEAR,IMONTH,IDAY
c      CHARACTER QMONTH(12)*3
c      DATA QMONTH/ 'Jan','Feb','Mar','Apr','May','Jun',
c     1             'Jul','Aug','Sep','Oct','Nov','Dec'/
c      CALL GETDAT( IYEAR, IMONTH, IDAY )
c      IYEAR = IYEAR - 1900
c      WRITE(QDATE,1) IDAY,IYEAR
c 1    FORMAT(I2,'-',3X,'-',I2)
c      QDATE(4:6) = QMONTH(IMONTH)
CIBMPC
      RETURN
      END
C ***  TIME - DUMMY ROUTINE
C *    LIMIT TO 8 CHARACTERS.  USED ONLY AS A TIME STAMP.
C *
      SUBROUTINE TIME( QTIME )
      CHARACTER QTIME*8
CIBM
C     QTIME = 'HH:MM:SS'
CIBM
CIBMPC
c      INTEGER*2 IH,IM,IS,IHS
c      CALL GETTIM( IH, IM, IS, IHS )
c      WRITE(QTIME,1) IH,IM,IS
c 1    FORMAT(I2,':',I2,':',I2)
c      IF(QTIME(4:4).EQ.' ') QTIME(4:4) = '0'
c      IF(QTIME(7:7).EQ.' ') QTIME(7:7) = '0'
CIBMPC
      RETURN
      END
C ***  CORPOS - TWO-THETA LINE CORRECTION FROM INSTRUMENTAL PARAMETERS
C *
C *  TT-COR = TT-OBS + CORPOS( TT-OBS )
C *
      FUNCTION CORPOS( TTOBS )
C *
C *  INCLUDE THE COMMON BLOCKS
      INCLUDE 'RIETCOM.FOR'
C *
      LDEG = KGCAL(1,2)
      CORPOS = WGCAL(1)
      DO 1010 J=1,LDEG
1010  CORPOS = CORPOS + WGCAL(J+1) * TTOBS**J
C *
      RETURN
      END
C ***  FUNCTION FNFWHM - GENERATE FWHM VALUES FOR PROFILES BASED ON UVW
C *
      SUBROUTINE FNFWHM
      INCLUDE 'RIETCOM.FOR'
C *
      TANTH = TAN( PREFTT(IORDC) * DTORD2 )
C *
C *  CALCULATE FWHM**2
      FWHML = (PPHUVW(1,1,IPHASE)*TANTH+PPHUVW(2,1,IPHASE))*TANTH
     1        +  PPHUVW(3,1,IPHASE)
      FWHMH = (PPHUVW(1,2,IPHASE)*TANTH+PPHUVW(2,2,IPHASE))*TANTH
     1        +  PPHUVW(3,2,IPHASE)
C *
C *  CALCULATE FWHM AND CHECK FOR TOO SMALL LINE WIDTH
      IF(FWHML.LT.0.0) THEN
        FWHML = STEP / 4.0
       ELSE
        FWHML = SQRT( FWHML )
      ENDIF
      IF(FWHMH.LT.0.0) THEN
        FWHMH = STEP / 4.0
       ELSE
        FWHMH = SQRT( FWHMH )
      ENDIF
CDBG  WRITE(99,'('' RFTT,FWHM L,H= '',4F8.4)') PREFTT(IORDC),FWHML,FWHMH
C *
9000  RETURN
      END
C ***  FUNCTION FNCFWI - GENERATE FWHM VALUES FOR INSTRUMENT PROFILES
C *
      FUNCTION FNCFWI( ANGLE, ISIDE )
      INCLUDE 'RIETCOM.FOR'
C *
C *  GENERATE VALUE FOR FRONT SIDE OF PROFILE
5000  IF(ISIDE.EQ.1) THEN
        TANTHT = TAN( ANGLE * DTORD2 )
        FNCFWI =
     1  SQRT( WGPRO(1,1) + WGPRO(1,2)*TANTHT + WGPRO(1,3)*TANTHT**2 )
      ENDIF
C *
C *  GENERATE VALUE FOR BACK SIDE OF PROFILE
      IF(ISIDE.EQ.2) THEN
        TANTHT = TAN( ANGLE * DTORD2 )
        FNCFWI =
     1  SQRT( WGPRO(3,1) + WGPRO(3,2)*TANTHT + WGPRO(3,3)*TANTHT**2 )
      ENDIF
C *
9000  RETURN
      END
C ***  FUNCTION FNSHAP - GENERATE EXPONENTIAL PARAMETER FOR PROFILES
C *
      FUNCTION FNSHAP( ANGLE, ISIDE )
      INCLUDE 'RIETCOM.FOR'
C *
C *  GENERATE VALUE FOR FRONT SIDE OF PROFILE
      IF(ISIDE.EQ.1) THEN
        FNSHAP = WGPRO(2,1) + WGPRO(2,2)*ANGLE + WGPRO(2,3)*ANGLE**2
      ENDIF
C *
C *  GENERATE VALUE FOR BACK SIDE OF PROFILE
      IF(ISIDE.EQ.2) THEN
        FNSHAP = WGPRO(4,1) + WGPRO(4,2)*ANGLE + WGPRO(4,3)*ANGLE**2
      ENDIF
C *
      RETURN
      END
C ***  FUNCTION PLORNZ - LORENTZ/POLARIZATION FACTOR AT TWO-THETA
C *
      FUNCTION PLORNZ( TWOTHT )
      INCLUDE 'RIETCOM.FOR'
C *
C *  THIS IS THE LORENTZ-POLARIZATION CORRECTED FOR GR MONOCHROMETER
      ANG = TWOTHT * DTOR
      ANGD2 = ANG / 2.0
      PLORNZ  = 1.0 / ( 2.0 * COS(ANGD2) * SIN(ANGD2)**2 )
      IF( JOBXN.EQ.1 .OR. JOBXN.EQ.3 ) THEN
        PLORNZ  = ( 1.0 + PMCCOR * COS(ANG)**2 ) * PLORNZ
      ENDIF
C *
      RETURN
      END
C ***  CALCPH - POSITION AND HEIGHT FOR A SATELLITE LINE
C *
      SUBROUTINE CALCPH( TT1, YI1, N, TTN, YIN )
      INCLUDE 'RIETCOM.FOR'
C *
      TTN = RTODT2 * ASIN( WGRAD(N,1)/WGRAD(1,1) * SIN(TT1*DTORD2) )
      YIN = YI1 * WGRAD(N,2)
      RETURN
      END
C--  PROFIL - GENERATES VALUES FOR PSF
C-
      FUNCTION PROFIL( X )
      INCLUDE 'RIETCOM.FOR'
C-
C-  TEST FOR SPLIT PROFILE FUNCTION
1000  IF(NPSF(2,IPHASE).EQ.0) GO TO 2000
      IF(NPSF(2,IPHASE).EQ.1) GO TO 3000
      IF(NPSF(2,IPHASE).EQ.2) GO TO 4000
      IF(NPSF(2,IPHASE).EQ.3) GO TO 5000
      STOP'--PROFILE:  Unknown shape constraints'
C-
C-  UN-SPLIT LINE PROFILES
C-
2000  GO TO (2100,2200,2300),NPSFKK
      STOP '--PROFIL:  Unknown PSF requested'
C-
C-  GAUSSIAN
2100  XE     = AMAX1( -2.772588722*X, -80.0 )
      PSFVAL = 0.939437279 / FWHM * EXP( XE )
      PSFDX  = 2.772588722
      GO TO 9000
C-
C-  PSEUDO-VOIGT
2200  EXPM = ( GAM3 * PREFTT(IORDC) + GAM2 ) * PREFTT(IORDC) + GAM1
      TLOR = 1.0 / ( 1.0 + 4.0 * X )
      TGAU = EXP( AMAX1( -2.772588722*X, -80.0 ) )
      PSFVAL   = (    EXPM      * 0.636619772  * TLOR
     1             + (1.0-EXPM) * 0.939437279  * TGAU    )
     1           / FWHM
      PSFDX    = (    EXPM      * 2.546479088  * TLOR**2
     1             + (1.0-EXPM) * 2.6046732048 * TGAU    )
     1           / FWHM / PSFVAL
      PSFDY(5) = (                0.636619772  * TLOR
     1             -              0.939437279  * TGAU    )
     1           / FWHM
      GO TO 9000
C-
C-  PEARSON VII WITH ANGULAR DEPENDENT M
2300  EXPM   = ( GAM3 * PREFTT(IORDC) + GAM2 ) * PREFTT(IORDC) + GAM1
      PRST   = 2.0**(1.0/EXPM) - 1.0
      TLOR   = ( 1.0 + 4.0 * PRST * X )
      PVM4   = TLOR**(-EXPM)
      PSFVAL = PVIIN(IPHASE,MODNRF) / FWHM * PVM4
      PSFDX  = EXPM * 4.0 * PRST / TLOR
      PDM4   = -EXPM * TLOR**(-EXPM-1.0)
     1 * ( 4.0 * X * 2.0**(1.0/EXPM) * ALOG(2.0) * (-EXPM**(-2)) )
     1 - ALOG(TLOR) * TLOR**(-EXPM)
      PSFDY(5) =
     1 ( PVIID(IPHASE,MODNRF)*PVM4 + PVIIN(IPHASE,MODNRF)*PDM4 ) / FWHM
      GO TO 9000
C-
C-  SPLIT PROFILES, DIFFERENT FWHM
C-
3000  GO TO (3100,3200,3300),NPSFKK
      STOP '--PROFIL:  Unknown PSF requested'
C-
C-  GAUSSIAN
3100  XE       = AMAX1( -2.772588722*X, -80.0 )
      FNRMD2   = 1.0 / ( FWHML + FWHMH )
      PSFVAL   = 2.0 * FNRMD2 * 0.939437279 * EXP( XE )
      PSFDX    = 2.772588722
      PSFDY(1) = -FNRMD2*PSFVAL + (-2.0*X/FWHML)*(-PSFDX*PSFVAL)
      PSFDY(1) = PSFDY(1) / PSFVAL
      PSFDY(2) = -FNRMD2*PSFVAL
      PSFDY(2) = PSFDY(2) / PSFVAL
      PSFDY(3) = -FNRMD2*PSFVAL
      PSFDY(3) = PSFDY(3) / PSFVAL
      PSFDY(4) = -FNRMD2*PSFVAL + (-2.0*X/FWHMH)*(-PSFDX*PSFVAL)
      PSFDY(4) = PSFDY(4) / PSFVAL
      GO TO 9000
C-
C-  PSEUDO-VOIGT
3200  EXPM   = ( GAM3 * PREFTT(IORDC) + GAM2 ) * PREFTT(IORDC) + GAM1
      TLOR   = 1.0 / ( 1.0 + 4.0 * X )
      TGAU   = EXP( AMAX1( -2.772588722*X, -80.0 ) )
      FNRMD2 = 1.0 / ( FWHML + FWHMH )
      FNORM  = 2.0 * FNRMD2
      PSFVAL = FNORM * (    EXPM      * 0.636619772  * TLOR
     1                   + (1.0-EXPM) * 0.939437279  * TGAU    )
      PSFDX  = FNORM * (    EXPM      * 2.546479088  * TLOR**2
     1                   + (1.0-EXPM) * 2.6046732048 * TGAU    )
     1         / PSFVAL
      PSFDY(1) = -FNRMD2*PSFVAL + (-2.0*X/FWHML)*(-PSFDX*PSFVAL)
      PSFDY(1) = PSFDY(1) / PSFVAL
      PSFDY(2) = -FNRMD2*PSFVAL
      PSFDY(2) = PSFDY(2) / PSFVAL
      PSFDY(3) = -FNRMD2*PSFVAL
      PSFDY(3) = PSFDY(3) / PSFVAL
      PSFDY(4) = -FNRMD2*PSFVAL + (-2.0*X/FWHMH)*(-PSFDX*PSFVAL)
      PSFDY(4) = PSFDY(4) / PSFVAL
      PSFDY(5) = (                0.636619772  * TLOR
     1             -              0.939437279  * TGAU    )
     1           * FNRMD2
      GO TO 9000
C-
C-  PEARSON VII WITH ANGULAR DEPENDENT M
3300  EXPM     = ( GAM3 * PREFTT(IORDC) + GAM2 ) * PREFTT(IORDC) + GAM1
      PRST     = 2.0**(1.0/EXPM) - 1.0
      TLOR     = ( 1.0 + 4.0 * PRST * X )
      FNRMD2   = 1.0 / ( FWHML + FWHMH )
      PVM4     = TLOR**(-EXPM)
      PSFVAL   = 2.0 * FNRMD2 * PVIIN(IPHASE,MODNRF) * PVM4
      PSFDX    = EXPM * 4.0 * PRST / TLOR
      PSFDY(1) = -FNRMD2*PSFVAL + (-2.0*X/FWHML)*(-PSFDX*PSFVAL)
      PSFDY(1) = PSFDY(1) / PSFVAL
      PSFDY(2) = -FNRMD2*PSFVAL
      PSFDY(2) = PSFDY(2) / PSFVAL
      PSFDY(3) = -FNRMD2*PSFVAL
      PSFDY(3) = PSFDY(3) / PSFVAL
      PSFDY(4) = -FNRMD2*PSFVAL + (-2.0*X/FWHMH)*(-PSFDX*PSFVAL)
      PSFDY(4) = PSFDY(4) / PSFVAL
      PDM4     = -EXPM * TLOR**(-EXPM-1.0)
     1 * ( 4.0 * X * 2.0**(1.0/EXPM) * ALOG(2.0) * (-EXPM**(-2)) )
     1 - ALOG(TLOR) * TLOR**(-EXPM)
      PSFDY(5) =
     1 ( PVIID(IPHASE,MODNRF)*PVM4 + PVIIN(IPHASE,MODNRF)*PDM4 ) / FWHM
      GO TO 9000
C-
C-  SPLIT PROFILES, DIFFERENT SHAPE PARAMETERS
C-
4000  GO TO (4100,4200,4300),NPSFKK
      STOP '--PROFIL:  ILLEGAL PROFILE FUNCTION REQUEST'
C-
C-  PROFILE DOES NOT HAVE VARIABLE SHAPE PARAMETERS
4100  STOP'--PROFILE: Gaussian PSF does not have variable shape'
C-
C-  PSEUDO-VOIGT
4200  EXPML= ( PPHPSF(3,1,IPHASE)*PREFTT(IORDC) + PPHPSF(2,1,IPHASE) ) *
     1  PREFTT(IORDC) + PPHPSF(1,1,IPHASE)
      EXPMH= ( PPHPSF(3,2,IPHASE)*PREFTT(IORDC) + PPHPSF(2,2,IPHASE) ) *
     1  PREFTT(IORDC) + PPHPSF(1,2,IPHASE)
      TLOR  = 1.0 / ( 1.0 + 4.0 * X )
      TGAU  = EXP( AMAX1( -2.772588722*X, -80.0 ) )
      IF(TTHOMC.GT.0.0) THEN
C       FNORM = (EXPML*(0.636619772-0.939437279)+0.939437279) /
C    1          (EXPMH*(0.636619772-0.939437279)+0.939437279)
        FNORM = 1.0
        EXPM  = EXPMH
       ELSE
        FNORM = (EXPMH*(0.636619772-0.939437279)+0.939437279) /
     1          (EXPML*(0.636619772-0.939437279)+0.939437279)
        EXPM  = EXPML
      ENDIF
      FFNORM  = ( 1.0 + (EXPMH*(0.636619772-0.939437279)+0.939437279) /
     1            (EXPML*(0.636619772-0.939437279)+0.939437279) ) / 2.0
      FNORM   = FNORM / FFNORM
      PSF     =         (   EXPM       * 0.636619772  * TLOR
     1                    + (1.0-EXPM) * 0.939437279  * TGAU    )
     1          / FWHM
      PSFVAL  = FNORM * PSF
      PSFDX   = FNORM * (   EXPM       * 2.546479088  * TLOR**2
     1                    + (1.0-EXPM) * 2.6046732048 * TGAU    )
     1          / FWHM / PSFVAL
      PSFDY(5) = FNORM * (                0.636619772  * TLOR
     1                     -              0.939437279  * TGAU    )
     1           / FWHM
      GO TO 9000
C-
C-  PEARSON VII WITH ANGULAR DEPENDENT M
4300  EXPM   = ( GAM3 * PREFTT(IORDC) + GAM2 ) * PREFTT(IORDC) + GAM1
      PRST   = 2.0**(1.0/EXPM) - 1.0
      TLOR   = ( 1.0 + 4.0 * PRST * X )
      PVM4   = TLOR**(-EXPM)
      PSFVAL = PVIIN(IPHASE,MODNRF) / FWHM * PVM4
      PSFDX  = EXPM * 4.0 * PRST / TLOR
      PDM4   = -EXPM * TLOR**(-EXPM-1.0)
     1 * ( 4.0 * X * 2.0**(1.0/EXPM) * ALOG(2.0) * (-EXPM**(-2)) )
     1 - ALOG(TLOR) * TLOR**(-EXPM)
      PSFDY(5) =
     1 ( PVIID(IPHASE,MODNRF)*PVM4 + PVIIN(IPHASE,MODNRF)*PDM4 ) / FWHM
      PSFDY(6) =
     1 PVIID2(IPHASE,MODNRF)*PVM4/FWHM
      PSFDY(7) =
     1 PVIID(IPHASE,MODNRF)*PVM4/FWHM
      PSFDY(8) =
     1 ( PVIID2(IPHASE,MODNRF)*PVM4 + PVIIN(IPHASE,MODNRF)*PDM4 ) / FWHM
      GO TO 9000
C-
C-  SPLIT PROFILES, DIFFERENT FWHM AND SHAPE PARAMETERS
C-
5000  GO TO (5100,5200,5300),NPSFKK
      STOP '--PROFIL:  Unknown PSF requested'
C-
C-  GAUSSIAN PSF
5100  STOP'--PROFILE: Gaussian PSF; FWHM *and* SHAPE not variable'
C-
C-  PSEUDO VOIGT
5200  STOP'--PROFILE: pseudo-Voigt PSF; FWHM *and* SHAPE not variable'
C-
C-  PEARSON VII WITH ANGULAR DEPENDENT M
5300  EXPM   = ( GAM3 * PREFTT(IORDC) + GAM2 ) * PREFTT(IORDC) + GAM1
      FNRMD2 = 1.0 / ( FWHML + FWHMH )
      FNORM  = 2.0 * FNRMD2
      PRST   = 2.0**(1.0/EXPM) - 1.0
      TLOR   = ( 1.0 + 4.0 * PRST * X )
      PVM4   = TLOR**(-EXPM)
      PSFVAL = FNORM * PVIIN(IPHASE,MODNRF) * PVM4
      PSFDX  = EXPM * 4.0 * PRST / TLOR
      PSFDY(1) = -FNRMD2*PSFVAL + (-2.0*X/FWHML)*(-PSFDX*PSFVAL)
      PSFDY(1) = PSFDY(1) / PSFVAL
      PSFDY(2) = -FNRMD2*PSFVAL
      PSFDY(2) = PSFDY(2) / PSFVAL
      PSFDY(3) = -FNRMD2*PSFVAL
      PSFDY(3) = PSFDY(3) / PSFVAL
      PSFDY(4) = -FNRMD2*PSFVAL + (-2.0*X/FWHMH)*(-PSFDX*PSFVAL)
      PSFDY(4) = PSFDY(4) / PSFVAL
      PDM4   = -EXPM * TLOR**(-EXPM-1.0)
     1 * ( 4.0 * X * 2.0**(1.0/EXPM) * ALOG(2.0) * (-EXPM**(-2)) )
     1 - ALOG(TLOR) * TLOR**(-EXPM)
      PSFDY(5) = FNORM *
     1 ( PVIID(IPHASE,MODNRF)*PVM4 + PVIIN(IPHASE,MODNRF)*PDM4 )
      PSFDY(6) = FNORM *
     1 ( PVIID2(IPHASE,MODNRF)*PVM4 )
      PSFDY(7) = FNORM *
     1 ( PVIID(IPHASE,MODNRF)*PVM4  )
      PSFDY(8) = FNORM *
     1 ( PVIID2(IPHASE,MODNRF)*PVM4 + PVIIN(IPHASE,MODNRF)*PDM4 )
C-
9000  PROFIL = PSFVAL
      RETURN
      END
C---  PHYCON - DETERMINE PHYSICAL CONSTANTS FOR EACH OF THE PHASES
C-
      SUBROUTINE PHYCON( IFLAG )
C-
      INCLUDE 'RIETCOM.FOR'
      PARAMETER ( AVAGOD = 6.0223E23,  CATOCC = 1.0E-24 )
      CHARACTER QATOM*3
      DIMENSION WGTFRC(MATMS), ATMABS(MATMS)
C-
      WGTMIX = 0.0
      ABSMIX = 0.0
C-
C--  REPEAT FOR EACH PHASE
C-
      IF(IFLAG.EQ.0) WRITE(IOTTO,1)
1     FORMAT(/,' * *  CALCULATED PHYSICAL PROPERTIES OF COMPONENTS:')
1000  DO 1010 IPHASE=1,NPHASE
C-
      NATOM = NATM(1,IPHASE)
      IOF   = NATM(2,IPHASE) - 1
      WGTCMP = 0.0
C-
C--  REPEAT FOR EACH ATOM IN THE PHASE
C-
      DO 1020 I=1,NATOM
      IPIOF = I + IOF
C-
C-  GET THE ATOM TYPE FROM THE ATOM PARAMETER LIST
      QATOM = QATTYP(IPIOF)(1:3)
      IF( LLT(QATOM(2:2),'A') .OR. LGT(QATOM(2:2),'Z') )QATOM(2:2) = ' '
      IF( LLT(QATOM(3:3),'A') .OR. LGT(QATOM(3:3),'Z') )QATOM(3:3) = ' '
C-
C-  SEARCH THE ATOMIC WEIGHTS TABLE FOR ENTRY
1100  DO 1110 J=1,109
1110  IF(QWGT(J).EQ.QATOM) GO TO 1120
      WRITE(IOTTO,1112) QATOM
1112  FORMAT(' --COULD NOT FIND ATOM ',A3,' IN ATOMIC WEIGHT TABLE.')
      STOP ' ARRRRGGGGGH'
C-
C-  CALCULATE THE CONTRIBUTION OF THIS ATOM TO THE CELL WEIGHT
1120  WGTFRC(I) = PATOM(5,IPIOF) * REAL(MLT(1,IPHASE)) * AWGT(J)
      WGTCMP = WGTCMP + WGTFRC(I)
C-
C-  SEARCH THE ABSORBTION TABLE FOR ENTRY
1200  DO 1210 J=1,87
1210  IF(QABS(J).EQ.QATOM) GO TO 1220
      WRITE(IOTTO,1212) QATOM
1212  FORMAT(' --COULD NOT FIND ATOM ',A3,' IN THE ABSORPTION TABLE.')
      STOP ' ARRRRGGGGGH'
C-
C-  GET THE MASS ABSORBTION COEFFICIENT FOR THE ATOM
1220  ATMABS(I) = AABS(IXRAY,J)
C-
1020  CONTINUE
C-
C--  CALCULATE THE MASS ABSORBTION COEFFICIENT FOR THE CELL
C-
      ABSCMP(IPHASE) = 0
      DO 1022 I=1,NATOM
1022  ABSCMP(IPHASE) = ABSCMP(IPHASE) + WGTFRC(I)/WGTCMP * ATMABS(I)
C-
C-  CALCULATE THE VOLUME FOR THIS CELL
      CELLAA = SAVE(1,IPHASE)
      CELLBB = SAVE(2,IPHASE)
      CELLCC = SAVE(3,IPHASE)
      COSA   = COS( SAVE(4,IPHASE) * DTOR )
      COSB   = COS( SAVE(5,IPHASE) * DTOR )
      COSG   = COS( SAVE(6,IPHASE) * DTOR )
      T1 = 1.0 - COSA**2 - COSB**2 - COSG**2 + 2.0 * COSA * COSB * COSG
      VOLUME = CELLAA * CELLBB * CELLCC * SQRT( T1 )
      VO2CMP(IPHASE) = VOLUME * VOLUME
C-
C-  THE DENSITY FOR THIS PHASE
      DENCMP(IPHASE) = WGTCMP / VOLUME / (AVAGOD*CATOCC)
C-
      IF(IFLAG.EQ.0) WRITE(IOTTO,1310) QPHSNM(IPHASE),QRADTN(IXRAY),
     1  VOLUME,WGTCMP,DENCMP(IPHASE),ABSCMP(IPHASE)
1310  FORMAT(/,
     1' Phase: ',A32,5X,'Using *',A2,'* radiation:',//,
     1 5X,'Cell volume: ',F8.2,' A**3        Mol. wgt. * Z:    ',F8.2,/,
     1 5X,'Density:     ',F8.2,' G/CM**3     Mass abs. coeff.: ',F8.2)
C-
1010  CONTINUE
C-
9000  RETURN
      END
C---  QUANT - QUANTITATIVE ANALYSIS OF MULTI-COMPONENT MIXTURE
C-
      SUBROUTINE QUANT
C-
      INCLUDE 'RIETCOM.FOR'
      PARAMETER ( AVAGOD = 6.0223E23,  CATOCC = 1.0E-24 )
      DIMENSION SCALE(MPHAS)
C-
C--  DETERMINE PHYSICAL FACTORS BASED ON LAST (BEST) VALUES
C-
C-  NOTE: SCALE FACTORS GET CORRECTED HERE FOR NEW VOLUME
CZZZ  SCALEF = SCALEF / VO2CMP(IPHASE)
1000  DO 1010 IPHASE=1,NPHASE
1010  PPHSCA(IPHASE) = PPHSCA(IPHASE) / VO2CMP(IPHASE)
      CALL PHYCON( 0 )
      SUMSF = 0.0
      DO 1020 IPHASE=1,NPHASE
      PPHSCA(IPHASE) = PPHSCA(IPHASE) * VO2CMP(IPHASE)
      SCALE(IPHASE)  = PPHSCA(IPHASE) * DENCMP(IPHASE)
      SUMSF = SUMSF + SCALE(IPHASE)
1020  CONTINUE
C-
C--  WEIGHT FRACTIONS WITHOUT INTERNAL STANDARD
C-
2000  WRITE(IOTTO,2005)
2005  FORMAT(/,' * *  QUANTITATIVE ANALYSIS OF COMPONENTS:',//,
     1' The following results assume the sample consists only of the',
     1' input phases.',/,
     1' The sum of the weight fractions is constrained to equal 1.0.',/)
      DO 2010 IPHASE=1,NPHASE
      WFREL = SCALE(IPHASE) / SUMSF * 100.0
      DW = 0.0
      WRITE(IOTTO,2030) IPHASE,QPHSNM(IPHASE),WFREL
2030  FORMAT(' Phase ',I2,': ',A32,2X,'Weight percent: ',F6.2)
2010  CONTINUE
C-
C--  WEIGHT FRACTIONS WITH INTERNAL STANDARD
C-
3000  IF(KINTSF.NE.1) GO TO 4000
      WRITE(IOTTO,3002)
3002  FORMAT(//,
     1' The following results are based on the internal standard.',/,
     1' The sum of the weight fractions is not constrained to 1.0.',//,
     1' The weight fractions in () are normalized to remove the',
     1' internal standard.')
      RKPMUM = SCALE(KINTSN) / RINTSQ
      WRITE(IOTTO,3004) KINTSN,RINTSQ*100.0,RKPMUM
3004  FORMAT(/,
     1' Phase ',I2,' comprises ',F6.2,'% of the sample.  Calculated',
     1' K*RHO(M)/U(M): ',F9.4,/)
      RKPMUM = 100.0 / RKPMUM
      SUMWF = 0.0
      SUMWFN = 0.0
      DO 3010 IPHASE=1,NPHASE
      WFREL = SCALE(IPHASE) * RKPMUM
      SUMWF = SUMWF + WFREL
      WFRELN = WFREL / ( 1.0 - RINTSQ )
      IF(IPHASE.EQ.KINTSN) WFRELN = 0.0
      SUMWFN = SUMWFN + WFRELN
      WRITE(IOTTO,3030) IPHASE,QPHSNM(IPHASE),WFREL,WFRELN
3030  FORMAT(' Phase ',I2,': ',A32,2X,'Weight percent: ',F6.2,2X,
     1'(',F6.2,')')
3010  CONTINUE
      WRITE(IOTTO,3020) SUMWF,SUMWFN
3020  FORMAT(/,' The sum of the weight percents is ',F6.2,2X,
     1'(',F6.2,')')
C-
C--  DETERMINE SCALE FACTOR ADJUSTMENTS
C-
4000  IF(NPHASE.EQ.1) GO TO 9000
      K1 = KINTSA(1)
      K2 = KINTSA(2)
      K3 = KINTSA(3)
      IF(K1.GT.0) GO TO 5000
      IF(K1.EQ.0) GO TO 9000
      K1 = -K1
      K2 = -K2
      WRITE(IOTTO,4002)
4002  FORMAT(//,' * DETERMINATION OF SCALE FACTOR ADJUSTMENTS FOR',
     1' QUANTITATIVE ANALYSIS:')
      IF( K1.LT.1 .OR. K1.GT.NPHASE .OR. K2.LT.0 .OR. K2.GT.NPHASE) THEN
        WRITE(IOTTO,4006)
4006    FORMAT(' -DESIGNATED PHASE FOR CORRECTION IS OUT OF RANGE')
        GO TO 9000
      ENDIF
C-
C-  BASE ADJUSTMENTS ON BOTH PHASES IN THE LIST
      ADJ = RINTSA( 1 ) * SUMSF - SCALE( K1 )
      IF(K2.EQ.0) ADJ = ADJ / ( 1.0 - RINTSA( 1 ) )
      ADJ1 = ( SCALE(K1) + ADJ ) / DENCMP(K1)
      ADJ1 = ADJ1 / ( SCALE(K1) / DENCMP(K1) )
      IF(K2.EQ.0) WRITE(IOTTO,4020) K1,K1,QPHSNM(K1),ADJ1
4020  FORMAT(/,' Adjustments based on data for phase ',I2,':',/,
     1  (' Phase ',I2,': ',A32,'  Adjustment ',F7.4))
      IF(K2.GT.0) THEN
        ADJ2 = ( SCALE(K2) - ADJ ) / DENCMP(K2)
        ADJ2 = ADJ2 / ( SCALE(K2) / DENCMP(K2) )
        WRITE(IOTTO,4020) K1,K1,QPHSNM(K1),ADJ1,K2,QPHSNM(K2),ADJ2
        ADJ = RINTSA( 2 ) * SUMSF - SCALE( K2 )
        ADJ12 = ( SCALE(K1) - ADJ ) / DENCMP(K1)
        ADJ12 = ADJ12 / ( SCALE(K1) / DENCMP(K1) )
        ADJ22 = ( SCALE(K2) + ADJ ) / DENCMP(K2)
        ADJ22 = ADJ22 / ( SCALE(K2) / DENCMP(K2) )
        WRITE(IOTTO,4020) K2,K1,QPHSNM(K1),ADJ12,K2,QPHSNM(K2),ADJ22
        ADJ1 = 0.5 * ( ADJ1 + ADJ12 )
        ADJ2 = 0.5 * ( ADJ2 + ADJ22 )
        WRITE(IOTTO,4024) K1,QPHSNM(K1),ADJ1,K2,QPHSNM(K2),ADJ2
4024    FORMAT(/,' Adjustments based on data from both phases:',/,
     1  (' Phase ',I2,': ',A32,'  Adjustment ',F7.4))
      ENDIF
      SUMSF = 0.0
      DO 4030 IPHASE=1,NPHASE
      IF(IPHASE.EQ.K1) THEN
        SCALE(IPHASE) = PPHSCA(IPHASE) * ADJ1 * DENCMP(IPHASE)
       ELSE IF(IPHASE.EQ.K2) THEN
        SCALE(IPHASE) = PPHSCA(IPHASE) * ADJ2 * DENCMP(IPHASE)
       ELSE
        SCALE(IPHASE) = PPHSCA(IPHASE)        * DENCMP(IPHASE)
      ENDIF
      SUMSF = SUMSF + SCALE(IPHASE)
4030  CONTINUE
      WRITE(IOTTO,4035)
4035  FORMAT(/,' Quantitative results after scale factor correction:',/)
      DO 4040 IPHASE=1,NPHASE
      WFREL = SCALE(IPHASE) / SUMSF * 100.0
      DW = 0.0
      WRITE(IOTTO,2030) IPHASE,QPHSNM(IPHASE),WFREL
4040  CONTINUE
      GO TO 6000
C-
C--  QUANT USING SCALE FACTOR ADJUSTMENTS
C-
5000  WRITE(IOTTO,5002)
5002  FORMAT(//,' * QUANTITATIVE ANALYSIS USING SCALE FACTOR',
     1' ADJUSTMENTS:',/)
      IF( K1.LT.1 .OR. K1.GT.NPHASE .OR. K2.LT.0 .OR. K2.GT.NPHASE .OR.
     1    K3.LT.0 .OR. K3.GT.NPHASE ) THEN
        WRITE(IOTTO,5004)
5004    FORMAT(' -DESIGNATED PHASE FOR CORRECTION IS OUT OF RANGE')
        GO TO 9000
      ENDIF
C-
C-  APPLY ADJUSTMENT FACTORS AND DETERMINE WEIGHT FRACTIONS
      WRITE(IOTTO,5010) K1,QPHSNM(K1),RINTSA(1)
5010  FORMAT(' Phase ',I2,': ',A32,'  Adjustment factor ',F7.4)
      IF(K2.NE.0) WRITE(IOTTO,5010) K2,QPHSNM(K2),RINTSA(2)
      IF(K3.NE.0) WRITE(IOTTO,5010) K3,QPHSNM(K3),RINTSA(3)
      SUMSF = 0.0
      DO 5020 IPHASE=1,NPHASE
      IF(IPHASE.EQ.K1) THEN
        SCALE(IPHASE) = PPHSCA(IPHASE) * RINTSA(1) * DENCMP(IPHASE)
       ELSE IF(IPHASE.EQ.K2) THEN
        SCALE(IPHASE) = PPHSCA(IPHASE) * RINTSA(2) * DENCMP(IPHASE)
       ELSE IF(IPHASE.EQ.K3) THEN
        SCALE(IPHASE) = PPHSCA(IPHASE) * RINTSA(3) * DENCMP(IPHASE)
       ELSE
        SCALE(IPHASE) = PPHSCA(IPHASE)             * DENCMP(IPHASE)
      ENDIF
      SUMSF = SUMSF + SCALE(IPHASE)
5020  CONTINUE
      WRITE(IOTTO,4035)
      DO 5030 IPHASE=1,NPHASE
      WFREL = SCALE(IPHASE) / SUMSF * 100.0
      DW = 0.0
      WRITE(IOTTO,2030) IPHASE,QPHSNM(IPHASE),WFREL
5030  CONTINUE
C-
C-  QUANT WITH INTERNAL STANDARD EMPLOYING SCALE FACTOR ADJUSTMENTS
C-
6000  IF(KINTSF.NE.1) GO TO 9000
      WRITE(IOTTO,6002)
6002  FORMAT(//,
     1' The following results are based on the internal standard.',/,
     1' The sum of the weight fractions is not constrained to 1.0.',/,
     1' Scale factor adjustments are applied in this analysis.',/,
     1' The weight fractions in () are normalized to remove the',
     1' internal standard.',/)
      RKPMUM = SCALE(KINTSN) / RINTSQ
      WRITE(IOTTO,3004) KINTSN,RINTSQ*100.0,RKPMUM
      RKPMUM = 100.0 / RKPMUM
      SUMWF = 0.0
      SUMWFN = 0.0
      DO 6010 IPHASE=1,NPHASE
      WFREL = SCALE(IPHASE) * RKPMUM
      SUMWF = SUMWF + WFREL
      WFRELN = WFREL / ( 1.0 - RINTSQ )
      IF(IPHASE.EQ.KINTSN) WFRELN = 0.0
      SUMWFN = SUMWFN + WFRELN
      WRITE(IOTTO,3030) IPHASE,QPHSNM(IPHASE),WFREL,WFRELN
6010  CONTINUE
      WRITE(IOTTO,3020) SUMWF,SUMWFN
C-
9000  RETURN
      END
C ***  GENERATE SYMMETRY EQUIVALENT REFLECTIONS BASED ON THE LAUE GROUP
C *
      SUBROUTINE GNLARE( QGRP, IVI, IVO, NHKL )
 
      CHARACTER QGRP*8, QLGRP(24)*12, QLGRH(10)*12, QGRPC*12
      COMMON/SPGCOM/NLAUGR,NORAXS,NCONT(10),NSPCNT,NSPPOL,NSPMLT
      DIMENSION IVI(3),IVO(3,48),IVH(4,24)
      DIMENSION NLGRP(2,24),NTMP (3,160),NTMS (3,160)
      DIMENSION NLGRH(2,10),NTMHP(4, 75),NTMHS(4, 75)
      DATA QLGRP( 1),NLGRP(1, 1),NLGRP(2, 1) /'m-3m        ', 48,   1 /
      DATA QLGRP( 2),NLGRP(1, 2),NLGRP(2, 2) /'m3m         ', 48,   1 /
      DATA QLGRP( 3),NLGRP(1, 3),NLGRP(2, 3) /'m3barm      ', 48,   1 /
      DATA (NTMP(J,  1),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,  1),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J,  2),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,  2),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J,  3),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,  3),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J,  4),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,  4),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J,  5),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J,  5),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J,  6),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J,  6),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J,  7),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J,  7),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J,  8),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J,  8),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J,  9),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J,  9),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 10),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 10),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J, 11),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 11),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J, 12),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 12),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J, 13),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 13),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J, 14),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 14),J=1,3) /  1,  1, -1 /
      DATA (NTMP(J, 15),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 15),J=1,3) /  1, -1,  1 /
      DATA (NTMP(J, 16),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 16),J=1,3) / -1,  1,  1 /
      DATA (NTMP(J, 17),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 17),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J, 18),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 18),J=1,3) / -1,  1,  1 /
      DATA (NTMP(J, 19),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 19),J=1,3) /  1,  1, -1 /
      DATA (NTMP(J, 20),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 20),J=1,3) /  1, -1,  1 /
      DATA (NTMP(J, 21),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 21),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J, 22),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 22),J=1,3) /  1, -1,  1 /
      DATA (NTMP(J, 23),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 23),J=1,3) / -1,  1,  1 /
      DATA (NTMP(J, 24),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 24),J=1,3) /  1,  1, -1 /
      DATA (NTMP(J, 25),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J, 25),J=1,3) /  1,  1, -1 /
      DATA (NTMP(J, 26),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J, 26),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J, 27),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J, 27),J=1,3) /  1, -1,  1 /
      DATA (NTMP(J, 28),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J, 28),J=1,3) / -1,  1,  1 /
      DATA (NTMP(J, 29),J=1,3) /  3,  2,  1 /
      DATA (NTMS(J, 29),J=1,3) / -1,  1,  1 /
      DATA (NTMP(J, 30),J=1,3) /  3,  2,  1 /
      DATA (NTMS(J, 30),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J, 31),J=1,3) /  3,  2,  1 /
      DATA (NTMS(J, 31),J=1,3) /  1,  1, -1 /
      DATA (NTMP(J, 32),J=1,3) /  3,  2,  1 /
      DATA (NTMS(J, 32),J=1,3) /  1, -1,  1 /
      DATA (NTMP(J, 33),J=1,3) /  1,  3,  2 /
      DATA (NTMS(J, 33),J=1,3) /  1, -1,  1 /
      DATA (NTMP(J, 34),J=1,3) /  1,  3,  2 /
      DATA (NTMS(J, 34),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J, 35),J=1,3) /  1,  3,  2 /
      DATA (NTMS(J, 35),J=1,3) / -1,  1,  1 /
      DATA (NTMP(J, 36),J=1,3) /  1,  3,  2 /
      DATA (NTMS(J, 36),J=1,3) /  1,  1, -1 /
      DATA (NTMP(J, 37),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J, 37),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J, 38),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J, 38),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 39),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J, 39),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J, 40),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J, 40),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J, 41),J=1,3) /  3,  2,  1 /
      DATA (NTMS(J, 41),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J, 42),J=1,3) /  3,  2,  1 /
      DATA (NTMS(J, 42),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 43),J=1,3) /  3,  2,  1 /
      DATA (NTMS(J, 43),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J, 44),J=1,3) /  3,  2,  1 /
      DATA (NTMS(J, 44),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J, 45),J=1,3) /  1,  3,  2 /
      DATA (NTMS(J, 45),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J, 46),J=1,3) /  1,  3,  2 /
      DATA (NTMS(J, 46),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 47),J=1,3) /  1,  3,  2 /
      DATA (NTMS(J, 47),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J, 48),J=1,3) /  1,  3,  2 /
      DATA (NTMS(J, 48),J=1,3) / -1, -1,  1 /
      DATA QLGRP( 4),NLGRP(1, 4),NLGRP(2, 4) /'m-3         ', 24,  49 /
      DATA QLGRP( 5),NLGRP(1, 5),NLGRP(2, 5) /'m3          ', 24,  49 /
      DATA QLGRP( 6),NLGRP(1, 6),NLGRP(2, 6) /'m3bar       ', 24,  49 /
      DATA (NTMP(J, 49),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 49),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 50),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 50),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J, 51),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 51),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J, 52),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 52),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J, 53),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 53),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 54),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 54),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J, 55),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 55),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J, 56),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 56),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J, 57),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 57),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 58),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 58),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J, 59),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 59),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J, 60),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 60),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J, 61),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 61),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J, 62),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 62),J=1,3) /  1,  1, -1 /
      DATA (NTMP(J, 63),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 63),J=1,3) /  1, -1,  1 /
      DATA (NTMP(J, 64),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 64),J=1,3) / -1,  1,  1 /
      DATA (NTMP(J, 65),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 65),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J, 66),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 66),J=1,3) / -1,  1,  1 /
      DATA (NTMP(J, 67),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 67),J=1,3) /  1,  1, -1 /
      DATA (NTMP(J, 68),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 68),J=1,3) /  1, -1,  1 /
      DATA (NTMP(J, 69),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 69),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J, 70),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 70),J=1,3) /  1, -1,  1 /
      DATA (NTMP(J, 71),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 71),J=1,3) / -1,  1,  1 /
      DATA (NTMP(J, 72),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 72),J=1,3) /  1,  1, -1 /
      DATA QLGRP( 7),NLGRP(1, 7),NLGRP(2, 7) /'23          ', 12,  73 /
      DATA (NTMP(J, 73),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 73),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 74),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 74),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J, 75),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 75),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J, 76),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 76),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J, 77),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 77),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 78),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 78),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J, 79),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 79),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J, 80),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 80),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J, 81),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 81),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 82),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 82),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J, 83),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 83),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J, 84),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 84),J=1,3) / -1, -1,  1 /
      DATA QLGRP( 8),NLGRP(1, 8),NLGRP(2, 8) /'-3mr        ', 12,  85 /
      DATA QLGRP( 9),NLGRP(1, 9),NLGRP(2, 9) /'3barmr      ', 12,  85 /
      DATA (NTMP(J, 85),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 85),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 86),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 86),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 87),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 87),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 88),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J, 88),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J, 89),J=1,3) /  1,  3,  2 /
      DATA (NTMS(J, 89),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J, 90),J=1,3) /  3,  2,  1 /
      DATA (NTMS(J, 90),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J, 91),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 91),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J, 92),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 92),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J, 93),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 93),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J, 94),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J, 94),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 95),J=1,3) /  1,  3,  2 /
      DATA (NTMS(J, 95),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 96),J=1,3) /  3,  2,  1 /
      DATA (NTMS(J, 96),J=1,3) /  1,  1,  1 /
      DATA QLGRP(10),NLGRP(1,10),NLGRP(2,10) /'-3r         ',  6,  97 /
      DATA QLGRP(11),NLGRP(1,11),NLGRP(2,11) /'3barr       ',  6,  97 /
      DATA (NTMP(J, 97),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J, 97),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 98),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J, 98),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J, 99),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J, 99),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J,100),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,100),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J,101),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J,101),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J,102),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J,102),J=1,3) / -1, -1, -1 /
      DATA QLGRP(12),NLGRP(1,12),NLGRP(2,12) /'3r          ',  3, 103 /
      DATA (NTMP(J,103),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,103),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J,104),J=1,3) /  3,  1,  2 /
      DATA (NTMS(J,104),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J,105),J=1,3) /  2,  3,  1 /
      DATA (NTMS(J,105),J=1,3) /  1,  1,  1 /
      DATA QLGRP(13),NLGRP(1,13),NLGRP(2,13) /'4/mmm       ', 16, 106 /
      DATA (NTMP(J,106),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,106),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J,107),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,107),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J,108),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J,108),J=1,3) / -1,  1,  1 /
      DATA (NTMP(J,109),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J,109),J=1,3) /  1, -1,  1 /
      DATA (NTMP(J,110),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,110),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J,111),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,111),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J,112),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J,112),J=1,3) /  1,  1, -1 /
      DATA (NTMP(J,113),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J,113),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J,114),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,114),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J,115),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,115),J=1,3) /  1,  1, -1 /
      DATA (NTMP(J,116),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J,116),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J,117),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J,117),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J,118),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,118),J=1,3) /  1, -1,  1 /
      DATA (NTMP(J,119),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,119),J=1,3) / -1,  1,  1 /
      DATA (NTMP(J,120),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J,120),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J,121),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J,121),J=1,3) /  1,  1,  1 /
      DATA QLGRP(14),NLGRP(1,14),NLGRP(2,14) /'4/m         ',  8, 122 /
      DATA (NTMP(J,122),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,122),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J,123),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,123),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J,124),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J,124),J=1,3) / -1,  1,  1 /
      DATA (NTMP(J,125),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J,125),J=1,3) /  1, -1,  1 /
      DATA (NTMP(J,126),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,126),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J,127),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,127),J=1,3) /  1,  1, -1 /
      DATA (NTMP(J,128),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J,128),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J,129),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J,129),J=1,3) / -1,  1, -1 /
      DATA QLGRP(15),NLGRP(1,15),NLGRP(2,15) /'4           ',  4, 130 /
      DATA (NTMP(J,130),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,130),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J,131),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,131),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J,132),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J,132),J=1,3) / -1,  1,  1 /
      DATA (NTMP(J,133),J=1,3) /  2,  1,  3 /
      DATA (NTMS(J,133),J=1,3) /  1, -1,  1 /
      DATA QLGRP(16),NLGRP(1,16),NLGRP(2,16) /'mmm         ',  8, 134 /
      DATA (NTMP(J,134),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,134),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J,135),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,135),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J,136),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,136),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J,137),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,137),J=1,3) /  1, -1, -1 /
      DATA (NTMP(J,138),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,138),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J,139),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,139),J=1,3) /  1,  1, -1 /
      DATA (NTMP(J,140),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,140),J=1,3) /  1, -1,  1 /
      DATA (NTMP(J,141),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,141),J=1,3) / -1,  1,  1 /
      DATA QLGRP(17),NLGRP(1,17),NLGRP(2,17) /'222         ',  4, 142 /
      DATA (NTMP(J,142),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,142),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J,143),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,143),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J,144),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,144),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J,145),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,145),J=1,3) /  1, -1, -1 /
      DATA QLGRP(18),NLGRP(1,18),NLGRP(2,18) /'2/m         ',  4, 146 /
      DATA (NTMP(J,146),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,146),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J,147),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,147),J=1,3) / -1,  1, -1 /
      DATA (NTMP(J,148),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,148),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J,149),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,149),J=1,3) /  1, -1,  1 /
      DATA QLGRP(19),NLGRP(1,19),NLGRP(2,19) /'2/mc        ',  4, 150 /
      DATA (NTMP(J,150),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,150),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J,151),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,151),J=1,3) / -1, -1,  1 /
      DATA (NTMP(J,152),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,152),J=1,3) / -1, -1, -1 /
      DATA (NTMP(J,153),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,153),J=1,3) /  1,  1, -1 /
      DATA QLGRP(20),NLGRP(1,20),NLGRP(2,20) /'2           ',  2, 154 /
      DATA (NTMP(J,154),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,154),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J,155),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,155),J=1,3) / -1,  1, -1 /
      DATA QLGRP(21),NLGRP(1,21),NLGRP(2,21) /'2c          ',  2, 156 /
      DATA (NTMP(J,156),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,156),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J,157),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,157),J=1,3) / -1, -1,  1 /
      DATA QLGRP(22),NLGRP(1,22),NLGRP(2,22) /'-1          ',  2, 158 /
      DATA QLGRP(23),NLGRP(1,23),NLGRP(2,23) /'1bar        ',  2, 158 /
      DATA (NTMP(J,158),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,158),J=1,3) /  1,  1,  1 /
      DATA (NTMP(J,159),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,159),J=1,3) / -1, -1, -1 /
      DATA QLGRP(24),NLGRP(1,24),NLGRP(2,24) /'1           ',  1, 160 /
      DATA (NTMP(J,160),J=1,3) /  1,  2,  3 /
      DATA (NTMS(J,160),J=1,3) /  1,  1,  1 /
C *
C *  HEXAGONAL AXES
      DATA QLGRH( 1),NLGRH(1, 1),NLGRH(2, 1) /'6/mmm       ', 24,   1 /
      DATA (NTMHP(J,  1),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J,  1),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J,  2),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J,  2),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J,  3),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J,  3),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J,  4),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J,  4),J=1,4) / -1, -1, -1,  1 /
      DATA (NTMHP(J,  5),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J,  5),J=1,4) / -1, -1, -1,  1 /
      DATA (NTMHP(J,  6),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J,  6),J=1,4) / -1, -1, -1,  1 /
      DATA (NTMHP(J,  7),J=1,4) /  2,  1,  3,  4 /
      DATA (NTMHS(J,  7),J=1,4) /  1,  1,  1, -1 /
      DATA (NTMHP(J,  8),J=1,4) /  1,  3,  2,  4 /
      DATA (NTMHS(J,  8),J=1,4) /  1,  1,  1, -1 /
      DATA (NTMHP(J,  9),J=1,4) /  3,  2,  1,  4 /
      DATA (NTMHS(J,  9),J=1,4) /  1,  1,  1, -1 /
      DATA (NTMHP(J, 10),J=1,4) /  2,  1,  3,  4 /
      DATA (NTMHS(J, 10),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 11),J=1,4) /  1,  3,  2,  4 /
      DATA (NTMHS(J, 11),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 12),J=1,4) /  3,  2,  1,  4 /
      DATA (NTMHS(J, 12),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 13),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J, 13),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 14),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J, 14),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 15),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J, 15),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 16),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J, 16),J=1,4) /  1,  1,  1, -1 /
      DATA (NTMHP(J, 17),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J, 17),J=1,4) /  1,  1,  1, -1 /
      DATA (NTMHP(J, 18),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J, 18),J=1,4) /  1,  1,  1, -1 /
      DATA (NTMHP(J, 19),J=1,4) /  2,  1,  3,  4 /
      DATA (NTMHS(J, 19),J=1,4) / -1, -1, -1,  1 /
      DATA (NTMHP(J, 20),J=1,4) /  1,  3,  2,  4 /
      DATA (NTMHS(J, 20),J=1,4) / -1, -1, -1,  1 /
      DATA (NTMHP(J, 21),J=1,4) /  3,  2,  1,  4 /
      DATA (NTMHS(J, 21),J=1,4) / -1, -1, -1,  1 /
      DATA (NTMHP(J, 22),J=1,4) /  2,  1,  3,  4 /
      DATA (NTMHS(J, 22),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 23),J=1,4) /  1,  3,  2,  4 /
      DATA (NTMHS(J, 23),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 24),J=1,4) /  3,  2,  1,  4 /
      DATA (NTMHS(J, 24),J=1,4) /  1,  1,  1,  1 /
      DATA QLGRH( 2),NLGRH(1, 2),NLGRH(2, 2) /'6/m         ', 12,  25 /
      DATA (NTMHP(J, 25),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J, 25),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 26),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J, 26),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 27),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J, 27),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 28),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J, 28),J=1,4) / -1, -1, -1,  1 /
      DATA (NTMHP(J, 29),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J, 29),J=1,4) / -1, -1, -1,  1 /
      DATA (NTMHP(J, 30),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J, 30),J=1,4) / -1, -1, -1,  1 /
      DATA (NTMHP(J, 31),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J, 31),J=1,4) /  1,  1,  1, -1 /
      DATA (NTMHP(J, 32),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J, 32),J=1,4) /  1,  1,  1, -1 /
      DATA (NTMHP(J, 33),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J, 33),J=1,4) /  1,  1,  1, -1 /
      DATA (NTMHP(J, 34),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J, 34),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 35),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J, 35),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 36),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J, 36),J=1,4) / -1, -1, -1, -1 /
      DATA QLGRH( 3),NLGRH(1, 3),NLGRH(2, 3) /'6           ',  6,  37 /
      DATA (NTMHP(J, 37),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J, 37),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 38),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J, 38),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 39),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J, 39),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 40),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J, 40),J=1,4) / -1, -1, -1,  1 /
      DATA (NTMHP(J, 41),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J, 41),J=1,4) / -1, -1, -1,  1 /
      DATA (NTMHP(J, 42),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J, 42),J=1,4) / -1, -1, -1,  1 /
      DATA QLGRH( 4),NLGRH(1, 4),NLGRH(2, 4) /'-3m1        ', 12,  43 /
      DATA QLGRH( 5),NLGRH(1, 5),NLGRH(2, 5) /'3barm1      ', 12,  43 /
      DATA (NTMHP(J, 43),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J, 43),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 44),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J, 44),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 45),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J, 45),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 46),J=1,4) /  2,  1,  3,  4 /
      DATA (NTMHS(J, 46),J=1,4) /  1,  1,  1, -1 /
      DATA (NTMHP(J, 47),J=1,4) /  1,  3,  2,  4 /
      DATA (NTMHS(J, 47),J=1,4) /  1,  1,  1, -1 /
      DATA (NTMHP(J, 48),J=1,4) /  3,  2,  1,  4 /
      DATA (NTMHS(J, 48),J=1,4) /  1,  1,  1, -1 /
      DATA (NTMHP(J, 49),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J, 49),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 50),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J, 50),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 51),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J, 51),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 52),J=1,4) /  2,  1,  3,  4 /
      DATA (NTMHS(J, 52),J=1,4) / -1, -1, -1,  1 /
      DATA (NTMHP(J, 53),J=1,4) /  1,  3,  2,  4 /
      DATA (NTMHS(J, 53),J=1,4) / -1, -1, -1,  1 /
      DATA (NTMHP(J, 54),J=1,4) /  3,  2,  1,  4 /
      DATA (NTMHS(J, 54),J=1,4) / -1, -1, -1,  1 /
      DATA QLGRH( 6),NLGRH(1, 6),NLGRH(2, 6) /'-31m        ', 12,  55 /
      DATA QLGRH( 7),NLGRH(1, 7),NLGRH(2, 7) /'3bar1m      ', 12,  55 /
      DATA (NTMHP(J, 55),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J, 55),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 56),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J, 56),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 57),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J, 57),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 58),J=1,4) /  2,  1,  3,  4 /
      DATA (NTMHS(J, 58),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 59),J=1,4) /  1,  3,  2,  4 /
      DATA (NTMHS(J, 59),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 60),J=1,4) /  3,  2,  1,  4 /
      DATA (NTMHS(J, 60),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 61),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J, 61),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 62),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J, 62),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 63),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J, 63),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 64),J=1,4) /  2,  1,  3,  4 /
      DATA (NTMHS(J, 64),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 65),J=1,4) /  1,  3,  2,  4 /
      DATA (NTMHS(J, 65),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 66),J=1,4) /  3,  2,  1,  4 /
      DATA (NTMHS(J, 66),J=1,4) /  1,  1,  1,  1 /
      DATA QLGRH( 8),NLGRH(1, 8),NLGRH(2, 8) /'-3          ',  6,  67 /
      DATA QLGRH( 9),NLGRH(1, 9),NLGRH(2, 9) /'3bar        ',  6,  67 /
      DATA (NTMHP(J, 67),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J, 67),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 68),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J, 68),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 69),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J, 69),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 70),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J, 70),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 71),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J, 71),J=1,4) / -1, -1, -1, -1 /
      DATA (NTMHP(J, 72),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J, 72),J=1,4) / -1, -1, -1, -1 /
      DATA QLGRH(10),NLGRH(1,10),NLGRH(2,10) /'3           ',  3,  73 /
      DATA (NTMHP(J, 73),J=1,4) /  1,  2,  3,  4 /
      DATA (NTMHS(J, 73),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 74),J=1,4) /  3,  1,  2,  4 /
      DATA (NTMHS(J, 74),J=1,4) /  1,  1,  1,  1 /
      DATA (NTMHP(J, 75),J=1,4) /  2,  3,  1,  4 /
      DATA (NTMHS(J, 75),J=1,4) /  1,  1,  1,  1 /
C *
C *  COPY THE ORIGINAL LAUE GROUP.  CHECK FOR C-AXIS UNIQUE MONOCLINIC
C *
1000  QGRPC = '            '
      NEXT = 0
      DO 1010 I=1,8
      IF(QGRP(I:I).EQ.' ') GO TO 1010
      NEXT = NEXT + 1
      IF( LGE(QGRP(I:I),'A') .AND. LLE(QGRP(I:I),'Z') ) THEN
        QGRPC(NEXT:NEXT) = CHAR( ICHAR(QGRP(I:I))-ICHAR('A')+ICHAR('a'))
       ELSE
        QGRPC(NEXT:NEXT) = QGRP(I:I)
      ENDIF
1010  CONTINUE
C *
C *  RIETVELD PROGRAM C-UNIQUE MONOCLINIC SETTING
      IF( QGRPC.EQ.'2/m     ' .AND. NORAXS.EQ.3 ) QGRPC = '2/mc        '
      IF( QGRPC.EQ.'2       ' .AND. NORAXS.EQ.3 ) QGRPC = '2c          '
C *
C *  SEARCH LAUE GROUP OPERATOR LIST
C *
1100  DO 1110 I=1,24
      IF(QGRPC.EQ.QLGRP(I)) THEN
        NN = I
        GO TO 2100
      ENDIF
1110  CONTINUE
C *
      DO 1120 I=1,10
      IF(QGRPC.EQ.QLGRH(I)) THEN
        NN = I
        GO TO 2200
      ENDIF
1120  CONTINUE
C *
C *  GROUP NOT FOUND
      NHKL = 0
      GO TO 9000
C *
C *  NON-HEXGONAL SYSTEM
C *
2100  NOPS = NLGRP(1,NN)
      NSTR = NLGRP(2,NN)
C *
C *  INITIALIZE NUMBER OF HKL VALUES RETURNED
      NHKL = 1
      IVO(1,1) = IVI(1)
      IVO(2,1) = IVI(2)
      IVO(3,1) = IVI(3)
C *
      DO 2110 J=NSTR,NSTR+NOPS-1
      IH = NTMS(1,J) * IVO( NTMP(1,J), 1 )
      IK = NTMS(2,J) * IVO( NTMP(2,J), 1 )
      IL = NTMS(3,J) * IVO( NTMP(3,J), 1 )
      DO 2120 K=1,NHKL
      IF(IH.EQ.IVO(1,K).AND.IK.EQ.IVO(2,K).AND.IL.EQ.IVO(3,K)) GOTO 2110
2120  CONTINUE
      NHKL = NHKL + 1
      IVO(1,NHKL) = IH
      IVO(2,NHKL) = IK
      IVO(3,NHKL) = IL
2110  CONTINUE
      GO TO 9000
C *
C *  HEXGONAL SYSTEM
2200  NOPS = NLGRH(1,NN)
      NSTR = NLGRH(2,NN)
C *
C *  INITIALIZE NUMBER OF HKL VALUES RETURNED
      NHKL = 1
      IVH(1,1) = IVI(1)
      IVH(2,1) = IVI(2)
      IVH(3,1) = -( IVI(1) + IVI(2) )
      IVH(4,1) = IVI(3)
C *
      DO 2210 J=NSTR,NSTR+NOPS-1
      IH = NTMHS(1,J) * IVH( NTMHP(1,J), 1 )
      IK = NTMHS(2,J) * IVH( NTMHP(2,J), 1 )
      II = NTMHS(3,J) * IVH( NTMHP(3,J), 1 )
      IL = NTMHS(4,J) * IVH( NTMHP(4,J), 1 )
      DO 2220 K=1,NHKL
      IF( IH.EQ.IVH(1,K) .AND. IK.EQ.IVH(2,K) .AND.
     1    II.EQ.IVH(3,K) .AND. IL.EQ.IVH(4,K)       ) GO TO 2210
2220  CONTINUE
      NHKL = NHKL + 1
      IVH(1,NHKL) = IH
      IVH(2,NHKL) = IK
      IVH(3,NHKL) = II
      IVH(4,NHKL) = IL
2210  CONTINUE
C *
C *  COPY TO RETURN ARRAY
      DO 2230 I=1,NHKL
      IVO(1,I) = IVH(1,I)
      IVO(2,I) = IVH(2,I)
      IVO(3,I) = IVH(4,I)
2230  CONTINUE
C *
C *  JOB COMPLETE
9000  RETURN
      END
C---  CALCULATION OF PREFERRED ORIENTATION CORRECTION AND DERIVATIVES
C-
      SUBROUTINE PRFCRF( IMODE, HKL, PRECOR, DERIV )
C-
      INCLUDE 'RIETCOM.FOR'
      DIMENSION AL(3,3),HKL(3),IVI(3),IVO(3,48),POCSUM(2),DERSUM(2)
      DIMENSION DERIV(MMATX)
C-
C-  CHECK PREFERRED ORIENTATION CORRECTION FLAG FOR PHASE
1000  PRECOR = 1.0
      IF( KPOCTY(1,IPHASE).LT.1 .OR. KPOCTY(1,IPHASE).GT.2 ) GO TO 9000
      IF( HKL(1).EQ.0.0.AND.HKL(2).EQ.0.0.AND.HKL(3).EQ.0.0 ) GO TO 9000
C-
C-  MODIFIED RECIPROCAL CELL CONSTANTS (MOD. RECIP. METRIC TENSOR)
      AL(1,1) = PPHLAT(1,IPHASE)
      AL(2,2) = PPHLAT(2,IPHASE)
      AL(3,3) = PPHLAT(3,IPHASE)
      AL(3,2) = PPHLAT(4,IPHASE)
      AL(3,1) = PPHLAT(5,IPHASE)
      AL(2,1) = PPHLAT(6,IPHASE)
      AL(1,2) = 0.0
      AL(1,3) = 0.0
      AL(2,3) = 0.0
C-
C-  CALCULATION OF DSTAR**2
      SS = 0.0
      DO 1010 I=1,3
      DO 1010 J=I,3
1010  SS = SS + AL(J,I) * HKL(I) * HKL(J)
C-
C-  DETERMINE SET OF SYMMETRY EQUIVALENT REFLECTIONS FOR REFLECTION
C-
CDBG  WRITE(99,'(/,'' HKL =  '',3F4.0)') HKL
1100  IVI(1) = NINT( HKL(1) )
      IVI(2) = NINT( HKL(2) )
      IVI(3) = NINT( HKL(3) )
      IVO(1,1) = IVI(1)
      IVO(2,1) = IVI(2)
      IVO(3,1) = IVI(3)
      IF(KINDRF(IPHASE).EQ.1) THEN
        NHKL = 1
       ELSE IF(KINDRF(IPHASE).EQ.2) THEN
        NHKL = 2
        IVO(1,2) = -IVI(1)
        IVO(2,2) = -IVI(2)
        IVO(3,2) = -IVI(3)
       ELSE
        CALL GNLARE( QLAUGR(IPHASE), IVI, IVO, NHKL )
      ENDIF
      FHKL = REAL( NHKL )
CDBG  Write(99,'(3i3,2x,3i3,2x,3i3,2x,3i3)')((ivo(j,i),j=1,3),i=1,NHKL)
C-
C-  REPEAT FOR EACH OF THE SYMMETRY EQUIVALENT REFLECTIONS
C-
C-  REPEAT FOR BOTH ORIENTATION VECTORS
2000  DO 2002 IVEC=1,2
C-
C-  INITIALIZE CONTRIBUTIONS FROM ORIENTATION VECTOR
      POCSUM(IVEC) = 0.0
C-
C-  INITIALIZE DERIVATIVES FOR PARAMETERS
      DERSUM(IVEC) = 0.0
C-
C-  IF THE SECOND VECTOR IS NOT USED THEN SKIP IT
      IF( IVEC.EQ.2 .AND. KPOCTY(2,IPHASE).EQ.0 ) GO TO 2002
C-
C-  REPEAT FOR EACH SYMMETRY RELATED REFLECTION
      DO 2010 K=1,NHKL
C-
C-  CHECK FOR PPOVEC OF 0,0,0... SET ANGLE TO ZERO AND SKIP SYMM. EQV. REFS.
      IF( PPOVEC(1,IVEC,IPHASE).EQ.0.0 .AND.
     1    PPOVEC(2,IVEC,IPHASE).EQ.0.0 .AND.
     1    PPOVEC(3,IVEC,IPHASE).EQ.0.0       ) THEN
        POANGS = 0.0
        GO TO 2190
      ENDIF
C-
C-  LOOK FOR LOWEST ANGLE MADE WITH RELATED PREFERRED ORIENTATION DIRECTIONS
2100  POANGS = 999.0
      DO 2110 L=1,KPOSNM(IVEC,IPHASE)
      TT = 0.0
      DO 2120 I=1,3
      DO 2120 J=I,3
2120  TT = TT + AL(J,I)*PPOSED(I,L,IVEC,IPHASE)*PPOSED(J,L,IVEC,IPHASE)
      POANG = 0.0
      DO 2130 I=1,3
      DO 2130 J=I,3
      POANG = POANG + AL(J,I) *
     1 (   PPOSED(I,L,IVEC,IPHASE)*REAL(IVO(J,K))
     1   + PPOSED(J,L,IVEC,IPHASE)*REAL(IVO(I,K)) ) / 2.0
2130  CONTINUE
      POANG = POANG * POANG / ( TT * SS )
      IF(POANG.EQ.0.0) THEN
        POANG = 1.57079633268
       ELSE
        POANG = ATAN( SQRT( ABS((1.0-POANG)/POANG) ) )
      ENDIF
      IF(POANG.LT.POANGS) POANGS = POANG
CDBG  WRITE(99,'('' PO VEC, POANG,POANGS = '',3F4.0,2F9.4)')
CDBG 1 (PPOSED(J,L,IVEC,IPHASE),J=1,3),57.29*POANG,57.29*POANGS
2110  CONTINUE
C-
C-  CALCULATION OF THE PREFERRED ORIENTATION CORRECTION
C-
2190  GO TO (2200,2300), KPOCTY(1,IPHASE)
C-
C-  RIETVELD CORRECTION FACTOR
C-
C-  CALCULATION OF CORRECTION FACTOR
2200  PRECOR  = EXP( PPOPAR(1,IVEC,IPHASE) * POANGS**2 )
      POCSUM(IVEC) = POCSUM(IVEC) + PRECOR
CDBG  WRITE(99,'('' HKL, COR = '',3I3,2F10.4)') (IVO(L,K),L=1,3),PRECOR
C-
C-  CALCULATION OF DERIVATIVE
      IF(IMODE.NE.2) GO TO 2010
      KP = LPOPAR(1,IVEC,IPHASE)
      IF(KP.GT.0) THEN
        DERSUM(IVEC) = DERSUM(IVEC) + POANGS**2 * PRECOR
      ENDIF
C-
      GO TO 2010
C-
C-  MARCH FUNCTION CORRECTION FACTOR
C-
C-  CALCULATION OF CORRECTION FACTOR
2300  CALPH2 = COS(POANGS)**2
      SALPH2 = SIN(POANGS)**2
      TERM =PPOPAR(1,IVEC,IPHASE)**2*CALPH2+SALPH2/PPOPAR(1,IVEC,IPHASE)
      PRECOR = TERM**(-3.0/2.0)
      POCSUM(IVEC) = POCSUM(IVEC) + PRECOR
CDBG  WRITE(99,'('' HKL, MCOR = '',3I3,2F10.4)') (IVO(L,K),L=1,3),PRECOR
C-
C-  CALCULATION OF DERIVATIVES
      IF(IMODE.NE.2) GO TO 2010
      KP = LPOPAR(1,IVEC,IPHASE)
      IF(KP.GT.0) THEN
        DERSUM(IVEC) = DERSUM(IVEC) +
     1  (-3.0/2.0)*TERM**(-5.0/2.0) *
     1 ( 2.0*PPOPAR(1,IVEC,IPHASE)*CALPH2 -
     1   SALPH2/PPOPAR(1,IVEC,IPHASE)**2     )
      ENDIF
C-
C-  NEXT SYMMETRY EQUIVALENT REFLECTION
2010  CONTINUE
C-
C-  NEXT PREFERRED ORIENTATION VECTOR
2002  CONTINUE
C-
C-  PREFERRED ORIENTATION CORRECTION FACTOR...
C-   CORRECTED FOR LINE MULTIPLICITY
C-
3000  PRECOR = (1.0-PPOPAR(2,1,IPHASE)) * POCSUM(1)/FHKL +
     1              PPOPAR(2,1,IPHASE)  * POCSUM(2)/FHKL
CDBG  WRITE(99,'('' PS1,PS2,P = '',3F8.4)') POCSUM,PRECOR
C-
C-  CALCULATION OF DERIVATIVES
C-
      IF(IMODE.NE.2) GO TO 9000
C-
C-  FACTORS SCALING DERIVATIVES TO INTENSITIES
      OMEGA = F2TOT(IORDC) / PRECOR
C-
C-  FINAL DERIVATIVES FOR ORIENTATION PARAMETERS
      K = LPOPAR(1,1,IPHASE)
      IF(K.GT.0) THEN
        DERIV(K) = DERIV(K) + OMEGA *
     1  (1.0-PPOPAR(2,1,IPHASE)) * APOPAR(1,1,IPHASE) * DERSUM(1) / FHKL
      ENDIF
      K = LPOPAR(1,2,IPHASE)
      IF(K.GT.0) THEN
        DERIV(K) = DERIV(K) + OMEGA *
     1  (    PPOPAR(2,1,IPHASE)) * APOPAR(1,2,IPHASE) * DERSUM(2) / FHKL
      ENDIF
C-
C-  CALCULATION OF DERIVATIVE FOR MIXING
      K = LPOPAR(2,1,IPHASE)
      IF(K.GT.0) THEN
        DERIV(K) = DERIV(K) + OMEGA *
     1  APOPAR(2,1,IPHASE) * ( POCSUM(2) - POCSUM(1) ) / FHKL
      ENDIF
C-
C-  JOB COMPLETE
9000  RETURN
      END
C---  CALCULATION OF ABSORPTION CORRECTION AND DERIVATIVES
C-
      SUBROUTINE ABSCRF( IMODE, TTHT, ABSCOR, DERIV )
C-
      INCLUDE 'RIETCOM.FOR'
      DIMENSION DERIV(MMATX)
C-
C-  CALCULATION OF CORRECTION FACTOR
C-
      IF(PPHABS(IPHASE).GT.0.0) THEN
        SINANG = SIN( TTHT * DTORD2 )
        TERM = EXP( -2.0 * PPHABS(IPHASE) / SINANG )
        ABSCOR = 1.0 - TERM
       ELSE
        ABSCOR = 1.0
      ENDIF
C-
C-  CALCULATION OF DERIVATIVE
C-
      IF(IMODE.NE.2) GO TO 9000
C-
C-  FACTORS SCALING DERIVATIVE TO INTENSITY
      OMEGA = F2TOT(IORDC) / ABSCOR
C-
      K = LPHABS(IPHASE)
      IF(K.GT.0) THEN
        DERIV(K) = DERIV(K) + OMEGA *
     1  APHABS(IPHASE) * ( 2.0 / SINANG ) * TERM
CDBG    WRITE(99,'('' ANG,TERM, DER = '',3F10.4)') PREFTT(IORDC),TERM,
CDBG 1   APHABS(IPHASE)*F2TOT(IORDC) * ( 2.0 / SINANG ) * TERM
      ENDIF
C-
C-  JOB COMPLETE
9000  RETURN
      END
C---  PROGRAM: RIETVELD  (RIET10)
C---  VERSION: 890911  (YYMMDD)
C---
      SUBROUTINE INPTR
C-
      INCLUDE 'RIETCOM.FOR'
      CHARACTER QDATE*9,QTIME*8,QSWTCH(-1:1)*4,QSPG(20)*1
      CHARACTER QATMPF*10,QMAGSF*10,QLLGRP*8,QPSF(3)*21
      DIMENSION XRYZ(5),MLTT(MREFS)
      DIMENSION IMATX(0:MMATX)
      DIMENSION CELDIR(6),CELREC(3,3)
      COMMON XDEL(26),IDEL(26),HKL(3),IVI(3),IVO(3,48)
      EQUIVALENCE ( MLTT, F2TOT )
      DATA XRYZ(1), XRYZ(2), XRYZ(3), XRYZ(4), XRYZ(5)
     1   / 2.28962, 1.93597, 1.54060, 0.70926, 0.556363 /
      DATA QSWTCH(-1),QSWTCH(0),QSWTCH(1) /'On  ','Off ','On  '/
      DATA QPSF(1) /'Gaussian             '/
      DATA QPSF(2) /'Pseudo-Voigt         '/
      DATA QPSF(3) /'Pearson VII          '/
C-
C--  SAY HELLO
C-
1000  CALL DATE( QDATE )
      CALL TIME( QTIME )
      WRITE(IOTTO,1005) ' ',IVER,QDATE,QTIME(1:5)
1005  FORMAT(A1,
     1'*** RIETVELD analysis program',10X,'V ',I6,9X,'Run ',A9,2X,A5)
C-
C--  INITIALIZE PARAMETERS
C-
      DO 1010 I=0,MMATX
1010  IMATX(I) = 0
      IOV = 0
      DO 1020 ITMP=1,MPHAS
1020  KREFNM(ITMP) = 0
      NSCTOT = 0
C-
C--  GET INPUT/OUTPUT FILE NAMES AND OPEN THEM NOW
C-
      CALL SETIO
C-
C--  SAY HELLO AGAIN- THIS TIME FOR THE RECORD
C-
2000  WRITE(IOTTO,1005) '1',IVER,QDATE,QTIME(1:5)
C-
C-  GIVE PROGRAM LIMITATIONS  ------------------------------------------
C-
      WRITE(IOTTO,2072) MREFS,MATMS,MMATX,MNPTS,MOVRL,MPHAS
2072  FORMAT(/,' Program limitations:',/,
     1     '  Total number of reflections   ',I5,
     1 T41,' Total number of atoms         ',I5,
     1 T82,' Number of variable parameters ',I5,/,
     1     '  Points in observed pattern    ',I5,
     1 T41,' Overlapping reflections       ',I5,
     1 T82,' Number of phases              ',I5)
C-
C--  READ AND ECHO CONTROL FLAGS  --------------------------------------
C-
C--  READ THE PROBLEM TITLE AND DESCRIPTIVE INFORMATION
C-
      READ(IODCF,2010) QTITLE
2010  FORMAT(A80)
      WRITE(IOTTO,2080) QTITLE(1:77)
2080  FORMAT(/,' Problem ID:',/,2X,A77)
C-
      READ(IODCF,2020) JOBXN,NPHASE,NBCKGD,NEXCRG,NSCAT,KINTSF,KAMOR,
     1                 KWSGON
2020  FORMAT(8I4)
C-
      IF(JOBXN.EQ.1) THEN
        WRITE(IOTTO,2040)
2040    FORMAT(2X,'Refinement of X-Ray data')
       ELSE IF(JOBXN.EQ.2) THEN
        WRITE(IOTTO,2050)
2050    FORMAT(2X,'Refinement of neutron data, nuclear intensities')
       ELSE IF(JOBXN.EQ.3) THEN
        WRITE(IOTTO,2060)
2060    FORMAT(2X,' Pattern calculation, X-Ray')
       ELSE IF(JOBXN.EQ.4) THEN
        WRITE(IOTTO,2070)
2070    FORMAT(2X,' Pattern calculation, Neutron')
       ELSE
        STOP '--INPTR: UNKNOWN JOB TYPE SPECIFIED'
      ENDIF
C-
      WRITE(IOTTO,2090) NPHASE,NEXCRG,NSCAT
2090  FORMAT(/,' Parameters for current refinement:',/,
     1     '  Number of phases in specimen  ',I5,
     1 T41,' Number of excluded regions    ',I5,
     1 T82,' Number of scattering sets     ',I5)
      IF(NPHASE.GT.MPHAS) THEN
        WRITE(IOTTO,2092)
2092    FORMAT(/,
     1' --THE NUMBER OF PHASES TO BE INPUT EXCEEDS THE CAPABILITY OF ',
     1'THIS PROGRAM.',/,
     1'   INCREASE THE VALUE OF *MPHAS* IN ALL PARAMETER STATEMENTS TO',
     1' SUIT YOUR NEEDS.')
        STOP '--INPTR: NUMBER OF INPUT PHASES EXCEEDS PROGRAM STORAGE'
      ENDIF
      IF(NPHASE.LT.0) STOP '--INPTR: NUMBER OF PHASES MUST BE > 0'
C-
      IF(NBCKGD.LT.1) THEN
        NBCKGD = 0
        WRITE(IOTTO,2100)
2100    FORMAT(/,' Background to be refined')
       ELSE IF(NBCKGD.EQ.1) THEN
        WRITE(IOTTO,2110)
2110    FORMAT(/,' Background data to be read from file')
       ELSE
        WRITE(IOTTO,2120)
2120    FORMAT(/,' Background correction by interpolation ',
     1  'between supplied data points')
      ENDIF
C-
      IF(KAMOR.EQ.1) THEN
        WRITE(IOTTO,2122)
2122    FORMAT(/,
     1  ' A Gaussian profile will be used to fit an amorphous line')
       ELSE
        KAMOR = 0
      ENDIF
C-
      IF(KWSGON.EQ.1) WRITE(IOTTO,2140)
2140  FORMAT(/,' A convolution based PSF will be used.')
C-
C--  READ AND PRINT OUTPUT FLAGS
C-
2200  READ(IODCF,2210) KOFILS,KOFPLL,KOFSFL,KOFMAT,KOFNCF,KOFRLI,
     1                 KOFCIL,KOFRLM,KOFSGO,KOFPLF,KCLRCW,KCONCW
2210  FORMAT(13I4)
      IF(KOFILS.NE.0) KOFILS = 1
      IF(KOFPLL.NE.0) KOFPLL = 1
      IF(KOFSFL.NE.0) KOFSFL = 1
      IF(KOFMAT.NE.0) KOFMAT = 1
      IF(KOFNCF.NE.0) KOFNCF = 1
      IF(KOFRLI.NE.0) KOFRLI = 1
      IF(KOFCIL.NE.0) KOFCIL = 1
      IF(KOFRLM.NE.0) KOFRLM = 1
      IF(KOFSGO.NE.0) KOFSGO = 1
      IF(KOFPLF.NE.0) KOFPLF = 1
      IF(KCLRCW.NE.0) KCLRCW = 1
      IF(KCONCW.NE.0) KCONCW = 1
      IF(JOBXN .GT.2) THEN
        KOFMAT = 0
        KCLRCW = 0
      ENDIF
      IF(NPHASE  .EQ.1) KOFRLM   = 0
      WRITE(IOTTO,2220) QSWTCH(KOFILS),QSWTCH(KOFPLL),QSWTCH(KOFSFL)
2220  FORMAT(/,' Program flag settings:',/,
     1         '  Output intensities on last cycle ',A4,
     1     T41,' Generate line printer plot       ',A4,
     1     T82,' Output structure factors         ',A4)
      WRITE(IOTTO,2230) QSWTCH(KOFMAT),QSWTCH(KOFNCF),QSWTCH(KOFRLI)
2230  FORMAT(
     1         '  Output correlation matrix        ',A4,
     1     T41,' Write new input file             ',A4,
     1     T82,' Print reflection list for phases ',A4)
      WRITE(IOTTO,2240) QSWTCH(KOFCIL),QSWTCH(KOFRLM),QSWTCH(KOFSGO)
2240  FORMAT(
     1         '  Print corrected data             ',A4,
     1     T41,' Print merged reflection list     ',A4,
     1     T82,' Print symmetry operators         ',A4)
      WRITE(IOTTO,2250) QSWTCH(KOFPLF),QSWTCH(KCLRCW),QSWTCH(KCONCW)
2250  FORMAT(
     1         '  Write data to plot file          ',A4,
     1     T41,' Clear unused code words          ',A4,
     1     T82,' Apply pre-selected constraints   ',A4)
C-
C-  READ AND PRINT AUTOPILOT FLAGS
C-
      READ(IODCF,2180) KAUTOV,KAUTOR
2180  FORMAT(20I4,/,20I4)
      DO 2182 I=1,20
2182  IF( KAUTOV(I).EQ.0 .OR. KAUTOR(I).EQ.0 ) GO TO 2184
      I = 21
2184  KAUTON = I - 1
      IF(KAUTON.EQ.0) STOP '--INPTR: NO AUTOPILOT DATA, ABORT'
      WRITE(IOTTO,2186) (I,KAUTOR(I),KAUTOV(I),I=1,KAUTON)
2186  FORMAT(/,' Autopilot refinement will follow:',/,
     1  (2X,'Round ',I2,':  Number of iterations ',I2,
     1  '  Number of variables ',I2))
      KMXVAR = KAUTOV(KAUTON)
      IF(KMXVAR.GT.MMATX) THEN
        WRITE(IOTTO,2922)
2922    FORMAT(/,
     1' --THE NUMBER OF VARIABLES EXCEEDS THE CAPABILITIES OF THIS ',
     1'PROGRAM.',/,
     1'   INCREASE THE VALUE OF *MMATX* ON ALL PARAMETER STATEMENTS TO',
     1' SUIT YOUR NEEDS.')
        STOP '--INPTR: NUMBER OF VARIABLES EXCEEDS PROGRAM STORAGE'
      ENDIF
C-
2400  READ(IODCF,2410) RADWAV,RADREL(2),WDTTHK,PMCCOR,THMIN,STEP,THMAX
2410  FORMAT(8F8.0)
      WRITE(IOTTO,2420) RADWAV,RADREL(2)
2420  FORMAT(/,' Wavelengths = ',2F10.6,'  Alpha2:Alpha1 ratio = ',F8.4)
      RADREL(1) = 1.0
      WRITE(IOTTO,2450) WDTTHK
2450  FORMAT(' Base of peak extends to = FWHM * ',F8.2)
      WRITE(IOTTO,2460) PMCCOR
2460  FORMAT(' Monochromator correction = ',F8.4)
C-
2500  READ(IODCF,2510) EPS,RELAX
2510  FORMAT(5F8.0)
      WRITE(IOTTO,2530) EPS
2530  FORMAT(/,
     1' Convergence achieved when parameter adjustmenst are <',F5.2,
     1' (EPS) * their ESDs')
      WRITE(IOTTO,2540) RELAX
2540  FORMAT(/,' Relaxation factors:',/,
     1         '  Atom xyz, iso temp and occup.   ',F5.2,2X,
     1         ' Atom anisotropic temp factor    ',F5.2,/,
     1         '  Phase related parameters        ',F5.2,2X,
     1         ' Global parameters               ',F5.2)
C-
C--  GET THE INSTRUMENT CALIBRATION DATA
C-
      CALL GETWSG
C-
C-  SET IXRAY TO REFLECT RADIATION WAVELENGTH
      DO 2430 IXRAY=1,5
2430  IF( (RADWAV(1)+0.1) .GT. XRYZ(IXRAY) ) GO TO 3100
      IXRAY = 5
C-
C--  CHECK INPUT/OUTPUT PATTERN PARAMETERS AND READ IF NECESSARY
C-
C-  READ THE INPUT PATTERN IF NECESSARY
3100  IF(JOBXN.LT.3) THEN
        CALL GETPAT
        GO TO 3002
      ENDIF
C-
C-  SET THE PARAMETERS FOR CALCULATED OUTPUT PATTERN
3200  IF(THMIN.EQ.0.0) THEN
        THMIN = 10.0
        WRITE(IOTTO,3210) THMIN
3210    FORMAT(2X,'2Theta minimum defaulting to ',F8.2,' degrees')
      ENDIF
      IF(THMAX.EQ.0.0) THEN
        THMAX = 90.0
        WRITE(IOTTO,3220) THMAX
3220    FORMAT(2X,'2Theta maximum defaulting to ',F8.2,' degrees')
      ENDIF
      IF(STEP.EQ.0.0) THEN
        STEP = 0.02
        WRITE(IOTTO,3230) STEP
3230    FORMAT(2X,'Angle increment defaulting to ',F8.2,' degrees')
      ENDIF
C-
C-  INSURE THAT OUTPUT PATTERN DOES NOT EXCEED STORAGE AREAS
      KPPTS = NINT( (THMAX-THMIN) / STEP ) + 1
      WRITE(IOTTO,3240) THMIN,STEP,THMAX,KPPTS
3240  FORMAT(/,' Calculated pattern: 2Theta Min ',F8.4,'  Step ',F7.4,
     1 '  Max ',F8.4,'  NPts ',I5)
      IF(KPPTS.GT.MNPTS) THEN
        WRITE(IOTTO,3250) MNPTS
3250    FORMAT('  -LIMITING POINTS IN PATTERN TO ',I5)
        KPPTS = MNPTS
        THMAX = THMIN + (MNPTS-1) * STEP
        WRITE(IOTTO,3240) THMIN,STEP,THMAX,KPPTS
      ENDIF
C-
C--  READ AND ECHO GLOBAL PARAMETERS  ----------------------------------
C-
3002  WRITE(IOTTO,3004)
3004  FORMAT(//,' * GLOBAL PARAMETERS AND CODEWORDS')
C-
C--  READ AND PRINT TWO-THETA ERROR CORRECTION PARAMETERS
C-
      READ(IODCF,3010) PGLB(1),PGLB(10),AGLB(1),AGLB(10)
3010  FORMAT(8X,2F8.0,/,8X,2F8.0)
      WRITE(IOTTO,3020) PGLB(1),AGLB(1),PGLB(10),AGLB(10)
3020  FORMAT(/,' * Two-theta error correction factors:',//,
     1  ' Zeropoint = ',F8.4,2X,F8.2,6X,'Specimen displacement = ',
     1  F8.4,2X,F8.2)
C-
C--  HANDLING OF BACKGROUND FOR THE PATTERN
C-
C-  READ LINEAR INTERPOLATION POINTS FOR BACKGROUND IF REQUIRED
2600  IF(NBCKGD.EQ.0) THEN
        READ(IODCF,3030) (PGLB(I),I=2,7),(AGLB(I),I=2,7)
3030    FORMAT(6G12.5)
        WRITE(IOTTO,3040) (PGLB(I),I=2,7),(AGLB(I),I=2,7)
3040    FORMAT(/,
     1  ' Polynomial background coefficients and codewords:',/,
     1  6X,'C0',11X,'C1',11X,'C2',11X,'C3',11X,'C4',11X,'C-1',/,
     1  1P,1X,6(1X,E12.5),/,0P,2X,6(1X,F8.2,4X))
       ELSE IF(NBCKGD.EQ.1) THEN
        OPEN(UNIT=IOBKG,FILE=QBKGFN,STATUS='OLD',ERR=2603)
        READ(IOBKG,2602) (YBKG(I),I=1,KPPTS)
2602    FORMAT(10F7.0)
        CLOSE(IOBKG)
        GO TO 2700
2603    STOP'--THE BACKGROUND DATA FILE WAS NOT FOUND'
       ELSE IF(NBCKGD.GT.1) THEN
        NTOGET = NBCKGD
        NBCKGD = 0
2604    READ(IODCF,2606) TEMP1,TEMP2
2606    FORMAT(2F8.0)
        IF(TEMP1.NE.-100.0) THEN
          IF(NBCKGD.EQ.30) THEN
            STOP'--Max of 30 background pts for interpolation allowed.'
          ENDIF
          NBCKGD = NBCKGD + 1
          PBKGTT(NBCKGD) = TEMP1
          PBKGIN(NBCKGD) = TEMP2
          IF(NBCKGD.EQ.NTOGET) GO TO 2607
          GO TO 2604
        ENDIF
2607    WRITE(IOTTO,2608) NBCKGD,(PBKGTT(I),PBKGIN(I),I=1,NBCKGD)
2608    FORMAT(/,
     1  1X,'The ',I2,' points for background interpolation:',//,
     1  3X,'Position',4X,'Intensity',/,
     1  (5X,F8.4,4X,F9.4))
      ENDIF
C-
C-  DETERMINE BACKGROUND BY INTERPOLATION
      IF(NBCKGD.LT.2) GO TO 2700
      DIFB = PBKGTT(1) - THMIN
      IF(DIFB) 2610,2620,2620
2620  NBX = DIFB / STEP + 2.5
      DO 2630 I=1,NBX
2630  YBKG(I) = PBKGIN(1)
      NXX = 1
      GO TO 2640
2610  NBX = (PBKGTT(2)-THMIN)/STEP + 1.5
      YBKG(1)=PBKGIN(1)-DIFB/(PBKGTT(2)-PBKGTT(1))*(PBKGIN(2)-PBKGIN(1))
      BSTEP = STEP / (PBKGTT(2)-PBKGTT(1)) * (PBKGIN(2)-PBKGIN(1))
      DO 2650 I=2,NBX
2650  YBKG(I) = YBKG(I-1) + BSTEP
      NXX = 2
2640  NBC = NBCKGD - 1
      IF(PBKGTT(NBCKGD).GE.THMAX) GO TO 2660
      PBKGTT(NBCKGD+1) = THMAX
      PBKGIN(NBCKGD+1) = PBKGIN(NBCKGD)
      NBC = NBC + 1
2660  DO 2670 J=NXX,NBC
      BSTEP = STEP * (PBKGIN(J+1)-PBKGIN(J)) / (PBKGTT(J+1)-PBKGTT(J))
      NINC = (PBKGTT(J+1)-PBKGTT(J))/STEP + 1.5
      N2X = MIN0( KPPTS, NBX+NINC )
      DO 2680 I=NBX,N2X
2680  YBKG(I) = YBKG(I-1) + BSTEP
      NBX = N2X
      IF(NBX.EQ.KPPTS) GO TO 2700
2670  CONTINUE
C-
C--  READ EXCLUDED REGIONS IN PATTERN
C-
2700  IF(NEXCRG.GT.0) THEN
        READ(IODCF,2606)  (PEXCLO(I),PEXCHI(I),I=1,NEXCRG)
        WRITE(IOTTO,2710) (PEXCLO(I),PEXCHI(I),I=1,NEXCRG)
2710    FORMAT(/,' Angular regions excluded from refinement:',/,
     1  (2X,'From ',F8.4,' to ',F8.4))
      ENDIF
C-
C--  READ SCATTERING SET ENTRIES
C-
2800  IF(NSCAT.LT.1) GO TO 2900
      IF( JOBXN.EQ.1 .OR. JOBXN.EQ.3 ) THEN
        WRITE(IOTTO,2802)
2802    FORMAT(/,' Form factors and analytical curve coefficients:')
       ELSE
        WRITE(IOTTO,2804)
2804    FORMAT(/,
     1  ' Scattering lengths and analytical curve coefficients:')
      ENDIF
C-
C-  REPEAT FOR INDICATED NUMBER OF SETS
      DO 2810 I=1,NSCAT
C-
      READ(IODCF,2820) QSCNAM(I),DFP(I),DFPP(I)
2820  FORMAT(A4,4X,2F8.0)
      IF( JOBXN.EQ.1 .OR. JOBXN.EQ.3 ) THEN
        WRITE(IOTTO,2892) QSCNAM(I),DFP(I),DFPP(I)
2892    FORMAT(/,3X,'Scatterer ',A4,':  DFP = ',F10.6,'  DFPP = ',F10.6)
       ELSE
        WRITE(IOTTO,2898) QSCNAM(I),DFP(I)
2898    FORMAT(/,3X,'Scatterer ',A4,':  Length = ',F10.6)
      ENDIF
      NSCOEF = 0
2830  READ(IODCF,2840) (SCATAC(J,I),J=1,9)
2840  FORMAT(9F8.0)
      SCATAC(10,I) = 0.0
C-
C-  IF END-OF-LIST INDICATED THEN ASSUME SCATTERING CURVES WERE ENTERED
C-    AND CALL COEF TO GENERATE THE INTERNAL CURVE SET
      IF(SCATAC(1,I).EQ.-100.0) THEN
        CALL COEF( I )
        DO 2850 J=1,NSCOEF
        TEMP = 0.0
        DO 2860 JJ=1,9,2
2860    TEMP = TEMP + SCATAC(JJ,I)*EXP( -SCATAC(JJ+1,I) * SINLAM(J)**2 )
        WRITE(IOTTO,2870) SINLAM(J),SCAT(J),TEMP
2870    FORMAT(
     1  5X,'Sinth/Lambda  ',F7.4,'  f = ',F7.4,'  f calc = ',F7.4)
2850    CONTINUE
        GO TO 2890
      ENDIF
C-
C-  IF THIRD COEFFICIENT IS 0.0 THEN ASSUME SCATTERING CURVE ENTERED
      IF(SCATAC(3,I).EQ.0.0) THEN
        NSCOEF = NSCOEF + 1
        SINLAM(NSCOEF) = SCATAC(1,I)
        SCAT(NSCOEF)   = SCATAC(2,I)
        IF(NSCOEF.LE.29) GO TO 2830
        STOP '--INPTR: TOO MANY SCATTERING CURVE ENTRIES'
      ENDIF
C-
2890  WRITE(IOTTO,2896) (SCATAC(J,I),J=1,9)
2896  FORMAT(5X,9F8.4)
C-
2810  CONTINUE
C-
C-  SET TOTAL NUMBER OF SCATTERING SETS TO THE NUMBER ENTERED
      NSCTOT = NSCAT
C-
C--  READ AND ECHO INTERNAL STANDARD DATA
C-
2900  IF(KINTSF.EQ.0) GO TO 3000
      READ(IODCF,2910) KINTSN,RINTSQ,KINTSA(1),RINTSA(1),
     1                 KINTSA(2),RINTSA(2),KINTSA(3),RINTSA(3)
2910  FORMAT(4(I8,F8.0))
C-
      IF(KINTSN.NE.0) THEN
        KINTSF = 1
        WRITE(IOTTO,2924) KINTSN,RINTSQ
2924    FORMAT(/,' Phase ',I2,' is an internal standard.  Weight',
     1  ' fraction ',F8.4)
        IF( KINTSN.LT.1 .OR. KINTSN.GT.NPHASE ) THEN
          WRITE(IOTTO,2926)
2926      FORMAT(' --INVALID PHASE:  NUMBER OUT OF RANGE.')
          KINTSF = 0
        ENDIF
      ENDIF
      IF(KINTSA(1).LT.0) THEN
        WRITE(IOTTO,2927) -KINTSA(1),RINTSA(1),-KINTSA(2),RINTSA(2),
     1  -KINTSA(3),RINTSA(3)
2927    FORMAT(/,
     1  ' Weight fraction data for scale factor corrections:',/,
     1  (2X,'Phase ',I2,': Weight fraction ',F8.4))
      ENDIF
      IF(KINTSA(1).GT.0) THEN
        WRITE(IOTTO,2928) KINTSA(1),RINTSA(1),KINTSA(2),RINTSA(2),
     1  KINTSA(3),RINTSA(3)
2928    FORMAT(/,' Data for scale factor corrections:',/,
     1  (2X,'Phase ',I2,': Correction factor ',F8.4))
      ENDIF
C-
C--  READ AND ECHO AMORPHOUS PROFILE PARAMETERS
C-
3000  IF(KAMOR.EQ.1) THEN
        READ(IODCF,3050) (PGLB(I),I=11,13), (AGLB(I),I=11,13)
3050    FORMAT(8X,3F8.0,/,8X,3F8.0)
        WRITE(IOTTO,3060) (PGLB(I),I=11,13), (AGLB(I),I=11,13)
3060    FORMAT(/,
     1  ' Amorphous line parameters: 2theta = ',F6.2,'  Peak hgt = ',
     1  F8.2,'  FWHM = ',F5.2,/,
     1  16X,'Code words:',10X,F6.2,13X,F8.2,8X,F6.2)
      ENDIF
C-
C--  READ AND ECHO PLOTTING PARAMETER CARDS
C-
C-  LINE PRINTER PLOTS
      IF(KOFPLL.EQ.1) THEN
        READ(IODCF,4854) (KLPPLT(I),I=1,2)
4810    WRITE(IOTTO,4812) (KLPPLT(I),I=1,2)
4812    FORMAT(/,
     1  ' *  Line printer plot parameters: ISCALE = ',I8,'  IDIF = ',I8)
      ENDIF
C-
C-  PLOT FILE PARAMETERS
4850  IF(KOFPLF.EQ.1) THEN
        READ(IODCF,4854) (KHCPLT(I),I=1,6)
4854    FORMAT(6I4)
4862    WRITE(IOTTO,4866) (KHCPLT(I),I=1,6)
4866    FORMAT(/,' Plot file output flags:',//,
     1  2X,'Observed pattern...',I2,3X,'Calculated pattern...',I2,
     1  3X,'Background.........',I2,/,
     1  2X,'Difference.........',I2,3X,'Reflection markers...',I2,
     1  3X,'Profile parameters.',I2)
      ENDIF
C-
C--  MATRIX POINTERS AND FRACTIONAL SHIFTS FOR GLOBAL PARAMETERS
C-
4700  DO 4710 I=1,13
      X = AGLB(I)
      CPYGLB(I) = X
      IYY = INT( ABS(X)/10.0 + 0.1 )
      IF(IYY.GT.KMXVAR) THEN
        IYY = 0
        X = 0.0
        IOV = IOV + 1
      ENDIF
      IF( KCLRCW.EQ.1 .AND. IYY.GT.KMXVAR ) THEN
        AGLB(I) = 0.0
        LGLB(I) = 0
        CPYGLB(I) = 0.0
       ELSE
        LGLB(I) = IYY
        AGLB(I) = ( ABS(X) - 10.0 * REAL(IYY) ) * SIGN(1.0,X)
        IMATX(IYY) = IMATX(IYY) + 1
      ENDIF
4710  CONTINUE
C-
C--  PHASE INFORMATION  ------------------------------------------------
C-
C-  REPEAT FOR EACH OF THE INPUT PHASES
3500  DO 3510 IPHASE=1,NPHASE
C-
C-  OFFSET INTO ATOM PARAMETER LISTS
      IOF = 0
      IF(IPHASE.GT.1) IOF = NATM(2,IPHASE-1) + NATM(1,IPHASE-1) - 1
C-
C-  READ AND ECHO PHASE HEADER INFORMATION
      READ(IODCF,3520) QPHSNM(IPHASE)
3520  FORMAT(A32)
      READ(IODCF,3560) (QSSYMB(I,IPHASE),I=1,20),QXTALS(IPHASE)
3560  FORMAT(20A1,A20)
      READ(IODCF,3530) NATM(1,IPHASE),KINDRF(IPHASE),KATMPF(IPHASE),
     1  KMAGSF(IPHASE)
3530  FORMAT(4I4)
      NATOM = NATM(1,IPHASE)
      NATM(2,IPHASE) = IOF + 1
      IF(KATMPF(IPHASE).EQ.0) THEN
        QATMPF = 'Beta      '
       ELSE
        QATMPF = 'Beta      '
      ENDIF
      IF(KATMPF(IPHASE).EQ.0) THEN
        QATMPF = 'Beta      '
       ELSE
        QATMPF = 'Beta      '
      ENDIF
      IF(KMAGSF(IPHASE).EQ.0) THEN
        QMAGSF = 'Inactive  '
       ELSE
        QMAGSF = 'Johnson   '
      ENDIF
      WRITE(IOTTO,3540) IPHASE,QPHSNM(IPHASE),NATOM,
     1                  (QSSYMB(I,IPHASE),I=1,20),QATMPF,
     1                  QXTALS(IPHASE),QMAGSF
3540  FORMAT(/,
     1 '1Phase ',I2,': ',A32,    T48,'Number of atoms: ',I3,/,
     1 2X,'Space group: ',20A1,  T48,'Aniso temp factors: ',A10,/,
     1 2X,'Crystal system: ',A20,T48,'Magnetic scattering: ',A10)
      IF(KINDRF(IPHASE).EQ.1) THEN
        WRITE(IOTTO,3550)
3550    FORMAT(/,1X,
     1  'Individual reflections: Not employing multiplicities.')
       ELSE IF(KINDRF(IPHASE).EQ.2) THEN
        WRITE(IOTTO,3552)
3552    FORMAT(/,1X,
     1  'Line multiplicities based on Friedel pairs.')
       ELSE
        WRITE(IOTTO,3554)
3554    FORMAT(/,1X,
     1  'Line multiplicities based on Laue symmetry.')
      ENDIF
C-
C-  GENERATE SPACE GROUP OPERATORS AND ASSOCIATED PARAMETERS
      DO 3570 I=1,20
3570  QSPG(I) = QSSYMB(I,IPHASE)
      CALL SPGP( QSPG )
C-
C--  READ AND ECHO ATOM PARAMETERS AND CODEWORDS
C-
C-  WRITE ATOM PARAMETER HEADER
3600  WRITE(IOTTO,3610)
3610  FORMAT(/,' *  ATOM PARAMETERS:',//,
     1 ' Label     Atom   Mag',
     1 11X,'X',7X,'Y',7X,'Z',7X,'B',7X,'N',/,
     1 ' Site symm. / Temp factors ',4X,
     1 'T11',5X,'T22',5X,'T33',5X,'T12',5X,'T13',5X,'T23')
C-
C-  REPEAT FOR EACH ATOM
      DO 3620 I=1,NATOM
      IPIOF = I + IOF
      IF(IPIOF.GT.MATMS) THEN
        WRITE(IOTTO,3622)
3622    FORMAT(/,
     1' --The number of atoms for this problem exceeds the alloted',
     1' storage space.',/,
     1'   Increase the value of *MATMS* in all parameter statements.',/)
        STOP '--INPTR:  NUMBER OF ATOMS EXCEEDS PROGRAM STORAGE'
      ENDIF
C-
C-  READ AND ECHO ATOM PARAMETERS AND CODEWORDS
      READ(IODCF,3630) QATLBL(IPIOF),QATTYP(IPIOF),KMAGSI(IPIOF),
     1 (PATOM(J,IPIOF),J=1,5),(AATOM(J,IPIOF),J=1,5)
3630  FORMAT(A8,A4,I4,8X,5F8.0,/,24X,5F8.0)
      WRITE(IOTTO,3632) QATLBL(IPIOF),QATTYP(IPIOF),KMAGSI(IPIOF),
     1 (PATOM(J,IPIOF),J=1,5),(AATOM(J,IPIOF),J=1,5)
3632  FORMAT(1X,A8,2X,A4,2X,I4,7X,5F8.5,/,28X,5F8.2)
      READ(IODCF,3634) QASPG(IPIOF),(PATOM(J,IPIOF),J=6,11),
     1 (AATOM(J,IPIOF),J=6,11)
3634  FORMAT(A20,4X,6F8.0,/,24X,6F8.0)
      WRITE(IOTTO,3636) QASPG(IPIOF),(PATOM(J,IPIOF),J=6,11),
     1 (PATOM(J,IPIOF),J=6,11)
3636  FORMAT(1X,A20,7X,6F8.5,/,28X,6F8.2)
      IF(KMAGSI(IPIOF).EQ.1) THEN
        READ(IODCF,3642) (PMAGVE(J,IPIOF),J=1,3),(CMAGVE(J,IPIOF),J=1,3)
3642    FORMAT(24X,3F8.0,/,24X,3F8.2)
        WRITE(IOTTO,3644)(PMAGVE(J,IPIOF),J=1,3),(CMAGVE(J,IPIOF),J=1,3)
3644    FORMAT(' Magnetic vector',12X,3F8.5,/,28X,3F8.2)
      ENDIF
C-
C-  CHECK ANISOTROPIC THERMAL PARAMETERS TO SEE IF THEY ARE USED
      KANISU(IPIOF) = 0
      DO 3650 J=6,11
3650  IF(PATOM(J,IPIOF).NE.0.0 ) KANISU(IPIOF) = 1
C-
C-  GENERATE MATRIX POINTERS AND FRACTIONAL SHIFTS FOR ATOM PARAMETERS
      DO 3950 J=1,11
      X = AATOM(J,IPIOF)
      CPYATM(J,IPIOF) = X
      IYY = INT( ABS(X)/10.0 + 0.1 )
      IF(IYY.GT.KMXVAR) THEN
        IYY = 0
        X = 0.0
        IOV = IOV + 1
      ENDIF
      IF( KCLRCW.EQ.1 .AND. IYY.GT.KMXVAR ) THEN
        AATOM(J,IPIOF) = 0.0
        LATOM(J,IPIOF) = 0
        CPYATM(J,IPIOF) = 0.0
       ELSE
        LATOM(J,IPIOF) = IYY
        AATOM(J,IPIOF) = ( ABS(X) - 10.0 * REAL(IYY) ) * SIGN(1.0,X)
        IMATX(IYY) = IMATX(IYY) + 1
      ENDIF
3950  CONTINUE
C-
C-  GENERATE MATRIX POINTERS AND FRACTIONAL SHIFTS FOR MAG PARAMETERS
      IF(KMAGSI(IPIOF).EQ.1) THEN
        DO 3952 J=1,3
        X = CMAGVE(J,IPIOF)
        CWMAGC(J,IPIOF) = X
        IYY = INT( ABS(X)/10.0 + 0.1 )
        IF(IYY.GT.KMXVAR) THEN
          IYY = 0
          X = 0.0
          IOV = IOV + 1
        ENDIF
        IF( KCLRCW.EQ.1 .AND. IYY.GT.KMXVAR ) THEN
          CMAGVE(J,IPIOF) = 0.0
          LCMAG(J,IPIOF) = 0
          CWMAGC(J,IPIOF) = 0.0
         ELSE
          LCMAG(J,IPIOF) = IYY
          CMAGVE(J,IPIOF) = ( ABS(X) - 10.0 * REAL(IYY) ) * SIGN(1.0,X)
          IMATX(IYY) = IMATX(IYY) + 1
        ENDIF
3952    CONTINUE
      ENDIF
C-
C-  CHECK ANISO THERMAL PARAMETER CODEWORDS TO SEE IF THEY ARE USED
      DO 3960 J=6,11
3960  IF(LATOM(J,IPIOF).GT.0) KANISU(IPIOF) = 1
C-
C-  NEXT ATOM
3620  CONTINUE
C-
C--  LOOKUP ATOM PARAMETERS
C-
      CALL LOOKUP( NSCTOT )
C-
C--  READ AND PRINT PHASE RELATED PARAMETERS AND CODEWORDS
C-
C-  SCALE AND OVERALL TEMPERATURE FACTOR
3700  READ(IODCF,3720) PPHSCA(IPHASE),PPHOIT(IPHASE),PPHABS(IPHASE),
     1                 APHSCA(IPHASE),APHOIT(IPHASE),APHABS(IPHASE)
3720  FORMAT(3F8.0,/,3F8.0)
      WRITE(IOTTO,3722) PPHSCA(IPHASE), APHSCA(IPHASE),
     1                  PPHOIT(IPHASE), APHOIT(IPHASE),
     1                  PPHABS(IPHASE), APHABS(IPHASE)
3722  FORMAT(/,' *  PHASE RELATED PARAMETERS AND CODEWORDS:',//,
     1 ' Scale factor for phase     = ',F9.2,'  Codeword = ',F8.2,/,
     1 ' Overall temp. factor       = ',F9.4,'  Codeword = ',F8.2,/,
     1 ' Absorption correction (ut) = ',F9.4,'  Codeword = ',F8.2)
C-
C-  PROFILE-SHAPE-FUNCTION PARAMETERS
      READ(IODCF,3730) NPSF(1,IPHASE),NPSF(2,IPHASE),RLIM(IPHASE),
     1 PPHASY(IPHASE),(PPHPSF(I,1,IPHASE),I=1,3),
     1 APHASY(IPHASE),(APHPSF(I,1,IPHASE),I=1,3)
3730  FORMAT(2I4,5F8.4,/,16X,4F8.2)
      IF( NPSF(1,IPHASE).LT.1 .OR. NPSF(1,IPHASE).GT.3 ) THEN
        STOP '--INPTR: Requested PSF number is invalid'
      ENDIF
      IF( NPSF(2,IPHASE).EQ.2 .OR. NPSF(2,IPHASE).EQ.3 ) THEN
        READ(IODCF,3732) (PPHPSF(I,2,IPHASE),I=1,3),
     1   (APHPSF(I,2,IPHASE),I=1,3)
3732    FORMAT(24X,3F8.4,/,24X,3F8.2)
      ENDIF
      WRITE(IOTTO,3734) NPSF(1,IPHASE),QPSF(NPSF(1,IPHASE)),
     1  NPSF(2,IPHASE)
3734  FORMAT(/,' Profile-shape-function = ',I1,3X,A21,/,
     1         ' Split function         = ',I1,3X,
     1'0-No 1-FWHM 2-Shape 3-Both')
      WRITE(IOTTO,3736) RLIM(IPHASE),PPHASY(IPHASE),APHASY(IPHASE)
3736  FORMAT(/,
     1' Asymmetry correction applied for angles less than ',F6.2,
     1' degrees',/,
     1' Profile asymmetry parameter = ',F8.4,'  Codeword = ',F8.2)
      IF(NPSF(1,IPHASE).EQ.2) THEN
        WRITE(IOTTO,3742) (PPHPSF(J,1,IPHASE),J=1,3),
     1   (APHPSF(J,1,IPHASE),J=1,3)
3742    FORMAT(/,' Pseudo-Voigt  m (mix) =',3F8.4,/,24X,3F8.2)
        IF( NPSF(2,IPHASE).EQ.2 .OR. NPSF(2,IPHASE).EQ.3 ) THEN
          WRITE(IOTTO,3744) (PPHPSF(J,2,IPHASE),J=1,3),
     1     (APHPSF(J,2,IPHASE),J=1,3)
3744      FORMAT(5X,'High angle side   =',3F8.4,/,24X,3F8.2)
        ENDIF
       ELSE IF(NPSF(1,IPHASE).EQ.3) THEN
        WRITE(IOTTO,3746) (PPHPSF(J,1,IPHASE),J=1,3),
     1   (APHPSF(J,1,IPHASE),J=1,3)
3746    FORMAT(/,' Pearson exponent (m) = ',3F8.4,/,24X,3F8.2)
        IF( NPSF(2,IPHASE).EQ.2 .OR. NPSF(2,IPHASE).EQ.3 ) THEN
          WRITE(IOTTO,3744) (PPHPSF(J,2,IPHASE),J=1,3),
     1     (APHPSF(J,2,IPHASE),J=1,3)
        ENDIF
      ENDIF
C-
C-  PROFILE BROADENING COEFFICIENTS
      READ(IODCF,3750) (PPHUVW(I,1,IPHASE),I=1,3),
     1  (APHUVW(I,1,IPHASE),I=1,3)
3750  FORMAT(8X,3F8.0,/,8X,3F8.2)
      IF( NPSF(2,IPHASE).EQ.1 .OR. NPSF(2,IPHASE).EQ.3 ) THEN
        READ(IODCF,3750) (PPHUVW(I,2,IPHASE),I=1,3),
     1    (APHUVW(I,2,IPHASE),I=1,3)
      ENDIF
      IF(KWSGON.EQ.1) THEN
        WRITE(IOTTO,3752) PPHUVW(1,1,IPHASE),APHUVW(1,1,IPHASE)
3752    FORMAT(/,
     1  ' Crystallite size =',4X,F10.2,' (nm)  Codeword = ',F8.2)
        PPHUVW(1,1,IPHASE) = PPHUVW(1,1,IPHASE) * 10.0
        PPHUVW(2,1,IPHASE) = PPHUVW(2,1,IPHASE) * 1.0E-3
        WRITE(IOTTO,3754) PPHUVW(2,1,IPHASE),APHUVW(2,1,IPHASE)
3754    FORMAT(
     1  ' Crystallite strain =',2X,F10.6,'       Codeword = ',F8.2)
       ELSE
        IF( NPSF(2,IPHASE).NE.1 .AND. NPSF(2,IPHASE).NE.3 ) THEN
          WRITE(IOTTO,3756) 'parameters',
     1     (PPHUVW(I,1,IPHASE),I=1,3),(APHUVW(I,1,IPHASE),I=1,3)
3756     FORMAT(/,' FWHM ',A10,' U,V,W =',3F8.4,/,24X,3F8.2)
         ELSE
          WRITE(IOTTO,3756) 'Low angle ',
     1    (PPHUVW(I,1,IPHASE),I=1,3),(APHUVW(I,1,IPHASE),I=1,3)
          WRITE(IOTTO,3756) 'High angle',
     1    (PPHUVW(I,2,IPHASE),I=1,3),(APHUVW(I,2,IPHASE),I=1,3)
        ENDIF
      ENDIF
C-
C-  LATTICE PARAMETERS
3760  WRITE(IOTTO,3762)
3762  FORMAT(/,
     1' Direct/reciprocal lattice parameters and codewords:',//,
     1 8X,'A',11X,'B',11X,'C',8X,'Alpha',7X,'Beta',8X,'Gamma')
      READ(IODCF,3764) CELDIR
3764  FORMAT(6F8.2)
      CALL CELL2( CELDIR, CELREC )
      DO 3766 I=1,6
      SAVE(I,IPHASE)  = CELDIR(I)
3766  CONTINUE
      PPHLAT(1,IPHASE) = SQRT( CELREC(1,1) )
      PPHLAT(2,IPHASE) = SQRT( CELREC(2,2) )
      PPHLAT(3,IPHASE) = SQRT( CELREC(3,3) )
      PPHLAT(4,IPHASE) = RTOD * ACOS(CELREC(2,3) /
     1                  (2.0 * PPHLAT(2,IPHASE) * PPHLAT(3,IPHASE)) )
      PPHLAT(5,IPHASE) = RTOD * ACOS(CELREC(1,3) /
     1                  (2.0 * PPHLAT(3,IPHASE) * PPHLAT(1,IPHASE)) )
      PPHLAT(6,IPHASE) = RTOD * ACOS(CELREC(1,2) /
     1                  (2.0 * PPHLAT(2,IPHASE) * PPHLAT(1,IPHASE)) )
      WRITE(IOTTO,3770) CELDIR,(PPHLAT(I,IPHASE),I=1,6)
3770  FORMAT((1X,3(1X,F11.6),3(1X,F9.4,2X)))
      READ(IODCF,3772) (APHLAT(I,IPHASE),I=1,6)
3772  FORMAT(6F8.2)
      WRITE(IOTTO,3774) (APHLAT(I,IPHASE),I=1,6)
3774  FORMAT(1X,3(1X,F11.2),3(1X,F9.2,2X))
      PPHLAT(1,IPHASE) = CELREC(1,1)
      PPHLAT(2,IPHASE) = CELREC(2,2)
      PPHLAT(3,IPHASE) = CELREC(3,3)
      PPHLAT(4,IPHASE) = CELREC(2,3)
      PPHLAT(5,IPHASE) = CELREC(1,3)
      PPHLAT(6,IPHASE) = CELREC(1,2)
C-
C-  CALL SRS TO SET REFLECTION PARAMETERS
      CALL REFGEN( CELDIR, CELREC )
      CALL RTMT( KOFSGO, IPHASE )
C-
C-  PREFERRED ORIENTATION PARAMETERS
3800  READ(IODCF,3810) KPOCTY(1,IPHASE),KPOCTY(2,IPHASE),
     1  (PPOVEC(I,1,IPHASE),I=1,3),(PPOPAR(I,1,IPHASE),I=1,2),
     1  (APOPAR(I,1,IPHASE),I=1,2)
3810  FORMAT(2I4,5F8.0,/,32X,2F8.0)
      IF(KPOCTY(2,IPHASE).EQ.1) THEN
        READ(IODCF,3812) (PPOVEC(I,2,IPHASE),I=1,3),
     1    (PPOPAR(I,2,IPHASE),I=1,2),(APOPAR(I,2,IPHASE),I=1,2)
3812    FORMAT(8X,5F8.0,/,32X,2F8.0)
      ENDIF
      IF(KPOCTY(1,IPHASE).EQ.0) THEN
        WRITE(IOTTO,3822) 'None          '
3822    FORMAT(/,
     1  ' Preferred orientation correction applied for phase: ',A14)
        GO TO 4100
       ELSE IF(KPOCTY(1,IPHASE).EQ.1) THEN
        WRITE(IOTTO,3822) 'Rietveld model'
       ELSE IF(KPOCTY(1,IPHASE).EQ.2) THEN
        WRITE(IOTTO,3822) 'March model   '
       ELSE
        WRITE(IOTTO,3822) 'Unknown code  '
        KPOCTY(1,IPHASE) = 0
        GO TO 4100
      ENDIF
      WRITE(IOTTO,3830) ' ',(PPOVEC(I,1,IPHASE),I=1,3),
     1 (PPOPAR(I,1,IPHASE),I=1,2),(APOPAR(I,1,IPHASE),I=1,2)
3830  FORMAT(/,' Preferred orientation vector ',A1,' = ',4X,3F8.4,//,
     1         ' Preferred orientation parameter(s) = ',2F8.4,/,
     1 38X,2F8.2)
      IF( KPOCTY(1,IPHASE).GT.0 .AND. APOPAR(1,1,IPHASE).NE.0.0 .AND.
     1   PPOVEC(1,1,IPHASE).EQ.0.0 .AND. PPOVEC(2,1,IPHASE).EQ.0.0 .AND.
     1   PPOVEC(3,1,IPHASE).EQ.0.0 ) WRITE(IOTTO,3832)
3832  FORMAT(//,
     1  ' --PREFERRED ORIENTATION VECTOR MUST BE NON-ZERO FOR',
     1  ' REFINEMENT.',/,3X,'EXPECT ERRORS DURING REFINEMENT.',/)
      IF( PPOPAR(1,1,IPHASE).EQ.0.0 .AND. PPOPAR(2,1,IPHASE).EQ.0.0 )
     1  WRITE(IOTTO,3834)
3834  FORMAT(//,
     1  ' --PREFERRED ORIENTATION PARAMETERS SHOULD BE NON-ZERO FOR',
     1  ' REFINEMENT.',/,3X,'EXPECT ERRORS DURING REFINEMENT.',/)
      IF(KPOCTY(2,IPHASE).EQ.1) THEN
        WRITE(IOTTO,3830) '2',(PPOVEC(I,2,IPHASE),I=1,3),
     1  (PPOPAR(I,2,IPHASE),I=1,2),(APOPAR(I,2,IPHASE),I=1,2)
      ENDIF
      IF( KPOCTY(2,IPHASE).EQ.1 .AND. APOPAR(1,2,IPHASE).NE.0.0 .AND.
     1   PPOVEC(1,2,IPHASE).EQ.0.0 .AND. PPOVEC(2,2,IPHASE).EQ.0.0 .AND.
     1   PPOVEC(3,2,IPHASE).EQ.0.0 ) WRITE(IOTTO,3832)
      IF( KPOCTY(2,IPHASE).EQ.1 .AND. PPOPAR(1,2,IPHASE).EQ.0.0 )
     1  WRITE(IOTTO,3834)
      IF(KPOCTY(1,IPHASE).EQ.0) GO TO 4100
      IF( QLAUGR(IPHASE).EQ.'M3M     ' .OR.
     1    QLAUGR(IPHASE).EQ.'M3      '      ) THEN
        QLLGRP = '23      '
       ELSE IF( QLAUGR(IPHASE).EQ.'3Bar M R' .OR.
     1          QLAUGR(IPHASE).EQ.'3Bar R  '      ) THEN
        QLLGRP = '3 R     '
       ELSE IF( QLAUGR(IPHASE).EQ.'3Bar M 1' .OR.
     1          QLAUGR(IPHASE).EQ.'3Bar 1 M' .OR.
     1          QLAUGR(IPHASE).EQ.'3Bar    '      ) THEN
        QLLGRP = '3       '
       ELSE IF( QLAUGR(IPHASE).EQ.'6/MMM   ' .OR.
     1          QLAUGR(IPHASE).EQ.'6/M     '      ) THEN
        QLLGRP = '6       '
       ELSE IF( QLAUGR(IPHASE).EQ.'4/MMM   ' .OR.
     1          QLAUGR(IPHASE).EQ.'4/M     '      ) THEN
        QLLGRP = '4       '
       ELSE IF( QLAUGR(IPHASE).EQ.'MMM     '      ) THEN
        QLLGRP = '222     '
       ELSE IF( QLAUGR(IPHASE).EQ.'2/M     '      ) THEN
        QLLGRP = '2       '
       ELSE IF( QLAUGR(IPHASE).EQ.'1Bar    '      ) THEN
        QLLGRP = '1       '
       ELSE
        STOP '--INPTR: Unknown Laue group'
      ENDIF
      ITEMP = 1
3850  IVI(1) = NINT( PPOVEC(1,ITEMP,IPHASE) )
      IVI(2) = NINT( PPOVEC(2,ITEMP,IPHASE) )
      IVI(3) = NINT( PPOVEC(3,ITEMP,IPHASE) )
      CALL GNLARE( QLLGRP, IVI, IVO, NTMP )
      NHKL = 1
      PPOSED(1,1,ITEMP,IPHASE) = REAL( IVO(1,1) )
      PPOSED(2,1,ITEMP,IPHASE) = REAL( IVO(2,1) )
      PPOSED(3,1,ITEMP,IPHASE) = REAL( IVO(3,1) )
      DO 3860 I=2,NTMP
      DO 3862 J=1,NHKL
      IF( IVO(1,I).EQ.-IVO(1,J) .AND. IVO(2,I).EQ.-IVO(2,J) .AND.
     1    IVO(3,I).EQ.-IVO(3,J) ) GO TO 3860
3862  CONTINUE
      NHKL = NHKL + 1
      IVO(1,NHKL) = IVO(1,I)
      IVO(2,NHKL) = IVO(2,I)
      IVO(3,NHKL) = IVO(3,I)
      PPOSED(1,NHKL,ITEMP,IPHASE) = REAL( IVO(1,I) )
      PPOSED(2,NHKL,ITEMP,IPHASE) = REAL( IVO(2,I) )
      PPOSED(3,NHKL,ITEMP,IPHASE) = REAL( IVO(3,I) )
3860  CONTINUE
      KPOSNM(ITEMP,IPHASE) = NHKL
      IF(KPOSNM(ITEMP,IPHASE).EQ.0)STOP '--INPTR: Laue symmetry problem'
      WRITE(IOTTO,3870) QLLGRP,ITEMP,
     1 ((NINT(PPOSED(J,I,ITEMP,IPHASE)),J=1,3),I=1,KPOSNM(ITEMP,IPHASE))
3870  FORMAT(/,
     1  ' Directions related by symmetry ',A8,' to preferred',
     1  ' orientation vector ',I1,' :',/,
     1  (2X,3I3,2X,3I3,2X,3I3,2X,3I3,2X,3I3,2X,3I3))
      IF( ITEMP.EQ.1 .AND. KPOCTY(2,IPHASE).EQ.1 ) THEN
        ITEMP = 2
        GO TO 3850
      ENDIF
C-
C-  GENERATE MATRIX POINTERS AND FRACT. SHIFTS FOR PHASE-RELATED PARAMETERS
4100  CPYPHS( 1,IPHASE) = APHSCA(IPHASE)
      CPYPHS( 2,IPHASE) = APHOIT(IPHASE)
      CPYPHS( 3,IPHASE) = APHABS(IPHASE)
      CPYPHS( 4,IPHASE) = APHPSF(1,1,IPHASE)
      CPYPHS( 5,IPHASE) = APHPSF(2,1,IPHASE)
      CPYPHS( 6,IPHASE) = APHPSF(3,1,IPHASE)
      CPYPHS( 7,IPHASE) = APHPSF(1,2,IPHASE)
      CPYPHS( 8,IPHASE) = APHPSF(2,2,IPHASE)
      CPYPHS( 9,IPHASE) = APHPSF(3,2,IPHASE)
      CPYPHS(10,IPHASE) = APHASY(IPHASE)
      CPYPHS(11,IPHASE) = APHUVW(1,1,IPHASE)
      CPYPHS(12,IPHASE) = APHUVW(2,1,IPHASE)
      CPYPHS(13,IPHASE) = APHUVW(3,1,IPHASE)
      CPYPHS(14,IPHASE) = APHUVW(1,2,IPHASE)
      CPYPHS(15,IPHASE) = APHUVW(2,2,IPHASE)
      CPYPHS(16,IPHASE) = APHUVW(3,2,IPHASE)
      CPYPHS(17,IPHASE) = APHLAT(1,IPHASE)
      CPYPHS(18,IPHASE) = APHLAT(2,IPHASE)
      CPYPHS(19,IPHASE) = APHLAT(3,IPHASE)
      CPYPHS(20,IPHASE) = APHLAT(4,IPHASE)
      CPYPHS(21,IPHASE) = APHLAT(5,IPHASE)
      CPYPHS(22,IPHASE) = APHLAT(6,IPHASE)
      CPYPHS(23,IPHASE) = APOPAR(1,1,IPHASE)
      CPYPHS(24,IPHASE) = APOPAR(2,1,IPHASE)
      CPYPHS(25,IPHASE) = APOPAR(1,2,IPHASE)
      CPYPHS(26,IPHASE) = APOPAR(2,2,IPHASE)
      DO 4110 I=1,26
      X   = CPYPHS(I,IPHASE)
      IYY = INT( ABS(X)/10.0 + 0.1 )
      X   = SIGN(1.0,X) * ( ABS(X) - 10.0*REAL(IYY) )
      IF(IYY.GT.KMXVAR) THEN
        IYY = 0
        IOV = IOV + 1
        IF(KCLRCW.EQ.1) THEN
          X = 0.0
          CPYPHS(I,IPHASE) = 0.0
        ENDIF
      ENDIF
      IMATX(IYY) = IMATX(IYY) + 1
      XDEL(I) = X
      IDEL(I) = IYY
4110  CONTINUE
      APHSCA(IPHASE)     = XDEL( 1)
      LPHSCA(IPHASE)     = IDEL( 1)
      APHOIT(IPHASE)     = XDEL( 2)
      LPHOIT(IPHASE)     = IDEL( 2)
      APHABS(IPHASE)     = XDEL( 3)
      LPHABS(IPHASE)     = IDEL( 3)
      APHPSF(1,1,IPHASE) = XDEL( 4)
      LPHPSF(1,1,IPHASE) = IDEL( 4)
      APHPSF(2,1,IPHASE) = XDEL( 5)
      LPHPSF(2,1,IPHASE) = IDEL( 5)
      APHPSF(3,1,IPHASE) = XDEL( 6)
      LPHPSF(3,1,IPHASE) = IDEL( 6)
      APHPSF(1,2,IPHASE) = XDEL( 7)
      LPHPSF(1,2,IPHASE) = IDEL( 7)
      APHPSF(2,2,IPHASE) = XDEL( 8)
      LPHPSF(2,2,IPHASE) = IDEL( 8)
      APHPSF(3,2,IPHASE) = XDEL( 9)
      LPHPSF(3,2,IPHASE) = IDEL( 9)
      APHASY(IPHASE)     = XDEL(10)
      LPHASY(IPHASE)     = IDEL(10)
      APHUVW(1,1,IPHASE) = XDEL(11)
      LPHUVW(1,1,IPHASE) = IDEL(11)
      APHUVW(2,1,IPHASE) = XDEL(12)
      LPHUVW(2,1,IPHASE) = IDEL(12)
      APHUVW(3,1,IPHASE) = XDEL(13)
      LPHUVW(3,1,IPHASE) = IDEL(13)
      APHUVW(1,2,IPHASE) = XDEL(14)
      LPHUVW(1,2,IPHASE) = IDEL(14)
      APHUVW(2,2,IPHASE) = XDEL(15)
      LPHUVW(2,2,IPHASE) = IDEL(15)
      APHUVW(3,2,IPHASE) = XDEL(16)
      LPHUVW(3,2,IPHASE) = IDEL(16)
      APHLAT(1,IPHASE)   = XDEL(17)
      LPHLAT(1,IPHASE)   = IDEL(17)
      APHLAT(2,IPHASE)   = XDEL(18)
      LPHLAT(2,IPHASE)   = IDEL(18)
      APHLAT(3,IPHASE)   = XDEL(19)
      LPHLAT(3,IPHASE)   = IDEL(19)
      APHLAT(4,IPHASE)   = XDEL(20)
      LPHLAT(4,IPHASE)   = IDEL(20)
      APHLAT(5,IPHASE)   = XDEL(21)
      LPHLAT(5,IPHASE)   = IDEL(21)
      APHLAT(6,IPHASE)   = XDEL(22)
      LPHLAT(6,IPHASE)   = IDEL(22)
      APOPAR(1,1,IPHASE) = XDEL(23)
      LPOPAR(1,1,IPHASE) = IDEL(23)
      APOPAR(2,1,IPHASE) = XDEL(24)
      LPOPAR(2,1,IPHASE) = IDEL(24)
      APOPAR(1,2,IPHASE) = XDEL(25)
      LPOPAR(1,2,IPHASE) = IDEL(25)
      APOPAR(2,2,IPHASE) = XDEL(26)
      LPOPAR(2,2,IPHASE) = IDEL(26)
C-
C--  WRITE REFLECTION LIST FOR THE PHASE
C-
C-  CALCULATE POINTERS INTO REFLECTION LIST FOR LISTING AND MULTS
4500  IEND = 0
      DO 4502 ITMP=1,IPHASE
4502  IEND = IEND + KREFNM(ITMP)
      ISTR = 1
      IF(IPHASE.GT.1) THEN
        DO 4504 ITMP=1,(IPHASE-1)
4504    ISTR = ISTR + KREFNM(ITMP)
      ENDIF
      IOFF = ISTR - 1
C-
C-  WRITE LIST
      IF(KOFRLI.NE.1) GO TO 4600
      DO 4510 IORDC=ISTR,IEND
      IRC    = MOD( KREFDT(IORDC)/256/256/256,   4 )
      IVI(1) = MOD( KREFDT(IORDC)/256/256,     256 ) - 128
      IVI(2) = MOD( KREFDT(IORDC)/256,         256 ) - 128
      IVI(3) = MOD( KREFDT(IORDC),             256 ) - 128
      TWOTHT = PREFTT(IORDC)
      CORL2T = TWOTHT-CORPOS(TWOTHT)+PGLB(1)+PGLB(10)*COS(TWOTHT*DTORD2)
      CALL FNFWHM
      D = RADWAV(IRC) / (2.0*SIN(TWOTHT*DTORD2))
      HKL(1) = REAL( IVI(1) )
      HKL(2) = REAL( IVI(2) )
      HKL(3) = REAL( IVI(3) )
      CALL PRFCRF( 1, HKL, PRECOR, TEMP )
      CALL ABSCRF( 1, PREFTT(IORDC), ABSCOR, TEMP )
      IP = IORDC - IOFF
      IF( MOD(IP-1,60) .EQ. 0 ) WRITE(IOTTO,4520)
4520  FORMAT('1 No.   H   K   L  Mult  Alpha  2Theta  D space ',
     1  ' FWHM     Lp    Pref.  Abs.',/)
      WRITE(IOTTO,4530) IP,IVI,MLTT(IORDC),IRC,TWOTHT,D,FWHML,
     1  PREFLP(IORDC),PRECOR,ABSCOR
4530  FORMAT(1X,4I4,3X,I2,4X,I2,2X,F8.3,1X,F8.4,F7.3,F9.4,2F6.2)
4510  CONTINUE
C-
C-  MULTIPLY LP OF EACH REFLECTION BY THE ITS MULTIPLICITY
4600  DO 4610 IORDC=ISTR,IEND
4610  PREFLP(IORDC) = PREFLP(IORDC) * REAL( MLTT(IORDC) )
C-
C-  NEXT PHASE
3510  CONTINUE
C-
C--  PRINT MATRIX USAGE STATISTICS  ------------------------------------
C-
5000  WRITE(IOTTO,5010)
5010  FORMAT(/,' Matrix usage statistics (position/references):')
      ISTRT = 1
5020  IFINI = MIN( ISTRT+29, MMATX )
      WRITE(IOTTO,5030) (I,I=ISTRT,IFINI)
      WRITE(IOTTO,5040) (IMATX(I),I=ISTRT,IFINI)
5030  FORMAT(/,1X,30I4)
5040  FORMAT(  1X,30I4)
      ISTRT = ISTRT + 30
      IF(IFINI.LT.MMATX) GO TO 5020
      IMT = 0
      DO 5050 I=1,MMATX
5050  IF( I.LE.KMXVAR .AND. IMATX(I).EQ.0 ) IMT = IMT + 1
      WRITE(IOTTO,5060) IMT,IOV
5060  FORMAT(/,' Number of holes in matrix ',I3,
     1 '  References beyond max number variables ',I3)
      IF( IMT.GT.0 .AND. JOBXN.LT.3 ) THEN
        WRITE(IOTTO,5070)
5070    FORMAT(/,
     1  ' --THE CURRENT CODEWORDS LEAVE A HOLE IN THE NORMAL EQUATION',
     1  ' MATRIX.',/,
     1  '   MATRIX USAGE MUST BE CONTIGUOUS IF THE PROGRAM IS TO',
     1  ' EXECUTE CORRECTLY.')
        STOP '--HOLES WERE FOUND IN THE NORMAL EQUATION MATRIX'
      ENDIF
C-
      RETURN
      END
C--  SETIO - SETUP FILE I/O NAMES
C-
      SUBROUTINE SETIO
C-
      INCLUDE 'RIETCOM.FOR'
      CHARACTER QFMT1S*36,QFMT2S*39,QFMT3S*33,QFMT4S*35,QFMT5S*37
      CHARACTER QFMT6S*34
      CHARACTER QFMT1N*2,QFMT2N*2,QFMT3N*2,QFMT4N*2,QFMT5N*2,QFMT6N*2
      CHARACTER QFILE1*40
      EQUIVALENCE ( QFMT1S(26:27), QFMT1N(1:2) )
      EQUIVALENCE ( QFMT2S(29:30), QFMT2N(1:2) )
      EQUIVALENCE ( QFMT3S(23:24), QFMT3N(1:2) )
      EQUIVALENCE ( QFMT4S(26:27), QFMT4N(1:2) )
      EQUIVALENCE ( QFMT5S(28:29), QFMT5N(1:2) )
      EQUIVALENCE ( QFMT6S(25:26), QFMT6N(1:2) )
      DATA QFMT1S/'('' Pattern file name <'',A##,''> ? '')'/
      DATA QFMT2S/'('' Background file name <'',A##,''> ? '')'/
      DATA QFMT3S/'('' Plot file name <'',A##,''> ? '')'/
      DATA QFMT4S/'('' Listing file name <'',A##,''> ? '')'/
      DATA QFMT5S/'('' New input file name <'',A##,''> ? '')'/
      DATA QFMT6S/'('' Status file name <'',A##,''> ? '')'/
C-
C-  GET THE NAME OF THE FILE CONTAINING THE CONTROL PARAMETERS
C-
1000  WRITE(IOTTO,1020)
1020  FORMAT(/,' Control file name <EXIT> ? ')
      READ(IOTTI,1030) QDCFFN
1030  FORMAT(A40)
      IF( QDCFFN.EQ.' ' .OR. QDCFFN.EQ.'/' ) THEN
        WRITE(IOTTO,1035)
1035    FORMAT(/,' -NO CONTROL FILE NAME; EXECUTION TERMINATED')
        STOP '-NO CONTROL FILE NAME; EXECUTION TERMINATED'
      ENDIF
C-
C-  DETERMINE FILE NAME POINTERS
1100  DO 1110 NEND=40,1,-1
1110  IF(QDCFFN(NEND:NEND).EQ.'.') GO TO 1120
      DO 1130 NEND=40,1,-1
1130  IF(QDCFFN(NEND:NEND).NE.' ') GO TO 1140
      STOP '--SETIO:  BLANK CONTROL FILE NAME; ABORT'
1140  NEND = NEND + 1
1120  NENDP3 = NEND + 3
C-
C-  OPEN THE CONTROL DATA FILE NOW
CVAX
      OPEN(UNIT=IODCF,FILE=QDCFFN,STATUS='OLD',ERR=1040,READONLY)
CVAX
CIBM
c      OPEN(UNIT=IODCF,FILE=QDCFFN,STATUS='OLD',ERR=1040)
CIBM
      GO TO 1200
1040  WRITE(IOTTO,1045)
1045  FORMAT(' --SETIO: CONTROL FILE IS BUSY OR NOT THERE; ABORT.')
      STOP '--SETIO: CONTROL FILE IS BUSY OR NOT THERE; ABORT'
C-
C-  INSTRUMENT CALIBRATION FILE NAME
C-
1200  WRITE(IOTTO,1210)
1210  FORMAT(' Instrument calibration file <NOT USED> ? ')
      READ(IOTTI,1030) QINSFN
      IF(QINSFN.EQ.'/') QINSFN = ' '
C-
C-  PATTERN FILE NAME
C-
2000  QPTNFN = QDCFFN
      QPTNFN(NEND:) = '.XDA'
      WRITE(QFMT1N,2010) NENDP3
2010  FORMAT(I2)
      WRITE(IOTTO,QFMT1S) QPTNFN(1:NENDP3)
      READ(IOTTI,1030) QFILE1
      IF( QFILE1(1:1).NE.' ' .AND. QFILE1(1:1).NE.'/' ) QPTNFN = QFILE1
C-
C-  BACKGROUND FILE NAME
C-
3000  QBKGFN = QDCFFN
      QBKGFN(NEND:) = '.BKG'
      WRITE(QFMT2N,2010) NENDP3
      WRITE(IOTTO,QFMT2S) QBKGFN(1:NENDP3)
      READ(IOTTI,1030) QFILE1
      IF( QFILE1(1:1).NE.' ' .AND. QFILE1(1:1).NE.'/' ) QBKGFN = QFILE1
C-
C-  PLOT FILE NAME
C-
4000  QPLTFN = QDCFFN
      QPLTFN(NEND:) = '.PLT'
      WRITE(QFMT3N,2010) NENDP3
      WRITE(IOTTO,QFMT3S) QPLTFN(1:NENDP3)
      READ(IOTTI,1030) QFILE1
      IF( QFILE1(1:1).NE.' ' .AND. QFILE1(1:1).NE.'/' ) QPLTFN = QFILE1
C-
C-  LISTING FILE NAME
C-
5000  WRITE(IOTTO,5002)
5002  FORMAT(' Listing file name <TERMINAL> ? ')
      READ(IOTTI,1030) QLSTFN
      IF( QLSTFN(1:1).EQ.' ' .OR. QLSTFN(1:1).EQ.'/' ) QLSTFN='TERMINAL'
C-
C-  NEW CONTROL DATA FILE NAME
C-
6000  QNEWFN = QDCFFN
      QNEWFN(NEND:) = '.NEW'
      WRITE(QFMT5N,2010) NENDP3
      WRITE(IOTTO,QFMT5S) QNEWFN(1:NENDP3)
      READ(IOTTI,1030) QFILE1
      IF( QFILE1(1:1).NE.' ' .AND. QFILE1(1:1).NE.'/' ) QNEWFN = QFILE1
C-
C-  STATUS FILE NAME
C-
7000  QSTAFN = QDCFFN
      QSTAFN(NEND:) = '.STA'
      WRITE(QFMT6N,2010) NENDP3
      WRITE(IOTTO,QFMT6S) QSTAFN(1:NENDP3)
      READ(IOTTI,1030) QFILE1
      IF( QFILE1(1:1).NE.' ' .AND. QFILE1(1:1).NE.'/' ) QSTAFN = QFILE1
C-
C- OPEN THE LISTING FILE NOW
C-
CVAX
      IF(QLSTFN.NE.'TERMINAL') THEN
        IOTTO = 8
        OPEN(UNIT=IOTTO,FILE=QLSTFN,STATUS='NEW',CARRIAGECONTROL='LIST',
     1       ERR=5010)
      ENDIF
CVAX
CIBM
c      IF(QLSTFN.NE.'TERMINAL') THEN
c        IOTTO = 8
c        OPEN(UNIT=IOTTO,FILE=QLSTFN,STATUS='UNKNOWN',
c     1  ERR=5010)
c      ENDIF
CIBM
      GO TO 9000
5010  IOTTO = 6
      WRITE(IOTTO,5020)
5020  FORMAT(' --SETIO: UNABLE TO OPEN LISTING FILE; ABORT.')
      STOP '--SETIO: UNABLE TO OPEN LISTING FILE; ABORT'
C-
9000  RETURN
      END
C---  GETPAT - FETCH REQUESTED SCAN DATA FROM PATTERN FILE
C-
      SUBROUTINE GETPAT
C-
      INCLUDE 'RIETCOM.FOR'
      LOGICAL LUNFMT
      CHARACTER QFTITL*80,QDATE*9,QTIME*8,QJUNK*1
      DIMENSION XDATA(10)
C-
C-  WHERE:  THMIN = REQUESTED STARTING ANGLE
C-          THMAX = REQUESTED ENDING ANGLE
C-
C-   DETERMINE FORMAT OF PATTERN FILE: FORMATTED OR UNFORMATTED
1000  LUNFMT = QPTNFN(1:1).EQ.'$'
      IF(LUNFMT) THEN
        QPTNFN(1:) = QPTNFN(2:)
      ENDIF
C-
C-  RECORD REQUESTED STEP WIDTH FOR DETERMINATION OF DATA STEP
      RSTEP = STEP
C-
C-  OPEN FILE AND GET PATTERN PARAMETERS
      IF(LUNFMT) THEN
CVAX
        OPEN(UNIT=IOPTN,FILE=QPTNFN,STATUS='OLD',READONLY,
     1       FORM='UNFORMATTED',ERR=1010)
CVAX
CIBM
c        OPEN(UNIT=IOPTN,FILE=QPTNFN,STATUS='OLD',
c     1  FORM='UNFORMATTED',ERR=1010)
CIBM
       ELSE
CVAX
       OPEN(UNIT=IOPTN,FILE=QPTNFN,STATUS='OLD',READONLY,
     1      FORM='FORMATTED',ERR=1010)
CVAX
CIBM
c        OPEN(UNIT=IOPTN,FILE=QPTNFN,STATUS='OLD',
c     1  FORM='FORMATTED',ERR=1010)
CIBM
      ENDIF
      GO TO 2000
1010  WRITE(IOTTO,1020)
1020  FORMAT(' --PATTERN FILE IS BUSY OR NOT THERE:  ABORT.')
      STOP '--PATTERN FILE IS BUSY OR NOT THERE'
C-
C-  READ AND WRITE THE PATTERN FILE HEADER
C-
2000  IF(LUNFMT) THEN
        READ(IOPTN) QFTITL
        READ(IOPTN) QDATE,QTIME
        READ(IOPTN) FBANG,FEANG,STEP,FTIME
       ELSE
        READ(IOPTN,2010) QFTITL
2010    FORMAT(A80)
        READ(IOPTN,2020) QDATE,QTIME
2020    FORMAT(A9,A8)
        READ(IOPTN,2030) FBANG,FEANG,STEP,FTIME
2030    FORMAT(4F10.4)
      ENDIF
C-
      WRITE(IOTTO,2040)
2040  FORMAT(/,' The run time parameters for the pattern file are:')
      WRITE(IOTTO,2050) QFTITL(1:72)
2050  FORMAT(/,2X,A72)
      WRITE(IOTTO,2070) FBANG,STEP,QDATE,FEANG,FTIME,QTIME
2070  FORMAT(/,
     1'  Starting angle: ',F8.4,'  Angle increment: ',F8.4,
     1'  Date: ',A9,/,
     1'  Ending angle  : ',F8.4,'  Step time      : ',F8.4,
     1'  Time:  ',A8)
C-
C-  SET DEFAULTS TO BEGINNING AND ENDING OF PATTERN IF NOT SPECIFIED
2100  IF(THMIN.LT.FBANG) THEN
        THMIN = FBANG
        WRITE(IOTTO,2110) THMIN
2110    FORMAT(2X,
     1  '-Input pattern 2Theta minimum defaulting to ',F8.2,' degrees')
      ENDIF
      IF( THMAX.LT.THMIN .OR. THMAX.GT.FEANG ) THEN
        THMAX = FEANG
        WRITE(IOTTO,2120) THMAX
2120    FORMAT(2X,
     1  '-Input pattern 2Theta maximum defaulting to ',F8.2,' degrees')
      ENDIF
C-
C-  READ THE SELECTED REGION FROM THE PATTERN FILE
C-
C-  DETERMINE DATA SAMPLING INTERVAL
      IF(RSTEP.LT.STEP) RSTEP = STEP
      NTHSV = 1
      IF(RSTEP.NE.STEP) THEN
        NTHSV = NINT( (RSTEP-STEP)/STEP ) + 1
        RSTEP = STEP * REAL(NTHSV)
        WRITE(IOTTO,2122) NTHSV,RSTEP
2122    FORMAT(2X,
     1  '-Requested sampling interval from the pattern is ',I2,
     1  ' (',F6.4,' degrees)')
      ENDIF
C-
C-  INSURE THAT OUTPUT PATTERN DOES NOT EXCEED STORAGE AREAS
      KPPTS = NINT( (THMAX-THMIN) / RSTEP ) + 1
      IF(KPPTS.GT.MNPTS) THEN
        WRITE(IOTTO,2130) MNPTS
2130    FORMAT(2X,
     1  '-Points in pattern limited to program maximum of ',I5)
        KPPTS = MNPTS
        THMAX = THMIN + (MNPTS-1) * RSTEP
      ENDIF
C-
C-  SET COUNTERS
      NDTBEG = INT( (THMIN-FBANG)/STEP + 0.1 ) + 1
      BANG = FBANG + REAL(NDTBEG-1) * STEP
      NDTEND = INT( (THMAX-FBANG)/STEP + 0.1 ) + 1
      NTOGET = ( NDTEND - NDTBEG + 1 ) / NTHSV
C-
C-  INITIALIZE POINTS COUNTER
      KPPTS = 0
      NTHSVC = NTHSV - 1
      NSCAN = 0
C-
C-  KEEP READING UNTIL THE PROPER NUMBER OF POINTS HAVE BEEN READ
3100  IF(LUNFMT) THEN
3105    READ(IOPTN,END=3300) XDATA
        DO 3110 J = 1,10
        NSCAN = NSCAN + 1
        IF(NSCAN.LT.NDTBEG) GO TO 3110
        NTHSVC = NTHSVC + 1
        IF(NTHSVC.NE.(NTHSVC/NTHSV)*NTHSV) GO TO 3110
        KPPTS = KPPTS + 1
        YOBS(KPPTS) = XDATA(J)
        IF(KPPTS.EQ.NTOGET) GO TO 4000
3110    CONTINUE
        GO TO 3105
       ELSE
3150    READ(IOPTN,3025,END=3300) XDATA
3025    FORMAT(10F7.0)
        DO 3160 J = 1,10
        NSCAN = NSCAN + 1
        IF(NSCAN.LT.NDTBEG) GO TO 3160
        NTHSVC = NTHSVC + 1
        IF(NTHSVC.NE.(NTHSVC/NTHSV)*NTHSV) GO TO 3160
        KPPTS = KPPTS + 1
        YOBS(KPPTS) = XDATA(J)
        IF(KPPTS.EQ.NTOGET) GO TO 4000
3160    CONTINUE
        GO TO 3150
      ENDIF
C-
3300  WRITE(IOTTO,3310) KPPTS
3310  FORMAT('  -END-OF-FILE WAS PREMATURELY HIT.  POINTS READ = ',I4)
C-
C-  CONFIRM DATA
4000  THMIN = BANG
      THMAX = BANG + REAL(KPPTS-1)*RSTEP
      STEP  = RSTEP
      CTIME = FTIME
      WRITE(IOTTO,4010) THMIN,STEP,THMAX,KPPTS
4010  FORMAT('  Pattern: 2Theta  Min = ',F8.4,'  Step = ',F7.4,
     1  '  Max = ',F8.4,'  NPts = ',I5)
C-
9000  CLOSE(UNIT=IOPTN)
      RETURN
      END
C---  GETWSG - GET INSTRUMENT RELATED PARAMETERS
C-
      SUBROUTINE GETWSG
C-
      INCLUDE 'RIETCOM.FOR'
      CHARACTER FILEID*20, FILEXX*20, QDATE*9, QTIME*8
      CHARACTER LINE72*72, LINEID*10, QWGFID*32, QWGTTL*72
      PARAMETER ( FILEID = '*** Ins Calibration' )
      DIMENSION WCU(5,2), FF(3), FB(3), SF(3), SB(3)
      EQUIVALENCE ( LINE72(1:20), FILEXX )
      DATA WCU/ 1.540598, 1.544435, 1.534380, 0.0, 0.0,
     1          1.00    , 0.50    , 0.01    , 0.0, 0.0/
      DATA FF/ 0.236949E-2,-0.203249E-3, 0.108885E-2/
      DATA FB/ 0.620709E-3, 0.144402E-3, 0.137567E-2/
      DATA SF/ 0.183509E+1,-0.137454E-1, 0.544673E-4/
      DATA SB/ 0.103232E+1,-0.145803E-2, 0.423803E-5/
      DATA IOWG / 15 /
C-
C-  IF QINSFN IS NON BLANK THEN ATTEMPT TO READ FROM THE FILE
      IF(QINSFN.NE.' ') GO TO 2000
C-
C--  SET DEFAULT PARAMETERS THAT WILL NOT AFFECT NORMAL OPERATION
C-
C-  SET DEFAULTS WAVELENGTHS TO THAT OF CU (USED IN CONVOLUTION ONLY)
1000  DO 1010 I=1,5
      WGRAD(I,1) = WCU(I,1)
      WGRAD(I,2) = WCU(I,2)
1010  CONTINUE
      KGRAD(1,2) = 3
C-
C-  SET THE DEFAULT PROFILE PARAMETERS (USED IN CONVOLUTION ONLY)
      DO 1030 I=1,3
      WGPRO(1,I) = FF(I)
      WGPRO(2,I) = SF(I)
      WGPRO(3,I) = FB(I)
      WGPRO(4,I) = SB(I)
1030  CONTINUE
C-
C-  DEFAULT DELTA 2THETA COEFFICIENTS: NO CORRECTION TO BE APPLIED
      DO 1040 I=1,6
1040  WGCAL(I) = 0.0
C-
      GO TO 9000
C-
C--  READ THE INSTRUMENT CALIBRATION FILE
C-
2000  WRITE(IOTTO,2002) QINSFN
2002  FORMAT(/,' Reading instrument parameters from: ',A40)
CVAX
      OPEN(UNIT=IOWG,FILE=QINSFN,STATUS='OLD',ERR=2010,READONLY)
CVAX
CIBM
c      OPEN(UNIT=IOWG,FILE=QINSFN,STATUS='OLD',ERR=2010)
CIBM
      GO TO 2100
2010  WRITE(IOTTO,2020)
2020  FORMAT(' --SPECIFIED INSTRUMENT DATA FILE IS BUSY OR NOT THERE')
      QINSFN = ' '
      GO TO 1000
C-
C-  A FILE IS THERE... DETERMINE IF IT IS A PARAMETER FILE
2100  READ(IOWG,2112,END=2115) LINE72
2112  FORMAT(1X,A72)
      IF(FILEID.EQ.FILEXX) GO TO 2200
C-
C-  FILE EXISTS BUT NOT AN INSTRUMENT DATA FILE...
2115  WRITE(IOTTO,2120)
2120  FORMAT(' --FILE IS NOT AN INSTRUMENT CALIBRATION FILE')
      CLOSE(UNIT=IOWG)
      GO TO 1000
C-
C-  READ THE CALIBRATION FILE HEADER
2200  READ(IOWG,2112) QWGTTL
      WRITE(IOTTO,2202) QWGTTL
2202  FORMAT(2X,A72)
C-
C-  READ THE RADIATION WAVELENGTHS
      READ(IOWG,2112) QWGTTL
      WRITE(IOTTO,2202) QWGTTL
      DO 2210 I=1,5
      READ(IOWG,2220) (KGRAD(I,J),J=1,2),(WGRAD(I,J),J=1,2)
2220  FORMAT(10X,1X,I2,1X,I2,1X,3(1X,E13.6))
2210  CONTINUE
      KGRAD(1,2) = 0
      DO 2212 I=1,5
      IF(WGRAD(I,1).GT.0.0) KGRAD(1,2) = KGRAD(1,2) + 1
2212  CONTINUE
      RADWAV(1) = WGRAD(1,1)
      RADREL(1)  = 1.0
      RADWAV(2) = WGRAD(2,1)
      RADREL(2)  = WGRAD(2,2)
      WRITE(IOTTO,2214) RADWAV(1),RADREL(1),RADWAV(2),RADREL(2)
2214  FORMAT('  Instrument wavelengths:',
     1' Alpha1 =',2(1X,F7.4),'  Alpha2 =',2(1X,F7.4))
C-
C-  READ THE PROFILE DATA
      READ(IOWG,2112) QWGTTL
      WRITE(IOTTO,2202) QWGTTL
      DO 2240 I=1,4
2240  READ(IOWG,2220) (KGPRO(I,J),J=1,2),(WGPRO(I,J),J=1,3)
C-
C-  READ THE CALIBRATION CURVE PARAMETERS
      READ(IOWG,2112) QWGTTL
      WRITE(IOTTO,2202) QWGTTL
      READ(IOWG,2220) (KGCAL(1,J),J=1,2),(WGCAL(J),J=1,3)
      READ(IOWG,2220) (KGCAL(2,J),J=1,2),(WGCAL(J),J=4,6)
C-
      CLOSE(UNIT=IOWG)
C-
9000  RETURN
      END
C--- PROGRAM: RIETVELD  (RIET11)
C--- VERSION: 881001  (YYMMDD)
C---
      SUBROUTINE COEF( IATOM )
C-
      IMPLICIT DOUBLE PRECISION ( A-H, O-Z )
      REAL SINLAM, SCAT, SCATAC, DFP, DFPP
      PARAMETER( MNPTS=5120, MREFS=1024, MATMS=48, MMATX=48, MPHAS=4 )
      CHARACTER*4 QSCNAM
      COMMON/SCACO2/ QSCNAM(16)
      COMMON/SCACO1/ NSCOEF,SINLAM(30),SCAT(30)
      COMMON/SCACO0/ NSCAT,KPTR(MATMS),SCATAC(10,16),DFP(16),DFPP(16)
      DIMENSION AB(10)
C-
      NN = MIN0( NSCOEF, 9 )
      DO 15 I=1,NN
15    AB(I) = DBLE( I )
      NN1 = NN + 1
      DO 16 I=NN1,10
16    AB(I) = 0.0D0
C-
      CALL STEEP( AB, 3, 10 )
      IF(AB(3).EQ.0.0D0) AB(3) = -1.0D-6
C-
      DO 20 I=1,9
20    SCATAC(I,IATOM) = AB(I)
C--
      RETURN
      END
C---  STEEP
C
      SUBROUTINE STEEP( X, N, M )
C-
      IMPLICIT DOUBLE PRECISION ( A-H, O-Z )
      DIMENSION Z(16),X(16),T(16),ZNT(16),SIGT(16),SIG(16)
      DIMENSION Y(16,16),XI(16),ZN(16)
C-
      IF(N.EQ.0) RETURN
C-
      CALL GRAD(X,Z)
      CALL CHISQQ(X,G)
C-
      DO 10 I=1,M
      DO 10 J=1,M
      Y(I,J)=0.0D0
      IF(I.EQ.J) Y(I,J)=1.0D0
10    CONTINUE
C-
      DO 200 K=1,N
C-
      U=0.0D0
      DO 20 I=1,M
      T1=0.0D0
      DO 30 J=1,M
30    T1=T1+Z(J)*Y(I,J)
      SIG(I)=T1
20    U=U-SIG(I)*Z(I)
      ETA=DMIN1(1.0D0,DABS(2.D0*G/U))
C-
      DO 40 I=1,M
40    T(I)=X(I)-ETA*SIG(I)
      CALL GRAD(T,ZN)
C-
      V=0.0D0
      DO 50 I=1,M
50    V=V-ZN(I)*SIG(I)
C-
      CALL CHISQQ(T,G1)
      D=3.0D0*DABS(G-G1)/ETA+U+V
COLD  W=DSQRT(D*D-U*V)
      W=DSQRT( DMAX1( D*D-U*V, 0.0D0) )
      ALPHA=ETA*(1.0D0-(V+W-D)/(V-U+2.D0*W))
      DO 60 I=1,M
      SIG(I)=-1.0D0*ALPHA*SIG(I)
      X(I)=X(I)+SIG(I)
60    ZN(I)=Z(I)
      CALL GRAD(X,Z)
      CALL CHISQQ(X,G)
      T1=0.0D0
      DO 70 I=1,M
      XI(I)=Z(I)-ZN(I)
70    T1=T1+XI(I)*SIG(I)
      DO 80 I=1,M
80    SIGT(I)=SIG(I)/T1
      T1=0.0D0
      DO 90 I=1,M
      T2=0.0D0
      DO 100 J=1,M
100   T2=T2+XI(J)*Y(I,J)
      ZN(I)=T2
90    T1=T1+ZN(I)*XI(I)
      DO 110 I=1,M
      T2=0.0D0
      DO 120 J=1,M
120   T2=T2+XI(J)*Y(J,I)
110   ZNT(I)=T2/T1
      DO 131 I=1,M
      DO 130 J=1,M
130   Y(I,J)=Y(I,J)+SIG(I)*SIGT(J)-ZN(I)*ZNT(J)
131   CONTINUE
C-
200   CONTINUE
C-
      RETURN
      END
C---  GRAD
C
      SUBROUTINE GRAD( AB, V )
C-
      IMPLICIT DOUBLE PRECISION ( A-H, O-Z )
      REAL SINLAM, SCAT
      COMMON/SCACO1/ NSCOEF,SINLAM(30),SCAT(30)
      DIMENSION AB(10),V(10)
C--
      MAXX = MIN0( 9, NSCOEF )
      DO 30 K=1,MAXX,2
      V(K) = 0.0D0
      DO 20 I=1,NSCOEF
      V(K) = V(K) + SCAT(I)
      DO 20 J=1,MAXX,2
      V(K) = V(K) - AB(J) * DEXP( -AB(J+1) * SINLAM(I)**2 )
20    CONTINUE
      V(K) = -2.0D0 * V(K) * DEXP( -AB(K+1) * SINLAM(K)**2 )
      V(K+1)=-V(K)*SINLAM(K)**2*AB(K)
30    CONTINUE
      NN = MAXX + 1
      DO 10 I=NN,10
10    V(I)=0.0D0
      RETURN
      END
C---  CHISQQ
C
      SUBROUTINE CHISQQ( AB, G )
C-
      IMPLICIT DOUBLE PRECISION ( A-H, O-Z )
      REAL SINLAM, SCAT
      COMMON/SCACO1/ NSCOEF,SINLAM(30),SCAT(30)
      DIMENSION AB(10)
C-
      MAXX = MIN0( 9, NSCOEF )
      G = 0.0D0
      DO 30 I=1,NSCOEF
      T = SCAT(I)
      DO 20 J=1,MAXX,2
20    T = T - AB(J)*DEXP( -AB(J+1) * SINLAM(I)**2 )
      G = G + T * T
30    CONTINUE
C--
      RETURN
      END
C---  PROGRAM: RIETVELD  (RIET12)
C---  VERSION: 881001  (YYMMDD)
C---
      SUBROUTINE LOOKUP( NSCTOT )
C-
      INCLUDE 'RIETCOM.FOR'
C-
      NATOM = NATM(1,IPHASE)
      IOF   = NATM(2,IPHASE) - 1
      IF( JOBXN.EQ.2 .OR. JOBXN.EQ.4 ) GO TO 70
C-
C-  SCATTERING COEFFICIENTS  *X-RAY*
C-
      DO 10 I=1,NATOM
      IPIOF = I + IOF
C-
C-  LOOK FOR NAME AS USER SUPPLIED OR ALREADY TABLED
      DO 20 J=1,NSCTOT
      IF(QATTYP(IPIOF).EQ.QSCNAM(J)) THEN
        KPTR(IPIOF) = J
        GO TO 10
      ENDIF
20    CONTINUE
C-
C-  LOOK FOR NAME IN INTERNAL TABLES
      DO 40 J=1,212
40    IF(QATTYP(IPIOF).EQ.QTBX(J)) GO TO 50
      WRITE(IOTTO,41) QATTYP(IPIOF)
41    FORMAT(' --SCATTERING COEFFICIENTS NOT FOUND FOR ',A4)
      STOP '--SCATTERING COEFFICIENTS NOT FOUND FOR AN ATOM'
C-
C-  USE INTERNAL TABLE VALUES
50    NSCTOT = NSCTOT + 1
      KPTR(IPIOF) = NSCTOT
      DO 60 L=1,9
60    SCATAC(L,NSCTOT)  = TBX(J,L)
      SCATAC(10,NSCTOT) = 0.0
      QSCNAM(NSCTOT) = QTBX(J)
      INDEX          = INT( TBX(J,10) + 0.5 )
      DFP(NSCTOT)    = TBD( INDEX, IXRAY )
      DFPP(NSCTOT)   = TBD( INDEX, IXRAY+5 )
C *
C *  NEXT ATOM
10    CONTINUE
      GO TO 9000
C-
C--  LOOKUP SCATTERING LENGTHS  *NEUTRON*
C-
70    DO 80 I=1,NATOM
      IPIOF = I + IOF
C-
C-  LOOK FOR USER SUPPLIED OR ALREADY TABLED
      DO 90 J=1,NSCTOT
      IF(QATTYP(IPIOF).EQ.QSCNAM(J)) THEN
        KPTR(IPIOF) = J
        GO TO 80
      ENDIF
90    CONTINUE
C-
C-  LOOKUP IN INTERNAL TABLE
      DO 110 J=1,85
110   IF(QATTYP(IPIOF).EQ.QTABN(J)) GO TO 120
      WRITE(IOTTO,111) QATTYP(IPIOF)
111   FORMAT(' --SCATTERING LENGTHS NOT FOUND FOR ',A4)
      STOP '--SCATTERING LENGTHS NOT FOUND FOR AN ATOM'
C-
C-  USE VALUES FROM INTERNAL TABLES
120   NSCTOT         = NSCTOT + 1
      KPTR(IPIOF)    = NSCTOT
      DFP(NSCTOT)    = TABN(J)
      QSCNAM(NSCTOT) = QTABN(J)
C-
C-  NEXT ATOM
80    CONTINUE
C-
9000  RETURN
      END
C---  PROGRAM: RIETVELD  (RIET13)
C---  VERSION: 881001  (YYMMDD)
C---
      SUBROUTINE CELL2( CELDIR, CELREC )
C-
      COMMON/SPGCOM/NLAUGR,NORAXS,NCONT(10),NSPCNT,NSPPOL,NSPMLT
      COMMON/IOLUNS/ IOTTI,IOTTO,IODCF,IOPTN,IOBKG,IOALT,IOPLT,IONEW
      DIMENSION CELDIR(6),CELREC(3,3)
C-
      SIN1(A) = SIN(A*6.28318531)
      COS1(A) = COS(A*6.28318531)
C-
C-  SET RECIPROCAL CELL ELEMENTS TO ZERO
C   (CELREC(1,1),ASTAR**2)
C   (CELREC(1,2),2*BACOSC) (CELREC(2,2),BSTAR**2)
C   (CELREC(1,3),2*CACOSB) (CELREC(2,3),2*BCCOSA) (CELREC(3,3),CSTAR**2)
      DO 1 I=1,3
      DO 1 J=1,3
1     CELREC(J,I) = 0.0
C-
      IF ( NORAXS.GT.3 ) STOP 5001
      GO TO (1002,1071,1072,1073,1073,1074,1074,1075,1075,1075,1075,
     1       1075,1076,1076),NLAUGR
C-
1071  IF ( NORAXS.NE.1 ) CELDIR(4) = 90.0
      IF ( NORAXS.NE.2 ) CELDIR(5) = 90.0
      IF ( NORAXS.NE.3 ) CELDIR(6) = 90.0
      GO TO 1002
C-
1073  CELDIR(2) = CELDIR(1)
1072  CELDIR(4) = 90.0
      CELDIR(5) = 90.0
      CELDIR(6) = 90.0
      GO TO 1002
C-
1074  CELDIR(2) = CELDIR(1)
      CELDIR(3) = CELDIR(1)
      CELDIR(5) = CELDIR(4)
      CELDIR(6) = CELDIR(4)
      GO TO 1002
C-
1075  CELDIR(2) = CELDIR(1)
      CELDIR(4) = 90.0
      CELDIR(5) = 90.0
      CELDIR(6) = 120.0
      GO TO 1002
C-
1076  CELDIR(2) = CELDIR(1)
      CELDIR(3) = CELDIR(1)
      GO TO 1072
C-
1002  COSA = COS1(CELDIR(4)/360.0)
      COSB = COS1(CELDIR(5)/360.0)
      COSC = COS1(CELDIR(6)/360.0)
      SINA = SQRT(1.0-COSA**2)
      SINB = SQRT(1.0-COSB**2)
      SINC = SQRT(1.0-COSC**2)
      COSASR = (COSB*COSC-COSA)/(SINB*SINC)
      COSBSR = (COSA*COSC-COSB)/(SINA*SINC)
      COSCSR = (COSA*COSB-COSC)/(SINA*SINB)
      SINASR = SQRT(1.0-COSASR**2)
      SINBSR = SQRT(1.0-COSBSR**2)
      CELREC(1,1) = 1.0/(CELDIR(1)*SINC*SINBSR)
      CELREC(2,2) = 1.0/(CELDIR(2)*SINC*SINASR)
      CELREC(3,3) = 1.0/(CELDIR(3)*SINA*SINBSR)
      CELREC(2,3) = CELREC(2,2)*CELREC(3,3)*COSASR*2.0
      CELREC(1,3) = CELREC(3,3)*CELREC(1,1)*COSBSR*2.0
      CELREC(1,2) = CELREC(2,2)*CELREC(1,1)*COSCSR*2.0
      CELREC(1,1) = CELREC(1,1)*CELREC(1,1)
      CELREC(2,2) = CELREC(2,2)*CELREC(2,2)
      CELREC(3,3) = CELREC(3,3)*CELREC(3,3)
C-
      RETURN
      END
C---  PROGRAM: RIETVELD  (RIET14)
C---  VERSION: 881001  (YYMMDD)
C---
      SUBROUTINE REFGEN( CELDIR, CELREC )
C-
      INTEGER H1,H2,H3
      CHARACTER QLAUE(14)*8
      CHARACTER QLAUGR*8
      PARAMETER( RTODT2 = 114.5915590 )
      PARAMETER ( DTORD2=8.72664626E-03, RTOD=5.729577951E+1 )
      PARAMETER( MNPTS=5120, MREFS=1024, MATMS=48, MMATX=48, MPHAS=4 )
      COMMON/CPTND2/ THMIN,STEP,THMAX,CTIME
      COMMON/WSGSS/ KWSGON
      COMMON/CCNTD1/ JOBXN,EPS,RELAX(4)
      COMMON/SPGCOM/NLAUGR,NORAXS,NCONT(10),NSPCNT,NSPPOL,NSPMLT
      COMMON/KLUDGE/ IFNEW,IHNEW,IKNEW,ILNEW
      COMMON/CRFDT4/ KREFRN(MNPTS),KREFDT(MREFS),KREFNM(MPHAS)
      COMMON/CCNTD2/ RADWAV(2),RADREL(2),PMCCOR,WDTTHK
      COMMON/CPSFD5/ PPHUVW(3,2,MPHAS),PPHPSF(3,2,MPHAS)
      COMMON/CRFDT3/ PREFTT(MREFS),PREFLP(MREFS)
      COMMON/PGMDT1/ IPHASE,IORD1,IORD2,IORDC,MODNRF
      COMMON/CRFDT1/ QLAUGR(MPHAS)
      COMMON/CRFDT2/ KINDRF(MPHAS)
      COMMON/HKLCTL/ KZZ(3,24),AZ(24),NCCNT(10,7),ICQ,N1,IER,HN
      COMMON/CSRDT1/ F2TOT(MREFS),F2STR(MREFS),F2MAG(MREFS)
      COMMON/IOLUNS/ IOTTI,IOTTO,IODCF,IOPTN,IOBKG,IOALT,IOPLT,IONEW
      DIMENSION MLTT(MREFS)
      DIMENSION CELDIR(6),CELREC(3,3), IVI(3),IVO(3,48)
      EQUIVALENCE ( MLTT, F2TOT ), (IVI(1),H1),(IVI(2),H2),(IVI(3),H3)
C-
      DATA  QLAUE( 1),  QLAUE( 2),  QLAUE( 3),  QLAUE( 4), QLAUE( 5)
     1   / '1Bar    ', '2/M     ', 'MMM     ', '4/M     ', '4/MMM   ' /
      DATA  QLAUE( 6),  QLAUE( 7),  QLAUE( 8),  QLAUE( 9), QLAUE(10)
     1   / '3Bar R  ', '3Bar M R', '3Bar    ', '3Bar M 1', '3Bar 1 M' /
      DATA  QLAUE(11),  QLAUE(12),  QLAUE(13),  QLAUE(14)
     1   / '6/M     ', '6/MMM   ', 'M3      ', 'M3M     ' /
      SIN1(A) = SIN(A*6.28318531)
C-
C-  IFNEW - REFLECTION FLAG FOR ADDITIONAL LINES
      IFNEW = 0
C-
      IF ( NORAXS.GT.3 ) STOP 5001
      KXIS = NORAXS
      NORAXS = 1
1002  N = 0
      J = 0
      I2D = 0
      I3D = 0
      I1D = 1
      I12D = 1
      I13D = 1
      I123D = 1
      I23D = 1
      I2DEL = 1
      I3DEL = 1
      DO 8000 I=1,8
      IF ( NCONT(I).EQ.0 ) GO TO 9000
      IF ( NCONT(I)-8192 ) 8002,8001,8000
8001  I3DEL = 3
      I1D = 2
      I123D = 3
      GO TO 9000
8002  IF ( NCONT(I)-576 ) 8004,8003,8004
8003  I3DEL = 2
      I23D = 2
      GO TO 8000
8004  IF ( NCONT(I)-516 ) 8008,8009,8008
8009  I3DEL = 2
      I13D = 2
      GO TO 8000
8008  IF ( NCONT(I)-68 ) 8012,8013,8012
8012  IF ( NCONT(I)-580 ) 8015,8016,8015
8013  I2DEL = 2
      I12D = 2
      GO TO 8000
8016  I123D = 2
      I3DEL = 2
8015  CONTINUE
8000  CONTINUE
9000  N = J - 1
C-
C-  DETERMINE MIN AND MAX BASED ON THT MIN AND MAX.  CHECK FOR ALHPA2
97    SMIN = ( SIN1( THMIN/720.0 ) / RADWAV(1) )**2
      SMAX = ( SIN1( THMAX/720.0 ) / RADWAV(1) )**2
      IF(RADWAV(2).GT.RADWAV(1))
     1  SMIN = SMIN * ( RADWAV(1)/RADWAV(2) )**2
      IF( RADWAV(2).GT.0.0 .AND. RADWAV(2).LT.RADWAV(1) )
     1  SMAX = SMAX * ( RADWAV(1)/RADWAV(2) )**2
C-
C-  COUNT THE REFLECTIONS
      IC = 0
      IF(IPHASE.GT.1) THEN
        DO 98 ITMP=1,(IPHASE-1)
98      IC = IC + KREFNM(ITMP)
      ENDIF
      ISTART = IC
C-
      CALL OP1
      QLAUGR(IPHASE) = QLAUE(NLAUGR)
      WRITE(IOTTO,36) QLAUGR(IPHASE)
36    FORMAT(/,' Laue symmetry ',A8,' will be used to generate indices')
      I1MAX = CELDIR(1) * 2.0 * SQRT(SMAX)
      I2MAX = CELDIR(2) * 2.0 * SQRT(SMAX)
      I3MAX = CELDIR(3) * 2.0 * SQRT(SMAX)
      L1 = NLAUGR
      IF ( L1.GE.13 .AND. NCONT(1).EQ.580 ) L1 = L1 + 2
      IF ( I12D+I13D+I23D .NE. 5 ) GO TO 2131
      I12D = 2
      I13D = 1
      I23D = 2
      I2DEL = 2
      I3DEL = 2
2131  IF ( L1.EQ.6 ) I2D = 1
      IF ( L1.EQ.7 ) I2D = 2
      I3D = I2D
      I1 = -1
2200  I1 = 1 + I1
      IF ( I1-I1MAX ) 2201,2201,2303
2201  H1 = I1
C-
      IF ( I2D.GT.0 ) I2MAX = I1
      GO TO (2203,2204,2204,2205,2206,2208,2209,2207,2204,2206,2204,
     1       2206,2206,2206,2206,2206),L1
2203  I2 = -MIN0( I2MAX, I1*I2MAX )
      GO TO 2210
2204  I2 = 0
      GO TO 2210
2205  I2 = MIN0( I1, 1 )
      GO TO 2210
2206  I2 = I1
      GO TO 2210
2207  I2 = MIN0( -I1+1, 0 )
      GO TO 2210
2208  I2 = -2 * I1
      GO TO 2210
2209  I2 = -I1 / 2
2210  I2 = I2DEL * ( I2/I2DEL ) + MOD( I1, I12D )
      GO TO 2221
2220  I2 = I2DEL + I2
2221  H2 = I2
      IF ( I2-I2MAX ) 2222,2222,2200
C-
2222  GO TO (2223,2223,2224,2224,2224,2225,2225,2224,2224,2223,2224,
     1       2224,2226,2227,2236,2235),L1
COLD
C2223  I3 = -MIN0( I3MAX, (I1+IABS(I2)) * I3MAX )
COLD
CNEW
2223  I3 = -MIN0( I3MAX, I1*I3MAX )
CNEW
      GO TO 2228
2224  I3 = 0
      GO TO 2228
2225  I3 = -I1 - I2
      GO TO 2228
2226  I3 = MIN0( I2, I1+I3DEL )
      GO TO 2228
2227  I3 = I2
2228  I3 = I3DEL*(I3/I3DEL) + MOD(MOD(I1+I1D*I2,I123D)+I123D,I123D)
     1    + MOD(I1,I13D) + MOD(I2,I23D)
      IF ( I3D-1 ) 2232,2229,2231
2229  I3MAX = I1
      IF ( I2-I1 ) 2230,2232,2230
2230  I3MAX = I3MAX - 1
      GO TO 2232
2231  I3MAX = I2
      GO TO 2232
2235  I3 = I2 + MOD(I1,2)
      GO TO 2232
2236  I3 = I1 + 2 - MOD(I2,2)
      IF ( I1.EQ.I2 .AND. MOD(I1,2).EQ.0 ) I3 = I1
      GO TO 2232
2233  I3 = I3DEL + I3
2232  H3 = I3
C-
      IF ( KXIS.NE.3 ) GO TO 2240
      H3 = I2
      H2 = I3
2240  CONTINUE
      IF ( I3-I3MAX ) 113,113,2220
C-
113   SQ = REAL(H1*H1)*CELREC(1,1) + REAL(H2*H2)*CELREC(2,2)
     1   + REAL(H3*H3)*CELREC(3,3) + REAL(H1*H2)*CELREC(1,2)
     1   + REAL(H1*H3)*CELREC(1,3) + REAL(H2*H3)*CELREC(2,3)
      SQ = SQ / 4.0
2234  IF ( SQ - SMAX ) 3000,3000,2233
3000  IF ( SQ - SMIN ) 2233,3117,3117
C-
3117  IF ( IC .GT. MREFS-2 ) GO TO 6001
      KZZ(1,1) = H1
      KZZ(2,1) = H2
      KZZ(3,1) = H3
      AZ(1) = 0.0
      IER = 0
      CALL SMTRY2
      IF(IER.NE.0) GO TO 2233
C-
C-  ASSIGN REFLECTIONS BASED ON WAVELENGTHS IN TABLE.  IF THE ALPHA1/ALPHA2
C-    RATIO IS ZERO, THEN DO NOT USE AN ALPHA 2 COMPONENT
C-
9875  IHNEW = 0
      IKNEW = 0
      ILNEW = 0
9876  LXN = 2
      IF( RADWAV(2).EQ.0.0 .OR. RADWAV(2).EQ.RADWAV(1) ) LXN = 1
      IF(KWSGON.EQ.1) LXN = 1
      DO 3118 LX1=1,LXN
      SQH = SQ * RADWAV(LX1) * RADWAV(LX1)
      TAN2 = SQH / ( 1.0 - SQH )
      IF(SQH.GE.1.0) GO TO 3118
      TANX = SQRT(TAN2)
      POS = ATAN(TANX) * RTODT2
      IF( POS.LT.THMIN .OR. POS.GT.THMAX ) GO TO 3118
C-
C-  ENSURE THE LINE IS NOT REDUNDANT WITH ONE ALREADY IN LIST
      CALL GNLARE( QLAUGR(IPHASE), IVI, IVO, NTMP )
      DO 8010 IRED=1,IC
      IPHS = KREFDT(IRED)/67108864
      IF(IPHS.NE.IPHASE) GO TO 8010
      IWAV = IAND( KREFDT(IRED)/16777216, 3 )
      IF(IWAV.NE.LX1   ) GO TO 8010
      IHHH = IAND( KREFDT(IRED)/65536, 255 ) - 128
      IKKK = IAND( KREFDT(IRED)/256,   255 ) - 128
      ILLL = IAND( KREFDT(IRED),       255 ) - 128
      DO 8020 IHKL=1,NTMP
      IF(IHHH.NE.IVO(1,IHKL)) GO TO 8020
      IF(IKKK.NE.IVO(2,IHKL)) GO TO 8020
      IF(ILLL.NE.IVO(3,IHKL)) GO TO 8020
      IF(KDEBUG.EQ.1) WRITE(IOTTO,8040) H1,H2,H3,(IVO(J,IHKL),J=1,3)
8040  FORMAT(
     1 ' --REFGEN: Line (',3I3,') is redundant with line (',3I3,')')
      GO TO 3118
8020  CONTINUE
8010  CONTINUE
C-
C-  REPEAT FOR EACH LAUE-SYMMETRY EQUIVALENT REFLECTION IF REQUIRED
      IF(KINDRF(IPHASE).EQ.1) THEN
        NHKL = NTMP
       ELSE IF(KINDRF(IPHASE).EQ.2) THEN
        NHKL = 1
        DO 3115 NTMPI=2,NTMP
        DO 3116 NTMPJ=1,NHKL
        IF( IVO(1,NTMPI).EQ.-IVO(1,NTMPJ) .AND.
     1      IVO(2,NTMPI).EQ.-IVO(2,NTMPJ) .AND.
     1      IVO(3,NTMPI).EQ.-IVO(3,NTMPJ)       ) GO TO 3115
3116    CONTINUE
        NHKL = NHKL + 1
        IVO(1,NHKL) = IVO(1,NTMPI)
        IVO(2,NHKL) = IVO(2,NTMPI)
        IVO(3,NHKL) = IVO(3,NTMPI)
3115    CONTINUE
       ELSE
        NHKL = 1
        IVO(1,1) = H1
        IVO(2,1) = H2
        IVO(3,1) = H3
      ENDIF
      DO 3119 NNHKL=1,NHKL
      H1 = IVO(1,NNHKL)
      H2 = IVO(2,NNHKL)
      H3 = IVO(3,NNHKL)
C-
C-  INCREMENT THE REFLECTION COUNTER
      IF(IC+1.GT.MREFS-1) GO TO 6001
      IC = IC + 1
C-
C-  STORE THE LINE POSITION
      PREFTT(IC) = POS
C-
C-  LORENTZ/POLARIZATION FACTORS
      PREFLP(IC) = PLORNZ( POS )
C-
C-  PACK HKL AND PHASE ID INTO IREFS
      KREFDT(IC)=256*(256*(256*(4*IPHASE+LX1)+128+H1)+128+H2)+128+H3
C-
C-  STORE THE MULTIPLICITIES
      IF(KINDRF(IPHASE).EQ.1) THEN
        MLTT(IC) = 1
       ELSE IF(KINDRF(IPHASE).EQ.2) THEN
        MLTT(IC) = 2
       ELSE
        IF(IFNEW.EQ.0) THEN
          MLTT(IC) = MLTHKL( H1, H2, H3 )
          IF( KDEBUG.EQ.1 .AND.  MLTT(IC).NE.NTMP ) THEN
            WRITE(IOTTO,3114) H1,H2,H3,MLTT(IC),NTMP,
     1      ((IVO(J,I),J=1,3),I=1,NTMP)
3114        FORMAT(
     1      ' --REFGEN: Line (',3I3,') multiplicities do not agree:',
     1      '  MLTT= ',I2,' NHKL= ',I2,/,
     1      (1X,3I3,2X,3I3,2X,3I3,2X,3I3,2X,3I3,2X,3I3))
          ENDIF
          MLTT(IC) = NTMP
         ELSE
          MLTT(IC) = MLTT(IC-1)
        ENDIF
      ENDIF
C-
C-  NEXT LAUE SYMMETRY EQUIVALENT REFLECTION
3119  CONTINUE
      H1 = IVO(1,1)
      H2 = IVO(2,1)
      H3 = IVO(3,1)
C-
C-  NEXT WAVELENGTH
3118  CONTINUE
C-
C-  TEST FOR NEWLY ADDED REFLECTION
      IF(IFNEW.EQ.1) THEN
        IF( IHNEW.EQ.0 .AND. IKNEW.EQ.0 .AND. ILNEW.EQ.0 ) THEN
          IFNEW = 0
          GO TO 2233
        ENDIF
        H1 = IHNEW
        H2 = IKNEW
        H3 = ILNEW
        IHNEW = 0
        IKNEW = 0
        ILNEW = 0
        WRITE(IOTTO,8050) H1,H2,H3
8050    FORMAT(/,
     1  ' --REFGEN: Line (',3I3,') added to reflection list.')
        GO TO 9876
      ENDIF
C-
C-  NEXT REFLECTION
      GO TO 2233
C-
6001  WRITE(IOTTO,24)
24    FORMAT(/,
     1' --THE NUMBER OF REFLECTIONS GENERATED EXCEEDS THE CAPABILITY',
     1' OF THIS PROGRAM.',/,
     1'   INCREASE THE VALUE OF *MREFS* ON ALL PARAMETER STATEMENTS TO',
     1' SUIT YOUR NEEDS.',/)
C-
C-  ALL DONE.  RETURN TO CALLER
2303  KREFNM(IPHASE) = IC - ISTART
      WRITE(IOTTO,2305) KREFNM(IPHASE)
2305  FORMAT('  The number of reflections for this phase is ',I5)
      CALL SORT( IPHASE )
      RETURN
C-
      END
      SUBROUTINE OP1
C
C                             THIS SR GENERATES THE OPERATORS FOR
C                           SMTRY2, DETERMINES THE POLARITY OF THE SPACE
C                           GROUP, NOTES THE PRESENCE OF A CENTER(1BAR),
C                           AND GENERATES A SET OF PSEUDO-OPERATORS FOR
C                           USE IN SYMOPR TO DEFINE SITE SYMMETRY.
      COMMON/SPGCOM/NLAUGR,NORAXS,NCONT(10),NSPCNT,NSPPOL,NSPMLT
      COMMON/BLNK1/N(581),NCTR(192)
      COMMON /HKLCTL/KZZ(4,24),NCCNT(10,7),IC,N1,IER,HN
      K = 2
      NSPPOL = 7
      DO 40 I=1,7
40    NCCNT(1,I) = 0
      NCTR(1) = 0
      DO 100 I=1,8
      IF ( NCONT(I).LE.0 ) GO TO 101
      IF ( NCONT(I).LT.8192 ) GO TO 80
      IF ( NCONT(I).LE.08192 ) GO TO 60
      IF ( NCONT(I).EQ.16384 ) GO TO 70
      NSPPOL = 4
      NCCNT(I,1) = 2
50    DO 51 J=2,7
51    NCCNT(I,J) = 0
      NCCNT(I,6) = MOD(NCONT(I)/4,32)
      GO TO 90
60    NCCNT (I,1) = 3
      NSPPOL = 1
      GO TO 50
70    NCCNT(I,1) = 1
      GO TO 50
80    NCCNT(I,1) = 0
      NCCNT(I,2) = MOD(NCONT(I),4)
      NCCNT(I,3) = MOD(NCONT(I)/4,4)
      NCCNT(I,4) = MOD(NCONT(I)/16,4)
      NCCNT(I,5) = MOD(NCONT(I)/64,4)
      NCCNT(I,6) = MOD(NCONT(I)/256,2)
      NCCNT(I,7) = MOD(NCONT(I)/512,16)
90    CONTINUE
      L = K-1
      DO 100 J=1,L
      IF ( NCONT(I).EQ.8192 ) GO TO 95
      NCTR(K) = IAND( IEOR(NCONT(I),NCTR (J  )),57651)
      IF(IAND(NCONT(I),17).EQ.0) GO TO 92
      IF(IAND(NCTR(J),34).EQ.0) GO TO 92
      IF(IAND(NCTR(J),34).EQ.34) GO TO 92
      NCTR(K)= IEOR(NCTR(K),34)
92    CONTINUE
      K = K+1
      IF ( NCONT(I).LT.8192 ) GO TO 100
      NCTR(K) = NCTR(K-1)+32768
      K = K+1
      GO TO 100
95    CONTINUE
      NCTR(K  ) = 0
      NCTR(K+1) = 0
      K = K+2
100   CONTINUE
101   NSPMLT = K-1
      N1 = I-1
      IF ( N1.LT.2 ) GO TO 105
      DO 102 N2=2,N1
      IF ( NCCNT(N2-1,1).EQ.1 ) GO TO 103
102   CONTINUE
      GO TO 105
103   DO 104 I=N2,N1
      DO 104 J=1,7
104   NCCNT(I-1,J) = NCCNT(I,J)
      NCCNT(N1,1) = 1
105   CONTINUE
      NSPCNT = 1
      DO 200 I=1,NSPMLT
      IF (  IEOR(NCTR(I),290).EQ.0 ) NSPCNT = 0
      IF ( IAND(NCTR(I),3).GT.0 ) NSPPOL = IAND(NSPPOL,6)
      IF ( IAND(NCTR(I),48).GT.0 ) NSPPOL = IAND(NSPPOL,5)
200   IF ( IAND(NCTR(I),256).GT.0 ) NSPPOL = IAND(NSPPOL,3)
      RETURN
      END
      SUBROUTINE SMTRY2
C                             THIS SR GENERATES THE FULL SET OF
C                           EQUIVALENT HKLS FROM ANY MEMBER OF THE SET.
C                           IT ALSO DETERMINES THE PHASE SHIFTS RELATIVE
C                           TO THE INPUT HKL PHASE.
      COMMON/HKLCTL/KZZ(3,24),A(24),NCCNT(10,7),IC,N1,IER,HM
      COMMON/SPGCOM/NLAUGR,NORAXS,NCONT(10),NSPCNT,NSPPOL,NSPMLT
      DIMENSION KD(6),KE(3),KF(3)
      DIMENSION NCH(24),NCK(24),NCL(24)
      DIMENSION LD(3,24)
      DIMENSION KPH(24)
      DATA KD(1),KD(2),KD(3),KD(4),KD(5),KD(6)/0,6,3,9,4,8/
      DATA KE(1),KE(2),KE(3),KF(1),KF(2),KF(3)/0,4,8,0,8,4/
CDB 1
C   1 FORMAT (7I5,F10.5,10I3)
      IF ( NSPCNT.GT.0 ) GO TO 14
      IF ( KZZ(1,1) ) 11,9,14
9     IF ( KZZ(2,1) ) 12,10,14
10    IF ( KZZ(3,1) ) 13,14,14
11    KZZ(1,1) = -KZZ(1,1)
12    KZZ(2,1) = -KZZ(2,1)
13    KZZ(3,1) = -KZZ(3,1)
14    CONTINUE
      KPH(1) = KZZ(3,1)+512*(KZZ(2,1)+512*KZZ(1,1))
      CI = 1.0
      IC = 1
      A(1) = 0.0
      LD(1,1) = 0
      LD(2,1) = 0
      LD(3,1) = 0
      NCH(1) = 0
      NCK(1) = 0
      NCL(1) = 1
      IF ( N1.EQ.0 ) GO TO 1000
      L = 2
      DO 900 I=1,N1
      CI = CI*2.0
      IF ( NCCNT(I,1).GT.0 ) CI = CI*1.5
      DO 890 J=1,IC
      NCO = NCCNT(I,1)+1
      GO TO (20,700,800,15),NCO
C     CALL GOTOER
15    IF(MOD(KZZ(1,1)-KZZ(2,1)-KZZ(3,1),3).NE.0 ) GO TO 1002
      GO TO 900
20    NCH(L) =  IEOR(NCH(J),NCCNT(I,2))
      IF ( MOD(NCCNT(I,2),2).NE.0 ) NCH(L)= IEOR(NCK(J),NCCNT(I,2))
      M = 1+MOD(NCH(L),2)
      MS = 1-2*MOD(NCH(L)/2,2)
      N = IABS(NCL(J))
      KZZ(M,L) = KZZ(1,N)*MS
      M = 1+MOD(NCCNT(I,2),2)
      MS = 1-2*MOD(NCCNT(I,2)/2,2)
      NCX = NCCNT(I,3)+1
      LD(1,L) = KD(NCX)+LD(M,J)*MS
      NCK(L) =  IEOR(NCK(J),NCCNT(I,4))
      IF ( MOD(NCCNT(I,4),2).NE.0 ) NCK(L)= IEOR(NCH(J),NCCNT(I,4))
      M = 2-MOD(NCK(L),2)
      MS = 1-2*MOD(NCK(L)/2,2)
      KZZ(M,L) = KZZ(2,N)*MS
      M = 2-MOD(NCCNT(I,4),2)
      MS = 1-2*MOD(NCCNT(I,4)/2,2)
      NCX = NCCNT(I,5)+1
      LD(2,L) = KD(NCX)+LD(M,J)*MS
      MS = (1-2*NCCNT(I,6))*ISIGN(1,NCL(J))
      NCL(L) = MS*NCL(N)
      KZZ(3,L) = KZZ(3,N)*MS
70    NCO = NCCNT(I,7)+1
      IF ( NCO.GT.5 ) NCO=6
      MS = 1-2*NCCNT(I,6)
      IF ( N.GT.1.AND.NCK(J).GE.4.AND.M.EQ.1 ) MS=-MS
      LD(3,L) = KD(NCO)+LD(3,J)*MS
80    IXIT = 0
81    CONTINUE
      KPH(L) = KZZ(3,L)+512*(KZZ(2,L)+512*KZZ(1,L))
87    LA = LD(1,L)*KZZ(1,1)+LD(2,L)*KZZ(2,1)+LD(3,L)*KZZ(3,1)
      A(L) = REAL(LA)/12.0
CDB 2
C     IF ( J1(20).GT.0 ) PRINT 1,L,(KZZ(M,L),M=1,3),(LD(M,L),M=1,3),A(L),
C    Z NCH(L),NCK(L),NCL(L),(NCCNT(I,M),M=1,7)
      IF ( NSPCNT.NE.0 ) GO TO 89
      IF ( NLAUGR.LT.12 ) GO TO 89
      IF ( NCCNT(I,1).GT.0 ) GO TO 89
      IF ( MOD(NCCNT(I,2),2).EQ.1 ) GO TO 89
      IF ( KPH(L).LE.0 ) GO TO 680
89    CONTINUE
      DO 90 M=2,L
      IF ( KPH(M-1).EQ.KPH(L) ) GO TO 690
      IF ( NSPCNT.NE.0 ) GO TO 90
      IF ( KPH(M-1).EQ.-KPH(L) ) GO TO 690
90    CONTINUE
      L = L+1
680   IF ( IXIT-1 ) 890,750,850
690   IF ( AMOD(ABS(A(L)-A(M-1)),1.).NE.0. ) GO TO 1002
      GO TO 680
700   IXIT = 2
      JD = J
750   IXIT = IXIT-1
      LD(1,L) = LD(1,JD)
      LD(2,L) = LD(2,JD)
      LD(3,L) = LD(3,JD)
      NCH(L) = 0
      NCK(L) = 0
      NCL(L) = L
      K1JD = KZZ(1,JD)
      KZZ(1,L) = KZZ(2,JD)
      KZZ(2,L) = KZZ(3,JD)
      KZZ(3,L) = K1JD
      JD = L
      GO TO 81
800   IXIT = 4
      JD = J
      NCO = NCCNT(I,6)
850   IXIT = IXIT-2
      NCH(L) = 0
      NCK(L) = 4
      NCL(L) = L
      LD(1,L) = 0
      LD(2,L) = 0
      KZZ(1,L) = -KZZ(1,JD)-KZZ(2,JD)
      KZZ(2,L) = KZZ(1,JD)
      KZZ(3,L) = KZZ(3,JD)
      LD(3,L) = KF(NCO)+LD(3,JD)
      IF ( MOD(NCH(J),2).NE.0 ) LD(3,L)=KE(NCO)+LD(3,JD)
      JD = L
      GO TO 81
890   CONTINUE
900   IC = L-1
1000  IER = 0
      HM = CI/REAL(IC)
      IF ( NSPCNT.NE.0 ) GO TO 1001
      DO 1003 M=2,IC
      IF ( KPH(M).GT.0 ) GO TO 1003
      KZZ(1,M) = -KZZ(1,M)
      KZZ(2,M) = -KZZ(2,M)
      KZZ(3,M) = -KZZ(3,M)
1003  CONTINUE
1001  RETURN
1002  IER = 1
      GO TO 1001
      END
C--  SORT
C-
      SUBROUTINE SORT( IPHASE )
C-
      PARAMETER( MNPTS=5120, MREFS=1024, MATMS=48, MMATX=48, MPHAS=4 )
      COMMON/CRFDT4/ KREFRN(MNPTS),KREFDT(MREFS),KREFNM(MPHAS)
      COMMON/CRFDT3/ PREFTT(MREFS),PREFLP(MREFS)
      COMMON/CSRDT1/ F2TOT(MREFS),F2STR(MREFS),F2MAG(MREFS)
      COMMON TEMP(MREFS),L(MREFS)
      DIMENSION ITEMP(MREFS),MLTT(MREFS)
      EQUIVALENCE ( ITEMP, TEMP ), ( MLTT, F2TOT )
C-
      IOF = 0
      IF(IPHASE.GT.1) THEN
        DO 1 ITMP=1,(IPHASE-1)
1       IOF = IOF + KREFNM(ITMP)
      ENDIF
      IC = KREFNM(IPHASE)
      DO 2 I=1,IC
2     L(I) = I
C-
      M = IC - 1
      DO 15 LL=1,5000
      K = 0
      DO 10 J=1,2
      DO 10 I=J,M,2
      INP = L(I) + IOF
      INP1 = L(I+1) + IOF
      R = PREFTT(INP1) - PREFTT(INP)
      IF(R) 20,10,10
20    IZ = L(I)
      L(I) = L(I+1)
      L(I+1) = IZ
      K = K + 1
10    CONTINUE
      IF(K.EQ.0) GO TO 5
15    CONTINUE
C-
C-  UPDATE WAVELENGTHS
5     DO 30 I=1,IC
30    ITEMP(I) = KREFDT(I+IOF)
      DO 31 I=1,IC
      LX = L(I)
      KREFDT(I+IOF) = ITEMP(LX)
31    CONTINUE
C-
C-  UPDATE POSN,L/P
      DO 40 I=1,IC
40    TEMP(I) = PREFTT(I+IOF)
      DO 41 I=1,IC
      LX = L(I)
41    PREFTT(I+IOF) = TEMP(LX)
      DO 42 I=1,IC
42    TEMP(I) = PREFLP(I+IOF)
      DO 43 I=1,IC
      LX = L(I)
43    PREFLP(I+IOF) = TEMP(LX)
C-
C-  UPDATE MULTIPLICITIES
      DO 34 I=1,IC
34    ITEMP(I) = MLTT(I+IOF)
      DO 35 I=1,IC
      LX = L(I)
35    MLTT(I+IOF) = ITEMP(LX)
C-
      RETURN
      END
C--  MLTHKL
C-
      FUNCTION MLTHKL(IH,IK,IL)
C-
      LOGICAL LHZ, LKZ, LLZ
      COMMON/SPGCOM/NLAUGR,NORAXS,NCONT(10),NSPCNT,NSPPOL,NSPMLT
      COMMON/KLUDGE/ IFNEW,IHNEW,IKNEW,ILNEW
      COMMON/IOLUNS/ IOTTI,IOTTO,IODCF,IOPTN,IOBKG,IOALT,IOPLT,IONEW
C-
C-  LOGIC FLAGS, LXZ = INDICE ZERO
      LHZ = IH .EQ. 0
      LKZ = IK .EQ. 0
      LLZ = IL .EQ. 0
C-
      IFNEW = 0
      P = 2.0
      GO TO (220,100,110,120,130,150,180,140,170,160,170,190,200,210),
     *NLAUGR
C-
C--  2/M
C-
C-  IF NORAXS=3 THEN THIS IS A C-AXIS UNIQE
100   IF(NORAXS.EQ.3) THEN
C-    H00, 0K0 AND 00L
        IF((LKZ.AND.LLZ).OR.(LHZ.AND.LLZ).OR.(LHZ.AND.LKZ)) GO TO 220
C-    HOL AND -HOL
        IF( LLZ .AND. (.NOT.LHZ) .AND. (.NOT.LKZ) ) GO TO 220
C-    ALL OTHER MULTIPLICITIES ARE 4
        P = 4.0
       ELSE
C-    H00, 0K0 AND 00L
        IF((LKZ.AND.LLZ).OR.(LHZ.AND.LLZ).OR.(LHZ.AND.LKZ)) GO TO 220
C-    HOL AND -HOL
        IF( LKZ .AND. (.NOT.LHZ) .AND. (.NOT.LLZ) ) GO TO 220
C-    ALL OTHER MULTIPLICITIES ARE 4
        P = 4.0
      ENDIF
      GO TO 220
C-
C--  MMM
C-
C-  H00, 0K0 AND 00L
110   IF( (LKZ.AND.LLZ) .OR. (LHZ.AND.LLZ) .OR. (LHZ.AND.LKZ) )GO TO 220
C-  HKL
      IF( (.NOT.LKZ) .AND. (.NOT.LHZ) .AND. (.NOT.LLZ) ) THEN
        P = 8.0
        GO TO 220
      ENDIF
C-  ALL OTHER MULTIPLICITIES ARE 4
      P = 4.0
      GO TO 220
C-
C-  4/M
120   IF ( IK ) 220,220,121
121   P = 2.0*P
      IF ( IL ) 220,220,122
122   P = 2.0*P
      GO TO 220
C-
C-  4/MMM
130   IF ( IK ) 220,220,131
131   P = 2.0*P
      IF ( IH ) 134,134,132
132   IF ( IH-IK ) 133,134,134
133   P = 2.0*P
134   IF ( IL ) 220,220,135
135   P = 2.0*P
      GO TO 220
C-
C-  3BAR
140   IF ( IH+IABS(IK) ) 142,142,141
141   P = 3.0*P
142   IF ( IL ) 220,220,143
143   P = 2.0*P
CSAH
      IF( ( LHZ      .AND. .NOT.LKZ .AND. .NOT.LLZ ) .OR.
     1    ( .NOT.LHZ .AND.      LKZ .AND. .NOT.LLZ )      ) THEN
        IFNEW = 1
        IHNEW =  IH
        IKNEW =  IK
        ILNEW = -IL
        P = P / 2.0
      ENDIF
CSAH
      GO TO 220
C-
C-  3BAR R
150   IF ( IH+IK+IL ) 151,152,151
151   P = 2.0*P
152   IF ( IH-IK ) 153,154,153
153   P = 3.0*P
      GO TO 220
154   IF ( IH-IL ) 153,220,153
C-
C-  3BAR 1 M
160   IF ( IK ) 220,220,161
161   P = 3.0*P
      IF ( IK-IH ) 220,220,162
162   IF ( IH ) 220,220,135
C-
C-  3BAR M 1
170   IF ( IL ) 172,172,171
171   IF( IH.NE.0 .OR. IK.NE.0 ) P = 2.0*P
172   IF ( IH ) 174,174,173
173   P = 3.0*P
      IF( IH.EQ.IK ) GO TO 178
      IF ( IK ) 178,178,175
174   IF ( IK ) 178,178,176
175   P = 2.0*P
      GO TO 178
176   P = 3.0*P
C-  ADD HO-L IF HOL FOUND
178   IF( (IH.NE.0.AND.IK.EQ.0.AND.IL.NE.0) .OR.
     1    (IH.EQ.0.AND.IK.NE.0.AND.IL.NE.0) ) THEN
C        WRITE(IOTTO,1701) IH,IK,IL,IH,IK,-IL
1701    FORMAT(' MLTHKL: LINE ',3I3,' ADDING ',3I3)
C        IHNEW =  IH
C        IKNEW =  IK
C        ILNEW = -IL
C        IFNEW = 1
        P = P / 2.0
      ENDIF
      IF( IH.NE.0 .AND. IK.NE.0 .AND. IL.NE.0 .AND. IH.NE.IK ) THEN
C        WRITE(IOTTO,1701) IH,IK,IL,IH,IK,-IL
C        IHNEW =  IH
C        IKNEW =  IK
C        ILNEW = -IL
C        IFNEW = 1
        P = P / 2.0
      ENDIF
      GO TO 220
C-
C-  3BAR M R
180   IF ( IH-IK ) 182,181,182
181   IF ( IH-IL ) 183,186,183
182   IF ( IK-IL ) 184,183,184
183   P = P/2.0
184   P = 3.0*P
      IF ( IH+IK+IL ) 185,186,185
185   P = 2.0*P
186   IF( IH.EQ.IK .AND. IK.EQ.IL ) THEN
        PT = 2.0
       ELSE IF( ( IH.EQ.IK .AND. IH.NE.IL ) .OR.
     1          ( IK.EQ.IL .AND. IK.NE.IH ) .OR.
     1          ( IH.EQ.IL .AND. IH.NE.IK ) ) THEN
        PT = 6.0
       ELSE IF( (  IH.EQ.-IL .AND.  IK.EQ. 0 ) .OR.
     1          ( -IH.EQ. IK .AND.  IL.EQ. 0 ) .OR.
     1          ( -IK.EQ. IL .AND.  IH.EQ. 0 ) ) THEN
        PT = 6.0
       ELSE
        PT = 12.0
      ENDIF
      IF(P.NE.PT) PRINT*,IH,IK,IL,'P, PT = ',P,PT
      P = PT
      GO TO 220
C-
C-  6/MMM
COLD190   IF ( IK ) 194,194,191
CNEW
190   P = 1.0
      IF ( IK ) 194,194,191
CNEW
191   P = 6.0*P
      IF ( IH ) 192,194,192
192   IF ( IK-IH ) 193,194,193
193   P = 2.0*P
194   IF ( IL ) 135,220,135
C-
C-  M3
200   IF ( IH-IK ) 203,201,203
201   IF ( IK-IL ) 203,202,203
202   P = 4.0*P
      GO TO 220
203   P = 3.0*P
      IF ( IK ) 205,205,204
204   P = 2.0*P
205   IF ( IH ) 220,220,135
C-
C-  M3M
210   IF ( IH ) 211,214,211
COLD211   P = 4.0
211   P = 4.0*P
      IF ( IH-IL ) 212,220,212
212   P = 3.0*P
      IF ( IH-IK ) 213,220,213
213   IF ( IK-IL ) 135,220,135
COLD214   P = 3.0
214   P = 3.0*P
      IF ( IK ) 215,220,215
215   P = 2.0*P
      IF ( IK-IL ) 135,220,135
C-
C-  1BAR AND RETURN
220   MLTHKL = INT( P )
C-
      RETURN
      END
C---  PROGRAM: RIETVELD  (RIET15)
C---  VERSION: 881001  (YYMMDD)
C---
      SUBROUTINE SPGP(SPG)
C
C   THIS SR INTERPRETS THE SPACE GROUP SYMBOL
C   AND GENERATES OPERATORS WHICH SYMOPR USES TO
C   GENERATE THE FULL SET OF EQUIVALENT
C   POSITIONS AND OP1 AND SMTRY2 USE TO GENERATE
C   THE FULL SET OF EQUIVALENT INDICES.
      CHARACTER*1 SPG(20),CHR(25)
      DIMENSION L(4,4),ICO(6,15)
      COMMON/SPGCOM/NLAUGR,NORAXS,NCONT(10),NSPCNT,NSPPOL,NSPMLT
      COMMON/IOLUNS/ IOTTI,IOTTO,IODCF,IOPTN,IOBKG,IOALT,IOPLT,IONEW
      DIMENSION NDAT(7)
      DATA NDAT(1),NDAT(2),NDAT(3),NDAT(4),NDAT(5),NDAT(6),NDAT(7)
     *        / 3,      1,      2,      0,      2,      1,      3 /
      DATA CHR(1),CHR(2),CHR(3),CHR(4),CHR(5),CHR(6),CHR(7),CHR(8),
     *CHR(9),CHR(10),CHR(11),CHR(12),CHR(13),CHR(14),CHR(15),CHR(16),
     *CHR(17),CHR(18),CHR(19),CHR(20),CHR(21)/' ','C','B','A','P',
     *'F','I','R','M','N','D','1','2','3','4','5','6','-','/','H','.'/
      LODGDF(I,J) = IAND( IEOR(I,J),307)
C-
C     WRITE(IOTTO,1) SPG
C1    FORMAT(/,' THE SPACE GROUP IS ',20A1)
      DO 97 I=1,6
      DO 97 J=1,15
97    ICO(I,J)=0
      DO 98 I=1,4
      DO 98 J=1,4
98    L(I,J) = 0
      M2 = 0
      K = 1
      M = 1
      NLAUGR = 0
      NORAXS = 0
      N = 0
      DO 110 J=1,20
99    DO 100 I=1,21
      IF ( SPG(J).EQ.CHR(I) ) GO TO 101
100   CONTINUE
CDB 2
C     PRINT 7,SPG(J),J
C   7 FORMAT (1XA1* IS AN UNRECOGNIZABLE CHARACTER IN COL. *I2)
      GO TO 110
101   IF ( K+M+I.EQ.3 ) GO TO 110
      IF ( I.EQ.1 ) GO TO 108
      L(M,K) = I
      N = 0
      M = M+1
      IF ( M-4 ) 110,110,108
108   IF ( N.EQ.1 ) GO TO 110
      N = 1
      M = 1
      K = K+1
      IF ( K.GT.4 ) GO TO 200
110   CONTINUE
200   IF ( K.LE.2 ) GO TO 500
CDB 3
C     PRINT 3,N,M,K,J,L
C   3 FORMAT (*0N =*I3*  M =*I3*  K =*I3*  J =*I3/
C    1  * L =*4I4/(4X4I4))
      IF ( L(1,1).GT.8 ) GO TO 500
      J = 1
      I = L(1,1)-1
      GO TO (203,202,201,119,204,205,206),I
      CALL GOTOER
201   NCONT(J) = 576
      GO TO 209
202   NCONT(J) = 516
      GO TO 209
203   NCONT(J) = 68
      GO TO 209
204   NCONT(J) = 576
      J = J+1
      GO TO 202
205   NCONT(J) = 580
      GO TO 209
207   K = K-1
      NLAUGR = K+3
      GO TO 210
206   IF ( L(1,3).EQ.8.OR.L(1,4).EQ.8 ) GO TO 207
      NCONT(J) = 8192
      IF ( L(1,K-1).EQ.20 ) K=K-1
      NLAUGR = K+5
      J = J+1
      GO TO 210
209   J = J+1
119   IF ( K-4 ) 120,130,140
120   IF ( L(1,2).EQ.18 ) GO TO 121
      IF ( L(1,2).EQ.17 ) GO TO 122
      IF ( L(1,2).EQ.14 ) GO TO 123
      IF ( L(1,2).EQ.15 ) GO TO 124
      IF ( L(1,2).EQ.12 ) GO TO 125
      NLAUGR = 2
      NORAXS = 2
      GO TO 210
121   IF ( L(2,2).EQ.17 ) GO TO 122
      IF ( L(2,2).EQ.14 ) GO TO 123
      IF ( L(2,2).EQ.15 ) GO TO 124
      IF ( L(2,2).EQ.12 ) GO TO 125
      GO TO 500
122   NLAUGR = 11
      GO TO 210
123   NLAUGR = 8
      GO TO 210
124   NLAUGR = 4
      GO TO 210
125   NLAUGR = 1
      GO TO 210
130   IF ( L(1,3).NE.14 ) GO TO 500
      NLAUGR = 13
      GO TO 210
140   IF ( L(1,3).EQ.14 ) GO TO 151
      IF ( L(1,2).EQ.18 ) GO TO 152
      IF ( L(1,2).EQ.17 ) GO TO 153
      IF ( L(1,2).EQ.14 ) GO TO 154
      IF ( L(1,2).EQ.15 ) GO TO 155
      IF ( L(1,2).EQ.12 ) GO TO 141
      IF ( L(1,3).EQ.12 ) GO TO 142
      IF ( L(1,4).EQ.12 ) GO TO 500
      NLAUGR = 3
      GO TO 210
141   IF ( L(1,3).EQ.12 ) GO TO 143
      IF ( L(1,4).NE.12 ) GO TO 500
      NLAUGR = 2
      NORAXS = 2
      GO TO 210
142   IF ( L(1,4).NE.12 ) GO TO 500
      NLAUGR = 2
      NORAXS = 1
      GO TO 210
143   IF ( L(1,4).EQ.12 ) GO TO 500
      NLAUGR = 2
      NORAXS = 3
      GO TO 210
151   NLAUGR = 14
      GO TO 210
152   IF ( L(2,2).EQ.17 ) GO TO 153
      IF ( L(2,2).EQ.14 ) GO TO 154
      IF ( L(2,2).EQ.15 ) GO TO 155
      GO TO 500
153   NLAUGR = 12
      GO TO 210
154   IF ( L(1,3).EQ.12 ) GO TO 156
      IF ( L(1,4).NE.12 ) GO TO 500
      NLAUGR = 9
      GO TO 210
155   NLAUGR = 5
      GO TO 210
156   IF ( L(1,4).EQ.12 ) GO TO 123
      NLAUGR = 10
210   K = K-1
CDB 2
C     PRINT 4,K,NSP,J,NCONT
C   4 FORMAT (*0K =*I3*  NSP =*2I4*  J=*I3/* NCONT =*10I4)
      N = 1
      DO 300 M=2,K
      IF ( L(1,M).EQ.0 ) GO TO 500
218   I = IABS(L(1,M)-5)
219   IF ( I.LE.0.OR.I.GT.15 ) GO TO 500
C              A   B   C   M   N   D   1   2   3   4   5   6   -   /
      GO TO (220,220,220,220,220,245,250,255,260,265,500,270,275,300,
     1 300),I
      CALL GOTOER
C        H
220   GO TO (500,221,222,223),M
      CALL GOTOER
221   IF ( L(1,3).EQ.14 ) GO TO 2230
      IF ( L(1,2).EQ.15 ) GO TO 2230
      IF ( L(1,2).EQ.17 ) GO TO 2230
      IF ( K.EQ.2 ) GO TO 2220
2210  ICO(1,N) = 2
      ICO(2,N) = 0
      ICO(3,N) = 0
      ICO(4,N) = 4
      IF ( I.EQ.2.OR.I.EQ.5 ) ICO(5,N) = 1
      IF ( I.EQ.3.OR.I.EQ.5 ) ICO(6,N) = 1
2211  N = N+1
      IF ( L(1,2).NE.15 ) GO TO 300
      ICO(1,N) = ICO(2,N-1)
      ICO(2,N) = ICO(1,N-1)
      ICO(3,N) = ICO(3,N-1)
      ICO(4,N) = ICO(5,N-1)
      ICO(5,N) = ICO(4,N-1)
      ICO(6,N) = ICO(6,N-1)
      N= N+1
      GO TO 300
222   IF ( L(1,2).EQ.14.OR.L(1,2).EQ.17 ) GO TO 225
      IF ( L(1,2).EQ.15 ) GO TO 2210
2220  ICO(1,N) = 0
      ICO(2,N) = 2
      ICO(3,N) = 0
      ICO(5,N) = 4
      IF ( I.EQ.1.OR.I.EQ.5 ) ICO(4,N) = 1
      IF ( I.EQ.3.OR.I.EQ.5 ) ICO(6,N) = 1
      N = N+1
      GO TO 300
223   IF ( L(1,3).EQ.14.OR.L(1,2).EQ.15 ) GO TO 224
      IF ( L(1,2).EQ.14.OR.L(1,2).EQ.17 ) GO TO 224
2230  ICO(1,N) = 0
      ICO(2,N) = 0
      ICO(3,N) = 2
      ICO(6,N) = 4
      IF ( I.EQ.1.OR.I.EQ.5 ) ICO(4,N) = 1
      IF ( I.EQ.2.OR.I.EQ.5 ) ICO(5,N) = 1
      N = N+1
      IF ( M.EQ.2.AND.L(1,2).EQ.15.AND.I.EQ.5 ) ICO(4,N-3)=1
      IF ( M.NE. 2.OR.L(1,2).NE.17) GO TO 300
      IF ( L(1,3).EQ.2 ) ICO(6,N-1)=1
      IF ( L(1,4).EQ.2 ) ICO(6,N-1)=MOD(ICO(6,N-1)+1,2)
      GO TO 300
224   ICO(1,N) = 1
      ICO(2,N) = 1
      ICO(3,N) = 0
      ICO(4,N) = 4
      ICO(5,N) = 4
      IF ( I.EQ.3.OR.I.EQ.5 ) ICO(6,N) = 1
      IF ( NLAUGR.EQ.7.AND.I.EQ.3 ) GO TO 2240
      IF ( I.NE.5 ) GO TO 226
2240  ICO(4,N) = 5
      ICO(5,N) = 5
      N = N+1
      GO TO 300
225   IF ( NLAUGR.EQ.7 ) GO TO 224
      ICO(1,N) = 3
      ICO(2,N) = 3
      ICO(3,N) = 0
      ICO(4,N) = 4
      ICO(5,N) = 4
      IF ( I.EQ.3 ) ICO(6,N) = 1
226   N = N+1
      GO TO 300
C    D TYPE MIRROR
245   GO TO (500,246,247,248),M
      CALL GOTOER
246   IF ( K.EQ.2 ) GO TO 247
      ICO(1,N) = 2
      ICO(2,N) = 0
      ICO(3,N) = 0
      ICO(4,N) = 6
      ICO(5,N) = 6
      ICO(6,N) = 6
      N = N+1
      GO TO 300
247   ICO(1,N) = 0
      ICO(2,N) = 2
      ICO(3,N) = 0
      ICO(4,N) = 6
      ICO(5,N) = 6
      ICO(6,N) = 6
      N = N+1
      GO TO 300
248   IF ( L(1,2).EQ.15.OR.L(1,3).EQ.14 ) GO TO 249
      ICO(1,N) = 0
      ICO(2,N) = 0
      ICO(3,N) = 2
      ICO(4,N) = 6
      ICO(5,N) = 6
      ICO(6,N) = 6
      N = N+1
      GO TO 300
249   ICO(1,N) = 1
      ICO(2,N) = 1
      ICO(3,N) = 0
      ICO(4,N) = 6
      ICO(5,N) = 6
      ICO(6,N) = 6
      IF (L(1,3).NE.13) GO TO 226
      ICO(4,N) = 0
      ICO(5,N) = 1
      N = N+1
      GO TO 300
C    1 FOLD ROTATION
250   IF ( L(2,M).NE.3 ) GO TO 300
      ICO(1,N) = 2
      ICO(2,N) = 2
      ICO(3,N) = 2
      ICO(4,N) = 4
      ICO(5,N) = 4
      ICO(6,N) = 4
      N = N+1
      GO TO 300
255   GO TO (500,256,257,258),M
      CALL GOTOER
C    2 FOLD ROTATION
256   IF ( K.EQ.2 ) GO TO 2571
2561  ICO(1,N) = 0
      ICO(2,N) = 2
      ICO(3,N) = 2
      ICO(4,N) = 0
      ICO(5,N) = 4
      ICO(6,N) = 4
      IF ( IABS(L(2,M)-13).EQ.1 ) ICO(4,N) = 1
2560  N = N+1
      DO 2562 I=2,4
      IF ( L(I,M).EQ.19 ) GO TO 2563
2562  CONTINUE
      GO TO 300
2563  IF ( L(I+1,M).LE.1 ) GO TO 500
      I = IABS(L(I+1,M)-5)
      GO TO 219
257   IF ( L(1,2).EQ.14.OR.L(1,2).EQ.17 ) GO TO 259
2571  ICO(1,N) = 2
      ICO(2,N) = 0
      ICO(3,N) = 2
      ICO(4,N) = 4
      ICO(5,N) = 0
      ICO(6,N) = 4
      IF ( L(2,M).EQ.12 ) ICO(5,N)=1
      IF ( L(1,2).EQ.15 ) GO TO 2211
      GO TO 2560
258   IF ( L(1,2).GE.14   ) GO TO 2595
      IF ( L(1,3).EQ.14 ) GO TO 259
2581  ICO(1,N) = 2
      ICO(2,N) = 2
      ICO(3,N) = 0
      ICO(4,N) = 4
      ICO(5,N) = 4
      ICO(6,N) = 0
      IF ( IABS(L(2,M)-13).EQ.1 ) ICO(6,N) = 1
      IF (      L(2,M).EQ.16    ) ICO(6,N) = 1
      GO TO 2560
259   IF ( L(1,3).EQ.8.OR.L(1,4).EQ.8 ) GO TO 2595
      ICO(1,N) = 1
      ICO(2,N) = 1
      ICO(3,N) = 2
      ICO(4,N) = 0
      ICO(5,N) = 0
      ICO(6,N) = 4
      GO TO 2560
2595  IF ( L(1,2).EQ.15)GO TO 259
      ICO(1,N) = 3
      ICO(2,N) = 3
      ICO(3,N) = 2
      ICO(4,N) = 4
      ICO(5,N) = 4
      ICO(6,N) = 4
      GO TO 2560
C    3 FOLD ROTATION
260   GO TO (500,261,262,500),M
      CALL GOTOER
261   IF ( L(1,1).EQ.8.AND.J.EQ.1 ) GO TO 262
      IX = 0
      IF ( L(2,M).EQ.12 ) GO TO 2611
      IF ( L(2,M).EQ.13 ) GO TO 2612
2610  NCONT(J) = 8196
      GO TO 2613
2611  NCONT(J) = 8200
      IF ( L(1,4).NE.13 ) GO TO 2613
      J = J+1
      NCONT(J) = 2321
      IF ( L(1,2).EQ.14 ) NCONT(J)=4403
      L(1,3) = 12
      L(1,4) = 12
      GO TO 2613
2612  NCONT(J) = 8204
      IF ( L(1,4).NE.13 ) GO TO 2613
      J = J+1
      NCONT(J) = 4369
      IF ( L(1,2).EQ.14 ) NCONT(J)=2355
      L(1,3) = 12
      L(1,4) = 12
2613  J = J+1
      IF ( IX-1 ) 250,2581,2230
C    CUBIC OR RHOMBOHEDERAL
262   NCONT(J) = 16384
      IF (L(2,M).NE.3 ) GO TO 2620
      J = J+1
      NCONT(J) = 290
2620  J = J+1
      IF ( N.EQ.1 ) GO TO 300
      I = N-1
      IN1 = N
      IN2 = N+1
      ICO(1,IN1) = ICO(3,I)
      ICO(2,IN1) = ICO(1,I)
      ICO(3,IN1) = ICO(2,I)
      ICO(4,IN1) = ICO(6,I)
      ICO(5,IN1) = ICO(4,I)
      ICO(6,IN1) = ICO(5,I)
      ICO(1,IN2) = ICO(2,I)
      ICO(2,IN2) = ICO(3,I)
      ICO(3,IN2) = ICO(1,I)
      ICO(4,IN2) = ICO(5,I)
      ICO(5,IN2) = ICO(6,I)
263   ICO(6,IN2) = ICO(4,I)
      N = IN2+1
      GO TO 300
265   IF ( M.NE.2 ) GO TO 500
      ICO(1,N) = 3
      ICO(2,N) = 1
      ICO(3,N) = 0
      ICO(4,N) = 4
      ICO(5,N) = 4
      ICO(6,N) = 0
      IF ( L(2,2).EQ.12 ) ICO(6,N) = 2
      IF ( L(2,2).EQ.13 ) ICO(6,N) = 1
      IF ( L(2,2).EQ.14 ) ICO(6,N) = 3
      IF ( L(2,2).EQ. 3 ) ICO(3,N) = 2
      N = N+1
      IF ( L(2,2).EQ.3.AND.L(1,3).EQ.14.AND.L(1,4).EQ.11 ) GO TO 266
      IF ( L(1,3).EQ.14 ) GO TO 2561
      IF ( K.GT.2.OR.L(1,1).NE.7 ) GO TO 2581
      IF ( L(2,2)+L(3,2).NE.12 ) GO TO 2581
      L(2,2) = 0
      ICO(5,N-1) = 1
      GO TO 2581
266   IF ( L(1,1).NE.7.OR.L(1,2).NE.15 ) GO TO 500
      NCONT(J  ) = 16384
      NCONT(J+1) = 356
      NCONT(J+2) = 834
      NCONT(J+3) = 1177
      J = J+3
      GO TO 410
270   IF ( M.NE.2 ) GO TO 500
      IX = 1
      IF ( L(2,2).EQ.12 ) GO TO 2611
      IF ( L(2,2).EQ.13 ) GO TO 2612
      IF ( L(2,2).EQ.14 ) GO TO 2610
      IF ( L(2,2).EQ.15 ) GO TO 2611
      IF ( L(2,2).EQ.16 ) GO TO 2612
      IF ( L(2,2).EQ. 3 ) GO TO 271
      GO TO 2610
271   IX = 2
      GO TO 2610
275   IF ( M.NE.2 ) GO TO 500
      L(1,2) = L(2,2)
      L(2,2) = 3
      GO TO 218
300   CONTINUE
      N = N-1
      IJ = J
      IF ( N.GT.0 ) GO TO 301
      J = J-1
      GO TO 410
301   DO 305 I=1,N
      NCONT(J) = ICO(1,I)+16*ICO(2,I)+128*ICO(3,I)+4*MOD(ICO(4,I),4)
     1 +64*MOD(ICO(5,I),4)+ 512*MOD(ICO(6,I),4)
305   J = J+1
306   J = J-1
CDB 4
C     PRINT 5,J,IJ,N,NSP,NCONT
C    1 ,ICO
C   5 FORMAT (*0J =*I3*  IJ =*I3*  N =*I3*  NSP =*2I5/* NCONT =*10I4/
C    1 * ICO =*6I3/(6X6I3))
310   DO 400 I=IJ,J
      NCI = I-IJ+1
      ICO4 = MOD(ICO(4,NCI),4)
      ICO5 = MOD(ICO(5,NCI),4)
      ICO6 = MOD(ICO(6,NCI),4)
      NI4 = NDAT(ICO4+4)
      NI5 = NDAT(ICO5+4)
      NI6 = NDAT(ICO6+4)
      KJ = I+1
      IF ( IAND(NCONT(I),307)-290 ) 320,315,320
315   IF ( IAND(NCONT(I),7884) ) 316,318,316
C   A CENTER IS PRESENT, NOT AT 0,0,0
316   CONTINUE
      WRITE(IOTTO,24)
24    FORMAT(/,' A CENTER IS PRESENT, NOT AT 0,0,0')
      GO TO 320
C   A CENTER AT 0,0,0 IS PRESENT
318   CONTINUE
320   IF ( KJ.GT.J ) GO TO 400
      DO 390 K=KJ,J
      NCK = K-IJ+1
      KCO4 = MOD(ICO(4,NCK),4)
      KCO5 = MOD(ICO(5,NCK),4)
      KCO6 = MOD(ICO(6,NCK),4)
      NK4 = NDAT(KCO4+4)
      NK5 = NDAT(KCO5+4)
      NK6 = NDAT(KCO6+4)
      NXC = MOD(NI4+NK4,4)
      NYC = MOD(NI5+NK5,4)
      NZC = MOD(NI6+NK6,4)
      MJ = K+1
      LOD = LODGDF(NCONT(K),NCONT(I))
      IF ( LOD.NE.290 ) GO TO 330
C   A CENTER IS GENERATED
      IF ( NXC+NYC+NZC.EQ.0 ) GO TO 330
      IF ( L(1,2).EQ.15.AND.I.EQ.IJ+1 ) GO TO 324
321   IF ( NXC.EQ.0 ) GO TO 322
      IF ( ICO(4,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NXC)*4
      IF ( ICO(4,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NXC)*4
322   IF ( NYC.EQ.0 ) GO TO 323
      IF ( ICO(5,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NYC)*64
      IF ( ICO(5,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NYC)*64
323   IF ( NZC.EQ.0 ) GO TO 325
      IF ( ICO(6,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NZC)*512
      IF ( ICO(6,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NZC)*512
      GO TO 325
324   L(1,2) = 30
      NIJ = ICO(6,1)
      NIJ = NDAT(NIJ+4)
      NJX = MOD(NIJ+NXC,4)
      NCONT(IJ) = IAND(NCONT(IJ),2035)+NDAT(NJX+4)*4
      NCONT(IJ) = IAND(NCONT(IJ),1855)+NDAT(NIJ+4)*64
      GO TO 321
325   CONTINUE
      ICO(4,NCI) = 0
      ICO(4,NCK) = 0
      ICO(5,NCK) = 0
      ICO(5,NCI) = 0
      ICO(6,NCI) = 0
      ICO(6,NCK) = 0
330   CONTINUE
      ICO4 = MOD(NCONT(I)/4  ,4)
      IKO4 = MOD(NCONT(K)/4  ,4)
      ICO5 = MOD(NCONT(I)/64 ,4)
      IKO5 = MOD(NCONT(K)/64 ,4)
      ICO6 = MOD(NCONT(I)/512,4)
      IKO6 = MOD(NCONT(K)/512,4)
      NI4 = NDAT(ICO4+4)
      NK4 = NDAT(IKO4+4)
      NI5 = NDAT(ICO5+4)
      NK5 = NDAT(IKO5+4)
      NI6 = NDAT(ICO6+4)
      NK6 = NDAT(IKO6+4)
      IF ( MJ.GT.J ) GO TO 390
      DO 380 M=MJ,J
      NCM = M-IJ+1
      MCO4 = MOD(ICO(4,NCM),4)
      MCO5 = MOD(ICO(5,NCM),4)
      MCO6 = MOD(ICO(6,NCM),4)
      NM4 = NDAT(MCO4+4)
      NM5 = NDAT(MCO5+4)
      NM6 = NDAT(MCO6+4)
      LOD1 = LODGDF(LOD,NCONT(M))
      NXC = MOD(NI4+NK4+NM4,4)
      NYC = MOD(NI5+NK5+NM5,4)
      NZC = MOD(NI6+NK6+NM6,4)
      IF ( LOD1.NE.290 ) GO TO 350
       IF  ( L(1,2).EQ.11 ) GO TO 334
      IF ( NXC+NYC+NZC.EQ.0 ) GO TO 380
      IF ( IJ.EQ.1 ) GO TO 331
      IF(NXC +NYC .EQ.0 )GO TO 333
      IF ( L(1,3).EQ.14 ) GO TO 331
      IF ( L(1,2).EQ.15 ) GO TO 331
      IF ( L(1,2).EQ.14 ) GO TO 331
      IF ( L(1,2).EQ.17 ) GO TO 331
      IF ( L(1,2)+L(1,3)+L(1,4).LT.18.AND.L(1,2).NE.9 ) GO TO 331
      NXC = MOD(NCONT(1)/2  +NXC,4)
      NYC = MOD(NCONT(1)/32 +NYC,4)
      NZC = MOD(NCONT(1)/256+NZC,4)
331   CONTINUE
      IF ( NXC.EQ.0 ) GO TO 332
      IF ( ICO(4,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NXC)*4
      IF ( ICO(4,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NXC)*4
      IF ( ICO(4,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NXC)*4
332   IF ( NYC.EQ.0 ) GO TO 333
      IF ( ICO(5,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NYC)*64
      IF ( ICO(5,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NYC)*64
      IF ( ICO(5,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NYC)*64
333   IF ( NZC.EQ.0 ) GO TO 335
      IF ( ICO(6,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NZC)*512
      IF ( ICO(6,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NZC)*512
      IF ( ICO(6,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NZC)*512
      GO TO 335
334   NCONT(I) = IAND(NCONT(I),2035)
      NCONT(K) = IAND(NCONT(K),1855)
      NCONT(M) = IAND(NCONT(M),511)
335   ICO(4,NCI) = 0
      ICO(5,NCI) = 0
      ICO(6,NCI) = 0
      ICO(4,NCK) = 0
      ICO(5,NCK) = 0
      ICO(6,NCK) = 0
      ICO(4,NCM) = 0
      ICO(5,NCM) = 0
      ICO(6,NCM) = 0
      GO TO 380
350   IF ( LOD1.NE.0 ) GO TO 380
CDB 3
C     PRINT 9,LOD1,NXC,NYC,NZC,NI4,NK4,NI5,NK5,NI6,NK6
C   9 FORMAT (* LOD1 = *O10* NXC =*I4* NYC =*I4* NZC =*I4/
C    1 * NI4 =*I3* NK4 =*I3* NI5 =*I3* NK5 =*I3* NI6 =*I3* NK6 =*I3)
      IF ( NXC+NYC+NZC.EQ.0 ) GO TO 359
      IF ( L(1,2).EQ.30 ) GO TO 3500
      IF ( L(1,2).EQ.15 ) GO TO 355
      IF ( L(1,2).EQ.17 ) GO TO 359
      IF ( L(1,2).EQ.13 ) GO TO 351
      IF ( L(1,3).EQ.13 ) GO TO 352
      IF ( L(1,4).EQ.13 ) GO TO 353
      GO TO 500
3500  IF ( NXC.EQ.0 ) GO TO 359
      IF ( L(4,2).EQ.4 ) GO TO 359
      IF ( NXC.EQ.NK4 ) GO TO 359
      NCONT(K) = IOR(NCONT(K),NDAT(NXC)*4)
      IF ( L(1,4).EQ.13.AND.L(2,4).EQ.0 ) GO TO 3580
      GO TO 359
351   NYC = MOD(NK5+NM5,4)
      NZC = MOD(NK6+NM6,4)
      IF ( L(1,3).EQ.13 ) GO TO 354
      IF ( L(1,3).EQ.14 ) GO TO 354
      IF ( L(1,4).EQ.13 ) GO TO 354
      M2 = I+1
3511  CONTINUE
      IF(L(2,2).EQ.12.AND.(L(1,3).EQ.9 .OR.L(1,4).EQ.9))  GO TO 360
      IF ( ICO(5,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NYC)*64
      IF ( ICO(5,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NYC)*64
3510  IF ( NZC.LE.0 ) GO TO 360
      IF ( ICO(6,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NZC)*512
      IF ( ICO(6,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NZC)*512
      GO TO 360
352   NXC = MOD(NI4+NM4,4)
      NZC = MOD(NI6+NM6,4)
      M2 = K+1
      IF(L(2,3).EQ.12 .AND.(L(1,2).EQ.9 .OR. L(1,4).EQ.9)) GO TO 360
      IF ( NXC.LE.0 ) GO TO 3520
      IF ( ICO(4,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NXC)*4
      IF ( ICO(4,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NXC)*4
3520  IF ( NZC.LE.0 ) GO TO 360
      IF ( ICO(6,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NZC)*512
      IF ( ICO(6,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NZC)*512
      GO TO 360
353   NXC = MOD(NI4+NK4,4)
      NYC = MOD(NI5+NK5,4)
      IF(L(2,4).EQ.12 .AND. ( L(1,2).EQ.9.OR.L(1,3).EQ.9)) GO TO 359
      IF ( NXC.LE.0 ) GO TO 3530
      IF ( ICO(4,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NXC)*4
      IF ( ICO(4,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NXC)*4
3530  IF ( NYC.LE.0 ) GO TO 359
      IF ( ICO(5,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NYC)*64
      IF ( ICO(5,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NYC)*64
      GO TO 359
354   IF ( NYC.LE.0 ) GO TO 3540
      IF ( IABS(L(2,2)-13).EQ.1 ) NCONT(I)=NCONT(I)+NDAT(NYC)*64
3540  IF ( NZC.LE.0 ) GO TO 3541
      IF ( ICO(6,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NZC)*512
3541  IF ( NXC.LE.0 ) GO TO 359
      IF ( L(1,4).EQ.0.OR.L(1,3).EQ.14 ) GO TO 359
      IF ( L(2,4).NE.12 ) NCONT(K)=NCONT(K)+NDAT(NXC)*4
      GO TO 359
355   L(1,2) = 30
      IF ( L(1,3).EQ.14 ) GO TO 370
      IF ( L(1,3).EQ.13.AND.L(2,3).EQ.12 ) GO TO 3561
      IF ( L(1,1).EQ. 7.AND.L(2,2).EQ.12 ) GO TO 357
      IF ( L(1,1).EQ. 7.AND.L(2,2).EQ.14 ) GO TO 357
      IF ( L(1,1).EQ. 6.AND.L(2,2).EQ.12 ) GO TO 358
      IF ( L(1,1).EQ. 6.AND.L(2,2).EQ.14 ) GO TO 358
      IF ( L(1,1).EQ.7.AND.L(1,3).EQ.13 ) GO TO 3581
      IF ( MOD(NCONT(I),1024).EQ.19 ) GO TO 350
      IF ( NXC+NYC.GT.0 ) GO TO 356
      IF ( NZC.NE.NM6 ) GO TO 359
      IF ( NZC.LE.0 ) GO TO 359
      NCONT(K) = NCONT(K)+NDAT(NZC)*512
      GO TO 359
356   IF ( L(3,2).EQ.10.OR.L(4,2).EQ.10 ) GO TO 359
      IF ( L(1,3).NE.10 ) GO TO 359
3561  IF ( L(2,2).EQ.3 ) GO TO 3560
      NCONT(I) = IOR(NCONT(I),68)
      GO TO 3580
3560  IF ( L(1,4).EQ.2 ) NCONT(K)=IOR(NCONT(K),512)
      GO TO 359
357   NCONT(I) = NCONT(I)+64
      IF ( L(3,2).NE.19 ) NCONT(I+1) = NCONT(I+1)-512
      IF ( L(1,4).EQ.11.AND.L(3,2).EQ.19 )NCONT(I) = NCONT(I)+588
      GO TO 3580
358   NCONT(I) = NCONT(I)+136
3580  IF ( L(1,3).NE.13 ) GO TO 359
3581  M2 = K+1
      GO TO 360
359   M2 = M+1
360   CONTINUE
      IF ( M2.GT.J ) GO TO 306
CDB 2
C     PRINT 6,M2,I,J,K,M
C   6 FORMAT (*0M2 =*I3*  I =*I3*  J =*I3* K =*I3*  M =*I3)
      DO 365 M1=M2,J
      NCONT(M1-1) = NCONT(M1)
      DO 365 M3=1,6
365   ICO(M3,M1-1) = ICO(M3,M1)
      GO TO 306
370   IF ( L(1,4).GT.12 ) GO TO 371
      M2 = I+1
      GO TO 360
371    CONTINUE
      L(1,2) = 13
      IF ( L(2,2).EQ.12.AND.L(1,1).EQ.5 ) NCONT(I) = NCONT(I)+200
      IF ( L(2,2).EQ.12.AND.L(1,1).EQ.6 ) NCONT(I) = NCONT(I)+136
      IF ( L(2,2).EQ.12.AND.L(1,1).EQ.7 ) NCONT(I) = NCONT(I)+652
      IF ( L(2,2).EQ.13 )                 NCONT(I) = NCONT(I)+68
      IF ( L(2,2).EQ.14 )                 NCONT(I) = NCONT(I)+140
      GO TO 359
380   CONTINUE
390   CONTINUE
400   CONTINUE
      LD = 0
      DO 405 I=1,J
405   LD = LODGDF(LD,NCONT(I))
      IF ( LD.NE.0 ) GO TO 410
      NCONT(J-1) = NCONT(J)
      J = J-1
410   CONTINUE
      NCONT(J+1) = 0
CDB 1
C     PRINT 4,K,NSP,J,NCONT
450   RETURN
500   WRITE(IOTTO,2) SPG
2     FORMAT(/,' DID YOU ENTER THE SPACE GROUP THE CARD CORRECTLY?',/,
     1 ' ERRORS OF SOME SORT WERE DETECTED.',//,
     2 ' THE SPACE GROUP WAS READ AS ',20A1)
      NORAXS = 4
      GO TO 450
      END
      SUBROUTINE GOTOER
      PRINT *,' A GOTO RAN OUT OF BOUNDS'
      RETURN
      END
C---  PROGRAM: RIETVELD  (RIET16)
C---  VERSION: 881001  (YYMMDD)
C---
      SUBROUTINE RTMT( IPRT, IPHASE )
C-
C THIS SUBROUTINE GENERATES ROTATION MATRICES AND TRANSLATION VECTORS
C    FROM THE OPERATORS TO FORM THE GROUP.
C-
C-  MLT(1,PHASE) = MULTIPLICITY OF THE SPACE GROUP
C-  MLT(2,PHASE) = STARTING POSITION OF OPERATORS FOR PHASE IN IV1,2,3
C-
C-
      COMMON/BLNK1/ N,NMAX,MULTX,Y(192,3),XLT,IXB,FILL(192)
      PARAMETER( MNPTS=5120, MREFS=1024, MATMS=48, MMATX=48, MPHAS=4 )
      COMMON/SPGCOM/NLAUGR,NORAXS,NCONT(10),NSPCNT,NSPPOL,NSPMLT
      COMMON/RTMTX1/ MLT(2,MPHAS),ICET(MPHAS),IV1(801),IV2(800),IV3(800)
      COMMON/RTMTX2/ PVX(400),PVY(400),PVZ(400),PVT(400)
      COMMON/IOLUNS/ IOTTI,IOTTO,IODCF,IOPTN,IOBKG,IOALT,IOPLT,IONEW
      DIMENSION VCTR(3,4), IVCTR(3)
C-
C-  SET POINTERS, KEEP TRACK OF PACVECTORS IN IV1(801)
C-
      IF(IPHASE.EQ.1) THEN
        NVEC = 0
        NVECPT = 0
       ELSE
        NVEC = IV1(801)
        NVECPT = MLT(2,IPHASE-1) + MLT(1,IPHASE-1) - 1
      ENDIF
      NVECST = NVECPT + 1
C-
      Y(1,1) = 2.0 / 108.0
      Y(1,2) = 3.0 / 108.0
      Y(1,3) = 4.0 / 108.0
      CALL SYMOPR
      NSPMLT = MULTX - 1
C-
C-  REPEAT FOR EACH OF THE GENERAL SYMMETRY OPERATORS
      DO 300 I=1,NSPMLT
      NVECPT = NVECPT + 1
C-
C-  REPEAT FOR EACH OF THE THREE AXES
      DO 320 K=1,3
      IX = Y(I,K) * 108.0 + 0.1
      VCTR(K,4) = REAL( (IX+4)/9 ) / 12.0
      VCTR(K,4) = AMOD( VCTR(K,4), 1.0 )
      IY = MOD(IX+4,9) - 4
      IZ = IABS( IY )
      GO TO (220,230,240,250),IZ
220   VCTR(K,1) = -REAL( ISIGN(1,IY) )
      VCTR(K,2) =  REAL( ISIGN(1,IY) )
      VCTR(K,3) =  0.0
      GO TO 310
230   VCTR(K,1) =  REAL( ISIGN(1,IY) )
      VCTR(K,2) =  0.0
      VCTR(K,3) =  0.0
      GO TO 310
240   VCTR(K,1) =  0.0
      VCTR(K,2) =  REAL( ISIGN(1,IY) )
      VCTR(K,3) =  0.00
      GO TO 310
250   VCTR(K,1) =  0.0
      VCTR(K,2) =  0.0
      VCTR(K,3) =  REAL( ISIGN(1,IY) )
C-
C--  SEARCH VECTOR TABLE FOR MATCH
C-
310   DO 2010 NN1=1,NVEC
      IF( VCTR(K,1) .NE. PVX(NN1) ) GO TO 2010
      IF( VCTR(K,2) .NE. PVY(NN1) ) GO TO 2010
      IF( VCTR(K,3) .NE. PVZ(NN1) ) GO TO 2010
      IF( VCTR(K,4) .NE. PVT(NN1) ) GO TO 2010
      IVCTR(K) = NN1
      GO TO 320
2010  CONTINUE
C-
C-  NO SIMILAR VECTOR... ADD TO TABLE
      NVEC = NVEC + 1
      PVX(NVEC) = VCTR(K,1)
      PVY(NVEC) = VCTR(K,2)
      PVZ(NVEC) = VCTR(K,3)
      PVT(NVEC) = VCTR(K,4)
      IVCTR(K) = NVEC
C-
320   CONTINUE
C-
C-  PUT ROTATION AND TRANSLATION VECTOR POINTERS INTO IV1,2,3
      IV1(NVECPT) = IVCTR(1)
      IV2(NVECPT) = IVCTR(2)
      IV3(NVECPT) = IVCTR(3)
C-
C-  PRINT THE SYMMETRY OPERATORS
      IF(IPRT.LT.1) GO TO 300
      IF(MOD(I-1,15).EQ.0) WRITE(IOTTO,10)
10    FORMAT('1The operations of the space group are:')
      WRITE(IOTTO,6) ((VCTR(KK,J),J=1,4),KK=1,3)
6     FORMAT(3H0 (,3F3.0,18H )     ( X )     (,F6.3,13H )     ( X2 ) /
     1       3H ( ,3F3.0,18H  ) * (  Y  ) + ( ,F6.3,14H  ) = (  Y2  )/
     2       3H  (,3F3.0,18H )     ( Z )     (,F6.3,13H )     ( Z2 ) )
C-
300   CONTINUE
C-
C-  SET POINTERS
C-
      MLT(1,IPHASE) = NSPMLT
      MLT(2,IPHASE) = NVECST
      ICET(IPHASE) = 1
      IF(NSPCNT.EQ.0) ICET(IPHASE) = 2
      IV1(801) = NVEC
      IF(ICET(IPHASE).EQ.1) WRITE(IOTTO,3030) 'a',NSPMLT
      IF(ICET(IPHASE).EQ.2) WRITE(IOTTO,3030) ' ',NSPMLT
3030  FORMAT('  General site multiplicity of this ',A1,
     1 'centric space group ',I3)
      WRITE(IOTTO,3034) NVEC,NVECPT
3034  FORMAT('  Room for vectors 400, used ',I3,
     1  ';  Room for pointers 800, used ',I4)
C-
      RETURN
      END
      SUBROUTINE SYMOPR
C
C     THIS SR TAKES A POINT XYZ, DETERMINES THE
C     SITE MULTIPLICITY, THE SITE SYMMETRY, AND
C     THE SYMMETRY CONSTRAINTS ON THE POSITIONAL
C     AND THERMAL PARAMETERS.
C
      COMMON/BLNK1/ N(2),L,X(192),Y(192),Z(192),XLT,KXB,NCTR(192)
      COMMON/SPGCOM/NLAUGR,NORAXS,NCONT(10),NSPCNT,NSPPOL,NSPMLT
      COMMON/IOLUNS/ IOTTI,IOTTO,IODCF,IOPTN,IOBKG,IOALT,IOPLT,IONEW
      ISCK = 0
103   L = 2
      ISRH = 0
      KXB = 0
      XLT = 1.0
      J = 1
      CALL CEL000
      L1=J
      DO 100 I=1,8
      IOP = 0
      IF ( NCONT(I).EQ.0 ) GO TO 104
1     DO 99 L2=J,L1
      L3=L-1
      IF ( NCONT(I)-8192 ) 4,5,4
5     X(L)=X(L2)+1.0/3.0
      Y(L)=Y(L2)+2.0/3.0
      Z(L)=Z(L2)+2.0/3.0
      X(L+1)=X(L2)+2.0/3.0
      Y(L+1)=Y(L2)+1.0/3.0
      Z(L+1)=Z(L2)+1.0/3.0
      L=L+1
      CALL CEL000
      L=L+1
      CALL CEL000
      GO TO 6
4     CALL OPERTR(I,L2)
6     L5=L
      L6=NCONT(I)
7     L = L3+1
8     L4 = 1
      IF ( ABS(X(L)-X(L4))-0.0001 ) 2,2,90
2     IF ( ABS(Y(L)-Y(L4))-0.0001 ) 3,3,90
3     IF ( ABS(Z(L)-Z(L4))-0.0001 ) 91,91,90
91    CONTINUE
      IF ( NCTR(L)-8192 ) 92,94,93
92    KX = MOD(NCTR(L),4)+1
      KY = MOD(NCTR(L)/16,4)+1
      KZ = MOD(NCTR(L)/256,2)
      IF ( IOP.EQ.0 ) XLT=XLT/2.0
      IOP = 1
      GO TO (920,930,940,950),KX
      CALL GOTOER
920   GO TO (921,1000,922,1000),KY
      CALL GOTOER
921   IF ( KZ.EQ.0 ) GO TO 1000
      KXB = IOR(KXB,2621450)
      GO TO 90
922   CONTINUE
      IF ( KZ.EQ.0 ) KXB=IOR(KXB,2228292)
      IF ( KZ.EQ.1 ) KXB=IOR(KXB, 655432)
      GO TO 90
930   KXB = IOR(KXB,32768)
      GO TO (1000,931,1000,932),KY
      CALL GOTOER
931   CONTINUE
      IF ( KZ.EQ.0 ) KXB=IOR(KXB, 4194464)
      IF ( KZ.EQ.1 ) KXB=IOR(KXB,12583048)
      GO TO 90
932   KXB = IOR(KXB,2753088)
      IF ( KZ.EQ.1 ) KXB = IOR(KXB,8)
      GO TO 90
940   KXB = IOR(KXB,512)
      GO TO (941,1000,942,1000),KY
      CALL GOTOER
941   KXB = IOR(KXB,131072)
      IF ( KZ.EQ.1 ) GO TO 943
      KXB = IOR(KXB,525312)
      GO TO 90
942   KXB = IOR(KXB,64)
      IF ( KZ.EQ.1 ) GO TO 944
      KXB = IOR(KXB,2623488)
      GO TO 90
943   KXB = IOR(KXB,2097152)
944   KXB = IOR(KXB,8)
      GO TO 90
950   KXB = IOR(KXB,32768)
      GO TO (1000,951,1000,952),KY
      CALL GOTOER
951   KXB = IOR(KXB,2753088)
      IF ( KZ.EQ.1 ) KXB = IOR(KXB,8)
      GO TO 90
952   IF ( KZ.EQ.0 ) KXB = IOR(KXB,8388864)
      IF ( KZ.EQ.1 ) KXB = IOR(KXB,4194568)
      GO TO 90
93    CONTINUE
      IF ( MOD(NCTR(L),16384).EQ.0 ) GO TO 95
      ISRH = 1
      IF ( IAND(307,NCTR(L)-NCONT(I)).EQ.0 ) GO TO 92
      GO TO 90
94    KXB = IOR(KXB,2916928)
      XLT = XLT/3.0
      GO TO 99
95    KXB = IOR(KXB,17924240)
      XLT = XLT/3.0
      GO TO 99
90    CONTINUE
      IF ( L6-8192 ) 99, 98,98
98    L6=1
      L = L+1
       GO TO 8
99    L=L5
100   L1=L-1
104   CONTINUE
      IF ( ISRH.EQ.0 ) GO TO 200
      IF ( ISCK.GT.1 ) GO TO 2000
      ISCK = ISCK+1
      DO 1010 J=1,I
      IF ( NCONT(J).EQ.16384 ) GO TO 1011
1010  CONTINUE
      DO 101 L2 = 1,L1
      IF ( ABS(X(L2)-Y(L2)).LE.0.0001 ) GO TO 102
      IF ( ABS(X(L2)+Y(L2)-1.0).LE.0.0002 ) GO TO 102
101   CONTINUE
      ISCK = 2
      WRITE(IOTTO,110) X(1),Y(1),Z(1),XLT
      GO TO 200
1011  CONTINUE
      IF ( ABS(X(1)-Y(1)).LT.0.0001 ) GO TO 120
      WRITE(IOTTO,111)X(1),Y(1),Z(1),Y(1),Z(1),X(1)
      X3 = X(1)
      X(1) = Y(1)
      Y(1) = Z(1)
      Z(1) = X3
      GO TO 103
110   FORMAT(/,' NO X,X,Z OR X,-X,Z SET WAS FOUND FOR ',4F8.5)
102   IF ( L2.EQ.1 ) GO TO 120
      WRITE(IOTTO,111)X(1),Y(1),Z(1),X(L2),Y(L2),Z(L2)
111   FORMAT(/,' THE ATOM AT ',3F8.5,' WAS PUT AT ',3F8.5)
      X(1) = X(L2)
      Y(1) = Y(L2)
      Z(1) =Z(L2)
      GO TO 103
1000  WRITE(IOTTO,112) NCTR(L)
112   FORMAT(/,' --THE SYMMETRY OPERATOR ',I10,' IS WRONG.')
      STOP 7701
2000  CONTINUE
      WRITE(IOTTO,113)X(1),Y(1),Z(1)
113   FORMAT(/,' THERE ARE UNRESOLVABLE PROBLEMS WITH THE POSITION SET',
     1 3F8.5,/,' ATTEMPTS TO DEFINE THE TRUE SITE SYMMETRY WERE ABANDO',
     2 'NED.')
120   IF ( ABS(X(1)-Y(1))+ABS(X(1)-Z(1)).LE.0.0002 ) GO TO 200
      DO 130 L2=2,L1
      IF ( ABS(X(L2)-Y(L2))+ABS(X(L2)-Z(L2)).LE.0.0002 ) GO TO 102
130   CONTINUE
200   CONTINUE
      KXB = MAX0(IAND(KXB,18874367),IAND(KXB,16777215))
      IF ( IAND(KXB,384).EQ.384 ) KXB=IOR(KXB,512)
      RETURN
      END
      SUBROUTINE CEL000
C
C     THIS SR IS USED TO FORCE A POINT XYZ TO
C     LIE IN THE UNIT CELL AT 000.
C
      COMMON/BLNK1/ N(2),L,X(192),Y(192),Z(192),XLT,IXB,FILL(192)
      X(L-1) = AMOD(X(L-1)+8.0,1.0)
      IF ( X(L-1)-.99999 ) 2,1,1
1     X(L-1) = 0.0
2     Y(L-1) = AMOD(Y(L-1)+8.0,1.0)
      IF ( Y(L-1)-.99999 ) 4,3,3
3     Y(L-1) = 0.0
4     Z(L-1) = AMOD(Z(L-1)+8.0,1.0)
      IF ( Z(L-1)-.99999 ) 6,5,5
5     Z(L-1) = 0.0
6     RETURN
      END
      SUBROUTINE OPERTR(I,L2)
C
C     THIS SR GENERATES THE SYMMETRY EQUIVALENT
C     POSITIONS. IT IS CALLED BY SYMOPR.
C
      COMMON/BLNK1/ N(2),L,X(192),Y(192),Z(192),XLT,IXB,FILL2(192)
      COMMON/SPGCOM/NLAUGR,NORAXS,NCONT(10),NSPCNT,NSPPOL,NSPMLT
      COMMON/IOLUNS/ IOTTI,IOTTO,IODCF,IOPTN,IOBKG,IOALT,IOPLT,IONEW
      I1 = MOD(NCONT(I),4)+1
      I2 = MOD(NCONT(I)/4,4)+1
      I3 = MOD(NCONT(I)/16,4)+1
      I4 = MOD(NCONT(I)/64,4)+1
      I5 = MOD(NCONT(I)/256,2)
      I6 = MOD(NCONT(I)/512,4)+1
      I7 = MOD(NCONT(I)/2048,4)+1
      I8 = NCONT(I)/8192+1
      GO TO (100,200,300),I8
      CALL GOTOER
100   GO TO (101,102,103,104),I1
      CALL GOTOER
101   X(L) = X(L2)
      GO TO 105
102   X(L) = Y(L2)
      GO TO 105
103   X(L) = -X(L2)
      GOTO 105
104   X(L) = -Y(L2)
105   GO TO (110,107,108,106),I2
      CALL GOTOER
106   X(L) = X(L)+0.25
107   X(L) = X(L)+0.25
108   X(L) = X(L)+0.25
110   GO TO (111,112,113,114),I3
      CALL GOTOER
111   Y(L) = Y(L2)
      GO TO 115
112   Y(L) = X(L2)
      GO TO 115
113   Y(L) = -Y(L2)
      GOTO 115
114   Y(L) = -X(L2)
115   GO TO (120,117,118,116),I4
      CALL GOTOER
116   Y(L) = Y(L)+0.25
117   Y(L) = Y(L)+0.25
118   Y(L) = Y(L)+0.25
120   Z(L) = Z(L2)*REAL(1-2*I5)
      GO TO (125,122,123,121),I6
      CALL GOTOER
121   Z(L) = Z(L)+0.25
122   Z(L) = Z(L)+0.25
123   Z(L) = Z(L)+0.25
125   GO TO (130,127,126),I7
      CALL GOTOER
126   Z(L) = Z(L)+0.333333333
127   Z(L) = Z(L)+0.333333333
130   L = L+1
      CALL CEL000
      RETURN
200   X(L) = -Y(L2)
      Y(L) = X(L2)-Y(L2)
      Z(L) = Z(L2)+0.333333333*REAL(I2-2)
      L = L+1
      CALL CEL000
      X(L) = -Y(L-1)
      Y(L) = -X(L2)
      Z(L) = Z(L2)-0.333333333*REAL(I2-2)
      GO TO 130
300   I1 = L2
301   X(L) = Z(I1)
      Y(L) = X(I1)
      Z(L) = Y(I1)
      IF ( I1-L2 ) 302,302,130
302   I1 = L
      L = L+1
      CALL CEL000
      GO TO 301
      END
C---  PROGRAM: RIETVELD  (RIET20)
C---  VERSION: 881001  (YYMMDD)
C---
      SUBROUTINE ASSIGN
C-
      INCLUDE 'RIETCOM.FOR'
      COMMON KR1(MNPTS),KR2(MNPTS)
      DIMENSION ISTOR(MPHAS)
      EQUIVALENCE (PGLB(11),AMOPOS),(PGLB(12),AMOHGT),(PGLB(13),AMOWID)
C-
C--  INITIALIZE VARIOUS LINE RELATED PARAMETERS
C-
C-  SORT LINE LIST
1000  IRTOT = 0
      DO 1010 ITMP=1,NPHASE
      IRTOT = IRTOT + KREFNM(ITMP)
      ISTOR(ITMP) = KREFNM(ITMP)
      KREFNM(ITMP) = 0
1010  CONTINUE
      KREFNM(1) = IRTOT
      IF(NPHASE.GT.1) CALL SORT( 1 )
      DO 1020 ITMP=1,NPHASE
1020  KREFNM(ITMP) = ISTOR(ITMP)
C-
C-  CLEAR LISTS FOR BEGINNING AND ENDING LINE CONTRIBUTION NUMBERS
      DO 1030 K=1,MNPTS
      KR1(K) = 0
      KR2(K) = 0
1030  CONTINUE
C-
C-  INITIALIZE AMORPHOUS LINE RANGE
      KAMSTR = 0
      KAMEND = 0
C-
C-- PRINT MERGED LINE LIST
C-
2000  IF(KOFRLM.EQ.0) GO TO 3000
      DO 2010 IORDC=1,IRTOT
      IPHASE = KREFDT(IORDC)/256/256/256/4
      IRC = MOD( KREFDT(IORDC)/256/256/256,  4 )
      IRH = MOD( KREFDT(IORDC)/256/256,    256 ) - 128
      IRK = MOD( KREFDT(IORDC)/256,        256 ) - 128
      IRL = MOD( KREFDT(IORDC),            256 ) - 128
      TWOTHT = PREFTT(IORDC)
      CORL2T = TWOTHT-CORPOS(TWOTHT)+PGLB(1)+PGLB(10)*COS(TWOTHT*DTORD2)
      CALL FNFWHM
      IF(MOD(IORDC-1,60).EQ.0) WRITE(IOTTO,2020)
2020  FORMAT('1NO. ALPHA    H   K   L  PHASE  FW    2Theta',/)
      WRITE(IOTTO,2030) IORDC,IRC,IRH,IRK,IRL,IPHASE,FWHML,TWOTHT
2030  FORMAT(2I4,3X,3I4,I6,2F8.3)
2010  CONTINUE
C-
C--  BRAGG REFLECTION LINE TO POINT-IN-PATTERN ASSIGNMENT
C-
3000  ZEROPC = PGLB(1)
C-
C-  REPEAT FOR EACH REFLECTION
      DO 3010 IORDC=1,IRTOT
C-
C-  SET PHASE IN COMMON
      IPHASE = KREFDT(IORDC)/256/256/256/4
C-
C-  ANGLE AND WIDTH OF REFLECTION
      TWOTHT = PREFTT(IORDC)
      CORL2T = TWOTHT-CORPOS(TWOTHT)+PGLB(1)+PGLB(10)*COS(TWOTHT*DTORD2)
      CALL FNFWHM
      IF( FWHML.LT.0.01) THEN
        WRITE(IOTTO,3002) IORDC,TWOTHT
3002    FORMAT(
     1  ' -ASSIGN: FWHM for reflection ',I4,' at ',F8.4,
     1  ' less than 0.01 degrees:',/,
     1  10X,'using 0.1 in calculation of range.')
        FWHML = 0.1
      ENDIF
C-
C-  RANGE FOR NON-CONVOLUTED PROFILES
3100  IF(KWSGON.EQ.1) GO TO 3200
      RMIN = CORL2T - WDTTHK * FWHML
      RMAX = CORL2T + WDTTHK * FWHML
      GO TO 3900
C-
C-  RANGE FOR CONVOLUTED LINES
3200  WSGW = WDTTHK * ( FNCFWI(CORL2T,1) + FNCFWI(CORL2T,2) ) / 2.0
      WSGPOS = CORL2T
      IF(KGRAD(1,2).GT.1) THEN
        CALL CALCPH( CORL2T, 1.0, 2, WSGPO2, WSGDUM )
        WSGPOS = ( WSGPOS + WSGPOS + WSGPO2 ) / 3.0
      ENDIF
      RMIN = WSGPOS - WSGW
      RMAX = WSGPOS + WSGW
C-
C-  SET MINIMUM AND MAXIMUM CONTRIBUTING REFLECTIONS TO POINT
3900  MINANG = NINT( (RMIN-THMIN)/STEP ) + 1
      MAXANG = NINT( (RMAX-THMIN)/STEP ) + 1
      MINANG = MIN0( MAX0( MINANG, 1 ) , KPPTS )
      MAXANG = MIN0( MAX0( MAXANG, 1 ) , KPPTS )
      DO 3910 K=MINANG,MAXANG
      IF(KR1(K).EQ.0) KR1(K) = IORDC
      KR2(K) = IORDC
3910  CONTINUE
C-
C-  NEXT LINE
3010  CONTINUE
C-
C-  RANGE FOR AMORPHOUS PROFILE
      IF(KAMOR.EQ.1) THEN
        RMIN = AMOPOS - ( 3.0 * AMOWID )
        RMAX = AMOPOS + ( 3.0 * AMOWID )
        MINANG = NINT( (RMIN-THMIN)/STEP ) + 1
        MAXANG = NINT( (RMAX-THMIN)/STEP ) + 1
        KAMSTR = MIN0( MAX0( MINANG, 1 ) , KPPTS )
        KAMEND = MIN0( MAX0( MAXANG, 1 ) , KPPTS )
        RMIN = THMIN+REAL(KAMSTR-1)*STEP
        RMAX = THMIN+REAL(KAMEND-1)*STEP
        WRITE(IOTTO,3920) RMIN,KAMSTR,RMAX,KAMEND
3920    FORMAT(/,
     1  ' Range of amorphous line: Start = ',F8.4,' (',I4,')  End = ',
     1  F8.4,' (',I4,')')
      ENDIF
C-
C--  MARK EXCLUDED REGIONS BY SETTING INDICES IORD1=0, IORD2=1
C-
4000  DO 4010 J=1,NEXCRG
      IF( PEXCHI(J).LT.THMIN .OR. PEXCLO(J).GT.THMAX ) GO TO 4010
      IN1 = NINT( ( PEXCLO(J)-THMIN)/STEP ) + 1
      IN1 = MAX0( IN1,    1 )
      IN2 = NINT( (PEXCHI(J)-THMIN)/STEP ) + 1
      IN2 = MIN0( IN2, KPPTS )
      DO 4020 I=IN1,IN2
      KR1(I) = 0
      KR2(I) = 1
4020  CONTINUE
4010  CONTINUE
C-
C--  PRINTING OF CORRECTED DATA LIST
C-
5000  IF(KOFCIL.EQ.0) GO TO 6000
      WRITE(IOTTO,5010) THMIN,THMAX,STEP
5010  FORMAT('1Pattern from ',F8.4,' to ',F8.4,' in steps of ',
     1       F8.4,' degrees')
      WRITE(IOTTO,5020)
5020  FORMAT(/,'  POSN',6X,'I+B',5X,'B',5X,'I',2X,'100*W',7X,'K11',3X,
     1       'K21')
      DO 5030 J=1,KPPTS
      PX = THMIN + REAL(J-1) * STEP
      YUN = YOBS(J) - YBKG(J)
      WT = 1.0 / AMAX1( YOBS(J), 1.0 )
      WRITE(IOTTO,5040) PX,YOBS(J),YBKG(J),YUN,WT,KR1(J),KR2(J)
5040  FORMAT(1X,F8.4,3F7.0,2PF9.4,2I5)
5030  CONTINUE
C-
C--  CHECK FOR PEAK OVERLAP... LIMITED BY MATRIX SIZE
C-
6000  ITMP = 0
      DO 6010 I=1,KPPTS
      ITMP1 = KR2(I) - KR1(I)
      IF( I.GE.KAMSTR .AND. I.LE.KAMEND ) ITMP1 = ITMP1 + 1
      IF(ITMP1.GT.ITMP) THEN
        ITMP = ITMP1
        IANG = I
      ENDIF
6010  CONTINUE
      ITMP = ITMP + 1
      ANG = THMIN + REAL(IANG-1)*STEP
      WRITE(IOTTO,6020) ITMP,ANG
6020  FORMAT(/,' Maximum number of overlapping reflections:',I4,' at ',
     1  F6.2,' degrees 2theta')
      IF(ITMP.LE.MOVRL) GO TO 7000
      WRITE(IOTTO,6030) ITMP,MOVRL
6030  FORMAT(/,
     1' --The number of overlapping lines (',I4,
     1') exceeds program storage (',I4,').',//,
     1'   Increase the value of *MOVRL* in all parameter statements.',/)
      STOP '--NUMBER OF OVERLAPPING REFLECTIONS EXCEEDS PROGRAM STORAGE'
C-
C--  PACK POINTERS
C-
7000  DO 7010 I=1,KPPTS
7010  KREFRN(I) = KR1(I) + 65536 * KR2(I)
C-
C--  MAKE SURE SOME REFLECTIONS ARE PRESENT AND CHECK ASYMMETRY
C-
8000  DO 8010 I=1,KPPTS
8010  IF( KREFRN(I).NE.0 .AND. KREFRN(I).NE.65536 ) GO TO 9000
      STOP '--ASSIGN: NO REFLECTIONS IN LIST; ABORT'
C-
9000  RETURN
      END
C---  PROGRAM: RIETVELD  (RIET30C1)
C---  VERSION: 881001  (YYMMDD)
C---
      SUBROUTINE ITER
C-
      INCLUDE 'RIETCOM.FOR'
      DOUBLE PRECISION RJACC,RJVXC,AC,BC,UC, RJVXO,RJVX2
      COMMON AC(MMATX,MMATX),BC(MMATX),UC(MMATX),M(MMATX),
     1       RJACC(MMATX,MMATX),RJVXC(MMATX)
      DIMENSION COPPHS(26,MPHAS),COPATM(11,MATMS),COPGLB(19)
      DIMENSION COPSAV(6,MPHAS),RJVX2(MMATX),RJVXO(MMATX)
      EQUIVALENCE ( PGLB(2),BKG0 ), ( PGLB(3),BKG1 ), ( PGLB(4),BKG2 ),
     1            ( PGLB(5),BKG3 ), ( PGLB(6),BKG4 ), ( PGLB(7),BKG5 )
C-
C--  INITIALIZATION OF CYCLE INDEPENDENT VARIABLES
C-
C-  DETERMINE IF STRUCTURE FACTORS NEED BE CALCULATED EVERY CYCLE.
C-    CHECK ATOM AND MAGNETIC CODEWORDS
1000  DO 1010 IPHASE=1,NPHASE
      KCLCSF(IPHASE) = 0
      NATOM = NATM(1,IPHASE)
      IOF = NATM(2,IPHASE) - 1
      DO 1020 I=1,NATOM
      IPIOF = I + IOF
      DO 1030 J=1,11
      IF( LATOM(J,IPIOF).GT.0 .AND. LATOM(J,IPIOF).LE.KMXVAR ) THEN
        KCLCSF(IPHASE) = 1
        GO TO 1010
      ENDIF
1030  CONTINUE
      IF(KMAGSI(IPIOF).EQ.1) THEN
        DO 1040 J=1,3
        IF( LCMAG(J,IPIOF).GT.0 .AND. LCMAG(J,IPIOF).LE.KMXVAR ) THEN
          KCLCSF(IPHASE) = 1
          GO TO 1010
        ENDIF
1040    CONTINUE
      ENDIF
1020  CONTINUE
1010  CONTINUE
C-
C-  COPY ORIGINAL PARAMETERS... THEY MAY BE NEEDED LATER
1100  DO 1110 IPHASE=1,NPHASE
      COPPHS( 1,IPHASE) = PPHSCA(IPHASE)
      COPPHS( 2,IPHASE) = PPHOIT(IPHASE)
      COPPHS( 3,IPHASE) = PPHABS(IPHASE)
      COPPHS( 4,IPHASE) = PPHPSF(1,1,IPHASE)
      COPPHS( 5,IPHASE) = PPHPSF(2,1,IPHASE)
      COPPHS( 6,IPHASE) = PPHPSF(3,1,IPHASE)
      COPPHS( 7,IPHASE) = PPHPSF(1,2,IPHASE)
      COPPHS( 8,IPHASE) = PPHPSF(2,2,IPHASE)
      COPPHS( 9,IPHASE) = PPHPSF(3,2,IPHASE)
      COPPHS(10,IPHASE) = PPHASY(IPHASE)
      COPPHS(11,IPHASE) = PPHUVW(1,1,IPHASE)
      COPPHS(12,IPHASE) = PPHUVW(2,1,IPHASE)
      COPPHS(13,IPHASE) = PPHUVW(3,1,IPHASE)
      COPPHS(14,IPHASE) = PPHUVW(1,2,IPHASE)
      COPPHS(15,IPHASE) = PPHUVW(2,2,IPHASE)
      COPPHS(16,IPHASE) = PPHUVW(3,2,IPHASE)
      COPPHS(17,IPHASE) = PPHLAT(1,IPHASE)
      COPPHS(18,IPHASE) = PPHLAT(2,IPHASE)
      COPPHS(19,IPHASE) = PPHLAT(3,IPHASE)
      COPPHS(20,IPHASE) = PPHLAT(4,IPHASE)
      COPPHS(21,IPHASE) = PPHLAT(5,IPHASE)
      COPPHS(22,IPHASE) = PPHLAT(6,IPHASE)
      COPPHS(23,IPHASE) = PPOPAR(1,1,IPHASE)
      COPPHS(24,IPHASE) = PPOPAR(2,1,IPHASE)
      COPPHS(25,IPHASE) = PPOPAR(1,2,IPHASE)
      COPPHS(26,IPHASE) = PPOPAR(2,2,IPHASE)
      DO 1130 J=1,6
1130  COPSAV(J,IPHASE) = SAVE(J,IPHASE)
1110  CONTINUE
      DO 1140 I=1,MATMS
      DO 1140 J=1,11
1140  COPATM(J,I) = PATOM(J,I)
      DO 1150 I=1,19
1150  COPGLB(I) = PGLB(I)
C-
C---  EXECUTION OF REFINEMENT CYCLES
C-
C-  ERROR TRACKING
2000  ERRLST = 1.0E30
C-
C-  KCUCYC - CURRENT REFINEMENT CYCLE
      DO 2010 KCUCYC=1,KMXCYC
C-
C--  INITIALIZATION OF ROUND DEPENDENT VARIABLES
C-
C-  RESET RELAXATION FACTORS
      OVRRLX = 1.0
      OVRDRL = 0.5
C-
C-  INDICES: NUMBER OF POINTS EVALUATED AND LAST REFLECTION CALCULATED
2028  NMATPT = 0
      IPREV = 1
C-
C-  RESET NORMAL EQUATION MATRIX
      DO 2020 I=1,KMXVAR
      RJVX(I) = 0.0
      DO 2020 J=1,KMXVAR
2020  RJAC(J,I) = 0.0
C-
C--  CALCULATE POLYNOMIAL BACKGROUND IF IT IS BEING REFINED
C-
      IF(NBCKGD.EQ.0) THEN
        TEMP = THMIN - STEP
        DO 2030 I=1,KPPTS
        THX = TEMP + REAL(I) * STEP
        YBKG(I) = BKG5 / THX + BKG0
        THX = THX - 90.0
        YBKG(I)= YBKG(I) + (((BKG4*THX+BKG3)*THX+BKG2)*THX+BKG1)*THX
2030    CONTINUE
      ENDIF
C-
C--  GENERATE AND STORE ALL PROFILES FOR CONVOLUTION
C-
CONVOLUTION
C     IF(KWSGON.GT.0) CALL INIINS
CONVOLUTION
C-
C--  GENERATE THE REFLECTIONS AND FORM SUMMATIONS, ON A PT BY PT BASIS
C-
2100  DO 2110 ICURPT=1,KPPTS
C-
C-  INITIALIZE THE CALCULATED INTENSITY AT THIS POINT
      YCLC(ICURPT) = 0.0
C-
C-  IF POINT IS IN EXCLUDED REGION THEN SKIP IT
      IF(KREFRN(ICURPT).EQ.65536) GO TO 2110
C-
C-  DECODE CONTRIBUTING REFLECTIONS
      IORD1 = IAND( KREFRN(ICURPT),       65535 )
      IORD2 = IAND( KREFRN(ICURPT)/65536, 65535 )
C-
C-  IF THERE IS A CONTRIBUTING REFLECTION THEN PROCEED
C-  IF BACKGROUND IS BEING CALCULATED THEN PROCEED
C-  IF THE POINT IS IN THE RANGE OF AN AMORPHOUS PROFILE THEN PROCEED
C-  OTHERWISE THERE IS NO NEED TO FURTHER CONSIDER THIS POINT
      IF( IORD1 .GT.0 ) THEN
        GO TO 2112
       ELSE IF( NBCKGD.EQ.0 ) THEN
        GO TO 2112
       ELSE IF( ICURPT.GE.KAMSTR .AND. ICURPT.LE.KAMEND ) THEN
        GO TO 2112
       ELSE
        GO TO 2110
      ENDIF
C-
C-  CALCULATE CURRENT ANGLE
2112  CURTHT = THMIN + REAL(ICURPT-1)*STEP
C-
C-  GENERATE PARAMETERS FOR REFLECTIONS IF NOT GENERATED BEFORE.
C-    CALCUL == CALCUL( IORDC )
      IF(IPREV.GT.IORD2) GO TO 2120
      DO 2130 IORDC=IPREV,IORD2
      CALL CALCUL
2130  CONTINUE
2120  IPREV = MAX0( IPREV, IORD2+1 )
C-
C-  GENERATE NUMERICAL DERIVATIVES FOR INTENSITY RELATED PARAMETERS
C-    SUMMAT == SUMMAT( ICURPT )
      CALL SUMMAT
C-
C-  COUNT THIS POINT AS AN OBSERVATION
      NMATPT = NMATPT + 1
C-
C-  END OF POINT BY POINT EVALUATION
2110  CONTINUE
C-
C--  IF ONLY CALCULATING A PATTERN THEN WE ARE FINISHED
C-
      IF(JOBXN.GT.2) GO TO 9000
C-
C--  OBTAIN SOLUTIONS AND TEST RESIDUAL ERRORS
C-
C-  OBTAIN SOLUTIONS.
2200  CALL CSOLVE( RJVX2 )
C-
C-  CHECK IF THE ERROR IS LOWER THAN ON LAST CYCLE
      IF(RESRWP.LT.ERRLST) GO TO 2300
C-
C-  THE ERROR IS HIGHER.  RESTORE ALL PARAMETER VALUES
      DO 2270 IPHASE=1,NPHASE
      PPHSCA(IPHASE)     = COPPHS( 1,IPHASE)
      PPHOIT(IPHASE)     = COPPHS( 2,IPHASE)
      PPHABS(IPHASE)     = COPPHS( 3,IPHASE)
      PPHPSF(1,1,IPHASE) = COPPHS( 4,IPHASE)
      PPHPSF(2,1,IPHASE) = COPPHS( 5,IPHASE)
      PPHPSF(3,1,IPHASE) = COPPHS( 6,IPHASE)
      PPHPSF(1,2,IPHASE) = COPPHS( 7,IPHASE)
      PPHPSF(2,2,IPHASE) = COPPHS( 8,IPHASE)
      PPHPSF(3,2,IPHASE) = COPPHS( 9,IPHASE)
      PPHASY(IPHASE)     = COPPHS(10,IPHASE)
      PPHUVW(1,1,IPHASE) = COPPHS(11,IPHASE)
      PPHUVW(2,1,IPHASE) = COPPHS(12,IPHASE)
      PPHUVW(3,1,IPHASE) = COPPHS(13,IPHASE)
      PPHUVW(1,2,IPHASE) = COPPHS(14,IPHASE)
      PPHUVW(2,2,IPHASE) = COPPHS(15,IPHASE)
      PPHUVW(3,2,IPHASE) = COPPHS(16,IPHASE)
      PPHLAT(1,IPHASE)   = COPPHS(17,IPHASE)
      PPHLAT(2,IPHASE)   = COPPHS(18,IPHASE)
      PPHLAT(3,IPHASE)   = COPPHS(19,IPHASE)
      PPHLAT(4,IPHASE)   = COPPHS(20,IPHASE)
      PPHLAT(5,IPHASE)   = COPPHS(21,IPHASE)
      PPHLAT(6,IPHASE)   = COPPHS(22,IPHASE)
      PPOPAR(1,1,IPHASE) = COPPHS(23,IPHASE)
      PPOPAR(2,1,IPHASE) = COPPHS(24,IPHASE)
      PPOPAR(1,2,IPHASE) = COPPHS(25,IPHASE)
      PPOPAR(2,2,IPHASE) = COPPHS(26,IPHASE)
      DO 2274 J=1,6
2274  SAVE(J,IPHASE) = COPSAV(J,IPHASE)
2270  CONTINUE
      DO 2276 I=1,MATMS
      DO 2276 J=1,11
2276  PATOM(J,I) = COPATM(J,I)
      DO 2278 I=1,19
2278  PGLB(I) = COPGLB(I)
C-
C-  CALCULATE THE NEW VALUE OF THE RELAXATION FACTOR
      OVRRLX = OVRRLX * OVRDRL
      IF(OVRRLX.LT.0.10) THEN
        WRITE(IOTTO,2230)
2230    FORMAT(//,
     1' -The last set of parameters will not decrease the error.',//,
     1' -The value of the relaxation factor is now less than the',
     1' allowed minimum.',//,
     1' -No more refinement cycles will be executed on this round.')
        GO TO 9000
      ENDIF
C-
C-  MULTIPLY THE LAST SET OF ADJUSTMENTS BY THE RELAXATION FACTOR
      DO 2288 I=1,KMXVAR
2288  RJVX(I) = RJVXO(I) * OVRRLX
C-
C-  SET RE-SOLVE FLAG AND RETURN TO OUTPTR TO RE-CALCULATE PARAM VALUES
      CALL OUTPTR
      WRITE(IOTTO,2220) KCUCYC-1
2220  FORMAT(/,
     1' -The error is larger than the low on cycle ',I2,'.  The error',
     1' printed above is',/,
     1'  based on the previous cycle''s parameters and adjustments and',
     1' not the',/,
     1'  parameter values given here.')
      WRITE(IOTTO,2289) OVRRLX
2289  FORMAT(/,
     1' -The adjustments from the last successful cycle have been',
     1' relaxed by ',F6.4)
      WRITE(IOTTO,2287)
2287  FORMAT(/,
     1' -These parameters and their adjustments will now be used to',
     1' calculate the new',/,
     1'  pattern and corresponding error.')
      GO TO 2028
C-
C--  OUTPUT THE CYCLES RESULTS
C-
C-  COPY THE SUCCESSFUL SET OF PARAMETERS
2300  DO 2310 IPHASE=1,NPHASE
      COPPHS( 1,IPHASE) = PPHSCA(IPHASE)
      COPPHS( 2,IPHASE) = PPHOIT(IPHASE)
      COPPHS( 3,IPHASE) = PPHABS(IPHASE)
      COPPHS( 4,IPHASE) = PPHPSF(1,1,IPHASE)
      COPPHS( 5,IPHASE) = PPHPSF(2,1,IPHASE)
      COPPHS( 6,IPHASE) = PPHPSF(3,1,IPHASE)
      COPPHS( 7,IPHASE) = PPHPSF(1,2,IPHASE)
      COPPHS( 8,IPHASE) = PPHPSF(2,2,IPHASE)
      COPPHS( 9,IPHASE) = PPHPSF(3,2,IPHASE)
      COPPHS(10,IPHASE) = PPHASY(IPHASE)
      COPPHS(11,IPHASE) = PPHUVW(1,1,IPHASE)
      COPPHS(12,IPHASE) = PPHUVW(2,1,IPHASE)
      COPPHS(13,IPHASE) = PPHUVW(3,1,IPHASE)
      COPPHS(14,IPHASE) = PPHUVW(1,2,IPHASE)
      COPPHS(15,IPHASE) = PPHUVW(2,2,IPHASE)
      COPPHS(16,IPHASE) = PPHUVW(3,2,IPHASE)
      COPPHS(17,IPHASE) = PPHLAT(1,IPHASE)
      COPPHS(18,IPHASE) = PPHLAT(2,IPHASE)
      COPPHS(19,IPHASE) = PPHLAT(3,IPHASE)
      COPPHS(20,IPHASE) = PPHLAT(4,IPHASE)
      COPPHS(21,IPHASE) = PPHLAT(5,IPHASE)
      COPPHS(22,IPHASE) = PPHLAT(6,IPHASE)
      COPPHS(23,IPHASE) = PPOPAR(1,1,IPHASE)
      COPPHS(24,IPHASE) = PPOPAR(2,1,IPHASE)
      COPPHS(25,IPHASE) = PPOPAR(1,2,IPHASE)
      COPPHS(26,IPHASE) = PPOPAR(2,2,IPHASE)
      DO 2302 J=1,6
2302  COPSAV(J,IPHASE) = SAVE(J,IPHASE)
2310  CONTINUE
      DO 2304 I=1,MATMS
      DO 2304 J=1,11
2304  COPATM(J,I) = PATOM(J,I)
      DO 2306 I=1,19
2306  COPGLB(I) = PGLB(I)
      DO 2308 I=1,KMXVAR
2308  RJVXO(I) = RJVX2(I)
C-
C-  OUTPUT THE ROUNDS RESULTS AND UPDATE PARAMETERS
      CALL OUTPTR
C-
C-  UPDATE THE ERROR TRACKING
      ERRLST = RESRWP
C-
C--  CONVERGENCE TEST.
      DO 2390 I=1,KMXVAR
2390  IF( DABS(RJVX(I)) .GT. DSQRT(DABS(RJAC(I,I)))*EPS ) GO TO 2010
      WRITE(IOTTO,2392)
2392  FORMAT(/,' * * *   Convergence was achieved   * * *')
      GO TO 8000
C-
C-  END OF CYCLES
2010  CONTINUE
C-
C-  COPY LAST CYCLES *ORIGINAL* PARAMETERS...
C-  ENSURES ONLY TESTED PARAMETERS ARE USED IN NEXT CYCLE.
8000  DO 8010 IPHASE=1,NPHASE
      PPHSCA(IPHASE)     = COPPHS( 1,IPHASE)
      PPHOIT(IPHASE)     = COPPHS( 2,IPHASE)
      PPHABS(IPHASE)     = COPPHS( 3,IPHASE)
      PPHPSF(1,1,IPHASE) = COPPHS( 4,IPHASE)
      PPHPSF(2,1,IPHASE) = COPPHS( 5,IPHASE)
      PPHPSF(3,1,IPHASE) = COPPHS( 6,IPHASE)
      PPHPSF(1,2,IPHASE) = COPPHS( 7,IPHASE)
      PPHPSF(2,2,IPHASE) = COPPHS( 8,IPHASE)
      PPHPSF(3,2,IPHASE) = COPPHS( 9,IPHASE)
      PPHASY(IPHASE)     = COPPHS(10,IPHASE)
      PPHUVW(1,1,IPHASE) = COPPHS(11,IPHASE)
      PPHUVW(2,1,IPHASE) = COPPHS(12,IPHASE)
      PPHUVW(3,1,IPHASE) = COPPHS(13,IPHASE)
      PPHUVW(1,2,IPHASE) = COPPHS(14,IPHASE)
      PPHUVW(2,2,IPHASE) = COPPHS(15,IPHASE)
      PPHUVW(3,2,IPHASE) = COPPHS(16,IPHASE)
      PPHLAT(1,IPHASE)   = COPPHS(17,IPHASE)
      PPHLAT(2,IPHASE)   = COPPHS(18,IPHASE)
      PPHLAT(3,IPHASE)   = COPPHS(19,IPHASE)
      PPHLAT(4,IPHASE)   = COPPHS(20,IPHASE)
      PPHLAT(5,IPHASE)   = COPPHS(21,IPHASE)
      PPHLAT(6,IPHASE)   = COPPHS(22,IPHASE)
      PPOPAR(1,1,IPHASE) = COPPHS(23,IPHASE)
      PPOPAR(2,1,IPHASE) = COPPHS(24,IPHASE)
      PPOPAR(1,2,IPHASE) = COPPHS(25,IPHASE)
      PPOPAR(2,2,IPHASE) = COPPHS(26,IPHASE)
      DO 8030 J=1,6
8030  SAVE(J,IPHASE) = COPSAV(J,IPHASE)
8010  CONTINUE
      DO 8040 I=1,MATMS
      DO 8040 J=1,11
8040  PATOM(J,I) = COPATM(J,I)
      DO 8050 I=1,19
8050  PGLB(I) = COPGLB(I)
C-
9000  RETURN
      END
C--  CALCUL - CALCULATE REFLECTION RELATED PARAMETERS
C-
      SUBROUTINE CALCUL
C-
      INCLUDE 'RIETCOM.FOR'
      COMMON TANN(MOVRL),DERSTO(MMATX*MOVRL)
      DIMENSION DERIV(MMATX)
      DIMENSION AL(3,3),HNN(3)
      EQUIVALENCE (LGLB(1),KZERO), (LGLB(10),KDISP)
C-
C-  SET REFLECTION AND DERIVATIVE STORAGE POINTERS
      MODNRF = MOD( IORDC, MOVRL ) + 1
      MODDER = MOD( IORDC-1, MOVRL ) * MMATX
C-
C-  INITIALIZE LOCAL AND GLOBAL-REFLECTION DERIVATIVE STORAGE AREAS
      DO 1010 K=1,KMXVAR
      DERIV(K) = 0.0
      DERSTO(K+MODDER) = 0.0
1010  CONTINUE
C-
C-  PHASE, SCALE FACTOR, WAVELENGTH
      IPHASE = KREFDT(IORDC) / 67108864
      SCALEF = PPHSCA(IPHASE) / VO2CMP(IPHASE)
      IWAVE  = IAND( KREFDT(IORDC)/16777216, 3 )
C-
C-  MODIFIED RECIPROCAL CELL CONSTANTS (MOD. RECIP. METRIC TENSOR)
      AL(1,1) = PPHLAT(1,IPHASE)
      AL(2,2) = PPHLAT(2,IPHASE)
      AL(3,3) = PPHLAT(3,IPHASE)
      AL(3,2) = PPHLAT(4,IPHASE)
      AL(3,1) = PPHLAT(5,IPHASE)
      AL(2,1) = PPHLAT(6,IPHASE)
      AL(1,2) = 0.0
      AL(1,3) = 0.0
      AL(2,3) = 0.0
C-
C-  UNPACK H,K,L FROM IREFS
      HHHH = IAND( KREFDT(IORDC)/65536, 255 ) - 128
      HKKK = IAND( KREFDT(IORDC)/256,   255 ) - 128
      HLLL = IAND( KREFDT(IORDC),       255 ) - 128
      HNN(1) = HHHH
      HNN(2) = HKKK
      HNN(3) = HLLL
C-
C-  CALCULATION OF DSTAR**2 (SS) AND SIN(THETA)**2/LAMBDA**2 (SSNN)
2000  SS = 0.0
      DO 2010 I=1,3
      DO 2010 J=I,3
2010  SS = SS + AL(J,I) * HNN(I) * HNN(J)
      SSNN = 0.25 * SS
C-
C----------------------------------------------------------------------
C--  CALCULATION OF PARAMETER VALUES
C----------------------------------------------------------------------
C-
C-  CALCULATION OF LINE POSITION (DSTAR**2 = 4 SIN**2(THETA)/LAMBDA**2)
      SLABDA       = RADWAV(IWAVE) * RADWAV(IWAVE) / 4.0
      SINSTH       = SLABDA * SS
      COSSTH       = 1.0 - SINSTH
      TANTH        = SQRT( SINSTH / COSSTH )
      TANN(MODNRF) = TANTH
      PREFTT(IORDC)  = ATAN(TANTH) * RTODT2
      CORL2T = PREFTT(IORDC) - CORPOS(PREFTT(IORDC)) + PGLB(1) +
     1         PGLB(10)*SQRT(COSSTH)
C-
C-  CHECK LINE WIDTH FOR MINIMUM
      CALL FNFWHM
      IF( FWHML.EQ.STEP/4.0 .OR. FWHMH.EQ.STEP/4.0 ) THEN
        WRITE(IOTTO,9876) IORDC,IPHASE,PREFTT(IORDC)
9876    FORMAT(
     1   ' -CALCUL: FWHM for ref. ',I4,' (Phase ',I2,', ',F6.2,
     1   ' deg) at min. width (STEP/4).')
      ENDIF
C-
C-  FACTORS FOR PEARSON VII WITH VARIABLE EXPONENT
C-
      IF( NPSF(1,IPHASE).EQ.3 .AND.
     1    ( NPSF(2,IPHASE).EQ.2 .OR. NPSF(2,IPHASE).EQ.3 ) ) THEN
        EXPML= ( PPHPSF(3,1,IPHASE)*PREFTT(IORDC) + PPHPSF(2,1,IPHASE) )
     1          * PREFTT(IORDC) + PPHPSF(1,1,IPHASE)
        PRSTL = 2.0**(1.0/EXPML) - 1.0
        PVM1L = GAMMA(EXPML)
        PVM2L = SQRT(PRSTL)
        PVM3L = GAMMA(EXPML-0.5)
        EXPMH= ( PPHPSF(3,2,IPHASE)*PREFTT(IORDC) + PPHPSF(2,2,IPHASE) )
     1          * PREFTT(IORDC) + PPHPSF(1,2,IPHASE)
        PRSTH = 2.0**(1.0/EXPMH) - 1.0
        PVM1H = GAMMA(EXPMH)
        PVM2H = SQRT(PRSTH)
        PVM3H = GAMMA(EXPMH-0.5)
        PVIIN(IPHASE,MODNRF) = 1.0 /
     1   ( PVM3L / PVM1L / PVM2L + PVM3H / PVM1H / PVM2H )
        IF( LPHPSF(1,1,IPHASE).GT.0 .OR. LPHPSF(2,1,IPHASE).GT.0 .OR.
     1      LPHPSF(3,1,IPHASE).GT.0 ) THEN
          PDM1 = -( PVM1L**(-2) * (GAMMA(EXPML+0.00001)-PVM1L)/0.00001 )
          PDM2 =
     1     -0.5*PRSTL**(-1.5)*2.**(1./EXPML)*ALOG(2.0)*(-(EXPML**(-2)))
          PDM3 = ( GAMMA(EXPML-0.49999) - PVM3L ) / 0.00001
          PVIID(IPHASE,MODNRF) = -2.0 * PRSC * PVIIN(IPHASE,MODNRF)**2
     1     * ( PDM3/PVM1L/PVM2L + PDM1*PVM3L/PVM2L + PDM2*PVM3L/PVM1L )
        ENDIF
        IF( LPHPSF(1,2,IPHASE).GT.0 .OR. LPHPSF(2,2,IPHASE).GT.0 .OR.
     1      LPHPSF(3,2,IPHASE).GT.0 ) THEN
          PDM1 = -( PVM1H**(-2) * (GAMMA(EXPMH+0.00001)-PVM1H)/0.00001 )
          PDM2 =
     1     -0.5*PRSTH**(-1.5)*2.**(1./EXPMH)*ALOG(2.0)*(-(EXPMH**(-2)))
          PDM3 = ( GAMMA(EXPMH-0.49999) - PVM3H ) / 0.00001
          PVIID2(IPHASE,MODNRF) = -2.0 * PRSC * PVIIN(IPHASE,MODNRF)**2
     1     * ( PDM3/PVM1H/PVM2H + PDM1*PVM3H/PVM2H + PDM2*PVM3H/PVM1H )
        ENDIF
        PVIIN(IPHASE,MODNRF) = 2.0 * PRSC * PVIIN(IPHASE,MODNRF)
      ENDIF
      IF( NPSF(1,IPHASE).EQ.3 .AND.
     1    ( NPSF(2,IPHASE).NE.2 .AND. NPSF(2,IPHASE).NE.3 ) ) THEN
        EXPM = ( PPHPSF(3,1,IPHASE)*PREFTT(IORDC) + PPHPSF(2,1,IPHASE) )
     1         * PREFTT(IORDC) + PPHPSF(1,1,IPHASE)
        PRST = 2.0**(1.0/EXPM) - 1.0
        PVM1 = GAMMA(EXPM)
        PVM2 = SQRT(PRST)
        PVM3 = GAMMA(EXPM-0.5)
        PVIIN(IPHASE,MODNRF) = PRSC * PVM1 * PVM2 / PVM3
        IF( LPHPSF(1,1,IPHASE).GT.0 .OR. LPHPSF(2,1,IPHASE).GT.0 .OR.
     1      LPHPSF(3,1,IPHASE).GT.0 ) THEN
          PDM1= (GAMMA(EXPM+0.00001)-PVM1)/0.00001
          PDM2= 0.5*PRST**(-0.5)*2.**(1./EXPM)*ALOG(2.0)*(-(EXPM**(-2)))
          PDM3= -( PVM3**(-2) * (GAMMA(EXPM-0.49999)-PVM3)/0.00001 )
          PVIID(IPHASE,MODNRF) =
     1    PRSC * ( PDM1*PVM2/PVM3 + PVM1*PDM2/PVM3 + PVM1*PVM2*PDM3 )
        ENDIF
      ENDIF
C-
C-  CALCULATION OF THE PREFERRED ORIENTATION CORRECTION
      CALL PRFCRF( 1, HNN, PRECOR, DERIV )
C-
C-  CALCULATION OF THE ABSORPTION CORRECTION
      CALL ABSCRF( 1, PREFTT(IORDC), ABSCOR, DERIV )
C-
C-  OVERALL ISOTROPIC TEMPERATURE FACTOR
      TMPPRE = EXP( -2.0 * PPHOIT(IPHASE) * SSNN )
C-
C-  IF STRUCTURE FACTORS HAVE ALREADY BEEN CALCULATED AND NO SF RELATED
C-  PARAMETERS ARE BEING REFINED THEN DON'T CALCULATE THE SF AGAIN
3000  IF( ( KCUCYC.GT.1 .OR. KCURND.GT.1 ) .AND.
     1    KCLCSF(IPHASE).EQ.0                    ) GO TO 4000
C-
C-  CALCULATION OF THE STRUCTURE FACTOR AND ASSOCIATED DERIVATIVES
      CALL CLCSTR( HHHH, HKKK, HLLL, TMPPRE, ABSCOR, PRECOR )
C-
C-  CALCULATION OF TOTAL STRUCTURE FACTOR
4000  F2TOT(IORDC) = (F2STR(IORDC)+F2MAG(IORDC))*TMPPRE*ABSCOR*PRECOR
C-
C----------------------------------------------------------------------
C--  CALCULATION OF PEAK INTENSITY
C----------------------------------------------------------------------
C-
C-  PROFILE-SHAPE-FUNCTION
      NPSFKK = NPSF(1,IPHASE)
C-
C-  BROADENING PARAMETERS FOR THE LINE
      CALL FNFWHM
      FWHM = FWHML
C-
C-  PROFILE SHAPE FUNCTION PARAMETERS FOR THE LINE
      GAM1   = PPHPSF(1,1,IPHASE)
      GAM2   = PPHPSF(2,1,IPHASE)
      GAM3   = PPHPSF(3,1,IPHASE)
C-
C-  CALCULATION OF PEAK INTENSITY FOR THE LINE
      PREFPK(IORDC)= SCALEF * PREFLP(IORDC) * F2TOT(IORDC) * PROFIL(0.0)
C-
C----------------------------------------------------------------------
C--  CALCULATION OF DERIVATIVES
C----------------------------------------------------------------------
C-
C-  SKIP DERIVATIVE CALCULATION IF ONLY IN PATTERN CALCULATION MODE
      IF(JOBXN.GT.2) GO TO 9000
C-
C-  COPY STRUCTURE FACTOR INTO SCALER VARIABLE
      FFTOT = F2TOT(IORDC)
C-
C- * DERIVATIVES REGARDLES WHETHER OR NOT CONVOLUTION IS USED  ---------
C-
C-  SCALE FACTOR
4200  K = LPHSCA(IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K)+APHSCA(IPHASE)*FFTOT/PPHSCA(IPHASE)
C-
C-  OVERALL ISOTROPIC TEMPERATURE FACTOR
      K = LPHOIT(IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) - APHOIT(IPHASE)*2.0*SSNN*FFTOT
C-
C-  ABSORPTION CORRECTION
      CALL ABSCRF( 2, PREFTT(IORDC), ABSCOR, DERIV )
C-
C-  PREFERRED ORIENTATION PARAMETERS
      CALL PRFCRF( 2, HNN, PRECOR, DERIV )
C-
C-  PROFILE GAM1, GAM2 AND GAM3; LOW AND HIGH ANGLE SIDES
      K = LPHPSF(1,1,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + APHPSF(1,1,IPHASE) * FFTOT
      K = LPHPSF(2,1,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + APHPSF(2,1,IPHASE) * FFTOT
      K = LPHPSF(3,1,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + APHPSF(3,1,IPHASE) * FFTOT
      IF( NPSF(2,IPHASE).EQ.2 .OR. NPSF(2,IPHASE).EQ.3 ) THEN
        K = LPHPSF(1,2,IPHASE)
        IF(K.GT.0) DERIV(K) = DERIV(K) + APHPSF(1,2,IPHASE) * FFTOT
        K = LPHPSF(2,2,IPHASE)
        IF(K.GT.0) DERIV(K) = DERIV(K) + APHPSF(2,2,IPHASE) * FFTOT
        K = LPHPSF(3,2,IPHASE)
        IF(K.GT.0) DERIV(K) = DERIV(K) + APHPSF(3,2,IPHASE) * FFTOT
      ENDIF
C-
C-  ASYMMETRY PARAMETER
      IF(PREFTT(IORDC).LT.RLIM(IPHASE)) THEN
        K = LPHASY(IPHASE)
        IF(K.GT.0) DERIV(K) = DERIV(K) - APHASY(IPHASE) * FFTOT / TANTH
      ENDIF
C-
C-----  EVALUATE DERIVATIVES FOR NON-CONVOLUTED PROFILE FUNCTIONS -----
C-
6000  IF(KWSGON.EQ.1) GO TO 7000
C-
C-  PROFILE BROADENING PARAMETERS: D(HK)/DU, D(HK)/DV, D(HK)/DW
C-    PROFILE BROADENING BASED ON UTAN2O+VTANO+W
      DO 6010 I=1,3
      K = LPHUVW(I,1,IPHASE)
      IF(K.GT.0) THEN
        DERIV(K) = DERIV(K) +
     1    TANTH**(3-I) * APHUVW(I,1,IPHASE) * FFTOT/(2.0*FWHML)
      ENDIF
      K = LPHUVW(I,2,IPHASE)
      IF(K.GT.0) THEN
        DERIV(K) = DERIV(K) +
     1    TANTH**(3-I) * APHUVW(I,2,IPHASE) * FFTOT/(2.0*FWHMH)
      ENDIF
6010  CONTINUE
C-
C-  ZERO PT
      IF(KZERO.GT.0) DERIV(KZERO) = DERIV(KZERO)+AGLB(1)*2.0*FFTOT
C-
C-  SPECIMEN DISPLACEMENT ERROR
      IF(KDISP.GT.0) THEN
        DERIV(KDISP) = DERIV(KDISP)+AGLB(10)*2.0*SQRT(COSSTH)*FFTOT
      ENDIF
C-
C-  RECIPROCAL CELL CONSTANTS
C-  NOTE:  DI/DX * DX/D2OK * D2OK/D(1/D**2) * D(1/D**2)/D(A,B,C,D,E,F)
      TMP = FFTOT * RTODT2 * SLABDA / SQRT(SINSTH*COSSTH)
      K = LPHLAT(1,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + HHHH*HHHH*TMP*APHLAT(1,IPHASE)
      K = LPHLAT(2,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + HKKK*HKKK*TMP*APHLAT(2,IPHASE)
      K = LPHLAT(3,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + HLLL*HLLL*TMP*APHLAT(3,IPHASE)
      K = LPHLAT(4,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + HKKK*HLLL*TMP*APHLAT(4,IPHASE)
      K = LPHLAT(5,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + HHHH*HLLL*TMP*APHLAT(5,IPHASE)
      K = LPHLAT(6,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + HHHH*HKKK*TMP*APHLAT(6,IPHASE)
C-
      GO TO 8000
C-
C-----       EVALUATE DERIVATIVES FOR CONVOLUTING REFLECTIONS     -----
C-
C-  PROFILE HL: D(HK)/DD, D(HK)/DE
C-    PROFILE BROADENING BASED ON PARTICLE SIZE AND STRAIN
7000  K = LPHUVW(1,1,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + APHUVW(1,1,IPHASE) * FFTOT
      K = LPHUVW(2,1,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + APHUVW(2,1,IPHASE) * FFTOT
C-
C-  ZERO PT
      IF(KZERO.GT.0) DERIV(KZERO) = DERIV(KZERO) + AGLB(1) * FFTOT
C-
C-  SPECIMEN DISPLACEMENT ERROR
      IF(KDISP.GT.0) DERIV(KDISP) = DERIV(KDISP) + AGLB(10) * FFTOT
C-
C-  RECIPROCAL CELL CONSTANTS
C-  NOTE:  DI/D2OK * D2OK/D(1/D**2) * D(1/D**2)/D(A,B,C,D,E,F)
      TMP= FFTOT * RTOD * RADWAV(IWAVE)**2 / (4.0*SQRT(SINSTH*COSSTH))
      K = LPHLAT(1,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + HHHH*HHHH*TMP*APHLAT(1,IPHASE)
      K = LPHLAT(2,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + HKKK*HKKK*TMP*APHLAT(2,IPHASE)
      K = LPHLAT(3,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + HLLL*HLLL*TMP*APHLAT(3,IPHASE)
      K = LPHLAT(4,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + HKKK*HLLL*TMP*APHLAT(4,IPHASE)
      K = LPHLAT(5,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + HHHH*HLLL*TMP*APHLAT(5,IPHASE)
      K = LPHLAT(6,IPHASE)
      IF(K.GT.0) DERIV(K) = DERIV(K) + HHHH*HKKK*TMP*APHLAT(6,IPHASE)
C-
C----------------------------------------------------------------------
C-
C--  STORE DERIVATIVES FOR THIS REFLECTION
C-
8000  DO 8010 K=1,KMXVAR
8010  DERSTO(K+MODDER) = DERSTO(K+MODDER) + DERIV(K)
C-
9000  RETURN
      END
C--  CLCSTR - CALCULATION OF THE STRUCTURE FACTOR AND ASSOCIATED DERIVATIVES
C-
      SUBROUTINE CLCSTR( HHHH, HKKK, HLLL, TMPPRE, ABSCOR, PRECOR )
C-
      INCLUDE 'RIETCOM.FOR'
      LOGICAL LANISO,LXRAY,LCLCFP
      COMMON TANN(MOVRL),DERSTO(MMATX*MOVRL)
      DIMENSION DERIV(MMATX),COSSUM(MATMS),SINSUM(MATMS)
      DIMENSION DAXYZ(3,MATMS),DAANI(6:11,MATMS)
      DIMENSION DBXYZ(3,MATMS),DBANI(6:11,MATMS)
      DIMENSION TNDERR(MATMS),TNDERI(MATMS)
      DIMENSION TMD100(MATMS),TMD010(MATMS),TMD001(MATMS)
      DIMENSION AL(3,3),HNN(3)
      DIMENSION RSD100(3),RSD010(3),RSD001(3)
      DATA RSD100 /1.,0.,0./, RSD010 /0.,1.,0./, RSD001 /0.,0.,1./
C-
C-  X-RAY CALCULATION FLAG
1000  LXRAY = JOBXN.EQ.1 .OR. JOBXN.EQ.3
C-
C-  CALCULATE FRIEDEL PAIR FLAG.  IF REFLECTIONS ARE BASED ON EITHER LAUE OR
C-  FRIEDEL-PAIRING, THEN THE FRIEDEL-MATE MUST BE EXPLICITLY INCLUDED IN THE
C-  STRUCTURE FACTOR CALCULATIONS.
      LCLCFP = KINDRF(IPHASE).NE.1
C-
C-  SET DERIVATIVE STORAGE POINTER
      MODDER = MOD( IORDC-1, MOVRL ) * MMATX
C-
C-  NUMBER OF ATOMS, SCALE FACTOR, CENTER FLAG, WAVELENGTH
      NATOM  = NATM(1,IPHASE)
      SCALEF = PPHSCA(IPHASE) / VO2CMP(IPHASE)
      ICENT  = ICET(IPHASE)
      IWAVE  = IAND( KREFDT(IORDC)/16777216, 3 )
C-
C-  ZEROIZE THE DERIVATIVES OF THIS REFLECTION W.R.T. TO PARAMETERS
C-
      DO 1010 K=1,KMXVAR
1010  DERIV(K) = 0.0
      DO 1020 I=1,NATOM
      DO 1030 J=1,3
      DAXYZ(J,I) = 0.0
      DBXYZ(J,I) = 0.0
1030  CONTINUE
      DO 1040 J=6,11
      DAANI(J,I) = 0.0
      DBANI(J,I) = 0.0
1040  CONTINUE
1020  CONTINUE
      SFNAR = 0.0
      SFNBR = 0.0
      SFNAI = 0.0
      SFNBI = 0.0
      SAA100 = 0.0
      SAA010 = 0.0
      SAA001 = 0.0
      SAB100 = 0.0
      SAB010 = 0.0
      SAB001 = 0.0
C-
C-  MODIFIED RECIPROCAL CELL CONSTANTS (MOD. RECIP. METRIC TENSOR)
      AL(1,1) = PPHLAT(1,IPHASE)
      AL(2,2) = PPHLAT(2,IPHASE)
      AL(3,3) = PPHLAT(3,IPHASE)
      AL(3,2) = PPHLAT(4,IPHASE)
      AL(3,1) = PPHLAT(5,IPHASE)
      AL(2,1) = PPHLAT(6,IPHASE)
      AL(1,2) = 0.0
      AL(1,3) = 0.0
      AL(2,3) = 0.0
C-
C-  STORE H,K,L AS A VECTOR
      HNN(1) = HHHH
      HNN(2) = HKKK
      HNN(3) = HLLL
C-
C-  CALCULATION OF DSTAR**2 (SS) AND SIN(THETA)**2/LAMBDA**2 (SSNN)
2000  SS = 0.0
      DO 2010 I=1,3
      DO 2010 J=I,3
2010  SS = SS + AL(J,I) * HNN(I) * HNN(J)
      SSNN = 0.25 * SS
C-
C----------------------------------------------------------------------
C-  CALCULATION OF STRUCTURE FACTORS
C----------------------------------------------------------------------
C-
C-  IOF = OFFSET TO ATOM PARAMETERS/CODEWORDS IN XL/LP
      IOF = NATM(2,IPHASE) - 1
C-
C-  IRNUM = NUMBER OF SYMMETRY OPERATIONS, IROFF = OFFSET FOR POINTERS
      IRNUM = MLT(1,IPHASE)
      IROFF = MLT(2,IPHASE) - 1
C-
C-  I RUNS OVER ALL ATOMS IN THE ASYMMETRIC UNIT
C-
CDBG  WRITE(99,'(/,'' HKL =  '',3F8.4)') HNN
      DO 3010 I=1,NATOM
      IPIOF  = I + IOF
      SUMCOS = 0.0
      SUMSIN = 0.0
C-
C-  CALCULATION OF THE MAGNETIC INTERACTION VECTOR FOR THE ATOM
      IF( LXRAY .OR. KMAGSI(IPIOF).EQ.0 ) GO TO 3012
      T0Q100 = AL(1,1) * RSD100(1) * RSD100(1)
     1       + AL(2,1) * RSD100(2) * RSD100(1)
     1       + AL(3,1) * RSD100(3) * RSD100(1)
     1       + AL(2,2) * RSD100(2) * RSD100(2)
     1       + AL(3,2) * RSD100(3) * RSD100(2)
     1       + AL(3,3) * RSD100(3) * RSD100(3)
      T0Q010 = AL(1,1) * RSD010(1) * RSD010(1)
     1       + AL(2,1) * RSD010(2) * RSD010(1)
     1       + AL(3,1) * RSD010(3) * RSD010(1)
     1       + AL(2,2) * RSD010(2) * RSD010(2)
     1       + AL(3,2) * RSD010(3) * RSD010(2)
     1       + AL(3,3) * RSD010(3) * RSD010(3)
      T0Q001 = AL(1,1) * RSD001(1) * RSD001(1)
     1       + AL(2,1) * RSD001(2) * RSD001(1)
     1       + AL(3,1) * RSD001(3) * RSD001(1)
     1       + AL(2,2) * RSD001(2) * RSD001(2)
     1       + AL(3,2) * RSD001(3) * RSD001(2)
     1       + AL(3,3) * RSD001(3) * RSD001(3)
      T1Q100 = 0.0
      T1Q010 = 0.0
      T1Q001 = 0.0
      DO 2114 J=1,3
      DO 2114 K=J,3
      T1Q100 = T1Q100 +
     1         AL(K,J) * ( RSD100(J)*HNN(K) + RSD100(K)*HNN(J) ) / 2.0
      T1Q010 = T1Q010 +
     1         AL(K,J) * ( RSD010(J)*HNN(K) + RSD010(K)*HNN(J) ) / 2.0
      T1Q001 = T1Q001 +
     1         AL(K,J) * ( RSD001(J)*HNN(K) + RSD001(K)*HNN(J) ) / 2.0
2114  CONTINUE
      T2Q100 = T1Q100 / SQRT( T0Q100 * SS )
      T2Q010 = T1Q010 / SQRT( T0Q010 * SS )
      T2Q001 = T1Q001 / SQRT( T0Q001 * SS )
      QMV100 = SIN( ACOS( T2Q100 ) )
      QMV010 = SIN( ACOS( T2Q010 ) )
      QMV001 = SIN( ACOS( T2Q001 ) )
      QM100 = 0.290521 * QMV100 * PMAGVE(1,IPIOF)
      QM010 = 0.290521 * QMV010 * PMAGVE(2,IPIOF)
      QM001 = 0.290521 * QMV001 * PMAGVE(3,IPIOF)
CDBG  QA100 = ASIN( QMV100 ) * RTOD
CDBG  QA010 = ASIN( QMV010 ) * RTOD
CDBG  QA001 = ASIN( QMV001 ) * RTOD
CDBG  WRITE(99,'('' 100: ANG,MIV = '',3F8.4)') T2Q100,QA100,QMV100
CDBG  WRITE(99,'('' 010: ANG,MIV = '',3F8.4)') T2Q010,QA010,QMV010
CDBG  WRITE(99,'('' 001: ANG,MIV = '',3F8.4)') T2Q001,QA001,QMV001
CDBG  WRITE(99,'('' QMIV = '',5F8.4)') QM100,QM010,QM001
C-
C-  COPY ALL ATOM PARAMETERS INTO SCALER VARIABLES
3012  AXXX = PATOM(1,IPIOF)
      AYYY = PATOM(2,IPIOF)
      AZZZ = PATOM(3,IPIOF)
      ABBB = PATOM(4,IPIOF)
      ANNN = PATOM(5,IPIOF)
C-
C-  LANISO IS TRUE IF ANISOTROPIC TEMPERATURE FACTORS USED FOR THIS ATOM
      LANISO = KANISU(IPIOF).EQ.1
C-
C-  ISOTROPIC TEMPERATURE TERM FOR EQV ATOMS
      TMPISO = EXP( -ABBB * SSNN )
C-
C-  TMPANI IS THE ANISOTROPIC TEMPERATURE TERM FOR EQV ATOMS
      IF(LANISO) THEN
        TMPANI = EXP( -(         HHHH * HHHH * PATOM( 6,IPIOF)
     1                   +       HKKK * HKKK * PATOM( 7,IPIOF)
     1                   +       HLLL * HLLL * PATOM( 8,IPIOF)
     1                   + 2.0 * HHHH * HKKK * PATOM( 9,IPIOF)
     1                   + 2.0 * HHHH * HLLL * PATOM(10,IPIOF)
     1                   + 2.0 * HKKK * HLLL * PATOM(11,IPIOF) ) )
       ELSE
        TMPANI = 1.0
      ENDIF
C-
C-  REPRODUCE ATOMS BASED ON SYMMETRY OPERATIONS
C-
      DO 3020 IR=1,IRNUM
      ISYM = IR + IROFF
C-
C-  SET UP MODIFIED ROTATION (H) AND TRANS (TR) MATRICES BASED ON HKLS
C-    HR1 = H * R11 + K * R21 + L * R31
C-    HR2 = H * R12 + K * R22 + L * R32
C-    HR3 = H * R13 + K * R23 + L * R33
C-    TR  = H *  T1 + K *  T2 + L *  T3
C-
      IVEC1 = IV1(ISYM)
      IVEC2 = IV2(ISYM)
      IVEC3 = IV3(ISYM)
      TR  = HHHH * PVT(IVEC1) + HKKK * PVT(IVEC2) + HLLL * PVT(IVEC3)
      HR1 = HHHH * PVX(IVEC1) + HKKK * PVX(IVEC2) + HLLL * PVX(IVEC3)
      HR2 = HHHH * PVY(IVEC1) + HKKK * PVY(IVEC2) + HLLL * PVY(IVEC3)
      HR3 = HHHH * PVZ(IVEC1) + HKKK * PVZ(IVEC2) + HLLL * PVZ(IVEC3)
C-
C-  PHSANG = 2 PI ( H X(I,R) +K Y(I,R) + L Z(I,R) )
      PHSANG = TWOPI * ( TR + HR1*AXXX + HR2*AYYY + HR3*AZZZ )
C-
C-  SUMCOS = SUM( COS(2PI(HX(I,R)+KY(I,R)+LZ(I,R)) * EXP(ANISO TEMP) )
C-  SUMSIN = SUM( SIN(2PI(HX(I,R)+KY(I,R)+LZ(I,R)) * EXP(ANISO TEMP) )
      COSA = COS(PHSANG) * TMPANI
      SINA = SIN(PHSANG) * TMPANI
      SUMCOS = SUMCOS + COSA
      IF(ICENT.EQ.1) SUMSIN = SUMSIN + SINA
C-
C-  TERMS FOR DERIVATIVES
      DAXYZ(1,I) = DAXYZ(1,I) - HR1 * SINA
      DAXYZ(2,I) = DAXYZ(2,I) - HR2 * SINA
      DAXYZ(3,I) = DAXYZ(3,I) - HR3 * SINA
      IF(LANISO) THEN
        DAANI( 6,I) = DAANI( 6,I) - HHHH * HHHH * COSA
        DAANI( 7,I) = DAANI( 7,I) - HKKK * HKKK * COSA
        DAANI( 8,I) = DAANI( 8,I) - HLLL * HLLL * COSA
        DAANI( 9,I) = DAANI( 9,I) - HHHH * HKKK * COSA
        DAANI(10,I) = DAANI(10,I) - HHHH * HLLL * COSA
        DAANI(11,I) = DAANI(11,I) - HKKK * HLLL * COSA
      ENDIF
C-
      IF(ICENT.NE.1) GO TO 3020
      DBXYZ(1,I) = DBXYZ(1,I) + HR1 * COSA
      DBXYZ(2,I) = DBXYZ(2,I) + HR2 * COSA
      DBXYZ(3,I) = DBXYZ(3,I) + HR3 * COSA
      IF(LANISO) THEN
        DBANI( 6,I) = DBANI( 6,I) - HHHH * HHHH * SINA
        DBANI( 7,I) = DBANI( 7,I) - HKKK * HKKK * SINA
        DBANI( 8,I) = DBANI( 8,I) - HLLL * HLLL * SINA
        DBANI( 9,I) = DBANI( 9,I) - HHHH * HKKK * SINA
        DBANI(10,I) = DBANI(10,I) - HHHH * HLLL * SINA
        DBANI(11,I) = DBANI(11,I) - HKKK * HLLL * SINA
      ENDIF
C-
C-  END OF SUMMATION OVER SYMMETRY RELATED ATOMS
3020  CONTINUE
C-
      COSSUM(I) = SUMCOS
      SINSUM(I) = SUMSIN
C-
C-  CALCULATION OF THE TERMS FOR THE NUCLEAR SCATTERING FACTORS
C-    AFF0FP == f0 + delta-f'
C-    AFFPP  == delta-f''
      NI = KPTR(IPIOF)
      IF(LXRAY) THEN
        AFFPP  = DFPP(NI)
        AFF0FP = DFP(NI)
        DO 3030 II=1,9,2
3030    AFF0FP = AFF0FP + SCATAC(II,NI) * EXP( -SCATAC(II+1,NI) * SSNN )
       ELSE
        AFF0FP = DFP(NI)
        AFFPP  = 0.0
      ENDIF
C-
C-  REAL AND IMAGINARY COMPONENTS OF THE NUCLEAR SCATTERING FACTORS
C-    CORRECTED FOR OCCUPANCY AND ISOTROPIC TEMPERATURE PARAMETERS
      AFCR = ANNN * AFF0FP * TMPISO
      AFCI = ANNN * AFFPP  * TMPISO
C-
C--  CONTRIBUTIONS TO NUCLEAR REAL AND IMAGINARY COMPONENTS OF A AND B
      SFNAR = SFNAR + AFCR * SUMCOS
      SFNAI = SFNAI + AFCI * SUMCOS
      SFNBR = SFNBR - AFCI * SUMSIN
      SFNBI = SFNBI + AFCR * SUMSIN
CDBG  WRITE(99,'('' AR,AI,BR,BI = '',4F10.4)') SFNAR,SFNAI,SFNBR,SFNBI
C-
C-  TERMS FOR NUCLEAR-RELATED DERIVATIVES
      TNDERR(I) = ( 2.0 * RADREL(IWAVE) ) * AFCR
      TNDERI(I) = ( 2.0 * RADREL(IWAVE) ) * AFCI
C-
C-  CALCULATION OF THE TERMS FOR THE MAGNETIC SCATTERING FACTORS FOR ATOM
C-    AFF0FP == MAGNETIC FORM FACTOR FOR MAGNETIC ATOM
      IF( .NOT.LXRAY .AND. KMAGSI(IPIOF).EQ.1 ) THEN
        NI = KPTR(IPIOF)
        AFF0FP = 0.0
        DO 3040 II=1,9,2
3040    AFF0FP = AFF0FP + SCATAC(II,NI) * EXP( -SCATAC(II+1,NI) * SSNN )
CDBG    WRITE(99,'(''  Mag IPIOF,NI,AFF0FP = '',2I3,F6.3)')
CDBG 1   IPIOF,NI,AFF0FP
        SAH100 = ANNN * ( QM100 * AFF0FP ) * TMPISO
        SAH010 = ANNN * ( QM010 * AFF0FP ) * TMPISO
        SAH001 = ANNN * ( QM001 * AFF0FP ) * TMPISO
        SAA100 = SAA100 + SAH100 * SUMCOS
        SAA010 = SAA010 + SAH010 * SUMCOS
        SAA001 = SAA001 + SAH001 * SUMCOS
        SAB100 = SAB100 + SAH100 * SUMSIN
        SAB010 = SAB010 + SAH010 * SUMSIN
        SAB001 = SAB001 + SAH001 * SUMSIN
        TMD100(I) = ( 2.0 * RADREL(IWAVE) ) * SAH100
        TMD010(I) = ( 2.0 * RADREL(IWAVE) ) * SAH010
        TMD001(I) = ( 2.0 * RADREL(IWAVE) ) * SAH001
      ENDIF
C-
C-  END OF SUMMATION OVER ASYMMETRIC UNIT
3010  CONTINUE
C-
C-  THE NUCLEAR STRUCTURE FACTOR FOR REFLECTION IORDC.  EXPLICITLY INCLUDE
C-    THE FRIEDEL PAIR-MATE IF LINES NOT INDIVIDUALIZED.
      IF(.NOT.LCLCFP) THEN
        FPHKL = ( SFNAR + SFNBR )**2 + ( SFNAI + SFNBI )**2
        F2STR(IORDC) = FPHKL
CDBG    WRITE(99,'('' F P = U= '',F10.4)') F2STR(IORDC)
       ELSE
        FPHKL = ( SFNAR + SFNBR )**2 + ( SFNAI + SFNBI )**2
        FMHKL = ( SFNAR - SFNBR )**2 + ( SFNAI - SFNBI )**2
        F2STR(IORDC) = 0.5 * ( FPHKL + FMHKL )
CDBG    WRITE(99,'('' F P,M U= '',4F10.4)') FPHKL,FMHKL,F2STR(IORDC)
      ENDIF
C-
C-  THE MAGNETIC STRUCTURE FACTOR FOR REFLECTION IORDC
      IF(.NOT.LXRAY) THEN
        F2MAG(IORDC) = SAA100**2 + SAA010**2 + SAA001**2
     1               + SAB100**2 + SAB010**2 + SAB001**2
       ELSE
        F2MAG(IORDC) = 0.0
      ENDIF
C-
C-  THE STRUCTURE FACTORS CORRECTED FOR PREFERRED ORIENTATION, OVERALL
C-  ISOTROPIC TEMPERATURE FACTOR, AND WAVELENGTH RELATIVE INTENSITY
C-
      F2STR(IORDC) = RADREL(IWAVE) * F2STR(IORDC)
      F2MAG(IORDC) = RADREL(IWAVE) * F2MAG(IORDC)
      F2TOT(IORDC) = F2STR(IORDC) + F2MAG(IORDC)
      WRITE(99,'(''  F2T,F2N,F2M = '',3E13.5)') F2TOT(IORDC),
     1  F2STR(IORDC),F2MAG(IORDC)
C-
C----------------------------------------------------------------------
C-  CALCULATION OF DERIVATIVES
C----------------------------------------------------------------------
C-
C-  SKIP DERIVATIVE CALCULATION IF ONLY IN PATTERN CALCULATION MODE
4000  IF(JOBXN.GT.2) GO TO 9000
C-
C-  COPY STRUCTURE FACTORS INTO SCALERS
      FFSTR = F2STR(IORDC)
      FFMAG = F2MAG(IORDC)
      FFTOT = F2TOT(IORDC)
C-
C-  REPEAT FOR EACH ATOM (I)
C-
4100  DO 4110 I=1,NATOM
      IPIOF = I + IOF
C-
C-  DERIVATIVES WRT NUCLEAR STRUCTURE FACTOR.  EXPLICITLY INLCUDE FRIEDEL
C-    PAIR SO COMBINED INTENSITY IS CALCULATED CORRECTLY.
C-
      TRDER  = TNDERR(I)
      TIDER  = TNDERI(I)
      SUMCOS = COSSUM(I)
      SUMSIN = SINSUM(I)
C-
C-  ATOM POSITION
      DO 4120 J=1,3
      K = LATOM(J,IPIOF)
      IF(K.EQ.0) GO TO 4120
      DXYZA = DAXYZ(J,I)
      DXYZB = DBXYZ(J,I)
      DER = TWOPI * ( (SFNAR+SFNBR) * (DXYZA*TRDER-DXYZB*TIDER) +
     1                (SFNAI+SFNBI) * (DXYZA*TIDER+DXYZB*TRDER)   )
      IF(LCLCFP) THEN
        DERM= TWOPI * ( (SFNAR-SFNBR) * (DXYZA*TRDER+DXYZB*TIDER) +
     1                  (SFNAI-SFNBI) * (DXYZA*TIDER-DXYZB*TRDER)   )
        DER = 0.5 * ( DER + DERM )
      ENDIF
      DERIV(K) = DERIV(K) + AATOM(J,IPIOF) * DER
4120  CONTINUE
C-
C-  ISOTROPIC THERMAL
      K = LATOM(4,IPIOF)
      IF(K.GT.0) THEN
        DER = -SSNN * ( (SFNAR+SFNBR) * (SUMCOS*TRDER-SUMSIN*TIDER) +
     1                  (SFNAI+SFNBI) * (SUMCOS*TIDER+SUMSIN*TRDER)   )
        IF(LCLCFP) THEN
          DERM= -SSNN*( (SFNAR-SFNBR) * (SUMCOS*TRDER+SUMSIN*TIDER) +
     1                  (SFNAI-SFNBI) * (SUMCOS*TIDER-SUMSIN*TRDER)   )
          DER = 0.5 * ( DER + DERM )
        ENDIF
        DERIV(K) = DERIV(K) + AATOM(4,IPIOF) * DER
      ENDIF
C-
C-  OCCUPANCY
      K = LATOM(5,IPIOF)
      IF(K.GT.0) THEN
        DER = ( (SFNAR+SFNBR) * (SUMCOS*TRDER-SUMSIN*TIDER) +
     1          (SFNAI+SFNBI) * (SUMCOS*TIDER+SUMSIN*TRDER)   )
     1        / PATOM(5,IPIOF)
        IF(LCLCFP) THEN
          DERM= ( (SFNAR-SFNBR) * (SUMCOS*TRDER+SUMSIN*TIDER) +
     1            (SFNAI-SFNBI) * (SUMCOS*TIDER-SUMSIN*TRDER)   )
     1          / PATOM(5,IPIOF)
          DER = 0.5 * ( DER + DERM )
        ENDIF
        DERIV(K) = DERIV(K) + AATOM(5,IPIOF) * DER
      ENDIF
C-
C-  ANISOTROPIC THERMAL
      IF(KANISU(IPIOF).EQ.1) THEN
        DO 4130 J=6,11
        K = LATOM(J,IPIOF)
        IF(K.EQ.0) GO TO 4130
        DANIA = DAANI(J,I)
        DANIB = DBANI(J,I)
        DER = (SFNAR+SFNBR) * (DANIA*TRDER-DANIB*TIDER) +
     1        (SFNAI+SFNBI) * (DANIA*TIDER+DANIB*TRDER)
        IF(LCLCFP) THEN
          DERM= (SFNAR-SFNBR) * (DANIA*TRDER+DANIB*TIDER) +
     1          (SFNAI-SFNBI) * (DANIA*TIDER-DANIB*TRDER)
          DER = 0.5 * ( DER + DERM )
        ENDIF
        IF(J.GT.8) DER = 2.0 * DER
        DERIV(K) = DERIV(K) + AATOM(J,IPIOF) * DER
4130    CONTINUE
      ENDIF
C-
C-  DERIVATIVES WRT MAGNETIC STRUCTURE FACTOR
      IF( LXRAY .OR. KMAGSI(IPIOF).EQ.0 ) GO TO 4110
C-
      TRM100 = TMD100(I)
      TRM010 = TMD010(I)
      TRM001 = TMD001(I)
C-
C-  ATOM POSITION
      DO 4140 J=1,3
      K = LATOM(J,IPIOF)
      IF(K.EQ.0) GO TO 4140
      DXYZA = DAXYZ(J,I)
      DXYZB = DBXYZ(J,I)
      DER = -TWOPI * (   ( SAA100*DXYZA - SAB100*DXYZB ) * TRM100
     1                 + ( SAA010*DXYZA - SAB010*DXYZB ) * TRM010
     1                 + ( SAA001*DXYZA - SAB001*DXYZB ) * TRM001 )
      DERIV(K) = DERIV(K) + AATOM(J,IPIOF) * DER
4140  CONTINUE
C-
C-  ISOTROPIC THERMAL
      K = LATOM(4,IPIOF)
      IF(K.GT.0) THEN
        DER = -SSNN * (   ( SUMCOS*SAA100 + SUMSIN*SAB100 ) * TRM100
     1                  + ( SUMCOS*SAA010 + SUMSIN*SAB010 ) * TRM010
     1                  + ( SUMCOS*SAA001 + SUMSIN*SAB001 ) * TRM001 )
        DERIV(K) = DERIV(K) + AATOM(4,IPIOF) * DER
      ENDIF
C-
C-  OCCUPANCY
      K = LATOM(5,IPIOF)
      IF(K.GT.0) THEN
        DER = (   ( SUMCOS*SAA100 + SUMSIN*SAB100 ) * TRM100
     1          + ( SUMCOS*SAA010 + SUMSIN*SAB010 ) * TRM010
     1          + ( SUMCOS*SAA001 + SUMSIN*SAB001 ) * TRM001 )
     1        / PATOM(5,IPIOF)
        DERIV(K) = DERIV(K) + AATOM(5,IPIOF) * DER
      ENDIF
C-
C-  ANISOTROPIC THERMAL
      IF(KANISU(IPIOF).EQ.1) THEN
        DO 4150 J=6,11
        K = LATOM(J,IPIOF)
        IF(K.EQ.0) GO TO 4150
        DANIA = DAANI(J,I)
        DANIB = DBANI(J,I)
        DER = -(   ( SAA100*DANIA + SAB100*DANIB ) * TRM100
     1           + ( SAA010*DANIA + SAB010*DANIB ) * TRM010
     1           + ( SAA001*DANIA + SAB001*DANIB ) * TRM001  )
        IF(J.GT.8) DER = 2.0 * DER
        DERIV(K) = DERIV(K) + AATOM(J,IPIOF) * DER
4150    CONTINUE
      ENDIF
C-
C-  MAGNETIC SCATTERING VECTOR
      K = LCMAG(1,IPIOF)
      IF(K.GT.0) THEN
        DER= ( SUMCOS*SAA100 + SUMSIN*SAB100 ) * TRM100/PMAGVE(1,IPIOF)
        DERIV(K) = DERIV(K) + CMAGVE(1,IPIOF) * DER
      ENDIF
      K = LCMAG(2,IPIOF)
      IF(K.GT.0) THEN
        DER= ( SUMCOS*SAA010 + SUMSIN*SAB010 ) * TRM010/PMAGVE(2,IPIOF)
        DERIV(K) = DERIV(K) + CMAGVE(2,IPIOF) * DER
      ENDIF
      K = LCMAG(3,IPIOF)
      IF(K.GT.0) THEN
        DER= ( SUMCOS*SAA001 + SUMSIN*SAB001 ) * TRM001/PMAGVE(3,IPIOF)
        DERIV(K) = DERIV(K) + CMAGVE(3,IPIOF) * DER
      ENDIF
C-
C-  END OF DERIVATIVES LOOP FOR ATOM PARAMETERS
4110  CONTINUE
C-
C----------------------------------------------------------------------
C-
C--  STORE DERIVATIVES FOR THIS REFLECTION
C-
8000  DO 8010 K=1,KMXVAR
8010  DERSTO(K+MODDER) = DERSTO(K+MODDER)+DERIV(K)*TMPPRE*ABSCOR*PRECOR
C-
9000  RETURN
      END
C--  SUMMAT
C-
      SUBROUTINE SUMMAT
C-
      INCLUDE 'RIETCOM.FOR'
      LOGICAL LASYM
      COMMON TANN(MOVRL),DERSTO(MMATX*MOVRL)
      DIMENSION DERIV(MMATX), KUSED(0:MMATX)
      EQUIVALENCE (LGLB(2),KBKG0), (LGLB(3),KBKG1), (LGLB(4),KBKG2)
      EQUIVALENCE (LGLB(5),KBKG3), (LGLB(6),KBKG4), (LGLB(7),KBKG5)
      EQUIVALENCE (LGLB(1),KZERO), (LGLB(10),KDISP)
C-
C--  INITIALIZE
C-
1000  DO 1010 K=1,KMXVAR
      KUSED(K) = 0
      DERIV(K) = 0.0
1010  CONTINUE
      YCALC = 0.0
C-
C----------------------------------------------------------------------
C-  LOOP THROUGH BRAGG REFLECTIONS
C----------------------------------------------------------------------
C-
2000  IF(IORD1.EQ.0) GO TO 2300
C-
C-  REPEAT FOR EACH CONTRIBUTING REFLECTION
      DO 2010 IORDC=IORD1,IORD2
C-
C--CONTRIBUTIONS TO I(CURTHT)-------------------------------------------
C-
C-  PHASE, WAVELENGTH, SCALE FACTOR AND PSF
      IPHASE = KREFDT(IORDC) / 67108864
      SCALEF = PPHSCA(IPHASE) / VO2CMP(IPHASE)
      NPSFKK = NPSF(1,IPHASE)
      TWOTHT = PREFTT(IORDC)
C-
C-  INDEX TO REFLECTION DERIVATIVES
      MODNRF = MOD( IORDC, MOVRL ) + 1
      MODDER = MOD( IORDC-1, MOVRL ) * MMATX
C-
C-  USE CORRECTED 2THETA TO DETERMINE OFFSET FROM LINE MAXIMUM
C-  CALC = OBS + CORPOS ==> OBS = CALC - CORPOS
      CORL2T = TWOTHT-CORPOS(TWOTHT)+PGLB(1)+PGLB(10)*COS(TWOTHT*DTORD2)
      TTHOMC  = CURTHT - CORL2T
C *
C *  BROADENING PARAMETERS FOR THE LINE
      CALL FNFWHM
      IF( CURTHT.GT.PREFTT(IORDC) .AND.
     1    ( NPSF(2,IPHASE).EQ.1 .OR. NPSF(2,IPHASE).EQ.3 ) ) THEN
        FWHM = FWHMH
       ELSE
        FWHM = FWHML
      ENDIF
C *
C *  PROFILE SHAPE FUNCTION PARAMETERS FOR THE LINE
      IF( CURTHT.GT.PREFTT(IORDC) .AND.
     1   ( NPSF(2,IPHASE).EQ.2 .OR. NPSF(2,IPHASE).EQ.3 ) ) THEN
        GAM1   = PPHPSF(1,2,IPHASE)
        GAM2   = PPHPSF(2,2,IPHASE)
        GAM3   = PPHPSF(3,2,IPHASE)
       ELSE
        GAM1   = PPHPSF(1,1,IPHASE)
        GAM2   = PPHPSF(2,1,IPHASE)
        GAM3   = PPHPSF(3,1,IPHASE)
      ENDIF
      EXPM  = ( GAM3*PREFTT(IORDC) + GAM2 )*PREFTT(IORDC) + GAM1
C-
C-  REQUIRED PARAMETERS
      FWHM2  = FWHM * FWHM
      DELTA2 = TTHOMC * TTHOMC
      DLTDBB = DELTA2 / FWHM2
C-
C-  DETERMINE IF PROFILE ASYMMETRY CORRECTION TO BE APPLIED
      LASYM = TWOTHT.LT.RLIM(IPHASE)
C-
C-  CALCULATION OF THE ASYMMETRY CORRECTION FACTOR
      IF(LASYM) THEN
        VRTY = DELTA2 * SIGN(1.0,TTHOMC)
        VRTZ = 1.0 - PPHASY(IPHASE) * VRTY / TANN(MODNRF)
        IF(VRTZ.LE.0.0) VRTZ = 0.0001
        VRTX = PPHASY(IPHASE)*SIGN(1.0,TTHOMC)*FWHM2/TANN(MODNRF)/VRTZ
       ELSE
        VRTZ = 1.0
        VRTX = 0.0
      ENDIF
C-
C-  GENERATE PSF VALUE FOR THIS CONTRIBUTING REFLECTION
C-
C-  WITH CONVOLUTION
CONVOLUTION
C     IF(KWSGON.NE.1) GO TO 2100
C     CALL GETCCI( WSGI, WSGIDS, WSGIDE, WSGIDP, NLWSG, NPWSG )
CDBG  IF( NLWSG.NE.IORDC .OR. NPWSG.NE.ICURPT ) WRITE(IOTTO,2102)
CDBG 1 IORDC,ICURPT,NLWSG,NPWSG
C2102 FORMAT('--SUMMAT ASKED FOR LINE, POINT = ',2I5,/,
CDBG 1        '    GETCCI RETURNED LINE,POINT = ',2I5)
C     OMEGA = SCALEF * PREFLP(IORDC) * WSGI
C     GO TO 2200
CONVOLUTION
C-
2100  OMEGA = SCALEF * PREFLP(IORDC) * VRTZ * PROFIL(DLTDBB)
C-
C-  ADD THE CONTRIBUTION FROM THIS REFLECTION TO THE POINT INTENSITY
C-
2200  YCALC = YCALC + OMEGA * F2TOT(IORDC)
C-
C--DERIVATIVES----------------------------------------------------------
C-
C-  DONT EVALUTE DERIVATIVES IF JUST CALCULATING A PATTERN
3000  IF(JOBXN.GT.2) GO TO 2010
C-
C-----  EVALUATE DERIVATIVES FOR NON-CONVOLUTED PROFILE FUNCTIONS -----
C-
      IF(KWSGON.EQ.1) GO TO 4000
C-
C-  PROFILE BROADENING PARAMETERS
C-
C-    DI/D(U,V,W) = DI/DHK * DHK/D(U,V,W)
      DO 3010 I=1,3
C-
      IF( NPSF(2,IPHASE).EQ.1 .OR. NPSF(2,IPHASE).EQ.3 ) GO TO 3012
C-
C-  SINGLE LINE PROFILE
      K = LPHUVW(I,1,IPHASE)
      IF(K.GT.0) THEN
        DEROME = ( PSFDX*2.0*DLTDBB - 1.0 ) / FWHM * OMEGA
        DERIV(K) = DERIV(K) + DEROME * DERSTO(K+MODDER)
        KUSED(K) = 1
      ENDIF
      GO TO 3010
C-
C-  SPLIT LINE PROFILE
3012  K = LPHUVW(I,1,IPHASE)
      IF(K.GT.0) THEN
        IF(TTHOMC.LE.0.0) THEN
          DEROME = OMEGA * PSFDY(1)
         ELSE
          DEROME = OMEGA * PSFDY(2)
        ENDIF
        DERIV(K) = DERIV(K) + DEROME * DERSTO(K+MODDER)
        KUSED(K) = 1
      ENDIF
      K = LPHUVW(I,2,IPHASE)
      IF(K.GT.0) THEN
        IF(TTHOMC.LE.0.0) THEN
          DEROME = OMEGA * PSFDY(3)
         ELSE
          DEROME = OMEGA * PSFDY(4)
        ENDIF
        DERIV(K) = DERIV(K) + DEROME * DERSTO(K+MODDER)
        KUSED(K) = 1
      ENDIF
C-
3010  CONTINUE
C-
C-  ZERO PT
      IF(KZERO.GT.0) THEN
        DER = TTHOMC / FWHM2 * ( PSFDX + VRTX )
        DERIV(KZERO) = DERIV(KZERO) + DER * DERSTO(KZERO+MODDER) * OMEGA
        KUSED(KZERO) = 1
      ENDIF
C-
C-  SPECIMEN DISPLACEMENT ERROR
      IF(KDISP.GT.0) THEN
        DER = TTHOMC / FWHM2 * ( PSFDX + VRTX )
        DERIV(KDISP) = DERIV(KDISP) + DER * DERSTO(KDISP+MODDER) * OMEGA
        KUSED(KDISP) = 1
      ENDIF
C-
C-  ASYMMETRY PARAMETER
      IF(LASYM) THEN
        K = LPHASY(IPHASE)
        IF(K.GT.0) THEN
          DER = VRTY / VRTZ
          DERIV(K) = DERIV(K) + DER * DERSTO(K+MODDER) * OMEGA
          KUSED(K) = 1
        ENDIF
      ENDIF
C-
C-  RECIPROCAL CELL CONSTANTS
      DEROME = ( TTHOMC / FWHM2 * ( PSFDX + VRTX ) ) * OMEGA
      DO 3030 M=1,6
      K = LPHLAT(M,IPHASE)
      IF(K.GT.0) THEN
        DERIV(K) = DERIV(K) + DEROME * DERSTO(K+MODDER)
        KUSED(K) = 1
      ENDIF
3030  CONTINUE
C-
C-  DERIVATIVES FOR SHAPE-RELATED PRAMETERS
C-
      GO TO (3020,3600,3700),NPSFKK
      STOP '--SUMMAT: Unknown PSF selected'
C-
C-  PSEUDO-VOIGT
3600  ANGLE = PREFTT(IORDC)
      DER = PREFLP(IORDC) * VRTZ * SCALEF * PSFDY(5)
      DO 3610 I=1,3
      K = LPHPSF(I,1,IPHASE)
      IF(K.GT.0) THEN
        DERIV(K) = DERIV(K) + DER * DERSTO(K+MODDER)
        KUSED(K) = 1
      ENDIF
      K = LPHPSF(I,2,IPHASE)
      IF(K.GT.0) THEN
        DERIV(K) = DERIV(K) + DER * DERSTO(K+MODDER)
        KUSED(K) = 1
      ENDIF
      DER = DER * ANGLE
3610  CONTINUE
      GO TO 3020
C-
C-  PEARSON VII WITH VARIABLE M
3700  IF( NPSF(2,IPHASE).EQ.2 .OR. NPSF(2,IPHASE).EQ.3 ) GO TO 3750
      ANGLE = PREFTT(IORDC)
      DER = PREFLP(IORDC) * VRTZ * SCALEF * PSFDY(5)
      DO 3710 I=1,3
      K = LPHPSF(I,1,IPHASE)
      IF(K.GT.0) THEN
        DERIV(K) = DERIV(K) + DER * DERSTO(K+MODDER)
        KUSED(K) = 1
      ENDIF
      K = LPHPSF(I,2,IPHASE)
      IF(K.GT.0) THEN
        DERIV(K) = DERIV(K) + DER * DERSTO(K+MODDER)
        KUSED(K) = 1
      ENDIF
      DER = DER * ANGLE
3710  CONTINUE
      GO TO 3020
3750  ANGLE = 1.0
      DO 3760 I=1,3
      K = LPHPSF(I,1,IPHASE)
      IF(K.GT.0) THEN
        IF(TTHOMC.LE.0.0) THEN
          DER = PREFLP(IORDC) * VRTZ * SCALEF * ANGLE * PSFDY(5)
         ELSE
          DER = PREFLP(IORDC) * VRTZ * SCALEF * ANGLE * PSFDY(6)
        ENDIF
        DERIV(K) = DERIV(K) + DER * DERSTO(K+MODDER)
        KUSED(K) = 1
      ENDIF
      K = LPHPSF(I,2,IPHASE)
      IF(K.GT.0) THEN
        IF(TTHOMC.LE.0.0) THEN
          DER = PREFLP(IORDC) * VRTZ * SCALEF * ANGLE * PSFDY(7)
         ELSE
          DER = PREFLP(IORDC) * VRTZ * SCALEF * ANGLE * PSFDY(8)
        ENDIF
        DERIV(K) = DERIV(K) + DER * DERSTO(K+MODDER)
        KUSED(K) = 1
      ENDIF
      ANGLE = ANGLE * PREFTT(IORDC)
3760  CONTINUE
C-
C-
3020  DO 3040 K=1,KMXVAR
      IF(KUSED(K).EQ.0) DERIV(K) = DERIV(K) + DERSTO(K+MODDER) * OMEGA
3040  CONTINUE
      GO TO 2010
C-
C-----       EVALUATE DERIVATIVES FOR CONVOLUTING REFLECTIONS     -----
C-
C-  PROFILE WIDTH PARAMETERS
C-    NOTE: GENERATE D(YI)/D(HK) SO THAT MULTIPLICATION RESULTS IN
C-      D(YI)/D(HK) * D(HK)/D(DD,DE) => D(YI)/D(DD,DE)
4000  K = LPHUVW(1,1,IPHASE)
      IF(K.GT.0) THEN
        DER = PREFLP(IORDC) * WSGIDS * SCALEF
        DERIV(K) = DERIV(K) + DERSTO(K+MODDER) * DER
        KUSED(K) = 1
      ENDIF
      K = LPHUVW(2,1,IPHASE)
      IF(K.GT.0) THEN
        DER = PREFLP(IORDC) * WSGIDE * SCALEF
        DERIV(K) = DERIV(K) + DERSTO(K+MODDER) * DER
        KUSED(K) = 1
      ENDIF
C-
C-  ZERO PT
      IF(KZERO.GT.0) THEN
        DER = PREFLP(IORDC) * WSGIDP * SCALEF
        DERIV(KZERO) =  DERIV(KZERO) + DERSTO(KZERO+MODDER) * DER
        KUSED(KZERO) = 1
      ENDIF
C-
C-  SPECIMEN DISPLACEMENT ERROR
      IF(KDISP.GT.0) THEN
        DER = PREFLP(IORDC) * WSGIDP * SCALEF * COS(TWOTHT*DTORD2)
        DERIV(KDISP) =  DERIV(KDISP) + DERSTO(KDISP+MODDER) * DER
        KUSED(KDISP) = 1
      ENDIF
C-
C-  RECIPROCAL CELL CONSTANTS
      DER = PREFLP(IORDC) * WSGIDP * SCALEF
      DO 4020 M=1,6
      K = LPHLAT(M,IPHASE)
      IF(K.GT.0) THEN
        DERIV(K) = DERIV(K) + DERSTO(K+MODDER) * DER
        KUSED(K) = 1
      ENDIF
4020  CONTINUE
C-
      DO 4005 K=1,KMXVAR
4005  IF(KUSED(K).EQ.0) DERIV(K) = DERIV(K) + DERSTO(K+MODDER) * OMEGA
C-
C-  END OF CYCLES FOR CONTRIBUTING BRAGG REFLECTIONS
2010  CONTINUE
C-
C----------------------------------------------------------------------
C-  GLOBAL PARAMETERS CONTRIBUTING TO POINT
C----------------------------------------------------------------------
C-
C-  GENERATE CONTRIBUTION AND DERIVATIVES FOR AMORPHOUS PROFILE
C-
2300  IF(KAMOR.EQ.0) GO TO 2400
      IF( ICURPT.LT.KAMSTR .OR. ICURPT.GT.KAMEND ) GO TO 2400
      TMP0 = -0.6931471806 / (PGLB(13)/2.0)**2
      TMP1 = CURTHT - PGLB(11)
      TMP2 = EXP( TMP0 * TMP1**2 )
      YAMO = PGLB(12) * TMP2
      YCALC = YCALC + YAMO
      K = LGLB(11)
      IF(K.GT.0) DERIV(K) = DERIV(K) - YAMO*2.0*TMP0*TMP1
      K = LGLB(12)
      IF(K.GT.0) DERIV(K) = DERIV(K) + TMP2
      K = LGLB(13)
      IF(K.GT.0) DERIV(K) = DERIV(K) - YAMO*TMP0*(PGLB(13)/2.0)*TMP1**2
C-
C-  STORE THE CALCULATED INTENSITY AT THIS POINT
2400  YCLC(ICURPT) = YCALC
C-
C----------------------------------------------------------------------
C-  DERIVATIVES FOR REFINED BACKGROUND...
C----------------------------------------------------------------------
C-
C-  USE UNCORRECTED CURRENT 2THETA
5000  IF(NBCKGD.EQ.0) THEN
        THX  = CURTHT - 90.0
        THXM = THX
        IF(KBKG0.GT.0) DERIV(KBKG0) = DERIV(KBKG0) + 1.0
        IF(KBKG1.GT.0) DERIV(KBKG1) = DERIV(KBKG1) + THX
        THX = THX * THXM
        IF(KBKG2.GT.0) DERIV(KBKG2) = DERIV(KBKG2) + THX
        THX = THX * THXM
        IF(KBKG3.GT.0) DERIV(KBKG3) = DERIV(KBKG3) + THX
        THX = THX * THXM
        IF(KBKG4.GT.0) DERIV(KBKG4) = DERIV(KBKG4) + THX
        IF(KBKG5.GT.0) DERIV(KBKG5) = DERIV(KBKG5) + 1.0 / CURTHT
      ENDIF
C-
C----------------------------------------------------------------------
C-  STORE THE NORMAL MATRIX ELEMENTS
C----------------------------------------------------------------------
C-
C-  NOTE: THE VARIANCE OF YOBS(I) FOR YOBS(I) < 1 SET EQUAL TO 1
6000  DELTA = YOBS(ICURPT) - ( YCALC + YBKG(ICURPT) )
      DO 6010 J=1,KMXVAR
      X = DERIV(J) / AMAX1( YOBS(ICURPT), 1.0 )
CZZZ  RJVX(J) = RJVX(J) + DELTA * X
      RJVX(J) = RJVX(J) + DPROD( DELTA, X )
      DO 6010 K=J,KMXVAR
CZZZ  RJAC(K,J) = RJAC(K,J) + X * DERIV(K)
      RJAC(K,J) = RJAC(K,J) + DPROD( X, DERIV(K) )
6010  CONTINUE
C-
      RETURN
      END
C---  CSOLVE - OBTAIN SOLUTIONS WITH POSSIBLE APPLICATION OF CONSTRAINTS
C-
      SUBROUTINE CSOLVE( RJVXO )
C-
      INCLUDE 'RIETCOM.FOR'
      LOGICAL LRESLV,LINDP
      DOUBLE PRECISION AC,BC,UC,RJACC,RJVXC, RJVXO, AKP2
      COMMON AC(MMATX,MMATX),BC(MMATX),UC(MMATX),M(MMATX),
     1       RJACC(MMATX,MMATX),RJVXC(MMATX)
      DIMENSION AKP2(MMATX),KBYPAS(MPHAS),LINDP(MMATX),RJVXO(MMATX)
C-
C-  THE KBYPAS FLAGS INDICATE PHASE PARAMETERS HAVE BEEN FIXED AND THE
C-  MATRIX RE-SOLVED.  CONDITION FORCED WHEN SCALE FACTOR TOO SMALL.
1000  DO 1 IPHASE=1,NPHASE
1     KBYPAS(IPHASE) = 0
C-
C-  MAKE THE NORMAL EQUATION MATRIX SYMMETRIC
2000  DO 2010 J1=1 ,KMXVAR
      DO 2010 J2=J1,KMXVAR
      RJAC(J1,J2) = RJAC(J2,J1)
2010  CONTINUE
C-
C-  MAKE SURE DIAGONAL COMPONENT IS NOT ZERO
2100  DO 2110 J1=1,KMXVAR
      IF( DABS(RJAC(J1,J1)) .GT. 1.0D-20 ) GO TO 2110
      DO 2120 J2=1,KMXVAR
      RJAC(J2,J1) = 0.0
      RJAC(J1,J2) = 0.0
2120  CONTINUE
      RJAC(J1,J1) = 1.0
      RJVX(J1)    = 0.0
      WRITE(IOTTO,2130) J1
2130  FORMAT(' -PARAMETER ',I3,' HAS BEEN REMOVED ON THIS CYCLE')
2110  CONTINUE
C-
C-  COPY THE NORMAL EQUATION MATRIX AND SOLUTION VECTORS
2200  DO 2210 J1=1,KMXVAR
      RJVXC(J1) = RJVX(J1)
      DO 2210 J2=1,KMXVAR
      RJACC(J2,J1) = RJAC(J2,J1)
2210  CONTINUE
C-
C-  SCALE THE MATRIX ELEMENTS
2300  DO 2310 J1=1,KMXVAR
2310  AKP2(J1) = DSQRT( RJAC(J1,J1) )
      DO 2320 J1=1,KMXVAR
      RJVX(J1) = RJVX(J1) / AKP2(J1)
      DO 2320 J2=1,KMXVAR
      RJAC(J2,J1) = RJAC(J2,J1) / ( AKP2(J1) * AKP2(J2) )
2320  CONTINUE
C-
C-  INVERT THE MATRIX AND OBTAIN ADJUSTMENTS FOR THE VARIABLES
2400  COND = DPINV( KMXVAR )
C-
C-  RESCALE THE INVERTED MATRIX ELEMENTS AND ADJUSTMENTS
2500  DO 2510 J1=1,KMXVAR
      RJVX(J1) = RJVX(J1) / AKP2(J1)
      DO 2510 J2=1,KMXVAR
      RJAC(J2,J1) = RJAC(J2,J1) / ( AKP2(J1) * AKP2(J2) )
2510  CONTINUE
C-
C-  COPY THE SOLUTION VECTOR IF NECESSARY
      DO 2520 J1=1,KMXVAR
2520  RJVXO(J1) = RJVX(J1)
C-
C--  CHECK FOR LIMITS ON PARAMETERS
C-
C-  FIRST SET OF CHECKS DETERMINES IF NEW SOLUTIONS NEED BE OBTAINED
3000  LRESLV = .FALSE.
      DO 3010 IPHASE=1,NPHASE
C-
C-  THE FOLLOWING PARAMETERS ARE *ALWAYS* CONSTRAINED
C-
C-  CHECK ON SCALE FACTORS
3100  IF(KBYPAS(IPHASE).EQ.1) GO TO 3200
      K = LPHSCA(IPHASE)
      IF(K.LT.1) GO TO 3200
      PARAM = PPHSCA(IPHASE) + RJVX(K) * APHSCA(IPHASE) * RELAX(3)
      IF(PARAM.GE.0.01) GO TO 3200
      IF(PPHSCA(IPHASE).EQ.0.01) THEN
        WRITE(IOTTO,3120) IPHASE
3120    FORMAT(' -CALCULATED SCALE FACTOR FOR PHASE ',I2,
     1  ' < 0.01: ALL PARAMETERS FOR THIS PHASE,',/,
     1  '  EXCLUDING THOSE NEEDED BY OTHER PHASES, FIXED THIS CYCLE')
        RJACC(K,K) = 0.0
        RJVXC(K)   = 0.0
       ELSE
        WRITE(IOTTO,3122) IPHASE
3122    FORMAT(' -CALCULATED SCALE FACTOR FOR PHASE ',I2,
     1  ' < 0.01: ALL PARAMETERS FOR THIS PHASE,',/,
     1  '  EXCLUDING THE SCALE FACTOR AND THOSE NEEDED BY OTHER PHASES',
     1  ', FIXED THIS CYCLE')
      ENDIF
      KBYPAS(IPHASE) = 1
      LRESLV = .TRUE.
C-  FORCE REMOVAL OF INDEPENDENT PHASE RELATED PARAMETERS
      DO 3130 ITPARC=2,19
3130  LINDP(ITPARC) = .TRUE.
      DO 3140 ITPH=1,NPHASE
      IF(ITPH.EQ.IPHASE) GO TO 3140
      DO 3150 ITPARC=2,26
      IF(ITPARC.EQ. 2) K = LPHOIT(IPHASE)
      IF(ITPARC.EQ. 3) K = LPHABS(IPHASE)
      IF(ITPARC.EQ. 4) K = LPHPSF(1,1,IPHASE)
      IF(ITPARC.EQ. 5) K = LPHPSF(2,1,IPHASE)
      IF(ITPARC.EQ. 6) K = LPHPSF(3,1,IPHASE)
      IF(ITPARC.EQ. 7) K = LPHPSF(1,2,IPHASE)
      IF(ITPARC.EQ. 8) K = LPHPSF(2,2,IPHASE)
      IF(ITPARC.EQ. 9) K = LPHPSF(3,2,IPHASE)
      IF(ITPARC.EQ.10) K = LPHASY(IPHASE)
      IF(ITPARC.EQ.11) K = LPHUVW(1,1,IPHASE)
      IF(ITPARC.EQ.12) K = LPHUVW(2,1,IPHASE)
      IF(ITPARC.EQ.13) K = LPHUVW(3,1,IPHASE)
      IF(ITPARC.EQ.14) K = LPHUVW(1,2,IPHASE)
      IF(ITPARC.EQ.15) K = LPHUVW(2,2,IPHASE)
      IF(ITPARC.EQ.16) K = LPHUVW(3,2,IPHASE)
      IF(ITPARC.EQ.17) K = LPHLAT(1,IPHASE)
      IF(ITPARC.EQ.18) K = LPHLAT(2,IPHASE)
      IF(ITPARC.EQ.19) K = LPHLAT(3,IPHASE)
      IF(ITPARC.EQ.20) K = LPHLAT(4,IPHASE)
      IF(ITPARC.EQ.21) K = LPHLAT(5,IPHASE)
      IF(ITPARC.EQ.22) K = LPHLAT(6,IPHASE)
      IF(ITPARC.EQ.23) K = LPOPAR(1,1,IPHASE)
      IF(ITPARC.EQ.24) K = LPOPAR(2,1,IPHASE)
      IF(ITPARC.EQ.25) K = LPOPAR(1,2,IPHASE)
      IF(ITPARC.EQ.26) K = LPOPAR(2,2,IPHASE)
      IF( K.EQ.LPHOIT(ITPH)       ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHABS(ITPH)       ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHPSF(1,1,ITPH)   ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHPSF(2,1,ITPH)   ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHPSF(3,1,ITPH)   ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHPSF(1,2,ITPH)   ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHPSF(2,2,ITPH)   ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHPSF(3,2,ITPH)   ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHASY(ITPH)       ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHUVW(1,1,ITPH)   ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHUVW(2,1,ITPH)   ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHUVW(3,1,ITPH)   ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHUVW(1,2,ITPH)   ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHUVW(2,2,ITPH)   ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHUVW(3,2,ITPH)   ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHLAT(1,ITPH)     ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHLAT(2,ITPH)     ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHLAT(3,ITPH)     ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHLAT(4,ITPH)     ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHLAT(5,ITPH)     ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPHLAT(6,ITPH)     ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPOPAR(1,1,ITPH)   ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPOPAR(2,1,ITPH)   ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPOPAR(1,2,ITPH)   ) LINDP(ITPARC) = .FALSE.
      IF( K.EQ.LPOPAR(2,2,ITPH)   ) LINDP(ITPARC) = .FALSE.
3150  CONTINUE
3140  CONTINUE
      DO 3160 ITPARC=2,26
      IF(.NOT.LINDP(ITPARC)) GO TO 3160
      IF(ITPARC.EQ. 2) K = LPHOIT(IPHASE)
      IF(ITPARC.EQ. 3) K = LPHABS(IPHASE)
      IF(ITPARC.EQ. 4) K = LPHPSF(1,1,IPHASE)
      IF(ITPARC.EQ. 5) K = LPHPSF(2,1,IPHASE)
      IF(ITPARC.EQ. 6) K = LPHPSF(3,1,IPHASE)
      IF(ITPARC.EQ. 7) K = LPHPSF(1,2,IPHASE)
      IF(ITPARC.EQ. 8) K = LPHPSF(2,2,IPHASE)
      IF(ITPARC.EQ. 9) K = LPHPSF(3,2,IPHASE)
      IF(ITPARC.EQ.10) K = LPHASY(IPHASE)
      IF(ITPARC.EQ.11) K = LPHUVW(1,1,IPHASE)
      IF(ITPARC.EQ.12) K = LPHUVW(2,1,IPHASE)
      IF(ITPARC.EQ.13) K = LPHUVW(3,1,IPHASE)
      IF(ITPARC.EQ.14) K = LPHUVW(1,2,IPHASE)
      IF(ITPARC.EQ.15) K = LPHUVW(2,2,IPHASE)
      IF(ITPARC.EQ.16) K = LPHUVW(3,2,IPHASE)
      IF(ITPARC.EQ.17) K = LPHLAT(1,IPHASE)
      IF(ITPARC.EQ.18) K = LPHLAT(2,IPHASE)
      IF(ITPARC.EQ.19) K = LPHLAT(3,IPHASE)
      IF(ITPARC.EQ.20) K = LPHLAT(4,IPHASE)
      IF(ITPARC.EQ.21) K = LPHLAT(5,IPHASE)
      IF(ITPARC.EQ.22) K = LPHLAT(6,IPHASE)
      IF(ITPARC.EQ.23) K = LPOPAR(1,1,IPHASE)
      IF(ITPARC.EQ.24) K = LPOPAR(2,1,IPHASE)
      IF(ITPARC.EQ.25) K = LPOPAR(1,2,IPHASE)
      IF(ITPARC.EQ.26) K = LPOPAR(2,2,IPHASE)
      RJACC(K,K) = 0.0
      RJVXC(K)   = 0.0
3160  CONTINUE
C-
C-  CONSTRAINTS ON CRYSTALLITE SIZE
3200  K = LPHUVW(1,1,IPHASE)
      IF( K.LT.1 .OR. KWSGON.NE.1 ) GO TO 3300
      PARAM = PPHUVW(1,1,IPHASE) + RJVX(K)*APHUVW(1,1,IPHASE)*RELAX(2)
      IF( PARAM.LT.10.0 .AND. PPHUVW(1,1,IPHASE).EQ.10.0 ) THEN
        WRITE(IOTTO,3210) IPHASE
3210    FORMAT(' -CALCULATED CRYSTALLITE SIZE FOR PHASE ',I2,
     1  ' < 1.0, FIXED ON THIS CYCLE')
        RJACC(K,K) = 0.0
        RJVXC(K)   = 0.0
        LRESLV = .TRUE.
      ENDIF
      IF( PARAM.GT.40000.0 .AND. PPHUVW(1,1,IPHASE).EQ.40000.0 ) THEN
        WRITE(IOTTO,3260) IPHASE
3260    FORMAT(' -CALCULATED CRYSTALLITE SIZE FOR PHASE ',I2,
     1  ' > 4000, FIXED ON THIS CYCLE')
        RJACC(K,K) = 0.0
        RJVXC(K)   = 0.0
        LRESLV = .TRUE.
      ENDIF
C-
C-  CONSTRAINTS ON CRYSTALLITE STRAIN
3300  K = LPHUVW(2,1,IPHASE)
      IF( K.LT.1 .OR. KWSGON.NE.1 ) GO TO 3400
      PARAM = PPHUVW(2,1,IPHASE) + RJVX(K)*APHUVW(2,1,IPHASE)*RELAX(2)
      IF( PARAM.LT.0.000001 .AND. PPHUVW(2,1,IPHASE).EQ.0.000001 ) THEN
        WRITE(IOTTO,3310) IPHASE
3310    FORMAT(' -CALCULATED CRYSTALLITE STRAIN FOR PHASE ',I2,
     1  ' < 0.000001, FIXED ON THIS CYCLE')
        RJACC(K,K) = 0.0
        RJVXC(K)   = 0.0
        LRESLV = .TRUE.
      ENDIF
      IF( PARAM.GT.0.01 .AND. PPHUVW(2,1,IPHASE).EQ.0.01 ) THEN
        WRITE(IOTTO,3360) IPHASE
3360    FORMAT(' -CALCULATED CRYSTALLITE STRAIN FOR PHASE ',I2,
     1  ' > 0.01, FIXED ON THIS CYCLE')
        RJACC(K,K) = 0.0
        RJVXC(K)   = 0.0
        LRESLV = .TRUE.
      ENDIF
C-
C-  THE FOLLOWING SET OF PARAMATERS ARE OPTIONALLY CONSTRAINED
C-
C-  ATOM RELATED PARAMETERS
3400  IF(KCONCW.NE.1) GO TO 3500
      NATOM = NATM(1,IPHASE)
      IOF = NATM(2,IPHASE) - 1
      DO 3410 I=1,NATOM
      IPIOF = I + IOF
C-
C-  INDIVIDUAL ISOTROPIC TEMPERATURE FACTORS
      K = LATOM(4,IPIOF)
      IF(K.LT.1) GO TO 3420
      PARAM = PATOM(4,IPIOF) + RJVX(K) * AATOM(4,IPIOF) * RELAX(1)
      IF( PARAM.LT.0.0001 .AND. PATOM(4,IPIOF).EQ.0.0001 ) THEN
        WRITE(IOTTO,3415) QATLBL(IPIOF)
3415    FORMAT(' -CON:MIN- ISOTROPIC THERMAL PARAMETER FOR ATOM ',A8,
     1  ' < 0.0001, FIXED ON THIS CYCLE')
        RJACC(K,K) = 0.0
        RJVXC(K)   = 0.0
        LRESLV = .TRUE.
      ENDIF
C-
C-  SITE OCCUPANCY FACTORS
3420  K = LATOM(5,IPIOF)
      IF(K.LT.1) GO TO 3430
      PARAM = PATOM(5,IPIOF) + RJVX(K) * AATOM(5,IPIOF) * RELAX(1)
      IF( PARAM.LT.0.0001 .AND. PATOM(5,IPIOF).EQ.0.0001 ) THEN
        WRITE(IOTTO,3425) QATLBL(IPIOF)
3425    FORMAT(' -CON:MIN- OCCUPANCY FACTOR FOR ATOM ',A8,
     1  ' < 0.0001, FIXED ON THIS CYCLE')
        RJACC(K,K) = 0.0
        RJVXC(K)   = 0.0
        LRESLV = .TRUE.
      ENDIF
C-
C-  DIAGONAL ELEMENTS OF THE ANISOTROPIC TEMPERATURE FACTORS
3430  DO 3450 J=6,8
      K = LATOM(J,IPIOF)
      IF(K.LT.1) GO TO 3450
      PARAM = PATOM(J,IPIOF) + RJVX(K) * AATOM(J,IPIOF) * RELAX(2)
      IF( PARAM.LT.1.0E-6 .AND. PATOM(J,IPIOF).EQ.1.0E-6 ) THEN
        WRITE(IOTTO,3435) J-5,J-5,QATLBL(IPIOF)
3435    FORMAT(' -CON:MIN- B',2I1,' FOR ATOM ',A8,
     1  ' < 1.0E-6, FIXED ON THIS CYCLE')
        RJACC(K,K) = 0.0
        RJVXC(K)   = 0.0
        LRESLV = .TRUE.
      ENDIF
3450  CONTINUE
C-
C-  NEXT ATOM
3410  CONTINUE
C-
C-  OVERALL ISOTROPIC TEMPERATURE FACTOR
      K = LPHOIT(IPHASE)
      IF(K.LT.1) GO TO 3470
      PARAM = PPHOIT(IPHASE) + RJVX(K) * APHOIT(IPHASE) * RELAX(3)
      IF( PARAM.LT.0.0001 .AND. PPHOIT(IPHASE).EQ.0.0001 ) THEN
        WRITE(IOTTO,3460) IPHASE
3460    FORMAT(' -CON:MIN- OVERALL ISOTROPIC TEMP FACTOR FOR PHASE ',I2,
     1  ' < 0.0001, FIXED ON THIS CYCLE')
        RJACC(K,K) = 0.0
        RJVXC(K)   = 0.0
        LRESLV = .TRUE.
      ENDIF
C-
C-  ETA FOR PSEUDO-VOIGT
3470  IF(NPSF(1,IPHASE).NE.2) GO TO 3500
      K = LPHPSF(1,1,IPHASE)
      IF(K.LT.1) GO TO 3500
      PARAM = PPHPSF(1,1,IPHASE) + RJVX(K)*APHPSF(1,1,IPHASE)*RELAX(3)
      IF( PARAM.LT.0.0001 .AND. PPHPSF(1,1,IPHASE).EQ.0.0001 ) THEN
        WRITE(IOTTO,3475) IPHASE
3475    FORMAT(' -CON:MIN-  ETA FOR PHASE ',I2,
     1  ' < 0.0001, FIXED ON THIS CYCLE')
        RJACC(K,K) = 0.0
        RJVXC(K)   = 0.0
        LRESLV = .TRUE.
      ENDIF
      IF( PARAM.GT.1.0 .AND. PPHPSF(1,1,IPHASE).EQ.1.0 ) THEN
        WRITE(IOTTO,3477) IPHASE
3477    FORMAT(' -CON:MAX-  ETA FOR PHASE ',I2,
     1  ' > 1.0, FIXED ON THIS CYCLE')
        RJACC(K,K) = 0.0
        RJVXC(K)   = 0.0
        LRESLV = .TRUE.
      ENDIF
C-
C-  NEXT SET OF CONSTRAINTS
3500  CONTINUE
C-
C-  NEXT PHASE
3010  CONTINUE
C-
C-  COPY NEW MATRIX VALUES AND RESOLVE IF NECESSARY
C-
4000  IF(.NOT.LRESLV) GO TO 5000
      DO 4010 J1=1,KMXVAR
      RJVX(J1) = RJVXC(J1)
      DO 4010 J2=1,KMXVAR
      RJAC(J2,J1) = RJACC(J2,J1)
4010  CONTINUE
      WRITE(IOTTO,4020)
4020  FORMAT(' -SOLVING MATRIX WITH NEW CONSTRAINTS')
      GO TO 2100
C-
C-  SECOND SET OF CHECKS DETERMINES IF CONSTRAINTS NEED TO BE APPLIED
C-
C-  COPY ORIGINAL SOLUTION VECTORS
5000  DO 5002 J1=1,KMXVAR
5002  RJVXC(J1) = RJVX(J1)
C-
C-  REPEAT FOR EACH PHASE
      DO 5010 IPHASE=1,NPHASE
C-
C-  CHECK ON SCALE FACTORS
5100  K = LPHSCA(IPHASE)
      IF(K.LT.1) GO TO 5200
      PARAM = PPHSCA(IPHASE) + RJVX(K) * APHSCA(IPHASE) * RELAX(3)
      IF(PARAM.LT.0.01) THEN
        WRITE(IOTTO,5110) IPHASE
5110    FORMAT(' -CALCULATED SCALE FACTOR FOR PHASE ',I2,
     1  ' < 0.01, SET TO 0.01')
        PPHSCA(IPHASE) = 0.01
        RJVXC(K)   = 0.0
      ENDIF
C-
C-  CONSTRAINTS ON CRYSTALLITE SIZE
5200  K = LPHUVW(1,1,IPHASE)
      IF( K.LT.1 .OR. KWSGON.NE.1 ) GO TO 5300
      PARAM = PPHUVW(1,1,IPHASE) + RJVX(K)*APHUVW(1,1,IPHASE)*RELAX(2)
      IF(PARAM.LT.10.0) THEN
        WRITE(IOTTO,5210) IPHASE
5210    FORMAT(' -CALCULATED CRYSTALLITE SIZE FOR PHASE ',I2,
     1  ' < 1.0, SET TO 1.0')
        PPHUVW(1,1,IPHASE) = 10.0
        RJVXC(K)   = 0.0
      ENDIF
      IF(PARAM.GT.40000.0) THEN
        WRITE(IOTTO,5260) IPHASE
5260    FORMAT(' -CALCULATED CRYSTALLITE SIZE FOR PHASE ',I2,
     1  ' > 4000, SET TO 4000')
        PPHUVW(1,1,IPHASE) = 40000.0
        RJVXC(K)   = 0.0
      ENDIF
C-
C-  CONSTRAINTS ON CRYSTALLITE STRAIN
5300  K = LPHUVW(2,1,IPHASE)
      IF( K.LT.1 .OR. KWSGON.NE.1 ) GO TO 5400
      PARAM = PPHUVW(2,1,IPHASE) + RJVX(K)*APHUVW(2,1,IPHASE)*RELAX(2)
      IF(PARAM.LT.0.000001) THEN
        WRITE(IOTTO,5310) IPHASE
5310    FORMAT(' -CALCULATED CRYSTALLITE STRAIN FOR PHASE ',I2,
     1  ' < 0.000001, SET TO 0.00001')
        PPHUVW(2,1,IPHASE) = 0.000001
        RJVXC(K)   = 0.0
      ENDIF
      IF(PARAM.GT.0.01) THEN
        WRITE(IOTTO,5360) IPHASE
5360    FORMAT(' -CALCULATED CRYSTALLITE STRAIN FOR PHASE ',I2,
     1  ' > 0.01, SET TO 0.01')
        PPHUVW(2,1,IPHASE) = 0.01
        RJVXC(K)   = 0.0
      ENDIF
C-
C-  THE FOLLOWING SET OF PARAMATERS ARE OPTIONALLY CONSTRAINED
C-
C-  ISOTROPIC THERMAL, OCCUPANCY AND DIAGONAL ELEMENTS OF ANISOTROPIC
5400  IF(KCONCW.NE.1) GO TO 5500
      NATOM = NATM(1,IPHASE)
      IOF = NATM(2,IPHASE) - 1
      DO 5410 I=1,NATOM
      IPIOF = I + IOF
C-
C-  INDIVIDUAL ISOTROPIC TEMPERATURE FACTORS
      K = LATOM(4,IPIOF)
      IF(K.LT.1) GO TO 5420
      PARAM = PATOM(4,IPIOF) + RJVX(K) * AATOM(4,IPIOF) * RELAX(1)
      IF(PARAM.LT.0.0001) THEN
        WRITE(IOTTO,5415) QATLBL(IPIOF)
5415    FORMAT(' -CON:MIN- ISOTROPIC THERMAL PARAMETER FOR ATOM ',A8,
     1  ' < 0.0001, SET TO 0.0001')
        PATOM(4,IPIOF) = 0.0001
        RJVXC(K)    = 0.0
      ENDIF
C-
C-  SITE OCCUPANCY FACTORS
5420  K = LATOM(5,IPIOF)
      IF(K.LT.1) GO TO 5430
      PARAM = PATOM(5,IPIOF) + RJVX(K) * AATOM(5,IPIOF) * RELAX(1)
      IF(PARAM.LT.0.0001) THEN
        WRITE(IOTTO,5425) QATLBL(IPIOF)
5425    FORMAT(' -CON:MIN- OCCUPANCY FACTOR FOR ATOM ',A8,
     1  ' < 0.0001, SET TO 0.0001')
        PATOM(5,IPIOF) = 0.0001
        RJVXC(K)    = 0.0
      ENDIF
C-
C-  DIAGONAL ELEMENTS OF ANISOTROPIC TEMPERATURE FACTORS
5430  DO 5450 J=6,8
      K = LATOM(J,IPIOF)
      IF(K.LT.1) GO TO 5450
      PARAM = PATOM(J,IPIOF) + RJVX(K) * AATOM(J,IPIOF) * RELAX(2)
      IF(PARAM.LT.1.0E-6) THEN
        WRITE(IOTTO,5435) J-5,J-5,QATLBL(IPIOF)
5435    FORMAT(' -CON:MIN- B',2I1,' FOR ATOM ',A8,
     1  ' < 1.0E-6, SET TO 1.0E-6')
        PATOM(J,IPIOF) = 1.0E-6
        RJVXC(K)    = 0.0
      ENDIF
5450  CONTINUE
C-
C-  NEXT ATOM
5410  CONTINUE
C-
C-  OVERALL ISOTROPIC TEMPERATURE FACTOR
      K = LPHOIT(IPHASE)
      IF(K.LT.1) GO TO 5470
      PARAM = PPHOIT(IPHASE) + RJVX(K) * APHOIT(IPHASE) * RELAX(3)
      IF(PARAM.LT.0.0001) THEN
        WRITE(IOTTO,5460)
5460    FORMAT(' -CON:MIN- OVERALL ISOTROPIC TEMP FACTOR FOR PHASE ',I2,
     1  ' < 0.0001, SET TO 0.0001')
        PPHOIT(IPHASE) = 0.0001
        RJVXC(K)   = 0.0
      ENDIF
C-
C-  ETA FOR PSEUDO VOIGT
5470  IF(NPSF(1,IPHASE).NE.2) GO TO 5500
      K = LPHPSF(1,1,IPHASE)
      IF(K.LT.1) GO TO 5500
      PARAM = PPHPSF(1,1,IPHASE) + RJVX(K)*APHPSF(1,1,IPHASE)*RELAX(3)
      IF(PARAM.LT.0.0001) THEN
        WRITE(IOTTO,5475) IPHASE
5475    FORMAT(' -CON:MIN-  ETA FOR PHASE ',I2,
     1  ' < 0.0001, SET TO 0.0001')
        PPHPSF(1,1,IPHASE) = 0.0001
        RJVXC(K)    = 0.0
      ENDIF
      IF( PARAM.GT.1.0 .AND. PPHPSF(1,1,IPHASE).EQ.1.0 ) THEN
        WRITE(IOTTO,5477) IPHASE
5477    FORMAT(' -CON:MAX-  ETA FOR PHASE ',I2,
     1  ' > 1.0, SET TO 1.0')
        PPHPSF(1,1,IPHASE) = 1.0
        RJVXC(K)    = 0.0
      ENDIF
C-
C-  NEXT SET OF CONSTRAINTS
5500  CONTINUE
C-
C-  NEXT PHASE
5010  CONTINUE
C-
C-  COPY NEW SOLUTION VECTOR
5900  DO 5910 J1=1,KMXVAR
5910  RJVX(J1) = RJVXC(J1)
C-
C-  CALCULATE RESIDUAL ERRORS
6000  CALL CHISQ
C-
C-  SCALE INVERTED MATRIX ELEMENTS  ( CHIS2 = SUM( YDEL(I)**2 / YOBS(I) ) )
      OOM = CHIS2 / REAL( NMATPT-KMXVAR )
      DO 6010 J1=1,KMXVAR
      DO 6010 J2=1,KMXVAR
6010  RJAC(J2,J1) = RJAC(J2,J1) * OOM
C *
C *  TASK COMPLETE
9000  RETURN
      END
C--  DPINV
C-
      FUNCTION DPINV( N )
C-
      INCLUDE 'RIETCOM.FOR'
      DOUBLE PRECISION AC,BC,UC,RJACC,RJVXC, S,T
      COMMON AC(MMATX,MMATX),BC(MMATX),UC(MMATX),M(MMATX),
     1       RJACC(MMATX,MMATX),RJVXC(MMATX)
C-
50    DPINV = 0.0
      DO 1 I=1,N
      BC(I) = RJVX(I)
      DO 1 J=1,N
1     AC(J,I) = RJAC(J,I)
C-
      DO 2 I=1,N
      UC(I) = DABS( AC(1,I) )
      C = UC(I)
      DO 3 J=2,N
      UC(I) = DMAX1( UC(I), DABS(AC(J,I)) )
3     C = C + DABS( AC(J,I) )
      DPINV = AMAX1( DPINV, C )
      M(I) = I
      BC(I) = BC(I) / UC(I)
      DO 2 J=1,N
2     AC(J,I) = AC(J,I) / UC(I)
C-
      DO 10 I=1,N
      IF(I.EQ.N) GO TO 15
      J = I
      I1 = I + 1
      MI = M(I)
      S = DABS( AC(I,MI) )
      DO 4 K=I1,N
      MI = M(K)
      IF(DABS(AC(I,MI)).LE.S) GO TO 4
      S = DABS(AC(I,MI))
      J = K
4     CONTINUE
      MK1 = M(J)
      M(J) = M(I)
      M(I) = MK1
15    MI1 = M(I)
      AC(I,MI1) = 1.0 / AC(I,MI1)
      BC(MI1) = BC(MI1) * AC(I,MI1)
      DO 20 J=1,N
      IF(I.EQ.J) GO TO 20
      AC(J,MI1) = AC(J,MI1) * AC(I,MI1)
20    CONTINUE
      DO 30 J=1,N
      IF(J.EQ.I) GO TO 30
      MJ = M(J)
      T = AC(I,MJ)
      MI1 = M(I)
      BC(MJ) = BC(MJ) - T * BC(MI1)
      AC(I,MJ) = -T * AC(I,MI1)
      DO 40 K=1,N
      IF(K.EQ.I) GO TO 40
      AC(K,MJ) = AC(K,MJ) - T * AC(K,MI1)
40    CONTINUE
30    CONTINUE
10    CONTINUE
C-
      DO 93 I=1,N
      MI1 = M(I)
      RJVX(I) = BC(MI1)
      DO 94 J=1,N
      MJ = M(J)
94    RJAC(MJ,I) = AC(J,MI1) / UC(MJ)
93    CONTINUE
C-
      C = 0.0
      DO 91 I=1,N
      D = DABS(RJAC(1,I))
      DO 92 J=2,N
92    D = D + DABS(RJAC(J,I))
91    C = AMAX1( C, D )
      DPINV = DPINV * C
C-
99    RETURN
      END
C--  CHISQ
C-
      SUBROUTINE CHISQ
C-
      INCLUDE 'RIETCOM.FOR'
C-
      CHIS1 = 0.0
      CHIS2 = 0.0
      CHIS3 = 0.0
      CHID1 = 0.0
      TMP   = 0.0
C-
C-  VARIANCE OF YOBS(I) FOR YOBS(I) < 1 SET EQUAL TO 1
      DO 10 I=1,KPPTS
      IF( KREFRN(I).EQ.65536 ) GO TO 10
      DELSQR = ( YOBS(I) - ( YCLC(I) + YBKG(I) ) )**2
      CHIS1 = CHIS1 + DELSQR
      CHIS2 = CHIS2 + DELSQR / AMAX1( YOBS(I), 1.0 )
      CHID1 = CHID1 + YOBS(I)
      TMP   = TMP   + YOBS(I)**2
      CHIS3 = CHIS3 + ( YCLC(I) + YBKG(I) )
10    CONTINUE
C-
C-  RESR==RP AND RESRWP==RWP
      RESR   = 100.0 * SQRT( CHIS1 / TMP   )
      RESRWP = 100.0 * SQRT( CHIS2 / CHID1 )
C-
      RETURN
      END
C-- OUTPTR
C-
      SUBROUTINE OUTPTR
C-
      INCLUDE 'RIETCOM.FOR'
      LOGICAL LANISO,LXRAY,LEXIST
      DIMENSION SY(20),SZ(20),DCSM(6,6),DCV(6)
C-
      WRITE(IOTTO,1) KCURND,KMXRND,KCUCYC,KMXCYC,KMXVAR
1     FORMAT('1',120('+'),//,
     1' Round ',I2,'/',I2,'   Cycle ',I2,'/',I2,'   Variables ',I2)
C-
C-  WRITE ROUND INFORMATION TO THE STATUS FILE
      IF(IOTTO.NE.6) THEN
CVAX
       INQUIRE(FILE=QSTAFN,EXIST=LEXIST)
       IF(LEXIST) THEN
         OPEN(UNIT=IOALT,FILE=QSTAFN,STATUS='OLD')
         CLOSE(UNIT=IOALT)
       ENDIF
       OPEN(UNIT=IOALT,FILE=QSTAFN,STATUS='NEW',CARRIAGECONTROL='LIST',
     1      ERR=1000)
CVAX
CIBMPC
c        OPEN(UNIT=IOALT,FILE='CON',STATUS='UNKNOWN',ERR=1000)
CIBMPC
        WRITE(IOALT,111) KCURND,KMXRND,KCUCYC,KMXCYC,KMXVAR,RESR,RESRWP
111     FORMAT(
     1  ' Round ',I2,'/',I2,'   Cycle ',I2,'/',I2,'   Variables ',I2,
     1  '   R ',G12.6,'  Rwp ',G12.6)
        CLOSE(UNIT=IOALT)
      ENDIF
C-
C-  X-RAY CALCULATION FLAG
1000  LXRAY = JOBXN.EQ.1 .OR. JOBXN.EQ.3
C-
C-  REPEAT FOR EACH PHASE
C-
      DO 1010 IPHASE=1,NPHASE
      IOF = NATM(2,IPHASE) - 1
      WRITE(IOTTO,1020) IPHASE,QPHSNM(IPHASE)
1020  FORMAT(/,' Phase ',I2,': ',A32)
      NATOM = NATM(1,IPHASE)
C-
C-----ATOM PARAMETERS---------------------------------------------------
C-
      WRITE(IOTTO,1030)
1030  FORMAT(/,' *  ATOM PARAMETERS, SHIFTS, AND STANDARD DEVIATIONS')
C-
C-  POSITION, ISOTROPIC THERMAL, AND OCCUPANCY FACTORS
C-
      LANISO = .FALSE.
      WRITE(IOTTO,1040)
1040  FORMAT(/,
     1  ' Atom',9X,'X',6X,'dX',5X,'sX',7X,'Y',6X,'dY',5X,'sY',
     1  7X,'Z',6X,'dZ',5X,'sZ',7X,'B',6X,'dB',5X,'sB',
     1  7X,'N',6X,'dN',5X,'sN')
      IF(.NOT.LXRAY) WRITE(IOTTO,1042)
1042  FORMAT(
     1 13X,'KX',5X,'dKX',4X,'sKX',6X,'KY',5X,'dKY',4X,'sKY',
     1  6X,'KZ',5X,'dKZ',4X,'sKZ')
C-
      DO 1050 I=1,NATOM
      IPIOF = I + IOF
C-
C-  NUCLEAR TERMS
      DO 1060 J=1,5
      KM = LATOM(J,IPIOF)
      IF(KM.GT.0) THEN
        SY(J) = RJVX(KM) * AATOM(J,IPIOF) * RELAX(1)
        SZ(J) = DSQRT( DABS(RJAC(KM,KM)) ) * ABS(AATOM(J,IPIOF))
        PATOM(J,IPIOF) = PATOM(J,IPIOF) + SY(J)
       ELSE
        SY(J) = 0.0
        SZ(J) = 0.0
      ENDIF
1060  CONTINUE
      WRITE(IOTTO,1070) QATLBL(IPIOF),
     1  (PATOM(J,IPIOF)-SY(J),SY(J),SZ(J),J=1,5)
1070  FORMAT(1X,A8,2X,5(3F7.4,2X))
C-
C-  CHECK FOR ANISOTROPIC TEMPERATURE FACTOR USAGE
      IF(KANISU(IPIOF).EQ.1) LANISO = .TRUE.
C-
C-  MAGNETIC TERMS
      IF( LXRAY .OR. KMAGSI(IPIOF).EQ.0 ) GO TO 1050
      DO 1062 J=1,3
      KM = LCMAG(J,IPIOF)
      IF(KM.GT.0) THEN
        SY(J) = RJVX(KM) * CMAGVE(J,IPIOF) * RELAX(1)
        SZ(J) = DSQRT( DABS(RJAC(KM,KM)) ) * ABS(CMAGVE(J,IPIOF))
        PMAGVE(J,IPIOF) = PMAGVE(J,IPIOF) + SY(J)
       ELSE
        SY(J) = 0.0
        SZ(J) = 0.0
      ENDIF
1062  CONTINUE
      WRITE(IOTTO,1072) (PMAGVE(J,IPIOF)-SY(J),SY(J),SZ(J),J=1,3)
1072  FORMAT(10X,3(3F7.3,2X))
C-
C-  NEXT ATOM
1050  CONTINUE
C-
C-  ANISOTROPIC THERMAL PARAMETERS
C-
1100  IF(.NOT.LANISO) GO TO 2000
      WRITE(IOTTO,1110)
1110  FORMAT(/,' Atom',9X,'B11',6X,'dB11',6X,'sB11',7X,'B22',6X,'dB22',
     1 6X,'sB22',7X,'B33',6X,'dB33',6X,'sB33',/,
     1 14X,'B12',6X,'dB12',6X,'sB12',7X,'B13',6X,'dB13',6X,'sB13',7X,
     1 'B23',6X,'dB23',6X,'sB23')
      DO  1120 I=1,NATOM
      IPIOF = I + IOF
      DO  1130 J=6,11
      KM = LATOM(J,IPIOF)
      IF(KM.GT.0) THEN
        SZ(J) = DSQRT( DABS(RJAC(KM,KM)) ) * ABS(AATOM(J,IPIOF))
        SY(J) = RJVX(KM) * AATOM(J,IPIOF) * RELAX(2)
        PATOM(J,IPIOF) = PATOM(J,IPIOF) + SY(J)
       ELSE
        SY(J) = 0.0
        SZ(J) = 0.0
      ENDIF
1130  CONTINUE
      WRITE(IOTTO,1140) QATLBL(IPIOF),
     1  (PATOM(J,IPIOF)-SY(J),SY(J),SZ(J),J=6,11)
1140  FORMAT(1X,A8,9F10.6,/,9X,9F10.6)
1120  CONTINUE
C-
C-----PHASE RELATED PARAMETERS------------------------------------------
C-
2000  WRITE(IOTTO,2002)
2002  FORMAT(/,
     1' *  PHASE RELATED PARAMETERS, SHIFTS, AND STANDARD DEVIATIONS')
C-
C-  SCALE FACTOR
      SZ(1) = 0.0
      SY(1) = 0.0
      KM = LPHSCA(IPHASE)
      IF(KM.GT.0) THEN
        SZ(1) = DSQRT( DABS(RJAC(KM,KM)) ) * ABS( APHSCA(IPHASE) )
        SY(1) = RJVX(KM) * APHSCA(IPHASE) * RELAX(3)
        PPHSCA(IPHASE) = PPHSCA(IPHASE) + SY(1)
      ENDIF
      WRITE(IOTTO,2030) PPHSCA(IPHASE)-SY(1),SY(1),SZ(1)
2030  FORMAT(/,' Overall scale factor =',6X,3(F11.4))
C-
C-  OVERALL ISO TEMP FACTOR
      SZ(1) = 0.0
      SY(1) = 0.0
      KM = LPHOIT(IPHASE)
      IF(KM.GT.0) THEN
        SZ(1) = DSQRT( DABS(RJAC(KM,KM)) ) * ABS( APHOIT(IPHASE) )
        SY(1) = RJVX(KM) * APHOIT(IPHASE) * RELAX(3)
        PPHOIT(IPHASE) = PPHOIT(IPHASE) + SY(1)
      ENDIF
      WRITE(IOTTO,2040) PPHOIT(IPHASE)-SY(1),SY(1),SZ(1)
2040  FORMAT(' Overall temperature factor =',3(F11.6))
C-
C-  ABSORPTION CORRECTION
      SZ(1) = 0.0
      SY(1) = 0.0
      KM = LPHABS(IPHASE)
      IF(KM.GT.0) THEN
        SZ(1) = DSQRT( DABS(RJAC(KM,KM)) ) * ABS( APHABS(IPHASE) )
        SY(1) = RJVX(KM) * APHABS(IPHASE) * RELAX(3)
        PPHABS(IPHASE) = PPHABS(IPHASE) + SY(1)
      ENDIF
      WRITE(IOTTO,2042) PPHABS(IPHASE)-SY(1),SY(1),SZ(1)
2042  FORMAT(' Absorption factor (ut)     =',3(F11.6),/)
C-
C-  PROFILE-SHAPE-FUNCTION PARAMETERS
      IF( NPSF(1,IPHASE).LT.2) GO TO 2080
      DO 2050 I=1,3
      SZ(I) = 0.0
      SY(I) = 0.0
      KM = LPHPSF(I,1,IPHASE)
      IF(KM.GT.0) THEN
        SZ(I) = DSQRT( DABS(RJAC(KM,KM)) ) * ABS( APHPSF(I,1,IPHASE) )
        SY(I) = RJVX(KM) * APHPSF(I,1,IPHASE) * RELAX(3)
        PPHPSF(I,1,IPHASE) = PPHPSF(I,1,IPHASE) + SY(I)
      ENDIF
      SZ(I+3) = 0.0
      SY(I+3) = 0.0
      KM = LPHPSF(I,2,IPHASE)
      IF(KM.GT.0) THEN
        SZ(I+3) = DSQRT( DABS(RJAC(KM,KM)) ) * ABS( APHPSF(I,2,IPHASE) )
        SY(I+3) = RJVX(KM) * APHPSF(I,2,IPHASE) * RELAX(3)
        PPHPSF(I,2,IPHASE) = PPHPSF(I,2,IPHASE) + SY(I+3)
      ENDIF
2050  CONTINUE
      IF(NPSF(1,IPHASE).EQ.2) THEN
        WRITE(IOTTO,3046) 'Pseudo-Voigt',
     1   (PPHPSF(J,1,IPHASE)-SY(J),SY(J),SZ(J),J=1,3)
       ELSE
        WRITE(IOTTO,3046) 'Pearson VII ',
     1   (PPHPSF(J,1,IPHASE)-SY(J),SY(J),SZ(J),J=1,3)
      ENDIF
3046  FORMAT(/,1X,A12,'           m0 = ',3(F11.6),/,
     1     5X,'  m1 * 2theta      m1 = ',3(F11.6),/,
     1     5X,'  m2 * 2theta**2   m2 = ',3(F11.6))
      IF( NPSF(2,IPHASE).EQ.2 .OR. NPSF(2,IPHASE).EQ.3 ) THEN
        WRITE(IOTTO,3048)
     1   (PPHPSF(J,2,IPHASE)-SY(J+3),SY(J+3),SZ(J+3),J=1,3)
3048    FORMAT(2X,' High angle side      m0 = ',3(F11.6),/,
     1            5X,'  m1 * 2theta      m1 = ',3(F11.6),/,
     1            5X,'  m2 * 2theta**2   m2 = ',3(F11.6))
      ENDIF
C-
C-  ASYMMETRY PARAMETER
2080  SZ(1) = 0.0
      SY(1) = 0.0
      KM = LPHASY(IPHASE)
      IF(KM.GT.0) THEN
        SZ(1) = DSQRT( DABS(RJAC(KM,KM)) ) * ABS( APHASY(IPHASE) )
        SY(1) = RJVX(KM) * APHASY(IPHASE) * RELAX(3)
        PPHASY(IPHASE) = PPHASY(IPHASE) + SY(1)
      ENDIF
      WRITE(IOTTO,2095) PPHASY(IPHASE)-SY(1),SY(1),SZ(1)
2095  FORMAT(/,' Asymmetry parameter =',7X,3(F11.6))
C-
C-  PROFILE BROADENING PARAMETERS
      DO 2060 I=1,3
      SZ(I) = 0.0
      SY(I) = 0.0
      KM = LPHUVW(I,1,IPHASE)
      IF(KM.GT.0) THEN
        SZ(I) = DSQRT( DABS(RJAC(KM,KM)) ) * ABS( APHUVW(I,1,IPHASE) )
        SY(I) = RJVX(KM) * APHUVW(I,1,IPHASE) * RELAX(3)
        PPHUVW(I,1,IPHASE) = PPHUVW(I,1,IPHASE) + SY(I)
      ENDIF
      SZ(I+3) = 0.0
      SY(I+3) = 0.0
      KM = LPHUVW(I,2,IPHASE)
      IF(KM.GT.0) THEN
        SZ(I+3) = DSQRT( DABS(RJAC(KM,KM)) ) * ABS( APHUVW(I,2,IPHASE) )
        SY(I+3) = RJVX(KM) * APHUVW(I,2,IPHASE) * RELAX(3)
        PPHUVW(I,2,IPHASE) = PPHUVW(I,2,IPHASE) + SY(I+3)
      ENDIF
2060  CONTINUE
      IF(KWSGON.EQ.1) THEN
        WSGTM1 = ( PPHUVW(1,1,IPHASE)-SY(1) ) * 0.1
        WSGTM2 = SY(1) * 0.1
        WSGTM3 = SZ(1) * 0.1
        WRITE(IOTTO,2062) WSGTM1,WSGTM2,WSGTM3
2062    FORMAT(/,' Crystallite size (nm) =',5X,3(2X,F9.2))
        WSGTM1 = ( PPHUVW(2,1,IPHASE)-SY(2) ) * 1000.0
        WSGTM2 = SY(2) * 1000.0
        WSGTM3 = SZ(2) * 1000.0
        WRITE(IOTTO,2064) WSGTM1,WSGTM2,WSGTM3
2064    FORMAT(' Crystallite strain x1000 =',2X,3(2X,F9.6))
       ELSE
        IF( NPSF(2,IPHASE).EQ.1 .OR. NPSF(2,IPHASE).EQ.3 ) THEN
          WRITE(IOTTO,2066) 'Low angle ',
     1     (PPHUVW(I,1,IPHASE)-SY(I),SY(I),SZ(I),I=1,3)
          WRITE(IOTTO,2066) 'High angle',
     1     (PPHUVW(I,2,IPHASE)-SY(I+3),SY(I+3),SZ(I+3),I=1,3)
2066      FORMAT(/,' FWHM ',A10,':  U dU sU = ',3(F11.6),/,
     1                         19X,'V dV sV = ',3(F11.6),/,
     1                         19X,'W dW sW = ',3(F11.6)   )
         ELSE
          WRITE(IOTTO,2066) 'parameters',
     1    (PPHUVW(I,1,IPHASE)-SY(I),SY(I),SZ(I),I=1,3)
        ENDIF
      ENDIF
C-
C-  LATTICE PARAMETERS
      DO 2010 I=1,6
      SZ(I) = 0.0
      SY(I) = 0.0
      KM = LPHLAT(I,IPHASE)
      IF(KM.GT.0) THEN
        SZ(I) = DSQRT( DABS(RJAC(KM,KM)) ) * ABS( APHLAT(I,IPHASE) )
        SY(I) = RJVX(KM) * APHLAT(I,IPHASE) * RELAX(3)
        PPHLAT(I,IPHASE) = PPHLAT(I,IPHASE) + SY(I)
      ENDIF
2010  CONTINUE
      CALL DIRECT( DCSM, DCV )
      DO 2020 I=1,6
      SY(I) = DCV(I) - SAVE(I,IPHASE)
      SAVE(I,IPHASE) = DCV(I)
2020  CONTINUE
      WRITE(IOTTO,2082) (DCV(I)-SY(I),I=1,6),
     1  (SY(I),I=1,6),(DCSM(I,I),I=1,6)
2082  FORMAT(/,8X,'A',11X,'B',11X,'C',10X,'Alpha',7X,'Beta',8X,'Gamma',
     1  3(/,1X,3(1X,F11.6),3(1X,F11.4)))
C-
C-  PREFERRED ORIENTATION PARAMETERS
      DO 2090 I=1,2
      DO 2090 J=1,2
      IP = (I-1)*2 + J
      SZ(IP) = 0.0
      SY(IP) = 0.0
      KM = LPOPAR(J,I,IPHASE)
      IF(KM.GT.0) THEN
        SZ(IP) = DSQRT( DABS(RJAC(KM,KM)) ) * ABS( APOPAR(J,I,IPHASE) )
        SY(IP) = RJVX(KM) * APOPAR(J,I,IPHASE) * RELAX(3)
        PPOPAR(J,I,IPHASE) = PPOPAR(J,I,IPHASE) + SY(IP)
      ENDIF
2090  CONTINUE
      IF(KPOCTY(1,IPHASE).GT.0) THEN
        WRITE(IOTTO,2092) ' ',
     1    (PPOPAR(J,1,IPHASE)-SY(J),SY(J),SZ(J),J=1,2)
2092    FORMAT(/,
     1  ' Preferred orientation vector ',A1,': B1 =',3(2X,F9.4),/,
     1                                    33X,'B2 =',3(2X,F9.4))
        IF(KPOCTY(2,IPHASE).EQ.1) WRITE(IOTTO,2092) '2',
     1  (PPOPAR(J,2,IPHASE)-SY(J+2),SY(J+2),SZ(J+2),J=1,2)
      ENDIF
C-
C-  NEXT PHASE
1010  CONTINUE
C-
C-----GLOBAL PARAMETERS-------------------------------------------------
C-
3000  WRITE(IOTTO,3002)
3002  FORMAT(//,' *  GLOBAL PARAMETERS, SHIFTS AND STANDARD DEVIATIONS')
C-
      DO 3010 J=1,13
      KM = LGLB(J)
      IF(KM.GT.0) THEN
        SZ(J) = DSQRT( DABS(RJAC(KM,KM)) ) * ABS(AGLB(J))
        IF( KWSGON.EQ.1 .AND. J.EQ.10 ) THEN
          SY(J) = RJVX(KM) * AGLB(J) * RELAX(2)
         ELSE
          SY(J) = RJVX(KM) * AGLB(J) * RELAX(4)
        ENDIF
        PGLB(J) = PGLB(J) + SY(J)
       ELSE
        SY(J) = 0.0
        SZ(J) = 0.0
      ENDIF
3010  CONTINUE
C-
C-  ZERO PT
      WRITE(IOTTO,3020) PGLB(1)-SY(1),SY(1),SZ(1),
     1  PGLB(10)-SY(10),SY(10),SZ(10)
3020  FORMAT(/,' Zeropoint correction  =',3F10.6,/,
     1         ' Specimen displacement =',3F10.6)
C-
C-  BACKGROUND PARAMETERS
      IF(NBCKGD.EQ.0) WRITE(IOTTO,3030)
     1         (PGLB(J)-SY(J),J=2,7),(SY(J),J=2,7),(SZ(J),J=2,7)
3030  FORMAT(/,' Background parameters:',/,
     1 6X,'C0',11X,'C1',11X,'C2',11X,'C3',11X,'C4',11X,'C-1',
     1 1P,3(/,1X,6(1X,E12.5)))
C-
C-  AMORPHOUS PROFILE PARAMETERS
      IF(KAMOR.EQ.1) WRITE(IOTTO,3060)
     1        (PGLB(J)-SY(J),J=11,13),(SY(J),J=11,13),(SZ(J),J=11,13)
3060  FORMAT(/,
     1' Amorphous profile parameters:   2Theta     Peak      FWHM',
     1 3(/,32X,F8.4,2X,F8.2,2X,F8.4))
C-
C-----R FACTORS AND ERRORS FOR THIS ROUND-------------------------------
C-
4000  X = 100.0 * SQRT( REAL(NMATPT-KMXVAR) / CHID1 )
      WRITE(IOTTO,4010) RESR,RESRWP,X
4010  FORMAT(//,
     1 ' Residual errors:  R = ',F8.2,' %   Rwp = ',F8.2,' %',/,
     1 8X,'Expected:',19X,'Rwp = ',F8.2,' %')
      I = NMATPT - KMXVAR
      WRITE(IOTTO,4040) CHID1,CHIS3,CHIS1,CHIS2,I,COND
4040  FORMAT(/,
     1  4X,'Sum-I-Obs',3X,'Sum-I-Calc',2X,'Sum-I-Dif**2',3X,'Residual',
     1  3X,'NPts - NVar',3X,'Condition',/,
     1  1X,1P,4(1X,E12.5),4X,I5,4X,E12.5,/)
C-
      RETURN
      END
C--DIRECT
      SUBROUTINE DIRECT( SM, V )
C-
      INCLUDE 'RIETCOM.FOR'
      DIMENSION V(6),SM(6,6)
C-
      DO 1 J=1,6
      V(J) = PPHLAT(J,IPHASE)
      X = APHLAT(J,IPHASE)
      K = LPHLAT(J,IPHASE)
      DO 1 L=J,6
      Z = APHLAT(L,IPHASE)
      M = LPHLAT(L,IPHASE)
      SM(L,J) = 0.0
      IF( M.EQ.0 .OR. K.EQ.0 ) GO TO 1
      SM(L,J) = RJAC(K,M) * X * Z
1     SM(J,L) = SM(L,J)
      CALL ESD( SM, V, 1.0 )
C-
      RETURN
      END
C--  ESD
C-
      SUBROUTINE ESD(SM,V,SUM)
      DIMENSION SM(6,6),V(6),S(6),R(6),E(6)
C-
      I=0
      DO 1 IA=1,3
      I=I+1
      IB=IA+1
      IF(IB.GT.3)IB=IB-3
      IC=IB+1
      IF(IC.GT.3)IC=IC-3
      ID=IA+3
      IE=IB+3
      IP=IC+3
      FNUM=4.*V(IB)*V(IC)-V(ID)*V(ID)
      DEN=4.*V(IA)*V(IB)*V(IC)-V(IA)*V(ID)*V(ID)-V(IB)*V(IE)*V(IE)-V(IC)
     1*V(IP)*V(IP)+V(ID)*V(IE)*V(IP)
      S(I)=SQRT(FNUM/DEN)
      R(IA)=-S(I)**4
      DENL=1./(DEN*DEN)
      R(IB)=DENL*(4.*V(IC)*DEN-(4.*V(IA)*V(IC)-V(IE)*V(IE))*FNUM)
      R(IC)=DENL*(4.*V(IB)*DEN-(4.*V(IA)*V(IB)-V(IP)*V(IP))*FNUM)
      R(ID)=-DENL*(2.*V(ID)*DEN-(2.*V(IA)*V(ID)-V(IE)*V(IP))*FNUM)
      R(IE)=DENL*FNUM*(2.*V(IB)*V(IE)-V(ID)*V(IP))
      R(IP)=DENL*FNUM*(2.*V(IC)*V(IP)-V(ID)*V(IE))
      E(I)=ERROR(SM(1,1),R(1),SUM)
      E(I)=E(I)/(2.*S(I))
      FNUM=V(IE)*V(IP)-2.*V(IA)*V(ID)
      DEN=16.*V(IA)*V(IA)*V(IB)*V(IC)+V(IE)*V(IE)*V(IP)*V(IP)-4.*(V(IA)*
     1V(IB)*V(IE)*V(IE)+V(IC)*V(IA)*V(IP)*V(IP))
      DENL=1./(DEN*DEN)
      FNUML=FNUM*FNUM
      S(I+3)=FNUML/DEN
      R(IA)=-4.*FNUM*DENL*(V(ID)*DEN+FNUM*(8.*V(IA)*V(IB)*V(IC)-V(IB)*V(
     1IE)*V(IE)-V(IC)*V(IP)*V(IP)))
      R(IB)=-4.*FNUML*DENL*(4.*V(IA)*V(IA)*V(IC)-V(IA)*V(IE)*V(IE))
      R(IC)=-4.*FNUML*DENL*(4.*V(IA)*V(IA)*V(IB)-V(IA)*V(IP)*V(IP))
      R(ID)=-4.*FNUM/DEN*V(IA)
      R(IE)=2.*FNUM*DENL*(V(IP)*DEN-FNUM*(V(IE)*V(IP)*V(IP)-4.*V(IA)*V(I
     1B)*V(IE)))
      R(IP)=2.*FNUM*DENL*(V(IE)*DEN-FNUM*(V(IE)*V(IE)*V(IP)-4.*V(IC)*V(I
     1A)*V(IP)))
      E(I+3)=ERROR(SM(1,1),R(1),SUM)
      IF(S(I+3).EQ.0.0) GOTO 3
      E(I+3)=E(I+3)/(2.*SQRT(S(I+3)*(1.-S(I+3))))*180./3.14159265359
      S(I+3)=ATAN(SQRT((1.-S(I+3))/S(I+3)))*180./3.14159265359
      GOTO 4
3     S(I+3)=90.
      E(I+3)=0.0
4     CONTINUE
      IF(FNUM.LT.0.)S(I+3)=180.-S(I+3)
      IF(SM(ID,ID).EQ.0.)E(ID)=0.
1     CONTINUE
      IF(ABS(S(1)-S(2)).LT..00008)E(1)=E(2)
      DO 2 I=1,6
      SM(I,I)=E(I)
2     V(I)=S(I)
      RETURN
      END
C--  ERROR
C-
      FUNCTION ERROR( A, B, OMEGA )
C-
      DIMENSION A(6,6),B(6)
C-
      SUM = 0.0
      DO 1 I=1,6
      DO 1 J=I,6
      X = 2.0
      IF(I.EQ.J) X = 1.0
1     SUM = SUM + A(I,J) * B(I) * B(J) * X
      IF(SUM.LT.1.0E-20) SUM = 0.0
      ERROR = SQRT( SUM * OMEGA )
C-
      RETURN
      END
C---  PROGRAM: RIETVELD  (RIET40)
C---  VERSION: 881001  (YYMMDD)
C---
      SUBROUTINE EXPUT
C-
      INCLUDE 'RIETCOM.FOR'
      PARAMETER( MAXFAC=1024 )
      LOGICAL LASYM,LBLOCK,LSTRUC,LEXIST
      CHARACTER*1 QSPACE,QDOT,QSTAR,QPLUS,QMINUS,QBAR,QPLTBF(150)
      CHARACTER QDATE*9,QTIME*8
      COMMON CLCPAT(MNPTS),OBSFAC(MAXFAC),CLCFAC(MAXFAC)
      DIMENSION INTDEL(10),DELANG(10),HKL(3)
      DIMENSION LABEL(12),KS(50)
      DATA QSPACE/' '/,QDOT/'.'/,QSTAR/'*'/,QPLUS/'+'/,QMINUS/'0'/
      DATA QBAR/'-'/
      DATA LBLOCK,LSTRUC /.FALSE.,.TRUE./
C-
C----W-R-I-T-E---N-E-W---C-O-N-T-R-O-L---F-I-L-E------------------------
C-
      IF(KOFNCF.GT.0) CALL REWRIT
C-
C---W-R-I-T-E---C-A-L-C-U-L-A-T-E-D---S-T-R-U-C-T-U-R-E---F-A-C-T-O-R-S-
C-
1000  IF( .NOT.LSTRUC .OR. KOFSFL.EQ.0 ) GO TO 46
C-
C-  OPEN FILE FOR STRUCTURE FACTOR DATA AND WRITE TITLE
      INQUIRE(FILE='STRUC',EXIST=LEXIST)
      IF(LEXIST) THEN
        OPEN(UNIT=31,FILE='STRUC',STATUS='OLD')
        CLOSE(UNIT=31,STATUS='DELETE')
      ENDIF
CIBM
c      OPEN(UNIT=31,FILE='STRUC',STATUS='NEW')
CIBM
CVAX
      OPEN(UNIT=31,FILE='STRUC',STATUS='NEW',CARRIAGECONTROL='LIST')
CVAX
      WRITE(31,1010) QTITLE(1:72)
1010  FORMAT(1X,A72)
      WRITE(31,1012) NPHASE
1012  FORMAT(/,' Number of phases: ',I2)
C-
C-  SET VARIABLES TO MINIMIZE CALCULATION TIME
      KMXVCO = KMXVAR
      KMXVAR = 0
      JOBCOP = JOBXN
      IF(JOBXN.LT.3) JOBXN = JOBXN + 2
C-
C-  GET THE TOTAL NUMBER OF REFLECTIONS
      IRTOT = 0
      DO 1020 IPHASE=1,NPHASE
1020  IRTOT = IRTOT + KREFNM(IPHASE)
C-
C-  REPEAT FOR EACH PHASE
      DO 1030 IPHASE=1,NPHASE
      WRITE(31,1040) QPHSNM(IPHASE),SQRT(VO2CMP(IPHASE)),
     1               KREFNM(IPHASE),(QSSYMB(J,IPHASE),J=1,20),
     1               QLAUGR(IPHASE),(SAVE(J,IPHASE),J=1,6)
1040  FORMAT(/,' Phase: ',A32,/,
     1         ' Cell volume: ',F10.4,'  Reflections: ',I4,/,
     1         ' Space group: ',20A1,' Laue group: ',A8,/,
     1         ' Lattice parameters: ',3F8.4,3F9.4)
      WRITE(31,1042)
1042  FORMAT(/,
     1 ' No.   H   K   L  Wave  M',6X,'Re(A)',8X,'Im(A)',8X,'Re(B)',8X,
     1 'Im(B)')
C-
C-  REPEAT FOR EACH REFLECTION ASSOCIATED WITH PHASE
      IXX = 0
      DO 1050 IORDC=1,IRTOT
      IF( IPHASE .NE. KREFDT(IORDC)/256/256/256/4 ) GO TO 1050
      IXX = IXX + 1
C-
C-  WRITE THE REFLECTION RELATED PARAMETERS
      MULT = NINT( PREFLP(IORDC) / PLORNZ(PREFTT(IORDC)) )
      IRH = MOD( KREFDT(IORDC)/256/256,      256 ) - 128
      IRK = MOD( KREFDT(IORDC)/256,          256 ) - 128
      IRL = MOD( KREFDT(IORDC),              256 ) - 128
      IRC = MOD( KREFDT(IORDC)/256/256/256 ,   4 )
      F2TCOP = F2TOT(IORDC)
      CALL CLCSTR( REAL(IRH), REAL(IRK), REAL(IRL), 1.0, 1.0, 1.0 )
      F2TOT(IORDC)= F2TCOP
      WRITE(31,1060) IXX,IRH,IRK,IRL,IRC,MULT,SFNAR,SFNAI,SFNBR,SFNBI
1060  FORMAT(I4,3I4,4X,I1,2X,I2,1X,1P,4(1X,E12.5))
C-
C-  NEXT REFLECTION
1050  CONTINUE
C-
C-  GET F(000) REFLECTION DATA
      IORDC = 1
      F2TCOP = F2TOT(IORDC)
      CALL CLCSTR( 0.0, 0.0, 0.0, 1.0, 1.0, 1.0 )
      F2TOT(IORDC)= F2TCOP
      WRITE(31,1060) 0,0,0,0,0,0,SFNAR,SFNAI,SFNBR,SFNBI
C-
C-  NEXT PHASE
1030  CONTINUE
C-
C-  RESET ALTERED PARAMETERS
      KMXVAR = KMXVCO
      JOBXN = JOBCOP
C-
C---GENERATE CALCULATED PATTERN IN CLCPAT-------------------------------
C-
46    DO 47 I=1,KPPTS
47    CLCPAT(I) = YCLC(I) + YBKG(I)
      IF(JOBXN.GT.2) THEN
        DO 48 I=1,KPPTS
48      YOBS(I) = CLCPAT(I)
      ENDIF
C-
C----IF ONLY PATTERN CALCULATION- SKIP NEXT TWO SECTIONS----------------
C-
      IF(JOBXN.GT.2) GO TO 4000
C-
C-----I-N-T-E-N-S-I-T-Y---D-I-F-F-E-R-E-N-C-E-S-------------------------
C-
2000  IF(.NOT.LBLOCK) GO TO 3000
      WRITE(IOTTO,2010)
2010  FORMAT(/,' Average intensity difference (Io-Ic) for the pattern,'
     1      ,/,' given in blocks of 20 observations.',/)
      DO 2020 I=1,KPPTS,200
      IM1 = I - 1
      DO 2030 J=1,10
      IJ = IM1 + (J-1) * 20
      INTDEL(J) = 0
      DO 2040 K=1,20
      IJK = IJ + K
      IF(IJK.GT.KPPTS) GO TO 2042
      INTDEL(J) = INTDEL(J) + NINT( YOBS(IJK) - CLCPAT(IJK) )
2040  CONTINUE
      K = 20
2042  INTDEL(J) = INTDEL(J) / AMAX0( K, 1 )
      INTDEL(J) = MIN0( INTDEL(J),  9999 )
      INTDEL(J) = MAX0( INTDEL(J), -9999 )
      DELANG(J) = THMIN + REAL(IJ) * STEP
      IF(IJK.GT.KPPTS) GO TO 2050
2030  CONTINUE
      J = 10
2050  WRITE(IOTTO,2060) (DELANG(JJ),INTDEL(JJ),JJ=1,J)
2060  FORMAT(10(2X,F6.2,I5))
2020  CONTINUE
C-
C-----C-O-R-R-E-L-A-T-I-O-N---M-A-T-R-I-X-------------------------------
C-
3000  IF(KOFMAT.EQ.0) GO TO 4000
      WRITE(IOTTO,3010)
3010  FORMAT(/,' * CORRELATION MATRIX:')
      IA = 1
      LIM = 20
3020  LIM = MIN0( KMXVAR, LIM )
      WRITE(IOTTO,3030) (I,I=IA,LIM)
3030  FORMAT(/,4X,20I6)
C-  CONVERT INVERTED MATRIX ELEMENTS TO COVARIANCE BY NORMALIZATION
      DO 3040 I=1,KMXVAR
      L = 0
      X = RJAC(I,I)
      DO 3050 J=IA,LIM
      L = L + 1
      YY = RJAC(J,J) * X
3050  KS(L) = 100.0 * RJAC(J,I) / ( SQRT(ABS(YY))*SIGN(1.,YY) ) + 0.5
3040  WRITE(IOTTO,3060) I,(KS(J),J=1,L)
3060  FORMAT(I5,20I6)
      IF(LIM.GE.KMXVAR) GO TO 4000
      IA = LIM + 1
      LIM = LIM + 20
      GO TO 3020
C-
C-----S-T-R-U-C-T-U-R-E---F-A-C-T-O-R-S---------------------------------
C-
4000  IF(KOFSFL.EQ.0) GO TO 5000
C-
C-  GET THE TOTAL NUMBER OF REFLECTIONS FOR ALL PHASES
      IRTOT = 0
      DO 4010 IPHASE=1,NPHASE
4010  IRTOT = IRTOT + KREFNM(IPHASE)
C-
C-  INITIALIZE THE AREAS FOR USE WITH THE INTEGRATION FACTORS
      DO 4230 J=1,MAXFAC
      OBSFAC(J) = 0.0
      CLCFAC(J) = 0.0
4230  CONTINUE
C-
C--  REPEAT FOR EACH PHASE
C-
4100  DO 4110 IPHASE=1,NPHASE
C-
C-  WRITE STRUCTURE-FILE HEADER INFORMATION
      IF(LSTRUC) THEN
        WRITE(31,4004) QPHSNM(IPHASE)
4004    FORMAT(/,' Phase name: ',A32)
        WRITE(31,4006)
4006    FORMAT(/,' No.   H   K   L  Alpha',6X,'Fc**2',8X,'Fo**2')
      ENDIF
C-
C-  PHASE RELATED PARAMETERS
      SCALEF = PPHSCA(IPHASE) / VO2CMP(IPHASE)
      NPSFKK = NPSF(1,IPHASE)
C-
C-- REPEAT FOR EACH LINE
C-
C-  INITIALIZE FACTORS FOR CALCULATION OF BRAGG R
4200  TOTOBS = 0.0
      TOTDIF = 0.0
C-
C--  CHECK EACH REFLECTION- ONLY INTERESTED IN LINES BELONGING TO IPHASE
      IXX = 0
      DO 4210 IORDC=1,IRTOT
      IF( IPHASE .NE. KREFDT(IORDC)/256/256/256/4 ) GO TO 4210
      IXX = IXX + 1
C-
C-  MILLER INDICES AND RADIATION WAVELENGTH FOR REFLECTION
      IRH = MOD( KREFDT(IORDC)/256/256,      256 ) - 128
      IRK = MOD( KREFDT(IORDC)/256,          256 ) - 128
      IRL = MOD( KREFDT(IORDC),              256 ) - 128
      IRC = MOD( KREFDT(IORDC)/256/256/256 ,   4 )
C-
C-  PREFERRED ORIENTATION AND ABSORPTION CORRECTION FACTORS FOR THE REFLECTION
      HKL(1) = REAL( IRH )
      HKL(2) = REAL( IRK )
      HKL(3) = REAL( IRL )
      CALL PRFCRF( 1, HKL, PRECOR, TEMP )
      CALL ABSCRF( 1, PREFTT(IORDC), ABSCOR, TEMP )
C-
C-  SET STORAGE POINTER (USED FOR PEARSON VII FACTOR BELOW)
      MODNRF = MOD( IORDC, MOVRL ) + 1
C-
C-  NORMALIZING FACTOR FOR PEARSON VII WITH VARIABLE EXPONENT
      IF( NPSFKK.EQ.3 ) THEN
        IF( NPSF(2,IPHASE).EQ.2 .OR. NPSF(2,IPHASE).EQ.3 ) THEN
          EXPML=( PPHPSF(3,1,IPHASE)*PREFTT(IORDC) + PPHPSF(2,1,IPHASE))
     1            * PREFTT(IORDC) + PPHPSF(1,1,IPHASE)
          PRSTL = 2.0**(1.0/EXPML) - 1.0
          PVM1L= GAMMA(EXPML)
          PVM2L= SQRT(PRSTL)
          PVM3L= GAMMA(EXPML-0.5)
          EXPMH=( PPHPSF(3,2,IPHASE)*PREFTT(IORDC) + PPHPSF(2,2,IPHASE))
     1            * PREFTT(IORDC) + PPHPSF(1,2,IPHASE)
          PRSTH = 2.0**(1.0/EXPMH) - 1.0
          PVM1H= GAMMA(EXPMH)
          PVM2H= SQRT(PRSTH)
          PVM3H= GAMMA(EXPMH-0.5)
          PVIIN(IPHASE,MODNRF) = PRSC /
     1      ( PVM1L * PVM2L / PVM3L + PVM1H * PVM2H / PVM3H )
         ELSE
          EXPM=( PPHPSF(3,1,IPHASE)*PREFTT(IORDC) + PPHPSF(2,1,IPHASE))
     1            * PREFTT(IORDC) + PPHPSF(1,1,IPHASE)
          PRST = 2.0**(1.0/EXPM) - 1.0
          PVM1 = GAMMA(EXPM)
          PVM2 = SQRT(PRST)
          PVM3 = GAMMA(EXPM-0.5)
          PVIIN(IPHASE,MODNRF) = PRSC * PVM1 * PVM2 / PVM3
        ENDIF
      ENDIF
C-
C-  LINE RELATED PARAMETERS
      TWOTHT = PREFTT(IORDC)
      TANTHT = TAN(TWOTHT*DTORD2)
      CORL2T = TWOTHT-CORPOS(TWOTHT)+PGLB(1)+PGLB(10)*COS(TWOTHT*DTORD2)
C-
C-  2THETA LTMIN AND LTMAX FOR LINE
      DO 4220 ICHKR=1,KPPTS
      IF( IAND( KREFRN(ICHKR)/65536, 65535 ) .GE. IORDC ) GO TO 4222
4220  CONTINUE
4224  WRITE(IOTTO,4226) IXX
4226  FORMAT(' -Line ',I4,' not found in pattern')
      GO TO 4210
4222  LTMIN = ICHKR
      DO 4228 ICHKR=LTMIN,KPPTS
      IF( IAND( KREFRN(ICHKR), 65535 ) .GT. IORDC ) GO TO 4229
4228  CONTINUE
      ICHKR = KPPTS + 1
4229  LTMAX = ICHKR - 1
C-
C-  FLAG INDICATING ASYMMETRY CORRECTION TO BE APPLIED THIS PHASE
      LASYM = TWOTHT.LT.RLIM(IPHASE)
C-
C-  POINTER FOR FACTORS USED IN THE INTEGRATION OF REFLECTIONS
      IP = 0
C-
C--  REPEAT FOR EACH POINT IN THE REFLECTION
4300  DO 4310 ICURPT=LTMIN,LTMAX
      CURTHT = THMIN + REAL(ICURPT-1) * STEP
C-
C-  SKIP POINTS THAT ARE IN EXCLUDED REGIONS
      IF(KREFRN(ICURPT).EQ.65536) GO TO 4310
C-
C-  DISTANCE AND SQUARE FROM PEAK
      TTHOMC = CURTHT - CORL2T
      DELTA2 = TTHOMC * TTHOMC
C-
C-  BROADENING PARAMETERS FOR THE LINE
      CALL FNFWHM
      IF( CURTHT.GT.PREFTT(IORDC) .AND.
     1    ( NPSF(2,IPHASE).EQ.1 .OR. NPSF(2,IPHASE).EQ.3 ) ) THEN
        FWHM = FWHMH
       ELSE
        FWHM = FWHML
      ENDIF
      FWHM2 = FWHM * FWHM
C-
C-  PROFILE SHAPE FUNCTION PARAMETERS FOR THE LINE
      IF( CURTHT.GT.PREFTT(IORDC) .AND.
     1   ( NPSF(2,IPHASE).EQ.2 .OR. NPSF(2,IPHASE).EQ.3 ) ) THEN
        GAM1   = PPHPSF(1,2,IPHASE)
        GAM2   = PPHPSF(2,2,IPHASE)
        GAM3   = PPHPSF(3,2,IPHASE)
       ELSE
        GAM1   = PPHPSF(1,1,IPHASE)
        GAM2   = PPHPSF(2,1,IPHASE)
        GAM3   = PPHPSF(3,1,IPHASE)
      ENDIF
C-
C-  FRACTIONAL DIVISION OF OBSERVED INTENSITIES
      IF(LASYM) THEN
        Z = 1.0 - PPHASY(IPHASE) * DELTA2 * SIGN( 1.0, TTHOMC ) / TANTHT
        Z = AMAX1( Z, 0.001 )
       ELSE
        Z = 1.0
      ENDIF
      OMEGA = Z * PROFIL(DELTA2/FWHM2)
      YCALC = YCLC(ICURPT)
      IF(YCALC.GT.0.0001) THEN
        IP = IP + 1
        CLCFAC(IP) = OMEGA
        OBSFAC(IP) = OMEGA/YCALC*AMAX1((YOBS(ICURPT)-YBKG(ICURPT)),0.0)
      ENDIF
C-
C-  ENSURE THE DATA AREAS ARE NOT OVERRUN
      IF(IP.EQ.MAXFAC) THEN
        WRITE(IOTTO,4312) (LTMAX-LTMIN+1),MAXFAC
4312    FORMAT(/,
     1  ' --EXPUT: Can not fully integrate reflection; too many points',
     1  ' in line (',I4,').',/,
     1  10X,'Increase the value of the parameter MAXFAC (',I4,').')
C       IRMIN = IAND( KREFRN(LTMIN)/65536, 65535 )
C       IRMAX = IAND( KREFRN(LTMAX)/65536, 65535 )
C       WRITE(IOTTO,4313) LTMIN,IRMIN,LTMAX,IRMAX,FWHML
C4314   FORMAT(10X,
C    1' LTMIN = ',I4,' (',I4,')  LTMAX = ',I4,' (',I4,')  FWHM = ',F6.2)
        GO TO 4314
      ENDIF
C-
C-  NEXT POINT
4310  CONTINUE
C-
C-  AREA UNDER THE CALCULATED AND OBSERVED CURVES
4314  IPC = IP
      IF(IP.EQ.(IP/2)*2) IP = IP + 1
      IF(IP.GT.KPPTS) IP = IP - 2
      SUM2 = 0.0
      SUM4 = 0.0
      DO 4240 J=2,IP-1,2
4240  SUM4 = SUM4 + CLCFAC(J)
      DO 4250 J=3,IP-2,2
4250  SUM2 = SUM2 + CLCFAC(J)
      CI = (STEP/3.0) * (CLCFAC(1)+CLCFAC(IP)+4.0*SUM4+2.0*SUM2)
      SUM2 = 0.0
      SUM4 = 0.0
      DO 4260 J=2,IP-1,2
4260  SUM4 = SUM4 + OBSFAC(J)
      DO 4270 J=3,IP-2,2
4270  SUM2 = SUM2 + OBSFAC(J)
      OI = (STEP/3.0) * (OBSFAC(1)+OBSFAC(IP)+4.0*SUM4+2.0*SUM2)
C      WRITE(6,3138) IP,IPC,OI,CI
C3138  FORMAT(' IP, IPC, OI, CI = ',2I5,1X,2F10.6)
C-
C-  RE-INITIALIZE AREAS FOR INTEGRATION FACTORS
      DO 4272 J=1,IPC
      OBSFAC(J) = 0.0
      CLCFAC(J) = 0.0
4272  CONTINUE
C-
C-  CALCULATION OF INTEGRATED INTENSITIES AND FACTORS FOR BRAGG R
      SF2TLP = SCALEF * F2TOT(IORDC) * PREFLP(IORDC)
      CLCINT = CI * SF2TLP
      OBSINT = OI * SF2TLP
      TOTOBS = TOTOBS + OBSINT
      TOTDIF = TOTDIF + ABS( OBSINT - CLCINT )
C-
C-  WRITE OBSERVED AND CALCULATED STRUCTURE FACTORS TO DATA FILE
      IF(LSTRUC) THEN
        CLCF2T = CI * F2TOT(IORDC) / PRECOR / ABSCOR
        OBSF2T = OBSINT / SCALEF / PREFLP(IORDC) / PRECOR / ABSCOR
        WRITE(31,4280) IXX,IRH,IRK,IRL,IRC,CLCF2T,OBSF2T
4280    FORMAT(I4,3I4,4X,I1,3X,1P,2(1X,E12.5))
      ENDIF
C-
C-  PRINTING OF LINE PARAMETERS
      DSPACE = RADWAV(IRC) / ( 2.0 * SIN(TWOTHT*DTORD2) )
      IF(MOD(IXX-1,60).EQ.0) WRITE(IOTTO,4290) IPHASE,QPHSNM(IPHASE)
4290  FORMAT(/,'1Structure factors for phase ',I2,': ',A32,//,
     1 '  No.  H  K  L  Alpha  2Theta  D-space  Peak I  Int-I Cal',
     1 2X,'Int-I Obs',5X,'F**2')
      WRITE(IOTTO,4292) IXX,IRH,IRK,IRL,IRC,TWOTHT,DSPACE,PREFPK(IORDC),
     1     CLCINT,OBSINT,F2TOT(IORDC)/PRECOR/ABSCOR
4292  FORMAT(1X,I4,3I3,I5,3X,F7.3,2X,F7.4,F8.1,F10.2,1X,F10.2,2X,F10.2)
C-
C-  NEXT LINE
4210  CONTINUE
C-
C-  THE DERIVED RB FOR THE PHASE
      IF(JOBXN.LT.3) THEN
        IF(TOTOBS.GT.0.0) THEN
          TOTDIF = 100.0 * TOTDIF / TOTOBS
         ELSE
          TOTDIF = -1.0
        ENDIF
       ELSE
        TOTDIF = 0.0
      ENDIF
      WRITE(IOTTO,4130) TOTDIF
4130  FORMAT(/,' Derived Bragg R-factor = ',F8.2)
C-
C-  NEXT PHASE
4110  CONTINUE
C-
C-  CLOSE STRUCTURE FACTOR DATA FILE
      IF(LSTRUC) CLOSE(UNIT=31)
C-
C-----O-B-S-E-R-V-E-D---/---C-A-L-C-U-L-A-T-E-D---I-N-T-E-N-S-I-T-I-E-S-
C-
5000  IF(KOFILS.EQ.0) GO TO 7000
      NP = KPPTS / 300
      DO 5010 I=1,KPPTS
5010  OBSFAC(I) = THMIN + REAL(I-1) * STEP
      WRITE(IOTTO,5020) (((OBSFAC(300*N-360+60*I+J),
     1                       YOBS(300*N-360+60*I+J),
     1                     CLCPAT(300*N-360+60*I+J),
     1                     I=1,5),J=1,60),N=1,NP)
5020  FORMAT(('1 ',5('2Theta',3X,'Iobs',4X,'Icalc',4X),/,
     1 60(5(1X,F8.4,2F8.0,1X),/)))
      NPTS2 = KPPTS - NP*300
      IF(NPTS2.EQ.0) GO TO 7000
      NCOL = NPTS2 / 60
      WRITE(IOTTO,5030)
5030  FORMAT('1 ',5('2Theta',3X,'Iobs',4X,'Icalc',4X))
      NLINES = NPTS2 - NCOL*60
      IF(NLINES.EQ.0) GO TO 5040
      NCOL1 = NCOL + 1
      NP = 300*NP - 60
      DO 5050 J=1,NLINES
5050  WRITE(IOTTO,5060) ( OBSFAC(NP+60*I+J),YOBS(NP+60*I+J),
     1 CLCPAT(NP+60*I+J),  I=1,NCOL1)
5060  FORMAT(5(1X,F8.4,2F8.0,1X))
      NP = NP + NLINES
      NLINES = 60 - NLINES
5040  DO 5070 J=1,NLINES
5070  WRITE(IOTTO,5060) ( OBSFAC(NP+60*I+J),YOBS(NP+60*I+J),
     1 CLCPAT(NP+60*I+J), I=1,NCOL)
C-
C-----C-A-L-C-U-L-A-T-E-D---P-A-T-T-E-R-N-------------------------------
C-
7000  IF(JOBXN.LT.3) GO TO 8000
      WRITE(IOTTO,7002)
7002  FORMAT(/,' Writing calculated pattern')
      WRITE(4,7010,ERR=7090) QTITLE
7010  FORMAT(A80)
      CALL DATE( QDATE )
      CALL TIME( QTIME )
      WRITE(4,7020,ERR=7090) QDATE,QTIME
7020  FORMAT(A9,A8)
      CTIME = 1.0
      WRITE(4,7030,ERR=7090) THMIN,THMAX,STEP,CTIME
7030  FORMAT(4F10.4)
      WRITE(4,7040,ERR=7090) (NINT(CLCPAT(I)),I=1,KPPTS)
7040  FORMAT(10I7)
      GO TO 8000
7090  WRITE(IOTTO,7092)
7092  FORMAT(' --Error writing calculated pattern!')
C-
C-----P-L-O-T-T-I-N-G---------------------------------------------------
C-
C----LINE PRINTER PLOT--------------------------------------------------
C-
8000  IF(KOFPLL.NE.1) GO TO 8100
C-
C-  LABEL THE INTENSITY AXIS
      DO 8010 I=1,12
8010  LABEL(I)= 10 * I * KLPPLT(1)
      WRITE(IOTTO,8020) QTITLE,LABEL
8020  FORMAT('1',30X,A80,//,1X,12I10)
      DO 8030 I=1,12
8030  LABEL(I)= -60 * KLPPLT(2) + 10 * I * KLPPLT(2)
      WRITE(IOTTO,8040) LABEL
8040  FORMAT(1X,12I10)
C-
C-  REPEAT FOR EACH POINT IN THE PATTERN
      DO 8050 I=1,KPPTS
C-
C-  SET THE MIN,MAX AND MIDPOINT MARKERS
      DO 8070 J=1,120
8070  QPLTBF(  J)=QSPACE
      QPLTBF(  1)=QDOT
      QPLTBF( 61)=QDOT
      QPLTBF(120)=QDOT
C-
C-  SET THE OBSERVED DATA POINT
      IY = INT( YOBS(I) ) / KLPPLT(1) + 2
      IY = MAX0( MIN0( IY, 120 ), 2 )
      QPLTBF(IY-1) = QBAR
      QPLTBF(IY  ) = QPLUS
      IF(IY.LE.119) QPLTBF(IY+1) = QBAR
C-
C-  SET THE CALCULATED DATA POINT
      IY = INT( CLCPAT(I) ) / KLPPLT(1) + 2
      IY = MAX0( MIN0( IY, 120 ), 2 )
      QPLTBF(IY) = QMINUS
C-
C-  SET THE DIFFERENCE DATA POINT
      IY = INT( YOBS(I)-CLCPAT(I) ) / KLPPLT(2) + 61
      IY = MAX0( MIN0( IY, 120 ), 2 )
      QPLTBF(IY) = QSTAR
C-
C-  OUTPUT THE LINE
      IF(MOD(I-1,10).EQ.0) THEN
        TLABEL = THMIN + REAL(I-1) * STEP
        WRITE(IOTTO,8080) (QPLTBF(J),J=1,113),TLABEL,QPLTBF(120)
8080    FORMAT(1X,113A1,F6.2,A1)
       ELSE
        WRITE(IOTTO,8090) (QPLTBF(J),J=1,120)
8090    FORMAT(1X,120A1)
      ENDIF
C-
C-  NEXT POINT
8050  CONTINUE
C-
C----GENERATE PLOT FILE-------------------------------------------------
C-
8100  IF(KOFPLF.EQ.0) GO TO 9000
      CALL CALPLT
C-
9000  RETURN
      END
C---  PROGRAM: RIETVELD  (RIET41)
C---  VERSION: 881001  (YYMMDD)
C---
      SUBROUTINE REWRIT
C-
      INCLUDE 'RIETCOM.FOR'
      CHARACTER QFMT*12
      DATA QFMT/'(F8.M,2F8.4)'/
C-
C---- OPEN THE NEW OUTPUT FILE -----------------------------------------
C-
CVAX
1000  OPEN(UNIT=IONEW,FILE=QNEWFN,STATUS='new',
     1 CARRIAGECONTROL='LIST')
*, ERR=1002)
* status was 'new' changed by dpm 12-5-90
CVAX
CIBM
c1000  OPEN(UNIT=IONEW,FILE=QNEWFN,STATUS='UNKNOWN',ERR=1002)
CIBM
      WRITE(IOTTO,1004) QNEWFN
1004  FORMAT(/,' Writing new control data on file: ',A40)
      GO TO 1100
1002  WRITE(IOTTO,1003)
1003  FORMAT(/,' --ERROR WRITING NEW CONTROL DATA FILE:  SKIP IT.')
      GO TO 9000
C-
C---- RECODE THE PARAMETER CODEWORDS -----------------------------------
C-
C-  RECODE THE ATOM PARAMETER CODEWORDS
1100  NATOM = NATM(2,NPHASE) + NATM(1,NPHASE) - 1
      DO 1110 I=1,NATOM
      DO 1112 J=1,11
1112  AATOM(J,I)= CPYATM(J,I)
      DO 1114 J=1,3
1114  CMAGVE(J,I)= CWMAGC(J,I)
1110  CONTINUE
C-
C-  RECODE THE SPECIMEN PARAMETER CODEWORDS
      DO 1120 IPHASE=1,NPHASE
      APHSCA(IPHASE)     = CPYPHS( 1,IPHASE)
      APHOIT(IPHASE)     = CPYPHS( 2,IPHASE)
      APHABS(IPHASE)     = CPYPHS( 3,IPHASE)
      APHPSF(1,1,IPHASE) = CPYPHS( 4,IPHASE)
      APHPSF(2,1,IPHASE) = CPYPHS( 5,IPHASE)
      APHPSF(3,1,IPHASE) = CPYPHS( 6,IPHASE)
      APHPSF(1,2,IPHASE) = CPYPHS( 7,IPHASE)
      APHPSF(2,2,IPHASE) = CPYPHS( 8,IPHASE)
      APHPSF(3,2,IPHASE) = CPYPHS( 9,IPHASE)
      APHASY(IPHASE)     = CPYPHS(10,IPHASE)
      APHUVW(1,1,IPHASE) = CPYPHS(11,IPHASE)
      APHUVW(2,1,IPHASE) = CPYPHS(12,IPHASE)
      APHUVW(3,1,IPHASE) = CPYPHS(13,IPHASE)
      APHUVW(1,2,IPHASE) = CPYPHS(14,IPHASE)
      APHUVW(2,2,IPHASE) = CPYPHS(15,IPHASE)
      APHUVW(3,2,IPHASE) = CPYPHS(16,IPHASE)
      APHLAT(1,IPHASE)   = CPYPHS(17,IPHASE)
      APHLAT(2,IPHASE)   = CPYPHS(18,IPHASE)
      APHLAT(3,IPHASE)   = CPYPHS(19,IPHASE)
      APHLAT(4,IPHASE)   = CPYPHS(20,IPHASE)
      APHLAT(5,IPHASE)   = CPYPHS(21,IPHASE)
      APHLAT(6,IPHASE)   = CPYPHS(22,IPHASE)
      APOPAR(1,1,IPHASE) = CPYPHS(23,IPHASE)
      APOPAR(2,1,IPHASE) = CPYPHS(24,IPHASE)
      APOPAR(1,2,IPHASE) = CPYPHS(25,IPHASE)
      APOPAR(2,2,IPHASE) = CPYPHS(26,IPHASE)
1120  CONTINUE
C-
C-  RECODE THE GLOBAL PARAMETER CODEWORDS
      DO 1135 I=1,19
      AGLB(I) = CPYGLB(I)
1135  CONTINUE
C-
C---- WRITE THE PARAMETERS TO THE NEW OUTPUT FILE ----------------------
C-
      WRITE(IONEW,1010) QTITLE(1:79)
1010  FORMAT(A79)
C-
      WRITE(IONEW,1020) JOBXN,NPHASE,NBCKGD,NEXCRG,NSCAT,KINTSF,KAMOR,
     1                  KWSGON
1020  FORMAT(8I4)
C-
      WRITE(IONEW,1030) KOFILS,KOFPLL,KOFSFL,KOFMAT,KOFNCF,KOFRLI,
     1                  KOFCIL,KOFRLM,KOFSGO,KOFPLF,KCLRCW,KCONCW
1030  FORMAT(12I4)
C-
      WRITE(IONEW,1022) (KAUTOV(I),I=1,KAUTON)
      WRITE(IONEW,1022) (KAUTOR(I),I=1,KAUTON)
1022  FORMAT(20I4)
C-
      WRITE(IONEW,1040) RADWAV,RADREL(2),WDTTHK,PMCCOR,THMIN,STEP,THMAX
1040  FORMAT(2F8.5,6F8.4)
C-
      WRITE(IONEW,1050) EPS,RELAX
1050  FORMAT(5F8.4)
C-
      WRITE(IONEW,1140) PGLB(1),PGLB(10),AGLB(1),AGLB(10)
1140  FORMAT('   0',4X,2F8.5,/,8X,2F8.2)
C-
      IF(NBCKGD.EQ.0) THEN
        WRITE(IONEW,1060) (PGLB(J),J=2,7),(AGLB(J),J=2,7)
1060    FORMAT(1P,6E12.5,/,0P,6(F8.2,4X))
       ELSE IF(NBCKGD.GT.1) THEN
        WRITE(IONEW,1062) (PBKGTT(I),PBKGIN(I),I=1,NBCKGD)
1062    FORMAT(2F8.2)
      ENDIF
C-
      IF(NEXCRG.GT.0) THEN
        WRITE(IONEW,1062) (PEXCLO(I),PEXCHI(I),I=1,NEXCRG)
      ENDIF
C-
      IF(NSCAT.GT.0) THEN
        DO 1070 I=1,NSCAT
        WRITE(IONEW,1080) QSCNAM(I),DFP(I),DFPP(I)
1080    FORMAT(A4,4X,2F8.4)
C       IF(JOBXN.EQ.1.OR.JOBXN.EQ.3) THEN
          WRITE(IONEW,1090) (SCATAC(J,I),J=1,9)
1090      FORMAT(9F8.5)
C       ENDIF
1070    CONTINUE
      ENDIF
C-
      IF(KINTSF.EQ.1) THEN
        WRITE(IONEW,1150) KINTSN,RINTSQ,KINTSA(1),RINTSA(1),
     1                    KINTSA(2),RINTSA(2),KINTSA(3),RINTSA(3)
1150    FORMAT(4(I8,F8.4))
      ENDIF
C-
      IF(KAMOR.EQ.1) THEN
        WRITE(IONEW,1160) (PGLB(J),J=11,13),(AGLB(J),J=11,13)
1160    FORMAT(8X,F8.4,F8.2,F8.4,/,8X,3F8.2)
      ENDIF
C-
C--  LINE PRINTER AND PLOT FILE PARAMETERS
C-
      IF(KOFPLL.NE.0) WRITE(IONEW,191) (KLPPLT(I),I=1,2)
      IF(KOFPLF.NE.0) WRITE(IONEW,191) (KHCPLT(I),I=1,6)
191   FORMAT(6I4)
C-
C-- WRITE THE PHASE INFORMATION
C-
2000  DO 2010 IPHASE=1,NPHASE
      NATOM = NATM(1,IPHASE)
      IOF   = NATM(2,IPHASE) - 1
C-
      WRITE(IONEW,2020) QPHSNM(IPHASE)
2020  FORMAT(A32)
      WRITE(IONEW,2030) (QSSYMB(I,IPHASE),I=1,20),QXTALS(IPHASE)
2030  FORMAT(20A1,A20)
      WRITE(IONEW,2040) NATM(1,IPHASE),KINDRF(IPHASE),KATMPF(IPHASE),
     1  KMAGSF(IPHASE)
2040  FORMAT(4I4)
C-
C-  ATOM PARAMETERS
      DO 2050 I=1,NATOM
      IPIOF = I + IOF
      WRITE(IONEW,2060) QATLBL(IPIOF),QATTYP(IPIOF),KMAGSI(IPIOF),
     1 (PATOM(J,IPIOF),J=1,5),(AATOM(J,IPIOF),J=1,5)
2060  FORMAT(A8,A4,I4,8X,5F8.5,/,24X,5F8.2)
      WRITE(IONEW,2062) QASPG(IPIOF),(PATOM(J,IPIOF),J=6,11),
     1 (AATOM(J,IPIOF),J=6,11)
2062  FORMAT(A20,4X,6F8.5,/,24X,6F8.2)
      IF(KMAGSI(IPIOF).EQ.1) THEN
        WRITE(IONEW,2064)(PMAGVE(J,IPIOF),J=1,3),(CMAGVE(J,IPIOF),J=1,3)
2064    FORMAT(24X,3F8.2,/,24X,3F8.5)
      ENDIF
2050  CONTINUE
C-
C-  SCALE, OVERALL ISO TEMP AND ABSORPTION FACTORS
      N = 7 - ( INT( ALOG10( AMAX1( PPHSCA(IPHASE), 1.0 ) ) ) + 1 )
      WRITE(QFMT(5:5),'(I1)') N
      WRITE(IONEW,QFMT) PPHSCA(IPHASE),PPHOIT(IPHASE),PPHABS(IPHASE)
      WRITE(IONEW,2160) APHSCA(IPHASE),APHOIT(IPHASE),APHABS(IPHASE)
2160  FORMAT(3F8.2)
C-
C-  PROFILE-SHAPE-FUNCTION PARAMETERS
      WRITE(IONEW,2080) NPSF(1,IPHASE),NPSF(2,IPHASE),RLIM(IPHASE),
     1 PPHASY(IPHASE),(PPHPSF(I,1,IPHASE),I=1,3),
     1 APHASY(IPHASE),(APHPSF(I,1,IPHASE),I=1,3)
2080  FORMAT(2I4,5F8.4,/,16X,4F8.2)
      IF( NPSF(2,IPHASE).EQ.2 .OR. NPSF(2,IPHASE).EQ.3 ) THEN
        WRITE(IONEW,2082) (PPHPSF(I,2,IPHASE),I=1,3),
     1   (APHPSF(I,2,IPHASE),I=1,3)
2082    FORMAT(24X,3F8.4,/,24X,3F8.2)
      ENDIF
C-
C-  PROFILE BROADENING COEFFICIENTS
      IF(KWSGON.EQ.0) THEN
        WRITE(IONEW,2090) (PPHUVW(I,1,IPHASE),I=1,3),
     1  (APHUVW(I,1,IPHASE),I=1,3)
2090    FORMAT(8X,3F8.5,/,8X,3F8.2)
        IF( NPSF(2,IPHASE).EQ.1 .OR. NPSF(2,IPHASE).EQ.3 ) THEN
          WRITE(IONEW,2090) (PPHUVW(I,2,IPHASE),I=1,3),
     1     (APHUVW(I,2,IPHASE),I=1,3)
        ENDIF
       ELSE
        PPHUVW(2,1,IPHASE) = PPHUVW(2,1,IPHASE) * 1.0E+3
        WRITE(IONEW,2092) PPHUVW(1,1,IPHASE)/10.0,PPHUVW(2,1,IPHASE),
     1  (APHUVW(I,1,IPHASE),I=1,2)
2092    FORMAT(8X,F8.2,F8.6,/,8X,2F8.2)
      ENDIF
C-
C-  LATTICE PARAMETERS
      WRITE(IONEW,2100) (SAVE(J,IPHASE),J=1,6),(APHLAT(I,IPHASE),I=1,6)
2100  FORMAT(3F8.5,3F8.4,/,6F8.2)
C-
C-  PREFERRED ORIENTATION PARAMETERS
      WRITE(IONEW,2110) KPOCTY(1,IPHASE),KPOCTY(2,IPHASE),
     1  (PPOVEC(I,1,IPHASE),I=1,3),(PPOPAR(I,1,IPHASE),I=1,2),
     1  (APOPAR(I,1,IPHASE),I=1,2)
2110  FORMAT(2I4,5F8.4,/,32X,2F8.2)
      IF(KPOCTY(2,IPHASE).EQ.1) THEN
        WRITE(IONEW,2112) (PPOVEC(I,2,IPHASE),I=1,3),
     1    (PPOPAR(I,2,IPHASE),I=1,2),(APOPAR(I,2,IPHASE),I=1,2)
2112    FORMAT(8X,5F8.4,/,32X,2F8.2)
      ENDIF
C-
C-  NEXT PHASE
2010  CONTINUE
C-
C-  CLOSE THE OUTPUT FILE
      CLOSE(UNIT=IONEW)
C-
C-  RETURN TO CALLER
9000  RETURN
      END
C---  PROGRAM: RIETVELD  (RIET42)
C---  VERSION: 881001  (YYMMDD)
C---
      SUBROUTINE CALPLT
C-
C-  KHCPLT(1) =>  OBSERVED PATTERN
C-  KHCPLT(2) =>  CALCULATED PATTERN
C-  KHCPLT(3) =>  BACKGROUND
C-  KHCPLT(4) =>  DIFFERENCE PATTERN
C-  KHCPLT(5) =>  REFLECTION MARKERS
C-  KHCPLT(6) =>  PROFILE PARAMETERS
C-  IPLTYP    => 0 - BINARY OUTPUT, 1 - FORMATTED OUTPUT
C-
      INCLUDE 'RIETCOM.FOR'
      PARAMETER ( IPLTYP=0, MXDGRP=32 )
      CHARACTER QPLTTL(MXDGRP)*20,QPLFHD*78
      COMMON CLCPAT(MNPTS),DIFFP(MNPTS)
      DIMENSION XVAL(100),YVAL(100)
      DIMENSION KPLCOD(MXDGRP),PPLOFF(MXDGRP),KPLPEN(MXDGRP)
      DIMENSION NPLSET(MXDGRP),KPLMRK(MXDGRP),PPLINC(MXDGRP)
      EQUIVALENCE ( XVAL, DIFFP ), ( YVAL, DIFFP(101) )
      DATA QPLFHD( 1:39) /'*** Plot file V1.0.  tttttttttttt      '/
      DATA QPLFHD(40:78) /'                     dd-mmm-yy hh:mm:ss'/
C-
C-  FIND THE MAXIMUM OF THE OBS AND CAL DATA AND CREATE DIFFERENCE PATTERN
C-  ADD BACKGROUND TO THE CALCULATED INTENSITIES TO GET CALC PATTERN
C-
1000  HI = YOBS(1) / CTIME
      DO 1010 I=2,KPPTS
1010  HI = AMAX1( HI, YOBS(I)/CTIME, CLCPAT(I)/CTIME )
C-
C-  SELECT SUITABLE Y-AXIS SCALING
      FS = AINT(HI/400.0) * 400.0
      IF(FS.LT.HI) FS = FS + 400.0
C-
C-  OPEN THE OUTPUT FILE
1100  IF(IPLTYP.EQ.0) THEN
        OPEN(UNIT=IOPLT,FILE=QPLTFN,STATUS='UNKNOWN',FORM='UNFORMATTED',
     1  ERR=1110)
       ELSE
CVAX
       OPEN(UNIT=IOPLT,FILE=QPLTFN,STATUS='NEW',FORM='FORMATTED',
     1      ERR=1110,CARRIAGECONTROL='LIST')
CVAX
CIBM
c        OPEN(UNIT=IOPLT,FILE=QPLTFN,STATUS='UNKNOWN',FORM='FORMATTED',
c     1  ERR=1110)
CIBM
      ENDIF
      WRITE(IOTTO,1120) QPLTFN
1120  FORMAT(/,' Plot data written on file: ',A40)
      GO TO 2000
1110  WRITE(IOTTO,1112) IOPLT
1112  FORMAT(' --CAN NOT OPEN "UNIT ',I2,'" FOR PLOTTING:  ABORT PLOTS')
      GO TO 9000
C-
C--  SET PLOT PARAMETERS
C-
2000  KPLNST = 0
C-
C-  OBSERVED PATTERN
C-
2100  IF(KHCPLT(1).EQ.0) GO TO 2200
      KPLNST = KPLNST + 1
      WRITE(IOTTO,2110)
2110  FORMAT('  Observed pattern')
      QPLTTL(KPLNST) = 'Observed pattern    '
      NPLSET(KPLNST) =    KPLNST
      KPLCOD(KPLNST) = KHCPLT(1)
      PPLOFF(KPLNST) =       1.0
      KPLPEN(KPLNST) =         2
      KPLMRK(KPLNST) =         0
      PPLINC(KPLNST) =      STEP
C-
C-  CALCULATED PATTERN
C-
2200  IF(KHCPLT(2).EQ.0) GO TO 2300
      KPLNST = KPLNST + 1
      WRITE(IOTTO,2210)
2210  FORMAT('  Calculated pattern')
      QPLTTL(KPLNST) = 'Calculated pattern  '
      NPLSET(KPLNST) =    KPLNST
      KPLCOD(KPLNST) = KHCPLT(2)
      PPLOFF(KPLNST) =       1.0
      KPLPEN(KPLNST) =         3
      KPLMRK(KPLNST) =         0
      PPLINC(KPLNST) =      STEP
C-
C-  BACKGROUND
C-
2300  IF(KHCPLT(3).EQ.0) GO TO 2400
      KPLNST = KPLNST + 1
      WRITE(IOTTO,2310)
2310  FORMAT('  Background')
      QPLTTL(KPLNST) = 'Background          '
      NPLSET(KPLNST) =    KPLNST
      KPLCOD(KPLNST) = KHCPLT(3)
      PPLOFF(KPLNST) =       1.0
      KPLPEN(KPLNST) =         0
      KPLMRK(KPLNST) =         0
      PPLINC(KPLNST) =      STEP
C-
C-  DIFFERENCE PATTERN
C-
2400  IF(KHCPLT(4).EQ.0) GO TO 2500
      KPLNST = KPLNST + 1
      WRITE(IOTTO,2410)
2410  FORMAT('  Difference pattern')
      QPLTTL(KPLNST) = 'Difference pattern  '
      NPLSET(KPLNST) =    KPLNST
      KPLCOD(KPLNST) = KHCPLT(4)
      PPLOFF(KPLNST) =       0.5
      KPLPEN(KPLNST) =         0
      KPLMRK(KPLNST) =         0
      PPLINC(KPLNST) =      STEP
C-
C-  REFLECTION MARKERS
C-
2500  IF(KHCPLT(5).EQ.0) GO TO 2600
      OFFST = 1.0 / REAL(NPHASE)
      BASE = REAL(NPHASE-1) * OFFST
      NPEN = 2
      DO 2510 IPHASE=1,NPHASE
      KPLNST = KPLNST + 1
      WRITE(IOTTO,2520) IPHASE,QPHSNM(IPHASE)(1:20)
2520  FORMAT('  Reflection markers for phase ',I2,'  Id=',A20)
      QPLTTL(KPLNST) = QPHSNM(IPHASE)(1:20)
      NPLSET(KPLNST) =    KPLNST
      KPLCOD(KPLNST) = KHCPLT(5)
      PPLOFF(KPLNST) =      BASE
      KPLPEN(KPLNST) =      NPEN
      KPLMRK(KPLNST) =         2
      PPLINC(KPLNST) =      STEP
      NPEN = NPEN + 1
      IF(NPEN.EQ.7) NPEN = 2
      BASE = BASE - OFFST
2510  CONTINUE
C-
C-  PROFILE PARAMETERS
C-
C-  REPEAT FOR EACH PHASE
2600  IF(KHCPLT(6).EQ.0) GO TO 2900
      NPEN = 2
      DO 2610 IPHASE=1,NPHASE
C-
C-  FWHM
      IF( NPSF(2,IPHASE).EQ.1 .OR. NPSF(2,IPHASE).EQ.3 ) THEN
        NREP = 2
       ELSE
        NREP = 1
      ENDIF
      DO 2620 NHALF=1,NREP
      KPLNST = KPLNST + 1
      IF( NREP.EQ.1 ) THEN
        QPLTTL(KPLNST) = 'Hk:'//QPHSNM(IPHASE)(1:17)
       ELSE
        IF(NHALF.EQ.1) QPLTTL(KPLNST) = 'Hk-L:'//QPHSNM(IPHASE)(1:15)
        IF(NHALF.EQ.2) QPLTTL(KPLNST) = 'Hk-H:'//QPHSNM(IPHASE)(1:15)
      ENDIF
      WRITE(IOTTO,2630) IPHASE,QPLTTL(KPLNST)
2630  FORMAT('  FWHM values for phase ',I2,'  Id=',A20)
      NPLSET(KPLNST) =    KPLNST
      KPLCOD(KPLNST) = KHCPLT(6)
      PPLOFF(KPLNST) =       0.0
      KPLPEN(KPLNST) =      NPEN
      KPLMRK(KPLNST) =         1
      PPLINC(KPLNST) =      STEP
2620  CONTINUE
C-
C-  PSEUDO-VOIGT MIXING AND PEARSON VII EXPONENT PARAMETERS
      IF(NPSF(1,IPHASE).LT.2) GO TO 2610
      IF( NPSF(2,IPHASE).EQ.2 .OR. NPSF(2,IPHASE).EQ.3 ) THEN
        NREP = 2
       ELSE
        NREP = 1
      ENDIF
      DO 2640 NHALF=1,NREP
      KPLNST = KPLNST + 1
      IF( NREP.EQ.1 ) THEN
        IF(NPSF(1,IPHASE).EQ.3) THEN
          QPLTTL(KPLNST) = 'P7 m:'//QPHSNM(IPHASE)(1:15)
          WRITE(IOTTO,2650) 'Pearson VII ',IPHASE,QPLTTL(KPLNST)
         ELSE
          QPLTTL(KPLNST) = 'pV m:'//QPHSNM(IPHASE)(1:15)
          WRITE(IOTTO,2650) 'Pseudo-Voigt',IPHASE,QPLTTL(KPLNST)
        ENDIF
       ELSE
        IF(NPSF(1,IPHASE).EQ.3) THEN
          QPLTTL(KPLNST) = 'P7 m- :'//QPHSNM(IPHASE)(1:13)
          IF(NHALF.EQ.1) QPLTTL(KPLNST)(6:6) = 'L'
          IF(NHALF.EQ.2) QPLTTL(KPLNST)(6:6) = 'H'
          WRITE(IOTTO,2650) 'Pearson VII ',IPHASE,QPLTTL(KPLNST)
         ELSE
          QPLTTL(KPLNST) = 'pV m- :'//QPHSNM(IPHASE)(1:13)
          IF(NHALF.EQ.1) QPLTTL(KPLNST)(6:6) = 'L'
          IF(NHALF.EQ.2) QPLTTL(KPLNST)(6:6) = 'H'
          WRITE(IOTTO,2650) 'Pseudo-Voigt',IPHASE,QPLTTL(KPLNST)
        ENDIF
      ENDIF
2650  FORMAT('  Profile parameter ',A12,' for phase ',I2,'  Id=',A20)
      NPLSET(KPLNST) =    KPLNST
      KPLCOD(KPLNST) = KHCPLT(6)
      PPLOFF(KPLNST) =       0.0
      KPLPEN(KPLNST) =      NPEN
      KPLMRK(KPLNST) =         1
      PPLINC(KPLNST) =      STEP
2640  CONTINUE
C-
2690  NPEN = NPEN + 1
      IF(NPEN.EQ.7) NPEN = 2
2610  CONTINUE
C-
C-  SET THE AXIS CONSTANTS
C-
2900  PPLSCA =   1.0
      KPLAXN =     1
      KPLAXD =     1
      KPLXID =     1
      PPLXOR =   0.0
      PPLXLN =   8.0
      PPLXST = THMIN
      PPLXEN = THMAX
      PPLXDV = ANINT( (PPLXEN-PPLXST) / PPLXLN )
      KPLYID =     1
      PPLYOR =   0.0
      PPLYLN =   5.0
      PPLYST =   0.0
      PPLYEN =    FS
      PPLYDV = ANINT( (PPLYEN-PPLYST) / PPLYLN )
C-
C--  WRITE THE PLOT FILE DATA
C-
C-  WRITE THE FILE HEADER
3000  CALL DATE( QPLFHD(61:69) )
      CALL TIME( QPLFHD(71:78) )
      IF(IPLTYP.EQ.0) THEN
        QPLFHD(22:33) = 'Unformatted.'
        WRITE(IOPLT) QPLFHD
        WRITE(IOPLT) QTITLE
        WRITE(IOPLT) PPLSCA,KPLAXN,KPLAXD
        WRITE(IOPLT) KPLXID,PPLXOR,PPLXLN,PPLXST,PPLXEN,PPLXDV
        WRITE(IOPLT) KPLYID,PPLYOR,PPLYLN,PPLYST,PPLYEN,PPLYDV
        WRITE(IOPLT) KPLNST
        DO 3010 I=1,KPLNST
        WRITE(IOPLT) QPLTTL(I),KPLCOD(I),PPLOFF(I),KPLPEN(I),KPLMRK(I),
     1   PPLINC(I)
3010    CONTINUE
       ELSE
        QPLFHD(22:33) = 'Formatted.  '
        WRITE(IOPLT,3020) QPLFHD
3020    FORMAT(A78)
        WRITE(IOPLT,3022) QTITLE
3022    FORMAT(A80)
        WRITE(IOPLT,3030) PPLSCA,KPLAXN,KPLAXD
3030    FORMAT(F9.2,2I9)
        WRITE(IOPLT,3040) KPLXID,PPLXOR,PPLXLN,PPLXST,PPLXEN,PPLXDV
        WRITE(IOPLT,3040) KPLYID,PPLYOR,PPLYLN,PPLYST,PPLYEN,PPLYDV
3040    FORMAT(I9,5F9.2)
        WRITE(IOPLT,3042) KPLNST
3042    FORMAT(I9)
        DO 3050 I=1,KPLNST
        WRITE(IOPLT,3060) QPLTTL(I),KPLCOD(I),PPLOFF(I),KPLPEN(I),
     1  KPLMRK(I),PPLINC(I)
3060    FORMAT(A20,I9,F9.2,2I9,F9.4)
3050    CONTINUE
      ENDIF
C-
C-  WRITE THE OBSERVED PATTERN
C-
C-  RESET POINTER
C-
4000  KPLNST = 0
C-
4100  IF(KHCPLT(1).EQ.0) GO TO 4200
      KPLNST = KPLNST + 1
      IF(IPLTYP.EQ.0) THEN
        WRITE(IOPLT) NPLSET(KPLNST),KPPTS,THMIN
        CALL URECO( YOBS, CTIME, 1, KPPTS )
       ELSE
        WRITE(IOPLT,4110) NPLSET(KPLNST),KPPTS,THMIN
4110    FORMAT(2I6,F10.4)
        WRITE(IOPLT,4120) (YOBS(I)/CTIME,I=1,KPPTS)
4120    FORMAT(10F8.1)
      ENDIF
C-
C-  WRITE THE CALCULATED PATTERN
C-
4200  IF(KHCPLT(2).EQ.0) GO TO 4300
      KPLNST = KPLNST + 1
      IF(IPLTYP.EQ.0) THEN
        WRITE(IOPLT) NPLSET(KPLNST),KPPTS,THMIN
        CALL URECO( CLCPAT, CTIME, 1, KPPTS )
       ELSE
        WRITE(IOPLT,4110) NPLSET(KPLNST),KPPTS,THMIN
        WRITE(IOPLT,4120) (CLCPAT(I)/CTIME,I=1,KPPTS)
      ENDIF
C-
C-  WRITE THE BACKGROUND
C-
4300  IF(KHCPLT(3).EQ.0) GO TO 4400
      KPLNST = KPLNST + 1
      IF(IPLTYP.EQ.0) THEN
        WRITE(IOPLT) NPLSET(KPLNST),KPPTS,THMIN
        CALL URECO( YBKG, CTIME, 1, KPPTS )
       ELSE
        WRITE(IOPLT,4110) NPLSET(KPLNST),KPPTS,THMIN
        WRITE(IOPLT,4120) (YBKG(I)/CTIME,I=1,KPPTS)
      ENDIF
C-
C-  WRITE THE DIFFERENCE PATTERN
C-
4400  IF(KHCPLT(4).EQ.0) GO TO 4500
      KPLNST = KPLNST + 1
      DO 4410 I=1,KPPTS
4410  DIFFP(I) = CLCPAT(I) - YOBS(I)
      DO 4420 J=1,NEXCRG
      IF(PEXCHI(J).LT.THMIN) GO TO 4420
      IF(PEXCLO(J).GT.THMAX) GO TO 4420
      IN1 = (PEXCLO(J)-THMIN)/STEP + 1.5
      IN1 = MAX0( IN1, 1 )
      IN2 = (PEXCHI(J)-THMIN)/STEP + 1.5
      IN2 = MIN0( IN2, KPPTS )
      DO 4430 I=IN1,IN2
4430  DIFFP(I) = 0.0
4420  CONTINUE
      IF(IPLTYP.EQ.0) THEN
        WRITE(IOPLT) NPLSET(KPLNST),KPPTS,THMIN
        CALL URECO( DIFFP, CTIME, 1, KPPTS )
       ELSE
        WRITE(IOPLT,4110) NPLSET(KPLNST),KPPTS,THMIN
        WRITE(IOPLT,4120) (DIFFP(I)/CTIME,I=1,KPPTS)
      ENDIF
C-
C-  WRITE THE REFLECTION MARKERS
C-
4500  IF(KHCPLT(5).EQ.0) GO TO 4600
C-
      IRTOT = 0
      DO 4510 IPHASE=1,NPHASE
4510  IRTOT = IRTOT + KREFNM(IPHASE)
C-
C-  REPEAT FOR EACH PHASE IN THE PATTERN
      DO 4520 IPHASE=1,NPHASE
C-
C-  WRITE THE DATA SET HEADER FOR THE PHASE MARKERS
      KPLNST = KPLNST + 1
      IF(IPLTYP.EQ.0) THEN
        WRITE(IOPLT) NPLSET(KPLNST),KREFNM(IPHASE),THMIN
       ELSE
        WRITE(IOPLT,4110) NPLSET(KPLNST),KREFNM(IPHASE),THMIN
      ENDIF
C-
C-  REPEAT FOR EACH REFLECTION
      DO 4530 IORDC=1,IRTOT
      IPHRI = KREFDT(IORDC)/67108864
      IF(IPHASE.NE.IPHRI) GO TO 4530
      IWAVE = MOD( KREFDT(IORDC)/256/256/256, 4 )
      ANGLE = RADWAV(1) / 2.0 / SIN( PREFTT(IORDC)*DTORD2 )
      HGT   = PREFPK(IORDC)/CTIME
C-
C-  WRITE THE MARKERS
      IF(IPLTYP.EQ.0) THEN
        WRITE(IOPLT) PREFTT(IORDC),HGT,PREFTT(IORDC),ANGLE,IWAVE
       ELSE
        WRITE(IOPLT,4540) PREFTT(IORDC),HGT,PREFTT(IORDC),ANGLE,IWAVE
4540    FORMAT(4F10.4,I2)
      ENDIF
C-
C-  NEXT REFLECTION
4530  CONTINUE
C-
C-  NEXT PHASE
4520  CONTINUE
C-
C-  WRITE THE PROFILE PARAMETERS FOR THE PHASES
C-
4600  IF(KHCPLT(6).EQ.0) GO TO 8000
C-
C-  REPEAT FOR EACH PHASE IN THE PATTERN
      DO 4610 IPHASE=1,NPHASE
C-
C-  FWHM VALUES
C-
C-  REPEAT IF A SPLIT PROFILE WAS USED
      IF( NPSF(2,IPHASE).EQ.1 .OR. NPSF(2,IPHASE).EQ.3 ) THEN
        NREP = 2
       ELSE
        NREP = 1
      ENDIF
      DO 4620 NHALF=1,NREP
C-
C-  GENERATE 100 POINTS
      DELTA = (THMAX-THMIN)/99.0
      DO 4630 I=1,100
      TTHT   = THMIN + REAL(I-1)*DELTA
      TANTHT = TAN( DTORD2 * TTHT )
      XVAL(I) = TTHT
      FWHM2   = PPHUVW(1,NHALF,IPHASE)*TANTHT**2
     1        + PPHUVW(2,NHALF,IPHASE)*TANTHT
     1        + PPHUVW(3,NHALF,IPHASE)
      IF(FWHM2.GT.0.0) THEN
        YVAL(I) = SQRT( FWHM2 )
       ELSE
        YVAL(I) = 0.0
      ENDIF
4630  CONTINUE
C-
C-  WRITE THE POINTS
      KPLNST = KPLNST + 1
      IF(IPLTYP.EQ.0) THEN
        WRITE(IOPLT) NPLSET(KPLNST),100,THMIN
        DO 4632 J=1,100
4632    WRITE(IOPLT) XVAL(J),YVAL(J)
       ELSE
        WRITE(IOPLT,4110) NPLSET(KPLNST),100,THMIN
        WRITE(IOPLT,4640) (XVAL(J),YVAL(J),J=1,100)
4640    FORMAT(2F10.4)
      ENDIF
C-
C-  NEXT SIDE OF PROFILE
4620  CONTINUE
C-
C-  PSEUDO-VOIGT MIXING AND PEARSON VII EXPONENT PARAMETERS
C-
      IF(NPSF(1,IPHASE).LT.2) GO TO 4610
C-
C-  REPEAT IF A SPLIT PROFILE WAS USED
      IF( NPSF(2,IPHASE).EQ.2 .OR. NPSF(2,IPHASE).EQ.3 ) THEN
        NREP = 2
       ELSE
        NREP = 1
      ENDIF
      DO 4650 NHALF=1,NREP
C-
C-  GENERATE 100 POINTS
      DELTA = (THMAX-THMIN)/99.0
      DO 4660 I=1,100
      TTHT   = THMIN + REAL(I-1)*DELTA
      XVAL(I) = TTHT
      YVAL(I) = PPHPSF(1,NHALF,IPHASE)
     1        + PPHPSF(2,NHALF,IPHASE)*TTHT
     1        + PPHPSF(3,NHALF,IPHASE)*TTHT**2
4660  CONTINUE
C-
C-  WRITE THE POINTS
      KPLNST = KPLNST + 1
      IF(IPLTYP.EQ.0) THEN
        WRITE(IOPLT) NPLSET(KPLNST),100,THMIN
        DO 4662 J=1,100
4662    WRITE(IOPLT) XVAL(J),YVAL(J)
       ELSE
        WRITE(IOPLT,4110) NPLSET(KPLNST),100,THMIN
        WRITE(IOPLT,4640) (XVAL(J),YVAL(J),J=1,100)
      ENDIF
C-
C-  NEXT SIDE OF PROFILE
4650  CONTINUE
C-
C-  NEXT PHASE
4610  CONTINUE
C-
C--  CLOSE THE PLOT FILE
C-
8000  CLOSE(UNIT=IOPLT)
C-
9000  RETURN
      END
C ***  URECO - WRITE UNFORMATTED RECORD IN SHADOW FORMAT
C *
      SUBROUTINE URECO( ARRAY, SCALE, NBEG, NEND )
C *
      INCLUDE 'RIETCOM.FOR'
C *
      DIMENSION FILL(10),ARRAY(NEND)
      DATA FILL / 10 * 0.0 /
C *
      NPTS = NEND - NBEG + 1
      NREC = NPTS / 10
      NREM = NPTS - ( NREC * 10 )
      NFIL = 10 - NREM
C *
      NTRK = NBEG - 1
      DO 1002 I=1,NREC
      WRITE(IOPLT) ( ARRAY(J)/SCALE,J=(NTRK+1),(NTRK+10) )
      NTRK = NTRK + 10
1002  CONTINUE
C *
      IF(NREM.GT.0) THEN
        WRITE(IOPLT) ( ARRAY(J)/SCALE,J=(NTRK+1),(NTRK+NREM) ),
     1               ( FILL (J)      ,J=(     1),(NFIL     ) )
      ENDIF
C *
      RETURN
      END
      SUBROUTINE GAMLIM(XMIN,XMAX)
C***BEGIN PROLOGUE  GAMLIM
C***DATE WRITTEN   770401   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  C7A,R2
C***KEYWORDS  GAMMA FUNCTION,LIMITS,SPECIAL FUNCTION
C***AUTHOR  FULLERTON, W., (LANL)
C***PURPOSE  Computes the minimum and maximum bounds for X in GAMMA(X).
C***DESCRIPTION
C
C Calculate the minimum and maximum legal bounds for X in GAMMA(X).
C XMIN and XMAX are not the only bounds, but they are the only non-
C trivial ones to calculate.
C
C             Output Arguments --
C XMIN   minimum legal value of X in GAMMA(X).  Any smaller value of
C        X might result in underflow.
C XMAX   maximum legal value of X in GAMMA(X).  Any larger value will
C        cause overflow.
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH,XERROR
C***END PROLOGUE  GAMLIM
C***FIRST EXECUTABLE STATEMENT  GAMLIM
      ALNSML = ALOG(R1MACH(1))
      XMIN = -ALNSML
      DO 10 I=1,10
        XOLD = XMIN
        XLN = ALOG(XMIN)
        XMIN = XMIN - XMIN*((XMIN+0.5)*XLN - XMIN - 0.2258 + ALNSML)
     1    / (XMIN*XLN + 0.5)
        IF (ABS(XMIN-XOLD).LT.0.005) GO TO 20
10    CONTINUE
      CALL XERROR ( 'GAMLIM  UNABLE TO FIND XMIN', 27, 1, 2)
C
20    XMIN = -XMIN + 0.01
C
      ALNBIG = ALOG(R1MACH(2))
      XMAX = ALNBIG
      DO 30 I=1,10
        XOLD = XMAX
        XLN = ALOG(XMAX)
        XMAX = XMAX - XMAX*((XMAX-0.5)*XLN - XMAX + 0.9189 - ALNBIG)
     1    / (XMAX*XLN - 0.5)
        IF (ABS(XMAX-XOLD).LT.0.005) GO TO 40
30    CONTINUE
      CALL XERROR ( 'GAMLIM  UNABLE TO FIND XMAX', 27, 2, 2)
C
40    XMAX = XMAX - 0.01
      XMIN = AMAX1 (XMIN, -XMAX+1.)
C
      RETURN
      END
      FUNCTION INITS(OS,NOS,ETA)
C***BEGIN PROLOGUE  INITS
C***DATE WRITTEN   770401   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  C3A2
C***KEYWORDS  INITIALIZE,ORTHOGONAL SERIES,SPECIAL FUNCTION
C***AUTHOR  FULLERTON, W., (LANL)
C***PURPOSE  Initializes an orthogonal series so that it defines the
C            number of terms to carry in the series to meet a specified
C            error.
C***DESCRIPTION
C
C Initialize the orthogonal series so that INITS is the number of terms
C needed to insure the error is no larger than ETA.  Ordinarily, ETA
C will be chosen to be one-tenth machine precision.
C
C             Input Arguments --
C OS     array of NOS coefficients in an orthogonal series.
C NOS    number of coefficients in OS.
C ETA    requested accuracy of series.
C***REFERENCES  (NONE)
C***ROUTINES CALLED  XERROR
C***END PROLOGUE  INITS
      DIMENSION OS(NOS)
C***FIRST EXECUTABLE STATEMENT  INITS
      IF (NOS.LT.1) CALL XERROR ( 'INITS   NUMBER OF COEFFICIENTS LT 1',
     1 35, 2, 2)
C
      ERR = 0.
      DO 10 II=1,NOS
        I = NOS + 1 - II
        ERR = ERR + ABS(OS(I))
        IF (ERR.GT.ETA) GO TO 20
10    CONTINUE
C
20    IF (I.EQ.NOS) CALL XERROR ( 'INITS   ETA MAY BE TOO SMALL', 28,
     1  1, 2)
      INITS = I
C
      RETURN
      END
      FUNCTION R9LGMC(X)
C***BEGIN PROLOGUE  R9LGMC
C***DATE WRITTEN   770801   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  C7E
C***KEYWORDS  CORRECTION FACTOR,LOG GAMMA,SPECIAL FUNCTION
C***AUTHOR  FULLERTON, W., (LANL)
C***PURPOSE  Computes the log Gamma correction factor so that
C            ALOG(GAMMA(X)) = ALOG(SQRT(2*PI)) + (X-.5)*ALOG(X) - X
C            + R9LGMC(X)
C***DESCRIPTION
C
C Compute the log gamma correction factor for X .GE. 10.0 so that
C  ALOG (GAMMA(X)) = ALOG(SQRT(2*PI)) + (X-.5)*ALOG(X) - X + R9LGMC(X)
C
C Series for ALGM       on the interval  0.          to  1.00000D-02
C                                        with weighted error   3.40E-16
C                                         log weighted error  15.47
C                               significant figures required  14.39
C                                    decimal places required  15.86
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL,INITS,R1MACH,XERROR
C***END PROLOGUE  R9LGMC
      DIMENSION ALGMCS(6)
      DATA ALGMCS( 1) /    .1666389480 45186E0 /
      DATA ALGMCS( 2) /   -.0000138494 817606E0 /
      DATA ALGMCS( 3) /    .0000000098 108256E0 /
      DATA ALGMCS( 4) /   -.0000000000 180912E0 /
      DATA ALGMCS( 5) /    .0000000000 000622E0 /
      DATA ALGMCS( 6) /   -.0000000000 000003E0 /
      DATA NALGM, XBIG, XMAX / 0, 2*0.0 /
C***FIRST EXECUTABLE STATEMENT  R9LGMC
      IF (NALGM.NE.0) GO TO 10
      NALGM = INITS (ALGMCS, 6, R1MACH(3))
      XBIG = 1.0/SQRT(R1MACH(3))
      XMAX = EXP (AMIN1(ALOG(R1MACH(2)/12.0), -ALOG(12.0*R1MACH(1))) )
C
10    IF (X.LT.10.0) CALL XERROR ( 'R9LGMC  X MUST BE GE 10', 23, 1, 2)
      IF (X.GE.XMAX) GO TO 20
C
      R9LGMC = 1.0/(12.0*X)
      IF (X.LT.XBIG) R9LGMC = CSEVL (2.0*(10./X)**2-1., ALGMCS, NALGM)/X
      RETURN
C
20    R9LGMC = 0.0
      CALL XERROR ( 'R9LGMC  X SO BIG R9LGMC UNDERFLOWS', 34, 2, 1)
      RETURN
C
      END
      FUNCTION CSEVL(X,CS,N)
C***BEGIN PROLOGUE  CSEVL
C***DATE WRITTEN   770401   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  C3A2
C***KEYWORDS  CHEBYSHEV,FNLIB,SPECIAL FUNCTION
C***AUTHOR  FULLERTON, W., (LANL)
C***PURPOSE  Evaluate the N-term Chebyshev series CS at X.
C***DESCRIPTION
C
C Evaluate the N-term Chebyshev series CS at X.  Adapted from
C R. Broucke, Algorithm 446, C.A.C.M., 16, 254 (1973). Also see Fox
C and Parker, Chebyshev Polynomials in Numerical Analysis, Oxford Press,
C page 56.
C
C       Input Arguments --
C X    value at which the series is to be evaluated.
C CS   array of N terms of a Chebyshev series.  In eval-
C      uating CS, only half the first coefficient is summed.
C N    number of terms in array CS.
C***REFERENCES  (NONE)
C***ROUTINES CALLED  XERROR
C***END PROLOGUE  CSEVL
C
       DIMENSION CS(1)
C***FIRST EXECUTABLE STATEMENT  CSEVL
       IF(N.LT.1) CALL XERROR( 'CSEVL   NUMBER OF TERMS LE 0', 28, 2,2)
       IF(N.GT.1000) CALL XERROR ( 'CSEVL   NUMBER OF TERMS GT 1000',
     1   31,3,2)
       IF (X.LT. -1.0 .OR. X.GT. 1.0) CALL XERROR( 'CSEVL   X OUTSIDE (-
     11,+1)', 25, 1, 1)
C
       B1=0.
       B0=0.
       TWOX=2.*X
       DO 10 I=1,N
       B2=B1
       B1=B0
       NI=N+1-I
       B0=TWOX*B1-B2+CS(NI)
10     CONTINUE
C
       CSEVL = 0.5 * (B0-B2)
C
       RETURN
      END
      REAL FUNCTION R1MACH(I)
C***BEGIN PROLOGUE  R1MACH
C***DATE WRITTEN   790101   (YYMMDD)
C***REVISION DATE  831014   (YYMMDD)
C***CATEGORY NO.  R1
C***KEYWORDS  MACHINE CONSTANTS
C***AUTHOR  FOX, P. A., (BELL LABS)
C           HALL, A. D., (BELL LABS)
C           SCHRYER, N. L., (BELL LABS)
C***PURPOSE  Returns single precision machine dependent constants
C***DESCRIPTION
C
C     R1MACH can be used to obtain machine-dependent parameters
C     for the local machine environment.  It is a function
C     subroutine with one (input) argument, and can be called
C     as follows, for example
C
C          A = R1MACH(I)
C
C     where I=1,...,5.  The (output) value of A above is
C     determined by the (input) value of I.  The results for
C     various values of I are discussed below.
C
C  Single-Precision Machine Constants
C  R1MACH(1) = B**(EMIN-1), the smallest positive magnitude.
C  R1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
C  R1MACH(3) = B**(-T), the smallest relative spacing.
C  R1MACH(4) = B**(1-T), the largest relative spacing.
C  R1MACH(5) = LOG10(B)
C***REFERENCES  FOX, P.A., HALL, A.D., SCHRYER, N.L, *FRAMEWORK FOR
C                 A PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHE-
C                 MATICAL SOFTWARE, VOL. 4, NO. 2, JUNE 1978,
C                 PP. 177-188.
C***ROUTINES CALLED  XERROR
C***END PROLOGUE  R1MACH
C
      INTEGER SMALL(2)
      INTEGER LARGE(2)
      INTEGER RIGHT(2)
      INTEGER DIVER(2)
      INTEGER LOG10(2)
C
      REAL RMACH(5)
C
      EQUIVALENCE (RMACH(1),SMALL(1))
      EQUIVALENCE (RMACH(2),LARGE(1))
      EQUIVALENCE (RMACH(3),RIGHT(1))
      EQUIVALENCE (RMACH(4),DIVER(1))
      EQUIVALENCE (RMACH(5),LOG10(1))
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
C
C     DATA RMACH(1) / Z400800000 /
C     DATA RMACH(2) / Z5FFFFFFFF /
C     DATA RMACH(3) / Z4E9800000 /
C     DATA RMACH(4) / Z4EA800000 /
C     DATA RMACH(5) / Z500E730E8 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS.
C
C     DATA RMACH(1) / O1771000000000000 /
C     DATA RMACH(2) / O0777777777777777 /
C     DATA RMACH(3) / O1311000000000000 /
C     DATA RMACH(4) / O1301000000000000 /
C     DATA RMACH(5) / O1157163034761675 /
C
C     MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES.
C
C     DATA RMACH(1) / 00564000000000000000B /
C     DATA RMACH(2) / 37767777777777777776B /
C     DATA RMACH(3) / 16414000000000000000B /
C     DATA RMACH(4) / 16424000000000000000B /
C     DATA RMACH(5) / 17164642023241175720B /
C
C     MACHINE CONSTANTS FOR THE CRAY 1
C
C     DATA RMACH(1) / 200034000000000000000B /
C     DATA RMACH(2) / 577767777777777777776B /
C     DATA RMACH(3) / 377224000000000000000B /
C     DATA RMACH(4) / 377234000000000000000B /
C     DATA RMACH(5) / 377774642023241175720B /
C
C     MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
C
C     NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD -
C     STATIC RMACH(5)
C
C     DATA SMALL/20K,0/,LARGE/77777K,177777K/
C     DATA RIGHT/35420K,0/,DIVER/36020K,0/
C     DATA LOG10/40423K,42023K/
C
C     MACHINE CONSTANTS FOR THE HARRIS 220
C
C     DATA SMALL(1),SMALL(2) / '20000000, '00000201 /
C     DATA LARGE(1),LARGE(2) / '37777777, '00000177 /
C     DATA RIGHT(1),RIGHT(2) / '20000000, '00000352 /
C     DATA DIVER(1),DIVER(2) / '20000000, '00000353 /
C     DATA LOG10(1),LOG10(2) / '23210115, '00000377 /
C
C     MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES.
C
C     DATA RMACH(1) / O402400000000 /
C     DATA RMACH(2) / O376777777777 /
C     DATA RMACH(3) / O714400000000 /
C     DATA RMACH(4) / O716400000000 /
C     DATA RMACH(5) / O776464202324 /
C
C     MACHINE CONSTANTS FOR THE HP 2100
C
C     3 WORD DOUBLE PRECISION WITH FTN4
C
C     DATA SMALL(1), SMALL(2) / 40000B,       1 /
C     DATA LARGE(1), LARGE(2) / 77777B, 177776B /
C     DATA RIGHT(1), RIGHT(2) / 40000B,    325B /
C     DATA DIVER(1), DIVER(2) / 40000B,    327B /
C     DATA LOG10(1), LOG10(2) / 46420B,  46777B /
C
C     MACHINE CONSTANTS FOR THE HP 2100
C     4 WORD DOUBLE PRECISION WITH FTN4
C
C     DATA SMALL(1), SMALL(2) / 40000B,       1 /
C     DATA LARGE91), LARGE(2) / 77777B, 177776B /
C     DATA RIGHT(1), RIGHT(2) / 40000B,    325B /
C     DATA DIVER(1), DIVER(2) / 40000B,    327B /
C     DATA LOG10(1), LOG10(2) / 46420B,  46777B /
C
C     MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
C     THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86  AND
C     THE PERKIN ELMER (INTERDATA) 7/32.
C
C     DATA RMACH(1) / Z00100000 /
C     DATA RMACH(2) / Z7FFFFFFF /
C     DATA RMACH(3) / Z3B100000 /
C     DATA RMACH(4) / Z3C100000 /
C     DATA RMACH(5) / Z41134413 /
C
C     MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR).
C
C     DATA RMACH(1) / "000400000000 /
C     DATA RMACH(2) / "377777777777 /
C     DATA RMACH(3) / "146400000000 /
C     DATA RMACH(4) / "147400000000 /
C     DATA RMACH(5) / "177464202324 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
C     32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
C
C     DATA SMALL(1) /    8388608 /
C     DATA LARGE(1) / 2147483647 /
C     DATA RIGHT(1) /  880803840 /
C     DATA DIVER(1) /  889192448 /
C     DATA LOG10(1) / 1067065499 /
C
C     DATA RMACH(1) / O00040000000 /
C     DATA RMACH(2) / O17777777777 /
C     DATA RMACH(3) / O06440000000 /
C     DATA RMACH(4) / O06500000000 /
C     DATA RMACH(5) / O07746420233 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
C     16-BIT INTEGERS  (EXPRESSED IN INTEGER AND OCTAL).
C
C     DATA SMALL(1),SMALL(2) /   128,     0 /
C     DATA LARGE(1),LARGE(2) / 32767,    -1 /
C     DATA RIGHT(1),RIGHT(2) / 13440,     0 /
C     DATA DIVER(1),DIVER(2) / 13568,     0 /
C     DATA LOG10(1),LOG10(2) / 16282,  8347 /
C
C     DATA SMALL(1),SMALL(2) / O000200, O000000 /
C     DATA LARGE(1),LARGE(2) / O077777, O177777 /
C     DATA RIGHT(1),RIGHT(2) / O032200, O000000 /
C     DATA DIVER(1),DIVER(2) / O032400, O000000 /
C     DATA LOG10(1),LOG10(2) / O037632, O020233 /
C
C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C
C     DATA RMACH(1) / O000400000000 /
C     DATA RMACH(2) / O377777777777 /
C     DATA RMACH(3) / O146400000000 /
C     DATA RMACH(4) / O147400000000 /
C     DATA RMACH(5) / O177464202324 /
C
C     MACHINE CONSTANTS FOR THE VAX 11/780
C    (EXPRESSED IN INTEGER AND HEXADECIMAL)
C  ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS***
C  *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS***
C
      DATA SMALL(1) /       128 /
      DATA LARGE(1) /    -32769 /
      DATA RIGHT(1) /     13440 /
      DATA DIVER(1) /     13568 /
      DATA LOG10(1) / 547045274 /
C
C     DATA SMALL(1) / Z00000080 /
C     DATA LARGE(1) / ZFFFF7FFF /
C     DATA RIGHT(1) / Z00003480 /
C     DATA DIVER(1) / Z00003500 /
C     DATA LOG10(1) / Z209B3F9A /
C
C     MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR
C
C     DATA SMALL(1),SMALL(2) /     0,    256/
C     DATA LARGE(1),LARGE(2) /    -1,   -129/
C     DATA RIGHT(1),RIGHT(2) /     0,  26880/
C     DATA DIVER(1),DIVER(2) /     0,  27136/
C     DATA LOG10(1),LOG10(2) /  8347,  32538/
C
C
C***FIRST EXECUTABLE STATEMENT  R1MACH
      IF (I .LT. 1  .OR.  I .GT. 5)
     1   CALL XERROR ( 'R1MACH -- I OUT OF BOUNDS',25,1,2)
C
      R1MACH = RMACH(I)
      RETURN
C
      END
      SUBROUTINE XERROR(MESSG,NMESSG,NERR,LEVEL)
C***BEGIN PROLOGUE  XERROR
C***DATE WRITTEN   790801   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  R3C
C***KEYWORDS  ERROR,XERROR PACKAGE
C***AUTHOR  JONES, R. E., (SNLA)
C***PURPOSE  Processes an error (diagnostic) message
C***DESCRIPTION
C
C     Abstract
C        XERROR processes a diagnostic message, in a manner
C        determined by the value of LEVEL and the current value
C        of the library error control flag, KONTRL.
C        (See subroutine XSETF for details.)
C
C     Description of Parameters
C      --Input--
C        MESSG - the Hollerith message to be processed, containing
C                no more than 72 characters.
C        NMESSG- the actual number of characters in MESSG.
C        NERR  - the error number associated with this message.
C                NERR must not be zero.
C        LEVEL - error category.
C                =2 means this is an unconditionally fatal error.
C                =1 means this is a recoverable error.  (I.e., it is
C                   non-fatal if XSETF has been appropriately called.)
C                =0 means this is a warning message only.
C                =-1 means this is a warning message which is to be
C                   printed at most once, regardless of how many
C                   times this call is executed.
C
C     Examples
C        CALL XERROR(23HSMOOTH -- NUM WAS ZERO.,23,1,2)
C        CALL XERROR(43HINTEG  -- LESS THAN FULL ACCURACY ACHIEVED.,
C                    43,2,1)
C        CALL XERROR(65HROOTER -- ACTUAL ZERO OF F FOUND BEFORE INTERVAL
C    1 FULLY COLLAPSED.,65,3,0)
C        CALL XERROR(39HEXP    -- UNDERFLOWS BEING SET TO ZERO.,39,1,-1)
C
C     Written by Ron Jones, with SLATEC Common Math Library Subcommittee
C     Latest revision ---  7 Feb 1979
C***REFERENCES  JONES R.E., *SLATEC COMMON MATHEMATICAL LIBRARY ERROR
C                 HANDLING PACKAGE*, SAND78-1189, SANDIA LABORATORIES,
C                 1978.
C***ROUTINES CALLED  XERRWV
C***END PROLOGUE  XERROR
C
C     DIMENSION MESSG(NMESSG)
C***FIRST EXECUTABLE STATEMENT  XERROR
C     CALL XERRWV(MESSG,NMESSG,NERR,LEVEL,0,0,0,0,0.,0.)
C     RETURN
C     END
C *
C *  MODIFIED S.A.HOWARD, XERRWV WAS NOT OBTAINED FROM LANL THEREFORE
C *  THIS SUBROUTINE WAS KLUDGED.  THIS VERSION WILL PRINT THE MESSAGE
C *  AND ACT BASED ON THE FLAG *LEVEL*.  IF LEVEL=2 EXECUTION IS HALTED.
C *
      CHARACTER MESSG(NMESSG)
      WRITE(6,1) LEVEL,NERR,(MESSG(I),I=1,NMESSG)
1     FORMAT(' -GAMMA FUNCTION ROUTINES: ERROR LEVEL ',I2,'  NUMBER ',
     1 I2,/,1X,72A1)
      IF(LEVEL.EQ.2) STOP'--GAMMA FUNCTION ROUTINES: ERROR LEVEL 2'
      RETURN
      END
      FUNCTION GAMMA(X)
C***BEGIN PROLOGUE  GAMMA
C***DATE WRITTEN   770601   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  C7A
C***KEYWORDS  GAMMA FUNCTION,SPECIAL FUNCTION
C***AUTHOR  FULLERTON, W., (LANL)
C***PURPOSE  Computes the Gamma function.
C***DESCRIPTION
C
C GAMMA computes the gamma function at X, where X is not 0, -1, -2, ....
C GAMMA and X are single precision.
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL,GAMLIM,INITS,R1MACH,R9LGMC,XERROR
C***END PROLOGUE  GAMMA
      DIMENSION GCS(23)
      DATA GCS   ( 1) / .0085711955 90989331E0/
      DATA GCS   ( 2) / .0044153813 24841007E0/
      DATA GCS   ( 3) / .0568504368 1599363E0/
      DATA GCS   ( 4) /-.0042198353 96418561E0/
      DATA GCS   ( 5) / .0013268081 81212460E0/
      DATA GCS   ( 6) /-.0001893024 529798880E0/
      DATA GCS   ( 7) / .0000360692 532744124E0/
      DATA GCS   ( 8) /-.0000060567 619044608E0/
      DATA GCS   ( 9) / .0000010558 295463022E0/
      DATA GCS   (10) /-.0000001811 967365542E0/
      DATA GCS   (11) / .0000000311 772496471E0/
      DATA GCS   (12) /-.0000000053 542196390E0/
      DATA GCS   (13) / .0000000009 193275519E0/
      DATA GCS   (14) /-.0000000001 577941280E0/
      DATA GCS   (15) / .0000000000 270798062E0/
      DATA GCS   (16) /-.0000000000 046468186E0/
      DATA GCS   (17) / .0000000000 007973350E0/
      DATA GCS   (18) /-.0000000000 001368078E0/
      DATA GCS   (19) / .0000000000 000234731E0/
      DATA GCS   (20) /-.0000000000 000040274E0/
      DATA GCS   (21) / .0000000000 000006910E0/
      DATA GCS   (22) /-.0000000000 000001185E0/
      DATA GCS   (23) / .0000000000 000000203E0/
      DATA PI /3.14159 26535 89793 24E0/
C SQ2PIL IS ALOG (SQRT (2.*PI) )
      DATA SQ2PIL /0.91893 85332 04672 74E0/
      DATA NGCS, XMIN, XMAX, DXREL /0, 3*0.0 /
C
C LANL DEPENDENT CODE REMOVED 81.02.04
C
C***FIRST EXECUTABLE STATEMENT  GAMMA
      IF (NGCS.NE.0) GO TO 10
C
C ---------------------------------------------------------------------
C INITIALIZE.  FIND LEGAL BOUNDS FOR X, AND DETERMINE THE NUMBER OF
C TERMS IN THE SERIES REQUIRED TO ATTAIN AN ACCURACY TEN TIMES BETTER
C THAN MACHINE PRECISION.
C
      NGCS = INITS (GCS, 23, 0.1*R1MACH(3))
C
      CALL GAMLIM (XMIN, XMAX)
      DXREL = SQRT (R1MACH(4))
C
C ---------------------------------------------------------------------
C FINISH INITIALIZATION.  START EVALUATING GAMMA(X).
C
10    Y = ABS(X)
      IF (Y.GT.10.0) GO TO 50
C
C COMPUTE GAMMA(X) FOR ABS(X) .LE. 10.0.  REDUCE INTERVAL AND
C FIND GAMMA(1+Y) FOR 0. .LE. Y .LT. 1. FIRST OF ALL.
C
      N = X
      IF (X.LT.0.) N = N - 1
      Y = X - FLOAT(N)
      N = N - 1
      GAMMA = 0.9375 + CSEVL(2.*Y-1., GCS, NGCS)
      IF (N.EQ.0) RETURN
C
      IF (N.GT.0) GO TO 30
C
C COMPUTE GAMMA(X) FOR X .LT. 1.
C
      N = -N
      IF (X.EQ.0.) CALL XERROR ( 'GAMMA   X IS 0', 14, 4, 2)
      IF (X.LT.0. .AND. X+FLOAT(N-2).EQ.0.) CALL XERROR (  'GAMMA   X IS
     1 A NEGATIVE INTEGER', 31, 4, 2)
      IF (X.LT.(-0.5) .AND. ABS((X-AINT(X-0.5))/X).LT.DXREL) CALL
     1  XERROR ( 'GAMMA   ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NE
     2GATIVE INTEGER', 68, 1, 1)
C
      DO 20 I=1,N
        GAMMA = GAMMA / (X+FLOAT(I-1))
20    CONTINUE
      RETURN
C
C GAMMA(X) FOR X .GE. 2.
C
30    DO 40 I=1,N
        GAMMA = (Y+FLOAT(I))*GAMMA
40    CONTINUE
      RETURN
C
C COMPUTE GAMMA(X) FOR ABS(X) .GT. 10.0.  RECALL Y = ABS(X).
C
50    IF (X.GT.XMAX) CALL XERROR ( 'GAMMA   X SO BIG GAMMA OVERFLOWS',
     1  32, 3, 2)
C
      GAMMA = 0.
      IF (X.LT.XMIN) CALL XERROR ( 'GAMMA   X SO SMALL GAMMA UNDERFLOWS'
     1  , 35, 2, 1)
      IF (X.LT.XMIN) RETURN
C
      GAMMA = EXP((Y-0.5)*ALOG(Y) - Y + SQ2PIL + R9LGMC(Y) )
      IF (X.GT.0.) RETURN
C
      IF (ABS((X-AINT(X-0.5))/X).LT.DXREL) CALL XERROR ( 'GAMMA   ANSWER
     1 LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER'  , 61, 1, 1)
C
      SINPIY = SIN (PI*Y)
      IF (SINPIY.EQ.0.) CALL XERROR ( 'GAMMA   X IS A NEGATIVE INTEGER',
     1 31, 4, 2)
C
      GAMMA = -PI / (Y*SINPIY*GAMMA)
C
      RETURN
      END

