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 234