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 (example of a link to documentation) 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:

link to documentation
!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:

link to documentation
      CALL STRTRN('GSAS2CIF','SHARED','LIST',IUEXP,IULST,IUTRM)
      CALL PROGNAM(IUTRM,'GSAS2CIF','Generate CIF files|'//
     1      'Original design by Brian Toby, NIST')
link to documentation
      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.)

link to documentation
      CALL GETUNIT(IUCIF)
      OPEN(UNIT=IUCIF,FILE=EXPNAM(1:LEXPNM)//'.cif',
     1      STATUS='UNKNOWN',
     1      FORM='FORMATTED')
     
link to documentation
      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.)

link to documentation
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.)

link to documentation
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
link to documentation
            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

link to documentation
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

link to documentation
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

link to documentation
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

link to documentation
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',
     $     ';'

link to documentation
C now insert the publication template
      CALL CPTMPLTE(IUCIF,' ','template_publ.cif',
     $     EXPNAM(1:LEXPNM)//'_publ.cif')

link to documentation
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)

link to documentation
      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
link to documentation
C now insert the phase template
            WRITE(MSG,'(2A,I1,A)') EXPNAM(1:LEXPNM),'_phase',
     $           IPHAS,'.cif'
            CALL CPTMPLTE(IUCIF,' ','template_phase.cif',MSG)
link to documentation
            CALL WRITEPHASE(IUCIF,IUEXP,IUTRM,IPHAS,NPHAS,DAYTIME,
     $           ONEBLOCK,%val(MATRX),NUMPAR,MBW,IUDIS)
         END IF
      END DO
      
link to documentation
      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
link to documentation
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
link to documentation
            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)
link to documentation
            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'
link to documentation
            CALL WRREFLIST(IUEXP,IUCIF,IHST,HTYPE,NUMPHAS,LAM2,DAYTIME)
         ELSE IF ( HTYPE(1:1).EQ.'S' .AND. HTYPE(4:4).NE.'*' ) THEN
link to documentation
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