This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / MINICERN / mathlib / gen / divon / modchl.F
1 *
2 * $Id$
3 *
4 * $Log$
5 * Revision 1.1.1.1  1996/04/01 15:03:26  mclareni
6 * Mathlib gen
7 *
8 *
9 #include "gen/pilot.h"
10       SUBROUTINE MODCHL (N,NADIM,AHESS,ALPHA,Z,IFAIL)
11       INTEGER N, NADIM, IFAIL
12       DOUBLE PRECISION ALPHA
13       DOUBLE PRECISION AHESS(NADIM,N), Z(N)
14       INTEGER I, IB, IP1, J, K
15       DOUBLE PRECISION A, BETA, DB, DI, GAMMA, P1, RMAX, T, W
16 #if defined(CERNLIB_IBM)||defined(CERNLIB_SINGLE)
17       RMAX=7.2D+75
18 #endif
19 #if (!defined(CERNLIB_IBM))&&(defined(CERNLIB_DOUBLE))
20       RMAX= 1.0D+37
21 #endif
22       IFAIL=0
23       A=ALPHA
24       K=0
25       DO 50 I=1,N
26       P1=Z(I)
27       DI=AHESS(I,I)
28       T=A*P1
29       DB=DI+T*P1
30       AHESS(I,I)=DB
31       IF(DB.GE.1.0D+0) GOTO 10
32       IF(DB.GT.0.0D+0.AND.DI.LE.RMAX*DB) GOTO 10
33       IFAIL=1
34       RETURN
35  10   GAMMA=DI/DB
36       BETA=T/DB
37       A=A*GAMMA
38       K=K+I
39       J=K
40       IF(I.EQ.N) GOTO 50
41       IP1=I+1
42       IF(GAMMA.GE.2.5D-1) GOTO 30
43       DO 20 IB=IP1,N
44       T=AHESS(IB,I)
45       AHESS(IB,I)=T*GAMMA+BETA*Z(IB)
46       Z(IB)=Z(IB)-P1*T
47  20   CONTINUE
48       GOTO 50
49  30   DO 40 IB=IP1,N
50       T=AHESS(IB,I)
51       W=Z(IB)-P1*T
52       Z(IB)=W
53       AHESS(IB,I)=BETA*W+T
54  40   CONTINUE
55  50   CONTINUE
56       RETURN
57       END