Actual source code: zmat.c

  1: /*$Id: zmat.c,v 1.100 2001/08/07 03:05:11 balay Exp $*/

 3:  #include src/mat/impls/adj/mpi/mpiadj.h
 4:  #include src/fortran/custom/zpetsc.h
 5:  #include petscmat.h

  7: #ifdef PETSC_HAVE_FORTRAN_CAPS
  8: #define matsettype_                      MATSETTYPE
  9: #define matmpiaijgetseqaij_              MATMPIAIJGETSEQAIJ
 10: #define matmpibaijgetseqbaij_            MATMPIBAIJGETSEQBAIJ
 11: #define matgetrowij_                     MATGETROWIJ
 12: #define matrestorerowij_                 MATRESTOREROWIJ
 13: #define matsetfromoptions_               MATSETFROMOPTIONS
 14: #define matcreateseqaijwitharrays_       MATCREATESEQAIJWITHARRAYS
 15: #define matpartitioningdestroy_          MATPARTITIONINGDESTROY
 16: #define matsetvalue_                     MATSETVALUE
 17: #define matsetvaluelocal_                MATSETVALUELOCAL
 18: #define matgetrow_                       MATGETROW
 19: #define matrestorerow_                   MATRESTOREROW
 20: #define matgetordering_                  MATGETORDERING
 21: #define matdestroy_                      MATDESTROY
 22: #define matcreatempiaij_                 MATCREATEMPIAIJ
 23: #define matcreateseqaij_                 MATCREATESEQAIJ
 24: #define matcreatempibaij_                MATCREATEMPIBAIJ
 25: #define matcreateseqbaij_                MATCREATESEQBAIJ
 26: #define matcreate_                       MATCREATE
 27: #define matcreateshell_                  MATCREATESHELL
 28: #define matorderingregisterdestroy_      MATORDERINGREGISTERDESTROY
 29: #define matcreatempirowbs_               MATCREATEMPIROWBS
 30: #define matcreateseqbdiag_               MATCREATESEQBDIAG
 31: #define matcreatempibdiag_               MATCREATEMPIBDIAG
 32: #define matcreateseqdense_               MATCREATESEQDENSE
 33: #define matcreatempidense_               MATCREATEMPIDENSE
 34: #define matconvert_                      MATCONVERT
 35: #define matload_                         MATLOAD
 36: #define mattranspose_                    MATTRANSPOSE
 37: #define matgetarray_                     MATGETARRAY
 38: #define matrestorearray_                 MATRESTOREARRAY
 39: #define matgettype_                      MATGETTYPE
 40: #define matgetinfo_                      MATGETINFO
 41: #define matshellsetoperation_            MATSHELLSETOPERATION
 42: #define matview_                         MATVIEW
 43: #define matfdcoloringcreate_             MATFDCOLORINGCREATE
 44: #define matfdcoloringdestroy_            MATFDCOLORINGDESTROY
 45: #define matfdcoloringsetfunctionsnes_    MATFDCOLORINGSETFUNCTIONSNES
 46: #define matfdcoloringsetfunctionts_      MATFDCOLORINGSETFUNCTIONTS
 47: #define matcopy_                         MATCOPY
 48: #define matgetsubmatrices_               MATGETSUBMATRICES
 49: #define matgetcoloring_                  MATGETCOLORING
 50: #define matpartitioningsettype_          MATPARTITIONINGSETTYPE
 51: #define matduplicate_                    MATDUPLICATE
 52: #define matzerorows_                     MATZEROROWS
 53: #define matzerorowslocal_                MATZEROROWSLOCAL
 54: #define matpartitioningview_             MATPARTITIONINGVIEW
 55: #define matpartitioningcreate_           MATPARTITIONINGCREATE
 56: #define matpartitioningsetadjacency_     MATPARTITIONINGSETADJACENCY
 57: #define matpartitioningapply_            MATPARTITIONINGAPPLY
 58: #define matcreatempiadj_                 MATCREATEMPIADJ
 59: #define matsetvaluesstencil_             MATSETVALUESSTENCIL
 60: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
 61: #define matsettype_                      matsettype
 62: #define matmpiaijgetseqaij_              matmpiaijgetseqaij
 63: #define matmpibaijgetseqbaij_            matmpibaijgetseqbaij          
 64: #define matrestorerowij_                 matrestorerowij
 65: #define matgetrowij_                     matgetrowij
 66: #define matcreateseqaijwitharrays_       matcreateseqaijwitharrays
 67: #define matpartitioningdestroy_          matpartitioningdestroy
 68: #define matpartitioningsettype_          matpartitioningsettype
 69: #define matsetvalue_                     matsetvalue
 70: #define matsetvaluelocal_                matsetvaluelocal
 71: #define matgetrow_                       matgetrow
 72: #define matrestorerow_                   matrestorerow
 73: #define matview_                         matview
 74: #define matgetinfo_                      matgetinfo
 75: #define matgettype_                      matgettype
 76: #define matdestroy_                      matdestroy
 77: #define matcreatempiaij_                 matcreatempiaij
 78: #define matcreateseqaij_                 matcreateseqaij
 79: #define matcreatempibaij_                matcreatempibaij
 80: #define matcreateseqbaij_                matcreateseqbaij
 81: #define matcreate_                       matcreate
 82: #define matcreateshell_                  matcreateshell
 83: #define matorderingregisterdestroy_      matorderingregisterdestroy
 84: #define matgetordering_                  matgetordering
 85: #define matcreatempirowbs_               matcreatempirowbs
 86: #define matcreateseqbdiag_               matcreateseqbdiag
 87: #define matcreatempibdiag_               matcreatempibdiag
 88: #define matcreateseqdense_               matcreateseqdense
 89: #define matcreatempidense_               matcreatempidense
 90: #define matconvert_                      matconvert
 91: #define matload_                         matload
 92: #define mattranspose_                    mattranspose
 93: #define matgetarray_                     matgetarray
 94: #define matrestorearray_                 matrestorearray
 95: #define matshellsetoperation_            matshellsetoperation
 96: #define matfdcoloringcreate_             matfdcoloringcreate
 97: #define matfdcoloringdestroy_            matfdcoloringdestroy
 98: #define matfdcoloringsetfunctionsnes_    matfdcoloringsetfunctionsnes
 99: #define matfdcoloringsetfunctionts_      matfdcoloringsetfunctionts
100: #define matcopy_                         matcopy
101: #define matgetsubmatrices_               matgetsubmatrices
102: #define matgetcoloring_                  matgetcoloring
103: #define matduplicate_                    matduplicate
104: #define matzerorows_                     matzerorows
105: #define matzerorowslocal_                matzerorowslocal
106: #define matpartitioningview_             matpartitioningview
107: #define matpartitioningcreate_           matpartitioningcreate
108: #define matpartitioningsetadjacency_     matpartitioningsetadjacency
109: #define matpartitioningapply_            matpartitioningapply            
110: #define matcreatempiadj_                 matcreatempiadj
111: #define matsetfromoptions_               matsetfromoptions
112: #define matsetvaluesstencil_             matsetvaluesstencil
113: #endif

115: /* The following variables have to be declared outsize EXTERN_C stuff - otherwise MS compilers are unhappy */
116: extern int *uglyrmapd,*uglyrmapo;

118: EXTERN_C_BEGIN

120: void PETSC_STDCALL matsettype_(Mat *x,CHAR type_name PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
121: {
122:   char *t;

124:   FIXCHAR(type_name,len,t);
125:   *MatSetType(*x,t);
126:   FREECHAR(type_name,t);
127: }

129: void PETSC_STDCALL matsetvaluesstencil_(Mat *mat,int *m,MatStencil *idxm,int *n,MatStencil *idxn,PetscScalar *v,InsertMode *addv,
130:                                         int *ierr)
131: {
132:   *MatSetValuesStencil(*mat,*m,idxm,*n,idxn,v,*addv);
133: }

135: void PETSC_STDCALL matmpiaijgetseqaij_(Mat *A,Mat *Ad,Mat *Ao,int *ic,long *iic,int *ierr)
136: {
137:   int *i;
138:   *MatMPIAIJGetSeqAIJ(*A,Ad,Ao,&i);if (*ierr) return;
139:   *iic  = PetscIntAddressToFortran(ic,i);
140: }

142: void PETSC_STDCALL matmpibaijgetseqbaij_(Mat *A,Mat *Ad,Mat *Ao,int *ic,long *iic,int *ierr)
143: {
144:   int *i;
145:   *MatMPIBAIJGetSeqBAIJ(*A,Ad,Ao,&i);if (*ierr) return;
146:   *iic  = PetscIntAddressToFortran(ic,i);
147: }

149: void PETSC_STDCALL matgetrowij_(Mat *B,int *shift,PetscTruth *sym,int *n,int *ia,long *iia,int *ja,long *jja,
150:                                 PetscTruth *done,int *ierr)
151: {
152:   int *IA,*JA;
153:   *MatGetRowIJ(*B,*shift,*sym,n,&IA,&JA,done);if (*ierr) return;
154:   *iia  = PetscIntAddressToFortran(ia,IA);
155:   *jja  = PetscIntAddressToFortran(ja,JA);
156: }

158: void PETSC_STDCALL matrestorerowij_(Mat *B,int *shift,PetscTruth *sym,int *n,int *ia,long *iia,int *ja,long *jja,
159:                                     PetscTruth *done,int *ierr)
160: {
161:   int *IA = PetscIntAddressFromFortran(ia,*iia),*JA = PetscIntAddressFromFortran(ja,*jja);
162:   *MatRestoreRowIJ(*B,*shift,*sym,n,&IA,&JA,done);
163: }

165: void PETSC_STDCALL matsetfromoptions_(Mat *B,int *ierr)
166: {
167:   *MatSetFromOptions(*B);
168: }

170: void PETSC_STDCALL matcreateseqaijwitharrays_(MPI_Comm *comm,int *m,int *n,int *i,int *j,PetscScalar *a,Mat *mat,int *ierr)
171: {
172:   *MatCreateSeqAIJWithArrays((MPI_Comm)PetscToPointerComm(*comm),*m,*n,i,j,a,mat);
173: }

175: void PETSC_STDCALL matcreatempiadj_(MPI_Comm *comm,int *m,int *n,int *i,int *j,int *values,Mat *A,int *ierr)
176: {
177:   Mat_MPIAdj *adj;

179:   CHKFORTRANNULLINTEGER(values);
180:   *MatCreateMPIAdj((MPI_Comm)PetscToPointerComm(*comm),*m,*n,i,j,values,A);
181:   adj = (Mat_MPIAdj*)(*A)->data;
182:   adj->freeaij = PETSC_FALSE;
183: }

185: void PETSC_STDCALL matpartitioningdestroy_(MatPartitioning *part,int *ierr)
186: {
187:   *MatPartitioningDestroy(*part);
188: }

190: void PETSC_STDCALL matpartitioningcreate_(MPI_Comm *comm,MatPartitioning *part, int *ierr)
191: {
192:   *MatPartitioningCreate((MPI_Comm)PetscToPointerComm(*comm),part);
193: }

195: void PETSC_STDCALL matpartitioningapply_(MatPartitioning *part,IS *is,int *ierr)
196: {
197:   *MatPartitioningApply(*part,is);
198: }

200: void PETSC_STDCALL matpartitioningsetadjacency_(MatPartitioning *part,Mat *mat,int *ierr)
201: {
202:   *MatPartitioningSetAdjacency(*part,*mat);
203: }

205: void PETSC_STDCALL matpartitioningview_(MatPartitioning  *part,PetscViewer *viewer, int *ierr)
206: {
207:   PetscViewer v;
208:   PetscPatchDefaultViewers_Fortran(viewer,v);
209:   *MatPartitioningView(*part,v);
210: }

212: void PETSC_STDCALL matpartitioningsettype_(MatPartitioning *part,CHAR type PETSC_MIXED_LEN(len),
213:                                            int *ierr PETSC_END_LEN(len))
214: {
215:   char *t;
216:   FIXCHAR(type,len,t);
217:   *MatPartitioningSetType(*part,t);
218:   FREECHAR(type,t);
219: }

221: void PETSC_STDCALL matgetcoloring_(Mat *mat,CHAR type PETSC_MIXED_LEN(len),ISColoring *iscoloring,
222:                                    int *ierr PETSC_END_LEN(len))
223: {
224:   char *t;
225:   FIXCHAR(type,len,t);
226:   *MatGetColoring(*mat,t,iscoloring);
227:   FREECHAR(type,t);
228: }

230: void PETSC_STDCALL matsetvalue_(Mat *mat,int *i,int *j,PetscScalar *va,InsertMode *mode,int *ierr)
231: {
232:   /* cannot use MatSetValue() here since that usesCHKERRQ() which has a return in it */
233:   *MatSetValues(*mat,1,i,1,j,va,*mode);
234: }

236: void PETSC_STDCALL matsetvaluelocal_(Mat *mat,int *i,int *j,PetscScalar *va,InsertMode *mode,int *ierr)
237: {
238:   /* cannot use MatSetValueLocal() here since that usesCHKERRQ() which has a return in it */
239:   *MatSetValuesLocal(*mat,1,i,1,j,va,*mode);
240: }

242: void PETSC_STDCALL matfdcoloringcreate_(Mat *mat,ISColoring *iscoloring,MatFDColoring *color,int *ierr)
243: {
244:   *MatFDColoringCreate(*mat,*iscoloring,color);
245: }

247: /*
248:    This is a poor way of storing the column and value pointers 
249:   generated by MatGetRow() to be returned with MatRestoreRow()
250:   but there is not natural,good place else to store them. Hence
251:   Fortran programmers can only have one outstanding MatGetRows()
252:   at a time.
253: */
254: static int    matgetrowactive = 0,*my_ocols = 0;
255: static PetscScalar *my_ovals = 0;

257: void PETSC_STDCALL matgetrow_(Mat *mat,int *row,int *ncols,int *cols,PetscScalar *vals,int *ierr)
258: {
259:   int    **oocols = &my_ocols;
260:   PetscScalar **oovals = &my_ovals;

262:   if (matgetrowactive) {
263:      PetscError(__LINE__,"MatGetRow_Fortran",__FILE__,__SDIR__,1,0,
264:                "Cannot have two MatGetRow() active simultaneouslyn
265:                call MatRestoreRow() before calling MatGetRow() a second time");
266:      *1;
267:      return;
268:   }

270:   CHKFORTRANNULLINTEGER(cols);
271:   CHKFORTRANNULLSCALAR(vals);

273:   *MatGetRow(*mat,*row,ncols,oocols,oovals);
274:   if (*ierr) return;

276:   if (oocols) { *PetscMemcpy(cols,my_ocols,(*ncols)*sizeof(int)); if (*ierr) return;}
277:   if (oovals) { *PetscMemcpy(vals,my_ovals,(*ncols)*sizeof(PetscScalar)); if (*ierr) return; }
278:   matgetrowactive = 1;
279: }

281: void PETSC_STDCALL matrestorerow_(Mat *mat,int *row,int *ncols,int *cols,PetscScalar *vals,int *ierr)
282: {
283:   int    **oocols = &my_ocols;
284:   PetscScalar **oovals = &my_ovals;
285:   if (!matgetrowactive) {
286:      PetscError(__LINE__,"MatRestoreRow_Fortran",__FILE__,__SDIR__,1,0,
287:                "Must call MatGetRow() first");
288:      *1;
289:      return;
290:   }
291:   CHKFORTRANNULLINTEGER(cols);
292:   CHKFORTRANNULLSCALAR(vals);
293:   *MatRestoreRow(*mat,*row,ncols,oocols,oovals);
294:   matgetrowactive = 0;
295: }

297: void PETSC_STDCALL matview_(Mat *mat,PetscViewer *vin,int *ierr)
298: {
299:   PetscViewer v;
300:   PetscPatchDefaultViewers_Fortran(vin,v);
301:   *MatView(*mat,v);
302: }

304: void PETSC_STDCALL matcopy_(Mat *A,Mat *B,MatStructure *str,int *ierr)
305: {
306:   *MatCopy(*A,*B,*str);
307: }

309: void PETSC_STDCALL matgetinfo_(Mat *mat,MatInfoType *flag,double *finfo,int *ierr)
310: {
311:   *MatGetInfo(*mat,*flag,(MatInfo*)finfo);
312: }

314: void PETSC_STDCALL matgetarray_(Mat *mat,PetscScalar *fa,long *ia,int *ierr)
315: {
316:   PetscScalar *mm;
317:   int    m,n;

319:   *MatGetArray(*mat,&mm); if (*ierr) return;
320:   *MatGetSize(*mat,&m,&n);  if (*ierr) return;
321:   *PetscScalarAddressToFortran((PetscObject)*mat,fa,mm,m*n,ia); if (*ierr) return;
322: }

324: void PETSC_STDCALL matrestorearray_(Mat *mat,PetscScalar *fa,long *ia,int *ierr)
325: {
326:   PetscScalar          *lx;
327:   int                  m,n;

329:   *MatGetSize(*mat,&m,&n); if (*ierr) return;
330:   *PetscScalarAddressFromFortran((PetscObject)*mat,fa,*ia,m*n,&lx);if (*ierr) return;
331:   *MatRestoreArray(*mat,&lx);if (*ierr) return;
332: }

334: void PETSC_STDCALL mattranspose_(Mat *mat,Mat *B,int *ierr)
335: {
336:   CHKFORTRANNULLINTEGER(B);
337:   *MatTranspose(*mat,B);
338: }

340: void PETSC_STDCALL matload_(PetscViewer *viewer,CHAR outtype PETSC_MIXED_LEN(len),Mat *newmat,int *ierr PETSC_END_LEN(len))
341: {
342:   char *t;
343:   PetscViewer v;
344:   FIXCHAR(outtype,len,t);
345:   PetscPatchDefaultViewers_Fortran(viewer,v);
346:   *MatLoad(v,t,newmat);
347:   FREECHAR(outtype,t);
348: }

350: void PETSC_STDCALL matconvert_(Mat *mat,CHAR outtype PETSC_MIXED_LEN(len),Mat *M,int *ierr PETSC_END_LEN(len))
351: {
352:   char *t;
353:   FIXCHAR(outtype,len,t);
354:   *MatConvert(*mat,t,M);
355:   FREECHAR(outtype,t);
356: }

358: void PETSC_STDCALL matcreateseqdense_(MPI_Comm *comm,int *m,int *n,PetscScalar *data,Mat *newmat,int *ierr)
359: {
360:   CHKFORTRANNULLSCALAR(data);
361:   *MatCreateSeqDense((MPI_Comm)PetscToPointerComm(*comm),*m,*n,data,newmat);
362: }

364: void PETSC_STDCALL matcreatempidense_(MPI_Comm *comm,int *m,int *n,int *M,int *N,PetscScalar *data,Mat *newmat,
365:                         int *ierr)
366: {
367:   CHKFORTRANNULLSCALAR(data);
368:   *MatCreateMPIDense((MPI_Comm)PetscToPointerComm(*comm),*m,*n,*M,*N,data,newmat);
369: }

371: /* Fortran ignores diagv */
372: void PETSC_STDCALL matcreatempibdiag_(MPI_Comm *comm,int *m,int *M,int *N,int *nd,int *bs,
373:                         int *diag,PetscScalar **diagv,Mat *newmat,int *ierr)
374: {
375:   *MatCreateMPIBDiag((MPI_Comm)PetscToPointerComm(*comm),
376:                               *m,*M,*N,*nd,*bs,diag,PETSC_NULL,newmat);
377: }

379: /* Fortran ignores diagv */
380: void PETSC_STDCALL matcreateseqbdiag_(MPI_Comm *comm,int *m,int *n,int *nd,int *bs,
381:                         int *diag,PetscScalar **diagv,Mat *newmat,int *ierr)
382: {
383:   *MatCreateSeqBDiag((MPI_Comm)PetscToPointerComm(*comm),*m,*n,*nd,*bs,diag,
384:                                PETSC_NULL,newmat);
385: }

387: #if defined(PETSC_HAVE_BLOCKSOLVE) && !defined(PETSC_USE_COMPLEX) && !defined(PETSC_USE_SINGLE)
388: /*  Fortran cannot pass in procinfo,hence ignored */
389: void PETSC_STDCALL matcreatempirowbs_(MPI_Comm *comm,int *m,int *M,int *nz,int *nnz,Mat *newmat,int *ierr)
390: {
391:   CHKFORTRANNULLINTEGER(nnz);
392:   *MatCreateMPIRowbs((MPI_Comm)PetscToPointerComm(*comm),*m,*M,*nz,nnz,newmat);
393: }
394: #endif

396: void PETSC_STDCALL matgetordering_(Mat *mat,CHAR type PETSC_MIXED_LEN(len),IS *rperm,IS *cperm,
397:                        int *ierr PETSC_END_LEN(len))
398: {
399:   char *t;
400:   FIXCHAR(type,len,t);
401:   *MatGetOrdering(*mat,t,rperm,cperm);
402:   FREECHAR(type,t);
403: }

405: void PETSC_STDCALL matorderingregisterdestroy_(int *ierr)
406: {
407:   *MatOrderingRegisterDestroy();
408: }

410: void PETSC_STDCALL matgettype_(Mat *mm,CHAR name PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
411: {
412:   char *tname;

414:   *MatGetType(*mm,&tname);
415: #if defined(PETSC_USES_CPTOFCD)
416:   {
417:     char *t = _fcdtocp(name); int len1 = _fcdlen(name);
418:     if (t != PETSC_NULL_CHARACTER_Fortran) {
419:       *PetscStrncpy(t,tname,len1);if (*ierr) return;
420:     }
421:   }
422: #else
423:   if (name != PETSC_NULL_CHARACTER_Fortran) {
424:     *PetscStrncpy(name,tname,len);if (*ierr) return;
425:   }
426: #endif
427: }

429: void PETSC_STDCALL matcreate_(MPI_Comm *comm,int *m,int *n,int *M,int *N,Mat *V,int *ierr)
430: {
431:   *MatCreate((MPI_Comm)PetscToPointerComm(*comm),*m,*n,*M,*N,V);
432: }

434: void PETSC_STDCALL matcreateseqaij_(MPI_Comm *comm,int *m,int *n,int *nz,
435:                            int *nnz,Mat *newmat,int *ierr)
436: {
437:   CHKFORTRANNULLINTEGER(nnz);
438:   *MatCreateSeqAIJ((MPI_Comm)PetscToPointerComm(*comm),*m,*n,*nz,nnz,newmat);
439: }

441: void PETSC_STDCALL matcreateseqbaij_(MPI_Comm *comm,int *bs,int *m,int *n,int *nz,
442:                            int *nnz,Mat *newmat,int *ierr)
443: {
444:   CHKFORTRANNULLINTEGER(nnz);
445:   *MatCreateSeqBAIJ((MPI_Comm)PetscToPointerComm(*comm),*bs,*m,*n,*nz,nnz,newmat);
446: }

448: void PETSC_STDCALL matfdcoloringdestroy_(MatFDColoring *mat,int *ierr)
449: {
450:   *MatFDColoringDestroy(*mat);
451: }

453: void PETSC_STDCALL matdestroy_(Mat *mat,int *ierr)
454: {
455:   *MatDestroy(*mat);
456: }

458: void PETSC_STDCALL matcreatempiaij_(MPI_Comm *comm,int *m,int *n,int *M,int *N,
459:          int *d_nz,int *d_nnz,int *o_nz,int *o_nnz,Mat *newmat,int *ierr)
460: {
461:   CHKFORTRANNULLINTEGER(d_nnz);
462:   CHKFORTRANNULLINTEGER(o_nnz);

464:   *MatCreateMPIAIJ((MPI_Comm)PetscToPointerComm(*comm),
465:                              *m,*n,*M,*N,*d_nz,d_nnz,*o_nz,o_nnz,newmat);
466: }
467: void PETSC_STDCALL matcreatempibaij_(MPI_Comm *comm,int *bs,int *m,int *n,int *M,int *N,
468:          int *d_nz,int *d_nnz,int *o_nz,int *o_nnz,Mat *newmat,int *ierr)
469: {
470:   CHKFORTRANNULLINTEGER(d_nnz);
471:   CHKFORTRANNULLINTEGER(o_nnz);
472:   *MatCreateMPIBAIJ((MPI_Comm)PetscToPointerComm(*comm),
473:                              *bs,*m,*n,*M,*N,*d_nz,d_nnz,*o_nz,o_nnz,newmat);
474: }


477: /*
478:       The MatShell Matrix Vector product requires a C routine.
479:    This C routine then calls the corresponding Fortran routine that was
480:    set by the user.
481: */
482: void PETSC_STDCALL matcreateshell_(MPI_Comm *comm,int *m,int *n,int *M,int *N,void **ctx,Mat *mat,int *ierr)
483: {
484:   *MatCreateShell((MPI_Comm)PetscToPointerComm(*comm),*m,*n,*M,*N,*ctx,mat);
485:   if (*ierr) return;
486:   *PetscMalloc(4*sizeof(void *),&((PetscObject)*mat)->fortran_func_pointers);
487: }

489: static int ourmult(Mat mat,Vec x,Vec y)
490: {
491:   int              0;
492:   (*(int (PETSC_STDCALL *)(Mat*,Vec*,Vec*,int*))(((PetscObject)mat)->fortran_func_pointers[0]))(&mat,&x,&y,&ierr);
493:   return ierr;
494: }

496: static int ourmulttranspose(Mat mat,Vec x,Vec y)
497: {
498:   int              0;
499:   (*(int (PETSC_STDCALL *)(Mat*,Vec*,Vec*,int*))(((PetscObject)mat)->fortran_func_pointers[2]))(&mat,&x,&y,&ierr);
500:   return ierr;
501: }

503: static int ourmultadd(Mat mat,Vec x,Vec y,Vec z)
504: {
505:   int              0;
506:   (*(int (PETSC_STDCALL *)(Mat*,Vec*,Vec*,Vec*,int*))(((PetscObject)mat)->fortran_func_pointers[1]))(&mat,&x,&y,&z,&ierr);
507:   return ierr;
508: }

510: static int ourmulttransposeadd(Mat mat,Vec x,Vec y,Vec z)
511: {
512:   int              0;
513:   (*(int (PETSC_STDCALL *)(Mat*,Vec*,Vec*,Vec*,int*))(((PetscObject)mat)->fortran_func_pointers[3]))(&mat,&x,&y,&z,&ierr);
514:   return ierr;
515: }

517: void PETSC_STDCALL matshellsetoperation_(Mat *mat,MatOperation *op,int (PETSC_STDCALL *f)(Mat*,Vec*,Vec*,int*),int *ierr)
518: {
519:   if (*op == MATOP_MULT) {
520:     *MatShellSetOperation(*mat,*op,(void(*)(void))ourmult);
521:     ((PetscObject)*mat)->fortran_func_pointers[0] = (void(*)(void))f;
522:   } else if (*op == MATOP_MULT_TRANSPOSE) {
523:     *MatShellSetOperation(*mat,*op,(void(*)(void))ourmulttranspose);
524:     ((PetscObject)*mat)->fortran_func_pointers[2] = (void(*)(void))f;
525:   } else if (*op == MATOP_MULT_ADD) {
526:     *MatShellSetOperation(*mat,*op,(void(*)(void))ourmultadd);
527:     ((PetscObject)*mat)->fortran_func_pointers[1] = (void(*)(void))f;
528:   } else if (*op == MATOP_MULT_TRANSPOSE_ADD) {
529:     *MatShellSetOperation(*mat,*op,(void(*)(void))ourmulttransposeadd);
530:     ((PetscObject)*mat)->fortran_func_pointers[3] = (void(*)(void))f;
531:   } else {
532:     PetscError(__LINE__,"MatShellSetOperation_Fortran",__FILE__,__SDIR__,1,0,
533:                "Cannot set that matrix operation");
534:     *1;
535:   }
536: }

538:  #include petscts.h
539: /*
540:         MatFDColoringSetFunction sticks the Fortran function into the fortran_func_pointers
541:     this function is then accessed by ourmatfdcoloringfunction()

543:    NOTE: FORTRAN USER CANNOT PUT IN A NEW J OR B currently.

545:    USER CAN HAVE ONLY ONE MatFDColoring in code Because there is no place to hang f7!
546: */

548: static void (PETSC_STDCALL *f7)(TS*,double*,Vec*,Vec*,void*,int*);

550: static int ourmatfdcoloringfunctionts(TS ts,double t,Vec x,Vec y,void *ctx)
551: {
552:   int 0;
553:   (*f7)(&ts,&t,&x,&y,ctx,&ierr);
554:   return ierr;
555: }

557: void PETSC_STDCALL matfdcoloringsetfunctionts_(MatFDColoring *fd,void (PETSC_STDCALL *f)(TS*,double*,Vec*,Vec*,void*,int*),
558:                                  void *ctx,int *ierr)
559: {
560:   f7 = f;
561:   *MatFDColoringSetFunction(*fd,(int (*)(void))ourmatfdcoloringfunctionts,ctx);
562: }

564: static void (PETSC_STDCALL *f8)(SNES*,Vec*,Vec*,void*,int*);

566: static int ourmatfdcoloringfunctionsnes(SNES ts,Vec x,Vec y,void *ctx)
567: {
568:   int 0;
569:   (*f8)(&ts,&x,&y,ctx,&ierr);
570:   return ierr;
571: }


574: void PETSC_STDCALL matfdcoloringsetfunctionsnes_(MatFDColoring *fd,void (PETSC_STDCALL *f)(SNES*,Vec*,Vec*,void*,int*),
575:                                  void *ctx,int *ierr)
576: {
577:   f8 = f;
578:   *MatFDColoringSetFunction(*fd,(int (*)(void))ourmatfdcoloringfunctionsnes,ctx);
579: }

581: /*
582:     MatGetSubmatrices() is slightly different from C since the 
583:     Fortran provides the array to hold the submatrix objects,while in C that 
584:     array is allocated by the MatGetSubmatrices()
585: */
586: void PETSC_STDCALL matgetsubmatrices_(Mat *mat,int *n,IS *isrow,IS *iscol,MatReuse *scall,Mat *smat,int *ierr)
587: {
588:   Mat *lsmat;
589:   int i;

591:   if (*scall == MAT_INITIAL_MATRIX) {
592:     *MatGetSubMatrices(*mat,*n,isrow,iscol,*scall,&lsmat);
593:     for (i=0; i<*n; i++) {
594:       smat[i] = lsmat[i];
595:     }
596:     PetscFree(lsmat);
597:   } else {
598:     *MatGetSubMatrices(*mat,*n,isrow,iscol,*scall,&smat);
599:   }
600: }

602: void PETSC_STDCALL matduplicate_(Mat *matin,MatDuplicateOption *op,Mat *matout,int *ierr)
603: {
604:   *MatDuplicate(*matin,*op,matout);
605: }

607: void PETSC_STDCALL matzerorows_(Mat *mat,IS *is,PetscScalar *diag,int *ierr)
608: {
609:   CHKFORTRANNULLSCALAR(diag);
610:   *MatZeroRows(*mat,*is,diag);
611: }

613: void PETSC_STDCALL matzerorowslocal_(Mat *mat,IS *is,PetscScalar *diag,int *ierr)
614: {
615:   CHKFORTRANNULLSCALAR(diag);
616:   *MatZeroRowsLocal(*mat,*is,diag);
617: }

619: /*        Patch added for Glenn */
620: #ifdef PETSC_HAVE_FORTRAN_CAPS
621: #define matmpibaijdiagonalscalelocal_    MATMPIBAIJDIAGONALSCALELOCAL
622: #define matdiagonalscalelocal_           MATDIAGONALSCALELOCAL
623: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
624: #define matmpibaijdiagonalscalelocal_    matmpibaijdiagonalscalelocal
625: #define matdiagonalscalelocal_           matdiagonalscalelocal
626: #endif

628: void matmpibaijdiagonalscalelocal_(Mat *A,Vec *scale,int *ierr)
629: {
630:   if (!uglyrmapd) {
631:     *MatMPIBAIJDiagonalScaleLocalSetUp(*A,*scale);
632:     if (*ierr) return;
633:   }
634:   *MatMPIBAIJDiagonalScaleLocal(*A,*scale);
635: }

637: void PETSC_STDCALL matdiagonalscalelocal_(Mat *A,Vec *scale, int *__ierr ){
638:   if (!uglyrmapd) {
639:     *__MatMPIBAIJDiagonalScaleLocalSetUp(*A,*scale);
640:     if (*__ierr) return;
641:   }
642:   *__MatMPIBAIJDiagonalScaleLocal(*A,*scale);
643: }

645: EXTERN_C_END