[u/mrichter/AliRoot.git] / MINICERN / mathlib / gen / d / d501n1.F

*
* $Id$
*
* $Log$
* Revision 1.1.1.1  1996/04/01 15:02:19  mclareni
* Mathlib gen
*
*
#include "gen/pilot.h"
      SUBROUTINE D501N1(K,N,M,A,AL,AU,X,NX,Y,SY,WORK,DPHI,DSCAL,LAMU,
     +                  F,DF,IAFR,MFR,SUB,EPS0,EPS,MODE,VERS,NERROR)

*************************************************************************
*   LEAMAX, VERSION: 15.03.1993
*************************************************************************
*
*   THIS ROUTINE COMPUTES FUNCTION VALUES, DERIVATIVES, THE GRADIENT,
*   AND THE SCALING PARAMETERS. IT ALSO DETERMINES THE ACTIVE SET OF
*   CONSTRAINTS AND THE LAGRANGE MULTIPLIER.
*
************************************************************************

#include "gen/imp64.inc"
#include "gen/def64.inc"
     +    LAMU
      CHARACTER VERS*6
      DIMENSION A(*),AL(*),AU(*),X(*),Y(*),SY(*),WORK(*),DPHI(*)
      DIMENSION DSCAL(*),LAMU(*),F(*),DF(N,*),IAFR(*)
      EXTERNAL SUB

      PARAMETER (Z0 = 0)

************************************************************************
*   COMPUTE INITIAL VALUES
************************************************************************

      HREL=SQRT(EPS0)
      HABS=10*EPS0

      NERROR=0

************************************************************************
*   COMPUTE FUNCTION VALUES AND DERIVATIVES (IF MODE NOTEQUAL ZERO)
************************************************************************

      CALL D501SF(VERS,SUB,MODE,M,A,N,F,DF,K,NX,X,Y,SY,WORK(N+1),NERROR)
      IF(NERROR .NE. 0) RETURN

      IF(MODE .EQ. 0) THEN

************************************************************************
*    APPROXIMATE DERIVATIVES
************************************************************************

       DO 10 J=1,M
       H =ABS(A(J))*HREL+HABS
       IF (A(J)+H .GT. AU(J)) H=-H
       A(J)=A(J)+H
       CALL D501SF
     +      (VERS,SUB,MODE,M,A,N,WORK,DF,K,NX,X,Y,SY,WORK(N+1),NERROR)
       IF(NERROR .NE. 0) RETURN
       A(J)=A(J)-H
       CALL DVSUB(N,WORK(1),WORK(2),F(1),F(2),DF(1,J),DF(2,J))
   10  CALL DVSCL(N,1/H,DF(1,J),DF(2,J),DF(1,J),DF(2,J))
      ENDIF

************************************************************************
*   COMPUTE THE GRADIENT OF THE OBJECTIVE FUNCTION
************************************************************************

      CALL DMMPY(M,N,DF(1,1),DF(2,1),DF(1,2),F(1),F(2),DPHI(1),DPHI(2))

************************************************************************
*   DETERMINE THE DIAGONAL MATRIX   DSCAL   FOR SCALING THE PROBLEM
************************************************************************

      DO 30 I=1,M
      AI=0
      DO 20 J=1,N
   20 AI=AI+DF(J,I)**2
   30 DSCAL(I)=MAX(DSCAL(I),SQRT(AI))

************************************************************************
*     DETERMINE FREE VARIABLES AND STORE THEIR INDECES IN IAFR
*     DETERMINE LAGRANGE-MULTIPLIER   LAMU
************************************************************************

      GR=0
      DO 40 I=1,MFR
   40 GR=GR+(DSCAL(I)*A(IAFR(I)))**2
      GR=HREL*SQRT(GR)

      CALL DVSET(M,Z0,LAMU(1),LAMU(2))

      MFR=0

      DO 50 I=1,M
      IF(AU(I)-AL(I) .LT. EPS*(ABS(AU(I))+ABS(AL(I)))+2*HABS) THEN
        A(I)=AU(I)
        LAMU(I)=DPHI(I)
      ELSE
       IF(A(I) .GE. AU(I)-(EPS * ABS(AU(I)) + HABS )) THEN
        A(I)=AU(I)
        IF(DPHI(I) .GT. -GR) THEN
         MFR=MFR+1
         IAFR(MFR)=I
        ELSE
         LAMU(I)=DPHI(I)
        ENDIF
       ELSE IF(A(I) .LE. AL(I)+(EPS * ABS(AL(I)) + HABS )) THEN
        A(I)=AL(I)
        IF(DPHI(I) .LT. GR) THEN
         MFR=MFR+1
         IAFR(MFR)=I
        ELSE
         LAMU(I)=DPHI(I)
        ENDIF
       ELSE
        MFR=MFR+1
        IAFR(MFR)=I
       ENDIF
      ENDIF

   50 CONTINUE

************************************************************************
*   DELETE ROWS OF  DSCAL  AND COLUMNS  OF  DF
*   WHICH BELONG TO NON-FREE VARIABLES
************************************************************************

       DO 60 I=1,MFR
       DSCAL(I)=DSCAL(IAFR(I))
       DO 60 L=1,N
   60  DF(L,I)=DF(L,IAFR(I))

      RETURN
      END
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 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)))+2HABS) 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