C ***  PROGRAM: SHADOW  (SHADOW00) - PATTERN ANALYSIS PROGRAM
C ***  VERSION: 860822  (YYMMDD)
C *
C *  AUTHOR:  S. A. HOWARD
C *           DEPARTMENT OF CERAMIC ENGINEERING
C *           UNIVERISTY OF MISSOURI - ROLLA
C *           ROLLA, MO 65401  USA
C *           314-341-4403
C *
C ***  SHADOW - MAIN PROGRAM
C *
      CHARACTER QANS*1,QANS2*1,QDATE*9,QTIME*8,QFILE*32
      CHARACTER QPTFID*32,QWGTTL*72,QFTITL*80,QWGFID*32,QWGANS*1
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      PARAMETER ( MPTST2 = MPTS * 2 )
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201)
      COMMON /SCHDAT/ KNFND,PSIGMA,RELLOW,BIGINT,KNSMO,KFFLT,KFMNT
      COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3)
      COMMON /BKGDAT/ LDEG,CLY,CLC(6),BKGSDV,IBKCPS,IBKNBK
      COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2)
      COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /RFREGN/ KNUMRG,KNUMCU,REFREG(200,2)
      COMMON /WSGDAT/ KWSGLN,WSGPAR(200,12)
      COMMON /WGDATC/ QWGTTL,QWGFID,QWGANS
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /PEAKDT/ NPEAK,PEAKS(200,4)
      COMMON /WDATA/ NWAVE,WTABLE(5,2)
      COMMON /COMSCR/ JUNK(MPTST2)
      COMMON /PDATA/ BANG, EANG
      COMMON /DIAGS/ ISENSE(10)
      COMMON /FLDATC/ QFTITL
      COMMON /XXFILE/ QPTFID
C *
C *  VAX 11/780 ERROR HANDLING ROUTINES
      EXTERNAL HDLR
      CALL LIB$ESTABLISH( HDLR )
      I = LIB$SIM_TRAP( SIGARGS, MECHARGS )
C *
C *  IBM ERROR RECOVERY ROUTINE
CIBM  CALL ERRSET(207,256,2,2,1,209)
C *
C *  SAY HELLO
1000  CALL DATE( QDATE )
      CALL TIME( QTIME )
      WRITE(ITTO,1010) QDATE,QTIME(1:5)
1010  FORMAT('1*** SHADOW - Pattern analysis  V 860818',4X,A9,2X,A5)
      IF(KPTDEF.EQ.0) WRITE(ITTO,1012)
1012  FORMAT(/,' Default PLOT file type is UNFORMATTED. Use $file.ext',
     1' to write FORMATTED.')
      IF(KPTDEF.EQ.1) WRITE(ITTO,1014)
1014  FORMAT(/,' Default PLOT file type is FORMATTED. Use $file.ext',
     1' to write UNFORMATTED.')
      WRITE(ITTO,1016)
1016  FORMAT(/,' Program options are given in (), defaults given in <>.'
     1,/,' Use a / to get the defaults or if the program hangs on a',
     1' read.')
C *
C *  DETERMINE MODE TO OPERATE IN...
C *
C *  KMODEO = 0 - EXECUTE COMMANDS "INTERACTIVE"
C *  KMODEO = 1 - WRITE COMMAND EXECUTION FILE FOR "BATCH"
C *  KMODEO = 2 - EXECUTING IN "BATCH MODE"
C *  KMODEO = 9 - ALLOW DEBUG FLAGS TO BE SET
C *
      WRITE(ITTO,1020)
1020  FORMAT(/,' Execution mode: (I)nteractive or',
     1' (B)atch setup ? <I> ')
      READ(ITTI,1030) QANS,ISENSE
1030  FORMAT(A1,3X,10I1)
      KMODEO = 0
      IF( QANS.EQ.'B' .OR. QANS.EQ.'b' ) KMODEO = 1
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) KMODEO = 2
      IF( QANS.EQ.'9') KMODEO = 9
      IF(KMODEO.EQ.2) WRITE(ITTO,1025)
1025  FORMAT(/,' *  Execution mode is BATCH  *')
C *
C *  GET FILE NAME FOR BATCH SETUP
      IF(KMODEO.NE.1) GO TO 2000
      WRITE(ITTO,1035)
1035  FORMAT(/,' Name for batch command file ? ')
      READ(ITTI,1040) QFILE
1040  FORMAT(A32)
CVAX
C      OPEN(UNIT=IOBO,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED',
C     1     ERR=1050,CARRIAGECONTROL='LIST')
CVAX
CIBM
      OPEN(UNIT=IOBO,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED',
     1     ERR=1050)
CIBM
      WRITE(IOBO,1045) ISENSE
1045  FORMAT('E',3X,10I1,T40,'Batch mode')
      GO TO 3000
1050  STOP '--Unable to open file for batch command ouput'
C *
C **  DEBUG SETUP
C *
2000  IF(KMODEO.NE.9) GO TO 3000
      WRITE(ITTO,1)
1     FORMAT(/,'*****>  DIAGONOSTICS INPUT')
      WRITE(ITTO,2)
2     FORMAT(/,' SHOW PROFILE GENERATION ? (0)-NO, (1)-YES ')
      READ(ITTI,*) ISENSE(1)
      WRITE(ITTO,3)
3     FORMAT(' SHOW REFINEMENT PARAMETERS ? (0)-NO, (1)-YES ')
      READ(ITTI,*) ISENSE(2)
      WRITE(ITTO,4)
4     FORMAT(' SHOW PEAK SEARCH PARAMETERS ? (0)-NO, (1)-YES ')
      READ(ITTI,*) ISENSE(3)
      WRITE(ITTO,5)
5     FORMAT(' LEAST-SQAURES OUTPUT ? (0)-NONE, (1)-PARTIAL, (2)-FULL ')
      READ(ITTI,*) ISENSE(4)
      WRITE(ITTO,6)
6     FORMAT(' SHOW BAKCKGROUND PARAMETERS ? (0)-NO, (1)- YES ')
      READ(ITTI,*) ISENSE(5)
C *
C **  INITIALIZE PROGRAM PARAMETERS
C *
3000  KSAMEP = 0
      KAUTOP = 0
      KWSGLN = 0
      DO 3010 I=1,200
      DO 3010 I2=1,11
3010  WSGPAR(I,I2) = 0.0
C *
C **  GET THE INSTRUMENTAL PARAMETERS
C *
      CALL GETWSG
C *
C **  GET THE INPUT PATTERN FILE PARAMETERS
C *
4000  NPEAK = 0
      CALL INITIO( ICODE )
      IF(ICODE.NE.0) GO TO 9000
C *
C **  DETERMINE THE BACKGROUND FOR THIS PATTERN
C *
      CALL BKGDET
C *
C **  DETERMINE FUNCTION TO PERFORM
C *
6000  KPTYPE = KPTDEF
      IF(KMODEO.NE.2) WRITE(ITTO,6010)
6010  FORMAT(//,' SHADOW performs the following functions:',//,
     1'   S(S) - Search for peaks (and setup refinement regions)',/,
     1'   R    - Refine peak parameters by profile fitting',/,
     1'   A(S) - Auto setup for refinement (with auto peak search)',/,
     1'   N    - Open new pattern for analysis',/,
     1'   L    - Line list functions',/,
     1'   P    - Read/write parameter file',/,
     1'   E    - Exit program',//,
     1' Function ? ')
      READ(ITTI,6020) QANS,QANS2
6020  FORMAT(2A1)
      IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000
      IF( QANS.EQ.'S' .OR. QANS.EQ.'s' ) GO TO 7000
      IF( QANS.EQ.'R' .OR. QANS.EQ.'r' ) GO TO 8000
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 10000
      IF( QANS.EQ.'P' .OR. QANS.EQ.'p' ) GO TO 11000
      IF( QANS.EQ.'L' .OR. QANS.EQ.'l' ) GO TO 12000
      IF( QANS.EQ.'A' .OR. QANS.EQ.'a' ) GO TO 13000
      GO TO 6000
C *
C **  PERFORM PEAK SEARCH FUNCTION
C *
7000  IF( QANS2.EQ.'S' .OR. QANS2.EQ.'s' ) KAUTOP = 2
      IF( QANS2.EQ.'R' .OR. QANS2.EQ.'r' ) KAUTOP = 3
      CALL PKSRCH
      KAUTOP = 0
      GO TO 6000
C *
C **  PERFORM THE REFINEMENT FUNCTION
C *
8000  IF(KMODEO.EQ.1) WRITE(IOBO,8010)
8010  FORMAT('Refine',T40,'Profile refinement')
      CALL PKREFN
      GO TO 6000
C *
C **  READ/WRITE PARAMETER FILE
C *
11000 IF(KMODEO.EQ.1) WRITE(IOBO,11010)
11010 FORMAT('Parameters',T40,'Use parameter file')
      CALL PARAMS
      GO TO 6000
C *
C ***  OPEN NEW PATTERN FILE
C *
10000 IF(KMODEO.EQ.1) WRITE(IOBO,10010)
10010 FORMAT('New',T40,'Open new pattern file')
      GO TO 4000
C *
C **  EVALUATE INSTRUMENTAL PARAMETERS
C *
12000 IF(KMODEO.EQ.1) WRITE(IOBO,12010)
12010 FORMAT('List',T40,'Internal line list')
      CALL WSGEVL
      GO TO 6000
C *
C **  AUTOPILOT OPERATION: SETUP FOR BATCH SEARCH AND REFINE
C *
13000 IF(KMODEO.NE.0) THEN
        WRITE(ITTO,13010)
13010   FORMAT(/,' --Autopilot can only be invoked in immediate',
     1  ' execution mode')
        GO TO 6000
      ENDIF
      WRITE(ITTO,13020)
13020 FORMAT(/,' *** Going to autopilot')
      KAUTOP = 1
C *
C *  GET FILE NAME FOR BATCH SETUP
      KMODEO = 1
      WRITE(ITTO,1035)
      READ(ITTI,1040) QFILE
CVAX
C      OPEN(UNIT=IOBO,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED',
C     1     ERR=1050,CARRIAGECONTROL='LIST')
CVAX
CIBM
      OPEN(UNIT=IOBO,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED',
     1     ERR=1050)
CIBM
      WRITE(IOBO,1045) ISENSE
C *
C *  THE FOLLOWING HAS TO BE SET UP
      CALL GETWSG
      CALL INITIO( ICODE )
      IF(ICODE.NE.0) GO TO 13090
      CALL BKGDET
C *
C *  CALL PKSRCH TO DETERMINE ESTIMATES FOR REGIONS AND LINE POSITIONS
C *  SEARCH PERFORMED ONLY IF S WAS INCLUDED IN COMMAND
      IF( QANS2.EQ.'S' .OR. QANS2.EQ.'s' ) CALL PKSRCH
      IF(NPEAK.LT.1) THEN
        WRITE(ITTO,13030)
13030   FORMAT(/,' --No lines from search: Aborting autopilot')
        GO TO 13090
      ENDIF
      IF(KNUMRG.LT.1) THEN
        WRITE(ITTO,13040)
13040   FORMAT(/,' --No regions from search: Aborting autopilot')
        GO TO 13090
      ENDIF

C *
C *  CALL PKREFN TO REFINE LINE POSITIONS
      WRITE(IOBO,8010)
      CALL PKREFN
C *
C *  WRITE THE LINE PARAMETERS
      WRITE(IOBO,12010)
      CALL WSGEVL
C *
C *  CALL PARAMS TO WRITE REFINED LINE PARAMETERS
      WRITE(IOBO,11010)
      CALL PARAMS
C *
C *  TURN OFF AUTOPILOT FLAG AND CLOSE BATCH FILE
13090 KAUTOP = 0
      KMODEO = 0
      WRITE(IOBO,9010)
      CLOSE(UNIT=IOBO)
      WRITE(ITTO,13092)
13092 FORMAT(/,' *** Autopilot off')
      GO TO 6000
C *
C **  THATS ALL FOLKS... EXIT STAGE RIGHT
C *
9000  IF(KMODEO.EQ.1) THEN
        WRITE(IOBO,9010)
9010    FORMAT('Exit',T40,'Program termination')
        CLOSE(UNIT=IOBO)
      ENDIF
      WRITE(ITTO,9060)
9060  FORMAT(/,'**  Normal termination of SHADOW  **')
C      CALL EXIT
      STOP
      END
C ***  CALCPH - POSITION AND HEIGHT FOR A SATELLITE LINE
C *
      SUBROUTINE CALCPH( TT1, YI1, N, TTN, YIN )
      PARAMETER ( DTORD2=8.72664626E-03, RTODT2=114.591559)
      COMMON /WDATA/ NWAVE,WTABLE(5,2)
C *
      TTN = SIN( TT1 * DTORD2 )
      TTN = RTODT2 * ASIN( WTABLE(N,1)/WTABLE(1,1) * TTN )
      YIN = YI1 * WTABLE(N,2)
      RETURN
      END
C ***  CORPOS - TWO-THETA LINE CORRECTION FROM INSTRUMENTAL PARAMETERS
C *
C *  TT-COR = TT-OBS + CORPOS( TT-OBS )
C *
      FUNCTION CORPOS( TTOBS )
      COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3)
C *
      CORPOS = WGCAL(1) + WGCAL(2)*TTOBS + WGCAL(3)*TTOBS**2
C *
      RETURN
      END
C ***  BKGLVL - GENERATION OF BACKGROUND
C *
      SUBROUTINE BKGLVL( TARGET )
C *
C *  KBKGR =  0 => BACKGROUND IS ASSUMED ZERO
C *        =  1 => ADDITIVE BACKGROUND OFFSET BEING REFINED
C *        =  2 => CALCULATED BACKGROUND IS MOVED TO TARGET
C *        =  3 => REFINE FIXED BACKGROUND SHAPE OFFSET
C *
C *  IF THE BACKGROUND HAS NOT BEEN EVALUATED... DAREA IS ZEROED.
C *
      PARAMETER ( DTOR=1.745329252E-02, RTOD=5.729577951E+01 )
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /BKGDAT/ LDEG,CLY,CLC(6),BKGSDV,IBKCPS,IBKNBK
      COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2)
      DIMENSION TARGET(MPTS)
      EQUIVALENCE (CLC(1),PC1),(CLC(2),PC2),(CLC(3),PC3),(CLC(4),PC4)
C *
C *  IF KBKGR=0,1,3 THEN USE KBKGR TO DETERMINE ACTION
      IF(KBKGR.EQ.0) GO TO 2000
      IF(KBKGR.EQ.1) GO TO 3000
      IF(KBKGR.EQ.3) GO TO 1000
C *
C *  BACKGROUND MUST HAVE BEEN DETERMINED IF KBKGR=2
      IF(KBKGD.NE.1) GO TO 2000
      IF(KBKGR.EQ.2) GO TO 1000
      STOP '--BKGLVL:  INVALID VALUE OF KBKGR: ABORT'
C *
C **  CALCULATED BACKGROUND USED
C *
C *  DETERMINE THE ADDITIVE CONSTANT BASED ON THE TYPE OF BACKGROUND
1000  OFFSET = CLY
      IF(KBKGR.EQ.3) OFFSET = BKGPAR
      IF(LDEG.EQ.0) GO TO 1100
C *
C *  SPAN THE ENTIRE RANGE WITH THE POLYNOMIAL BACKGROUND
C *
C *  CALCULATE THE EXPECTED INTENSITIES
      IF(LDEG.EQ.1) THEN
        DO 1011 I=1,KOBS
1011    TARGET(I) = OFFSET + PC1*YANG(I)
       ELSE IF(LDEG.EQ.2) THEN
        DO 1012 I=1,KOBS
        ANG = YANG(I)
        TARGET(I) = OFFSET + (PC2*ANG + PC1)*ANG
1012    CONTINUE
       ELSE IF(LDEG.EQ.3) THEN
        DO 1013 I=1,KOBS
        ANG = YANG(I)
        TARGET(I) = OFFSET + ((PC3*ANG + PC2)*ANG + PC1)*ANG
1013    CONTINUE
       ELSE
        DO 1014 I=1,KOBS
        ANG = YANG(I)
        TARGET(I) = OFFSET + (((PC4*ANG + PC3)*ANG + PC2)*ANG + PC1)*ANG
1014    CONTINUE
      ENDIF
      GO TO 9000
C *
C **  SPAN THE ENTIRE RANGE WITH THE FIXED BACKGROUND SHAPE
C *
1100  TMP = ( 2.0**(1.0/PC3) - 1.0 ) / ( (PC2/2.0)**2 )
      DO 1110 I=1,KOBS
1110  TARGET(I) = PC1/(1.0+TMP*YANG(I)**2)**PC3 + PC4*YANG(I) + OFFSET
      GO TO 9000
C *
C **  BACKGROUND IS ZERO...
C *
2000  DO 2010 I=1,KOBS
2010  TARGET(I) = 0.0
      GO TO 9000
C *
C **  ADDITIVE OFFSET BEING REFINED
C *
3000  DO 3010 I=1,KOBS
3010  TARGET(I) = BKGPAR
C *
9000  RETURN
      END
C ***  FUNCTION CPUSEC - RETURNS CPU EXECUTION TIME IN SECONDS
C *
C *  ARGUMENT IS USED FOR DELTA TIME INTERVALS
C *
      FUNCTION CPUSEC( START )
C *
CVAX  ISTAT = LIB$STAT_TIMER(2,ITIME)
CVAX  TIME = FLOAT( ITIME ) / 100.0
CVAX  CPUSEC = TIME - START
      CPUSEC = 0.0
C *
      RETURN
      END
C ***  DATE - DUMMY DATE ROUTINE
C *
C      SUBROUTINE DATE( QDATE )
C      CHARACTER QDATE*9
C      QDATE = 'dd-mmm-yy'
c      RETURN
C      END
C ***  TIME - DUMMY TIME ROUTINE
C *
C      SUBROUTINE TIME( QTIME )
C      CHARACTER QTIME*8
C      QTIME = 'hh:mm:ss'
C      RETURN
C      END
C ***  BLOCK DATA
C *
      BLOCK DATA
C *
C *  LOGICAL UNIT ASSIGNMENTS:
C *  ITTI - TERMINAL INPUT            ITTO - TERMINAL OUTPUT
C *  IOFI - PATTERN INPUT             IOFO - PATTERN FILE OUTPUT
C *  IOSC - SCRATCH FILE (OUT/IN)     IOPL - PLOT FILE OUTPUT
C *  IOBO - BATCH COMMAND FILE OUTPUT IOPO - PARAMETER FILE (IN/OUT)
C *  IDLO - LINE FILE OUTPUT (IN/OUT) IOWG - INST PARAMETER FILE (IN/OUT
C *  KPTYPE - PLOT FILE: 0 - UNFORMATTED, 1 - FORMATTED
C *
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF
      DATA ITTI /  5 /
      DATA ITTO /  6 /
      DATA IOFI / 10 /
      DATA IOFO / 11 /
      DATA IOBO / 12 /
      DATA IOPL / 13 /
      DATA IOPO / 14 /
      DATA IOLO / 15 /
      DATA IOSC / 16 /
      DATA IOWG / 17 /
      DATA KPTDEF / 0 /
      END
C ***  PROGRAM: SHADOW  (SHADOW10)
C ***  VERSION: 860822  (YYMMDD)
C *
C ***  BKGDET - BACKGROUND DETERMINATION
C *
      SUBROUTINE BKGDET
C *
      LOGICAL LOFLAG
      CHARACTER QJUNK*1
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      PARAMETER ( DTOR = 0.01745329252 )
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3)
      COMMON /BKGDAT/ LDEG,CLY,CLC(6),BKGSDV,IBKCPS,IBKNBK
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /DIAGS/ ISENSE(10)
      DIMENSION XDATA(10), PCOEFF(10)
      EQUIVALENCE ( PCOEFF(1), PC1 ), ( PCOEFF(2), PC2 ),
     1            ( PCOEFF(3), PC3 ), ( PCOEFF(4), PC4 )
C *
      IF(KMODEO.EQ.2) THEN
        WRITE(ITTO,1)
1       FORMAT(//,8X,'* * *   B A C K G R O U N D   D E T E R M I N',
     1  ' A T I O N   * * *')
       ELSE
        WRITE(ITTO,2)
2       FORMAT(/,' *  Background determination')
      ENDIF
C *
C *  INITIALIZE BACKGROUND PARAMETERS IF AUTOPILOT IS OFF
      IF(KAUTOP.NE.1) THEN
        IBKCPS = 0
        KBKGD = 0
        KBKGR = 0
        LDEG = 0
        BKGSDV = 0.0
        CLY = 0.0
        DO 11 I=1,6
11      CLC(I) = 0.0
        IWGT = 0
      ENDIF
C *
C *  GET THE TYPE OF BACKGROUND TO EVALUATE
C *
100   IF( KMODEO.NE.2 .AND. KAUTOP.NE.1 ) WRITE(ITTO,105)
105   FORMAT(/,' Type of background for evaluation:',/,
     1     5X,'  -1  None',/,
     1     5X,'   0  Refine fixed shape background offset',/,
     1     5X,' 1-4  Polynomial',//,
     1        ' Background model ? <0> ')
      IF(KAUTOP.NE.1) THEN
        IF(LDEG.NE.2) THEN
          LDEG = 0
          READ(ITTI,*) LDEG
         ELSE
          READ(ITTI,110) LDEG
110       FORMAT(I2)
        ENDIF
      ENDIF
      IF( LDEG.LT.-1 .OR. LDEG.GT.4 ) GO TO 100
      IF(KMODEO.EQ.1) WRITE(IOBO,112) LDEG
112   FORMAT(I2,T40,'Background model')
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,114) LDEG
114   FORMAT(/,' Background evaluated: ',I2)
      IF(LDEG.EQ.-1) GO TO 9000
C *
C *  IF AUTOPILOT IS ON-> MODEL WRITTEN TO BATCH FILE, EXIT
      IF(KAUTOP.EQ.1) GO TO 9000
C *
C *  SKIP THE FILES HEADER RECORDS
200   REWIND IOFI
      IF(KFILET.EQ.0) NSKIP = 3
      IF(KFILET.EQ.1) NSKIP = 3
      DO 210 I=1,NSKIP
      IF(KFILET.EQ.0) THEN
        READ(IOFI,215) QJUNK
215     FORMAT(A1)
       ELSE
        READ(IOFI) QJUNK
      ENDIF
210   CONTINUE
C *
C *  DETERMINE NUMBER OF POINTS IN SEGMENT
C *
1100  NLIMIT = MIN( 2048, MPTS )
      NHID = NINT( (FEANG-FBANG)/FAINC ) + 1
      IF(NHID.GT.NLIMIT*10) THEN
        WRITE(ITTO,1102) NLIMIT
1102    FORMAT(/,' -Background limited to ',I4,' points')
        NHID = NLIMIT * 10
      ENDIF
      NHIR = NHID / 10
      IF(NHIR.LT.1) STOP'ERROR-TOO FEW POINTS IN PATTERN'
      NHIP = NLIMIT / NHIR
      IF(NHIP.EQ.0) STOP'ERROR-TOO MANY POINTS IN PATTERN'
      IF(NHIP.GT.10) NHIP = 10
      IF(ISENSE(5).NE.0) WRITE(ITTO,9990) NHID,NHIR,NHIP
9990  FORMAT(' NHID,NHIR,NHIP = ',3I6)
      NINTVL = 10 / NHIP
      IF(NINTVL.EQ.10) NINTVL = 1
      NTOGET = 1 + ( NHIP - 1 ) * NINTVL
C *
C *  READ PATTERN SEGMENTS FOR BACKGROUND DATA
C *
      KOBS = 0
      IF(KFILET.EQ.0) THEN
        DO 1110 I=1,NHIR
        READ(IOFI,1112,END=1134) (XDATA(J),J=1,NTOGET,NINTVL)
1112    FORMAT(10F7.0)
        ABREC = FBANG + 10.0*REAL(I-1)*FAINC - FAINC
        DO 1114 J=1,NTOGET,NINTVL
        KOBS = KOBS + 1
        YANG(KOBS) = ABREC + REAL(J) * FAINC
        YOBS(KOBS) = XDATA(J)
1114    CONTINUE
1110    CONTINUE
       ELSE
        DO 1120 I=1,NHIR
        READ(IOFI,END=1134) (XDATA(J),J=1,NTOGET,NINTVL)
        ABREC = FBANG + 10.0*REAL(I-1)*FAINC - FAINC
        DO 1122 J=1,NTOGET,NINTVL
        KOBS = KOBS + 1
        YANG(KOBS) = ABREC + REAL(J) * FAINC
        YOBS(KOBS) = XDATA(J)
1122    CONTINUE
1120    CONTINUE
      ENDIF
1138  WRITE(ITTO,1130) NHIR,NHIP,KOBS
1130  FORMAT(/,' Records read ',I5,'  Points/record ',I2,
     1'  Total number of points ',I5)
      GO TO 1132
1134  WRITE(ITTO,1136)
1136  FORMAT(/,
     1' --The end-of-file was unexpectedly hit while reading the',
     1' pattern file.')
      GO TO 1138
C *
C *  SET TSIGMA, SIGMA LEVEL ABOVE WHICH TO REJECT POINTS
1132  TSIGMA = 1.75
      IF(ISENSE(5).NE.0) THEN
        WRITE(ITTO,9991)
9991    FORMAT(/,' ENTER TSIGMA: ')
        ANS = 0.0
        READ(ITTI,*) ANS
        IF(ANS.GT.0.) TSIGMA = ANS
      ENDIF
C *
C *  DETERMINE TYPE OF BACKGROUND DETERMINATION...
C *
      IF(LDEG.EQ.0) GO TO 4000
C *
C **  THE BACKGROUND WILL BE EVALUATED AS A POLYNOMIAL.  THE DEGREE INPU
C **  WILL BE USED AND ANY POINTS OUTSIDE OF THE LIMITS WILL BE REJECTED
C *
C *  GENERATE THE WEIGHTING FACTORS IN YBKG
1300  IF(IWGT.NE.0) THEN
        DO 1302 I=1,KOBS
1302    YBKG(I) = 1.0 / AMAX1( 1.0, YOBS(I) )
      ENDIF
      NCYCLE = 0
      NTDEL = 0
      LOFLAG = .FALSE.
      YDUM = 0.0
C *
C *  COMPUTE COEFFICIENTS FOR BEST FIT
1305  PSDEV = PFIT(YANG,YOBS,YBKG,KOBS,LDEG,YDUM,PYINT,PCOEFF,IWGT)
C *
C *  CALCULATE THE EXPECTED INTENSITIES
      IF(LDEG.EQ.1) THEN
        DO 1311 I=1,KOBS
1311    YSYN(I) = PYINT + PC1*YANG(I)
       ELSE IF(LDEG.EQ.2) THEN
        DO 1312 I=1,KOBS
        ANG = YANG(I)
        YSYN(I) = PYINT + (PC2*ANG + PC1)*ANG
1312    CONTINUE
       ELSE IF(LDEG.EQ.3) THEN
        DO 1313 I=1,KOBS
        ANG = YANG(I)
        YSYN(I) = PYINT + ((PC3*ANG + PC2)*ANG + PC1)*ANG
1313    CONTINUE
       ELSE
        DO 1314 I=1,KOBS
        ANG = YANG(I)
        YSYN(I) = PYINT + (((PC4*ANG + PC3)*ANG + PC2)*ANG + PC1)*ANG
1314    CONTINUE
      ENDIF
C *
C *  ELIMINATE POINTS TSIGMA SIGMA ABOVE COMPUTED LINE
      NDEL = 0
      DO 1320 I=1,KOBS
C *
C *  CALCULATE THE EXPECTED INTENSITY AND SIGMA LIMIT
      YCALC = AMAX1( YSYN(I), 0.0 )
      PLIM = TSIGMA * SQRT(YCALC)
C *
C *  REJECT IF ABOVE LIMIT
      IF(YOBS(I).GT.(YCALC+PLIM)) GO TO 1335
C *
C *  REJECT IF BELOW LIMIT
      IF(.NOT.LOFLAG) GO TO 1320
      IF(YOBS(I).GT.(YCALC-PLIM)) GO TO 1320
C *
C *  MARK POINT FOR FUTURE REMOVAL FROM LIST
1335  YANG(I) = 0.0
      NDEL = NDEL + 1
C *
1320  CONTINUE
C *
C *  COMPRESS LIST
      IF(NDEL.EQ.0) GO TO 1360
      NTEMP = KOBS
      KOBS = 0
      DO 1340 I=1,NTEMP
      IF(YANG(I).EQ.0.0) GO TO 1340
      KOBS = KOBS + 1
      IF(KOBS.EQ.I) GO TO 1340
      YANG(KOBS) = YANG(I)
      YOBS(KOBS) = YOBS(I)
      YBKG(KOBS) = YBKG(I)
1340  CONTINUE
C *
C *  REPEAT ON SECOND ROUND REJECTING POINTS BELOW TSIGMA*SIGMA
1360  IF(ISENSE(5).NE.0) WRITE(ITTO,9992) KOBS,NTEMP,NDEL
9992  FORMAT(' KOBS,NTEMP,NDEL: ',3I6)
      NTDEL = NTDEL + NDEL
      NCYCLE = NCYCLE + 1
      IF(NDEL.GT.0) GO TO 1305
      IF(LOFLAG) GO TO 1370
      LOFLAG = .TRUE.
      GO TO 1305
C *
C *  COPY THE COEFFICIENTS TO COMMON
1370  CLY = PYINT
      DO 1380 I=1,LDEG
1380  CLC(I) = PCOEFF(I)
C *
C *  WRITE THE POLYNOMIAL BACKGROUND INFO
      WRITE(ITTO,1382)
1382  FORMAT(/,' Background evaluation;  Polynomial approximation:')
      WRITE(ITTO,1384) NCYCLE,KOBS,NTDEL
1384  FORMAT('  Cycles = ',I3,'  Points used = ',I4,'  Deleted = ',I4)
      WRITE(ITTO,131) CLY/FTIME, (CLC(I),I,I=1,LDEG)
131   FORMAT(/,'   BKG(2THETA) = ',SP,E13.6,
     1  4(/,17X,SP,E13.6,' * 2THETA**',S,I1))
C *
C *  COMPUTE THE TOTAL STANDARD DEVIATION FOR THE BACKGROUND
1400  BKGSDV = 0.0
      DO 1410 I=1,KOBS
1410  BKGSDV = BKGSDV + 1.0 / AMAX1( 1.0, YOBS(I) )
      BKGSDV = SQRT( 1.0 / BKGSDV )
      WRITE(ITTO,1450) BKGSDV/FTIME
1450  FORMAT(/,'  Standard deviation of background = ',F10.6)
C *
C *  FLAG THE BACKGROUND DETERMINATION PROCESS COMPLETE
      KBKGD = 1
      GO TO 9000
C *
C **  FIXED BACKGROUND SHAPE.... ONLY ADJUST ADDITIVE CONSTANT
C *
4000  DO 4001 I=1,4
4001  CLC(I) = WGBAK(I)
      NCYCLE = 0
      NTDEL = 0
      LOFLAG = .FALSE.
C *
C *  CALCULATE THE BACKGROUND IN YSYN, WEIGHTS IN YBKG
      TMP = ( 2.0**(1.0/CLC(3)) - 1.0 ) / ( (CLC(2)/2.0)**2 )
      DO 4002 I=1,KOBS
      TEMP = CLC(1) / ( 1.0 + TMP * YANG(I)**2 )**CLC(3)
      YSYN(I) = TEMP + CLC(4)*YANG(I)
      YBKG(I) = 1.0 / AMAX1( 1.0, YOBS(I) )
4002  CONTINUE
C *
C *  COMPUTE THE AVERAGES AND STANDARD DEVIATION
4005  BCKGND = 0.0
      SWGT = 0.0
      IF(IWGT.EQ.0) THEN
        DO 4006 I=1,KOBS
        BCKGND = BCKGND + ( YOBS(I)-YSYN(I) )
        SWGT = SWGT + YBKG(I)
4006    CONTINUE
        BCKGND = BCKGND / REAL( KOBS )
       ELSE
        DO 4007 I=1,KOBS
        BCKGND = BCKGND + YBKG(I) * ( YOBS(I)-YSYN(I) )
        SWGT = SWGT + YBKG(I)
4007    CONTINUE
        BCKGND = BCKGND / SWGT
      ENDIF
CZZZ  IF(BCKGND.LT.0.0) BCKGND = 0.0
      BKGVAR = 1.0 / SWGT
      BKGSDV = SQRT( BKGVAR )
      IF(ISENSE(5).NE.0) WRITE(ITTO,9993) BCKGND/FTIME,BKGSDV/FTIME
9993  FORMAT(' BCKGND = ',F8.4,'  SIGMA = ',F8.4)
      TSIGMA = 2.00
C *
C *  ELIMINATE POINTS TSIGMA SIGMA ABOVE COMPUTED LINE
      NDEL = 0
      DO 4010 I=1,KOBS
      YCALC = YSYN(I) + BCKGND
      YHI = YCALC + TSIGMA * SQRT( YCALC )
      IF(YOBS(I).GT.YHI) GO TO 4012
      IF(.NOT.LOFLAG) GO TO 4010
      YLO = YCALC - TSIGMA * SQRT( YCALC )
      IF(YOBS(I).GT.YLO) GO TO 4010
4012  YANG(I) = 0.0
      NDEL = NDEL + 1
4010  CONTINUE
C *
C *  COMPRESS LIST
      IF(NDEL.EQ.0) GO TO 4100
      NTEMP = KOBS
      KOBS = 0
      DO 4040 I=1,NTEMP
      IF(YANG(I).EQ.0.0) GO TO 4040
      KOBS = KOBS + 1
      IF(KOBS.EQ.I) GO TO 4040
      YANG(KOBS) = YANG(I)
      YOBS(KOBS) = YOBS(I)
      YSYN(KOBS) = YSYN(I)
      YBKG(KOBS) = YBKG(I)
4040  CONTINUE
C *
4100  IF(ISENSE(5).NE.0) WRITE(ITTO,9992) KOBS,NTEMP,NDEL
      NTDEL = NTDEL + NDEL
      NCYCLE = NCYCLE + 1
      IF(NDEL.GT.0) GO TO 4005
      IF(LOFLAG) GO TO 4200
      LOFLAG = .TRUE.
      GO TO 4005
C *
C *  COPY THE BACKGROUND OFFSET TO COMMON
4200  CLY = BCKGND
C *
C *  WRITE THE FIXED SHAPE BACKGROUND INFO
      WRITE(ITTO,4210)
4210  FORMAT(/,' Background evaluation with predetermined shape')
      WRITE(ITTO,1384) NCYCLE,KOBS,NTDEL
      WRITE(ITTO,4230) CLY/FTIME,BKGSDV/FTIME
4230  FORMAT('  Background offset = ',F8.4,'  Sigma = ',F8.4)
C *
C *  FLAG BACKGROUND DETERMINED
      KBKGD = 1
C *
C *  PROCESS COMPLETE... RETURN
9000  RETURN
      END
C *** PFIT
C *
C *  FUNCTION PFIT FITS AN NTH DEGREE LINEAR LEAST-SQUARES
C *  POLYNOMIAL CURVE TO THE M DATA POINTS CONTAINED IN THE
C *  X AND Y ARRAYS.  RETURNED ARE THE STANDARD DEVIATION
C *  OF THE POINTS ABOUT THE REGRESSION CURVE AS THE VALUE
C *  OF THE FUNCTION AND THE Y INTERCEPT AND POLYNOMIAL
C *  COEFFICIENTS IN THE CALLING ARGUMENTS.  IF THE VALUE
C *  OF N IS POSITIVE THEN THE POLYNOMIAL IS EVALUATED SO THE
C *  Y INTERCEPT IS REFINED AS A VARIABLE.  HOWEVER, IF THE
C *  VALUE OF N IS NEGATIVE THEN THE Y INTERCEPT IS PINNED AT
C *  THE VALUE YINTCP AND THE SYSTEM OF SIMULTANEOUS USED
C *  TO DETERMINE THE REGRESSION COEFFICIENTS ARE EVALUATED
C *  ACCORDINGLY.
C *
C *
C *  CALLING ARGUMENTS:
C *
C *     X      = X DATA ARRAY
C *     Y      = Y DATA ARRAY
C *     W      = WEIGHTING FOR Y VALUES
C *     M      = NUMBER OF POINTS IN REGRESSION
C *     N      = DEGREE OF POLYNOMIAL FIT.  IF N IS POSITIVE THE Y
C *              INTERCEPT VALUE IS REFINED.  IF N IS NEGATIVE THEN
C *              THE POLYNOMIAL CURVE WILL BE REFINED SUCH THAT
C *              THE VALUE OF YINTCP WILL BE THE Y INTERCEPT.
C *     YINTCP = THE PINNED Y INTERCEPT
C *     IWGT   = 0 - NO WEIGHTING  1 - WEIGHTING
C *
C *  RETURN ARGUMENTS:
C *
C *     PFIT   = STANDARD DEVIATION OF THE POINTS ABOUT THE
C *              REGRESSION CURVE.
C *     PYINT  = THE Y INTERCEPT OF THE REGRESSION CURVE.
C *     PB     = THE REGRESSION COEFFICIENTS, LOW TO HIGH POWER.
C *
      FUNCTION PFIT( X, Y, W, M, N, YINTCP, PYINT, PB, IWGT )
C *
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*4 PFIT, X(M), Y(M), W(M), YINTCP, PYINT, PB(10)
      DIMENSION C(11,11), SX(20), SYX(10), CYX(10), B(10)
C *
C *  NDEG IS THE DEGREE OF THE POLYNOMIAL TO FIT
      NDEG = IABS( N )
C *
C *  INITIALIZE THE FUNCTION VALUE TO A LARGE NUMBER
      PFIT = 1.0E15
C *
C *  THE NUMBER OF POINTS MUST BE TWO GREATER THAN THE POWER
      IF(M.LT.NDEG+2) RETURN
C *
C *  FIRST THROUGH TENTH DEGREE FIT ONLY
      IF( NDEG.LT.1 .OR. NDEG.GT.10 ) STOP'PFIT: BAD N'
C *
C *  COMPUTE CONSTANTS
      FM = DBLE( M )
      NTWO = 2 * NDEG
      NP1 = NDEG + 1
      NP2 = NDEG + 2
C *
C *  INITIALIZE VARIABLES
      SY = 0.0
      SYY = 0.0
      DO 1 I=1,NDEG
      NPI = NDEG + I
      SX(I) = 0.0
      SX(NPI) = 0.0
1     SYX(I) = 0.0
C *
C *  COMPUTE SUMS AND PRODUCTS WITHOUT WEIGHTS
2000  IF(IWGT.EQ.0) THEN
        DO 2010 I = 1,M
        SY = SY + Y(I)
        SYY = SYY + ( Y(I) * Y(I) )
        DUM = 1.0
        DO 2020 J = 1,NDEG
        DUM = DUM * X(I)
        SX(J) = SX(J) + DUM
2020    SYX(J) = SYX(J) + ( Y(I) * DUM )
        DO 2010 J = NP1,NTWO
        DUM = DUM * X(I)
2010    SX(J) = SX(J) + DUM
       ELSE
C *  COMPUTE SUMS AND PRODUCTS WITH WEIGHTS
        FM = 0.0
        DO 2030 I = 1,M
        FM = FM + W(I)
        SY = SY + ( W(I) * Y(I) )
        SYY = SYY + ( W(I) * Y(I) * Y(I) )
        DUM = W(I)
        DO 2040 J = 1,NDEG
        DUM = DUM * X(I)
        SX(J) = SX(J) + DUM
2040    SYX(J) = SYX(J) + ( Y(I) * DUM )
        DO 2030 J = NP1,NTWO
        DUM = DUM * X(I)
2030    SX(J) = SX(J) + DUM
      ENDIF
C *
C *  EXECUTE ACCORDING TO THE SIGN OF N.  IF POSITIVE THEN REFINE THE
C *  Y INTERCEPT VALUE.  IF NOT THEN NO REFINEMENT IS NECESSARY.
      IF(N.LT.0) GO TO 100
C *
C *  CREATE COEFFICIENT MATRIX
      DO 5 I = 1,NDEG
      CYX(I) = SYX(I) - ( SY * SX(I) / FM )
      C(I,NP1) = CYX(I)
      DO 5 J = 1,NDEG
      IPJ = I + J
5     C(I,J) = SX(IPJ) - ( SX(I) * SX(J) / FM )
C *
C *  CALL SIMUL TO SOLVE SIMULTANEOUS EQUATIONS
      DET = SIMUL( NDEG, C, B, 11 )
C     WRITE(7,300)DET
C300  FORMAT(' THE DETERMINANT EQUALS ',F10.2)
      IF(DET.NE.0.0) GO TO 8
      RETURN
C *
C *  COMPUTE INTERCEPT YINT AND STANDARD DEVIATION SDEV
8     CYY = SYY - SY * SY / FM
      DO 9 I=1,NDEG
      SY = SY - B(I) * SX(I)
9     CYY = CYY - B(I) * CYX(I)
      PYINT = SY / FM
      DENOM = M - NDEG - 1
      PFIT = DSQRT( DABS( CYY / DENOM ) )
      GO TO 200
C *
C *  COMPUTE THE POLYNOMIAL WITH THE PINNED INTERCEPT
C *
C *  CREATE COEFFICIENT MATRIX
100   DO 110 I=1,NDEG
      CYX(I) = SYX(I) - SY * SX(I) / FM
      DO 120 J=1,NDEG
      IPJ = I + J
120   C(I,J) = SX(IPJ)
110   C(I,NP1) = SYX(I) - YINTCP * SX(I)
C *
C *  CALL SIMUL TO SOLVE SIMULTANEOUS EQUATIONS
      DET = SIMUL( NDEG, C, B, 11 )
C     WRITE(7,300) DET
      IF(DET.NE.0.0) GO TO 130
      RETURN
C *
C *  RETURN THE Y INTERCEPT VALUE
130   PYINT = YINTCP
C *
C *  COMPUTE STANDARD DEVIATION
      CYY = SYY - SY * SY / FM
      DO 150 I=1,NDEG
150   CYY = CYY - B(I) * CYX(I)
      DENOM = M - NDEG - 1
      PFIT = DSQRT( DABS( CYY / DENOM ) )
C *
C *  TRANSFER THE COEFFICIENTS
200   DO 210 I=1,NDEG
210   PB(I) = B(I)
C *
      RETURN
      END
C ***  FUNCTION SIMUL
C *
C *  FUNCTION SIMUL SOLVES SIMULTANEOUS LINEAR EQUATIONS WHICH ARE
C *  SOLVED IN PLACE. THE GAUSS-JORDEN COMPLETE ELIMINATION METHOD
C *  IS EMPLOYED WITH THE MAXIMUM PIVOT STRATEGY.  ROW AND COLUMN
C *  SUBSCRIPTS OF SUCCESSIVE PIVOT ELEMENTS ARE SAVED IN ORDER IN
C *  THE IROW AND JCOL ARRAYS RESPECTIVELY.  K IS THE PIVOT COUNTER,
C *  PIVOT THE ALGEBRAIC VALUE OF THE PIVOT ELEMENT, MAX
C *  THE NUMBER OF COLUMNS IN A AND DETER THE DETERMINANT OF THE
C *  COEFFICIENT MATRIX.  THE SOLUTIONS ARE COMPUTED IN THE (N+1)TH
C *  COLUMN OF A AND THEN UNSCRAMBLED AND PUT IN PROPER ORDER IN
C *  X(1)...X(N) USING THE PIVOT SUBSCRIPT INFORMATION AVAILABLE
C *  IN THE IROW AND JCOL ARRAYS,  THE SIGN OF THE DETERMINANT IS
C *  ASJUSTED, IF NECESSARY, BY DETERIMINING IF AN ODD OR EVEN NUMBER
C *  OF PAIRWISE INTERCHANGES IS REQUIRED TO PUT THE ELEMENTS OF THE
C *  JORD ARRAY IN ASCENDING SEQUENCE WHERE JORD(IROW(I))=JCOL(I).
C *  FUNCTION SIMUL COMPUTES THE VALUE OF THE DETERMINANT AND
C *  IS RETURNED AS THE VALUE OF THE FUNCTION.  SHOULD THE POTENTIAL
C *  PIVOT OF LARGEST MAGNITUDE BE SMALLER IN MAGNITUDE THAN EPS,
C *  THE MATRIX IS CONSIDERED TO BE SINGULAR AND A TRUE ZERO IS
C *  RETURNED AS THE VALUE OF THE FUNCTION.
C *
      FUNCTION SIMUL( N, A, X, NRC )
C *
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      DIMENSION IROW(30),JCOL(30),JORD(30),A(NRC,NRC),X(N)
      DATA EPS/1.00E-20/
C *
      MAX=N+1
C *
C *  INSURE N IS LESS THAN 30
      IF(N.GT.30) STOP'SIMUL: N TOO LARGE'
C *
C *  BEGIN ELIMINATION PROCEDURE
5     DETER=1.0
      DO 18 K=1,N
      KM1=K-1
C *
C *  SEARCH FOR PIVOT ELEMENT
      PIVOT=0.0
      DO 11 I=1,N
      DO 11 J=1,N
C *  SCAN IROW AND JCOL ARRAYS FOR INVALID PIVOT SUBSCRIPTS
      IF(K.EQ.1) GO TO 9
      DO 8 ISCAN=1,KM1
      DO 8 JSCAN=1,KM1
      IF(I.EQ.IROW(ISCAN))GO TO 11
8     IF(J.EQ.JCOL(JSCAN))GO TO 11
9     IF(DABS(A(I,J)).LE.DABS(PIVOT))GO TO 11
      PIVOT=A(I,J)
      IROW(K)=I
      JCOL(K)=J
11    CONTINUE
C *
C *  INSURE THAT THE SELECTED PIVOT ELEMENT IS LARGER THAN EPS
      IF(DABS(PIVOT).GT.EPS)GO TO 13
      WRITE(ITTO,100)
100   FORMAT(/,' -SIMUL: WARNING - PIVOT ELEMENT TOO SMALL')
      SIMUL=0.0
      RETURN
C *
C *  UPDATE THE DETERMINATE VALUE
13    IROWK=IROW(K)
      JCOLK=JCOL(K)
      DETER=DETER*PIVOT
C *
C *  NORMALIZE PIVOT ROW ELEMENTS
      DO 14 J=1,MAX
14    A(IROWK,J)=A(IROWK,J)/PIVOT
C *
C *  CARRY OUT ELIMINATION AND CARRY OUT INVERSE
      A(IROWK,JCOLK)=1.0/PIVOT
      DO 18 I=1,N
      AIJCK=A(I,JCOLK)
      IF(I.EQ.IROWK)GO TO 18
      A(I,JCOLK)=-AIJCK/PIVOT
      DO 17 J=1,MAX
17    IF(J.NE.JCOLK) A(I,J)=A(I,J)-AIJCK*A(IROWK,J)
18    CONTINUE
C *
C *  ORDER SOLUTION VALUES AND CREATE JORD ARRAY
      DO 20 I=1,N
      IROWI=IROW(I)
      JCOLI=JCOL(I)
      JORD(IROWI)=JCOLI
20    X(JCOLI)=A(IROWI,MAX)
C *
C *  ADJUST THE SIGN OF THE DETERMINANT
      INTCH=0
      NM1=N-1
      DO 22 I=1,NM1
      IP1=I+1
      DO 22 J=IP1,N
      IF(JORD(J).GE.JORD(I))GO TO 22
      JTEMP=JORD(J)
      JORD(J)=JORD(I)
      JORD(I)=JTEMP
      INTCH=INTCH+1
22    CONTINUE
      IF(INTCH/2*2.NE.INTCH) DETER=-DETER
C *
C *  RETURN WITH RESULTS
24    SIMUL = DETER
      RETURN
      END
C ***  PROGRAM: SHADOW  (SHADOW20)
C ***  VERSION: 860822  (YYMMDD)
C *
C *** GETWSG - GET INSTRUMENT RELATED PARAMETERS
C *
      SUBROUTINE GETWSG
C *
      CHARACTER LINE72*72,LINEID*10,QWGTTL*72,QWGFID*32,QWGANS*1
      CHARACTER FILEID*20, FILEXX*20, QDATE*9, QTIME*8
      PARAMETER ( FILEID = '*** INS CALIBRATION' )
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3)
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /WGDATC/ QWGTTL,QWGFID,QWGANS
      COMMON /WDATA/ NWAVE,WTABLE(5,2)
      DIMENSION WCU(5,2), BKF(6), 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 BKF(1)/ 0.168128E+4 /
      DATA BKF(2)/ 0.211972E+1 /
      DATA BKF(3)/ 0.713281E+0 /
      DATA BKF(4)/ 0.628660E-1 /
      DATA BKF(5)/-0.184998E+1 /
      DATA BKF(6)/ 0.000000E+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/
C *
C *  IF IN AUTOMODE BASE ACTION ON PREVIOUSLY ANSWERED QUESTION
      IF(KAUTOP.NE.0) GO TO 1199
C *
C *  SET DEFAULTS WAVELENGTHS
1000  DO 1010 I=1,5
      WTABLE(I,1) = WCU(I,1)
      WTABLE(I,2) = WCU(I,2)
1010  CONTINUE
      NWAVE = 3
C *
C *  SET THE DEFAULT BACKGROUND COEFFICIENTS
      DO 1020 I=1,6
1020  WGBAK(I) = BKF(I)
C *
C *  SET THE DEFAULT INSTRUMENTAL PROFILE PARAMETERS
      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 *  SET THE DEFAULT DELTA 2THETA COEFFICIENTS
      DO 1040 I=1,3
1040  WGCAL(I) = 0.0
C *
C *  INDICATE DEFAULT PARAMETERS HAVE BEEN USED
      QWGTTL = 'DEFAULT PROGRAM PARAMETERS'
C *
C *  GET THE INFORMATION REGARDING THE INSTRUMENT
1100  WRITE(ITTO,1110)
1110  FORMAT(/,' The standard Cu radiation wavelengths are default.')
1120  WRITE(ITTO,1130)
1130  FORMAT(/,' Wavelength   Relative intensity')
      DO 1140 I=1,NWAVE
1140  WRITE(ITTO,1150)  WTABLE(I,1), WTABLE(I,2)
1150  FORMAT(2X,F8.5,9X,F6.4)
1160  IF(KMODEO.NE.2) WRITE(ITTO,1170)
1170  FORMAT(/,'   A - Accept wavelengths',/,
     1         '   S - Set new wavelengths',/,
     1         '   R - Read instrument calibration file',//,
     1         ' Choice ? <R> ')
      READ(ITTI,1180) QWGANS,QWGFID
1180  FORMAT(A1,A32)
      IF(QWGFID.EQ.' ') QWGFID = 'WSGDAT'
      IF( QWGANS.NE.'A' .AND. QWGANS.NE.'a' .AND.
     1    QWGANS.NE.'S' .AND. QWGANS.NE.'s' ) QWGANS = 'R'
      IF( QWGANS.EQ.'R' .AND. QWGFID(1:3).NE.'WSG') THEN
        WRITE(ITTO,1182) QWGFID
1182    FORMAT(/,' -Instrument data file name must begin with "WSG":',
     1  ' Using WSGDAT')
        QWGFID = 'WSGDAT'
      ENDIF
C *
C *  CONFIRM THE RESPONSE
1199  IF(KMODEO.EQ.1) WRITE(IOBO,1190) QWGANS,QWGFID
1190  FORMAT(A1,A32,T40,'(A)ccept, (S)et or (R)ead')
      IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,1195) QWGANS,QWGFID
1195  FORMAT(/,' Wavelengths: (A)ccept, (S)et or (R)ead: ',
     1  A1,1X,A32)
C *
C *  DO IT
      IF( (QWGANS.EQ.'A'.OR.QWGANS.EQ.'a') .AND. KAUTOP.NE.0 )GO TO 9000
      IF( (QWGANS.EQ.'R'.OR.QWGANS.EQ.'r') .AND. KAUTOP.NE.0 )GO TO 9000
      IF( QWGANS.EQ.'A' .OR. QWGANS.EQ.'a' ) GO TO 1300
      IF( QWGANS.EQ.'R' .OR. QWGANS.EQ.'r' ) GO TO 2000
C *
C **  GET THE NEW RADIATION WAVELENGTHS
C *
C *
C *  INDICATE RADIATION PARAMETERS HAVE BEEN SET
1200  QWGTTL = 'RADIATION PARAMETERS SET BY OPERATOR'
C *
      IF( KMODEO.NE.2 .AND. KAUTOP.EQ.0 ) THEN
        WRITE(ITTO,1210)
1210    FORMAT(/,' Enter the new wavelengths in (A) and relative',
     1  ' intensities by pairs.',/,' A blank line ends input. ',/)
       ELSE
        WRITE(ITTO,1212)
1212    FORMAT(/,' Radiation data has been set as follows:',/)
      ENDIF
      DO 1220 I=1,5
      IF(KAUTOP.EQ.0) THEN
        IF(KMODEO.NE.2) THEN
          WRITE(ITTO,1222)
1222      FORMAT(' Wavelength, Relative intensity ? <END INPUT> ')
          WTABLE(I,1) = 0.0
          WTABLE(I,2) = 0.0
          READ(ITTI,*) WTABLE(I,1),WTABLE(I,2)
         ELSE
          READ(ITTI,1230) WTABLE(I,1), WTABLE(I,2)
1230      FORMAT(F10.6,F7.4)
        ENDIF
       ELSE
        WTABLE(I,1) = WTABLE(I,1) * 1.0E10
      ENDIF
      IF(WTABLE(I,1).EQ.0.0) WTABLE(I,2) = 0.0
      IF(KMODEO.EQ.1) WRITE(IOBO,1240) WTABLE(I,1),WTABLE(I,2)
1240  FORMAT(F10.6,F7.4,T40,' Wavelength entry')
      IF(WTABLE(I,1).EQ.0.0) GO TO 1300
      IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,1242) WTABLE(I,1),
     1 WTABLE(I,2)
1242  FORMAT(' Wavelength ',F10.6,' Relative Intensity ',F7.4)
      NWAVE = I
1220  CONTINUE
C *
C *  SCALE WAVELENGTH VALUES TO ANGSTROMS
1300  DO 1310 I=1,NWAVE
      WTABLE(I,1) = WTABLE(I,1) * 1.0E-10
      WGRAD(I,1) = WTABLE(I,1)
1310  WGRAD(I,2) = WTABLE(I,2)
      GO TO 9000
C *
C **  READ THE INSTRUMENT CALIBRATION FILE, DEFAULT IS 'WSGDAT'
C *
2000  IF( QWGFID.NE.'WSGDAT' .AND. KMODEO.NE.2 ) WRITE(ITTO,2002) QWGFID
2002  FORMAT(/,' Reading instrument data from: ',A32)
CVAX
C      OPEN(UNIT=IOWG,FILE=QWGFID,STATUS='OLD',ERR=2010,READONLY)
CVAX
CIBM
      OPEN(UNIT=IOWG,FILE=QWGFID,STATUS='OLD',ERR=2010)
CIBM
      GO TO 2100
2010  WRITE(ITTO,2020)
2020  FORMAT(' --Instrument data file does not exist:',
     1' Use INSCAL to create one')
      GO TO 1160
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 *  FILE EXISTS BUT NOT AN INSTRUMENT DATA FILE...
2115  WRITE(ITTO,2120)
2120  FORMAT(' --File is not an instrument calibration file')
      CLOSE(UNIT=IOWG)
      GO TO 1160
C *
C *  READ THE CALIBRATION FILE HEADER
2200  READ(IOWG,2112) QWGTTL
C *
C *  READ THE RADIATION WAVELENGTHS
      NWAVE = 0
      DO 2210 I=1,5
      READ(IOWG,2220) LINEID,WGRAD(I,1),WGRAD(I,2),Z,QDATE,QTIME
2220  FORMAT(1X,A10,3(1X,E13.6),1X,A9,1X,A8)
      IF(WGRAD(I,1).GT.0.0) THEN
        NWAVE = NWAVE + 1
        WTABLE(NWAVE,1) = WGRAD(I,1)
        WTABLE(NWAVE,2) = WGRAD(I,2)
        WTABLE(NWAVE,1) = WTABLE(NWAVE,1) * 1.0E-10
        WGRAD(I,1) = WGRAD(I,1) * 1.0E-10
      ENDIF
2210  CONTINUE
C *
C *  READ THE BACKGROUND DATA
      READ(IOWG,2220)  LINEID,(WGBAK(I),I=1,3),QDATE,QTIME
      READ(IOWG,2220)  LINEID,(WGBAK(I),I=4,6),QDATE,QTIME
C *
C *  READ THE INSTRUMENT PROFILE DATA
      DO 2240 I=1,4
      READ(IOWG,2220)  LINEID,T1,T2,T3,QDATE,QTIME
      IF( T1.EQ.0.0 .AND. T2.EQ.0.0 .AND. T3.EQ.0.0 ) GO TO 2240
      WGPRO(I,1) = T1
      WGPRO(I,2) = T2
      WGPRO(I,3) = T3
2240  CONTINUE
C *
C *  READ THE CALIBRATION CURVE PARAMETERS
      READ(IOWG,2220)  LINEID,(WGCAL(I),I=1,3),QDATE,QTIME
C *
      CLOSE(UNIT=IOWG)
C *
9000  RETURN
      END
C ***  INITIO - GET PATTERN FILE PARAMETERS
C *
      SUBROUTINE INITIO( KODE )
C *
C *  EXIT PARAMETER KODE:  0 => OPERATION SUCCESFUL, FILE OPEN
C *                        1 => OPERATION UNSUCCESFUL, FILE NOT OPEN
C *
C *
      CHARACTER QDATE*9, QTIME*8, QPTFID*32, QANS*1, QFTITL*80
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /XXFILE/ QPTFID
      COMMON /FLDATC/ QFTITL
C *
C *  GET THE DATA FILE NAME... QUIT IF BLANK
C *
1000  KODE = 0
      IF(KAUTOP.NE.1) THEN
        CLOSE(UNIT=IOFI)
        IF(KMODEO.NE.2) WRITE(ITTO,1010)
1010    FORMAT(/,' The name of the pattern file ? ')
        READ(ITTI,1020) QPTFID
1020    FORMAT(A32)
      ENDIF
      IF(KMODEO.EQ.1) WRITE(IOBO,1025) QPTFID
1025  FORMAT(A32,T40,'Pattern file name')
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,1035) QPTFID
1035  FORMAT(/,' Pattern file: ',A32)
      IF(QPTFID(1:1).NE.' ') GO TO 1030
      KODE = 1
      GO TO 9000
C *
C *  GET THE DATA FILE TYPE
C *
1030  IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,1040)
1040    FORMAT(' (F)ormatted or (U)nformatted file type ? <F> ')
        READ(ITTI,1050) QANS
1050    FORMAT(A1)
       ELSE
        QANS = 'F'
        IF(KFILET.EQ.1) QANS = 'U'
      ENDIF
      IF( QANS.EQ.'U' .OR. QANS.EQ.'u' ) THEN
        KFILET = 1
       ELSE
        QANS = 'F'
        KFILET = 0
      ENDIF
      IF(KMODEO.EQ.1) WRITE(IOBO,1051) QANS
1051  FORMAT(A1,T40,' Formatted/unformatted file')
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,1052) QANS
1052  FORMAT('  Pattern file is formatted/unformatted: ',A1)
      IF(KAUTOP.EQ.1) GO TO 9000
C *
C *  OPEN FILE AND GET PATTERN PARAMETERS
      IF(KFILET.EQ.0) THEN
CVAX
C        OPEN(UNIT=IOFI,FILE=QPTFID,STATUS='OLD',READONLY,
C     1    FORM='FORMATTED',ERR=1070)
CVAX
CIBM
        OPEN(UNIT=IOFI,FILE=QPTFID,STATUS='OLD',
     1    FORM='FORMATTED',ERR=1070)
CIBM
        READ(IOFI,2010) QFTITL
2010    FORMAT(A80)
        READ(IOFI,2030) QDATE,QTIME
2030    FORMAT(A9,A8)
        READ(IOFI,2050) FBANG,FEANG,FAINC,FTIME
2050    FORMAT(4F10.4)
       ELSE
CVAX
C        OPEN(UNIT=IOFI,FILE=QPTFID,STATUS='OLD',READONLY,
C     1  FORM='UNFORMATTED',ERR=1070)
CVAX
CIBM
        OPEN(UNIT=IOFI,FILE=QPTFID,STATUS='OLD',
     1  FORM='UNFORMATTED',ERR=1070)
CIBM
        READ(IOFI) QFTITL
        READ(IOFI) QDATE,QTIME
        READ(IOFI) FBANG,FEANG,FAINC,FTIME
      ENDIF
C *
2000  WRITE(ITTO,2001)
2001  FORMAT(/,' The run time parameters for this file are:')
      WRITE(ITTO,2020) QFTITL(1:72)
2020  FORMAT(/,1X,A72)
      WRITE(ITTO,2040) QDATE,QTIME
2040  FORMAT(/,' Pattern recorded  Date: ',A9,'   Time: ',A8)
      WRITE(ITTO,2060) FBANG,FEANG,FAINC,FTIME
2060  FORMAT(/,' Starting angle : ',F8.4,
     1      '    Ending angle   : ',F8.4,/,
     1         ' Angle increment: ',F8.4,
     1      '    Step time      : ',F8.4)
      GO TO 9000
C *
C *  AN ERROR OCCURED ON FILE OPENING
1070  WRITE(ITTO,1080)
1080  FORMAT(' --File busy or not there')
      KODE = 1
C *
C *  EXIT STAGE RIGHT
9000  RETURN
      END
C ***  PARAMS - READ OR WRITE PARAMETER FILE
C *
      SUBROUTINE PARAMS
C *
      LOGICAL EXISTS, LAPPND, LHTEOF
      CHARACTER IOFILE*8,IDBACK*8,IDSEAR*8,IDREFN*8,LINE72*72,LINEID*8
      CHARACTER WGBACK*10, WGPROF*10, WGWAVE*10, WGCALB*10, IDWSGP*10
      CHARACTER PRFILE*32,QPTFID*32,LINEPT*32,QRW*1,QANS*1,QWGTTL*72
      CHARACTER QDATE*9,QTIME*8,WID*1
      PARAMETER ( IOFILE = '***FILE:' )
      PARAMETER ( IDREFN = '*REFINE:' )
      PARAMETER ( IDSEAR = '*SEARCH:' )
      PARAMETER ( IDBACK = '*BAKGND:' )
      PARAMETER ( IDWSGP = '*PROFIL:' )
      PARAMETER ( WGBACK = 'BACKGROUND' )
      PARAMETER ( WGPROF = 'PROFILES  ' )
      PARAMETER ( WGWAVE = 'RADIATION ' )
      PARAMETER ( WGCALB = 'DELTA 2THT' )
      PARAMETER ( DTORD2=8.72664626E-3, RTODT2=114.591559 )
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SCHDAT/ KNFND,PSIGMA,RELLOW,BIGINT,KNSMO,KFFLT,KFMNT
      COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3)
      COMMON /BKGDAT/ LDEG,CLY,CLC(6),BKGSDV,IBKCPS,IBKNBK
      COMMON /WSGDAT/ KWSGLN,WSGPAR(200,12)
      COMMON /PEAKDT/ NPEAK,PEAKS(200,4)
      COMMON /WDATA/ NWAVE,WTABLE(5,2)
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /WGDATC/ QWGTTL
      COMMON /XXFILE/ QPTFID
      EQUIVALENCE ( LINE72(1: 8), LINEID )
      EQUIVALENCE ( LINE72(9:40), LINEPT )
C *
C **  GET FILE NAME AND DETERMINE MODE OF OPERATION
C *
1000  IF(KMODEO.EQ.2) THEN
        WRITE(ITTO,1002)
1002    FORMAT('1',6X,'* * *   P A R A M E T E R   F I L E   F U N C',
     1  ' T I O N S   * * *')
       ELSE
        WRITE(ITTO,1004)
1004    FORMAT(/,' * Parameter file functions')
      ENDIF
      IF(KAUTOP.EQ.0) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,1010)
1010    FORMAT(/,' Parameter file name ? ')
        READ(ITTI,1020) PRFILE
1020    FORMAT(A32)
       ELSE
        PRFILE = 'AUTOPRM'
      ENDIF
      IF(KMODEO.EQ.1) WRITE(IOBO,1030) PRFILE
1030  FORMAT(A32,T40,' File name')
      IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,1040) PRFILE
1040  FORMAT(/,'  File name: ',A32)
      IF(PRFILE(1:1).EQ.' ') GO TO 9000
      IF(KAUTOP.EQ.0) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,1050)
1050    FORMAT(' (R)ead or (W)rite parameter file ? <R> ')
        READ(ITTI,1060) QRW
1060    FORMAT(A1)
       ELSE
        QRW = 'W'
      ENDIF
      IF( QRW.NE.'W' .AND. QRW.NE.'w' ) QRW = 'R'
      IF(KMODEO.EQ.1) WRITE(IOBO,1070) QRW
1070  FORMAT(A1,T40,' Read/write')
      IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,1080) QRW
1080  FORMAT('  Read or write to parameter file: ',A1)
C *
C **  CHECK FILE FOR EXISTANCE AND CORRECT ID FOR CURRENT FILE
C *
C *  TEST FOR FILE EXISTANCE
C     INQUIRE(FILE=PRFILE,EXIST=EXISTS)
C     IF(EXISTS) GO TO 2200
C     IF( QRW.EQ.'W' .OR. QRW.EQ.'w' ) GO TO 2100
CIBM   IF YOU HAVE AN NON-IBM MACHINE, THEN REMOVE THE
CIBM   FOLLOWING STATEMENTS AND USE THE INQUIRE STATEMENT ABOVE.
      IF(KAUTOP.EQ.0) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,2010)
2010    FORMAT(' Does this parameter file currently exist ? <Y> ')
        READ(ITTI,1060) QANS
       ELSE
        QANS = 'N'
      ENDIF
      IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y'
      IF(KMODEO.EQ.1) WRITE(IOBO,2020) QANS
2020  FORMAT(A1,T40,' Parameter file exists')
      IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,2030) QANS
2030  FORMAT('  Parameter file exists: ',A1)
C *
C *  CHECK FOR AUTOPILOT AND/OR FILE EXISTANCE
      IF(KAUTOP.NE.0) GO TO 6000
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) GO TO 2200
      IF( QRW.EQ.'W' .OR. QRW.EQ.'w' ) GO TO 2100
CIBM
C *
C *  FILE DOES NOT EXIST
      WRITE(ITTO,2040)
2040  FORMAT(' --File does not exist and read specified:  Abort')
      GO TO 9000
C *
C *  FILE DOES NOT EXIST AND WRITE SPECIFIED... START A NEW ONE
CVAX
C2100  OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='NEW',FORM='FORMATTED',
C     1CARRIAGECONTROL='LIST')
CIBM
2100  OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='UNKNOWN',FORM='FORMATTED')
CIBM
      CALL DATE(QDATE)
      CALL TIME(QTIME)
      WRITE(IOPO,2110) IOFILE,QPTFID,QDATE,QTIME
2110  FORMAT(1X,A8,A32,5X,'Created:',1X,A9,1X,A8)
      CLOSE(UNIT=IOPO)
C *
C *  A FILE IS THERE... DETERMINE IF IT IS A PARAMETER FILE
2200  OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='OLD',ERR=2240)
      READ(IOPO,2210,END=2220) LINE72
2210  FORMAT(1X,A72)
      CLOSE(UNIT=IOPO)
      IF(LINEID.EQ.IOFILE) GO TO 2300
2220  WRITE(ITTO,2230)
2230  FORMAT(' --File does not exist or is not a parameter file.')
      GO TO 9000
2240  WRITE(ITTO,2250)
2250  FORMAT(' --File does not exist: abort.')
      GO TO 9000
C *
C *  PARAMETER FILE EXISTS... CHECK FOR CORRECT ID
2300  IF(LINEPT.EQ.QPTFID) GO TO 2400
      WRITE(ITTO,2310) LINEPT
2310  FORMAT(' -Parameter file for: ',A32,'. Use this file ? <N> ')
      READ(ITTI,1060) QANS
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS='N'
      IF(KMODEO.EQ.1) WRITE(IOBO,2320) QANS
2320  FORMAT(A1,T40,' Use foreign file')
      IF(KMODEO.EQ.2) WRITE(ITTO,2330) QANS
2330  FORMAT('  Use foreign file: ',A1)
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) GO TO 2400
      CLOSE (UNIT=IOPO)
      GO TO 9000
C *
C *  DO REQUESTED FUNCTION
2400  IF( QRW.EQ.'R' .OR. QRW.EQ.'r' ) GO TO 3000
      IF( QRW.EQ.'W' .OR. QRW.EQ.'w' ) GO TO 6000
C *  HMMMM.... WE SHOULD NOT BE HERE
      GO TO 9000
C *
C *****  READ THE PARAMETER FILE
C *
3000  OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='OLD',FORM='FORMATTED')
C *
C **  GET THE BACKGROUND INFORMATION
C *
3002  READ(IOPO,2210,END=4000) LINE72
      IF(LINEID.NE.IDBACK) GO TO 3002
      IF(KMODEO.NE.2) WRITE(ITTO,3004)
3004  FORMAT(/,' Read background parameters ? <Y> ')
      READ(ITTI,1060) QANS
      IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y'
      IF(KMODEO.EQ.1) WRITE(IOBO,3006) QANS
3006  FORMAT(A1,T40,' Read background params')
      IF(KMODEO.EQ.2) WRITE(ITTO,3008) QANS
3008  FORMAT(' Read background params: ',A1)
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 4000
C *
C *  BACKGROUND FOUND... READ IT.
      READ(IOPO,3010) LDEG,KBKGD,BKGSDV,CLY
3010  FORMAT(//,30X,I3,1X,I1,24X,E13.6,//,22X,E13.6)
      DO 3020 I=1,5,2
      IP1 = I + 1
      READ(IOPO,3030) CLC(I),CLC(IP1)
3030  FORMAT(22X,E13.6,24X,E13.6)
3020  CONTINUE
C *
C **  GET THE PEAK SEARCH RESULTS
C *
4000  REWIND (UNIT=IOPO)
4002  READ(IOPO,2210,END=5000) LINE72
      IF(LINEID.NE.IDSEAR) GO TO 4002
      IF(KMODEO.NE.2) WRITE(ITTO,4004)
4004  FORMAT(' Read peak search results ? <Y> ')
      READ(ITTI,1060) QANS
      IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y'
      IF(KMODEO.EQ.1) WRITE(IOBO,4006) QANS
4006  FORMAT(A1,T40,' Read search params')
      IF(KMODEO.EQ.2) WRITE(ITTO,4008) QANS
4008  FORMAT('  Read search parameters: ',A1)
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 5000
C *
C *  GET THE PARAMETERS USED IN THE SEARCH
      READ(IOPO,4010) PSIGMA,RELLOW,KNFND,KNSMO,KFFLT,KFMNT
4010  FORMAT(//,27X,F5.2,27X,F5.2,2(/,27X,I5,27X,I5),///)
C *
C *  GET THE PEAK INFORMATION
      BIGINT = 0.0
      NPEAK = 0
4030  READ(IOPO,4040,END=4100) IP,POS,LAMBDA,HGT,DSP,RI
4040  FORMAT(1X,I3,2X,F9.4,4X,I1,2X,F10.4,2X,F9.4,2X,F9.4)
      IF(IP.EQ.999) GO TO 5000
      NPEAK = NPEAK + 1
      PEAKS(NPEAK,1) = POS - CORPOS( POS )
      PEAKS(NPEAK,2) = HGT
      BIGINT = AMAX1( BIGINT, HGT )
      PEAKS(IP,4) = MAX( LAMBDA, 1 )
      GO TO 4030
4100  WRITE(ITTO,4110)
4110  FORMAT(/,' -Premature EOF hit: Continuing')
C *
C **  GET THE REFINED LINE PARAMETERS
C *
5000  REWIND (UNIT=IOPO)
5002  READ(IOPO,2210,END=11000) LINE72
      IF(LINEID.NE.IDREFN) GO TO 5002
      IF(KMODEO.NE.2) WRITE(ITTO,5004)
5004  FORMAT(' Read refined line results ? <Y> ')
      READ(ITTI,1060) QANS
      IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y'
      IF(KMODEO.EQ.1) WRITE(IOBO,5006) QANS
5006  FORMAT(A1,T40,' Read refined lines')
      IF(KMODEO.EQ.2) WRITE(ITTO,5008) QANS
5008  FORMAT('  Read refined line params: ',A1)
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 11000
C *
C *  SKIP THE HEADER RECORDS
      READ(IOPO,5009)
5009  FORMAT(///)
C *
C *  GET THE REFINED LINE INFORMATION
      BIGINT = 0.0
      NPEAK = 0
5010  READ(IOPO,4040,END=5100) IP,POS,LAMBDA,HGT,DSP,RI
      IF(IP.EQ.999) GO TO 11000
      NPEAK = NPEAK + 1
      PEAKS(NPEAK,1) = POS - CORPOS( POS )
      PEAKS(NPEAK,2) = HGT
      BIGINT = AMAX1( BIGINT, HGT )
      PEAKS(IP,4) = MAX( LAMBDA, 1 )
      GO TO 5010
5100  WRITE(ITTO,4110)
C *
C **  GET THE INSTRUMENT PARAMETERS FROM THE FILE
C *
11000 REWIND (UNIT=IOPO)
11002 READ(IOPO,2210,END=9000) LINE72
      IF(LINEID.NE.IDWSGP) GO TO 11002
      IF(KMODEO.NE.2) WRITE(ITTO,11004)
11004 FORMAT(' Read instrument parameters ? <Y> ')
      READ(ITTI,1060) QANS
      IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y'
      IF(KMODEO.EQ.1) WRITE(IOBO,11006) QANS
11006 FORMAT(A1,T40,' Read instrument parameters')
      IF(KMODEO.EQ.2) WRITE(ITTO,11008) QANS
11008 FORMAT('  Read instrument parameters: ',A1)
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 9000
C *
C *  BYPASS HEADER RECORD AND READ FILE IDENTIFIER
11100 READ(IOPO,2210) LINE72
      READ(IOPO,2210) QWGTTL
C *
C *  READ THE RADIATION PARAMETERS
      DO 11120 I=1,5
11120 READ(IOPO,11130) LINEID,WGRAD(I,1),WGRAD(I,2),ZERO,QDATE,QTIME
11130 FORMAT(1X,A10,3(1X,E13.6),1X,A9,1X,A8)
C *
C *  READ THE BACKGROUND PARAMETERS
      READ(IOPO,11130) LINEID,(WGBAK(I),I=1,3),QDATE,QTIME
      READ(IOPO,11130) LINEID,(WGBAK(I),I=4,6),QDATE,QTIME
C *
C *  READ THE PROFILE CALIBRATION PARAMETERS
      READ(IOPO,11130) LINEID,(WGPRO(1,I),I=1,3),QDATE,QTIME
      READ(IOPO,11130) LINEID,(WGPRO(2,I),I=1,3),QDATE,QTIME
      READ(IOPO,11130) LINEID,(WGPRO(3,I),I=1,3),QDATE,QTIME
      READ(IOPO,11130) LINEID,(WGPRO(4,I),I=1,3),QDATE,QTIME
C *
C *  READ THE TWO-THETA ERROR CURVE
      READ(IOPO,11130) LINEID,(WGCAL(I),I=1,3),QDATE,QTIME
      GO TO 9000
C *
C *****  WRITE PARAMETERS
C *
C **  WRITE THE BACKGROUND PARAMETERS
C *
6000  IF(KAUTOP.EQ.0) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,6002)
6002    FORMAT(/,' Write background parameters ? <N> ')
        READ(ITTI,1060) QANS
       ELSE
        QANS = 'Y'
      ENDIF
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS = 'N'
      IF(KMODEO.EQ.1) WRITE(IOBO,6004) QANS
6004  FORMAT(A1,T40,' Write background params')
      IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,6006) QANS
6006  FORMAT('  Write background params: ',A1)
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' .OR. KAUTOP.NE.0 ) GO TO 7000
C *
C *  OPEN OLD AND SCRATCH FILES
      OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='OLD')
CVAX
C      OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='NEW',FORM='FORMATTED',
C     1CARRIAGECONTROL='LIST')
CVAX
CIBM
      OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='UNKNOWN',FORM='FORMATTED')
CIBM
C *
C *  COPY OLD FILE... BYPASS OLD BACKGROUND PARAMETERS
6100  READ(IOPO,2210,END=6130) LINE72
      IF(LINEID.EQ.IDBACK) GO TO 6110
      WRITE(IOSC,2210) LINE72
      GO TO 6100
6110  WRITE(ITTO,6112)
6112  FORMAT(' -Replacing existing background parameters')
6115  READ(IOPO,2210,END=6130) LINE72
      IF(LINEID.NE.IDBACK) GO TO 6115
      GO TO 6100
6130  CLOSE(UNIT=IOPO)
C *
C *  WRITE THE NEW PARAMETERS
6200  CALL DATE( QDATE )
      CALL TIME( QTIME )
      WRITE(IOSC,6210) IDBACK,QDATE,QTIME
6210  FORMAT(1X,A8,36X,'Recorded:',1X,A9,1X,A8)
      WRITE(IOSC,6220)
6220  FORMAT(' * Background parameters:')
      WRITE(IOSC,6230) LDEG,KBKGD,BKGSDV,CLY
6230  FORMAT(/' Background form    : ',8X,I3,1X,I1,2X,
     1        ' Standard deviation : ',E13.6,//,
     1        ' Background constant: ',E13.6)
      DO 6240 I=1,5,2
      IP1 = I + 1
      WRITE(IOSC,6250) I,CLC(I),IP1,CLC(IP1)
6240  CONTINUE
6250  FORMAT(' Coefficient ',I4,'   : ',E13.6,2X,
     1       ' Coefficient ',I4,'   : ',E13.6)
      WRITE(IOSC,6210) IDBACK,QDATE,QTIME
C *
C *  COPY THE TEMP FILE BACK TO THE PERMANENT FILE
6300  REWIND (UNIT=IOSC)
CVAX
C      OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='NEW',FORM='FORMATTED',
C     1CARRIAGECONTROL='LIST')
CVAX
CIBM
      OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='UNKNOWN',FORM='FORMATTED')
CIBM
6310  READ(IOSC,2210,END=6399) LINE72
      WRITE(IOPO,2210) LINE72
      GO TO 6310
6399  CLOSE(UNIT=IOPO)
      CLOSE(UNIT=IOSC)
C *
C **  WRITE THE PEAK SEARCH PARAMETERS AND PEAKS FOUND
C *
7000  IF(KAUTOP.EQ.0) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,7002)
7002    FORMAT(' Write search results ? <N> ')
        READ(ITTI,1060) QANS
       ELSE
        QANS = 'N'
      ENDIF
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS = 'N'
      IF(KMODEO.EQ.1) WRITE(IOBO,7004) QANS
7004  FORMAT(A1,T40,' Write search results')
      IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,7006) QANS
7006  FORMAT('  Write search results: ',A1)
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' .OR. KAUTOP.NE.0 ) GO TO 8000
C *
C *  OPEN OLD AND NEW FILES
      OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='OLD')
CVAX
C      OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='NEW',FORM='FORMATTED',
C     1CARRIAGECONTROL='LIST')
CVAX
CIBM
      OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='UNKNOWN',FORM='FORMATTED')
CIBM
C *
C *  COPY OLD FILE... BYPASS OLD SEARCH SECTION
7100  READ(IOPO,2210,END=7120) LINE72
      IF(LINEID.EQ.IDSEAR) GO TO 7110
      WRITE(IOSC,2210) LINE72
      GO TO 7100
7110  WRITE(ITTO,7112)
7112  FORMAT(' -Replacing existing search results')
7115  READ(IOPO,2210,END=7120) LINE72
      IF(LINEID.NE.IDSEAR) GO TO 7115
      GO TO 7100
7120  CLOSE(UNIT=IOPO)
C *
C *  WRITE THE PARAMETERS USED IN THE SEARCH
7200  CALL DATE( QDATE )
      CALL TIME( QTIME )
      WRITE(IOSC,6210) IDSEAR,QDATE,QTIME
      WRITE(IOSC,7220)
7220  FORMAT(' *  Peak search results:')
      WRITE(IOSC,7230) PSIGMA,RELLOW,KNFND,KNSMO,KFFLT,KFMNT
7230  FORMAT(/2X,' STD devation threshold: ',F5.2,
     1        2X,' Min relative intensity: ',F5.2,/,
     1        2X,' Points used for search: ',I5,
     1        2X,' Points used for smooth: ',I5,/,
     1        2X,' Filter type           : ',I5,
     1        2X,' Filter moment         : ',I5)
C *
C *  LIST THE PEAK PARAMETERS
      WRITE(IOSC,7250)
7250  FORMAT(/,' NO.  TWO-THETA  REF  INT. (CPS)  D SPACING  REL. INT.',
     1       /,' ---  ---------  ---  ----------  ---------  ---------')
C *
C *  HAVE ANY PEAKS BEEN DETECTED?
      IF(NPEAK.EQ.0) GO TO 7300
C *
C *  PRINT ALL THE PEAK INFORMATION
      BIGINT = 0.0
      DO 7255 I=1,NPEAK
7255  IF(PEAKS(I,2).GT.BIGINT) BIGINT = PEAKS(I,2)
      BIGINT = BIGINT / 100.0
      DO 7260 IP=1,NPEAK
      POSC = PEAKS(IP,1) + CORPOS( PEAKS(IP,1) )
      RI = PEAKS(IP,2) / BIGINT
      LAMBDA = INT( PEAKS(IP,4) )
      DSP = WTABLE(LAMBDA,1) / ( 2.0*SIN(POSC*DTORD2) ) * 1.0E10
      WRITE(WID,7270) LAMBDA
7270  FORMAT(I1)
      IF(WID.EQ.'1') WID = ' '
      WRITE(IOSC,7280)IP,POSC,WID,PEAKS(IP,2),DSP,RI
7280  FORMAT(' ',I3,2X,F9.4,4X,A1,2X,F10.4,2X,F9.4,2X,F9.4)
7260  CONTINUE
C *
C *  WRITE END OF LIST MARKER
7300  WRITE(IOSC,7310)
7310  FORMAT(1X,'999')
      WRITE(IOSC,6210) IDSEAR,QDATE,QTIME
C *
C *  COPY THE TEMP FILE BACK TO THE PERMANENT FILE
7400  REWIND (UNIT=IOSC)
CVAX
C      OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='NEW',FORM='FORMATTED',
C     1CARRIAGECONTROL='LIST')
CVAX
CIBM
      OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='UNKNOWN',FORM='FORMATTED')
CIBM
7410  READ(IOSC,2210,END=7499) LINE72
      WRITE(IOPO,2210) LINE72
      GO TO 7410
7499  CLOSE(UNIT=IOPO)
      CLOSE(UNIT=IOSC)
C *
C **  WRITE THE REFINED LINE RESULTS
C *
8000  IF(KAUTOP.EQ.0) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,8002)
8002    FORMAT(' Write refined line results ? <N> ')
        READ(ITTI,1060) QANS
       ELSE
        QANS = 'Y'
      ENDIF
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' .AND.
     1    QANS.NE.'A' .AND. QANS.NE.'a' ) QANS = 'N'
      IF(KMODEO.EQ.1) WRITE(IOBO,8004) QANS
8004  FORMAT(A1,T40,' Write refined line results')
      IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,8006) QANS
8006  FORMAT('  Write refined line results: ',A1)
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' .AND.
     1    QANS.NE.'A' .AND. QANS.NE.'a' .OR. KAUTOP.NE.0 ) GO TO 10000
C *
C *  OPEN OLD AND NEW FILES
      OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='OLD')
CVAX
C      OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='NEW',FORM='FORMATTED',
C     1CARRIAGECONTROL='LIST')
CVAX
CIBM
      OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='UNKNOWN',FORM='FORMATTED')
CIBM
C *
C *  EXAMINE OLD FILE... COPY OR BYPASS EXISTING LINE PARAMETERS
C *
C *  LOOK FOR EXISTING DATA
8100  LAPPND = .FALSE.
      LHTEOF = .TRUE.
      NOLDLN = 0
8102  READ(IOPO,2210,END=8200) LINE72
      IF(LINEID.EQ.IDREFN) GO TO 8110
      WRITE(IOSC,2210) LINE72
      GO TO 8102
C *
C *  EXISTING DATA FOUND... COPY OR BYPASS
8110  LHTEOF = .FALSE.
      IF( QANS.EQ.'A' .OR. QANS.EQ.'a' ) LAPPND = .TRUE.
      IF(.NOT.LAPPND) WRITE(ITTO,8112)
8112  FORMAT(' -Replacing existing refinement results')
      IF(LAPPND) WRITE(ITTO,8114)
8114  FORMAT(' -Adding to exsiting refinement results')
C *  BYPASS THE HEADER RECORDS
      IF(LAPPND) WRITE(IOSC,2210) LINE72
      DO 8120 I=1,4
      READ(IOPO,2210,END=8199) LINE72
      IF(LAPPND) WRITE(IOSC,2210) LINE72
8120  CONTINUE
C *  GO THROUGH INDIVIDUAL LINE PARAMETERS
8130  READ(IOPO,2210,END=8199) LINE72
      IF( .NOT.LAPPND .AND. LINEID.NE.IDREFN ) GO TO 8130
      IF( .NOT.LAPPND .AND. LINEID.EQ.IDREFN ) GO TO 8200
      READ(LINE72(1:3),8140) NTEMP
8140  FORMAT(I3)
      IF(NTEMP.NE.999) THEN
        WRITE(IOSC,2210) LINE72
        NOLDLN = NTEMP
        GO TO 8130
      ENDIF
      READ(IOPO,2210,END=8252) LINE72
      GO TO 8252
C *
C *  UNEXPECTED EOF HIT... ABORT OPERATION
8199  WRITE(ITTO,8198)
8198  FORMAT(' --Unexpected EOF hit: Aborting operation')
      CLOSE(UNIT=IOPO)
      CLOSE(UNIT=IOSC)
      GO TO 10000
C *
C *  WRITE THE REFINED LINE PARAMTERS
8200  CALL DATE( QDATE )
      CALL TIME( QTIME )
      WRITE(IOSC,6210) IDREFN,QDATE,QTIME
      WRITE(IOSC,8220)
8220  FORMAT(' *  Refined line positions and intensities:')
C *
C *  LIST THE LINE POSITIONS AND INTENSITIES
      WRITE(IOSC,8250)
8250  FORMAT(/,' NO.  TWO-THETA  REF  INT. (CPS)  D SPACING  REL. INT.',
     1       /,' ---  ---------  ---  ----------  ---------  ---------')
C *
C *  HAVE ANY LINE BEEN REFINED?
8252  IF(KWSGLN.EQ.0) GO TO 8300
C *
C *  WRITE ALL THE REFINED LINE INFORMATION
      BIGINT = 0.0
      DO 8255 I=1,KWSGLN
8255  IF(WSGPAR(I,2).GT.BIGINT) BIGINT = WSGPAR(I,2)
      BIGINT = BIGINT / 100.0
      DO 8260 IP=1,KWSGLN
      POSC = WSGPAR(IP,1) + CORPOS( WSGPAR(IP,1) )
      RI = WSGPAR(IP,2) / BIGINT
      LAMBDA = NINT( WSGPAR(IP,12) )
      DSP = WTABLE(LAMBDA,1) / ( 2.0*SIN(POSC*DTORD2) ) * 1.0E10
      WRITE(WID,7270) LAMBDA
      IF(WID.EQ.'1') WID = ' '
      WRITE(IOSC,7280) IP+NOLDLN,POSC,WID,WSGPAR(IP,2),DSP,RI
8260  CONTINUE
C *
C *  WRITE END OF LIST MARKER
8300  WRITE(IOSC,7310)
      WRITE(IOSC,6210) IDREFN,QDATE,QTIME
C *
C *  COPY ANY MORE DATA FROM OLD FILE TO NEW
8310  IF(LHTEOF) GO TO 8399
      READ(IOPO,2210,END=8399) LINE72
      WRITE(IOSC,2210) LINE72
      GO TO 8310
8399  CLOSE(UNIT=IOPO)
C *
C *  COPY THE TEMP FILE BACK TO THE PERMANENT FILE
8400  REWIND (UNIT=IOSC)
CVAX
C      OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='NEW',FORM='FORMATTED',
C     1CARRIAGECONTROL='LIST')
CVAX
CIBM
      OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='UNKNOWN',FORM='FORMATTED')
CIBM
8410  READ(IOSC,2210,END=8499) LINE72
      WRITE(IOPO,2210) LINE72
      GO TO 8410
8499  CLOSE(UNIT=IOPO)
      CLOSE(UNIT=IOSC)
C *
C **  WRITE THE INSTRUMENT PARAMETERS
C *
10000 IF(KAUTOP.EQ.0) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,10002)
10002   FORMAT(' Write current instrument parameters ? <N> ')
        READ(ITTI,1060) QANS
       ELSE
        QANS = 'Y'
      ENDIF
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS = 'N'
      IF(KMODEO.EQ.1) WRITE(IOBO,10004) QANS
10004 FORMAT(A1,T40,' Write instrument parameters')
      IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,10006) QANS
10006 FORMAT('  Write current instrument parameters: ',A1)
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' .OR. KAUTOP.NE.0 ) GO TO 9000
C *
C *  OPEN OLD AND NEW FILES
      OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='OLD')
CVAX
C      OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='NEW',FORM='FORMATTED',
C     1CARRIAGECONTROL='LIST')
CVAX
CIBM
      OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='UNKNOWN',FORM='FORMATTED')
CIBM
C *
C *  COPY OLD FILE... BYPASS EXISTING INSTRUMENT PARAMETERS
10100 READ(IOPO,2210,END=10120) LINE72
      IF(LINEID.EQ.IDWSGP) GO TO 10110
      WRITE(IOSC,2210) LINE72
      GO TO 10100
10110 WRITE(ITTO,10112)
10112 FORMAT(' -Replacing existing instrument parameters')
10115 READ(IOPO,2210,END=10120) LINE72
      IF(LINEID.NE.IDWSGP) GO TO 10115
      GO TO 10100
10120 CLOSE(UNIT=IOPO)
C *
      CALL DATE( QDATE )
      CALL TIME( QTIME )
      WRITE(IOSC,6210) IDWSGP,QDATE,QTIME
      WRITE(IOSC,10130)
10130 FORMAT(' *  INS PARAMETERS:')
      WRITE(IOSC,2210) QWGTTL
C *
C *  READ THE RADIATION PARAMETERS
10200 ZERO = 0.0
      DO 10220 I=1,5
10220 WRITE(IOSC,10230) WGWAVE,WGRAD(I,1),WGRAD(I,2),ZERO,QDATE,QTIME
10230 FORMAT(1X,A10,3(1X,E13.6),1X,A9,1X,A8)
C *
C *  READ THE BACKGROUND PARAMETERS
      WRITE(IOSC,10230) WGBACK,(WGBAK(I),I=1,3),QDATE,QTIME
      WRITE(IOSC,10230) WGBACK,(WGBAK(I),I=4,6),QDATE,QTIME
C *
C *  READ THE PROFILE PARAMETERS
      WRITE(IOSC,10230) WGPROF,(WGPRO(1,I),I=1,3),QDATE,QTIME
      WRITE(IOSC,10230) WGPROF,(WGPRO(2,I),I=1,3),QDATE,QTIME
      WRITE(IOSC,10230) WGPROF,(WGPRO(3,I),I=1,3),QDATE,QTIME
      WRITE(IOSC,10230) WGPROF,(WGPRO(4,I),I=1,3),QDATE,QTIME
C *
C *  READ THE TWO-THETA ERROR CURVE
      WRITE(IOSC,10230) WGCALB,(WGCAL(I),I=1,3),QDATE,QTIME
C *
C *  WRITE END-OF-DATA MARKER
      WRITE(IOSC,6210) IDWSGP,QDATE,QTIME
C *
C *  COPY THE TEMP FILE BACK TO THE PERMANENT FILE
10300 REWIND (UNIT=IOSC)
CVAX
C      OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='NEW',FORM='FORMATTED',
C     1CARRIAGECONTROL='LIST')
CVAX
CIBM
      OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='UNKNOWN',FORM='FORMATTED')
CIBM
10310 READ(IOSC,2210,END=9000) LINE72
      WRITE(IOPO,2210) LINE72
      GO TO 10310
C *
C *  FINISIO
9000  CLOSE(UNIT=IOPO)
      CLOSE(UNIT=IOSC)
      RETURN
      END
C ***  WSGEVL - EVALUATE PARAMETERS ASSOCIATED WITH THE INSTRUMENT
C *
      SUBROUTINE WSGEVL
C *
      LOGICAL EXISTS, LPLOTS
      CHARACTER FILEID*17, FILEXX*17, LINEID*10, LINEXX*10
      CHARACTER QANS*1, QDATE*9, QTIME*8, LINE*72, QFTITL*80
      CHARACTER QTITLS(4)*20, QFILE*32
      CHARACTER WSGSET*18, WSGSXX*18
      PARAMETER ( FILEID = '*** PROFILE DATA ' , LINEID = '** SET ID ' )
      PARAMETER ( DTORD2=8.726646260E-3, RTODT2=114.591559 )
      PARAMETER ( DTOR  =1.745329252E-2, RTOD  =57.29577951 )
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3)
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF
      COMMON /WSGDAT/ KWSGLN,WSGPAR(200,12)
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /WDATA/ NWAVE,WTABLE(5,2)
      COMMON /COMSCR/ X(MPTS),Y(MPTS)
      COMMON /FLDATC/ QFTITL
      DIMENSION NCPLOT(4),OFFSET(4),NUMPEN(4),MARKER(4)
      EQUIVALENCE ( LINE(2:18) , FILEXX )
      EQUIVALENCE ( LINE(2:11) , LINEXX )
      EQUIVALENCE ( LINE(14:31), WSGSXX )
      DATA QTITLS(1)/'OBSERVED FWHM VALUES'/
      DATA QTITLS(2)/'SIZE ONLY FIT       '/
      DATA QTITLS(3)/'STRAIN ONLY FIT     '/
      DATA QTITLS(4)/'SIZE AND STRAIN FIT '/
C *
C *  DETERMINE FUNCTION
1000  IF(KMODEO.EQ.2) THEN
        WRITE(ITTO,1002)
1002    FORMAT('1',11X,'* * *   L I N E   L I S T   F U N C T I O N S',
     1  '   * * *')
       ELSE
        WRITE(ITTO,1004)
1004    FORMAT(/,' * Line list functions')
      ENDIF
      WRITE(ITTO,1006) KWSGLN
1006  FORMAT(/,' Total number of lines in list is :',I3)
      IF( KMODEO.NE.2 .AND. KAUTOP.EQ.0 ) WRITE(ITTO,1010)
1010  FORMAT(/,'   C - Clear line list',/,
     1         '   S - Size and/or strain analysis from line list',/,
     1         '   W - Write line list to profile data file',//,
     1         ' Choice ? ')
      IF(KAUTOP.EQ.0) THEN
        READ(ITTI,1020) QANS
1020    FORMAT(A1)
       ELSE
        QANS = 'W'
      ENDIF
      IF(KMODEO.EQ.1) WRITE(IOBO,1030) QANS
1030  FORMAT(A1,T40,' (C)lear, (S)ize/strain, (W)rite')
      IF( QANS.NE.'C' .AND. QANS.NE.'c' .AND.
     1    QANS.NE.'S' .AND. QANS.NE.'s' .AND.
     1    QANS.NE.'W' .AND. QANS.NE.'w' ) GO TO 9000
      IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,1040) QANS
1040  FORMAT(/,' (C)lear, (S)ize/strain analysis, (W)rite lines: ',A1)
C *
C *  DO IT
1200  IF( QANS.EQ.'C' .OR. QANS.EQ.'c' ) GO TO 2000
      IF( QANS.EQ.'S' .OR. QANS.EQ.'s' ) GO TO 3000
      IF( QANS.EQ.'W' .OR. QANS.EQ.'w' ) GO TO 4000
      GO TO 9000
C *
C **  CLEAR THE LINE LIST
C *
2000  DO 2010 I=1,200
      DO 2010 I2=1,11
2010  WSGPAR(I,I2) = 0.0
      KWSGLN = 0
      GO TO 9000
C *
C **  EVALUATE SIZE AND/OR STRAIN
C *
C *  DATA CAN BE PLOTTED.  CHECK FOR PLOTTING BY NAME...
3000  LPLOTS = .FALSE.
      IF(KMODEO.NE.2) WRITE(ITTO,3010)
3010  FORMAT(' Plot file name ? (* = NONE) <CPLOT> ')
      READ(ITTI,3020) QFILE
3020  FORMAT(A32)
      IF( QFILE.EQ.' ' .OR. QFILE.EQ.'/' ) QFILE = 'CPLOT'
      IF(KMODEO.EQ.1) THEN
        WRITE(IOBO,3022) QFILE
3022    FORMAT(A32,T40,' Plot file name (*=NO PLOTS)')
        WRITE(ITTO,3024)
3024    FORMAT(/,' -Batch setup active:  Command recorded')
        GO TO 9000
      ENDIF
      IF(KMODEO.EQ.2) WRITE(ITTO,3026) QFILE
3026  FORMAT('  Plot file name (*=NONE): ',A32)
      IF(QFILE.EQ.'*') GO TO 3100
      IF(KPTYPE.EQ.0) THEN
        OPEN(UNIT=IOPL,FILE=QFILE,STATUS='NEW',FORM='UNFORMATTED',
     1  ERR=3030)
       ELSE
CVAX
C        OPEN(UNIT=IOPL,FILE=QFILE,STATUS='NEW',FORM='FORMATTED',
C     1  CARRIAGECONTROL='LIST',ERR=3030)
CVAX
CIBM
        OPEN(UNIT=IOPL,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED',
     1  ERR=3030)
CIBM
      ENDIF
      LPLOTS = .TRUE.
      GO TO 3050
3030  WRITE(ITTO,3040)
3040  FORMAT(' --Can not open specified plot file')
      GO TO 3100
C *
C *  SET DEFAULT PARAMETERS
C *  OBSERVED DATA
3050  KPSETS(1) =  1
      NCPLOT(1) = -1
      OFFSET(1) =  0.0
      NUMPEN(1) =  1
      MARKER(1) =  1
C *  SIZE ONLY FIT
      KPSETS(2) =  2
      NCPLOT(2) =  1
      OFFSET(2) =  0.0
      NUMPEN(2) =  2
      MARKER(2) =  1
C *  STRAIN ONLY FIT
      KPSETS(3) =  3
      NCPLOT(3) =  1
      OFFSET(3) =  0.0
      NUMPEN(3) =  3
      MARKER(3) =  1
C *  SIZE AND STRAIN FIT
      KPSETS(4) =  4
      NCPLOT(4) =  1
      OFFSET(4) =  0.0
      NUMPEN(4) =  4
      MARKER(4) =  1
C *
C *  DETERMINE THE RANGE FOR THE PLOT FILE OUTPUT
      NPTS = 0
      STRT = 180.0
      FINS =   0.0
      DO 3060 I=1,KWSGLN
      IF(WSGPAR(I,3).LT.0.0002) GO TO 3060
      NPTS = NPTS + 1
      X(NPTS) = WSGPAR(I,1) + CORPOS( WSGPAR(I,1) )
      Y(NPTS) = WSGPAR(I,3)
      IF(X(NPTS).LT.STRT) STRT = X(NPTS)
      IF(X(NPTS).GT.FINS) FINS = X(NPTS)
3060  CONTINUE
      IF(NPTS.EQ.0) THEN
        STRT = 0.0
        FINS = 0.0
      ENDIF
      STRT = AINT( STRT/10.0 ) * 10.0
      FINS = AINT( FINS/10.0 ) * 10.0 + 10.0
C *
      NUMSTS = 4
      NPLOTS = 1
      IAXIS = 0
      DPI = 2.0
      IFS = 2
      KYID = 3
C *
C *  WRITE THE INITIAL INFORMATION TO THE PLOT FILE
      IF(KPTYPE.EQ.0) THEN
        WRITE(IOPL) QFTITL
        WRITE(IOPL) STRT,FINS,FAINC
        WRITE(IOPL) NUMSTS,NPLOTS,IAXIS,DPI,IFS,KYID
        WRITE(IOPL) QTITLS(1),NCPLOT(1),OFFSET(1),NUMPEN(1),MARKER(1)
        WRITE(IOPL) QTITLS(2),NCPLOT(2),OFFSET(2),NUMPEN(2),MARKER(2)
        WRITE(IOPL) QTITLS(3),NCPLOT(3),OFFSET(3),NUMPEN(3),MARKER(3)
        WRITE(IOPL) QTITLS(4),NCPLOT(4),OFFSET(4),NUMPEN(4),MARKER(4)
       ELSE
        WRITE(IOPL,3062) QFTITL
3062    FORMAT(A80)
        WRITE(IOPL,3064) STRT,FINS,FAINC
3064    FORMAT(3F10.4)
        WRITE(IOPL,3066) NUMSTS,NPLOTS,IAXIS,DPI,IFS,KYID
3066    FORMAT(3I6,F6.2,2I6)
        WRITE(IOPL,3068) QTITLS(1),NCPLOT(1),OFFSET(1),NUMPEN(1),
     1  MARKER(1)
3068    FORMAT(A20,I6,F6.2,2I6)
        WRITE(IOPL,3068) QTITLS(2),NCPLOT(2),OFFSET(2),NUMPEN(2),
     1  MARKER(2)
        WRITE(IOPL,3068) QTITLS(3),NCPLOT(3),OFFSET(3),NUMPEN(3),
     1  MARKER(3)
        WRITE(IOPL,3068) QTITLS(4),NCPLOT(4),OFFSET(4),NUMPEN(4),
     1  MARKER(4)
      ENDIF
C *
C *  DETERMINE IF THERE ARE ENOUGH POINTS TO EVALUATE
      IF(NPTS.LT.1) THEN
        WRITE(ITTO,3070)
3070    FORMAT(' --Not enough points for any type of analysis')
        CLOSE(UNIT=IOPL)
        GO TO 9000
      ENDIF
C *
C *  WRITE THE RAW DATA TO THE PLOT FILE
      IF(KPTYPE.EQ.0) THEN
        WRITE(IOPL) KPSETS(1),NPTS,0.0
        WRITE(IOPL) (X(I),Y(I),I=1,NPTS)
       ELSE
        WRITE(IOPL,3072) KPSETS(1),NPTS,0.0
3072    FORMAT(I6,I6,F10.4)
        WRITE(IOPL,3074) (X(I),Y(I),I=1,NPTS)
3074    FORMAT(2F10.4)
      ENDIF
C *
C *  EVALUATE SIZE
3100  NPTS = 0
      DO 3110 I=1,KWSGLN
      IF(WSGPAR(I,3).LT.0.0002) GO TO 3110
      TT = WSGPAR(I,1) + CORPOS( WSGPAR(I,1) )
      NPTS = NPTS + 1
      X(NPTS) = RTOD * WTABLE(1,1) / COS( TT * DTORD2 )
      Y(NPTS) = WSGPAR(I,3)
3110  CONTINUE
      CALL LINREG( X, Y, NPTS, SL, YINT, SLONLY, SDEV )
      SIZE = 1.0E9 / SLONLY
      WRITE(ITTO,3120) SIZE
3120  FORMAT(/,' X-ray crystallite size   :',F15.4,' NM',
     1  '    * SIZE ONLY *')
      IF(.NOT.LPLOTS) GO TO 3200
      NPTS = 100
      FINC = ( FINS - STRT ) / REAL( NPTS-1 )
      DO 3130 I=1,NPTS
      X(I) = STRT + REAL(I-1) * FINC
      X(I) = X(I) + CORPOS( X(I) )
      Y(I) = RTOD * WTABLE(1,1) * 1.0E9 / ( SIZE * COS(X(I)*DTORD2) )
3130  CONTINUE
      IF(KPTYPE.EQ.0) THEN
        WRITE(IOPL) KPSETS(2),NPTS,0.0
        WRITE(IOPL) (X(I),Y(I),I=1,NPTS)
       ELSE
        WRITE(IOPL,3072) KPSETS(2),NPTS,0.0
        WRITE(IOPL,3074) (X(I),Y(I),I=1,NPTS)
      ENDIF
C *
C *  EVALUATE STRAIN
3200  NPTS = 0
      DO 3210 I=1,KWSGLN
      IF(WSGPAR(I,3).LT.0.0002) GO TO 3210
      TT = WSGPAR(I,1) + CORPOS( WSGPAR(I,1) )
      NPTS = NPTS + 1
      X(NPTS) = RTOD * 4.0 * TAN( TT * DTORD2 )
      Y(NPTS) = WSGPAR(I,3)
3210  CONTINUE
      CALL LINREG( X, Y, NPTS, SL, YINT, SLONLY, SDEV )
      STRAIN = SLONLY
      WRITE(ITTO,3220) STRAIN
3220  FORMAT(/,' X-ray strain (delta-d/d) :',F15.8,'   ',
     1  '    * STRAIN ONLY *')
      IF(.NOT.LPLOTS) GO TO 3300
      NPTS = 100
      FINC = ( FINS - STRT ) / REAL( NPTS-1 )
      DO 3230 I=1,NPTS
      X(I) = STRT + REAL(I-1) * FINC
      X(I) = X(I) + CORPOS( X(I) )
      Y(I) = RTOD * 4.0 * STRAIN * TAN( X(I) * DTORD2 )
3230  CONTINUE
      IF(KPTYPE.EQ.0) THEN
        WRITE(IOPL) KPSETS(3),NPTS,0.0
        WRITE(IOPL) (X(I),Y(I),I=1,NPTS)
       ELSE
        WRITE(IOPL,3072) KPSETS(3),NPTS,0.0
        WRITE(IOPL,3074) (X(I),Y(I),I=1,NPTS)
      ENDIF
C *
C *  EVALUATE BOTH SIZE AND STRAIN
3300  NPTS = 0
      DO 3310 I=1,KWSGLN
      IF(WSGPAR(I,3).LT.0.0002) GO TO 3310
      NPTS = NPTS + 1
      TT = WSGPAR(I,1) + CORPOS( WSGPAR(I,1) )
      X(NPTS) = RTOD * 4.0 * SIN( TT * DTORD2 )
      Y(NPTS) = WSGPAR(I,3) * COS( TT * DTORD2 )
3310  CONTINUE
      IF(NPTS.LT.2) THEN
        WRITE(ITTO,3312)
3312    FORMAT(/,' -Too few points to evaluate size/strain ',
     1  'simultaneously')
        IF(LPLOTS) CLOSE(UNIT=IOPL)
        GO TO 9000
      ENDIF
      CALL LINREG( X, Y, NPTS, SL, YINT, SLONLY, SDEV )
      STRAIN = SL
      SIZE = RTOD * WTABLE(1,1) * 1.0E9 / YINT
      WRITE(ITTO,3320) SIZE,STRAIN
3320  FORMAT(/,' X-ray crystallite size   :',F15.4,' NM',
     1 '    * SIZE AND STRAIN *',/,
     1         ' X-RAY STRAIN (DELTA-D/D) :',F15.8,'   ',
     1 '    * SIZE AND STRAIN *')
      IF(.NOT.LPLOTS) GO TO 9000
      NPTS = 100
      FINC = ( FINS - STRT ) / REAL( NPTS-1 )
      DO 3330 I=1,NPTS
      X(I) = STRT + REAL(I-1) * FINC
      X(I) = X(I) + CORPOS( X(I) )
      Y(I) = RTOD * WTABLE(1,1) / ( SIZE*1.0E-9 * COS(X(I)*DTORD2) )
     1     + RTOD * 4.0 * STRAIN * TAN( X(I) * DTORD2 )
3330  CONTINUE
      IF(KPTYPE.EQ.0) THEN
        WRITE(IOPL) KPSETS(4),NPTS,STRT
        WRITE(IOPL) (X(I),Y(I),I=1,NPTS)
       ELSE
        WRITE(IOPL,3072) KPSETS(4),NPTS,STRT
        WRITE(IOPL,3074) (X(I),Y(I),I=1,NPTS)
      ENDIF
      CLOSE(UNIT=IOPL)
      GO TO 9000
C *
C **  WRITE TO PROFILE DATA FILE
C *
4000  IF( KMODEO.NE.2 .AND. KAUTOP.EQ.0 ) WRITE(ITTO,4010)
4010  FORMAT(/,' Profile file name ? <WSGPRO> ')
      IF(KAUTOP.EQ.0) THEN
        READ(ITTI,4020) QFILE
4020    FORMAT(A32)
       ELSE
        QFILE = 'AUTOPRO'
      ENDIF
      IF( QFILE.EQ.' ' .OR. QFILE.EQ.'/' ) QFILE = 'WSGPRO'
      IF(KMODEO.EQ.1) WRITE(IOBO,4030) QFILE
4030  FORMAT(A32,T40,' Profile file name')
      IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,4040) QFILE
4040  FORMAT('  File name: ',A32)
C *
C **  GET THE DATA SET IDENTIFIER
      IF( KMODEO.NE.2 .AND. KAUTOP.EQ.0 ) WRITE(ITTO,4050)
4050  FORMAT(/,' 18 character set identifier ? ')
      IF(KAUTOP.EQ.0) THEN
        READ(ITTI,4060) WSGSET
4060    FORMAT(A18)
       ELSE
        WSGSET = 'WRITTEN BY AUTO'
      ENDIF
      IF(KMODEO.EQ.1) WRITE(IOBO,4070) WSGSET
4070  FORMAT(A18,T40,' Date set ID')
      IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,4080) WSGSET
4080  FORMAT('  Data set identifier: ',A18)
C *
C *  IF BATCH SETUP... WE ARE FINISHED
      IF(KMODEO.EQ.1) THEN
CIBM
        QANS = 'N'
        WRITE(IOBO,4130) QANS
CIBM
        WRITE(ITTO,3024)
        GO TO 9000
      ENDIF
C *
C *  TEST FOR FILE EXISTANCE
CVAX
C     INQUIRE(FILE=QFILE,EXIST=EXISTS)
C     IF(.NOT.EXISTS) GO TO 4300
CVAX
CIBM   IF YOU HAVE AN NON-IBM MACHINE, THEN REMOVE THE
CIBM   FOLLOWING STATEMENTS AND USE THE INQUIRE STATEMENT ABOVE.
      IF(KMODEO.NE.2) WRITE(ITTO,4110)
4110  FORMAT(' Does this profile file currently exist ? <Y> ')
      READ(ITTI,1020) QANS
      IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y'
      IF(KMODEO.EQ.1) WRITE(IOBO,4130) QANS
4130  FORMAT(A1,T40,' Profile file exists')
      IF(KMODEO.EQ.2) WRITE(ITTO,4140) QANS
4140  FORMAT('  Profile file exists: ',A1)
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 4300
CIBM
C *
C *  A FILE IS THERE... DETERMINE IF IT IS A PROFILE FILE
4200  OPEN(UNIT=IOLO,FILE=QFILE,STATUS='OLD',ERR=4220)
      READ(IOLO,4210,END=4220) LINE
4210  FORMAT(A72)
      IF(FILEXX.EQ.FILEID) GO TO 4400
C *  FILE EXISTS BUT NOT A PROFILE DATA FILE...
4220  WRITE(ITTO,4230)
4230  FORMAT(' --File is not a profile data file.')
      CLOSE(UNIT=IOLO)
      GO TO 9000
C *
C *  PROFILE FILE DOES NOT EXIST... CREATE ONE
CVAX
C4300  OPEN(UNIT=IOLO,FILE=QFILE,STATUS='NEW',FORM='FORMATTED',
C     1CARRIAGECONTROL='LIST')
CVAX
CIBM
4300  OPEN(UNIT=IOLO,FILE=QFILE,STATUS='NEW',FORM='FORMATTED')
CIBM
      CALL DATE(QDATE)
      CALL TIME(QTIME)
      WRITE(IOLO,4310) FILEID,QDATE,QTIME
4310  FORMAT(1X,A17,29X,'Filed:',1X,A9,1X,A8)
C *
C *  OPEN TEMPORARY FILE TO COPY EXISTING DATA
4400  REWIND (UNIT=IOLO)
CVAX
C      OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='NEW',FORM='FORMATTED',
C     1CARRIAGECONTROL='LIST')
CVAX
CIBM
      OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='UNKNOWN',FORM='FORMATTED')
CIBM
C *
C *  COPY OLD FILE... BYPASS OLD DATA SET WITH SAME NAME
4500  READ(IOLO,4210,END=4510) LINE
      IF(WSGSET.EQ.WSGSXX) GO TO 4520
4550  WRITE(IOSC,4210) LINE
      GO TO 4500
4520  WRITE(ITTO,4530)
4530  FORMAT(' -Replacing profile data set with same identifier')
4540  READ(IOLO,4210,END=4510) LINE
      IF(WSGSET.NE.WSGSXX) GO TO 4540
      GO TO 4500
4510  CLOSE(UNIT=IOLO)
C *
C *  WRITE THE NEW PARAMETERS
4600  CALL DATE(QDATE)
      CALL TIME(QTIME)
      WRITE(IOSC,4610) LINEID,WSGSET,KWSGLN,QDATE,QTIME
4610  FORMAT(1X,A10,1X,'>',A18,'<  ',I3,' LINES ',A9,1X,A8)
      DO 4620 I=1,KWSGLN
4620  WRITE(IOSC,4630) WSGPAR(I,1),WSGPAR(I,2),INT(WSGPAR(I,11)),
     1  (WSGPAR(I,J),J=3,10)
4630  FORMAT(1X,F8.4,2X,F10.2,10X,'Profile: ',I3,/,
     1  2(6X,E13.6,1X,E13.6,1X,E13.6,1X,E13.6,/))
      WRITE(IOSC,4610) LINEID,WSGSET,KWSGLN,QDATE,QTIME
C *
C *  COPY THE TEMP FILE BACK TO THE PERMANENT FILE
4700  REWIND (UNIT=IOSC)
CVAX
C      OPEN(UNIT=IOLO,FILE=QFILE,STATUS='NEW',FORM='FORMATTED',
C     1CARRIAGECONTROL='LIST')
CVAX
CIBM
      OPEN(UNIT=IOLO,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED')
CIBM
4710  READ(IOSC,4210,END=4799) LINE
      WRITE(IOLO,4210) LINE
      GO TO 4710
4799  CLOSE(UNIT=IOLO)
      CLOSE(UNIT=IOSC)
C *
C *  SUBJOB COMPLETE
9000  RETURN
      END
C ***  LINREG - CARRIES OUT A LINEAR REGRESSION ANALYSIS
C *
      SUBROUTINE LINREG( X, Y, NPTS, SLOPE, YINT, SLONLY, STDEV)
C *
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      REAL X,Y,SLOPE,YINT,STDEV,SLONLY
      DIMENSION X(NPTS),Y(NPTS)
C *
C *  CRUNCH DATA
      Z = DBLE( NPTS )
      SUMX = 0.0D00
      SUMY = 0.0D00
      SUMXY = 0.0D00
      SUMXS = 0.0D00
      SUMYS = 0.0D00
      DO 100 J=1,NPTS
      SUMX = SUMX + X(J)
      SUMXS = SUMXS + X(J)**2
      SUMY = SUMY + Y(J)
      SUMYS = SUMYS + Y(J)**2
      SUMXY = SUMXY + X(J)*Y(J)
100   CONTINUE
      XBAR = SUMX/Z
      YBAR = SUMY/Z
      XS1 = Z*SUMXY - SUMX*SUMY
      XS2 = Z*SUMXS - SUMX*SUMX
      DSLOPE = XS1/XS2
      DSLONL = SUMXY/SUMXS
      DYINT = YBAR - DSLOPE*XBAR
      IF(NPTS.GT.2) THEN
        VY1 = ( SUMXY - XBAR*SUMY )**2
        VY2 = SUMXS - XBAR*SUMX
        VARY = ( SUMYS - YBAR*SUMY - VY1/VY2 ) / ( Z - 2.D00 )
        DSTDEV = DSQRT( VARY )
       ELSE
        VARY = 99.99
        DSTDEV = 99.99
      ENDIF
C *
C *  COMPUTE COEFFICIENT OF DETERMINATION
C *
C     RS0 = ( SUMXY - (SUMX*SUMY)/Z )**2
C     RS1 = SUMXS - (SUMX**2)/Z
C     RS2 = SUMYS - (SUMY**2)/Z
C     RSQ = RS0 / ( RS1*RS2 )
C *
C *  RETURN
      SLOPE = DSLOPE
      SLONLY = DSLONL
      YINT = DYINT
      STDEV = DSTDEV
      RETURN
      END
C ***  PROGRAM: SHADOW  (SHADOW30)
C ***  VERSION: 860822  (YYMMDD)
C *
C ***  PKREFN  - PERFORM PROFILE REFINEMENT
C *
      SUBROUTINE PKREFN
C *
      LOGICAL LFIRST, LBYPAS
      CHARACTER QANS*1, QFTITL*80
      PARAMETER ( DTOR=1.745329252E-02, RTOD=57.29577951 )
      PARAMETER ( DTORD2=8.72664626E-03 )
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 )
      PARAMETER ( MEMSCR = 12000 )
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201)
      COMMON /VECTOR/ NVECS,BVECS(MEMVT2),BMINS(MEMV),BMAXS(MEMV)
      COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /SCRTCH/ SCRDAT(MEMSCR),IPOINT(MEMV,4)
      COMMON /WSGDAT/ KWSGLN,WSGPAR(200,12)
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /OPTRES/ RERR,RESID,ICON,ITER
      COMMON /MATRIX/ AMAT(MEMV,MEMVP1)
C *
C *  SET FIRST PASS THROUGH FLAG AND OPEN SCRATCH FILE
      LFIRST = .TRUE.
      OPEN(UNIT=IOSC,STATUS='SCRATCH',FORM='UNFORMATTED')
      KNUMCU = 0
C *
1000  IF(KMODEO.EQ.2) THEN
        WRITE(ITTO,1001)
1001    FORMAT('1',14X,'* * *   P R O F I L E   R E F I N E M E N T',
     1  '   * * *')
       ELSE
        WRITE(ITTO,1002)
1002    FORMAT(/,' *  Profile refinement')
      ENDIF
C *
C *  SET A DEFAULT PROFILE-SHAPE-FUNCTION
      JKPROF = 11
C *
C ***  PARAMETER INITIALIZATION
C *
1100  KPROF = JKPROF
      CALL PROINT( LFIRST )
      JKPROF = KPROF
      IF(NVECS.EQ.0) GO TO 9000
C *
C ***  PLOT FILE INITIALIZATION
C *
      IF(LFIRST) CALL RFPLOT
C *
C *  SELECTION OF REFINEMENT TECHNIQUE
C *
1400  LBYPAS = .FALSE.
      IREFN = 1
      IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,1410)
1410    FORMAT(/,' Refinement, (G)auss-Newton, (M)arquardt or',
     1  ' (B)ypass ? <G> ')
        READ(ITTI,1720) QANS
       ELSE
        QANS = 'G'
      ENDIF
      IF( QANS.EQ.'B' .OR. QANS.EQ.'b' ) THEN
        LBYPAS = .TRUE.
       ELSE IF( QANS.EQ.'M' .OR. QANS.EQ.'m' ) THEN
        IREFN = 0
       ELSE
        QANS = 'G'
      ENDIF
      IF(KMODEO.EQ.1) WRITE(IOBO,1417) QANS
1417  FORMAT(A1,T40,'Refinement: (G)auss (M)arq (B)ypass')
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,1420) QANS
1420  FORMAT(' (G)auss-Newton, (M)arquardt or (B)ypass refinement: ',A1)
C *
C **  PERFORM PROFILE REFINEMENT
C *
C *  BYPASS REFINEMENT OF THIS REGION IF BYPASS FLAG SET
      IF(LBYPAS) THEN
        WRITE(ITTO,1416)
1416    FORMAT(/,' -Bypassing refinement of this region')
        GO TO 1700
      ENDIF
C *
C *  BYPASS REFINEMENT OF THIS REGION IF IN BATCH SETUP MODE
      IF(KMODEO.EQ.1) THEN
        WRITE(ITTO,1430)
1430    FORMAT(/,' -Batch setup mode active, bypassing refinement')
        GO TO 1700
      ENDIF
C *
C *  MAXIMUM ITERATION LIMIT
1500  ITER = 20
C *
C *  REFINE THE LINE PARAMETERS WITH MARQUARDT TECHNIQUE
      CALL BSOLVE( IREFN )
C *
C *  PULL THE OPTIMIZED PARAMETERS FROM BVECS
      CALL PMSORT( BVECS )
C *
C *  MAKE THE BACKGROUND AVAILABLE
      IF( KBKGR.EQ.1 .OR. KBKGR.EQ.3 ) CALL BKGLVL( YBKG )
C *
C *  OUTPUT THE RESULTS
      CALL PRMOUT
C *
C *  CYCLE THROUGH AGAIN....
C *
1700  IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2)WRITE(ITTO,1710)
1710    FORMAT(/,' Add line(s) and/or repeat refinement ? <N> ')
        READ(ITTI,1720) QANS
1720    FORMAT(A1)
       ELSE
        QANS = 'N'
      ENDIF
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS = 'N'
      IF(KMODEO.EQ.1) WRITE(IOBO,1730) QANS
1730  FORMAT(A1,T40,'Repeat refinement cycle')
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,1735) QANS
1735  FORMAT(/,' Repeat refinement cycle: ',A1)
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) GO TO 1800
C *  ADD ADDITIONAL REFLECTIONS IF REQUESTED
      IF(KAUTOP.NE.1) CALL PKADD
      GO TO 1400
C *
C **  RECORD THE REFINED LINE PARAMETERS
C *
1800  IF(LBYPAS) GO TO 1900
      DO 1810 I=1,KNLIN
      KWSGLN = MIN( KWSGLN+1, 200 )
      DO 1820 I2=1,KNPRM
1820  WSGPAR(KWSGLN,I2) = PLPRM(I,I2)
      WSGPAR(KWSGLN,2) = WSGPAR(KWSGLN,2) / FTIME
      WSGPAR(KWSGLN,11) = REAL( KPROF )
      WSGPAR(KWSGLN,12) = REAL( KRLIN(I) )
      IF(KCRYS.GT.0) WSGPAR(KWSGLN,3) = PLPRM(I,3)
1810  CONTINUE
C *
C *  GENERATE THE PLOT RESULTS
      IF( KPPLOT.GT.0 .AND. KMODEO.NE.1 ) CALL PRMPLT
C *
C *  SPLIT COMPOUND LINES IF NOT ALREADY DONE
      IF( KPPLOT.EQ.0 .AND. KMODEO.NE.1 ) CALL PKSPLT
C *
C *  WRITE THE CORRECTED PATTERN...
1900  IF(LFIRST) CALL PATWRI
C *
C *  DO IT ALL AGAIN
      LFIRST = .FALSE.
      GO TO 1100
C *
C *  EXIT EXIT EXIT EXIT EXIT RETURN
9000  IF(KPPLOT.NE.0) CLOSE(UNIT=IOPL)
      CLOSE(UNIT=IOSC)
      RETURN
      END
C ****  PMSORT - PULLS LINE PARAMETERS FROM THE OPTIMIZATION ARRAYS
C *
      SUBROUTINE PMSORT( PAIN )
C *
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 )
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201)
      COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2)
      COMMON /DIAGS/ ISENSE(10)
      DIMENSION PAIN(MEMVT2)
C *
C *  THE DATA COMES OUT BY KNPRMS FOR THE LINE ENTRIES.
C *  IF KPROF IS NEGATIVE THEN ALL PROFILES HAVE THE SAME VALUES FOR ALL
C *  VARIABLES EXCEPT THAT EACH WILL HAVE ITS OWN POSITION AND HEIGHT.
C *
400   NEXT = 0
      IF(KNLIN.EQ.0) GO TO 500
C *
C *  GET THE REGULAR COEFFICIENTS
      IF(KPROF.LT.0) GO TO 450
      DO 410 I=1,KNLIN
      DO 420 J=1,KNPRM
      NEXT = NEXT + 1
      PLPRM(I,J) = PAIN(NEXT)
420   CONTINUE
410   CONTINUE
      GO TO 500
C *
C *  GET THE COEFFICIENTS FOR THE CONSTRAINED CURVES
450   DO 460 J=1,KNPRM
      NEXT = NEXT + 1
      PLPRM(1,J) = PAIN(NEXT)
460   CONTINUE
      IF(KNLIN.GT.1) THEN
        DO 470 I=2,KNLIN
        NEXT = NEXT + 1
        PLPRM(I,1) = PAIN(NEXT)
        NEXT = NEXT + 1
        PLPRM(I,2) = PAIN(NEXT)
        DO 480 J=3,KNPRM
480     PLPRM(I,J) = PLPRM(1,J)
470     CONTINUE
      ENDIF
C *
C *  RECOVER BACKGROUND IF IT IS BEING REFINED
500   IF( KBKGR.EQ.1 .OR. KBKGR.EQ.3 ) THEN
        NEXT = NEXT + 1
        BKGPAR = PAIN(NEXT)
      ENDIF
C *
C *  RECOVER ASYMMETRY PARAMETER IF BEING REFINED
      IF(KASYM.NE.0) THEN
        NEXT = NEXT + 1
        ASYPAR = PAIN(NEXT)
      ENDIF
C *
C *  RECOVER THE AMORPHOUS PROFILE PARAMETERS IF BEING REFINED
      IF(KAMOR.NE.0) THEN
        DO 560 I=1,3
        NEXT = NEXT + 1
        AMOPAR(I) = PAIN(NEXT)
560     CONTINUE
      ENDIF
C *
C *  RECOVER PARTICLE SIZE PARAMETER
      IF( KCRYS.EQ.1 .OR. KCRYS.EQ.3 ) THEN
        NEXT = NEXT + 1
        CRYPAR(1) = PAIN(NEXT)
      ENDIF
C *
C *  RECOVER PARTICLE STRAIN PARAMETER
      IF( KCRYS.EQ.2 .OR. KCRYS.EQ.3 ) THEN
        NEXT = NEXT + 1
        CRYPAR(2) = PAIN(NEXT)
      ENDIF
C *
C *  OUTPUT PARAMETER VALUES
700   IF(ISENSE(2).EQ.0) GO TO 9000
      NS = 1
      NE = KNPRM
      DO 710 I=1,KNLIN
      WRITE(ITTO,720) I,(PAIN(J),J=NS,NE)
720   FORMAT(1X,I3,2X,F8.4,2X,F10.2,:,/,6X,2(4(1X,E12.5),/))
      NS = NS + KNPRM
      NE = NE + KNPRM
710   CONTINUE
      IF(KASYM.EQ.1) WRITE(ITTO,730) ASYPAR
730   FORMAT(' ASYPAR = ',F10.4)
      IF(KAMOR.EQ.1) WRITE(ITTO,740) AMOPAR
740   FORMAT(' AMOPAR = ',3(1X,F10.4))
      IF(KCRYS.GT.0) WRITE(ITTO,750) CRYPAR
750   FORMAT(' CRYPAR = ',2(1X,F15.4))
      IF(KBKGR.EQ.1) WRITE(ITTO,760) BKGPAR
760   FORMAT(' BKGPAR = ',F10.4)
C *
9000  RETURN
      END
C ***  SHADOW - GENERATE THE PROFILE IN TARGET ARRAY
C *
C *     IF IPNUM = - 1  GENERATE THE AMORPHOUS PROFILE ONLY
C *     IF IPNUM =   0  GENERATE BACKGROUND ONLY
C *     IF IPNUM =   N  GENERATE THE NTH PROFILE ONLY
C *     IF IPNUM = 999  GENERATE ALL PROFILES AND BACKGROUND
C *
      SUBROUTINE SHADOW( TARGET, IPNUM, ILO, IHI )
C *
      CHARACTER QFTITL*80
      PARAMETER ( DTOR=1.745329252E-02, RTOD=57.29577951 )
      PARAMETER ( DTORD2=8.72664626E-03 )
      PARAMETER ( SQRTPI=1.772453851 )
      PARAMETER ( PEPS = 0.1000 )
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201)
      COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2)
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /WDATA/ NWAVE,WTABLE(5,2)
      COMMON /PDATA/ BANG, EANG
      COMMON /DIAGS/ ISENSE(10)
      COMMON /FLDATC/ QFTITL
      DIMENSION TARGET(MPTS)
C *
C **  TARGET IS ALWAYS ZEROED BEFORE USE
C *
100   DO 110 I=1,KOBS
110   TARGET(I) = 0.0
C *
C **  IF AN AMORPHOUS PROFILE IS USED... GENERATE IT NOW
C *
300   IF(KAMOR.EQ.0) GO TO 400
      IF( IPNUM.NE.999 .AND. IPNUM.NE.-1 ) GO TO 400
      TT = AMOPAR(1)
      YI = AMOPAR(2)
      AX = AMOPAR(3)
      CALL GAUSSN(TARGET,1,TT,YI,AX,ILO,IHI)
      IF(IPNUM.EQ.999) KLLIN(KNLIN+1) = IHI*16384 + ILO
      IF(IPNUM.EQ.-1) GO TO 800
C *
C *  REPEAT FOR ALL LINES IN THE PATTERN
C *
400   DO 410 IPEAK = 1,KNLIN
C *
C *  DONT GENERATE ANY UNECESSARY LINES...
      IF( IPNUM.NE.IPEAK .AND. IPNUM.NE.999 ) GO TO 410
C *
C *  SORT PEAK PARAMETERS
      TT = PLPRM( IPEAK, 1 )
      YI = PLPRM( IPEAK, 2 )
      AX = PLPRM( IPEAK, 3 )
      BX = PLPRM( IPEAK, 4 )
      CX = PLPRM( IPEAK, 5 )
      DX = PLPRM( IPEAK, 6 )
      EX = PLPRM( IPEAK, 7 )
      FX = PLPRM( IPEAK, 8 )
      GX = PLPRM( IPEAK, 9 )
      HX = PLPRM( IPEAK,10 )
C *
C *  FIND THE CENTER OF THIS PROFILE
      ICNTR = INT( (TT-YANG(1))/FAINC + 0.1 ) + 1
C *
C *  SYNTHESIZE CORRECT PROFILE
700   JKPROF = IABS( KPROF )
      GO TO(1000,2000,3000,4000,5000,6000,7000,8000,9000,
     1      10000,11000,12000,13000,14000,14000,14000),JKPROF
C *
C **  GENERATE A LORENTZIAN PROFILE
C *
1000  TMP = 1.0 / (AX/2.0)**2
C *  LOW ANGLE SIDE
      ILO = 1
      IF(ICNTR.LT.1) GO TO 1100
      DO 1010 IP=ICNTR,1,-1
      XP = YI / ( 1.0 + TMP * ( YANG(IP)-TT )**2 )
      IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT )
      IF(XP.LT.PEPS) GO TO 1020
      TARGET(IP) = TARGET(IP) + XP
C     IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP)
C1    FORMAT(' ANG,OBS,YINT = ',F8.2,2X,F8.2,2X,F8.2)
1010  CONTINUE
      IP = 0
1020  ILO = MIN( IP+1, ICNTR )
C *  HIGH ANGLE SIDE
1100  IHI = KOBS
      IF(ICNTR.GE.KOBS) GO TO 420
      DO 1130 IP=ICNTR+1,KOBS
      XP = YI / ( 1.0 + TMP * ( YANG(IP)-TT )**2 )
      IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT )
      IF(XP.LT.PEPS) GO TO 1140
      TARGET(IP) = TARGET(IP) + XP
C     IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP)
1130  CONTINUE
      IP = KOBS + 1
1140  IHI = MAX( IP-1, ICNTR+1 )
      GO TO 420
C *
C **  MODIFIED LORENTZIAN
C *
2000  TMP = 0.4142135624 / (AX/2.0)**2
C *  LOW ANGLE SIDE
      ILO = 1
      IF(ICNTR.LT.1) GO TO 2100
      DO 2010 IP=ICNTR,1,-1
      XP = YI / ( 1.0 + TMP * ( YANG(IP)-TT )**2 )**2
      IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT )
      IF(XP.LT.PEPS) GO TO 2020
      TARGET(IP) = TARGET(IP) + XP
C     IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP)
2010  CONTINUE
      IP = 0
2020  ILO = MIN( IP+1, ICNTR )
C *  HIGH ANGLE SIDE
2100  IHI = KOBS
      IF(ICNTR.GE.KOBS) GO TO 420
      DO 2130 IP=ICNTR+1,KOBS
      XP = YI / ( 1.0 + TMP * ( YANG(IP)-TT )**2 )**2
      IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT )
      IF(XP.LT.PEPS) GO TO 2140
      TARGET(IP) = TARGET(IP) + XP
C     IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP)
2130  CONTINUE
      IP = KOBS + 1
2140  IHI = MAX( IP-1, ICNTR+1 )
      GO TO 420
C *
C **  INTERMEDIATE LORENTZIAN
C *
3000  TMP = 0.587401052 / (AX/2.0)**2
C *  LOW ANGLE SIDE
      ILO = 1
      IF(ICNTR.LT.1) GO TO 3100
      DO 3010 IP=ICNTR,1,-1
      XP = YI / ( 1.0 + TMP * ( YANG(IP)-TT )**2 )**1.5
      IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT )
      IF(XP.LT.PEPS) GO TO 3120
      TARGET(IP) = TARGET(IP) + XP
C     IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP)
3010  CONTINUE
      IP = 0
3120  ILO = MIN( IP+1, ICNTR )
C *  HIGH ANGLE SIDE
3100  IHI = KOBS
      IF(ICNTR.GE.KOBS) GO TO 420
      DO 3130 IP=ICNTR+1,KOBS
      XP = YI / ( 1.0 + TMP * ( YANG(IP)-TT )**2 )**1.5
      IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT )
      IF(XP.LT.PEPS) GO TO 3140
      TARGET(IP) = TARGET(IP) + XP
C     IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP)
3130  CONTINUE
      IP = KOBS + 1
3140  IHI = MAX( IP-1, ICNTR+1 )
      GO TO 420
C *
C **  PEARSON VII
C *
4000  CALL PEARSN(TARGET,0,TT,YI,AX,BX,AX,BX,ILO,IHI)
      GO TO 420
C *
C **  GAUSSIAN
C *
5000  CALL GAUSSN(TARGET,0,TT,YI,AX,ILO,IHI)
      GO TO 420
C *
C **  VOIGT PROFILE,  AX=BETAG, BX=BETAC
C *
6000  ILO = 1
      IF(ICNTR.LT.1) GO TO 6100
      DO 6010 IP=ICNTR,1,-1
      ARG1 = SQRTPI * ABS( YANG(IP)-TT ) / AX
      ARG2 = BX / ( SQRTPI * AX )
      XP = YI * BX * CERRFC( ARG1, ARG2 )
      IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT )
      IF(XP.LT.PEPS) GO TO 6020
      TARGET(IP) = TARGET(IP) + XP
C     IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP)
6010  CONTINUE
      IP = 1
6020  ILO = MIN( IP+1, ICNTR )
C *  HIGH ANGLE SIDE
6100  IHI = KOBS
      IF(ICNTR.GE.KOBS) GO TO 420
      DO 6130 IP=ICNTR+1,KOBS
      ARG1 = SQRTPI * ABS( YANG(IP)-TT ) / AX
      ARG2 = BX / ( SQRTPI * AX )
      XP = YI * BX * CERRFC( ARG1, ARG2 )
      IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT )
      IF(XP.LT.PEPS) GO TO 6140
      TARGET(IP) = TARGET(IP) + XP
C     IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP)
6130  CONTINUE
      IP = KOBS + 1
6140  IHI = MAX( IP-1, ICNTR+1 )
      GO TO 420
C *
C **  SPLIT PEARSON VII
C *
7000  CALL PEARSN(TARGET,0,TT,YI,AX,BX,CX,DX,ILO,IHI)
      GO TO 420
C *
C **  INTERMEDIATE LORENTZIAN WITH ALPHA2 REFLECTION
C *
C *  ALPHA 1 REFLECTION
8000  AW = FNFWHM(TT,1) + AX
      BC = FNSHAP(TT,1)
      CW = FNFWHM(TT,2) + AX
      DC = FNSHAP(TT,2)
      CALL PEARSN(TARGET,0,TT,YI,AW,BC,CW,DC,ILO,IHI)
C *  A2
      IF(NWAVE.GT.1) THEN
        CALL CALCPH(TT,YI,2,T2,Y2)
        IF(KLRNZ.EQ.1) Y2 = Y2 * ( PLORNZ(T2)/PLORNZ(TT) )
        CALL PEARSN(TARGET,0,T2,Y2,AW,BC,CW,DC,JLO,JHI)
        IF(JLO.LT.ILO) ILO = JLO
        IF(JHI.GT.IHI) IHI = JHI
      ENDIF
C *  A3
C      IF(NWAVE.GT.2) THEN
C        CALL CALCPH(TT,YI,3,T3,Y3)
C        IF(KLRNZ.EQ.1) Y3 = Y3 * ( PLORNZ(T3)/PLORNZ(TT) )
C        CALL PEARSN(TARGET,0,T3,Y3,AW,BC,CW,DC,JLO,JHI)
C        IF(JLO.LT.ILO) ILO = JLO
C        IF(JHI.GT.IHI) IHI = JHI
C      ENDIF
      GO TO 420
C *
C **  SPVII WITH A2,A3 AND NO CONSTRAINED PARAMETERS
C *
C *  A1
9000  CALL PEARSN(TARGET,0,TT,YI,AX,BX,CX,DX,ILO,IHI)
C *  A2
      IF(NWAVE.GT.1) THEN
        CALL CALCPH(TT,YI,2,T2,Y2)
        IF(KLRNZ.EQ.1) Y2 = Y2 * ( PLORNZ(T2)/PLORNZ(TT) )
        CALL PEARSN(TARGET,0,T2,Y2,EX,FX,GX,HX,JLO,JHI)
        IF(JLO.LT.ILO) ILO = JLO
        IF(JHI.GT.IHI) IHI = JHI
      ENDIF
C *  A3
      IF(NWAVE.GT.2) THEN
        CALL CALCPH(TT,YI,3,T3,Y3)
        IF(KLRNZ.EQ.1) Y3 = Y3 * ( PLORNZ(T3)/PLORNZ(TT) )
        CALL PEARSN(TARGET,0,T3,Y3,AX,BX,CX,DX,JLO,JHI)
        IF(JLO.LT.ILO) ILO = JLO
        IF(JHI.GT.IHI) IHI = JHI
      ENDIF
      GO TO 420
C *
C **  SPVII WITH A2,A3 AND CONSTRAINED SHAPE FACTORS
C *
C *  A1
10000 CALL PEARSN(TARGET,0,TT,YI,AX,BX,CX,DX,ILO,IHI)
C *  A2
      IF(NWAVE.GT.1) THEN
        CALL CALCPH(TT,YI,2,T2,Y2)
        IF(KLRNZ.EQ.1) Y2 = Y2 * ( PLORNZ(T2)/PLORNZ(TT) )
        CALL PEARSN(TARGET,0,T2,Y2,EX,BX,FX,DX,JLO,JHI)
        IF(JLO.LT.ILO) ILO = JLO
        IF(JHI.GT.IHI) IHI = JHI
      ENDIF
C *  A3
      IF(NWAVE.GT.2) THEN
        CALL CALCPH(TT,YI,3,T3,Y3)
        IF(KLRNZ.EQ.1) Y3 = Y3 * ( PLORNZ(T3)/PLORNZ(TT) )
        CALL PEARSN(TARGET,0,T3,Y3,AX,BX,CX,DX,JLO,JHI)
        IF(JLO.LT.ILO) ILO = JLO
        IF(JHI.GT.IHI) IHI = JHI
      ENDIF
      GO TO 420
C *
C **  SPVII WITH A2,A3 AND CONSTRAINED FWHM AND SHAPE FACTORS
C *
C *  A1
11000 CALL PEARSN(TARGET,0,TT,YI,AX,BX,CX,DX,ILO,IHI)
C *  A2
      IF(NWAVE.GT.1) THEN
        CALL CALCPH(TT,YI,2,T2,Y2)
        IF(KLRNZ.EQ.1) Y2 = Y2 * ( PLORNZ(T2)/PLORNZ(TT) )
        CALL PEARSN(TARGET,0,T2,Y2,AX,BX,CX,DX,JLO,JHI)
        IF(JLO.LT.ILO) ILO = JLO
        IF(JHI.GT.IHI) IHI = JHI
      ENDIF
C *  A3
      IF(NWAVE.GT.2) THEN
        CALL CALCPH(TT,YI,3,T3,Y3)
        IF(KLRNZ.EQ.1) Y3 = Y3 * ( PLORNZ(T3)/PLORNZ(TT) )
        CALL PEARSN(TARGET,0,T3,Y3,AX,BX,CX,DX,JLO,JHI)
        IF(JLO.LT.ILO) ILO = JLO
        IF(JHI.GT.IHI) IHI = JHI
      ENDIF
      GO TO 420
C *
C *  SPVII WITH CALCULATED FWHM AND VARIABLE SHAPE FACTORS
C *
C *  A1
12000 WF = FNFWHM(TT,1)
      WB = FNFWHM(TT,2)
      CALL PEARSN(TARGET,0,TT,YI,WF,AX,WB,BX,ILO,IHI)
C *  A2
      IF(NWAVE.GT.1) THEN
        CALL CALCPH(TT,YI,2,T2,Y2)
        IF(KLRNZ.EQ.1) Y2 = Y2 * ( PLORNZ(T2)/PLORNZ(TT) )
        CALL PEARSN(TARGET,0,T2,Y2,WF,AX,WB,BX,JLO,JHI)
        IF(JLO.LT.ILO) ILO = JLO
        IF(JHI.GT.IHI) IHI = JHI
      ENDIF
C *  A3
      IF(NWAVE.GT.2) THEN
        CALL CALCPH(TT,YI,3,T3,Y3)
        IF(KLRNZ.EQ.1) Y3 = Y3 * ( PLORNZ(T3)/PLORNZ(TT) )
        CALL PEARSN(TARGET,0,T3,Y3,WF,AX,WB,BX,JLO,JHI)
        IF(JLO.LT.ILO) ILO = JLO
        IF(JHI.GT.IHI) IHI = JHI
      ENDIF
      GO TO 420
C *
C **  SPVII WITH A2,A3 AND CONSTRAINED FWHM AND SHAPE FACTORS
C *
C *  A1
13000 AC = FNFWHM(TT,1)
      BC = FNSHAP(TT,1)
      CC = FNFWHM(TT,2)
      DC = FNSHAP(TT,2)
      CALL PEARSN(TARGET,0,TT,YI,AC,BC,CC,DC,ILO,IHI)
C *  A2
      IF(NWAVE.GT.1) THEN
        CALL CALCPH(TT,YI,2,T2,Y2)
        IF(KLRNZ.EQ.1) Y2 = Y2 * ( PLORNZ(T2)/PLORNZ(TT) )
        CALL PEARSN(TARGET,0,T2,Y2,AC,BC,CC,DC,JLO,JHI)
        IF(JLO.LT.ILO) ILO = JLO
        IF(JHI.GT.IHI) IHI = JHI
      ENDIF
C *  A3
      IF(NWAVE.GT.2) THEN
        CALL CALCPH(TT,YI,3,T3,Y3)
        IF(KLRNZ.EQ.1) Y3 = Y3 * ( PLORNZ(T3)/PLORNZ(TT) )
        CALL PEARSN(TARGET,0,T3,Y3,AC,BC,CC,DC,JLO,JHI)
        IF(JLO.LT.ILO) ILO = JLO
        IF(JHI.GT.IHI) IHI = JHI
      ENDIF
      GO TO 420
C *
C **  GENERATE A CONVOLUTE
C *
14000 IF(KCRYS.EQ.0) GO TO 14100
C *  IF CONSTRAINED BROADENING IS USED... USE INTEGRAL BREADTH BETA
      TTC = TT + CORPOS( TT )
      THETAR = TTC * DTORD2
      BSIZE = 0.0
      BSTRN = 0.0
      IF( KCRYS.EQ.1 .OR. KCRYS.EQ.3 ) THEN
        BSIZE = RTOD * WTABLE(1,1) / ( CRYPAR(1) * COS(THETAR) )
      ENDIF
      IF( KCRYS.EQ.2 .OR. KCRYS.EQ.3 ) THEN
        BSTRN = RTOD * 4.0 * CRYPAR(2) * TAN(THETAR)
      ENDIF
      IF(JKPROF.EQ.14) AX = BSIZE + BSTRN
      IF(JKPROF.EQ.15) AX = SQRT( BSIZE**2 + BSTRN**2 )
      PLPRM(IPEAK,3) = AX
C *
C *  CONVERT INTEGRAL-BREADTH TO FWHM
14100 IF( JKPROF.EQ.14 .OR. JKPROF.EQ.16 ) FWHM = 0.6366197724 * AX
      IF(JKPROF.EQ.15) FWHM = 0.9394372786 * AX
      IF(JKPROF.EQ.16) FWHM2 = 0.9394372786 * BX
      CALL WSGSS(TARGET,TT,YI,FWHM,FWHM2,ILO,IHI)
C *
C **  SET END OF PARAMETER POINTERS
420   IF(IPNUM.EQ.999) KLLIN(IPEAK) = IHI*16384 + ILO
410   CONTINUE
C *
800   RETURN
      END
C *** PEARSN - GENERATE A SPLIT-PEARSON VII PROFILE
C *
      SUBROUTINE PEARSN(TARGET,IFLAG,TTHT,YMAX,AX,BX,CX,DX,ILO,IHI)
C *
      CHARACTER QFTITL*80
      PARAMETER ( PEPS = 0.1000 , CONEPS = 0.00001 )
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /CONDAT/ CIA(4097),CII(4097),CONINC,KCONLO,KCONHI
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /DIAGS/ ISENSE(10)
      COMMON /FLDATC/ QFTITL
      DIMENSION TARGET(MPTS)
C *
C *  IF IFLAG IS SET THEN GENERATE A SPVII FOR CONVOLUTION
      IF( IFLAG .NE. 0 ) GO TO 3000
C *
C *  FIND THE CENTER OF THIS PEAK
      ICNTR = INT( (TTHT-YANG(1))/FAINC + 0.10 ) + 1
C *
C *  CHOOSE CODE BASED ON MAXIMUM EFFICIENCY...
      PPEPS = PEPS * FTIME
      IF(KASYM.EQ.1) GO TO 2000
C *
C **  SPLIT PEARSON VII WITHOUT ASYMMETRY
C *
      TMP = ( 2.0**(1.0/BX) - 1.0 ) / ( (AX/2.0)**2 )
C *  LOW ANGLE SIDE
      ILO = 1
      IF(ICNTR.LT.1) GO TO 1100
      DO 1010 IP=ICNTR,1,-1
      YC = YMAX / ( 1.0 + TMP * ( YANG(IP)-TTHT )**2 )**BX
      IF(YC.LT.PPEPS) GO TO 1020
      TARGET(IP) = TARGET(IP) + YC
C     IF(ISENSE(1).EQ.1) WRITE(ITTO,1) YANG(IP),YOBS(IP),TARGET(IP)
C1    FORMAT(' ANG,OBS,TARGET = ',F8.2,2X,F8.2,2X,F8.2)
1010  CONTINUE
      IP = 0
1020  ILO = MIN( IP+1, ICNTR )
C *  HIGH ANGLE SIDE
1100  IHI = KOBS
      IF(ICNTR.GE.KOBS) GO TO 9000
      TMP = ( 2.0**(1.0/DX) - 1.0 ) / ( (CX/2.0)**2 )
      DO 1130 IP=ICNTR+1,KOBS
      YC = YMAX / ( 1.0 + TMP * ( YANG(IP)-TTHT )**2 )**DX
      IF(YC.LT.PPEPS) GO TO 1140
      TARGET(IP) = TARGET(IP) + YC
C     IF(ISENSE(1).EQ.1) WRITE(ITTO,1) YANG(IP),YOBS(IP),YINT(IP)
1130  CONTINUE
      IP = KOBS + 1
1140  IHI = MAX( IP-1, ICNTR+1 )
      GO TO 9000
C *
C **  SPLIT PEARSON VII WITH ASYMMETRY
C *
C *  LOW ANGLE SIDE
2000  ILO = 1
      IF(ICNTR.LT.1) GO TO 2100
      TMP = ( 2.0**(1.0/BX) - 1.0 ) / ( (AX/2.0)**2 )
      DO 2010 IP=ICNTR,1,-1
      YC = YMAX / ( 1.0 + TMP * ( YANG(IP)-TTHT )**2 )**BX
      YC = YC * SYMFAC( YANG(IP), TTHT )
      IF(YC.LT.PPEPS) GO TO 2020
      TARGET(IP) = TARGET(IP) + YC
C     IF(ISENSE(1).EQ.1) WRITE(ITTO,1) YANG(IP),YOBS(IP),YINT(IP)
2010  CONTINUE
      IP = 0
2020  ILO = MIN( IP+1, ICNTR )
C *  HIGH ANGLE SIDE
2100  IHI = KOBS
      IF(ICNTR.GE.KOBS) GO TO 9000
      TMP = ( 2.0**(1.0/DX) - 1.0 ) / ( (CX/2.0)**2 )
      DO 2130 IP=ICNTR+1,KOBS
      YC = YMAX / ( 1.0 + TMP * ( YANG(IP)-TTHT )**2 )**DX
      YC = YC * SYMFAC( YANG(IP), TTHT )
      IF(YC.LT.PPEPS) GO TO 2140
      TARGET(IP) = TARGET(IP) + YC
C     IF(ISENSE(1).EQ.1) WRITE(ITTO,1) YANG(IP),YOBS(IP),YINT(IP)
2130  CONTINUE
      IP = KOBS + 1
2140  IHI = MAX( IP-1, ICNTR+1 )
      GO TO 9000
C *
C **  GENERATE AN SPVII FOR CONVOLUTION
C *
C *  FIND THE CENTER OF THIS PEAK
3000  ICNTR = INT( (TTHT-CIA(1))/CONINC + 0.10 ) + 1
C *
C *  LOW ANGLE SIDE
      ILO = KCONLO
      IF(ICNTR.LT.KCONLO) GO TO 3100
      TMP = ( 2.0**(1.0/BX) - 1.0 ) / ( (AX/2.0)**2 )
      DO 3010 IP=ICNTR,KCONLO,-1
      YC = YMAX / ( 1.0 + TMP * ( CIA(IP)-TTHT )**2 )**BX
      IF(YC.LT.CONEPS) GO TO 3020
      CII(IP) = CII(IP) + YC
C     IF(ISENSE(1).EQ.1) WRITE(ITTO,2) CIA(IP),CII(IP)
C2    FORMAT(' CIA,CII = ',F8.2,2X,F8.2)
3010  CONTINUE
      IP = KCONLO - 1
3020  ILO = MIN( IP+1, ICNTR )
C *  HIGH ANGLE SIDE
3100  IHI = KCONHI
      IF(ICNTR.GE.KCONHI) GO TO 9000
      TMP = ( 2.0**(1.0/DX) - 1.0 ) / ( (CX/2.0)**2 )
      DO 3130 IP=ICNTR+1,KCONHI
      YC = YMAX / ( 1.0 + TMP * ( CIA(IP)-TTHT )**2 )**DX
      IF(YC.LT.CONEPS) GO TO 3140
      CII(IP) = CII(IP) + YC
C     IF(ISENSE(1).EQ.1) WRITE(ITTO,2) CIA(IP),CII(IP)
3130  CONTINUE
      IP = KCONHI + 1
3140  IHI = MAX( IP-1, ICNTR+1 )
C *
9000  RETURN
      END
C *** GAUSSN - GENERATE A GAUSSIAN PROFILE IN THE TARGET ARRAY
C *
      SUBROUTINE GAUSSN(TARGET,IFLG,XPOS,YM,FWHM,ILO,IHI)
C *
      CHARACTER QFTITL*80
      PARAMETER ( PEPS = 0.1000 )
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      COMMON /DIAGS/ ISENSE(10)
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /FLDATC/ QFTITL
      DIMENSION TARGET(MPTS)
C *
C *  SET CONSTANTS
      YMAX = YM
      IA = 0
      IF( KASYM.EQ.1 .AND. IFLG.EQ.0 ) IA = 1
C *
C *  FIND THE CENTER OF THIS PEAK
      ICNTR = INT( (XPOS-YANG(1))/FAINC + 0.10 ) + 1
C *
C *  LOW ANGLE SIDE
1000  TMP = -0.6931471806 / (FWHM/2.0)**2
      ILO = 1
      IF(ICNTR.LT.1) GO TO 1100
      DO 1010 IP=ICNTR,1,-1
      XP = YMAX * EXP( TMP * ( YANG(IP)-XPOS )**2  )
      IF(IA.EQ.1) XP = XP * SYMFAC( YANG(IP), XPOS )
      IF(XP.LT.PEPS) GO TO 1020
      TARGET(IP) = TARGET(IP) + XP
C     IF(ISENSE(1).EQ.1) WRITE(ITTO,1) YANG(IP),YOBS(IP),TARGET(IP)
C1    FORMAT(' ANG,OBS,SYN = ',F8.2,2X,F8.2,2X,F8.2)
1010  CONTINUE
      IP = 0
1020  ILO = MIN( IP+1, ICNTR )
C *  HIGH ANGLE SIDE
1100  IHI = KOBS
      IF(ICNTR.GE.KOBS) GO TO 9000
      DO 1130 IP=ICNTR+1,KOBS
      XP = YMAX * EXP( TMP * ( YANG(IP)-XPOS )**2 )
      IF(IA.EQ.1) XP = XP * SYMFAC( YANG(IP), XPOS )
      IF(XP.LT.PEPS) GO TO 1140
      TARGET(IP) = TARGET(IP) + XP
C     IF(ISENSE(1).EQ.1) WRITE(ITTO,1) YANG(IP),YOBS(IP),TARGET(IP)
1130  CONTINUE
      IP = KOBS + 1
1140  IHI = MAX( IP-1, ICNTR+1 )
C *
9000  RETURN
      END
C ***  FUNCTION FNFWHM - GENERATE FWHM VALUES FOR PROFILES
C *
      FUNCTION FNFWHM( ANGLE, ISIDE )
      PARAMETER ( DTORD2 = 0.87266463E-2 )
      COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3)
C *
C *  GENERATE VALUE FOR FRONT SIDE OF PROFILE
      IF(ISIDE.EQ.1) THEN
        TANTHT = TAN( ANGLE * DTORD2 )
        TEMP = WGPRO(1,1) + WGPRO(1,2)*TANTHT + WGPRO(1,3)*TANTHT**2
        FNFWHM = SQRT( TEMP ) * 2.0
      ENDIF
C *
C *  GENERATE VALUE FOR BACK SIDE OF PROFILE
      IF(ISIDE.EQ.2) THEN
        TANTHT = TAN( ANGLE * DTORD2 )
        TEMP = WGPRO(3,1) + WGPRO(3,2)*TANTHT + WGPRO(3,3)*TANTHT**2
        FNFWHM = SQRT( TEMP ) * 2.0
      ENDIF
C *
      RETURN
      END
C ***  FUNCTION FNSHAP - GENERATE EXPONENTIAL PARAMETER FOR PROFILES
C *
      FUNCTION FNSHAP( ANGLE, ISIDE )
      COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3)
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 X TWO-THETA
C *
      FUNCTION PLORNZ( TWOTHT )
      PARAMETER ( DTOR=1.745329252E-02 )
      PARAMETER ( GC=0.8001525593 )
C *
C *  THIS IS THE LORENTZ-POLARIZATION CORRECTED FOR GR MONOCHROMETER
      ANG = TWOTHT * DTOR
      ANGD2 = ANG / 2.0
      PLORNZ  = (1.+GC*COS(ANG)**2) / (COS(ANGD2)*SIN(ANGD2)**2)
C *
      RETURN
      END
C ***  FUNCTION SYMFAC
C *
C *  PROVIDES SYMMETRY FACTOR FOR PEAK AT THETAB, EVALUATED
C *  AT ANGLE THETAX.  WE WILL PULL THE SYMMETRY FACTOR
C *  FROM THE COMMON ASYPAR PARAMETER.
C *
      FUNCTION SYMFAC( THETAX, THETAB )
      PARAMETER ( DTORD2=8.72664625E-03 )
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2)
      COMMON /DIAGS/ ISENSE(10)
C *
      DELTHT = THETAX - THETAB
      DELSQR = DELTHT**2
      TANTHT = TAN( THETAB * DTORD2 )
      TMP = ASYPAR * DELSQR / TANTHT
      SYMFAC = 1.0
      IF(THETAX.GT.THETAB) SYMFAC = 1.0 - TMP
      IF(THETAX.LE.THETAB) SYMFAC = 1.0 + TMP
C *
C     IF(ISENSE(1).NE.0) WRITE(ITTO,100) THETAX,SYMFAC
C100  FORMAT(' THETAX, SYMFAC = ',F8.4,2X,F8.4)
200   RETURN
      END
C ***  FUNCTION CERRFC
C *
      FUNCTION CERRFC( XVAL, YVAL )
C *
      DOUBLE PRECISION XPASS,YPASS,UPASS,VPASS
C *
C *  THE ARGUMENTS PASSED TO WSER,WINT ARE DOUBLE PRECISION
      XPASS = DBLE( XVAL )
      YPASS = DBLE( YVAL )
C *
C *  CALL THE CORRECT FUNCTION FOR GENERATING THE COMPLEX ERROR FUNCTION
      IF(YPASS.GT.0.75) GO TO 1030
      IF(XPASS.GT.1./YPASS) GO TO 1030
      CALL WSER( XPASS, YPASS, UPASS, VPASS )
      GO TO 2000
1030  CALL WINT( XPASS, YPASS, UPASS, VPASS )
C *
C *  RETURN THE VALUE
2000  CERRFC = SNGL( UPASS )
C     WRITE(6,2010) XVAL,YVAL,XPASS,YPASS,FUNCT
C2010 FORMAT(' X,Y,F = ',5F10.4)
      RETURN
      END
C ***  SUBROUTINE WSER
C *
C *  THIS PROGRAM CALCULATES THE REAL AND THE IMAGINARY PART OF THE FUNC
C *
C *    W(Z) = SQRT(PI) * EXP(-Z*Z) * (1-ERF(-1*Z))
C *
C *    (COMPLEX ERROR FUNCTION, C.F. ABROMOWITZ & STEGNUN, HANDBOOK OF
C *    MATHMATICAL FUNCTIONS, P. 295)
C *
C *  WSER USES A SERIES EXPANSION IN TERMS OF THE IMAGINARY ARGUMENT.
C *
C *  SUBROUTINE NEEDED: FDAW - DAWSONS' INTEGRAL
C *
C *  * FROM: T. SUNDIUS, J. OF RAMAN SPECTR. 1 (1973) 471-488. *
C *
      SUBROUTINE WSER( X, Y, UXY, VXY )
C *
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      VPI = 1.772453851
      EPS = 5.0E-9
      U0 = VPI * DEXP( -X*X )
      V0 = 2.0 * FDAW( X )
      U1 = -2.0 * X * U0
      V1 = 2.0 * ( 1.0 - X * V0 )
      I = 0
      YI = 1.0
      UXY = U0
      VXY = V0
      SU = 1.0
      SV = 1.0
2     SU = -SU
      U = SU * V1
      V = SV * U1
4     I = I + 1
      IF (I-30) 6,6,10
6     XI = I
      YI = YI * Y / XI
      DU = U * YI
      DV = V * YI
      IF( DABS(DU)-EPS ) 7,7,9
7     IF( DABS(DV)-EPS ) 10,10,9
9     UXY = UXY + DU
      VXY = VXY + DV
      U = U1
      U1 = -2.0 * ( XI*U0 + X*U1 )
      U0 = U
      V = V1
      V1 = -2.0 * ( XI*V0 + X*V1 )
      V0 = V
      IF( MOD(I,2) ) 8,2,8
8     SV = -SV
      U = SU * U1
      V = SV * V1
      GO TO 4
10    RETURN
      END
C ***  SUBROUTINE WINT
C *
C *  THIS PROGRAM CALCULATES THE REAL AND THE IMAGINARY PART OF THE FUNC
C *
C *    W(Z) = SQRT(PI) * EXP(-Z*Z) * (1-ERF(-1*Z))
C *
C *    (COMPLEX ERROR FUNCTION, C.F. ABROMOWITZ & STEGNUN, HANDBOOK OF
C *    MATHMATICAL FUNCTIONS, P. 297)
C *
C *  WINT USES NUMERICAL INTEGRATION USING A 96-POINT HERMITE-GAUSS INTE
C *  FORMULA.  (SHAO, CHEN & FRANK, IBM TECHNICAL REPORT 00.1100, 1964)
C *
C *  * FROM: T. SUNDIUS, J. OF RAMAN SPECTR. 1 (1973) 471-488. *
C *
      SUBROUTINE WINT( XI, Y, UXY, VXY )
C *
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION X(18), W(18)
      DATA X(01),X(02),X(03)/1.13068883E-1,3.39236619E-1,5.65494366E-1/
      DATA X(04),X(05),X(06)/7.91902479E-1,1.01852183E+0,1.24541404E+0/
      DATA X(07),X(08),X(09)/1.47264168E+0,1.70026852E+0,1.92835978E+0/
      DATA X(10),X(11),X(12)/2.15698239E+0,2.38620523E+0,2.61609953E+0/
      DATA X(13),X(14),X(15)/2.84673908E+0,3.07820069E+0,3.31056454E+0/
      DATA X(16),X(17),X(18)/3.54391464E+0,3.77833931E+0,4.01393176E+0/
      DATA W(01),W(02),W(03)/2.23270023E-1,2.01613013E-1,1.64379631E-1/
      DATA W(04),W(05),W(06)/1.20983117E-1,8.03539501E-2,4.81399067E-2/
      DATA W(07),W(08),W(09)/2.60003403E-2,1.26513751E-2,5.54163129E-3/
      DATA W(10),W(11),W(12)/2.18313198E-3,7.72695822E-4,2.45418093E-4/
      DATA W(13),W(14),W(15)/6.98543244E-5,1.77918059E-5,4.04823318E-6/
      DATA W(16),W(17),W(18)/8.21354455E-7,1.48296941E-7,2.37736621E-8/
C *
      VPI = 1.772453851
      UXY = 0.0
      VXY = 0.0
      YSQ = Y * Y
C *
      DO 1 I=1,18
      X1 = XI - X(I)
      X2 = XI + X(I)
      Y1 = W(I) / ( YSQ + X1*X1 )
      Y2 = W(I) / ( YSQ + X2*X2 )
      UXY = UXY + Y1 + Y2
1     VXY = VXY + Y1*X1 + Y2*X2
C *
      UXY = Y * UXY/VPI
      VXY = VXY/VPI
      RETURN
      END
C ***  FUNCTION FDAW
C *
C *  THIS PROGRAM CALCULATED DAWSONS INTEGRAL
C *
C *    EXP(-X*X) * INT(O-X)*(EXP(-T*T)*DT)
C *
C *  ACCORDING TO APPROXIMATIONS BY CODY,PACIORED & THACHER (MATH.
C *  COMPT. 24 (1970) 171-178)
C *
C *  FOUR ARGUMENT REGIONS ARE CONSIDERED:
C *    (A)  ABS(X) .LE. 2.5
C *    (B)  ABS(X) .GT. 2.5 .OR. ABS(X) .LE. 3.5
C *    (C)  ABS(X) .GT. 3.5 .OR. ABS(X) .LE. 5.0
C *    (D)  ABS(X) .GT. 5.0
C *
C *  * FROM: T. SUNDIUS, J. OF RAMAN SPECTR. 1 (1973) 471-488. *
C *
      FUNCTION FDAW( X )
C *
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION P(6),Q(6),A1(5),B1(4),A2(4),B2(3),A3(4),B3(3)
      DATA P(1),P(2),P(3)/ 1.08326559E+4,-1.28405832E+3, 4.19672902E+2/
      DATA P(4),P(5),P(6)/-1.51982152E+1, 1.67795116E+0,-2.38594566E-2/
      DATA Q(1),Q(2),Q(3)/ 1.08326559E+4, 5.93771277E+3, 1.48943557E+3/
      DATA Q(4),Q(5),Q(6)/ 2.19728332E+2, 1.99422336E+1, 1.00000000E+0/
      DATA A1(1),A1(2),A1(3)/5.00652754E-1,-4.91605366E+0,4.07068102E+0/
      DATA A1(4),A1(5),B1(1)/-1.26817902E+1,3.47393743E+0,2.14221966E-1/
      DATA B1(2),B1(3),B1(4)/3.73902764E+1,1.38216341E+1,8.87619387E+1/
      DATA A2(1),A2(2),A2(3)/5.00009652E-1,-1.58539350E0,-1.03850248E+1/
      DATA A2(4),B2(1),B2(2)/-4.10832338E0,2.49246324E-1,-5.37142730E-1/
      DATA B2(3),A3(1),A3(2)/1.77617781E+1,5.00000002E-1,-2.50017117E0/
      DATA A3(3),A3(4),B3(1)/-4.67312022E0,-1.11952164E+1,7.49999191E-1/
      DATA B3(2),B3(3)      /-2.48787659E+0,-4.12544066E+0/
C *
      X2 = X * X
      AX = DABS( X )
      IF( AX-2.5 ) 6,6,2
2     IF( AX-3.5 ) 12,12,4
4     IF( AX-5.0 ) 16,16,20
C *
6     Y1 = P(6)
      DO 8 I=1,5
      J = 6 - I
8     Y1 = P(J) + X2*Y1
      Y2 = Q(6)
      DO 10 I=1,5
      J = 6 - I
10    Y2 = Q(J) + X2*Y2
      FDAW = X * Y1/Y2
      GO TO 24
C *
12    Y = A1(5)
      DO 14 I=1,4
      J = 5 - I
14    Y = A1(J) + B1(J)/(X2+Y)
      FDAW = Y/X
      GO TO 24
C *
16    Y = A2(4)
      DO 18 I=1,3
      J = 4 - I
18    Y = A2(J) + B2(J)/(X2+Y)
      FDAW = Y/X
      GO TO 24
C *
20    Y = A3(4)
      DO 22 I=1,3
      J = 4 - I
22    Y = A3(J) + B3(J)/(X2+Y)
      FDAW = ( 1.0+ Y/X2 ) / X / 2.0
24    RETURN
      END
C ***  WSGSS - GENERATE A CONVOLUTE.  (LORENTZ,GAUSSIAN) * INSTRUMENT.
C *
      SUBROUTINE WSGSS(TARGET,TT,YI,AX,BX,ILO,IHI)
C *
      LOGICAL LPATCH
      DOUBLE PRECISION DPS
      PARAMETER ( PRSC = 1.128379167 )
      PARAMETER ( PEPS = 0.1000 )
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /CONDAT/ CIA(4097),CII(4097),CONINC,KCONLO,KCONHI
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /WDATA/ NWAVE,WTABLE(5,2)
      COMMON /DIAGS/ ISENSE(10)
      DIMENSION TARGET(MPTS)
      DIMENSION CSI(512)
C *
C *  INITIALIZE SOME PARAMETERS
      LPATCH = .FALSE.
      IK = IABS( KPROF ) - 2
      ILO = 1
      IHI = 1
C *
C **  DETERMINE THE INTERVAL FOR CONVOLUTE PROFILE GENERATION.  SPAN
C *   COVERS THE MINIMUM OF THE REFINEMENT SEGMENT OR *RANGE* DEGREES
C *
1000  NSPAN = ( 3072 - 1026 ) + 1
      SPAN  = REAL(NSPAN-1) * FAINC
      RANGE = AMAX1( AMIN1( 4.0, YANG(KOBS)-YANG(1) ), FAINC )
      KCINC = MAX( INT(SPAN/RANGE), 1 )
      CONINC = FAINC / REAL(KCINC)
CDBG  WRITE(99,'(''RANGE,KCINC,CONINC= '',F8.4,I5,F9.6)')
CDBG 1  RANGE,KCINC,CONINC
C *
C *  MID-POINT OF INSTRUMENT PROFILE IS WEIGHTED A1,A2 AVERAGE
      TW = TT
      IF( NWAVE.GT.1 .AND. KOBS.GT.1 ) THEN
        CALL CALCPH(TT,YI,2,T2,Y2)
        TW = ( TT + TT + T2 ) / 3.0
      ENDIF
C *
C *  DEFINE THE APPROXIMATE CENTER POINT OF THE CONVOLUTE PROFILE
      KCNTR = INT( (TW-YANG(1))/FAINC + 0.1 ) + 1
C *
C *  POINTS THAT MAY BE GENERATED TO THE LOW AND HIGH ANGLE SIDE
      NNPTLO = KCNTR - ( 2049 - 1026 ) / KCINC
      NNPTHI = KCNTR + ( 3072 - 2049 ) / KCINC
CDBG  WRITE(99,'(''KCNTR,NNPTLO,NNPTHI= '',3I5)') KCNTR,NNPTLO,NNPTHI
      IF( NNPTLO.GT.KOBS .OR. NNPTHI.LT.1 ) THEN
        WRITE(ITTO,14002) TT,KCNTR,NNPTLO,NNPTHI
14002   FORMAT(
     1  ' -Line at ',F6.2,' degrees is out of refinement region',/,
     1  '  ( KCNTR = ',I4,'  NNPTLO = ',I4,'  NNPTHI = ',I4,' )')
        GO TO 9000
      ENDIF
      NNPTLO = MAX( NNPTLO,    1 )
      NNPTHI = MIN( NNPTHI, KOBS )
CDBG  WRITE(99,'(''      NNPTLO,NNPTHI= '',2I5)') NNPTLO,NNPTHI
C *
C *  INITIALIZE THE ANGLE, INTENSITY ARRAYS FOR THE INSTRUMENT PROFILE
      XS = YANG(1) + REAL(KCNTR-1)*FAINC - 2048.0*CONINC - CONINC
      DO 14015 I=1,4097
      CIA(I) = XS + REAL(I)*CONINC
      CII(I) = 0.0
14015 CONTINUE
C *
C *  STARTING AND ENDING POINTS IN CONVOLUTE PROFILE ARRAY
      NNSGLO = 2049 - ( KCNTR  - NNPTLO ) * KCINC
      NNSGHI = 2049 + ( NNPTHI - KCNTR  ) * KCINC
CDBG  WRITE(99,'('' NNSEGLO,HI= '',2I5)') NNSGLO,NNSGHI
C *
C **  GENERATE THE SPECIMEN PROFILE
C *
C *   NOTE:  THE NORMALIZING FACTOR DOES NOT NEED TO APPEAR IN THE PSF
C *   SINCE LATER DIVISION BY SMPSUM WILL NEGATE IT.  WE ARE, IN EFFECT,
C *   GENERATING A NORMALIZED PROFILE.
C *
2000  P2T = CIA(1) - CONINC
      FWHM = AX
      IF(LPATCH) FWHM = BX
CDBG  WRITE(99,'(''  FWHM (SPEC) = '',G13.6)') FWHM
C *
C *  GENERATE A LORENTZIAN
      IF( IK.EQ.12 .OR. ( IK.EQ.14 .AND. .NOT.LPATCH ) ) THEN
        TMULT = 4.0 / FWHM**2
CREDUN  TNORM = 0.636619772 / FWHM
        SMPSUM = 1.0
        PLIM = 0.0025
        DO 2010 IP=1,512
        CSI(IP) = 1.0 / ( 1.0 + TMULT * ( CIA(IP)-P2T )**2 )
        IF(ISENSE(1).NE.0) WRITE(ITTO,11) CIA(IP),CSI(IP)
   11   FORMAT('   CIA,CSI = ',F8.4,2X,F8.6)
        IF(CSI(IP).LT.PLIM) GO TO 2030
        SMPSUM = SMPSUM + CSI(IP) + CSI(IP)
2010    CONTINUE
        IP = 513
      ENDIF
C *
C *  GENERATE A GAUSSIAN
      IF( IK.EQ.13 .OR. LPATCH ) THEN
        TMULT = -2.772588722 / FWHM**2
CREDUN  TNORM = 0.939437279 / FWHM
        SMPSUM = 1.0
        PLIM = 0.0050
        DO 2020 IP=1,512
        CSI(IP) = EXP( TMULT * ( CIA(IP)-P2T )**2 )
        IF(CSI(IP).LT.PLIM) GO TO 2030
        SMPSUM = SMPSUM + CSI(IP) + CSI(IP)
2020    CONTINUE
        IP = 513
      ENDIF
C *
C *  SET NUMBER OF POINTS IN SPECIMEN PROFILE WIDTH, NORMALIZING FACTOR
2030  ISWID = IP
CDBG  WRITE(99,'('' ISWID,SMPSUM='',I5,2F8.4)')ISWID,SMPSUM,CSI(ISWID-1)
      SMPSUM = 1.0 / SMPSUM
C *
C *  IF LPATCH THEN ALL THINGS HAVE BEEN TAKEN CARE OF
      IF(LPATCH) GO TO 14200
C *
C **  GENERATE THE INSTRUMENTAL PROFILE
C *
C *  DETERMINE POSSIBLE LIMITS ON INSTRUMENT PROFILES BASED ON WIDTH OF
C *  PATTERN SEGMENT AND SPECIMEN PROFILE
14100 KCONLO = NNSGLO - ( ISWID - 1 )
      KCONLO = MAX( 1, MIN( KCONLO, 4097 ) )
      KCONHI = NNSGHI + ( ISWID - 1 )
      KCONHI = MAX( 1, MIN( KCONHI, 4097 ) )
CDBG  WRITE(99,'(''KCONLO,KCONHI= '',2I5)') KCONLO,KCONHI
C *
C *  RETRIEVE PROFILE COEFFICIENTS AND CALC NORMALIZING FACTORS
      Y1  = 100.0
      AC  = FNFWHM( TT, 1 )
      BC  = FNSHAP( TT, 1 )
      CC  = FNFWHM( TT, 2 )
      DC  = FNSHAP( TT, 2 )
      P1  = GAMMA(BC)
      P2  = SQRT( 2.0**(1.0/BC) - 1.0 )
      P3  = GAMMA(BC-0.5)
      PNL = 0.5 / ( PRSC * P1 * P2 / ( P3 * AC ) )
      P1  = GAMMA(DC)
      P2  = SQRT( 2.0**(1.0/DC) - 1.0 )
      P3  = GAMMA(DC-0.5)
      PNH = 0.5 / ( PRSC * P1 * P2 / ( P3 * CC ) )
C *
C *  GENERATE THE PROFILE AND CALCULATE THE OVERALL AREA
C *  A1
      CALL PEARSN(CII,1,TT,Y1,AC,BC,CC,DC,IILO,IIHI)
      PAREA = Y1 * ( PNL + PNH )
C *  A2
      IF(NWAVE.GT.1) THEN
        CALL CALCPH(TT,Y1,2,T2,Y2)
        IF(KLRNZ.EQ.1) Y2 = Y2 * ( PLORNZ(T2)/PLORNZ(TT) )
        CALL PEARSN(CII,1,T2,Y2,AC,BC,CC,DC,JILO,JIHI)
        PAREA = PAREA + Y2 * ( PNL + PNH )
        IF(JILO.LT.IILO) IILO = JILO
        IF(JIHI.GT.IIHI) IIHI = JIHI
      ENDIF
C *  A3
      IF(NWAVE.GT.2) THEN
        CALL CALCPH(TT,Y1,3,T3,Y3)
        IF(KLRNZ.EQ.1) Y3 = Y3 * ( PLORNZ(T3)/PLORNZ(TT) )
        CALL PEARSN(CII,1,T3,Y3,AC,BC,CC,DC,JILO,JIHI)
        PAREA = PAREA + Y3 * ( PNL + PNH )
        IF(JILO.LT.IILO) IILO = JILO
        IF(JIHI.GT.IIHI) IIHI = JIHI
      ENDIF
C *
C *  NORMALIZE THE INSTRUMENT PROFILE
CDBG  WRITE(99,'(''IILO,IIHI,PAREA = '',2I5,F8.2)')IILO,IIHI,PAREA
      IF(PAREA.GT.0.0) THEN
        PAREA = 1.0 / PAREA
       ELSE
        PAREA = 0.0
      ENDIF
      DO 14110 I=IILO,IIHI
14110 CII(I) = CII(I) * PAREA
C *
C **  CONVOLUTE THE SAMPLE PROFILE WITH THE INSTRUMENTAL PROFILES
C *
14200 ILO = 0
      IHI = 0
C *
C *  DETERMINE OVERALL LIMITS FOR CONVOLUTION AND OFFSET FOR OBS DATA
      ISTRT = NNSGLO
      IEND  = NNSGHI
      IPNT  = NNPTLO - 1
CDBG  WRITE(99,'(''ISTRT,IPNT,IEND = '',3I5)') ISTRT,IPNT,IEND
C *
C **  GENERATE CONVOLUTE PROFILE
C *
15000 DO 15010 NSC = ISTRT,IEND,KCINC
      DPS = DBLE( CII(NSC) )
      DO 15020 NS = 1,(ISWID-1)
15020 DPS = DPS + CSI(NS) * ( CII(NSC-NS) + CII(NSC+NS) )
      YC = SNGL(DPS) * ( YI * SMPSUM )
      IPNT = IPNT + 1
      IF(ISENSE(1).NE.0) WRITE(ITTO,1) YANG(IPNT),YOBS(IPNT),YC
    1 FORMAT(' ANG,OBS,YINT = ',F8.4,2X,F8.2,2X,G13.6)
      IF(YC.LT.PEPS) GO TO 15010
      TARGET(IPNT) = TARGET(IPNT) + YC
      IF(ILO.EQ.0) ILO = IPNT
      IHI = IPNT
15010 CONTINUE
      IF(ILO.EQ.0) ILO = 1
      IF(IHI.EQ.0) IHI = 1
C *
C *  CHECK FOR PROFILE #14.  TWO CONVOLUTIONS TO BE PERFORMED
C *
8000  IF( IK.NE.14 .OR. LPATCH ) GO TO 9000
      LPATCH = .TRUE.
      GO TO 2000
C *
9000  RETURN
      END
C ***  GAMMA - DUMMY GAMMA FUNCTION ROUTINE
C *
      FUNCTION GAMMA( X )
      PARAMETER ( A0 = +0.944484E+1 )
      PARAMETER ( A1 = -0.369213E+2 )
      PARAMETER ( A2 = +0.717266E+2 )
      PARAMETER ( A3 = -0.789921E+2 )
      PARAMETER ( A4 = +0.532151E+2 )
      PARAMETER ( A5 = -0.226184E+2 )
      PARAMETER ( A6 = +0.608133E+1 )
      PARAMETER ( A7 = -0.100099E+1 )
      PARAMETER ( A8 = +0.918978E-1 )
      PARAMETER ( A9 = -0.359081E-2 )
      GAMMA = A0+
     1((((((((A9*X+A8)*X+A7)*X+A6)*X+A5)*X+A4)*X+A3)*X+A2)*X+A1)*X
      RETURN
      END
C ***  PROINT (31) - INITIALIZE PROFILE REFINEMENT PARAMETERS
C *
      SUBROUTINE PROINT( LFIRST )
C *
      LOGICAL LFIRST,LUSEM
      CHARACTER QANS*1, QFTITL*80
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 )
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201)
      COMMON /VECTOR/ NVECS,BVECS(MEMVT2),BMINS(MEMV),BMAXS(MEMV)
      COMMON /BKGDAT/ LDEG,CLY,CLC(6),BKGSDV,IBKCPS,IBKNBK
      COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2)
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /RFREGN/ KNUMRG,KNUMCU,REFREG(200,2)
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /PEAKDT/ NPEAK,PEAKS(200,4)
      COMMON /PDATA/ BANG, EANG
      COMMON /FLDATC/ QFTITL
C *
C **  INITIALIZE NUMBER OF PARAMETERS TO ZERO
C *
      NVECS = 0
C *
C **  GET ANGLES FOR THE REFINEMENT REGION.
C *
900   KOBS = 0
      START = 0.0
      END = 0.0
      IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) THEN
          WRITE(ITTO,910)
910       FORMAT(/,' Angular region for refinement ? <none> ')
          READ(ITTI,*) START,END
         ELSE
          READ(ITTI,920) START,END
920       FORMAT(2F10.4)
        ENDIF
       ELSE
        KNUMCU = KNUMCU + 1
        IF(KNUMCU.LE.KNUMRG) THEN
          START = REFREG(KNUMCU,1) - 0.5
          END   = REFREG(KNUMCU,2) + 0.5
        ENDIF
      ENDIF
      IF( START.EQ.0.0 .AND. END.EQ.0.0 ) THEN
        IF(KMODEO.EQ.1) WRITE(IOBO,930) START,END
930     FORMAT(F10.4,F10.4,T40,'Refinement region')
        IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,932)
932     FORMAT(//,' * End of profile refinement')
        GO TO 9000
      ENDIF
      START = AMAX1( START, FBANG )
      END   = AMIN1( END,   FEANG )
      IF(END.LE.START) GO TO 900
      NTEMP = NINT( (END-START)/FAINC ) + 1
      IF(NTEMP.LE.MPTS) GO TO 950
      WRITE(ITTO,940)
940   FORMAT(/,' --Too many points in interval to evaluate')
      GO TO 900
C *
C *  VALID REGION SPECIFIED.  IF NOT LFIRST SIGNAL BEGINNING OF REFINE
950   IF(.NOT.LFIRST.AND.(KMODEO.EQ.2.OR.KAUTOP.EQ.1)) WRITE(ITTO,952)
952   FORMAT('1',14X,'* * *   P R O F I L E   R E F I N E M E N T',
     1  '   * * *')
C *
C *  CALL DINPUT TO GET THE REQUESTED DATA
      IF(KMODEO.EQ.1) WRITE(IOBO,930) START,END
      IF(KMODEO.NE.1) THEN
        CALL DINPUT( START, END )
        WRITE(ITTO,960) BANG,EANG,KOBS
960     FORMAT(/,' Beginning angle: ',F8.4,'  Ending angle: ',F8.4,
     1           '  Points in interval: ',I4)
       ELSE
        BANG = START
        EANG = END
        WRITE(ITTO,960) BANG,EANG,NTEMP
      ENDIF
C *
C **  GET THE LINE PARAMETERS
C *
C *  SET THE NUMBER OF LINES IN PARAMETER LIST TO ZERO
      KNLIN = 0
C *
C *  IF BATCH MODE... READ LINE POSITIONS
      IF(KMODEO.EQ.2) GO TO 2200
C *
C *  IF SEARCH HAS BEEN PERFORMED... USE THESE AS INPUT
      IF(NPEAK.GT.0) GO TO 2000
C *
C *  SEARCH THE INTERVAL FOR THE MAXIMUM POINT...
1000  IF(KMODEO.EQ.1) CALL DINPUT( START, END )
      IHIGH = 1
      DO 1010 I = 2,KOBS
1010  IF(YOBS(I).GT.YOBS(IHIGH)) IHIGH = I
      PLPRM(1,1) = YANG(IHIGH)
      PLPRM(1,2) = YOBS(IHIGH)
      KRLIN(1) = 1
      PLPRM(1,1) = PLPRM(1,1) + CORPOS( PLPRM(1,1) )
      PLPRM(1,2) = PLPRM(1,2)/FTIME
      WRITE(ITTO,1020) PLPRM(1,1),PLPRM(1,2),KRLIN(1)
1020  FORMAT(/,' Angle = ',F8.4,'  Intensity = ',F10.2,
     1  '  Wavelength = ',I2,/,' New values ? ')
      A = 0.0
      B = 0.0
      IREF = 0
      READ(ITTI,*) A,B,IREF
      IF(A.GT.0.00) PLPRM(1,1) = A
      IF(B.GT.0.00) PLPRM(1,2) = B
      IF(IREF.GT.0) KRLIN(1) = IREF
      KNLIN = 1
      IF(KMODEO.EQ.1) WRITE(IOBO,1035) PLPRM(1,1),PLPRM(1,2),KRLIN(1)
1035  FORMAT(F10.4,F10.2,I2,T40,'Initial line entry')
      PLPRM(1,1) = PLPRM(1,1) - CORPOS( PLPRM(1,1) )
      PLPRM(1,2) = PLPRM(1,2) * FTIME
      GO TO 2200
C *
C *  USE PEAK SEARCH LIST FOR LINE ENTRIES
C *
2000  IF(KAUTOP.NE.1) THEN
        WRITE(ITTO,2010)
2010    FORMAT(/,' * Use the following options for lines found in the',
     1  ' peak search:',//,
     1  ' (A)ccept, (R)eject, (M)anual entry, or (U)se all',/)
        LUSEM = .FALSE.
       ELSE
        LUSEM = .TRUE.
      ENDIF
      DO 2070 I=1,NPEAK
      IF( PEAKS(I,1).LT.BANG .OR. PEAKS(I,1).GT.EANG ) GO TO 2070
      POSC = PEAKS(I,1) + CORPOS( PEAKS(I,1) )
      IREF = INT( PEAKS(I,4) )
      WRITE(ITTO,2025) I,POSC,PEAKS(I,2),IREF
2025  FORMAT(' Line  ',I3,'  Angle: ',F8.4,'  Intensity: ',F10.2,
     1       '  Wavelength: ',I2)
      IF( IREF.NE.1 .AND. KAUTOP.EQ.1 ) THEN
        WRITE(ITTO,2028)
2028    FORMAT(' -AUTOPILOT:  Rejected; line not alpha-1')
        GO TO 2070
      ENDIF
      IF(.NOT.LUSEM) THEN
        WRITE(ITTO,2026)
2026    FORMAT('  (R/A/E,U) ? <R> ')
        READ(ITTI,2011) QANS
2011    FORMAT(A1)
        IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 2200
        IF( QANS.EQ.'U' .OR. QANS.EQ.'u' ) LUSEM = .TRUE.
      ENDIF
2012  IF( QANS.EQ.'A' .OR. QANS.EQ.'a' .OR. LUSEM ) THEN
        IF(KMODEO.EQ.1) WRITE(IOBO,2027) POSC,PEAKS(I,2),IREF
2027    FORMAT(F10.4,F10.2,I2,T40,'Line entry via pksrch')
        KNLIN = KNLIN + 1
        PLPRM(KNLIN,1) = PEAKS(I,1)
        PLPRM(KNLIN,2) = PEAKS(I,2) * FTIME
        KRLIN(KNLIN) = IREF
      ENDIF
2070  CONTINUE
C *
C *  GET OTHER PEAK PARAMETERS IF REQUESTED
2200  A = 0.0
      B = 0.0
      IREF = 0
      IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,2210)
2210    FORMAT(/,'  Additional lines ? (Angle, Intensity, Wavelength)',
     1  ' <NONE> ')
2220    IF(KMODEO.NE.2) THEN
          READ(ITTI,*) A,B,IREF
         ELSE
          READ(ITTI,1030) A,B,IREF
1030      FORMAT(F10.4,F10.2,I2)
        ENDIF
      ENDIF
      IF(IREF.EQ.0) IREF = 1
      IF(KMODEO.EQ.1) WRITE(IOBO,2225) A,B,IREF
2225  FORMAT(F10.4,F10.2,I2,T40,'Manual line entry')
      IF( A.EQ.0.0 .OR. B.EQ.0.0 ) GO TO 3000
      IF( A.EQ.-1.0 .AND. B.EQ.-1.0 ) THEN
        IHIGH = 1
        DO 2227 I = 2,KOBS
2227    IF(YOBS(I).GT.YOBS(IHIGH)) IHIGH = I
        A = YANG(IHIGH)
        B = YOBS(IHIGH) / FTIME
      ENDIF
      KNLIN = KNLIN + 1
      POSC = A - CORPOS( A )
      PLPRM(KNLIN,1) = POSC
      PLPRM(KNLIN,2) = B * FTIME
      KRLIN(KNLIN) = IREF
      WRITE(ITTO,2230) A,B,IREF
2230  FORMAT(' Line entry:  Angle ',F8.4,'  Intensity ',F10.2,
     1'  Wavelength ',I2)
      GO TO 2200
C *
C **  THIS IS THE START OF THE REFINEMENT PARAMETER CRITERION SELECTION
C *
C *  IF THIS IS THE FIRST TIME IN THE ROUTINE THEN ASK ALL THE QUESTIONS
C *  AND RECORD ALL THE ANSWERS.  ON THE SUBSEQUENT ENTRIES TO THIS SUB-
C *  ROUTINE USE THE LAST SET OF PARAMETERS.
C *
C *  GET PROFILE FUNCTION TO USE
C *
3000  IF( KMODEO.NE.2 .AND. KAUTOP.NE.1 ) WRITE(ITTO,3010)
3010  FORMAT(/,' Profile selection for refinement:',//,
     1  '  1 - Lorentzian',/,
     1  '  2 - Modified Lorentzian',/,
     1  '  3 - Intermediate Lorenztian',/,
     1  '  4 - Pearson VII',/,
     1  '  5 - Gaussian',/,
     1  '  6 - Voigt',/,
     1  '  7 - Split Pearson VII',/,
     1  '  8 - Intermediate Lorentzian with alpha2 reflection',/,
     1  '  9 - SPVII with a2,a3: no constrained parameters',/,
     1  ' 10 - SPVII with a2,a3: shape factors a1=a2=a3',/,
     1  ' 11 - SPVII with a2,a3: shape and fwhm a1=a2=a3',/,
     1  ' 12 - SPVII with a2,a3: calc fwhms, shapes a1=a2=a3',/,
     1  ' 13 - SPVII with a2,a3: calc fwhms and shape factors',/,
     1  ' 14 - Lorentzian convoluted with instrumental profile',/,
     1  ' 15 - Gaussian convoluted with instrumental profile',/,
     1  ' 16 - Gaussian*Lorentzian*instrumental profile')
      JKPROF = KPROF
      KPROF = 0
      IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) THEN
          WRITE(ITTO,3015) JKPROF
3015      FORMAT(/,' Profile? <',I3,'> ')
          READ(ITTI,*) KPROF
         ELSE
          READ(ITTI,3020) KPROF
3020      FORMAT(I3)
        ENDIF
      ENDIF
      IF( IABS(KPROF).LT.1 .OR. IABS(KPROF).GT.16 ) KPROF = JKPROF
C *
C *  NEGATIVE PROFILE # MEANS ALL PROFILES WILL LOOK THE SAME
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3030) KPROF
3030  FORMAT(/,' Profile function selected: ',I3)
      IF(KMODEO.EQ.1) WRITE(IOBO,3040) KPROF
3040  FORMAT(I3,T40,'Profile')
C *
C *  DETERMINE FUNCTIONAL FORM FOR CONVOLUTED PROFILES
C *
      KCRYS = 0
      IF( IABS(KPROF).NE.14 .AND. IABS(KPROF).NE.15 ) GO TO 2400
      IF(.NOT.LFIRST) THEN
        KCRYS = JKCRYS
        GO TO 2400
      ENDIF
C *
C *  BROADENING IS A FUNCTION OF CRYSTALLITE SIZE
      IF(KMODEO.NE.2) WRITE(ITTO,3050)
3050  FORMAT('  Use crystallite size broadening ? <N> ')
      READ(ITTI,2011) QANS
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
        KCRYS = 1
        KPROF = IABS( KPROF )
       ELSE
        QANS = 'N'
      ENDIF
      JKCRYS = KCRYS
      IF(KMODEO.EQ.1) WRITE(IOBO,3052) QANS
3052  FORMAT(A1,T40,' Crystallite size broadening')
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3054) QANS
3054  FORMAT('  Crystallite size broadening used: ',A1)
C *
C *  BROADENING IS A FUNCTION OF CRYSTALLITE STRAIN
      IF(KMODEO.NE.2) WRITE(ITTO,3060)
3060  FORMAT('  Use crystallite strain broadening ? <N> ')
      READ(ITTI,2011) QANS
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
        KCRYS = KCRYS + 2
        KPROF = IABS( KPROF )
       ELSE
        QANS = 'N'
      ENDIF
      JKCRYS = KCRYS
      IF(KMODEO.EQ.1) WRITE(IOBO,3062) QANS
3062  FORMAT(A1,T40,' Crystallite strain broadening')
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3064) QANS
3064  FORMAT('  Crystallite strain broadening used: ',A1)
C *
C **  ADD REFLECTIONS DUE TO OTHER WAVELENGTHS IF REQUESTED
C *
C *  DONT TRY TO ADD REFS FOR PROFILES WITH REFS BUILT IN
2400  IF(IABS(KPROF).GT.7) GO TO 3100
      NOLD = KNLIN
      DO 2410 I=1,NOLD
2410  CALL PCALC( I )
C *
C **  ADDITIONAL REFINEMENT CRITERIA
C *
C *  APPLICATION OF PATTERN ASYMMETRY FACTOR
3100  IF(.NOT.LFIRST) THEN
        KASYM = JKASYM
        GO TO 3200
      ENDIF
      IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,3110)
3110    FORMAT(/,'  Apply pattern asymmetry factor ? <N> ')
        READ(ITTI,2011) QANS
       ELSE
        QANS = 'N'
      ENDIF
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
        KASYM = 1
       ELSE
        QANS = 'N'
        KASYM = 0
      ENDIF
      JKASYM = KASYM
      IF(KMODEO.EQ.1) WRITE(IOBO,3115) QANS
3115  FORMAT(A1,T40,'Apply asymmetry factor')
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3120) QANS
3120  FORMAT(' Profile asymmetry correction applied: ',A1)
C *
C *  CORRECT TO LORENTZ/POLARIZTION FACTORS?
3200  IF(.NOT.LFIRST) THEN
        KLRNZ = JKLRNZ
        GO TO 3300
      ENDIF
      IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,3210)
3210    FORMAT('  Correct lines for l/p factors ? <Y> ')
        READ(ITTI,2011) QANS
       ELSE
        QANS = 'Y'
      ENDIF
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) THEN
        KLRNZ = 0
       ELSE
        QANS = 'Y'
        KLRNZ = 1
      ENDIF
      JKLRNZ = KLRNZ
      IF(KMODEO.EQ.1) WRITE(IOBO,3215) QANS
3215  FORMAT(A1,T40,'Correct for l/p factors')
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3230) QANS
3230  FORMAT(' L/P correction factors applied to profiles: ',A1)
C *
C *  SELECTION OF ERROR CRITERION
3300  IF(.NOT.LFIRST) THEN
        KERRT = JKERRT
        GO TO 3400
      ENDIF
      IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,3310)
3310    FORMAT('  Use weighted error criterion Rwp ? <Y> ')
        READ(ITTI,2011) QANS
       ELSE
        QANS = 'Y'
      ENDIF
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) THEN
        KERRT = 0
       ELSE
        QANS = 'Y'
        KERRT = 1
      ENDIF
      JKERRT = KERRT
      IF(KMODEO.EQ.1) WRITE(IOBO,3315) QANS
3315  FORMAT(A1,T40,'Use weighted error criterion')
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3330) QANS
3330  FORMAT(' Weighted error criterion for refinement: ',A1)
C *
C **  TYPE OF BACKGROUND TO USE DURING REFINEMENT
C *
C *  HAS BACKGROUND BEEN DETERMINED... IF SO USE IT?
3400  IF(.NOT.LFIRST) THEN
        KBKGR = JKBKGR
        GO TO 1900
      ENDIF
      IF(KBKGD.EQ.0) GO TO 3430
      IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,3410)
3410    FORMAT('  Use calculated background ? <Y> ')
        READ(ITTI,2011) QANS
       ELSE
        QANS = 'Y'
      ENDIF
      IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y'
      IF(KMODEO.EQ.1) WRITE(IOBO,3422) QANS
3422  FORMAT(A1,T40,'Use calc background')
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 3450
      KBKGR = 2
      JKBKGR = KBKGR
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3425)
3425  FORMAT(' Calculated background used')
      GO TO 1900
C *
C *  REFINE FIXED SHAPE BACKGROUND OFFSET
3450  IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,3452)
3452    FORMAT('   Refine fixed shape offset ? <Y> ')
        READ(ITTI,2011) QANS
       ELSE
        QANS = 'Y'
      ENDIF
      IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y'
      IF(KMODEO.EQ.1) WRITE(IOBO,3454) QANS
3454  FORMAT(A1,T40,' Refine fixed shape offset')
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 3430
      KBKGR = 3
      JKBKGR = KBKGR
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3456)
3456  FORMAT(' Refining fixed background shape offset')
      GO TO 1900
C *
C *  REFINE OR LEAVE ZERO?
3430  IF(KATUOP.NE.1) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,3440)
3440    FORMAT('  Background (Z)ero or (R)efine additive value? <R> ')
        READ(ITTI,2011) QANS
       ELSE
        QANS = 'R'
      ENDIF
      IF( QANS.EQ.'Z' .OR. QANS.EQ.'z' ) THEN
        KBKGR = 0
       ELSE
        QANS = 'R'
        KBKGR = 1
      ENDIF
      JKBKGR = KBKGR
      IF(KMODEO.EQ.1) WRITE(IOBO,3441) QANS
3441  FORMAT(A1,T40,'(Z)ero or (R)efine background')
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3442) QANS
3442  FORMAT(' Background (Z)ero or (R)efined: ',A1)
C *
C *  INCLUDE AN AMORPHOUS PROFILE IF SELECTED
C *
1900  IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,1910)
1910    FORMAT(' Include an amorphous profile in pattern ? <N> ')
        READ(ITTI,2011) QANS
       ELSE
        QANS = 'N'
      ENDIF
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN
        KAMOR = 1
       ELSE
        QANS = 'N'
        KAMOR = 0
      ENDIF
      JKAMOR = KAMOR
      IF(KMODEO.EQ.1) WRITE(IOBO,1912) QANS
1912  FORMAT(A1,T40,'Include amorphous profile')
      IF((KMODEO.EQ.2.OR.KAUTOP.EQ.1).AND.QANS.NE.'Y') WRITE(ITTO,1914)
1914  FORMAT(' No amorphous profile included in refinement')
      IF(KAMOR.NE.0) THEN
        IF(KMODEO.NE.2) THEN
          WRITE(ITTO,1920)
1920      FORMAT(/,' Initial estimates of parameters are needed here.',
     1    /,'  Two-theta, Intensity and fwhm for this profile ? ')
          AMOPAR(1) = 0.0
          AMOPAR(2) = 0.0
          AMOPAR(3) = 0.0
          READ(ITTI,*) (AMOPAR(I),I=1,3)
         ELSE
          READ(ITTI,1930) (AMOPAR(I),I=1,3)
1930      FORMAT(F10.4,F10.2,F7.2)
        ENDIF
        IF(KMODEO.EQ.1) WRITE(IOBO,1932) (AMOPAR(I),I=1,3)
1932    FORMAT(F10.4,F10.2,F7.2,T40,'Amorphous profile parameters')
        IF(KMODEO.EQ.2.OR.KAUTOP.EQ.1) WRITE(ITTO,1934)(AMOPAR(I),I=1,3)
1934    FORMAT(' Amorphous profile parameters:',
     1  '  POS ',F8.4,'  HGT ',F8.2,'  FWHM ',F5.2)
        AMOPAR(1) = AMOPAR(1) - CORPOS( AMOPAR(1) )
        AMOPAR(2) = AMOPAR(2) * FTIME
      ENDIF
C *
C *  INITIALIZE THE PARAMETERS AND THEIR LIMITS
C *
C *  IF IN AUTO MODE DONT SET UP PARAMETERS
4000  IF(KAUTOP.NE.0) THEN
        NVECS = 1
        GO TO 9100
      ENDIF
C *
C *  INITIALIZE THE PROFILE PARAMETERS
      NVECS = 0
      DO 4010 I=1,KNLIN
4010  CALL PRINIT( I )
C *
C *  BACKGROUND
4100  IF(KBKGR.EQ.1.OR.KBKGR.EQ.3) THEN
        IF(KBKGD.EQ.1) THEN
          BKGPAR = CLY
         ELSE
          BKGPAR = 5.0000 * FTIME
        ENDIF
        NVECS = NVECS + 1
        BVECS(NVECS) = BKGPAR
        BMINS(NVECS) = -10000.00
        BMAXS(NVECS) =  10000.00 * FTIME
      ENDIF
C *
C *  PATTERN ASYMMETRY FACTOR
      IF(KASYM.NE.0) THEN
        ASYPAR = 0.10
        NVECS = NVECS + 1
        BVECS(NVECS) = ASYPAR
        BMINS(NVECS) = 0.0001
        BMAXS(NVECS) = 1.00E+30
      ENDIF
C *
C *  AMORPHOUS PROFILE PARAMETERS- POS,INT,FWHM
      IF(KAMOR.NE.0) THEN
        NVECS = NVECS + 1
        BVECS(NVECS) = AMOPAR(1)
        BMINS(NVECS) = AMOPAR(1) - 2.0
        BMAXS(NVECS) = AMOPAR(1) + 2.0
        NVECS = NVECS + 1
        BVECS(NVECS) = AMOPAR(2)
        BMINS(NVECS) = 0.0001
        BMAXS(NVECS) = AMOPAR(2) * 10.0
        NVECS = NVECS + 1
        BVECS(NVECS) = AMOPAR(3)
        BMINS(NVECS) = 0.0001
        BMAXS(NVECS) = AMOPAR(3) * 5.0
      ENDIF
C *
C *  CRYSTALLITE SIZE PARAMETER (IN NANOMETERS)
      IF( KCRYS.EQ.1 .OR. KCRYS.EQ.3 ) THEN
        CRYPAR(1) = 500.0E-9
        IF(KCRYS.EQ.3) CRYPAR(1) =  600.0E-9
        NVECS = NVECS + 1
        BVECS(NVECS) = CRYPAR(1)
        BMINS(NVECS) =    0.1E-9
        BMAXS(NVECS) = 4000.0E-9
      ENDIF
C *
C *  CRYSTALLITE STRAIN PARAMETER
      IF( KCRYS.EQ.2 .OR. KCRYS.EQ.3 ) THEN
        CRYPAR(2) = 0.0005
        IF(KCRYS.EQ.3) CRYPAR(2) = 0.0001
        NVECS = NVECS + 1
        BVECS(NVECS) = CRYPAR(2)
        BMINS(NVECS) = 1.0E-6
        BMAXS(NVECS) = 1.0
      ENDIF
C *
C *  CHECK FOR EXCEEDING NUMBER OF PARAMETERS FOR REFINEMENT
9000  IF(NVECS.LE.MEMV) GO TO 9100
      WRITE(ITTO,9010) NVECS,MEMV
9010  FORMAT(/,' --NUMBER OF PARAMETERS (',I3,') EXCEEDS THE CURRENT',
     1' PROGRAM LIMIT OF ',I3,/,
     1'   CHANGE THE VALUE OF *MEMV* ON ALL PARAMETER CARDS TO SUIT',
     1' YOUR NEEDS',/)
      STOP '--ABORT:  NUMBER OF PARAMETERS EXCEEDS PROGRAM LIMIT'
C *
9100  RETURN
      END
C ***  PRINIT - INITIALIZE PROFILE PARAMETERS
C *
      SUBROUTINE PRINIT( NPOINT )
C *
      CHARACTER QFTITL*80
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 )
      PARAMETER ( DTOR=1.745329252E-2, RTOD=5.729577951E+1 )
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201)
      COMMON /VECTOR/ NVECS,BVECS(MEMVT2),BMINS(MEMV),BMAXS(MEMV)
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /WDATA/ NWAVE,WTABLE(5,2)
      COMMON /FLDATC/ QFTITL
C *
C *  ALL PROFILES GET ANGLES AND INTENSITIES SET
C *
C *  CONSTRAINTS ON ANGLES -> NO MORE THAN 0.2 DEGREES TWO-THETA
      TTHT = PLPRM(NPOINT,1)
      BMINS(NVECS+1) = TTHT - 0.2
      BMAXS(NVECS+1) = TTHT + 0.2
C *
C *  FWHM VALUES AND EXPONENT VALUES
      PPL = FNFWHM( TTHT, 1)
      PPH = FNFWHM( TTHT, 2)
      PP = 0.5 * ( PPL + PPH )
      PEL = FNSHAP( TTHT, 1)
      PEH = FNSHAP( TTHT, 2)
      PE = 0.5 * ( PEL + PEH )
C *
C *  CONSTRAINTS ON INTENSITIES
      JK = IABS( KPROF )
      BMINS(NVECS+2) = 0.2500
      BMAXS(NVECS+2) = 2.0 * PLPRM(NPOINT,2)
      IF(JK.EQ.14.OR.JK.EQ.15.OR.JK.EQ.6) BMAXS(NVECS+2) = 1.0E10
C *
C *  IF USING -VE PROFILE AND THIS LINE NOT THE FIRST PARAMS ARE SET
      IF( KPROF.LT.0 .AND. NPOINT.GT.1 )GO TO 9000
C *
C *  SELECT PROPER PROFILE FUNCTION
      GO TO(10,10,10,40,10,60,70,80,90,100,110,120,130,140,140,150),JK
C *
C *  GAUSSIAN AND NORMAL, MODIFIED, AND INTERMEDIATE LORENZTIAN
10    KNPRM = 3
C *  ACOEFF - FULL WIDTH AT HALF MAXIMUM
      PLPRM(NPOINT,3) = PP
      BMINS(NVECS+3) = 0.0010
      BMAXS(NVECS+3) = 5.0000
      GO TO 9000
C *
C *  PEARSON VII
40    KNPRM = 4
C *  ACOEFF - FULL WIDTH AT HALF MAX
      PLPRM(NPOINT,3) = PP
      BMINS(NVECS+3) = 0.0010
      BMAXS(NVECS+3) = 5.0000
C *  BCOEFF - EXPONENT
      PLPRM(NPOINT,4) = PE
      BMINS(NVECS+4) = 0.5000
      BMAXS(NVECS+4) = 5.0000
      GO TO 9000
C *
C *  VOIGT PROFILE
60    KNPRM = 4
C *  BETA-G -> GAUSSIAN BREADTH PARAMETER
      PLPRM(NPOINT,3) = PP / 2.0
      BMINS(NVECS+3) = 0.0001
      BMAXS(NVECS+3) = 4.0000
C *  BETA-C -> LORENTZIAN BREADTH PARAMETER
      PLPRM(NPOINT,4) = PP / 2.0
      BMINS(NVECS+4) = 0.0001
      BMAXS(NVECS+4) = 4.0000
      GO TO 9000
C *
C *  SPLIT PEARSON VII
70    KNPRM = 6
C *  ACOEFF - FULL WIDTH AT HALF MAX
      PLPRM(NPOINT,3) = PPL
      BMINS(NVECS+3) = 0.0010
      BMAXS(NVECS+3) = 5.0000
C *  BCOEFF - EXPONENT
      PLPRM(NPOINT,4) = PEL
      BMINS(NVECS+4) = 0.5000
      BMAXS(NVECS+4) = 5.0000
C *  CCOEFF - FULL WIDTH AT HALF MAX
      PLPRM(NPOINT,5) = PPH
      BMINS(NVECS+5) = 0.0010
      BMAXS(NVECS+5) = 5.0000
C *  DCOEFF - EXPONENT
      PLPRM(NPOINT,6) = PEH
      BMINS(NVECS+6) = 0.5000
      BMAXS(NVECS+6) = 5.0000
      GO TO 9000
C *
C *  INTERMEDIATE LORENTZIAN WITH ALPHA2 REFLECTION
80    KNPRM = 3
C *  ACOEFF - FULL WIDTH AT HALF MAXIMUM INTENSITY, ALPHA1
      PLPRM(NPOINT,3) = 0.001
      BMINS(NVECS+3) = 0.0000 - 0.1 * PP
      BMAXS(NVECS+3) = 0.4000
      IF(TTHT.LT.15.0) BMAXS(NVECS+3) = 2.0000
      GO TO 9000
C *
C *  SPLIT PEARSON VII WITH ALPHA 2 REFLECTION
90    KNPRM = 10
C *  ACOEFF - FULL WIDTH AT HALF MAX, ALPHA1
      PLPRM(NPOINT,3) = PPL
      BMINS(NVECS+3) = 0.0010
      BMAXS(NVECS+3) = 5.0000
C *  BCOEFF - EXPONENT, ALPHA1
      PLPRM(NPOINT,4) = PEL
      BMINS(NVECS+4) = 0.5000
      BMAXS(NVECS+4) = 5.0000
C *  CCOEFF - FULL WIDTH AT HALF MAX, ALPHA 1 BACK
      PLPRM(NPOINT,5) = PPH
      BMINS(NVECS+5) = 0.0010
      BMAXS(NVECS+5) = 5.0000
C *  DCOEFF - EXPONENT, ALPHA 1
      PLPRM(NPOINT,6) = PEH
      BMINS(NVECS+6) = 0.5000
      BMAXS(NVECS+6) = 5.0000
C *  ECOEFF - FULL WIDTH AT HALF MAX, ALPHA2 FRONT
      PLPRM(NPOINT,7) = PPL
      BMINS(NVECS+7) = 0.0010
      BMAXS(NVECS+7) = 5.0000
C *  FCOEFF - EXPONENT, ALPHA2
      PLPRM(NPOINT,8) = PEL
      BMINS(NVECS+8) = 0.5000
      BMAXS(NVECS+8) = 5.0000
C *  GCOEFF - FULL WIDTH AT HALF MAX, ALPHA 2 BACK
      PLPRM(NPOINT,9) = PPH
      BMINS(NVECS+9) = 0.0010
      BMAXS(NVECS+9) = 5.0000
C *  HCOEFF - EXPONENT, ALPHA 2
      PLPRM(NPOINT,10) = PEH
      BMINS(NVECS+10) = 0.5000
      BMAXS(NVECS+10) = 5.0000
      GO TO 9000
C *
C *  CONSTRAINED PEARSON WITH REFLECTION
100   KNPRM = 8
C *  ACOEFF - FULL WIDTH AT HALF MAX, ALPHA1 FRONT
      PLPRM(NPOINT,3) = PPL
      BMINS(NVECS+3) = 0.0010
      BMAXS(NVECS+3) = 5.0000
C *  BCOEFF - EXPONENT, ALPHA1
      PLPRM(NPOINT,4) = PEL
      BMINS(NVECS+4) = 0.5000
      BMAXS(NVECS+4) = 5.0000
C *  CCOEFF - FULL WIDTH AT HALF MAX, ALPHA 1 BACK
      PLPRM(NPOINT,5) = PPH
      BMINS(NVECS+5) = 0.0010
      BMAXS(NVECS+5) = 5.0000
C *  DCOEFF - EXPONENT, ALPHA 1
      PLPRM(NPOINT,6) = PEH
      BMINS(NVECS+6) = 0.5000
      BMAXS(NVECS+6) = 5.0000
C *  ECOEFF - FULL WIDTH AT HALF MAX, ALPHA2 FRONT
      PLPRM(NPOINT,7) = PPL
      BMINS(NVECS+7) = 0.0010
      BMAXS(NVECS+7) = 5.0000
C *  FCOEFF - FULL WIDTH AT HALF MAX, ALPHA 2 BACK
      PLPRM(NPOINT,8) = PPH
      BMINS(NVECS+8) = 0.0010
      BMAXS(NVECS+8) = 5.0000
      GO TO 9000
C *
C *  CONSTRAINED PEARSON WITH REFLECTION
110   KNPRM = 6
C *  ACOEFF - FULL WIDTH AT HALF MAX, ALPHA1 AND ALPHA2 FRONT
      PLPRM(NPOINT,3) = PPL
      BMINS(NVECS+3) = 0.0100
      BMAXS(NVECS+3) = 5.0000
C *  BCOEFF - EXPONENT, ALPHA1 AND ALPHA2
      PLPRM(NPOINT,4) = PEL
      BMINS(NVECS+4) = 0.5000
      BMAXS(NVECS+4) = 5.0000
C *  CCOEFF - FULL WIDTH AT HALF MAX, ALPHA 1 AND ALPHA2 BACK
      PLPRM(NPOINT,5) = PPH
      BMINS(NVECS+5) = 0.0100
      BMAXS(NVECS+5) = 5.0000
C *  DCOEFF - EXPONENT, ALPHA 1 AND ALPHA2
      PLPRM(NPOINT,6) = PEH
      BMINS(NVECS+6) = 0.5000
      BMAXS(NVECS+6) = 5.0000
      GO TO 9000
C *
C *  CONSTRAINED PEARSON WITH REFLECTION, CALC FWHM, REFINED SF
120   KNPRM = 4
C *  ACOEFF - EXPONENT, ALPHA1,2 FRONT
      PLPRM(NPOINT,3) = PEL
      BMINS(NVECS+3) = 0.5000
      BMAXS(NVECS+3) = 5.0000
C *  BCOEFF - EXPONENT ALPHA1,2 BACK
      PLPRM(NPOINT,4) = PEH
      BMINS(NVECS+4) = 0.5000
      BMAXS(NVECS+4) = 5.0000
      GO TO 9000
C *
C *  PEARSON VII, FULLY CONSTRAINED
130   KNPRM = 2
      GO TO 9000
C *
C *  CONVOLUTION PRODUCT... LORENTZIAN OR GAUSSIAN WITH INSTRUMENT
140   KNPRM = 2
C *  ACOEFF - INTEGRAL BREADTH OF THE SPECIMEN PROFILE
C *    INITIAL ESTIMATES ARE OBTAINED FROM THE SCHERRER EQUATION.
      IF(KCRYS.NE.0) GO TO 9000
      KNPRM = 3
      SIZE = 500.0E-9
      AX = RTOD * WTABLE(1,1) / ( SIZE * COS(TTHT/2.*DTOR) )
      IF(AX.LT.0.005) AX = 0.005
      PLPRM(NPOINT,3) = AX
      BMINS(NVECS+3) =  0.00001
      BMAXS(NVECS+3) = 10.00000
      GO TO 9000
C *
C *  CONVOLUTION PRODUCT... LORENTZIAN OR GAUSSIAN WITH INSTRUMENT
150   KNPRM = 2
C *  ACOEFF - INTEGRAL BREADTH OF THE SPECIMEN PROFILE
C *    INITIAL ESTIMATES ARE OBTAINED FROM THE SCHERRER EQUATION.
      IF(KCRYS.NE.0) GO TO 9000
      KNPRM = 4
      SIZE = 500.0E-9
      AX = RTOD * WTABLE(1,1) / ( SIZE * COS(TTHT/2.0*DTOR) )
      IF(AX.LT.0.005) AX = 0.005
      PLPRM(NPOINT,3) = AX / 2.0
      BMINS(NVECS+3) =  0.00001
      BMAXS(NVECS+3) = 10.00000
      PLPRM(NPOINT,4) = AX / 2.0
      BMINS(NVECS+4) =  0.00001
      BMAXS(NVECS+4) = 10.00000
C *
C *  COPY PLPRM TO BVECS... INITIAL OPTIMIZATION VECTOR
C *
C *  COPY PARAMETERS FOR INDIVIDUAL PROFILES
9000  IF( NPOINT.NE.1 .AND. KPROF.LT.0 )GO TO 9050
      DO 9010 I=1,KNPRM
      NVECS = NVECS + 1
      BVECS(NVECS) = PLPRM(NPOINT,I)
9010  CONTINUE
      GO TO 9999
C *
C *  COPY PARAMETERS FOR FULLY CONSTRAINED PROFILES
9050  DO 9060 I=1,2
      NVECS = NVECS + 1
      BVECS(NVECS) = PLPRM(NPOINT,I)
9060  CONTINUE
      DO 9070 I=3,KNPRM
9070  PLPRM(NPOINT,I) = PLPRM(1,I)
C *
C *  THE PROFILE PARAMETERS ARE INITIALIZED
9999  RETURN
      END
C ***  RFPLOT - INITIALIZES PLOTTING FOR THE REFINEMENT PHASE
C *
      SUBROUTINE RFPLOT
C *
      LOGICAL LNOMOR
      CHARACTER QFILE*32, ITITLS(5)*20, QANS*1, QFTITL*80
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      PARAMETER ( MAXREC = MPTS/10 )
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /PDATA/ BANG, EANG
      COMMON /FLDATC/ QFTITL
      DIMENSION NCPLOT(5),OFFSET(5),NUMPEN(5),MARKER(5),XDATA(10)
      DATA ITITLS(1)/'OBSERVED PATTERN    '/
      DATA ITITLS(2)/'REFINED PATTERN     '/
      DATA ITITLS(3)/'DIFFERENCE PATTERN  '/
      DATA ITITLS(4)/'CALCULATED PROFILES '/
      DATA ITITLS(5)/'ALPHA 1 PATTERN     '/
C *
C *  DETERMINE WHETHER A PLOTTING FILE IS TO BE GENERATED
C *
1000  KPPLOT = 0
      DO 1005 I=1,5
      KPSETS(I) = 0
      NCPLOT(I) = 0
      OFFSET(I) = 0.0
      NUMPEN(I) = 0
      MARKER(I) = 0
1005  CONTINUE
      IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,1010)
1010    FORMAT(/,' Do you want plotting after refinement ? <N> ')
        READ(ITTI,1020) QANS
1020    FORMAT(A1)
       ELSE
        QANS = 'Y'
      ENDIF
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS = 'N'
      IF(KMODEO.EQ.1) WRITE(IOBO,1030) QANS
1030  FORMAT(A1,T40,'Plotting after refinement')
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) GO TO 2000
      IF((KMODEO.EQ.2.OR.KAUTOP.EQ.1).AND.QANS.NE.'Y') WRITE(ITTO,1040)
1040  FORMAT(' No ploting after refinement')
      GO TO 9000
C *
C *  GET THE OUTPUT FILE NAME AND OPEN IT
2000  KPPLOT = 1
      IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,2010)
2010    FORMAT(' Plot file name ? <RPLOT> ')
        READ(ITTI,2020) QFILE
2020    FORMAT(A32)
       ELSE
        QFILE = 'RPLOT'
      ENDIF
      IF( QFILE(1:1).EQ.'$' .AND. KPTYPE.EQ.0 ) THEN
        WRITE(ITTO,2022)
2022    FORMAT(' -Plot file type changed for formatted')
        KPTYPE = 1
        QFILE(1:) = QFILE(2:)
      ENDIF
      IF( QFILE(1:1).EQ.'$' .AND. KPTYPE.EQ.1 ) THEN
        WRITE(ITTO,2024)
2024    FORMAT(' -Plot file type changed for unformatted')
        KPTYPE = 0
        QFILE(1:) = QFILE(2:)
      ENDIF
      IF( QFILE.EQ.' ' .OR. QFILE.EQ.'/' ) QFILE = 'RPLOT'
      IF(KMODEO.EQ.1) THEN
        WRITE(IOBO,2030) QFILE
2030    FORMAT(A32,T40,' Plot file name')
        GO TO 3000
      ENDIF
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,2040) QFILE
2040  FORMAT(' Refinement plot data stored on: ',A32)
      IF(KPTYPE.EQ.0) THEN
        OPEN(UNIT=IOPL,FILE=QFILE,STATUS='UNKNOWN',FORM='UNFORMATTED',
     1     ERR=2100)
       ELSE
        OPEN(UNIT=IOPL,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED',
     1     ERR=2100)
      ENDIF
      GO TO 3000
2100  WRITE(ITTO,2110)
2110  FORMAT(' --Can not open plot file:  No plot data will be written')
      KPPLOT = 0
      GO TO 9000
C *
C **  USE DEFAULT PARAMS OR SET THEM INDIVIDUALLY....
C *
3000  IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,3010)
3010    FORMAT(' Do you want the default plots ? <Y> ')
        READ(ITTI,1020) QANS
       ELSE
        QANS = 'Y'
      ENDIF
      IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y'
      IF(KMODEO.EQ.1) WRITE(IOBO,3020) QANS
3020  FORMAT(A1,T40,' Default plot set')
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3030) QANS
3030  FORMAT('  Generate the default refinement plots: ',A1)
      IF(QANS.EQ.'N') GO TO 3200
C *
C **  SET DEFAULT PARAMETERS
C *
      NUMSTS = 3
C *  RAW
      KPSETS(1) =  1
      NCPLOT(1) =  1
      OFFSET(1) =  0.0
      NUMPEN(1) =  2
      MARKER(1) =  0
C *  REFINED
      KPSETS(2) =  2
      NCPLOT(2) =  1
      OFFSET(2) =  0.0
      NUMPEN(2) =  3
      MARKER(2) =  0
C *  DIFFERENCE
      KPSETS(3) =  0
      NCPLOT(3) =  0
      OFFSET(3) =  0.0
      NUMPEN(3) =  0
      MARKER(3) =  0
C *  PROFILES
      KPSETS(4) =  3
      NCPLOT(4) =  1
      OFFSET(4) =  0.0
      NUMPEN(4) =  4
      MARKER(4) =  0
C *  CORRECTED
      KPSETS(5) =  0
      NCPLOT(5) =  0
      OFFSET(5) =  0.0
      NUMPEN(5) =  0
      MARKER(5) =  0
C *  AXIS
      NPLOTS = 1
      IAXIS = 0
      FS = 1200.0
      DPI = 2.
      GO TO 5000
C *
C **  GET THE NON STANDARD PLOTTING PARAMETERS
C *
C *  TELL THEM HOW TO DO IT
3200  NUMSTS = 0
      IF(KMODEO.NE.2)WRITE(ITTO,3210)
3210  FORMAT(/,' The following questions pertain to plotting of the',
     1 ' results.',/,' Enter <+N,0 or -N> for plotting of every',
     1 ' Nth point in the data set.',//,
     1 3X,' +N => Draw lines between each Nth point',/,
     1 3X,'  0 => Skips the data set',/,
     1 3X,' -N => Draw dots at each Nth point',//,
     1 ' Follow N with a value for the offset (in inches) to',
     1 ' separate',/,' the data groups.  e.g., .75 displaces the data',
     1 ' set .75 inches.',//,
     1 ' The final parameter specifies the pen to use in plotting',
     1 ' the data set.')
C *
C *  RAW PATTERN
3300  KPSETS(1) = 0
      NCPLOT(1) = 0
      OFFSET(1) = 0.0
      NUMPEN(1) = 0
      MARKER(1) = 0
      IF(KMODEO.NE.2) THEN
        WRITE(ITTO,3310)
3310    FORMAT(/,' Raw data ? <0,0.0,0> ')
        READ(ITTI,*) NCPLOT(1),OFFSET(1),NUMPEN(1)
       ELSE
        READ(ITTI,3320) NCPLOT(1),OFFSET(1),NUMPEN(1)
3320    FORMAT(I3,F5.2,I3)
      ENDIF
      IF(NCPLOT(1).NE.0) THEN
        NUMSTS = NUMSTS + 1
        KPSETS(1) = NUMSTS
      ENDIF
      IF(KMODEO.EQ.1) WRITE(IOBO,3330)NCPLOT(1),OFFSET(1),NUMPEN(1)
3330  FORMAT(I3,F5.2,I3,T40,' Plot params')
C *
C *  CALCULATED PATTERN
3400  KPSETS(2) = 0
      NCPLOT(2) = 0
      OFFSET(2) = 0.0
      NUMPEN(2) = 0
      MARKER(2) = 0
      IF(KMODEO.NE.2) THEN
        WRITE(ITTO,3410)
3410    FORMAT(' Calculated pattern ? <0,0.0,0> ')
        READ(ITTI,*) NCPLOT(2),OFFSET(2),NUMPEN(2)
       ELSE
        READ(ITTI,3320) NCPLOT(2),OFFSET(2),NUMPEN(2)
      ENDIF
      IF(NCPLOT(2).NE.0) THEN
        NUMSTS = NUMSTS + 1
        KPSETS(2) = NUMSTS
      ENDIF
      IF(KMODEO.EQ.1) WRITE(IOBO,3330)NCPLOT(2),OFFSET(2),NUMPEN(2)
C *
C * DIFFERENCE PATTERN
3500  KPSETS(3) = 0
      NCPLOT(3) = 0
      OFFSET(3) = 0.0
      NUMPEN(3) = 0
      MARKER(3) = 0
      IF(KMODEO.NE.2) THEN
        WRITE(ITTO,3510)
3510    FORMAT(' Difference pattern ? <0,0.0,0> ')
        READ(ITTI,*) NCPLOT(3),OFFSET(3),NUMPEN(3)
       ELSE
        READ(ITTI,3320) NCPLOT(3),OFFSET(3),NUMPEN(3)
      ENDIF
      IF(NCPLOT(3).NE.0) THEN
        NUMSTS = NUMSTS + 1
        KPSETS(3) = NUMSTS
      ENDIF
      IF(KMODEO.EQ.1) WRITE(IOBO,3330)NCPLOT(3),OFFSET(3),NUMPEN(3)
C *
C *  INDIVIDUAL PROFILES
3600  KPSETS(4) = 0
      NCPLOT(4) = 0
      OFFSET(4) = 0.0
      NUMPEN(4) = 0
      MARKER(4) = 0
      IF(KMODEO.NE.2) THEN
        WRITE(ITTO,3610)
3610    FORMAT(' Calculated profiles ? <0,0.0,0> ')
        READ(ITTI,*) NCPLOT(4),OFFSET(4),NUMPEN(4)
       ELSE
        READ(ITTI,3320) NCPLOT(4),OFFSET(4),NUMPEN(4)
      ENDIF
      IF(NCPLOT(4).NE.0) THEN
        NUMSTS = NUMSTS + 1
        KPSETS(4) = NUMSTS
      ENDIF
      IF(KMODEO.EQ.1) WRITE(IOBO,3330)NCPLOT(4),OFFSET(4),NUMPEN(4)
C *
C *  ALPHA 1 PATTERN
3700  KPSETS(5) = 0
      NCPLOT(5) = 0
      OFFSET(5) = 0.0
      NUMPEN(5) = 0
      MARKER(5) = 0
      IF(KMODEO.NE.2) THEN
        WRITE(ITTO,3710)
3710    FORMAT(' Alpha 1 pattern ? <0,0.0,0> ')
        READ(ITTI,*) NCPLOT(5),OFFSET(5),NUMPEN(5)
       ELSE
        READ(ITTI,3320) NCPLOT(5),OFFSET(5),NUMPEN(5)
      ENDIF
      IF(NCPLOT(5).NE.0) THEN
        NUMSTS = NUMSTS + 1
        KPSETS(5) = NUMSTS
      ENDIF
      IF(KMODEO.EQ.1) WRITE(IOBO,3330)NCPLOT(5),OFFSET(5),NUMPEN(5)
C *
C **  AXIS INFORMATION
C *
4000  IF(KMODEO.NE.2) THEN
        WRITE(ITTO,4002)
4002    FORMAT(/,' Number of plots per page ? (1 OR 2) <1> ')
        NPLOTS = 1
        READ(ITTI,*) NPLOTS
       ELSE
        READ(ITTI,4004) NPLOTS
4004    FORMAT(I2)
      ENDIF
      IF(NPLOTS.EQ.0) NPLOTS = 1
      IF( NPLOTS.LT.-2 .OR. NPLOTS.GT.2 ) NPLOTS = 1
      IF(KMODEO.EQ.1) WRITE(IOBO,4006) NPLOTS
4006  FORMAT(I2,T40,' Plots per page')
      DPI = 2.0
      IF(NPLOTS.LT.0) THEN
        IF(KMODEO.NE.2) THEN
          WRITE(ITTO,4010)
4010      FORMAT(' Degrees per inch for two-theta axis ? <2.0> ')
          READ(ITTI,*) DPI
         ELSE
          READ(ITTI,4012) DPI
4012      FORMAT(F6.2)
        ENDIF
        IF(DPI.LE.0.0) DPI = 2.0
        IF(KMODEO.EQ.1) WRITE(IOBO,4014) DPI
4014    FORMAT(F6.2,T40,' Deg/inch two-theta')
      ENDIF
C *
4040  IF(KMODEO.NE.2) WRITE(ITTO,4042)
4042  FORMAT(' Draw the axis system ? <Y> ')
      READ(ITTI,1020) QANS
      IAXIS = 0
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) IAXIS = 1
      IF(KMODEO.EQ.1) WRITE(IOBO,4050) QANS
4050  FORMAT(A1,T40,' Draw axis system')
C *
      IF(KMODEO.NE.2) THEN
        WRITE(ITTO,4060)
4060    FORMAT(' Full scale value for intensity axis ? <1200.0> ')
        READ(ITTI,*) FS
       ELSE
        READ(ITTI,4022) FS
4022    FORMAT(F8.2)
      ENDIF
      IF(FS.LE.0.0) FS = 1200.0
      IF(KMODEO.EQ.1) WRITE(IOBO,4070) FS
4070  FORMAT(F8.2,T40,' Full scale')
C *
C **  WRITE THE INITIAL INFORMATION TO THE PLOT FILE
C *
C *  IF BATCH SETUP... DONT WRITE FILE
5000  IF(KMODEO.EQ.1) GO TO 9000
C *
C *  WRITE THE FILE HEADER
      KYID = 0
      IF(KPTYPE.EQ.0) THEN
        WRITE(IOPL) QFTITL
        WRITE(IOPL) BANG,EANG,FAINC
        WRITE(IOPL) NUMSTS,NPLOTS,IAXIS,DPI,FS,KYID
        DO 5010 I=1,5
        IF(KPSETS(I).EQ.0) GO TO 5010
        WRITE(IOPL) ITITLS(I),NCPLOT(I),OFFSET(I),NUMPEN(I),MARKER(I)
5010    CONTINUE
       ELSE
        WRITE(IOPL,5020) QFTITL
5020    FORMAT(A80)
        WRITE(IOPL,5030) BANG,EANG,FAINC
5030    FORMAT(3F10.4)
        WRITE(IOPL,5040) NUMSTS,NPLOTS,IAXIS,DPI,FS,KYID
5040    FORMAT(3I6,F6.2,2I6)
        DO 5050 I=1,5
        IF(KPSETS(I).EQ.0) GO TO 5050
        WRITE(IOPL,5060) ITITLS(I),NCPLOT(I),OFFSET(I),NUMPEN(I),
     1  MARKER(I)
5060    FORMAT(A20,I6,F6.2,2I6)
5050    CONTINUE
      ENDIF
C *
C **  PUT THE RAW DATA IN THE PLOT FILE NOW...
C *
6000  IF(KPSETS(1).EQ.0) GO TO 9000
C *
C *  SKIP HEADER AND SKIP RECORDS
      REWIND (UNIT=IOFI)
      IF(KFILET.EQ.0) THEN
        DO 6010 I=1,3
6010    READ(IOFI,6020) JUNK
6020    FORMAT(1A1)
       ELSE
        DO 6030 I=1,3
6030    READ(IOFI) JUNK
      ENDIF
C *
C *  READ THE INPUT RECORDS
6100  NTOGO = NINT( (FEANG-FBANG) / FAINC ) + 1
      NGONE  = 0
      NTOTAL = 0
6105  NPASS = 0
      LNOMOR = .TRUE.
      DO 6110 I=1,MAXREC
      IF(KFILET.EQ.0) THEN
        READ(IOFI,6120,END=6200) XDATA
6120    FORMAT(10F7.0)
       ELSE
        READ(IOFI,END=6200) XDATA
      ENDIF
      DO 6130 J=1,10
      NPASS  = NPASS  + 1
      YSYN(NPASS) = XDATA(J)
      NTOTAL = NTOTAL + 1
      IF(NTOTAL.EQ.NTOGO) GO TO 6200
6130  CONTINUE
6110  CONTINUE
      LNOMOR = .FALSE.
6200  ANGLE = FBANG + REAL(NGONE) * FAINC
      IF(KPTYPE.EQ.0) THEN
        WRITE(IOPL) KPSETS(1),NPASS,ANGLE
        WRITE(IOPL) (YSYN(I)/FTIME,I=1,NPASS)
       ELSE
        WRITE(IOPL,6210) KPSETS(1),NPASS,ANGLE
6210    FORMAT(I6,I6,F10.4)
        WRITE(IOPL,6220) (YSYN(I)/FTIME,I=1,NPASS)
6220    FORMAT(10F8.1)
      ENDIF
      NGONE = NGONE + NPASS
      IF(.NOT.LNOMOR) GO TO 6105
C *
C *  INITIALIZATION COMPLETE... EXIT
9000  RETURN
      END
C ***  PCALC
C *
C *  PCALC ADDS LINES CORRESPONDING TO THE WAVELENGTHS IN THE
C *  WAVELENGTH TABLE.  ARGUMENT IPEAK POINTS TO THE LINE
C *  THAT WILL HAVE REFLECTIONS ADDED.
C *
      SUBROUTINE PCALC( IPEAK )
C *
      CHARACTER QANS*1, QFTITL*80
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201)
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /WDATA/ NWAVE,WTABLE(5,2)
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /FLDATC/ QFTITL
C *
C *  DO NOT EXECUTE IF THERE IS ONLY ONE WAVELENGTH TABLED
      IF(NWAVE.EQ.1) GO TO 600
C *
C *  ADD REFLECTIONS DUE TO ADDITIONAL WAVELENGTHS
      IF(KMODEO.NE.2) WRITE(ITTO,100)IPEAK,PLPRM(IPEAK,1),
     1  PLPRM(IPEAK,2)/FTIME,KRLIN(IPEAK)
100   FORMAT(/,' Line ',I2,': Ang = ',F6.2,' Int = ',F8.2,
     1' Wavelength = ',I2)
      IF(KMODEO.NE.2)WRITE(ITTO,105)
105   FORMAT(' Add reflections ? <N> ')
      READ(ITTI,110) QANS
110   FORMAT(A1)
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS = 'N'
      IF(KMODEO.EQ.1) WRITE(IOBO,107) QANS,IPEAK
107   FORMAT(A1,T40,'Reflections for line ',I3)
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) GO TO 600
C *
      RTOD = 360.00 / ( 2.00 * 3.141592653590 )
      PANG = PLPRM(IPEAK,1)
      PMAX = PLPRM(IPEAK,2)
C *
C *  LIST NEW PARAMETERS
      WRITE(ITTO,130) PANG,PMAX/FTIME
130   FORMAT(' Primary line 1 at: ',F10.4,' Intensity: ',F10.4)
C *
C *  USE THE FIRST WAVELENGTH TO DETERMINE THE CORRESPONDING D-SPACING
      RAD = (PANG/2.0) / 360.00 * ( 2.00 * 3.141592653590 )
      DSP = WTABLE(1,1) / ( 2.00 * SIN(RAD) )
C *
C *  ADD ADDITIONAL LINES CORRESPONDING TO OTHER WAVELENGTHS
      DO 500 I=2,NWAVE
C *
C *  DETERMINE THE BRAGG ANGLE AND INTENSITY FOR REQUESTED WAVELENGTH
      WPOS = 2.00 * RTOD * ASIN( WTABLE(I,1)/(2.00*DSP) )
      WINT = PMAX * WTABLE(I,2)
      WRITE(ITTO,140) I,WPOS,WINT/FTIME
140   FORMAT('   Reflection ',I1,' at: ',F10.4,' Intensity: ',F10.4)
      KNLIN = KNLIN + 1
      PLPRM(KNLIN,1) = WPOS
      PLPRM(KNLIN,2) = WINT
      KRLIN(KNLIN) = I
500   CONTINUE
C *
600   RETURN
      END
C ***  DINPUT - FETCH REQUESTED SCAN DATA FROM PATTERN FILE
C *
      SUBROUTINE DINPUT( START, END )
C *
C *  WHERE:  START = REQUESTED STARTING ANGLE
C *          END   = REQUESTED ENDING ANGLE
C *
      CHARACTER QJUNK*1, QFTITL*80
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /PDATA/ BANG, EANG
      COMMON /FLDATC/ QFTITL
      DIMENSION XDATA(10)
C *
      KOBS = 0
      NSKIPB = INT( (START-FBANG)/FAINC + 0.1 )
      BANG = FBANG + REAL(NSKIPB) * FAINC
      NRSKIP = NSKIPB / 10
      NPSKIP = NSKIPB - NRSKIP * 10
      NSKIPE = NINT( (END-FBANG)/FAINC )
      EANG = FBANG + REAL(NSKIPE) * FAINC
      NTOGET = NSKIPE - NSKIPB + 1
C *
C *  SKIP RECORDS AT BEGINNING OF THE FILE
      REWIND (UNIT=IOFI)
      NRSKIP = NRSKIP + 3
      IF(KFILET.EQ.0) THEN
        DO 2010 I=1,NRSKIP
2010    READ(IOFI,2012) QJUNK
2012    FORMAT(1A1)
       ELSE
        DO 2014 I=1,NRSKIP
2014    READ(IOFI) QJUNK
      ENDIF
C *
C *  READ NEXT RECORD IF ANY POINTS ARE ON IT
      IF(NPSKIP.EQ.0) GO TO 2040
      IF(KFILET.EQ.0) THEN
        READ(IOFI,2025) XDATA
2025    FORMAT(10F7.0)
       ELSE
        READ(IOFI) XDATA
      ENDIF
      DO 2032 I = (NPSKIP+1), 10
      KOBS = KOBS +1
      YOBS(KOBS) = XDATA(I)
      IF(KOBS.EQ.NTOGET) GO TO 3000
2032  CONTINUE
C *
C *  KEEP READING UNTIL THE PROPER NUMBER OF POINTS HAVE BEEN READ
2040  IF(KFILET.EQ.0) THEN
2100    READ(IOFI,2025,END=2300) XDATA
        DO 2160 J = 1, 10
        KOBS = KOBS + 1
        YOBS(KOBS) = XDATA(J)
        IF(KOBS.EQ.NTOGET) GO TO 3000
2160    CONTINUE
        GO TO 2100
       ELSE
2200    READ(IOFI,END=2300) XDATA
        DO 2262 J = 1, 10
        KOBS = KOBS + 1
        YOBS(KOBS) = XDATA(J)
        IF(KOBS.EQ.NTOGET) GO TO 3000
2262    CONTINUE
        GO TO 2200
      ENDIF
C *
2300  WRITE(ITTO,2310) KOBS
2310  FORMAT(/,' -EOF was prematurely hit.  Points read = ',I4)
C *
C *  ASSOCIATE ANGLES WITH INTENSITIES
C *
3000  BANG = BANG - FAINC
      DO 3010 I=1,KOBS
3010  YANG(I) = BANG + REAL(I) * FAINC
      BANG = YANG(   1)
      EANG = YANG(KOBS)
C *
9000  RETURN
      END
C ***  PROGRAM: SHADOW  (SHADOW32)
C ***  VERSION: 880228  (YYMMDD)
C *
C ***  BSOLVE - LEAST-SQUARES OPTIMIZATION ALGORITHM
C *
      SUBROUTINE BSOLVE( IMODE )
C *
      LOGICAL LMARQ,LTOCOM
      DOUBLE PRECISION PHI,PH,PRESID,OBSTOT,DG,DN,GN,COSG,GAMM,DPSUM
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      PARAMETER ( MEMSCR = 12000 )
      PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 )
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201)
      COMMON /DERDAT/ DERIVS(MPTS),ZCALC(MPTS),NCLINE,NCSTRT,NCFINI
      COMMON /VECTOR/ NVECS,BVECS(MEMVT2),BMINS(MEMV),BMAXS(MEMV)
      COMMON /SCRTCH/ SCRDAT(MEMSCR),IPOINT(MEMV,4)
      COMMON /OPTRES/ RERR,RESID,ICON,ITER
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /MATRIX/ AMAT(MEMV,MEMVP1)
      COMMON /DIAGS/ ISENSE(10)
      COMMON WGTS(MPTS), ZDIFF(MPTS)
      DIMENSION AKP2(MEMV),ACKP2(MEMV),PRMS(MEMVT2)
C *
C **  SETUP FOR REFINEMENT
C *
C *  SET MAX ITERATION LIMIT
      ITERLM = 999
      IF( ITER.GT.0 .AND. ITER.LT.1000 ) ITERLM = ITER
      ITER = 0
      ITER1 = 0
C *
C *  MAKE SURE WE DONT TRY TO EXCEED THE NUMBER OF VARIABLES POSSIBLE
100   WRITE(ITTO,110) NVECS,ITERLM
110   FORMAT(/,
     1 ' Variables for refinement: ',I3,'  Iteration limit: ',I3,/)
      IF(NVECS.GT.MEMV) THEN
        WRITE(ITTO,120) MEMV
120     FORMAT(/,
     1  ' --Number of variables exceeds program limit of ',I3,
     1  ', Refinement skipped.')
        ICON = -4
        GO TO 9000
      ENDIF
C *
C **  MODE OF OPERATION.  REGULAR GAUSS-NEWTON OR MARQUARDT
      LMARQ = IMODE.EQ.0
C *
C *  INITIALIZE VARIABLES
      N = KOBS
      K = NVECS
      KP1 = K + 1
      FNU = 2.0
      FL = 1.00
      RRLX = 0.5
      RLX = 1.0
      TAU = 0.001
      EPS = 0.001
      PH = 1.0D20
      ICON = 999
C *
C *  CAN PARAMETERS BE TRANSFERRED TO THE SCRATCH ARRAY?
      LTOCOM = ( K * KP1 ) .LE. MEMSCR
C *
C *  DETERMINE DENOMINATOR FOR THE ERROR AND WEIGHTS IF NECESSARY
1000  OBSTOT = 0.0
      IF(KERRT.EQ.0) THEN
        DO 1005 I=1,N
1005    OBSTOT = OBSTOT + YOBS(I)**2
       ELSE
        DO 1010 I=1,N
        WGTS(I) = 1.0 / AMAX1( 1.0, YOBS(I) )
        OBSTOT = OBSTOT + WGTS(I)*YOBS(I)**2
1010    CONTINUE
      ENDIF
C *
C *  COPY ORIGINAL PARAMETERS
1015  DO 1020 J1=1,K
      PRMS(J1) = BVECS(J1)
      J1PK = J1 + K
COLD  PRMS(J1PK) = ABS( BVECS(J1) ) + 1.0E-2
      PRMS(J1PK) = AMAX1( BVECS(J1), 1.0E-10 )
      BVECS(J1PK) = 0.0
1020  CONTINUE
C *
C *  MAKE SURE CURRENT BACKGROUND IS CORRECT.  BACKGROUND FOR KBKGR
C *  EQUAL TO 1 OR 3 GENERATED AT SECTION LABELED 1700.
      IF( KBKGR.NE.1 .AND. KBKGR.NE.3 ) CALL BKGLVL( YBKG )
C *
C *  GENERATE CALCULATED PATTERN AND EVALUATE BEGINNING ERROR
      GO TO 1700
C *
C **  DETERMINE DERIVATIVES
C *
C *  IF ONLY ONE LINE BEING REFINED, OR JUST THE AMORPHOUS PROFILE,
C *  COPY THE LINE TO ZCALC AND SET NCLINE
1100  IF( KNLIN.GT.1 .OR. ( KNLIN.EQ.1 .AND. KAMOR.NE.0 ) ) THEN
        NCLINE = 0
       ELSE
        DO 1102 I=1,KOBS
1102    ZCALC(I) = YSYN(I)
        NCLINE = 1
        IF(KNLIN.EQ.0) NCLINE = -1
        NCFINI = KLLIN(1)/16384
        NCSTRT = KLLIN(1) - NCFINI*16384
      ENDIF
C *
C *  CALCULATE (WEIGHTED) DIFFERENCE IN ZDIFF
      IF(KERRT.EQ.0) THEN
        DO 1104 I=1,KOBS
1104    ZDIFF(I) = YOBS(I) - YSYN(I) - YBKG(I)
       ELSE
        DO 1106 I=1,KOBS
1106    ZDIFF(I) = WGTS(I) * ( YOBS(I) - YSYN(I) - YBKG(I) )
      ENDIF
C *
C *  INIT THE SCRATCH MEMORY
      CALL SCRMEM( FUNK1, JUNK2, JUNK3, JUNK4, 0 )
C *
C *  REPEAT FOR EACH PARAMETER
      DO 1110 J1=1,K
C *
C *  DETERMINE INCREMENTAL PARAMETER SHIFTS
      DO 1120 J2=1,K
1120  PRMS(J2) = BVECS(J2)
      DEN = 0.00001 * AMAX1( ABS(PRMS(J1)), PRMS(J1+K) )
      IF( (PRMS(J1)+DEN) .LE. BMAXS(J1) ) THEN
        PRMS(J1) = PRMS(J1) + DEN
       ELSE
        PRMS(J1) = PRMS(J1) - DEN
        DEN = -DEN
      ENDIF
C *
C *  DETERMINE DERIVATIVES WITH PARAMETER SHIFT
      CALL GENDER( PRMS, J1, DEN, ISTART, IFINIS )
C *
C *  WRITE THE DERIVATIVES TO THE SCRATCH MEMORY
      CALL SCRMEM( DERIVS, ISTART, IFINIS, J1, 1 )
C *
C *  CALCULATE LAST MATRIX COLUMN
      DPSUM = 0.0D00
      DO 1225 J2=ISTART,IFINIS
1225  DPSUM = DPSUM + DPROD( DERIVS(J2), ZDIFF(J2) )
      AMAT(J1,KP1) = SNGL( DPSUM )
C *
C *  NEXT PARAMETER
1110  CONTINUE
C *
C **  SET UP CORRECTION EQUATIONS
C *
C *  REPEAT FOR ALL PARAMETERS
1200  DO 1210 J1=1,K
C *
C *  RETRIEVE THE DERIVATIVES FROM SCRATCH MEMORY
      CALL SCRMEM( YSYN, ISTAR0, IFINI0, J1, -1 )
C *
C *  DETERMINE THE DIAGONAL COMPONENT
      DPSUM = 0.0D00
      IF(KERRT.EQ.0) THEN
        DO 1238 J3=ISTAR0,IFINI0
1238    DPSUM = DPSUM + DPROD( YSYN(J3), YSYN(J3) )
       ELSE
        DO 1235 J3=ISTAR0,IFINI0
1235    DPSUM = DPSUM + DBLE(WGTS(J3)) *  DPROD( YSYN(J3), YSYN(J3) )
      ENDIF
      AMAT(J1,J1) = SNGL( DPSUM )
      IF(J1.EQ.K) GO TO 1210
C *
C *  IF ERROR IS WEIGHTED THEN WEIGHT YSYN NOW
      IF(KERRT.NE.0) THEN
        DO 1236 I=ISTAR0,IFINI0
1236    YSYN(I) = DPROD( YSYN(I), WGTS(I) )
      ENDIF
C *
C *  DETERMINE OFF-DIAGONAL ELEMENTS
      DO 1230 J2=J1+1,K
      AMAT(J1,J2) = 0.0
      AMAT(J2,J1) = 0.0
      CALL SCRMEM( ZCALC, ISTAR1, IFINI1, J2, -1 )
C *  DETERMINE OVERLAP REGION OF DERIVATIVE SETS
      I0 = IFINI0 - ISTAR1
      I1 = IFINI1 - ISTAR0
      IF( I0.LT.1 .OR. I1.LT.1 ) GO TO 1230
      ISTAR2 = MAX0( ISTAR0, ISTAR1 )
      IFINI2 = MIN0( IFINI0, IFINI1 )
C *  FIND NUMERICAL VALUES
      DPSUM = 0.0D00
      DO 1253 J3=ISTAR2,IFINI2
1253  DPSUM = DPSUM + DPROD( YSYN(J3), ZCALC(J3) )
      AMAT(J1,J2) = SNGL( DPSUM )
      AMAT(J2,J1) = SNGL( DPSUM )
1230  CONTINUE
C *
C *  NEXT SET OF ELEMENTS
1210  CONTINUE
C *
C **  CORRECT FOR NEAR ZERO DIAGONAL ELEMENT
      DO 1260 J1=1,K
      IF(AMAT(J1,J1).GT.1.0E-20) GO TO 1260
      IF(ITER1.EQ.0) WRITE(ITTO,1265) J1,ITER
1265  FORMAT('   Parameter: ',I3,'  Eliminated on cycle ',I4)
      DO 1270 J3=1,KP1
1270  AMAT(J1,J3) = 0.0
      AMAT(J1,J1) = 1.0
1260  CONTINUE
C *
C * EXIT HERE IF JUST SETTING UP NORMAL EQUATION MATRIX
      IF(ITER1.EQ.1) GO TO 2260
C *
C *  CALCULATE VECTOR COMPONENT
      GN = 0.0
      IF(LMARQ) THEN
        DO 1255 J1=1,K
1255    GN = GN + AMAT(J1,KP1)**2
      ENDIF
C *
C **  SCALE CORRECTION EQUATIONS
C *
1300  DO 1310 J1=1,K
1310  AKP2(J1) = SQRT( AMAT(J1,J1) )
      DO 1314 J1=1,K
      AMAT(J1,KP1) = AMAT(J1,KP1) / AKP2(J1)
      DO 1316 J2=1,K
      AMAT(J1,J2) = AMAT(J1,J2) / ( AKP2(J1)*AKP2(J2) )
1316  CONTINUE
1314  CONTINUE
C *
C *  VERIFY MATRIX
      IF(ISENSE(4).GT.0) THEN
        WRITE(ITTO,1317) (J1,J1=1,K)
1317    FORMAT(/,6X,30(1X,I3))
        DO 1320 J1=1,K
1320    WRITE(ITTO,4) J1,(NINT(AMAT(J1,LL)*100.0),LL=1,K)
4       FORMAT(1X,I3,2X,30(1X,I3))
      ENDIF
C *
C **  DETERMINE LAMBDA AND ADD TO DIAGONAL ELEMENTS
C *
C *  WRITE THE A MATRIX TO THE SCRATCH FILE FOR POSSIBLE LATER USE
1400  IF(LMARQ) THEN
C *
        IF(LTOCOM) THEN
          NTEMP = 0
          DO 1402 J1=1,K
          DO 1402 J2=1,KP1
          NTEMP = NTEMP + 1
          SCRDAT(NTEMP) = AMAT(J1,J2)
1402      CONTINUE
         ELSE
          REWIND (UNIT=IOSC)
          WRITE(IOSC) ((AMAT(J1,J2),J1=1,K),J2=1,KP1)
        ENDIF
C *
C *  DECREASE THE SIZE OF FL
        FL = FL / FNU
C *
C *  ADD TO DIAGONAL
1415    DO 1425 J1=1,K
1425    AMAT(J1,J1) = AMAT(J1,J1) + FL
C *
      ENDIF
C *
C **  SOLVE CORRECTION EQUATIONS
C *
1500  DO 1510 L1=1,K
      L1P1 = L1 + 1
      DO 1515 L2=L1P1,KP1
      IF(AMAT(L1,L1).EQ.0.0) THEN
        WRITE(ITTO,1502)
1502    FORMAT(' -BSOLVE: Avoiding zero division in matrix solution.')
        GO TO 1516
      ENDIF
      AMAT(L1,L2) = AMAT(L1,L2) / AMAT(L1,L1)
1515  CONTINUE
1516  DO 1520 L3=1,K
      IF( L1-L3 ) 1530,1520,1530
1530  DO 1525 L4=L1P1,KP1
1525  AMAT(L3,L4) = AMAT(L3,L4) - AMAT(L1,L4) * AMAT(L3,L1)
1520  CONTINUE
1510  CONTINUE
C *
C **   SOLVE FOR NEXT SOLUTION VECTOR AND APPLY CONSTRAINTS
C *
C *  SOLVE FOR NEXT SET OF PARAMETERS
1600  DN = 0.0
      DG = 0.0
      DO 1610 J1=1,K
      ACKP2(J1) = AMAT(J1,KP1) / AKP2(J1)
      IF(ISENSE(4).EQ.2) WRITE(ITTO,6) J1,ACKP2(J1)
6     FORMAT(' PARAMETER ',I3,'  ADJUSTMENT ',E13.6)
      BPADJ =  BVECS(J1) + ACKP2(J1)
      IF(BPADJ.GT.BMAXS(J1)) WRITE(ITTO,10) J1,BPADJ,BMAXS(J1)
10    FORMAT('   Parameter ',I3,':  Calculated Value ',E13.6,
     1  ' Max limit ',E13.6)
      BPADJ = AMIN1( BMAXS(J1), BPADJ )
      IF(BPADJ.LT.BMINS(J1)) WRITE(ITTO,11) J1,BPADJ,BMINS(J1)
11    FORMAT('   Parameter ',I3,':  Calculated Value ',E13.6,
     1  ' Min limit ',E13.6)
      PRMS(J1) = AMAX1( BMINS(J1), BPADJ )
      IF(LMARQ) THEN
        DG = DG + ACKP2(J1) * AMAT(J1,KP1) * AKP2(J1)
        DN = DN + ACKP2(J1) * ACKP2(J1)
      ENDIF
1610  CONTINUE
C *
C *  FACTORS FOR THE MARQUARDT ANALYSIS
      IF(LMARQ) THEN
        COSG = DG / DSQRT( DN*GN )
        IF(ISENSE(4).EQ.2) WRITE(ITTO,7) COSG
7       FORMAT(' COSG = ',E13.6)
        JGAM = 0
        IF( COSG ) 1615,1620,1620
1615    JGAM = 2
        COSG = -COSG
1620    IF(COSG.GT.1.0) COSG = 1.00
        GAMM = DATAN( DSQRT(1.00-COSG*COSG)/COSG )
        GAMM = GAMM * 180.00 / 3.1415926531615
        IF(JGAM.GT.0) GAMM = 180.0 - GAMM
        IF(ISENSE(4).EQ.2) WRITE(ITTO,5)GAMM
5       FORMAT(' GAMM = ',E13.6)
      ENDIF
C *
C **  EVALUATE FUNCTION AND FIND NEW ERROR
C *
C *  GENERATE PROFILES WITH NEW SET OF PARAMETERS
1700  CALL PMSORT( PRMS )
      CALL SHADOW( YSYN, 999, ILO, IHI )
      IF( KBKGR.EQ.1 .OR. KBKGR.EQ.3 ) CALL BKGLVL( YBKG )
C *
C *  DETERMINE THE SUM-OF-SQUARES ERROR
      PRESID = 0.0
      IF(KERRT.EQ.0) THEN
        DO 1710 J1=1,N
1710    PRESID = PRESID + ( YOBS(J1) - YSYN(J1) - YBKG(J1) )**2
       ELSE
        DO 1760 J1=1,N
1760    PRESID = PRESID + WGTS(J1)*( YOBS(J1) - YSYN(J1) - YBKG(J1) )**2
      ENDIF
      PHI = DSQRT( PRESID / OBSTOT )
      IF(PHI.LT.PH) THEN
        IF(LMARQ) THEN
          WRITE(ITTO,2) ITER,PHI*100.0,FL
2        FORMAT(' Iteration = ',I3,'  Error =',F7.2,'  Weight = ',F11.6)
         ELSE
          WRITE(ITTO,3) ITER,PHI*100.0,RLX
3         FORMAT(' Iteration = ',I3,'  Error =',F7.2,'  Relax = ',F8.6)
        ENDIF
      ENDIF
      IF(PHI.LT.1.0E-10) GO TO 2200
      IF(ITER.EQ.0) GO TO 2120
      IF(PHI.GE.PH) GO TO 2000
      IF(.NOT.LMARQ) RLX = 1.0
C *
C **  TEST FOR CONVERGENCE
C *
C *  EPSILON TEST FOR CONVERGENCE BASED ON DEVIATION OF PARAMETERS
1800  ICON = 0
      DO 1810 J1=1,K
      DELTA = ABS( PRMS(J1) - BVECS(J1) )
      IF( DELTA/(TAU+ABS(PRMS(J1))) .GT. EPS ) ICON = ICON + 1
1810  CONTINUE
      IF(ISENSE(4).EQ.2) WRITE(ITTO,8) ICON
8     FORMAT(' ICON = ',I3)
C *
C *  TESTS FOR MARQUARDT PARAMETERS
C *
      IF(.NOT.LMARQ) GO TO 2100
      IF(ICON.NE.0) GO TO 1900
C *
C *  GAMMA EPSILON TEST (IS LAMBDA LARGE?)
      IF( FL.GT.1.0 .AND. GAMM.LE.45.0 ) THEN
        ICON = -3
        WRITE(ITTO,1820) ICON,GAMM,FL
1820    FORMAT(' *BSOLVE* GAMM,FL = ',I2,2X,F10.4,1X,E12.6)
      ENDIF
      GO TO 2100
C *
C *  GAMMA LAMBDA TEST (HAVE THE TWO SOLUTIONS VECTORS DIVERGED?)
1900  IF( FL.GT.1.0 .AND. GAMM.GT.90.0 ) THEN
        ICON = -2
        WRITE(ITTO,1825) ICON,GAMM,FL
1825    FORMAT(' *BSOLVE ABORT* GAMM,FL = ',I2,2X,F10.4,1X,E12.6)
      ENDIF
      GO TO 2100
C *
C **  ERROR INCREASED... TAKE APPROPRIATE ACTION
C *
2000  IF(LMARQ) THEN
C *
C *  INCREASE FL IF THE LIMIT HAS NOT BEEN HIT
        IF(FL.GT.1000.0) THEN
          ICON = -1
          WRITE(ITTO,2010)
2010      FORMAT(' -Maximum limit for diagonal weight hit:  Halting',
     1    ' refinement')
          PHI = PH
          GO TO 2200
         ELSE
          FL = FL * FNU
          IF(LTOCOM) THEN
            NTEMP = 0
            DO 2020 J1=1,K
            DO 2020 J2=1,KP1
            NTEMP = NTEMP + 1
            AMAT(J1,J2) = SCRDAT(NTEMP)
2020        CONTINUE
           ELSE
            REWIND (UNIT=IOSC)
            READ(IOSC) ((AMAT(J1,J2),J1=1,K),J2=1,KP1)
          ENDIF
          GO TO 1415
        ENDIF
C *
       ELSE
C *
C *  DECREASE RELAXATION FACTOR RLX IF THE LIMIT HAS NOT BEEN HIT
        IF(RLX.LT.0.001) THEN
          WRITE(ITTO,2030)
2030      FORMAT(' -Minimum limit for the relaxation factor hit:',
     1    '  Refinement halted')
          ICON = -1
          PHI = PH
          GO TO 2200
         ELSE
          RLX = RLX * RRLX
          DO 2040 J1=1,K
          BPADJ    = BVECS(J1) + ( ACKP2(J1) * RLX )
          BPADJ    = AMIN1( BMAXS(J1), BPADJ )
          PRMS(J1) = AMAX1( BMINS(J1), BPADJ )
2040      CONTINUE
          GO TO 1700
        ENDIF
C *
      ENDIF
C *
C **  UPDATE THE VALUES FOR PARAMETERS AND BEST ERROR PH
C *
2100  DO 2110 J2=1,K
2110  BVECS(J2) = PRMS(J2)
2120  PH = PHI
      RESID = SNGL( PRESID )
C *
C *  BEGIN TERMINATION PROCEDURE IF WE HAVE CONVERGED OR ERRORED
      IF(ICON.LT.1) GO TO 2200
C *
C *  GO FOR NEXT ITERATION IF THE LIMIT HAS NOT BEEN HIT
      ITER = ITER + 1
      IF(ITER.LE.ITERLM) GO TO 1100
      WRITE(ITTO,2130)
2130  FORMAT(' -Iteration limit hit:  Halting refinement')
      ITER = ITER - 1
      ICON = -5
C *
C **  RETURN WITH RESULTS
C *
2200  RERR = SNGL( PHI )
C *
C *  BACK FOR ONE MORE PASS TO SET UP FOR ERROR ANALYSIS
      ITER1 = 1
      GO TO 1100
2260  CALL CHOL( AMAT, MEMV, MEMVP1, K, BVECS )
C *
9000  RETURN
      END
C ***  SCRMEM - HANDLE SCRATCH MEMORY REQUIREMENTS FOR REF. ALGORITHMS
C *
      SUBROUTINE SCRMEM( DATAIN, IBEG, IEND, ISET, ICODE )
C *
C *  ICODE:  0 -> INITIALIZE
C *         +1 -> STORE
C *         -1 -> RETRIEVE
C *
C *  SET PARAMETER MEMSCR TO WHATEVER ROOM IS AVAILABLE/NECESSARY.
C *  SETTING MEMSCR TO 1 HAS ALL DERIVATIVES WRITTEN TO SCRATCH FILE.
C *  VIRTUAL MACHINES.... THIS ONE'S FOR YOU!
C *
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      PARAMETER ( MEMSCR = 12000 )
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SCRTCH/ SCRDAT(MEMSCR),IPOINT(MEMV,4)
      DIMENSION DATAIN(MPTS)
C *
C **  RESET POINTERS ( ICODE = 0 )
C *
1000  IF(ICODE.NE.0) GO TO 2000
      DO 1010 I=1,MEMV
      IPOINT(I,1) = 0
      IPOINT(I,2) = 0
      IPOINT(I,3) = 0
      IPOINT(I,4) = 0
1010  CONTINUE
      IMLAST = 0
      REWIND (UNIT=IOSC)
      IFLAST = 0
      IFCURR = 0
      GO TO 9000
C *
C **  MOVE DATA FROM *DATAIN* TO *SCRDAT* OR *DISK* IF *SCRDAT* IS FULL
C *
2000  IF(ICODE.NE.1) GO TO 3000
C *
C *  CHECK THAT INDICATED DATA SET IS EMPTY
      IF( IPOINT(ISET,1).EQ.0 .AND. IPOINT(ISET,2).EQ.0 ) GO TO 2100
      WRITE(ITTO,2010) ISET
2010  FORMAT(' --WRITE REQUESTED TO SET ',I3,' BUT DATA SET EXISTS')
      STOP
C *
C *  DETERMINE IF THIS DATA SET CAN BE STORED IN *SCRDAT*
2100  NSTORE = IEND - IBEG + 1
      IF(IMLAST+NSTORE.LE.MEMSCR) GO TO 2900
C *
C *  THE CURRENT FILE-SET MUST BE THE SAME AS THE LAST-FILE SET.
C *  WRITES TO FILE MUST BE SEQUENTIAL
      IF(IFLAST.EQ.IFCURR) GO TO 2200
      WRITE(ITTO,2030) ISET,IFLAST,IFCURR
2030  FORMAT(' -INVALID REQUEST TO WRITE SET ',I3,'  IFLAST ',I3,
     1  '  IFCURR ',I3)
      STOP
C *
C *  STORE THE DATA ON *DISK*
2200  IFLAST = IFLAST + 1
      IFCURR = IFLAST
      IPOINT(ISET,1) = -IFCURR
      IPOINT(ISET,2) = -IFCURR
      IPOINT(ISET,3) = IBEG
      IPOINT(ISET,4) = IEND
      WRITE(IOSC) IBEG,IEND,(DATAIN(I),I=IBEG,IEND)
      WRITE(ITTO,9876) ISET
9876  FORMAT(' Set ',I4,' written to disk')
      GO TO 9000
C *
C *  STORE THE REQUESTED DATA IN *SCRDAT*
2900  IPOINT(ISET,1) = IMLAST + 1
      DO 2910 I=IBEG,IEND
      IMLAST = IMLAST + 1
      SCRDAT(IMLAST) = DATAIN(I)
2910  CONTINUE
      IPOINT(ISET,2) = IMLAST
      IPOINT(ISET,3) = IBEG
      IPOINT(ISET,4) = IEND
      GO TO 9000
C *
C **  RETRIEVE DATA FROM *SCRDAT* OR *DISK*
C *
3000  IF(ICODE.NE.-1) GO TO 8000
C *
C *  DETERMINE IF DATA SET EXISTS
      IF( IPOINT(ISET,1).NE.0 .AND. IPOINT(ISET,2).NE.0 ) GO TO 3100
      WRITE(ITTO,3010) ISET
3010  FORMAT(' --REQUEST FOR DATA SET ',I3,' INVALID: NO SUCH SET')
      STOP
C *
C *  DETERMINE IF DATA SET IS IN *SCRDAT* OR ON *DISK*
3100  IF( IPOINT(ISET,1).GT.0 .AND. IPOINT(ISET,2).GT.0 ) GO TO 3900
C *
C *  DETERMINE WHICH SET ON *DISK* IS TO BE RETRIEVED
      NDISK = -IPOINT(ISET,1)
C *
C *  IF THE CURRENT-SET IS ONE LESS THAN NDISK THEN NEXT READ IS CORRECT
      IF(IFCURR.EQ.NDISK-1) GO TO 3200
C *
C *  IF IFCURR IS > OR = TO NDISK THEN WE MUST REWIND
      IF(IFCURR.GE.NDISK) REWIND (UNIT=IOSC)
      IFCURR = 0
C *
C *  DETERMINE NUMBER OF SETS TO BYPASS FOR CORRECT SET
      NSKIP = NDISK - IFCURR - 1
      IF(NSKIP.GT.0) THEN
        DO 3120 I=1,NSKIP
        READ(IOSC) AJUNK
        IFCURR = IFCURR + 1
3120    CONTINUE
      ENDIF
C *
C *  READ THE DATA SET
3200  READ(IOSC) IBEG,IEND,(DATAIN(I),I=IBEG,IEND)
      IFCURR = IFCURR + 1
      GO TO 9000
C *
C *  RETRIEVE THE DATA FROM *SCRDAT*
3900  IBEG = IPOINT(ISET,3)
      IEND = IPOINT(ISET,4)
      NPNT = IPOINT(ISET,1)
      DO 3910 I=IBEG,IEND
      DATAIN(I) = SCRDAT(NPNT)
      NPNT = NPNT + 1
3910  CONTINUE
      GO TO 9000
C *
C **  UNKNOWN REQUEST CODE
C *
8000  WRITE(ITTO,8010) ICODE
8010  FORMAT(' --UNKNOWN REQUEST CODE:',I6)
C *
C *  RETURN RETURN RETURN
9000  RETURN
      END
C ***  GENDER - GENERATE DERIVATIVES FOR THE OPTIMIZATION ALGORITHMS
C *
      SUBROUTINE GENDER( PAIN, IPRM, DELTA, IDSTR, IDEND )
C *
      LOGICAL LSKIP
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 )
      PARAMETER ( DTORD2=8.72664626E-03,  RTODT2=114.591559)
      PARAMETER ( DTOR  =1.745329252E-02, RTOD  = 57.29577951 )
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201)
      COMMON /DERDAT/ DERIVS(MPTS),ZCALC(MPTS),NCLINE,NCSTRT,NCFINI
      COMMON /VECTOR/ NVECS,BVECS(MEMVT2),BMINS(MEMV),BMAXS(MEMV)
      COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2)
      COMMON /WDATA/ NWAVE,WTABLE(5,2)
      COMMON /DIAGS/ ISENSE(10)
      DIMENSION PAIN(MEMVT2)
C *
C **  DETERMINE WHICH PARAMETER IS BEING VARIED
C *
C *  DERIVATIVES REQUIRED FOR A LINE PARAMETER?
1000  IF(KNLIN.GT.0) THEN
        IF(KPROF.GT.0) THEN
          NEXT = KNLIN * KNPRM
         ELSE
          NEXT = KNPRM + ( KNLIN - 1 ) * 2
        ENDIF
        IF(IPRM.LE.NEXT) GO TO 2000
       ELSE
        NEXT = 0
      ENDIF
C *
C *  BACKGROUND?
1100  IF( KBKGR.EQ.1 .OR. KBKGR.EQ.3 ) THEN
        NEXT = NEXT + 1
        IF(NEXT.EQ.IPRM) GO TO 5000
      ENDIF
C *
C *  ASYMMETRY?
      IF(KASYM.NE.0) THEN
        NEXT = NEXT + 1
        IF(NEXT.EQ.IPRM) GO TO 3000
      ENDIF
C *
C *  AMORPHOUS PROFILE PARAMETERS?
      IF(KAMOR.NE.0) THEN
        NEXT = NEXT + 3
        IF(IPRM.LE.NEXT) GO TO 4000
      ENDIF
C *
C *  PARTICLE SIZE PARAMETER?
      IF( KCRYS.EQ.1 .OR. KCRYS.EQ.3 ) THEN
        NEXT = NEXT + 1
        NSS = 1
        IF(NEXT.EQ.IPRM) GO TO 3000
        NSS = 0
      ENDIF
C *
C *  PARTICLE STRAIN PARAMETER?
      IF( KCRYS.EQ.2 .OR. KCRYS.EQ.3 ) THEN
        NEXT = NEXT + 1
        NSS = 2
        IF(NEXT.EQ.IPRM) GO TO 3000
        NSS = 0
      ENDIF
C *
C *  NO OTHER PARAMETERS:  SOMETHING WRONG
      IDSTR = 1
      IDEND = 1
      DERIVS(1) = 0.0
      WRITE(ITTO,1010) IPRM
1010  FORMAT(/,' GENDER: INCORRECT PARAMETER SPECIFIED = ',I6)
      GO TO 9000
C *
C **  GENERATE THE NECESSARY PART OF THE PATTERN
C *
C *  GENERATE THE LINE PARAMETERS
C *  (NOTE: WHEN REFINING, CALC PTN W/ LST ST PRMS IS IN ZCALC)
C *
C *  DETERINE WHICH LINE WE ARE WORKING WITH
2000  IF(KPROF.GT.0) THEN
        ILINE = (IPRM-1) / KNPRM + 1
       ELSE
        IF(IPRM.GT.KNPRM) THEN
          ILINE = (IPRM-KNPRM-1) / 2 + 2
         ELSE
          ILINE = 1
        ENDIF
      ENDIF
C *
C *  IF THE LINE GENERATED BY THE LAST SET OF PARAMETERS IS NOT IN ZCALC
C *  THEN GENERATE IT
2010  IF(ILINE.EQ.NCLINE) THEN
        NBS = NCSTRT
        NBE = NCFINI
       ELSE
        CALL PMSORT( BVECS )
        CALL SHADOW( ZCALC, ILINE, NBS, NBE )
        NCLINE = ILINE
        NCSTRT = NBS
        NCFINI = NBE
      ENDIF
C *
C *  GENERATE THE LINE WITH THE NEW SET OF PARAMETERS AND RANGE FOR
C *  DERIVATIVES
      CALL PMSORT( PAIN )
      CALL SHADOW( YSYN, ILINE, NAS, NAE )
      IDSTR = MIN( NBS, NAS )
      IDEND = MAX( NBE, NAE )
      GO TO 8000
C *
C *  GENERATE FULL PATTERN FOR ASYMMETRY OR CRYSTALLITE PARAMETERS
C *
3000  IF(NCLINE.NE.999) THEN
        CALL PMSORT( BVECS )
        CALL SHADOW( ZCALC, 999, ILO, IHI )
        NCLINE = 999
      ENDIF
      SIZE   = 0.0
      STRAIN = 0.0
      IF( NSS.EQ.1 ) THEN
        SIZE = BVECS(NEXT)
        IF( KCRYS.EQ.3 ) STRAIN = BVECS(NEXT+1)
      ENDIF
      IF( NSS.EQ.2 ) THEN
        STRAIN = BVECS(NEXT)
        IF( KCRYS.EQ.3 ) SIZE = BVECS(NEXT-1)
      ENDIF
CDBG  WRITE(99,'('' SIZE,STRAIN = '',2G13.6)') SIZE,STRAIN
CDBG  WRITE(99,'('' NEXT,NSS,DELTA = '',2I5,G13.6)') NEXT,NSS,DELTA
      THTRMD = ( (YANG(1)+YANG(KOBS))/2.0 ) * DTORD2
      BBMD = RTOD * 4.0 * STRAIN * TAN(THTRMD)
      IF(SIZE.GT.0.0) BBMD = BBMD +
     1                RTOD * WTABLE(1,1) / ( COS(THTRMD) * SIZE )
      DBB = BBMD * 0.00010
      IF(NSS.EQ.1) THEN
        DELTA = -(COS(THTRMD)*SIZE**2) / (RTOD*WTABLE(1,1))  * DBB
CDBG    WRITE(99,'('' SIZE: B,DB,S,DS='',4G13.6)') BBMD,DBB,SIZE,DELTA
      ENDIF
      IF(NSS.EQ.2) THEN
        DELTA = DBB / ( RTOD * 4.0 * TAN(THTRMD) )
CDBG    WRITE(99,'('' STRA: B,DB,S,DS='',4G13.6)')BBMD,DBB,STRAIN,DELTA
      ENDIF
CDBG  WRITE(99,'('' P,B,DELTA = '',3G14.7)')PAIN(NEXT),BVECS(NEXT),DELTA
      PAIN(NEXT) = BVECS(NEXT) + DELTA
      CALL PMSORT( PAIN )
      CALL SHADOW( YSYN, 999, ILO, IHI )
      IDSTR = 1
      IDEND = KOBS
      GO TO 8000
C *
C *  GENERATE AMORPHOUS PROFILE
C *
C *  IF THE AMORPHOUS PROFILE IS NOT IN ZCALC THEN GENERATE IT
4000  IF(NCLINE.EQ.-1) THEN
        NBS = NCSTRT
        NBE = NCFINI
       ELSE
        CALL PMSORT( BVECS )
        CALL SHADOW( ZCALC, -1, NBS, NBE )
        NCLINE = -1
        NCSTRT = NBS
        NCFINI = NBE
      ENDIF
C *
C *  GENERATE THE LINE WITH THE NEW SET OF PARAMETERS AND RANGE FOR
C *  DERIVATIVES
      CALL PMSORT( PAIN )
      CALL SHADOW( YSYN, -1, NAS, NAE )
      IDSTR = MIN( NBS, NAS )
      IDEND = MAX( NBE, NAE )
      GO TO 8000
C *
C *  GENERATE BACKGROUND PARAMETERS
C *    NOTE: BACKGROUND WITH BVECS IS IN YBKG.  JUST USE PAIN NOW.
C *
C *  GENERATE NEW BKG IN DERIVS
5000  CALL PMSORT( PAIN )
      CALL BKGLVL( DERIVS )
C *
C *  DETERMINE OPTIMUM RANGE FOR DERIVATIVES
      IDSTR = 1
      IDEND = KOBS
      DO 5030 I=IDSTR,IDEND
5030  IF(DERIVS(I).NE.YBKG(I)) GO TO 5040
      IDSTR = 1
      IDEND = 1
      DERIVS(1) = 0.0
      GO TO 9000
5040  IDSTR = I
      DO 5050 I=IDEND,IDSTR,-1
5050  IF(DERIVS(I).NE.YBKG(I)) GO TO 5060
      IDSTR = 1
      IDEND = 1
      DERIVS(1) = 0.0
      GO TO 9000
C *
C *  GENERATE DERIVATIVES
5060  IDEND = I
      DO 5070 I=IDSTR,IDEND
5070  DERIVS(I) = ( DERIVS(I) - YBKG(I) ) / DELTA
      GO TO 9000
C *
C **  CALCULATE DERIVATIVES FOR ALL PARAMETERS EXCEPT BACKGROUND
C *
C *  CAN WE SAVE SOME ROOM AND EFFORT?
8000  DO 8010 I=IDSTR,IDEND
8010  IF(ZCALC(I).NE.YSYN(I)) GO TO 8020
      IDSTR = 1
      IDEND = 1
      DERIVS(1) = 0.0
      GO TO 9000
8020  IDSTR = I
      DO 8030 I=IDEND,IDSTR,-1
8030  IF(ZCALC(I).NE.YSYN(I)) GO TO 8040
      IDSTR = 1
      IDEND = 1
      DERIVS(1) = 0.0
      GO TO 9000
8040  IDEND = I
C *
C *  CALCULATE THE DERIVATIVES
8200  DO 8210 I=IDSTR,IDEND
8210  DERIVS(I) = ( YSYN(I) - ZCALC(I) ) / DELTA
C *
9000  RETURN
      END
C *** CHOL - DETERMINE THE INVERSE OF AN NXN POSITIVE-SYMMETRIC MATRIX
C *          IN PLACE USING THE CHOLESKY METHOD
C *
C *  CODED BY S.A.HOWARD
C *           UNIVERSITY OF MISSOURI- ROLLA
C *
C *  ARGUMENTS: S - (A)SYMMETRIC MATRIX S(NCOL,NROW)
C *             NROW - NUMBER OF ROWS IN MATRIX S
C *             NCOL - NUMBER OF COLUMNS IN MATRIX S
C *             NE - S OF S(NE,NE) IS TO BE INVERTED
C *
      SUBROUTINE CHOL( S, NROW, NCOL, NE, PARAMS )
C *
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 )
      DOUBLE PRECISION DPSUM
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /OPTRES/ RERR,RESID,ICON,ITER
      DIMENSION S(NROW,NCOL),PARAMS(MEMVT2)
C *
C **    USE CHOLESKY'S METHOD OF DETERMINING THE FACTORED MATRIX S
C *       FROM THE SYMMETRIC, POSITIVE DEFINITE MATRIX S (IN PLACE)
C *
C     WRITE(ITTO,120) 'START',( ( S(LR,LC),LC=1,NE),LR=1,NE)
1000  IF(S(1,1).LE.0.0) GO TO 1065
      SD = SQRT( S(1,1) )
      DO 1010 J=2,NE
1010  S(1,J) = S(1,J) / SD
      S(1,1) = SD
C *
C *  REPEAT 2->NE
      DO 1020 I=2,NE
C *
C *  DIAGONAL ELEMENTS
      DPSUM = 0.0D00
      DO 1030 K=1,I-1
        DPSUM = DPSUM + S(K,I)**2
1030  CONTINUE
      SUM = SNGL(DPSUM)
      IF(SUM.GE.S(I,I)) GO TO 1065
      S(I,I) = SQRT( S(I,I) - SUM )
C *
C *  OFF DIAGONAL ELEMENTS
      DO 1050 J=I+1,NE
      DPSUM = 0.0D00
        DO 1060 K=1,I-1
          DPSUM = DPSUM + S(K,I)*S(K,J)
1060    CONTINUE
      S(I,J) = ( S(I,J) - SNGL(DPSUM) ) / S(I,I)
1050  CONTINUE
C *
1020  CONTINUE
      GO TO 1075
C *
C *  ERROR... MATRIX CAN NOT BE FACTORED
1065  WRITE(ITTO,1067)
1067  FORMAT(/,' -CHOL:Matrix can not be factored.  No ESDs calculated')
      GO TO 9000
C *
C *  MOVE TO LOWER DIAGONAL SYMMETRIC
1075  DO 1070 I=2,NE
        DO 1080 J=1,I-1
          S(I,J) = S(J,I)
          S(J,I) = 0.0
1080    CONTINUE
1070  CONTINUE
C     WRITE(ITTO,120) 'FACTR',( ( S(LR,LC),LC=1,NE),LR=1,NE)
C *
C **  INVERTING THE SYMMETRIC S MATRIX IN PLACE
C **    THIS IS AN OPTIMIZED GAUSS-JORDEN ELIMINATION
C *
C *  DO FOR THE ENTIRE SERIES OF EQUATIONS
2000  S(1,1) = 1.0 / S(1,1)
      DO 2010 K=2,NE
      KM1 = K - 1
      IF(S(K,K).LT.1.E-20) STOP'ERROR: PIVOT TOO SMALL'
C *
C *  NORMALIZE BY THE DIAGONAL ELEMENT
      SD = 1.0 / S(K,K)
      DO 2020 I=1,KM1
        S(K,I) = S(K,I) * SD
2020  CONTINUE
      S(K,K) = SD
C *
C *  REDUCE
      DO 2030 I=1,KM1
        DPSUM = 0.0D00
        DO 2040 J=I,KM1
          DPSUM = DPSUM + S(K,J) * S(J,I)
2040    CONTINUE
        S(K,I) = -DPSUM
2030  CONTINUE
C *
2010  CONTINUE
C     WRITE(ITTO,120) 'INVER',( ( S(LR,LC),LC=1,NE),LR=1,NE)
C120  FORMAT(' S ='A5,<NE>(/,X,<NE>F10.4))
C *
C **  NOW MULTIPLY THE S MATRIX BY ITS TRANSPOSE TO OBTAIN THE DESIRED
C **    INVERSION( S-ORIGINAL )
C *
3000  DO 3010 I=1,NE
        DO 3020 K=1,I
        DPSUM = 0.0D00
          DO 3030 J=I,NE
            DPSUM = DPSUM + S(J,I) * S(J,K)
3030      CONTINUE
        S(I,K) = SNGL( DPSUM )
        S(K,I) = S(I,K)
3020    CONTINUE
3010  CONTINUE
C     WRITE(ITTO,120) 'FINAL',( ( S(LR,LC),LC=1,NE),LR=1,NE)
C *
C **  RETURN THE UNCERTAINTY FOR THE COMPONENTS IN THE PARAMS VECTOR.
C **    THIS IS BASED ON THE VARIANCES BY LEAST SQUARES STATISTICS.
C *
C *  THE POPULATION VARIANCE
4000  VERR = RESID / REAL( KOBS - NE )
C *
C *  THE VARIANCE FOR EACH OF THE COMPONENTS
      DO 4010 I=1,NE
      NEPI = NE + I
4010  PARAMS(NEPI) = SQRT( S(I,I) * VERR )
C *
9000  RETURN
      END
*** subroutine prmout goes here ***
C ***  PRMPLT - GENERATE REFINEMENT PLOT FILE OUTPUT
C *
      SUBROUTINE PRMPLT
C *
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201)
      COMMON /BKGDAT/ LDEG,CLY,CLC(6),BKGSDV,IBKCPS,IBKNBK
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /WDATA/ NWAVE,WTABLE(5,2)
C *
C *  CALCULATED PATTERN...
      IF(KPSETS(2).NE.0) THEN
        CALL SHADOW( YSYN, 999, IDUM1, IDUM2 )
        DO 1002 I=1,KOBS
1002    YSYN(I) = YSYN(I) + YBKG(I)
        IF(KPTYPE.EQ.0) THEN
          WRITE(IOPL) KPSETS(2),KOBS,YANG(1)
          WRITE(IOPL) (YSYN(I)/FTIME,I=1,KOBS)
         ELSE
          WRITE(IOPL,1010) KPSETS(2),KOBS,YANG(1)
1010      FORMAT(I6,I6,F10.4)
          WRITE(IOPL,1020) (YSYN(I)/FTIME,I=1,KOBS)
1020      FORMAT(10F8.1)
        ENDIF
      ENDIF
C *
C *  DIFFERENCE PATTERN...
      IF(KPSETS(3).NE.0) THEN
        IF(KPSETS(2).EQ.0) THEN
          CALL SHADOW( YSYN, 999, IDUM1, IDUM2 )
          DO 1845 I=1,KOBS
1845      YSYN(I) = YSYN(I) + YBKG(I)
        ENDIF
        DO 1850 I=1,KOBS
1850    YSYN(I) = ( YOBS(I) - YSYN(I) ) / FTIME
        IF(KPTYPE.EQ.0) THEN
          WRITE(IOPL) KPSETS(3),KOBS,YANG(1)
          WRITE(IOPL) (YSYN(I),I=1,KOBS)
         ELSE
          WRITE(IOPL,1010) KPSETS(3),KOBS,YANG(1)
          WRITE(IOPL,1020) (YSYN(I),I=1,KOBS)
        ENDIF
      ENDIF
C *
C *  INDIVIDUALIZE THE PROFILES HERE IF YOU WANT TO SEE ALPHA LINES
C *  DRAWN SEPARATELY
C      CALL PKSPLT
C *
C *  GENERATE INDIVIDUAL PROFILES AND PLOT THEM
C *
      IF(KPSETS(4).EQ.0) GO TO 99
C *
      JK = IABS( KPROF )
      DO 1870 I=1,KNLIN
      CALL SHADOW( YSYN, I, ILO, IHI )
C *
C *  CALCULATED FWHM VALUES
      PPL = FNFWHM( PLPRM(I,1), 1)
      PPH = FNFWHM( PLPRM(I,1), 2)
C *
C *  SELECT PROPER PROFILE FUNCTION
      GO TO(10,10,10,40,10,60,70,80,90,100,110,120,130,140,140,150),JK
      STOP 'PRMPLT: A GOTO ERROR OCCURRED, PLEASE CHECK'
C *
C *  GAUSSIAN AND NORMAL, MODIFIED, AND INTERMEDIATE LORENZTIAN
C *  ACOEFF - FULL WIDTH AT HALF MAXIMUM
10    PPL = PLPRM(I,3)
      PPH = PPL
      GO TO 1880
C *
C *  PEARSON VII
C *  ACOEFF - FULL WIDTH AT HALF MAX
40    PPL = PLPRM(I,3)
      PPH = PPL
      GO TO 1880
C *
C *  VOIGT PROFILE
60    PPL = 0.5
      PPH = PPL
      GO TO 1880
C *
C *  SPLIT PEARSON VII
C *  ACOEFF - FULL WIDTH AT HALF MAX
70    PPL = PLPRM(I,3)
C *  CCOEFF - FULL WIDTH AT HALF MAX
      PPH = PLPRM(I,5)
      GO TO 1880
C *
C *  SPLIT PEARSON VII WITH CALC FWHM+DELTA, CALC SF
C *  ACOEFF - DELTA FOR FULL WIDTH AT HALF MAXIMUM INTENSITY
80    PPL = PPL + PLPRM(I,3)
      PPH = PPH + PLPRM(I,3)
      GO TO 1880
C *
C *  SPLIT PEARSON VII WITH ALPHA 2 REFLECTION
C *  ACOEFF - FULL WIDTH AT HALF MAX, ALPHA1 FRONT
90    PPL = PLPRM(I,3)
C *  CCOEFF - FULL WIDTH AT HALF MAX, ALPHA 1 BACK
      PPH = PLPRM(I,5)
C *  ECOEFF - FULL WIDTH AT HALF MAX, ALPHA2 FRONT
      PPL = AMAX1( PLPRM(I,7), PPL )
C *  GCOEFF - FULL WIDTH AT HALF MAX, ALPHA 2 BACK
      PPH = AMAX1( PLPRM(I,9), PPH )
      GO TO 1880
C *
C *  CONSTRAINED PEARSON WITH REFLECTION
C *  ACOEFF - FULL WIDTH AT HALF MAX, ALPHA1 FRONT
100   PPL = PLPRM(I,3)
C *  CCOEFF - FULL WIDTH AT HALF MAX, ALPHA 1 BACK
      PPH = PLPRM(I,5)
C *  ECOEFF - FULL WIDTH AT HALF MAX, ALPHA2 FRONT
      PPL = AMAX1( PLPRM(I,7), PPL )
C *  FCOEFF - FULL WIDTH AT HALF MAX, ALPHA 2 BACK
      PPH = AMAX1( PLPRM(I,8), PPH )
      GO TO 1880
C *
C *  CONSTRAINED PEARSON WITH REFLECTION
C *  ACOEFF - FULL WIDTH AT HALF MAX, ALPHA1 AND ALPHA2 FRONT
110   PPL = PLPRM(I,3)
C *  CCOEFF - FULL WIDTH AT HALF MAX, ALPHA 1 AND ALPHA2 BACK
      PPH = PLPRM(I,5)
      GO TO 1880
C *
C *  CONSTRAINED PEARSON WITH REFLECTION, CALC FWHM, REFINED SF
120   GO TO 1880
C *
C *  PEARSON VII, FULLY CONSTRAINED
130   GO TO 1880
C *
C *  CONVOLUTION PRODUCT... LORENTZIAN OR GAUSSIAN WITH INSTRUMENT
140   PPL = 0.5
      PPH = 0.5
      GO TO 1880
C *
C *  CONVOLUTION PRODUCT... LORENTZIAN OR GAUSSIAN WITH INSTRUMENT
150   PPL = 0.5
      PPH = 0.5
C *
C *  DETERMINE RANGE FOR PLOTTING BASED ON PROFILE HALF WIDTHS
1880  IPPL = 8 * NINT( PPL / FAINC )
      IPPH = 8 * NINT( PPH / FAINC )
      IPP  = MAX( IPPL, IPPH )
C *  A1
      ICNTR = INT( (PLPRM(I,1)-YANG(1))/FAINC + 0.1 ) + 1
      IILO = ICNTR - IPP
      IIHI = ICNTR + IPP
      IF(JK.LT.8) GO TO 1882
C *  A2
      IF(NWAVE.GT.1) THEN
        CALL CALCPH(PLPRM(I,1),PLPRM(I,2),2,T2,Y2)
        ICNTR = INT( (T2-YANG(1))/FAINC + 0.1 ) + 1
        IILO = MIN( ICNTR-IPP, IILO )
        IIHI = MAX( ICNTR+IPP, IIHI )
      ENDIF
C *  A3
      IF(NWAVE.GT.2) THEN
        CALL CALCPH(PLPRM(I,1),PLPRM(I,2),3,T2,Y2)
        ICNTR = INT( (T2-YANG(1))/FAINC + 0.1 ) + 1
        IILO = MIN( ICNTR-IPP, IILO )
        IIHI = MAX( ICNTR+IPP, IIHI )
      ENDIF
C *
1882  IILO = MAX( IILO, ILO )
      IIHI = MIN( IIHI, IHI )
      ND = IIHI - IILO + 1
C *
      IF(KPTYPE.EQ.0) THEN
        WRITE(IOPL) KPSETS(4),ND,YANG(IILO)
        WRITE(IOPL) (YSYN(J)/FTIME,J=IILO,IIHI)
       ELSE
        WRITE(IOPL,1010) KPSETS(4),ND,YANG(IILO)
        WRITE(IOPL,1020) (YSYN(J)/FTIME,J=IILO,IIHI)
      ENDIF
1870  CONTINUE
C *  GENERATE THE AMORPHOUS PROFILE
      IF(KAMOR.NE.0) THEN
        CALL SHADOW( YSYN, -1, ILO, IHI )
        ND = IHI - ILO + 1
        IF(KPTYPE.EQ.0) THEN
          WRITE(IOPL) KPSETS(4),ND,YANG(ILO)
          WRITE(IOPL) (YSYN(I)/FTIME,I=ILO,IHI)
         ELSE
          WRITE(IOPL,1010) KPSETS(4),ND,YANG(ILO)
          WRITE(IOPL,1020) (YSYN(I)/FTIME,I=ILO,IHI)
        ENDIF
      ENDIF
C *
C *  PROFILES MUST BE INDIVIDUALIZED BY THIS POINT SO THE ALPHA-1
C *  PATTERN CAN BE DRAW.  IF DONE HERE ITS NOT NECESSARY TO DO IT
C *  USING THE ABOVE CALL TO PKSPLT.  USE ONE OR THE OTHER.
99    CALL PKSPLT
C *
C *  ALPHA 1 PATTERN
      IF(KPSETS(5).NE.0) THEN
        CALL PATSUB
        NSET = 5
        IF(KPTYPE.EQ.0) THEN
          WRITE(IOPL) KPSETS(5),KOBS,YANG(1)
          WRITE(IOPL) (YSYN(I)/FTIME,I=1,KOBS)
         ELSE
          WRITE(IOPL,1010) KPSETS(5),KOBS,YANG(1)
          WRITE(IOPL,1020) (YSYN(I)/FTIME,I=1,KOBS)
        ENDIF
      ENDIF
C *
C *  EXIT
9000  RETURN
      END
C ***  SINTGR - INTEGRATION BY SIMPSONS METHOD
C *
      SUBROUTINE SINTGR( A )
C *
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
C *
C *  INSURE THAT NPOINT IS ODD (OR AN EVEN NUMBER OF INTERVALS IS USED).
      AREA = 0.0
      NTEMP = (KOBS/2)*2 + 1
      IF(NTEMP.LT.5) GO TO 9000
C *
C *  AREA UNDER THE PROFILE
      SUM2 = 0.0
      SUM4 = 0.0
      DO 1010 J=2,NTEMP-1,2
1010  SUM4 = SUM4 + YSYN(J)
      DO 1020 J=3,NTEMP-2,2
1020  SUM2 = SUM2 + YSYN(J)
      A = (FAINC/3.0) * ( YSYN(1) + YSYN(NTEMP) + 4.0*SUM4 + 2.0*SUM2 )
C *
C *  INTEGRATED....
9000  RETURN
      END
C ***  PKADD - ADDS ANOTHER LINE TO THE CURRENT PEAK LIST
C *
      SUBROUTINE PKADD
C *
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 )
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201)
      COMMON /VECTOR/ NVECS,BVECS(MEMVT2),BMINS(MEMV),BMAXS(MEMV)
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      DIMENSION AMCOPY(3,3)
      DIMENSION CRYVEC(2),CRYMIN(2),CRYMAX(2)
C *
C *  GET NUMBER OF LINES TO ADD TO CURRENT PROFILE
1000  NADD = 0
      IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) THEN
          WRITE(ITTO,1010)
1010      FORMAT(/,' Number of lines being added to region ? <0> ')
          READ(ITTI,*) NADD
         ELSE
          READ(ITTI,1020) NADD
1020      FORMAT(I3)
        ENDIF
      ENDIF
      IF(KMODEO.EQ.1) WRITE(IOBO,1030) NADD
1030  FORMAT(I3,T40,'Number of lines being added')
      IF(NADD.EQ.0) GO TO 9000
C *
C *  TO KEEP THE PROFILE PARAMETERS AT THE FRONT OF THE LIST, PULL THE
C *  BACKGROUND, ASYMMETRY, AND AMORPHOUS PROFILE AND THE CRYSTALLITE
C *  PARAMETERS FROM THE LIST.
C *
C *  BACKGROUND PARAMETER
1100  NTEMP = KNLIN * KNPRM
      IF(KBKGR.EQ.1.OR.KBKGR.EQ.3) THEN
        NTEMP = NTEMP + 1
        BKGVEC = BVECS(NTEMP)
        BKGMIN = BMINS(NTEMP)
        BKGMAX = BMAXS(NTEMP)
        NVECS = NVECS - 1
      ENDIF
C *
C *  ASYMMETRY PARAMETER
      IF(KASYM.EQ.1) THEN
        NTEMP = NTEMP + 1
        ASYVEC = BVECS(NTEMP)
        ASYMIN = BMINS(NTEMP)
        ASYMAX = BMAXS(NTEMP)
        NVECS = NVECS - 1
      ENDIF
C *
C *  AMORPHOUS PROFILE PARAMETERS
      IF(KAMOR.EQ.1) THEN
        DO 1170 I=1,3
        NTEMP = NTEMP + 1
        AMCOPY(I,1) = BVECS(NTEMP)
        AMCOPY(I,2) = BMINS(NTEMP)
        AMCOPY(I,3) = BMAXS(NTEMP)
        NVECS = NVECS - 1
1170    CONTINUE
      ENDIF
C *
C *  CRYSTALLITE SIZE PARAMTER
      IF(KCRYS.EQ.1.OR.KCRYS.EQ.3) THEN
        NTEMP = NTEMP + 1
        CRYVEC(1) = BVECS(NTEMP)
        CRYMIN(1) = BMINS(NTEMP)
        CRYMAX(1) = BMAXS(NTEMP)
        NVECS = NVECS - 1
      ENDIF
C *
C *  CRYSTALLITE STRAIN PARAMTER
      IF(KCRYS.EQ.2.OR.KCRYS.EQ.3) THEN
        NTEMP = NTEMP + 1
        CRYVEC(2) = BVECS(NTEMP)
        CRYMIN(2) = BMINS(NTEMP)
        CRYMAX(2) = BMAXS(NTEMP)
        NVECS = NVECS - 1
      ENDIF
C *
C *  ADD NADD LINES TO CURRENT NUMBER OF LINES IN THE PROFILE.
C *  IN ADDITION TO THESE NEW LINES... CHECK FOR WAVELENGTH REFLECTIONS.
C *
2000  NORIG = KNLIN
      DO 2010 I=1,NADD
      KNLIN = KNLIN + 1
      IF(KMODEO.NE.2) THEN
        WRITE(ITTO,2020) KNLIN
2020    FORMAT(/,' Position and intensity for line ',I3,' ? ')
        PLPRM(KNLIN,1) = 0.0
        PLPRM(KNLIN,2) = 0.0
        READ(ITTI,*) PLPRM(KNLIN,1),PLPRM(KNLIN,2)
       ELSE
        READ(ITTI,2030) PLPRM(KNLIN,1),PLPRM(KNLIN,2)
2030    FORMAT(2F10.4)
        WRITE(ITTO,2050) PLPRM(KNLIN,1),PLPRM(KNLIN,2)
2050    FORMAT(/,' New line added: Pos = ',F8.4,' Intensity = ',F8.2)
      ENDIF
      IF(KMODEO.EQ.1) WRITE(IOBO,2040) PLPRM(KNLIN,1),PLPRM(KNLIN,2)
2040  FORMAT(2F10.4,T40,' New line added')
      PLPRM(KNLIN,2) = PLPRM(KNLIN,2) * FTIME
      NOLD = KNLIN
      CALL PCALC( KNLIN )
      DO 2060 J=NOLD,KNLIN
2060  PLPRM(J,1) = PLPRM(J,1) - CORPOS( PLPRM(J,1) )
2010  CONTINUE
C *
C *  NOW INITIALIZE THE PARAMETERS FOR THESE PROFILES
C *
3000  DO 3010 I=NORIG+1,KNLIN
      CALL PRINIT( I )
3010  CONTINUE
C *
C *  AND FINALLY... ADD OTHER PARAMETERS TO THE LIST
C *
C *  BACKGROUND PARAMETER
4000  NTEMP = KNLIN * KNPRM
      IF(KBKGR.EQ.1.OR.KBKGR.EQ.3) THEN
        NTEMP = NTEMP + 1
        BVECS(NTEMP) = BKGVEC
        BMINS(NTEMP) = BKGMIN
        BMAXS(NTEMP) = BKGMAX
        NVECS = NVECS + 1
      ENDIF
C *
C *  ASYMMETRY PARAMETER
      IF(KASYM.EQ.1) THEN
        NTEMP = NTEMP + 1
        BVECS(NTEMP) = ASYVEC
        BMINS(NTEMP) = ASYMIN
        BMAXS(NTEMP) = ASYMAX
        NVECS = NVECS + 1
      ENDIF
C *
C *  AMORPHOUS PROFILE PARAMETERS
      IF(KAMOR.EQ.1) THEN
        DO 4070 I=1,3
        NTEMP = NTEMP + 1
        BVECS(NTEMP) = AMCOPY(I,1)
        BMINS(NTEMP) = AMCOPY(I,2)
        BMAXS(NTEMP) = AMCOPY(I,3)
        NVECS = NVECS + 1
4070    CONTINUE
      ENDIF
C *
C *  CRYSTALLITE SIZE PARAMETER
      IF(KCRYS.EQ.1.OR.KCRYS.EQ.3) THEN
        NTEMP = NTEMP + 1
        BVECS(NTEMP) = CRYVEC(1)
        BMINS(NTEMP) = CRYMIN(1)
        BMAXS(NTEMP) = CRYMAX(1)
        NVECS = NVECS + 1
      ENDIF
C *
C *  CRYSTALLITE STRAIN PARAMETER
      IF(KCRYS.EQ.2.OR.KCRYS.EQ.3) THEN
        NTEMP = NTEMP + 1
        BVECS(NTEMP) = CRYVEC(2)
        BMINS(NTEMP) = CRYMIN(2)
        BMAXS(NTEMP) = CRYMAX(2)
        NVECS = NVECS + 1
      ENDIF
C *
9000  RETURN
      END
C ***  PKSPLT - SPLIT COMPOUND PROFILES TO COMPONENT PROFILES
C *
      SUBROUTINE PKSPLT
C *
      PARAMETER ( DTORD2=8.72664626E-03,  RTODT2=114.591559 )
      PARAMETER ( DTOR  =1.745329252E-02, RTOD=   57.29577951 )
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201)
      COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2)
      COMMON /WDATA/ NWAVE,WTABLE(5,2)
      COMMON /COMSCR/ PN(200,10)
C *
C *  WRITE SETUP INFO
      WRITE(ITTO,1) KPROF, KNLIN
1     FORMAT(/,' PKSPLT=> Entry: Profile: ',I3,' Lines: ',I3)
      JK = IABS( KPROF )
C *
C *  SPLIT PEARSON VII WITH ALPHA2
C *
C *  SORT PARAMETERS
1000  IF(JK.NE.9) GO TO 2000
      NTMP = 0
      DO 1010 I=1,KNLIN
C *  ALPHA1 REFLECTION
      NTMP = NTMP +1
      PN(NTMP,1) = PLPRM(I,1)
      PN(NTMP,2) = PLPRM(I,2)
      PN(NTMP,3) = PLPRM(I,3)
      PN(NTMP,4) = PLPRM(I,4)
      PN(NTMP,5) = PLPRM(I,5)
      PN(NTMP,6) = PLPRM(I,6)
      KRLIN(NTMP) = 1
C *  ALPHA2 REFLECTION
      IF(NWAVE.GT.1) THEN
        NTMP = NTMP + 1
        CALL CALCPH(PLPRM(I,1),PLPRM(I,2),2,PN(NTMP,1),PN(NTMP,2))
        PN(NTMP,3) = PLPRM(I,7)
        PN(NTMP,4) = PLPRM(I,8)
        PN(NTMP,5) = PLPRM(I,9)
        PN(NTMP,6) = PLPRM(I,10)
        KRLIN(NTMP) = 2
      ENDIF
C *  ALPHA3 REFLECTION
      IF(NWAVE.GT.2) THEN
        NTMP = NTMP + 1
        CALL CALCPH(PLPRM(I,1),PLPRM(I,2),3,PN(NTMP,1),PN(NTMP,2))
        PN(NTMP,3) = PLPRM(I,3)
        PN(NTMP,4) = PLPRM(I,4)
        PN(NTMP,5) = PLPRM(I,5)
        PN(NTMP,6) = PLPRM(I,6)
        KRLIN(NTMP) = 3
      ENDIF
1010  CONTINUE
C *  RETURN PROPER PARAMETERS
      KPROF = 7
      KNLIN = NTMP
      KNPRM = 6
      GO TO 8000
C *
C *  SPLIT PEARSON VII WITH CONSTRAINED FWHM
C *
C *  SORT PARAMETERS
2000  IF(JK.NE.10) GO TO 3000
      NTMP = 0
      DO 2010 I=1,KNLIN
C *  ALPHA1 REFLECTION
      NTMP = NTMP + 1
      PN(NTMP,1) = PLPRM(I,1)
      PN(NTMP,2) = PLPRM(I,2)
      PN(NTMP,3) = PLPRM(I,3)
      PN(NTMP,4) = PLPRM(I,4)
      PN(NTMP,5) = PLPRM(I,5)
      PN(NTMP,6) = PLPRM(I,6)
      KRLIN(NTMP) = 1
C *  ALPHA2 REFLECTION
      IF(NWAVE.GT.1) THEN
        NTMP = NTMP + 1
        CALL CALCPH(PLPRM(I,1),PLPRM(I,2),2,PN(NTMP,1),PN(NTMP,2))
        PN(NTMP,3) = PLPRM(I,7)
        PN(NTMP,4) = PLPRM(I,3)
        PN(NTMP,5) = PLPRM(I,8)
        PN(NTMP,6) = PLPRM(I,4)
        KRLIN(NTMP) = 2
      ENDIF
C *  ALPHA3 REFLECTION
      IF(NWAVE.GT.2) THEN
        NTMP = NTMP + 1
        CALL CALCPH(PLPRM(I,1),PLPRM(I,2),3,PN(NTMP,1),PN(NTMP,2))
        PN(NTMP,3) = PLPRM(I,3)
        PN(NTMP,4) = PLPRM(I,4)
        PN(NTMP,5) = PLPRM(I,5)
        PN(NTMP,6) = PLPRM(I,6)
        KRLIN(NTMP) = 3
      ENDIF
2010  CONTINUE
C *  RETURN PROPER PARAMETERS
      KPROF = 7
      KNLIN = NTMP
      KNPRM = 6
      GO TO 8000
C *
C *  SPLIT PEARSON VII WITH CONSTRAINED FWHM AND SHAPE FACTORS
C *
C *  SORT PARAMETERS
3000  IF(JK.NE.11) GO TO 4000
      NTMP = 0
      DO 3010 I=1,KNLIN
C *  ALPHA1 REFLECTION
      NTMP = NTMP + 1
      PN(NTMP,1) = PLPRM(I,1)
      PN(NTMP,2) = PLPRM(I,2)
      PN(NTMP,3) = PLPRM(I,3)
      PN(NTMP,4) = PLPRM(I,4)
      PN(NTMP,5) = PLPRM(I,5)
      PN(NTMP,6) = PLPRM(I,6)
      KRLIN(NTMP) = 1
C *  ALPHA2 REFLECTION
      IF(NWAVE.GT.1) THEN
        NTMP = NTMP + 1
        CALL CALCPH(PLPRM(I,1),PLPRM(I,2),2,PN(NTMP,1),PN(NTMP,2))
        PN(NTMP,3) = PLPRM(I,3)
        PN(NTMP,4) = PLPRM(I,4)
        PN(NTMP,5) = PLPRM(I,5)
        PN(NTMP,6) = PLPRM(I,6)
        KRLIN(NTMP) = 2
      ENDIF
C *  ALPHA3 REFLECTION
      IF(NWAVE.GT.2) THEN
        NTMP = NTMP + 1
        CALL CALCPH(PLPRM(I,1),PLPRM(I,2),3,PN(NTMP,1),PN(NTMP,2))
        PN(NTMP,3) = PLPRM(I,3)
        PN(NTMP,4) = PLPRM(I,4)
        PN(NTMP,5) = PLPRM(I,5)
        PN(NTMP,6) = PLPRM(I,6)
        KRLIN(NTMP) = 3
      ENDIF
3010  CONTINUE
C *  RETURN PROPER PARAMETERS
      KPROF = 7
      KNLIN = NTMP
      KNPRM = 6
      GO TO 8000
C *
C *  SPLIT PEARSON VII WITH CONSTRAINED SHAPE FACTORS
C *
C *  SORT PARAMETERS
4000  IF(JK.NE.12) GO TO 6000
      NTMP = 0
      DO 4010 I=1,KNLIN
      WF = FNFWHM( PLPRM(I,1), 1 )
      WB = FNFWHM( PLPRM(I,1), 2 )
C *  ALPHA1 REFLECTION
      NTMP = NTMP + 1
      PN(NTMP,1) = PLPRM(I,1)
      PN(NTMP,2) = PLPRM(I,2)
      PN(NTMP,3) = WF
      PN(NTMP,4) = PLPRM(I,3)
      PN(NTMP,5) = WB
      PN(NTMP,6) = PLPRM(I,4)
      KRLIN(NTMP) = 1
C *  ALPHA2 REFLECTION
      IF(NWAVE.GT.1) THEN
        NTMP = NTMP + 1
        CALL CALCPH(PLPRM(I,1),PLPRM(I,2),2,PN(NTMP,1),PN(NTMP,2))
        PN(NTMP,3) = WF
        PN(NTMP,4) = PLPRM(I,3)
        PN(NTMP,5) = WB
        PN(NTMP,6) = PLPRM(I,4)
        KRLIN(NTMP) = 2
      ENDIF
C *  ALPHA3 REFLECTION
      IF(NWAVE.GT.2) THEN
        NTMP = NTMP + 1
        CALL CALCPH(PLPRM(I,1),PLPRM(I,2),3,PN(NTMP,1),PN(NTMP,2))
        PN(NTMP,3) = WF
        PN(NTMP,4) = PLPRM(I,3)
        PN(NTMP,5) = WB
        PN(NTMP,6) = PLPRM(I,4)
        KRLIN(NTMP) = 3
      ENDIF
4010  CONTINUE
C *  RETURN PROPER PARAMETERS
      KPROF = 7
      KNLIN = NTMP
      KNPRM = 6
      GO TO 8000
C *
C *  SPLIT PEARSON VII, CALCULATED FWHM AND SHAPE FACTORS
C *
C *  SORT PARAMETERS
6000  IF(JK.NE.13)GO TO 6100
      NTMP = 0
      DO 6010 I=1,KNLIN
      ANGLE = PLPRM(I,1)
      AC = FNFWHM( ANGLE, 1 )
      BC = FNSHAP( ANGLE, 1 )
      CC = FNFWHM( ANGLE, 2 )
      DC = FNSHAP( ANGLE, 2 )
C *  ALPHA1 REFLECTION
      NTMP = NTMP + 1
      PN(NTMP,1) = PLPRM(I,1)
      PN(NTMP,2) = PLPRM(I,2)
      PN(NTMP,3) = AC
      PN(NTMP,4) = BC
      PN(NTMP,5) = CC
      PN(NTMP,6) = DC
      KRLIN(NTMP) = 1
C *  ALPHA2 REFLECTION
      IF(NWAVE.GT.1) THEN
        NTMP = NTMP + 1
        CALL CALCPH(PLPRM(I,1),PLPRM(I,2),2,PN(NTMP,1),PN(NTMP,2))
        PN(NTMP,3) = AC
        PN(NTMP,4) = BC
        PN(NTMP,5) = CC
        PN(NTMP,6) = DC
        KRLIN(NTMP) = 2
      ENDIF
C *  ALPHA3 REFLECTION
      IF(NWAVE.GT.2) THEN
        NTMP = NTMP + 1
        CALL CALCPH(PLPRM(I,1),PLPRM(I,2),3,PN(NTMP,1),PN(NTMP,2))
        PN(NTMP,3) = AC
        PN(NTMP,4) = BC
        PN(NTMP,5) = CC
        PN(NTMP,6) = DC
        KRLIN(NTMP) = 3
      ENDIF
6010  CONTINUE
C *  RETURN PROPER PARAMETERS
      KPROF = 7
      KNLIN = NTMP
      KNPRM = 6
      GO TO 8000
C *
C **  CONVOLUTE PROFILES USING INSTRUMENTAL * SPECIMEN
C *
C *  SORT PARAMETERS
6100  IF( JK.NE.14 .AND. JK.NE.15 ) GO TO 7000
C *  IF CONVOLUTE PROFILES ARE TO BE SHOWN.... USE NEXT LINE.
C *    OTHERWISE THE PROFILES SHOWN ARE THOSE OF THE SPECIMEN.
      GO TO 7000
C *  GENERATE THE CORRECT SPECIMEN PROFILE PARAMETERS
6101  NTMP = 0
      DO 6110 I=1,KNLIN
      AX = PLPRM(I,3)
C *  IF CONSTRAINED BROADENING IS USED... THEN CALCULATE BETA
      IF(KCRYS.EQ.0) GO TO 6120
      TTC = PLPRM(I,1) + CORPOS( PLPRM(I,1) )
      THETAR = TTC * DTORD2
      BETA = 0.0
      IF( KCRYS.EQ.1 .OR. KCRYS.EQ.3 ) THEN
        BETA = RTOD * WTABLE(1,1) / CRYPAR(1) / COS(THETAR)
      ENDIF
      IF( KCRYS.EQ.2 .OR. KCRYS.EQ.3 ) THEN
        BETA = BETA + RTOD * 4.0 * CRYPAR(2) * TAN(THETAR)
      ENDIF
C *  CONVERT INTEGRAL-BREADTH TO FWHM
      IF(JK.EQ.14) AX = 0.6366197724 * BETA
      IF(JK.EQ.15) AX = 0.9394372786 * BETA
C *  ALPHA1 REFLECTION
6120  NTMP = NTMP + 1
      PN(NTMP,1) = PLPRM(I,1)
      PN(NTMP,2) = PLPRM(I,2)
      PN(NTMP,3) = AX
      KRLIN(NTMP) = 1
6110  CONTINUE
C *  RETURN PROPER PARAMETERS
      IF(JK.EQ.14) KPROF = 1
      IF(JK.EQ.15) KPROF = 5
      KNLIN = NTMP
      KNPRM = 3
      GO TO 8000
C *
C **  INTERMEDIATE LORENTZIAN WITH ALPHA 2 REFLECTION
C *
C *  SORT PARAMETERS
7000  IF(JK.NE.8) GO TO 9000
      NTMP = 0
      DO 7010 I=1,KNLIN
      ANGLE = PLPRM(I,1)
      AX = FNFWHM(ANGLE,1) + PLPRM(I,3)
      BX = FNSHAP(ANGLE,1)
      CX = FNFWHM(ANGLE,2) + PLPRM(I,3)
      DX = FNSHAP(ANGLE,2)
C *  ALPHA1 REFLECTION
      NTMP = NTMP + 1
      PN(NTMP,1) = PLPRM(I,1)
      PN(NTMP,2) = PLPRM(I,2)
      PN(NTMP,3) = AX
      PN(NTMP,4) = BX
      PN(NTMP,5) = CX
      PN(NTMP,6) = DX
      KRLIN(NTMP) = 1
C *  ALPHA2 REFLECTION
      IF(NWAVE.GT.1) THEN
        NTMP = NTMP + 1
        CALL CALCPH(PLPRM(I,1),PLPRM(I,2),2,PN(NTMP,1),PN(NTMP,2))
        PN(NTMP,3) = AX
        PN(NTMP,4) = BX
        PN(NTMP,5) = CX
        PN(NTMP,6) = DX
        KRLIN(NTMP) = 2
      ENDIF
7010  CONTINUE
C *  RETURN PROPER PARAMETERS
      KPROF = 7
      KNLIN = NTMP
      KNPRM = 6
C *
C *  PUT SPLIT LINES BACK INTO PLPRM ARRAY
8000  DO 8010 I=1,KNLIN
      DO 8020 J=1,KNPRM
      PLPRM(I,J) = PN(I,J)
8020  CONTINUE
8010  CONTINUE
C *
C *  RETURN TO MAIN
9000  KPROF = IABS( KPROF )
      WRITE(ITTO,9001) KPROF,KNLIN
9001  FORMAT(10X,'Exit : Profile: ',I3,' Lines: ',I3)
      RETURN
      END
C *** PATWRI - GENERATE ALPHA-1 PATTERN AND WRITES IT TO A FILE
C *
      SUBROUTINE PATWRI
C *
      LOGICAL ASCII
      CHARACTER QDATE*9, QTIME*8, QFILE*20, QANS*1, QTITLE*80
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /PDATA/ BANG, EANG
      DIMENSION XDATA(10)
C *
100   IF(KAUTOP.NE.1) THEN
        IF(KMODEO.NE.2) WRITE(ITTO,110)
110     FORMAT(/,' Write alpha-1 pattern to a file ? <N> ')
        READ(ITTI,1050) QANS
       ELSE
        QANS = 'N'
      ENDIF
      IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS = 'N'
      IF(KMODEO.EQ.1) WRITE(IOBO,120) QANS
120   FORMAT(A1,T40,'Output alpha-1 pattern')
      IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,130) QANS
130   FORMAT(/,' Output alpha-1 pattern: ',A1)
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 9000
C *
C **  OPEN THE OUTPUT DATA FILE
C *
C *  GET THE DATA FILE NAME... QUIT IF BLANK
1000  IF(KMODEO.NE.2) WRITE(ITTO,1010)
1010  FORMAT(' What is the name for the output file ? ')
      READ(ITTI,1020) QFILE
1020  FORMAT(A20)
      IF(KMODEO.EQ.1) WRITE(IOBO,1025) QFILE
1025  FORMAT(A20,T40,' Pattern file name')
      IF(KMODEO.EQ.2) WRITE(ITTO,1035) QFILE
1035  FORMAT(/,' Alpha 1 corrected pattern file:',A20)
      IF(QFILE(1:1).NE.' ') GO TO 1030
      GO TO 9000
C *
C *  GET THE DATA FILE TYPE
1030  IF(KMODEO.NE.2) WRITE(ITTO,1040)
1040  FORMAT(' (F)ormatted or (U)nformatted output file ? <F> ')
      READ(ITTI,1050) QANS
1050  FORMAT(A1)
      ASCII = .NOT.( QANS.EQ.'U' .OR. QANS.EQ.'u' )
      IF(ASCII) QANS = 'F'
      IF(KMODEO.EQ.1) WRITE(IOBO,1051) QANS
1051  FORMAT(A1,T40,' Formatted/unformatted file type')
      IF(KMODEO.EQ.2) WRITE(ITTO,1052) QANS
1052  FORMAT('  Output file is formatted/unformatted: ',A1)
C *
C **  VERIFY THE FILE PARAMTERS
C *
1100  IF(KMODEO.NE.2) WRITE(ITTO,1120)
1120  FORMAT(' The title for the pattern ? ')
      READ(ITTI,1130) QTITLE
1130  FORMAT(A80)
      IF(KMODEO.EQ.1) WRITE(IOBO,1130) QTITLE
      IF(KMODEO.EQ.2) WRITE(ITTO,1140) QTITLE(1:72)
1140  FORMAT(1X,A72)
      WRITE(ITTO,1110) BANG,EANG,FAINC,FTIME
1110  FORMAT(/,' The run time parameters for this file are:',//,
     1  ' Starting angle    : ',F10.4,/,
     1  ' Ending angle      : ',F10.4,/,
     1  ' Angle increment   : ',F10.4,/,
     1  ' Step time         : ',F10.4)
C *
C *  IF WE ARE RUNNING BATCH SETUP... EXIT HERE
C *
      IF(KMODEO.EQ.1) GO TO 9000
C *
C *  OPEN THE ASCII OUTPUT DATA FILE
      IF(ASCII) THEN
        OPEN(UNIT=IOFO,FILE=QFILE,STATUS='NEW',ERR=1070,
     1  FORM='FORMATTED')
       ELSE
        OPEN(UNIT=IOFO,FILE=QFILE,STATUS='NEW',ERR=1070,
     1  FORM='UNFORMATTED')
      ENDIF
      GO TO 2000
C *
C *  AN ERROR OCCURED ON FILE OPENING
1070  WRITE(ITTO,1080)
1080  FORMAT(/,' -Unable to open output pattern file; Continuing')
      GO TO 9000
C *
C *  GET THE DATE AND TIME OF PATTERN CREATION
C *
2000  CALL DATE( QDATE )
      CALL TIME( QTIME )
      WRITE(ITTO,2020) QDATE,QTIME
2020  FORMAT(/,' Time of pattern creation: ',A9,2X,A8)
C *
C *  WRITE THE FILE HEADERS
C *
3000  IF(ASCII) THEN
        WRITE(IOFO,1130) QTITLE
        WRITE(IOFO,3010) QDATE,QTIME
        WRITE(IOFO,3020) BANG,EANG,FAINC,FTIME
3010    FORMAT(A9,A8)
3020    FORMAT(4F10.4)
       ELSE
        WRITE(IOFO) QTITLE
        WRITE(IOFO) QDATE,QTIME
        WRITE(IOFO) BANG,EANG,FAINC,FTIME
      ENDIF
C *
C *  SUBTRACT THE ALPHA2,3 FROM THE PATTERN
C *
4000  CALL PATSUB
C *
C *  WRITE THE PATTERN TO THE FILE
C *
5000  IP = 0
5010  DO 5020 I=1,10
5020  XDATA(I) = 0.0
      DO 5030 I=1,10
      IP = IP + 1
      IF(IP.GT.KOBS) GO TO 5040
      XDATA(I) = YSYN(IP)
5030  CONTINUE
5040  IF(ASCII) THEN
        WRITE(IOFO,5060) XDATA
5060    FORMAT(10F7.2)
       ELSE
        WRITE(IOFO) XDATA
      ENDIF
      IF(IP.LT.KOBS) GO TO 5010
C *
C *  CLOSE THE OUTPUT FILE AND EXIT STAGE RIGHT
      CLOSE(UNIT=IOFO)
9000  RETURN
      END
C ***  PATSUB - GENERATES THE ALPHA-1 PATTERN
C *
      SUBROUTINE PATSUB
C *
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201)
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /COMSCR/ PN(200,10)
      DIMENSION NRCOPY(200)
C *
C *  COPY THE ORIGINAL PARAMETERS
C *
1000  DO 1010 I=1,KNLIN
      NRCOPY(I) = KRLIN(I)
      DO 1020 J=1,KNPRM
1020  PN(I,J) = PLPRM(I,J)
1010  CONTINUE
      NLCOPY = KNLIN
      NPCOPY = KNPRM
C *
C *  SUBTRACT THE ALPHA2,3 FROM THE PATTERN
C *
4000  NSTART = KNLIN
      NTEMP = KNLIN
      KRLIN(KNLIN+1) = -1
C *
C *  CHECK FOR ALPHA1
      DO 4010 I0=1,KNLIN
4005  IF(KRLIN(I0).EQ.-1) GO TO 4050
      IF(KRLIN(I0).NE. 1) GO TO 4010
C *
C *  REMOVE LINE FROM PARAMETER LIST
      DO 4020 I1=I0,NTEMP
      I1P1 = I1 + 1
      DO 4030 I2=1,KNPRM
4030  PLPRM(I1,I2) = PLPRM(I1P1,I2)
      KRLIN(I1) = KRLIN(I1P1)
4020  CONTINUE
      NTEMP = NTEMP - 1
      GO TO 4005
4010  CONTINUE
C *
4050  KNLIN = NTEMP
      WRITE(ITTO,4055) NSTART - KNLIN
4055  FORMAT(/,' Lines remaining in pattern: ',I3)
C *
C *  SYNTHESIZE THE PATTERN IN YSYN
      CALL SHADOW( YSYN, 999, IDUM1, IDUM2 )
      DO 4057 I=1,KOBS
4057  YSYN(I) = YSYN(I) + YBKG(I)
C *
C *  SUBTRACT THE TWO PATTERNS
      DO 4060 I=1,KOBS
4060  YSYN(I) = YOBS(I) - YSYN(I)
C *
C *  RESTORE THE ORIGINAL PARAMETERS
C *
2000  DO 2010 I=1,KNLIN
      KRLIN(I) = NRCOPY(I)
      DO 2020 J=1,KNPRM
2020  PLPRM(I,J) = PN(I,J)
2010  CONTINUE
      KNLIN = NLCOPY
      KNPRM = NPCOPY
C *
C *  THATS ALL....
9000  RETURN
      END
C ***  PROGRAM: SHADOW  (SHADOW40)
C ***  VERSION: 860822  (YYMMDD)
C *
C ***  PKSRCH - FIND DIFFRACTION LINES IN THE SCAN DATA
C *
C *  PROGRAMMER: S. A. HOWARD
C *              DEPARTMENT OF CERAMICS
C *              UNIVERISTY OF MISSOURI- ROLLA
C *
      SUBROUTINE PKSRCH
C *
      LOGICAL LFIRST, LLAST
      CHARACTER QWID*1
      PARAMETER ( DTORD2=8.72664626E-03, RTODT2=114.591559 )
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      PARAMETER ( MAXREC = MPTS / 10 )
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /SCHDAT/ KNFND,PSIGMA,RELLOW,BIGINT,KNSMO,KFFLT,KFMNT
      COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3)
      COMMON /BKGDAT/ LDEG,CLY,CLC(6),BKGSDV,IBKCPS,IBKNBK
      COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /RFREGN/ KNUMRG,KNUMCU,REFREG(200,2)
      COMMON /COMSCR/ THTCOR(MPTS),DSPACE(MPTS)
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /PEAKDT/ NPEAK,PEAKS(200,4)
      COMMON /WDATA/ NWAVE,WTABLE(5,2)
      COMMON /SCHANG/ KBEGPT, KENDPT
      COMMON /PDATA/ BANG, EANG
      DIMENSION XDATA(10),OVRLAP(80,2)
C *
C *  PEAKDT - (1) POSITION 2THETA
C *           (2) INTENSITY
C *           (3) WIDTH OF PEAK IN MULTIPLES OF STEP WIDTH
C *           (4) WAVELENGTH IN WAVE TABLE CAUSING THIS REFLECTION
C *
C **  GET THE ANGULAR RANGE FOR THE SEARCH
C *
C *  GET THE APPROXIMATE ANGLES OVER WHICH TO SEARCH
1000  WRITE(ITTO,1001)
1001  FORMAT(/,' * Search criteria:')
      IF(KAUTOP.NE.1) THEN
        WRITE(ITTO,1005)
1005    FORMAT(/,' Angular region for search ? <file start/end> ')
        BANG = 0.0
        EANG = 0.0
        READ(ITTI,*) BANG,EANG
       ELSE
        BANG = FBANG
        EANG = FEANG
      ENDIF
      IF(BANG.LE.0.0) BANG = FBANG
      IF(EANG.LE.0.0) EANG = FEANG
      BANGP = BANG
      EANGP = EANG
      BANG = AMAX1( BANG, FBANG )
      EANG = AMIN1( EANG, FEANG )
      IF(BANG.GE.EANG) GO TO 1000
C *
C *  DETERMINE THE NUMBER OF RECORDS TO SKIP AT BEGINNING
      NSKIP = INT( (BANG-FBANG)/FAINC + 0.10 ) / 10
C *
C *  DETERMINE THE BEGINNING ANGLE
      ANGLE = FBANG + REAL(NSKIP*10) * FAINC
      BANG = ANGLE
C *
C *  DETERMINE THE TOTAL NUMBER OF RECORDS TO BE READ
      NREC = NINT( (EANG-BANG) / FAINC ) / 10 + 1
      EANG = BANG + FAINC * REAL( NREC * 10 ) - FAINC
      IF(EANG.GT.FEANG) EANG = FEANG
      WRITE(ITTO,1015) BANG,EANG
1015  FORMAT(/,' Angles for search: ',F8.4,' to ',F8.4,' 2theta')
C *
C **  GET THE SEARCH PARAMETERS
2000  CALL SRCPRM
C *
C **  GET PLOTTING PARAMETERS
C *
3000  CALL SRPLOT( BANGP, EANGP )
C *
C **  INITIALIZE PEAK/POINTS COUNTERS AND FIRST-PASS-THRU FLAG
      IF(KAUTOP.NE.3) THEN
        NPEAK = 0
        BIGINT = 0.0
      ENDIF
      KOBS  = 0
      LFIRST = .TRUE.
      KNUMRG = 0
C *
C **  LOAD THE BUFFER; USE AN INTEGRAL NUMBER OF RECORDS
C *
C *  REWIND DATA FILE TO BEGINNING
      REWIND (UNIT=IOFI)
C *
C *  SKIP HEADER AND SKIP RECORDS
      IF(KFILET.EQ.0) THEN
        NTEMP = NSKIP + 3
        DO 4002 I=1,NTEMP
4002    READ(IOFI,4020) QWID
4020    FORMAT(1A1)
       ELSE
        NTEMP = NSKIP + 3
        DO 4004 I=1,NTEMP
4004    READ(IOFI) QWID
      ENDIF
C *
C *  DETERMINE THE NUMBER OF RECORDS TO READ ON FIRST PASS
      NREAD = MIN( NREC, MAXREC )
      NREC = NREC - NREAD
C *
C *  READ THE INPUT RECORDS
4030  TEMP = ANGLE - FAINC
      IF(KFILET.EQ.0) THEN
        DO 4040 I=1,NREAD
        READ(IOFI,4042,END=4062) XDATA
4042    FORMAT(10F7.0)
        DO 4044 K=1,10
        KOBS  = KOBS  + 1
        YANG(KOBS) = TEMP + REAL(KOBS) * FAINC
        YOBS(KOBS) = XDATA(K)
4044    CONTINUE
4040    CONTINUE
       ELSE
        DO 4050 I=1,NREAD
        READ(IOFI,END=4062) XDATA
        DO 4052 K=1,10
        KOBS  = KOBS  + 1
        YANG(KOBS) = TEMP + REAL(KOBS) * FAINC
        YOBS(KOBS) = XDATA(K)
4052    CONTINUE
4050    CONTINUE
      ENDIF
      KMAX = INT( (EANG-ANGLE)/FAINC + 0.10 ) + 1
      IF(KOBS.GT.KMAX) KOBS = KMAX
      GO TO 4060
4062  WRITE(ITTO,4064)
4064  FORMAT(/,
     1' --The end-of-file was unexpectedly hit while reading the',
     1' pattern file.')
      NREC = 0
C *
C *  SET LAST PASS THROUGH FLAG BASED ON NREC - RECORDS REMAINING
4060  LLAST = NREC.EQ.0
C *
C *  SET INDEX POINTER BASED ON LFIRST AND LLAST FLAGS
      KBEGPT = 41
      IF(LFIRST) KBEGPT = 1
      LFIRST = .FALSE.
      KENDPT = KOBS - 39
      IF(LLAST) KENDPT = KOBS
      KNNNPT = KENDPT - KBEGPT + 1
C *
C *  RECORD LAST EIGHTY (80) POINTS FOR OVERLAP
      IF(.NOT.LLAST) THEN
        DO 4070 I=1,80
        OVRLAP(I,1) = YANG(KOBS-80+I)
        OVRLAP(I,2) = YOBS(KOBS-80+I)
4070    CONTINUE
      ENDIF
C *
C *  WRITE SEGMENT BEING EVALUATED
      WRITE(ITTO,4080) YANG(KBEGPT),YANG(KENDPT),KNNNPT
4080  FORMAT(/,' Segment: ',F8.4,' to ',F8.4,'  Points = ',I4)
C *
C *  WRITE RAW DATA TO PLOT FILE
      IF(KPSETS(1).NE.0) THEN
        IF(KPTYPE.EQ.0) THEN
          WRITE(IOPL) KPSETS(1),KNNNPT,YANG(KBEGPT)
          WRITE(IOPL) (YOBS(I)/FTIME,I=KBEGPT,KENDPT)
         ELSE
          WRITE(IOPL,4090) KPSETS(1),KNNNPT,YANG(KBEGPT)
4090      FORMAT(I6,I6,F10.4)
          WRITE(IOPL,4092) (YOBS(I)/FTIME,I=KBEGPT,KENDPT)
4092      FORMAT(10F8.1)
        ENDIF
      ENDIF
C *
C **  APPLY THE DIGITAL FILTER TO THE DATA
C *
C *  KFFLT = 1: BROMBA/ZIEGLER FILTER... RECURSIVE, INTEGER AND FAST
C *  KFFLT = 2: SAVITSKY/GOLAY... NONRECURSIVE
C *  NOTE:      SCRATCH ARRAYS ARE USED IN DGFILT
C *
      IF(KFFLT.EQ.1) THEN
        CALL DGFILT( KFMNT, KNSMO )
       ELSE IF(KFFLT.EQ.2) THEN
        CALL SVGOLY( KNSMO,     0 )
       ELSE
        DO 6080 I=1,KOBS
6080    YSYN(I) = YOBS(I)
        GO TO 5000
      ENDIF
C *
C *  CALCULATE THE R FACTOR FOR SMOOTHING
      R0 = 0.0
      R1 = 0.0
      DO 6090 I=KBEGPT,KENDPT
      WGT = 1.0 / AMAX1( YOBS(I), 1.0 )
      R0 = R0 + YOBS(I)
      R1 = R1 + WGT * ( YOBS(I) - YSYN(I) )**2
6090  CONTINUE
      R0 = SQRT( R1 / R0 )
      WRITE(ITTO,6092) R0
6092  FORMAT(' Rwp after smoothing the raw data = ',F9.4)
C *
C *  WRITE SMOOTHED DATA TO PLOT FILE
      IF(KPSETS(4).NE.0) THEN
        IF(KPTYPE.EQ.0) THEN
          WRITE(IOPL) KPSETS(4),KNNNPT,YANG(KBEGPT)
          WRITE(IOPL) (YSYN(I)/FTIME,I=KBEGPT,KENDPT)
         ELSE
          WRITE(IOPL,4090) KPSETS(4),KNNNPT,YANG(KBEGPT)
          WRITE(IOPL,4092) (YSYN(I)/FTIME,I=KBEGPT,KENDPT)
        ENDIF
      ENDIF
C *
C **  REMOVE BACKGROUND IF BACKGROUND HAS BEEN DETERMINED
C *
5000  IF(KBKGD.NE.1) THEN
        WRITE(ITTO,5010)
5010    FORMAT(' No background adjustment made on this segment')
        GO TO 7000
       ELSE
        KBKGR = 2
      ENDIF
C *
C *  GENERATE THE BACKGROUND IN YBKG
      ICODE = 0
      CALL BKGLVL( YBKG )
C *
C *  CORRECT YOBS FOR BACKGROUND, GENERATE THE THRESHOLD LEVEL IN YBKG
C *  AND CORRECT YSYN FOR THE THRESHOLD
      WRITE(ITTO,5020)
5020  FORMAT(' Subtracting background from segment')
      DO 5030 I=1,KOBS
      CYOBS = YOBS(I)
      YOBS(I) = CYOBS - YBKG(I)
      YBKG(I) = YBKG(I) + PSIGMA * SQRT( AMAX1(YBKG(I),0.0) + CYOBS )
      YSYN(I) = YSYN(I) - YBKG(I)
5030  CONTINUE
C *
C *  WRITE BACKGROUND CORRECTED DATA TO PLOT FILE
      IF(KPSETS(2).NE.0) THEN
        IF(KPTYPE.EQ.0) THEN
          WRITE(IOPL) KPSETS(2),KNNNPT,YANG(KBEGPT)
          WRITE(IOPL) (YOBS(I)/FTIME,I=KBEGPT,KENDPT)
         ELSE
          WRITE(IOPL,4090) KPSETS(2),KNNNPT,YANG(KBEGPT)
          WRITE(IOPL,4092) (YOBS(I)/FTIME,I=KBEGPT,KENDPT)
        ENDIF
      ENDIF
C *
C *  WRITE THRESHOLD TO PLOT FILE
      IF(KPSETS(3).NE.0) THEN
        IF(KPTYPE.EQ.0) THEN
          WRITE(IOPL) KPSETS(3),KNNNPT,YANG(KBEGPT)
          WRITE(IOPL) (YBKG(I)/FTIME,I=KBEGPT,KENDPT)
         ELSE
          WRITE(IOPL,4090) KPSETS(3),KNNNPT,YANG(KBEGPT)
          WRITE(IOPL,4092) (YBKG(I)/FTIME,I=KBEGPT,KENDPT)
        ENDIF
      ENDIF
C *
C **  PERFORM PEAK DETECTION ON THIS SEGMENT
C *
7000  IF(KAUTOP.NE.3) CALL PKFIND
C *
C *  NOW REJECT PEAKS OF TOO LOW INTENSITY
      IF(NPEAK.LT.2) GO TO 7100
      YMIN = RELLOW * BIGINT
      DO 7010 I=1,NPEAK
7010  IF(PEAKS(I,2).LT.YMIN) PEAKS(I,1) = 0.0
      NTEMP = NPEAK
      NPEAK = 0
      DO 7020 I=1,NTEMP
      IF(PEAKS(I,1).EQ.0.0) GO TO 7020
      NPEAK = NPEAK + 1
      IF(NPEAK.EQ.I) GO TO 7020
      PEAKS(NPEAK,1) = PEAKS(I,1)
      PEAKS(NPEAK,2) = PEAKS(I,2)
      PEAKS(NPEAK,3) = PEAKS(I,3)
      PEAKS(NPEAK,4) = PEAKS(I,4)
7020  CONTINUE
C *
C **  DETERMINE REGIONS FOR REFINEMENT WHEN AUTOPILOT FLAG IS ON
C *
7100  IF(KAUTOP.NE.0) CALL SETREG( 0 )
C *
C **  LOAD NEXT SEGMENT FOR SEARCH
C *
C *  TEST FOR REMAINING RECORDS
8000  IF(LLAST) GO TO 9000
C *
C *  COPY THE LAST EIGHTY (80) POINTS TO FRONT OF BUFFER
      DO 8010 I=1,80
      YANG(I) = OVRLAP(I,1)
      YOBS(I) = OVRLAP(I,2)
      YSYN(I) = YOBS(I)
8010  CONTINUE
C *
C *  UPDATE ANGLE FOR NEXT SEGMENT AND KOBS
      KOBS = 80
      ANGLE = YANG(1)
C *
C *  SET RECORD INDICATOR, NOTE: 80 POINTS IS 8 RECORDS
      NREAD = MIN( NREC, (MAXREC-8) )
      NREC = NREC - NREAD
      GO TO 4030
C *
C **  CHECK FOR WHICH REFLECTION WRT WAVELENGTH IS PRESENT.
C **  CALCULATE ALL OTHER POSITIONS BASED ON THE WAVELENGTHS TABLED,
C **  ALLOWANCES: INTENSITY 20%, POSITION 2 ANGULAR INCREMENTS.
C *
9000  IF(NWAVE.LT.2) GO TO 9090
C *
C *  CHECK ALL PEAKS
      DELMAX = 2.0 * FAINC
      DO 9010 I0=1,NPEAK
C *
C *  CHECK ALL WAVELENGTHS
      DO 9020 LAMBDA=2,NWAVE
      CALL CALCPH(PEAKS(I0,1),PEAKS(I0,2),LAMBDA,PN,YN)
C *
C *  CHECK ALL PEAKS FOR A MATCH
      DO 9030 I1=1,NPEAK
      IF( ABS(PEAKS(I1,1)-PN) .GT. DELMAX )GO TO 9030
      RIDIFF = ABS( 1. - YN/PEAKS(I1,2) )
      IF(RIDIFF.GT.0.20) GO TO 9030
      PEAKS(I1,4) = REAL(LAMBDA)
9030  CONTINUE
9020  CONTINUE
9010  CONTINUE
C *
C *  CALL SETREG TO CLEANUP THE REFINEMENT REGIONS IF AUTOPILOT IS ON
9090  IF(KAUTOP.NE.0) CALL SETREG( 1 )
C *
C **  LIST PEAK SEARCH RESULTS
C *
C *  PRINT THE HEADER
9100  WRITE(ITTO,9105)
9105  FORMAT(//,6X,'*****   P E A K   S E A R C H   R E S U L T S',
     1 '   *****')
C *
C *  LIST THE PARAMETERS USED IN THE SEARCH
      RELLOW = RELLOW * 100.0
      WRITE(ITTO,9107)PSIGMA,RELLOW,KNFND,KNSMO,KFFLT,KFMNT
9107  FORMAT(/,2X,' Std devation threshold: ',F5.2,
     1         2X,' Min relative intensity: ',F5.2,/,
     1         2X,' Points used for search: ',I5,
     1         2X,' Points used for smooth: ',I5,/,
     1         2X,' Filter type           : ',I5,
     1         2X,' Filter moment         : ',I5)
C *
C *  HAVE ANY PEAKS BEEN DETECTED?
      IF(NPEAK.EQ.0) GO TO 9200
C *
C *  HAS THE CALIBRATION CURVE BEEN APPLIED?
      TEMP = ABS(WGCAL(1)) + ABS(WGCAL(2)) + ABS(WGCAL(3))
      IF(TEMP.GT.0.0) WRITE(ITTO,9108)
9108  FORMAT(/,' *  2theta calibration curve applied to positions')
C *
C *  LIST THE PEAK PARAMETERS
      WRITE(ITTO,9115)
9115  FORMAT(//,' No.  Two-theta  Ref  Peak (CPS)  D spacing  Rel. peak'
     1         ,'  Peak width  Region'
     1       ,/,' ---  ---------  ---  ----------  ---------  ---------'
     1         ,'  ----------  ------')
C *
C *  PRINT ALL THE PEAK INFORMATION
      DO 9120 IP=1,NPEAK
      POS = PEAKS(IP,1)
      IF(KAUTOP.NE.0) THEN
        DO 9130 IR=1,KNUMRG
9130    IF( POS.GE.REFREG(IR,1) .AND. POS.LE.REFREG(IR,2) ) GO TO 9135
        IR = 999
       ELSE
        IR = 0
      ENDIF
9135  RI = PEAKS(IP,2) / BIGINT * 100.0
      POS = POS + CORPOS( POS )
      IF(KAUTOP.NE.3) PEAKS(IP,2) = PEAKS(IP,2) / FTIME
      LAMBDA = INT( PEAKS(IP,4) )
      DSP = WTABLE(LAMBDA,1) / ( 2.0*SIN(POS*DTORD2) ) * 1.0E10
      WRITE(QWID,9125) LAMBDA
9125  FORMAT(I1)
      IF(QWID.EQ.'1') QWID = ' '
      WRITE(ITTO,9140) IP,POS,QWID,PEAKS(IP,2),DSP,RI,PEAKS(IP,3),IR
9140  FORMAT(' ',I3,2X,F9.4,4X,A1,2X,F10.4,2X,F9.4,2X,F9.4,2X,F9.4,
     1 4X,I3)
      THTCOR(IP) = POS
      DSPACE(IP) = DSP
9120  CONTINUE
C *
C *  IF THE PEAK LOCATION MARKERS ARE BEING PLOTTED...
      IF(KPSETS(5).NE.0) THEN
        IF(KPTYPE.EQ.0) THEN
          WRITE(IOPL) KPSETS(5),NPEAK,PEAKS(1,1)
          WRITE(IOPL) (PEAKS(I,1),PEAKS(I,2),THTCOR(I),DSPACE(I),
     1    INT(PEAKS(I,4)),I=1,NPEAK)
         ELSE
          WRITE(IOPL,4090) KPSETS(5),NPEAK,PEAKS(1,1)
          WRITE(IOPL,9102) (PEAKS(I,1),PEAKS(I,2),THTCOR(I),DSPACE(I),
     1    INT(PEAKS(I,4)),I=1,NPEAK)
9102      FORMAT(4F10.4,I2)
        ENDIF
      ENDIF
C *
      GO TO 9900
C *
C *  NO PEAKS HAVE BEEN FOUND IN THIS INTERVAL....
9200  WRITE(ITTO,9210)
9210  FORMAT(/,' ',15X,'--- No peaks detected ---')
C *
C *  EXIT STAGE LEFT
9900  IF(KPPLOT.NE.0) CLOSE(IOPL)
      RETURN
      END
C ***  SRCPRM - DETERMINE PARAMETERS FOR THE SEARCH
C *
      SUBROUTINE SRCPRM
C *
      CHARACTER QANS*1
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS
      COMMON /SCHDAT/ KNFND,PSIGMA,RELLOW,BIGINT,KNSMO,KFFLT,KFMNT
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
C *
C **  DETERMINE WHETHER THIS IS A STANDARD SEARCH
C *
2000  IF(KAUTOP.EQ.1) THEN
        WRITE(ITTO,2002)
2002    FORMAT(/,' Standard search parameters in use')
        GO TO 2100
      ENDIF
      WRITE(ITTO,2005)
2005  FORMAT(/,' Perform standard search ? <Y> ')
      READ(ITTI,2010) QANS
2010  FORMAT(A1)
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 3000
C *
C **  SET THE DEFAULT PARAMETERS
C *
2100  PSIGMA = 3.0
      RELLOW = 0.01
      IF(KBKGD.EQ.1) RELLOW = 0.000001
      KFFLT = 1
      KFMNT = 2
      KNFND = 5
      IF(FAINC.LE.0.02) KNFND = 7
      IF(FAINC.LE.0.01) KNFND = 9
      KNSMO = KNFND
      IF(KAUTOP.EQ.1) THEN
        PSIGMA = 5.0
        RELLOW = 0.02
        KNFND = KNFND + 2
        KNSMO = KNSMO + 2
      ENDIF
      GO TO 9000
C *
C **  GET THE NON STANDARD PEAK SEARCH PARAMETERS
C *
C *  SIGMA ABOVE BACKGROUND FOR ACCEPTANCE
3000  WRITE(ITTO,3005)
3005  FORMAT(/,' Sigma above background for peak acceptance ? <3.0> ')
      PSIGMA = 3.0
      READ(ITTI,*) PSIGMA
      IF(PSIGMA.LE.0.0) PSIGMA = 3.0
C *
C *  MINIMUM RELATIVE INTENSITY
      DEFREL = 1.0
      IF(KBKGD.EQ.1) DEFREL = 0.00001
      WRITE(ITTO,3010) DEFREL
3010  FORMAT(' Minimum relative intensity accepted ? <',F5.2,'> ')
      RELLOW = DEFREL
      READ(ITTI,*) RELLOW
      IF(RELLOW.LE.0.0) RELLOW = DEFREL
      RELLOW = RELLOW / 100.0
C *
C *  NUMBER OF POINTS USED TO FIND PEAKS
      KNFND = 5
      IF(FAINC.LE.0.02) KNFND = 7
      IF(FAINC.LE.0.01) KNFND = 9
      WRITE(ITTO,3015) KNFND
3015  FORMAT(' Number of points for peak detection ? (5-25) <',I2,'> ')
      NTEMP = 0
      READ(ITTI,*) NTEMP
      IF(NTEMP.GT.0) KNFND = NTEMP
      KNFND = (KNFND/2) * 2 + 1
      IF(KNFND.LT.5) KNFND = 5
      IF(KNFND.GT.25) KNFND = 25
C *
C *  GET PARAMETERS FOR FILTERING TECHNIQUE
C *
C *  GET THE TYPE OF FILTER
      WRITE(ITTO,3025)
3025  FORMAT(/,
     1 ' Filter: 1 - Bromba/Ziegler (recursive)',/,
     1       9X,'2 - Savitsky/Golay (nonrecursive)',/,
     1       9X,'3 - No filtering',//,
     1 ' Type of smoothing algorithm ? <1> ')
      KFFLT = 1
      READ(ITTI,*) KFFLT
      IF( KFFLT.LT.1 .OR. KFFLT.GT.3 ) KFFLT = 1
C *
C *  SET UP THE BROMBA/ZIEGLER FILTER MOMENT
      KFMNT = 2
      IF(KFFLT.NE.1) GO TO 3030
      WRITE(ITTO,3035)
3035  FORMAT(/,'  Smoothing filter moment+1 ?  (1,3,5) <3> ')
      KFMNT = 3
      READ(ITTI,*) KFMNT
      KFMNT = KFMNT - 1
      IF( KFMNT.NE.0 .AND. KFMNT.NE.2 .AND. KFMNT.NE.4 ) KFMNT = 2
C *
C *  FILTER WIDTH SHOULD BE PEAK FWHM....
3030  IF(KFFLT.GT.2) GO TO 9000
      KNSMO = KNFND
      WRITE(ITTO,3040) KNSMO
3040  FORMAT(/,' Number of points full-width of filter ? (5-25) ',
     1 ' <',I2,'> ')
      NTEMP = 0
      READ(ITTI,*) NTEMP
      IF(NTEMP.GT.0) KNSMO = NTEMP
      KNSMO = (KNSMO/2) * 2 + 1
      IF(KNSMO.LT.5) KNSMO = 5
      IF(KNSMO.GT.25) KNSMO = 25
C *
C *  PARAMETER SETUP COMPLETE
9000  RETURN
      END
C ***  PKFIND - SLIDING SECOND ORDER POLYNOMIAL PEAK FINDER
C *
      SUBROUTINE PKFIND
C *
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /SCHDAT/ KNFND,PSIGMA,RELLOW,BIGINT,KNSMO,KFFLT,KFMNT
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /PEAKDT/ NPEAK,PEAKS(200,4)
      COMMON /SCHANG/ KBEGPT, KENDPT
      COMMON /DIAGS/ ISENSE(10)
C *
C *  COMPUTE CONSTANTS FOR PEAK DETECTION
1000  MIDPNT = ( KNFND + 1 ) / 2
      I02 = 0
      I04 = 0
      DO 1010 I=1,KNFND
      I02 = I02 + ( I-MIDPNT )**2
      I04 = I04 + ( I-MIDPNT )**4
1010  CONTINUE
      NI1I02 = KNFND * I04 - I02**2
      FI02 = REAL( I02 )
      FI04 = REAL( I04 )
      FNI1I2 = REAL( NI1I02 )
      FKNFND = REAL( KNFND )
      PCLOSE = FAINC * REAL( KNFND / 2 )
C *
C *  MINIMUM RELATIVE INTENSITY FOR FURTHER CONSIDERATION
      YMIN = BIGINT * RELLOW
C *
C *  COMPUTE CONSTANTS FOR THE INTERVAL
      NOFFST = KNFND / 2
      NSTART = KBEGPT - NOFFST
      IF(NSTART.LT.1) NSTART = 1
      NFINIS = KOBS - KNFND + 1
      NTEMP = ( NFINIS + NOFFST ) - KENDPT
      IF(NTEMP.GT.0) NFINIS = NFINIS - NTEMP
C *
1300  DO 1310 I=NSTART,NFINIS
C *
C *  COMPUTE INDEX POINTER, POINT UNDER CONSIDERATION.
      NPOINT = NOFFST + I
C *
C *  REJECT POINT IF LOWER THAN THERESHOLD
      IF(YSYN(NPOINT).LT.0.0) GO TO 1310
C *
C *  REJECT POINT IF LOWER THAN MINIMUM INTENSITY
      IF(YOBS(NPOINT).LT.YMIN) GO TO 1310
C *
C *  COMPUTE SUMS FOR EVALUATION
1400  FJ0 = 0.0
      FJ1 = 0.0
      FJ2 = 0.0
      DO 1410 NP=1,KNFND
      NPP = NP + I - 1
      FACT = REAL( NP - MIDPNT )
      YNPP = YSYN(NPP)
      FJ0 = FJ0 +                 YNPP
      FJ1 = FJ1 +          FACT * YNPP
      FJ2 = FJ2 + FACT * ( FACT * YNPP )
1410  CONTINUE
C *
C *  COMPUTE COEFFICIENTS
      FNJJI = FKNFND * FJ2 - FJ0 * FI02
      A0 = ( FJ0 * FNI1I2 - FNJJI ) / ( FKNFND * FNI1I2 )
      A1 = FJ1 / ( FI02 * FAINC )
      A2 = FNJJI / ( FNI1I2 * FAINC**2 )
C *
C *  INSURE DOWNWARDS CONCAVITY
      DET = A1**2 - 4.0 * A2 * A0
      IF(DET.LT.0.0) GO TO 1310
C *
C *  CALCULATE OFFSET FROM OBSERVED MAX TO PREDICTED
      DELTA = -A1 / ( 2.0 * A2 + 0.000001 )
      IF( ABS(DELTA) .GT. FAINC  ) GO TO 1310
C *
C *  CONSIDER THIS A PEAK
      PL = YANG(NPOINT) + DELTA
      PI = YOBS(NPOINT)
C *
C *  DETERMINE IF THIS IS THE HIGHEST PEAK SO FAR
      IF(PI.GT.BIGINT) THEN
        BIGINT = PI
        YMIN = BIGINT * RELLOW
      ENDIF
C *
C *  FIND ROOTS ON BOTH SIDES OF PEAK
      IDIR = -1
1460  ICU = I
1462  ICU = ICU + IDIR
      IF(ICU.LT.NSTART) GO TO 1466
      IF(ICU.GT.NFINIS) GO TO 1468
      FJ0 = 0.0
      FJ1 = 0.0
      FJ2 = 0.0
      DO 1464 NP=1,KNFND
      NPP = NP + ICU - 1
      FACT = REAL( NP - MIDPNT )
      YNPP = YSYN(NPP)
      FJ0 = FJ0 +                 YNPP
      FJ1 = FJ1 +          FACT * YNPP
      FJ2 = FJ2 + FACT * ( FACT * YNPP )
1464  CONTINUE
C *  COMPUTE COEFFICIENTS, IF CONCAVE DOWN TRY NEXT POINT
      FNJJI = FKNFND * FJ2 - FJ0 * FI02
      A0 = ( FJ0 * FNI1I2 - FNJJI ) / ( FKNFND * FNI1I2 )
      A1 = FJ1 / ( FI02 * FAINC )
      A2 = FNJJI / ( FNI1I2 * FAINC**2 )
      DET = A1**2 - 4.0 * A2 * A0
      IF(DET.GE.0.0) GO TO 1462
C *  CHANGE DIRECTIONS IF BACKWARDS HAS BEEN SEARCHED
1466  IF(IDIR.EQ.-1) THEN
         ILO = NOFFST + ( ICU + 1 )
         IDIR = 1
         GO TO 1460
      ENDIF
C *  DETERMINE WIDTH
1468  IHI = NOFFST + ( ICU - 1 )
      PWID = YANG(IHI) - YANG(ILO)
      IF(ISENSE(3).NE.0)
     1WRITE(ITTO,1430) YANG(NPOINT),YANG(ILO),YANG(IHI),DELTA,PWID
1430  FORMAT(' 2THT BEG END, D2THT, WID = ',5F10.4)
C *
C *  CHECK FOR ADJACENT PEAKS, REPLACE WITH HIGHEST
      IF(NPEAK.LT.1) GO TO 1440
      IF( (PL-PEAKS(NPEAK,1)) .GT. PCLOSE ) GO TO 1440
      IF(PI.LT.PEAKS(NPEAK,2)) GO TO 1310
      PEAKS(NPEAK,1) = PL
      PEAKS(NPEAK,2) = PI
      PEAKS(NPEAK,3) = PWID
      GO TO 1310
C *
C *  THERE ARE > 200 PEAKS SO FAR, REMOVE THE LOWEST
1440  IF(NPEAK.LT.200) GO TO 1450
      LOWEST = 1
      DO 1455 ILOW = 2,NPEAK
1455  IF(PEAKS(ILOW,2).LT.PEAKS(LOWEST,2)) LOWEST = ILOW
      IF(LOWEST.EQ.NPEAK) GO TO 1472
      DO 1470 ISHIFT=LOWEST,NPEAK-1
      IP1 = ISHIFT + 1
      PEAKS(ISHIFT,1) = PEAKS(IP1,1)
      PEAKS(ISHIFT,2) = PEAKS(IP1,2)
      PEAKS(ISHIFT,3) = PEAKS(IP1,3)
1470  CONTINUE
1472  NPEAK = NPEAK - 1
C *
C *  RECORD THE NEW PEAK PARAMETERS
1450  NPEAK = NPEAK + 1
      PEAKS(NPEAK,1) = PL
      PEAKS(NPEAK,2) = PI
      PEAKS(NPEAK,3) = PWID
      PEAKS(NPEAK,4) = 1.0
C *
C *  NEXT POINT IN SEGMENT
1310  CONTINUE
C *
C *  PEAK FINDING COMPLETE
      RETURN
      END
C ***  SETREG - SET REGIONS FOR REFINEMENT
C *
      SUBROUTINE SETREG( ICODE )
C *
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      PARAMETER ( OVRMIN = 1.0 )
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /SCHDAT/ KNFND,PSIGMA,RELLOW,BIGINT,KNSMO,KFFLT,KFMNT
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /RFREGN/ KNUMRG,KNUMCU,REFREG(200,2)
      COMMON /PEAKDT/ NPEAK,PEAKS(200,4)
      COMMON /SCHANG/ KBEGPT, KENDPT
      COMMON /DIAGS/ ISENSE(10)
C *
C *  IF ICODE=0 FIND REGIONS, ICODE=1 THEN CLEAN UP
      IF(ICODE.EQ.1) GO TO 5000
C *
C **  FIND SEGMENT ABOVE BACKGROUND LEVEL
C *
1000  N1 = KBEGPT
      N2 = KBEGPT
C *
C *  FIND STARTING POINT
1010  IF(N1.GT.KENDPT) GO TO 2000
      IF(YSYN(N1).GT.0.0001) GO TO 1020
      N1 = N1 + 1
      GO TO 1010
C *
C *  FIND ENDING POINT
1020  N2 = N1 + 1
1030  IF(N2.GT.KENDPT) GO TO 1040
      IF(YSYN(N2).LT.0.0001) GO TO 1050
      N2 = N2 + 1
      GO TO 1030
C *
C * FOUND END OF REGION ABOVE BACKGROUND
1050  N2 = N2 - 1
      KNUMRG = KNUMRG + 1
      REFREG(KNUMRG,1) = YANG(N1)
      REFREG(KNUMRG,2) = YANG(N2)
C      WRITE(ITTO,1052) YANG(N1),YANG(N2),N2-N1+1
C1052  FORMAT(' REGION FOUND:  RANGE ',F8.4,' TO ',F8.4,' DEGREES, ',I4,
C     1  ' POINTS')
      N1 = N2 + 1
      GO TO 1010
C *
C *  END POINT OF REGION NOT WITHIN CURRENT SEGMENT
1040  N2 = N2 - 1
      KNUMRG = KNUMRG + 1
      REFREG(KNUMRG,1) = YANG(N1)
      REFREG(KNUMRG,2) = YANG(N2)
C      WRITE(ITTO,1042) YANG(N1),YANG(N2),N2-N1+1
C1042  FORMAT(' END OF SEGMENT HIT: RANGE ',F8.4,' TO ',F8.4,' DEGREES ',
C     1  I4,' POINTS')
C *
C **  DETERMINE MAJOR SEGMENTS BASED ON OVRMIN DEGREE OVERLAP
C *
2000  IF(KNUMRG.LT.2) GO TO 9000
      NUMOLD = KNUMRG
      KNUMRG = 1
      DO 2010 I=2,NUMOLD
2015  IF(REFREG(I,1).EQ.0.0) GO TO 9000
      OVR = REFREG(I,1) - REFREG(I-1,2)
      IF(OVR.GT.OVRMIN) GO TO 2020
C *  COMBINE REGION AND COMPRESS LIST
      REFREG(KNUMRG,1) = REFREG(I-1,1)
      REFREG(KNUMRG,2) = REFREG(I  ,2)
      IF(I.LT.NUMOLD) THEN
        DO 2030 J=I+1,NUMOLD
        REFREG(J-1,1) = REFREG(J,1)
        REFREG(J-1,2) = REFREG(J,2)
2030    CONTINUE
      ENDIF
      REFREG(NUMOLD,1) = 0.0
      REFREG(NUMOLD,2) = 0.0
      GO TO 2015
C *  COPY REGION
2020  KNUMRG = KNUMRG + 1
      REFREG(KNUMRG,1) = REFREG(I,1)
      REFREG(KNUMRG,2) = REFREG(I,2)
2010  CONTINUE
      GO TO 9000
C *
C **  FINAL CLEAN UP.  REGIONS MUST HAVE LINES.
C *
5000  WRITE(ITTO,5002)
5002  FORMAT(/,' * Regions for refinement will be as follows:',/)
      NUMOLD = KNUMRG
      KNUMRG = 0
      DO 5010 I=1,NUMOLD
      LINES = 0
      DO 5020 J=1,NPEAK
5020  IF( PEAKS(J,1).GE.REFREG(I,1) .AND. PEAKS(J,1).LE.REFREG(I,2) )
     1  LINES = LINES + 1
      IF(LINES.EQ.0) GO TO 5010
      KNUMRG = KNUMRG + 1
      REFREG(KNUMRG,1) = REFREG(I,1)
      REFREG(KNUMRG,2) = REFREG(I,2)
      NPTS = NINT( (REFREG(KNUMRG,2)-REFREG(KNUMRG,1))/FAINC ) + 1
      WRITE(ITTO,5030) REFREG(I,1),REFREG(I,2),NPTS,LINES
5010  CONTINUE
5030  FORMAT(' Region ',F8.4,' to ',F8.4,'  Points ',I4,'  Lines ',I3)
C *
C *  REGION SETUP COMPLETE
9000  RETURN
      END
C **  SRPLOT - SET UP PLOT FILE FOR SEARCH PHASE
C *
      SUBROUTINE SRPLOT( STRT, FINS )
C *
      CHARACTER QTITLS(5)*20, QFILE*32, QANS*1, QFTITL*80
      COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG
      COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME
      COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF
      COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /FLDATC/ QFTITL
      DIMENSION NCPLOT(5),OFFSET(5),NUMPEN(5),MARKER(5)
      DATA QTITLS(1)/'Observed pattern    '/
      DATA QTITLS(2)/'Bkg corr pattern    '/
      DATA QTITLS(3)/'Threshold level     '/
      DATA QTITLS(4)/'Filtered pattern    '/
      DATA QTITLS(5)/'Peak location marker'/
C *
1000  KPPLOT = 0
      DO 1010 I=1,5
      KPSETS(I) = 0
      NCPLOT(I) = 0
      OFFSET(I) = 0.0
      NUMPEN(I) = 0
      MARKER(I) = 0
1010  CONTINUE
C *
C *  DETERMINE WHETHER A PLOTTING FILE IS TO BE GENERATED
      IF(KAUTOP.NE.1) THEN
        WRITE(ITTO,1020)
1020    FORMAT(/,' Produce plotting from the search phase ? <N> ')
        READ(ITTI,1030) QANS
1030    FORMAT(1A1)
       ELSE
        QANS = 'Y'
      ENDIF
      IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) KPPLOT = 1
      IF(KPPLOT.EQ.0) GO TO 9000
C *
C *  GET THE OUTPUT FILE NAME AND OPEN IT
1035  IF(KAUTOP.NE.1) THEN
        WRITE(ITTO,1040)
1040    FORMAT(' Plot file name ? <SPLOT> ')
        READ(ITTI,1050) QFILE
1050    FORMAT(A32)
       ELSE
        QFILE = 'SPLOT'
        WRITE(ITTO,1051) QFILE
1051    FORMAT(/,' Plot data written to: ',A32)
      ENDIF
      IF( QFILE(1:1).EQ.'$' .AND. KPTYPE.EQ.0 ) THEN
        WRITE(ITTO,1052)
1052    FORMAT(' -Plot file type changed to formatted')
        KPTYPE = 1
        QFILE(1:) = QFILE(2:)
      ENDIF
      IF( QFILE(1:1).EQ.'$' .AND. KPTYPE.EQ.1 ) THEN
        WRITE(ITTO,1054)
1054    FORMAT(' -Plot file type changed to unformatted')
        KPTYPE = 0
        QFILE(1:) = QFILE(2:)
      ENDIF
      IF( QFILE.EQ.' ' .OR. QFILE.EQ.'/' ) QFILE = 'SPLOT'
      IF(KPTYPE.EQ.0) THEN
        OPEN(UNIT=IOPL,FILE=QFILE,STATUS='UNKNOWN',FORM='UNFORMATTED',
     1  ERR=1060)
       ELSE
        OPEN(UNIT=IOPL,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED',
     1  ERR=1060)
      ENDIF
      GO TO 2000
1060  WRITE(ITTO,1070)
1070  FORMAT(' --Can not open specified plot file')
      GO TO 1035
C *
C *  USE DEFAULT PARAMS OR SET THEM INDIVIDUALLY....
C *
2000  IF(KAUTOP.NE.1) THEN
        WRITE(ITTO,2010)
2010    FORMAT(' Do you want the default plot package ? <Y> ')
        READ(ITTI,1030) QANS
       ELSE
        QANS = 'Y'
        WRITE(ITTO,2012)
2012    FORMAT('  Default plot parameters used')
      ENDIF
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 2100
C *
C *  SET DEFAULT PARAMETERS
C *
      NUMSTS = 3
C *
      KPSETS(1) =  1
      NCPLOT(1) =  1
      OFFSET(1) =  0.0
      NUMPEN(1) =  2
      MARKER(1) =  0
C *
      KPSETS(2) =  0
      NCPLOT(2) =  0
      OFFSET(2) =  0.0
      NUMPEN(2) =  0
      MARKER(2) =  0
C *
      KPSETS(3) =  2
      NCPLOT(3) = 10
      OFFSET(3) =  0.0
      NUMPEN(3) =  3
      MARKER(3) =  0
C *
      KPSETS(4) =  0
      NCPLOT(4) =  0
      OFFSET(4) =  0.0
      NUMPEN(4) =  0
      MARKER(4) =  0
C *
      KPSETS(5) =  3
      NCPLOT(5) =  1
      OFFSET(5) =  0.0
      NUMPEN(5) =  4
      MARKER(5) =  2
C *
      NPLOTS = 1
      IAXIS = 0
      FS = 1200.0
      DPI = 2.
      GO TO 3000
C *
C *  TELL THEM HOW ITS DONE
2100  NUMSTS = 0
      WRITE(ITTO,2115)
2115  FORMAT(/,' The following questions pertain to plotting of the',
     1 ' search results.',/,' Enter <+N,0 or -N> for plotting of every',
     1 ' Nth point in the data set',//,
     1 3X,' +N => Draw lines between each Nth point',/,
     1 3X,'  0 => Skips the data set.',/,
     1 3X,' -N => Draw dots at each Nth point',//,
     1 ' Follow N with a value for the offset (in inches) to',
     1 ' separate',/,' the data groups.  e.g., .75 displaces the data',
     1 ' set .75 inches.',//,
     1 ' The final parameter specifies the pen to use in plotting',
     1 ' the data set')
C *
C *  RAW PATTERN
      KPSETS(1) = 0
      NCPLOT(1) = 0
      OFFSET(1) = 0.0
      NUMPEN(1) = 0
      MARKER(1) = 0
      WRITE(ITTO,2120)
2120  FORMAT(/,' Raw data ? <0,0.0,0> ')
      READ(ITTI,*) NCPLOT(1),OFFSET(1),NUMPEN(1)
      IF(NCPLOT(1).NE.0) THEN
        NUMSTS = NUMSTS + 1
        KPSETS(1) = NUMSTS
      ENDIF
C *
C *  THRESHOLD CORRECTED PATTERN
      KPSETS(2) = 0
      NCPLOT(2) = 0
      OFFSET(2) = 0.0
      NUMPEN(2) = 0
      MARKER(2) = 0
      WRITE(ITTO,2140)
2140  FORMAT(' Threshold corrected data ? <0,0.0,0> ')
      READ(ITTI,*) NCPLOT(2),OFFSET(2),NUMPEN(2)
      IF(NCPLOT(2).NE.0) THEN
        NUMSTS = NUMSTS + 1
        KPSETS(2) = NUMSTS
      ENDIF
C *
C *  THE THRESHOLD LEVEL
      KPSETS(3) = 0
      NCPLOT(3) = 0
      OFFSET(3) = 0.0
      NUMPEN(3) = 0
      MARKER(3) = 0
      WRITE(ITTO,2150)
2150  FORMAT(' Threshold level ? <0,0.0,0> ')
      READ(ITTI,*) NCPLOT(3),OFFSET(3),NUMPEN(3)
      IF(NCPLOT(3).NE.0) THEN
        NUMSTS = NUMSTS + 1
        KPSETS(3) = NUMSTS
      ENDIF
C *
C *  THE FILTERED PATTERN
      KPSETS(4) = 0
      NCPLOT(4) = 0
      OFFSET(4) = 0.0
      NUMPEN(4) = 0
      MARKER(4) = 0
      WRITE(ITTO,2160)
2160  FORMAT(' Smoothed data ? <0,0.0,0> ')
      READ(ITTI,*) NCPLOT(4),OFFSET(4),NUMPEN(4)
      IF(NCPLOT(4).NE.0) THEN
        NUMSTS = NUMSTS + 1
        KPSETS(4) = NUMSTS
      ENDIF
C *
C *  PEAK LOCATION MARKERS
      KPSETS(5) = 0
      NCPLOT(5) = 0
      OFFSET(5) = 0.0
      NUMPEN(5) = 0
      MARKER(5) = 2
      WRITE(ITTO,2170)
2170  FORMAT(' Peak location markers ? <0,0.0,0> ')
      READ(ITTI,*) NCPLOT(5),OFFSET(5),NUMPEN(5)
      IF(NCPLOT(5).NE.0) THEN
        NCPLOT(5) = 1
        NUMSTS = NUMSTS + 1
        KPSETS(5) = NUMSTS
      ENDIF
C *
C *  THE AXIS INFORMATION
C *
      WRITE(ITTO,2265)
2265  FORMAT(/,' Number of plots per page ? (1 OR 2) <1> ')
      READ(ITTI,*) NPLOTS
      IF(NPLOTS.EQ.0) NPLOTS = 1
      IF( NPLOTS.LT.-2 .OR. NPLOTS.GT.2 ) NPLOTS = 1
      DPI = 2.0
      IF(NPLOTS.LT.0) THEN
        WRITE(ITTO,2266)
2266    FORMAT(' Degrees per inch for two-theta axis ? <2.0> ')
        READ(ITTI,*) DPI
        IF(DPI.LE.0.0) DPI = 2.0
      ENDIF
      WRITE(ITTO,2270)
2270  FORMAT(' Draw the axis system ? <Y> ')
      READ(ITTI,1030) QANS
      IAXIS = 0
      IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) IAXIS = 1
      WRITE(ITTO,2280)
2280  FORMAT(' Full scale value for plot ? <1200.0> ')
      FS = 1200.0
      READ(ITTI,*) FS
      IF(FS.LE.0.0) FS = 1200.0
C *
C *  WRITE THE INITIAL INFORMATION TO THE PLOT FILE
3000  KYID = 0
      IF(KPTYPE.EQ.0) THEN
        WRITE(IOPL) QFTITL
        WRITE(IOPL) STRT,FINS,FAINC
        WRITE(IOPL) NUMSTS,NPLOTS,IAXIS,DPI,FS,KYID
        DO 3010 I=1,5
        IF(KPSETS(I).EQ.0) GO TO 3010
        WRITE(IOPL) QTITLS(I),NCPLOT(I),OFFSET(I),NUMPEN(I),MARKER(I)
3010    CONTINUE
       ELSE
        WRITE(IOPL,3020) QFTITL
3020    FORMAT(A80)
        WRITE(IOPL,3030) STRT,FINS,FAINC
3030    FORMAT(3F10.4)
        WRITE(IOPL,3040) NUMSTS,NPLOTS,IAXIS,DPI,FS,KYID
3040    FORMAT(3I6,F6.2,2I6)
        DO 3050 I=1,5
        IF(KPSETS(I).EQ.0) GO TO 3050
        WRITE(IOPL,3060) QTITLS(I),NCPLOT(I),OFFSET(I),NUMPEN(I),
     1  MARKER(I)
3060    FORMAT(A20,I6,F6.2,2I6)
3050    CONTINUE
       ENDIF
C *
C *  THATS IT
9000  RETURN
      END
C ***  DGFILT - DIGITAL FILTERING
C *
C *  ALGORITHM ADAPTED FROM:
C *
C *   M. U. A. BROMBA AND H. ZIEGLER, ANAL CHEMISTRY,
C *   VOL. 51, NO. 11 SEPTEMBER 1979
C *
C *  CODED BY:  S.A. HOWARD
C *             UNIVERSITY OF MISSOURI- ROLLA
C *
C *  YOBS  - INPUT DATA ARRAY TO BE SMOOTHED
C *  DTOUT - OUTPUT SMOOTHED DATA ARRAY
C *  NDATA - NUMBER OF DATA POINTS IN ARRAYS
C *  M     - FILTER MOMENT: 0, 2 OR 4 ORDER
C *  NF    - FULL WIDTH OF SMOOTHING FILTER
C *
      SUBROUTINE DGFILT( M, NF )
C *
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      COMMON /COMSCR/ IK(MPTS), IL(MPTS)
C *
C *  APPLY THE DIGITAL FILTER TO THE DATA
C *
C *  CALCULATE THE NORMALIZING INTEGER DENOMINATORS AND STARTING PTS
1700  N = NF / 2
      NT2 = N * 2
      IF(M.EQ.0) THEN
        IMULT = NT2 + 1
        KSTART = N + 1 + 1
      ENDIF
      IF(M.EQ.2) THEN
        IMULT = (NT2-1) * (NT2+1) * (NT2+3) / 3
        KSTART = N + 3 + 1
      ENDIF
      IF(M.EQ.4) THEN
        IMULT = 4 * (NT2-3)*(NT2-1)*(NT2+1)*(NT2+3)*(NT2+5) / 15
        KSTART = N + 5 + 1
      ENDIF
C *
C *  COMPUTE LIMITS OF FILTER APPLICATION TO DATA ARRAY
      KINIT = KSTART + N
      KEND = KOBS - N
C *
C *  MOVE DATA INTO INTEGER ARRAY
      DO 1710 K=1,KOBS
1710  IK(K) = NINT( YOBS(K) )
C *
C *  INITIALIZE THE FILTER
      IKK = IK(KINIT)
      ILL = IKK * IMULT
      DO 1715 K=1,KINIT-1
      IK(K) = IKK
      IL(K) = ILL
1715  CONTINUE
      IL(KINIT) = ILL
C *
C *  APPLY THE DIGITAL FILTER TO THE DATA
      IF(M.EQ.2) GO TO 1730
      IF(M.EQ.4) GO TO 1740
C *
C *  APPLY ZERO ORDER FILTER
1720  DO 1725 K=KSTART,KEND
1725  IL(K) = IL(K-1) + ( IK(K+N) - IK(K-N-1) )
      GO TO 1750
C *
C *  APPLY SECOND ORDER FILTER
1730  NT2M1 = NT2 - 1
      NM1 = N - 1
      NT2P3 = NT2 + 3
      NP2 = N + 2
      N0 = NT2M1 * NM1
      N1 = NT2P3 * NT2M1
      N2 = NT2P3 * NP2
      DO 1735 K=KSTART,KEND
      I1 =        IL(K-3)
      I2 =  3 * ( IL(K-2)   - IL(K-1)   )
      I3 = N0 * ( IK(K+N)   - IK(K-N-3) )
      I4 = N1 * ( IK(K+N-1) - IK(K-N-2) )
      I5 = N2 * ( IK(K+N-2) - IK(K-N-1) )
      IL(K) = I1 - I2 - I3 + I4 - I5
1735  CONTINUE
      GO TO 1750
C *
C *  APPLY FOURTH ORDER FILTER
1740  NT2M1 = NT2 - 1
      NT2M3 = NT2 - 3
      NM2 = N - 2
      NM1 = N - 1
      NT2P5 = NT2 + 5
      NT2M4 = NT2 - 4
      NT2S6N = 6 * N * N + 6 * N - 22
      NT2P6 = NT2 + 6
      NT2P3 = NT2 + 3
      NP3 = N + 3
      NP2 = N + 2
      N0 = NT2M1 * NT2M3 * NM2 * NM1 * 2
      N1 = NT2P5 * NT2M1 * NT2M3 * NT2M4 * 2
      N2 = NT2P5 * NT2M3 * NT2S6N * 2
      N3 = NT2P6 * NT2P5 * NT2P3 * NT2M3 * 2
      N4 = NT2P5 * NT2P3 * NP3 * NP2 * 2
      DO 1745 K=KSTART,KEND
      I1 =        IL(K-5)
      I2 =  5 * ( IL(K-4)   - IL(K-1)   )
      I3 = 10 * ( IL(K-3)   - IL(K-2)   )
      I4 = N0 * ( IK(K+N)   - IK(K-N-5) )
      I5 = N1 * ( IK(K+N-1) - IK(K-N-4) )
      I6 = N2 * ( IK(K+N-2) - IK(K-N-3) )
      I7 = N3 * ( IK(K+N-3) - IK(K-N-2) )
      I8 = N4 * ( IK(K+N-4) - IK(K-N-1) )
      IL(K) = I1 - I2 + I3 + I4 - I5 + I6 - I7 + I8
1745  CONTINUE
C *
C *  COMPUTE SMOOTHED VALUES... ONLY IN SMOOTHED REGION
1750  FMULT = 1.0 / REAL( IMULT )
      DO 1760 K=KSTART,KEND
1760  YSYN(K) = REAL( IL(K) ) * FMULT
C *
C *  FILL GAPS AT BEGINING AND END OF SMOOTHED INTERVAL
      DO 1770 K=1,KINIT
1770  YSYN(K) = YOBS(K)
      DO 1780 K=KEND+1,KOBS
1780  YSYN(K) = YOBS(K)
C *
C *  RETURN... DATA FILTERED
1900  RETURN
      END
      SUBROUTINE SVGOLY( NSMO, INDEX )
C
C
C PROGRAMMER: C.L. MALLORY
C             ALFRED UNIVERSITY
C
C ROUTINE TO PERFORM A SMOOTHING FUNCTION AS DESCRIBED BY
C SAVITZKY AND GOLAY, ANAL. CHEM., VOL36, 8, 1627 (1964) AND AS MODIFIED
C STEINIER, TREMONIA, AND DELTOUR, ANAL. CHEM., VOL44, 11, 1909 (1972)
C
C NOTE **  IT WILL ONLY PERFORM THE 2ND & 3RD SMOOTH AND THE 2ND & 3RD D
C          SINCE THAT IS ALL I PLUGGED INTO THE MACHINE.
C
C ARGUMENT DEFINITION:
C YRAW - RAW DATA ARRAY.
C YSMO -  RETURNED, EITHER SMOOTHED OR DERIV. DATA.
C NPTS - THE NUMBER OF POINTS IN THE YRAW ARRAY
C NSMO - THE NUMBER OF POINTS TO USE IN SMOOTHING, ODD.
C INDEX - INDICATION OF WHAT IS TO BE PERFORMED.
C         0 - PERFORM THE SMOOTHING FUNCTION.
C         1 - PERFORM THE DERIVATIVE FUNCTION.
C
C
C VARIABLE DEFINITION:
C ICON - ARRAY HOLDING THE CONVOLUTING INTEGERS USED IN SMOOTHING.
C ID2 - ARRAY HOLDING THE SECOND DERIVATIVE CONVOLUTING INTEGERS.
C RNORMS - ARRAY HOLDING THE VALUES OF THE SMOOTHING NORM.
C RNORMD - ARRAY HOLDING THE VALUES OF THE DERIVATIVE NORM.
C
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS)
      DIMENSION ICON(13,11),ID2(13,11),RNORMS(11),RNORMD(11)
C
      DATA ICON/-3,12,17,0,0,0,0,0,0,0,0,0,0,
     1  -2,3,6,7,0,0,0,0,0,0,0,0,0,
     1  -21,14,39,54,59,0,0,0,0,0,0,0,0,
     1  -36,9,44,69,84,89,0,0,0,0,0,0,0,
     1  -11,0,9,16,21,24,25,0,0,0,0,0,0,
     1  -78,-13,42,87,122,147,162,167,0,0,0,0,0,
     1  -21,-6,7,18,27,34,39,42,43,0,0,0,0,
     1  -136,-51,24,89,144,189,224,249,264,269,0,0,0,
     1  -171,-76,9,84,149,204,249,284,309,324,329,0,0,
     1  -42,-21,-2,15,30,43,54,63,70,75,78,79,0,
     1  -253,-138,-33,62,147,222,287,343,387,422,447,462,467/
C
      DATA ID2/2,-1,-2,0,0,0,0,0,0,0,0,0,0,
     1  5,0,-3,-4,0,0,0,0,0,0,0,0,0,
     1  28,7,-8,-17,-20,0,0,0,0,0,0,0,0,
     1  15,6,-1,-6,-9,-10,0,0,0,0,0,0,0,
     1  22,11,2,-5,-10,-13,-14,0,0,0,0,0,0,
     1  91,52,19,-8,-29,-44,-53,-56,0,0,0,0,0,
     1  40,25,12,1,-8,-15,-20,-23,-24,0,0,0,0,
     1  51,34,19,6,-5,-14,-21,-26,-29,-30,0,0,0,
     1  190,133,82,37,-2,-35,-62,-83,-98,-107,-110,0,0,
     1  77,56,37,20,5,-8,-19,-28,-35,-40,-43,-44,0,
     1  92,69,48,29,12,-3,-16,-27,-36,-43,-48,-51,-52/
C
      DATA RNORMS/35.,21.,231.,429.,143.,1105.,323.,
     1  2261.,3059.,805.,5175./
C
      DATA RNORMD/7.,42.,462.,429.,1001.,6188.,3876.,6783.,
     1  33649.,17710.,26910./
C
C THE PROGRAM CAN ONLY HANDLE FROM A 5 TO 25 POINT SMOOTH.
C MAKE SURE THAT THE NUMBERS ARE INSIDE THESE LIMITS.
C ALSO MAKE THE NUMBER AN ODD NUMBER IF IT ISN'T.
      NPT = (NSMO/2) * 2 + 1
      IF(NPT.LT. 5) NPT = 5
      IF(NPT.GT.25) NPT = 25
C *
C GENERATE ARRAY POINTERS.
      N = NPT / 2
      N1 = N - 1
      N2 = N + 1
      K = NPT - 1
      NPNT = N + 1
      NFINI = KOBS - 2 * N
C *
C PERFORM THE DESIRED FUNCTION.
      IF(INDEX.EQ.1) GO TO 20
C *
C SMOOTH THE DATA.
      DO 10 INDY =1,NFINI
      K = NPT - 1
      SUM = 0.0
      DO 15 I=1,N
      IP = INDY + I - 1
      SUM = SUM + ICON(I,N1) * ( YOBS(IP) + YOBS(IP+K) )
      K = K - 2
15    CONTINUE
      YSYN(NPNT) = ( SUM + ICON(N2,N1) * YOBS(IP+N2) ) / RNORMS(N1)
      NPNT = NPNT + 1
10    CONTINUE
      GO TO 30
C *
C PERFORM THE DERIVATIVE FUNCTION.
20    DO 21 INDY=1,NFINI
      K = NPT - 1
      SUM = 0.0
      DO 25 I=1,N
      IP = INDY + I - 1
      SUM = SUM + ID2(I,N1) * ( YOBS(IP) + YOBS(IP+K) )
      K = K - 2
25    CONTINUE
      YSYN(NPNT) = ( SUM + ID2(N2,N1) * YOBS(IP+N2) ) / RNORMD(N1)
      NPNT = NPNT + 1
21    CONTINUE
C *
C *  THATS IT...
30    RETURN
      END
