Actual source code: zoptions.c
1: /*$Id: zoptions.c,v 1.82 2001/08/10 16:50:43 balay Exp $*/
3: /*
4: This file contains Fortran stubs for Options routines.
5: These are not generated automatically since they require passing strings
6: between Fortran and C.
7: */
9: #include src/fortran/custom/zpetsc.h
10: #include petscsys.h
11: extern PetscTruth PetscBeganMPI;
13: #ifdef PETSC_HAVE_FORTRAN_CAPS
14: #define petscoptionsgetlogical_ PETSCOPTIONSGETLOGICAL
15: #define petscgetarchtype_ PETSCGETARCHTYPE
16: #define petscoptionsgetintarray_ PETSCOPTIONSGETINTARRAY
17: #define petscoptionssetvalue_ PETSCOPTIONSSETVALUE
18: #define petscoptionsclearvalue_ PETSCOPTIONSCLEARVALUE
19: #define petscoptionshasname_ PETSCOPTIONSHASNAME
20: #define petscoptionsgetint_ PETSCOPTIONSGETINT
21: #define petscoptionsgetreal_ PETSCOPTIONSGETREAL
22: #define petscoptionsgetrealarray_ PETSCOPTIONSGETREALARRAY
23: #define petscoptionsgetstring_ PETSCOPTIONSGETSTRING
24: #define petscgetprogramname PETSCGETPROGRAMNAME
25: #define petscoptionsinsertfile_ PETSCOPTIONSINSERTFILE
26: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
27: #define petscoptionsgetlogical_ petscoptionsgetlogical
28: #define petscgetarchtype_ petscgetarchtype
29: #define petscoptionssetvalue_ petscoptionssetvalue
30: #define petscoptionsclearvalue_ petscoptionsclearvalue
31: #define petscoptionshasname_ petscoptionshasname
32: #define petscoptionsgetint_ petscoptionsgetint
33: #define petscoptionsgetreal_ petscoptionsgetreal
34: #define petscoptionsgetrealarray_ petscoptionsgetrealarray
35: #define petscoptionsgetstring_ petscoptionsgetstring
36: #define petscoptionsgetintarray_ petscoptionsgetintarray
37: #define petscgetprogramname_ petscgetprogramname
38: #define petscoptionsinsertfile_ petscoptionsinsertfile
39: #endif
41: EXTERN_C_BEGIN
43: /* ---------------------------------------------------------------------*/
45: void PETSC_STDCALL petscoptionsinsertfile_(CHAR file PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
46: {
47: char *c1;
49: FIXCHAR(file,len,c1);
50: *PetscOptionsInsertFile(c1);
51: FREECHAR(file,c1);
52: }
54: void PETSC_STDCALL petscoptionssetvalue_(CHAR name PETSC_MIXED_LEN(len1),CHAR value PETSC_MIXED_LEN(len2),
55: int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
56: {
57: char *c1,*c2;
59: FIXCHAR(name,len1,c1);
60: FIXCHAR(value,len2,c2);
61: *PetscOptionsSetValue(c1,c2);
62: FREECHAR(name,c1);
63: FREECHAR(value,c2);
64: }
66: void PETSC_STDCALL petscoptionsclearvalue_(CHAR name PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
67: {
68: char *c1;
70: FIXCHAR(name,len,c1);
71: *PetscOptionsClearValue(c1);
72: FREECHAR(name,c1);
73: }
75: void PETSC_STDCALL petscoptionshasname_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
76: PetscTruth *flg,int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
77: {
78: char *c1,*c2;
80: FIXCHAR(pre,len1,c1);
81: FIXCHAR(name,len2,c2);
82: *PetscOptionsHasName(c1,c2,flg);
83: FREECHAR(pre,c1);
84: FREECHAR(name,c2);
85: }
87: void PETSC_STDCALL petscoptionsgetint_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
88: int *ivalue,PetscTruth *flg,int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
89: {
90: char *c1,*c2;
92: FIXCHAR(pre,len1,c1);
93: FIXCHAR(name,len2,c2);
94: *PetscOptionsGetInt(c1,c2,ivalue,flg);
95: FREECHAR(pre,c1);
96: FREECHAR(name,c2);
97: }
99: void PETSC_STDCALL petscoptionsgetlogical_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
100: PetscTruth *ivalue,PetscTruth *flg,int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
101: {
102: char *c1,*c2;
104: FIXCHAR(pre,len1,c1);
105: FIXCHAR(name,len2,c2);
106: *PetscOptionsGetLogical(c1,c2,ivalue,flg);
107: FREECHAR(pre,c1);
108: FREECHAR(name,c2);
109: }
111: void PETSC_STDCALL petscoptionsgetreal_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
112: PetscReal *dvalue,PetscTruth *flg,int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
113: {
114: char *c1,*c2;
116: FIXCHAR(pre,len1,c1);
117: FIXCHAR(name,len2,c2);
118: *PetscOptionsGetReal(c1,c2,dvalue,flg);
119: FREECHAR(pre,c1);
120: FREECHAR(name,c2);
121: }
123: void PETSC_STDCALL petscoptionsgetrealarray_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
124: PetscReal *dvalue,int *nmax,PetscTruth *flg,int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
125: {
126: char *c1,*c2;
128: FIXCHAR(pre,len1,c1);
129: FIXCHAR(name,len2,c2);
130: *PetscOptionsGetRealArray(c1,c2,dvalue,nmax,flg);
131: FREECHAR(pre,c1);
132: FREECHAR(name,c2);
133: }
135: void PETSC_STDCALL petscoptionsgetintarray_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
136: int *dvalue,int *nmax,PetscTruth *flg,int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
137: {
138: char *c1,*c2;
140: FIXCHAR(pre,len1,c1);
141: FIXCHAR(name,len2,c2);
142: *PetscOptionsGetIntArray(c1,c2,dvalue,nmax,flg);
143: FREECHAR(pre,c1);
144: FREECHAR(name,c2);
145: }
147: void PETSC_STDCALL petscoptionsgetstring_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
148: CHAR string PETSC_MIXED_LEN(len),PetscTruth *flg,
149: int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2) PETSC_END_LEN(len))
150: {
151: char *c1,*c2,*c3;
152: int len3;
154: FIXCHAR(pre,len1,c1);
155: FIXCHAR(name,len2,c2);
156: #if defined(PETSC_USES_CPTOFCD)
157: c3 = _fcdtocp(string);
158: len3 = _fcdlen(string) - 1;
159: #else
160: c3 = string;
161: len3 = len - 1;
162: #endif
164: *PetscOptionsGetString(c1,c2,c3,len3,flg);
165: FREECHAR(pre,c1);
166: FREECHAR(name,c2);
167: }
169: void PETSC_STDCALL petscgetarchtype_(CHAR str PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
170: {
171: #if defined(PETSC_USES_CPTOFCD)
172: char *tstr = _fcdtocp(str);
173: int len1 = _fcdlen(str);
174: *PetscGetArchType(tstr,len1);
175: #else
176: *PetscGetArchType(str,len);
177: #endif
178: }
180: void PETSC_STDCALL petscgetprogramname_(CHAR name PETSC_MIXED_LEN(len_in),int *ierr PETSC_END_LEN(len_in))
181: {
182: char *tmp;
183: int len;
184: #if defined(PETSC_USES_CPTOFCD)
185: tmp = _fcdtocp(name);
186: len = _fcdlen(name) - 1;
187: #else
188: tmp = name;
189: len = len_in - 1;
190: #endif
191: *PetscGetProgramName(tmp,len);
192: }
194: EXTERN_C_END
196: /*
197: This is code for translating PETSc memory addresses to integer offsets
198: for Fortran.
199: */
200: char *PETSC_NULL_CHARACTER_Fortran;
201: void *PETSC_NULL_INTEGER_Fortran;
202: void *PETSC_NULL_Fortran;
203: void *PETSC_NULL_SCALAR_Fortran;
204: void *PETSC_NULL_DOUBLE_Fortran;
205: void *PETSC_NULL_REAL_Fortran;
206: EXTERN_C_BEGIN
207: void (*PETSC_NULL_FUNCTION_Fortran)(void);
208: EXTERN_C_END
209: long PetscIntAddressToFortran(int *base,int *addr)
210: {
211: unsigned long tmp1 = (unsigned long) base,tmp2 = 0;
212: unsigned long tmp3 = (unsigned long) addr;
213: long itmp2;
215: #if !defined(PETSC_HAVE_CRAY90_POINTER)
216: if (tmp3 > tmp1) {
217: tmp2 = (tmp3 - tmp1)/sizeof(int);
218: itmp2 = (long) tmp2;
219: } else {
220: tmp2 = (tmp1 - tmp3)/sizeof(int);
221: itmp2 = -((long) tmp2);
222: }
223: #else
224: if (tmp3 > tmp1) {
225: tmp2 = (tmp3 - tmp1);
226: itmp2 = (long) tmp2;
227: } else {
228: tmp2 = (tmp1 - tmp3);
229: itmp2 = -((long) tmp2);
230: }
231: #endif
233: if (base + itmp2 != addr) {
234: (*PetscErrorPrintf)("PetscIntAddressToFortran:C and Fortran arrays aren");
235: (*PetscErrorPrintf)("not commonly aligned or are too far apart to be indexed n");
236: (*PetscErrorPrintf)("by an integer. Locations: C %ld Fortran %ldn",tmp1,tmp3);
237: MPI_Abort(PETSC_COMM_WORLD,1);
238: }
239: return itmp2;
240: }
242: int *PetscIntAddressFromFortran(int *base,long addr)
243: {
244: return base + addr;
245: }
247: /*
248: obj - PETSc object on which request is made
249: base - Fortran array address
250: addr - C array address
251: res - will contain offset from C to Fortran
252: shift - number of bytes that prevent base and addr from being commonly aligned
254: To fix! If tmp2 is larger than a signed long can handle MUST genrate error,
255: currently we just stick into the signed and don't check.
257: */
258: int PetscScalarAddressToFortran(PetscObject obj,PetscScalar *base,PetscScalar *addr,int N,long *res)
259: {
260: unsigned long tmp1 = (unsigned long) base,tmp2 = tmp1/sizeof(PetscScalar);
261: unsigned long tmp3 = (unsigned long) addr;
262: long itmp2;
263: int shift;
265: #if !defined(PETSC_HAVE_CRAY90_POINTER)
266: if (tmp3 > tmp1) { /* C is bigger than Fortran */
267: tmp2 = (tmp3 - tmp1)/sizeof(PetscScalar);
268: itmp2 = (long) tmp2;
269: shift = (sizeof(PetscScalar) - (int)((tmp3 - tmp1) % sizeof(PetscScalar))) % sizeof(PetscScalar);
270: } else {
271: tmp2 = (tmp1 - tmp3)/sizeof(PetscScalar);
272: itmp2 = -((long) tmp2);
273: shift = (int)((tmp1 - tmp3) % sizeof(PetscScalar));
274: }
275: #else
276: if (tmp3 > tmp1) { /* C is bigger than Fortran */
277: tmp2 = (tmp3 - tmp1);
278: itmp2 = (long) tmp2;
279: } else {
280: tmp2 = (tmp1 - tmp3);
281: itmp2 = -((long) tmp2);
282: }
283: shift = 0;
284: #endif
285:
286: if (shift) {
287: /*
288: Fortran and C not PetscScalar aligned,recover by copying values into
289: memory that is aligned with the Fortran
290: */
291: int ierr;
292: PetscScalar *work;
293: PetscObjectContainer container;
295: PetscMalloc((N+1)*sizeof(PetscScalar),&work);
297: /* shift work by that number of bytes */
298: work = (PetscScalar*)(((char*)work) + shift);
299: PetscMemcpy(work,addr,N*sizeof(PetscScalar));
301: /* store in the first location in addr how much you shift it */
302: ((int *)addr)[0] = shift;
303:
304: PetscObjectContainerCreate(PETSC_COMM_SELF,&container);
305: PetscObjectContainerSetPointer(container,addr);
306: PetscObjectCompose(obj,"GetArrayPtr",(PetscObject)container);
308: tmp3 = (unsigned long) work;
309: if (tmp3 > tmp1) { /* C is bigger than Fortran */
310: tmp2 = (tmp3 - tmp1)/sizeof(PetscScalar);
311: itmp2 = (long) tmp2;
312: shift = (sizeof(PetscScalar) - (int)((tmp3 - tmp1) % sizeof(PetscScalar))) % sizeof(PetscScalar);
313: } else {
314: tmp2 = (tmp1 - tmp3)/sizeof(PetscScalar);
315: itmp2 = -((long) tmp2);
316: shift = (int)((tmp1 - tmp3) % sizeof(PetscScalar));
317: }
318: if (shift) {
319: (*PetscErrorPrintf)("PetscScalarAddressToFortran:C and Fortran arrays aren");
320: (*PetscErrorPrintf)("not commonly aligned.n");
321: /* double/int doesn't work with ADIC */
322: (*PetscErrorPrintf)("Locations/sizeof(PetscScalar): C %f Fortran %fn",
323: ((PetscReal)tmp3)/(PetscReal)sizeof(PetscScalar),((PetscReal)tmp1)/(PetscReal)sizeof(PetscScalar));
324: MPI_Abort(PETSC_COMM_WORLD,1);
325: }
326: PetscLogInfo((void *)obj,"PetscScalarAddressToFortran:Efficiency warning, copying array in XXXGetArray() duen
327: to alignment differences between C and Fortrann");
328: }
329: *res = itmp2;
330: return 0;
331: }
333: /*
334: obj - the PETSc object where the scalar pointer came from
335: base - the Fortran array address
336: addr - the Fortran offset from base
337: N - the amount of data
339: lx - the array space that is to be passed to XXXXRestoreArray()
340: */
341: int PetscScalarAddressFromFortran(PetscObject obj,PetscScalar *base,long addr,int N,PetscScalar **lx)
342: {
343: int ierr,shift;
344: PetscObjectContainer container;
345: PetscScalar *tlx;
347: PetscObjectQuery(obj,"GetArrayPtr",(PetscObject *)&container);
348: if (container) {
349: ierr = PetscObjectContainerGetPointer(container,(void**)lx);
350: tlx = base + addr;
352: shift = *(int *)*lx;
353: ierr = PetscMemcpy(*lx,tlx,N*sizeof(PetscScalar));
354: tlx = (PetscScalar*)(((char *)tlx) - shift);
355: PetscFree(tlx);
356: PetscObjectContainerDestroy(container);
357: PetscObjectCompose(obj,"GetArrayPtr",0);
358: } else {
359: *lx = base + addr;
360: }
361: return 0;
362: }
364: #undef __FUNCT__
366: /*@C
367: MPICCommToFortranComm - Converts a MPI_Comm represented
368: in C to one appropriate to pass to a Fortran routine.
370: Not collective
372: Input Parameter:
373: . cobj - the C MPI_Comm
375: Output Parameter:
376: . fobj - the Fortran MPI_Comm
378: Level: advanced
380: Notes:
381: MPICCommToFortranComm() must be called in a C/C++ routine.
382: MPI 1 does not provide a standard for mapping between
383: Fortran and C MPI communicators; this routine handles the
384: mapping correctly on all machines.
386: .keywords: Fortran, C, MPI_Comm, convert, interlanguage
388: .seealso: MPIFortranCommToCComm()
389: @*/
390: int MPICCommToFortranComm(MPI_Comm comm,int *fcomm)
391: {
392: int ierr,size;
395: /* call to MPI_Comm_size() is for error checking on comm */
396: MPI_Comm_size(comm,&size);
397: if (ierr) SETERRQ(1,"Invalid MPI communicator");
399: *fcomm = PetscFromPointerComm(comm);
400: return(0);
401: }
403: #undef __FUNCT__
405: /*@C
406: MPIFortranCommToCComm - Converts a MPI_Comm represented
407: int Fortran (as an integer) to a MPI_Comm in C.
409: Not collective
411: Input Parameter:
412: . fcomm - the Fortran MPI_Comm (an integer)
414: Output Parameter:
415: . comm - the C MPI_Comm
417: Level: advanced
419: Notes:
420: MPIFortranCommToCComm() must be called in a C/C++ routine.
421: MPI 1 does not provide a standard for mapping between
422: Fortran and C MPI communicators; this routine handles the
423: mapping correctly on all machines.
425: .keywords: Fortran, C, MPI_Comm, convert, interlanguage
427: .seealso: MPICCommToFortranComm()
428: @*/
429: int MPIFortranCommToCComm(int fcomm,MPI_Comm *comm)
430: {
431: int ierr,size;
434: *comm = (MPI_Comm)PetscToPointerComm(fcomm);
435: /* call to MPI_Comm_size() is for error checking on comm */
436: MPI_Comm_size(*comm,&size);
437: if (ierr) SETERRQ(1,"Invalid MPI communicator");
438: return(0);
439: }