This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / MINICERN / mathlib / gen / d / d501n1.F
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 D501N1(K,N,M,A,AL,AU,X,NX,Y,SY,WORK,DPHI,DSCAL,LAMU,
11      +                  F,DF,IAFR,MFR,SUB,EPS0,EPS,MODE,VERS,NERROR)
12
13 *************************************************************************
14 *   LEAMAX, VERSION: 15.03.1993
15 *************************************************************************
16 *
17 *   THIS ROUTINE COMPUTES FUNCTION VALUES, DERIVATIVES, THE GRADIENT,
18 *   AND THE SCALING PARAMETERS. IT ALSO DETERMINES THE ACTIVE SET OF
19 *   CONSTRAINTS AND THE LAGRANGE MULTIPLIER.
20 *
21 ************************************************************************
22
23 #include "gen/imp64.inc"
24 #include "gen/def64.inc"
25      +    LAMU
26       CHARACTER VERS*6
27       DIMENSION A(*),AL(*),AU(*),X(*),Y(*),SY(*),WORK(*),DPHI(*)
28       DIMENSION DSCAL(*),LAMU(*),F(*),DF(N,*),IAFR(*)
29       EXTERNAL SUB
30
31       PARAMETER (Z0 = 0)
32
33 ************************************************************************
34 *   COMPUTE INITIAL VALUES
35 ************************************************************************
36
37       HREL=SQRT(EPS0)
38       HABS=10*EPS0
39
40       NERROR=0
41
42 ************************************************************************
43 *   COMPUTE FUNCTION VALUES AND DERIVATIVES (IF MODE NOTEQUAL ZERO)
44 ************************************************************************
45
46       CALL D501SF(VERS,SUB,MODE,M,A,N,F,DF,K,NX,X,Y,SY,WORK(N+1),NERROR)
47       IF(NERROR .NE. 0) RETURN
48
49       IF(MODE .EQ. 0) THEN
50
51 ************************************************************************
52 *    APPROXIMATE DERIVATIVES
53 ************************************************************************
54
55        DO 10 J=1,M
56        H =ABS(A(J))*HREL+HABS
57        IF (A(J)+H .GT. AU(J)) H=-H
58        A(J)=A(J)+H
59        CALL D501SF
60      +      (VERS,SUB,MODE,M,A,N,WORK,DF,K,NX,X,Y,SY,WORK(N+1),NERROR)
61        IF(NERROR .NE. 0) RETURN
62        A(J)=A(J)-H
63        CALL DVSUB(N,WORK(1),WORK(2),F(1),F(2),DF(1,J),DF(2,J))
64    10  CALL DVSCL(N,1/H,DF(1,J),DF(2,J),DF(1,J),DF(2,J))
65       ENDIF
66
67 ************************************************************************
68 *   COMPUTE THE GRADIENT OF THE OBJECTIVE FUNCTION
69 ************************************************************************
70
71       CALL DMMPY(M,N,DF(1,1),DF(2,1),DF(1,2),F(1),F(2),DPHI(1),DPHI(2))
72
73 ************************************************************************
74 *   DETERMINE THE DIAGONAL MATRIX   DSCAL   FOR SCALING THE PROBLEM
75 ************************************************************************
76
77       DO 30 I=1,M
78       AI=0
79       DO 20 J=1,N
80    20 AI=AI+DF(J,I)**2
81    30 DSCAL(I)=MAX(DSCAL(I),SQRT(AI))
82
83 ************************************************************************
84 *     DETERMINE FREE VARIABLES AND STORE THEIR INDECES IN IAFR
85 *     DETERMINE LAGRANGE-MULTIPLIER   LAMU
86 ************************************************************************
87
88       GR=0
89       DO 40 I=1,MFR
90    40 GR=GR+(DSCAL(I)*A(IAFR(I)))**2
91       GR=HREL*SQRT(GR)
92
93       CALL DVSET(M,Z0,LAMU(1),LAMU(2))
94
95       MFR=0
96
97       DO 50 I=1,M
98       IF(AU(I)-AL(I) .LT. EPS*(ABS(AU(I))+ABS(AL(I)))+2*HABS) THEN
99         A(I)=AU(I)
100         LAMU(I)=DPHI(I)
101       ELSE
102        IF(A(I) .GE. AU(I)-(EPS * ABS(AU(I)) + HABS )) THEN
103         A(I)=AU(I)
104         IF(DPHI(I) .GT. -GR) THEN
105          MFR=MFR+1
106          IAFR(MFR)=I
107         ELSE
108          LAMU(I)=DPHI(I)
109         ENDIF
110        ELSE IF(A(I) .LE. AL(I)+(EPS * ABS(AL(I)) + HABS )) THEN
111         A(I)=AL(I)
112         IF(DPHI(I) .LT. GR) THEN
113          MFR=MFR+1
114          IAFR(MFR)=I
115         ELSE
116          LAMU(I)=DPHI(I)
117         ENDIF
118        ELSE
119         MFR=MFR+1
120         IAFR(MFR)=I
121        ENDIF
122       ENDIF
123
124    50 CONTINUE
125
126 ************************************************************************
127 *   DELETE ROWS OF  DSCAL  AND COLUMNS  OF  DF
128 *   WHICH BELONG TO NON-FREE VARIABLES
129 ************************************************************************
130
131        DO 60 I=1,MFR
132        DSCAL(I)=DSCAL(IAFR(I))
133        DO 60 L=1,N
134    60  DF(L,I)=DF(L,IAFR(I))
135
136       RETURN
137       END
138
139
140
141