Mercurial > hg > octave-nkf

annotate libcruft/amos/xzabs.f @ 8209:2abbc8036f6a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
graphics.cc: style fix
author John W. Eaton <jwe@octave.org>
date Fri, 10 Oct 2008 14:54:47 -0400
parents 8b0cb8f79fdc
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
3217
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
1 DOUBLE PRECISION FUNCTION XZABS(ZR, ZI)
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
2 C***BEGIN PROLOGUE XZABS
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
3 C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
4 C
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
5 C XZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
6 C PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI)
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
7 C
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
8 C***ROUTINES CALLED (NONE)
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
9 C***END PROLOGUE XZABS
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
10 DOUBLE PRECISION ZR, ZI, U, V, Q, S
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
11 U = DABS(ZR)
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
12 V = DABS(ZI)
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
13 S = U + V
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
14 C-----------------------------------------------------------------------
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
15 C S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
16 C TRUE FLOATING ZERO
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
17 C-----------------------------------------------------------------------
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
18 S = S*1.0D+0
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
19 IF (S.EQ.0.0D+0) GO TO 20
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
20 IF (U.GT.V) GO TO 10
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
21 Q = U/V
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
22 XZABS = V*DSQRT(1.D+0+Q*Q)
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
23 RETURN
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
24 10 Q = V/U
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
25 XZABS = U*DSQRT(1.D+0+Q*Q)
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
26 RETURN
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
27 20 XZABS = 0.0D+0
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
28 RETURN
8b0cb8f79fdc [project @ 1998-11-11 23:32:20 by jwe]
jwe
parents:
diff changeset
29 END