Actual source code: zsys.c

  1: /*$Id: zsys.c,v 1.88 2001/03/22 20:33:25 bsmith Exp $*/

 3:  #include src/fortran/custom/zpetsc.h
 4:  #include petscsys.h
 5:  #include petscengine.h

  7: #ifdef PETSC_HAVE_FORTRAN_CAPS
  8: #define petscfopen_                PETSCFOPEN
  9: #define petscfclose_               PETSCFCLOSE
 10: #define petscfprintf_              PETSCFPRINTF
 11: #define petscsynchronizedfprintf_  PETSCSYNCHRONIZEDFPRINTF
 12: #define petscsynchronizedflush_    PETSCSYNCHRONIZEDFLUSH
 13: #define chkmemfortran_             CHKMEMFORTRAN
 14: #define petscattachdebugger_       PETSCATTACHDEBUGGER
 15: #define petscobjectsetname_        PETSCOBJECTSETNAME
 16: #define petscobjectdestroy_        PETSCOBJECTDESTROY
 17: #define petscobjectgetcomm_        PETSCOBJECTGETCOMM
 18: #define petscobjectgetname_        PETSCOBJECTGETNAME
 19: #define petscgetflops_             PETSCGETFLOPS
 20: #define petscerror_                PETSCERROR
 21: #define petscrandomcreate_         PETSCRANDOMCREATE
 22: #define petscrandomdestroy_        PETSCRANDOMDESTROY
 23: #define petscrandomgetvalue_       PETSCRANDOMGETVALUE
 24: #define petsctrvalid_              PETSCTRVALID
 25: #define petscdoubleview_           PETSCDOUBLEVIEW
 26: #define petscintview_              PETSCINTVIEW
 27: #define petscsequentialphasebegin_ PETSCSEQUENTIALPHASEBEGIN
 28: #define petscsequentialphaseend_   PETSCSEQUENTIALPHASEEND
 29: #define petsctrlog_                PETSCTRLOG
 30: #define petscmemcpy_               PETSCMEMCPY
 31: #define petsctrdump_               PETSCTRDUMP
 32: #define petsctrlogdump_            PETSCTRLOGDUMP
 33: #define petscmemzero_              PETSCMEMZERO
 34: #define petscbinaryopen_           PETSCBINARYOPEN
 35: #define petscbinaryread_           PETSCBINARYREAD
 36: #define petscbinarywrite_          PETSCBINARYWRITE
 37: #define petscbinaryclose_          PETSCBINARYCLOSE
 38: #define petscbinaryseek_           PETSCBINARYSEEK
 39: #define petscfixfilename_          PETSCFIXFILENAME
 40: #define petscstrncpy_              PETSCSTRNCPY
 41: #define petscbarrier_              PETSCBARRIER
 42: #define petscsynchronizedflush_    PETSCSYNCHRONIZEDFLUSH
 43: #define petscsplitownership_       PETSCSPLITOWNERSHIP
 44: #define petscobjectgetnewtag_      PETSCOBJECTGETNEWTAG
 45: #define petsccommgetnewtag_        PETSCCOMMGETNEWTAG
 46: #define petscfptrap_               PETSCFPTRAP
 47: #define petscoffsetfortran_        PETSCOFFSETFORTRAN
 48: #define petscmatlabenginecreate_      PETSCMATLABENGINECREATE
 49: #define petscmatlabenginedestroy_     PETSCMATLABENGINEDESTROY
 50: #define petscmatlabengineevaluate_    PETSCMATLABENGINEEVALUATE
 51: #define petscmatlabenginegetoutput_   PETSCMATLABENGINEGETOUTPUT
 52: #define petscmatlabengineprintoutput_ PETSCMATLABENGINEPRINTOUTPUT
 53: #define petscmatlabengineput_         PETSCMATLABENGINEPUT
 54: #define petscmatlabengineget_         PETSCMATLABENGINEGET
 55: #define petscmatlabengineputarray_    PETSCMATLABENGINEPUTARRAY
 56: #define petscmatlabenginegetarray_    PETSCMATLABENGINEGETARRAY
 57: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
 58: #define petscfopen_                   petscfopen
 59: #define petscfclose_                  petscfclose
 60: #define petscfprintf_                 petscfprintf
 61: #define petscsynchronizedfprintf_     petscsynchronizedfprintf
 62: #define petscsynchronizedflush_       petscsynchronizedflush
 63: #define petscmatlabenginecreate_      petscmatlabenginecreate
 64: #define petscmatlabenginedestroy_     petscmatlabenginedestroy
 65: #define petscmatlabengineevaluate_    petscmatlabengineevaluate
 66: #define petscmatlabenginegetoutput_   petscmatlabenginegetoutput
 67: #define petscmatlabengineprintoutput_ petscmatlabengineprintoutput
 68: #define petscmatlabengineput_         petscmatlabengineput
 69: #define petscmatlabengineget_         petscmatlabengineget
 70: #define petscmatlabengineputarray_    petscmatlabengineputarray
 71: #define petscmatlabenginegetarray_    petscmatlabenginegetarray
 72: #define petscoffsetfortran_        petscoffsetfortran     
 73: #define chkmemfortran_             chkmemfortran
 74: #define petscobjectgetnewtag_      petscobjectgetnewtag
 75: #define petsccommgetnewtag_        petsccommgetnewtag
 76: #define petscsplitownership_       petscsplitownership
 77: #define petscbarrier_              petscbarrier
 78: #define petscstrncpy_              petscstrncpy
 79: #define petscfixfilename_          petscfixfilename
 80: #define petsctrlog_                petsctrlog
 81: #define petscattachdebugger_       petscattachdebugger
 82: #define petscobjectsetname_        petscobjectsetname
 83: #define petscobjectdestroy_        petscobjectdestroy
 84: #define petscobjectgetcomm_        petscobjectgetcomm
 85: #define petscobjectgetname_        petscobjectgetname
 86: #define petscgetflops_             petscgetflops 
 87: #define petscerror_                petscerror
 88: #define petscrandomcreate_         petscrandomcreate
 89: #define petscrandomdestroy_        petscrandomdestroy
 90: #define petscrandomgetvalue_       petscrandomgetvalue
 91: #define petsctrvalid_              petsctrvalid
 92: #define petscdoubleview_           petscdoubleview
 93: #define petscintview_              petscintview
 94: #define petscsequentialphasebegin_ petscsequentialphasebegin
 95: #define petscsequentialphaseend_   petscsequentialphaseend
 96: #define petscmemcpy_               petscmemcpy
 97: #define petsctrdump_               petsctrdump
 98: #define petsctrlogdump_            petsctlogrdump
 99: #define petscmemzero_              petscmemzero
100: #define petscbinaryopen_           petscbinaryopen
101: #define petscbinaryread_           petscbinaryread
102: #define petscbinarywrite_          petscbinarywrite
103: #define petscbinaryclose_          petscbinaryclose
104: #define petscbinaryseek_           petscbinaryseek
105: #define petscsynchronizedflush_    petscsynchronizedflush
106: #define petscfptrap_               petscfptrap
107: #endif

109: EXTERN_C_BEGIN
110: /*
111:     integer i_x,i_y,shift
112:     Vec     x,y
113:     Scalar  v_x(1),v_y(1)

115:     call VecGetArray(x,v_x,i_x,ierr)
116:     if (x .eq. y) then
117:       call PetscOffsetFortran(y_v,x_v,shift,ierr)
118:       i_y = i_x + shift
119:     else 
120:       call VecGetArray(y,v_y,i_y,ierr)
121:     endif
122: */
123: void PETSC_STDCALL petscoffsetfortran_(Scalar *x,Scalar *y,int *shift,int *ierr)
124: {
125:   *0;
126:   *shift = y - x;
127: }

129: void PETSC_STDCALL petscfopen_(MPI_Comm *comm,CHAR fname PETSC_MIXED_LEN(len1),CHAR fmode PETSC_MIXED_LEN(len2),
130:                                FILE **file,int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
131: {
132:   char *c1,*c2;

134:   FIXCHAR(fname,len1,c1);
135:   FIXCHAR(fmode,len2,c2);
136:   *PetscFOpen((MPI_Comm)PetscToPointerComm(*comm),c1,c2,file);
137:   FREECHAR(fname,c1);
138:   FREECHAR(fmode,c2);
139: }
140: 
141: void PETSC_STDCALL petscfclose_(MPI_Comm *comm,FILE **file,int *ierr)
142: {
143:   *PetscFClose((MPI_Comm)PetscToPointerComm(*comm),*file);
144: }

146: void PETSC_STDCALL petscsynchronizedflush_(MPI_Comm *comm,int *ierr)
147: {
148:   *PetscSynchronizedFlush((MPI_Comm)PetscToPointerComm(*comm));
149: }

151: void PETSC_STDCALL petscfprintf_(MPI_Comm *comm,FILE **file,CHAR fname PETSC_MIXED_LEN(len1),int *ierr PETSC_END_LEN(len1))
152: {
153:   char *c1;

155:   FIXCHAR(fname,len1,c1);
156:   *PetscFPrintf((MPI_Comm)PetscToPointerComm(*comm),*file,c1);
157:   FREECHAR(fname,c1);
158: }

160: void PETSC_STDCALL petscsynchronizedfprintf_(MPI_Comm *comm,FILE **file,CHAR fname PETSC_MIXED_LEN(len1),int *ierr PETSC_END_LEN(len1))
161: {
162:   char *c1;

164:   FIXCHAR(fname,len1,c1);
165:   *PetscSynchronizedFPrintf((MPI_Comm)PetscToPointerComm(*comm),*file,c1);
166:   FREECHAR(fname,c1);
167: }

169: void PETSC_STDCALL petscsetfptrap_(PetscFPTrap *flag,int *ierr)
170: {
171:   *PetscSetFPTrap(*flag);
172: }

174: void PETSC_STDCALL petscobjectgetnewtag_(PetscObject *obj,int *tag,int *ierr)
175: {
176:   *PetscObjectGetNewTag(*obj,tag);
177: }

179: void PETSC_STDCALL petsccommgetnewtag_(MPI_Comm *comm,int *tag,int *ierr)
180: {
181:   *PetscCommGetNewTag((MPI_Comm)PetscToPointerComm(*comm),tag);
182: }

184: void PETSC_STDCALL petscsplitownership_(MPI_Comm *comm,int *n,int *N,int *ierr)
185: {
186:   *PetscSplitOwnership((MPI_Comm)PetscToPointerComm(*comm),n,N);
187: }

189: void PETSC_STDCALL petscbarrier_(PetscObject *obj,int *ierr)
190: {
191:   *PetscBarrier(*obj);
192: }

194: void PETSC_STDCALL petscstrncpy_(CHAR s1 PETSC_MIXED_LEN(len1),CHAR s2 PETSC_MIXED_LEN(len2),int *n,
195:                                  int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
196: {
197:   char *t1,*t2;
198:   int  m;

200: #if defined(PETSC_USES_CPTOFCD)
201:   t1 = _fcdtocp(s1);
202:   t2 = _fcdtocp(s2);
203:   m = *n; if (_fcdlen(s1) < m) m = _fcdlen(s1); if (_fcdlen(s2) < m) m = _fcdlen(s2);
204: #else
205:   t1 = s1;
206:   t2 = s2;
207:   m = *n; if (len1 < m) m = len1; if (len2 < m) m = len2;
208: #endif
209:   *PetscStrncpy(t1,t2,m);
210: }

212: void PETSC_STDCALL petscfixfilename_(CHAR filein PETSC_MIXED_LEN(len1),CHAR fileout PETSC_MIXED_LEN(len2),
213:                                      int *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
214: {
215:   int  i,n;
216:   char *in,*out;

218: #if defined(PETSC_USES_CPTOFCD)
219:   in  = _fcdtocp(filein);
220:   out = _fcdtocp(fileout);
221:   n   = _fcdlen (filein);
222: #else
223:   in  = filein;
224:   out = fileout;
225:   n   = len1;
226: #endif

228:   for (i=0; i<n; i++) {
229: #if defined(PARCH_win32)
230:     if (in[i] == '/') out[i] = '\';
231: #else
232:     if (in[i] == '\') out[i] = '/';
233: #endif
234:     else out[i] = in[i];
235:   }
236:   out[i] = 0;
237: }

239: void PETSC_STDCALL petscbinaryopen_(CHAR name PETSC_MIXED_LEN(len),int *type,int *fd,
240:                                     int *ierr PETSC_END_LEN(len))
241: {
242:   char *c1;

244:   FIXCHAR(name,len,c1);
245:   *PetscBinaryOpen(c1,*type,fd);
246:   FREECHAR(name,c1);
247: }

249: void PETSC_STDCALL petscbinarywrite_(int *fd,void *p,int *n,PetscDataType *type,int *istemp,int *ierr)
250: {
251:   *PetscBinaryWrite(*fd,p,*n,*type,*istemp);
252: }

254: void PETSC_STDCALL petscbinaryread_(int *fd,void *p,int *n,PetscDataType *type,int *ierr)
255: {
256:   *PetscBinaryRead(*fd,p,*n,*type);
257: }

259: void PETSC_STDCALL petscbinaryseek_(int *fd,int *size,PetscBinarySeekType *whence,int *offset,int *ierr)
260: {
261:   *PetscBinarySeek(*fd,*size,*whence,offset);
262: }

264: void PETSC_STDCALL petscbinaryclose_(int *fd,int *ierr)
265: {
266:   *PetscBinaryClose(*fd);
267: }

269: /* ---------------------------------------------------------------------------------*/
270: void PETSC_STDCALL petscmemzero_(void *a,int *n,int *ierr)
271: {
272:   *PetscMemzero(a,*n);
273: }

275: void PETSC_STDCALL petsctrdump_(int *ierr)
276: {
277:   *PetscTrDump(stdout);
278: }
279: void PETSC_STDCALL petsctrlogdump_(int *ierr)
280: {
281:   *PetscTrLogDump(stdout);
282: }

284: void PETSC_STDCALL petscmemcpy_(int *out,int *in,int *length,int *ierr)
285: {
286:   *PetscMemcpy(out,in,*length);
287: }

289: void PETSC_STDCALL petsctrlog_(int *ierr)
290: {
291:   *PetscTrLog();
292: }

294: /*
295:         This version does not do a malloc 
296: */
297: static char FIXCHARSTRING[1024];
298: #if defined(PETSC_USES_CPTOFCD)
299: #include <fortran.h>

301: #define CHAR _fcd
302: #define FIXCHARNOMALLOC(a,n,b) 
303: { 
304:   b = _fcdtocp(a); 
305:   n = _fcdlen (a); 
306:   if (b == PETSC_NULL_CHARACTER_Fortran) { 
307:       b = 0; 
308:   } else {  
309:     while((n > 0) && (b[n-1] == ' ')) n--; 
310:     b = FIXCHARSTRING; 
311:     *PetscStrncpy(b,_fcdtocp(a),n); 
312:     if (*ierr) return; 
313:     b[n] = 0; 
314:   } 
315: }

317: #else

319: #define CHAR char*
320: #define FIXCHARNOMALLOC(a,n,b) 
321: {
322:   if (a == PETSC_NULL_CHARACTER_Fortran) { 
323:     b = a = 0; 
324:   } else { 
325:     while((n > 0) && (a[n-1] == ' ')) n--; 
326:     if (a[n] != 0) { 
327:       b = FIXCHARSTRING; 
328:       *PetscStrncpy(b,a,n); 
329:       if (*ierr) return; 
330:       b[n] = 0; 
331:     } else b = a;
332:   } 
333: }

335: #endif

337: void PETSC_STDCALL chkmemfortran_(int *line,CHAR file PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
338: {
339:   char *c1;

341:   FIXCHARNOMALLOC(file,len,c1);
342:   *PetscTrValid(*line,"Userfunction",c1," ");
343: }

345: void PETSC_STDCALL petsctrvalid_(int *ierr)
346: {
347:   *PetscTrValid(0,"Unknown Fortran",0,0);
348: }

350: void PETSC_STDCALL petscrandomgetvalue_(PetscRandom *r,Scalar *val,int *ierr)
351: {
352:   *PetscRandomGetValue(*r,val);
353: }


356: void PETSC_STDCALL petscobjectgetname_(PetscObject *obj,CHAR name PETSC_MIXED_LEN(len),
357:                                        int *ierr PETSC_END_LEN(len))
358: {
359:   char *tmp;
360:   *PetscObjectGetName(*obj,&tmp);
361: #if defined(PETSC_USES_CPTOFCD)
362:   {
363:   char *t = _fcdtocp(name);
364:   int  len1 = _fcdlen(name);
365:   *PetscStrncpy(t,tmp,len1);if (*ierr) return;
366:   }
367: #else
368:   *PetscStrncpy(name,tmp,len);if (*ierr) return;
369: #endif
370: }

372: void PETSC_STDCALL petscobjectdestroy_(PetscObject *obj,int *ierr)
373: {
374:   *PetscObjectDestroy(*obj);
375: }

377: void PETSC_STDCALL petscobjectgetcomm_(PetscObject *obj,int *comm,int *ierr)
378: {
379:   MPI_Comm c;
380:   *PetscObjectGetComm(*obj,&c);
381:   *(int*)comm = PetscFromPointerComm(c);
382: }

384: void PETSC_STDCALL petscattachdebugger_(int *ierr)
385: {
386:   *PetscAttachDebugger();
387: }

389: void PETSC_STDCALL petscobjectsetname_(PetscObject *obj,CHAR name PETSC_MIXED_LEN(len),
390:                                        int *ierr PETSC_END_LEN(len))
391: {
392:   char *t1;

394:   FIXCHAR(name,len,t1);
395:   *PetscObjectSetName(*obj,t1);
396:   FREECHAR(name,t1);
397: }

399: void PETSC_STDCALL petscerror_(int *number,int *p,CHAR message PETSC_MIXED_LEN(len),
400:                                int *ierr PETSC_END_LEN(len))
401: {
402:   char *t1;
403:   FIXCHAR(message,len,t1);
404:   *PetscError(-1,"fortran_interface_unknown_file",0,0,*number,*p,t1);
405:   FREECHAR(message,t1);
406: }

408: void PETSC_STDCALL petscgetflops_(PetscLogDouble *d,int *ierr)
409: {
410: #if defined(PETSC_USE_LOG)
411:   *PetscGetFlops(d);
412: #else
413:   0;
414:   *d     = 0.0;
415: #endif
416: }

418: void PETSC_STDCALL petscrandomcreate_(MPI_Comm *comm,PetscRandomType *type,PetscRandom *r,int *ierr)
419: {
420:   *PetscRandomCreate((MPI_Comm)PetscToPointerComm(*comm),*type,r);
421: }

423: void PETSC_STDCALL petscrandomdestroy_(PetscRandom *r,int *ierr)
424: {
425:   *PetscRandomDestroy(*r);
426: }

428: void PETSC_STDCALL petscdoubleview_(int *n,double *d,int *viwer,int *ierr)
429: {
430:   *PetscDoubleView(*n,d,0);
431: }

433: void PETSC_STDCALL petscintview_(int *n,int *d,int *viwer,int *ierr)
434: {
435:   *PetscIntView(*n,d,0);
436: }

438: void PETSC_STDCALL petscsequentialphasebegin_(MPI_Comm *comm,int *ng,int *ierr){
439: *PetscSequentialPhaseBegin(
440:         (MPI_Comm)PetscToPointerComm(*comm),*ng);
441: }
442: void PETSC_STDCALL petscsequentialphaseend_(MPI_Comm *comm,int *ng,int *ierr){
443: *PetscSequentialPhaseEnd(
444:         (MPI_Comm)PetscToPointerComm(*comm),*ng);
445: }


448: #if defined(PETSC_HAVE_MATLAB_ENGINE) && !defined(PETSC_USE_COMPLEX)

450: void PETSC_STDCALL petscmatlabenginecreate_(MPI_Comm *comm,CHAR m PETSC_MIXED_LEN(len),PetscMatlabEngine *e,
451:                                             int *ierr PETSC_END_LEN(len))
452: {
453:   char *ms;

455:   FIXCHAR(m,len,ms);
456:   *PetscMatlabEngineCreate((MPI_Comm)PetscToPointerComm(*comm),ms,e);
457:   FREECHAR(m,ms);
458: }

460: void PETSC_STDCALL petscmatlabenginedestroy_(PetscMatlabEngine *e,int *ierr)
461: {
462:   *PetscMatlabEngineDestroy(*e);
463: }

465: void PETSC_STDCALL petscmatlabengineevaluate_(PetscMatlabEngine *e,CHAR m PETSC_MIXED_LEN(len),
466:                                               int *ierr PETSC_END_LEN(len))
467: {
468:   char *ms;
469:   FIXCHAR(m,len,ms);
470:   *PetscMatlabEngineEvaluate(*e,ms);
471:   FREECHAR(m,ms);
472: }

474: void PETSC_STDCALL petscmatlabengineput_(PetscMatlabEngine *e,PetscObject *o,int *ierr)
475: {
476:   *PetscMatlabEnginePut(*e,*o);
477: }

479: void PETSC_STDCALL petscmatlabengineget_(PetscMatlabEngine *e,PetscObject *o,int *ierr)
480: {
481:   *PetscMatlabEngineGet(*e,*o);
482: }

484: void PETSC_STDCALL petscmatlabengineputarray_(PetscMatlabEngine *e,int *m,int *n,Scalar *a,
485:                                               CHAR s PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
486: {
487:   char *ms;
488:   FIXCHAR(s,len,ms);
489:   *PetscMatlabEnginePutArray(*e,*m,*n,a,ms);
490:   FREECHAR(s,ms);
491: }

493: void PETSC_STDCALL petscmatlabenginegetarray_(PetscMatlabEngine *e,int *m,int *n,Scalar *a,
494:                                               CHAR s PETSC_MIXED_LEN(len),int *ierr PETSC_END_LEN(len))
495: {
496:   char *ms;
497:   FIXCHAR(s,len,ms);
498:   *PetscMatlabEngineGetArray(*e,*m,*n,a,ms);
499:   FREECHAR(s,ms);
500: }

502: #endif
503: /*
504: EXTERN int PetscMatlabEngineGetOutput(PetscMatlabEngine,char **);
505: EXTERN int PetscMatlabEnginePrintOutput(PetscMatlabEngine,FILE*);
506: */

508: EXTERN_C_END