1program blacs_prb 2! 3!******************************************************************************* 4! 5!! BLACS_PRB is a test program for the BLACS. 6! 7! 8! Discussion: 9! 10! The BLACS is a library of Basic Linear Algebra Communications 11! Subroutines which can facilitate the solution of linear algebra 12! computations that use message passing. 13! 14! Modified: 15! 16! 20 November 2003 17! 18! Reference: 19! 20! Jack Dongarra and Clint Whaley, 21! LAPACK Working Note 94: 22! A User's Guide to the BLACS v1.1, 23! pages 60-62. 24! 25 implicit none 26! 27 integer blacs_pnum 28 integer caller 29 integer contxt 30 integer i 31 integer ios 32 integer j 33 integer pcol_me 34 integer pcol_num 35 integer proc_me 36 integer proc_num 37 integer prow_me 38 integer prow_num 39 integer you 40 integer yourcol 41 integer yourrow 42! 43! The call to BLACS_PINFO will return the process number assigned to 44! this process, and the total number of processes. 45! 46 call blacs_pinfo ( proc_me, proc_num ) 47 48 if ( proc_me == 0 ) then 49 call timestamp ( ) 50 write ( *, '(a)' ) ' ' 51 write ( *, '(a,i6)' ) 'BLACS_PRB - Process ', proc_me 52 write ( *, '(a)' ) ' A sample program for the BLACS.' 53 write ( *, '(a)' ) ' ' 54 write ( *, '(a)' ) ' In this simple example, we begin with a' 55 write ( *, '(a)' ) ' certain number of processes.' 56 write ( *, '(a)' ) ' ' 57 write ( *, '(a)' ) ' These processes are arranged into a 2D' 58 write ( *, '(a)' ) ' computational grid (and any left over processes' 59 write ( *, '(a)' ) ' will exit.)' 60 write ( *, '(a)' ) ' ' 61 write ( *, '(a)' ) ' Then BLACS is initialized, and the (0,0) process' 62 write ( *, '(a)' ) ' expects to receive a "check-in" message from all' 63 write ( *, '(a)' ) ' other active processes.' 64 write ( *, '(a)' ) ' ' 65 write ( *, '(a,i12)' ) ' The number of processes is ', proc_num 66 else 67 write ( *, '(a)' ) ' ' 68 write ( *, '(a,i6)' ) 'BLACS_PRB - Process ', proc_me 69 write ( *, '(a)' ) ' Process beginning.' 70 end if 71! 72! If in PVM, create the virtual machine if it doesn't exist. 73! 74 if ( proc_num < 1 ) then 75 if ( proc_me == 0 ) then 76 write ( *, '(a)' ) ' ' 77 write ( *, '(a,i6)' ) 'BLACS_PRB - Process ', proc_me 78 write ( *, '(a)' ) ' Please enter the number of processes.' 79 read ( *, *, iostat = ios ) proc_num 80 if ( ios /= 0 ) then 81 write ( *, '(a)' ) ' ' 82 write ( *, '(a,i6)' ) 'BLACS_PRB - Process ', proc_me 83 write ( *, '(a)' ) ' Abnormal end of execution.' 84 write ( *, '(a)' ) ' Could not input number of processes.' 85 stop 86 end if 87 call blacs_setup ( proc_me, proc_num ) 88 end if 89 end if 90! 91! Set up the process grid. 92! 93 prow_num = int ( sqrt ( real ( proc_num ) ) ) 94 pcol_num = proc_num / prow_num 95 96 if ( proc_me == 0 ) then 97 write ( *, '(a)' ) ' ' 98 write ( *, '(a,i6)' ) 'BLACS_PRB - Process ', proc_me 99 write ( *, '(a)' ) ' Setting up the 2D process grid.' 100 write ( *, '(a)' ) ' ' 101 write ( *, '(a,i3)' ) ' prow_num = ', prow_num 102 write ( *, '(a,i3)' ) ' pcol_num = ', pcol_num 103 end if 104! 105! Get the default system context. 106! 107 call blacs_get ( 0, 0, contxt ) 108! 109! Define the grid. 110! 111 if ( proc_me == 0 ) then 112 write ( *, '(a)' ) ' ' 113 write ( *, '(a,i10)' ) 'The context handle is: ', contxt 114 write ( *, '(a,i6)' ) 'BLACS_PRB - Process ', proc_me 115 write ( *, '(a)' ) ' Calling BLACS_GRIDINIT to define the grid.' 116 end if 117 118 call blacs_gridinit ( contxt, 'ROW', prow_num, pcol_num ) 119! 120! Get this process's row and column grid coordinates. 121! 122 if ( proc_me == 0 ) then 123 write ( *, '(a)' ) ' ' 124 write ( *, '(a,i6)' ) 'BLACS_PRB - Process ', proc_me 125 write ( *, '(a)' ) ' Calling BLACS_GRIDINFO for process grid coordinates.' 126 end if 127 128 call blacs_gridinfo ( contxt, prow_num, pcol_num, prow_me, pcol_me ) 129! 130! If this process is not in the grid, exit. 131! 132 if ( prow_num <= prow_me .or. pcol_num <= pcol_me ) then 133 write ( *, '(a)' ) ' ' 134 write ( *, '(a)' ) 'BLACS_PRB - Process ', proc_me 135 write ( *, '(a)' ) ' Not part of the grid, exiting.' 136 call blacs_exit ( 0 ) 137 stop 138 end if 139! 140! Get the process id from the grid coordinates. 141! 142 if ( proc_me == 0 ) then 143 write ( *, '(a)' ) ' ' 144 write ( *, '(a,i6)' ) 'BLACS_PRB - Process ', proc_me 145 write ( *, '(a)' ) ' Call BLACS_PNUM for process id from grid coordinates.' 146 end if 147 148 caller = blacs_pnum ( contxt, prow_me, pcol_me ) 149! 150! Process (0,0) RECEIVES check-in messages from all other processes. 151! 152 if ( prow_me == 0 .and. pcol_me == 0 ) then 153 154 write ( *, '(a)' ) ' ' 155 write ( *, '(a)' ) 'Process(0,0):' 156 write ( *, '(a)' ) ' All other processes must send me a check in message.' 157 write ( *, '(a)' ) ' ' 158 write ( *, '(a)' ) ' Process BLACS' 159 write ( *, '(a)' ) ' Row Col ID' 160 write ( *, '(a)' ) ' ' 161 162 do i = 0, prow_num - 1 163 do j = 0, pcol_num - 1 164 165 if ( i == 0 .and. j == 0 ) then 166 you = caller 167 else 168 call igerv2d ( contxt, 1, 1, you, 1, i, j ) 169 end if 170! 171! From the remote process's rank, determine its grid coordinates. 172! 173 call blacs_pcoord ( contxt, you, yourrow, yourcol ) 174! 175! If the grid coordinates are not what we expect, fail. 176! 177 if ( yourrow /= i .or. yourcol /= j ) then 178 write ( *, '(a)' ) ' ' 179 write ( *, '(a)' ) 'BLACS_PRB - Master (0,0) process:' 180 write ( *, '(a,i6)' ) ' A grid error has occurred with process ', you 181 stop 182 end if 183 184 write ( *, '(3i6)' ) i, j, you 185 186 end do 187 end do 188! 189! Non-master processes SEND their process number to BLACS process (0,0). 190! 191 else 192 193 call igesd2d ( contxt, 1, 1, caller, 1, 0, 0 ) 194 195 end if 196 197 call blacs_exit ( 0 ) 198 199 if ( prow_me == 0 .and. pcol_me == 0 ) then 200 write ( *, '(a)' ) ' ' 201 write ( *, '(a)' ) 'BLACS_PRB - Master (0,0) process:' 202 write ( *, '(a)' ) ' Normal end of execution.' 203 write ( *, '(a)' ) ' ' 204 call timestamp ( ) 205 end if 206 207 stop 208end 209subroutine timestamp ( ) 210! 211!******************************************************************************* 212! 213!! TIMESTAMP prints the current YMDHMS date as a time stamp. 214! 215! 216! Example: 217! 218! May 31 2001 9:45:54.872 AM 219! 220! Modified: 221! 222! 31 May 2001 223! 224! Author: 225! 226! John Burkardt 227! 228! Parameters: 229! 230! None 231! 232 implicit none 233! 234 character ( len = 8 ) ampm 235 integer d 236 character ( len = 8 ) date 237 integer h 238 integer m 239 integer mm 240 character ( len = 9 ), parameter, dimension(12) :: month = (/ & 241 'January ', 'February ', 'March ', 'April ', & 242 'May ', 'June ', 'July ', 'August ', & 243 'September', 'October ', 'November ', 'December ' /) 244 integer n 245 integer s 246 character ( len = 10 ) time 247 integer values(8) 248 integer y 249 character ( len = 5 ) zone 250! 251 call date_and_time ( date, time, zone, values ) 252 253 y = values(1) 254 m = values(2) 255 d = values(3) 256 h = values(5) 257 n = values(6) 258 s = values(7) 259 mm = values(8) 260 261 if ( h < 12 ) then 262 ampm = 'AM' 263 else if ( h == 12 ) then 264 if ( n == 0 .and. s == 0 ) then 265 ampm = 'Noon' 266 else 267 ampm = 'PM' 268 end if 269 else 270 h = h - 12 271 if ( h < 12 ) then 272 ampm = 'PM' 273 else if ( h == 12 ) then 274 if ( n == 0 .and. s == 0 ) then 275 ampm = 'Midnight' 276 else 277 ampm = 'AM' 278 end if 279 end if 280 end if 281 282 write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & 283 trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) 284 285 return 286end 287