Subroutine CPTMPLTE for program GSAS2CIF
This subroutine is used to insert the contents of a
CIF template file into a CIF file.
See the gsas2cif documentation for an
explanation of this code.
SUBROUTINE CPTMPLTE(IUCIF,TEMPLATE1,TEMPLATE2,LOCALCOPY)
C Copy Template File
C This subroutine opens the file referenced by LOCALCOPY and copies
C the contents, line by line to the output CIF file (IUCIF).
C
C If this file does not exist, a master template file named TEMPLATE1
C is opened and a file named LOCALCOPY is created. If that does not exist
C or is blank, a master template file named TEMPLATE2 is opened.
C
C The master template file is then copied to are copied both to the
C output CIF file (IUCIF) and the LOCALCOPY file.
C
C The master template file will be read from the current default data
C data directory, if it exists, otherwise it is read from the GSAS
C data directory.
INTEGER*4 IUCIF !Unit no. for cif file
CHARACTER*(*) TEMPLATE1 !Name of template file #1
CHARACTER*(*) TEMPLATE2 !Name of template file #2
CHARACTER*(*) LOCALCOPY !Name of local copy of template file
!LOCAL VARIABLES:
INTEGER*4 IUIN !Unit no. for input file
INTEGER*4 IUCP !Unit no. for output localcopy file (if needed)
INTEGER*4 IFLAG !Open error flag
INTEGER*4 ILONG !# of too long lines
INTEGER*4 L
CHARACTER*100 LINE !temp variable
CHARACTER*255 FULLNAME !full path for template file
CHARACTER*255 GSAS !location of GSAS files
LOGICAL*4 DATAFLAG !set to true after the data_ line is read
!FUNCTION DEFINITIONS:
INTEGER*4 GSGETENV !get a environment variable
INTEGER*4 LENCH !length of a character string
IUCP = 0
CALL GETUNIT(IUIN)
C first try to open the LOCALCOPY, if it exists
OPEN(UNIT=IUIN,FILE=LOCALCOPY,
1 IOSTAT=IFLAG, !error flag
1 STATUS='OLD',FORM='FORMATTED')
IF (IFLAG .EQ. 0) THEN
PRINT '(2A)',' Copying from file ',LOCALCOPY
END IF
IF (IFLAG .NE. 0 .AND. TEMPLATE1 .NE. ' ') THEN
C open failed, open the 1st template
C look first for a template in the current directory
OPEN(UNIT=IUIN,FILE=TEMPLATE1,
1 IOSTAT=IFLAG, !error flag
1 STATUS='OLD',FORM='FORMATTED')
IF ( IFLAG.EQ.0 ) THEN
PRINT '(2A)',' Reading from current directory, file ',
1 TEMPLATE1(:LENCH(TEMPLATE1))
CALL GETUNIT(IUCP)
OPEN(UNIT=IUCP,FILE=LOCALCOPY,STATUS='NEW',
1 FORM='FORMATTED')
PRINT '(2A)',' Creating file ',LOCALCOPY
ELSE
C not found, look in the GSAS data directory
IFLAG = GSGETENV('gsas ',GSAS)
IF ( IFLAG.EQ.0 ) STOP
1 'ERROR - Environment variable GSAS is undefined'
FULLNAME = GSAS(1:INDEX(GSAS,' ')-1)//'/data/'//TEMPLATE1
OPEN(UNIT=IUIN,FILE=FULLNAME,
1 IOSTAT=IFLAG,
1 STATUS='OLD',FORM='FORMATTED')
IF ( IFLAG.NE.0 ) THEN
PRINT '(3A)',' File ',TEMPLATE1(:LENCH(TEMPLATE1)),
1 ' not found in current or GSAS data directory'
PRINT '(4A)',' will try generic template'
ELSE
PRINT '(2A)',' Reading from GSAS data directory, file ',
1 TEMPLATE1(:LENCH(TEMPLATE1))
CALL GETUNIT(IUCP)
OPEN(UNIT=IUCP,FILE=LOCALCOPY,STATUS='NEW',
1 FORM='FORMATTED')
PRINT '(2A)',' Creating file ',LOCALCOPY
END IF
END IF
END IF
IF (IFLAG .NE. 0) THEN
C open failed, open the 2nd template
C look first for a template in the current directory
OPEN(UNIT=IUIN,FILE=TEMPLATE2,
1 IOSTAT=IFLAG, !error flag
1 STATUS='OLD',FORM='FORMATTED')
IF ( IFLAG.EQ.0 ) THEN
PRINT '(2A)',' Reading from current directory, file ',
1 TEMPLATE2(:LENCH(TEMPLATE2))
ELSE
C not found, look in the GSAS data directory
IFLAG = GSGETENV('gsas ',GSAS)
IF ( IFLAG.EQ.0 ) STOP
1 'ERROR - Environment variable GSAS is undefined'
FULLNAME = GSAS(1:INDEX(GSAS,' ')-1)//'/data/'//TEMPLATE2
OPEN(UNIT=IUIN,FILE=FULLNAME,
1 IOSTAT=IFLAG,
1 STATUS='OLD',FORM='FORMATTED')
IF ( IFLAG.NE.0 ) THEN
PRINT '(2A)',' Error: could not find file ',
1 TEMPLATE2(:LENCH(TEMPLATE2))
PRINT '(4A)',' This file is missing from GSAS',
1 ' data directory, ',GSAS(1:INDEX(GSAS,' ')-1),
1 '/data/'
STOP 'ERROR - missing template file'
END IF
PRINT '(2A)',' Reading from GSAS data directory, file ',
1 TEMPLATE2(:LENCH(TEMPLATE2))
END IF
CALL GETUNIT(IUCP)
OPEN(UNIT=IUCP,FILE=LOCALCOPY,STATUS='NEW',FORM='FORMATTED')
PRINT '(2A)',' Creating file ',LOCALCOPY
END IF
C got the input file, now read from it
ILONG = 0
DATAFLAG = .FALSE.
READ (IUIN,'(A)',IOSTAT=IFLAG) LINE
DO WHILE (IFLAG .EQ. 0)
L = LENCH(LINE) ! is the line too long?
IF (L .GT. 80) THEN
L = 80
ILONG = ILONG + 1
END IF
C don't copy lines that preceed the data_ token
IF (DATAFLAG) WRITE (IUCIF,'(A)') LINE(:L)
IF (IUCP .NE. 0) WRITE (IUCP,'(A)') LINE(:L)
C Did this line contain a data_ block name?
IF (.NOT. DATAFLAG) THEN
I = 1
DO WHILE (LINE(I:I) .EQ. ' ' .AND. I .LT. L)
I = I + 1
END DO
CALL UPCASE(LINE)
IF (LINE(I:I+4) .EQ. 'DATA_') DATAFLAG = .TRUE.
END IF
READ (IUIN,'(A)',IOSTAT=IFLAG) LINE
END DO
IF (ILONG .GT. 0) PRINT '(A,I5,A)',' Warning:',ILONG,
1 ' lines longer than 80 characters were truncated'
IF (IUCP .NE. 0) CLOSE(IUCP)
CLOSE(IUIN)
RETURN
END