C=======================================================================
C     FAST S-ESTIMATION
C     MATHSOFT, INC.
C     07/25/99
C=======================================================================
      SUBROUTINE RLRICLLS(XT,Y,N,NP,MDX,TAU,K,THETA,RS1,SF,SG,SH,IP)
C.......................................................................
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION XT(MDX,NP),Y(N),THETA(N),RS1(N)
      DIMENSION SF(NP),SG(NP),SH(NP),IP(NP)
      DATA ZERO/0.D0/
C-----------------------------------------------------------------------
C     COMPUTES THE SOLUTION OF AN LS PROBLEM
C-----------------------------------------------------------------------
      CALL RLRMTRM2(XT,N,NP,MDX,0,TAU,K,SF,SG,SH,IP)
      DO 20 JJ=1,NP
         J=JJ
         CALL RLH12M2(2,J,J+1,N,XT(1,J),1,SH(J),Y,1,N,1,N)
 20   CONTINUE
      DO 30 I=1,N
         THETA(I)=Y(I)
 30   CONTINUE
      CALL RLSOLVM2(XT,THETA,NP,K,MDX,N)
      DO I=1,K
         RS1(I) = ZERO
      ENDDO
      DO I=NP+1,N
         RS1(I) = Y(I)
      ENDDO
      DO J1=1,NP
         J=NP-J1+1
         CALL RLH12M2(2,J,J+1,N,XT(1,J),1,SH(J),RS1,1,N,1,N)
      ENDDO
      CALL RLPERMM2(THETA,IP,NP,NP)
      RETURN
      END
C=======================================================================
      SUBROUTINE RLDPSORT(X, N, IPERM)
C.......................................................................
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION IPERM(N),X(N)
      INTEGER IL(21), IU(21)
C-----------------------------------------------------------------------
C     Return the permutation vector generated by sorting a given
C     array. A slightly modified quicksort algorithm is used.
C     R. C. Singleton, Algorithm 347, An efficient algorithm
C     for sorting with minimal storage, Communications of the ACM, 
C     12, 3 (1969), pp. 185-187.
C-----------------------------------------------------------------------
      NN = N  
      DO 10 I=1,NN
         IPERM(I) = I
 10   CONTINUE
      IF (NN .EQ. 1) GOTO 200
      M = 1
      I = 1
      J = NN
      R = .375D0
 30   IF (I .EQ. J) GO TO 80
      IF (R .LE. 0.5898437D0) THEN
         R = R+3.90625D-2
      ELSE
         R = R-0.21875D0
      ENDIF
 40   K = I
      IJ = I + INT((J-I)*R)
      LM = IPERM(IJ)
      IF (X(IPERM(I)) .GT. X(LM)) THEN
         IPERM(IJ) = IPERM(I)
         IPERM(I) = LM
         LM = IPERM(IJ)
      ENDIF
      L = J
      IF (X(IPERM(J)) .LT. X(LM)) THEN
         IPERM(IJ) = IPERM(J)
         IPERM(J) = LM
         LM = IPERM(IJ)
         IF (X(IPERM(I)) .GT. X(LM)) THEN
            IPERM(IJ) = IPERM(I)
            IPERM(I) = LM
            LM = IPERM(IJ)
         ENDIF
      ENDIF
      GO TO 60
 50   LMT = IPERM(L)
      IPERM(L) = IPERM(K)
      IPERM(K) = LMT
 60   L = L-1
      IF (X(IPERM(L)) .GT. X(LM)) GO TO 60
 70   K = K+1
      IF (X(IPERM(K)) .LT. X(LM)) GO TO 70
      IF (K .LE. L) GO TO 50
      IF (L-I .GT. J-K) THEN
         IL(M) = I
         IU(M) = L
         I = K
         M = M+1
      ELSE
         IL(M) = K
         IU(M) = J
         J = L
         M = M+1
      ENDIF
      GO TO 90
 80   M = M-1
      IF (M .EQ. 0) GOTO 200
      I = IL(M)
      J = IU(M)
 90   IF (J-I .GE. 1) GO TO 40
      IF (I .EQ. 1) GO TO 30
      I = I-1
 100  I = I+1
      IF (I .EQ. J) GO TO 80
      LM = IPERM(I+1)
      IF (X(IPERM(I)) .LE. X(LM)) GO TO 100
      K = I
 110  IPERM(K+1) = IPERM(K)
      K = K-1
      IF (X(LM) .LT. X(IPERM(K))) GO TO 110
      IPERM(K+1) = LM
      GO TO 100
 200  RETURN
      END
C=======================================================================
      SUBROUTINE RLPRINSS(X,X2,MDX,NP,Y,N,THETA,RES,TAU,K,SF,SG,SH,IP,
     +     XPXH,XPXI,HDIAG,Q,U,Z)
C.......................................................................
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION X(MDX,NP),Y(N),THETA(N),RES(N),XPXH(NP,NP),XPXI(NP,NP)
      DIMENSION X2(MDX,NP),SF(NP),SG(3*NP),SH(NP),IP(NP)
      DIMENSION HDIAG(N),Q(NP,NP),U(NP,NP),Z(MDX,NP)
      DATA ZERO,ONE/0.D0,1.D0/
C
C avoid compiler warnings
C 

      dummy = U(1,1)

C-----------------------------------------------------------------------     
C     COMPUTES OLS FIT AND PRINCIPAL SENSITIVITY COMPONENTS
C-----------------------------------------------------------------------   
      CALL RLRICLLS(X,Y,N,NP,MDX,TAU,K,THETA,RES,SF,SG,SH,IP)
      IF(K .NE. NP) RETURN
      DO I = 1, NP
         DO J = 1, NP
            XPXI(I,J) = X(I,J)
         ENDDO
      ENDDO
      DO I = 1, NP
         DO J = 1, NP
            IF (I .EQ. J) THEN 
               XPXH(I,J) = ONE
            ELSE
               XPXH(I,J) = ZERO
            ENDIF
         ENDDO
      ENDDO
c      CALL DBKSL(XPXI,NP,NP,XPXH,NP,INFO)
      CALL DTRTRS('U', 'N', 'N', NP, NP, XPXI, NP, XPXH, NP, INFO)
      DO I = 1, NP
         DO J = 1, NP
            S = ZERO
            DO KK = 1, NP
               S = S + XPXH(I,KK)*XPXH(J,KK)
            ENDDO
            XPXI(I,J) = S
         ENDDO
      ENDDO
      DO I = 1, NP
         DO J = 1, NP
            XPXH(I,J) = XPXI(I,J)
         ENDDO
      ENDDO
c      CALL CHOL(XPXH,NP,SF,0,0,KK)
      CALL DPOTRF('U', NP, XPXH, NP, KK)
      DO J = 1, NP
         DO I = J+1, NP
            XPXH(I,J) = XPXH(J,I)
            XPXH(J,I) = ZERO
         ENDDO
      ENDDO
      DO I = 1, N
         S = ZERO
         DO KK=1, NP
            DO LL=1, NP
               S = S + X2(I,KK)*XPXI(KK,LL)*X2(I,LL)
            ENDDO
         ENDDO
         HDIAG(I) = (RES(I)/(ONE-S))**2
      ENDDO
      DO I = 1, NP
         DO J = 1, NP
            S = ZERO
            DO KK = 1, N
               S = S + X2(KK,I) * HDIAG(KK) * X2(KK,J)
            ENDDO
            XPXI(I,J) = S
         ENDDO
      ENDDO
      DO I = 1, NP
         DO J = 1, NP
            S = ZERO
            DO KK = 1, NP
               DO LL = 1, NP
                  S = S+XPXH(KK,I)*XPXI(KK,LL)*XPXH(LL,J)
               ENDDO
            ENDDO
            Q(I,J) = S
         ENDDO
      ENDDO
C      CALL RS(NP,NP,Q,SF,1,U,SG,SH,INFO)
      CALL DSYEV('V','U',NP,Q,NP,SF,SG,3*NP,INFO)
      IF (INFO .NE. 0) RETURN
      DO I = 1, N
         DO J = 1, NP
            S = ZERO
            DO KK = 1, NP
               DO LL = 1, NP
C                  S = S+X2(I,KK)*XPXH(KK,LL)*U(LL,NP-J+1)
                  S = S+X2(I,KK)*XPXH(KK,LL)*Q(LL,J)
               ENDDO
            ENDDO
            Z(I,J) = S
         ENDDO
      ENDDO
      RETURN
      END
C=======================================================================
      SUBROUTINE RLFASTSE(X,X2,MDX,NP,Y,Y2,N,RES,TAU,K,SF,SG,SH,IP,
     +     XPXH,XPXI,HDIAG,Q,U,Z,ITER,IERR,XX,YY,SMIN,IPS,XK,BETA,BET0,
     +     MXS,TOLS,TOLR,MAXS1,THETA,XTHETA1,XTHETA2,IPERM,C1)
C.......................................................................
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION X(MDX,NP),Y(N),RES(N),XPXH(NP,NP),XPXI(NP,NP),Y2(N)
      DIMENSION SF(NP),SG(3*NP),SH(NP),IP(NP),IPERM(N)
      DIMENSION HDIAG(N),Q(NP,NP),U(NP,NP),Z(MDX,NP),X2(MDX,NP)
      DIMENSION XX(MDX,NP),YY(N),THETA(N),XTHETA1(NP),XTHETA2(NP)
      LOGICAL ALLEQUAL
      DATA ZERO /0.D0/
C-----------------------------------------------------------------------     
C     STEP 1. START ITERATION WITH LS
C-----------------------------------------------------------------------
      ITER = 1
      IZ = 0
      NZ = 1
      IERR = 0
      SMIN=ZERO
      K1=N/2+1
      CONST=BETA*DBLE(N-NP)
      NX = N
      DO I=1, NX
         DO J=1,NP
            XX(I,J) = X(I,J)
            X2(I,J) = X(I,J)
         ENDDO
         YY(I) = Y(I)
         Y2(I) = Y(I)
      ENDDO
 100  CALL RLPRINSS(XX,X2,MDX,NP,YY,NX,THETA,RES,TAU,K,SF,SG,SH,IP,
     +     XPXH,XPXI,HDIAG,Q,U,Z)
      CALL RLRESDM2(X,Y,THETA,N,NP,MDX,RES)
      IF (K .NE. NP) THEN
         IERR = 1
         GOTO 800
      ENDIF
C----------------------------------------------------------------------- 
C     STEP 2. INITIALIZE S0 AND SRES IF NECESSARY
C----------------------------------------------------------------------- 
      IF (SMIN .EQ. ZERO) THEN
         S=1.0D7
         DO I=1,N
            ARI=DABS(RES(I))
            HDIAG(I)=ARI
            IF (ARI .NE. ZERO) S=DMIN1(S,ARI)
         ENDDO
         IF (S .EQ. 1.0D7) GOTO 800
         CALL RLSTORM2(HDIAG,N,K1,S0)
         S0=2.D0*S0
         IF (S0 .EQ. ZERO) S0=S
         SRES=S0
      ENDIF
C----------------------------------------------------------------------- 
C     STEP 3. UPDATE SRES AND SMIN IF NECESSARY
C-----------------------------------------------------------------------
 435  D=ZERO
      DO 440 I=1,N
         D=D+RLCHIM2(RES(I)/SRES,IPS,XK)
 440  CONTINUE
      IF (SMIN .NE. ZERO .AND. D .GT. CONST) GOTO 700
      IF (D .LE. CONST) GOTO 500
      S0=1.5D0*S0
      SRES=S0
      GOTO 435
 500  CALL RLRSIGM2(RES,HDIAG,S0,N,NP,TOLR,1,1,MAXS1,NIS,SRES,HDIAG,
     +     HDIAG,IPS,XK,BETA,BET0)
      SMIN=SRES
      S0=SMIN
      DO J=1,NP
         XTHETA2(J)=THETA(J)
      ENDDO
      IF (SRES .LE. TOLS) THEN
         IERR=2
         GOTO 800
      ENDIF
C----------------------------------------------------------------------- 
C     STEP 4. REGRESSION BASED ON PRINCIPAL SENSITIVITY COMPONENTS
C-----------------------------------------------------------------------
 700  IF (NZ .GT. NP) THEN
         NZ = 1
         GOTO 750
      ENDIF
      IF (IZ .EQ. 3) THEN
         IZ = 0
         NZ = NZ + 1
         GOTO 700
      ELSE
         IZ = IZ + 1
      ENDIF
      IF (IZ .EQ. 1) GOTO 710
      IF (IZ .EQ. 2) GOTO 720
      IF (IZ .EQ. 3) GOTO 730
 710  NHALF=NX/2
      DO I=1, NX
         HDIAG(I) = Z(I,NZ)
      ENDDO
      CALL RLDPSORT(HDIAG,NX,IPERM)
      DO I=1,NHALF
         IDX = IPERM(I)
         DO J=1,NP
            XX(I,J) = X2(IDX,J)
         ENDDO
         YY(I) = Y2(IDX)
      ENDDO
      NEND = NHALF
      GOTO 740
 720  DO I=NHALF+1,NX
         IDX = IPERM(I)
         IH = I - NHALF
         DO J=1,NP
            XX(IH,J) = X2(IDX,J)
         ENDDO
         YY(IH) = Y2(IDX)         
      ENDDO
      NEND = NX-NHALF
      GOTO 740
 730  DO I=1, NX
         HDIAG(I) = DABS(Z(I,NZ))
      ENDDO
      CALL RLDPSORT(HDIAG,NX,IPERM)
      DO I=1,NHALF
         IDX = IPERM(I)
         DO J=1,NP
            XX(I,J) = X2(IDX,J)
         ENDDO
         YY(I) = Y2(IDX)
      ENDDO
      NEND = NHALF
 740  CALL RLRMTRM2(XX,NEND,NP,MDX,1,TAU,K,SF,SG,SH,IP)
      IF(K .NE. NP) THEN
         IERR = 1
         GOTO 800
      ENDIF
      CALL RLRICLM2(XX,YY,NEND,NP,MDX,THETA,SH,IP)
      CALL RLRESDM2(X,Y,THETA,N,NP,MDX,RES)
      GOTO 435
C-----------------------------------------------------------------------
C     STEP 5: GOTO NEXT ITERATION OR EXIT
C-----------------------------------------------------------------------
 750  ALLEQUAL = .TRUE.
      DO J=1,NP
         IF (.NOT. ALLEQUAL) GOTO 760
         IF (ABS(XTHETA2(J)-XTHETA1(J)) .GT. TOLR) ALLEQUAL = .FALSE.
      ENDDO
      IF (ALLEQUAL) GOTO 800
 760  DO J=1,NP
         XTHETA1(J) = XTHETA2(J)
      ENDDO
      IF (ITER .EQ. MXS) THEN
         IERR = 3
         GOTO 800
      ENDIF
      CALL RLRESDM2(X,Y,XTHETA1,N,NP,MDX,RES)
      BIG = C1*SMIN
      NX = 0
      DO I=1,N
         IF (RES(I) .LE. BIG) THEN
            NX = NX + 1
            DO J=1,NP
               XX(NX,J) = X(I,J)
               X2(NX,J) = X(I,J)
            ENDDO
            YY(NX) = Y(I)
            Y2(NX) = Y(I)
         ENDIF
      ENDDO
      ITER = ITER + 1
      GOTO 100
 800  RETURN
      END



