+++ /dev/null
-*
-* $Id$
-*
-* $Log$
-* Revision 1.1.1.1 1996/04/01 15:02:20 mclareni
-* Mathlib gen
-*
-*
-#include "gen/pilot.h"
- SUBROUTINE MINSQ (M,N,F,X,E,IPRINT,NFUN ,NW,W,COV,XSTEP)
- DIMENSION F(M),X(N),E(N),W(NW)
- IFLAG=1
- ESCALE=1.
- MAXFUN=NFUN
- MPLUSN=M+N
- KST=N+MPLUSN
- NPLUS=N+1
- KINV=NPLUS*(MPLUSN+1)
- KSTORE=KINV-MPLUSN-1
- CALL FCN1(M,N,F,X,IFLAG,NW,W,KEND,KEND2N)
- IFLAG=4
- NN=N+N
- K=NN
- DO 1 I=1,M
- K=K+1
- W(K)=F(I)
- 1 CONTINUE
- IINV=2
- K=KST
- I=1
- 2 X(I)=X(I)+E(I)
- CALL FCN1(M,N,F,X,IFLAG,NW,W,KEND,KEND2N)
- X(I)=X(I)-E(I)
- DO 3 J=1,N
- K=K+1
- W(K)=0.
- W(J)=0.
- 3 CONTINUE
- SUM=0.
- KK=NN
- DO 4 J=1,M
- KK=KK+1
- F(J)=F(J)-W(KK)
- SUM=SUM+F(J)*F(J)
- 4 CONTINUE
- IF (SUM) 5,5,6
- 5 WRITE(6,7)I
- 7 FORMAT(5X,'E(',I3,') UNREASONABLY SMALL')
- RETURN
- 6 SUM=1./SQRT (SUM)
- J=K-N+I
- W(J)=E(I)*SUM
- DO 9 J=1,M
- K=K+1
- W(K)=F(J)*SUM
- KK=NN+J
- DO 11 II=1,I
- KK=KK+MPLUSN
- W(II)=W(II)+W(KK)*W(K)
- 11 CONTINUE
- 9 CONTINUE
- ILESS=I-1
- IGAMAX=N+I-1
- INCINV=N-ILESS
- INCINP=INCINV+1
- IF (ILESS) 13,13,14
- 13 W(KINV)=1.
- GO TO 15
- 14 B=1.
- DO 16 J=NPLUS,IGAMAX
- W(J)=0.
- 16 CONTINUE
- KK=KINV
- DO 17 II=1,ILESS
- IIP=II+N
- W(IIP)=W(IIP)+W(KK)*W(II)
- JL=II+1
- IF (JL-ILESS) 18,18,19
- 18 DO 20 JJ=JL,ILESS
- KK=KK+1
- JJP=JJ+N
- W(IIP)=W(IIP)+W(KK)*W(JJ)
- W(JJP)=W(JJP)+W(KK)*W(II)
- 20 CONTINUE
- 19 B=B-W(II)*W(IIP)
- KK=KK+INCINP
- 17 CONTINUE
- B=1./B
- KK=KINV
- DO 21 II=NPLUS,IGAMAX
- BB=-B*W(II)
- DO 22 JJ=II,IGAMAX
- W(KK)=W(KK)-BB*W(JJ)
- KK=KK+1
- 22 CONTINUE
- W(KK)=BB
- KK=KK+INCINV
- 21 CONTINUE
- W(KK)=B
- 15 GO TO (27,24),IINV
- 24 I=I+1
- IF (I-N) 2,2,25
- 25 IINV=1
- FF=0.
- KL=NN
- DO 26 I=1,M
- KL=KL+1
- F(I)=W(KL)
- FF=FF+F(I)*F(I)
- 26 CONTINUE
- ICONT = 1
- ISS=1
- MC=N+1
- IPP=IPRINT*(IPRINT-1)
- ITC=0
- IPS=1
- IPC=0
- 27 IPC=IPC-IPRINT
- IF (IPC) 28,29,29
- 28 WRITE(6,30)ITC,MC,FF
- 30 FORMAT(//5X,'ITERATION',I4,I9,' CALLS OF FCN ',5X,'F=',E24.14)
- WRITE(6,31)(X(I),I=1,N)
- 31 FORMAT(5X,'VARIABLES',/(5E24.14))
- WRITE(6,32)(F(I),I=1,M)
- 32 FORMAT(5X,'FUNCTIONS',/(5E24.14))
- IPC=IPP
- GO TO (29,33),IPS
- 29 GO TO (34,35),ICONT
- 35 IF (CHANGE-1.) 10,10,36
- 10 CONTINUE
-C*UL 37 WRITE(6,38)
- WRITE(6,38)
- 38 FORMAT(//5X,' FINAL VALUES OF FUNCTIONS AND VARIABLES')
- IPS=2
- GO TO 28
- 33 IFLAG=3
- CALL FCN1(M,N,F,X,IFLAG,NW,W,KEND,KEND2N)
- IF(COV.EQ.0.) RETURN
- IWC1 = 2*N+N*(N+M)
- IWC=IWC1
- DO 91 I=1,N
- DO 91 J=1,I
- IWC=IWC+1
- W(IWC)=0.
- DO 90 MR=1,N
- JCOV=N+J+MR*(N+M)
- ICOV=N+I+MR*(N+M)
- 90 W(IWC)=W(IWC)+W(ICOV)*W(JCOV)
- 91 CONTINUE
- WRITE(6,1000)
- 1000 FORMAT(///40X,'VARIANCE-COVARIANCE MATRIX'///)
- IB=IWC1
- DO 92 I=1,N
- IA=IB+1
- IB=IB+I
- 92 WRITE(6,1001)(W(J),J=IA,IB)
- 1001 FORMAT(10X,5G20.6//)
- RETURN
- 36 ICONT=1
- 34 ITC=ITC+1
- K=N
- KK=KST
- DO 39 I=1,N
- K=K+1
- W(K)=0.
- KK=KK+N
- W(I)=0.
- DO 40 J=1,M
- KK=KK+1
- W(I)=W(I)+W(KK)*F(J)
- 40 CONTINUE
- 39 CONTINUE
- DM=0.
- K=KINV
- DO 41 II=1,N
- IIP=II+N
- W(IIP)=W(IIP)+W(K)*W(II)
- JL=II+1
- IF (JL-N) 42,42,43
- 42 DO 44 JJ=JL,N
- JJP=JJ+N
- K=K+1
- W(IIP)=W(IIP)+W(K)*W(JJ)
- W(JJP)=W(JJP)+W(K)*W(II)
- 44 CONTINUE
- K=K+1
- 43 IF (DM-ABS (W(II)*W(IIP))) 45,41,41
- 45 DM=ABS (W(II)*W(IIP))
- KL=II
- 41 CONTINUE
- II=N+MPLUSN*KL
- CHANGE=0.
- DO 46 I=1,N
- JL=N+I
- W(I)=0.
- DO 47 J=NPLUS,NN
- JL=JL+MPLUSN
- W(I)=W(I)+W(J)*W(JL)
- 47 CONTINUE
- II=II+1
- W(II)=W(JL)
- W(JL)=X(I)
- IF (ABS (E(I)*CHANGE)-ABS (W(I))) 48,48,46
- 48 CHANGE=ABS (W(I)/E(I))
- 46 CONTINUE
- DO 49 I=1,M
- II=II+1
- JL=JL+1
- W(II)=W(JL)
- W(JL)=F(I)
- 49 CONTINUE
- FC=FF
- ACC=0.1/CHANGE
- IT=3
- XC=0.
- XL=0.
- IS=3
- IF (CHANGE-1.) 50,50,51
- 50 ICONT=2
- 51 CALL VD01A (IT,XC,FC,20,ACC,0.1,XSTEP)
- GO TO (52,53,53,53),IT
- 52 MC=MC+1
- IF (MC-MAXFUN) 54,54,55
- 55 WRITE(6,56)MAXFUN
- 56 FORMAT(5X,I6,' CALLS OF FCN')
- ISS=2
- GO TO 53
- 54 XL=XC-XL
- DO 57 J=1,N
- X(J)=X(J)+XL*W(J)
- 57 CONTINUE
- XL=XC
- CALL FCN1(M,N,F,X,IFLAG,NW,W,KEND,KEND2N)
- FC=0.
- DO 58 J=1,M
- FC=FC+F(J)*F(J)
- 58 CONTINUE
- GO TO (59,59,60),IS
- 60 K=N
- IF (FC-FF) 61,51,62
- 61 IS=2
- FMIN=FC
- FSEC=FF
- GO TO 63
- 62 IS=1
- FMIN=FF
- FSEC=FC
- GO TO 63
- 59 IF (FC-FSEC) 64,51,51
- 64 K=KSTORE
- GO TO (75,74),IS
- 75 K=N
- 74 IF (FC-FMIN) 65,51,66
- 66 FSEC=FC
- GO TO 63
- 65 IS=3-IS
- FSEC=FMIN
- FMIN=FC
- 63 DO 67 J=1,N
- K=K+1
- W(K)=X(J)
- 67 CONTINUE
- DO 68 J=1,M
- K=K+1
- W(K)=F(J)
- 68 CONTINUE
- GO TO 51
- 53 K=KSTORE
- KK=N
- GO TO (69,70,69),IS
- 70 K=N
- KK=KSTORE
- 69 SUM=0.
- DM=0.
- JJ=KSTORE
- DO 71 J=1,N
- K=K+1
- KK=KK+1
- JJ=JJ+1
- X(J)=W(K)
- W(JJ)=W(K)-W(KK)
- 71 CONTINUE
- DO 72 J=1,M
- K=K+1
- KK=KK+1
- JJ=JJ+1
- F(J)=W(K)
- W(JJ)=W(K)-W(KK)
- SUM=SUM+W(JJ)*W(JJ)
- DM=DM+F(J)*W(JJ)
- 72 CONTINUE
- GO TO (73,10),ISS
- 73 J=KINV
- KK=NPLUS-KL
- DO 76 I=1,KL
- K=J+KL-I
- J=K+KK
- W(I)=W(K)
- W(K)=W(J-1)
- 76 CONTINUE
- IF (KL-N) 77,78,78
- 77 KL=KL+1
- JJ=K
- DO 79 I=KL,N
- K=K+1
- J=J+NPLUS-I
- W(I)=W(K)
- W(K)=W(J-1)
- 79 CONTINUE
- W(JJ)=W(K)
- B=1./W(KL-1)
- W(KL-1)=W(N)
- GO TO 88
- 78 B=1./W(N)
- 88 K=KINV
- DO 80 I=1,ILESS
- BB=B*W(I)
- DO 81 J=I,ILESS
- W(K)=W(K)-BB*W(J)
- K=K+1
- 81 CONTINUE
- K=K+1
- 80 CONTINUE
- IF (FMIN-FF) 82,83,83
- 83 CHANGE=0.
- GO TO 84
- 82 FF=FMIN
- CHANGE=ABS (XC)*CHANGE
- 84 XL=-DM/FMIN
- SUM=1./SQRT (SUM+DM*XL)
- K=KSTORE
- DO 85 I=1,N
- K=K+1
- W(K)=SUM*W(K)
- W(I)=0.
- 85 CONTINUE
- DO 86 I=1,M
- K=K+1
- W(K)=SUM*(W(K)+XL*F(I))
- KK=NN+I
- DO 87 J=1,N
- KK=KK+MPLUSN
- W(J)=W(J)+W(KK)*W(K)
- 87 CONTINUE
- 86 CONTINUE
- GO TO 14
- END
git://git.uio.no / u / mrichter / AliRoot.git / blobdiff