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: }