Logo AND Algorithmique Numérique Distribuée

Public GIT Repository
remove a few more leaks to please valgrind, but nothing important
[simgrid.git] / src / smpi / smpi_f77.c
1 /* Copyright (c) 2010. The SimGrid Team.
2  * All rights reserved.                                                     */
3
4 /* This program is free software; you can redistribute it and/or modify it
5   * under the terms of the license (GNU LGPL) which comes with this package. */
6
7 #include <limits.h>
8 #include <stdio.h>
9
10 #include "private.h"
11 #include "xbt.h"
12
13 extern int xargc;
14 extern char** xargv;
15
16 static xbt_dynar_t comm_lookup = NULL;
17 static xbt_dynar_t group_lookup = NULL;
18 static xbt_dict_t request_lookup = NULL;
19 static xbt_dynar_t datatype_lookup = NULL;
20 static xbt_dynar_t op_lookup = NULL;
21
22 #define KEY_SIZE (sizeof(int) * 2 + 1)
23
24 static int new_comm(MPI_Comm comm) {
25   xbt_dynar_push(comm_lookup, &comm);
26   return (int)xbt_dynar_length(comm_lookup) - 1;
27 }
28
29 static void free_comm(int comm) {
30   xbt_dynar_remove_at(comm_lookup, comm, NULL);
31 }
32
33 static MPI_Comm get_comm(int comm) {
34   if(comm == -2) {
35     return MPI_COMM_SELF;
36   } else if(comm_lookup && comm >= 0 && comm < (int)xbt_dynar_length(comm_lookup)) {
37     return *(MPI_Comm*)xbt_dynar_get_ptr(comm_lookup, comm);
38   }
39   return MPI_COMM_NULL;
40 }
41
42 static int new_group(MPI_Group group) {
43   xbt_dynar_push(group_lookup, &group);
44   return (int)xbt_dynar_length(group_lookup) - 1;
45 }
46
47 static MPI_Group get_group(int group) {
48   if(group == -2) {
49     return MPI_GROUP_EMPTY;
50   } else if(group_lookup && group >= 0 && group < (int)xbt_dynar_length(group_lookup)) {
51     return *(MPI_Group*)xbt_dynar_get_ptr(group_lookup, group);
52   }
53   return MPI_COMM_NULL;
54 }
55
56 static char* get_key(char* key, int id) {
57   snprintf(key, KEY_SIZE, "%x", id);
58   return key;
59 }
60
61 static int new_request(MPI_Request req) {
62   static int request_id = INT_MIN;
63   char key[KEY_SIZE];
64
65   xbt_dict_set(request_lookup, get_key(key, request_id), req, NULL);
66   return request_id++;
67 }
68
69 static MPI_Request find_request(int req) {
70   char key[KEY_SIZE];
71    
72   return (MPI_Request)xbt_dict_get(request_lookup, get_key(key, req));
73 }
74
75 static int new_datatype(MPI_Datatype datatype) {
76   xbt_dynar_push(datatype_lookup, &datatype);
77   return (int)xbt_dynar_length(datatype_lookup) - 1;
78 }
79
80 static MPI_Datatype get_datatype(int datatype) {
81   return datatype >= 0
82          ? *(MPI_Datatype*)xbt_dynar_get_ptr(datatype_lookup, datatype)
83          : MPI_DATATYPE_NULL;
84 }
85
86 static void free_datatype(int datatype) {
87   xbt_dynar_remove_at(datatype_lookup, datatype, NULL);
88 }
89
90 static int new_op(MPI_Op op) {
91   xbt_dynar_push(op_lookup, &op);
92   return (int)xbt_dynar_length(op_lookup) - 1;
93 }
94
95 static MPI_Op get_op(int op) {
96    return op >= 0
97           ? *(MPI_Op*)xbt_dynar_get_ptr(op_lookup, op)
98           : MPI_OP_NULL;
99 }
100
101 void mpi_init_(int* ierr) {
102    if(!comm_lookup){
103      comm_lookup = xbt_dynar_new(sizeof(MPI_Comm), NULL);
104      new_comm(MPI_COMM_WORLD);
105      group_lookup = xbt_dynar_new(sizeof(MPI_Group), NULL);
106
107      request_lookup = xbt_dict_new_homogeneous(NULL);
108
109      datatype_lookup = xbt_dynar_new(sizeof(MPI_Datatype), NULL);
110      new_datatype(MPI_BYTE);
111      new_datatype(MPI_CHAR);
112      new_datatype(MPI_INT);
113      new_datatype(MPI_INT);
114      new_datatype(MPI_INT8_T);
115      new_datatype(MPI_INT16_T);
116      new_datatype(MPI_INT32_T);
117      new_datatype(MPI_INT64_T);
118      new_datatype(MPI_FLOAT);
119      new_datatype(MPI_FLOAT);
120      new_datatype(MPI_DOUBLE);
121      new_datatype(MPI_DOUBLE);
122      new_datatype(MPI_C_FLOAT_COMPLEX);
123      new_datatype(MPI_C_DOUBLE_COMPLEX);
124      new_datatype(MPI_2INT);
125      new_datatype(MPI_UINT8_T);
126      new_datatype(MPI_UINT16_T);
127      new_datatype(MPI_UINT32_T);
128      new_datatype(MPI_UINT64_T);
129      new_datatype(MPI_2FLOAT);
130      new_datatype(MPI_2DOUBLE);
131
132
133      op_lookup = xbt_dynar_new(sizeof(MPI_Op), NULL);
134      new_op(MPI_MAX);
135      new_op(MPI_MIN);
136      new_op(MPI_MAXLOC);
137      new_op(MPI_MINLOC);
138      new_op(MPI_SUM);
139      new_op(MPI_PROD);
140      new_op(MPI_LAND);
141      new_op(MPI_LOR);
142      new_op(MPI_LXOR);
143      new_op(MPI_BAND);
144      new_op(MPI_BOR);
145      new_op(MPI_BXOR);
146    }
147    /* smpif2c is responsible for generating a call with the final arguments */
148    *ierr = MPI_Init(NULL, NULL);
149 }
150
151 void mpi_finalize_(int* ierr) {
152    *ierr = MPI_Finalize();
153    xbt_dynar_free(&op_lookup);
154    op_lookup = NULL;
155    xbt_dynar_free(&datatype_lookup);
156    datatype_lookup = NULL;
157    xbt_dict_free(&request_lookup);
158    request_lookup = NULL;
159    xbt_dynar_free(&comm_lookup);
160    comm_lookup = NULL;
161 }
162
163 void mpi_abort_(int* comm, int* errorcode, int* ierr) {
164   *ierr = MPI_Abort(get_comm(*comm), *errorcode);
165 }
166
167 void mpi_comm_rank_(int* comm, int* rank, int* ierr) {
168    *ierr = MPI_Comm_rank(get_comm(*comm), rank);
169 }
170
171 void mpi_comm_size_(int* comm, int* size, int* ierr) {
172    *ierr = MPI_Comm_size(get_comm(*comm), size);
173 }
174
175 double mpi_wtime_(void) {
176    return MPI_Wtime();
177 }
178
179 double mpi_wtick_(void) {
180   return MPI_Wtick();
181 }
182
183 void mpi_comm_dup_(int* comm, int* newcomm, int* ierr) {
184   MPI_Comm tmp;
185
186   *ierr = MPI_Comm_dup(get_comm(*comm), &tmp);
187   if(*ierr == MPI_SUCCESS) {
188     *newcomm = new_comm(tmp);
189   }
190 }
191
192 void mpi_comm_create_(int* comm, int* group, int* newcomm, int* ierr) {
193   MPI_Comm tmp;
194
195   *ierr = MPI_Comm_create(get_comm(*comm),get_group(*group), &tmp);
196   if(*ierr == MPI_SUCCESS) {
197     *newcomm = new_comm(tmp);
198   }
199 }
200
201
202 void mpi_comm_free_(int* comm, int* ierr) {
203   MPI_Comm tmp = get_comm(*comm);
204
205   *ierr = MPI_Comm_free(&tmp);
206
207   if(*ierr == MPI_SUCCESS) {
208     free_comm(*comm);
209   }
210 }
211
212 void mpi_comm_split_(int* comm, int* color, int* key, int* comm_out, int* ierr) {
213   MPI_Comm tmp;
214
215   *ierr = MPI_Comm_split(get_comm(*comm), *color, *key, &tmp);
216   if(*ierr == MPI_SUCCESS) {
217     *comm_out = new_comm(tmp);
218   }
219 }
220
221 void mpi_group_incl_(int* group, int* n, int* ranks, int* group_out, int* ierr) {
222   MPI_Group tmp;
223
224   *ierr = MPI_Group_incl(get_group(*group), *n, ranks, &tmp);
225   if(*ierr == MPI_SUCCESS) {
226     *group_out = new_group(tmp);
227   }
228 }
229
230 void mpi_comm_group_(int* comm, int* group_out,  int* ierr) {
231   MPI_Group tmp;
232
233   *ierr = MPI_Comm_group(get_comm(*comm), &tmp);
234   if(*ierr == MPI_SUCCESS) {
235     *group_out = new_group(tmp);
236   }
237 }
238
239
240 void mpi_initialized_(int* flag, int* ierr){
241   *ierr = MPI_Initialized(flag);
242 }
243
244 void mpi_send_init_(void *buf, int* count, int* datatype, int* dst, int* tag,
245                      int* comm, int* request, int* ierr) {
246   MPI_Request req;
247
248   *ierr = MPI_Send_init(buf, *count, get_datatype(*datatype), *dst, *tag,
249                         get_comm(*comm), &req);
250   if(*ierr == MPI_SUCCESS) {
251     *request = new_request(req);
252   }
253 }
254
255 void mpi_isend_(void *buf, int* count, int* datatype, int* dst,
256                  int* tag, int* comm, int* request, int* ierr) {
257   MPI_Request req;
258
259   *ierr = MPI_Isend(buf, *count, get_datatype(*datatype), *dst, *tag,
260                     get_comm(*comm), &req);
261   if(*ierr == MPI_SUCCESS) {
262     *request = new_request(req);
263   }
264 }
265
266 void mpi_irsend_(void *buf, int* count, int* datatype, int* dst,
267                  int* tag, int* comm, int* request, int* ierr) {
268   MPI_Request req;
269
270   *ierr = MPI_Irsend(buf, *count, get_datatype(*datatype), *dst, *tag,
271                     get_comm(*comm), &req);
272   if(*ierr == MPI_SUCCESS) {
273     *request = new_request(req);
274   }
275 }
276
277 void mpi_send_(void* buf, int* count, int* datatype, int* dst,
278                 int* tag, int* comm, int* ierr) {
279    *ierr = MPI_Send(buf, *count, get_datatype(*datatype), *dst, *tag,
280                     get_comm(*comm));
281 }
282
283 void mpi_rsend_(void* buf, int* count, int* datatype, int* dst,
284                 int* tag, int* comm, int* ierr) {
285    *ierr = MPI_Rsend(buf, *count, get_datatype(*datatype), *dst, *tag,
286                     get_comm(*comm));
287 }
288
289 void mpi_sendrecv_(void* sendbuf, int* sendcount, int* sendtype, int* dst,
290                 int* sendtag, void *recvbuf, int* recvcount,
291                 int* recvtype, int* src, int* recvtag,
292                 int* comm, MPI_Status* status, int* ierr) {
293    *ierr = MPI_Sendrecv(sendbuf, *sendcount, get_datatype(*sendtype), *dst,
294        *sendtag, recvbuf, *recvcount,get_datatype(*recvtype), *src, *recvtag,
295        get_comm(*comm), status);
296 }
297
298 void mpi_recv_init_(void *buf, int* count, int* datatype, int* src, int* tag,
299                      int* comm, int* request, int* ierr) {
300   MPI_Request req;
301
302   *ierr = MPI_Recv_init(buf, *count, get_datatype(*datatype), *src, *tag,
303                         get_comm(*comm), &req);
304   if(*ierr == MPI_SUCCESS) {
305     *request = new_request(req);
306   }
307 }
308
309 void mpi_irecv_(void *buf, int* count, int* datatype, int* src, int* tag,
310                  int* comm, int* request, int* ierr) {
311   MPI_Request req;
312
313   *ierr = MPI_Irecv(buf, *count, get_datatype(*datatype), *src, *tag,
314                     get_comm(*comm), &req);
315   if(*ierr == MPI_SUCCESS) {
316     *request = new_request(req);
317   }
318 }
319
320 void mpi_recv_(void* buf, int* count, int* datatype, int* src,
321                 int* tag, int* comm, MPI_Status* status, int* ierr) {
322    *ierr = MPI_Recv(buf, *count, get_datatype(*datatype), *src, *tag,
323                     get_comm(*comm), status);
324 }
325
326 void mpi_start_(int* request, int* ierr) {
327   MPI_Request req = find_request(*request);
328
329   *ierr = MPI_Start(&req);
330 }
331
332 void mpi_startall_(int* count, int* requests, int* ierr) {
333   MPI_Request* reqs;
334   int i;
335
336   reqs = xbt_new(MPI_Request, *count);
337   for(i = 0; i < *count; i++) {
338     reqs[i] = find_request(requests[i]);
339   }
340   *ierr = MPI_Startall(*count, reqs);
341   free(reqs);
342 }
343
344 void mpi_wait_(int* request, MPI_Status* status, int* ierr) {
345    MPI_Request req = find_request(*request);
346    
347    *ierr = MPI_Wait(&req, status);
348 }
349
350 void mpi_waitany_(int* count, int* requests, int* index, MPI_Status* status, int* ierr) {
351   MPI_Request* reqs;
352   int i;
353
354   reqs = xbt_new(MPI_Request, *count);
355   for(i = 0; i < *count; i++) {
356     reqs[i] = find_request(requests[i]);
357   }
358   *ierr = MPI_Waitany(*count, reqs, index, status);
359   free(reqs);
360 }
361
362 void mpi_waitall_(int* count, int* requests, MPI_Status* status, int* ierr) {
363   MPI_Request* reqs;
364   int i;
365
366   reqs = xbt_new(MPI_Request, *count);
367   for(i = 0; i < *count; i++) {
368     reqs[i] = find_request(requests[i]);
369   }
370   *ierr = MPI_Waitall(*count, reqs, status);
371   free(reqs);
372 }
373
374 void mpi_barrier_(int* comm, int* ierr) {
375   *ierr = MPI_Barrier(get_comm(*comm));
376 }
377
378 void mpi_bcast_(void *buf, int* count, int* datatype, int* root, int* comm, int* ierr) {
379   *ierr = MPI_Bcast(buf, *count, get_datatype(*datatype), *root, get_comm(*comm));
380 }
381
382 void mpi_reduce_(void* sendbuf, void* recvbuf, int* count,
383                   int* datatype, int* op, int* root, int* comm, int* ierr) {
384   *ierr = MPI_Reduce(sendbuf, recvbuf, *count,
385                      get_datatype(*datatype), get_op(*op), *root, get_comm(*comm));
386 }
387
388 void mpi_allreduce_(void* sendbuf, void* recvbuf, int* count, int* datatype,
389                      int* op, int* comm, int* ierr) {
390   *ierr = MPI_Allreduce(sendbuf, recvbuf, *count, get_datatype(*datatype),
391                         get_op(*op), get_comm(*comm));
392 }
393
394 void mpi_reduce_scatter_(void* sendbuf, void* recvbuf, int* recvcounts, int* datatype,
395                      int* op, int* comm, int* ierr) {
396   *ierr = MPI_Reduce_scatter(sendbuf, recvbuf, recvcounts, get_datatype(*datatype),
397                         get_op(*op), get_comm(*comm));
398 }
399
400 void mpi_scatter_(void* sendbuf, int* sendcount, int* sendtype,
401                    void* recvbuf, int* recvcount, int* recvtype, 
402                    int* root, int* comm, int* ierr) {
403   *ierr = MPI_Scatter(sendbuf, *sendcount, get_datatype(*sendtype),
404                       recvbuf, *recvcount, get_datatype(*recvtype), *root, get_comm(*comm));
405 }
406
407
408 void mpi_scatterv_(void* sendbuf, int* sendcounts, int* displs, int* sendtype,
409                    void* recvbuf, int* recvcount, int* recvtype,
410                    int* root, int* comm, int* ierr) {
411   *ierr = MPI_Scatterv(sendbuf, sendcounts, displs, get_datatype(*sendtype),
412                       recvbuf, *recvcount, get_datatype(*recvtype), *root, get_comm(*comm));
413 }
414
415 void mpi_gather_(void* sendbuf, int* sendcount, int* sendtype,
416                   void* recvbuf, int* recvcount, int* recvtype,
417                   int* root, int* comm, int* ierr) {
418   *ierr = MPI_Gather(sendbuf, *sendcount, get_datatype(*sendtype),
419                      recvbuf, *recvcount, get_datatype(*recvtype), *root, get_comm(*comm));
420 }
421
422 void mpi_gatherv_(void* sendbuf, int* sendcount, int* sendtype,
423                   void* recvbuf, int* recvcounts, int* displs, int* recvtype,
424                   int* root, int* comm, int* ierr) {
425   *ierr = MPI_Gatherv(sendbuf, *sendcount, get_datatype(*sendtype),
426                      recvbuf, recvcounts, displs, get_datatype(*recvtype), *root, get_comm(*comm));
427 }
428
429 void mpi_allgather_(void* sendbuf, int* sendcount, int* sendtype,
430                      void* recvbuf, int* recvcount, int* recvtype,
431                      int* comm, int* ierr) {
432   *ierr = MPI_Allgather(sendbuf, *sendcount, get_datatype(*sendtype),
433                         recvbuf, *recvcount, get_datatype(*recvtype), get_comm(*comm));
434 }
435
436 void mpi_allgatherv_(void* sendbuf, int* sendcount, int* sendtype,
437                      void* recvbuf, int* recvcounts,int* displs, int* recvtype,
438                      int* comm, int* ierr) {
439   *ierr = MPI_Allgatherv(sendbuf, *sendcount, get_datatype(*sendtype),
440                         recvbuf, recvcounts, displs, get_datatype(*recvtype), get_comm(*comm));
441 }
442
443 void mpi_scan_(void* sendbuf, void* recvbuf, int* count, int* datatype,
444                 int* op, int* comm, int* ierr) {
445   *ierr = MPI_Scan(sendbuf, recvbuf, *count, get_datatype(*datatype),
446                    get_op(*op), get_comm(*comm));
447 }
448
449 void mpi_alltoall_(void* sendbuf, int* sendcount, int* sendtype,
450                     void* recvbuf, int* recvcount, int* recvtype, int* comm, int* ierr) {
451   *ierr = MPI_Alltoall(sendbuf, *sendcount, get_datatype(*sendtype),
452                        recvbuf, *recvcount, get_datatype(*recvtype), get_comm(*comm));
453 }
454
455 void mpi_alltoallv_(void* sendbuf, int* sendcounts, int* senddisps, int* sendtype,
456                     void* recvbuf, int* recvcounts, int* recvdisps, int* recvtype, int* comm, int* ierr) {
457   *ierr = MPI_Alltoallv(sendbuf, sendcounts, senddisps, get_datatype(*sendtype),
458                        recvbuf, recvcounts, recvdisps, get_datatype(*recvtype), get_comm(*comm));
459 }
460
461 void mpi_test_ (int * request, int *flag, MPI_Status * status, int* ierr){
462   MPI_Request req = find_request(*request);
463   *ierr= MPI_Test(&req, flag, status);
464 }
465
466
467 void mpi_testall_ (int* count, int * requests,  int *flag, MPI_Status * statuses, int* ierr){
468   MPI_Request* reqs;
469   int i;
470   reqs = xbt_new(MPI_Request, *count);
471   for(i = 0; i < *count; i++) {
472     reqs[i] = find_request(requests[i]);
473   }
474   *ierr= MPI_Testall(*count, reqs, flag, statuses);
475 }
476
477
478 void mpi_get_processor_name_(char *name, int *resultlen, int* ierr){
479   *ierr = MPI_Get_processor_name(name, resultlen);
480 }
481
482 void mpi_get_count_(MPI_Status * status, int* datatype, int *count, int* ierr){
483   *ierr = MPI_Get_count(status, get_datatype(*datatype), count);
484 }
485
486 void mpi_attr_get_(int* comm, int* keyval, void* attr_value, int* flag, int* ierr ){
487   *ierr = MPI_Attr_get(get_comm(*comm), *keyval, attr_value, flag);
488 }
489
490 void mpi_type_extent_(int* datatype, MPI_Aint * extent, int* ierr){
491   *ierr= MPI_Type_extent(get_datatype(*datatype),  extent);
492 }
493
494 void mpi_type_commit_(int* datatype,  int* ierr){
495   MPI_Datatype tmp= get_datatype(*datatype);
496   *ierr= MPI_Type_commit(&tmp);
497 }
498
499 void mpi_type_vector_(int* count, int* blocklen, int* stride, int* old_type, int* newtype,  int* ierr){
500   MPI_Datatype tmp;
501   *ierr= MPI_Type_vector(*count, *blocklen, *stride, get_datatype(*old_type), &tmp);
502   if(*ierr == MPI_SUCCESS) {
503     *newtype = new_datatype(tmp);
504   }
505 }
506
507 void mpi_type_create_vector_(int* count, int* blocklen, int* stride, int* old_type, int* newtype,  int* ierr){
508   MPI_Datatype tmp;
509   *ierr= MPI_Type_vector(*count, *blocklen, *stride, get_datatype(*old_type), &tmp);
510   if(*ierr == MPI_SUCCESS) {
511     *newtype = new_datatype(tmp);
512   }
513 }
514
515 void mpi_type_hvector_(int* count, int* blocklen, MPI_Aint* stride, int* old_type, int* newtype,  int* ierr){
516   MPI_Datatype tmp;
517   *ierr= MPI_Type_hvector (*count, *blocklen, *stride, get_datatype(*old_type), &tmp);
518   if(*ierr == MPI_SUCCESS) {
519     *newtype = new_datatype(tmp);
520   }
521 }
522
523 void mpi_type_create_hvector_(int* count, int* blocklen, MPI_Aint* stride, int* old_type, int* newtype,  int* ierr){
524   MPI_Datatype tmp;
525   *ierr= MPI_Type_hvector(*count, *blocklen, *stride, get_datatype(*old_type), &tmp);
526   if(*ierr == MPI_SUCCESS) {
527     *newtype = new_datatype(tmp);
528   }
529 }
530
531 void mpi_type_free_(int* datatype, int* ierr){
532   MPI_Datatype tmp= get_datatype(*datatype);
533   *ierr= MPI_Type_free (&tmp);
534   if(*ierr == MPI_SUCCESS) {
535     free_datatype(*datatype);
536   }
537 }
538
539 void mpi_type_ub_(int* datatype, MPI_Aint * disp, int* ierr){
540   *ierr= MPI_Type_ub(get_datatype(*datatype), disp);
541 }
542
543 void mpi_type_lb_(int* datatype, MPI_Aint * extent, int* ierr){
544   *ierr= MPI_Type_extent(get_datatype(*datatype), extent);
545 }
546
547 void mpi_type_size_(int* datatype, int *size, int* ierr)
548 {
549   *ierr = MPI_Type_size(get_datatype(*datatype), size);
550 }
551
552 void mpi_error_string_(int* errorcode, char* string, int* resultlen, int* ierr){
553   *ierr = MPI_Error_string(*errorcode, string, resultlen);
554 }
555
556 void mpi_win_fence_( int* assert,  int* win, int* ierr){
557   *ierr =  MPI_Win_fence(* assert, *(MPI_Win*)win);
558 }
559
560 void mpi_win_free_( int* win, int* ierr){
561   *ierr =  MPI_Win_free(  (MPI_Win*)win);
562 }
563
564 void mpi_win_create_( int *base, MPI_Aint* size, int* disp_unit, int* info, int* comm, int *win, int* ierr){
565   *ierr =  MPI_Win_create( (void*)base, *size, *disp_unit, *(MPI_Info*)info, get_comm(*comm),(MPI_Win*)win);
566 }
567
568 void mpi_info_create_( int *info, int* ierr){
569   *ierr =  MPI_Info_create( (MPI_Info *)info);
570 }
571
572 void mpi_info_set_( int *info, char *key, char *value, int* ierr){
573   *ierr =  MPI_Info_set( (MPI_Info *)info, key, value);
574 }
575
576 void mpi_info_free_(int* info, int* ierr){
577   *ierr =  MPI_Info_free((MPI_Info *) info);
578 }
579
580 void mpi_get_( int *origin_addr, int* origin_count, int* origin_datatype, int *target_rank,
581     MPI_Aint* target_disp, int *target_count, int* target_datatype, int* win, int* ierr){
582   *ierr =  MPI_Get( (void*)origin_addr,*origin_count, get_datatype(*origin_datatype),*target_rank,
583       *target_disp, *target_count,get_datatype(*target_datatype), *(MPI_Win *)win);
584 }