 	SUBROUTINE PHBOX5 (STATUS)C======================================================================CC	   Routine to produce PDF Card Photocomp Interchange FormatC	   Cards for Box 5, the free format comments box, of theC	   new PDF Card format (25&26).  Interchange cards 18-28.CC	   By: Mark Holomany, JCPDS     Date: 16-Feb-1984CC	   Revised:C	   16-Mar-84 MAH - changed wording order in Minerals groups.C	   26-Apr-85 MAH - added 'TM' and 'DB' codes (DB is notC	                   currently written onto th PDF card)C	    1-May-85 MAH - special handling of 'HK' and 'FN' commentC	                   cards via ADDFN so that footnotes areC	                   correctly handled.  No longer mattersC	                   whether or not there is a space after theC	                   footnote character on the comment card.CC         15-Jul-87 SJK -  RET5 ModificationsC======================================================================	IMPLICIT INTEGER (A-Z)	CHARACTER*2      CMCODE(30)	COMMON /DSPCRD/  DCARD, NUMDS, NUMCRD	CHARACTER*80     DCARD(100)	COMMON /COMCRD/  CCARD, NUMPHC, CHPHC, CDCNT, FSTCRD, LINKCM,	1                STCRD, NUMCD	CHARACTER        CCARD*1760	INTEGER          CDCNT(30), FSTCRD(30), LINKCM(20)	INTEGER          STCRD(30)	CHARACTER STRING*200	CHARACTER MWT*11	CHARACTER VOLUME*12	EQUIVALENCE (STRING, MWT, VOLUME)	COMMON /MINGRP/  GRPNAM(7), SUBNAM(7)	CHARACTER*20 GRPNAM,SUBNAM	CHARACTER*3  GRPHLD,SUBHLD	COMMON/GRPNUM/NUMGRP	COMMON/CDEQPD/EQCELS	LOGICAL       EQCELSD	INCLUDE 'IORET.CMN'D	INCLUDE 'PDFDATA.CMN'C\$INCLUDE:'IORET.CMN'C\$INCLUDE:'PDFDATA.CMN'	DATA CMCODE / 'CL', 'OO', 'SM', 'PR', 'AN',	1             '  ', 'AT', 'TH', 'FF', 'SC',	2             'PM', 'ST', 'HK', 'AD', 'LN',	3             'MP', 'OP', 'UC', 'FN', 'PD',	4             'DB', 'TM',	5             8*' '  /	CALL ESTMOD ('PHBOX5')	STATUS = 0	CHPHC  = 0CC	... Set up pointers to the first card in CARDB for each possibleC	... comment code type (FSTCRD).  Then link in all other cards ofC	... that type using LINKCM.  Continuation cards are ignored.C	... The number of cards of each type is in CDCNT.  NUMPHC holdsC	... the number of cards filled for output.C	DO 4001 N=1,NUMCD	CDCNT(N)  = 04001	FSTCRD(N) = 0		DO 4002 N=1,204002	LINKCM(N) = 0	DO 4010 NB=1,NUMC(11)	IF(CARDB(NB)(1:1).EQ.'#' .AND. (CARDB(NB)(68:69).NE.'HK' .AND.	1  CARDB(NB)(68:69).NE.'FN')) CALL ERRTXT ('W', 	2  'Footnote not coded with "HK" or "FN"')	IF(NB.GT.1) THEN	   IF(CARDB(NB-1)(70:70) .EQ. 'C') GO TO 4010	ENDIF	DO 4020 NCODE=1,NUMCD	IF(CARDB(NB)(68:69) .EQ. CMCODE(NCODE)) THEN	   CDCNT(NCODE) = CDCNT(NCODE) + 1	   IF(FSTCRD(NCODE) .EQ. 0) THEN	      FSTCRD(NCODE) = NB	   ELSE	      N = FSTCRD(NCODE)100	      IF(LINKCM(N) .NE. 0) THEN	         N = LINKCM(N)	         GO TO 100	      ENDIF	      LINKCM(N) = NB	   ENDIF	   GO TO 4010	ENDIF4020	CONTINUE	CALL ERRTXT ('E', 	1  'Invalid CARDB code "' // CARDB(NB)(68:69) // '"')4010	CONTINUECC	... Error checking codeC-->	WRITE(NOUT,43) (CARDB(N)(1:71),LINKCM(N),N=1,NUMC(11))C-->43	FORMAT(' ',A,I4 )C-->	TYPE *,' 'C-->	WRITE(NOUT,44) (CMCODE(N),FSTCRD(N),CDCNT(N),N=1,NUMCD)C-->44	FORMAT((' ',5(A,2X,2I3,5X)))C-->	TYPE *,' 'C-->	TYPE *,' 'C=======================================================================CC	... Color -- 'CL'	IF(CDCNT(1).GT.0) THEN	   CALL CONCAT('Color: ')	   CALL ADDALL(1,STATUS)	   CALL CONCAT('|')	ENDIFCC	... Peak height/Integrated intensities	IF(NUMC(16) .GT. 0) THEN	   IF(CARDG(3:3) .EQ. 'P') 	1    CALL CONCAT('Peak height intensities.  ')	   IF(CARDG(3:3) .EQ. 'I')	1    CALL CONCAT('Integrated intensities.  ')	ENDIFCC	... O assigned because... -- 'OO'	IF(CDCNT(2).GT.0) THEN	   CALL ADDALL(2,STATUS)	ENDIFCC	... Temperature measured... -- 'TM'	IF(CDCNT(22).GT.0) THEN	   CALL ADDALL(22,STATUS)	ENDIFCC	... Additional Powder Reference -- 'PD'	IF(CDCNT(20).GT.0) THEN	   CALL ADDALL(20,STATUS)	ENDIFCC	... Sample/specimen from... -- 'SM'	IF(CDCNT(3).GT.0) THEN	   CALL ADDALL(3,STATUS)	ENDIFCC	... CAS #	IF(NUMC(5).GT.0 .AND. CARD5(1) (54:64) .NE. ' ')  THEN           STRING(1:11) = CARD5(1) (54:64)	   CALL LEFT (STRING(1:11), SIZE)	   SIZE = LENGTH (STRING(1:11))	   CALL CONCAT('CAS $NO: ' // STRING(1:SIZE) // '.  ')	ENDIFCC	... Preparation -- 'PR'	IF(CDCNT(4).GT.0) THEN	   CALL ADDALL(4,STATUS)	ENDIFCC	... Chemical Analysis -- 'AN'	IF(CDCNT(5).GT.0) THEN	   CALL ADDALL(5,STATUS)	ENDIFCC	... General Comments -- '  '	IF(CDCNT(6).GT.0) THEN	   CALL ADDALL(6,STATUS)	ENDIFCC	... Unit Cell Data -- 'UC'	IF(CDCNT(18).GT.0) THEN	   CALL ADDALL(18,STATUS)	ENDIFCC	... Sigma(Iobs) for exp., R-factor for Calc.	IF(NUMC(16).EQ.1 .AND. CARDG(28:32).NE.' ') THEN	   CALL LEFT(CARDG(28:32),SIZE)           SIZE = LENGTH (CARDG(28:32))	   IF(CARDG(1:1).EQ.'C') THEN	      CALL CONCAT('R-factor: ' // CARDG(28:28+SIZE-1) // '.  ')	   ELSE	      CALL CONCAT('$GS(I#o#b#s)=$PM' // 	1                 CARDG(28:28+SIZE-1) // '.  ')	   ENDIF	ENDIFCC	... Calculated Pattern Comments -- 'AT', 'TH', 'FF', 'SC'	IF(CDCNT(7).GT.0) THEN	   CALL ADDALL(7,STATUS)	ENDIF	IF(CDCNT(8).GT.0) THEN	   CALL ADDALL(8,STATUS)	ENDIF	IF(CDCNT(9).GT.0) THEN	   CALL ADDALL(9,STATUS)	ENDIF	IF(CDCNT(10).GT.0) THEN	   CALL ADDALL(10,STATUS)	ENDIFCC	... Polymorphism -- 'PM'	IF(CDCNT(11).GT.0) THEN	   CALL ADDALL(11,STATUS)	ENDIFCC	... Structure Analysis -- 'ST'	IF(CDCNT(12).GT.0) THEN	   CALL ADDALL(12,STATUS)	ENDIFCC	... Structure type	IF(NUMC(10) .EQ. 1) THEN	   L = LENGTH(CARDA(18:67))           IF(L .GT. 0) CALL CONCAT(CARDA(18:17+L) // ' ')	ENDIFCC	... Mineral Group/Subgroup	IF(NUMC(5).GE.1 .AND. CARD5(1)(3:3).EQ.'M') THEN	   IWARN = 0	   IERR  = 0	   CALL MINSUB(STATUS)	   IF(STATUS .NE. 0) THEN	      CALL ERRTXT ('E', 'Error in mineral group codes')	      STATUS = 1	   ENDIF	   IF(NUMGRP.EQ.0) GO TO 200	   NXTCHR = 1      	   DO 4030 N=1,NUMGRP	   I = LENGTH(GRPNAM(N))	   IF(I .EQ. 0) THEN	      I = 20	      CALL ERRTXT ('W','Mineral group name has leading blanks:')	      CALL ERRTXT ('C', '"' // GRPNAM(N) // '"')	   ENDIF	   LSTCHR = NXTCHR + 6 + I - 1	   STRING(NXTCHR:LSTCHR) = GRPNAM(N)(1:I) // ' group'	   NXTCHR = LSTCHR + 1	   I = LENGTH(SUBNAM(N))	   IF(I.GE.1) THEN	      LSTCHR = NXTCHR + 11 + I - 1	      STRING(NXTCHR:LSTCHR) = ', ' //	1                             SUBNAM(N)(1:I) //  ' subgroup'	      NXTCHR = LSTCHR + 1	   ENDIF	   LSTCHR = NXTCHR + 2	   STRING(NXTCHR:LSTCHR) = '.   '	   NXTCHR = LSTCHR + 14030	   CONTINUE	   CALL CONCAT(STRING(1:LSTCHR))	ENDIF200	CONTINUECC	... Also Called - Common or trivial name	IALSO = 14100	IALSO = IALSO + 1	IF(IALSO .LE. NUMC(6)) THEN	   IF(CARD6(IALSO) (69:69) .EQ. 'C') THEN	      CALL CONCAT('Also called: ')	      L =  LENGTH(CARD6(IALSO) (1:67))	      CALL CONCAT(CARD6(IALSO) (1:L))300	      IF(CARD6(IALSO) (70:70) .EQ. 'C') THEN	         IALSO = IALSO + 1	         L = LENGTH(CARD6(IALSO) (1:67))	         CALL CONCAT(' ' // CARD6(IALSO) (1:L) )	         GO TO 300	      ENDIF	      CALL CONCAT('.  ')	   ENDIF	GO TO 4100	ENDIFCC	... CD Cell	IF(.NOT.EQCELS .AND. NUMC(14).GT.0) THEN	   CALL PHCD(STRING,SIZE,STATUS)	   CALL CONCAT(STRING(1:SIZE))	   CALL CONCAT('  ')	ENDIFC	... Footnotes for hkl's -- 'HK'	IF(CDCNT(13).GT.0) CALL ADDFN (13, STATUS)CC	... Footnotes for the d's and I's -- 'FN'	IF(CDCNT(19).GT.0) CALL ADDFN (19, STATUS)CC	... Internal/external standard	IF(NUMC(15).GT.0 .AND. CARDF(57:57) .NE. ' ') THEN	IF(CARDF(50:55) .NE. ' ') THEN	   CALL PHSTD(STRING,CARDF(50:55),SIZE,NFLDS)	   CALL CONCAT( STRING(1:SIZE))	   IF(CARDF(57:57) .EQ. 'I') THEN	      IF(NFLDS .LE. 1) THEN	         CALL CONCAT(' used as internal standard.  ')	      ELSE	         CALL CONCAT(' used as internal standards.  ')	      ENDIF	   ELSE IF(CARDF(57:57) .EQ. 'E') THEN	      IF(NFLDS .LE. 1) THEN	         CALL CONCAT(' used as external standard.  ')	      ELSE	         CALL CONCAT(' used as external standards.  ')	      ENDIF	   ENDIF	ELSE	   IF(CARDF(57:57) .EQ. 'I') THEN	      CALL CONCAT('Internal standard used.  ')	   ELSE IF(CARDF(57:57) .EQ. 'E') THEN	      CALL CONCAT('External standard used.  ')	   ENDIF	ENDIF	ENDIFCC	... Single Crystal Data	IF(CARD1(1)(67:67) .EQ. 'S') THEN	   CALL CONCAT('Single-crystal data used.  ')CC	... Rietveld or profile fit analysis	ELSE IF(CARD1(1)(67:67) .EQ. 'R') THEN	   CALL CONCAT('Unit cell data determined by Rietveld ' //	1              'or profile fit analysis.  ')CC	... Electron diffraction data	ELSE IF(CARD1(1)(67:67) .EQ. 'E') THEN	   CALL CONCAT(	1  'Unit cell data determined by electron diffraction.  ')	ENDIFCC	... Pearson Code	IF(NUMC(10).GT.0 .AND.	1  CARDA(1:9).NE.' ' .AND.	2  CARDA(2:2).NE.'?' .AND. CARDA(3:9).NE.'9999.99') THEN	   CALL CMPRES(CARDA(1:9), L)C	   .. Drop the ".00" from the Pearson code	   IF(L .GE. 4) THEN	      IF(CARDA(L-2:L) .EQ. '.00') L = L - 3	   ELSE	      CALL ERRTXT ('W', 	1       'Pearson code may be incorrect: "' //CARDA(1:9) //'".')	   ENDIF	   IF(CARDA(10:10) .EQ. ' ')	1     CALL CONCAT('PSC: '  // CARDA(1:L) // '.  ')	   IF(CARDA(10:10) .EQ. 'E')	1     CALL CONCAT('PSC: [' // CARDA(1:L) // '].  ' )	ENDIFCC	... Additional pattern / replaces pattern -- 'AD'	IF(CDCNT(14).GT.0) THEN	   CALL ADDALL(14,STATUS)	ENDIF                                           CC	... "Deleted by ..." -- 'DB'	IF(CDCNT(21).GT.0) THEN	   CALL ADDALL(21,STATUS)	ENDIF                                           CC	... Additional Lines -- 'LN'	IF(CDCNT(15).GT.0) THEN	   CALL ADDALL(15,STATUS)	ENDIFCC	... Add any references that have not already been photocomposed	CALL ADDREF(STATUS)CC	 ... **Just for PC-PDF** Add Mwt and CD-cell volume	IF(NUMC(4) .GT. 0) THEN	   IF(CARD4(51:58) .NE. ' '  .AND.  CARD4(59:59) .NE. 'G') THEN	      MWT = CARD4(51:58)	      CALL LEFT (MWT, L)	      L = LENGTH (MWT)	      MWT(L+1:L+3) = '.  '	      CALL CONCAT ('Mwt: ')	      CALL CONCAT ( MWT(1:L+3) )	   ENDIF	   IF(CARD4(61:69) .NE. ' '  .AND.	1     CARD4(61:69) .NE. '     0.00') THEN	      VOLUME = CARD4(61:69)	      CALL LEFT (VOLUME, L)	      L = LENGTH (VOLUME)	      VOLUME(L+1:L+3) = '.  '	      CALL CONCAT ('Volume[CD]: ')	      CALL CONCAT ( VOLUME(1:L+3) )	   ENDIF	ENDIFCC	... Check for and convert any imbeded chemical formulasC	... (delimited by "\") and space groups (delimited by "`")	CALL CONCOM(STATUS)CC	... Compute the number of "cards" used above	IF(CHPHC.EQ.0) THEN	   NUMPHC = 0	   GO TO 700	ENDIFCC	... Divide up the comments onto individual cards	CALL DIVCOM700	CONTINUEC-->	DO 12345 I=1,NUMPHCC-->	SIZE = MIN0(STCRD(I+1)-1, CHPHC) - STCRD(I)C-->	TYPE *,I,STCRD(I),SIZEC-->12345	CONTINUE9000	STATUS = 0	CALL DESMOD ('PHBOX5')	RETURN	END