subroutine msetup (ndig) c c initialize for precision of ndig decimal digits. NDIG c must be .le. 200 for the given register array R. c common /mpcom / b, t, m, lun, mxr, ipar(18) common // r(3277) integer b, t, m, lun, mxr, r c call mpset (6, ndig, 1000, 3277) c nd = float(t-1) * alog10(float(b)) + 0.5 write (lun, 10) nd, b, t, m, lun, mxr 10 format ('1 multiple precision package initialized with' 1 //1x, i10, ' Decimal digits precision' 2 /1x, i10, ' Base' 3 /1x, i10, ' Words of precision' 4 /1x, i10, ' Maximum exponent' 5 /1x, i10, ' Standard output unit' 6 /1x, i10, ' Words in register storage') c return end subroutine mcopy (ix, iz) common /cstak / istak(1000) call mpstr (istak(ix), istak(iz)) return end subroutine malc (ix) common /mpcom / b, t, m, lun, mxr, ipar(18) integer b, t, m, lun, mxr ix = istkgt (t+2, 2) return end subroutine malcp (ix) c allocate permanent storage for the multiple precision number at the c top of the stack. c common /mpcom / b, t, m, lun, mxr, ipar(18) integer b, t, m, lun, mxr ix = istkgt (t+2, -2) return end subroutine mdalc (ix) call istkrl (1) return end subroutine maalc (ix, n) common /mpcom / b, t, m, lun, mxr, ipar(18) integer b, t, m, lun, mxr, ix(n) c if (n.lt.1) call seterr (17hmaalc n is lt 0, 17, 1, 2) c len = (t+2)*n ix(1) = istkgt (len, 2) c if (n.lt.2) return do 10 i=2,n ix(i) = ix(i-1) + t + 2 10 continue c return end subroutine maalcp (ix, n) common /mpcom / b, t, m, lun, mxr, ipar(18) integer b, t, m, lun, mxr, ix(n) c if (n.lt.1) call seterr (17hmaalcp n is lt 0, 17, 1, 2) c len = (t+2)*n ix(1) = istkgt (len, -2) c if (n.lt.2) return do 10 i=2,n ix(i) = ix(i-1) + t + 2 10 continue c return end subroutine madalc (ix, n) integer ix(n) call istkrl (1) return end subroutine mitom (intger, iz) common /cstak / istak(1000) call mpcim (intger, istak(iz)) return end subroutine metom (r, iz) common /cstak / istak(1000) call mpcrm (r, istak(iz)) return end subroutine mdtom (d, iz) common /cstak / istak(1000) double precision d call mpcdm (d, istak(iz)) return end subroutine mhtom (h, iz) common /cstak / istak(1000) integer h(1) call mpcam (h, istak(iz)) return end integer function mmtoi (ix) common /cstak / istak(1000) call mpcmi (istak(ix), intger) mmtoi = intger return end real function mmtoe (ix) common /cstak / istak(1000) double precision d call mpcmd (istak(ix), d) mmtoe = d return end double precision function mmtod (ix) common /cstak / istak(1000) double precision d call mpcmd (istak(ix), d) mmtod = d return end subroutine madd (ix, iy, iz) common /cstak / istak(1000) call mpadd (istak(ix), istak(iy), istak(iz)) return end subroutine msub (ix, iy, iz) common /cstak / istak(1000) call mpsub (istak(ix), istak(iy), istak(iz)) return end subroutine mneg (ix, iz) common /cstak / istak(1000) call mpneg (istak(ix), istak(iz)) return end subroutine mmul (ix, iy, iz) common /cstak / istak(1000) call mpmul (istak(ix), istak(iy), istak(iz)) return end subroutine mmul1 (intger, iy, iz) common /cstak / istak(1000) call mpmuli (istak(iy), intger, istak(iz)) return end subroutine mmul2 (ix, intger, iz) common /cstak / istak(1000) call mpmuli (istak(ix), intger, istak(iz)) return end subroutine mdiv (ix, iy, iz) common /cstak / istak(1000) call mpdiv (istak(ix), istak(iy), istak(iz)) return end subroutine mdivi (ix, intger, iz) common /cstak / istak(1000) call mpdivi (istak(ix), intger, istak(iz)) return end subroutine mmexm (ix, iy, iz) common /cstak / istak(1000) call mppwr2 (istak(ix), istak(iy), istak(iz)) return end subroutine mmexi (ix, intger, iz) common /cstak / istak(1000) call mppwr (istak(ix), intger, istak(iz)) return end logical function mlt (ix, iy) common /cstak / istak(1000) logical mplt mlt = mplt (istak(ix), istak(iy)) return end logical function mle (ix, iy) common /cstak / istak(1000) logical mple mle = mple (istak(ix), istak(iy)) return end logical function meq (ix, iy) common /cstak / istak(1000) logical mpeq meq = mpeq (istak(ix), istak(iy)) return end logical function mne (ix, iy) common /cstak / istak(1000) logical mpne mne = mpne (istak(ix), istak(iy)) return end logical function mge (ix, iy) common /cstak / istak(1000) logical mpge mge = mpge (istak(ix), istak(iy)) return end logical function mgt (ix, iy) common /cstak / istak(1000) logical mpgt mgt = mpgt (istak(ix), istak(iy)) return end subroutine mabs (ix, iz) common /cstak / istak(1000) call mpabs (istak(ix), istak(iz)) return end subroutine mint (ix, iz) common /cstak / istak(1000) call mpcmim (istak(ix), istak(iz)) return end subroutine mmod (ix, iy, iz) common /cstak / istak(1000) call mpmod (istak(ix), istak(iy), istak(iz)) return end subroutine msign (ix, iy, iz) common /cstak / istak(1000) call mpsign (istak(ix), istak(iy), istak(iz)) return end subroutine mmax1 (ix, iy, iz) common /cstak / istak(1000) call mpmax (istak(ix), istak(iy), istak(iz)) return end subroutine mmin1 (ix, iy, iz) common /cstak / istak(1000) call mpmin (istak(ix), istak(iy), istak(iz)) return end subroutine mdim (ix, iy, iz) common /cstak / istak(1000) call mpdim (istak(ix), istak(iy), istak(iz)) return end subroutine mpi (intger, iz) common /cstak / istak(1000) call mppi (istak(iz)) return end subroutine meul (intger, iz) common /cstak / istak(1000) call mpeul (istak(iz)) return end subroutine msqrt (ix, iz) common /cstak / istak(1000) call mpsqrt (istak(ix), istak(iz)) return end subroutine mlog (ix, iz) common /cstak / istak(1000) call mpln (istak(ix), istak(iz)) return end subroutine mlog10 (ix, iz) common /cstak / istak(1000) call mplg10 (istak(ix), istak(iz)) return end subroutine mexp (ix, iz) common /cstak / istak(1000) call mpexp (istak(ix), istak(iz)) return end subroutine msin (ix, iz) common /cstak / istak(1000) call mpsin (istak(ix), istak(iz)) return end subroutine mcos (ix, iz) common /cstak / istak(1000) call mpcos (istak(ix), istak(iz)) return end subroutine mtan (ix, iz) common /cstak / istak(1000) call mptan (istak(ix), istak(iz)) return end subroutine macos (ix, iz) common /cstak / istak(1000) c call malc (ipi) call mpi (0, ipi) call mdivi (ipi, 2, ipi) call masin (ix, iz) call msub (ipi, iz, iz) call mdalc (ipi) c return end subroutine masin (ix, iz) common /cstak / istak(1000) call mpasin (istak(ix), istak(iz)) return end subroutine matan2 (isn, ics, iz) common /cstak / istak(1000) logical mle c call malc (ipi) call mpi (0, ipi) if (istak(ics).eq.0) go to 20 c call malc (itmp) call mdiv (isn, ics, itmp) call matan (itmp, itmp) c if (istak(ics).lt.0) call madd (itmp, ipi, itmp) c if (mle(itmp, ipi)) go to 10 call mmul1 (2, ipi, ipi) call msub (itmp, ipi, itmp) c 10 call mcopy (itmp, iz) call mdalc (itmp) call mdalc (ipi) return c 20 if (istak(isn).eq.0) call seterr ( 1 31hmatan2 both arguments are zero, 31, 1, 2) c call mdivi (ipi, 2, ipi) call msign (ipi, isn, iz) call mdalc (ipi) return c end subroutine matan (ix, iz) common /cstak / istak(1000) call mpatan (istak(ix), istak(iz)) return end subroutine msinh (ix, iz) common /cstak / istak(1000) call mpsinh (istak(ix), istak(iz)) return end subroutine mcosh (ix, iz) common /cstak / istak(1000) call mpcosh (istak(ix), istak(iz)) return end subroutine mrec (ix, iz) common /cstak / istak(1000) call mprec (istak(ix), istak(iz)) return end subroutine mgamma (ix, iz) common /cstak / istak(1000) call mpgam (istak(ix), istak(iz)) return end subroutine merf (ix, iz) common /cstak / istak(1000) call mperf (istak(ix), istak(iz)) return end subroutine merfc (ix, iz) common /cstak / istak(1000) call mperfc (istak(ix), istak(iz)) return end subroutine mdaw (ix, iz) common /cstak / istak(1000) call mpdaw (istak(ix), istak(iz)) return end subroutine mei (ix, iz) common /cstak / istak(1000) call mpei (istak(ix), istak(iz)) return end subroutine mli (ix, iz) common /cstak / istak(1000) call mpli (istak(ix), istak(iz)) return end subroutine moutf (ix, c, iwid, n) common /cstak / istak(1000) integer c(iwid) call mpout (istak(ix), c, iwid, n) return end subroutine moute (ix, c, jexp, iwid) common /cstak / istak(1000) call mpoute (istak(ix), c, jexp, iwid) return end subroutine meps (idum, iz) common /cstak / istak(1000) call mpeps (istak(iz)) return end subroutine mprnt (ix, name) common /cstak / istak(1000) common /mpcom / b, t, m, lun, mxr, ipar(18) integer b, t, m, lun, mxr, name(2) c ndig = float(t)*alog10(float(b)) + 2.5 ic = istkgt (ndig, 2) call moute (ix, istak(ic), iexp, ndig) c imax = ic + ndig - 1 write (lun, 10) name, iexp, (istak(i), i=ic,imax) 10 format (1x, a4, a2, 3x, 1h(, i6, 2h ), 3x, 5(10a1, 1x) / 1 (25x, 5(10a1, 1x)) ) c call istkrl (1) return end subroutine mprnta (ix, n, name) common /cstak / istak(1000) common /mpcom / b, t, m, lun, mxr, ipar(18) integer b, t, m, lun, ix(n), name(2) c ndig = float(t)*alog10(float(b)) + 2.5 ic = istkgt (ndig, 2) imax = ic + ndig - 1 c write (lun, 10) name 10 format (30x, a4, a2) c do 30 i=1,n call moute (ix(i), istak(ic), iexp, ndig) c write (lun, 20) i, iexp, (istak(j), j=ic, imax) 20 format (1x, i4, 5x, 1h(, i6, 2h ), 3x, 5(10a1, 1x) / 1 (25x, 5(10a1, 1x)) ) 30 continue c call istkrl (1) return end