



      SUBROUTINE POWELL (P,XI,N,NP,FTOL,ITER,FRET,PFUN)








      IMPLICIT      NONE
      INTEGER       NMAX, ITMAX, NP
      PARAMETER     (NMAX=150,ITMAX=200)
      INTEGER       I, J, N, ITER, IBIG
      REAL          P(NP), XI(NP,NP), PT(NMAX), PTT(NMAX), XIT(NMAX), 
     +              FRET, PFUN, FP, DEL, FTOL, FPTT, T
      EXTERNAL      PFUN



      FRET=PFUN(P)
      DO 11 J=1,N
         PT(J)=P(J)
 11   CONTINUE
      ITER=0



 1    ITER=ITER+1
      FP=FRET
      IBIG=0
      DEL=0.
      DO 13 I=1,N
         DO 12 J=1,N
            XIT(J)=XI(J,I)
 12      CONTINUE
         CALL LINMIN (P,XIT,N,FRET,PFUN)
         IF (ABS(FP-FRET).GT.DEL) THEN
            DEL=ABS(FP-FRET)
            IBIG=I
         ENDIF
 13   CONTINUE
      IF (2.*ABS(FP-FRET).LE.FTOL*(ABS(FP)+ABS(FRET))) RETURN
      IF (ITER.GE.ITMAX) THEN
         CALL GVSTT6 ('?R00064')
         RETURN
      END IF
      DO 14 J=1,N
         PTT(J)=2.*P(J)-PT(J)
         XIT(J)=P(J)-PT(J)
         PT(J)=P(J)
 14   CONTINUE
      FPTT=PFUN(PTT)
      IF (FPTT.GE.FP) GOTO 1
      T=2.*(FP-2.*FRET+FPTT)*(FP-FRET-DEL)**2-DEL*(FP-FPTT)**2
      IF (T.GE.0.) GO TO 1
      CALL LINMIN (P,XIT,N,FRET,PFUN)
      DO 15 J=1,N
         XI(J,IBIG)=XIT(J)
 15   CONTINUE
      GO TO 1
      
      END
      SUBROUTINE LINMIN (P,XI,N,FRET,GVFUNC)







      IMPLICIT      NONE
      INTEGER       NMAX, N
      REAL          TOL
      PARAMETER     (NMAX=150,TOL=1.E-4)
      REAL          F1DIM, GVFUNC
      EXTERNAL      F1DIM, GVFUNC
      INTEGER       NCOM, J
      REAL          P(N), XI(N), PCOM, XICOM, AX, XX, BX, FA, FB, FX,
     +              FRET, BRENT, XMIN
      COMMON /F1COM/NCOM,PCOM(NMAX),XICOM(NMAX)
      
      NCOM=N
      DO 11 J=1,N
         PCOM(J)=P(J)
         XICOM(J)=XI(J)
 11   CONTINUE
      AX=0.0
      XX=1.0
      BX=2.0
      CALL MNBRAK (AX,XX,BX,FA,FX,FB,F1DIM,GVFUNC)
      FRET=BRENT(AX,XX,BX,F1DIM,GVFUNC,TOL,XMIN)
      DO 12 J=1,N
         XI(J)=XMIN*XI(J)
         P(J)=P(J)+XI(J)
 12   CONTINUE

      RETURN
      END
      SUBROUTINE MNBRAK(AX,BX,CX,FA,FB,FC,QFUN,GVFUNC)







      IMPLICIT      NONE
      REAL          QFUN, GVFUNC, GOLD, GLIMIT, TINY
      EXTERNAL      QFUN, GVFUNC
      PARAMETER     (GOLD=1.618034, GLIMIT=100., TINY=1.E-20)
      REAL          FA, AX, BX, CX, FB, FC, DUM, R, Q, U, ULIM,
     +              FU

      FA=QFUN(AX,GVFUNC)
      FB=QFUN(BX,GVFUNC)
      IF (FB.GT.FA) THEN
         DUM=AX
         AX=BX
         BX=DUM
         DUM=FB
         FB=FA
         FA=DUM
      END IF
      CX=BX+GOLD*(BX-AX)
      FC=QFUN(CX,GVFUNC)
 1    IF (FB.GE.FC) THEN
         R=(BX-AX)*(FB-FC)
         Q=(BX-CX)*(FB-FA)
         U=BX-((BX-CX)*Q-(BX-AX)*R)/(2.*SIGN(MAX(ABS(Q-R),TINY),Q-R))
         ULIM=BX+GLIMIT*(CX-BX)
         IF ((BX-U)*(U-CX).GT.0.) THEN
            FU=QFUN(U,GVFUNC)
            IF(FU.LT.FC)THEN
               AX=BX
               FA=FB
               BX=U
               FB=FU
               GO TO 1
            ELSE IF(FU.GT.FB)THEN
               CX=U
               FC=FU
               GO TO 1
            ENDIF
            U=CX+GOLD*(CX-BX)
            FU=QFUN(U,GVFUNC)
         ELSE IF((CX-U)*(U-ULIM).GT.0.)THEN
            FU=QFUN(U,GVFUNC)
            IF(FU.LT.FC)THEN
               BX=CX
               CX=U
               U=CX+GOLD*(CX-BX)
               FB=FC
               FC=FU
               FU=QFUN(U,GVFUNC)
            ENDIF
         ELSE IF((U-ULIM)*(ULIM-CX).GE.0.)THEN
            U=ULIM
            FU=QFUN(U,GVFUNC)
         ELSE
            U=CX+GOLD*(CX-BX)
            FU=QFUN(U,GVFUNC)
         ENDIF
         AX=BX
         BX=CX
         CX=U
         FA=FB
         FB=FC
         FC=FU
         GO TO 1
      ENDIF

      RETURN
      END
      REAL FUNCTION F1DIM(X,GVFUNC)







      IMPLICIT      NONE
      INTEGER       NMAX, NCOM
      PARAMETER     (NMAX=150)
      REAL          GVFUNC, PCOM, XICOM, X
      EXTERNAL      GVFUNC
      INTEGER       J
      REAL          XT(NMAX)
      COMMON /F1COM/NCOM,PCOM(NMAX),XICOM(NMAX)





      DO 11 J=1,NCOM
         XT(J)=PCOM(J)+X*XICOM(J)
 11   CONTINUE
      F1DIM=GVFUNC(XT)





      RETURN
      END
      REAL FUNCTION BRENT(AX,BX,CX,F,GVFUNC,TOL,XMIN)







      IMPLICIT      NONE
      REAL          F, GVFUNC, CGOLD, ZEPS, AX, BX, CX, TOL, XMIN
      EXTERNAL      F, GVFUNC
      INTEGER       ITMAX
      PARAMETER     (ITMAX=100, CGOLD=.3819660, ZEPS=1.0E-10)
      INTEGER       ITER
      REAL          A, B, D, V, W, X, FX, FV, FW, XM, TOL1, TOL2, E,
     +              R, Q, P, ETEMP, U, FU







      A=MIN(AX,CX)
      B=MAX(AX,CX)
      D=0.0
      V=BX
      W=V
      X=V
      E=0.
      FX=F(X,GVFUNC)
      FV=FX
      FW=FX



      DO 11 ITER=1,ITMAX
         XM=0.5*(A+B)
         TOL1=TOL*ABS(X)+ZEPS
         TOL2=2.*TOL1
         IF (ABS(X-XM).LE.(TOL2-.5*(B-A))) GOTO 3
         IF (ABS(E).GT.TOL1) THEN
            R=(X-W)*(FX-FV)
            Q=(X-V)*(FX-FW)
            P=(X-V)*Q-(X-W)*R
            Q=2.*(Q-R)
            IF (Q.GT.0.) P=-P
            Q=ABS(Q)
            ETEMP=E
            E=D
            IF (ABS(P).GE.ABS(.5*Q*ETEMP).OR.P.LE.Q*(A-X).OR. 
     *           P.GE.Q*(B-X)) GOTO 1
            D=P/Q
            U=X+D
            IF (U-A.LT.TOL2 .OR. B-U.LT.TOL2) D=SIGN(TOL1,XM-X)
            GOTO 2
         ENDIF
 1       IF (X.GE.XM) THEN
            E=A-X
         ELSE
            E=B-X
         ENDIF
         D=CGOLD*E
 2       IF (ABS(D).GE.TOL1) THEN
            U=X+D
         ELSE
            U=X+SIGN(TOL1,D)
         ENDIF
         FU=F(U,GVFUNC)
         IF (FU.LE.FX) THEN
            IF (U.GE.X) THEN
               A=X
            ELSE
               B=X
            ENDIF
            V=W
            FV=FW
            W=X
            FW=FX
            X=U
            FX=FU
         ELSE
            IF (U.LT.X) THEN
               A=U
            ELSE
               B=U
            ENDIF
            IF (FU.LE.FW .OR. W.EQ.X) THEN
               V=W
               FV=FW
               W=U
               FW=FU
            ELSE IF (FU.LE.FV .OR. V.EQ.X .OR. V.EQ.W) THEN
               V=U
               FV=FU
            ENDIF
         ENDIF
 11   CONTINUE
      
      CALL GVSTT6 ('?R00065')
 3    XMIN=X
      BRENT=FX





      RETURN
      END

      SUBROUTINE XTCOPEN (I1,C1,C2,I2)
      IMPLICIT      NONE
      INTEGER       I1, I2
      CHARACTER*(*) C1, C2



      IF (I1.EQ.0.OR.I2.EQ.0) CALL GVSEIR ('XTCOPEN')
      C1(1:1)=' '
      C2(1:1)=' '

      RETURN
      END
      SUBROUTINE READXTC (I1,I2,R1,R2,R3,R4,R5,I3)
      IMPLICIT      NONE
      INTEGER       R1, I1, I2, I3
      REAL          R3(9), R2, R4, R5



      IF (I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.R1.LT.0.0.OR.R2.LT.0.0.OR.
     + R4.LT.0.0.OR.R5.LT.0.0) CALL GVSEIR ('READXTC')
      CALL GVSRT0 (R3,9)

      RETURN
      END

      SUBROUTINE TRED2 (A,N,NP,D,E)







      IMPLICIT      NONE
      INTEGER       N, NP
      REAL          A(NP,NP), D(NP), E(NP)
      INTEGER       I, L, K, J
      REAL          H, SCALE, F, G, HH

      IF (N.GT.1) THEN
         DO 18 I=N,2,-1  
            L=I-1
            H=0.
            SCALE=0.
            IF (L.GT.1) THEN
               DO 11 K=1,L
                  SCALE=SCALE+ABS(A(I,K))
 11            CONTINUE
               IF(SCALE.EQ.0.)THEN
                  E(I)=A(I,L)
               ELSE
                  DO 12 K=1,L
                     A(I,K)=A(I,K)/SCALE
                     H=H+A(I,K)**2
 12               CONTINUE
                  F=A(I,L)
                  G=-SIGN(SQRT(H),F)
                  E(I)=SCALE*G
                  H=H-F*G
                  A(I,L)=F-G
                  F=0.
                  DO 15 J=1,L
                     A(J,I)=A(I,J)/H
                     G=0.
                     DO 13 K=1,J
                        G=G+A(J,K)*A(I,K)
 13                  CONTINUE
                     IF(L.GT.J)THEN
                        DO 14 K=J+1,L
                           G=G+A(K,J)*A(I,K)
 14                     CONTINUE
                     ENDIF
                     E(J)=G/H
                     F=F+E(J)*A(I,J)
 15               CONTINUE
                  HH=F/(H+H)
                  DO 17 J=1,L
                     F=A(I,J)
                     G=E(J)-HH*F
                     E(J)=G
                     DO 16 K=1,J
                        A(J,K)=A(J,K)-F*E(K)-G*A(I,K)
 16                  CONTINUE
 17               CONTINUE
               ENDIF
            ELSE
               E(I)=A(I,L)
            ENDIF
            D(I)=H
 18      CONTINUE
      ENDIF
      D(1)=0.
      E(1)=0.
      DO 23 I=1,N
         L=I-1
         IF(D(I).NE.0.)THEN
            DO 21 J=1,L
               G=0.
               DO 19 K=1,L
                  G=G+A(I,K)*A(K,J)
 19            CONTINUE
               DO 20 K=1,L
                  A(K,J)=A(K,J)-G*A(K,I)
 20            CONTINUE
 21         CONTINUE
         ENDIF
         D(I)=A(I,I)
         A(I,I)=1.
         IF(L.GE.1)THEN
            DO 22 J=1,L
               A(I,J)=0.
               A(J,I)=0.
 22         CONTINUE
         ENDIF
 23   CONTINUE
      RETURN
      END

      SUBROUTINE TQLI (D,E,N,NP,Z)







      IMPLICIT      NONE
      INTEGER       N, NP
      REAL          D(NP), E(NP), Z(NP,NP)
      INTEGER       I, L, ITER, M, K
      REAL          DD, G, R, S, C, P, F, B

      IF (N.GT.1) THEN
         DO 11 I=2,N
            E(I-1)=E(I)
 11      CONTINUE
         E(N)=0.0
         DO 15 L=1,N
            ITER=0
 1          DO 12 M=L,N-1
               DD=ABS(D(M))+ABS(D(M+1))
               IF (ABS(E(M))+DD.EQ.DD) GO TO 2
 12         CONTINUE
            M=N
 2          IF (M.NE.L) THEN
               IF (ITER.GT.1000) THEN
                  CALL GVSTT6 ('?M4714')
                  RETURN
               END IF
               ITER=ITER+1
               G=(D(L+1)-D(L))/(2.*E(L))
               R=SQRT(G**2+1.)
               G=D(M)-D(L)+E(L)/(G+SIGN(R,G))
               S=1.0
               C=1.0
               P=0.0
               DO 14 I=M-1,L,-1
                  F=S*E(I)
                  B=C*E(I)
                  IF(ABS(F).GE.ABS(G))THEN
                     C=G/F
                     R=SQRT(C**2+1.)
                     E(I+1)=F*R
                     S=1./R
                     C=C*S
                  ELSE
                     S=F/G
                     R=SQRT(S**2+1.)
                     E(I+1)=G*R
                     C=1./R  
                     S=S*C
                  END IF
                  G=D(I+1)-P
                  R=(D(I)-G)*S+2.*C*B
                  P=S*R
                  D(I+1)=G+P
                  G=C*R-B
                  DO 13 K=1,N
                     F=Z(K,I+1)
                     Z(K,I+1)=S*Z(K,I)+C*F
                     Z(K,I)=C*Z(K,I)-S*F
 13               CONTINUE
 14            CONTINUE
               D(L)=D(L)-P
               E(L)=G
               E(M)=0.
               GO TO 1
            END IF
 15      CONTINUE
      END IF
      
      RETURN
      END
      SUBROUTINE JACOBI (A,N,NP,D,V,NROT)







      IMPLICIT      NONE
      INTEGER       N, NP, NROT, NMAX
      PARAMETER     (NMAX=1000)
      REAL          A(NP,NP), D(NP), V(NP,NP), B(NMAX), Z(NMAX)
      INTEGER       IP, IQ, I, J
      REAL          SM, TRESH, G, H, T, THETA, C, S, TAU

      DO 12 IP=1,N
         DO 11 IQ=1,N
            V(IP,IQ)=0.
 11      CONTINUE
         V(IP,IP)=1.
 12   CONTINUE
      DO 13 IP=1,N
         B(IP)=A(IP,IP)
         D(IP)=B(IP)
         Z(IP)=0.
 13   CONTINUE
      NROT=0
      DO 24 I=1,50
         SM=0.
         DO 15 IP=1,N-1
            DO 14 IQ=IP+1,N
               SM=SM+ABS(A(IP,IQ))
 14         CONTINUE
 15      CONTINUE
         IF(SM.EQ.0.)RETURN
         IF(I.LT.4)THEN
            TRESH=0.2*SM/N**2
         ELSE
            TRESH=0.
         ENDIF
         DO 22 IP=1,N-1
            DO 21 IQ=IP+1,N
               G=100.*ABS(A(IP,IQ))
               IF((I.GT.4).AND.(ABS(D(IP))+G.EQ.ABS(D(IP)))
     *              .AND.(ABS(D(IQ))+G.EQ.ABS(D(IQ))))THEN
                  A(IP,IQ)=0.
               ELSE IF(ABS(A(IP,IQ)).GT.TRESH)THEN
                  H=D(IQ)-D(IP)
                  IF(ABS(H)+G.EQ.ABS(H))THEN
                     T=A(IP,IQ)/H
                  ELSE
                     THETA=0.5*H/A(IP,IQ)
                     T=1./(ABS(THETA)+SQRT(1.+THETA**2))
                     IF(THETA.LT.0.)T=-T
                  ENDIF
                  C=1./SQRT(1+T**2)
                  S=T*C
                  TAU=S/(1.+C)
                  H=T*A(IP,IQ)
                  Z(IP)=Z(IP)-H
                  Z(IQ)=Z(IQ)+H
                  D(IP)=D(IP)-H
                  D(IQ)=D(IQ)+H
                  A(IP,IQ)=0.
                  DO 16 J=1,IP-1
                     G=A(J,IP)
                     H=A(J,IQ)
                     A(J,IP)=G-S*(H+G*TAU)
                     A(J,IQ)=H+S*(G-H*TAU)
 16               CONTINUE
                  DO 17 J=IP+1,IQ-1
                     G=A(IP,J)
                     H=A(J,IQ)
                     A(IP,J)=G-S*(H+G*TAU)
                     A(J,IQ)=H+S*(G-H*TAU)
 17               CONTINUE
                  DO 18 J=IQ+1,N
                     G=A(IP,J)
                     H=A(IQ,J)
                     A(IP,J)=G-S*(H+G*TAU)
                     A(IQ,J)=H+S*(G-H*TAU)
 18               CONTINUE
                  DO 19 J=1,N
                     G=V(J,IP)
                     H=V(J,IQ)
                     V(J,IP)=G-S*(H+G*TAU)
                     V(J,IQ)=H+S*(G-H*TAU)
 19               CONTINUE
                  NROT=NROT+1
               ENDIF
 21         CONTINUE
 22      CONTINUE
         DO 23 IP=1,N
            B(IP)=B(IP)+Z(IP)
            D(IP)=B(IP)
            Z(IP)=0.
 23      CONTINUE
 24   CONTINUE
      PRINT*,'50 iterations should never happen'
      RETURN
      END

      SUBROUTINE EIGSRT (D,V,N,NP)







      IMPLICIT      NONE
      INTEGER       N, NP
      REAL          D(NP), V(NP,NP)
      INTEGER       I, K, J
      REAL          P

      DO 13 I=1,N-1
         K=I
         P=D(I)
         DO 11 J=I+1,N
            IF (D(J).GE.P) THEN
               K=J
               P=D(J)
            END IF
 11      CONTINUE
         IF (K.NE.I) THEN
            D(K)=D(I)
            D(I)=P
            DO 12 J=1,N
               P=V(J,I)
               V(J,I)=V(J,K)
               V(J,K)=P
 12         CONTINUE
         END IF
 13   CONTINUE

      RETURN
      END
      SUBROUTINE LUBKSB (A,N,NP,INDX,B)







      IMPLICIT      NONE
      INTEGER       N, NP
      INTEGER       INDX(N)
      REAL          A(NP,NP), B(N)
      INTEGER       II, I, LL, J
      REAL          SUM

      II=0
      DO 12 I=1,N
         LL=INDX(I)
         SUM=B(LL)
         B(LL)=B(I)
         IF (II.NE.0)THEN
            DO 11 J=II,I-1
               SUM=SUM-A(I,J)*B(J)
 11         CONTINUE
         ELSE IF (SUM.NE.0.) THEN
            II=I
         ENDIF
         B(I)=SUM
 12   CONTINUE
      DO 14 I=N,1,-1
         SUM=B(I)
         IF(I.LT.N)THEN
            DO 13 J=I+1,N
               SUM=SUM-A(I,J)*B(J)
 13         CONTINUE
         ENDIF
         B(I)=SUM/A(I,I)
 14   CONTINUE

      RETURN
      END
      SUBROUTINE LUDCMP (A,N,NP,INDX,D)







      IMPLICIT      NONE
      INTEGER       N, NP, NMAX
      INTEGER       INDX(N)
      REAL          TINY, A(NP,NP)
      PARAMETER     (NMAX=100,TINY=1.0E-14)
      INTEGER       IMAX, I, J, K
      REAL          AAMAX, D, SUM, DUM, VV(NMAX)
      IMAX=0
      D=1.
      DO 12 I=1,N
        AAMAX=0.
        DO 11 J=1,N
          IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
11      CONTINUE
        IF (AAMAX.EQ.0.) THEN
           CALL GVSTTB ('?SYM051')
           RETURN
        END IF
        VV(I)=1./AAMAX
12    CONTINUE
      DO 19 J=1,N
        IF (J.GT.1) THEN
          DO 14 I=1,J-1
            SUM=A(I,J)
            IF (I.GT.1)THEN
              DO 13 K=1,I-1
                SUM=SUM-A(I,K)*A(K,J)
13            CONTINUE
              A(I,J)=SUM
            ENDIF
14        CONTINUE
        ENDIF
        AAMAX=0.
        DO 16 I=J,N
          SUM=A(I,J)
          IF (J.GT.1)THEN
            DO 15 K=1,J-1
              SUM=SUM-A(I,K)*A(K,J)
15          CONTINUE
            A(I,J)=SUM
          ENDIF
          DUM=VV(I)*ABS(SUM)
          IF (DUM.GE.AAMAX) THEN
            IMAX=I
            AAMAX=DUM
          ENDIF
16      CONTINUE
        IF (J.NE.IMAX)THEN
          DO 17 K=1,N
            DUM=A(IMAX,K)
            A(IMAX,K)=A(J,K)
            A(J,K)=DUM
17        CONTINUE
          D=-D
          VV(IMAX)=VV(J)
        ENDIF
        INDX(J)=IMAX
        IF(J.NE.N)THEN
          IF(A(J,J).EQ.0.)A(J,J)=TINY
          DUM=1./A(J,J)
          DO 18 I=J+1,N
            A(I,J)=A(I,J)*DUM
18        CONTINUE
        ENDIF
19    CONTINUE
      IF(A(N,N).EQ.0.)A(N,N)=TINY

      RETURN
      END
