	SUBROUTINE PHBOX3 (TSC, CDREF, STATUS)

C***********************************************************************
C
C	   Routine to produce Interchange Format cards for Box 3,
C	   the Crystalographic Parameters and Physical Constants,
C	   for the new PDF Card format (25&26).
C	   Interchange Cards 10-14.  TSC is .TRUE. if type setting codes
C	   are to bge included, .FALSE. otherwise.
C
C	   By: Mark Holomany, JCPDS     Date: 15-Feb-1984
C
C	   Revised:
C	    7-Jan-86 MAH Restrict Dx and Dm to 2 decimal places for
C	                 mineral patterns (request of Minerals SC)
C          15-Jul-87 SJK RET5 Modifications
C	   19-JUL-87 MAH Pass CDREF as CALL parameter to control len
C
C***********************************************************************

	IMPLICIT INTEGER (A-Z)

	CHARACTER*1   DMBRAC, DXBRAC, SBRACK, ZBRACK
	CHARACTER*2   ERRA, ERRB, ERRC
	CHARACTER*3   SPGNUM
 	CHARACTER*6   DX, DM, Z
	CHARACTER*7   XTLABR
	CHARACTER*8   RATIOA,RATIOC
	CHARACTER*10  NEWSTR
	CHARACTER*12  SPGSYM
	CHARACTER*18  ICRYST(0:7)
	CHARACTER*22  SSFOM
	CHARACTER*25  MP
	CHARACTER*(*) CDREF
	LOGICAL       TSC
	REAL          A,B,C, AOB,COB,COA
        REAL          MATRIX(9)
	REAL          FLDM, FLDX

	COMMON /CDEQPD/ EQCELS
	LOGICAL		EQCELS

D	INCLUDE 'CURCRD.CMN'
D	INCLUDE 'IORET.CMN'
D	INCLUDE 'PDFDATA.CMN'

C\$INCLUDE:'CURCRD.CMN'
C\$INCLUDE:'IORET.CMN'
C\$INCLUDE:'PDFDATA.CMN'

	DATA ICRYST/
	1 ' ',
	1 'Triclinic',
	2 'Monoclinic',
	3 'Orthorhombic',
	4 'Tetragonal',
	5 'Hexagonal',
	6 'Rhombohedral (Hex)',
	7 'Cubic'            /
	DATA XTLABR /'AMOTHRC'/

	STATUS = 0

C=========================================================================
C
C  Working on Card 10 -- Crystal. Parameters, from System to abc
C
C=========================================================================

	NSYS = INDEX( XTLABR, CARD1(1)(79:79))

	IF(NUMC(3).EQ.1) THEN
	   CALL PHSPG(CARD3(1:8),SPGSYM)

	   IF(CARD3(9:9) .EQ. 'E') THEN
	      SBRACK = 'B'
	   ELSE
	      SBRACK = ' '
	   ENDIF
	ELSE
	   SPGSYM = ' '
	   SBRACK = ' '
	ENDIF

	IF(NUMC(4).EQ.1) THEN
	   IF(CARD4(11:11) .EQ. '*') THEN
	      SPGNUM = ' '
	   ELSE
	      SPGNUM = CARD4(12:14)
	   ENDIF
	ELSE
	   SPGNUM = ' '
	ENDIF
C
C	... Cell parameters - a, b, c
	CALL LEFT(CARD1(1) ( 1: 9), SIZE)
	CALL LEFT(CARD1(1) (10:18), SIZE)
	CALL LEFT(CARD1(1) (19:27), SIZE)
C
C	... Cell parameter errors
	IF(NUMC(2).GT.0) THEN	
	   CALL PHERR(CARD2(1) ( 1: 9), ERRA)
	   CALL PHERR(CARD2(1) (10:18), ERRB)
	   CALL PHERR(CARD2(1) (19:27), ERRC)
	ELSE
	   ERRA = ' '
	   ERRB = ' '
	   ERRC = ' '
	ENDIF	   


	WRITE(RETCRD(10),1110)
	1                 ICRYST(NSYS), SPGSYM, SPGNUM, SBRACK,
	2                 CARD1(1) ( 1: 9), ERRA,
	3                 CARD1(1) (10:18), ERRB,
	4                 CARD1(1) (19:27), ERRC

1110	FORMAT(A18,A12,A3,A1, 3(A9,A2), 13X)

C======================================================================
C
C    Working on Card 11 -- Crystal. Parameters, from A&C to Z
C
C======================================================================
C
C	... A & C
	RATIOA = ' '
	RATIOC = ' '
	IF(.NOT. EQCELS) GO TO 50
	IF(CARD1(1)(79:79) .EQ. 'X' .OR.
	1  CARD1(1)(79:79) .EQ. 'C')     GO TO 50

	READ (UNIT=CARD1(1), FMT=1800) A,B,C
1800	FORMAT(3F9.5)
	IF(A .EQ. 0.0) GO TO 50
	IF(B .EQ. 0.0) B = A
	IF(C .EQ. 0.0) C = B

	IF(CARD1(1)(79:79) .EQ. 'A' .OR.
	1  CARD1(1)(79:79) .EQ. 'M' .OR.
	2  CARD1(1)(79:79) .EQ. 'O')     THEN
	   AOB = A/B
	   COB = C/B
	   WRITE(UNIT=RATIOA, FMT=1810) AOB
	   WRITE(UNIT=RATIOC, FMT=1810) COB
1810	   FORMAT(F8.4)
C	   ...
C	   Fixup ".1234" to "0.1234" for IBM PC (Microsoft Fortran)
	   IF(RATIOA(1:4) .EQ. '   .') RATIOA(3:3) = '0'
	   IF(RATIOC(1:4) .EQ. '   .') RATIOC(3:3) = '0'
	   CALL LEFT(RATIOA,SIZE)
	   CALL LEFT(RATIOC,SIZE)

	ELSE
	   COA = C/A
	   WRITE(UNIT=RATIOC, FMT=1810) COA
	   CALL LEFT(RATIOC,SIZE)
	ENDIF
C
C	... Cell angles, alpha, beta, gamma
50	CALL LEFT(CARD1(1) (28:35), SIZE)
	CALL LEFT(CARD1(1) (36:43), SIZE)
	CALL LEFT(CARD1(1) (44:51), SIZE)
C
C	... Cell angle errors
	IF(NUMC(2).GT.0) THEN	
	   CALL PHERR(CARD2(1) (28:35), ERRA)
	   CALL PHERR(CARD2(1) (36:43), ERRB)
	   CALL PHERR(CARD2(1) (44:51), ERRC)
	ELSE
	   ERRA = ' '
	   ERRB = ' '
	   ERRC = ' '
	ENDIF
C
C	... Z and Z editorial code
	Z      = ' '
	ZBRACK = ' '
	IF(NUMC(3).GT.0) THEN
	   Z = CARD3(20:25)
	   CALL LEFT(Z,SIZE)

	   IF(CARD3(26:26) .EQ. 'G') THEN
	      N = MIN0(SIZE+1,6)
	      Z(N:N) = 'g'
	      IF(N .EQ. SIZE) CALL ERRTXT ('E',
	1       'Z field overflow with addition of "g" code')
	   ENDIF

	   IF(CARD3(26:26) .EQ. 'E') ZBRACK = 'B'
	ENDIF
C
C	... Do Melting Point
	MP = ' '
	IF(NUMC(11).GT.0) THEN
	   DO 4002 N=1,NUMC(11)
	   IF(CARDB(N) (68:69) .EQ. 'MP') THEN
	      MP = CARDB(N) (1:25)
C
C	      ... Convert greeks if there are any
	      NG = INDEX (MP, '$')
	      IF(NG .GT. 0) THEN
	         CALL PITRAN (MP(NG+1:NG+2), NEWSTR, LENPI)
	         MP(NG:) = NEWSTR(1:LENPI) // CARDB(N)(NG+3:)
	      ENDIF                  

	      GO TO 200
	   ENDIF
4002	   CONTINUE
	ENDIF


200	WRITE(RETCRD(11),1111)
	1                 RATIOA, RATIOC,
	2                 CARD1(1) (28:35), ERRA,
	3                 CARD1(1) (36:43), ERRB,
	4                 CARD1(1) (44:51), ERRC,
	5                 Z,ZBRACK,MP

1111	FORMAT(A8,A8, 3(A8,A2), A6,A1, A25, 2X)

C======================================================================
C
C   Working on Cards 12&13 -- Crystal Data  Reference
C
C======================================================================

	CALL DOREFS ('UC', .FALSE., .TRUE., IRET, CDREF, LENREF)
	IF(LENREF .GT. 0) THEN
	   IF(LENREF .LT. LEN(CDREF)) CDREF(LENREF+1:) = ' '
           RETCRD(12) = CDREF (1:80)
	   RETCRD(13) = CDREF (81:LEN(CDREF))
	ELSE IF(CARD1(1)(79:79) .EQ. 'X' .OR. NUMC(9) .LE. 0) THEN
C	   .. Check if "Ibid." is implied, ie. if there is a xl system
	         RETCRD(12) = ' '
	         RETCRD(13) = ' '
             ELSE                    
                 RETCRD(12) = 'Ibid.'
	         RETCRD(13) = ' '
             ENDIF

C=======================================================================
C
C	   Working on Card 14
C
C=======================================================================

C
C	... Get  Dx
C	... use aids d-calc unless it is guessed
	IF(NUMC(3).GT.0) THEN
	   IF(NUMC(4).GT.0) THEN
	      IF(CARD4(44:44).EQ.'G' .OR. CARD4(38:43).EQ.' '  .or.
	1     card4(59:59) .eq. 'G') THEN
C
C	      .. temporary fix above to use the author's Dx when the
C	      .. Molecular weight is marked as guessed.  This gets
C	      .. around the error in AIDS that fails to mark Dx as
C	      .. guessed when the mol wt is guessed (ie., when "Ln"
C	      .. is present in the chem formula.  Discovered by WFM
C	      .. and applied here 4-13-84.  This should be removed
C	      .. after 25&26 has been produced and all succeeding
C	      .. sets have been reprocessed through AIDS.  -- MAH
C
	         DX = CARD3(38:43)                                         
	         CALL LEFT(DX,SIZE)
	      ELSE
	         DX = CARD4(38:43)                                         
	         CALL LEFT(DX,SIZE)
	      ENDIF
	      DXBRAC = ' '

	   ELSE
	      DX = CARD3(38:43)
	      CALL LEFT(DX,SIZE)
	      IF(CARD3(44:44).EQ.'E') THEN
	         DXBRAC = 'B'
	      ELSE
	         DXBRAC = ' '
	      ENDIF
	   ENDIF

	ELSE
	   DX     = ' '
	   DXBRAC = ' '
	ENDIF

	IF(DX .NE. ' '  .AND.  CARD5(1)(3:3) .EQ. 'M') THEN
C	   .. Restrict density to 2 decimal places for minerals
	   READ (UNIT=DX, FMT='(F6.3)') FLDX
	   WRITE(UNIT=DX, FMT='(F6.2)') FLDX
	   CALL LEFT (DX, SIZE)
	ENDIF

C
C	... Get Dm
C
C	???  WHEN SHOULD BRACKETS BE PUT AROUND DM ???
C
	DMBRAC = ' '
	IF(NUMC(3).GT.0) THEN
	   DM = CARD3(30:35)                                            
	   CALL LEFT(DM,SIZE)
	   IF(DM .NE. ' '  .AND.  CARD5(1)(3:3) .EQ. 'M') THEN
C	      .. Restrict density to 2 decimal places for minerals
	      READ (UNIT=DM, FMT='(F6.3)', IOSTAT=IOS) FLDM
	      IF(IOS .NE. 0) CALL ERRTXT ('E', 'DM invalid in the MDB')
	      WRITE(UNIT=DM, FMT='(F6.2)') FLDM
	      CALL LEFT (DM, SIZE)
	   ENDIF
	ELSE
	   DM = ' '
	ENDIF
C
C	... Smith/Snyder Figure of Merit
	IF(NUMC(16).GT.0 .AND. CARDG(34:38).NE.' ') THEN

	WRITE (SSFOM, 1801) CARDG(46:47), 
	1                   CARDG(34:38), CARDG(40:44), 
	2                   CARDG(49:51)
1801	FORMAT('F(', A, ')',  '=',A, '(',A,  ',',A, ')')
C>>>	IF(SSFOM(3:3) .NE. ' ') SSFOM(2:2) = '#'
	CALL CMPRES (SSFOM, SIZE)

	ELSE
	   SSFOM = ' '
	ENDIF


	WRITE(RETCRD(14),1114) DX,DXBRAC,DM,DMBRAC,SSFOM
1114	FORMAT(A6,A1, A6,A1, A22, 44X)

9000	CONTINUE
	RETURN
	END
