SUBROUTINE CODE(X,N,Y)
C
C     PURPOSE--THIS SUBROUTINE CODES THE ELEMENTS 
C              OF THE INPUT VECTOR X
C              AND PUTS THE CODED VALUES INTO THE OUTPUT VECTOR Y.
C              THE CODING IS AS FOLLOWS--
C              THE MINIMUM IS CODED AS 1.0.
C              THE NEXT LARGER VALUE AS 2.0,
C              THE NEXT LARGER VALUE AS 3.0,
C              ETC. 
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR
C                                OF OBSERVATIONS TO BE CODED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X. 
C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE CODED VALUES
C                                WILL BE PLACED.
C     OUTPUT--THE SINGLE PRECISION VECTOR Y
C             WHICH WILL CONTAIN THE CODED VALUES 
C             CORRESPONDING TO THE OBSERVATIONS IN
C             THE VECTOR X.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
C                   FOR THIS SUBROUTINE IS 15000. 
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     COMMENT--ALL OCCURRANCES OF THE MINIMUM ARE CODED AS 1.0;
C              ALL OCCURANCES OF THE NEXT LARGER VALUE
C              ARE CODED AS 2.0;
C              ALL OCCURANCES OF THE NEXT LARGER VALUE
C              ARE CODED AS 3.0, ETC.
C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
C     REFERENCES--NONE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-2315
C     ORIGINAL VERSION--OCTOBER  1975.
C     UPDATED         --NOVEMBER 1975.
C     UPDATED         --JUNE     1977.
C
C---------------------------------------------------------------------
C
      DIMENSION X(1),Y(1)
      DIMENSION DIST(15000)
      COMMON /BLOCK2/ WS(15000)
      EQUIVALENCE (DIST(1),WS(1))
C
      IPR=6
      IUPPER=15000
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1.OR.N.GT.IUPPER)GOTO50
      IF(N.EQ.1)GOTO55
      HOLD=X(1)
      DO60I=2,N
      IF(X(I).NE.HOLD)GOTO90
   60 CONTINUE
      WRITE(IPR, 9)HOLD
      DO61I=1,N
      Y(I)=I
   61 CONTINUE
      RETURN
   50 WRITE(IPR,17)IUPPER
      WRITE(IPR,47)N
      RETURN
   55 WRITE(IPR,18) 
      Y(1)=1.0
      RETURN
   90 CONTINUE
    9 FORMAT(1H ,109H***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUME
     1NT (A VECTOR) TO THE CODE   SUBROUTINE HAS ALL ELEMENTS = ,E15.8,6
     1H *****)
   17 FORMAT(1H , 98H***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE
     1 CODE   SUBROUTINE IS OUTSIDE THE ALLOWABLE (1,,I6,16H) INTERVAL *
     1****)
   18 FORMAT(1H ,100H***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUME
     1NT TO THE CODE   SUBROUTINE HAS THE VALUE 1 *****)
   47 FORMAT(1H , 35H***** THE VALUE OF THE ARGUMENT IS ,I8   ,6H *****)
C
C-----START POINT-----------------------------------------------------
C
C     PERFORM THE CODING--
C     PULL OUT THE DISTINCT VALUES,
C     THEN SORT (AND ESSENTIALLY RANK) THE DISTINCT VALUES, 
C     THEN APPLY THE RANKS TO ALL THE VALUES.
C
      NUMDIS=1
      DIST(NUMDIS)=X(1)
      DO100I=2,N
      DO200J=1,NUMDIS
      IF(X(I).EQ.DIST(J))GOTO100
  200 CONTINUE
      NUMDIS=NUMDIS+1
      DIST(NUMDIS)=X(I)
  100 CONTINUE
C
      CALL SORT(DIST,NUMDIS,DIST)
C
      DO600I=1,N
      DO700J=1,NUMDIS
      IF(X(I).EQ.DIST(J))GOTO750
  700 CONTINUE
      WRITE(IPR,705)
      WRITE(IPR,710)I,X(I)
  705 FORMAT(1H ,'*****INTERNAL ERROR IN CODE SUBROUTINE')
  710 FORMAT(1H ,'NO CODE FOUND FOR ELEMENT NUMBER ',I5,' = ',F15.7)
      RETURN
  750 Y(I)=J
  600 CONTINUE
C
C     WRITE OUT A FEW LINES OF SUMMARY INFORMATION ABOUT THE CODING.
C
      WRITE(IPR,999)
      WRITE(IPR,905)
      WRITE(IPR,906)NUMDIS
      WRITE(IPR,999)
      WRITE(IPR,910)
      DO900I=1,NUMDIS
      AI=I
      WRITE(IPR,915)DIST(I),AI
  900 CONTINUE
  905 FORMAT(1H ,'OUTPUT FROM THE CODE SUBROUTINE')
  906 FORMAT(1H ,'NUMBER OF DISTINCT CODE VALUES = ',I8)
  999 FORMAT(1H )
  910 FORMAT(1H ,8X,'VALUE     CODED VALUE')
  915 FORMAT(1H ,F15.7,6X,F6.0)
C
      RETURN
      END