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