Actual source code: zoptions.c
1: /*$Id: zoptions.c,v 1.77 2001/03/28 19:43:08 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 petscgetarchtype_ PETSCGETARCHTYPE
15: #define petscoptionsgetintarray_ PETSCOPTIONSGETINTARRAY
16: #define petscoptionssetvalue_ PETSCOPTIONSSETVALUE
17: #define petscoptionsclearvalue_ PETSCOPTIONSCLEARVALUE
18: #define petscoptionshasname_ PETSCOPTIONSHASNAME
19: #define petscoptionsgetint_ PETSCOPTIONSGETINT
20: #define petscoptionsgetdouble_ PETSCOPTIONSGETDOUBLE
21: #define petscoptionsgetdoublearray_ PETSCOPTIONSGETDOUBLEARRAY
22: #define petscoptionsgetstring_ PETSCOPTIONSGETSTRING
23: #define petscgetprogramname PETSCGETPROGRAMNAME
24: #define petscoptionsinsertfile_ PETSCOPTIONSINSERTFILE
25: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
26: #define petscgetarchtype_ petscgetarchtype
27: #define petscoptionssetvalue_ petscoptionssetvalue
28: #define petscoptionsclearvalue_ petscoptionsclearvalue
29: #define petscoptionshasname_ petscoptionshasname
30: #define petscoptionsgetint_ petscoptionsgetint
31: #define petscoptionsgetdouble_ petscoptionsgetdouble
32: #define petscoptionsgetdoublearray_ petscoptionsgetdoublearray
33: #define petscoptionsgetstring_ petscoptionsgetstring
34: #define petscoptionsgetintarray_ petscoptionsgetintarray
35: #define petscgetprogramname_ petscgetprogramname
36: #define petscoptionsinsertfile_ petscoptionsinsertfile
37: #endif
39: EXTERN_C_BEGIN
41: /* ---------------------------------------------------------------------*/
43: void PETSC_STDCALL petscoptionsinsertfile_(CHAR file PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
44: {
45: char *c1;
47: FIXCHAR(file,len,c1);
48: *PetscOptionsInsertFile(c1);
49: FREECHAR(file,c1);
50: }
52: void PETSC_STDCALL petscoptionssetvalue_(CHAR name PETSC_MIXED_LEN(len1),CHAR value PETSC_MIXED_LEN(len2),
53: int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
54: {
55: char *c1,*c2;
57: FIXCHAR(name,len1,c1);
58: FIXCHAR(value,len2,c2);
59: *PetscOptionsSetValue(c1,c2);
60: FREECHAR(name,c1);
61: FREECHAR(value,c2);
62: }
64: void PETSC_STDCALL petscoptionsclearvalue_(CHAR name PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
65: {
66: char *c1;
68: FIXCHAR(name,len,c1);
69: *PetscOptionsClearValue(c1);
70: FREECHAR(name,c1);
71: }
73: void PETSC_STDCALL petscoptionshasname_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
74: PetscTruth *flg,int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
75: {
76: char *c1,*c2;
78: FIXCHAR(pre,len1,c1);
79: FIXCHAR(name,len2,c2);
80: *PetscOptionsHasName(c1,c2,flg);
81: FREECHAR(pre,c1);
82: FREECHAR(name,c2);
83: }
85: void PETSC_STDCALL petscoptionsgetint_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
86: int *ivalue,PetscTruth *flg,int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
87: {
88: char *c1,*c2;
90: FIXCHAR(pre,len1,c1);
91: FIXCHAR(name,len2,c2);
92: *PetscOptionsGetInt(c1,c2,ivalue,flg);
93: FREECHAR(pre,c1);
94: FREECHAR(name,c2);
95: }
97: void PETSC_STDCALL petscoptionsgetdouble_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
98: double *dvalue,PetscTruth *flg,int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
99: {
100: char *c1,*c2;
102: FIXCHAR(pre,len1,c1);
103: FIXCHAR(name,len2,c2);
104: *PetscOptionsGetDouble(c1,c2,dvalue,flg);
105: FREECHAR(pre,c1);
106: FREECHAR(name,c2);
107: }
109: void PETSC_STDCALL petscoptionsgetdoublearray_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
110: double *dvalue,int *nmax,PetscTruth *flg,int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
111: {
112: char *c1,*c2;
114: FIXCHAR(pre,len1,c1);
115: FIXCHAR(name,len2,c2);
116: *PetscOptionsGetDoubleArray(c1,c2,dvalue,nmax,flg);
117: FREECHAR(pre,c1);
118: FREECHAR(name,c2);
119: }
121: void PETSC_STDCALL petscoptionsgetintarray_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
122: int *dvalue,int *nmax,PetscTruth *flg,int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
123: {
124: char *c1,*c2;
126: FIXCHAR(pre,len1,c1);
127: FIXCHAR(name,len2,c2);
128: *PetscOptionsGetIntArray(c1,c2,dvalue,nmax,flg);
129: FREECHAR(pre,c1);
130: FREECHAR(name,c2);
131: }
133: void PETSC_STDCALL petscoptionsgetstring_(CHAR pre PETSC_MIXED_LEN(len1),CHAR name PETSC_MIXED_LEN(len2),
134: CHAR string PETSC_MIXED_LEN(len),PetscTruth *flg,
135: int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2) PETSC_END_LEN(len))
136: {
137: char *c1,*c2,*c3;
138: int len3;
140: FIXCHAR(pre,len1,c1);
141: FIXCHAR(name,len2,c2);
142: #if defined(PETSC_USES_CPTOFCD)
143: c3 = _fcdtocp(string);
144: len3 = _fcdlen(string) - 1;
145: #else
146: c3 = string;
147: len3 = len - 1;
148: #endif
150: *PetscOptionsGetString(c1,c2,c3,len3,flg);
151: FREECHAR(pre,c1);
152: FREECHAR(name,c2);
153: }
155: void PETSC_STDCALL petscgetarchtype_(CHAR str PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
156: {
157: #if defined(PETSC_USES_CPTOFCD)
158: char *tstr = _fcdtocp(str);
159: int len1 = _fcdlen(str);
160: *PetscGetArchType(tstr,len1);
161: #else
162: *PetscGetArchType(str,len);
163: #endif
164: }
166: void PETSC_STDCALL petscgetprogramname_(CHAR name PETSC_MIXED_LEN(len_in),int *ierr PETSC_END_LEN(len_in))
167: {
168: char *tmp;
169: int len;
170: #if defined(PETSC_USES_CPTOFCD)
171: tmp = _fcdtocp(name);
172: len = _fcdlen(name) - 1;
173: #else
174: tmp = name;
175: len = len_in - 1;
176: #endif
177: *PetscGetProgramName(tmp,len);
178: }
180: EXTERN_C_END
182: /*
183: This is code for translating PETSc memory addresses to integer offsets
184: for Fortran.
185: */
186: char *PETSC_NULL_CHARACTER_Fortran;
187: void *PETSC_NULL_INTEGER_Fortran;
188: void *PETSC_NULL_SCALAR_Fortran;
189: void *PETSC_NULL_DOUBLE_Fortran;
190: EXTERN_C_BEGIN
191: void (*PETSC_NULL_FUNCTION_Fortran)();
192: EXTERN_C_END
193: long PetscIntAddressToFortran(int *base,int *addr)
194: {
195: unsigned long tmp1 = (unsigned long) base,tmp2 = 0;
196: unsigned long tmp3 = (unsigned long) addr;
197: long itmp2;
199: #if !defined(PETSC_HAVE_CRAY90_POINTER)
200: if (tmp3 > tmp1) {
201: tmp2 = (tmp3 - tmp1)/sizeof(int);
202: itmp2 = (long) tmp2;
203: } else {
204: tmp2 = (tmp1 - tmp3)/sizeof(int);
205: itmp2 = -((long) tmp2);
206: }
207: #else
208: if (tmp3 > tmp1) {
209: tmp2 = (tmp3 - tmp1);
210: itmp2 = (long) tmp2;
211: } else {
212: tmp2 = (tmp1 - tmp3);
213: itmp2 = -((long) tmp2);
214: }
215: #endif
217: if (base + itmp2 != addr) {
218: (*PetscErrorPrintf)("PetscIntAddressToFortran:C and Fortran arrays aren");
219: (*PetscErrorPrintf)("not commonly aligned or are too far apart to be indexed n");
220: (*PetscErrorPrintf)("by an integer. Locations: C %ld Fortran %ldn",tmp1,tmp3);
221: MPI_Abort(PETSC_COMM_WORLD,1);
222: }
223: return itmp2;
224: }
226: int *PetscIntAddressFromFortran(int *base,long addr)
227: {
228: return base + addr;
229: }
231: /*
232: obj - PETSc object on which request is made
233: base - Fortran array address
234: addr - C array address
235: res - will contain offset from C to Fortran
236: shift - number of bytes that prevent base and addr from being commonly aligned
238: To fix! If tmp2 is larger than a signed long can handle MUST genrate error,
239: currently we just stick into the signed and don't check.
241: */
242: int PetscScalarAddressToFortran(PetscObject obj,Scalar *base,Scalar *addr,int N,long *res)
243: {
244: unsigned long tmp1 = (unsigned long) base,tmp2 = tmp1/sizeof(Scalar);
245: unsigned long tmp3 = (unsigned long) addr;
246: long itmp2;
247: int shift;
249: #if !defined(PETSC_HAVE_CRAY90_POINTER)
250: if (tmp3 > tmp1) { /* C is bigger than Fortran */
251: tmp2 = (tmp3 - tmp1)/sizeof(Scalar);
252: itmp2 = (long) tmp2;
253: shift = (sizeof(Scalar) - (int)((tmp3 - tmp1) % sizeof(Scalar))) % sizeof(Scalar);
254: } else {
255: tmp2 = (tmp1 - tmp3)/sizeof(Scalar);
256: itmp2 = -((long) tmp2);
257: shift = (int)((tmp1 - tmp3) % sizeof(Scalar));
258: }
259: #else
260: if (tmp3 > tmp1) { /* C is bigger than Fortran */
261: tmp2 = (tmp3 - tmp1);
262: itmp2 = (long) tmp2;
263: } else {
264: tmp2 = (tmp1 - tmp3);
265: itmp2 = -((long) tmp2);
266: }
267: shift = 0;
268: #endif
269:
270: if (shift) {
271: /*
272: Fortran and C not Scalar aligned,recover by copying values into
273: memory that is aligned with the Fortran
274: */
275: int ierr;
276: Scalar *work;
277: PetscObjectContainer container;
279: PetscMalloc((N+1)*sizeof(Scalar),&work);
281: /* shift work by that number of bytes */
282: work = (Scalar*)(((char*)work) + shift);
283: PetscMemcpy(work,addr,N*sizeof(Scalar));
285: /* store in the first location in addr how much you shift it */
286: ((int *)addr)[0] = shift;
287:
288: PetscObjectContainerCreate(PETSC_COMM_SELF,&container);
289: PetscObjectContainerSetPointer(container,addr);
290: PetscObjectCompose(obj,"GetArrayPtr",(PetscObject)container);
292: tmp3 = (unsigned long) work;
293: if (tmp3 > tmp1) { /* C is bigger than Fortran */
294: tmp2 = (tmp3 - tmp1)/sizeof(Scalar);
295: itmp2 = (long) tmp2;
296: shift = (sizeof(Scalar) - (int)((tmp3 - tmp1) % sizeof(Scalar))) % sizeof(Scalar);
297: } else {
298: tmp2 = (tmp1 - tmp3)/sizeof(Scalar);
299: itmp2 = -((long) tmp2);
300: shift = (int)((tmp1 - tmp3) % sizeof(Scalar));
301: }
302: if (shift) {
303: (*PetscErrorPrintf)("PetscScalarAddressToFortran:C and Fortran arrays aren");
304: (*PetscErrorPrintf)("not commonly aligned.n");
305: /* double/int doesn't work with ADIC */
306: (*PetscErrorPrintf)("Locations/sizeof(Scalar): C %f Fortran %fn",
307: ((double)tmp3)/(double)sizeof(Scalar),((double)tmp1)/(double)sizeof(Scalar));
308: MPI_Abort(PETSC_COMM_WORLD,1);
309: }
310: PetscLogInfo((void *)obj,"PetscScalarAddressToFortran:Efficiency warning, copying array in XXXGetArray() duen
311: to alignment differences between C and Fortrann");
312: }
313: *res = itmp2;
314: return 0;
315: }
317: /*
318: obj - the PETSc object where the scalar pointer came from
319: base - the Fortran array address
320: addr - the Fortran offset from base
321: N - the amount of data
323: lx - the array space that is to be passed to XXXXRestoreArray()
324: */
325: int PetscScalarAddressFromFortran(PetscObject obj,Scalar *base,long addr,int N,Scalar **lx)
326: {
327: int ierr,shift;
328: PetscObjectContainer container;
329: Scalar *tlx;
331: PetscObjectQuery(obj,"GetArrayPtr",(PetscObject *)&container);
332: if (container) {
333: ierr = PetscObjectContainerGetPointer(container,(void**)lx);
334: tlx = base + addr;
336: shift = *(int *)*lx;
337: ierr = PetscMemcpy(*lx,tlx,N*sizeof(Scalar));
338: tlx = (Scalar*)(((char *)tlx) - shift);
339: PetscFree(tlx);
340: PetscObjectContainerDestroy(container);
341: PetscObjectCompose(obj,"GetArrayPtr",0);
342: } else {
343: *lx = base + addr;
344: }
345: return 0;
346: }
348: /*@C
349: MPICCommToFortranComm - Converts a MPI_Comm represented
350: in C to one appropriate to pass to a Fortran routine.
352: Not collective
354: Input Parameter:
355: . cobj - the C MPI_Comm
357: Output Parameter:
358: . fobj - the Fortran MPI_Comm
360: Level: advanced
362: Notes:
363: MPICCommToFortranComm() must be called in a C/C++ routine.
364: MPI 1 does not provide a standard for mapping between
365: Fortran and C MPI communicators; this routine handles the
366: mapping correctly on all machines.
368: .keywords: Fortran, C, MPI_Comm, convert, interlanguage
370: .seealso: MPIFortranCommToCComm()
371: @*/
372: int MPICCommToFortranComm(MPI_Comm comm,int *fcomm)
373: {
374: int ierr,size;
377: /* call to MPI_Comm_size() is for error checking on comm */
378: MPI_Comm_size(comm,&size);
379: if (ierr) SETERRQ(1,"Invalid MPI communicator");
381: *fcomm = PetscFromPointerComm(comm);
382: return(0);
383: }
385: /*@C
386: MPIFortranCommToCComm - Converts a MPI_Comm represented
387: int Fortran (as an integer) to a MPI_Comm in C.
389: Not collective
391: Input Parameter:
392: . fcomm - the Fortran MPI_Comm (an integer)
394: Output Parameter:
395: . comm - the C MPI_Comm
397: Level: advanced
399: Notes:
400: MPIFortranCommToCComm() must be called in a C/C++ routine.
401: MPI 1 does not provide a standard for mapping between
402: Fortran and C MPI communicators; this routine handles the
403: mapping correctly on all machines.
405: .keywords: Fortran, C, MPI_Comm, convert, interlanguage
407: .seealso: MPICCommToFortranComm()
408: @*/
409: int MPIFortranCommToCComm(int fcomm,MPI_Comm *comm)
410: {
411: int ierr,size;
414: *comm = (MPI_Comm)PetscToPointerComm(fcomm);
415: /* call to MPI_Comm_size() is for error checking on comm */
416: MPI_Comm_size(*comm,&size);
417: if (ierr) SETERRQ(1,"Invalid MPI communicator");
418: return(0);
419: }