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