C	PROGRAM NBSDIRECT
C
C	TO SET UP ONE-LINE FILE FROM COMPLETE DATA BASE
C	AND TO CONVERT THE SEQUENTIAL DATA-BASE FILES TO A DIRECT ACCESS
C	FILES.
C
	LOGICAL ASCEND
	CHARACTER*80 BUFFER
	BYTE IRT(16),NRT,ISYS,ISC
	INTEGER ENTRY,ORDER
	CHARACTER*20 JOURN
	CHARACTER*54 ELEM
	COMMON/LINE/ A(6),IV,NSPGR,ISYS,ISC,NREC,JOURN,ELEM
C
	DATA IRT/'1','2','3','4','5','6','7','8','9','A','B','C','D',
	1 'E','J','K'/
C
C
C
	NSAVE=0
	DO 800 ICD=1,2
	IRECNO=0
	ENTRY=-1
	IF (ICD.EQ.1) THEN
	OPEN (UNIT=1,NAME='CRYST.INORG',FORM='FORMATTED',STATUS='OLD')
	OPEN (UNIT=2,NAME='CRYSTI.DIRECT',STATUS='NEW',ACCESS='DIRECT',
	1 FORM='FORMATTED',RECL=80)
	OPEN (UNIT=4,NAME='NBSI.;',STATUS='NEW',
	1 ACCESS='DIRECT',FORM='FORMATTED',RECL=132)
	ENDIF
	IF (ICD.EQ.2) THEN
	OPEN (UNIT=1,NAME='CRYST.ORG',FORM='FORMATTED',STATUS='OLD')
	OPEN (UNIT=2,NAME='CRYSTO.DIRECT',STATUS='NEW',ACCESS='DIRECT',
	1 FORM='FORMATTED',RECL=80)
	OPEN (UNIT=4,NAME='NBSO.;',STATUS='NEW',
	1 ACCESS='DIRECT',FORM='FORMATTED',RECL=132)
	ENDIF
10	READ (1,11,END=500) BUFFER
11	FORMAT (A)
	IRECNO=IRECNO+1
	DECODE (80,15,BUFFER(72:78)) N
15	FORMAT(I7)
C
C	IF N=NSAVE, PROCESS THE REMAINDER OF ENTRY UNTIL ALL NECESSARY
C	INFORMATION IS OBTAINED.
C
C	IF N<>NSAVE, WRITE OUT OLD ENTRY AND START A NEW ENTRY
C
	IF (N.EQ.NSAVE) GO TO 200
	ENTRY=ENTRY+1
	IF (ENTRY.GT.0) WRITE (4,12,REC=ENTRY) A,IV,NSPGR,ISYS,ISC,
	1 NREC,JOURN,ELEM
12	FORMAT (3F6.2,3F6.1,I6,I4,1X,2A1,I6,1X,A,1X,A)
	NSAVE=N
	NREC=IRECNO
	IF(ENTRY.GT.200000) GO TO 400
C
C	BE SURE THIS IS RECORD TYPE 1
C
	DECODE (80,16,BUFFER(80:80)) NRT
16	FORMAT (A1)
	IF (NRT.NE.IRT(1)) GO TO 350
C
C	GET STRUCTURE CODE AND CRYSTAL SYSTEM CODE
C
	DECODE (80,16,BUFFER(69:69)) ISC
	DECODE (80,16,BUFFER(79:79)) ISYS
C
C
	WRITE (2,11,REC=IRECNO) BUFFER
D	WRITE (6,999) ENTRY,IREC(ENTRY),ICODE(ENTRY)
D999	FORMAT (' ENTRY,IREC,ICODE ='3I10)
	GO TO 10
C
C
C	FIND OUT WHAT CARD WE ARE DEALING WITH AND PICK UP APPROPRIATE
C	INFORMATION.
C
200	DECODE (80,16,BUFFER(80:80)) NRT
	DO 210 I=2,16
	IF (NRT.EQ.IRT(I)) GO TO 220
210	CONTINUE
	GO TO 350
C
220	GO TO (300,300,300,230,300,300,240,300,260,
	1 300,300,300,280,300,300,300) I
C
C	GET SPACE GROUP NUMBER
C
230	DECODE (80,232,BUFFER(12:14)) NSPGR
232	FORMAT (I3)
	GO TO 300
C
C	GET CHEMICAL FORMULA
C
240	DECODE (80,241,BUFFER(71:71)) ICONT
241	FORMAT (I1)
	IF (ICONT.GE.2) GO TO 300
	DECODE (80,242,BUFFER(1:54)) ELEM
242	FORMAT (A)
	GO TO 300
C
C	GET REFERENCE
C
260	DECODE (80,241,BUFFER(71:71)) ICONT
	IF (ICONT.GE.2) GO TO 300
	DECODE (80,242,BUFFER(1:20)) JOURN
	GO TO 300
C
C	GET REDUCED CELL
C
280	DECODE (80,282,BUFFER(1:54)) A,V
282	FORMAT(3F8.3,3F7.2,F9.2)
	IV=NINT(V)
	IF (IV.GT.99999) IV=99999
C
300	WRITE (2,11,REC=IRECNO) BUFFER
	GO TO 10
C
C
C
350	WRITE (6,352) ENTRY
352	FORMAT (' ENTRY 'I6' DOES NOT HAVE RECORD TYPE 1 AS THE'
	1 ' FIRST RECORD'/' ***** PROCESSING IS ABORTED *****')
	GO TO 900
C
400	WRITE (6,402)
402	FORMAT (' ***** WARNING -- THE NUMBER OF ENTRIES HAS EXCEEDED'
	1 ' THE DIMENSIONS *****')
C
C	WRITE OUT LAST RECORD INTO ONE-LINE FILE AND CLOSE FILES
C
500	ENTRY=ENTRY+1
	WRITE (4,12,REC=ENTRY) A,IV,NSPGR,ISYS,ISC,NREC,JOURN,ELEM
	IF (ICD.EQ.1) WRITE (6,502) ENTRY
502	FORMAT (' THIS PROGRAM HAS PROCESSED 'I6' INORGANIC ENTRIES')
	IF (ICD.EQ.2) WRITE (6,504) ENTRY
504	FORMAT (' THIS PROGRAM HAS PROCESSED 'I6' ORGANIC ENTRIES')
	CLOSE (UNIT=1)
	CLOSE (UNIT=2)
	CLOSE (UNIT=4)
800	CONTINUE
900	CONTINUE
C
	STOP
	END
