C	PROGRAM NBSENCODE
C
C	TO ENCODE THE NBS CRYSTAL-DATA DATA BASE INTO ONE-LINE, BINARY,
C	DIRECT-ACCESS FILE.
C
C
	BYTE ASPC,ORIENC,ZCODEC,DCODE,IX,OX,MX,AX,ELEM(200),CCONT,ICONT
	BYTE IRT(16),NRT,ISYS,STRUC,SOUR,EDIT,RAD,METRIC,IR,YEAR,ISET
	BYTE KSYMB(2)
	INTEGER*2 IAA(6),IAR(6),IVOLR,IAC(6),NSPGC,ICARD,COMP,QUAL,IZC
	INTEGER*2 IDMA,IDXA,IDMC,IDXC,MAT,FSYM(20),CHSYM(104),KSYM
	INTEGER*4 CHEM(104,2000)
	INTEGER ENTRY
	DIMENSION AA(6),AR(6),AC(6)
	CHARACTER*8 SPGC
	CHARACTER*15 JOURN
	CHARACTER*80 BUFFER
	EQUIVALENCE (MAT,IR)
	EQUIVALENCE (KSYM,KSYMB(1))
C
C
C
	DATA IRT/'1','2','3','4','5','6','7','8','9','A','B','C','D',
	1 'E','J','K'/

      DATA CHSYM/'H ','He','Li','Be','B ','C ','N ','O ','F ','Ne',
     1'Na','Mg','Al','Si','P ','S ','Cl','Ar','K ','Ca','Sc','Ti','V ',
     2'Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As','Se','Br','Kr',
     3'Rb','Sr','Y ','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In',
     4'Sn','Sb','Te','I ','Xe','Cs','Ba','La','Ce','Pr','Nd','Pm','Sm','
     5Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb','Lu','Hf','Ta','W ','Re','O
     6s','Ir','Pt','Au','Hg','Tl','Pb','Bi','Po','At','Rn','Fr','Ra',
     7'Ac','Th','Pa','U ','Np','Pu','Am','Cm','Bk','Cf','Es','Fm','Md',
     8 'No','Lw','Ln'/

	DATA ISIZEI/59613/,ISIZEO/56140/

C
C
	DO 800 ICD=1,2
	NCHEM=0
	NSAVE=0
	NREC2=0
	IERR=0
	IRECNO=0
	ENTRY=0
	DO 6 I=1,104
	DO 5 J=1,2000
	CHEM(I,J)=0
5	CONTINUE
6	CONTINUE
C
C
C
	IF (ICD.EQ.1) THEN
	OPEN (UNIT=1,NAME='CD:CRYSTI.DIRECT',STATUS='OLD',
	1 FORM='FORMATTED',ACCESS='DIRECT',RECL=80)
	OPEN (UNIT=2,NAME='CD:NBSI.BIN',STATUS='NEW',
	1 FORM='UNFORMATTED',ACCESS='DIRECT',RECL=32)
	OPEN (UNIT=3,NAME='CD:NBS.ERI',STATUS='NEW',FORM='FORMATTED')
	OPEN (UNIT=4,NAME='CD:CHEMI.BIN',STATUS='NEW',
	1 FORM='UNFORMATTED',ACCESS='DIRECT',RECL=2000)
	NSIZE=ISIZEI/32
	LAST=MOD(ISIZEI,32)
	IF (LAST.NE.0) NSIZE=NSIZE+1
	ENDIF
	IF (ICD.EQ.2) THEN
	OPEN (UNIT=1,NAME='CD:CRYSTO.DIRECT',STATUS='OLD',
	1 FORM='FORMATTED',ACCESS='DIRECT',RECL=80)
	OPEN (UNIT=2,NAME='CD:NBSO.BIN',STATUS='NEW',
	1 FORM='UNFORMATTED',ACCESS='DIRECT',RECL=32)
	OPEN (UNIT=3,NAME='CD:NBS.ERO',STATUS='NEW',FORM='FORMATTED')
	OPEN (UNIT=4,NAME='CD:CHEMO.BIN',STATUS='NEW',
	1 FORM='UNFORMATTED',ACCESS='DIRECT',RECL=2000)
	NSIZE=ISIZEO/32
	LAST=MOD(ISIZEO,32)
	IF (LAST.NE.0) NSIZE=NSIZE+1
	ENDIF
C


10	IRECNO=IRECNO+1
	READ (1,11,REC=IRECNO,ERR=700) BUFFER
11	FORMAT (A)
	DECODE (80,12,BUFFER(72:78)) N
12	FORMAT (I7)



C	IF N=NSAVE, PROCESS THE REMAINDER OF THE ENTRY UNTIL ALL
C	NECESSARY INFORMATION IS OBTAINED.

C	IF N<>NSAVE, WRITE OUT THE OLD ENTRY AND START A NEW ONE.


	IF (N.EQ.NSAVE) GO TO 200
	IF (N.NE.NSAVE.AND.ENTRY.GT.0) GO TO 710

15	NSAVE=N
	NREC=IRECNO
	IWORD=1+ENTRY/32
	IBITE=MOD(ENTRY,32)
	ENTRY=ENTRY+1
	COMP=0
	MAT=0


C	I CAN'T ALWAYS BE SURE THAT ALL OF THE NECESSARY CARDS WILL EXIST
C	FOR ANY ONE ENTRY.  TO INSURE THAT VARIABLES DON'T CARRY OVER FROM
C	ONE ENTRY TO THE NEXT, I HAVE DECIDED TO ZERO EVERYTHING.

	DO 100 I=1,6
	IAA(I)=0
	IAR(I)=0
	IAC(I)=0
100	CONTINUE
	IVOLR=0
	SPGC='        '
	NSPGC=0
	ASPC=' '
	IZC=0
	IDMC=0
	IDXC=0
	JOURN='               '
	YEAR=0
	ISET=0
	ICARD=0
	IPROC=0
	NCH=0
	DO 180 I=1,200
180	ELEM(I)=' '
	DO 190 I=1,20
190	FSYM(I)='  '
200	DECODE (80,205,BUFFER(80:80)) NRT
205	FORMAT (A1)
	DO 210 N=1,16
	IF (NRT.EQ.IRT(N)) GO TO 220
210	CONTINUE
	GO TO 500


220	GO TO (310,320,330,340,350,10,370,10,390,
	1 10,10,10,430,440,10,460) N

C	GET AUTHORS' CELL     (CARD 1)

310	DECODE (80,311,BUFFER(1:80),ERR=314) AA,EDIT,RAD,SOUR,STRUC,ISYS
311	FORMAT (3F9.5,3F8.3,A1,12X,A1,1X,A1,1X,A1,9X,A1)
	IF (ISYS.EQ.'C'.OR.ISYS.EQ.'T'.OR.ISYS.EQ.'H'.OR.ISYS.EQ.'R')
	1 AA(2)=AA(1)
	IF (ISYS.EQ.'C') AA(3)=AA(1)
	IF (AA(4).EQ.0.0) AA(4)=90.00
	IF (AA(5).EQ.0.0) AA(5)=90.00
	IF (AA(6).EQ.0.0.AND.(ISYS.EQ.'H'.OR.ISYS.EQ.'R')) AA(6)=120.00
	IF (AA(6).EQ.0.0) AA(6)=90.00
	DO 313 I=1,6
	IF (AA(I).GT.320.0) THEN
	WRITE (3,905) NREC,NSAVE,AA
905	FORMAT (' *****ERRONEOUS AUTHOR CELL IN RECORD: 'I7,5X,
	1' ENTRY: 'I7,/6F10.3)
	AA(I)=-1.0
	ENDIF
312	IAA(I)=NINT(100.0*AA(I))
313	CONTINUE

C	SET BITS 0-9 AND 14-15 OF COMP

	IF (RAD.EQ.'X'.OR.RAD.EQ.'E') COMP=IBSET(COMP,0)
	IF (RAD.EQ.'N'.OR.RAD.EQ.'E') COMP=IBSET(COMP,1)
	IF (RAD.EQ.'G') COMP=IBSET(COMP,2)
	IF (SOUR.EQ.'S'.OR.SOUR.EQ.'R') COMP=IBSET(COMP,3)
	IF (SOUR.EQ.'P'.OR.SOUR.EQ.'R') COMP=IBSET(COMP,4)
	IF (STRUC.EQ.'L') COMP=IBSET(COMP,5)
	IF (STRUC.EQ.'T') COMP=IBSET(COMP,6)
	IF (ISYS.EQ.'A'.OR.ISYS.EQ.'O'.OR.ISYS.EQ.'H'.OR.ISYS.EQ.'C')
	1  COMP=IBSET(COMP,7)
	IF (ISYS.EQ.'M'.OR.ISYS.EQ.'O'.OR.ISYS.EQ.'R'.OR.ISYS.EQ.'C')
	1 COMP=IBSET(COMP,8)
	IF (ISYS.EQ.'T'.OR.ISYS.EQ.'H'.OR.ISYS.EQ.'R'.OR.ISYS.EQ.'C')
	1 COMP=IBSET(COMP,9)
	IF (EDIT.EQ.'T') COMP=IBSET(COMP,14)
	IF (EDIT.EQ.'P') COMP=IBSET(COMP,15)
	GO TO 10

314	DO 315 I=1,6
315	AA(I)=-1
	DECODE (80,316,BUFFER(52:80)) EDIT,RAD,SOUR,STRUC,ISYS
316	FORMAT (A1,12X,A1,1X,A1,1X,A1,9X,A1)
	GO TO 312

C	GET QUALITY CODE      (CARD 2)

320	DECODE (80,321,BUFFER(59:60)) QUAL
321	FORMAT (A2)

C	SET BITS 10-13 OF COMP

	IF (QUAL.EQ.'A '.OR.QUAL.EQ.'B '.OR.QUAL.EQ.'C '.OR.QUAL.EQ.'F')
	1 COMP=IBSET(COMP,10)
	IF (QUAL.EQ.'A-'.OR.QUAL.EQ.'C-'.OR.QUAL.EQ.'D ')
	1 COMP=IBSET(COMP,11)
	IF (QUAL.EQ.'C '.OR.QUAL.EQ.'C-'.OR.QUAL.EQ.'D ')
	1 COMP=IBSET(COMP,12)
	IF (QUAL.EQ.'D-'.OR.QUAL.EQ.'F ') COMP=IBSET(COMP,13)
	GO TO 10

C	GET AUTHORS' SPACE GROUP AND STUFF    (CARD 3)

330	DECODE (80,331,BUFFER(20:69)) ZA,DMA,DXA,VOLA
331	FORMAT (F6.0,4X,F6.3,2X,F6.3,17X,F9.2)
C	WRITE (3,908) ZA,DMA,DXA
C908	FORMAT (' ZA,DMA,DXA = '3F8.3)
	IDMA=1000*DMA
	IDXA=1000*DXA
	GO TO 10

C	GET CRYSTAL DATA SPACE GROUP AND STUFF    (CARD 4)

340	DECODE (80,341,BUFFER(1:69)) SPGC,ASPC,NSPGC,ORIENC,ZC,
	1 ZCODEC,DMC,DXC,DCODE,FORMWT,VOLC
341	FORMAT (A,2X,A1,I3,A1,4X,F6.0,A1,3X,F5.2,3X,F6.3,
	1 A1,6X,F8.2,2X,F9.2)
C	WRITE (3,907) ZC,DMC,DXC
C907	FORMAT (' ZC,DMC,DXC = '3F8.3)
	IF (ZC.LT.0.0.OR.ZC.GT.320.0) THEN
	WRITE (3,904) ZC,NREC,NSAVE
904	FORMAT (' ***** ERRONEOUS VALUE OF ZC -- 'F10.3,5X,
	1 ' RECORD: 'I7,5X,' ENTRY: 'I7)
	ZC=0.0
	ENDIF
	IZC=100*ZC
	IF (DMC.GT.30.00) THEN
	WRITE (3,901) DMC,NREC,NSAVE
901	FORMAT (' *****ERRONEOUS VALUE FOR DMC -- 'F8.3,5X,
	1 'RECORD: 'I7,5X,' ENTRY: 'I7)
	DMC=0.0
	ENDIF
	IF (DXC.GT.30.00) THEN
	WRITE (3,902) DXC,NREC,NSAVE
902	FORMAT (' *****ERRONEOUS VALUE FOR DXC -- 'F8.3,5X,
	1 'RECORD: 'I7,5X,' ENTRY: 'I7)
	DXC=0.0
	ENDIF
	IDMC=1000*DMC
	IDXC=1000*DXC
	IF (ASPC.EQ.'*') NSPGC=-NSPGC
	GO TO 10


C	GET MATERIAL, CLASS, AND REGISTRATION INDICATORS

350	DECODE (80,351,BUFFER(71:71)) ICONT
351	FORMAT (I1)
	IF (ICONT.GT.1) GO TO 10
	DECODE (80,352,BUFFER(1:4)) IX,OX,MX,AX
352	FORMAT (4A1)

C	SET BITS 0-3 OF MAT

	IF (IX.EQ.'I') MAT=IBSET(MAT,8)
	IF (OX.EQ.'O') MAT=IBSET(MAT,9)
	IF (MX.EQ.'M') MAT=IBSET(MAT,10)
	IF (AX.EQ.'A') MAT=IBSET(MAT,11)
	GO TO 10

C	GET COMPOUND NAME  (CARD 6)


C	GET CHEMICAL FORMULA  (CARD 7)

370	DECODE (80,371,BUFFER(70:71)) CCONT,ICONT
371	FORMAT(A1,I1)
	IF (ICONT.GT.1) GO TO 10
	IF (IPROC.EQ.1) GO TO 10
	IPROC=1
	DECODE (80,372,BUFFER(1:67)) (ELEM(I),I=1,67)
372	FORMAT (67A1)
	L=LENGTH(ELEM,67)

C	I'M WILLING TO LOOK FOR ONE CONTINUATION CHEMISTRY CARD -- NO MORE
C	THERE ARE SOME ODD CARDS UNDER THIS CATEGORY THAT I WISH TO AVOID.

	IF (CCONT.EQ.'C'.AND.ICONT.EQ.1) THEN
	IRECNO=IRECNO+1
	READ (1,11,REC=IRECNO,ERR=700) BUFFER
	IB=L+1
	IE=IB+66
	DECODE (80,372,BUFFER(1:71)) (ELEM(I),I=IB,IE)
	L=LENGTH(ELEM,IE)
	ENDIF
	IF (L.EQ.0) THEN
	WRITE (3,779) NREC,NSAVE
	GO TO 10
	ENDIF
	DO 889 I=1,(L-1)
	IF (ELEM(I).EQ.'T'.AND.ELEM(I+1).EQ.'R') THEN
	ELEM(I)='L'
	ELEM(I+1)='n'
	ENDIF
889	CONTINUE
891	CALL ELEMENTS (L,ELEM,NCH,FSYM)
d	WRITE (5,887) (ELEM(I),I=1,L)
d887	FORMAT (' ELEM :'/3(1X,80A1))
d	WRITE (5,888) (FSYM(I),I=1,NCH)
d888	FORMAT (' FSYM = '20(1X,A2))
	IF (NCH.EQ.0) THEN
	WRITE (3,779) NREC,NSAVE
779	FORMAT (' NO CHEMICAL INFORMATION FOR RECORD: '
	1 I7,5X,'ENTRY: 'I7)
	ENDIF
	DO 376 I=1,NCH
373	DO 374 J=1,104
	IF (FSYM(I).EQ.CHSYM(J)) THEN
	CHEM(J,IWORD)=IBSET(CHEM(J,IWORD),IBITE)
	IF (J.GE.57.AND.J.LE.71) CHEM(104,IWORD)=
	1 	IBSET(CHEM(104,IWORD),IBITE)
	IF (J.EQ.104) THEN
		DO 384 K=57,71
384		CHEM(K,IWORD)=IBSET(CHEM(K,IWORD),IBITE)
	ENDIF
	GO TO 376
	ENDIF
374	CONTINUE
	IF (FSYM(I).EQ.'D '.OR.FSYM(I).EQ.'T ') THEN
	CHEM(1,IWORD)=IBSET(CHEM(1,IWORD),IBITE)
	GO TO 376
	ENDIF
C	Some symbols are not recognizable, e.g. A M Q X Z
C	Some are followed by 'n' as in Kn and Un. These should be reduced
C	to K and U.
	KSYM=FSYM(I)
	IF (KSYMB(2).EQ.'n') THEN
	KSYMB(2)=' '
	FSYM(I)=KSYM
	GO TO 373
	ENDIF
	WRITE (3,375) FSYM(I),NREC,NSAVE
375	FORMAT (' SOMETHING STRANGE ABOUT THIS SYMBOL: 'A2,5X,
	1 'RECORD: 'I7,5X,'ENTRY: 'I7)
376	CONTINUE

	IF (L.GT.47)  NCHEM=NCHEM+1
	IF (L.GT.47)  ELEM(47)='*'
	GO TO 10


C	GET EMPIRICAL FORMULA    (CARD 8)


C	GET REFERENCE   (CARD 9)

390	DECODE (80,351,BUFFER(71:71)) ICONT
	IF (ICONT.GT.1) GO TO 10
	DECODE (80,391,BUFFER(1:20)) JOURN,IYR
391	FORMAT (A,1X,I4)
	IF (IYR.EQ.0) THEN
	YEAR=0
	GO TO 10
	ENDIF
	IF (IYR.GT.2000.OR.IYR.LT.1800) THEN
	WRITE (3,903) IYR,NREC,NSAVE
903	FORMAT (' *****ERRONEOUS VALUE FOR IYR -- 'I4,5X,
	1 ' RECORD: 'I7,5X,' ENTRY: 'I7)
	IYR=1800
	ENDIF
	YEAR=IYR-1900
	GO TO 10


C	GET STRUCTURE TYPE   (CARD A)


C	GET COMMENT CARDS    (CARD B)


C	GET MATRIX    (CARD C)


C	GET REDUCED CELL     (CARD D)

430	DECODE (80,431,BUFFER(1:68)) AR,VOLR,IR,METRIC
431	FORMAT (3F8.3,3F7.2,F9.2,11X,I2,A1)
	DO 432 I=1,6
	IF (AR(I).GT.320.0) THEN
	WRITE (3,909) NREC,NSAVE,AR
909	FORMAT (' *****ERRONEOUS REDUCED CELL IN RECORD: 'I7,5X,
	1' ENTRY: 'I7,/6F10.3)
	AR(I)=-1
	ENDIF
	IAR(I)=NINT(100.0*AR(I))
432	CONTINUE
	IF (VOLR.GT.32000.0) VOLR=-1.0
	IVOLR=NINT(VOLR)
	IF (METRIC.EQ.'X') IR=-IR
	GO TO 10


C	GET CRYSTAL DATA CELL     (CARD E)

440	DECODE (80,441,BUFFER(1:45)) AC
441	FORMAT (3F8.3,3F7.2)
	DO 442 I=1,6
	IF (AC(I).GT.320.0) THEN
	WRITE (3,906) NREC,NSAVE,AC
906	FORMAT (' *****ERRONEOUS CRYST-DAT CELL IN RECORD: 'I7,5X,
	1' ENTRY: 'I7,/6F10.3)
	AC(I)=-1
	ENDIF
	IAC(I)=NINT(100.0*AC(I))
442	CONTINUE
	GO TO 10


C	UPDATE OR REVISION INFORMATION     (CARD J)


C	GET PDF NUMBER    (CARD K)

460	DECODE (80,462,BUFFER(51:57),ERR=463) ISET,ICARD
462	FORMAT (I3,I4)
	GO TO 10
463	ISET=0
	ICARD=0
	GO TO 10


C
C
C
C


500	WRITE (5,502) IRECNO
502	FORMAT (' ERROR OCCURRED WHILE DECODING RECORD # 'I8,
	1 /' ***** PROCESSING ABORTED *****')


700	IERR=1
710	NREC2=NREC2+1
	WRITE (2,REC=NREC2) IAA,IAR,IAC,IVOLR,SPGC,NSPGC,IDMA,IDXC,
	1 JOURN,YEAR,ISET,ICARD,IZC,COMP,MAT,NREC,(ELEM(I),I=1,47)
	IF (IERR.EQ.0) GO TO 15
	DO 740 I=1,104
740	WRITE (4,REC=I) (CHEM(I,J),J=1,2000)
	WRITE (6,730) NCHEM
730	FORMAT (' NCHEM = ',I10)
	CLOSE (UNIT=1)
	CLOSE (UNIT=2)
	CLOSE (UNIT=3)
	CLOSE (UNIT=4)
800	CONTINUE


	STOP
	END
	SUBROUTINE ELEMENTS(L,FORM,NCH,FSYM)
C
C	READS A LINE OF FORMULA AND PICKS OUT THE ELEMENTS PRESENT
C

C
      INTEGER*2 FSYM(20),MTEST
      BYTE FORM(200),ISYM(2)
      EQUIVALENCE(MTEST,ISYM)
      DO 100 K=1,20
100   FSYM(K)='  '
      J=1
      NCH=0
      ISYM(1)=' '
      ISYM(2)=' '
200   IF(FORM(J).GE.'A'.AND.FORM(J).LE.'Z')GO TO 210
      J=J+1
      IF(J.GT.L)GO TO 300
      GO TO 200
210   ISYM(1)=FORM(J)
      J=J+1
      IF(J.GT.L)GO TO 230
      IF(FORM(J).GE.'a'.AND.FORM(J).LE.'z')ISYM(2)=FORM(J)
C	
C	MUST AVOID THINGS LIKE Nx AND Oz  -- TR'S HAVE BEEN CHANGED TO Ln's
C
      IF(FORM(J).EQ.'x'.OR.FORM(J).EQ.'z') ISYM(2)=' '
230   IF(NCH.EQ.0)GO TO 260
      DO 250 K=1,NCH
250   IF(MTEST.EQ.FSYM(K))GO TO 270
260   NCH=NCH+1
      FSYM(NCH)=MTEST
      IF(NCH.GE.20)GO TO 300
270   ISYM(1)=' '
      ISYM(2)=' '
      J=J+1
      IF(J.GT.200)GO TO 300
      GO TO 200
300   NSYM=NCH
      RETURN
      END


	SUBROUTINE UPCASE (LC,UC,NCHAR)
C*********************************************************************

C	CONVERT FROM LOWER CASE TO UPPER CASE.
C	STORE LOWER CASE ARRAY IN LC.
C	STORE UPPER CASE ARRAY IN UC.
C	NCHAR IS THE NUMBER OF CHARACTERS TO CONVERT.
C
	LOGICAL*1 LC(1),UC(1)
	DO 100 I=1,NCHAR
	UC(I)=LC(I)
	IF(UC(I).GE."141.AND.UC(I).LE."172) UC(I)=UC(I)-"040
100	CONTINUE
	RETURN
	END




      FUNCTION LENGTH (STRING,MAXLEN)
C*********************************************************************

C          ROUTINE TO FIND THE LENGTH OF A CHARACTER STRING.
C          THE LENGTH IS DEFINED AS THE POSITION OF THE LAST
C          NON-BLANK CHARACTER.  LENGTH=0 IF STRING IS BLANK.
C
      IMPLICIT  INTEGER (A-Z)
      BYTE STRING(MAXLEN)
C
      DO 400 I=MAXLEN,1,-1
      IF(STRING(I) .NE. ' ') THEN
         LENGTH = I
         RETURN
      ENDIF
400   CONTINUE

      LENGTH = 0
      RETURN
      END
