SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
pzlawrite.f
Go to the documentation of this file.
1 SUBROUTINE pzlawrite( 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 COMPLEX*16 A( * ), WORK( * )
18* ..
19*
20* Purpose
21* =======
22*
23* PZLAWRITE 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 $ zgerv2d, zgesd2d
48* ..
49* .. External Functions ..
50 INTEGER ICEIL
51 EXTERNAL iceil
52* ..
53* .. Intrinsic Functions ..
54 INTRINSIC dble, dimag, 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 zgesd2d( 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 zgerv2d( ictxt, ib, 1, work, desca( mb_ ),
95 $ icurrow, icurcol )
96 DO 20 k = 1, ib
97 WRITE( nout, fmt = 9999 ) dble(work( k )),
98 $ dimag(work( k ))
99 20 CONTINUE
100 END IF
101 END IF
102 IF( myrow.EQ.icurrow )
103 $ ii = ii + ib
104 icurrow = mod( icurrow+1, nprow )
105 CALL blacs_barrier( ictxt, 'All' )
106*
107* Loop over remaining block of rows
108*
109 DO 50 i = in+1, ia+m-1, desca( mb_ )
110 ib = min( desca( mb_ ), ia+m-i )
111 IF( icurrow.EQ.irwrit .AND. icurcol.EQ.icwrit ) THEN
112 IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
113 DO 30 k = 0, ib-1
114 WRITE( nout, fmt = 9999 )
115 $ dble(a( ii+k+(jj+h-1)*lda )),
116 $ dimag(a( ii+k+(jj+h-1)*lda ))
117 30 CONTINUE
118 END IF
119 ELSE
120 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
121 CALL zgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
122 $ lda, irwrit, icwrit )
123 ELSE IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
124 CALL zgerv2d( ictxt, ib, 1, work, desca( mb_ ),
125 $ icurrow, icurcol )
126 DO 40 k = 1, ib
127 WRITE( nout, fmt = 9999 ) dble(work( k )),
128 $ dimag(work( k ))
129 40 CONTINUE
130 END IF
131 END IF
132 IF( myrow.EQ.icurrow )
133 $ ii = ii + ib
134 icurrow = mod( icurrow+1, nprow )
135 CALL blacs_barrier( ictxt, 'All' )
136 50 CONTINUE
137*
138 ii = iia
139 icurrow = iarow
140 60 CONTINUE
141*
142 IF( mycol.EQ.icurcol )
143 $ jj = jj + jb
144 icurcol = mod( icurcol+1, npcol )
145 CALL blacs_barrier( ictxt, 'All' )
146*
147* Loop over remaining column blocks
148*
149 DO 130 j = jn+1, ja+n-1, desca( nb_ )
150 jb = min( desca( nb_ ), ja+n-j )
151 DO 120 h = 0, jb-1
152 in = min( iceil( ia, desca( mb_ ) ) * desca( mb_ ), ia+m-1 )
153 ib = in-ia+1
154 IF( icurrow.EQ.irwrit .AND. icurcol.EQ.icwrit ) THEN
155 IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
156 DO 70 k = 0, ib-1
157 WRITE( nout, fmt = 9999 )
158 $ dble(a( ii+k+(jj+h-1)*lda )),
159 $ dimag(a( ii+k+(jj+h-1)*lda ))
160 70 CONTINUE
161 END IF
162 ELSE
163 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
164 CALL zgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
165 $ lda, irwrit, icwrit )
166 ELSE IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
167 CALL zgerv2d( ictxt, ib, 1, work, desca( mb_ ),
168 $ icurrow, icurcol )
169 DO 80 k = 1, ib
170 WRITE( nout, fmt = 9999 ) dble(work( k )),
171 $ dimag(work( k))
172 80 CONTINUE
173 END IF
174 END IF
175 IF( myrow.EQ.icurrow )
176 $ ii = ii + ib
177 icurrow = mod( icurrow+1, nprow )
178 CALL blacs_barrier( ictxt, 'All' )
179*
180* Loop over remaining block of rows
181*
182 DO 110 i = in+1, ia+m-1, desca( mb_ )
183 ib = min( desca( mb_ ), ia+m-i )
184 IF( icurrow.EQ.irwrit .AND. icurcol.EQ.icwrit ) THEN
185 IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
186 DO 90 k = 0, ib-1
187 WRITE( nout, fmt = 9999 )
188 $ dble(a( ii+k+(jj+h-1)*lda )),
189 $ dimag(a( ii+k+(jj+h-1)*lda ))
190 90 CONTINUE
191 END IF
192 ELSE
193 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
194 CALL zgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
195 $ lda, irwrit, icwrit )
196 ELSE IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
197 CALL zgerv2d( ictxt, ib, 1, work, desca( mb_ ),
198 $ icurrow, icurcol )
199 DO 100 k = 1, ib
200 WRITE( nout, fmt = 9999 ) dble(work( k )),
201 $ dimag(work( k ))
202 100 CONTINUE
203 END IF
204 END IF
205 IF( myrow.EQ.icurrow )
206 $ ii = ii + ib
207 icurrow = mod( icurrow+1, nprow )
208 CALL blacs_barrier( ictxt, 'All' )
209 110 CONTINUE
210*
211 ii = iia
212 icurrow = iarow
213 120 CONTINUE
214*
215 IF( mycol.EQ.icurcol )
216 $ jj = jj + jb
217 icurcol = mod( icurcol+1, npcol )
218 CALL blacs_barrier( ictxt, 'All' )
219*
220 130 CONTINUE
221*
222 IF( myrow.EQ.irwrit .AND. mycol.EQ.icwrit ) THEN
223 CLOSE( nout )
224 END IF
225*
226 9999 FORMAT( e15.8,e15.8 )
227*
228 RETURN
229*
230* End of PZLAWRITE
231*
232 END
233
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
pzlawrite
subroutine pzlawrite(filnam, m, n, a, ia, ja, desca, irwrit, icwrit, work)
Definition pzlawrite.f:3