xref: /petsc/src/sys/ftn-custom/zsys.c (revision e2df7a95c5ea77c899beea10ff9effd6061e7c8f) 
1 
2 #include "zpetsc.h"
3 #include "petscsys.h"
4 #include "petscmatlab.h"
5 
6 void *PETSCNULLPOINTERADDRESS = PETSC_NULL;
7 
8 #ifdef PETSC_HAVE_FORTRAN_CAPS
9 #define petscfopen_                PETSCFOPEN
10 #define petscfprintf_              PETSCFPRINTF
11 #define petscsynchronizedfprintf_  PETSCSYNCHRONIZEDFPRINTF
12 #define petscprintf_               PETSCPRINTF
13 #define petscsynchronizedprintf_   PETSCSYNCHRONIZEDPRINTF
14 #define chkmemfortran_             CHKMEMFORTRAN
15 #define petscobjectsetname_        PETSCOBJECTSETNAME
16 #define petscobjectgetcomm_        PETSCOBJECTGETCOMM
17 #define petscobjectgetname_        PETSCOBJECTGETNAME
18 #define petscgetflops_             PETSCGETFLOPS
19 #define petscerror_                PETSCERROR
20 #define petscmallocvalidate_       PETSCMALLOCVALIDATE
21 #define petscrealview_             PETSCREALVIEW
22 #define petscintview_              PETSCINTVIEW
23 #define petsctrlog_                PETSCTRLOG
24 #define petscmallocdump_           PETSCMALLOCDUMP
25 #define petscmallocdumplog_        PETSCMALLOCDUMPLOG
26 #define petscbinaryopen_           PETSCBINARYOPEN
27 #define petscfixfilename_          PETSCFIXFILENAME
28 #define petscstrncpy_              PETSCSTRNCPY
29 #define petscfptrap_               PETSCFPTRAP
30 #define petscoffsetfortran_        PETSCOFFSETFORTRAN
31 #define petscmatlabenginecreate_      PETSCMATLABENGINECREATE
32 #define petscmatlabengineevaluate_    PETSCMATLABENGINEEVALUATE
33 #define petscmatlabenginegetoutput_   PETSCMATLABENGINEGETOUTPUT
34 #define petscmatlabengineprintoutput_ PETSCMATLABENGINEPRINTOUTPUT
35 #define petscmatlabengineputarray_    PETSCMATLABENGINEPUTARRAY
36 #define petscmatlabenginegetarray_    PETSCMATLABENGINEGETARRAY
37 #define petscgetmemoryusage    _      PETSCGETMEMORYUSAGE
38 #define petscviewerasciiprintf_       PETSCVIEWERASCIIPRINTF
39 #define petscviewerasciisynchronizedprintf_       PETSCVIEWERASCIISYNCHRONIZEDPRINTF
40 #define petscpusherrorhandler_        PETSCPUSHERRORHANDLER
41 #define petsctracebackerrorhandler_   PETSCTRACEBACKERRORHANDLER
42 #define petscaborterrorhandler_       PETSCABORTERRORHANDLER
43 #define petscignoreerrorhandler_      PETSCIGNOREERRORHANDLER
44 #define petscemacsclienterrorhandler_ PETSCEMACSCLIENTERRORHANDLER
45 #define petscattachdebuggererrorhandler_   PETSCATTACHDEBUGGERERRORHANDLER
46 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
47 #define petscfopen_                   petscfopen
48 #define petscfprintf_                 petscfprintf
49 #define petscsynchronizedfprintf_     petscsynchronizedfprintf
50 #define petscprintf_                  petscprintf
51 #define petscsynchronizedprintf_      petscsynchronizedprintf
52 #define petscmatlabenginecreate_      petscmatlabenginecreate
53 #define petscmatlabengineevaluate_    petscmatlabengineevaluate
54 #define petscmatlabenginegetoutput_   petscmatlabenginegetoutput
55 #define petscmatlabengineprintoutput_ petscmatlabengineprintoutput
56 #define petscmatlabengineputarray_    petscmatlabengineputarray
57 #define petscmatlabenginegetarray_    petscmatlabenginegetarray
58 #define petscoffsetfortran_        petscoffsetfortran
59 #define chkmemfortran_             chkmemfortran
60 #define petscstrncpy_              petscstrncpy
61 #define petscfixfilename_          petscfixfilename
62 #define petscobjectsetname_        petscobjectsetname
63 #define petscobjectgetcomm_        petscobjectgetcomm
64 #define petscobjectgetname_        petscobjectgetname
65 #define petscgetflops_             petscgetflops
66 #define petscerror_                petscerror
67 #define petscmallocvalidate_       petscmallocvalidate
68 #define petscrealview_             petscrealview
69 #define petscintview_              petscintview
70 #define petscmallocdump_           petscmallocdump
71 #define petscmallocdumplog_        petscmallocdumplog
72 #define petscbinaryopen_           petscbinaryopen
73 #define petscfptrap_               petscfptrap
74 #define petscgetmemoryusage_       petscgetmemoryusage
75 #define petscviewerasciiprintf_    petscviewerasciiprintf
76 #define petscviewerasciisynchronizedprintf_    petscviewerasciisynchronizedprintf
77 #define petscpusherrorhandler_   petscpusherrorhandler
78 #define petsctracebackerrorhandler_   petsctracebackerrorhandler
79 #define petscaborterrorhandler_       petscaborterrorhandler
80 #define petscignoreerrorhandler_      petscignoreerrorhandler
81 #define petscemacsclienterrorhandler_ petscemacsclienterrorhandler
82 #define petscattachdebuggererrorhandler_   petscattachdebuggererrorhandler
83 #endif
84 
85 EXTERN_C_BEGIN
86 static void (PETSC_STDCALL *f2)(int*,const CHAR PETSC_MIXED_LEN(len1),const CHAR PETSC_MIXED_LEN(len2),const CHAR PETSC_MIXED_LEN(len3),int*,int*,const CHAR PETSC_MIXED_LEN(len4),void*,PetscErrorCode* PETSC_END_LEN(len1) PETSC_END_LEN(len2) PETSC_END_LEN(len3) PETSC_END_LEN(len4));
87 EXTERN_C_END
88 
89 /* These are not extern C because they are passed into non-extern C user level functions */
90 static PetscErrorCode ourerrorhandler(int line,const char *fun,const char *file,const char *dir,int n,int p,const char *mess,void *ctx)
91 {
92   PetscErrorCode ierr = 0;
93   size_t len1,len2,len3,len4;
94   int l1,l2,l3,l4;
95 
96   PetscStrlen(fun,&len1); l1 = (int)len1;
97   PetscStrlen(file,&len2);l2 = (int)len2;
98   PetscStrlen(dir,&len3);l3 = (int)len3;
99   PetscStrlen(mess,&len4);l4 = (int)len4;
100 
101 #if defined(PETSC_USES_CPTOFCD)
102  {
103    CHAR fun_c,file_c,dir_c,mess_c;
104 
105    fun_c  = _cptofcd(fun,len1);
106    file_c = _cptofcd(file,len2);
107    dir_c  = _cptofcd(dir,len3);
108    mess_c = _cptofcd(mess,len4);
109    (*f2)(&line,fun_c,file_c,dir_c,&n,&p,mess_c,ctx,&ierr,len1,len2,len3,len4);
110 
111  }
112 #elif defined(PETSC_HAVE_FORTRAN_MIXED_STR_ARG)
113   (*f2)(&line,fun,l1,file,l2,dir,l3,&n,&p,mess,l4,ctx,&ierr);
114 #else
115   (*f2)(&line,fun,file,dir,&n,&p,mess,ctx,&ierr,l1,l2,l3,l4);
116 #endif
117   return ierr;
118 }
119 
120 EXTERN_C_BEGIN
121 /*
122     integer i_x,i_y,shift
123     Vec     x,y
124     PetscScalar  v_x(1),v_y(1)
125 
126     call VecGetArray(x,v_x,i_x,ierr)
127     if (x .eq. y) then
128       call PetscOffsetFortran(y_v,x_v,shift,ierr)
129       i_y = i_x + shift
130     else
131       call VecGetArray(y,v_y,i_y,ierr)
132     endif
133 */
134 
135 /*
136         These are not usually called from Fortran but allow Fortran users
137    to transparently set these monitors from .F code
138 
139    functions, hence no STDCALL
140 */
141 void petsctracebackerrorhandler_(int *line,const char *fun,const char *file,const char *dir,int *n,int *p,const char *mess,void *ctx,PetscErrorCode *ierr)
142 {
143   *ierr = PetscTraceBackErrorHandler(*line,fun,file,dir,*n,*p,mess,ctx);
144 }
145 
146 void petscaborterrorhandler_(int *line,const char *fun,const char *file,const char *dir,int *n,int *p,const char *mess,void *ctx,PetscErrorCode *ierr)
147 {
148   *ierr = PetscAbortErrorHandler(*line,fun,file,dir,*n,*p,mess,ctx);
149 }
150 
151 void petscattachdebuggererrorhandler_(int *line,const char *fun,const char *file,const char *dir,int *n,int *p,const char *mess,void *ctx,PetscErrorCode *ierr)
152 {
153   *ierr = PetscAttachDebuggerErrorHandler(*line,fun,file,dir,*n,*p,mess,ctx);
154 }
155 
156 void petscemacsclienterrorhandler_(int *line,const char *fun,const char *file,const char *dir,int *n,int *p,const char *mess,void *ctx,PetscErrorCode *ierr)
157 {
158   *ierr = PetscEmacsClientErrorHandler(*line,fun,file,dir,*n,*p,mess,ctx);
159 }
160 
161 void petscignoreerrorhandler_(int *line,const char *fun,const char *file,const char *dir,int *n,int *p,const char *mess,void *ctx,PetscErrorCode *ierr)
162 {
163   *ierr = PetscIgnoreErrorHandler(*line,fun,file,dir,*n,*p,mess,ctx);
164 }
165 
166 void PETSC_STDCALL petscpusherrorhandler_(void (PETSC_STDCALL *handler)(int*,const CHAR PETSC_MIXED_LEN(len1),const CHAR PETSC_MIXED_LEN(len2),const CHAR PETSC_MIXED_LEN(len3),int*,int*,const CHAR PETSC_MIXED_LEN(len4),void*,PetscErrorCode* PETSC_END_LEN(len1) PETSC_END_LEN(len2) PETSC_END_LEN(len3) PETSC_END_LEN(len4)),void *ctx,PetscErrorCode *ierr)
167 {
168   if ((void(*)(void))handler == (void(*)(void))petsctracebackerrorhandler_) {
169     *ierr = PetscPushErrorHandler(PetscTraceBackErrorHandler,0);
170   } else {
171     f2    = handler;
172     *ierr = PetscPushErrorHandler(ourerrorhandler,ctx);
173   }
174 }
175 
176 void PETSC_STDCALL petscviewerasciiprintf_(PetscViewer *viewer,CHAR str PETSC_MIXED_LEN(len1),PetscErrorCode *ierr PETSC_END_LEN(len1))
177 {
178   char *c1;
179 
180   FIXCHAR(str,len1,c1);
181   *ierr = PetscViewerASCIIPrintf(*viewer,c1);
182   FREECHAR(str,c1);
183 }
184 
185 void PETSC_STDCALL petscviewerasciisynchronizedprintf_(PetscViewer *viewer,CHAR str PETSC_MIXED_LEN(len1),PetscErrorCode *ierr PETSC_END_LEN(len1))
186 {
187   char *c1;
188 
189   FIXCHAR(str,len1,c1);
190   *ierr = PetscViewerASCIISynchronizedPrintf(*viewer,c1);
191   FREECHAR(str,c1);
192 }
193 
194 void PETSC_STDCALL petscoffsetfortran_(PetscScalar *x,PetscScalar *y,size_t *shift,PetscErrorCode *ierr)
195 {
196   *ierr = 0;
197   *shift = y - x;
198 }
199 
200 void PETSC_STDCALL petscfopen_(MPI_Comm *comm,CHAR fname PETSC_MIXED_LEN(len1),CHAR fmode PETSC_MIXED_LEN(len2),
201                                FILE **file,PetscErrorCode *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
202 {
203   char *c1,*c2;
204 
205   FIXCHAR(fname,len1,c1);
206   FIXCHAR(fmode,len2,c2);
207   *ierr = PetscFOpen((MPI_Comm)PetscToPointerComm(*comm),c1,c2,file);
208   FREECHAR(fname,c1);
209   FREECHAR(fmode,c2);
210 }
211 
212 void PETSC_STDCALL petscfprintf_(MPI_Comm *comm,FILE **file,CHAR fname PETSC_MIXED_LEN(len1),PetscErrorCode *ierr PETSC_END_LEN(len1))
213 {
214   char *c1;
215 
216   FIXCHAR(fname,len1,c1);
217   *ierr = PetscFPrintf((MPI_Comm)PetscToPointerComm(*comm),*file,c1);
218   FREECHAR(fname,c1);
219 }
220 
221 void PETSC_STDCALL petscprintf_(MPI_Comm *comm,CHAR fname PETSC_MIXED_LEN(len1),PetscErrorCode *ierr PETSC_END_LEN(len1))
222 {
223   char *c1;
224 
225   FIXCHAR(fname,len1,c1);
226   *ierr = PetscPrintf((MPI_Comm)PetscToPointerComm(*comm),c1);
227   FREECHAR(fname,c1);
228 }
229 
230 void PETSC_STDCALL petscsynchronizedfprintf_(MPI_Comm *comm,FILE **file,CHAR fname PETSC_MIXED_LEN(len1),PetscErrorCode *ierr PETSC_END_LEN(len1))
231 {
232   char *c1;
233 
234   FIXCHAR(fname,len1,c1);
235   *ierr = PetscSynchronizedFPrintf((MPI_Comm)PetscToPointerComm(*comm),*file,c1);
236   FREECHAR(fname,c1);
237 }
238 
239 void PETSC_STDCALL petscsynchronizedprintf_(MPI_Comm *comm,CHAR fname PETSC_MIXED_LEN(len1),PetscErrorCode *ierr PETSC_END_LEN(len1))
240 {
241   char *c1;
242 
243   FIXCHAR(fname,len1,c1);
244   *ierr = PetscSynchronizedPrintf((MPI_Comm)PetscToPointerComm(*comm),c1);
245   FREECHAR(fname,c1);
246 }
247 
248 void PETSC_STDCALL petscstrncpy_(CHAR s1 PETSC_MIXED_LEN(len1),CHAR s2 PETSC_MIXED_LEN(len2),int *n,
249                                  PetscErrorCode *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
250 {
251   char *t1,*t2;
252   int  m;
253 
254 #if defined(PETSC_USES_CPTOFCD)
255   t1 = _fcdtocp(s1);
256   t2 = _fcdtocp(s2);
257   m = *n; if (_fcdlen(s1) < m) m = _fcdlen(s1); if (_fcdlen(s2) < m) m = _fcdlen(s2);
258 #else
259   t1 = s1;
260   t2 = s2;
261   m = *n; if (len1 < m) m = len1; if (len2 < m) m = len2;
262 #endif
263   *ierr = PetscStrncpy(t1,t2,m);
264 }
265 
266 void PETSC_STDCALL petscfixfilename_(CHAR filein PETSC_MIXED_LEN(len1),CHAR fileout PETSC_MIXED_LEN(len2),
267                                      PetscErrorCode *ierr PETSC_END_LEN(len1) PETSC_END_LEN(len2))
268 {
269   PetscInt  i,n;
270   char *in,*out;
271 
272 #if defined(PETSC_USES_CPTOFCD)
273   in  = _fcdtocp(filein);
274   out = _fcdtocp(fileout);
275   n   = _fcdlen (filein);
276 #else
277   in  = filein;
278   out = fileout;
279   n   = len1;
280 #endif
281 
282   for (i=0; i<n; i++) {
283     if (in[i] == PETSC_REPLACE_DIR_SEPARATOR) out[i] = PETSC_DIR_SEPARATOR;
284     else out[i] = in[i];
285   }
286   out[i] = 0;
287 }
288 
289 void PETSC_STDCALL petscbinaryopen_(CHAR name PETSC_MIXED_LEN(len),PetscViewerFileType *type,int *fd,
290                                     PetscErrorCode *ierr PETSC_END_LEN(len))
291 {
292   char *c1;
293 
294   FIXCHAR(name,len,c1);
295   *ierr = PetscBinaryOpen(c1,*type,fd);
296   FREECHAR(name,c1);
297 }
298 
299 /* ---------------------------------------------------------------------------------*/
300 void PETSC_STDCALL  petscmallocdump_(PetscErrorCode *ierr)
301 {
302   *ierr = PetscMallocDump(stdout);
303 }
304 void PETSC_STDCALL petscmallocdumplog_(PetscErrorCode *ierr)
305 {
306   *ierr = PetscMallocDumpLog(stdout);
307 }
308 
309 /*
310         This version does not do a malloc
311 */
312 static char FIXCHARSTRING[1024];
313 #if defined(PETSC_USES_CPTOFCD)
314 #include <fortran.h>
315 
316 #define CHAR _fcd
317 #define FIXCHARNOMALLOC(a,n,b) \
318 { \
319   b = _fcdtocp(a); \
320   n = _fcdlen (a); \
321   if (b == PETSC_NULL_CHARACTER_Fortran) { \
322       b = 0; \
323   } else {  \
324     while((n > 0) && (b[n-1] == ' ')) n--; \
325     b = FIXCHARSTRING; \
326     *ierr = PetscStrncpy(b,_fcdtocp(a),n); \
327     if (*ierr) return; \
328     b[n] = 0; \
329   } \
330 }
331 
332 #else
333 
334 #define CHAR char*
335 #define FIXCHARNOMALLOC(a,n,b) \
336 {\
337   if (a == PETSC_NULL_CHARACTER_Fortran) { \
338     b = a = 0; \
339   } else { \
340     while((n > 0) && (a[n-1] == ' ')) n--; \
341     if (a[n] != 0) { \
342       b = FIXCHARSTRING; \
343       *ierr = PetscStrncpy(b,a,n); \
344       if (*ierr) return; \
345       b[n] = 0; \
346     } else b = a;\
347   } \
348 }
349 
350 #endif
351 
352 void PETSC_STDCALL chkmemfortran_(int *line,CHAR file PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
353 {
354   char *c1;
355 
356   FIXCHARNOMALLOC(file,len,c1);
357   *ierr = PetscMallocValidate(*line,"Userfunction",c1," ");
358 }
359 
360 void PETSC_STDCALL petscmallocvalidate_(PetscErrorCode *ierr)
361 {
362   *ierr = PetscMallocValidate(0,"Unknown Fortran",0,0);
363 }
364 
365 void PETSC_STDCALL petscobjectgetname_(PetscObject *obj,CHAR name PETSC_MIXED_LEN(len),
366                                        PetscErrorCode *ierr PETSC_END_LEN(len))
367 {
368   const char *tmp;
369   *ierr = PetscObjectGetName(*obj,&tmp);
370 #if defined(PETSC_USES_CPTOFCD)
371   {
372   char *t = _fcdtocp(name);
373   int  len1 = _fcdlen(name);
374   *ierr = PetscStrncpy(t,tmp,len1);if (*ierr) return;
375   }
376 #else
377   *ierr = PetscStrncpy(name,tmp,len);if (*ierr) return;
378 #endif
379 }
380 
381 void PETSC_STDCALL petscobjectgetcomm_(PetscObject *obj,int *comm,PetscErrorCode *ierr)
382 {
383   MPI_Comm c;
384   *ierr = PetscObjectGetComm(*obj,&c);
385   *(int*)comm = PetscFromPointerComm(c);
386 }
387 
388 void PETSC_STDCALL petscobjectsetname_(PetscObject *obj,CHAR name PETSC_MIXED_LEN(len),
389                                        PetscErrorCode *ierr PETSC_END_LEN(len))
390 {
391   char *t1;
392 
393   FIXCHAR(name,len,t1);
394   *ierr = PetscObjectSetName(*obj,t1);
395   FREECHAR(name,t1);
396 }
397 
398 void PETSC_STDCALL petscerror_(int *number,int *p,CHAR message PETSC_MIXED_LEN(len),
399                                PetscErrorCode *ierr PETSC_END_LEN(len))
400 {
401   char *t1;
402   FIXCHAR(message,len,t1);
403   *ierr = PetscError(-1,0,0,0,*number,*p,t1);
404   FREECHAR(message,t1);
405 }
406 
407 void PETSC_STDCALL petscgetflops_(PetscLogDouble *d,PetscErrorCode *ierr)
408 {
409 #if defined(PETSC_USE_LOG)
410   *ierr = PetscGetFlops(d);
411 #else
412   ierr = 0;
413   *d     = 0.0;
414 #endif
415 }
416 
417 void PETSC_STDCALL petscrealview_(PetscInt *n,PetscReal *d,int *viwer,PetscErrorCode *ierr)
418 {
419   *ierr = PetscRealView(*n,d,0);
420 }
421 
422 void PETSC_STDCALL petscintview_(PetscInt *n,PetscInt *d,int *viwer,PetscErrorCode *ierr)
423 {
424   *ierr = PetscIntView(*n,d,0);
425 }
426 
427 #if defined(PETSC_HAVE_MATLAB) && !defined(PETSC_USE_COMPLEX) && !defined(PETSC_USE_SINGLE) && !defined(PETSC_USE_MAT_SINGLE)
428 
429 void PETSC_STDCALL petscmatlabenginecreate_(MPI_Comm *comm,CHAR m PETSC_MIXED_LEN(len),PetscMatlabEngine *e,
430                                             PetscErrorCode *ierr PETSC_END_LEN(len))
431 {
432   char *ms;
433 
434   FIXCHAR(m,len,ms);
435   *ierr = PetscMatlabEngineCreate((MPI_Comm)PetscToPointerComm(*comm),ms,e);
436   FREECHAR(m,ms);
437 }
438 
439 void PETSC_STDCALL petscmatlabengineevaluate_(PetscMatlabEngine *e,CHAR m PETSC_MIXED_LEN(len),
440                                               PetscErrorCode *ierr PETSC_END_LEN(len))
441 {
442   char *ms;
443   FIXCHAR(m,len,ms);
444   *ierr = PetscMatlabEngineEvaluate(*e,ms);
445   FREECHAR(m,ms);
446 }
447 
448 void PETSC_STDCALL petscmatlabengineputarray_(PetscMatlabEngine *e,PetscInt *m,PetscInt *n,PetscScalar *a,
449                                               CHAR s PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
450 {
451   char *ms;
452   FIXCHAR(s,len,ms);
453   *ierr = PetscMatlabEnginePutArray(*e,*m,*n,a,ms);
454   FREECHAR(s,ms);
455 }
456 
457 void PETSC_STDCALL petscmatlabenginegetarray_(PetscMatlabEngine *e,PetscInt *m,PetscInt *n,PetscScalar *a,
458                                               CHAR s PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
459 {
460   char *ms;
461   FIXCHAR(s,len,ms);
462   *ierr = PetscMatlabEngineGetArray(*e,*m,*n,a,ms);
463   FREECHAR(s,ms);
464 }
465 
466 #endif
467 /*
468 EXTERN int PetscMatlabEngineGetOutput(PetscMatlabEngine,char **);
469 EXTERN int PetscMatlabEnginePrintOutput(PetscMatlabEngine,FILE*);
470 */
471 
472 EXTERN_C_END
473 
474 
475