	SUBROUTINE PHBOX1 (STATUS)
C
C	   Routine to produce interchange format cards for Box 1
C	   of the revised JCPDS PDF card (Sets 25&26).  Specifically,
C	   it produces cards 1-6, including the PDF number, Quality
C	   Mark, Chemical Formula(s), Mineral Name and Chemical Name.
C
C
C	   By: Mark Holomany, JCPDS     Date: 15-Feb-1984
C	   Revised:
C	   12-Jan-86 MAH Use LENRWU to determine length of chem name;
C	                 use PNAME rather that PFORM with chem name.
C	   15-JUL-87 SJK Modifications for RET5
C	    5-Jan-88 MAH Suppressed messages for record keeping patterns
C	                 (those without d-spacings) if NUMC(18) .EQ. 0
C
C============================================================================
  
	IMPLICIT INTEGER (A-Z)

	CHARACTER*1   QMARKS(0:5), QUALTY
	CHARACTER*5   QCODES
	CHARACTER*8   CARDNO
	CHARACTER*10  NEWSTR
	CHARACTER*80  PFORM
	CHARACTER*160 PNAME
	LOGICAL       DIGIT, FIRST

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

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

	DATA          QCODES /'OSBIC'/,                        
	1             QMARKS /' ', 'O', '*', ' ', 'i', 'C'/    

	CALL ESTMOD ('PHBOX1')
	STATUS = 0

C=======================================================================
C
C	   Working on Card 1 -- PDF Card number, quality, etc.
C
C=======================================================================
C
C	... Format PDF Card number, dropping leading Zeros
C
C	... If this is an Editor #, then leave as is
	IF((.NOT. DIGIT(CARD1(1)(73:73))) .OR. DBSW.EQ.'CDIF') THEN
	   CARDNO = CARD1(1)(73:78)
	   GO TO 10
	ENDIF
C
C	... Process as PDF#
	IF(CARD1(1)(73:73) .EQ. '0') THEN
	   CARDNO = CARD1(1)(74:74) // '-'
	ELSE
	   CARDNO = CARD1(1)(73:74) // '-'
	ENDIF
	DO 4001 I=75,78
	IF(CARD1(1)(I:I) .NE. '0') THEN
	   CARDNO(4:) = CARD1(1)(I:78)
	   GO TO 10
	ENDIF
4001	CONTINUE
                
10	IF(NUMC(16).GT.0) THEN
	   QUALTY = QMARKS( INDEX(QCODES, CARDG(25:25)))
	ELSE
	   QUALTY = ' '
	ENDIF
C
C	 ... The NUMC(18) skips message if no reflections in pattern,
C	 ... pattern is deleted and present just for record keeping
	IF(QUALTY .EQ. ' ' .AND. CARDG(25:25) .NE. 'B' .AND.
	1  NUMC(18) .GE. 1) THEN
	   CALL ERRTXT ('E', 
	1    'Final quality mark missing; preliminary mark is "' //
	2    CARDG(24:24) // '"')
	   CALL ERRTXT ('C', 'Quality mark set to blank on PDF card.')
	ENDIF
C
C	... Check if PDF Card has a diffractometer trace on it
	IF(CARDG(26:26) .EQ. 'G') THEN
	   RETCRD(1)(11:11) = 'G'
	ELSE
	   RETCRD(1)(11:11) = ' '
	ENDIF

	RETCRD(1)(1:8) = CARDNO
	RETCRD(1)(9:9) = QUALTY
	RETCRD(1)(10:10) = ' '
	IF(CARD1(1)(72:72) .EQ. 'D') RETCRD(1)(10:10) = 'D'

C=======================================================================
C
C	   Working on Card 2 -- Primary Chemical Formula
C
C=======================================================================
C
C	... First chemical formula - regular formula
	IF(NUMC(7).LE.0) THEN
	   IF(NUMC(18) .EQ. 0) THEN
	      CALL ERRTXT ('E', 
	1       'No chemical formula (record keeping card)')
	   ELSE
	      CALL ERRTXT ('E', 'No chemical formula')
	   ENDIF
	   STATUS = 1
	   RETCRD(2) = ' '
	   GO TO 30
	ENDIF
C
C	... Check that Index Code is ' ' or 'X'
	IF(CARD7(1)(69:69) .NE. ' ' .AND.
	1  CARD7(1)(69:69) .NE. 'X' .AND.
	2  CARD7(1)(69:69) .NE. 'A')     THEN
	   CALL ERRTXT ('W', 
	1    'Invalid Index Code for Primary formula: "' //
	2    CARD7(1)(69:69) // '"')
	   STATUS = 1
	ENDIF
C
C	... Add Greek characters from CARDA, if any
	L = 1
	IF(NUMC(10).GT.0) THEN
	   L2 = LENGTH(CARDA(11:16))
	   IF(L2 .GE. 1) THEN
              IF(CARDA(11:11) .EQ. '$') THEN
	         CALL PITRAN (CARDA(12:13),NEWSTR,L2)
	         PFORM(1:L2) = NEWSTR(1:L2)
	         PFORM(L2+1:L2+1) = '-'
	         L = L2 + 2
	      ELSE
	         PFORM(1:L2 + 1) = CARDA(11:L2 + 10) // '-'
	         L = L2 + 2
	      ENDIF
	   ENDIF
	ENDIF

	IF(CARD7(1)(70:70) .EQ.'C') THEN
	   CALL PHFORM( CARD7(1)(1:67) // CARD7(2)(1:67),
	1               PFORM(L:), LENP, IRET)
	ELSE
	   CALL PHFORM( CARD7(1)(1:67), PFORM(L:), LENP, IRET)
	ENDIF

	IF(IRET.NE.0) THEN
	   CALL ERRTXT ('E',
	1    'Primary chemical formula is not in AIDS format:')
	   CALL ERRTXT ('C', CARD7(1)(1:67) )
	   CALL ERRTXT ('C', 
	1    'Most likely cause: typeset formula longer than ' //
	2    '80 characters')
	   STATUS = 1
	ENDIF
	RETCRD(2) = PFORM


C=======================================================================
C
C	   Working on Card 3 -- Second Chemical Formula
C
C=======================================================================

30	CONTINUE
	DO 4002 N=2,NUMC(7)
	IF(CARD7(N)(69:69).EQ.'S' .OR. 
	1 (CARD7(N)(69:69).EQ.' ' .AND. CARD7(1)(69:69).EQ.'X') ) THEN
	   IF(CARD7(N)(70:70) .EQ. 'C') THEN
	      CALL PHFORM( CARD7(N)(1:67) // CARD7(N+1)(1:67),
	1                  PFORM, LENP, IRET)
	   ELSE
	      CALL PHFORM( CARD7(N)(1:67), PFORM, LENP, IRET)
	   ENDIF

	   IF(IRET.NE.0) THEN
	      CALL ERRTXT ('E',
	1       'Secondary chemical formula is not in AIDS format:')
	      CALL ERRTXT ('C', CARD7(N)(1:67) )
	      CALL ERRTXT ('C', 
	1       'Most likely cause: typeset formula longer than ' //
	2       '80 characters')
	      STATUS = 1
	   ENDIF
	   RETCRD(3) = PFORM
	   GO TO 40
	ENDIF
4002	CONTINUE
	RETCRD(3) = ' '


C========================================================================
C
C	   Working on Cards 4&5 -- Chemical name
C
C========================================================================

40	CONTINUE
	IF(NUMC(6).LE.0) THEN
	   IF(NUMC(18) .GE. 1) CALL ERRTXT ('E', 'No PDF chemical name')
	   RETCRD(4) = ' '
	   RETCRD(5) = ' '
	   STATUS = 1
	   GO TO 60
	ENDIF

	DO 4004 N=1,NUMC(6)
	IF(CARD6(N) (69:69) .EQ. 'P') THEN
	   PNAME = CARD6(N)(1:67)
	   SIZE = LENGTH(PNAME(1:67))
	   IF(CARD6(N)(70:70) .EQ. 'C') THEN
C
C	      .. Do not add blank at end of first card if last char is '-'
	      NEND = SIZE + 2
	      IF(PNAME(SIZE:SIZE) .EQ. '-') NEND = SIZE + 1
	      PNAME(NEND:) = CARD6(N+1)(1:67)
	      SIZE = LENGTH(PNAME)
	      IF(CARD6(N+1)(70:70) .EQ. 'C') 
	1       CALL ERRTXT ('E',
	2       'More than 1 continuation card to chem name, others '//
	3       'dropped.')
	   ENDIF

C
C	   ... Convert greeks if there are any
45	   NG = INDEX (PNAME, '$')
	   IF(NG .GT. 0) THEN
	      CALL PITRAN (PNAME(NG+1:NG+2), NEWSTR, LENPI)
C	       ... Trap PI codes that have no translation in the table
	      IF(LENPI .EQ. 3  .AND.
	1        NEWSTR(1:3) .EQ. PNAME(NG:NG+2) ) GO TO 48
	      NDELTA = LENPI - 3
  	      IF(SIZE+NDELTA .GT. LEN(PNAME)) THEN
	         CALL ERRTXT ('E', 
	1          'Cannot convert Greek PIcode, no space left')
	         GO TO 48
	      ENDIF
C
C	      ... Set from/to for the DO loop to correspond to correct
C	      ... direction for sign of NDELTA (l to r/r to l in PNAME)
	      NXFROM = SIZE
	      NXTO   = NG+3
	      NXSTEP = -1
	      IF(NDELTA .LE. -1) THEN
	         NXFROM = NG+3
	         NXTO   = SIZE
	         NXSTEP = 1
	      ENDIF

	      DO 4010 NX=NXFROM,NXTO,NXSTEP
4010	      PNAME(NX+NDELTA:NX+NDELTA) = PNAME(NX:NX)
C	      ... Insert PI code translation
	      PNAME(NG:NG+LENPI-1) = NEWSTR(1:LENPI)
	      SIZE = SIZE + (LENPI - 3)
C	      ... See if there are more
	      GO TO 45
	   ENDIF

48	   IL = SIZE
	   IR = 0

	   IF(SIZE .LE. 80) GO TO 55
	   NPOS = 81
50	   CALL FSPLIT (PNAME, NPOS, IL, IR)
	   IF(IL .EQ. 0) THEN
	      IR = NPOS
	      IL = NPOS - 1
	   ENDIF

55	   CONTINUE
           RETCRD(4) = PNAME(1:IL)
	   IF(IR .NE. 0) THEN
              RETCRD(5) = PNAME(IR:SIZE)
	   ELSE
              RETCRD(5) = ' '
	   ENDIF
	   GO TO 60
	ENDIF
4004	CONTINUE
C
C	... No PDF name found (coded "P")
	IF(NUMC(18) .GE. 1) CALL ERRTXT ('E', 'No PDF chemical name')
	RETCRD(4) = ' '
        RETCRD(5) = ' '
	STATUS = 1


C========================================================================
C
C	   Working on Card 6 -- Mineral Name
C
C========================================================================

60	CONTINUE
	DO 4003 N=1,NUMC(6)
	IF(CARD6(N) (69:69) .EQ. 'M') THEN
	   IF(CARD6(N)(70:70) .EQ. 'C') THEN
	      CALL ERRTXT ('W', 'Mineral name on CARD6 continued')
	      STATUS = 1
	   ENDIF
	   RETCRD(6) = CARD6(N)(1:67)
	   GO TO 9000
	ENDIF
4003	CONTINUE

        RETCRD(6) = ' '

9000	CONTINUE
	CALL DESMOD ('PHBOX1')
	RETURN
	END
