C
C This subroutine removes missing values before
C calling SPCORR. It keeps count of the missing
C values via NMSG. 
C
       SUBROUTINE SPCORRZ(X,Y,N,IWRITE,SPC,HASXMSG,XMSG,
     +                    HASYMSG,YMSG,NMSG)
C INPUT
       INTEGER N, IWRITE
       INTEGER HASXMSG, HASYMSG
       DOUBLE PRECISION X(N), Y(N), XMSG,YMSG
C OUTPUT
       DOUBLE PRECISION SPC
       INTEGER NMSG
C
C LOCAL
       INTEGER NN, K
       DOUBLE PRECISION XX(N), YY(N)

       IF(HASXMSG.EQ.0.AND.HASYMSG.EQ.0) THEN
          CALL SPCORR(X,Y,N,IWRITE,SPC)
          NMSG = 0
       ELSE
          NN   = 0
          DO K=1,N
             IF (.NOT.((HASXMSG.EQ.1.AND.X(K).EQ.XMSG) .OR. 
     +                 (HASYMSG.EQ.1.AND.Y(K).EQ.YMSG))) THEN
                NN = NN+1
                XX(NN) = X(K)
                YY(NN) = Y(K)
             END IF
          END DO
          IF (NN.GT.0) THEN
             CALL SPCORR(XX,YY,NN,IWRITE,SPC)
          END IF
          NMSG = N - NN
       END IF
       RETURN
       END
C NCLFORTSTART
      SUBROUTINE SPCORR(X,Y,N,IWRITE,SPC)
C                                                  INPUT
      INTEGER N, IWRITE
      DOUBLE PRECISION X(N), Y(N)
C                                                  OUTPUT
      DOUBLE PRECISION SPC
C NCLEND
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SPEARMAN RANK CORRELATION COEFFICIENT
C              BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y.
C              THE SPEARMAN RANK CORRELATION COEFFICIENT WILL BE A
C              SINGLE PRECISION VALUE BETWEEN -1.0 AND 1.0
C              (INCLUSIVELY).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE SECOND SET
C                                OF DATA.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X, OR EQUIVALENTLY,
C                                THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C                     --IWRITE = AN INTEGER FLAG CODE WHICH
C                                (IF SET TO 0) WILL SUPPRESS
C                                THE PRINTING OF THE
C                                SPEARMAN RANK CORRELATION COEFFICIENT
C                                AS IT IS COMPUTED;
C                                OR (IF SET TO SOME INTEGER
C                                VALUE NOT EQUAL TO 0),
C                                LIKE, SAY, 1) WILL CAUSE
C                                THE PRINTING OF THE
C                                SPEARMAN CORRELATION COEFFICIENT
C                                AT THE TIME IT IS COMPUTED.
C     OUTPUT ARGUMENTS--SPC    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SPEARMAN RANK CORRELATION
C                                COEFFICIENT BETWEEN THE 2 SETS OF DATA
C                                IN THE INPUT VECTORS X AND Y.
C                                THIS SINGLE PRECISION VALUE
C                                WILL BE BETWEEN -1.0 AND 1.0
C                                (INCLUSIVELY).
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SPEARMAN RANK CORRELATION COEFFICIENT BETWEEN THE 2 SETS
C             OF DATA IN THE INPUT VECTORS X AND Y.
C     PRINTING--NONE, UNLESS IWRITE HAS BEEN SET TO A NON-ZERO
C               INTEGER, OR UNLESS AN INPUT ARGUMENT ERROR
C               CONDITION EXISTS.
C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
C                   FOR THIS SUBROUTINE IS 7500.
C     OTHER DATAPAC   SUBROUTINES NEEDED--RANK AND SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 2, EDITION 1, 1961, PAGES 476-477.
C               --SNEDECOR AND COCHRAN, STATISTICAL METHODS,
C                 EDITION 6, 1967, PAGES 193-195.
C               --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL
C                 ANALYSIS, EDITION 2, 1957, PAGES 294-295.
C               --MOOD AND GRABLE, 'INTRODUCTION TO THE THEORY
C                 OF STATISTICS, EDITION 2, 1963, PAGE 424.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --OCTOBER   1974.
C     UPDATED         --JANUARY   1975.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --FEBRUARY  1976.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION XR(N), YR(N)
      DOUBLE PRECISION AN
      DOUBLE PRECISION HOLD
      DOUBLE PRECISION SUM
C
      IPR = 6
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      AN  = N
      SPC = 0.0D0
      IFLAG = 0
      IF (N.EQ.1) GO TO 55
      HOLD = X(1)
      DO I = 2,N
          IF (X(I).NE.HOLD) GO TO 65
      END DO   
c c   WRITE (IPR,FMT=9) HOLD
      IFLAG = 1
   65 HOLD = Y(1)
      DO I = 2,N
          IF (Y(I).NE.HOLD) GO TO 80
      END DO   

c c c WRITE (IPR,FMT=19) HOLD
      IFLAG = 1
   80 IF (IFLAG.EQ.1) RETURN
      GO TO 90
c c50 WRITE (IPR,FMT=27) IUPPER
c c   WRITE (IPR,FMT=47) N
c c   RETURN
   55 CONTINUE  
c c   WRITE (IPR,FMT=28)
      RETURN
   90 CONTINUE
c c 9 FORMAT (1H ,
c c  +108H***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT (A VECTO
c c  +R) TO THE SPCORR SUBROUTINE HAS ALL ELEMENTS =,D15.8,6H *****)
c c19 FORMAT (1H ,
c c  +108H***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT (A VECTO
c c  +R) TO THE SPCORR SUBROUTINE HAS ALL ELEMENTS =,D15.8,6H *****)
c c27 FORMAT (' ***** FATAL ERROR--THE THIRD  INPUT ARGUMENT TO THE SP',
c c  + 'CORR SUBROUTINE IS OUTSIDE THE ALLOWABLE (1,,I6,16H) INTERVAL *'
c c  +       ,'****')
c c28 FORMAT (1H ,
c c  +100H***** NON-FATAL DIAGNOSTIC--THE THIRD  INPUT ARGUMENT TO THE S
c c  +PCORR SUBROUTINE HAS THE VALUE 1 *****)
c c47 FORMAT (1H ,35H***** THE VALUE OF THE ARGUMENT IS ,I8,6H *****)
C
C-----START POINT-----------------------------------------------------
C
      CALL SPRANK(X,N,XR)
      CALL SPRANK(Y,N,YR)
 
      SUM = 0.0D0
      DO I = 1,N
          SUM = SUM + (XR(I)-YR(I))**2
      END DO  
      SPC = 1.0D0 - (6.0D0*SUM/ ((AN-1.0D0)*AN* (AN+1.0D0)))
C
c c   IF (IWRITE.NE.0) WRITE (IPR,FMT=105) N,SPC
c c05 FORMAT (1H ,
c c  +    59HTHE SPEARMAN RANK CORRELATION COEFFICIENT OF THE 2 SETS OF
c c  +       ,I6,17H OBSERVATIONS IS ,F14.5)
      RETURN
      END
C
      SUBROUTINE SPRANK(X,N,XR)
      INTEGER N
      DOUBLE PRECISION X(N), XR(N)
C  http://www.itl.nist.gov/div898/software/datapac/RANK.f
C
C     PURPOSE--THIS SUBROUTINE RANKS (IN ASCENDING ORDER)
C              THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X,
C              AND PUTS THE RESULTING N RANKS INTO THE
C              SINGLE PRECISION VECTOR XR.
C              THIS SUBROUTINE GIVES THE DATA ANALYST
C              THE ABILITY TO (FOR EXAMPLE) RANK THE DATA
C              PRELIMINARY TO CERTAIN DISTRIBUTION-FREE
C              ANALYSES.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE RANKED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XR     = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE RANKS
C                                FROM X WILL BE PLACED.
C     OUTPUT--THE SINGLE PRECISION VECTOR XR
C             CONTAINING THE RANKS
C             (IN ASCENDING ORDER)
C             OF THE VALUES
C             IN THE SINGLE PRECISION 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 7500.
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--THE RANK OF THE FIRST ELEMENT
C              OF THE VECTOR X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR XR,
C              THE RANK OF THE SECOND ELEMENT
C              OF THE VECTOR X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR XR,
C              ETC.
C     COMMENT--THE SMALLEST ELEMENT IN THE VECTOR X
C              WILL HAVE A RANK OF 1 (UNLESS TIES EXIST).
C              THE LARGEST ELEMENT IN THE VECTOR X
C              WILL HAVE A RANK OF N (UNLESS TIES EXIST).
C     COMMENT--ALTHOUGH RANKS ARE USUALLY (UNLESS TIES EXIST)
C              INTEGRAL VALUES FROM 1 TO N, IT IS TO BE
C              NOTED THAT THEY ARE OUTPUTED AS SINGLE
C              PRECISION INTEGERS IN THE SINGLE PRECISION
C              VECTOR XR.
C              XR IS SINGLE PRECISION SO AS TO BE
C              CONSISTENT WITH THE FACT THAT ALL
C              VECTOR ARGUMENTS IN ALL OTHER
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION;
C              BUT MORE IMPORTANTLY, BECAUSE TIES FREQUENTLY
C              DO EXIST IN DATA SETS AND SO SOME OF THE
C              RESULTING RANKS WILL BE NON-INTEGRAL
C              AND SO THE OUTPUT VECTOR OF RANKS MUST NECESSARILY
C              BE SINGLE PRECISION AND NOT INTEGER.
C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
C     COMMENT--DUE TO CONFLICTING USE OF LABELED
C              COMMON /BLOCK2/ BY THIS RANK
C              SUBROUTINE AND THE SPCORR (SPEARMAN RANK
C              CORRELATION COEFFICIENT) SUBROUTINE,
C              THE VECTOR XS OF THIS RANK
C              SUBROUTINE HAS BEEN PLACED IN
C              LABELED COMMON /BLOCK4/
C     COMMENT--THE FIRST AND THIRD ARGUMENTS IN THE
C              CALLING SEQUENCE MAY
C              BE IDENTICAL; THAT IS, AN 'IN PLACE'
C              RANKING IS PERMITTED.
C              THE CALLING SEQUENCE
C              CALL RANK(X,N,X) IS VALID, IF DESIRED.
C     COMMENT--THE SORTING ALGORTHM USED HEREIN
C              IS THE BINARY SORT.
C              THIS ALGORTHIM IS EXTREMELY FAST AS THE
C              FOLLOWING TIME TRIALS INDICATE.
C              THESE TIME TRIALS WERE CARRIED OUT ON THE
C              UNIVAC 1108 EXEC 8 SYSTEM AT NBS
C              IN AUGUST OF 1974.
C              BY WAY OF COMPARISON, THE TIME TRIAL VALUES
C              FOR THE EASY-TO-PROGRAM BUT EXTREMELY
C              INEFFICIENT BUBBLE SORT ALGORITHM HAVE
C              ALSO BEEN INCLUDED--
C              NUMBER OF RANDOM        BINARY SORT       BUBBLE SORT
C               NUMBERS SORTED
C                N = 10                 .002 SEC          .002 SEC
C                N = 100                .011 SEC          .045 SEC
C                N = 1000               .141 SEC         4.332 SEC
C                N = 3000               .476 SEC        37.683 SEC
C                N = 10000             1.887 SEC      NOT COMPUTED
C     REFERENCES--CACM MARCH 1969, PAGE 186 (BINARY SORT ALGORITHM
C                 BY RICHARD C. SINGLETON).
C               --CACM JANUARY 1970, PAGE 54.
C               --CACM OCTOBER 1970, PAGE 624.
C               --JACM JANUARY 1961, PAGE 41.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-2315
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --JANUARY   1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --JANUARY   1977.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION XS(N)
      DOUBLE PRECISION AN
      DOUBLE PRECISION HOLD
      DOUBLE PRECISION AVRANK
      DOUBLE PRECISION XPREV
      DOUBLE PRECISION RPREV
C
      AN = N
      IPR = 6
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF (N.EQ.1) GO TO 55
      HOLD = X(1)
      DO I = 2,N
          IF (X(I).NE.HOLD) GO TO 90
      END DO   

c c   WRITE (IPR,FMT=9) HOLD
      AVRANK = (AN+1.0D0)/2.0D0
      DO I = 1,N
          XR(I) = AVRANK
      END DO   
      RETURN

   50 CONTINUE
c c   WRITE (IPR,FMT=17) IUPPER
c c   WRITE (IPR,FMT=47) N
      RETURN
   55 CONTINUE
c c   WRITE (IPR,FMT=18)
      XR(1) = 1.0D0
      RETURN

   90 CONTINUE
c c 9 FORMAT (1H ,
c c  +109H***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT (A VECTO
c c  +R) TO THE RANK   SUBROUTINE HAS ALL ELEMENTS = ,D15.8,6H *****)
c c17 FORMAT (1H ,
c c  +98H***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE RANK   SUBR
c c  +OUTINE IS OUTSIDE THE ALLOWABLE (1,,I6,16H) INTERVAL *****)
c c18 FORMAT (1H ,
c c  +100H***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE R
c c  +ANK   SUBROUTINE HAS THE VALUE 1 *****)
c c47 FORMAT (1H ,35H***** THE VALUE OF THE ARGUMENT IS ,I8,6H *****)
C
C-----START POINT-----------------------------------------------------
C
C     FIRST SORT THE DATA FROM THE INPUT VECTOR X
C     INTO THE INTERMEDIATE STORAGE VECTOR XS.
C
      CALL SPSORT(X,N,XS)
C
C     NOW DETERMINE THE RANKS.
C     THE BASIC ALGORITHM IS TO TAKE A GIVEN ELEMENT
C     IN THE ORIGINAL INPUT VECTOR X,
C     AND SCAN THE SORTED VALUES IN THE XS VECTOR
C     UNTIL A MATCH IS FOUND;
C     WHEN A MATCH IS FOUND, THEN THE RANK FOR THAT
C     VALUE IN THE XS VECTOR IS DETERMINED.
C     THAT RANK IS THEN WRITTEN INTO THAT POSITION
C     IN THE OUTPUT Y VECTOR WHICH CORRESPONDS TO THE POSITION OF THE
C     GIVEN ELEMENT OF INTEREST IN THE ORIGINAL X VECTOR.
C     THE CODE IS LENGTHENED FROM THIS BASIC ALGORITHM
C     BY A SECTION WHICH CUTS DOWN THE SEARCH IN THE XS VECTOR,
C     AND BY A SECTION WHICH OBVIATES (UNDER CERTAIN CIRCUMSTANCES)
C     THE NEED FOR RECALCULATING THE RANK OF AN ELEMENT IN XS.
C
      NM1 = N - 1
      XPREV = X(1)
      DO I = 1,N
          JMIN = 1
          IF (X(I).GT.XPREV) GO TO 770
          IF (I.EQ.1) GO TO 790
          IF (X(I).EQ.XPREV) GO TO 750
          GO TO 790
  750     CONTINUE
          XR(I) = RPREV
          GO TO 880
  770     CONTINUE
          JMIN = K
          IF (JMIN.LT.N) GO TO 790
          IF (JMIN.EQ.N) GO TO 820
          IBRAN = 1
c c       WRITE (IPR,FMT=109) IBRAN
c c       WRITE (IPR,FMT=101) JMIN
c 109     FORMAT (1H ,40H*****INTERNAL ERROR IN RANK SUBROUTINE--,
c c  +           46HIMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ,I8)
c 101     FORMAT (1H ,'JMIN = ',I8)
          STOP
  790     CONTINUE
          DO 800 J = JMIN,NM1
              IF (X(I).NE.XS(J)) GO TO 800
              JP1 = J + 1
              DO K = JP1,N
                  IF (XS(K).NE.XS(J)) GO TO 950
              END DO   
              K = N + 1
  950         CONTINUE
              AVRANK = J + K - 1
              AVRANK = AVRANK/2.0D0
              XR(I) = AVRANK
              GO TO 880
  800     CONTINUE 
  820     CONTINUE
          J = N
          K = N + 1
          IF (X(I).EQ.XS(J)) GO TO 850
          IBRAN = 2
c c       WRITE (IPR,FMT=109) IBRAN
c c       WRITE (IPR,FMT=102) X(I),XS(J)
c 102     FORMAT (1H ,'X(I) = ',F15.7,'   XS(J) = ',F15.7)
          STOP
  850     CONTINUE
          XR(I) = N
  880     CONTINUE
          XPREV = X(I)
          RPREV = XR(I)
      END DO   
C
      RETURN
      END
c ======================================================
 
 
      SUBROUTINE SPSORT(X, N, Y)
      INTEGER N
      DOUBLE PRECISION  X(N), Y(N)

C
C     PURPOSE--THIS SUBROUTINE SORTS (IN ASCENDING ORDER)
C              THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X
C              AND PUTS THE RESULTING N SORTED VALUES INTO THE
C              SINGLE PRECISION VECTOR Y.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE SORTED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE SORTED DATA VALUES
C                                FROM X WILL BE PLACED.
C     OUTPUT--THE SINGLE PRECISION VECTOR Y
C             CONTAINING THE SORTED
C             (IN ASCENDING ORDER) VALUES
C             OF THE SINGLE PRECISION VECTOR X.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU
C                   (DEFINED AND USED INTERNALLY WITHIN
C                   THIS SUBROUTINE) DICTATE THE MAXIMUM
C                   ALLOWABLE VALUE OF N FOR THIS SUBROUTINE.
C                   IF IL AND IU EACH HAVE DIMENSION K,
C                   THEN N MAY NOT EXCEED 2**(K+1) - 1.
C                   FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS
C                   OF IL AND IU HAVE BEEN SET TO 36,
C                   THUS THE MAXIMUM ALLOWABLE VALUE OF N IS
C                   APPROXIMATELY 137 BILLION.
C                   SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE
C                   VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS,
C                   AND SINCE A SORT OF 137 BILLION ELEMENTS
C                   IS PRESENTLY IMPRACTICAL AND UNLIKELY,
C                   THEN THERE IS NO PRACTICAL RESTRICTION
C                   ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE.
C                   (IN LIGHT OF THE ABOVE, NO CHECK OF THE
C                   UPPER LIMIT OF N HAS BEEN INCORPORATED
C                   INTO THIS SUBROUTINE.)
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR Y,
C              THE SECOND SMALLEST ELEMENT IN THE VECTOR X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR Y, ETC.
C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
C     COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE',
C              THIS IS DONE BY HAVING THE SAME
C              OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE.
C              THUS, FOR EXAMPLE, THE CALLING SEQUENCE
C              CALL SORT(X,N,X)
C              IS ALLOWABLE AND WILL RESULT IN
C              THE DESIRED 'IN-PLACE' SORT.
C     COMMENT--THE SORTING ALGORTHM USED HEREIN
C              IS THE BINARY SORT.
C              THIS ALGORTHIM IS EXTREMELY FAST AS THE
C              FOLLOWING TIME TRIALS INDICATE.
C              THESE TIME TRIALS WERE CARRIED OUT ON THE
C              UNIVAC 1108 EXEC 8 SYSTEM AT NBS
C              IN AUGUST OF 1974.
C              BY WAY OF COMPARISON, THE TIME TRIAL VALUES
C              FOR THE EASY-TO-PROGRAM BUT EXTREMELY
C              INEFFICIENT BUBBLE SORT ALGORITHM HAVE
C              ALSO BEEN INCLUDED--
C              NUMBER OF RANDOM        BINARY SORT       BUBBLE SORT
C               NUMBERS SORTED
C                N = 10                 .002 SEC          .002 SEC
C                N = 100                .011 SEC          .045 SEC
C                N = 1000               .141 SEC         4.332 SEC
C                N = 3000               .476 SEC        37.683 SEC
C                N = 10000             1.887 SEC      NOT COMPUTED
C     REFERENCES--CACM MARCH 1969, PAGE 186 (BINARY SORT ALGORITHM
C                 BY RICHARD C. SINGLETON).
C               --CACM JANUARY 1970, PAGE 54.
C               --CACM OCTOBER 1970, PAGE 624.
C               --JACM JANUARY 1961, PAGE 41.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-2315
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --NOVEMBER  1975.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION  HOLD
      DOUBLE PRECISION  AMED
      DOUBLE PRECISION  TT
      INTEGER  IU(36), IL(36)
C
      IPR = 6
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF (N .GE. 1) THEN
         IF (N .EQ. 1) GO TO 55
         HOLD = X(1)
         DO I = 2, N
            IF (X(I) .NE. HOLD) GO TO 90
         END DO
c c      WRITE (IPR, FMT=9) HOLD
         DO I = 1, N
            Y(I) = X(I)
         END DO
         RETURN 
      ENDIF
c c   WRITE (IPR, FMT=15)
c c   WRITE (IPR, FMT=47) N
      RETURN 
   55 CONTINUE
c c   WRITE (IPR, FMT=18)
      Y(1) = X(1)
      RETURN 
   90 CONTINUE
c c 9 FORMAT(1H ,
c c  1108H***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT (A VECTO
c c  2R) TO THE SORT   SUBROUTINE HAS ALL ELEMENTS =,D15.8,6H *****)
c c15 FORMAT(1H ,
c c  191H***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE SORT   SUBR
c c  2OUTINE IS NON-POSITIVE *****)
c c18 FORMAT(1H ,
c c  1100H***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE S
c c  2ORT   SUBROUTINE HAS THE VALUE 1 *****)
c c47 FORMAT(1H ,35H***** THE VALUE OF THE ARGUMENT IS ,I8,6H *****)
C
C-----START POINT-----------------------------------------------------
C
C     COPY THE VECTOR X INTO THE VECTOR Y
      DO I = 1, N
         Y(I) = X(I)
      END DO
C
C     CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED
C
      NM1 = N - 1
      DO I = 1, NM1
         IP1 = I + 1
         IF (Y(I) .GT. Y(IP1)) GO TO 250
      END DO
      RETURN 
  250 CONTINUE
      M = 1
      I = 1
      J = N
  305 CONTINUE
      IF (I .GE. J) GO TO 370
  310 CONTINUE
      K = I
      MID = (I + J)/2
      AMED = Y(MID)
      IF (Y(I) .GT. AMED) THEN
         Y(MID) = Y(I)
         Y(I) = AMED
         AMED = Y(MID)
      ENDIF
      L = J
      IF (Y(J) .GE. AMED) GO TO 340
      Y(MID) = Y(J)
      Y(J) = AMED
      AMED = Y(MID)
      IF (Y(I) .LE. AMED) GO TO 340
      Y(MID) = Y(I)
      Y(I) = AMED
      AMED = Y(MID)
      GO TO 340
  330 CONTINUE
      Y(L) = Y(K)
      Y(K) = TT
  340 CONTINUE
      L = L - 1
      IF (Y(L) .GT. AMED) GO TO 340
      TT = Y(L)
  350 CONTINUE
      K = K + 1
      IF (Y(K) .LT. AMED) GO TO 350
      IF (K .LE. L) GO TO 330
      LMI = L - I
      JMK = J - K
      IF (LMI .GT. JMK) THEN
         IL(M) = I
         IU(M) = L
         I = K
         M = M + 1
         GO TO 380
      ENDIF
      IL(M) = K
      IU(M) = J
      J = L
      M = M + 1
      GO TO 380
  370 CONTINUE
      M = M - 1
      IF (M .EQ. 0) RETURN 
      I = IL(M)
      J = IU(M)
  380 CONTINUE
      JMI = J - I
      IF (JMI .GE. 11) GO TO 310
      IF (I .EQ. 1) GO TO 305
      I = I - 1
  390 CONTINUE
      I = I + 1
      IF (I .EQ. J) GO TO 370
      AMED = Y(I+1)
      IF (Y(I) .LE. AMED) GO TO 390
      K = I
  395 CONTINUE
      Y(K+1) = Y(K)
      K = K - 1
      IF (AMED .LT. Y(K)) GO TO 395
      Y(K+1) = AMED
      GO TO 390
      END 
