ic.pl

   1 #!/usr/bin/perl -w
   2 use strict;
   3 use Parallel::MPI::Simple;
   4
   5 # Test basic functionality and blocking
   6 MPI_Init();
   7 my($rank,$size);
   8 $rank = MPI_Comm_rank(MPI_COMM_WORLD);
   9 $size = MPI_Comm_size(MPI_COMM_WORLD);
  10
  11 if ($rank ==0) {
  12   my $msg = "Hi ho the lillies grow\n";
  13   MPI_Send($msg,1,0,MPI_COMM_WORLD);
  14   $msg = MPI_Recv(1,0,MPI_COMM_WORLD);
  15   print $msg;
  16
  17   print "ok 2 # MPI_Send MPI_Recv\n";
  18   MPI_Barrier(MPI_COMM_WORLD);
  19 }
  20 else {
  21   my $msg = MPI_Recv(0,0,MPI_COMM_WORLD);
  22   $msg =~ s/(Hi ho).*/ok 1/;
  23   MPI_Send($msg, 0,0,MPI_COMM_WORLD);
  24
  25   MPI_Barrier(MPI_COMM_WORLD);
  26   print "ok 3 # MPI_Barrier\n";
  27 }
  28
  29 # Test broadcast
  30 MPI_Barrier(MPI_COMM_WORLD);
  31 if ($rank ==0) {
  32   my $msg = 4;
  33   $msg = MPI_Bcast($msg, 0,MPI_COMM_WORLD);
  34 }
  35 else {
  36   my $msg = MPI_Bcast(undef, 0, MPI_COMM_WORLD);
  37   print "ok $msg # MPI_Bcast\n";
  38 }
  39
  40 # Test gather
  41 MPI_Barrier(MPI_COMM_WORLD);
  42 if ($rank ==0) {
  43   my $msg = "ok 5 # MPI_Gather\n";
  44   print MPI_Gather($msg, 0, MPI_COMM_WORLD);
  45 }
  46 else {
  47   my $msg = "ok 6 # MPI_Gather\n";
  48   print MPI_Gather($msg, 0, MPI_COMM_WORLD); # shouldn't print anything.
  49 }
  50
  51 # Test Scatter
  52 MPI_Barrier(MPI_COMM_WORLD);
  53 {
  54   my $rt = MPI_Scatter(["ok 7 # MPI_Scatter\n", "ok 8\n"],
  55                           0, MPI_COMM_WORLD);
  56   print $rt if $rank ==0;
  57   MPI_Barrier(MPI_COMM_WORLD);
  58   print $rt if $rank ==1;
  59 }
  60
  61 # blessed reference
  62 MPI_Barrier(MPI_COMM_WORLD);
  63 { print "ok 9 # Skipped - blessed references\n" if $rank ==0; last;
  64   my $obj = bless {cows=>"ok 9 # blessed ref\n"}, 'ZZZZZ::Testing';
  65   my $sobj;
  66   if ($rank == 0) {
  67     MPI_Send($obj, 1, 0, MPI_COMM_WORLD);
  68   }
  69   else {
  70     $sobj = MPI_Recv($obj, 0, 0, MPI_COMM_WORLD);
  71     print $sobj->method;
  72   }
  73 }
  74
  75 # Test Allgather
  76 MPI_Barrier(MPI_COMM_WORLD);
  77 {
  78   my @rt = MPI_Allgather($rank, MPI_COMM_WORLD);
  79   if ($rank ==0) {
  80     print "ok ". ($rt[0]+10) . " # MPI_Allgather\n";
  81     print "ok ". ($rt[1]+10) . "\n";
  82     MPI_Barrier(MPI_COMM_WORLD);
  83   }
  84   else {
  85     MPI_Barrier(MPI_COMM_WORLD);
  86     print "ok ". ($rt[0]+12)."\n";
  87     print "ok ". ($rt[1]+12)."\n";
  88   }
  89 }
  90
  91 # Test Alltoall
  92 {
  93   MPI_Barrier(MPI_COMM_WORLD);
  94   my @data = (14+2*$rank, 15+2*$rank);
  95   my @return = MPI_Alltoall(\@data, MPI_COMM_WORLD);
  96   if ($rank == 0) {
  97     print "ok $return[0] # MPI_Alltoall\n"; # 14
  98     MPI_Barrier(MPI_COMM_WORLD);
  99     print "ok $return[1]\n";
 100     MPI_Barrier(MPI_COMM_WORLD);
 101   }
 102   else {
 103     MPI_Barrier(MPI_COMM_WORLD);
 104     print "ok $return[0]\n";
 105     MPI_Barrier(MPI_COMM_WORLD);
 106     print "ok $return[1]\n";
 107   }
 108 }
 109
 110 # reduce
 111 MPI_Barrier(MPI_COMM_WORLD);
 112 {
 113   my $rt = MPI_Reduce($rank, sub {$_[0] + $_[1]}, MPI_COMM_WORLD);
 114   if ($rank == 0) {
 115     print "not " unless $rt == 1;
 116     print "ok 18 # reduce\n";
 117   }
 118   else {
 119     print "not " unless $rt == 1;
 120     print "ok 19 # reduce\n";
 121   }
 122 }
 123
 124 MPI_Barrier(MPI_COMM_WORLD);
 125 { # MPI_Comm_compare
 126     if (MPI_Comm_compare(MPI_COMM_WORLD,MPI_COMM_WORLD) != MPI_IDENT) {
 127         print "not ";
 128     }
 129     print "ok 2$rank # Comm_compare (ident)\n";
 130 }
 131
 132 {
 133     MPI_Barrier(MPI_COMM_WORLD);
 134     my $dup = MPI_Comm_dup(MPI_COMM_WORLD);
 135     if ($rank==0&&MPI_Comm_compare($dup, MPI_COMM_WORLD) != MPI_CONGRUENT) {
 136         print "not ";
 137     }
 138     print "ok 22 # comm_dup\n" if $rank ==0;
 139     MPI_Comm_free($dup);
 140 }
 141
 142 {
 143     MPI_Barrier(MPI_COMM_WORLD);
 144     if ($rank ==0 ) {
 145         my $newcomm = MPI_Comm_split(MPI_COMM_WORLD, $rank, 0);
 146         if (MPI_Comm_compare($newcomm, MPI_COMM_WORLD) !=
 147             MPI_UNEQUAL) {
 148             print "not ";
 149         }
 150         print "ok 23 # MPI_Comm_split\n";
 151         MPI_Comm_free($newcomm);
 152     }
 153     else {
 154         my $rt=MPI_Comm_split(MPI_COMM_WORLD, MPI_UNDEFINED, 0);
 155         if (defined($rt)) {print "not "}
 156         print "ok 24 # MPI_Comm_split, not in new\n";
 157     }
 158 }
 159
 160 MPI_Barrier(MPI_COMM_WORLD);
 161 if ($rank == 0) {
 162     my $msg = "Sending from ANY";
 163     MPI_Send($msg,1,0,MPI_COMM_WORLD);
 164     print "ok 25 # sent from ANY\n";
 165 }
 166 else {
 167     my $msg = MPI_Recv(MPI_ANY_SOURCE,0,MPI_COMM_WORLD);
 168     if ($msg =~ /Sending from ANY/) {
 169         print "ok 26 # receive from ANY_SOURCE";
 170     }
 171     else {
 172         print "not ok 26 # receive from ANY_SOURCE";
 173     }
 174 }
 175
 176 MPI_Finalize();
 177 exit(0);
 178
 179 package ZZZZZ::Testing;
 180 sub method {
 181   return $_[0]->{cows};
 182 }
 183