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