	PROGRAM JCPD11
C++  Adapted from the DCON routine of DJ HELM	Date: 13 FEB 85
C  By R. L. Snyder  8/84
C++	Purpose: main routine for the conversion programs
C++
C	Modifications
C	Who	date	what
C
C
C
C
C
	COMMON /TRMBLK/IUNIT1,IUNIT2,TERM, IDIFAS
	INTEGER IUNIT1,IUNIT2,TERM
	BYTE EXD(4),FILE1(32),FILE2(32),EXI(4)
	DATA EXD/'.','D','A','T'/
       DATA EXI/'.','D','I','F'/
C
	IUNIT1=1
	IUNIT2=2
	TERM=5
C
1	WRITE(TERM,2)
2	FORMAT(//' JCPDS test d-I data to Diffrac 11 .DIF file '/)
C
C	JCPDS test data to diffrac 11 d-I file conversion
C
C
C	the file designation will be asked for 
C
300	WRITE(TERM,3121)
3121	FORMAT(/' Enter the number of the JCP file to be converted: ',$)
C**	extension not entered default to .DAT
       FILE1(1) = 'J'
       FILE1(2) = 'C'
       FILE1(3) = 'P'
       FILE1(6) = ' '
       READ(TERM,3022)FILE1(4),FILE1(5)
3022	FORMAT(2A1)
       IF(FILE1(4) .EQ. ' ')GO TO 1000
	DO 3122 I=4,32
	IF(FILE1(I).GT.' ')GO TO 3122
	IC=1
	DO 3123 J=I,I+3
	FILE1(J)=EXD(IC)
	IC=IC+1
3123	CONTINUE
C PLACE A NUL AT END OF NAME
       FILE1(I+4) = 0
	GO TO 3124
3122	CONTINUE
C
C  SET UP THE OUTPUT DIFFRAC 1 FILE NAME
C
3124	DO 3126 I=1,32
3126	FILE2(I) = FILE1(I)
	DO 3132 I=1,32
	IF(FILE2(I).NE.'.')GO TO 3132
	IC=2
	DO 3133 J=I+1,I+3
	FILE2(J)=EXI(IC)
	IC=IC+1
3133	CONTINUE
	GO TO 3150
3132	CONTINUE
C
C  OPEN BOTH FILES
C
3150		OPEN(UNIT=IUNIT2,ACCESS='DIRECT',TYPE='NEW',
	1	NAME=FILE2,RECORDSIZE=1,ASSOCIATEDVARIABLE=IDIFAS)
		OPEN(UNIT=IUNIT1,ACCESS='SEQUENTIAL',TYPE='OLD',
	1	NAME=FILE1,RECORDSIZE=1,READONLY)
	WRITE(TERM,1154)
1154	FORMAT(//' 		TRANSFER INITIATED '//)
       CALL JCPDS(FILE1,FILE2)
	WRITE(TERM,1151)
1151	FORMAT(' Transfer complete.')
	GO TO 1
C
1000	CALL EXIT
	END

	SUBROUTINE JCPDS(FILE1,FILE2)
C++
C++	Routine: JCPDS
C++	Purpose: Conversion routine
C++	Syntax:
C++
C	Modifications
C	Who	date	what
C
C
C
	COMMON /TRMBLK/IUNIT1,IUNIT2,TERM, IDIFAS
	COMMON /DIFPA2/ DIHEAD
	INTEGER IUNIT1,IUNIT2,TERM
       CHARACTER*80 BUF
	BYTE FILE1(32),FILE2(32),ID(16),DAT(9),TIM(8),BLK(3),USER(12)
	REAL WAVE,SNGLE,ENGLE,STPSIZ,TIME,TUBVOL,LAMBDA,ANODE
     1,DELWAV,WAVE1,WAVE2,ZERO
	REAL DVAL(200),HEIGHT(200),FWHM(200),DIHEAD(24),UNICEL(14)
C
C  Set up the parameters for the .DIF output file to be writen by wrtout
C
C**************************************************
CDiffrac-11 *.DIF file format.
C
C 1- 4	SAMP ID.		These are alphanumerics
C 5- 7	DATE OF MEAS  (A9,3^@)
C 8- 9	TIME OF MEAS
C10-12	OPERATOR NAME FROM FILLOC.DAT
C
C13	SANG
C14	ENAG
C15	AINC
C16	CTIM
C17	res.
C
C18	ANODE (A4)
C19	WAVELENGTH
C
C20	A=ADR, I=IDR;  I=integral, N=net intens.
C21	npeak, nresid.peaks	(2I*2)
C22	C=COMSEA, J=JCPDS
C23	Apeture (rec 18 of .RAW file) 
C24	?
C
C25	MCELL (1=unitcell stored by appel)  MINO (1=hkl stored)
C26-27	crystal system (A6);   bravais lattice (A2)
C28-30	A,B,C of unit cell
C31	cell volume
C32-34	angles alpha, beta, gamma
C
C35-38	res.
C
C    FIRST PEAK
C39-40	h,k,l,0 (4I*2)
C41	D-value
C42	Intensity
C43	FWHM
C44	Residual intensity
C
C45-50	Next peak
C
C
C************************************************************
C  SET UP THE TITLE AND OPERATOR NAME
       DATA ID/'J','C','P','D','S',' ','P','R','O','B','L','E','M',
     1' ','#','#'/
       DATA USER/'R','.',' ','L','.',' ','S','N','Y','D','E','R'/
       EQUIVALENCE (DIHEAD(1),ID(1)), (DIHEAD(5),DAT(1)),
     1 (DIHEAD(8),TIM(1)), (DIHEAD(10),USER(1))
C  PUT THE SAMPLE NUMBER INTO THE TITLE
       DO 1 J=1,32
       IF(FILE1(J).EQ.'P')GO TO 2
1	CONTINUE
2	ID(15) = FILE1(J+1)
       ID(16) = FILE1(J+2)
C
C  GET DATE AND TIME
C
       CALL DATE( DAT )
       CALL TIME( TIM )
C  
C  Read in the oddball JCP file print the header information and then 
c  ask for the needed input parameters from the user.  We will default 
c  most  parameters for these test files.
c  
5       READ(IUNIT1,10)BUF
10	FORMAT(A80)
       WRITE(TERM,15)BUF
15	FORMAT(1X,A80)
C  TEST IF THIS IS THE LAST HEADER RECORD
       IF(BUF(1:5) .NE. 'start')GO TO 5
C
C  BEGIN READING THE D AND I VALUES
C
       DO 50 I=1,200
       READ(IUNIT1,20,END=60) DVAL(I), HEIGHT(I)
C       WRITE(TERM,21) I, DVAL(I), HEIGHT(I)
20	FORMAT(15X,F10.4,8X,F5.0)
C21	FORMAT(2X,I5,10X,F10.4,10X,F5.0)
       FWHM(I) = 0.1
       IF(DVAL(I) .EQ. 0.0 .AND. HEIGHT(I) .EQ. 0.0) GO TO 60
50	CONTINUE
       WRITE(TERM,55)
55	FORMAT(' **** d-I list cut off at 200 ****')
60	NDIF = I - 1
C
C  GET THE STARTING AND ENDING ANGLES OF THE SCAN
C
       DLO = DVAL(NDIF) - .1
       WRITE(TERM,70) DLO
70	FORMAT(/' Enter high and low d limits for scan (default',
     1'=20.,',F5.2,'): '$)
       READ(TERM,75)DHI,DLO
75	FORMAT(2G)
       IF(DLO.EQ.0.0)DLO = DVAL(NDIF) - .1
C  CU IS LOWER LIMIT
       IF(DLO .LT. .775) DLO = .775
       IF(DHI.EQ.0.0)DHI = 20.
       	DTR = 3.141592654 / 180.
       DIHEAD(13) = 2.0/DTR * ASIN(1.540598/(2.0*DHI))
       DIHEAD(14) = 2.0/DTR * ASIN(1.540598/(2.0*DLO))
       DIHEAD(15) = .02
       DIHEAD(16) = 1.0
       DIHEAD(17) = 0.0
C18	ANODE (A4)
C19	WAVELENGTH
C20	A=ADR, I=IDR;  I=integral, N=net intens.
C21	npeak, nresid.peaks	(2I*2)
C22	C=COMSEA, J=JCPDS
C23	Apeture (rec 18 of .RAW file) 
C24	?
	DIHEAD(18) = 'CU  '
	DIHEAD(19) = 1.540510
C  I WILL JUST ZERO OUT RECORDS 20 - 24
       DO 100 I=20,24
100	DIHEAD(I) = 0.0
	UNICEL(1)=0		! NO UNIT CELL PARAMETERS
	UNICEL(2)=0		! NO HKL INDICES STORED
	UNICEL(2)='    '	! PRESET CRYST SYSTEM WITH BLANKS
	UNICEL(3)='    '
	DO 150 I=4,10
150	UNICEL(I)=0.0	! PRESET RECORDS 4-10 WITH 0.0
	DO 155 I=21,28
155	UNICEL(I)=0	! PRESET RECORDS 35-38 WITH 0 0	
C
C  DUMP IT ALL OUT INTO DIFFRAC 11 FORMAT AND LETS GO HOME
C
	CALL WTDIF(NDIF,UNICEL,DVAL,HEIGHT,FWHM)
C
C	everything completed
C	
	CLOSE(UNIT=IUNIT1)
	CLOSE(UNIT=IUNIT2)
	WRITE(TERM,200)(FILE1(I),I=1,26),(FILE2(I),I=1,26)
200	FORMAT(' File ',26A1,' has been transfered to ',26A1)
201	RETURN
	END

	SUBROUTINE WTDIF (NDIF,UNICEL,DVAL,HEIGHT,FWHM)
C
C  WRITE D/I'S ON A .DIF FILE
C
C  UNICEL = ARRAY CONTAINING UNIT CELL PARAMETERS (RECORDS 25-38)
C  DVAL   = ARRAY CONTAINING D VALUES
C  HEIGHT = ARRAY CONTAINING PEAK INTENSITIES
C  FWHM   = ARRAY CONTAINING FULL WIDTH AT HALF MAXIMUM
c	COMMON /CAT1/ NREC,NUMFIL,NFIL,ICATU,ICATAS,CATFLG
C	COMMON /CAT2/ FILNAM,SMPNAM,NRAW,NDIF,NPLT,NDUM
C	COMMON /CAT3/ ICATSH
C	COMMON /DIFPA1/ IDIFU,IDIFAS,DIFFLG
	COMMON /DIFPA2/ DIHEAD
C	COMMON /DIFPA3/ IDIFSH
	INTEGER IUNIT1,IUNIT2,TERM
	COMMON /TRMBLK/IUNIT1,IUNIT2,TERM, IDIFAS
	INTEGER*2 FILNAM(6),SMPNAM(8),NDUM(4),FNAM(6),NDI(2)
	LOGICAL*1 CATFLG(2),DIFFLG(2)
	REAL DVAL(1),HEIGHT(1),FWHM(1),DIHEAD(24),UNICEL(14)
	EQUIVALENCE (DIHEAD(21),NDI(1))
C
c	IDIFSH=0	! NO SHARED ACCESS FOR 'DIF'-FILE
c	ICATSH=0	! NO SHARED ACCESS FOR 'DI11.CAT'-FILE
C  OPEN XXXXXX.DIF TYPE='UNKNOWN'
c	DO 10 N=1,6		! READ FILE NAME FROM COMMON CAT2
c10	FNAM(N)=FILNAM(N)
c	CALL DIFOPN(FNAM,0)
C  WRITE HEADER ON FILE (RECORDS 1 - 24)
	NDI(1)=NDIF	! STORE NUMBER OF PEAKS IN RECORD 21
	NDI(2)=0	! RESET RESIDUAL PATTERN
	DO 50  N=1, 24
50	WRITE (IUNIT2'N)  DIHEAD(N)
C  WRITE UNIT CELL PARAMETERS (RECORDS 25 - 38)
	DO 70  N=25,38
70	WRITE (IUNIT2'N) UNICEL(N-24)
C
C WRITE D&I'S ON FILE
       NDI(1) = 0
       ZERO = 0.0
	IDIFAS=39
	DO 80  N=1, NDIF
C       WRITE(TERM,1234)N,DVAL(N),HEIGHT(N),FWHM(N),NDIF,IDIFAS
C1234	FORMAT(1XI5,3F10.4,2I5)
	WRITE (IUNIT2'IDIFAS) DIHEAD(21)	! H=0,K=0
	WRITE (IUNIT2'IDIFAS) DIHEAD(21)	! L=0
	WRITE (IUNIT2'IDIFAS)  DVAL(N)	! D VALUE
	WRITE (IUNIT2'IDIFAS)  HEIGHT(N)	! INTENSITY
	WRITE (IUNIT2'IDIFAS)  FWHM(N)	! WIDTH
80	WRITE (IUNIT2'IDIFAS) ZERO	! GROSS INTENSITY=0.0
C
c	CALL DIFCLS
C  OPEN DI11.CAT
c	CALL DIOPEN
c	IF(NFIL.GT.0) GOTO 100		! FILE ALREADY STORED IN DI11.CAT
c	NUMFIL=NUMFIL+1			! NEW FILE NAME ! INCREASE THE POINTER
c	NFIL=NUMFIL+1			! AND CALCULATE THE RECORD NUMBER
c100	WRITE(ICATU'NFIL) (FILNAM(L),L=1,5),(SMPNAM(L),L=1,8),
c     +	NRAW,NDIF,NPLT,(NDUM(L),L=1,4)
c	WRITE(ICATU'1) NREC,NUMFIL	! RESTORE THE POINTERS
c	CALL DICLOS
	RETURN
	END
