examples/smpi/NAS/MPI_dummy/mpi_dummy.f

   1       subroutine mpi_isend(buf,count,datatype,source,
   2      & tag,comm,request,ierror)
   3       integer buf(*), count,datatype,source,tag,comm,
   4      & request,ierror
   5       call mpi_error()
   6       return
   7       end
   8
   9       subroutine mpi_irecv(buf,count,datatype,source,
  10      & tag,comm,request,ierror)
  11       integer buf(*), count,datatype,source,tag,comm,
  12      & request,ierror
  13       call mpi_error()
  14       return
  15       end
  16
  17       subroutine mpi_send(buf,count,datatype,dest,tag,comm,ierror)
  18       integer buf(*), count,datatype,dest,tag,comm,ierror
  19       call mpi_error()
  20       return
  21       end
  22
  23       subroutine mpi_recv(buf,count,datatype,source,
  24      & tag,comm,status,ierror)
  25       integer buf(*), count,datatype,source,tag,comm,
  26      & status(*),ierror
  27       call mpi_error()
  28       return
  29       end
  30
  31       subroutine mpi_comm_split(comm,color,key,newcomm,ierror)
  32       integer comm,color,key,newcomm,ierror
  33       return
  34       end
  35
  36       subroutine mpi_comm_rank(comm, rank,ierr)
  37       implicit none
  38       integer comm, rank,ierr
  39       rank = 0
  40       return
  41       end
  42
  43       subroutine mpi_comm_size(comm, size, ierr)
  44       implicit none
  45       integer comm, size, ierr
  46       size = 1
  47       return
  48       end
  49
  50       double precision function mpi_wtime()
  51       implicit none
  52       double precision t
  53 c This function must measure wall clock time, not CPU time.
  54 c Since there is no portable timer in Fortran (77)
  55 c we call a routine compiled in C (though the C source may have
  56 c to be tweaked).
  57       call wtime(t)
  58 c The following is not ok for "official" results because it reports
  59 c CPU time not wall clock time. It may be useful for developing/testing
  60 c on timeshared Crays, though.
  61 c     call second(t)
  62
  63       mpi_wtime = t
  64
  65       return
  66       end
  67
  68
  69 c may be valid to call this in single processor case
  70       subroutine mpi_barrier(comm,ierror)
  71       return
  72       end
  73
  74 c may be valid to call this in single processor case
  75       subroutine mpi_bcast(buf, nitems, type, root, comm, ierr)
  76       implicit none
  77       integer buf(*), nitems, type, root, comm, ierr
  78       return
  79       end
  80
  81       subroutine mpi_comm_dup(oldcomm, newcomm,ierror)
  82       integer oldcomm, newcomm,ierror
  83       newcomm= oldcomm
  84       return
  85       end
  86
  87       subroutine mpi_error()
  88       print *, 'mpi_error called'
  89       stop
  90       end
  91
  92       subroutine mpi_abort(comm, errcode, ierr)
  93       implicit none
  94       integer comm, errcode, ierr
  95       print *, 'mpi_abort called'
  96       stop
  97       end
  98
  99       subroutine mpi_finalize(ierr)
 100       return
 101       end
 102
 103       subroutine mpi_init(ierr)
 104       return
 105       end
 106
 107
 108 c assume double precision, which is all SP uses
 109       subroutine mpi_reduce(inbuf, outbuf, nitems,
 110      $                      type, op, root, comm, ierr)
 111       implicit none
 112       include 'mpif.h'
 113       integer nitems, type, op, root, comm, ierr
 114       double precision inbuf(*), outbuf(*)
 115
 116       if (type .eq. mpi_double_precision) then
 117          call mpi_reduce_dp(inbuf, outbuf, nitems,
 118      $                      type, op, root, comm, ierr)
 119       else if (type .eq.  mpi_double_complex) then
 120          call mpi_reduce_dc(inbuf, outbuf, nitems,
 121      $                      type, op, root, comm, ierr)
 122       else if (type .eq.  mpi_complex) then
 123          call mpi_reduce_complex(inbuf, outbuf, nitems,
 124      $                      type, op, root, comm, ierr)
 125       else if (type .eq.  mpi_real) then
 126          call mpi_reduce_real(inbuf, outbuf, nitems,
 127      $                      type, op, root, comm, ierr)
 128       else if (type .eq.  mpi_integer) then
 129          call mpi_reduce_int(inbuf, outbuf, nitems,
 130      $                      type, op, root, comm, ierr)
 131       else
 132          print *, 'mpi_reduce: unknown type ', type
 133       end if
 134       return
 135       end
 136
 137
 138       subroutine mpi_reduce_real(inbuf, outbuf, nitems,
 139      $                      type, op, root, comm, ierr)
 140       implicit none
 141       integer nitems, type, op, root, comm, ierr, i
 142       real inbuf(*), outbuf(*)
 143       do i = 1, nitems
 144          outbuf(i) = inbuf(i)
 145       end do
 146
 147       return
 148       end
 149
 150       subroutine mpi_reduce_dp(inbuf, outbuf, nitems,
 151      $                      type, op, root, comm, ierr)
 152       implicit none
 153       integer nitems, type, op, root, comm, ierr, i
 154       double precision inbuf(*), outbuf(*)
 155       do i = 1, nitems
 156          outbuf(i) = inbuf(i)
 157       end do
 158
 159       return
 160       end
 161
 162       subroutine mpi_reduce_dc(inbuf, outbuf, nitems,
 163      $                      type, op, root, comm, ierr)
 164       implicit none
 165       integer nitems, type, op, root, comm, ierr, i
 166       double complex inbuf(*), outbuf(*)
 167       do i = 1, nitems
 168          outbuf(i) = inbuf(i)
 169       end do
 170
 171       return
 172       end
 173
 174
 175       subroutine mpi_reduce_complex(inbuf, outbuf, nitems,
 176      $                      type, op, root, comm, ierr)
 177       implicit none
 178       integer nitems, type, op, root, comm, ierr, i
 179       complex inbuf(*), outbuf(*)
 180       do i = 1, nitems
 181          outbuf(i) = inbuf(i)
 182       end do
 183
 184       return
 185       end
 186
 187       subroutine mpi_reduce_int(inbuf, outbuf, nitems,
 188      $                      type, op, root, comm, ierr)
 189       implicit none
 190       integer nitems, type, op, root, comm, ierr, i
 191       integer inbuf(*), outbuf(*)
 192       do i = 1, nitems
 193          outbuf(i) = inbuf(i)
 194       end do
 195
 196       return
 197       end
 198
 199       subroutine mpi_allreduce(inbuf, outbuf, nitems,
 200      $                      type, op, comm, ierr)
 201       implicit none
 202       integer nitems, type, op, comm, ierr
 203       double precision inbuf(*), outbuf(*)
 204
 205       call mpi_reduce(inbuf, outbuf, nitems,
 206      $                      type, op, 0, comm, ierr)
 207       return
 208       end
 209
 210       subroutine mpi_alltoall(inbuf, nitems, type, outbuf, nitems_dum,
 211      $                        type_dum, comm, ierr)
 212       implicit none
 213       include 'mpif.h'
 214       integer nitems, type, comm, ierr, nitems_dum, type_dum
 215       double precision inbuf(*), outbuf(*)
 216       if (type .eq. mpi_double_precision) then
 217          call mpi_alltoall_dp(inbuf, outbuf, nitems,
 218      $                      type, comm, ierr)
 219       else if (type .eq.  mpi_double_complex) then
 220          call mpi_alltoall_dc(inbuf, outbuf, nitems,
 221      $                      type, comm, ierr)
 222       else if (type .eq.  mpi_complex) then
 223          call mpi_alltoall_complex(inbuf, outbuf, nitems,
 224      $                      type, comm, ierr)
 225       else if (type .eq.  mpi_real) then
 226          call mpi_alltoall_real(inbuf, outbuf, nitems,
 227      $                      type, comm, ierr)
 228       else if (type .eq.  mpi_integer) then
 229          call mpi_alltoall_int(inbuf, outbuf, nitems,
 230      $                      type, comm, ierr)
 231       else
 232          print *, 'mpi_alltoall: unknown type ', type
 233       end if
 234       return
 235       end
 236
 237       subroutine mpi_alltoall_dc(inbuf, outbuf, nitems,
 238      $                           type, comm, ierr)
 239       implicit none
 240       integer nitems, type, comm, ierr, i
 241       double complex inbuf(*), outbuf(*)
 242       do i = 1, nitems
 243          outbuf(i) = inbuf(i)
 244       end do
 245
 246       return
 247       end
 248
 249
 250       subroutine mpi_alltoall_complex(inbuf, outbuf, nitems,
 251      $                           type, comm, ierr)
 252       implicit none
 253       integer nitems, type, comm, ierr, i
 254       double complex inbuf(*), outbuf(*)
 255       do i = 1, nitems
 256          outbuf(i) = inbuf(i)
 257       end do
 258
 259       return
 260       end
 261
 262       subroutine mpi_alltoall_dp(inbuf, outbuf, nitems,
 263      $                           type, comm, ierr)
 264       implicit none
 265       integer nitems, type, comm, ierr, i
 266       double precision inbuf(*), outbuf(*)
 267       do i = 1, nitems
 268          outbuf(i) = inbuf(i)
 269       end do
 270
 271       return
 272       end
 273
 274       subroutine mpi_alltoall_real(inbuf, outbuf, nitems,
 275      $                             type, comm, ierr)
 276       implicit none
 277       integer nitems, type, comm, ierr, i
 278       real inbuf(*), outbuf(*)
 279       do i = 1, nitems
 280          outbuf(i) = inbuf(i)
 281       end do
 282
 283       return
 284       end
 285
 286       subroutine mpi_alltoall_int(inbuf, outbuf, nitems,
 287      $                            type, comm, ierr)
 288       implicit none
 289       integer nitems, type, comm, ierr, i
 290       integer inbuf(*), outbuf(*)
 291       do i = 1, nitems
 292          outbuf(i) = inbuf(i)
 293       end do
 294
 295       return
 296       end
 297
 298       subroutine mpi_wait(request,status,ierror)
 299       integer request,status,ierror
 300       call mpi_error()
 301       return
 302       end
 303
 304       subroutine mpi_waitall(count,requests,status,ierror)
 305       integer count,requests(*),status(*),ierror
 306       call mpi_error()
 307       return
 308       end
 309