Subroutine LISTPRF for program GSAS2CIF

This subroutine is used to describe the current peak profile function and list parameter values. See the gsas2cif documentation for an explanation of this code.
link to documentation
      SUBROUTINE LISTPRF(IUCIF,NPRF,PTYP,PCOF,LAUE,NAXIS,HTYPE,CTOF)
!Purpose: List powder profile type 1 parameters

      INCLUDE       '../INCLDS/COPYRIGT.FOR' 

!PSEUDOCODE:

!CALLING ARGUMENTS:

      INTEGER*4     IUCIF               !Output file
      INTEGER*4     NPRF                !Number of coefficients
      INTEGER*4     PTYP                !Profile function type
      REAL*4        PCOF(36)            !Profile coefficients
      INTEGER*4     LAUE                !Laue class
      INTEGER*4     NAXIS               !Unique axis for monoclinic
      CHARACTER*4   HTYPE               !histogram type code
      REAL*4        CTOF                !Peak cutoff

!INCLUDE STATEMENTS:

!LOCAL VARIABLES:

      INTEGER*4     NSTR(14)            !No. Shkl strain terms

!SUBROUTINES CALLED:

!FUNCTION DEFINITIONS:

!DATA STATEMENTS:

      DATA  NSTR/15,9,6,5,4, 5,4,5,4,4, 3,3,2,2/

!CODE:

      IF ( HTYPE(2:3).EQ.'NT' ) THEN
        WRITE(IUCIF,'(A,I2,A,I3,A)') ' TOF Profile function number',
     1    PTYP,' with ',NPRF,' terms'
C taken from SUBROUTINE EDTPTP1
        IF ( ABS(PTYP).EQ.1 ) THEN
          NPRF = 12
          WRITE(IUCIF,'(A)') ' Profile coefficients for Von Dreele,',
     1      ' Jorgensen & Windsor convolution function'
          WRITE(IUCIF,'(A)') '  J. Appl. Cryst., 15,581-589(1982)'
          WRITE(IUCIF,'(A)')
     1      '  Modified by Von Dreele - unpublished (1983).'
          WRITE(IUCIF,2) (PCOF(I),I=1,5,2),(PCOF(I),I=2,6,2),PCOF(8),
     1      PCOF(9),PCOF(7),(PCOF(I),I=10,12)
 2        FORMAT(
     1      ' #1(alp-0) = ',F8.4,
     1      ' #3(bet-0) = ',1PE12.4,
     1      ' #5(sig-0) = ',0PF10.3,/,
     1      ' #2(alp-1) = ',F8.4,
     1      ' #4(bet-1) = ',1PE12.4,
     1      ' #6(sig-1) = ',0PF10.3,/,
     1      ' #8(rstr ) = ',F8.3,
     1      ' #9(rsta ) = ',F12.3,
     1      ' #7(sig-2) = ',F10.3,/
     1      ' #10(rsca) = ',F8.3,
     1      ' #11(s1ec) = ',F12.2,
     1      ' #12(s2ec) = ',F10.2)
        ELSE IF ( ABS(PTYP).EQ.2 ) THEN
          NPRF = 15
          WRITE(IUCIF,'(A)') ' Profile coefficients for W.I.F. David',
     1      ' function; a convolution of the'
          WRITE(IUCIF,'(A)')
     1      ' Ikeda-Carpenter and Pseudo-Voight functions'
          WRITE(IUCIF,'(A)')
     1      '  W.I.F. David, J. Appl. Cryst., 19,63-64,(1986)'
          WRITE(IUCIF,'(A)')
     1      '  W.I.F. David - unpublished (1986).'
          WRITE(IUCIF,3) (PCOF(I),PCOF(I+4),
     1      PCOF(I+7),I=1,3),PCOF(4),
     1      (PCOF(I),I=11,15)
 3        FORMAT(        ' #1 (alp-0) = ',F8.4,
     1      ' #5 (sig-0) = ',F8.2,
     1      ' #8 (gam-0) = ',F8.2,/,
     1      ' #2 (alp-1) = ',F8.4,
     1      ' #6 (sig-1) = ',F8.2,
     1      ' #9 (gam-1) = ',F8.2,/,
     1      ' #3 (beta ) = ',F8.2,
     1      ' #7 (sig-2) = ',F8.2,
     1      ' #10(gam-2) = ',F8.2,/,
     1      ' #4(switch) = ',F8.2,
     1      ' #11(ptec ) = ',F8.2,
     1      ' #12(stec ) = ',F8.2,/,
     1      ' #13(difc ) = ',F8.2,
     1      ' #14(difa ) = ',F8.2,
     1      ' #15(zero ) = ',F8.2)
        ELSE IF ( ABS(PTYP).EQ.3 ) THEN
          NPRF = 21
          WRITE(IUCIF,'(A)')' Profile coefficients for exponential'//
     1      ' pseudovoigt'
          WRITE(IUCIF,'(A)')
     1      '  convolution Von Dreele, 1990 (unpublished)'
          WRITE(IUCIF,4)(PCOF(I),I=1,21)
 4        FORMAT(' #1 (alp  ) = ',F8.4,
     1      ' #2 (bet-0) = ',F8.6,
     1      ' #3 (bet-1) = ',F8.6,/,
     1      ' #4 (sig-0) = ',F8.1,
     1      ' #5 (sig-1) = ',F8.1,
     1      ' #6 (sig-2) = ',F8.1,/,
     1      ' #7 (gam-0) = ',F8.2,
     1      ' #8 (gam-1) = ',F8.2,
     1      ' #9 (gam-2) = ',F8.2,/,
     1      ' #10(gsf  ) = ',F8.2,
     1      ' #11(g1ec ) = ',F8.2,
     1      ' #12(g2ec ) = ',F8.2,/,
     1      ' #13(rstr ) = ',F8.3,
     1      ' #14(rsta ) = ',F8.3,
     1      ' #15(rsca ) = ',F8.3,/,
     1      ' #16(L11)   = ',F8.3,
     1      ' #17(L22)   = ',F8.3,
     1      ' #18(L33)   = ',F8.3,/,
     1      ' #19(L12)   = ',F8.3,
     1      ' #20(L13)   = ',F8.3,
     1      ' #21(L23)   = ',F8.3)
        ELSE IF ( ABS(PTYP).EQ.4 ) THEN
          NPRF = 12+NSTR(LAUE)
          WRITE(IUCIF,'(A)') ' Profile coefficients for exponential'//
     1      ' pseudovoigt'
          WRITE(IUCIF,'(A)')
     1      '  convolution Von Dreele, 1990 (unpublished)'
          WRITE(IUCIF,'(A)')
     1      ' Microstrain broadening by P.W. Stephens, '//
     1      ' (1999). J. Appl. Cryst.,32,281-289.'
          WRITE(IUCIF,5) (PCOF(I),I=1,12)
 5        FORMAT(' #1 (alp  ) = ',F8.4,
     1      ' #2 (bet-0) = ',F8.6,
     1      ' #3 (bet-1) = ',F8.6,/,
     1      ' #4 (sig-1) = ',F8.1,
     1      ' #5 (sig-2) = ',F8.1,/,
     1      ' #6 (gam-2) = ',F8.2,
     1      ' #7 (g2ec ) = ',F8.2,
     1      ' #8 (gsf  ) = ',F8.2,/,
     1      ' #9 (rstr ) = ',F8.3,
     1      ' #10(rsta ) = ',F8.3,
     1      ' #11(rsca ) = ',F8.3,/,
     1      ' #12(eta  ) = ',F8.4)
          IF ( LAUE.GE.13) THEN                           !cubic
            WRITE(IUCIF,10)(i,PCOF(I),I=13,NPRF)
 10         FORMAT(' #',i2,'(S400 ) = ',1PE8.1,
     1        ' #',i2,'(S220 ) = ',1PE8.1)
          ELSE IF ( LAUE.EQ.11 .OR. LAUE.EQ.12 ) THEN     !hexagonal
            WRITE(IUCIF,11)(I,PCOF(I),I=13,NPRF)
 11         FORMAT(' #',i2,'(S400 ) = ',1PE8.1,
     1        ' #',i2,'(S004 ) = ',1PE8.1,
     1        ' #',i2,'(S202 ) = ',1PE8.1)
          ELSE IF ( LAUE.EQ.10 ) THEN                     !trigonal 3bar1m
            WRITE(IUCIF,12)(I,PCOF(I),I=13,NPRF)
 12         FORMAT(' #',i2,'(S400 ) = ',1PE8.1,
     1        ' #',i2,'(S004 ) = ',1PE8.1,/,
     1        ' #',i2,'(S202 ) = ',1PE8.1,
     1        ' #',i2,'(S211 ) = ',1PE8.1)
          ELSE IF ( LAUE.EQ.9 ) THEN                      !trigonal 3barm1
            WRITE(IUCIF,13)(I,PCOF(I),I=13,NPRF)
 13         FORMAT(' #',i2,'(S400 ) = ',1PE8.1,
     1        ' #',i2,'(S004 ) = ',1PE8.1,/,
     1        ' #',i2,'(S202 ) = ',1PE8.1,
     1        ' #',i2,'(S301 ) = ',1PE8.1)
          ELSE IF ( LAUE.EQ.8 ) THEN                      !trigonal 3bar
            WRITE(IUCIF,14)(I,PCOF(I),I=13,NPRF)
 14         FORMAT(' #',i2,'(S400 ) = ',1PE8.1,
     1        ' #',i2,'(S004 ) = ',1PE8.1,
     1        ' #',i2,'(S202 ) = ',1PE8.1,/,
     1        ' #',i2,'(S310 ) = ',1PE8.1,
     1        ' #',i2,'(S211 ) = ',1PE8.1)
          ELSE IF ( LAUE.EQ.7 ) THEN                      !rhombohedral 3m
            WRITE(IUCIF,15)(I,PCOF(I),I=13,NPRF)
 15         FORMAT(' #',i2,'(S400 ) = ',1PE8.1,
     1        ' #',i2,'(S220 ) = ',1PE8.1,/,
     1        ' #',i2,'(S310 ) = ',1PE8.1,
     1        ' #',i2,'(S211 ) = ',1PE8.1)
          ELSE IF ( LAUE.EQ.6 ) THEN                      !rhombohedral 3
            WRITE(IUCIF,16)(I,PCOF(I),I=13,NPRF)
 16         FORMAT(' #',i2,'(S400 ) = ',1PE8.1,
     1        ' #',i2,'(S220 ) = ',1PE8.1,
     1        ' #',i2,'(S310 ) = ',1PE8.1,/,
     1        ' #',i2,'(S301 ) = ',1PE8.1,
     1        ' #',i2,'(S211 ) = ',1PE8.1)
          ELSE IF ( LAUE.EQ.5 ) THEN                     !tetragonal 4/mmm
            WRITE(IUCIF,17)(I,PCOF(I),I=13,NPRF)
 17         FORMAT(' #',i2,'(S400 ) = ',1PE8.1,
     1        ' #',i2,'(S004 ) = ',1PE8.1,/,
     1        ' #',i2,'(S220 ) = ',1PE8.1,
     1        ' #',i2,'(S202 ) = ',1PE8.1)
          ELSE IF ( LAUE.EQ.4 ) THEN                      !tetragonal 4/m
            WRITE(IUCIF,18)(I,PCOF(I),I=13,NPRF)
 18         FORMAT(' #',i2,'(S400 ) = ',1PE8.1,
     1        ' #',i2,'(S004 ) = ',1PE8.1,
     1        ' #',i2,'(S220 ) = ',1PE8.1,/,
     1        ' #',i2,'(S202 ) = ',1PE8.1,
     1        ' #',i2,'(S310 ) = ',1PE8.1)
          ELSE IF ( LAUE.EQ.3 ) THEN                      !orthorhombic
            WRITE(IUCIF,19)(I,PCOF(I),I=13,NPRF)
 19         FORMAT(' #',i2,'(S400 ) = ',1PE8.1,
     1        ' #',i2,'(S040 ) = ',1PE8.1,
     1        ' #',i2,'(S004 ) = ',1PE8.1,/,
     1        ' #',i2,'(S220 ) = ',1PE8.1,
     1        ' #',i2,'(S202 ) = ',1PE8.1,
     1        ' #',i2,'(S022 ) = ',1PE8.1)
          ELSE IF ( LAUE.EQ.2 ) THEN                      !monoclinic
            WRITE(IUCIF,19)(I,PCOF(I),I=13,18)
            IF ( NAXIS.EQ.1) THEN
              WRITE(IUCIF,20) (I,PCOF(I),I=19,NPRF)
 20           FORMAT(' #',i2,'(S013 ) = ',1PE8.1,
     1          ' #',i2,'(S031 ) = ',1PE8.1,
     1          ' #',i2,'(S211 ) = ',1PE8.1)
            ELSE IF ( NAXIS.EQ.2 ) THEN
              WRITE(IUCIF,21)(I,PCOF(I),I=19,NPRF)
 21           FORMAT(' #',i2,'(S301 ) = ',1PE8.1,
     1          ' #',i2,'(S103 ) = ',1PE8.1,
     1          ' #',i2,'(S121 ) = ',1PE8.1)
            ELSE
              WRITE(IUCIF,22)(I,PCOF(I),I=19,NPRF)
 22           FORMAT(' #',i2,'(S130 ) = ',1PE8.1,
     1          ' #',i2,'(S310 ) = ',1PE8.1,
     1          ' #',i2,'(S112 ) = ',1PE8.1)
            END IF
          ELSE IF ( LAUE.EQ.1 ) THEN                      !triclinic
            WRITE(IUCIF,19)(I,PCOF(I),I=13,18)
            WRITE(IUCIF,23)(I,PCOF(I),I=19,NPRF)
 23         FORMAT(' #',i2,'(S310 ) = ',1PE8.1,
     1        ' #',i2,'(S103 ) = ',1PE8.1,
     1        ' #',i2,'(S031 ) = ',1PE8.1,/,
     1        ' #',i2,'(S130 ) = ',1PE8.1,
     1        ' #',i2,'(S301 ) = ',1PE8.1,
     1        ' #',i2,'(S013 ) = ',1PE8.1,/,
     1        ' #',i2,'(S211 ) = ',1PE8.1,
     1        ' #',i2,'(S121 ) = ',1PE8.1,
     1        ' #',i2,'(S112 ) = ',1PE8.1)
          END IF
        ELSE
          WRITE(IUCIF,'(A)') ' Profile option not installed.'
          WRITE(IUCIF,'(A)') ' This is an error & should not happen!'
        END IF
      ELSE IF ( HTYPE(2:3).EQ.'NC' .OR. HTYPE(2:3).EQ.'XC' ) THEN
C taken from SUBROUTINE EDTPTP3
        WRITE(IUCIF,'(A,I2,A,I3,A)') ' CW Profile function number',
     1    PTYP,' with ',NPRF,' terms'
        IF ( PTYP.EQ.1 ) THEN
          NPRF = 6
          WRITE(IUCIF,'(A)')
     1      ' Profile coefficients for Simpson''s rule'//
     1      ' integration of Gaussian function'
          WRITE(IUCIF,'(A)')
     1      ' C.J. Howard (1982). J. Appl. Cryst.,15,615-620.'
          WRITE(IUCIF,'(A)')
     1      ' Cooper & Sayer, J. Appl. Cryst., 8, 615-618'//
     1      ' (1975).'
          WRITE(IUCIF,'(A)')
     1      ' Thomas, J. Appl. Cryst., 10, 12-13(1977).'
          WRITE(IUCIF,32)(PCOF(I),I=1,6)
 32       FORMAT(        ' #1(U)    = ',F8.3,
     1      ' #2(V)    = ',F8.3,
     1      ' #3(W)    = ',F8.3,/,
     1      ' #4(asym) = ',F8.4,
     1      ' #5(F1)   = ',F8.3,
     1      ' #6(F2)   = ',F8.3)
        ELSE IF ( PTYP.EQ.2 ) THEN
          NPRF = 18
          WRITE(IUCIF,'(A)')
     1      ' Profile coefficients for Simpson''s rule'//
     1      ' integration of pseudovoigt function'
          WRITE(IUCIF,'(A)')
     1      ' C.J. Howard (1982). J. Appl. Cryst.,15,615-620.'
          WRITE(IUCIF,'(A)')
     1      ' P. Thompson, D.E. Cox & J.B. Hastings (1987).'//
     1      ' J. Appl. Cryst.,20,79-83.'
          WRITE(IUCIF,33)(PCOF(I),I=1,18)
 33       FORMAT(        ' #1(GU)   = ',F8.3,
     1      ' #2(GV)   = ',F8.3,
     1      ' #3(GW)   = ',F8.3,/,
     1      ' #4(LX)   = ',F8.3,
     1      ' #5(LY)   = ',F8.3,
     1      ' #6(trns) = ',F8.3,/,
     1      ' #7(asym) = ',F8.4,
     1      ' #8(shft) = ',F8.4,
     1      ' #9(GP)   = ',F8.3,/,
     1      ' #10(stec)= ',F8.2,
     1      ' #11(ptec)= ',F8.2,
     1      ' #12(sfec)= ',F8.2,/,
     1      ' #13(L11) = ',F8.3,
     1      ' #14(L22) = ',F8.3,
     1      ' #15(L33) = ',F8.3,/,
     1      ' #16(L12) = ',F8.3,
     1      ' #17(L13) = ',F8.3,
     1      ' #18(L23) = ',F8.3)
        ELSE IF ( PTYP.EQ.3 ) THEN
          NPRF = 19
          WRITE(IUCIF,'(A)') ' Pseudovoigt profile coefficients as'//
     1      ' parameterized in'
          WRITE(IUCIF,'(A)')
     1      ' P. Thompson, D.E. Cox & J.B. Hastings (1987).'//
     1      ' J. Appl. Cryst.,20,79-83.'
          WRITE(IUCIF,'(A)')
     1      ' Asymmetry correction of L.W. Finger, D.E.'//
     1      ' Cox & A. P. Jephcoat (1994).',
     1      ' J. Appl. Cryst.,27,892-900.'
          WRITE(IUCIF,34)(PCOF(I),I=1,19)
 34       FORMAT(' #1(GU)   = ',F8.3,
     1      ' #2(GV)   = ',F8.3,
     1      ' #3(GW)   = ',F8.3,/,
     1      ' #4(GP)   = ',F8.3,
     1      ' #5(LX)   = ',F8.3,
     1      ' #6(LY)   = ',F8.3,/,
     1      ' #7(S/L)  = ',F8.4,
     1      ' #8(H/L)  = ',F8.4,/,
     1      ' #9(trns) = ',F8.2,
     1      ' #10(shft)= ',F8.4,/,
     1      ' #11(stec)= ',F8.2,
     1      ' #12(ptec)= ',F8.2,
     1      ' #13(sfec)= ',F8.2,/
     1      ' #14(L11) = ',F8.3,
     1      ' #15(L22) = ',F8.3,
     1      ' #16(L33) = ',F8.3,/,
     1      ' #17(L12) = ',F8.3,
     1      ' #18(L13) = ',F8.3,
     1      ' #19(L23) = ',F8.3)
        ELSE IF ( PTYP.EQ.4 ) THEN     
          NPRF = 12+NSTR(LAUE)
          WRITE(IUCIF,'(A)')
     1      ' Pseudovoigt profile coefficients as'//
     1      ' parameterized in'
          WRITE(IUCIF,'(A)')
     1      ' P. Thompson, D.E. Cox & J.B. Hastings (1987).'//
     1      ' J. Appl. Cryst.,20,79-83.'
          WRITE(IUCIF,'(A)')
     1      ' Asymmetry correction of L.W. Finger, D.E.'//
     1      ' Cox & A. P. Jephcoat (1994).',
     1      ' J. Appl. Cryst.,27,892-900.'
          WRITE(IUCIF,'(A)')
     1      ' Microstrain broadening by P.W. Stephens, '//
     1      ' (1999). J. Appl. Cryst.,32,281-289.'
          WRITE(IUCIF,35)(PCOF(I),I=1,12)
 35       FORMAT(' #1(GU)   = ',F8.3,
     1      ' #2(GV)   = ',F8.3,
     1      ' #3(GW)   = ',F8.3,/,
     1      ' #4(GP)   = ',F8.3,
     1      ' #5(LX)   = ',F8.3,
     1      ' #6(ptec) = ',F8.2,/,
     1      ' #7(trns) = ',F8.2,
     1      ' #8(shft) = ',F8.4,
     1      ' #9(sfec) = ',F8.2,/,
     1      ' #10(S/L) = ',F8.4,
     1      ' #11(H/L) = ',F8.4,
     1      ' #12(eta) = ',F8.4)
          IF ( LAUE.GE.13) THEN                           !cubic
            WRITE(IUCIF,10)(I,PCOF(I),I=13,NPRF)
          ELSE IF ( LAUE.EQ.11 .OR. LAUE.EQ.12 ) THEN     !hexagonal
            WRITE(IUCIF,11)(I,PCOF(I),I=13,NPRF)
          ELSE IF ( LAUE.EQ.10 ) THEN                     !trigonal 3bar1m
            WRITE(IUCIF,12)(I,PCOF(I),I=13,NPRF)
          ELSE IF ( LAUE.EQ.9 ) THEN                      !trigonal 3barm1
            WRITE(IUCIF,13)(I,PCOF(I),I=13,NPRF)
          ELSE IF ( LAUE.EQ.8 ) THEN                      !trigonal 3bar
            WRITE(IUCIF,14)(I,PCOF(I),I=13,NPRF)
          ELSE IF ( LAUE.EQ.7 ) THEN                      !rhombohedral 3m
            WRITE(IUCIF,15)(I,PCOF(I),I=13,NPRF)
          ELSE IF ( LAUE.EQ.6 ) THEN                      !rhombohedral 3
            WRITE(IUCIF,16)(I,PCOF(I),I=13,NPRF)
          ELSE IF ( LAUE.EQ.5 ) THEN                     !tetragonal 4/mmm
            WRITE(IUCIF,17)(I,PCOF(I),I=13,NPRF)
          ELSE IF ( LAUE.EQ.4 ) THEN                      !tetragonal 4/m
            WRITE(IUCIF,18)(I,PCOF(I),I=13,NPRF)
          ELSE IF ( LAUE.EQ.3 ) THEN                      !orthorhombic
            WRITE(IUCIF,19)(I,PCOF(I),I=13,NPRF)
          ELSE IF ( LAUE.EQ.2 ) THEN                      !monoclinic
            WRITE(IUCIF,19)(I,PCOF(I),I=13,18)
            IF ( NAXIS.EQ.1) THEN
              WRITE(IUCIF,20)(I,PCOF(I),I=19,NPRF)
            ELSE IF ( NAXIS.EQ.2 ) THEN
              WRITE(IUCIF,21)(I,PCOF(I),I=19,NPRF)
            ELSE
              WRITE(IUCIF,22)(I,PCOF(I),I=19,NPRF)
            END IF
          END IF
        ELSE
          WRITE(IUCIF,'(A)') ' Profile function not installed.'
          WRITE(IUCIF,'(A)') ' This is an error & should not happen!'
        END IF
      ELSE IF ( HTYPE(2:3).EQ.'XE' ) THEN
C taken from SUBROUTINE EDTPTP4
        WRITE(IUCIF,'(2A,I2,A,I3,A)') ' Energy Dispersive X-ray',
     1    ' Profile function number',PTYP,' with ',NPRF,' terms'
        IF ( PTYP.EQ.1 ) THEN
          NPRF = 5
          WRITE(IUCIF,'(A)')
     1      ' Profile coefficients for Gaussian function'
          WRITE(IUCIF,42) (PCOF(I),I=1,5)
 42       FORMAT(        ' #1(A)    = ',F8.4,
     1      ' #2(B)    = ',F8.4,
     1      ' #3(C)    = ',F8.4,/
     1      ' #4(ds)   = ',F8.4,
     1      ' #5(cds)  = ',F8.4)
        ELSE
          WRITE(IUCIF,'(A)') ' Profile function not installed.'
          WRITE(IUCIF,'(A)') ' This is an error & should not happen!'
        END IF
      END IF
      WRITE(IUCIF,'(2A,F7.4,A)') ' Peak tails are ignored ',
     1  ' where the intensity is below',CTOF,
     1  ' times the peak'
      RETURN
      END