MINICERN/mathlib/gen/e/rchebn.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:02:28  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10 #if !defined(CERNLIB_DOUBLE)
  11       SUBROUTINE RCHEBN(M,N,A,MDIM,B,TOL,RELERR,X,RESMAX,IRK,ITER,IOCD)
  12
  13       DIMENSION A(MDIM,*),B(*),X(*)
  14
  15       PARAMETER (R0 = 0, R1 = 1, R2 = 2)
  16
  17       DATA BIG /1E+37/
  18
  19       IRK=N
  20       NR=1
  21       RELTMP=RELERR
  22       RELERR=0
  23
  24       CALL RVSET(M,R1,A(1,N+1),A(2,N+1))
  25       CALL RVSCL(M,-R1,B(1),B(2),A(1,N+2),A(2,N+2))
  26       DO 10 I = 1,M
  27       A(I,N+3)=N+I
  28    10 CONTINUE
  29       DO 20 J = 1,N
  30       A(M+1,J)=J
  31    20 CONTINUE
  32       A(M+1,N+1)=0
  33       ITER=0
  34       IOCD=1
  35       CALL RVSET(N,R0,X(1),X(2))
  36
  37       LEV=1
  38
  39       K=0
  40       NK=N+1
  41    30 K=K+1
  42       NK=NK-1
  43       MODE=0
  44       CALL RVSET(M-K+1,R1,B(1),B(2))
  45
  46    50 D=-BIG
  47       DO 60 I = K,M
  48       IF(B(I) .NE. 0) THEN
  49        DD=ABS(A(I,N+2))
  50        IF(DD .GT. D) THEN
  51         IQ=I
  52         D=DD
  53        ENDIF
  54       ENDIF
  55    60 CONTINUE
  56       IF(K .LE. 1 .AND. D .LE. TOL) THEN
  57        RESMAX=0
  58        MODE=2
  59        GOTO 380
  60       ENDIF
  61       D=TOL
  62       DO 80 J = 1,NK
  63       DD=ABS(A(IQ,J))
  64       IF(DD .GT. D) THEN
  65        IP=J
  66        D=DD
  67       ENDIF
  68    80 CONTINUE
  69       IF(D .GT. TOL) GOTO 330
  70
  71       B(IQ)=0
  72       IF(MODE .EQ. 1)  GOTO 50
  73       DO 100 I = K,M
  74       IF(B(I) .NE. 0) THEN
  75        DO 90 J = 1,NK
  76        IF(ABS(A(I,J)) .GT. TOL) THEN
  77         MODE=1
  78         GOTO 50
  79        ENDIF
  80    90  CONTINUE
  81       ENDIF
  82   100 CONTINUE
  83       IRK=K-1
  84       NR=N+1-IRK
  85       IOCD=0
  86       GOTO 160
  87
  88   110 CALL RVXCH(N+3,A(IQ,1),A(IQ,2),A(K,1),A(K,2))
  89       CALL RVXCH(M+1,A(1,IP),A(2,IP),A(1,NK),A(2,NK))
  90       IF(K .LT. N)  GOTO 30
  91   160 IF(IRK .EQ. M) GOTO 380
  92
  93       LEV=2
  94
  95       D=TOL
  96       DO 170 I = IRK+1,M
  97       DD=ABS(A(I,N+2))
  98       IF(DD .GT. D) THEN
  99        IQ=I
 100        D=DD
 101       ENDIF
 102   170 CONTINUE
 103
 104       IF(D .LE. TOL) THEN
 105        RESMAX=0
 106        MODE=3
 107        GOTO 380
 108       ENDIF
 109       IF(A(IQ,N+2) .GE. -TOL) THEN
 110        A(IQ,N+1)=2-A(IQ,N+1)
 111        CALL RVSCL(N+4-NR,-R1,A(IQ,1),A(IQ,2),A(IQ,1),A(IQ,2))
 112        A(IQ,N+1)=-A(IQ,N+1)
 113       ENDIF
 114       DO 220 J = NR,N
 115       IF(A(IQ,J) .GE. TOL) THEN
 116        CALL RVSCA(M,R2,
 117      1            A(1,J),A(2,J),A(1,N+1),A(2,N+1),A(1,N+1),A(2,N+1))
 118        CALL RVSCL(M,-R1,A(1,J),A(2,J),A(1,J),A(2,J))
 119        A(M+1,J)=-A(M+1,J)
 120       ENDIF
 121   220 CONTINUE
 122       IP=N+1
 123       GOTO 330
 124
 125   230 IF(IRK+1 .EQ. M) GO TO 380
 126       CALL RVXCH(IRK+3,A(IQ,1),A(IQ,2),A(M,1),A(M,2))
 127
 128       LEV=3
 129
 130   260 D=-TOL
 131       H=2*A(M,N+2)
 132       DO 280 I = IRK+1,M-1
 133       IF(A(I,N+2) .LT. D) THEN
 134        IQ=I
 135        D=A(I,N+2)
 136        MODE=0
 137       ELSE
 138        DD=H-A(I,N+2)
 139        IF(DD .LT. D) THEN
 140         IQ=I
 141         D=DD
 142         MODE=1
 143        ENDIF
 144       ENDIF
 145   280 CONTINUE
 146       IF(D .GE. -TOL)  GOTO 380
 147       DD=-D/A(M,N+2)
 148       IF(DD .LT. RELTMP) THEN
 149        RELERR=DD
 150        MODE=4
 151        GOTO 380
 152       ENDIF
 153       IF(MODE .NE. 0) THEN
 154        CALL RVSCS(IRK+1,R2,
 155      1            A(M,1),A(M,2),A(IQ,1),A(IQ,2),A(IQ,1),A(IQ,2))
 156        A(IQ,N+2)=D
 157        A(IQ,N+3)=-A(IQ,N+3)
 158       ENDIF
 159       D=BIG
 160       DO 320 J = NR,N+1
 161       IF(A(IQ,J) .GT. TOL) THEN
 162        DD=A(M,J)/A(IQ,J)
 163        IF(DD .LT. D) THEN
 164         IP=J
 165         D=DD
 166        ENDIF
 167       ENDIF
 168   320 CONTINUE
 169       IF(D .LT. BIG) GO TO 330
 170       IOCD=2
 171       GOTO 380
 172
 173   330 RPVT=1/A(IQ,IP)
 174       CALL RVSCL(M,RPVT,A(1,IP),A(2,IP),A(1,IP),A(2,IP))
 175       DO 360 I = 1,M
 176       IF(I .NE. IQ) THEN
 177        D=A(I,IP)
 178        CALL RVSCA(N+3-NR,-D,
 179      1          A(IQ,NR),A(IQ,NR+1),A(I,NR),A(I,NR+1),A(I,NR),A(I,NR+1))
 180        A(I,IP)=D
 181       ENDIF
 182   360 CONTINUE
 183       CALL RVSCL(IRK+2,-RPVT,A(IQ,NR),A(IQ,NR+1),A(IQ,NR),A(IQ,NR+1))
 184       A(IQ,IP)=RPVT
 185       D=A(M+1,IP)
 186       A(M+1,IP)=A(IQ,N+3)
 187       A(IQ,N+3)=D
 188       ITER=ITER+1
 189       GOTO (110,230,260), LEV
 190
 191   380 CALL RVSET(M,R0,B(1),B(2))
 192       IF(MODE .EQ. 2)  GOTO 450
 193       DO 400 I = 1,IRK
 194       X(INT(A(I,N+3)))=A(I,N+2)
 195   400 CONTINUE
 196       IF(MODE .EQ. 3 .OR. IRK .EQ. M)  GOTO 450
 197       DO 410 J = NR,N+1
 198       B(INT(ABS(A(M+1,J)))-N)=A(M,N+2)*SIGN(R1,A(M+1,J))
 199   410 CONTINUE
 200       DO 420 I = IRK+1,M-1
 201       B(INT(ABS(A(I,N+3)))-N)=(A(M,N+2)-A(I,N+2))*SIGN(R1,A(I,N+3))
 202   420 CONTINUE
 203   430 DO 440 J = NR,N+1
 204       IF(ABS(A(M,J)) .LE. TOL) THEN
 205        IOCD=0
 206        GOTO 450
 207       ENDIF
 208   440 CONTINUE
 209   450 IF(MODE .NE. 2 .AND. MODE .NE. 3) RESMAX=A(M,N+2)
 210       IF(IRK .EQ. M) RESMAX=0
 211       IF(MODE .EQ. 4) RESMAX=RESMAX-D
 212       RETURN
 213       END
 214 #endif