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