Mercurial > octave-nkf

annotate libcruft/odepack/sewset.f @ 7948:af10baa63915 ss-3-1-50

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
3.1.50 snapshot
author John W. Eaton <jwe@octave.org>
date Fri, 18 Jul 2008 17:42:48 -0400
parents 96ba591be50f
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
7793
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
1 SUBROUTINE SEWSET (N, ITOL, RTOL, ATOL, YCUR, EWT)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
2 C***BEGIN PROLOGUE SEWSET
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
3 C***SUBSIDIARY
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
4 C***PURPOSE Set error weight vector.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
5 C***TYPE SINGLE PRECISION (SEWSET-S, DEWSET-D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
6 C***AUTHOR Hindmarsh, Alan C., (LLNL)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
7 C***DESCRIPTION
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
8 C
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
9 C This subroutine sets the error weight vector EWT according to
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
10 C EWT(i) = RTOL(i)*ABS(YCUR(i)) + ATOL(i), i = 1,...,N,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
11 C with the subscript on RTOL and/or ATOL possibly replaced by 1 above,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
12 C depending on the value of ITOL.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
13 C
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
14 C***SEE ALSO SLSODE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
15 C***ROUTINES CALLED (NONE)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
16 C***REVISION HISTORY (YYMMDD)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
17 C 791129 DATE WRITTEN
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
18 C 890501 Modified prologue to SLATEC/LDOC format. (FNF)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
19 C 890503 Minor cosmetic changes. (FNF)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
20 C 930809 Renamed to allow single/double precision versions. (ACH)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
21 C***END PROLOGUE SEWSET
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
22 C**End
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
23 INTEGER N, ITOL
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
24 INTEGER I
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
25 REAL RTOL, ATOL, YCUR, EWT
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
26 DIMENSION RTOL(*), ATOL(*), YCUR(N), EWT(N)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
27 C
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
28 C***FIRST EXECUTABLE STATEMENT SEWSET
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
29 GO TO (10, 20, 30, 40), ITOL
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
30 10 CONTINUE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
31 DO 15 I = 1,N
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
32 15 EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
33 RETURN
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
34 20 CONTINUE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
35 DO 25 I = 1,N
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
36 25 EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(I)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
37 RETURN
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
38 30 CONTINUE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
39 DO 35 I = 1,N
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
40 35 EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
41 RETURN
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
42 40 CONTINUE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
43 DO 45 I = 1,N
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
44 45 EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
45 RETURN
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
46 C----------------------- END OF SUBROUTINE SEWSET ----------------------
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
47 END