subroutine mccopy (x, z)
c ===== processed by augment, version 4n =====
c ----- global variables -----
c multiple precision
integer x(2), z(2)
c ===== translated program =====
call mcopy (x(1),z(1))
call mcopy (x(2),z(2))
go to 30000
c ----- return code -----
return
end
subroutine mcalc (ix)
c ===== processed by augment, version 4n =====
c ----- global variables -----
integer ix(2)
c ===== translated program =====
call malc (ix(1))
call malc (ix(2))
go to 30000
c ----- return code -----
return
end
subroutine mcdalc (ix)
c ===== processed by augment, version 4n =====
c ----- global variables -----
integer ix(2)
c ===== translated program =====
call mdalc (ix(2))
call mdalc (ix(1))
go to 30000
c ----- return code -----
return
end
subroutine mcadd (x, y, z)
c ===== processed by augment, version 4n =====
c ----- global variables -----
c multiple precision
integer x(2), y(2), z(2)
c ===== translated program =====
call madd (x(1),y(1),z(1))
call madd (x(2),y(2),z(2))
go to 30000
c ----- return code -----
return
end
subroutine mcsub (x, y, z)
c ===== processed by augment, version 4n =====
c ----- global variables -----
c multiple precision
integer x(2), y(2), z(2)
c ===== translated program =====
call msub (x(1),y(1),z(1))
call msub (x(2),y(2),z(2))
go to 30000
c ----- return code -----
return
end
subroutine mcmul1 (intger, y, z)
c ===== processed by augment, version 4n =====
c ----- global variables -----
integer intger
c multiple precision
integer y(2), z(2)
c ===== translated program =====
call mmul1 (intger,y(1),z(1))
call mmul1 (intger,y(2),z(2))
go to 30000
c ----- return code -----
return
end
subroutine mcmul2 (x, intger, z)
c ===== processed by augment, version 4n =====
c ----- global variables -----
integer intger
c multiple precision
integer x(2), z(2)
c ===== translated program =====
call mmul1 (intger,x(1),z(1))
call mmul1 (intger,x(2),z(2))
go to 30000
c ----- return code -----
return
end
subroutine mcmul (x, y, z)
c ===== processed by augment, version 4n =====
c ----- initialize/erase indexes -----
integer o0i1
c ----- temporary storage locations -----
c multiple precision
integer mtmp(2)
c ----- local variables -----
c multiple precision
integer tmp
c ----- global variables -----
c multiple precision
integer x(2), y(2), z(2)
c ===== translated program =====
c ----- begin initialization -----
do 30001 o0i1 = 1, 2
call malc (tmp)
c ----- end initialization -----
call mmul (x(1),y(1),mtmp(1))
call mmul (x(2),y(2),mtmp(2))
call msub (mtmp(1),mtmp(2),tmp)
call mmul (x(1),y(2),mtmp(1))
call mmul (x(2),y(1),mtmp(2))
call madd (mtmp(1),mtmp(2),z(2))
call mcopy (tmp,z(1))
go to 30000
c ----- return code -----
c ----- begin erasure -----
do 30002 o0i1 = 1, 2
call mdalc (tmp)
c ----- end erasure -----
return
end
subroutine mcdiv (x, y, z)
c ===== processed by augment, version 4n =====
c ----- initialize/erase indexes -----
integer o0i1
c ----- temporary storage locations -----
c multiple precision
integer mtmp(2)
c ----- local variables -----
c multiple precision
integer tmp1, tmp2
c ----- global variables -----
c multiple precision
integer x(2), y(2), z(2)
c ----- functions -----
real rec
c ===== translated program =====
c ----- begin initialization -----
do 30001 o0i1 = 1, 2
call malc (tmp1)
call malc (tmp2)
c ----- end initialization -----
call mmul (y(1),y(1),mtmp(1))
call mmul (y(2),y(2),mtmp(2))
call madd (mtmp(1),mtmp(2),mtmp(2))
call metom (rec (mtmp(2)),tmp1)
call mmul (x(1),y(1),mtmp(1))
call mmul (x(2),y(2),mtmp(2))
call madd (mtmp(1),mtmp(2),mtmp(2))
call mmul (mtmp(2),tmp1,tmp2)
call mmul (x(1),y(2),mtmp(1))
call mneg (mtmp(1),mtmp(1))
call mmul (x(2),y(1),mtmp(2))
call madd (mtmp(1),mtmp(2),mtmp(2))
call mmul (mtmp(2),tmp1,z(2))
call mcopy (tmp2,z(1))
go to 30000
c ----- return code -----
c ----- begin erasure -----
do 30002 o0i1 = 1, 2
call mdalc (tmp1)
call mdalc (tmp2)
c ----- end erasure -----
return
end
subroutine mcdivi (x, intger, z)
c ===== processed by augment, version 4n =====
c ----- global variables -----
integer intger
c multiple precision
integer x(2), z(2)
c ===== translated program =====
call mdivi (x(1),intger,z(1))
call mdivi (x(2),intger,z(2))
go to 30000
c ----- return code -----
return
end
subroutine mccexi (x,n, mcrlt)
c ===== processed by augment, version 4n =====
c ----- temporary storage locations -----
c multiple complex
integer mctmp(2,1)
c ----- local variables -----
integer n2, ns
c multiple complex
integer sq(2), mcres(2)
c ----- global variables -----
integer n
c multiple complex
integer x(2), mcrlt(2)
c ----- supporting package functions -----
logical mcne
c ===== translated program =====
c
c ----- begin initialization -----
call mcalc (mcres)
call mcalc (mctmp(1,1))
call mcalc (sq)
c ----- end initialization -----
n2 = n
if (n2) 20, 10, 40
c
10 call mcitoc (1,mcres)
go to 30000
c
20 n2 = -n2
c ===== mixed mode operands accepted =====
call mcitoc (0,mctmp(1,1))
if (mcne (x,mctmp(1,1))) go to 60
call seterr (30hmccexi zero to negative power, 30, 1, 2)
stop
c
c ===== mixed mode operands accepted =====
40 call mcitoc (0,mctmp(1,1))
if (mcne (x,mctmp(1,1))) go to 60
call mcitoc (0,mcres)
go to 30000
c
60 call mccopy (x,sq)
c ===== mixed mode operands accepted =====
if (.not. (n.lt.0)) go to 30001
call mcitoc (1,mctmp(1,1))
call mcdiv (mctmp(1,1),sq,sq)
call mcitoc (1,mcres)
c
70 ns = n2
n2 = n2/2
if (2*n2.ne.ns) call mcmul (sq,mcres,mcres)
if (n2.le.0) go to 30000
call mcmul (sq,sq,sq)
go to 70
c
c ----- return code -----
call mccopy (mcres,mcrlt)
c ----- begin erasure -----
call mcdalc (mcres)
call mcdalc (mctmp(1,1))
call mcdalc (sq)
c ----- end erasure -----
return
end
subroutine mccexc (x,y, mcrlt)
c ===== processed by augment, version 4n =====
c ----- temporary storage locations -----
c multiple complex
integer mctmp(2,1)
c ----- local variables -----
c multiple complex
integer mcres(2)
c ----- global variables -----
c multiple complex
integer x(2), y(2), mcrlt(2)
c ----- supporting package functions -----
logical mcne
c ===== translated program =====
c
c ----- begin initialization -----
call mcalc (mcres)
call mcalc (mctmp(1,1))
c ----- end initialization -----
c ===== mixed mode operands accepted =====
call mcetoc (0.,mctmp(1,1))
if (mcne (y,mctmp(1,1))) go to 10
call mcitoc (1,mcres)
go to 30000
c
c ===== mixed mode operands accepted =====
10 call mcetoc (0.,mctmp(1,1))
if (mcne (x,mctmp(1,1))) go to 20
call mcitoc (0,mcres)
go to 30000
c
20 call mclog (x,mctmp(1,1))
call mcmul (y,mctmp(1,1),mctmp(1,1))
call mcexp (mctmp(1,1),mcres)
go to 30000
c
c ----- return code -----
call mccopy (mcres,mcrlt)
c ----- begin erasure -----
call mcdalc (mcres)
call mcdalc (mctmp(1,1))
c ----- end erasure -----
return
end
subroutine mcitoc (intger, z)
c ===== processed by augment, version 4n =====
c ----- global variables -----
integer intger
c multiple precision
integer z(2)
c ===== translated program =====
call mitom (intger,z(1))
call mitom (0,z(2))
go to 30000
c ----- return code -----
return
end
subroutine mcetoc (r, z)
c ===== processed by augment, version 4n =====
c ----- global variables -----
real r
c multiple precision
integer z(2)
c ===== translated program =====
call metom (r,z(1))
call mitom (0,z(2))
go to 30000
c ----- return code -----
return
end
subroutine mcdtoc (d, z)
c ===== processed by augment, version 4n =====
c ----- global variables -----
double precision d
c multiple precision
integer z(2)
c ===== translated program =====
call mdtom (d,z(1))
call mitom (0,z(2))
go to 30000
c ----- return code -----
return
end
subroutine mcctoc (c, z)
c ===== processed by augment, version 4n =====
c ----- global variables -----
complex c
c multiple precision
integer z(1)
c ===== translated program =====
call metom (real (c),z(1))
call metom (aimag (c),z(2))
go to 30000
c ----- return code -----
return
end
logical function mceq (x,y)
c ===== processed by augment, version 4n =====
c ----- global variables -----
c multiple precision
integer x(2), y(2)
c ----- functions -----
logical mne
c ===== translated program =====
c
mceq = .false.
if (mne(x(1),y(1))) go to 30000
if (mne(x(2),y(2))) go to 30000
mceq = .true.
c
go to 30000
c ----- return code -----
return
end
logical function mcne (x,y)
c ===== processed by augment, version 4n =====
c ----- global variables -----
c multiple precision
integer x(2), y(2)
c ----- functions -----
logical meq
c ===== translated program =====
c
mcne = .false.
if (meq(x(1),y(1))) go to 30000
if (meq(x(2),y(2))) go to 30000
mcne = .true.
c
go to 30000
c ----- return code -----
return
end
subroutine mcreal (z, mrlt)
c ===== processed by augment, version 4n =====
c ----- local variables -----
c multiple precision
integer mres
c ----- global variables -----
c multiple precision
integer z(2), mrlt
c ===== translated program =====
c ----- begin initialization -----
call malc (mres)
c ----- end initialization -----
call mcopy (z(1),mres)
go to 30000
c ----- return code -----
call mcopy (mres,mrlt)
c ----- begin erasure -----
call mdalc (mres)
c ----- end erasure -----
return
end
subroutine mcimag (z, mrlt)
c ===== processed by augment, version 4n =====
c ----- local variables -----
c multiple precision
integer mres
c ----- global variables -----
c multiple precision
integer z(2), mrlt
c ===== translated program =====
c ----- begin initialization -----
call malc (mres)
c ----- end initialization -----
call mcopy (z(2),mres)
go to 30000
c ----- return code -----
call mcopy (mres,mrlt)
c ----- begin erasure -----
call mdalc (mres)
c ----- end erasure -----
return
end
subroutine mccmpl (x, y, z)
c ===== processed by augment, version 4n =====
c ----- global variables -----
c multiple precision
integer x, y, z(2)
c ===== translated program =====
call mcopy (x,z(1))
call mcopy (y,z(2))
go to 30000
c ----- return code -----
return
end
subroutine mcexp (z, mcrlt)
c ===== processed by augment, version 4n =====
c ----- initialize/erase indexes -----
integer o0i1
c ----- temporary storage locations -----
c multiple precision
integer mtmp(2)
c ----- local variables -----
c multiple precision
integer r, y
c multiple complex
integer mcres(2)
c ----- global variables -----
c multiple complex
integer z(2), mcrlt(2)
c ----- supporting package functions -----
logical meq
c ===== translated program =====
c
c ----- begin initialization -----
call mcalc (mcres)
do 30001 o0i1 = 1, 2
call malc (r)
call malc (y)
c ----- end initialization -----
call mcreal (z,mtmp(1))
call mexp (mtmp(1),r)
c ===== mixed mode operands accepted =====
call mitom (0,mtmp(1))
if (meq (r,mtmp(1))) go to 10
c
call mcimag (z,y)
call mcos (y,mtmp(1))
call mmul (r,mtmp(1),mtmp(1))
call msin (y,mtmp(2))
call mmul (r,mtmp(2),mtmp(2))
call mccmpl (mtmp(1),mtmp(2),mcres)
go to 30000
c
10 call mcitoc (0,mcres)
go to 30000
c
c ----- return code -----
call mccopy (mcres,mcrlt)
c ----- begin erasure -----
call mcdalc (mcres)
do 30002 o0i1 = 1, 2
call mdalc (r)
call mdalc (y)
c ----- end erasure -----
return
end
subroutine mclog (z, mcrlt)
c ===== processed by augment, version 4n =====
c ----- initialize/erase indexes -----
integer o0i1
c ----- temporary storage locations -----
c multiple precision
integer mtmp(2)
c ----- local variables -----
c multiple complex
integer mcres(2)
c ----- global variables -----
c multiple complex
integer z(2), mcrlt(2)
c ===== translated program =====
c
c ----- begin initialization -----
call mcalc (mcres)
do 30001 o0i1 = 1, 2
c ----- end initialization -----
call mcabs (z,mtmp(1))
call mlog (mtmp(1),mtmp(1))
call mcarg (z,mtmp(2))
call mccmpl (mtmp(1),mtmp(2),mcres)
c
go to 30000
c ----- return code -----
call mccopy (mcres,mcrlt)
c ----- begin erasure -----
call mcdalc (mcres)
do 30002 o0i1 = 1, 2
c ----- end erasure -----
return
end
subroutine mcabs (z, mrlt)
c ===== processed by augment, version 4n =====
c ----- initialize/erase indexes -----
integer o0i1
c ----- temporary storage locations -----
c multiple precision
integer mtmp(2)
c ----- local variables -----
c multiple precision
integer r1, r2, x, y, mres
c ----- global variables -----
c multiple precision
integer mrlt
c multiple complex
integer z(2)
c ----- supporting package functions -----
logical mne
c ===== translated program =====
c
c ----- begin initialization -----
call malc (mres)
do 30002 o0i1 = 1, 2
call malc (r1)
call malc (r2)
call malc (x)
call malc (y)
c ----- end initialization -----
call mcreal (z,mtmp(1))
call mabs (mtmp(1),x)
call mcimag (z,mtmp(1))
call mabs (mtmp(1),y)
call mmin1 (x,y,r1)
call mmax1 (x,y,r2)
c
call mcopy (r2,mres)
c ===== mixed mode operands accepted =====
c ===== mixed mode operands accepted =====
call mdtom (0.d0,mtmp(1))
if (.not. (mne (r1,mtmp(1)))) go to 30001
call mdiv (r1,r2,mtmp(1))
call mmexi (mtmp(1),2,mtmp(1))
call mdtom (1.d0,mtmp(2))
call madd (mtmp(2),mtmp(1),mtmp(1))
call msqrt (mtmp(1),mtmp(1))
call mmul (r2,mtmp(1),mres)
c
go to 30000
c ----- return code -----
call mcopy (mres,mrlt)
c ----- begin erasure -----
call mdalc (mres)
do 30003 o0i1 = 1, 2
call mdalc (r1)
call mdalc (r2)
call mdalc (x)
call mdalc (y)
c ----- end erasure -----
return
end
subroutine mcarg (z, mrlt)
c ===== processed by augment, version 4n =====
c ----- initialize/erase indexes -----
integer o0i1
c ----- temporary storage locations -----
c multiple precision
integer mtmp(2)
c ----- local variables -----
c multiple precision
integer mres
c ----- global variables -----
c multiple precision
integer mrlt
c multiple complex
integer z(2)
c ----- supporting package functions -----
logical meq, mne
c ===== translated program =====
c
c ----- begin initialization -----
call malc (mres)
do 30001 o0i1 = 1, 2
c ----- end initialization -----
call mitom (0,mres)
c ===== mixed mode operands accepted =====
call mcreal (z,mtmp(1))
call mitom (0,mtmp(2))
if (mne (mtmp(1),mtmp(2))) go to 10
c ===== mixed mode operands accepted =====
call mcimag (z,mtmp(1))
call mitom (0,mtmp(2))
if (meq (mtmp(1),mtmp(2))) go to 30000
c
10 call mcimag (z,mtmp(1))
call mcreal (z,mtmp(2))
call matan2 (mtmp(1),mtmp(2),mres)
c
go to 30000
c ----- return code -----
call mcopy (mres,mrlt)
c ----- begin erasure -----
call mdalc (mres)
do 30002 o0i1 = 1, 2
c ----- end erasure -----
return
end
subroutine mcsqrt (z, mcrlt)
c ===== processed by augment, version 4n =====
c ----- initialize/erase indexes -----
integer o0i1
c ----- temporary storage locations -----
c multiple precision
integer mtmp(2)
c ----- local variables -----
c multiple precision
integer r, x, xtmp, y, ytmp
c multiple complex
integer mcres(2)
c ----- global variables -----
c multiple complex
integer z(2), mcrlt(2)
c ----- supporting package functions -----
logical mlt, meq, mge, mne
c ===== translated program =====
c
c ----- begin initialization -----
call mcalc (mcres)
do 30002 o0i1 = 1, 2
call malc (r)
call malc (x)
call malc (xtmp)
call malc (y)
call malc (ytmp)
c ----- end initialization -----
call mcreal (z,x)
call mcimag (z,y)
call mcabs (z,r)
c
c ===== mixed mode operands accepted =====
call mitom (0,mtmp(1))
if (mne (r,mtmp(1))) go to 10
call mcitoc (0,mcres)
go to 30000
c
10 call mabs (x,mtmp(1))
call madd (r,mtmp(1),mtmp(1))
call mdivi (mtmp(1),2,mtmp(1))
call msqrt (mtmp(1),xtmp)
call mmul1 (2,xtmp,mtmp(1))
call mdiv (y,mtmp(1),ytmp)
c
c ===== mixed mode operands accepted =====
call mitom (0,mtmp(1))
if (mge (x,mtmp(1))) call mccmpl (xtmp,ytmp,mcres)
c ===== mixed mode operands accepted =====
call mitom (0,mtmp(1))
if (meq (y,mtmp(1))) call mitom (1,y)
c ===== mixed mode operands accepted =====
call mitom (0,mtmp(1))
if (.not. (mlt (x,mtmp(1)))) go to 30001
call mabs (ytmp,mtmp(1))
call msign (xtmp,y,mtmp(2))
call mccmpl (mtmp(1),mtmp(2),mcres)
c
go to 30000
c ----- return code -----
call mccopy (mcres,mcrlt)
c ----- begin erasure -----
call mcdalc (mcres)
do 30003 o0i1 = 1, 2
call mdalc (r)
call mdalc (x)
call mdalc (xtmp)
call mdalc (y)
call mdalc (ytmp)
c ----- end erasure -----
return
end
.
