f2clib.c 1.2 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485
  1. /*
  2. $Log$
  3. Revision 1.14 2003/02/12 13:59:15 matteo
  4. mer feb 12 14:56:57 CET 2003
  5. Revision 1.1.1.1 2003/02/12 13:59:15 matteo
  6. mer feb 12 14:56:57 CET 2003
  7. Revision 1.2 2000/01/05 08:20:39 markster
  8. Some OSS fixes and a few lpc changes to make it actually work
  9. * Revision 1.1 1996/08/19 22:32:10 jaf
  10. * Initial revision
  11. *
  12. */
  13. /*
  14. * f2clib.c
  15. *
  16. * SCCS ID: @(#)f2clib.c 1.2 96/05/19
  17. */
  18. #include "f2c.h"
  19. #ifdef KR_headers
  20. integer pow_ii(ap, bp) integer *ap, *bp;
  21. #else
  22. integer pow_ii(integer *ap, integer *bp)
  23. #endif
  24. {
  25. integer pow, x, n;
  26. unsigned long u;
  27. x = *ap;
  28. n = *bp;
  29. if (n <= 0) {
  30. if (n == 0 || x == 1)
  31. return 1;
  32. if (x != -1)
  33. return x == 0 ? 0 : 1/x;
  34. n = -n;
  35. }
  36. u = n;
  37. for(pow = 1; ; )
  38. {
  39. if(u & 01)
  40. pow *= x;
  41. if(u >>= 1)
  42. x *= x;
  43. else
  44. break;
  45. }
  46. return(pow);
  47. }
  48. #ifdef KR_headers
  49. double r_sign(a,b) real *a, *b;
  50. #else
  51. double r_sign(real *a, real *b)
  52. #endif
  53. {
  54. double x;
  55. x = (*a >= 0 ? *a : - *a);
  56. return( *b >= 0 ? x : -x);
  57. }
  58. #ifdef KR_headers
  59. double floor();
  60. integer i_nint(x) real *x;
  61. #else
  62. #undef abs
  63. #include "math.h"
  64. integer i_nint(real *x)
  65. #endif
  66. {
  67. return( (integer)((*x)>=0 ?
  68. floor(*x + .5) : -floor(.5 - *x)) );
  69. }