root/mpich2/trunk/src/mpe2/src/wrappers/src/mpe_proff.c @ 4879

Revision 4879, 83.9 KB (checked in by chan, 5 months ago)

comented out debugging statements.
Line 
1/*
2   (C) 2001 by Argonne National Laboratory.
3       See COPYRIGHT in top-level directory.
4*/
5/* myprof.c */
6/* Custom Fortran interface file */
7/* These have been edited because they require special string processing */
8/* See mpe_prof.c for what these are interfacing to */
9
10/*
11 * If not building for MPICH, then MPE_ErrPrint and the mpi_iargc_/mpir_getarg_
12 * calls need to be replaced.
13 */
14
15#ifdef MPI_BUILD_PROFILING
16#undef MPI_BUILD_PROFILING
17#endif
18#include "mpe_conf.h"
19#include "mpe_wrappers_conf.h"
20#include "mpi.h"
21
22/* AIX requires this to be the first thing in the file.  */
23#ifndef __GNUC__
24# if HAVE_ALLOCA_H
25#  include <alloca.h>
26# else
27#  ifdef _AIX
28 #pragma alloca
29#  else
30#   ifndef alloca /* predefined by HP cc +Olibcalls */
31char *alloca ();
32#   endif
33#  endif
34# endif
35#else
36# if defined( HAVE_ALLOCA_H )
37#  include <alloca.h>
38# endif
39#endif
40
41#include <stdio.h>
42#define MPE_ErrPrint(comm,errcode,str) (fprintf( stderr, "%s\n", str ),errcode)
43
44#if defined( STDC_HEADERS ) || defined( HAVE_STDARG_H )
45#include <stdarg.h>
46#endif
47
48#if ! defined( MPICH_NAME ) || defined ( MPICH2 )
49#if defined( HAVE_STRING_H )
50#include <string.h>
51#endif
52/* If we aren't running MPICH, just use fprintf for errors */
53/* Also avoid Fortran arguments */
54#define mpir_iargc_() 0
55#define mpir_getarg_( idx, str, ln ) strncpy(str,"Unknown",ln)
56#else
57/* Make sure that we get the correct Fortran form */
58
59#ifdef F77_NAME_UPPER
60#define mpir_iargc_ MPIR_IARGC
61#define mpir_getarg_ MPIR_GETARG
62#elif defined(F77_NAME_LOWER_2USCORE)
63#define mpir_iargc_ mpir_iargc__
64#define mpir_getarg_ mpir_getarg__
65#elif !defined(F77_NAME_LOWER_USCORE)
66#define mpir_iargc_ mpir_iargc
67#define mpir_getarg_ mpir_getarg
68#endif
69
70#endif
71
72/*
73   Include a definition of MALLOC and FREE to allow the use of MPICH
74   memory debug code
75*/
76#if defined(MPIR_MEMDEBUG)
77/* Enable memory tracing.  This requires MPICH's mpid/util/tr2.c codes */
78#define MALLOC(a)    MPID_trmalloc((unsigned)(a),__LINE__,__FILE__)
79#define FREE(a)      MPID_trfree(a,__LINE__,__FILE__)
80
81#else
82#define MALLOC(a) malloc(a)
83#define FREE(a)   free(a)
84#define MPID_trvalid(a)
85#ifdef HAVE_STDLIB_H
86#include <stdlib.h>
87#endif
88#endif
89
90#ifndef DEBUG_ALL
91#define DEBUG_ALL
92#endif
93
94/* Set MPER_F_Initialized is false before initialization */
95int       MPER_F_Initialized = 0;
96/* Fortran value for MPI_IN_PLACE */
97void     *MPER_F_MPI_IN_PLACE;
98/* Fortran value for MPI_STATUS(ES)_IGNORE */
99MPI_Fint *MPER_F_MPI_STATUS_IGNORE;
100MPI_Fint *MPER_F_MPI_STATUSES_IGNORE;
101/* size of MPI_Status in MPI_Fint */
102MPI_Fint  MPER_F_MPI_STATUS_SIZE;
103/* Fortran logical values */
104MPI_Fint  MPER_F_TRUE;
105MPI_Fint  MPER_F_FALSE;
106
107/* Fortran logical values */
108#if defined( WITH_CRAY_FCD_LOGICAL )
109/*
110   CRAY Vector processors only; these are defined in /usr/include/fortran.h
111   Thanks to lmc@cray.com
112*/
113#include <fortran.h>
114#define MPIR_TO_FLOG(a) (_btol(a))
115#define MPIR_FROM_FLOG(a) ( _ltob(&(a)) )    /*(a) must be a pointer */
116
117#else
118/*  extern MPI_Fint MPER_F_TRUE, MPER_F_FALSE;  */
119#define MPIR_TO_FLOG(a) ((a) ? MPER_F_TRUE : MPER_F_FALSE)
120/*
121   Note on true and false.  This code is only an approximation.
122   Some systems define either true or false, and allow some or ALL other
123   patterns for the other.  This is just like C, where 0 is false and
124   anything not zero is true.  Modify this test as necessary for your
125   system.
126 */
127#define MPIR_FROM_FLOG(a) ( (a) == MPER_F_TRUE ? 1 : 0 )
128#endif
129
130/* MPIR_F_MPI_BOTTOM is the address of the Fortran MPI_BOTTOM value */
131extern void *MPIR_F_MPI_BOTTOM;
132
133/* A temporary until we can make this do
134   MPIR_F_PTR(a) (((a)==(MPIR_F_MPI_BOTTOM))?MPI_BOTTOM:a)
135*/
136#define MPIR_F_PTR(a) (a)
137
138/* Error handling */
139#if defined(USE_STDARG) && !defined(USE_OLDSTYLE_STDARG)
140int MPER_Err_setmsg( int, int, const char *, const char *, const char *, ... );
141#else
142int MPER_Err_setmsg();
143#endif
144
145#ifndef MPIR_ERR_DEFAULT
146#define MPIR_ERR_DEFAULT 1
147#endif
148
149#ifndef MPIR_ERROR
150#define MPIR_ERROR(a,b,c) fprintf(stderr, "%s\n", c )
151#endif
152
153#ifndef MPIR_FALLOC
154#define MPIR_FALLOC(ptr,expr,a,b,c) \
155    if (! (ptr = (expr))) { MPIR_ERROR(a,b,c); }
156#endif
157
158#ifndef MPIR_USE_LOCAL_ARRAY
159#define MPIR_USE_LOCAL_ARRAY 32
160#endif
161
162#ifndef HAVE_MPI_COMM_F2C
163#define MPI_Comm_c2f(comm) (MPI_Fint)(comm)
164#define MPI_Comm_f2c(comm) (MPI_Comm)(comm)
165#endif
166#ifndef HAVE_MPI_TYPE_F2C
167#define MPI_Type_c2f(datatype) (MPI_Fint)(datatype)
168#define MPI_Type_f2c(datatype) (MPI_Datatype)(datatype)
169#endif
170#ifndef HAVE_MPI_GROUP_F2C
171#define MPI_Group_c2f(group) (MPI_Fint)(group)
172#define MPI_Group_f2c(group) (MPI_Group)(group)
173#endif
174#ifndef HAVE_MPI_REQUEST_F2C
175#define MPI_Request_c2f(request) (MPI_Fint)(request)
176#define MPI_Request_f2c(request) (MPI_Request)(request)
177#endif
178#ifndef HAVE_MPI_OP_F2C
179#define MPI_Op_c2f(op) (MPI_Fint)(op)
180#define MPI_Op_f2c(op) (MPI_Op)(op)
181#endif
182#ifndef HAVE_MPI_ERRHANDLER_F2C
183#define MPI_Errhandler_c2f(errhandler) (MPI_Fint)(errhandler)
184#define MPI_Errhandler_f2c(errhandler) (MPI_Errhandler)(errhandler)
185#endif
186#ifndef HAVE_MPI_STATUS_F2C
187#define MPI_Status_f2c(f_status,c_status) memcpy(c_status,f_status,sizeof(MPI_Status))
188#define MPI_Status_c2f(c_status,f_status) memcpy(f_status,c_status,sizeof(MPI_Status))
189#endif
190
191#ifdef F77_NAME_UPPER
192#if defined( MPICH2 )
193#define mpirinitf_ MPIRINITF
194#endif
195#define fsub_mpi_fconsts_ FSUB_MPI_FCONSTS
196#define csub_mpi_in_place_ CSUB_MPI_IN_PLACE
197#define csub_mpi_status_ignore_ CSUB_MPI_STATUS_IGNORE
198#define csub_mpi_statuses_ignore_ CSUB_MPI_STATUSES_IGNORE
199#define mpi_init_ MPI_INIT
200#define mpi_init_thread_ MPI_INIT_THREAD
201#define mpi_pcontrol_ MPI_PCONTROL
202#define mpi_comm_create_ MPI_COMM_CREATE
203#define mpi_comm_dup_ MPI_COMM_DUP
204#define mpe_comm_free_ MPI_COMM_FREE
205#define mpi_comm_split_ MPI_COMM_SPLIT
206#define mpi_intercomm_create_ MPI_INTERCOMM_CREATE
207#define mpi_intercomm_merge_ MPI_INTERCOMM_MERGE
208#define mpi_cart_create_ MPI_CART_CREATE
209#define mpi_cart_sub_ MPI_CART_SUB
210#define mpi_graph_create_ MPI_GRAPH_CREATE
211#define mpi_bsend_ MPI_BSEND
212#define mpi_bsend_init_ MPI_BSEND_INIT
213#define mpi_buffer_attach_ MPI_BUFFER_ATTACH
214#define mpi_buffer_detach_ MPI_BUFFER_DETACH
215#define mpi_cancel_ MPI_CANCEL
216#define mpi_request_free_ MPI_REQUEST_FREE
217#define mpi_recv_init_ MPI_RECV_INIT
218#define mpi_send_init_ MPI_SEND_INIT
219#define mpi_get_count_ MPI_GET_COUNT
220#define mpi_get_elements_ MPI_GET_ELEMENTS
221#define mpi_ibsend_ MPI_IBSEND
222#define mpi_iprobe_ MPI_IPROBE
223#define mpi_irecv_ MPI_IRECV
224#define mpi_irsend_ MPI_IRSEND
225#define mpi_isend_ MPI_ISEND
226#define mpi_issend_ MPI_ISSEND
227#define mpi_pack_size_ MPI_PACK_SIZE
228#define mpi_pack_ MPI_PACK
229#define mpi_probe_ MPI_PROBE
230#define mpi_recv_ MPI_RECV
231#define mpi_rsend_init_ MPI_RSEND_INIT
232#define mpi_rsend_ MPI_RSEND
233#define mpi_send_ MPI_SEND
234#define mpi_sendrecv_ MPI_SENDRECV
235#define mpi_sendrecv_replace_ MPI_SENDRECV_REPLACE
236#define mpi_ssend_init_ MPI_SSEND_INIT
237#define mpi_ssend_ MPI_SSEND
238#define mpi_startall_ MPI_STARTALL
239#define mpi_start_ MPI_START
240#define mpi_testall_ MPI_TESTALL
241#define mpi_testany_ MPI_TESTANY
242#define mpi_test_canceled_ MPI_TESTCANCEL
243#define mpi_test_ MPI_TEST
244#define mpi_testsome_ MPI_TESTSOME
245#define mpi_type_commit_ MPI_TYPE_COMMIT
246#define mpi_type_contiguous_ MPI_TYPE_CONTIGUOUS
247#define mpi_type_extent_ MPI_TYPE_EXTENT
248#define mpi_type_free_ MPI_TYPE_FREE
249#define mpi_type_hindexed_ MPI_TYPE_HINDEXED
250#define mpi_type_hvector_ MPI_TYPE_HVECTOR
251#define mpi_type_indexed_ MPI_TYPE_INDEXED
252#define mpi_type_lb_ MPI_TYPE_LB
253#define mpi_type_size_ MPI_TYPE_SIZE
254#define mpi_type_struct_ MPI_TYPE_STRUCT
255#define mpi_type_ub_ MPI_TYPE_UB
256#define mpi_type_vector_ MPI_TYPE_VECTOR
257#define mpi_unpack_ MPI_UNPACK
258#define mpi_waitall_ MPI_WAITALL
259#define mpi_waitany_ MPI_WAITANY
260#define mpi_wait_ MPI_WAIT
261#define mpi_waitsome_ MPI_WAITSOME
262#define mpi_allgather_ MPI_ALLGATHER
263#define mpi_allgatherv_ MPI_ALLGATHERV
264#define mpi_allreduce_ MPI_ALLREDUCE
265#define mpi_alltoall_ MPI_ALLTOALL
266#define mpi_alltoallv_ MPI_ALLTOALLV
267#define mpi_barrier_ MPI_BARRIER
268#define mpi_bcast_ MPI_BCAST
269#define mpi_gather_ MPI_GATHER
270#define mpi_gatherv_ MPI_GATHERV
271#define mpi_op_create_ MPI_OP_CREATE
272#define mpi_op_free_ MPI_OP_FREE
273#define mpi_reduce_scatter_ MPI_REDUCE_SCATTER
274#define mpi_reduce_ MPI_REDUCE
275#define mpi_scan_ MPI_SCAN
276#define mpi_scatter_ MPI_SCATTER
277#define mpi_scatterv_ MPI_SCATTERV
278#define mpi_finalize_ MPI_FINALIZE
279#elif defined(F77_NAME_LOWER_2USCORE)
280/*
281#if defined( MPICH2 )
282#define mpirinitf_ mpirinitf__
283#endif
284*/
285#define fsub_mpi_fconsts_ fsub_mpi_fconsts__
286#define csub_mpi_in_place_ csub_mpi_in_place__
287#define csub_mpi_status_ignore_ csub_mpi_status_ignore__
288#define csub_mpi_statuses_ignore_ csub_mpi_statuses_ignore__
289#define mpi_init_ mpi_init__
290#define mpi_init_thread_ mpi_init_thread__
291#define mpi_pcontrol_ mpi_pcontrol__
292#define mpi_comm_create_ mpi_comm_create__
293#define mpi_comm_dup_ mpi_comm_dup__
294#define mpe_comm_free_ mpi_comm_free__
295#define mpi_comm_split_ mpi_comm_split__
296#define mpi_intercomm_create_ mpi_intercomm_create__
297#define mpi_intercomm_merge_ mpi_intercomm_merge__
298#define mpi_cart_create_ mpi_cart_create__
299#define mpi_cart_sub_ mpi_cart_sub__
300#define mpi_graph_create_ mpi_graph_create__
301#define mpi_bsend_ mpi_bsend__
302#define mpi_bsend_init_ mpi_bsend_init__
303#define mpi_buffer_attach_ mpi_buffer_attach__
304#define mpi_buffer_detach_ mpi_buffer_detach__
305#define mpi_cancel_ mpi_cancel__
306#define mpi_request_free_ mpi_request_free__
307#define mpi_recv_init_ mpi_recv_init__
308#define mpi_send_init_ mpi_send_init__
309#define mpi_get_count_ mpi_get_count__
310#define mpi_get_elements_ mpi_get_elements__
311#define mpi_ibsend_ mpi_ibsend__
312#define mpi_iprobe_ mpi_iprobe__
313#define mpi_irecv_ mpi_irecv__
314#define mpi_irsend_ mpi_irsend__
315#define mpi_isend_ mpi_isend__
316#define mpi_issend_ mpi_issend__
317#define mpi_pack_size_ mpi_pack_size__
318#define mpi_pack_ mpi_pack__
319#define mpi_probe_ mpi_probe__
320#define mpi_recv_ mpi_recv__
321#define mpi_rsend_init_ mpi_rsend_init__
322#define mpi_rsend_ mpi_rsend__
323#define mpi_send_ mpi_send__
324#define mpi_sendrecv_ mpi_sendrecv__
325#define mpi_sendrecv_replace_ mpi_sendrecv_replace__
326#define mpi_ssend_init_ mpi_ssend_init__
327#define mpi_ssend_ mpi_ssend__
328#define mpi_startall_ mpi_startall__
329#define mpi_start_ mpi_start__
330#define mpi_testall_ mpi_testall__
331#define mpi_testany_ mpi_testany__
332#define mpi_test_cancelled_ mpi_test_cancelled__
333#define mpi_test_ mpi_test__
334#define mpi_testsome_ mpi_testsome__
335#define mpi_type_commit_ mpi_type_commit__
336#define mpi_type_contiguous_ mpi_type_contiguous__
337#define mpi_type_extent_ mpi_type_extent__
338#define mpi_type_free_ mpi_type_free__
339#define mpi_type_hindexed_ mpi_type_hindexed__
340#define mpi_type_hvector_ mpi_type_hvector__
341#define mpi_type_indexed_ mpi_type_indexed__
342#define mpi_type_lb_ mpi_type_lb__
343#define mpi_type_size_ mpi_type_size__
344#define mpi_type_struct_ mpi_type_struct__
345#define mpi_type_ub_ mpi_type_ub__
346#define mpi_type_vector_ mpi_type_vector__
347#define mpi_unpack_ mpi_unpack__
348#define mpi_waitall_ mpi_waitall__
349#define mpi_waitany_ mpi_waitany__
350#define mpi_wait_ mpi_wait__
351#define mpi_waitsome_ mpi_waitsome__
352#define mpi_allgather_ mpi_allgather__
353#define mpi_allgatherv_ mpi_allgatherv__
354#define mpi_allreduce_ mpi_allreduce__
355#define mpi_alltoall_ mpi_alltoall__
356#define mpi_alltoallv_ mpi_alltoallv__
357#define mpi_barrier_ mpi_barrier__
358#define mpi_bcast_ mpi_bcast__
359#define mpi_gather_ mpi_gather__
360#define mpi_gatherv_ mpi_gatherv__
361#define mpi_op_create_ mpi_op_create__
362#define mpi_op_free_ mpi_op_free__
363#define mpi_reduce_scatter_ mpi_reduce_scatter__
364#define mpi_reduce_ mpi_reduce__
365#define mpi_scan_ mpi_scan__
366#define mpi_scatter_ mpi_scatter__
367#define mpi_scatterv_ mpi_scatterv__
368#define mpi_finalize_ mpi_finalize__
369#elif defined(F77_NAME_LOWER)
370#if defined( MPICH2 )
371#define mpirinitf_ mpirinitf
372#endif
373#define fsub_mpi_fconsts_ fsub_mpi_fconsts
374#define csub_mpi_in_place_ csub_mpi_in_place
375#define csub_mpi_status_ignore_ csub_mpi_status_ignore
376#define csub_mpi_statuses_ignore_ csub_mpi_statuses_ignore
377#define mpi_init_ mpi_init
378#define mpi_init_thread_ mpi_init_thread
379#define mpi_pcontrol_ mpi_pcontrol
380#define mpi_comm_create_ mpi_comm_create
381#define mpi_comm_dup_ mpi_comm_dup
382#define mpe_comm_free_ mpi_comm_free
383#define mpi_comm_split_ mpi_comm_split
384#define mpi_intercomm_create_ mpi_intercomm_create
385#define mpi_intercomm_merge_ mpi_intercomm_merge
386#define mpi_cart_create_ mpi_cart_create
387#define mpi_cart_sub_ mpi_cart_sub
388#define mpi_graph_create_ mpi_graph_create
389#define mpi_bsend_ mpi_bsend
390#define mpi_bsend_init_ mpi_bsend_init
391#define mpi_buffer_attach_ mpi_buffer_attach
392#define mpi_buffer_detach_ mpi_buffer_detach
393#define mpi_cancel_ mpi_cancel
394#define mpi_request_free_ mpi_request_free
395#define mpi_recv_init_ mpi_recv_init
396#define mpi_send_init_ mpi_send_init
397#define mpi_get_count_ mpi_get_count
398#define mpi_get_elements_ mpi_get_elements
399#define mpi_ibsend_ mpi_ibsend
400#define mpi_iprobe_ mpi_iprobe
401#define mpi_irecv_ mpi_irecv
402#define mpi_irsend_ mpi_irsend
403#define mpi_isend_ mpi_isend
404#define mpi_issend_ mpi_issend
405#define mpi_pack_size_ mpi_pack_size
406#define mpi_pack_ mpi_pack
407#define mpi_probe_ mpi_probe
408#define mpi_recv_ mpi_recv
409#define mpi_rsend_init_ mpi_rsend_init
410#define mpi_rsend_ mpi_rsend
411#define mpi_send_ mpi_send
412#define mpi_sendrecv_ mpi_sendrecv
413#define mpi_sendrecv_replace_ mpi_sendrecv_replace
414#define mpi_ssend_init_ mpi_ssend_init
415#define mpi_ssend_ mpi_ssend
416#define mpi_startall_ mpi_startall
417#define mpi_start_ mpi_start
418#define mpi_testall_ mpi_testall
419#define mpi_testany_ mpi_testany
420#define mpi_test_cancelled_ mpi_test_cancelled
421#define mpi_test_ mpi_test
422#define mpi_testsome_ mpi_testsome
423#define mpi_type_commit_ mpi_type_commit
424#define mpi_type_contiguous_ mpi_type_contiguous
425#define mpi_type_extent_ mpi_type_extent
426#define mpi_type_free_ mpi_type_free
427#define mpi_type_hindexed_ mpi_type_hindexed
428#define mpi_type_hvector_ mpi_type_hvector
429#define mpi_type_indexed_ mpi_type_indexed
430#define mpi_type_lb_ mpi_type_lb
431#define mpi_type_size_ mpi_type_size
432#define mpi_type_struct_ mpi_type_struct
433#define mpi_type_ub_ mpi_type_ub
434#define mpi_type_vector_ mpi_type_vector
435#define mpi_unpack_ mpi_unpack
436#define mpi_waitall_ mpi_waitall
437#define mpi_waitany_ mpi_waitany
438#define mpi_wait_ mpi_wait
439#define mpi_waitsome_ mpi_waitsome
440#define mpi_allgather_ mpi_allgather
441#define mpi_allgatherv_ mpi_allgatherv
442#define mpi_allreduce_ mpi_allreduce
443#define mpi_alltoall_ mpi_alltoall
444#define mpi_alltoallv_ mpi_alltoallv
445#define mpi_barrier_ mpi_barrier
446#define mpi_bcast_ mpi_bcast
447#define mpi_gather_ mpi_gather
448#define mpi_gatherv_ mpi_gatherv
449#define mpi_op_create_ mpi_op_create
450#define mpi_op_free_ mpi_op_free
451#define mpi_reduce_scatter_ mpi_reduce_scatter
452#define mpi_reduce_ mpi_reduce
453#define mpi_scan_ mpi_scan
454#define mpi_scatter_ mpi_scatter
455#define mpi_scatterv_ mpi_scatterv
456#define mpi_finalize_ mpi_finalize
457#endif
458
459/* This fortran subroutine the C function */
460void fsub_mpi_fconsts_( MPI_Fint *status_size_ptr,
461                        MPI_Fint *itrue_ptr, MPI_Fint *ifalse_ptr );
462
463void csub_mpi_in_place_( void *arg4inplace );
464void csub_mpi_in_place_( void *arg4inplace )
465{ MPER_F_MPI_IN_PLACE = arg4inplace; }
466
467void csub_mpi_status_ignore_( void *arg4statusignore );
468void csub_mpi_status_ignore_( void *arg4statusignore )
469{ MPER_F_MPI_STATUS_IGNORE = (MPI_Fint *) arg4statusignore; }
470
471void csub_mpi_statuses_ignore_( void *arg4statusesignore );
472void csub_mpi_statuses_ignore_( void *arg4statusesignore )
473{ MPER_F_MPI_STATUSES_IGNORE = (MPI_Fint *) arg4statusesignore; }
474
475#if defined( MPICH2 )
476/* Provide a prototype for the mpirinitf function */
477extern void mpirinitf_( void );
478#endif
479
480/* Copy of CLOG_Util_getenvbool() in log_mpi_util.c */
481int MPE_Util_getenvbool( char *env_var, int default_value );
482
483void mper_fconsts_init( void );
484void mper_fconsts_init( void )
485{
486    int  use_mpih;
487    /*
488       Set MPI_STATUS_SIZE, fortran logicals,
489           MPI_IN_PLACE, MPI_STATUS(ES)_IGNORE
490    */
491
492    /* Default MPE_USE_FCONSTS_IN_MPIH = false */
493    use_mpih = MPE_Util_getenvbool( "MPE_USE_FCONSTS_IN_MPIH", 0 );
494    /* Let everyone in MPI_COMM_WORLD know what root has */
495    PMPI_Bcast( &use_mpih, 1, MPI_INT, 0, MPI_COMM_WORLD );
496#if defined( MPICH2 )
497    if ( use_mpih ) {
498        mpirinitf_();
499    }
500#endif
501    fsub_mpi_fconsts_( &MPER_F_MPI_STATUS_SIZE, &MPER_F_TRUE, &MPER_F_FALSE );
502/* Use the determined values and ignore MPI_F_* from mpi.h */
503#if defined( HAVE_MPI_F_STATUS_IGNORE )
504    if ( use_mpih ) {
505        MPER_F_MPI_STATUS_IGNORE = MPI_F_STATUS_IGNORE;
506    }
507#endif
508#if defined( HAVE_MPI_F_STATUSES_IGNORE )
509    if ( use_mpih ) {
510        MPER_F_MPI_STATUSES_IGNORE = MPI_F_STATUSES_IGNORE;
511    }
512#endif
513/*
514{
515    int  world_rank;
516    PMPI_Comm_rank( MPI_COMM_WORLD, &world_rank );
517    if ( world_rank == 0 ) {
518        printf( "f2c(MPI_IN_PLACE) = %p\n", MPER_F_MPI_IN_PLACE );
519        printf( "f2c(MPI_STATUS_IGNORE) = %p\n", MPER_F_MPI_STATUS_IGNORE );
520        printf( "f2c(MPI_STATUSES_IGNORE) = %p\n", MPER_F_MPI_STATUSES_IGNORE );
521        printf( "f2c(MPI_STATUS_SIZE) = %d\n", MPER_F_MPI_STATUS_SIZE );
522        printf( ".TRUE. = %d, .FALSE. = %d\n", MPER_F_TRUE, MPER_F_FALSE );
523    }
524}
525*/
526}
527
528/*
529 * Define prototypes next to the fortran2c wrapper to keep the compiler happy
530 */
531
532
533
534#if defined(USE_STDARG) && !defined(USE_OLDSTYLE_STDARG)
535int MPER_Err_setmsg( int errclass, int errkind,
536                     const char *routine_name, 
537                     const char *generic_string, 
538                     const char *default_string, ... )
539{
540    va_list Argp;
541    va_start( Argp, default_string );
542#else
543/* This assumes old-style varargs support */
544int MPER_Err_setmsg( errclass, errkind, routine_name, 
545                     generic_string, default_string, va_alist )
546int errclass, errkind;
547const char *routine_name, *generic_string, *default_string;
548va_dcl
549{
550    va_list Argp;
551    va_start( Argp );
552#endif
553
554    va_end( Argp );
555    fprintf( stderr, __FILE__":MPER_Err_setmg(%s) in MPE\n", routine_name );
556    return errclass;
557}
558
559
560/****************************************************************************/
561
562/*
563extern int is_mpe_f2c;
564*/
565
566void mpi_init_( MPI_Fint * );
567void mpi_init_( MPI_Fint *ierr )
568{
569    int Argc;
570    int i, argsize = 1024;
571    char **Argv, *p;
572    int  ArgcSave;           /* Save the argument count */
573    char **ArgvSave;         /* Save the pointer to the argument vector */
574
575/* Recover the args with the Fortran routines iargc_ and getarg_ */
576    ArgcSave        = Argc = mpir_iargc_() + 1;
577    ArgvSave        = Argv = (char **)MALLOC( Argc * sizeof(char *) );
578    if (!Argv) {
579        *ierr = MPE_ErrPrint( (MPI_Comm)0, MPI_ERR_OTHER, 
580                              "Out of space in MPI_INIT" );
581        return;
582    }
583    for (i=0; i<Argc; i++) {
584        ArgvSave[i] = Argv[i] = (char *)MALLOC( argsize + 1 );
585        if (!Argv[i]) {
586            *ierr = MPE_ErrPrint( (MPI_Comm)0, MPI_ERR_OTHER, 
587                                  "Out of space in MPI_INIT" );
588            return;
589        }
590        mpir_getarg_( &i, Argv[i], argsize );
591
592        /* Trim trailing blanks */
593        p = Argv[i] + argsize - 1;
594        while (p > Argv[i]) {
595            if (*p != ' ') {
596                p[1] = '\0';
597                break;
598            }
599            p--;
600        }
601    }
602
603    /*
604    is_mpe_f2c = 1;
605    */
606    *ierr = MPI_Init( &Argc, &Argv );
607    mper_fconsts_init(); MPER_F_Initialized = 1;
608   
609   
610    /* Recover space */
611    for (i=0; i<ArgcSave; i++) {
612        FREE( ArgvSave[i] );
613    }
614    FREE( ArgvSave );
615}
616
617
618#if defined( HAVE_MPI_INIT_THREAD )
619void mpi_init_thread_( MPI_Fint *required, MPI_Fint *provided, MPI_Fint *ierr );
620void mpi_init_thread_( MPI_Fint *required, MPI_Fint *provided, MPI_Fint *ierr )
621{
622    *ierr = MPI_Init_thread( NULL, NULL, *required, provided );
623    mper_fconsts_init(); MPER_F_Initialized = 1;
624}
625#endif
626
627
628
629void mpi_pcontrol_( MPI_Fint *icontrol, MPI_Fint *__ierr );
630void mpi_pcontrol_( MPI_Fint *icontrol, MPI_Fint *__ierr )
631{
632    *__ierr = MPI_Pcontrol( *icontrol );
633}
634
635
636
637void mpi_comm_create_( MPI_Fint *comm, MPI_Fint *group,
638                       MPI_Fint *comm_out, MPI_Fint *__ierr );
639void mpi_comm_create_( MPI_Fint *comm, MPI_Fint *group,
640                       MPI_Fint *comm_out, MPI_Fint *__ierr )
641{
642    MPI_Comm l_comm_out;
643
644    *__ierr = MPI_Comm_create( MPI_Comm_f2c(*comm), MPI_Group_f2c(*group),
645                               &l_comm_out);
646    if (*__ierr == MPI_SUCCESS)
647        *comm_out = MPI_Comm_c2f(l_comm_out);
648}
649
650
651
652void mpi_comm_dup_( MPI_Fint *comm, MPI_Fint *comm_out, MPI_Fint *__ierr );
653void mpi_comm_dup_( MPI_Fint *comm, MPI_Fint *comm_out, MPI_Fint *__ierr )
654{
655    MPI_Comm l_comm_out;
656
657    *__ierr = MPI_Comm_dup( MPI_Comm_f2c(*comm), &l_comm_out );
658    if (*__ierr == MPI_SUCCESS)
659        *comm_out = MPI_Comm_c2f(l_comm_out);
660}
661
662
663
664void mpi_comm_free_( MPI_Fint *comm, MPI_Fint *__ierr );
665void mpi_comm_free_( MPI_Fint *comm, MPI_Fint *__ierr )
666{
667    MPI_Comm l_comm = MPI_Comm_f2c(*comm);
668    *__ierr = MPI_Comm_free(&l_comm);
669    if (*__ierr == MPI_SUCCESS)
670        *comm = MPI_Comm_c2f(l_comm);
671}
672
673
674
675void mpi_comm_split_( MPI_Fint *comm, MPI_Fint *color, MPI_Fint *key,
676                      MPI_Fint *comm_out, MPI_Fint *__ierr );
677void mpi_comm_split_( MPI_Fint *comm, MPI_Fint *color, MPI_Fint *key,
678                      MPI_Fint *comm_out, MPI_Fint *__ierr )
679{
680    MPI_Comm l_comm_out;
681
682    *__ierr = MPI_Comm_split( MPI_Comm_f2c(*comm), (int)*color, (int)*key,
683                              &l_comm_out);
684    if (*__ierr == MPI_SUCCESS)
685        *comm_out = MPI_Comm_c2f(l_comm_out);
686}
687
688
689
690void mpi_intercomm_create_( MPI_Fint *local_comm, MPI_Fint *local_leader,
691                            MPI_Fint *peer_comm, MPI_Fint *remote_leader,
692                            MPI_Fint *tag, MPI_Fint *comm_out,
693                            MPI_Fint *__ierr );
694void mpi_intercomm_create_( MPI_Fint *local_comm, MPI_Fint *local_leader,
695                            MPI_Fint *peer_comm, MPI_Fint *remote_leader,
696                            MPI_Fint *tag, MPI_Fint *comm_out,
697                            MPI_Fint *__ierr )
698{
699    MPI_Comm l_comm_out;
700    *__ierr = MPI_Intercomm_create( MPI_Comm_f2c(*local_comm),
701                                    (int)*local_leader,
702                                    MPI_Comm_f2c(*peer_comm),
703                                    (int)*remote_leader, (int)*tag,
704                                    &l_comm_out);
705    if (*__ierr == MPI_SUCCESS)
706        *comm_out = MPI_Comm_c2f(l_comm_out);
707}
708
709
710
711void mpi_intercomm_merge_( MPI_Fint *comm, MPI_Fint *high, MPI_Fint *comm_out,
712                           MPI_Fint *__ierr );
713void mpi_intercomm_merge_( MPI_Fint *comm, MPI_Fint *high, MPI_Fint *comm_out,
714                           MPI_Fint *__ierr )
715{
716    MPI_Comm l_comm_out;
717
718    *__ierr = MPI_Intercomm_merge( MPI_Comm_f2c(*comm), (int)*high,
719                                   &l_comm_out);
720    if (*__ierr == MPI_SUCCESS)
721        *comm_out = MPI_Comm_c2f(l_comm_out);
722}
723
724
725
726void mpi_cart_create_( MPI_Fint *comm_old, MPI_Fint *ndims, MPI_Fint *dims,
727                       MPI_Fint *periods, MPI_Fint *reorder,
728                       MPI_Fint *comm_cart, MPI_Fint *ierr );
729void mpi_cart_create_( MPI_Fint *comm_old, MPI_Fint *ndims, MPI_Fint *dims,
730                       MPI_Fint *periods, MPI_Fint *reorder,
731                       MPI_Fint *comm_cart, MPI_Fint *ierr )
732{
733    MPI_Comm   l_comm_cart;
734    int       *lperiods, *ldims;
735    int        ls_ints[40];     /* local static int[] */
736    int       *la_ints;         /* local allocated int[] */
737    int        is_malloced;
738    int        i;
739
740    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
741
742    is_malloced = 0;
743    if ( *ndims > 20 ) {
744#if ! defined( HAVE_ALLOCA )
745        la_ints  = (int *) malloc( 2 * (*ndims) * sizeof(int) );
746        is_malloced = 1;
747#else
748        la_ints  = (int *) alloca( 2 * (*ndims) * sizeof(int) );
749#endif
750        lperiods = &(la_ints[0]);
751        ldims    = &(la_ints[*ndims]);
752    }
753    else  { /* if ( *ndims <= 20 ) */
754        lperiods = &(ls_ints[0]);
755        ldims    = &(ls_ints[20]);
756    }
757    for (i=0; i<(int)*ndims; i++) {
758        lperiods[i] = MPIR_FROM_FLOG(periods[i]);
759        ldims[i] = (int)dims[i];
760    }
761
762#if defined(_TWO_WORD_FCD)
763    int tmp = *reorder;
764    *ierr = MPI_Cart_create( MPI_Comm_f2c(*comm_old),
765                             (int)*ndims, ldims,
766                             lperiods, MPIR_FROM_FLOG(tmp),
767                             &l_comm_cart);
768#else
769    *ierr = MPI_Cart_create( MPI_Comm_f2c(*comm_old),
770                             (int)*ndims, ldims,
771                             lperiods, MPIR_FROM_FLOG(*reorder),
772                             &l_comm_cart);
773#endif
774
775#if ! defined( HAVE_ALLOCA )
776    if ( is_malloced == 1 )
777        free( la_ints );
778#endif
779    if (*ierr == MPI_SUCCESS)
780        *comm_cart = MPI_Comm_c2f(l_comm_cart);
781}
782
783
784
785void mpi_cart_sub_( MPI_Fint *comm, MPI_Fint *remain_dims,
786                    MPI_Fint *comm_new, MPI_Fint *__ierr );
787void mpi_cart_sub_( MPI_Fint *comm, MPI_Fint *remain_dims,
788                    MPI_Fint *comm_new, MPI_Fint *__ierr )
789{
790    MPI_Comm   lcomm_new;
791    int        ls_ints[20];     /* local static int[] */
792    int       *la_ints;         /* local allocated int[] */
793    int        is_malloced;
794    int       *lremain_dims;
795    int        ndims, i;
796
797    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
798
799    MPI_Cartdim_get( MPI_Comm_f2c(*comm), &ndims );
800
801    is_malloced = 0;
802    if ( ndims > 20 ) {
803#if ! defined( HAVE_ALLOCA )
804        la_ints  = (int *) malloc( ndims * sizeof(int) );
805        is_malloced = 1;
806#else
807        la_ints  = (int *) alloca( ndims * sizeof(int) );
808#endif
809        lremain_dims = la_ints;
810    }
811    else  { /* if ( ndims <= 20 ) */
812        lremain_dims = ls_ints;
813    }
814    for (i=0; i<ndims; i++)
815        lremain_dims[i] = MPIR_FROM_FLOG(remain_dims[i]);
816
817    *__ierr = MPI_Cart_sub( MPI_Comm_f2c(*comm), lremain_dims,
818                            &lcomm_new);
819
820#if ! defined( HAVE_ALLOCA )
821    if ( is_malloced == 1 )
822        free( la_ints );
823#endif
824    if (*__ierr == MPI_SUCCESS)
825        *comm_new = MPI_Comm_c2f(lcomm_new);
826}
827
828void mpi_graph_create_( MPI_Fint *comm_old, MPI_Fint *nnodes,
829                        MPI_Fint *index, MPI_Fint *edges, MPI_Fint *reorder,
830                        MPI_Fint *comm_graph, MPI_Fint *__ierr );
831void mpi_graph_create_( MPI_Fint *comm_old, MPI_Fint *nnodes,
832                        MPI_Fint *index, MPI_Fint *edges, MPI_Fint *reorder,
833                        MPI_Fint *comm_graph, MPI_Fint *__ierr )
834{
835    MPI_Comm lcomm_graph;
836
837    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
838
839    if (sizeof(MPI_Fint) == sizeof(int))
840#if defined(_TWO_WORD_FCD)
841        int tmp = *reorder;
842        *__ierr = MPI_Graph_create( MPI_Comm_f2c(*comm_old), *nnodes,
843                                    index, edges,
844                                    MPIR_FROM_FLOG(tmp),
845                                    &lcomm_graph);
846#else
847        *__ierr = MPI_Graph_create( MPI_Comm_f2c(*comm_old), *nnodes,
848                                    index, edges,
849                                    MPIR_FROM_FLOG(*reorder),
850                                    &lcomm_graph);
851#endif
852    else {
853        int i;
854        int nedges;
855        int *lindex;
856        int *ledges;
857
858
859        MPI_Graphdims_get(MPI_Comm_f2c(*comm_old), nnodes, &nedges);
860        MPIR_FALLOC(lindex,(int*)MALLOC(sizeof(int)* (int)*nnodes),
861                    MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
862                    "MPI_Graph_create");
863        MPIR_FALLOC(ledges,(int*)MALLOC(sizeof(int)* (int)nedges),
864                    MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
865                    "MPI_Graph_create");
866
867        for (i=0; i<(int)*nnodes; i++)
868            lindex[i] = (int)index[i];
869
870        for (i=0; i<nedges; i++)
871            ledges[i] = (int)edges[i];
872
873#if defined(_TWO_WORD_FCD)
874        int tmp = *reorder;
875        *__ierr = MPI_Graph_create( MPI_Comm_f2c(*comm_old), (int)*nnodes,
876                                    lindex, ledges,
877                                    MPIR_FROM_FLOG(tmp),
878                                    &lcomm_graph);
879#else
880        *__ierr = MPI_Graph_create( MPI_Comm_f2c(*comm_old), (int)*nnodes,
881                                    lindex, ledges,
882                                    MPIR_FROM_FLOG(*reorder),
883                                    &lcomm_graph);
884#endif
885        FREE( lindex );
886        FREE( ledges );
887    }
888    if (*__ierr == MPI_SUCCESS)
889        *comm_graph = MPI_Comm_c2f(lcomm_graph);
890}
891
892
893
894void mpi_bsend_init_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
895                       MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
896void mpi_bsend_init_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
897                      MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
898                      MPI_Fint *request, MPI_Fint *__ierr )
899{
900    MPI_Request lrequest;
901    *__ierr = MPI_Bsend_init( MPIR_F_PTR(buf), (int)*count,
902                              MPI_Type_f2c(*datatype),
903                              (int)*dest,
904                              (int)*tag, MPI_Comm_f2c(*comm),
905                              &lrequest);
906    *request = MPI_Request_c2f(lrequest);
907}
908
909void mpi_bsend_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
910                  MPI_Fint *, MPI_Fint *, MPI_Fint * );
911void mpi_bsend_( void *buf, MPI_Fint *count, MPI_Fint *datatype, 
912                 MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm, 
913                 MPI_Fint *__ierr )
914{
915    *__ierr = MPI_Bsend( MPIR_F_PTR(buf), (int)*count, MPI_Type_f2c(*datatype),
916                         (int)*dest, (int)*tag, MPI_Comm_f2c(*comm) );
917}
918
919void mpi_buffer_attach_ ( void *, MPI_Fint *, MPI_Fint * );
920void mpi_buffer_attach_( void *buffer, MPI_Fint *size, MPI_Fint *__ierr )
921{
922    *__ierr = MPI_Buffer_attach(buffer,(int)*size);
923}
924
925void mpi_buffer_detach_ ( void **, MPI_Fint *, MPI_Fint * );
926void mpi_buffer_detach_( void **buffer, MPI_Fint *size, MPI_Fint *__ierr )
927{
928    void *tmp = (void *)buffer;
929    int lsize;
930
931    *__ierr = MPI_Buffer_detach(&tmp,&lsize);
932    *size = (MPI_Fint)lsize;
933}
934
935void mpi_cancel_ (MPI_Fint *, MPI_Fint *);
936void mpi_cancel_( MPI_Fint *request, MPI_Fint *__ierr )
937{
938    MPI_Request lrequest;
939
940    lrequest = MPI_Request_f2c(*request); 
941    *__ierr = MPI_Cancel(&lrequest); 
942}
943
944void mpi_request_free_ ( MPI_Fint *, MPI_Fint * );
945void mpi_request_free_( MPI_Fint *request, MPI_Fint *__ierr )
946{
947    MPI_Request lrequest = MPI_Request_f2c(*request);
948    *__ierr = MPI_Request_free( &lrequest );
949    *request = MPI_Request_c2f(lrequest);
950}
951
952void mpi_recv_init_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *, 
953                      MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
954void mpi_recv_init_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
955                     MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm,
956                     MPI_Fint *request, MPI_Fint *__ierr )
957{
958    MPI_Request lrequest;
959    *__ierr = MPI_Recv_init(MPIR_F_PTR(buf),(int)*count,
960                            MPI_Type_f2c(*datatype),(int)*source,(int)*tag,
961                            MPI_Comm_f2c(*comm),&lrequest);
962    *request = MPI_Request_c2f(lrequest);
963}
964
965void mpi_send_init_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *, 
966                      MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
967void mpi_send_init_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
968                     MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
969                     MPI_Fint *request, MPI_Fint *__ierr )
970{
971    MPI_Request lrequest;
972    *__ierr = MPI_Send_init(MPIR_F_PTR(buf),(int)*count,
973                            MPI_Type_f2c(*datatype),(int)*dest,(int)*tag,
974                            MPI_Comm_f2c(*comm),&lrequest);
975    *request = MPI_Request_c2f( lrequest );
976}
977
978void mpi_get_count_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
979void mpi_get_count_( MPI_Fint *status, MPI_Fint *datatype, MPI_Fint *count,
980                     MPI_Fint *__ierr )
981{
982    int lcount;
983    MPI_Status c_status;
984
985    MPI_Status_f2c(status, &c_status);
986    *__ierr = MPI_Get_count(&c_status, MPI_Type_f2c(*datatype),
987                            &lcount);
988    *count = (MPI_Fint)lcount;
989}
990
991void mpi_get_elements_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
992void mpi_get_elements_ ( MPI_Fint *status, MPI_Fint *datatype,
993                         MPI_Fint *elements, MPI_Fint *__ierr )
994{
995    int lelements;
996    MPI_Status c_status;
997
998    MPI_Status_f2c(status, &c_status);
999    *__ierr = MPI_Get_elements(&c_status,MPI_Type_f2c(*datatype),
1000                               &lelements);
1001    *elements = (MPI_Fint)lelements;
1002}
1003
1004void mpi_ibsend_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1005                   MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1006void mpi_ibsend_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1007                  MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1008                  MPI_Fint *request, MPI_Fint *__ierr )
1009{
1010    MPI_Request lrequest;
1011    *__ierr = MPI_Ibsend(MPIR_F_PTR(buf),(int)*count,MPI_Type_f2c(*datatype),
1012                         (int)*dest,(int)*tag,MPI_Comm_f2c(*comm),
1013                         &lrequest);
1014    *request = MPI_Request_c2f(lrequest);
1015}
1016
1017void mpi_iprobe_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *,
1018                   MPI_Fint *, MPI_Fint *, MPI_Fint * );
1019void mpi_iprobe_( MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm,
1020                  MPI_Fint *flag, MPI_Fint *status, MPI_Fint *__ierr )
1021{
1022    int lflag;
1023    MPI_Status c_status;
1024
1025    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1026
1027    *__ierr = MPI_Iprobe((int)*source,(int)*tag,MPI_Comm_f2c(*comm),
1028                         &lflag,&c_status);
1029    *flag = MPIR_TO_FLOG(lflag);
1030    if ( status != MPER_F_MPI_STATUS_IGNORE )
1031        MPI_Status_c2f(&c_status, status);
1032}
1033
1034void mpi_irecv_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1035                  MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1036void mpi_irecv_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1037                 MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm,
1038                 MPI_Fint *request, MPI_Fint *__ierr )
1039{
1040    MPI_Request lrequest;
1041    *__ierr = MPI_Irecv(MPIR_F_PTR(buf),(int)*count,MPI_Type_f2c(*datatype),
1042                        (int)*source,(int)*tag,
1043                        MPI_Comm_f2c(*comm),&lrequest);
1044    *request = MPI_Request_c2f(lrequest);
1045}
1046
1047void mpi_irsend_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1048                   MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1049void mpi_irsend_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1050                  MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1051                  MPI_Fint *request, MPI_Fint *__ierr )
1052{
1053    MPI_Request lrequest;
1054    *__ierr = MPI_Irsend(MPIR_F_PTR(buf),(int)*count,MPI_Type_f2c(*datatype),
1055                         (int)*dest,(int)*tag,
1056                         MPI_Comm_f2c(*comm),&lrequest);
1057    *request = MPI_Request_c2f(lrequest);
1058}
1059
1060void mpi_isend_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1061                  MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1062void mpi_isend_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1063                 MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1064                 MPI_Fint *request, MPI_Fint *__ierr )
1065{
1066    MPI_Request lrequest;
1067    *__ierr = MPI_Isend(MPIR_F_PTR(buf),(int)*count,MPI_Type_f2c(*datatype),
1068                        (int)*dest,
1069                        (int)*tag,MPI_Comm_f2c(*comm),
1070                        &lrequest);
1071    *request = MPI_Request_c2f(lrequest);
1072}
1073
1074void mpi_issend_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1075                   MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1076void mpi_issend_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1077                  MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1078                  MPI_Fint *request, MPI_Fint *__ierr )
1079{
1080    MPI_Request lrequest;
1081    *__ierr = MPI_Issend(MPIR_F_PTR(buf),(int)*count,MPI_Type_f2c(*datatype),
1082                         (int)*dest, (int)*tag,
1083                         MPI_Comm_f2c(*comm),
1084                         &lrequest);
1085    *request = MPI_Request_c2f(lrequest);
1086}
1087
1088void mpi_pack_size_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *,
1089                      MPI_Fint *, MPI_Fint * );
1090void mpi_pack_size_ ( MPI_Fint *incount, MPI_Fint *datatype, MPI_Fint *comm,
1091                      MPI_Fint *size, MPI_Fint *__ierr )
1092{
1093    int lsize;
1094
1095    *__ierr = MPI_Pack_size((int)*incount, MPI_Type_f2c(*datatype),
1096                            MPI_Comm_f2c(*comm), &lsize);
1097    *size = (MPI_Fint)lsize;
1098}
1099
1100void mpi_pack_ ( void *, MPI_Fint *, MPI_Fint *, void *,
1101                 MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1102void mpi_pack_ ( void *inbuf, MPI_Fint *incount, MPI_Fint *type,
1103                 void *outbuf, MPI_Fint *outcount, MPI_Fint *position,
1104                 MPI_Fint *comm, MPI_Fint *__ierr )
1105{
1106    int lposition;
1107
1108    lposition = (int)*position;
1109    *__ierr = MPI_Pack(MPIR_F_PTR(inbuf), (int)*incount, MPI_Type_f2c(*type),
1110                       outbuf, (int)*outcount, &lposition,
1111                       MPI_Comm_f2c(*comm));
1112    *position = (MPI_Fint)lposition;
1113}
1114
1115void mpi_probe_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *,
1116                  MPI_Fint *, MPI_Fint * );
1117void mpi_probe_( MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm,
1118                 MPI_Fint *status, MPI_Fint *__ierr )
1119{
1120    MPI_Status c_status;
1121
1122    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1123
1124    *__ierr = MPI_Probe((int)*source, (int)*tag, MPI_Comm_f2c(*comm),
1125                        &c_status);
1126    if ( status != MPER_F_MPI_STATUS_IGNORE )
1127        MPI_Status_c2f(&c_status, status);
1128}
1129
1130void mpi_recv_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1131                         MPI_Fint *, MPI_Fint *, MPI_Fint *,
1132                         MPI_Fint * );
1133void mpi_recv_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1134                MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm,
1135                MPI_Fint *status, MPI_Fint *__ierr )
1136{
1137    MPI_Status c_status;
1138
1139    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1140
1141    *__ierr = MPI_Recv(MPIR_F_PTR(buf), (int)*count,MPI_Type_f2c(*datatype),
1142                       (int)*source, (int)*tag,
1143                       MPI_Comm_f2c(*comm), &c_status);
1144    if ( status != MPER_F_MPI_STATUS_IGNORE )
1145        MPI_Status_c2f(&c_status, status);
1146}
1147
1148void mpi_rsend_init_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1149                       MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1150void mpi_rsend_init_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1151                      MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1152                      MPI_Fint *request, MPI_Fint *__ierr )
1153{
1154    MPI_Request lrequest;
1155    *__ierr = MPI_Rsend_init(MPIR_F_PTR(buf), (int)*count,
1156                             MPI_Type_f2c(*datatype), (int)*dest,
1157                             (int)*tag,
1158                             MPI_Comm_f2c(*comm), &lrequest);
1159    *request = MPI_Request_c2f(lrequest);
1160}
1161
1162void mpi_rsend_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1163                  MPI_Fint *, MPI_Fint *, MPI_Fint * );
1164void mpi_rsend_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1165                 MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1166                 MPI_Fint *__ierr )
1167{
1168    *__ierr = MPI_Rsend(MPIR_F_PTR(buf), (int)*count,MPI_Type_f2c(*datatype),
1169                        (int)*dest, (int)*tag, MPI_Comm_f2c(*comm));
1170}
1171
1172void mpi_send_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1173                 MPI_Fint *, MPI_Fint*, MPI_Fint * );
1174
1175void mpi_send_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1176                MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1177                MPI_Fint *__ierr )
1178{
1179    *__ierr = MPI_Send(MPIR_F_PTR(buf), (int)*count, MPI_Type_f2c(*datatype),
1180                       (int)*dest, (int)*tag, MPI_Comm_f2c(*comm));
1181}
1182
1183void mpi_sendrecv_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1184                     void *, MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1185                     MPI_Fint *, MPI_Fint *, MPI_Fint * );
1186void mpi_sendrecv_( void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype,
1187                    MPI_Fint *dest, MPI_Fint *sendtag,
1188                    void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype,
1189                    MPI_Fint *source, MPI_Fint *recvtag,
1190                    MPI_Fint *comm, MPI_Fint *status, MPI_Fint *__ierr )
1191{
1192    MPI_Status c_status;
1193
1194    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1195
1196    *__ierr = MPI_Sendrecv(MPIR_F_PTR(sendbuf), (int)*sendcount,
1197                           MPI_Type_f2c(*sendtype), (int)*dest,
1198                           (int)*sendtag, MPIR_F_PTR(recvbuf),
1199                           (int)*recvcount, MPI_Type_f2c(*recvtype),
1200                           (int)*source, (int)*recvtag,
1201                           MPI_Comm_f2c(*comm), &c_status);
1202    if ( status != MPER_F_MPI_STATUS_IGNORE )
1203        MPI_Status_c2f(&c_status, status);
1204}
1205
1206void mpi_sendrecv_replace_ ( void *, MPI_Fint *, MPI_Fint *,
1207                                     MPI_Fint *, MPI_Fint *, MPI_Fint *,
1208                                     MPI_Fint *, MPI_Fint *, MPI_Fint *,
1209                                     MPI_Fint * );
1210void mpi_sendrecv_replace_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1211                            MPI_Fint *dest, MPI_Fint *sendtag,
1212                            MPI_Fint *source, MPI_Fint *recvtag,
1213                            MPI_Fint *comm, MPI_Fint *status,
1214                            MPI_Fint *__ierr )
1215{
1216    MPI_Status c_status;
1217
1218    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1219
1220    *__ierr = MPI_Sendrecv_replace(MPIR_F_PTR(buf), (int)*count,
1221                                   MPI_Type_f2c(*datatype), (int)*dest,
1222                                   (int)*sendtag, (int)*source, (int)*recvtag,
1223                                   MPI_Comm_f2c(*comm), &c_status );
1224    if ( status != MPER_F_MPI_STATUS_IGNORE )
1225        MPI_Status_c2f(&c_status, status);
1226}
1227
1228void mpi_ssend_init_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1229                       MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1230void mpi_ssend_init_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1231                      MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1232                      MPI_Fint *request, MPI_Fint *__ierr )
1233{
1234    MPI_Request lrequest;
1235    *__ierr = MPI_Ssend_init(MPIR_F_PTR(buf), (int)*count,
1236                             MPI_Type_f2c(*datatype), (int)*dest, (int)*tag,
1237                             MPI_Comm_f2c(*comm), &lrequest);
1238    *request = MPI_Request_c2f(lrequest);
1239}
1240
1241void mpi_ssend_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1242                          MPI_Fint *, MPI_Fint *, MPI_Fint * );
1243void mpi_ssend_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1244                 MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1245                 MPI_Fint *__ierr )
1246{
1247    *__ierr = MPI_Ssend(MPIR_F_PTR(buf), (int)*count,
1248                        MPI_Type_f2c(*datatype), (int)*dest, (int)*tag,
1249                        MPI_Comm_f2c(*comm));
1250}
1251
1252void mpi_startall_ ( MPI_Fint *, MPI_Fint [], MPI_Fint * );
1253void mpi_startall_( MPI_Fint *count, MPI_Fint array_of_requests[],
1254                    MPI_Fint *__ierr )
1255{
1256    MPI_Request *lrequest = 0;
1257    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
1258    int i;
1259
1260    if ((int)*count > 0) {
1261        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1262            MPIR_FALLOC(lrequest,
1263                        (MPI_Request*)MALLOC(sizeof(MPI_Request)*(int)*count),
1264                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
1265                        "MPI_STARTALL" );
1266        }
1267        else {
1268            lrequest = local_lrequest;
1269        }
1270        for (i=0; i<(int)*count; i++) {
1271            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
1272        }
1273        *__ierr = MPI_Startall((int)*count,lrequest);
1274    }
1275    else
1276        *__ierr = MPI_Startall((int)*count,(MPI_Request *)0);
1277
1278    for (i=0; i<(int)*count; i++) {
1279        array_of_requests[i] = MPI_Request_c2f( lrequest[i]);
1280    }
1281    if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1282        FREE( lrequest );
1283    }
1284}
1285
1286void mpi_start_ ( MPI_Fint *, MPI_Fint * );
1287void mpi_start_( MPI_Fint *request, MPI_Fint *__ierr )
1288{
1289    MPI_Request lrequest = MPI_Request_f2c(*request );
1290    *__ierr = MPI_Start( &lrequest );
1291    *request = MPI_Request_c2f(lrequest);
1292}
1293
1294void mpi_testall_ ( MPI_Fint *, MPI_Fint [], MPI_Fint *,
1295                    MPI_Fint *, MPI_Fint * );
1296void mpi_testall_( MPI_Fint *count, MPI_Fint array_of_requests[],
1297                   MPI_Fint *flag,
1298                   MPI_Fint *array_of_statuses,
1299                   MPI_Fint *__ierr )
1300{
1301    int lflag;
1302    int i;
1303    MPI_Request *lrequest = 0;
1304    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
1305    MPI_Status *c_status = 0;
1306    MPI_Status local_c_status[MPIR_USE_LOCAL_ARRAY];
1307    MPI_Fint   *f_status = 0;
1308
1309    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1310
1311    if ((int)*count > 0) {
1312        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1313            MPIR_FALLOC(lrequest,
1314                        (MPI_Request*)MALLOC(sizeof(MPI_Request)*(int)*count),
1315                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
1316                        "MPI_TESTALL");
1317            MPIR_FALLOC(c_status,
1318                        (MPI_Status*)MALLOC(sizeof(MPI_Status)* (int)*count),
1319                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
1320                        "MPI_TESTTALL");
1321        }
1322        else {
1323            lrequest = local_lrequest;
1324            c_status = local_c_status;
1325        }
1326        for (i=0; i<(int)*count; i++) {
1327            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
1328        }
1329
1330        *__ierr = MPI_Testall((int)*count,lrequest,&lflag,c_status);
1331        /* By checking for lrequest[i] = 0, we handle persistant requests */
1332        for (i=0; i<(int)*count; i++) {
1333             array_of_requests[i] = MPI_Request_c2f( lrequest[i] );
1334        }
1335    }
1336    else
1337        *__ierr = MPI_Testall((int)*count,(MPI_Request *)0,&lflag,c_status);
1338   
1339    *flag = MPIR_TO_FLOG(lflag);
1340    /* We must only copy for those elements that corresponded to non-null
1341       requests, and only if there is a change */
1342    if ( array_of_statuses != MPER_F_MPI_STATUSES_IGNORE )
1343    {
1344        if (lflag) {
1345            f_status = array_of_statuses;
1346            for (i=0; i<(int)*count; i++) {
1347                MPI_Status_c2f( &c_status[i], f_status );
1348                f_status += MPER_F_MPI_STATUS_SIZE;
1349            }
1350        }
1351    }
1352
1353    if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1354        FREE( lrequest );
1355        FREE( c_status );
1356    }
1357}
1358
1359void mpi_testany_ ( MPI_Fint *, MPI_Fint [], MPI_Fint *,
1360                    MPI_Fint *, MPI_Fint *, MPI_Fint * );
1361void mpi_testany_( MPI_Fint *count, MPI_Fint array_of_requests[],
1362                   MPI_Fint *index, MPI_Fint *flag, MPI_Fint *status,
1363                   MPI_Fint *__ierr )
1364{
1365    int lindex;
1366    int lflag;
1367    MPI_Request *lrequest;
1368    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
1369    MPI_Status c_status;
1370    int i;
1371
1372    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1373
1374    if ((int)*count > 0) {
1375        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1376            MPIR_FALLOC(lrequest,
1377                        (MPI_Request*)MALLOC(sizeof(MPI_Request)* (int)*count),
1378                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
1379                        "MPI_TESTANY");
1380        }
1381        else 
1382            lrequest = local_lrequest;
1383
1384        for (i=0; i<(int)*count; i++) 
1385            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
1386
1387    }
1388    else
1389        lrequest = 0;
1390
1391    *__ierr = MPI_Testany((int)*count,lrequest,&lindex,&lflag,&c_status);
1392    if (lindex != -1) {
1393        if (lflag && !*__ierr) {
1394            array_of_requests[lindex] = MPI_Request_c2f(lrequest[lindex]);
1395        }
1396     }
1397    if ((int)*count > MPIR_USE_LOCAL_ARRAY) 
1398        FREE( lrequest );
1399   
1400    *flag = MPIR_TO_FLOG(lflag);
1401    /* See the description of waitany in the standard; the Fortran index ranges
1402       are from 1, not zero */
1403    *index = (MPI_Fint)lindex;
1404    if ((int)*index >= 0)
1405        *index = *index + 1;
1406
1407    if ( status != MPER_F_MPI_STATUS_IGNORE )
1408        MPI_Status_c2f(&c_status, status);
1409}
1410
1411void mpi_test_cancelled_ ( MPI_Fint *, MPI_Fint *, MPI_Fint * );
1412void mpi_test_cancelled_(MPI_Fint *status, MPI_Fint *flag, MPI_Fint *__ierr)
1413{
1414    int lflag;
1415    MPI_Status c_status;
1416
1417    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1418
1419    MPI_Status_f2c(status, &c_status);
1420    *__ierr = MPI_Test_cancelled(&c_status, &lflag);
1421    *flag = MPIR_TO_FLOG(lflag);
1422}
1423
1424void mpi_test_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1425void mpi_test_ ( MPI_Fint *request, MPI_Fint *flag, MPI_Fint *status,
1426                 MPI_Fint *__ierr )
1427{
1428    int        l_flag;
1429    MPI_Status c_status;
1430    MPI_Request lrequest;
1431
1432    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1433
1434    lrequest = MPI_Request_f2c(*request);
1435    *__ierr = MPI_Test( &lrequest, &l_flag, &c_status);
1436    *request = MPI_Request_c2f(lrequest);
1437
1438    *flag = MPIR_TO_FLOG(l_flag);
1439
1440    if ( status != MPER_F_MPI_STATUS_IGNORE )
1441        if (l_flag)
1442            MPI_Status_c2f(&c_status, status);
1443}
1444
1445void mpi_testsome_ ( MPI_Fint *, MPI_Fint [], MPI_Fint *,
1446                     MPI_Fint [], MPI_Fint *, MPI_Fint * );
1447void mpi_testsome_( MPI_Fint *incount, MPI_Fint array_of_requests[],
1448                    MPI_Fint *outcount, MPI_Fint array_of_indices[], 
1449                    MPI_Fint *array_of_statuses, MPI_Fint *__ierr )
1450{
1451    int i,j,found;
1452    int loutcount;
1453    int *l_indices = 0;
1454    int local_l_indices[MPIR_USE_LOCAL_ARRAY];
1455    MPI_Request *lrequest = 0;
1456    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
1457    MPI_Status *c_status = 0;
1458    MPI_Status local_c_status[MPIR_USE_LOCAL_ARRAY];
1459    MPI_Fint   *f_status = 0;
1460
1461    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1462
1463    if ((int)*incount > 0) {
1464        if ((int)*incount > MPIR_USE_LOCAL_ARRAY) {
1465            MPIR_FALLOC(lrequest,
1466                       (MPI_Request*)MALLOC(sizeof(MPI_Request)*(int)*incount),
1467                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
1468                        "MPI_TESTSOME");
1469
1470            MPIR_FALLOC(l_indices,(int*)MALLOC(sizeof(int)* (int)*incount),
1471                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
1472                        "MPI_TESTSOME" );
1473            MPIR_FALLOC(c_status,
1474                        (MPI_Status*)MALLOC(sizeof(MPI_Status)* (int)*incount),
1475                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
1476                        "MPI_TESTSOME" );
1477        }
1478        else {
1479            lrequest = local_lrequest;
1480            l_indices = local_l_indices;
1481            c_status = local_c_status;
1482        }
1483
1484        for (i=0; i<(int)*incount; i++) {
1485            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
1486        }
1487        *__ierr = MPI_Testsome((int)*incount,lrequest,&loutcount,l_indices,
1488                               c_status);
1489
1490        /* By checking for lrequest[l_indices[i] =  0,
1491           we handle persistant requests */
1492        for (i=0; i<(int)*incount; i++) {
1493            if ( i < loutcount ) {
1494                array_of_requests[l_indices[i]]
1495                = MPI_Request_c2f(lrequest[l_indices[i]] );
1496            }
1497            else {
1498                found = 0;
1499                j = 0;
1500                while ( (!found) && (j<loutcount) ) {
1501                    if (l_indices[j++] == i)
1502                        found = 1;
1503                }
1504                if (!found)
1505                    array_of_requests[i] = MPI_Request_c2f( lrequest[i] );
1506            }
1507        }
1508    }
1509    else
1510        *__ierr = MPI_Testsome( (int)*incount, (MPI_Request *)0, &loutcount, 
1511                                l_indices, c_status );
1512
1513    f_status = array_of_statuses;
1514    for (i=0; i<loutcount; i++) {
1515        if ( array_of_statuses != MPER_F_MPI_STATUSES_IGNORE )
1516        {
1517            MPI_Status_c2f(&c_status[i], f_status );
1518            f_status += MPER_F_MPI_STATUS_SIZE;
1519        }
1520        if (l_indices[i] >= 0)
1521            array_of_indices[i] = l_indices[i] + 1;
1522    }
1523    *outcount = (MPI_Fint)loutcount;
1524    if ((int)*incount > MPIR_USE_LOCAL_ARRAY) {
1525        FREE( l_indices );
1526        FREE( lrequest );
1527        FREE( c_status );
1528    }
1529
1530}
1531
1532void mpi_type_commit_ ( MPI_Fint *, MPI_Fint * );
1533void mpi_type_commit_ ( MPI_Fint *datatype, MPI_Fint *__ierr )
1534{
1535    MPI_Datatype ldatatype = MPI_Type_f2c(*datatype);
1536    *__ierr = MPI_Type_commit( &ldatatype );
1537    *datatype = MPI_Type_c2f(ldatatype);
1538}
1539
1540void mpi_type_contiguous_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1541void mpi_type_contiguous_( MPI_Fint *count, MPI_Fint *old_type,
1542                           MPI_Fint *newtype, MPI_Fint *__ierr )
1543{
1544    MPI_Datatype  ldatatype;
1545
1546    *__ierr = MPI_Type_contiguous((int)*count, MPI_Type_f2c(*old_type),
1547                                  &ldatatype);
1548    *newtype = MPI_Type_c2f(ldatatype);
1549}
1550
1551void mpi_type_extent_ ( MPI_Fint *, MPI_Fint *, MPI_Fint * );
1552void mpi_type_extent_( MPI_Fint *datatype, MPI_Fint *extent, MPI_Fint *__ierr )
1553{
1554    MPI_Aint c_extent;
1555    *__ierr = MPI_Type_extent(MPI_Type_f2c(*datatype), &c_extent);
1556    /* Really should check for truncation, ala mpi_address_ */
1557    *extent = (MPI_Fint)c_extent;
1558}
1559
1560void mpi_type_free_ ( MPI_Fint *, MPI_Fint * );
1561void mpi_type_free_ ( MPI_Fint *datatype, MPI_Fint *__ierr )
1562{
1563    MPI_Datatype ldatatype = MPI_Type_f2c(*datatype);
1564    *__ierr = MPI_Type_free(&ldatatype);
1565    *datatype = MPI_Type_c2f(ldatatype);
1566}
1567
1568void mpi_type_hindexed_ ( MPI_Fint *, MPI_Fint [], MPI_Fint [],
1569                          MPI_Fint *, MPI_Fint *, MPI_Fint * );
1570void mpi_type_hindexed_( MPI_Fint *count, MPI_Fint blocklens[],
1571                         MPI_Fint indices[], MPI_Fint *old_type,
1572                         MPI_Fint *newtype, MPI_Fint *__ierr )
1573{
1574    MPI_Aint     *c_indices;
1575    MPI_Aint     local_c_indices[MPIR_USE_LOCAL_ARRAY];
1576    int          i, mpi_errno;
1577    int          *l_blocklens; 
1578    int          local_l_blocklens[MPIR_USE_LOCAL_ARRAY];
1579    MPI_Datatype ldatatype;
1580    static char  myname[] = "MPI_TYPE_HINDEXED";
1581
1582    if ((int)*count > 0) {
1583        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1584        /* We really only need to do this when
1585           sizeof(MPI_Aint) != sizeof(INTEGER) */
1586            MPIR_FALLOC(c_indices,
1587                        (MPI_Aint *) MALLOC( *count * sizeof(MPI_Aint) ),
1588                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
1589
1590            MPIR_FALLOC(l_blocklens,(int *) MALLOC( *count * sizeof(int) ),
1591                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
1592        }
1593        else {
1594            c_indices = local_c_indices;
1595            l_blocklens = local_l_blocklens;
1596        }
1597
1598        for (i=0; i<(int)*count; i++) {
1599            c_indices[i] = (MPI_Aint) indices[i];
1600            l_blocklens[i] = (int) blocklens[i];
1601        }
1602        *__ierr = MPI_Type_hindexed((int)*count,l_blocklens,c_indices,
1603                                    MPI_Type_f2c(*old_type), &ldatatype);
1604        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1605            FREE( c_indices );
1606            FREE( l_blocklens );
1607        }
1608        *newtype = MPI_Type_c2f(ldatatype);
1609    }
1610    else if ((int)*count == 0) {
1611        *__ierr = MPI_SUCCESS;
1612        *newtype = 0;
1613    }
1614    else {
1615        mpi_errno = MPER_Err_setmsg( MPI_ERR_COUNT, MPIR_ERR_DEFAULT, myname,
1616                                     (char *)0, (char *)0, (int)(*count) );
1617        *__ierr = MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
1618        return;
1619    }
1620}
1621
1622void mpi_type_hvector_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *,
1623                         MPI_Fint *, MPI_Fint *, MPI_Fint * );
1624void mpi_type_hvector_( MPI_Fint *count, MPI_Fint *blocklen, MPI_Fint *stride,
1625                        MPI_Fint *old_type, MPI_Fint *newtype,
1626                        MPI_Fint *__ierr )
1627{
1628    MPI_Aint     c_stride = (MPI_Aint)*stride;
1629    MPI_Datatype ldatatype;
1630
1631    *__ierr = MPI_Type_hvector((int)*count, (int)*blocklen, c_stride,
1632                               MPI_Type_f2c(*old_type),
1633                               &ldatatype);
1634    *newtype = MPI_Type_c2f(ldatatype);
1635}
1636
1637void mpi_type_indexed_ ( MPI_Fint *, MPI_Fint [], MPI_Fint [],
1638                         MPI_Fint *, MPI_Fint *, MPI_Fint * );
1639void mpi_type_indexed_( MPI_Fint *count, MPI_Fint blocklens[],
1640                        MPI_Fint indices[], MPI_Fint *old_type,
1641                        MPI_Fint *newtype, MPI_Fint *__ierr )
1642{
1643    int          i;
1644    int          *l_blocklens = 0;
1645    int          local_l_blocklens[MPIR_USE_LOCAL_ARRAY];
1646    int          *l_indices = 0;
1647    int          local_l_indices[MPIR_USE_LOCAL_ARRAY];
1648    MPI_Datatype ldatatype;
1649    static char myname[] = "MPI_TYPE_INDEXED";
1650
1651    if ((int)*count > 0) {
1652        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1653            MPIR_FALLOC(l_blocklens,(int *) MALLOC( *count * sizeof(int) ),
1654                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
1655
1656            MPIR_FALLOC(l_indices,(int *) MALLOC( *count * sizeof(int) ),
1657                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
1658        }
1659        else {
1660            l_blocklens = local_l_blocklens;
1661            l_indices = local_l_indices;
1662        }
1663
1664        for (i=0; i<(int)*count; i++) {
1665            l_indices[i] = (int)indices[i];
1666            l_blocklens[i] = (int)blocklens[i];
1667         }
1668    }
1669
1670    *__ierr = MPI_Type_indexed((int)*count, l_blocklens, l_indices,
1671                               MPI_Type_f2c(*old_type), 
1672                               &ldatatype);
1673    if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1674        FREE( l_indices );
1675        FREE( l_blocklens );
1676    }
1677    *newtype = MPI_Type_c2f(ldatatype);
1678}
1679
1680void mpi_type_lb_ ( MPI_Fint *, MPI_Fint *, MPI_Fint * );
1681void mpi_type_lb_ ( MPI_Fint *datatype, MPI_Fint *displacement,
1682                    MPI_Fint *__ierr )
1683{
1684    MPI_Aint   c_displacement;
1685
1686    *__ierr = MPI_Type_lb(MPI_Type_f2c(*datatype), &c_displacement);
1687    /* Should check for truncation */
1688    *displacement = (MPI_Fint)c_displacement;
1689}
1690
1691void mpi_type_size_ ( MPI_Fint *, MPI_Fint *, MPI_Fint * );
1692void mpi_type_size_ ( MPI_Fint *datatype, MPI_Fint *size, MPI_Fint *__ierr )
1693{
1694    /* MPI_Aint c_size;*/
1695    int c_size;
1696    *__ierr = MPI_Type_size(MPI_Type_f2c(*datatype), &c_size);
1697    /* Should check for truncation */
1698    *size = (MPI_Fint)c_size;
1699}
1700
1701void mpi_type_struct_ ( MPI_Fint *, MPI_Fint [], MPI_Fint [],
1702                        MPI_Fint [], MPI_Fint *, MPI_Fint * );
1703void mpi_type_struct_( MPI_Fint *count, MPI_Fint blocklens[],
1704                       MPI_Fint indices[], MPI_Fint old_types[],
1705                       MPI_Fint *newtype, MPI_Fint *__ierr )
1706{
1707    MPI_Aint     *c_indices;
1708    MPI_Aint     local_c_indices[MPIR_USE_LOCAL_ARRAY];
1709    MPI_Datatype *l_datatype;
1710    MPI_Datatype local_l_datatype[MPIR_USE_LOCAL_ARRAY];
1711    MPI_Datatype l_newtype;
1712    int          *l_blocklens;
1713    int          local_l_blocklens[MPIR_USE_LOCAL_ARRAY];
1714    int          i;
1715    int          mpi_errno;
1716    static char  myname[] = "MPI_TYPE_STRUCT";
1717   
1718    if ((int)*count > 0) {
1719        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1720        /* Since indices come from MPI_ADDRESS (the FORTRAN VERSION),
1721           they are currently relative to MPIF_F_MPI_BOTTOM. 
1722           Convert them back */
1723            MPIR_FALLOC(c_indices,
1724                        (MPI_Aint *) MALLOC( *count * sizeof(MPI_Aint) ),
1725                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
1726
1727            MPIR_FALLOC(l_blocklens,(int *) MALLOC( *count * sizeof(int) ),
1728                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
1729
1730            MPIR_FALLOC(l_datatype,
1731                        (MPI_Datatype *)
1732                        MALLOC( *count * sizeof(MPI_Datatype) ),
1733                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
1734        }
1735        else {
1736            c_indices = local_c_indices;
1737            l_blocklens = local_l_blocklens;
1738            l_datatype = local_l_datatype;
1739        }
1740
1741        for (i=0; i<(int)*count; i++) {
1742            c_indices[i] = (MPI_Aint) indices[i]/* + (MPI_Aint)MPIR_F_MPI_BOTTOM*/;
1743            l_blocklens[i] = (int) blocklens[i];
1744            l_datatype[i] = MPI_Type_f2c(old_types[i]);
1745        }
1746        *__ierr = MPI_Type_struct((int)*count, l_blocklens, c_indices,
1747                                  l_datatype, &l_newtype);
1748
1749        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1750            FREE( c_indices );
1751            FREE( l_blocklens );
1752            FREE( l_datatype );
1753        }
1754    }
1755    else if ((int)*count == 0) {
1756        *__ierr = MPI_SUCCESS;
1757        *newtype = 0;
1758    }
1759    else {
1760        mpi_errno = MPER_Err_setmsg( MPI_ERR_COUNT, MPIR_ERR_DEFAULT, myname,
1761                                     (char *)0, (char *)0, (int)(*count) );
1762        *__ierr = MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
1763        return;
1764    }
1765    *newtype = MPI_Type_c2f(l_newtype);
1766
1767}
1768
1769void mpi_type_ub_ ( MPI_Fint *, MPI_Fint *, MPI_Fint * );
1770void mpi_type_ub_ ( MPI_Fint *datatype, MPI_Fint *displacement,
1771                    MPI_Fint *__ierr )
1772{
1773    MPI_Aint c_displacement;
1774
1775    *__ierr = MPI_Type_ub(MPI_Type_f2c(*datatype), &c_displacement);
1776    /* Should check for truncation */
1777    *displacement = (MPI_Fint)c_displacement;
1778}
1779
1780void mpi_type_vector_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *,
1781                        MPI_Fint *, MPI_Fint *, MPI_Fint * );
1782void mpi_type_vector_( MPI_Fint *count, MPI_Fint *blocklen, MPI_Fint *stride,
1783                       MPI_Fint *old_type, MPI_Fint *newtype,
1784                       MPI_Fint *__ierr )
1785{
1786    MPI_Datatype l_datatype;
1787
1788    *__ierr = MPI_Type_vector((int)*count, (int)*blocklen, (int)*stride,
1789                              MPI_Type_f2c(*old_type),
1790                              &l_datatype);
1791    *newtype = MPI_Type_c2f(l_datatype);
1792}
1793
1794void mpi_unpack_ ( void *, MPI_Fint *, MPI_Fint *, void *,
1795                           MPI_Fint *, MPI_Fint *, MPI_Fint *,
1796                           MPI_Fint * );
1797void mpi_unpack_ ( void *inbuf, MPI_Fint *insize, MPI_Fint *position,
1798                   void *outbuf, MPI_Fint *outcount, MPI_Fint *type,
1799                   MPI_Fint *comm, MPI_Fint *__ierr )
1800{
1801    int l_position;
1802    l_position = (int)*position;
1803
1804    *__ierr = MPI_Unpack(inbuf, (int)*insize, &l_position,
1805                         MPIR_F_PTR(outbuf), (int)*outcount,
1806                         MPI_Type_f2c(*type), MPI_Comm_f2c(*comm) );
1807    *position = (MPI_Fint)l_position;
1808}
1809
1810void mpi_waitall_ ( MPI_Fint *, MPI_Fint [],
1811                    MPI_Fint *, MPI_Fint *);
1812void mpi_waitall_( MPI_Fint *count, MPI_Fint array_of_requests[],
1813                   MPI_Fint *array_of_statuses, MPI_Fint *__ierr )
1814{
1815    int i;
1816    MPI_Request *lrequest = 0;
1817    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
1818    MPI_Status *c_status = 0;
1819    MPI_Status local_c_status[MPIR_USE_LOCAL_ARRAY];
1820    MPI_Fint   *f_status = 0;
1821
1822    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1823
1824    if ((int)*count > 0) {
1825        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1826            MPIR_FALLOC(lrequest,(MPI_Request*)MALLOC(sizeof(MPI_Request) * 
1827                        (int)*count), MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, 
1828                        "MPI_WAITALL" );
1829
1830            MPIR_FALLOC(c_status,(MPI_Status*)MALLOC(sizeof(MPI_Status) * 
1831                        (int)*count), MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, 
1832                        "MPI_WAITALL" );
1833        }
1834        else {
1835            lrequest = local_lrequest;
1836            c_status = local_c_status;
1837        }
1838
1839        for (i=0; i<(int)*count; i++) {
1840            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
1841        }
1842
1843        *__ierr = MPI_Waitall((int)*count,lrequest,c_status);
1844        /* By checking for lrequest[i] = 0, we handle persistant requests */
1845        for (i=0; i<(int)*count; i++) {
1846                array_of_requests[i] = MPI_Request_c2f( lrequest[i] );
1847        }
1848    }
1849    else 
1850        *__ierr = MPI_Waitall((int)*count,(MPI_Request *)0, c_status );
1851
1852    if ( array_of_statuses != MPER_F_MPI_STATUSES_IGNORE )
1853    {
1854        f_status = array_of_statuses;
1855        for (i=0; i<(int)*count; i++) {
1856            MPI_Status_c2f(&(c_status[i]), f_status );
1857            f_status += MPER_F_MPI_STATUS_SIZE;
1858        }
1859    }
1860   
1861    if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1862        FREE( lrequest );
1863        FREE( c_status );
1864    }
1865}
1866
1867void mpi_waitany_ ( MPI_Fint *, MPI_Fint [], MPI_Fint *,
1868                    MPI_Fint *, MPI_Fint * );
1869void mpi_waitany_( MPI_Fint *count, MPI_Fint array_of_requests[],
1870                   MPI_Fint *index, MPI_Fint *status, MPI_Fint *__ierr )
1871{
1872
1873    int lindex;
1874    MPI_Request *lrequest;
1875    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
1876    MPI_Status c_status;
1877    int i;
1878
1879    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1880
1881    if ((int)*count > 0) {
1882        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1883            MPIR_FALLOC(lrequest,
1884                        (MPI_Request*)
1885                        MALLOC(sizeof(MPI_Request) * (int)*count),
1886                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, 
1887                        "MPI_WAITANY" );
1888        }
1889        else 
1890            lrequest = local_lrequest;
1891
1892        for (i=0; i<(int)*count; i++) 
1893            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
1894    }
1895    else
1896        lrequest = 0;
1897
1898    *__ierr = MPI_Waitany((int)*count,lrequest,&lindex,&c_status);
1899
1900    if (lindex != -1) {
1901        if (!*__ierr) {
1902            array_of_requests[lindex] = MPI_Request_c2f(lrequest[lindex]);
1903        }
1904    }
1905
1906   if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1907        FREE( lrequest );
1908    }
1909
1910    /* See the description of waitany in the standard; the Fortran index ranges
1911       are from 1, not zero */
1912    *index = (MPI_Fint)lindex;
1913    if ((int)*index >= 0) *index = (MPI_Fint)*index + 1;
1914    if ( status != MPER_F_MPI_STATUS_IGNORE )
1915        MPI_Status_c2f(&c_status, status);
1916}
1917
1918void mpi_wait_ ( MPI_Fint *, MPI_Fint *, MPI_Fint * );
1919void mpi_wait_ ( MPI_Fint *request, MPI_Fint *status, MPI_Fint *__ierr )
1920{
1921    MPI_Request lrequest;
1922    MPI_Status c_status;
1923
1924    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1925
1926    lrequest = MPI_Request_f2c(*request);
1927    *__ierr = MPI_Wait(&lrequest, &c_status);
1928    *request = MPI_Request_c2f(lrequest);
1929
1930    if ( status != MPER_F_MPI_STATUS_IGNORE )
1931        MPI_Status_c2f(&c_status, status);
1932}
1933
1934void mpi_waitsome_ ( MPI_Fint *, MPI_Fint [], MPI_Fint *,
1935                     MPI_Fint [], MPI_Fint *, MPI_Fint * );
1936void mpi_waitsome_( MPI_Fint *incount, MPI_Fint array_of_requests[],
1937                    MPI_Fint *outcount, MPI_Fint array_of_indices[], 
1938                    MPI_Fint *array_of_statuses,
1939                    MPI_Fint *__ierr )
1940{
1941    int i,j,found;
1942    int loutcount;
1943    int *l_indices = 0;
1944    int local_l_indices[MPIR_USE_LOCAL_ARRAY];
1945    MPI_Request *lrequest = 0;
1946    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
1947    MPI_Status *c_status = 0;
1948    MPI_Status local_c_status[MPIR_USE_LOCAL_ARRAY];
1949    MPI_Fint   *f_status = 0;
1950
1951    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1952
1953    if ((int)*incount > 0) {
1954        if ((int)*incount > MPIR_USE_LOCAL_ARRAY) {
1955            MPIR_FALLOC(lrequest,
1956                        (MPI_Request*)
1957                        MALLOC(sizeof(MPI_Request)* (int)*incount),
1958                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, 
1959                        "MPI_WAITSOME" );
1960
1961            MPIR_FALLOC(l_indices,(int*)MALLOC(sizeof(int) * (int)*incount),
1962                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, 
1963                        "MPI_WAITSOME" );
1964
1965            MPIR_FALLOC(c_status,
1966                        (MPI_Status*)
1967                        MALLOC(sizeof(MPI_Status) * (int)*incount),
1968                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, 
1969                        "MPI_WAITSOME" );
1970        }
1971        else {
1972            lrequest = local_lrequest;
1973            l_indices = local_l_indices;
1974            c_status = local_c_status;
1975        }
1976
1977        for (i=0; i<(int)*incount; i++) 
1978            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
1979
1980        *__ierr = MPI_Waitsome((int)*incount,lrequest,&loutcount,l_indices,
1981                               c_status);
1982
1983/* By checking for lrequest[l_indices[i]] = 0,
1984   we handle persistant requests */
1985        for (i=0; i<(int)*incount; i++) {
1986            if ( i < loutcount) {
1987                if (l_indices[i] >= 0) {
1988                    array_of_requests[l_indices[i]]
1989                    = MPI_Request_c2f( lrequest[l_indices[i]] );
1990                }
1991            }
1992            else {
1993                found = 0;
1994                j = 0;
1995                while ( (!found) && (j<loutcount) ) {
1996                    if (l_indices[j++] == i)
1997                        found = 1;
1998                }
1999                if (!found)
2000                    array_of_requests[i] = MPI_Request_c2f( lrequest[i] );
2001            }
2002        }
2003    }
2004    else 
2005        *__ierr = MPI_Waitsome( (int)*incount, (MPI_Request *)0, &loutcount,
2006                                l_indices, c_status );
2007
2008    f_status = array_of_statuses;
2009    for (i=0; i<loutcount; i++) {
2010        if ( array_of_statuses != MPER_F_MPI_STATUSES_IGNORE )
2011        {
2012            MPI_Status_c2f( &c_status[i], f_status );
2013            f_status += MPER_F_MPI_STATUS_SIZE;
2014        }
2015        if (l_indices[i] >= 0)
2016            array_of_indices[i] = l_indices[i] + 1;
2017    }
2018    *outcount = (MPI_Fint)loutcount;
2019    if ((int)*incount > MPIR_USE_LOCAL_ARRAY) {
2020        FREE( l_indices );
2021        FREE( lrequest );
2022        FREE( c_status );
2023    }
2024}
2025
2026void mpi_allgather_ ( void *, MPI_Fint *, MPI_Fint *, void *,
2027                              MPI_Fint *, MPI_Fint *, MPI_Fint *,
2028                              MPI_Fint * );
2029void mpi_allgather_ ( void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype,
2030                      void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype,
2031                      MPI_Fint *comm, MPI_Fint *__ierr )
2032{
2033    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2034    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2035
2036    *__ierr = MPI_Allgather(MPIR_F_PTR(sendbuf), (int)*sendcount,
2037                            MPI_Type_f2c(*sendtype),
2038                            MPIR_F_PTR(recvbuf),
2039                            (int)*recvcount,
2040                            MPI_Type_f2c(*recvtype),
2041                            MPI_Comm_f2c(*comm));
2042}
2043
2044void mpi_allgatherv_ ( void *, MPI_Fint *, MPI_Fint *,
2045                       void *, MPI_Fint *, MPI_Fint *,
2046                       MPI_Fint *, MPI_Fint *, MPI_Fint * );
2047void mpi_allgatherv_ ( void *sendbuf, MPI_Fint *sendcount,  MPI_Fint *sendtype,
2048                       void *recvbuf, MPI_Fint *recvcounts, MPI_Fint *displs,
2049                       MPI_Fint *recvtype, MPI_Fint *comm, MPI_Fint *__ierr )
2050{
2051    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2052    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2053
2054    if (sizeof(MPI_Fint) == sizeof(int))
2055        *__ierr = MPI_Allgatherv(MPIR_F_PTR(sendbuf), *sendcount,
2056                                 MPI_Type_f2c(*sendtype),
2057                                 MPIR_F_PTR(recvbuf), recvcounts,
2058                                 displs, MPI_Type_f2c(*recvtype),
2059                                 MPI_Comm_f2c(*comm));
2060    else {
2061        int size;
2062        int *l_recvcounts;
2063        int *l_displs;
2064        int i;
2065
2066        MPI_Comm_size(MPI_Comm_f2c(*comm), &size);
2067
2068        MPIR_FALLOC(l_recvcounts,(int*)MALLOC(sizeof(int)* size),
2069                    MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2070                    "MPI_Allgatherv");
2071        MPIR_FALLOC(l_displs,(int*)MALLOC(sizeof(int)* size),
2072                    MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2073                    "MPI_Allgatherv");
2074        for (i=0; i<size; i++) {
2075            l_recvcounts[i] = (int)recvcounts[i];
2076            l_displs[i] = (int)displs[i];
2077        }
2078
2079        *__ierr = MPI_Allgatherv(MPIR_F_PTR(sendbuf), (int)*sendcount,
2080                                 MPI_Type_f2c(*sendtype),
2081                                 MPIR_F_PTR(recvbuf), l_recvcounts,
2082                                 l_displs, MPI_Type_f2c(*recvtype),
2083                                 MPI_Comm_f2c(*comm));
2084        FREE( l_recvcounts );
2085        FREE( l_displs );
2086    }
2087}
2088
2089void mpi_allreduce_ ( void *, void *, MPI_Fint *, MPI_Fint *,
2090                      MPI_Fint *, MPI_Fint *, MPI_Fint * );
2091void mpi_allreduce_ ( void *sendbuf, void *recvbuf, MPI_Fint *count,
2092                      MPI_Fint *datatype, MPI_Fint *op, MPI_Fint *comm,
2093                      MPI_Fint *__ierr )
2094{
2095    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2096    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2097
2098    *__ierr = MPI_Allreduce(MPIR_F_PTR(sendbuf),MPIR_F_PTR(recvbuf),
2099                            (int)*count, MPI_Type_f2c(*datatype),
2100                            MPI_Op_f2c(*op), MPI_Comm_f2c(*comm) );
2101}
2102
2103
2104void mpi_alltoall_ ( void *, MPI_Fint *, MPI_Fint *, void *,
2105                             MPI_Fint *, MPI_Fint *, MPI_Fint *,
2106                             MPI_Fint * );
2107void mpi_alltoall_( void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype,
2108                    void *recvbuf, MPI_Fint *recvcnt, MPI_Fint *recvtype,
2109                    MPI_Fint *comm, MPI_Fint *__ierr )
2110{
2111    *__ierr = MPI_Alltoall(MPIR_F_PTR(sendbuf), (int)*sendcount,
2112                           MPI_Type_f2c(*sendtype), MPIR_F_PTR(recvbuf),
2113                           (int)*recvcnt, MPI_Type_f2c(*recvtype),
2114                           MPI_Comm_f2c(*comm) );
2115}
2116
2117void mpi_alltoallv_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *, 
2118                      void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
2119                      MPI_Fint *, MPI_Fint * );
2120void mpi_alltoallv_ ( void *sendbuf, MPI_Fint *sendcnts,
2121                      MPI_Fint *sdispls, MPI_Fint *sendtype,
2122                      void *recvbuf, MPI_Fint *recvcnts,
2123                      MPI_Fint *rdispls, MPI_Fint *recvtype,
2124                      MPI_Fint *comm, MPI_Fint *__ierr )
2125{
2126    if (sizeof(MPI_Fint) == sizeof(int))
2127    *__ierr = MPI_Alltoallv(MPIR_F_PTR(sendbuf), sendcnts,
2128                                sdispls, MPI_Type_f2c(*sendtype),
2129                    MPIR_F_PTR(recvbuf), recvcnts,
2130                                rdispls, MPI_Type_f2c(*recvtype),
2131                    MPI_Comm_f2c(*comm) );
2132    else {
2133
2134        int *l_sendcnts;
2135        int *l_sdispls;
2136        int *l_recvcnts;
2137        int *l_rdispls;
2138    int size;
2139    int i;
2140
2141    MPI_Comm_size(MPI_Comm_f2c(*comm), &size);
2142
2143    MPIR_FALLOC(l_sendcnts,(int*)MALLOC(sizeof(int)* size),
2144            MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2145            "MPI_Alltoallv");
2146    MPIR_FALLOC(l_sdispls,(int*)MALLOC(sizeof(int)* size),
2147            MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2148            "MPI_Alltoallv");
2149    MPIR_FALLOC(l_recvcnts,(int*)MALLOC(sizeof(int)* size),
2150            MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2151            "MPI_Alltoallv");
2152    MPIR_FALLOC(l_rdispls,(int*)MALLOC(sizeof(int)* size),
2153            MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2154            "MPI_Alltoallv");
2155
2156    for (i=0; i<size; i++) {
2157        l_sendcnts[i] = (int)sendcnts[i];
2158        l_sdispls[i] = (int)sdispls[i];
2159        l_recvcnts[i] = (int)recvcnts[i];
2160        l_rdispls[i] = (int)rdispls[i];
2161    }
2162    *__ierr = MPI_Alltoallv(MPIR_F_PTR(sendbuf), l_sendcnts,
2163                                l_sdispls, MPI_Type_f2c(*sendtype),
2164                    MPIR_F_PTR(recvbuf), l_recvcnts,
2165                                l_rdispls, MPI_Type_f2c(*recvtype),
2166                    MPI_Comm_f2c(*comm) );
2167    FREE( l_sendcnts);
2168    FREE( l_sdispls );
2169    FREE( l_recvcnts);
2170    FREE( l_rdispls );
2171    }
2172}
2173
2174void mpi_barrier_ ( MPI_Fint *, MPI_Fint * );
2175void mpi_barrier_ ( MPI_Fint *comm, MPI_Fint *__ierr )
2176{
2177    *__ierr = MPI_Barrier( MPI_Comm_f2c(*comm) );
2178}
2179
2180void mpi_bcast_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
2181                          MPI_Fint *, MPI_Fint * );
2182void mpi_bcast_ ( void *buffer, MPI_Fint *count, MPI_Fint *datatype,
2183                  MPI_Fint *root, MPI_Fint *comm, MPI_Fint *__ierr )
2184{
2185    *__ierr = MPI_Bcast(MPIR_F_PTR(buffer), (int)*count,
2186                        MPI_Type_f2c(*datatype), (int)*root,
2187                        MPI_Comm_f2c(*comm));
2188}
2189
2190void mpi_gather_ ( void *, MPI_Fint *, MPI_Fint *,
2191                   void *, MPI_Fint *, MPI_Fint *,
2192                   MPI_Fint *, MPI_Fint *, MPI_Fint * );
2193void mpi_gather_ ( void *sendbuf, MPI_Fint *sendcnt, MPI_Fint *sendtype,
2194                   void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype,
2195                   MPI_Fint *root, MPI_Fint *comm, MPI_Fint *__ierr )
2196{
2197    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2198    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2199
2200    *__ierr = MPI_Gather(MPIR_F_PTR(sendbuf), (int)*sendcnt,
2201                         MPI_Type_f2c(*sendtype), MPIR_F_PTR(recvbuf),
2202                         (int)*recvcount, MPI_Type_f2c(*recvtype),
2203                         (int)*root, MPI_Comm_f2c(*comm));
2204}
2205
2206void mpi_gatherv_ ( void *, MPI_Fint *, MPI_Fint *,
2207                    void *, MPI_Fint *, MPI_Fint *,
2208                    MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
2209void mpi_gatherv_ ( void *sendbuf, MPI_Fint *sendcnt, MPI_Fint *sendtype,
2210                    void *recvbuf, MPI_Fint *recvcnts, MPI_Fint *displs,
2211                    MPI_Fint *recvtype, MPI_Fint *root, MPI_Fint *comm,
2212                    MPI_Fint *__ierr )
2213{
2214    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2215    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2216
2217    if (sizeof(MPI_Fint) == sizeof(int))
2218        *__ierr = MPI_Gatherv(MPIR_F_PTR(sendbuf), *sendcnt,
2219                              MPI_Type_f2c(*sendtype), MPIR_F_PTR(recvbuf),
2220                              recvcnts, displs,
2221                              MPI_Type_f2c(*recvtype), *root,
2222                              MPI_Comm_f2c(*comm));
2223    else {
2224    int size;
2225        int *l_recvcnts;
2226        int *l_displs;
2227    int i;
2228
2229    MPI_Comm_size(MPI_Comm_f2c(*comm), &size);
2230
2231    MPIR_FALLOC(l_recvcnts,(int*)MALLOC(sizeof(int)* size),
2232                MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2233                "MPI_Gatherv");
2234    MPIR_FALLOC(l_displs,(int*)MALLOC(sizeof(int)* size),
2235                MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2236                "MPI_Gatherv");
2237    for (i=0; i<size; i++) {
2238        l_recvcnts[i] = (int)recvcnts[i];
2239        l_displs[i] = (int)displs[i];
2240    }
2241        *__ierr = MPI_Gatherv(MPIR_F_PTR(sendbuf), (int)*sendcnt,
2242                              MPI_Type_f2c(*sendtype), MPIR_F_PTR(recvbuf),
2243                              l_recvcnts, l_displs,
2244                              MPI_Type_f2c(*recvtype), (int)*root,
2245                              MPI_Comm_f2c(*comm));
2246    FREE( l_recvcnts );
2247    FREE( l_displs );
2248    }
2249
2250}
2251
2252#ifdef FORTRAN_SPECIAL_FUNCTION_PTR
2253void mpi_op_create_( MPI_User_function **, MPI_Fint *, MPI_Fint *, MPI_Fint * );
2254#else
2255void mpi_op_create_( MPI_User_function *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
2256#endif
2257
2258void mpi_op_create_(
2259#ifdef FORTRAN_SPECIAL_FUNCTION_PTR
2260        MPI_User_function **function,
2261#else
2262        MPI_User_function *function,
2263#endif
2264        MPI_Fint *commute, MPI_Fint *op, MPI_Fint *__ierr)
2265{
2266
2267    MPI_Op l_op;
2268
2269    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2270
2271#ifdef FORTRAN_SPECIAL_FUNCTION_PTR
2272    *__ierr = MPI_Op_create(*function,MPIR_FROM_FLOG((int)*commute),
2273                            &l_op);
2274#elif defined(_TWO_WORD_FCD)
2275    int tmp = *commute;
2276    *__ierr = MPI_Op_create(*function,MPIR_FROM_FLOG(tmp),&l_op);
2277
2278#else
2279    *__ierr = MPI_Op_create(function,MPIR_FROM_FLOG((int)*commute),
2280                            &l_op);
2281#endif
2282    *op = MPI_Op_c2f(l_op);
2283}
2284
2285void mpi_op_free_ ( MPI_Fint *, MPI_Fint * );
2286void mpi_op_free_( MPI_Fint *op, MPI_Fint *__ierr )
2287{
2288    MPI_Op l_op = MPI_Op_f2c(*op);
2289    *__ierr = MPI_Op_free(&l_op);
2290}
2291
2292void mpi_reduce_scatter_ ( void *, void *, MPI_Fint *, MPI_Fint *,
2293                           MPI_Fint *, MPI_Fint *, MPI_Fint * );
2294void mpi_reduce_scatter_ ( void *sendbuf, void *recvbuf,
2295                           MPI_Fint *recvcnts, MPI_Fint *datatype,
2296                           MPI_Fint *op, MPI_Fint *comm, MPI_Fint *__ierr )
2297{
2298    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2299    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2300
2301    if (sizeof(MPI_Fint) == sizeof(int))
2302        *__ierr = MPI_Reduce_scatter(MPIR_F_PTR(sendbuf),
2303                                     MPIR_F_PTR(recvbuf), recvcnts,
2304                                     MPI_Type_f2c(*datatype), MPI_Op_f2c(*op),
2305                                     MPI_Comm_f2c(*comm));
2306    else {
2307        int size;
2308        int *l_recvcnts;
2309    int i;
2310
2311    MPI_Comm_size(MPI_Comm_f2c(*comm), &size);
2312
2313    MPIR_FALLOC(l_recvcnts,(int*)MALLOC(sizeof(int)* size),
2314            MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2315            "MPI_Reduce_scatter");
2316    for (i=0; i<size; i++)
2317        l_recvcnts[i] = (int)recvcnts[i];
2318
2319        *__ierr = MPI_Reduce_scatter(MPIR_F_PTR(sendbuf),
2320                                     MPIR_F_PTR(recvbuf), l_recvcnts,
2321                                     MPI_Type_f2c(*datatype), MPI_Op_f2c(*op),
2322                                     MPI_Comm_f2c(*comm));
2323    FREE( l_recvcnts);
2324    }
2325
2326}
2327
2328void mpi_reduce_ ( void *, void *, MPI_Fint *, MPI_Fint *,
2329                   MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
2330void mpi_reduce_ ( void *sendbuf, void *recvbuf, MPI_Fint *count,
2331                   MPI_Fint *datatype, MPI_Fint *op, MPI_Fint *root,
2332                   MPI_Fint *comm, MPI_Fint *__ierr )
2333{
2334    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2335    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2336
2337    *__ierr = MPI_Reduce(MPIR_F_PTR(sendbuf), MPIR_F_PTR(recvbuf),
2338                         (int)*count, MPI_Type_f2c(*datatype),
2339                         MPI_Op_f2c(*op), (int)*root,
2340                         MPI_Comm_f2c(*comm));
2341}
2342
2343void mpi_scan_ ( void *, void *, MPI_Fint *, MPI_Fint *,
2344                 MPI_Fint *, MPI_Fint *, MPI_Fint * );
2345void mpi_scan_ ( void *sendbuf, void *recvbuf, MPI_Fint *count,
2346                 MPI_Fint *datatype, MPI_Fint *op, MPI_Fint *comm,
2347                 MPI_Fint *__ierr )
2348{
2349    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2350    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2351
2352    *__ierr = MPI_Scan(MPIR_F_PTR(sendbuf), MPIR_F_PTR(recvbuf),
2353                       (int)*count, MPI_Type_f2c(*datatype),
2354                       MPI_Op_f2c(*op), MPI_Comm_f2c(*comm));
2355}
2356
2357void mpi_scatter_ ( void *, MPI_Fint *, MPI_Fint *,
2358                    void *, MPI_Fint *, MPI_Fint *,
2359                    MPI_Fint *, MPI_Fint *, MPI_Fint * );
2360void mpi_scatter_ ( void *sendbuf, MPI_Fint *sendcnt, MPI_Fint *sendtype,
2361                    void *recvbuf, MPI_Fint *recvcnt, MPI_Fint *recvtype,
2362                    MPI_Fint *root, MPI_Fint *comm, MPI_Fint *__ierr )
2363{
2364    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2365    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2366
2367    *__ierr = MPI_Scatter(MPIR_F_PTR(sendbuf), (int)*sendcnt,
2368                          MPI_Type_f2c(*sendtype), MPIR_F_PTR(recvbuf),
2369                          (int)*recvcnt, MPI_Type_f2c(*recvtype),
2370                          (int)*root, MPI_Comm_f2c(*comm));
2371}
2372
2373void mpi_scatterv_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
2374                     void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
2375                     MPI_Fint *, MPI_Fint * );
2376void mpi_scatterv_ ( void *sendbuf, MPI_Fint *sendcnts,
2377                     MPI_Fint *displs, MPI_Fint *sendtype,
2378                     void *recvbuf, MPI_Fint *recvcnt, 
2379                     MPI_Fint *recvtype, MPI_Fint *root,
2380                     MPI_Fint *comm, MPI_Fint *__ierr )
2381{
2382    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2383    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2384
2385    if (sizeof(MPI_Fint) == sizeof(int))
2386        *__ierr = MPI_Scatterv(MPIR_F_PTR(sendbuf), sendcnts, displs,
2387                               MPI_Type_f2c(*sendtype), MPIR_F_PTR(recvbuf),
2388                               *recvcnt, MPI_Type_f2c(*recvtype),
2389                               *root, MPI_Comm_f2c(*comm) );
2390    else {
2391    int size;
2392        int *l_sendcnts;
2393        int *l_displs;
2394    int i;
2395
2396    MPI_Comm_size(MPI_Comm_f2c(*comm), &size);
2397
2398    MPIR_FALLOC(l_sendcnts,(int*)MALLOC(sizeof(int)* size),
2399                MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2400               "MPI_Scatterv");
2401    MPIR_FALLOC(l_displs,(int*)MALLOC(sizeof(int)* size),
2402                MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2403                "MPI_Scatterv");
2404    for (i=0; i<size; i++) {
2405        l_sendcnts[i] = (int)sendcnts[i];
2406        l_displs[i] = (int)displs[i];
2407    }
2408
2409        *__ierr = MPI_Scatterv(MPIR_F_PTR(sendbuf), l_sendcnts, l_displs,
2410                               MPI_Type_f2c(*sendtype), MPIR_F_PTR(recvbuf),
2411                               (int)*recvcnt, MPI_Type_f2c(*recvtype),
2412                               (int)*root, MPI_Comm_f2c(*comm) );
2413        FREE( l_sendcnts);
2414        FREE( l_displs);
2415    }
2416}
2417
2418void mpi_finalize_ ( int * );
2419void mpi_finalize_( ierr )
2420int *ierr; 
2421{
2422    *ierr = MPI_Finalize();
2423}
Note: See TracBrowser for help on using the browser.