xwsne.c 1.1 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677
  1. #include "f2c.h"
  2. #include "fio.h"
  3. #include "lio.h"
  4. #include "fmt.h"
  5. extern int f__Aquote;
  6. static VOID
  7. nl_donewrec(Void)
  8. {
  9. (*f__donewrec)();
  10. PUT(' ');
  11. }
  12. #ifdef KR_headers
  13. x_wsne(a) cilist *a;
  14. #else
  15. #include "string.h"
  16. #ifdef __cplusplus
  17. extern "C" {
  18. #endif
  19. VOID
  20. x_wsne(cilist *a)
  21. #endif
  22. {
  23. Namelist *nl;
  24. char *s;
  25. Vardesc *v, **vd, **vde;
  26. ftnint number, type;
  27. ftnlen *dims;
  28. ftnlen size;
  29. extern ftnlen f__typesize[];
  30. nl = (Namelist *)a->cifmt;
  31. PUT('&');
  32. for(s = nl->name; *s; s++)
  33. PUT(*s);
  34. PUT(' ');
  35. f__Aquote = 1;
  36. vd = nl->vars;
  37. vde = vd + nl->nvars;
  38. while(vd < vde) {
  39. v = *vd++;
  40. s = v->name;
  41. #ifdef No_Extra_Namelist_Newlines
  42. if (f__recpos+strlen(s)+2 >= L_len)
  43. #endif
  44. nl_donewrec();
  45. while(*s)
  46. PUT(*s++);
  47. PUT(' ');
  48. PUT('=');
  49. number = (dims = v->dims) ? dims[1] : 1;
  50. type = v->type;
  51. if (type < 0) {
  52. size = -type;
  53. type = TYCHAR;
  54. }
  55. else
  56. size = f__typesize[type];
  57. l_write(&number, v->addr, size, type);
  58. if (vd < vde) {
  59. if (f__recpos+2 >= L_len)
  60. nl_donewrec();
  61. PUT(',');
  62. PUT(' ');
  63. }
  64. else if (f__recpos+1 >= L_len)
  65. nl_donewrec();
  66. }
  67. f__Aquote = 0;
  68. PUT('/');
  69. }
  70. #ifdef __cplusplus
  71. }
  72. #endif