ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pclawrite.f
Go to the documentation of this file.
1  SUBROUTINE pclawrite( 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 A( * ), WORK( * )
18 * ..
19 *
20 * Purpose
21 * =======
22 *
23 * PCLAWRITE 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  $ cgerv2d, cgesd2d
48 * ..
49 * .. External Functions ..
50  INTEGER ICEIL
51  EXTERNAL iceil
52 * ..
53 * .. Intrinsic Functions ..
54  INTRINSIC aimag, real, 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 cgesd2d( 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 cgerv2d( ictxt, ib, 1, work, desca( mb_ ),
95  $ icurrow, icurcol )
96  DO 20 k = 1, ib
97  WRITE( nout, fmt = 9999 ) real(work( k )),
98  $ aimag(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  $ real(a( ii+k+(jj+h-1)*lda )),
116  $ aimag(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 cgesd2d( 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 cgerv2d( ictxt, ib, 1, work, desca( mb_ ),
125  $ icurrow, icurcol )
126  DO 40 k = 1, ib
127  WRITE( nout, fmt = 9999 ) real(work( k )),
128  $ aimag(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  $ real(a( ii+k+(jj+h-1)*lda )),
159  $ aimag(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 cgesd2d( 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 cgerv2d( ictxt, ib, 1, work, desca( mb_ ),
168  $ icurrow, icurcol )
169  DO 80 k = 1, ib
170  WRITE( nout, fmt = 9999 ) real(work( k )),
171  $ aimag(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  $ real(a( ii+k+(jj+h-1)*lda )),
189  $ aimag(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 cgesd2d( 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 cgerv2d( ictxt, ib, 1, work, desca( mb_ ),
198  $ icurrow, icurcol )
199  DO 100 k = 1, ib
200  WRITE( nout, fmt = 9999 ) real(work( k )),
201  $ aimag(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( d30.18,d30.18 )
227 *
228  RETURN
229 *
230 * End of PCLAWRITE
231 *
232  END
233 
infog2l
subroutine infog2l(GRINDX, GCINDX, DESC, NPROW, NPCOL, MYROW, MYCOL, LRINDX, LCINDX, RSRC, CSRC)
Definition: infog2l.f:3
pclawrite
subroutine pclawrite(FILNAM, M, N, A, IA, JA, DESCA, IRWRIT, ICWRIT, WORK)
Definition: pclawrite.f:3
min
#define min(A, B)
Definition: pcgemr.c:181