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 223