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