C ***  PROGRAM: SHADOW  (SHADOW33)
C ***  VERSION: 860822  (YYMMDD)
C *
C ***  PRMOUT - OUTPUT THE LEAST-SQUARES RESULTS
C *
      SUBROUTINE PRMOUT
C *
      CHARACTER QB*1,QS*1,QSTRNG*34,QSTRNU*34,QPARMU*10,QVOIGT*34
      PARAMETER ( MEMV = 32, MPTS = 2048 )
      PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 )
      PARAMETER ( QSTRNG = ' LINE  REF  POSITION   INTENSITY  ' )
      PARAMETER ( QSTRNU = ' ----  ---  --------   ---------  ' )
      PARAMETER ( QVOIGT = ' LINE  REF  POSITION     IG*IC    ' )
      PARAMETER ( QPARMU = '--------  ' )
      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 /MODEOP/ KMODEO,KSAMEP,KAUTOP
      COMMON /OPTRES/ RERR,RESID,ICON,ITER
      COMMON /PDATA/ BANG, EANG
      DIMENSION PINTIN(201),SIGCRY(2)
C *
1400  WRITE(ITTO,1401)
1401  FORMAT(/,' * Refined parameters (with a *) and estimated sigmas:')
C *
C *  SET UP OUTPUT HEADER BASED ON PROFILE TYPE
      QB = ' '
      QS = '*'
      IK = IABS( KPROF )
      IF(IK.EQ.1) WRITE(ITTO,1405) QSTRNG,QSTRNU, QPARMU
      IF(IK.EQ.2) WRITE(ITTO,1405) QSTRNG,QSTRNU, QPARMU
      IF(IK.EQ.3) WRITE(ITTO,1405) QSTRNG,QSTRNU, QPARMU
      IF(IK.EQ.4) WRITE(ITTO,1410) QSTRNG,QSTRNU,(QPARMU,J=1,2)
      IF(IK.EQ.5) WRITE(ITTO,1405) QSTRNG,QSTRNU, QPARMU
      IF(IK.EQ.6) WRITE(ITTO,1415) QVOIGT,QSTRNU,(QPARMU,J=1,2)
      IF(IK.EQ.7) WRITE(ITTO,1420) QSTRNG,QSTRNU,(QPARMU,J=1,4)
CDEL      IF(IK.EQ.8) WRITE(ITTO,1425) QSTRNG,QSTRNU,(QPARMU,J=1,2)
      IF(IK.EQ.8) WRITE(ITTO,1425) QSTRNG,QSTRNU, QPARMU
      IF(IK.EQ.9) WRITE(ITTO,1430) QSTRNG,QSTRNU,(QPARMU,J=1,8)
      IF(IK.EQ.10)WRITE(ITTO,1430) QSTRNG,QSTRNU,(QPARMU,J=1,8)
      IF(IK.EQ.11)WRITE(ITTO,1430) QSTRNG,QSTRNU,(QPARMU,J=1,8)
      IF(IK.EQ.12)WRITE(ITTO,1430) QSTRNG,QSTRNU,(QPARMU,J=1,8)
      IF(IK.EQ.13)WRITE(ITTO,1430) QSTRNG,QSTRNU,(QPARMU,J=1,8)
      IF(IK.EQ.14)WRITE(ITTO,1406) QSTRNG,QSTRNU, QPARMU
      IF(IK.EQ.15)WRITE(ITTO,1406) QSTRNG,QSTRNU, QPARMU
      IF(IK.EQ.16)WRITE(ITTO,1407) QSTRNG,QSTRNU, QPARMU, QPARMU
1405  FORMAT(/,A34,'  FWHM  ',/,A34,A10)
1406  FORMAT(/,A34,'  BETA  ',/,A34,A10)
1407  FORMAT(/,A34,' BETA L    BETA G ',/,A34,2A10)
1410  FORMAT(/,A34,'  FWHM       EXP  ',/,A34,2A10)
1415  FORMAT(/,A34,' BETA-G    BETA-C ',/,A34,2A10)
1420  FORMAT(/,A34,'  FWHM F    EXP F     FWHM B    EXP B  ',
     1       /,A34,4A10)
CDEL1425  FORMAT(/,A34,' FWHM A1   FWHM A2 ',/,A34,2A10)
1425  FORMAT(/,A34,'FWHM A12',/,A34,A10)
1430  FORMAT(/,A34,' FW F A1   EX F A1   FW B A1   EX B A1 ',
     1 '  FW F A2   EX F A2   FW B A2   EX B A2',/,A34,8A10)
C *
C *  LIST FINAL LINE PARAMETERS...
1600  NS = NVECS + 1
      PKMAX = 0.0
      DO 1610 I=1,KNLIN
      NW = KRLIN(I)
      NE = NS + KNPRM - 1
      TT = PLPRM(I,1) + CORPOS( PLPRM(I,1) )
      Y0 = PLPRM(I,2) / FTIME
      BVECS(NS+1) = BVECS(NS+1) / FTIME
      IF(PKMAX.LT.PLPRM(I,2)) PKMAX = PLPRM(I,2)
      IF( IK.LT.9 .OR. IK.GT.15 )GO TO 1630
C *
      IF(IK.EQ.10) THEN
        WRITE(ITTO,1620) I,NW,TT,Y0,(PLPRM(I,J),QS,J=3,7),
     1  PLPRM(I,4),QB,PLPRM(I,9),QS,PLPRM(I,6),QB
1620    FORMAT(1X,'#',I3,2X,I3,2X,F8.4,'*',1X,F10.4,'*',8(1X,F8.5,A1))
        WRITE(ITTO,1640) (BVECS(J),J=NS,NE)
1640    FORMAT(7X,'ESD',2X,F8.4,2X,F10.4,1X,7(1X,F8.5,1X),10X,1X,F8.5)
        GO TO 1690
      ENDIF
C *
      IF(IK.EQ.11) THEN
        WRITE(ITTO,1620) I,NW,TT,Y0,(PLPRM(I,J),QS,J=3,6),
     1  (PLPRM(I,J),QB,J=3,6)
        WRITE(ITTO,1642) (BVECS(J),J=NS,NE)
1642    FORMAT(7X,'ESD',2X,F8.4,2X,F10.4,1X,6(1X,F8.5,1X))
        GO TO 1690
      ENDIF
C *
      IF(IK.EQ.12) THEN
        TX1 = FNFWHM( PLPRM(I,1), 1 )
        TX2 = FNFWHM( PLPRM(I,1), 2 )
        WRITE(ITTO,1620) I,NW,TT,Y0,TX1,QB,PLPRM(I,3),QS,
     1  TX2,QB,PLPRM(I,4),QS,TX1,QB,PLPRM(I,3),QB,
     1  TX2,QB,PLPRM(I,4),QB
        WRITE(ITTO,1644) (BVECS(J),J=NS,NE)
1644    FORMAT(7X,'ESD',2X,F8.4,2X,F10.4,1X,2(1X,8X,1X,1X,F8.5,1X))
        GO TO 1690
      ENDIF
C *
      IF(IK.EQ.13) THEN
        PLPRM(I,3) = FNFWHM( PLPRM(I,1), 1 )
        PLPRM(I,4) = FNSHAP( PLPRM(I,1), 1 )
        PLPRM(I,5) = FNFWHM( PLPRM(I,1), 2 )
        PLPRM(I,6) = FNSHAP( PLPRM(I,1), 2 )
        WRITE(ITTO,1620) I,NW,TT,Y0,(PLPRM(I,J),QB,J=3,6),
     1  (PLPRM(I,J),QB,J=3,6)
        WRITE(ITTO,1644) (BVECS(J),J=NS,NE)
        GO TO 1690
      ENDIF
C *
      IF( IK.EQ.14 .OR. IK.EQ.15 ) THEN
        IF(KCRYS.EQ.0) THEN
          WRITE(ITTO,1635) I,NW,TT,Y0,PLPRM(I,3),QS
          WRITE(ITTO,1636) (BVECS(J),J=NS,NE)
         ELSE
          WRITE(ITTO,1635) I,NW,TT,Y0,PLPRM(I,3),QB
          WRITE(ITTO,1636) (BVECS(J),J=NS,NE)
        ENDIF
        GO TO 1690
      ENDIF
C *
1630  WRITE(ITTO,1635) I,NW,TT,Y0,(PLPRM(I,J),QS,J=3,KNPRM)
1635  FORMAT(1X,'#',I3,2X,I3,2X,F8.4,'*',F11.4,'*',8(1X,F8.5,A1))
      WRITE(ITTO,1636) (BVECS(J),J=NS,NE)
1636  FORMAT(7X,'ESD',2X,F8.4,1X,F11.4,1X,8(1X,F8.5,1X))
C *
C *  ADJUST OFFSETS FOR POSITIVE-TYPE PROFILES
1690  IF(KPROF.GT.0) THEN
        NS = NS + KNPRM
      ENDIF
C *
C *  ADJUST OFFSETS FOR NEGATIVE-TYPE PROFILES
      IF(KPROF.LT.0) THEN
        NP = NVECS + KNPRM + (I-1)*2 + 1
        IF(I.LT.KNLIN) THEN
          BVECS(NVECS+1) = BVECS(NP)
          BVECS(NVECS+2) = BVECS(NP+1)
          QS = QB
         ELSE
          NS = NP
        ENDIF
      ENDIF
C *
1610  CONTINUE
C *
C **  GET SIGMAS FOR MISC PARAMETERS
C *
      IF(KBKGR.EQ.1.OR.KBKGR.EQ.3) THEN
        SIGBKG = BVECS(NS)
        NS = NS + 1
      ENDIF
C *
      IF(KASYM.NE.0) THEN
        SIGASY = BVECS(NS)
        NS = NS + 1
      ENDIF
C *
      IF(KAMOR.NE.0) THEN
        SIGAM1 = BVECS(NS)
        SIGAM2 = BVECS(NS+1)
        SIGAM3 = BVECS(NS+2)
        NS = NS + 3
      ENDIF
C *
      IF(KCRYS.EQ.1.OR.KCRYS.EQ.3) THEN
        SIGCRY(1) = BVECS(NS)
        NS = NS + 1
      ENDIF
C *
      IF(KCRYS.EQ.2.OR.KCRYS.EQ.3) THEN
        SIGCRY(2) = BVECS(NS)
        NS = NS + 1
      ENDIF
C *
C **  GET THE INTEGRATED INTENSITIES FOR EACH PROFILE
C *
C *  SET THE NUMBER OF POINTS TO 2047
2000  ANCOPY = YANG(1)
      NDCOPY = KOBS
      KOBS = 2047
      PIMAX = 0.0
C *
C *  REPEAT INTEGRATION FOR EACH PROFILE IN THE LIST
      DO 2310 I=1,KNLIN
C *
C *  SET LINE POSITION TO CENTER OF YANG AND COPY OLD POSITION
      ANGLE = PLPRM(I,1) - 1024.0*FAINC - FAINC
      DO 2015 J=1,KOBS
2015  YANG(J) = ANGLE + REAL(J) * FAINC
      BANG = YANG(1)
      EANG = YANG(KOBS)
C *
C *  GENERATE THE LINE AND GET THE INTEGRATED AREA
      CALL SHADOW( YSYN, I, IDUM1, IDUM2 )
      CALL SINTGR( AREA )
      PINTIN(I) = AREA
      IF(AREA.GT.PIMAX) PIMAX = AREA
2310  CONTINUE
C *
C *  INTEGRATE THE AMORPHOUS PROFILE
      IF(KAMOR.EQ.0) GO TO 2390
C *
C *  SET LINE POSITION TO CENTER OF YANG
      ANGLE = AMOPAR(1) - 1024.0*FAINC - FAINC
      DO 2340 J=1,KOBS
2340  YANG(J) = ANGLE + REAL(J) * FAINC
      BANG = YANG(1)
      EANG = YANG(KOBS)
C *
C *  GENERATE THE LINE AND INTEGRATE THE AREA
      CALL SHADOW( YSYN, -1, IDUM1, IDUM2 )
      CALL SINTGR( AREA )
      PINTIN(KNLIN+1) = AREA
C *
C *  RESET THE YANG ARRAY AND ASSOCIATED FLAGS
2390  KOBS = NDCOPY
      ANCOPY = ANCOPY - FAINC
      DO 2395 J=1,KOBS
2395  YANG(J) = ANCOPY + REAL(J) * FAINC
      BANG = YANG(1)
      EANG = YANG(KOBS)
C *
C **  STATISTICS FOR EACH PROFILE
C *
2300  WRITE(ITTO,2305)
2305  FORMAT(//' * Line statistics:',//,
     1 ' Line   Start     Finish   R error  R exptd  Int Int ',
     1 '  Rel Int   Rel Pk I',/,
     1 ' ----  --------  --------  -------  -------  --------',
     1 '  --------  --------')
C *
C *  GENERATE THE FULL PATTERN
1200  CALL SHADOW( YSYN, 999, IDUM1, IDUM2 )
C *
C *  ADD BKG + CALC INTENSITIES, DETERMINE GOODNESS OF FIT
      SERR = 0.0
      DO 1202 I=1,KOBS
      YSYN(I) = YSYN(I) + YBKG(I)
      SERR = SERR + (1.0/AMAX1(1.0,YOBS(I))) * (YSYN(I)-YOBS(I))**2
1202  CONTINUE
      SERR = SQRT( SERR / REAL( KOBS - NVECS ) )
C *
C *  DETERMINE RELATIVE INTENSITES, RANGE, AND ERRORS
      PIMAX = 100.0 / PIMAX
      PKMAX = 100.0 / PKMAX
      DO 1210 I0=1,KNLIN+1
      IF( I0.GT.KNLIN .AND. KAMOR.EQ.0 ) GO TO 1210
      IHI = KLLIN(I0)/16384
      ILO = KLLIN(I0) - IHI*16384
      RN = 0.0
      RD = 0.0
      RE = 0.0
      DO 1220 I1=ILO,IHI
      RN = RN + ( YSYN(I1) - YOBS(I1) )**2
      RE = RE + ( 3.0 * SQRT(YOBS(I1)))**2
      RD = RD + YOBS(I1)**2
1220  CONTINUE
      IF(RD.EQ.0.0) THEN
        R = 1.0
        RE = 1.0
       ELSE
        R = SQRT( RN / RD )
        RE = SQRT( RE / RD )
      ENDIF
      SA = YANG( ILO )
      SE = YANG( IHI )
      RINTI = PINTIN(I0) * PIMAX
      IF(I0.GT.KNLIN) THEN
        RPKI = AMOPAR(2) * PKMAX
        WRITE(ITTO,1250)    SA,SE,R,RE,PINTIN(I0)/FTIME,RINTI,RPKI
1250    FORMAT(1X,'Amor',2X,2(F8.4,2X),2(F7.6,2X),3(F8.2,2X))
       ELSE
        RPKI = PLPRM(I0,2) * PKMAX
        WRITE(ITTO,1230) I0,SA,SE,R,RE,PINTIN(I0)/FTIME,RINTI,RPKI
1230    FORMAT(1X,I4    ,2X,2(F8.4,2X),2(F7.6,2X),3(F8.2,2X))
      ENDIF
1210  CONTINUE
C *
C **  WRITE MISC INFO
C *
1700  IF(KBKGR.EQ.0) WRITE(ITTO,1720)
1720  FORMAT(/,' Background assumed = 0.0000')
      IF(KBKGR.EQ.1.OR.KBKGR.EQ.3) WRITE(ITTO,1721)
     1  BKGPAR/FTIME,SIGBKG/FTIME
1721  FORMAT(/,' Refined background =',F9.4,'  ESD =',F9.4)
      IF(KBKGR.EQ.2) WRITE(ITTO,1722)
1722  FORMAT(/,' Background used from prior evaluation')
      IF(KASYM.EQ.1) WRITE(ITTO,1745) ASYPAR,SIGASY
1745  FORMAT(' Pattern asymmetry factor = ',E13.6,'  ESD = ',F8.4)
      IF(KAMOR.EQ.1) THEN
        POSC = AMOPAR(1) + CORPOS( AMOPAR(1) )
        WRITE(ITTO,1750) POSC,AMOPAR(2)/FTIME,
     1  AMOPAR(3),SIGAM1,SIGAM2/FTIME,SIGAM3
1750    FORMAT(' Amorphous profile parameters: ',
     1  'Pos ',F8.4,'  Hgt ',F8.2,'  FWHM ',F5.2,/,
     1  35X,F8.4,6X,F8.2,7X,F5.2)
      ENDIF
      IF(KCRYS.EQ.1.OR.KCRYS.EQ.3) THEN
        FTEMP1 = CRYPAR(1) * 1.0E09
        FTEMP2 = SIGCRY(1) * 1.0E09
        WRITE(ITTO,1755) FTEMP1,FTEMP2
1755    FORMAT(' Crystallite size (nm) = ',F8.1,'  ESD = ',F8.1)
      ENDIF
      IF(KCRYS.EQ.2.OR.KCRYS.EQ.3) THEN
        WRITE(ITTO,1756) CRYPAR(2),SIGCRY(2)
1756    FORMAT(' Crystallite strain =    ',F8.6,'  ESD = ',F8.6)
      ENDIF
      WRITE(ITTO,1730) RERR*100.0
1730  FORMAT(/,' Residual error  = ',F6.2,' %')
      WRITE(ITTO,1732) SERR
1732  FORMAT(' Goodness of fit = ',F12.6)
      WRITE(ITTO,1735) ITER
1735  FORMAT(' Iterations =              ',I4)
      WRITE(ITTO,1740) ICON
1740  FORMAT(' Convergence parameter =   ',I4)
C *
C *  RETURN
9000  RETURN
      END
