C----
C---- $Id: recipes.f,v 1.2 1995/11/10 14:16:25 hooft Exp $
C----
C---- Routines taken from Numerical Recipes have their own copyright!
C----
      SUBROUTINE MEDFIT(X,Y,NDATA,A,B,ABDEV)
      PARAMETER (NMAX=32768)
      EXTERNAL ROFUNC
      COMMON /ARRAYS/ NDATAT,XT(NMAX),YT(NMAX),ARR(NMAX),AA,ABDEVT
      DIMENSION X(NDATA),Y(NDATA)
      SX=0.
      SY=0.
      SXY=0.
      SXX=0.
      DO 11 J=1,NDATA
         XT(J)=X(J)
         YT(J)=Y(J)
         SX=SX+X(J)
         SY=SY+Y(J)
         SXY=SXY+X(J)*Y(J)
         SXX=SXX+X(J)**2
   11 CONTINUE
      NDATAT=NDATA
      DEL=NDATA*SXX-SX**2
      AA=(SXX*SY-SX*SXY)/DEL
      BB=(NDATA*SXY-SX*SY)/DEL
      CHISQ=0.
      DO 12 J=1,NDATA
         CHISQ=CHISQ+(Y(J)-(AA+BB*X(J)))**2
   12 CONTINUE
      SIGB=SQRT(CHISQ/DEL)
      B1=BB
      F1=ROFUNC(B1)
      B2=BB+SIGN(3.*SIGB,F1)
      F2=ROFUNC(B2)
    1 IF(F1*F2.GT.0.)THEN
         BB=2.*B2-B1
         B1=B2
         F1=F2
         B2=BB
         F2=ROFUNC(B2)
         GOTO 1
      ENDIF
      SIGB=0.01*SIGB
    2 IF(ABS(B2-B1).GT.SIGB)THEN
         BB=0.5*(B1+B2)
         IF(BB.EQ.B1.OR.BB.EQ.B2)GOTO 3
         F=ROFUNC(BB)
         IF(F*F1.GE.0.)THEN
            F1=F
            B1=BB
         ELSE
            F2=F
            B2=BB
         ENDIF
         GOTO 2
      ENDIF
    3 A=AA
      B=BB
      ABDEV=ABDEVT/NDATA
      RETURN
      END
      FUNCTION ROFUNC(B)
      PARAMETER (NMAX=32768)
      COMMON /ARRAYS/ NDATA,X(NMAX),Y(NMAX),ARR(NMAX),AA,ABDEV
      N1=NDATA+1
      NML=N1/2
      NMH=N1-NML
      DO 11 J=1,NDATA
         ARR(J)=Y(J)-B*X(J)
   11 CONTINUE
      CALL SORT(NDATA,ARR)
      AA=0.5*(ARR(NML)+ARR(NMH))
      SUM=0.
      ABDEV=0.
      DO 12 J=1,NDATA
         D=Y(J)-(B*X(J)+AA)
         ABDEV=ABDEV+ABS(D)
         SUM=SUM+X(J)*SIGN(1.0,D)
   12 CONTINUE
      ROFUNC=SUM
      RETURN
      END
      SUBROUTINE SPLINE(X,Y,N,YP1,YPN,Y2)
      PARAMETER (NMAX=32767)
      DIMENSION X(N),Y(N),Y2(N),U(NMAX)
      IF (YP1.GT..99E30) THEN
         Y2(1)=0.
         U(1)=0.
      ELSE
         Y2(1)=-0.5
         U(1)=(3./(X(2)-X(1)))*((Y(2)-Y(1))/(X(2)-X(1))-YP1)
      ENDIF
      DO 11 I=2,N-1
         SIG=(X(I)-X(I-1))/(X(I+1)-X(I-1))
         P=SIG*Y2(I-1)+2.
         Y2(I)=(SIG-1.)/P
         U(I)=(6.*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1))
     *        /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-SIG*U(I-1))/P
   11 CONTINUE
      IF (YPN.GT..99E30) THEN
         QN=0.
         UN=0.
      ELSE
         QN=0.5
         UN=(3./(X(N)-X(N-1)))*(YPN-(Y(N)-Y(N-1))/(X(N)-X(N-1)))
      ENDIF
      Y2(N)=(UN-QN*U(N-1))/(QN*Y2(N-1)+1.)
      DO 12 K=N-1,1,-1
         Y2(K)=Y2(K)*Y2(K+1)+U(K)
   12 CONTINUE
      RETURN
      END
      SUBROUTINE SPLINT(XA,YA,Y2A,N,X,Y)
      DIMENSION XA(N),YA(N),Y2A(N)
      KLO=1
      KHI=N
    1 IF (KHI-KLO.GT.1) THEN
         K=(KHI+KLO)/2
         IF(XA(K).GT.X)THEN
            KHI=K
         ELSE
            KLO=K
         ENDIF
         GOTO 1
      ENDIF
      H=XA(KHI)-XA(KLO)
c-Hooft  25-JUL-1990 12:34:10 
      IF (H.EQ.0.) then
         a=0.5
         b=0.5
      else
         A=(XA(KHI)-X)/H
         B=(X-XA(KLO))/H
      endif
      Y=A*YA(KLO)+B*YA(KHI)+
     *     ((A**3-A)*Y2A(KLO)+(B**3-B)*Y2A(KHI))*(H**2)/6.
      RETURN
      END     
C----
C---- Least Squares procedure from W.H.PRESS
C----
      SUBROUTINE FIT(X,Y,NDATA,SIG,MWT,A,B,SIGA,SIGB,CHI2,Q)
      DIMENSION X(NDATA),Y(NDATA),SIG(NDATA)
      SX=0.
      SY=0.
      ST2=0.
      B=0.
      IF(MWT.NE.0) THEN
         SS=0.
         DO 11 I=1,NDATA
            WT=1./(SIG(I)**2)
            SS=SS+WT
            SX=SX+X(I)*WT
            SY=SY+Y(I)*WT
   11    CONTINUE
      ELSE
         DO 12 I=1,NDATA
            SX=SX+X(I)
            SY=SY+Y(I)
   12    CONTINUE
         SS=FLOAT(NDATA)
      ENDIF
      SXOSS=SX/SS
      IF(MWT.NE.0) THEN
         DO 13 I=1,NDATA
            T=(X(I)-SXOSS)/SIG(I)
            ST2=ST2+T*T
            B=B+T*Y(I)/SIG(I)
   13    CONTINUE
      ELSE
         DO 14 I=1,NDATA
            T=X(I)-SXOSS
            ST2=ST2+T*T
            B=B+T*Y(I)
   14    CONTINUE
      ENDIF
      B=B/ST2
      A=(SY-SX*B)/SS
      SIGA=SQRT((1.+SX*SX/(SS*ST2))/SS)
      SIGB=SQRT(1./ST2)
      CHI2=0.
      IF(MWT.EQ.0) THEN
         DO 15 I=1,NDATA
            CHI2=CHI2+(Y(I)-A-B*X(I))**2
   15    CONTINUE
         Q=1.
         SIGDAT=SQRT(CHI2/(NDATA-2))
         SIGA=SIGA*SIGDAT
         SIGB=SIGB*SIGDAT
      ELSE
         DO 16 I=1,NDATA
            CHI2=CHI2+((Y(I)-A-B*X(I))/SIG(I))**2
   16    CONTINUE
         Q=GAMMQ(0.5*(NDATA-2),0.5*CHI2)
      END IF
      RETURN
      END
      FUNCTION GAMMQ(A,X)
      IF(X.LT.0..OR.A.LE.0.)PAUSE
      IF(X.LT.A+1.)THEN
         CALL GSER(GAMSER,A,X,GLN)
         GAMMQ=1.-GAMSER
      ELSE
         CALL GCF(GAMMCF,A,X,GLN)
         GAMMQ=GAMMCF
      END IF
      RETURN
      END
      SUBROUTINE GSER(GAMSER,A,X,GLN)
      PARAMETER (ITMAX=100,EPS=3.E-7)
      GLN=GAMMLN(A)
      IF (X.LE.0.)THEN
         IF (X.LT.0.)PAUSE
         GAMSER=0.
         RETURN
      END IF
      AP=A
      SUM=1./A
      DEL=SUM
      DO 11 N=1,ITMAX
         AP=AP+1.
         DEL=DEL*X/AP
         SUM=SUM+DEL
         IF(ABS(DEL).LT.ABS(SUM)*EPS)GO TO 1
   11 CONTINUE
      PAUSE 'A too large, ITMAX too small'
    1 GAMSER=SUM*EXP(-X+A*LOG(X)-GLN)
      RETURN
      END
      SUBROUTINE GCF(GAMMCF,A,X,GLN)
      PARAMETER (ITMAX=100,EPS=3.E-7)
      GLN=GAMMLN(A)
      GOLD=0.
      A0=1.
      A1=X
      B0=0.
      B1=1.
      FAC=1.
      DO 11 N=1,ITMAX
         AN=FLOAT(N)
         ANA=AN-A
         A0=(A1+A0*ANA)*FAC
         B0=(B1+B0*ANA)*FAC
         ANF=AN*FAC
         A1=X*A0+ANF*A1
         B1=X*B0+ANF*B1
         IF(A1.NE.0.)THEN
            FAC=1./A1
            G=B1*FAC
            IF(ABS((G-GOLD)/G).LT.EPS)GO TO 1
            GOLD=G
         ENDIF
   11 CONTINUE
      PAUSE 'A too large, ITMAX too small'
    1 GAMMCF=EXP(-X+A*ALOG(X)-GLN)*G
      RETURN
      END
      FUNCTION GAMMLN(XX)
      REAL*8 COF(6),STP,HALF,ONE,FPF,X,TMP,SER
      DATA COF,STP/76.18009173D0,-86.50532033D0,24.01409822D0,
     *    -1.231739516D0,.120858003D-2,-.536382D-5,2.50662827465D0/
      DATA HALF,ONE,FPF/0.5D0,1.0D0,5.5D0/
      X=XX-ONE
      TMP=X+FPF
      TMP=(X+HALF)*LOG(TMP)-TMP
      SER=ONE
      DO 11 J=1,6
         X=X+ONE
         SER=SER+COF(J)/X
   11 CONTINUE
      GAMMLN=TMP+LOG(STP*SER)
      RETURN
      END
C----
C---- Calculation of correlation coefficient
C----
      SUBROUTINE PEARSN (X,Y,N,R,PROB,Z)
      PARAMETER (TINY=1.E-20)
      DIMENSION X(N),Y(N)
      AX=0.
      AY=0.
      DO 11 J=1,N
         AX=AX+X(J)
         AY=AY+Y(J)
   11 CONTINUE
      AX=AX/N
      AY=AY/N
      SXX=0.
      SYY=0.
      SXY=0.
      DO 12 J=1,N
         XT=X(J)-AX
         YT=Y(J)-AY
         SXX=SXX+XT**2
         SYY=SYY+YT**2
         SXY=SXY+XT*YT
   12 CONTINUE
      R=SXY/SQRT(SXX*SYY)
      Z=0.5*ALOG(((1.+R)+TINY)/((1.-R)+TINY))
      DF=N-2
      T=R*SQRT(DF/(((1.-R)+TINY)*((1.+R)+TINY)))
      PROB=BETAI(0.5*DF,0.5,DF/(DF+T**2))
C     PROB=ERFCC(ABS(Z*SQRT(N-1.))/1.4142136)
      RETURN
      END
      FUNCTION BETAI(A,B,X)
      IF(X.LT.0..OR.X.GT.1.) PAUSE 'bad argument X in BETAI'
      IF(X.EQ.0..OR.X.EQ.1.) THEN
        BT=0.
      ELSE
        BT=EXP(GAMMLN(A+B)-GAMMLN(A)-GAMMLN(B)
     *      +A*ALOG(X)+B*ALOG(1.-X))
      END IF
      IF(X.LT.(A+1.)/(A+B+2.))THEN
        BETAI=BT*BETACF(A,B,X)/A
        RETURN
      ELSE
        BETAI=1.-BT*BETACF(B,A,1.-X)/B
        RETURN
      ENDIF
      END
      FUNCTION BETACF(A,B,X)
      PARAMETER (ITMAX=100,EPS=3.E-7)
      AM=1.
      BM=1.
      AZ=1.
      QAB=A+B
      QAP=A+1.
      QAM=A-1.
      BZ=1.-QAB*X/QAP
      DO 11 M=1,ITMAX
        EM=M
        TEM=EM+EM
        D=EM*(B-M)*X/((QAM+TEM)*(A+TEM))
        AP=AZ+D*AM
        BP=BZ+D*BM
        D=-(A+EM)*(QAB+EM)*X/((A+TEM)*(QAP+TEM))
        APP=AP+D*AZ
        BPP=BP+D*BZ
        AOLD=AZ
        AM=AP/BPP
        BM=BP/BPP
        AZ=APP/BPP
        BZ=1.
        IF(ABS(AZ-AOLD).LT.EPS*ABS(AZ))GO TO 1
11    CONTINUE
      PAUSE 'A or B too big, or ITMAX too small'
1     BETACF=AZ
      RETURN
      END

      SUBROUTINE FOUR1(DATA,NN,ISIGN)
      REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
      DIMENSION DATA(*)
      N=2*NN
      J=1
      DO 11 I=1,N,2
        IF(J.GT.I)THEN
          TEMPR=DATA(J)
          TEMPI=DATA(J+1)
          DATA(J)=DATA(I)
          DATA(J+1)=DATA(I+1)
          DATA(I)=TEMPR
          DATA(I+1)=TEMPI
        ENDIF
        M=N/2
1       IF ((M.GE.2).AND.(J.GT.M)) THEN
          J=J-M
          M=M/2
        GO TO 1
        ENDIF
        J=J+M
11    CONTINUE
      MMAX=2
2     IF (N.GT.MMAX) THEN
        ISTEP=2*MMAX
        THETA=6.28318530717959D0/(ISIGN*MMAX)
        WPR=-2.D0*DSIN(0.5D0*THETA)**2
        WPI=DSIN(THETA)
        WR=1.D0
        WI=0.D0
        DO 13 M=1,MMAX,2
          DO 12 I=M,N,ISTEP
            J=I+MMAX
            TEMPR=SNGL(WR)*DATA(J)-SNGL(WI)*DATA(J+1)
            TEMPI=SNGL(WR)*DATA(J+1)+SNGL(WI)*DATA(J)
            DATA(J)=DATA(I)-TEMPR
            DATA(J+1)=DATA(I+1)-TEMPI
            DATA(I)=DATA(I)+TEMPR
            DATA(I+1)=DATA(I+1)+TEMPI
12        CONTINUE
          WTEMP=WR
          WR=WR*WPR-WI*WPI+WR
          WI=WI*WPR+WTEMP*WPI+WI
13      CONTINUE
        MMAX=ISTEP
      GO TO 2
      ENDIF
      RETURN
      END

      SUBROUTINE CORREL(DATA1,DATA2,N,ANS)
      PARAMETER(NMAX=32768)
      DIMENSION DATA1(N),DATA2(N)
      COMPLEX FFT(NMAX),ANS(N)
      CALL TWOFFT(DATA1,DATA2,FFT,ANS,N)
      NO2=FLOAT(N)/2.0
      DO 11 I=1,N/2+1
        ANS(I)=FFT(I)*CONJG(ANS(I))/NO2
11    CONTINUE
      ANS(1)=CMPLX(REAL(ANS(1)),REAL(ANS(N/2+1)))
      CALL REALFT(ANS,N/2,-1)
      RETURN
      END

      SUBROUTINE TWOFFT(DATA1,DATA2,FFT1,FFT2,N)
      DIMENSION DATA1(N),DATA2(N)
      COMPLEX FFT1(N),FFT2(N),H1,H2,C1,C2
      C1=CMPLX(0.5,0.0)
      C2=CMPLX(0.0,-0.5)
      DO 11 J=1,N
        FFT1(J)=CMPLX(DATA1(J),DATA2(J))
11    CONTINUE
      CALL FOUR1(FFT1,N,1)
      FFT2(1)=CMPLX(AIMAG(FFT1(1)),0.0)
      FFT1(1)=CMPLX(REAL(FFT1(1)),0.0)
      N2=N+2
      DO 12 J=2,N/2+1
        H1=C1*(FFT1(J)+CONJG(FFT1(N2-J)))
        H2=C2*(FFT1(J)-CONJG(FFT1(N2-J)))
        FFT1(J)=H1
        FFT1(N2-J)=CONJG(H1)
        FFT2(J)=H2
        FFT2(N2-J)=CONJG(H2)
12    CONTINUE
      RETURN
      END

      SUBROUTINE REALFT(DATA,N,ISIGN)
      REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
      DIMENSION DATA(*)
      THETA=6.28318530717959D0/2.0D0/DBLE(N)
      C1=0.5
      IF (ISIGN.EQ.1) THEN
        C2=-0.5
        CALL FOUR1(DATA,N,+1)
      ELSE
        C2=0.5
        THETA=-THETA
      ENDIF
      WPR=-2.0D0*DSIN(0.5D0*THETA)**2
      WPI=DSIN(THETA)
      WR=1.0D0+WPR
      WI=WPI
      N2P3=2*N+3
      DO 11 I=2,N/2+1
        I1=2*I-1
        I2=I1+1
        I3=N2P3-I2
        I4=I3+1
        WRS=SNGL(WR)
        WIS=SNGL(WI)
        H1R=C1*(DATA(I1)+DATA(I3))
        H1I=C1*(DATA(I2)-DATA(I4))
        H2R=-C2*(DATA(I2)+DATA(I4))
        H2I=C2*(DATA(I1)-DATA(I3))
        DATA(I1)=H1R+WRS*H2R-WIS*H2I
        DATA(I2)=H1I+WRS*H2I+WIS*H2R
        DATA(I3)=H1R-WRS*H2R+WIS*H2I
        DATA(I4)=-H1I+WRS*H2I+WIS*H2R
        WTEMP=WR
        WR=WR*WPR-WI*WPI+WR
        WI=WI*WPR+WTEMP*WPI+WI
11    CONTINUE
      IF (ISIGN.EQ.1) THEN
        H1R=DATA(1)
        DATA(1)=H1R+DATA(2)
        DATA(2)=H1R-DATA(2)
      ELSE
        H1R=DATA(1)
        DATA(1)=C1*(H1R+DATA(2))
        DATA(2)=C1*(H1R-DATA(2))
        CALL FOUR1(DATA,N,-1)
      ENDIF
      RETURN
      END
      SUBROUTINE SPEAR(DATA1,DATA2,N,WKSP1,WKSP2,D,ZD,PROBD,RS,PROBRS)
      DIMENSION DATA1(N),DATA2(N),WKSP1(N),WKSP2(N)
      DO 11 J=1,N
        WKSP1(J)=DATA1(J)
        WKSP2(J)=DATA2(J)
11    CONTINUE
      CALL SORT2(N,WKSP1,WKSP2)
      CALL CRANK(N,WKSP1,SF)
      CALL SORT2(N,WKSP2,WKSP1)
      CALL CRANK(N,WKSP2,SG)
      D=0.
      DO 12 J=1,N
        D=D+(WKSP1(J)-WKSP2(J))**2
12    CONTINUE
      EN=N
      EN3N=EN**3-EN
      AVED=EN3N/6.-(SF+SG)/12.
      FAC=(1.-SF/EN3N)*(1.-SG/EN3N)
      VARD=((EN-1.)*EN**2*(EN+1.)**2/36.)*FAC
      ZD=(D-AVED)/SQRT(VARD)
      PROBD=ERFCC(ABS(ZD)/1.4142136)
      RS=(1.-(6./EN3N)*(D+0.5*(SF+SG)))/FAC
      T=RS*SQRT((EN-2.)/((1.+RS)*(1.-RS)))
      DF=EN-2.
      PROBRS=BETAI(0.5*DF,0.5,DF/(DF+T**2))
      RETURN
      END
      SUBROUTINE KENDL1(DATA1,DATA2,N,TAU,Z,PROB)
      DIMENSION DATA1(N),DATA2(N)
      N1=0
      N2=0
      IS=0
      DO 12 J=1,N-1
        DO 11 K=J+1,N
          A1=DATA1(J)-DATA1(K)
          A2=DATA2(J)-DATA2(K)
          AA=A1*A2
          IF(AA.NE.0.)THEN
            N1=N1+1
            N2=N2+1
            IF(AA.GT.0.)THEN
              IS=IS+1
            ELSE
              IS=IS-1
            ENDIF
          ELSE
            IF(A1.NE.0.)N1=N1+1
            IF(A2.NE.0.)N2=N2+1
          ENDIF
11      CONTINUE
12    CONTINUE
      TAU=FLOAT(IS)/SQRT(FLOAT(N1)*FLOAT(N2))
      VAR=(4.*N+10.)/(9.*N*(N-1.))
      Z=TAU/SQRT(VAR)
      PROB=ERFCC(ABS(Z)/1.4142136)
      RETURN
      END
      FUNCTION ERFCC(X)
      Z=ABS(X)      
      T=1./(1.+0.5*Z)
      ERFCC=T*EXP(-Z*Z-1.26551223+T*(1.00002368+T*(.37409196+
     *    T*(.09678418+T*(-.18628806+T*(.27886807+T*(-1.13520398+
     *    T*(1.48851587+T*(-.82215223+T*.17087277)))))))))
      IF (X.LT.0.) ERFCC=2.-ERFCC
      RETURN
      END
      SUBROUTINE CRANK(N,W,S)
      DIMENSION W(N)
      S=0.
      J=1
1     IF(J.LT.N)THEN
        IF(W(J+1).NE.W(J))THEN
          W(J)=J
          J=J+1
        ELSE
          DO 11 JT=J+1,N
            IF(W(JT).NE.W(J))GO TO 2
11        CONTINUE
          JT=N+1
2         RANK=0.5*(J+JT-1)
          DO 12 JI=J,JT-1
            W(JI)=RANK
12        CONTINUE
          T=JT-J
          S=S+T**3-T
          J=JT
        ENDIF
      GO TO 1
      ENDIF
      IF(J.EQ.N)W(N)=N
      RETURN
      END
      SUBROUTINE SORT2(N,RA,RB)
      DIMENSION RA(N),RB(N)
      L=N/2+1
      IR=N
10    CONTINUE
        IF(L.GT.1)THEN
          L=L-1
          RRA=RA(L)
          RRB=RB(L)
        ELSE
          RRA=RA(IR)
          RRB=RB(IR)
          RA(IR)=RA(1)
          RB(IR)=RB(1)
          IR=IR-1
          IF(IR.EQ.1)THEN
            RA(1)=RRA
            RB(1)=RRB
            RETURN
          ENDIF
        ENDIF
        I=L
        J=L+L
20      IF(J.LE.IR)THEN
          IF(J.LT.IR)THEN
            IF(RA(J).LT.RA(J+1))J=J+1
          ENDIF
          IF(RRA.LT.RA(J))THEN
            RA(I)=RA(J)
            RB(I)=RB(J)
            I=J
            J=J+J
          ELSE
            J=IR+1
          ENDIF
        GO TO 20
        ENDIF
        RA(I)=RRA
        RB(I)=RRB
      GO TO 10
      END
      SUBROUTINE SORT(N,RA)
      DIMENSION RA(N)
      L=N/2+1
      IR=N
10    CONTINUE
        IF(L.GT.1)THEN
          L=L-1
          RRA=RA(L)
        ELSE
          RRA=RA(IR)
          RA(IR)=RA(1)
          IR=IR-1
          IF(IR.EQ.1)THEN
            RA(1)=RRA
            RETURN
          ENDIF
        ENDIF
        I=L
        J=L+L
20      IF(J.LE.IR)THEN
          IF(J.LT.IR)THEN
            IF(RA(J).LT.RA(J+1))J=J+1
          ENDIF
          IF(RRA.LT.RA(J))THEN
            RA(I)=RA(J)
            I=J
            J=J+J
          ELSE
            J=IR+1
          ENDIF
        GO TO 20
        ENDIF
        RA(I)=RRA
      GO TO 10
      END
