C------------------------------------------------------------------------
	SUBROUTINE GETNAME(QUALTY,PFORM1,PFORM2,PNAME,MINNAM,FC,STATUS)
C========================================================================
C
C	   Routine to return the Quality Mark, Reference Intensity, 
C	   Chemical Formula(s), Mineral Name and Chemical Name.
C	   By: B. H. Toby, Oct, 1990
C
C	Based on routine PHBOX1
C
C	   By: Mark Holomany, JCPDS     Date: 15-Feb-1984
C
C	QUALTY		Quality Mark
C	PFORM1		Chemical Formula Line 1 
C	PFORM2		Chemical Formula Line 2
C	PNAME		Chemical Name
C	MINNAM		Mineral Name 
C	FC		Reference Intensity
C============================================================================
  
	IMPLICIT INTEGER (A-Z)
	CHARACTER*1   QUALTY
	CHARACTER*80  PFORM1
	CHARACTER*80  PFORM2
	CHARACTER*160 PNAME
	CHARACTER*80  MINNAM
	REAL	      FC

	CHARACTER*1   QMARKS(0:5)
	CHARACTER*5   QCODES
	CHARACTER*10  NEWSTR

C!	INCLUDE 'CURCRD.CMN'
	INCLUDE 'IORET.CMN'
C!	INCLUDE 'RET3.CMN'
	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 ('GETNAME')
	STATUS = 0

C=======================================================================
C
C	   Working on Card 1 -- PDF Card number, quality, etc.
C
C=======================================================================
C
                
10	IF(NUMC(16).GT.0) THEN
	   QUALTY = QMARKS( INDEX(QCODES, CARDG(25:25)))
	ELSEIF(CARD1(1)(72:72) .EQ. 'D' .or. 
     1		CARD1(1)(72:72) .EQ. 'D') THEN
	   QUALTY = 'D'
	ELSE
	   QUALTY = ' '
	ENDIF
C

C=======================================================================
C
C	   Working on Card 2 -- Primary Chemical Formula
C
C=======================================================================
C
C	... First chemical formula - regular formula
	PFORM1 = ' '
	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 = 4
	   GOTO 9000
	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 = MIN(STATUS,10)
	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)
	         PFORM1(1:L2) = NEWSTR(1:L2)
	         PFORM1(L2+1:L2+2) = '--'
	         L = L2 + 3
	      ELSE
	         PFORM1(1:L2 + 2) = CARDA(11:L2 + 10) // '--'
	         L = L2 + 3
	      ENDIF
	   ENDIF
	ENDIF

	IF(CARD7(1)(70:70) .EQ.'C') THEN
C!	   CALL PHFORM( CARD7(1)(1:67) // CARD7(2)(1:67),
C!     1               PFORM1(L:), LENP, IRET)
	   PFORM1(L:) = CARD7(1)(1:67) // CARD7(2)(1:67)
	ELSE
C!	   CALL PHFORM( CARD7(1)(1:67), PFORM1(L:), LENP, IRET)
	   PFORM1(L:) = CARD7(1)(1:67)
	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 = MIN(STATUS,10)
	ENDIF


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

30	CONTINUE
	PFORM2 = ' '
	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
C!	      CALL PHFORM( CARD7(N)(1:67) // CARD7(N+1)(1:67),
C!     1                  PFORM2, LENP, IRET)
	      PFORM2(L:) = CARD7(N)(1:67) // CARD7(N+1)(1:67)
	   ELSE
C!	      CALL PHFORM( CARD7(N)(1:67), PFORM2, LENP, IRET)
	      PFORM2(L:) = CARD7(N)(1:67)
	   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
	   GO TO 40
	ENDIF
4002	CONTINUE


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

40	CONTINUE
	PNAME = ' '
	IF(NUMC(6).LE.0) THEN
	   CALL ERRTXT ('E', 'No PDF chemical name')
C!	   IF(NUMC(18) .GE. 1) CALL ERRTXT ('E', 'No PDF chemical name')
	   STATUS = 3
	   GO TO 9000
	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 60
	      NDELTA = LENPI - 3
  	      IF(SIZE+NDELTA .GT. LEN(PNAME)) THEN
	         CALL ERRTXT ('E', 
     1          'Cannot convert Greek PIcode, no space left')
	         STATUS = MIN(STATUS,10)
	         GO TO 60
	       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

	   GO TO 60
	ENDIF
4004	CONTINUE
C
C	... No PDF name found (coded "P")
	CALL ERRTXT ('E', 'No PDF chemical name')
C!	IF(NUMC(18) .GE. 1) CALL ERRTXT ('E', 'No PDF chemical name')
	STATUS = 3


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 = MIN(STATUS,10)
	   ENDIF
	   MINNAM = CARD6(N)(1:67)
	   GO TO 70
	ENDIF
4003	CONTINUE

	MINNAM = ' '
70	CALL REMSPEC(MINNAM,PNAME)

9000	CONTINUE
C=======================================================================
C
C	... I/I Corundum
C
C=======================================================================
	IF(NUMC(16) .NE. 0) THEN
	  READ (CARDG(5:10),'(F6.0)') FC
	ELSE
	  FC = 0.0
	ENDIF

	CALL DESMOD ('GETNAME')
	RETURN
	END
C----------------------------------------------------------------------
	SUBROUTINE REMSPEC(NAME,outname)
C remove special codes from string NAME
C removes font codes (\BF, \IT, \RG, subscripts and superscripts
C and changes greek characters to ascii
C----------------------------------------------------------------------
	CHARACTER *(*) NAME,outname
	CHARACTER*10  NEWSTR
	NMIN = LENCH(NAME)
	N = 1
	K = 0
	DO WHILE (N .LE. NMIN)
C remove formatting instructions
	  IF ((N+2.LE. NMIN) .and. (NAME(N:N+2) .eq. '\IT' .or. 
     1	NAME(N:N+2) .eq. '\RG' .or. NAME(N:N+2) .eq. '\BF')) THEN
     	     N = N+3
C skip over subscripts and superscripts
	  ELSEIF (NAME(N:N) .eq. '@' .or. NAME(N:N) .eq. '#')THEN
     	     N = N+2
C change greek character codes to ASCII
	  ELSEIF (NAME(N:N) .eq. '$') THEN
	    CALL PITRAN (NAME(N+1:N+2), NEWSTR, LENPI)
C	  ... Trap PI codes that have no translation in the table
	    IF (LENPI .NE. 3  .or. NEWSTR(1:3) .NE. NAME(N:N+2)) THEN
	      outname(K+1:K+LENPI) = NEWSTR(1:LENPI)
	      K = K + LENPI
	    ENDIF
     	    N = N+3
	  ELSE
	    K = K + 1
	    IF (K .ne. N) NAME(K:K) = NAME(N:N)
     	    N = N+1
	  ENDIF
	ENDDO
	RETURN
	END
