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.
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