ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
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
pdlawrite
subroutine pdlawrite(FILNAM, M, N, A, IA, JA, DESCA, IRWRIT, ICWRIT, WORK)
Definition: pdlawrite.f:3
min
#define min(A, B)
Definition: pcgemr.c:181