Actual source code: zoptions.c
1: /*
2: This file contains Fortran stubs for Options routines.
3: These are not generated automatically since they require passing strings
4: between Fortran and C.
5: */
7: /*MC
8: PetscFortranAddr - a variable type in Fortran that can hold a
9: regular C pointer.
11: Notes: Used, for example, as the file argument in PetscFOpen()
13: Level: beginner
15: .seealso: PetscOffset, PetscInt
16: M*/
17: /*MC
18: PetscOffset - a variable type in Fortran used with VecGetArray()
19: and ISGetIndices()
21: Level: beginner
23: .seealso: PetscFortranAddr, PetscInt
24: M*/
26: #include src/fortran/custom/zpetsc.h
27: #include petscsys.h
30: #ifdef PETSC_HAVE_FORTRAN_CAPS
31: #define petscoptionsgettruth_ PETSCOPTIONSGETTRUTH
32: #define petscgetarchtype_ PETSCGETARCHTYPE
33: #define petscoptionsgetintarray_ PETSCOPTIONSGETINTARRAY
34: #define petscoptionssetvalue_ PETSCOPTIONSSETVALUE
35: #define petscoptionsclearvalue_ PETSCOPTIONSCLEARVALUE
36: #define petscoptionshasname_ PETSCOPTIONSHASNAME
37: #define petscoptionsgetint_ PETSCOPTIONSGETINT
38: #define petscoptionsgetreal_ PETSCOPTIONSGETREAL
39: #define petscoptionsgetrealarray_ PETSCOPTIONSGETREALARRAY
40: #define petscoptionsgetstring_ PETSCOPTIONSGETSTRING
41: #define petscgetprogramname PETSCGETPROGRAMNAME
42: #define petscoptionsinsertfile_ PETSCOPTIONSINSERTFILE
43: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
44: #define petscoptionsgettruth_ petscoptionsgettruth
45: #define petscgetarchtype_ petscgetarchtype
46: #define petscoptionssetvalue_ petscoptionssetvalue
47: #define petscoptionsclearvalue_ petscoptionsclearvalue
48: #define petscoptionshasname_ petscoptionshasname
49: #define petscoptionsgetint_ petscoptionsgetint
50: #define petscoptionsgetreal_ petscoptionsgetreal
51: #define petscoptionsgetrealarray_ petscoptionsgetrealarray
52: #define petscoptionsgetstring_ petscoptionsgetstring
53: #define petscoptionsgetintarray_ petscoptionsgetintarray
54: #define petscgetprogramname_ petscgetprogramname
55: #define petscoptionsinsertfile_ petscoptionsinsertfile
56: #endif
60: /* ---------------------------------------------------------------------*/
62: void PETSC_STDCALL petscoptionsinsertfile_(CHAR file PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
63: {
64: char *c1;
66: FIXCHAR(file,len,c1);
67: *PetscOptionsInsertFile(c1);
68: FREECHAR(file,c1);
69: }
71: void PETSC_STDCALL petscoptionssetvalue_(CHAR name PETSC_MIXED_LEN(len1),CHAR value PETSC_MIXED_LEN(len2),
72: PetscErrorCode *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
73: {
74: char *c1,*c2;
76: FIXCHAR(name,len1,c1);
77: FIXCHAR(value,len2,c2);
78: *PetscOptionsSetValue(c1,c2);
79: FREECHAR(name,c1);
80: FREECHAR(value,c2);
81: }
83: void PETSC_STDCALL petscoptionsclearvalue_(CHAR name PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
84: {
85: char *c1;
87: FIXCHAR(name,len,c1);
88: *PetscOptionsClearValue(c1);
89: FREECHAR(name,c1);
90: }
92: void PETSC_STDCALL petscoptionshasname_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
93: PetscTruth *flg,PetscErrorCode *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
94: {
95: char *c1,*c2;
97: FIXCHAR(pre,len1,c1);
98: FIXCHAR(name,len2,c2);
99: *PetscOptionsHasName(c1,c2,flg);
100: FREECHAR(pre,c1);
101: FREECHAR(name,c2);
102: }
104: void PETSC_STDCALL petscoptionsgetint_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
105: PetscInt *ivalue,PetscTruth *flg,PetscErrorCode *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
106: {
107: char *c1,*c2;
109: FIXCHAR(pre,len1,c1);
110: FIXCHAR(name,len2,c2);
111: *PetscOptionsGetInt(c1,c2,ivalue,flg);
112: FREECHAR(pre,c1);
113: FREECHAR(name,c2);
114: }
116: void PETSC_STDCALL petscoptionsgettruth_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
117: PetscTruth *ivalue,PetscTruth *flg,PetscErrorCode *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
118: {
119: char *c1,*c2;
121: FIXCHAR(pre,len1,c1);
122: FIXCHAR(name,len2,c2);
123: *PetscOptionsGetTruth(c1,c2,ivalue,flg);
124: FREECHAR(pre,c1);
125: FREECHAR(name,c2);
126: }
128: void PETSC_STDCALL petscoptionsgetreal_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
129: PetscReal *dvalue,PetscTruth *flg,PetscErrorCode *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
130: {
131: char *c1,*c2;
133: FIXCHAR(pre,len1,c1);
134: FIXCHAR(name,len2,c2);
135: *PetscOptionsGetReal(c1,c2,dvalue,flg);
136: FREECHAR(pre,c1);
137: FREECHAR(name,c2);
138: }
140: void PETSC_STDCALL petscoptionsgetrealarray_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
141: PetscReal *dvalue,PetscInt *nmax,PetscTruth *flg,PetscErrorCode *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
142: {
143: char *c1,*c2;
145: FIXCHAR(pre,len1,c1);
146: FIXCHAR(name,len2,c2);
147: *PetscOptionsGetRealArray(c1,c2,dvalue,nmax,flg);
148: FREECHAR(pre,c1);
149: FREECHAR(name,c2);
150: }
152: void PETSC_STDCALL petscoptionsgetintarray_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
153: PetscInt *dvalue,PetscInt *nmax,PetscTruth *flg,PetscErrorCode *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
154: {
155: char *c1,*c2;
157: FIXCHAR(pre,len1,c1);
158: FIXCHAR(name,len2,c2);
159: *PetscOptionsGetIntArray(c1,c2,dvalue,nmax,flg);
160: FREECHAR(pre,c1);
161: FREECHAR(name,c2);
162: }
164: void PETSC_STDCALL petscoptionsgetstring_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
165: CHAR string PETSC_MIXED_LEN(len),PetscTruth *flg,
166: PetscErrorCode *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2) PETSC_END_LEN(len))
167: {
168: char *c1,*c2,*c3;
169: int len3;
171: FIXCHAR(pre,len1,c1);
172: FIXCHAR(name,len2,c2);
173: #if defined(PETSC_USES_CPTOFCD)
174: c3 = _fcdtocp(string);
175: len3 = _fcdlen(string) - 1;
176: #else
177: c3 = string;
178: len3 = len - 1;
179: #endif
181: *PetscOptionsGetString(c1,c2,c3,len3,flg);
182: FREECHAR(pre,c1);
183: FREECHAR(name,c2);
184: FIXRETURNCHAR(string,len);
185: }
187: void PETSC_STDCALL petscgetarchtype_(CHAR str PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
188: {
189: #if defined(PETSC_USES_CPTOFCD)
190: char *tstr = _fcdtocp(str);
191: int len1 = _fcdlen(str);
192: *PetscGetArchType(tstr,len1);
193: #else
194: *PetscGetArchType(str,len);
195: #endif
196: FIXRETURNCHAR(str,len);
198: }
200: void PETSC_STDCALL petscgetprogramname_(CHAR name PETSC_MIXED_LEN(len_in),PetscErrorCode *ierr PETSC_END_LEN(len_in))
201: {
202: char *tmp;
203: int len;
204: #if defined(PETSC_USES_CPTOFCD)
205: tmp = _fcdtocp(name);
206: len = _fcdlen(name) - 1;
207: #else
208: tmp = name;
209: len = len_in - 1;
210: #endif
211: *PetscGetProgramName(tmp,len);
212: FIXRETURNCHAR(name,len_in);
213: }
217: /*
218: This is code for translating PETSc memory addresses to integer offsets
219: for Fortran.
220: */
221: char *PETSC_NULL_CHARACTER_Fortran = 0;
222: void *PETSC_NULL_INTEGER_Fortran = 0;
223: void *PETSC_NULL_OBJECT_Fortran = 0;
224: void *PETSC_NULL_Fortran = 0;
225: void *PETSC_NULL_SCALAR_Fortran = 0;
226: void *PETSC_NULL_DOUBLE_Fortran = 0;
227: void *PETSC_NULL_REAL_Fortran = 0;
229: void (*PETSC_NULL_FUNCTION_Fortran)(void) = 0;
231: size_t PetscIntAddressToFortran(PetscInt *base,PetscInt *addr)
232: {
233: size_t tmp1 = (size_t) base,tmp2 = 0;
234: size_t tmp3 = (size_t) addr;
235: size_t itmp2;
237: #if !defined(PETSC_HAVE_CRAY90_POINTER)
238: if (tmp3 > tmp1) {
239: tmp2 = (tmp3 - tmp1)/sizeof(PetscInt);
240: itmp2 = (size_t) tmp2;
241: } else {
242: tmp2 = (tmp1 - tmp3)/sizeof(PetscInt);
243: itmp2 = -((size_t) tmp2);
244: }
245: #else
246: if (tmp3 > tmp1) {
247: tmp2 = (tmp3 - tmp1);
248: itmp2 = (size_t) tmp2;
249: } else {
250: tmp2 = (tmp1 - tmp3);
251: itmp2 = -((size_t) tmp2);
252: }
253: #endif
255: if (base + itmp2 != addr) {
256: (*PetscErrorPrintf)("PetscIntAddressToFortran:C and Fortran arrays are\n");
257: (*PetscErrorPrintf)("not commonly aligned or are too far apart to be indexed \n");
258: (*PetscErrorPrintf)("by an integer. Locations: C %uld Fortran %uld\n",tmp1,tmp3);
259: MPI_Abort(PETSC_COMM_WORLD,1);
260: }
261: return itmp2;
262: }
264: PetscInt *PetscIntAddressFromFortran(PetscInt *base,size_t addr)
265: {
266: return base + addr;
267: }
269: /*
270: obj - PETSc object on which request is made
271: base - Fortran array address
272: addr - C array address
273: res - will contain offset from C to Fortran
274: shift - number of bytes that prevent base and addr from being commonly aligned
275: N - size of the array
277: */
278: PetscErrorCode PetscScalarAddressToFortran(PetscObject obj,PetscScalar *base,PetscScalar *addr,PetscInt N,size_t *res)
279: {
280: size_t tmp1 = (size_t) base,tmp2 = tmp1/sizeof(PetscScalar);
281: size_t tmp3 = (size_t) addr;
282: size_t itmp2;
283: PetscInt shift;
285: #if !defined(PETSC_HAVE_CRAY90_POINTER)
286: if (tmp3 > tmp1) { /* C is bigger than Fortran */
287: tmp2 = (tmp3 - tmp1)/sizeof(PetscScalar);
288: itmp2 = (size_t) tmp2;
289: shift = (sizeof(PetscScalar) - (int)((tmp3 - tmp1) % sizeof(PetscScalar))) % sizeof(PetscScalar);
290: } else {
291: tmp2 = (tmp1 - tmp3)/sizeof(PetscScalar);
292: itmp2 = -((size_t) tmp2);
293: shift = (int)((tmp1 - tmp3) % sizeof(PetscScalar));
294: }
295: #else
296: if (tmp3 > tmp1) { /* C is bigger than Fortran */
297: tmp2 = (tmp3 - tmp1);
298: itmp2 = (size_t) tmp2;
299: } else {
300: tmp2 = (tmp1 - tmp3);
301: itmp2 = -((size_t) tmp2);
302: }
303: shift = 0;
304: #endif
305:
306: if (shift) {
307: /*
308: Fortran and C not PetscScalar aligned,recover by copying values into
309: memory that is aligned with the Fortran
310: */
311: PetscErrorCode ierr;
312: PetscScalar *work;
313: PetscObjectContainer container;
315: PetscMalloc((N+1)*sizeof(PetscScalar),&work);
317: /* shift work by that number of bytes */
318: work = (PetscScalar*)(((char*)work) + shift);
319: PetscMemcpy(work,addr,N*sizeof(PetscScalar));
321: /* store in the first location in addr how much you shift it */
322: ((PetscInt*)addr)[0] = shift;
323:
324: PetscObjectContainerCreate(PETSC_COMM_SELF,&container);
325: PetscObjectContainerSetPointer(container,addr);
326: PetscObjectCompose(obj,"GetArrayPtr",(PetscObject)container);
328: tmp3 = (size_t) work;
329: if (tmp3 > tmp1) { /* C is bigger than Fortran */
330: tmp2 = (tmp3 - tmp1)/sizeof(PetscScalar);
331: itmp2 = (size_t) tmp2;
332: shift = (sizeof(PetscScalar) - (int)((tmp3 - tmp1) % sizeof(PetscScalar))) % sizeof(PetscScalar);
333: } else {
334: tmp2 = (tmp1 - tmp3)/sizeof(PetscScalar);
335: itmp2 = -((size_t) tmp2);
336: shift = (int)((tmp1 - tmp3) % sizeof(PetscScalar));
337: }
338: if (shift) {
339: (*PetscErrorPrintf)("PetscScalarAddressToFortran:C and Fortran arrays are\n");
340: (*PetscErrorPrintf)("not commonly aligned.\n");
341: /* double/int doesn't work with ADIC */
342: (*PetscErrorPrintf)("Locations/sizeof(PetscScalar): C %f Fortran %f\n",
343: ((PetscReal)tmp3)/(PetscReal)sizeof(PetscScalar),((PetscReal)tmp1)/(PetscReal)sizeof(PetscScalar));
344: MPI_Abort(PETSC_COMM_WORLD,1);
345: }
346: PetscLogInfo(((void*)obj,"PetscScalarAddressToFortran:Efficiency warning, copying array in XXXGetArray() due\n\
347: to alignment differences between C and Fortran\n"));
348: }
349: *res = itmp2;
350: return 0;
351: }
353: /*
354: obj - the PETSc object where the scalar pointer came from
355: base - the Fortran array address
356: addr - the Fortran offset from base
357: N - the amount of data
359: lx - the array space that is to be passed to XXXXRestoreArray()
360: */
361: PetscErrorCode PetscScalarAddressFromFortran(PetscObject obj,PetscScalar *base,size_t addr,PetscInt N,PetscScalar **lx)
362: {
363: PetscErrorCode ierr;
364: PetscInt shift;
365: PetscObjectContainer container;
366: PetscScalar *tlx;
368: PetscObjectQuery(obj,"GetArrayPtr",(PetscObject *)&container);
369: if (container) {
370: PetscObjectContainerGetPointer(container,(void**)lx);
371: tlx = base + addr;
373: shift = *(PetscInt*)*lx;
374: PetscMemcpy(*lx,tlx,N*sizeof(PetscScalar));
375: tlx = (PetscScalar*)(((char *)tlx) - shift);
376: PetscFree(tlx);
377: PetscObjectContainerDestroy(container);
378: PetscObjectCompose(obj,"GetArrayPtr",0);
379: } else {
380: *lx = base + addr;
381: }
382: return 0;
383: }
387: /*@C
388: MPICCommToFortranComm - Converts a MPI_Comm represented
389: in C to one appropriate to pass to a Fortran routine.
391: Not collective
393: Input Parameter:
394: . cobj - the C MPI_Comm
396: Output Parameter:
397: . fobj - the Fortran MPI_Comm
399: Level: advanced
401: Notes:
402: MPICCommToFortranComm() must be called in a C/C++ routine.
403: MPI 1 does not provide a standard for mapping between
404: Fortran and C MPI communicators; this routine handles the
405: mapping correctly on all machines.
407: .keywords: Fortran, C, MPI_Comm, convert, interlanguage
409: .seealso: MPIFortranCommToCComm()
410: @*/
411: PetscErrorCode MPICCommToFortranComm(MPI_Comm comm,int *fcomm)
412: {
414: PetscMPIInt size;
417: /* call to MPI_Comm_size() is for error checking on comm */
418: MPI_Comm_size(comm,&size);
419: if (ierr) SETERRQ(PETSC_ERR_ARG_CORRUPT ,"Invalid MPI communicator");
421: *fcomm = PetscFromPointerComm(comm);
422: return(0);
423: }
427: /*@C
428: MPIFortranCommToCComm - Converts a MPI_Comm represented
429: int Fortran (as an integer) to a MPI_Comm in C.
431: Not collective
433: Input Parameter:
434: . fcomm - the Fortran MPI_Comm (an integer)
436: Output Parameter:
437: . comm - the C MPI_Comm
439: Level: advanced
441: Notes:
442: MPIFortranCommToCComm() must be called in a C/C++ routine.
443: MPI 1 does not provide a standard for mapping between
444: Fortran and C MPI communicators; this routine handles the
445: mapping correctly on all machines.
447: .keywords: Fortran, C, MPI_Comm, convert, interlanguage
449: .seealso: MPICCommToFortranComm()
450: @*/
451: PetscErrorCode MPIFortranCommToCComm(int fcomm,MPI_Comm *comm)
452: {
454: PetscMPIInt size;
457: *comm = (MPI_Comm)PetscToPointerComm(fcomm);
458: /* call to MPI_Comm_size() is for error checking on comm */
459: MPI_Comm_size(*comm,&size);
460: if (ierr) SETERRQ(PETSC_ERR_ARG_CORRUPT,"Invalid MPI communicator");
461: return(0);
462: }