Mercurial > octave-nkf

comparison libcruft/arpack/util/dmout.f @ 12274:9f5d2ef078e8 release-3-4-x

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
import ARPACK sources to libcruft from Debian package libarpack2 2.1+parpack96.dfsg-3+b1
author John W. Eaton <jwe@octave.org>
date Fri, 28 Jan 2011 14:04:33 -0500
parents
children
comparison
equal deleted inserted replaced
12273:83133b5bf392 12274:9f5d2ef078e8
1 *-----------------------------------------------------------------------
2 * Routine: DMOUT
3 *
4 * Purpose: Real matrix output routine.
5 *
6 * Usage: CALL DMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT)
7 *
8 * Arguments
9 * M - Number of rows of A. (Input)
10 * N - Number of columns of A. (Input)
11 * A - Real M by N matrix to be printed. (Input)
12 * LDA - Leading dimension of A exactly as specified in the
13 * dimension statement of the calling program. (Input)
14 * IFMT - Format to be used in printing matrix A. (Input)
15 * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In)
16 * If IDIGIT .LT. 0, printing is done with 72 columns.
17 * If IDIGIT .GT. 0, printing is done with 132 columns.
18 *
19 *-----------------------------------------------------------------------
20 *
21 SUBROUTINE DMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT )
22 * ...
23 * ... SPECIFICATIONS FOR ARGUMENTS
24 * ...
25 * ... SPECIFICATIONS FOR LOCAL VARIABLES
26 * .. Scalar Arguments ..
27 CHARACTER*( * ) IFMT
28 INTEGER IDIGIT, LDA, LOUT, M, N
29 * ..
30 * .. Array Arguments ..
31 DOUBLE PRECISION A( LDA, * )
32 * ..
33 * .. Local Scalars ..
34 CHARACTER*80 LINE
35 INTEGER I, J, K1, K2, LLL, NDIGIT
36 * ..
37 * .. Local Arrays ..
38 CHARACTER ICOL( 3 )
39 * ..
40 * .. Intrinsic Functions ..
41 INTRINSIC LEN, MIN, MIN0
42 * ..
43 * .. Data statements ..
44 DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o',
45 $ 'l' /
46 * ..
47 * .. Executable Statements ..
48 * ...
49 * ... FIRST EXECUTABLE STATEMENT
50 *
51 LLL = MIN( LEN( IFMT ), 80 )
52 DO 10 I = 1, LLL
53 LINE( I: I ) = '-'
54 10 CONTINUE
55 *
56 DO 20 I = LLL + 1, 80
57 LINE( I: I ) = ' '
58 20 CONTINUE
59 *
60 WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL )
61 9999 FORMAT( / 1X, A, / 1X, A )
62 *
63 IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 )
64 $ RETURN
65 NDIGIT = IDIGIT
66 IF( IDIGIT.EQ.0 )
67 $ NDIGIT = 4
68 *
69 *=======================================================================
70 * CODE FOR OUTPUT USING 72 COLUMNS FORMAT
71 *=======================================================================
72 *
73 IF( IDIGIT.LT.0 ) THEN
74 NDIGIT = -IDIGIT
75 IF( NDIGIT.LE.4 ) THEN
76 DO 40 K1 = 1, N, 5
77 K2 = MIN0( N, K1+4 )
78 WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 )
79 DO 30 I = 1, M
80 WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 )
81 30 CONTINUE
82 40 CONTINUE
83 *
84 ELSE IF( NDIGIT.LE.6 ) THEN
85 DO 60 K1 = 1, N, 4
86 K2 = MIN0( N, K1+3 )
87 WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 )
88 DO 50 I = 1, M
89 WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 )
90 50 CONTINUE
91 60 CONTINUE
92 *
93 ELSE IF( NDIGIT.LE.10 ) THEN
94 DO 80 K1 = 1, N, 3
95 K2 = MIN0( N, K1+2 )
96 WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 )
97 DO 70 I = 1, M
98 WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 )
99 70 CONTINUE
100 80 CONTINUE
101 *
102 ELSE
103 DO 100 K1 = 1, N, 2
104 K2 = MIN0( N, K1+1 )
105 WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 )
106 DO 90 I = 1, M
107 WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 )
108 90 CONTINUE
109 100 CONTINUE
110 END IF
111 *
112 *=======================================================================
113 * CODE FOR OUTPUT USING 132 COLUMNS FORMAT
114 *=======================================================================
115 *
116 ELSE
117 IF( NDIGIT.LE.4 ) THEN
118 DO 120 K1 = 1, N, 10
119 K2 = MIN0( N, K1+9 )
120 WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 )
121 DO 110 I = 1, M
122 WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 )
123 110 CONTINUE
124 120 CONTINUE
125 *
126 ELSE IF( NDIGIT.LE.6 ) THEN
127 DO 140 K1 = 1, N, 8
128 K2 = MIN0( N, K1+7 )
129 WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 )
130 DO 130 I = 1, M
131 WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 )
132 130 CONTINUE
133 140 CONTINUE
134 *
135 ELSE IF( NDIGIT.LE.10 ) THEN
136 DO 160 K1 = 1, N, 6
137 K2 = MIN0( N, K1+5 )
138 WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 )
139 DO 150 I = 1, M
140 WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 )
141 150 CONTINUE
142 160 CONTINUE
143 *
144 ELSE
145 DO 180 K1 = 1, N, 5
146 K2 = MIN0( N, K1+4 )
147 WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 )
148 DO 170 I = 1, M
149 WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 )
150 170 CONTINUE
151 180 CONTINUE
152 END IF
153 END IF
154 WRITE( LOUT, FMT = 9990 )
155 *
156 9998 FORMAT( 10X, 10( 4X, 3A1, I4, 1X ) )
157 9997 FORMAT( 10X, 8( 5X, 3A1, I4, 2X ) )
158 9996 FORMAT( 10X, 6( 7X, 3A1, I4, 4X ) )
159 9995 FORMAT( 10X, 5( 9X, 3A1, I4, 6X ) )
160 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 10D12.3 )
161 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 8D14.5 )
162 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 6D18.9 )
163 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 5D22.13 )
164 9990 FORMAT( 1X, ' ' )
165 *
166 RETURN
167 END