MINICERN/mathlib/gen/d/d501n2.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 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