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