MINICERN/mathlib/gen/h/h101s1.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:02:49  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10       SUBROUTINE H101S1(A,B,C,Z,M,N,IDA,IP,KP,LW,IDW,EPS)
  11
  12 #include "gen/imp64.inc"
  13
  14       DIMENSION A(IDA,*),B(*),C(*),LW(IDW,*)
  15
  16       PARAMETER (R10 = 10, IE0 = 15)
  17
  18 C     Exchanges a basic with a non-basic variable and transforms
  19 C     the whole tableau
  20
  21       A(IP,KP)=1/A(IP,KP)
  22       DO 1 I = 1,M
  23       IF(I .NE. IP) A(I,KP)=A(I,KP)*A(IP,KP)
  24     1 CONTINUE
  25       C(KP)=C(KP)*A(IP,KP)
  26       DO 3 I = 1,M
  27       IF(I .NE. IP) THEN
  28        DO 2 K = 1,N
  29        IF(K .NE. KP) A(I,K)=A(I,K)-A(IP,K)*A(I,KP)
  30     2  CONTINUE
  31        B(I)=B(I)-B(IP)*A(I,KP)
  32       ENDIF
  33     3 CONTINUE
  34       DO 4 K = 1,N
  35       IF(K .NE. KP) THEN
  36        C(K)=C(K)-A(IP,K)*C(KP)
  37        A(IP,K)=-A(IP,K)*A(IP,KP)
  38       ENDIF
  39     4 CONTINUE
  40       Z=Z-B(IP)*C(KP)
  41       B(IP)=-B(IP)*A(IP,KP)
  42
  43       EPS=0
  44       DO 5 I = 1,M
  45       DO 5 K = 1,N
  46     5 EPS=EPS+ABS(A(I,K))
  47       EPSL=LOG10(2*EPS/(M*N))
  48       IEXP=INT(EPSL)-IE0
  49       IF(EPSL .LT. 0) IEXP=IEXP-1
  50       EPS=R10**IEXP
  51
  52       DO 10 I = 1,M
  53       IF(ABS(B(I)) .LT. EPS) B(I)=0
  54       DO 10 K = 1,N
  55       IF(ABS(A(I,K)) .LT. EPS) A(I,K)=0
  56    10 CONTINUE
  57       DO 25 K = 1,N
  58       IF(ABS(C(K)) .LT. EPS) C(K)=0
  59    25 CONTINUE
  60       IF(ABS(Z) .LT. EPS) Z=0
  61       IR=LW(IP,4)
  62       LW(IP,4)=LW(KP,5)
  63       LW(KP,5)=IR
  64       RETURN
  65       END