Program GSAS2CIF
This program is used to create pdCIF files from GSAS Rietveld refinements.
See the gsas2cif documentation for an
explanation of this code. Dots (
) indicate links to sections in this documentation and
underlined subroutines and functions are links to the source code for those
routines.
PROGRAM GSAS2CIF
!PURPOSE: Create a CIF file from a GSAS .EXP file
INCLUDE '../INCLDS/COPYRIGT.FOR'
!PSEUDOCODE:
!CALLING ARGUMENTS:
!INCLUDE STATEMENTS:
INCLUDE '../INCLDS/ARRAYSZE.FOR'
INCLUDE '../INCLDS/DISAGLCM.FOR'
!LOCAL VARIABLES:
INTEGER*4 MATRX !Pointer to Var-Covar matrix
INTEGER*4 IUCIF !Unit no. for cif file
CHARACTER*68 DESCR !Experiment title
CHARACTER*255 EXPNAM !Experiment file name
CHARACTER*20 EXPRNAME !Experiment name = name of data block
CHARACTER*255 CMTNAM
CHARACTER*80 TEXT !ISAM data string
CHARACTER*255 MSG !
CHARACTER*100 MSG1 !
INTEGER*4 NPHAS(9) !Phase existance flags
INTEGER*4 NUMPHAS !No. of phases
LOGICAL*4 IFPWDR ! true when powder data are present
LOGICAL*4 IFSNGL ! true when single xtal data are present
LOGICAL*4 IXST
LOGICAL*4 ONEBLOCK ! true if the CIF will have one block
CHARACTER*4 HTYP(99) !Histo. types
CHARACTER*4 HTYPE !Current histogram type
CHARACTER*30 INSTNAME ! name of instrument (for I.D.)
CHARACTER*12 KEYVAL !ISAM key
INTEGER*4 IUPRF !Unit no. for powder histogram
CHARACTER*24 DAYTIME
CHARACTER*50 AUTHOR !The dreaded Author name appears again
CHARACTER*24 SAUTHOR !A shortened version of the author name
CHARACTER*3 MONTH
!SUBROUTINES CALLED:
!FUNCTION DEFINITIONS:
INTEGER*4 READEXP !ISAM file read function
CHARACTER*6 CRSKEY !ISAM key building routine
CHARACTER*6 HSTKEY !ISAM key building routine
!DATA STATEMENTS:
!CODE:
CALL STRTRN('GSAS2CIF','SHARED','LIST',IUEXP,IULST,IUTRM)
CALL PROGNAM(IUTRM,'GSAS2CIF','Generate CIF files|'//
1 'Original design by Brian Toby, NIST')
INQUIRE(UNIT=IUEXP,NAME=EXPNAM)
LEXPNM = INDEX(EXPNAM,'.EXP')-1
! drop the directory names
IST = 1
DO I = 1,LEXPNM
IF (EXPNAM(I:I) .EQ. '/' .OR. EXPNAM(I:I) .EQ. '\\') IST = I+1 ! written for -fbackslash
ENDDO
EXPRNAME = EXPNAM(IST:LEXPNM)
CALL VSTRNG(EXPRNAME,LENCH(EXPRNAME),.TRUE.,.TRUE.)
CALL GETUNIT(IUCIF)
OPEN(UNIT=IUCIF,FILE=EXPNAM(1:LEXPNM)//'.cif',
1 STATUS='UNKNOWN',
1 FORM='FORMATTED')
CALL GSDATE(DAYTIME)
! reformat the date in the preferred CIF format yyyy-mm-ddThh:mm
MONTH = DAYTIME(1:3)
CALL UPCASE(MONTH)
IF (MONTH .EQ. 'JAN') THEN
MONTH = '01-'
ELSEIF (MONTH .EQ. 'FEB') THEN
MONTH = '02-'
ELSEIF (MONTH .EQ. 'MAR') THEN
MONTH = '03-'
ELSEIF (MONTH .EQ. 'APR') THEN
MONTH = '04-'
ELSEIF (MONTH .EQ. 'MAY') THEN
MONTH = '05-'
ELSEIF (MONTH .EQ. 'JUN') THEN
MONTH = '06-'
ELSEIF (MONTH .EQ. 'JUL') THEN
MONTH = '07-'
ELSEIF (MONTH .EQ. 'AUG') THEN
MONTH = '08-'
ELSEIF (MONTH .EQ. 'SEP') THEN
MONTH = '09-'
ELSEIF (MONTH .EQ. 'OCT') THEN
MONTH = '10-'
ELSEIF (MONTH .EQ. 'NOV') THEN
MONTH = '11-'
ELSE
MONTH = '12-'
ENDIF
IF (DAYTIME(5:5) .EQ. ' ') DAYTIME(5:5) = '0'
DAYTIME = DAYTIME(17:20)//'-'//MONTH//DAYTIME(5:6)//
$ 'T'//DAYTIME(8:15)
! the software does not expect spaces in the date
CALL VSTRNG(DAYTIME,LENCH(DAYTIME),.TRUE.,.TRUE.)
C get an author name if one is not saved
ISAM = READEXP(IUEXP,'CIF AUTHOR ',TEXT)
IF ( ISAM.NE.0 ) THEN
WRITE (MSG,'(A,I2,A)') 'Please enter your name:'
CALL REDTRML('Enter your name:',AUTHOR)
CALL WRITEXP(IUEXP,'CIF AUTHOR ',' '//AUTHOR)
ELSE
AUTHOR = TEXT(3:)
END IF
! the software does not expect spaces in the short version of the Author name
I = lench(AUTHOR)
IF (I .GT. 20) THEN
SAUTHOR = AUTHOR(I-19:)
ELSE
SAUTHOR = AUTHOR
ENDIF
CALL VSTRNG(SAUTHOR,LENCH(SAUTHOR),.TRUE.,.TRUE.)
C count the number of phases & histograms -- use a single CIF block
C if there is only one of each
CALL GETNPHAS(IUEXP,NPHAS)
C count phase(s)
NUMPHAS = 0
DO I=1,9
IF ( NPHAS(I).GT.0 ) NUMPHAS = NUMPHAS+1
END DO
IFLAG = READEXP(IUEXP,' EXPR NHST ',TEXT)
READ (TEXT,'(I5)') NHIST
CALL RDHTYP(IUEXP,NHIST,HTYP)
C count histogram(s) & set instrument names
IFLAG = READEXP(IUEXP,' EXPR NHST ',TEXT)
READ (TEXT,'(I5)') NHIST
CALL RDHTYP(IUEXP,NHIST,HTYP)
IFPWDR = .FALSE.
IFSNGL = .FALSE.
NPWDHIST = 0
INSTNAME = ' '
DO IHST=1,NHIST
HTYPE = HTYP(IHST)
IF ( (HTYPE(1:1).EQ.'S' .OR. HTYPE(1:1).EQ.'P')
1 .AND. HTYPE(4:4).NE.'*' ) THEN
NPWDHIST = NPWDHIST + 1
ISAM = READEXP(IUEXP,HSTKEY(IHST)//' INAME',TEXT)
IF ( ISAM.NE.0 ) THEN
C is this a default? Is there something to consider as a default?
CALL WRHNAM(IUEXP,IHST,HTYPE)
IF (INSTNAME .EQ. ' ') THEN
WRITE (MSG,'(A,I2,A)') 'Histogram',IHST,
$ ' has no diffractometer name|'//
1 '| Enter a name for the diffractometer:'
ELSE
WRITE (MSG,'(A,I2,4A)') 'Histogram',IHST,
$ ' has no diffractometer name|',
1 '| Enter a name for the diffractometer (/ = ',
$ INSTNAME(:lench(INSTNAME)),'):'
ENDIF
CALL REDTRML(MSG(:lench(MSG)),TEXT)
IF (TEXT .NE. '/') INSTNAME = TEXT
CALL WRITEXP(IUEXP,HSTKEY(IHST)//' INAME',' '//INSTNAME)
ELSE
INSTNAME = TEXT(3:)
END IF
IF ( HTYPE(1:1).EQ.'P' ) IFPWDR = .TRUE.
IF ( HTYPE(1:1).EQ.'S' ) IFSNGL = .TRUE.
END IF
END DO
C set the Single-block flag -- if 1 phase & 1 histogram we don't have to
C break the CIF into more than one block
IF (NPWDHIST .EQ. 1 .AND. NUMPHAS .EQ. 1) THEN
ONEBLOCK = .TRUE.
ELSE
ONEBLOCK = .FALSE.
ENDIF
C read the .CMT file
CMTNAM = EXPNAM(1:LEXPNM)//'.CMT'
INQUIRE(FILE=CMTNAM,EXIST=IXST)
IF ( IXST ) THEN
IUCMT = IUEXP+1
CALL GETUNIT(IUCMT)
OPEN(IUCMT,FILE=CMTNAM,STATUS='OLD',
1 FORM='UNFORMATTED')
READ (IUCMT) NCYCLE
READ (IUCMT) MATSIZ
CLOSE (IUCMT)
CALL GETVM(MATRX,MATSIZ*4)
CALL RDCOVAR(IULST,IUEXP,NUMPAR,PARNAMS,MBW,%val(MATRX))
ELSE
NUMPAR = 0
END IF
IF ( NUMPAR.EQ.0 ) THEN
CALL REDTRML('The Variance-covarance matrix (.CMT file)'//
$ ' cannot be read.|'//
$ 'Uncertainty estimates can not be reported.|'//
$ 'Continue anyway? (Y,[N])',MSG)
CALL UPCASE(MSG(1:1))
IF (MSG .NE. 'Y') STOP
END IF
C get the cycle number and SUM(D**2) from the .EXP file
IFLAG = READEXP(IUEXP,' GNLS RUN ',TEXT) !Read the cycle number from the EXP file
IF ( IFLAG.EQ.0 ) THEN
READ (TEXT,'(43X,I4)') MCYCLE
READ (TEXT(50:68),'(F15.0)') SUMDSQ1
ELSE
MCYCLE = -1
SUMDSQ1 = -1
END IF
C open the Distance & Angle file & check it is current?
CMTNAM = EXPNAM(1:LEXPNM)//'.DISAGL'
INQUIRE(FILE=CMTNAM,EXIST=IXST)
IF (IXST) THEN
IUDIS = IUEXP+1
CALL GETUNIT(IUDIS)
OPEN(IUDIS,FILE=CMTNAM,STATUS='OLD',
1 FORM='FORMATTED')
READ (IUDIS,'(4x,I5,G20.5)') NCYCLE,SUMDSQ
IF (NCYCLE .NE. MCYCLE .OR. SUMDSQ .NE. SUMDSQ1) THEN
PRINT '(3A)','The DISAGL output file does not match the',
$ ' current refinement. Run DISAGL again.'
PRINT '(10x,2A20)', '.DISAGL file','.EXP file'
PRINT '(A10,2(7x,i6,7x))','Cycle:',NCYCLE,MCYCLE
PRINT '(A10,2G20.5)','SUM(D**2):',SUMDSQ,SUMDSQ1
CLOSE(IUDIS)
IUDIS = 0
ENDIF
ELSE
IUDIS = 0
NCYCLE = -2
SUMDSQ1 = -2
ENDIF
IF(IUDIS .EQ. 0) THEN
CALL REDTRML('The distance & angles (.DISAGL file)'//
$ ' cannot be read. (Was DISAGL run?)|'//
$ 'Distances and angles cannot be Reported.|'//
$ 'Continue anyway? (Y,[N])',MSG)
CALL UPCASE(MSG(1:1))
IF (MSG .NE. 'Y') STOP
ENDIF
C now start creating the CIF
PRINT '(A)',' Preparing publ section'
ILEN = LENCH(EXPRNAME)
WRITE(IUCIF,'(3A,/)') 'data_',EXPRNAME(1:ILEN),'_publ'
IF (ONEBLOCK) THEN
C fix up instrument name
I = 1
DO WHILE (I .LT. LENCH(INSTNAME) .AND. INSTNAME(I:I) .EQ. ' ')
I = I + 1
ENDDO
IF (I .GT. 1) INSTNAME = INSTNAME(I:)
CALL VSTRNG(INSTNAME,LENCH(INSTNAME),.TRUE.,.TRUE.)
WRITE(IUCIF,'(A,/,2x,7A)') '_pd_block_id',
$ DAYTIME(1:16),'|',EXPRNAME(1:ILEN),'|',
$ SAUTHOR(:LENCH(SAUTHOR)),'|',
$ INSTNAME(:LENCH(INSTNAME))
ELSE
WRITE(IUCIF,'(A,/,2x,6A)') '_pd_block_id',
$ DAYTIME(1:16),'|',EXPRNAME(1:ILEN),'|',
$ SAUTHOR(:LENCH(SAUTHOR)),'|Overall'
ENDIF
WRITE(IUCIF,'(/A,2X,A)') '_audit_creation_method',
1 '"from EXP file using GSAS2CIF"'
CALL WRVAL(IUCIF,'_audit_creation_date',DAYTIME(1:16))
CALL WRVAL(IUCIF,'_audit_author_name',AUTHOR)
WRITE (IUCIF,'(A,/,3A,/,A,/)') '_audit_update_record',
1 '; ',DAYTIME(1:16),' Initial CIF as created by GSAS2CIF',
$ ';'
C now insert the publication template
CALL CPTMPLTE(IUCIF,' ','template_publ.cif',
$ EXPNAM(1:LEXPNM)//'_publ.cif')
C deal with the overall refinement information
IF (.NOT. ONEBLOCK) THEN
WRITE(IUCIF,'(A,/)') 'data_'//EXPRNAME(1:LENCH(EXPRNAME))//
1 '_overall'
END IF
CALL OVERALL(IUEXP,IUCIF,EXPRNAME,IFPWDR,HTYP,NHIST,
$ NPWDHIST,MBW)
DO IPHAS=1,9
IF ( NPHAS(IPHAS).GT.0 ) THEN
PRINT '(A,I1)',' Processing phase ',IPHAS
IF (.NOT. ONEBLOCK) THEN
WRITE(IUCIF,'(/,A,I2)') '# Information for phase',IPHAS
WRITE(IUCIF,'(A,I1,/)') 'data_'//
$ EXPRNAME(1:LENCH(EXPRNAME))//
$ '_phase_',IPHAS
WRITE(IUCIF,'(A,/,2X,2A,I1,4A)') '_pd_block_id',
1 DAYTIME(1:16)//'|',
$ EXPRNAME(1:LENCH(EXPRNAME))//'_phase',IPHAS,'|',
$ SAUTHOR(:LENCH(SAUTHOR)),'||'
END IF
C now insert the phase template
WRITE(MSG,'(2A,I1,A)') EXPNAM(1:LEXPNM),'_phase',
$ IPHAS,'.cif'
CALL CPTMPLTE(IUCIF,' ','template_phase.cif',MSG)
CALL WRITEPHASE(IUCIF,IUEXP,IUTRM,IPHAS,NPHAS,DAYTIME,
$ ONEBLOCK,%val(MATRX),NUMPAR,MBW,IUDIS)
END IF
END DO
CALL GETUNIT(IUPRF)
DO IHST=1,NHIST
PRINT '(A,I2,A)',' Begin processing histogram ',IHST,' data'
HTYPE = HTYP(IHST)
C get & fix up instrument name
ISAM = READEXP(IUEXP,HSTKEY(IHST)//' INAME',INSTNAME)
I = 1
DO WHILE (I .LT. LENCH(INSTNAME) .AND. INSTNAME(I:I) .EQ. ' ')
I = I + 1
ENDDO
IF (I .GT. 1) INSTNAME = INSTNAME(I:)
CALL VSTRNG(INSTNAME,LENCH(INSTNAME),.TRUE.,.TRUE.)
IF ( HTYPE(1:1).EQ.'P' .AND. HTYPE(4:4).NE.'*') THEN
C Process powder histograms
WRITE(IUCIF,'(/,A,I3)')
1 '# Powder diffraction data for histogram',IHST
IF (.NOT. ONEBLOCK) THEN
WRITE(IUCIF,'(A,I2.2,/)') 'data_'//
1 EXPRNAME(1:LENCH(EXPRNAME))//
1 '_p_',IHST
WRITE(IUCIF,'(A,/,2X,2A,I2.2,4A)') '_pd_block_id',
1 DAYTIME(1:16)//'|',
$ EXPRNAME(1:LENCH(EXPRNAME))//'_H_',IHST,'|',
$ SAUTHOR(:LENCH(SAUTHOR)),'|',
$ INSTNAME(:LENCH(INSTNAME))
ENDIF
WRITE(MSG1,'(3A)') 'template_',
$ INSTNAME(:LENCH(INSTNAME)),'.cif'
WRITE(MSG,'(3A,I2.2,A)') EXPNAM(1:LEXPNM),'_',
$ INSTNAME(:LENCH(INSTNAME)),IHST,'.cif'
CALL CPTMPLTE(IUCIF,MSG1,'template_instrument.cif',MSG)
CALL WRPOWDHIST(IUCIF,IUEXP,IUTRM,IHST,HTYPE,IUPRF,
1 LAM2,DAYTIME,ONEBLOCK,EXPRNAME,SAUTHOR)
PRINT '(A,I2,A)',' Begin processing histogram ',IHST,
1 ' reflection data'
CALL WRREFLIST(IUEXP,IUCIF,IHST,HTYPE,NUMPHAS,LAM2,DAYTIME)
ELSE IF ( HTYPE(1:1).EQ.'S' .AND. HTYPE(4:4).NE.'*' ) THEN
C Process single histograms
IF (.NOT. ONEBLOCK) THEN
WRITE(IUCIF,'(A,I2.2,/)') 'data_'//
$ EXPRNAME(1:LENCH(EXPRNAME))//
1 '_s_',IHST
ENDIF
CALL WRREFLIST(IUEXP,IUCIF,IHST,HTYPE,NUMPHAS,LAM2,DAYTIME)
END IF
END DO
WRITE(IUCIF,'(21A)') '#--',('eof--',i=1,15),'#'
STOP 'GSAS2CIF completed successfully'
END