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