SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
pdlawrite.f
Go to the documentation of this file.
1 SUBROUTINE pdlawrite( FILNAM, M, N, A, IA, JA, DESCA, IRWRIT,
2 $ ICWRIT, WORK )
3*
4* -- ScaLAPACK tools routine (version 1.8) --
5* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6* and University of California, Berkeley.
7*
8* written by Antoine Petitet, August 1995 (petitet@cs.utk.edu)
9* adapted by Julie Langou, April 2007 (julie@cs.utk.edu)
10*
11* .. Scalar Arguments ..
12 INTEGER IA, ICWRIT, IRWRIT, JA, M, N
13* ..
14* .. Array Arguments ..
15 CHARACTER*(*) FILNAM
16 INTEGER DESCA( * )
17 DOUBLE PRECISION A( * ), WORK( * )
18* ..
19*
20* Purpose
21* =======
22*
23* PDLAWRITE writes to a file named FILNAMa distributed matrix sub( A )
24* denoting A(IA:IA+M-1,JA:JA+N-1). The local pieces are sent to and
25* written by the process of coordinates (IRWWRITE, ICWRIT).
26*
27* WORK must be of size >= MB_ = DESCA( MB_ ).
28*
29* =====================================================================
30*
31* .. Parameters ..
32 INTEGER NOUT
33 parameter( nout = 13 )
34 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DT_,
35 $ lld_, mb_, m_, nb_, n_, rsrc_
36 parameter( block_cyclic_2d = 1, dlen_ = 9, dt_ = 1,
37 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
38 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
39* ..
40* .. Local Scalars ..
41 INTEGER H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
42 $ icurrow, ii, iia, in, j, jb, jj, jja, jn, k,
43 $ lda, mycol, myrow, npcol, nprow
44* ..
45* .. External Subroutines ..
46 EXTERNAL blacs_barrier, blacs_gridinfo, infog2l,
47 $ dgerv2d, dgesd2d
48* ..
49* .. External Functions ..
50 INTEGER ICEIL
51 EXTERNAL iceil
52* ..
53* .. Intrinsic Functions ..
54 INTRINSIC min, mod
55* ..
56* .. Executable Statements ..
57*
58* Get grid parameters
59*
60 ictxt = desca( ctxt_ )
61 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
62*
63 IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
64 OPEN( nout, file=filnam, status='UNKNOWN' )
65 WRITE( nout, fmt = * ) m, n
66 END IF
67*
68 CALL infog2l( ia, ja, desca, nprow, npcol, myrow, mycol,
69 $ iia, jja, iarow, iacol )
70 icurrow = iarow
71 icurcol = iacol
72 ii = iia
73 jj = jja
74 lda = desca( lld_ )
75*
76* Handle the first block of column separately
77*
78 jn = min( iceil( ja, desca( nb_ ) ) * desca( nb_ ), ja+n-1 )
79 jb = jn-ja+1
80 DO 60 h = 0, jb-1
81 in = min( iceil( ia, desca( mb_ ) ) * desca( mb_ ), ia+m-1 )
82 ib = in-ia+1
83 IF( icurrow.EQ.irwrit .AND. icurcol.EQ.icwrit ) THEN
84 IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
85 DO 10 k = 0, ib-1
86 WRITE( nout, fmt = 9999 ) a( ii+k+(jj+h-1)*lda )
87 10 CONTINUE
88 END IF
89 ELSE
90 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
91 CALL dgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ), lda,
92 $ irwrit, icwrit )
93 ELSE IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
94 CALL dgerv2d( ictxt, ib, 1, work, desca( mb_ ),
95 $ icurrow, icurcol )
96 DO 20 k = 1, ib
97 WRITE( nout, fmt = 9999 ) work( k )
98 20 CONTINUE
99 END IF
100 END IF
101 IF( myrow.EQ.icurrow )
102 $ ii = ii + ib
103 icurrow = mod( icurrow+1, nprow )
104 CALL blacs_barrier( ictxt, 'All' )
105*
106* Loop over remaining block of rows
107*
108 DO 50 i = in+1, ia+m-1, desca( mb_ )
109 ib = min( desca( mb_ ), ia+m-i )
110 IF( icurrow.EQ.irwrit .AND. icurcol.EQ.icwrit ) THEN
111 IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
112 DO 30 k = 0, ib-1
113 WRITE( nout, fmt = 9999 ) a( ii+k+(jj+h-1)*lda )
114 30 CONTINUE
115 END IF
116 ELSE
117 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
118 CALL dgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
119 $ lda, irwrit, icwrit )
120 ELSE IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
121 CALL dgerv2d( ictxt, ib, 1, work, desca( mb_ ),
122 $ icurrow, icurcol )
123 DO 40 k = 1, ib
124 WRITE( nout, fmt = 9999 ) work( k )
125 40 CONTINUE
126 END IF
127 END IF
128 IF( myrow.EQ.icurrow )
129 $ ii = ii + ib
130 icurrow = mod( icurrow+1, nprow )
131 CALL blacs_barrier( ictxt, 'All' )
132 50 CONTINUE
133*
134 ii = iia
135 icurrow = iarow
136 60 CONTINUE
137*
138 IF( mycol.EQ.icurcol )
139 $ jj = jj + jb
140 icurcol = mod( icurcol+1, npcol )
141 CALL blacs_barrier( ictxt, 'All' )
142*
143* Loop over remaining column blocks
144*
145 DO 130 j = jn+1, ja+n-1, desca( nb_ )
146 jb = min( desca( nb_ ), ja+n-j )
147 DO 120 h = 0, jb-1
148 in = min( iceil( ia, desca( mb_ ) ) * desca( mb_ ), ia+m-1 )
149 ib = in-ia+1
150 IF( icurrow.EQ.irwrit .AND. icurcol.EQ.icwrit ) THEN
151 IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
152 DO 70 k = 0, ib-1
153 WRITE( nout, fmt = 9999 ) a( ii+k+(jj+h-1)*lda )
154 70 CONTINUE
155 END IF
156 ELSE
157 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
158 CALL dgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
159 $ lda, irwrit, icwrit )
160 ELSE IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
161 CALL dgerv2d( ictxt, ib, 1, work, desca( mb_ ),
162 $ icurrow, icurcol )
163 DO 80 k = 1, ib
164 WRITE( nout, fmt = 9999 ) work( k )
165 80 CONTINUE
166 END IF
167 END IF
168 IF( myrow.EQ.icurrow )
169 $ ii = ii + ib
170 icurrow = mod( icurrow+1, nprow )
171 CALL blacs_barrier( ictxt, 'All' )
172*
173* Loop over remaining block of rows
174*
175 DO 110 i = in+1, ia+m-1, desca( mb_ )
176 ib = min( desca( mb_ ), ia+m-i )
177 IF( icurrow.EQ.irwrit .AND. icurcol.EQ.icwrit ) THEN
178 IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
179 DO 90 k = 0, ib-1
180 WRITE( nout, fmt = 9999 ) a( ii+k+(jj+h-1)*lda )
181 90 CONTINUE
182 END IF
183 ELSE
184 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
185 CALL dgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
186 $ lda, irwrit, icwrit )
187 ELSE IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
188 CALL dgerv2d( ictxt, ib, 1, work, desca( mb_ ),
189 $ icurrow, icurcol )
190 DO 100 k = 1, ib
191 WRITE( nout, fmt = 9999 ) work( k )
192 100 CONTINUE
193 END IF
194 END IF
195 IF( myrow.EQ.icurrow )
196 $ ii = ii + ib
197 icurrow = mod( icurrow+1, nprow )
198 CALL blacs_barrier( ictxt, 'All' )
199 110 CONTINUE
200*
201 ii = iia
202 icurrow = iarow
203 120 CONTINUE
204*
205 IF( mycol.EQ.icurcol )
206 $ jj = jj + jb
207 icurcol = mod( icurcol+1, npcol )
208 CALL blacs_barrier( ictxt, 'All' )
209*
210 130 CONTINUE
211*
212 IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
213 CLOSE( nout )
214 END IF
215*
216 9999 FORMAT( d30.18 )
217*
218 RETURN
219*
220* End of PDLAWRITE
221*
222 END
infog2l
subroutine infog2l(grindx, gcindx, desc, nprow, npcol, myrow, mycol, lrindx, lcindx, rsrc, csrc)
Definition infog2l.f:3
min
#define min(A, B)
Definition pcgemr.c:181
pdlawrite
subroutine pdlawrite(filnam, m, n, a, ia, ja, desca, irwrit, icwrit, work)
Definition pdlawrite.f:3