Subroutine WRREFLIST for program GSAS2CIF
This subroutine is used to write a reflection list for both
single crystal and powder diffraction data.
See the gsas2cif documentation for an
explanation of this code.
SUBROUTINE WRREFLIST(IUEXP,IUCIF,IHST,HTYPE,NPHASES,LAM2,DAYTIME)
INCLUDE '../INCLDS/COPYRIGT.FOR'
!Calling arguments:
INTEGER*4 IUEXP !Experiment file unit number
INTEGER*4 IUCIF !CIF file unit number
INTEGER*4 IHST !Histogram number
CHARACTER*4 HTYPE !Histogram type
INTEGER*4 NPHASES !Number of phases present in the experiment
REAL*4 LAM2 !2nd wave length in the powder pattern
CHARACTER*20 DAYTIME
!Local variables:
INTEGER*4 MINHKL(3)
INTEGER*4 MAXHKL(3)
REAL*4 HKL(3)
REAL*4 INCDNT,DSPACE,LAM,FOSQ,PEAKI,FOTSQ,FCSQ,FCTSQ,
1 PHAS,TRANS,EXTCOR,PROFLP,TF
CHARACTER*80 TEXT
CHARACTER*20 BUFFER(11)
INTEGER*4 BUFLEN(11)
LOGICAL*4 PWDR !.TRUE. for powder data
LOGICAL*4 SNGL !.TRUE. if single crystal data
!Functions defined:
CHARACTER*6 HSTKEY
INTEGER*4 READEXP
INTEGER*4 HEXTOINT
INTEGER*4 REDREFP
INTEGER*4 REDREFS
!Code:
PWDR = .FALSE.
SNGL = .FALSE.
DO I=1,11
BUFLEN(I) = 0
END DO
IF ( HTYPE(1:1).EQ.'P' ) THEN
PWDR = .TRUE.
ELSE
SNGL = .TRUE.
END IF
WRITE(IUCIF,'(/a5,1x,A)') 'loop_'
IF ( PWDR ) THEN
WRITE(IUCIF,'(6x,A)') '_refln_index_h'
WRITE(IUCIF,'(6x,A)') '_refln_index_k'
WRITE(IUCIF,'(6x,A)') '_refln_index_l'
IF (LAM2 .ne. 0) WRITE(IUCIF,'(6x,A)')
1 '_pd_refln_wavelength_id'
IF (NPHASES .GT. 1) WRITE(IUCIF,'(6x,A)') '_pd_refln_phase_id'
ELSE
WRITE(IUCIF,'(6x,A)') '_refln_index_h'
WRITE(IUCIF,'(6x,A)') '_refln_index_k'
WRITE(IUCIF,'(6x,A)') '_refln_index_l'
END IF
WRITE(IUCIF,'(6x,A)') '_refln_observed_status'
WRITE(IUCIF,'(6x,A)') '_refln_F_squared_meas'
WRITE(IUCIF,'(6x,A)') '_refln_F_squared_calc'
WRITE(IUCIF,'(6x,A)') '_refln_phase_calc'
IF ( PWDR ) THEN
WRITE(IUCIF,'(6x,A)') '_refln_d_spacing'
WRITE(IUCIF,'(6x,A)') '_gsas_i100_meas'
ISAM = READEXP(IUEXP,HSTKEY(IHST)//' BIGFO',TEXT)
IF ( ISAM.EQ.0 ) THEN
READ(TEXT,'(F15.0)') BIGFO
IF ( BIGFO.LE.0.0 ) BIGFO = 1.0
ELSE
BIGFO = 1.0
END IF
ISAM = readexp(IUEXP,HSTKEY(IHST)//' NREF ',text)
ELSE
ISAM = readexp(IUEXP,HSTKEY(IHST)//' NREFM',text)
IF ( ISAM.NE.0 ) THEN
ISAM = readexp(IUEXP,HSTKEY(IHST)//' NREF ',text)
END IF
END IF
READ(text,'(I5,F10.0,4X,A1)') NREF,DMIN,IFOBS
numobs = 0
do i=1,3
minhkl(i) = 999
maxhkl(i) = -999
END DO
dmax = 0.
dmin = 9999.
NREFI = 100000*IHST
IF ( HTYPE(1:3).EQ.'PNT' ) NREFI=NREFI+NREF+1
CALL GETUNIT(IUSCRT)
OPEN(IUSCRT)
MREF = 0
DO K=1,NREF
J = 0
IF ( PWDR ) THEN
IF ( HTYPE(1:3).EQ.'PNT' ) THEN
KREF = NREFI - K
ELSE
KREF = NREFI + K
END IF
IS = HEXTOINT('0000FFFF') !1111 1111 1111 1111
I = REDREFP(IUEXP,KREF,IS,HKL,MUL,ICODE,
1 PRFOCOR,DSPACE,LAM,FOSQ,PEAKI,
1 FOTSQ,FCSQ,FCTSQ,PHAS,TRANS,
1 EXTCOR,PROFLP,TF)
IPHAS = MOD(ICODE/1000,10)
ILAM = MOD(ICODE/100,10)
PEAKI = 100.0*PEAKI/BIGFO
ELSE
KREF = NREFI + K
IS = HEXTOINT('00006FFD') !'00 0000 0000 0110 1111 1111 1101'
I = REDREFS(IUEXP,KREF,IS,HKL,0,ICODE,
1 INCDNT,DSPACE,LAM,FOSQ,SIGFO,
1 FOTSQ,FCSQ,FCTSQ,PHAS,0,
1 EXTCOR,WTFO,0,0,0,
1 0,0,0,0,0, 0,0,0)
IPHAS = MOD(ICODE/10000,10)
IELEM = MOD(ICODE/1000,10)
IMAG = MOD(ICODE/100,10)
END IF
do i=1,3
minhkl(i) = min(minhkl(i), nint(hkl(I)))
maxhkl(i) = max(maxhkl(i), nint(hkl(I)))
END DO
J = J + 1
WRITE(BUFFER(J),'(3I4)') (NINT(HKL(i)),i=1,3)
BUFLEN(J) = MAX(BUFLEN(J),LENCH(BUFFER(J)))
IF ( (PWDR .AND. PROFLP.GT.0.5) .OR. SNGL ) THEN
MREF = MREF+1
DMAX = MAX(DMAX, DSPACE)
DMIN = MIN(DMIN, DSPACE)
IF (LAM2 .NE. 0) THEN
J = J + 1
WRITE(BUFFER(J),'(I2)') ILAM + 1
BUFLEN(J) = MAX(BUFLEN(J),LENCH(BUFFER(J)))
END IF
IF (NPHASES .GT. 1) THEN
J = J + 1
WRITE(BUFFER(J),'(I2)') IPHAS
BUFLEN(J) = MAX(BUFLEN(J),LENCH(BUFFER(J)))
ENDIF
J = J + 1
IF ( (SNGL .AND. WTFO.GT.0.0) .OR. PWDR ) THEN
BUFFER(J) = 'o'
NUMOBS = NUMOBS+1
ELSE
BUFFER(J) = '<'
END IF
BUFLEN(J) = MAX(BUFLEN(J),LENCH(BUFFER(J)))
J = J + 1
ESD = -0.01
IF ( SNGL .AND. FOSQ.GT.0.0 ) ESD = SIGFO*FOTSQ/FOSQ
LN = -1
CALL FESD(FOTSQ, ESD, BUFFER(J),LN)
BUFLEN(J) = MAX(BUFLEN(J),LENCH(BUFFER(J)))
J = J + 1
LN = -1
CALL FESD(FCTSQ, -ABS(ESD), BUFFER(J), LN)
BUFLEN(J) = MAX(BUFLEN(J),LENCH(BUFFER(J)))
J = J + 1
LN = -1
CALL FESD(PHAS, -0.1, BUFFER(J), LN)
BUFLEN(J) = MAX(BUFLEN(J),LENCH(BUFFER(J)))
IF ( PWDR ) THEN
J = J + 1
LN = -1
CALL FESD(DSPACE, -0.0001, BUFFER(J), LN)
BUFLEN(J) = MAX(BUFLEN(J),LENCH(BUFFER(J)))
J = J + 1
LN = -1
CALL FESD(PEAKI, -0.1, BUFFER(J), LN)
BUFLEN(J) = MAX(BUFLEN(J),LENCH(BUFFER(J)))
END IF
WRITE (IUSCRT,'(11A)') (BUFFER(JJ),JJ=1,J)
JMAX = J
END IF
END DO
REWIND(IUSCRT)
DO I=1,MREF
READ(IUSCRT,'(11A)') (BUFFER(JJ),JJ=1,JMAX)
WRITE(IUCIF,'(11(A,:,1x))') (BUFFER(JJ)(1:BUFLEN(JJ)),JJ=1,JMAX)
END DO
CLOSE(IUSCRT,STATUS='DELETE')
write (text,'(i9)') numobs
CALL WRVAL(IUCIF, '_reflns_number_observed', text)
write (text,'(i5)') minhkl(1)
CALL WRVAL(IUCIF, '_reflns_limit_h_min', text)
write (text,'(i5)') maxhkl(1)
CALL WRVAL(IUCIF, '_reflns_limit_h_max', text)
write (text,'(i5)') minhkl(2)
CALL WRVAL(IUCIF, '_reflns_limit_k_min', text)
write (text,'(i5)') maxhkl(2)
CALL WRVAL(IUCIF, '_reflns_limit_k_max', text)
write (text,'(i5)') minhkl(3)
CALL WRVAL(IUCIF, '_reflns_limit_l_min', text)
write (text,'(i5)') maxhkl(3)
CALL WRVAL(IUCIF, '_reflns_limit_l_max', text)
write (text,'(f8.3)') dmin
CALL WRVAL(IUCIF, '_reflns_d_resolution_high', text)
write (text,'(f8.3)') dmax
CALL WRVAL(IUCIF, '_reflns_d_resolution_low', text)
C? _reflns_number_total 1592
C? _reflns_observed_criterion F_>_6.0_\s(F)
RETURN
END