MINICERN/mathlib/gen/divon/shrnk.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:03:27  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10       SUBROUTINE SHRNK (N,NADIM,AHESS,IOUT,VEC)
  11       INTEGER N, NADIM, IOUT
  12       DOUBLE PRECISION AHESS(NADIM, N), VEC(N)
  13       INTEGER I, IFAIL, IM1, IOM1, J, NM1
  14       DOUBLE PRECISION GAMMA
  15       IF(N.EQ.IOUT.OR.N.EQ.1) RETURN
  16       IF(IOUT.EQ.1) GOTO 20
  17       IOM1=IOUT-1
  18       DO 10 I=1,IOM1
  19       VEC(I)=0.0D+0
  20  10   CONTINUE
  21  20   NM1=N-1
  22       GAMMA=AHESS(IOUT,IOUT)
  23       DO 30 I=IOUT,NM1
  24       VEC(I)=AHESS(I+1,IOUT)
  25       AHESS(I,I)=AHESS(I+1,I+1)
  26  30   CONTINUE
  27       DO 50 I=IOUT,NM1
  28       IM1=I-1
  29       IF(IM1.EQ.0) GOTO 50
  30       DO 40 J=1,IM1
  31       AHESS(I,J)=AHESS(I+1,J)
  32  40   CONTINUE
  33  50   CONTINUE
  34       CALL MODCHL(NM1,NADIM,AHESS,GAMMA,VEC,IFAIL)
  35       AHESS(N,N)=0.0D+0
  36       DO 60 J=1,NM1
  37       AHESS(N,J)=0.0D+0
  38  60   CONTINUE
  39       RETURN
  40       END