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