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

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

Added env variable MPE_USE_FCONSTS_IN_MPIH so user can choose to use
mpi.h's fortran to C constants instead of relying on MPE.
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  world_rank;
487    int  use_mpih;
488    /*
489       Set MPI_STATUS_SIZE, fortran logicals,
490           MPI_IN_PLACE, MPI_STATUS(ES)_IGNORE
491    */
492
493    /* Default MPE_USE_FCONSTS_IN_MPIH = false */
494    use_mpih = MPE_Util_getenvbool( "MPE_USE_FCONSTS_IN_MPIH", 0 );
495    /* Let everyone in MPI_COMM_WORLD know what root has */
496    PMPI_Bcast( &use_mpih, 1, MPI_INT, 0, MPI_COMM_WORLD );
497#if defined( MPICH2 )
498    if ( use_mpih ) {
499        mpirinitf_();
500    }
501#endif
502    fsub_mpi_fconsts_( &MPER_F_MPI_STATUS_SIZE, &MPER_F_TRUE, &MPER_F_FALSE );
503/* Use the determined values and ignore MPI_F_* from mpi.h */
504#if defined( HAVE_MPI_F_STATUS_IGNORE )
505    if ( use_mpih ) {
506        MPER_F_MPI_STATUS_IGNORE = MPI_F_STATUS_IGNORE;
507    }
508#endif
509#if defined( HAVE_MPI_F_STATUSES_IGNORE )
510    if ( use_mpih ) {
511        MPER_F_MPI_STATUSES_IGNORE = MPI_F_STATUSES_IGNORE;
512    }
513#endif
514    PMPI_Comm_rank( MPI_COMM_WORLD, &world_rank );
515    if ( world_rank == 0 ) {
516        printf( "f2c(MPI_IN_PLACE) = %p\n", MPER_F_MPI_IN_PLACE );
517        printf( "f2c(MPI_STATUS_IGNORE) = %p\n", MPER_F_MPI_STATUS_IGNORE );
518        printf( "f2c(MPI_STATUSES_IGNORE) = %p\n", MPER_F_MPI_STATUSES_IGNORE );
519        printf( "f2c(MPI_STATUS_SIZE) = %d\n", MPER_F_MPI_STATUS_SIZE );
520        printf( ".TRUE. = %d, .FALSE. = %d\n", MPER_F_TRUE, MPER_F_FALSE );
521    }
522}
523
524/*
525 * Define prototypes next to the fortran2c wrapper to keep the compiler happy
526 */
527
528
529
530#if defined(USE_STDARG) && !defined(USE_OLDSTYLE_STDARG)
531int MPER_Err_setmsg( int errclass, int errkind,
532                     const char *routine_name, 
533                     const char *generic_string, 
534                     const char *default_string, ... )
535{
536    va_list Argp;
537    va_start( Argp, default_string );
538#else
539/* This assumes old-style varargs support */
540int MPER_Err_setmsg( errclass, errkind, routine_name, 
541                     generic_string, default_string, va_alist )
542int errclass, errkind;
543const char *routine_name, *generic_string, *default_string;
544va_dcl
545{
546    va_list Argp;
547    va_start( Argp );
548#endif
549
550    va_end( Argp );
551    fprintf( stderr, __FILE__":MPER_Err_setmg(%s) in MPE\n", routine_name );
552    return errclass;
553}
554
555
556/****************************************************************************/
557
558/*
559extern int is_mpe_f2c;
560*/
561
562void mpi_init_( MPI_Fint * );
563void mpi_init_( MPI_Fint *ierr )
564{
565    int Argc;
566    int i, argsize = 1024;
567    char **Argv, *p;
568    int  ArgcSave;           /* Save the argument count */
569    char **ArgvSave;         /* Save the pointer to the argument vector */
570
571/* Recover the args with the Fortran routines iargc_ and getarg_ */
572    ArgcSave        = Argc = mpir_iargc_() + 1;
573    ArgvSave        = Argv = (char **)MALLOC( Argc * sizeof(char *) );
574    if (!Argv) {
575        *ierr = MPE_ErrPrint( (MPI_Comm)0, MPI_ERR_OTHER, 
576                              "Out of space in MPI_INIT" );
577        return;
578    }
579    for (i=0; i<Argc; i++) {
580        ArgvSave[i] = Argv[i] = (char *)MALLOC( argsize + 1 );
581        if (!Argv[i]) {
582            *ierr = MPE_ErrPrint( (MPI_Comm)0, MPI_ERR_OTHER, 
583                                  "Out of space in MPI_INIT" );
584            return;
585        }
586        mpir_getarg_( &i, Argv[i], argsize );
587
588        /* Trim trailing blanks */
589        p = Argv[i] + argsize - 1;
590        while (p > Argv[i]) {
591            if (*p != ' ') {
592                p[1] = '\0';
593                break;
594            }
595            p--;
596        }
597    }
598
599    /*
600    is_mpe_f2c = 1;
601    */
602    *ierr = MPI_Init( &Argc, &Argv );
603    mper_fconsts_init(); MPER_F_Initialized = 1;
604   
605   
606    /* Recover space */
607    for (i=0; i<ArgcSave; i++) {
608        FREE( ArgvSave[i] );
609    }
610    FREE( ArgvSave );
611}
612
613
614#if defined( HAVE_MPI_INIT_THREAD )
615void mpi_init_thread_( MPI_Fint *required, MPI_Fint *provided, MPI_Fint *ierr );
616void mpi_init_thread_( MPI_Fint *required, MPI_Fint *provided, MPI_Fint *ierr )
617{
618    *ierr = MPI_Init_thread( NULL, NULL, *required, provided );
619    mper_fconsts_init(); MPER_F_Initialized = 1;
620}
621#endif
622
623
624
625void mpi_pcontrol_( MPI_Fint *icontrol, MPI_Fint *__ierr );
626void mpi_pcontrol_( MPI_Fint *icontrol, MPI_Fint *__ierr )
627{
628    *__ierr = MPI_Pcontrol( *icontrol );
629}
630
631
632
633void mpi_comm_create_( MPI_Fint *comm, MPI_Fint *group,
634                       MPI_Fint *comm_out, MPI_Fint *__ierr );
635void mpi_comm_create_( MPI_Fint *comm, MPI_Fint *group,
636                       MPI_Fint *comm_out, MPI_Fint *__ierr )
637{
638    MPI_Comm l_comm_out;
639
640    *__ierr = MPI_Comm_create( MPI_Comm_f2c(*comm), MPI_Group_f2c(*group),
641                               &l_comm_out);
642    if (*__ierr == MPI_SUCCESS)
643        *comm_out = MPI_Comm_c2f(l_comm_out);
644}
645
646
647
648void mpi_comm_dup_( MPI_Fint *comm, MPI_Fint *comm_out, MPI_Fint *__ierr );
649void mpi_comm_dup_( MPI_Fint *comm, MPI_Fint *comm_out, MPI_Fint *__ierr )
650{
651    MPI_Comm l_comm_out;
652
653    *__ierr = MPI_Comm_dup( MPI_Comm_f2c(*comm), &l_comm_out );
654    if (*__ierr == MPI_SUCCESS)
655        *comm_out = MPI_Comm_c2f(l_comm_out);
656}
657
658
659
660void mpi_comm_free_( MPI_Fint *comm, MPI_Fint *__ierr );
661void mpi_comm_free_( MPI_Fint *comm, MPI_Fint *__ierr )
662{
663    MPI_Comm l_comm = MPI_Comm_f2c(*comm);
664    *__ierr = MPI_Comm_free(&l_comm);
665    if (*__ierr == MPI_SUCCESS)
666        *comm = MPI_Comm_c2f(l_comm);
667}
668
669
670
671void mpi_comm_split_( MPI_Fint *comm, MPI_Fint *color, MPI_Fint *key,
672                      MPI_Fint *comm_out, MPI_Fint *__ierr );
673void mpi_comm_split_( MPI_Fint *comm, MPI_Fint *color, MPI_Fint *key,
674                      MPI_Fint *comm_out, MPI_Fint *__ierr )
675{
676    MPI_Comm l_comm_out;
677
678    *__ierr = MPI_Comm_split( MPI_Comm_f2c(*comm), (int)*color, (int)*key,
679                              &l_comm_out);
680    if (*__ierr == MPI_SUCCESS)
681        *comm_out = MPI_Comm_c2f(l_comm_out);
682}
683
684
685
686void mpi_intercomm_create_( MPI_Fint *local_comm, MPI_Fint *local_leader,
687                            MPI_Fint *peer_comm, MPI_Fint *remote_leader,
688                            MPI_Fint *tag, MPI_Fint *comm_out,
689                            MPI_Fint *__ierr );
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 )
694{
695    MPI_Comm l_comm_out;
696    *__ierr = MPI_Intercomm_create( MPI_Comm_f2c(*local_comm),
697                                    (int)*local_leader,
698                                    MPI_Comm_f2c(*peer_comm),
699                                    (int)*remote_leader, (int)*tag,
700                                    &l_comm_out);
701    if (*__ierr == MPI_SUCCESS)
702        *comm_out = MPI_Comm_c2f(l_comm_out);
703}
704
705
706
707void mpi_intercomm_merge_( MPI_Fint *comm, MPI_Fint *high, MPI_Fint *comm_out,
708                           MPI_Fint *__ierr );
709void mpi_intercomm_merge_( MPI_Fint *comm, MPI_Fint *high, MPI_Fint *comm_out,
710                           MPI_Fint *__ierr )
711{
712    MPI_Comm l_comm_out;
713
714    *__ierr = MPI_Intercomm_merge( MPI_Comm_f2c(*comm), (int)*high,
715                                   &l_comm_out);
716    if (*__ierr == MPI_SUCCESS)
717        *comm_out = MPI_Comm_c2f(l_comm_out);
718}
719
720
721
722void mpi_cart_create_( MPI_Fint *comm_old, MPI_Fint *ndims, MPI_Fint *dims,
723                       MPI_Fint *periods, MPI_Fint *reorder,
724                       MPI_Fint *comm_cart, MPI_Fint *ierr );
725void mpi_cart_create_( MPI_Fint *comm_old, MPI_Fint *ndims, MPI_Fint *dims,
726                       MPI_Fint *periods, MPI_Fint *reorder,
727                       MPI_Fint *comm_cart, MPI_Fint *ierr )
728{
729    MPI_Comm   l_comm_cart;
730    int       *lperiods, *ldims;
731    int        ls_ints[40];     /* local static int[] */
732    int       *la_ints;         /* local allocated int[] */
733    int        is_malloced;
734    int        i;
735
736    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
737
738    is_malloced = 0;
739    if ( *ndims > 20 ) {
740#if ! defined( HAVE_ALLOCA )
741        la_ints  = (int *) malloc( 2 * (*ndims) * sizeof(int) );
742        is_malloced = 1;
743#else
744        la_ints  = (int *) alloca( 2 * (*ndims) * sizeof(int) );
745#endif
746        lperiods = &(la_ints[0]);
747        ldims    = &(la_ints[*ndims]);
748    }
749    else  { /* if ( *ndims <= 20 ) */
750        lperiods = &(ls_ints[0]);
751        ldims    = &(ls_ints[20]);
752    }
753    for (i=0; i<(int)*ndims; i++) {
754        lperiods[i] = MPIR_FROM_FLOG(periods[i]);
755        ldims[i] = (int)dims[i];
756    }
757
758#if defined(_TWO_WORD_FCD)
759    int tmp = *reorder;
760    *ierr = MPI_Cart_create( MPI_Comm_f2c(*comm_old),
761                             (int)*ndims, ldims,
762                             lperiods, MPIR_FROM_FLOG(tmp),
763                             &l_comm_cart);
764#else
765    *ierr = MPI_Cart_create( MPI_Comm_f2c(*comm_old),
766                             (int)*ndims, ldims,
767                             lperiods, MPIR_FROM_FLOG(*reorder),
768                             &l_comm_cart);
769#endif
770
771#if ! defined( HAVE_ALLOCA )
772    if ( is_malloced == 1 )
773        free( la_ints );
774#endif
775    if (*ierr == MPI_SUCCESS)
776        *comm_cart = MPI_Comm_c2f(l_comm_cart);
777}
778
779
780
781void mpi_cart_sub_( MPI_Fint *comm, MPI_Fint *remain_dims,
782                    MPI_Fint *comm_new, MPI_Fint *__ierr );
783void mpi_cart_sub_( MPI_Fint *comm, MPI_Fint *remain_dims,
784                    MPI_Fint *comm_new, MPI_Fint *__ierr )
785{
786    MPI_Comm   lcomm_new;
787    int        ls_ints[20];     /* local static int[] */
788    int       *la_ints;         /* local allocated int[] */
789    int        is_malloced;
790    int       *lremain_dims;
791    int        ndims, i;
792
793    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
794
795    MPI_Cartdim_get( MPI_Comm_f2c(*comm), &ndims );
796
797    is_malloced = 0;
798    if ( ndims > 20 ) {
799#if ! defined( HAVE_ALLOCA )
800        la_ints  = (int *) malloc( ndims * sizeof(int) );
801        is_malloced = 1;
802#else
803        la_ints  = (int *) alloca( ndims * sizeof(int) );
804#endif
805        lremain_dims = la_ints;
806    }
807    else  { /* if ( ndims <= 20 ) */
808        lremain_dims = ls_ints;
809    }
810    for (i=0; i<ndims; i++)
811        lremain_dims[i] = MPIR_FROM_FLOG(remain_dims[i]);
812
813    *__ierr = MPI_Cart_sub( MPI_Comm_f2c(*comm), lremain_dims,
814                            &lcomm_new);
815
816#if ! defined( HAVE_ALLOCA )
817    if ( is_malloced == 1 )
818        free( la_ints );
819#endif
820    if (*__ierr == MPI_SUCCESS)
821        *comm_new = MPI_Comm_c2f(lcomm_new);
822}
823
824void mpi_graph_create_( MPI_Fint *comm_old, MPI_Fint *nnodes,
825                        MPI_Fint *index, MPI_Fint *edges, MPI_Fint *reorder,
826                        MPI_Fint *comm_graph, MPI_Fint *__ierr );
827void mpi_graph_create_( MPI_Fint *comm_old, MPI_Fint *nnodes,
828                        MPI_Fint *index, MPI_Fint *edges, MPI_Fint *reorder,
829                        MPI_Fint *comm_graph, MPI_Fint *__ierr )
830{
831    MPI_Comm lcomm_graph;
832
833    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
834
835    if (sizeof(MPI_Fint) == sizeof(int))
836#if defined(_TWO_WORD_FCD)
837        int tmp = *reorder;
838        *__ierr = MPI_Graph_create( MPI_Comm_f2c(*comm_old), *nnodes,
839                                    index, edges,
840                                    MPIR_FROM_FLOG(tmp),
841                                    &lcomm_graph);
842#else
843        *__ierr = MPI_Graph_create( MPI_Comm_f2c(*comm_old), *nnodes,
844                                    index, edges,
845                                    MPIR_FROM_FLOG(*reorder),
846                                    &lcomm_graph);
847#endif
848    else {
849        int i;
850        int nedges;
851        int *lindex;
852        int *ledges;
853
854
855        MPI_Graphdims_get(MPI_Comm_f2c(*comm_old), nnodes, &nedges);
856        MPIR_FALLOC(lindex,(int*)MALLOC(sizeof(int)* (int)*nnodes),
857                    MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
858                    "MPI_Graph_create");
859        MPIR_FALLOC(ledges,(int*)MALLOC(sizeof(int)* (int)nedges),
860                    MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
861                    "MPI_Graph_create");
862
863        for (i=0; i<(int)*nnodes; i++)
864            lindex[i] = (int)index[i];
865
866        for (i=0; i<nedges; i++)
867            ledges[i] = (int)edges[i];
868
869#if defined(_TWO_WORD_FCD)
870        int tmp = *reorder;
871        *__ierr = MPI_Graph_create( MPI_Comm_f2c(*comm_old), (int)*nnodes,
872                                    lindex, ledges,
873                                    MPIR_FROM_FLOG(tmp),
874                                    &lcomm_graph);
875#else
876        *__ierr = MPI_Graph_create( MPI_Comm_f2c(*comm_old), (int)*nnodes,
877                                    lindex, ledges,
878                                    MPIR_FROM_FLOG(*reorder),
879                                    &lcomm_graph);
880#endif
881        FREE( lindex );
882        FREE( ledges );
883    }
884    if (*__ierr == MPI_SUCCESS)
885        *comm_graph = MPI_Comm_c2f(lcomm_graph);
886}
887
888
889
890void mpi_bsend_init_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
891                       MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
892void mpi_bsend_init_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
893                      MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
894                      MPI_Fint *request, MPI_Fint *__ierr )
895{
896    MPI_Request lrequest;
897    *__ierr = MPI_Bsend_init( MPIR_F_PTR(buf), (int)*count,
898                              MPI_Type_f2c(*datatype),
899                              (int)*dest,
900                              (int)*tag, MPI_Comm_f2c(*comm),
901                              &lrequest);
902    *request = MPI_Request_c2f(lrequest);
903}
904
905void mpi_bsend_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
906                  MPI_Fint *, MPI_Fint *, MPI_Fint * );
907void mpi_bsend_( void *buf, MPI_Fint *count, MPI_Fint *datatype, 
908                 MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm, 
909                 MPI_Fint *__ierr )
910{
911    *__ierr = MPI_Bsend( MPIR_F_PTR(buf), (int)*count, MPI_Type_f2c(*datatype),
912                         (int)*dest, (int)*tag, MPI_Comm_f2c(*comm) );
913}
914
915void mpi_buffer_attach_ ( void *, MPI_Fint *, MPI_Fint * );
916void mpi_buffer_attach_( void *buffer, MPI_Fint *size, MPI_Fint *__ierr )
917{
918    *__ierr = MPI_Buffer_attach(buffer,(int)*size);
919}
920
921void mpi_buffer_detach_ ( void **, MPI_Fint *, MPI_Fint * );
922void mpi_buffer_detach_( void **buffer, MPI_Fint *size, MPI_Fint *__ierr )
923{
924    void *tmp = (void *)buffer;
925    int lsize;
926
927    *__ierr = MPI_Buffer_detach(&tmp,&lsize);
928    *size = (MPI_Fint)lsize;
929}
930
931void mpi_cancel_ (MPI_Fint *, MPI_Fint *);
932void mpi_cancel_( MPI_Fint *request, MPI_Fint *__ierr )
933{
934    MPI_Request lrequest;
935
936    lrequest = MPI_Request_f2c(*request); 
937    *__ierr = MPI_Cancel(&lrequest); 
938}
939
940void mpi_request_free_ ( MPI_Fint *, MPI_Fint * );
941void mpi_request_free_( MPI_Fint *request, MPI_Fint *__ierr )
942{
943    MPI_Request lrequest = MPI_Request_f2c(*request);
944    *__ierr = MPI_Request_free( &lrequest );
945    *request = MPI_Request_c2f(lrequest);
946}
947
948void mpi_recv_init_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *, 
949                      MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
950void mpi_recv_init_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
951                     MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm,
952                     MPI_Fint *request, MPI_Fint *__ierr )
953{
954    MPI_Request lrequest;
955    *__ierr = MPI_Recv_init(MPIR_F_PTR(buf),(int)*count,
956                            MPI_Type_f2c(*datatype),(int)*source,(int)*tag,
957                            MPI_Comm_f2c(*comm),&lrequest);
958    *request = MPI_Request_c2f(lrequest);
959}
960
961void mpi_send_init_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *, 
962                      MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
963void mpi_send_init_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
964                     MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
965                     MPI_Fint *request, MPI_Fint *__ierr )
966{
967    MPI_Request lrequest;
968    *__ierr = MPI_Send_init(MPIR_F_PTR(buf),(int)*count,
969                            MPI_Type_f2c(*datatype),(int)*dest,(int)*tag,
970                            MPI_Comm_f2c(*comm),&lrequest);
971    *request = MPI_Request_c2f( lrequest );
972}
973
974void mpi_get_count_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
975void mpi_get_count_( MPI_Fint *status, MPI_Fint *datatype, MPI_Fint *count,
976                     MPI_Fint *__ierr )
977{
978    int lcount;
979    MPI_Status c_status;
980
981    MPI_Status_f2c(status, &c_status);
982    *__ierr = MPI_Get_count(&c_status, MPI_Type_f2c(*datatype),
983                            &lcount);
984    *count = (MPI_Fint)lcount;
985}
986
987void mpi_get_elements_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
988void mpi_get_elements_ ( MPI_Fint *status, MPI_Fint *datatype,
989                         MPI_Fint *elements, MPI_Fint *__ierr )
990{
991    int lelements;
992    MPI_Status c_status;
993
994    MPI_Status_f2c(status, &c_status);
995    *__ierr = MPI_Get_elements(&c_status,MPI_Type_f2c(*datatype),
996                               &lelements);
997    *elements = (MPI_Fint)lelements;
998}
999
1000void mpi_ibsend_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1001                   MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1002void mpi_ibsend_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1003                  MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1004                  MPI_Fint *request, MPI_Fint *__ierr )
1005{
1006    MPI_Request lrequest;
1007    *__ierr = MPI_Ibsend(MPIR_F_PTR(buf),(int)*count,MPI_Type_f2c(*datatype),
1008                         (int)*dest,(int)*tag,MPI_Comm_f2c(*comm),
1009                         &lrequest);
1010    *request = MPI_Request_c2f(lrequest);
1011}
1012
1013void mpi_iprobe_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *,
1014                   MPI_Fint *, MPI_Fint *, MPI_Fint * );
1015void mpi_iprobe_( MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm,
1016                  MPI_Fint *flag, MPI_Fint *status, MPI_Fint *__ierr )
1017{
1018    int lflag;
1019    MPI_Status c_status;
1020
1021    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1022
1023    *__ierr = MPI_Iprobe((int)*source,(int)*tag,MPI_Comm_f2c(*comm),
1024                         &lflag,&c_status);
1025    *flag = MPIR_TO_FLOG(lflag);
1026    if ( status != MPER_F_MPI_STATUS_IGNORE )
1027        MPI_Status_c2f(&c_status, status);
1028}
1029
1030void mpi_irecv_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1031                  MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1032void mpi_irecv_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1033                 MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm,
1034                 MPI_Fint *request, MPI_Fint *__ierr )
1035{
1036    MPI_Request lrequest;
1037    *__ierr = MPI_Irecv(MPIR_F_PTR(buf),(int)*count,MPI_Type_f2c(*datatype),
1038                        (int)*source,(int)*tag,
1039                        MPI_Comm_f2c(*comm),&lrequest);
1040    *request = MPI_Request_c2f(lrequest);
1041}
1042
1043void mpi_irsend_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1044                   MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1045void mpi_irsend_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1046                  MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1047                  MPI_Fint *request, MPI_Fint *__ierr )
1048{
1049    MPI_Request lrequest;
1050    *__ierr = MPI_Irsend(MPIR_F_PTR(buf),(int)*count,MPI_Type_f2c(*datatype),
1051                         (int)*dest,(int)*tag,
1052                         MPI_Comm_f2c(*comm),&lrequest);
1053    *request = MPI_Request_c2f(lrequest);
1054}
1055
1056void mpi_isend_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1057                  MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1058void mpi_isend_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1059                 MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1060                 MPI_Fint *request, MPI_Fint *__ierr )
1061{
1062    MPI_Request lrequest;
1063    *__ierr = MPI_Isend(MPIR_F_PTR(buf),(int)*count,MPI_Type_f2c(*datatype),
1064                        (int)*dest,
1065                        (int)*tag,MPI_Comm_f2c(*comm),
1066                        &lrequest);
1067    *request = MPI_Request_c2f(lrequest);
1068}
1069
1070void mpi_issend_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1071                   MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1072void mpi_issend_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1073                  MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1074                  MPI_Fint *request, MPI_Fint *__ierr )
1075{
1076    MPI_Request lrequest;
1077    *__ierr = MPI_Issend(MPIR_F_PTR(buf),(int)*count,MPI_Type_f2c(*datatype),
1078                         (int)*dest, (int)*tag,
1079                         MPI_Comm_f2c(*comm),
1080                         &lrequest);
1081    *request = MPI_Request_c2f(lrequest);
1082}
1083
1084void mpi_pack_size_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *,
1085                      MPI_Fint *, MPI_Fint * );
1086void mpi_pack_size_ ( MPI_Fint *incount, MPI_Fint *datatype, MPI_Fint *comm,
1087                      MPI_Fint *size, MPI_Fint *__ierr )
1088{
1089    int lsize;
1090
1091    *__ierr = MPI_Pack_size((int)*incount, MPI_Type_f2c(*datatype),
1092                            MPI_Comm_f2c(*comm), &lsize);
1093    *size = (MPI_Fint)lsize;
1094}
1095
1096void mpi_pack_ ( void *, MPI_Fint *, MPI_Fint *, void *,
1097                 MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1098void mpi_pack_ ( void *inbuf, MPI_Fint *incount, MPI_Fint *type,
1099                 void *outbuf, MPI_Fint *outcount, MPI_Fint *position,
1100                 MPI_Fint *comm, MPI_Fint *__ierr )
1101{
1102    int lposition;
1103
1104    lposition = (int)*position;
1105    *__ierr = MPI_Pack(MPIR_F_PTR(inbuf), (int)*incount, MPI_Type_f2c(*type),
1106                       outbuf, (int)*outcount, &lposition,
1107                       MPI_Comm_f2c(*comm));
1108    *position = (MPI_Fint)lposition;
1109}
1110
1111void mpi_probe_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *,
1112                  MPI_Fint *, MPI_Fint * );
1113void mpi_probe_( MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm,
1114                 MPI_Fint *status, MPI_Fint *__ierr )
1115{
1116    MPI_Status c_status;
1117
1118    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1119
1120    *__ierr = MPI_Probe((int)*source, (int)*tag, MPI_Comm_f2c(*comm),
1121                        &c_status);
1122    if ( status != MPER_F_MPI_STATUS_IGNORE )
1123        MPI_Status_c2f(&c_status, status);
1124}
1125
1126void mpi_recv_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1127                         MPI_Fint *, MPI_Fint *, MPI_Fint *,
1128                         MPI_Fint * );
1129void mpi_recv_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1130                MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm,
1131                MPI_Fint *status, MPI_Fint *__ierr )
1132{
1133    MPI_Status c_status;
1134
1135    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1136
1137    *__ierr = MPI_Recv(MPIR_F_PTR(buf), (int)*count,MPI_Type_f2c(*datatype),
1138                       (int)*source, (int)*tag,
1139                       MPI_Comm_f2c(*comm), &c_status);
1140    if ( status != MPER_F_MPI_STATUS_IGNORE )
1141        MPI_Status_c2f(&c_status, status);
1142}
1143
1144void mpi_rsend_init_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1145                       MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1146void mpi_rsend_init_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1147                      MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1148                      MPI_Fint *request, MPI_Fint *__ierr )
1149{
1150    MPI_Request lrequest;
1151    *__ierr = MPI_Rsend_init(MPIR_F_PTR(buf), (int)*count,
1152                             MPI_Type_f2c(*datatype), (int)*dest,
1153                             (int)*tag,
1154                             MPI_Comm_f2c(*comm), &lrequest);
1155    *request = MPI_Request_c2f(lrequest);
1156}
1157
1158void mpi_rsend_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1159                  MPI_Fint *, MPI_Fint *, MPI_Fint * );
1160void mpi_rsend_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1161                 MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1162                 MPI_Fint *__ierr )
1163{
1164    *__ierr = MPI_Rsend(MPIR_F_PTR(buf), (int)*count,MPI_Type_f2c(*datatype),
1165                        (int)*dest, (int)*tag, MPI_Comm_f2c(*comm));
1166}
1167
1168void mpi_send_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1169                 MPI_Fint *, MPI_Fint*, MPI_Fint * );
1170
1171void mpi_send_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1172                MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1173                MPI_Fint *__ierr )
1174{
1175    *__ierr = MPI_Send(MPIR_F_PTR(buf), (int)*count, MPI_Type_f2c(*datatype),
1176                       (int)*dest, (int)*tag, MPI_Comm_f2c(*comm));
1177}
1178
1179void mpi_sendrecv_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1180                     void *, MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1181                     MPI_Fint *, MPI_Fint *, MPI_Fint * );
1182void mpi_sendrecv_( void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype,
1183                    MPI_Fint *dest, MPI_Fint *sendtag,
1184                    void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype,
1185                    MPI_Fint *source, MPI_Fint *recvtag,
1186                    MPI_Fint *comm, MPI_Fint *status, MPI_Fint *__ierr )
1187{
1188    MPI_Status c_status;
1189
1190    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1191
1192    *__ierr = MPI_Sendrecv(MPIR_F_PTR(sendbuf), (int)*sendcount,
1193                           MPI_Type_f2c(*sendtype), (int)*dest,
1194                           (int)*sendtag, MPIR_F_PTR(recvbuf),
1195                           (int)*recvcount, MPI_Type_f2c(*recvtype),
1196                           (int)*source, (int)*recvtag,
1197                           MPI_Comm_f2c(*comm), &c_status);
1198    if ( status != MPER_F_MPI_STATUS_IGNORE )
1199        MPI_Status_c2f(&c_status, status);
1200}
1201
1202void mpi_sendrecv_replace_ ( void *, MPI_Fint *, MPI_Fint *,
1203                                     MPI_Fint *, MPI_Fint *, MPI_Fint *,
1204                                     MPI_Fint *, MPI_Fint *, MPI_Fint *,
1205                                     MPI_Fint * );
1206void mpi_sendrecv_replace_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1207                            MPI_Fint *dest, MPI_Fint *sendtag,
1208                            MPI_Fint *source, MPI_Fint *recvtag,
1209                            MPI_Fint *comm, MPI_Fint *status,
1210                            MPI_Fint *__ierr )
1211{
1212    MPI_Status c_status;
1213
1214    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1215
1216    *__ierr = MPI_Sendrecv_replace(MPIR_F_PTR(buf), (int)*count,
1217                                   MPI_Type_f2c(*datatype), (int)*dest,
1218                                   (int)*sendtag, (int)*source, (int)*recvtag,
1219                                   MPI_Comm_f2c(*comm), &c_status );
1220    if ( status != MPER_F_MPI_STATUS_IGNORE )
1221        MPI_Status_c2f(&c_status, status);
1222}
1223
1224void mpi_ssend_init_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1225                       MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1226void mpi_ssend_init_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1227                      MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1228                      MPI_Fint *request, MPI_Fint *__ierr )
1229{
1230    MPI_Request lrequest;
1231    *__ierr = MPI_Ssend_init(MPIR_F_PTR(buf), (int)*count,
1232                             MPI_Type_f2c(*datatype), (int)*dest, (int)*tag,
1233                             MPI_Comm_f2c(*comm), &lrequest);
1234    *request = MPI_Request_c2f(lrequest);
1235}
1236
1237void mpi_ssend_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
1238                          MPI_Fint *, MPI_Fint *, MPI_Fint * );
1239void mpi_ssend_( void *buf, MPI_Fint *count, MPI_Fint *datatype,
1240                 MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm,
1241                 MPI_Fint *__ierr )
1242{
1243    *__ierr = MPI_Ssend(MPIR_F_PTR(buf), (int)*count,
1244                        MPI_Type_f2c(*datatype), (int)*dest, (int)*tag,
1245                        MPI_Comm_f2c(*comm));
1246}
1247
1248void mpi_startall_ ( MPI_Fint *, MPI_Fint [], MPI_Fint * );
1249void mpi_startall_( MPI_Fint *count, MPI_Fint array_of_requests[],
1250                    MPI_Fint *__ierr )
1251{
1252    MPI_Request *lrequest = 0;
1253    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
1254    int i;
1255
1256    if ((int)*count > 0) {
1257        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1258            MPIR_FALLOC(lrequest,
1259                        (MPI_Request*)MALLOC(sizeof(MPI_Request)*(int)*count),
1260                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
1261                        "MPI_STARTALL" );
1262        }
1263        else {
1264            lrequest = local_lrequest;
1265        }
1266        for (i=0; i<(int)*count; i++) {
1267            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
1268        }
1269        *__ierr = MPI_Startall((int)*count,lrequest);
1270    }
1271    else
1272        *__ierr = MPI_Startall((int)*count,(MPI_Request *)0);
1273
1274    for (i=0; i<(int)*count; i++) {
1275        array_of_requests[i] = MPI_Request_c2f( lrequest[i]);
1276    }
1277    if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1278        FREE( lrequest );
1279    }
1280}
1281
1282void mpi_start_ ( MPI_Fint *, MPI_Fint * );
1283void mpi_start_( MPI_Fint *request, MPI_Fint *__ierr )
1284{
1285    MPI_Request lrequest = MPI_Request_f2c(*request );
1286    *__ierr = MPI_Start( &lrequest );
1287    *request = MPI_Request_c2f(lrequest);
1288}
1289
1290void mpi_testall_ ( MPI_Fint *, MPI_Fint [], MPI_Fint *,
1291                    MPI_Fint *, MPI_Fint * );
1292void mpi_testall_( MPI_Fint *count, MPI_Fint array_of_requests[],
1293                   MPI_Fint *flag,
1294                   MPI_Fint *array_of_statuses,
1295                   MPI_Fint *__ierr )
1296{
1297    int lflag;
1298    int i;
1299    MPI_Request *lrequest = 0;
1300    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
1301    MPI_Status *c_status = 0;
1302    MPI_Status local_c_status[MPIR_USE_LOCAL_ARRAY];
1303    MPI_Fint   *f_status = 0;
1304
1305    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1306
1307    if ((int)*count > 0) {
1308        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1309            MPIR_FALLOC(lrequest,
1310                        (MPI_Request*)MALLOC(sizeof(MPI_Request)*(int)*count),
1311                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
1312                        "MPI_TESTALL");
1313            MPIR_FALLOC(c_status,
1314                        (MPI_Status*)MALLOC(sizeof(MPI_Status)* (int)*count),
1315                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
1316                        "MPI_TESTTALL");
1317        }
1318        else {
1319            lrequest = local_lrequest;
1320            c_status = local_c_status;
1321        }
1322        for (i=0; i<(int)*count; i++) {
1323            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
1324        }
1325
1326        *__ierr = MPI_Testall((int)*count,lrequest,&lflag,c_status);
1327        /* By checking for lrequest[i] = 0, we handle persistant requests */
1328        for (i=0; i<(int)*count; i++) {
1329             array_of_requests[i] = MPI_Request_c2f( lrequest[i] );
1330        }
1331    }
1332    else
1333        *__ierr = MPI_Testall((int)*count,(MPI_Request *)0,&lflag,c_status);
1334   
1335    *flag = MPIR_TO_FLOG(lflag);
1336    /* We must only copy for those elements that corresponded to non-null
1337       requests, and only if there is a change */
1338    if ( array_of_statuses != MPER_F_MPI_STATUSES_IGNORE )
1339    {
1340        if (lflag) {
1341            f_status = array_of_statuses;
1342            for (i=0; i<(int)*count; i++) {
1343                MPI_Status_c2f( &c_status[i], f_status );
1344                f_status += MPER_F_MPI_STATUS_SIZE;
1345            }
1346        }
1347    }
1348
1349    if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1350        FREE( lrequest );
1351        FREE( c_status );
1352    }
1353}
1354
1355void mpi_testany_ ( MPI_Fint *, MPI_Fint [], MPI_Fint *,
1356                    MPI_Fint *, MPI_Fint *, MPI_Fint * );
1357void mpi_testany_( MPI_Fint *count, MPI_Fint array_of_requests[],
1358                   MPI_Fint *index, MPI_Fint *flag, MPI_Fint *status,
1359                   MPI_Fint *__ierr )
1360{
1361    int lindex;
1362    int lflag;
1363    MPI_Request *lrequest;
1364    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
1365    MPI_Status c_status;
1366    int i;
1367
1368    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1369
1370    if ((int)*count > 0) {
1371        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1372            MPIR_FALLOC(lrequest,
1373                        (MPI_Request*)MALLOC(sizeof(MPI_Request)* (int)*count),
1374                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
1375                        "MPI_TESTANY");
1376        }
1377        else 
1378            lrequest = local_lrequest;
1379
1380        for (i=0; i<(int)*count; i++) 
1381            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
1382
1383    }
1384    else
1385        lrequest = 0;
1386
1387    *__ierr = MPI_Testany((int)*count,lrequest,&lindex,&lflag,&c_status);
1388    if (lindex != -1) {
1389        if (lflag && !*__ierr) {
1390            array_of_requests[lindex] = MPI_Request_c2f(lrequest[lindex]);
1391        }
1392     }
1393    if ((int)*count > MPIR_USE_LOCAL_ARRAY) 
1394        FREE( lrequest );
1395   
1396    *flag = MPIR_TO_FLOG(lflag);
1397    /* See the description of waitany in the standard; the Fortran index ranges
1398       are from 1, not zero */
1399    *index = (MPI_Fint)lindex;
1400    if ((int)*index >= 0)
1401        *index = *index + 1;
1402
1403    if ( status != MPER_F_MPI_STATUS_IGNORE )
1404        MPI_Status_c2f(&c_status, status);
1405}
1406
1407void mpi_test_cancelled_ ( MPI_Fint *, MPI_Fint *, MPI_Fint * );
1408void mpi_test_cancelled_(MPI_Fint *status, MPI_Fint *flag, MPI_Fint *__ierr)
1409{
1410    int lflag;
1411    MPI_Status c_status;
1412
1413    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1414
1415    MPI_Status_f2c(status, &c_status);
1416    *__ierr = MPI_Test_cancelled(&c_status, &lflag);
1417    *flag = MPIR_TO_FLOG(lflag);
1418}
1419
1420void mpi_test_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1421void mpi_test_ ( MPI_Fint *request, MPI_Fint *flag, MPI_Fint *status,
1422                 MPI_Fint *__ierr )
1423{
1424    int        l_flag;
1425    MPI_Status c_status;
1426    MPI_Request lrequest;
1427
1428    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1429
1430    lrequest = MPI_Request_f2c(*request);
1431    *__ierr = MPI_Test( &lrequest, &l_flag, &c_status);
1432    *request = MPI_Request_c2f(lrequest);
1433
1434    *flag = MPIR_TO_FLOG(l_flag);
1435
1436    if ( status != MPER_F_MPI_STATUS_IGNORE )
1437        if (l_flag)
1438            MPI_Status_c2f(&c_status, status);
1439}
1440
1441void mpi_testsome_ ( MPI_Fint *, MPI_Fint [], MPI_Fint *,
1442                     MPI_Fint [], MPI_Fint *, MPI_Fint * );
1443void mpi_testsome_( MPI_Fint *incount, MPI_Fint array_of_requests[],
1444                    MPI_Fint *outcount, MPI_Fint array_of_indices[], 
1445                    MPI_Fint *array_of_statuses, MPI_Fint *__ierr )
1446{
1447    int i,j,found;
1448    int loutcount;
1449    int *l_indices = 0;
1450    int local_l_indices[MPIR_USE_LOCAL_ARRAY];
1451    MPI_Request *lrequest = 0;
1452    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
1453    MPI_Status *c_status = 0;
1454    MPI_Status local_c_status[MPIR_USE_LOCAL_ARRAY];
1455    MPI_Fint   *f_status = 0;
1456
1457    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1458
1459    if ((int)*incount > 0) {
1460        if ((int)*incount > MPIR_USE_LOCAL_ARRAY) {
1461            MPIR_FALLOC(lrequest,
1462                       (MPI_Request*)MALLOC(sizeof(MPI_Request)*(int)*incount),
1463                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
1464                        "MPI_TESTSOME");
1465
1466            MPIR_FALLOC(l_indices,(int*)MALLOC(sizeof(int)* (int)*incount),
1467                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
1468                        "MPI_TESTSOME" );
1469            MPIR_FALLOC(c_status,
1470                        (MPI_Status*)MALLOC(sizeof(MPI_Status)* (int)*incount),
1471                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
1472                        "MPI_TESTSOME" );
1473        }
1474        else {
1475            lrequest = local_lrequest;
1476            l_indices = local_l_indices;
1477            c_status = local_c_status;
1478        }
1479
1480        for (i=0; i<(int)*incount; i++) {
1481            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
1482        }
1483        *__ierr = MPI_Testsome((int)*incount,lrequest,&loutcount,l_indices,
1484                               c_status);
1485
1486        /* By checking for lrequest[l_indices[i] =  0,
1487           we handle persistant requests */
1488        for (i=0; i<(int)*incount; i++) {
1489            if ( i < loutcount ) {
1490                array_of_requests[l_indices[i]]
1491                = MPI_Request_c2f(lrequest[l_indices[i]] );
1492            }
1493            else {
1494                found = 0;
1495                j = 0;
1496                while ( (!found) && (j<loutcount) ) {
1497                    if (l_indices[j++] == i)
1498                        found = 1;
1499                }
1500                if (!found)
1501                    array_of_requests[i] = MPI_Request_c2f( lrequest[i] );
1502            }
1503        }
1504    }
1505    else
1506        *__ierr = MPI_Testsome( (int)*incount, (MPI_Request *)0, &loutcount, 
1507                                l_indices, c_status );
1508
1509    f_status = array_of_statuses;
1510    for (i=0; i<loutcount; i++) {
1511        if ( array_of_statuses != MPER_F_MPI_STATUSES_IGNORE )
1512        {
1513            MPI_Status_c2f(&c_status[i], f_status );
1514            f_status += MPER_F_MPI_STATUS_SIZE;
1515        }
1516        if (l_indices[i] >= 0)
1517            array_of_indices[i] = l_indices[i] + 1;
1518    }
1519    *outcount = (MPI_Fint)loutcount;
1520    if ((int)*incount > MPIR_USE_LOCAL_ARRAY) {
1521        FREE( l_indices );
1522        FREE( lrequest );
1523        FREE( c_status );
1524    }
1525
1526}
1527
1528void mpi_type_commit_ ( MPI_Fint *, MPI_Fint * );
1529void mpi_type_commit_ ( MPI_Fint *datatype, MPI_Fint *__ierr )
1530{
1531    MPI_Datatype ldatatype = MPI_Type_f2c(*datatype);
1532    *__ierr = MPI_Type_commit( &ldatatype );
1533    *datatype = MPI_Type_c2f(ldatatype);
1534}
1535
1536void mpi_type_contiguous_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
1537void mpi_type_contiguous_( MPI_Fint *count, MPI_Fint *old_type,
1538                           MPI_Fint *newtype, MPI_Fint *__ierr )
1539{
1540    MPI_Datatype  ldatatype;
1541
1542    *__ierr = MPI_Type_contiguous((int)*count, MPI_Type_f2c(*old_type),
1543                                  &ldatatype);
1544    *newtype = MPI_Type_c2f(ldatatype);
1545}
1546
1547void mpi_type_extent_ ( MPI_Fint *, MPI_Fint *, MPI_Fint * );
1548void mpi_type_extent_( MPI_Fint *datatype, MPI_Fint *extent, MPI_Fint *__ierr )
1549{
1550    MPI_Aint c_extent;
1551    *__ierr = MPI_Type_extent(MPI_Type_f2c(*datatype), &c_extent);
1552    /* Really should check for truncation, ala mpi_address_ */
1553    *extent = (MPI_Fint)c_extent;
1554}
1555
1556void mpi_type_free_ ( MPI_Fint *, MPI_Fint * );
1557void mpi_type_free_ ( MPI_Fint *datatype, MPI_Fint *__ierr )
1558{
1559    MPI_Datatype ldatatype = MPI_Type_f2c(*datatype);
1560    *__ierr = MPI_Type_free(&ldatatype);
1561    *datatype = MPI_Type_c2f(ldatatype);
1562}
1563
1564void mpi_type_hindexed_ ( MPI_Fint *, MPI_Fint [], MPI_Fint [],
1565                          MPI_Fint *, MPI_Fint *, MPI_Fint * );
1566void mpi_type_hindexed_( MPI_Fint *count, MPI_Fint blocklens[],
1567                         MPI_Fint indices[], MPI_Fint *old_type,
1568                         MPI_Fint *newtype, MPI_Fint *__ierr )
1569{
1570    MPI_Aint     *c_indices;
1571    MPI_Aint     local_c_indices[MPIR_USE_LOCAL_ARRAY];
1572    int          i, mpi_errno;
1573    int          *l_blocklens; 
1574    int          local_l_blocklens[MPIR_USE_LOCAL_ARRAY];
1575    MPI_Datatype ldatatype;
1576    static char  myname[] = "MPI_TYPE_HINDEXED";
1577
1578    if ((int)*count > 0) {
1579        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1580        /* We really only need to do this when
1581           sizeof(MPI_Aint) != sizeof(INTEGER) */
1582            MPIR_FALLOC(c_indices,
1583                        (MPI_Aint *) MALLOC( *count * sizeof(MPI_Aint) ),
1584                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
1585
1586            MPIR_FALLOC(l_blocklens,(int *) MALLOC( *count * sizeof(int) ),
1587                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
1588        }
1589        else {
1590            c_indices = local_c_indices;
1591            l_blocklens = local_l_blocklens;
1592        }
1593
1594        for (i=0; i<(int)*count; i++) {
1595            c_indices[i] = (MPI_Aint) indices[i];
1596            l_blocklens[i] = (int) blocklens[i];
1597        }
1598        *__ierr = MPI_Type_hindexed((int)*count,l_blocklens,c_indices,
1599                                    MPI_Type_f2c(*old_type), &ldatatype);
1600        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1601            FREE( c_indices );
1602            FREE( l_blocklens );
1603        }
1604        *newtype = MPI_Type_c2f(ldatatype);
1605    }
1606    else if ((int)*count == 0) {
1607        *__ierr = MPI_SUCCESS;
1608        *newtype = 0;
1609    }
1610    else {
1611        mpi_errno = MPER_Err_setmsg( MPI_ERR_COUNT, MPIR_ERR_DEFAULT, myname,
1612                                     (char *)0, (char *)0, (int)(*count) );
1613        *__ierr = MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
1614        return;
1615    }
1616}
1617
1618void mpi_type_hvector_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *,
1619                         MPI_Fint *, MPI_Fint *, MPI_Fint * );
1620void mpi_type_hvector_( MPI_Fint *count, MPI_Fint *blocklen, MPI_Fint *stride,
1621                        MPI_Fint *old_type, MPI_Fint *newtype,
1622                        MPI_Fint *__ierr )
1623{
1624    MPI_Aint     c_stride = (MPI_Aint)*stride;
1625    MPI_Datatype ldatatype;
1626
1627    *__ierr = MPI_Type_hvector((int)*count, (int)*blocklen, c_stride,
1628                               MPI_Type_f2c(*old_type),
1629                               &ldatatype);
1630    *newtype = MPI_Type_c2f(ldatatype);
1631}
1632
1633void mpi_type_indexed_ ( MPI_Fint *, MPI_Fint [], MPI_Fint [],
1634                         MPI_Fint *, MPI_Fint *, MPI_Fint * );
1635void mpi_type_indexed_( MPI_Fint *count, MPI_Fint blocklens[],
1636                        MPI_Fint indices[], MPI_Fint *old_type,
1637                        MPI_Fint *newtype, MPI_Fint *__ierr )
1638{
1639    int          i;
1640    int          *l_blocklens = 0;
1641    int          local_l_blocklens[MPIR_USE_LOCAL_ARRAY];
1642    int          *l_indices = 0;
1643    int          local_l_indices[MPIR_USE_LOCAL_ARRAY];
1644    MPI_Datatype ldatatype;
1645    static char myname[] = "MPI_TYPE_INDEXED";
1646
1647    if ((int)*count > 0) {
1648        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1649            MPIR_FALLOC(l_blocklens,(int *) MALLOC( *count * sizeof(int) ),
1650                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
1651
1652            MPIR_FALLOC(l_indices,(int *) MALLOC( *count * sizeof(int) ),
1653                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
1654        }
1655        else {
1656            l_blocklens = local_l_blocklens;
1657            l_indices = local_l_indices;
1658        }
1659
1660        for (i=0; i<(int)*count; i++) {
1661            l_indices[i] = (int)indices[i];
1662            l_blocklens[i] = (int)blocklens[i];
1663         }
1664    }
1665
1666    *__ierr = MPI_Type_indexed((int)*count, l_blocklens, l_indices,
1667                               MPI_Type_f2c(*old_type), 
1668                               &ldatatype);
1669    if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1670        FREE( l_indices );
1671        FREE( l_blocklens );
1672    }
1673    *newtype = MPI_Type_c2f(ldatatype);
1674}
1675
1676void mpi_type_lb_ ( MPI_Fint *, MPI_Fint *, MPI_Fint * );
1677void mpi_type_lb_ ( MPI_Fint *datatype, MPI_Fint *displacement,
1678                    MPI_Fint *__ierr )
1679{
1680    MPI_Aint   c_displacement;
1681
1682    *__ierr = MPI_Type_lb(MPI_Type_f2c(*datatype), &c_displacement);
1683    /* Should check for truncation */
1684    *displacement = (MPI_Fint)c_displacement;
1685}
1686
1687void mpi_type_size_ ( MPI_Fint *, MPI_Fint *, MPI_Fint * );
1688void mpi_type_size_ ( MPI_Fint *datatype, MPI_Fint *size, MPI_Fint *__ierr )
1689{
1690    /* MPI_Aint c_size;*/
1691    int c_size;
1692    *__ierr = MPI_Type_size(MPI_Type_f2c(*datatype), &c_size);
1693    /* Should check for truncation */
1694    *size = (MPI_Fint)c_size;
1695}
1696
1697void mpi_type_struct_ ( MPI_Fint *, MPI_Fint [], MPI_Fint [],
1698                        MPI_Fint [], MPI_Fint *, MPI_Fint * );
1699void mpi_type_struct_( MPI_Fint *count, MPI_Fint blocklens[],
1700                       MPI_Fint indices[], MPI_Fint old_types[],
1701                       MPI_Fint *newtype, MPI_Fint *__ierr )
1702{
1703    MPI_Aint     *c_indices;
1704    MPI_Aint     local_c_indices[MPIR_USE_LOCAL_ARRAY];
1705    MPI_Datatype *l_datatype;
1706    MPI_Datatype local_l_datatype[MPIR_USE_LOCAL_ARRAY];
1707    MPI_Datatype l_newtype;
1708    int          *l_blocklens;
1709    int          local_l_blocklens[MPIR_USE_LOCAL_ARRAY];
1710    int          i;
1711    int          mpi_errno;
1712    static char  myname[] = "MPI_TYPE_STRUCT";
1713   
1714    if ((int)*count > 0) {
1715        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1716        /* Since indices come from MPI_ADDRESS (the FORTRAN VERSION),
1717           they are currently relative to MPIF_F_MPI_BOTTOM. 
1718           Convert them back */
1719            MPIR_FALLOC(c_indices,
1720                        (MPI_Aint *) MALLOC( *count * sizeof(MPI_Aint) ),
1721                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
1722
1723            MPIR_FALLOC(l_blocklens,(int *) MALLOC( *count * sizeof(int) ),
1724                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
1725
1726            MPIR_FALLOC(l_datatype,
1727                        (MPI_Datatype *)
1728                        MALLOC( *count * sizeof(MPI_Datatype) ),
1729                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
1730        }
1731        else {
1732            c_indices = local_c_indices;
1733            l_blocklens = local_l_blocklens;
1734            l_datatype = local_l_datatype;
1735        }
1736
1737        for (i=0; i<(int)*count; i++) {
1738            c_indices[i] = (MPI_Aint) indices[i]/* + (MPI_Aint)MPIR_F_MPI_BOTTOM*/;
1739            l_blocklens[i] = (int) blocklens[i];
1740            l_datatype[i] = MPI_Type_f2c(old_types[i]);
1741        }
1742        *__ierr = MPI_Type_struct((int)*count, l_blocklens, c_indices,
1743                                  l_datatype, &l_newtype);
1744
1745        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1746            FREE( c_indices );
1747            FREE( l_blocklens );
1748            FREE( l_datatype );
1749        }
1750    }
1751    else if ((int)*count == 0) {
1752        *__ierr = MPI_SUCCESS;
1753        *newtype = 0;
1754    }
1755    else {
1756        mpi_errno = MPER_Err_setmsg( MPI_ERR_COUNT, MPIR_ERR_DEFAULT, myname,
1757                                     (char *)0, (char *)0, (int)(*count) );
1758        *__ierr = MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
1759        return;
1760    }
1761    *newtype = MPI_Type_c2f(l_newtype);
1762
1763}
1764
1765void mpi_type_ub_ ( MPI_Fint *, MPI_Fint *, MPI_Fint * );
1766void mpi_type_ub_ ( MPI_Fint *datatype, MPI_Fint *displacement,
1767                    MPI_Fint *__ierr )
1768{
1769    MPI_Aint c_displacement;
1770
1771    *__ierr = MPI_Type_ub(MPI_Type_f2c(*datatype), &c_displacement);
1772    /* Should check for truncation */
1773    *displacement = (MPI_Fint)c_displacement;
1774}
1775
1776void mpi_type_vector_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *,
1777                        MPI_Fint *, MPI_Fint *, MPI_Fint * );
1778void mpi_type_vector_( MPI_Fint *count, MPI_Fint *blocklen, MPI_Fint *stride,
1779                       MPI_Fint *old_type, MPI_Fint *newtype,
1780                       MPI_Fint *__ierr )
1781{
1782    MPI_Datatype l_datatype;
1783
1784    *__ierr = MPI_Type_vector((int)*count, (int)*blocklen, (int)*stride,
1785                              MPI_Type_f2c(*old_type),
1786                              &l_datatype);
1787    *newtype = MPI_Type_c2f(l_datatype);
1788}
1789
1790void mpi_unpack_ ( void *, MPI_Fint *, MPI_Fint *, void *,
1791                           MPI_Fint *, MPI_Fint *, MPI_Fint *,
1792                           MPI_Fint * );
1793void mpi_unpack_ ( void *inbuf, MPI_Fint *insize, MPI_Fint *position,
1794                   void *outbuf, MPI_Fint *outcount, MPI_Fint *type,
1795                   MPI_Fint *comm, MPI_Fint *__ierr )
1796{
1797    int l_position;
1798    l_position = (int)*position;
1799
1800    *__ierr = MPI_Unpack(inbuf, (int)*insize, &l_position,
1801                         MPIR_F_PTR(outbuf), (int)*outcount,
1802                         MPI_Type_f2c(*type), MPI_Comm_f2c(*comm) );
1803    *position = (MPI_Fint)l_position;
1804}
1805
1806void mpi_waitall_ ( MPI_Fint *, MPI_Fint [],
1807                    MPI_Fint *, MPI_Fint *);
1808void mpi_waitall_( MPI_Fint *count, MPI_Fint array_of_requests[],
1809                   MPI_Fint *array_of_statuses, MPI_Fint *__ierr )
1810{
1811    int i;
1812    MPI_Request *lrequest = 0;
1813    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
1814    MPI_Status *c_status = 0;
1815    MPI_Status local_c_status[MPIR_USE_LOCAL_ARRAY];
1816    MPI_Fint   *f_status = 0;
1817
1818    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1819
1820    if ((int)*count > 0) {
1821        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1822            MPIR_FALLOC(lrequest,(MPI_Request*)MALLOC(sizeof(MPI_Request) * 
1823                        (int)*count), MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, 
1824                        "MPI_WAITALL" );
1825
1826            MPIR_FALLOC(c_status,(MPI_Status*)MALLOC(sizeof(MPI_Status) * 
1827                        (int)*count), MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, 
1828                        "MPI_WAITALL" );
1829        }
1830        else {
1831            lrequest = local_lrequest;
1832            c_status = local_c_status;
1833        }
1834
1835        for (i=0; i<(int)*count; i++) {
1836            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
1837        }
1838
1839        *__ierr = MPI_Waitall((int)*count,lrequest,c_status);
1840        /* By checking for lrequest[i] = 0, we handle persistant requests */
1841        for (i=0; i<(int)*count; i++) {
1842                array_of_requests[i] = MPI_Request_c2f( lrequest[i] );
1843        }
1844    }
1845    else 
1846        *__ierr = MPI_Waitall((int)*count,(MPI_Request *)0, c_status );
1847
1848    if ( array_of_statuses != MPER_F_MPI_STATUSES_IGNORE )
1849    {
1850        f_status = array_of_statuses;
1851        for (i=0; i<(int)*count; i++) {
1852            MPI_Status_c2f(&(c_status[i]), f_status );
1853            f_status += MPER_F_MPI_STATUS_SIZE;
1854        }
1855    }
1856   
1857    if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1858        FREE( lrequest );
1859        FREE( c_status );
1860    }
1861}
1862
1863void mpi_waitany_ ( MPI_Fint *, MPI_Fint [], MPI_Fint *,
1864                    MPI_Fint *, MPI_Fint * );
1865void mpi_waitany_( MPI_Fint *count, MPI_Fint array_of_requests[],
1866                   MPI_Fint *index, MPI_Fint *status, MPI_Fint *__ierr )
1867{
1868
1869    int lindex;
1870    MPI_Request *lrequest;
1871    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
1872    MPI_Status c_status;
1873    int i;
1874
1875    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1876
1877    if ((int)*count > 0) {
1878        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1879            MPIR_FALLOC(lrequest,
1880                        (MPI_Request*)
1881                        MALLOC(sizeof(MPI_Request) * (int)*count),
1882                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, 
1883                        "MPI_WAITANY" );
1884        }
1885        else 
1886            lrequest = local_lrequest;
1887
1888        for (i=0; i<(int)*count; i++) 
1889            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
1890    }
1891    else
1892        lrequest = 0;
1893
1894    *__ierr = MPI_Waitany((int)*count,lrequest,&lindex,&c_status);
1895
1896    if (lindex != -1) {
1897        if (!*__ierr) {
1898            array_of_requests[lindex] = MPI_Request_c2f(lrequest[lindex]);
1899        }
1900    }
1901
1902   if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
1903        FREE( lrequest );
1904    }
1905
1906    /* See the description of waitany in the standard; the Fortran index ranges
1907       are from 1, not zero */
1908    *index = (MPI_Fint)lindex;
1909    if ((int)*index >= 0) *index = (MPI_Fint)*index + 1;
1910    if ( status != MPER_F_MPI_STATUS_IGNORE )
1911        MPI_Status_c2f(&c_status, status);
1912}
1913
1914void mpi_wait_ ( MPI_Fint *, MPI_Fint *, MPI_Fint * );
1915void mpi_wait_ ( MPI_Fint *request, MPI_Fint *status, MPI_Fint *__ierr )
1916{
1917    MPI_Request lrequest;
1918    MPI_Status c_status;
1919
1920    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1921
1922    lrequest = MPI_Request_f2c(*request);
1923    *__ierr = MPI_Wait(&lrequest, &c_status);
1924    *request = MPI_Request_c2f(lrequest);
1925
1926    if ( status != MPER_F_MPI_STATUS_IGNORE )
1927        MPI_Status_c2f(&c_status, status);
1928}
1929
1930void mpi_waitsome_ ( MPI_Fint *, MPI_Fint [], MPI_Fint *,
1931                     MPI_Fint [], MPI_Fint *, MPI_Fint * );
1932void mpi_waitsome_( MPI_Fint *incount, MPI_Fint array_of_requests[],
1933                    MPI_Fint *outcount, MPI_Fint array_of_indices[], 
1934                    MPI_Fint *array_of_statuses,
1935                    MPI_Fint *__ierr )
1936{
1937    int i,j,found;
1938    int loutcount;
1939    int *l_indices = 0;
1940    int local_l_indices[MPIR_USE_LOCAL_ARRAY];
1941    MPI_Request *lrequest = 0;
1942    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
1943    MPI_Status *c_status = 0;
1944    MPI_Status local_c_status[MPIR_USE_LOCAL_ARRAY];
1945    MPI_Fint   *f_status = 0;
1946
1947    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
1948
1949    if ((int)*incount > 0) {
1950        if ((int)*incount > MPIR_USE_LOCAL_ARRAY) {
1951            MPIR_FALLOC(lrequest,
1952                        (MPI_Request*)
1953                        MALLOC(sizeof(MPI_Request)* (int)*incount),
1954                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, 
1955                        "MPI_WAITSOME" );
1956
1957            MPIR_FALLOC(l_indices,(int*)MALLOC(sizeof(int) * (int)*incount),
1958                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, 
1959                        "MPI_WAITSOME" );
1960
1961            MPIR_FALLOC(c_status,
1962                        (MPI_Status*)
1963                        MALLOC(sizeof(MPI_Status) * (int)*incount),
1964                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, 
1965                        "MPI_WAITSOME" );
1966        }
1967        else {
1968            lrequest = local_lrequest;
1969            l_indices = local_l_indices;
1970            c_status = local_c_status;
1971        }
1972
1973        for (i=0; i<(int)*incount; i++) 
1974            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
1975
1976        *__ierr = MPI_Waitsome((int)*incount,lrequest,&loutcount,l_indices,
1977                               c_status);
1978
1979/* By checking for lrequest[l_indices[i]] = 0,
1980   we handle persistant requests */
1981        for (i=0; i<(int)*incount; i++) {
1982            if ( i < loutcount) {
1983                if (l_indices[i] >= 0) {
1984                    array_of_requests[l_indices[i]]
1985                    = MPI_Request_c2f( lrequest[l_indices[i]] );
1986                }
1987            }
1988            else {
1989                found = 0;
1990                j = 0;
1991                while ( (!found) && (j<loutcount) ) {
1992                    if (l_indices[j++] == i)
1993                        found = 1;
1994                }
1995                if (!found)
1996                    array_of_requests[i] = MPI_Request_c2f( lrequest[i] );
1997            }
1998        }
1999    }
2000    else 
2001        *__ierr = MPI_Waitsome( (int)*incount, (MPI_Request *)0, &loutcount,
2002                                l_indices, c_status );
2003
2004    f_status = array_of_statuses;
2005    for (i=0; i<loutcount; i++) {
2006        if ( array_of_statuses != MPER_F_MPI_STATUSES_IGNORE )
2007        {
2008            MPI_Status_c2f( &c_status[i], f_status );
2009            f_status += MPER_F_MPI_STATUS_SIZE;
2010        }
2011        if (l_indices[i] >= 0)
2012            array_of_indices[i] = l_indices[i] + 1;
2013    }
2014    *outcount = (MPI_Fint)loutcount;
2015    if ((int)*incount > MPIR_USE_LOCAL_ARRAY) {
2016        FREE( l_indices );
2017        FREE( lrequest );
2018        FREE( c_status );
2019    }
2020}
2021
2022void mpi_allgather_ ( void *, MPI_Fint *, MPI_Fint *, void *,
2023                              MPI_Fint *, MPI_Fint *, MPI_Fint *,
2024                              MPI_Fint * );
2025void mpi_allgather_ ( void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype,
2026                      void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype,
2027                      MPI_Fint *comm, MPI_Fint *__ierr )
2028{
2029    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2030    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2031
2032    *__ierr = MPI_Allgather(MPIR_F_PTR(sendbuf), (int)*sendcount,
2033                            MPI_Type_f2c(*sendtype),
2034                            MPIR_F_PTR(recvbuf),
2035                            (int)*recvcount,
2036                            MPI_Type_f2c(*recvtype),
2037                            MPI_Comm_f2c(*comm));
2038}
2039
2040void mpi_allgatherv_ ( void *, MPI_Fint *, MPI_Fint *,
2041                       void *, MPI_Fint *, MPI_Fint *,
2042                       MPI_Fint *, MPI_Fint *, MPI_Fint * );
2043void mpi_allgatherv_ ( void *sendbuf, MPI_Fint *sendcount,  MPI_Fint *sendtype,
2044                       void *recvbuf, MPI_Fint *recvcounts, MPI_Fint *displs,
2045                       MPI_Fint *recvtype, MPI_Fint *comm, MPI_Fint *__ierr )
2046{
2047    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2048    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2049
2050    if (sizeof(MPI_Fint) == sizeof(int))
2051        *__ierr = MPI_Allgatherv(MPIR_F_PTR(sendbuf), *sendcount,
2052                                 MPI_Type_f2c(*sendtype),
2053                                 MPIR_F_PTR(recvbuf), recvcounts,
2054                                 displs, MPI_Type_f2c(*recvtype),
2055                                 MPI_Comm_f2c(*comm));
2056    else {
2057        int size;
2058        int *l_recvcounts;
2059        int *l_displs;
2060        int i;
2061
2062        MPI_Comm_size(MPI_Comm_f2c(*comm), &size);
2063
2064        MPIR_FALLOC(l_recvcounts,(int*)MALLOC(sizeof(int)* size),
2065                    MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2066                    "MPI_Allgatherv");
2067        MPIR_FALLOC(l_displs,(int*)MALLOC(sizeof(int)* size),
2068                    MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2069                    "MPI_Allgatherv");
2070        for (i=0; i<size; i++) {
2071            l_recvcounts[i] = (int)recvcounts[i];
2072            l_displs[i] = (int)displs[i];
2073        }
2074
2075        *__ierr = MPI_Allgatherv(MPIR_F_PTR(sendbuf), (int)*sendcount,
2076                                 MPI_Type_f2c(*sendtype),
2077                                 MPIR_F_PTR(recvbuf), l_recvcounts,
2078                                 l_displs, MPI_Type_f2c(*recvtype),
2079                                 MPI_Comm_f2c(*comm));
2080        FREE( l_recvcounts );
2081        FREE( l_displs );
2082    }
2083}
2084
2085void mpi_allreduce_ ( void *, void *, MPI_Fint *, MPI_Fint *,
2086                      MPI_Fint *, MPI_Fint *, MPI_Fint * );
2087void mpi_allreduce_ ( void *sendbuf, void *recvbuf, MPI_Fint *count,
2088                      MPI_Fint *datatype, MPI_Fint *op, MPI_Fint *comm,
2089                      MPI_Fint *__ierr )
2090{
2091    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2092    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2093
2094    *__ierr = MPI_Allreduce(MPIR_F_PTR(sendbuf),MPIR_F_PTR(recvbuf),
2095                            (int)*count, MPI_Type_f2c(*datatype),
2096                            MPI_Op_f2c(*op), MPI_Comm_f2c(*comm) );
2097}
2098
2099
2100void mpi_alltoall_ ( void *, MPI_Fint *, MPI_Fint *, void *,
2101                             MPI_Fint *, MPI_Fint *, MPI_Fint *,
2102                             MPI_Fint * );
2103void mpi_alltoall_( void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype,
2104                    void *recvbuf, MPI_Fint *recvcnt, MPI_Fint *recvtype,
2105                    MPI_Fint *comm, MPI_Fint *__ierr )
2106{
2107    *__ierr = MPI_Alltoall(MPIR_F_PTR(sendbuf), (int)*sendcount,
2108                           MPI_Type_f2c(*sendtype), MPIR_F_PTR(recvbuf),
2109                           (int)*recvcnt, MPI_Type_f2c(*recvtype),
2110                           MPI_Comm_f2c(*comm) );
2111}
2112
2113void mpi_alltoallv_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *, 
2114                      void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
2115                      MPI_Fint *, MPI_Fint * );
2116void mpi_alltoallv_ ( void *sendbuf, MPI_Fint *sendcnts,
2117                      MPI_Fint *sdispls, MPI_Fint *sendtype,
2118                      void *recvbuf, MPI_Fint *recvcnts,
2119                      MPI_Fint *rdispls, MPI_Fint *recvtype,
2120                      MPI_Fint *comm, MPI_Fint *__ierr )
2121{
2122    if (sizeof(MPI_Fint) == sizeof(int))
2123    *__ierr = MPI_Alltoallv(MPIR_F_PTR(sendbuf), sendcnts,
2124                                sdispls, MPI_Type_f2c(*sendtype),
2125                    MPIR_F_PTR(recvbuf), recvcnts,
2126                                rdispls, MPI_Type_f2c(*recvtype),
2127                    MPI_Comm_f2c(*comm) );
2128    else {
2129
2130        int *l_sendcnts;
2131        int *l_sdispls;
2132        int *l_recvcnts;
2133        int *l_rdispls;
2134    int size;
2135    int i;
2136
2137    MPI_Comm_size(MPI_Comm_f2c(*comm), &size);
2138
2139    MPIR_FALLOC(l_sendcnts,(int*)MALLOC(sizeof(int)* size),
2140            MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2141            "MPI_Alltoallv");
2142    MPIR_FALLOC(l_sdispls,(int*)MALLOC(sizeof(int)* size),
2143            MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2144            "MPI_Alltoallv");
2145    MPIR_FALLOC(l_recvcnts,(int*)MALLOC(sizeof(int)* size),
2146            MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2147            "MPI_Alltoallv");
2148    MPIR_FALLOC(l_rdispls,(int*)MALLOC(sizeof(int)* size),
2149            MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2150            "MPI_Alltoallv");
2151
2152    for (i=0; i<size; i++) {
2153        l_sendcnts[i] = (int)sendcnts[i];
2154        l_sdispls[i] = (int)sdispls[i];
2155        l_recvcnts[i] = (int)recvcnts[i];
2156        l_rdispls[i] = (int)rdispls[i];
2157    }
2158    *__ierr = MPI_Alltoallv(MPIR_F_PTR(sendbuf), l_sendcnts,
2159                                l_sdispls, MPI_Type_f2c(*sendtype),
2160                    MPIR_F_PTR(recvbuf), l_recvcnts,
2161                                l_rdispls, MPI_Type_f2c(*recvtype),
2162                    MPI_Comm_f2c(*comm) );
2163    FREE( l_sendcnts);
2164    FREE( l_sdispls );
2165    FREE( l_recvcnts);
2166    FREE( l_rdispls );
2167    }
2168}
2169
2170void mpi_barrier_ ( MPI_Fint *, MPI_Fint * );
2171void mpi_barrier_ ( MPI_Fint *comm, MPI_Fint *__ierr )
2172{
2173    *__ierr = MPI_Barrier( MPI_Comm_f2c(*comm) );
2174}
2175
2176void mpi_bcast_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
2177                          MPI_Fint *, MPI_Fint * );
2178void mpi_bcast_ ( void *buffer, MPI_Fint *count, MPI_Fint *datatype,
2179                  MPI_Fint *root, MPI_Fint *comm, MPI_Fint *__ierr )
2180{
2181    *__ierr = MPI_Bcast(MPIR_F_PTR(buffer), (int)*count,
2182                        MPI_Type_f2c(*datatype), (int)*root,
2183                        MPI_Comm_f2c(*comm));
2184}
2185
2186void mpi_gather_ ( void *, MPI_Fint *, MPI_Fint *,
2187                   void *, MPI_Fint *, MPI_Fint *,
2188                   MPI_Fint *, MPI_Fint *, MPI_Fint * );
2189void mpi_gather_ ( void *sendbuf, MPI_Fint *sendcnt, MPI_Fint *sendtype,
2190                   void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype,
2191                   MPI_Fint *root, MPI_Fint *comm, MPI_Fint *__ierr )
2192{
2193    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2194    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2195
2196    *__ierr = MPI_Gather(MPIR_F_PTR(sendbuf), (int)*sendcnt,
2197                         MPI_Type_f2c(*sendtype), MPIR_F_PTR(recvbuf),
2198                         (int)*recvcount, MPI_Type_f2c(*recvtype),
2199                         (int)*root, MPI_Comm_f2c(*comm));
2200}
2201
2202void mpi_gatherv_ ( void *, MPI_Fint *, MPI_Fint *,
2203                    void *, MPI_Fint *, MPI_Fint *,
2204                    MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
2205void mpi_gatherv_ ( void *sendbuf, MPI_Fint *sendcnt, MPI_Fint *sendtype,
2206                    void *recvbuf, MPI_Fint *recvcnts, MPI_Fint *displs,
2207                    MPI_Fint *recvtype, MPI_Fint *root, MPI_Fint *comm,
2208                    MPI_Fint *__ierr )
2209{
2210    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2211    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2212
2213    if (sizeof(MPI_Fint) == sizeof(int))
2214        *__ierr = MPI_Gatherv(MPIR_F_PTR(sendbuf), *sendcnt,
2215                              MPI_Type_f2c(*sendtype), MPIR_F_PTR(recvbuf),
2216                              recvcnts, displs,
2217                              MPI_Type_f2c(*recvtype), *root,
2218                              MPI_Comm_f2c(*comm));
2219    else {
2220    int size;
2221        int *l_recvcnts;
2222        int *l_displs;
2223    int i;
2224
2225    MPI_Comm_size(MPI_Comm_f2c(*comm), &size);
2226
2227    MPIR_FALLOC(l_recvcnts,(int*)MALLOC(sizeof(int)* size),
2228                MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2229                "MPI_Gatherv");
2230    MPIR_FALLOC(l_displs,(int*)MALLOC(sizeof(int)* size),
2231                MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2232                "MPI_Gatherv");
2233    for (i=0; i<size; i++) {
2234        l_recvcnts[i] = (int)recvcnts[i];
2235        l_displs[i] = (int)displs[i];
2236    }
2237        *__ierr = MPI_Gatherv(MPIR_F_PTR(sendbuf), (int)*sendcnt,
2238                              MPI_Type_f2c(*sendtype), MPIR_F_PTR(recvbuf),
2239                              l_recvcnts, l_displs,
2240                              MPI_Type_f2c(*recvtype), (int)*root,
2241                              MPI_Comm_f2c(*comm));
2242    FREE( l_recvcnts );
2243    FREE( l_displs );
2244    }
2245
2246}
2247
2248#ifdef FORTRAN_SPECIAL_FUNCTION_PTR
2249void mpi_op_create_( MPI_User_function **, MPI_Fint *, MPI_Fint *, MPI_Fint * );
2250#else
2251void mpi_op_create_( MPI_User_function *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
2252#endif
2253
2254void mpi_op_create_(
2255#ifdef FORTRAN_SPECIAL_FUNCTION_PTR
2256        MPI_User_function **function,
2257#else
2258        MPI_User_function *function,
2259#endif
2260        MPI_Fint *commute, MPI_Fint *op, MPI_Fint *__ierr)
2261{
2262
2263    MPI_Op l_op;
2264
2265    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2266
2267#ifdef FORTRAN_SPECIAL_FUNCTION_PTR
2268    *__ierr = MPI_Op_create(*function,MPIR_FROM_FLOG((int)*commute),
2269                            &l_op);
2270#elif defined(_TWO_WORD_FCD)
2271    int tmp = *commute;
2272    *__ierr = MPI_Op_create(*function,MPIR_FROM_FLOG(tmp),&l_op);
2273
2274#else
2275    *__ierr = MPI_Op_create(function,MPIR_FROM_FLOG((int)*commute),
2276                            &l_op);
2277#endif
2278    *op = MPI_Op_c2f(l_op);
2279}
2280
2281void mpi_op_free_ ( MPI_Fint *, MPI_Fint * );
2282void mpi_op_free_( MPI_Fint *op, MPI_Fint *__ierr )
2283{
2284    MPI_Op l_op = MPI_Op_f2c(*op);
2285    *__ierr = MPI_Op_free(&l_op);
2286}
2287
2288void mpi_reduce_scatter_ ( void *, void *, MPI_Fint *, MPI_Fint *,
2289                           MPI_Fint *, MPI_Fint *, MPI_Fint * );
2290void mpi_reduce_scatter_ ( void *sendbuf, void *recvbuf,
2291                           MPI_Fint *recvcnts, MPI_Fint *datatype,
2292                           MPI_Fint *op, MPI_Fint *comm, MPI_Fint *__ierr )
2293{
2294    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2295    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2296
2297    if (sizeof(MPI_Fint) == sizeof(int))
2298        *__ierr = MPI_Reduce_scatter(MPIR_F_PTR(sendbuf),
2299                                     MPIR_F_PTR(recvbuf), recvcnts,
2300                                     MPI_Type_f2c(*datatype), MPI_Op_f2c(*op),
2301                                     MPI_Comm_f2c(*comm));
2302    else {
2303        int size;
2304        int *l_recvcnts;
2305    int i;
2306
2307    MPI_Comm_size(MPI_Comm_f2c(*comm), &size);
2308
2309    MPIR_FALLOC(l_recvcnts,(int*)MALLOC(sizeof(int)* size),
2310            MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2311            "MPI_Reduce_scatter");
2312    for (i=0; i<size; i++)
2313        l_recvcnts[i] = (int)recvcnts[i];
2314
2315        *__ierr = MPI_Reduce_scatter(MPIR_F_PTR(sendbuf),
2316                                     MPIR_F_PTR(recvbuf), l_recvcnts,
2317                                     MPI_Type_f2c(*datatype), MPI_Op_f2c(*op),
2318                                     MPI_Comm_f2c(*comm));
2319    FREE( l_recvcnts);
2320    }
2321
2322}
2323
2324void mpi_reduce_ ( void *, void *, MPI_Fint *, MPI_Fint *,
2325                   MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
2326void mpi_reduce_ ( void *sendbuf, void *recvbuf, MPI_Fint *count,
2327                   MPI_Fint *datatype, MPI_Fint *op, MPI_Fint *root,
2328                   MPI_Fint *comm, MPI_Fint *__ierr )
2329{
2330    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2331    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2332
2333    *__ierr = MPI_Reduce(MPIR_F_PTR(sendbuf), MPIR_F_PTR(recvbuf),
2334                         (int)*count, MPI_Type_f2c(*datatype),
2335                         MPI_Op_f2c(*op), (int)*root,
2336                         MPI_Comm_f2c(*comm));
2337}
2338
2339void mpi_scan_ ( void *, void *, MPI_Fint *, MPI_Fint *,
2340                 MPI_Fint *, MPI_Fint *, MPI_Fint * );
2341void mpi_scan_ ( void *sendbuf, void *recvbuf, MPI_Fint *count,
2342                 MPI_Fint *datatype, MPI_Fint *op, MPI_Fint *comm,
2343                 MPI_Fint *__ierr )
2344{
2345    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2346    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2347
2348    *__ierr = MPI_Scan(MPIR_F_PTR(sendbuf), MPIR_F_PTR(recvbuf),
2349                       (int)*count, MPI_Type_f2c(*datatype),
2350                       MPI_Op_f2c(*op), MPI_Comm_f2c(*comm));
2351}
2352
2353void mpi_scatter_ ( void *, MPI_Fint *, MPI_Fint *,
2354                    void *, MPI_Fint *, MPI_Fint *,
2355                    MPI_Fint *, MPI_Fint *, MPI_Fint * );
2356void mpi_scatter_ ( void *sendbuf, MPI_Fint *sendcnt, MPI_Fint *sendtype,
2357                    void *recvbuf, MPI_Fint *recvcnt, MPI_Fint *recvtype,
2358                    MPI_Fint *root, MPI_Fint *comm, MPI_Fint *__ierr )
2359{
2360    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2361    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2362
2363    *__ierr = MPI_Scatter(MPIR_F_PTR(sendbuf), (int)*sendcnt,
2364                          MPI_Type_f2c(*sendtype), MPIR_F_PTR(recvbuf),
2365                          (int)*recvcnt, MPI_Type_f2c(*recvtype),
2366                          (int)*root, MPI_Comm_f2c(*comm));
2367}
2368
2369void mpi_scatterv_ ( void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
2370                     void *, MPI_Fint *, MPI_Fint *, MPI_Fint *,
2371                     MPI_Fint *, MPI_Fint * );
2372void mpi_scatterv_ ( void *sendbuf, MPI_Fint *sendcnts,
2373                     MPI_Fint *displs, MPI_Fint *sendtype,
2374                     void *recvbuf, MPI_Fint *recvcnt, 
2375                     MPI_Fint *recvtype, MPI_Fint *root,
2376                     MPI_Fint *comm, MPI_Fint *__ierr )
2377{
2378    if ( !MPER_F_Initialized ) { mper_fconsts_init(); MPER_F_Initialized = 1; }
2379    if ( sendbuf == MPER_F_MPI_IN_PLACE ) sendbuf = MPI_IN_PLACE;
2380
2381    if (sizeof(MPI_Fint) == sizeof(int))
2382        *__ierr = MPI_Scatterv(MPIR_F_PTR(sendbuf), sendcnts, displs,
2383                               MPI_Type_f2c(*sendtype), MPIR_F_PTR(recvbuf),
2384                               *recvcnt, MPI_Type_f2c(*recvtype),
2385                               *root, MPI_Comm_f2c(*comm) );
2386    else {
2387    int size;
2388        int *l_sendcnts;
2389        int *l_displs;
2390    int i;
2391
2392    MPI_Comm_size(MPI_Comm_f2c(*comm), &size);
2393
2394    MPIR_FALLOC(l_sendcnts,(int*)MALLOC(sizeof(int)* size),
2395                MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2396               "MPI_Scatterv");
2397    MPIR_FALLOC(l_displs,(int*)MALLOC(sizeof(int)* size),
2398                MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
2399                "MPI_Scatterv");
2400    for (i=0; i<size; i++) {
2401        l_sendcnts[i] = (int)sendcnts[i];
2402        l_displs[i] = (int)displs[i];
2403    }
2404
2405        *__ierr = MPI_Scatterv(MPIR_F_PTR(sendbuf), l_sendcnts, l_displs,
2406                               MPI_Type_f2c(*sendtype), MPIR_F_PTR(recvbuf),
2407                               (int)*recvcnt, MPI_Type_f2c(*recvtype),
2408                               (int)*root, MPI_Comm_f2c(*comm) );
2409        FREE( l_sendcnts);
2410        FREE( l_displs);
2411    }
2412}
2413
2414void mpi_finalize_ ( int * );
2415void mpi_finalize_( ierr )
2416int *ierr; 
2417{
2418    *ierr = MPI_Finalize();
2419}
Note: See TracBrowser for help on using the browser.