C   PACKNIH.FTN
C  PROGRAM TO PACK NIH ELEMENTAL DATA BASE FOR XRF
C     ELEMENTAL SEARCH/MATCH
C
C   COPYRIGHT 1982 GENERAL ELECTRIC CO.
C      WRITTEN MARCH 1982  M.F.GARBAUSKAS
C
C   MAXIMUM WAVELENGTH: 25 ANGSTROMS
C   MINIMUM RELATIVE INTENSITY: 0.06
C   MAXIMUM NUMBER OF LINES PER ELEMENT: 75
C
C   INTENSITY AND WAVELENGTH CUTOFFS DETERMINED IN 'IF' STATEMENTS
C   LINE NUMBER DETERMINED BY DIMENSION OF ARRAYS AND RECORDSIZE
C    OF OUTPUT FILE AS WELL AS 'IF' STATEMENTS
C
C    TASKBUILD OPTIONS: MAXBUF=1100
C
      REAL*8 LINE(75),L
      DIMENSION WAVE(75)
      DIMENSION INT(75)
      OPEN(UNIT=1,NAME='MASTER.TRS',TYPE='OLD',READONLY)
C PDP 11 LENGTH = .5 + 75 + 37.5 + 150 = 263
C VAX LENGTH = 1 + 75 + 75 + 150 = 301
      OPEN(UNIT=2,NAME='LAMBDA.NIH',TYPE='NEW',ACCESS='DIRECT'
     % ,RECORDSIZE=301)
CPDP11     % ,RECORDSIZE=263)
C
      K=1
      NREC=1
100   READ(1,9100,END=900,ERR=800)IZ,IEL,L,ITEST,W,RELINT
9100  FORMAT(I2,1X,A2,1X,A8,1X,A2,2X,F12.8,1X,F7.3)
200   IF(K.EQ.1)IOLD=IZ
      IF(IOLD.NE.IZ)GO TO 500
      IF(ITEST.EQ.'AB')GO TO 100
      IF(RELINT.LT.0.06)GO TO 100
      IF(W.GT.25.)GO TO 100
      WAVE(K)=W
      LINE(K)=L
      INT(K)=100.*RELINT
      K=K+1
      IF(K.LE.75)GO TO 100
      WRITE(5,9500)IZ
9500  FORMAT(' * LINE COUNT EXCEEDED FOR ELEMENT NO. ',I3)
      STOP
500   K=K-1
      WRITE(2'NREC)IOLD,WAVE,INT,LINE
      NREC=NREC+1
      WRITE(5,9600)IOLD,K
9600  FORMAT(' * ELEMENT NO. ',I3,' HAS ',I3,' LINES STORED')
      DO 550 I=1,75
      WAVE(I)=0.
      INT(I)=0.
      LINE(I)='        '
550   CONTINUE
      K=1
      GO TO 200
800   WRITE(5,9800)IZ,K
9800  FORMAT(' * ERROR READING ELEMENT NO. ',I3,' LINE NO. ',I3)
      STOP
900   NREC=NREC-1
      WRITE(5,9900)NREC
9900  FORMAT(' * RECORDS IN FILE:',I3)
      CLOSE(UNIT=1)
      CLOSE(UNIT=2)
      STOP
      END
