home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume20 / cfortran / part01 / cfortest.c next >
Encoding:
C/C++ Source or Header  |  1991-06-26  |  8.8 KB  |  332 lines
  1. /* cfortex.c */
  2. /* Burkhard Burow, burow%13313.hepnet@csa3.lbl.gov, U. of Toronto, 1991. */
  3.  
  4. #include <stdio.h>
  5. #include "cfortran.h"
  6.  
  7. #define   EQ_SELECT 1   /* To see the various examples select one of:
  8.         EASY_SELECT,  ST_SELECT, FT_SELECT, S1_SELECT, ABC_SELECT,  R_SELECT,
  9.          REV_SELECT, FCB_SELECT, EQ_SELECT, F0_SELECT,  FA_SELECT, FB_SELECT,
  10.           FC_SELECT,  FD_SELECT, FE_SELECT, FF_SELECT,  FG_SELECT, FH_SELECT,
  11.           FI_SELECT,  FJ_SELECT. */
  12.  
  13. #ifdef EASY_SELECT
  14. PROTOCCALLSFSUB2(easy,PINT,INT)
  15. #define EASY(A,B)      CCALLSFSUB2(easy,PINT,INT, A,B)
  16.  
  17. main() {
  18. int a;
  19. printf("\nEASY EXAMPLE\n");
  20. EASY(a,7);
  21. printf("The FORTRAN routine easy(a,7) returns a = %d\n", a);
  22. }
  23. #endif
  24.  
  25. #ifdef ST_SELECT
  26. PROTOCCALLSFSUB3(st,PSTRINGV,STRINGV,FLOAT)
  27. #define ST(A,B,C) CCALLSFSUB3(st,PSTRINGV,STRINGV,FLOAT,A,B,C)
  28.  
  29. int main() {
  30. static char v[][5] = {"000 ", "1", "22", " "};
  31. static char w[][9]  = {" ", "bb","ccc ","dddd"};
  32. ST(v, w, 10.);
  33. printf("main:v=%s,%s,%s,%s. PSTRINGV => Has had trailing blanks stripped.\n",
  34.        v[0],v[1],v[2],v[3]);
  35. printf("main:w=%s,%s,%s,%s. STRINGV => malloc'd copy for FORTRAN=> C intact.\n"
  36.        ,w[0],w[1],w[2],w[3]);
  37. }
  38. #endif
  39.  
  40. #ifdef FT_SELECT
  41. PROTOCCALLSFFUN3(STRING,ft,PSTRINGV,STRINGV,FLOAT)
  42. #define FT(A,B,C) CCALLSFFUN3(ft,PSTRINGV,STRINGV,FLOAT,A,B,C)
  43.  
  44. main() {
  45. static char v[][5] = {"000 ", "1", "22", " "};
  46. static char w[][9]  = {" ", "bb","ccc ","dddd"};
  47. float a = 10.0;
  48. printf("FT(v, w, a); returns:%s.\n",FT(v, w, a));
  49. printf("main:v=%s,%s,%s,%s. PSTRINGV => Has had trailing blanks stripped.\n",
  50.        v[0],v[1],v[2],v[3]);
  51. printf("main:w=%s,%s,%s,%s. STRINGV => malloc'd copy for FORTRAN=> C intact.\n"
  52.        ,w[0],w[1],w[2],w[3]);
  53. }
  54. #endif
  55.  
  56. #ifdef S1_SELECT
  57. PROTOCCALLSFSUB1(s1,PSTRING)
  58. #define S1(A1)              CCALLSFSUB1(s1,PSTRING,A1)
  59. PROTOCCALLSFSUB1(forstr1,PSTRING)
  60. #define FORSTR1(A1)         CCALLSFSUB1(forstr1,PSTRING,A1)
  61.  
  62. main() {
  63. static char b[] = "abcdefghij", forb[13] = "abcdefghijkl";
  64. S1(b); FORSTR1(forb);
  65. printf("s1(b) returns b = %s; forstr1(forb) = returns forb = %s;\n", b, forb);
  66. }
  67. #endif
  68.  
  69. #ifdef ABC_SELECT
  70. PROTOCCALLSFSUB3(abc,STRING,PSTRING,PSTRING)
  71. #define ABC(A1,A2,A3)       CCALLSFSUB3(abc,STRING,PSTRING,PSTRING,A1,A2,A3)
  72.  
  73. main() {
  74. static char aa[] = "one  ", bb[] = "two  ", cc[] = "three"; int i;
  75. for (i=0; i<10; i++) {printf("%s;%s;%s;\n",aa,bb,cc); ABC(aa,bb,cc);}
  76. }
  77. #endif
  78.  
  79. #ifdef R_SELECT
  80. PROTOCCALLSFFUN1(FLOAT,r,INT)
  81. #define R(A1)               CCALLSFFUN1(r,INT,A1)
  82. PROTOCCALLSFFUN0(STRING,forstr2)
  83. #define FORSTR2()           CCALLSFFUN0(forstr2)
  84. PROTOCCALLSFFUN1(STRING,forstr,STRING)
  85. #define FORSTR(A1)          CCALLSFFUN1(forstr,STRING,A1)
  86.  
  87. main() {
  88. static char aa[] = "one";
  89. int rrr = 333;
  90. printf("R(rrr=%d) returns int arg. as float:%f\n",rrr,R(rrr));
  91. printf("FORSTR(aa=%s) returns the string arg. as:%s<-end here\n",aa,FORSTR(aa));
  92. printf("FORSTR2() returns the string constant:%s<-end here\n",FORSTR2());
  93. }
  94. #endif
  95.  
  96. #ifdef REV_SELECT
  97. PROTOCCALLSFFUN1(INT,frev,INTV)
  98. #define FREV(A1)               CCALLSFFUN1(frev,INTV,A1)
  99. PROTOCCALLSFSUB1(rev,INTV)
  100. #define REV(A1)                CCALLSFSUB1(rev,INTV,A1)
  101.  
  102. main() {
  103. static int a[] = {1,2};
  104. printf("REV(a[0,1]=%d,%d) returns:",a[0],a[1]);
  105. REV(a); printf("a[0,1]=%d,%d\n",a[0],a[1]);
  106. printf("FREV(a[0,1]=%d,%d) returns:",a[0],a[1]);
  107. printf("%d",FREV(a)); printf(" with a[0,1]=%d,%d\n",a[0],a[1]);
  108. }
  109. #endif
  110.  
  111. #ifdef FCB_SELECT
  112. PROTOCCALLSFSUB0(ffcb)
  113. #define FFCB()                 CCALLSFSUB0(ffcb)
  114.  
  115. typedef struct { char v[13],w[4][13],x[2][3][13]; } FCB_DEF;
  116. #define FCB COMMON_BLOCK(fcb)
  117. extern FCB_DEF FCB;
  118.  
  119. main() {
  120. char cv[14];
  121. static char cw[4][14]    = {"C's w[0]", "C's w[1]", "C's w[2]", "C's w[3]"};
  122. static char cx[2][3][14] = {"C's x[0][0]", "C's x[0][1]", "C's x[0][2]",
  123.                             "C's x[1][0]", "C's x[1][1]", "C's x[1][2]"};
  124. C2FCBSTR("C's V" ,FCB.v,0);
  125. C2FCBSTR(cw      ,FCB.w,1);
  126. C2FCBSTR(cx      ,FCB.x,2);
  127. FFCB();
  128. FCB2CSTR(FCB.v   ,cv   ,0);
  129. FCB2CSTR(FCB.w   ,cw   ,1);
  130. FCB2CSTR(FCB.x   ,cx   ,2);
  131. printf("FCB returns v = %s.\n",cv);
  132. printf("FCB returns w[1,2,3,4] = %s,%s,%s,%s.\n",cw[0],cw[1],cw[2],cw[3]);
  133. printf("FCB returns x[0,(1,2,3)] = %s,%s,%s.\n",cx[0][0],cx[0][1],cx[0][2]);
  134. printf("FCB returns x[1,(1,2,3)] = %s,%s,%s.\n",cx[1][0],cx[1][1],cx[1][2]);
  135. }
  136. #endif
  137.  
  138. #ifdef EQ_SELECT
  139. PROTOCCALLSFSUB0(feq)
  140. #define FEQ()                 CCALLSFSUB0(feq)
  141.  
  142. #define KWBANK 690
  143. typedef struct {
  144.   int nzebra; float gversn,zversn; int ixstor,ixdiv,ixcons; float fendq[16];
  145.   union {
  146.     struct {
  147.       int Lmain,Lr1;
  148.       union {float Ws[KWBANK]; int Iws[2];}u;
  149.     }s;
  150.     union {
  151.       int Lq[80];
  152.       struct {
  153.         int dummy[8];
  154.         union {float Q[2]; int Iq[2];}u;
  155.       }s;
  156.     }u;
  157.   }u;
  158. } GCBANK_DEF;
  159. #define lmain u.s.Lmain
  160. #define lr1   u.s.Lr1
  161. #define ws    u.s.u.Ws
  162. #define iws   u.s.u.Iws
  163. #define lq    u.u.Lq
  164. #define q     u.u.s.u.Q
  165. #define iq    u.u.s.u.Iq
  166. #define GCBANK COMMON_BLOCK(gcbank)
  167. GCBANK_DEF GCBANK;
  168.  
  169. main() {
  170. FEQ();
  171. printf("GCBANK.nzebra       = %d.\n", GCBANK.nzebra);
  172. printf("GCBANK.gversn       = %f.\n", GCBANK.gversn);
  173. printf("GCBANK.zversn       = %f.\n", GCBANK.zversn);
  174. printf("GCBANK.ixstor       = %d.\n", GCBANK.ixstor);
  175. printf("GCBANK.ixcons       = %d.\n", GCBANK.ixcons);
  176. printf("GCBANK.fendq[15]    = %f.\n", GCBANK.fendq[15]);
  177. printf("GCBANK.lmain        = %d.\n", GCBANK.lmain);
  178. printf("GCBANK.lr1          = %d.\n", GCBANK.lr1);
  179. printf("GCBANK.ws[KWBANK-1] = %f.\n", GCBANK.ws[KWBANK-1]);
  180. printf("GCBANK.iq[0]        = %d.\n", GCBANK.iq[0]);
  181. }
  182. #endif
  183.  
  184. /* The following functions are called by FORTRAN functions, as shown by the
  185.    remaining examples.
  186.    We redefine the C name of each routine called from FORTRAN so that the
  187.    FORTRAN call may use the C name, e.g. the next line. */
  188. #define EXIST ccallsc(exist)
  189. void EXIST() {printf("EXIST: was called.\n");}
  190. FCALLSCSUB0(exist)
  191.  
  192. #define CA ccallsc(ca)
  193. void CA(int i) {printf("CA: had integer argument:%d.\n",i);}
  194. FCALLSCSUB1(ca,INT)
  195.  
  196. #define CB ccallsc(cb)
  197. void CB(int *i) {
  198. printf("CB: had pointer argument to integer:%d.\n",*i); *i*=2;}
  199. FCALLSCSUB1(cb,PINT)
  200.  
  201. #define CC ccallsc(cc)
  202. void CC(char *s) {printf("CC: had string argument:%s.\n",s);}
  203. FCALLSCSUB1(cc,STRING)
  204.  
  205. #define CD ccallsc(cd)
  206. void CD(char *s)
  207. {printf("CD: had string argument:%s.\n",s); strcpy(s,"to you 12345678");}
  208. FCALLSCSUB1(cd,PSTRING)
  209.  
  210. #define CE ccallsc(ce)
  211. void CE(char v[][5])
  212. {printf("CE: had string vector argument:%s,%s,%s.\n",v[0],v[1],v[2]);}
  213. #define ce_STRV_A1 TERM_CHARS(' ',1)
  214. FCALLSCSUB1(ce,STRINGV)
  215.  
  216. #define CF ccallsc(cf)
  217. void CF(char v[][5], int n)
  218. {int i;
  219. printf("CF: had %d string vector argument:",n);
  220. for (i=0; i<n-1; i++) printf("%s,",v[i]);
  221. printf("%s.\n",v[i]);
  222. }
  223. #define cf_STRV_A1 NUM_ELEM_ARG(2)
  224. FCALLSCSUB2(cf,STRINGV,INT)
  225.  
  226.  
  227. #define CG ccallsc(cg)
  228. int CG() {return 1;}
  229. FCALLSCFUN0(INT,cg)
  230.  
  231. #define CH ccallsc(ch)
  232. char *CH() {return "hello";}
  233. FCALLSCFUN0(STRING,ch)
  234.  
  235. #define CI ccallsc(ci)
  236. char *CI(char v[][5]) {return v[3];}
  237. #define ci_STRV_A1 NUM_ELEMS(6)
  238. FCALLSCFUN1(STRING,ci,STRINGV)
  239.  
  240. #define CJ ccallsc(cj)
  241. char *CJ(int v) {printf("CJ:v=%d\n",v);return "hello";}
  242. FCALLSCFUN1(STRING,cj,INT)
  243.  
  244. #ifdef F0_SELECT
  245. PROTOCCALLSFSUB0(fexist)
  246. #define FEXIST()               CCALLSFSUB0(fexist)
  247.  
  248. main() {FEXIST();}
  249. #endif
  250.  
  251. #ifdef FA_SELECT
  252. PROTOCCALLSFSUB1(fa,INT)
  253. #define FA(A1)               CCALLSFSUB1(fa,INT,A1)
  254.  
  255. main() {FA(1234);}
  256. #endif
  257.  
  258. #ifdef FB_SELECT
  259. PROTOCCALLSFSUB1(fb,PINT)
  260. #define FB(A1)               CCALLSFSUB1(fb,PINT,A1)
  261.  
  262. main()
  263. {int i,ii; i=ii=1234;
  264.  FB(ii); printf("MAIN: FB(i=%d) returns with i=%d.\n",i,ii);}
  265. #endif
  266.  
  267. #ifdef FC_SELECT
  268. PROTOCCALLSFSUB1(fc,STRING)
  269. #define FC(A1)               CCALLSFSUB1(fc,STRING,A1)
  270.  
  271. main() {FC("hello");}
  272. #endif
  273.  
  274. #ifdef FD_SELECT
  275. PROTOCCALLSFSUB1(fd,PSTRING)
  276. #define FD(A1)               CCALLSFSUB1(fd,PSTRING,A1)
  277.  
  278. main()
  279. {static char i[] = "happy     "; static char ii[] = "happy      ";
  280.  FD(ii); printf("MAIN: FD(i=%s) returns with i=%s.\n",i,ii);}
  281. #endif
  282.  
  283. #ifdef FE_SELECT
  284. PROTOCCALLSFSUB1(fe,STRINGV)
  285. #define FE(A1)               CCALLSFSUB1(fe,STRINGV,A1)
  286.  
  287. main()
  288. {static char v[][5] = {"0000", "1", "22", ""}; FE(v);}
  289. #endif
  290.  
  291. #ifdef FF_SELECT
  292. PROTOCCALLSFSUB2(ff,STRINGV,INT)
  293. #define FF(A1,A2)               CCALLSFSUB2(ff,STRINGV,INT, A1,A2)
  294.  
  295. main()
  296. {static char v[][5] = {"0000", "1", "22", ""};
  297.  FF(v,sizeof(v)/sizeof v[0]);}
  298. #endif
  299.  
  300. #ifdef FG_SELECT
  301. PROTOCCALLSFFUN0(INT,fg)
  302. #define FG()               CCALLSFFUN0(fg)
  303.  
  304. main()
  305. {printf("FG() returns %d.\n",FG());}
  306. #endif
  307.  
  308. #ifdef FH_SELECT
  309. PROTOCCALLSFFUN0(STRING,fh)
  310. #define FH()               CCALLSFFUN0(fh)
  311.  
  312. main()
  313. {printf("FH() returns %s.\n",FH());}
  314. #endif
  315.  
  316. #ifdef FI_SELECT
  317. PROTOCCALLSFFUN1(STRING,fi,STRINGV)
  318. #define FI(A1)               CCALLSFFUN1(fi,STRINGV,A1)
  319.  
  320. main()
  321. {static char v[][5] = {"0000", "1", "22", "333", "8", "9"};
  322.  printf("FI(v) returns %s.\n",FI(v));}
  323. #endif
  324.  
  325. #ifdef FJ_SELECT
  326. PROTOCCALLSFFUN1(STRING,fj,INT)
  327. #define FJ(A1)               CCALLSFFUN1(fj,INT,A1)
  328.  
  329. main()
  330. { printf("FJ(2) returns %s.\n",FJ(2));}
  331. #endif
  332.