]>
Commit | Line | Data |
---|---|---|
fe4da5cc | 1 | * |
2 | * $Id$ | |
3 | * | |
4 | * $Log$ | |
5 | * Revision 1.1.1.1 1996/04/01 15:02:19 mclareni | |
6 | * Mathlib gen | |
7 | * | |
8 | * | |
9 | #include "gen/pilot.h" | |
10 | SUBROUTINE D501N2(K,N,M,A,AL,AU,X,NX,WORK,B,DPHI,DSCAL,LAMU, | |
11 | 1 AM,COV,IAFR,MFR,SUB,EPS0,EPS,MODE,NERROR) | |
12 | ||
13 | #include "gen/imp64.inc" | |
14 | #include "gen/def64.inc" | |
15 | + LAMU | |
16 | DIMENSION A(*),AL(*),AU(*),X(*),WORK(*),B(*),DPHI(*),DSCAL(*) | |
17 | DIMENSION LAMU(*),AM(M,*),COV(M,*),IAFR(*) | |
18 | PARAMETER (Z0 = 0) | |
19 | ||
20 | ************************************************************************* | |
21 | * LEAMAX, VERSION: 15.03.1993 | |
22 | ************************************************************************* | |
23 | * | |
24 | * THIS ROUTINE COMPUTES THE GRADIENT, THE JACOBIAN, AND IT SETS UP | |
25 | * THE MATRIX FOR THE NORMAL EQUATIONS. IT ALSO DETERMINES THE ACTIVE | |
26 | * SET OF CONSTRAINTS AND THE LAGRANGE-MULTIPLIER. | |
27 | * | |
28 | ************************************************************************ | |
29 | ||
30 | ************************************************************************ | |
31 | * SET INITIAL VALUES | |
32 | ************************************************************************ | |
33 | ||
34 | HREL=SQRT(EPS0) | |
35 | HABS=10*EPS0 | |
36 | ||
37 | ************************************************************************ | |
38 | * COMPUTE THE GRADIENT B OF THE OBJECTIVE FUNCTION | |
39 | * COMPUTE AN APPROXIMATION AM OF THE SECOND DERIVATIVE (THE HESSIAN) | |
40 | * OF THE OBJECTIVE FUNCTION | |
41 | ************************************************************************ | |
42 | ||
43 | NERROR=0 | |
44 | CALL DVSET(M,Z0,B(1),B(2)) | |
45 | CALL DMSET(M,M,Z0,AM(1,1),AM(1,2),AM(2,1)) | |
46 | IX=1 | |
47 | ||
48 | DO 30 I=1,N | |
49 | ||
50 | CALL SUB(K,X(IX),M,A,F0,WORK,MODE,NERROR) | |
51 | IF(NERROR .NE. 0 .OR. F0 .LE. 0) THEN | |
52 | NERROR=3 | |
53 | RETURN | |
54 | ENDIF | |
55 | ||
56 | IF(MODE .EQ. 0) THEN | |
57 | ||
58 | ************************************************************************ | |
59 | * APPROXIMATE DERIVATIVES | |
60 | ************************************************************************ | |
61 | ||
62 | DO 10 J=1,M | |
63 | H =ABS(A(J))*HREL+HABS | |
64 | IF (A(J)+H .GT. AU(J)) H =-H | |
65 | A(J)=A(J)+H | |
66 | CALL SUB(K,X(IX),M,A,FH,WORK,MODE,NERROR) | |
67 | IF(NERROR .NE. 0) THEN | |
68 | NERROR=3 | |
69 | RETURN | |
70 | ENDIF | |
71 | A(J)=A(J)-H | |
72 | 10 WORK(J)=(FH-F0)/H | |
73 | ENDIF | |
74 | ||
75 | CALL DVSCL(M,1/F0,WORK(1),WORK(2),WORK(1),WORK(2)) | |
76 | CALL DVSUB(M,B(1),B(2),WORK(1),WORK(2),B(1),B(2)) | |
77 | ||
78 | DO 20 L=1,M | |
79 | DO 20 J=L,M | |
80 | 20 AM(L,J)=AM(L,J)+WORK(L)*WORK(J) | |
81 | ||
82 | 30 IX=IX+NX | |
83 | ||
84 | CALL DMUTL(M,AM(1,1),AM(1,2),AM(2,1)) | |
85 | ||
86 | ************************************************************************ | |
87 | * COPY THE GRADIENT OF THE OBJECTIVE FUNCTION TO DPHI | |
88 | ************************************************************************ | |
89 | ||
90 | CALL DVCPY(M,B(1),B(2),DPHI(1),DPHI(2)) | |
91 | ||
92 | ************************************************************************ | |
93 | * DETERMINE THE DIAGONAL MATRIX DSCAL FOR SCALING THE PROBLEM | |
94 | ************************************************************************ | |
95 | ||
96 | DO 40 I=1,M | |
97 | 40 DSCAL(I)=MAX(DSCAL(I),SQRT(AM(I,I))) | |
98 | ||
99 | ************************************************************************ | |
100 | * DETERMINE FREE VARIABLES AND STORE THEIR INDICES IN IAFR | |
101 | * DETERMINE LAGRANGE MULTIPLIER LAMU | |
102 | ************************************************************************ | |
103 | ||
104 | GR=0 | |
105 | DO 50 I=1,MFR | |
106 | 50 GR=GR+(DSCAL(I)*A(IAFR(I)))**2 | |
107 | GR=HREL*SQRT(GR) | |
108 | CALL DVSET(M,Z0,LAMU(1),LAMU(2)) | |
109 | ||
110 | MFR=0 | |
111 | ||
112 | DO 60 I=1,M | |
113 | IF(AU(I)-AL(I) .LT. EPS*(ABS(AU(I))+ABS(AL(I)))+2*HABS) THEN | |
114 | A(I)=AU(I) | |
115 | LAMU(I)=DPHI(I) | |
116 | ELSE | |
117 | IF(A(I) .GE. AU(I)-(EPS * ABS(AU(I)) + HABS)) THEN | |
118 | A(I)=AU(I) | |
119 | IF(DPHI(I) .GT. -GR) THEN | |
120 | MFR=MFR+1 | |
121 | IAFR(MFR)=I | |
122 | ELSE | |
123 | LAMU(I)=DPHI(I) | |
124 | ENDIF | |
125 | ELSE IF(A(I) .LE. AL(I)+(EPS * ABS(AL(I)) + HABS)) THEN | |
126 | A(I)=AL(I) | |
127 | IF(DPHI(I) .LT. GR) THEN | |
128 | MFR=MFR+1 | |
129 | IAFR(MFR)=I | |
130 | ELSE | |
131 | LAMU(I)=DPHI(I) | |
132 | ENDIF | |
133 | ELSE | |
134 | MFR=MFR+1 | |
135 | IAFR(MFR)=I | |
136 | ENDIF | |
137 | ENDIF | |
138 | ||
139 | 60 CONTINUE | |
140 | ||
141 | *********************************************************************** | |
142 | * DELETE ROWS AND COLUMNS OF AM AND B WHICH BELONG TO NON-FREE | |
143 | * VARIABLES | |
144 | ************************************************************************ | |
145 | ||
146 | IF(MFR .EQ. 0 .OR. MFR .EQ. M) THEN | |
147 | MFC=M | |
148 | ELSE | |
149 | MFC=MFR | |
150 | DO 70 I =1,MFR | |
151 | B(I)=B(IAFR(I)) | |
152 | DSCAL(I)=DSCAL(IAFR(I)) | |
153 | DO 70 L = 1,M | |
154 | 70 AM(L,I)=AM(L,IAFR(I)) | |
155 | DO 80 I=1,MFR | |
156 | DO 80 L=1,M | |
157 | 80 AM(I,L)=AM(IAFR(I),L) | |
158 | ENDIF | |
159 | ||
160 | CALL DMCPY(MFC,MFC,AM(1,1),AM(1,2),AM(2,1), | |
161 | + COV(1,1),COV(1,2),COV(2,1)) | |
162 | RETURN | |
163 | ||
164 | END | |
165 | ||
166 | ||
167 |