MINICERN/mathlib/gen/h/assndx.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 ASSNDX(MODE,A,N,M,IDA,K,SUM,IW,IDW)
  11       LOGICAL LSW
  12       CHARACTER NAME*(*)
  13       CHARACTER*80 ERRTXT
  14       PARAMETER (NAME = 'ASSNDX')
  15
  16       DIMENSION A(IDA,*),K(*),IW(IDW,*)
  17
  18       IF(N .LT. 1 .OR. M .LT. 1) THEN
  19        WRITE(ERRTXT,101) N,M
  20        CALL MTLPRT(NAME,'H301.1',ERRTXT)
  21        RETURN
  22       ENDIF
  23       IMAX=MAX(N,M)
  24       IMIN=MIN(N,M)
  25       SUM=0
  26       IF(N .LE. M) THEN
  27        DO 1 I = 1,N
  28        RMIN=A(I,1)
  29        DO 2 J = 1,M
  30     2  RMIN=MIN(RMIN,A(I,J))
  31        SUM=SUM+RMIN
  32        DO 3 J = 1,M
  33     3  A(I,J)=A(I,J)-RMIN
  34     1  CONTINUE
  35       ENDIF
  36       IF(N .GE. M) THEN
  37        DO 4 J = 1,M
  38        RMIN=A(1,J)
  39        DO 5 I = 1,N
  40     5  RMIN=MIN(RMIN,A(I,J))
  41        SUM=SUM+RMIN
  42        DO 7 I = 1,N
  43     7  A(I,J)=A(I,J)-RMIN
  44     4  CONTINUE
  45       ENDIF
  46       DO 8 I = 1,IMAX
  47       K(I)=0
  48     8 IW(I,1)=0
  49
  50       DO 12 I = 1,N
  51       DO 13 J = 1,M
  52       IF(A(I,J)+IW(J,1) .EQ. 0) THEN
  53        K(I)=J
  54        IW(J,1)=I
  55        GO TO 12
  56       ENDIF
  57    13 CONTINUE
  58    12 CONTINUE
  59
  60    10 IFLAG=N
  61       IRL=0
  62       ICL=0
  63       IRS=1
  64
  65       DO 11 I = 1,N
  66       IW(I,5)=0
  67       IF(K(I) .EQ. 0) THEN
  68        IRL=IRL+1
  69        IW(IRL,6)=I
  70        IW(I,5)=-1
  71        IFLAG=IFLAG-1
  72       ENDIF
  73    11 CONTINUE
  74       IF(IFLAG .EQ. IMIN) THEN
  75        IF(MODE .EQ. 2) THEN
  76         DO 70 I = 1,IMAX
  77    70   K(I)=IW(I,1)
  78        ENDIF
  79        RETURN
  80       ENDIF
  81
  82       DO 14 J = 1,M
  83    14 IW(J,4)=0
  84
  85    30 I=IW(IRS,6)
  86       IRS=IRS+1
  87       DO 31 J = 1,M
  88       IF(A(I,J)+IW(J,4) .EQ. 0) THEN
  89        IW(J,4)=I
  90        ICL=ICL+1
  91        IW(ICL,2)=J
  92        NEW=IW(J,1)
  93        IF(NEW .EQ. 0) THEN
  94         J1=J
  95    61   IW(J1,1)=IW(J1,4)
  96         I=IW(J1,4)
  97         IF(K(I) .EQ. 0) THEN
  98          K(I)=J1
  99          GO TO 10
 100         ENDIF
 101         JSV=J1
 102         J1=K(I)
 103         K(I)=JSV
 104         GO TO 61
 105        ENDIF
 106        IRL=IRL+1
 107        IW(IRL,6)=NEW
 108        IW(NEW,5)=I
 109       ENDIF
 110    31 CONTINUE
 111       IF(IRS .LE. IRL) GO TO 30
 112
 113       LSW=.TRUE.
 114       ICL0=ICL
 115       ICBL=0
 116       DO 41 J = 1,M
 117       IF(IW(J,4) .EQ. 0) THEN
 118        ICBL=ICBL+1
 119        IW(ICBL,3)=J
 120       ENDIF
 121    41 CONTINUE
 122       RMIN=A(IW(1,6),IW(1,3))
 123       DO 42 I = 1,IRL
 124       DO 42 J = 1,ICBL
 125    42 RMIN=MIN(RMIN,A(IW(I,6),IW(J,3)))
 126       SUM=SUM+RMIN*(IRL+ICBL-IMAX)
 127
 128       DO 44 I = 1,N
 129       IF(IW(I,5) .EQ. 0) THEN
 130        DO 49 IPP = 1,ICL0
 131    49  A(I,IW(IPP,2))=A(I,IW(IPP,2))+RMIN
 132        GO TO 44
 133       ENDIF
 134       DO 45 IPP = 1,ICBL
 135       NEW=IW(IPP,3)
 136       A(I,NEW)=A(I,NEW)-RMIN
 137       IF(LSW .AND. A(I,NEW)+IW(NEW,4) .EQ. 0) THEN
 138        IW(NEW,4)=I
 139        IF(IW(NEW,1) .EQ. 0) THEN
 140         J1=NEW
 141         LSW=.FALSE.
 142        ELSE
 143         ICL=ICL+1
 144         IW(ICL,2)=NEW
 145         IRL=IRL+1
 146         IW(IRL,6)=IW(NEW,1)
 147        END IF
 148       END IF
 149    45 CONTINUE
 150    44 CONTINUE
 151       IF(LSW) THEN
 152        DO 51 I = ICL0+1,ICL
 153    51  IW(IW(IW(I,2),1),5)=IW(I,2)
 154        GO TO 30
 155       ELSE
 156    62  IW(J1,1)=IW(J1,4)
 157        I=IW(J1,4)
 158        IF(K(I) .EQ. 0) THEN
 159         K(I)=J1
 160         GO TO 10
 161        ENDIF
 162        JSV=J1
 163        J1=K(I)
 164        K(I)=JSV
 165        GO TO 62
 166       ENDIF
 167   101 FORMAT('N = ',I5,' < 1   OR   M = ',I5,' < 1')
 168       END