diff --git a/src/Makefile b/src/Makefile
index f73457cd508d36bca1583272a11376a64ef1042a..7b90707e60f3d865615b73602e2550aecd808ce6 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -4,7 +4,7 @@
#
#-------------------------------------------------------------------------------
#
-# Copyright (C) 1998-2008 Hinnerk Stueben
+# Copyright (C) 1998-2011 Hinnerk Stueben
# 2006-2010 Yoshifumi Nakamura
#
# This file is part of BQCD -- Berlin Quantum ChromoDynamics program
@@ -77,24 +77,26 @@ LIBF = fermi/lib_fermi.a
LIBB = \
su3sc/lib_su3sc.a \
ildg/$(LIBILDG) \
- $(LIBRANDOM)
+ $(LIBRANDOM) \
+ fermi/d/$(LIBD) \
+ comm/$(LIBCOMM) \
+ fermi/d/$(LIBD) \
+ comm/$(LIBCOMM)
-#ifdef libdi
-#LIBB += comm/$(LIBCOMM)
-#else
-LIBB += fermi/d/$(LIBD) comm/$(LIBCOMM)
-#endif
-bqcd4: bqcdi.o $(MODULES) $(OBJS) lib_bqcdi.a
- $(F90) -o $@ $(LDFLAGS) bqcdi.o $(MODULES) $(OBJS) lib_bqcdi.a $(SYSLIBS)
+bqcd4: bqcdi.o $(MODULES) $(OBJS) $(LIBS) $(LIBF) $(LIBB)
+ $(F90) -o $@ $(LDFLAGS) bqcdi.o $(MODULES) $(OBJS) $(LIBS) $(LIBF) $(LIBB) $(SYSLIBS)
+#bqcd4: bqcdi.o $(MODULES) $(OBJS) lib_bqcdi.a
+# $(F90) -o $@ $(LDFLAGS) bqcdi.o $(MODULES) $(OBJS) lib_bqcdi.a $(SYSLIBS)
fast:
- make timing.h
+ make auto_headers
cd modules && $(MAKE)
cd comm && $(MAKE) fast
cd fermi/d && $(MAKE) fast
cd ildg && $(MAKE) fast
cd ran/$(random) && $(MAKE) fast
+ cd fmlib && $(MAKE) fast
cd su3sc && make
cd boundary && make
cd gauge && make
@@ -104,9 +106,6 @@ fast:
cd util && make
$(FAST_MAKE) bqcd4
-timing.h: timing.H
- awk 'NF > 0 {print $$0, ++count}' timing.H > ./include/$@
-
clean:
rm -f bqcd.[0-9][0-9][0-9].* diag.[0-9][0-9] core app.rif
rm -f random_test random_test.dump random_test.out
@@ -129,7 +128,16 @@ clobber: tidy
-cd su3sc && $(MAKE) clobber
-cd gauge && $(MAKE) clobber
-cd fermi && $(MAKE) clobber
- -rm -f ./include/timing.h
+ -cd fmlib && $(MAKE) clobber
+ -rm -f ./include_auto/*.h
+
+auto_headers: timing.H precision.H
+ @awk 'NF > 0 {print $$0, ++count}' timing.H > ./include_auto/timing.h
+ @awk 'NF > 0 {gsub(/#/, ""); gsub(/define/,"static const int"); print $$0, "=", ++count, ";"}' timing.H > ./include_auto/c_timing.h
+ @awk 'NF > 0 {if ( $$0 ~ "define") print $$0, $$3"_r4"; else print $0}' precision.H > ./include_auto/precision_r4.h
+ @awk 'NF > 0 {if ( $$0 ~ "define") print $$0, $$3"_r16"; else print $0}' precision.H > ./include_auto/precision_r16.h
+# @awk 'NF > 0 {print $$0, $$3"_r4"}' precision.H > ./include_auto/precision_r4.h
+# @awk 'NF > 0 {print $$0, $$3"_r16"}' precision.H > ./include_auto/precision_r16.h
Modules:
cd modules && $(MAKE)
@@ -248,28 +256,20 @@ prep-htc:
prep-gnu:
$(MAKE) prep PLATFORM=gnu
-prep-kekb:
- $(MAKE) prep PLATFORM=kekb
-
prep-linux:
$(MAKE) prep PLATFORM=linux
-prep-riken:
- $(MAKE) prep PLATFORM=riken
-
-prep-kpc4:
- $(MAKE) prep PLATFORM=intel-kpc4
-
-prep-zn:
- $(MAKE) prep PLATFORM=intel-zn
prep-qp:
$(MAKE) prep PLATFORM=QPACE
+
prep-juice:
$(MAKE) prep PLATFORM=juice
-prep-rgbg:
- $(MAKE) prep PLATFORM=rgbg
-prep-athene:
- $(MAKE) prep PLATFORM=athene
+
+prep-k:
+ $(MAKE) prep PLATFORM=k
+
+prep-supermig:
+ $(MAKE) prep PLATFORM=supermig
gj_test: gj.o gj_test.o misc.o service.o ranf.o
diff --git a/src/Makefile.in b/src/Makefile.in
index ec2b373e6ee6f0d0cc44503193fef22cd1164d87..7e73496ac4debce9648b0dfd04795085762f2350 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -4,7 +4,7 @@
#
#-------------------------------------------------------------------------------
#
-# Copyright (C) 2009 Yoshifumi Nakamura
+# Copyright (C) 2009-2011 Yoshifumi Nakamura
#
# This file is part of BQCD -- Berlin Quantum ChromoDynamics program
#
@@ -25,24 +25,47 @@
include $(DIR)Makefile.var
#-------------------------------------------------------------------------------
#
+# macro
+#
+M4=m4
+#-------------------------------------------------------------------------------
+#
# bqcdi options
#
omtdtd =1
-libdi =
# [chroma|chiral|ddhmc|bqcd] empty means bqcd
gamma =
doedeo =
flipsc =
qpace =
+quad =
+# if tune Ration approximation, remove #
+# FMLIB = ./fmlib
+
#-------------------------------------------------------------------------------
#
-# path for LIBs
+# path for own LIBs. If unnecessary, comment out
#
-LIME = $(HOME)/opt/lime-1.3.1
-#FMLIB = $(HOME)/opt/FMLIB
+COMPILER=gnu_mpich
+ifndef LIME
+LIME = $(HOME)/opt/lime-1.3.1
+endif
+
+ifndef LAPACK
+LAPACK = $(HOME)/lib/$(COMPILER)/lapack.a $(HOME)/lib/$(COMPILER)/blas.a
+endif
+
+ifndef SCALAPACK
+SCALAPACK= $(HOME)/lib/$(COMPILER)/scalapack.a $(HOME)/lib/$(COMPILER)/blacs.a
+endif
+
+ifndef ARPACK
+#ARPACK = $(HOME)/lib/$(COMPILER)/arpack.a
+endif
+
+#LEMON = $(HOME)/opt/lemon
#BAGEL = $(HOME)/chroma/for_bqcd/install_146s
-#ARPACK = $(HOME)/opt/ARPACK/libarpack_SUN4.a
-#LAPACK = $(HOME)/work/opt/lapack-3.2.1/lapack_LINUX.a $(HOME)/work/opt/lapack-3.2.1/blas_LINUX.a
+
#-------------------------------------------------------------------------------
#
# debug options
@@ -58,27 +81,39 @@ SYSLIBS += $(LIME)/lib/liblime.a
LIBILDG = libildg.a
endif
+ifdef LEMON
+CFLAGS_STD +=-I$(LEMON)/include
+SYSLIBS += $(LEMON)/src/liblemon.a
+MYFLAGS += -DLEMON
+endif
+
ifdef FMLIB
-MODULES_FLAG += -I$(FMLIB)
+MODULES_FLAG += -I../../$(FMLIB) # from fermi/rhmc
SYSLIBS += $(FMLIB)/lib_FM.a
MYFLAGS += -DFMLIB
endif
+ifdef SCALAPACK
+SYSLIBS += $(SCALAPACK)
+MYFLAGS += -DSCALAPACK
+endif
+
ifdef ARPACK
-SYSLIBS += $(ARPACK)
+SYSLIBS += $(ARPACK)
+MYFLAGS += -DARPACK
endif
ifdef LAPACK
-SYSLIBS += $(LAPACK)
+SYSLIBS += $(LAPACK)
+MYFLAGS += -DLAPACK
endif
-ifeq ($(libd),100)
- libdi=100
+ifdef quad
+MYFLAGS += -DQUAD
endif
ifdef BAGEL
-libd =21
-libdi =100
+libd =100
gamma =chroma
qmp =1
flipsc =1
@@ -89,6 +124,10 @@ SYSLIBS += $(BAGEL)/lib/libwfm.a \
$(BAGEL)/lib/libqmp.a -lstdc++
endif
+ifeq ($(libd),100)
+ libdi=100
+endif
+
ifeq ($(libd),500)
MYFLAGS += -DD500
endif
diff --git a/src/Makefile.var b/src/Makefile.var
index c8c738c48f08f20ffd01de755ac2178036523c87..edeaa9606132c03db7c1506644adcfa6c5f3ef0a 120000
--- a/src/Makefile.var
+++ b/src/Makefile.var
@@ -1 +1 @@
-platform/Makefile-linux.var
\ No newline at end of file
+platform/Makefile-gnu.var
\ No newline at end of file
diff --git a/src/boundary/Makefile b/src/boundary/Makefile
index d9278c7fa04e4bde83734f1eea497b1b14d284a3..071ecb33b6cc25e7e5f1e93628d234b85dfbdb63 100644
--- a/src/boundary/Makefile
+++ b/src/boundary/Makefile
@@ -39,8 +39,6 @@ endif
$(fpp) -I../include $(MYFLAGS) $< > $*.f90
$(F90) -c $(FFLAGS) $*.f90
-
-
OBJS = \
bc.o \
flip_bc_normal.o \
@@ -49,8 +47,8 @@ OBJS = \
flip_bc_schfun.o \
schr_boundary_gauge.o
-lib_boundary.a: $(OBJS) $(OBJS_DSF)
- $(AR) $(ARFLAGS) rv $@ $(OBJS) $(OBJS_DSF)
+lib_boundary.a: $(OBJS)
+ $(AR) $(ARFLAGS) rv $@ $(OBJS)
clobber:
rm -f *.[Tiod] *.f90 *.mod work.pc work.pcl
diff --git a/src/boundary/flip_bc_normal.F90 b/src/boundary/flip_bc_normal.F90
index 88ffcb897a7ec0cd98d3bf46f2223f373b8222d8..ddfd6d0382d31e0bc8f64b18423c47e792927cb4 100644
--- a/src/boundary/flip_bc_normal.F90
+++ b/src/boundary/flip_bc_normal.F90
@@ -125,31 +125,14 @@ end
!-------------------------------------------------------------------------------
subroutine flip_bc2_normal(u_flip, u)
-
- use module_flip_bc_normal
- use module_lattice
use module_vol
implicit none
GAUGE_FIELD, intent(in) :: u
GAUGE_FIELD, intent(out) :: u_flip
- integer :: mu, nu, count, i, eo, c1, c2
u_flip = u
-
- do mu = 1, DIM
- nu = gamma_index(mu)
- do eo = EVEN,ODD
- do count = 1, flip_bc_len(mu,eo)
- i = flip_bc_list(count, eo, mu)
- do c2 = 1, NCOL
- do c1 = 1, NCOL
- u_flip(c1, c2, i, eo, nu) = -u(c1, c2, i, eo, nu)
- enddo
- enddo
- enddo
- enddo
- enddo
+ call flip_bc1_normal(u_flip)
end
diff --git a/src/boundary/flip_bc_schfun.F90 b/src/boundary/flip_bc_schfun.F90
index 1ff31dde1573ffd4a57ec17aa0719831ca466d9e..a9ba11be36be8e77f13f8253131cd548ef9f45bf 100644
--- a/src/boundary/flip_bc_schfun.F90
+++ b/src/boundary/flip_bc_schfun.F90
@@ -25,95 +25,108 @@
# include "defs.h"
!-------------------------------------------------------------------------------
-subroutine flip_bc1_schfun(u_flip, u)
-
+subroutine flip_bc1_schfun(u)
use module_schr_bc
- use module_lattice
use module_vol
implicit none
- integer, dimension(DIM) :: i_pe
- GAUGE_FIELD, intent(in) :: u
- GAUGE_FIELD, intent(out) :: u_flip
- integer :: mu, nu, count, i, eo
-
- u_flip = u
+ GAUGE_FIELD, intent(inout) :: u
+ integer :: count, i, eo
- mu = gamma_index(4)
do eo = EVEN,ODD
+ !
+ ! P+ psi(T)=0
+ !
+
!$omp parallel do private(i)
- do count = 1, bc_len_bb(eo)
- i = bc_list_bb(count, eo)
- call u_zero(u_flip(1, 1, i, eo, mu))
+ do count = 1, bc_len_t_all(eo)
+ i = bc_list_t_all(count, eo)
+ u(:, :, i, eo, 4)=ZERO
enddo
+ !
+ ! P- psi(0)=0
+ !
+
!$omp parallel do private(i)
- do count = 1, bc_len_tt(eo)
- i = bc_list_tt(count, eo)
- call u_zero(u_flip(1, 1, i, eo, mu))
+ do count = 1, bc_len_b_all(eo)
+ i = bc_list_b_all(count, eo)
+ u(:, :, i, eo, 1:4)=ZERO
enddo
+ !
+ ! out side of box
+ !
+
!$omp parallel do private(i)
- do count = 1, bc_len_b(eo)
- i = bc_list_b(count, eo)
- call u_zero(u_flip(1, 1, i, eo, mu))
+ do count = 1, bc_len_bb(eo)
+ i = bc_list_bb(count, eo)
+ u(:, :, i, eo, 1:4)=ZERO
enddo
-
!$omp parallel do private(i)
- do count = 1, bc_len_t(eo)
- i = bc_list_t(count, eo)
- call u_zero(u_flip(1, 1, i, eo, mu))
+ do count = 1, bc_len_tp(eo)
+ i = bc_list_tp(count, eo)
+ u(:, :, i, eo, 1:4)=ZERO
enddo
-
enddo
end
!-------------------------------------------------------------------------------
subroutine flip_bc2_schfun(u_flip, u)
-
- use module_schr_bc
- use module_lattice
use module_vol
implicit none
- integer, dimension(DIM) :: i_pe
GAUGE_FIELD, intent(in) :: u
GAUGE_FIELD, intent(out) :: u_flip
- integer :: mu, nu, count, i, eo
u_flip = u
-
- mu = gamma_index(4)
- do eo = EVEN,ODD
-
- !$omp parallel do private(i)
- do count = 1, bc_len_bb(eo)
- i = bc_list_bb(count, eo)
- call u_zero(u_flip(1, 1, i, eo, mu))
- enddo
-
- !$omp parallel do private(i)
- do count = 1, bc_len_tt(eo)
- i = bc_list_tt(count, eo)
- call u_zero(u_flip(1, 1, i, eo, mu))
- enddo
-
- !$omp parallel do private(i)
- do count = 1, bc_len_b(eo)
- i = bc_list_b(count, eo)
- call u_zero(u_flip(1, 1, i, eo, mu))
- enddo
-
- !$omp parallel do private(i)
- do count = 1, bc_len_t(eo)
- i = bc_list_t(count, eo)
- call u_zero(u_flip(1, 1, i, eo, mu))
- enddo
-
- enddo
+ call flip_bc1_schfun(u_flip)
end
+!!!-------------------------------------------------------------------------------
+!!subroutine flip_bc1_schfun_pcac(u)
+!! use module_schr_bc
+!! use module_vol
+!! implicit none
+!!
+!! GAUGE_FIELD, intent(inout) :: u
+!! integer :: mu, count, i, eo
+!!
+!! mu = 4
+!! do eo = EVEN,ODD
+!!
+!! !
+!! ! out side of box
+!! !
+!!
+!! !$omp parallel do private(i)
+!! do count = 1, bc_len_bb(eo)
+!! i = bc_list_bb(count, eo)
+!! u(:, :, i, eo, 1:4)=ZERO
+!! enddo
+!! !$omp parallel do private(i)
+!! do count = 1, bc_len_tp(eo)
+!! i = bc_list_tp(count, eo)
+!! u(:, :, i, eo, 1:4)=ZERO
+!! enddo
+!! enddo
+!!
+!!end
+!!
+!!!-------------------------------------------------------------------------------
+!!subroutine flip_bc2_schfun_pcac(u_flip, u)
+!! use module_vol
+!! implicit none
+!!
+!! GAUGE_FIELD, intent(in) :: u
+!! GAUGE_FIELD, intent(out) :: u_flip
+!!
+!! u_flip = u
+!! call flip_bc1_schfun_pcac(u_flip)
+!!
+!!end
+!!
!===============================================================================
diff --git a/src/boundary/init_schr_bc.F90 b/src/boundary/init_schr_bc.F90
index 76e0dc3a56dca15b48803788a8787ca084c8be1b..7f43de8d60c8e81700bf5f71a8936703f0c8f1cc 100644
--- a/src/boundary/init_schr_bc.F90
+++ b/src/boundary/init_schr_bc.F90
@@ -27,60 +27,68 @@
!-------------------------------------------------------------------------------
module module_schr_bc
+ INTEGER, dimension(:, :), pointer, save :: bc_list_1
INTEGER, dimension(:, :), pointer, save :: bc_list_b
INTEGER, dimension(:, :), pointer, save :: bc_list_t
INTEGER, dimension(:, :), pointer, save :: bc_list_bb
- INTEGER, dimension(:, :), pointer, save :: bc_list_tt
- INTEGER, dimension(:, :), pointer, save :: bc_list_in
+ INTEGER, dimension(:, :), pointer, save :: bc_list_tp
+ INTEGER, dimension(:, :), pointer, save :: bc_list_b_all
+ INTEGER, dimension(:, :), pointer, save :: bc_list_t_all
- integer, dimension(EVEN:ODD), save :: bc_len_b
- integer, dimension(EVEN:ODD), save :: bc_len_t
- integer, dimension(EVEN:ODD), save :: bc_len_bb
- integer, dimension(EVEN:ODD), save :: bc_len_tt
- integer, dimension(EVEN:ODD), save :: bc_len_in
+ INTEGER, dimension(EVEN:ODD), save :: bc_len_1
+ INTEGER, dimension(EVEN:ODD), save :: bc_len_b
+ INTEGER, dimension(EVEN:ODD), save :: bc_len_t
+ INTEGER, dimension(EVEN:ODD), save :: bc_len_bb
+ INTEGER, dimension(EVEN:ODD), save :: bc_len_tp
+ INTEGER, dimension(EVEN:ODD), save :: bc_len_b_all
+ INTEGER, dimension(EVEN:ODD), save :: bc_len_t_all
+
+ REAL, save :: cps, cpt, crt
end
!-------------------------------------------------------------------------------
subroutine init_schr_bc()
-
- use module_schr_bc
- use module_function_decl
- use module_lattice
- use module_vol
+ use module_schr_bc
+ use module_function_decl
+ use module_lattice
+ use module_vol
implicit none
- integer, dimension(DIM) :: i0, i1, i_pe, j
- integer :: me, mu, x, y, z, t, i, eo, count(EVEN:ODD)
+ integer, dimension(DIM) :: i_pe, j
+ integer :: mu, x, y, z, t, i, eo, dmin(3), dmax(3)
integer, external :: xyzt2i, e_o
+ if (NPE(4) == 1 ) call die("so far schr bc does not work in NPE(4)=1 ")
call my_coord(i_pe)
- mu = gamma_index(4)
- if (NPE(mu) == 1 ) call die("so far schr bc does not work in NPE(4)=1 ")
-
- allocate(bc_list_b(volh_tot, EVEN:ODD))
- allocate(bc_list_t(volh_tot, EVEN:ODD))
- allocate(bc_list_bb(volh_tot, EVEN:ODD))
- allocate(bc_list_tt(volh_tot, EVEN:ODD))
- allocate(bc_list_in(volh_tot, EVEN:ODD))
+
+ allocate(bc_list_1( (nx+2)*(ny+2)*(nz+2), EVEN:ODD))
+ allocate(bc_list_b( (nx+2)*(ny+2)*(nz+2), EVEN:ODD))
+ allocate(bc_list_t( (nx+2)*(ny+2)*(nz+2), EVEN:ODD))
+ allocate(bc_list_bb((nx+2)*(ny+2)*(nz+2), EVEN:ODD))
+ allocate(bc_list_tp((nx+2)*(ny+2)*(nz+2), EVEN:ODD))
+ allocate(bc_list_b_all( (nx+2)*(ny+2)*(nz+2), EVEN:ODD))
+ allocate(bc_list_t_all( (nx+2)*(ny+2)*(nz+2), EVEN:ODD))
+ bc_len_1 = 0
bc_len_b = 0
bc_len_t = 0
bc_len_bb = 0
- bc_len_tt = 0
- bc_len_in = 0
-
-!==========================================================t
-!----------------------------------------------------------t
- if (i_pe(mu) == (NPE(mu) - 1)) then
- i0 = 0
- i1 = N - 1
- i0(mu) = N(mu) - 1
- i1(mu) = i0(mu)
- do t = i0(4), i1(4)
- do z = i0(3), i1(3)
- do y = i0(2), i1(2)
- do x = i0(1), i1(1)
- j = (/x, y, z, t/)
+ bc_len_tp = 0
+ bc_len_b_all = 0
+ bc_len_t_all = 0
+
+ do mu = 1, 3
+ dmin(mu) = 0
+ dmax(mu) = n(mu) - 1
+ if (NPE(mu) > 1) dmin(mu) = -1
+ if (NPE(mu) > 1) dmax(mu) = n(mu)
+ enddo
+
+ if ( i_pe(4) == (NPE(4) - 1) ) then !! t=T-1
+ do x = 0, n(1) - 1
+ do y = 0, n(2) - 1
+ do z = 0, n(3) - 1
+ j = (/x, y, z, nt-1/)
i = xyzt2i(j)
eo = e_o(j)
bc_len_t(eo) = bc_len_t(eo) + 1
@@ -88,55 +96,35 @@ subroutine init_schr_bc()
enddo
enddo
enddo
- enddo
-!----------------------------------------------------------tt
- i0 = 0
- i1 = N - 1
- i0(mu) = N(mu)
- i1(mu) = i0(mu)
- do t = i0(4), i1(4)
- do z = i0(3), i1(3)
- do y = i0(2), i1(2)
- do x = i0(1), i1(1)
- j = (/x, y, z, t/)
+ do x = dmin(1), dmax(1)
+ do y = dmin(2), dmax(2)
+ do z = dmin(3), dmax(3)
+ j = (/x, y, z, nt-1/)
i = xyzt2i(j)
eo = e_o(j)
- bc_len_tt(eo) = bc_len_tt(eo) + 1
- bc_list_tt(bc_len_tt(eo), eo) = i
+ bc_len_t_all(eo) = bc_len_t_all(eo) + 1
+ bc_list_t_all(bc_len_t_all(eo), eo) = i
enddo
enddo
enddo
- enddo
-!----------------------------------------------------------t in
- i0 = 0
- i1 = N - 1
- i0(mu) = N(mu) -2
- i1(mu) = i0(mu)
- do t = i0(4), i1(4)
- do z = i0(3), i1(3)
- do y = i0(2), i1(2)
- do x = i0(1), i1(1)
- j = (/x, y, z, t/)
+
+ do x = dmin(1), dmax(1)
+ do y = dmin(2), dmax(2)
+ do z = dmin(3), dmax(3)
+ j = (/x, y, z, nt/)
i = xyzt2i(j)
eo = e_o(j)
- bc_len_tt(eo) = bc_len_tt(eo) + 1
- bc_list_tt(bc_len_tt(eo), eo) = i
- enddo
+ bc_len_tp(eo) = bc_len_tp(eo) + 1
+ bc_list_tp(bc_len_tp(eo), eo) = i
enddo
enddo
enddo
-!==========================================================b
-!----------------------------------------------------------b
- elseif (i_pe(mu) == 0) then
- i0 = 0
- i1 = N - 1
- i0(mu) = 0
- i1(mu) = i0(mu)
- do t = i0(4), i1(4)
- do z = i0(3), i1(3)
- do y = i0(2), i1(2)
- do x = i0(1), i1(1)
- j = (/x, y, z, t/)
+ endif
+ if ( i_pe(4) == 0 ) then !! t=0
+ do x = 0, n(1) - 1
+ do y = 0, n(2) - 1
+ do z = 0, n(3) - 1
+ j = (/x, y, z, 0/)
i = xyzt2i(j)
eo = e_o(j)
bc_len_b(eo) = bc_len_b(eo) + 1
@@ -144,17 +132,21 @@ subroutine init_schr_bc()
enddo
enddo
enddo
+ do x = dmin(1), dmax(1)
+ do y = dmin(2), dmax(2)
+ do z = dmin(3), dmax(3)
+ j = (/x, y, z, 0/)
+ i = xyzt2i(j)
+ eo = e_o(j)
+ bc_len_b_all(eo) = bc_len_b_all(eo) + 1
+ bc_list_b_all(bc_len_b_all(eo), eo) = i
+ enddo
+ enddo
enddo
-!----------------------------------------------------------bb
- i0 = 0
- i1 = N - 1
- i0(mu) = -1
- i1(mu) = i0(mu)
- do t = i0(4), i1(4)
- do z = i0(3), i1(3)
- do y = i0(2), i1(2)
- do x = i0(1), i1(1)
- j = (/x, y, z, t/)
+ do x = dmin(1), dmax(1)
+ do y = dmin(2), dmax(2)
+ do z = dmin(3), dmax(3)
+ j = (/x, y, z, -1/)
i = xyzt2i(j)
eo = e_o(j)
bc_len_bb(eo) = bc_len_bb(eo) + 1
@@ -162,44 +154,42 @@ subroutine init_schr_bc()
enddo
enddo
enddo
- enddo
-!----------------------------------------------------------b in
- i0 = 0
- i1 = N - 1
- i0(mu) = 1
- i1(mu) = i0(mu)
- do t = i0(4), i1(4)
- do z = i0(3), i1(3)
- do y = i0(2), i1(2)
- do x = i0(1), i1(1)
- j = (/x, y, z, t/)
+ endif
+
+ if (nt > 1 .and. i_pe(4) == 0) then
+ do x = 0, n(1) - 1
+ do y = 0, n(2) - 1
+ do z = 0, n(3) - 1
+ j = (/x, y, z, 1/)
i = xyzt2i(j)
eo = e_o(j)
- bc_len_in(eo) = bc_len_in(eo) + 1
- bc_list_in(bc_len_in(eo), eo) = i
- enddo
+ bc_len_1(eo) = bc_len_1(eo) + 1
+ bc_list_1(bc_len_1(eo), eo) = i
enddo
enddo
enddo
- else
-!==========================================================in
- i0 = 0
- i1 = N - 1
- do t = i0(4), i1(4)
- do z = i0(3), i1(3)
- do y = i0(2), i1(2)
- do x = i0(1), i1(1)
- j = (/x, y, z, t/)
+ endif
+ if(nt==1 .and. i_pe(4) == 1) then
+ do x = 0, n(1) - 1
+ do y = 0, n(2) - 1
+ do z = 0, n(3) - 1
+ j = (/x, y, z, 0/)
i = xyzt2i(j)
eo = e_o(j)
- bc_len_in(eo) = bc_len_in(eo) + 1
- bc_list_in(bc_len_in(eo), eo) = i
- enddo
+ bc_len_1(eo) = bc_len_1(eo) + 1
+ bc_list_1(bc_len_1(eo), eo) = i
enddo
enddo
enddo
endif
+!write(*,*)",bc_len_t e",my_pe(),bc_len_t(0)
+!write(*,*)",bc_len_b o",my_pe(),bc_len_b(1)
+!write(*,*)",bc_len_t o",my_pe(),bc_len_t(1)
+!call flush(6)
+!call comm_finalize()
+!stop
+
end
!===============================================================================
diff --git a/src/boundary/init_schr_weight.F90 b/src/boundary/init_schr_weight.F90
index 05cd12998c753802a4d332f48e5ef672464c0c49..cb8f624a3e80399597462e56190eed5066e01806 100644
--- a/src/boundary/init_schr_weight.F90
+++ b/src/boundary/init_schr_weight.F90
@@ -26,45 +26,40 @@
!-------------------------------------------------------------------------------
subroutine init_schr_weight()
-
use module_schr_weight
use module_schr_bc
use module_vol
- use module_lattice
implicit none
- REAL :: cpt,cps,crt
- integer :: mu, nu, mu1, nu1, eo, i, count
+ integer :: mu, nu, eo, i, count
- cps = 0.3_8
- cpt = 0.9_8
- crt = TWO/THREE
+ cps = 0.5_8
+ cpt = ONE
+ crt = 1.5_8
allocate(cp(volh_tot, EVEN:ODD, DIM, DIM))
allocate(cr1(volh_tot, EVEN:ODD, DIM, DIM))
allocate(cr2(volh_tot, EVEN:ODD, DIM, DIM))
cp = ONE
- cr1 = ONE
- cr2 = ONE
+ cr1 = ONE ! horizontally long
+ cr2 = ONE ! vetically long
do mu = 1, DIM
do nu = 1, DIM
if (mu /= nu) then
- mu1 = gamma_index(mu)
- nu1 = gamma_index(nu)
if (mu == 4 .or. nu == 4) then
do eo = EVEN,ODD
do count = 1, bc_len_b(eo)
i = bc_list_b(count, eo)
- cp(i, eo, mu1, nu1) = cpt
- cr1(i, eo, mu1, nu1) = crt
- cr2(i, eo, mu1, nu1) = ONE
+ cp(i, eo, mu, nu) = cpt
+ cr1(i, eo, mu, nu) = crt
+ cr2(i, eo, mu, nu) = crt
enddo
do count = 1, bc_len_t(eo)
i = bc_list_t(count, eo)
- cp(i, eo, mu1, nu1) = cpt
- cr1(i, eo, mu1, nu1) = crt
- cr2(i, eo, mu1, nu1) = ZERO
+ cp(i, eo, mu, nu) = cpt
+ cr1(i, eo, mu, nu) = crt
+ cr2(i, eo, mu, nu) = ZERO
enddo
enddo
endif
@@ -72,9 +67,15 @@ subroutine init_schr_weight()
do eo = EVEN,ODD
do count = 1, bc_len_b(eo)
i = bc_list_b(count, eo)
- cp(i, eo, mu1, nu1) = cps
- cr1(i, eo, mu1, nu1) = ZERO
- cr2(i, eo, mu1, nu1) = ZERO
+ cp(i, eo, mu, nu) = cps
+ cr1(i, eo, mu, nu) = ZERO
+ cr2(i, eo, mu, nu) = ZERO
+ enddo
+ do count = 1, bc_len_tp(eo)
+ i = bc_list_tp(count, eo)
+ cp(i, eo, mu, nu) = cps
+ cr1(i, eo, mu, nu) = ZERO
+ cr2(i, eo, mu, nu) = ZERO
enddo
enddo
endif
diff --git a/src/boundary/schr_boundary_gauge.F90 b/src/boundary/schr_boundary_gauge.F90
index 010dfa0cb6b775856704afbcaf2baf00721c1638..1c277b369c2e2974793b7282dcf5105969704ec5 100644
--- a/src/boundary/schr_boundary_gauge.F90
+++ b/src/boundary/schr_boundary_gauge.F90
@@ -41,105 +41,511 @@ subroutine schr_boundary_gauge(u)
GAUGE_FIELD, intent(inout) :: u
integer :: mu, nu, count, i, eo, c1, c2, mu1
- COMPLEX :: bound, bound1(3), bound2(3)
-
-REAL,external :: Re_Tr_uu,sg
-
-SU3::uuu
-integer::j1,j2,o,e
-REAL::p
-
-
- bound1(1) = cmplx(dcos(PI/SIX), -dsin(PI/SIX), kind = RKIND)
- bound1(2) = cmplx(ONE, ZERO, kind = RKIND)
- bound1(3) = cmplx(dcos(PI/SIX), dsin(PI/SIX), kind = RKIND)
- bound2(1) = cmplx(dcos(5.0_8*PI/SIX), -dsin(5.0_8*PI/SIX), kind = RKIND)
- bound2(2) = cmplx(dcos(PI/THREE), dsin(PI/THREE), kind = RKIND)
- bound2(3) = cmplx(dcos(PI/TWO), dsin(PI/TWO), kind = RKIND)
-
-write(STDERR,*)sg(u)
- do mu = 1, 1!4!3 !DIM
- mu1 = gamma_index(mu)
- do eo = EVEN,ODD
- do count = 1, bc_len_b(eo)
- i = bc_list_b(count, eo)
- do c2 = 1, NCOL
- do c1 = 1, NCOL
- u(c1, c2, i, eo, mu1) = ZERO
- enddo
+ REAL :: phi0(3), phi1(3), dl(3)
+ COMPLEX :: bound, bd1(3,3), bd2(3,3)
+
+ phi0(1)=-PI/SIX
+ phi0(2)= ZERO
+ phi0(3)=-(phi0(1)+phi0(2))
+ phi1(1)=-5.0_8*PI/SIX
+ phi1(2)= 2.0_8*PI/SIX
+ phi1(3)=-(phi1(1)+phi1(2))
+
+ dl(1)=dble(lx)
+ dl(2)=dble(ly)
+ dl(3)=dble(lz)
+ do c1 =1, 3
+ do mu =1, 3
+ bd1(c1,mu) = cmplx(dcos(phi0(c1)/dl(mu)), dsin(phi0(c1)/dl(mu)),kind=RKIND)
+ bd2(c1,mu) = cmplx(dcos(phi1(c1)/dl(mu)), dsin(phi1(c1)/dl(mu)),kind=RKIND)
+ enddo
+ enddo
+
+ do eo = EVEN,ODD
+ !
+ ! put 0 for links at t = -1
+ !
+ do mu = 1, 4
+ do count = 1, bc_len_bb(eo)
+ i = bc_list_bb(count, eo)
+ u(:, :, i, eo, mu) = ZERO
+ enddo
+ enddo
+ !
+ ! put Schr bound for (1,2,3)-dir links at t = 0
+ !
+ do mu = 1, 3
+ do count = 1, bc_len_b_all(eo)
+ i = bc_list_b_all(count, eo)
+ u(:, :, i, eo, mu) = ZERO
+ do c1 = 1, NCOL
+ u(c1, c1, i, eo, mu) = bd1(c1,mu)
+ enddo
+ enddo
+ enddo
+ !
+ ! put Schr bound for (1,2,3)-dir links at t = T+1
+ !
+ do mu = 1, 3
+ do count = 1, bc_len_tp(eo)
+ i = bc_list_tp(count, eo)
+ u(:, :, i, eo, mu) = ZERO
+ do c1 = 1, NCOL
+ u(c1, c1, i, eo, mu) = bd2(c1,mu)
enddo
-! do c2 = 1, NCOL
-! u(c2, c2, i, eo, mu1) = bound1(c2)
-! enddo
enddo
-! do count = 1, bc_len_tt(eo)
-!!write(STDERR,*)my_pe(),"ttttt"
-! i = bc_list_tt(count, eo)
-! do c2 = 1, NCOL
-! do c1 = 1, NCOL
-! u(c1, c2, i, eo, mu1) = ZERO
-! enddo
-! enddo
-!! do c2 = 1, NCOL
-!! u(c2, c2, i, eo, mu1) = bound2(c2)
-!! enddo
-! enddo
+ enddo
+ !
+ ! put 0 for 4-dir links at t = T+1
+ !
+ do count = 1, bc_len_tp(eo)
+ i = bc_list_tp(count, eo)
+ u(:, :, i, eo, 4) = ZERO
+ enddo
+ enddo
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine schr_boundary_zero3(u) ! put 0 out of boundary
+ use module_schr_bc
+ use module_vol
+ implicit none
+ GAUGE_FIELD, intent(inout) :: u
+ integer :: mu, count, i, eo
+
+ do eo = EVEN,ODD
+ !
+ ! put 0 for spacial links at t = 0
+ !
+ do count = 1, bc_len_b_all(eo)
+ i = bc_list_b_all(count, eo)
+ u(:, :, i, eo, 1:3) = ZERO
+ enddo
+ enddo
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine schr_boundary_zero4(u) ! put 0 out of boundary
+ use module_schr_bc
+ use module_vol
+ implicit none
+ GAUGE_FIELD, intent(inout) :: u
+ integer :: mu, count, i, eo
+
+ do eo = EVEN,ODD
+ !
+ ! put 0 for links at t = -1
+ !
+ do count = 1, bc_len_bb(eo)
+ i = bc_list_bb(count, eo)
+ u(:, :, i, eo, 1:4) = ZERO
+ enddo
+ !
+ ! put 0 for links at t = T+1
+ !
+ do count = 1, bc_len_tp(eo)
+ i = bc_list_tp(count, eo)
+ u(:, :, i, eo, 1:4) = ZERO
enddo
enddo
-! do mu = 1, DIM
-! do eo = EVEN,ODD
-! do count = 1, bc_len_bb(eo)
-! i = bc_list_bb(count, eo)
-! do c2 = 1, NCOL
-! do c1 = 1, NCOL
-! u(c1, c2, i, eo, mu) = ZERO
-! enddo
-! enddo
-! enddo
-! enddo
-! enddo
+end
+
+!-------------------------------------------------------------------------------
+subroutine schr_boundary_p(p)
+ use module_schr_bc
+ use module_vol
+ implicit none
+ GENERATOR_FIELD, intent(inout) :: p
+ integer :: eo, i, count
-!STOP
+ !
+ ! put 0 for (1,2,3)-dir links at t = 0
+ !
+ do eo = EVEN,ODD
+ do count = 1, bc_len_b(eo)
+ i = bc_list_b(count, eo)
+ p(:, i, eo, 1:3) = ZERO
+ enddo
+ enddo
+end
+!-------------------------------------------------------------------------------
+REAL function s_plaq_sfdiff(u) ! returns S_g only diff by SF
+ use module_schr_weight
+ use module_schr_bc
+ use module_lattice
+ use module_nn
+ use module_vol
+ implicit none
+ GAUGE_FIELD :: u
+ REAL :: p
+ SU3 :: uuu
+ integer :: i, e, o, mu, nu, j1, j2, count
+ REAL, external :: Re_Tr_uu, global_sum
+ DEBUG2S("Start: s_plaq_sfdiff")
+ p = ZERO
do mu = 1, DIM
+ do nu = mu + 1, DIM
+ if (mu /= 4 .and. nu /= 4) cycle
+ do e = EVEN, ODD
+ o = EVEN + ODD - e
+ !$omp parallel do reduction(+: p) private(i, j1, j2, uuu)
+ do count = 1, bc_len_b(e)
+ i = bc_list_b(count, e)
+ j1 = nn(i, e, mu, FWD)
+ j2 = nn(i, e, nu, FWD)
+ call udd_imp(uuu, u(1, 1, j1, o, nu), &
+ u(1, 1, j2, o, mu), &
+ u(1, 1, i, e, nu))
+ p = p + (ONE - Re_Tr_uu(uuu, u(1, 1, i, e, mu))/THREE ) * ( cpt -ONE )
+ enddo
+
+ !$omp parallel do reduction(+: p) private(i, j1, j2, uuu)
+ do count = 1, bc_len_t(e)
+ i = bc_list_t(count, e)
+ j1 = nn(i, e, mu, FWD)
+ j2 = nn(i, e, nu, FWD)
+ call udd_imp(uuu, u(1, 1, j1, o, nu), &
+ u(1, 1, j2, o, mu), &
+ u(1, 1, i, e, nu))
+ p = p + (ONE - Re_Tr_uu(uuu, u(1, 1, i, e, mu))/THREE ) * ( cpt -ONE )
+ enddo
+ enddo
+ enddo
+ enddo
+
+ s_plaq_sfdiff = global_sum(p)
+!! call sf_classical_action()
+ DEBUG2S("End: s_plaq_sfdiff")
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine dsg_sfdiff(p, plaq, step)
+ use module_schr_weight
+ use module_schr_bc
+ use module_field
+ use module_action_type
+ use module_vol
+ use module_nn
+ implicit none
+
+ GENERATOR_FIELD, intent(inout) :: p
+ type(type_plaq), intent(in) :: plaq
+ REAL, intent(in) :: step
+ REAL :: s
+ SU3 :: uuu, w
+ integer :: mu, nu, e, o, i, j1, j2, count
+
+ s = - step * plaq%beta / THREE * ( cpt - ONE )
+
+ if (s == ZERO) return
+
+ DEBUG2S("Start: dsg_sfdiff")
+
+ do mu = 1, 3
do e = EVEN, ODD
o = EVEN + ODD - e
- do nu = mu + 1, DIM
- p = ZERO
- !$omp parallel do reduction(+: p) private(j1, j2, uuu)
- do i = 1, VOLH
- ! (j2,o) --<-- x nu
- ! | |
- ! v ^ ^
- ! | | |
- ! (i,e) -->-- (j1,o) x--> mu
+ !$omp parallel do private(i, j1, j2, uuu, w)
+ do count = 1, bc_len_1(e)
+ i = bc_list_1(count, e)
+ j1 = nn(i, e, 4, BWD)
+ j2 = nn(j1, o, mu, FWD)
+ call ddu_imp(uuu, gauge(1)%u(1, 1,j2, e, 4), &
+ gauge(1)%u(1, 1,j1, o, mu), &
+ gauge(1)%u(1, 1,j1, o, 4))
+ call uu(w, gauge(1)%u(1, 1, i, e, mu), uuu)
+ call im_tr_j(p(1, i, e, mu), w, s)
+ enddo
+ !$omp parallel do private(i, j1, j2, uuu, w)
+ do count = 1, bc_len_t(e)
+ i = bc_list_t(count, e)
+ j1 = nn(i, e, mu, FWD)
+ j2 = nn(i, e, 4, FWD)
+ call udd_imp(uuu, gauge(1)%u(1, 1, j1, o, 4), &
+ gauge(1)%u(1, 1, j2, o, mu), &
+ gauge(1)%u(1, 1, i, e, 4))
+ call uu(w, gauge(1)%u(1, 1, i, e, mu), uuu)
+ call im_tr_j(p(1, i, e, mu), w, s)
+ enddo
+ enddo
+ enddo
- j1 = nn(i, e, mu, FWD)
- j2 = nn(i, e, nu, FWD)
-
- uuu = 0
- call uuu_fwd(uuu, u(1, 1, j1, o, nu), &
- u(1, 1, j2, o, mu), &
- u(1, 1, i, e, nu))
+ do e = EVEN, ODD
+ !$omp parallel do private(i, j1, j2, uuu, w)
+ do count = 1, bc_len_b(e)
+ i = bc_list_b(count, e)
+ call staple(uuu, gauge(1)%u, i, e, 4)
+ call uu(w, gauge(1)%u(1, 1, i, e, 4), uuu)
+ call im_tr_j(p(1, i, e, 4), w, s)
+ enddo
- p = Re_Tr_uu(uuu, u(1, 1, i, e, mu))
-if(p< 0.00001)write(STDERR,*)"zero u",my_pe(),i,&
-"eo=",e,"munu=",mu,nu,u(1, 1, i, e, mu),u(1, 1, j1, o, nu), u(1, 1, j2, o, mu), u(1, 1, i, e, nu),j2
+ !$omp parallel do private(i, j1, j2, uuu, w)
+ do count = 1, bc_len_t(e)
+ i = bc_list_t(count, e)
+ call staple(uuu, gauge(1)%u, i, e, 4)
+ call uu(w, gauge(1)%u(1, 1, i, e, 4), uuu)
+ call im_tr_j(p(1, i, e, 4), w, s)
+ enddo
+ enddo
- enddo
+ DEBUG2S("End: dsg_sfdiff")
+end
+
+!-------------------------------------------------------------------------------
+REAL function s_rect_sfdiff(u) ! returns S_g only diff by SF
+ use module_schr_weight
+ use module_schr_bc
+ use module_lattice
+ use module_nn
+ use module_vol
+ use module_switches
+ implicit none
+
+ GAUGE_FIELD :: u, w1, w2
+ REAL :: p
+ SU3 :: uuu
+ integer :: i, e, o, mu, nu, j1, j2, count
+ REAL, external :: Re_Tr_uu, global_sum
+
+ DEBUG2S("Start: s_rect_sfdiff")
+
+ p = ZERO
+ do mu = 1, 3
+ call r_staple(w1, u(1,1,1,0,1), mu)
+ if (switches%boundary_sf) call schr_boundary_zero4(w1)
+
+ do e = EVEN, ODD
+ o = EVEN + ODD - e
+
+ !$omp parallel do reduction(+: p) private(i, j1, j2, uuu)
+ do count = 1, bc_len_b(e)
+ i = bc_list_b(count, e)
+ j1 = nn(i , e, mu, FWD)
+ j2 = nn(i , e, 4, FWD)
+ uuu = ZERO
+ call uddp(uuu, w1(1, 1, j1, o, 4), &
+ u(1, 1, j2, o, mu), &
+ u(1, 1, i , e, 4))
+ p = p + (ONE - Re_Tr_uu(uuu, u(1, 1, i, e, mu))/THREE ) * ( crt - ONE )
+ enddo
+
+ !$omp parallel do reduction(+: p) private(i, j1, j2, uuu)
+ do count = 1, bc_len_t(e)
+ i = bc_list_t(count, e)
+ j1 = nn(i , e, mu, FWD)
+ j2 = nn(i , e, 4, FWD)
+ uuu = ZERO
+ call uddp(uuu, w1(1, 1, j1, o, 4), &
+ u(1, 1, j2, o, mu), &
+ u(1, 1, i , e, 4))
+ p = p + (ONE - Re_Tr_uu(uuu, u(1, 1, i, e, mu))/THREE ) * ( crt - ONE )
enddo
+
enddo
enddo
-
-write(STDERR,*)sg(u)
-STOP
+
+ !! 3*lx*ly*lz subtruction for rectangle sticking out of t=T
+ s_rect_sfdiff = global_sum(p) - dble(3*lx*ly*lz)
+
+ DEBUG2S("End: s_rect_sfdiff")
end
+!-------------------------------------------------------------------------------
+subroutine dsig_sfdiff(p, impg, step)
+ use module_schr_weight
+ use module_schr_bc
+ use module_field
+ use module_action_type
+ use module_vol
+ use module_nn
+ use module_switches
+ implicit none
+
+ GENERATOR_FIELD, intent(inout) :: p
+ type(type_impg), intent(in) :: impg
+ REAL, intent(in) :: step
+ REAL :: s
+ SU3 :: uuu, w
+ integer :: mu, nu, e, o, i, j1, j2, count
+ COMPLEX, allocatable :: w1(:, :, :, :, :)
+ COMPLEX, allocatable :: w2(:, :, :, :, :)
+
+ s = -step * impg%beta1 / THREE * ( crt - ONE )
+
+ if (s == ZERO) return
+
+ DEBUG2S("Start: dsig_sfdiff")
+ allocate(w1(NCOL, NCOL, volh_tot, EVEN:ODD, DIM))
+ allocate(w2(NCOL, NCOL, volh_tot, EVEN:ODD, DIM))
+
+ !
+ ! right staple
+ !
+
+
+ do mu = 1, 3
+ call r_staple(w1, gauge(1)%u(1,1,1,0,1), mu)
+ if (switches%boundary_sf) call schr_boundary_zero4(w1)
+ do e = EVEN, ODD
+ o = EVEN + ODD - e
+
+ ! 4==>---x t=1
+ ! | |
+ ! x------mu t=0
+
+ !$omp parallel do private(i, j1, j2, uuu, w)
+ do count = 1, bc_len_1(e)
+ i = bc_list_1(count, e)
+ j1 = nn(i, e, 4, BWD)
+ j2 = nn(j1, o, mu, FWD)
+ call ddu_imp(uuu, w1(1, 1,j2, e, 4), &
+ gauge(1)%u(1, 1,j1, o, mu), &
+ gauge(1)%u(1, 1,j1, o, 4))
+ call uu(w, gauge(1)%u(1, 1, i, e, mu), uuu)
+ call im_tr_j(p(1, i, e, mu), w, s)
+ enddo
+
+ ! 4------x t=T
+ ! | |
+ ! x==>---mu t=T-1
+
+ !$omp parallel do private(i, j1, j2, uuu, w)
+ do count = 1, bc_len_t(e)
+ i = bc_list_t(count, e)
+ j1 = nn(i, e, mu, FWD)
+ j2 = nn(i, e, 4, FWD)
+ call udd_imp(uuu, w1(1, 1, j1, o, 4), &
+ gauge(1)%u(1, 1, j2, o, mu), &
+ gauge(1)%u(1, 1, i, e, 4))
+ call uu(w, gauge(1)%u(1, 1, i, e, mu), uuu)
+ call im_tr_j(p(1, i, e, mu), w, s)
+ enddo
+ enddo
+ enddo
+
+ !
+ ! left stable
+ !
+
+
+ do mu = 1, 3
+ call l_staple(w1, gauge(1)%u(1,1,1,0,1), mu)
+ if (switches%boundary_sf) call schr_boundary_zero4(w1)
+ do e = EVEN, ODD
+ o = EVEN + ODD - e
+
+ ! 4---==>x t=1
+ ! | |
+ ! x------mu t=0
+
+ !$omp parallel do private(i, j1, j2, uuu, w)
+ do count = 1, bc_len_1(e)
+ i = bc_list_1(count, e)
+ j1 = nn(i, e, 4, BWD)
+ j2 = nn(j1, o, mu, FWD)
+ call ddu_imp(uuu, gauge(1)%u(1, 1,j2, e, 4), &
+ gauge(1)%u(1, 1,j1, o, mu), &
+ w1(1, 1,j1, o, 4))
+ call uu(w, gauge(1)%u(1, 1, i, e, mu), uuu)
+ call im_tr_j(p(1, i, e, mu), w, s)
+ enddo
+
+ ! 4------x t=T
+ ! | |
+ ! x---==>mu t=T-1
+
+ !$omp parallel do private(i, j1, j2, uuu, w)
+ do count = 1, bc_len_t(e)
+ i = bc_list_t(count, e)
+ j1 = nn(i, e, mu, FWD)
+ j2 = nn(i, e, 4, FWD)
+ call udd_imp(uuu, gauge(1)%u(1, 1, j1, o, 4), &
+ gauge(1)%u(1, 1, j2, o, mu), &
+ w1(1, 1, i, e, 4))
+ call uu(w, gauge(1)%u(1, 1, i, e, mu), uuu)
+ call im_tr_j(p(1, i, e, mu), w, s)
+ enddo
+ enddo
+
+ enddo
+
+ call u_staple(w1, gauge(1)%u(1,1,1,0,1), 4)
+ call d_staple(w2, gauge(1)%u(1,1,1,0,1), 4)
+ if (switches%boundary_sf) call schr_boundary_zero4(w1)
+ if (switches%boundary_sf) call schr_boundary_zero4(w2)
+
+ do e = EVEN, ODD
+ !$omp parallel do private(i, uuu, w)
+ do count = 1, bc_len_b(e)
+ i = bc_list_b(count, e)
+ call staple_ud(uuu, gauge(1)%u, w1, w2, i, e, 4)
+ call uu(w, gauge(1)%u(1, 1, i, e, 4), uuu)
+ call im_tr_j(p(1, i, e, 4), w, s)
+ enddo
+
+ !$omp parallel do private(i, uuu, w)
+ do count = 1, bc_len_t(e)
+ i = bc_list_t(count, e)
+ call staple_ud(uuu, gauge(1)%u, w1, w2, i, e, 4)
+ call uu(w, gauge(1)%u(1, 1, i, e, 4), uuu)
+ call im_tr_j(p(1, i, e, 4), w, s)
+ enddo
+ enddo
+
+ deallocate(w1,w2)
+ DEBUG2S("End: dsig_sfdiff")
+end
+
+!-------------------------------------------------------------------------------
+subroutine schrfunc_cswkappa(fac)
+ use module_schr_bc
+ use module_vol
+ REAL, intent(inout) :: fac(EVEN:ODD, volh)
+ integer :: eo, i, count
+
+ do eo = EVEN,ODD
+ do count = 1, bc_len_b(eo)
+ i = bc_list_b(count, eo)
+ fac(eo, i) = ZERO
+ enddo
+ enddo
+
+end
+
+!-------------------------------------------------------------------------------
+
+!!
+!! below must be correct
+!!
+!!!-------------------------------------------------------------------------------
+!!subroutine sf_classical_action()
+!! use module_action
+!! use module_lattice
+!! REAL :: lt3, lt6, sin1, sin2, w, lll, ca
+!!
+!! w = 1.5_8
+!! lll=lx*ly*lz
+!! lt3=PI/dble(3*lt*lx)
+!! lt6=PI/dble(6*lt*lx)
+!!
+!! sin0=sin( lt3)**2 + TWO * sin(lt6)**2
+!! sin1=sin(TWO*lt3)**2 + TWO * sin(lt3)**2
+!!
+!! ca = c0*sin0*lt + c1*sin1*(2*lt -3 + 2*w)
+!!
+!!write(0,*)"sf_classical_action",ca * lll * 12 / g2
+!!call flush(0)
+!!
+!!end
+!!
!===============================================================================
diff --git a/src/bqcdi.F90 b/src/bqcdi.F90
index ed7cdc4bc86b6bd210cb91e8679a83d3a1537e36..45efa0de520be24bb25b339cddb78f96a2975305 100644
--- a/src/bqcdi.F90
+++ b/src/bqcdi.F90
@@ -91,6 +91,9 @@ program bqcd
call init_cg_para()
call init_cg_stat_all()
call init_xbound()
+#ifdef QUAD
+ call init_xbound_r16()
+#endif
#ifndef D500
call init_xbound_r4()
#endif
@@ -137,6 +140,9 @@ subroutine init_para(para, flags)
use module_bqcd
use module_input
use module_mre
+#ifdef QUAD
+ use module_mre_r16
+#endif
use module_mre2
use module_switches
use module_switches
@@ -174,7 +180,10 @@ subroutine init_para(para, flags)
para%cg_log = input%solver_ignore_no_convergence
para%cg_check = input%solver_check_solution
mre_n_vec = input%solver_mre_vectors
- mre2_n_vec = input%solver_mre_vectors
+#ifdef QUAD
+ mre_n_vec_r16 = input%solver_mre_vectors
+#endif
+ mre2_n_vec = input%solver_mre_vectors
switches%measure_rhmc_forces = (input%measure_rhmc_forces /= 0)
switches%measure_minmax = (input%measure_minmax /= 0)
@@ -223,6 +232,7 @@ subroutine init_para(para, flags)
para%c_hmc(i)%n_stout = input%n_stout(i)
para%c_hmc(i)%alpha = input%alpha(i)
para%c_hmc(i)%theta = input%theta(i)
+ para%c_hmc(i)%chemi = input%chemi(i)
read(para%c_hmc(i)%kappa_strange, *) para%hmc(i)%kappa_strange
read(para%c_hmc(i)%rho2, *) para%hmc(i)%rho2
@@ -235,7 +245,8 @@ subroutine init_para(para, flags)
read(para%c_hmc(i)%n_stout ,*) para%hmc(i)%n_stout
read(para%c_hmc(i)%alpha ,*) para%hmc(i)%alpha
read(para%c_hmc(i)%theta ,*) para%hmc(i)%theta
-
+ read(para%c_hmc(i)%chemi ,*) para%hmc(i)%chemi
+chemi=para%hmc(1)%chemi
if (para%hmc(i)%kappa == ZERO .and. para%hmc(i)%csw /= ZERO) then
para%hmc(i)%csw_kappa = para%hmc(i)%csw
para%c_hmc(i)%csw = "-1 (infinity)"
@@ -372,10 +383,14 @@ subroutine init_para(para, flags)
switches%tempering = .false.
switches%measure_polyakov_loop = .false.
switches%measure_traces = .false.
+ switches%measure_chemical = .false.
+ switches%measure_schrpcac = .false.
if (input%ensembles > 1) switches%tempering = .true.
if (input%measure_polyakov_loop /= 0) switches%measure_polyakov_loop = .true.
if (input%measure_traces /= 0) switches%measure_traces = .true.
+ if (input%measure_chemical /= 0) switches%measure_chemical = .true.
+ if (input%measure_schrpcac /= 0) switches%measure_schrpcac = .true.
switches%measurement_only = .false.
switches%boundary_sf = .false.
@@ -383,6 +398,11 @@ subroutine init_para(para, flags)
if (input%boundary_sf /= 0) switches%boundary_sf = .true.
+ if (input%replay_trick_ntau /=0) then
+ if (input%replay_trick_ntau < para%hmc(1)%ntau) call die("replay_trick_ntau < ntau")
+ switches%replay = .true.
+ endif
+
if (input%hmc_test == 0) then
switches%hmc_test = .false.
else
@@ -586,6 +606,7 @@ subroutine write_header(para, flags)
write(UREC, fmt) "n_stout_", i, " ", trim(para%c_hmc(i)%n_stout)
write(UREC, fmt) "alpha_", i, " ", trim(para%c_hmc(i)%alpha)
write(UREC, fmt) "theta_", i, " ", trim(para%c_hmc(i)%theta)
+ write(UREC, fmt) "chemi_", i, " ", trim(para%c_hmc(i)%chemi)
write(UREC, fmt) "h_", i, " ", trim(para%c_hmc(i)%h)
write(UREC, fmt) "rho_", i, " ", trim(para%c_hmc(i)%rho)
write(UREC, fmt) "rho2_", i, " ", trim(para%c_hmc(i)%rho2)
@@ -607,6 +628,12 @@ if(nts>5)write(UREC, fmt) "m_scale5_", i, " ", trim(c_info_mdsteps(para
!! write(UREC, *) "fraction_u1", input%rhmc_fraction_u1
!! write(UREC, *) "fraction_u2", input%rhmc_fraction_u2
!! write(UREC, *) "roughness_level", input%rhmc_roughness_level
+
+ if (switches%replay) then
+ write(UREC, *) "HMC_replay_ntau ", input%replay_trick_ntau
+ write(UREC, *) "HMC_replay_threshold ", input%replay_trick_threshold
+ endif
+
write(UREC, *) "HMC_model ", para%hmc(1)%model
write(UREC, *) "REAL_kind ", RKIND
write(UREC, *) "Solver_outer ", trim(input%solver_outer_solver)
diff --git a/src/cksum.c b/src/cksum.c
index 356266227ee6f95251de9f9a45eb86aaf4d7b145..136cd71bd9cd8a66742cfd0e704350d28f3a797e 100644
--- a/src/cksum.c
+++ b/src/cksum.c
@@ -2,6 +2,7 @@
!===============================================================================
!
! Copyright (C) 1998-2006 Hinnerk Stueben
+! 2010 Yoshifumi Nakamura
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
@@ -140,3 +141,53 @@ void CKSUM_GET(INT8 *total_crc, INT8 *total_bytes)
*total_crc = (INT8) crc;
*total_bytes = the_bytes;
}
+
+/*--------------------------------------------------------------------------*/
+//
+// add for para IO, 2010/07/01 yn
+//
+#ifndef NONMPI
+#include <mpi.h>
+#include <stdio.h>
+/*
+void CKSUM_ADD_MPI()
+{
+ int status;
+ unsigned INT8 the_crc_tmp;
+ INT8 the_bytes_tmp;
+
+
+
+ unsigned long send= (unsigned long) the_crc;
+ unsigned long recv;
+
+ fprintf(stderr,"CKSUM_ADD_MPI crc before %lu \n",send);
+ status = MPI_Allreduce( (void *)&send, (void *)&recv, 1,
+ MPI_UNSIGNED_LONG, MPI_BXOR, MPI_COMM_WORLD);
+ fprintf(stderr,"CKSUM_ADD_MPI crc after %lu \n",recv);
+
+ status = MPI_Allreduce( (void *)&the_bytes, (void *)&the_bytes_tmp, 1,
+ MPI_LONG_LONG, MPI_SUM, MPI_COMM_WORLD);
+
+
+
+ the_crc=(unsigned INT8) recv;
+ the_bytes=the_bytes_tmp;
+}
+*/
+
+void CKSUM_BCAST(int *np)
+{
+#ifdef MPI_1
+ /* this may not work wtih MPI-1*/
+ MPI_Bcast ( (void *)&the_crc, 1, MPI_DOUBLE, *np, MPI_COMM_WORLD ) ;
+#else
+ MPI_Bcast ( (void *)&the_crc, 1, MPI_UNSIGNED_LONG_LONG, *np, MPI_COMM_WORLD ) ;
+#endif
+ MPI_Bcast ( (void *)&the_bytes, 1, MPI_LONG_LONG, *np, MPI_COMM_WORLD ) ;
+}
+
+#else
+void CKSUM_ADD_MPI(){}
+void CKSUM_BCAST(int *np){}
+#endif
diff --git a/src/comm/Makefile b/src/comm/Makefile
index b85005cd9230d62b716b13cd561660329ec8b996..0d999bd7320abdd24f105047c2b82f77de70a449 100644
--- a/src/comm/Makefile
+++ b/src/comm/Makefile
@@ -26,16 +26,16 @@ DIR=../
include $(DIR)Makefile.in
ifdef FPP2
- fpp = $(FPP2)
+ fpp = $(FPP2) -I../include $(MYFLAGS)
else
- fpp = $(FPP)
+ fpp = $(FPP) -I../include $(MYFLAGS)
endif
.SUFFIXES:
.SUFFIXES: .a .o .F90 .cc .c
.F90.o:
- $(fpp) -I../include $(MYFLAGS) $< > $*.f90
+ $(fpp) $< > $*.f90
$(F90) -c $(FFLAGS) $*.f90
.cc.o:
@@ -65,13 +65,22 @@ OBJS_MPI = \
global_mpi.o \
global_eo_sum_vec_mpi.o \
bgl_process_mapping.o \
- bgl_cart_comm_create.o
+ bgl_cart_comm_create.o\
+ ildg_io_lemon.o
+
+ifdef quad
+OBJS_MPI += \
+ allocate_r16.o \
+ xbound_mpi_r16.o \
+ reduction_mpi_r16.o
+endif
OBJS_BGL = \
dotprod.o \
comm_bgl.o \
allocate.o \
allocate_r4.o \
+ allocate_r16.o \
field_io_bgl.o \
pes_bgl.o \
broadcast_bgl.o \
@@ -86,6 +95,7 @@ OBJS_SHMEM = \
comm_shmem.o \
allocate_shmem.o \
allocate_shmem_r4.o \
+ allocate_shmem_r16.o \
field_io_shmem.o \
reduction_shmem.o \
seed_shmem.o \
@@ -98,6 +108,7 @@ OBJS_SHMEMPI = \
comm_shmempi.o \
allocate_shmem.o \
allocate_shmem_r4.o \
+ allocate_shmem_r16.o \
field_io_mpi.o \
ildg_io_mpi_r4.o \
ildg_io_mpi_r8.o \
@@ -127,6 +138,13 @@ OBJS_SINGLE_PE = \
reduction_single_pe_r4.o \
module_reduction.o
+ifdef quad
+OBJS_SINGLE_PE += \
+ allocate_r16.o \
+ xbound_single_pe_r16.o \
+ reduction_single_pe_r16.o
+endif
+
ifdef qmp
OBJS_MPI += init_qmp.o
OBJS_SINGLE_PE += init_qmp.o
@@ -155,20 +173,59 @@ lib_single_pe.a: $(OBJS_SINGLE_PE)
allocate_r4.o: allocate.F90
+ $(fpp) -DPRECISION_R4 $< > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
allocate_shmem_r4.o: allocate_shmem.F90
+ $(fpp) -DPRECISION_R4 $< > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
+
+allocate_r16.o: allocate.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
+
+allocate_shmem_r16.o: allocate_shmem.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
+
ildg_io_single_pe_r4.o: ildg_io_single_pe_r8.F90
ildg_io_mpi_r4.o: ildg_io_mpi_r8.F90
+reduction_single_pe_r4.o: reduction_single_pe.F90
+ $(fpp) -DPRECISION_R4 $< > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
+
+reduction_mpi_r4.o: reduction_mpi.F90
+ $(fpp) -DPRECISION_R4 $< > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
+
+reduction_single_pe_r16.o: reduction_single_pe.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
+
+reduction_mpi_r16.o: reduction_mpi.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
+
xbound_mpi.o: xbound_d_proj_mpi.F90
xbound_mpi_r4.o: xbound_mpi.F90 xbound_d_proj_mpi.F90
+ $(fpp) -DPRECISION_R4 xbound_mpi.F90 > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
xbound_single_pe_r4.o: xbound_single_pe.F90
+ $(fpp) -DPRECISION_R4 $< > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
+xbound_mpi_r16.o: xbound_mpi.F90 xbound_d_proj_mpi.F90
+ $(fpp) -DPRECISION_R16 xbound_mpi.F90 > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
+xbound_single_pe_r16.o: xbound_single_pe.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
clobber:
rm -f *.[Tiod] *.f90 *.mod work.pc work.pcl
diff --git a/src/comm/ildg_io_lemon.F90 b/src/comm/ildg_io_lemon.F90
new file mode 100644
index 0000000000000000000000000000000000000000..f6fc9806bf248310fb57cb66a7cf02da05baa286
--- /dev/null
+++ b/src/comm/ildg_io_lemon.F90
@@ -0,0 +1,96 @@
+!===============================================================================
+!
+! ildg_io_lemon.F90
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2010 Yoshifumi Nakamura
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+# include "defs.h"
+
+!-------------------------------------------------------------------------------
+subroutine ildg_io_lemon(action, u, precision)
+ use module_function_decl
+ use module_lattice_io
+ use module_vol
+ implicit none
+ include 'mpif.h'
+ character(*), intent(in) :: action
+ GAUGE_FIELD_ILDG, intent(inout) :: u
+ integer, intent(in) :: precision
+
+ integer :: x, y, z, t, ix, iy, iz, it
+ integer :: coord(DIM), ierror, my, gmy, my_tmp
+ INT8 :: words, words_in_u
+
+ ! 8 is size of real [bytes]
+ words = SIZE_COMPLEX * NCOL * NCOL * DIM * NX * 8
+ if (precision == 32) words = words / 2
+
+ words_in_u= SIZE_COMPLEX * NCOL * NCOL * DIM * vol
+
+ call pe2coord(my_pe(), coord)
+ my=my_pe()
+
+ if (action == "write") then
+ if (precision == 64)call swap_endian8(words_in_u, u)
+ if (precision == 32)call swap_endian4(words_in_u, u)
+ call ildg_write_lemon(u, l, vol, precision)
+ else
+ call ildg_read_lemon(u, l, vol, precision)
+ endif
+
+ !!
+ !! now calculate crc cksum
+ !!
+ do t = 0, LT - 1
+ do z = 0, LZ - 1
+ do y = 0, LY - 1
+ do x = 0, LX - 1, NX
+ it = t - nt*coord(4)
+ iz = z - nz*coord(3)
+ iy = y - ny*coord(2)
+ ix = x - nx*coord(1)
+ if ( 0<=it .and. it < nt .and. &
+ 0<=iz .and. iz < nz .and. &
+ 0<=iy .and. iy < ny .and. &
+ 0<=ix .and. ix < nx) then
+ call cksum_add(u(1,1,1,ix,iy,iz,it),words)
+ my_tmp=my
+ else
+ my_tmp=0
+ endif
+ call mpi_allreduce(my_tmp, gmy, 1, &
+ MPI_INTEGER4, MPI_SUM, MPI_COMM_WORLD, ierror)
+ call cksum_bcast(gmy)
+ call mpi_barrier(MPI_COMM_WORLD, ierror)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ if (action == "read") then
+ if (precision == 64)call swap_endian8(words_in_u, u)
+ if (precision == 32)call swap_endian4(words_in_u, u)
+ endif
+ call mpi_barrier(MPI_COMM_WORLD, ierror)
+
+end
+
+!===============================================================================
diff --git a/src/comm/xbound_single_pe.F90 b/src/comm/xbound_single_pe.F90
index 4ff6e79bfbae5bcbe9d518aa0205aec70b18e6ec..8c4f4b88c8a1bc99835879101e4e7dfd8a124cee 100644
--- a/src/comm/xbound_single_pe.F90
+++ b/src/comm/xbound_single_pe.F90
@@ -91,4 +91,37 @@ subroutine xbound_g_rect_ind(u, eo, mu, nu, fb)
return
end
+
+subroutine init_xbound_d_proj()
+ return
+end
+subroutine xbound_d_proj(a, eo, dag)
+ use module_vol
+ implicit none
+ SPINCOL_FIELD :: a
+ integer :: eo, dag
+ return
+end
+subroutine xbound_d_proj_sr(a, eo, dag)
+ use module_vol
+ implicit none
+ SPINCOL_FIELD :: a
+ integer :: eo, dag
+ return
+end
+subroutine xbound_d_proj_i(a, eo, dag)
+ use module_vol
+ implicit none
+ SPINCOL_FIELD :: a
+ integer :: eo, dag
+ return
+end
+
+subroutine xbound_sc(a, direction)
+ use module_vol
+ implicit none
+ integer :: direction
+ SPINCOL_FIELD :: a
+ return
+end
!===============================================================================
diff --git a/src/data/README b/src/data/README
index d7fcbb3febf224d23b7c4f4b439cefda71f60a94..000667bcb62d64cba770d7e473b3ddc5405309d6 100644
--- a/src/data/README
+++ b/src/data/README
@@ -10,6 +10,18 @@ bqcd.200.output output for comparison
bqcd.300.input test input for Nf = 2 + 1
bqcd.300.output output for comparison
+bqcd.310.input test input for Nf = 2 + 1 with replay trick
+bqcd.310.output output for comparison
+
+bqcd.320.input test input for Nf = 2 + 1 with RHMC tuning
+rangelist parameter files for RHMC tuning
+fractiontolerance parameter files for RHMC tuning
+bqcd.320.output output for comparison
+
+bqcd.500.input test input for NF = 3 SLOC with SF boundary condition
+bqcd.500.output output for comparison
+fAfPhist.000001 output for comparison, correlation functions for cSW
+
cool.list a cooling list (see manual)
qcdsf-configuration-04.xml an example ILDG metadata template for configurations
diff --git a/src/data/bqcd.300.input b/src/data/bqcd.300.input
index 0182f99c189988eec22c8ef896d9b48e9b53d546..0b25370916cc740a78d247478b55187a7072bfe4 100644
--- a/src/data/bqcd.300.input
+++ b/src/data/bqcd.300.input
@@ -1,3 +1,4 @@
+comment "Test for Nf=2+1"
run 300
lattice 4 4 4 4
boundary_conditions_fermions 1 1 1 -1
diff --git a/src/data/bqcd.300.output b/src/data/bqcd.300.output
index a1d40fa08da6d169984dd8c216b79af77ad06af9..12962b46881a9e0edb9c630c3e28a1eca2033b79 100644
--- a/src/data/bqcd.300.output
+++ b/src/data/bqcd.300.output
@@ -1,13 +1,14 @@
>BeginJob
>BeginHeader
- Program bqcd 4.0.0 (revision 259)
+ Comment Test for Nf=2+1
+ Program bqcd 4.0.0 (revision 324)
Version_of_D 100
- Communication single_pe
+ Communication MPI (sc:immediate) (g:immediate)
RandomNumbers ranlux-3.2 level 2
Run 300
Job 1
- Host pc58588
- Date 2010-06-11 16:56:02.444
+ Host m500
+ Date 2011-09-21 14:28:37.415
L 4 4 4 4
DDL 1 1 1 1
NPE 1 1 1 1
@@ -42,6 +43,7 @@
n_stout_1 1
alpha_1 0.1
theta_1 0.0
+ chemi_1 0.0
h_1 0.0
rho_1 0.1203
rho2_1 0.0
@@ -57,9 +59,6 @@
mpf_eo[m,l,s]: 2 0 2
mpf_dd[m,l,s]: 0 0 0
mpf_hh[m,l,s]: 0 0 0
- fraction_u1 40
- fraction_u2 0
- roughness_level 0
HMC_model F
REAL_kind 8
Solver_outer cg
@@ -93,7 +92,7 @@
%egnv -9 1 1 0.80547445E-01 2.2603050 73 41 1e-11 28.062 1.67
%egnv -9 1 2 0.74060643E-01 2.3117457 74 39 1e-11 31.214 1.72
%egnv -9 1 3 0.78792963E-01 2.2737198 73 41 1e-11 28.857 1.68
- %it -8 309 5274 1650 1179 0 0 0 0 0 0
+ %it -8 309 5273 1650 1179 0 0 0 0 0 0
%it4 -8 0 0 0 0 0 0 0 0 0 0
%Favg -8 8.173 0.726 1.348 2.465 0.067 0.809 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax -8 14.511 1.353 2.755 6.638 0.189 1.925 0.000 0.000 0.000 0.000 0.000 0.000
@@ -101,11 +100,11 @@
%Hold -8 0.9777570E+04 0.4030068E+04 0.5626949E+04 -0.5967133E+04 0.1485841E+04 0.1560926E+04 0.3040919E+04
%Hnew -8 0.9778114E+04 0.4628898E+04 0.5029892E+04 -0.5984421E+04 0.1505593E+04 0.1560220E+04 0.3037933E+04
%Hdif -8 0.5445722E+00 0.5988301E+03 -0.5970570E+03 -0.1728829E+02 0.1975166E+02 -0.7061834E+00 -0.2985696E+01
- %fa -8 1 0.6837585510 0.5800898725 203 6982 58 26 1430 65 0.316241448982582
+ %fa -8 1 0.6837585510 0.5800898725 203 6981 58 26 1430 65 0.316241448982973
%egnv -8 1 1 0.71967912E-01 2.1601388 172 64 1e-11 30.015 1.70
%egnv -8 1 2 0.65996267E-01 2.2033538 176 62 1e-11 33.386 1.75
%egnv -8 1 3 0.70350902E-01 2.1714299 173 63 1e-11 30.866 1.71
- %it -7 367 6315 1972 1416 0 0 0 0 0 0
+ %it -7 367 6315 1972 1417 0 0 0 0 0 0
%it4 -7 0 0 0 0 0 0 0 0 0 0
%Favg -7 8.463 0.775 1.341 2.442 0.071 0.862 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax -7 15.009 1.430 2.738 6.868 0.236 2.102 0.000 0.000 0.000 0.000 0.000 0.000
@@ -113,11 +112,11 @@
%Hold -7 0.9293270E+04 0.4094299E+04 0.5029892E+04 -0.5984421E+04 0.1512332E+04 0.1487833E+04 0.3153335E+04
%Hnew -7 0.9292577E+04 0.4531932E+04 0.4556032E+04 -0.5956843E+04 0.1510334E+04 0.1488096E+04 0.3163026E+04
%Hdif -7 -0.6925139E+00 0.4376328E+03 -0.4738597E+03 0.2757784E+02 -0.1997839E+01 0.2632195E+00 0.9691159E+01
- %fa -7 1 0.6247996765 1.9987337431 203 8348 72 26 1722 88 0.375200323526387
+ %fa -7 1 0.6247996765 1.9987337429 203 8348 72 26 1723 88 0.375200323526924
%egnv -7 1 1 0.35981194E-01 2.4918009 109 27 1e-11 69.253 2.12
%egnv -7 1 2 0.31457047E-01 2.5556502 113 27 1e-11 81.243 2.20
%egnv -7 1 3 0.34743068E-01 2.5084717 110 27 1e-11 72.201 2.14
- %it -6 415 6439 1996 1435 0 0 0 0 0 0
+ %it -6 415 6439 1995 1435 0 0 0 0 0 0
%it4 -6 0 0 0 0 0 0 0 0 0 0
%Favg -6 8.588 0.801 1.341 2.583 0.073 0.848 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax -6 15.164 1.485 2.883 6.699 0.201 2.233 0.000 0.000 0.000 0.000 0.000 0.000
@@ -125,11 +124,11 @@
%Hold -6 0.8871121E+04 0.4101907E+04 0.4556032E+04 -0.5956843E+04 0.1567070E+04 0.1524604E+04 0.3078351E+04
%Hnew -6 0.8870834E+04 0.4182358E+04 0.4478885E+04 -0.5981559E+04 0.1590364E+04 0.1524322E+04 0.3076463E+04
%Hdif -6 -0.2872979E+00 0.8045069E+02 -0.7714721E+02 -0.2471533E+02 0.2329443E+02 -0.2821219E+00 -0.1887758E+01
- %fa -6 1 0.6141827704 1.3328212627 203 8518 83 26 1767 89 0.385817229617386
+ %fa -6 1 0.6141827704 1.3328212641 203 8517 83 26 1767 89 0.385817229616329
%egnv -6 1 1 0.44963111E-01 2.2734221 88 50 1e-11 50.562 1.96
%egnv -6 1 2 0.39975905E-01 2.3294476 90 48 1e-11 58.271 2.03
%egnv -6 1 3 0.43602824E-01 2.2880091 89 50 1e-11 52.474 1.98
- %it -5 408 6831 2127 1499 0 0 0 0 0 0
+ %it -5 407 6831 2127 1499 0 0 0 0 0 0
%it4 -5 0 0 0 0 0 0 0 0 0 0
%Favg -5 8.537 0.810 1.325 2.374 0.073 0.792 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax -5 15.199 1.518 2.779 5.839 0.240 1.881 0.000 0.000 0.000 0.000 0.000 0.000
@@ -137,19 +136,19 @@
%Hold -5 0.8651157E+04 0.4089832E+04 0.4478885E+04 -0.5981559E+04 0.1533584E+04 0.1538412E+04 0.2992002E+04
%Hnew -5 0.8651211E+04 0.4106159E+04 0.4427728E+04 -0.5966972E+04 0.1552947E+04 0.1538339E+04 0.2993011E+04
%Hdif -5 0.5466773E-01 0.1632681E+02 -0.5115719E+02 0.1458633E+02 0.1936275E+02 -0.7251007E-01 0.1008478E+01
- %fa -5 1 0.6078148517 0.9467996885 203 9032 74 26 1833 89 0.392185148346159
+ %fa -5 1 0.6078148517 0.9467996866 203 9032 74 26 1832 89 0.392185148343124
%egnv -5 1 1 0.22021276E-01 2.4372806 104 107 1e-11 110.678 2.35
%egnv -5 1 2 0.18136345E-01 2.5058991 109 102 1e-11 138.170 2.46
%egnv -5 1 3 0.20945916E-01 2.4551219 105 104 1e-11 117.212 2.38
- %it -4 430 6845 2158 1507 0 0 0 0 0 0
+ %it -4 429 6844 2157 1507 0 0 0 0 0 0
%it4 -4 0 0 0 0 0 0 0 0 0 0
%Favg -4 8.590 0.817 1.341 2.382 0.075 0.815 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax -4 15.030 1.533 2.840 6.062 0.241 1.996 0.000 0.000 0.000 0.000 0.000 0.000
%Frat -4 62.306 6.354 11.771 25.130 1.000 8.273 0.000 0.000 0.000 0.000 0.000 0.000
%Hold -4 0.8583368E+04 0.4091101E+04 0.4427728E+04 -0.5966972E+04 0.1500592E+04 0.1498237E+04 0.3032683E+04
%Hnew -4 0.8583295E+04 0.4195410E+04 0.4340990E+04 -0.5972497E+04 0.1494524E+04 0.1498127E+04 0.3026742E+04
- %Hdif -4 -0.7338697E-01 0.1043087E+03 -0.8673771E+02 -0.5524790E+01 -0.6068144E+01 -0.1098792E+00 -0.5941606E+01
- %fa -4 1 0.5963913539 1.0761468895 203 9087 84 26 1853 89 0.403608646128713
+ %Hdif -4 -0.7338696E-01 0.1043087E+03 -0.8673771E+02 -0.5524790E+01 -0.6068144E+01 -0.1098792E+00 -0.5941606E+01
+ %fa -4 1 0.5963913539 1.0761468837 203 9085 84 26 1852 89 0.403608646129048
%egnv -4 1 1 0.30188146E-01 2.1647039 72 43 1e-11 71.707 2.14
%egnv -4 1 2 0.25911790E-01 2.2091304 74 42 1e-11 85.256 2.22
%egnv -4 1 3 0.29014812E-01 2.1763156 73 43 1e-11 75.007 2.16
@@ -161,140 +160,140 @@
%Hold -3 0.8614961E+04 0.4145810E+04 0.4340990E+04 -0.5972497E+04 0.1528241E+04 0.1522367E+04 0.3050051E+04
%Hnew -3 0.8614829E+04 0.4253580E+04 0.4279266E+04 -0.5991784E+04 0.1500857E+04 0.1521232E+04 0.3051678E+04
%Hdif -3 -0.1322210E+00 0.1077699E+03 -0.6172370E+02 -0.1928727E+02 -0.2738316E+02 -0.1135419E+01 0.1627457E+01
- %fa -3 1 0.5874912538 1.1413604914 203 9010 81 26 1820 85 0.412508746190435
+ %fa -3 1 0.5874912538 1.1413604891 203 9010 81 26 1820 85 0.412508746210098
%egnv -3 1 1 0.43832510E-01 2.0903463 114 69 1e-11 47.689 1.93
%egnv -3 1 2 0.39086798E-01 2.1258883 115 68 1e-11 54.389 2.00
%egnv -3 1 3 0.42539420E-01 2.0996774 114 68 1e-11 49.358 1.95
- %it -2 396 7076 2167 1526 0 0 0 0 0 0
+ %it -2 396 7073 2166 1525 0 0 0 0 0 0
%it4 -2 0 0 0 0 0 0 0 0 0 0
%Favg -2 8.913 0.864 1.305 2.441 0.078 0.774 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax -2 15.503 1.622 2.583 6.663 0.219 1.881 0.000 0.000 0.000 0.000 0.000 0.000
%Frat -2 70.650 7.390 11.770 30.364 1.000 8.574 0.000 0.000 0.000 0.000 0.000 0.000
%Hold -2 0.8505403E+04 0.4191183E+04 0.4279266E+04 -0.5991784E+04 0.1438738E+04 0.1538052E+04 0.3049948E+04
%Hnew -2 0.8505738E+04 0.4375280E+04 0.4115031E+04 -0.5998951E+04 0.1429808E+04 0.1538295E+04 0.3046276E+04
- %Hdif -2 0.3356661E+00 0.1840966E+03 -0.1642358E+03 -0.7166638E+01 -0.8930498E+01 0.2437761E+00 -0.3671725E+01
- %fa -2 1 0.5665928637 0.7148617392 203 9316 73 26 1849 83 0.433407136283996
+ %Hdif -2 0.3356661E+00 0.1840966E+03 -0.1642358E+03 -0.7166638E+01 -0.8930499E+01 0.2437761E+00 -0.3671725E+01
+ %fa -2 1 0.5665928635 0.7148617414 203 9312 73 26 1848 83 0.433407136480923
%egnv -2 1 1 0.36920645E-01 2.2540469 93 63 1e-11 61.051 2.06
%egnv -2 1 2 0.32990186E-01 2.3051667 96 61 1e-11 69.874 2.12
- %egnv -2 1 3 0.35843876E-01 2.2674050 93 62 1e-11 63.258 2.07
- %it -1 442 8015 2455 1689 0 0 0 0 0 0
+ %egnv -2 1 3 0.35843876E-01 2.2674049 93 62 1e-11 63.258 2.07
+ %it -1 442 8015 2454 1689 0 0 0 0 0 0
%it4 -1 0 0 0 0 0 0 0 0 0 0
%Favg -1 8.930 0.880 1.321 2.692 0.078 0.817 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax -1 15.259 1.577 2.784 7.084 0.243 1.970 0.000 0.000 0.000 0.000 0.000 0.000
%Frat -1 62.866 6.495 11.468 29.186 1.000 8.115 0.000 0.000 0.000 0.000 0.000 0.000
%Hold -1 0.8457890E+04 0.4133751E+04 0.4115031E+04 -0.5998951E+04 0.1543906E+04 0.1550057E+04 0.3114096E+04
%Hnew -1 0.8458024E+04 0.4133266E+04 0.4063189E+04 -0.5982004E+04 0.1572060E+04 0.1549422E+04 0.3122091E+04
- %Hdif -1 0.1340929E+00 -0.4850769E+00 -0.5184203E+02 0.1694690E+02 0.2815357E+02 -0.6347644E+00 0.7995497E+01
- %fa -1 1 0.5600325226 0.8745088056 203 10549 84 26 2052 99 0.439967477374255
- %egnv -1 1 1 0.20043751E-01 2.6191537 175 22 1e-11 130.672 2.44
- %egnv -1 1 2 0.16816987E-01 2.7011716 181 21 1e-11 160.622 2.54
- %egnv -1 1 3 0.19150390E-01 2.6404756 176 22 1e-11 137.881 2.46
- %it 0 479 8213 2551 1736 0 0 0 0 0 0
+ %Hdif -1 0.1340929E+00 -0.4850763E+00 -0.5184203E+02 0.1694690E+02 0.2815357E+02 -0.6347645E+00 0.7995497E+01
+ %fa -1 1 0.5600325225 0.8745087766 203 10548 84 26 2052 99 0.439967477457935
+ %egnv -1 1 1 0.20043752E-01 2.6191537 175 22 1e-11 130.672 2.44
+ %egnv -1 1 2 0.16816988E-01 2.7011717 181 21 1e-11 160.622 2.54
+ %egnv -1 1 3 0.19150390E-01 2.6404757 176 22 1e-11 137.881 2.46
+ %it 0 479 8211 2551 1733 0 0 0 0 0 0
%it4 0 0 0 0 0 0 0 0 0 0 0
%Favg 0 8.948 0.890 1.310 2.576 0.079 0.785 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax 0 14.994 1.600 2.652 7.318 0.257 1.987 0.000 0.000 0.000 0.000 0.000 0.000
%Frat 0 58.398 6.233 10.329 28.504 1.000 7.738 0.000 0.000 0.000 0.000 0.000 0.000
%Hold 0 0.8333887E+04 0.4060687E+04 0.4063189E+04 -0.5982004E+04 0.1622086E+04 0.1520595E+04 0.3049334E+04
%Hnew 0 0.8334043E+04 0.4222562E+04 0.3927864E+04 -0.5981657E+04 0.1589964E+04 0.1519281E+04 0.3056029E+04
- %Hdif 0 0.1560966E+00 0.1618753E+03 -0.1353246E+03 0.3474536E+00 -0.3212248E+02 -0.1314227E+01 0.6694721E+01
- %fa 0 1 0.5423191696 0.8554765110 203 10858 94 26 2121 100 0.457680830362908
- %egnv 0 1 1 0.21786046E-01 2.0954561 183 71 1e-11 96.183 2.28
- %egnv 0 1 2 0.18395558E-01 2.1338142 187 70 1e-11 115.996 2.38
- %egnv 0 1 3 0.20849283E-01 2.1055060 184 71 1e-11 100.987 2.31
+ %Hdif 0 0.1560966E+00 0.1618753E+03 -0.1353247E+03 0.3474509E+00 -0.3212248E+02 -0.1314227E+01 0.6694722E+01
+ %fa 0 1 0.5423191678 0.8554765410 203 10856 94 26 2118 100 0.457680832187485
+ %egnv 0 1 1 0.21786047E-01 2.0954562 183 71 1e-11 96.183 2.28
+ %egnv 0 1 2 0.18395558E-01 2.1338143 187 70 1e-11 115.996 2.38
+ %egnv 0 1 3 0.20849284E-01 2.1055060 184 71 1e-11 100.987 2.31
>EndForceAcceptance
>BeginILDGwrite
ildg-write file bqcd.300.lime
ildg-write precision 64
ildg-write bytes 147456
- ildg-write cksum 886460001
- ildg-write lfn bqcd-restart bqcd.300.lime 886460001 147456 300 1 0
+ ildg-write cksum 889189260
+ ildg-write lfn bqcd-restart bqcd.300.lime 889189260 147456 300 1 0
>EndILDGwrite
>BeginFooter
- Date 2010-06-11 16:58:33.680
+ Date 2011-09-21 14:30:51.744
Seed -1
- CPU-Time 151.2 s on 1 CPUs
+ CPU-Time 134.3 s on 1 CPUs
>BeginTiming
Performance
region #calls time mean min max Total
s Mflop/s Mflop/s Mflop/s Gflop/s
- d_xf 529058 8.59 2269.78 2269.78 2269.78 2.27
+ d_xf 528994 7.32 2664.45 2664.45 2664.45 2.66
d_xb 0
- d_yf 529058 8.40 2515.14 2515.14 2515.14 2.52
+ d_yf 528994 6.12 3451.89 3451.89 3451.89 3.45
d_yb 0
- d_zf 529058 8.76 2411.77 2411.77 2411.77 2.41
+ d_zf 528994 5.92 3571.53 3571.53 3571.53 3.57
d_zb 0
- d_t 529058 8.97 2354.78 2354.78 2354.78 2.35
+ d_t 528994 6.24 3384.98 3384.98 3384.98 3.38
d_fb 0
d_dag_fb 0
d_xyzt 0
- sc2_projection 529058 6.93 703.74 703.74 703.74 0.70
- D_TOTAL 529058 42.83 2049.29 2049.29 2049.29 2.05
+ sc2_projection 528994 7.22 675.62 675.62 675.62 0.68
+ D_TOTAL 528994 40.75 2153.53 2153.53 2153.53 2.15
d_dd 0
d_eo 0
- MTDAGMT 114697 57.08 1926.09 1926.09 1926.09 1.93
- CG 2030 46.49 1912.32 1912.32 1912.32 1.91
+ MTDAGMT 114681 50.11 2193.42 2193.42 2193.42 2.19
+ CG 2030 40.86 2175.43 2175.43 2175.43 2.18
CG_DD 0
CG_HH 0
cg_global_sum 0
- global_sum 0
- global_sum_vec 0
- sc_zero 39896 0.83
- sc_copy 12140 0.10
- sc_scale 9902 0.03 950.53 950.53 950.53 0.95
- sc_norm2 44608 0.21 1292.72 1292.72 1292.72 1.29
- sc_dot 51190 0.21 1511.96 1511.96 1511.96 1.51
- sc_axpy 360804 1.64 1354.93 1354.93 1354.93 1.35
- sc_xpby 352627 1.27 1703.16 1703.16 1703.16 1.70
- sc_axpby 326804 1.23 2444.50 2444.50 2444.50 2.44
- sc_cdotc 29180 0.17 2134.17 2134.17 2134.17 2.13
- sc_caxpy 1940 0.01 2979.47 2979.47 2979.47 2.98
- sc_caxpy2 1940 0.02 2979.47 2979.47 2979.47 2.98
- sc_cax2 1980 0.01 4055.04 4055.04 4055.04 4.06
- clover_init 2403 4.43
+ global_sum 104061 0.06
+ global_sum_vec 181776 0.57
+ sc_zero 39900 0.42
+ sc_copy 137381 0.21
+ sc_scale 9902 0.00 10146.41 10146.41 10146.41 10.15
+ sc_norm2 44603 0.03 8840.60 8840.60 8840.60 8.84
+ sc_dot 51185 0.03 10846.78 10846.78 10846.78 10.85
+ sc_axpy 360714 0.29 7617.05 7617.05 7617.05 7.62
+ sc_xpby 352579 0.15 13978.48 13978.48 13978.48 13.98
+ sc_axpby 326719 0.42 7204.47 7204.47 7204.47 7.20
+ sc_cdotc 29180 0.05 7796.22 7796.22 7796.22 7.80
+ sc_caxpy 1940 0.00 +Inf +Inf +Inf +Inf
+ sc_caxpy2 1940 0.00 23838.72 23838.72 23838.72 23.84
+ sc_cax2 1980 0.02 2862.89 2862.89 2862.89 2.86
+ clover_init 2403 3.78
clover_mult_a 0
- clover_mult_ao 498668 18.03 1954.71 1954.71 1954.71 1.95
- clover_mult_b 60200 2.53 1679.79 1679.79 1679.79 1.68
- clover_dsd 410 4.16
+ clover_mult_ao 498604 13.17 2674.56 2674.56 2674.56 2.67
+ clover_mult_b 60200 1.97 2163.87 2163.87 2163.87 2.16
+ clover_dsd 410 4.05
clover_dsf 0
- hmc_init 10 0.03
- hmc_init_p 10 0.03
- hmc_u 6400 6.58
+ hmc_init 10 0.02
+ hmc_init_p 10 0.01
+ hmc_u 6400 5.94
hmc_momenta 0
- hmc_phi 10 1.62
- hmc_h_old 10 1.68
+ hmc_phi 10 1.37
+ hmc_h_old 10 1.40
hmc_backup 10 0.00
hmc_half_step0 0
hmc_half_step1 0
hmc_xbound_g 10541 0.01
- hmc_steps 8540 140.02
- hmc_h_new 10 0.01
+ hmc_steps 8540 124.41
+ hmc_h_new 10 0.02
hmc_rest 10 0.00
- HMC 10 148.35
+ HMC 10 131.82
h_mult_a 0
h_mult_b 0
h_mult_c 0
- dsg 6410 8.32
- dsf 2020 33.43
- plaquette 21 0.00 +Inf +Inf +Inf +Inf
+ dsg 6410 6.72
+ dsf 2020 29.66
+ plaquette 21 0.01 1745.86 1745.86 1745.86 1.75
cooling 0
- ran_gauss_volh 128 0.06
+ ran_gauss_volh 128 0.04
MTDAGMT_r4 0
- dsig 1610 10.17
- rectangle 20 0.03 1778.41 1778.41 1778.41 1.78
+ dsig 1610 9.09
+ rectangle 20 0.02 2263.81 2263.81 2263.81 2.26
chair 0
parallelogram 0
- stout_smear 1601 4.06 1548.38 1548.38 1548.38 1.55
- stout_diffe 2540 12.68 2316.61 2316.61 2316.61 2.32
- clover_bsa_w 20260 2.37 2010.52 2010.52 2010.52 2.01
- clover_dsd_w 1640 1.50 1141.57 1141.57 1141.57 1.14
- clover_d_w 5900 13.74 2198.19 2198.19 2198.19 2.20
- dsf_at_bt 10130 3.25 1473.58 1473.58 1473.58 1.47
- dsf_xyztfb_w 10130 4.56 2263.58 2263.58 2263.58 2.26
- dsf_sum 10130 13.14 1512.78 1512.78 1512.78 1.51
- dsf_w2gen 2540 26.73 2095.20 2095.20 2095.20 2.10
- cgm 260 12.06 1839.82 1839.82 1839.82 1.84
- cg_ritz 82 3.93 1859.83 1859.83 1859.83 1.86
+ stout_smear 1601 3.10 2027.62 2027.62 2027.62 2.03
+ stout_diffe 2540 10.58 2778.42 2778.42 2778.42 2.78
+ clover_bsa_w 20260 3.05 1560.80 1560.80 1560.80 1.56
+ clover_dsd_w 1640 1.26 1360.02 1360.02 1360.02 1.36
+ clover_d_w 5900 13.21 2287.22 2287.22 2287.22 2.29
+ dsf_at_bt 10130 2.68 1786.46 1786.46 1786.46 1.79
+ dsf_xyztfb_w 10130 5.11 2020.18 2020.18 2020.18 2.02
+ dsf_sum 10130 14.18 1402.26 1402.26 1402.26 1.40
+ dsf_w2gen 2540 23.58 2375.32 2375.32 2375.32 2.38
+ cgm 260 10.65 2082.88 2082.88 2082.88 2.08
+ cg_ritz 82 3.36 2175.34 2175.34 2175.34 2.18
cg_mix 0
bicgstab 0
bicgstab_mix 0
@@ -302,13 +301,13 @@
unprec_mmul 0
unprec_dsf 0
dsf_un 0
- dsf_mtmp 2020 92.45
- cg_mre_mtmp 2020 49.18
- dsf_wmul_r8 2020 0.52
- dsf_wdag_r8 410 0.15
- integrator 10 146.62
+ dsf_mtmp 2020 79.97
+ cg_mre_mtmp 2020 43.16
+ dsf_wmul_r8 2020 0.45
+ dsf_wdag_r8 410 0.09
+ integrator 10 130.38
bagel_d 0
- TOTAL 1 151.23
+ TOTAL 1 134.32
Performance
region #calls time mean min max Total
@@ -320,20 +319,20 @@
u_read_bqcd 0
u_write_bqcd 0
u_read_ildg 0
- u_write_ildg 1 0.00 +Inf +Inf +Inf +Inf
+ u_write_ildg 1 0.00 147.46 147.46 147.46 0.15
>EndTiming
>EndFooter
>EndJob
>BeginJob
>BeginHeader
- Program bqcd 4.0.0 (revision 259)
+ Program bqcd 4.0.0 (revision 324)
Version_of_D 100
- Communication single_pe
+ Communication MPI (sc:immediate) (g:immediate)
RandomNumbers ranlux-3.2 level 2
Run 300
Job 2
- Host pc58588
- Date 2010-06-11 16:59:21.622
+ Host m500
+ Date 2011-09-21 14:39:59.024
L 4 4 4 4
DDL 1 1 1 1
NPE 1 1 1 1
@@ -368,6 +367,7 @@
n_stout_1 1
alpha_1 0.1
theta_1 0.0
+ chemi_1 0.0
h_1 0.0
rho_1 0.1203
rho2_1 0.0
@@ -383,9 +383,6 @@
mpf_eo[m,l,s]: 2 0 2
mpf_dd[m,l,s]: 0 0 0
mpf_hh[m,l,s]: 0 0 0
- fraction_u1 40
- fraction_u2 0
- roughness_level 0
HMC_model F
REAL_kind 8
Solver_outer cg
@@ -401,14 +398,14 @@
ildg-read file bqcd.300.lime
ildg-read precision 64
ildg-read bytes 147456
- ildg-read cksum 886460001
- ildg-read lfn bqcd-restart bqcd.300.lime 886460001 147456 300 1 0
+ ildg-read cksum 889189260
+ ildg-read lfn bqcd-restart bqcd.300.lime 889189260 147456 300 1 0
>EndILDGread
>BeginMC
T%mc traj e f PlaqEnergy exp(-Delta_H) Acc CGcalls CGitTot CGitMax CGMcalls CGMitTotCGMitMax Plaquette
T%pr traj Plaquette PlaquetteS PlaquetteT Rectangle RectangleS RectangleT
T%it traj iter_SF iter_F1 iter_F2 iter_F3 iter_F4 iter_F5 iter_F6 iter_F7 iter_F8 iter_F9
- %it 1 466 9160 2766 1827 0 0 0 0 0 0
+ %it 1 468 9158 2766 1827 0 0 0 0 0 0
%it4 1 0 0 0 0 0 0 0 0 0 0
T%Favg traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
T%Fmax traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
@@ -420,103 +417,103 @@
T%Hnew traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
T%Hdif traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
%Hold 1 0.8059372E+04 0.3981543E+04 0.3927864E+04 -0.5981657E+04 0.1572569E+04 0.1491144E+04 0.3067908E+04
- %Hnew 1 0.8059149E+04 0.4134470E+04 0.3802579E+04 -0.5991136E+04 0.1561179E+04 0.1491647E+04 0.3060409E+04
- %Hdif 1 -0.2222102E+00 0.1529275E+03 -0.1252850E+03 -0.9479002E+01 -0.1138985E+02 0.5033574E+00 -0.7499230E+01
- %mc 1 1 1 0.5256287819 1.2488337936 1 203 12014 88 26 2205 96 0.474371218105791
- %pr 1 0.4743712181058 0.4726444579752 0.4760979782364 0.2448709195136 0.2412306449670 0.2485111940602
+ %Hnew 1 0.8059149E+04 0.4134471E+04 0.3802579E+04 -0.5991136E+04 0.1561179E+04 0.1491647E+04 0.3060409E+04
+ %Hdif 1 -0.2222101E+00 0.1529275E+03 -0.1252850E+03 -0.9479001E+01 -0.1138985E+02 0.5033573E+00 -0.7499235E+01
+ %mc 1 1 1 0.5256287770 1.2488337049 1 203 12012 88 26 2207 97 0.474371223046195
+ %pr 1 0.4743712230462 0.4726444624484 0.4760979836440 0.2448709265833 0.2412306527605 0.2485112004061
T%egnv traj type mid min max it_min it_max tol condi n_opt
- %egnv 1 1 1 0.11201689E-01 2.1239394 92 55 1e-11 189.609 2.62
- %egnv 1 1 2 0.88566368E-02 2.1649865 94 54 1e-11 244.448 2.75
- %egnv 1 1 3 0.10542698E-01 2.1346871 92 55 1e-11 202.480 2.66
+ %egnv 1 1 1 0.11201679E-01 2.1239394 92 55 1e-11 189.609 2.62
+ %egnv 1 1 2 0.88566285E-02 2.1649865 94 54 1e-11 244.448 2.75
+ %egnv 1 1 3 0.10542689E-01 2.1346870 92 55 1e-11 202.480 2.66
T%tr traj e f Re(pbp) Im(pbp) Re(p5p) -Im(p5p) PionNorm CGiter
- %tr 1 1 1 1.096700490 -0.1407549329E-01 0.2229626393E-01 -0.7190087646E-12 2.751909090 98
+ %tr 1 1 1 1.096700470 -0.1407549757E-01 0.2229625706E-01 -0.7183356919E-12 2.751909058 98
T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
- %pl 1 1 1 -0.2789723339E-01 0.5139161873E-01
+ %pl 1 1 1 -0.2789723450E-01 0.5139162926E-01
>BeginCooling
T%Qc traj e f i_cool Q_cool PlaqEnergy
- %Qc 1 1 1 0 0.048126 0.5256287819
- %Qc 1 1 1 1 0.020771 0.1313428205
- %Qc 1 1 1 2 0.182281 0.0511502439
- %Qc 1 1 1 3 0.219577 0.0309807565
- %Qc 1 1 1 4 0.142080 0.0218651570
- %Qc 1 1 1 5 0.052773 0.0161620071
- %Qc 1 1 1 6 0.009561 0.0114304799
- %Qc 1 1 1 7 0.002320 0.0075411392
- %Qc 1 1 1 8 0.001251 0.0046428300
- %Qc 1 1 1 9 0.000558 0.0026599216
- %Qc 1 1 1 10 0.000203 0.0014373723
+ %Qc 1 1 1 0 0.048126 0.5256287770
+ %Qc 1 1 1 1 0.020771 0.1313428137
+ %Qc 1 1 1 2 0.182281 0.0511502420
+ %Qc 1 1 1 3 0.219577 0.0309807569
+ %Qc 1 1 1 4 0.142079 0.0218651553
+ %Qc 1 1 1 5 0.052772 0.0161620044
+ %Qc 1 1 1 6 0.009561 0.0114304766
+ %Qc 1 1 1 7 0.002320 0.0075411352
+ %Qc 1 1 1 8 0.001251 0.0046428261
+ %Qc 1 1 1 9 0.000558 0.0026599186
+ %Qc 1 1 1 10 0.000203 0.0014373703
%Qc 1 1 1 20 0.000000 0.0000057767
- %Qc 1 1 1 30 -0.000000 0.0000001381
+ %Qc 1 1 1 30 0.000000 0.0000001381
%Qc 1 1 1 40 0.000000 0.0000000048
%Qc 1 1 1 50 0.000000 0.0000000002
>EndCooling
- %it 2 455 7725 2355 1642 0 0 0 0 0 0
+ %it 2 455 7713 2353 1642 0 0 0 0 0 0
%it4 2 0 0 0 0 0 0 0 0 0 0
%Favg 2 9.177 0.940 1.294 2.393 0.063 0.763 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax 2 15.786 1.705 2.628 6.960 0.203 2.201 0.000 0.000 0.000 0.000 0.000 0.000
%Frat 2 77.904 8.415 12.971 34.348 1.000 10.863 0.000 0.000 0.000 0.000 0.000 0.000
%Hold 2 0.8090140E+04 0.4136443E+04 0.3802579E+04 -0.5991136E+04 0.1557003E+04 0.1537098E+04 0.3048153E+04
%Hnew 2 0.8089947E+04 0.4104749E+04 0.3861978E+04 -0.5997383E+04 0.1531613E+04 0.1537314E+04 0.3051676E+04
- %Hdif 2 -0.1930398E+00 -0.3169372E+02 0.5939898E+02 -0.6247830E+01 -0.2538992E+02 0.2159010E+00 0.3523546E+01
- %mc 2 1 1 0.5329972801 1.2129310686 1 203 10172 92 26 2005 98 0.467002719935582
- %pr 2 0.4670027199356 0.4683780993849 0.4656273404862 0.2414972288243 0.2417406808935 0.2412537767551
- %egnv 2 1 1 0.22479273E-01 2.2750864 88 38 1e-11 101.208 2.31
- %egnv 2 1 2 0.19130153E-01 2.3261450 89 37 1e-11 121.596 2.40
- %egnv 2 1 3 0.21554334E-01 2.2884333 88 38 1e-11 106.170 2.33
- %tr 2 1 1 1.057820167 -0.6021855563E-02 0.1866932235E-01 0.2982776063E-12 2.375531424 83
+ %Hdif 2 -0.1930397E+00 -0.3169376E+02 0.5939898E+02 -0.6247813E+01 -0.2538990E+02 0.2159003E+00 0.3523551E+01
+ %mc 2 1 1 0.5329972758 1.2129309274 1 203 10158 92 26 2005 98 0.467002724201304
+ %pr 2 0.4670027242013 0.4683781065808 0.4656273418218 0.2414972304105 0.2417406884514 0.2412537723697
+ %egnv 2 1 1 0.22479261E-01 2.2750867 88 38 1e-11 101.208 2.31
+ %egnv 2 1 2 0.19130143E-01 2.3261452 89 37 1e-11 121.596 2.40
+ %egnv 2 1 3 0.21554323E-01 2.2884335 88 38 1e-11 106.171 2.33
+ %tr 2 1 1 1.057820190 -0.6021862974E-02 0.1866931362E-01 0.3615741965E-12 2.375531840 83
T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
- %pl 2 1 1 -0.1273482066E-01 -0.2853310257E-02
+ %pl 2 1 1 -0.1273484913E-01 -0.2853321515E-02
>BeginCooling
T%Qc traj e f i_cool Q_cool PlaqEnergy
- %Qc 2 1 1 0 -0.009762 0.5329972801
- %Qc 2 1 1 1 -0.005589 0.1193819388
- %Qc 2 1 1 2 0.280278 0.0339020463
- %Qc 2 1 1 3 0.458564 0.0186745744
- %Qc 2 1 1 4 0.515329 0.0133907635
- %Qc 2 1 1 5 0.494449 0.0106876369
- %Qc 2 1 1 6 0.412660 0.0089590302
- %Qc 2 1 1 7 0.243721 0.0071402566
- %Qc 2 1 1 8 0.051628 0.0041254140
- %Qc 2 1 1 9 0.004785 0.0017870795
- %Qc 2 1 1 10 0.000654 0.0008693693
- %Qc 2 1 1 20 -0.000000 0.0000149504
- %Qc 2 1 1 30 -0.000000 0.0000007825
- %Qc 2 1 1 40 -0.000000 0.0000000488
- %Qc 2 1 1 50 -0.000000 0.0000000034
+ %Qc 2 1 1 0 -0.009762 0.5329972758
+ %Qc 2 1 1 1 -0.005589 0.1193819288
+ %Qc 2 1 1 2 0.280278 0.0339020377
+ %Qc 2 1 1 3 0.458564 0.0186745698
+ %Qc 2 1 1 4 0.515328 0.0133907596
+ %Qc 2 1 1 5 0.494448 0.0106876320
+ %Qc 2 1 1 6 0.412659 0.0089590221
+ %Qc 2 1 1 7 0.243719 0.0071402369
+ %Qc 2 1 1 8 0.051627 0.0041253851
+ %Qc 2 1 1 9 0.004785 0.0017870676
+ %Qc 2 1 1 10 0.000654 0.0008693651
+ %Qc 2 1 1 20 0.000000 0.0000149504
+ %Qc 2 1 1 30 0.000000 0.0000007825
+ %Qc 2 1 1 40 0.000000 0.0000000488
+ %Qc 2 1 1 50 0.000000 0.0000000034
>EndCooling
- %it 3 402 7600 2291 1560 0 0 0 0 0 0
+ %it 3 401 7600 2291 1560 0 0 0 0 0 0
%it4 3 0 0 0 0 0 0 0 0 0 0
%Favg 3 9.316 0.968 1.278 2.307 0.059 0.758 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax 3 15.815 1.684 2.594 6.295 0.182 1.919 0.000 0.000 0.000 0.000 0.000 0.000
%Frat 3 86.712 9.230 14.222 34.514 1.000 10.520 0.000 0.000 0.000 0.000 0.000 0.000
%Hold 3 0.8167467E+04 0.4128298E+04 0.3861978E+04 -0.5997383E+04 0.1564709E+04 0.1498362E+04 0.3111503E+04
%Hnew 3 0.8167623E+04 0.4163487E+04 0.3834727E+04 -0.6003886E+04 0.1563891E+04 0.1498577E+04 0.3110827E+04
- %Hdif 3 0.1561674E+00 0.3518970E+02 -0.2725048E+02 -0.6502840E+01 -0.8185873E+00 0.2147341E+00 -0.6763635E+00
- %mc 3 1 1 0.5292769819 0.8554159753 1 203 9971 80 26 1882 84 0.470723018098662
- %pr 3 0.4707230180987 0.4681862080567 0.4732598281407 0.2464434901217 0.2415090083184 0.2513779719250
- %egnv 3 1 1 0.30015044E-01 2.1062975 104 54 1e-11 70.175 2.13
- %egnv 3 1 2 0.26192101E-01 2.1456848 105 54 1e-11 81.921 2.20
- %egnv 3 1 3 0.28967864E-01 2.1166148 105 54 1e-11 73.068 2.15
- %tr 3 1 1 1.021762823 -0.2042151733E-01 -0.4749031798E-01 0.4647902433E-14 2.277549541 77
+ %Hdif 3 0.1561684E+00 0.3518979E+02 -0.2725051E+02 -0.6502838E+01 -0.8186301E+00 0.2147334E+00 -0.6763733E+00
+ %mc 3 1 1 0.5292769730 0.8554151541 1 203 9971 80 26 1881 84 0.470723026987640
+ %pr 3 0.4707230269876 0.4681862142698 0.4732598397055 0.2464434949806 0.2415090164368 0.2513779735243
+ %egnv 3 1 1 0.30015001E-01 2.1062975 104 54 1e-11 70.175 2.13
+ %egnv 3 1 2 0.26192060E-01 2.1456848 105 54 1e-11 81.921 2.20
+ %egnv 3 1 3 0.28967822E-01 2.1166148 105 54 1e-11 73.068 2.15
+ %tr 3 1 1 1.021762802 -0.2042146706E-01 -0.4749026802E-01 0.3708838792E-14 2.277549660 77
T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
- %pl 3 1 1 0.1773357402E-02 -0.6020302397E-02
+ %pl 3 1 1 0.1773340717E-02 -0.6020339663E-02
>BeginCooling
T%Qc traj e f i_cool Q_cool PlaqEnergy
- %Qc 3 1 1 0 0.082096 0.5292769819
- %Qc 3 1 1 1 0.130736 0.1094908249
- %Qc 3 1 1 2 0.348311 0.0290075332
- %Qc 3 1 1 3 0.482537 0.0148645258
- %Qc 3 1 1 4 0.532008 0.0109541619
- %Qc 3 1 1 5 0.531717 0.0093610450
- %Qc 3 1 1 6 0.496172 0.0084716148
- %Qc 3 1 1 7 0.418683 0.0077233870
- %Qc 3 1 1 8 0.256949 0.0064885255
- %Qc 3 1 1 9 0.051149 0.0036024180
- %Qc 3 1 1 10 0.004666 0.0014501003
- %Qc 3 1 1 20 -0.000001 0.0000733980
- %Qc 3 1 1 30 -0.000000 0.0000200829
- %Qc 3 1 1 40 -0.000000 0.0000066622
- %Qc 3 1 1 50 -0.000000 0.0000023273
+ %Qc 3 1 1 0 0.082096 0.5292769730
+ %Qc 3 1 1 1 0.130736 0.1094908154
+ %Qc 3 1 1 2 0.348311 0.0290075334
+ %Qc 3 1 1 3 0.482538 0.0148645273
+ %Qc 3 1 1 4 0.532008 0.0109541635
+ %Qc 3 1 1 5 0.531718 0.0093610467
+ %Qc 3 1 1 6 0.496172 0.0084716167
+ %Qc 3 1 1 7 0.418684 0.0077233903
+ %Qc 3 1 1 8 0.256950 0.0064885359
+ %Qc 3 1 1 9 0.051150 0.0036024366
+ %Qc 3 1 1 10 0.004666 0.0014501075
+ %Qc 3 1 1 20 -0.000001 0.0000733981
+ %Qc 3 1 1 30 0.000000 0.0000200830
+ %Qc 3 1 1 40 0.000000 0.0000066622
+ %Qc 3 1 1 50 0.000000 0.0000023273
>EndCooling
%it 4 359 6627 2011 1413 0 0 0 0 0 0
%it4 4 0 0 0 0 0 0 0 0 0 0
@@ -524,332 +521,332 @@
%Fmax 4 15.430 1.680 2.590 5.796 0.235 1.829 0.000 0.000 0.000 0.000 0.000 0.000
%Frat 4 65.672 7.152 11.026 24.668 1.000 7.786 0.000 0.000 0.000 0.000 0.000 0.000
%Hold 4 0.8032018E+04 0.4044664E+04 0.3834727E+04 -0.6003886E+04 0.1492007E+04 0.1535946E+04 0.3128561E+04
- %Hnew 4 0.8031830E+04 0.4209353E+04 0.3696939E+04 -0.6021735E+04 0.1497246E+04 0.1535235E+04 0.3114790E+04
- %Hdif 4 -0.1882389E+00 0.1646888E+03 -0.1377879E+03 -0.1784827E+02 0.5239810E+01 -0.7103588E+00 -0.1377034E+02
- %mc 4 1 1 0.5098751753 1.2071218126 1 203 8712 74 26 1698 77 0.490124824737818
- %pr 4 0.4901248247378 0.4871551218511 0.4930945276245 0.2773603205663 0.2734506483273 0.2812699928054
- %egnv 4 1 1 0.65502609E-01 2.0458115 171 64 1e-11 31.233 1.72
- %egnv 4 1 2 0.61459935E-01 2.0819227 136 63 1e-11 33.874 1.76
- %egnv 4 1 3 0.64416896E-01 2.0552798 169 64 1e-11 31.906 1.73
- %tr 4 1 1 1.007907845 -0.7601643054E-02 0.2443747534E-01 0.1701113209E-12 2.040834341 63
+ %Hnew 4 0.8031830E+04 0.4209353E+04 0.3696940E+04 -0.6021735E+04 0.1497246E+04 0.1535235E+04 0.3114790E+04
+ %Hdif 4 -0.1882383E+00 0.1646887E+03 -0.1377878E+03 -0.1784831E+02 0.5239860E+01 -0.7103572E+00 -0.1377036E+02
+ %mc 4 1 1 0.5098751838 1.2071211928 1 203 8712 74 26 1698 77 0.490124816237965
+ %pr 4 0.4901248162380 0.4871551144651 0.4930945180108 0.2773603035793 0.2734506445581 0.2812699626005
+ %egnv 4 1 1 0.65502654E-01 2.0458122 171 64 1e-11 31.233 1.72
+ %egnv 4 1 2 0.61460003E-01 2.0819235 136 63 1e-11 33.874 1.76
+ %egnv 4 1 3 0.64416952E-01 2.0552805 169 64 1e-11 31.906 1.73
+ %tr 4 1 1 1.007907740 -0.7601657422E-02 0.2443749522E-01 0.1701416785E-12 2.040833175 63
T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
- %pl 4 1 1 0.7951725245E-01 0.5623780163E-01
+ %pl 4 1 1 0.7951735428E-01 0.5623785358E-01
>BeginCooling
T%Qc traj e f i_cool Q_cool PlaqEnergy
- %Qc 4 1 1 0 0.045646 0.5098751753
- %Qc 4 1 1 1 -0.029235 0.0931408422
- %Qc 4 1 1 2 0.001388 0.0184513185
- %Qc 4 1 1 3 0.003494 0.0052928934
- %Qc 4 1 1 4 0.001061 0.0023353861
- %Qc 4 1 1 5 0.000387 0.0012942043
- %Qc 4 1 1 6 0.000180 0.0008218519
- %Qc 4 1 1 7 0.000100 0.0005731850
- %Qc 4 1 1 8 0.000059 0.0004276599
+ %Qc 4 1 1 0 0.045646 0.5098751838
+ %Qc 4 1 1 1 -0.029234 0.0931408520
+ %Qc 4 1 1 2 0.001388 0.0184513252
+ %Qc 4 1 1 3 0.003494 0.0052928955
+ %Qc 4 1 1 4 0.001061 0.0023353871
+ %Qc 4 1 1 5 0.000387 0.0012942050
+ %Qc 4 1 1 6 0.000180 0.0008218524
+ %Qc 4 1 1 7 0.000100 0.0005731852
+ %Qc 4 1 1 8 0.000059 0.0004276600
%Qc 4 1 1 9 0.000037 0.0003349832
- %Qc 4 1 1 10 0.000023 0.0002717444
- %Qc 4 1 1 20 -0.000000 0.0000711819
- %Qc 4 1 1 30 -0.000000 0.0000293477
- %Qc 4 1 1 40 -0.000000 0.0000144832
- %Qc 4 1 1 50 -0.000000 0.0000078682
+ %Qc 4 1 1 10 0.000023 0.0002717443
+ %Qc 4 1 1 20 0.000000 0.0000711818
+ %Qc 4 1 1 30 0.000000 0.0000293476
+ %Qc 4 1 1 40 0.000000 0.0000144831
+ %Qc 4 1 1 50 0.000000 0.0000078681
>EndCooling
%it 5 314 5524 1698 1202 0 0 0 0 0 0
%it4 5 0 0 0 0 0 0 0 0 0 0
%Favg 5 9.482 1.018 1.283 2.051 0.066 0.702 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax 5 15.906 1.765 2.497 5.144 0.220 1.751 0.000 0.000 0.000 0.000 0.000 0.000
%Frat 5 72.376 8.032 11.363 23.406 1.000 7.968 0.000 0.000 0.000 0.000 0.000 0.000
- %Hold 5 0.7907837E+04 0.4124302E+04 0.3696939E+04 -0.6021735E+04 0.1493893E+04 0.1589574E+04 0.3024863E+04
- %Hnew 5 0.7907717E+04 0.4170782E+04 0.3640564E+04 -0.6017343E+04 0.1500153E+04 0.1589358E+04 0.3024205E+04
- %Hdif 5 -0.1194158E+00 0.4647944E+02 -0.5637588E+02 0.4391044E+01 0.6260341E+01 -0.2158011E+00 -0.6585559E+00
- %mc 5 1 1 0.5031014784 1.1268383552 1 203 7284 62 26 1454 65 0.496898521559694
- %pr 5 0.4968985215597 0.4932022938734 0.5005947492460 0.2783644727806 0.2752902984062 0.2814386471549
- %egnv 5 1 1 0.55985783E-01 2.1002743 57 79 1e-11 37.514 1.81
- %egnv 5 1 2 0.52921759E-01 2.1423924 58 75 1e-11 40.482 1.85
- %egnv 5 1 3 0.55143429E-01 2.1112897 58 78 1e-11 38.287 1.82
- %tr 5 1 1 1.001996987 0.3439318868E-01 0.8709399251E-02 0.2187463174E-12 2.079031150 59
+ %Hold 5 0.7907837E+04 0.4124302E+04 0.3696940E+04 -0.6021735E+04 0.1493893E+04 0.1589574E+04 0.3024863E+04
+ %Hnew 5 0.7907717E+04 0.4170782E+04 0.3640564E+04 -0.6017344E+04 0.1500153E+04 0.1589358E+04 0.3024205E+04
+ %Hdif 5 -0.1194159E+00 0.4647945E+02 -0.5637582E+02 0.4390938E+01 0.6260358E+01 -0.2158074E+00 -0.6585272E+00
+ %mc 5 1 1 0.5031014919 1.1268384922 1 203 7284 62 26 1454 65 0.496898508071844
+ %pr 5 0.4968985080718 0.4932023050255 0.5005947111182 0.2783644750499 0.2752902995812 0.2814386505187
+ %egnv 5 1 1 0.55985947E-01 2.1002751 57 79 1e-11 37.514 1.81
+ %egnv 5 1 2 0.52921920E-01 2.1423933 58 75 1e-11 40.482 1.85
+ %egnv 5 1 3 0.55143592E-01 2.1112906 58 78 1e-11 38.287 1.82
+ %tr 5 1 1 1.001996920 0.3439334613E-01 0.8709501380E-02 0.2185751580E-12 2.079030151 59
T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
- %pl 5 1 1 0.1138802121 0.4482838698E-02
+ %pl 5 1 1 0.1138805534 0.4482829392E-02
>BeginCooling
T%Qc traj e f i_cool Q_cool PlaqEnergy
- %Qc 5 1 1 0 0.027003 0.5031014784
- %Qc 5 1 1 1 -0.080645 0.0867700263
- %Qc 5 1 1 2 -0.054680 0.0171108504
- %Qc 5 1 1 3 -0.007190 0.0055779860
- %Qc 5 1 1 4 -0.001143 0.0023577164
- %Qc 5 1 1 5 -0.000409 0.0012326226
- %Qc 5 1 1 6 -0.000174 0.0007421948
- %Qc 5 1 1 7 -0.000077 0.0004950696
- %Qc 5 1 1 8 -0.000036 0.0003559673
- %Qc 5 1 1 9 -0.000018 0.0002700183
+ %Qc 5 1 1 0 0.027002 0.5031014919
+ %Qc 5 1 1 1 -0.080644 0.0867700000
+ %Qc 5 1 1 2 -0.054677 0.0171107429
+ %Qc 5 1 1 3 -0.007189 0.0055779297
+ %Qc 5 1 1 4 -0.001143 0.0023577075
+ %Qc 5 1 1 5 -0.000409 0.0012326219
+ %Qc 5 1 1 6 -0.000174 0.0007421952
+ %Qc 5 1 1 7 -0.000077 0.0004950700
+ %Qc 5 1 1 8 -0.000036 0.0003559675
+ %Qc 5 1 1 9 -0.000018 0.0002700184
%Qc 5 1 1 10 -0.000010 0.0002125880
- %Qc 5 1 1 20 -0.000001 0.0000387951
- %Qc 5 1 1 30 -0.000000 0.0000102065
- %Qc 5 1 1 40 -0.000000 0.0000032597
- %Qc 5 1 1 50 -0.000000 0.0000011935
+ %Qc 5 1 1 20 -0.000001 0.0000387950
+ %Qc 5 1 1 30 0.000000 0.0000102066
+ %Qc 5 1 1 40 0.000000 0.0000032598
+ %Qc 5 1 1 50 0.000000 0.0000011935
>EndCooling
- %it 6 284 4843 1476 1074 0 0 0 0 0 0
+ %it 6 284 4840 1476 1074 0 0 0 0 0 0
%it4 6 0 0 0 0 0 0 0 0 0 0
%Favg 6 9.655 1.064 1.253 2.035 0.053 0.680 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax 6 16.137 1.794 2.508 5.690 0.163 1.586 0.000 0.000 0.000 0.000 0.000 0.000
%Frat 6 99.208 11.027 15.421 34.982 1.000 9.750 0.000 0.000 0.000 0.000 0.000 0.000
- %Hold 6 0.7711427E+04 0.4021976E+04 0.3640564E+04 -0.6017343E+04 0.1557628E+04 0.1489029E+04 0.3019573E+04
- %Hnew 6 0.7711868E+04 0.4145540E+04 0.3545618E+04 -0.6029318E+04 0.1542523E+04 0.1489057E+04 0.3018447E+04
- %Hdif 6 0.4417190E+00 0.1235644E+03 -0.9494551E+02 -0.1197408E+02 -0.1510536E+02 0.2809388E-01 -0.1125836E+01
- %mc 6 1 1 0.5031014784 0.6429302791 0 203 6377 58 26 1300 61 0.496898521559694
- %pr 6 0.4968985215597 0.4932022938734 0.5005947492460 0.2783644727806 0.2752902984062 0.2814386471549
- %egnv 6 1 1 0.55985783E-01 2.1002743 57 79 1e-11 37.514 1.81
- %egnv 6 1 2 0.52921759E-01 2.1423924 58 75 1e-11 40.482 1.85
- %egnv 6 1 3 0.55143429E-01 2.1112897 58 78 1e-11 38.287 1.82
- %tr 6 1 1 1.021818852 -0.8049552490E-02 0.1859040886E-01 0.2879403891E-12 2.002771437 60
+ %Hold 6 0.7711427E+04 0.4021976E+04 0.3640564E+04 -0.6017344E+04 0.1557628E+04 0.1489029E+04 0.3019573E+04
+ %Hnew 6 0.7711868E+04 0.4145540E+04 0.3545618E+04 -0.6029317E+04 0.1542523E+04 0.1489057E+04 0.3018448E+04
+ %Hdif 6 0.4417224E+00 0.1235641E+03 -0.9494574E+02 -0.1197384E+02 -0.1510522E+02 0.2810082E-01 -0.1125694E+01
+ %mc 6 1 1 0.5031014919 0.6429280999 0 203 6374 58 26 1300 61 0.496898508071844
+ %pr 6 0.4968985080718 0.4932023050255 0.5005947111182 0.2783644750499 0.2752902995812 0.2814386505187
+ %egnv 6 1 1 0.55985947E-01 2.1002751 57 79 1e-11 37.514 1.81
+ %egnv 6 1 2 0.52921920E-01 2.1423933 58 75 1e-11 40.482 1.85
+ %egnv 6 1 3 0.55143592E-01 2.1112906 58 78 1e-11 38.287 1.82
+ %tr 6 1 1 1.021818811 -0.8049552374E-02 0.1859023707E-01 0.2879224636E-12 2.002770834 60
T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
- %pl 6 1 1 0.1138802121 0.4482838698E-02
+ %pl 6 1 1 0.1138805534 0.4482829392E-02
>BeginCooling
T%Qc traj e f i_cool Q_cool PlaqEnergy
- %Qc 6 1 1 0 0.027003 0.5031014784
- %Qc 6 1 1 1 -0.080645 0.0867700263
- %Qc 6 1 1 2 -0.054680 0.0171108504
- %Qc 6 1 1 3 -0.007190 0.0055779860
- %Qc 6 1 1 4 -0.001143 0.0023577164
- %Qc 6 1 1 5 -0.000409 0.0012326226
- %Qc 6 1 1 6 -0.000174 0.0007421948
- %Qc 6 1 1 7 -0.000077 0.0004950696
- %Qc 6 1 1 8 -0.000036 0.0003559673
- %Qc 6 1 1 9 -0.000018 0.0002700183
+ %Qc 6 1 1 0 0.027002 0.5031014919
+ %Qc 6 1 1 1 -0.080644 0.0867700000
+ %Qc 6 1 1 2 -0.054677 0.0171107429
+ %Qc 6 1 1 3 -0.007189 0.0055779297
+ %Qc 6 1 1 4 -0.001143 0.0023577075
+ %Qc 6 1 1 5 -0.000409 0.0012326219
+ %Qc 6 1 1 6 -0.000174 0.0007421952
+ %Qc 6 1 1 7 -0.000077 0.0004950700
+ %Qc 6 1 1 8 -0.000036 0.0003559675
+ %Qc 6 1 1 9 -0.000018 0.0002700184
%Qc 6 1 1 10 -0.000010 0.0002125880
- %Qc 6 1 1 20 -0.000001 0.0000387951
- %Qc 6 1 1 30 -0.000000 0.0000102065
- %Qc 6 1 1 40 -0.000000 0.0000032597
- %Qc 6 1 1 50 -0.000000 0.0000011935
+ %Qc 6 1 1 20 -0.000001 0.0000387950
+ %Qc 6 1 1 30 0.000000 0.0000102066
+ %Qc 6 1 1 40 0.000000 0.0000032598
+ %Qc 6 1 1 50 0.000000 0.0000011935
>EndCooling
- %it 7 307 5336 1618 1164 0 0 0 0 0 0
+ %it 7 307 5336 1618 1162 0 0 0 0 0 0
%it4 7 0 0 0 0 0 0 0 0 0 0
%Favg 7 9.477 1.033 1.265 2.097 0.056 0.707 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax 7 15.923 1.808 2.602 5.365 0.152 1.725 0.000 0.000 0.000 0.000 0.000 0.000
%Frat 7 104.582 11.874 17.091 35.238 1.000 11.327 0.000 0.000 0.000 0.000 0.000 0.000
- %Hold 7 0.8015286E+04 0.4099800E+04 0.3640564E+04 -0.6017343E+04 0.1590498E+04 0.1568021E+04 0.3133748E+04
- %Hnew 7 0.8015235E+04 0.4183155E+04 0.3571096E+04 -0.6012626E+04 0.1584634E+04 0.1567366E+04 0.3121610E+04
- %Hdif 7 -0.5113948E-01 0.8335553E+02 -0.6946721E+02 0.4717735E+01 -0.5864061E+01 -0.6556146E+00 -0.1213753E+02
- %mc 7 1 1 0.4940644414 1.0524696860 1 203 7012 58 26 1413 64 0.505935558570389
- %pr 7 0.5059355585704 0.5058614794300 0.5060096377108 0.2865056687715 0.2908622534745 0.2821490840686
- %egnv 7 1 1 0.54562660E-01 2.1441410 139 46 1e-11 39.297 1.84
- %egnv 7 1 2 0.50838984E-01 2.1892239 135 45 1e-11 43.062 1.88
- %egnv 7 1 3 0.53545687E-01 2.1559265 137 46 1e-11 40.263 1.85
- %tr 7 1 1 1.038466593 0.1605924825E-01 0.3407742008E-01 0.4800454016E-12 2.153321764 63
+ %Hold 7 0.8015286E+04 0.4099800E+04 0.3640564E+04 -0.6017344E+04 0.1590498E+04 0.1568021E+04 0.3133748E+04
+ %Hnew 7 0.8015235E+04 0.4183154E+04 0.3571097E+04 -0.6012626E+04 0.1584634E+04 0.1567366E+04 0.3121610E+04
+ %Hdif 7 -0.5114375E-01 0.8335450E+02 -0.6946645E+02 0.4717881E+01 -0.5863984E+01 -0.6556227E+00 -0.1213747E+02
+ %mc 7 1 1 0.4940645550 1.0524741801 1 203 7012 58 26 1411 64 0.505935444971773
+ %pr 7 0.5059354449718 0.5058614714847 0.5060094184589 0.2865055656035 0.2908621877491 0.2821489434578
+ %egnv 7 1 1 0.54562852E-01 2.1441359 139 46 1e-11 39.297 1.84
+ %egnv 7 1 2 0.50839167E-01 2.1892184 135 45 1e-11 43.062 1.88
+ %egnv 7 1 3 0.53545877E-01 2.1559214 137 46 1e-11 40.263 1.85
+ %tr 7 1 1 1.038466540 0.1605938750E-01 0.3407762013E-01 0.4752147749E-12 2.153323043 63
T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
- %pl 7 1 1 0.1059552749 0.4013742461E-01
+ %pl 7 1 1 0.1059549123 0.4013756611E-01
>BeginCooling
T%Qc traj e f i_cool Q_cool PlaqEnergy
- %Qc 7 1 1 0 0.039829 0.4940644414
- %Qc 7 1 1 1 -0.077202 0.0875074447
- %Qc 7 1 1 2 -0.009690 0.0174920790
- %Qc 7 1 1 3 0.001651 0.0054441039
- %Qc 7 1 1 4 0.000961 0.0023981248
- %Qc 7 1 1 5 0.000521 0.0013220648
- %Qc 7 1 1 6 0.000299 0.0008278102
- %Qc 7 1 1 7 0.000182 0.0005630218
- %Qc 7 1 1 8 0.000117 0.0004060663
- %Qc 7 1 1 9 0.000078 0.0003059132
- %Qc 7 1 1 10 0.000054 0.0002381615
- %Qc 7 1 1 20 0.000002 0.0000411097
- %Qc 7 1 1 30 0.000000 0.0000101558
+ %Qc 7 1 1 0 0.039831 0.4940645550
+ %Qc 7 1 1 1 -0.077203 0.0875075687
+ %Qc 7 1 1 2 -0.009691 0.0174921751
+ %Qc 7 1 1 3 0.001651 0.0054441412
+ %Qc 7 1 1 4 0.000961 0.0023981364
+ %Qc 7 1 1 5 0.000521 0.0013220685
+ %Qc 7 1 1 6 0.000299 0.0008278110
+ %Qc 7 1 1 7 0.000182 0.0005630213
+ %Qc 7 1 1 8 0.000117 0.0004060652
+ %Qc 7 1 1 9 0.000078 0.0003059119
+ %Qc 7 1 1 10 0.000054 0.0002381602
+ %Qc 7 1 1 20 0.000002 0.0000411089
+ %Qc 7 1 1 30 0.000000 0.0000101555
%Qc 7 1 1 40 0.000000 0.0000026919
- %Qc 7 1 1 50 0.000000 0.0000007363
+ %Qc 7 1 1 50 0.000000 0.0000007362
>EndCooling
%it 8 302 4696 1431 1063 0 0 0 0 0 0
%it4 8 0 0 0 0 0 0 0 0 0 0
%Favg 8 9.507 1.048 1.262 2.120 0.049 0.691 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax 8 15.685 1.748 2.664 5.060 0.139 1.547 0.000 0.000 0.000 0.000 0.000 0.000
%Frat 8 112.648 12.552 19.131 36.341 1.000 11.110 0.000 0.000 0.000 0.000 0.000 0.000
- %Hold 8 0.7775594E+04 0.4076839E+04 0.3571096E+04 -0.6012626E+04 0.1539474E+04 0.1536608E+04 0.3064202E+04
- %Hnew 8 0.7775299E+04 0.4189634E+04 0.3454245E+04 -0.6021089E+04 0.1552887E+04 0.1535884E+04 0.3063738E+04
- %Hdif 8 -0.2944022E+00 0.1127952E+03 -0.1168511E+03 -0.8463289E+01 0.1341280E+02 -0.7246042E+00 -0.4634163E+00
- %mc 8 1 1 0.4784649756 1.3423236869 1 203 6187 60 26 1305 64 0.521535024389628
- %pr 8 0.5215350243896 0.5201126083548 0.5229574404244 0.3041822322966 0.3066437871460 0.3017206774472
- %egnv 8 1 1 0.89804417E-01 2.1318832 402 49 1e-11 23.739 1.58
- %egnv 8 1 2 0.87969935E-01 2.1776359 458 47 1e-11 24.754 1.60
- %egnv 8 1 3 0.89284234E-01 2.1438379 410 49 1e-11 24.011 1.59
- %tr 8 1 1 1.005232580 -0.1776836719E-01 0.1515187603E-01 0.9981830177E-13 1.925465958 56
+ %Hold 8 0.7775594E+04 0.4076839E+04 0.3571097E+04 -0.6012626E+04 0.1539474E+04 0.1536608E+04 0.3064202E+04
+ %Hnew 8 0.7775300E+04 0.4189633E+04 0.3454247E+04 -0.6021089E+04 0.1552886E+04 0.1535884E+04 0.3063738E+04
+ %Hdif 8 -0.2944143E+00 0.1127944E+03 -0.1168503E+03 -0.8463230E+01 0.1341267E+02 -0.7246035E+00 -0.4633272E+00
+ %mc 8 1 1 0.4784652040 1.3423399820 1 203 6187 60 26 1305 64 0.521534795979921
+ %pr 8 0.5215347959799 0.5201125895339 0.5229570024259 0.3041819451087 0.3066437102312 0.3017201799862
+ %egnv 8 1 1 0.89804536E-01 2.1318790 402 49 1e-11 23.739 1.58
+ %egnv 8 1 2 0.87970045E-01 2.1776315 458 47 1e-11 24.754 1.60
+ %egnv 8 1 3 0.89284351E-01 2.1438337 410 49 1e-11 24.011 1.59
+ %tr 8 1 1 1.005232548 -0.1776789782E-01 0.1515165817E-01 0.9984258790E-13 1.925466705 56
T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
- %pl 8 1 1 0.2075269581 -0.2875034199E-02
+ %pl 8 1 1 0.2075281073 -0.2875211505E-02
>BeginCooling
T%Qc traj e f i_cool Q_cool PlaqEnergy
- %Qc 8 1 1 0 0.002028 0.4784649756
- %Qc 8 1 1 1 0.015649 0.0739165664
- %Qc 8 1 1 2 -0.000337 0.0117042590
- %Qc 8 1 1 3 0.001183 0.0041610990
- %Qc 8 1 1 4 0.000999 0.0021419626
- %Qc 8 1 1 5 0.000624 0.0012944200
- %Qc 8 1 1 6 0.000384 0.0008672893
- %Qc 8 1 1 7 0.000246 0.0006281566
- %Qc 8 1 1 8 0.000165 0.0004827686
- %Qc 8 1 1 9 0.000115 0.0003880828
- %Qc 8 1 1 10 0.000083 0.0003226650
- %Qc 8 1 1 20 0.000006 0.0001077947
- %Qc 8 1 1 30 0.000000 0.0000541516
- %Qc 8 1 1 40 -0.000000 0.0000309701
- %Qc 8 1 1 50 -0.000000 0.0000189534
+ %Qc 8 1 1 0 0.002027 0.4784652040
+ %Qc 8 1 1 1 0.015649 0.0739168346
+ %Qc 8 1 1 2 -0.000337 0.0117043398
+ %Qc 8 1 1 3 0.001183 0.0041611320
+ %Qc 8 1 1 4 0.000999 0.0021419796
+ %Qc 8 1 1 5 0.000624 0.0012944292
+ %Qc 8 1 1 6 0.000384 0.0008672942
+ %Qc 8 1 1 7 0.000246 0.0006281591
+ %Qc 8 1 1 8 0.000165 0.0004827697
+ %Qc 8 1 1 9 0.000115 0.0003880831
+ %Qc 8 1 1 10 0.000083 0.0003226648
+ %Qc 8 1 1 20 0.000006 0.0001077940
+ %Qc 8 1 1 30 0.000000 0.0000541512
+ %Qc 8 1 1 40 0.000000 0.0000309698
+ %Qc 8 1 1 50 0.000000 0.0000189532
>EndCooling
%it 9 278 4611 1400 1029 0 0 0 0 0 0
%it4 9 0 0 0 0 0 0 0 0 0 0
%Favg 9 9.639 1.071 1.268 1.943 0.053 0.713 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax 9 15.785 1.806 2.600 4.739 0.143 1.810 0.000 0.000 0.000 0.000 0.000 0.000
- %Frat 9 110.570 12.650 18.212 33.199 1.000 12.678 0.000 0.000 0.000 0.000 0.000 0.000
- %Hold 9 0.7850211E+04 0.4133535E+04 0.3454245E+04 -0.6021089E+04 0.1494688E+04 0.1594648E+04 0.3194184E+04
- %Hnew 9 0.7850568E+04 0.4138992E+04 0.3457535E+04 -0.6034924E+04 0.1511286E+04 0.1595209E+04 0.3182469E+04
- %Hdif 9 0.3565416E+00 0.5456571E+01 0.3289833E+01 -0.1383473E+02 0.1659775E+02 0.5614769E+00 -0.1171437E+02
- %mc 9 1 1 0.4783439102 0.7000933530 1 203 6066 55 26 1252 58 0.521656089758662
- %pr 9 0.5216560897587 0.5175579692613 0.5257542102560 0.3092871013305 0.2946128306597 0.3239613720014
- %egnv 9 1 1 0.79339562E-01 2.1200901 60 38 1e-11 26.722 1.64
- %egnv 9 1 2 0.76287012E-01 2.1642184 61 37 1e-11 28.369 1.67
- %egnv 9 1 3 0.78499302E-01 2.1316285 60 38 1e-11 27.155 1.65
- %tr 9 1 1 1.017316061 0.1019396879E-01 -0.3873125184E-02 0.3965323440E-12 1.988905552 53
+ %Frat 9 110.569 12.650 18.212 33.199 1.000 12.678 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 9 0.7850213E+04 0.4133535E+04 0.3454247E+04 -0.6021089E+04 0.1494688E+04 0.1594648E+04 0.3194184E+04
+ %Hnew 9 0.7850570E+04 0.4138991E+04 0.3457538E+04 -0.6034924E+04 0.1511286E+04 0.1595209E+04 0.3182469E+04
+ %Hdif 9 0.3565431E+00 0.5455512E+01 0.3291321E+01 -0.1383545E+02 0.1659824E+02 0.5615024E+00 -0.1171458E+02
+ %mc 9 1 1 0.4783442927 0.7000922742 1 203 6066 55 26 1252 58 0.521655707272326
+ %pr 9 0.5216557072723 0.5175574633608 0.5257539511838 0.3092870341369 0.2946129849990 0.3239610832748
+ %egnv 9 1 1 0.79341387E-01 2.1200690 60 38 1e-11 26.721 1.64
+ %egnv 9 1 2 0.76288790E-01 2.1641957 61 37 1e-11 28.368 1.67
+ %egnv 9 1 3 0.78501115E-01 2.1316070 60 38 1e-11 27.154 1.65
+ %tr 9 1 1 1.017315715 0.1019447404E-01 -0.3872964918E-02 0.3966439445E-12 1.988903398 53
T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
- %pl 9 1 1 0.2796975100 0.7808683790E-02
+ %pl 9 1 1 0.2796950282 0.7809490015E-02
>BeginCooling
T%Qc traj e f i_cool Q_cool PlaqEnergy
- %Qc 9 1 1 0 0.015460 0.4783439102
- %Qc 9 1 1 1 -0.031638 0.0709671563
- %Qc 9 1 1 2 -0.004020 0.0099617757
- %Qc 9 1 1 3 -0.000717 0.0031588151
- %Qc 9 1 1 4 -0.000133 0.0014990532
- %Qc 9 1 1 5 -0.000030 0.0008893425
- %Qc 9 1 1 6 -0.000018 0.0006135112
- %Qc 9 1 1 7 -0.000020 0.0004674604
- %Qc 9 1 1 8 -0.000021 0.0003788013
- %Qc 9 1 1 9 -0.000021 0.0003186521
- %Qc 9 1 1 10 -0.000019 0.0002743553
- %Qc 9 1 1 20 -0.000005 0.0000937959
- %Qc 9 1 1 30 -0.000001 0.0000408909
- %Qc 9 1 1 40 -0.000000 0.0000197091
- %Qc 9 1 1 50 -0.000000 0.0000101358
+ %Qc 9 1 1 0 0.015458 0.4783442927
+ %Qc 9 1 1 1 -0.031634 0.0709672566
+ %Qc 9 1 1 2 -0.004020 0.0099618190
+ %Qc 9 1 1 3 -0.000717 0.0031588453
+ %Qc 9 1 1 4 -0.000133 0.0014990782
+ %Qc 9 1 1 5 -0.000030 0.0008893626
+ %Qc 9 1 1 6 -0.000018 0.0006135269
+ %Qc 9 1 1 7 -0.000020 0.0004674728
+ %Qc 9 1 1 8 -0.000021 0.0003788112
+ %Qc 9 1 1 9 -0.000021 0.0003186601
+ %Qc 9 1 1 10 -0.000019 0.0002743619
+ %Qc 9 1 1 20 -0.000005 0.0000937979
+ %Qc 9 1 1 30 -0.000001 0.0000408921
+ %Qc 9 1 1 40 0.000000 0.0000197099
+ %Qc 9 1 1 50 0.000000 0.0000101365
>EndCooling
%it 10 268 4598 1388 1018 0 0 0 0 0 0
%it4 10 0 0 0 0 0 0 0 0 0 0
%Favg 10 9.724 1.094 1.257 2.038 0.051 0.670 0.000 0.000 0.000 0.000 0.000 0.000
%Fmax 10 15.974 1.861 2.511 5.364 0.151 1.614 0.000 0.000 0.000 0.000 0.000 0.000
- %Frat 10 105.778 12.326 16.627 35.521 1.000 10.690 0.000 0.000 0.000 0.000 0.000 0.000
- %Hold 10 0.7651666E+04 0.4096361E+04 0.3457535E+04 -0.6034924E+04 0.1594950E+04 0.1543888E+04 0.2993857E+04
- %Hnew 10 0.7651844E+04 0.4112810E+04 0.3453801E+04 -0.6026672E+04 0.1576267E+04 0.1544064E+04 0.2991575E+04
- %Hdif 10 0.1781014E+00 0.1644903E+02 -0.3733711E+01 0.8252019E+01 -0.1868320E+02 0.1756377E+00 -0.2281678E+01
- %mc 10 1 1 0.4782961713 0.8368575590 1 203 6038 52 26 1234 54 0.521703828699875
- %pr 10 0.5217038286999 0.5220441959034 0.5213634614963 0.3053448518001 0.3028146382562 0.3078750653441
- %egnv 10 1 1 0.86328110E-01 2.0804812 68 49 1e-11 24.100 1.59
- %egnv 10 1 2 0.84184902E-01 2.1219390 69 48 1e-11 25.206 1.61
- %egnv 10 1 3 0.85726953E-01 2.0913289 68 48 1e-11 24.395 1.60
- %tr 10 1 1 1.022055159 0.5521503278E-02 -0.2998286013E-01 0.8873341876E-13 2.027423632 53
+ %Frat 10 105.786 12.327 16.628 35.524 1.000 10.691 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 10 0.7651669E+04 0.4096361E+04 0.3457538E+04 -0.6034924E+04 0.1594950E+04 0.1543888E+04 0.2993857E+04
+ %Hnew 10 0.7651847E+04 0.4112810E+04 0.3453802E+04 -0.6026671E+04 0.1576267E+04 0.1544064E+04 0.2991576E+04
+ %Hdif 10 0.1780956E+00 0.1644972E+02 -0.3736125E+01 0.8253212E+01 -0.1868316E+02 0.1756585E+00 -0.2281204E+01
+ %mc 10 1 1 0.4782963023 0.8368624258 1 203 6038 52 26 1234 54 0.521703697718456
+ %pr 10 0.5217036977185 0.5220436866234 0.5213637088135 0.3053444417748 0.3028137078901 0.3078751756595
+ %egnv 10 1 1 0.86329054E-01 2.0804691 68 49 1e-11 24.099 1.59
+ %egnv 10 1 2 0.84185814E-01 2.1219260 69 48 1e-11 25.205 1.61
+ %egnv 10 1 3 0.85727889E-01 2.0913165 68 48 1e-11 24.395 1.60
+ %tr 10 1 1 1.022055607 0.5523151529E-02 -0.2998225125E-01 0.8880859011E-13 2.027435705 53
T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
- %pl 10 1 1 0.1284477377 0.6387078416E-02
+ %pl 10 1 1 0.1284470852 0.6393035583E-02
>BeginCooling
T%Qc traj e f i_cool Q_cool PlaqEnergy
- %Qc 10 1 1 0 -0.116389 0.4782961713
- %Qc 10 1 1 1 -0.007454 0.0669723197
- %Qc 10 1 1 2 -0.003763 0.0090384656
- %Qc 10 1 1 3 -0.001751 0.0027058642
- %Qc 10 1 1 4 -0.000821 0.0012937578
- %Qc 10 1 1 5 -0.000389 0.0007832207
- %Qc 10 1 1 6 -0.000190 0.0005480911
- %Qc 10 1 1 7 -0.000095 0.0004200246
- %Qc 10 1 1 8 -0.000049 0.0003401863
- %Qc 10 1 1 9 -0.000026 0.0002849915
- %Qc 10 1 1 10 -0.000014 0.0002438627
- %Qc 10 1 1 20 0.000000 0.0000756183
- %Qc 10 1 1 30 0.000000 0.0000302082
- %Qc 10 1 1 40 0.000000 0.0000140579
- %Qc 10 1 1 50 0.000000 0.0000073432
+ %Qc 10 1 1 0 -0.116392 0.4782963023
+ %Qc 10 1 1 1 -0.007457 0.0669725915
+ %Qc 10 1 1 2 -0.003763 0.0090385244
+ %Qc 10 1 1 3 -0.001751 0.0027058910
+ %Qc 10 1 1 4 -0.000821 0.0012937810
+ %Qc 10 1 1 5 -0.000389 0.0007832382
+ %Qc 10 1 1 6 -0.000190 0.0005481038
+ %Qc 10 1 1 7 -0.000095 0.0004200338
+ %Qc 10 1 1 8 -0.000049 0.0003401928
+ %Qc 10 1 1 9 -0.000026 0.0002849962
+ %Qc 10 1 1 10 -0.000014 0.0002438660
+ %Qc 10 1 1 20 0.000000 0.0000756167
+ %Qc 10 1 1 30 0.000000 0.0000302060
+ %Qc 10 1 1 40 0.000000 0.0000140558
+ %Qc 10 1 1 50 0.000000 0.0000073414
>EndCooling
>EndMC
>BeginILDGwrite
ildg-write file bqcd.300.lime
ildg-write precision 64
ildg-write bytes 147456
- ildg-write cksum 3484010393
- ildg-write lfn bqcd-restart bqcd.300.lime 3484010393 147456 300 2 10
+ ildg-write cksum 3360731158
+ ildg-write lfn bqcd-restart bqcd.300.lime 3360731158 147456 300 2 10
>EndILDGwrite
>BeginFooter
- Date 2010-06-11 17:01:50.403
+ Date 2011-09-21 14:42:10.352
Seed -1
- CPU-Time 148.8 s on 1 CPUs
+ CPU-Time 131.3 s on 1 CPUs
>BeginTiming
Performance
region #calls time mean min max Total
s Mflop/s Mflop/s Mflop/s Gflop/s
- d_xf 493370 7.95 2288.18 2288.18 2288.18 2.29
+ d_xf 493290 6.63 2744.03 2744.03 2744.03 2.74
d_xb 0
- d_yf 493370 8.12 2427.55 2427.55 2427.55 2.43
+ d_yf 493290 5.72 3442.21 3442.21 3442.21 3.44
d_yb 0
- d_zf 493370 8.33 2365.75 2365.75 2365.75 2.37
+ d_zf 493290 5.39 3657.54 3657.54 3657.54 3.66
d_zb 0
- d_t 493370 8.06 2445.64 2445.64 2445.64 2.45
+ d_t 493290 5.83 3377.26 3377.26 3377.26 3.38
d_fb 0
d_dag_fb 0
d_xyzt 0
- sc2_projection 493370 6.26 726.30 726.30 726.30 0.73
- D_TOTAL 493370 39.66 2063.72 2063.72 2063.72 2.06
+ sc2_projection 493290 6.64 684.97 684.97 684.97 0.68
+ D_TOTAL 493290 37.89 2159.68 2159.68 2159.68 2.16
d_dd 0
d_eo 0
- MTDAGMT 105760 52.88 1917.10 1917.10 1917.10 1.92
- CG 2040 42.47 1921.47 1921.47 1921.47 1.92
+ MTDAGMT 105740 46.19 2194.25 2194.25 2194.25 2.19
+ CG 2040 37.45 2179.05 2179.05 2179.05 2.18
CG_DD 0
CG_HH 0
cg_global_sum 0
- global_sum 0
- global_sum_vec 0
- sc_zero 39910 0.86
- sc_copy 12140 0.09
- sc_scale 9902 0.02 1520.87 1520.87 1520.87 1.52
- sc_norm2 43082 0.28 958.98 958.98 958.98 0.96
- sc_dot 50034 0.26 1182.28 1182.28 1182.28 1.18
- sc_axpy 329830 1.40 1443.27 1443.27 1443.27 1.44
- sc_xpby 325446 1.13 1772.52 1772.52 1772.52 1.77
- sc_axpby 298576 1.16 2371.98 2371.98 2371.98 2.37
- sc_cdotc 29220 0.15 2425.80 2425.80 2425.80 2.43
- sc_caxpy 1940 0.00 +Inf +Inf +Inf +Inf
- sc_caxpy2 1940 0.03 1702.64 1702.64 1702.64 1.70
- sc_cax2 1980 0.03 1737.87 1737.87 1737.87 1.74
- clover_init 2436 4.59
- clover_mult_a 20 0.00 +Inf +Inf +Inf +Inf
- clover_mult_ao 462970 16.62 1968.09 1968.09 1968.09 1.97
- clover_mult_b 60200 2.36 1799.17 1799.17 1799.17 1.80
- clover_dsd 410 4.45
+ global_sum 102051 0.08
+ global_sum_vec 167038 0.52
+ sc_zero 39914 0.45
+ sc_copy 128450 0.17
+ sc_scale 9902 0.00 10139.65 10139.65 10139.65 10.14
+ sc_norm2 43081 0.04 6458.05 6458.05 6458.05 6.46
+ sc_dot 50033 0.04 8309.75 8309.75 8309.75 8.31
+ sc_axpy 329780 0.28 7315.56 7315.56 7315.56 7.32
+ sc_xpby 325386 0.15 13330.48 13330.48 13330.48 13.33
+ sc_axpby 298527 0.36 7643.74 7643.74 7643.74 7.64
+ sc_cdotc 29220 0.04 8161.65 8161.65 8161.65 8.16
+ sc_caxpy 1940 0.00 5962.66 5962.66 5962.66 5.96
+ sc_caxpy2 1940 0.01 3668.62 3668.62 3668.62 3.67
+ sc_cax2 1980 0.01 5407.32 5407.32 5407.32 5.41
+ clover_init 2436 3.85
+ clover_mult_a 20 0.00 1413.12 1413.12 1413.12 1.41
+ clover_mult_ao 462890 12.37 2643.52 2643.52 2643.52 2.64
+ clover_mult_b 60200 1.96 2172.69 2172.69 2172.69 2.17
+ clover_dsd 410 4.04
clover_dsf 0
hmc_init 10 0.03
- hmc_init_p 10 0.02
- hmc_u 6400 6.40
+ hmc_init_p 10 0.01
+ hmc_u 6400 5.95
hmc_momenta 0
- hmc_phi 10 1.70
- hmc_h_old 10 1.73
+ hmc_phi 10 1.35
+ hmc_h_old 10 1.38
hmc_backup 10 0.00
hmc_half_step0 0
hmc_half_step1 0
- hmc_xbound_g 10552 0.00
- hmc_steps 8540 135.73
- hmc_h_new 10 0.02
+ hmc_xbound_g 10552 0.01
+ hmc_steps 8540 119.79
+ hmc_h_new 10 0.01
hmc_rest 10 0.00
- HMC 10 143.93
+ HMC 10 127.19
h_mult_a 0
h_mult_b 0
h_mult_c 0
- dsg 6410 8.40
- dsf 2020 33.80
- plaquette 22 0.02 914.50 914.50 914.50 0.91
- cooling 10 1.41
- ran_gauss_volh 140 0.06
+ dsg 6410 6.73
+ dsf 2020 29.74
+ plaquette 22 0.01 2090.58 2090.58 2090.58 2.09
+ cooling 10 1.15
+ ran_gauss_volh 140 0.03
MTDAGMT_r4 0
- dsig 1610 10.50
- rectangle 21 0.03 1867.26 1867.26 1867.26 1.87
+ dsig 1610 9.10
+ rectangle 21 0.02 2273.94 2273.94 2273.94 2.27
chair 0
parallelogram 0
- stout_smear 1612 4.08 1549.85 1549.85 1549.85 1.55
- stout_diffe 2540 12.68 2317.33 2317.33 2317.33 2.32
- clover_bsa_w 20260 2.53 1883.30 1883.30 1883.30 1.88
- clover_dsd_w 1640 1.46 1166.54 1166.54 1166.54 1.17
- clover_d_w 5900 13.90 2172.26 2172.26 2172.26 2.17
- dsf_at_bt 10130 3.28 1461.00 1461.00 1461.00 1.46
- dsf_xyztfb_w 10130 4.43 2333.09 2333.09 2333.09 2.33
- dsf_sum 10130 13.34 1490.11 1490.11 1490.11 1.49
- dsf_w2gen 2540 26.41 2120.58 2120.58 2120.58 2.12
- cgm 260 10.92 1815.99 1815.99 1815.99 1.82
- cg_ritz 82 4.15 1855.29 1855.29 1855.29 1.86
+ stout_smear 1612 3.13 2021.97 2021.97 2021.97 2.02
+ stout_diffe 2540 10.62 2765.87 2765.87 2765.87 2.77
+ clover_bsa_w 20260 3.03 1572.15 1572.15 1572.15 1.57
+ clover_dsd_w 1640 1.27 1346.06 1346.06 1346.06 1.35
+ clover_d_w 5900 13.11 2303.44 2303.44 2303.44 2.30
+ dsf_at_bt 10130 2.65 1805.33 1805.33 1805.33 1.81
+ dsf_xyztfb_w 10130 5.17 1997.52 1997.52 1997.52 2.00
+ dsf_sum 10130 14.12 1408.22 1408.22 1408.22 1.41
+ dsf_w2gen 2540 23.67 2365.99 2365.99 2365.99 2.37
+ cgm 260 9.53 2081.45 2081.45 2081.45 2.08
+ cg_ritz 82 3.55 2171.59 2171.59 2171.59 2.17
cg_mix 0
bicgstab 0
bicgstab_mix 0
@@ -857,13 +854,13 @@
unprec_mmul 0
unprec_dsf 0
dsf_un 0
- dsf_mtmp 2020 88.52
- cg_mre_mtmp 2020 44.83
- dsf_wmul_r8 2020 0.48
- dsf_wdag_r8 410 0.18
- integrator 10 142.14
+ dsf_mtmp 2020 76.35
+ cg_mre_mtmp 2020 39.43
+ dsf_wmul_r8 2020 0.43
+ dsf_wdag_r8 410 0.10
+ integrator 10 125.77
bagel_d 0
- TOTAL 1 148.77
+ TOTAL 1 131.32
Performance
region #calls time mean min max Total
@@ -874,8 +871,8 @@
xbound_sc2 0
u_read_bqcd 0
u_write_bqcd 0
- u_read_ildg 1 0.00 36.86 36.86 36.86 0.04
- u_write_ildg 1 0.00 +Inf +Inf +Inf +Inf
+ u_read_ildg 1 0.00 49.15 49.15 49.15 0.05
+ u_write_ildg 1 0.00 147.46 147.46 147.46 0.15
>EndTiming
>EndFooter
>EndJob
diff --git a/src/data/bqcd.300.output.r259 b/src/data/bqcd.300.output.r259
new file mode 100644
index 0000000000000000000000000000000000000000..a1d40fa08da6d169984dd8c216b79af77ad06af9
--- /dev/null
+++ b/src/data/bqcd.300.output.r259
@@ -0,0 +1,881 @@
+ >BeginJob
+ >BeginHeader
+ Program bqcd 4.0.0 (revision 259)
+ Version_of_D 100
+ Communication single_pe
+ RandomNumbers ranlux-3.2 level 2
+ Run 300
+ Job 1
+ Host pc58588
+ Date 2010-06-11 16:56:02.444
+ L 4 4 4 4
+ DDL 1 1 1 1
+ NPE 1 1 1 1
+ process_mapping 1 2 3 4
+ bc_fermions 1 1 1 -1
+ gamma_index 1 2 3 4
+ Gauge Action TREE
+ Fermi Action SLRC
+ tilde M 1 - T^-1 D T^-1 D
+ Gamma notation BQCD
+ eo-prec DeoDoe
+ BoundaryCondition normal
+ Threads 1
+ Start 0
+ Seed 319503
+ Swap_seq 0
+ N_force 10
+ N_traj 10
+ N_save 0
+ N_temper 1
+ beta_1 5.5
+ c0_1 0.0
+ c1_1 0.0
+ c2_1 0.0
+ c3_1 0.0
+ u04_1 0.0
+ kappa_1 0.121095
+ kappa_strange_1 0.120512
+ csw_1 2.65
+ csw_kappa_1 0.320901750000000
+ csw_kappa_strange_1 0.319356800000000
+ n_stout_1 1
+ alpha_1 0.1
+ theta_1 0.0
+ h_1 0.0
+ rho_1 0.1203
+ rho2_1 0.0
+ rho3_1 0.0
+ rho4_1 0.0
+ traj_length_1 1.0
+ tau_1 0.200000000000000
+ N_tau_1 5 2MNSTS ers
+ m_scale_1 2 2MNSTS eo2 dat
+ m_scale2_1 2 2MNSTS eo1 ig
+ m_scale3_1 2 2MNSTS g
+ hkappa 1
+ mpf_eo[m,l,s]: 2 0 2
+ mpf_dd[m,l,s]: 0 0 0
+ mpf_hh[m,l,s]: 0 0 0
+ fraction_u1 40
+ fraction_u2 0
+ roughness_level 0
+ HMC_model F
+ REAL_kind 8
+ Solver_outer cg
+ Solver_inner cg
+ CG_rest 1e-11
+ CG_rest_md 1e-9
+ CG_stopping_criterion 1
+ CG_outer_steps 0
+ MRE_vectors 5
+ Fullsolver eo
+ >EndHeader
+ >BeginForceAcceptance
+ T%fa i_fa e PlaqEnergy exp(-Delta_H) CGcalls CGitTot CGitMax CGMcalls CGMitTotCGMitMax Plaquette
+ T%it traj iter_SF iter_F1 iter_F2 iter_F3 iter_F4 iter_F5 iter_F6 iter_F7 iter_F8 iter_F9
+ %it -9 260 4665 1469 1042 0 0 0 0 0 0
+ %it4 -9 0 0 0 0 0 0 0 0 0 0
+ T%Favg traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
+ T%Fmax traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
+ T%Frat traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
+ %Favg -9 7.822 0.666 1.340 2.775 0.067 0.823 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -9 14.008 1.247 2.702 7.549 0.193 1.961 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -9 72.626 6.464 14.006 39.139 1.000 10.165 0.000 0.000 0.000 0.000 0.000 0.000
+ T%Hold traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
+ T%Hnew traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
+ T%Hdif traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
+ %Hold -9 0.1175206E+05 0.4065964E+04 0.7585522E+04 -0.6000883E+04 0.1567305E+04 0.1517629E+04 0.3016521E+04
+ %Hnew -9 0.1175243E+05 0.5957390E+04 0.5626949E+04 -0.5967133E+04 0.1595594E+04 0.1515925E+04 0.3023703E+04
+ %Hdif -9 0.3697911E+00 0.1891426E+04 -0.1958573E+04 0.3375016E+02 0.2828917E+02 -0.1704640E+01 0.7182088E+01
+ %fa -9 1 0.7596780818 0.6908786269 203 6179 48 26 1257 61 0.240321918219764
+ T%egnv traj type mid min max it_min it_max tol condi n_opt
+ %egnv -9 1 1 0.80547445E-01 2.2603050 73 41 1e-11 28.062 1.67
+ %egnv -9 1 2 0.74060643E-01 2.3117457 74 39 1e-11 31.214 1.72
+ %egnv -9 1 3 0.78792963E-01 2.2737198 73 41 1e-11 28.857 1.68
+ %it -8 309 5274 1650 1179 0 0 0 0 0 0
+ %it4 -8 0 0 0 0 0 0 0 0 0 0
+ %Favg -8 8.173 0.726 1.348 2.465 0.067 0.809 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -8 14.511 1.353 2.755 6.638 0.189 1.925 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -8 76.618 7.144 14.547 35.048 1.000 10.166 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -8 0.9777570E+04 0.4030068E+04 0.5626949E+04 -0.5967133E+04 0.1485841E+04 0.1560926E+04 0.3040919E+04
+ %Hnew -8 0.9778114E+04 0.4628898E+04 0.5029892E+04 -0.5984421E+04 0.1505593E+04 0.1560220E+04 0.3037933E+04
+ %Hdif -8 0.5445722E+00 0.5988301E+03 -0.5970570E+03 -0.1728829E+02 0.1975166E+02 -0.7061834E+00 -0.2985696E+01
+ %fa -8 1 0.6837585510 0.5800898725 203 6982 58 26 1430 65 0.316241448982582
+ %egnv -8 1 1 0.71967912E-01 2.1601388 172 64 1e-11 30.015 1.70
+ %egnv -8 1 2 0.65996267E-01 2.2033538 176 62 1e-11 33.386 1.75
+ %egnv -8 1 3 0.70350902E-01 2.1714299 173 63 1e-11 30.866 1.71
+ %it -7 367 6315 1972 1416 0 0 0 0 0 0
+ %it4 -7 0 0 0 0 0 0 0 0 0 0
+ %Favg -7 8.463 0.775 1.341 2.442 0.071 0.862 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -7 15.009 1.430 2.738 6.868 0.236 2.102 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -7 63.708 6.071 11.622 29.153 1.000 8.920 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -7 0.9293270E+04 0.4094299E+04 0.5029892E+04 -0.5984421E+04 0.1512332E+04 0.1487833E+04 0.3153335E+04
+ %Hnew -7 0.9292577E+04 0.4531932E+04 0.4556032E+04 -0.5956843E+04 0.1510334E+04 0.1488096E+04 0.3163026E+04
+ %Hdif -7 -0.6925139E+00 0.4376328E+03 -0.4738597E+03 0.2757784E+02 -0.1997839E+01 0.2632195E+00 0.9691159E+01
+ %fa -7 1 0.6247996765 1.9987337431 203 8348 72 26 1722 88 0.375200323526387
+ %egnv -7 1 1 0.35981194E-01 2.4918009 109 27 1e-11 69.253 2.12
+ %egnv -7 1 2 0.31457047E-01 2.5556502 113 27 1e-11 81.243 2.20
+ %egnv -7 1 3 0.34743068E-01 2.5084717 110 27 1e-11 72.201 2.14
+ %it -6 415 6439 1996 1435 0 0 0 0 0 0
+ %it4 -6 0 0 0 0 0 0 0 0 0 0
+ %Favg -6 8.588 0.801 1.341 2.583 0.073 0.848 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -6 15.164 1.485 2.883 6.699 0.201 2.233 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -6 75.365 7.378 14.327 33.291 1.000 11.097 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -6 0.8871121E+04 0.4101907E+04 0.4556032E+04 -0.5956843E+04 0.1567070E+04 0.1524604E+04 0.3078351E+04
+ %Hnew -6 0.8870834E+04 0.4182358E+04 0.4478885E+04 -0.5981559E+04 0.1590364E+04 0.1524322E+04 0.3076463E+04
+ %Hdif -6 -0.2872979E+00 0.8045069E+02 -0.7714721E+02 -0.2471533E+02 0.2329443E+02 -0.2821219E+00 -0.1887758E+01
+ %fa -6 1 0.6141827704 1.3328212627 203 8518 83 26 1767 89 0.385817229617386
+ %egnv -6 1 1 0.44963111E-01 2.2734221 88 50 1e-11 50.562 1.96
+ %egnv -6 1 2 0.39975905E-01 2.3294476 90 48 1e-11 58.271 2.03
+ %egnv -6 1 3 0.43602824E-01 2.2880091 89 50 1e-11 52.474 1.98
+ %it -5 408 6831 2127 1499 0 0 0 0 0 0
+ %it4 -5 0 0 0 0 0 0 0 0 0 0
+ %Favg -5 8.537 0.810 1.325 2.374 0.073 0.792 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -5 15.199 1.518 2.779 5.839 0.240 1.881 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -5 63.304 6.323 11.576 24.320 1.000 7.834 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -5 0.8651157E+04 0.4089832E+04 0.4478885E+04 -0.5981559E+04 0.1533584E+04 0.1538412E+04 0.2992002E+04
+ %Hnew -5 0.8651211E+04 0.4106159E+04 0.4427728E+04 -0.5966972E+04 0.1552947E+04 0.1538339E+04 0.2993011E+04
+ %Hdif -5 0.5466773E-01 0.1632681E+02 -0.5115719E+02 0.1458633E+02 0.1936275E+02 -0.7251007E-01 0.1008478E+01
+ %fa -5 1 0.6078148517 0.9467996885 203 9032 74 26 1833 89 0.392185148346159
+ %egnv -5 1 1 0.22021276E-01 2.4372806 104 107 1e-11 110.678 2.35
+ %egnv -5 1 2 0.18136345E-01 2.5058991 109 102 1e-11 138.170 2.46
+ %egnv -5 1 3 0.20945916E-01 2.4551219 105 104 1e-11 117.212 2.38
+ %it -4 430 6845 2158 1507 0 0 0 0 0 0
+ %it4 -4 0 0 0 0 0 0 0 0 0 0
+ %Favg -4 8.590 0.817 1.341 2.382 0.075 0.815 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -4 15.030 1.533 2.840 6.062 0.241 1.996 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -4 62.306 6.354 11.771 25.130 1.000 8.273 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -4 0.8583368E+04 0.4091101E+04 0.4427728E+04 -0.5966972E+04 0.1500592E+04 0.1498237E+04 0.3032683E+04
+ %Hnew -4 0.8583295E+04 0.4195410E+04 0.4340990E+04 -0.5972497E+04 0.1494524E+04 0.1498127E+04 0.3026742E+04
+ %Hdif -4 -0.7338697E-01 0.1043087E+03 -0.8673771E+02 -0.5524790E+01 -0.6068144E+01 -0.1098792E+00 -0.5941606E+01
+ %fa -4 1 0.5963913539 1.0761468895 203 9087 84 26 1853 89 0.403608646128713
+ %egnv -4 1 1 0.30188146E-01 2.1647039 72 43 1e-11 71.707 2.14
+ %egnv -4 1 2 0.25911790E-01 2.2091304 74 42 1e-11 85.256 2.22
+ %egnv -4 1 3 0.29014812E-01 2.1763156 73 43 1e-11 75.007 2.16
+ %it -3 405 6806 2123 1496 0 0 0 0 0 0
+ %it4 -3 0 0 0 0 0 0 0 0 0 0
+ %Favg -3 8.812 0.851 1.322 2.317 0.076 0.815 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -3 15.659 1.548 2.832 6.624 0.240 2.042 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -3 65.194 6.446 11.792 27.579 1.000 8.503 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -3 0.8614961E+04 0.4145810E+04 0.4340990E+04 -0.5972497E+04 0.1528241E+04 0.1522367E+04 0.3050051E+04
+ %Hnew -3 0.8614829E+04 0.4253580E+04 0.4279266E+04 -0.5991784E+04 0.1500857E+04 0.1521232E+04 0.3051678E+04
+ %Hdif -3 -0.1322210E+00 0.1077699E+03 -0.6172370E+02 -0.1928727E+02 -0.2738316E+02 -0.1135419E+01 0.1627457E+01
+ %fa -3 1 0.5874912538 1.1413604914 203 9010 81 26 1820 85 0.412508746190435
+ %egnv -3 1 1 0.43832510E-01 2.0903463 114 69 1e-11 47.689 1.93
+ %egnv -3 1 2 0.39086798E-01 2.1258883 115 68 1e-11 54.389 2.00
+ %egnv -3 1 3 0.42539420E-01 2.0996774 114 68 1e-11 49.358 1.95
+ %it -2 396 7076 2167 1526 0 0 0 0 0 0
+ %it4 -2 0 0 0 0 0 0 0 0 0 0
+ %Favg -2 8.913 0.864 1.305 2.441 0.078 0.774 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -2 15.503 1.622 2.583 6.663 0.219 1.881 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -2 70.650 7.390 11.770 30.364 1.000 8.574 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -2 0.8505403E+04 0.4191183E+04 0.4279266E+04 -0.5991784E+04 0.1438738E+04 0.1538052E+04 0.3049948E+04
+ %Hnew -2 0.8505738E+04 0.4375280E+04 0.4115031E+04 -0.5998951E+04 0.1429808E+04 0.1538295E+04 0.3046276E+04
+ %Hdif -2 0.3356661E+00 0.1840966E+03 -0.1642358E+03 -0.7166638E+01 -0.8930498E+01 0.2437761E+00 -0.3671725E+01
+ %fa -2 1 0.5665928637 0.7148617392 203 9316 73 26 1849 83 0.433407136283996
+ %egnv -2 1 1 0.36920645E-01 2.2540469 93 63 1e-11 61.051 2.06
+ %egnv -2 1 2 0.32990186E-01 2.3051667 96 61 1e-11 69.874 2.12
+ %egnv -2 1 3 0.35843876E-01 2.2674050 93 62 1e-11 63.258 2.07
+ %it -1 442 8015 2455 1689 0 0 0 0 0 0
+ %it4 -1 0 0 0 0 0 0 0 0 0 0
+ %Favg -1 8.930 0.880 1.321 2.692 0.078 0.817 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -1 15.259 1.577 2.784 7.084 0.243 1.970 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -1 62.866 6.495 11.468 29.186 1.000 8.115 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -1 0.8457890E+04 0.4133751E+04 0.4115031E+04 -0.5998951E+04 0.1543906E+04 0.1550057E+04 0.3114096E+04
+ %Hnew -1 0.8458024E+04 0.4133266E+04 0.4063189E+04 -0.5982004E+04 0.1572060E+04 0.1549422E+04 0.3122091E+04
+ %Hdif -1 0.1340929E+00 -0.4850769E+00 -0.5184203E+02 0.1694690E+02 0.2815357E+02 -0.6347644E+00 0.7995497E+01
+ %fa -1 1 0.5600325226 0.8745088056 203 10549 84 26 2052 99 0.439967477374255
+ %egnv -1 1 1 0.20043751E-01 2.6191537 175 22 1e-11 130.672 2.44
+ %egnv -1 1 2 0.16816987E-01 2.7011716 181 21 1e-11 160.622 2.54
+ %egnv -1 1 3 0.19150390E-01 2.6404756 176 22 1e-11 137.881 2.46
+ %it 0 479 8213 2551 1736 0 0 0 0 0 0
+ %it4 0 0 0 0 0 0 0 0 0 0 0
+ %Favg 0 8.948 0.890 1.310 2.576 0.079 0.785 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 0 14.994 1.600 2.652 7.318 0.257 1.987 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 0 58.398 6.233 10.329 28.504 1.000 7.738 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 0 0.8333887E+04 0.4060687E+04 0.4063189E+04 -0.5982004E+04 0.1622086E+04 0.1520595E+04 0.3049334E+04
+ %Hnew 0 0.8334043E+04 0.4222562E+04 0.3927864E+04 -0.5981657E+04 0.1589964E+04 0.1519281E+04 0.3056029E+04
+ %Hdif 0 0.1560966E+00 0.1618753E+03 -0.1353246E+03 0.3474536E+00 -0.3212248E+02 -0.1314227E+01 0.6694721E+01
+ %fa 0 1 0.5423191696 0.8554765110 203 10858 94 26 2121 100 0.457680830362908
+ %egnv 0 1 1 0.21786046E-01 2.0954561 183 71 1e-11 96.183 2.28
+ %egnv 0 1 2 0.18395558E-01 2.1338142 187 70 1e-11 115.996 2.38
+ %egnv 0 1 3 0.20849283E-01 2.1055060 184 71 1e-11 100.987 2.31
+ >EndForceAcceptance
+ >BeginILDGwrite
+ ildg-write file bqcd.300.lime
+ ildg-write precision 64
+ ildg-write bytes 147456
+ ildg-write cksum 886460001
+ ildg-write lfn bqcd-restart bqcd.300.lime 886460001 147456 300 1 0
+ >EndILDGwrite
+ >BeginFooter
+ Date 2010-06-11 16:58:33.680
+ Seed -1
+ CPU-Time 151.2 s on 1 CPUs
+ >BeginTiming
+ Performance
+ region #calls time mean min max Total
+ s Mflop/s Mflop/s Mflop/s Gflop/s
+
+ d_xf 529058 8.59 2269.78 2269.78 2269.78 2.27
+ d_xb 0
+ d_yf 529058 8.40 2515.14 2515.14 2515.14 2.52
+ d_yb 0
+ d_zf 529058 8.76 2411.77 2411.77 2411.77 2.41
+ d_zb 0
+ d_t 529058 8.97 2354.78 2354.78 2354.78 2.35
+ d_fb 0
+ d_dag_fb 0
+ d_xyzt 0
+ sc2_projection 529058 6.93 703.74 703.74 703.74 0.70
+ D_TOTAL 529058 42.83 2049.29 2049.29 2049.29 2.05
+ d_dd 0
+ d_eo 0
+ MTDAGMT 114697 57.08 1926.09 1926.09 1926.09 1.93
+ CG 2030 46.49 1912.32 1912.32 1912.32 1.91
+ CG_DD 0
+ CG_HH 0
+ cg_global_sum 0
+ global_sum 0
+ global_sum_vec 0
+ sc_zero 39896 0.83
+ sc_copy 12140 0.10
+ sc_scale 9902 0.03 950.53 950.53 950.53 0.95
+ sc_norm2 44608 0.21 1292.72 1292.72 1292.72 1.29
+ sc_dot 51190 0.21 1511.96 1511.96 1511.96 1.51
+ sc_axpy 360804 1.64 1354.93 1354.93 1354.93 1.35
+ sc_xpby 352627 1.27 1703.16 1703.16 1703.16 1.70
+ sc_axpby 326804 1.23 2444.50 2444.50 2444.50 2.44
+ sc_cdotc 29180 0.17 2134.17 2134.17 2134.17 2.13
+ sc_caxpy 1940 0.01 2979.47 2979.47 2979.47 2.98
+ sc_caxpy2 1940 0.02 2979.47 2979.47 2979.47 2.98
+ sc_cax2 1980 0.01 4055.04 4055.04 4055.04 4.06
+ clover_init 2403 4.43
+ clover_mult_a 0
+ clover_mult_ao 498668 18.03 1954.71 1954.71 1954.71 1.95
+ clover_mult_b 60200 2.53 1679.79 1679.79 1679.79 1.68
+ clover_dsd 410 4.16
+ clover_dsf 0
+ hmc_init 10 0.03
+ hmc_init_p 10 0.03
+ hmc_u 6400 6.58
+ hmc_momenta 0
+ hmc_phi 10 1.62
+ hmc_h_old 10 1.68
+ hmc_backup 10 0.00
+ hmc_half_step0 0
+ hmc_half_step1 0
+ hmc_xbound_g 10541 0.01
+ hmc_steps 8540 140.02
+ hmc_h_new 10 0.01
+ hmc_rest 10 0.00
+ HMC 10 148.35
+ h_mult_a 0
+ h_mult_b 0
+ h_mult_c 0
+ dsg 6410 8.32
+ dsf 2020 33.43
+ plaquette 21 0.00 +Inf +Inf +Inf +Inf
+ cooling 0
+ ran_gauss_volh 128 0.06
+ MTDAGMT_r4 0
+ dsig 1610 10.17
+ rectangle 20 0.03 1778.41 1778.41 1778.41 1.78
+ chair 0
+ parallelogram 0
+ stout_smear 1601 4.06 1548.38 1548.38 1548.38 1.55
+ stout_diffe 2540 12.68 2316.61 2316.61 2316.61 2.32
+ clover_bsa_w 20260 2.37 2010.52 2010.52 2010.52 2.01
+ clover_dsd_w 1640 1.50 1141.57 1141.57 1141.57 1.14
+ clover_d_w 5900 13.74 2198.19 2198.19 2198.19 2.20
+ dsf_at_bt 10130 3.25 1473.58 1473.58 1473.58 1.47
+ dsf_xyztfb_w 10130 4.56 2263.58 2263.58 2263.58 2.26
+ dsf_sum 10130 13.14 1512.78 1512.78 1512.78 1.51
+ dsf_w2gen 2540 26.73 2095.20 2095.20 2095.20 2.10
+ cgm 260 12.06 1839.82 1839.82 1839.82 1.84
+ cg_ritz 82 3.93 1859.83 1859.83 1859.83 1.86
+ cg_mix 0
+ bicgstab 0
+ bicgstab_mix 0
+ ddbqnohat 0
+ unprec_mmul 0
+ unprec_dsf 0
+ dsf_un 0
+ dsf_mtmp 2020 92.45
+ cg_mre_mtmp 2020 49.18
+ dsf_wmul_r8 2020 0.52
+ dsf_wdag_r8 410 0.15
+ integrator 10 146.62
+ bagel_d 0
+ TOTAL 1 151.23
+
+ Performance
+ region #calls time mean min max Total
+ s MByte/s MByte/s MByte/s GByte/s
+
+ xbound_g 0
+ xbound_sc 0
+ xbound_sc2 0
+ u_read_bqcd 0
+ u_write_bqcd 0
+ u_read_ildg 0
+ u_write_ildg 1 0.00 +Inf +Inf +Inf +Inf
+ >EndTiming
+ >EndFooter
+ >EndJob
+ >BeginJob
+ >BeginHeader
+ Program bqcd 4.0.0 (revision 259)
+ Version_of_D 100
+ Communication single_pe
+ RandomNumbers ranlux-3.2 level 2
+ Run 300
+ Job 2
+ Host pc58588
+ Date 2010-06-11 16:59:21.622
+ L 4 4 4 4
+ DDL 1 1 1 1
+ NPE 1 1 1 1
+ process_mapping 1 2 3 4
+ bc_fermions 1 1 1 -1
+ gamma_index 1 2 3 4
+ Gauge Action TREE
+ Fermi Action SLRC
+ tilde M 1 - T^-1 D T^-1 D
+ Gamma notation BQCD
+ eo-prec DeoDoe
+ BoundaryCondition normal
+ Threads 1
+ Start 2
+ Seed -1
+ Swap_seq 0
+ N_force 10
+ N_traj 10
+ N_save 0
+ N_temper 1
+ beta_1 5.5
+ c0_1 0.0
+ c1_1 0.0
+ c2_1 0.0
+ c3_1 0.0
+ u04_1 0.0
+ kappa_1 0.121095
+ kappa_strange_1 0.120512
+ csw_1 2.65
+ csw_kappa_1 0.320901750000000
+ csw_kappa_strange_1 0.319356800000000
+ n_stout_1 1
+ alpha_1 0.1
+ theta_1 0.0
+ h_1 0.0
+ rho_1 0.1203
+ rho2_1 0.0
+ rho3_1 0.0
+ rho4_1 0.0
+ traj_length_1 1.0
+ tau_1 0.200000000000000
+ N_tau_1 5 2MNSTS ers
+ m_scale_1 2 2MNSTS eo2 dat
+ m_scale2_1 2 2MNSTS eo1 ig
+ m_scale3_1 2 2MNSTS g
+ hkappa 1
+ mpf_eo[m,l,s]: 2 0 2
+ mpf_dd[m,l,s]: 0 0 0
+ mpf_hh[m,l,s]: 0 0 0
+ fraction_u1 40
+ fraction_u2 0
+ roughness_level 0
+ HMC_model F
+ REAL_kind 8
+ Solver_outer cg
+ Solver_inner cg
+ CG_rest 1e-11
+ CG_rest_md 1e-9
+ CG_stopping_criterion 1
+ CG_outer_steps 0
+ MRE_vectors 5
+ Fullsolver eo
+ >EndHeader
+ >BeginILDGread
+ ildg-read file bqcd.300.lime
+ ildg-read precision 64
+ ildg-read bytes 147456
+ ildg-read cksum 886460001
+ ildg-read lfn bqcd-restart bqcd.300.lime 886460001 147456 300 1 0
+ >EndILDGread
+ >BeginMC
+ T%mc traj e f PlaqEnergy exp(-Delta_H) Acc CGcalls CGitTot CGitMax CGMcalls CGMitTotCGMitMax Plaquette
+ T%pr traj Plaquette PlaquetteS PlaquetteT Rectangle RectangleS RectangleT
+ T%it traj iter_SF iter_F1 iter_F2 iter_F3 iter_F4 iter_F5 iter_F6 iter_F7 iter_F8 iter_F9
+ %it 1 466 9160 2766 1827 0 0 0 0 0 0
+ %it4 1 0 0 0 0 0 0 0 0 0 0
+ T%Favg traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
+ T%Fmax traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
+ T%Frat traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
+ %Favg 1 9.045 0.914 1.310 2.609 0.074 0.780 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 1 15.598 1.700 2.656 7.611 0.211 1.853 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 1 73.953 8.060 12.594 36.086 1.000 8.788 0.000 0.000 0.000 0.000 0.000 0.000
+ T%Hold traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
+ T%Hnew traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
+ T%Hdif traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
+ %Hold 1 0.8059372E+04 0.3981543E+04 0.3927864E+04 -0.5981657E+04 0.1572569E+04 0.1491144E+04 0.3067908E+04
+ %Hnew 1 0.8059149E+04 0.4134470E+04 0.3802579E+04 -0.5991136E+04 0.1561179E+04 0.1491647E+04 0.3060409E+04
+ %Hdif 1 -0.2222102E+00 0.1529275E+03 -0.1252850E+03 -0.9479002E+01 -0.1138985E+02 0.5033574E+00 -0.7499230E+01
+ %mc 1 1 1 0.5256287819 1.2488337936 1 203 12014 88 26 2205 96 0.474371218105791
+ %pr 1 0.4743712181058 0.4726444579752 0.4760979782364 0.2448709195136 0.2412306449670 0.2485111940602
+ T%egnv traj type mid min max it_min it_max tol condi n_opt
+ %egnv 1 1 1 0.11201689E-01 2.1239394 92 55 1e-11 189.609 2.62
+ %egnv 1 1 2 0.88566368E-02 2.1649865 94 54 1e-11 244.448 2.75
+ %egnv 1 1 3 0.10542698E-01 2.1346871 92 55 1e-11 202.480 2.66
+ T%tr traj e f Re(pbp) Im(pbp) Re(p5p) -Im(p5p) PionNorm CGiter
+ %tr 1 1 1 1.096700490 -0.1407549329E-01 0.2229626393E-01 -0.7190087646E-12 2.751909090 98
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 1 1 1 -0.2789723339E-01 0.5139161873E-01
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 1 1 1 0 0.048126 0.5256287819
+ %Qc 1 1 1 1 0.020771 0.1313428205
+ %Qc 1 1 1 2 0.182281 0.0511502439
+ %Qc 1 1 1 3 0.219577 0.0309807565
+ %Qc 1 1 1 4 0.142080 0.0218651570
+ %Qc 1 1 1 5 0.052773 0.0161620071
+ %Qc 1 1 1 6 0.009561 0.0114304799
+ %Qc 1 1 1 7 0.002320 0.0075411392
+ %Qc 1 1 1 8 0.001251 0.0046428300
+ %Qc 1 1 1 9 0.000558 0.0026599216
+ %Qc 1 1 1 10 0.000203 0.0014373723
+ %Qc 1 1 1 20 0.000000 0.0000057767
+ %Qc 1 1 1 30 -0.000000 0.0000001381
+ %Qc 1 1 1 40 0.000000 0.0000000048
+ %Qc 1 1 1 50 0.000000 0.0000000002
+ >EndCooling
+ %it 2 455 7725 2355 1642 0 0 0 0 0 0
+ %it4 2 0 0 0 0 0 0 0 0 0 0
+ %Favg 2 9.177 0.940 1.294 2.393 0.063 0.763 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 2 15.786 1.705 2.628 6.960 0.203 2.201 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 2 77.904 8.415 12.971 34.348 1.000 10.863 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 2 0.8090140E+04 0.4136443E+04 0.3802579E+04 -0.5991136E+04 0.1557003E+04 0.1537098E+04 0.3048153E+04
+ %Hnew 2 0.8089947E+04 0.4104749E+04 0.3861978E+04 -0.5997383E+04 0.1531613E+04 0.1537314E+04 0.3051676E+04
+ %Hdif 2 -0.1930398E+00 -0.3169372E+02 0.5939898E+02 -0.6247830E+01 -0.2538992E+02 0.2159010E+00 0.3523546E+01
+ %mc 2 1 1 0.5329972801 1.2129310686 1 203 10172 92 26 2005 98 0.467002719935582
+ %pr 2 0.4670027199356 0.4683780993849 0.4656273404862 0.2414972288243 0.2417406808935 0.2412537767551
+ %egnv 2 1 1 0.22479273E-01 2.2750864 88 38 1e-11 101.208 2.31
+ %egnv 2 1 2 0.19130153E-01 2.3261450 89 37 1e-11 121.596 2.40
+ %egnv 2 1 3 0.21554334E-01 2.2884333 88 38 1e-11 106.170 2.33
+ %tr 2 1 1 1.057820167 -0.6021855563E-02 0.1866932235E-01 0.2982776063E-12 2.375531424 83
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 2 1 1 -0.1273482066E-01 -0.2853310257E-02
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 2 1 1 0 -0.009762 0.5329972801
+ %Qc 2 1 1 1 -0.005589 0.1193819388
+ %Qc 2 1 1 2 0.280278 0.0339020463
+ %Qc 2 1 1 3 0.458564 0.0186745744
+ %Qc 2 1 1 4 0.515329 0.0133907635
+ %Qc 2 1 1 5 0.494449 0.0106876369
+ %Qc 2 1 1 6 0.412660 0.0089590302
+ %Qc 2 1 1 7 0.243721 0.0071402566
+ %Qc 2 1 1 8 0.051628 0.0041254140
+ %Qc 2 1 1 9 0.004785 0.0017870795
+ %Qc 2 1 1 10 0.000654 0.0008693693
+ %Qc 2 1 1 20 -0.000000 0.0000149504
+ %Qc 2 1 1 30 -0.000000 0.0000007825
+ %Qc 2 1 1 40 -0.000000 0.0000000488
+ %Qc 2 1 1 50 -0.000000 0.0000000034
+ >EndCooling
+ %it 3 402 7600 2291 1560 0 0 0 0 0 0
+ %it4 3 0 0 0 0 0 0 0 0 0 0
+ %Favg 3 9.316 0.968 1.278 2.307 0.059 0.758 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 3 15.815 1.684 2.594 6.295 0.182 1.919 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 3 86.712 9.230 14.222 34.514 1.000 10.520 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 3 0.8167467E+04 0.4128298E+04 0.3861978E+04 -0.5997383E+04 0.1564709E+04 0.1498362E+04 0.3111503E+04
+ %Hnew 3 0.8167623E+04 0.4163487E+04 0.3834727E+04 -0.6003886E+04 0.1563891E+04 0.1498577E+04 0.3110827E+04
+ %Hdif 3 0.1561674E+00 0.3518970E+02 -0.2725048E+02 -0.6502840E+01 -0.8185873E+00 0.2147341E+00 -0.6763635E+00
+ %mc 3 1 1 0.5292769819 0.8554159753 1 203 9971 80 26 1882 84 0.470723018098662
+ %pr 3 0.4707230180987 0.4681862080567 0.4732598281407 0.2464434901217 0.2415090083184 0.2513779719250
+ %egnv 3 1 1 0.30015044E-01 2.1062975 104 54 1e-11 70.175 2.13
+ %egnv 3 1 2 0.26192101E-01 2.1456848 105 54 1e-11 81.921 2.20
+ %egnv 3 1 3 0.28967864E-01 2.1166148 105 54 1e-11 73.068 2.15
+ %tr 3 1 1 1.021762823 -0.2042151733E-01 -0.4749031798E-01 0.4647902433E-14 2.277549541 77
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 3 1 1 0.1773357402E-02 -0.6020302397E-02
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 3 1 1 0 0.082096 0.5292769819
+ %Qc 3 1 1 1 0.130736 0.1094908249
+ %Qc 3 1 1 2 0.348311 0.0290075332
+ %Qc 3 1 1 3 0.482537 0.0148645258
+ %Qc 3 1 1 4 0.532008 0.0109541619
+ %Qc 3 1 1 5 0.531717 0.0093610450
+ %Qc 3 1 1 6 0.496172 0.0084716148
+ %Qc 3 1 1 7 0.418683 0.0077233870
+ %Qc 3 1 1 8 0.256949 0.0064885255
+ %Qc 3 1 1 9 0.051149 0.0036024180
+ %Qc 3 1 1 10 0.004666 0.0014501003
+ %Qc 3 1 1 20 -0.000001 0.0000733980
+ %Qc 3 1 1 30 -0.000000 0.0000200829
+ %Qc 3 1 1 40 -0.000000 0.0000066622
+ %Qc 3 1 1 50 -0.000000 0.0000023273
+ >EndCooling
+ %it 4 359 6627 2011 1413 0 0 0 0 0 0
+ %it4 4 0 0 0 0 0 0 0 0 0 0
+ %Favg 4 9.366 0.992 1.286 2.203 0.068 0.750 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 4 15.430 1.680 2.590 5.796 0.235 1.829 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 4 65.672 7.152 11.026 24.668 1.000 7.786 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 4 0.8032018E+04 0.4044664E+04 0.3834727E+04 -0.6003886E+04 0.1492007E+04 0.1535946E+04 0.3128561E+04
+ %Hnew 4 0.8031830E+04 0.4209353E+04 0.3696939E+04 -0.6021735E+04 0.1497246E+04 0.1535235E+04 0.3114790E+04
+ %Hdif 4 -0.1882389E+00 0.1646888E+03 -0.1377879E+03 -0.1784827E+02 0.5239810E+01 -0.7103588E+00 -0.1377034E+02
+ %mc 4 1 1 0.5098751753 1.2071218126 1 203 8712 74 26 1698 77 0.490124824737818
+ %pr 4 0.4901248247378 0.4871551218511 0.4930945276245 0.2773603205663 0.2734506483273 0.2812699928054
+ %egnv 4 1 1 0.65502609E-01 2.0458115 171 64 1e-11 31.233 1.72
+ %egnv 4 1 2 0.61459935E-01 2.0819227 136 63 1e-11 33.874 1.76
+ %egnv 4 1 3 0.64416896E-01 2.0552798 169 64 1e-11 31.906 1.73
+ %tr 4 1 1 1.007907845 -0.7601643054E-02 0.2443747534E-01 0.1701113209E-12 2.040834341 63
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 4 1 1 0.7951725245E-01 0.5623780163E-01
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 4 1 1 0 0.045646 0.5098751753
+ %Qc 4 1 1 1 -0.029235 0.0931408422
+ %Qc 4 1 1 2 0.001388 0.0184513185
+ %Qc 4 1 1 3 0.003494 0.0052928934
+ %Qc 4 1 1 4 0.001061 0.0023353861
+ %Qc 4 1 1 5 0.000387 0.0012942043
+ %Qc 4 1 1 6 0.000180 0.0008218519
+ %Qc 4 1 1 7 0.000100 0.0005731850
+ %Qc 4 1 1 8 0.000059 0.0004276599
+ %Qc 4 1 1 9 0.000037 0.0003349832
+ %Qc 4 1 1 10 0.000023 0.0002717444
+ %Qc 4 1 1 20 -0.000000 0.0000711819
+ %Qc 4 1 1 30 -0.000000 0.0000293477
+ %Qc 4 1 1 40 -0.000000 0.0000144832
+ %Qc 4 1 1 50 -0.000000 0.0000078682
+ >EndCooling
+ %it 5 314 5524 1698 1202 0 0 0 0 0 0
+ %it4 5 0 0 0 0 0 0 0 0 0 0
+ %Favg 5 9.482 1.018 1.283 2.051 0.066 0.702 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 5 15.906 1.765 2.497 5.144 0.220 1.751 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 5 72.376 8.032 11.363 23.406 1.000 7.968 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 5 0.7907837E+04 0.4124302E+04 0.3696939E+04 -0.6021735E+04 0.1493893E+04 0.1589574E+04 0.3024863E+04
+ %Hnew 5 0.7907717E+04 0.4170782E+04 0.3640564E+04 -0.6017343E+04 0.1500153E+04 0.1589358E+04 0.3024205E+04
+ %Hdif 5 -0.1194158E+00 0.4647944E+02 -0.5637588E+02 0.4391044E+01 0.6260341E+01 -0.2158011E+00 -0.6585559E+00
+ %mc 5 1 1 0.5031014784 1.1268383552 1 203 7284 62 26 1454 65 0.496898521559694
+ %pr 5 0.4968985215597 0.4932022938734 0.5005947492460 0.2783644727806 0.2752902984062 0.2814386471549
+ %egnv 5 1 1 0.55985783E-01 2.1002743 57 79 1e-11 37.514 1.81
+ %egnv 5 1 2 0.52921759E-01 2.1423924 58 75 1e-11 40.482 1.85
+ %egnv 5 1 3 0.55143429E-01 2.1112897 58 78 1e-11 38.287 1.82
+ %tr 5 1 1 1.001996987 0.3439318868E-01 0.8709399251E-02 0.2187463174E-12 2.079031150 59
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 5 1 1 0.1138802121 0.4482838698E-02
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 5 1 1 0 0.027003 0.5031014784
+ %Qc 5 1 1 1 -0.080645 0.0867700263
+ %Qc 5 1 1 2 -0.054680 0.0171108504
+ %Qc 5 1 1 3 -0.007190 0.0055779860
+ %Qc 5 1 1 4 -0.001143 0.0023577164
+ %Qc 5 1 1 5 -0.000409 0.0012326226
+ %Qc 5 1 1 6 -0.000174 0.0007421948
+ %Qc 5 1 1 7 -0.000077 0.0004950696
+ %Qc 5 1 1 8 -0.000036 0.0003559673
+ %Qc 5 1 1 9 -0.000018 0.0002700183
+ %Qc 5 1 1 10 -0.000010 0.0002125880
+ %Qc 5 1 1 20 -0.000001 0.0000387951
+ %Qc 5 1 1 30 -0.000000 0.0000102065
+ %Qc 5 1 1 40 -0.000000 0.0000032597
+ %Qc 5 1 1 50 -0.000000 0.0000011935
+ >EndCooling
+ %it 6 284 4843 1476 1074 0 0 0 0 0 0
+ %it4 6 0 0 0 0 0 0 0 0 0 0
+ %Favg 6 9.655 1.064 1.253 2.035 0.053 0.680 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 6 16.137 1.794 2.508 5.690 0.163 1.586 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 6 99.208 11.027 15.421 34.982 1.000 9.750 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 6 0.7711427E+04 0.4021976E+04 0.3640564E+04 -0.6017343E+04 0.1557628E+04 0.1489029E+04 0.3019573E+04
+ %Hnew 6 0.7711868E+04 0.4145540E+04 0.3545618E+04 -0.6029318E+04 0.1542523E+04 0.1489057E+04 0.3018447E+04
+ %Hdif 6 0.4417190E+00 0.1235644E+03 -0.9494551E+02 -0.1197408E+02 -0.1510536E+02 0.2809388E-01 -0.1125836E+01
+ %mc 6 1 1 0.5031014784 0.6429302791 0 203 6377 58 26 1300 61 0.496898521559694
+ %pr 6 0.4968985215597 0.4932022938734 0.5005947492460 0.2783644727806 0.2752902984062 0.2814386471549
+ %egnv 6 1 1 0.55985783E-01 2.1002743 57 79 1e-11 37.514 1.81
+ %egnv 6 1 2 0.52921759E-01 2.1423924 58 75 1e-11 40.482 1.85
+ %egnv 6 1 3 0.55143429E-01 2.1112897 58 78 1e-11 38.287 1.82
+ %tr 6 1 1 1.021818852 -0.8049552490E-02 0.1859040886E-01 0.2879403891E-12 2.002771437 60
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 6 1 1 0.1138802121 0.4482838698E-02
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 6 1 1 0 0.027003 0.5031014784
+ %Qc 6 1 1 1 -0.080645 0.0867700263
+ %Qc 6 1 1 2 -0.054680 0.0171108504
+ %Qc 6 1 1 3 -0.007190 0.0055779860
+ %Qc 6 1 1 4 -0.001143 0.0023577164
+ %Qc 6 1 1 5 -0.000409 0.0012326226
+ %Qc 6 1 1 6 -0.000174 0.0007421948
+ %Qc 6 1 1 7 -0.000077 0.0004950696
+ %Qc 6 1 1 8 -0.000036 0.0003559673
+ %Qc 6 1 1 9 -0.000018 0.0002700183
+ %Qc 6 1 1 10 -0.000010 0.0002125880
+ %Qc 6 1 1 20 -0.000001 0.0000387951
+ %Qc 6 1 1 30 -0.000000 0.0000102065
+ %Qc 6 1 1 40 -0.000000 0.0000032597
+ %Qc 6 1 1 50 -0.000000 0.0000011935
+ >EndCooling
+ %it 7 307 5336 1618 1164 0 0 0 0 0 0
+ %it4 7 0 0 0 0 0 0 0 0 0 0
+ %Favg 7 9.477 1.033 1.265 2.097 0.056 0.707 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 7 15.923 1.808 2.602 5.365 0.152 1.725 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 7 104.582 11.874 17.091 35.238 1.000 11.327 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 7 0.8015286E+04 0.4099800E+04 0.3640564E+04 -0.6017343E+04 0.1590498E+04 0.1568021E+04 0.3133748E+04
+ %Hnew 7 0.8015235E+04 0.4183155E+04 0.3571096E+04 -0.6012626E+04 0.1584634E+04 0.1567366E+04 0.3121610E+04
+ %Hdif 7 -0.5113948E-01 0.8335553E+02 -0.6946721E+02 0.4717735E+01 -0.5864061E+01 -0.6556146E+00 -0.1213753E+02
+ %mc 7 1 1 0.4940644414 1.0524696860 1 203 7012 58 26 1413 64 0.505935558570389
+ %pr 7 0.5059355585704 0.5058614794300 0.5060096377108 0.2865056687715 0.2908622534745 0.2821490840686
+ %egnv 7 1 1 0.54562660E-01 2.1441410 139 46 1e-11 39.297 1.84
+ %egnv 7 1 2 0.50838984E-01 2.1892239 135 45 1e-11 43.062 1.88
+ %egnv 7 1 3 0.53545687E-01 2.1559265 137 46 1e-11 40.263 1.85
+ %tr 7 1 1 1.038466593 0.1605924825E-01 0.3407742008E-01 0.4800454016E-12 2.153321764 63
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 7 1 1 0.1059552749 0.4013742461E-01
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 7 1 1 0 0.039829 0.4940644414
+ %Qc 7 1 1 1 -0.077202 0.0875074447
+ %Qc 7 1 1 2 -0.009690 0.0174920790
+ %Qc 7 1 1 3 0.001651 0.0054441039
+ %Qc 7 1 1 4 0.000961 0.0023981248
+ %Qc 7 1 1 5 0.000521 0.0013220648
+ %Qc 7 1 1 6 0.000299 0.0008278102
+ %Qc 7 1 1 7 0.000182 0.0005630218
+ %Qc 7 1 1 8 0.000117 0.0004060663
+ %Qc 7 1 1 9 0.000078 0.0003059132
+ %Qc 7 1 1 10 0.000054 0.0002381615
+ %Qc 7 1 1 20 0.000002 0.0000411097
+ %Qc 7 1 1 30 0.000000 0.0000101558
+ %Qc 7 1 1 40 0.000000 0.0000026919
+ %Qc 7 1 1 50 0.000000 0.0000007363
+ >EndCooling
+ %it 8 302 4696 1431 1063 0 0 0 0 0 0
+ %it4 8 0 0 0 0 0 0 0 0 0 0
+ %Favg 8 9.507 1.048 1.262 2.120 0.049 0.691 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 8 15.685 1.748 2.664 5.060 0.139 1.547 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 8 112.648 12.552 19.131 36.341 1.000 11.110 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 8 0.7775594E+04 0.4076839E+04 0.3571096E+04 -0.6012626E+04 0.1539474E+04 0.1536608E+04 0.3064202E+04
+ %Hnew 8 0.7775299E+04 0.4189634E+04 0.3454245E+04 -0.6021089E+04 0.1552887E+04 0.1535884E+04 0.3063738E+04
+ %Hdif 8 -0.2944022E+00 0.1127952E+03 -0.1168511E+03 -0.8463289E+01 0.1341280E+02 -0.7246042E+00 -0.4634163E+00
+ %mc 8 1 1 0.4784649756 1.3423236869 1 203 6187 60 26 1305 64 0.521535024389628
+ %pr 8 0.5215350243896 0.5201126083548 0.5229574404244 0.3041822322966 0.3066437871460 0.3017206774472
+ %egnv 8 1 1 0.89804417E-01 2.1318832 402 49 1e-11 23.739 1.58
+ %egnv 8 1 2 0.87969935E-01 2.1776359 458 47 1e-11 24.754 1.60
+ %egnv 8 1 3 0.89284234E-01 2.1438379 410 49 1e-11 24.011 1.59
+ %tr 8 1 1 1.005232580 -0.1776836719E-01 0.1515187603E-01 0.9981830177E-13 1.925465958 56
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 8 1 1 0.2075269581 -0.2875034199E-02
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 8 1 1 0 0.002028 0.4784649756
+ %Qc 8 1 1 1 0.015649 0.0739165664
+ %Qc 8 1 1 2 -0.000337 0.0117042590
+ %Qc 8 1 1 3 0.001183 0.0041610990
+ %Qc 8 1 1 4 0.000999 0.0021419626
+ %Qc 8 1 1 5 0.000624 0.0012944200
+ %Qc 8 1 1 6 0.000384 0.0008672893
+ %Qc 8 1 1 7 0.000246 0.0006281566
+ %Qc 8 1 1 8 0.000165 0.0004827686
+ %Qc 8 1 1 9 0.000115 0.0003880828
+ %Qc 8 1 1 10 0.000083 0.0003226650
+ %Qc 8 1 1 20 0.000006 0.0001077947
+ %Qc 8 1 1 30 0.000000 0.0000541516
+ %Qc 8 1 1 40 -0.000000 0.0000309701
+ %Qc 8 1 1 50 -0.000000 0.0000189534
+ >EndCooling
+ %it 9 278 4611 1400 1029 0 0 0 0 0 0
+ %it4 9 0 0 0 0 0 0 0 0 0 0
+ %Favg 9 9.639 1.071 1.268 1.943 0.053 0.713 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 9 15.785 1.806 2.600 4.739 0.143 1.810 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 9 110.570 12.650 18.212 33.199 1.000 12.678 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 9 0.7850211E+04 0.4133535E+04 0.3454245E+04 -0.6021089E+04 0.1494688E+04 0.1594648E+04 0.3194184E+04
+ %Hnew 9 0.7850568E+04 0.4138992E+04 0.3457535E+04 -0.6034924E+04 0.1511286E+04 0.1595209E+04 0.3182469E+04
+ %Hdif 9 0.3565416E+00 0.5456571E+01 0.3289833E+01 -0.1383473E+02 0.1659775E+02 0.5614769E+00 -0.1171437E+02
+ %mc 9 1 1 0.4783439102 0.7000933530 1 203 6066 55 26 1252 58 0.521656089758662
+ %pr 9 0.5216560897587 0.5175579692613 0.5257542102560 0.3092871013305 0.2946128306597 0.3239613720014
+ %egnv 9 1 1 0.79339562E-01 2.1200901 60 38 1e-11 26.722 1.64
+ %egnv 9 1 2 0.76287012E-01 2.1642184 61 37 1e-11 28.369 1.67
+ %egnv 9 1 3 0.78499302E-01 2.1316285 60 38 1e-11 27.155 1.65
+ %tr 9 1 1 1.017316061 0.1019396879E-01 -0.3873125184E-02 0.3965323440E-12 1.988905552 53
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 9 1 1 0.2796975100 0.7808683790E-02
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 9 1 1 0 0.015460 0.4783439102
+ %Qc 9 1 1 1 -0.031638 0.0709671563
+ %Qc 9 1 1 2 -0.004020 0.0099617757
+ %Qc 9 1 1 3 -0.000717 0.0031588151
+ %Qc 9 1 1 4 -0.000133 0.0014990532
+ %Qc 9 1 1 5 -0.000030 0.0008893425
+ %Qc 9 1 1 6 -0.000018 0.0006135112
+ %Qc 9 1 1 7 -0.000020 0.0004674604
+ %Qc 9 1 1 8 -0.000021 0.0003788013
+ %Qc 9 1 1 9 -0.000021 0.0003186521
+ %Qc 9 1 1 10 -0.000019 0.0002743553
+ %Qc 9 1 1 20 -0.000005 0.0000937959
+ %Qc 9 1 1 30 -0.000001 0.0000408909
+ %Qc 9 1 1 40 -0.000000 0.0000197091
+ %Qc 9 1 1 50 -0.000000 0.0000101358
+ >EndCooling
+ %it 10 268 4598 1388 1018 0 0 0 0 0 0
+ %it4 10 0 0 0 0 0 0 0 0 0 0
+ %Favg 10 9.724 1.094 1.257 2.038 0.051 0.670 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 10 15.974 1.861 2.511 5.364 0.151 1.614 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 10 105.778 12.326 16.627 35.521 1.000 10.690 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 10 0.7651666E+04 0.4096361E+04 0.3457535E+04 -0.6034924E+04 0.1594950E+04 0.1543888E+04 0.2993857E+04
+ %Hnew 10 0.7651844E+04 0.4112810E+04 0.3453801E+04 -0.6026672E+04 0.1576267E+04 0.1544064E+04 0.2991575E+04
+ %Hdif 10 0.1781014E+00 0.1644903E+02 -0.3733711E+01 0.8252019E+01 -0.1868320E+02 0.1756377E+00 -0.2281678E+01
+ %mc 10 1 1 0.4782961713 0.8368575590 1 203 6038 52 26 1234 54 0.521703828699875
+ %pr 10 0.5217038286999 0.5220441959034 0.5213634614963 0.3053448518001 0.3028146382562 0.3078750653441
+ %egnv 10 1 1 0.86328110E-01 2.0804812 68 49 1e-11 24.100 1.59
+ %egnv 10 1 2 0.84184902E-01 2.1219390 69 48 1e-11 25.206 1.61
+ %egnv 10 1 3 0.85726953E-01 2.0913289 68 48 1e-11 24.395 1.60
+ %tr 10 1 1 1.022055159 0.5521503278E-02 -0.2998286013E-01 0.8873341876E-13 2.027423632 53
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 10 1 1 0.1284477377 0.6387078416E-02
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 10 1 1 0 -0.116389 0.4782961713
+ %Qc 10 1 1 1 -0.007454 0.0669723197
+ %Qc 10 1 1 2 -0.003763 0.0090384656
+ %Qc 10 1 1 3 -0.001751 0.0027058642
+ %Qc 10 1 1 4 -0.000821 0.0012937578
+ %Qc 10 1 1 5 -0.000389 0.0007832207
+ %Qc 10 1 1 6 -0.000190 0.0005480911
+ %Qc 10 1 1 7 -0.000095 0.0004200246
+ %Qc 10 1 1 8 -0.000049 0.0003401863
+ %Qc 10 1 1 9 -0.000026 0.0002849915
+ %Qc 10 1 1 10 -0.000014 0.0002438627
+ %Qc 10 1 1 20 0.000000 0.0000756183
+ %Qc 10 1 1 30 0.000000 0.0000302082
+ %Qc 10 1 1 40 0.000000 0.0000140579
+ %Qc 10 1 1 50 0.000000 0.0000073432
+ >EndCooling
+ >EndMC
+ >BeginILDGwrite
+ ildg-write file bqcd.300.lime
+ ildg-write precision 64
+ ildg-write bytes 147456
+ ildg-write cksum 3484010393
+ ildg-write lfn bqcd-restart bqcd.300.lime 3484010393 147456 300 2 10
+ >EndILDGwrite
+ >BeginFooter
+ Date 2010-06-11 17:01:50.403
+ Seed -1
+ CPU-Time 148.8 s on 1 CPUs
+ >BeginTiming
+ Performance
+ region #calls time mean min max Total
+ s Mflop/s Mflop/s Mflop/s Gflop/s
+
+ d_xf 493370 7.95 2288.18 2288.18 2288.18 2.29
+ d_xb 0
+ d_yf 493370 8.12 2427.55 2427.55 2427.55 2.43
+ d_yb 0
+ d_zf 493370 8.33 2365.75 2365.75 2365.75 2.37
+ d_zb 0
+ d_t 493370 8.06 2445.64 2445.64 2445.64 2.45
+ d_fb 0
+ d_dag_fb 0
+ d_xyzt 0
+ sc2_projection 493370 6.26 726.30 726.30 726.30 0.73
+ D_TOTAL 493370 39.66 2063.72 2063.72 2063.72 2.06
+ d_dd 0
+ d_eo 0
+ MTDAGMT 105760 52.88 1917.10 1917.10 1917.10 1.92
+ CG 2040 42.47 1921.47 1921.47 1921.47 1.92
+ CG_DD 0
+ CG_HH 0
+ cg_global_sum 0
+ global_sum 0
+ global_sum_vec 0
+ sc_zero 39910 0.86
+ sc_copy 12140 0.09
+ sc_scale 9902 0.02 1520.87 1520.87 1520.87 1.52
+ sc_norm2 43082 0.28 958.98 958.98 958.98 0.96
+ sc_dot 50034 0.26 1182.28 1182.28 1182.28 1.18
+ sc_axpy 329830 1.40 1443.27 1443.27 1443.27 1.44
+ sc_xpby 325446 1.13 1772.52 1772.52 1772.52 1.77
+ sc_axpby 298576 1.16 2371.98 2371.98 2371.98 2.37
+ sc_cdotc 29220 0.15 2425.80 2425.80 2425.80 2.43
+ sc_caxpy 1940 0.00 +Inf +Inf +Inf +Inf
+ sc_caxpy2 1940 0.03 1702.64 1702.64 1702.64 1.70
+ sc_cax2 1980 0.03 1737.87 1737.87 1737.87 1.74
+ clover_init 2436 4.59
+ clover_mult_a 20 0.00 +Inf +Inf +Inf +Inf
+ clover_mult_ao 462970 16.62 1968.09 1968.09 1968.09 1.97
+ clover_mult_b 60200 2.36 1799.17 1799.17 1799.17 1.80
+ clover_dsd 410 4.45
+ clover_dsf 0
+ hmc_init 10 0.03
+ hmc_init_p 10 0.02
+ hmc_u 6400 6.40
+ hmc_momenta 0
+ hmc_phi 10 1.70
+ hmc_h_old 10 1.73
+ hmc_backup 10 0.00
+ hmc_half_step0 0
+ hmc_half_step1 0
+ hmc_xbound_g 10552 0.00
+ hmc_steps 8540 135.73
+ hmc_h_new 10 0.02
+ hmc_rest 10 0.00
+ HMC 10 143.93
+ h_mult_a 0
+ h_mult_b 0
+ h_mult_c 0
+ dsg 6410 8.40
+ dsf 2020 33.80
+ plaquette 22 0.02 914.50 914.50 914.50 0.91
+ cooling 10 1.41
+ ran_gauss_volh 140 0.06
+ MTDAGMT_r4 0
+ dsig 1610 10.50
+ rectangle 21 0.03 1867.26 1867.26 1867.26 1.87
+ chair 0
+ parallelogram 0
+ stout_smear 1612 4.08 1549.85 1549.85 1549.85 1.55
+ stout_diffe 2540 12.68 2317.33 2317.33 2317.33 2.32
+ clover_bsa_w 20260 2.53 1883.30 1883.30 1883.30 1.88
+ clover_dsd_w 1640 1.46 1166.54 1166.54 1166.54 1.17
+ clover_d_w 5900 13.90 2172.26 2172.26 2172.26 2.17
+ dsf_at_bt 10130 3.28 1461.00 1461.00 1461.00 1.46
+ dsf_xyztfb_w 10130 4.43 2333.09 2333.09 2333.09 2.33
+ dsf_sum 10130 13.34 1490.11 1490.11 1490.11 1.49
+ dsf_w2gen 2540 26.41 2120.58 2120.58 2120.58 2.12
+ cgm 260 10.92 1815.99 1815.99 1815.99 1.82
+ cg_ritz 82 4.15 1855.29 1855.29 1855.29 1.86
+ cg_mix 0
+ bicgstab 0
+ bicgstab_mix 0
+ ddbqnohat 0
+ unprec_mmul 0
+ unprec_dsf 0
+ dsf_un 0
+ dsf_mtmp 2020 88.52
+ cg_mre_mtmp 2020 44.83
+ dsf_wmul_r8 2020 0.48
+ dsf_wdag_r8 410 0.18
+ integrator 10 142.14
+ bagel_d 0
+ TOTAL 1 148.77
+
+ Performance
+ region #calls time mean min max Total
+ s MByte/s MByte/s MByte/s GByte/s
+
+ xbound_g 0
+ xbound_sc 0
+ xbound_sc2 0
+ u_read_bqcd 0
+ u_write_bqcd 0
+ u_read_ildg 1 0.00 36.86 36.86 36.86 0.04
+ u_write_ildg 1 0.00 +Inf +Inf +Inf +Inf
+ >EndTiming
+ >EndFooter
+ >EndJob
diff --git a/src/data/bqcd.310.input b/src/data/bqcd.310.input
new file mode 100644
index 0000000000000000000000000000000000000000..1d81c3c40d0d189b2c0a71fa684afef860380d69
--- /dev/null
+++ b/src/data/bqcd.310.input
@@ -0,0 +1,85 @@
+comment "Test for Nf=2+1 with replay trick"
+run 310
+lattice 4 4 4 4
+boundary_conditions_fermions 1 1 1 -1
+process_mapping 1 2 3 4
+processes 1 1 1 1
+
+gauge_action TREE
+beta 5.5
+fermi_action SLRC
+kappa 0.121095
+kappa_strange 0.120512
+csw 2.65
+n_stout 1
+alpha 0.1
+
+hmc_test 0
+hmc_integrator1 2MNSTS
+hmc_integrator2 2MNSTS
+hmc_integrator3 2MNSTS
+hmc_integrator4 2MNSTS
+
+hmc_model F
+hmc_mpf_mass 2
+hmc_mpf_rhmc_s 2
+hmc_hkappa 1
+hmc_rho 0.1203
+hmc_accept_first 10
+hmc_trajectory_length 1.0
+
+hmc_steps 5
+hmc_m_scale 2
+hmc_m_scale2 2
+hmc_m_scale3 2
+
+hmc_dsf1_mtmp 3
+hmc_dsf2_mtmp 2
+hmc_dsf_ers 1
+hmc_dsd 2
+hmc_dsig 3
+hmc_dsg 4
+
+start_configuration hot
+io_restart_format ildg
+#start_ildg_file qcdsf.699.00550.lime
+
+start_random 319503
+mc_steps 20
+mc_total_steps 20000
+mc_save_frequency 0
+
+solver_rest 1e-11
+solver_rest_md 1e-9
+solver_rest_cg_ritz 1e-11
+solver_maxiter 1200000
+solver_stopping_criterion 1
+solver_ignore_no_convergence 0
+solver_mre_vectors 5
+solver_check_solution 0
+solver_outer_solver cg
+solver_inner_solver cg
+solver_outer_steps 0
+
+measure_traces 1
+measure_minmax 1
+measure_polyakov_loop 1
+measure_rhmc_forces 0
+measure_cooling_list "cool.list"
+
+io_conf_format "ildg"
+ildg_filename_prefix "qcdsf"
+ildg_filename_extension "lime"
+ildg_precision 64
+ildg_template_ensemble "qcdsf-ensemble-05.xml"
+ildg_template_conf "qcdsf-configuration-04.xml"
+ildg_markov_chain_uri "mc://ldg/qcd_collaboration/clover_nf2p1/b5p50kp121095kp120512-32x64"
+ildg_data_lfn_path "lfn://ldg/qcd_collaboration/clover_nf2p1/b5p50kp121095kp120512-32x64"
+ildg_participant_name "Your Name"
+ildg_participant_institution "Your Institute"
+ildg_machine_name "fast_runner"
+ildg_machine_institution "Your Computing Centre"
+ildg_machine_type "fast_computer"
+
+replay_trick_ntau 10
+replay_trick_threshold 0.3
diff --git a/src/data/bqcd.310.output b/src/data/bqcd.310.output
new file mode 100644
index 0000000000000000000000000000000000000000..8efa1fea34b1d9f34602183669bf3b014b000760
--- /dev/null
+++ b/src/data/bqcd.310.output
@@ -0,0 +1,680 @@
+ >BeginJob
+ >BeginHeader
+ Comment Test for Nf=2+1 with replay trick
+ Program bqcd 4.0.0 (revision 332)
+ Version_of_D 100
+ Communication single_pe
+ RandomNumbers ranlux-3.2 level 2
+ Run 310
+ Job 1
+ Host ubuntu
+ Date 2011-09-21 22:27:52.571
+ L 4 4 4 4
+ DDL 1 1 1 1
+ NPE 1 1 1 1
+ process_mapping 1 2 3 4
+ bc_fermions 1 1 1 -1
+ gamma_index 1 2 3 4
+ Gauge Action TREE
+ Fermi Action SLRC
+ tilde M 1 - T^-1 D T^-1 D
+ Gamma notation BQCD
+ eo-prec DeoDoe
+ BoundaryCondition normal
+ Threads 1
+ Start 0
+ Seed 319503
+ Swap_seq 0
+ N_force 10
+ N_traj 20
+ N_save 0
+ N_temper 1
+ beta_1 5.5
+ c0_1 0.0
+ c1_1 0.0
+ c2_1 0.0
+ c3_1 0.0
+ u04_1 0.0
+ kappa_1 0.121095
+ kappa_strange_1 0.120512
+ csw_1 2.65
+ csw_kappa_1 0.320901750000000
+ csw_kappa_strange_1 0.319356800000000
+ n_stout_1 1
+ alpha_1 0.1
+ theta_1 0.0
+ chemi_1 0.0
+ h_1 0.0
+ rho_1 0.1203
+ rho2_1 0.0
+ rho3_1 0.0
+ rho4_1 0.0
+ traj_length_1 1.0
+ tau_1 0.200000000000000
+ N_tau_1 5 2MNSTS ers
+ m_scale_1 2 2MNSTS eo2 dat
+ m_scale2_1 2 2MNSTS eo1 ig
+ m_scale3_1 2 2MNSTS g
+ hkappa 1
+ mpf_eo[m,l,s]: 2 0 2
+ mpf_dd[m,l,s]: 0 0 0
+ mpf_hh[m,l,s]: 0 0 0
+ HMC_replay_ntau 10
+ HMC_replay_threshold 0.3
+ HMC_model F
+ REAL_kind 8
+ Solver_outer cg
+ Solver_inner cg
+ CG_rest 1e-11
+ CG_rest_md 1e-9
+ CG_stopping_criterion 1
+ CG_outer_steps 0
+ MRE_vectors 5
+ Fullsolver eo
+ >EndHeader
+ >BeginForceAcceptance
+ T%fa i_fa e PlaqEnergy exp(-Delta_H) CGcalls CGitTot CGitMax CGMcalls CGMitTotCGMitMax Plaquette
+ T%it traj iter_SF iter_F1 iter_F2 iter_F3 iter_F4 iter_F5 iter_F6 iter_F7 iter_F8 iter_F9
+ %it -9 260 4665 1469 1042 0 0 0 0 0 0
+ %it4 -9 0 0 0 0 0 0 0 0 0 0
+ T%Favg traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
+ T%Fmax traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
+ T%Frat traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
+ %Favg -9 7.822 0.666 1.340 2.775 0.067 0.823 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -9 14.008 1.247 2.702 7.549 0.193 1.961 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -9 72.626 6.464 14.006 39.139 1.000 10.165 0.000 0.000 0.000 0.000 0.000 0.000
+ T%Hold traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
+ T%Hnew traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
+ T%Hdif traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
+ %Hold -9 0.1175206E+05 0.4065964E+04 0.7585522E+04 -0.6000883E+04 0.1567305E+04 0.1517629E+04 0.3016521E+04
+ %Hnew -9 0.1175243E+05 0.5957390E+04 0.5626949E+04 -0.5967133E+04 0.1595594E+04 0.1515925E+04 0.3023703E+04
+ %Hdif -9 0.3697911E+00 0.1891426E+04 -0.1958573E+04 0.3375016E+02 0.2828917E+02 -0.1704640E+01 0.7182088E+01
+ %fa -9 1 0.7596780818 0.6908786269 203 6179 48 26 1257 61 0.240321918219764
+ T%egnv traj type mid min max it_min it_max tol condi n_opt
+ %egnv -9 1 1 0.80547445E-01 2.2603050 73 41 1e-11 28.062 1.67
+ %egnv -9 1 2 0.74060643E-01 2.3117457 74 39 1e-11 31.214 1.72
+ %egnv -9 1 3 0.78792963E-01 2.2737198 73 41 1e-11 28.857 1.68
+ %it -8 309 5273 1650 1179 0 0 0 0 0 0
+ %it4 -8 0 0 0 0 0 0 0 0 0 0
+ %Favg -8 8.173 0.726 1.348 2.465 0.067 0.809 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -8 14.511 1.353 2.755 6.638 0.189 1.925 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -8 76.618 7.144 14.547 35.048 1.000 10.166 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -8 0.9777570E+04 0.4030068E+04 0.5626949E+04 -0.5967133E+04 0.1485841E+04 0.1560926E+04 0.3040919E+04
+ %Hnew -8 0.9778114E+04 0.4628898E+04 0.5029892E+04 -0.5984421E+04 0.1505593E+04 0.1560220E+04 0.3037933E+04
+ %Hdif -8 0.5445722E+00 0.5988301E+03 -0.5970570E+03 -0.1728829E+02 0.1975166E+02 -0.7061834E+00 -0.2985696E+01
+ %fa -8 1 0.6837585510 0.5800898725 203 6981 58 26 1430 65 0.316241448982835
+ %egnv -8 1 1 0.71967912E-01 2.1601388 172 64 1e-11 30.015 1.70
+ %egnv -8 1 2 0.65996267E-01 2.2033538 176 62 1e-11 33.386 1.75
+ %egnv -8 1 3 0.70350902E-01 2.1714299 173 63 1e-11 30.866 1.71
+ %it -7 367 6315 1972 1416 0 0 0 0 0 0
+ %it4 -7 0 0 0 0 0 0 0 0 0 0
+ %Favg -7 8.463 0.775 1.341 2.442 0.071 0.862 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -7 15.009 1.430 2.738 6.868 0.236 2.102 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -7 63.708 6.071 11.622 29.153 1.000 8.920 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -7 0.9293270E+04 0.4094299E+04 0.5029892E+04 -0.5984421E+04 0.1512332E+04 0.1487833E+04 0.3153335E+04
+ %Hnew -7 0.9292577E+04 0.4531932E+04 0.4556032E+04 -0.5956843E+04 0.1510334E+04 0.1488096E+04 0.3163026E+04
+ %Hdif -7 -0.6925139E+00 0.4376328E+03 -0.4738597E+03 0.2757784E+02 -0.1997839E+01 0.2632195E+00 0.9691159E+01
+ %fa -7 1 0.6247996765 1.9987337431 203 8348 72 26 1722 88 0.375200323527170
+ %egnv -7 1 1 0.35981194E-01 2.4918009 109 27 1e-11 69.253 2.12
+ %egnv -7 1 2 0.31457047E-01 2.5556502 113 27 1e-11 81.243 2.20
+ %egnv -7 1 3 0.34743068E-01 2.5084717 110 27 1e-11 72.201 2.14
+ %it -6 415 6439 1996 1435 0 0 0 0 0 0
+ %it4 -6 0 0 0 0 0 0 0 0 0 0
+ %Favg -6 8.588 0.801 1.341 2.583 0.073 0.848 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -6 15.164 1.485 2.883 6.699 0.201 2.233 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -6 75.365 7.378 14.327 33.291 1.000 11.097 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -6 0.8871121E+04 0.4101907E+04 0.4556032E+04 -0.5956843E+04 0.1567070E+04 0.1524604E+04 0.3078351E+04
+ %Hnew -6 0.8870834E+04 0.4182358E+04 0.4478885E+04 -0.5981559E+04 0.1590364E+04 0.1524322E+04 0.3076463E+04
+ %Hdif -6 -0.2872979E+00 0.8045069E+02 -0.7714721E+02 -0.2471533E+02 0.2329443E+02 -0.2821219E+00 -0.1887758E+01
+ %fa -6 1 0.6141827704 1.3328212611 203 8518 83 26 1767 89 0.385817229614800
+ %egnv -6 1 1 0.44963111E-01 2.2734221 88 50 1e-11 50.562 1.96
+ %egnv -6 1 2 0.39975905E-01 2.3294476 90 48 1e-11 58.271 2.03
+ %egnv -6 1 3 0.43602824E-01 2.2880091 89 50 1e-11 52.474 1.98
+ %it -5 408 6831 2127 1499 0 0 0 0 0 0
+ %it4 -5 0 0 0 0 0 0 0 0 0 0
+ %Favg -5 8.537 0.810 1.325 2.374 0.073 0.792 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -5 15.199 1.518 2.779 5.839 0.240 1.881 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -5 63.304 6.323 11.576 24.320 1.000 7.834 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -5 0.8651157E+04 0.4089832E+04 0.4478885E+04 -0.5981559E+04 0.1533584E+04 0.1538412E+04 0.2992002E+04
+ %Hnew -5 0.8651211E+04 0.4106159E+04 0.4427728E+04 -0.5966972E+04 0.1552947E+04 0.1538339E+04 0.2993011E+04
+ %Hdif -5 0.5466773E-01 0.1632681E+02 -0.5115719E+02 0.1458633E+02 0.1936275E+02 -0.7251007E-01 0.1008478E+01
+ %fa -5 1 0.6078148517 0.9467996843 203 9032 74 26 1833 89 0.392185148344773
+ %egnv -5 1 1 0.22021276E-01 2.4372806 104 107 1e-11 110.678 2.35
+ %egnv -5 1 2 0.18136345E-01 2.5058991 109 102 1e-11 138.170 2.46
+ %egnv -5 1 3 0.20945916E-01 2.4551219 105 104 1e-11 117.212 2.38
+ %it -4 429 6844 2157 1507 0 0 0 0 0 0
+ %it4 -4 0 0 0 0 0 0 0 0 0 0
+ %Favg -4 8.590 0.817 1.341 2.382 0.075 0.815 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -4 15.030 1.533 2.840 6.062 0.241 1.996 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -4 62.306 6.354 11.771 25.130 1.000 8.273 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -4 0.8583368E+04 0.4091101E+04 0.4427728E+04 -0.5966972E+04 0.1500592E+04 0.1498237E+04 0.3032683E+04
+ %Hnew -4 0.8583295E+04 0.4195410E+04 0.4340990E+04 -0.5972497E+04 0.1494524E+04 0.1498127E+04 0.3026742E+04
+ %Hdif -4 -0.7338696E-01 0.1043087E+03 -0.8673771E+02 -0.5524790E+01 -0.6068144E+01 -0.1098792E+00 -0.5941606E+01
+ %fa -4 1 0.5963913539 1.0761468820 203 9085 84 26 1852 89 0.403608646117285
+ %egnv -4 1 1 0.30188146E-01 2.1647039 72 43 1e-11 71.707 2.14
+ %egnv -4 1 2 0.25911790E-01 2.2091304 74 42 1e-11 85.256 2.22
+ %egnv -4 1 3 0.29014812E-01 2.1763156 73 43 1e-11 75.007 2.16
+ %it -3 405 6806 2123 1496 0 0 0 0 0 0
+ %it4 -3 0 0 0 0 0 0 0 0 0 0
+ %Favg -3 8.812 0.851 1.322 2.317 0.076 0.815 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -3 15.659 1.548 2.832 6.624 0.240 2.042 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -3 65.194 6.446 11.792 27.579 1.000 8.503 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -3 0.8614961E+04 0.4145810E+04 0.4340990E+04 -0.5972497E+04 0.1528241E+04 0.1522367E+04 0.3050051E+04
+ %Hnew -3 0.8614829E+04 0.4253580E+04 0.4279266E+04 -0.5991784E+04 0.1500857E+04 0.1521232E+04 0.3051678E+04
+ %Hdif -3 -0.1322210E+00 0.1077699E+03 -0.6172370E+02 -0.1928727E+02 -0.2738316E+02 -0.1135419E+01 0.1627457E+01
+ %fa -3 1 0.5874912538 1.1413604899 203 9010 81 26 1820 85 0.412508746225394
+ %egnv -3 1 1 0.43832510E-01 2.0903463 114 69 1e-11 47.689 1.93
+ %egnv -3 1 2 0.39086798E-01 2.1258883 115 68 1e-11 54.389 2.00
+ %egnv -3 1 3 0.42539420E-01 2.0996774 114 68 1e-11 49.358 1.95
+ %it -2 396 7072 2166 1525 0 0 0 0 0 0
+ %it4 -2 0 0 0 0 0 0 0 0 0 0
+ %Favg -2 8.913 0.864 1.305 2.441 0.078 0.774 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -2 15.503 1.622 2.583 6.663 0.219 1.881 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -2 70.650 7.390 11.770 30.364 1.000 8.574 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -2 0.8505403E+04 0.4191183E+04 0.4279266E+04 -0.5991784E+04 0.1438738E+04 0.1538052E+04 0.3049948E+04
+ %Hnew -2 0.8505738E+04 0.4375280E+04 0.4115031E+04 -0.5998951E+04 0.1429808E+04 0.1538295E+04 0.3046276E+04
+ %Hdif -2 0.3356661E+00 0.1840966E+03 -0.1642358E+03 -0.7166638E+01 -0.8930499E+01 0.2437761E+00 -0.3671725E+01
+ %fa -2 1 0.5665928635 0.7148617486 203 9311 73 26 1848 83 0.433407136503992
+ %egnv -2 1 1 0.36920646E-01 2.2540469 93 63 1e-11 61.051 2.06
+ %egnv -2 1 2 0.32990186E-01 2.3051667 96 61 1e-11 69.874 2.12
+ %egnv -2 1 3 0.35843877E-01 2.2674049 93 62 1e-11 63.258 2.07
+ %it -1 443 8015 2453 1689 0 0 0 0 0 0
+ %it4 -1 0 0 0 0 0 0 0 0 0 0
+ %Favg -1 8.930 0.880 1.321 2.692 0.078 0.817 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -1 15.259 1.577 2.784 7.084 0.243 1.970 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -1 62.866 6.495 11.468 29.186 1.000 8.115 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -1 0.8457890E+04 0.4133751E+04 0.4115031E+04 -0.5998951E+04 0.1543906E+04 0.1550057E+04 0.3114096E+04
+ %Hnew -1 0.8458024E+04 0.4133266E+04 0.4063189E+04 -0.5982004E+04 0.1572060E+04 0.1549422E+04 0.3122091E+04
+ %Hdif -1 0.1340930E+00 -0.4850760E+00 -0.5184203E+02 0.1694690E+02 0.2815357E+02 -0.6347645E+00 0.7995496E+01
+ %fa -1 1 0.5600325226 0.8745087585 203 10547 84 26 2053 99 0.439967477354792
+ %egnv -1 1 1 0.20043752E-01 2.6191537 175 22 1e-11 130.672 2.44
+ %egnv -1 1 2 0.16816988E-01 2.7011716 181 21 1e-11 160.622 2.54
+ %egnv -1 1 3 0.19150390E-01 2.6404757 176 22 1e-11 137.881 2.46
+ %it 0 479 8211 2550 1734 0 0 0 0 0 0
+ %it4 0 0 0 0 0 0 0 0 0 0 0
+ %Favg 0 8.948 0.890 1.310 2.576 0.079 0.785 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 0 14.994 1.600 2.652 7.318 0.257 1.987 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 0 58.398 6.233 10.329 28.504 1.000 7.738 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 0 0.8333887E+04 0.4060687E+04 0.4063189E+04 -0.5982004E+04 0.1622086E+04 0.1520595E+04 0.3049334E+04
+ %Hnew 0 0.8334043E+04 0.4222562E+04 0.3927864E+04 -0.5981657E+04 0.1589964E+04 0.1519281E+04 0.3056029E+04
+ %Hdif 0 0.1560966E+00 0.1618753E+03 -0.1353247E+03 0.3474518E+00 -0.3212248E+02 -0.1314227E+01 0.6694721E+01
+ %fa 0 1 0.5423191675 0.8554765278 203 10855 94 26 2119 100 0.457680832487830
+ %egnv 0 1 1 0.21786046E-01 2.0954562 183 71 1e-11 96.183 2.28
+ %egnv 0 1 2 0.18395558E-01 2.1338143 187 70 1e-11 115.996 2.38
+ %egnv 0 1 3 0.20849284E-01 2.1055060 184 71 1e-11 100.987 2.31
+ >EndForceAcceptance
+ >BeginMC
+ T%mc traj e f PlaqEnergy exp(-Delta_H) Acc CGcalls CGitTot CGitMax CGMcalls CGMitTotCGMitMax Plaquette
+ T%pr traj Plaquette PlaquetteS PlaquetteT Rectangle RectangleS RectangleT
+ %it 1 468 9157 2766 1827 0 0 0 0 0 0
+ %it4 1 0 0 0 0 0 0 0 0 0 0
+ %Favg 1 9.045 0.914 1.310 2.609 0.074 0.780 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 1 15.598 1.700 2.656 7.611 0.211 1.853 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 1 73.953 8.060 12.594 36.086 1.000 8.788 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 1 0.8059372E+04 0.3981543E+04 0.3927864E+04 -0.5981657E+04 0.1572569E+04 0.1491144E+04 0.3067908E+04
+ %Hnew 1 0.8059149E+04 0.4134471E+04 0.3802579E+04 -0.5991136E+04 0.1561179E+04 0.1491647E+04 0.3060409E+04
+ %Hdif 1 -0.2222102E+00 0.1529275E+03 -0.1252850E+03 -0.9479001E+01 -0.1138985E+02 0.5033573E+00 -0.7499237E+01
+ %mc 1 1 1 0.5256287766 1.2488338160 1 203 12011 88 26 2207 97 0.474371223366952
+ %pr 1 0.4743712233670 0.4726444614416 0.4760979852923 0.2448709263519 0.2412306523393 0.2485112003645
+ %egnv 1 1 1 0.11201679E-01 2.1239394 92 55 1e-11 189.609 2.62
+ %egnv 1 1 2 0.88566281E-02 2.1649865 94 54 1e-11 244.448 2.75
+ %egnv 1 1 3 0.10542689E-01 2.1346870 92 55 1e-11 202.480 2.66
+ T%tr traj e f Re(pbp) Im(pbp) Re(p5p) -Im(p5p) PionNorm CGiter
+ %tr 1 1 1 1.096700462 -0.1407549483E-01 0.2229625636E-01 -0.7157087423E-12 2.751908895 98
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 1 1 1 -0.2789722073E-01 0.5139163744E-01
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 1 1 1 0 0.048126 0.5256287766
+ %Qc 1 1 1 1 0.020771 0.1313428133
+ %Qc 1 1 1 2 0.182281 0.0511502413
+ %Qc 1 1 1 3 0.219576 0.0309807577
+ %Qc 1 1 1 4 0.142079 0.0218651580
+ %Qc 1 1 1 5 0.052772 0.0161620086
+ %Qc 1 1 1 6 0.009561 0.0114304824
+ %Qc 1 1 1 7 0.002320 0.0075411411
+ %Qc 1 1 1 8 0.001251 0.0046428307
+ %Qc 1 1 1 9 0.000558 0.0026599217
+ %Qc 1 1 1 10 0.000203 0.0014373722
+ %Qc 1 1 1 20 0.000000 0.0000057767
+ %Qc 1 1 1 30 -0.000000 0.0000001381
+ %Qc 1 1 1 40 0.000000 0.0000000048
+ %Qc 1 1 1 50 0.000000 0.0000000002
+ >EndCooling
+ %it 2 455 7713 2354 1642 0 0 0 0 0 0
+ %it4 2 0 0 0 0 0 0 0 0 0 0
+ %Favg 2 9.177 0.940 1.294 2.393 0.063 0.763 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 2 15.786 1.705 2.628 6.960 0.203 2.201 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 2 77.904 8.415 12.971 34.348 1.000 10.863 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 2 0.8090140E+04 0.4136443E+04 0.3802579E+04 -0.5991136E+04 0.1557003E+04 0.1537098E+04 0.3048153E+04
+ %Hnew 2 0.8089947E+04 0.4104749E+04 0.3861978E+04 -0.5997383E+04 0.1531613E+04 0.1537314E+04 0.3051676E+04
+ %Hdif 2 -0.1930394E+00 -0.3169377E+02 0.5939897E+02 -0.6247810E+01 -0.2538989E+02 0.2159002E+00 0.3523552E+01
+ %mc 2 1 1 0.5329972738 1.2129305712 1 203 10159 92 26 2005 98 0.467002726200149
+ %pr 2 0.4670027262001 0.4683781125821 0.4656273398182 0.2414972351911 0.2417406997376 0.2412537706446
+ %egnv 2 1 1 0.22479266E-01 2.2750867 88 38 1e-11 101.208 2.31
+ %egnv 2 1 2 0.19130147E-01 2.3261453 89 37 1e-11 121.596 2.40
+ %egnv 2 1 3 0.21554327E-01 2.2884336 88 38 1e-11 106.170 2.33
+ %tr 2 1 1 1.057820178 -0.6021840548E-02 0.1866930893E-01 0.3389672802E-12 2.375531736 83
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 2 1 1 -0.1273484595E-01 -0.2853351752E-02
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 2 1 1 0 -0.009762 0.5329972738
+ %Qc 2 1 1 1 -0.005589 0.1193819284
+ %Qc 2 1 1 2 0.280278 0.0339020381
+ %Qc 2 1 1 3 0.458564 0.0186745713
+ %Qc 2 1 1 4 0.515329 0.0133907613
+ %Qc 2 1 1 5 0.494449 0.0106876341
+ %Qc 2 1 1 6 0.412659 0.0089590257
+ %Qc 2 1 1 7 0.243720 0.0071402461
+ %Qc 2 1 1 8 0.051627 0.0041253981
+ %Qc 2 1 1 9 0.004785 0.0017870726
+ %Qc 2 1 1 10 0.000654 0.0008693666
+ %Qc 2 1 1 20 -0.000000 0.0000149504
+ %Qc 2 1 1 30 -0.000000 0.0000007825
+ %Qc 2 1 1 40 -0.000000 0.0000000488
+ %Qc 2 1 1 50 -0.000000 0.0000000034
+ >EndCooling
+ %it 3 401 7600 2292 1560 0 0 0 0 0 0
+ %it4 3 0 0 0 0 0 0 0 0 0 0
+ %Favg 3 9.316 0.968 1.278 2.307 0.059 0.758 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 3 15.815 1.684 2.594 6.295 0.182 1.919 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 3 86.712 9.230 14.222 34.514 1.000 10.520 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 3 0.8167467E+04 0.4128298E+04 0.3861978E+04 -0.5997383E+04 0.1564709E+04 0.1498362E+04 0.3111503E+04
+ %Hnew 3 0.8167623E+04 0.4163487E+04 0.3834727E+04 -0.6003886E+04 0.1563891E+04 0.1498577E+04 0.3110827E+04
+ %Hdif 3 0.1561686E+00 0.3518982E+02 -0.2725052E+02 -0.6502846E+01 -0.8186534E+00 0.2147323E+00 -0.6763621E+00
+ %mc 3 1 1 0.5292769709 0.8554149516 1 203 9972 80 26 1881 84 0.470723029146328
+ %pr 3 0.4707230291463 0.4681862119893 0.4732598463034 0.2464434953329 0.2415090174780 0.2513779731878
+ %egnv 3 1 1 0.30014974E-01 2.1062972 104 54 1e-11 70.175 2.13
+ %egnv 3 1 2 0.26192034E-01 2.1456845 105 54 1e-11 81.921 2.20
+ %egnv 3 1 3 0.28967795E-01 2.1166145 105 54 1e-11 73.068 2.15
+ %tr 3 1 1 1.021762789 -0.2042146031E-01 -0.4749027568E-01 0.3973673242E-14 2.277549460 77
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 3 1 1 0.1773374000E-02 -0.6020273049E-02
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 3 1 1 0 0.082096 0.5292769709
+ %Qc 3 1 1 1 0.130736 0.1094908049
+ %Qc 3 1 1 2 0.348310 0.0290075306
+ %Qc 3 1 1 3 0.482536 0.0148645267
+ %Qc 3 1 1 4 0.532007 0.0109541621
+ %Qc 3 1 1 5 0.531717 0.0093610445
+ %Qc 3 1 1 6 0.496172 0.0084716141
+ %Qc 3 1 1 7 0.418683 0.0077233872
+ %Qc 3 1 1 8 0.256949 0.0064885283
+ %Qc 3 1 1 9 0.051149 0.0036024191
+ %Qc 3 1 1 10 0.004666 0.0014500989
+ %Qc 3 1 1 20 -0.000001 0.0000733980
+ %Qc 3 1 1 30 -0.000000 0.0000200830
+ %Qc 3 1 1 40 -0.000000 0.0000066622
+ %Qc 3 1 1 50 -0.000000 0.0000023273
+ >EndCooling
+ %it 4 359 6627 2011 1413 0 0 0 0 0 0
+ %it4 4 0 0 0 0 0 0 0 0 0 0
+ %Favg 4 9.366 0.992 1.286 2.203 0.068 0.750 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 4 15.430 1.680 2.590 5.796 0.235 1.829 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 4 65.672 7.152 11.026 24.668 1.000 7.786 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 4 0.8032018E+04 0.4044664E+04 0.3834727E+04 -0.6003886E+04 0.1492007E+04 0.1535946E+04 0.3128561E+04
+ %Hnew 4 0.8031830E+04 0.4209353E+04 0.3696939E+04 -0.6021735E+04 0.1497246E+04 0.1535235E+04 0.3114790E+04
+ %Hdif 4 -0.1882387E+00 0.1646889E+03 -0.1377879E+03 -0.1784834E+02 0.5239836E+01 -0.7103568E+00 -0.1377038E+02
+ %mc 4 1 1 0.5098751696 1.2071215764 1 203 8712 74 26 1698 77 0.490124830404474
+ %pr 4 0.4901248304045 0.4871551126951 0.4930945481138 0.2773603468371 0.2734506793642 0.2812700143101
+ %egnv 4 1 1 0.65502739E-01 2.0458128 171 64 1e-11 31.232 1.72
+ %egnv 4 1 2 0.61460094E-01 2.0819241 136 63 1e-11 33.874 1.76
+ %egnv 4 1 3 0.64417039E-01 2.0552811 169 64 1e-11 31.906 1.73
+ %tr 4 1 1 1.007907734 -0.7601675140E-02 0.2443749946E-01 0.1701263551E-12 2.040833006 63
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 4 1 1 0.7951758767E-01 0.5623775904E-01
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 4 1 1 0 0.045646 0.5098751696
+ %Qc 4 1 1 1 -0.029234 0.0931408157
+ %Qc 4 1 1 2 0.001388 0.0184512823
+ %Qc 4 1 1 3 0.003494 0.0052928828
+ %Qc 4 1 1 4 0.001061 0.0023353821
+ %Qc 4 1 1 5 0.000387 0.0012942022
+ %Qc 4 1 1 6 0.000180 0.0008218505
+ %Qc 4 1 1 7 0.000100 0.0005731839
+ %Qc 4 1 1 8 0.000059 0.0004276590
+ %Qc 4 1 1 9 0.000037 0.0003349825
+ %Qc 4 1 1 10 0.000023 0.0002717438
+ %Qc 4 1 1 20 -0.000000 0.0000711818
+ %Qc 4 1 1 30 -0.000000 0.0000293477
+ %Qc 4 1 1 40 -0.000000 0.0000144832
+ %Qc 4 1 1 50 -0.000000 0.0000078682
+ >EndCooling
+ %it 5 314 5524 1698 1202 0 0 0 0 0 0
+ %it4 5 0 0 0 0 0 0 0 0 0 0
+ %Favg 5 9.482 1.018 1.283 2.051 0.066 0.702 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 5 15.906 1.765 2.497 5.144 0.220 1.751 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 5 72.376 8.032 11.363 23.406 1.000 7.968 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 5 0.7907837E+04 0.4124302E+04 0.3696939E+04 -0.6021735E+04 0.1493893E+04 0.1589574E+04 0.3024863E+04
+ %Hnew 5 0.7907717E+04 0.4170782E+04 0.3640564E+04 -0.6017344E+04 0.1500153E+04 0.1589358E+04 0.3024205E+04
+ %Hdif 5 -0.1194174E+00 0.4647936E+02 -0.5637582E+02 0.4391006E+01 0.6260365E+01 -0.2158112E+00 -0.6585196E+00
+ %mc 5 1 1 0.5031014837 1.1268401568 1 203 7284 62 26 1454 65 0.496898516346528
+ %pr 5 0.4968985163465 0.4932023561982 0.5005946764949 0.2783644677154 0.2752903495813 0.2814385858495
+ %egnv 5 1 1 0.55985794E-01 2.1002748 57 79 1e-11 37.514 1.81
+ %egnv 5 1 2 0.52921769E-01 2.1423930 58 75 1e-11 40.482 1.85
+ %egnv 5 1 3 0.55143439E-01 2.1112902 58 78 1e-11 38.287 1.82
+ %tr 5 1 1 1.001997007 0.3439332297E-01 0.8709493911E-02 0.2186260432E-12 2.079031451 59
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 5 1 1 0.1138803811 0.4482985504E-02
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 5 1 1 0 0.027002 0.5031014837
+ %Qc 5 1 1 1 -0.080645 0.0867699973
+ %Qc 5 1 1 2 -0.054679 0.0171107966
+ %Qc 5 1 1 3 -0.007190 0.0055779637
+ %Qc 5 1 1 4 -0.001143 0.0023577124
+ %Qc 5 1 1 5 -0.000409 0.0012326215
+ %Qc 5 1 1 6 -0.000174 0.0007421942
+ %Qc 5 1 1 7 -0.000077 0.0004950691
+ %Qc 5 1 1 8 -0.000036 0.0003559669
+ %Qc 5 1 1 9 -0.000018 0.0002700179
+ %Qc 5 1 1 10 -0.000010 0.0002125877
+ %Qc 5 1 1 20 -0.000001 0.0000387950
+ %Qc 5 1 1 30 -0.000000 0.0000102065
+ %Qc 5 1 1 40 -0.000000 0.0000032597
+ %Qc 5 1 1 50 -0.000000 0.0000011935
+ >EndCooling
+ replay_trcik: start replay mode
+ replay_trcik: h_dif before replaying = 0.44172592934523891
+ replay_trcik: replayed h_dif = 4.29239621057604381E-002
+ replay_trcik: reversibility is ok
+ %it 6 509 18024 5449 4204 0 0 0 0 0 0
+ %it4 6 0 0 0 0 0 0 0 0 0 0
+ %Favg 6 9.655 1.064 1.253 2.035 0.052 0.679 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 6 16.137 1.794 2.506 5.691 0.163 1.587 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 6 99.302 11.037 15.424 35.021 1.000 9.768 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 6 0.7711426E+04 0.4021976E+04 0.3640564E+04 -0.6017344E+04 0.1557628E+04 0.1489029E+04 0.3019573E+04
+ %Hnew 6 0.7711469E+04 0.4145317E+04 0.3545489E+04 -0.6029303E+04 0.1542500E+04 0.1489057E+04 0.3018410E+04
+ %Hdif 6 0.4292396E-01 0.1233405E+03 -0.9507433E+02 -0.1195946E+02 -0.1512790E+02 0.2756884E-01 -0.1163497E+01
+ %mc 6 1 1 0.4899120698 0.9579842304 1 807 23531 58 94 4655 61 0.510087930209968
+ %pr 6 0.5100879302100 0.5039894148151 0.5161864456048 0.2977179722441 0.2893726814300 0.3060632630583
+ %egnv 6 1 1 0.56001623E-01 2.1000720 57 79 1e-11 37.500 1.81
+ %egnv 6 1 2 0.52939033E-01 2.1421753 58 76 1e-11 40.465 1.85
+ %egnv 6 1 3 0.55159652E-01 2.1110836 58 79 1e-11 38.272 1.82
+ %tr 6 1 1 1.021805588 -0.8061190176E-02 0.1861780366E-01 0.2880881297E-12 2.002666822 60
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 6 1 1 0.1139995601 0.4436629194E-02
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 6 1 1 0 0.027022 0.5030705621
+ %Qc 6 1 1 1 -0.080630 0.0867494720
+ %Qc 6 1 1 2 -0.054720 0.0171038254
+ %Qc 6 1 1 3 -0.007191 0.0055745286
+ %Qc 6 1 1 4 -0.001142 0.0023557693
+ %Qc 6 1 1 5 -0.000409 0.0012315836
+ %Qc 6 1 1 6 -0.000174 0.0007416228
+ %Qc 6 1 1 7 -0.000077 0.0004947387
+ %Qc 6 1 1 8 -0.000036 0.0003557664
+ %Qc 6 1 1 9 -0.000018 0.0002698915
+ %Qc 6 1 1 10 -0.000010 0.0002125057
+ %Qc 6 1 1 20 -0.000001 0.0000387985
+ %Qc 6 1 1 30 -0.000000 0.0000102099
+ %Qc 6 1 1 40 -0.000000 0.0000032612
+ %Qc 6 1 1 50 -0.000000 0.0000011941
+ >EndCooling
+ %it 7 307 5333 1618 1163 0 0 0 0 0 0
+ %it4 7 0 0 0 0 0 0 0 0 0 0
+ %Favg 7 9.477 1.033 1.265 2.096 0.056 0.707 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 7 15.922 1.808 2.602 5.363 0.152 1.724 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 7 104.604 11.877 17.096 35.237 1.000 11.329 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 7 0.8015038E+04 0.4099800E+04 0.3640345E+04 -0.6017373E+04 0.1590498E+04 0.1568021E+04 0.3133748E+04
+ %Hnew 7 0.8014986E+04 0.4183110E+04 0.3570930E+04 -0.6012642E+04 0.1584620E+04 0.1567366E+04 0.3121602E+04
+ %Hdif 7 -0.5200006E-01 0.8331074E+02 -0.6941488E+02 0.4730904E+01 -0.5877344E+01 -0.6555696E+00 -0.1214585E+02
+ %mc 7 1 1 0.4940437079 1.0533758104 1 203 7009 58 26 1412 64 0.505956292117162
+ %pr 7 0.5059562921172 0.5058849656887 0.5060276185456 0.2865159176321 0.2908687432589 0.2821630920052
+ %egnv 7 1 1 0.54610211E-01 2.1438095 139 46 1e-11 39.257 1.84
+ %egnv 7 1 2 0.50884876E-01 2.1888613 135 45 1e-11 43.016 1.88
+ %egnv 7 1 3 0.53592794E-01 2.1555870 137 46 1e-11 40.222 1.85
+ %tr 7 1 1 1.038443506 0.1600582102E-01 0.3407846420E-01 0.4839872716E-12 2.153266182 63
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 7 1 1 0.1059826774 0.4003929450E-01
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 7 1 1 0 0.039811 0.4940437079
+ %Qc 7 1 1 1 -0.076854 0.0874759097
+ %Qc 7 1 1 2 -0.009481 0.0174635439
+ %Qc 7 1 1 3 0.001655 0.0054334709
+ %Qc 7 1 1 4 0.000959 0.0023947757
+ %Qc 7 1 1 5 0.000520 0.0013207805
+ %Qc 7 1 1 6 0.000298 0.0008272406
+ %Qc 7 1 1 7 0.000182 0.0005627423
+ %Qc 7 1 1 8 0.000117 0.0004059155
+ %Qc 7 1 1 9 0.000078 0.0003058232
+ %Qc 7 1 1 10 0.000054 0.0002381022
+ %Qc 7 1 1 20 0.000002 0.0000411009
+ %Qc 7 1 1 30 0.000000 0.0000101513
+ %Qc 7 1 1 40 0.000000 0.0000026894
+ %Qc 7 1 1 50 0.000000 0.0000007351
+ >EndCooling
+ %it 8 302 4694 1431 1063 0 0 0 0 0 0
+ %it4 8 0 0 0 0 0 0 0 0 0 0
+ %Favg 8 9.507 1.048 1.262 2.120 0.049 0.691 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 8 15.687 1.748 2.662 5.060 0.139 1.547 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 8 112.742 12.563 19.133 36.363 1.000 11.118 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 8 0.7775411E+04 0.4076839E+04 0.3570930E+04 -0.6012642E+04 0.1539474E+04 0.1536608E+04 0.3064202E+04
+ %Hnew 8 0.7775116E+04 0.4189293E+04 0.3454433E+04 -0.6021064E+04 0.1552837E+04 0.1535885E+04 0.3063732E+04
+ %Hdif 8 -0.2943737E+00 0.1124539E+03 -0.1164968E+03 -0.8421251E+01 0.1336344E+02 -0.7233774E+00 -0.4702051E+00
+ %mc 8 1 1 0.4784909580 1.3422854279 1 203 6185 60 26 1305 64 0.521509041989961
+ %pr 8 0.5215090419900 0.5200820783909 0.5229360055890 0.3041447054901 0.3066112596803 0.3016781513000
+ %egnv 8 1 1 0.89799448E-01 2.1321057 401 49 1e-11 23.743 1.58
+ %egnv 8 1 2 0.87965151E-01 2.1778884 454 47 1e-11 24.759 1.60
+ %egnv 8 1 3 0.89279303E-01 2.1440681 409 48 1e-11 24.015 1.59
+ %tr 8 1 1 1.005222676 -0.1776428302E-01 0.1522476550E-01 0.9026807080E-13 1.924950517 56
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 8 1 1 0.2075425382 -0.3198528415E-02
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 8 1 1 0 0.001633 0.4784909580
+ %Qc 8 1 1 1 0.015612 0.0739140977
+ %Qc 8 1 1 2 -0.000323 0.0117005162
+ %Qc 8 1 1 3 0.001189 0.0041608023
+ %Qc 8 1 1 4 0.001001 0.0021424802
+ %Qc 8 1 1 5 0.000624 0.0012949879
+ %Qc 8 1 1 6 0.000384 0.0008677716
+ %Qc 8 1 1 7 0.000246 0.0006285518
+ %Qc 8 1 1 8 0.000165 0.0004830964
+ %Qc 8 1 1 9 0.000115 0.0003883603
+ %Qc 8 1 1 10 0.000083 0.0003229043
+ %Qc 8 1 1 20 0.000006 0.0001078803
+ %Qc 8 1 1 30 0.000000 0.0000541871
+ %Qc 8 1 1 40 -0.000000 0.0000309797
+ %Qc 8 1 1 50 -0.000000 0.0000189483
+ >EndCooling
+ replay_trcik: start replay mode
+ replay_trcik: h_dif before replaying = 0.35994678609176844
+ replay_trcik: replayed h_dif = -3.13361914595589042E-003
+ replay_trcik: reversibility is ok
+ %it 9 499 17127 5193 4029 0 0 0 0 0 0
+ %it4 9 0 0 0 0 0 0 0 0 0 0
+ %Favg 9 9.639 1.071 1.268 1.943 0.053 0.712 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 9 15.788 1.806 2.599 4.736 0.143 1.810 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 9 110.593 12.651 18.205 33.174 1.000 12.682 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 9 0.7850425E+04 0.4133535E+04 0.3454433E+04 -0.6021064E+04 0.1494688E+04 0.1594648E+04 0.3194184E+04
+ %Hnew 9 0.7850421E+04 0.4138680E+04 0.3457675E+04 -0.6034941E+04 0.1511289E+04 0.1595214E+04 0.3182505E+04
+ %Hdif 9 -0.3133619E-02 0.5144314E+01 0.3241921E+01 -0.1387744E+02 0.1660076E+02 0.5657190E+00 -0.1167841E+02
+ %mc 9 1 1 0.4783628696 1.0031385341 1 807 22375 55 94 4473 58 0.521637130358626
+ %pr 9 0.5216371303586 0.5175422601170 0.5257320006002 0.3092630899021 0.2946022782536 0.3239239015505
+ %egnv 9 1 1 0.89840994E-01 2.1319465 401 48 1e-11 23.730 1.58
+ %egnv 9 1 2 0.88005317E-01 2.1777243 455 47 1e-11 24.745 1.60
+ %egnv 9 1 3 0.89320501E-01 2.1439077 410 48 1e-11 24.002 1.59
+ %tr 9 1 1 1.033743959 0.1418372126E-01 0.1773518737E-01 0.2437182400E-12 2.136426205 57
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 9 1 1 0.2076343853 -0.3202561565E-02
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 9 1 1 0 0.001631 0.4784622803
+ %Qc 9 1 1 1 0.015684 0.0738970966
+ %Qc 9 1 1 2 -0.000315 0.0116939039
+ %Qc 9 1 1 3 0.001190 0.0041578798
+ %Qc 9 1 1 4 0.001001 0.0021409311
+ %Qc 9 1 1 5 0.000624 0.0012940821
+ %Qc 9 1 1 6 0.000384 0.0008672161
+ %Qc 9 1 1 7 0.000246 0.0006281990
+ %Qc 9 1 1 8 0.000165 0.0004828658
+ %Qc 9 1 1 9 0.000116 0.0003882058
+ %Qc 9 1 1 10 0.000084 0.0003227986
+ %Qc 9 1 1 20 0.000006 0.0001078830
+ %Qc 9 1 1 30 0.000000 0.0000542000
+ %Qc 9 1 1 40 -0.000000 0.0000309944
+ %Qc 9 1 1 50 -0.000000 0.0000189627
+ >EndCooling
+ %it 10 276 4373 1353 1023 0 0 0 0 0 0
+ %it4 10 0 0 0 0 0 0 0 0 0 0
+ %Favg 10 9.652 1.077 1.257 1.944 0.053 0.680 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 10 15.905 1.840 2.631 4.810 0.159 1.721 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 10 100.031 11.575 16.548 30.249 1.000 10.825 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 10 0.7662171E+04 0.4096361E+04 0.3454229E+04 -0.6021114E+04 0.1594950E+04 0.1543888E+04 0.2993857E+04
+ %Hnew 10 0.7662219E+04 0.4115513E+04 0.3451672E+04 -0.6032564E+04 0.1595036E+04 0.1544497E+04 0.2988065E+04
+ %Hdif 10 0.4844474E-01 0.1915216E+02 -0.2557151E+01 -0.1145054E+02 0.8667463E-01 0.6094854E+00 -0.5792184E+01
+ %mc 10 1 1 0.4776125109 0.9527099859 1 203 5781 55 26 1244 58 0.522387489085741
+ %pr 10 0.5223874890857 0.5201161708789 0.5246588072926 0.3096610602803 0.3087144282286 0.3106076923319
+ %egnv 10 1 1 0.95202887E-01 2.0541882 126 33 1e-11 21.577 1.54
+ %egnv 10 1 2 0.93121432E-01 2.0922909 125 32 1e-11 22.468 1.56
+ %egnv 10 1 3 0.94623418E-01 2.0641689 126 32 1e-11 21.815 1.54
+ %tr 10 1 1 0.9947831625 0.9106074977E-02 -0.1817837948E-01 0.1067809036E-13 1.936077965 52
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 10 1 1 0.2104837252 -0.7062826354E-01
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 10 1 1 0 -0.005531 0.4776125109
+ %Qc 10 1 1 1 -0.024231 0.0689734718
+ %Qc 10 1 1 2 -0.006609 0.0121285172
+ %Qc 10 1 1 3 -0.001572 0.0045666920
+ %Qc 10 1 1 4 -0.000583 0.0023255207
+ %Qc 10 1 1 5 -0.000292 0.0013762327
+ %Qc 10 1 1 6 -0.000164 0.0009176696
+ %Qc 10 1 1 7 -0.000097 0.0006720028
+ %Qc 10 1 1 8 -0.000061 0.0005266109
+ %Qc 10 1 1 9 -0.000041 0.0004323089
+ %Qc 10 1 1 10 -0.000029 0.0003661488
+ %Qc 10 1 1 20 -0.000003 0.0001231469
+ %Qc 10 1 1 30 -0.000001 0.0000556736
+ %Qc 10 1 1 40 -0.000000 0.0000280411
+ %Qc 10 1 1 50 -0.000000 0.0000150627
+ >EndCooling
+ >EndMC
+ >BeginILDGwrite
+ ildg-write file bqcd.310.lime
+ ildg-write precision 64
+ ildg-write bytes 147456
+ ildg-write cksum 4073776015
+ ildg-write lfn bqcd-restart bqcd.310.lime 4073776015 147456 310 1 10
+ >EndILDGwrite
+ >BeginFooter
+ Date 2011-09-21 22:34:41.413
+ Seed -1
+ CPU-Time 404.4 s on 1 CPUs
+ >BeginTiming
+ Performance
+ region #calls time mean min max Total
+ s Mflop/s Mflop/s Mflop/s Gflop/s
+
+ d_xf 1235348 21.54 2114.46 2114.46 2114.46 2.11
+ d_xb 0
+ d_yf 1235348 27.44 1798.07 1798.07 1798.07 1.80
+ d_yb 0
+ d_zf 1235348 26.71 1847.36 1847.36 1847.36 1.85
+ d_zb 0
+ d_t 1235348 25.82 1910.60 1910.60 1910.60 1.91
+ d_fb 0
+ d_dag_fb 0
+ d_xyzt 0
+ sc2_projection 1235348 19.11 595.91 595.91 595.91 0.60
+ D_TOTAL 1235348 124.04 1652.18 1652.18 1652.18 1.65
+ d_dd 0
+ d_eo 0
+ MTDAGMT 263316 149.73 1685.52 1685.52 1685.52 1.69
+ CG 5278 120.34 1699.47 1699.47 1699.47 1.70
+ CG_DD 0
+ CG_HH 0
+ cg_global_sum 0
+ global_sum 0
+ global_sum_vec 0
+ sc_zero 102200 2.37
+ sc_copy 321326 1.04
+ sc_scale 25730 0.14 548.87 548.87 548.87 0.55
+ sc_norm2 108125 0.43 1552.07 1552.07 1552.07 1.55
+ sc_dot 123345 0.62 1222.24 1222.24 1222.24 1.22
+ sc_axpy 831615 3.78 1351.62 1351.62 1351.62 1.35
+ sc_xpby 814050 3.28 1522.89 1522.89 1522.89 1.52
+ sc_axpby 746670 3.73 1845.73 1845.73 1845.73 1.85
+ sc_cdotc 76072 0.41 2268.72 2268.72 2268.72 2.27
+ sc_caxpy 5056 0.02 2588.35 2588.35 2588.35 2.59
+ sc_caxpy2 5056 0.02 7766.02 7766.02 7766.02 7.77
+ sc_cax2 5152 0.05 2434.82 2434.82 2434.82 2.43
+ clover_init 6279 11.40
+ clover_mult_a 20 0.00 +Inf +Inf +Inf +Inf
+ clover_mult_ao 1156762 44.07 1854.73 1854.73 1854.73 1.85
+ clover_mult_b 155840 5.93 1857.35 1857.35 1857.35 1.86
+ clover_dsd 1064 11.77
+ clover_dsf 0
+ hmc_init 20 0.04
+ hmc_init_p 20 0.02
+ hmc_u 16640 17.11
+ hmc_momenta 0
+ hmc_phi 20 3.49
+ hmc_h_old 20 3.56
+ hmc_backup 20 0.02
+ hmc_half_step0 0
+ hmc_half_step1 0
+ hmc_xbound_g 27409 0.02
+ hmc_steps 22196 374.50
+ hmc_h_new 20 0.04
+ hmc_rest 20 81.60
+ HMC 20 395.35
+ h_mult_a 0
+ h_mult_b 0
+ h_mult_c 0
+ dsg 16664 21.14
+ dsf 5248 90.91
+ plaquette 46 0.02 1529.63 1529.63 1529.63 1.53
+ cooling 10 1.27
+ ran_gauss_volh 268 0.04
+ MTDAGMT_r4 0
+ dsig 4184 26.45
+ rectangle 45 0.06 2000.63 2000.63 2000.63 2.00
+ chair 0
+ parallelogram 0
+ stout_smear 4173 10.23 1599.83 1599.83 1599.83 1.60
+ stout_diffe 6596 35.03 2178.41 2178.41 2178.41 2.18
+ clover_bsa_w 52384 9.14 1346.82 1346.82 1346.82 1.35
+ clover_dsd_w 4256 3.48 1273.55 1273.55 1273.55 1.27
+ clover_d_w 15320 38.86 2018.37 2018.37 2018.37 2.02
+ dsf_at_bt 26192 9.22 1343.27 1343.27 1343.27 1.34
+ dsf_xyztfb_w 26192 15.02 1778.88 1778.88 1778.88 1.78
+ dsf_sum 26192 40.23 1278.01 1278.01 1278.01 1.28
+ dsf_w2gen 6596 73.94 1967.01 1967.01 1967.01 1.97
+ cgm 656 32.28 1558.73 1558.73 1558.73 1.56
+ cg_ritz 170 10.02 1690.34 1690.34 1690.34 1.69
+ cg_mix 0
+ bicgstab 0
+ bicgstab_mix 0
+ ddbqnohat 0
+ unprec_mmul 0
+ unprec_dsf 0
+ dsf_un 0
+ dsf_mtmp 5248 242.27
+ cg_mre_mtmp 5248 128.23
+ dsf_wmul_r8 5248 1.41
+ dsf_wdag_r8 1064 0.38
+ integrator 24 391.66
+ bagel_d 0
+ TOTAL 1 404.41
+
+ Performance
+ region #calls time mean min max Total
+ s MByte/s MByte/s MByte/s GByte/s
+
+ xbound_g 0
+ xbound_sc 0
+ xbound_sc2 0
+ u_read_bqcd 0
+ u_write_bqcd 0
+ u_read_ildg 0
+ u_write_ildg 1 0.00 +Inf +Inf +Inf +Inf
+ >EndTiming
+ >EndFooter
+ >EndJob
diff --git a/src/data/bqcd.320.input b/src/data/bqcd.320.input
new file mode 100644
index 0000000000000000000000000000000000000000..ceff2ca875464c44854d2bd9815d3394854f20c9
--- /dev/null
+++ b/src/data/bqcd.320.input
@@ -0,0 +1,86 @@
+comment "Test for Nf=2+1 with RHMC tuning"
+run 320
+lattice 4 4 4 4
+boundary_conditions_fermions 1 1 1 -1
+process_mapping 1 2 3 4
+processes 1 1 1 1
+
+gauge_action TREE
+beta 5.5
+fermi_action SLRC
+kappa 0.121095
+kappa_strange 0.120512
+csw 2.65
+n_stout 1
+alpha 0.1
+
+hmc_test 0
+hmc_integrator1 2MNSTS
+hmc_integrator2 2MNSTS
+hmc_integrator3 2MNSTS
+hmc_integrator4 2MNSTS
+
+hmc_model F
+hmc_mpf_mass 2
+hmc_mpf_rhmc_s 2
+hmc_hkappa 1
+hmc_rho 0.1203
+hmc_accept_first 10
+hmc_trajectory_length 1.0
+
+hmc_steps 5
+hmc_m_scale 2
+hmc_m_scale2 2
+hmc_m_scale3 2
+
+hmc_dsf1_mtmp 3
+hmc_dsf2_mtmp 2
+hmc_dsf_ers 1
+hmc_dsd 2
+hmc_dsig 3
+hmc_dsg 4
+
+start_configuration hot
+io_restart_format ildg
+#start_ildg_file qcdsf.699.00550.lime
+
+start_random 319503
+mc_steps 10
+mc_total_steps 20000
+mc_save_frequency 0
+
+solver_rest 1e-11
+solver_rest_md 1e-9
+solver_rest_cg_ritz 1e-11
+solver_maxiter 1200000
+solver_stopping_criterion 1
+solver_ignore_no_convergence 0
+solver_mre_vectors 5
+solver_check_solution 0
+solver_outer_solver cg
+solver_inner_solver cg
+solver_outer_steps 0
+
+measure_traces 1
+measure_minmax 1
+measure_polyakov_loop 1
+measure_rhmc_forces 0
+measure_cooling_list "cool.list"
+
+io_conf_format "ildg"
+ildg_filename_prefix "qcdsf"
+ildg_filename_extension "lime"
+ildg_precision 64
+ildg_template_ensemble "qcdsf-ensemble-05.xml"
+ildg_template_conf "qcdsf-configuration-04.xml"
+ildg_markov_chain_uri "mc://ldg/qcd_collaboration/clover_nf2p1/b5p50kp121095kp120512-32x64"
+ildg_data_lfn_path "lfn://ldg/qcd_collaboration/clover_nf2p1/b5p50kp121095kp120512-32x64"
+ildg_participant_name "Your Name"
+ildg_participant_institution "Your Institute"
+ildg_machine_name "fast_runner"
+ildg_machine_institution "Your Computing Centre"
+ildg_machine_type "fast_computer"
+
+tuning_approx_range 1
+tuning_approx_range_list "rangelist"
+tuning_fraction_tolerance "fractiontolerance"
diff --git a/src/data/bqcd.320.output b/src/data/bqcd.320.output
new file mode 100644
index 0000000000000000000000000000000000000000..00ae15ff7e7c3ed4df322b62d8df892c6e8745c8
--- /dev/null
+++ b/src/data/bqcd.320.output
@@ -0,0 +1,325 @@
+ >BeginJob
+ >BeginHeader
+ Comment Test for Nf=2+1 with RHMC tuning
+ Program bqcd 4.0.0 (revision 332)
+ Version_of_D 100
+ Communication single_pe
+ RandomNumbers ranlux-3.2 level 2
+ Run 320
+ Job 1
+ Host ubuntu
+ Date 2011-09-22 19:05:14.740
+ L 4 4 4 4
+ DDL 1 1 1 1
+ NPE 1 1 1 1
+ process_mapping 1 2 3 4
+ bc_fermions 1 1 1 -1
+ gamma_index 1 2 3 4
+ Gauge Action TREE
+ Fermi Action SLRC
+ tilde M 1 - T^-1 D T^-1 D
+ Gamma notation BQCD
+ eo-prec DeoDoe
+ BoundaryCondition normal
+ Threads 1
+ Start 0
+ Seed 319503
+ Swap_seq 0
+ N_force 10
+ N_traj 10
+ N_save 0
+ N_temper 1
+ beta_1 5.5
+ c0_1 0.0
+ c1_1 0.0
+ c2_1 0.0
+ c3_1 0.0
+ u04_1 0.0
+ kappa_1 0.121095
+ kappa_strange_1 0.120512
+ csw_1 2.65
+ csw_kappa_1 0.320901750000000
+ csw_kappa_strange_1 0.319356800000000
+ n_stout_1 1
+ alpha_1 0.1
+ theta_1 0.0
+ chemi_1 0.0
+ h_1 0.0
+ rho_1 0.1203
+ rho2_1 0.0
+ rho3_1 0.0
+ rho4_1 0.0
+ traj_length_1 1.0
+ tau_1 0.200000000000000
+ N_tau_1 5 2MNSTS ers
+ m_scale_1 2 2MNSTS eo2 dat
+ m_scale2_1 2 2MNSTS eo1 ig
+ m_scale3_1 2 2MNSTS g
+ hkappa 1
+ mpf_eo[m,l,s]: 2 0 2
+ mpf_dd[m,l,s]: 0 0 0
+ mpf_hh[m,l,s]: 0 0 0
+ HMC_model F
+ REAL_kind 8
+ Solver_outer cg
+ Solver_inner cg
+ CG_rest 1e-11
+ CG_rest_md 1e-9
+ CG_stopping_criterion 1
+ CG_outer_steps 0
+ MRE_vectors 5
+ Fullsolver eo
+ >EndHeader
+ >BeginForceAcceptance
+ T%fa i_fa e PlaqEnergy exp(-Delta_H) CGcalls CGitTot CGitMax CGMcalls CGMitTotCGMitMax Plaquette
+ T%it traj iter_SF iter_F1 iter_F2 iter_F3 iter_F4 iter_F5 iter_F6 iter_F7 iter_F8 iter_F9
+ %it -9 256 4665 1469 897 0 0 0 0 0 0
+ %it4 -9 0 0 0 0 0 0 0 0 0 0
+ T%Favg traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
+ T%Fmax traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
+ T%Frat traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
+ %Favg -9 7.822 0.666 1.340 2.775 0.067 0.823 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -9 14.008 1.247 2.702 7.549 0.193 1.961 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -9 72.626 6.464 14.006 39.139 1.000 10.165 0.000 0.000 0.000 0.000 0.000 0.000
+ T%Hold traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
+ T%Hnew traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
+ T%Hdif traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
+ %Hold -9 0.1175206E+05 0.4065964E+04 0.7585522E+04 -0.6000883E+04 0.1567305E+04 0.1517629E+04 0.3016521E+04
+ %Hnew -9 0.1175243E+05 0.5957390E+04 0.5626949E+04 -0.5967133E+04 0.1595594E+04 0.1515925E+04 0.3023703E+04
+ %Hdif -9 0.3697904E+00 0.1891426E+04 -0.1958573E+04 0.3375016E+02 0.2828917E+02 -0.1704640E+01 0.7182088E+01
+ %fa -9 1 0.7596780815 0.6908791076 203 6179 48 26 1108 60 0.240321918533823
+ T%egnv traj type mid min max it_min it_max tol condi n_opt
+ %egnv -9 1 1 0.80547444E-01 2.2603050 73 41 1e-11 28.062 1.67
+ %egnv -9 1 2 0.74060642E-01 2.3117457 74 39 1e-11 31.214 1.72
+ %egnv -9 1 3 0.78792962E-01 2.2737198 73 41 1e-11 28.857 1.68
+ %it -8 305 5273 1650 1021 0 0 0 0 0 0
+ %it4 -8 0 0 0 0 0 0 0 0 0 0
+ %Favg -8 8.173 0.726 1.348 2.465 0.067 0.809 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -8 14.511 1.353 2.755 6.638 0.189 1.925 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -8 76.618 7.144 14.547 35.048 1.000 10.166 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -8 0.9777570E+04 0.4030068E+04 0.5626949E+04 -0.5967133E+04 0.1485841E+04 0.1560926E+04 0.3040919E+04
+ %Hnew -8 0.9778114E+04 0.4628898E+04 0.5029892E+04 -0.5984421E+04 0.1505593E+04 0.1560220E+04 0.3037933E+04
+ %Hdif -8 0.5445720E+00 0.5988301E+03 -0.5970570E+03 -0.1728829E+02 0.1975166E+02 -0.7061834E+00 -0.2985696E+01
+ %fa -8 1 0.6837585513 0.5800900368 203 6981 58 26 1268 64 0.316241448723477
+ %egnv -8 1 1 0.71967912E-01 2.1601388 172 64 1e-11 30.015 1.70
+ %egnv -8 1 2 0.65996267E-01 2.2033538 176 62 1e-11 33.386 1.75
+ %egnv -8 1 3 0.70350902E-01 2.1714299 173 63 1e-11 30.866 1.71
+ %it -7 362 6315 1972 1220 0 0 0 0 0 0
+ %it4 -7 0 0 0 0 0 0 0 0 0 0
+ %Favg -7 8.463 0.775 1.341 2.442 0.071 0.862 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -7 15.009 1.430 2.738 6.868 0.236 2.102 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -7 63.708 6.071 11.622 29.153 1.000 8.920 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -7 0.9293270E+04 0.4094299E+04 0.5029892E+04 -0.5984421E+04 0.1512332E+04 0.1487833E+04 0.3153335E+04
+ %Hnew -7 0.9292577E+04 0.4531932E+04 0.4556032E+04 -0.5956843E+04 0.1510334E+04 0.1488096E+04 0.3163026E+04
+ %Hdif -7 -0.6924984E+00 0.4376329E+03 -0.4738598E+03 0.2757786E+02 -0.1997844E+01 0.2632200E+00 0.9691162E+01
+ %fa -7 1 0.6247996693 1.9987028544 203 8348 72 26 1521 87 0.375200330691069
+ %egnv -7 1 1 0.35981141E-01 2.4918010 109 27 1e-11 69.253 2.12
+ %egnv -7 1 2 0.31456996E-01 2.5556503 113 27 1e-11 81.243 2.20
+ %egnv -7 1 3 0.34743015E-01 2.5084718 110 27 1e-11 72.201 2.14
+ %it -6 409 6439 1996 1256 0 0 0 0 0 0
+ %it4 -6 0 0 0 0 0 0 0 0 0 0
+ %Favg -6 8.588 0.801 1.341 2.583 0.073 0.848 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -6 15.164 1.485 2.883 6.699 0.201 2.233 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -6 75.365 7.378 14.327 33.291 1.000 11.097 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -6 0.8871121E+04 0.4101907E+04 0.4556032E+04 -0.5956843E+04 0.1567070E+04 0.1524604E+04 0.3078351E+04
+ %Hnew -6 0.8870834E+04 0.4182358E+04 0.4478885E+04 -0.5981559E+04 0.1590364E+04 0.1524322E+04 0.3076463E+04
+ %Hdif -6 -0.2872986E+00 0.8045064E+02 -0.7714713E+02 -0.2471534E+02 0.2329441E+02 -0.2821228E+00 -0.1887754E+01
+ %fa -6 1 0.6141827725 1.3328220986 203 8518 83 26 1582 87 0.385817227526101
+ %egnv -6 1 1 0.44963138E-01 2.2734220 88 50 1e-11 50.562 1.96
+ %egnv -6 1 2 0.39975932E-01 2.3294475 90 48 1e-11 58.271 2.03
+ %egnv -6 1 3 0.43602852E-01 2.2880089 89 50 1e-11 52.474 1.98
+ %it -5 401 6831 2127 1302 0 0 0 0 0 0
+ %it4 -5 0 0 0 0 0 0 0 0 0 0
+ %Favg -5 8.537 0.810 1.325 2.374 0.073 0.792 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -5 15.199 1.518 2.779 5.839 0.240 1.881 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -5 63.303 6.323 11.576 24.320 1.000 7.834 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -5 0.8651157E+04 0.4089832E+04 0.4478885E+04 -0.5981559E+04 0.1533584E+04 0.1538412E+04 0.2992002E+04
+ %Hnew -5 0.8651211E+04 0.4106159E+04 0.4427728E+04 -0.5966972E+04 0.1552947E+04 0.1538339E+04 0.2993011E+04
+ %Hdif -5 0.5477337E-01 0.1632714E+02 -0.5115747E+02 0.1458638E+02 0.1936273E+02 -0.7250489E-01 0.1008497E+01
+ %fa -5 1 0.6078148188 0.9466996718 203 9032 74 26 1629 88 0.392185181189589
+ %egnv -5 1 1 0.22020686E-01 2.4372908 104 108 1e-11 110.682 2.35
+ %egnv -5 1 2 0.18135798E-01 2.5059099 109 102 1e-11 138.175 2.46
+ %egnv -5 1 3 0.20945337E-01 2.4551323 105 104 1e-11 117.216 2.38
+ %it -4 425 6844 2157 1326 0 0 0 0 0 0
+ %it4 -4 0 0 0 0 0 0 0 0 0 0
+ %Favg -4 8.590 0.817 1.341 2.382 0.075 0.815 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -4 15.030 1.533 2.840 6.062 0.241 1.996 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -4 62.306 6.354 11.771 25.129 1.000 8.273 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -4 0.8583368E+04 0.4091101E+04 0.4427728E+04 -0.5966972E+04 0.1500592E+04 0.1498237E+04 0.3032683E+04
+ %Hnew -4 0.8583295E+04 0.4195410E+04 0.4340990E+04 -0.5972497E+04 0.1494523E+04 0.1498127E+04 0.3026742E+04
+ %Hdif -4 -0.7338959E-01 0.1043085E+03 -0.8673745E+02 -0.5524798E+01 -0.6068206E+01 -0.1098821E+00 -0.5941585E+01
+ %fa -4 1 0.5963913517 1.0761497072 203 9085 84 26 1667 88 0.403608648280112
+ %egnv -4 1 1 0.30188256E-01 2.1647060 72 43 1e-11 71.707 2.14
+ %egnv -4 1 2 0.25911897E-01 2.2091327 74 42 1e-11 85.256 2.22
+ %egnv -4 1 3 0.29014922E-01 2.1763178 73 43 1e-11 75.007 2.16
+ %it -3 399 6806 2123 1314 0 0 0 0 0 0
+ %it4 -3 0 0 0 0 0 0 0 0 0 0
+ %Favg -3 8.812 0.851 1.322 2.317 0.076 0.815 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -3 15.659 1.548 2.832 6.624 0.240 2.042 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -3 65.194 6.446 11.792 27.579 1.000 8.503 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -3 0.8614961E+04 0.4145810E+04 0.4340990E+04 -0.5972497E+04 0.1528241E+04 0.1522367E+04 0.3050051E+04
+ %Hnew -3 0.8614829E+04 0.4253579E+04 0.4279267E+04 -0.5991784E+04 0.1500858E+04 0.1521232E+04 0.3051678E+04
+ %Hdif -3 -0.1322136E+00 0.1077693E+03 -0.6172324E+02 -0.1928734E+02 -0.2738286E+02 -0.1135432E+01 0.1627398E+01
+ %fa -3 1 0.5874913047 1.1413521318 203 9010 81 26 1632 83 0.412508695290138
+ %egnv -3 1 1 0.43832460E-01 2.0903440 114 69 1e-11 47.689 1.93
+ %egnv -3 1 2 0.39086749E-01 2.1258858 115 68 1e-11 54.389 2.00
+ %egnv -3 1 3 0.42539370E-01 2.0996751 114 68 1e-11 49.358 1.95
+ %it -2 390 7072 2166 1328 0 0 0 0 0 0
+ %it4 -2 0 0 0 0 0 0 0 0 0 0
+ %Favg -2 8.913 0.864 1.305 2.441 0.078 0.774 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -2 15.503 1.622 2.583 6.663 0.219 1.881 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -2 70.650 7.390 11.770 30.363 1.000 8.574 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -2 0.8505403E+04 0.4191183E+04 0.4279267E+04 -0.5991784E+04 0.1438738E+04 0.1538052E+04 0.3049948E+04
+ %Hnew -2 0.8505739E+04 0.4375281E+04 0.4115030E+04 -0.5998951E+04 0.1429807E+04 0.1538295E+04 0.3046276E+04
+ %Hdif -2 0.3357357E+00 0.1840982E+03 -0.1642367E+03 -0.7167187E+01 -0.8930730E+01 0.2437728E+00 -0.3671618E+01
+ %fa -2 1 0.5665927626 0.7148119804 203 9311 73 26 1645 82 0.433407237358159
+ %egnv -2 1 1 0.36920538E-01 2.2540348 93 63 1e-11 61.051 2.06
+ %egnv -2 1 2 0.32990080E-01 2.3051535 96 61 1e-11 69.874 2.12
+ %egnv -2 1 3 0.35843769E-01 2.2673925 93 62 1e-11 63.258 2.07
+ %it -1 437 8015 2453 1468 0 0 0 0 0 0
+ %it4 -1 0 0 0 0 0 0 0 0 0 0
+ %Favg -1 8.930 0.880 1.321 2.692 0.078 0.817 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -1 15.259 1.577 2.784 7.084 0.243 1.970 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -1 62.868 6.496 11.469 29.187 1.000 8.115 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -1 0.8457889E+04 0.4133751E+04 0.4115030E+04 -0.5998951E+04 0.1543906E+04 0.1550057E+04 0.3114096E+04
+ %Hnew -1 0.8458023E+04 0.4133266E+04 0.4063185E+04 -0.5982003E+04 0.1572062E+04 0.1549422E+04 0.3122091E+04
+ %Hdif -1 0.1340397E+00 -0.4850214E+00 -0.5184522E+02 0.1694845E+02 0.2815570E+02 -0.6349218E+00 0.7995054E+01
+ %fa -1 1 0.5600319796 0.8745553183 203 10547 84 26 1826 98 0.439968020414765
+ %egnv -1 1 1 0.20042774E-01 2.6194113 175 22 1e-11 130.691 2.44
+ %egnv -1 1 2 0.16816033E-01 2.7014528 181 21 1e-11 160.647 2.54
+ %egnv -1 1 3 0.19149417E-01 2.6407393 176 22 1e-11 137.902 2.46
+ %it 0 472 8210 2550 1532 0 0 0 0 0 0
+ %it4 0 0 0 0 0 0 0 0 0 0 0
+ %Favg 0 8.948 0.890 1.310 2.576 0.079 0.785 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 0 14.994 1.600 2.652 7.319 0.257 1.987 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 0 58.396 6.233 10.328 28.503 1.000 7.738 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 0 0.8333884E+04 0.4060687E+04 0.4063185E+04 -0.5982003E+04 0.1622086E+04 0.1520595E+04 0.3049334E+04
+ %Hnew 0 0.8334040E+04 0.4222592E+04 0.3927838E+04 -0.5981661E+04 0.1589964E+04 0.1519281E+04 0.3056026E+04
+ %Hdif 0 0.1560512E+00 0.1619053E+03 -0.1353465E+03 0.3424912E+00 -0.3212229E+02 -0.1314248E+01 0.6691298E+01
+ %fa 0 1 0.5423157268 0.8555154010 203 10854 94 26 1910 98 0.457684273243757
+ %egnv 0 1 1 0.21789647E-01 2.0954160 183 71 1e-11 96.166 2.28
+ %egnv 0 1 2 0.18398977E-01 2.1337724 187 70 1e-11 115.972 2.38
+ %egnv 0 1 3 0.20852837E-01 2.1054654 184 71 1e-11 100.968 2.31
+ >EndForceAcceptance
+ >BeginILDGwrite
+ ildg-write file bqcd.320.lime
+ ildg-write precision 64
+ ildg-write bytes 147456
+ ildg-write cksum 623338568
+ ildg-write lfn bqcd-restart bqcd.320.lime 623338568 147456 320 1 0
+ >EndILDGwrite
+ >BeginFooter
+ Date 2011-09-22 19:10:06.135
+ Seed -1
+ CPU-Time 289.6 s on 1 CPUs
+ >BeginTiming
+ Performance
+ region #calls time mean min max Total
+ s Mflop/s Mflop/s Mflop/s Gflop/s
+
+ d_xf 490542 8.81 2052.93 2052.93 2052.93 2.05
+ d_xb 0
+ d_yf 490542 11.18 1751.53 1751.53 1751.53 1.75
+ d_yb 0
+ d_zf 490542 10.92 1794.52 1794.52 1794.52 1.79
+ d_zb 0
+ d_t 490542 10.37 1888.65 1888.65 1888.65 1.89
+ d_fb 0
+ d_dag_fb 0
+ d_xyzt 0
+ sc2_projection 490542 7.45 606.95 606.95 606.95 0.61
+ D_TOTAL 490542 50.16 1622.47 1622.47 1622.47 1.62
+ d_dd 0
+ d_eo 0
+ MTDAGMT 112768 65.77 1643.41 1643.41 1643.41 1.64
+ CG 2030 54.14 1641.78 1641.78 1641.78 1.64
+ CG_DD 0
+ CG_HH 0
+ cg_global_sum 0
+ global_sum 0
+ global_sum_vec 0
+ sc_zero 14060 0.46
+ sc_copy 121948 0.45
+ sc_scale 9902 0.05 633.68 633.68 633.68 0.63
+ sc_norm2 42693 0.18 1457.14 1457.14 1457.14 1.46
+ sc_dot 49276 0.25 1220.69 1220.69 1220.69 1.22
+ sc_axpy 97908 0.43 1392.39 1392.39 1392.39 1.39
+ sc_xpby 340679 1.62 1291.99 1291.99 1291.99 1.29
+ sc_axpby 74386 0.54 1278.92 1278.92 1278.92 1.28
+ sc_cdotc 29180 0.17 2084.55 2084.55 2084.55 2.08
+ sc_caxpy 1940 0.02 1489.92 1489.92 1489.92 1.49
+ sc_caxpy2 1940 0.03 1489.83 1489.83 1489.83 1.49
+ sc_cax2 1980 0.02 3041.09 3041.09 3041.09 3.04
+ clover_init 2403 4.72
+ clover_mult_a 0
+ clover_mult_ao 478632 18.53 1825.14 1825.14 1825.14 1.83
+ clover_mult_b 35560 1.40 1799.69 1799.69 1799.69 1.80
+ clover_dsd 410 4.76
+ clover_dsf 0
+ hmc_init 10 0.07
+ hmc_init_p 10 0.01
+ hmc_u 6400 6.65
+ hmc_momenta 0
+ hmc_phi 10 12.70
+ hmc_h_old 10 12.74
+ hmc_backup 10 0.01
+ hmc_half_step0 0
+ hmc_half_step1 0
+ hmc_xbound_g 10541 0.00
+ hmc_steps 8540 266.77
+ hmc_h_new 10 0.02
+ hmc_rest 10 0.01
+ HMC 10 286.29
+ h_mult_a 0
+ h_mult_b 0
+ h_mult_c 0
+ dsg 6410 8.38
+ dsf 2020 36.03
+ plaquette 21 0.00 +Inf +Inf +Inf +Inf
+ cooling 0
+ ran_gauss_volh 128 0.01
+ MTDAGMT_r4 0
+ dsig 1610 10.54
+ rectangle 20 0.04 1244.90 1244.90 1244.90 1.24
+ chair 0
+ parallelogram 0
+ stout_smear 1601 4.02 1560.69 1560.69 1560.69 1.56
+ stout_diffe 2540 13.62 2156.77 2156.77 2156.77 2.16
+ clover_bsa_w 7940 1.50 1243.90 1243.90 1243.90 1.24
+ clover_dsd_w 1640 1.24 1381.71 1381.71 1381.71 1.38
+ clover_d_w 5900 15.46 1953.13 1953.13 1953.13 1.95
+ dsf_at_bt 3970 1.58 1188.63 1188.63 1188.63 1.19
+ dsf_xyztfb_w 3970 2.30 1757.28 1757.28 1757.28 1.76
+ dsf_sum 3970 6.87 1134.63 1134.63 1134.63 1.13
+ dsf_w2gen 2540 28.96 1933.72 1933.72 1933.72 1.93
+ cgm 260 10.18 1603.75 1603.75 1603.75 1.60
+ cg_ritz 82 4.41 1657.54 1657.54 1657.54 1.66
+ cg_mix 0
+ bicgstab 0
+ bicgstab_mix 0
+ ddbqnohat 0
+ unprec_mmul 0
+ unprec_dsf 0
+ dsf_un 0
+ dsf_mtmp 2020 102.46
+ cg_mre_mtmp 2020 57.25
+ dsf_wmul_r8 2020 0.52
+ dsf_wdag_r8 410 0.22
+ integrator 10 273.44
+ bagel_d 0
+ TOTAL 1 289.59
+
+ Performance
+ region #calls time mean min max Total
+ s MByte/s MByte/s MByte/s GByte/s
+
+ xbound_g 0
+ xbound_sc 0
+ xbound_sc2 0
+ u_read_bqcd 0
+ u_write_bqcd 0
+ u_read_ildg 0
+ u_write_ildg 1 0.00 +Inf +Inf +Inf +Inf
+ >EndTiming
+ >EndFooter
+ >EndJob
diff --git a/src/data/bqcd.500.input b/src/data/bqcd.500.input
new file mode 100644
index 0000000000000000000000000000000000000000..b8edda39936a3d6f6876fe5c05f9d239f344b53d
--- /dev/null
+++ b/src/data/bqcd.500.input
@@ -0,0 +1,84 @@
+comment "Test for NF = 3 SLOC with SF boundary condition"
+run 500
+lattice 4 4 4 4
+boundary_conditions_fermions 1 1 1 -1
+boundary_sf 1
+process_mapping 1 2 3 4
+processes 1 1 1 2
+
+gauge_action IWASAKI
+beta 2.6
+fermi_action SLOC
+kappa 0.125
+kappa_strange 0.125
+csw 1.00
+n_stout 1
+alpha 0.1
+
+hmc_test 0
+hmc_integrator1 2MNSTS
+hmc_integrator2 2MNSTS
+hmc_integrator3 2MNSTS
+hmc_integrator4 2MNSTS
+
+hmc_model F
+hmc_mpf_mass 2
+hmc_mpf_rhmc_s 2
+hmc_hkappa 1
+hmc_rho 0.12
+hmc_accept_first 5
+hmc_trajectory_length 1.0
+
+hmc_steps 5
+hmc_m_scale 2
+hmc_m_scale2 2
+hmc_m_scale3 2
+
+hmc_dsf1_mtmp 3
+hmc_dsf2_mtmp 2
+hmc_dsf_ers 1
+hmc_dsd 2
+hmc_dsig 3
+hmc_dsg 4
+
+start_configuration hot
+io_restart_format ildg
+#start_ildg_file qcdsf.699.00550.lime
+
+start_random 319503
+mc_steps 10
+mc_total_steps 20000
+mc_save_frequency 0
+
+solver_rest 1e-11
+solver_rest_md 1e-9
+solver_rest_cg_ritz 1e-11
+solver_maxiter 1200000
+solver_stopping_criterion 1
+solver_ignore_no_convergence 0
+solver_mre_vectors 5
+solver_check_solution 0
+solver_outer_solver cg
+solver_inner_solver cg
+solver_outer_steps 0
+
+measure_traces 1
+measure_minmax 1
+measure_polyakov_loop 1
+measure_rhmc_forces 0
+measure_cooling_list "cool.list"
+measure_schrpcac 2
+
+io_conf_format "ildg"
+ildg_filename_prefix "sloc_sf_nf2p1"
+ildg_filename_extension "lime"
+ildg_precision 64
+ildg_template_ensemble "qcdsf-ensemble-05.xml"
+ildg_template_conf "qcdsf-configuration-04.xml"
+ildg_markov_chain_uri "mc://ldg/qcd_collaboration/sloc_nf2p1/b2p60kp125000kp125000-4x4"
+ildg_data_lfn_path "lfn://ldg/qcd_collaboration/sloc_nf2p1/b2p60kp125000kp125000-4x4"
+ildg_participant_name "Your Name"
+ildg_participant_institution "Your Institute"
+ildg_machine_name "fast_runner"
+ildg_machine_institution "Your Computing Centre"
+ildg_machine_type "fast_computer"
diff --git a/src/data/bqcd.500.output b/src/data/bqcd.500.output
new file mode 100644
index 0000000000000000000000000000000000000000..cf77a9d7c15f485d8918b7904b87515687a4197e
--- /dev/null
+++ b/src/data/bqcd.500.output
@@ -0,0 +1,430 @@
+ >BeginJob
+ >BeginHeader
+ Comment Test for NF = 3 SLOC with SF boundary condition
+ Program bqcd 4.0.0 (revision 324)
+ Version_of_D 100
+ Communication MPI (sc:immediate) (g:immediate)
+ RandomNumbers ranlux-3.2 level 2
+ Run 500
+ Job 1
+ Host m500
+ Date 2011-09-21 14:58:36.031
+ L 4 4 4 4
+ DDL 1 1 1 1
+ NPE 1 1 1 2
+ process_mapping 1 2 3 4
+ bc_fermions 1 1 1 -1
+ gamma_index 1 2 3 4
+ Gauge Action IWASAKI
+ Fermi Action SLOC
+ tilde M 1 - T^-1 D T^-1 D
+ Gamma notation BQCD
+ eo-prec DeoDoe
+ BoundaryCondition schr
+ Threads 1
+ Start 0
+ Seed 319503
+ Swap_seq 0
+ N_force 5
+ N_traj 10
+ N_save 0
+ N_temper 1
+ beta_1 2.6
+ c0_1 0.0
+ c1_1 0.0
+ c2_1 0.0
+ c3_1 0.0
+ u04_1 0.0
+ kappa_1 0.125
+ kappa_strange_1 0.125
+ csw_1 1.00
+ csw_kappa_1 0.125000000000000
+ csw_kappa_strange_1 0.125000000000000
+ n_stout_1 1
+ alpha_1 0.1
+ theta_1 0.0
+ chemi_1 0.0
+ h_1 0.0
+ rho_1 0.12
+ rho2_1 0.0
+ rho3_1 0.0
+ rho4_1 0.0
+ traj_length_1 1.0
+ tau_1 0.200000000000000
+ N_tau_1 5 2MNSTS ers
+ m_scale_1 2 2MNSTS eo2 dat
+ m_scale2_1 2 2MNSTS eo1 ig
+ m_scale3_1 2 2MNSTS g
+ hkappa 1
+ mpf_eo[m,l,s]: 2 0 2
+ mpf_dd[m,l,s]: 0 0 0
+ mpf_hh[m,l,s]: 0 0 0
+ HMC_model F
+ REAL_kind 8
+ Solver_outer cg
+ Solver_inner cg
+ CG_rest 1e-11
+ CG_rest_md 1e-9
+ CG_stopping_criterion 1
+ CG_outer_steps 0
+ MRE_vectors 5
+ Fullsolver eo
+ >EndHeader
+ >BeginForceAcceptance
+ T%fa i_fa e PlaqEnergy exp(-Delta_H) CGcalls CGitTot CGitMax CGMcalls CGMitTotCGMitMax Plaquette
+ T%it traj iter_SF iter_F1 iter_F2 iter_F3 iter_F4 iter_F5 iter_F6 iter_F7 iter_F8 iter_F9
+ %it -4 140 1813 676 543 0 0 0 0 0 0
+ %it4 -4 0 0 0 0 0 0 0 0 0 0
+ T%Favg traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
+ T%Fmax traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
+ T%Frat traj F_gauge F_impg F_det F_F1 F_F2 F_F3 F_F4 F_F5 F_F6 F_F7 F_F8 F_F9
+ %Favg -4 11.969 1.907 0.133 1.015 0.093 0.343 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -4 23.962 3.999 0.390 3.814 0.305 1.098 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -4 78.527 13.105 1.277 12.500 1.000 3.598 0.000 0.000 0.000 0.000 0.000 0.000
+ T%Hold traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
+ T%Hnew traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
+ T%Hdif traj H_total H_generator H_gauge H_det H_fermion_1 H_fermion_2 H_fermion_3
+ %Hold -4 0.1353317E+05 0.3328837E+04 0.1044373E+05 -0.6340852E+04 0.1567305E+04 0.1517629E+04 0.3016521E+04
+ %Hnew -4 0.1353309E+05 0.6587449E+04 0.7122485E+04 -0.6333897E+04 0.1624378E+04 0.1514455E+04 0.3018221E+04
+ %Hdif -4 -0.7839827E-01 0.3258611E+04 -0.3321243E+04 0.6954870E+01 0.5707333E+02 -0.3174790E+01 0.1700152E+01
+ %fa -4 1 0.6403763201 1.0815533263 203 2513 24 26 659 31 0.359623679903077
+ T%egnv traj type mid min max it_min it_max tol condi n_opt
+ %egnv -4 1 1 0.28834255 1.5954759 208 201 1e-11 5.533 0.86
+ %egnv -4 1 2 0.24655254 1.6618200 184 174 1e-11 6.740 0.95
+ %it -3 158 1953 721 604 0 0 0 0 0 0
+ %it4 -3 0 0 0 0 0 0 0 0 0 0
+ %Favg -3 12.553 2.201 0.120 0.821 0.091 0.326 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -3 25.092 4.704 0.354 2.951 0.336 1.095 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -3 74.652 13.994 1.054 8.780 1.000 3.259 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -3 0.1012980E+05 0.3253521E+04 0.7122485E+04 -0.6333897E+04 0.1485841E+04 0.1560926E+04 0.3040919E+04
+ %Hnew -3 0.1012977E+05 0.4892391E+04 0.5466292E+04 -0.6336889E+04 0.1505175E+04 0.1559668E+04 0.3043132E+04
+ %Hdif -3 -0.2603294E-01 0.1638870E+04 -0.1656193E+04 -0.2992339E+01 0.1933409E+02 -0.1258284E+01 0.2213295E+01
+ %fa -3 1 0.5095041109 1.0263747607 203 2700 26 26 736 35 0.490495889066937
+ %egnv -3 1 1 0.22292913 1.5352529 136 117 1e-11 6.887 0.96
+ %egnv -3 1 2 0.18196947 1.5951492 114 106 1e-11 8.766 1.09
+ %it -2 180 2148 814 694 0 0 0 0 0 0
+ %it4 -2 0 0 0 0 0 0 0 0 0 0
+ %Favg -2 13.333 2.602 0.110 0.790 0.077 0.299 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -2 26.488 5.253 0.347 2.737 0.268 0.922 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -2 98.896 19.611 1.296 10.218 1.000 3.442 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -2 0.8551774E+04 0.3268872E+04 0.5466292E+04 -0.6336889E+04 0.1512332E+04 0.1487833E+04 0.3153335E+04
+ %Hnew -2 0.8551737E+04 0.4281175E+04 0.4423581E+04 -0.6342926E+04 0.1546757E+04 0.1487999E+04 0.3155153E+04
+ %Hdif -2 -0.3675218E-01 0.1012303E+04 -0.1042711E+04 -0.6036714E+01 0.3442507E+02 0.1658554E+00 0.1817786E+01
+ %fa -2 1 0.4221582027 1.0374358890 203 2991 29 26 845 40 0.577841797250672
+ %egnv -2 1 1 0.17321410 1.5045685 83 101 1e-11 8.686 1.08
+ %egnv -2 1 2 0.13402399 1.5608876 84 99 1e-11 11.646 1.23
+ %it -1 200 2403 924 791 0 0 0 0 0 0
+ %it4 -1 0 0 0 0 0 0 0 0 0 0
+ %Favg -1 13.738 2.935 0.102 0.787 0.074 0.278 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax -1 26.693 5.888 0.314 2.626 0.246 0.944 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat -1 108.583 23.952 1.278 10.682 1.000 3.838 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold -1 0.7535292E+04 0.3284612E+04 0.4423581E+04 -0.6342926E+04 0.1567070E+04 0.1524604E+04 0.3078351E+04
+ %Hnew -1 0.7535287E+04 0.3855255E+04 0.3821653E+04 -0.6352040E+04 0.1607377E+04 0.1521737E+04 0.3081305E+04
+ %Hdif -1 -0.5262236E-02 0.5706422E+03 -0.6019280E+03 -0.9113573E+01 0.4030737E+02 -0.2867415E+01 0.2954164E+01
+ %fa -1 1 0.3669784832 1.0052761059 203 3360 33 26 958 43 0.633021516761825
+ %egnv -1 1 1 0.14037653 1.4771079 51 125 1e-11 10.522 1.18
+ %egnv -1 1 2 0.10385173 1.5298162 53 131 1e-11 14.731 1.34
+ %it 0 210 2417 934 811 0 0 0 0 0 0
+ %it4 0 0 0 0 0 0 0 0 0 0 0
+ %Favg 0 13.894 3.116 0.095 0.703 0.073 0.265 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 0 27.319 6.172 0.285 2.353 0.258 0.772 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 0 105.926 23.930 1.105 9.124 1.000 2.995 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 0 0.6858386E+04 0.3324775E+04 0.3821653E+04 -0.6352040E+04 0.1533584E+04 0.1538412E+04 0.2992002E+04
+ %Hnew 0 0.6858434E+04 0.3737309E+04 0.3405203E+04 -0.6355276E+04 0.1544475E+04 0.1536458E+04 0.2990265E+04
+ %Hdif 0 0.4775611E-01 0.4125340E+03 -0.4164499E+03 -0.3236873E+01 0.1089132E+02 -0.1953300E+01 -0.1737470E+01
+ %fa 0 1 0.3308996721 0.9533662705 203 3387 36 26 985 44 0.669100327909929
+ %egnv 0 1 1 0.13398230 1.4625602 66 172 1e-11 10.916 1.20
+ %egnv 0 1 2 0.98898742E-01 1.5141982 69 144 1e-11 15.311 1.36
+ >EndForceAcceptance
+ >BeginMC
+ T%mc traj e f PlaqEnergy exp(-Delta_H) Acc CGcalls CGitTot CGitMax CGMcalls CGMitTotCGMitMax Plaquette
+ T%pr traj Plaquette PlaquetteS PlaquetteT Rectangle RectangleS RectangleT
+ %it 1 217 2558 989 844 0 0 0 0 0 0
+ %it4 1 0 0 0 0 0 0 0 0 0 0
+ %Favg 1 13.872 3.229 0.092 0.681 0.067 0.251 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 1 26.320 6.386 0.294 2.050 0.237 0.731 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 1 111.051 26.945 1.240 8.651 1.000 3.083 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 1 0.6439580E+04 0.3358143E+04 0.3405203E+04 -0.6355276E+04 0.1500592E+04 0.1498237E+04 0.3032683E+04
+ %Hnew 1 0.6439607E+04 0.3598377E+04 0.3160033E+04 -0.6359956E+04 0.1502431E+04 0.1497283E+04 0.3041440E+04
+ %Hdif 1 0.2629737E-01 0.2402337E+03 -0.2451698E+03 -0.4679659E+01 0.1839244E+01 -0.9537493E+00 0.8756494E+01
+ %mc 1 1 1 0.3308996721 0.9740453962 0 203 3583 36 26 1025 47 0.669100327909929
+ %pr 1 0.6691003279099 0.7103594558126 0.6278412000072 0.4361414142395 0.5404177165891 0.3318651118898
+ %egnv 1 1 1 0.13398230 1.4625602 66 172 1e-11 10.916 1.20
+ %egnv 1 1 2 0.98898742E-01 1.5141982 69 144 1e-11 15.311 1.36
+ T%tr traj e f Re(pbp) Im(pbp) Re(p5p) -Im(p5p) PionNorm CGiter
+ %tr 1 1 1 0.9999381170 0.6847212568E-02 0.2858814583E-01 -0.2984331532E-13 1.339078457 42
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 1 1 1 0.3016057535E-01 -0.4070000346E-01
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 1 1 1 0 0.100011 0.3308996721
+ %Qc 1 1 1 1 -0.165165 0.0739625797
+ %Qc 1 1 1 2 -0.205936 0.0319064791
+ %Qc 1 1 1 3 -0.183866 0.0220630186
+ %Qc 1 1 1 4 -0.048702 0.0148323759
+ %Qc 1 1 1 5 0.002249 0.0085176063
+ %Qc 1 1 1 6 0.001282 0.0058336262
+ %Qc 1 1 1 7 0.000569 0.0041532745
+ %Qc 1 1 1 8 0.000282 0.0029480171
+ %Qc 1 1 1 9 0.000156 0.0020859537
+ %Qc 1 1 1 10 0.000092 0.0014810796
+ %Qc 1 1 1 20 0.000001 0.0000991833
+ %Qc 1 1 1 30 0.000000 0.0000244502
+ %Qc 1 1 1 40 0.000000 0.0000099754
+ %Qc 1 1 1 50 0.000000 0.0000046650
+ >EndCooling
+ %it 2 211 2556 958 812 0 0 0 0 0 0
+ %it4 2 0 0 0 0 0 0 0 0 0 0
+ %Favg 2 13.828 3.195 0.093 0.650 0.062 0.268 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 2 27.707 6.262 0.271 2.115 0.222 0.879 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 2 124.799 28.205 1.219 9.526 1.000 3.958 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 2 0.6486785E+04 0.3312116E+04 0.3405203E+04 -0.6355276E+04 0.1472883E+04 0.1513182E+04 0.3138677E+04
+ %Hnew 2 0.6486778E+04 0.3551641E+04 0.3164872E+04 -0.6358044E+04 0.1473591E+04 0.1512692E+04 0.3142025E+04
+ %Hdif 2 -0.6510001E-02 0.2395252E+03 -0.2403305E+03 -0.2767806E+01 0.7084518E+00 -0.4897941E+00 0.3348034E+01
+ %mc 2 1 1 0.3089093866 1.0065312371 1 203 3550 36 26 987 44 0.691090613380691
+ %pr 2 0.6910906133807 0.7292952490493 0.6528859777121 0.4664056383772 0.5594542291118 0.3733570476425
+ %egnv 2 1 1 0.11964747 1.4555103 44 190 1e-11 12.165 1.25
+ %egnv 2 1 2 0.84075806E-01 1.5056874 44 150 1e-11 17.909 1.44
+ %tr 2 1 1 0.9626272480 0.6054419022E-02 -0.1158633808E-01 0.2479960681E-12 1.291148724 43
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 2 1 1 0.4925754427E-01 -0.1780255773E-01
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 2 1 1 0 0.018397 0.3089093866
+ %Qc 2 1 1 1 -0.240196 0.0647824863
+ %Qc 2 1 1 2 -0.107894 0.0261583439
+ %Qc 2 1 1 3 -0.002293 0.0169589792
+ %Qc 2 1 1 4 0.002243 0.0132628318
+ %Qc 2 1 1 5 0.000698 0.0115473548
+ %Qc 2 1 1 6 0.000064 0.0104928863
+ %Qc 2 1 1 7 -0.000101 0.0097335443
+ %Qc 2 1 1 8 -0.000110 0.0091403237
+ %Qc 2 1 1 9 -0.000086 0.0086579321
+ %Qc 2 1 1 10 -0.000062 0.0082578917
+ %Qc 2 1 1 20 -0.000001 0.0065495476
+ %Qc 2 1 1 30 0.000000 0.0063734802
+ %Qc 2 1 1 40 0.000000 0.0063643737
+ %Qc 2 1 1 50 0.000000 0.0063639128
+ >EndCooling
+ %it 3 219 2653 995 848 0 0 0 0 0 0
+ %it4 3 0 0 0 0 0 0 0 0 0 0
+ %Favg 3 13.701 3.223 0.093 0.634 0.067 0.256 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 3 27.302 6.219 0.268 2.011 0.230 0.718 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 3 118.859 27.076 1.165 8.755 1.000 3.125 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 3 0.6288030E+04 0.3274797E+04 0.3164872E+04 -0.6358044E+04 0.1538466E+04 0.1598029E+04 0.3069910E+04
+ %Hnew 3 0.6288033E+04 0.3520550E+04 0.2930023E+04 -0.6360813E+04 0.1530841E+04 0.1597144E+04 0.3070288E+04
+ %Hdif 3 0.2170062E-02 0.2457526E+03 -0.2348488E+03 -0.2768719E+01 -0.7625328E+01 -0.8851877E+00 0.3776214E+00
+ %mc 3 1 1 0.2877975361 0.9978322904 1 203 3685 37 26 1030 47 0.712202463855429
+ %pr 3 0.7122024638554 0.7457785420516 0.6786263856593 0.4909658922262 0.5805268609120 0.4014049235404
+ %egnv 3 1 1 0.10359238 1.4544668 52 90 1e-11 14.040 1.32
+ %egnv 3 1 2 0.70809733E-01 1.5044999 53 87 1e-11 21.247 1.53
+ %tr 3 1 1 0.9979471357 -0.1349950405E-01 -0.1656489454E-01 -0.1794951629E-12 1.332780917 46
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 3 1 1 -0.3301207588E-02 0.2980887108E-01
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 3 1 1 0 -0.140438 0.2877975361
+ %Qc 3 1 1 1 -0.129074 0.0562804469
+ %Qc 3 1 1 2 -0.026330 0.0212599437
+ %Qc 3 1 1 3 -0.003973 0.0146786235
+ %Qc 3 1 1 4 -0.000766 0.0120516379
+ %Qc 3 1 1 5 -0.000084 0.0104835686
+ %Qc 3 1 1 6 0.000129 0.0093645081
+ %Qc 3 1 1 7 0.000171 0.0085185980
+ %Qc 3 1 1 8 0.000148 0.0078720753
+ %Qc 3 1 1 9 0.000108 0.0073775620
+ %Qc 3 1 1 10 0.000074 0.0069954100
+ %Qc 3 1 1 20 0.000021 0.0038478929
+ %Qc 3 1 1 30 0.000000 0.0007432523
+ %Qc 3 1 1 40 0.000000 0.0001803892
+ %Qc 3 1 1 50 0.000000 0.0000521749
+ >EndCooling
+ %it 4 228 2705 1064 892 0 0 0 0 0 0
+ %it4 4 0 0 0 0 0 0 0 0 0 0
+ %Favg 4 13.786 3.308 0.091 0.625 0.066 0.240 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 4 27.127 6.298 0.257 2.039 0.227 0.669 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 4 119.667 27.781 1.133 8.995 1.000 2.953 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 4 0.5939915E+04 0.3344712E+04 0.2930023E+04 -0.6360813E+04 0.1470273E+04 0.1503656E+04 0.3052064E+04
+ %Hnew 4 0.5939903E+04 0.3419307E+04 0.2857422E+04 -0.6364466E+04 0.1468675E+04 0.1502515E+04 0.3056452E+04
+ %Hdif 4 -0.1205339E-01 0.7459468E+02 -0.7260170E+02 -0.3653531E+01 -0.1597750E+01 -0.1141256E+01 0.4387499E+01
+ %mc 4 1 1 0.2794366907 1.0121263279 1 203 3808 39 26 1081 48 0.720563309324562
+ %pr 4 0.7205633093246 0.7568515371242 0.6842750815249 0.5085721133937 0.6007310495502 0.4164131772373
+ %egnv 4 1 1 0.93922095E-01 1.4387702 109 165 1e-11 15.319 1.36
+ %egnv 4 1 2 0.64538209E-01 1.4842517 112 157 1e-11 22.998 1.57
+ %tr 4 1 1 0.9638769916 0.2222270705E-02 0.1376794116E-01 0.7289365870E-13 1.368055721 47
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 4 1 1 -0.9120799282E-01 -0.4153638231E-01
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 4 1 1 0 0.055734 0.2794366907
+ %Qc 4 1 1 1 0.003262 0.0517110339
+ %Qc 4 1 1 2 -0.004106 0.0187900157
+ %Qc 4 1 1 3 -0.004067 0.0140341068
+ %Qc 4 1 1 4 -0.002966 0.0122466265
+ %Qc 4 1 1 5 -0.001872 0.0111330628
+ %Qc 4 1 1 6 -0.001118 0.0102962633
+ %Qc 4 1 1 7 -0.000651 0.0096219791
+ %Qc 4 1 1 8 -0.000380 0.0090631132
+ %Qc 4 1 1 9 -0.000226 0.0085939522
+ %Qc 4 1 1 10 -0.000137 0.0081968897
+ %Qc 4 1 1 20 0.000000 0.0065305824
+ %Qc 4 1 1 30 0.000000 0.0063895949
+ %Qc 4 1 1 40 0.000000 0.0063736269
+ %Qc 4 1 1 50 0.000000 0.0063688610
+ >EndCooling
+ %it 5 229 2604 1021 871 0 0 0 0 0 0
+ %it4 5 0 0 0 0 0 0 0 0 0 0
+ %Favg 5 13.769 3.318 0.089 0.623 0.064 0.245 0.000 0.000 0.000 0.000 0.000 0.000
+ %Fmax 5 27.575 6.460 0.245 1.973 0.211 0.736 0.000 0.000 0.000 0.000 0.000 0.000
+ %Frat 5 130.700 30.619 1.161 9.352 1.000 3.489 0.000 0.000 0.000 0.000 0.000 0.000
+ %Hold 5 0.5885801E+04 0.3322794E+04 0.2857422E+04 -0.6364466E+04 0.1482208E+04 0.1552593E+04 0.3035250E+04
+ %Hnew 5 0.5885814E+04 0.3346498E+04 0.2816848E+04 -0.6364621E+04 0.1487581E+04 0.1552820E+04 0.3046688E+04
+ %Hdif 5 0.1335233E-01 0.2370463E+02 -0.4057337E+02 -0.1545538E+00 0.5372505E+01 0.2261831E+00 0.1143796E+02
+ %mc 5 1 1 0.2754950257 0.9867364154 1 203 3665 40 26 1060 48 0.724504974250426
+ %pr 5 0.7245049742504 0.7597969141072 0.6892130343936 0.5138221231837 0.6064981158920 0.4211461304753
+ %egnv 5 1 1 0.11162166 1.4403753 126 100 1e-11 12.904 1.28
+ %egnv 5 1 2 0.80293203E-01 1.4859246 161 99 1e-11 18.506 1.46
+ %tr 5 1 1 1.006534943 0.9327805670E-02 -0.7410992775E-02 0.6217191114E-13 1.377875934 44
+ T%pl traj e f Re(Polyakov_Loop) Im(Polyakov_Loop)
+ %pl 5 1 1 -0.6897297645E-02 -0.6018785038E-01
+ >BeginCooling
+ T%Qc traj e f i_cool Q_cool PlaqEnergy
+ %Qc 5 1 1 0 -0.013628 0.2754950257
+ %Qc 5 1 1 1 -0.006776 0.0483737677
+ %Qc 5 1 1 2 0.006194 0.0173583212
+ %Qc 5 1 1 3 0.002384 0.0125600902
+ %Qc 5 1 1 4 0.000844 0.0106245124
+ %Qc 5 1 1 5 0.000338 0.0094371793
+ %Qc 5 1 1 6 0.000156 0.0085793905
+ %Qc 5 1 1 7 0.000084 0.0079107498
+ %Qc 5 1 1 8 0.000054 0.0073601425
+ %Qc 5 1 1 9 0.000041 0.0068781819
+ %Qc 5 1 1 10 0.000036 0.0064257806
+ %Qc 5 1 1 20 0.000005 0.0014611870
+ %Qc 5 1 1 30 0.000000 0.0002225256
+ %Qc 5 1 1 40 0.000000 0.0000446238
+ %Qc 5 1 1 50 0.000000 0.0000110227
+ >EndCooling
+ >EndMC
+ >BeginILDGwrite
+ ildg-write file bqcd.500.lime
+ ildg-write precision 64
+ ildg-write bytes 147456
+ ildg-write cksum 3744829595
+ ildg-write lfn bqcd-restart bqcd.500.lime 3744829595 147456 500 1 5
+ >EndILDGwrite
+ >BeginFooter
+ Date 2011-09-21 14:59:40.073
+ Seed -1
+ CPU-Time 64.0 s on 2 CPUs
+ >BeginTiming
+ Performance
+ region #calls time mean min max Total
+ s Mflop/s Mflop/s Mflop/s Gflop/s
+
+ d_xf 283140 1.82 2871.87 2867.91 2875.83 5.74
+ d_xb 0
+ d_yf 283140 1.48 3820.61 3805.19 3836.16 7.64
+ d_yb 0
+ d_zf 283140 1.35 4191.68 4179.34 4204.11 8.38
+ d_zb 0
+ d_t 283140 1.50 3781.04 3747.21 3815.48 7.56
+ d_fb 0
+ d_dag_fb 0
+ d_xyzt 0
+ sc2_projection 283140 1.68 778.82 776.27 781.38 1.56
+ D_TOTAL 283140 13.64 1721.13 1720.88 1721.38 3.44
+ d_dd 0
+ d_eo 0
+ MTDAGMT 53162 13.69 1861.20 1858.69 1863.72 3.72
+ CG 2083 9.94 1824.37 1822.81 1825.93 3.65
+ CG_DD 0
+ CG_HH 0
+ cg_global_sum 0
+ global_sum 87814 0.15
+ global_sum_vec 75308 0.23
+ sc_zero 39914 0.33
+ sc_copy 75915 0.11
+ sc_scale 9882 0.01 2335.55 2168.70 2530.21 4.67
+ sc_norm2 36347 0.04 3146.14 3018.84 3284.64 6.29
+ sc_dot 42996 0.02 5621.18 5284.19 6004.08 11.24
+ sc_axpy 214318 0.07 8838.92 8664.21 9020.82 17.68
+ sc_xpby 167999 0.06 8325.09 8193.12 8461.37 16.65
+ sc_axpby 188863 0.08 11377.48 9670.86 13815.51 22.75
+ sc_cdotc 29200 0.01 14951.65 12815.54 17942.27 29.90
+ sc_caxpy 1940 0.00 +Inf +Inf +Inf +Inf
+ sc_caxpy2 1940 0.00 23838.72 23838.72 23838.72 47.68
+ sc_cax2 1980 0.01 2704.26 2704.26 2704.26 5.41
+ clover_init 2014 1.70
+ clover_mult_a 10 0.00 +Inf +Inf +Inf +Inf
+ clover_mult_ao 252793 3.18 2808.82 2787.78 2830.19 5.62
+ clover_mult_b 50360 0.76 2329.05 2316.94 2341.28 4.66
+ clover_dsd 410 3.54
+ clover_dsf 0
+ hmc_init 10 0.01
+ hmc_init_p 10 0.01
+ hmc_u 6400 3.09
+ hmc_momenta 0
+ hmc_phi 10 0.49
+ hmc_h_old 10 0.51
+ hmc_backup 10 0.00
+ hmc_half_step0 0
+ hmc_half_step1 0
+ hmc_xbound_g 11367 0.33
+ hmc_steps 8540 58.17
+ hmc_h_new 10 0.01
+ hmc_rest 10 0.00
+ HMC 10 62.00
+ h_mult_a 0
+ h_mult_b 0
+ h_mult_c 0
+ dsg 6410 3.50
+ dsf 2020 16.78
+ plaquette 22 0.00 1828.99 1828.99 1828.99 3.66
+ cooling 5 0.31
+ ran_gauss_volh 138 0.03
+ MTDAGMT_r4 0
+ dsig 1610 6.91
+ rectangle 21 0.01 2011.58 2011.50 2011.66 4.02
+ chair 0
+ parallelogram 0
+ stout_smear 1607 1.66 1895.16 1894.56 1895.75 3.79
+ stout_diffe 3360 7.49 2594.48 2589.47 2599.51 5.19
+ clover_bsa_w 20260 1.70 1403.48 1403.07 1403.89 2.81
+ clover_dsd_w 820 0.38 1125.27 1123.79 1126.75 2.25
+ clover_d_w 5900 7.56 1997.19 1995.61 1998.77 3.99
+ dsf_at_bt 10130 1.84 1303.54 1301.76 1305.31 2.61
+ dsf_xyztfb_w 10130 2.99 1727.10 1705.72 1749.03 3.45
+ dsf_sum 10130 8.71 1141.10 1141.04 1141.17 2.28
+ dsf_w2gen 2540 12.43 2250.96 2247.97 2253.95 4.50
+ cgm 260 3.46 1727.09 1726.84 1727.34 3.45
+ cg_ritz 62 2.01 1823.58 1823.58 1823.59 3.65
+ cg_mix 0
+ bicgstab 0
+ bicgstab_mix 0
+ ddbqnohat 0
+ unprec_mmul 0
+ unprec_dsf 0
+ dsf_un 0
+ dsf_mtmp 2020 31.83
+ cg_mre_mtmp 2020 11.04
+ dsf_wmul_r8 2020 0.27
+ dsf_wdag_r8 410 0.07
+ integrator 10 61.47
+ bagel_d 0
+ TOTAL 1 64.04
+
+ Performance
+ region #calls time mean min max Total
+ s MByte/s MByte/s MByte/s GByte/s
+
+ xbound_g 11368 0.29 2860.97 2721.64 3015.33 5.72
+ xbound_sc 60780 0.11 7046.99 6669.74 7469.47 14.09
+ xbound_sc2 283140 0.67 2594.86 2581.38 2608.47 5.19
+ u_read_bqcd 0
+ u_write_bqcd 0
+ u_read_ildg 0
+ u_write_ildg 1 0.00 73.80 73.73 73.80 0.15
+ >EndTiming
+ >EndFooter
+ >EndJob
diff --git a/src/data/fAfPhist.000001 b/src/data/fAfPhist.000001
new file mode 100644
index 0000000000000000000000000000000000000000..6b0740dfa5fbf1cca1b3d43db92fb755fe37acdf
--- /dev/null
+++ b/src/data/fAfPhist.000001
@@ -0,0 +1,6 @@
+ 2 2 -0.1093922664909526E+02 0.3226655326743535E+02 -0.5690947076921602E+01 0.1778139124900939E+02
+ 2 3 -0.3482655321981409E+01 0.8798795114149012E+01 -0.1999837887417912E+01 0.4056267385476374E+01
+ 2 4 -0.1030793027835868E+01 0.1999752671170661E+01 -0.8747566385057118E+00 0.1181154569084714E+01
+ 4 2 -0.1042765902160017E+02 0.3692756648981153E+02 -0.5762968403171802E+01 0.1885973619083830E+02
+ 4 3 -0.4915729002104299E+01 0.1335250372777899E+02 -0.3101381604108358E+01 0.5460805459492596E+01
+ 4 4 -0.1989742507969638E+01 0.3829683536458950E+01 -0.1894084381092628E+01 0.2325879701525509E+01
diff --git a/src/data/fractiontolerance b/src/data/fractiontolerance
new file mode 100644
index 0000000000000000000000000000000000000000..bb92c57a0795d5aaefff35bcd3b0e8c17735658d
--- /dev/null
+++ b/src/data/fractiontolerance
@@ -0,0 +1,4 @@
+0.1
+0.5
+1.0
+0.7
diff --git a/src/data/rangelist b/src/data/rangelist
new file mode 100644
index 0000000000000000000000000000000000000000..ee40e0a27ea2115274047ff4367df1868dc89d30
--- /dev/null
+++ b/src/data/rangelist
@@ -0,0 +1 @@
+1 7 10 1.5
diff --git a/src/fermi/clover2/Makefile b/src/fermi/clover2/Makefile
index c43899ea7f8b9c3ba2f8db936063d583762a94ca..f3c9c39e5cebf6de926600723983f1e016629600 100644
--- a/src/fermi/clover2/Makefile
+++ b/src/fermi/clover2/Makefile
@@ -27,16 +27,16 @@ include $(DIR)Makefile.in
MODULES_DIR = $(DIR)/modules
ifdef FPP2
- fpp = $(FPP2)
+ fpp = $(FPP2) -I$(DIR)include $(MYFLAGS)
else
- fpp = $(FPP)
+ fpp = $(FPP) -I$(DIR)include $(MYFLAGS)
endif
.SUFFIXES:
.SUFFIXES: .a .o .F90
.F90.o:
- $(fpp) -I$(DIR)include $(MYFLAGS) $< > $*.f90
+ $(fpp) $< > $*.f90
$(F90) -c $(FFLAGS) $*.f90
OBJS = \
@@ -53,6 +53,10 @@ OBJS = \
clover_inv.o \
clover_t_init.o
+ifdef quad
+OBJS += clover_allocate_r16.o
+endif
+
fast:
$(FAST_MAKE) lib_clover2.a
@@ -62,3 +66,10 @@ lib_clover2.a: $(OBJS)
clobber:
rm -f *.[Tiod] *.f90 *.mod
rm -f lib_clover2.a
+
+clover_allocate_r4.o: clover_allocate.F90
+ $(fpp) -DPRECISION_R4 $< > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
+clover_allocate_r16.o: clover_allocate.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
diff --git a/src/fermi/clover2/clover_d.F90 b/src/fermi/clover2/clover_d.F90
index 42ab0800f1c612b411c135ca9ac79c5f3eb2a132..baadbbce6efed6d26db5123d2e4cbc77bd76ea56 100644
--- a/src/fermi/clover2/clover_d.F90
+++ b/src/fermi/clover2/clover_d.F90
@@ -69,6 +69,7 @@ end
!-------------------------------------------------------------------------------
subroutine clover_d_w(out, u, in, eo)
use module_vol
+ use module_switches
implicit none
GAUGE_FIELD, intent(out) :: out
@@ -102,6 +103,7 @@ subroutine clover_d_w(out, u, in, eo)
call xbound_g(inh, EVEN, mu)
call xbound_g(inh, ODD , mu)
enddo
+ if (switches%boundary_sf) call schr_boundary_zero4(inh)
out = ZERO
call clover_d_mu_nu_w(eo, 1, 2, out, u, inh(1, 1, 1, EVEN, 1))
@@ -124,6 +126,8 @@ subroutine clover_d_w(out, u, in, eo)
enddo
enddo
+ if (switches%boundary_sf) call schr_boundary_zero3(out)
+
deallocate(inh, STAT = ierr)
if (ierr /= 0) then
call stderr2_int("deallocation failed", 1, ierr)
diff --git a/src/fermi/clover2/clover_init.F90 b/src/fermi/clover2/clover_init.F90
index d6ab119860c07091e10c44bc65bec0e6a4e50db4..73ba200a86e102757cc4a80967e768bff0f9b639 100644
--- a/src/fermi/clover2/clover_init.F90
+++ b/src/fermi/clover2/clover_init.F90
@@ -30,6 +30,7 @@
subroutine clover_init(a, ainv, b, u, csw_kappa, m1, m2)
use typedef_clover
use module_vol
+ use module_switches
implicit none
CLOVER_FIELD_A, intent(out) :: a, ainv
@@ -41,12 +42,13 @@ subroutine clover_init(a, ainv, b, u, csw_kappa, m1, m2)
integer :: i, eo, mu1(6), mu2(6)
SU3 :: f, g
type(type_clover_a) :: p, q
- REAL :: factor
+ REAL :: factor(EVEN:ODD, volh)
DEBUG2S("Start: clover_init")
TIMING_START(timing_bin_clover_init)
factor = -csw_kappa / EIGHT
+ if (switches%boundary_sf) call schrfunc_cswkappa(factor)
#ifdef GAMMA_NOTATION_CHROMA
mu1(1)=1 ; mu1(2)=2
@@ -91,7 +93,7 @@ subroutine clover_init(a, ainv, b, u, csw_kappa, m1, m2)
call clover_f_mu_nu_imp(f, mu2(3), mu2(4), i, eo, u) ! F14 = i(f14 - f14^{+}) [3x3]
call clover_f_mu_nu_imp(g, mu2(5), mu2(6), i, eo, u) ! F42 = i(f42 - f42^{+}) [3x3]
call clover_init2(q, f, g) ! FF4
- call clover_init3(a(1, i, eo), a(2, i, eo), p, q, factor)
+ call clover_init3(a(1, i, eo), a(2, i, eo), p, q, factor(eo, i))
call clover_init4(a(1, i, eo), m1)
call clover_init4(a(2, i, eo), m2)
call clover_inv(b(1, i, eo), ainv(1, i, eo), a(1, i, eo))
diff --git a/src/fermi/d/D100_g.F90 b/src/fermi/d/D100_g.F90
index 316e64260eeafb0268f23c4944c479852f96cc25..4eff41ebc7d6bbf3d403d6c406cf3e5e2022c3ba 100644
--- a/src/fermi/d/D100_g.F90
+++ b/src/fermi/d/D100_g.F90
@@ -27,22 +27,18 @@
module module_d_g_reorder
complex(8), dimension(:,:, :, :, :),pointer,save :: u_reorder
complex(4), dimension(:,:, :, :, :),pointer,save :: u_reorder_r4
+#ifdef QUAD
+ complex(16), dimension(:,:, :, :, :),pointer,save :: u_reorder_r16
+#endif
integer :: mud(4), save
end
!-------------------------------------------------------------------------------
-!subroutine d_g_init(u_orig)
-! use module_vol
-! implicit none
-! GAUGE_FIELD :: u_orig
-!
-! return
-!end
-
-!-------------------------------------------------------------------------------
-!subroutine d_g_u_reorder(u)
+#ifdef D520
+subroutine d_g_init100(u)
+#else
subroutine d_g_init(u)
-
+#endif
use module_d_g_reorder
use module_nn
use module_vol
@@ -81,11 +77,29 @@ subroutine d_g_init(u)
enddo
enddo
+#ifdef QUAD
+ do eo = EVEN, ODD
+ do mu = 1, DIM
+ !$omp parallel do private(c1, c2)
+ do i = 1, volh
+ do c1 = 1, 3
+ do c2 = 1, 6
+ u_reorder_r16(c2, c1, i, mu, eo) = u_reorder(c2, c1, i, mu, eo)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+#endif
+
end
!-------------------------------------------------------------------------------
-!subroutine init_d_g_u_reorder()
+#ifdef D520
+subroutine init_d100()
+#else
subroutine init_d()
+#endif
use module_lattice
use module_d_g_reorder
use module_vol
@@ -93,6 +107,9 @@ subroutine init_d()
allocate(u_reorder(6,NCOL, volh, DIM, EVEN:ODD))
allocate(u_reorder_r4(6,NCOL, volh, DIM, EVEN:ODD))
+#ifdef QUAD
+ allocate(u_reorder_r16(6,NCOL, volh, DIM, EVEN:ODD))
+#endif
mud(1) = decomp_direction(1)
mud(2) = decomp_direction(2)
mud(3) = decomp_direction(3)
diff --git a/src/fermi/d/D100_util_block.m4 b/src/fermi/d/D100_util_block.m4
index 9dc9c9aa8d23d4f0491a39cf236156033d011779..19dc51b629b03be79148f68e4ed9ee30f29e060a 100644
--- a/src/fermi/d/D100_util_block.m4
+++ b/src/fermi/d/D100_util_block.m4
@@ -39,7 +39,6 @@ subroutine _STRCAT(d_,NAME,_block2)(out, a_fwd, a_bwd, u, nn_fwd, nn_bwd, i1, i2
#else
COMPLEX, dimension (4, 3, *) :: out
#endif
-
integer :: i, jf, jb, i1, i2
COMPLEX :: a1, a2 , bf11,bf21,bf12,bf22,bf13,bf23
COMPLEX :: bb11,bb21,bb12,bb22,bb13,bb23
diff --git a/src/measure/cdotc_12.F90 b/src/fermi/d/D103.c
similarity index 55%
rename from src/measure/cdotc_12.F90
rename to src/fermi/d/D103.c
index bdca10f4d84ef0dfaf2499a73e7b0c2bf044332a..4cf873a5d6a34e8d5f3c49c67ae61870d5e85f68 100644
--- a/src/measure/cdotc_12.F90
+++ b/src/fermi/d/D103.c
@@ -1,10 +1,11 @@
+/*
!===============================================================================
!
-! cdotc_12.F90
+! D103.c
!
!-------------------------------------------------------------------------------
!
-! Copyright (C) 2007 Yoshifumi Nakamura
+! Copyright (C) 2011 Hinnerk Stueben
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
@@ -22,24 +23,55 @@
! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
!
!-------------------------------------------------------------------------------
-# include "defs.h"
+*/
+#undef DAGGER
-!-------------------------------------------------------------------------------
-COMPLEX function cdotc_12(x, y) ! Sum_i conjg(x_i) * y_i
+#undef NAME
+#define NAME d_xf
+#define DIR_X
+#include "D103xyzt.c"
+#undef DIR_X
- implicit none
- COMPLEX, intent(in) :: x(*), y(*)
- COMPLEX :: tmp
- integer :: i
-
- tmp = ZERO
- !$omp parallel do reduction(+: tmp)
- do i = 1, 12
- tmp = tmp + conjg(x(i)) * y(i)
- enddo
+#undef NAME
+#define NAME d_yf
+#define DIR_Y
+#include "D103xyzt.c"
+#undef DIR_Y
- cdotc_12 = tmp
+#undef NAME
+#define NAME d_zf
+#define DIR_Z
+#include "D103xyzt.c"
+#undef DIR_Z
-end
+#undef NAME
+#define NAME d_t
+#define DIR_T
+#include "D103xyzt.c"
+#undef DIR_T
-!===============================================================================
+#define DAGGER
+
+#undef NAME
+#define NAME d_dag_xf
+#define DIR_X
+#include "D103xyzt.c"
+#undef DIR_X
+
+#undef NAME
+#define NAME d_dag_yf
+#define DIR_Y
+#include "D103xyzt.c"
+#undef DIR_Y
+
+#undef NAME
+#define NAME d_dag_zf
+#define DIR_Z
+#include "D103xyzt.c"
+#undef DIR_Z
+
+#undef NAME
+#define NAME d_dag_t
+#define DIR_T
+#include "D103xyzt.c"
+#undef DIR_T
diff --git a/src/fermi/d/D103.m4 b/src/fermi/d/D103.m4
new file mode 100644
index 0000000000000000000000000000000000000000..1a9594fee54df868a0a6cff2f64771a490820d99
--- /dev/null
+++ b/src/fermi/d/D103.m4
@@ -0,0 +1,274 @@
+include(`defs.m4')
+include(`spin_proj.m4')
+include(`d100_defs.m4')
+!===============================================================================
+!
+! D103.m4 - this version supports only GAMMA_NOTATION=BQCD
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2008 Yoshifumi Nakamura
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+#include "defs.h"
+!-------------------------------------------------------------------------------
+subroutine d(e, o, out, in, u)
+ use module_d_g_reorder
+ use module_vol
+ use module_lattice
+ use module_nn
+ use module_d21
+ use module_p_interface
+ implicit none
+ integer :: e, o
+#ifdef FLIPSC
+# error FLIPSC is not supported in libd103
+ !!COMPLEX, dimension (NCOL, NDIRAC, volh_tot) :: out, in
+#else
+ SPINCOL_FIELD :: out, in
+#endif
+ GAUGE_FIELD :: u
+
+ TIMING_START(timing_bin_d)
+ ALLOCATE_SC2_FIELD(a) ! kept in 'module_d21'
+ call d_projection(a, in)
+ call xbound_sc2_field(a)
+ call d_xf(out,a(1,1,1,mud(1),0),a(1,1,1, mud(1),1),u_reorder(1,1,1,1,e),nn(1,e,1,0),nn(1,e,1,1), volh)
+ call d_yf(out,a(1,1,1,mud(2),0),a(1,1,1, mud(2),1),u_reorder(1,1,1,2,e),nn(1,e,2,0),nn(1,e,2,1), volh)
+ call d_zf(out,a(1,1,1,mud(3),0),a(1,1,1, mud(3),1),u_reorder(1,1,1,3,e),nn(1,e,3,0),nn(1,e,3,1), volh)
+ call d_t( out,a(1,1,1,mud(4),0),a(1,1,1, mud(4),1),u_reorder(1,1,1,4,e),nn(1,e,4,0),nn(1,e,4,1), volh)
+ TIMING_STOP(timing_bin_d)
+end
+
+!-------------------------------------------------------------------------------
+subroutine d_dag(e, o, out, in, u)
+ use module_d_g_reorder
+ use module_vol
+ use module_lattice
+ use module_nn
+ use module_d21
+ use module_p_interface
+ implicit none
+ integer :: e, o
+#ifdef FLIPSC
+ COMPLEX, dimension (NCOL, NDIRAC, volh_tot) :: out, in
+#else
+ SPINCOL_FIELD :: out, in
+#endif
+ GAUGE_FIELD :: u
+
+ TIMING_START(timing_bin_d)
+ ALLOCATE_SC2_FIELD(a) ! kept in 'module_d21'
+ call d_dag_projection(a, in)
+ call xbound_sc2_field(a)
+ call d_dag_xf(out,a(1,1,1,mud(1),0),a(1,1,1, mud(1),1),u_reorder(1,1,1,1,e),nn(1,e,1,0),nn(1,e,1,1), volh)
+ call d_dag_yf(out,a(1,1,1,mud(2),0),a(1,1,1, mud(2),1),u_reorder(1,1,1,2,e),nn(1,e,2,0),nn(1,e,2,1), volh)
+ call d_dag_zf(out,a(1,1,1,mud(3),0),a(1,1,1, mud(3),1),u_reorder(1,1,1,3,e),nn(1,e,3,0),nn(1,e,3,1), volh)
+ call d_dag_t( out,a(1,1,1,mud(4),0),a(1,1,1, mud(4),1),u_reorder(1,1,1,4,e),nn(1,e,4,0),nn(1,e,4,1), volh)
+ TIMING_STOP(timing_bin_d)
+end
+
+!-------------------------------------------------------------------------------
+subroutine d_projection(out, in)
+ use module_d_g_reorder
+ use module_vol
+ implicit none
+ integer :: mu(4), i, col
+ SC2_FIELD :: out
+#ifdef FLIPSC
+ COMPLEX, dimension (NCOL, NDIRAC, volh_tot) :: in
+#else
+ SPINCOL_FIELD :: in
+#endif
+ COMPLEX ci
+
+ mu=mud
+ ci = dcmplx(1,1)
+
+# undef fwd
+# undef bwd
+# define fwd FWD
+# define bwd BWD
+
+ TIMING_START(timing_bin_sc2_projection)
+
+#ifdef IBM
+ call alignx(16, in(1,1,1) )
+ call alignx(16, out(1,1,1,1,1))
+#endif
+ !$omp parallel do
+ do i = 1, volh
+_D_PROJECTION1
+_D_PROJECTION2
+_D_PROJECTION3
+_D_PROJECTION4
+ enddo
+ TIMING_STOP(timing_bin_sc2_projection)
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine d_dag_projection(out, in)
+ use module_d_g_reorder
+ use module_vol
+ implicit none
+ integer :: mu(4), i, col
+ SC2_FIELD :: out
+#ifdef FLIPSC
+ COMPLEX, dimension (NCOL, NDIRAC, volh_tot) :: in
+#else
+ SPINCOL_FIELD :: in
+#endif
+ COMPLEX ci
+
+ mu=mud
+ ci = dcmplx(1,1)
+
+# undef fwd
+# undef bwd
+# define bwd FWD
+# define fwd BWD
+
+ TIMING_START(timing_bin_sc2_projection)
+#ifdef IBM
+ call alignx(16, in(1,1,1) )
+ call alignx(16, out(1,1,1,1,1))
+#endif
+ !$omp parallel do
+ do i = 1, volh
+_D_PROJECTION1
+_D_PROJECTION2
+_D_PROJECTION3
+_D_PROJECTION4
+ enddo
+ TIMING_STOP(timing_bin_sc2_projection)
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine d_block(out, in, u, eo, i1, i2)
+ use module_d_g_reorder
+ use module_vol
+ use module_nn
+ implicit none
+ integer :: eo, i1, i2
+ COMPLEX, dimension (4,3, volh_tot) :: out
+ COMPLEX, dimension (2,3, volh_tot, DIM, 0:1) :: in
+ GAUGE_FIELD :: u
+ call d_x_block(out, in, u_reorder(1,1,1,1,eo), nn(1,eo,1,FWD),nn(1,eo,1,BWD), i1,i2)
+ call d_y_block(out, in, u_reorder(1,1,1,2,eo), nn(1,eo,2,FWD),nn(1,eo,2,BWD), i1,i2)
+ call d_z_block(out, in, u_reorder(1,1,1,3,eo), nn(1,eo,3,FWD),nn(1,eo,3,BWD), i1,i2)
+ call d_t_block(out, in, u_reorder(1,1,1,4,eo), nn(1,eo,4,FWD),nn(1,eo,4,BWD), i1,i2)
+end
+
+!-------------------------------------------------------------------------------
+subroutine d_dag_block(out, in, u, eo, i1, i2)
+ use module_d_g_reorder
+ use module_vol
+ use module_nn
+ implicit none
+ integer :: eo, i1, i2
+ COMPLEX, dimension (4,3, volh_tot) :: out
+ COMPLEX, dimension (2,3, volh_tot, DIM, 0:1) :: in
+ GAUGE_FIELD :: u
+ call d_dag_x_block(out, in, u_reorder(1,1,1,1,eo), nn(1,eo,1,FWD),nn(1,eo,1,BWD), i1,i2)
+ call d_dag_y_block(out, in, u_reorder(1,1,1,2,eo), nn(1,eo,2,FWD),nn(1,eo,2,BWD), i1,i2)
+ call d_dag_z_block(out, in, u_reorder(1,1,1,3,eo), nn(1,eo,3,FWD),nn(1,eo,3,BWD), i1,i2)
+ call d_dag_t_block(out, in, u_reorder(1,1,1,4,eo), nn(1,eo,4,FWD),nn(1,eo,4,BWD), i1,i2)
+end
+
+!-------------------------------------------------------------------------------
+subroutine d_projection_block(out, in, i1, i2)
+ use module_d_g_reorder
+ use module_vol
+ implicit none
+ integer :: mu(4), i1, i2
+ integer :: i
+ SC2_FIELD :: out
+#ifdef FLIPSC
+ COMPLEX, dimension (NCOL, NDIRAC, volh_tot) :: in
+#else
+ SPINCOL_FIELD :: in
+#endif
+ COMPLEX ci
+
+# undef fwd
+# undef bwd
+# define fwd FWD
+# define bwd BWD
+
+ mu=mud
+ ci = dcmplx(1,1)
+
+#ifdef IBM
+ call alignx(16, in(1,1,1) )
+ call alignx(16, out(1,1,1,1,1))
+#endif
+ do i = i1, i2
+_D_PROJECTION1
+_D_PROJECTION2
+_D_PROJECTION3
+_D_PROJECTION4
+ enddo
+end
+!-------------------------------------------------------------------------------
+subroutine d_dag_projection_block(out, in, i1, i2)
+ use module_d_g_reorder
+ use module_vol
+ implicit none
+ integer :: mu(4), i1, i2
+ integer :: i
+ SC2_FIELD :: out
+#ifdef FLIPSC
+ COMPLEX, dimension (NCOL, NDIRAC, volh_tot) :: in
+#else
+ SPINCOL_FIELD :: in
+#endif
+ COMPLEX ci
+
+# undef fwd
+# undef bwd
+# define bwd FWD
+# define fwd BWD
+
+ mu=mud
+ ci = dcmplx(1,1)
+#ifdef IBM
+ call alignx(16, in(1,1,1) )
+ call alignx(16, out(1,1,1,1,1))
+#endif
+ do i = i1, i2
+_D_PROJECTION1
+_D_PROJECTION2
+_D_PROJECTION3
+_D_PROJECTION4
+ enddo
+end
+
+!-------------------------------------------------------------------------------
+subroutine d_xbound(a)
+
+ use module_vol
+ implicit none
+ SC2_FIELD, intent(inout) :: a
+
+ call xbound_sc2_field(a)
+
+end
+
+!===============================================================================
diff --git a/src/fermi/d/D103_block.c b/src/fermi/d/D103_block.c
new file mode 100644
index 0000000000000000000000000000000000000000..5e7ce13dc11070d2a2567f8a9fb6009244ddd037
--- /dev/null
+++ b/src/fermi/d/D103_block.c
@@ -0,0 +1,79 @@
+/*
+!===============================================================================
+!
+! D103_block.c
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2011 Hinnerk Stueben
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+*/
+#define BLOCK
+
+#undef DAGGER
+
+#undef NAME
+#define NAME d_x_block2
+#define DIR_X
+#include "D103xyzt.c"
+#undef DIR_X
+
+#undef NAME
+#define NAME d_y_block2
+#define DIR_Y
+#include "D103xyzt.c"
+#undef DIR_Y
+
+#undef NAME
+#define NAME d_z_block2
+#define DIR_Z
+#include "D103xyzt.c"
+#undef DIR_Z
+
+#undef NAME
+#define NAME d_t_block2
+#define DIR_T
+#include "D103xyzt.c"
+#undef DIR_T
+
+#define DAGGER
+
+#undef NAME
+#define NAME d_dag_x_block2
+#define DIR_X
+#include "D103xyzt.c"
+#undef DIR_X
+
+#undef NAME
+#define NAME d_dag_y_block2
+#define DIR_Y
+#include "D103xyzt.c"
+#undef DIR_Y
+
+#undef NAME
+#define NAME d_dag_z_block2
+#define DIR_Z
+#include "D103xyzt.c"
+#undef DIR_Z
+
+#undef NAME
+#define NAME d_dag_t_block2
+#define DIR_T
+#include "D103xyzt.c"
+#undef DIR_T
diff --git a/src/fermi/d/D103_block_r4.c b/src/fermi/d/D103_block_r4.c
new file mode 100644
index 0000000000000000000000000000000000000000..e7001b3b72768776ae175b29f05e28212d90bcc7
--- /dev/null
+++ b/src/fermi/d/D103_block_r4.c
@@ -0,0 +1,80 @@
+/*
+!===============================================================================
+!
+! D103_block_r4.c
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2011 Hinnerk Stueben
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+*/
+#define BLOCK
+#define PRECISION_R4
+#undef DAGGER
+
+#undef NAME
+#define NAME d_x_block2_r4
+#define DIR_X
+#include "D103xyzt_r4.c"
+#undef DIR_X
+
+#undef NAME
+#define NAME d_y_block2_r4
+#define DIR_Y
+#include "D103xyzt_r4.c"
+#undef DIR_Y
+
+#undef NAME
+#define NAME d_z_block2_r4
+#define DIR_Z
+#include "D103xyzt_r4.c"
+#undef DIR_Z
+
+#undef NAME
+#define NAME d_t_block2_r4
+#define DIR_T
+#include "D103xyzt_r4.c"
+#undef DIR_T
+
+#define DAGGER
+
+#undef NAME
+#define NAME d_dag_x_block2_r4
+#define DIR_X
+#include "D103xyzt_r4.c"
+#undef DIR_X
+
+#undef NAME
+#define NAME d_dag_y_block2_r4
+#define DIR_Y
+#include "D103xyzt_r4.c"
+#undef DIR_Y
+
+#undef NAME
+#define NAME d_dag_z_block2_r4
+#define DIR_Z
+#include "D103xyzt_r4.c"
+#undef DIR_Z
+
+#undef NAME
+#define NAME d_dag_t_block2_r4
+#define DIR_T
+#include "D103xyzt_r4.c"
+#undef DIR_T
+
diff --git a/src/fermi/d/D103_r4.c b/src/fermi/d/D103_r4.c
new file mode 100644
index 0000000000000000000000000000000000000000..eb95197a2f13c291a30818a9048828dc3e43c00b
--- /dev/null
+++ b/src/fermi/d/D103_r4.c
@@ -0,0 +1,79 @@
+/*
+!===============================================================================
+!
+! D103_r4.c
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2011 Hinnerk Stueben
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+*/
+#define PRECISION_R4
+#undef DAGGER
+
+#undef NAME
+#define NAME d_xf_r4
+#define DIR_X
+#include "D103xyzt_r4.c"
+#undef DIR_X
+
+#undef NAME
+#define NAME d_yf_r4
+#define DIR_Y
+#include "D103xyzt_r4.c"
+#undef DIR_Y
+
+#undef NAME
+#define NAME d_zf_r4
+#define DIR_Z
+#include "D103xyzt_r4.c"
+#undef DIR_Z
+
+#undef NAME
+#define NAME d_t_r4
+#define DIR_T
+#include "D103xyzt_r4.c"
+#undef DIR_T
+
+#define DAGGER
+
+#undef NAME
+#define NAME d_dag_xf_r4
+#define DIR_X
+#include "D103xyzt_r4.c"
+#undef DIR_X
+
+#undef NAME
+#define NAME d_dag_yf_r4
+#define DIR_Y
+#include "D103xyzt_r4.c"
+#undef DIR_Y
+
+#undef NAME
+#define NAME d_dag_zf_r4
+#define DIR_Z
+#include "D103xyzt_r4.c"
+#undef DIR_Z
+
+#undef NAME
+#define NAME d_dag_t_r4
+#define DIR_T
+#include "D103xyzt_r4.c"
+#undef DIR_T
+
diff --git a/src/fermi/d/D103_util_block.m4 b/src/fermi/d/D103_util_block.m4
new file mode 100644
index 0000000000000000000000000000000000000000..f368b75acf40b300f7b4db5985edfbe4de3fe4c9
--- /dev/null
+++ b/src/fermi/d/D103_util_block.m4
@@ -0,0 +1,31 @@
+include(`defs.m4')
+include(`spin_sum.m4')
+include(`d100_defs.m4')
+ifelse(DIRECTION,X,`define(`_DIR',1)')dnl
+ifelse(DIRECTION,Y,`define(`_DIR',2)')dnl
+ifelse(DIRECTION,Z,`define(`_DIR',3)')dnl
+ifelse(DIRECTION,T,`define(`_DIR',4)')dnl
+!-------------------------------------------------------------------------------
+#include "defs.h"
+!-------------------------------------------------------------------------------
+subroutine _STRCAT(d_,NAME,_block)(out, a, u, nn_fwd, nn_bwd, i1, i2)
+ use module_d_g_reorder
+ use module_vol
+ implicit none
+ COMPLEX, dimension (2, 3, volh_tot, DIM, 0:1) :: a
+ COMPLEX, dimension (6, 3, *) :: u
+ integer(4), dimension (*) :: nn_fwd, nn_bwd
+#ifdef FLIPSC
+# error FLIPSC is not supported in libd103
+ !!COMPLEX, dimension (3, 4, *) :: out
+#else
+ COMPLEX, dimension (4, 3, *) :: out
+#endif
+ integer :: i1, i2
+
+ call _STRCAT(d_,NAME,_block2)(out, &
+ a(1,1,1,mud(_DIR),0), a(1,1,1,mud(_DIR),1), &
+ u, nn_fwd, nn_bwd, i1, i2)
+end
+
+!===============================================================================
diff --git a/src/fermi/d/D103xyzt.c b/src/fermi/d/D103xyzt.c
new file mode 100644
index 0000000000000000000000000000000000000000..86a768bafa4c24c1f64db9798787abaa8cd97732
--- /dev/null
+++ b/src/fermi/d/D103xyzt.c
@@ -0,0 +1,445 @@
+/*
+!===============================================================================
+!
+! D103xyzt.c
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2011 Hinnerk Stueben
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+*/
+# include <emmintrin.h>
+# include <pmmintrin.h>
+# include "c_defs.h"
+
+# define cAdd(a, b) a = _mm_add_pd(a, b)
+# define cSum(a, b, c) a = _mm_add_pd(b, c)
+# define cDiff(a, b, c) a = _mm_sub_pd(b, c)
+
+#ifdef DAGGER
+# define cDiff2(a, b, c) cDiff(a, c, b)
+#else
+# define cDiff2(a, b, c) cDiff(a, b, c)
+#endif
+
+#ifdef DAGGER
+# define cDiff3(a, b, c) a = _mm_mul_pd(conjgr, _mm_sub_pd(b, c))
+#else
+# define cDiff3(a, b, c) a = _mm_mul_pd(conjg, _mm_sub_pd(b, c))
+#endif
+
+# define cLoadAf(s, c) STRCAT3(af_ri,s,c) = _mm_load_pd((double*) &(a_fwd(s, c, jf))); \
+ STRCAT3(af_ir,s,c) = _mm_loadr_pd((double*) &(a_fwd(s, c, jf)))
+
+# define cLoadAb(s, c) STRCAT3(ab_ri,s,c) = _mm_load_pd((double*) &(a_bwd(s, c, jb))); \
+ STRCAT3(ab_ir,s,c) = _mm_loadr_pd((double*) &(a_bwd(s, c, jb)))
+
+# define cLoadU(c, d) STRCAT3(u_rr,c,d) = _mm_load1_pd((double*) &(Re(u(c, d, i)))); \
+ STRCAT3(u_ii,c,d) = _mm_load1_pd((double*) &(Im(u(c, d, i))))
+
+# define cProdAfU(s, c, d) STRCAT3(bf,s,c) = _mm_addsub_pd(_mm_mul_pd(STRCAT3(af_ri,s,d), STRCAT3(u_rr,c,d)), _mm_mul_pd(STRCAT3(af_ir,s,d), STRCAT3(u_ii,c,d)))
+# define cProdAbU(s, c, d) STRCAT3(bb,s,c) = _mm_addsub_pd(_mm_mul_pd(STRCAT3(ab_ri,s,d), STRCAT3(u_rr,c,d)), _mm_mul_pd(STRCAT3(ab_ir,s,d), STRCAT3(u_ii,c,d)))
+
+# define cAddProdAfU(s, c, d) cAdd(STRCAT3(bf,s,c), _mm_addsub_pd(_mm_mul_pd(STRCAT3(af_ri,s,d), STRCAT3(u_rr,c,d)), _mm_mul_pd(STRCAT3(af_ir,s,d), STRCAT3(u_ii,c,d))))
+# define cAddProdAbU(s, c, d) cAdd(STRCAT3(bb,s,c), _mm_addsub_pd(_mm_mul_pd(STRCAT3(ab_ri,s,d), STRCAT3(u_rr,c,d)), _mm_mul_pd(STRCAT3(ab_ir,s,d), STRCAT3(u_ii,c,d))))
+
+# define cLoadOut(s, c) STRCAT3(out,s,c) = _mm_load_pd((double*) &(out(s, c, i)))
+# define cLoadrOut(s, c) STRCAT3(out,s,c) = _mm_loadr_pd((double*) &(out(s, c, i)))
+# define cStoreOut(s, c) _mm_store_pd((double*) &(out(s, c, i)), STRCAT3(out,s,c))
+# define cStorerOut(s, c) _mm_storer_pd((double*) &(out(s, c, i)), STRCAT3(out,s,c))
+
+
+# define out(a, b, c) out_[c][b-1][a-1]
+# define a_fwd(a, b, c) a_fwd_[c][b-1][a-1]
+# define a_bwd(a, b, c) a_bwd_[c][b-1][a-1]
+# define u(a, b, c) u_[c][b-1][a-1]
+# define nn_fwd(c) nn_fwd_[c]
+# define nn_bwd(c) nn_bwd_[c]
+
+/*------------------------------------------------------------------------*/
+void STRCAT(NAME, _)(SPINCOL_FIELD out_,
+ SC2_FLD a_fwd_,
+ SC2_FLD a_bwd_,
+ REORDERED_GAUGE_FIELD u_,
+ INTEGER nn_fwd_[],
+ INTEGER nn_bwd_[],
+#ifdef BLOCK
+ int *i1, int *i2)
+#else
+ int *volh)
+#endif
+
+{
+ int i, jf, jb;
+ __m128d af_ri11,af_ri21,af_ri12,af_ri22,af_ri13,af_ri23;
+ __m128d af_ir11,af_ir21,af_ir12,af_ir22,af_ir13,af_ir23;
+ __m128d ab_ri11,ab_ri21,ab_ri12,ab_ri22,ab_ri13,ab_ri23;
+ __m128d ab_ir11,ab_ir21,ab_ir12,ab_ir22,ab_ir13,ab_ir23;
+ __m128d u_rr11,u_rr12,u_rr13,u_rr21,u_rr22,u_rr23,u_rr31,u_rr32,u_rr33;
+ __m128d u_rr41,u_rr42,u_rr43,u_rr51,u_rr52,u_rr53,u_rr61,u_rr62,u_rr63;
+ __m128d u_ii11,u_ii12,u_ii13,u_ii21,u_ii22,u_ii23,u_ii31,u_ii32,u_ii33;
+ __m128d u_ii41,u_ii42,u_ii43,u_ii51,u_ii52,u_ii53,u_ii61,u_ii62,u_ii63;
+ __m128d bf11,bf21,bf12,bf22,bf13,bf23;
+ __m128d bb14,bb24,bb15,bb25,bb16,bb26;
+ __m128d out11, out21, out31, out41, out12, out22, out32, out42, out13, out23, out33, out43;
+ __m128d tmp11, tmp21, tmp31, tmp41, tmp12, tmp22, tmp32, tmp42, tmp13, tmp23, tmp33, tmp43;
+
+ const __m128d conjg = _mm_setr_pd(ONE, -ONE);
+ const __m128d conjgr = _mm_set_pd(ONE, -ONE);
+
+
+#ifndef PRECISION_R4
+#ifndef BLOCK
+ TIMING_START(STRCAT(timing_bin_, NAME));
+#endif
+#endif
+
+ out_--;
+ a_fwd_--;
+ a_bwd_--;
+ u_--;
+ nn_fwd_--;
+ nn_bwd_--;
+
+
+#ifdef BLOCK
+ for (i = *i1; i <= *i2; i++)
+#else
+ #pragma omp parallel for \
+ private (i, jf, jb) \
+ private (af_ri11,af_ri21,af_ri12,af_ri22,af_ri13,af_ri23) \
+ private (af_ir11,af_ir21,af_ir12,af_ir22,af_ir13,af_ir23) \
+ private (ab_ri11,ab_ri21,ab_ri12,ab_ri22,ab_ri13,ab_ri23) \
+ private (ab_ir11,ab_ir21,ab_ir12,ab_ir22,ab_ir13,ab_ir23) \
+ private (u_rr11,u_rr12,u_rr13,u_rr21,u_rr22,u_rr23,u_rr31,u_rr32,u_rr33) \
+ private (u_rr41,u_rr42,u_rr43,u_rr51,u_rr52,u_rr53,u_rr61,u_rr62,u_rr63) \
+ private (u_ii11,u_ii12,u_ii13,u_ii21,u_ii22,u_ii23,u_ii31,u_ii32,u_ii33) \
+ private (u_ii41,u_ii42,u_ii43,u_ii51,u_ii52,u_ii53,u_ii61,u_ii62,u_ii63) \
+ private (bf11,bf21,bf12,bf22,bf13,bf23) \
+ private (bb14,bb24,bb15,bb25,bb16,bb26) \
+ private (out11, out21, out31, out41, out12, out22, out32, out42, out13, out23, out33, out43) \
+ private (tmp11, tmp21, tmp31, tmp41, tmp12, tmp22, tmp32, tmp42, tmp13, tmp23, tmp33, tmp43)
+
+ for (i = 1; i <= *volh; i++)
+#endif
+ {
+ jf=nn_fwd(i);
+ jb=nn_bwd(i);
+
+ cLoadAf(1, 1);
+ cLoadAf(2, 1);
+ cLoadU(1, 1);
+ cLoadU(2, 1);
+ cLoadU(3, 1);
+ cProdAfU(1, 1, 1);
+ cProdAfU(2, 1, 1);
+ cProdAfU(1, 2, 1);
+ cProdAfU(2, 2, 1);
+ cProdAfU(1, 3, 1);
+ cProdAfU(2, 3, 1);
+
+ cLoadAb(1, 1);
+ cLoadAb(2, 1);
+ cLoadU(4, 1);
+ cLoadU(5, 1);
+ cLoadU(6, 1);
+ cProdAbU(1, 4, 1);
+ cProdAbU(2, 4, 1);
+ cProdAbU(1, 5, 1);
+ cProdAbU(2, 5, 1);
+ cProdAbU(1, 6, 1);
+ cProdAbU(2, 6, 1);
+
+ cLoadAf(1, 2);
+ cLoadAf(2, 2);
+ cLoadU(1, 2);
+ cLoadU(2, 2);
+ cLoadU(3, 2);
+ cAddProdAfU(1, 1, 2);
+ cAddProdAfU(2, 1, 2);
+ cAddProdAfU(1, 2, 2);
+ cAddProdAfU(2, 2, 2);
+ cAddProdAfU(1, 3, 2);
+ cAddProdAfU(2, 3, 2);
+
+ cLoadAb(1, 2);
+ cLoadAb(2, 2);
+ cLoadU(4, 2);
+ cLoadU(5, 2);
+ cLoadU(6, 2);
+ cAddProdAbU(1, 4, 2);
+ cAddProdAbU(2, 4, 2);
+ cAddProdAbU(1, 5, 2);
+ cAddProdAbU(2, 5, 2);
+ cAddProdAbU(1, 6, 2);
+ cAddProdAbU(2, 6, 2);
+
+ cLoadAf(1, 3);
+ cLoadAf(2, 3);
+ cLoadU(1, 3);
+ cLoadU(2, 3);
+ cLoadU(3, 3);
+ cAddProdAfU(1, 1, 3);
+ cAddProdAfU(2, 1, 3);
+ cAddProdAfU(1, 2, 3);
+ cAddProdAfU(2, 2, 3);
+ cAddProdAfU(1, 3, 3);
+ cAddProdAfU(2, 3, 3);
+
+ cLoadAb(1, 3);
+ cLoadAb(2, 3);
+ cLoadU(4, 3);
+ cLoadU(5, 3);
+ cLoadU(6, 3);
+ cAddProdAbU(1, 4, 3);
+ cAddProdAbU(2, 4, 3);
+ cAddProdAbU(1, 5, 3);
+ cAddProdAbU(2, 5, 3);
+ cAddProdAbU(1, 6, 3);
+ cAddProdAbU(2, 6, 3);
+
+
+#ifdef DIR_T
+ cLoadOut(1, 1);
+ cLoadOut(2, 1);
+ cLoadOut(3, 1);
+ cLoadOut(4, 1);
+ cLoadOut(1, 2);
+ cLoadOut(2, 2);
+ cLoadOut(3, 2);
+ cLoadOut(4, 2);
+ cLoadOut(1, 3);
+ cLoadOut(2, 3);
+ cLoadOut(3, 3);
+ cLoadOut(4, 3);
+#ifdef DAGGER
+ cAdd(out11, bf11);
+ cAdd(out21, bf21);
+ cAdd(out31, bb14);
+ cAdd(out41, bb24);
+ cAdd(out12, bf12);
+ cAdd(out22, bf22);
+ cAdd(out32, bb15);
+ cAdd(out42, bb25);
+ cAdd(out13, bf13);
+ cAdd(out23, bf23);
+ cAdd(out33, bb16);
+ cAdd(out43, bb26);
+#else
+ cAdd(out11, bb14);
+ cAdd(out21, bb24);
+ cAdd(out31, bf11);
+ cAdd(out41, bf21);
+ cAdd(out12, bb15);
+ cAdd(out22, bb25);
+ cAdd(out32, bf12);
+ cAdd(out42, bf22);
+ cAdd(out13, bb16);
+ cAdd(out23, bb26);
+ cAdd(out33, bf13);
+ cAdd(out43, bf23);
+#endif
+ cStoreOut(1, 1);
+ cStoreOut(2, 1);
+ cStoreOut(3, 1);
+ cStoreOut(4, 1);
+ cStoreOut(1, 2);
+ cStoreOut(2, 2);
+ cStoreOut(3, 2);
+ cStoreOut(4, 2);
+ cStoreOut(1, 3);
+ cStoreOut(2, 3);
+ cStoreOut(3, 3);
+ cStoreOut(4, 3);
+#endif
+
+#ifdef DIR_X
+ cSum(out11, bf11, bb14);
+ cSum(out21, bf21, bb24);
+ cDiff3(out31, bf21, bb24);
+ cDiff3(out41, bf11, bb14);
+
+ cSum(out12, bf12, bb15);
+ cSum(out22, bf22, bb25);
+ cDiff3(out32, bf22, bb25);
+ cDiff3(out42, bf12, bb15);
+
+ cSum(out13, bf13, bb16);
+ cSum(out23, bf23, bb26);
+ cDiff3(out33, bf23, bb26);
+ cDiff3(out43, bf13, bb16);
+
+ cStoreOut(1, 1);
+ cStoreOut(2, 1);
+ cStorerOut(3, 1);
+ cStorerOut(4, 1);
+ cStoreOut(1, 2);
+ cStoreOut(2, 2);
+ cStorerOut(3, 2);
+ cStorerOut(4, 2);
+ cStoreOut(1, 3);
+ cStoreOut(2, 3);
+ cStorerOut(3, 3);
+ cStorerOut(4, 3);
+#endif
+
+
+#ifdef DIR_Y
+ cSum(tmp11, bf11, bb14);
+ cSum(tmp21, bf21, bb24);
+ cDiff2(tmp31, bf21, bb24);
+ cDiff2(tmp41, bb14, bf11);
+
+ cSum(tmp12, bf12, bb15);
+ cSum(tmp22, bf22, bb25);
+ cDiff2(tmp32, bf22, bb25);
+ cDiff2(tmp42, bb15, bf12);
+
+ cSum(tmp13, bf13, bb16);
+ cSum(tmp23, bf23, bb26);
+ cDiff2(tmp33, bf23, bb26);
+ cDiff2(tmp43, bb16, bf13);
+
+ cLoadOut(1, 1);
+ cLoadOut(2, 1);
+ cLoadOut(3, 1);
+ cLoadOut(4, 1);
+ cLoadOut(1, 2);
+ cLoadOut(2, 2);
+ cLoadOut(3, 2);
+ cLoadOut(4, 2);
+ cLoadOut(1, 3);
+ cLoadOut(2, 3);
+ cLoadOut(3, 3);
+ cLoadOut(4, 3);
+
+ cAdd(out11, tmp11);
+ cAdd(out21, tmp21);
+ cAdd(out31, tmp31);
+ cAdd(out41, tmp41);
+ cAdd(out12, tmp12);
+ cAdd(out22, tmp22);
+ cAdd(out32, tmp32);
+ cAdd(out42, tmp42);
+ cAdd(out13, tmp13);
+ cAdd(out23, tmp23);
+ cAdd(out33, tmp33);
+ cAdd(out43, tmp43);
+
+ cStoreOut(1, 1);
+ cStoreOut(2, 1);
+ cStoreOut(3, 1);
+ cStoreOut(4, 1);
+ cStoreOut(1, 2);
+ cStoreOut(2, 2);
+ cStoreOut(3, 2);
+ cStoreOut(4, 2);
+ cStoreOut(1, 3);
+ cStoreOut(2, 3);
+ cStoreOut(3, 3);
+ cStoreOut(4, 3);
+#endif
+
+#ifdef DIR_Z
+ cSum(tmp11, bf11, bb14);
+ cSum(tmp21, bf21, bb24);
+ cDiff3(tmp31, bf11, bb14);
+ cDiff3(tmp41, bb24, bf21);
+
+ cSum(tmp12, bf12, bb15);
+ cSum(tmp22, bf22, bb25);
+ cDiff3(tmp32, bf12, bb15);
+ cDiff3(tmp42, bb25, bf22);
+
+ cSum(tmp13, bf13, bb16);
+ cSum(tmp23, bf23, bb26);
+ cDiff3(tmp33, bf13, bb16);
+ cDiff3(tmp43, bb26, bf23);
+
+ cLoadOut(1, 1);
+ cLoadOut(2, 1);
+ cLoadrOut(3, 1);
+ cLoadrOut(4, 1);
+ cLoadOut(1, 2);
+ cLoadOut(2, 2);
+ cLoadrOut(3, 2);
+ cLoadrOut(4, 2);
+ cLoadOut(1, 3);
+ cLoadOut(2, 3);
+ cLoadrOut(3, 3);
+ cLoadrOut(4, 3);
+
+ cAdd(out11, tmp11);
+ cAdd(out21, tmp21);
+ cAdd(out31, tmp31);
+ cAdd(out41, tmp41);
+ cAdd(out12, tmp12);
+ cAdd(out22, tmp22);
+ cAdd(out32, tmp32);
+ cAdd(out42, tmp42);
+ cAdd(out13, tmp13);
+ cAdd(out23, tmp23);
+ cAdd(out33, tmp33);
+ cAdd(out43, tmp43);
+
+ cStoreOut(1, 1);
+ cStoreOut(2, 1);
+ cStorerOut(3, 1);
+ cStorerOut(4, 1);
+ cStoreOut(1, 2);
+ cStoreOut(2, 2);
+ cStorerOut(3, 2);
+ cStorerOut(4, 2);
+ cStoreOut(1, 3);
+ cStoreOut(2, 3);
+ cStorerOut(3, 3);
+ cStorerOut(4, 3);
+#endif
+ }
+
+#ifndef PRECISION_R4
+#ifndef BLOCK
+ TIMING_STOP(STRCAT(timing_bin_, NAME));
+#endif
+#endif
+
+}
+
+# undef cCopy
+# undef cCopyr
+# undef cSum
+# undef cDiff
+# undef cDiff2
+# undef cDiff2
+# undef cDiff3
+# undef cProd
+# undef cAdd
+# undef cAddSum
+# undef cAddProd
+# undef cLoadAf
+# undef cLoadAb
+# undef cLoadU
+# undef cProdAfU
+# undef cProdAbU
+# undef cAddProdAfU
+# undef cAddProdAbU
+# undef cLoadOut
+# undef cLoadrOut
+# undef cStoreOut
+# undef cStorerOut
diff --git a/src/fermi/d/D103xyzt_r4.c b/src/fermi/d/D103xyzt_r4.c
new file mode 100644
index 0000000000000000000000000000000000000000..fafe2b7aed13a9142842866c341c0ab179d3eb49
--- /dev/null
+++ b/src/fermi/d/D103xyzt_r4.c
@@ -0,0 +1,335 @@
+/*
+!===============================================================================
+!
+! D103xyzt_r4.c
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2011 Hinnerk Stueben
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+*/
+# include <xmmintrin.h>
+# include <emmintrin.h>
+# include <pmmintrin.h>
+# include "c_defs.h"
+
+# define cAdd(a, b) a = _mm_add_ps(a, b)
+# define cSum(a, b, c) a = _mm_add_ps(b, c)
+# define cDiff(a, b, c) a = _mm_sub_ps(b, c)
+
+#ifdef DAGGER
+# define cDiff2(a, b, c) cDiff(a, c, b)
+#else
+# define cDiff2(a, b, c) cDiff(a, b, c)
+#endif
+
+#ifdef DAGGER
+# define cDiff3(a, b, c) a = _mm_mul_ps(conjgr, _mm_sub_ps(b, c))
+#else
+# define cDiff3(a, b, c) a = _mm_mul_ps(conjg, _mm_sub_ps(b, c))
+#endif
+
+# define cLoadAf(s, c) STRCAT3(af_ri,s,c) = _mm_load_ps((float*) &(a_fwd(s, c, jf))); \
+ STRCAT3(af_ir,s,c) = _mm_shuffle_ps(_mm_loadr_ps((float*) &(a_fwd(s, c, jf))), \
+ _mm_loadr_ps((float*) &(a_fwd(s, c, jf))), _MM_SHUFFLE(1,0,3,2))
+
+# define cLoadAb(s, c) STRCAT3(ab_ri,s,c) = _mm_load_ps((float*) &(a_bwd(s, c, jb))); \
+ STRCAT3(ab_ir,s,c) = _mm_shuffle_ps(_mm_loadr_ps((float*) &(a_bwd(s, c, jb))), \
+ _mm_loadr_ps((float*) &(a_bwd(s, c, jb))), _MM_SHUFFLE(1,0,3,2))
+
+# define cLoadU(c, d) STRCAT3(u_rr,c,d) = _mm_load1_ps((float*) &(Re(u(c, d, i)))); \
+ STRCAT3(u_ii,c,d) = _mm_load1_ps((float*) &(Im(u(c, d, i))))
+
+# define cProdAfU(s, c, d) STRCAT3(bf,s,c) = _mm_addsub_ps(_mm_mul_ps(STRCAT3(af_ri,s,d), STRCAT3(u_rr,c,d)), _mm_mul_ps(STRCAT3(af_ir,s,d), STRCAT3(u_ii,c,d)))
+# define cProdAbU(s, c, d) STRCAT3(bb,s,c) = _mm_addsub_ps(_mm_mul_ps(STRCAT3(ab_ri,s,d), STRCAT3(u_rr,c,d)), _mm_mul_ps(STRCAT3(ab_ir,s,d), STRCAT3(u_ii,c,d)))
+
+# define cAddProdAfU(s, c, d) cAdd(STRCAT3(bf,s,c), _mm_addsub_ps(_mm_mul_ps(STRCAT3(af_ri,s,d), STRCAT3(u_rr,c,d)), _mm_mul_ps(STRCAT3(af_ir,s,d), STRCAT3(u_ii,c,d))))
+# define cAddProdAbU(s, c, d) cAdd(STRCAT3(bb,s,c), _mm_addsub_ps(_mm_mul_ps(STRCAT3(ab_ri,s,d), STRCAT3(u_rr,c,d)), _mm_mul_ps(STRCAT3(ab_ir,s,d), STRCAT3(u_ii,c,d))))
+
+# define cShuffleR(a) _mm_shuffle_ps(a, a, _MM_SHUFFLE(2,3,0,1))
+
+# define cLoadOut(s, c) STRCAT3(out,s,c) = _mm_load_ps((float*) &(out(s, c, i)))
+# define cLoadrOut(s, c) STRCAT3(out,s,c) = cShuffleR(_mm_load_ps((float*) &(out(s, c, i))))
+# define cStoreOut(s, c) _mm_store_ps((float*) &(out(s, c, i)), STRCAT3(out,s,c))
+# define cStorerOut(s, c) _mm_store_ps((float*) &(out(s, c, i)), cShuffleR(STRCAT3(out,s,c)))
+
+
+# define out(a, b, c) out_[c][b-1][a-1]
+# define a_fwd(a, b, c) a_fwd_[c][b-1][a-1]
+# define a_bwd(a, b, c) a_bwd_[c][b-1][a-1]
+# define u(a, b, c) u_[c][b-1][a-1]
+# define nn_fwd(c) nn_fwd_[c]
+# define nn_bwd(c) nn_bwd_[c]
+
+/*------------------------------------------------------------------------*/
+void STRCAT(NAME, _)(SPINCOL_FIELD out_,
+ SC2_FLD a_fwd_,
+ SC2_FLD a_bwd_,
+ REORDERED_GAUGE_FIELD u_,
+ INTEGER nn_fwd_[],
+ INTEGER nn_bwd_[],
+#ifdef BLOCK
+ int *i1, int *i2)
+#else
+ int *volh)
+#endif
+
+{
+ int i, jf, jb;
+ __m128 af_ri11,af_ri12,af_ri13;
+ __m128 af_ir11,af_ir12,af_ir13;
+ __m128 ab_ri11,ab_ri12,ab_ri13;
+ __m128 ab_ir11,ab_ir12,ab_ir13;
+ __m128 u_rr11,u_rr12,u_rr13,u_rr21,u_rr22,u_rr23,u_rr31,u_rr32,u_rr33;
+ __m128 u_rr41,u_rr42,u_rr43,u_rr51,u_rr52,u_rr53,u_rr61,u_rr62,u_rr63;
+ __m128 u_ii11,u_ii12,u_ii13,u_ii21,u_ii22,u_ii23,u_ii31,u_ii32,u_ii33;
+ __m128 u_ii41,u_ii42,u_ii43,u_ii51,u_ii52,u_ii53,u_ii61,u_ii62,u_ii63;
+ __m128 bf11,bf12,bf13;
+ __m128 bb14,bb15,bb16;
+ __m128 out11, out31, out12, out32, out13, out33;
+ __m128 tmp11, tmp31, tmp12, tmp32, tmp13, tmp33;
+
+ const __m128 conjg = _mm_setr_ps(ONE, -ONE, ONE, -ONE);
+ const __m128 conjgr = _mm_set_ps(ONE, -ONE, ONE, -ONE);
+
+
+ out_--;
+ a_fwd_--;
+ a_bwd_--;
+ u_--;
+ nn_fwd_--;
+ nn_bwd_--;
+
+#ifdef BLOCK
+ for (i = *i1; i <= *i2; i++)
+#else
+ #pragma omp parallel for \
+ private (i, jf, jb) \
+ private (af_ri11,af_ri12,af_ri13) \
+ private (af_ir11,af_ir12,af_ir13) \
+ private (ab_ri11,ab_ri12,ab_ri13) \
+ private (ab_ir11,ab_ir12,ab_ir13) \
+ private (u_rr11,u_rr12,u_rr13,u_rr21,u_rr22,u_rr23,u_rr31,u_rr32,u_rr33) \
+ private (u_rr41,u_rr42,u_rr43,u_rr51,u_rr52,u_rr53,u_rr61,u_rr62,u_rr63) \
+ private (u_ii11,u_ii12,u_ii13,u_ii21,u_ii22,u_ii23,u_ii31,u_ii32,u_ii33) \
+ private (u_ii41,u_ii42,u_ii43,u_ii51,u_ii52,u_ii53,u_ii61,u_ii62,u_ii63) \
+ private (bf11,bf12,bf13) \
+ private (bb14,bb15,bb16) \
+ private (out11, out31, out12, out32, out13, out33) \
+ private (tmp11, tmp31, tmp12, tmp32, tmp13, tmp33)
+
+ for (i = 1; i <= *volh; i++)
+#endif
+ {
+ jf=nn_fwd(i);
+ jb=nn_bwd(i);
+
+ cLoadAf(1, 1);
+ cLoadU(1, 1);
+ cLoadU(2, 1);
+ cLoadU(3, 1);
+ cProdAfU(1, 1, 1);
+ cProdAfU(1, 2, 1);
+ cProdAfU(1, 3, 1);
+
+ cLoadAb(1, 1);
+ cLoadU(4, 1);
+ cLoadU(5, 1);
+ cLoadU(6, 1);
+ cProdAbU(1, 4, 1);
+ cProdAbU(1, 5, 1);
+ cProdAbU(1, 6, 1);
+
+ cLoadAf(1, 2);
+ cLoadU(1, 2);
+ cLoadU(2, 2);
+ cLoadU(3, 2);
+ cAddProdAfU(1, 1, 2);
+ cAddProdAfU(1, 2, 2);
+ cAddProdAfU(1, 3, 2);
+
+ cLoadAb(1, 2);
+ cLoadU(4, 2);
+ cLoadU(5, 2);
+ cLoadU(6, 2);
+ cAddProdAbU(1, 4, 2);
+ cAddProdAbU(1, 5, 2);
+ cAddProdAbU(1, 6, 2);
+
+ cLoadAf(1, 3);
+ cLoadU(1, 3);
+ cLoadU(2, 3);
+ cLoadU(3, 3);
+ cAddProdAfU(1, 1, 3);
+ cAddProdAfU(1, 2, 3);
+ cAddProdAfU(1, 3, 3);
+
+ cLoadAb(1, 3);
+ cLoadU(4, 3);
+ cLoadU(5, 3);
+ cLoadU(6, 3);
+ cAddProdAbU(1, 4, 3);
+ cAddProdAbU(1, 5, 3);
+ cAddProdAbU(1, 6, 3);
+
+
+#ifdef DIR_T
+ cLoadOut(1, 1);
+ cLoadOut(3, 1);
+ cLoadOut(1, 2);
+ cLoadOut(3, 2);
+ cLoadOut(1, 3);
+ cLoadOut(3, 3);
+#ifdef DAGGER
+ cAdd(out11, bf11);
+ cAdd(out31, bb14);
+ cAdd(out12, bf12);
+ cAdd(out32, bb15);
+ cAdd(out13, bf13);
+ cAdd(out33, bb16);
+#else
+ cAdd(out11, bb14);
+ cAdd(out31, bf11);
+ cAdd(out12, bb15);
+ cAdd(out32, bf12);
+ cAdd(out13, bb16);
+ cAdd(out33, bf13);
+#endif
+ cStoreOut(1, 1);
+ cStoreOut(3, 1);
+ cStoreOut(1, 2);
+ cStoreOut(3, 2);
+ cStoreOut(1, 3);
+ cStoreOut(3, 3);
+#endif
+
+#ifdef DIR_X
+# define cShuffleX(a) _mm_shuffle_ps(a, a, _MM_SHUFFLE(1,0,3,2))
+
+ cSum(out11, bf11, bb14);
+ cDiff3(out31, cShuffleX(bf11), cShuffleX(bb14));
+
+ cSum(out12, bf12, bb15);
+ cDiff3(out32, cShuffleX(bf12), cShuffleX(bb15));
+
+ cSum(out13, bf13, bb16);
+ cDiff3(out33, cShuffleX(bf13), cShuffleX(bb16));
+
+ cStoreOut(1, 1);
+ cStorerOut(3, 1);
+ cStoreOut(1, 2);
+ cStorerOut(3, 2);
+ cStoreOut(1, 3);
+ cStorerOut(3, 3);
+#endif
+
+
+#ifdef DIR_Y
+
+# define cShuffleY(a, b) _mm_shuffle_ps(a, b, _MM_SHUFFLE(1,0,3,2))
+
+ cSum(tmp11, bf11, bb14);
+ cDiff2(tmp31, cShuffleY(bf11, bb14), cShuffleY(bb14, bf11));
+
+ cSum(tmp12, bf12, bb15);
+ cDiff2(tmp32, cShuffleY(bf12, bb15), cShuffleY(bb15, bf12));
+
+ cSum(tmp13, bf13, bb16);
+ cDiff2(tmp33, cShuffleY(bf13, bb16), cShuffleY(bb16, bf13));
+
+ cLoadOut(1, 1);
+ cLoadOut(3, 1);
+ cLoadOut(1, 2);
+ cLoadOut(3, 2);
+ cLoadOut(1, 3);
+ cLoadOut(3, 3);
+
+ cAdd(out11, tmp11);
+ cAdd(out31, tmp31);
+ cAdd(out12, tmp12);
+ cAdd(out32, tmp32);
+ cAdd(out13, tmp13);
+ cAdd(out33, tmp33);
+
+ cStoreOut(1, 1);
+ cStoreOut(3, 1);
+ cStoreOut(1, 2);
+ cStoreOut(3, 2);
+ cStoreOut(1, 3);
+ cStoreOut(3, 3);
+#endif
+
+#ifdef DIR_Z
+# define cShuffleZ(a, b) _mm_shuffle_ps(a, b, _MM_SHUFFLE(3,2,1,0))
+
+ cSum(tmp11, bf11, bb14);
+ cDiff3(tmp31, cShuffleZ(bf11, bb14), cShuffleZ(bb14, bf11));
+
+ cSum(tmp12, bf12, bb15);
+ cDiff3(tmp32, cShuffleZ(bf12, bb15), cShuffleZ(bb15, bf12));
+
+ cSum(tmp13, bf13, bb16);
+ cDiff3(tmp33, cShuffleZ(bf13, bb16), cShuffleZ(bb16, bf13));
+
+ cLoadOut(1, 1);
+ cLoadrOut(3, 1);
+ cLoadOut(1, 2);
+ cLoadrOut(3, 2);
+ cLoadOut(1, 3);
+ cLoadrOut(3, 3);
+
+ cAdd(out11, tmp11);
+ cAdd(out31, tmp31);
+ cAdd(out12, tmp12);
+ cAdd(out32, tmp32);
+ cAdd(out13, tmp13);
+ cAdd(out33, tmp33);
+
+ cStoreOut(1, 1);
+ cStorerOut(3, 1);
+ cStoreOut(1, 2);
+ cStorerOut(3, 2);
+ cStoreOut(1, 3);
+ cStorerOut(3, 3);
+#endif
+ }
+}
+
+# undef cCopy
+# undef cCopyr
+# undef cSum
+# undef cDiff
+# undef cDiff2
+# undef cDiff2
+# undef cDiff3
+# undef cProd
+# undef cAdd
+# undef cAddSum
+# undef cAddProd
+# undef cLoadAf
+# undef cLoadAb
+# undef cLoadU
+# undef cProdAfU
+# undef cProdAbU
+# undef cAddProdAfU
+# undef cAddProdAbU
+# undef cLoadOut
+# undef cLoadrOut
+# undef cStoreOut
+# undef cStorerOut
diff --git a/src/fermi/d/D520_g.F90 b/src/fermi/d/D520_g.F90
index c4996b38a73b205d96fea76e7af0912a4d09d59e..2c3b4cf3b6d430bfb74cc609cc2c4cf37211a33e 100644
--- a/src/fermi/d/D520_g.F90
+++ b/src/fermi/d/D520_g.F90
@@ -41,7 +41,9 @@ subroutine d_g_init(u_orig) ! copies the original gauge field to "wilson"
!!call flip_bc(u_orig)
!! call d_g_init_r4(u)
-
+#ifdef QUAD
+ call d_g_init100(u_orig)
+#endif
end
!===============================================================================
diff --git a/src/fermi/d/D520_init.F90 b/src/fermi/d/D520_init.F90
index 313c9a14eb577b65f79593b3380713873fe4ec0f..8fb296dc13806de30d306955cbcee1880d1d2ac4 100644
--- a/src/fermi/d/D520_init.F90
+++ b/src/fermi/d/D520_init.F90
@@ -32,6 +32,9 @@ subroutine init_d()
implicit none
call wilson_init(n, npe, volh_tot, nn)
+#ifdef QUAD
+ call init_d100()
+#endif
end
!===============================================================================
diff --git a/src/fermi/d/Makefile b/src/fermi/d/Makefile
index 5b9eef83f7eb3c82d04b8f5cea3dd2df1f8aea97..5fadb8e4630ee07a648b7b197e0bef178f23da91 100644
--- a/src/fermi/d/Makefile
+++ b/src/fermi/d/Makefile
@@ -4,7 +4,7 @@
#
#-------------------------------------------------------------------------------
#
-# Copyright (C) 1998-2007 Hinnerk Stueben
+# Copyright (C) 1998-2011 Hinnerk Stueben
#
# This file is part of BQCD -- Berlin Quantum ChromoDynamics program
#
@@ -34,16 +34,17 @@ endif
.SUFFIXES:
-.SUFFIXES: .a .o .f90 .F90 .m4
+.SUFFIXES: .a .o .f90 .F90 .c .m4
.f90.o:
$(F90) -c $(FFLAGS) $<
-MODULES_DIR = ../../modules
+.c.o:
+ $(CC) -c -I../../include $(MYFLAGS) $(CFLAGS) $<
+
$(LIBD):
-###include DSF.mk
include D_PROJ.mk
include $(LIBD:.a=.mk)
@@ -69,9 +70,15 @@ d_r4.f90: D_r4.F90
d_xbound.f90: D_xbound.F90
$(fpp) D_xbound.F90 > $@
+
+chemicalp.f90: chemicalp.F90; $(fpp) $< > $@
+
clean:
rm -f *.[Tiod] *.f90 *.mod work.pc work.pcl
- -rm -f dxyzt.F90 dxyzt_block.F90 d100.F90
+ rm -f dxyzt.F90 dxyzt_block.F90 d100.F90 d103.F90
+ rm -f dxyzt.c dxyzt_r4.c
+ rm -f dxyzt_block.c dxyzt_block_r4.c dxyzt_block2.c dxyzt_block2_r4.c
+ rm -f dproj.c ddagproj.c dproj_r4.c ddagproj_r4.c
clobber: clean
rm -f libd*.a
diff --git a/src/measure/chemicalp.F90 b/src/fermi/d/chemicalp.F90
similarity index 93%
rename from src/measure/chemicalp.F90
rename to src/fermi/d/chemicalp.F90
index f8e5578eb5514610f6ffc52fb3319529618fa500..11463569d6f60cf23feb91e074c59a0b310ac94a 100644
--- a/src/measure/chemicalp.F90
+++ b/src/fermi/d/chemicalp.F90
@@ -50,22 +50,24 @@ subroutine apply_mp_chemu(oe, oo, ie, io, mid, chemu, i)! d^i M / (d mu)^i
call d(EVEN, ODD, oe, io, gauge(2)%u)
oo = - action%mtilde(mid)%kappa * oo
oe = - action%mtilde(mid)%kappa * oe
- call d_g_u_reorder(gauge(2)%u)
+ call d_g_init(gauge(2)%u)
end
!-------------------------------------------------------------------------------
-subroutine emuu4(u, fac1, fac2)
- use module_d_g_reorder
+#ifdef LIBDI
+subroutine emuu4(u, fac1, fac2, uzero)
use module_nn
use module_vol
use module_lattice
+ use module_d_g_reorder
implicit none
GAUGE_FIELD, intent(in) :: u
REAL, intent(in) :: fac1, fac2
+ logical :: uzero
integer :: eo, oe, i, j, mu, col, c1, c2
- u_reorder = 0
+ if (uzero)u_reorder=0
mu = gamma_index(4)
do eo = EVEN, ODD
@@ -85,5 +87,9 @@ subroutine emuu4(u, fac1, fac2)
enddo
end
-
+#else
+subroutine emuu4()
+call die("emuu4: works only when LIBDI")
+end
+#endif
!===============================================================================
diff --git a/src/fermi/d/libd.mk b/src/fermi/d/libd.mk
index ffd80c8d8fc6ab301888ca5efcd915a9dbfd0db3..8945552fc3fbad3242e71ce77011f2e4352dd089 100644
--- a/src/fermi/d/libd.mk
+++ b/src/fermi/d/libd.mk
@@ -61,7 +61,8 @@ OBJS = \
d_version.o \
d_block.o \
d_projection.o \
- d_xbound.o
+ d_xbound.o \
+ chemicalp.o
R4_FLAGS = -DPRECISION_R4 -DD_R4_INTERNAL
diff --git a/src/fermi/d/libd100.mk b/src/fermi/d/libd100.mk
index 0d8cf3cb87d1bce0c2022b66cde9d3f9c6c41937..10458cf10679c475226415a7c230624e921d5707 100644
--- a/src/fermi/d/libd100.mk
+++ b/src/fermi/d/libd100.mk
@@ -29,7 +29,11 @@ M4=m4
MODULES = \
module_d21.o \
- module_d21_r4.o
+ module_d21_r4.o \
+
+ifdef quad
+MODULES += module_d21_r16.o
+endif
OBJS = \
d$(libd)_g.o \
@@ -39,9 +43,18 @@ OBJS = \
dxyzt_block.o \
dxyzt_r4.o \
d$(libd)_r4.o \
- dxyzt_block_r4.o
+ dxyzt_block_r4.o \
+ chemicalp.o
+
+ifdef quad
+OBJS += dxyzt_r16.o \
+ d$(libd)_r16.o \
+ dxyzt_block_r16.o
+endif
+
+
+
-# d_init.o \
R4_FLAGS = -DPRECISION_R4 -DD_R4_INTERNAL
@@ -50,7 +63,8 @@ fast:
$(FAST_MAKE)
module_d21.f90: module_d21.F90; $(fpp) $< > $@
-module_d21_r4.f90: module_d21.F90; $(fpp) $(R4_FLAGS) $< > $@
+module_d21_r4.f90: module_d21.F90; $(fpp) -DPRECISION_R4 $< > $@
+module_d21_r16.f90: module_d21.F90; $(fpp) -DPRECISION_R16 $< > $@
d100.F90: D100.m4; $(M4) -I../../include $(MYFLAGS) D100.m4 >d100.F90
@@ -81,6 +95,12 @@ d$(libd).f90: d$(libd).F90; $(fpp) d$(libd).F90 > d$(libd).f90
dxyzt.f90: dxyzt.F90; $(fpp) dxyzt.F90 > $@
dxyzt_block.f90: dxyzt_block.F90; $(fpp) dxyzt_block.F90 > $@
-d100_r4.f90: d100_r4.F90; $(fpp) d100_r4.F90 > $@
-dxyzt_r4.f90: dxyzt_r4.F90; $(fpp) dxyzt_r4.F90 > $@
-dxyzt_block_r4.f90: dxyzt_block_r4.F90; $(fpp) dxyzt_block_r4.F90 > $@
+d100_r4.f90: d100.F90; $(fpp) -DPRECISION_R4 $< > $@
+dxyzt_r4.f90: dxyzt.F90; $(fpp) -DPRECISION_R4 $< > $@
+dxyzt_block_r4.f90: dxyzt_block.F90; $(fpp) -DPRECISION_R4 $< > $@
+
+d100_r16.f90: d100.F90; $(fpp) -DPRECISION_R16 $< > $@
+dxyzt_r16.f90: dxyzt.F90; $(fpp) -DPRECISION_R16 $< > $@
+dxyzt_block_r16.f90: dxyzt_block.F90; $(fpp) -DPRECISION_R16 $< > $@
+
+#chemicalp.f90: chemicalp.F90; $(fpp) $< > $@
diff --git a/src/fermi/d/libd103.mk b/src/fermi/d/libd103.mk
new file mode 100644
index 0000000000000000000000000000000000000000..f7135d6cfac988e6f9b1d9bd9bf207393f5eda06
--- /dev/null
+++ b/src/fermi/d/libd103.mk
@@ -0,0 +1,121 @@
+#===============================================================================
+#
+# d/libd103.mk - libd100 with SSE for GAMMA_NOTATION=BQCD
+#
+#-------------------------------------------------------------------------------
+#
+# Copyright (C) 2008-2011 Yoshifumi Nakamura, Hinnerk Stueben
+#
+# This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+#
+# BQCD is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# BQCD is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+#
+#===============================================================================
+
+FAST_MAKE = make -j 1
+
+M4=m4
+
+MODULES = \
+ module_d21.o \
+ module_d21_r4.o \
+
+ifdef quad
+MODULES += module_d21_r16.o
+endif
+
+OBJS = \
+ d100_g.o \
+ d103_version.o \
+ d103.o \
+ dxyzt.o \
+ dxyzt_block.o \
+ dxyzt_block2.o \
+ dxyzt_r4.o \
+ d103_r4.o \
+ dxyzt_block_r4.o \
+ dxyzt_block2_r4.o \
+ chemicalp.o
+
+ifdef quad
+OBJS += dxyzt_r16.o \
+ d100_r16.o \
+ dxyzt_block_r16.o
+endif
+
+
+R4_FLAGS = -DPRECISION_R4 -DD_R4_INTERNAL
+
+fast:
+ $(MAKE) $(MODULES)
+ $(FAST_MAKE)
+
+module_d21.f90: module_d21.F90; $(fpp) $< > $@
+module_d21_r4.f90: module_d21.F90; $(fpp) -DPRECISION_R4 $< > $@
+module_d21_r16.f90: module_d21.F90; $(fpp) -DPRECISION_R16 $< > $@
+
+d100.F90: D100.m4; $(M4) -I../../include $(MYFLAGS) D100.m4 >d100.F90
+d103.F90: D103.m4; $(M4) -I../../include $(MYFLAGS) D103.m4 >d103.F90
+
+dxyzt.c: D103.c
+ $(CPP) -I../../include $(CFLAGS_STD) $(MYFLAGS) $< > $@
+
+dxyzt_r4.c: D103_r4.c
+ $(CPP) -I../../include $(CFLAGS_STD) $(MYFLAGS) $< > $@
+
+dxyzt_block2.c: D103_block.c
+ $(CPP) -I../../include $(CFLAGS_STD) $(MYFLAGS) $< > $@
+
+dxyzt_block2_r4.c: D103_block_r4.c
+ $(CPP) -I../../include $(CFLAGS_STD) $(MYFLAGS) $< > $@
+
+dxyzt.c: D103xyzt.c
+dxyzt_r4.c: D103xyzt_r4.c
+dxyzt_block2.c: D103xyzt.c
+dxyzt_block2_r4.c: D103xyzt_r4.c
+
+dxyzt.F90: D100_util.m4
+ $(M4) -I../../include $(MYFLAGS) -DNAME=xf -DDIRECTION=X D100_util.m4 > dxyzt.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=yf -DDIRECTION=Y D100_util.m4 >>dxyzt.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=zf -DDIRECTION=Z D100_util.m4 >>dxyzt.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=t -DDIRECTION=T D100_util.m4 >>dxyzt.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_xf -DDIRECTION=X -DDAGGER D100_util.m4 >>dxyzt.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_yf -DDIRECTION=Y -DDAGGER D100_util.m4 >>dxyzt.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_zf -DDIRECTION=Z -DDAGGER D100_util.m4 >>dxyzt.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_t -DDIRECTION=T -DDAGGER D100_util.m4 >>dxyzt.F90
+
+dxyzt_block.F90: D103_util_block.m4
+ $(M4) -I../../include $(MYFLAGS) -DNAME=x -DDIRECTION=X D103_util_block.m4 > dxyzt_block.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=y -DDIRECTION=Y D103_util_block.m4 >>dxyzt_block.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=z -DDIRECTION=Z D103_util_block.m4 >>dxyzt_block.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=t -DDIRECTION=T D103_util_block.m4 >>dxyzt_block.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_x -DDIRECTION=X -DDAGGER D103_util_block.m4 >>dxyzt_block.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_y -DDIRECTION=Y -DDAGGER D103_util_block.m4 >>dxyzt_block.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_z -DDIRECTION=Z -DDAGGER D103_util_block.m4 >>dxyzt_block.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_t -DDIRECTION=T -DDAGGER D103_util_block.m4 >>dxyzt_block.F90
+
+d100_g.f90: D100_g.F90; $(fpp) D100_g.F90 > $@
+d103_version.f90: DVersion.F90; $(fpp) -DVERSION=103 DVersion.F90 > $@
+
+d103.f90: d103.F90; $(fpp) d103.F90 > d103.f90
+dxyzt_block.f90: dxyzt_block.F90; $(fpp) dxyzt_block.F90 > $@
+
+d103_r4.f90: d103.F90; $(fpp) -DPRECISION_R4 $< > $@
+dxyzt_block_r4.f90: dxyzt_block.F90; $(fpp) -DPRECISION_R4 $< > $@
+
+d100_r16.f90: d100.F90; $(fpp) -DPRECISION_R16 $< > $@
+dxyzt_r16.f90: dxyzt.F90; $(fpp) -DPRECISION_R16 $< > $@
+dxyzt_block_r16.f90: dxyzt_block.F90; $(fpp) -DPRECISION_R16 $< > $@
+
+chemicalp.f90: chemicalp.F90; $(fpp) $< > $@
diff --git a/src/fermi/d/libd2.mk b/src/fermi/d/libd2.mk
index 93f5a27caab44b4bf236fbcf444fb653de3d2d63..d57e0da91901e4d5b64fbb44e51ff78929dcc0aa 100644
--- a/src/fermi/d/libd2.mk
+++ b/src/fermi/d/libd2.mk
@@ -56,7 +56,8 @@ OBJS = \
d2_dag_y_block.o \
d2_dag_z_block.o \
d2_dag_t_block.o \
- d2_version.o
+ d2_version.o \
+ chemicalp.o
R4_FLAGS = -DPRECISION_R4 -DD_R4_INTERNAL
diff --git a/src/fermi/d/libd21.mk b/src/fermi/d/libd21.mk
index 2e61d584012c2b509440d287cdd7dd0e2ad60c82..f6d9f0d0db07f0205ef46f2a74e4102db411caba 100644
--- a/src/fermi/d/libd21.mk
+++ b/src/fermi/d/libd21.mk
@@ -59,7 +59,8 @@ OBJS = \
d21_dag_y_block.o \
d21_dag_z_block.o \
d21_dag_t_block.o \
- d21_version.o
+ d21_version.o \
+ chemicalp.o
R4_FLAGS = -DPRECISION_R4 -DD_R4_INTERNAL
diff --git a/src/fermi/d/libd25.mk b/src/fermi/d/libd25.mk
index 616a6e3e50b56c19aff0c1cde78ce65892641964..b1ed4219666286cdd45ae896f61e35bbe89291af 100644
--- a/src/fermi/d/libd25.mk
+++ b/src/fermi/d/libd25.mk
@@ -56,7 +56,8 @@ OBJS = \
d2_dag_y_block.o \
d2_dag_z_block.o \
d2_dag_t_block.o \
- d25_version.o
+ d25_version.o \
+ chemicalp.o
R4_FLAGS = -DPRECISION_R4 -DD_R4_INTERNAL
diff --git a/src/fermi/d/libd3.mk b/src/fermi/d/libd3.mk
index 8fd75f9509d033f7ce020ee2df9e89809b1774aa..89037b3a523700a37c8f960fc30973bf824c4edd 100644
--- a/src/fermi/d/libd3.mk
+++ b/src/fermi/d/libd3.mk
@@ -49,7 +49,8 @@ OBJS = \
d3_version.o \
d_block.o \
d_projection.o \
- d_xbound.o
+ d_xbound.o \
+ chemicalp.o
R4_FLAGS = -DPRECISION_R4 -DD_R4_INTERNAL
diff --git a/src/fermi/d/libd520.mk b/src/fermi/d/libd520.mk
index 61c08591600d56546e94016197f606fd1979deed..a02c4486bdd2532f54b351f5a43d3743fc9c856c 100644
--- a/src/fermi/d/libd520.mk
+++ b/src/fermi/d/libd520.mk
@@ -42,17 +42,13 @@ OBJS = \
wilson_d520/globals.o \
wilson_d520/adirac.o
-# d45_r4.o \
-# d4_bwd_r4.o \
-# d4_fwd_r4.o \
-# d45_dag_r4.o \
-# d4_dag_bwd_r4.o \
-# d4_dag_fwd_r4.o \
-# d4_bwd.o \
-# d4_fwd.o \
-# d4_dag_bwd.o \
-# d4_dag_fwd.o \
-# d4_g_r4.o \
+ifdef quad
+OBJS += module_d21_r16.o \
+ d100_g.o \
+ d100_r16.o \
+ dxyzt_r16.o \
+ dxyzt_block_r16.o
+endif
R4_FLAGS = -DPRECISION_R4 -DD_R4_INTERNAL
@@ -106,3 +102,31 @@ d520.f90: D520.F90; $(fpp) -DNAME=d -UDAGGER D520.F90 > $@
d520_dag.f90: D520.F90; $(fpp) -DNAME=d_dag -DDAGGER D520.F90 > $@
+d100.F90: D100.m4; $(M4) -I../../include $(MYFLAGS) D100.m4 >d100.F90
+dxyzt.F90: D100_util.m4
+ $(M4) -I../../include $(MYFLAGS) -DNAME=xf -DDIRECTION=X D100_util.m4 > dxyzt.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=yf -DDIRECTION=Y D100_util.m4 >>dxyzt.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=zf -DDIRECTION=Z D100_util.m4 >>dxyzt.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=t -DDIRECTION=T D100_util.m4 >>dxyzt.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_xf -DDIRECTION=X -DDAGGER D100_util.m4 >>dxyzt.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_yf -DDIRECTION=Y -DDAGGER D100_util.m4 >>dxyzt.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_zf -DDIRECTION=Z -DDAGGER D100_util.m4 >>dxyzt.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_t -DDIRECTION=T -DDAGGER D100_util.m4 >>dxyzt.F90
+
+dxyzt_block.F90: D100_util_block.m4
+ $(M4) -I../../include $(MYFLAGS) -DNAME=x -DDIRECTION=X D100_util_block.m4 > dxyzt_block.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=y -DDIRECTION=Y D100_util_block.m4 >>dxyzt_block.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=z -DDIRECTION=Z D100_util_block.m4 >>dxyzt_block.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=t -DDIRECTION=T D100_util_block.m4 >>dxyzt_block.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_x -DDIRECTION=X -DDAGGER D100_util_block.m4 >>dxyzt_block.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_y -DDIRECTION=Y -DDAGGER D100_util_block.m4 >>dxyzt_block.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_z -DDIRECTION=Z -DDAGGER D100_util_block.m4 >>dxyzt_block.F90
+ $(M4) -I../../include $(MYFLAGS) -DNAME=dag_t -DDIRECTION=T -DDAGGER D100_util_block.m4 >>dxyzt_block.F90
+
+
+
+module_d21_r16.f90: module_d21.F90; $(fpp) -DPRECISION_R16 $< > $@
+d100_g.f90: D100_g.F90; $(fpp) -DD520 D100_g.F90 > $@
+d100_r16.f90: d100.F90; $(fpp) -DPRECISION_R16 $< > $@
+dxyzt_r16.f90: dxyzt.F90; $(fpp) -DPRECISION_R16 $< > $@
+dxyzt_block_r16.f90: dxyzt_block.F90; $(fpp) -DPRECISION_R16 $< > $@
diff --git a/src/fermi/dd/dsf_dd.F90 b/src/fermi/dd/dsf_dd.F90
index 0c0319494d6cce818a1ae78bffba558e92c61ea5..3c1e174492658c4e4f0545a7c85b148bf39fa3a8 100644
--- a/src/fermi/dd/dsf_dd.F90
+++ b/src/fermi/dd/dsf_dd.F90
@@ -189,7 +189,7 @@ subroutine dsf_hh2(p, step, calc_sf, sf, id)
call hmc_forces_old(p)
if (mid2 ==0 ) then
- call dsf_mtdagmt_hh(p, step, a, b, mid1,0)
+ call dsf_mtdagmt_hh(p, step, a, b, mid1)
else
if (switches%mass_kappa) then
call dsf_mtdagmt_hh(p, step, a, b, mid1)
diff --git a/src/fermi/dd/init_dd.F90 b/src/fermi/dd/init_dd.F90
index 68a4b4ffb7bac23f216cdfafd6983aa24d90b6e0..5aea1da539ab2c6f25e032438da2aa000da68900 100644
--- a/src/fermi/dd/init_dd.F90
+++ b/src/fermi/dd/init_dd.F90
@@ -142,6 +142,7 @@ subroutine init_dd()
end
!-------------------------------------------------------------------------------
subroutine init_ddeo_count(nn)
+ use module_function_decl
use module_dd
implicit none
type(type_nn) :: nn
@@ -189,6 +190,28 @@ subroutine init_ddeo_count(nn)
! enddo
!stop
+#ifdef DEBUG2
+if (my_pe()==0) then
+write(0,*) nn%count_dd(0,1,FWD)+nn%count_dd(0,1,BWD)
+write(0,*) nn%count_dd(0,2,FWD)+nn%count_dd(0,2,BWD)
+write(0,*) nn%count_dd(0,3,FWD)+nn%count_dd(0,3,BWD)
+write(0,*) nn%count_dd(0,4,FWD)+nn%count_dd(0,4,BWD)
+write(0,*) nn%count_dd(1,1,FWD)+nn%count_dd(1,1,BWD)
+write(0,*) nn%count_dd(1,2,FWD)+nn%count_dd(1,2,BWD)
+write(0,*) nn%count_dd(1,3,FWD)+nn%count_dd(1,3,BWD)
+write(0,*) nn%count_dd(1,4,FWD)+nn%count_dd(1,4,BWD)
+
+write(0,*) nn%count_eo(0,1,FWD)+nn%count_eo(0,1,BWD)
+write(0,*) nn%count_eo(0,2,FWD)+nn%count_eo(0,2,BWD)
+write(0,*) nn%count_eo(0,3,FWD)+nn%count_eo(0,3,BWD)
+write(0,*) nn%count_eo(0,4,FWD)+nn%count_eo(0,4,BWD)
+write(0,*) nn%count_eo(1,1,FWD)+nn%count_eo(1,1,BWD)
+write(0,*) nn%count_eo(1,2,FWD)+nn%count_eo(1,2,BWD)
+write(0,*) nn%count_eo(1,3,FWD)+nn%count_eo(1,3,BWD)
+write(0,*) nn%count_eo(1,4,FWD)+nn%count_eo(1,4,BWD)
+endif
+#endif
+
do mu=1,DIM
if (nn%count_eo(EVEN,mu,FWD)/=nn%count_eo(EVEN,mu,BWD)) call warn("init_ddeo_count: count_ef/=count_eb")
if (nn%count_eo(EVEN,mu,FWD)/=nn%count_eo(ODD ,mu,FWD)) call warn("init_ddeo_count: count_ef/=count_of")
diff --git a/src/fermi/dd/mult_dd.F90_v2 b/src/fermi/dd/mult_dd.F90_v2
index 0abba49e00a0c8e246fd93364123df3f4231521d..04c0e6047c316cc55b154f718bd7a8b3f5d3cb1b 100644
--- a/src/fermi/dd/mult_dd.F90_v2
+++ b/src/fermi/dd/mult_dd.F90_v2
@@ -402,8 +402,8 @@ end
subroutine inv_unprec_mmul_dd_ip(out_e, out_o, in_e, in_o, id, ip, dag)
use module_dd
use module_action
- use module_mre2
- use mre2_get_interface
+!! use module_mre2
+!! use mre2_get_interface
implicit none
COMPLEX, dimension (12*ld%lat%volh) :: out_e, out_o
COMPLEX, dimension (12*ld%lat%volh) :: in_e, in_o
diff --git a/src/fermi/f_action/dsf.F90 b/src/fermi/f_action/dsf.F90
index cf80ff91a4b2398cc3cd346b9a14c44ad341dd9d..5b8045a4f725523e7d24314f3159cfd1de020c94 100644
--- a/src/fermi/f_action/dsf.F90
+++ b/src/fermi/f_action/dsf.F90
@@ -109,6 +109,11 @@ subroutine dsf_sum(w, w1, w2, step, a, b, id)
REAL :: s, s1, s2
integer :: ierr
+ REAL :: fac1, fac2
+ fac1=exp( chemi)
+ fac2=exp(-chemi)
+
+
TIMING_START(timing_bin_dsf_sum)
DEBUG2S("Start: dsf_sum")
@@ -141,7 +146,7 @@ subroutine dsf_sum(w, w1, w2, step, a, b, id)
s2 = -step * TWO * (action%mtilde(id)%cswkappa / EIGHT) * action%mtilde(id)%kappa**2
#ifdef OMTDTD
! ALLOCATE_SC_FIELD(tmp)
- tmp = b
+ call sc_copy(tmp, b)
if (s1 /= ZERO) then
call clover_mult_b(clover(action%mtilde(id)%cid)%b(1,1,se), tmp, volh)
endif
@@ -157,7 +162,11 @@ subroutine dsf_sum(w, w1, w2, step, a, b, id)
call scfield_reorder_43_to_34(at)
#endif
call sc_zero_halo(at)
+
+ if (chemi /=0) call emuu4(gauge(2)%u, fac1, fac2, .false.)
call d(se, so, bt, at, gauge(2)%u(1,1,1,0,1))
+ if (chemi /=0) call emuu4(gauge(2)%u, ONE, ONE, .false.)
+
call xbound_sc_field(at)
call clover_mult_b(clover(action%mtilde(id)%cid)%b(1,1,se), bt, volh)
#ifdef FLIPSC
@@ -289,6 +298,7 @@ end
!-------------------------------------------------------------------------------
subroutine dsf_at_bt(at, bt, a, b, k, ck, h, cid, e)
+ use module_action
use module_field
use module_vol
implicit none
@@ -298,6 +308,9 @@ subroutine dsf_at_bt(at, bt, a, b, k, ck, h, cid, e)
integer, intent(in) :: e, cid
integer :: o
+ REAL :: fac1, fac2
+
+
if (k == ZERO) return
TIMING_START(timing_bin_dsf_at_bt)
@@ -307,8 +320,17 @@ subroutine dsf_at_bt(at, bt, a, b, k, ck, h, cid, e)
call sc_zero_halo(b)
o = 1 - e
+
+ fac1=exp( chemi)
+ fac2=exp(-chemi)
+ if (chemi /=0) call emuu4(gauge(2)%u, fac1, fac2, .false.)
call d( o, e, at, a, gauge(2)%u(1,1,1,0,1)) ! A~ = Doe A
+ if (chemi /=0) call emuu4(gauge(2)%u, ONE, ONE, .false.)
+
+ if (chemi /=0) call emuu4(gauge(2)%u, fac2, fac1, .false.)
call d_dag(o, e, bt, b, gauge(2)%u(1,1,1,0,1)) ! B~ = Deo+ B
+ if (chemi /=0) call emuu4(gauge(2)%u, ONE, ONE, .false.)
+
if (ck /= ZERO) then
call clover_mult_b(clover(cid)%b(1,1,o), at, volh) ! A~ = inv(Too) A~
call clover_mult_b(clover(cid)%b(1,1,o), bt, volh) ! B~ = inv(Too) B~
@@ -405,7 +427,7 @@ subroutine dsf_xyztfb_w(w_add, u, s, a, b, at, bt, e)
#endif
call flip_bc(w)
- do mu = 1, DIM
+ do mu = 1, 3
do eo = EVEN, ODD
!$omp parallel do
do i = 1, volh
@@ -414,6 +436,18 @@ subroutine dsf_xyztfb_w(w_add, u, s, a, b, at, bt, e)
enddo
enddo
enddo
+ !$omp parallel do
+ do i = 1, volh
+ call u_scale(w(1, 1, i, e, 4), s*exp(chemi))
+ call u_add(w_add(1, 1, i, e, 4), w(1, 1, i, e, 4))
+ enddo
+ !$omp parallel do
+ do i = 1, volh
+ call u_scale(w(1, 1, i, o, 4), s*exp(chemi))
+ call u_add(w_add(1, 1, i, o, 4), w(1, 1, i, o, 4))
+ enddo
+
+
#ifdef GAMMA_NOTATION_CHROMA
call dsf_b_dcmp_1_m_gamma1(w(1,1,1,e,1), bt, a, nn(1,e,1,FWD))
@@ -458,14 +492,14 @@ subroutine dsf_xyztfb_w(w_add, u, s, a, b, at, bt, e)
!$omp parallel do private(v)
do i = 1, volh
call uud(v, w(1, 1, i, eo, mu), u(1, 1, i, eo, mu))
- call udu(w(1, 1, i, eo, mu), u(1, 1, i, eo, mu), v)
+ call udu(w(1, 1, i, eo, mu), u(1, 1, i, eo, mu), v) !! to cancel later
enddo
enddo
enddo
call flip_bc(w)
- do mu = 1, DIM
+ do mu = 1, 3
do eo = EVEN, ODD
!$omp parallel do
do i = 1, volh
@@ -474,6 +508,18 @@ subroutine dsf_xyztfb_w(w_add, u, s, a, b, at, bt, e)
enddo
enddo
enddo
+ !$omp parallel do
+ do i = 1, volh
+ call u_scale(w(1, 1, i, o, 4), -s*exp(-chemi))
+ call u_add(w_add(1, 1, i, o, 4), w(1, 1, i, o, 4))
+ enddo
+ !$omp parallel do
+ do i = 1, volh
+ call u_scale(w(1, 1, i, e, 4), -s*exp(-chemi))
+ call u_add(w_add(1, 1, i, e, 4), w(1, 1, i, e, 4))
+ enddo
+
+
deallocate(w, STAT = ierr)
if (ierr /= 0) then
diff --git a/src/fermi/f_action/dsf_mtmp.F90 b/src/fermi/f_action/dsf_mtmp.F90
index 2c8fa94e2c1afc748f554d3a831c6d2079fdbbf6..f2e215f20869e6b995b151e16b03c02428932676 100644
--- a/src/fermi/f_action/dsf_mtmp.F90
+++ b/src/fermi/f_action/dsf_mtmp.F90
@@ -40,9 +40,9 @@ subroutine dsf_mtmp(p, step, calc_sf, sf, fermiid)
integer, intent(in) :: fermiid, calc_sf
REAL, intent(in) :: step
REAL, intent(out) :: sf
-!! P_SPINCOL_FIELD, save :: a, b
- COMPLEX, allocatable :: a(:,:,:)
- COMPLEX, allocatable :: b(:,:,:)
+ P_SPINCOL_FIELD, save :: a, b
+!! COMPLEX, allocatable :: a(:,:,:)
+!! COMPLEX, allocatable :: b(:,:,:)
REAL, external :: dotprod
integer :: ierr
@@ -55,18 +55,18 @@ subroutine dsf_mtmp(p, step, calc_sf, sf, fermiid)
DEBUG2S("Start: dsf_mtmp")
call init_quark(action%fermi(fermiid)%mid1)
call init_quark(action%fermi(fermiid)%mid2)
-!! ALLOCATE_SC_FIELD(a)
-!! ALLOCATE_SC_FIELD(b)
- allocate(a(NDIRAC,NCOL,volh_tot), STAT = ierr)
- if (ierr /= 0) then
- call stderr2_int("allocation failed", 1, ierr)
- call die("dsf_mtmp: allocation failed a")
- endif
- allocate(b(NDIRAC,NCOL,volh_tot), STAT = ierr)
- if (ierr /= 0) then
- call stderr2_int("allocation failed", 1, ierr)
- call die("dsf_mtmp: allocation failed b")
- endif
+ ALLOCATE_SC_FIELD(a)
+ ALLOCATE_SC_FIELD(b)
+!! allocate(a(NDIRAC,NCOL,volh_tot), STAT = ierr)
+!! if (ierr /= 0) then
+!! call stderr2_int("allocation failed", 1, ierr)
+!! call die("dsf_mtmp: allocation failed a")
+!! endif
+!! allocate(b(NDIRAC,NCOL,volh_tot), STAT = ierr)
+!! if (ierr /= 0) then
+!! call stderr2_int("allocation failed", 1, ierr)
+!! call die("dsf_mtmp: allocation failed b")
+!! endif
if (action%fermi(fermiid)%mid2 /=0 ) then
@@ -115,16 +115,16 @@ subroutine dsf_mtmp(p, step, calc_sf, sf, fermiid)
call hmc_forces_new(p, step, action%fermi(fermiid)%fid)
TIMING_STOP(timing_bin_dsf)
- deallocate(a, STAT = ierr)
- if (ierr /= 0) then
- call stderr2_int("deallocation failed", 1, ierr)
- call die("dsf_mtmp: deallocation failed a")
- endif
- deallocate(b, STAT = ierr)
- if (ierr /= 0) then
- call stderr2_int("deallocation failed", 1, ierr)
- call die("dsf_mtmp: deallocation failed b")
- endif
+!! deallocate(a, STAT = ierr)
+!! if (ierr /= 0) then
+!! call stderr2_int("deallocation failed", 1, ierr)
+!! call die("dsf_mtmp: deallocation failed a")
+!! endif
+!! deallocate(b, STAT = ierr)
+!! if (ierr /= 0) then
+!! call stderr2_int("deallocation failed", 1, ierr)
+!! call die("dsf_mtmp: deallocation failed b")
+!! endif
DEBUG2S("End: dsf_mtmp")
TIMING_STOP(timing_bin_dsf_mtmp)
diff --git a/src/fermi/f_action/fermi_action.F90 b/src/fermi/f_action/fermi_action.F90
index aa0244c8c62b9b1c4a5ad331ad32281a49641673..933c108695f5c1c37d8e06991c01bfb8cc557e37 100644
--- a/src/fermi/f_action/fermi_action.F90
+++ b/src/fermi/f_action/fermi_action.F90
@@ -172,6 +172,10 @@ subroutine fermi_action_mtdagmt_dd(fid, inout, sf, init)
mid1 = action%fermi(fid)%mid1
mid2 = action%fermi(fid)%mid2
+ if (.not. ddable) then
+ call die("fermi_action_mtdagmt_dd is called, but DD is not able")
+ endif
+
if (init) then
call random_sc_field_dd(tmp)
sf = dotprod(tmp, tmp, SIZE_SC_FIELD)
@@ -215,6 +219,10 @@ subroutine fermi_action_mtdagmt_hh(fid, inout, sf, init)
mid1 = action%fermi(fid)%mid1
mid2 = action%fermi(fid)%mid2
+ if (.not. ddable) then
+ call die("fermi_action_mtdagmt_dd is called, but DD is not able")
+ endif
+
if (init) then
call random_sc_field_hh(tmp)
sf = dotprod(tmp, tmp, SIZE_SC_FIELD)
diff --git a/src/fermi/mult/Makefile b/src/fermi/mult/Makefile
index b583c728ae07f571a9a68e879e3d4bf0db29cf2a..4ad2f0ddd5dbfb63d7c88988f3680d8ca488c8d3 100644
--- a/src/fermi/mult/Makefile
+++ b/src/fermi/mult/Makefile
@@ -4,7 +4,7 @@
#
#-------------------------------------------------------------------------------
#
-# Copyright (C) 2006 Yoshifumi Nakamura
+# Copyright (C) 2006, 2010 Yoshifumi Nakamura
#
# This file is part of BQCD -- Berlin Quantum ChromoDynamics program
#
@@ -26,7 +26,7 @@ DIR= ../../
include $(DIR)Makefile.in
MODULES_DIR = $(DIR)/modules
-FAST_MAKE = make -j 1
+FAST_MAKE = $(MAKE) -j 1
ifdef FPP2
fpp = $(FPP2) -I$(DIR)include $(MYFLAGS)
@@ -34,19 +34,40 @@ else
fpp = $(FPP) -I$(DIR)include $(MYFLAGS)
endif
+cc = $(CC) -c -I ../../include $(CFLAGS) $(MYFLAGS)
+
+
.SUFFIXES:
.SUFFIXES: .a .o .F90 .cc .c
.F90.o:
- $(fpp) -I../../include $(MYFLAGS) $< > $*.f90
+ $(fpp) $< > $*.f90
$(F90) -c $(FFLAGS) $*.f90
.cc.o:
$(CCPP) $(CFLAGS) -c -o $@ $<
-OBJS = \
+.c.o:
+ $(cc) -o $@ $<
+
+OBJS_CLOVER = \
+ clover_mult_ao.o \
+ clover_mult_ao_r4.o \
clover_mult.o \
- clover_mult_r4.o \
+ clover_mult_r4.o
+
+ifeq ($(libd),103)
+OBJS_CLOVER = \
+ clover_mult_ao_sse.o \
+ clover_mult_ao_sse_r4.o \
+ clover_mult_ao_block_sse.o \
+ clover_mult_ao_block_sse_r4.o \
+ clover_mult.o \
+ clover_mult_r4.o
+endif
+
+OBJS = \
+ $(OBJS_CLOVER) \
m_tilde.o \
m_tilde_r4.o \
m_tilde_r8.o \
@@ -59,6 +80,16 @@ OBJS = \
w_mult_block.o \
w_mult_block_r4.o
+ifdef quad
+OBJS += \
+ clover_mult_ao_r16.o \
+ clover_mult_r16.o \
+ m_tilde_r16.o \
+ w_mult_r16.o \
+ h_mult_r16.o \
+ w_mult_block_r16.o
+endif
+
ifdef BAGEL
OBJS += bqcd_bagel.o support_bagel.o
endif
@@ -73,5 +104,54 @@ clobber:
rm -f *.[Tiod] *.f90 *.mod
rm -f lib_mult.a
+clover_mult_r4.o: clover_mult.F90
+ $(fpp) -DPRECISION_R4 $< > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
+
+clover_mult_ao_r4.o: clover_mult_ao.F90
+ $(fpp) -DPRECISION_R4 $< > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
+
+clover_mult_r16.o: clover_mult.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
+
+clover_mult_ao_r16.o: clover_mult_ao.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
+
+clover_mult_ao_block_sse.o: clover_mult_ao_sse.c
+ $(cc) -DBLOCK -o $@ $<
+
+clover_mult_ao_block_sse_r4.o: clover_mult_ao_sse_r4.c
+ $(cc) -DBLOCK -o $@ $<
+
+m_tilde_r8.o: m_tilde.F90
+m_tilde_r4.o: m_tilde.F90
+ $(fpp) -DPRECISION_R4 $< > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
+m_tilde_r16.o: m_tilde.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
+
+w_mult_r4.o: w_mult.F90
+ $(fpp) -DPRECISION_R4 $< > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
+w_mult_r16.o: w_mult.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
+
+h_mult_r4.o: h_mult.F90
+ $(fpp) -DPRECISION_R4 $< > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
+h_mult_r16.o: h_mult.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
+
w_mult_block.o: m_mult_block.h90 m_mult_omtdtd_block.h90
w_mult_block_r4.o: m_mult_block.h90 m_mult_omtdtd_block.h90 w_mult_block.F90
+ $(fpp) -DPRECISION_R4 w_mult_block_r4.F90 > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
+w_mult_block_r16.o: m_mult_block.h90 m_mult_omtdtd_block.h90 w_mult_block.F90
+ $(fpp) -DPRECISION_R16 w_mult_block.F90 > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
diff --git a/src/fermi/mult/clover_mult.F90 b/src/fermi/mult/clover_mult.F90
index 0e5467cdfa4101489363a39a2f8db9ed0dfcd0fb..1085eac54c242b59b426b1012e0bc1d81bbc7568 100644
--- a/src/fermi/mult/clover_mult.F90
+++ b/src/fermi/mult/clover_mult.F90
@@ -1,10 +1,10 @@
!===============================================================================
!
-! clover_mult_a.F90
+! clover_mult.F90
!
!-------------------------------------------------------------------------------
!
-! Copyright (C) 1998-2001, 2008 Hinnerk Stueben
+! Copyright (C) 1998-2011 Hinnerk Stueben
! 2008 Yoshifumi Nakamura
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
@@ -250,118 +250,6 @@ subroutine clover_mult_b(b, x, volh) ! x := B x
TIMING_STOP(timing_bin_clover_mult_b)
end
-!-------------------------------------------------------------------------------
-subroutine clover_mult_ao(a, x, volh) ! x := A x
-
- implicit none
-
- COMPLEX, dimension(18, 2, *) :: a
-#ifdef FLIPSC
- COMPLEX, dimension(NCOL, NDIRAC, *) :: x
-#else
- COMPLEX, dimension(NDIRAC, NCOL, *) :: x
-#endif
- integer :: volh
-
- integer :: i
- COMPLEX :: x1, x2, x3, x4, x5, x6
- COMPLEX :: y1, y2, y3, y4, y5, y6
-
- TIMING_START(timing_bin_clover_mult_ao)
-
-#ifdef IBM
- call alignx(16, x(1,1,1))
- call alignx(16, a(1,1,1))
-#endif
- !$omp parallel do private(x1, x2, x3, x4, x5, x6, y1, y2, y3, y4, y5, y6)
- do i = 1, volh
-
-#ifdef GAMMAC
- x1 = x(SC1, i)
- x2 = x(SC2, i)
- x3 = x(SC3, i)
- x4 = x(SC4, i)
- x5 = x(SC5, i)
- x6 = x(SC6, i)
-#else
- x1 = x(SC1, i) + x(SC7, i)
- x2 = x(SC2, i) + x(SC8, i)
- x3 = x(SC3, i) + x(SC9, i)
- x4 = x(SC4, i) + x(SC10, i)
- x5 = x(SC5, i) + x(SC11, i)
- x6 = x(SC6, i) + x(SC12, i)
-#endif
-
-# undef J
-# define J 1
-# include "clover_mult_a.h90"
-
-#ifdef GAMMAC
- x(SC1, i) = y1
- x(SC2, i) = y2
- x(SC3, i) = y3
- x(SC4, i) = y4
- x(SC5, i) = y5
- x(SC6, i) = y6
- x1 = x(SC7, i)
- x2 = x(SC8, i)
- x3 = x(SC9, i)
- x4 = x(SC10, i)
- x5 = x(SC11, i)
- x6 = x(SC12, i)
-#else
- x1 = x(SC1, i) - x(SC7, i)
- x2 = x(SC2, i) - x(SC8, i)
- x3 = x(SC3, i) - x(SC9, i)
- x4 = x(SC4, i) - x(SC10, i)
- x5 = x(SC5, i) - x(SC11, i)
- x6 = x(SC6, i) - x(SC12, i)
-
- x(SC1, i) = y1
- x(SC2, i) = y2
- x(SC3, i) = y3
- x(SC4, i) = y4
- x(SC5, i) = y5
- x(SC6, i) = y6
- x(SC7, i) = y1
- x(SC8, i) = y2
- x(SC9, i) = y3
- x(SC10, i) = y4
- x(SC11, i) = y5
- x(SC12, i) = y6
-#endif
-
-# undef J
-# define J 2
-# include "clover_mult_a.h90"
-
-#ifdef GAMMAC
- x(SC7, i) = y1
- x(SC8, i) = y2
- x(SC9, i) = y3
- x(SC10, i) = y4
- x(SC11, i) = y5
- x(SC12, i) = y6
-#else
- x(SC1, i) = x(SC1, i) + y1
- x(SC2, i) = x(SC2, i) + y2
- x(SC3, i) = x(SC3, i) + y3
- x(SC4, i) = x(SC4, i) + y4
- x(SC5, i) = x(SC5, i) + y5
- x(SC6, i) = x(SC6, i) + y6
- x(SC7, i) = x(SC7, i) - y1
- x(SC8, i) = x(SC8, i) - y2
- x(SC9, i) = x(SC9, i) - y3
- x(SC10, i) = x(SC10, i) - y4
- x(SC11, i) = x(SC11, i) - y5
- x(SC12, i) = x(SC12, i) - y6
-#endif
-
- enddo
-
- TIMING_STOP(timing_bin_clover_mult_ao)
-end
-
!-------------------------------------------------------------------------------
subroutine clover_mult_a2_block(out, b, a, in, i1, i2) ! out := A in
@@ -474,15 +362,15 @@ subroutine clover_mult_a2_block(out, b, a, in, i1, i2) ! out := A in
end
!-------------------------------------------------------------------------------
-subroutine clover_mult_ao_block(a, x, i1, i2) ! x := A x
+subroutine clover_mult_ao2_block(out, a, in, i1, i2) ! out := A in
implicit none
COMPLEX, dimension(18, 2, *) :: a
#ifdef FLIPSC
- COMPLEX, dimension(NCOL, NDIRAC, *) :: x
+ COMPLEX, dimension(NCOL, NDIRAC, *) :: out, in
#else
- COMPLEX, dimension(NDIRAC, NCOL, *) :: x
+ COMPLEX, dimension(NDIRAC, NCOL, *) :: out, in
#endif
integer :: i1, i2
@@ -492,25 +380,26 @@ subroutine clover_mult_ao_block(a, x, i1, i2) ! x := A x
!!TIMING_START(timing_bin_clover_mult_ao)
#ifdef IBM
- call alignx(16, x(1,1,1))
+ call alignx(16, out(1,1,1))
+ call alignx(16, in(1,1,1))
call alignx(16, a(1,1,1))
#endif
do i = i1, i2
#ifdef GAMMAC
- x1 = x(SC1, i)
- x2 = x(SC2, i)
- x3 = x(SC3, i)
- x4 = x(SC4, i)
- x5 = x(SC5, i)
- x6 = x(SC6, i)
+ x1 = in(SC1, i)
+ x2 = in(SC2, i)
+ x3 = in(SC3, i)
+ x4 = in(SC4, i)
+ x5 = in(SC5, i)
+ x6 = in(SC6, i)
#else
- x1 = x(SC1, i) + x(SC7, i)
- x2 = x(SC2, i) + x(SC8, i)
- x3 = x(SC3, i) + x(SC9, i)
- x4 = x(SC4, i) + x(SC10, i)
- x5 = x(SC5, i) + x(SC11, i)
- x6 = x(SC6, i) + x(SC12, i)
+ x1 = in(SC1, i) + in(SC7, i)
+ x2 = in(SC2, i) + in(SC8, i)
+ x3 = in(SC3, i) + in(SC9, i)
+ x4 = in(SC4, i) + in(SC10, i)
+ x5 = in(SC5, i) + in(SC11, i)
+ x6 = in(SC6, i) + in(SC12, i)
#endif
# undef J
@@ -518,38 +407,38 @@ subroutine clover_mult_ao_block(a, x, i1, i2) ! x := A x
# include "clover_mult_a.h90"
#ifdef GAMMAC
- x(SC1, i) = y1
- x(SC2, i) = y2
- x(SC3, i) = y3
- x(SC4, i) = y4
- x(SC5, i) = y5
- x(SC6, i) = y6
- x1 = x(SC7, i)
- x2 = x(SC8, i)
- x3 = x(SC9, i)
- x4 = x(SC10, i)
- x5 = x(SC11, i)
- x6 = x(SC12, i)
+ out(SC1, i) = y1
+ out(SC2, i) = y2
+ out(SC3, i) = y3
+ out(SC4, i) = y4
+ out(SC5, i) = y5
+ out(SC6, i) = y6
+ x1 = in(SC7, i)
+ x2 = in(SC8, i)
+ x3 = in(SC9, i)
+ x4 = in(SC10, i)
+ x5 = in(SC11, i)
+ x6 = in(SC12, i)
#else
- x1 = x(SC1, i) - x(SC7, i)
- x2 = x(SC2, i) - x(SC8, i)
- x3 = x(SC3, i) - x(SC9, i)
- x4 = x(SC4, i) - x(SC10, i)
- x5 = x(SC5, i) - x(SC11, i)
- x6 = x(SC6, i) - x(SC12, i)
-
- x(SC1, i) = y1
- x(SC2, i) = y2
- x(SC3, i) = y3
- x(SC4, i) = y4
- x(SC5, i) = y5
- x(SC6, i) = y6
- x(SC7, i) = y1
- x(SC8, i) = y2
- x(SC9, i) = y3
- x(SC10, i) = y4
- x(SC11, i) = y5
- x(SC12, i) = y6
+ x1 = in(SC1, i) - in(SC7, i)
+ x2 = in(SC2, i) - in(SC8, i)
+ x3 = in(SC3, i) - in(SC9, i)
+ x4 = in(SC4, i) - in(SC10, i)
+ x5 = in(SC5, i) - in(SC11, i)
+ x6 = in(SC6, i) - in(SC12, i)
+
+ out(SC1, i) = y1
+ out(SC2, i) = y2
+ out(SC3, i) = y3
+ out(SC4, i) = y4
+ out(SC5, i) = y5
+ out(SC6, i) = y6
+ out(SC7, i) = y1
+ out(SC8, i) = y2
+ out(SC9, i) = y3
+ out(SC10, i) = y4
+ out(SC11, i) = y5
+ out(SC12, i) = y6
#endif
# undef J
@@ -557,25 +446,25 @@ subroutine clover_mult_ao_block(a, x, i1, i2) ! x := A x
# include "clover_mult_a.h90"
#ifdef GAMMAC
- x(SC7, i) = y1
- x(SC8, i) = y2
- x(SC9, i) = y3
- x(SC10, i) = y4
- x(SC11, i) = y5
- x(SC12, i) = y6
+ out(SC7, i) = y1
+ out(SC8, i) = y2
+ out(SC9, i) = y3
+ out(SC10, i) = y4
+ out(SC11, i) = y5
+ out(SC12, i) = y6
#else
- x(SC1, i) = x(SC1, i) + y1
- x(SC2, i) = x(SC2, i) + y2
- x(SC3, i) = x(SC3, i) + y3
- x(SC4, i) = x(SC4, i) + y4
- x(SC5, i) = x(SC5, i) + y5
- x(SC6, i) = x(SC6, i) + y6
- x(SC7, i) = x(SC7, i) - y1
- x(SC8, i) = x(SC8, i) - y2
- x(SC9, i) = x(SC9, i) - y3
- x(SC10, i) = x(SC10, i) - y4
- x(SC11, i) = x(SC11, i) - y5
- x(SC12, i) = x(SC12, i) - y6
+ out(SC1, i) = out(SC1, i) + y1
+ out(SC2, i) = out(SC2, i) + y2
+ out(SC3, i) = out(SC3, i) + y3
+ out(SC4, i) = out(SC4, i) + y4
+ out(SC5, i) = out(SC5, i) + y5
+ out(SC6, i) = out(SC6, i) + y6
+ out(SC7, i) = out(SC7, i) - y1
+ out(SC8, i) = out(SC8, i) - y2
+ out(SC9, i) = out(SC9, i) - y3
+ out(SC10, i) = out(SC10, i) - y4
+ out(SC11, i) = out(SC11, i) - y5
+ out(SC12, i) = out(SC12, i) - y6
#endif
enddo
diff --git a/src/fermi/mult/clover_mult_ao.F90 b/src/fermi/mult/clover_mult_ao.F90
new file mode 100644
index 0000000000000000000000000000000000000000..1637591aa4e0905f8253885f95a6240175306543
--- /dev/null
+++ b/src/fermi/mult/clover_mult_ao.F90
@@ -0,0 +1,249 @@
+!===============================================================================
+!
+! clover_mult_ao.F90
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 1998-2011 Hinnerk Stueben
+! 2008 Yoshifumi Nakamura
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+# define CLOVER_AS_COMPLEX_ARRAY
+# include "defs.h"
+# include "clover.h"
+
+!-------------------------------------------------------------------------------
+subroutine clover_mult_ao(a, x, volh) ! x := A x
+
+ implicit none
+
+ COMPLEX, dimension(18, 2, *) :: a
+#ifdef FLIPSC
+ COMPLEX, dimension(NCOL, NDIRAC, *) :: x
+#else
+ COMPLEX, dimension(NDIRAC, NCOL, *) :: x
+#endif
+ integer :: volh
+
+ integer :: i
+ COMPLEX :: x1, x2, x3, x4, x5, x6
+ COMPLEX :: y1, y2, y3, y4, y5, y6
+
+ TIMING_START(timing_bin_clover_mult_ao)
+
+#ifdef IBM
+ call alignx(16, x(1,1,1))
+ call alignx(16, a(1,1,1))
+#endif
+ !$omp parallel do private(x1, x2, x3, x4, x5, x6, y1, y2, y3, y4, y5, y6)
+ do i = 1, volh
+
+#ifdef GAMMAC
+ x1 = x(SC1, i)
+ x2 = x(SC2, i)
+ x3 = x(SC3, i)
+ x4 = x(SC4, i)
+ x5 = x(SC5, i)
+ x6 = x(SC6, i)
+#else
+ x1 = x(SC1, i) + x(SC7, i)
+ x2 = x(SC2, i) + x(SC8, i)
+ x3 = x(SC3, i) + x(SC9, i)
+ x4 = x(SC4, i) + x(SC10, i)
+ x5 = x(SC5, i) + x(SC11, i)
+ x6 = x(SC6, i) + x(SC12, i)
+#endif
+
+# undef J
+# define J 1
+# include "clover_mult_a.h90"
+
+#ifdef GAMMAC
+ x(SC1, i) = y1
+ x(SC2, i) = y2
+ x(SC3, i) = y3
+ x(SC4, i) = y4
+ x(SC5, i) = y5
+ x(SC6, i) = y6
+ x1 = x(SC7, i)
+ x2 = x(SC8, i)
+ x3 = x(SC9, i)
+ x4 = x(SC10, i)
+ x5 = x(SC11, i)
+ x6 = x(SC12, i)
+#else
+ x1 = x(SC1, i) - x(SC7, i)
+ x2 = x(SC2, i) - x(SC8, i)
+ x3 = x(SC3, i) - x(SC9, i)
+ x4 = x(SC4, i) - x(SC10, i)
+ x5 = x(SC5, i) - x(SC11, i)
+ x6 = x(SC6, i) - x(SC12, i)
+
+ x(SC1, i) = y1
+ x(SC2, i) = y2
+ x(SC3, i) = y3
+ x(SC4, i) = y4
+ x(SC5, i) = y5
+ x(SC6, i) = y6
+ x(SC7, i) = y1
+ x(SC8, i) = y2
+ x(SC9, i) = y3
+ x(SC10, i) = y4
+ x(SC11, i) = y5
+ x(SC12, i) = y6
+#endif
+
+# undef J
+# define J 2
+# include "clover_mult_a.h90"
+
+#ifdef GAMMAC
+ x(SC7, i) = y1
+ x(SC8, i) = y2
+ x(SC9, i) = y3
+ x(SC10, i) = y4
+ x(SC11, i) = y5
+ x(SC12, i) = y6
+#else
+ x(SC1, i) = x(SC1, i) + y1
+ x(SC2, i) = x(SC2, i) + y2
+ x(SC3, i) = x(SC3, i) + y3
+ x(SC4, i) = x(SC4, i) + y4
+ x(SC5, i) = x(SC5, i) + y5
+ x(SC6, i) = x(SC6, i) + y6
+ x(SC7, i) = x(SC7, i) - y1
+ x(SC8, i) = x(SC8, i) - y2
+ x(SC9, i) = x(SC9, i) - y3
+ x(SC10, i) = x(SC10, i) - y4
+ x(SC11, i) = x(SC11, i) - y5
+ x(SC12, i) = x(SC12, i) - y6
+#endif
+
+ enddo
+
+ TIMING_STOP(timing_bin_clover_mult_ao)
+end
+
+!-------------------------------------------------------------------------------
+subroutine clover_mult_ao_block(a, x, i1, i2) ! x := A x
+
+ implicit none
+
+ COMPLEX, dimension(18, 2, *) :: a
+#ifdef FLIPSC
+ COMPLEX, dimension(NCOL, NDIRAC, *) :: x
+#else
+ COMPLEX, dimension(NDIRAC, NCOL, *) :: x
+#endif
+ integer :: i1, i2
+
+ integer :: i
+ COMPLEX :: x1, x2, x3, x4, x5, x6
+ COMPLEX :: y1, y2, y3, y4, y5, y6
+
+#ifdef IBM
+ call alignx(16, x(1,1,1))
+ call alignx(16, a(1,1,1))
+#endif
+ do i = i1, i2
+
+#ifdef GAMMAC
+ x1 = x(SC1, i)
+ x2 = x(SC2, i)
+ x3 = x(SC3, i)
+ x4 = x(SC4, i)
+ x5 = x(SC5, i)
+ x6 = x(SC6, i)
+#else
+ x1 = x(SC1, i) + x(SC7, i)
+ x2 = x(SC2, i) + x(SC8, i)
+ x3 = x(SC3, i) + x(SC9, i)
+ x4 = x(SC4, i) + x(SC10, i)
+ x5 = x(SC5, i) + x(SC11, i)
+ x6 = x(SC6, i) + x(SC12, i)
+#endif
+
+# undef J
+# define J 1
+# include "clover_mult_a.h90"
+
+#ifdef GAMMAC
+ x(SC1, i) = y1
+ x(SC2, i) = y2
+ x(SC3, i) = y3
+ x(SC4, i) = y4
+ x(SC5, i) = y5
+ x(SC6, i) = y6
+ x1 = x(SC7, i)
+ x2 = x(SC8, i)
+ x3 = x(SC9, i)
+ x4 = x(SC10, i)
+ x5 = x(SC11, i)
+ x6 = x(SC12, i)
+#else
+ x1 = x(SC1, i) - x(SC7, i)
+ x2 = x(SC2, i) - x(SC8, i)
+ x3 = x(SC3, i) - x(SC9, i)
+ x4 = x(SC4, i) - x(SC10, i)
+ x5 = x(SC5, i) - x(SC11, i)
+ x6 = x(SC6, i) - x(SC12, i)
+
+ x(SC1, i) = y1
+ x(SC2, i) = y2
+ x(SC3, i) = y3
+ x(SC4, i) = y4
+ x(SC5, i) = y5
+ x(SC6, i) = y6
+ x(SC7, i) = y1
+ x(SC8, i) = y2
+ x(SC9, i) = y3
+ x(SC10, i) = y4
+ x(SC11, i) = y5
+ x(SC12, i) = y6
+#endif
+
+# undef J
+# define J 2
+# include "clover_mult_a.h90"
+
+#ifdef GAMMAC
+ x(SC7, i) = y1
+ x(SC8, i) = y2
+ x(SC9, i) = y3
+ x(SC10, i) = y4
+ x(SC11, i) = y5
+ x(SC12, i) = y6
+#else
+ x(SC1, i) = x(SC1, i) + y1
+ x(SC2, i) = x(SC2, i) + y2
+ x(SC3, i) = x(SC3, i) + y3
+ x(SC4, i) = x(SC4, i) + y4
+ x(SC5, i) = x(SC5, i) + y5
+ x(SC6, i) = x(SC6, i) + y6
+ x(SC7, i) = x(SC7, i) - y1
+ x(SC8, i) = x(SC8, i) - y2
+ x(SC9, i) = x(SC9, i) - y3
+ x(SC10, i) = x(SC10, i) - y4
+ x(SC11, i) = x(SC11, i) - y5
+ x(SC12, i) = x(SC12, i) - y6
+#endif
+
+ enddo
+
+end
+
+!===============================================================================
diff --git a/src/fermi/mult/clover_mult_ao_sse.c b/src/fermi/mult/clover_mult_ao_sse.c
new file mode 100644
index 0000000000000000000000000000000000000000..25d09821994fcd458e3cb3a3af28a22e97f26345
--- /dev/null
+++ b/src/fermi/mult/clover_mult_ao_sse.c
@@ -0,0 +1,237 @@
+/*
+!===============================================================================
+!
+! clover_mult_ao_sse.c
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2011 Hinnerk Stueben
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+*/
+# include <emmintrin.h>
+# include <pmmintrin.h>
+# include "c_defs.h"
+
+# define cLoad(b) _mm_load_pd((double*) &(b))
+# define cLoadr(b) _mm_loadr_pd((double*) &(b))
+# define cLoad1(b) _mm_load1_pd((double*) &(b))
+# define cLoads(b) _mm_load_sd((double*) &(b))
+# define cStore(a,b) _mm_store_pd((double*) &(a), b)
+# define cAdd(b, c) _mm_add_pd(b, c)
+# define cSub(b, c) _mm_sub_pd(b, c)
+# define cMul(b, c) _mm_mul_pd(b, c)
+# define cAddSub(b, c) _mm_addsub_pd(b, c)
+
+# define cLoadX(a, b, c) STRCAT(a,rr) = cAdd(cLoad1(Re(b)), cLoad1(Re(c))); \
+ STRCAT(a,ii) = cAdd(cLoad1(Im(b)), cLoad1(Im(c)))
+
+# define cLoadXX(a, b, c) STRCAT(a,rr) = cSub(cLoad1(Re(b)), cLoad1(Re(c))); \
+ STRCAT(a,ii) = cSub(cLoad1(Im(b)), cLoad1(Im(c)))
+
+# define cStoreX(a, b, c) cStore(a, cAdd(b, c))
+# define cStoreXX(a, b, c) cStore(a, cSub(b, c))
+
+# define cConjg(a) cMul(conjg, a)
+# define cConjgr(a) cMul(conjgr, a)
+
+
+# define cCmplxMul(b, c) cAddSub(cMul(cLoad(b), STRCAT(c,rr)), cMul(cLoadr(b), STRCAT(c,ii)))
+
+# define cCmplxMulConjg(b, c) cAddSub(cMul(cConjg(cLoad(b)), STRCAT(c,rr)), cMul(cConjgr(cLoadr(b)), STRCAT(c,ii)))
+
+# define cCmplxMulRe(b, c) _mm_hsub_pd(cMul(cLoads(Re(b)), STRCAT(c,rr)), cMul(cLoads(Re(b)), STRCAT(c,ii)))
+
+# define cCmplxMulIm(b, c) _mm_hsub_pd(cMul(cLoads(Im(b)), STRCAT(c,rr)), cMul(cLoads(Im(b)), STRCAT(c,ii)))
+
+
+# define cProd(a, b, c) a = cCmplxMul(b, c)
+
+# define cProdConjg(a, b, c) a = cCmplxMulConjg(b, c)
+
+# define cProdRe(a, b, c) a = cCmplxMulRe(b, c)
+
+
+# define cAddProd(a, b, c) a = cAdd(a, cCmplxMul(b, c))
+
+# define cAddProdConjg(a,b,c) a = cAdd(a, cCmplxMulConjg(b, c))
+
+# define cAddProdRe(a, b, c) a = cAdd(a, cCmplxMulRe(b, c))
+
+# define cAddProdIm(a, b, c) a = cAdd(a, cCmplxMulIm(b, c))
+
+
+# define aa(s, c, i) aa_[i][c-1][s-1]
+# define x(s, c, i) x_[i][c-1][s-1]
+
+#ifdef BLOCK
+void clover_mult_ao_block_(COMPLEX (*aa_)[2][18], COMPLEX (*x_)[3][4], int *i1, int *i2)
+#else
+void clover_mult_ao_(COMPLEX (*aa_)[2][18], COMPLEX (*x_)[3][4], int *volh)
+#endif
+{
+ int i;
+ __m128d x1rr, x2rr, x3rr, x4rr, x5rr, x6rr;
+ __m128d x1ii, x2ii, x3ii, x4ii, x5ii, x6ii;
+ __m128d y1, y2, y3, y4, y5, y6;
+ __m128d xx1rr, xx2rr, xx3rr, xx4rr, xx5rr, xx6rr;
+ __m128d xx1ii, xx2ii, xx3ii, xx4ii, xx5ii, xx6ii;
+ __m128d yy1, yy2, yy3, yy4, yy5, yy6;
+
+ const __m128d conjg = _mm_setr_pd(ONE, -ONE);
+ const __m128d conjgr = _mm_set_pd(ONE, -ONE);
+ const __m128d sign = _mm_set_pd(-ONE, -ONE);
+
+#ifndef BLOCK
+ TIMING_START(timing_bin_clover_mult_ao);
+#endif
+
+ aa_--;
+ x_--;
+
+#ifdef BLOCK
+ for (i = *i1; i <= *i2; i++)
+#else
+ # pragma omp parallel for \
+ private (x1rr, x2rr, x3rr, x4rr, x5rr, x6rr) \
+ private (x1ii, x2ii, x3ii, x4ii, x5ii, x6ii) \
+ private (y1, y2, y3, y4, y5, y6) \
+ private (xx1rr, xx2rr, xx3rr, xx4rr, xx5rr, xx6rr) \
+ private (xx1ii, xx2ii, xx3ii, xx4ii, xx5ii, xx6ii) \
+ private (yy1, yy2, yy3, yy4, yy5, yy6)
+
+ for (i = 1; i <= *volh; i++)
+#endif
+ {
+ cLoadX(x1, x(1, 1, i), x(3, 1, i));
+ cLoadX(x2, x(1, 2, i), x(3, 2, i));
+ cLoadX(x3, x(1, 3, i), x(3, 3, i));
+ cLoadX(x4, x(2, 1, i), x(4, 1, i));
+ cLoadX(x5, x(2, 2, i), x(4, 2, i));
+ cLoadX(x6, x(2, 3, i), x(4, 3, i));
+
+ cProdRe(y1, aa(1,1,i), x1);
+ cAddProd(y1, aa(2,1,i), x2);
+ cAddProd(y1, aa(3,1,i), x3);
+ cAddProd(y1, aa(4,1,i), x4);
+ cAddProd(y1, aa(5,1,i), x5);
+ cAddProd(y1, aa(6,1,i), x6);
+
+ cProdConjg(y2, aa(2,1,i), x1);
+ cAddProdIm(y2, aa(1,1,i), x2);
+ cAddProd(y2, aa(7,1,i), x3);
+ cAddProd(y2, aa(8,1,i), x4);
+ cAddProd(y2, aa(9,1,i), x5);
+ cAddProd(y2, aa(10,1,i), x6);
+
+ cProdConjg(y3, aa(3,1,i), x1);
+ cAddProdConjg(y3, aa(7,1,i), x2);
+ cAddProdRe(y3, aa(11,1,i), x3);
+ cAddProd(y3, aa(12,1,i), x4);
+ cAddProd(y3, aa(13,1,i), x5);
+ cAddProd(y3, aa(14,1,i), x6);
+
+ cProdConjg(y4, aa(4,1,i), x1);
+ cAddProdConjg(y4, aa(8,1,i), x2);
+ cAddProdConjg(y4, aa(12,1,i), x3);
+ cAddProdIm(y4, aa(11,1,i), x4);
+ cAddProd(y4, aa(15,1,i), x5);
+ cAddProd(y4, aa(16,1,i), x6);
+
+ cProdConjg(y5, aa(5,1,i), x1);
+ cAddProdConjg(y5, aa(9,1,i), x2);
+ cAddProdConjg(y5, aa(13,1,i), x3);
+ cAddProdConjg(y5, aa(15,1,i), x4);
+ cAddProdRe(y5, aa(17,1,i), x5);
+ cAddProd(y5, aa(18,1,i), x6);
+
+ cProdConjg(y6, aa(6,1,i), x1);
+ cAddProdConjg(y6, aa(10,1,i), x2);
+ cAddProdConjg(y6, aa(14,1,i), x3);
+ cAddProdConjg(y6, aa(16,1,i), x4);
+ cAddProdConjg(y6, aa(18,1,i), x5);
+ cAddProdIm(y6, aa(17,1,i), x6);
+
+ cLoadXX(xx1, x(1, 1, i), x(3, 1, i));
+ cLoadXX(xx2, x(1, 2, i), x(3, 2, i));
+ cLoadXX(xx3, x(1, 3, i), x(3, 3, i));
+ cLoadXX(xx4, x(2, 1, i), x(4, 1, i));
+ cLoadXX(xx5, x(2, 2, i), x(4, 2, i));
+ cLoadXX(xx6, x(2, 3, i), x(4, 3, i));
+
+ cProdRe(yy1, aa(1,2,i), xx1);
+ cAddProd(yy1, aa(2,2,i), xx2);
+ cAddProd(yy1, aa(3,2,i), xx3);
+ cAddProd(yy1, aa(4,2,i), xx4);
+ cAddProd(yy1, aa(5,2,i), xx5);
+ cAddProd(yy1, aa(6,2,i), xx6);
+
+ cProdConjg(yy2, aa(2,2,i), xx1);
+ cAddProdIm(yy2, aa(1,2,i), xx2);
+ cAddProd(yy2, aa(7,2,i), xx3);
+ cAddProd(yy2, aa(8,2,i), xx4);
+ cAddProd(yy2, aa(9,2,i), xx5);
+ cAddProd(yy2, aa(10,2,i), xx6);
+
+ cProdConjg(yy3, aa(3,2,i), xx1);
+ cAddProdConjg(yy3, aa(7,2,i), xx2);
+ cAddProdRe(yy3, aa(11,2,i), xx3);
+ cAddProd(yy3, aa(12,2,i), xx4);
+ cAddProd(yy3, aa(13,2,i), xx5);
+ cAddProd(yy3, aa(14,2,i), xx6);
+
+ cProdConjg(yy4, aa(4,2,i), xx1);
+ cAddProdConjg(yy4, aa(8,2,i), xx2);
+ cAddProdConjg(yy4, aa(12,2,i), xx3);
+ cAddProdIm(yy4, aa(11,2,i), xx4);
+ cAddProd(yy4, aa(15,2,i), xx5);
+ cAddProd(yy4, aa(16,2,i), xx6);
+
+ cProdConjg(yy5, aa(5,2,i), xx1);
+ cAddProdConjg(yy5, aa(9,2,i), xx2);
+ cAddProdConjg(yy5, aa(13,2,i), xx3);
+ cAddProdConjg(yy5, aa(15,2,i), xx4);
+ cAddProdRe(yy5, aa(17,2,i), xx5);
+ cAddProd(yy5, aa(18,2,i), xx6);
+
+ cProdConjg(yy6, aa(6,2,i), xx1);
+ cAddProdConjg(yy6, aa(10,2,i), xx2);
+ cAddProdConjg(yy6, aa(14,2,i), xx3);
+ cAddProdConjg(yy6, aa(16,2,i), xx4);
+ cAddProdConjg(yy6, aa(18,2,i), xx5);
+ cAddProdIm(yy6, aa(17,2,i), xx6);
+
+ cStoreX(x(1, 1, i), y1, yy1);
+ cStoreX(x(1, 2, i), y2, yy2);
+ cStoreX(x(1, 3, i), y3, yy3);
+ cStoreX(x(2, 1, i), y4, yy4);
+ cStoreX(x(2, 2, i), y5, yy5);
+ cStoreX(x(2, 3, i), y6, yy6);
+
+ cStoreXX(x(3, 1, i), y1, yy1);
+ cStoreXX(x(3, 2, i), y2, yy2);
+ cStoreXX(x(3, 3, i), y3, yy3);
+ cStoreXX(x(4, 1, i), y4, yy4);
+ cStoreXX(x(4, 2, i), y5, yy5);
+ cStoreXX(x(4, 3, i), y6, yy6);
+ }
+
+#ifndef BLOCK
+ TIMING_STOP(timing_bin_clover_mult_ao);
+#endif
+}
diff --git a/src/fermi/mult/clover_mult_ao_sse_r4.c b/src/fermi/mult/clover_mult_ao_sse_r4.c
new file mode 100644
index 0000000000000000000000000000000000000000..b98fc0d9a27f427bb4609e4631ec654a357c8cb5
--- /dev/null
+++ b/src/fermi/mult/clover_mult_ao_sse_r4.c
@@ -0,0 +1,206 @@
+/*
+!===============================================================================
+!
+! clover_mult_ao_sse_r4.c
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2011 Hinnerk Stueben
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+*/
+# include <xmmintrin.h>
+# include <emmintrin.h>
+# include <pmmintrin.h>
+# define PRECISION_R4
+# include "c_defs.h"
+
+# define cLoad(b) _mm_load_ps((float*) &(b))
+# define cLoad1(b) _mm_load1_ps((float*) &(b))
+# define cStore(a,b) _mm_store_ps((float*) &(a), b)
+# define cAdd(b, c) _mm_add_ps(b, c)
+# define cSub(b, c) _mm_sub_ps(b, c)
+# define cMul(b, c) _mm_mul_ps(b, c)
+# define cAddSub(b, c) _mm_addsub_ps(b, c)
+
+# define cConjgRI(a) cMul(conjg, a)
+# define cConjgIR(a) cMul(conjgr, a)
+
+# define cLoadX(a, b, c) STRCAT(a,rr) = cAdd(cLoad1(Re(b)), cLoad1(Re(c))); \
+ STRCAT(a,ii) = cAdd(cLoad1(Im(b)), cLoad1(Im(c)))
+
+# define cLoadXX(a, b, c) STRCAT(a,rr) = cSub(cLoad1(Re(b)), cLoad1(Re(c))); \
+ STRCAT(a,ii) = cSub(cLoad1(Im(b)), cLoad1(Im(c)))
+
+# define cLoadRI(a) cLoad(a)
+# define cLoadIR(a) _mm_shuffle_ps(cLoad(a), cLoad(a), _MM_SHUFFLE(2,3,0,1))
+
+# define cLoadDiagRI1(a) cMul(cLoadRI(a), conjg1)
+# define cLoadDiagIR1(a) cMul(cLoadIR(a), conjg1r)
+
+# define cLoadDiagRI2(a) cMul(_mm_shuffle_ps(cLoad(a), cLoad(a), _MM_SHUFFLE(0,1,3,2)), c1110)
+# define cLoadDiagIR2(a) cMul(_mm_shuffle_ps(cLoad(a), cLoad(a), _MM_SHUFFLE(1,0,2,3)), c1101)
+
+
+# define cDiag1(iaa, y1, y2, ia, x1, x2) \
+y1 = cAddSub(cMul(cLoadDiagRI1(aa(ia,iaa,i)), STRCAT(x1,rr)), cMul(cLoadDiagIR1(aa(ia,iaa,i)), STRCAT(x1,ii))); \
+y1 = cAdd(y1, cAddSub(cMul(cLoadDiagRI2(aa(ia,iaa,i)), STRCAT(x2,rr)), cMul(cLoadDiagIR2(aa(ia,iaa,i)), STRCAT(x2,ii))))
+
+# define cDiag2(iaa, y1, y2, ia, x1, x2) \
+y1 = cAdd(y1, cAddSub(cMul(cLoadDiagRI1(aa(ia,iaa,i)), STRCAT(x1,rr)), cMul(cLoadDiagIR1(aa(ia,iaa,i)), STRCAT(x1,ii)))); \
+y1 = cAdd(y1, cAddSub(cMul(cLoadDiagRI2(aa(ia,iaa,i)), STRCAT(x2,rr)), cMul(cLoadDiagIR2(aa(ia,iaa,i)), STRCAT(x2,ii))))
+
+
+
+# define cLoadUpperRI1(a, b) _mm_shuffle_ps(cLoad(a), cLoad(b), _MM_SHUFFLE(1,0,1,0))
+# define cLoadUpperIR1(a, b) _mm_shuffle_ps(cLoad(a), cLoad(b), _MM_SHUFFLE(0,1,0,1))
+
+# define cLoadUpperRI2(a, b) _mm_shuffle_ps(cLoad(a), cLoad(b), _MM_SHUFFLE(3,2,3,2))
+# define cLoadUpperIR2(a, b) _mm_shuffle_ps(cLoad(a), cLoad(b), _MM_SHUFFLE(2,3,2,3))
+
+
+# define cUpper(iaa, y1, y2, ia1, ia2, x1, x2) \
+y1 = cAdd(y1, cAddSub(cMul(cLoadUpperRI1(aa(ia1,iaa,i),aa(ia2,iaa,i)), STRCAT(x1,rr)), cMul(cLoadUpperIR1(aa(ia1,iaa,i),aa(ia2,iaa,i)), STRCAT(x1,ii)))); \
+y1 = cAdd(y1, cAddSub(cMul(cLoadUpperRI2(aa(ia1,iaa,i),aa(ia2,iaa,i)), STRCAT(x2,rr)), cMul(cLoadUpperIR2(aa(ia1,iaa,i),aa(ia2,iaa,i)), STRCAT(x2,ii))))
+
+
+
+# define cCmplxMulConjg(b, c) cAddSub(cMul(cConjgRI(cLoadRI(b)), STRCAT(c,rr)), cMul(cConjgIR(cLoadIR(b)), STRCAT(c,ii)))
+
+# define cProdConjg(a, b, c) a = cCmplxMulConjg(b, c)
+
+# define cAddProdConjg(a,b,c) a = cAdd(a, cCmplxMulConjg(b, c))
+
+# define cLower1(iaa, y1, y2, ia1, ia2, x1, x2) \
+ cProdConjg(y1, aa(ia1,iaa,i), x1); \
+ cAddProdConjg(y1, aa(ia2,iaa,i), x2)
+
+# define cLower2(iaa, y1, y2, ia1, ia2, x1, x2) \
+ cAddProdConjg(y1, aa(ia1,iaa,i), x1); \
+ cAddProdConjg(y1, aa(ia2,iaa,i), x2)
+
+
+# define cStoreX1(a, b, c) cStore(a, _mm_shuffle_ps(b, c, _MM_SHUFFLE(3,2,1,0)))
+# define cStoreX2(a, b, c) cStore(a, _mm_shuffle_ps(b, c, _MM_SHUFFLE(1,0,3,2)))
+# define cStoreX3(a, b, c) cStore(a, _mm_shuffle_ps(b, c, _MM_SHUFFLE(3,2,1,0)))
+
+
+# define aa(s, c, i) aa_[i][c-1][s-1]
+# define x(s, c, i) x_[i][c-1][s-1]
+
+
+#ifdef BLOCK
+void clover_mult_ao_block_r4_(COMPLEX (*aa_)[2][18], COMPLEX (*x_)[3][4], int *i1, int *i2)
+#else
+void clover_mult_ao_r4_(COMPLEX (*aa_)[2][18], COMPLEX (*x_)[3][4], int *volh)
+#endif
+{
+ int i;
+ __m128 x1rr, x2rr, x3rr, x4rr, x5rr, x6rr;
+ __m128 x1ii, x2ii, x3ii, x4ii, x5ii, x6ii;
+ __m128 y1, y3, y5;
+ __m128 z1, z3, z5;
+ __m128 xx1rr, xx2rr, xx3rr, xx4rr, xx5rr, xx6rr;
+ __m128 xx1ii, xx2ii, xx3ii, xx4ii, xx5ii, xx6ii;
+ __m128 yy1, yy3, yy5;
+ __m128 zz1, zz3, zz5;
+
+ const __m128 conjg = _mm_setr_ps(ONE, -ONE, ONE, -ONE);
+ const __m128 conjgr = _mm_setr_ps(-ONE, ONE, -ONE, ONE);
+
+ const __m128 conjg1 = _mm_setr_ps(ONE, ZERO, ONE, -ONE);
+ const __m128 conjg1r = _mm_setr_ps(ZERO, ONE, -ONE, ONE);
+ const __m128 c1101 = _mm_setr_ps(ONE, ONE, ZERO, ONE);
+ const __m128 c1110 = _mm_setr_ps(ONE, ONE, ONE, ZERO);
+
+
+ aa_--;
+ x_--;
+
+#ifdef BLOCK
+ for (i = *i1; i <= *i2; i++)
+#else
+ # pragma omp parallel for \
+ private (x1rr, x2rr, x3rr, x4rr, x5rr, x6rr) \
+ private (x1ii, x2ii, x3ii, x4ii, x5ii, x6ii) \
+ private (y1, y3, y5) \
+ private (z1, z3, z5) \
+ private (xx1rr, xx2rr, xx3rr, xx4rr, xx5rr, xx6rr) \
+ private (xx1ii, xx2ii, xx3ii, xx4ii, xx5ii, xx6ii) \
+ private (yy1, yy3, yy5) \
+ private (zz1, zz3, zz5)
+
+ for (i = 1; i <= *volh; i++)
+#endif
+ {
+ cLoadX(x1, x(1, 1, i), x(3, 1, i));
+ cLoadX(x2, x(1, 2, i), x(3, 2, i));
+ cLoadX(x3, x(1, 3, i), x(3, 3, i));
+ cLoadX(x4, x(2, 1, i), x(4, 1, i));
+ cLoadX(x5, x(2, 2, i), x(4, 2, i));
+ cLoadX(x6, x(2, 3, i), x(4, 3, i));
+
+ cDiag1(1, y1, y2, 1, x1, x2);
+ cUpper(1, y1, y2, 3, 7, x3, x4);
+ cUpper(1, y1, y2, 5, 9, x5, x6);
+
+ cLower1(1, y3, y4, 3, 7, x1, x2);
+ cDiag2(1, y3, y4, 11, x3, x4);
+ cUpper(1, y3, y4, 13, 15, x5, x6);
+
+ cLower1(1, y5, y6, 5, 9, x1, x2);
+ cLower2(1, y5, y6, 13, 15, x3, x4);
+ cDiag2(1, y5, y6, 17, x5, x6);
+
+ cLoadXX(xx1, x(1, 1, i), x(3, 1, i));
+ cLoadXX(xx2, x(1, 2, i), x(3, 2, i));
+ cLoadXX(xx3, x(1, 3, i), x(3, 3, i));
+ cLoadXX(xx4, x(2, 1, i), x(4, 1, i));
+ cLoadXX(xx5, x(2, 2, i), x(4, 2, i));
+ cLoadXX(xx6, x(2, 3, i), x(4, 3, i));
+
+ cDiag1(2, yy1, yy2, 1, xx1, xx2);
+ cUpper(2, yy1, yy2, 3, 7, xx3, xx4);
+ cUpper(2, yy1, yy2, 5, 9, xx5, xx6);
+
+ cLower1(2, yy3, yy4, 3, 7, xx1, xx2);
+ cDiag2(2, yy3, yy4, 11, xx3, xx4);
+ cUpper(2, yy3, yy4, 13, 15, xx5, xx6);
+
+ cLower1(2, yy5, yy6, 5, 9, xx1, xx2);
+ cLower2(2, yy5, yy6, 13, 15, xx3, xx4);
+ cDiag2(2, yy5, yy6, 17, xx5, xx6);
+
+ z1 = cAdd(y1, yy1);
+ z3 = cAdd(y3, yy3);
+ z5 = cAdd(y5, yy5);
+
+ zz1 = cSub(y1, yy1);
+ zz3 = cSub(y3, yy3);
+ zz5 = cSub(y5, yy5);
+
+ cStoreX1(x(1, 1, i), z1, z3);
+ cStoreX1(x(3, 1, i), zz1, zz3);
+
+ cStoreX2(x(1, 2, i), z1, z5);
+ cStoreX2(x(3, 2, i), zz1, zz5);
+
+ cStoreX3(x(1, 3, i), z3, z5);
+ cStoreX3(x(3, 3, i), zz3, zz5);
+ }
+}
diff --git a/src/fermi/mult/m_mult_block.h90 b/src/fermi/mult/m_mult_block.h90
index 82e74fb1c40d4af0790bf413bfb6b43cc9fdb62a..d8fd0c58f4b3b4cb42764a071795eb504f8660ea 100644
--- a/src/fermi/mult/m_mult_block.h90
+++ b/src/fermi/mult/m_mult_block.h90
@@ -37,6 +37,8 @@
d_out => out
case (100) ; d_in => tmp1 ; d_out => out
case (101) ; d_in => tmp1 ; d_out => out
+ case (102) ; d_in => tmp1 ; d_out => out
+ case (103) ; d_in => tmp1 ; d_out => out
end select
diff --git a/src/fermi/mult/m_mult_omtdtd_block.h90 b/src/fermi/mult/m_mult_omtdtd_block.h90
index 43c362c84199e4a40b550e726b95ed31668e6219..c7db2574ac2d9d61490df507d1ffcd3bfea693f2 100644
--- a/src/fermi/mult/m_mult_omtdtd_block.h90
+++ b/src/fermi/mult/m_mult_omtdtd_block.h90
@@ -12,7 +12,7 @@
SPINCOL_OVERINDEXED, intent(inout), target :: in
integer, intent(in) :: id
logical, intent(in) :: extra_loops
- SPINCOL_FIELD, intent(in) :: p_or_r
+ SPINCOL_OVERINDEXED, intent(in) :: p_or_r
REAL, intent(in) :: bk
DOUBLE, intent(out) :: paap
@@ -41,18 +41,18 @@
d_out => out
end select
-#ifdef DAGGER
- out = in
-#endif
-
do i1 = 1, volh, input%tuning_cg_block_length
i2 = min(volh, i1 + input%tuning_cg_block_length - 1)
#ifndef DAGGER
if (extra_loops) call sc_xpby_block(in, p_or_r, bk, i1, i2) ! from cg: p = r + bk * p
call STRCAT(M_MULT_D, _projection_block)(d_in, in, i1, i2)
#else
- if (cid/=0)call clover_mult_ao_block(clover(cid)%i(1,1,se), out, i1, i2)
- call STRCAT(M_MULT_D, _projection_block)(d_in, out, i1, i2)
+ if (cid/=0) then
+ call clover_mult_ao2_block(out, clover(cid)%i(1,1,se), in, i1, i2)
+ call STRCAT(M_MULT_D, _projection_block)(d_in, out, i1, i2)
+ else
+ call STRCAT(M_MULT_D, _projection_block)(d_in, in, i1, i2)
+ endif
#endif
enddo
diff --git a/src/fermi/mult/m_tilde.F90 b/src/fermi/mult/m_tilde.F90
index b52011a7c53a1f08108afaac7a684a24c89323e6..7ac0fea79c9da21b8fa881cb358b03df55f7a882 100644
--- a/src/fermi/mult/m_tilde.F90
+++ b/src/fermi/mult/m_tilde.F90
@@ -34,9 +34,13 @@ subroutine mtil(out, in, id)
SPINCOL_FIELD, intent(in) :: in
integer, intent(in) :: id
SPINCOL_FIELD :: tmp
- REAL :: b
+ REAL :: b, fac1, fac2
b = action%mtilde(id)%b
+ fac1=exp( chemi)
+ fac2=exp(-chemi)
+ if (chemi /= 0)call emuu4(gauge(2)%u, fac1, fac2, .false.)
+
if (action%mtilde(id)%kappa /= 0) then
#ifdef BAGEL
@@ -78,6 +82,8 @@ subroutine mtil(out, in, id)
endif
#endif
+ if (chemi /= 0)call emuu4(gauge(2)%u, ONE, ONE, .false.)
+
end
!-------------------------------------------------------------------------------
@@ -90,12 +96,16 @@ subroutine mtil_dag(out, in, id)
SPINCOL_FIELD, intent(in) :: in
integer, intent(in) :: id
SPINCOL_FIELD :: tmp
- REAL :: b
+ REAL :: b, fac1, fac2
b = action%mtilde(id)%b
+ fac1=exp(-chemi)
+ fac2=exp( chemi)
+
+ if (chemi /= 0)call emuu4(gauge(2)%u, fac1, fac2, .false.)
#ifdef OMTDTD
- out = in
+ call sc_copy(out,in)
if (action%mtilde(id)%cswkappa /= 0) &
call clover_mult_ao(clover(action%mtilde(id)%cid)%i(1,1,se), out, volh)
if (action%mtilde(id)%h /= 0) &
@@ -149,6 +159,9 @@ subroutine mtil_dag(out, in, id)
call h_mult_a(out, -real(action%mtilde(id)%h,kind=RKIND), in, volh)
endif
#endif
+
+ if (chemi /= 0)call emuu4(gauge(2)%u, ONE, ONE, .false.)
+
end
!===============================================================================
diff --git a/src/fermi/mult/w_mult_block.F90 b/src/fermi/mult/w_mult_block.F90
index c80ab41c09da719cdb969e86edbb20add4f0abae..55281577818134bc158e01a830c513ecc1f826ea 100644
--- a/src/fermi/mult/w_mult_block.F90
+++ b/src/fermi/mult/w_mult_block.F90
@@ -30,24 +30,52 @@ module module_m_mult_block
REAL, dimension(:), pointer, save :: tmp1 ! sc2-field
REAL, dimension(:), pointer, save :: tmp2 ! sc2-field
+ interface
+ subroutine wdagw_block(out, in, id, extra_loops, r, bk, paap)
+ use module_vol
+ implicit none
+ SPINCOL_OVERINDEXED :: out, in, r
+ integer :: id
+ logical :: extra_loops
+ REAL :: bk
+ DOUBLE :: paap
+ end subroutine wdagw_block
+ subroutine wmul_block(out, in, id, extra_loops, p_or_r, bk, paap)
+ use module_vol
+ implicit none
+ SPINCOL_OVERINDEXED, target :: out, in
+ integer :: id
+ logical :: extra_loops
+ SPINCOL_OVERINDEXED :: p_or_r
+ REAL :: bk
+ DOUBLE :: paap
+ end subroutine wmul_block
+ subroutine wdag_block(out, in, id, extra_loops, p_or_r, bk, paap)
+ use module_vol
+ implicit none
+ SPINCOL_OVERINDEXED, target :: out, in
+ integer :: id
+ logical :: extra_loops
+ SPINCOL_OVERINDEXED :: p_or_r
+ REAL :: bk
+ DOUBLE :: paap
+ end subroutine wdag_block
+ end interface
+
end
!-------------------------------------------------------------------------------
subroutine wdagw_block(out, in, id, extra_loops, r, bk, paap) ! out = (W+ W) in
use module_vol
- use module_p_interface
+ use module_m_mult_block
implicit none
- SPINCOL_FIELD, intent(out) :: out
- SPINCOL_FIELD, intent(inout) :: in
- P_SPINCOL_FIELD, save :: tmp
- integer,intent(in) :: id
- logical, intent(in) :: extra_loops
- SPINCOL_FIELD, intent(in) :: r
- REAL, intent(in) :: bk
- DOUBLE, intent(out) :: paap
+ SPINCOL_OVERINDEXED :: out, in, r, tmp
+ integer,intent(in) :: id
+ logical,intent(in) :: extra_loops
+ REAL, intent(in) :: bk
+ DOUBLE, intent(out) :: paap
TIMING_START(timing_bin_mtdagmt)
- ALLOCATE_SC_FIELD(tmp)
call wmul_block(tmp, in, id, extra_loops, r, bk, paap)
call wdag_block(out, tmp, id, extra_loops, in, bk, paap)
TIMING_STOP(timing_bin_mtdagmt)
@@ -58,6 +86,7 @@ subroutine wmul_block(out, in, id, extra_loops, p_or_r, bk, paap)
# undef DAGGER
+# undef d
# define M_MULT_D d
# define PLUS +
# define MINUS -
@@ -77,6 +106,7 @@ subroutine wdag_block(out, in, id, extra_loops, p_or_r, bk, paap)
# undef PLUS
# undef MINUS
+# undef d_dag
# define M_MULT_D d_dag
# define PLUS -
# define MINUS +
@@ -86,5 +116,6 @@ subroutine wdag_block(out, in, id, extra_loops, p_or_r, bk, paap)
#else
# include "m_mult_block.h90"
#endif
+
end
!===============================================================================
diff --git a/src/fermi/mult/w_mult_block_r4.F90 b/src/fermi/mult/w_mult_block_r4.F90
index e124fab9497f8b026be8a97b4a70a8e0e8825f75..f70501ed3183a37a02963783a4940ad1bc75c7b7 100644
--- a/src/fermi/mult/w_mult_block_r4.F90
+++ b/src/fermi/mult/w_mult_block_r4.F90
@@ -1,5 +1,4 @@
# define PRECISION_R4
-# define WDAGW_R4
#ifdef LIBDI
# include "w_mult_block.F90"
diff --git a/src/fermi/mult/w_mult_r4.F90 b/src/fermi/mult/w_mult_r4.F90
index 59a7b93a5cb416fccca22710c55aeea54eb8a9cb..b8181e094aef7c1f86c9df79e92515bf7b211583 100644
--- a/src/fermi/mult/w_mult_r4.F90
+++ b/src/fermi/mult/w_mult_r4.F90
@@ -1,4 +1,3 @@
# define PRECISION_R4
-# define WDAGW_R4
# include "w_mult.F90"
diff --git a/src/fermi/rhmc/init_rhmc.F90 b/src/fermi/rhmc/init_rhmc.F90
index b7201232db4625f1a854d5e80e3073e8246da704..734d333d8732c85506212c3b7c808abeb8d3de8a 100644
--- a/src/fermi/rhmc/init_rhmc.F90
+++ b/src/fermi/rhmc/init_rhmc.F90
@@ -4,7 +4,7 @@
!
!-------------------------------------------------------------------------------
!
-! Copyright (C) 2006-2007 Yoshifumi Nakamura
+! Copyright (C) 2006-2011 Yoshifumi Nakamura
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
@@ -38,6 +38,9 @@ subroutine init_rhmc(para)
type(hmc_para), intent(in) :: para
integer ::i, j, nth, max_frac, n_rid, iostat
FILENAME:: list
+!! REAL , allocatable :: relax_tmp(:)
+ REAL :: dmax
+ character (len=100) :: key
nth=0
if (para%model=="F")then
@@ -97,7 +100,6 @@ subroutine init_rhmc(para)
enddo
n_rid = i
-
rewind(ULIST)
iostat = 0
@@ -107,10 +109,53 @@ subroutine init_rhmc(para)
enddo
close(ULIST)
else
- call die("init_rhmc(): list is missing")
+ call die("init_rhmc(): tuning_approx_range_list is missing")
endif
endif
+ list = input%tuning_fraction_tolerance
+ if (list /= " ") then
+ open(ULIST, file = list, action = "read", status = "old")
+ iostat = 0
+ i = 0
+ do while (iostat == 0)
+ read(ULIST, *, iostat = iostat) key
+ i = i + 1
+ enddo
+ i=i-1
+
+ if (my_pe()==0)write(0,*)"tuning_fraction_tolerance",i,"lines are read"
+
+ rewind(ULIST)
+
+ iostat = 0
+ allocate(relax(i))
+ do j = 1, i
+ read(ULIST, *) relax(j)
+ enddo
+
+ dmax=ZERO
+ do j = 1, i
+ dmax=max(relax(j),dmax)
+ enddo
+ if (dmax==ZERO) call die("init_rhmc(): max of tuning_fraction_tolerance is zero")
+
+ relax=dmax/relax
+ if (my_pe()==0) then
+ write(0,*)"multi shift solver tolerances are relaxed"
+ write(0,*)"shift factor"
+ do j = 1, i
+ write(0,*)j, relax(j)
+ enddo
+ endif
+
+!! deallocate(relax_tmp)
+ close(ULIST)
+ endif
+
+
+
+
ratapp(0)%time_switch=1
!! do i=1,min(ratapp(0)%shift,input%rhmc_fraction_u1)
!! ratapp(0)%time_switch(i)=1
@@ -174,8 +219,10 @@ endif
if (input%tuning_approx_range/=0)rid = rid + 1
endif
if (max_ev/min_ev > ratapp(rid)%max_rhmc/ratapp(rid)%min_rhmc) then
- ratapp(rid)%max_rhmc = (max_ev / min_ev) * ratapp(rid)%margin_factor
- ratapp(rid)%min_rhmc = 1
+!! ratapp(rid)%max_rhmc = (max_ev / min_ev) * ratapp(rid)%margin_factor
+!! ratapp(rid)%min_rhmc = 1
+ ratapp(rid)%max_rhmc = max_ev * ratapp(rid)%margin_factor
+ ratapp(rid)%min_rhmc = min_ev
deg(1) = ratapp(rid)%shift
deg(2) = ratapp(rid)%shift_exact
@@ -185,11 +232,10 @@ endif
allocate(dp(1:deg(pm), pm))
#ifdef FMLIB
call remez(ratapp(rid)%min_rhmc,ratapp(rid)%max_rhmc, &
- 1, num*pm, deg(pm), 60, dr, dp, pm)
+ 1, num*pm, deg(pm),100, dr, dp, pm)
#else
call die("remez method needs FMLIB")
#endif
-
call storeremez(rid, deg(pm), pm, num*pm, dr, dp)
deallocate(dr)
deallocate(dp)
@@ -220,6 +266,33 @@ endif
!! endif
end
+!-------------------------------------------------------------------------------
+subroutine init_rid()
+ use module_action
+ use module_rhmc
+ use module_input
+ implicit none
+ integer :: fid, mid, rid, ftype
+ logical :: id_done(n_mtilde_id,8)
+ logical, external :: type_rational
+
+ id_done = .false.
+ rid = 0
+
+ do fid = 1, size(action%fermi)
+ ftype = action%fermi(fid)%type
+ mid = action%fermi(fid)%mid1
+ if ( type_rational(ftype) ) then
+ if (.not. id_done(mid,ftype)) then
+ id_done(mid,ftype) = .true.
+ if (input%tuning_approx_range/=0)rid = rid + 1
+ endif
+ action%fermi(fid)%rid = rid
+ endif
+ enddo
+
+end
+
!-------------------------------------------------------------------------------
subroutine storeremez(rid, deg, pm, num, dr, dp)
use module_rhmc
@@ -263,4 +336,5 @@ subroutine storeremez(rid, deg, pm, num, dr, dp)
endif
end
+
!===============================================================================
diff --git a/src/fermi/rhmc/remez.F90 b/src/fermi/rhmc/remez.F90
index 105fc9852b9dc3961939b9bc62e3809b16324286..6bf87a805529dd52a8fee5918e428e4109c1f793 100644
--- a/src/fermi/rhmc/remez.F90
+++ b/src/fermi/rhmc/remez.F90
@@ -1,10 +1,11 @@
!===============================================================================
!
-! remez.F90
+! remez.F90 with FMLIB version 1.3
+! not optimized, maybe slower then remez.F90_FMLIBv1.2)
!
!-------------------------------------------------------------------------------
!
-! Copyright (C) 2008 Yoshifumi Nakamura
+! Copyright (C) 2008-2011 Yoshifumi Nakamura
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
@@ -29,6 +30,7 @@ module module_remez
type(fm), allocatable, save :: roots(:), poles(:)
integer, save :: n, d, neq
integer, save :: power_num, power_den
+
end
!-------------------------------------------------------------------------------
@@ -176,7 +178,7 @@ integer function remez_root(err_dp)
tolerance = 1d-15
- call fmpi(pi)
+ call fm_pi(pi)
spread = to_fm(1d37)
iter = 0
apwidt = apend - apstrt
@@ -218,22 +220,20 @@ subroutine initialguess()
mm(0) = apstrt
do i = 1, neq-1
- call fmcos(pi*i/a, cc)
-!! r = to_fm(0.5) * (to_fm(1) - cc )
-!! r = (to_fm(1) - cc )/2
- r = ( 1 - cc )/2
- call fmsqrt_r1(r)
- mm(i) = apstrt + r * apwidt
+!! call fmcos(pi*i/a, cc)
+!! cc=cos(pi*i/a)
+!! r = ( 1 - cos(pi*i/a) )/2
+!! call fmsqrt_r1(r)
+ mm(i) = apstrt + sqrt( ( 1 - cos(pi*i/a) )/2 ) * apwidt
enddo
mm(neq) = apend
a = to_fm(2.0 * neq)
do i = 0, neq
- call fmcos(pi*(2*i+1)/a, cc)
- r = (1 - cc )/2
- call fmsqrt_r1(r)
-!! r = (exp(to_dp(r))-1)/(exp(1.0)-1)
- xx(i) = apstrt + r * apwidt
+!! call fmcos(pi*(2*i+1)/a, cc)
+!! r = (1 - cc )/2
+!! call fmsqrt_r1(r)
+ xx(i) = apstrt + sqrt( (1 - cos(pi*(2*i+1)/a) )/2 ) * apwidt
enddo
end
@@ -291,8 +291,9 @@ subroutine target_func(x, y)
type(fm), intent(in) :: x
type(fm) :: pwr, f, df, dy, tmp1,tmp2
- pwr = to_fm(dble(power_num)/dble(power_den))
- call fmpwr(x,pwr,y)
+!! pwr = to_fm(dble(power_num)/dble(power_den))
+!! call fmpwr(x,pwr,y)
+ call fmrpwr(x, power_num, power_den, y)
end
@@ -378,7 +379,7 @@ subroutine search(ym)
type(fm), allocatable :: yy(:)
meq = neq + 1
- allocate( yy(meq) )
+ allocate( yy(0:meq) )
eclose = to_fm(1d30)
farther = to_fm(0)
diff --git a/src/fermi/rhmc/remez.F90_FMLIBv1.2 b/src/fermi/rhmc/remez.F90_FMLIBv1.2
new file mode 100644
index 0000000000000000000000000000000000000000..03a2f89b0bb9d53a60445838831d67fdc77facb4
--- /dev/null
+++ b/src/fermi/rhmc/remez.F90_FMLIBv1.2
@@ -0,0 +1,706 @@
+!===============================================================================
+!
+! remez.F90 with FMLIB version 1.2
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2008-2011 Yoshifumi Nakamura
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+module module_remez
+ use fmzm
+ type(fm), save :: spread, apstrt, apend, apwidt, pi, delta, norm
+ type(fm), allocatable, save :: mm(:), xx(:), step(:), coef(:)
+ type(fm), allocatable, save :: roots(:), poles(:)
+ integer, save :: n, d, neq
+ integer, save :: power_num, power_den
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine remez(start, end, power_num, power_den, degree, prec, dr, dp, pm)
+ use module_function_decl
+ implicit none
+ real(8), intent(in) :: start, end
+ integer, intent(in) :: power_num, power_den, degree, prec, pm
+ real(8), intent(out):: dr(0:degree,pm), dp(degree,pm)
+ real(8) :: err
+ integer :: n,d, i, rrr
+ integer, external :: remez_root
+
+ if (.not.(pm == 1 .or. pm == 2)) call die("undefined procedure at remez")
+
+ n=degree
+ d=degree
+
+ call remez_init(power_num,power_den,n,d,start,end,prec)
+ call remez_allocate()
+ rrr= remez_root(err)
+ if (rrr==1) call die("Delta too small, try increasing precision")
+ if (rrr==2) call die("remez_root : try increasing maxiter")
+
+ if ( pm == 1) then
+ call getpfe(-1, dr(0,1), dp(1,1))
+ if (my_pe()==0) then
+ write(0,*)"generated new coeffs x^(-",power_num,"/",power_den,")"
+ write(0,*)"range[", start,",", end,"]"
+ write(0,*)err
+ write(0,"(d25.17)")dr(0,1)
+ do i = 1,n
+ write(0,"(2d25.17)")dr(i,1),dp(i,1)
+ enddo
+ endif
+ else
+ call getpfe(-1, dr(0,1), dp(1,1))
+ if (my_pe()==0) then
+ write(0,*)"generated new coeffs x^(-",power_num,"/",power_den,")"
+ write(0,*)"range[", start,",", end,"]"
+ write(0,*)err
+ write(0,"(d25.17)")dr(0,1)
+ do i = 1,n
+ write(0,"(2d25.17)")dr(i,1),dp(i,1)
+ enddo
+ endif
+ call getpfe( 1, dr(0,2), dp(1,2))
+ if (my_pe()==0) then
+ write(0,*)"generated new coeffs x^(+",power_num,"/",power_den,")"
+ write(0,*)"range[", start,",", end,"]"
+ write(0,*)err
+ write(0,"(d25.17)")dr(0,2)
+ do i = 1,n
+ write(0,"(2d25.17)")dr(i,2),dp(i,2)
+ enddo
+ endif
+ endif
+
+ call remez_deallocate()
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine remez_test()
+ implicit none
+ real(8) :: start, end, err, dr(0:10), dp(10)
+ integer :: power_num,power_den,n,d, prec, i, rrr
+ integer, external :: remez_root
+
+ start = 0.003_8
+ end = 1
+ power_num =1
+ power_den =2
+ prec=95
+
+ do i = 41, 80
+ n=i;d=n
+10 continue
+ call remez_init(power_num,power_den,n,d,start,end,prec)
+ call remez_allocate()
+ rrr= remez_root(err)
+!! if (rrr==1) call die("Delta too small, try increasing precision")
+ if (rrr==1) then
+ prec = prec + 1
+ call remez_deallocate()
+ go to 10
+ endif
+ if (rrr==2) call die("remez_root : try increasing maxiter")
+ call remez_deallocate()
+ write(*,*)" %remez",n, prec
+ enddo
+end
+
+!-------------------------------------------------------------------------------
+subroutine remez_init(pnum,pden,num,den,start,end,prec)
+ use module_remez
+ implicit none
+ real(8) :: start, end
+ integer :: prec, pnum,pden,num,den
+
+ power_num = pnum
+ power_den = pden
+ n = num
+ d = den
+ neq = n + d + 1
+ call fm_set(prec)
+ apstrt = to_fm(start)
+ apend = to_fm(end)
+
+end
+!-------------------------------------------------------------------------------
+subroutine remez_allocate()
+ use module_remez
+ implicit none
+
+ allocate(step(0:n+d+1))
+ allocate( mm(0:n+d+1))
+ allocate( xx(0:n+d+2))
+ allocate(coef(n+d+1))
+ allocate( roots(0:n-1) )
+ allocate( poles(0:d-1) )
+end
+
+!-------------------------------------------------------------------------------
+subroutine remez_deallocate()
+ use module_remez
+ implicit none
+
+ deallocate(step)
+ deallocate( mm)
+ deallocate( xx)
+ deallocate(coef)
+ deallocate( roots)
+ deallocate( poles)
+end
+
+!-------------------------------------------------------------------------------
+integer function remez_root(err_dp)
+ use module_remez
+ implicit none
+ real(8), intent(out) :: err_dp
+ integer :: iter
+ real(8) :: tolerance
+ type(fm) :: err
+
+ tolerance = 1d-15
+
+ call fm_pi(pi)
+ spread = to_fm(1d37)
+ iter = 0
+ apwidt = apend - apstrt
+
+ call initialguess()
+ call stpini()
+
+ do while (spread > tolerance)
+ if (mod(iter, 100) == 0 ) then
+ write(0,*)iter, to_dp(spread), to_dp(delta)
+ endif
+ call equations(neq,n,d, xx(0:neq-1), coef)
+ if (delta < tolerance) then
+ remez_root = 1
+ return
+ endif
+ call search(err)
+ iter = iter + 1
+ if (iter > 999999) then
+ remez_root = 2
+ return
+ endif
+ enddo
+ err_dp = to_dp(err)
+ write(0,*)"Converged at",iter,"iterations, error =",err_dp
+
+ call root()
+ remez_root = 0
+end
+
+!-------------------------------------------------------------------------------
+subroutine initialguess()
+ use module_remez
+ implicit none
+ type(fm) :: a, r, cc
+ integer :: i
+
+ a = to_fm(neq)
+
+ mm(0) = apstrt
+ do i = 1, neq-1
+!! call fmcos(pi*i/a, cc)
+!! cc=cos(pi*i/a)
+!! r = ( 1 - cos(pi*i/a) )/2
+!! call fmsqrt_r1(r)
+ mm(i) = apstrt + sqrt( ( 1 - cos(pi*i/a) )/2 ) * apwidt
+ enddo
+ mm(neq) = apend
+
+ a = to_fm(2.0 * neq)
+ do i = 0, neq
+!! call fmcos(pi*(2*i+1)/a, cc)
+!! r = (1 - cc )/2
+!! call fmsqrt_r1(r)
+ xx(i) = apstrt + sqrt( (1 - cos(pi*(2*i+1)/a) )/2 ) * apwidt
+ enddo
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine stpini()
+ use module_remez
+ implicit none
+ integer :: i
+
+ xx(neq+1) = apend
+ delta = to_fm(0.25)
+ step(0) = xx(0) - apstrt
+ do i = 1, neq-1
+ step(i) = xx(i) - xx(i-1)
+ enddo
+ step(neq) = step(neq-1)
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine equations(nd1,n,d, xt, b)
+ use fmzm
+ implicit none
+ type(fm), intent(out) :: b(nd1)
+ type(fm), intent(in) :: xt(nd1)
+ integer, intent(in) :: nd1, n, d
+ type(fm) :: a(nd1,nd1), yt, z
+ integer :: i, j
+
+ do i = 1, nd1
+ call target_func(xt(i), yt)
+ z = to_fm(1)
+ do j = 1, n+1
+ a(i,j) = z
+ z = z * xt(i)
+ enddo
+ z = to_fm(1)
+ do j = 1, d
+ a(i,n+1+j) = - yt * z
+ z = z * xt(i)
+ enddo
+ b(i) = yt * z
+ enddo
+
+ call solve_fm(a,b,nd1)
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine target_func(x, y)
+ use module_remez
+ implicit none
+ type(fm), intent(out) :: y
+ type(fm), intent(in) :: x
+ type(fm) :: pwr, f, df, dy, tmp1,tmp2
+
+!! pwr = to_fm(dble(power_num)/dble(power_den))
+!! call fmpwr(x,pwr,y)
+ call fmrpwr(x, power_num, power_den, y)
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine solve_fm(a, b, n)
+ use fmzm
+ implicit none
+ type(fm), intent(inout) :: a(n,n), b(n)
+ integer, intent(in) :: n
+ type(fm) :: big, tmp, dum, pivinv
+ integer :: i,j,k,l,ll, irow, icol, ipiv(n)
+
+ ipiv = 0
+
+ do i = 1, n
+ big = to_fm(0)
+ do j = 1, n
+ if (ipiv(j) /= 1) then
+ do k = 1, n
+ if (ipiv(k) == 0) then
+ call fmabs(a(j, k), tmp)
+ if (tmp >= big) then
+ big = tmp
+ irow = j
+ icol = k
+ endif
+ else if (ipiv(k) > 1) then
+ call die("solve_fm(): singular matrix 1")
+ endif
+ enddo
+ endif
+ enddo
+
+ ipiv(icol) = ipiv(icol) + 1
+
+ if (irow /= icol) then
+ do l = 1, n
+ dum = a(irow, l)
+ a(irow, l) = a(icol, l)
+ a(icol, l) = dum
+ enddo
+ dum = b(irow)
+ b(irow) = b(icol)
+ b(icol) = dum
+ endif
+
+ if (a(icol, icol) == 0 ) then
+ call fm_prnt(a(icol, icol))
+ call die("solve_fm(): singular matrix 2")
+ endif
+
+ pivinv = 1 / a(icol, icol)
+ !!a(icol, icol) = ONE !! only needed for inv(a)
+
+ do l = 1, n
+ a(icol, l) = a(icol, l) * pivinv
+ enddo
+
+ b(icol) = b(icol) * pivinv
+
+ do ll = 1, n
+ if (ll /= icol) then
+ dum = a(ll, icol)
+ a(ll, icol) = to_fm(0)
+ do l = 1, n
+ a(ll, l) = a(ll, l) - a(icol, l) * dum
+ enddo
+ b(ll) = b(ll) - b(icol) * dum
+ endif
+ enddo
+
+ enddo
+
+end
+
+!-------------------------------------------------------------------------------
+! Search for error maxima and minima
+subroutine search(ym)
+ use module_remez
+ implicit none
+ integer :: i, j, meq, emsign, ensign, steps
+ type(fm) :: a, q, xm, ym, xn, yn, xx0, xx1, eclose, farther
+ type(fm), allocatable :: yy(:)
+
+ meq = neq + 1
+ allocate( yy(0:meq) )
+
+ eclose = to_fm(1d30)
+ farther = to_fm(0)
+
+ j = 1
+ xx0 = apstrt
+
+ do i=0, meq -1
+ steps = 0
+ xx1 = xx(i)
+ if (i==meq-1) xx1 = apend
+ xm = mm(i)
+ call geterr(ym,xm,emsign)
+ q = step(i)
+ xn = xm + q
+ if (xn < xx0 .or. xn >= xx1) then
+ q = -q
+ xn = xm
+ yn = ym
+ ensign = emsign
+ else
+ call geterr(yn,xn,ensign)
+ if (yn < ym) then
+ q = -q
+ xn = xm
+ yn = ym
+ ensign = emsign
+ endif
+ endif
+
+
+ do while(yn >= ym)
+ steps = steps + 1
+ if (steps > 10) exit
+
+ ym = yn
+ xm = xn
+ emsign = ensign
+ a = xm + q
+ if (a == xm .or. a <= xx0 .or. a >= xx1) exit
+ xn = a
+ call geterr(yn,xn,ensign)
+ enddo
+
+ mm(i) = xm !! Position of maximum
+ yy(i) = ym !! Value of maximum
+
+ if (eclose > ym) eclose = ym
+ if (farther < ym) farther = ym
+
+ xx0 = xx1 !! Walk to next zero.
+ enddo !! end of search loop
+
+ q = (farther - eclose) !! Decrease step size if error spread increased
+ if ( eclose /= to_fm(0) ) q = q / eclose !! Relative error spread
+ if (q >= spread) delta = delta * to_fm(0.5) !! Spread is increasing; decrease step size
+ spread = q
+
+
+ do i = 0, neq - 1
+ q = yy(i+1)
+ if (q /= 0 ) then
+ q = yy(i) / q - to_fm(1)
+ else
+ q = to_fm(0.0625)
+ endif
+ if (q > to_fm(0.25)) q = to_fm(0.25)
+ q = q * ( mm(i+1) - mm(i) )
+ step(i) = q * delta
+ enddo
+
+ step(neq) = step(neq-1)
+
+ do i = 0, neq - 1
+ xm = xx(i) - step(i)
+ if ( xm <= apstrt ) cycle
+ if ( xm >= apend ) cycle
+ if (xm <= mm(i) ) xm = to_fm(0.5) * (mm(i) + xx(i))
+ if (xm >= mm(i+1)) xm = to_fm(0.5) * (mm(i+1) + xx(i))
+ xx(i) = xm
+ enddo
+
+ deallocate(yy)
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine geterr(err,x,nsign)
+ use fmzm
+ implicit none
+ integer :: nsign
+ type(fm) :: err,x,f,app
+
+ call target_func(x, f)
+ call approx(x, app)
+ err = app - f
+
+ if (f /= to_fm(0)) err = err / f
+ if (err < to_fm(0)) then
+ nsign = -1
+ err = -err
+ else
+ nsign = 1
+ endif
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine approx(x,app)
+ use module_remez
+ implicit none
+ type(fm) :: x,app, yn, yd
+ integer :: i
+
+ yn = coef(n+1)
+ do i = n, 1, -1
+ yn = x * yn + coef(i)
+ enddo
+ yd = x + coef(d+n+1)
+ do i = d+n,n+2,-1
+ yd = x * yd + coef(i)
+ enddo
+
+ app = yn/yd
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine root()
+ use module_remez
+ implicit none
+ type(fm) :: x,dx,upper,lower,tol
+ type(fm) :: poly(0:neq)
+ integer :: i,j
+
+ dx = 0.5
+ upper=to_fm(1) ; lower=to_fm(-100000) ; tol = to_fm(1d-20)
+
+ poly(0:neq)=to_fm(0)
+
+ !! First find the numerator roots
+ do i = 0, n
+ poly(i) = coef(i+1)
+ enddo
+
+ do i = n-1, 0, -1
+ call rtnewt(roots(i), poly, i+1, lower,upper,tol)
+ if ( roots(i) == 0 ) write(0,*)i
+ if ( roots(i) == 0 ) call die("Err: Failure to converge on root of num")
+ poly(0) = -poly(0) / roots(i)
+ do j = 1, i
+ poly(j) = ( poly(j-1) - poly(j) ) / roots(i)
+ enddo
+ enddo
+
+ !! Now find the denominator roots
+ poly(d) = 1
+ do i = 0, d-1
+ poly(i) = coef(n+2+i)
+ enddo
+ do i = d-1, 0, -1
+ call rtnewt(poles(i),poly,i+1,lower,upper,tol);
+ if (poles(i) == 0.0) call die("Err: Failure to converge on rootof den")
+ poly(0) = -poly(0)/poles(i)
+ do j = 1, i
+ poly(j) = ( poly(j-1) - poly(j) ) / poles(i);
+ enddo
+ enddo
+
+ norm = coef(n+1)
+
+#ifdef DEBUG2
+ write(0,*)"Normalisation constant is",to_dp(norm)
+ do i = 0, n-1
+ write(0,*)"root(",i,")=",to_dp(roots(i))
+ enddo
+ do i = 0, d-1
+ write(0,*)"pole(",i,")=",to_dp(poles(i))
+ enddo
+#endif
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine rtnewt(out, poly, i, x1, x2, xacc)
+ use module_remez
+ implicit none
+ type(fm) :: out, poly(0:neq), x1, x2, xacc, df, dx, f
+ integer :: i, j, jmax, k
+
+jmax=1000
+ out = (x1+x2)/2
+ do j=1, jmax
+ f=poly(i)
+ do k=i-1,0,-1
+ f= f*out + poly(k)
+ enddo
+
+ df=to_fm(i)*poly(i)
+ do k=i-1,1,-1
+ df = df*out + to_fm(k)*poly(k)
+ enddo
+ dx = f/df
+ out = out - dx
+ if ((x1-out)*(out-x2) < 0) call die("Jumped out of brackets in rtnewt")
+ if (abs(dx) < xacc) return
+ enddo
+ call warn("Maximum number of iterations exceeded in rtnewt")
+ out = 0
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine getpfe(ss, dr, dp)
+ use module_remez
+ implicit none
+ type(fm) :: r(0:n-1), p(0:d-1), tmp
+ integer :: i, ss
+ real(8) :: dr(0:n), dp(d)
+
+ if (n /= d) call die("n should be equal to d ")
+ if (.not. (ss == 1 .or. ss == -1)) call die("getpfe : unknown sign")
+
+ if (ss == -1) then
+ do i = 0, n-1
+ p(i)=roots(i)
+ r(i)=poles(i)
+ enddo
+ tmp = 1/norm
+ else
+ do i = 0, n-1
+ r(i)=roots(i)
+ p(i)=poles(i)
+ enddo
+ tmp = norm
+ endif
+
+ call pfe(n, d, r,p,tmp)
+
+ do i = 1,n
+ dr(i)= to_dp(r(i-1))
+ dp(i)= to_dp(p(i-1))
+ enddo
+ dr(0)=to_dp(tmp)
+end
+
+!-------------------------------------------------------------------------------
+subroutine pfe(n, d, res, poles, norm)
+ use fmzm
+ implicit none
+ integer, intent(in) :: n, d
+ type(fm), intent(inout) :: res(0:n-1), poles(0:d-1), norm
+ type(fm) :: numerator(0:n-1), denominator(0:d-1), temp
+ integer :: i, j, small
+
+! Initialization
+ do i = 1, n-1
+ numerator(i) = to_fm(0)
+ denominator(i) = to_fm(0)
+ enddo
+ numerator(0) = to_fm(1)
+ denominator(0) = to_fm(1)
+
+ do j = 0, n-1
+ do i = n-1, 0, -1
+ numerator(i) = - numerator(i) * res(j)
+ denominator(i) = - denominator(i) * poles(j)
+ if (i>0) then
+ numerator(i) = numerator(i) + numerator(i-1)
+ denominator(i) = denominator(i) + denominator(i-1)
+ endif
+ enddo
+ enddo
+
+! Convert to proper fraction form.
+! Fraction is now in the form 1 + n/d, where O(n)+1=O(d)
+
+ do i = 0, n-1
+ numerator(i) = numerator(i) - denominator(i)
+ enddo
+
+! Find the residues of the partial fraction expansion and absorb the
+! coefficients.
+
+ do i = 0, n-1
+ res(i) = to_fm(0)
+ do j = n-1, 0, -1
+ res(i) = poles(i)*res(i)+numerator(j)
+ enddo
+ do j = n-1, 0, -1
+ if (i/=j) res(i) = res(i) / (poles(i)-poles(j))
+ enddo
+ res(i) = res(i)*norm
+ enddo
+
+! res now holds the residues
+
+ j = 0
+ do i = 0, n-1
+ poles(i) = -poles(i)
+ enddo
+
+! Move the ordering of the poles from smallest to largest
+ do j = 0, n-1
+ small = j
+ do i = j+1, n-1
+ if (poles(i) < poles(small)) small = i
+ enddo
+ if (small /= j) then
+ temp = poles(small)
+ poles(small) = poles(j)
+ poles(j) = temp
+ temp = res(small)
+ res(small) = res(j)
+ res(j) = temp
+
+ endif
+#ifdef DEBUG2
+ write(0,*)"pfe : Residue = ", to_dp(res(j)), " Pole = ",to_dp(poles(j))
+#endif
+ enddo
+
+end
+
+!===============================================================================
diff --git a/src/fermi/solver/Makefile b/src/fermi/solver/Makefile
index fc41a4834397b5d3032c8403d91600ec853ba577..c82dc33666106e680a895263724e781c9ae1d5d5 100644
--- a/src/fermi/solver/Makefile
+++ b/src/fermi/solver/Makefile
@@ -4,7 +4,7 @@
#
#-------------------------------------------------------------------------------
#
-# Copyright (C) 2008 Yoshifumi Nakamura
+# Copyright (C) 2008, 2010 Yoshifumi Nakamura
#
# This file is part of BQCD -- Berlin Quantum ChromoDynamics program
#
@@ -27,25 +27,16 @@ include $(DIR)Makefile.in
MODULES_DIR = $(DIR)/modules
ifdef FPP2
- fpp = $(FPP2)
+ fpp = $(FPP2) -I$(DIR)/include $(MYFLAGS)
else
- fpp = $(FPP)
+ fpp = $(FPP) -I$(DIR)/include $(MYFLAGS)
endif
.SUFFIXES:
.SUFFIXES: .a .o .F90
-
-ifdef ARPACK
-MYFLAGS += -DARPACK
-endif
-ifdef LAPACK
-MYFLAGS += -DLAPACK
-endif
-
-
.F90.o:
- $(fpp) -I$(DIR)/include $(MYFLAGS) $< > $*.f90
+ $(fpp) $< > $*.f90
$(F90) -c $(FFLAGS) $*.f90
OBJS = \
@@ -78,7 +69,14 @@ OBJS = \
cg_def.o \
solver.o \
sort.o \
- gcrodr_dd.o
+ gcrodr_dd.o \
+ gcrodr.o
+
+ifdef quad
+OBJS += mre_r16.o \
+ cg_r16.o \
+ cg_mix_r16.o
+endif
ifdef ARPACK
OBJS += neig.o \
@@ -106,3 +104,14 @@ cg.o:cg.F90
$(fpp) -I$(DIR)/include $(MYFLAGS) cg.F90 > cg.f90
$(F90) -c -O2 -I../../modules -qmaxmem=-1 -qarch=450d -qtune=450 cg.f90
endif
+
+cg_r4.o: cg.F90
+ $(fpp) -DPRECISION_R4 $< > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
+cg_r16.o: cg.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
+
+mre_r16.o: mre.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
diff --git a/src/fermi/solver/blockbicggr.F90 b/src/fermi/solver/blockbicggr.F90
new file mode 100644
index 0000000000000000000000000000000000000000..254eca3d256d233ed07172730be9a943f9182a01
--- /dev/null
+++ b/src/fermi/solver/blockbicggr.F90
@@ -0,0 +1,234 @@
+!===============================================================================
+!
+! blockbicggr.F90 - solves "matrix_mult * X = B"
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2010 Yoshifumi Nakamura
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+# include "defs.h"
+
+!-------------------------------------------------------------------------------
+subroutine bloclbicggr(x, b, id, iter, res, nblock)
+ use module_function_decl
+ use module_check_solution
+ use module_action
+ use module_cg
+ use module_vol
+ use module_counter
+ implicit none
+
+ real(8), dimension(2*4*3*volh_tot,nblock), intent(inout) :: x
+ real(8), dimension(2*4*3*volh_tot,nblock), intent(in) :: b
+ integer, intent(out) :: iter
+ integer, intent(in) :: id
+ DOUBLE, intent(in) :: res
+
+ real(8), allocatable ::r0(:,:),r(:,:),p(:,:),aap(:,:)
+ integer :: i, niter, ierr
+ character(72) :: msg
+ integer, save :: nitert=0
+
+!-------------------------------------------------------------------------------
+
+ DEBUG2S("Start: cg")
+ TIMING_START(timing_bin_cg)
+
+ allocate(r(SIZE_COMPLEX*NDIRAC*NCOL*volh_tot), STAT = ierr)
+ allocate(p(SIZE_COMPLEX*NDIRAC*NCOL*volh_tot), STAT = ierr)
+ allocate(aap(SIZE_COMPLEX*NDIRAC*NCOL*volh_tot), STAT = ierr)
+
+ niter = 0
+
+ do ib = 1, nblock
+ call wdagw(r0(1,ib), x(1,ib), id)
+ niter = niter +1
+ nitert= nitert+1
+
+ !$omp parallel do reduction(+: rtrold) private(dtmp)
+ do i = 1, size_sc_field
+ r0(i,ib) = b(i) - r0(i,ib)
+ r(i,ib) = r0(i,ib)
+ p(i,ib) = r0(i,ib)
+ dtmp = r(i,ib)
+ rtrold(ib) = rtrold(ib) + dtmp**2
+ enddo
+ enddo
+ call global_sum_vec(nblock, rtrold)
+
+
+!! if (stop_condition(rtrold, res, bb)) goto 9999
+
+ do ib = 1, nblock
+ !! precon F=MR
+
+ !$omp parallel do
+ do i = 1, size_sc_field
+ f(i,ib) = r(i,ib)
+ enddo
+
+ call wdagw(w(1,ib), f(1,ib), id)
+ niter = niter +1
+ nitert= nitert+1
+
+ !$omp parallel do
+ do i = 1, size_sc_field
+ v(i,ib) = w(i,ib)
+ enddo
+ enddo
+
+ do niter = 1, cg_para%maxiter
+
+ do ib = 1, nblock
+ wr=wr+sc_cdotc(w(1,ib),r(1,ib))
+ ww=ww+sc_norm2(w(1,ib))
+ do jb = 1, nblock
+ rv(ib,jb)=sc_cdotc(r(1,ib),v(1,jb))
+ rr(ib,jb)=sc_cdotc(r(1,ib),r(1,jb))
+ enddo
+ enddo
+ !! globalsum
+ xi=1
+ alpha=1
+
+ do ib = 1, nblock
+ !$omp parallel do
+ do i = 1, size_sc_field
+ s(i,ib) = p(i,ib) - zeta * v(i,ib)
+ enddo
+ enddo
+
+ do ib = 1, nblock
+ do i = 1, size_sc_field
+ tmp=0
+ do jb = 1, nblock
+ tmp = tmp + s(i,jb) * alpha(jb,ib)
+ enddo
+ u(i,ib) = tmp
+ enddo
+ enddo
+
+
+
+
+
+ call wdagw(aap, p, id) ; nitert= nitert+1
+ paap = ZERO
+ !$omp parallel do reduction(+: paap) private(dtmp1, dtmp2)
+ do i = 1, size_sc_field
+ dtmp1 = p(i)
+ dtmp2 = aap(i)
+ paap = paap + dtmp1 * dtmp2
+ enddo
+ call global_sum_vec(1, paap)
+ ak = rtrold / paap
+
+ rtr = 0.0_8
+ !$omp parallel do reduction(+: rtr) private(dtmp)
+ do i = 1, size_sc_field
+ x(i) = x(i) + ak * p(i)
+ r(i) = r(i) - ak * aap(i)
+ dtmp = r(i)
+ rtr = rtr + dtmp**2
+ enddo
+ call global_sum_vec(1, rtr)
+
+
+if(my_pe()==0 .and. mod(niter,100)==0 )write(0,*)"cg res:",nitert, niter, rtr
+#ifdef DEBUG2
+if(my_pe()==0 .and. mod(niter,100)==0 )write(0,*)"cg res:",niter, rtr
+#endif
+
+ if (stop_condition(rtr, res, bb)) goto 9999
+ bk = rtr / rtrold
+ rtrold = rtr
+
+ call sc_xpby(p, r, bk) ! p = r + bk * p
+ enddo
+
+ niter = niter - 1
+
+ if (cg_para%log /= 2) then
+if(my_pe()==0) write(0,*)"no conv=============="
+if(my_pe()==0) write(0,*)"p(1)=",p(1)
+ call wdagw_r8(aap, p, id)
+if(my_pe()==0) write(0,*)"wdagw_r8 aap(1)=",aap(1)
+if(my_pe()==0) write(0,*)"wdagw_r8 aap(2)=",aap(2)
+if(my_pe()==0) write(0,*)"wdagw_r8 aap(3)=",aap(3)
+if(my_pe()==0) write(0,*)"wdagw_r8 aap(4)=",aap(4)
+ call wdagw(aap, p, id)
+if(my_pe()==0) write(0,*)"wdagw aap(1)=",aap(1)
+if(my_pe()==0) write(0,*)"wdagw aap(2)=",aap(2)
+if(my_pe()==0) write(0,*)"wdagw aap(3)=",aap(3)
+if(my_pe()==0) write(0,*)"wdagw aap(4)=",aap(4)
+
+
+ write(msg, *) "cg(): no convergence; rtr = ", rtr
+ call die(msg)
+ endif
+
+9999 continue
+
+ call update_cg_stat(cg_stat, niter, 0)
+ cg_iterations_total = cg_stat%niter_tot_run
+ iter = niter
+ if(my_pe()==0 )write(0,*)"CG done! res:",nitert, niter, rtr
+
+ TIMING_STOP(timing_bin_cg)
+
+ if (cg_para%check /= 0) then ! check solution
+
+ call check_solution(id, x, b, norm)
+
+ if (headline_check_written == 0) then
+ if (my_pe() == 0) then
+ write(UREC, fmt_chk_h) &
+ "T", key_chk, "traj", "rtr", "Rb", "Rx", "iterations"
+ endif
+ headline_check_written = 1
+ endif
+
+ if (my_pe() == 0) then
+ write(UREC, fmt_chk_b) &
+ key_chk, counter%traj, rtr, &
+ norm(1)/norm(2), norm(1)/norm(3), iter
+ endif
+
+ endif
+
+ deallocate(r, STAT = ierr)
+ if (ierr /= 0) then
+ call stderr2_int("deallocation failed", 1, ierr)
+ call die("cg: deallocation failed r")
+ endif
+ deallocate(p, STAT = ierr)
+ if (ierr /= 0) then
+ call stderr2_int("deallocation failed", 1, ierr)
+ call die("cg: deallocation failed p")
+ endif
+ deallocate(aap, STAT = ierr)
+ if (ierr /= 0) then
+ call stderr2_int("deallocation failed", 1, ierr)
+ call die("cg: deallocation failed aap")
+ endif
+
+ DEBUG2S("End: cg")
+end
+
+!===============================================================================
diff --git a/src/fermi/solver/cg.F90 b/src/fermi/solver/cg.F90
index bd3fb7ccc884fb371117df2afa8631fb82ed1c76..79578e9aaa1493742102a76876e7d54ff9af09ac 100644
--- a/src/fermi/solver/cg.F90
+++ b/src/fermi/solver/cg.F90
@@ -25,6 +25,10 @@
!-------------------------------------------------------------------------------
# include "defs.h"
+#ifdef PRECISION_R16
+# define stop_condition stop_condition_r16
+#endif
+
!-------------------------------------------------------------------------------
subroutine cg(x, b, id, iter, res)
use module_function_decl
@@ -47,6 +51,7 @@ subroutine cg(x, b, id, iter, res)
DOUBLE :: rtr, rtrold, paap, bb, dtmp, dtmp1, dtmp2
integer :: i, niter, ierr
character(72) :: msg
+ integer, save :: nitert=0
!
! needed for checking solution
@@ -84,7 +89,6 @@ subroutine cg(x, b, id, iter, res)
endif
-
bb = 0.0_8
!$omp parallel do reduction(+: bb) private(dtmp)
do i = 1, size_sc_field
@@ -100,7 +104,8 @@ subroutine cg(x, b, id, iter, res)
DEBUG2S("Start: cg 1")
call wdagw(r, x, id)
niter = 1
- DEBUG2S("Start: cg 2")
+ nitert= nitert+1
+
rtrold = ZERO
!$omp parallel do reduction(+: rtrold) private(dtmp)
do i = 1, size_sc_field
@@ -109,14 +114,14 @@ subroutine cg(x, b, id, iter, res)
dtmp = r(i)
rtrold = rtrold + dtmp**2
enddo
- DEBUG2S("Start: cg 3")
call global_sum_vec(1, rtrold)
+
+ if(my_pe()==0 )write(0,*)"CG start rtr kappa:", rtrold, action%mtilde(id)%kappa
if (stop_condition(rtrold, res, bb)) goto 9999
- DEBUG2S("Start: cg 4")
bk=ZERO
do niter = 1, cg_para%maxiter
- call wdagw(aap, p, id)
+ call wdagw(aap, p, id) ; nitert= nitert+1
paap = ZERO
!$omp parallel do reduction(+: paap) private(dtmp1, dtmp2)
do i = 1, size_sc_field
@@ -138,7 +143,7 @@ subroutine cg(x, b, id, iter, res)
call global_sum_vec(1, rtr)
#ifdef DEBUG2
-if(my_pe()==0 .and. mod(niter,100)==0 )write(0,*)niter,"rtr",rtr
+if(my_pe()==0 .and. mod(niter,100)==0 )write(0,*)"CG rtr iter :",rtr, niter, nitert
#endif
if (stop_condition(rtr, res, bb)) goto 9999
@@ -164,7 +169,6 @@ if(my_pe()==0) write(0,*)"wdagw aap(2)=",aap(2)
if(my_pe()==0) write(0,*)"wdagw aap(3)=",aap(3)
if(my_pe()==0) write(0,*)"wdagw aap(4)=",aap(4)
-
write(msg, *) "cg(): no convergence; rtr = ", rtr
call die(msg)
endif
@@ -174,6 +178,7 @@ if(my_pe()==0) write(0,*)"wdagw aap(4)=",aap(4)
call update_cg_stat(cg_stat, niter, 0)
cg_iterations_total = cg_stat%niter_tot_run
iter = niter
+ if(my_pe()==0 )write(0,*)"CG done! rtr iter :",rtr, niter, nitert
TIMING_STOP(timing_bin_cg)
diff --git a/src/fermi/solver/cg_control.F90 b/src/fermi/solver/cg_control.F90
index 118416efd84aef2e74fff2a23694f50ef3c112fd..cea94b04b830f422cd38ababad64f43731229aee 100644
--- a/src/fermi/solver/cg_control.F90
+++ b/src/fermi/solver/cg_control.F90
@@ -71,9 +71,17 @@ subroutine cg_outer(x, b, id, np, calc_sf)
endif
case("bicgstab"); call bicgstab( x, b, id, iters, res)
case("gmres"); call gmres( x, b, id, iters, res)
+ case("gcrodr")
+ call init_gcrodr()
+ call gcrodr( x, b, id, iters, res)
case("cg_mix")
call cg_mix( x, b, id, iters, iters4, res)
call iteration_count_is_f4(iters4, np)
+#ifdef QUAD
+ case("cg_mix_r16")
+ call cg_mix_r16( x, b, id, iters, iters4, res)
+ call iteration_count_is_f4(iters4, np)
+#endif
case("bicgstab_mix")
call bicgstab_mix( x, b, id, iters, iters4, res)
call iteration_count_is_f4(iters4, np)
@@ -350,6 +358,14 @@ subroutine cg_inner(x, b, id, iters, res)
DEBUG2S("Start: cg_inner")
#ifndef BAGEL
+#ifdef IBM
+ select case(inner_solver)
+ case("cg"); call cg( x, b, id, iters_tmp, res)
+ case("bicgstab"); call bicgstab(x, b, id, iters_tmp, res)
+ case default
+ call die("cg_inner: unknown solver: " // inner_solver )
+ end select
+#else
allocate(x4(SIZE_COMPLEX*NDIRAC*NCOL*volh_tot), STAT = ierr)
if (ierr /= 0) then
call stderr2_int("allocation failed", 1, ierr)
@@ -388,7 +404,7 @@ subroutine cg_inner(x, b, id, iters, res)
call stderr2_int("deallocation failed", 1, ierr)
call die("cg_inner: deallocation failed b4")
endif
-
+#endif
#else
select case(inner_solver)
case("cg"); call cg( x, b, id, iters_tmp, res)
@@ -458,6 +474,7 @@ subroutine mcg_outer(type, b, id, n, frdo, shift, iter_sh, np, calc_sf)
use module_vol
use module_dd
use module_function_decl
+ use module_rhmc
implicit none
integer, intent(in) :: n, calc_sf, id, type, np ! np for iter count
@@ -466,25 +483,33 @@ subroutine mcg_outer(type, b, id, n, frdo, shift, iter_sh, np, calc_sf)
REAL, intent(in) :: shift(n)
COMPLEX, dimension(NDIRAC, NCOL, volh_tot), intent(in) :: b
- REAL :: res
- integer :: iters, i8, i4
+ REAL :: res, res_sh(n)
+ integer :: i, iters, i8, i4
external :: wdagw_r8, wtdagwt_all_dd, unprec_hdagh
call get_cg_res(res, calc_sf)
+ res_sh=res
+
+ if (calc_sf == CG_MD .and. associated(relax)) then
+ do i = 1, size(relax)
+ res_sh(i)=res * relax(i)
+ enddo
+ endif
+
select case(type)
case(EO_RATIONAL)
- call multi_shift_cg(wdagw_r8, id, n, frdo, shift, b, iters, iter_sh, res)
-!! call fom_shift(wdagw_r8, id, n, frdo, shift, b, iters, iter_sh, res)
+ call multi_shift_cg(wdagw_r8, id, n, frdo, shift, b, iters, iter_sh, res_sh)
+!! call fom_shift(wdagw_r8, id, n, frdo, shift, b, iters, iter_sh, res_sh)
!! not work
-!! call gmres_shift(wdagw_r8, id, n, frdo, shift, b, iters, iter_sh, res)
+!! call gmres_shift(wdagw_r8, id, n, frdo, shift, b, iters, iter_sh, res_sh)
call iteration_count_is_f(iters, np)
case(DD_RATIONAL)
- call multi_shift_cg(wtdagwt_all_dd, id, n, frdo, shift, b, iters, iter_sh, res)
-!! call fom_shift( wtdagwt_all_dd, id, n, frdo, shift, b, iters, iter_sh, res)
+ call multi_shift_cg(wtdagwt_all_dd, id, n, frdo, shift, b, iters, iter_sh, res_sh)
+!! call fom_shift( wtdagwt_all_dd, id, n, frdo, shift, b, iters, iter_sh, res_sh)
call iteration_count_is_d( iters*ld%lat%num_ip,np)
case(HH_RATIONAL)
call init_cg_stat2(dd_stat)
- call multi_shift_cg(unprec_hdagh, id, n, frdo, shift, b, iters, iter_sh, res)
+ call multi_shift_cg(unprec_hdagh, id, n, frdo, shift, b, iters, iter_sh, res_sh)
call get_cg_stat2(dd_stat, i8,i4)
call iteration_count_is_d( i8,np)
call iteration_count_is_d4(i4,np)
diff --git a/src/fermi/solver/cg_mix_r16.F90 b/src/fermi/solver/cg_mix_r16.F90
new file mode 100644
index 0000000000000000000000000000000000000000..1661d2f8f130888d72cf715499df914b222be02f
--- /dev/null
+++ b/src/fermi/solver/cg_mix_r16.F90
@@ -0,0 +1,168 @@
+!===============================================================================
+!
+! cg_mix_r16.F90 - mixed precision cg
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2010 Yoshifumi Nakamura
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+# include "defs.h"
+
+!-------------------------------------------------------------------------------
+subroutine cg_mix_r16(x, b, id, iter, iter4, res)
+ use module_function_decl
+ use module_check_solution
+ use module_field
+ use module_action
+ use module_mre_r16
+ use module_cg
+ use module_counter
+ use module_vol
+ implicit none
+
+ type(type_mre_r16), save :: solutions
+
+ SPINCOL_OVERINDEXED, intent(inout) :: x
+ SPINCOL_OVERINDEXED, intent(in) :: b
+ integer, intent(out) :: iter, iter4
+ integer, intent(in) :: id
+ REAL, intent(in) :: res
+
+ real(8), allocatable ::r(:),p(:)
+ real(16), allocatable ::r16(:),p16(:),x16(:)
+ real(16) :: rtr, interval, rtr0, bb
+ integer :: i, niter, ierr
+ character(72) :: msg
+
+!
+! needed for checking solution
+!
+ REAL :: norm(3)
+ integer, save :: headline_check_written = 0
+ character(*), parameter :: key_chk = "%cgmixChk"
+ character(*), parameter :: fmt_chk_h = "(1x, 2a, a6, 5a20)"
+ character(*), parameter :: fmt_chk_b = "(1x, a10, i6, 3e20.10, 2i20)"
+
+!-------------------------------------------------------------------------------
+ DEBUG2S("Start: cg_mix_r16")
+ TIMING_START(timing_bin_cg_mix)
+
+ allocate(r(SIZE_COMPLEX*NDIRAC*NCOL*volh_tot), STAT = ierr)
+ allocate(p(SIZE_COMPLEX*NDIRAC*NCOL*volh_tot), STAT = ierr)
+ allocate(r16(SIZE_COMPLEX*NDIRAC*NCOL*volh_tot), STAT = ierr)
+ allocate(p16(SIZE_COMPLEX*NDIRAC*NCOL*volh_tot), STAT = ierr)
+ allocate(x16(SIZE_COMPLEX*NDIRAC*NCOL*volh_tot), STAT = ierr)
+
+ iter4 = 0
+
+ bb = 0
+ !$omp parallel do reduction(+: bb)
+ do i = 1, size_sc_field
+ bb = bb + (real(b(i),kind=16))**2
+ enddo
+ call global_sum_vec_r16(1, bb)
+
+ x16=x
+ call wdagw_r16(r16, x16, id)
+ niter = 1
+
+ rtr = 0
+ !$omp parallel do reduction(+: rtr)
+ do i = 1, size_sc_field
+ r16(i) = b(i) - r16(i)
+ rtr = rtr + r16(i)**2
+ enddo
+ call global_sum_vec_r16(1, rtr)
+
+ if (stop_condition_r16(rtr, real(res,kind=16), bb)) goto 9999
+ rtr0=rtr
+
+ do niter = 1, cg_para%maxiter
+!! call mre_get2_r16(solutions, p16, r16, id)
+ p=p16
+ r=r16
+!! p=r
+ call cg_inner(p, r, id, iter4, dble(res_cg_inner(res, dble(rtr0), dble(bb), niter)))
+ p16=p
+!! call mre_put(solutions, p16, 0)
+
+ !$omp parallel do
+ do i = 1, size_sc_field
+ x16(i) = x16(i) + p16(i)
+ enddo
+
+ call wdagw_r16(r16, x16, id)
+ rtr = 0
+ !$omp parallel do reduction(+: rtr)
+ do i = 1, size_sc_field
+ r16(i) = b(i) - r16(i)
+ rtr = rtr + r16(i)**2
+ enddo
+ call global_sum_vec_r16(1, rtr)
+
+ if (stop_condition_r16(rtr, real(res,kind=16), bb)) goto 9999
+ enddo
+
+ niter = niter - 1
+
+ if (cg_para%log /= 2) then
+ write(msg, *) "cg(): no convergence; rtr = ", rtr
+ call die(msg)
+ endif
+
+9999 continue
+ call mre_put(solutions, p, 1)
+ call update_cg_stat(cg_stat, niter, 0)
+
+ x=x16
+ iter = niter
+
+ TIMING_STOP(timing_bin_cg_mix)
+
+!! if (cg_para%check /= 0) then ! check solution
+!!
+!! call check_solution(id, x, b, norm)
+!!
+!! if (headline_check_written == 0) then
+!! if (my_pe() == 0) then
+!! write(UREC, fmt_chk_h) &
+!! "T", key_chk, "traj", "rtr", "Rb", "Rx", "iterations", "iter4"
+!! endif
+!!
+!! headline_check_written = 1
+!! endif
+!!
+!! if (my_pe() == 0) then
+!! write(UREC, fmt_chk_b) &
+!! key_chk, counter%traj, rtr, norm(1)/norm(2), norm(1)/norm(3), &
+!! niter, iter4
+!! endif
+!! endif
+
+ deallocate(r, STAT = ierr)
+ deallocate(p, STAT = ierr)
+ deallocate(r16, STAT = ierr)
+ deallocate(p16, STAT = ierr)
+ deallocate(x16, STAT = ierr)
+
+ DEBUG2S("End: cg_mix_r16")
+stop
+end
+
+!===============================================================================
diff --git a/src/fermi/solver/cg_mre_mtmp.F90 b/src/fermi/solver/cg_mre_mtmp.F90
index 7f79f453aa8dadb810819078db20371e00ee2e7f..bb8f2d4c6df2baac21b261c477128f72f5e800ca 100644
--- a/src/fermi/solver/cg_mre_mtmp.F90
+++ b/src/fermi/solver/cg_mre_mtmp.F90
@@ -4,7 +4,7 @@
!
!-------------------------------------------------------------------------------
!
-! Copyright (C) 2006-2009 Yoshifumi Nakamura
+! Copyright (C) 2006-2010 Yoshifumi Nakamura
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
@@ -137,6 +137,92 @@ subroutine mre_get2(basis, trial, phi, id)
end
+!-------------------------------------------------------------------------------
+#ifdef QUAD
+subroutine mre_get2_r16(basis, trial, phi, id)
+
+ ! get trial solution
+
+ use module_function_decl
+ use module_mre_r16
+ use module_vol
+ implicit none
+
+ type(type_mre_r16), intent(inout) :: basis
+ real(16), dimension(SIZE_COMPLEX*NDIRAC*NCOL*volh_tot), intent(out) :: trial
+ real(16), dimension(SIZE_COMPLEX*NDIRAC*NCOL*volh_tot), intent(in) :: phi
+ integer , intent(in) :: id
+
+ type(type_mre_r16), save :: mv ! "Matrix * v"
+ complex(16), target :: g(mre_n_vec_r16, mre_n_vec_r16 + 1)
+ complex(16), pointer :: b(:)
+ integer :: size_g
+ integer :: i
+ integer :: j
+ integer :: s
+ integer :: c
+ integer :: rest
+
+
+ DEBUG2S("Start: mre_get2_r16")
+
+ if (mre_n_vec_r16 == 0 .or. .not. associated(basis%vec) .or. basis%rank == 0) then
+ call sc_copy_r16(trial, phi)
+ DEBUG2S("End: mre_get2_r16")
+ return
+ endif
+
+ if (basis%rank == 1) then
+ call sc_copy_r16(trial, basis%vec(1)%sc(1,1,1))
+ DEBUG2S("End: mre_get2_r16")
+ return
+ endif
+
+ size_g = mre_n_vec_r16 * (mre_n_vec_r16 + 1) * SIZE_COMPLEX
+
+ b => g(:, mre_n_vec_r16 + 1) ! storage arrangement for global sum
+ ! => one global sum for everything
+
+ call mre_allocate_r16(mv)
+ call mre_gram_schmidt_r16(basis)
+
+ do i = 1, basis%rank
+ b(i) = sc_cdotc_r16(basis%vec(i)%sc(1,1,1), phi)
+ call wmul_r16(mv%vec(i)%sc(1,1,1), basis%vec(i)%sc(1,1,1), id)
+ enddo
+
+ do i = 1, basis%rank
+ g(i, i) = sc_norm2_r16(mv%vec(i)%sc(1,1,1))
+ do j = i + 1, basis%rank
+ g(i, j) = sc_cdotc_r16(mv%vec(i)%sc(1,1,1), mv%vec(j)%sc(1,1,1))
+ g(j, i) = conjg(g(i, j))
+ enddo
+ enddo
+
+ call global_sum_vec_r16(size_g, g)
+
+ call mre_gauss_jordan_r16(g, b, basis%rank, mre_n_vec_r16)
+
+ ! calculation of "trial" with doubled data re-use:
+
+ call sc_cax2_r16(trial, basis%vec(1)%sc(1,1,1), b(1), basis%vec(2)%sc(1,1,1), b(2))
+
+ rest = mod(basis%rank, 2)
+
+ do j = 3, basis%rank - rest, 2
+ call sc_caxpy2_r16(trial, basis%vec(j)%sc(1,1,1), b(j), &
+ basis%vec(j+1)%sc(1,1,1), b(j+1))
+ enddo
+
+ if (rest == 1) then
+ j = basis%rank
+ call sc_caxpy_r16(trial, basis%vec(j)%sc(1,1,1), b(j))
+ endif
+
+ DEBUG2S("End: mre_get2_r16")
+
+end
+#endif
!===============================================================================
!===============================================================================
!-------------------------------------------------------------------------------
diff --git a/src/fermi/solver/cg_ritz.F90 b/src/fermi/solver/cg_ritz.F90
index 33195673e14179011fc7cd2447b662f4aecfb4b4..61b9b373d457551ef3e4a7a67effe13a72fc354d 100644
--- a/src/fermi/solver/cg_ritz.F90
+++ b/src/fermi/solver/cg_ritz.F90
@@ -282,7 +282,6 @@ subroutine cg_ritz_half(ftype, id, iter, mu, x, evecs, n, action)
call die("cg_ritz_half can not treat this fermionic type")
endif
-
call orthogonalize_sc_half(n, evecs, z)
pap = sc_dot(p, z) ; pap = global_sum(pap)
call min_ritz_func(mu, costheta, sintheta, rtr, pap, pp, action)
diff --git a/src/fermi/solver/check_solution.F90 b/src/fermi/solver/check_solution.F90
index 542c79721fa6f084c7431edbedf57b1e94116b6b..b284f9366c4867dcf6adeb09f799d1a46cb33984 100644
--- a/src/fermi/solver/check_solution.F90
+++ b/src/fermi/solver/check_solution.F90
@@ -4,7 +4,7 @@
!
!-------------------------------------------------------------------------------
!
-! Copyright (C) 2008 Yoshifumi Nakamura
+! Copyright (C) 2008, 2010 Yoshifumi Nakamura
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
@@ -35,6 +35,14 @@ module module_check_solution
interface check_solution
+#ifdef QUAD
+ subroutine check_solution_r16(id, x, b, norm)
+ real(16), dimension(:), intent(in) :: x, b
+ integer, intent(in) :: id
+ real(16), intent(out):: norm(3)
+ end
+#endif
+
subroutine check_solution_r8(id, x, b, norm)
real(8), dimension(:), intent(in) :: x, b
integer, intent(in) :: id
@@ -76,6 +84,34 @@ module module_check_solution
#endif
end module module_check_solution
+!-------------------------------------------------------------------------------
+#ifdef QUAD
+subroutine check_solution_r16(id, x, b, norm)
+ use module_vol
+ use module_p_interface_r16
+ implicit none
+ real(16), dimension(:), intent(in) :: x, b
+ integer, intent(in) :: id
+ real(16), intent(out):: norm(3)
+ real(16), dimension(:), pointer, save :: r
+ integer :: i
+
+ if (.not. associated(r)) call allocate_sc_overindexed_r16(r)
+
+ call wdagw_r16(r, x, id)
+
+ norm = 0
+ !$omp parallel do reduction(+: norm)
+ do i = 1, size_sc_field
+ norm(1) = norm(1) + (r(i) - b(i))**2
+ norm(2) = norm(2) + b(i)**2
+ norm(3) = norm(3) + x(i)**2
+ enddo
+
+ call global_sum_vec_r16(3, norm)
+
+end
+#endif
!-------------------------------------------------------------------------------
subroutine check_solution_r8(id, x, b, norm)
use module_vol
diff --git a/src/fermi/solver/gcrodr.F90 b/src/fermi/solver/gcrodr.F90
index adce4a7c46de59ea1e9cd4e95bbd176295c37336..69c233b6a913d08b079535939ee10cdba1405ed3 100644
--- a/src/fermi/solver/gcrodr.F90
+++ b/src/fermi/solver/gcrodr.F90
@@ -8,7 +8,7 @@
!
!-------------------------------------------------------------------------------
!
-! Copyright (C) 2008 Yoshifumi Nakamura
+! Copyright (C) 2008, 2010 Yoshifumi Nakamura
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
@@ -29,251 +29,474 @@
# include "defs.h"
!-------------------------------------------------------------------------------
-subroutine gcrodr(x, b, id, iter, res)
+module module_gcrodr
+
+ type type_eigenmodes
+ logical :: initial, fresh
+ complex(8), pointer :: eval(:)
+ complex(8), pointer :: x(:,:)
+ end type type_eigenmodes
+
+ integer, save :: defeig, m
+ type(type_eigenmodes),dimension(:),pointer,save :: emode
+
+
+end module module_gcrodr
+
+!-------------------------------------------------------------------------------
+subroutine init_gcrodr()
+ use module_input
+ use module_gcrodr
+ use module_vol
+ use module_action
+ use module_function_decl
+ implicit none
+ integer, save:: count=0
+ integer :: i
+
+ if (count==1) return
+
+ DEBUG2S("Start: init_gcrodr")
+
+ allocate(emode(size(action%mtilde)))
+ m=input%solver_gcrodr_numarstep
+ defeig=input%solver_gcrodr_numdefvec
+ do i=1, size(action%mtilde)
+ emode(i)%initial=.true.
+ allocate(emode(i)%x(12*volh_tot,defeig))
+ allocate(emode(i)%eval(defeig))
+ enddo
+ count=1
+ if (my_pe()==0) write(0,*)"GCRODR(", defeig, ",", m, ")"
+
+ DEBUG2S("End: init_gcrodr")
+end
+
+!-------------------------------------------------------------------------------
+subroutine gcrodr(x, b, id, iter, res)
use module_function_decl
use module_check_solution
- use module_action
use module_cg
use module_vol
- use module_counter
+ use module_gcrodr
+ use module_action
implicit none
+ complex(8),intent(inout):: x(12*volh_tot)
+ complex(8),intent(in) :: b(12*volh_tot)
+ integer, intent(in) :: id
+ integer, intent(out) :: iter
+ real(8), intent(in) :: res
- SPINCOL_OVERINDEXED, intent(inout) :: x
- SPINCOL_OVERINDEXED, intent(in) :: b
- integer, intent(out) :: iter
- integer, intent(in) :: id
- DOUBLE, intent(in) :: res
+ complex(8) :: r(12*volh_tot), v(12*volh_tot,m+1), vtmp(12*volh_tot,defeig+1)
+ complex(8) :: cc(12*volh_tot,defeig), uu(12*volh_tot,defeig)
- SPINCOL_OVERINDEXED :: r, aap
- REAL :: ak, bk
- DOUBLE :: rtr, paap, bb, dtmp, dtmp1, dtmp2
- integer :: i, niter
- character(72) :: msg
+ integer :: i, j, k, niter, lwork, info
+ integer, save :: itert=0
+ real(8) :: beta, bb, tmp, rtr, rtr_real
+ complex(8) :: h(m+1,m), g(m+1), yy(m+1),htmp(m+1,m),y(m)
+ complex(8):: p(m+1,defeig+1), eval(defeig),evec(m,defeig), gg(m,m), ff(m,m)
+ complex(8):: r_qr(defeig,defeig), qr(m+1,defeig), gtmp(m+1,1), ctmp, ctmp2(defeig)
+ complex(8)::work(m*2)
+ lwork=m*2
-!
-! needed for checking solution
-!
- DOUBLE :: norm(3)
- integer, save :: headline_check_written = 0
- character(*), parameter :: key_chk = "%cgChk"
- character(*), parameter :: fmt_chk_h = "(1x, 2a, a6, 4a20)"
- character(*), parameter :: fmt_chk_b = "(1x, a7, i6, 3e20.10, i20)"
+#ifdef LAPACK
+ DEBUG2S("Start: gcrodr")
-!-------------------------------------------------------------------------------
+ if (m<=defeig) call die("GCRODR impossible m<nev")
+ if (0==defeig) call die("GCRODR inev=0")
- TIMING_START(timing_bin_cg)
+ bb = sc_norm2(b) ; call global_sum_vec(1, bb)
+ call wdagw(r, x, id) ; iter=1 ; itert=itert+1
+ r = b - r
+ rtr=sc_norm2(r) ; call global_sum_vec(1, rtr)
+ niter =1
- bb = 0.0_8
- !$omp parallel do reduction(+: bb) private(dtmp)
- do i = 1, size_sc_field
- dtmp = b(i)
- bb = bb + dtmp**2
- enddo
- call global_sum_vec(1, bb)
-
- DEBUG2R("norm(b)= ", sqrt(bb)/2/action%mtilde(id)%kappa)
- DEBUG2R("rsd = ", dble(res)**2*bb/(2*action%mtilde(id)%kappa)**2)
-
- call wdagw(r, x, id)
- rtrold = ZERO
- !$omp parallel do reduction(+: rtrold) private(dtmp)
- do i = 1, size_sc_field
- r(i) = b(i) - r(i)
- dtmp = r(i)
- rtr = rtr + dtmp**2
- enddo
- call global_sum_vec(1, rtr)
+
+ if (my_pe()==0 )write(0,*)"GCRODR kappa:", action%mtilde(id)%kappa
+ if (my_pe()==0 )write(0,*)"GCRODR res:",itert,iter, rtr
if (stop_condition(rtr, res, bb)) goto 9999
-!----------------------------------------
-
- if (ydefine) then
- call wdagw_mult_nsco(id, k, c, u)
- call qrdcmp_nsco(k, c, h) ! R => h Q => new
- call inv_upper_hessen(k, h) ! h <= h^-1
- call mm_mult_nsco(k, u, h) ! u <= u*h^-1
- call (k, c, x) ! x <= x + U C^+ x
- call orthogonalize_sc(k, c, r) ! r <= r - C C^+ r
- else
- call gmres_m(x, b, r, id, m, rtr)
-!! make Pk, line 14
- not yet
- call km_mult_nsco(k, m, u, v, p) !tilde{Y}_k = V_m P_k, line 15.
-
-!! QR dcmp of underbar{H}_m P_k, line 16
- call mm_mult(hp, uh ,p, m+1, k, m)
- call qrdcmp(hp, q, invr, m+1, k)
-
- call mm_mult_nsco(k, m+1, c, v, q)! C_k = V_{m+1} Q, line 17
- call mm_mult_nsco(k, u, invr) !U_k = tilde{Y}_k R^{-1}, line 18
- endif
+if (.not. emode(id)%initial) then
+ ! when rtr /=rtr_real, this does not work
+ !if (emode(id)%fresh) then
+ ! do i=1,defeig
+ ! uu(:,i)=emode(id)%x(:,i)
+ ! cc(:,i)=emode(id)%ax(:,i)
+ ! enddo
+ !else
+ do i=1,defeig
+ call wdagw(cc(1,i), emode(id)%x(1,i), id) ; iter=iter+1 ; itert=itert+1
+ enddo
+!! for check QR
+! do i=1,defeig
+! call sc_copy(vtmp(1,i), cc(1,i))
+! enddo
+
+ call gram_schmidt2(cc, r_qr, 12*volh_tot, 12*volh, defeig, .true.)
+
+!! check QR
+! do i=1,defeig
+! vtmp(1:12*volh,defeig+1)=ZERO
+! do j=1,defeig
+! if (r_qr(j,i)/=ZERO)then
+! vtmp(1:12*volh,defeig+1)=vtmp(1:12*volh,defeig+1)+ cc(1:12*volh,j) * r_qr(j,i)
+! endif
+! enddo
+! vtmp(1:12*volh,defeig+1)=vtmp(1:12*volh,defeig+1) - vtmp(1:12*volh,i)
+! rtr=sc_norm2(vtmp(1,defeig+1)); call global_sum_vec(1, rtr)
+! if (my_pe()==0)write(0,*)"QR res: ",i,rtr
+! enddo
+
+
+
+ call ZTRTRI( "U", "N", defeig, r_qr, defeig, INFO ) !! R^-1
+
+ uu=ZERO
+ do i=1,defeig
+ do j=1,defeig
+ if (r_qr(j,i)/=ZERO)then
+ uu(1:12*volh,i)=uu(1:12*volh,i)+ emode(id)%x(1:12*volh,j) * r_qr(j,i)
+ endif
+ enddo
+ enddo
+ !endif
+
+ do i=1,defeig
+ ctmp2(i)=sc_cdotc(cc(1,i), r)
+ enddo
+ call global_sum_vec(2*defeig, ctmp2)
+
+ do i=1,defeig
+ x(1:12*volh)=x(1:12*volh)+uu(1:12*volh,i)*ctmp2(i)
+ r(1:12*volh)=r(1:12*volh)-cc(1:12*volh,i)*ctmp2(i)
+ enddo
+ rtr=sc_norm2(r) ; call global_sum_vec(1, rtr)
+
+!! do i=1,defeig
+!! call sc_copy(emode(id)%x(1,i), uu(1,i)) ! \til{Y}
+!! enddo
+! call wdagw(vtmp(1,1), x, id) ; iter = iter +1
+! vtmp(:,1)=vtmp(:,1)-b
+! rtr_real=sc_norm2(vtmp(1,1)) ; call global_sum_vec(1, rtr_real)
+!! if (max(rtr_real, rtr) > 1.01_8* min(rtr_real,rtr) ) then
+! write(0,*)rtr,rtr_real
+!! stop
+!! endif
+
+else
+
+ v(1:12*volh,1)=r(1:12*volh)
+ call normalize_sc_half(v(1,1), beta)
+ h=ZERO
- do niter = 1, cg_para%maxiter
- if (stop_condition(rtr, res, bb)) goto 9999
- h=ZERO
- do i = 1, k
- v(i)%sco = u(i)%sco
- call normalize_sc(v(i)%sco, dummy)
- h(i,i) = ONE/dummy
- enddo
- v(k+1)%sco = r
- call normalize_sc(v(k+1)%sco, dummy)
- do j = k+1, m
- call wdagw(v(j+1)%sco, v(j)%sco, id)
- call orthogonalize_sc(k, c, (v(j+1)%sco) ! v <= (I - C C^+)Av
- do i = 1, j
- h(i,j) = sc_dot(v(j+1)%sco, v(i)%sco)
- h(i,j) = global_sum(h(i,j))
- call sc_axpy(v(j+1)%sco, v(i)%sco, -h(i,j))
- enddo
- call normalize_sc(v(j+1)%sco, h(j+1,j))
+ do j = 1, m !!!!! gmres(m)
+ call wdagw(v(1,j+1), v(1,j), id) ; iter = iter +1 ; itert=itert+1
+ do i = 1, j
+ h(i,j) = sc_cdotc(v(1,i), v(1,j+1)) ; call global_sum_vec(2, h(i,j))
+ v(1:12*volh,j+1) = v(1:12*volh,j+1) - h(i,j) * v(1:12*volh,i)
enddo
- do j = k+1, m
- call wdagw(aap, v(j)%sco, id)
- do i = 1, k
- xx=sc_cdotc(c(i)%sco, aap)
- call global_sum_vec(2, xx)
- h(i,j) = xx
- enddo
- enddo
-
- htmp = h
- !!!!!!!!!!!!!!!!!!!!!!! koko kara
+ call normalize_sc_half(v(1,j+1), tmp)
+ h(j+1,j)=tmp
enddo
+ g=ZERO; g(1)=beta
+ beta=h(m+1,m) !!! NEW beta
+ htmp=h; gtmp(:,1)=g
+ call zgels("N", m+1, m, 1, htmp, m+1, gtmp, m+1, work,lwork, info)
+ y(1:m)=gtmp(1:m,1)
+ do j = 1, m
+ x(1:12*volh) = x(1:12*volh) + v(1:12*volh,j) * y(j)
+ enddo
+ gtmp(:,1)=g
+ call zgemv("N", m+1, m, (dcmplx(-ONE,ZERO)), h, m+1, y, 1, (dcmplx(ONE,ZERO)), gtmp, 1)
+ yy(:)=gtmp(:,1)
- niter = niter - 1
+ r(1:12*volh) = v(1:12*volh,1) * yy(1)
+ do i = 2, m+1
+ r(1:12*volh) = r(1:12*volh) + v(1:12*volh,i) * yy(i)
+ enddo
+ rtr=sc_norm2(r) ; call global_sum_vec(1, rtr)
- if (cg_para%log /= 2) then
- write(msg, *) "cg(): no convergence; rtr = ", rtr
- call die(msg)
- endif
+! call wdagw(vtmp(1,1), x, id)
+! vtmp(:,1)=vtmp(:,1)-b
+! rtr_real=sc_norm2(vtmp(1,1)) ; call global_sum_vec(1, rtr_real)
+! write(0,*)rtr,rtr_real
-9999 continue
+ call zhritz(eval, evec, h(1:m,1:m), beta, m, defeig)
+ p(1:m,1:defeig)=evec(1:m,1:defeig)
- call update_cg_stat(gcrodr_stat, niter, 0)
- iter = niter
+ vtmp=ZERO
+ do i=1,defeig
+ do j=1,m
+ vtmp(:,i) = vtmp(:,i) + v(:,j) * p(j,i)
+ enddo
+ enddo
+ do i=1,defeig
+ call sc_copy(emode(id)%x(1,i),vtmp(1,i))
+ enddo
- TIMING_STOP(timing_bin_cg)
+ qr=ZERO
+ do i=1,m+1
+ do j=1,defeig
+ do k=1, m
+ qr(i,j)=qr(i,j)+h(i,k)*p(k,j)
+ enddo
+ enddo
+ enddo !!! this is HmPk
- if (cg_para%check /= 0) then ! check solution
+ call zqr(qr,r_qr,m+1,defeig)
+ call ZTRTRI( "U", "N", defeig, r_qr, defeig, INFO ) !! R^-1
- call check_solution(id, x, b, norm)
+ cc=ZERO
+ uu=ZERO
+ do i=1,defeig
+ do j=1,m+1
+ cc(1:12*volh,i)=cc(1:12*volh,i)+ v(1:12*volh,j) * qr(j,i)
+ enddo
+ enddo
- if (headline_check_written == 0) then
- if (my_pe() == 0) then
- write(UREC, fmt_chk_h) &
- "T", key_chk, "traj", "rtr", "Rb", "Rx", "iterations"
+ do i=1,defeig
+ do j=1,defeig
+ if (r_qr(j,i)/=ZERO)then
+ uu(1:12*volh,i)=uu(1:12*volh,i)+ emode(id)%x(1:12*volh,j) * r_qr(j,i)
endif
- headline_check_written = 1
- endif
-
- if (my_pe() == 0) then
- write(UREC, fmt_chk_b) &
- key_chk, counter%traj, rtr, &
- norm(1)/norm(2), norm(1)/norm(3), iter
- endif
+ enddo
+ enddo
- endif
+! !! check U and C
+! do i =1, defeig
+! call wdagw(vtmp(1,1), uu(1,i), id)
+! vtmp(:,1)=vtmp(:,1)-cc(:,i)
+! rtr_real=sc_norm2(vtmp(1,1)) ; call global_sum_vec(1, rtr_real)
+! if (my_pe()==0)write(0,*)"|Au-c|",i,rtr_real
+! enddo
+
+endif
+
+if (my_pe()==0 )write(0,*)"GCRODR res:",itert, iter, rtr
+if (stop_condition(rtr, res, bb)) goto 9999
+
+do niter = 1, cg_para%maxiter
+ h=ZERO
+ do i = 1, defeig
+ call normalize_sc_half(uu(1,i), tmp)
+ h(i,i)=ONE/tmp
+ v(1:12*volh,i)=uu(1:12*volh,i)
+ enddo
+
+ DEBUG2S("gcrodr 101")
+
+ j=defeig
+ v(1:12*volh,j+1) = r(1:12*volh)
+ call normalize_sc_half(v(1,j+1), tmp)
+ do j = defeig+1, m
+ call wdagw(vtmp(1,1), v(1,j), id) ; iter = iter +1 ; itert=itert+1
+ do i = 1, defeig
+ h(i,j) = sc_cdotc(cc(1,i), vtmp(1,1)) ; call global_sum_vec(2, h(i,j))
+ enddo
+ call projecton_imvv(v(1,j+1), vtmp(1,1), cc, 12*volh_tot, 12*volh, defeig, .true.)
+ do i = 1, defeig
+ ctmp = sc_cdotc(cc(1,i), v(1,j+1)) ; call global_sum_vec(2, ctmp)
+ v(1:12*volh,j+1) = v(1:12*volh,j+1) - ctmp * cc(1:12*volh,i)
+ enddo
+ do i = defeig+1, j
+ h(i,j) = sc_cdotc(v(1,i), v(1,j+1)) ; call global_sum_vec(2, h(i,j))
+ v(1:12*volh,j+1) = v(1:12*volh,j+1) - h(i,j) * v(1:12*volh,i)
+ enddo
+ call normalize_sc_half(v(1,j+1), tmp)
+ h(j+1,j)=tmp
+ enddo
-end
+ DEBUG2S("gcrodr 102")
-!-------------------------------------------------------------------------------
-subroutine qrdcmp(input, q, invr, n, k)
- implicit none
- COMPLEX, intent(in) :: input(n,k)
- COMPLEX, intent(out) :: q(n,k), invr(k,k)
- integer, intent(in) :: n, k
+ do i = 1, defeig
+ g(i)=sc_cdotc(cc(1,i), r)
+ enddo
+ do i = defeig+1, m+1
+ g(i)=sc_cdotc(v(1,i), r)
+ enddo
+ call global_sum_vec(2*(m+1), g)
-end
+ DEBUG2S("gcrodr 103")
-!-------------------------------------------------------------------------------
-subroutine mv_mult(out, in1, in2, c, r)
- implicit none
+ htmp=h; gtmp(:,1)=g
+ call zgels("N", m+1, m, 1, htmp, m+1, gtmp, m+1, work,lwork, info)
+ y(1:m)=gtmp(1:m,1)
- COMPLEX, intent(out) :: out(c)
- COMPLEX, intent(out) :: in1(c,r), in2(r)
- integer, intent(in) :: c, r
- integer :: i, j, k
+ DEBUG2S("gcrodr 104")
- !$omp parallel do
- do i = 1, c
- out(i) = in1(i,1) * in2(1)
+ do j = 1, m
+ x(1:12*volh) = x(1:12*volh) + v(1:12*volh,j) * y(j)
enddo
- do j = 2, r
- !$omp parallel do
- do i = 1, c
- out(i) = out(i) + in1(i,j) * in2(j)
+
+ DEBUG2S("gcrodr 105")
+
+ yy=ZERO
+ do i = 1, m+1
+ do j = 1, m
+ yy(i) = yy(i) + h(i,j) * y(j)
enddo
enddo
-end
+ DEBUG2S("gcrodr 106")
-!-------------------------------------------------------------------------------
-subroutine mm_mult(out, in1, in2, c, r, m)
- implicit none
+ do i = 1, defeig
+ r(1:12*volh) = r(1:12*volh) - cc(1:12*volh,i) * yy(i)
+ enddo
+ do i = defeig+1, m+1
+ r(1:12*volh) = r(1:12*volh) - v(1:12*volh,i) * yy(i)
+ enddo
+ rtr=sc_norm2(r) ; call global_sum_vec(1, rtr)
+
+ DEBUG2S("gcrodr 107")
+
+ call wdagw(vtmp(1,1), x, id) ; iter = iter +1 ; itert=itert+1
+ vtmp(:,1)=vtmp(:,1)-b
+ rtr_real=sc_norm2(vtmp(1,1)) ; call global_sum_vec(1, rtr_real)
+ if (max(rtr_real, rtr) > 1.01_8* min(rtr_real,rtr) ) then
+ if (my_pe()==0)write(0,*)"GCRODR inconsistent res!!!"
+ if (my_pe()==0)write(0,*)"GCRODR rtr, rtt_real",rtr,rtr_real
+ if (stop_condition(rtr_real, res, bb)) then
+ if (my_pe()==0)write(0,*) &
+ "GCRODR rtt_real satisfies stopping condition, finilize without error"
+ goto 9999
+ endif
+ stop
+ endif
- COMPLEX, intent(out) :: out(c, r)
- COMPLEX, intent(out) :: in1(c,m), in2(m,r)
- integer, intent(in) :: c, r, m
- integer :: i, j, k
+ DEBUG2S("gcrodr 108")
+
+htmp=ZERO
+do i=1,defeig
+ do j=1,m
+ htmp(i,j)=sc_cdotc(cc(1,i),v(1,j))
+ enddo
+enddo
+do i=defeig+1,m+1
+ do j=1,m
+ htmp(i,j)=sc_cdotc(v(1,i),v(1,j))
+ enddo
+enddo
+call global_sum_vec(2*m*(m+1), htmp)
+
+ DEBUG2S("gcrodr 109")
+
+
+ff=ZERO
+do i=1,m
+do j=1,m
+do k=1,m+1
+ ff(i,j)=ff(i,j)+conjg(h(k,i))*htmp(k,j)
+enddo
+enddo
+enddo
+
+ DEBUG2S("gcrodr 110")
+
+
+gg=ZERO
+do i=1,m
+do j=1,m
+do k=1,m+1
+ gg(i,j)=gg(i,j)+conjg(h(k,i))*h(k,j)
+enddo
+enddo
+enddo
+
+ DEBUG2S("gcrodr 111")
+
+ call zgeneigen(eval, evec, gg, ff, m, defeig)
+ p(1:m,1:defeig)=evec(1:m,1:defeig)
+
+ if (my_pe()==0 .and. mod(niter,10)==0) then
+ do j=1,defeig
+ write(0,*)"GCRODR eval",itert, iter,j,eval(j)
+ enddo
+ endif
- do j = 1, r
- !$omp parallel do
- do i = 1, c
- out(i,j) = in1(i,1) * in2(1,j)
+ do i=1,defeig
+ call sc_zero(emode(id)%x(1,i))
+ do j=1,m
+ emode(id)%x(1:12*volh,i) = emode(id)%x(1:12*volh,i) + v(1:12*volh,j) * p(j,i)
enddo
enddo
- do k = 2, m
- do j = 1, r
- !$omp parallel do
- do i = 1, c
- out(i,j) = out(i,j) + in1(i,k) * in2(k,j)
+ qr=ZERO
+ do i=1,m+1
+ do j=1,defeig
+ do k=1, m
+ qr(i,j)=qr(i,j)+h(i,k)*p(k,j)
enddo
enddo
- enddo
+ enddo !!! this is HmPk
-end
+ DEBUG2S("gcrodr 114")
-!-------------------------------------------------------------------------------
-subroutine qrdcmp_nsco(n, v, h)
- use typedef
- use module_function_decl
- implicit none
- type(sco_field),intent(inout) :: v(n)
- REAL, intent(out) :: h(n,n)
- integer, intent(in) :: n
- integer :: i, j
+ call zqr(qr,r_qr,m+1,defeig)
+ call ZTRTRI( "U", "N", defeig, r_qr, defeig, INFO ) !! R^-1
- h=ZERO
- do j = 1, n
- do j = 1, j-1
- h(i,j) = sc_dot(v(i)%sco, v(j)%sco)
- h(i,j) = global_sum(h(i,j))
- call sc_axpy(v(i)%sco, v(j)%sco, -h(i,j))
+ DEBUG2S("gcrodr 115")
+
+ do i=1,defeig
+ uu(1:12*volh,i)=ZERO
+ do j=1,defeig
+ if (r_qr(j,i)/=ZERO)then
+ uu(1:12*volh,i)=uu(1:12*volh,i)+ emode(id)%x(1:12*volh,j) * r_qr(j,i)
+ endif
enddo
- call normalize_sc(v(i)%sco, h(j,j))
enddo
-end
+ DEBUG2S("gcrodr 116")
-!-------------------------------------------------------------------------------
-subroutine wdagw_mult_nsco(id, n, out, in)
- use typedef
- implicit none
+ vtmp=ZERO
+ do i=1,defeig
+ do j=1,defeig
+ vtmp(:,i)=vtmp(:,i) + cc(:,j) * qr(j,i)
+ enddo
+ do j=defeig+1,m+1
+ vtmp(:,i)=vtmp(:,i) + v(:,j) * qr(j,i)
+ enddo
+ enddo
+ do i=1,defeig
+ cc(:,i)= vtmp(:,i)
+ enddo
+
+ DEBUG2S("gcrodr 117")
+
+ if (my_pe()==0 .and. mod(niter,1+ int(50/m) )==0 )write(0,*)"GCRODR res:",itert, iter, rtr
+ if (stop_condition(rtr, res, bb)) goto 9999
- type(sco_field),intent(out) :: out(n)
- type(sco_field),intent(in) :: in(n)
- integer, intent(in) :: id, n
- integer :: i
- do i = 1, n
- call wdagw(out(i)%sco, in(i)%sco, id)
+enddo
+
+ DEBUG2S("gcrodr 201")
+
+ niter = niter - 1
+ if (cg_para%log /= 2) then
+ write(0, *) "gcrodr(): no convergence; rtr = ", rtr ; stop
+ endif
+ 9999 continue
+
+ if (my_pe()==0 )write(0,*)"GCRODR res:",itert, iter, rtr
+ DEBUG2S("gcrodr 300")
+
+! must be changed
+ do i=1,defeig
+ call sc_copy(emode(id)%x(1,i), uu(1,i)) ! \til{Y}
enddo
+ emode(id)%fresh=.true.
+ emode(id)%initial=.false.
-end
-!===============================================================================
+ DEBUG2S("gcrodr 301")
+
+ call update_cg_stat(cg_stat, iter, 0) !! must be changed
+
+#else
+ call die("gcrodr needs LAPCK")
+#endif
+
+ DEBUG2S("End: init_gcrodr")
+end
diff --git a/src/fermi/solver/gcrodr_dd.F90 b/src/fermi/solver/gcrodr_dd.F90
index dfa5ac27e31d4c3c47b04d470f25f73445a69396..3a281b387e17813dc447bc40d3652fea57a28bcc 100644
--- a/src/fermi/solver/gcrodr_dd.F90
+++ b/src/fermi/solver/gcrodr_dd.F90
@@ -202,7 +202,7 @@ do niter = 1, cg_para%maxiter
do i = 1, defeig
h(i,j) = ddsc_cdotc(cc(1,i), vtmp(1,1))
enddo
- call projecton_imvv(v(1,j+1), vtmp(1,1), cc, 12*ld%lat%volh, defeig)
+ call projecton_imvv(v(1,j+1), vtmp(1,1), cc, 12*ld%lat%volh, 12*ld%lat%volh, defeig, .false.)
do i = 1, defeig
ctmp = ddsc_cdotc(cc(1,i), v(1,j+1))
v(:,j+1) = v(:,j+1) - ctmp * cc(:,i)
@@ -373,20 +373,22 @@ enddo
end
!-------------------------------------------------------------------------------
-subroutine projecton_imvv(out, in, v, len, k) ! out=(I - V_k V_k^H) in
+subroutine projecton_imvv(out, in, v, lenall, len, k, global) ! out=(I - V_k V_k^H) in
implicit none
- complex(8), dimension(len) :: in, out
- complex(8), dimension(len,k):: v
- integer :: i, j, k, len
+ complex(8), dimension(lenall) :: in, out
+ complex(8), dimension(lenall,k):: v
+ integer :: i, j, k, len, lenall
+ logical :: global
complex(8) :: fac
- out(:) = in(:)
+ out(1:len) = in(1:len)
do i = 1, k
fac=ZERO
do j = 1, len
fac = fac + conjg(v(j,i)) * in(j)
enddo
- out(:) = out(:) - fac * v(:,i)
+ if (global) call global_sum_vec(2, fac)
+ out(1:len) = out(1:len) - fac * v(1:len,i)
enddo
end
@@ -404,7 +406,7 @@ subroutine zhritz(eval, evec, h, beta, m, n) ! return 'SM' harmonic ritz pairs
complex(8),allocatable :: work(:)
integer :: lwork, info, ilo,ihi, ipiv(m), i,j
-#ifdef LAPCK
+#ifdef LAPACK
scale=ONE
@@ -529,7 +531,7 @@ subroutine zqr(q, r, m, n)
#ifdef LAPACK
-!! write(0,*)"zqr: initial A",q
+! write(0,*)"zqr: initial A",q
allocate(work(10)) !! dummy allocation
lwork=-1
@@ -562,15 +564,18 @@ subroutine zqr(q, r, m, n)
if (info/=0)write(0,*)"ZUNGQR failed at zqr err",info
if (info/=0)call die("ZUNGQR failed at zqr")
-!! qr=ZERO
-!! do i=1,m
-!! do j=1,n
-!! do k=1,n
-!! qr(i,j)=qr(i,j)+q(i,k)*r(k,j)
-!! enddo
-!! enddo
-!! enddo
-!! write(0,*)"zqr: result qr",qr
+!! call gram_schmidt(q, r, m, n, .false.)
+
+! qr=ZERO
+! do i=1,m
+! do j=1,n
+! do k=1,n
+! qr(i,j)=qr(i,j)+q(i,k)*r(k,j)
+! enddo
+! enddo
+! enddo
+! write(0,*)"zqr: result qr",qr
+
deallocate(work)
diff --git a/src/fermi/solver/gmres.F90 b/src/fermi/solver/gmres.F90
index c9a4858e73c5acc87e7aa2e06ddb367f1c8cadd0..197b2d0498549c8f3170a858cbacf0736d5aef0b 100644
--- a/src/fermi/solver/gmres.F90
+++ b/src/fermi/solver/gmres.F90
@@ -420,7 +420,7 @@ subroutine gmrespj_dd(matrix, x, b, id, ip, iter, res, m)
real(8), external :: ddsc_norm2
integer :: i, j, k, niter, lwork, info, mdm
real(8) :: vv, beta, inv, bb, tmp, rtr, ttt(m), rtr_real
- complex(8) :: h(m+1,m), g(m+1), yy(m+1), htmp(m+1,m),y(m)
+ complex(8) :: h(m+1,m), g(m+1), yy(m+1), htmp(m+1,m),y(m), r_dummy(defeig,defeig)
complex(8) :: eval(defeig),evec(m,defeig), gtmp(m+1,1), gg(m,m),ff(m,m)
complex(8)::work(80)
lwork=80
@@ -541,7 +541,7 @@ enddo
enddo
- call gram_schmidt(vtmp, 12*ld%lat%volh, defeig, .false.)
+ call gram_schmidt(vtmp, r_dummy, 12*ld%lat%volh, defeig, .false.)
do i=1,defeig
v(:,i)=vtmp(:,i)
enddo
@@ -596,7 +596,7 @@ subroutine gmresdr_dd(matrix, x, b, id, ip, iter, res, m)
real(8), external :: ddsc_norm2
integer :: i, j, k, niter, lwork,info, mdm
real(8) :: beta, inv, bb, tmp, rtr, rtr_real
- complex(8) :: h(m+1,m), g(m+1), yy(m+1),htmp(m+1,m),y(m), rr(defeig+1,defeig+1)
+ complex(8) :: h(m+1,m), g(m+1), yy(m+1),htmp(m+1,m),y(m), rr(defeig+1,defeig+1), r_dummy(defeig,defeig)
complex(8) :: p(m+1,defeig+1), eval(defeig),evec(m,defeig), gtmp(m+1,1)
complex(8)::work(80)
lwork=80
@@ -701,13 +701,10 @@ do niter = 1, cg_para%maxiter
p(1:m,1:defeig)=evec(1:m,1:defeig)
p(m+1,1:defeig)=dcmplx(ZERO,ZERO)
- call gram_schmidt(p, m+1, defeig, .false.)
+ call gram_schmidt(p, r_dummy, m+1, defeig, .false.)
p(:,defeig+1)= yy(:)
call gram_schmidt_last(p, m+1, defeig+1, .false.)
-!! call zqr(p, rr, m+1, defeig+1)
-!! call gram_schmidt(p, m+1, defeig+1, .false.)
-
!
! calculation of new H and V
@@ -738,7 +735,6 @@ do niter = 1, cg_para%maxiter
enddo
call gram_schmidt_last(vtmp, 12*ld%lat%volh, defeig+1, .false.)
-!! call gram_schmidt(vtmp, 12*ld%lat%volh, defeig+1, .false.)
do i=1,defeig+1
v(:,i)=vtmp(:,i)
diff --git a/src/fermi/solver/mre.F90 b/src/fermi/solver/mre.F90
index e3cceb5b6b4af310688ba4b8a7978b8d869cec8e..6f7eebce794d0eb8619ae949aae1a308c443446a 100644
--- a/src/fermi/solver/mre.F90
+++ b/src/fermi/solver/mre.F90
@@ -26,6 +26,13 @@
!-------------------------------------------------------------------------------
# include "defs.h"
+#ifdef PRECISION_R16
+# define vec_norm2_c8 vec_norm2_c16
+# define vec_cdotc_c8 vec_cdotc_c16
+# define vec_dot_c8 vec_dot_c16
+#endif
+
+
!-------------------------------------------------------------------------------
subroutine mre_put(basis, sc_field, reset) ! add a solution
@@ -66,86 +73,86 @@ subroutine mre_put(basis, sc_field, reset) ! add a solution
end
!-------------------------------------------------------------------------------
-subroutine mre_get(basis, matrix_mult, trial, phi, para, conf)
-
- ! get trial solution
-
- use typedef_hmc
- use module_function_decl
- use module_mre
- use module_vol
- implicit none
-
- type(type_mre), intent(inout) :: basis
- external :: matrix_mult
- SPINCOL_FIELD, intent(out) :: trial
- SPINCOL_FIELD, intent(in) :: phi
- type(hmc_para), intent(in) :: para
- type(hmc_conf), intent(in) :: conf
-
- type(type_mre), save :: mv ! "Matrix * v"
- COMPLEX, target :: g(mre_n_vec, mre_n_vec + 1)
- COMPLEX, pointer :: b(:)
- integer :: size_g
- integer :: i
- integer :: j
- integer :: s
- integer :: c
- integer :: rest
-
- if (mre_n_vec == 0 .or. .not. associated(basis%vec) .or. basis%rank == 0) then
- call sc_copy(trial, phi)
- return
- endif
-
- if (basis%rank == 1) then
- call sc_copy(trial, basis%vec(1)%sc)
- return
- endif
-
- size_g = mre_n_vec * (mre_n_vec + 1) * SIZE_COMPLEX
-
- b => g(:, mre_n_vec + 1) ! storage arrangement for global sum
- ! => one global sum for everything
-
- call mre_allocate(mv)
- call mre_gram_schmidt(basis)
-
- do i = 1, basis%rank
- b(i) = sc_cdotc(basis%vec(i)%sc, phi)
- call matrix_mult(mv%vec(i)%sc, basis%vec(i)%sc, para, conf)
- enddo
-
- do i = 1, basis%rank
- g(i, i) = sc_norm2(mv%vec(i)%sc)
- do j = i + 1, basis%rank
- g(i, j) = sc_cdotc(mv%vec(i)%sc, mv%vec(j)%sc)
- g(j, i) = conjg(g(i, j))
- enddo
- enddo
-
- call global_sum_vec(size_g, g)
-
- call mre_gauss_jordan(g, b, basis%rank, mre_n_vec)
-
- ! calculation of "trial" with doubled data re-use:
-
- call sc_cax2(trial, basis%vec(1)%sc, b(1), basis%vec(2)%sc, b(2))
-
- rest = mod(basis%rank, 2)
-
- do j = 3, basis%rank - rest, 2
- call sc_caxpy2(trial, basis%vec(j)%sc, b(j), &
- basis%vec(j+1)%sc, b(j+1))
- enddo
-
- if (rest == 1) then
- j = basis%rank
- call sc_caxpy(trial, basis%vec(j)%sc, b(j))
- endif
-
-end
-
+!!subroutine mre_get(basis, matrix_mult, trial, phi, para, conf)
+!!
+!! ! get trial solution
+!!
+!! use typedef_hmc
+!! use module_function_decl
+!! use module_mre
+!! use module_vol
+!! implicit none
+!!
+!! type(type_mre), intent(inout) :: basis
+!! external :: matrix_mult
+!! SPINCOL_FIELD, intent(out) :: trial
+!! SPINCOL_FIELD, intent(in) :: phi
+!! type(hmc_para), intent(in) :: para
+!! type(hmc_conf), intent(in) :: conf
+!!
+!! type(type_mre), save :: mv ! "Matrix * v"
+!! COMPLEX, target :: g(mre_n_vec, mre_n_vec + 1)
+!! COMPLEX, pointer :: b(:)
+!! integer :: size_g
+!! integer :: i
+!! integer :: j
+!! integer :: s
+!! integer :: c
+!! integer :: rest
+!!
+!! if (mre_n_vec == 0 .or. .not. associated(basis%vec) .or. basis%rank == 0) then
+!! call sc_copy(trial, phi)
+!! return
+!! endif
+!!
+!! if (basis%rank == 1) then
+!! call sc_copy(trial, basis%vec(1)%sc)
+!! return
+!! endif
+!!
+!! size_g = mre_n_vec * (mre_n_vec + 1) * SIZE_COMPLEX
+!!
+!! b => g(:, mre_n_vec + 1) ! storage arrangement for global sum
+!! ! => one global sum for everything
+!!
+!! call mre_allocate(mv)
+!! call mre_gram_schmidt(basis)
+!!
+!! do i = 1, basis%rank
+!! b(i) = sc_cdotc(basis%vec(i)%sc, phi)
+!! call matrix_mult(mv%vec(i)%sc, basis%vec(i)%sc, para, conf)
+!! enddo
+!!
+!! do i = 1, basis%rank
+!! g(i, i) = sc_norm2(mv%vec(i)%sc)
+!! do j = i + 1, basis%rank
+!! g(i, j) = sc_cdotc(mv%vec(i)%sc, mv%vec(j)%sc)
+!! g(j, i) = conjg(g(i, j))
+!! enddo
+!! enddo
+!!
+!! call global_sum_vec(size_g, g)
+!!
+!! call mre_gauss_jordan(g, b, basis%rank, mre_n_vec)
+!!
+!! ! calculation of "trial" with doubled data re-use:
+!!
+!! call sc_cax2(trial, basis%vec(1)%sc, b(1), basis%vec(2)%sc, b(2))
+!!
+!! rest = mod(basis%rank, 2)
+!!
+!! do j = 3, basis%rank - rest, 2
+!! call sc_caxpy2(trial, basis%vec(j)%sc, b(j), &
+!! basis%vec(j+1)%sc, b(j+1))
+!! enddo
+!!
+!! if (rest == 1) then
+!! j = basis%rank
+!! call sc_caxpy(trial, basis%vec(j)%sc, b(j))
+!! endif
+!!
+!!end
+!!
!-------------------------------------------------------------------------------
subroutine mre_allocate(basis)
@@ -298,9 +305,9 @@ subroutine mre2_get(matrix, basis, trial, phi, id, ip)
implicit none
type(type_mre2), intent(inout) :: basis
- complex(8), intent(out) :: trial(:)
- complex(8),target,intent(in) :: phi(:)
- complex(8),pointer :: tmp(:)
+ COMPLEX, intent(out) :: trial(:)
+ COMPLEX,target,intent(in) :: phi(:)
+ COMPLEX,pointer :: tmp(:)
integer, intent(in) :: id
integer,optional, intent(in) :: ip
external :: matrix
@@ -367,17 +374,17 @@ subroutine mre2_get(matrix, basis, trial, phi, id, ip)
end
!-------------------------------------------------------------------------------
-! for complex(8)
+! for complex(RKIND)
!-------------------------------------------------------------------------------
subroutine mre2_put(basis, field, reset, vec_size) ! add a solution
use module_mre2
implicit none
type(type_mre2), intent(inout) :: basis
- integer, intent(in) :: reset, vec_size
- complex(8), intent(in) :: field(vec_size)
- complex(8),pointer :: tmp(:)
- integer :: i
+ integer, intent(in) :: reset, vec_size
+ COMPLEX, intent(in) :: field(vec_size)
+ COMPLEX,pointer :: tmp(:)
+ integer :: i
if (mre2_n_vec == 0) return
call mre2_allocate(basis, vec_size)
diff --git a/src/fermi/solver/multi_shift_cg.F90 b/src/fermi/solver/multi_shift_cg.F90
index 24a0099a2c11e7609a0c5431ccd7d4fa265dd277..6b096c1bcf29d01dc1ef76196f470629866a8911 100644
--- a/src/fermi/solver/multi_shift_cg.F90
+++ b/src/fermi/solver/multi_shift_cg.F90
@@ -36,13 +36,13 @@ subroutine multi_shift_cg(matrix, id, n, shift_switch, betabar, b, iterations, n
integer, intent(out) :: iterations, niter_shift(n)
integer, intent(in) :: shift_switch(n), n, id
REAL, intent(in) :: betabar(n)
- REAL, intent(in) :: res
+ REAL, intent(in) :: res(n)
external :: matrix
REAL, allocatable ::r(:),p(:),aap(:)
REAL :: alpha, alpha_old, beta, beta_new, rtr, rtrold, paap, bb
REAL,dimension(n) :: sxi_old,sxi,sxi_new,salpha,salpha_old,sbeta, sbeta_new
- integer :: i,j, niter, n_min, n_con(n), niter_sub , ierr
+ integer :: i,j, niter, n_min, n_con(n), niter_sub , ierr, ncon
character(72) :: msg
@@ -105,18 +105,24 @@ niter_sub=0
call sc_axpy(sco(1,j)%sco(1), sco(2,j)%sco(1), -salpha(j))
niter_sub = niter_sub + 1
- if (stop_condition(sxi_new(j)*sxi_new(j)*rtr, res, bb)) niter_shift(j)= niter
- if (stop_condition(sxi_new(j)*sxi_new(j)*rtr, res, bb)) n_con(j)=1
-!! if ( sxi_new(j)*sxi_new(j)*rtr <= res ) niter_shift(j)= niter
-!! if ( sxi_new(j)*sxi_new(j)*rtr <= res ) n_con(j)=1
+ if (stop_condition(sxi_new(j)*sxi_new(j)*rtr, res(j), bb)) niter_shift(j)= niter
+ if (stop_condition(sxi_new(j)*sxi_new(j)*rtr, res(j), bb)) n_con(j)=1
+!! if ( sxi_new(j)*sxi_new(j)*rtr <= res(j) ) niter_shift(j)= niter
+!! if ( sxi_new(j)*sxi_new(j)*rtr <= res(j) ) n_con(j)=1
endif
enddo
#ifdef DEBUG2
if(my_pe()==0 .and. mod(niter,100)==0 )write(0,*)niter,"mcg:rtr",sxi_new(n_min)*sxi_new(n_min)*rtr
#endif
- if (stop_condition(sxi_new(n_min)*sxi_new(n_min)*rtr, res, bb)) goto 9999
-!! if ( sxi_new(n_min)*sxi_new(n_min)*rtr <= res ) goto 9999
+ if (stop_condition(sxi_new(n_min)*sxi_new(n_min)*rtr, res(n_min), bb)) then
+ ncon=0
+ do j = n_min, n
+ ncon=ncon + n_con(j)
+ enddo
+ if (ncon == n - n_min +1) goto 9999
+ endif
+!! if ( sxi_new(n_min)*sxi_new(n_min)*rtr <= res(n_min) ) goto 9999
beta_new = rtr / rtrold
rtrold = rtr
@@ -192,7 +198,7 @@ subroutine fom_shift(matrix, id, n, shift_switch, betabar, b, iterations, niter_
integer, intent(out):: iterations, niter_shift(n)
integer, intent(in) :: shift_switch(n), n, id
REAL, intent(in) :: betabar(n)
- REAL, intent(in) :: res
+ REAL, intent(in) :: res(n)
external :: matrix
integer,parameter :: m = 3
@@ -200,7 +206,7 @@ subroutine fom_shift(matrix, id, n, shift_switch, betabar, b, iterations, niter_
complex(8) :: h1,h2, g1,g2,cs, w(12*volh_tot,m+1)
complex(8) :: h(m+1,m), htmp(m+1,m), c(m+1), ctmp(m+1),s(m+1), stmp(m+1),d(m,n)
real(8) :: bb, rtr, rho(n), r2, sn, tmp, inv ,fac
- integer :: i,j, niter, n_min, n_con(n), ns, scsize, niter_sub
+ integer :: i,j, niter, n_min, n_con(n), ncon, ns, scsize, niter_sub
character(72) :: msg
logical :: nsend(n)
@@ -271,14 +277,20 @@ do niter=1, cg_para%maxiter
call sc_copy(sco(1, ns)%sco(1),x)
niter_shift(ns)=niter*m
- nsend(ns)=stop_condition(rho(ns)**2, res, bb)
+ nsend(ns)=stop_condition(rho(ns)**2, res(ns), bb)
niter_sub = niter_sub + 1
endif
enddo ! end of ns
call sc_copy(r,v(1,m+1))
- if (nsend(n_min)) goto 9999
+ if (nsend(n_min)) then
+ ncon=0
+ do i = n_min, n
+ if (nsend(i)) ncon=ncon + 1
+ enddo
+ if (ncon == n - n_min +1) goto 9999
+ endif
enddo
9999 iterations = niter
@@ -313,7 +325,7 @@ subroutine gmres_shift(matrix, id, n, shift_switch, betabar, b, iterations, nite
integer, intent(out) :: iterations, niter_shift(n)
integer, intent(in) :: shift_switch(n), n, id
REAL, intent(in) :: betabar(n)
- REAL, intent(in) :: res
+ REAL, intent(in) :: res(n)
external :: matrix
integer,parameter :: m = 5
@@ -347,15 +359,13 @@ do niter=1, cg_para%maxiter
s=ZERO
h=ZERO
rtr = sc_norm2(r) ; rtr=global_sum(rtr)
- if (rtr<res)go to 9999
+ if (rtr<res(1))go to 9999
inv=ONE/sqrt(rtr)
v(1:scsize,1) = r(1:scsize) * inv
c(1)=sc_cdotc(v(1,1), r) ; call global_sum_vec(2,c(1))
do j = 1, m
-! tmp=sqrt(res)
-! call cg_inner(w(1,j), v(1,j), id, iter4, res)
call matrix(v(1,j+1), v(1,j), id)
@@ -464,7 +474,7 @@ do niter=1, cg_para%maxiter
enddo
call sc_copy(sco(1, ns)%sco(1),x)
niter_shift(ns)=niter
- nsend(ns)=(beta(ns)<res)
+ nsend(ns)=(beta(ns)<res(ns))
enddo
do i=1,m+1
diff --git a/src/fermi/solver/solver.F90 b/src/fermi/solver/solver.F90
index 33fc1cba04af5c5b7e06a8555a4913edb1e87f6b..4ec320d00dfff02db64e973b96950d794fe596f4 100644
--- a/src/fermi/solver/solver.F90
+++ b/src/fermi/solver/solver.F90
@@ -166,9 +166,10 @@ subroutine bcgs(matrix, x, b, m)
end
!-------------------------------------------------------------------------------
-subroutine gram_schmidt(inout, len, n, global)
+subroutine gram_schmidt(inout, r, len, n, global) ! and QR dcmp
implicit none
complex(8), dimension(len,n), intent(inout):: inout
+ complex(8), dimension(n,n), intent(out):: r
integer, intent(in) :: len,n
real(8), external :: vecnorm2
complex(8),external :: veccdotc
@@ -177,30 +178,82 @@ subroutine gram_schmidt(inout, len, n, global)
logical :: global
integer :: i, j
+ r = ZERO
+! do i=1, n
+! xx=vecnorm2(inout(1,i), len)
+! if(global) call global_sum_vec(1, xx)
+! xx=ONE/sqrt(xx)
+! inout(:,i)=inout(:,i)*xx
+! do j=i+1,n
+! zz = veccdotc(inout(1,i), inout(1,j), len)
+! if(global) call global_sum_vec(2, zz)
+! inout(:,j) = inout(:,j) -zz * inout(:,i)
+! enddo
+! enddo
+
+!! same as above
do i=1, n
+ do j= 1,i-1
+ zz = veccdotc(inout(1,j), inout(1,i), len)
+ if(global) call global_sum_vec(2, zz)
+ r(j,i)=zz
+ inout(:,i) = inout(:,i) -zz * inout(:,j)
+ enddo
xx=vecnorm2(inout(1,i), len)
if(global) call global_sum_vec(1, xx)
- xx=ONE/sqrt(xx)
+ r(i,i)=sqrt(xx)
+ xx=ONE/Re(r(i,i))
inout(:,i)=inout(:,i)*xx
- do j=i+1,n
+ enddo
+
+ xx = ZERO
+ do i = 1, n
+ do j = 1, n
zz = veccdotc(inout(1,i), inout(1,j), len)
if(global) call global_sum_vec(2, zz)
- inout(:,j) = inout(:,j) -zz * inout(:,i)
+ if (i==j)then
+ xx = xx + ( real(zz) - ONE )**2
+ xx = xx + (aimag(zz) )**2
+ else
+ xx = xx + ( real(zz) )**2
+ xx = xx + (aimag(zz) )**2
+ endif
enddo
enddo
+#ifdef DEBUG2
+ write(0,*)"orthonormal check: len=",len,"n=",n,"global:",global,"res=",xx
+#endif
-!! same as above
-!! do i=1, n
-!! do j= 1,i-1
-!! zz = veccdotc(inout(1,j), inout(1,i), len)
-!! if(global) call global_sum_vec(2, zz)
-!! inout(:,i) = inout(:,i) -zz * inout(:,j)
-!! enddo
-!! xx=vecnorm2(inout(1,i), len)
-!! if(global) call global_sum_vec(1, xx)
-!! xx=ONE/sqrt(xx)
-!! inout(:,i)=inout(:,i)*xx
-!! enddo
+end
+
+!-------------------------------------------------------------------------------
+subroutine gram_schmidt2(inout, r, lenall, len, n, global) ! and QR dcmp
+ use module_function_decl
+ implicit none
+ complex(8), dimension(lenall,n), intent(inout):: inout
+ complex(8), dimension(n,n), intent(out):: r
+ integer, intent(in) :: lenall, len,n
+ real(8), external :: vecnorm2
+ complex(8),external :: veccdotc
+ real(8) :: xx
+ complex(8):: zz
+ logical :: global
+ integer :: i, j
+
+ r = ZERO
+ do i=1, n
+ do j= 1,i-1
+ zz = veccdotc(inout(1,j), inout(1,i), len)
+ if(global) call global_sum_vec(2, zz)
+ r(j,i)=zz
+ inout(1:len,i) = inout(1:len,i) -zz * inout(1:len,j)
+ enddo
+ xx=vecnorm2(inout(1,i), len)
+ if(global) call global_sum_vec(1, xx)
+ r(i,i)=sqrt(xx)
+ xx=ONE/r(i,i)
+ inout(1:len,i)=inout(1:len,i)*xx
+ enddo
xx = ZERO
do i = 1, n
@@ -216,6 +269,9 @@ subroutine gram_schmidt(inout, len, n, global)
endif
enddo
enddo
+
+ if (my_pe()==0) write(0,*)"orthonormal check: len=",len,"n=",n,"global:",global,"res=",xx
+!! call stderr2_real("gram_schmidt2:res=",1,xx)
#ifdef DEBUG2
write(0,*)"orthonormal check: len=",len,"n=",n,"global:",global,"res=",xx
#endif
diff --git a/src/fermi/solver/sort.F90 b/src/fermi/solver/sort.F90
index e81ecd1797a8783a44a993f7494093a3e327d8e1..942f4712d2046f9a6c4bdeb8c94940963ec36230 100644
--- a/src/fermi/solver/sort.F90
+++ b/src/fermi/solver/sort.F90
@@ -29,11 +29,11 @@ subroutine sortd(a, idx, n)
real(8) :: a(n), atmp
integer :: i,j
-#ifdef DEBUG2
- do i=1,n
- write(0,*)"sortd:",i,a(i)
- enddo
-#endif
+!#ifdef DEBUG2
+! do i=1,n
+! write(0,*)"sortd:",i,a(i)
+! enddo
+!#endif
idx=1
do j=2, n
@@ -48,11 +48,11 @@ subroutine sortd(a, idx, n)
idx(i+1)=j
end do
-#ifdef DEBUG2
- do i=1,n
- write(0,*)"sortd:",idx(i),a(i)
- enddo
-#endif
+!#ifdef DEBUG2
+! do i=1,n
+! write(0,*)"sortd:",idx(i),a(i)
+! enddo
+!#endif
end
diff --git a/src/fmlib/FM.F90 b/src/fmlib/FM.F90
new file mode 100644
index 0000000000000000000000000000000000000000..c720653df2ed4bf9fcfd2181cd7636499fc40357
--- /dev/null
+++ b/src/fmlib/FM.F90
@@ -0,0 +1,36895 @@
+
+
+
+! FM 1.2 David M. Smith 8-17-01
+
+
+! The routines in this package perform multiple precision arithmetic and
+! functions on three kinds of numbers.
+! FM routines handle floating-point real multiple precision numbers,
+! IM routines handle integer multiple precision numbers, and
+! ZM routines handle floating-point complex multiple precision numbers.
+
+
+! 1. INITIALIZING THE PACKAGE
+
+! The variables that contain values to be shared by the different routines are
+! located in module FMVALS in file FMSAVE.f90. Variables that are described
+! below for controlling various features of the FM package are found in this
+! module. They are initialized to default values assuming 32-bit integers and
+! 64-bit double precision representation of the arrays holding multiple
+! precision numbers. The base and number of digits to be used are initialized
+! to give slightly more than 50 decimal digits. Subroutine FMVARS can be used
+! to get a list of these variables and their values.
+
+! The intent of module FMVALS is to hide the FM internal variables from the
+! user's program, so that no name conflicts can occur. Subroutine FMSETVAR can
+! be used to change the variables listed below to new values. It is not always
+! safe to try to change these variables directly by putting USE FMVALS into the
+! calling program and then changing them by hand. Some of the saved constants
+! depend upon others, so that changing one variable may cause errors if others
+! depending on that one are not also changed. FMSETVAR automatically updates
+! any others that depend upon the one being changed.
+
+! Subroutine FMSET also initializes these variables. It tries to compute the
+! best value for each, and it checks several of the values set in FMVALS to see
+! that they are reasonable for a given machine. FMSET can also be called to
+! set or change the current precision level for the multiple precision numbers.
+
+! Calling FMSET is optional in version 1.2 of the FM package. In previous
+! versions one call was required before any other routine in the package could
+! be used.
+
+! The routine ZMSET from version 1.1 is no longer needed, and the complex
+! operations are automatically initialized in FMVALS. It has been left in the
+! package for compatibility with version 1.1.
+
+
+! 2. REPRESENTATION OF FM NUMBERS
+
+! MBASE is the base in which the arithmetic is done. MBASE must be
+! bigger than one, and less than or equal to the square root of
+! the largest representable integer. For best efficiency MBASE
+! should be large, but no more than about 1/4 of the square root
+! of the largest representable integer. Input and output
+! conversions are much faster when MBASE is a power of ten.
+
+! NDIG is the number of base MBASE digits that are carried in the
+! multiple precision numbers. NDIG must be at least two. The
+! upper limit for NDIG is defined in FMVALS and is restricted
+! only by the amount of memory available.
+
+! Sometimes it is useful to dynamically vary NDIG during the program. Routine
+! FMEQU should be used to round numbers to lower precision or zero-pad them to
+! higher precision when changing NDIG.
+
+! The default value of MBASE is a large power of ten. FMSET also sets MBASE to
+! a large power of ten. For an application where another base is used, such as
+! simulating a given machine's base two arithmetic, use subroutine FMSETVAR to
+! change MBASE, so that the other internal values depending on MBASE will be
+! changed accordingly.
+
+! There are two representations for a floating point multiple precision number.
+! The unpacked representation used by the routines while doing the computations
+! is base MBASE and is stored in NDIG+3 words. A packed representation is
+! available to store the numbers in the user's program in compressed form. In
+! this format, the NDIG (base MBASE) digits of the mantissa are packed two per
+! word to conserve storage. Thus the external, packed form of a number
+! requires (NDIG+1)/2+3 words.
+
+! This version uses double precision arrays to hold the numbers. Version 1.0
+! of FM used integer arrays, which are faster on some machines. The package
+! can be changed to use integer arrays --- see section 11 on EFFICIENCY below.
+
+! The unpacked format of a floating multiple precision number is as follows.
+! A number MA is kept in an array with MA(1) containing the exponent, and
+! MA(2) through MA(NDIG+1) each containing one digit of the mantissa, expressed
+! in base MBASE. The array is dimensioned to start at MA(-1), with the
+! sign of the number (+1 or -1) held in MA(-1), and the approximate number
+! of bits of precision stored in MA(0). This precision value is intended to
+! be used by FM functions that need to monitor cancellation error in addition
+! and subtraction. The cancellation monitor code is usually disabled for user
+! calls, and FM functions only check for cancellation when they must. Tracking
+! cancellation causes most routines to run slower, with addition and
+! subtraction being affected the most. The exponent is a power of MBASE and
+! the implied radix point is immediately before the first digit of the
+! mantissa. Every nonzero number is normalized so that the second array
+! element (the first digit of the mantissa) is nonzero.
+
+! In both representations the sign of the number is carried on the second array
+! element only. Elements 3,4,... are always nonnegative. The exponent is a
+! signed integer and may be as large in magnitude as MXEXP.
+
+! For MBASE = 10,000 and NDIG = 4, if array MA holds the number -pi, it would
+! have these representations:
+! Word 1 2 3 4 5
+
+! Unpacked: 1 3 1415 9265 3590
+! Packed: 1 31415 92653590
+
+! In both formats MA(0) would be 42, indicating that the mantissa has about 42
+! bits of precision, and MA(-1) = -1 since the number is negative.
+
+! Because of normalization in a large base, the equivalent number of base 10
+! significant digits for an FM number may be as small as
+! LOG10(MBASE)*(NDIG-1) + 1.
+
+! The integer routines use the FM format to represent numbers, without the
+! number of digits (NDIG) being fixed. Integers in IM format are essentially
+! variable precision, using the minimum number of words to represent each
+! value.
+
+! For programs using both FM and IM numbers, FM routines should not be called
+! with IM numbers, and IM routines should not be called with FM numbers, since
+! the implied value of NDIG used for an IM number may not match the explicit
+! NDIG expected by an FM routine. Use the conversion routines IMFM2I and
+! IMI2FM to change between the FM and IM formats.
+
+! The format for complex FM numbers (called ZM numbers below) is very similar
+! to that for real FM numbers. Each ZM array holds two FM numbers to represent
+! the real and imaginary parts of a complex number. Each ZM array is twice as
+! long as a corresponding FM array, with the imaginary part starting at the
+! midpoint of the array. As with FM, there are packed and unpacked formats for
+! the numbers.
+
+
+! 3. INPUT/OUTPUT ROUTINES
+
+! All versions of the input routines perform free-format conversion from
+! characters to FM numbers.
+
+! a. Conversion to or from a character array
+
+! FMINP converts from a character*1 array to an FM number.
+
+! FMOUT converts an FM number to base 10 and formats it for output as an
+! array of type character*1. The output is left justified in the
+! array, and the format is defined by two variables in module FMVALS,
+! so that a separate format definition does not have to be provided
+! for each output call.
+
+! JFORM1 and JFORM2 define a default output format.
+
+! JFORM1 = 0 E format ( .314159M+6 )
+! = 1 1PE format ( 3.14159M+5 )
+! = 2 F format ( 314159.000 )
+
+! JFORM2 is the number of significant digits to display (if JFORM1 =
+! 0 or 1). If JFORM2 = 0 then a default number of digits is chosen.
+! The default is roughly the full precision of the number.
+! JFORM2 is the number of digits after the decimal point (if JFORM1 = 2).
+! See the FMOUT documentation for more details.
+
+! b. Conversion to or from a character string
+
+! FMST2M converts from a character string to an FM number.
+
+! FMFORM converts an FM number to a character string according to a format
+! provided in each call. The format description is more like that of
+! a Fortran FORMAT statement, and integer or fixed-point output is
+! right justified.
+
+! c. Direct read or write
+
+! FMPRNT uses FMOUT to print one FM number.
+
+! FMFPRT uses FMFORM to print one FM number.
+
+! FMWRIT writes FM numbers for later input using FMREAD.
+
+! FMREAD reads FM numbers written by FMWRIT.
+
+! The values given to JFORM1 and JFORM2 can be used to define a default output
+! format when FMOUT or FMPRNT are called. The explicit format used in a call
+! to FMFORM or FMFPRT overrides the settings of JFORM1 and JFORM2.
+
+! KW is the unit number to be used for standard output from the package,
+! including error and warning messages, and trace output.
+
+! For multiple precision integers, the corresponding routines IMINP, IMOUT,
+! IMST2M, IMFORM, IMPRNT, IMFPRT, IMWRIT, and IMREAD provide similar input and
+! output conversions. For output of IM numbers, JFORM1 and JFORM2 are ignored
+! and integer format (JFORM1=2, JFORM2=0) is used.
+
+! For ZM numbers, the corresponding routines ZMINP, ZMOUT, ZMST2M, ZMFORM,
+! ZMPRNT, ZMFPRT, ZMWRIT, and ZMREAD provide similar input and output
+! conversions.
+
+! For the output format of ZM numbers, JFORM1 and JFORM2 determine the default
+! format for the individual parts of a complex number as with FM numbers.
+
+! JFORMZ determines the combined output format of the real and
+! imaginary parts.
+
+! JFORMZ = 1 normal setting : 1.23 - 4.56 i
+! = 2 use capital I : 1.23 - 4.56 I
+! = 3 parenthesis format: ( 1.23 , -4.56 )
+
+! JPRNTZ controls whether to print real and imaginary parts
+! on one line whenever possible.
+
+! JPRNTZ = 1 print both parts as a single string :
+! 1.23456789M+321 - 9.87654321M-123 i
+! = 2 print on separate lines without the 'i' :
+! 1.23456789M+321
+! -9.87654321M-123
+
+! For further description of these routines, see sections 9 and 10 below.
+
+
+! 4. ARITHMETIC TRACING
+
+! NTRACE and LVLTRC control trace printout from the package.
+
+! NTRACE = 0 No output except warnings and errors. (Default)
+! = 1 The result of each call to one of the routines
+! is printed in base 10, using FMOUT.
+! = -1 The result of each call to one of the routines
+! is printed in internal base MBASE format.
+! = 2 The input arguments and result of each call to one
+! of the routines is printed in base 10, using FMOUT.
+! = -2 The input arguments and result of each call to one
+! of the routines is printed in base MBASE format.
+
+! LVLTRC defines the call level to which the trace is done. LVLTRC = 1
+! means only FM routines called directly by the user are traced,
+! LVLTRC = 2 also prints traces for FM routines called by other
+! FM routines called directly by the user, etc. Default is 1.
+
+! In the above description, internal MBASE format means the number is
+! printed as it appears in the array --- an exponent followed by NDIG
+! base MBASE digits.
+
+
+! 5. ERROR CONDITIONS
+
+! KFLAG is a condition value returned by the package after each call to one of
+! the routines. Negative values indicate conditions for which a warning
+! message will be printed unless KWARN = 0.
+! Positive values indicate conditions that may be of interest but are not
+! errors. No warning message is printed if KFLAG is nonnegative.
+
+! Subroutine FMFLAG is provided to give the user access to the current
+! condition code. For example, to set the user's local variable LFLAG
+! to FM's internal KFLAG value: CALL FMFLAG(LFLAG)
+
+! KFLAG = 0 Normal operation.
+
+! = 1 One of the operands in FMADD or FMSUB was insignificant with
+! respect to the other, so that the result was equal to
+! the argument of larger magnitude.
+! = 2 In converting an FM number to a one word integer in FMM2I,
+! the FM number was not exactly an integer. The next
+! integer toward zero was returned.
+
+! = -1 NDIG was less than 2 or more than NDIGMX.
+! = -2 MBASE was less than 2 or more than MXBASE.
+! = -3 An exponent was out of range.
+! = -4 Invalid input argument(s) to an FM routine.
+! UNKNOWN was returned.
+! = -5 + or - OVERFLOW was generated as a result from an
+! FM routine.
+! = -6 + or - UNDERFLOW was generated as a result from an
+! FM routine.
+! = -7 The input string (array) to FMINP was not legal.
+! = -8 The character array was not large enough in an
+! input or output routine.
+! = -9 Precision could not be raised enough to provide all
+! requested guard digits. Increasing the value
+! of NDIGMX in file FMSAVE.f90 may fix this.
+! UNKNOWN was returned.
+! = -10 An FM input argument was too small in magnitude to
+! convert to the machine's single or double
+! precision in FMM2SP or FMM2DP. Check that the
+! definitions of SPMAX and DPMAX in file FMSAVE.f90
+! are correct for the current machine.
+! Zero was returned.
+! = -11 Array MBERN is not dimensioned large enough for the
+! requested number of Bernoulli numbers.
+! = -12 Array MJSUMS is not dimensioned large enough for
+! the number of coefficients needed in the
+! reflection formula in FMPGAM.
+
+! When a negative KFLAG condition is encountered, the value of KWARN
+! determines the action to be taken.
+
+! KWARN = 0 Execution continues and no message is printed.
+! = 1 A warning message is printed and execution continues.
+! = 2 A warning message is printed and execution stops.
+
+! The default setting is KWARN = 1.
+
+! When an overflow or underflow is generated for an operation in which an input
+! argument was already an overflow or underflow, no additional message is
+! printed. When an unknown result is generated and an input argument was
+! already unknown, no additional message is printed. In these cases the
+! negative KFLAG value is still returned.
+
+! IM routines handle exceptions like OVERFLOW or UNKNOWN in the same way as FM
+! routines. When using IMMPY, the product of two large positive integers will
+! return +OVERFLOW. The routines IMMPYM and IMPMOD can be used to obtain a
+! modular result without overflow. The largest representable IM integer is
+! MBASE**NDIGMX - 1. For example, if MBASE is 10**7 and NDIGMX is set to 256,
+! integers less than 10**1792 can be used.
+
+
+! 6. OTHER OPTIONS
+
+! KRAD = 0 All angles in the trigonometric functions and inverse functions
+! are measured in degrees.
+! = 1 All angles are measured in radians. (Default)
+
+! KROUND = -1 All results are rounded toward minus infinity.
+! = 0 All results are rounded toward zero (chopped).
+! = 1 All results are rounded to the nearest FM number, or to the
+! value with an even last digit if the result is halfway
+! between two FM numbers. (Default)
+! = 2 All results are rounded toward plus infinity.
+
+! In all cases, while a function is being computed all intermediate
+! results are rounded to nearest, with only the final result being
+! rounded according to KROUND.
+
+! KRPERF = 0 A smaller number of guard digits used, to give nearly perfect
+! rounding. This number is chosen so that the last intermediate
+! result should have error less than 0.001 unit in the last place
+! of the final rounded result. (Default)
+! = 1 Causes more guard digits to be used, to get perfect rounding in
+! the mode set by KROUND. This slows execution speed.
+
+! If a small base is used for the arithmetic, like MBASE = 2, 10, or 16,
+! FM assumes that the arithmetic hardware for some machine is being
+! simulated, so perfect rounding is done without regard for the value
+! of KRPERF.
+! If KROUND = 1, then KRPERF = 1 means returned results are no more than
+! 0.500 units in the last place from the exact mathematical result,
+! versus 0.501 for KRPERF = 0.
+! If KROUND is not 1, then KRPERF = 1 means returned results are no more
+! than 1.000 units in the last place from the exact mathematical result,
+! versus 1.001 for KRPERF = 0.
+
+! KSWIDE defines the maximum screen width to be used for all unit KW output.
+! Default is 80.
+
+! KESWCH controls the action taken in FMINP and other input routines for
+! strings like 'E7' that have no digits before the exponent field.
+! This is sometimes a convenient abbreviation when doing interactive
+! keyboard input.
+! KESWCH = 1 causes 'E7' to translate like '1.0E+7'. (Default)
+! KESWCH = 0 causes 'E7' to translate like '0.0E+7' and give 0.
+
+! CMCHAR defines the exponent letter to be used for FM variable output.
+! Default is 'M', as in 1.2345M+678.
+! Change it to 'E' for output to be read by a non-FM program.
+
+! KDEBUG = 0 No error checking is done to see if input arguments are valid
+! and parameters like NDIG and MBASE are correct upon entry to
+! each routine. (Default)
+! = 1 Some error checking is done. (Slower speed)
+
+! See module FMVALS in file FMSAVE.f90 for additional description of these and
+! other variables defining various FM conditions.
+
+
+! 7. ARRAY DIMENSIONS
+
+! The dimensions of the arrays in the FM package are defined using parameters
+! NDIGMX and NBITS.
+! NDIGMX is the maximum value the user may set for NDIG.
+! NBITS is the number of bits used to represent integers for a given machine.
+! See the EFFICIENCY discussion below.
+
+! The standard version of FM sets NDIGMX = 55, so on a 32-bit machine using
+! MBASE = 10**7 the maximum precision is about 7*54+1 = 379 significant
+! digits. Previous versions of FM set NDIGMX = 256. Two reasons for making
+! this change are:
+! (a) Almost all applications using FM use only 30 to 50 significant digits
+! for checking double or quadruple precision results, and the larger
+! arrays are wasted space.
+! (b) Most FM applications use the derived type interface so that the number
+! of changes to existing code is minimized. Many compilers implement the
+! FM interface by doing copy in / copy out argument passing of the derived
+! types. Copying the entire large array when only a small part of it is
+! being used causes the derived type arithmetic to be slow compared to
+! making direct calls to the subroutines. Setting NDIGMX to be only
+! slightly higher than a program actually uses minimizes any performance
+! penalty for the derived type arithmetic.
+
+! To change dimensions so that 10,000 significant digit calculation can be
+! done, NDIGMX needs to be at least 10**4/7 + 5 = 1434. This allows for a
+! few user guard digits to be defined when the precision is changed using
+! CALL FMSET(10000). Changing 'NDIGMX = 55' to 'NDIGMX = 1434' in FMSAVE.f90
+! will define all the new array sizes.
+
+! If NDIG much greater than 256 is to be used and elementary functions will
+! be needed, they will be faster if array MJSUMS is larger. The parameter
+! defining the size of MJSUMS is set in the standard version by
+! LJSUMS = 8*(LUNPCK+3)
+! The 8 means that up to eight concurrent sums can be used by the elementary
+! functions. The approximate number needed for best speed is given by
+! 0.051*Log(MBASE)*NDIG**0.333 + 1.85
+! For example, with MBASE=10**7 and NDIG=1434 this gives 11. Changing
+! 'LJSUMS = 8*(LUNPCK+3)' to 'LJSUMS = 11*(LUNPCK+3)' in FMSAVE.f90 will give
+! slightly better speed.
+
+! FM numbers in packed format have dimension -1:LPACK, and those in unpacked
+! format have dimension -1:LUNPCK.
+
+! The parameters LPACKZ and LUNPKZ define the size of the packed and unpacked
+! ZM arrays. The real part starts at the beginning of the array, and the
+! imaginary part starts at word KPTIMP for packed format or at word KPTIMU for
+! unpacked format.
+
+
+! 8. PORTABILITY
+
+! In FMSET several variables are set to machine-dependent values, and many of
+! the variables initialized in module FMVALS in file FMSAVE.f90 are checked to
+! see that they have reasonable values. FMSET will print warning messages on
+! unit KW for any of the FMVALS variables that seem to be poorly initialized.
+
+! If an FM run fails, call FMVARS to get a list of all the FMVALS variables
+! printed on unit KW. Setting KDEBUG = 1 at the start may also identify some
+! errors.
+
+! Some compilers object to a function like FMCOMP with side effects such as
+! changing KFLAG or other module variables. Blocks of code in FMCOMP and
+! IMCOMP that modify these variables are identified so they may be removed or
+! commented out to produce a function without side effects. This disables
+! trace printing in FMCOMP and IMCOMP, and error codes are not returned in
+! KFLAG. See FMCOMP and IMCOMP for further details.
+
+! In FMBER2 and FMPGAM several constants are used that require the machine's
+! integer word size to be at least 32 bits.
+
+
+! 9. LIST OF ROUTINES
+
+! These are the FM routines that are designed to be called by the user.
+! All are subroutines except logical function FMCOMP.
+! MA, MB, MC refer to FM format numbers.
+
+! In Fortran-90 and later versions of the Fortran standard, it is potentially
+! unsafe to use the same array more than once in the calling sequence. The
+! operation MA = MA + MB should not be written as
+! CALL FMADD(MA,MB,MA)
+! since the compiler is allowed to pass the three arguments with a copy in /
+! copy out mechanism. This means the third argument, containing the result,
+! might not be copied out last, and then a later copy out of the original
+! input MA could destroy the computed result.
+
+! One solution is to use a third array and then put the result back in MA:
+! CALL FMADD(MA,MB,MC)
+! CALL FMEQ(MC,MA)
+
+! When the first call is doing one of the "fast" operations like addition,
+! the extra call to move the result back to MA can cause a noticeable loss in
+! efficiency. To avoid this, separate routines are provided for the basic
+! arithmetic operations when the result is to be returned in the same array
+! as one of the inputs.
+
+! A routine name with a suffix of "_R1" returns the result in the first
+! input array, and a suffix of "_R2" returns the result in the second input
+! array. The example above would then be:
+! CALL FMADD_R1(MA,MB)
+
+! These routines each have one less argument than the original version, since
+! the output is re-directed to one of the inputs. The result array should
+! not be the same as any input array when the original version of the routine
+! is used.
+
+! The routines that can be used this way are listed below. For others, like
+! CALL FMEXP(MA,MA)
+! the relative cost of doing an extra copy is small. This one should become
+! CALL FMEXP(MA,MB)
+! CALL FMEQ(MB,MA)
+
+! If the derived-type interface is used, as in
+! TYPE (FM) A,B
+! ...
+! A = A + B
+! there is no problem putting the result back into A, since the interface
+! routine creates a temporary scratch array for the result of A + B, allowing
+! copy in / copy out to work.
+
+! For each of these routines there is also a version available for which the
+! argument list is the same but all FM numbers are in packed format. The
+! routines using packed numbers have the same names except 'FM' is replaced by
+! 'FP' at the start of each name.
+
+
+! FMABS(MA,MB) MB = ABS(MA)
+
+! FMACOS(MA,MB) MB = ACOS(MA)
+
+! FMADD(MA,MB,MC) MC = MA + MB
+
+! FMADD_R1(MA,MB) MA = MA + MB
+
+! FMADD_R2(MA,MB) MB = MA + MB
+
+! FMADDI(MA,IVAL) MA = MA + IVAL Increment an FM number by a one word
+! integer. Note this call does not have
+! an "MB" result like FMDIVI and FMMPYI.
+
+! FMASIN(MA,MB) MB = ASIN(MA)
+
+! FMATAN(MA,MB) MB = ATAN(MA)
+
+! FMATN2(MA,MB,MC) MC = ATAN2(MA,MB)
+
+! FMBIG(MA) MA = Biggest FM number less than overflow.
+
+! FMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA).
+! Faster than making two separate calls.
+
+! FMCOMP(MA,LREL,MB) Logical comparison of MA and MB.
+! LREL is a CHARACTER*2 value identifying
+! which of the six comparisons is to be made.
+! Example: IF (FMCOMP(MA,'GE',MB)) ...
+! Also can be: IF (FMCOMP(MA,'>=',MB)) ...
+! CHARACTER*1 is ok: IF (FMCOMP(MA,'>',MB)) ...
+
+! FMCONS Set several saved constants that depend on MBASE,
+! the base being used. FMCONS should be called
+! immediately after changing MBASE.
+
+! FMCOS(MA,MB) MB = COS(MA)
+
+! FMCOSH(MA,MB) MB = COSH(MA)
+
+! FMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA).
+! Faster than making two separate calls.
+
+! FMDIG(NSTACK,KST) Find a set of precisions to use during Newton
+! iteration for finding a simple root starting with
+! about double precision accuracy.
+
+! FMDIM(MA,MB,MC) MC = DIM(MA,MB)
+
+! FMDIV(MA,MB,MC) MC = MA / MB
+
+! FMDIV_R1(MA,MB) MA = MA / MB
+
+! FMDIV_R2(MA,MB) MB = MA / MB
+
+! FMDIVI(MA,IVAL,MB) MB = MA/IVAL IVAL is a one word integer.
+
+! FMDIVI_R1(MA,IVAL) MA = MA/IVAL
+
+! FMDP2M(X,MA) MA = X Convert from double precision to FM.
+
+! FMDPM(X,MA) MA = X Convert from double precision to FM.
+! Faster than FMDP2M, but MA agrees with X only
+! to D.P. accuracy. See the comments in the
+! two routines.
+
+! FMEQ(MA,MB) MB = MA Both have precision NDIG.
+! This is the version to use for standard
+! B = A statements.
+
+! FMEQU(MA,MB,NA,NB) MB = MA Version for changing precision.
+! MA has NA digits (i.e., MA was computed
+! using NDIG = NA), and MB will be defined
+! having NB digits.
+! MB is rounded if NB < NA
+! MB is zero-padded if NB > NA
+
+! FMEXP(MA,MB) MB = EXP(MA)
+
+! FMFLAG(K) K = KFLAG get the value of the FM condition
+! flag -- stored in the internal FM
+! variable KFLAG in module FMVALS.
+
+! FMFORM(FORM,MA,STRING) MA is converted to a character string using format
+! FORM and returned in STRING. FORM can represent
+! I, F, E, or 1PE formats. Example:
+! CALL FMFORM('F60.40',MA,STRING)
+
+! FMFPRT(FORM,MA) Print MA on unit KW using FORM format.
+
+! FMI2M(IVAL,MA) MA = IVAL Convert from one word integer to FM.
+
+! FMINP(LINE,MA,LA,LB) MA = LINE Input conversion.
+! Convert LINE(LA) through LINE(LB)
+! from characters to FM.
+
+! FMINT(MA,MB) MB = INT(MA) Integer part of MA.
+
+! FMIPWR(MA,IVAL,MB) MB = MA**IVAL Raise an FM number to a one word
+! integer power.
+
+! FMLG10(MA,MB) MB = LOG10(MA)
+
+! FMLN(MA,MB) MB = LOG(MA)
+
+! FMLNI(IVAL,MA) MA = LOG(IVAL) Natural log of a one word integer.
+
+! FMM2DP(MA,X) X = MA Convert from FM to double precision.
+
+! FMM2I(MA,IVAL) IVAL = MA Convert from FM to integer.
+
+! FMM2SP(MA,X) X = MA Convert from FM to single precision.
+
+! FMMAX(MA,MB,MC) MC = MAX(MA,MB)
+
+! FMMIN(MA,MB,MC) MC = MIN(MA,MB)
+
+! FMMOD(MA,MB,MC) MC = MA mod MB
+
+! FMMPY(MA,MB,MC) MC = MA * MB
+
+! FMMPY_R1(MA,MB) MA = MA * MB
+
+! FMMPY_R2(MA,MB) MB = MA * MB
+
+! FMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer.
+
+! FMMPYI_R1(MA,IVAL) MA = MA*IVAL
+
+! FMNINT(MA,MB) MB = NINT(MA) Nearest FM integer.
+
+! FMOUT(MA,LINE,LB) LINE = MA Convert from FM to character.
+! LINE is a character array of length LB.
+
+! FMPI(MA) MA = pi
+
+! FMPRNT(MA) Print MA on unit KW using current format.
+
+! FMPWR(MA,MB,MC) MC = MA**MB
+
+! FM_RANDOM_NUMBER(X) X is returned as a double precision random number,
+! uniform on (0,1). High-quality, long-period
+! generator.
+! Note that X is double precision, unlike the similar
+! Fortran intrinsic random number routine, which
+! returns a single-precision result.
+! See the comments in section 10 below and also those
+! in the routine for more details.
+
+! FMREAD(KREAD,MA) MA is returned after reading one (possibly multi-line)
+! FM number on unit KREAD. This routine reads
+! numbers written by FMWRIT.
+
+! FMRPWR(MA,K,J,MB) MB = MA**(K/J) Rational power.
+! Faster than FMPWR for functions like the cube root.
+
+! FMSET(NPREC) Set the internal FM variables so that the precision
+! is at least NPREC base 10 digits plus three base 10
+! guard digits.
+
+! FMSETVAR(STRING) Define a new value for one of the internal FM
+! variables in module FMVALS that controls one of the
+! FM options. STRING has the form variable = value.
+! Example: To change the screen width for FM output:
+! CALL FMSETVAR(' KSWIDE = 120 ')
+! The variables that can be changed and the options
+! they control are listed in sections 2 through 6
+! above. Only one variable can be set per call.
+! The variable name in STRING must have no embedded
+! blanks. The value part of STRING can be in any
+! numerical format, except in the case of variable
+! CMCHAR, which is character type. To set CMCHAR to
+! 'E', don't use any quotes in STRING:
+! CALL FMSETVAR(' CMCHAR = E ')
+
+! FMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer.
+
+! FMSIN(MA,MB) MB = SIN(MA)
+
+! FMSINH(MA,MB) MB = SINH(MA)
+
+! FMSP2M(X,MA) MA = X Convert from single precision to FM.
+
+! FMSQR(MA,MB) MB = MA * MA Faster than FMMPY.
+
+! FMSQR_R1(MA) MA = MA * MA
+
+! FMSQRT(MA,MB) MB = SQRT(MA)
+
+! FMSQRT_R1(MA) MA = SQRT(MA)
+
+! FMST2M(STRING,MA) MA = STRING
+! Convert from character string to FM.
+! STRING may be in any numerical format.
+! Often more convenient than FMINP, which converts
+! an array of CHARACTER*1 values. Example:
+! CALL FMST2M('123.4',MA)
+
+! FMSUB(MA,MB,MC) MC = MA - MB
+
+! FMSUB_R1(MA,MB) MA = MA - MB
+
+! FMSUB_R2(MA,MB) MB = MA - MB
+
+! FMTAN(MA,MB) MB = TAN(MA)
+
+! FMTANH(MA,MB) MB = TANH(MA)
+
+! FMULP(MA,MB) MB = One Unit in the Last Place of MA.
+
+! FMVARS Write the current values of the internal FM
+! variables on unit KW.
+
+! FMWRIT(KWRITE,MA) Write MA on unit KWRITE.
+! Multi-line numbers will have '&' as the last
+! nonblank character on all but the last line. These
+! numbers can then be read easily using FMREAD.
+
+
+
+! These are the Gamma and Related Functions.
+
+! FMBERN(N,MA,MB) MB = MA*B(N) Multiply by Nth Bernoulli number
+
+! FMBETA(MA,MB,MC) MC = Beta(MA,MB)
+
+! FMCOMB(MA,MB,MC) MC = Combination MA choose MB (Binomial coeff.)
+
+! FMEULR(MA) MA = Euler's constant ( 0.5772156649... )
+
+! FMFACT(MA,MB) MB = MA Factorial (Gamma(MA+1))
+
+! FMGAM(MA,MB) MB = Gamma(MA)
+
+! FMIBTA(MX,MA,MB,MC) MC = Incomplete Beta(MX,MA,MB)
+
+! FMIGM1(MA,MB,MC) MC = Incomplete Gamma(MA,MB). Lower case Gamma(a,x)
+
+! FMIGM2(MA,MB,MC) MC = Incomplete Gamma(MA,MB). Upper case Gamma(a,x)
+
+! FMLNGM(MA,MB) MB = Ln(Gamma(MA))
+
+! FMPGAM(N,MA,MB) MB = Polygamma(N,MA) (Nth derivative of Psi)
+
+! FMPOCH(MA,N,MB) MB = MA*(MA+1)*(MA+2)*...*(MA+N-1) (Pochhammer)
+
+! FMPSI(MA,MB) MB = Psi(MA) (Derivative of Ln(Gamma(MA))
+
+
+
+! These are the integer routines that are designed to be called by the user.
+! All are subroutines except logical function IMCOMP. MA, MB, MC refer to IM
+! format numbers. In each case the version of the routine to handle packed IM
+! numbers has the same name, with 'IM' replaced by 'IP'.
+
+! IMABS(MA,MB) MB = ABS(MA)
+
+! IMADD(MA,MB,MC) MC = MA + MB
+
+! IMBIG(MA) MA = Biggest IM number less than overflow.
+
+! IMCOMP(MA,LREL,MB) Logical comparison of MA and MB.
+! LREL is a CHARACTER*2 value identifying which of
+! the six comparisons is to be made.
+! Example: IF (IMCOMP(MA,'GE',MB)) ...
+! Also can be: IF (IMCOMP(MA,'>=',MB))
+! CHARACTER*1 is ok: IF (IMCOMP(MA,'>',MB)) ...
+
+! IMDIM(MA,MB,MC) MC = DIM(MA,MB)
+
+! IMDIV(MA,MB,MC) MC = int(MA/MB)
+! Use IMDIVR if the remainder is also needed.
+
+! IMDIVI(MA,IVAL,MB) MB = int(MA/IVAL)
+! IVAL is a one word integer.
+! Use IMDVIR to get the remainder also.
+
+! IMDIVR(MA,MB,MC,MD) MC = int(MA/MB), MD = MA mod MB
+! When both the quotient and remainder are needed,
+! this routine is twice as fast as calling both
+! IMDIV and IMMOD.
+
+! IMDVIR(MA,IVAL,MB,IREM) MB = int(MA/IVAL), IREM = MA mod IVAL
+! IVAL and IREM are one word integers.
+
+! IMEQ(MA,MB) MB = MA
+
+! IMFM2I(MAFM,MB) MB = MAFM Convert from real (FM) format to
+! integer (IM) format.
+
+! IMFORM(FORM,MA,STRING) MA is converted to a character string using format
+! FORM and returned in STRING. FORM can represent
+! I, F, E, or 1PE formats. Example:
+! CALL IMFORM('I70',MA,STRING)
+
+! IMFPRT(FORM,MA) Print MA on unit KW using FORM format.
+
+! IMGCD(MA,MB,MC) MC = greatest common divisor of MA and MB.
+
+! IMI2FM(MA,MBFM) MBFM = MA Convert from integer (IM) format to
+! real (FM) format.
+
+! IMI2M(IVAL,MA) MA = IVAL Convert from one word integer to IM.
+
+! IMINP(LINE,MA,LA,LB) MA = LINE Input conversion.
+! Convert LINE(LA) through LINE(LB)
+! from characters to IM.
+
+! IMM2DP(MA,X) X = MA Convert from IM to double precision.
+
+! IMM2I(MA,IVAL) IVAL = MA Convert from IM to one word integer.
+
+! IMMAX(MA,MB,MC) MC = MAX(MA,MB)
+
+! IMMIN(MA,MB,MC) MC = MIN(MA,MB)
+
+! IMMOD(MA,MB,MC) MC = MA mod MB
+
+! IMMPY(MA,MB,MC) MC = MA*MB
+
+! IMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer.
+
+! IMMPYM(MA,MB,MC,MD) MD = MA*MB mod MC
+! Slightly faster than calling IMMPY and IMMOD
+! separately, and it works for cases where IMMPY
+! would return OVERFLOW.
+
+! IMOUT(MA,LINE,LB) LINE = MA Convert from IM to character.
+! LINE is a character array of length LB.
+
+! IMPMOD(MA,MB,MC,MD) MD = MA**MB mod MC
+
+! IMPRNT(MA) Print MA on unit KW.
+
+! IMPWR(MA,MB,MC) MC = MA**MB
+
+! IMREAD(KREAD,MA) MA is returned after reading one (possibly multi-line)
+! IM number on unit KREAD.
+! This routine reads numbers written by IMWRIT.
+
+! IMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer.
+
+! IMSQR(MA,MB) MB = MA*MA Faster than IMMPY.
+
+! IMST2M(STRING,MA) MA = STRING
+! Convert from character string to IM.
+! Often more convenient than IMINP, which converts an
+! array of CHARACTER*1 values. Example:
+! CALL IMST2M('12345678901',MA)
+
+! IMSUB(MA,MB,MC) MC = MA - MB
+
+! IMWRIT(KWRITE,MA) Write MA on unit KWRITE.
+! Multi-line numbers will have '&' as the last
+! nonblank character on all but the last line.
+! These numbers can then be read easily using IMREAD.
+
+
+
+! These are the complex routines that are designed to be called by the user.
+! All are subroutines, and in each case the version of the routine to handle
+! packed ZM numbers has the same name, with 'ZM' replaced by 'ZP'.
+
+! MA, MB, MC refer to ZM format complex numbers.
+! MAFM, MBFM, MCFM refer to FM format real numbers.
+! INTEG is a Fortran INTEGER variable.
+! ZVAL is a Fortran COMPLEX variable.
+
+! ZMABS(MA,MBFM) MBFM = ABS(MA) Result is real.
+
+! ZMACOS(MA,MB) MB = ACOS(MA)
+
+! ZMADD(MA,MB,MC) MC = MA + MB
+
+! ZMADDI(MA,INTEG) MA = MA + INTEG Increment an ZM number by a one word
+! integer. Note this call does not have
+! an "MB" result like ZMDIVI and ZMMPYI.
+
+! ZMARG(MA,MBFM) MBFM = Argument(MA) Result is real.
+
+! ZMASIN(MA,MB) MB = ASIN(MA)
+
+! ZMATAN(MA,MB) MB = ATAN(MA)
+
+! ZMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA).
+! Faster than 2 calls.
+
+! ZMCMPX(MAFM,MBFM,MC) MC = CMPLX(MAFM,MBFM)
+
+! ZMCONJ(MA,MB) MB = CONJG(MA)
+
+! ZMCOS(MA,MB) MB = COS(MA)
+
+! ZMCOSH(MA,MB) MB = COSH(MA)
+
+! ZMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA).
+! Faster than 2 calls.
+
+! ZMDIV(MA,MB,MC) MC = MA / MB
+
+! ZMDIVI(MA,INTEG,MB) MB = MA / INTEG
+
+! ZMEQ(MA,MB) MB = MA
+
+! ZMEQU(MA,MB,NDA,NDB) MB = MA Version for changing precision.
+! (NDA and NDB are as in FMEQU)
+
+! ZMEXP(MA,MB) MB = EXP(MA)
+
+! ZMFORM(FORM1,FORM2,MA,STRING) STRING = MA
+! MA is converted to a character string using format
+! FORM1 for the real part and FORM2 for the imaginary
+! part. The result is returned in STRING. FORM1 and
+! FORM2 can represent I, F, E, or 1PE formats. Example:
+! CALL ZMFORM('F20.10','F15.10',MA,STRING)
+! A 1PE in the first format does not carry over to the
+! other format descriptor, as it would in an ordinary
+! FORMAT statement.
+
+! ZMFPRT(FORM1,FORM2,MA) Print MA on unit KW using formats FORM1 and FORM2.
+
+! ZMI2M(INTEG,MA) MA = CMPLX(INTEG,0)
+
+! ZM2I2M(INTEG1,INTEG2,MA) MA = CMPLX(INTEG1,INTEG2)
+
+! ZMIMAG(MA,MBFM) MBFM = IMAG(MA) Imaginary part.
+
+! ZMINP(LINE,MA,LA,LB) MA = LINE Input conversion.
+! Convert LINE(LA) through LINE(LB) from
+! characters to ZM. LINE is a character array
+! of length at least LB.
+
+! ZMINT(MA,MB) MB = INT(MA) Integer part of both Real
+! and Imaginary parts of MA.
+
+! ZMIPWR(MA,INTEG,MB) MB = MA ** INTEG Integer power function.
+
+! ZMLG10(MA,MB) MB = LOG10(MA)
+
+! ZMLN(MA,MB) MB = LOG(MA)
+
+! ZMM2I(MA,INTEG) INTEG = INT(REAL(MA))
+
+! ZMM2Z(MA,ZVAL) ZVAL = MA
+
+! ZMMPY(MA,MB,MC) MC = MA * MB
+
+! ZMMPYI(MA,INTEG,MB) MB = MA * INTEG
+
+! ZMNINT(MA,MB) MB = NINT(MA) Nearest integer of both Real
+! and Imaginary.
+
+! ZMOUT(MA,LINE,LB,LAST1,LAST2) LINE = MA
+! Convert from FM to character.
+! LINE is the returned character*1 array.
+! LB is the dimensioned size of LINE.
+! LAST1 is returned as the position in LINE of
+! the last character of REAL(MA).
+! LAST2 is returned as the position in LINE
+! of the last character of AIMAG(MA).
+
+! ZMPRNT(MA) Print MA on unit KW using current format.
+
+! ZMPWR(MA,MB,MC) MC = MA ** MB
+
+! ZMREAD(KREAD,MA) MA is returned after reading one (possibly multi-line)
+! ZM number on unit KREAD.
+! This routine reads numbers written by ZMWRIT.
+
+! ZMREAL(MA,MBFM) MBFM = REAL(MA) Real part.
+
+! ZMRPWR(MA,IVAL,JVAL,MB) MB = MA ** (IVAL/JVAL)
+
+! ZMSET(NPREC) Set precision to the equivalent of a few more than NPREC
+! base 10 digits. This is now the same as FMSET, but is
+! retained for compatibility with earlier versions of the
+! package.
+
+! ZMSIN(MA,MB) MB = SIN(MA)
+
+! ZMSINH(MA,MB) MB = SINH(MA)
+
+! ZMSQR(MA,MB) MB = MA*MA Faster than ZMMPY.
+
+! ZMSQRT(MA,MB) MB = SQRT(MA)
+
+! ZMST2M(STRING,MA) MA = STRING
+! Convert from character string to ZM.
+! Often more convenient than ZMINP, which
+! converts an array of CHARACTER*1 values.
+! Example: CALL ZMST2M('123.4+5.67i',MA).
+
+! ZMSUB(MA,MB,MC) MC = MA - MB
+
+! ZMTAN(MA,MB) MB = TAN(MA)
+
+! ZMTANH(MA,MB) MB = TANH(MA)
+
+! ZMWRIT(KWRITE,MA) Write MA on unit KWRITE. Multi-line numbers are
+! formatted for automatic reading with ZMREAD.
+
+! ZMZ2M(ZVAL,MA) MA = ZVAL
+
+
+! 10. NEW FOR VERSION 1.2
+
+! Version 1.2 is written in Fortran-90 free source format.
+
+! The routines for the Gamma function and related mathematical special
+! functions are new in version 1.2.
+
+! Several new derived-type function interfaces are included in module FMZM in
+! file FMZM90.f90, such as integer multiple precision operations GCD, modular
+! multiplication, and modular powers. There are also formatting functions and
+! function interfaces for the Gamma and related special functions.
+
+! Two new rounding modes have been added, round toward -infinity and round
+! toward +infinity. See the description of KROUND above.
+! An option has been added to force more guard digits to be used, so that basic
+! arithmetic operations will always round perfectly. See the description of
+! KRPERF above.
+! These options are included for applications that use FM to check IEEE
+! hardware arithmetic. They are not normally useful for most multiple
+! precision calculations.
+
+! The random number routine FM_RANDOM_NUMBER uses 49-digit prime numbers in a
+! shuffled multiplicative congruential generator. Historically, some popular
+! random number routines tried so hard for maximum speed that they were later
+! found to fail some tests for randomness. FM_RANDOM_NUMBER tries to return
+! high-quality random values. It is much slower than other generators, but can
+! return about 60,000 numbers per second on a 400 MHz single-processor machine.
+! This is usually fast enough to be used as a check for suspicious monte carlo
+! results from other generators.
+! For more details, see the comments in the routine.
+
+! The arrays for multiple precision numbers were dimensioned starting at 0 in
+! version 1.1, and now begin at -1. Array(-1) now holds the sign of the number
+! instead of combining the sign with Array(2) as before. The reason for moving
+! the sign bit is that many of the original routines, written before Fortran-90
+! existed, simplified the logic by temporarily making input arguments positive,
+! working with positive values, then restoring the signs to the input arguments
+! upon return. This became illegal under Fortran-90 when used with the derived
+! type interface, which demands the inputs to functions for arithmetic operator
+! overloading be declared with INTENT(IN).
+
+! The common blocks of earlier versions have been replaced by module FMVALS.
+! This makes it easier to hide the FM internal variable names from the calling
+! program, and these variables can be initialized in the module so the
+! initializing call to FMSET is no longer mandatory. Several new routines are
+! provided to set or return the values for some of these variables. See the
+! descriptions for FMSETVAR, FMFLAG, and FMVARS above.
+
+! Version 1.0 used integer arrays and integer arithmetic internally to perform
+! the multiple precision operations. Later versions use double precision
+! arithmetic and arrays internally. This is usually faster at higher
+! precisions, and on many machines it is also faster at lower precisions.
+! Version 1.2 is written so that the arithmetic used can easily be changed from
+! double precision to integer, or any other available arithmetic type. This
+! permits the user to make the best use of a given machine's arithmetic
+! hardware. See the EFFICIENCY discussion below.
+
+
+! 11. EFFICIENCY
+
+! When the derived type interface is used to access the FM routines, there may
+! be a loss of speed if the arrays used to define the multiple precision data
+! types are larger than necessary. See comment (b) in the section above on
+! array dimensions.
+
+! To take advantage of hardware architecture on different machines, the package
+! has been designed so that the arithmetic used to perform the multiple
+! precision operations can easily be changed. All variables that must be
+! changed to get a different arithmetic have names beginning with 'M' and are
+! declared using REAL (KIND(1.0D0)) ...
+
+! For example, to change the package to use integer arithmetic internally, make
+! these two changes everywhere in the FM.f90 file.
+! Change 'REAL (KIND(1.0D0))' to 'INTEGER'.
+! Change 'AINT (' to 'INT('. Note the blank between AINT and (.
+! On some systems, changing 'AINT (' to '(' may give better speed.
+
+! In most places in FM, an AINT function is not supposed to be changed. These
+! are written 'AINT(', with no embedded blank, so they will not be changed by
+! the global change above.
+
+! The first of these changes must also be made throughout the files FMZM90.f90
+! and FMSAVE.f90.
+! Change 'REAL (KIND(1.0D0))' to 'INTEGER'.
+
+! Many of the variables in FMSAVE.f90 are initialized when they are declared,
+! so the initialization values should be changed to integer values.
+! Find the lines beginning '! Integer initialization' in file FMSAVE.f90 and
+! change the values. The values needed for 32-bit integer arithmetic are next
+! to the double precision values, but commented out. In every case, the line
+! before the '! Integer initialization' should have '!' inserted in column 1
+! and the line after should have the '!' removed from column 1. If a different
+! wordsize is used, the first call to FMSET will check the values defined in
+! file FMSAVE.f90 and write messages (on unit KW) if any need to be changed.
+
+! When changing to a different type of arithmetic, any FM arrays in the user's
+! program must be changed to agree. If derived types are used instead of
+! direct calls, no changes should be needed in the calling program.
+
+! For example, in the test program TestFM.f90, change all
+! 'REAL (KIND(1.0D0))' to 'INTEGER', as with the other files.
+
+! This version of FM restricts the base used to be also representable in
+! integer variables, so using precision above double usually does not save much
+! time unless integers can also be declared at a higher precision. Using IEEE
+! Extended would allow a base of around 10**9 to be chosen, but the delayed
+! digit-normalization method used for multiplication and division means that a
+! slightly smaller base like 10**8 would probably run faster. This would
+! usually not be much faster than using the usual base 10**7 with double
+! precision.
+
+! The value of NBITS defined as a parameter in FMVALS refers to the number of
+! bits used to represent integers in an M-variable word. Typical values for
+! NBITS are: 24 for IEEE single precision, 32 for integer, 53 for IEEE double
+! precision. NBITS controls only array size, so setting it too high is ok, but
+! then the program will use slightly more memory than necessary.
+
+! For cases where special compiler directives or minor re-writing of the code
+! may improve speed, several of the most important loops in FM are identified
+! by comments containing the string '(Inner Loop)'.
+
+! ------------------------------------------------------------------------------
+! ------------------------------------------------------------------------------
+
+
+ SUBROUTINE FMSET(NPREC)
+
+! Initialize the global FM variables that must be set before calling
+! other FM routines. These variables are initialized to fairly standard
+! values in the FMSAVE.f90 file (MODULE FMVALS), so calling FMSET at the
+! beginning of a program is now optional. FMSET is a convenient way to set
+! or change the precision being used, and it also checks to see that the
+! generic values chosen for several machine-dependent variables are valid.
+
+! Base and precision will be set to give at least NPREC+3 decimal
+! digits of precision (giving the user three base ten guard digits).
+
+! MBASE (base for FM arithmetic) is set to a large power of ten.
+! JFORM1 and JFORM2 (default output format controls) are set to 1PE format
+! displaying NPREC significant digits.
+
+! Several FM options were set here in previous versions of the package,
+! and are now initialized to their default values in module FMVALS.
+! Here are the initial settings:
+
+! The trace option is set off.
+! The mode for angles in trig functions is set to radians.
+! The rounding mode is set to symmetric rounding.
+! Warning error message level is set to 1.
+! Cancellation error monitor is set off.
+! Screen width for output is set to 80 columns.
+! The exponent character for FM output is set to 'M'.
+! Debug error checking is set off.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER NPREC
+
+ REAL (KIND(1.0D0)) :: MAXINT_CHK,MXEXP2_CHK,MEXPOV_CHK,MEXPUN_CHK, &
+ MUNKNO_CHK
+ DOUBLE PRECISION DPEPS_CHK,DPMAX_CHK,SPMAX_CHK,TEMP
+ INTEGER INTMAX_CHK,K,NPSAVE
+
+ IF (NBITS < DIGITS(MAXINT)) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' NBITS was set to ',NBITS,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For this machine it should be at least ',DIGITS(MAXINT)
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' NBITS is a parameter that controls array size, so its'
+ WRITE (KW,*) ' value cannot be changed for this run, and this might'
+ WRITE (KW,*) ' cause some FM operations to get incorrect results.'
+ WRITE (KW,*) ' '
+ ENDIF
+
+! MAXINT should be set to a very large integer, possibly
+! the largest representable integer for the current
+! machine. For most 32-bit machines, MAXINT is set
+! to 2**53 - 1 = 9.007D+15 when double precision
+! arithmetic is used for M-variables. Using integer
+! M-variables usually gives MAXINT = 2**31 - 1 =
+! 2147483647.
+
+! Setting MAXINT to a smaller number is ok, but this
+! unnecessarily restricts the permissible range of
+! MBASE and MXEXP.
+
+ MAXINT_CHK = RADIX(MAXINT_CHK)
+ MAXINT_CHK = ((MAXINT_CHK**(DIGITS(MAXINT_CHK)-1)-1)*MAXINT_CHK - 1) + &
+ MAXINT_CHK
+ IF (MAXINT > MAXINT_CHK) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' MAXINT was set to ',MAXINT,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For this machine it should be no more than ',MAXINT_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, MAXINT has been changed to ',MAXINT_CHK
+ WRITE (KW,*) ' '
+ MAXINT = MAXINT_CHK
+ ELSE IF (MAXINT < MAXINT_CHK/2) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' MAXINT was set to ',MAXINT,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For better performance set it to ',MAXINT_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, MAXINT has been changed to ',MAXINT_CHK
+ WRITE (KW,*) ' '
+ MAXINT = MAXINT_CHK
+ ENDIF
+
+! INTMAX is a large value close to the overflow threshold
+! for integer variables. It is usually 2**31 - 1
+! for machines with 32-bit integer arithmetic.
+
+! The following code sets INTMAX_CHK to the
+! largest representable integer.
+! Then INTMAX is checked against this value.
+
+ INTMAX_CHK = HUGE(1)
+ IF (INTMAX > INTMAX_CHK) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' INTMAX was set to ',INTMAX,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For this machine it should be no more than ',INTMAX_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, INTMAX has been changed to ',INTMAX_CHK
+ WRITE (KW,*) ' '
+ INTMAX = INTMAX_CHK
+ ELSE IF (INTMAX < INTMAX_CHK/2) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' INTMAX was set to ',INTMAX,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For better performance set it to ',INTMAX_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, INTMAX has been changed to ',INTMAX_CHK
+ WRITE (KW,*) ' '
+ INTMAX = INTMAX_CHK
+ ENDIF
+
+! DPMAX should be set to a value near the machine's double
+! precision overflow threshold, so that DPMAX and
+! 1.0D0/DPMAX are both representable in double
+! precision.
+
+ DPMAX_CHK = HUGE(1.0D0)/5
+ IF (DPMAX > DPMAX_CHK) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' DPMAX was set to ',DPMAX,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For this machine it should be no more than ',DPMAX_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, DPMAX has been changed to ',DPMAX_CHK
+ WRITE (KW,*) ' '
+ DPMAX = DPMAX_CHK
+ ELSE IF (DPMAX < DPMAX_CHK/1.0D2) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' DPMAX was set to ',DPMAX,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For better performance set it to ',DPMAX_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, DPMAX has been changed to ',DPMAX_CHK
+ WRITE (KW,*) ' '
+ DPMAX = DPMAX_CHK
+ ENDIF
+
+! SPMAX should be set to a value near the machine's single
+! precision overflow threshold, so that 1.01*SPMAX
+! and 1.0/SPMAX are both representable in single
+! precision.
+
+ SPMAX_CHK = HUGE(1.0)/5
+ IF (SPMAX > SPMAX_CHK) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' SPMAX was set to ',SPMAX,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For this machine it should be no more than ',SPMAX_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, SPMAX has been changed to ',SPMAX_CHK
+ WRITE (KW,*) ' '
+ SPMAX = SPMAX_CHK
+ ELSE IF (SPMAX < SPMAX_CHK/1.0D2) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' SPMAX was set to ',SPMAX,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For better performance set it to ',SPMAX_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, SPMAX has been changed to ',SPMAX_CHK
+ WRITE (KW,*) ' '
+ SPMAX = SPMAX_CHK
+ ENDIF
+
+! MXBASE is the maximum value for MBASE.
+
+ TEMP = MAXINT
+ TEMP = INT(MIN(DBLE(INTMAX),SQRT(TEMP)))
+ IF (MXBASE > TEMP) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' MXBASE was set to ',MXBASE,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For this machine it should be no more than ',TEMP
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, MXBASE has been changed to ',TEMP
+ WRITE (KW,*) ' '
+ MXBASE = TEMP
+ ELSE IF (MXBASE < TEMP/2) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' MXBASE was set to ',MXBASE,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For better performance set it to ',TEMP
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, MXBASE has been changed to ',TEMP
+ WRITE (KW,*) ' '
+ MXBASE = TEMP
+ ENDIF
+
+! MBASE is the currently used base for arithmetic.
+
+ K = INT(LOG10(DBLE(MXBASE)/4))
+ MBASE = 10**K
+
+! NDIG is the number of digits currently being carried.
+
+ NPSAVE = NPREC
+ NDIG = 2 + (NPREC+2)/K
+ IF (NDIG < 2 .OR. NDIG > NDIGMX) THEN
+ NDIG = MAX(2,NDIG)
+ NDIG = MIN(NDIGMX,NDIG)
+ WRITE (KW, &
+ "(//' Precision out of range when calling FMSET.'," // &
+ "' NPREC =',I20/' The nearest valid NDIG will be'," // &
+ "' used instead: NDIG =',I6//)" &
+ ) NPREC,NDIG
+ NPSAVE = 0
+ ENDIF
+
+! NCALL is the call stack pointer.
+
+ NCALL = 0
+
+! MXEXP is the current maximum exponent.
+! MXEXP2 is the internal maximum exponent. This is used to
+! define the overflow and underflow thresholds.
+
+! These values are chosen so that FM routines can raise the
+! overflow/underflow limit temporarily while computing
+! intermediate results, and so that EXP(INTMAX) is greater
+! than MXBASE**(MXEXP2+1).
+
+! The overflow threshold is MBASE**(MXEXP+1), and the
+! underflow threshold is MBASE**(-MXEXP-1).
+! This means the valid exponents in the first word of an FM
+! number can range from -MXEXP to MXEXP+1 (inclusive).
+
+ MXEXP = INT((DBLE(INTMAX))/(2.0D0*LOG(DBLE(MXBASE))) - 1.0D0)
+ MXEXP2_CHK = INT(2*MXEXP + MXEXP/100)
+ IF (MXEXP2 > MXEXP2_CHK*1.01) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' MXEXP2 was set to ',MXEXP2,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For this machine it should be no more than ',MXEXP2_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, MXEXP2 has been changed to ',MXEXP2_CHK
+ WRITE (KW,*) ' '
+ MXEXP2 = MXEXP2_CHK
+ ELSE IF (MXEXP2 < MXEXP2_CHK*0.99) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' MXEXP2 was set to ',MXEXP2,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For this machine it should be no less than ',MXEXP2_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, MXEXP2 has been changed to ',MXEXP2_CHK
+ WRITE (KW,*) ' '
+ MXEXP2 = MXEXP2_CHK
+ ENDIF
+
+! KACCSW is a switch used to enable cancellation error
+! monitoring. Routines where cancellation is
+! not a problem run faster by skipping the
+! cancellation monitor calculations.
+! KACCSW = 0 means no error monitoring,
+! = 1 means error monitoring is done.
+
+ KACCSW = 0
+
+! MEXPUN is the exponent used as a special symbol for
+! underflowed results.
+
+ MEXPUN_CHK = -AINT(MXEXP2*1.01D0)
+ IF (MEXPUN < MEXPUN_CHK*1.01) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' MEXPUN was set to ',MEXPUN,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For this machine it should be no less than ',MEXPUN_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, MEXPUN has been changed to ',MEXPUN_CHK
+ WRITE (KW,*) ' '
+ MEXPUN = MEXPUN_CHK
+ ELSE IF (MEXPUN > MEXPUN_CHK) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' MEXPUN was set to ',MEXPUN,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For this machine it should be no more than ',MEXPUN_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, MEXPUN has been changed to ',MEXPUN_CHK
+ WRITE (KW,*) ' '
+ MEXPUN = MEXPUN_CHK
+ ENDIF
+
+! MEXPOV is the exponent used as a special symbol for
+! overflowed results.
+
+ MEXPOV_CHK = -MEXPUN
+ IF (MEXPOV /= MEXPOV_CHK) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' MEXPOV was set to ',MEXPOV,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For this machine it should be ',MEXPOV_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, MEXPOV has been changed to ',MEXPOV_CHK
+ WRITE (KW,*) ' '
+ MEXPOV = MEXPOV_CHK
+ ENDIF
+
+! MUNKNO is the exponent used as a special symbol for
+! unknown FM results (1/0, SQRT(-3.0), ...).
+
+ MUNKNO_CHK = AINT(MEXPOV*1.01D0)
+ IF (MUNKNO > MUNKNO_CHK*1.01) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' MUNKNO was set to ',MUNKNO,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For this machine it should be no more than ',MUNKNO_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, MUNKNO has been changed to ',MUNKNO_CHK
+ WRITE (KW,*) ' '
+ MUNKNO = MUNKNO_CHK
+ ELSE IF (MUNKNO < MUNKNO_CHK) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' MUNKNO was set to ',MUNKNO,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For this machine it should be no less than ',MUNKNO_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, MUNKNO has been changed to ',MUNKNO_CHK
+ WRITE (KW,*) ' '
+ MUNKNO = MUNKNO_CHK
+ ENDIF
+
+! RUNKNO is returned from FM to real or double conversion
+! routines when no valid result can be expressed in
+! real or double precision. On systems that provide
+! a value for undefined results (e.g., Not A Number)
+! setting RUNKNO to that value is reasonable. On
+! other systems set it to a value that is likely to
+! make any subsequent results obviously wrong that
+! use it. In either case a KFLAG = -4 condition is
+! also returned.
+
+ RUNKNO = -1.01*SPMAX
+
+! IUNKNO is returned from FM to integer conversion routines
+! when no valid result can be expressed as a one word
+! integer. KFLAG = -4 is also set.
+
+ IUNKNO = -INT(MXEXP2)
+
+! DPEPS is the approximate machine precision.
+
+ DPEPS_CHK = EPSILON(1.0D0)
+ IF (DPEPS > DPEPS_CHK*1.01) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' DPEPS was set to ',DPEPS,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For this machine it should be no more than ',DPEPS_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, DPEPS has been changed to ',DPEPS_CHK
+ WRITE (KW,*) ' '
+ DPEPS = DPEPS_CHK
+ ELSE IF (DPEPS < DPEPS_CHK*0.99) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' In routine FMSET it appears that FM internal variable'
+ WRITE (KW,*) ' DPEPS was set to ',DPEPS,' in file FMSAVE.f90'
+ WRITE (KW,*) ' For this machine it should be no less than ',DPEPS_CHK
+ WRITE (KW,*) ' Change the initialization in FMSAVE.f90 to this value.'
+ WRITE (KW,*) ' For this run, DPEPS has been changed to ',DPEPS_CHK
+ WRITE (KW,*) ' '
+ DPEPS = DPEPS_CHK
+ ENDIF
+
+! JFORM1 indicates the format used by FMOUT.
+
+ JFORM1 = 1
+
+! JFORM2 indicates the number of digits used in FMOUT.
+
+ JFORM2 = NPSAVE
+
+! Set JFORMZ to ' 1.23 + 4.56 i ' format.
+
+ JFORMZ = 1
+
+! Set JPRNTZ to print real and imaginary parts on one
+! line whenever possible.
+
+ JPRNTZ = 1
+
+! Initialize two hash tables that are used for character
+! look-up during input conversion.
+
+ CALL FMHTBL
+
+! FMCONS sets several real and double precision constants.
+
+ CALL FMCONS
+
+
+ RETURN
+ END SUBROUTINE FMSET
+
+ SUBROUTINE FMABS(MA,MB)
+
+! MB = ABS(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MD2B
+ INTEGER KWRNSV
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMABS '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+
+ KFLAG = 0
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMEQ(MA,MB)
+ MB(-1) = 1
+ KWARN = KWRNSV
+
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MB(0),MD2B)
+ ENDIF
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMABS
+
+ SUBROUTINE FMACOS(MA,MB)
+
+! MB = ACOS(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
+ INTEGER J,K,KASAVE,KOVUN,KRESLT,NDSAVE
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB .OR. MA(1) > 0 .OR. MA(2) == 0) THEN
+ CALL FMENTR('FMACOS',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMACOS'
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ MAS = MA(-1)
+ MACCA = MA(0)
+ CALL FMEQ2(MA,MB,NDSAVE,NDIG)
+ MB(0) = NINT(NDIG*ALOGM2)
+
+! Use ACOS(X) = ATAN(SQRT(1-X*X)/X)
+
+ MB(-1) = 1
+ CALL FMI2M(1,M05)
+ CALL FMSUB(M05,MB,M03)
+ CALL FMADD(M05,MB,M04)
+ CALL FMMPY_R2(M03,M04)
+ CALL FMSQRT_R1(M04)
+ CALL FMDIV_R2(M04,MB)
+
+ CALL FMATAN(MB,M13)
+ CALL FMEQ(M13,MB)
+
+ IF (MAS < 0) THEN
+ IF (KRAD == 1) THEN
+ CALL FMPI(M05)
+ ELSE
+ CALL FMI2M(180,M05)
+ ENDIF
+ CALL FMSUB_R2(M05,MB)
+ ENDIF
+
+! Round the result and return.
+
+ MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMACOS
+
+ SUBROUTINE FMADD(MA,MB,MC)
+
+! MC = MA + MB
+
+! This routine performs the trace printing for addition.
+! FMADD2 is used to do the arithmetic.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMADD '
+ CALL FMNTR(2,MA,MB,2,1)
+
+ CALL FMADD2(MA,MB,MC)
+
+ CALL FMNTR(1,MC,MC,1,1)
+ ELSE
+ CALL FMADD2(MA,MB,MC)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMADD
+
+ SUBROUTINE FMADD2(MA,MB,MC)
+
+! Internal addition routine. MC = MA + MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MA0,MA1,MA2,MAS,MB0,MB1,MB2,MB2RD,MBS
+ INTEGER J,JCOMP,JRSSAV,JSIGN,KRESLT,N1,NGUARD,NMWA
+ REAL B2RDA,B2RDB
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JRSSAV = JRSIGN
+ MA2 = MA(2)
+ MB2 = MB(2)
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. &
+ KDEBUG == 1) THEN
+ IF (KSUB == 1) THEN
+ CALL FMARGS('FMSUB ',2,MA,MB,KRESLT)
+ ELSE
+ CALL FMARGS('FMADD ',2,MA,MB,KRESLT)
+ ENDIF
+ IF (KRESLT /= 0) THEN
+ IF ((KRESLT /= 1 .AND. KRESLT /= 2) .OR. MA(2) == 0 .OR. &
+ MB(2) == 0) THEN
+ NCALL = NCALL + 1
+ IF (KSUB == 1) THEN
+ NAMEST(NCALL) = 'FMSUB '
+ ELSE
+ NAMEST(NCALL) = 'FMADD '
+ ENDIF
+ CALL FMRSLT(MA,MB,MC,KRESLT)
+ JRSIGN = JRSSAV
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ ELSE
+ IF (MA(2) == 0) THEN
+ MA0 = MIN(MA(0),MB(0))
+ CALL FMEQ(MB,MC)
+ MC(0) = MA0
+ KFLAG = 1
+ IF (KSUB == 1) THEN
+ IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
+ KFLAG = 0
+ ENDIF
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+ IF (MB(2) == 0) THEN
+ MA0 = MIN(MA(0),MB(0))
+ CALL FMEQ(MA,MC)
+ MC(0) = MA0
+ KFLAG = 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+ ENDIF
+
+ MA0 = MA(0)
+ IF (KACCSW == 1) THEN
+ MB0 = MB(0)
+ MA1 = MA(1)
+ MB1 = MB(1)
+ ENDIF
+ KFLAG = 0
+ N1 = NDIG + 1
+
+! NGUARD is the number of guard digits used.
+
+ IF (NCALL > 1) THEN
+ NGUARD = NGRD21
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ ELSE
+ NGUARD = NGRD52
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 10
+ ENDIF
+ ENDIF
+ NMWA = N1 + NGUARD
+
+! Save the signs of MA and MB and then work with
+! positive numbers.
+! JSIGN is the sign of the result of MA + MB.
+
+ JSIGN = 1
+ MAS = MA(-1)
+ MBS = MB(-1)
+ IF (KSUB == 1) MBS = -MBS
+
+! See which one is larger in absolute value.
+
+ JCOMP = 2
+ IF (MA(1) > MB(1)) THEN
+ JCOMP = 1
+ ELSE IF (MB(1) > MA(1)) THEN
+ JCOMP = 3
+ ELSE
+ DO J = 2, N1
+ IF (MA(J) > MB(J)) THEN
+ JCOMP = 1
+ EXIT
+ ENDIF
+ IF (MB(J) > MA(J)) THEN
+ JCOMP = 3
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (JCOMP < 3) THEN
+ IF (MAS < 0) JSIGN = -1
+ JRSIGN = JSIGN
+ IF (MAS*MBS > 0) THEN
+ CALL FMADDP(MA,MB,NGUARD,NMWA)
+ ELSE
+ CALL FMADDN(MA,MB,NGUARD,NMWA)
+ ENDIF
+ ELSE
+ IF (MBS < 0) JSIGN = -1
+ JRSIGN = JSIGN
+ IF (MAS*MBS > 0) THEN
+ CALL FMADDP(MB,MA,NGUARD,NMWA)
+ ELSE
+ CALL FMADDN(MB,MA,NGUARD,NMWA)
+ ENDIF
+ ENDIF
+
+! Transfer to MC and fix the sign of the result.
+
+ CALL FMMOVE(MWA,MC)
+ MC(-1) = 1
+ IF (JSIGN < 0 .AND. MC(2) /= 0) MC(-1) = -1
+
+ IF (KFLAG < 0) THEN
+ IF (KSUB == 1) THEN
+ NAMEST(NCALL) = 'FMSUB '
+ ELSE
+ NAMEST(NCALL) = 'FMADD '
+ ENDIF
+ CALL FMWARN
+ ENDIF
+
+ IF (KACCSW == 1) THEN
+ B2RDA = LOG(REAL(ABS(MC(2))+1)/REAL(ABS(MA2)+1))/0.69315 + &
+ REAL(MC(1)-MA1)*ALOGM2 + REAL(MA0)
+ B2RDB = LOG(REAL(ABS(MC(2))+1)/REAL(ABS(MB2)+1))/0.69315 + &
+ REAL(MC(1)-MB1)*ALOGM2 + REAL(MB0)
+ MB2RD = NINT(MAX(0.0,MIN(B2RDA,B2RDB, &
+ (NDIG-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)))
+ IF (MC(2) == 0) THEN
+ MC(0) = 0
+ ELSE
+ MC(0) = MIN(MAX(MA0,MB0),MB2RD)
+ ENDIF
+ ELSE
+ MC(0) = MA0
+ ENDIF
+
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMADD2
+
+ SUBROUTINE FMADD_R1(MA,MB)
+
+! MA = MA + MB
+
+! This routine performs the trace printing for addition.
+! FMADD2_R1 is used to do the arithmetic.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMADD '
+ CALL FMNTR(2,MA,MB,2,1)
+
+ CALL FMADD2_R1(MA,MB)
+
+ CALL FMNTR(1,MA,MA,1,1)
+ ELSE
+ CALL FMADD2_R1(MA,MB)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMADD_R1
+
+ SUBROUTINE FMADD2_R1(MA,MB)
+
+! Internal addition routine. MA = MA + MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MA0,MA1,MA2,MAS,MB0,MB1,MB2,MB2RD,MBS
+ INTEGER J,JCOMP,JRSSAV,JSIGN,KRESLT,N1,NGUARD,NMWA
+ REAL B2RDA,B2RDB
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JRSSAV = JRSIGN
+ MA2 = MA(2)
+ MB2 = MB(2)
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. &
+ KDEBUG == 1) THEN
+ IF (KSUB == 1) THEN
+ CALL FMARGS('FMSUB ',2,MA,MB,KRESLT)
+ ELSE
+ CALL FMARGS('FMADD ',2,MA,MB,KRESLT)
+ ENDIF
+ IF (KRESLT /= 0) THEN
+ IF ((KRESLT /= 1 .AND. KRESLT /= 2) .OR. MA(2) == 0 .OR. &
+ MB(2) == 0) THEN
+ NCALL = NCALL + 1
+ IF (KSUB == 1) THEN
+ NAMEST(NCALL) = 'FMSUB '
+ ELSE
+ NAMEST(NCALL) = 'FMADD '
+ ENDIF
+ CALL FMRSLT(MA,MB,M07,KRESLT)
+ CALL FMEQ(M07,MA)
+ JRSIGN = JRSSAV
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ ELSE
+ IF (MA(2) == 0) THEN
+ MA0 = MIN(MA(0),MB(0))
+ CALL FMEQ(MB,MA)
+ MA(0) = MA0
+ KFLAG = 1
+ IF (KSUB == 1) THEN
+ IF (MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -MA(-1)
+ KFLAG = 0
+ ENDIF
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+ IF (MB(2) == 0) THEN
+ MA0 = MIN(MA(0),MB(0))
+ MA(0) = MA0
+ KFLAG = 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+ ENDIF
+
+ MA0 = MA(0)
+ IF (KACCSW == 1) THEN
+ MB0 = MB(0)
+ MA1 = MA(1)
+ MB1 = MB(1)
+ ENDIF
+ KFLAG = 0
+ N1 = NDIG + 1
+
+! NGUARD is the number of guard digits used.
+
+ IF (NCALL > 1) THEN
+ NGUARD = NGRD21
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ ELSE
+ NGUARD = NGRD52
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 10
+ ENDIF
+ ENDIF
+ NMWA = N1 + NGUARD
+
+! Save the signs of MA and MB and then work with
+! positive numbers.
+! JSIGN is the sign of the result of MA + MB.
+
+ JSIGN = 1
+ MAS = MA(-1)
+ MBS = MB(-1)
+ IF (KSUB == 1) MBS = -MBS
+
+! See which one is larger in absolute value.
+
+ JCOMP = 2
+ IF (MA(1) > MB(1)) THEN
+ JCOMP = 1
+ ELSE IF (MB(1) > MA(1)) THEN
+ JCOMP = 3
+ ELSE
+ DO J = 2, N1
+ IF (MA(J) > MB(J)) THEN
+ JCOMP = 1
+ EXIT
+ ENDIF
+ IF (MB(J) > MA(J)) THEN
+ JCOMP = 3
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (JCOMP < 3) THEN
+ IF (MAS < 0) JSIGN = -1
+ JRSIGN = JSIGN
+ IF (MAS*MBS > 0) THEN
+ CALL FMADDP(MA,MB,NGUARD,NMWA)
+ ELSE
+ CALL FMADDN(MA,MB,NGUARD,NMWA)
+ ENDIF
+ ELSE
+ IF (MBS < 0) JSIGN = -1
+ JRSIGN = JSIGN
+ IF (MAS*MBS > 0) THEN
+ CALL FMADDP(MB,MA,NGUARD,NMWA)
+ ELSE
+ CALL FMADDN(MB,MA,NGUARD,NMWA)
+ ENDIF
+ ENDIF
+
+! Transfer to MA and fix the sign of the result.
+
+ CALL FMMOVE(MWA,MA)
+ MA(-1) = 1
+ IF (JSIGN < 0 .AND. MA(2) /= 0) MA(-1) = -1
+
+ IF (KFLAG < 0) THEN
+ IF (KSUB == 1) THEN
+ NAMEST(NCALL) = 'FMSUB '
+ ELSE
+ NAMEST(NCALL) = 'FMADD '
+ ENDIF
+ CALL FMWARN
+ ENDIF
+
+ IF (KACCSW == 1) THEN
+ B2RDA = LOG(REAL(ABS(MA(2))+1)/REAL(ABS(MA2)+1))/0.69315 + &
+ REAL(MA(1)-MA1)*ALOGM2 + REAL(MA0)
+ B2RDB = LOG(REAL(ABS(MA(2))+1)/REAL(ABS(MB2)+1))/0.69315 + &
+ REAL(MA(1)-MB1)*ALOGM2 + REAL(MB0)
+ MB2RD = NINT(MAX(0.0,MIN(B2RDA,B2RDB, &
+ (NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315)))
+ IF (MA(2) == 0) THEN
+ MA(0) = 0
+ ELSE
+ MA(0) = MIN(MAX(MA0,MB0),MB2RD)
+ ENDIF
+ ELSE
+ MA(0) = MA0
+ ENDIF
+
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMADD2_R1
+
+ SUBROUTINE FMADD_R2(MA,MB)
+
+! MB = MA + MB
+
+! This routine performs the trace printing for addition.
+! FMADD2_R2 is used to do the arithmetic.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMADD '
+ CALL FMNTR(2,MA,MB,2,1)
+
+ CALL FMADD2_R2(MA,MB)
+
+ CALL FMNTR(1,MB,MB,1,1)
+ ELSE
+ CALL FMADD2_R2(MA,MB)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMADD_R2
+
+ SUBROUTINE FMADD2_R2(MA,MB)
+
+! Internal addition routine. MB = MA + MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MA0,MA1,MA2,MAS,MB0,MB1,MB2,MB2RD,MBS
+ INTEGER J,JCOMP,JRSSAV,JSIGN,KRESLT,N1,NGUARD,NMWA
+ REAL B2RDA,B2RDB
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JRSSAV = JRSIGN
+ MA2 = MA(2)
+ MB2 = MB(2)
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. &
+ KDEBUG == 1) THEN
+ IF (KSUB == 1) THEN
+ CALL FMARGS('FMSUB ',2,MA,MB,KRESLT)
+ ELSE
+ CALL FMARGS('FMADD ',2,MA,MB,KRESLT)
+ ENDIF
+ IF (KRESLT /= 0) THEN
+ IF ((KRESLT /= 1 .AND. KRESLT /= 2) .OR. MA(2) == 0 .OR. &
+ MB(2) == 0) THEN
+ NCALL = NCALL + 1
+ IF (KSUB == 1) THEN
+ NAMEST(NCALL) = 'FMSUB '
+ ELSE
+ NAMEST(NCALL) = 'FMADD '
+ ENDIF
+ CALL FMRSLT(MA,MB,M07,KRESLT)
+ CALL FMEQ(M07,MB)
+ JRSIGN = JRSSAV
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ ELSE
+ IF (MA(2) == 0) THEN
+ MA0 = MIN(MA(0),MB(0))
+ MB(0) = MA0
+ KFLAG = 1
+ IF (KSUB == 1) THEN
+ IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
+ KFLAG = 0
+ ENDIF
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+ IF (MB(2) == 0) THEN
+ MA0 = MIN(MA(0),MB(0))
+ CALL FMEQ(MA,MB)
+ MB(0) = MA0
+ KFLAG = 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+ ENDIF
+
+ MA0 = MA(0)
+ IF (KACCSW == 1) THEN
+ MB0 = MB(0)
+ MA1 = MA(1)
+ MB1 = MB(1)
+ ENDIF
+ KFLAG = 0
+ N1 = NDIG + 1
+
+! NGUARD is the number of guard digits used.
+
+ IF (NCALL > 1) THEN
+ NGUARD = NGRD21
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ ELSE
+ NGUARD = NGRD52
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 10
+ ENDIF
+ ENDIF
+ NMWA = N1 + NGUARD
+
+! Save the signs of MA and MB and then work with
+! positive numbers.
+! JSIGN is the sign of the result of MA + MB.
+
+ JSIGN = 1
+ MAS = MA(-1)
+ MBS = MB(-1)
+ IF (KSUB == 1) MBS = -MBS
+
+! See which one is larger in absolute value.
+
+ JCOMP = 2
+ IF (MA(1) > MB(1)) THEN
+ JCOMP = 1
+ ELSE IF (MB(1) > MA(1)) THEN
+ JCOMP = 3
+ ELSE
+ DO J = 2, N1
+ IF (MA(J) > MB(J)) THEN
+ JCOMP = 1
+ EXIT
+ ENDIF
+ IF (MB(J) > MA(J)) THEN
+ JCOMP = 3
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (JCOMP < 3) THEN
+ IF (MAS < 0) JSIGN = -1
+ JRSIGN = JSIGN
+ IF (MAS*MBS > 0) THEN
+ CALL FMADDP(MA,MB,NGUARD,NMWA)
+ ELSE
+ CALL FMADDN(MA,MB,NGUARD,NMWA)
+ ENDIF
+ ELSE
+ IF (MBS < 0) JSIGN = -1
+ JRSIGN = JSIGN
+ IF (MAS*MBS > 0) THEN
+ CALL FMADDP(MB,MA,NGUARD,NMWA)
+ ELSE
+ CALL FMADDN(MB,MA,NGUARD,NMWA)
+ ENDIF
+ ENDIF
+
+! Transfer to MB and fix the sign of the result.
+
+ CALL FMMOVE(MWA,MB)
+ MB(-1) = 1
+ IF (JSIGN < 0 .AND. MB(2) /= 0) MB(-1) = -1
+
+ IF (KFLAG < 0) THEN
+ IF (KSUB == 1) THEN
+ NAMEST(NCALL) = 'FMSUB '
+ ELSE
+ NAMEST(NCALL) = 'FMADD '
+ ENDIF
+ CALL FMWARN
+ ENDIF
+
+ IF (KACCSW == 1) THEN
+ B2RDA = LOG(REAL(ABS(MB(2))+1)/REAL(ABS(MA2)+1))/0.69315 + &
+ REAL(MB(1)-MA1)*ALOGM2 + REAL(MA0)
+ B2RDB = LOG(REAL(ABS(MB(2))+1)/REAL(ABS(MB2)+1))/0.69315 + &
+ REAL(MB(1)-MB1)*ALOGM2 + REAL(MB0)
+ MB2RD = NINT(MAX(0.0,MIN(B2RDA,B2RDB, &
+ (NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)))
+ IF (MB(2) == 0) THEN
+ MB(0) = 0
+ ELSE
+ MB(0) = MIN(MAX(MA0,MB0),MB2RD)
+ ENDIF
+ ELSE
+ MB(0) = MA0
+ ENDIF
+
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMADD2_R2
+
+ SUBROUTINE FMADDI(MA,IVAL)
+
+! MA = MA + IVAL
+
+! Increment MA by one word integer IVAL.
+
+! This routine is faster than FMADD when IVAL is small enough so
+! that it can be added to a single word of MA without often causing
+! a carry. Otherwise FMI2M and FMADD are used.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER :: IVAL
+ REAL (KIND(1.0D0)) :: MAEXP,MD2B,MKSUM
+ INTEGER :: KPTMA
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMADDI'
+ CALL FMNTR(2,MA,MA,1,1)
+ CALL FMNTRI(2,IVAL,0)
+ ENDIF
+ KFLAG = 0
+
+ MAEXP = MA(1)
+ IF (MAEXP <= 0 .OR. MAEXP > NDIG) GO TO 110
+ KPTMA = INT(MAEXP) + 1
+ IF (MA(-1) < 0) THEN
+ MKSUM = MA(KPTMA) - IVAL
+ ELSE
+ MKSUM = MA(KPTMA) + IVAL
+ ENDIF
+
+ IF (MKSUM >= MBASE .OR. MKSUM < 0) GO TO 110
+ IF (KPTMA == 2 .AND. MKSUM == 0) GO TO 110
+ MA(KPTMA) = MKSUM
+ GO TO 120
+
+ 110 CALL FMI2M(IVAL,M01)
+ CALL FMADD2_R1(MA,M01)
+
+ 120 IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315)
+ MA(0) = MIN(MA(0),MD2B)
+ ENDIF
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MA,MA,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMADDI
+
+ SUBROUTINE FMADDN(MA,MB,NGUARD,NMWA)
+
+! Internal addition routine. MWA = MA - MB
+! The arguments are such that MA >= MB >= 0.
+
+! NGUARD is the number of guard digits being carried.
+! NMWA is the number of words in MWA that will be used.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER NGUARD,NMWA
+ REAL (KIND(1.0D0)) :: MK,MR
+ INTEGER J,K,KL,KP1,KP2,KPT,KSH,N1,N2,NK,NK1
+
+ N1 = NDIG + 1
+
+! Check for an insignificant operand.
+
+ MK = MA(1) - MB(1)
+ IF (MK >= NDIG+2) THEN
+ DO J = 1, N1
+ MWA(J) = MA(J)
+ ENDDO
+ MWA(N1+1) = 0
+ IF (KROUND == 0 .OR. (KROUND == 2 .AND. JRSIGN == -1) .OR. &
+ (KROUND == -1 .AND. JRSIGN == 1)) THEN
+ MWA(N1) = MWA(N1) - 1
+ GO TO 120
+ ENDIF
+ KFLAG = 1
+ RETURN
+ ENDIF
+ K = INT(MK)
+ IF (NGUARD <= 1) NMWA = N1 + 2
+
+! Subtract MB from MA.
+
+ KP1 = MIN(N1,K+1)
+ MWA(K+1) = 0
+ DO J = 1, KP1
+ MWA(J) = MA(J)
+ ENDDO
+ KP2 = K + 2
+
+! (Inner Loop)
+
+ DO J = KP2, N1
+ MWA(J) = MA(J) - MB(J-K)
+ ENDDO
+
+ N2 = NDIG + 2
+ IF (N2-K <= 1) N2 = 2 + K
+ NK = MIN(NMWA,N1+K)
+ DO J = N2, NK
+ MWA(J) = -MB(J-K)
+ ENDDO
+ NK1 = NK + 1
+ DO J = NK1, NMWA
+ MWA(J) = 0
+ ENDDO
+
+! Normalize. Fix the sign of any negative digit.
+
+ IF (K > 0) THEN
+ DO J = NMWA, KP2, -1
+ IF (MWA(J) < 0) THEN
+ MWA(J) = MWA(J) + MBASE
+ MWA(J-1) = MWA(J-1) - 1
+ ENDIF
+ ENDDO
+
+ KPT = KP2 - 1
+ 110 IF (MWA(KPT) < 0 .AND. KPT >= 3) THEN
+ MWA(KPT) = MWA(KPT) + MBASE
+ MWA(KPT-1) = MWA(KPT-1) - 1
+ KPT = KPT - 1
+ GO TO 110
+ ENDIF
+ GO TO 130
+ ENDIF
+
+ 120 DO J = N1, 3, -1
+ IF (MWA(J) < 0) THEN
+ MWA(J) = MWA(J) + MBASE
+ MWA(J-1) = MWA(J-1) - 1
+ ENDIF
+ ENDDO
+
+! Shift left if there are any leading zeros in the mantissa.
+
+ 130 DO J = 2, NMWA
+ IF (MWA(J) > 0) THEN
+ KSH = J - 2
+ GO TO 140
+ ENDIF
+ ENDDO
+ MWA(1) = 0
+ RETURN
+
+ 140 IF (KSH > 0) THEN
+ KL = NMWA - KSH
+ DO J = 2, KL
+ MWA(J) = MWA(J+KSH)
+ ENDDO
+ DO J = KL+1, NMWA
+ MWA(J) = 0
+ ENDDO
+ MWA(1) = MWA(1) - KSH
+ IF (MK >= NDIG+2) THEN
+ MWA(N1) = MBASE - 1
+ ENDIF
+ ENDIF
+
+! Round the result.
+
+ MR = 2*MWA(NDIG+2) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,0)
+ ELSE IF (MR >= MBASE) THEN
+ IF (MR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1) = MWA(N1) + 1
+ MWA(N1+1) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,0)
+ ENDIF
+ ENDIF
+
+! See if the result is equal to one of the input arguments.
+
+ IF (ABS(MA(1)-MB(1)) < NDIG) GO TO 150
+ IF (ABS(MA(1)-MB(1)) > NDIG+1) THEN
+ KFLAG = 1
+ GO TO 150
+ ENDIF
+
+ N2 = NDIG + 4
+ DO J = 3, N1
+ IF (MWA(N2-J) /= MA(N2-J)) GO TO 150
+ ENDDO
+ IF (MWA(1) /= MA(1)) GO TO 150
+ IF (MWA(2) /= ABS(MA(2))) GO TO 150
+ KFLAG = 1
+
+ 150 RETURN
+ END SUBROUTINE FMADDN
+
+ SUBROUTINE FMADDP(MA,MB,NGUARD,NMWA)
+
+! Internal addition routine. MWA = MA + MB
+! The arguments are such that MA >= MB >= 0.
+
+! NMWA is the number of words in MWA that will be used.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER NGUARD,NMWA
+ REAL (KIND(1.0D0)) :: MK,MKT,MR
+ INTEGER J,K,KP,KP2,KPT,KSHIFT,N1,N2,NK
+
+ N1 = NDIG + 1
+
+! Check for an insignificant operand.
+
+ MK = MA(1) - MB(1)
+ IF (MK >= NDIG+1) THEN
+ MWA(1) = MA(1) + 1
+ MWA(2) = 0
+ DO J = 2, N1
+ MWA(J+1) = MA(J)
+ ENDDO
+ MWA(N1+2) = 0
+ IF ((KROUND == 2 .AND. JRSIGN == 1) .OR. &
+ (KROUND == -1 .AND. JRSIGN == -1)) THEN
+ MWA(N1+2) = 1
+ GO TO 120
+ ENDIF
+ KFLAG = 1
+ RETURN
+ ENDIF
+ K = INT(MK)
+
+! Add MA and MB.
+
+ MWA(1) = MA(1) + 1
+ MWA(2) = 0
+ DO J = 2, K+1
+ MWA(J+1) = MA(J)
+ ENDDO
+ KP2 = K + 2
+
+! (Inner Loop)
+
+ DO J = KP2, N1
+ MWA(J+1) = MA(J) + MB(J-K)
+ ENDDO
+ N2 = NDIG + 2
+ NK = MIN(NMWA,N1+K)
+ DO J = N2, NK
+ MWA(J+1) = MB(J-K)
+ ENDDO
+ DO J = NK+1, NMWA
+ MWA(J+1) = 0
+ ENDDO
+
+! Normalize. Fix any digit not less than MBASE.
+
+ IF (K == NDIG) GO TO 140
+
+ IF (K > 0) THEN
+ DO J = N1+1, KP2, -1
+ IF (MWA(J) >= MBASE) THEN
+ MWA(J) = MWA(J) - MBASE
+ MWA(J-1) = MWA(J-1) + 1
+ ENDIF
+ ENDDO
+
+ KPT = KP2 - 1
+ 110 IF (MWA(KPT) >= MBASE .AND. KPT >= 3) THEN
+ MWA(KPT) = MWA(KPT) - MBASE
+ MWA(KPT-1) = MWA(KPT-1) + 1
+ KPT = KPT - 1
+ GO TO 110
+ ENDIF
+ GO TO 120
+ ENDIF
+
+ DO J = N1+1, 3, -1
+ IF (MWA(J) >= MBASE) THEN
+ MWA(J) = MWA(J) - MBASE
+ MWA(J-1) = MWA(J-1) + 1
+ ENDIF
+ ENDDO
+
+! Shift right if the leading digit is not less than MBASE.
+
+ 120 IF (MWA(2) >= MBASE) THEN
+ 130 KP = NMWA + 4
+ DO J = 4, NMWA
+ MWA(KP-J) = MWA(KP-J-1)
+ ENDDO
+ MKT = AINT (MWA(2)/MBASE)
+ MWA(3) = MWA(2) - MKT*MBASE
+ MWA(2) = MKT
+ MWA(1) = MWA(1) + 1
+ IF (MWA(2) >= MBASE) GO TO 130
+ ENDIF
+
+! Round the result.
+
+ 140 KSHIFT = 0
+ IF (MWA(2) == 0) KSHIFT = 1
+ MR = 2*MWA(NDIG+2+KSHIFT) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ELSE IF (MR >= MBASE) THEN
+ IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
+ MWA(N1+1+KSHIFT) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ENDIF
+ ENDIF
+
+! See if the result is equal to one of the input arguments.
+
+ IF (ABS(MA(1)-MB(1)) < NDIG) GO TO 150
+ IF (KSHIFT == 0) GO TO 150
+ IF (ABS(MA(1)-MB(1)) > NDIG+1) THEN
+ KFLAG = 1
+ GO TO 150
+ ENDIF
+
+ N2 = NDIG + 4
+ DO J = 3, N1
+ IF (MWA(N2-J+1) /= MA(N2-J)) GO TO 150
+ ENDDO
+ IF (MWA(1) /= MA(1)+1) GO TO 150
+ IF (MWA(3) /= ABS(MA(2))) GO TO 150
+ KFLAG = 1
+
+ 150 RETURN
+ END SUBROUTINE FMADDP
+
+ SUBROUTINE FMARGS(KROUTN,NARGS,MA,MB,KRESLT)
+
+! Check the input arguments to a routine for special cases.
+
+! KROUTN - Name of the subroutine that was called
+! NARGS - The number of input arguments (1 or 2)
+! MA - First input argument
+! MB - Second input argument (if NARGS is 2)
+! KRESLT - Result code returned to the calling routine.
+
+! Result codes:
+
+! 0 - Perform the normal operation
+! 1 - The result is the first input argument
+! 2 - The result is the second input argument
+! 3 - The result is -OVERFLOW
+! 4 - The result is +OVERFLOW
+! 5 - The result is -UNDERFLOW
+! 6 - The result is +UNDERFLOW
+! 7 - The result is -1.0
+! 8 - The result is +1.0
+! 9 - The result is -pi/2
+! 10 - The result is +pi/2
+! 11 - The result is 0.0
+! 12 - The result is UNKNOWN
+! 13 - The result is +pi
+! 14 - The result is -pi/4
+! 15 - The result is +pi/4
+
+ USE FMVALS
+ IMPLICIT NONE
+ CHARACTER(6) :: KROUTN
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER NARGS,KRESLT
+
+ REAL (KIND(1.0D0)) :: MBS
+ INTEGER J,KWRNSV,NCATMA,NCATMB,NDS
+
+! These tables define the result codes to be returned for
+! given values of the input argument(s).
+
+! For example, row 7 column 2 of this array initialization
+! KADD(2,7) = 2 means that if the first argument in a call
+! to FMADD is in category 7 ( -UNDERFLOW ) and the second
+! argument is in category 2 ( near -OVERFLOW but
+! representable ) then the result code is 2 ( the value
+! of the sum is equal to the second input argument).
+! See routine FMCAT for descriptions of the categories.
+
+ INTEGER :: KADD(15,15) = RESHAPE( (/ &
+ 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,12,12, &
+ 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0,12, &
+ 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, &
+ 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, &
+ 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, &
+ 3, 0, 0, 0, 0, 0,12, 1,12, 0, 0, 0, 0, 0, 4, &
+ 3, 2, 2, 2, 2,12,12, 5,12,12, 2, 2, 2, 2, 4, &
+ 3, 2, 2, 2, 2, 2, 5, 2, 6, 2, 2, 2, 2, 2, 4, &
+ 3, 2, 2, 2, 2,12,12, 6,12,12, 2, 2, 2, 2, 4, &
+ 3, 0, 0, 0, 0, 0,12, 1,12, 0, 0, 0, 0, 0, 4, &
+ 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, &
+ 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, &
+ 3, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, &
+ 12, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 4, &
+ 12,12, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 /) &
+ , (/ 15,15 /) )
+
+ INTEGER :: KMPY(15,15) = RESHAPE( (/ &
+ 4, 4, 4, 4,12,12,12,11,12,12,12, 3, 3, 3, 3, &
+ 4, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 3, &
+ 4, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 3, &
+ 4, 0, 0, 0, 0, 0, 6,11, 5, 0, 0, 1, 0, 0, 3, &
+ 12, 0, 0, 0, 0, 0, 6,11, 5, 0, 0, 1, 0, 0,12, &
+ 12, 0, 0, 0, 0, 0, 6,11, 5, 0, 0, 1, 0, 0,12, &
+ 12,12,12, 6, 6, 6, 6,11, 5, 5, 5, 5,12,12,12, &
+ 11,11,11,11,11,11,11,11,11,11,11,11,11,11,11, &
+ 12,12,12, 5, 5, 5, 5,11, 6, 6, 6, 6,12,12,12, &
+ 12, 0, 0, 0, 0, 0, 5,11, 6, 0, 0, 1, 0, 0,12, &
+ 12, 0, 0, 0, 0, 0, 5,11, 6, 0, 0, 1, 0, 0,12, &
+ 3, 2, 2, 2, 2, 2, 5,11, 6, 2, 2, 2, 2, 2, 4, &
+ 3, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 4, &
+ 3, 0, 0, 0, 0, 0,12,11,12, 0, 0, 1, 0, 0, 4, &
+ 3, 3, 3, 3,12,12,12,11,12,12,12, 4, 4, 4, 4 /) &
+ , (/ 15,15 /) )
+
+ INTEGER :: KDIV(15,15) = RESHAPE( (/ &
+ 12,12,12, 4, 4, 4, 4,12, 3, 3, 3, 3,12,12,12, &
+ 12, 0, 0, 0, 0, 0, 4,12, 3, 0, 0, 1, 0, 0,12, &
+ 12, 0, 0, 0, 0, 0, 4,12, 3, 0, 0, 1, 0, 0,12, &
+ 6, 0, 0, 0, 0, 0, 4,12, 3, 0, 0, 1, 0, 0, 5, &
+ 6, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 5, &
+ 6, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 5, &
+ 6, 6, 6, 6,12,12,12,12,12,12,12, 5, 5, 5, 5, &
+ 11,11,11,11,11,11,11,12,11,11,11,11,11,11,11, &
+ 5, 5, 5, 5,12,12,12,12,12,12,12, 6, 6, 6, 6, &
+ 5, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 6, &
+ 5, 0, 0, 0, 0, 0,12,12,12, 0, 0, 1, 0, 0, 6, &
+ 5, 0, 0, 0, 0, 0, 3,12, 4, 0, 0, 1, 0, 0, 6, &
+ 12, 0, 0, 0, 0, 0, 3,12, 4, 0, 0, 1, 0, 0,12, &
+ 12, 0, 0, 0, 0, 0, 3,12, 4, 0, 0, 1, 0, 0,12, &
+ 12,12,12, 3, 3, 3, 3,12, 4, 4, 4, 4,12,12,12 /) &
+ , (/ 15,15 /) )
+
+ INTEGER :: KPWR(15,15) = RESHAPE( (/ &
+ 12,12, 0, 5,12,12,12, 8,12,12,12, 3, 0,12,12, &
+ 12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12, &
+ 12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12, &
+ 12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12, &
+ 12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12, &
+ 12,12, 0, 0,12,12,12, 8,12,12,12, 1, 0,12,12, &
+ 12,12, 0, 3,12,12,12, 8,12,12,12, 5, 0,12,12, &
+ 12,12,12,12,12,12,12,12,11,11,11,11,11,11,11, &
+ 4, 4, 4, 4,12,12,12, 8,12,12,12, 6, 6, 6, 6, &
+ 4, 4, 0, 0, 0, 8, 8, 8, 8, 0, 0, 1, 0, 6, 6, &
+ 4, 4, 0, 0, 0, 8, 8, 8, 8, 0, 0, 1, 0, 6, 6, &
+ 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, &
+ 6, 6, 0, 0, 0, 8, 8, 8, 8, 8, 0, 1, 0, 4, 4, &
+ 6, 6, 0, 0, 0, 8, 8, 8, 8, 8, 0, 1, 0, 4, 4, &
+ 6, 6, 6, 6,12,12,12, 8,12,12,12, 4, 4, 4, 4 /) &
+ , (/ 15,15 /) )
+
+ INTEGER :: KSQRT(15) = (/ 12,12,12,12,12,12,12,11,12, 0, 0, 8, 0, 0,12 /)
+ INTEGER :: KEXP(15) = (/ 6, 6, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0, 4, 4 /)
+ INTEGER :: KLN(15) = (/ 12,12,12,12,12,12,12,12,12, 0, 0,11, 0, 0,12 /)
+ INTEGER :: KSIN(15) = (/ 12,12, 0, 0, 0, 0, 5,11, 6, 0, 0, 0, 0,12,12 /)
+ INTEGER :: KCOS(15) = (/ 12,12, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0,12,12 /)
+ INTEGER :: KTAN(15) = (/ 12,12, 0, 0, 0, 0, 5,11, 6, 0, 0, 0, 0,12,12 /)
+ INTEGER :: KASIN(15) = (/ 12,12,12, 9, 0, 0, 5,11, 6, 0, 0,10,12,12,12 /)
+ INTEGER :: KACOS(15) = (/ 12,12,12,13, 0,10,10,10,10,10, 0,11,12,12,12 /)
+ INTEGER :: KATAN(15) = (/ 9, 9, 0,14, 0, 0, 5,11, 6, 0, 0,15, 0,10,10 /)
+ INTEGER :: KSINH(15) = (/ 3, 3, 0, 0, 0, 1, 5,11, 6, 1, 0, 0, 0, 4, 4 /)
+ INTEGER :: KCOSH(15) = (/ 4, 4, 0, 0, 0, 8, 8, 8, 8, 8, 0, 0, 0, 4, 4 /)
+ INTEGER :: KTANH(15) = (/ 7, 7, 0, 0, 0, 1, 5,11, 6, 1, 0, 0, 0, 8, 8 /)
+ INTEGER :: KLG10(15) = (/ 12,12,12,12,12,12,12,12,12, 0, 0,11, 0, 0,12 /)
+
+ KRESLT = 12
+ KFLAG = -4
+ IF (MA(1) == MUNKNO) RETURN
+ IF (NARGS == 2) THEN
+ IF (MB(1) == MUNKNO) RETURN
+ ENDIF
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KFLAG = 0
+ NAMEST(NCALL) = KROUTN
+
+! Check the validity of parameters if this is a user call.
+
+ IF (NCALL > 1 .AND. KDEBUG == 0) GO TO 130
+
+! Check NDIG.
+
+ IF (NDIG < 2 .OR. NDIG > NDIGMX) THEN
+ KFLAG = -1
+ CALL FMWARN
+ NDS = NDIG
+ IF (NDIG < 2) NDIG = 2
+ IF (NDIG > NDIGMX) NDIG = NDIGMX
+ WRITE (KW, &
+ "(' NDIG was',I10,'. It has been changed to',I10,'.')" &
+ ) NDS,NDIG
+ RETURN
+ ENDIF
+
+! Check MBASE.
+
+ IF (MBASE < 2 .OR. MBASE > MXBASE) THEN
+ KFLAG = -2
+ CALL FMWARN
+ MBS = MBASE
+ IF (MBASE < 2) MBASE = 2
+ IF (MBASE > MXBASE) MBASE = MXBASE
+ WRITE (KW, &
+ "(' MBASE was',I10,'. It has been changed to',I10,'.')" &
+ ) INT(MBS),INT(MBASE)
+ CALL FMCONS
+ RETURN
+ ENDIF
+
+! Check exponent range.
+
+ IF (MA(1) > MXEXP+1 .OR. MA(1) < -MXEXP) THEN
+ IF (ABS(MA(1)) /= MEXPOV .OR. ABS(MA(2)) /= 1) THEN
+ KFLAG = -3
+ CALL FMWARN
+ RETURN
+ ENDIF
+ ENDIF
+ IF (NARGS == 2) THEN
+ IF (MB(1) > MXEXP+1 .OR. MB(1) < -MXEXP) THEN
+ IF (ABS(MB(1)) /= MEXPOV .OR. ABS(MB(2)) /= 1) THEN
+ KFLAG = -3
+ CALL FMWARN
+ RETURN
+ ENDIF
+ ENDIF
+ ENDIF
+
+! Check for properly normalized digits in the
+! input arguments.
+
+ IF (ABS(MA(1)-INT(MA(1))) /= 0) KFLAG = 1
+ IF (MA(2) <= (-1) .OR. MA(2) >= MBASE .OR. &
+ ABS(MA(2)-INT(MA(2))) /= 0) KFLAG = 2
+ IF (KDEBUG == 0) GO TO 110
+ DO J = 3, NDIG+1
+ IF (MA(J) < 0 .OR. MA(J) >= MBASE .OR. &
+ ABS(MA(J)-INT(MA(J))) /= 0) THEN
+ KFLAG = J
+ GO TO 110
+ ENDIF
+ ENDDO
+ 110 IF (KFLAG /= 0) THEN
+ J = KFLAG
+ KFLAG = -4
+ KWRNSV = KWARN
+ IF (KWARN >= 2) KWARN = 1
+ CALL FMWARN
+ KWARN = KWRNSV
+ IF (KWARN >= 1) THEN
+ WRITE (KW,*) ' First invalid array element: MA(', &
+ J,') = ',MA(J)
+ ENDIF
+ KFLAG = -4
+ IF (KWARN >= 2) THEN
+ STOP
+ ENDIF
+ RETURN
+ ENDIF
+ IF (NARGS == 2) THEN
+ IF (ABS(MB(1)-INT(MB(1))) /= 0) KFLAG = 1
+ IF (MB(2) <= (-1) .OR. MB(2) >= MBASE .OR. &
+ ABS(MB(2)-INT(MB(2))) /= 0) KFLAG = 2
+ IF (KDEBUG == 0) GO TO 120
+ DO J = 3, NDIG+1
+ IF (MB(J) < 0 .OR. MB(J) >= MBASE .OR. &
+ ABS(MB(J)-INT(MB(J))) /= 0) THEN
+ KFLAG = J
+ GO TO 120
+ ENDIF
+ ENDDO
+ 120 IF (KFLAG /= 0) THEN
+ J = KFLAG
+ KFLAG = -4
+ KWRNSV = KWARN
+ IF (KWARN >= 2) KWARN = 1
+ CALL FMWARN
+ KWARN = KWRNSV
+ IF (KWARN >= 1) THEN
+ WRITE (KW,*) ' First invalid array element: MB(', &
+ J,') = ',MB(J)
+ ENDIF
+ KFLAG = -4
+ IF (KWARN >= 2) THEN
+ STOP
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+
+! Check for special cases.
+
+ 130 CALL FMCAT(MA,NCATMA)
+ NCATMB = 0
+ IF (NARGS == 2) CALL FMCAT(MB,NCATMB)
+
+ IF (KROUTN == 'FMADD ') THEN
+ KRESLT = KADD(NCATMB,NCATMA)
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMSUB ') THEN
+ IF (NCATMB < 16) NCATMB = 16 - NCATMB
+ KRESLT = KADD(NCATMB,NCATMA)
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMMPY ') THEN
+ KRESLT = KMPY(NCATMB,NCATMA)
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMDIV ') THEN
+ KRESLT = KDIV(NCATMB,NCATMA)
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMPWR ') THEN
+ KRESLT = KPWR(NCATMB,NCATMA)
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMSQRT') THEN
+ KRESLT = KSQRT(NCATMA)
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMEXP ') THEN
+ KRESLT = KEXP(NCATMA)
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMLN ') THEN
+ KRESLT = KLN(NCATMA)
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMSIN ') THEN
+ KRESLT = KSIN(NCATMA)
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMCOS ') THEN
+ KRESLT = KCOS(NCATMA)
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMTAN ') THEN
+ KRESLT = KTAN(NCATMA)
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMASIN') THEN
+ KRESLT = KASIN(NCATMA)
+ IF ((NCATMA == 7.OR.NCATMA == 9) .AND. KRAD == 0) KRESLT = 12
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMACOS') THEN
+ KRESLT = KACOS(NCATMA)
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMATAN') THEN
+ KRESLT = KATAN(NCATMA)
+ IF ((NCATMA == 7.OR.NCATMA == 9) .AND. KRAD == 0) KRESLT = 12
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMSINH') THEN
+ KRESLT = KSINH(NCATMA)
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMCOSH') THEN
+ KRESLT = KCOSH(NCATMA)
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMTANH') THEN
+ KRESLT = KTANH(NCATMA)
+ GO TO 140
+ ENDIF
+
+ IF (KROUTN == 'FMLG10') THEN
+ KRESLT = KLG10(NCATMA)
+ GO TO 140
+ ENDIF
+
+ KRESLT = 0
+ RETURN
+
+ 140 IF (KRESLT == 12) THEN
+ KFLAG = -4
+ CALL FMWARN
+ ENDIF
+ IF (KRESLT == 3 .OR. KRESLT == 4) THEN
+ IF (NCATMA == 1 .OR. NCATMA == 7 .OR. NCATMA == 9 .OR. &
+ NCATMA == 15 .OR. NCATMB == 1 .OR. NCATMB == 7 .OR. &
+ NCATMB == 9 .OR. NCATMB == 15) THEN
+ KFLAG = -5
+ ELSE
+ KFLAG = -5
+ CALL FMWARN
+ ENDIF
+ ENDIF
+ IF (KRESLT == 5 .OR. KRESLT == 6) THEN
+ IF (NCATMA == 1 .OR. NCATMA == 7 .OR. NCATMA == 9 .OR. &
+ NCATMA == 15 .OR. NCATMB == 1 .OR. NCATMB == 7 .OR. &
+ NCATMB == 9 .OR. NCATMB == 15) THEN
+ KFLAG = -6
+ ELSE
+ KFLAG = -6
+ CALL FMWARN
+ ENDIF
+ ENDIF
+ RETURN
+ END SUBROUTINE FMARGS
+
+ SUBROUTINE FMASIN(MA,MB)
+
+! MB = ARCSIN(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
+ INTEGER J,K,KASAVE,KOVUN,KRESLT,NDSAVE
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB .OR. MA(1) > 0 .OR. MA(2) == 0) THEN
+ CALL FMENTR('FMASIN',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMASIN'
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ MACCA = MA(0)
+ CALL FMEQ2(MA,MB,NDSAVE,NDIG)
+ MB(0) = NINT(NDIG*ALOGM2)
+
+! Use ASIN(X) = ATAN(X/SQRT(1-X*X))
+
+ CALL FMI2M(1,M05)
+ CALL FMSUB(M05,MB,M03)
+ CALL FMADD(M05,MB,M04)
+ CALL FMMPY_R2(M03,M04)
+ CALL FMSQRT_R1(M04)
+ CALL FMDIV_R1(MB,M04)
+
+ CALL FMATAN(MB,M13)
+ CALL FMEQ(M13,MB)
+
+! Round the result and return.
+
+ MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMASIN
+
+ SUBROUTINE FMATAN(MA,MB)
+
+! MB = ARCTAN(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ DOUBLE PRECISION X,XM
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER NSTACK(19)
+ REAL (KIND(1.0D0)) :: MA1,MACCA,MACMAX,MAS,MXSAVE
+ INTEGER J,K,KASAVE,KOVUN,KRESLT,KRSAVE,KST,KWRNSV,NDSAV1,NDSAVE, &
+ NDSV
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN
+ CALL FMENTR('FMATAN',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMATAN'
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ MACCA = MA(0)
+ CALL FMEQ2(MA,M05,NDSAVE,NDIG)
+ M05(0) = NINT(NDIG*ALOGM2)
+
+! If MA >= 1 work with 1/MA.
+
+ MA1 = MA(1)
+ MAS = MA(-1)
+ M05(-1) = 1
+ IF (MA1 >= 1) THEN
+ CALL FMI2M(1,MB)
+ CALL FMDIV_R2(MB,M05)
+ ENDIF
+
+ KRSAVE = KRAD
+ KRAD = 1
+ KWRNSV = KWARN
+
+ X = M05(1)
+ XM = MXBASE
+
+! In case pi has not been computed at the current precision
+! and will be needed here, get it to full precision first
+! to avoid repeated calls at increasing precision during
+! Newton iteration.
+
+ IF (MA1 >= 1 .OR. KRSAVE == 0) THEN
+ IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDIG+2,NDG2MX)
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'NOEQ '
+ CALL FMPI(MPISAV)
+ NCALL = NCALL - 1
+ NDIG = NDSV
+ ENDIF
+ ENDIF
+
+! If the argument is small, use the Taylor series,
+! otherwise use Newton iteration.
+
+ IF (X*DLOGMB < -5.0D0*LOG(XM)) THEN
+ KWARN = 0
+ CALL FMEQ(M05,MB)
+ IF (MB(1) <= -NDIG) GO TO 120
+ CALL FMSQR(M05,M06)
+ J = 3
+ NDSAV1 = NDIG
+
+ 110 CALL FMMPY_R1(M05,M06)
+ IF (M05(1) /= MUNKNO .AND. M05(2) /= 0) M05(-1) = -M05(-1)
+ CALL FMDIVI(M05,J,M03)
+ NDIG = NDSAV1
+ CALL FMADD_R1(MB,M03)
+ IF (KFLAG /= 0) THEN
+ KFLAG = 0
+ GO TO 120
+ ENDIF
+ NDIG = NDSAV1 - INT((MB(1)-M03(1)))
+ IF (NDIG < 2) NDIG = 2
+ J = J + 2
+ GO TO 110
+ ELSE
+
+ CALL FMM2DP(M05,X)
+ X = ATAN(X)
+ CALL FMDPM(X,MB)
+ CALL FMDIG(NSTACK,KST)
+
+! Newton iteration.
+
+ DO J = 1, KST
+ NDIG = NSTACK(J)
+ CALL FMSIN(MB,M06)
+ CALL FMSQR(M06,M03)
+ CALL FMI2M(1,M04)
+ CALL FMSUB_R2(M04,M03)
+ CALL FMSQRT(M03,M04)
+ CALL FMDIV_R2(M06,M04)
+ CALL FMSUB_R1(M04,M05)
+ CALL FMMPY_R2(M03,M04)
+ CALL FMSUB_R1(MB,M04)
+ ENDDO
+ MB(0) = NINT(NDIG*ALOGM2)
+ ENDIF
+
+! If MA >= 1 use pi/2 - ATAN(1/MA)
+
+ 120 IF (MA1 >= 1) THEN
+ CALL FMDIVI(MPISAV,2,M06)
+ CALL FMSUB_R2(M06,MB)
+ ENDIF
+
+! Convert to degrees if necessary, round and return.
+
+ KRAD = KRSAVE
+ IF (KRAD == 0) THEN
+ CALL FMMPYI_R1(MB,180)
+ CALL FMDIV_R1(MB,MPISAV)
+ ENDIF
+ IF (MB(1) /= MUNKNO .AND. MB(2) /= 0 .AND. MAS < 0) MB(-1) = -MB(-1)
+
+ IF (KFLAG == 1) KFLAG = 0
+ KWARN = KWRNSV
+ MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMATAN
+
+ SUBROUTINE FMATN2(MA,MB,MC)
+
+! MC = ATAN2(MA,MB)
+
+! MC is returned as the angle between -pi and pi (or -180 and 180 if
+! degree mode is selected) for which TAN(MC) = MA/MB. MC is an angle
+! for the point (MB,MA) in polar coordinates.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MXEXP1,MXSAVE
+ INTEGER J,JQUAD,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB) THEN
+ CALL FMENTR('FMATN2',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMATN2'
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MB,MC,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ KWRNSV = KWARN
+ KWARN = 0
+
+ MACCA = MA(0)
+ MACCB = MB(0)
+ CALL FMEQ2(MA,M01,NDSAVE,NDIG)
+ M01(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ2(MB,M02,NDSAVE,NDIG)
+ M02(0) = NINT(NDIG*ALOGM2)
+
+! Check for special cases.
+
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR. &
+ (MA(2) == 0 .AND. MB(2) == 0)) THEN
+ CALL FMST2M('UNKNOWN',MC)
+ KFLAG = -4
+ GO TO 110
+ ENDIF
+
+ IF (MB(2) == 0 .AND. MA(-1) > 0) THEN
+ IF (KRAD == 0) THEN
+ CALL FMI2M(90,MC)
+ ELSE
+ CALL FMPI(MC)
+ CALL FMDIVI_R1(MC,2)
+ ENDIF
+ GO TO 110
+ ENDIF
+
+ IF (MB(2) == 0 .AND. MA(-1) < 0) THEN
+ IF (KRAD == 0) THEN
+ CALL FMI2M(-90,MC)
+ ELSE
+ CALL FMPI(MC)
+ CALL FMDIVI_R1(MC,-2)
+ ENDIF
+ GO TO 110
+ ENDIF
+
+ MXEXP1 = INT(MXEXP2/2.01D0)
+ IF (MA(1) == MEXPOV .AND. MB(1) < MXEXP1-NDIG-2) THEN
+ IF (KRAD == 0) THEN
+ CALL FMI2M(90,MC)
+ ELSE
+ CALL FMPI(MC)
+ CALL FMDIVI_R1(MC,2)
+ ENDIF
+ IF (M01(-1) < 0) MC(-1) = -1
+ GO TO 110
+ ENDIF
+
+ IF (MA(1) == MEXPUN .AND. (-MB(1)) < MXEXP1-NDIG-2 .AND. &
+ MB(-1) < 0) THEN
+ IF (KRAD == 0) THEN
+ CALL FMI2M(180,MC)
+ ELSE
+ CALL FMPI(MC)
+ ENDIF
+ IF (M01(-1) < 0) MC(-1) = -1
+ GO TO 110
+ ENDIF
+
+ IF (MB(1) == MEXPOV .AND. MA(1) < MXEXP1-NDIG-2 .AND. &
+ MB(-1) < 0) THEN
+ IF (KRAD == 0) THEN
+ CALL FMI2M(180,MC)
+ ELSE
+ CALL FMPI(MC)
+ ENDIF
+ IF (M01(-1) < 0) MC(-1) = -1
+ GO TO 110
+ ENDIF
+
+ IF (MB(1) == MEXPUN .AND. MA(2) == 0) THEN
+ IF (MB(-1) < 0) THEN
+ IF (KRAD == 0) THEN
+ CALL FMI2M(180,MC)
+ ELSE
+ CALL FMPI(MC)
+ ENDIF
+ ELSE
+ CALL FMI2M(0,MC)
+ ENDIF
+ GO TO 110
+ ENDIF
+
+ IF (MB(1) == MEXPUN .AND. (-MA(1)) < MXEXP1-NDIG-2) THEN
+ IF (KRAD == 0) THEN
+ CALL FMI2M(90,MC)
+ ELSE
+ CALL FMPI(MC)
+ CALL FMDIVI_R1(MC,2)
+ ENDIF
+ IF (M01(-1) < 0) MC(-1) = -1
+ GO TO 110
+ ENDIF
+
+! Determine the quadrant for the result, then use FMATAN.
+
+ IF (MA(-1) >= 0 .AND. MB(-1) > 0) JQUAD = 1
+ IF (MA(-1) >= 0 .AND. MB(-1) < 0) JQUAD = 2
+ IF (MA(-1) < 0 .AND. MB(-1) < 0) JQUAD = 3
+ IF (MA(-1) < 0 .AND. MB(-1) > 0) JQUAD = 4
+
+ CALL FMDIV(M01,M02,MC)
+ MC(-1) = 1
+ CALL FMATAN(MC,M13)
+ CALL FMEQ(M13,MC)
+
+ IF (JQUAD == 2 .OR. JQUAD == 3) THEN
+ IF (KRAD == 0) THEN
+ CALL FMI2M(180,M05)
+ CALL FMSUB_R2(M05,MC)
+ ELSE
+ CALL FMPI(M05)
+ CALL FMSUB_R2(M05,MC)
+ ENDIF
+ ENDIF
+
+ IF ((JQUAD == 3 .OR. JQUAD == 4) .AND. MC(1) /= MUNKNO .AND. &
+ MC(2) /= 0) MC(-1) = -MC(-1)
+
+! Round the result and return.
+
+ 110 IF (KFLAG == 1) KFLAG = 0
+ KWARN = KWRNSV
+ MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)
+ MC(0) = MIN(MC(0),MACCA,MACCB,MACMAX)
+ DO J = -1, NDIG+1
+ M01(J) = MC(J)
+ ENDDO
+ CALL FMEXIT(M01,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMATN2
+
+ SUBROUTINE FMBIG(MA)
+
+! MA = The biggest representable FM number using the current base
+! and precision.
+! The smallest positive number is then 1.0/MA.
+! Because of rounding, 1.0/(1.0/MA) will then overflow.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ INTEGER J,N1
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMBIG '
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KFLAG = 0
+ N1 = NDIG + 1
+ DO J = 2, N1
+ MA(J) = MBASE - 1
+ ENDDO
+ MA(1) = MXEXP + 1
+ MA(0) = NINT(NDIG*ALOGM2)
+ MA(-1) = 1
+
+ IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMBIG
+
+ SUBROUTINE FMCAT(MA,NCAT)
+
+! NCAT is returned as the category of MA. This is used by the various
+! arithmetic routines to handle special cases such as:
+! 'number greater than 1' + 'underflowed result' is the first argument,
+! 'overflowed result' / 'overflowed result' is 'unknown'.
+
+! NCAT range
+
+! 1. -OV OV stands for overflowed results.
+! 2. (-OV , -OVTH) ( MA(1) >= MAXEXP+2 )
+! 3. (-OVTH , -1)
+! 4. -1 OVTH stands for a representable
+! 5. (-1 , -UNTH) number near the overflow
+! 6. (-UNTH , -UN) threshold.
+! 7. -UN ( MA(1) >= MAXEXP-NDIG+1 )
+! 8. 0
+! 9. +UN UN stands for underflowed results.
+! 10. (+UN , +UNTH) ( MA(1) <= -MAXEXP-1 )
+! 11. (+UNTH , +1)
+! 12. +1 UNTH stands for a representable
+! 13. (+1 , +OVTH) number near the underflow
+! 14. (+OVTH , +OV) threshold.
+! 15. +OV ( MA(1) <= -MAXEXP+NDIG-1 )
+! 16. UNKNOWN
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER NCAT
+
+ REAL (KIND(1.0D0)) :: MA2,MXEXP1
+ INTEGER J,NLAST
+
+! Check for special symbols.
+
+ NCAT = 16
+ IF (MA(1) == MUNKNO) RETURN
+
+ IF (MA(1) == MEXPOV) THEN
+ NCAT = 15
+ IF (MA(-1) < 0) NCAT = 1
+ RETURN
+ ENDIF
+
+ IF (MA(1) == MEXPUN) THEN
+ NCAT = 9
+ IF (MA(-1) < 0) NCAT = 7
+ RETURN
+ ENDIF
+
+ IF (MA(2) == 0) THEN
+ NCAT = 8
+ RETURN
+ ENDIF
+
+! Check for +1 or -1.
+
+ MA2 = ABS(MA(2))
+ IF (MA(1) == 1 .AND. MA2 == 1) THEN
+ NLAST = NDIG + 1
+ IF (NLAST >= 3) THEN
+ DO J = 3, NLAST
+ IF (MA(J) /= 0) GO TO 110
+ ENDDO
+ ENDIF
+ NCAT = 12
+ IF (MA(-1) < 0) NCAT = 4
+ RETURN
+ ENDIF
+
+ 110 MXEXP1 = INT(MXEXP)
+ IF (MA(1) >= MXEXP1-NDIG+2) THEN
+ NCAT = 14
+ IF (MA(-1) < 0) NCAT = 2
+ RETURN
+ ENDIF
+
+ IF (MA(1) >= 1) THEN
+ NCAT = 13
+ IF (MA(-1) < 0) NCAT = 3
+ RETURN
+ ENDIF
+
+ IF (MA(1) >= -MXEXP1+NDIG) THEN
+ NCAT = 11
+ IF (MA(-1) < 0) NCAT = 5
+ RETURN
+ ENDIF
+
+ IF (MA(1) >= -MXEXP1) THEN
+ NCAT = 10
+ IF (MA(-1) < 0) NCAT = 6
+ RETURN
+ ENDIF
+
+ RETURN
+ END SUBROUTINE FMCAT
+
+ SUBROUTINE FMCHSH(MA,MB,MC)
+
+! MB = COSH(MA), MC = SINH(MA)
+
+! If both the hyperbolic sine and cosine are needed, this routine
+! is faster than calling both FMCOSH and FMSINH.
+
+! MB and MC must be distinct arrays.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
+ INTEGER J,K,KASAVE,KOVUN,KRESLT,KWRNSV,NCSAVE,NDSAVE
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ MACCA = MA(0)
+ MAS = MA(-1)
+ IF (ABS(MA(1)) > MEXPAB) THEN
+ NCSAVE = NCALL
+ CALL FMENTR('FMCHSH',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (MA(1) == MUNKNO) KOVUN = 2
+ NCALL = NCSAVE + 1
+ CALL FMEQ2(MA,M04,NDSAVE,NDIG)
+ M04(0) = NINT(NDIG*ALOGM2)
+ M04(-1) = 1
+ CALL FMCOSH(M04,MB)
+ CALL FMSINH(M04,MC)
+ GO TO 110
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMCHSH'
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ CALL FMEQ(MA,M04)
+ CALL FMCOSH(M04,MB)
+ CALL FMSINH(M04,MC)
+ KFLAG = -9
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ CALL FMEQ2(MA,M04,NDSAVE,NDIG)
+ M04(0) = NINT(NDIG*ALOGM2)
+ M04(-1) = 1
+
+ K = 1
+ IF (M04(1) == 0 .AND. M04(2) /= 0) THEN
+ IF (MBASE/M04(2) >= 100) K = 2
+ ENDIF
+ IF (M04(1) >= 0 .AND. M04(2) /= 0 .AND. K == 1) THEN
+ CALL FMCOSH(M04,MB)
+ IF (MB(1) > NDIG) THEN
+ CALL FMEQ(MB,MC)
+ GO TO 110
+ ENDIF
+ CALL FMSQR(MB,M03)
+ CALL FMI2M(-1,M02)
+ CALL FMADD_R1(M03,M02)
+ CALL FMSQRT(M03,MC)
+ ELSE
+ CALL FMSINH(M04,MC)
+ CALL FMSQR(MC,M03)
+ CALL FMI2M(1,M02)
+ CALL FMADD_R1(M03,M02)
+ CALL FMSQRT(M03,MB)
+ ENDIF
+
+! Round and return.
+
+ 110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)
+ MC(0) = MIN(MC(0),MACCA,MACMAX)
+ IF (MAS < 0 .AND. MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
+ CALL FMEQ2_R1(MC,NDIG,NDSAVE)
+ MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ IF (KOVUN == 2) THEN
+ KWRNSV = KWARN
+ KWARN = 0
+ ENDIF
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ IF (KOVUN == 2) THEN
+ KWARN = KWRNSV
+ ENDIF
+ IF (NTRACE /= 0) THEN
+ IF (ABS(NTRACE) >= 1 .AND. NCALL+1 <= LVLTRC) THEN
+ IF (NTRACE < 0) THEN
+ CALL FMNTRJ(MC,NDIG)
+ ELSE
+ CALL FMPRNT(MC)
+ ENDIF
+ ENDIF
+ ENDIF
+ RETURN
+ END SUBROUTINE FMCHSH
+
+ FUNCTION FMCOMP(MA,LREL,MB)
+
+! Logical comparison of FM numbers MA and MB.
+
+! LREL is a CHARACTER description of the comparison to be done:
+! LREL = 'EQ' returns FMCOMP = .TRUE. if MA == MB
+! = 'NE', 'GE', 'GT', 'LE', 'LT' also work like a logical IF.
+! = '==', '/=', '<', '<=', '>', '>=' may be used.
+
+! For comparisons involving 'UNKNOWN' or two identical special symbols
+! such as +OVERFLOW,'EQ',+OVERFLOW, FMCOMP is returned FALSE and a
+! KFLAG = -4 error condition is returned.
+
+! Some compilers object to functions with side effects such as
+! changing KFLAG or other module FMVALS variables. Blocks of
+! code that modify these variables are identified by:
+! C DELETE START
+! ...
+! C DELETE STOP
+! These may be removed or commented out to produce a function without
+! side effects. This disables trace printing in FMCOMP, and error
+! codes are not returned in KFLAG.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+ CHARACTER(*) :: LREL
+ CHARACTER(2) :: JREL
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ INTEGER J,JCOMP,NLAST
+
+! DELETE START
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMCOMP'
+
+ IF (NCALL <= LVLTRC .AND. ABS(NTRACE) >= 2) THEN
+ WRITE (KW,"(' Input to FMCOMP')")
+
+ IF (NTRACE > 0) THEN
+ CALL FMPRNT(MA)
+ IF (INDEX('=/<>',LREL(1:1)) > 0) THEN
+ WRITE (KW,"(8X,A)") LREL
+ ELSE
+ WRITE (KW,"(7X,'.',A,'.')") LREL
+ ENDIF
+ CALL FMPRNT(MB)
+ ELSE
+ CALL FMNTRJ(MA,NDIG)
+ IF (INDEX('=/<>',LREL(1:1)) > 0) THEN
+ WRITE (KW,"(8X,A)") LREL
+ ELSE
+ WRITE (KW,"(7X,'.',A,'.')") LREL
+ ENDIF
+ CALL FMNTRJ(MB,NDIG)
+ ENDIF
+ ENDIF
+! DELETE STOP
+
+! JCOMP will be 1 if MA > MB
+! 2 if MA == MB
+! 3 if MA < MB
+
+! Check for special cases.
+
+ JREL = LREL
+ IF (LREL /= 'EQ' .AND. LREL /= 'NE' .AND. LREL /= 'LT' .AND. &
+ LREL /= 'GT' .AND. LREL /= 'LE' .AND. LREL /= 'GE') THEN
+ IF (LREL == 'eq' .OR. LREL == '==') THEN
+ JREL = 'EQ'
+ ELSE IF (LREL == 'ne' .OR. LREL == '/=') THEN
+ JREL = 'NE'
+ ELSE IF (LREL == 'lt' .OR. LREL == '<') THEN
+ JREL = 'LT'
+ ELSE IF (LREL == 'gt' .OR. LREL == '>') THEN
+ JREL = 'GT'
+ ELSE IF (LREL == 'le' .OR. LREL == '<=') THEN
+ JREL = 'LE'
+ ELSE IF (LREL == 'ge' .OR. LREL == '>=') THEN
+ JREL = 'GE'
+ ELSE
+ FMCOMP = .FALSE.
+! DELETE START
+ KFLAG = -4
+ IF (NCALL /= 1 .OR. KWARN <= 0) GO TO 120
+! DELETE STOP
+ IF (KWARN <= 0) GO TO 120
+ WRITE (KW, &
+ "(/' Error of type KFLAG = -4 in FM package in'," // &
+ "' routine FMCOMP'//1X,A,' is not one of the six'," // &
+ "' recognized comparisons.'//' .FALSE. has been'," // &
+ "' returned.'/)" &
+ ) LREL
+ IF (KWARN >= 2) THEN
+ STOP
+ ENDIF
+ GO TO 120
+ ENDIF
+ ENDIF
+
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
+ FMCOMP = .FALSE.
+! DELETE START
+ KFLAG = -4
+! DELETE STOP
+ GO TO 120
+ ENDIF
+
+ IF (ABS(MA(1)) == MEXPOV .AND. MA(1) == MB(1) .AND. &
+ MA(2) == MB(2) .AND. MA(-1) == MB(-1)) THEN
+ FMCOMP = .FALSE.
+! DELETE START
+ KFLAG = -4
+ IF (NCALL /= 1 .OR. KWARN <= 0) GO TO 120
+! DELETE STOP
+ IF (KWARN <= 0) GO TO 120
+ WRITE (KW, &
+ "(/' Error of type KFLAG = -4 in FM package in routine'," // &
+ "' FMCOMP'//' Two numbers in the same overflow or'," // &
+ "' underflow category cannot be compared.'//" // &
+ "' .FALSE. has been returned.'/)" &
+ )
+ IF (KWARN >= 2) THEN
+ STOP
+ ENDIF
+ GO TO 120
+ ENDIF
+
+! Check for zero.
+
+! DELETE START
+ KFLAG = 0
+! DELETE STOP
+ IF (MA(2) == 0) THEN
+ JCOMP = 2
+ IF (MB(2) == 0) GO TO 110
+ IF (MB(-1) < 0) JCOMP = 1
+ IF (MB(-1) > 0) JCOMP = 3
+ GO TO 110
+ ENDIF
+ IF (MB(2) == 0) THEN
+ JCOMP = 1
+ IF (MA(-1) < 0) JCOMP = 3
+ GO TO 110
+ ENDIF
+! Check for opposite signs.
+
+ IF (MA(-1) > 0 .AND. MB(-1) < 0) THEN
+ JCOMP = 1
+ GO TO 110
+ ENDIF
+ IF (MB(-1) > 0 .AND. MA(-1) < 0) THEN
+ JCOMP = 3
+ GO TO 110
+ ENDIF
+
+! See which one is larger in absolute value.
+
+ IF (MA(1) > MB(1)) THEN
+ JCOMP = 1
+ GO TO 110
+ ENDIF
+ IF (MB(1) > MA(1)) THEN
+ JCOMP = 3
+ GO TO 110
+ ENDIF
+ NLAST = NDIG + 1
+
+ DO J = 2, NLAST
+ IF (ABS(MA(J)) > ABS(MB(J))) THEN
+ JCOMP = 1
+ GO TO 110
+ ENDIF
+ IF (ABS(MB(J)) > ABS(MA(J))) THEN
+ JCOMP = 3
+ GO TO 110
+ ENDIF
+ ENDDO
+
+ JCOMP = 2
+
+! Now match the JCOMP value to the requested comparison.
+
+ 110 IF (JCOMP == 1 .AND. MA(-1) < 0) THEN
+ JCOMP = 3
+ ELSE IF (JCOMP == 3 .AND. MB(-1) < 0) THEN
+ JCOMP = 1
+ ENDIF
+
+ FMCOMP = .FALSE.
+ IF (JCOMP == 1 .AND. (JREL == 'GT' .OR. JREL == 'GE' .OR. &
+ JREL == 'NE')) FMCOMP = .TRUE.
+
+ IF (JCOMP == 2 .AND. (JREL == 'EQ' .OR. JREL == 'GE' .OR. &
+ JREL == 'LE')) FMCOMP = .TRUE.
+
+ IF (JCOMP == 3 .AND. (JREL == 'NE' .OR. JREL == 'LT' .OR. &
+ JREL == 'LE')) FMCOMP = .TRUE.
+
+ 120 CONTINUE
+! DELETE START
+ IF (NTRACE /= 0) THEN
+ IF (NCALL <= LVLTRC .AND. ABS(NTRACE) >= 1) THEN
+ IF (KFLAG == 0) THEN
+ WRITE (KW, &
+ "(' FMCOMP',15X,'Call level =',I2,5X,'MBASE ='," // &
+ "I10,5X,'NDIG =',I6)" &
+ ) NCALL,INT(MBASE),NDIG
+ ELSE
+ WRITE (KW, &
+ "(' FMCOMP',6X,'Call level =',I2,4X,'MBASE ='," // &
+ "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)" &
+ ) NCALL,INT(MBASE),NDIG,KFLAG
+ ENDIF
+ IF (FMCOMP) THEN
+ WRITE (KW,"(7X,'.TRUE.')")
+ ELSE
+ WRITE (KW,"(7X,'.FALSE.')")
+ ENDIF
+ ENDIF
+ ENDIF
+ NCALL = NCALL - 1
+! DELETE STOP
+ RETURN
+ END FUNCTION FMCOMP
+
+ SUBROUTINE FMCONS
+
+! Set several saved machine precision constants.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ MBLOGS = MBASE
+ ALOGMB = LOG(REAL(MBASE))
+ ALOGM2 = ALOGMB/LOG(2.0)
+ ALOGMX = LOG(REAL(MAXINT))
+ ALOGMT = ALOGMB/LOG(10.0)
+ NGRD21 = INT(2.0/ALOGMT + 1.0)
+ NGRD52 = INT(5.0/ALOGMT + 2.0)
+ NGRD22 = INT(2.0/ALOGMT + 2.0)
+ IF (MBASE < 1000 .OR. KRPERF /= 0) THEN
+ NGRD21 = 2*NGRD21
+ NGRD52 = 4*NGRD52
+ NGRD22 = 2*NGRD22
+ ENDIF
+ MEXPAB = AINT (MXEXP2/5)
+ DLOGMB = LOG(DBLE(MBASE))
+ DLOGTN = LOG(10.0D0)
+ DLOGTW = LOG(2.0D0)
+ DPPI = 4.0D0*ATAN(1.0D0)
+ DLOGTP = LOG(2.0D0*DPPI)
+ DLOGPI = LOG(DPPI)
+ DLOGEB = -LOG(DPEPS)/DLOGMB
+
+ RETURN
+ END SUBROUTINE FMCONS
+
+ SUBROUTINE FMCOS(MA,MB)
+
+! MB = COS(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
+ INTEGER J,JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NDSV
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN
+ CALL FMENTR('FMCOS ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMCOS '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ MACCA = MA(0)
+ CALL FMEQ2(MA,MB,NDSAVE,NDIG)
+ MB(0) = NINT(NDIG*ALOGM2)
+ MB(-1) = 1
+ CALL FMEQ(MB,MWE)
+ KWRNSV = KWARN
+ KWARN = 0
+
+! Reduce the argument, convert to radians if the input is
+! in degrees, and evaluate the function.
+
+ CALL FMRDC(MB,JSIN,JCOS,JSWAP)
+ KWARN = KWRNSV
+ IF (MB(1) == MUNKNO) THEN
+ IF (KRAD /= 1 .OR. JSWAP == 1) THEN
+ CALL FMEQ(MWE,MB)
+ CALL FMRDC(MB,JSIN,JCOS,JSWAP)
+ GO TO 110
+ ENDIF
+ IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDIG+2,NDG2MX)
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'NOEQ '
+ CALL FMPI(MPISAV)
+ NCALL = NCALL - 1
+ NDIG = NDSV
+ ENDIF
+ CALL FMDIV(MWE,MPISAV,M04)
+ CALL FMNINT(M04,M03)
+ CALL FMMPY(M03,MPISAV,M02)
+ CALL FMSUB_R2(MWE,M02)
+ IF (M02(2) == 0) CALL FMULP(MWE,M02)
+ CALL FMI2M(1,M04)
+ CALL FMSQR_R1(M02)
+ CALL FMDIVI_R1(M02,2)
+ CALL FMSUB_R2(M04,M02)
+ CALL FMSUB_R1(M02,M04)
+ IF (M02(2) == 0) THEN
+ CALL FMI2M(JCOS,MB)
+ ELSE
+ CALL FMEQ(MWE,MB)
+ CALL FMRDC(MB,JSIN,JCOS,JSWAP)
+ ENDIF
+ GO TO 110
+ ENDIF
+ IF (KRAD == 0) THEN
+ IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDIG+2,NDG2MX)
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'NOEQ '
+ CALL FMPI(MPISAV)
+ NCALL = NCALL - 1
+ NDIG = NDSV
+ ENDIF
+ CALL FMMPY_R1(MB,MPISAV)
+ CALL FMDIVI_R1(MB,180)
+ ENDIF
+ IF (MB(1) /= MUNKNO) THEN
+ IF (JSWAP == 0) THEN
+ CALL FMCOS2(MB,M09)
+ CALL FMEQ(M09,MB)
+ ELSE
+ IF (MB(1) < 0 .OR. NDIG <= 50) THEN
+ CALL FMSIN2(MB,M09)
+ CALL FMEQ(M09,MB)
+ ELSE
+ CALL FMCOS2(MB,M09)
+ CALL FMEQ(M09,MB)
+ CALL FMI2M(1,M03)
+ CALL FMSQR_R1(MB)
+ CALL FMSUB_R2(M03,MB)
+ CALL FMSQRT_R1(MB)
+ ENDIF
+ ENDIF
+ ENDIF
+
+! Append the sign, round, and return.
+
+ IF (MB(1) /= MUNKNO .AND. MB(2) /= 0 .AND. JCOS == -1) MB(-1) = -MB(-1)
+ 110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMCOS
+
+ SUBROUTINE FMCOS2(MA,MB)
+
+! Internal subroutine for MB = COS(MA) where 0 <= MA <= 1.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent
+! sums. Increasing this value will begin to improve the
+! speed of COS when the base is large and precision exceeds
+! about 1,500 decimal digits.
+
+ REAL (KIND(1.0D0)) :: MAXVAL
+ INTEGER J,J2,K,K2,KPT,KTWO,KWRNSV,L,L2,LARGE,N2,NBOT,NDSAV1, &
+ NDSAVE,NTERM
+ REAL ALOG2,ALOGT,B,T,TJ
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (MA(2) == 0) THEN
+ CALL FMI2M(1,MB)
+ RETURN
+ ENDIF
+ NDSAVE = NDIG
+ KWRNSV = KWARN
+ KWARN = 0
+
+! Use the direct series
+! COS(X) = 1 - X**2/2! + X**4/4! - ...
+
+! The argument will be divided by 2**K2 before the series
+! is summed. The series will be added as J2 concurrent
+! series. The approximately optimal values of K2 and J2
+! are now computed to try to minimize the time required.
+! N2/2 is the approximate number of terms of the series
+! that will be needed, and L2 guard digits will be carried.
+
+! Since X is small when the series is summed, COS(X) - 1
+! is computed. Then a version of the recovery formula can
+! be used that does not suffer from severe cancellation.
+
+ B = REAL(MBASE)
+ K = NGRD52
+ T = MAX(NDIG-K,2)
+ ALOG2 = LOG(2.0)
+ ALOGT = LOG(T)
+ TJ = 0.03*ALOGMB*T**0.3333 + 1.85
+ J2 = INT(TJ)
+ J2 = MAX(1,MIN(J2,LJSUMS/NDG2MX))
+ K2 = INT(0.5*SQRT(T*ALOGMB/TJ) + 2.8)
+
+ L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B + &
+ REAL(MA(3))/(B*B)))/ALOG2 - 0.3)
+ K2 = K2 - L
+ IF (L < 0) L = 0
+ IF (K2 < 0) THEN
+ K2 = 0
+ J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) + .33)
+ ENDIF
+ IF (J2 <= 1) J2 = 1
+
+ N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2))
+ L2 = INT(LOG(REAL(N2)+2.0**K2)/ALOGMB)
+ NDIG = NDIG + L2
+ IF (NDIG > NDG2MX) THEN
+ IF (NCALL == 1) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MB)
+ KWARN = KWRNSV
+ RETURN
+ ELSE
+ NDIG = NDG2MX
+ ENDIF
+ ENDIF
+ NDSAV1 = NDIG
+
+! Divide the argument by 2**K2.
+
+ CALL FMEQ2(MA,M02,NDSAVE,NDIG)
+ KTWO = 1
+ MAXVAL = MXBASE/2
+ IF (K2 > 0) THEN
+ DO J = 1, K2
+ KTWO = 2*KTWO
+ IF (KTWO > MAXVAL) THEN
+ CALL FMDIVI_R1(M02,KTWO)
+ KTWO = 1
+ ENDIF
+ ENDDO
+ IF (KTWO > 1) CALL FMDIVI_R1(M02,KTWO)
+ ENDIF
+
+! Split into J2 concurrent sums and reduce NDIG while
+! computing each term in the sum as the terms get smaller.
+
+ CALL FMSQR_R1(M02)
+ CALL FMEQ(M02,M03)
+ IF (M03(1) /= MUNKNO .AND. M03(2) /= 0) M03(-1) = -M03(-1)
+ NTERM = 2
+ DO J = 1, J2
+ NBOT = NTERM*(NTERM-1)
+ CALL FMDIVI_R1(M03,NBOT)
+ NTERM = NTERM + 2
+ KPT = (J-1)*(NDIG+3)
+ CALL FMEQ(M03,MJSUMS(KPT-1))
+ IF (M03(1) /= MUNKNO .AND. M03(2) /= 0) M03(-1) = -M03(-1)
+ ENDDO
+ IF (M02(1) < -NDIG) GO TO 120
+ CALL FMIPWR(M02,J2,MB)
+
+ 110 CALL FMMPY_R1(M03,MB)
+ LARGE = INT(INTMAX/NTERM)
+ DO J = 1, J2
+ NBOT = NTERM*(NTERM-1)
+ IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN
+ CALL FMDIVI_R1(M03,NTERM)
+ NBOT = NTERM - 1
+ CALL FMDIVI_R1(M03,NBOT)
+ ELSE
+ CALL FMDIVI_R1(M03,NBOT)
+ ENDIF
+ KPT = (J-1)*(NDSAV1+3)
+ NDIG = NDSAV1
+ CALL FMADD_R1(MJSUMS(KPT-1),M03)
+ IF (KFLAG /= 0) GO TO 120
+ NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1))
+ IF (NDIG < 2) NDIG = 2
+ IF (M03(1) /= MUNKNO .AND. M03(2) /= 0) M03(-1) = -M03(-1)
+ NTERM = NTERM + 2
+ ENDDO
+ GO TO 110
+
+! Next put the J2 separate sums back together.
+
+ 120 KFLAG = 0
+ KPT = (J2-1)*(NDIG+3)
+ CALL FMEQ(MJSUMS(KPT-1),MB)
+ IF (J2 >= 2) THEN
+ DO J = 2, J2
+ CALL FMMPY_R2(M02,MB)
+ KPT = (J2-J)*(NDIG+3)
+ CALL FMADD_R1(MB,MJSUMS(KPT-1))
+ ENDDO
+ ENDIF
+
+! Reverse the effect of reducing the argument to
+! compute COS(MA).
+
+ NDIG = NDSAV1
+ IF (K2 > 0) THEN
+ IF (NDSAVE <= 20) THEN
+ CALL FMI2M(2,M02)
+ DO J = 1, K2
+ CALL FMADD(MB,M02,M03)
+ CALL FMMPY_R2(MB,M03)
+ CALL FMADD(M03,M03,MB)
+ ENDDO
+ ELSE
+ DO J = 1, K2
+ CALL FMSQR(MB,M03)
+ CALL FMADD(MB,MB,M02)
+ CALL FMADD_R1(M03,M02)
+ CALL FMADD(M03,M03,MB)
+ ENDDO
+ ENDIF
+ ENDIF
+ CALL FMI2M(1,M03)
+ CALL FMADD_R2(M03,MB)
+
+ CALL FMEQ2_R1(MB,NDSAV1,NDSAVE)
+ NDIG = NDSAVE
+ KWARN = KWRNSV
+
+ RETURN
+ END SUBROUTINE FMCOS2
+
+ SUBROUTINE FMCOSH(MA,MB)
+
+! MB = COSH(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
+ INTEGER J,K,KASAVE,KOVUN,KRESLT,NDSAVE,NMETHD
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB) THEN
+ CALL FMENTR('FMCOSH',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMCOSH'
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ MACCA = MA(0)
+ CALL FMEQ2(MA,MB,NDSAVE,NDIG)
+ MB(0) = NINT(NDIG*ALOGM2)
+ MB(-1) = 1
+ IF (MA(2) == 0) THEN
+ CALL FMI2M(1,MB)
+ GO TO 120
+ ENDIF
+
+! Use a series for small arguments, FMEXP for large ones.
+
+ IF (MB(1) == MUNKNO) GO TO 120
+ IF (MBASE > 99) THEN
+ IF (MB(1) <= 0) THEN
+ NMETHD = 1
+ ELSE IF (MB(1) >= 2) THEN
+ NMETHD = 2
+ ELSE IF (ABS(MB(2)) < 10) THEN
+ NMETHD = 1
+ ELSE
+ NMETHD = 2
+ ENDIF
+ ELSE
+ IF (MB(1) <= 0) THEN
+ NMETHD = 1
+ ELSE
+ NMETHD = 2
+ ENDIF
+ ENDIF
+
+ IF (NMETHD == 2) GO TO 110
+ CALL FMCSH2(MB,M09)
+ CALL FMEQ(M09,MB)
+ GO TO 120
+
+ 110 CALL FMEXP(MB,M12)
+ CALL FMEQ(M12,MB)
+ IF (MB(1) == MEXPOV) THEN
+ GO TO 120
+ ELSE IF (MB(1) == MEXPUN) THEN
+ MB(1) = MEXPOV
+ GO TO 120
+ ENDIF
+ IF (INT(MB(1)) <= (NDIG+1)/2) THEN
+ CALL FMI2M(1,M01)
+ CALL FMDIV_R1(M01,MB)
+ CALL FMADD_R1(MB,M01)
+ ENDIF
+ CALL FMDIVI_R1(MB,2)
+
+! Round and return.
+
+ 120 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMCOSH
+
+ SUBROUTINE FMCSH2(MA,MB)
+
+! Internal subroutine for MB = COSH(MA).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent
+! sums. Increasing this value will begin to improve the
+! speed of COSH when the base is large and precision exceeds
+! about 1,500 decimal digits.
+
+ REAL (KIND(1.0D0)) :: MAXVAL
+ INTEGER J,J2,K,K2,KPT,KTWO,KWRNSV,L,L2,LARGE,N2,NBOT,NDSAV1, &
+ NDSAVE,NTERM
+ REAL ALOG2,ALOGT,B,T,TJ
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (MA(2) == 0) THEN
+ CALL FMI2M(1,MB)
+ RETURN
+ ENDIF
+ NDSAVE = NDIG
+ KWRNSV = KWARN
+ KWARN = 0
+
+! Use the direct series
+! COSH(X) = 1 + X**2/2! + X**4/4! - ...
+
+! The argument will be divided by 2**K2 before the series
+! is summed. The series will be added as J2 concurrent
+! series. The approximately optimal values of K2 and J2
+! are now computed to try to minimize the time required.
+! N2/2 is the approximate number of terms of the series
+! that will be needed, and L2 guard digits will be carried.
+
+! Since X is small when the series is summed, COSH(X) - 1
+! is computed. Then a version of the recovery formula can
+! be used that does not suffer from severe cancellation.
+
+ B = REAL(MBASE)
+ K = NGRD52
+ T = MAX(NDIG-K,2)
+ ALOG2 = LOG(2.0)
+ ALOGT = LOG(T)
+ TJ = 0.03*ALOGMB*T**0.3333 + 1.85
+ J2 = INT(TJ)
+ J2 = MAX(1,MIN(J2,LJSUMS/NDG2MX))
+ K2 = INT(0.5*SQRT(T*ALOGMB/TJ) + 2.8)
+
+ L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B + &
+ REAL(MA(3))/(B*B)))/ALOG2 - 0.3)
+ K2 = K2 - L
+ IF (L < 0) L = 0
+ IF (K2 < 0) THEN
+ K2 = 0
+ J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) + .33)
+ ENDIF
+ IF (J2 <= 1) J2 = 1
+
+ N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2))
+ L2 = INT(LOG(REAL(N2)+2.0**K2)/ALOGMB)
+ NDIG = NDIG + L2
+ IF (NDIG > NDG2MX) THEN
+ IF (NCALL == 1) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MB)
+ KWARN = KWRNSV
+ RETURN
+ ELSE
+ NDIG = NDG2MX
+ ENDIF
+ ENDIF
+ NDSAV1 = NDIG
+ CALL FMEQ2(MA,M02,NDSAVE,NDIG)
+
+! Divide the argument by 2**K2.
+
+ KTWO = 1
+ MAXVAL = MXBASE/2
+ IF (K2 > 0) THEN
+ DO J = 1, K2
+ KTWO = 2*KTWO
+ IF (KTWO > MAXVAL) THEN
+ CALL FMDIVI_R1(M02,KTWO)
+ KTWO = 1
+ ENDIF
+ ENDDO
+ IF (KTWO > 1) CALL FMDIVI_R1(M02,KTWO)
+ ENDIF
+
+! Split into J2 concurrent sums and reduce NDIG while
+! computing each term in the sum as the terms get smaller.
+
+ CALL FMSQR_R1(M02)
+ CALL FMEQ(M02,M03)
+ NTERM = 2
+ DO J = 1, J2
+ NBOT = NTERM*(NTERM-1)
+ CALL FMDIVI_R1(M03,NBOT)
+ NTERM = NTERM + 2
+ KPT = (J-1)*(NDIG+3)
+ CALL FMEQ(M03,MJSUMS(KPT-1))
+ ENDDO
+ IF (M02(1) < -NDIG) GO TO 120
+ CALL FMIPWR(M02,J2,MB)
+
+ 110 CALL FMMPY_R1(M03,MB)
+ LARGE = INT(INTMAX/NTERM)
+ DO J = 1, J2
+ NBOT = NTERM*(NTERM-1)
+ IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN
+ CALL FMDIVI_R1(M03,NTERM)
+ NBOT = NTERM - 1
+ CALL FMDIVI_R1(M03,NBOT)
+ ELSE
+ CALL FMDIVI_R1(M03,NBOT)
+ ENDIF
+ KPT = (J-1)*(NDSAV1+3)
+ NDIG = NDSAV1
+ CALL FMADD_R1(MJSUMS(KPT-1),M03)
+ IF (KFLAG /= 0) GO TO 120
+ NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1))
+ IF (NDIG < 2) NDIG = 2
+ NTERM = NTERM + 2
+ ENDDO
+ GO TO 110
+
+! Next put the J2 separate sums back together.
+
+ 120 KFLAG = 0
+ KPT = (J2-1)*(NDIG+3)
+ CALL FMEQ(MJSUMS(KPT-1),MB)
+ IF (J2 >= 2) THEN
+ DO J = 2, J2
+ CALL FMMPY_R2(M02,MB)
+ KPT = (J2-J)*(NDIG+3)
+ CALL FMADD_R1(MB,MJSUMS(KPT-1))
+ ENDDO
+ ENDIF
+
+! Reverse the effect of reducing the argument to
+! compute COSH(MA).
+
+ NDIG = NDSAV1
+ IF (K2 > 0) THEN
+ IF (NDSAVE <= 20) THEN
+ CALL FMI2M(2,M02)
+ DO J = 1, K2
+ CALL FMADD(MB,M02,M03)
+ CALL FMMPY_R2(MB,M03)
+ CALL FMADD(M03,M03,MB)
+ ENDDO
+ ELSE
+ DO J = 1, K2
+ CALL FMSQR(MB,M03)
+ CALL FMADD(MB,MB,M02)
+ CALL FMADD_R1(M03,M02)
+ CALL FMADD(M03,M03,MB)
+ ENDDO
+ ENDIF
+ ENDIF
+ CALL FMI2M(1,M03)
+ CALL FMADD_R2(M03,MB)
+
+ CALL FMEQ2_R1(MB,NDSAV1,NDSAVE)
+ NDIG = NDSAVE
+ KWARN = KWRNSV
+
+ RETURN
+ END SUBROUTINE FMCSH2
+
+ SUBROUTINE FMCSSN(MA,MB,MC)
+
+! MB = COS(MA), MC = SIN(MA)
+
+! If both the sine and cosine are needed, this routine is faster
+! than calling both FMCOS and FMSIN.
+
+! MB and MC must be distinct arrays.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
+ INTEGER J,JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,KWRNSV,NCSAVE, &
+ NDSAVE,NDSV
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ MACCA = MA(0)
+ MAS = MA(-1)
+ IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN
+ NCSAVE = NCALL
+ CALL FMENTR('FMCSSN',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (MA(1) == MUNKNO) KOVUN = 2
+ NCALL = NCSAVE + 1
+ CALL FMEQ2(MA,M05,NDSAVE,NDIG)
+ M05(0) = NINT(NDIG*ALOGM2)
+ M05(-1) = 1
+ CALL FMCOS(M05,MB)
+ CALL FMSIN(M05,MC)
+ GO TO 110
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMCSSN'
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ CALL FMEQ(MA,M05)
+ CALL FMCOS(M05,MB)
+ CALL FMSIN(M05,MC)
+ KFLAG = -9
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ IF (MA(2) == 0) THEN
+ CALL FMI2M(1,MB)
+ CALL FMI2M(0,MC)
+ GO TO 110
+ ENDIF
+
+ CALL FMEQ2(MA,MB,NDSAVE,NDIG)
+ MB(0) = NINT(NDIG*ALOGM2)
+ MB(-1) = 1
+ CALL FMEQ(MB,MWE)
+
+! Reduce the argument, convert to radians if the input is
+! in degrees, and evaluate the functions.
+
+ CALL FMRDC(MB,JSIN,JCOS,JSWAP)
+ IF (MB(1) == MUNKNO) THEN
+ CALL FMCOS(MWE,MB)
+ CALL FMSIN(MWE,MC)
+ GO TO 110
+ ENDIF
+ IF (KRAD == 0) THEN
+ IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDIG+2,NDG2MX)
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'NOEQ '
+ CALL FMPI(MPISAV)
+ NCALL = NCALL - 1
+ NDIG = NDSV
+ ENDIF
+ CALL FMMPY_R1(MB,MPISAV)
+ CALL FMDIVI_R1(MB,180)
+ ENDIF
+ IF (MB(1) /= MUNKNO) THEN
+ IF (JSWAP == 0) THEN
+ IF (MB(1) < 0) THEN
+ CALL FMSIN2(MB,MC)
+ MC(-1) = JSIN*MC(-1)
+ CALL FMSQR(MC,M03)
+ CALL FMI2M(1,M02)
+ CALL FMSUB_R2(M02,M03)
+ CALL FMSQRT(M03,MB)
+ MB(-1) = JCOS*MB(-1)
+ ELSE
+ CALL FMCOS2(MB,M09)
+ CALL FMEQ(M09,MB)
+ MB(-1) = JCOS*MB(-1)
+ CALL FMSQR(MB,M03)
+ CALL FMI2M(1,M02)
+ CALL FMSUB_R2(M02,M03)
+ CALL FMSQRT(M03,MC)
+ MC(-1) = JSIN*MC(-1)
+ ENDIF
+ ELSE
+ IF (MB(1) < 0) THEN
+ CALL FMSIN2(MB,M09)
+ CALL FMEQ(M09,MB)
+ MB(-1) = JCOS*MB(-1)
+ CALL FMSQR(MB,M03)
+ CALL FMI2M(1,M02)
+ CALL FMSUB_R2(M02,M03)
+ CALL FMSQRT(M03,MC)
+ MC(-1) = JSIN*MC(-1)
+ ELSE
+ CALL FMCOS2(MB,MC)
+ MC(-1) = JSIN*MC(-1)
+ CALL FMSQR(MC,M03)
+ CALL FMI2M(1,M02)
+ CALL FMSUB_R2(M02,M03)
+ CALL FMSQRT(M03,MB)
+ MB(-1) = JCOS*MB(-1)
+ ENDIF
+ ENDIF
+ ELSE
+ CALL FMEQ(MB,MC)
+ ENDIF
+
+! Round and return.
+
+ 110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)
+ MC(0) = MIN(MC(0),MACCA,MACMAX)
+ IF (MAS < 0 .AND. MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
+ CALL FMEQ2_R1(MC,NDIG,NDSAVE)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ IF (KOVUN == 2) THEN
+ KWRNSV = KWARN
+ KWARN = 0
+ ENDIF
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ IF (KOVUN == 2) THEN
+ KWARN = KWRNSV
+ ENDIF
+ IF (NTRACE /= 0) THEN
+ IF (ABS(NTRACE) >= 1 .AND. NCALL+1 <= LVLTRC) THEN
+ IF (NTRACE < 0) THEN
+ CALL FMNTRJ(MC,NDIG)
+ ELSE
+ CALL FMPRNT(MC)
+ ENDIF
+ ENDIF
+ ENDIF
+ RETURN
+ END SUBROUTINE FMCSSN
+
+ SUBROUTINE FMDBL(A,B,C)
+
+! C = A + B. All are double precision. This routine tries to
+! force the compiler to round C to double precision accuracy.
+! Some compilers allow double precision loops like the ones in
+! FMSET and FMDM to be done in extended precision, which defeats
+! the routine's attempt to determine double precision accuracy.
+! This can lead to doing too few Newton steps and failing to
+! get sufficient accuracy in several FM routines.
+
+ USE FMVALS
+ IMPLICIT NONE
+ DOUBLE PRECISION A,B,C
+ C = A + B
+ RETURN
+ END SUBROUTINE FMDBL
+
+ SUBROUTINE FMDIG(NSTACK,KST)
+
+! Compute the number of intermediate digits to be used in Newton
+! iteration. This assumes that a starting approximation that is
+! accurate to double precision is used, and the root is simple.
+
+! KST is the number of iterations needed for final accuracy NDIG.
+! NSTACK(J) holds the value of NDIG to be used for the
+! Jth iteration.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER NSTACK(19),KST
+
+ DOUBLE PRECISION Y
+ INTEGER J,JT,L,ND,NDT,NE
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+
+! NE is the maximum number of base MBASE digits that
+! can be used in the first Newton iteration.
+
+ NE = INT(1.9D0*DLOGEB)
+
+! Fill the intermediate digit stack (backwards).
+
+ KST = 1
+ ND = NDIG
+ NSTACK(1) = ND
+ IF (ND < NE .OR. ND <= 2) RETURN
+
+ 110 Y = ND
+
+! The 1.9 accounts for the fact that the number of correct
+! digits approximately doubles at each iteration.
+
+ NDT = INT(Y/1.9D0)
+ IF (2*NDT <= ND) NDT = NDT + 1
+ ND = NDT
+ KST = KST + 1
+ NSTACK(KST) = ND
+ IF (ND > NE .AND. ND > 2) GO TO 110
+
+! Reverse the stack.
+
+ L = KST/2
+ DO J = 1, L
+ JT = NSTACK(J)
+ NSTACK(J) = NSTACK(KST+1-J)
+ NSTACK(KST+1-J) = JT
+ ENDDO
+
+ RETURN
+ END SUBROUTINE FMDIG
+
+ SUBROUTINE FMDIM(MA,MB,MC)
+
+! MC = DIM(MA,MB)
+
+! Positive difference. MC = MA - MB if MA >= MB,
+! = 0 otherwise.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MXSAVE
+ INTEGER J,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE
+ LOGICAL FMCOMP
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB) THEN
+ CALL FMENTR('FMDIM ',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMDIM '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MB,MC,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+ KWRNSV = KWARN
+ KWARN = 0
+ MXEXP = MXSAVE
+
+ MACCA = MA(0)
+ MACCB = MB(0)
+ CALL FMEQ2(MA,M01,NDSAVE,NDIG)
+ M01(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ2(MB,M02,NDSAVE,NDIG)
+ M02(0) = NINT(NDIG*ALOGM2)
+
+ IF (FMCOMP(M01,'LT',M02)) THEN
+ CALL FMI2M(0,MC)
+ ELSE
+ CALL FMSUB(M01,M02,MC)
+ ENDIF
+
+ IF (KFLAG == 1) KFLAG = 0
+ KWARN = KWRNSV
+ MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)
+ MC(0) = MIN(MC(0),MACCA,MACCB,MACMAX)
+ DO J = -1, NDIG+1
+ M01(J) = MC(J)
+ ENDDO
+ CALL FMEXIT(M01,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMDIM
+
+ SUBROUTINE FMDIV(MA,MB,MC)
+
+! MC = MA / MB
+
+! This routine performs the trace printing for division.
+! FMDIV2 is used to do the arithmetic.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMDIV '
+ CALL FMNTR(2,MA,MB,2,1)
+
+ CALL FMDIV2(MA,MB,MC)
+
+ CALL FMNTR(1,MC,MC,1,1)
+ ELSE
+ CALL FMDIV2(MA,MB,MC)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMDIV
+
+ SUBROUTINE FMDIV2(MA,MB,MC)
+
+! Internal division routine. MC = MA / MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MLR,MR,MS,MT1,MT2
+ INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KT3,L,N1,NG,NGUARD,NL
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JRSSAV = JRSIGN
+ MACCA = MA(0)
+ MACCB = MB(0)
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. &
+ KDEBUG == 1) THEN
+ CALL FMARGS('FMDIV ',2,MA,MB,KRESLT)
+ IF (KRESLT /= 0) THEN
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMDIV '
+ CALL FMRSLT(MA,MB,MC,KRESLT)
+ JRSIGN = JRSSAV
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ELSE
+ IF (MB(2) == 0) THEN
+ NAMEST(NCALL) = 'FMDIV '
+ CALL FMIM(0,MC)
+ KFLAG = -4
+ CALL FMWARN
+ MC(1) = MUNKNO
+ MC(2) = 1
+ MC(0) = NINT(NDIG*ALOGM2)
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+ IF (MA(2) == 0) THEN
+ CALL FMIM(0,MC)
+ MC(0) = MIN(MACCA,MACCB)
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+ ENDIF
+ KFLAG = 0
+
+! NGUARD is the number of guard digits used.
+
+ IF (NCALL > 1) THEN
+ NGUARD = NGRD21
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ ELSE
+ NGUARD = NGRD52 - 1
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 10
+ ENDIF
+ ENDIF
+ N1 = NDIG + 1
+ NG = NDIG + NGUARD
+
+! Save the sign of MA and MB and then work only with
+! positive numbers.
+
+ MAS = MA(-1)
+ MBS = MB(-1)
+ IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ MWA(1) = MA(1) - MB(1) + 1
+
+ IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
+ IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN
+ MBASEL = MBASE
+ NDIGL = NDIG
+ NGUARL = NGUARD
+ DO J = 2, 1000
+ MR = MBASE*MBASEL
+ IF (4*MR > MXBASE) THEN
+ N21 = J - 1
+ NDIG = (NDIGL-1)/N21 + 1
+ IF (NDIG < 2) NDIG = 2
+ NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG
+ IF (NGRDN < 1) NGRDN = 1
+ EXIT
+ ENDIF
+ MBASE = MR
+ ENDDO
+ MBASEN = MBASE
+ NDIGN = NDIG
+ ELSE
+ MBASE = MBASEN
+ NDIG = NDIGN
+ ENDIF
+ MPMA(1) = 0
+ MPMB(1) = 0
+ L = 2 - N21
+ DO J = 2, NDIGL+2-N21, N21
+ MT1 = MA(J)
+ MT2 = MB(J)
+ DO K = J+1, J+N21-1
+ MT1 = MT1*MBASEL + MA(K)
+ MT2 = MT2*MBASEL + MB(K)
+ ENDDO
+ MPMA(2+J/N21) = MT1
+ MPMB(2+J/N21) = MT2
+ L = J
+ ENDDO
+ DO J = 3+L/N21, NDIG+NGRDN+2
+ MPMA(J) = 0
+ MPMB(J) = 0
+ ENDDO
+ IF (L+N21 <= NDIGL+1) THEN
+ MT1 = 0
+ MT2 = 0
+ DO J = L+N21, L+2*N21-1
+ IF (J <= NDIGL+1) THEN
+ MT1 = MT1*MBASEL + MA(J)
+ MT2 = MT2*MBASEL + MB(J)
+ ELSE
+ MT1 = MT1*MBASEL
+ MT2 = MT2*MBASEL
+ ENDIF
+ ENDDO
+ MPMA(2+(L+N21)/N21) = MT1
+ MPMB(2+(L+N21)/N21) = MT2
+ ENDIF
+ NG = NDIG + NGRDN + 1
+ IF (MPMA(2) >= MPMB(2)) NG = NG + 1
+
+! Copy MA into the working array.
+
+ DO J = 2, NDIG+1
+ MWA(J+1) = MPMA(J)
+ ENDDO
+ MWA(2) = 0
+ DO J = NDIG+3, NG+4
+ MWA(J) = 0
+ ENDDO
+ CALL FMDIV3(MPMB,NG)
+ KT3 = N21 - 1
+ IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN
+ DO J = 2+NDIG+NGRDN, 3, -1
+ KT1 = MWA(J)
+ KT = 2 + (J-2)*N21
+ KT2 = N21 + KT - 1
+ DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3)
+ MWA(K-KT3) = IBITS(KT1,KT2-K,1)
+ ENDDO
+ ENDDO
+ ELSE
+ MS = MBASEL**(N21-1)
+ DO J = 2+NDIG+NGRDN, 3, -1
+ MR = MS
+ MT1 = MWA(J)
+ DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3)
+ MWA(K-KT3) = AINT (MT1/MR)
+ MT1 = MT1 - MWA(K-KT3)*MR
+ MR = AINT (MR/MBASEL)
+ ENDDO
+ ENDDO
+ ENDIF
+ NDIG = NDIGL
+ MBASE = MBASEL
+ ELSE
+
+! Copy MA into the working array.
+
+ DO J = 2, N1
+ MWA(J+1) = MA(J)
+ ENDDO
+ MWA(2) = 0
+ NL = N1 + NGUARD + 3
+ DO J = NDIG+3, NL
+ MWA(J) = 0
+ ENDDO
+ CALL FMDIV3(MB,NG)
+ ENDIF
+
+! Round, affix the sign, and return.
+
+ IF (MWA(2) == 0) THEN
+ MLR = 2*MWA(NDIG+3) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,1)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1+1) = MWA(N1+1) + 1
+ MWA(N1+2) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,1)
+ ENDIF
+ ENDIF
+ ELSE
+ MLR = 2*MWA(NDIG+2) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,0)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1) = MWA(N1) + 1
+ MWA(N1+1) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,0)
+ ENDIF
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWA,MC)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMDIV '
+ CALL FMWARN
+ ENDIF
+
+ MC(-1) = 1
+ IF (MAS*MBS < 0 .AND. MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1
+
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)
+ MC(0) = MIN(MACCA,MACCB,MD2B)
+ ELSE
+ MC(0) = MIN(MACCA,MACCB)
+ ENDIF
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMDIV2
+
+ SUBROUTINE FMDIV_R1(MA,MB)
+
+! MA = MA / MB
+
+! This routine performs the trace printing for division.
+! FMDIV2_R1 is used to do the arithmetic.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMDIV '
+ CALL FMNTR(2,MA,MB,2,1)
+
+ CALL FMDIV2_R1(MA,MB)
+
+ CALL FMNTR(1,MA,MA,1,1)
+ ELSE
+ CALL FMDIV2_R1(MA,MB)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMDIV_R1
+
+ SUBROUTINE FMDIV2_R1(MA,MB)
+
+! Internal division routine. MA = MA / MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MLR,MR,MS,MT1,MT2
+ INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KT3,L,N1,NG,NGUARD,NL
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JRSSAV = JRSIGN
+ MACCA = MA(0)
+ MACCB = MB(0)
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. &
+ KDEBUG == 1) THEN
+ CALL FMARGS('FMDIV ',2,MA,MB,KRESLT)
+ IF (KRESLT /= 0) THEN
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMDIV '
+ CALL FMRSLT(MA,MB,M07,KRESLT)
+ CALL FMEQ(M07,MA)
+ JRSIGN = JRSSAV
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ELSE
+ IF (MB(2) == 0) THEN
+ NAMEST(NCALL) = 'FMDIV '
+ CALL FMIM(0,MA)
+ KFLAG = -4
+ CALL FMWARN
+ MA(1) = MUNKNO
+ MA(2) = 1
+ MA(0) = NINT(NDIG*ALOGM2)
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+ IF (MA(2) == 0) THEN
+ CALL FMIM(0,MA)
+ MA(0) = MIN(MACCA,MACCB)
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+ ENDIF
+ KFLAG = 0
+
+! NGUARD is the number of guard digits used.
+
+ IF (NCALL > 1) THEN
+ NGUARD = NGRD21
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ ELSE
+ NGUARD = NGRD52 - 1
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 10
+ ENDIF
+ ENDIF
+ N1 = NDIG + 1
+ NG = NDIG + NGUARD
+
+! Save the sign of MA and MB and then work only with
+! positive numbers.
+
+ MAS = MA(-1)
+ MBS = MB(-1)
+ IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ MWA(1) = MA(1) - MB(1) + 1
+
+ IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
+ IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN
+ MBASEL = MBASE
+ NDIGL = NDIG
+ NGUARL = NGUARD
+ DO J = 2, 1000
+ MR = MBASE*MBASEL
+ IF (4*MR > MXBASE) THEN
+ N21 = J - 1
+ NDIG = (NDIGL-1)/N21 + 1
+ IF (NDIG < 2) NDIG = 2
+ NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG
+ IF (NGRDN < 1) NGRDN = 1
+ EXIT
+ ENDIF
+ MBASE = MR
+ ENDDO
+ MBASEN = MBASE
+ NDIGN = NDIG
+ ELSE
+ MBASE = MBASEN
+ NDIG = NDIGN
+ ENDIF
+ MPMA(1) = 0
+ MPMB(1) = 0
+ L = 2 - N21
+ DO J = 2, NDIGL+2-N21, N21
+ MT1 = MA(J)
+ MT2 = MB(J)
+ DO K = J+1, J+N21-1
+ MT1 = MT1*MBASEL + MA(K)
+ MT2 = MT2*MBASEL + MB(K)
+ ENDDO
+ MPMA(2+J/N21) = MT1
+ MPMB(2+J/N21) = MT2
+ L = J
+ ENDDO
+ DO J = 3+L/N21, NDIG+NGRDN+2
+ MPMA(J) = 0
+ MPMB(J) = 0
+ ENDDO
+ IF (L+N21 <= NDIGL+1) THEN
+ MT1 = 0
+ MT2 = 0
+ DO J = L+N21, L+2*N21-1
+ IF (J <= NDIGL+1) THEN
+ MT1 = MT1*MBASEL + MA(J)
+ MT2 = MT2*MBASEL + MB(J)
+ ELSE
+ MT1 = MT1*MBASEL
+ MT2 = MT2*MBASEL
+ ENDIF
+ ENDDO
+ MPMA(2+(L+N21)/N21) = MT1
+ MPMB(2+(L+N21)/N21) = MT2
+ ENDIF
+ NG = NDIG + NGRDN + 1
+ IF (MPMA(2) >= MPMB(2)) NG = NG + 1
+
+! Copy MA into the working array.
+
+ DO J = 2, NDIG+1
+ MWA(J+1) = MPMA(J)
+ ENDDO
+ MWA(2) = 0
+ DO J = NDIG+3, NG+4
+ MWA(J) = 0
+ ENDDO
+ CALL FMDIV3(MPMB,NG)
+ KT3 = N21 - 1
+ IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN
+ DO J = 2+NDIG+NGRDN, 3, -1
+ KT1 = MWA(J)
+ KT = 2 + (J-2)*N21
+ KT2 = N21 + KT - 1
+ DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3)
+ MWA(K-KT3) = IBITS(KT1,KT2-K,1)
+ ENDDO
+ ENDDO
+ ELSE
+ MS = MBASEL**(N21-1)
+ DO J = 2+NDIG+NGRDN, 3, -1
+ MR = MS
+ MT1 = MWA(J)
+ DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3)
+ MWA(K-KT3) = AINT (MT1/MR)
+ MT1 = MT1 - MWA(K-KT3)*MR
+ MR = AINT (MR/MBASEL)
+ ENDDO
+ ENDDO
+ ENDIF
+ NDIG = NDIGL
+ MBASE = MBASEL
+ ELSE
+
+! Copy MA into the working array.
+
+ DO J = 2, N1
+ MWA(J+1) = MA(J)
+ ENDDO
+ MWA(2) = 0
+ NL = N1 + NGUARD + 3
+ DO J = NDIG+3, NL
+ MWA(J) = 0
+ ENDDO
+ CALL FMDIV3(MB,NG)
+ ENDIF
+
+! Round, affix the sign, and return.
+
+ IF (MWA(2) == 0) THEN
+ MLR = 2*MWA(NDIG+3) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,1)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1+1) = MWA(N1+1) + 1
+ MWA(N1+2) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,1)
+ ENDIF
+ ENDIF
+ ELSE
+ MLR = 2*MWA(NDIG+2) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,0)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1) = MWA(N1) + 1
+ MWA(N1+1) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,0)
+ ENDIF
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWA,MA)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMDIV '
+ CALL FMWARN
+ ENDIF
+
+ MA(-1) = 1
+ IF (MAS*MBS < 0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1
+
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315)
+ MA(0) = MIN(MACCA,MACCB,MD2B)
+ ELSE
+ MA(0) = MIN(MACCA,MACCB)
+ ENDIF
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMDIV2_R1
+
+ SUBROUTINE FMDIV_R2(MA,MB)
+
+! MB = MA / MB
+
+! This routine performs the trace printing for division.
+! FMDIV2_R2 is used to do the arithmetic.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMDIV '
+ CALL FMNTR(2,MA,MB,2,1)
+
+ CALL FMDIV2_R2(MA,MB)
+
+ CALL FMNTR(1,MB,MB,1,1)
+ ELSE
+ CALL FMDIV2_R2(MA,MB)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMDIV_R2
+
+ SUBROUTINE FMDIV2_R2(MA,MB)
+
+! Internal division routine. MB = MA / MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MLR,MR,MS,MT1,MT2
+ INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KT3,L,N1,NG,NGUARD,NL
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JRSSAV = JRSIGN
+ MACCA = MA(0)
+ MACCB = MB(0)
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. &
+ KDEBUG == 1) THEN
+ CALL FMARGS('FMDIV ',2,MA,MB,KRESLT)
+ IF (KRESLT /= 0) THEN
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMDIV '
+ CALL FMRSLT(MA,MB,M07,KRESLT)
+ CALL FMEQ(M07,MB)
+ JRSIGN = JRSSAV
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ELSE
+ IF (MB(2) == 0) THEN
+ NAMEST(NCALL) = 'FMDIV '
+ CALL FMIM(0,MB)
+ KFLAG = -4
+ CALL FMWARN
+ MB(1) = MUNKNO
+ MB(2) = 1
+ MB(0) = NINT(NDIG*ALOGM2)
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+ IF (MA(2) == 0) THEN
+ CALL FMIM(0,MB)
+ MB(0) = MIN(MACCA,MACCB)
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+ ENDIF
+ KFLAG = 0
+
+! NGUARD is the number of guard digits used.
+
+ IF (NCALL > 1) THEN
+ NGUARD = NGRD21
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ ELSE
+ NGUARD = NGRD52 - 1
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 10
+ ENDIF
+ ENDIF
+ N1 = NDIG + 1
+ NG = NDIG + NGUARD
+
+! Save the sign of MA and MB and then work only with
+! positive numbers.
+
+ MAS = MA(-1)
+ MBS = MB(-1)
+ IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ MWA(1) = MA(1) - MB(1) + 1
+
+ IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
+ IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN
+ MBASEL = MBASE
+ NDIGL = NDIG
+ NGUARL = NGUARD
+ DO J = 2, 1000
+ MR = MBASE*MBASEL
+ IF (4*MR > MXBASE) THEN
+ N21 = J - 1
+ NDIG = (NDIGL-1)/N21 + 1
+ IF (NDIG < 2) NDIG = 2
+ NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG
+ IF (NGRDN < 1) NGRDN = 1
+ EXIT
+ ENDIF
+ MBASE = MR
+ ENDDO
+ MBASEN = MBASE
+ NDIGN = NDIG
+ ELSE
+ MBASE = MBASEN
+ NDIG = NDIGN
+ ENDIF
+ MPMA(1) = 0
+ MPMB(1) = 0
+ L = 2 - N21
+ DO J = 2, NDIGL+2-N21, N21
+ MT1 = MA(J)
+ MT2 = MB(J)
+ DO K = J+1, J+N21-1
+ MT1 = MT1*MBASEL + MA(K)
+ MT2 = MT2*MBASEL + MB(K)
+ ENDDO
+ MPMA(2+J/N21) = MT1
+ MPMB(2+J/N21) = MT2
+ L = J
+ ENDDO
+ DO J = 3+L/N21, NDIG+NGRDN+2
+ MPMA(J) = 0
+ MPMB(J) = 0
+ ENDDO
+ IF (L+N21 <= NDIGL+1) THEN
+ MT1 = 0
+ MT2 = 0
+ DO J = L+N21, L+2*N21-1
+ IF (J <= NDIGL+1) THEN
+ MT1 = MT1*MBASEL + MA(J)
+ MT2 = MT2*MBASEL + MB(J)
+ ELSE
+ MT1 = MT1*MBASEL
+ MT2 = MT2*MBASEL
+ ENDIF
+ ENDDO
+ MPMA(2+(L+N21)/N21) = MT1
+ MPMB(2+(L+N21)/N21) = MT2
+ ENDIF
+ NG = NDIG + NGRDN + 1
+ IF (MPMA(2) >= MPMB(2)) NG = NG + 1
+
+! Copy MA into the working array.
+
+ DO J = 2, NDIG+1
+ MWA(J+1) = MPMA(J)
+ ENDDO
+ MWA(2) = 0
+ DO J = NDIG+3, NG+4
+ MWA(J) = 0
+ ENDDO
+ CALL FMDIV3(MPMB,NG)
+ KT3 = N21 - 1
+ IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN
+ DO J = 2+NDIG+NGRDN, 3, -1
+ KT1 = MWA(J)
+ KT = 2 + (J-2)*N21
+ KT2 = N21 + KT - 1
+ DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3)
+ MWA(K-KT3) = IBITS(KT1,KT2-K,1)
+ ENDDO
+ ENDDO
+ ELSE
+ MS = MBASEL**(N21-1)
+ DO J = 2+NDIG+NGRDN, 3, -1
+ MR = MS
+ MT1 = MWA(J)
+ DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2+KT3)
+ MWA(K-KT3) = AINT (MT1/MR)
+ MT1 = MT1 - MWA(K-KT3)*MR
+ MR = AINT (MR/MBASEL)
+ ENDDO
+ ENDDO
+ ENDIF
+ NDIG = NDIGL
+ MBASE = MBASEL
+ ELSE
+
+! Copy MA into the working array.
+
+ DO J = 2, N1
+ MWA(J+1) = MA(J)
+ ENDDO
+ MWA(2) = 0
+ NL = N1 + NGUARD + 3
+ DO J = NDIG+3, NL
+ MWA(J) = 0
+ ENDDO
+ CALL FMDIV3(MB,NG)
+ ENDIF
+
+! Round, affix the sign, and return.
+
+ IF (MWA(2) == 0) THEN
+ MLR = 2*MWA(NDIG+3) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,1)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1+1) = MWA(N1+1) + 1
+ MWA(N1+2) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,1)
+ ENDIF
+ ENDIF
+ ELSE
+ MLR = 2*MWA(NDIG+2) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,0)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1) = MWA(N1) + 1
+ MWA(N1+1) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,0)
+ ENDIF
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWA,MB)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMDIV '
+ CALL FMWARN
+ ENDIF
+
+ MB(-1) = 1
+ IF (MAS*MBS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1
+
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MACCA,MACCB,MD2B)
+ ELSE
+ MB(0) = MIN(MACCA,MACCB)
+ ENDIF
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMDIV2_R2
+
+ SUBROUTINE FMDIV3(MB,NG)
+
+! Internal division routine. Divide MA/MB and return the
+! quotient in MWA.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MB(-1:LUNPCK)
+
+ DOUBLE PRECISION XB,XBR,XBASE,XMWA
+ REAL (KIND(1.0D0)) :: MAXMWA,MBM1,MCARRY,MKT,MLMAX,MQD
+ INTEGER J,JB,JL,KA,KB,KL,KPTMWA,N1,NG,NL,NMBWDS,NZDMB
+ N1 = NDIG + 1
+ NL = NG + 4
+
+! NMBWDS is the number of words of MB used to
+! compute the estimated quotient digit MQD.
+
+ NMBWDS = 4
+ IF (MBASE < 100) NMBWDS = 7
+
+! XB is an approximation of MB used in
+! estimating the quotient digits.
+
+ XBASE = DBLE(MBASE)
+ XB = 0
+ JL = NMBWDS
+ IF (JL <= N1) THEN
+ DO J = 2, JL
+ XB = XB*XBASE + DBLE(MB(J))
+ ENDDO
+ ELSE
+ DO J = 2, JL
+ IF (J <= N1) THEN
+ XB = XB*XBASE + DBLE(MB(J))
+ ELSE
+ XB = XB*XBASE
+ ENDIF
+ ENDDO
+ ENDIF
+ IF (JL+1 <= N1) THEN
+ XB = XB + DBLE(MB(JL+1))/XBASE
+ ENDIF
+ XBR = 1.0D0/XB
+
+! MLMAX determines when to normalize all of MWA.
+
+ MBM1 = MBASE - 1
+ MLMAX = MAXINT/MBM1
+ MKT = INTMAX - MBASE
+ MLMAX = MIN(MLMAX,MKT)
+
+! Count the trailing zero digits of MB.
+
+ DO J = N1, 2, -1
+ IF (MB(J) /= 0) THEN
+ NZDMB = N1 - J
+ GO TO 110
+ ENDIF
+ ENDDO
+
+! MAXMWA is an upper bound on the size of values in MWA
+! divided by MBASE-1. It is used to determine whether
+! normalization can be postponed.
+
+ 110 MAXMWA = 0
+
+! KPTMWA points to the next digit in the quotient.
+
+ KPTMWA = 2
+
+! This is the start of the division loop.
+
+! XMWA is an approximation of the active part of MWA
+! used in estimating quotient digits.
+
+ 120 KL = KPTMWA + NMBWDS - 1
+ IF (KL <= NL) THEN
+ XMWA = ((DBLE(MWA(KPTMWA))*XBASE &
+ + DBLE(MWA(KPTMWA+1)))*XBASE &
+ + DBLE(MWA(KPTMWA+2)))*XBASE &
+ + DBLE(MWA(KPTMWA+3))
+ DO J = KPTMWA+4, KL
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ ENDDO
+ ELSE
+ XMWA = DBLE(MWA(KPTMWA))
+ DO J = KPTMWA+1, KL
+ IF (J <= NL) THEN
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ ELSE
+ XMWA = XMWA*XBASE
+ ENDIF
+ ENDDO
+ ENDIF
+
+! MQD is the estimated quotient digit.
+
+ MQD = AINT(XMWA*XBR)
+ IF (MQD < 0) MQD = MQD - 1
+
+ IF (MQD > 0) THEN
+ MAXMWA = MAXMWA + MQD
+ ELSE
+ MAXMWA = MAXMWA - MQD
+ ENDIF
+
+! See if MWA must be normalized.
+
+ KA = KPTMWA + 1
+ KB = MIN(KA+NDIG-1-NZDMB,NL)
+ IF (MAXMWA >= MLMAX) THEN
+ DO J = KB, KA, -1
+ IF (MWA(J) < 0) THEN
+ MCARRY = INT((-MWA(J)-1)/MBASE) + 1
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ELSE IF (MWA(J) >= MBASE) THEN
+ MCARRY = -INT(MWA(J)/MBASE)
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ENDIF
+ ENDDO
+ XMWA = 0
+ IF (KL <= NL) THEN
+ DO J = KPTMWA, KL
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ ENDDO
+ ELSE
+ DO J = KPTMWA, KL
+ IF (J <= NL) THEN
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ ELSE
+ XMWA = XMWA*XBASE
+ ENDIF
+ ENDDO
+ ENDIF
+ MQD = AINT(XMWA*XBR)
+ IF (MQD < 0) MQD = MQD - 1
+ IF (MQD > 0) THEN
+ MAXMWA = MQD
+ ELSE
+ MAXMWA = -MQD
+ ENDIF
+ ENDIF
+
+! Subtract MQD*MB from MWA.
+
+ JB = KA - 2
+ IF (MQD /= 0) THEN
+
+! Major (Inner Loop)
+
+ DO J = KA, KB
+ MWA(J) = MWA(J) - MQD*MB(J-JB)
+ ENDDO
+ ENDIF
+
+ MWA(KA) = MWA(KA) + MWA(KA-1)*MBASE
+ MWA(KPTMWA) = MQD
+
+ KPTMWA = KPTMWA + 1
+ IF (KPTMWA <= NG) GO TO 120
+ IF (MWA(2) == 0 .AND. KPTMWA <= NG+1) GO TO 120
+
+ KL = KPTMWA + NMBWDS - 1
+ IF (KL <= NL) THEN
+ XMWA = ((DBLE(MWA(KPTMWA))*XBASE &
+ + DBLE(MWA(KPTMWA+1)))*XBASE &
+ + DBLE(MWA(KPTMWA+2)))*XBASE &
+ + DBLE(MWA(KPTMWA+3))
+ DO J = KPTMWA+4, KL
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ ENDDO
+ ELSE
+ XMWA = DBLE(MWA(KPTMWA))
+ DO J = KPTMWA+1, KL
+ IF (J <= NL) THEN
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ ELSE
+ XMWA = XMWA*XBASE
+ ENDIF
+ ENDDO
+ ENDIF
+ MQD = AINT(XMWA*XBR)
+ IF (MQD < 0) MQD = MQD - 1
+ MWA(KPTMWA) = MQD
+ MWA(KPTMWA+1) = 0
+ MWA(KPTMWA+2) = 0
+
+! Final normalization.
+
+ DO J = KPTMWA, 3, -1
+ IF (MWA(J) < 0) THEN
+ MCARRY = INT((-MWA(J)-1)/MBASE) + 1
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ELSE IF (MWA(J) >= MBASE) THEN
+ MCARRY = -INT(MWA(J)/MBASE)
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ENDIF
+ ENDDO
+
+ RETURN
+ END SUBROUTINE FMDIV3
+
+ SUBROUTINE FMDIVD(MA,MB,MC,MD,ME)
+
+! Double division routine. MD = MA / MC, ME = MB / MC
+
+! It is usually slightly faster to do two divisions that
+! have a common denominator with one call.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK), &
+ MD(-1:LUNPCK),ME(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MA2P,MACCA,MACCB,MACCC,MAS,MAXMWA,MB2P,MBS, &
+ MBM1,MC2P,MCARRY,MCS,MD2B,MKT,MLMAX,MLR, &
+ MQDMWA,MQDMWD,MTEMP
+ DOUBLE PRECISION XB,XBR,XBASE,XMWA,XMWD
+ INTEGER J,JB,JL,JRSSAV,KA,KB,KL,KOVUN,KPTMW,N1,NG,NGUARD,NL, &
+ NMBWDS,NZDMB
+
+ NCALL = NCALL + 1
+ JRSSAV = JRSIGN
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMDIVD'
+ CALL FMNTR(2,MA,MB,2,1)
+ IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
+ IF (NTRACE < 0) THEN
+ CALL FMNTRJ(MC,NDIG)
+ ELSE
+ CALL FMPRNT(MC)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ MACCA = MA(0)
+ MACCB = MB(0)
+ MACCC = MC(0)
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. &
+ ABS(MC(1)) > MEXPAB .OR. MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN .OR. &
+ MB(1) == MEXPOV .OR. MB(1) == MEXPUN .OR. &
+ MC(1) == MEXPOV .OR. MC(1) == MEXPUN) KOVUN = 1
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR. &
+ MC(1) == MUNKNO) KOVUN = 2
+ NCALL = NCALL + 1
+ CALL FMDIV2(MA,MC,MWD)
+ KB = KFLAG
+ CALL FMDIV2(MB,MC,ME)
+ NCALL = NCALL - 1
+ IF (((KFLAG < 0 .OR. KB < 0) .AND. KOVUN == 0) .OR. &
+ ((KFLAG == -4 .OR. KB == -4) .AND. KOVUN == 1)) THEN
+ IF (KFLAG == -4 .OR. KB == -4) THEN
+ KFLAG = -4
+ ELSE IF (KFLAG == -5 .OR. KB == -5) THEN
+ KFLAG = -5
+ ELSE
+ KFLAG = MIN(KFLAG,KB)
+ ENDIF
+ NAMEST(NCALL) = 'FMDIVD'
+ CALL FMWARN
+ ENDIF
+ CALL FMEQ(MWD,MD)
+ GO TO 130
+ ENDIF
+ IF (MC(2) == 0) THEN
+ NAMEST(NCALL) = 'FMDIVD'
+ KFLAG = -4
+ CALL FMWARN
+ CALL FMST2M('UNKNOWN',MD)
+ CALL FMST2M('UNKNOWN',ME)
+ GO TO 130
+ ENDIF
+ IF (MA(2) == 0 .OR. MB(2) == 0) THEN
+ CALL FMDIV2(MA,MC,MWD)
+ CALL FMDIV2(MB,MC,ME)
+ CALL FMEQ(MWD,MD)
+ GO TO 130
+ ENDIF
+ KFLAG = 0
+
+! NGUARD is the number of guard digits used.
+
+ IF (NCALL > 1) THEN
+ NGUARD = NGRD21
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ ELSE
+ NGUARD = NGRD52 - 1
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 10
+ ENDIF
+ ENDIF
+ MA2P = ABS(MA(2))
+ MB2P = ABS(MB(2))
+ MC2P = ABS(MC(2))
+ IF ((MC2P >= MA2P .OR. MC2P >= MB2P) .AND. NGUARD < 2) NGUARD = 2
+ N1 = NDIG + 1
+ NG = NDIG + NGUARD
+
+! Copy MA and MB into the working arrays.
+
+ DO J = 3, N1
+ MWA(J+1) = MA(J)
+ MWD(J+1) = MB(J)
+ ENDDO
+ MWA(1) = MA(1) - MC(1) + 1
+ MWD(1) = MB(1) - MC(1) + 1
+ MWA(2) = 0
+ MWD(2) = 0
+ NL = N1 + NGUARD + 3
+ DO J = NDIG+3, NL
+ MWA(J) = 0
+ MWD(J) = 0
+ ENDDO
+
+! Save the signs and then work only with
+! positive numbers.
+
+ MAS = MA(-1)
+ MBS = MB(-1)
+ MCS = MC(-1)
+ MWA(3) = MA(2)
+ MWD(3) = MB(2)
+
+! NMBWDS is the number of words used to compute
+! the estimated quotient digits.
+
+ NMBWDS = 4
+ IF (MBASE < 100) NMBWDS = 7
+
+! XB is an approximation of MC used in selecting
+! estimated quotients.
+
+ XBASE = DBLE(MBASE)
+ XB = 0
+ JL = NMBWDS
+ IF (JL <= N1) THEN
+ DO J = 2, JL
+ XB = XB*XBASE + DBLE(MC(J))
+ ENDDO
+ ELSE
+ DO J = 2, JL
+ IF (J <= N1) THEN
+ XB = XB*XBASE + DBLE(MC(J))
+ ELSE
+ XB = XB*XBASE
+ ENDIF
+ ENDDO
+ ENDIF
+ IF (JL+1 <= N1) XB = XB + DBLE(MC(JL+1))/XBASE
+ XBR = 1.0D0/XB
+
+! MLMAX determines when to normalize all of MWA.
+
+ MBM1 = MBASE - 1
+ MLMAX = MAXINT/MBM1
+ MKT = INTMAX - MBASE
+ MLMAX = MIN(MLMAX,MKT)
+
+! Count the trailing zero digits of MC.
+
+ DO J = N1, 2, -1
+ IF (MC(J) /= 0) THEN
+ NZDMB = N1 - J
+ GO TO 110
+ ENDIF
+ ENDDO
+
+! MAXMWA is an upper bound on the size of values in MWA
+! divided by MBASE-1. It is used to determine whether
+! normalization can be postponed.
+
+ 110 MAXMWA = 0
+
+! KPTMW points to the next digit in the quotient.
+
+ KPTMW = 2
+
+! This is the start of the division loop.
+
+! XMWA is an approximation of the active part of MWA
+! used in selecting estimated quotients.
+
+ 120 KL = KPTMW + NMBWDS - 1
+ IF (KL <= NL) THEN
+ XMWA = ((DBLE(MWA(KPTMW))*XBASE &
+ + DBLE(MWA(KPTMW+1)))*XBASE &
+ + DBLE(MWA(KPTMW+2)))*XBASE &
+ + DBLE(MWA(KPTMW+3))
+ XMWD = ((DBLE(MWD(KPTMW))*XBASE &
+ + DBLE(MWD(KPTMW+1)))*XBASE &
+ + DBLE(MWD(KPTMW+2)))*XBASE &
+ + DBLE(MWD(KPTMW+3))
+ DO J = KPTMW+4, KL
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ XMWD = XMWD*XBASE + DBLE(MWD(J))
+ ENDDO
+ ELSE
+ XMWA = DBLE(MWA(KPTMW))
+ XMWD = DBLE(MWD(KPTMW))
+ DO J = KPTMW+1, KL
+ IF (J <= NL) THEN
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ XMWD = XMWD*XBASE + DBLE(MWD(J))
+ ELSE
+ XMWA = XMWA*XBASE
+ XMWD = XMWD*XBASE
+ ENDIF
+ ENDDO
+ ENDIF
+
+! MQDMWA and MQDMWD are the estimated quotient digits.
+
+ MQDMWA = AINT(XMWA*XBR)
+ IF (MQDMWA < 0) MQDMWA = MQDMWA - 1
+ MQDMWD = AINT(XMWD*XBR)
+ IF (MQDMWD < 0) MQDMWD = MQDMWD - 1
+
+ MAXMWA = MAXMWA + MAX(ABS(MQDMWA),ABS(MQDMWD))
+
+! See if MWA and MWD must be normalized.
+
+ KA = KPTMW + 1
+ KB = MIN(KA+NDIG-1-NZDMB,NL)
+ IF (MAXMWA >= MLMAX) THEN
+ DO J = KB, KA, -1
+ IF (MWA(J) < 0) THEN
+ MCARRY = INT((-MWA(J)-1)/MBASE) + 1
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ELSE IF (MWA(J) >= MBASE) THEN
+ MCARRY = -INT(MWA(J)/MBASE)
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ENDIF
+ IF (MWD(J) < 0) THEN
+ MCARRY = INT((-MWD(J)-1)/MBASE) + 1
+ MWD(J) = MWD(J) + MCARRY*MBASE
+ MWD(J-1) = MWD(J-1) - MCARRY
+ ELSE IF (MWD(J) >= MBASE) THEN
+ MCARRY = -INT(MWD(J)/MBASE)
+ MWD(J) = MWD(J) + MCARRY*MBASE
+ MWD(J-1) = MWD(J-1) - MCARRY
+ ENDIF
+ ENDDO
+ XMWA = 0
+ XMWD = 0
+ IF (KL <= NL) THEN
+ DO J = KPTMW, KL
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ XMWD = XMWD*XBASE + DBLE(MWD(J))
+ ENDDO
+ ELSE
+ DO J = KPTMW, KL
+ IF (J <= NL) THEN
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ XMWD = XMWD*XBASE + DBLE(MWD(J))
+ ELSE
+ XMWA = XMWA*XBASE
+ XMWD = XMWD*XBASE
+ ENDIF
+ ENDDO
+ ENDIF
+ MQDMWA = AINT(XMWA*XBR)
+ IF (MQDMWA < 0) MQDMWA = MQDMWA - 1
+ MQDMWD = AINT(XMWD*XBR)
+ IF (MQDMWD < 0) MQDMWD = MQDMWD - 1
+ MAXMWA = MAX(ABS(MQDMWA),ABS(MQDMWD))
+ ENDIF
+
+! Subtract MQDMWA*MC from MWA and MQDMWD*MC from MWD.
+
+ JB = KA - 2
+
+! Major (Inner Loop)
+
+ DO J = KA, KB
+ MTEMP = MC(J-JB)
+ MWA(J) = MWA(J) - MQDMWA*MTEMP
+ MWD(J) = MWD(J) - MQDMWD*MTEMP
+ ENDDO
+
+ MWA(KA) = MWA(KA) + MWA(KA-1)*MBASE
+ MWD(KA) = MWD(KA) + MWD(KA-1)*MBASE
+ MWA(KPTMW) = MQDMWA
+ MWD(KPTMW) = MQDMWD
+
+ KPTMW = KPTMW + 1
+ IF (KPTMW <= NG) GO TO 120
+
+ KL = KPTMW + NMBWDS - 1
+ IF (KL <= NL) THEN
+ XMWA = ((DBLE(MWA(KPTMW))*XBASE &
+ + DBLE(MWA(KPTMW+1)))*XBASE &
+ + DBLE(MWA(KPTMW+2)))*XBASE &
+ + DBLE(MWA(KPTMW+3))
+ XMWD = ((DBLE(MWD(KPTMW))*XBASE &
+ + DBLE(MWD(KPTMW+1)))*XBASE &
+ + DBLE(MWD(KPTMW+2)))*XBASE &
+ + DBLE(MWD(KPTMW+3))
+ DO J = KPTMW+4, KL
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ XMWD = XMWD*XBASE + DBLE(MWD(J))
+ ENDDO
+ ELSE
+ XMWA = DBLE(MWA(KPTMW))
+ XMWD = DBLE(MWD(KPTMW))
+ DO J = KPTMW+1, KL
+ IF (J <= NL) THEN
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ XMWD = XMWD*XBASE + DBLE(MWD(J))
+ ELSE
+ XMWA = XMWA*XBASE
+ XMWD = XMWD*XBASE
+ ENDIF
+ ENDDO
+ ENDIF
+ MQDMWA = AINT(XMWA*XBR)
+ IF (MQDMWA < 0) MQDMWA = MQDMWA - 1
+ MQDMWD = AINT(XMWD*XBR)
+ IF (MQDMWD < 0) MQDMWD = MQDMWD - 1
+ MWA(KPTMW) = MQDMWA
+ MWA(KPTMW+1) = 0
+ MWA(KPTMW+2) = 0
+ MWD(KPTMW) = MQDMWD
+ MWD(KPTMW+1) = 0
+ MWD(KPTMW+2) = 0
+
+! Final normalization.
+
+ DO J = KPTMW-1, 3, -1
+ IF (MWA(J) < 0) THEN
+ MCARRY = INT((-MWA(J)-1)/MBASE) + 1
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ELSE IF (MWA(J) >= MBASE) THEN
+ MCARRY = -INT(MWA(J)/MBASE)
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ENDIF
+ IF (MWD(J) < 0) THEN
+ MCARRY = INT((-MWD(J)-1)/MBASE) + 1
+ MWD(J) = MWD(J) + MCARRY*MBASE
+ MWD(J-1) = MWD(J-1) - MCARRY
+ ELSE IF (MWD(J) >= MBASE) THEN
+ MCARRY = -INT(MWD(J)/MBASE)
+ MWD(J) = MWD(J) + MCARRY*MBASE
+ MWD(J-1) = MWD(J-1) - MCARRY
+ ENDIF
+ ENDDO
+
+! Round, affix the sign, and return.
+
+ IF ((MAS > 0 .AND. MCS > 0) .OR. (MAS < 0 .AND. MCS < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ IF (MWA(2) == 0) THEN
+ MLR = 2*MWA(NDIG+3) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,1)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1+1) = MWA(N1+1) + 1
+ MWA(N1+2) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,1)
+ ENDIF
+ ENDIF
+ ELSE
+ MLR = 2*MWA(NDIG+2) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,0)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1) = MWA(N1) + 1
+ MWA(N1+1) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,0)
+ ENDIF
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWA,MD)
+
+ IF ((MBS > 0 .AND. MCS > 0) .OR. (MBS < 0 .AND. MCS < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ IF (MWD(2) == 0) THEN
+ MLR = 2*MWD(NDIG+3) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWD,NDIG,NGUARD,1)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWD(N1+1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWD(N1+1) = MWD(N1+1) + 1
+ MWD(N1+2) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWD,NDIG,NGUARD,1)
+ ENDIF
+ ENDIF
+ ELSE
+ MLR = 2*MWD(NDIG+2) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWD,NDIG,NGUARD,0)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWD(N1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWD(N1) = MWD(N1) + 1
+ MWD(N1+1) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWD,NDIG,NGUARD,0)
+ ENDIF
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWD,ME)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMDIVD'
+ CALL FMWARN
+ ENDIF
+
+ MD(-1) = 1
+ IF (MAS*MCS < 0 .AND. MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -1
+ ME(-1) = 1
+ IF (MBS*MCS < 0 .AND. ME(1) /= MUNKNO .AND. ME(2) /= 0) ME(-1) = -1
+
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MD(2))+1))/0.69315)
+ MD(0) = MIN(MACCA,MACCC,MD2B)
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(ME(2))+1))/0.69315)
+ ME(0) = MIN(MACCB,MACCC,MD2B)
+ ELSE
+ MD(0) = MIN(MACCA,MACCC)
+ ME(0) = MIN(MACCB,MACCC)
+ ENDIF
+
+ 130 IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MD,MD,1,1)
+ IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN
+ IF (NTRACE < 0) THEN
+ CALL FMNTRJ(ME,NDIG)
+ ELSE
+ CALL FMPRNT(ME)
+ ENDIF
+ ENDIF
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMDIVD
+
+ SUBROUTINE FMDIVI(MA,IVAL,MB)
+
+! MB = MA / IVAL
+
+! Divide FM number MA by one word integer IVAL.
+
+! This routine is faster than FMDIV when the divisor is less than
+! MXBASE (the square root of the largest integer).
+! When IVAL is not less than MXBASE, FMDIV2 is used. In this case,
+! if IVAL is known to be a product of two integers less than
+! MXBASE, it is usually faster to make two calls to FMDIVI with
+! half-word factors than one call with their product.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER IVAL
+ REAL (KIND(1.0D0)) :: MACCA,MD2B
+
+ KFLAG = 0
+ MACCA = MA(0)
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMDIVI'
+ CALL FMNTR(2,MA,MA,1,1)
+ CALL FMNTRI(2,IVAL,0)
+ CALL FMDIVN(MA,IVAL,MB)
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/ &
+ 0.69315)
+ MB(0) = MIN(MACCA,MD2B)
+ ELSE
+ MB(0) = MACCA
+ ENDIF
+ CALL FMNTR(1,MB,MB,1,1)
+ ELSE
+ CALL FMDIVN(MA,IVAL,MB)
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/ &
+ 0.69315)
+ MB(0) = MIN(MACCA,MD2B)
+ ELSE
+ MB(0) = MACCA
+ ENDIF
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMDIVI
+
+ SUBROUTINE FMDIVN(MA,IVAL,MB)
+
+! Internal divide by integer routine. MB = MA / IVAL
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER IVAL
+ REAL (KIND(1.0D0)) :: MA1,MAS,MKT,MLR,MODINT,MVALP
+ INTEGER J,JRSSAV,KA,KB,KL,KPT,KPTWA,N1,NGUARD,NMVAL,NV2
+
+! Check for special cases.
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JRSSAV = JRSIGN
+ N1 = NDIG + 1
+ IF (MA(1) == MUNKNO .OR. IVAL == 0) THEN
+ MA1 = MA(1)
+ CALL FMIM(0,MB)
+ MB(0) = NINT(NDG2MX*ALOGM2)
+ MB(1) = MUNKNO
+ MB(2) = 1
+ KFLAG = -4
+ IF (MA1 /= MUNKNO) THEN
+ NAMEST(NCALL) = 'FMDIVI'
+ CALL FMWARN
+ ENDIF
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (MA(2) == 0) THEN
+ CALL FMEQ(MA,MB)
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (ABS(MA(1)) < MEXPOV .AND. ABS(IVAL) > 1) GO TO 110
+
+ IF (ABS(IVAL) == 1) THEN
+ DO J = 0, N1
+ MB(J) = MA(J)
+ ENDDO
+ MB(-1) = MA(-1)*IVAL
+ IF (MA(1) == MEXPOV) KFLAG = -5
+ IF (MA(1) == MEXPUN) KFLAG = -6
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (MA(1) == MEXPUN) THEN
+ MAS = MA(-1)
+ CALL FMIM(0,MB)
+ MB(1) = MEXPUN
+ MB(2) = 1
+ MB(0) = NINT(NDIG*ALOGM2)
+ IF ((MAS < 0 .AND. IVAL > 0) .OR. &
+ (MAS > 0 .AND. IVAL < 0)) MB(-1) = -1
+ KFLAG = -6
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (MA(1) == MEXPOV) THEN
+ NAMEST(NCALL) = 'FMDIVI'
+ CALL FMIM(0,MB)
+ MB(1) = MUNKNO
+ MB(2) = 1
+ MB(0) = NINT(NDIG*ALOGM2)
+ KFLAG = -4
+ CALL FMWARN
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+! NGUARD is the number of guard digits used.
+
+ 110 IF (NCALL > 1) THEN
+ NGUARD = NGRD21
+ ELSE
+ NGUARD = NGRD52
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 10
+ ENDIF
+ ENDIF
+
+! If ABS(IVAL) >= MXBASE use FMDIV.
+
+ MVALP = ABS(IVAL)
+ NMVAL = INT(MVALP)
+ NV2 = NMVAL - 1
+ IF (ABS(IVAL) > MXBASE .OR. NMVAL /= ABS(IVAL) .OR. &
+ NV2 /= ABS(IVAL)-1) THEN
+ CALL FMIM(IVAL,M01)
+ CALL FMDIV2(MA,M01,MB)
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+! Work with positive numbers.
+
+ MAS = MA(-1)
+
+! Find the first significant digit of the quotient.
+
+ MKT = MA(2)
+ IF (MKT >= MVALP) THEN
+ KPT = 2
+ GO TO 130
+ ENDIF
+ DO J = 3, N1
+ MKT = MKT*MBASE + MA(J)
+ IF (MKT >= MVALP) THEN
+ KPT = J
+ GO TO 130
+ ENDIF
+ ENDDO
+ KPT = N1
+
+ 120 KPT = KPT + 1
+ MKT = MKT*MBASE
+ IF (MKT < MVALP) GO TO 120
+
+! Do the rest of the division.
+
+ 130 KA = KPT + 1
+ MWA(1) = MA(1) + 2 - KPT
+ MWA(2) = INT (MKT/MVALP)
+ MODINT = MKT - MWA(2)*MVALP
+ KPTWA = 2
+ IF (KA <= N1) THEN
+ KL = 3 - KA
+
+! (Inner Loop)
+
+ DO J = KA, N1
+ MKT = MODINT*MBASE + MA(J)
+ MWA(KL+J) = INT (MKT/MVALP)
+ MODINT = MKT - MWA(KL+J)*MVALP
+ ENDDO
+ KPTWA = KL + N1
+ ENDIF
+
+ KA = KPTWA + 1
+ KB = N1 + NGUARD
+ DO J = KA, KB
+ MKT = MODINT*MBASE
+ MWA(J) = INT (MKT/MVALP)
+ MODINT = MKT - MWA(J)*MVALP
+ ENDDO
+
+! Round the result, put the sign on MB and return.
+
+ MLR = 2*MWA(NDIG+2) + 1
+ IF ((MAS > 0 .AND. IVAL > 0) .OR. (MAS < 0 .AND. IVAL < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,0)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1) = MWA(N1) + 1
+ MWA(N1+1) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,0)
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWA,MB)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMDIVI'
+ CALL FMWARN
+ ENDIF
+ MB(-1) = JRSIGN
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMDIVN
+
+ SUBROUTINE FMDIVI_R1(MA,IVAL)
+
+! MA = MA / IVAL
+
+! Divide FM number MA by one word integer IVAL.
+
+! This routine is faster than FMDIV when the divisor is less than
+! MXBASE (the square root of the largest integer).
+! When IVAL is not less than MXBASE, FMDIV2 is used. In this case,
+! if IVAL is known to be a product of two integers less than
+! MXBASE, it is usually faster to make two calls to FMDIVI with
+! half-word factors than one call with their product.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER IVAL
+ REAL (KIND(1.0D0)) :: MACCA,MD2B
+
+ KFLAG = 0
+ MACCA = MA(0)
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMDIVI'
+ CALL FMNTR(2,MA,MA,1,1)
+ CALL FMNTRI(2,IVAL,0)
+ CALL FMDIVN_R1(MA,IVAL)
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/ &
+ 0.69315)
+ MA(0) = MIN(MACCA,MD2B)
+ ELSE
+ MA(0) = MACCA
+ ENDIF
+ CALL FMNTR(1,MA,MA,1,1)
+ ELSE
+ CALL FMDIVN_R1(MA,IVAL)
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/ &
+ 0.69315)
+ MA(0) = MIN(MACCA,MD2B)
+ ELSE
+ MA(0) = MACCA
+ ENDIF
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMDIVI_R1
+
+ SUBROUTINE FMDIVN_R1(MA,IVAL)
+
+! Internal divide by integer routine. MA = MA / IVAL
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER IVAL
+ REAL (KIND(1.0D0)) :: MA1,MAS,MKT,MLR,MODINT,MVALP
+ INTEGER J,JRSSAV,KA,KB,KL,KPT,KPTWA,N1,NGUARD,NMVAL,NV2
+
+! Check for special cases.
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JRSSAV = JRSIGN
+ N1 = NDIG + 1
+ IF (MA(1) == MUNKNO .OR. IVAL == 0) THEN
+ MA1 = MA(1)
+ CALL FMIM(0,MA)
+ MA(0) = NINT(NDG2MX*ALOGM2)
+ MA(1) = MUNKNO
+ MA(2) = 1
+ KFLAG = -4
+ IF (MA1 /= MUNKNO) THEN
+ NAMEST(NCALL) = 'FMDIVI'
+ CALL FMWARN
+ ENDIF
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (MA(2) == 0) THEN
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (ABS(MA(1)) < MEXPOV .AND. ABS(IVAL) > 1) GO TO 110
+
+ IF (ABS(IVAL) == 1) THEN
+ MA(-1) = MA(-1)*IVAL
+ IF (MA(1) == MEXPOV) KFLAG = -5
+ IF (MA(1) == MEXPUN) KFLAG = -6
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (MA(1) == MEXPUN) THEN
+ MAS = MA(-1)
+ CALL FMIM(0,MA)
+ MA(1) = MEXPUN
+ MA(2) = 1
+ MA(0) = NINT(NDIG*ALOGM2)
+ IF ((MAS < 0 .AND. IVAL > 0) .OR. &
+ (MAS > 0 .AND. IVAL < 0)) MA(-1) = -1
+ KFLAG = -6
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (MA(1) == MEXPOV) THEN
+ NAMEST(NCALL) = 'FMDIVI'
+ CALL FMIM(0,MA)
+ MA(1) = MUNKNO
+ MA(2) = 1
+ MA(0) = NINT(NDIG*ALOGM2)
+ KFLAG = -4
+ CALL FMWARN
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+! NGUARD is the number of guard digits used.
+
+ 110 IF (NCALL > 1) THEN
+ NGUARD = NGRD21
+ ELSE
+ NGUARD = NGRD52
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 10
+ ENDIF
+ ENDIF
+
+! If ABS(IVAL) >= MXBASE use FMDIV.
+
+ MVALP = ABS(IVAL)
+ NMVAL = INT(MVALP)
+ NV2 = NMVAL - 1
+ IF (ABS(IVAL) > MXBASE .OR. NMVAL /= ABS(IVAL) .OR. &
+ NV2 /= ABS(IVAL)-1) THEN
+ CALL FMIM(IVAL,M01)
+ CALL FMDIV2_R1(MA,M01)
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+! Work with positive numbers.
+
+ MAS = MA(-1)
+
+! Find the first significant digit of the quotient.
+
+ MKT = MA(2)
+ IF (MKT >= MVALP) THEN
+ KPT = 2
+ GO TO 130
+ ENDIF
+ DO J = 3, N1
+ MKT = MKT*MBASE + MA(J)
+ IF (MKT >= MVALP) THEN
+ KPT = J
+ GO TO 130
+ ENDIF
+ ENDDO
+ KPT = N1
+
+ 120 KPT = KPT + 1
+ MKT = MKT*MBASE
+ IF (MKT < MVALP) GO TO 120
+
+! Do the rest of the division.
+
+ 130 KA = KPT + 1
+ MWA(1) = MA(1) + 2 - KPT
+ MWA(2) = INT (MKT/MVALP)
+ MODINT = MKT - MWA(2)*MVALP
+ KPTWA = 2
+ IF (KA <= N1) THEN
+ KL = 3 - KA
+
+! (Inner Loop)
+
+ DO J = KA, N1
+ MKT = MODINT*MBASE + MA(J)
+ MWA(KL+J) = INT (MKT/MVALP)
+ MODINT = MKT - MWA(KL+J)*MVALP
+ ENDDO
+ KPTWA = KL + N1
+ ENDIF
+
+ KA = KPTWA + 1
+ KB = N1 + NGUARD
+ DO J = KA, KB
+ MKT = MODINT*MBASE
+ MWA(J) = INT (MKT/MVALP)
+ MODINT = MKT - MWA(J)*MVALP
+ ENDDO
+
+! Round the result, put the sign on MA and return.
+
+ MLR = 2*MWA(NDIG+2) + 1
+ IF ((MAS > 0 .AND. IVAL > 0) .OR. (MAS < 0 .AND. IVAL < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,0)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1) = MWA(N1) + 1
+ MWA(N1+1) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,0)
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWA,MA)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMDIVI'
+ CALL FMWARN
+ ENDIF
+ MA(-1) = JRSIGN
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMDIVN_R1
+
+ SUBROUTINE FMDM(X,MA)
+
+! Internal routine for converting double precision to multiple
+! precision. Called by FMDPM.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ DOUBLE PRECISION X
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ DOUBLE PRECISION ONE,XBASE,Y,Y2,YT
+ REAL (KIND(1.0D0)) :: MK,MN
+ INTEGER J,K,N1,NE
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KFLAG = 0
+ N1 = NDIG + 1
+
+ ONE = 1.0D0
+ XBASE = MBASE
+ K = 0
+
+! NE-1 is the number of words at the current precision and
+! base roughly equal to machine precision.
+
+ NE = INT(DLOGEB) + 3
+ Y = X
+ IF (X < 0.0) Y = -X
+
+ IF (X == 0.0) THEN
+ DO J = 1, N1
+ MA(J) = 0
+ ENDDO
+ GO TO 160
+ ENDIF
+
+! Get the exponent.
+
+ IF (Y > ONE) THEN
+ IF (Y/XBASE < Y) THEN
+ 110 K = K + 1
+ Y = Y/XBASE
+ IF (Y > ONE) GO TO 110
+ IF (Y < ONE) THEN
+ MA(1) = K
+ GO TO 140
+ ENDIF
+ GO TO 130
+ ELSE
+ KFLAG = -4
+ CALL FMWARN
+ DO J = 1, N1
+ MA(J) = 0
+ ENDDO
+ MA(1) = MUNKNO
+ MA(2) = 1
+ MA(-1) = 1
+ MA(0) = NINT(NDIG*ALOGM2)
+ RETURN
+ ENDIF
+ ENDIF
+
+ IF (Y < ONE) THEN
+ IF (Y*XBASE > Y) THEN
+ 120 K = K - 1
+ Y = Y*XBASE
+ IF (Y < ONE) GO TO 120
+ IF (Y > ONE) THEN
+ K = K + 1
+ Y = Y/XBASE
+ MA(1) = K
+ GO TO 140
+ ENDIF
+ ELSE
+ KFLAG = -4
+ CALL FMWARN
+ DO J = 1, N1
+ MA(J) = 0
+ ENDDO
+ MA(1) = MUNKNO
+ MA(2) = 1
+ MA(-1) = 1
+ MA(0) = NINT(NDIG*ALOGM2)
+ RETURN
+ ENDIF
+ ENDIF
+
+ 130 MA(1) = K + 1
+ MA(2) = 1
+ DO J = 3, N1
+ MA(J) = 0
+ ENDDO
+ GO TO 160
+
+! Build the rest of the number.
+
+ 140 DO J = 2, NE
+ Y = Y*XBASE
+ MK = AINT(Y)
+ YT = -MK
+ CALL FMDBL(Y,YT,Y2)
+ Y = Y2
+ MA(J) = MK
+ IF (J >= N1) GO TO 150
+ ENDDO
+ K = NE + 1
+ DO J = K, N1
+ MA(J) = 0
+ ENDDO
+
+! Normalize.
+
+ 150 IF (ABS(MA(2)) >= MBASE) THEN
+ K = N1 + 1
+ DO J = 3, N1
+ K = K - 1
+ MA(K) = MA(K-1)
+ ENDDO
+ MN = AINT (MA(2)/MBASE)
+ MA(3) = MA(2) - MN*MBASE
+ MA(2) = MN
+ MA(1) = MA(1) + 1
+ GO TO 160
+ ENDIF
+
+ IF (MA(2) == 0) THEN
+ DO J = 2, NDIG
+ MA(J) = MA(J+1)
+ ENDDO
+ MA(1) = MA(1) - 1
+ MA(N1) = 0
+ ENDIF
+
+ 160 MA(-1) = 1
+ IF (X < 0.0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1
+ MA(0) = MIN(NINT((NE-1)*ALOGM2),NINT(NDIG*ALOGM2))
+ RETURN
+ END SUBROUTINE FMDM
+
+ SUBROUTINE FMDM2(X,MA)
+
+! Internal routine for converting double precision to multiple
+! precision. Called by FMDP2M.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ DOUBLE PRECISION X
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ DOUBLE PRECISION Y,TWO20
+ INTEGER J,JEXP,K,KEXP,KRESLT,N1,NDSAVE
+
+! Increase the working precision.
+
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD21,1)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,M07,KRESLT)
+ CALL FMEQ(M07,MA)
+ IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KFLAG = 0
+ N1 = NDIG + 1
+
+ IF (X == 0.0D0) THEN
+ DO J = 1, N1
+ MA(J) = 0
+ ENDDO
+ GO TO 140
+ ENDIF
+
+ Y = ABS(X)
+ TWO20 = 1048576.0D0
+
+! If this power of two is not representable at the current
+! base and precision, use a smaller one.
+
+ IF (INT(NDIG*ALOGM2) < 20) THEN
+ K = INT(NDIG*ALOGM2)
+ TWO20 = 1.0D0
+ DO J = 1, K
+ TWO20 = TWO20*2.0D0
+ ENDDO
+ ENDIF
+
+ KEXP = 0
+ IF (Y > TWO20) THEN
+ 110 Y = Y/TWO20
+ KEXP = KEXP + 1
+ IF (Y > TWO20) GO TO 110
+ ELSE IF (Y < 1.0D0) THEN
+ 120 Y = Y*TWO20
+ KEXP = KEXP - 1
+ IF (Y < 1.0D0) GO TO 120
+ ENDIF
+
+ K = INT(TWO20)
+ CALL FMI2M(K,M04)
+ K = INT(Y)
+ CALL FMI2M(K,M02)
+ Y = (Y-DBLE(K))*TWO20
+ JEXP = 0
+
+ 130 K = INT(Y)
+ CALL FMI2M(K,M03)
+ CALL FMMPY_R1(M02,M04)
+ JEXP = JEXP + 1
+ CALL FMADD_R1(M02,M03)
+ Y = (Y-DBLE(K))*TWO20
+ IF (JEXP <= 1000 .AND. Y /= 0.0D0) GO TO 130
+
+ K = KEXP - JEXP
+ CALL FMIPWR(M04,K,M03)
+ CALL FMMPY(M02,M03,MA)
+
+ 140 MA(-1) = 1
+ IF (X < 0.0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1
+ MA(0) = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315)
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE FMDM2
+
+ SUBROUTINE FMDP2M(X,MA)
+
+! MA = X
+
+! Convert a double precision floating point number to FM format.
+
+! This version tries to convert the REAL (KIND(1.0D0)) :: Machine
+! number to FM with accuracy of nearly full FM precision.
+! If conversion to FM with approximately double precision accuracy
+! is good enough, FMDPM is faster and uses less scratch space.
+
+! This routine assumes the machine's base for double precision is
+! a power of two.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ DOUBLE PRECISION X
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMDP2M'
+ IF (NTRACE /= 0) CALL FMNTRR(2,X,1)
+
+ CALL FMDM2(X,MA)
+
+ IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMDP2M
+
+ SUBROUTINE FMDPM(X,MA)
+
+! MA = X
+
+! Convert a double precision floating point number to FM format.
+
+! In general, the relative accuracy of the FM number returned is only
+! the relative accuracy of a machine precision number. This may be
+! true even if X can be represented exactly in the machine floating
+! point number system.
+
+! This version is faster than FMDP2M, but often less accurate.
+! No scratch arrays are used.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ DOUBLE PRECISION X
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ DOUBLE PRECISION Y,YT
+ INTEGER K
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMDPM '
+ IF (NTRACE /= 0) CALL FMNTRR(2,X,1)
+
+! Check to see if X is exactly a small integer. If so,
+! converting as an integer is better.
+! Also see if X is exactly a small integer divided by
+! a small power of two.
+
+ Y = 1048576.0D0
+ IF (ABS(X) < Y) THEN
+ K = INT(X)
+ Y = K
+ IF (Y == X) THEN
+ CALL FMIM(K,MA)
+ GO TO 110
+ ENDIF
+ ENDIF
+ IF (ABS(X) < 1.0D0) THEN
+ Y = 4096.0D0*X
+ K = INT(Y)
+ YT = K
+ IF (Y == YT) THEN
+ CALL FMIM(K,MA)
+ CALL FMDIVI_R1(MA,4096)
+ GO TO 110
+ ENDIF
+ ENDIF
+
+ CALL FMDM(X,MA)
+
+ 110 IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMDPM
+
+ SUBROUTINE FMENTR(NROUTN,MA,MB,NARGS,KNAM,MC,KRESLT,NDSAVE,MXSAVE, &
+ KASAVE,KOVUN)
+
+! Do the argument checking and increasing of precision and overflow
+! threshold upon entry to an FM routine.
+
+! NROUTN - routine name of calling routine
+! MA - first input argument
+! MB - second input argument (optional)
+! NARGS - number of input arguments
+! KNAM - positive if the routine name is to be printed.
+! MC - result argument
+! KRESLT - returned nonzero if the input arguments give the result
+! immediately (e.g., MA*0 or OVERFLOW*MB)
+! NDSAVE - saves the value of NDIG after NDIG is increased
+! MXSAVE - saves the value of MXEXP
+! KASAVE - saves the value of KACCSW
+! KOVUN - returned nonzero if an input argument is (+ or -) overflow
+! or underflow.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(6) :: NROUTN
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK),MXSAVE
+ INTEGER KNAM,NARGS,KRESLT,NDSAVE,KASAVE,KOVUN
+
+ REAL (KIND(1.0D0)) :: MACCAB
+ INTEGER K
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = NROUTN
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,NARGS,KNAM)
+ CALL FMARGS(NROUTN,NARGS,MA,MB,KRESLT)
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ IF (NARGS == 2) THEN
+ IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1
+ ENDIF
+
+! Increase the working precision.
+
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ KRESLT = 12
+ NDIG = NDSAVE
+ ENDIF
+ ENDIF
+
+ IF (KRESLT /= 0) THEN
+ MACCAB = MA(0)
+ IF (NARGS == 2) MACCAB = MIN(MACCAB,MB(0))
+ IF (KRESLT == 9 .OR. KRESLT == 10 .OR. KRESLT >= 13) THEN
+ IF (KRAD == 1) THEN
+ CALL FMPI(MC)
+ ELSE
+ CALL FMI2M(180,MC)
+ ENDIF
+ IF (KRESLT <= 10) CALL FMDIVI_R1(MC,2)
+ IF (KRESLT >= 14) CALL FMDIVI_R1(MC,4)
+ CALL FMEQ2_R1(MC,NDIG,NDSAVE)
+ NDIG = NDSAVE
+ IF ((KRESLT == 9 .OR. KRESLT == 14) .AND. &
+ MC(1) /= MUNKNO .AND. MC(2) /= 0) &
+ MC(-1) = -MC(-1)
+ MC(0) = MACCAB
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ KASAVE = KACCSW
+ MXSAVE = MXEXP
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ NDIG = NDSAVE
+ CALL FMRSLT(MA,MB,MC,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ KASAVE = KACCSW
+ MXSAVE = MXEXP
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ KASAVE = KACCSW
+ KACCSW = 0
+
+! Extend the overflow/underflow threshold.
+
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ RETURN
+ END SUBROUTINE FMENTR
+
+ SUBROUTINE FMEQ(MA,MB)
+
+! MB = MA
+
+! This is the standard form of equality, where MA and MB both
+! have precision NDIG. Use FMEQU for assignments that also
+! change precision.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ INTEGER J
+
+ DO J = -1, NDIG+1
+ MB(J) = MA(J)
+ ENDDO
+
+! Check for overflow or underflow.
+
+ IF (ABS(MB(1)) > MXEXP) THEN
+ IF (MB(1) /= MUNKNO .OR. MB(2) /= 1) THEN
+ NCALL = NCALL + 1
+ CALL FMTRAP(MB)
+ NCALL = NCALL - 1
+ ENDIF
+ IF (MB(1) == MUNKNO) KFLAG = -4
+ ENDIF
+
+ RETURN
+ END SUBROUTINE FMEQ
+
+ SUBROUTINE FMEQ2(MA,MB,NDA,NDB)
+
+! Set MB (having NDB digits) equal to MA (having NDA digits).
+
+! If MB has less precision than MA the result is rounded to NDB digits.
+
+! If MB has more precision the result has zero digits padded on the
+! right.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER NDA,NDB
+
+ REAL (KIND(1.0D0)) :: M2,MACCA,MBS,MKT
+ INTEGER J,JT,K,KB,L,N1
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ MACCA = MA(0)
+
+! Check for precision in range.
+
+ IF (NDA < 1 .OR. NDA > NDG2MX .OR. NDB < 1 .OR. &
+ NDB > NDG2MX) THEN
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMEQU '
+ KFLAG = -1
+ CALL FMWARN
+ WRITE (KW, &
+ "(/' The two precisions in FMEQU were NDA =',I10," // &
+ "' NDB =',I10/)" &
+ ) NDA,NDB
+ CALL FMIM(0,MB)
+ KFLAG = -1
+ MB(1) = MUNKNO
+ MB(2) = 1
+ MB(0) = NINT(NDIG*ALOGM2)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ MBS = MA(-1)
+ MB(-1) = MBS
+
+! Check for special symbols.
+
+ KFLAG = 0
+ IF (ABS(MA(1)) >= MEXPOV) THEN
+ DO J = 2, NDB
+ MB(J+1) = 0
+ ENDDO
+ MB(1) = MA(1)
+ MB(2) = MA(2)
+ GO TO 150
+ ENDIF
+
+ IF (NDB == NDA) GO TO 130
+
+ IF (NDB > NDA) GO TO 140
+
+! Round to NDB digits.
+
+ N1 = NDB + 1
+ DO J = 1, N1
+ MB(J) = MA(J)
+ ENDDO
+ IF (KROUND == -1 .AND. NCALL <= 1) THEN
+ IF (MA(-1) > 0) GO TO 150
+ DO J = NDB+2, NDA+1
+ IF (MA(J) > 0) GO TO 110
+ ENDDO
+ GO TO 150
+ ENDIF
+ IF (KROUND == 2 .AND. NCALL <= 1) THEN
+ IF (MA(-1) < 0) GO TO 150
+ DO J = NDB+2, NDA+1
+ IF (MA(J) > 0) GO TO 110
+ ENDDO
+ GO TO 150
+ ENDIF
+ IF (KROUND == 0 .AND. NCALL <= 1) GO TO 150
+
+ L = NDB + 2
+ IF (2*(MA(L)+1) < MBASE) GO TO 150
+ M2 = 2
+ IF (INT(MBASE-AINT (MBASE/M2)*M2) == 0) THEN
+ IF (2*MA(L) < MBASE) GO TO 150
+ IF (2*MA(L) == MBASE) THEN
+ IF (L <= NDA) THEN
+ DO J = L, NDA
+ IF (MA(J+1) > 0) GO TO 110
+ ENDDO
+ ENDIF
+
+! Round to even.
+
+ IF (INT(MB(N1)-AINT (MB(N1)/M2)*M2) == 0) GO TO 150
+ ENDIF
+ ELSE
+ IF (2*MA(L)+1 == MBASE) THEN
+ IF (L <= NDA) THEN
+ DO J = L, NDA
+ IF (2*(MA(J+1)+1) < MBASE) GO TO 150
+ IF (2*MA(J+1) > MBASE) GO TO 110
+ ENDDO
+ GO TO 150
+ ENDIF
+ ENDIF
+ ENDIF
+
+ 110 MB(NDB+1) = MB(NDB+1) + 1
+ MB(NDB+2) = 0
+
+! Check whether there was a carry in the rounded digit.
+
+ KB = NDB + 1
+ IF (KB >= 3) THEN
+ K = KB + 1
+ DO J = 3, KB
+ K = K - 1
+ IF (MB(K) < MBASE) GO TO 120
+ MKT = AINT (MB(K)/MBASE)
+ MB(K-1) = MB(K-1) + MKT
+ MB(K) = MB(K) - MKT*MBASE
+ ENDDO
+ ENDIF
+
+! If there is a carry in the first digit then the exponent
+! must be adjusted and the number shifted right.
+
+ IF (MB(2) < MBASE) GO TO 120
+ IF (KB >= 4) THEN
+ K = KB + 1
+ DO J = 4, KB
+ K = K - 1
+ MB(K) = MB(K-1)
+ ENDDO
+ ENDIF
+
+ MKT = AINT (MB(2)/MBASE)
+ IF (KB >= 3) MB(3) = MB(2) - MKT*MBASE
+ MB(2) = MKT
+ MB(1) = MB(1) + 1
+
+ 120 IF (MBS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1
+ GO TO 150
+
+! MA and MB have the same precision.
+
+ 130 DO J = 1, NDA+1
+ MB(J) = MA(J)
+ ENDDO
+ GO TO 150
+
+! Extend to NDB digits by padding with zeros.
+
+ 140 DO J = 1, NDA+1
+ MB(J) = MA(J)
+ ENDDO
+ DO J = NDA+2, NDB+1
+ MB(J) = 0
+ ENDDO
+
+! Check for overflow or underflow.
+
+ 150 IF (ABS(MB(1)) > MXEXP) THEN
+ IF (MB(1) /= MUNKNO .OR. MB(2) /= 1) THEN
+ NCALL = NCALL + 1
+ CALL FMTRAP(MB)
+ NCALL = NCALL - 1
+ ENDIF
+ IF (MB(1) == MUNKNO) KFLAG = -4
+ ENDIF
+
+ IF (KACCSW == 1) THEN
+ JT = NINT(LOG(REAL(ABS(MB(2))+1))/0.69315)
+ IF (NDB > NDA) THEN
+ MB(0) = NINT((NDB-1)*ALOGM2 + JT)
+ ELSE
+ MB(0) = MIN(NINT((NDB-1)*ALOGM2+JT),INT(MACCA))
+ ENDIF
+ ELSE
+ MB(0) = MA(0)
+ ENDIF
+ RETURN
+ END SUBROUTINE FMEQ2
+
+ SUBROUTINE FMEQ2_R1(MA,NDA,NDB)
+
+! Change precision of MA from NDA digits on input to NDB digits on output.
+
+! If NDB is less than NDA the result is rounded to NDB digits.
+
+! If NDB is greater than NDA the result has zero digits padded on the
+! right.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER NDA,NDB
+
+ REAL (KIND(1.0D0)) :: M2,MACCA,MBS,MKT
+ INTEGER J,JT,K,KB,L,N1
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ MACCA = MA(0)
+
+! Check for precision in range.
+
+ IF (NDA < 1 .OR. NDA > NDG2MX .OR. NDB < 1 .OR. &
+ NDB > NDG2MX) THEN
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMEQU '
+ KFLAG = -1
+ CALL FMWARN
+ WRITE (KW, &
+ "(/' The two precisions in FMEQU were NDA =',I10," // &
+ "' NDB =',I10/)" &
+ ) NDA,NDB
+ CALL FMIM(0,MA)
+ KFLAG = -1
+ MA(1) = MUNKNO
+ MA(2) = 1
+ MA(0) = NINT(NDIG*ALOGM2)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ MBS = MA(-1)
+
+! Check for special symbols.
+
+ KFLAG = 0
+ IF (ABS(MA(1)) >= MEXPOV) THEN
+ DO J = 2, NDB
+ MA(J+1) = 0
+ ENDDO
+ GO TO 140
+ ENDIF
+
+ IF (NDB == NDA) GO TO 140
+
+ IF (NDB > NDA) GO TO 130
+
+! Round to NDB digits.
+
+ N1 = NDB + 1
+ IF (KROUND == -1 .AND. NCALL <= 1) THEN
+ IF (MA(-1) > 0) GO TO 140
+ DO J = NDB+2, NDA+1
+ IF (MA(J) > 0) GO TO 110
+ ENDDO
+ GO TO 140
+ ENDIF
+ IF (KROUND == 2 .AND. NCALL <= 1) THEN
+ IF (MA(-1) < 0) GO TO 140
+ DO J = NDB+2, NDA+1
+ IF (MA(J) > 0) GO TO 110
+ ENDDO
+ GO TO 140
+ ENDIF
+ IF (KROUND == 0 .AND. NCALL <= 1) GO TO 140
+
+ L = NDB + 2
+ IF (2*(MA(L)+1) < MBASE) GO TO 140
+ M2 = 2
+ IF (INT(MBASE-AINT (MBASE/M2)*M2) == 0) THEN
+ IF (2*MA(L) < MBASE) GO TO 140
+ IF (2*MA(L) == MBASE) THEN
+ IF (L <= NDA) THEN
+ DO J = L, NDA
+ IF (MA(J+1) > 0) GO TO 110
+ ENDDO
+ ENDIF
+
+! Round to even.
+
+ IF (INT(MA(N1)-AINT (MA(N1)/M2)*M2) == 0) GO TO 140
+ ENDIF
+ ELSE
+ IF (2*MA(L)+1 == MBASE) THEN
+ IF (L <= NDA) THEN
+ DO J = L, NDA
+ IF (2*(MA(J+1)+1) < MBASE) GO TO 140
+ IF (2*MA(J+1) > MBASE) GO TO 110
+ ENDDO
+ GO TO 140
+ ENDIF
+ ENDIF
+ ENDIF
+
+ 110 MA(NDB+1) = MA(NDB+1) + 1
+ MA(NDB+2) = 0
+
+! Check whether there was a carry in the rounded digit.
+
+ KB = NDB + 1
+ IF (KB >= 3) THEN
+ K = KB + 1
+ DO J = 3, KB
+ K = K - 1
+ IF (MA(K) < MBASE) GO TO 120
+ MKT = AINT (MA(K)/MBASE)
+ MA(K-1) = MA(K-1) + MKT
+ MA(K) = MA(K) - MKT*MBASE
+ ENDDO
+ ENDIF
+
+! If there is a carry in the first digit then the exponent
+! must be adjusted and the number shifted right.
+
+ IF (MA(2) < MBASE) GO TO 120
+ IF (KB >= 4) THEN
+ K = KB + 1
+ DO J = 4, KB
+ K = K - 1
+ MA(K) = MA(K-1)
+ ENDDO
+ ENDIF
+
+ MKT = AINT (MA(2)/MBASE)
+ IF (KB >= 3) MA(3) = MA(2) - MKT*MBASE
+ MA(2) = MKT
+ MA(1) = MA(1) + 1
+
+ 120 IF (MBS < 0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1
+ GO TO 140
+
+! Extend to NDB digits by padding with zeros.
+
+ 130 DO J = NDA+2, NDB+1
+ MA(J) = 0
+ ENDDO
+
+! Check for overflow or underflow.
+
+ 140 IF (ABS(MA(1)) > MXEXP) THEN
+ IF (MA(1) /= MUNKNO .OR. MA(2) /= 1) THEN
+ NCALL = NCALL + 1
+ CALL FMTRAP(MA)
+ NCALL = NCALL - 1
+ ENDIF
+ IF (MA(1) == MUNKNO) KFLAG = -4
+ ENDIF
+
+ IF (KACCSW == 1) THEN
+ JT = NINT(LOG(REAL(ABS(MA(2))+1))/0.69315)
+ IF (NDB > NDA) THEN
+ MA(0) = NINT((NDB-1)*ALOGM2 + JT)
+ ELSE
+ MA(0) = MIN(NINT((NDB-1)*ALOGM2+JT),INT(MACCA))
+ ENDIF
+ ENDIF
+ RETURN
+ END SUBROUTINE FMEQ2_R1
+
+ SUBROUTINE FMEQU(MA,MB,NDA,NDB)
+
+! Set MB (having NDB digits) equal to MA (having NDA digits).
+
+! If MB has less precision than MA, the result is rounded to
+! NDB digits.
+
+! If MB has more precision, the result has its precision extended
+! by padding with zero digits on the right.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER NDA,NDB
+
+ CALL FMEQ2(MA,MB,NDA,NDB)
+
+ RETURN
+ END SUBROUTINE FMEQU
+
+ SUBROUTINE FMEXIT(MT,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
+
+! Upon exit from an FM routine the result MT (having precision NDIG)
+! is rounded and returned in MC (having precision NDSAVE).
+! The values of NDIG, MXEXP, and KACCSW are restored.
+! KOVUN is nonzero if one of the routine's input arguments was overflow
+! or underflow.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MT(-1:LUNPCK),MC(-1:LUNPCK),MXSAVE
+ INTEGER NDSAVE,KASAVE,KOVUN
+
+ INTEGER KFSAVE,KWRNSV
+
+ KWRNSV = KWARN
+ KWARN = 0
+ MXEXP = MXSAVE
+ KFSAVE = KFLAG
+ CALL FMEQ2(MT,MC,NDIG,NDSAVE)
+ IF (KFLAG /= -5 .AND. KFLAG /= -6) KFLAG = KFSAVE
+ NDIG = NDSAVE
+ KWARN = KWRNSV
+ IF (KFLAG == 1) KFLAG = 0
+ IF ((MC(1) == MUNKNO .AND. KFLAG /= -9) &
+ .OR. (MC(1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MC(1) == MEXPOV .AND. KOVUN == 0)) CALL FMWARN
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ NCALL = NCALL - 1
+ KACCSW = KASAVE
+ RETURN
+ END SUBROUTINE FMEXIT
+
+ SUBROUTINE FMEXP(MA,MB)
+
+! MB = EXP(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ CHARACTER(155) :: STRING
+ REAL (KIND(1.0D0)) :: M1,MA1,MA2,MACCA,MACMAX,MAS,MXSAVE
+ INTEGER IEXTRA,J,K,KASAVE,KOVUN,KRESLT,KT,KWRNSV,NDMB, &
+ NDSAVE,NDSV,NMETHD
+ REAL XMA,XOV
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN
+ CALL FMENTR('FMEXP ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMEXP '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ MA1 = MA(1)
+ MA2 = MA(2)
+ MAS = MA(-1)
+
+ MACCA = MA(0)
+ CALL FMEQ2(MA,MB,NDSAVE,NDIG)
+ MB(0) = NINT(NDIG*ALOGM2)
+
+! Check for obvious underflow or overflow.
+! XOV is LN(LN(slightly above overflow))
+! XMA is LN(LN(EXP(MA))) approximately.
+
+ XOV = LOG(1.01*REAL(MXEXP)) + LOG(ALOGMB)
+ M1 = 1
+ XMA = LOG(REAL(MAX(ABS(MA2),M1))) - ALOGMB + &
+ REAL(MA1)*ALOGMB
+
+ 110 IF (XMA >= XOV) THEN
+ CALL FMIM(0,MB)
+ IF (MAS > 0) THEN
+ KFLAG = -5
+ CALL FMST2M('OVERFLOW',MB)
+ ELSE
+ KFLAG = -6
+ CALL FMST2M('UNDERFLOW',MB)
+ ENDIF
+ NDIG = NDSAVE
+ MXEXP = MXSAVE
+ KACCSW = KASAVE
+ CALL FMWARN
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+! Split MA into integer and fraction parts.
+! Work with a positive argument.
+! M02 = integer part of ABS(MA)
+! MB = fraction part of ABS(MA)
+
+ MB(-1) = 1
+ CALL FMINT(MB,M02)
+ CALL FMSUB_R1(MB,M02)
+
+! If the integer part is not zero, use FMIPWR to compute
+! E**(M02). If M02 is too large to represent as a one word
+! integer, the definition of MXEXP insures that E**(M02)
+! overflows or underflows.
+
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMM2I(M02,KT)
+ KWARN = KWRNSV
+ IF (KFLAG /= 0) THEN
+ XMA = XOV
+ GO TO 110
+ ENDIF
+ IF (KT > 0) THEN
+
+! Compute IEXTRA, the number of extra digits required
+! to get EXP(KT) correct to the current precision.
+
+ IEXTRA = INT(LOG(REAL(KT))/ALOGMB + 0.5)
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(MB,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ IF (NCALL == 1) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',MB)
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ ELSE
+ CALL FMEQ2_R1(MB,NDIG-IEXTRA,NDG2MX)
+ NDIG = NDG2MX
+ ENDIF
+ ENDIF
+
+! Check whether the current precision of e is large
+! enough.
+
+ IF (MBSE /= MBASE .OR. NDIG > NDIGE) THEN
+ NDMB = INT(150.0*2.302585/ALOGMB)
+ IF (NDMB >= NDIG) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDMB,NDG2MX)
+ STRING = '2.718281828459045235360287471352662497757247'// &
+ '09369995957496696762772407663035354759457138217852516'// &
+ '6427427466391932003059921817413596629043572900334295261'
+ CALL FMST2M(STRING,MESAV)
+ MESAV(0) = NINT(NDIG*ALOGM2)
+ MBSE = MBASE
+ NDIGE = NDIG
+ IF (ABS(MESAV(1)) > 10) NDIGE = 0
+ NDIG = NDSV
+ ELSE
+ NDSV = NDIG
+ NDIG = MIN(NDIG+2,NDG2MX)
+ CALL FMI2M(1,MESAV)
+ CALL FMEXP2(MESAV,M09)
+ CALL FMEQ(M09,MESAV)
+ MESAV(0) = NINT(NDIG*ALOGM2)
+ MBSE = MBASE
+ NDIGE = NDIG
+ IF (ABS(MESAV(1)) > 10) NDIGE = 0
+ NDIG = NDSV
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+! Now do the fraction part of MA and combine the results.
+
+ KWRNSV = KWARN
+ KWARN = 0
+ NMETHD = 1
+ IF (NDIG > 50) NMETHD = 2
+ IF (MB(2) /= 0 .AND. KT > 0 .AND. NMETHD == 1) THEN
+ CALL FMEXP2(MB,M09)
+ CALL FMEQ(M09,MB)
+ CALL FMIPWR(MESAV,KT,M03)
+ CALL FMMPY_R1(MB,M03)
+ ELSE IF (MB(2) /= 0 .AND. KT == 0 .AND. NMETHD == 1) THEN
+ CALL FMEXP2(MB,M09)
+ CALL FMEQ(M09,MB)
+ ELSE IF (MB(2) /= 0 .AND. KT > 0 .AND. NMETHD == 2) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDIG+NGRD21,NDG2MX)
+ CALL FMEQ2_R1(MB,NDSV,NDIG)
+ IF (MB(1) >= 0) THEN
+ CALL FMCSH2(MB,M09)
+ CALL FMEQ(M09,MB)
+ CALL FMSQR(MB,M03)
+ CALL FMI2M(-1,M02)
+ CALL FMADD_R1(M03,M02)
+ CALL FMSQRT_R1(M03)
+ CALL FMADD_R1(MB,M03)
+ ELSE
+ CALL FMSNH2(MB,M09)
+ CALL FMEQ(M09,MB)
+ CALL FMSQR(MB,M03)
+ CALL FMI2M(1,M02)
+ CALL FMADD_R1(M03,M02)
+ CALL FMSQRT_R1(M03)
+ CALL FMADD_R1(MB,M03)
+ ENDIF
+ NDIG = NDSV
+ CALL FMIPWR(MESAV,KT,M03)
+ CALL FMMPY_R1(MB,M03)
+ ELSE IF (MB(2) /= 0 .AND. KT == 0 .AND. NMETHD == 2) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDIG+NGRD21,NDG2MX)
+ CALL FMEQ2_R1(MB,NDSV,NDIG)
+ IF (MB(1) >= 0) THEN
+ CALL FMCSH2(MB,M09)
+ CALL FMEQ(M09,MB)
+ CALL FMSQR(MB,M03)
+ CALL FMI2M(-1,M02)
+ CALL FMADD_R1(M03,M02)
+ CALL FMSQRT_R1(M03)
+ CALL FMADD_R1(MB,M03)
+ ELSE
+ CALL FMSNH2(MB,M09)
+ CALL FMEQ(M09,MB)
+ CALL FMSQR(MB,M03)
+ CALL FMI2M(1,M02)
+ CALL FMADD_R1(M03,M02)
+ CALL FMSQRT_R1(M03)
+ CALL FMADD_R1(MB,M03)
+ ENDIF
+ NDIG = NDSV
+ ELSE IF (MB(2) == 0 .AND. KT > 0) THEN
+ CALL FMIPWR(MESAV,KT,MB)
+ ELSE
+ CALL FMI2M(1,MB)
+ ENDIF
+
+! Invert if MA was negative.
+
+ IF (MAS < 0) THEN
+ CALL FMI2M(1,M02)
+ CALL FMDIV_R2(M02,MB)
+ ENDIF
+ KWARN = KWRNSV
+
+! Round the result and return.
+
+ MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMEXP
+
+ SUBROUTINE FMEXP2(MA,MB)
+
+! MB = EXP(MA)
+
+! Internal exponential routine (called with 0 < MA <= 1).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent
+! sums. Increasing this value will begin to improve the
+! speed of EXP when the base is large and precision exceeds
+! about 1,500 decimal digits.
+
+ REAL (KIND(1.0D0)) :: MAXVAL
+ INTEGER J,J2,K,K2,KPT,KTWO,L,L2,N2,NBIG,NBOT,NDSAV1,NDSAVE, &
+ NTERM,NTOP
+ REAL ALOG2,ALOGT,B,T,TJ,XN
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ NDSAVE = NDIG
+ IF (MA(1) == 1) THEN
+
+! Here the special case EXP(1.0) is computed.
+! Use the direct series e = 1/0! + 1/1! + 1/2! + ...
+! Do as much of the work as possible using small integers
+! to minimize the number of FM calls.
+! Reduce NDIG while computing each term in the
+! sum as the terms get smaller.
+
+ T = NDIG
+ XN = T*ALOGMB/LOG(T)
+ K = INT(LOG(XN)/ALOGMB)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ IF (NCALL == 1) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MB)
+ RETURN
+ ELSE
+ NDIG = NDG2MX
+ ENDIF
+ ENDIF
+ NDSAV1 = NDIG
+
+ CALL FMI2M(2,MB)
+ CALL FMI2M(1,M02)
+ J = 2
+ NBIG = INT(MXBASE)
+
+ 110 NTOP = 1
+ NBOT = J
+ 120 IF (NBOT > NBIG/(J+1)) GO TO 130
+ J = J + 1
+ NTOP = J*NTOP + 1
+ NBOT = J*NBOT
+ GO TO 120
+
+ 130 CALL FMDIVI_R1(M02,NBOT)
+ IF (NTOP > 1) THEN
+ CALL FMMPYI(M02,NTOP,M03)
+ NDIG = NDSAV1
+ CALL FMADD_R1(MB,M03)
+ NDIG = NDSAV1 - INT(MB(1)-M03(1))
+ ELSE
+ NDIG = NDSAV1
+ CALL FMADD_R1(MB,M02)
+ NDIG = NDSAV1 - INT(MB(1)-M02(1))
+ ENDIF
+ IF (NDIG < 2) NDIG = 2
+ IF (KFLAG /= 1) THEN
+ J = J + 1
+ GO TO 110
+ ENDIF
+ NDIG = NDSAVE
+ CALL FMI2M(-1,M02)
+ CALL FMADD(MB,M02,M03)
+ KFLAG = 0
+ RETURN
+ ENDIF
+
+! Here is the general case. Compute EXP(MA) where
+! 0 < MA < 1.
+
+! Use the direct series
+! EXP(X) = 1 + X + X**2/2! + X**3/3! + ...
+
+! The argument will be halved K2 times before the series
+! is summed. The series will be added as J2 concurrent
+! series. The approximately optimal values of K2 and J2
+! are now computed to try to minimize the time required.
+! N2 is the approximate number of terms of the series that
+! will be needed, and L2 guard digits will be carried.
+
+ B = REAL(MBASE)
+ K = NGRD52
+ T = MAX(NDIG-K,2)
+ ALOG2 = REAL(DLOGTW)
+ ALOGT = LOG(T)
+ TJ = 0.051*ALOGMB*T**0.3333 + 1.85
+ J2 = INT(TJ)
+ J2 = MAX(1,MIN(J2,LJSUMS/NDG2MX))
+ K2 = INT(1.13*SQRT(T*ALOGMB/TJ) - 0.5*ALOGT + 4.5)
+
+ L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B + &
+ REAL(MA(3))/(B*B)))/ALOG2 - 0.3)
+ K2 = K2 - L
+ IF (L < 0) L = 0
+ IF (K2 < 0) THEN
+ K2 = 0
+ J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2)) + .33)
+ ENDIF
+ IF (J2 <= 1) J2 = 1
+
+ N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG2))
+ L2 = INT(LOG(REAL(N2)+2.0**K2)/ALOGMB)
+ NDIG = NDIG + L2
+ IF (NDIG > NDG2MX) THEN
+ IF (NCALL == 1) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MB)
+ RETURN
+ ELSE
+ NDIG = NDG2MX
+ ENDIF
+ ENDIF
+ NDSAV1 = NDIG
+
+! Halve the argument K2 times.
+
+ CALL FMEQ2(MA,M02,NDSAVE,NDIG)
+ KTWO = 1
+ MAXVAL = MXBASE/2
+ IF (K2 > 0) THEN
+ DO J = 1, K2
+ KTWO = 2*KTWO
+ IF (KTWO > MAXVAL) THEN
+ CALL FMDIVI_R1(M02,KTWO)
+ KTWO = 1
+ ENDIF
+ ENDDO
+ IF (KTWO > 1) CALL FMDIVI_R1(M02,KTWO)
+ ENDIF
+
+! Sum the series X + X**2/2! + X**3/3! + ....
+! Split into J2 concurrent sums and reduce NDIG while
+! computing each term in the sum as the terms get smaller.
+
+ CALL FMEQ(M02,MB)
+ NTERM = 1
+ DO J = 1, J2
+ CALL FMDIVI_R1(MB,NTERM)
+ NTERM = NTERM + 1
+ KPT = (J-1)*(NDIG+3)
+ CALL FMEQ(MB,MJSUMS(KPT-1))
+ ENDDO
+ IF (M02(1) < -NDIG) GO TO 150
+ CALL FMIPWR(M02,J2,M03)
+
+ 140 CALL FMMPY_R1(MB,M03)
+ DO J = 1, J2
+ CALL FMDIVI_R1(MB,NTERM)
+ KPT = (J-1)*(NDSAV1+3)
+ NDIG = NDSAV1
+ CALL FMADD_R1(MJSUMS(KPT-1),MB)
+ IF (KFLAG /= 0) GO TO 150
+ NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-MB(1))
+ IF (NDIG < 2) NDIG = 2
+ NTERM = NTERM + 1
+ ENDDO
+ GO TO 140
+
+! Put the J2 separate sums back together.
+
+ 150 KFLAG = 0
+ KPT = (J2-1)*(NDIG+3)
+ CALL FMEQ(MJSUMS(KPT-1),M03)
+ IF (J2 >= 2) THEN
+ DO J = 2, J2
+ CALL FMMPY_R2(M02,M03)
+ KPT = (J2-J)*(NDIG+3)
+ CALL FMADD_R1(M03,MJSUMS(KPT-1))
+ ENDDO
+ ENDIF
+
+! Reverse the effect of halving the argument to
+! compute EXP(MA).
+
+ NDIG = NDSAV1
+ IF (K2 > 0) THEN
+ IF (NDSAVE <= 20) THEN
+ CALL FMI2M(2,M02)
+ DO J = 1, K2
+ CALL FMADD(M03,M02,MB)
+ CALL FMMPY_R2(MB,M03)
+ ENDDO
+ ELSE
+ DO J = 1, K2
+ CALL FMSQR(M03,MB)
+ CALL FMADD(M03,M03,M02)
+ CALL FMADD(MB,M02,M03)
+ ENDDO
+ ENDIF
+ ENDIF
+ CALL FMI2M(1,M02)
+ CALL FMADD(M02,M03,MB)
+
+ CALL FMEQ2_R1(MB,NDSAV1,NDSAVE)
+ NDIG = NDSAVE
+
+ RETURN
+ END SUBROUTINE FMEXP2
+
+ SUBROUTINE FMFLAG(K)
+
+! Return the internal condition variable KFLAG to the user.
+
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER K
+ K = KFLAG
+ RETURN
+ END SUBROUTINE FMFLAG
+
+ SUBROUTINE FMFORM(FORM,MA,STRING)
+
+! Convert an FM number (MA) to a character string base 10 (STRING)
+! using character string FORM format.
+
+! FORM can be one of these types: Iw, Fw.d, Ew.d, 1PEw.d
+! for positive integers w,d.
+
+! If Iw format is used and MA is not exactly an integer, then the
+! nearest integer to MA is printed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(*) :: FORM,STRING
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ CHARACTER(20) :: FORMB
+ INTEGER J,JF1SAV,JF2SAV,JPT,K1,K2,K3,KD,KSAVE,KWD,KWI,LAST, &
+ LB,LENGFM,LENGST,LFIRST,ND,NEXP
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMFORM'
+
+ KSAVE = KFLAG
+ JF1SAV = JFORM1
+ JF2SAV = JFORM2
+ STRING = ' '
+ LENGFM = LEN(FORM)
+ LENGST = LEN(STRING)
+ KWI = 75
+ KWD = 40
+
+ IF (INDEX(FORM,'I') > 0 .OR. INDEX(FORM,'i') > 0) THEN
+ K1 = MAX(INDEX(FORM,'I'),INDEX(FORM,'i')) + 1
+ K2 = LENGFM
+ WRITE (FORMB,"('(I',I5,')')") K2-K1+1
+ IF (K2 >= K1) THEN
+ READ (FORM(K1:K2),FORMB) KWI
+ ELSE
+ KWI = LENGST
+ ENDIF
+ KWI = MAX(1,MIN(KWI,LENGST))
+ JFORM1 = 2
+ JFORM2 = 0
+ KWD = KWI + 21
+ IF (KWD > LMBUFF) GO TO 120
+ CALL FMNINT(MA,M02)
+ IF (M02(2) /= 0) THEN
+ CALL FMOUT(M02,CMBUFF,KWD)
+ ELSE
+ DO J = 1, KWD
+ CMBUFF(J) = ' '
+ ENDDO
+ CMBUFF(2) = '0'
+ ENDIF
+ LFIRST = 1
+ LAST = 1
+ DO J = 1, KWD
+ IF (CMBUFF(KWD+1-J) /= ' ') LFIRST = KWD+1-J
+ IF (CMBUFF(J) /= ' ') LAST = J
+ ENDDO
+ JPT = 1
+ IF (LAST-LFIRST+1 > KWI) GO TO 120
+ IF (LAST <= KWI) THEN
+ DO J = LAST, LFIRST, -1
+ JPT = KWI - LAST + J
+ STRING(JPT:JPT) = CMBUFF(J)
+ ENDDO
+ DO J = 1, JPT-1
+ STRING(J:J) = ' '
+ ENDDO
+ ELSE
+ DO J = LFIRST, LAST
+ JPT = KWI - LAST + J
+ STRING(JPT:JPT) = CMBUFF(J)
+ ENDDO
+ ENDIF
+ ELSE IF (INDEX(FORM,'F') > 0 .OR. INDEX(FORM,'f') > 0) THEN
+ K1 = MAX(INDEX(FORM,'F'),INDEX(FORM,'f')) + 1
+ K2 = INDEX(FORM,'.')
+ K3 = LENGFM
+ IF (K2 > K1) THEN
+ WRITE (FORMB,"('(I',I5,')')") K2-K1
+ READ (FORM(K1:K2-1),FORMB) KWI
+ ELSE
+ KWI = 50
+ ENDIF
+ IF (K3 > K2) THEN
+ WRITE (FORMB,"('(I',I5,')')") K3-K2
+ READ (FORM(K2+1:K3),FORMB) KD
+ ELSE
+ KD = 0
+ ENDIF
+ KWI = MAX(1,MIN(KWI,LENGST))
+ KD = MAX(0,MIN(KD,KWI-2))
+ JFORM1 = 2
+ JFORM2 = KD
+ ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
+ IF (ND < 2) ND = 2
+ NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
+ LB = MAX(JFORM2+NEXP,ND+NEXP)
+ LB = MIN(LB,LMBUFF)
+ KWD = LB
+ CALL FMOUT(MA,CMBUFF,KWD)
+ LFIRST = 1
+ LAST = 1
+ DO J = 1, KWD
+ IF (CMBUFF(KWD+1-J) /= ' ') LFIRST = KWD+1-J
+ IF (CMBUFF(J) /= ' ') LAST = J
+ ENDDO
+ IF (LAST-LFIRST+1 > KWI) THEN
+
+! Not enough room for this F format, or FMOUT converted
+! it to E format to avoid showing no significant digits.
+! See if a shortened form will fit in E format.
+
+ NEXP = INT(LOG10((ABS(REAL(MA(1)))+1)*LOG10(REAL(MBASE))+1)+1)
+ ND = KWI - NEXP - 5
+ IF (ND < 1) THEN
+ GO TO 120
+ ELSE
+ JFORM1 = 0
+ JFORM2 = ND
+ CALL FMOUT(MA,CMBUFF,KWI)
+ LFIRST = 1
+ LAST = 1
+ DO J = 1, KWI
+ IF (CMBUFF(KWI+1-J) /= ' ') LFIRST = KWI+1-J
+ IF (CMBUFF(J) /= ' ') LAST = J
+ ENDDO
+ ENDIF
+ ENDIF
+ JPT = 1
+ IF (LAST <= KWI) THEN
+ DO J = LAST, LFIRST, -1
+ JPT = KWI - LAST + J
+ STRING(JPT:JPT) = CMBUFF(J)
+ ENDDO
+ DO J = 1, JPT-1
+ STRING(J:J) = ' '
+ ENDDO
+ ELSE
+ DO J = LFIRST, LAST
+ JPT = KWI - LAST + J
+ STRING(JPT:JPT) = CMBUFF(J)
+ ENDDO
+ ENDIF
+ ELSE IF (INDEX(FORM,'1PE') > 0 .OR. INDEX(FORM,'1pe') > 0) THEN
+ K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1
+ K2 = INDEX(FORM,'.')
+ K3 = LENGFM
+ IF (K2 > K1) THEN
+ WRITE (FORMB,"('(I',I5,')')") K2-K1
+ READ (FORM(K1:K2-1),FORMB) KWI
+ ELSE
+ KWI = 50
+ ENDIF
+ IF (K3 > K2) THEN
+ WRITE (FORMB,"('(I',I5,')')") K3-K2
+ READ (FORM(K2+1:K3),FORMB) KD
+ ELSE
+ KD = 0
+ ENDIF
+ KWI = MAX(1,MIN(KWI,LENGST))
+ KD = MAX(0,MIN(KD,KWI-2))
+ JFORM1 = 1
+ JFORM2 = KD
+ IF (KWI > LMBUFF) GO TO 120
+ CALL FMOUT(MA,CMBUFF,KWI)
+ DO J = KWI, 1, -1
+ IF (J > LENGST) THEN
+ IF (CMBUFF(J) /= ' ') GO TO 120
+ ELSE
+ STRING(J:J) = CMBUFF(J)
+ ENDIF
+ ENDDO
+ ELSE IF (INDEX(FORM,'E') > 0 .OR. INDEX(FORM,'e') > 0) THEN
+ K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1
+ K2 = INDEX(FORM,'.')
+ K3 = LENGFM
+ IF (K2 > K1) THEN
+ WRITE (FORMB,"('(I',I5,')')") K2-K1
+ READ (FORM(K1:K2-1),FORMB) KWI
+ ELSE
+ KWI = 50
+ ENDIF
+ IF (K3 > K2) THEN
+ WRITE (FORMB,"('(I',I5,')')") K3-K2
+ READ (FORM(K2+1:K3),FORMB) KD
+ ELSE
+ KD = 0
+ ENDIF
+ KWI = MAX(1,MIN(KWI,LENGST))
+ KD = MAX(0,MIN(KD,KWI-2))
+ JFORM1 = 0
+ JFORM2 = KD
+ IF (KWI > LMBUFF) GO TO 120
+ CALL FMOUT(MA,CMBUFF,KWI)
+ DO J = KWI, 1, -1
+ IF (J > LENGST) THEN
+ IF (CMBUFF(J) /= ' ') GO TO 120
+ ELSE
+ STRING(J:J) = CMBUFF(J)
+ ENDIF
+ ENDDO
+ ELSE
+ GO TO 120
+ ENDIF
+
+ 110 KFLAG = KSAVE
+ JFORM1 = JF1SAV
+ JFORM2 = JF2SAV
+ NCALL = NCALL - 1
+ RETURN
+
+! Error condition.
+
+ 120 KFLAG = -8
+ DO J = 1, LENGST
+ STRING(J:J) = '*'
+ ENDDO
+ GO TO 110
+ END SUBROUTINE FMFORM
+
+ SUBROUTINE FMFPRT(FORM,MA)
+
+! Print an FM number (MA) on unit KW using character
+! string FORM format.
+
+! FORM can be one of these types: Iw, Fw.d, Ew.d, 1PEw.d
+! for positive integers w,d.
+
+! If Iw format is used and MA is not exactly an integer, then the
+! nearest integer to MA is printed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(*) :: FORM
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ CHARACTER(20) :: FORM2,FORMB
+ INTEGER J,JF1SAV,JF2SAV,JPT,K,K1,K2,K3,KD,KSAVE,KWD,KWI, &
+ LAST,LB,LENGFM,LFIRST,ND,NEXP
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMFPRT'
+
+ KSAVE = KFLAG
+ JF1SAV = JFORM1
+ JF2SAV = JFORM2
+ LENGFM = LEN(FORM)
+ KWI = 75
+ KWD = 40
+
+ IF (INDEX(FORM,'I') > 0 .OR. INDEX(FORM,'i') > 0) THEN
+ K1 = MAX(INDEX(FORM,'I'),INDEX(FORM,'i')) + 1
+ K2 = LENGFM
+ WRITE (FORMB,"('(I',I5,')')") K2-K1+1
+ IF (K2 >= K1) THEN
+ READ (FORM(K1:K2),FORMB) KWI
+ ELSE
+ KWI = 50
+ ENDIF
+ KWI = MAX(1,MIN(KWI,LMBUFF-11))
+ JFORM1 = 2
+ JFORM2 = 0
+ KWD = KWI + 21
+ CALL FMNINT(MA,M02)
+ IF (M02(2) /= 0) THEN
+ CALL FMOUT(M02,CMBUFF,KWD)
+ ELSE
+ DO J = 1, KWD
+ CMBUFF(J) = ' '
+ ENDDO
+ CMBUFF(2) = '0'
+ ENDIF
+ LFIRST = 1
+ LAST = 1
+ DO J = 1, KWD
+ IF (CMBUFF(KWD+1-J) /= ' ') LFIRST = KWD+1-J
+ IF (CMBUFF(J) /= ' ') LAST = J
+ ENDDO
+ JPT = 1
+ IF (LAST-LFIRST+1 > KWI) GO TO 120
+ IF (LAST <= KWI) THEN
+ DO J = LAST, LFIRST, -1
+ JPT = KWI - LAST + J
+ IF (JPT /= J) CMBUFF(JPT) = CMBUFF(J)
+ ENDDO
+ DO J = 1, JPT-1
+ CMBUFF(J) = ' '
+ ENDDO
+ ELSE
+ DO J = LFIRST, LAST
+ JPT = KWI - LAST + J
+ IF (JPT /= J) CMBUFF(JPT) = CMBUFF(J)
+ ENDDO
+ ENDIF
+ ELSE IF (INDEX(FORM,'F') > 0 .OR. INDEX(FORM,'f') > 0) THEN
+ K1 = MAX(INDEX(FORM,'F'),INDEX(FORM,'f')) + 1
+ K2 = INDEX(FORM(1:LENGFM),'.')
+ K3 = LENGFM
+ IF (K2 > K1) THEN
+ WRITE (FORMB,"('(I',I5,')')") K2-K1
+ READ (FORM(K1:K2-1),FORMB) KWI
+ ELSE
+ KWI = 50
+ ENDIF
+ IF (K3 > K2) THEN
+ WRITE (FORMB,"('(I',I5,')')") K3-K2
+ READ (FORM(K2+1:K3),FORMB) KD
+ ELSE
+ KD = 0
+ ENDIF
+ KWI = MAX(1,MIN(KWI,LMBUFF))
+ KD = MAX(0,MIN(KD,KWI-2))
+ JFORM1 = 2
+ JFORM2 = KD
+ ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
+ IF (ND < 2) ND = 2
+ NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
+ LB = MAX(JFORM2+NEXP,ND+NEXP)
+ LB = MIN(LB,LMBUFF)
+ KWD = LB
+ CALL FMOUT(MA,CMBUFF,KWD)
+ LFIRST = 1
+ LAST = 1
+ DO J = 1, KWD
+ IF (CMBUFF(KWD+1-J) /= ' ') LFIRST = KWD+1-J
+ IF (CMBUFF(J) /= ' ') LAST = J
+ ENDDO
+ IF (LAST-LFIRST+1 > KWI) THEN
+
+! Not enough room for this F format, or FMOUT converted
+! it to E format to avoid showing no significant digits.
+! See if a shortened form will fit in E format.
+
+ NEXP = INT(LOG10((ABS(REAL(MA(1)))+1)*LOG10(REAL(MBASE))+1)+1)
+ ND = KWI - NEXP - 5
+ IF (ND < 1) THEN
+ GO TO 120
+ ELSE
+ JFORM1 = 0
+ JFORM2 = ND
+ CALL FMOUT(MA,CMBUFF,KWI)
+ LFIRST = 1
+ LAST = 1
+ DO J = 1, KWI
+ IF (CMBUFF(KWI+1-J) /= ' ') LFIRST = KWI+1-J
+ IF (CMBUFF(J) /= ' ') LAST = J
+ ENDDO
+ ENDIF
+ ENDIF
+ JPT = 1
+ IF (LAST <= KWI) THEN
+ DO J = LAST, LFIRST, -1
+ JPT = KWI - LAST + J
+ IF (JPT /= J) CMBUFF(JPT) = CMBUFF(J)
+ ENDDO
+ DO J = 1, JPT-1
+ CMBUFF(J) = ' '
+ ENDDO
+ ELSE
+ DO J = LFIRST, LAST
+ JPT = KWI - LAST + J
+ IF (JPT /= J) CMBUFF(JPT) = CMBUFF(J)
+ ENDDO
+ ENDIF
+ ELSE IF (INDEX(FORM,'1PE') > 0 .OR. INDEX(FORM,'1pe') > 0) THEN
+ K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1
+ K2 = INDEX(FORM(1:LENGFM),'.')
+ K3 = LENGFM
+ IF (K2 > K1) THEN
+ WRITE (FORMB,"('(I',I5,')')") K2-K1
+ READ (FORM(K1:K2-1),FORMB) KWI
+ ELSE
+ KWI = 50
+ ENDIF
+ IF (K3 > K2) THEN
+ WRITE (FORMB,"('(I',I5,')')") K3-K2
+ READ (FORM(K2+1:K3),FORMB) KD
+ ELSE
+ KD = 0
+ ENDIF
+ KWI = MAX(1,MIN(KWI,LMBUFF))
+ KD = MAX(0,MIN(KD,KWI-2))
+ JFORM1 = 1
+ JFORM2 = KD
+ CALL FMOUT(MA,CMBUFF,KWI)
+ ELSE IF (INDEX(FORM,'E') > 0 .OR. INDEX(FORM,'e') > 0) THEN
+ K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1
+ K2 = INDEX(FORM(1:LENGFM),'.')
+ K3 = LENGFM
+ IF (K2 > K1) THEN
+ WRITE (FORMB,"('(I',I5,')')") K2-K1
+ READ (FORM(K1:K2-1),FORMB) KWI
+ ELSE
+ KWI = 50
+ ENDIF
+ IF (K3 > K2) THEN
+ WRITE (FORMB,"('(I',I5,')')") K3-K2
+ READ (FORM(K2+1:K3),FORMB) KD
+ ELSE
+ KD = 0
+ ENDIF
+ KWI = MAX(1,MIN(KWI,LMBUFF))
+ KD = MAX(0,MIN(KD,KWI-2))
+ JFORM1 = 0
+ JFORM2 = KD
+ CALL FMOUT(MA,CMBUFF,KWI)
+ ELSE
+ GO TO 120
+ ENDIF
+
+ 110 LAST = KWI + 1
+ WRITE (FORM2,"(' (6X,',I3,'A1) ')") KSWIDE-7
+ IF (KFLAG /= -8) KFLAG = KSAVE
+ JFORM1 = JF1SAV
+ JFORM2 = JF2SAV
+ DO J = KWI, 1, -1
+ IF (CMBUFF(J) /= ' ' .OR. J == 1) THEN
+ WRITE (KW,FORM2) (CMBUFF(K),K=1,J)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDDO
+ NCALL = NCALL - 1
+ RETURN
+
+! Error condition.
+
+ 120 KFLAG = -8
+ DO J = 1, KWI
+ CMBUFF(J) = '*'
+ ENDDO
+ GO TO 110
+ END SUBROUTINE FMFPRT
+
+ SUBROUTINE FMGCDI(N1,N2)
+
+! Find the Greatest Common Divisor of N1 and N2, and return both
+! having been divided by their GCD. Both must be positive.
+
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER K1,K2,K3,N1,N2
+
+ K1 = MAX(N1,N2)
+ K2 = MIN(N1,N2)
+ 110 K3 = MOD(K1,K2)
+ IF (K3 == 0) THEN
+ N1 = N1/K2
+ N2 = N2/K2
+ RETURN
+ ELSE
+ K1 = K2
+ K2 = K3
+ GO TO 110
+ ENDIF
+ END SUBROUTINE FMGCDI
+
+ SUBROUTINE FMHTBL
+
+! Initialize two hash tables that are used for character
+! look-up during input conversion.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER J,KPT
+
+ CHARACTER :: LCHARS(21) = (/ &
+ '+','-','0','1','2','3','4','5','6','7','8','9', &
+ '.','E','D','Q','M','e','d','q','m' /)
+ INTEGER :: LTYPES(21) = (/ 1,1,2,2,2,2,2,2,2,2,2,2,3,4,4,4,4,4,4,4,4 /)
+ INTEGER :: LVALS(21) = (/ 1,-1,0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0,0,0,0 /)
+
+ DO J = LHASH1, LHASH2
+ KHASHT(J) = 5
+ KHASHV(J) = 0
+ ENDDO
+ DO J = 1, 21
+ KPT = ICHAR(LCHARS(J))
+ IF (KPT < LHASH1 .OR. KPT > LHASH2) THEN
+ WRITE (KW, &
+ "(/' Error in input conversion.'/" // &
+ "' ICHAR function was out of range for the current'," // &
+ "' dimensions.'/' ICHAR(''',A,''') gave the value '," // &
+ "I12,', which is outside the currently'/' dimensioned'," // &
+ "' bounds of (',I5,':',I5,') for variables KHASHT '," // &
+ "'and KHASHV.'/' Re-define the two parameters '," // &
+ "'LHASH1 and LHASH2 so the dimensions will'/' contain'," // &
+ "' all possible output values from ICHAR.'//)" &
+ ) LCHARS(J),KPT,LHASH1,LHASH2
+ ELSE
+ KHASHT(KPT) = LTYPES(J)
+ KHASHV(KPT) = LVALS(J)
+ ENDIF
+ ENDDO
+ LHASH = 1
+ END SUBROUTINE FMHTBL
+
+ SUBROUTINE FMI2M(IVAL,MA)
+
+! MA = IVAL
+
+! Convert an integer to FM format.
+
+! The conversion is exact if IVAL is less than MBASE**NDIG,
+! otherwise the result is an approximation.
+
+! This routine performs the trace printing for the conversion.
+! FMIM is used to do the arithmetic.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER IVAL
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMI2M '
+ CALL FMNTRI(2,IVAL,1)
+
+ CALL FMIM(IVAL,MA)
+
+ CALL FMNTR(1,MA,MA,1,1)
+ ELSE
+ CALL FMIM(IVAL,MA)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMI2M
+
+ SUBROUTINE FMIM(IVAL,MA)
+
+! MA = IVAL. Internal integer conversion routine.
+
+! The conversion is exact if IVAL is less than MBASE**NDIG.
+! Otherwise FMDM is used to get an approximation.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER IVAL
+
+ DOUBLE PRECISION X
+ REAL (KIND(1.0D0)) :: MK,ML,MVAL
+ INTEGER J,JM2,KB,KB1,N1,NMVAL,NV2
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KFLAG = 0
+ N1 = NDIG + 1
+
+ MVAL = ABS(IVAL)
+ NMVAL = INT(MVAL)
+ NV2 = NMVAL - 1
+ IF (ABS(IVAL) > MXBASE .OR. NMVAL /= ABS(IVAL) .OR. &
+ NV2 /= ABS(IVAL)-1) THEN
+ CALL FMIMS(IVAL,MA)
+ GO TO 120
+ ENDIF
+
+! Check for small IVAL.
+
+ IF (MVAL < MBASE) THEN
+ DO J = 3, N1
+ MA(J) = 0
+ ENDDO
+ IF (IVAL >= 0) THEN
+ MA(2) = IVAL
+ MA(-1) = 1
+ ELSE
+ MA(2) = -IVAL
+ MA(-1) = -1
+ ENDIF
+ IF (IVAL == 0) THEN
+ MA(1) = 0
+ ELSE
+ MA(1) = 1
+ ENDIF
+ GO TO 120
+ ENDIF
+
+! Compute and store the digits, right to left.
+
+ MA(1) = 0
+ J = NDIG + 1
+
+ 110 MK = AINT (MVAL/MBASE)
+ ML = MVAL - MK*MBASE
+ MA(1) = MA(1) + 1
+ MA(J) = ML
+ IF (MK > 0) THEN
+ MVAL = MK
+ J = J - 1
+ IF (J >= 2) GO TO 110
+
+! Here IVAL cannot be expressed exactly.
+
+ X = IVAL
+ CALL FMDM(X,MA)
+ RETURN
+ ENDIF
+
+! Normalize MA.
+
+ KB = N1 - J + 2
+ JM2 = J - 2
+ DO J = 2, KB
+ MA(J) = MA(J+JM2)
+ ENDDO
+ KB1 = KB + 1
+ IF (KB1 <= N1) THEN
+ DO J = KB1, N1
+ MA(J) = 0
+ ENDDO
+ ENDIF
+
+ MA(-1) = 1
+ IF (IVAL < 0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1
+
+ 120 MA(0) = NINT(NDIG*ALOGM2)
+ RETURN
+ END SUBROUTINE FMIM
+
+ SUBROUTINE FMIMS(IVAL,MA)
+
+! MA = IVAL. Internal integer conversion routine.
+
+! This routine is called when M-variable precision is less than
+! Integer precision. This often happens when single precision
+! is chosen for M-variables.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER IVAL
+
+ DOUBLE PRECISION X
+ REAL (KIND(1.0D0)) :: ML
+ INTEGER J,JM2,KB,KB1,KBASE,KMK,KVAL,N1
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KFLAG = 0
+ N1 = NDIG + 1
+
+! Check for small IVAL.
+
+ KVAL = ABS(IVAL)
+ KBASE = INT(MBASE)
+ IF (KVAL < KBASE) THEN
+ DO J = 3, N1
+ MA(J) = 0
+ ENDDO
+ IF (IVAL >= 0) THEN
+ MA(2) = IVAL
+ MA(-1) = 1
+ ELSE
+ MA(2) = -IVAL
+ MA(-1) = -1
+ ENDIF
+ IF (IVAL == 0) THEN
+ MA(1) = 0
+ ELSE
+ MA(1) = 1
+ ENDIF
+ GO TO 120
+ ENDIF
+
+! Compute and store the digits, right to left.
+
+ MA(1) = 0
+ J = NDIG + 1
+
+ 110 KMK = (KVAL/KBASE)
+ ML = KVAL - KMK*KBASE
+ MA(1) = MA(1) + 1
+ MA(J) = ML
+ IF (KMK > 0) THEN
+ KVAL = KMK
+ J = J - 1
+ IF (J >= 2) GO TO 110
+
+! Here IVAL cannot be expressed exactly.
+
+ X = IVAL
+ CALL FMDM(X,MA)
+ RETURN
+ ENDIF
+
+! Normalize MA.
+
+ KB = N1 - J + 2
+ JM2 = J - 2
+ DO J = 2, KB
+ MA(J) = MA(J+JM2)
+ ENDDO
+ KB1 = KB + 1
+ IF (KB1 <= N1) THEN
+ DO J = KB1, N1
+ MA(J) = 0
+ ENDDO
+ ENDIF
+
+ MA(-1) = 1
+ IF (IVAL < 0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1
+
+ 120 MA(0) = NINT(NDIG*ALOGM2)
+ RETURN
+ END SUBROUTINE FMIMS
+
+ SUBROUTINE FMINP(LINE,MA,LA,LB)
+
+! Convert an array of characters to floating point multiple precision
+! format.
+
+! LINE is an A1 character array of length LB to be converted
+! to FM format and returned in MA.
+! LA is a pointer telling the routine where in the array to begin
+! the conversion. This allows more than one number to be stored
+! in an array and converted in place.
+! LB is a pointer to the last character of the field for that number.
+
+! The input number may be in integer or any real format.
+
+! KESWCH = 1 causes input to FMINP with no digits before the exponent
+! letter to be treated as if there were a leading '1'.
+! This is sometimes better for interactive input:
+! 'E7' converts to 10.0**7.
+! = 0 causes a leading zero to be assumed. This gives
+! compatibility with Fortran:
+! 'E7' converts to 0.0.
+
+! In exponential format the 'E' may also be 'D', 'Q', or 'M'.
+
+! So that FMINP will convert any output from FMOUT, LINE is tested
+! to see if the input is one of the special symbols +OVERFLOW,
+! -OVERFLOW, +UNDERFLOW, -UNDERFLOW, or UNKNOWN.
+! For user input the abbreviations OVFL, UNFL, UNKN may be used.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER LA,LB
+ CHARACTER LINE(LB)
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: M2,MNDSV1,MXSAV1,MXSAV2
+ INTEGER J,JSTATE,K,K10PWR,KASAVE,KDFLAG,KEXP,KF1,KF2,KMN,KOF,KPOWER, &
+ KPT,KRSAVE,KSIGN,KSIGNX,KSTART,KSTOP,KTENEX,KTENF1,KTENF2, &
+ KTYPE,KUF,KUK,KVAL,KWRNSV,LARGE,N2,NDSAV1,NDSAVE
+
+! Simulate a finite-state automaton to scan the input line
+! and build the number. States of the machine:
+
+! 1. Initial entry to the subroutine
+! 2. Sign of the number
+! 3. Scanning digits before a decimal point
+! 4. Decimal point
+! 5. Scanning digits after a decimal point
+! 6. E, D, Q, or M -- precision indicator before the exponent
+! 7. Sign of the exponent
+! 8. Scanning exponent
+! 9. Syntax error
+
+! Character types recognized by the machine:
+
+! 1. Sign (+,-)
+! 2. Numeral (0,1,...,9)
+! 3. Decimal point (.)
+! 4. Precision indicator (E,D,Q,M)
+! 5. Illegal character for number
+
+! All blanks are ignored. The analysis of the number proceeds as
+! follows: If the simulated machine is in state JSTATE and a character
+! of type JTYPE is encountered the new state of the machine is given by
+! JTRANS(JSTATE,JTYPE).
+
+! In this initialization note the array is loaded by columns.
+
+! State 1 2 3 4 5 6 7 8
+
+ INTEGER :: JTRANS(8,4) = RESHAPE( (/ &
+ 2, 9, 9, 9, 9, 7, 9, 9, &
+ 3, 3, 3, 5, 5, 8, 8, 8, &
+ 4, 4, 4, 9, 9, 9, 9, 9, &
+ 6, 6, 6, 6, 6, 9, 9, 9 /) &
+ , (/ 8,4 /) )
+
+ CHARACTER :: KOVFL(4) = (/ 'O','V','F','L' /)
+ CHARACTER :: KUNFL(4) = (/ 'U','N','F','L' /)
+ CHARACTER :: KUNKN(4) = (/ 'U','N','K','N' /)
+ CHARACTER :: LOVFL(4) = (/ 'o','v','f','l' /)
+ CHARACTER :: LUNFL(4) = (/ 'u','n','f','l' /)
+ CHARACTER :: LUNKN(4) = (/ 'u','n','k','n' /)
+
+! To avoid recursion, FMINP calls only internal arithmetic
+! routines (FMADD2, FMMPY2, ...), so no trace printout is
+! done during a call to FMINP.
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMINP '
+
+! Raise the call stack again, since the internal
+! routines don't.
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMINP '
+ NDSAVE = NDIG
+ KASAVE = KACCSW
+ KACCSW = 0
+ KRSAVE = KROUND
+ KROUND = 1
+ KFLAG = 0
+ MXSAV1 = MXEXP
+ MXSAV2 = MXEXP2
+ IF (MXEXP < 100000) THEN
+ MXEXP = 100000
+ MXEXP2 = 201000
+ ENDIF
+
+! Initialize two hash tables that are used for character
+! look-up during input conversion.
+
+ IF (LHASH == 0) CALL FMHTBL
+
+! Check for special symbols.
+
+ KMN = 1
+ KOF = 1
+ KUF = 1
+ KUK = 1
+ DO J = LA, LB
+ KPT = ICHAR(LINE(J))
+ IF (KPT >= LHASH1 .AND. KPT <= LHASH2) THEN
+ KTYPE = KHASHT(KPT)
+ IF (KTYPE == 2) GO TO 110
+ ENDIF
+ IF (LINE(J) == '-') KMN = -1
+ IF (LINE(J) == KOVFL(KOF) .OR. LINE(J) == LOVFL(KOF)) THEN
+ KOF = KOF + 1
+ IF (KOF == 5) THEN
+ CALL FMIM(0,MA)
+ MA(1) = MEXPOV
+ MA(2) = 1
+ MA(-1) = KMN
+ MA(0) = NINT(NDIG*ALOGM2)
+ GO TO 150
+ ENDIF
+ ENDIF
+ IF (LINE(J) == KUNFL(KUF) .OR. LINE(J) == LUNFL(KOF)) THEN
+ KUF = KUF + 1
+ IF (KUF == 5) THEN
+ CALL FMIM(0,MA)
+ MA(1) = MEXPUN
+ MA(2) = 1
+ MA(-1) = KMN
+ MA(0) = NINT(NDIG*ALOGM2)
+ GO TO 150
+ ENDIF
+ ENDIF
+ IF (LINE(J) == KUNKN(KUK) .OR. LINE(J) == LUNKN(KOF)) THEN
+ KUK = KUK + 1
+ IF (KUK == 5) THEN
+ CALL FMIM(0,MA)
+ MA(1) = MUNKNO
+ MA(2) = 1
+ MA(0) = NINT(NDIG*ALOGM2)
+ GO TO 150
+ ENDIF
+ ENDIF
+ ENDDO
+
+! Increase the working precision.
+
+ 110 K = NGRD52
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) NDIG = NDG2MX
+ NDSAV1 = NDIG
+ M2 = 2
+ MNDSV1 = NDSAV1
+ KSTART = LA
+ KSTOP = LB
+ JSTATE = 1
+ KSIGN = 1
+ CALL FMIM(0,MLV2)
+ CALL FMIM(0,MLV3)
+ CALL FMIM(0,MLV4)
+ CALL FMIM(0,MLV5)
+
+! If MBASE is a power of ten then call FMINP2 for
+! faster input conversion.
+
+ KPOWER = INT(LOG10(DBLE(MBASE)) + 0.5D0)
+ IF (MBASE == 10**KPOWER) THEN
+ CALL FMINP2(MA,LINE,KSTART,KSTOP,JTRANS,KPOWER)
+ GO TO 140
+ ENDIF
+
+ N2 = 0
+ KSIGNX = 1
+ KF1 = 0
+ KF2 = 0
+ KEXP = 0
+ KTENF1 = 1
+ KTENF2 = 1
+ KTENEX = 1
+ K10PWR = 0
+
+! LARGE is a threshold used in order to do as much of the
+! conversion as possible in one-word integer arithmetic.
+
+ LARGE = INT((INTMAX - 10)/10)
+
+! KDFLAG will be 1 if any digits are found before 'E'.
+
+ KDFLAG = 0
+
+! Scan the number.
+
+ DO J = KSTART, KSTOP
+ IF (LINE(J) == ' ') CYCLE
+ KPT = ICHAR(LINE(J))
+ IF (KPT < LHASH1 .OR. KPT > LHASH2) THEN
+ WRITE (KW, &
+ "(/' Error in input conversion.'/" // &
+ "' ICHAR function was out of range for the current'," // &
+ "' dimensions.'/' ICHAR(''',A,''') gave the value '," // &
+ "I12,', which is outside the currently'/' dimensioned'," // &
+ "' bounds of (',I5,':',I5,') for variables KHASHT '," // &
+ "'and KHASHV.'/' Re-define the two parameters '," // &
+ "'LHASH1 and LHASH2 so the dimensions will'/' contain'," // &
+ "' all possible output values from ICHAR.'//)" &
+ ) LINE(J),KPT,LHASH1,LHASH2
+ KTYPE = 5
+ KVAL = 0
+ ELSE
+ KTYPE = KHASHT(KPT)
+ KVAL = KHASHV(KPT)
+ ENDIF
+
+ IF (KTYPE >= 5) GO TO 160
+
+ JSTATE = JTRANS(JSTATE,KTYPE)
+
+ SELECT CASE (JSTATE)
+
+! State 2. Sign of the number.
+
+ CASE (2)
+ KSIGN = KVAL
+
+! State 3. Digits before a decimal point.
+
+ CASE (3)
+ KDFLAG = 1
+ KF1 = 10*KF1 + KVAL
+ KTENF1 = 10*KTENF1
+ IF (KTENF1 > LARGE) THEN
+ IF (KTENF1 /= K10PWR .AND. MLV3(2) /= 0) THEN
+ CALL FMIM(KTENF1,MA)
+ K10PWR = KTENF1
+ ENDIF
+ IF (MLV3(2) == 0) THEN
+ CALL FMIM(KF1,MLV3)
+ ELSE
+ NDIG = INT(MAX(M2,MIN(MLV3(1)+MA(1),MNDSV1)))
+ CALL FMMPY2_R1(MLV3,MA)
+ NDIG = NDSAV1
+ CALL FMIM(KF1,MLV2)
+ NDIG = INT(MAX(M2,MIN(MAX(MLV3(1),MLV2(1))+1,MNDSV1)))
+ IF (KF1 /= 0) CALL FMADD2_R1(MLV3,MLV2)
+ NDIG = NDSAV1
+ ENDIF
+ KF1 = 0
+ KTENF1 = 1
+ ENDIF
+
+! State 4. Decimal point
+
+ CASE (4)
+ CYCLE
+
+! State 5. Digits after a decimal point.
+
+ CASE (5)
+ KDFLAG = 1
+ N2 = N2 + 1
+ KF2 = 10*KF2 + KVAL
+ KTENF2 = 10*KTENF2
+ IF (KTENF2 > LARGE) THEN
+ IF (KTENF2 /= K10PWR .AND. MLV4(2) /= 0) THEN
+ CALL FMIM(KTENF2,MA)
+ K10PWR = KTENF2
+ ENDIF
+ IF (MLV4(2) == 0) THEN
+ CALL FMIM(KF2,MLV4)
+ ELSE
+ NDIG = INT(MAX(M2,MIN(MLV4(1)+MA(1),MNDSV1)))
+ CALL FMMPY2_R1(MLV4,MA)
+ NDIG = NDSAV1
+ CALL FMIM(KF2,MLV2)
+ NDIG = INT(MAX(M2,MIN(MAX(MLV4(1),MLV2(1))+1,MNDSV1)))
+ IF (KF2 /= 0) CALL FMADD2_R1(MLV4,MLV2)
+ NDIG = NDSAV1
+ ENDIF
+ KF2 = 0
+ KTENF2 = 1
+ ENDIF
+
+! State 6. Precision indicator.
+
+ CASE (6)
+ IF (KDFLAG == 0 .AND. KESWCH == 1) CALL FMIM(1,MLV3)
+
+! State 7. Sign of the exponent.
+
+ CASE (7)
+ KSIGNX = KVAL
+
+! State 8. Digits of the exponent.
+
+ CASE (8)
+ KEXP = 10*KEXP + KVAL
+ KTENEX = 10*KTENEX
+ IF (KTENEX > LARGE) THEN
+ IF (KTENEX /= K10PWR .AND. MLV5(2) /= 0) THEN
+ CALL FMIM(KTENEX,MA)
+ K10PWR = KTENEX
+ ENDIF
+ IF (MLV5(2) == 0) THEN
+ CALL FMIM(KEXP,MLV5)
+ ELSE
+ NDIG = INT(MAX(M2,MIN(MLV5(1)+MA(1),MNDSV1)))
+ CALL FMMPY2_R1(MLV5,MA)
+ NDIG = NDSAV1
+ CALL FMIM(KEXP,MLV2)
+ NDIG = INT(MAX(M2,MIN(MAX(MLV5(1),MLV2(1))+1,MNDSV1)))
+ IF (KEXP /= 0) CALL FMADD2_R1(MLV5,MLV2)
+ NDIG = NDSAV1
+ ENDIF
+ KEXP = 0
+ KTENEX = 1
+ ENDIF
+
+ CASE DEFAULT
+ GO TO 160
+
+ END SELECT
+
+ ENDDO
+
+! Form the number and return.
+! MA = KSIGN*(MLV3 + MLV4/10.0**N2)*10.0**MLV5
+
+ IF (KTENF1 > 1) THEN
+ IF (KTENF1 /= K10PWR .AND. MLV3(2) /= 0) THEN
+ CALL FMIM(KTENF1,MA)
+ K10PWR = KTENF1
+ ENDIF
+ IF (MLV3(2) == 0) THEN
+ CALL FMIM(KF1,MLV3)
+ ELSE
+ NDIG = INT(MAX(M2,MIN(MLV3(1)+MA(1),MNDSV1)))
+ CALL FMMPY2_R1(MLV3,MA)
+ NDIG = NDSAV1
+ CALL FMIM(KF1,MLV2)
+ NDIG = INT(MAX(M2,MIN(MAX(MLV3(1),MLV2(1))+1,MNDSV1)))
+ IF (KF1 /= 0) CALL FMADD2_R1(MLV3,MLV2)
+ NDIG = NDSAV1
+ ENDIF
+ ENDIF
+ IF (KTENF2 > 1) THEN
+ IF (KTENF2 /= K10PWR .AND. MLV4(2) /= 0) THEN
+ CALL FMIM(KTENF2,MA)
+ K10PWR = KTENF2
+ ENDIF
+ IF (MLV4(2) == 0) THEN
+ CALL FMIM(KF2,MLV4)
+ ELSE
+ NDIG = INT(MAX(M2,MIN(MLV4(1)+MA(1),MNDSV1)))
+ CALL FMMPY2_R1(MLV4,MA)
+ NDIG = NDSAV1
+ CALL FMIM(KF2,MLV2)
+ NDIG = INT(MAX(M2,MIN(MAX(MLV4(1),MLV2(1))+1,MNDSV1)))
+ IF (KF2 /= 0) CALL FMADD2_R1(MLV4,MLV2)
+ NDIG = NDSAV1
+ ENDIF
+ ENDIF
+ IF (KTENEX > 1) THEN
+ IF (KTENEX /= K10PWR .AND. MLV5(2) /= 0) THEN
+ CALL FMIM(KTENEX,MA)
+ K10PWR = KTENEX
+ ENDIF
+ IF (MLV5(2) == 0) THEN
+ CALL FMIM(KEXP,MLV5)
+ ELSE
+ NDIG = INT(MAX(M2,MIN(MLV5(1)+MA(1),MNDSV1)))
+ CALL FMMPY2_R1(MLV5,MA)
+ NDIG = NDSAV1
+ CALL FMIM(KEXP,MLV2)
+ NDIG = INT(MAX(M2,MIN(MAX(MLV5(1),MLV2(1))+1,MNDSV1)))
+ IF (KEXP /= 0) CALL FMADD2_R1(MLV5,MLV2)
+ NDIG = NDSAV1
+ ENDIF
+ ENDIF
+
+ IF (KSIGNX == -1 .AND. MLV5(1) /= MUNKNO .AND. MLV5(2) /= 0) &
+ MLV5(-1) = -MLV5(-1)
+ IF (MLV4(2) /= 0) THEN
+ CALL FMIM(10,MLV2)
+ K = N2
+ IF (MOD(K,2) == 0) THEN
+ CALL FMIM(1,MA)
+ ELSE
+ CALL FMEQ(MLV2,MA)
+ ENDIF
+
+ 120 K = K/2
+ NDIG = INT(MAX(M2,MIN(2*MLV2(1),MNDSV1)))
+ CALL FMSQR2_R1(MLV2)
+ IF (MOD(K,2) == 1) THEN
+ NDIG = INT(MAX(M2,MIN(MLV2(1)+MA(1),MNDSV1)))
+ CALL FMMPY2_R2(MLV2,MA)
+ ENDIF
+ IF (K > 1) GO TO 120
+ NDIG = NDSAV1
+ CALL FMDIV2_R1(MLV4,MA)
+ ENDIF
+ IF (MLV5(2) /= 0) THEN
+ CALL FMIM(10,MLV2)
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMMI(MLV5,KEXP)
+ KWARN = KWRNSV
+ IF (KFLAG /= 0) GO TO 160
+ K = ABS(KEXP)
+ IF (MOD(K,2) == 0) THEN
+ CALL FMIM(1,MLV5)
+ ELSE
+ CALL FMEQ(MLV2,MLV5)
+ ENDIF
+
+ 130 K = K/2
+ NDIG = INT(MAX(M2,MIN(2*MLV2(1),MNDSV1)))
+ CALL FMSQR2_R1(MLV2)
+ IF (MOD(K,2) == 1) THEN
+ NDIG = INT(MAX(M2,MIN(MLV2(1)+MLV5(1),MNDSV1)))
+ CALL FMMPY2_R2(MLV2,MLV5)
+ ENDIF
+ IF (K > 1) GO TO 130
+ NDIG = NDSAV1
+ IF (KEXP < 0) THEN
+ CALL FMIM(1,MLV2)
+ CALL FMDIV2_R2(MLV2,MLV5)
+ ENDIF
+ ENDIF
+ CALL FMADD2(MLV3,MLV4,MA)
+ IF (MLV5(2) /= 0) CALL FMMPY2_R1(MA,MLV5)
+ IF (KSIGN == -1 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -MA(-1)
+ 140 CALL FMEQ2_R1(MA,NDIG,NDSAVE)
+ IF (MA(1) == MUNKNO) GO TO 160
+
+ 150 NDIG = NDSAVE
+ KACCSW = KASAVE
+ KROUND = KRSAVE
+ MXEXP = MXSAV1
+ MXEXP2 = MXSAV2
+ IF (KFLAG == 1) KFLAG = 0
+ MA(0) = NINT(NDIG*ALOGM2)
+ IF (MA(2) == 0) MA(-1) = 1
+ NCALL = NCALL - 2
+ RETURN
+
+! Error in converting the number.
+
+ 160 CALL FMIM(0,MA)
+ MA(1) = MUNKNO
+ MA(2) = 1
+ MA(0) = NINT(NDIG*ALOGM2)
+ KFLAG = -7
+ NCALL = NCALL - 1
+ CALL FMWARN
+ NCALL = NCALL + 1
+ GO TO 150
+ END SUBROUTINE FMINP
+
+ SUBROUTINE FMINP2(MA,LINE,KSTART,KSTOP,JTRANS,KPOWER)
+
+! Internal routine for input conversion for a power of ten MBASE.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER KSTART,KSTOP,KPOWER,JTRANS(8,4)
+ CHARACTER LINE(KSTOP)
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ INTEGER J,JSTATE,KDFLAG,KEXP,KF1,KF1DIG,KF2,KF2DIG,KF2PT,KNZDIG, &
+ KPT,KSHIFT,KSIGN,KSIGNX,KTYPE,KVAL,LARGE
+
+ JSTATE = 1
+ KDFLAG = 0
+ KSIGN = 1
+ KSIGNX = 1
+ KF1 = 0
+ KNZDIG = 0
+ KF1DIG = 0
+ KF2 = 0
+ KF2DIG = 0
+ KF2PT = 2
+ KEXP = 0
+ LARGE = INT(INTMAX/10)
+
+! Scan the number.
+
+ DO J = KSTART, KSTOP
+ IF (LINE(J) == ' ') CYCLE
+ KPT = ICHAR(LINE(J))
+ IF (KPT < LHASH1 .OR. KPT > LHASH2) THEN
+ WRITE (KW, &
+ "(/' Error in input conversion.'/" // &
+ "' ICHAR function was out of range for the current'," // &
+ "' dimensions.'/' ICHAR(''',A,''') gave the value '," // &
+ "I12,', which is outside the currently'/' dimensioned'," // &
+ "' bounds of (',I5,':',I5,') for variables KHASHT '," // &
+ "'and KHASHV.'/' Re-define the two parameters '," // &
+ "'LHASH1 and LHASH2 so the dimensions will'/' contain'," // &
+ "' all possible output values from ICHAR.'//)" &
+ ) LINE(J),KPT,LHASH1,LHASH2
+ KTYPE = 5
+ KVAL = 0
+ ELSE
+ KTYPE = KHASHT(KPT)
+ KVAL = KHASHV(KPT)
+ ENDIF
+
+ IF (KTYPE >= 5) GO TO 110
+
+ JSTATE = JTRANS(JSTATE,KTYPE)
+
+ SELECT CASE (JSTATE)
+
+! State 2. Sign of the number.
+
+ CASE (2)
+ KSIGN = KVAL
+
+! State 3. Digits before a decimal point.
+
+ CASE (3)
+ KDFLAG = 1
+ KF1 = 10*KF1 + KVAL
+ IF (KVAL > 0 .OR. KNZDIG /= 0) THEN
+ KNZDIG = 1
+ KF1DIG = KF1DIG + 1
+ ENDIF
+ IF (KF1DIG == KPOWER) THEN
+ MLV3(1) = MLV3(1) + 1
+ IF (MLV3(1) < NDIG) MLV3(INT(MLV3(1))+1) = KF1
+ KF1 = 0
+ KF1DIG = 0
+ ENDIF
+
+! State 4. Decimal point
+
+ CASE (4)
+ CYCLE
+
+! State 5. Digits after a decimal point.
+
+ CASE (5)
+ KDFLAG = 1
+ IF (KF2PT > NDIG+1) CYCLE
+ KF2 = 10*KF2 + KVAL
+ KF2DIG = KF2DIG + 1
+ IF (KF2DIG == KPOWER) THEN
+ MLV4(KF2PT) = KF2
+ IF (KF2 == 0 .AND. KF2PT == 2) THEN
+ MLV4(1) = MLV4(1) - 1
+ ELSE
+ KF2PT = KF2PT + 1
+ ENDIF
+ KF2 = 0
+ KF2DIG = 0
+ ENDIF
+
+! State 6. Precision indicator.
+
+ CASE (6)
+ IF (KDFLAG == 0 .AND. KESWCH == 1) CALL FMIM(1,MLV3)
+
+! State 7. Sign of the exponent.
+
+ CASE (7)
+ KSIGNX = KVAL
+
+! State 8. Digits of the exponent.
+
+ CASE (8)
+ IF (KEXP >= LARGE) THEN
+ IF (MLV3(2) == 0 .AND. MLV4(2) == 0) THEN
+ CALL FMIM(0,MA)
+ RETURN
+ ENDIF
+ CALL FMIM(0,MA)
+ IF (KSIGNX == 1) THEN
+ MA(1) = MEXPOV
+ KFLAG = -4
+ ELSE
+ MA(1) = MEXPUN
+ KFLAG = -4
+ ENDIF
+ MA(2) = 1
+ MA(-1) = KSIGN
+ MA(0) = NINT(NDIG*ALOGM2)
+ NCALL = NCALL - 1
+ CALL FMWARN
+ NCALL = NCALL + 1
+ RETURN
+ ENDIF
+ KEXP = 10*KEXP + KVAL
+
+ CASE DEFAULT
+ GO TO 110
+
+ END SELECT
+
+ ENDDO
+
+! Form the number and return.
+! MA = KSIGN*(MLV3 + MLV4)*10.0**(KSIGNX*KEXP)
+
+ IF (KF1DIG /= 0) THEN
+ MLV3(1) = MLV3(1) + 1
+ KSHIFT = 10**(KPOWER-KF1DIG)
+ IF (MLV3(1) < NDIG) MLV3(INT(MLV3(1))+1) = KF1*KSHIFT
+ IF (KSHIFT > 1) THEN
+ CALL FMDIVN_R1(MLV3,KSHIFT)
+ ENDIF
+ ENDIF
+
+ IF (KF2DIG /= 0) THEN
+ KSHIFT = 10**(KPOWER-KF2DIG)
+ MLV4(KF2PT) = KF2*KSHIFT
+ ENDIF
+ IF (MLV4(2) == 0) MLV4(1) = 0
+
+ IF (KEXP /= 0) THEN
+ IF (KSIGNX == 1) THEN
+ MLV5(1) = INT(KEXP/KPOWER) + 1
+ MLV5(2) = 10**(MOD(KEXP,KPOWER))
+ ELSE
+ MLV5(1) = -INT((KEXP-1)/KPOWER)
+ KSHIFT = 10**(MOD(KEXP,KPOWER))
+ IF (KSHIFT > 1) THEN
+ MLV5(2) = MBASE/KSHIFT
+ ELSE
+ MLV5(2) = 1
+ ENDIF
+ ENDIF
+ ENDIF
+
+ CALL FMADD2(MLV3,MLV4,MA)
+ IF (KEXP > 0) CALL FMMPY2_R1(MA,MLV5)
+ MA(-1) = KSIGN
+
+ RETURN
+
+! Error in converting the number.
+
+ 110 CALL FMIM(0,MA)
+ MA(1) = MUNKNO
+ MA(2) = 1
+ MA(-1) = 1
+ MA(0) = NINT(NDIG*ALOGM2)
+ RETURN
+ END SUBROUTINE FMINP2
+
+ SUBROUTINE FMINT(MA,MB)
+
+! MB = INT(MA)
+
+! The integer part of MA is computed and returned in MB as a multiple
+! precision floating point number.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX
+ INTEGER J,KA,KB,KRESLT,N1
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ MACCA = MA(0)
+ KFLAG = 0
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMINT '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ IF (ABS(MA(1)) > MEXPAB) THEN
+ CALL FMARGS('FMINT ',1,MA,MB,KRESLT)
+ IF (KRESLT /= 0) THEN
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+
+ N1 = NDIG + 1
+
+! If MA is less than one in magnitude, return zero.
+
+ IF (MA(1) <= 0) THEN
+ DO J = 1, N1
+ MB(J) = 0
+ ENDDO
+ GO TO 110
+ ENDIF
+
+! If the radix point is off the right end of MA then MA is
+! already an integer. Return MA.
+
+ IF (MA(1) >= NDIG) THEN
+ DO J = 1, N1
+ MB(J) = MA(J)
+ ENDDO
+ GO TO 110
+ ENDIF
+
+! Here MA has both integer and fraction parts. Replace
+! the digits right of the radix point by zeros.
+
+ KA = INT(MA(1)) + 2
+ KB = KA - 1
+ DO J = 1, KB
+ MB(J) = MA(J)
+ ENDDO
+
+ DO J = KA, N1
+ MB(J) = 0
+ ENDDO
+
+ 110 IF (KACCSW == 1) THEN
+ MACMAX = NINT((NDIG-1)*ALOGM2 + &
+ LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MACCA,MACMAX)
+ ELSE
+ MB(0) = MACCA
+ ENDIF
+ MB(-1) = MA(-1)
+ IF (MB(2) == 0) MB(-1) = 1
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMINT
+
+ SUBROUTINE FMIPWR(MA,IVAL,MB)
+
+! MB = MA ** IVAL
+
+! Raise an FM number to an integer power.
+! The binary multiplication method used requires an average of
+! 1.5 * LOG2(IVAL) multiplications. MA may be negative.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER IVAL
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX
+ INTEGER JSIGN,K,KWRNSV,NDSAVE
+ REAL XVAL
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KFLAG = 0
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMIPWR'
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(2,MA,MA,1,1)
+ CALL FMNTRI(2,IVAL,0)
+ ENDIF
+
+! Check for special cases.
+
+ IF (MA(1) == MUNKNO .OR. (IVAL <= 0 .AND. MA(2) == 0)) THEN
+ KFLAG = -4
+ IF (IVAL <= 0 .AND. MA(2) == 0) CALL FMWARN
+ CALL FMST2M('UNKNOWN',MB)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ IF (IVAL == 0) THEN
+ CALL FMIM(1,MB)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ IF (ABS(IVAL) == 1) THEN
+ KWRNSV = KWARN
+ KWARN = 0
+ IF (IVAL == 1) THEN
+ CALL FMEQ(MA,MB)
+ ELSE
+ CALL FMIM(1,M01)
+ CALL FMDIV(M01,MA,MB)
+ ENDIF
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ KWARN = KWRNSV
+ RETURN
+ ENDIF
+
+ IF (MA(2) == 0) THEN
+ CALL FMEQ(MA,MB)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ IF (MA(1) == MEXPOV) THEN
+ JSIGN = 1
+ IF (MA(-1) < 0) JSIGN = -1
+ CALL FMIM(0,MB)
+ IF (IVAL > 0) THEN
+ CALL FMST2M('OVERFLOW',MB)
+ MB(-1) = JSIGN**MOD(IVAL,2)
+ KFLAG = -5
+ ELSE
+ CALL FMST2M('UNDERFLOW',MB)
+ MB(-1) = JSIGN**MOD(IVAL,2)
+ KFLAG = -6
+ ENDIF
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ IF (MA(1) == MEXPUN) THEN
+ JSIGN = 1
+ IF (MA(-1) < 0) JSIGN = -1
+ CALL FMIM(0,MB)
+ IF (IVAL > 0) THEN
+ CALL FMST2M('UNDERFLOW',MB)
+ MB(-1) = JSIGN**MOD(IVAL,2)
+ KFLAG = -6
+ ELSE
+ CALL FMST2M('OVERFLOW',MB)
+ MB(-1) = JSIGN**MOD(IVAL,2)
+ KFLAG = -5
+ ENDIF
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+! Increase the working precision.
+
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ XVAL = ABS(IVAL)
+ K = INT((5.0*REAL(DLOGTN) + LOG(XVAL))/ALOGMB + 2.0)
+ NDIG = MAX(NDIG+K,2)
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
+ ENDIF
+ ELSE
+ XVAL = ABS(IVAL)
+ IF (XVAL > 10.0 .OR. REAL(MBASE) <= 999.0) THEN
+ K = INT(LOG(XVAL)/ALOGMB + 1.0)
+ NDIG = NDIG + K
+ ENDIF
+ ENDIF
+ IF (NDIG > NDG2MX) THEN
+ IF (NCALL == 1) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MB)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ELSE
+ NDIG = NDG2MX
+ ENDIF
+ ENDIF
+
+! Initialize.
+
+ K = ABS(IVAL)
+ KWRNSV = KWARN
+ KWARN = 0
+ MACCA = MA(0)
+ CALL FMEQ2(MA,M01,NDSAVE,NDIG)
+ M01(0) = NINT(NDIG*ALOGM2)
+
+! Handle small exponents by hand.
+
+ IF (K == 2) THEN
+ CALL FMSQR(M01,MB)
+ GO TO 120
+ ENDIF
+ IF (K == 3) THEN
+ CALL FMSQR(M01,MB)
+ CALL FMMPY_R1(MB,M01)
+ GO TO 120
+ ENDIF
+ IF (K == 4) THEN
+ CALL FMSQR(M01,MB)
+ CALL FMSQR_R1(MB)
+ GO TO 120
+ ENDIF
+ IF (K == 5) THEN
+ CALL FMSQR(M01,MB)
+ CALL FMSQR_R1(MB)
+ CALL FMMPY_R1(MB,M01)
+ GO TO 120
+ ENDIF
+
+ IF (MOD(K,2) == 0) THEN
+ CALL FMI2M(1,MB)
+ ELSE
+ CALL FMEQ(M01,MB)
+ ENDIF
+
+! This is the multiplication loop.
+
+ 110 K = K/2
+ CALL FMSQR_R1(M01)
+ IF (MOD(K,2) == 1) CALL FMMPY_R2(M01,MB)
+ IF (K > 1) GO TO 110
+
+! Invert if the exponent is negative.
+
+ 120 IF (IVAL < 0) THEN
+ CALL FMI2M(1,M01)
+ CALL FMDIV_R2(M01,MB)
+ ENDIF
+ KWARN = KWRNSV
+
+! Round the result and return.
+
+ CALL FMEQ2_R1(MB,NDIG,NDSAVE)
+ NDIG = NDSAVE
+ IF (KACCSW == 1) THEN
+ MACMAX = NINT((NDSAVE-1)*ALOGM2 + &
+ LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ ELSE
+ MB(0) = MACCA
+ ENDIF
+ IF (KFLAG < 0) CALL FMWARN
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMIPWR
+
+ SUBROUTINE FMLG10(MA,MB)
+
+! MB = LOG10(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
+ INTEGER J,K,KASAVE,KOVUN,KRESLT,NDSAVE
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0 .OR. MA(-1) < 0) THEN
+ CALL FMENTR('FMLG10',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMLG10'
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ MACCA = MA(0)
+ CALL FMEQ2(MA,MB,NDSAVE,NDIG)
+ MB(0) = NINT(NDIG*ALOGM2)
+
+ CALL FMLN(MB,M13)
+ CALL FMEQ(M13,MB)
+ IF (MBASE /= MBSLI .OR. NDIG > NDIGLI) THEN
+ CALL FMLNI(10,M03)
+ ELSE
+ CALL FMADD(MLN1,MLN3,M03)
+ ENDIF
+ CALL FMDIV_R1(MB,M03)
+
+! Round the result and return.
+
+ MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMLG10
+
+ SUBROUTINE FMLN(MA,MB)
+
+! MB = LOG(MA) (Natural logarithm)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ DOUBLE PRECISION Y
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER NSTACK(19)
+ REAL (KIND(1.0D0)) :: MA1,MACCA,MACMAX,MXSAVE
+ INTEGER IEXTRA,IVAL,J,K,K2,K2EXP,KASAVE,KBOT,KM1,KOVUN,KRESLT, &
+ KSCALE,KST,KWRNSV,LAST,N1,N3,NDSAV1,NDSAVE,NDSV
+ REAL X
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0 .OR. MA(-1) < 0) THEN
+ CALL FMENTR('FMLN ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMLN '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+! If MA is close to 1, use the Taylor series:
+! LN(1+X) = X - X**2/2 + X**3/3 - ...
+! This is faster for small X and avoids cancellation error.
+
+! This method is faster for moderate sized NDIG, but is
+! asymptotically slower by a factor of NDIG**(2/3) than
+! using Newton and FMEXP. For MBASE=10,000 the Taylor
+! series is faster for NDIG less than about 150 (and is
+! used only when MA is between .9999 and 1.0001).
+
+ IF (MA(1) == 0 .OR. MA(1) == 1) THEN
+ X = REAL(MBASE)
+ X = X**(INT(MA(1))-1)*(REAL(MA(2))+REAL(MA(3))/X)
+ ELSE
+ X = 2.0
+ ENDIF
+ IF (X > 0.9999 .AND. X <= 1.0001) THEN
+ MACCA = MA(0)
+ CALL FMEQ2(MA,M03,NDSAVE,NDIG)
+ M03(0) = NINT(NDIG*ALOGM2)
+
+ CALL FMI2M(-1,M01)
+ CALL FMADD_R1(M03,M01)
+
+! The sum will be done as two concurrent series.
+
+ NDSAV1 = NDIG
+ CALL FMEQ(M03,M04)
+ CALL FMDIVI(M03,2,M05)
+ CALL FMSQR(M03,MB)
+ CALL FMEQ(M03,M02)
+ KBOT = 2
+
+ 110 KBOT = KBOT + 1
+ CALL FMMPY_R1(M02,MB)
+ CALL FMDIVI(M02,KBOT,M01)
+ NDIG = NDSAV1
+ CALL FMADD_R1(M04,M01)
+ NDIG = MAX(2,NDSAV1 - INT(M04(1)-M01(1)))
+ KBOT = KBOT + 1
+ CALL FMDIVI(M02,KBOT,M01)
+ NDIG = NDSAV1
+ CALL FMADD_R1(M05,M01)
+ NDIG = MAX(2,NDSAV1 - INT(M04(1)-M01(1)))
+ IF (KFLAG /= 1) GO TO 110
+
+ NDIG = NDSAV1
+ CALL FMMPY_R1(M05,M03)
+ CALL FMSUB(M04,M05,MB)
+ GO TO 140
+ ENDIF
+
+ MA1 = MA(1)
+ MACCA = MA(0)
+ CALL FMEQ2(MA,M05,NDSAVE,NDIG)
+ M05(0) = NINT(NDIG*ALOGM2)
+
+! Compute IEXTRA, the number of extra digits required.
+
+ CALL FMI2M(1,M04)
+ CALL FMSUB_R1(M04,M05)
+ IEXTRA = MAX(0-INT(M04(1)),0)
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M05,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ IF (NCALL == 1) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MB)
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ ELSE
+ CALL FMEQ2_R1(M05,NDIG-IEXTRA,NDG2MX)
+ NDIG = NDG2MX
+ ENDIF
+ ENDIF
+
+! Check to see if the argument is a small integer.
+! If so use FMLNI.
+
+ KM1 = 0
+
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMM2I(M05,IVAL)
+ KWARN = KWRNSV
+ IF (KFLAG == 0 .AND. IVAL < MXBASE) THEN
+ CALL FMLNI(IVAL,MB)
+ GO TO 140
+ ENDIF
+
+! See if the argument can be scaled to a small integer.
+
+ N3 = NDIG + 3
+ N1 = NDIG + 1
+ DO J = 2, N1
+ IF (M05(N3-J) /= 0) THEN
+ LAST = N3 - J - 1
+ GO TO 120
+ ENDIF
+ ENDDO
+
+ 120 KSCALE = INT(MA1) - LAST
+ M05(1) = LAST
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMM2I(M05,IVAL)
+ KWARN = KWRNSV
+ IF (KFLAG == 0 .AND. IVAL < MXBASE) THEN
+ CALL FMLNI(IVAL,M04)
+ IF (IVAL == 1) KM1 = 1
+ K2EXP = 0
+ GO TO 130
+ ENDIF
+
+! For the non-integer case, scale the argument to lie
+! between e/2 and e to speed up the calls to FMEXP.
+
+ M05(1) = 1
+ KSCALE = INT(MA1) - 1
+ CALL FMM2DP(M05,Y)
+ K2EXP = INT(LOG(2.0*REAL(Y)/2.71828)/0.693147)
+ IF (Y < 1.359141) THEN
+ K2EXP = -1
+ CALL FMMPYI_R1(M05,2)
+ Y = 2.0D0*Y
+ ELSE
+ K2 = 2**K2EXP
+ CALL FMDIVI_R1(M05,K2)
+ Y = Y/K2
+ ENDIF
+
+! Generate the initial approximation.
+
+ Y = LOG(Y)
+ CALL FMDPM(Y,M04)
+ CALL FMDIG(NSTACK,KST)
+
+! Newton iteration.
+
+ DO J = 1, KST
+ NDIG = NSTACK(J)
+ CALL FMEXP(M04,MB)
+ CALL FMSUB(M05,MB,M02)
+ CALL FMDIV_R2(M02,MB)
+ CALL FMADD_R1(M04,MB)
+ ENDDO
+ M04(0) = NINT(NDIG*ALOGM2)
+
+! Compute LN(MBASE**KSCALE).
+
+ 130 IF ((MBSLB /= MBASE .OR. NDIGLB < NDIG) .AND. KSCALE /= 0) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDIG+2,NDG2MX)
+ CALL FMLNI(INT(MBASE),MLBSAV)
+ MBSLB = MBASE
+ NDIGLB = NDIG
+ IF (ABS(MLBSAV(1)) > 10) NDIGLB = 0
+ NDIG = NDSV
+ ENDIF
+
+ IF (KSCALE /= 0 .AND. KM1 == 0) THEN
+ CALL FMMPYI(MLBSAV,KSCALE,MB)
+ CALL FMADD_R2(M04,MB)
+ ELSE IF (KSCALE /= 0 .AND. KM1 == 1) THEN
+ CALL FMMPYI(MLBSAV,KSCALE,MB)
+ ELSE IF (KSCALE == 0 .AND. KM1 == 0) THEN
+ CALL FMEQ(M04,MB)
+ ELSE IF (KSCALE == 0 .AND. KM1 == 1) THEN
+ CALL FMI2M(0,MB)
+ ENDIF
+
+ IF (K2EXP /= 0) THEN
+ IF (MBASE /= MBSLI .OR. NDIG > NDIGLI) THEN
+ CALL FMLNI(2,M04)
+ ENDIF
+ CALL FMMPYI(MLN1,K2EXP,M04)
+ CALL FMADD_R1(MB,M04)
+ ENDIF
+
+! Round the result and return.
+
+ 140 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMLN
+
+ SUBROUTINE FMLNI(IVAL,MA)
+
+! MA = LOG(IVAL)
+
+! Compute the natural logarithm of an integer IVAL.
+
+! If IVAL has only powers of 2, 3, 5, and 7 in its factorization then
+! FMLNI is faster than FMLN. Otherwise, if IVAL >= MXBASE (i.e., IVAL
+! does not fit in 1/2 word) then FMLN is usually faster.
+
+! Use FMLN instead of FMLNI if 10*IVAL would cause integer overflow.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER IVAL
+ CHARACTER(155) :: STRING
+ INTEGER INT2,J2,J3,J5,J7,JTEMP2,JTEMP3,JTEMP5,JTEMP7,K,K2,K3, &
+ K5,K7,KASAVE,KDELTA,LAST,ND,NDMB,NDSAVE,NDSV,NT
+ REAL XVAL
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KFLAG = 0
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMLNI '
+ IF (NTRACE /= 0) CALL FMNTRI(2,IVAL,1)
+
+! Check for special cases.
+
+ IF (IVAL <= 0) THEN
+ KFLAG = -4
+ CALL FMWARN
+ CALL FMST2M('UNKNOWN',MA)
+ IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ IF (IVAL == 1) THEN
+ CALL FMI2M(0,MA)
+ IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+! Increase the working precision.
+
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = NGRD52
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MA)
+ IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+
+! Find integers K2, K3, K5, and K7 such that
+! NT = 2**K2 * 3**K3 * 5**K5 * 7**K7
+! is a good approximation of IVAL.
+! KDELTA = ABS(IVAL - NT).
+
+ INT2 = IVAL
+ IF (IVAL > INTMAX/100) INT2 = IVAL/100
+ KDELTA = INT2
+ NT = 0
+ K2 = 0
+ K3 = 0
+ K5 = 0
+ K7 = 0
+
+! Start the search loop.
+
+ XVAL = INT2
+ LAST = INT(LOG(DBLE(XVAL))/DLOGTW + 2.0D0)
+
+ JTEMP7 = 1
+ DO J7 = 1, LAST
+ IF (JTEMP7 > INT2 .AND. &
+ ABS(JTEMP7-INT2) > KDELTA) GO TO 140
+
+ JTEMP5 = JTEMP7
+ DO J5 = 1, LAST
+ IF (JTEMP5 > INT2 .AND. &
+ ABS(JTEMP5-INT2) > KDELTA) GO TO 130
+
+ JTEMP3 = JTEMP5
+ DO J3 = 1, LAST
+ IF (JTEMP3 > INT2 .AND. &
+ ABS(JTEMP3-INT2) > KDELTA) GO TO 120
+
+ JTEMP2 = JTEMP3
+ DO J2 = 1, LAST
+ IF (ABS(JTEMP2-INT2) <= KDELTA) THEN
+ IF (ABS(JTEMP2-INT2) == KDELTA .AND. &
+ JTEMP2 < INT2) GO TO 110
+ KDELTA = ABS(JTEMP2-INT2)
+ NT = JTEMP2
+ K2 = J2 - 1
+ K3 = J3 - 1
+ K5 = J5 - 1
+ K7 = J7 - 1
+ IF (KDELTA == 0) GO TO 140
+ ENDIF
+ IF (JTEMP2 > INT2) GO TO 110
+
+ JTEMP2 = 2*JTEMP2
+ ENDDO
+
+ 110 JTEMP3 = 3*JTEMP3
+ ENDDO
+
+ 120 JTEMP5 = 5*JTEMP5
+ ENDDO
+
+ 130 JTEMP7 = 7*JTEMP7
+ ENDDO
+
+! If IVAL was too close to the integer overflow limit,
+! restore NT to an approximation of IVAL.
+
+ 140 IF (INT2 /= IVAL) THEN
+ IF (NT <= INT2) THEN
+ NT = NT*100
+ K2 = K2 + 2
+ K5 = K5 + 2
+ ELSE IF (NT <= IVAL/98) THEN
+ NT = NT*98
+ K2 = K2 + 1
+ K7 = K7 + 2
+ ELSE
+ NT = NT*70
+ K2 = K2 + 1
+ K5 = K5 + 1
+ K7 = K7 + 1
+ ENDIF
+ ENDIF
+
+! End of the search. Now compute LN(NT) as a linear
+! combination of LN(2), LN(3), LN(5), and LN(7).
+
+ IF (MBASE /= MBSLI .OR. NDIG > NDIGLI) THEN
+ NDMB = INT(150.0*2.302585/ALOGMB)
+ IF (NDMB >= NDIG) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDMB,NDG2MX)
+ STRING = '0.693147180559945309417232121458176568075500'// &
+ '13436025525412068000949339362196969471560586332699641'// &
+ '8687542001481020570685733685520235758130557032670751635'
+ CALL FMST2M(STRING,MLN1)
+ STRING = '1.098612288668109691395245236922525704647490'// &
+ '55782274945173469433363749429321860896687361575481373'// &
+ '2088787970029065957865742368004225930519821052801870767'
+ CALL FMST2M(STRING,MLN2)
+ STRING = '1.609437912434100374600759333226187639525601'// &
+ '35426851772191264789147417898770765776463013387809317'// &
+ '9610799966303021715562899724005229324676199633616617464'
+ CALL FMST2M(STRING,MLN3)
+ STRING = '1.945910149055313305105352743443179729637084'// &
+ '72958186118845939014993757986275206926778765849858787'// &
+ '1526993061694205851140911723752257677786843148958095164'
+ CALL FMST2M(STRING,MLN4)
+ MBSLI = MBASE
+ NDIGLI = NDIG
+ IF (ABS(MLN1(1)) > 10 .OR. ABS(MLN2(1)) > 10 .OR. &
+ ABS(MLN3(1)) > 10 .OR. ABS(MLN4(1)) > 10) NDIGLI = 0
+ ELSE
+ NDSV = NDIG
+ NDIG = MIN(NDIG+2,NDG2MX)
+ MBSLI = MBASE
+ NDIGLI = NDIG
+
+ CALL FMLNI2(1,126,MLN1)
+ CALL FMLNI2(1,225,MLN2)
+ CALL FMLNI2(1,2401,MLN3)
+ CALL FMLNI2(1,4375,MLN4)
+
+! Get Ln(2).
+
+ CALL FMMPYI_R1(MLN1,-72)
+ CALL FMMPYI(MLN2,-27,MA)
+ CALL FMADD_R1(MLN1,MA)
+ CALL FMMPYI(MLN3,19,MA)
+ CALL FMADD_R1(MLN1,MA)
+ CALL FMMPYI(MLN4,-31,MA)
+ CALL FMADD_R1(MLN1,MA)
+
+! Get Ln(3).
+
+ CALL FMMPYI_R1(MLN2,-3)
+ CALL FMMPYI(MLN1,19,MA)
+ CALL FMADD_R1(MLN2,MA)
+ CALL FMSUB_R1(MLN2,MLN3)
+ CALL FMADD_R1(MLN2,MLN4)
+ CALL FMDIVI_R1(MLN2,12)
+
+! Get Ln(5).
+
+ CALL FMSUB_R1(MLN3,MLN1)
+ CALL FMMPYI(MLN2,27,MA)
+ CALL FMADD_R1(MLN3,MA)
+ CALL FMMPYI(MLN4,-4,MA)
+ CALL FMADD_R1(MLN3,MA)
+ CALL FMDIVI_R1(MLN3,18)
+
+! Get Ln(7).
+
+ CALL FMSUB_R2(MLN1,MLN4)
+ CALL FMMPYI(MLN2,7,MA)
+ CALL FMADD_R1(MLN4,MA)
+ CALL FMMPYI(MLN3,-4,MA)
+ CALL FMADD_R1(MLN4,MA)
+ ENDIF
+ MLN1(0) = NINT(NDIG*ALOGM2)
+ MLN2(0) = MLN1(0)
+ MLN3(0) = MLN1(0)
+ MLN4(0) = MLN1(0)
+ IF (ABS(MLN1(1)) > 10 .OR. ABS(MLN2(1)) > 10 .OR. &
+ ABS(MLN3(1)) > 10 .OR. ABS(MLN4(1)) > 10) NDIGLI = 0
+ NDIG = NDSV
+ ENDIF
+
+! If NT /= IVAL then the final step is to compute
+! LN(IVAL/NT) and then use LN(IVAL) = LN(IVAL/NT) + LN(NT).
+
+ IF (NT /= IVAL) THEN
+ ND = NT - IVAL
+ CALL FMLNI2(ND,NT,MA)
+ ENDIF
+
+ CALL FMMPYI(MLN1,K2,M02)
+ CALL FMMPYI(MLN2,K3,M01)
+ CALL FMADD_R1(M02,M01)
+ CALL FMMPYI(MLN3,K5,M01)
+ CALL FMADD_R1(M02,M01)
+ CALL FMMPYI(MLN4,K7,M01)
+ IF (NT /= IVAL) CALL FMADD_R1(M02,MA)
+ CALL FMADD(M02,M01,MA)
+
+! Round and move the result to MA.
+
+ KACCSW = KASAVE
+ CALL FMEQ2_R1(MA,NDIG,NDSAVE)
+ NDIG = NDSAVE
+ IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMLNI
+
+ SUBROUTINE FMLNI2(INT1,INT2,MA)
+
+! MA = LN(1 - INT1/INT2)
+
+! Taylor series for computing the logarithm of a rational number
+! near 1.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER INT1,INT2
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER J,NDSAVE
+
+ CALL FMI2M(INT1,M02)
+ CALL FMDIVI_R1(M02,INT2)
+ CALL FMEQ(M02,MA)
+ NDSAVE = NDIG
+ J = 1
+
+ 110 J = J + 1
+ IF (INT1 /= 1) CALL FMMPYI_R1(M02,INT1)
+ CALL FMDIVI_R1(M02,INT2)
+ CALL FMDIVI(M02,J,M01)
+ NDIG = NDSAVE
+ CALL FMADD_R1(MA,M01)
+ NDIG = NDSAVE - INT(MA(1)-M01(1))
+ IF (NDIG < 2) NDIG = 2
+ IF (KFLAG /= 1) GO TO 110
+
+ NDIG = NDSAVE
+ MA(0) = NINT(NDIG*ALOGM2)
+ IF (MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -MA(-1)
+ RETURN
+ END SUBROUTINE FMLNI2
+
+ SUBROUTINE FMM2DP(MA,X)
+
+! X = MA
+
+! Convert an FM number to double precision.
+
+! If KFLAG = -4 is returned for a value of MA that is in the range
+! of the machine's double precision number system, change the
+! definition of DPMAX in routine FMSET to reflect the current machine's
+! range.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ DOUBLE PRECISION X
+
+ INTEGER KRESLT
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMM2DP'
+ KRESLT = 0
+ IF (ABS(MA(1)) > MEXPAB) THEN
+ CALL FMARGS('FMM2DP',1,MA,MA,KRESLT)
+ ENDIF
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ IF (KRESLT /= 0) THEN
+
+! Here no valid result can be returned. Set X to some
+! value that the user is likely to recognize as wrong.
+
+ X = DBLE(RUNKNO)
+ KFLAG = -4
+ IF (MA(1) /= MUNKNO) CALL FMWARN
+ IF (NTRACE /= 0) CALL FMNTRR(1,X,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ CALL FMMD(MA,X)
+
+ IF (NTRACE /= 0) CALL FMNTRR(1,X,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMM2DP
+
+ SUBROUTINE FMM2I(MA,IVAL)
+
+! IVAL = MA
+
+! Convert an FM number to integer.
+
+! KFLAG = 0 is returned if the conversion is exact.
+! = -4 is returned if MA is larger than INTMAX in magnitude.
+! IVAL = IUNKNO is returned as an indication that IVAL
+! could not be computed without integer overflow.
+! = 2 is returned if MA is smaller than INTMAX in magnitude
+! but MA is not an integer. The next integer toward zero
+! is returned in IVAL.
+! It is sometimes convenient to call FMM2I to see if an FM number
+! can be represented as a one-word integer, by checking KFLAG upon
+! return. To avoid an unwanted error message being printed in the
+! KFLAG=-4 case, set KWARN=0 before the call to FMM2I and reset it
+! after the call.
+
+! This routine performs the trace printing for the conversion.
+! FMMI is used to do the arithmetic.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER IVAL
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMM2I '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+
+ CALL FMMI(MA,IVAL)
+
+ IF (NTRACE /= 0) CALL FMNTRI(1,IVAL,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMM2I
+
+ SUBROUTINE FMM2SP(MA,X)
+
+! X = MA
+
+! Convert an FM number to single precision.
+
+! MA is converted and the result is returned in X.
+
+! If KFLAG = -4 is returned for a value of MA that is in the range
+! of the machine's single precision number system, change the
+! definition of SPMAX in routine FMSET to reflect the current machine's
+! range.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ REAL X
+
+ DOUBLE PRECISION Y
+ INTEGER KRESLT
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMM2SP'
+ KRESLT = 0
+ IF (ABS(MA(1)) > MEXPAB) THEN
+ CALL FMARGS('FMM2SP',1,MA,MA,KRESLT)
+ ENDIF
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ IF (KRESLT /= 0) THEN
+
+! Here no valid result can be returned. Set X to some
+! value that the user is likely to recognize as wrong.
+
+ X = RUNKNO
+ KFLAG = -4
+ IF (MA(1) /= MUNKNO) CALL FMWARN
+ Y = DBLE(X)
+ IF (NTRACE /= 0) CALL FMNTRR(1,Y,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ CALL FMMD(MA,Y)
+ X = REAL(Y)
+
+ IF (NTRACE /= 0) THEN
+ Y = DBLE(X)
+ CALL FMNTRR(1,Y,1)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMM2SP
+
+ SUBROUTINE FMMAX(MA,MB,MC)
+
+! MC = MAX(MA,MB)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ INTEGER KWRNSV
+ LOGICAL FMCOMP
+
+ KFLAG = 0
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMMAX '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)
+
+ KWRNSV = KWARN
+ KWARN = 0
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
+ CALL FMST2M('UNKNOWN',MC)
+ KFLAG = -4
+ ELSE IF (FMCOMP(MA,'LT',MB)) THEN
+ CALL FMEQ(MB,MC)
+ ELSE
+ CALL FMEQ(MA,MC)
+ ENDIF
+
+ KWARN = KWRNSV
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMMAX
+
+ SUBROUTINE FMMD(MA,X)
+
+! X = MA
+
+! Internal routine for conversion to double precision.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ DOUBLE PRECISION X
+
+ DOUBLE PRECISION Y,YT,XBASE,RZERO,ONE,PMAX,DLOGDP
+ REAL (KIND(1.0D0)) :: MA1,MAS
+ INTEGER J,KWRNSV,N1,NCASE
+
+! Check to see if MA is in range for single or double
+! precision.
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ PMAX = DPMAX
+ IF (NCALL > 0) THEN
+ IF (NAMEST(NCALL) == 'FMM2SP') PMAX = DBLE(SPMAX)
+ ENDIF
+ DLOGDP = LOG(PMAX)
+ MA1 = MA(1)
+ NCASE = 0
+ IF (DBLE(MA(1)-1)*DLOGMB > DLOGDP) THEN
+ KFLAG = -4
+ X = DBLE(RUNKNO)
+ CALL FMWARN
+ RETURN
+ ELSE IF (DBLE(MA(1)+1)*DLOGMB > DLOGDP) THEN
+ MA1 = MA1 - 2
+ NCASE = 1
+ ELSE IF (DBLE(MA(1)+1)*DLOGMB < -DLOGDP) THEN
+ KFLAG = -10
+ X = 0.0D0
+ CALL FMWARN
+ RETURN
+ ELSE IF (DBLE(MA(1)-1)*DLOGMB < -DLOGDP) THEN
+ MA1 = MA1 + 2
+ NCASE = 2
+ ENDIF
+
+! Try FMMI first so that small integers will be
+! converted exactly.
+
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMMI(MA,J)
+ KWARN = KWRNSV
+ IF (KFLAG == 0) THEN
+ X = J
+ RETURN
+ ENDIF
+ KFLAG = 0
+
+ MAS = MA(-1)
+ RZERO = 0.0D0
+ ONE = 1.0D0
+ N1 = NDIG + 1
+ XBASE = MBASE
+ X = RZERO
+ Y = ONE
+ DO J = 2, N1
+ Y = Y/XBASE
+ YT = MA(J)
+ X = X + Y*YT
+ YT = ONE + Y*XBASE
+ IF (YT <= ONE) GO TO 110
+ ENDDO
+
+ 110 X = X*XBASE**MA1
+ IF (MAS < 0) X = -X
+
+! Check the result if it is near overflow or underflow.
+
+ IF (NCASE == 1) THEN
+ IF (X <= PMAX/(XBASE*XBASE)) THEN
+ X = X*XBASE*XBASE
+ ELSE
+ KFLAG = -4
+ X = DBLE(RUNKNO)
+ CALL FMWARN
+ ENDIF
+ ELSE IF (NCASE == 2) THEN
+ IF (X >= (1.0D0/PMAX)*XBASE*XBASE) THEN
+ X = X/(XBASE*XBASE)
+ ELSE
+ KFLAG = -10
+ X = 0.0D0
+ CALL FMWARN
+ ENDIF
+ ENDIF
+ RETURN
+ END SUBROUTINE FMMD
+
+ SUBROUTINE FMMI(MA,IVAL)
+
+! IVAL = MA. Internal FM to integer conversion routine.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER IVAL
+
+ INTEGER J,KA,KB,LARGE,N1
+
+ KFLAG = 0
+ N1 = NDIG + 1
+ LARGE = INT(INTMAX/MBASE)
+ IVAL = 0
+ IF (MA(1) <= 0) THEN
+ IF (MA(2) /= 0) KFLAG = 2
+ RETURN
+ ENDIF
+
+ KB = INT(MA(1)) + 1
+ IVAL = INT(ABS(MA(2)))
+ IF (KB >= 3) THEN
+ DO J = 3, KB
+ IF (IVAL > LARGE) THEN
+ KFLAG = -4
+ IF (MA(1) /= MUNKNO) CALL FMWARN
+ IVAL = IUNKNO
+ RETURN
+ ENDIF
+ IF (J <= N1) THEN
+ IVAL = IVAL*INT(MBASE)
+ IF (IVAL > INTMAX-MA(J)) THEN
+ KFLAG = -4
+ IF (MA(1) /= MUNKNO) CALL FMWARN
+ IVAL = IUNKNO
+ RETURN
+ ELSE
+ IVAL = IVAL + INT(MA(J))
+ ENDIF
+ ELSE
+ IVAL = IVAL*INT(MBASE)
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (MA(-1) < 0) IVAL = -IVAL
+
+! Check to see if MA is an integer.
+
+ KA = KB + 1
+ IF (KA <= N1) THEN
+ DO J = KA, N1
+ IF (MA(J) /= 0) THEN
+ KFLAG = 2
+ RETURN
+ ENDIF
+ ENDDO
+ ENDIF
+
+ RETURN
+ END SUBROUTINE FMMI
+
+ SUBROUTINE FMMIN(MA,MB,MC)
+
+! MC = MIN(MA,MB)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ INTEGER KWRNSV
+ LOGICAL FMCOMP
+
+ KFLAG = 0
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMMIN '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)
+
+ KWRNSV = KWARN
+ KWARN = 0
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
+ CALL FMST2M('UNKNOWN',MC)
+ KFLAG = -4
+ ELSE IF (FMCOMP(MA,'GT',MB)) THEN
+ CALL FMEQ(MB,MC)
+ ELSE
+ CALL FMEQ(MA,MC)
+ ENDIF
+
+ KWARN = KWRNSV
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMMIN
+
+ SUBROUTINE FMMOD(MA,MB,MC)
+
+! MC = MA(MOD MB).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MVB,MVC,MVY,MVZ,MXSAVE
+ INTEGER J,K,KASAVE,KB,KE,KN,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV
+ LOGICAL FMCOMP
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB) THEN
+ CALL FMENTR('FMMOD ',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMMOD '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MB,MC,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+ KWRNSV = KWARN
+ KWARN = 0
+ MACCA = MA(0)
+ MACCB = MB(0)
+
+ IF (MB(1) > MA(1) .AND. MB(2) /= 0) THEN
+ CALL FMEQ2(MA,M01,NDSAVE,NDIG)
+ M01(0) = NINT(NDIG*ALOGM2)
+ ELSE
+
+! Special cases when MB is a small integer.
+
+ CALL FMEQ2(MA,M02,NDSAVE,NDIG)
+ M02(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ2(MB,M03,NDSAVE,NDIG)
+ M03(0) = NINT(NDIG*ALOGM2)
+ M02(-1) = 1
+ M03(-1) = 1
+
+ CALL FMM2I(M03,KB)
+ IF (KFLAG == 0 .AND. KB < MXBASE) THEN
+ IF (KB == 1 .OR. KB == -1) THEN
+ IF (M02(1) >= NDIG) THEN
+ CALL FMI2M(0,M01)
+ GO TO 130
+ ELSE
+ CALL FMINT(M02,M03)
+ CALL FMSUB(M02,M03,M01)
+ IF (MA(-1) < 0 .AND. M01(1) /= MUNKNO .AND. &
+ M01(2) /= 0) M01(-1) = -M01(-1)
+ GO TO 130
+ ENDIF
+ ELSE IF (M02(1) == MEXPOV .OR. KB == 0) THEN
+ KFLAG = -4
+ KWARN = KWRNSV
+ KACCSW = KASAVE
+ MXEXP = MXSAVE
+ CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MC)
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ELSE IF (M02(1) > NDIG.AND.MOD(INT(MBASE),KB) == 0) THEN
+ CALL FMI2M(0,M01)
+ GO TO 130
+ ENDIF
+ IF (M02(1) < NDIG) THEN
+ DO J = INT(M02(1))+1, NDIG+1
+ IF (M02(J) /= 0) GO TO 120
+ ENDDO
+ ENDIF
+ KE = MIN(INT(M02(1)),NDIG)
+ MVB = KB
+ MVC = MOD(M02(2),MVB)
+ DO J = 3, KE+1
+ MVC = MOD(MVC*MBASE+M02(J),MVB)
+ ENDDO
+ IF (MVC == 0) THEN
+ CALL FMI2M(0,M01)
+ GO TO 130
+ ENDIF
+ KN = INT(M02(1)) - KE
+ MVY = MOD(MBASE,MVB)
+ MVZ = 1
+ IF (MOD(KN,2) == 1) MVZ = MVY
+
+ IF (MVY /= 1) THEN
+ 110 KN = KN/2
+ MVY = MOD(MVY*MVY,MVB)
+ IF (MOD(KN,2) == 1) MVZ = MOD(MVZ*MVY,MVB)
+ IF (KN > 1) GO TO 110
+ ENDIF
+ MVZ = MOD(MVZ*MVC,MVB)
+ KE = INT(MVZ)
+ CALL FMI2M(KE,M01)
+ IF (MA(-1) < 0 .AND. M01(1) /= MUNKNO .AND. &
+ M01(2) /= 0) M01(-1) = -M01(-1)
+ GO TO 130
+ ENDIF
+
+! General case.
+
+ 120 IF (MA(2) /= 0) THEN
+ NDIG = NDIG + INT(MA(1)-MB(1))
+ ENDIF
+ IF (NDIG > NDG2MX .OR. MB(2) == 0) THEN
+ KFLAG = -9
+ IF (MA(1) == MEXPOV .OR. MB(1) == MEXPUN .OR. MB(2) == 0) &
+ KFLAG = -4
+ KWARN = KWRNSV
+ KACCSW = KASAVE
+ MXEXP = MXSAVE
+ CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MC)
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ CALL FMEQ2(MA,M02,NDSAVE,NDIG)
+ M02(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ2(MB,M03,NDSAVE,NDIG)
+ M03(0) = NINT(NDIG*ALOGM2)
+
+ M02(-1) = 1
+ M03(-1) = 1
+ CALL FMDIV(M02,M03,M01)
+ CALL FMINT(M01,M08)
+ CALL FMEQ(M08,M01)
+ CALL FMMPY_R1(M01,M03)
+ CALL FMSUB_R2(M02,M01)
+
+! Due to rounding, M01 may not be between 0 and MB here.
+
+ NTRSAV = NTRACE
+ NTRACE = 0
+ IF (FMCOMP(M01,'GE',M03)) THEN
+ NTRACE = NTRSAV
+ CALL FMSUB_R1(M01,M03)
+ ENDIF
+ NTRACE = NTRSAV
+ IF (M01(-1) < 0) CALL FMADD_R1(M01,M03)
+ IF (MA(-1) < 0 .AND. M01(1) /= MUNKNO .AND. M01(2) /= 0) &
+ M01(-1) = -M01(-1)
+ ENDIF
+
+ 130 IF (KFLAG == 1) KFLAG = 0
+ KWARN = KWRNSV
+ MACMAX = NINT((NDSAVE-1)*ALOGM2+LOG(REAL(ABS(M01(2))+1))/0.69315)
+ M01(0) = MIN(M01(0),MACCA,MACCB,MACMAX)
+ CALL FMEXIT(M01,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMMOD
+
+ SUBROUTINE FMMOVE(MW,MA)
+
+! Move a result from a work area (MW) to MA.
+
+! If the result has MW(2)=0, then it is shifted and the exponent
+! adjusted when it is moved to MA.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MW(LMWA)
+
+ INTEGER J,N1,N2
+
+ IF (MW(2) /= 0) THEN
+ N1 = NDIG + 1
+
+! Major (Inner Loop)
+
+ DO J = 1, N1
+ MA(J) = MW(J)
+ ENDDO
+ ELSE
+ N2 = NDIG + 2
+ DO J = 3, N2
+ MA(J-1) = MW(J)
+ ENDDO
+ IF (MA(2) /= 0) THEN
+ MA(1) = MW(1) - 1
+ ELSE
+ MA(1) = 0
+ ENDIF
+ ENDIF
+
+ MA(-1) = 1
+ IF (ABS(MA(1)) > MXEXP) CALL FMTRAP(MA)
+
+ RETURN
+ END SUBROUTINE FMMOVE
+
+ SUBROUTINE FMMPY(MA,MB,MC)
+
+! MC = MA * MB
+
+! When one of the numbers MA, MB is known to have more zero digits
+! (base MBASE) than the other, it is faster if MB is the one with
+! more zero digits.
+
+! This routine performs the trace printing for multiplication.
+! FMMPY2 is used to do the arithmetic.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMMPY '
+ CALL FMNTR(2,MA,MB,2,1)
+
+ CALL FMMPY2(MA,MB,MC)
+
+ CALL FMNTR(1,MC,MC,1,1)
+ ELSE
+ CALL FMMPY2(MA,MB,MC)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMMPY
+
+ SUBROUTINE FMMPY2(MA,MB,MC)
+
+! Internal multiplication routine. MC = MA * MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MR,MS,MT1,MT2
+ INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KSHIFT,L,N1,NGUARD
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JRSSAV = JRSIGN
+ MACCA = MA(0)
+ MACCB = MB(0)
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. &
+ KDEBUG == 1) THEN
+ CALL FMARGS('FMMPY ',2,MA,MB,KRESLT)
+ IF (KRESLT /= 0) THEN
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMMPY '
+ CALL FMRSLT(MA,MB,MC,KRESLT)
+ JRSIGN = JRSSAV
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ELSE IF (MA(2) == 0 .OR. MB(2) == 0) THEN
+ CALL FMIM(0,MC)
+ MC(0) = MIN(MACCA,MACCB)
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+ KFLAG = 0
+
+! Save the sign of MA and MB and then work only with
+! positive numbers.
+
+ MAS = MA(-1)
+ MBS = MB(-1)
+
+! NGUARD is the number of guard digits used.
+
+ IF (NCALL > 1) THEN
+ NGUARD = NGRD22
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ ELSE
+ NGUARD = NGRD52
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 2
+ ENDIF
+ ENDIF
+ IF (MA(2)*MB(2) < MBASE .AND. NGUARD < 3) NGUARD = 3
+
+ N1 = NDIG + 1
+
+! If MBASE is small, pack the input numbers and use a larger
+! base to speed up the calculation.
+
+ IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
+ IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN
+ MBASEL = MBASE
+ NDIGL = NDIG
+ NGUARL = NGUARD
+ DO J = 2, 1000
+ MR = MBASE*MBASEL
+ IF (4*MR > MXBASE) THEN
+ N21 = J - 1
+ NDIG = (NDIGL-1)/N21 + 1
+ IF (NDIG < 2) NDIG = 2
+ NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG
+ IF (NGRDN < 1) NGRDN = 1
+ EXIT
+ ENDIF
+ MBASE = MR
+ ENDDO
+ MBASEN = MBASE
+ NDIGN = NDIG
+ ELSE
+ MBASE = MBASEN
+ NDIG = NDIGN
+ ENDIF
+ MPMA(1) = 0
+ MPMB(1) = 0
+ L = 2 - N21
+ DO J = 2, NDIGL+2-N21, N21
+ MT1 = MA(J)
+ MT2 = MB(J)
+ DO K = J+1, J+N21-1
+ MT1 = MT1*MBASEL + MA(K)
+ MT2 = MT2*MBASEL + MB(K)
+ ENDDO
+ MPMA(2+J/N21) = MT1
+ MPMB(2+J/N21) = MT2
+ L = J
+ ENDDO
+ DO J = 3+L/N21, NDIG+NGRDN+1
+ MPMA(J) = 0
+ MPMB(J) = 0
+ ENDDO
+ IF (L+N21 <= NDIGL+1) THEN
+ MT1 = 0
+ MT2 = 0
+ DO J = L+N21, L+2*N21-1
+ IF (J <= NDIGL+1) THEN
+ MT1 = MT1*MBASEL + MA(J)
+ MT2 = MT2*MBASEL + MB(J)
+ ELSE
+ MT1 = MT1*MBASEL
+ MT2 = MT2*MBASEL
+ ENDIF
+ ENDDO
+ MPMA(2+(L+N21)/N21) = MT1
+ MPMB(2+(L+N21)/N21) = MT2
+ ENDIF
+ CALL FMMPY3(MPMA,MPMB,NGRDN,KSHIFT)
+ IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN
+ DO J = 1+NDIG+NGRDN, 2, -1
+ KT1 = MWA(J)
+ KT = 2 + (J-2)*N21
+ KT2 = N21 + KT - 1
+ DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2)
+ MWA(K) = IBITS(KT1,KT2-K,1)
+ ENDDO
+ ENDDO
+ ELSE
+ MS = MBASEL**(N21-1)
+ DO J = 1+NDIG+NGRDN, 2, -1
+ MR = MS
+ MT1 = MWA(J)
+ DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2)
+ MWA(K) = AINT (MT1/MR)
+ MT1 = MT1 - MWA(K)*MR
+ MR = AINT (MR/MBASEL)
+ ENDDO
+ ENDDO
+ ENDIF
+ KSHIFT = 0
+ IF (MWA(2) == 0) KSHIFT = 1
+ MWA(1) = MA(1) + MB(1)
+ NDIG = NDIGL
+ MBASE = MBASEL
+ ELSE
+ CALL FMMPY3(MA,MB,NGUARD,KSHIFT)
+ ENDIF
+
+! The multiplication is complete. Round the result,
+! move it to MC, and append the correct sign.
+
+ IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ MR = 2*MWA(NDIG+2+KSHIFT) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ELSE IF (MR >= MBASE) THEN
+ IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
+ MWA(N1+1+KSHIFT) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWA,MC)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMMPY '
+ CALL FMWARN
+ ENDIF
+
+ MC(-1) = 1
+ IF (MAS*MBS < 0 .AND. MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1
+
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)
+ MC(0) = MIN(MACCA,MACCB,MD2B)
+ ELSE
+ MC(0) = MIN(MACCA,MACCB)
+ ENDIF
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMMPY2
+
+ SUBROUTINE FMMPY_R1(MA,MB)
+
+! MA = MA * MB
+
+! When one of the numbers MA, MB is known to have more zero digits
+! (base MBASE) than the other, it is faster if MB is the one with
+! more zero digits.
+
+! This routine performs the trace printing for multiplication.
+! FMMPY2_R1 is used to do the arithmetic.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMMPY '
+ CALL FMNTR(2,MA,MB,2,1)
+
+ CALL FMMPY2_R1(MA,MB)
+
+ CALL FMNTR(1,MA,MA,1,1)
+ ELSE
+ CALL FMMPY2_R1(MA,MB)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMMPY_R1
+
+ SUBROUTINE FMMPY2_R1(MA,MB)
+
+! Internal multiplication routine. MA = MA * MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MR,MS,MT1,MT2
+ INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KSHIFT,L,N1,NGUARD
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JRSSAV = JRSIGN
+ MACCA = MA(0)
+ MACCB = MB(0)
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. &
+ KDEBUG == 1) THEN
+ CALL FMARGS('FMMPY ',2,MA,MB,KRESLT)
+ IF (KRESLT /= 0) THEN
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMMPY '
+ CALL FMRSLT(MA,MB,M07,KRESLT)
+ CALL FMEQ(M07,MA)
+ JRSIGN = JRSSAV
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ELSE IF (MA(2) == 0 .OR. MB(2) == 0) THEN
+ CALL FMIM(0,MA)
+ MA(0) = MIN(MACCA,MACCB)
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+ KFLAG = 0
+
+! Save the sign of MA and MB and then work only with
+! positive numbers.
+
+ MAS = MA(-1)
+ MBS = MB(-1)
+
+! NGUARD is the number of guard digits used.
+
+ IF (NCALL > 1) THEN
+ NGUARD = NGRD22
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ ELSE
+ NGUARD = NGRD52
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 2
+ ENDIF
+ ENDIF
+ IF (MA(2)*MB(2) < MBASE .AND. NGUARD < 3) NGUARD = 3
+
+ N1 = NDIG + 1
+
+! If MBASE is small, pack the input numbers and use a larger
+! base to speed up the calculation.
+
+ IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
+ IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN
+ MBASEL = MBASE
+ NDIGL = NDIG
+ NGUARL = NGUARD
+ DO J = 2, 1000
+ MR = MBASE*MBASEL
+ IF (4*MR > MXBASE) THEN
+ N21 = J - 1
+ NDIG = (NDIGL-1)/N21 + 1
+ IF (NDIG < 2) NDIG = 2
+ NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG
+ IF (NGRDN < 1) NGRDN = 1
+ EXIT
+ ENDIF
+ MBASE = MR
+ ENDDO
+ MBASEN = MBASE
+ NDIGN = NDIG
+ ELSE
+ MBASE = MBASEN
+ NDIG = NDIGN
+ ENDIF
+ MPMA(1) = 0
+ MPMB(1) = 0
+ L = 2 - N21
+ DO J = 2, NDIGL+2-N21, N21
+ MT1 = MA(J)
+ MT2 = MB(J)
+ DO K = J+1, J+N21-1
+ MT1 = MT1*MBASEL + MA(K)
+ MT2 = MT2*MBASEL + MB(K)
+ ENDDO
+ MPMA(2+J/N21) = MT1
+ MPMB(2+J/N21) = MT2
+ L = J
+ ENDDO
+ DO J = 3+L/N21, NDIG+NGRDN+1
+ MPMA(J) = 0
+ MPMB(J) = 0
+ ENDDO
+ IF (L+N21 <= NDIGL+1) THEN
+ MT1 = 0
+ MT2 = 0
+ DO J = L+N21, L+2*N21-1
+ IF (J <= NDIGL+1) THEN
+ MT1 = MT1*MBASEL + MA(J)
+ MT2 = MT2*MBASEL + MB(J)
+ ELSE
+ MT1 = MT1*MBASEL
+ MT2 = MT2*MBASEL
+ ENDIF
+ ENDDO
+ MPMA(2+(L+N21)/N21) = MT1
+ MPMB(2+(L+N21)/N21) = MT2
+ ENDIF
+ CALL FMMPY3(MPMA,MPMB,NGRDN,KSHIFT)
+ IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN
+ DO J = 1+NDIG+NGRDN, 2, -1
+ KT1 = MWA(J)
+ KT = 2 + (J-2)*N21
+ KT2 = N21 + KT - 1
+ DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2)
+ MWA(K) = IBITS(KT1,KT2-K,1)
+ ENDDO
+ ENDDO
+ ELSE
+ MS = MBASEL**(N21-1)
+ DO J = 1+NDIG+NGRDN, 2, -1
+ MR = MS
+ MT1 = MWA(J)
+ DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2)
+ MWA(K) = AINT (MT1/MR)
+ MT1 = MT1 - MWA(K)*MR
+ MR = AINT (MR/MBASEL)
+ ENDDO
+ ENDDO
+ ENDIF
+ KSHIFT = 0
+ IF (MWA(2) == 0) KSHIFT = 1
+ MWA(1) = MA(1) + MB(1)
+ NDIG = NDIGL
+ MBASE = MBASEL
+ ELSE
+ CALL FMMPY3(MA,MB,NGUARD,KSHIFT)
+ ENDIF
+
+! The multiplication is complete. Round the result,
+! move it to MA, and append the correct sign.
+
+ IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ MR = 2*MWA(NDIG+2+KSHIFT) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ELSE IF (MR >= MBASE) THEN
+ IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
+ MWA(N1+1+KSHIFT) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWA,MA)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMMPY '
+ CALL FMWARN
+ ENDIF
+
+ MA(-1) = 1
+ IF (MAS*MBS < 0 .AND. MA(1) /= MUNKNO .AND. MA(2) /= 0) MA(-1) = -1
+
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315)
+ MA(0) = MIN(MACCA,MACCB,MD2B)
+ ELSE
+ MA(0) = MIN(MACCA,MACCB)
+ ENDIF
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMMPY2_R1
+
+ SUBROUTINE FMMPY_R2(MA,MB)
+
+! MB = MA * MB
+
+! When one of the numbers MA, MB is known to have more zero digits
+! (base MBASE) than the other, it is faster if MB is the one with
+! more zero digits.
+
+! This routine performs the trace printing for multiplication.
+! FMMPY2_R2 is used to do the arithmetic.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMMPY '
+ CALL FMNTR(2,MA,MB,2,1)
+
+ CALL FMMPY2_R2(MA,MB)
+
+ CALL FMNTR(1,MB,MB,1,1)
+ ELSE
+ CALL FMMPY2_R2(MA,MB)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMMPY_R2
+
+ SUBROUTINE FMMPY2_R2(MA,MB)
+
+! Internal multiplication routine. MB = MA * MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS,MD2B,MR,MS,MT1,MT2
+ INTEGER J,JRSSAV,K,KRESLT,KT,KT1,KT2,KSHIFT,L,N1,NGUARD
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JRSSAV = JRSIGN
+ MACCA = MA(0)
+ MACCB = MB(0)
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. &
+ KDEBUG == 1) THEN
+ CALL FMARGS('FMMPY ',2,MA,MB,KRESLT)
+ IF (KRESLT /= 0) THEN
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMMPY '
+ CALL FMRSLT(MA,MB,M07,KRESLT)
+ CALL FMEQ(M07,MB)
+ JRSIGN = JRSSAV
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ELSE IF (MA(2) == 0 .OR. MB(2) == 0) THEN
+ CALL FMIM(0,MB)
+ MB(0) = MIN(MACCA,MACCB)
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+ KFLAG = 0
+
+! Save the sign of MA and MB and then work only with
+! positive numbers.
+
+ MAS = MA(-1)
+ MBS = MB(-1)
+
+! NGUARD is the number of guard digits used.
+
+ IF (NCALL > 1) THEN
+ NGUARD = NGRD22
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ ELSE
+ NGUARD = NGRD52
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 2
+ ENDIF
+ ENDIF
+ IF (MA(2)*MB(2) < MBASE .AND. NGUARD < 3) NGUARD = 3
+
+ N1 = NDIG + 1
+
+! If MBASE is small, pack the input numbers and use a larger
+! base to speed up the calculation.
+
+ IF (MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
+ IF (NDIGL /= NDIG .OR. MBASEL /= MBASE .OR. NGUARL /= NGUARD) THEN
+ MBASEL = MBASE
+ NDIGL = NDIG
+ NGUARL = NGUARD
+ DO J = 2, 1000
+ MR = MBASE*MBASEL
+ IF (4*MR > MXBASE) THEN
+ N21 = J - 1
+ NDIG = (NDIGL-1)/N21 + 1
+ IF (NDIG < 2) NDIG = 2
+ NGRDN = (NDIGL+NGUARD-1)/N21 + 2 - NDIG
+ IF (NGRDN < 1) NGRDN = 1
+ EXIT
+ ENDIF
+ MBASE = MR
+ ENDDO
+ MBASEN = MBASE
+ NDIGN = NDIG
+ ELSE
+ MBASE = MBASEN
+ NDIG = NDIGN
+ ENDIF
+ MPMA(1) = 0
+ MPMB(1) = 0
+ L = 2 - N21
+ DO J = 2, NDIGL+2-N21, N21
+ MT1 = MA(J)
+ MT2 = MB(J)
+ DO K = J+1, J+N21-1
+ MT1 = MT1*MBASEL + MA(K)
+ MT2 = MT2*MBASEL + MB(K)
+ ENDDO
+ MPMA(2+J/N21) = MT1
+ MPMB(2+J/N21) = MT2
+ L = J
+ ENDDO
+ DO J = 3+L/N21, NDIG+NGRDN+1
+ MPMA(J) = 0
+ MPMB(J) = 0
+ ENDDO
+ IF (L+N21 <= NDIGL+1) THEN
+ MT1 = 0
+ MT2 = 0
+ DO J = L+N21, L+2*N21-1
+ IF (J <= NDIGL+1) THEN
+ MT1 = MT1*MBASEL + MA(J)
+ MT2 = MT2*MBASEL + MB(J)
+ ELSE
+ MT1 = MT1*MBASEL
+ MT2 = MT2*MBASEL
+ ENDIF
+ ENDDO
+ MPMA(2+(L+N21)/N21) = MT1
+ MPMB(2+(L+N21)/N21) = MT2
+ ENDIF
+ CALL FMMPY3(MPMA,MPMB,NGRDN,KSHIFT)
+ IF (MBASEL == 2 .AND. MBASE < INTMAX) THEN
+ DO J = 1+NDIG+NGRDN, 2, -1
+ KT1 = MWA(J)
+ KT = 2 + (J-2)*N21
+ KT2 = N21 + KT - 1
+ DO K = KT, MIN(1+(J-1)*N21,NDIGL+NGUARD+2)
+ MWA(K) = IBITS(KT1,KT2-K,1)
+ ENDDO
+ ENDDO
+ ELSE
+ MS = MBASEL**(N21-1)
+ DO J = 1+NDIG+NGRDN, 2, -1
+ MR = MS
+ MT1 = MWA(J)
+ DO K = 2+(J-2)*N21, MIN(1+(J-1)*N21,NDIGL+NGUARD+2)
+ MWA(K) = AINT (MT1/MR)
+ MT1 = MT1 - MWA(K)*MR
+ MR = AINT (MR/MBASEL)
+ ENDDO
+ ENDDO
+ ENDIF
+ KSHIFT = 0
+ IF (MWA(2) == 0) KSHIFT = 1
+ MWA(1) = MA(1) + MB(1)
+ NDIG = NDIGL
+ MBASE = MBASEL
+ ELSE
+ CALL FMMPY3(MA,MB,NGUARD,KSHIFT)
+ ENDIF
+
+! The multiplication is complete. Round the result,
+! move it to MB, and append the correct sign.
+
+ IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ MR = 2*MWA(NDIG+2+KSHIFT) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ELSE IF (MR >= MBASE) THEN
+ IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
+ MWA(N1+1+KSHIFT) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWA,MB)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMMPY '
+ CALL FMWARN
+ ENDIF
+
+ MB(-1) = 1
+ IF (MAS*MBS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1
+
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MACCA,MACCB,MD2B)
+ ELSE
+ MB(0) = MIN(MACCA,MACCB)
+ ENDIF
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMMPY2_R2
+
+ SUBROUTINE FMMPY3(MA,MB,NGUARD,KSHIFT)
+
+! Internal multiplication of MA*MB. The result is returned in MWA.
+! Both MA and MB are positive.
+
+! NGUARD is the number of guard digits that will be used.
+! KSHIFT = 1 is returned if a left shift is pending (i.e., MWA(2)=0).
+! The shift will be done in FMMOVE. KSHIFT = 0 is returned
+! if no shift is pending.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER NGUARD,KSHIFT
+
+ REAL (KIND(1.0D0)) :: MAXMWA,MBJ,MBKJ,MBM1,MBNORM,MK,MKT,MMAX,MT
+ INTEGER J,JM1,K,KB,KI,KJ,KL,KNZ,KWA,L,N1
+
+ N1 = NDIG + 1
+ MWA(1) = MA(1) + MB(1)
+ L = N1 + NGUARD
+ MWA(L+1) = 0
+
+! The multiplication loop begins here.
+
+! MBNORM is the minimum number of digits that can be
+! multiplied before normalization is required.
+! MAXMWA is an upper bound on the size of values in MWA
+! divided by (MBASE-1). It is used to determine
+! whether to normalize before the next digit is
+! multiplied.
+
+ MBM1 = MBASE - 1
+ MBNORM = AINT (MAXINT/(MBM1*MBM1))
+ MMAX = INTMAX - MBASE
+ MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX)
+ IF (MBNORM > 1) THEN
+ MBJ = MB(2)
+
+! Count the trailing zeros in MA.
+
+ IF (MA(N1) /= 0) THEN
+ KNZ = N1
+ ELSE
+ DO J = NDIG, 2, -1
+ IF (MA(J) /= 0) THEN
+ KNZ = J
+ GO TO 110
+ ENDIF
+ ENDDO
+ ENDIF
+
+ 110 MWA(2) = 0
+ DO K = NDIG+2, L
+ MWA(K) = 0
+ ENDDO
+
+! (Inner Loop)
+
+ DO K = 2, N1
+ MWA(K+1) = MA(K)*MBJ
+ ENDDO
+ MAXMWA = MBJ
+ DO J = 3, N1
+ MBJ = MB(J)
+ IF (MBJ /= 0) THEN
+ MAXMWA = MAXMWA + MBJ
+ JM1 = J - 1
+ KL = MIN(KNZ,L-JM1)
+
+! Major (Inner Loop)
+
+ DO K = J+1, J+KL-1
+ MWA(K) = MWA(K) + MA(K-JM1)*MBJ
+ ENDDO
+ ENDIF
+
+ IF (MAXMWA > MMAX) THEN
+ MAXMWA = 0
+
+! Here normalization is only required for the
+! range of digits currently changing in MWA.
+
+ DO KB = JM1+KL, JM1+2, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ ENDDO
+ ENDIF
+ ENDDO
+
+! Perform the final normalization. (Inner Loop)
+
+ DO KB = L, 3, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ ENDDO
+
+ ELSE
+
+! If normalization must be done for each digit, combine
+! the two loops and normalize as the digits are multiplied.
+
+ DO J = 2, L
+ MWA(J) = 0
+ ENDDO
+ KJ = NDIG + 2
+ DO J = 2, N1
+ KJ = KJ - 1
+ MBKJ = MB(KJ)
+ IF (MBKJ == 0) CYCLE
+ KL = L - KJ + 1
+ IF (KL > N1) KL = N1
+ KI = KL + 2
+ KWA = KL+ KJ + 1
+ MK = 0
+ DO K = 2, KL
+ MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MK
+ MK = INT (MT/MBASE)
+ MWA(KWA-K) = MT - MBASE*MK
+ ENDDO
+ MWA(KWA-KL-1) = MK
+ ENDDO
+
+ ENDIF
+
+! Set KSHIFT = 1 if a shift left is necessary.
+
+ IF (MWA(2) == 0) THEN
+ KSHIFT = 1
+ RETURN
+ ELSE
+ KSHIFT = 0
+ RETURN
+ ENDIF
+
+ END SUBROUTINE FMMPY3
+
+ SUBROUTINE FMMPYD(MA,MB,MC,MD,ME)
+
+! Double multiplication routine. MD = MA * MB, ME = MA * MC
+
+! It is usually slightly faster to do two multiplications that
+! have a common factor with one call.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK), &
+ MD(-1:LUNPCK),ME(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MACCC,MAS,MAXMWA,MBS,MBJ,MBKJ, &
+ MBM1,MBNORM,MCJ,MCKJ,MCS,MD2B,MKB,MKC,MKT, &
+ MMAX,MR,MT,MTEMP
+ INTEGER J,JM1,JRSSAV,K,KB,KI,KJ,KL,KNZ,KOVUN,KSHIFT,KWA,L,N1,NGUARD
+
+ NCALL = NCALL + 1
+ JRSSAV = JRSIGN
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMMPYD'
+ CALL FMNTR(2,MA,MB,2,1)
+ IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
+ IF (NTRACE < 0) THEN
+ CALL FMNTRJ(MC,NDIG)
+ ELSE
+ CALL FMPRNT(MC)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ MACCA = MA(0)
+ MACCB = MB(0)
+ MACCC = MC(0)
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. &
+ ABS(MC(1)) > MEXPAB .OR. MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN .OR. &
+ MB(1) == MEXPOV .OR. MB(1) == MEXPUN .OR. &
+ MC(1) == MEXPOV .OR. MC(1) == MEXPUN) KOVUN = 1
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR. &
+ MC(1) == MUNKNO) KOVUN = 2
+ NCALL = NCALL + 1
+ CALL FMMPY2(MA,MB,MWD)
+ KB = KFLAG
+ CALL FMMPY2(MA,MC,ME)
+ NCALL = NCALL - 1
+ IF (((KFLAG < 0 .OR. KB < 0) .AND. KOVUN == 0) .OR. &
+ ((KFLAG == -4 .OR. KB == -4) .AND. KOVUN == 1)) THEN
+ IF (KFLAG == -4 .OR. KB == -4) THEN
+ KFLAG = -4
+ ELSE IF (KFLAG == -5 .OR. KB == -5) THEN
+ KFLAG = -5
+ ELSE
+ KFLAG = MIN(KFLAG,KB)
+ ENDIF
+ NAMEST(NCALL) = 'FMMPYD'
+ CALL FMWARN
+ ENDIF
+ CALL FMEQ(MWD,MD)
+ GO TO 120
+ ENDIF
+ IF (MA(2) == 0) THEN
+ CALL FMIM(0,MD)
+ MD(0) = MIN(MACCA,MACCB)
+ CALL FMIM(0,ME)
+ ME(0) = MIN(MACCA,MACCC)
+ GO TO 120
+ ENDIF
+ IF (MB(2) == 0) THEN
+ CALL FMMPY2(MA,MC,ME)
+ CALL FMIM(0,MD)
+ MD(0) = MIN(MACCA,MACCB)
+ GO TO 120
+ ENDIF
+ IF (MC(2) == 0) THEN
+ CALL FMMPY2(MA,MB,MD)
+ CALL FMIM(0,ME)
+ ME(0) = MIN(MACCA,MACCC)
+ GO TO 120
+ ENDIF
+ KFLAG = 0
+
+! NGUARD is the number of guard digits used.
+
+ IF (NCALL > 1) THEN
+ NGUARD = NGRD22
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ ELSE
+ NGUARD = NGRD52
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 10
+ ENDIF
+ ENDIF
+ IF ((MA(2)*MB(2) < MBASE .OR. MA(2)*MC(2) < MBASE) &
+ .AND. NGUARD < 3) NGUARD = 3
+
+! Save the sign of MA, MB, and MC and then
+! work only with positive numbers.
+
+ MAS = MA(-1)
+ MBS = MB(-1)
+ MCS = MC(-1)
+
+ N1 = NDIG + 1
+ MWA(1) = MA(1) + MB(1)
+ MWD(1) = MA(1) + MC(1)
+ L = NDIG + 1 + NGUARD
+ MWA(L+1) = 0
+ MWD(L+1) = 0
+
+! The multiplication loop begins here.
+
+! MBNORM is the minimum number of digits that can be
+! multiplied before normalization is required.
+! MAXMWA is an upper bound on the size of values in MWA
+! divided by (MBASE-1). It is used to determine
+! whether to normalize before the next digit is
+! multiplied.
+
+ MBM1 = MBASE - 1
+ MBNORM = AINT (MAXINT/(MBM1*MBM1))
+ MMAX = INTMAX - MBASE
+ MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX)
+ IF (MBNORM > 1) THEN
+ MBJ = MB(2)
+ MCJ = MC(2)
+
+! Count the trailing zeros in MA.
+
+ IF (MA(N1) /= 0) THEN
+ KNZ = N1
+ ELSE
+ DO J = NDIG, 2, -1
+ IF (MA(J) /= 0) THEN
+ KNZ = J
+ GO TO 110
+ ENDIF
+ ENDDO
+ ENDIF
+
+ 110 MWA(2) = 0
+ MWD(2) = 0
+ DO K = NDIG+2, L
+ MWA(K) = 0
+ MWD(K) = 0
+ ENDDO
+
+! (Inner Loop)
+
+ DO K = 2, N1
+ MTEMP = MA(K)
+ MWA(K+1) = MTEMP*MBJ
+ MWD(K+1) = MTEMP*MCJ
+ ENDDO
+ IF (MBJ > MCJ) THEN
+ MAXMWA = MBJ
+ ELSE
+ MAXMWA = MCJ
+ ENDIF
+ DO J = 3, N1
+ MBJ = MB(J)
+ MCJ = MC(J)
+ IF (MBJ > MCJ) THEN
+ MAXMWA = MAXMWA + MBJ
+ ELSE
+ MAXMWA = MAXMWA + MCJ
+ ENDIF
+ JM1 = J - 1
+ KL = MIN(KNZ,L-JM1)
+
+! Major (Inner Loop)
+
+ DO K = J+1, J+KL-1
+ MTEMP = MA(K-JM1)
+ MWA(K) = MWA(K) + MTEMP*MBJ
+ MWD(K) = MWD(K) + MTEMP*MCJ
+ ENDDO
+
+ IF (MAXMWA > MMAX) THEN
+ MAXMWA = 0
+
+! Here normalization is only required for the
+! range of digits currently changing in MWA.
+
+ DO KB = JM1+KL, JM1+2, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ MKT = INT (MWD(KB)/MBASE)
+ MWD(KB-1) = MWD(KB-1) + MKT
+ MWD(KB) = MWD(KB) - MKT*MBASE
+ ENDDO
+ ENDIF
+ ENDDO
+
+! Perform the final normalization. (Inner Loop)
+
+ DO KB = L, 3, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ MKT = INT (MWD(KB)/MBASE)
+ MWD(KB-1) = MWD(KB-1) + MKT
+ MWD(KB) = MWD(KB) - MKT*MBASE
+ ENDDO
+
+ ELSE
+
+! If normalization must be done for each digit, combine
+! the two loops and normalize as the digits are multiplied.
+
+ DO J = 2, L
+ MWA(J) = 0
+ MWD(J) = 0
+ ENDDO
+ KJ = NDIG + 2
+ DO J = 2, N1
+ KJ = KJ - 1
+ MBKJ = MB(KJ)
+ MCKJ = MC(KJ)
+ KL = L - KJ + 1
+ IF (KL > N1) KL = N1
+ KI = KL + 2
+ KWA = KL+ KJ + 1
+ MKB = 0
+ MKC = 0
+ DO K = 2, KL
+ MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MKB
+ MKB = INT (MT/MBASE)
+ MWA(KWA-K) = MT - MBASE*MKB
+ MT = MA(KI-K)*MCKJ + MWD(KWA-K) + MKC
+ MKC = INT (MT/MBASE)
+ MWD(KWA-K) = MT - MBASE*MKC
+ ENDDO
+ MWA(KWA-KL-1) = MKB
+ MWD(KWA-KL-1) = MKC
+ ENDDO
+
+ ENDIF
+
+! Set KSHIFT = 1 if a shift left is necessary.
+
+ IF (MWA(2) == 0) THEN
+ KSHIFT = 1
+ ELSE
+ KSHIFT = 0
+ ENDIF
+
+! The multiplications are complete.
+
+ IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ MR = 2*MWA(NDIG+2+KSHIFT) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ELSE IF (MR >= MBASE) THEN
+ IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
+ MWA(N1+1+KSHIFT) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWA,MD)
+
+ IF ((MAS > 0 .AND. MCS > 0) .OR. (MAS < 0 .AND. MCS < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ IF (MWD(2) == 0) THEN
+ KSHIFT = 1
+ ELSE
+ KSHIFT = 0
+ ENDIF
+ MR = 2*MWD(NDIG+2+KSHIFT) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWD,NDIG,NGUARD,KSHIFT)
+ ELSE IF (MR >= MBASE) THEN
+ IF (MR-1 > MBASE .AND. MWD(N1+KSHIFT) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWD(N1+KSHIFT) = MWD(N1+KSHIFT) + 1
+ MWD(N1+1+KSHIFT) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWD,NDIG,NGUARD,KSHIFT)
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWD,ME)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMMPYD'
+ CALL FMWARN
+ ENDIF
+
+ MD(-1) = 1
+ IF (MAS*MBS < 0 .AND. MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -1
+ ME(-1) = 1
+ IF (MAS*MCS < 0 .AND. ME(1) /= MUNKNO .AND. ME(2) /= 0) ME(-1) = -1
+
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MD(2))+1))/0.69315)
+ MD(0) = MIN(MACCA,MACCB,MD2B)
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(ME(2))+1))/0.69315)
+ ME(0) = MIN(MACCA,MACCC,MD2B)
+ ELSE
+ MD(0) = MIN(MACCA,MACCB)
+ ME(0) = MIN(MACCA,MACCC)
+ ENDIF
+
+ 120 IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MD,MD,1,1)
+ IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN
+ IF (NTRACE < 0) THEN
+ CALL FMNTRJ(ME,NDIG)
+ ELSE
+ CALL FMPRNT(ME)
+ ENDIF
+ ENDIF
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMMPYD
+
+ SUBROUTINE FMMPYE(MA,MB,MC,MD,ME,MF,MG)
+
+! Triple multiplication routine.
+
+! ME = MA * MB, MF = MA * MC, MG = MA * MD
+
+! It is usually slightly faster to do three multiplications that
+! have a common factor with one call.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK), &
+ MD(-1:LUNPCK),ME(-1:LUNPCK),MF(-1:LUNPCK), &
+ MG(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MACCC,MACCD,MAS,MAXJ,MAXMWA,MBS,MBJ, &
+ MBKJ,MBM1,MBNORM,MCJ,MCKJ,MCS,MD2B,MDJ,MDKJ,MDS, &
+ MKB,MKC,MKD,MKT,MMAX,MR,MT,MTEMP
+ INTEGER J,JM1,JRSSAV,K,KB,KI,KJ,KL,KNZ,KOVUN,KSHIFT,KWA,L,N1,NGUARD
+
+ NCALL = NCALL + 1
+ JRSSAV = JRSIGN
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMMPYE'
+ CALL FMNTR(2,MA,MB,2,1)
+ IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
+ IF (NTRACE < 0) THEN
+ CALL FMNTRJ(MC,NDIG)
+ CALL FMNTRJ(MD,NDIG)
+ ELSE
+ CALL FMPRNT(MC)
+ CALL FMPRNT(MD)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ MACCA = MA(0)
+ MACCB = MB(0)
+ MACCC = MC(0)
+ MACCD = MD(0)
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. &
+ ABS(MC(1)) > MEXPAB .OR. ABS(MD(1)) > MEXPAB .OR. &
+ MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN .OR. &
+ MB(1) == MEXPOV .OR. MB(1) == MEXPUN .OR. &
+ MC(1) == MEXPOV .OR. MC(1) == MEXPUN .OR. &
+ MD(1) == MEXPOV .OR. MD(1) == MEXPUN) KOVUN = 1
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR. &
+ MC(1) == MUNKNO .OR. MD(1) == MUNKNO) KOVUN = 2
+ NCALL = NCALL + 1
+ CALL FMMPY2(MA,MB,MWD)
+ KB = KFLAG
+ CALL FMMPY2(MA,MC,MWE)
+ KJ = KFLAG
+ CALL FMMPY2(MA,MD,MG)
+ NCALL = NCALL - 1
+ IF (((KFLAG < 0 .OR. KB < 0 .OR. KJ < 0) .AND. KOVUN == 0) &
+ .OR. ((KFLAG == -4 .OR. KB == -4 .OR. KJ == -4) .AND. &
+ KOVUN == 1)) THEN
+ IF (KFLAG == -4 .OR. KB == -4 .OR. KJ == -4) THEN
+ KFLAG = -4
+ ELSE IF (KFLAG == -5 .OR. KB == -5 .OR. KJ == -5) THEN
+ KFLAG = -5
+ ELSE
+ KFLAG = MIN(KFLAG,KB,KJ)
+ ENDIF
+ NAMEST(NCALL) = 'FMMPYE'
+ CALL FMWARN
+ ENDIF
+ CALL FMEQ(MWD,ME)
+ CALL FMEQ(MWE,MF)
+ GO TO 120
+ ENDIF
+ IF (MA(2) == 0) THEN
+ CALL FMIM(0,ME)
+ ME(0) = MIN(MACCA,MACCB)
+ CALL FMIM(0,MF)
+ MF(0) = MIN(MACCA,MACCC)
+ CALL FMIM(0,MG)
+ MG(0) = MIN(MACCA,MACCD)
+ GO TO 120
+ ENDIF
+ IF (MB(2) == 0 .OR. MC(2) == 0 .OR. MD(2) == 0) THEN
+ CALL FMMPY2(MA,MB,MWD)
+ CALL FMMPY2(MA,MC,MWE)
+ CALL FMMPY2(MA,MD,MG)
+ CALL FMEQ(MWD,ME)
+ CALL FMEQ(MWE,MF)
+ GO TO 120
+ ENDIF
+ KFLAG = 0
+
+! NGUARD is the number of guard digits used.
+
+ IF (NCALL > 1) THEN
+ NGUARD = NGRD22
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ ELSE
+ NGUARD = NGRD52
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 10
+ ENDIF
+ ENDIF
+ IF ((MA(2)*MB(2) < MBASE .OR. MA(2)*MC(2) < MBASE .OR. &
+ MA(2)*MD(2) < MBASE) .AND. NGUARD < 3) NGUARD = 3
+
+! Save the signs and then work only with positive numbers.
+
+ MAS = MA(-1)
+ MBS = MB(-1)
+ MCS = MC(-1)
+ MDS = MD(-1)
+
+ N1 = NDIG + 1
+ MWA(1) = MA(1) + MB(1)
+ MWD(1) = MA(1) + MC(1)
+ MWE(1) = MA(1) + MD(1)
+ L = NDIG + 1 + NGUARD
+ MWA(L+1) = 0
+ MWD(L+1) = 0
+ MWE(L+1) = 0
+
+! The multiplication loop begins here.
+
+! MBNORM is the minimum number of digits that can be
+! multiplied before normalization is required.
+! MAXMWA is an upper bound on the size of values in MWA
+! divided by (MBASE-1). It is used to determine
+! whether to normalize before the next digit is
+! multiplied.
+
+ MBM1 = MBASE - 1
+ MBNORM = AINT (MAXINT/(MBM1*MBM1))
+ MMAX = INTMAX - MBASE
+ MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX)
+ IF (MBNORM > 1) THEN
+ MBJ = MB(2)
+ MCJ = MC(2)
+ MDJ = MD(2)
+
+! Count the trailing zeros in MA.
+
+ IF (MA(N1) /= 0) THEN
+ KNZ = N1
+ ELSE
+ DO J = NDIG, 2, -1
+ IF (MA(J) /= 0) THEN
+ KNZ = J
+ GO TO 110
+ ENDIF
+ ENDDO
+ ENDIF
+
+ 110 MWA(2) = 0
+ MWD(2) = 0
+ MWE(2) = 0
+ DO K = NDIG+2, L
+ MWA(K) = 0
+ MWD(K) = 0
+ MWE(K) = 0
+ ENDDO
+
+! (Inner Loop)
+
+ DO K = 2, N1
+ MTEMP = MA(K)
+ MWA(K+1) = MTEMP*MBJ
+ MWD(K+1) = MTEMP*MCJ
+ MWE(K+1) = MTEMP*MDJ
+ ENDDO
+ MAXMWA = MBJ
+ IF (MCJ > MAXMWA) MAXMWA = MCJ
+ IF (MDJ > MAXMWA) MAXMWA = MDJ
+ DO J = 3, N1
+ MBJ = MB(J)
+ MCJ = MC(J)
+ MDJ = MD(J)
+ MAXJ = MBJ
+ IF (MCJ > MAXJ) MAXJ = MCJ
+ IF (MDJ > MAXJ) MAXJ = MDJ
+ MAXMWA = MAXMWA + MAXJ
+ JM1 = J - 1
+ KL = MIN(KNZ,L-JM1)
+
+! Major (Inner Loop)
+
+ DO K = J+1, J+KL-1
+ MTEMP = MA(K-JM1)
+ MWA(K) = MWA(K) + MTEMP*MBJ
+ MWD(K) = MWD(K) + MTEMP*MCJ
+ MWE(K) = MWE(K) + MTEMP*MDJ
+ ENDDO
+
+ IF (MAXMWA > MMAX) THEN
+ MAXMWA = 0
+
+! Here normalization is only required for the
+! range of digits currently changing in MWA.
+
+ DO KB = JM1+KL, JM1+2, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ MKT = INT (MWD(KB)/MBASE)
+ MWD(KB-1) = MWD(KB-1) + MKT
+ MWD(KB) = MWD(KB) - MKT*MBASE
+ MKT = INT (MWE(KB)/MBASE)
+ MWE(KB-1) = MWE(KB-1) + MKT
+ MWE(KB) = MWE(KB) - MKT*MBASE
+ ENDDO
+ ENDIF
+ ENDDO
+
+! Perform the final normalization. (Inner Loop)
+
+ DO KB = L, 3, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ MKT = INT (MWD(KB)/MBASE)
+ MWD(KB-1) = MWD(KB-1) + MKT
+ MWD(KB) = MWD(KB) - MKT*MBASE
+ MKT = INT (MWE(KB)/MBASE)
+ MWE(KB-1) = MWE(KB-1) + MKT
+ MWE(KB) = MWE(KB) - MKT*MBASE
+ ENDDO
+
+ ELSE
+
+! If normalization must be done for each digit, combine
+! the two loops and normalize as the digits are multiplied.
+
+ DO J = 2, L
+ MWA(J) = 0
+ MWD(J) = 0
+ MWE(J) = 0
+ ENDDO
+ KJ = NDIG + 2
+ DO J = 2, N1
+ KJ = KJ - 1
+ MBKJ = MB(KJ)
+ MCKJ = MC(KJ)
+ MDKJ = MD(KJ)
+ KL = L - KJ + 1
+ IF (KL > N1) KL = N1
+ KI = KL + 2
+ KWA = KL+ KJ + 1
+ MKB = 0
+ MKC = 0
+ MKD = 0
+ DO K = 2, KL
+ MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MKB
+ MKB = INT (MT/MBASE)
+ MWA(KWA-K) = MT - MBASE*MKB
+ MT = MA(KI-K)*MCKJ + MWD(KWA-K) + MKC
+ MKC = INT (MT/MBASE)
+ MWD(KWA-K) = MT - MBASE*MKC
+ MT = MA(KI-K)*MDKJ + MWE(KWA-K) + MKD
+ MKD = INT (MT/MBASE)
+ MWE(KWA-K) = MT - MBASE*MKD
+ ENDDO
+ MWA(KWA-KL-1) = MKB
+ MWD(KWA-KL-1) = MKC
+ MWE(KWA-KL-1) = MKD
+ ENDDO
+
+ ENDIF
+
+! Set KSHIFT = 1 if a shift left is necessary.
+
+ IF (MWA(2) == 0) THEN
+ KSHIFT = 1
+ ELSE
+ KSHIFT = 0
+ ENDIF
+
+! The multiplications are complete.
+
+ IF ((MAS > 0 .AND. MBS > 0) .OR. (MAS < 0 .AND. MBS < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ MR = 2*MWA(NDIG+2+KSHIFT) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ELSE IF (MR >= MBASE) THEN
+ IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
+ MWA(N1+1+KSHIFT) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWA,ME)
+
+ IF ((MAS > 0 .AND. MCS > 0) .OR. (MAS < 0 .AND. MCS < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ IF (MWD(2) == 0) THEN
+ KSHIFT = 1
+ ELSE
+ KSHIFT = 0
+ ENDIF
+ MR = 2*MWD(NDIG+2+KSHIFT) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWD,NDIG,NGUARD,KSHIFT)
+ ELSE IF (MR >= MBASE) THEN
+ IF (MR-1 > MBASE .AND. MWD(N1+KSHIFT) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWD(N1+KSHIFT) = MWD(N1+KSHIFT) + 1
+ MWD(N1+1+KSHIFT) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWD,NDIG,NGUARD,KSHIFT)
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWD,MF)
+
+ IF ((MAS > 0 .AND. MDS > 0) .OR. (MAS < 0 .AND. MDS < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ IF (MWE(2) == 0) THEN
+ KSHIFT = 1
+ ELSE
+ KSHIFT = 0
+ ENDIF
+ MR = 2*MWE(NDIG+2+KSHIFT) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWE,NDIG,NGUARD,KSHIFT)
+ ELSE IF (MR >= MBASE) THEN
+ IF (MR-1 > MBASE .AND. MWE(N1+KSHIFT) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWE(N1+KSHIFT) = MWE(N1+KSHIFT) + 1
+ MWE(N1+1+KSHIFT) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWE,NDIG,NGUARD,KSHIFT)
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWE,MG)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMMPYE'
+ CALL FMWARN
+ ENDIF
+
+ ME(-1) = 1
+ IF (MAS*MBS < 0 .AND. ME(1) /= MUNKNO .AND. ME(2) /= 0) ME(-1) = -1
+ MF(-1) = 1
+ IF (MAS*MCS < 0 .AND. MF(1) /= MUNKNO .AND. MF(2) /= 0) MF(-1) = -1
+ MG(-1) = 1
+ IF (MAS*MDS < 0 .AND. MG(1) /= MUNKNO .AND. MG(2) /= 0) MG(-1) = -1
+
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(ME(2))+1))/0.69315)
+ ME(0) = MIN(MACCA,MACCB,MD2B)
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MF(2))+1))/0.69315)
+ MF(0) = MIN(MACCA,MACCC,MD2B)
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MG(2))+1))/0.69315)
+ MG(0) = MIN(MACCA,MACCD,MD2B)
+ ELSE
+ ME(0) = MIN(MACCA,MACCB)
+ MF(0) = MIN(MACCA,MACCC)
+ MG(0) = MIN(MACCA,MACCD)
+ ENDIF
+
+ 120 IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,ME,ME,1,1)
+ IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN
+ IF (NTRACE < 0) THEN
+ CALL FMNTRJ(MF,NDIG)
+ CALL FMNTRJ(MG,NDIG)
+ ELSE
+ CALL FMPRNT(MF)
+ CALL FMPRNT(MG)
+ ENDIF
+ ENDIF
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMMPYE
+
+ SUBROUTINE FMMPYI(MA,IVAL,MB)
+
+! MB = MA * IVAL
+
+! Multiply FM number MA by one word integer IVAL.
+
+! This routine is faster than FMMPY when IVAL*MBASE is a
+! one word integer.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER IVAL
+ REAL (KIND(1.0D0)) :: MACCA,MAS,MCARRY,MD2B,MKT,MLR,MVAL
+ INTEGER J,JRSSAV,KA,KB,KC,KSHIFT,N1,NGUARD,NMVAL,NV2
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JRSSAV = JRSIGN
+ MACCA = MA(0)
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMMPYI'
+ CALL FMNTR(2,MA,MA,1,1)
+ CALL FMNTRI(2,IVAL,0)
+ ENDIF
+ KFLAG = 0
+ N1 = NDIG + 1
+
+! Check for special cases.
+
+ IF (MA(2) == 0) THEN
+ CALL FMEQ(MA,MB)
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MB,MB,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (ABS(MA(1)) < MEXPOV .AND. ABS(IVAL) > 1) GO TO 110
+
+ IF (MA(1) == MUNKNO) THEN
+ CALL FMST2M('UNKNOWN',MB)
+ KFLAG = -4
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MB,MB,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (IVAL == 0) THEN
+ CALL FMIM(0,MB)
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MB,MB,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (ABS(IVAL) == 1) THEN
+ DO J = -1, N1
+ MB(J) = MA(J)
+ ENDDO
+ IF (MA(1) == MEXPOV) KFLAG = -5
+ IF (MA(1) == MEXPUN) KFLAG = -6
+ MB(-1) = MA(-1)*IVAL
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MB,MB,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (MA(1) == MEXPOV) THEN
+ MAS = MA(-1)
+ KFLAG = -5
+ CALL FMST2M('OVERFLOW',MB)
+ IF ((MAS < 0 .AND. IVAL > 0) .OR. &
+ (MAS > 0 .AND. IVAL < 0)) MB(-1) = -1
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MB,MB,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (MA(1) == MEXPUN) THEN
+ NAMEST(NCALL) = 'FMMPYI'
+ KFLAG = -4
+ CALL FMWARN
+ CALL FMST2M('UNKNOWN',MB)
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MB,MB,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+! Work with positive numbers.
+
+ 110 MAS = MA(-1)
+ MVAL = ABS(IVAL)
+ NMVAL = INT(MVAL)
+ NV2 = NMVAL - 1
+
+! To leave room for the normalization, shift the product
+! to the right KSHIFT places in MWA.
+
+ KSHIFT = INT((LOG(DBLE(MA(2)+1)*DBLE(MVAL)))/DLOGMB)
+
+! If IVAL is too big use FMMPY.
+
+ IF (KSHIFT > NDIG .OR. MVAL > MAXINT/MBASE .OR. &
+ NMVAL /= ABS(IVAL) .OR. NV2 /= ABS(IVAL)-1) THEN
+ CALL FMIM(IVAL,M01)
+ CALL FMMPY2(MA,M01,MB)
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MB,MB,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ MWA(1) = MA(1) + KSHIFT
+ KA = 2 + KSHIFT
+ KB = N1 + KSHIFT
+ KC = NDIG + 5
+ DO J = KB, KC
+ MWA(J) = 0
+ ENDDO
+
+ MCARRY = 0
+
+! This is the main multiplication loop.
+
+ DO J = KB, KA, -1
+ MKT = MA(J-KSHIFT)*MVAL + MCARRY
+ MCARRY = INT (MKT/MBASE)
+ MWA(J) = MKT - MCARRY*MBASE
+ ENDDO
+
+! Resolve the final carry.
+
+ DO J = KA-1, 2, -1
+ MKT = INT (MCARRY/MBASE)
+ MWA(J) = MCARRY - MKT*MBASE
+ MCARRY = MKT
+ ENDDO
+
+! Now the first significant digit in the product is in
+! MWA(2) or MWA(3). Round the result and move it to MB.
+
+ IF ((MAS > 0 .AND. IVAL > 0) .OR. (MAS < 0 .AND. IVAL < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ IF (MWA(2) == 0) THEN
+ MLR = 2*MWA(NDIG+3) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ NGUARD = KSHIFT - 1
+ CALL FMRND(MWA,NDIG,NGUARD,1)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1+1) = MWA(N1+1) + 1
+ MWA(N1+2) = 0
+ ENDIF
+ ELSE
+ NGUARD = KSHIFT - 1
+ CALL FMRND(MWA,NDIG,NGUARD,1)
+ ENDIF
+ ENDIF
+ ELSE
+ MLR = 2*MWA(NDIG+2) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,KSHIFT,0)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1) = MWA(N1) + 1
+ MWA(N1+1) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,KSHIFT,0)
+ ENDIF
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWA,MB)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMMPYI'
+ CALL FMWARN
+ ENDIF
+
+! Put the sign on the result.
+
+ MB(-1) = JRSIGN
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MACCA,MD2B)
+ ELSE
+ MB(0) = MACCA
+ ENDIF
+
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MB,MB,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMMPYI
+
+ SUBROUTINE FMMPYI_R1(MA,IVAL)
+
+! MA = MA * IVAL
+
+! Multiply FM number MA by one word integer IVAL.
+
+! This routine is faster than FMMPY when IVAL*MBASE is a
+! one word integer.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER IVAL
+ REAL (KIND(1.0D0)) :: MACCA,MAS,MCARRY,MD2B,MKT,MLR,MVAL
+ INTEGER J,JRSSAV,KA,KB,KC,KSHIFT,N1,NGUARD,NMVAL,NV2
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JRSSAV = JRSIGN
+ MACCA = MA(0)
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMMPYI'
+ CALL FMNTR(2,MA,MA,1,1)
+ CALL FMNTRI(2,IVAL,0)
+ ENDIF
+ KFLAG = 0
+ N1 = NDIG + 1
+
+! Check for special cases.
+
+ IF (MA(2) == 0) THEN
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MA,MA,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (ABS(MA(1)) < MEXPOV .AND. ABS(IVAL) > 1) GO TO 110
+
+ IF (MA(1) == MUNKNO) THEN
+ CALL FMST2M('UNKNOWN',MA)
+ KFLAG = -4
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MA,MA,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (IVAL == 0) THEN
+ CALL FMIM(0,MA)
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MA,MA,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (ABS(IVAL) == 1) THEN
+ IF (MA(1) == MEXPOV) KFLAG = -5
+ IF (MA(1) == MEXPUN) KFLAG = -6
+ MA(-1) = MA(-1)*IVAL
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MA,MA,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (MA(1) == MEXPOV) THEN
+ MAS = MA(-1)
+ KFLAG = -5
+ CALL FMST2M('OVERFLOW',MA)
+ IF ((MAS < 0 .AND. IVAL > 0) .OR. &
+ (MAS > 0 .AND. IVAL < 0)) MA(-1) = -1
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MA,MA,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ IF (MA(1) == MEXPUN) THEN
+ NAMEST(NCALL) = 'FMMPYI'
+ KFLAG = -4
+ CALL FMWARN
+ CALL FMST2M('UNKNOWN',MA)
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MA,MA,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+! Work with positive numbers.
+
+ 110 MAS = MA(-1)
+ MVAL = ABS(IVAL)
+ NMVAL = INT(MVAL)
+ NV2 = NMVAL - 1
+
+! To leave room for the normalization, shift the product
+! to the right KSHIFT places in MWA.
+
+ KSHIFT = INT((LOG(DBLE(MA(2)+1)*DBLE(MVAL)))/DLOGMB)
+
+! If IVAL is too big use FMMPY.
+
+ IF (KSHIFT > NDIG .OR. MVAL > MAXINT/MBASE .OR. &
+ NMVAL /= ABS(IVAL) .OR. NV2 /= ABS(IVAL)-1) THEN
+ CALL FMIM(IVAL,M01)
+ CALL FMMPY2_R1(MA,M01)
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MA,MA,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ ENDIF
+
+ MWA(1) = MA(1) + KSHIFT
+ KA = 2 + KSHIFT
+ KB = N1 + KSHIFT
+ KC = NDIG + 5
+ DO J = KB, KC
+ MWA(J) = 0
+ ENDDO
+
+ MCARRY = 0
+
+! This is the main multiplication loop.
+
+ DO J = KB, KA, -1
+ MKT = MA(J-KSHIFT)*MVAL + MCARRY
+ MCARRY = INT (MKT/MBASE)
+ MWA(J) = MKT - MCARRY*MBASE
+ ENDDO
+
+! Resolve the final carry.
+
+ DO J = KA-1, 2, -1
+ MKT = INT (MCARRY/MBASE)
+ MWA(J) = MCARRY - MKT*MBASE
+ MCARRY = MKT
+ ENDDO
+
+! Now the first significant digit in the product is in
+! MWA(2) or MWA(3). Round the result and move it to MA.
+
+ IF ((MAS > 0 .AND. IVAL > 0) .OR. (MAS < 0 .AND. IVAL < 0)) THEN
+ JRSIGN = 1
+ ELSE
+ JRSIGN = -1
+ ENDIF
+ IF (MWA(2) == 0) THEN
+ MLR = 2*MWA(NDIG+3) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ NGUARD = KSHIFT - 1
+ CALL FMRND(MWA,NDIG,NGUARD,1)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWA(N1+1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1+1) = MWA(N1+1) + 1
+ MWA(N1+2) = 0
+ ENDIF
+ ELSE
+ NGUARD = KSHIFT - 1
+ CALL FMRND(MWA,NDIG,NGUARD,1)
+ ENDIF
+ ENDIF
+ ELSE
+ MLR = 2*MWA(NDIG+2) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,KSHIFT,0)
+ ELSE IF (MLR >= MBASE) THEN
+ IF (MLR-1 > MBASE .AND. MWA(N1) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1) = MWA(N1) + 1
+ MWA(N1+1) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,KSHIFT,0)
+ ENDIF
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWA,MA)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMMPYI'
+ CALL FMWARN
+ ENDIF
+
+! Put the sign on the result.
+
+ MA(-1) = JRSIGN
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315)
+ MA(0) = MIN(MACCA,MD2B)
+ ELSE
+ MA(0) = MACCA
+ ENDIF
+
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(1,MA,MA,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMMPYI_R1
+
+ SUBROUTINE FMNINT(MA,MB)
+
+! MB = NINT(MA) -- MB is returned as the nearest integer to MA.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MA2,MXSAVE
+ INTEGER J,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB) THEN
+ CALL FMENTR('FMNINT',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMNINT'
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMEQ2(MA,MB,NDSAVE,NDIG)
+ IF (NDSAVE > INT(MA(1))) THEN
+ MA2 = MA(-1)
+ MB(-1) = 1
+ CALL FMI2M(1,M01)
+ CALL FMDIVI_R1(M01,2)
+ CALL FMADD_R1(MB,M01)
+ CALL FMINT(MB,M08)
+ CALL FMEQ(M08,MB)
+ IF (MA2 < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
+ ENDIF
+ KWARN = KWRNSV
+
+! Round the result and return.
+
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMNINT
+
+ SUBROUTINE FMNTR(NTR,MA,MB,NARG,KNAM)
+
+! Print FM numbers in base 10 format using FMOUT for conversion.
+! This is used for trace output from the FM routines.
+
+! NTR = 1 if a result of an FM call is to be printed.
+! = 2 to print input argument(s) to an FM call.
+
+! MA - the FM number to be printed.
+
+! MB - an optional second FM number to be printed.
+
+! NARG - the number of arguments. NARG = 1 if only MA is to be
+! printed, and NARG = 2 if both MA and MB are to be printed.
+
+! KNAM - positive if the routine name is to be printed.
+
+
+! NTRACE and LVLTRC (in module FMVALS) control trace printout.
+
+! NTRACE = 0 No printout except warnings and errors.
+
+! NTRACE = 1 The result of each call to one of the routines
+! is printed in base 10, using FMOUT.
+
+! NTRACE = -1 The result of each call to one of the routines
+! is printed in internal base MBASE format.
+
+! NTRACE = 2 The input arguments and result of each call to one
+! of the routines is printed in base 10, using FMOUT.
+
+! NTRACE = -2 The input arguments and result of each call to one
+! of the routines is printed in base MBASE format.
+
+! LVLTRC defines the call level to which the trace is done. LVLTRC = 1
+! means only FM routines called directly by the user are traced,
+! LVLTRC = K prints traces for FM routines with call levels up
+! to and including level K.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER KNAM,NTR,NARG
+
+ CHARACTER(6) :: NAME
+
+ IF (NTRACE == 0) RETURN
+ IF (NCALL > LVLTRC) RETURN
+ IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN
+
+ IF (NTR == 2) THEN
+ IF (KNAM > 0) THEN
+ NAME = NAMEST(NCALL)
+ WRITE (KW,"(' Input to ',A6)") NAME
+ ENDIF
+ ELSE
+ NAME = NAMEST(NCALL)
+ IF (KFLAG == 0) THEN
+ WRITE (KW, &
+ "(' ',A6,15X,'Call level =',I2,5X,'MBASE ='," // &
+ "I10,5X,'NDIG =',I6)" &
+ ) NAME,NCALL,INT(MBASE),NDIG
+ ELSE
+ WRITE (KW, &
+ "(' ',A6,6X,'Call level =',I2,4X,'MBASE ='," // &
+ "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)" &
+ ) NAME,NCALL,INT(MBASE),NDIG,KFLAG
+ ENDIF
+ ENDIF
+
+! Check for base MBASE internal format trace.
+
+ IF (NTRACE < 0) THEN
+ CALL FMNTRJ(MA,NDIG)
+ IF (NARG == 2) CALL FMNTRJ(MB,NDIG)
+ ENDIF
+
+! Check for base 10 trace using FMOUT.
+
+ IF (NTRACE > 0) THEN
+ CALL FMPRNT(MA)
+
+ IF (NARG == 2) THEN
+ CALL FMPRNT(MB)
+ ENDIF
+ ENDIF
+
+ RETURN
+ END SUBROUTINE FMNTR
+
+ SUBROUTINE FMNTRI(NTR,N,KNAM)
+
+! Internal routine for trace output of integer variables.
+
+! NTR = 1 for output values
+! 2 for input values
+
+! N Integer to be printed.
+
+! KNAM is positive if the routine name is to be printed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER NTR,N,KNAM
+
+ CHARACTER(6) :: NAME
+
+ IF (NTRACE == 0) RETURN
+ IF (NCALL > LVLTRC) RETURN
+ IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN
+
+ IF (NTR == 2 .AND. KNAM > 0) THEN
+ NAME = NAMEST(NCALL)
+ WRITE (KW,"(' Input to ',A6)") NAME
+ ENDIF
+ IF (NTR == 1 .AND. KNAM > 0) THEN
+ NAME = NAMEST(NCALL)
+ IF (KFLAG == 0) THEN
+ WRITE (KW, &
+ "(' ',A6,15X,'Call level =',I2,5X,'MBASE ='," // &
+ "I10,5X,'NDIG =',I6)" &
+ ) NAME,NCALL,INT(MBASE),NDIG
+ ELSE
+ WRITE (KW, &
+ "(' ',A6,6X,'Call level =',I2,4X,'MBASE ='," // &
+ "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)" &
+ ) NAME,NCALL,INT(MBASE),NDIG,KFLAG
+ ENDIF
+ ENDIF
+
+ WRITE (KW,"(1X,I18)") N
+
+ RETURN
+ END SUBROUTINE FMNTRI
+
+ SUBROUTINE FMNTRJ(MA,ND)
+
+! Print trace output in internal base MBASE format. The number to
+! be printed is in MA.
+
+! ND is the number of base MBASE digits to be printed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER ND
+
+ CHARACTER(50) :: FORM
+ INTEGER J,L,N,N1
+
+ N1 = ND + 1
+
+ L = INT(LOG10(DBLE(MBASE-1))) + 2
+ N = (KSWIDE-23)/L
+ IF (N > 10) N = 5*(N/5)
+ IF (ND <= N) THEN
+ WRITE (FORM,"(' (1X,I19,I',I2,',',I3,'I',I2,') ')") L+2, N-1, L
+ ELSE
+ WRITE (FORM, &
+ "(' (1X,I19,I',I2,',',I3,'I',I2,'/" // &
+ "(22X,',I3,'I',I2,')) ')" &
+ ) L+2, N-1, L, N, L
+ ENDIF
+ WRITE (KW,FORM) INT(MA(1)),INT(MA(-1)*MA(2)),(INT(MA(J)),J=3,N1)
+
+ RETURN
+ END SUBROUTINE FMNTRJ
+
+ SUBROUTINE FMNTRR(NTR,X,KNAM)
+
+! Internal routine for trace output of real variables.
+
+! NTR - 1 for output values
+! 2 for input values
+
+! X - Double precision value to be printed if NX == 1
+
+! KNAM - Positive if the routine name is to be printed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER NTR,KNAM
+ DOUBLE PRECISION X
+
+ CHARACTER(6) :: NAME
+
+ IF (NTRACE == 0) RETURN
+ IF (NCALL > LVLTRC) RETURN
+ IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN
+
+ IF (NTR == 2 .AND. KNAM > 0) THEN
+ NAME = NAMEST(NCALL)
+ WRITE (KW,"(' Input to ',A6)") NAME
+ ENDIF
+ IF (NTR == 1 .AND. KNAM > 0) THEN
+ NAME = NAMEST(NCALL)
+ IF (KFLAG == 0) THEN
+ WRITE (KW, &
+ "(' ',A6,15X,'Call level =',I2,5X,'MBASE ='," // &
+ "I10,5X,'NDIG =',I6)" &
+ ) NAME,NCALL,INT(MBASE),NDIG
+ ELSE
+ WRITE (KW, &
+ "(' ',A6,6X,'Call level =',I2,4X,'MBASE ='," // &
+ "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)" &
+ ) NAME,NCALL,INT(MBASE),NDIG,KFLAG
+ ENDIF
+ ENDIF
+
+ WRITE (KW,"(1X,D30.20)") X
+
+ RETURN
+ END SUBROUTINE FMNTRR
+
+ SUBROUTINE FMOUT(MA,LINE,LB)
+
+! Convert a floating multiple precision number to a character array
+! for output.
+
+! MA is an FM number to be converted to an A1 character
+! array in base 10 format
+! LINE is the CHARACTER*1 array in which the result is returned.
+! LB is the length of LINE.
+
+! JFORM1 and JFORM2 (in module FMVALS) determine the format of LINE.
+
+! JFORM1 = 0 normal setting ( .314159M+6 )
+! = 1 1PE format ( 3.14159M+5 )
+! = 2 F format ( 314159.000 )
+
+! JFORM2 = number of significant digits to display (if JFORM1 = 0, 1)
+! = number of digits after the decimal point (if JFORM1 = 2)
+
+! If JFORM2 == 0 and JFORM1 /= 2 then a default number of
+! digits is chosen. The default is roughly the full precision
+! of MA.
+
+! If JFORM2 == 0 and JFORM1 == 2 then the number is returned in
+! integer format with no decimal point. Rounding is done as
+! with other settings, so the value displayed is the nearest
+! integer to MA.
+
+! If JFORM1 == 2 and MA is too large or too small to display in the
+! requested format, it is converted using JFORM1=0, JFORM2=0.
+
+! LINE should be dimensioned at least LOG10(MBASE)*NDIG + 15 on a
+! 32-bit machine to allow for up to 10 digit exponents. Replace
+! 15 by 20 if 48-bit integers are used, 25 for 64-bit integers, ....
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER LB
+ CHARACTER LINE(LB)
+
+ CHARACTER KCHAR
+ REAL (KIND(1.0D0)) :: M2,MBSAVE,MEXP,MEXP10,MKT,MNDGMS,MS1,MS2, &
+ MSD2,MT10,MXSAVE
+ INTEGER J,JDPT,JF1SAV,JF2SAV,K,K1,K2,KA,KASAVE,KB,KC,KDIGIT, &
+ KEXP,KEXPSH,KMS2SD,KMT,KPT,KRSAVE,L,ND,NDE,NDE2,NDIGMS, &
+ NDS2,NDSAVE,NPOWER,NSD1,NSD2,NVAL,NWORD,NWORD1,NWORD2
+ REAL X
+
+ CHARACTER :: NUMB(10) = (/ '0','1','2','3','4','5','6','7','8','9' /)
+ CHARACTER :: NUNKNO(12) = (/ &
+ ' ',' ',' ','U','N','K','N','O','W','N',' ',' ' /)
+ CHARACTER :: NEXPOV(12) = (/ &
+ ' ',' ',' ','O','V','E','R','F','L','O','W',' ' /)
+ CHARACTER :: NEXPUN(12) = (/ &
+ ' ',' ',' ','U','N','D','E','R','F','L','O','W' /)
+
+! To avoid recursion, FMOUT calls only internal arithmetic
+! routines (FMADD2, FMMPY2, ...), so no trace printout is
+! done during a call to FMOUT.
+
+ KFLAG = 0
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMOUT '
+
+! Raise the call stack again, since the internal
+! routines don't.
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMOUT '
+ DO J = 1, LB
+ LINE(J) = ' '
+ ENDDO
+
+! Check for special cases.
+
+ IF (MA(1) == MUNKNO) THEN
+ DO J = 1, 12
+ LINE(J) = NUNKNO(J)
+ ENDDO
+ NCALL = NCALL - 2
+ RETURN
+ ENDIF
+ IF (MA(1) == MEXPOV) THEN
+ DO J = 1, 12
+ LINE(J) = NEXPOV(J)
+ ENDDO
+ LINE(2) = '+'
+ IF (MA(-1) < 0) LINE(2) = '-'
+ NCALL = NCALL - 2
+ RETURN
+ ENDIF
+ IF (MA(1) == MEXPUN) THEN
+ DO J = 1, 12
+ LINE(J) = NEXPUN(J)
+ ENDDO
+ LINE(2) = '+'
+ IF (MA(-1) < 0) LINE(2) = '-'
+ NCALL = NCALL - 2
+ RETURN
+ ENDIF
+ IF (MA(2) == 0 .AND. JFORM1 == 2 .AND. JFORM2 == 0) THEN
+ LINE(2) = '0'
+ NCALL = NCALL - 2
+ RETURN
+ ENDIF
+
+ KASAVE = KACCSW
+ KACCSW = 0
+ KRSAVE = KROUND
+ KROUND = 1
+ JF1SAV = JFORM1
+ JF2SAV = JFORM2
+ MBSAVE = MBASE
+ NDSAVE = NDIG
+ MXSAVE = MXEXP
+
+! ND is the number of base 10 digits required.
+
+ 110 ND = JFORM2
+ IF (JFORM1 == 2 .AND. MA(1) > 0) ND = JFORM2 + &
+ INT(REAL(MA(1))*LOG10(REAL(MBASE))) + 1
+ IF (ND <= 1) THEN
+ K = INT(REAL(NDIG)*LOG10(REAL(MBASE)))
+ ND = MAX(K,JFORM2)
+ ENDIF
+ IF (JFORM2 <= 0 .AND. JFORM1 <= 1) ND = &
+ INT(1.1 + REAL(NDIG-1)*LOG10(REAL(MBASE)))
+ IF (ND < 2) ND = 2
+
+ IF (LB < ND+6) THEN
+ IF (JFORM1 == 2) THEN
+ JFORM1 = 0
+ JFORM2 = 0
+ GO TO 110
+ ENDIF
+ GO TO 170
+ ENDIF
+
+! Convert to the base that is the largest power of 10
+! less than MXBASE and build the output number.
+
+ NPOWER = INT(LOG10(REAL(MXBASE)/4))
+ MXEXP = MXEXP2
+ MBASE = 10**NPOWER
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ NDIG = ND/NPOWER + 3
+ IF (NDIG < 2) NDIG = 2
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ NCALL = NCALL - 1
+ CALL FMWARN
+ NCALL = NCALL + 1
+ GO TO 170
+ ENDIF
+
+ IF (MA(2) == 0) THEN
+ CALL FMIM(0,MLV4)
+ GO TO 130
+ ENDIF
+
+! Check to see if MA is already in a base that is a
+! power of ten. If so, the conversion can be skipped.
+
+ K = NPOWER
+ DO J = 1, K
+ MBASE = 10**J
+ IF (MBASE == MBSAVE) THEN
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ NPOWER = J
+ NDIG = ND/NPOWER + 2
+ IF (NDIG < 2) NDIG = 2
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ NCALL = NCALL - 1
+ CALL FMWARN
+ NCALL = NCALL + 1
+ GO TO 170
+ ENDIF
+ CALL FMEQ2(MA,MLV4,NDSAVE,NDIG)
+ MLV4(-1) = 1
+ GO TO 130
+ ENDIF
+ ENDDO
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ CALL FMIM(INT(MBSAVE),MLV2)
+ NDS2 = NDSAVE + 1
+ CALL FMIM(1,MLV3)
+ KMT = 1
+
+! Convert the fraction part of MA to the new base.
+
+ KPT = NDS2 + 1
+ DO J = 3, NDS2
+ KPT = KPT - 1
+ IF (MA(KPT) /= 0) EXIT
+ ENDDO
+
+ KEXPSH = KPT - 1
+ KDIGIT = INT(ABS(MA(2)))
+ CALL FMIM(KDIGIT,MLV4)
+ NDIGMS = NDIG
+
+ DO J = 3, KPT
+ KDIGIT = INT(MA(J))
+ NDIG = MIN(NDIGMS,MAX(2,INT(MLV4(1)+MLV2(1))))
+ CALL FMMPY2_R1(MLV4,MLV2)
+
+ IF (KDIGIT > 0) THEN
+ IF (KMT /= KDIGIT) THEN
+ NDIG = MIN(NDIGMS,MAX(2,INT(MLV2(1))))
+ CALL FMIM(KDIGIT,MLV3)
+ KMT = KDIGIT
+ ENDIF
+ NDIG = MIN(NDIGMS,MAX(2,INT(MAX(MLV4(1),MLV3(1)))+1))
+ CALL FMADD2_R1(MLV4,MLV3)
+ ENDIF
+ ENDDO
+
+! Convert the exponent.
+
+ NDIG = NDIGMS
+ CALL FMIM(1,MLV3)
+ K = ABS(INT(MA(1))-KEXPSH)
+ IF (MOD(K,2) == 1) THEN
+ CALL FMEQ(MLV2,MLV3)
+ ELSE
+ CALL FMIM(1,MLV3)
+ ENDIF
+
+ 120 K = K/2
+ M2 = 2
+ MNDGMS = NDIGMS
+ NDIG = INT(MIN(MNDGMS,MAX(M2,MLV2(1)*M2)))
+ IF (K > 0) CALL FMSQR2_R1(MLV2)
+ IF (MOD(K,2) == 1) THEN
+ NDIG = INT(MIN(MNDGMS,MAX(M2,MLV3(1)+MLV2(1))))
+ CALL FMMPY2_R1(MLV3,MLV2)
+ ENDIF
+ IF (K > 1) GO TO 120
+
+ NDIG = NDIGMS
+ IF (MA(1)-KEXPSH < 0) THEN
+ CALL FMDIV2_R1(MLV4,MLV3)
+ ELSE
+ CALL FMMPY2_R1(MLV4,MLV3)
+ ENDIF
+
+! Now MLV4 is the value of MA converted to a
+! power of ten base.
+
+! Convert it to a character string base 10 for output.
+
+! MEXP10 is the base 10 exponent.
+! KMS2SD is the number of base 10 significant digits
+! in MLV4(2).
+
+ 130 MS1 = MLV4(1)
+ 140 MEXP10 = NPOWER*MLV4(1)
+ KMS2SD = NPOWER
+ K = INT(MBASE)
+ DO J = 1, NPOWER
+ K = K/10
+ IF (MLV4(2) < K .AND. MLV4(2) /= 0) THEN
+ MEXP10 = MEXP10 - 1
+ KMS2SD = KMS2SD - 1
+ ENDIF
+ ENDDO
+
+! For printing using JFORM1 = 1, reduce the exponent to
+! account for the fact that the decimal point and first
+! significant digit will later be swapped.
+
+ IF (JFORM1 == 1 .AND. MLV4(2) /= 0) MEXP10 = MEXP10 - 1
+
+! Find the position in the unpacked number for rounding.
+! NWORD is the word in which rounding is done, or zero if
+! no rounding is necessary.
+! NWORD is set to -1 if JFORM1 is 2 (F format) but no
+! significant digits would be printed. This case
+! defaults to JFORM1 = 0.
+! NVAL gives the position within that word where rounding
+! occurs.
+! NSD1 is the maximum number of base 10 S.D.'s in NWORD
+! digits of base 10**NPOWER.
+! NSD2 is the number of base 10 S.D.'s needed to get ND
+! base 10 digits after the decimal.
+
+ NSD2 = ND
+ IF (JFORM1 == 2) THEN
+ MSD2 = JFORM2 + MEXP10
+ IF (MSD2 > ND) THEN
+ NSD2 = ND
+ ELSE
+ NSD2 = INT(MSD2)
+ ENDIF
+ NWORD = (NSD2-KMS2SD-1+NPOWER)/NPOWER + 2
+ IF (NWORD < 2) NWORD = -1
+ IF (NWORD > NDIG) NWORD = 0
+ IF (NWORD >= 2 .AND. NSD2 <= 0) NWORD = -1
+ ELSE
+ NWORD = (ND-KMS2SD-1+NPOWER)/NPOWER + 2
+ ENDIF
+ NSD1 = KMS2SD + NPOWER*(NWORD-2)
+ IF (NWORD < 2) THEN
+ NVAL = 0
+ ELSE
+ NVAL = 10**(NSD1-NSD2)
+ ENDIF
+
+! Now do the base 10 rounding.
+
+ IF (NWORD >= 2) THEN
+ X = 0.0
+ IF (NVAL > 1) X = MOD(INT(MLV4(NWORD)),NVAL)
+ IF (NWORD < NDIG+1) THEN
+ X = REAL(DBLE(X) + DBLE(MLV4(NWORD+1))/DBLE(MBASE))
+ ENDIF
+ X = X/NVAL
+ IF (X < 0.5) GO TO 150
+ MS2 = MLV4(2)
+ MLV4(NWORD) = INT(MLV4(NWORD)/NVAL)*NVAL
+ MLV4(NWORD+1) = 0
+ MLV4(NWORD+2) = 0
+ MLV4(NWORD) = MLV4(NWORD) + NVAL
+ IF (MLV4(NWORD) >= MBASE) THEN
+ NWORD1 = NWORD - 1
+ NWORD2 = NWORD - 2
+ IF (NWORD > 2) THEN
+ CALL FMEQ2_R1(MLV4,NWORD1,NWORD2)
+ ELSE
+ MLV4(1) = MLV4(1) + 1
+ MLV4(2) = INT(MLV4(2)/MBASE)
+ MLV4(3) = 0
+ ENDIF
+ ENDIF
+ IF (MLV4(1) /= MS1 .OR. MLV4(2) /= MS2) GO TO 140
+ ENDIF
+
+! Build the base 10 character string.
+
+ 150 IF (MA(-1) < 0) LINE(1) = '-'
+ LINE(2) = '.'
+ K = 10**KMS2SD
+ L = 2
+ IF (NWORD == -1) NSD2 = ND
+ DO J = 1, NSD2
+ K = K/10
+ IF (K == 0) THEN
+ K = INT(MBASE)/10
+ L = L + 1
+ ENDIF
+ KDIGIT = INT(MLV4(L))/K
+ MLV4(L) = MOD(INT(MLV4(L)),K)
+ LINE(J+2) = NUMB(KDIGIT+1)
+ ENDDO
+
+ KA = NSD2 + 3
+ KB = ND + 2
+ IF (KB >= KA) THEN
+ DO J = KA, KB
+ LINE(J) = NUMB(1)
+ ENDDO
+ ENDIF
+
+ LINE(ND+3) = CMCHAR
+ LINE(ND+4) = '+'
+ IF (MEXP10 < 0) LINE(ND+4) = '-'
+ IF (MA(2) == 0) LINE(ND+4) = ' '
+
+! Build the digits of the base 10 exponent backwards,
+! then reverse them.
+
+ NDE = 1
+ MEXP = ABS(MEXP10)
+ MT10 = 10
+ DO J = 1, LB
+ MKT = AINT (MEXP/MT10)
+ KDIGIT = INT(MEXP-MKT*MT10)
+ LINE(ND+4+J) = NUMB(KDIGIT+1)
+ MEXP = MKT
+ IF (MEXP == 0) EXIT
+
+ IF (ND+5+J > LB) THEN
+ DO K = 1, LB
+ LINE(K) = '*'
+ ENDDO
+ GO TO 160
+ ENDIF
+
+ NDE = NDE + 1
+ ENDDO
+
+ NDE2 = NDE/2
+ IF (NDE2 < 1) GO TO 160
+ K1 = ND + 4
+ K2 = ND + 5 + NDE
+ DO J = 1, NDE2
+ K1 = K1 + 1
+ K2 = K2 - 1
+ KCHAR = LINE(K1)
+ LINE(K1) = LINE(K2)
+ LINE(K2) = KCHAR
+ ENDDO
+
+! If JFORM1 is 1 put the first digit left of the decimal.
+
+ 160 IF (JFORM1 == 1) THEN
+ KCHAR = LINE(2)
+ LINE(2) = LINE(3)
+ LINE(3) = KCHAR
+ ENDIF
+
+! If JFORM1 is 2 put the number into fixed format.
+
+ IF (JFORM1 == 2 .AND. JFORM2 >= 0) THEN
+ IF (MEXP10 <= -JFORM2 .OR. MEXP10+2 > LB) THEN
+ JFORM1 = 0
+ JFORM2 = 0
+ MBASE = MBSAVE
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ NDIG = NDSAVE
+ MXEXP = MXSAVE
+ DO J = 1, LB
+ LINE(J) = ' '
+ ENDDO
+ GO TO 110
+ ENDIF
+ KA = ND + 3
+ DO J = KA, LB
+ LINE(J) = NUMB(1)
+ ENDDO
+
+ KEXP = INT(MEXP10)
+ IF (MEXP10 > 0) THEN
+ DO J = 1, KEXP
+ LINE(J+1) = LINE(J+2)
+ ENDDO
+ LINE(KEXP+2) = '.'
+ ENDIF
+
+ IF (MEXP10 < 0) THEN
+ KEXP = -INT(MEXP10)
+ KA = 3 + KEXP
+ KB = LB + 1
+ KC = KB - KEXP
+ DO J = KA, LB
+ KB = KB - 1
+ KC = KC - 1
+ LINE(KB) = LINE(KC)
+ LINE(KC) = NUMB(1)
+ ENDDO
+ ENDIF
+
+ JDPT = 0
+ DO J = 1, LB
+ IF (LINE(J) == '.') JDPT = J
+ IF (JDPT > 0 .AND. J > JDPT+JFORM2) LINE(J) = ' '
+ ENDDO
+ IF (JFORM2 == 0 .AND. JDPT > 0) LINE(KEXP+2) = ' '
+
+ ENDIF
+
+! Restore values and return
+
+ GO TO 180
+
+! LINE is not big enough to hold the number
+! of digits specified.
+
+ 170 KFLAG = -8
+ DO J = 1, LB
+ LINE(J) = '*'
+ ENDDO
+ NCALL = NCALL - 1
+ CALL FMWARN
+ NCALL = NCALL + 1
+
+ 180 MBASE = MBSAVE
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ NDIG = NDSAVE
+ MXEXP = MXSAVE
+ NCALL = NCALL - 2
+ KACCSW = KASAVE
+ KROUND = KRSAVE
+ JFORM1 = JF1SAV
+ JFORM2 = JF2SAV
+ RETURN
+ END SUBROUTINE FMOUT
+
+ SUBROUTINE FMPACK(MA,MP)
+
+! MA is packed two base NDIG digits per word and returned in MP.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MP(-1:LPACK)
+
+ INTEGER J,KP
+
+ KP = 2
+ MP(-1) = MA(-1)
+ MP(0) = MA(0)
+ MP(1) = MA(1)
+ MP(2) = ABS(MA(2))*MBASE + MA(3)
+ IF (NDIG >= 4) THEN
+ DO J = 4, NDIG, 2
+ KP = KP + 1
+ MP(KP) = MA(J)*MBASE + MA(J+1)
+ ENDDO
+ ENDIF
+ IF (MOD(NDIG,2) == 1) MP(KP+1) = MA(NDIG+1)*MBASE
+ RETURN
+ END SUBROUTINE FMPACK
+
+ SUBROUTINE FMPI(MA)
+
+! MA = pi
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ CHARACTER(155) :: STRING
+ INTEGER K,KASAVE,NDMB,NDSAVE,NDSV
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KFLAG = 0
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMPI '
+ IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
+ WRITE (KW,"(' Input to FMPI')")
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+
+! Increase the working precision.
+
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = NGRD52
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MA)
+ GO TO 110
+ ENDIF
+ ENDIF
+
+! Check to see if pi has previously been computed
+! in base MBASE with sufficient precision.
+
+ IF (MBSPI == MBASE .AND. NDIGPI >= NDIG) THEN
+ IF (NAMEST(NCALL-1) /= 'NOEQ ') THEN
+ KACCSW = KASAVE
+ CALL FMEQ2(MPISAV,MA,NDIGPI,NDSAVE)
+ ENDIF
+ ELSE
+ NDMB = INT(150.0*2.302585/ALOGMB)
+ IF (NDMB >= NDIG) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDMB,NDG2MX)
+ STRING = '3.141592653589793238462643383279502884197169'// &
+ '39937510582097494459230781640628620899862803482534211'// &
+ '7067982148086513282306647093844609550582231725359408128'
+ CALL FMST2M(STRING,MPISAV)
+ MPISAV(0) = NINT(NDIG*ALOGM2)
+ MBSPI = MBASE
+ NDIGPI = NDIG
+ IF (ABS(MPISAV(1)) > 10) NDIGPI = 0
+ ELSE
+ NDSV = NDIG
+ NDIG = MIN(NDIG+2,NDG2MX)
+ CALL FMPI2(MPISAV)
+ MPISAV(0) = NINT(NDIG*ALOGM2)
+ MBSPI = MBASE
+ NDIGPI = NDIG
+ IF (ABS(MPISAV(1)) > 10) NDIGPI = 0
+ ENDIF
+ IF (NAMEST(NCALL-1) /= 'NOEQ ') THEN
+ KACCSW = KASAVE
+ CALL FMEQ2(MPISAV,MA,NDIG,NDSAVE)
+ ENDIF
+ NDIG = NDSV
+ ENDIF
+
+ 110 NDIG = NDSAVE
+ KACCSW = KASAVE
+ IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMPI
+
+ SUBROUTINE FMPI2(MPI)
+
+! Internal routine to compute pi.
+! The formula used is due to S. Ramanujan:
+! (4n)!(1103+26390n)
+! 1/pi = (sqrt(8)/9801) * sum(n=0 to infinity) --------------------
+! ((n!)**4)(396**(4n))
+! The result is returned in MPI.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MPI(-1:LUNPCK)
+ DOUBLE PRECISION X
+ REAL (KIND(1.0D0)) :: MX
+ INTEGER NSTACK(19),J,K,KST,LARGE,N,NDIGRD,NDSAVE
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ NDSAVE = NDIG
+ N = -1
+ CALL FMI2M(1103,MPI)
+ CALL FMI2M(1,M02)
+ CALL FMI2M(26390,M03)
+ CALL FMI2M(1103,M04)
+ MX = MXBASE**2/MBASE
+ IF (MX > MXEXP2) MX = MXEXP2
+
+ 110 N = N + 1
+ LARGE = INT(MX)/(4*N + 3)
+ J = 4*N + 1
+ IF (J > LARGE) THEN
+ CALL FMMPYI_R1(M02,J)
+ J = J + 1
+ CALL FMMPYI_R1(M02,J)
+ J = J + 1
+ CALL FMMPYI_R1(M02,J)
+ ELSE IF (J*(J+1) > LARGE) THEN
+ K = J*(J+1)
+ CALL FMMPYI_R1(M02,K)
+ J = J + 2
+ CALL FMMPYI_R1(M02,J)
+ ELSE
+ K = J*(J+1)*(J+2)
+ CALL FMMPYI_R1(M02,K)
+ ENDIF
+
+ J = N + 1
+ LARGE = INT(MXBASE)/J
+ IF (J > LARGE) THEN
+ CALL FMDIVI_R1(M02,J)
+ CALL FMDIVI_R1(M02,J)
+ CALL FMDIVI_R1(M02,J)
+ ELSE IF (J*J > LARGE) THEN
+ K = J*J
+ CALL FMDIVI_R1(M02,K)
+ CALL FMDIVI_R1(M02,J)
+ ELSE
+ K = J*J*J
+ CALL FMDIVI_R1(M02,K)
+ ENDIF
+
+! Break 4/396**4 into 1/(2178*2178*1296).
+
+ J = 2178
+ LARGE = INT(MXBASE)/J
+ IF (J > LARGE) THEN
+ CALL FMDIVI_R1(M02,J)
+ CALL FMDIVI_R1(M02,J)
+ CALL FMDIVI_R1(M02,1296)
+ ELSE
+ K = J*J
+ CALL FMDIVI_R1(M02,K)
+ CALL FMDIVI_R1(M02,1296)
+ ENDIF
+
+ NDIGRD = NDIG
+ NDIG = NDSAVE
+ CALL FMADD_R2(M03,M04)
+ NDIG = NDIGRD
+ CALL FMMPY(M02,M04,M01)
+
+ NDIG = NDSAVE
+ CALL FMADD_R1(MPI,M01)
+ NDIG = MAX(2,NDSAVE - INT(MPI(1) - M01(1)))
+ IF (KFLAG /= 1) GO TO 110
+ NDIG = NDSAVE
+
+ CALL FMI2M(8,M02)
+ X = 8
+ X = SQRT(X)
+ CALL FMDPM(X,M04)
+ CALL FMDIG(NSTACK,KST)
+ DO J = 1, KST
+ NDIG = NSTACK(J)
+ CALL FMDIV(M02,M04,M01)
+ CALL FMADD_R1(M04,M01)
+ CALL FMDIVI_R1(M04,2)
+ ENDDO
+ M04(0) = NINT(NDIG*ALOGM2)
+ CALL FMI2M(9801,M03)
+ CALL FMMPY_R1(MPI,M04)
+ CALL FMDIV_R2(M03,MPI)
+
+ RETURN
+ END SUBROUTINE FMPI2
+
+ SUBROUTINE FMPRNT(MA)
+
+! Print MA in base 10 format.
+
+! FMPRNT can be called directly by the user for easy output
+! in M format. MA is converted using FMOUT and printed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ CHARACTER(20) :: FORM
+ INTEGER J,K,KSAVE,L,LAST,LB,ND,NEXP
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMPRNT'
+ KSAVE = KFLAG
+ ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
+ IF (ND < 2) ND = 2
+ NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
+ LB = MAX(JFORM2+NEXP,ND+NEXP)
+ LB = MIN(LB,LMBUFF)
+ CALL FMOUT(MA,CMBUFF,LB)
+ KFLAG = KSAVE
+ LAST = LB + 1
+ WRITE (FORM,"(' (6X,',I3,'A1) ')") KSWIDE-7
+ DO J = 1, LB
+ IF (CMBUFF(LAST-J) /= ' ' .OR. J == LB) THEN
+ L = LAST - J
+ WRITE (KW,FORM) (CMBUFF(K),K=1,L)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDDO
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMPRNT
+
+ SUBROUTINE FMPWR(MA,MB,MC)
+
+! MC = MA ** MB
+
+! If MB can be expressed exactly as a one word integer, then FMIPWR is
+! used. This is much faster when MB is small, and using FMIPWR allows
+! MA to be negative.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MXSAVE
+ INTEGER IEXTRA,INTMB,J,K,KASAVE,KFL,KOVUN,KRESLT,KWRNSV,NDSAVE
+
+! Convert MB to an integer before changing NDIG.
+
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMMI(MB,INTMB)
+ KWARN = KWRNSV
+ KFL = KFLAG
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MB(1)) > MEXPAB .OR. &
+ MA(2) == 0 .OR. MA(-1) < 0) THEN
+ CALL FMENTR('FMPWR ',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMPWR '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MB,MC,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+! If the exponent is large or the base is very large,
+! raise the precision.
+
+ IF (MA(1) /= 0) THEN
+ IEXTRA = MAX(0,INT(MB(1)))+INT(LOG(ABS(REAL(MA(1))))/ALOGMB)
+ ELSE
+ IEXTRA = MAX(0,INT(MB(1)))
+ ENDIF
+ IF (MB(1)-NDIG > LOG(ALOGMB*REAL(MXEXP2))) THEN
+ IEXTRA = 0
+ ENDIF
+
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ IF (NCALL == 1) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MC)
+ DO J = -1, NDIG+1
+ M01(J) = MC(J)
+ ENDDO
+ CALL FMEXIT(M01,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ ELSE
+ NDIG = NDG2MX
+ ENDIF
+ ENDIF
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
+ ENDIF
+
+! If the exponent is a small integer, call FMIPWR.
+
+ KWRNSV = KWARN
+ KWARN = 0
+
+ MACCA = MA(0)
+ MACCB = NINT(NDIG*ALOGM2)
+ CALL FMEQ2(MA,M06,NDSAVE,NDIG)
+ M06(0) = NINT(NDIG*ALOGM2)
+
+ IF (KFL == 0) THEN
+ CALL FMIPWR(M06,INTMB,MC)
+ ELSE IF (M06(2) == 0 .OR. M06(-1) < 0) THEN
+ CALL FMST2M('UNKNOWN',MC)
+ KFLAG = -4
+ ELSE
+ CALL FMLN(M06,M13)
+ CALL FMEQ(M13,M06)
+ MACCB = MB(0)
+ CALL FMEQ2(MB,M02,NDSAVE,NDIG)
+ M02(0) = NINT(NDIG*ALOGM2)
+ CALL FMMPY_R1(M06,M02)
+ CALL FMEXP(M06,MC)
+ ENDIF
+ KWARN = KWRNSV
+
+! Round the result and return.
+
+ MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MC(2))+1))/0.69315)
+ MC(0) = MIN(MC(0),MACCA,MACCB,MACMAX)
+ DO J = -1, NDIG+1
+ M01(J) = MC(J)
+ ENDDO
+ CALL FMEXIT(M01,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMPWR
+
+ SUBROUTINE FM_RANDOM_NUMBER(VALUE)
+
+! FM_RANDOM_NUMBER generates pseudo-random numbers uniform on (0,1).
+! VALUE is returned as the next random (double precision) number.
+! Neither zero nor one will be returned in VALUE.
+
+! This version uses the FM package to implement a multiplicative congruential
+! generator. Both the modulus and the multiplier are 49-digit primes, and
+! the period is over 1.0E+49. This generator passes the spectral test, with
+! mu(2), ..., mu(6) = 3.40, 4.35, 3.98, 3.19, 3.20.
+
+! Then the numbers are shuffled before returning them to the calling program.
+! See the discussion of Bays and Durham shuffling in Knuth, V. 2.
+
+! Both the basic multiplicative congruential generator and the shuffled
+! version have passed Marsaglia's DieHard test suite for generators.
+
+! The typical usage is to call FM_RANDOM_SEED once with PUT defined as an
+! integer array of length 7 containing seven seed values used to initialize
+! the generator. This initializes the table used by the mixed congruential
+! generator. Then each call to FM_RANDOM_NUMBER gets the next random value.
+
+! The calling program must USE FMZM to call FM_RANDOM_SEED. FM_RANDOM_NUMBER
+! can be used with a default seed without any calls to FM_RANDOM_SEED.
+
+! This example seeds the generator and then fills the array R with random
+! values between 0 and 1.
+
+! SEED = (/ 314159,265358,979323,846264,338327,950288,419716 /)
+! CALL FM_RANDOM_SEED(PUT=SEED)
+! DO J = 1, N
+! CALL FM_RANDOM_NUMBER(R(J))
+! ENDDO
+
+! In a GET= call, the seed array is returned that would later restart the
+! multiplicative congruential generator in FM_RANDOM_NUMBER at the same place
+! in the sequence, but since the table used to shuffle the output values is
+! not saved in a GET= call, the sequence may not repeat exactly.
+
+! SEED = (/ 314159,265358,979323,846264,338327,950288,419716 /)
+! CALL FM_RANDOM_SEED(PUT=SEED)
+! DO J = 1, 100
+! CALL FM_RANDOM_NUMBER(R(J))
+! ENDDO
+
+! CALL FM_RANDOM_SEED(GET=SEED)
+! DO J = 101, 200
+! CALL FM_RANDOM_NUMBER(R(J))
+! ENDDO
+
+! CALL FM_RANDOM_SEED(PUT=SEED)
+! DO J = 201, 300
+! CALL FM_RANDOM_NUMBER(R(J))
+! ENDDO
+
+! CALL FM_RANDOM_SEED(PUT=SEED)
+! DO J = 301, 400
+! CALL FM_RANDOM_NUMBER(R(J))
+! ENDDO
+
+! Here the seed is saved after 100 calls. The seed is used to re-set the
+! generator after 200 calls to the same state it had after 100 calls, but
+! R(201), ..., R(300) is not the same sequence as R(101), ..., R(200)
+! because the shuffling is different.
+
+! However, re-setting again after 300 calls will reinitialize the shuffling
+! the same way as after 200 calls, so R(301), ..., R(400) is exactly the
+! same sequence as R(201), ..., R(300).
+
+ USE FMVALS
+ USE FMZM
+
+ IMPLICIT NONE
+
+ DOUBLE PRECISION VALUE,DPM,DPX,Y
+ SAVE DPM,Y
+ INTEGER POS_OF_LAST_DIGIT,J,JBASE,LAST_DIGIT_OF_X,LAST_DIGIT_OF_M_M1
+ INTEGER :: SEED(7) = (/314159,265358,979323,846264,338327,950288,419716/)
+ SAVE JBASE,LAST_DIGIT_OF_M_M1,SEED
+ DOUBLE PRECISION :: MSAVE
+ LOGICAL IMCOMP
+
+! Keep a table of recently generated numbers and shuffle the
+! order before returning them.
+
+ INTEGER, PARAMETER :: TABLE_SIZE = 100
+ DOUBLE PRECISION, SAVE :: TABLE(0:TABLE_SIZE-1)
+
+ MSAVE = MBASE
+ MBASE = MBRAND
+
+! START_RANDOM_SEQUENCE = 0 for normal operation.
+! Get the next random value.
+! = 1 for an initializing call after
+! the user has called FM_RANDOM_SEED.
+! Use that value in MRNX to initialize.
+! = -1 for the first user call if there
+! was no initializing call to
+! FM_RANDOM_SEED. Use a default
+! seed to initialize MRNX.
+
+ IF (START_RANDOM_SEQUENCE /= 0) THEN
+ IF (START_RANDOM_SEQUENCE == -1) THEN
+ CALL FM_RANDOM_SEED(PUT=SEED)
+ ENDIF
+ START_RANDOM_SEQUENCE = 0
+ CALL IMST2M('1424133622579837639401183671018194926834820238197',MRNA)
+ CALL IMST2M('2070613773952029032014000773560846464373793273739',MRNM)
+ LAST_DIGIT_OF_M_M1 = INT(MRNM(INT(MRNM(1))+1)) - 1
+ JBASE = INT(MBASE) - 1
+ CALL IMI2M(1,MRNC)
+ CALL IMM2DP(MRNM,DPM)
+ DPM = 1.0D0/DPM
+ DO J = 0, TABLE_SIZE-1
+ 110 CALL IMMPYM(MRNA,MRNX,MRNM,M13)
+ CALL IMADD(M13,MRNC,M10)
+ CALL IMMOD(M10,MRNM,MRNX)
+ CALL IMM2DP(MRNX,DPX)
+ VALUE = DPX*DPM
+ IF (VALUE >= 1.0D0 .OR. VALUE <= 0.0D0) GO TO 110
+ TABLE(J) = VALUE
+ ENDDO
+ CALL IMMPYM(MRNA,MRNX,MRNM,M13)
+ CALL IMADD(M13,MRNC,M10)
+ CALL IMMOD(M10,MRNM,MRNX)
+ CALL IMM2DP(MRNX,DPX)
+ Y = DPX*DPM
+ ENDIF
+
+! Get the next number in the sequence.
+
+ 120 CALL IMMPYM(MRNA,MRNX,MRNM,M13)
+ POS_OF_LAST_DIGIT = INT(MRNX(1)) + 1
+ DO J = -1, POS_OF_LAST_DIGIT
+ MRNX(J) = M13(J)
+ ENDDO
+ LAST_DIGIT_OF_X = INT(MRNX(POS_OF_LAST_DIGIT))
+ IF (LAST_DIGIT_OF_X == LAST_DIGIT_OF_M_M1) THEN
+ CALL IMADD(MRNX,MRNC,M10)
+ CALL IMEQ(M10,MRNX)
+ IF (IMCOMP(MRNX,'GE',MRNM)) THEN
+ CALL IMSUB(MRNX,MRNM,M10)
+ CALL IMEQ(M10,MRNX)
+ ENDIF
+ ELSE IF (LAST_DIGIT_OF_X < JBASE) THEN
+ MRNX(POS_OF_LAST_DIGIT) = MRNX(POS_OF_LAST_DIGIT) + 1
+ ELSE
+ CALL IMADD(MRNX,MRNC,M10)
+ CALL IMEQ(M10,MRNX)
+ ENDIF
+
+! Convert to double precision.
+
+ DPX = MRNX(2)
+ DO J = 3, POS_OF_LAST_DIGIT
+ DPX = MBASE*DPX + MRNX(J)
+ ENDDO
+
+ DPX = DPX*DPM
+ IF (DPX >= 1.0D0 .OR. DPX <= 0.0D0) GO TO 120
+
+! Shuffling.
+
+ J = Y*TABLE_SIZE
+ Y = TABLE(J)
+ VALUE = Y
+ TABLE(J) = DPX
+
+ MBASE = MSAVE
+ RETURN
+ END SUBROUTINE FM_RANDOM_NUMBER
+
+ SUBROUTINE FMRDC(MA,JSIN,JCOS,JSWAP)
+
+! Reduce MA using various trigonometric identities to an equivalent
+! angle between 0 and 45 degrees. The reduction is done in radians
+! if KRAD (in module FMVALS) is 1, in degrees if KRAD is 0.
+! JSIN and JCOS are returned +1 or -1 and JSWAP is returned to indicate
+! that the sin and cos functions have been interchanged as follows:
+
+! JSWAP = 0 means SIN(MA) = JSIN*SIN(returned value of MA)
+! COS(MA) = JCOS*COS(returned value of MA)
+
+! JSWAP = 1 means SIN(MA) = JSIN*COS(returned value of MA)
+! COS(MA) = JCOS*SIN(returned value of MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER JSIN,JCOS,JSWAP
+ REAL (KIND(1.0D0)) :: MA0
+ DOUBLE PRECISION X
+ INTEGER J,KASAVE,NDSAVE,NDSV
+ LOGICAL FMCOMP
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JSIN = 1
+ JCOS = 1
+ JSWAP = 0
+ NDSAVE = NDIG
+ NDIG = NDIG + MAX(0,INT(MA(1)))
+
+! If the argument is too big, return UNKNOWN.
+
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MA)
+ RETURN
+ ENDIF
+ MA0 = MA(0) + NINT(ALOGM2*REAL(MAX(0,INT(MA(1)))))
+
+! If MA is less than 1/MBASE, no reduction is needed.
+
+ IF (MA(1) < 0) THEN
+ NDIG = NDSAVE
+ IF (MA(-1) < 0) THEN
+ MA(-1) = 1
+ JSIN = -1
+ ENDIF
+ RETURN
+ ENDIF
+
+ J = 1
+ IF (KRAD == 1) THEN
+ 110 IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDIG+2,NDG2MX)
+ KASAVE = KACCSW
+ KACCSW = 0
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'NOEQ '
+ CALL FMPI(MPISAV)
+ NCALL = NCALL - 1
+ KACCSW = KASAVE
+ NDIG = NDSV
+ ENDIF
+ CALL FMEQ2(MA,M04,NDSAVE,NDIG)
+ M04(0) = MA0
+ IF (MA(-1) < 0) JSIN = -1
+ M04(-1) = 1
+ IF (M04(1) == 0) THEN
+ CALL FMM2DP(M04,X)
+ IF (X <= 0.75) THEN
+ NDIG = NDSAVE
+ CALL FMEQ(M04,MA)
+ RETURN
+ ENDIF
+ ENDIF
+ CALL FMADD(MPISAV,MPISAV,M02)
+ IF (FMCOMP(M04,'GE',M02)) THEN
+ CALL FMDIV(M04,M02,M01)
+ CALL FMINT(M01,M08)
+ CALL FMEQ(M08,M01)
+ CALL FMMPY_R1(M01,M02)
+ CALL FMSUB_R1(M04,M01)
+ ENDIF
+ CALL FMEQ(MPISAV,M03)
+ IF (FMCOMP(M04,'GE',M03)) THEN
+ JSIN = -JSIN
+ CALL FMSUB_R2(M02,M04)
+ ENDIF
+ CALL FMDIVI_R1(M02,4)
+ IF (FMCOMP(M04,'GE',M02)) THEN
+ JCOS = -JCOS
+ CALL FMSUB_R2(M03,M04)
+ ENDIF
+ CALL FMDIVI_R1(M03,4)
+ IF (FMCOMP(M04,'GE',M03)) THEN
+ JSWAP = 1
+ CALL FMSUB_R2(M02,M04)
+ ENDIF
+
+! If the reduced argument is close to zero, then
+! cancellation has produced an inaccurate value.
+! Raise NDIG and do the reduction again.
+
+ IF (J == 1 .AND. (M04(1) < 0 .OR. M04(2) == 0)) THEN
+ J = 2
+ IF (M04(2) == 0) THEN
+ NDIG = MIN(2*NDIG,NDG2MX)
+ ELSE
+ NDIG = NDIG - INT(M04(1))
+ ENDIF
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MA)
+ RETURN
+ ENDIF
+ JSIN = 1
+ JCOS = 1
+ JSWAP = 0
+ MA0 = MA(0) + NINT(ALOGM2*REAL(-M04(1)))
+ GO TO 110
+ ENDIF
+
+ ELSE
+
+ CALL FMEQ2(MA,M04,NDSAVE,NDIG)
+ M04(0) = MA0
+ IF (MA(-1) < 0) JSIN = -1
+ M04(-1) = 1
+ IF (M04(1) == 0) THEN
+ CALL FMM2DP(M04,X)
+ IF (X <= 44.0) THEN
+ NDIG = NDSAVE
+ CALL FMEQ(M04,MA)
+ RETURN
+ ENDIF
+ ENDIF
+ CALL FMI2M(360,M02)
+ IF (FMCOMP(M04,'GE',M02)) THEN
+ CALL FMDIV(M04,M02,M01)
+ CALL FMINT(M01,M08)
+ CALL FMEQ(M08,M01)
+ CALL FMMPY_R1(M01,M02)
+ CALL FMSUB_R1(M04,M01)
+ ENDIF
+ CALL FMI2M(180,M03)
+ IF (FMCOMP(M04,'GE',M03)) THEN
+ JSIN = -JSIN
+ CALL FMSUB_R2(M02,M04)
+ ENDIF
+ CALL FMI2M(90,M02)
+ IF (FMCOMP(M04,'GE',M02)) THEN
+ JCOS = -JCOS
+ CALL FMSUB_R2(M03,M04)
+ ENDIF
+ CALL FMI2M(45,M03)
+ IF (FMCOMP(M04,'GE',M03)) THEN
+ JSWAP = 1
+ CALL FMSUB_R2(M02,M04)
+ ENDIF
+
+ ENDIF
+
+! Round the result and return.
+
+ CALL FMEQ2(M04,MA,NDIG,NDSAVE)
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE FMRDC
+
+ SUBROUTINE FMREAD(KREAD,MA)
+
+! Read MA on unit KREAD. Multi-line numbers will have '&' as the
+! last nonblank character on all but the last line. Only one
+! number is allowed on the line(s).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER KREAD
+
+ CHARACTER LINE(80)
+ INTEGER J,LB,NDSAVE
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMREAD'
+ NDSAVE = NDIG
+ NDIG = MIN(NDG2MX,MAX(NDIG+NGRD52,2))
+ LB = 0
+
+ 110 READ (KREAD,"(80A1)",ERR=120,END=120) LINE
+
+! Scan the line and look for '&'
+
+ DO J = 1, 80
+ IF (LINE(J) == '&') GO TO 110
+ IF (LINE(J) /= ' ') THEN
+ LB = LB + 1
+ IF (LB > LMBUFF) THEN
+ KFLAG = -8
+ GO TO 130
+ ENDIF
+ CMBUFF(LB) = LINE(J)
+ ENDIF
+ ENDDO
+
+ CALL FMINP(CMBUFF,M01,1,LB)
+
+ CALL FMEQ2(M01,MA,NDIG,NDSAVE)
+ NDIG = NDSAVE
+ NCALL = NCALL - 1
+ RETURN
+
+! If there is an error, return UNKNOWN.
+
+ 120 KFLAG = -4
+ 130 CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MA)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMREAD
+
+ SUBROUTINE FMRND(MW,ND,NGUARD,KSHIFT)
+
+! Round MW to ND digits (base MBASE).
+
+! MW is non-negative and has ND+NGUARD+KSHIFT digits.
+
+! NGUARD is the number of guard digits carried.
+! KSHIFT is 1 if a left shift is pending when MW(2)=0.
+
+! Round to position MW(ND+1+KSHIFT) using the guard digits
+! MW(ND+2+KSHIFT), ..., MW(ND+1+NGUARD+KSHIFT).
+
+! This routine is designed to be called only from within the FM
+! package. The user should call FMEQU to round numbers.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MW(LMWA)
+ INTEGER ND,NGUARD,KSHIFT
+
+ REAL (KIND(1.0D0)) :: M2,MFACTR,MKT
+ INTEGER J,K,KB,L
+
+ IF (KROUND == -1 .AND. NCALL <= 1) THEN
+ IF (JRSIGN == 1) RETURN
+ DO J = ND+2+KSHIFT, ND+1+NGUARD+KSHIFT
+ IF (MW(J) > 0) THEN
+ MW(ND+1+KSHIFT) = MW(ND+1+KSHIFT) + 1
+ MW(ND+2+KSHIFT) = 0
+ IF (MW(ND+1+KSHIFT) < MBASE) RETURN
+ L = ND + 2 + KSHIFT
+ GO TO 120
+ ENDIF
+ ENDDO
+ RETURN
+ ENDIF
+
+ IF (KROUND == 2 .AND. NCALL <= 1) THEN
+ IF (JRSIGN == -1) RETURN
+ DO J = ND+2+KSHIFT, ND+1+NGUARD+KSHIFT
+ IF (MW(J) > 0) THEN
+ MW(ND+1+KSHIFT) = MW(ND+1+KSHIFT) + 1
+ MW(ND+2+KSHIFT) = 0
+ IF (MW(ND+1+KSHIFT) < MBASE) RETURN
+ L = ND + 2 + KSHIFT
+ GO TO 120
+ ENDIF
+ ENDDO
+ RETURN
+ ENDIF
+
+ IF (KROUND == 0 .AND. NCALL <= 1) RETURN
+ L = ND + 2 + KSHIFT
+ IF (2*(MW(L)+1) < MBASE) RETURN
+ IF (2*MW(L) > MBASE) THEN
+ MW(L-1) = MW(L-1) + 1
+ MW(L) = 0
+ IF (MW(L-1) < MBASE) RETURN
+ GO TO 120
+ ENDIF
+
+! If the first guard digit gives a value close to 1/2 then
+! further guard digits must be examined.
+
+ M2 = 2
+ IF (INT(MBASE-AINT (MBASE/M2)*M2) == 0) THEN
+ IF (2*MW(L) < MBASE) RETURN
+ IF (2*MW(L) == MBASE) THEN
+ IF (NGUARD >= 2) THEN
+ IF (MBASE >= 1000) THEN
+ IF (MBASE < 1000000) THEN
+ MFACTR = INT(0.5D0+0.6883D0*MBASE)
+ ELSE
+ MFACTR = INT(0.5D0+0.687783D0*MBASE)
+ ENDIF
+ IF (MW(L+1) == MFACTR) RETURN
+ ENDIF
+ DO J = 2, NGUARD
+ IF (MW(L+J-1) > 0) GO TO 110
+ ENDDO
+ ENDIF
+
+! Round to even.
+
+ IF (INT(MW(L-1)-AINT (MW(L-1)/M2)*M2) == 0) RETURN
+ ENDIF
+ ELSE
+ IF (2*MW(L)+1 == MBASE) THEN
+ IF (NGUARD >= 2) THEN
+ DO J = 2, NGUARD
+ IF (2*(MW(L+J-1)+1) < MBASE) RETURN
+ IF (2*MW(L+J-1) > MBASE) GO TO 110
+ ENDDO
+ IF (NGUARD <= NDIG) RETURN
+ M2 = 2
+ IF (INT(MW(L-1)-AINT (MW(L-1)/M2)*M2) == 0) THEN
+ RETURN
+ ELSE
+ GO TO 110
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+
+ 110 MW(L-1) = MW(L-1) + 1
+ MW(L) = 0
+
+! Check whether there was a carry in the rounded digit.
+
+ 120 KB = L - 1
+ IF (KB >= 3) THEN
+ K = KB + 1
+ DO J = 3, KB
+ K = K - 1
+ IF (MW(K) < MBASE) RETURN
+ MKT = AINT (MW(K)/MBASE)
+ MW(K-1) = MW(K-1) + MKT
+ MW(K) = MW(K) - MKT*MBASE
+ ENDDO
+ ENDIF
+
+! If there is a carry in the first digit then the exponent
+! must be adjusted and the number shifted right.
+
+ IF (MW(2) >= MBASE) THEN
+ IF (KB >= 4) THEN
+ K = KB + 1
+ DO J = 4, KB
+ K = K - 1
+ MW(K) = MW(K-1)
+ ENDDO
+ ENDIF
+
+ MKT = AINT (MW(2)/MBASE)
+ IF (KB >= 3) MW(3) = MW(2) - MKT*MBASE
+ MW(2) = MKT
+ MW(1) = MW(1) + 1
+ ENDIF
+
+ RETURN
+ END SUBROUTINE FMRND
+
+ SUBROUTINE FMRPWR(MA,IVAL,JVAL,MB)
+
+! MB = MA ** (IVAL/JVAL) rational exponentiation.
+
+! This routine is faster than FMPWR when IVAL and JVAL are
+! small integers.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER IVAL,JVAL
+ DOUBLE PRECISION X,F
+ REAL (KIND(1.0D0)) :: MA1,MA2,MAS,MACCA,MACMAX,MXSAVE
+ INTEGER NSTACK(19),IJSIGN,INVERT,IVAL2,J,JVAL2,K,KASAVE,KOVUN, &
+ KRESLT,KST,KWRNSV,L,LVAL,NDSAVE
+ REAL XVAL
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMRPWR'
+ IF (NTRACE /= 0) THEN
+ CALL FMNTR(2,MA,MA,1,1)
+ CALL FMNTRI(2,IVAL,0)
+ CALL FMNTRI(2,JVAL,0)
+ ENDIF
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ XVAL = MAX(ABS(IVAL),ABS(JVAL))
+ IF (XVAL == 0.0) XVAL = 1.0
+ K = INT((5.0*REAL(DLOGTN) + 2.0*LOG(XVAL))/ALOGMB + 2.0)
+ NDIG = MAX(NDIG+K,2)
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
+ ENDIF
+ ELSE
+ XVAL = MAX(ABS(IVAL),ABS(JVAL))
+ IF (XVAL == 0.0) XVAL = 1.0
+ K = INT(LOG(XVAL)/ALOGMB + 1.0)
+ NDIG = NDIG + K
+ ENDIF
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+
+ MAS = MA(-1)
+ MA1 = MA(1)
+ MA2 = MA(2)
+ MACCA = MA(0)
+ CALL FMEQ2(MA,M02,NDSAVE,NDIG)
+ M02(0) = NINT(NDIG*ALOGM2)
+
+! Use GCD-reduced positive exponents.
+
+ IJSIGN = 1
+ IVAL2 = ABS(IVAL)
+ JVAL2 = ABS(JVAL)
+ IF (IVAL > 0 .AND. JVAL < 0) IJSIGN = -1
+ IF (IVAL < 0 .AND. JVAL > 0) IJSIGN = -1
+ IF (IVAL2 > 0 .AND. JVAL2 > 0) CALL FMGCDI(IVAL2,JVAL2)
+
+! Check for special cases.
+
+ 110 IF (MA1 == MUNKNO .OR. JVAL2 == 0 .OR. &
+ (IJSIGN <= 0 .AND. MA2 == 0)) THEN
+ CALL FMST2M('UNKNOWN',MB)
+ KFLAG = -4
+ GO TO 120
+ ENDIF
+
+ IF (IVAL2 == 0) THEN
+ CALL FMIM(1,MB)
+ GO TO 120
+ ENDIF
+
+ IF (JVAL2 == 1) THEN
+ CALL FMIPWR(M02,IJSIGN*IVAL2,MB)
+ GO TO 120
+ ENDIF
+
+ IF (MA2 == 0) THEN
+ CALL FMEQ(MA,MB)
+ GO TO 120
+ ENDIF
+
+ IF (MAS < 0) THEN
+ IF (MOD(JVAL2,2) == 0) THEN
+ JVAL2 = 0
+ GO TO 110
+ ENDIF
+ ENDIF
+
+ IF (MA1 == MEXPOV) THEN
+ IF (IVAL2 < JVAL2) THEN
+ JVAL2 = 0
+ GO TO 110
+ ENDIF
+ CALL FMIM(0,MB)
+ IF (IJSIGN == 1 .AND. MAS > 0) THEN
+ CALL FMST2M('OVERFLOW',MB)
+ KFLAG = -5
+ ELSE IF (IJSIGN == -1 .AND. MAS > 0) THEN
+ CALL FMST2M('UNDERFLOW',MB)
+ KFLAG = -6
+ ELSE IF (IJSIGN == 1 .AND. MAS < 0) THEN
+ IF (MOD(IVAL2,2) == 0) THEN
+ CALL FMST2M('OVERFLOW',MB)
+ KFLAG = -5
+ ELSE
+ CALL FMST2M('-OVERFLOW',MB)
+ KFLAG = -5
+ ENDIF
+ ELSE IF (IJSIGN == -1 .AND. MAS < 0) THEN
+ IF (MOD(IVAL2,2) == 0) THEN
+ CALL FMST2M('UNDERFLOW',MB)
+ KFLAG = -6
+ ELSE
+ CALL FMST2M('-UNDERFLOW',MB)
+ KFLAG = -6
+ ENDIF
+ ENDIF
+ GO TO 120
+ ENDIF
+
+ IF (MA1 == MEXPUN) THEN
+ IF (IVAL2 < JVAL2) THEN
+ JVAL2 = 0
+ GO TO 110
+ ENDIF
+ CALL FMIM(0,MB)
+ IF (IJSIGN == 1 .AND. MAS > 0) THEN
+ CALL FMST2M('UNDERFLOW',MB)
+ KFLAG = -6
+ ELSE IF (IJSIGN == -1 .AND. MAS > 0) THEN
+ CALL FMST2M('OVERFLOW',MB)
+ KFLAG = -5
+ ELSE IF (IJSIGN == 1 .AND. MAS < 0) THEN
+ IF (MOD(IVAL2,2) == 0) THEN
+ CALL FMST2M('UNDERFLOW',MB)
+ KFLAG = -6
+ ELSE
+ CALL FMST2M('-UNDERFLOW',MB)
+ KFLAG = -6
+ ENDIF
+ ELSE IF (IJSIGN == -1 .AND. MAS < 0) THEN
+ IF (MOD(IVAL2,2) == 0) THEN
+ CALL FMST2M('OVERFLOW',MB)
+ KFLAG = -5
+ ELSE
+ CALL FMST2M('-OVERFLOW',MB)
+ KFLAG = -5
+ ENDIF
+ ENDIF
+ GO TO 120
+ ENDIF
+
+! Invert MA if MA > 1 and IVAL or JVAL is large.
+
+ INVERT = 0
+ IF (MA(1) > 0) THEN
+ IF (IVAL > 5 .OR. JVAL > 5) THEN
+ INVERT = 1
+ CALL FMI2M(1,M01)
+ CALL FMDIV_R2(M01,M02)
+ ENDIF
+ ENDIF
+
+! Generate the first approximation to ABS(MA)**(1/JVAL2).
+
+ MA1 = M02(1)
+ M02(1) = 0
+ M02(-1) = 1
+ CALL FMM2DP(M02,X)
+ L = INT(MA1/JVAL2)
+ F = MA1/DBLE(JVAL2) - L
+ X = X**(1.0D0/JVAL2) * DBLE(MBASE)**F
+ CALL FMDPM(X,MB)
+ MB(1) = MB(1) + L
+ M02(1) = MA1
+
+! Initialize.
+
+ CALL FMDIG(NSTACK,KST)
+
+! Newton iteration.
+
+ DO J = 1, KST
+ NDIG = NSTACK(J)
+ IF (J < KST) NDIG = NDIG + 1
+ LVAL = JVAL2 - 1
+ CALL FMIPWR(MB,LVAL,M03)
+ CALL FMDIV_R2(M02,M03)
+ CALL FMMPYI_R1(MB,LVAL)
+ CALL FMADD_R1(MB,M03)
+ CALL FMDIVI_R1(MB,JVAL2)
+ ENDDO
+
+ IF (MB(1) /= MUNKNO .AND. MB(2) /= 0 .AND. MAS < 0) MB(-1) = -MB(-1)
+ CALL FMIPWR(MB,IJSIGN*IVAL2,M03)
+ CALL FMEQ(M03,MB)
+ IF (INVERT == 1) THEN
+ CALL FMI2M(1,M01)
+ CALL FMDIV_R2(M01,MB)
+ ENDIF
+
+! Round the result and return.
+
+ 120 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MACCA,MACMAX)
+ KWRNSV = KWARN
+ IF (MA1 == MUNKNO) KWARN = 0
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ KWARN = KWRNSV
+ RETURN
+ END SUBROUTINE FMRPWR
+
+ SUBROUTINE FMRSLT(MA,MB,MC,KRESLT)
+
+! Handle results that are special cases, such as overflow,
+! underflow, and unknown.
+
+! MA and MB are the input arguments to an FM subroutine.
+
+! MC is the result that is returned.
+
+! KRESLT is the result code from FMARGS. Result codes handled here:
+
+! 0 - Perform the normal operation
+! 1 - The result is the first input argument
+! 2 - The result is the second input argument
+! 3 - The result is -OVERFLOW
+! 4 - The result is +OVERFLOW
+! 5 - The result is -UNDERFLOW
+! 6 - The result is +UNDERFLOW
+! 7 - The result is -1.0
+! 8 - The result is +1.0
+! 11 - The result is 0.0
+! 12 - The result is UNKNOWN
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+ INTEGER KRESLT
+
+ REAL (KIND(1.0D0)) :: MACCAB,MACCSV
+ INTEGER KFSAVE
+
+ KFSAVE = KFLAG
+ MACCAB = MIN(MA(0),MB(0))
+ IF (KRESLT == 1) THEN
+ MACCSV = MA(0)
+ CALL FMEQ(MA,MC)
+ MC(0) = MACCAB
+ IF (NAMEST(NCALL) == 'FMADD ' .OR. &
+ NAMEST(NCALL) == 'FMSUB ') THEN
+ KFLAG = 1
+ MC(0) = MACCSV
+ ELSE
+ KFLAG = KFSAVE
+ ENDIF
+ RETURN
+ ENDIF
+
+ IF (KRESLT == 2) THEN
+ MACCSV = MB(0)
+ CALL FMEQ(MB,MC)
+ MC(0) = MACCAB
+ IF (NAMEST(NCALL) == 'FMADD ') THEN
+ KFLAG = 1
+ MC(0) = MACCSV
+ ELSE
+ KFLAG = KFSAVE
+ ENDIF
+ IF (NAMEST(NCALL) == 'FMSUB ') THEN
+ IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
+ KFLAG = KFSAVE
+ MC(0) = MACCSV
+ ENDIF
+ RETURN
+ ENDIF
+
+ IF (KRESLT == 3 .OR. KRESLT == 4) THEN
+ CALL FMIM(0,MC)
+ MC(1) = MEXPOV
+ MC(2) = 1
+ MC(0) = NINT(NDIG*ALOGM2)
+ IF (KRESLT == 3) MC(-1) = -1
+ MC(0) = MACCAB
+ KFLAG = KFSAVE
+ RETURN
+ ENDIF
+
+ IF (KRESLT == 5 .OR. KRESLT == 6) THEN
+ CALL FMIM(0,MC)
+ MC(1) = MEXPUN
+ MC(2) = 1
+ MC(0) = NINT(NDIG*ALOGM2)
+ IF (KRESLT == 5) MC(-1) = -1
+ MC(0) = MACCAB
+ KFLAG = KFSAVE
+ RETURN
+ ENDIF
+
+ IF (KRESLT == 7) THEN
+ CALL FMIM(-1,MC)
+ MC(0) = MACCAB
+ KFLAG = KFSAVE
+ RETURN
+ ENDIF
+
+ IF (KRESLT == 8) THEN
+ CALL FMIM(1,MC)
+ MC(0) = MACCAB
+ KFLAG = KFSAVE
+ RETURN
+ ENDIF
+
+ IF (KRESLT == 11) THEN
+ CALL FMIM(0,MC)
+ MC(0) = MACCAB
+ KFLAG = KFSAVE
+ RETURN
+ ENDIF
+
+ IF (KRESLT == 12 .OR. KRESLT < 0 .OR. KRESLT > 15) THEN
+ CALL FMIM(0,MC)
+ MC(1) = MUNKNO
+ MC(2) = 1
+ MC(0) = NINT(NDIG*ALOGM2)
+ MC(0) = MACCAB
+ KFLAG = KFSAVE
+ RETURN
+ ENDIF
+
+ RETURN
+ END SUBROUTINE FMRSLT
+
+ SUBROUTINE FMSETVAR(STRING)
+
+! Change the value of one of the internal FM variables.
+! STRING must have the format ' variablename = value ', with no
+! embedded blanks in variablename.
+
+ USE FMVALS
+ IMPLICIT NONE
+ CHARACTER(*) :: STRING
+ CHARACTER(6) :: VARNAME
+ INTEGER IVAL,J,KPTEQ,KPT1,KPT2
+ DOUBLE PRECISION DVAL
+ REAL (KIND(1.0D0)) :: MVAL
+
+ CHARACTER(52) :: LETTERS = &
+ 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+
+! Find the equal sign.
+
+ KPTEQ = INDEX(STRING,'=')
+ IF (KPTEQ <= 0) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' Cannot find the equal sign in FMSETVAR.'
+ WRITE (KW,*) ' Input string: ',STRING
+ RETURN
+ ENDIF
+
+! Find the variable name.
+
+ KPT1 = 0
+ KPT2 = 0
+ DO J = 1, KPTEQ-1
+ IF (KPT1 == 0 .AND. STRING(J:J) /= ' ') KPT1 = J
+ ENDDO
+ DO J = KPTEQ-1, 1, -1
+ IF (KPT2 == 0 .AND. STRING(J:J) /= ' ') KPT2 = J
+ ENDDO
+ IF (KPT1 == 0) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' Cannot find the variable name in FMSETVAR.'
+ WRITE (KW,*) ' Input string: ',STRING
+ RETURN
+ ENDIF
+ VARNAME = ' '
+ DO J = KPT1, KPT2
+ IVAL = INDEX(LETTERS,STRING(J:J))
+ IF (IVAL > 26 .AND. IVAL <= 52) THEN
+ VARNAME(J-KPT1+1:J-KPT1+1) = LETTERS(IVAL-26:IVAL-26)
+ ELSE
+ VARNAME(J-KPT1+1:J-KPT1+1) = STRING(J:J)
+ ENDIF
+ ENDDO
+
+! CMCHAR is a special case, since the value is a character.
+
+ IF (VARNAME == 'CMCHAR') THEN
+ KPT1 = 0
+ KPT2 = 0
+ DO J = KPTEQ+1, LEN(STRING)
+ IF (KPT1 == 0 .AND. STRING(J:J) /= ' ') KPT1 = J
+ ENDDO
+ DO J = LEN(STRING), KPTEQ+1, -1
+ IF (KPT2 == 0 .AND. STRING(J:J) /= ' ') KPT2 = J
+ ENDDO
+ IF (KPT1 == KPT2 .AND. INDEX(LETTERS,STRING(KPT1:KPT2)) > 0) THEN
+ CMCHAR = STRING(KPT1:KPT2)
+ ELSE
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' Only a single letter is allowed after the', &
+ ' equal sign in FMSETVAR.'
+ WRITE (KW,*) ' Input string: ',STRING
+ RETURN
+ ENDIF
+ ENDIF
+
+! Convert the value after the equal sign.
+
+ IF (KPTEQ+1 <= LEN(STRING)) THEN
+ IF (INDEX(STRING(KPTEQ+1:LEN(STRING)),'=') /= 0) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' Only a single equal sign is allowed in FMSETVAR.'
+ WRITE (KW,*) ' Input string: ',STRING
+ RETURN
+ ENDIF
+ CALL FMST2D(STRING(KPTEQ+1:LEN(STRING)),DVAL)
+ IF (KFLAG /= 0) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' Invalid value after the equal sign in', &
+ ' FMSETVAR.'
+ WRITE (KW,*) ' Input string: ',STRING
+ RETURN
+ ENDIF
+ ELSE
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' Cannot find a value after the equal sign in', &
+ ' FMSETVAR.'
+ WRITE (KW,*) ' Input string: ',STRING
+ RETURN
+ ENDIF
+
+! Check the list of variable names.
+
+ IF (VARNAME == 'JFORM1') THEN
+ JFORM1 = NINT(DVAL)
+ IF (JFORM1 < 0 .OR. JFORM1 > 2) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',JFORM1, &
+ ' is an invalid value for JFORM1'
+ JFORM1 = 1
+ WRITE (KW,*) ' Valid values are 0,1,2.', &
+ ' JFORM1 was set to ',JFORM1
+ ENDIF
+ ELSE IF (VARNAME == 'JFORM2') THEN
+ JFORM2 = NINT(DVAL)
+ IF (JFORM2 < 0) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',JFORM2, &
+ ' is an invalid value for JFORM2'
+ JFORM2 = 1
+ WRITE (KW,*) ' It should be nonegative.', &
+ ' JFORM2 was set to ',JFORM2
+ ENDIF
+ ELSE IF (VARNAME == 'JFORMZ') THEN
+ JFORMZ = NINT(DVAL)
+ IF (JFORMZ < 1 .OR. JFORMZ > 3) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',JFORMZ, &
+ ' is an invalid value for JFORMZ'
+ JFORMZ = 1
+ WRITE (KW,*) ' Valid values are 1,2,3.', &
+ ' JFORMZ was set to ',JFORMZ
+ ENDIF
+ ELSE IF (VARNAME == 'JPRNTZ') THEN
+ JPRNTZ = NINT(DVAL)
+ IF (JPRNTZ < 1 .OR. JPRNTZ > 2) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',JPRNTZ, &
+ ' is an invalid value for JPRNTZ'
+ JPRNTZ = 1
+ WRITE (KW,*) ' Valid values are 1,2.', &
+ ' JPRNTZ was set to ',JPRNTZ
+ ENDIF
+ ELSE IF (VARNAME == 'KACCSW') THEN
+ KACCSW = NINT(DVAL)
+ IF (KACCSW < 0 .OR. KACCSW > 1) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',KACCSW, &
+ ' is an invalid value for KACCSW'
+ KACCSW = 0
+ WRITE (KW,*) ' Valid values are 0,1.', &
+ ' KACCSW was set to ',KACCSW
+ ENDIF
+ ELSE IF (VARNAME == 'KDEBUG') THEN
+ KDEBUG = NINT(DVAL)
+ IF (KDEBUG < 0 .OR. KDEBUG > 1) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',KDEBUG, &
+ ' is an invalid value for KDEBUG'
+ KDEBUG = 1
+ WRITE (KW,*) ' Valid values are 0,1.', &
+ ' KDEBUG was set to ',KDEBUG
+ ENDIF
+ ELSE IF (VARNAME == 'KESWCH') THEN
+ KESWCH = NINT(DVAL)
+ IF (KESWCH < 0 .OR. KESWCH > 1) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',KESWCH, &
+ ' is an invalid value for KESWCH'
+ KESWCH = 1
+ WRITE (KW,*) ' Valid values are 0,1.', &
+ ' KESWCH was set to ',KESWCH
+ ENDIF
+ ELSE IF (VARNAME == 'KRAD ') THEN
+ KRAD = NINT(DVAL)
+ IF (KRAD < 0 .OR. KRAD > 1) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',KRAD, &
+ ' is an invalid value for KRAD'
+ KRAD = 1
+ WRITE (KW,*) ' Valid values are 0,1.', &
+ ' KRAD was set to ',KRAD
+ ENDIF
+ ELSE IF (VARNAME == 'KROUND') THEN
+ KROUND = NINT(DVAL)
+ IF (KROUND < -1 .OR. KROUND > 2) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',KROUND, &
+ ' is an invalid value for KROUND'
+ KROUND = 1
+ WRITE (KW,*) ' Valid values are -1,0,1,2.', &
+ ' KROUND was set to ',KROUND
+ ENDIF
+ ELSE IF (VARNAME == 'KRPERF') THEN
+ KRPERF = NINT(DVAL)
+ IF (KRPERF < 0 .OR. KRPERF > 1) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',KRPERF, &
+ ' is an invalid value for KRPERF'
+ KRPERF = 0
+ WRITE (KW,*) ' Valid values are 0,1.', &
+ ' KRPERF was set to ',KRPERF
+ ENDIF
+ ELSE IF (VARNAME == 'KSWIDE') THEN
+ KSWIDE = NINT(DVAL)
+ IF (KSWIDE < 10) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',KSWIDE, &
+ ' is an invalid value for KSWIDE'
+ KSWIDE = 80
+ WRITE (KW,*) ' It should be 10 or more.', &
+ ' KSWIDE was set to ',KSWIDE
+ ENDIF
+ ELSE IF (VARNAME == 'KW ') THEN
+ KW = NINT(DVAL)
+ ELSE IF (VARNAME == 'KWARN ') THEN
+ KWARN = NINT(DVAL)
+ IF (KWARN < 0 .OR. KWARN > 2) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',KWARN, &
+ ' is an invalid value for KWARN'
+ KWARN = 1
+ WRITE (KW,*) ' Valid values are 0,1,2.', &
+ ' KWARN was set to ',KWARN
+ ENDIF
+ ELSE IF (VARNAME == 'LVLTRC') THEN
+ LVLTRC = NINT(DVAL)
+ IF (LVLTRC < 0) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',LVLTRC, &
+ ' is an invalid value for LVLTRC'
+ LVLTRC = 1
+ WRITE (KW,*) ' It should be nonegative.', &
+ ' LVLTRC was set to ',LVLTRC
+ ENDIF
+ ELSE IF (VARNAME == 'NDIG ') THEN
+ IVAL = NDIG
+ NDIG = NINT(DVAL)
+ IF (NDIG < 2) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',NDIG, &
+ ' is an invalid value for NDIG'
+ NDIG = IVAL
+ WRITE (KW,*) ' It should be > 1.', &
+ ' NDIG was not changed from ',NDIG
+ ENDIF
+ IF (NDIG > NDIGMX) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',NDIG, &
+ ' is an invalid value for NDIG'
+ NDIG = NDIGMX
+ WRITE (KW,*) ' It should be <=',NDIGMX, &
+ '. NDIG was set to ',NDIG
+ ENDIF
+ ELSE IF (VARNAME == 'NTRACE') THEN
+ NTRACE = NINT(DVAL)
+ IF (NTRACE < -2 .OR. NTRACE > 2) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',NTRACE, &
+ ' is an invalid value for NTRACE'
+ NTRACE = 0
+ WRITE (KW,*) ' Valid values are -2,-1,0,1,2.', &
+ ' NTRACE was set to ',NTRACE
+ ENDIF
+ ELSE IF (VARNAME == 'MBASE ') THEN
+ MVAL = MBASE
+ MBASE = ANINT (DVAL)
+ IF (MBASE < 2) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',MBASE, &
+ ' is an invalid value for MBASE'
+ MBASE = MVAL
+ WRITE (KW,*) ' It should be > 1.', &
+ ' MBASE was not changed from ',MBASE
+ ENDIF
+ ELSE IF (VARNAME == 'MXEXP ') THEN
+ MXEXP = AINT (DVAL)
+ IF (MXEXP < 10 .OR. MXEXP > MXEXP2/2.01D0) THEN
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' FMSETVAR: Input string: ',STRING
+ WRITE (KW,*) ' ',MXEXP, &
+ ' is an invalid value for MXEXP'
+ MXEXP = INT(MXEXP2/2.01D0)
+ WRITE (KW,*) ' Valid values are 10 to ', &
+ INT(MXEXP2/2.01D0),' MXEXP was set to ',MXEXP
+ ENDIF
+ ELSE
+ WRITE (KW,*) ' Variable name not recognized in FMSETVAR.'
+ WRITE (KW,*) ' Input string: ',STRING
+ RETURN
+ ENDIF
+
+ CALL FMCONS
+ RETURN
+ END SUBROUTINE FMSETVAR
+
+ SUBROUTINE FMSIGN(MA,MB,MC)
+
+! MC = SIGN(MA,MB)
+
+! MC is set to ABS(MA) if MB is positive or zero,
+! or -ABS(MA) if MB is negative.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ INTEGER KWRNSV
+
+ KFLAG = 0
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMSIGN'
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)
+
+ KWRNSV = KWARN
+ KWARN = 0
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
+ CALL FMST2M('UNKNOWN',MC)
+ KFLAG = -4
+ ELSE IF (MB(-1) >= 0) THEN
+ CALL FMEQ(MA,MC)
+ MC(-1) = 1
+ ELSE
+ CALL FMEQ(MA,MC)
+ IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1
+ ENDIF
+
+ KWARN = KWRNSV
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMSIGN
+
+ SUBROUTINE FMSIN(MA,MB)
+
+! MB = SIN(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
+ INTEGER J,JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NDSV
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN
+ CALL FMENTR('FMSIN ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMSIN '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ MACCA = MA(0)
+ MAS = MA(-1)
+ CALL FMEQ2(MA,MB,NDSAVE,NDIG)
+ MB(0) = NINT(NDIG*ALOGM2)
+ MB(-1) = 1
+ CALL FMEQ(MB,MWE)
+ KWRNSV = KWARN
+ KWARN = 0
+
+! Reduce the argument, convert to radians if the input is
+! in degrees, and evaluate the function.
+
+ CALL FMRDC(MB,JSIN,JCOS,JSWAP)
+ KWARN = KWRNSV
+ IF (MB(1) == MUNKNO) THEN
+ IF (KRAD /= 1 .OR. JSWAP == 0) THEN
+ CALL FMEQ(MWE,MB)
+ CALL FMRDC(MB,JSIN,JCOS,JSWAP)
+ GO TO 110
+ ENDIF
+ IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDIG+2,NDG2MX)
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'NOEQ '
+ CALL FMPI(MPISAV)
+ NCALL = NCALL - 1
+ NDIG = NDSV
+ ENDIF
+ CALL FMDIV(MWE,MPISAV,M04)
+ CALL FMMPYI_R1(M04,2)
+ CALL FMNINT(M04,M03)
+ CALL FMMPY(M03,MPISAV,M02)
+ CALL FMDIVI_R1(M02,2)
+ CALL FMSUB_R2(MWE,M02)
+ IF (M02(2) == 0) CALL FMULP(MWE,M02)
+ CALL FMI2M(1,M04)
+ CALL FMSQR_R1(M02)
+ CALL FMDIVI_R1(M02,2)
+ CALL FMSUB_R2(M04,M02)
+ CALL FMSUB_R1(M02,M04)
+ IF (M02(2) == 0) THEN
+ CALL FMI2M(JSIN,MB)
+ ELSE
+ CALL FMEQ(MWE,MB)
+ CALL FMRDC(MB,JSIN,JCOS,JSWAP)
+ ENDIF
+ GO TO 110
+ ENDIF
+ IF (KRAD == 0) THEN
+ IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDIG+2,NDG2MX)
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'NOEQ '
+ CALL FMPI(MPISAV)
+ NCALL = NCALL - 1
+ NDIG = NDSV
+ ENDIF
+ CALL FMMPY_R1(MB,MPISAV)
+ CALL FMDIVI_R1(MB,180)
+ ENDIF
+ IF (MB(1) /= MUNKNO) THEN
+ IF (JSWAP == 0) THEN
+ IF (MB(1) < 0 .OR. NDIG <= 50) THEN
+ CALL FMSIN2(MB,M09)
+ CALL FMEQ(M09,MB)
+ ELSE
+ CALL FMCOS2(MB,M09)
+ CALL FMEQ(M09,MB)
+ CALL FMI2M(1,M03)
+ CALL FMSQR_R1(MB)
+ CALL FMSUB_R2(M03,MB)
+ CALL FMSQRT_R1(MB)
+ ENDIF
+ ELSE
+ CALL FMCOS2(MB,M09)
+ CALL FMEQ(M09,MB)
+ ENDIF
+ ENDIF
+
+! Append the sign, round, and return.
+
+ IF (JSIN == -1 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
+ 110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ IF (MAS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMSIN
+
+ SUBROUTINE FMSIN2(MA,MB)
+
+! Internal subroutine for MB = SIN(MA) where 0 <= MA <= 1.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent
+! sums. Increasing this value will begin to improve the
+! speed of SIN when the base is large and precision exceeds
+! about 1,500 decimal digits.
+
+ REAL (KIND(1.0D0)) :: MAXVAL
+ INTEGER J,J2,K,K2,KPT,KTHREE,KWRNSV,L,L2,LARGE,N2,NBOT,NDSAV1, &
+ NDSAVE,NTERM
+ REAL ALOG3,ALOGT,B,T,TJ
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (MA(2) == 0) THEN
+ CALL FMEQ(MA,MB)
+ RETURN
+ ENDIF
+ NDSAVE = NDIG
+ KWRNSV = KWARN
+ KWARN = 0
+
+! Use the direct series
+! SIN(X) = X - X**3/3! + X**5/5! - ...
+
+! The argument will be divided by 3**K2 before the series
+! is summed. The series will be added as J2 concurrent
+! series. The approximately optimal values of K2 and J2
+! are now computed to try to minimize the time required.
+! N2/2 is the approximate number of terms of the series
+! that will be needed, and L2 guard digits will be carried.
+
+ B = REAL(MBASE)
+ K = NGRD52
+ T = MAX(NDIG-K,2)
+ ALOG3 = LOG(3.0)
+ ALOGT = LOG(T)
+ TJ = 0.05*ALOGMB*T**0.3333 + 1.85
+ J2 = INT(TJ)
+ J2 = MAX(1,MIN(J2,LJSUMS/NDG2MX))
+ K2 = INT(0.1*SQRT(T*ALOGMB/TJ) - 0.05*ALOGT + 2.5)
+
+ L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B + &
+ REAL(MA(3))/(B*B)))/ALOG3 - 0.3)
+ K2 = K2 - L
+ IF (L < 0) L = 0
+ IF (K2 < 0) THEN
+ K2 = 0
+ J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG3)) + .33)
+ ENDIF
+ IF (J2 <= 1) J2 = 1
+
+ N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG3))
+ L2 = INT(LOG(REAL(N2)+3.0**K2)/ALOGMB)
+ NDIG = NDIG + L2
+ IF (NDIG > NDG2MX) THEN
+ IF (NCALL == 1) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MB)
+ KWARN = KWRNSV
+ RETURN
+ ELSE
+ NDIG = NDG2MX
+ ENDIF
+ ENDIF
+ NDSAV1 = NDIG
+
+! Divide the argument by 3**K2.
+
+ CALL FMEQ2(MA,M02,NDSAVE,NDIG)
+ KTHREE = 1
+ MAXVAL = MXBASE/3
+ IF (K2 > 0) THEN
+ DO J = 1, K2
+ KTHREE = 3*KTHREE
+ IF (KTHREE > MAXVAL) THEN
+ CALL FMDIVI_R1(M02,KTHREE)
+ KTHREE = 1
+ ENDIF
+ ENDDO
+ IF (KTHREE > 1) CALL FMDIVI_R1(M02,KTHREE)
+ ENDIF
+
+! Split into J2 concurrent sums and reduce NDIG while
+! computing each term in the sum as the terms get smaller.
+
+ CALL FMEQ(M02,M03)
+ NTERM = 1
+ DO J = 1, J2
+ NBOT = NTERM*(NTERM-1)
+ IF (NBOT > 1) CALL FMDIVI_R1(M03,NBOT)
+ NTERM = NTERM + 2
+ KPT = (J-1)*(NDIG+3)
+ CALL FMEQ(M03,MJSUMS(KPT-1))
+ IF (M03(1) /= MUNKNO .AND. M03(2) /= 0) M03(-1) = -M03(-1)
+ ENDDO
+ CALL FMSQR_R1(M02)
+ IF (M02(1) < -NDIG) GO TO 120
+ CALL FMIPWR(M02,J2,MB)
+
+ 110 CALL FMMPY_R1(M03,MB)
+ LARGE = INT(INTMAX/NTERM)
+ DO J = 1, J2
+ NBOT = NTERM*(NTERM-1)
+ IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN
+ CALL FMDIVI_R1(M03,NTERM)
+ NBOT = NTERM - 1
+ CALL FMDIVI_R1(M03,NBOT)
+ ELSE
+ CALL FMDIVI_R1(M03,NBOT)
+ ENDIF
+ KPT = (J-1)*(NDSAV1+3)
+ NDIG = NDSAV1
+ CALL FMADD_R1(MJSUMS(KPT-1),M03)
+ IF (KFLAG /= 0) GO TO 120
+ NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1))
+ IF (NDIG < 2) NDIG = 2
+ IF (M03(1) /= MUNKNO .AND. M03(2) /= 0) M03(-1) = -M03(-1)
+ NTERM = NTERM + 2
+ ENDDO
+ GO TO 110
+
+! Next put the J2 separate sums back together.
+
+ 120 KFLAG = 0
+ KPT = (J2-1)*(NDIG+3)
+ CALL FMEQ(MJSUMS(KPT-1),MB)
+ IF (J2 >= 2) THEN
+ DO J = 2, J2
+ CALL FMMPY_R2(M02,MB)
+ KPT = (J2-J)*(NDIG+3)
+ CALL FMADD_R1(MB,MJSUMS(KPT-1))
+ ENDDO
+ ENDIF
+
+! Reverse the effect of reducing the argument to
+! compute SIN(MA).
+
+ NDIG = NDSAV1
+ IF (K2 > 0) THEN
+ CALL FMI2M(3,M02)
+ DO J = 1, K2
+ CALL FMSQR(MB,M03)
+ CALL FMMPYI_R1(M03,-4)
+ CALL FMADD_R2(M02,M03)
+ CALL FMMPY_R2(M03,MB)
+ ENDDO
+ ENDIF
+
+ CALL FMEQ2_R1(MB,NDSAV1,NDSAVE)
+ NDIG = NDSAVE
+ KWARN = KWRNSV
+
+ RETURN
+ END SUBROUTINE FMSIN2
+
+ SUBROUTINE FMSINH(MA,MB)
+
+! MB = SINH(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
+ INTEGER J,K,KASAVE,KOVUN,KRESLT,NDSAVE,NMETHD
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB) THEN
+ CALL FMENTR('FMSINH',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMSINH'
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ MACCA = MA(0)
+ MAS = MA(-1)
+ CALL FMEQ2(MA,MB,NDSAVE,NDIG)
+ IF (MA(2) == 0) THEN
+ GO TO 120
+ ENDIF
+ MB(0) = NINT(NDIG*ALOGM2)
+ MB(-1) = 1
+
+! Use a series for small arguments, FMEXP for large ones.
+
+ IF (MB(1) == MUNKNO) GO TO 120
+ IF (MBASE > 99) THEN
+ IF (MB(1) <= 0) THEN
+ NMETHD = 1
+ ELSE IF (MB(1) >= 2) THEN
+ NMETHD = 2
+ ELSE IF (ABS(MB(2)) < 10) THEN
+ NMETHD = 1
+ ELSE
+ NMETHD = 2
+ ENDIF
+ ELSE
+ IF (MB(1) <= 0) THEN
+ NMETHD = 1
+ ELSE
+ NMETHD = 2
+ ENDIF
+ ENDIF
+
+ IF (NMETHD == 2) GO TO 110
+ IF (MB(1) < 0 .OR. NDIG <= 50) THEN
+ CALL FMSNH2(MB,M09)
+ CALL FMEQ(M09,MB)
+ ELSE
+ CALL FMCSH2(MB,M09)
+ CALL FMEQ(M09,MB)
+ CALL FMI2M(1,M03)
+ CALL FMSQR_R1(MB)
+ CALL FMSUB_R1(MB,M03)
+ CALL FMSQRT_R1(MB)
+ ENDIF
+ GO TO 120
+
+ 110 CALL FMEXP(MB,M12)
+ CALL FMEQ(M12,MB)
+ IF (MB(1) == MEXPOV) THEN
+ GO TO 120
+ ELSE IF (MB(1) == MEXPUN) THEN
+ MB(1) = MEXPOV
+ GO TO 120
+ ENDIF
+ IF (INT(MB(1)) <= (NDIG+1)/2) THEN
+ CALL FMI2M(1,M01)
+ CALL FMDIV_R1(M01,MB)
+ CALL FMSUB_R1(MB,M01)
+ ENDIF
+ CALL FMDIVI_R1(MB,2)
+
+! Round and return.
+
+ 120 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ IF (MAS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMSINH
+
+ SUBROUTINE FMSNH2(MA,MB)
+
+! Internal subroutine for MB = SINH(MA).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+! LJSUMS = 8*(LUNPCK+1) allows for up to eight concurrent
+! sums. Increasing this value will begin to improve the
+! speed of SINH when the base is large and precision exceeds
+! about 1,500 decimal digits.
+
+ REAL (KIND(1.0D0)) :: MAXVAL
+ INTEGER J,J2,K,K2,KPT,KTHREE,KWRNSV,L,L2,LARGE,N2,NBOT,NDSAV1, &
+ NDSAVE,NTERM
+ REAL ALOG3,ALOGT,B,T,TJ
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (MA(2) == 0) THEN
+ CALL FMEQ(MA,MB)
+ RETURN
+ ENDIF
+ NDSAVE = NDIG
+ KWRNSV = KWARN
+ KWARN = 0
+
+! Use the direct series
+! SINH(X) = X + X**3/3! + X**5/5! - ...
+
+! The argument will be divided by 3**K2 before the series
+! is summed. The series will be added as J2 concurrent
+! series. The approximately optimal values of K2 and J2
+! are now computed to try to minimize the time required.
+! N2/2 is the approximate number of terms of the series
+! that will be needed, and L2 guard digits will be carried.
+
+ B = REAL(MBASE)
+ K = NGRD52
+ T = MAX(NDIG-K,2)
+ ALOG3 = LOG(3.0)
+ ALOGT = LOG(T)
+ TJ = 0.05*ALOGMB*T**0.3333 + 1.85
+ J2 = INT(TJ)
+ J2 = MAX(1,MIN(J2,LJSUMS/NDG2MX))
+ K2 = INT(0.1*SQRT(T*ALOGMB/TJ) - 0.05*ALOGT + 2.5)
+
+ L = INT(-(REAL(MA(1))*ALOGMB+LOG(REAL(MA(2))/B + &
+ REAL(MA(3))/(B*B)))/ALOG3 - 0.3)
+ K2 = K2 - L
+ IF (L < 0) L = 0
+ IF (K2 < 0) THEN
+ K2 = 0
+ J2 = INT(.43*SQRT(T*ALOGMB/(ALOGT+REAL(L)*ALOG3)) + .33)
+ ENDIF
+ IF (J2 <= 1) J2 = 1
+
+ N2 = INT(T*ALOGMB/(ALOGT+REAL(L)*ALOG3))
+ L2 = INT(LOG(REAL(N2)+3.0**K2)/ALOGMB)
+ NDIG = NDIG + L2
+ IF (NDIG > NDG2MX) THEN
+ IF (NCALL == 1) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MB)
+ KWARN = KWRNSV
+ RETURN
+ ELSE
+ NDIG = NDG2MX
+ ENDIF
+ ENDIF
+ NDSAV1 = NDIG
+
+! Divide the argument by 3**K2.
+
+ CALL FMEQ2(MA,M02,NDSAVE,NDIG)
+ KTHREE = 1
+ MAXVAL = MXBASE/3
+ IF (K2 > 0) THEN
+ DO J = 1, K2
+ KTHREE = 3*KTHREE
+ IF (KTHREE > MAXVAL) THEN
+ CALL FMDIVI_R1(M02,KTHREE)
+ KTHREE = 1
+ ENDIF
+ ENDDO
+ IF (KTHREE > 1) CALL FMDIVI_R1(M02,KTHREE)
+ ENDIF
+
+! Split into J2 concurrent sums and reduce NDIG while
+! computing each term in the sum as the terms get smaller.
+
+ CALL FMEQ(M02,M03)
+ NTERM = 1
+ DO J = 1, J2
+ NBOT = NTERM*(NTERM-1)
+ IF (NBOT > 1) CALL FMDIVI_R1(M03,NBOT)
+ NTERM = NTERM + 2
+ KPT = (J-1)*(NDIG+3)
+ CALL FMEQ(M03,MJSUMS(KPT-1))
+ ENDDO
+ CALL FMSQR_R1(M02)
+ IF (M02(1) < -NDIG) GO TO 120
+ CALL FMIPWR(M02,J2,MB)
+
+ 110 CALL FMMPY_R1(M03,MB)
+ LARGE = INT(INTMAX/NTERM)
+ DO J = 1, J2
+ NBOT = NTERM*(NTERM-1)
+ IF (NTERM > LARGE .OR. NBOT > MXBASE) THEN
+ CALL FMDIVI_R1(M03,NTERM)
+ NBOT = NTERM - 1
+ CALL FMDIVI_R1(M03,NBOT)
+ ELSE
+ CALL FMDIVI_R1(M03,NBOT)
+ ENDIF
+ KPT = (J-1)*(NDSAV1+3)
+ NDIG = NDSAV1
+ CALL FMADD_R1(MJSUMS(KPT-1),M03)
+ IF (KFLAG /= 0) GO TO 120
+ NDIG = NDSAV1 - INT(MJSUMS(KPT+1)-M03(1))
+ IF (NDIG < 2) NDIG = 2
+ NTERM = NTERM + 2
+ ENDDO
+ GO TO 110
+
+! Next put the J2 separate sums back together.
+
+ 120 KFLAG = 0
+ KPT = (J2-1)*(NDIG+3)
+ CALL FMEQ(MJSUMS(KPT-1),MB)
+ IF (J2 >= 2) THEN
+ DO J = 2, J2
+ CALL FMMPY_R2(M02,MB)
+ KPT = (J2-J)*(NDIG+3)
+ CALL FMADD_R1(MB,MJSUMS(KPT-1))
+ ENDDO
+ ENDIF
+
+! Reverse the effect of reducing the argument to
+! compute SINH(MA).
+
+ NDIG = NDSAV1
+ IF (K2 > 0) THEN
+ CALL FMI2M(3,M02)
+ DO J = 1, K2
+ CALL FMSQR(MB,M03)
+ CALL FMMPYI_R1(M03,4)
+ CALL FMADD_R2(M02,M03)
+ CALL FMMPY_R2(M03,MB)
+ ENDDO
+ ENDIF
+
+ CALL FMEQ2_R1(MB,NDSAV1,NDSAVE)
+ NDIG = NDSAVE
+ KWARN = KWRNSV
+
+ RETURN
+ END SUBROUTINE FMSNH2
+
+ SUBROUTINE FMSP2M(X,MA)
+
+! MA = X
+
+! Convert a single precision number to FM format.
+
+! This version tries to convert the single precision machine
+! number to FM with accuracy of nearly full FM precision.
+! If conversion to FM with approximately double precision accuracy
+! is good enough, it is faster to CALL FMDPM(DBLE(X),MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL X
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ DOUBLE PRECISION XDP,Y,YT
+ INTEGER K
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMSP2M'
+ XDP = DBLE(X)
+ IF (NTRACE /= 0) CALL FMNTRR(2,XDP,1)
+
+! Check to see if X is exactly a small integer. If so,
+! converting as an integer is better.
+! Also see if X is exactly a small integer divided by
+! a small power of two.
+
+ Y = MXEXP2
+ IF (ABS(XDP) < Y) THEN
+ K = INT(XDP)
+ Y = K
+ IF (Y == XDP) THEN
+ CALL FMIM(K,MA)
+ GO TO 110
+ ENDIF
+ ENDIF
+ IF (ABS(XDP) < 1.0D0) THEN
+ Y = 4096.0D0 * XDP
+ K = INT(Y)
+ YT = K
+ IF (Y == YT) THEN
+ CALL FMIM(K,MA)
+ CALL FMDIVI_R1(MA,4096)
+ GO TO 110
+ ENDIF
+ ENDIF
+
+ CALL FMDM2(XDP,MA)
+
+ 110 IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMSP2M
+
+ SUBROUTINE FMSQR(MA,MB)
+
+! MB = MA*MA Faster than using FMMPY.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMSQR '
+ CALL FMNTR(2,MA,MA,1,1)
+
+ CALL FMSQR2(MA,MB)
+
+ CALL FMNTR(1,MB,MB,1,1)
+ ELSE
+ CALL FMSQR2(MA,MB)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMSQR
+
+ SUBROUTINE FMSQR2(MA,MB)
+
+! MB = MA*MA.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MACCA,MAXMAX,MAXMWA,MBJ,MBKJ,MBM1, &
+ MBNORM,MD2B,MK,MKA,MKT,MMAX,MR,MT
+ INTEGER J,JM1,JRSSAV,K,KB,KI,KJ,KL,KNZ,KOVUN,KSHIFT,KWA, &
+ L,N1,NGUARD
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JRSSAV = JRSIGN
+ IF (ABS(MA(1)) > MEXPAB .OR. KDEBUG == 1 .OR. &
+ MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ IF (MA(1) == MUNKNO) KOVUN = 2
+ NCALL = NCALL + 1
+ CALL FMMPY2(MA,MA,MB)
+ NCALL = NCALL - 1
+ IF ((KFLAG < 0 .AND. KOVUN == 0) .OR. &
+ (KFLAG == -4 .AND. KOVUN == 1)) THEN
+ NAMEST(NCALL) = 'FMSQR '
+ CALL FMWARN
+ ENDIF
+ GO TO 120
+ ELSE IF (MA(2) == 0) THEN
+ CALL FMEQ(MA,MB)
+ GO TO 120
+ ENDIF
+ KFLAG = 0
+ MAXMAX = 0
+
+ MACCA = MA(0)
+ N1 = NDIG + 1
+ MWA(1) = MA(1) + MA(1)
+
+! NGUARD is the number of guard digits used.
+
+ IF (NCALL > 1) THEN
+ NGUARD = NGRD22
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ ELSE
+ NGUARD = NGRD52
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 10
+ ENDIF
+ ENDIF
+ IF (MA(2)*MA(2) < MBASE .AND. NGUARD < 3) NGUARD = 3
+
+ L = N1 + NGUARD
+ MWA(L+1) = 0
+
+! The multiplication loop begins here.
+
+! MBNORM is the minimum number of digits that can be
+! multiplied before normalization is required.
+! MAXMWA is an upper bound on the size of values in MWA
+! divided by (MBASE-1). It is used to determine
+! whether to normalize before the next digit is
+! multiplied.
+
+ MBM1 = MBASE - 1
+ MBNORM = AINT (MAXINT/(MBM1*MBM1))
+ MMAX = INTMAX - MBASE
+ MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX)
+ IF (MBNORM > 1) THEN
+ MBJ = MA(2)
+
+! Count the trailing zeros in MA.
+
+ IF (MA(N1) /= 0) THEN
+ KNZ = N1
+ ELSE
+ DO J = NDIG, 2, -1
+ IF (MA(J) /= 0) THEN
+ KNZ = J
+ GO TO 110
+ ENDIF
+ ENDDO
+ ENDIF
+
+ 110 MWA(2) = 0
+ MWA(3) = 0
+ DO K = NDIG+2, L
+ MWA(K) = 0
+ ENDDO
+
+! (Inner Loop)
+
+ DO K = 3, N1
+ MWA(K+1) = MA(K)*MBJ
+ ENDDO
+ MAXMWA = MBJ
+ DO J = 3, MIN(L/2,N1)
+ MBJ = MA(J)
+ IF (MBJ /= 0) THEN
+ MAXMWA = MAXMWA + MBJ
+ JM1 = J - 1
+ KL = MIN(KNZ,L-JM1)
+
+! Major (Inner Loop)
+
+ DO K = 2*J, JM1+KL
+ MWA(K) = MWA(K) + MA(K-JM1)*MBJ
+ ENDDO
+ ENDIF
+
+ IF (MAXMWA > MMAX) THEN
+ MAXMAX = MAX(MAXMAX,MAXMWA)
+ MAXMWA = 0
+
+! Normalization is only required for the
+! range of digits currently changing in MWA.
+
+ DO KB = JM1+KL, 2*J, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ ENDDO
+ ENDIF
+ ENDDO
+
+! Double MWA, add the square terms, and perform
+! the final normalization. (Inner Loop)
+
+ IF (2*MAX(MAXMAX,MAXMWA)+MBASE > MMAX) THEN
+ DO KB = L, 4, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ ENDDO
+ ENDIF
+
+ DO J = 3, L-1, 2
+ IF ((J+1)/2 <= N1) THEN
+ MKA = MA((J+1)/2)
+ MWA(J) = 2*MWA(J) + MKA*MKA
+ MWA(J+1) = 2*MWA(J+1)
+ ELSE
+ MWA(J) = 2*MWA(J)
+ MWA(J+1) = 2*MWA(J+1)
+ ENDIF
+ ENDDO
+ IF (MOD(L,2) == 1) THEN
+ IF ((L+1)/2 <= N1) THEN
+ MKA = MA((L+1)/2)
+ MWA(L) = 2*MWA(L) + MKA*MKA
+ ELSE
+ MWA(L) = 2*MWA(L)
+ ENDIF
+ ENDIF
+
+ DO KB = L, 3, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ ENDDO
+
+ ELSE
+
+! If normalization must be done for each digit, combine
+! the two loops and normalize as the digits are multiplied.
+
+ DO J = 2, L
+ MWA(J) = 0
+ ENDDO
+ KJ = NDIG + 2
+ DO J = 2, N1
+ KJ = KJ - 1
+ MBKJ = MA(KJ)
+ IF (MBKJ == 0) CYCLE
+ KL = L - KJ + 1
+ IF (KL > N1) KL = N1
+ KI = KL + 2
+ KWA = KL+ KJ + 1
+ MK = 0
+ DO K = 2, KL
+ MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MK
+ MK = INT (MT/MBASE)
+ MWA(KWA-K) = MT - MBASE*MK
+ ENDDO
+ MWA(KWA-KL-1) = MK
+ ENDDO
+
+ ENDIF
+
+! Set KSHIFT = 1 if a shift left is necessary.
+
+ IF (MWA(2) == 0) THEN
+ KSHIFT = 1
+ ELSE
+ KSHIFT = 0
+ ENDIF
+
+! The multiplication is complete.
+! Round the result and move it to MB.
+
+ JRSIGN = 1
+ MR = 2*MWA(NDIG+2+KSHIFT) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ELSE IF (MR >= MBASE) THEN
+ IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
+ MWA(N1+1+KSHIFT) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWA,MB)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMSQR '
+ CALL FMWARN
+ ENDIF
+
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MACCA,MD2B)
+ ELSE
+ MB(0) = MACCA
+ ENDIF
+ 120 MB(-1) = 1
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMSQR2
+
+ SUBROUTINE FMSQR_R1(MA)
+
+! MA = MA*MA Faster than using FMMPY.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMSQR '
+ CALL FMNTR(2,MA,MA,1,1)
+
+ CALL FMSQR2_R1(MA)
+
+ CALL FMNTR(1,MA,MA,1,1)
+ ELSE
+ CALL FMSQR2_R1(MA)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMSQR_R1
+
+ SUBROUTINE FMSQR2_R1(MA)
+
+! MA = MA*MA.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MACCA,MAXMAX,MAXMWA,MBJ,MBKJ,MBM1, &
+ MBNORM,MD2B,MK,MKA,MKT,MMAX,MR,MT
+ INTEGER J,JM1,JRSSAV,K,KB,KI,KJ,KL,KNZ,KOVUN,KSHIFT,KWA, &
+ L,N1,NGUARD
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ JRSSAV = JRSIGN
+ IF (ABS(MA(1)) > MEXPAB .OR. KDEBUG == 1 .OR. &
+ MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ IF (MA(1) == MUNKNO) KOVUN = 2
+ NCALL = NCALL + 1
+ CALL FMMPY2(MA,MA,M07)
+ CALL FMEQ(M07,MA)
+ NCALL = NCALL - 1
+ IF ((KFLAG < 0 .AND. KOVUN == 0) .OR. &
+ (KFLAG == -4 .AND. KOVUN == 1)) THEN
+ NAMEST(NCALL) = 'FMSQR '
+ CALL FMWARN
+ ENDIF
+ GO TO 120
+ ELSE IF (MA(2) == 0) THEN
+ GO TO 120
+ ENDIF
+ KFLAG = 0
+ MAXMAX = 0
+
+ MACCA = MA(0)
+ N1 = NDIG + 1
+ MWA(1) = MA(1) + MA(1)
+
+! NGUARD is the number of guard digits used.
+
+ IF (NCALL > 1) THEN
+ NGUARD = NGRD22
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ ELSE
+ NGUARD = NGRD52
+ IF (NGUARD > NDIG) NGUARD = NDIG
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NGUARD = NDIG + 10
+ ENDIF
+ ENDIF
+ IF (MA(2)*MA(2) < MBASE .AND. NGUARD < 3) NGUARD = 3
+
+ L = N1 + NGUARD
+ MWA(L+1) = 0
+
+! The multiplication loop begins here.
+
+! MBNORM is the minimum number of digits that can be
+! multiplied before normalization is required.
+! MAXMWA is an upper bound on the size of values in MWA
+! divided by (MBASE-1). It is used to determine
+! whether to normalize before the next digit is
+! multiplied.
+
+ MBM1 = MBASE - 1
+ MBNORM = AINT (MAXINT/(MBM1*MBM1))
+ MMAX = INTMAX - MBASE
+ MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX)
+ IF (MBNORM > 1) THEN
+ MBJ = MA(2)
+
+! Count the trailing zeros in MA.
+
+ IF (MA(N1) /= 0) THEN
+ KNZ = N1
+ ELSE
+ DO J = NDIG, 2, -1
+ IF (MA(J) /= 0) THEN
+ KNZ = J
+ GO TO 110
+ ENDIF
+ ENDDO
+ ENDIF
+
+ 110 MWA(2) = 0
+ MWA(3) = 0
+ DO K = NDIG+2, L
+ MWA(K) = 0
+ ENDDO
+
+! (Inner Loop)
+
+ DO K = 3, N1
+ MWA(K+1) = MA(K)*MBJ
+ ENDDO
+ MAXMWA = MBJ
+ DO J = 3, MIN(L/2,N1)
+ MBJ = MA(J)
+ IF (MBJ /= 0) THEN
+ MAXMWA = MAXMWA + MBJ
+ JM1 = J - 1
+ KL = MIN(KNZ,L-JM1)
+
+! Major (Inner Loop)
+
+ DO K = 2*J, JM1+KL
+ MWA(K) = MWA(K) + MA(K-JM1)*MBJ
+ ENDDO
+ ENDIF
+
+ IF (MAXMWA > MMAX) THEN
+ MAXMAX = MAX(MAXMAX,MAXMWA)
+ MAXMWA = 0
+
+! Normalization is only required for the
+! range of digits currently changing in MWA.
+
+ DO KB = JM1+KL, 2*J, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ ENDDO
+ ENDIF
+ ENDDO
+
+! Double MWA, add the square terms, and perform
+! the final normalization. (Inner Loop)
+
+ IF (2*MAX(MAXMAX,MAXMWA)+MBASE > MMAX) THEN
+ DO KB = L, 4, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ ENDDO
+ ENDIF
+
+ DO J = 3, L-1, 2
+ IF ((J+1)/2 <= N1) THEN
+ MKA = MA((J+1)/2)
+ MWA(J) = 2*MWA(J) + MKA*MKA
+ MWA(J+1) = 2*MWA(J+1)
+ ELSE
+ MWA(J) = 2*MWA(J)
+ MWA(J+1) = 2*MWA(J+1)
+ ENDIF
+ ENDDO
+ IF (MOD(L,2) == 1) THEN
+ IF ((L+1)/2 <= N1) THEN
+ MKA = MA((L+1)/2)
+ MWA(L) = 2*MWA(L) + MKA*MKA
+ ELSE
+ MWA(L) = 2*MWA(L)
+ ENDIF
+ ENDIF
+
+ DO KB = L, 3, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ ENDDO
+
+ ELSE
+
+! If normalization must be done for each digit, combine
+! the two loops and normalize as the digits are multiplied.
+
+ DO J = 2, L
+ MWA(J) = 0
+ ENDDO
+ KJ = NDIG + 2
+ DO J = 2, N1
+ KJ = KJ - 1
+ MBKJ = MA(KJ)
+ IF (MBKJ == 0) CYCLE
+ KL = L - KJ + 1
+ IF (KL > N1) KL = N1
+ KI = KL + 2
+ KWA = KL+ KJ + 1
+ MK = 0
+ DO K = 2, KL
+ MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MK
+ MK = INT (MT/MBASE)
+ MWA(KWA-K) = MT - MBASE*MK
+ ENDDO
+ MWA(KWA-KL-1) = MK
+ ENDDO
+
+ ENDIF
+
+! Set KSHIFT = 1 if a shift left is necessary.
+
+ IF (MWA(2) == 0) THEN
+ KSHIFT = 1
+ ELSE
+ KSHIFT = 0
+ ENDIF
+
+! The multiplication is complete.
+! Round the result and move it to MA.
+
+ JRSIGN = 1
+ MR = 2*MWA(NDIG+2+KSHIFT) + 1
+ IF (KROUND == -1 .OR. KROUND == 2) THEN
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ELSE IF (MR >= MBASE) THEN
+ IF (MR-1 > MBASE .AND. MWA(N1+KSHIFT) < MBASE-1) THEN
+ IF (KROUND /= 0 .OR. NCALL > 1) THEN
+ MWA(N1+KSHIFT) = MWA(N1+KSHIFT) + 1
+ MWA(N1+1+KSHIFT) = 0
+ ENDIF
+ ELSE
+ CALL FMRND(MWA,NDIG,NGUARD,KSHIFT)
+ ENDIF
+ ENDIF
+ CALL FMMOVE(MWA,MA)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMSQR '
+ CALL FMWARN
+ ENDIF
+
+ IF (KACCSW == 1) THEN
+ MD2B = NINT((NDIG-1)*ALOGM2 + LOG(REAL(ABS(MA(2))+1))/0.69315)
+ MA(0) = MIN(MACCA,MD2B)
+ ELSE
+ MA(0) = MACCA
+ ENDIF
+ 120 MA(-1) = 1
+ JRSIGN = JRSSAV
+ RETURN
+ END SUBROUTINE FMSQR2_R1
+
+ SUBROUTINE FMSQRT(MA,MB)
+
+! MB = SQRT(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ DOUBLE PRECISION X,XB
+ REAL (KIND(1.0D0)) :: MA1,MACCA,MD2B,MKE,MXSAVE
+ INTEGER NSTACK(19),J,K,KASAVE,KMA1,KOVUN,KRESLT,KST,NDSAVE
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0 .OR. MA(-1) < 0) THEN
+ CALL FMENTR('FMSQRT',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMSQRT'
+ CALL FMNTR(2,MA,MA,1,1)
+ ENDIF
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ NAMEST(NCALL) = 'FMSQRT'
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
+ ENDIF
+
+ MA1 = MA(1)
+
+ MACCA = MA(0)
+ CALL FMEQ2(MA,M02,NDSAVE,NDIG)
+ M02(0) = NINT(NDIG*ALOGM2)
+
+! Generate the first approximation.
+
+ M02(1) = 0
+ CALL FMM2DP(M02,X)
+ X = SQRT(X)
+ MKE = MA1/2
+ KMA1 = INT(ABS(MA1))
+ IF (MOD(KMA1,2) == 1) THEN
+ XB = MBASE
+ X = X*SQRT(XB)
+ MKE = (MA1-1)/2
+ ENDIF
+ CALL FMDPM(X,MB)
+ MB(1) = MB(1) + MKE
+
+! Initialize.
+
+ M02(1) = MA1
+ CALL FMDIG(NSTACK,KST)
+
+! Newton iteration.
+
+ DO J = 1, KST
+ NDIG = NSTACK(J)
+ CALL FMDIV(M02,MB,M01)
+ CALL FMADD_R1(MB,M01)
+ CALL FMDIVI_R1(MB,2)
+ ENDDO
+
+! Round the result and return.
+
+ IF (KASAVE == 1) THEN
+ MD2B = NINT((NDSAVE-1)*ALOGM2+LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MACCA,MD2B)
+ ELSE
+ MB(0) = MACCA
+ ENDIF
+ MB(-1) = 1
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,0)
+ RETURN
+ END SUBROUTINE FMSQRT
+
+ SUBROUTINE FMSQRT_R1(MA)
+
+! MA = SQRT(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ DOUBLE PRECISION X,XB
+ REAL (KIND(1.0D0)) :: MA1,MACCA,MD2B,MKE,MXSAVE
+ INTEGER NSTACK(19),J,K,KASAVE,KMA1,KOVUN,KRESLT,KST,NDSAVE
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0 .OR. MA(-1) < 0) THEN
+ CALL FMENTR('FMSQRT',MA,MA,1,1,M07,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) THEN
+ CALL FMEQ(M07,MA)
+ RETURN
+ ENDIF
+ ELSE
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMSQRT'
+ CALL FMNTR(2,MA,MA,1,1)
+ ENDIF
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ NAMEST(NCALL) = 'FMSQRT'
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,M07,KRESLT)
+ CALL FMEQ(M07,MA)
+ IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
+ ENDIF
+
+ MA1 = MA(1)
+
+ MACCA = MA(0)
+ CALL FMEQ2(MA,M02,NDSAVE,NDIG)
+ M02(0) = NINT(NDIG*ALOGM2)
+
+! Generate the first approximation.
+
+ M02(1) = 0
+ CALL FMM2DP(M02,X)
+ X = SQRT(X)
+ MKE = MA1/2
+ KMA1 = INT(ABS(MA1))
+ IF (MOD(KMA1,2) == 1) THEN
+ XB = MBASE
+ X = X*SQRT(XB)
+ MKE = (MA1-1)/2
+ ENDIF
+ CALL FMDPM(X,MA)
+ MA(1) = MA(1) + MKE
+
+! Initialize.
+
+ M02(1) = MA1
+ CALL FMDIG(NSTACK,KST)
+
+! Newton iteration.
+
+ DO J = 1, KST
+ NDIG = NSTACK(J)
+ CALL FMDIV(M02,MA,M01)
+ CALL FMADD_R1(MA,M01)
+ CALL FMDIVI_R1(MA,2)
+ ENDDO
+
+! Round the result and return.
+
+ IF (KASAVE == 1) THEN
+ MD2B = NINT((NDSAVE-1)*ALOGM2+LOG(REAL(ABS(MA(2))+1))/0.69315)
+ MA(0) = MIN(MACCA,MD2B)
+ ELSE
+ MA(0) = MACCA
+ ENDIF
+ MA(-1) = 1
+ DO J = -1, NDIG+1
+ M01(J) = MA(J)
+ ENDDO
+ CALL FMEXIT(M01,MA,NDSAVE,MXSAVE,KASAVE,0)
+ RETURN
+ END SUBROUTINE FMSQRT_R1
+
+ SUBROUTINE FMST2D(STRING,X)
+
+! STRING contains a free-format number that is converted to double
+! precision and returned in X.
+
+! The input number may be in integer or any real format.
+! The convention is made that if no digits appear before 'E' then 1.0
+! is assumed. For example 'E6' is converted as '1.0E+6'.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(*) :: STRING
+ INTEGER J,JSTATE,KDIGFL,KEXP,KPT,KSIGN,KSIGNX,KSTART,KSTOP, &
+ KTYPE,KVAL,N2
+ DOUBLE PRECISION X,F1,F2
+
+ INTEGER :: JTRANS(8,4) = RESHAPE( (/ &
+ 2, 9, 9, 9, 9, 7, 9, 9, &
+ 3, 3, 3, 5, 5, 8, 8, 8, &
+ 4, 4, 4, 9, 9, 9, 9, 9, &
+ 6, 6, 6, 6, 6, 9, 9, 9 /) &
+ , (/ 8,4 /) )
+
+ CHARACTER :: KBLANK = ' '
+
+ JSTATE = 1
+ KSIGN = 1
+ F1 = 0.0D0
+ F2 = 0.0D0
+ N2 = 0
+ KSIGNX = 1
+ KEXP = 0
+ KSTART = 1
+ KSTOP = LEN(STRING)
+ KFLAG = 0
+
+! KDIGFL will be 1 if any digits are found before 'E'.
+
+ KDIGFL = 0
+
+! Initialize two hash tables that are used for character
+! look-up during input conversion.
+
+ IF (LHASH == 0) CALL FMHTBL
+
+! Scan the number.
+
+ DO J = KSTART, KSTOP
+ IF (STRING(J:J) == KBLANK) CYCLE
+ KPT = ICHAR(STRING(J:J))
+ IF (KPT < LHASH1 .OR. KPT > LHASH2) THEN
+ WRITE (KW, &
+ "(/' Error in input conversion.'/" // &
+ "' ICHAR function was out of range for the current'," // &
+ "' dimensions.'/' ICHAR(''',A,''') gave the value '," // &
+ "I12,', which is outside the currently'/' dimensioned'," // &
+ "' bounds of (',I5,':',I5,') for variables KHASHT '," // &
+ "'and KHASHV.'/' Re-define the two parameters '," // &
+ "'LHASH1 and LHASH2 so the dimensions will'/' contain'," // &
+ "' all possible output values from ICHAR.'//)" &
+ ) STRING(J:J),KPT,LHASH1,LHASH2
+ KTYPE = 5
+ KVAL = 0
+ ELSE
+ KTYPE = KHASHT(KPT)
+ KVAL = KHASHV(KPT)
+ ENDIF
+ IF (KTYPE >= 5) GO TO 110
+
+ JSTATE = JTRANS(JSTATE,KTYPE)
+
+ SELECT CASE (JSTATE)
+
+! State 2. Sign of the number.
+
+ CASE (2)
+ KSIGN = KVAL
+
+! State 3. Digits before a decimal point.
+
+ CASE (3)
+ KDIGFL = 1
+ F1 = 10.0D0*F1 + KVAL
+
+! State 4. Decimal point
+
+ CASE (4)
+ CYCLE
+
+! State 5. Digits after a decimal point.
+
+ CASE (5)
+ KDIGFL = 1
+ F2 = 10.0D0*F2 + KVAL
+ N2 = N2 + 1
+
+! State 6. Precision indicator.
+
+ CASE (6)
+ IF (KDIGFL == 0) F1 = 1.0D0
+
+! State 7. Sign of the exponent.
+
+ CASE (7)
+ KSIGNX = KVAL
+
+! State 8. Digits of the exponent.
+
+ CASE (8)
+ KEXP = 10*KEXP + KVAL
+
+ CASE DEFAULT
+ GO TO 110
+
+ END SELECT
+
+ ENDDO
+
+! Form the number and return.
+
+ KEXP = KSIGNX*KEXP
+ X = KSIGN*(F1 + F2/10.0D0**N2)*10.0D0**KEXP
+
+ RETURN
+
+! Error in converting the number.
+
+ 110 X = -1.0D+31
+ KFLAG = -4
+ RETURN
+ END SUBROUTINE FMST2D
+
+ SUBROUTINE FMST2M(STRING,MA)
+
+! MA = STRING
+
+! Convert a character string to FM format.
+! This is often more convenient than using FMINP, which converts an
+! array of CHARACTER*1 values.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(*) :: STRING
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ INTEGER J,LB,KFSAVE
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMST2M'
+ LB = MIN(LEN(STRING),LMBUFF)
+ KFSAVE = KFLAG
+
+ DO J = 1, LB
+ CMBUFF(J) = STRING(J:J)
+ ENDDO
+ CALL FMINP(CMBUFF,MA,1,LB)
+
+ IF (KFSAVE /= 0) KFLAG = KFSAVE
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMST2M
+
+ SUBROUTINE FMSUB(MA,MB,MC)
+
+! MC = MA - MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ INTEGER KFLG1
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMSUB '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)
+
+ KFLG1 = 0
+ IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1
+ IF (MB(2) == 0) KFLG1 = 0
+
+! FMADD2 will negate MB and add.
+
+ KSUB = 1
+ CALL FMADD2(MA,MB,MC)
+ KSUB = 0
+
+! If MA was smaller than MB, then KFLAG = 1 returned from
+! FMADD means the result from FMSUB is the opposite of the
+! input argument of larger magnitude, so reset KFLAG.
+
+ IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0
+
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ ELSE
+ KFLG1 = 0
+ IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1
+ IF (MB(2) == 0) KFLG1 = 0
+ KSUB = 1
+ CALL FMADD2(MA,MB,MC)
+ KSUB = 0
+ IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMSUB
+
+ SUBROUTINE FMSUB_R1(MA,MB)
+
+! MA = MA - MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ INTEGER KFLG1
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMSUB '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)
+
+ KFLG1 = 0
+ IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1
+ IF (MB(2) == 0) KFLG1 = 0
+
+! FMADD2 will negate MB and add.
+
+ KSUB = 1
+ CALL FMADD2_R1(MA,MB)
+ KSUB = 0
+
+! If MA was smaller than MB, then KFLAG = 1 returned from
+! FMADD means the result from FMSUB is the opposite of the
+! input argument of larger magnitude, so reset KFLAG.
+
+ IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0
+
+ IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
+ ELSE
+ KFLG1 = 0
+ IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1
+ IF (MB(2) == 0) KFLG1 = 0
+ KSUB = 1
+ CALL FMADD2_R1(MA,MB)
+ KSUB = 0
+ IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMSUB_R1
+
+ SUBROUTINE FMSUB_R2(MA,MB)
+
+! MB = MA - MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ INTEGER KFLG1
+
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'FMSUB '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,2,1)
+
+ KFLG1 = 0
+ IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1
+ IF (MB(2) == 0) KFLG1 = 0
+
+! FMADD2 will negate MB and add.
+
+ KSUB = 1
+ CALL FMADD2_R2(MA,MB)
+ KSUB = 0
+
+! If MA was smaller than MB, then KFLAG = 1 returned from
+! FMADD means the result from FMSUB is the opposite of the
+! input argument of larger magnitude, so reset KFLAG.
+
+ IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0
+
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ ELSE
+ KFLG1 = 0
+ IF (MB(1) > MA(1) .OR. MA(2) == 0) KFLG1 = 1
+ IF (MB(2) == 0) KFLG1 = 0
+ KSUB = 1
+ CALL FMADD2_R2(MA,MB)
+ KSUB = 0
+ IF (KFLAG == 1 .AND. KFLG1 == 1) KFLAG = 0
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMSUB_R2
+
+ SUBROUTINE FMTAN(MA,MB)
+
+! MB = TAN(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
+ INTEGER J,JCOS,JSIN,JSWAP,K,KASAVE,KOVUN,KRESLT,NDSAVE,NDSV
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB .OR. MA(2) == 0) THEN
+ CALL FMENTR('FMTAN ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMTAN '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ MACCA = MA(0)
+ MAS = MA(-1)
+ CALL FMEQ2(MA,MB,NDSAVE,NDIG)
+ MB(0) = NINT(NDIG*ALOGM2)
+ MB(-1) = 1
+
+! Reduce the argument, convert to radians if the input is
+! in degrees, and evaluate the function.
+
+ CALL FMRDC(MB,JSIN,JCOS,JSWAP)
+ IF (MB(1) == MUNKNO) GO TO 110
+ IF (MB(2) == 0) THEN
+ IF (JSWAP == 1) THEN
+ KFLAG = -4
+ CALL FMWARN
+ CALL FMST2M('UNKNOWN',MB)
+ ENDIF
+ GO TO 110
+ ENDIF
+ IF (KRAD == 0) THEN
+ IF (MBSPI /= MBASE .OR. NDIGPI < NDIG) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDIG+2,NDG2MX)
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'NOEQ '
+ CALL FMPI(MPISAV)
+ NCALL = NCALL - 1
+ NDIG = NDSV
+ ENDIF
+ CALL FMMPY_R1(MB,MPISAV)
+ CALL FMDIVI_R1(MB,180)
+ ENDIF
+ IF (MB(1) /= MUNKNO) THEN
+ IF (JSWAP == 0) THEN
+ IF (MB(1) < 0) THEN
+ CALL FMSIN2(MB,M09)
+ CALL FMEQ(M09,MB)
+ MB(-1) = JSIN*MB(-1)
+ CALL FMSQR(MB,M03)
+ CALL FMI2M(1,M02)
+ CALL FMSUB_R2(M02,M03)
+ CALL FMSQRT(M03,M04)
+ M04(-1) = JCOS*M04(-1)
+ CALL FMDIV_R1(MB,M04)
+ ELSE
+ CALL FMCOS2(MB,M09)
+ CALL FMEQ(M09,MB)
+ MB(-1) = JCOS*MB(-1)
+ CALL FMSQR(MB,M03)
+ CALL FMI2M(1,M02)
+ CALL FMSUB_R2(M02,M03)
+ CALL FMSQRT(M03,M04)
+ M04(-1) = JSIN*M04(-1)
+ CALL FMDIV_R2(M04,MB)
+ ENDIF
+ ELSE
+ IF (MB(1) < 0) THEN
+ CALL FMSIN2(MB,M09)
+ CALL FMEQ(M09,MB)
+ MB(-1) = JCOS*MB(-1)
+ CALL FMSQR(MB,M03)
+ CALL FMI2M(1,M02)
+ CALL FMSUB_R2(M02,M03)
+ CALL FMSQRT(M03,M04)
+ M04(-1) = JSIN*M04(-1)
+ CALL FMDIV_R2(M04,MB)
+ ELSE
+ CALL FMCOS2(MB,M09)
+ CALL FMEQ(M09,MB)
+ MB(-1) = JSIN*MB(-1)
+ CALL FMSQR(MB,M03)
+ CALL FMI2M(1,M02)
+ CALL FMSUB_R2(M02,M03)
+ CALL FMSQRT(M03,M04)
+ M04(-1) = JCOS*M04(-1)
+ CALL FMDIV_R1(MB,M04)
+ ENDIF
+ ENDIF
+ ENDIF
+
+! Round and return.
+
+ 110 MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ IF (MAS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMTAN
+
+ SUBROUTINE FMTANH(MA,MB)
+
+! MB = TANH(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
+ INTEGER J,K,KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE
+ REAL X,XT
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB) THEN
+ CALL FMENTR('FMTANH',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMTANH'
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = MAX(NGRD52-1,2)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ KWRNSV = KWARN
+ KWARN = 0
+ MAS = MA(-1)
+
+ MACCA = MA(0)
+ CALL FMEQ2(MA,MB,NDSAVE,NDIG)
+ IF (MA(2) == 0) THEN
+ GO TO 110
+ ENDIF
+ MB(0) = NINT(NDIG*ALOGM2)
+ MB(-1) = 1
+
+ IF (MA(1) >= 1) THEN
+ XT = REAL((NDIG+1)/2)*ALOGMB
+ K = INT(LOG(XT)/ALOGMB)
+ IF (MA(1) > K+1) THEN
+ CALL FMI2M(1,MB)
+ GO TO 110
+ ELSE
+ X = REAL(MB(2)*MBASE+MB(3)+1)*REAL(MBASE)**INT(MB(1)-2)
+ IF (X > XT+5.0) THEN
+ CALL FMI2M(1,MB)
+ GO TO 110
+ ENDIF
+ ENDIF
+ ENDIF
+ IF (MB(1) == 0 .AND. NDIG < 50) THEN
+ CALL FMEXP2(MB,M09)
+ CALL FMEQ(M09,MB)
+ CALL FMSQR_R1(MB)
+ CALL FMI2M(1,M02)
+ CALL FMSUB(MB,M02,M03)
+ CALL FMADD_R2(MB,M02)
+ CALL FMDIV(M03,M02,MB)
+ GO TO 110
+ ENDIF
+ IF (MB(1) >= 0 .AND. MB(2) /= 0) THEN
+ CALL FMCOSH(MB,M13)
+ CALL FMEQ(M13,MB)
+ IF (MB(1) > NDIG) THEN
+ IF (MAS > 0) THEN
+ CALL FMI2M(1,MB)
+ GO TO 110
+ ELSE
+ CALL FMI2M(-1,MB)
+ GO TO 110
+ ENDIF
+ ENDIF
+ CALL FMSQR(MB,M03)
+ CALL FMI2M(-1,M02)
+ CALL FMADD_R1(M03,M02)
+ CALL FMSQRT_R1(M03)
+ CALL FMDIV_R2(M03,MB)
+ ELSE
+ CALL FMSINH(MB,M13)
+ CALL FMEQ(M13,MB)
+ CALL FMSQR(MB,M03)
+ CALL FMI2M(1,M02)
+ CALL FMADD_R1(M03,M02)
+ CALL FMSQRT_R1(M03)
+ CALL FMDIV_R1(MB,M03)
+ ENDIF
+
+! Round and return.
+
+ 110 KWARN = KWRNSV
+ MACMAX = NINT((NDSAVE-1)*ALOGM2 + LOG(REAL(ABS(MB(2))+1))/0.69315)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ IF (MAS < 0 .AND. MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXIT(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMTANH
+
+ SUBROUTINE FMTRAP(MA)
+
+! If MA has overflowed or underflowed, replace it by the appropriate
+! symbol.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ IF (NCALL <= 0) RETURN
+ IF (MA(1) > MXEXP+1) THEN
+ IF (MA(-1) > 0) THEN
+ CALL FMIM(0,MA)
+ MA(1) = MEXPOV
+ MA(2) = 1
+ MA(0) = NINT(NDIG*ALOGM2)
+ ELSE
+ CALL FMIM(0,MA)
+ MA(1) = MEXPOV
+ MA(2) = 1
+ MA(-1) = -1
+ MA(0) = NINT(NDIG*ALOGM2)
+ ENDIF
+ KFLAG = -5
+ ENDIF
+ IF (MA(1) < -MXEXP) THEN
+ IF (MA(-1) > 0) THEN
+ CALL FMIM(0,MA)
+ MA(1) = MEXPUN
+ MA(2) = 1
+ MA(0) = NINT(NDIG*ALOGM2)
+ ELSE
+ CALL FMIM(0,MA)
+ MA(1) = MEXPUN
+ MA(2) = 1
+ MA(-1) = -1
+ MA(0) = NINT(NDIG*ALOGM2)
+ ENDIF
+ KFLAG = -6
+ ENDIF
+
+ RETURN
+ END SUBROUTINE FMTRAP
+
+ SUBROUTINE FMULP(MA,MB)
+
+! MB = The value of one Unit in the Last Place of MA at the current
+! base and precision.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MA1
+ INTEGER J,KWRNSV,N1
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KFLAG = 0
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMULP '
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,1)
+
+ MA1 = MA(1)
+ N1 = NDIG + 1
+ DO J = 3, N1
+ MWA(J) = 0
+ ENDDO
+ MWA(2) = 1
+ MWA(1) = MA(1) - NDIG + 1
+ IF (MA(2) == 0 .OR. MA(1) >= MEXPOV) THEN
+ KFLAG = -4
+ IF (MA1 /= MUNKNO) CALL FMWARN
+ CALL FMST2M('UNKNOWN',MB)
+ ELSE
+ KWRNSV = KWARN
+ IF (MA1 == MEXPUN) KWARN = 0
+ IF (MA(-1) < 0) THEN
+ CALL FMMOVE(MWA,MB)
+ MB(-1) = 1
+ IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1
+ ELSE
+ CALL FMMOVE(MWA,MB)
+ MB(-1) = 1
+ ENDIF
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'FMULP '
+ CALL FMWARN
+ ENDIF
+ KWARN = KWRNSV
+ ENDIF
+ MB(0) = NINT(NDIG*ALOGM2)
+
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMULP
+
+ SUBROUTINE FMUNPK(MP,MA)
+
+! MP is unpacked and the value returned in MA.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MP(-1:LPACK)
+
+ INTEGER J,KP
+
+ KP = 2
+ MA(-1) = MP(-1)
+ MA(0) = MP(0)
+ MA(1) = MP(1)
+ MA(2) = AINT (ABS(MP(2))/MBASE)
+ MA(3) = ABS(MP(2)) - MA(2)*MBASE
+ IF (NDIG >= 4) THEN
+ DO J = 4, NDIG, 2
+ KP = KP + 1
+ MA(J) = AINT (MP(KP)/MBASE)
+ MA(J+1) = MP(KP) - MA(J)*MBASE
+ ENDDO
+ ENDIF
+ IF (MOD(NDIG,2) == 1) THEN
+ MA(NDIG+1) = AINT (MP(KP+1)/MBASE)
+ ENDIF
+ RETURN
+ END SUBROUTINE FMUNPK
+
+ SUBROUTINE FMVARS
+
+! Write the values of the FM global variables in module FMVALS.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' Current values of the FM global variables.'
+ WRITE (KW,*) ' '
+ WRITE (KW,*) ' ALOGM2 = ',ALOGM2
+ WRITE (KW,*) ' ALOGMB = ',ALOGMB
+ WRITE (KW,*) ' ALOGMT = ',ALOGMT
+ WRITE (KW,*) ' ALOGMX = ',ALOGMX
+ WRITE (KW,*) ' CMCHAR = ',CMCHAR
+ WRITE (KW,*) ' DLOGEB = ',DLOGEB
+ WRITE (KW,*) ' DLOGMB = ',DLOGMB
+ WRITE (KW,*) ' DLOGPI = ',DLOGPI
+ WRITE (KW,*) ' DLOGTN = ',DLOGTN
+ WRITE (KW,*) ' DLOGTP = ',DLOGTP
+ WRITE (KW,*) ' DLOGTW = ',DLOGTW
+ WRITE (KW,*) ' DPEPS = ',DPEPS
+ WRITE (KW,*) ' DPMAX = ',DPMAX
+ WRITE (KW,*) ' DPPI = ',DPPI
+ WRITE (KW,*) ' INTMAX = ',INTMAX
+ WRITE (KW,*) ' IUNKNO = ',IUNKNO
+ WRITE (KW,*) ' JFORM1 = ',JFORM1
+ WRITE (KW,*) ' JFORM2 = ',JFORM2
+ WRITE (KW,*) ' JFORMZ = ',JFORMZ
+ WRITE (KW,*) ' JPRNTZ = ',JPRNTZ
+ WRITE (KW,*) ' KACCSW = ',KACCSW
+ WRITE (KW,*) ' KDEBUG = ',KDEBUG
+ WRITE (KW,*) ' KESWCH = ',KESWCH
+ WRITE (KW,*) ' KFLAG = ',KFLAG
+ WRITE (KW,*) ' KPTIMP = ',KPTIMP
+ WRITE (KW,*) ' KPTIMU = ',KPTIMU
+ WRITE (KW,*) ' KRAD = ',KRAD
+ WRITE (KW,*) ' KROUND = ',KROUND
+ WRITE (KW,*) ' KRPERF = ',KRPERF
+ WRITE (KW,*) ' KSUB = ',KSUB
+ WRITE (KW,*) ' KSWIDE = ',KSWIDE
+ WRITE (KW,*) ' KW = ',KW
+ WRITE (KW,*) ' KWARN = ',KWARN
+ WRITE (KW,*) ' LHASH = ',LHASH
+ WRITE (KW,*) ' LHASH1 = ',LHASH1
+ WRITE (KW,*) ' LHASH2 = ',LHASH2
+ WRITE (KW,*) ' LJSUMS = ',LJSUMS
+ WRITE (KW,*) ' LMBERN = ',LMBERN
+ WRITE (KW,*) ' LMBUFF = ',LMBUFF
+ WRITE (KW,*) ' LMBUFZ = ',LMBUFZ
+ WRITE (KW,*) ' LMWA = ',LMWA
+ WRITE (KW,*) ' LPACK = ',LPACK
+ WRITE (KW,*) ' LPACKZ = ',LPACKZ
+ WRITE (KW,*) ' LUNPCK = ',LUNPCK
+ WRITE (KW,*) ' LUNPKZ = ',LUNPKZ
+ WRITE (KW,*) ' LVLTRC = ',LVLTRC
+ WRITE (KW,*) ' MAXINT = ',MAXINT
+ WRITE (KW,*) ' MBASE = ',MBASE
+ WRITE (KW,*) ' MBLOGS = ',MBLOGS
+ WRITE (KW,*) ' MBS2PI = ',MBS2PI
+ WRITE (KW,*) ' MBSBRN = ',MBSBRN
+ WRITE (KW,*) ' MBSE = ',MBSE
+ WRITE (KW,*) ' MBSEUL = ',MBSEUL
+ WRITE (KW,*) ' MBSGAM = ',MBSGAM
+ WRITE (KW,*) ' MBSLB = ',MBSLB
+ WRITE (KW,*) ' MBSLI = ',MBSLI
+ WRITE (KW,*) ' MBSPI = ',MBSPI
+ WRITE (KW,*) ' MEXPAB = ',MEXPAB
+ WRITE (KW,*) ' MEXPOV = ',MEXPOV
+ WRITE (KW,*) ' MEXPUN = ',MEXPUN
+ WRITE (KW,*) ' MUNKNO = ',MUNKNO
+ WRITE (KW,*) ' MXBASE = ',MXBASE
+ WRITE (KW,*) ' MXEXP = ',MXEXP
+ WRITE (KW,*) ' MXEXP2 = ',MXEXP2
+ WRITE (KW,*) ' NBITS = ',NBITS
+ WRITE (KW,*) ' NCALL = ',NCALL
+ WRITE (KW,*) ' NDG2MX = ',NDG2MX
+ WRITE (KW,*) ' NDG2PI = ',NDG2PI
+ WRITE (KW,*) ' NDGEUL = ',NDGEUL
+ WRITE (KW,*) ' NDGGAM = ',NDGGAM
+ WRITE (KW,*) ' NDIG = ',NDIG
+ WRITE (KW,*) ' NDIGE = ',NDIGE
+ WRITE (KW,*) ' NDIGLB = ',NDIGLB
+ WRITE (KW,*) ' NDIGLI = ',NDIGLI
+ WRITE (KW,*) ' NDIGMX = ',NDIGMX
+ WRITE (KW,*) ' NDIGPI = ',NDIGPI
+ WRITE (KW,*) ' NGRD21 = ',NGRD21
+ WRITE (KW,*) ' NGRD22 = ',NGRD22
+ WRITE (KW,*) ' NGRD52 = ',NGRD52
+ WRITE (KW,*) ' NTRACE = ',NTRACE
+ WRITE (KW,*) ' NUMBRN = ',NUMBRN
+ WRITE (KW,*) ' NWDBRN = ',NWDBRN
+ WRITE (KW,*) ' RUNKNO = ',RUNKNO
+ WRITE (KW,*) ' SPMAX = ',SPMAX
+ WRITE (KW,*) ' '
+
+ RETURN
+ END SUBROUTINE FMVARS
+
+ SUBROUTINE FMWARN
+
+! Called by one of the FM routines to print a warning message
+! if any error condition arises in that routine.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(6) :: NAME
+ INTEGER NCS
+
+ IF (KFLAG >= 0 .OR. NCALL /= 1 .OR. KWARN <= 0) RETURN
+ NCS = NCALL
+ NAME = NAMEST(NCALL)
+ WRITE (KW, &
+ "(/' Error of type KFLAG =',I3," // &
+ "' in FM package in routine ',A6/)" &
+ ) KFLAG,NAME
+
+ 110 NCALL = NCALL - 1
+ IF (NCALL > 0) THEN
+ NAME = NAMEST(NCALL)
+ WRITE (KW,"( ' called from ',A6)") NAME
+ GO TO 110
+ ENDIF
+
+ IF (KFLAG == -1) THEN
+ WRITE (KW,"(' NDIG must be between 2 and',I10/)") NDIGMX
+ ELSE IF (KFLAG == -2) THEN
+ WRITE (KW,"(' MBASE must be between 2 and',I10/)") INT(MXBASE)
+ ELSE IF (KFLAG == -3) THEN
+ WRITE (KW, &
+ "(' An input argument is not a valid FM number.'," // &
+ "' Its exponent is out of range.'/)" &
+ )
+ WRITE (KW,"(' UNKNOWN has been returned.'/)")
+ ELSE IF (KFLAG == -4 .OR. KFLAG == -7) THEN
+ WRITE (KW,"(' Invalid input argument for this routine.'/)")
+ WRITE (KW,"(' UNKNOWN has been returned.'/)")
+ ELSE IF (KFLAG == -5) THEN
+ WRITE (KW,"(' The result has overflowed.'/)")
+ ELSE IF (KFLAG == -6) THEN
+ WRITE (KW,"(' The result has underflowed.'/)")
+ ELSE IF (KFLAG == -8 .AND. NAME == 'FMOUT ') THEN
+ WRITE (KW, &
+ "(' The result array is not big enough to hold the'," // &
+ "' output character string'/' in the current format.'/" // &
+ "' The result ''***...***'' has been returned.'/)" &
+ )
+ ELSE IF (KFLAG == -8 .AND. NAME == 'FMREAD') THEN
+ WRITE (KW, &
+ "(' The CMBUFF array is not big enough to hold the'," // &
+ "' input character string'/" // &
+ "' UNKNOWN has been returned.'/)" &
+ )
+ ELSE IF (KFLAG == -9) THEN
+ WRITE (KW, &
+ "(' Precision could not be raised enough to'" // &
+ ",' provide all requested guard digits.'/)" &
+ )
+ WRITE (KW, &
+ "(I23,' digits were requested (NDIG).'/" // &
+ "' Maximum number of digits currently available'," // &
+ "' (NDG2MX) is',I7,'.'/)" &
+ ) NDIG,NDG2MX
+ WRITE (KW,"(' UNKNOWN has been returned.'/)")
+ ELSE IF (KFLAG == -10) THEN
+ IF (NAMEST(NCS) == 'FMM2SP') THEN
+ WRITE (KW, &
+ "(' An FM number was too small in magnitude to '," // &
+ "'convert to single precision.'/)" &
+ )
+ ELSE
+ WRITE (KW, &
+ "(' An FM number was too small in magnitude to '," // &
+ "'convert to double precision.'/)" &
+ )
+ ENDIF
+ WRITE (KW,"(' Zero has been returned.'/)")
+ ENDIF
+
+ NCALL = NCS
+ IF (KWARN >= 2) THEN
+ STOP
+ ENDIF
+ RETURN
+ END SUBROUTINE FMWARN
+
+ SUBROUTINE FMWRIT(KWRITE,MA)
+
+! Write MA on unit KWRITE. Multi-line numbers will have '&' as the
+! last nonblank character on all but the last line. These numbers can
+! then be read easily using FMREAD.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER KWRITE
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ INTEGER J,JF1SAV,JF2SAV,K,KSAVE,L,LAST,LB,ND,NDSAVE,NEXP
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMWRIT'
+ NDSAVE = NDIG
+ NDIG = MIN(NDG2MX,MAX(NDIG+NGRD52,2))
+
+ CALL FMEQ2(MA,M01,NDSAVE,NDIG)
+ KSAVE = KFLAG
+ ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
+ IF (ND < 2) ND = 2
+ NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
+ LB = MIN(ND+NEXP,LMBUFF)
+
+ JF1SAV = JFORM1
+ JF2SAV = JFORM2
+ JFORM1 = 1
+ JFORM2 = ND + 6
+
+ CALL FMOUT(M01,CMBUFF,LB)
+
+ KFLAG = KSAVE
+ NDIG = NDSAVE
+ JFORM1 = JF1SAV
+ JFORM2 = JF2SAV
+ LAST = LB + 1
+ DO J = 1, LB
+ IF (CMBUFF(LAST-J) /= ' ' .OR. J == LB) THEN
+ L = LAST - J
+ IF (MOD(L,73) /= 0) THEN
+ WRITE (KWRITE,"(4X,73A1,' &')") (CMBUFF(K),K=1,L)
+ ELSE
+ IF (L > 73) WRITE (KWRITE,"(4X,73A1,' &')") &
+ (CMBUFF(K),K=1,L-73)
+ WRITE (KWRITE,"(4X,73A1)") (CMBUFF(K),K=L-72,L)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDDO
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMWRIT
+
+! Here are the routines that work with packed FM numbers. All names
+! are the same as unpacked versions with 'FM' replaced by 'FP'.
+
+! To convert a program using the FM package from unpacked calls to
+! packed calls make these changes to the program:
+! '(-1:LUNPCK)' to '(-1:LPACK)' in dimensions.
+! 'CALL FM' to 'CALL FP'
+! 'FMCOMP' to 'FPCOMP'.
+
+! This packed format is not available when using the FM, IM, or ZM
+! derived types.
+
+
+ SUBROUTINE FPABS(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMABS(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPABS
+
+ SUBROUTINE FPACOS(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMACOS(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPACOS
+
+ SUBROUTINE FPADD(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMADD(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPADD
+
+ SUBROUTINE FPADD_R1(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMADD(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MA)
+ RETURN
+ END SUBROUTINE FPADD_R1
+
+ SUBROUTINE FPADD_R2(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMADD(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MB)
+ RETURN
+ END SUBROUTINE FPADD_R2
+
+ SUBROUTINE FPADDI(MA,L)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ INTEGER L
+ CALL FMUNPK(MA,MPA)
+ CALL FMADDI(MPA,L)
+ CALL FMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE FPADDI
+
+ SUBROUTINE FPASIN(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMASIN(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPASIN
+
+ SUBROUTINE FPATAN(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMATAN(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPATAN
+
+ SUBROUTINE FPATN2(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMATN2(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPATN2
+
+ SUBROUTINE FPBIG(MA)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMBIG(MPA)
+ CALL FMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE FPBIG
+
+ SUBROUTINE FPCHSH(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMCHSH(MPA,MPB,MPC)
+ CALL FMPACK(MPB,MB)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPCHSH
+
+ FUNCTION FPCOMP(MA,LREL,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ LOGICAL FPCOMP,FMCOMP
+ CHARACTER(*) :: LREL
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ FPCOMP = FMCOMP(MPA,LREL,MPB)
+ RETURN
+ END FUNCTION FPCOMP
+
+ SUBROUTINE FPCOS(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMCOS(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPCOS
+
+ SUBROUTINE FPCOSH(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMCOSH(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPCOSH
+
+ SUBROUTINE FPCSSN(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMCSSN(MPA,MPB,MPC)
+ CALL FMPACK(MPB,MB)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPCSSN
+
+ SUBROUTINE FPDIG(NSTACK,KST)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER NSTACK(19),KST
+ CALL FMDIG(NSTACK,KST)
+ RETURN
+ END SUBROUTINE FPDIG
+
+ SUBROUTINE FPDIM(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMDIM(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPDIM
+
+ SUBROUTINE FPDIV(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMDIV(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPDIV
+
+ SUBROUTINE FPDIV_R1(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMDIV(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MA)
+ RETURN
+ END SUBROUTINE FPDIV_R1
+
+ SUBROUTINE FPDIV_R2(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMDIV(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MB)
+ RETURN
+ END SUBROUTINE FPDIV_R2
+
+ SUBROUTINE FPDIVI(MA,IVAL,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ INTEGER IVAL
+ CALL FMUNPK(MA,MPA)
+ CALL FMDIVI(MPA,IVAL,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPDIVI
+
+ SUBROUTINE FPDIVI_R1(MA,IVAL)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ INTEGER IVAL
+ CALL FMUNPK(MA,MPA)
+ CALL FMDIVI(MPA,IVAL,MPB)
+ CALL FMPACK(MPB,MA)
+ RETURN
+ END SUBROUTINE FPDIVI_R1
+
+ SUBROUTINE FPDP2M(X,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ DOUBLE PRECISION X
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMDP2M(X,MPA)
+ CALL FMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE FPDP2M
+
+ SUBROUTINE FPDPM(X,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ DOUBLE PRECISION X
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMDPM(X,MPA)
+ CALL FMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE FPDPM
+
+ SUBROUTINE FPEQ(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMEQ(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPEQ
+
+ SUBROUTINE FPEQ2_R1(MA,NDA,NDB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ INTEGER NDA,NDB
+ INTEGER NDASAV,NDBSAV,NDGSAV
+ NDASAV = NDA
+ NDBSAV = NDB
+ NDGSAV = NDIG
+ NDIG = NDASAV
+ CALL FMUNPK(MA,MPA)
+ CALL FMEQ2_R1(MPA,NDASAV,NDBSAV)
+ NDIG = NDBSAV
+ CALL FMPACK(MPA,MA)
+ NDA = NDASAV
+ NDB = NDBSAV
+ NDIG = NDGSAV
+ RETURN
+ END SUBROUTINE FPEQ2_R1
+
+ SUBROUTINE FPEQU(MA,MB,NDA,NDB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ INTEGER NDA,NDB
+ INTEGER NDASAV,NDBSAV,NDGSAV
+ NDASAV = NDA
+ NDBSAV = NDB
+ NDGSAV = NDIG
+ NDIG = NDASAV
+ CALL FMUNPK(MA,MPA)
+ CALL FMEQ2_R1(MPA,NDASAV,NDBSAV)
+ NDIG = NDBSAV
+ CALL FMPACK(MPA,MB)
+ NDA = NDASAV
+ NDB = NDBSAV
+ NDIG = NDGSAV
+ RETURN
+ END SUBROUTINE FPEQU
+
+ SUBROUTINE FPEXP(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMEXP(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPEXP
+
+ SUBROUTINE FPFLAG(K)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER K
+ K = KFLAG
+ RETURN
+ END SUBROUTINE FPFLAG
+
+ SUBROUTINE FPFORM(FORM,MA,STRING)
+ USE FMVALS
+ IMPLICIT NONE
+ CHARACTER(*) :: FORM,STRING
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMFORM(FORM,MPA,STRING)
+ RETURN
+ END SUBROUTINE FPFORM
+
+ SUBROUTINE FPFPRT(FORM,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ CHARACTER(*) :: FORM
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMFPRT(FORM,MPA)
+ RETURN
+ END SUBROUTINE FPFPRT
+
+ SUBROUTINE FPI2M(IVAL,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER IVAL
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMI2M(IVAL,MPA)
+ CALL FMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE FPI2M
+
+ SUBROUTINE FPINP(LINE,MA,LA,LB)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER LA,LB
+ CHARACTER LINE(LB)
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMINP(LINE,MPA,LA,LB)
+ CALL FMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE FPINP
+
+ SUBROUTINE FPINT(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMINT(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPINT
+
+ SUBROUTINE FPIPWR(MA,IVAL,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ INTEGER IVAL
+ CALL FMUNPK(MA,MPA)
+ CALL FMIPWR(MPA,IVAL,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPIPWR
+
+ SUBROUTINE FPLG10(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMLG10(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPLG10
+
+ SUBROUTINE FPLN(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMLN(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPLN
+
+ SUBROUTINE FPLNI(IVAL,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER IVAL
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMLNI(IVAL,MPA)
+ CALL FMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE FPLNI
+
+ SUBROUTINE FPM2DP(MA,X)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ DOUBLE PRECISION X
+ CALL FMUNPK(MA,MPA)
+ CALL FMM2DP(MPA,X)
+ RETURN
+ END SUBROUTINE FPM2DP
+
+ SUBROUTINE FPM2I(MA,IVAL)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ INTEGER IVAL
+ CALL FMUNPK(MA,MPA)
+ CALL FMM2I(MPA,IVAL)
+ RETURN
+ END SUBROUTINE FPM2I
+
+ SUBROUTINE FPM2SP(MA,X)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ REAL X
+ CALL FMUNPK(MA,MPA)
+ CALL FMM2SP(MPA,X)
+ RETURN
+ END SUBROUTINE FPM2SP
+
+ SUBROUTINE FPMAX(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMMAX(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPMAX
+
+ SUBROUTINE FPMIN(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMMIN(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPMIN
+
+ SUBROUTINE FPMOD(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMMOD(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPMOD
+
+ SUBROUTINE FPMPY(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMMPY(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPMPY
+
+ SUBROUTINE FPMPY_R1(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMMPY(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MA)
+ RETURN
+ END SUBROUTINE FPMPY_R1
+
+ SUBROUTINE FPMPY_R2(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMMPY(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MB)
+ RETURN
+ END SUBROUTINE FPMPY_R2
+
+ SUBROUTINE FPMPYI(MA,IVAL,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ INTEGER IVAL
+ CALL FMUNPK(MA,MPA)
+ CALL FMMPYI(MPA,IVAL,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPMPYI
+
+ SUBROUTINE FPMPYI_R1(MA,IVAL)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ INTEGER IVAL
+ CALL FMUNPK(MA,MPA)
+ CALL FMMPYI(MPA,IVAL,MPB)
+ CALL FMPACK(MPB,MA)
+ RETURN
+ END SUBROUTINE FPMPYI_R1
+
+ SUBROUTINE FPNINT(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMNINT(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPNINT
+
+ SUBROUTINE FPOUT(MA,LINE,LB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ INTEGER LB
+ CHARACTER LINE(LB)
+ CALL FMUNPK(MA,MPA)
+ CALL FMOUT(MPA,LINE,LB)
+ RETURN
+ END SUBROUTINE FPOUT
+
+ SUBROUTINE FPPI(MA)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMPI(MPA)
+ CALL FMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE FPPI
+
+ SUBROUTINE FPPRNT(MA)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMPRNT(MPA)
+ RETURN
+ END SUBROUTINE FPPRNT
+
+ SUBROUTINE FPPWR(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMPWR(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPPWR
+
+ SUBROUTINE FPREAD(KREAD,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER KREAD
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMREAD(KREAD,MPA)
+ CALL FMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE FPREAD
+
+ SUBROUTINE FPRPWR(MA,KVAL,JVAL,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ INTEGER KVAL,JVAL
+ CALL FMUNPK(MA,MPA)
+ CALL FMRPWR(MPA,KVAL,JVAL,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPRPWR
+
+ SUBROUTINE FPSET(NPREC)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER NPREC
+ CALL FMSET(NPREC)
+ RETURN
+ END SUBROUTINE FPSET
+
+ SUBROUTINE FPSETVAR(STRING)
+ USE FMVALS
+ IMPLICIT NONE
+ CHARACTER(*) :: STRING
+ CALL FMSETVAR(STRING)
+ RETURN
+ END SUBROUTINE FPSETVAR
+
+ SUBROUTINE FPSIGN(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMSIGN(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPSIGN
+
+ SUBROUTINE FPSIN(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMSIN(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPSIN
+
+ SUBROUTINE FPSINH(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMSINH(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPSINH
+
+ SUBROUTINE FPSP2M(X,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL X
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMSP2M(X,MPA)
+ CALL FMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE FPSP2M
+
+ SUBROUTINE FPSQR(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMSQR(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPSQR
+
+ SUBROUTINE FPSQR_R1(MA)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMSQR(MPA,MPB)
+ CALL FMPACK(MPB,MA)
+ RETURN
+ END SUBROUTINE FPSQR_R1
+
+ SUBROUTINE FPSQRT(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMSQRT(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPSQRT
+
+ SUBROUTINE FPSQRT_R1(MA)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMSQRT(MPA,MPB)
+ CALL FMPACK(MPB,MA)
+ RETURN
+ END SUBROUTINE FPSQRT_R1
+
+ SUBROUTINE FPST2M(STRING,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ CHARACTER(*) :: STRING
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMST2M(STRING,MPA)
+ CALL FMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE FPST2M
+
+ SUBROUTINE FPSUB(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMSUB(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPSUB
+
+ SUBROUTINE FPSUB_R1(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMSUB(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MA)
+ RETURN
+ END SUBROUTINE FPSUB_R1
+
+ SUBROUTINE FPSUB_R2(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMSUB(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MB)
+ RETURN
+ END SUBROUTINE FPSUB_R2
+
+ SUBROUTINE FPTAN(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMTAN(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPTAN
+
+ SUBROUTINE FPTANH(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMTANH(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPTANH
+
+ SUBROUTINE FPULP(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMULP(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPULP
+
+ SUBROUTINE FPVARS
+ CALL FMVARS
+ RETURN
+ END SUBROUTINE FPVARS
+
+ SUBROUTINE FPWRIT(KWRITE,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER KWRITE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMWRIT(KWRITE,MPA)
+ RETURN
+ END SUBROUTINE FPWRIT
+
+! The IM routines perform integer multiple-precision arithmetic.
+
+
+ SUBROUTINE IMABS(MA,MB)
+
+! MB = ABS(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ INTEGER KWRNSV,NDSAVE
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMABS ',1,MA,MA)
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMABS '
+ CALL IMNTR(2,MA,MA,1)
+ ENDIF
+
+ KFLAG = 0
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL IMEQ(MA,MB)
+ MB(-1) = 1
+ KWARN = KWRNSV
+
+ IF (NTRACE /= 0) CALL IMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMABS
+
+ SUBROUTINE IMADD(MA,MB,MC)
+
+! MC = MA + MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MDA,MDAB,MDB
+ INTEGER NDSAVE
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMADD ',2,MA,MB)
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMADD '
+ CALL IMNTR(2,MA,MB,2)
+ ENDIF
+ KFLAG = 0
+
+ IF (MA(1) <= 2) THEN
+ IF (MB(1) > 2 .OR. MA(1) < 0 .OR. MB(1) < 0) GO TO 110
+ IF (MA(1) <= 1) THEN
+ MDA = MA(-1) * MA(2)
+ ELSE
+ MDA = MA(-1) * (MA(2)*MBASE + MA(3))
+ ENDIF
+ IF (MB(1) <= 1) THEN
+ MDB = MB(-1) * MB(2)
+ ELSE
+ MDB = MB(-1) * (MB(2)*MBASE + MB(3))
+ ENDIF
+ MDAB = MDA + MDB
+ IF (ABS(MDAB) < MBASE) THEN
+ MC(0) = MIN(MA(0),MB(0))
+ MC(1) = 1
+ IF (MDAB == 0) MC(1) = 0
+ IF (MDAB < 0) THEN
+ MC(2) = -MDAB
+ MC(-1) = -1
+ ELSE
+ MC(2) = MDAB
+ MC(-1) = 1
+ ENDIF
+ MC(3) = 0
+ IF (MDA == 0 .OR. MDB == 0) KFLAG = 1
+ GO TO 120
+ ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
+ MC(0) = MIN(MA(0),MB(0))
+ MC(1) = 2
+ IF (MDAB < 0) THEN
+ MC(2) = AINT (-MDAB/MBASE)
+ MC(3) = ABS(-MDAB - MBASE*MC(2))
+ MC(-1) = -1
+ ELSE
+ MC(2) = AINT (MDAB/MBASE)
+ MC(3) = ABS(MDAB - MBASE*MC(2))
+ MC(-1) = 1
+ ENDIF
+ IF (MDA == 0 .OR. MDB == 0) KFLAG = 1
+ GO TO 120
+ ENDIF
+ ENDIF
+
+! Check for special cases.
+
+ 110 IF (MA(1) > NDG2MX .OR. MB(1) > NDG2MX .OR. &
+ MA(1) < 0 .OR. MB(1) < 0) THEN
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
+ CALL IMST2M('UNKNOWN',MC)
+ KFLAG = -4
+ GO TO 130
+ ENDIF
+ IF (MA(1) == MEXPOV) THEN
+ IF (MA(-1) == MB(-1) .OR. MB(2) == 0) THEN
+ MC(-1) = MA(-1)
+ MC(0) = MA(0)
+ MC(1) = MA(1)
+ MC(2) = MA(2)
+ MC(3) = MA(3)
+ KFLAG = -5
+ GO TO 130
+ ELSE
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMADD '
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MC)
+ GO TO 130
+ ENDIF
+ ENDIF
+ IF (MB(1) == MEXPOV) THEN
+ IF (MB(-1) == MA(-1) .OR. MA(2) == 0) THEN
+ MC(-1) = MB(-1)
+ MC(0) = MB(0)
+ MC(1) = MB(1)
+ MC(2) = MB(2)
+ MC(3) = MB(3)
+ KFLAG = -5
+ GO TO 130
+ ELSE
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMADD '
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MC)
+ GO TO 130
+ ENDIF
+ ENDIF
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMADD '
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MC)
+ GO TO 130
+ ENDIF
+
+ CALL IMADD2(MA,MB,MC)
+
+ 120 IF (MC(1) > NDIGMX) THEN
+ IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN
+ IF (MC(-1) > 0) THEN
+ CALL IMST2M('OVERFLOW',MC)
+ ELSE
+ CALL IMST2M('-OVERFLOW',MC)
+ ENDIF
+ KFLAG = -5
+ NAMEST(NCALL) = 'IMADD '
+ CALL FMWARN
+ ENDIF
+ ENDIF
+
+ 130 IF (MC(1) <= 1) MC(3) = 0
+ IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMADD
+
+ SUBROUTINE IMADD2(MA,MB,MC)
+
+! Internal addition routine. MC = MA + MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MAS,MBS
+ INTEGER J,JCOMP,JSIGN,N1
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (MA(2) == 0) THEN
+ CALL IMEQ(MB,MC)
+ KFLAG = 1
+ IF (KSUB == 1) THEN
+ IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
+ KFLAG = 0
+ ENDIF
+ RETURN
+ ENDIF
+ IF (MB(2) == 0) THEN
+ CALL IMEQ(MA,MC)
+ KFLAG = 1
+ RETURN
+ ENDIF
+
+ KFLAG = 0
+ N1 = MAX(MA(1),MB(1)) + 1
+
+! JSIGN is the sign of the result of MA + MB.
+
+ JSIGN = 1
+ MAS = MA(-1)
+ MBS = MB(-1)
+ IF (KSUB == 1) MBS = -MBS
+
+! See which one is larger in absolute value.
+
+ JCOMP = 2
+ IF (MA(1) > MB(1)) THEN
+ JCOMP = 1
+ ELSE IF (MB(1) > MA(1)) THEN
+ JCOMP = 3
+ ELSE
+ DO J = 2, N1
+ IF (MA(J) > MB(J)) THEN
+ JCOMP = 1
+ EXIT
+ ENDIF
+ IF (MB(J) > MA(J)) THEN
+ JCOMP = 3
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (JCOMP < 3) THEN
+ IF (MAS < 0) JSIGN = -1
+ IF (MAS*MBS > 0) THEN
+ CALL IMADDP(MA,MB)
+ ELSE
+ CALL IMADDN(MA,MB)
+ ENDIF
+ ELSE
+ IF (MBS < 0) JSIGN = -1
+ IF (MAS*MBS > 0) THEN
+ CALL IMADDP(MB,MA)
+ ELSE
+ CALL IMADDN(MB,MA)
+ ENDIF
+ ENDIF
+
+! Transfer to MC and fix the sign of the result.
+
+ NDIG = MWA(1)
+ IF (NDIG < 2) NDIG = 2
+ IF (NDIG > NDG2MX) NDIG = NDG2MX
+ CALL FMMOVE(MWA,MC)
+ MC(0) = NINT(NDIGMX*ALOGM2)
+ MC(-1) = 1
+ IF (JSIGN < 0 .AND. MC(2) /= 0) MC(-1) = -1
+
+ IF (KFLAG < 0) THEN
+ IF (KSUB == 1) THEN
+ NAMEST(NCALL) = 'IMSUB '
+ ELSE
+ NAMEST(NCALL) = 'IMADD '
+ ENDIF
+ CALL FMWARN
+ ENDIF
+
+ RETURN
+ END SUBROUTINE IMADD2
+
+ SUBROUTINE IMADDN(MA,MB)
+
+! Internal addition routine. MWA = MA - MB
+! The arguments are such that MA >= MB >= 0.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MK
+ INTEGER J,K,KL,KP1,KP2,KPT,KSH,N1
+
+ IF (MA(1) == MEXPOV .OR. MB(1) == MEXPOV) THEN
+ KFLAG = -4
+ MWA(1) = MUNKNO
+ MWA(2) = 1
+ MWA(3) = 0
+ RETURN
+ ENDIF
+
+ N1 = MA(1) + 1
+ MK = MA(1) - MB(1)
+ K = INT(MK)
+
+! Subtract MB from MA.
+
+ KP1 = MIN(N1,K+1)
+ DO J = 1, KP1
+ MWA(J) = MA(J)
+ ENDDO
+ KP2 = K + 2
+
+! (Inner Loop)
+
+ DO J = KP2, N1
+ MWA(J) = MA(J) - MB(J-K)
+ ENDDO
+
+! Normalize. Fix the sign of any negative digit.
+
+ IF (K > 0) THEN
+ DO J = N1, KP2, -1
+ IF (MWA(J) < 0) THEN
+ MWA(J) = MWA(J) + MBASE
+ MWA(J-1) = MWA(J-1) - 1
+ ENDIF
+ ENDDO
+ KPT = KP2 - 1
+ 110 IF (MWA(KPT) < 0 .AND. KPT >= 3) THEN
+ MWA(KPT) = MWA(KPT) + MBASE
+ MWA(KPT-1) = MWA(KPT-1) - 1
+ KPT = KPT - 1
+ GO TO 110
+ ENDIF
+ ELSE
+ DO J = N1, 3, -1
+ IF (MWA(J) < 0) THEN
+ MWA(J) = MWA(J) + MBASE
+ MWA(J-1) = MWA(J-1) - 1
+ ENDIF
+ ENDDO
+ ENDIF
+
+! Shift left if there are any leading zeros in the mantissa.
+
+ DO J = 2, N1
+ IF (MWA(J) > 0) THEN
+ KSH = J - 2
+ GO TO 120
+ ENDIF
+ ENDDO
+ MWA(1) = 0
+ MWA(3) = 0
+ RETURN
+
+ 120 IF (KSH > 0) THEN
+ KL = N1 - KSH
+ DO J = 2, KL
+ MWA(J) = MWA(J+KSH)
+ ENDDO
+ DO J = KL+1, N1
+ MWA(J) = 0
+ ENDDO
+ MWA(1) = MWA(1) - KSH
+ ENDIF
+
+ RETURN
+ END SUBROUTINE IMADDN
+
+ SUBROUTINE IMADDP(MA,MB)
+
+! Internal addition routine. MWA = MA + MB
+! The arguments are such that MA >= MB >= 0.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MK
+ INTEGER J,K,KP2,KPT,N1
+
+ N1 = MA(1) + 1
+ MK = MA(1) - MB(1)
+ K = INT(MK)
+
+! Add MA and MB.
+
+ MWA(1) = MA(1) + 1
+ MWA(2) = 0
+ DO J = 2, K+1
+ MWA(J+1) = MA(J)
+ ENDDO
+ KP2 = K + 2
+
+! (Inner Loop)
+
+ DO J = KP2, N1
+ MWA(J+1) = MA(J) + MB(J-K)
+ ENDDO
+
+! Normalize. Fix any digit not less than MBASE.
+
+ IF (K > 0) THEN
+ DO J = N1+1, KP2, -1
+ IF (MWA(J) >= MBASE) THEN
+ MWA(J) = MWA(J) - MBASE
+ MWA(J-1) = MWA(J-1) + 1
+ ENDIF
+ ENDDO
+ KPT = KP2 - 1
+ 110 IF (MWA(KPT) >= MBASE .AND. KPT >= 3) THEN
+ MWA(KPT) = MWA(KPT) - MBASE
+ MWA(KPT-1) = MWA(KPT-1) + 1
+ KPT = KPT - 1
+ GO TO 110
+ ENDIF
+ ELSE
+ DO J = N1+1, 3, -1
+ IF (MWA(J) >= MBASE) THEN
+ MWA(J) = MWA(J) - MBASE
+ MWA(J-1) = MWA(J-1) + 1
+ ENDIF
+ ENDDO
+ ENDIF
+
+ RETURN
+ END SUBROUTINE IMADDP
+
+ SUBROUTINE IMARGS(KROUTN,NARGS,MA,MB)
+
+! Check the input arguments to a routine for special cases.
+
+! KROUTN - Name of the subroutine that was called
+! NARGS - The number of input arguments (1 or 2)
+! MA - First input argument
+! MB - Second input argument (if NARGS is 2)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(6) :: KROUTN
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER NARGS
+
+ REAL (KIND(1.0D0)) :: MBS
+ INTEGER J,KWRNSV,LAST
+
+ KFLAG = -4
+ IF (MA(1) == MUNKNO) RETURN
+ IF (NARGS == 2) THEN
+ IF (MB(1) == MUNKNO) RETURN
+ ENDIF
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KFLAG = 0
+
+! Check the validity of parameters.
+
+ IF (NCALL > 1 .AND. KDEBUG == 0) RETURN
+ NAMEST(NCALL) = KROUTN
+
+! Check MBASE.
+
+ IF (MBASE < 2 .OR. MBASE > MXBASE) THEN
+ KFLAG = -2
+ CALL FMWARN
+ MBS = MBASE
+ IF (MBASE < 2) MBASE = 2
+ IF (MBASE > MXBASE) MBASE = MXBASE
+ WRITE (KW, &
+ "(' MBASE was',I10,'. It has been changed to',I10,'.')" &
+ ) INT(MBS),INT(MBASE)
+ CALL FMCONS
+ RETURN
+ ENDIF
+
+! Check exponent range.
+
+ IF (MA(1) > LUNPCK .OR. MA(1) < 0) THEN
+ IF (ABS(MA(1)) /= MEXPOV .OR. ABS(MA(2)) /= 1) THEN
+ KFLAG = -3
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MA)
+ RETURN
+ ENDIF
+ ENDIF
+ IF (NARGS == 2) THEN
+ IF (MB(1) > LUNPCK .OR. MB(1) < 0) THEN
+ IF (ABS(MB(1)) /= MEXPOV .OR. ABS(MB(2)) /= 1) THEN
+ KFLAG = -3
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MB)
+ RETURN
+ ENDIF
+ ENDIF
+ ENDIF
+
+! Check for properly normalized digits in the
+! input arguments.
+
+ IF (ABS(MA(1)-INT(MA(1))) /= 0) KFLAG = 1
+ IF (MA(2) <= (-1) .OR. MA(2) >= MBASE .OR. &
+ ABS(MA(2)-INT(MA(2))) /= 0) KFLAG = 2
+ IF (KDEBUG == 0) GO TO 110
+ LAST = INT(MA(1)) + 1
+ IF (MA(1) > LUNPCK) LAST = 3
+ DO J = 3, LAST
+ IF (MA(J) < 0 .OR. MA(J) >= MBASE .OR. &
+ ABS(MA(J)-INT(MA(J))) /= 0) THEN
+ KFLAG = J
+ GO TO 110
+ ENDIF
+ ENDDO
+ 110 IF (KFLAG /= 0) THEN
+ J = KFLAG
+ KFLAG = -4
+ KWRNSV = KWARN
+ IF (KWARN >= 2) KWARN = 1
+ CALL FMWARN
+ KWARN = KWRNSV
+ IF (KWARN >= 1) THEN
+ WRITE (KW,*) ' First invalid array element: MA(', &
+ J,') = ',MA(J)
+ ENDIF
+ CALL IMST2M('UNKNOWN',MA)
+ IF (KWARN >= 2) THEN
+ STOP
+ ENDIF
+ RETURN
+ ENDIF
+ IF (NARGS == 2) THEN
+ IF (ABS(MB(1)-INT(MB(1))) /= 0) KFLAG = 1
+ IF (MB(2) <= (-1) .OR. MB(2) >= MBASE .OR. &
+ ABS(MB(2)-INT(MB(2))) /= 0) KFLAG = 2
+ IF (KDEBUG == 0) GO TO 120
+ LAST = INT(MB(1)) + 1
+ IF (MB(1) > LUNPCK) LAST = 3
+ DO J = 3, LAST
+ IF (MB(J) < 0 .OR. MB(J) >= MBASE .OR. &
+ ABS(MB(J)-INT(MB(J))) /= 0) THEN
+ KFLAG = J
+ GO TO 120
+ ENDIF
+ ENDDO
+ 120 IF (KFLAG /= 0) THEN
+ J = KFLAG
+ KFLAG = -4
+ KWRNSV = KWARN
+ IF (KWARN >= 2) KWARN = 1
+ CALL FMWARN
+ KWARN = KWRNSV
+ IF (KWARN >= 1) THEN
+ WRITE (KW,*) ' First invalid array element: MB(', &
+ J,') = ',MB(J)
+ ENDIF
+ CALL IMST2M('UNKNOWN',MB)
+ IF (KWARN >= 2) THEN
+ STOP
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+ RETURN
+ END SUBROUTINE IMARGS
+
+ SUBROUTINE IMBIG(MA)
+
+! MA = The biggest representable IM integer.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ INTEGER J
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'IMBIG '
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KFLAG = 0
+ DO J = 2, NDIGMX+1
+ MA(J) = MBASE - 1
+ ENDDO
+ MA(1) = NDIGMX
+ MA(0) = NINT(NDIGMX*ALOGM2)
+ MA(-1) = 1
+
+ IF (NTRACE /= 0) CALL IMNTR(1,MA,MA,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE IMBIG
+
+ FUNCTION IMCOMP(MA,LREL,MB)
+
+! Logical comparison of FM numbers MA and MB.
+
+! LREL is a CHARACTER description of the comparison to be done:
+! LREL = 'EQ' returns IMCOMP = .TRUE. if MA == MB
+! = 'NE', 'GE', 'GT', 'LE', 'LT' also work like a logical IF.
+! = '==', '/=', '<', '<=', '>', '>=' may be used.
+
+! Some compilers object to functions with side effects such as
+! changing KFLAG or other module FMVALS variables. Blocks of
+! code that modify these variables are identified by:
+! C DELETE START
+! ...
+! C DELETE STOP
+! These may be removed or commented out to produce a function without
+! side effects. This disables trace printing in IMCOMP, and error
+! codes are not returned in KFLAG.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ LOGICAL IMCOMP
+ CHARACTER(*) :: LREL
+ CHARACTER(2) :: JREL
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ INTEGER J,JCOMP,NDSAVE,NLAST,NTRSAV
+
+! DELETE START
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMCOMP',2,MA,MB)
+ NAMEST(NCALL) = 'IMCOMP'
+
+ IF (NCALL <= LVLTRC .AND. ABS(NTRACE) >= 2) THEN
+ WRITE (KW,"(' Input to IMCOMP')")
+ NDSAVE = NDIG
+ IF (NTRACE > 0) THEN
+ CALL IMPRNT(MA)
+ IF (INDEX('=/<>',LREL(1:1)) > 0) THEN
+ WRITE (KW,"(8X,A)") LREL
+ ELSE
+ WRITE (KW,"(7X,'.',A,'.')") LREL
+ ENDIF
+ CALL IMPRNT(MB)
+ ELSE
+ NDIG = MAX(2,INT(MA(1)))
+ IF (NDIG > NDG2MX) NDIG = 2
+ NTRSAV = NTRACE
+ IF (NTRACE < -2) NTRACE = -2
+ CALL IMNTRJ(MA,NDIG)
+ IF (INDEX('=/<>',LREL(1:1)) > 0) THEN
+ WRITE (KW,"(8X,A)") LREL
+ ELSE
+ WRITE (KW,"(7X,'.',A,'.')") LREL
+ ENDIF
+ NDIG = MAX(2,INT(MB(1)))
+ IF (NDIG > NDG2MX) NDIG = 2
+ CALL IMNTRJ(MB,NDIG)
+ NTRACE = NTRSAV
+ ENDIF
+ NDIG = NDSAVE
+ ENDIF
+! DELETE STOP
+
+! JCOMP will be 1 if MA > MB
+! 2 if MA == MB
+! 3 if MA < MB
+
+! Check for special cases.
+
+ JREL = LREL
+ IF (LREL /= 'EQ' .AND. LREL /= 'NE' .AND. LREL /= 'LT' .AND. &
+ LREL /= 'GT' .AND. LREL /= 'LE' .AND. LREL /= 'GE') THEN
+ IF (LREL == 'eq' .OR. LREL == '==') THEN
+ JREL = 'EQ'
+ ELSE IF (LREL == 'ne' .OR. LREL == '/=') THEN
+ JREL = 'NE'
+ ELSE IF (LREL == 'lt' .OR. LREL == '<') THEN
+ JREL = 'LT'
+ ELSE IF (LREL == 'gt' .OR. LREL == '>') THEN
+ JREL = 'GT'
+ ELSE IF (LREL == 'le' .OR. LREL == '<=') THEN
+ JREL = 'LE'
+ ELSE IF (LREL == 'ge' .OR. LREL == '>=') THEN
+ JREL = 'GE'
+ ELSE
+ IMCOMP = .FALSE.
+! DELETE START
+ KFLAG = -4
+ IF (NCALL /= 1 .OR. KWARN <= 0) GO TO 120
+! DELETE STOP
+ IF (KWARN <= 0) GO TO 120
+ WRITE (KW, &
+ "(/' Error of type KFLAG = -4 in FM package in'," // &
+ "' routine IMCOMP'//1X,A,' is not one of the six'," // &
+ "' recognized comparisons.'//' .FALSE. has been'," // &
+ "' returned.'/)" &
+ ) LREL
+ IF (KWARN >= 2) THEN
+ STOP
+ ENDIF
+ GO TO 120
+ ENDIF
+ ENDIF
+
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
+ IMCOMP = .FALSE.
+! DELETE START
+ KFLAG = -4
+! DELETE STOP
+ GO TO 120
+ ENDIF
+
+ IF (ABS(MA(1)) == MEXPOV .AND. MA(1) == MB(1) .AND. &
+ MA(2) == MB(2) .AND. MA(-1) == MB(-1)) THEN
+ IMCOMP = .FALSE.
+! DELETE START
+ KFLAG = -4
+ IF (NCALL /= 1 .OR. KWARN <= 0) GO TO 120
+! DELETE STOP
+ IF (KWARN <= 0) GO TO 120
+ WRITE (KW, &
+ "(/' Error of type KFLAG = -4 in FM package in '," // &
+ "'routine IMCOMP'//' Two numbers in the same '," // &
+ "'overflow category cannot be compared.'//" // &
+ "' .FALSE. has been returned.'/)" &
+ )
+ IF (KWARN >= 2) THEN
+ STOP
+ ENDIF
+ GO TO 120
+ ENDIF
+
+! Check for zero.
+
+! DELETE START
+ KFLAG = 0
+! DELETE STOP
+ IF (MA(2) == 0) THEN
+ JCOMP = 2
+ IF (MB(2) == 0) GO TO 110
+ IF (MB(-1) < 0) JCOMP = 1
+ IF (MB(-1) > 0) JCOMP = 3
+ GO TO 110
+ ENDIF
+ IF (MB(2) == 0) THEN
+ JCOMP = 1
+ IF (MA(-1) < 0) JCOMP = 3
+ GO TO 110
+ ENDIF
+! Check for opposite signs.
+
+ IF (MA(-1) > 0 .AND. MB(-1) < 0) THEN
+ JCOMP = 1
+ GO TO 110
+ ENDIF
+ IF (MB(-1) > 0 .AND. MA(-1) < 0) THEN
+ JCOMP = 3
+ GO TO 110
+ ENDIF
+
+! See which one is larger in absolute value.
+
+ IF (MA(1) > MB(1)) THEN
+ JCOMP = 1
+ GO TO 110
+ ENDIF
+ IF (MB(1) > MA(1)) THEN
+ JCOMP = 3
+ GO TO 110
+ ENDIF
+ NLAST = INT(MA(1)) + 1
+ IF (NLAST > NDG2MX+1) NLAST = 2
+
+ DO J = 2, NLAST
+ IF (ABS(MA(J)) > ABS(MB(J))) THEN
+ JCOMP = 1
+ GO TO 110
+ ENDIF
+ IF (ABS(MB(J)) > ABS(MA(J))) THEN
+ JCOMP = 3
+ GO TO 110
+ ENDIF
+ ENDDO
+
+ JCOMP = 2
+
+! Now match the JCOMP value to the requested comparison.
+
+ 110 IF (JCOMP == 1 .AND. MA(-1) < 0) THEN
+ JCOMP = 3
+ ELSE IF (JCOMP == 3 .AND. MB(-1) < 0) THEN
+ JCOMP = 1
+ ENDIF
+
+ IMCOMP = .FALSE.
+ IF (JCOMP == 1 .AND. (JREL == 'GT' .OR. JREL == 'GE' .OR. &
+ JREL == 'NE')) IMCOMP = .TRUE.
+
+ IF (JCOMP == 2 .AND. (JREL == 'EQ' .OR. JREL == 'GE' .OR. &
+ JREL == 'LE')) IMCOMP = .TRUE.
+
+ IF (JCOMP == 3 .AND. (JREL == 'NE' .OR. JREL == 'LT' .OR. &
+ JREL == 'LE')) IMCOMP = .TRUE.
+
+ 120 CONTINUE
+! DELETE START
+ IF (NTRACE /= 0) THEN
+ IF (NCALL <= LVLTRC .AND. ABS(NTRACE) >= 1) THEN
+ IF (KFLAG == 0) THEN
+ WRITE (KW, &
+ "(' IMCOMP',15X,'Call level =',I2,5X," // &
+ "'MBASE =',I10)" &
+ ) NCALL,INT(MBASE)
+ ELSE
+ WRITE (KW, &
+ "(' IMCOMP',6X,'Call level =',I2,4X," // &
+ "'MBASE =',I10,4X,'KFLAG =',I3)" &
+ ) NCALL,INT(MBASE),KFLAG
+ ENDIF
+ IF (IMCOMP) THEN
+ WRITE (KW,"(7X,'.TRUE.')")
+ ELSE
+ WRITE (KW,"(7X,'.FALSE.')")
+ ENDIF
+ ENDIF
+ ENDIF
+ NCALL = NCALL - 1
+! DELETE STOP
+ RETURN
+ END FUNCTION IMCOMP
+
+ SUBROUTINE IMDIM(MA,MB,MC)
+
+! MC = DIM(MA,MB)
+
+! Positive difference. MC = MA - MB if MA >= MB,
+! = 0 otherwise.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ INTEGER KOVFL
+ LOGICAL IMCOMP
+
+ KFLAG = 0
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMDIM ',2,MA,MB)
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMDIM '
+ CALL IMNTR(2,MA,MB,2)
+ ENDIF
+
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
+ CALL IMST2M('UNKNOWN',MC)
+ KFLAG = -4
+ GO TO 110
+ ENDIF
+ IF (MA(1) < 0 .OR. MB(1) < 0) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMDIM '
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MC)
+ GO TO 110
+ ENDIF
+ KOVFL = 0
+ IF (MA(1) == MEXPOV .OR. MB(1) == MEXPOV) THEN
+ KOVFL = 1
+ IF (MA(1) == MEXPOV .AND. MB(1) == MEXPOV .AND. &
+ MA(2) == MB(2) .AND. MA(-1) == MB(-1)) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMDIM '
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MC)
+ GO TO 110
+ ENDIF
+ ENDIF
+
+ IF (IMCOMP(MA,'GE',MB)) THEN
+ CALL IMSUB(MA,MB,MC)
+ IF (KFLAG == 1) KFLAG = 0
+ ELSE
+ MC(1) = 0
+ MC(2) = 0
+ MC(3) = 0
+ MC(-1) = 1
+ MC(0) = NINT(NDG2MX*ALOGM2)
+ ENDIF
+
+ IF (MC(1) > NDIGMX) THEN
+ IF (MC(1) == MUNKNO) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMDIM '
+ CALL FMWARN
+ ELSE IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN
+ IF (MC(-1) > 0) THEN
+ CALL IMST2M('OVERFLOW',MC)
+ ELSE
+ CALL IMST2M('-OVERFLOW',MC)
+ ENDIF
+ KFLAG = -5
+ NAMEST(NCALL) = 'IMDIM '
+ IF (KOVFL /= 1) CALL FMWARN
+ ENDIF
+ ENDIF
+
+ 110 IF (MC(1) <= 1) MC(3) = 0
+ IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE IMDIM
+
+ SUBROUTINE IMDIV(MA,MB,MC)
+
+! MC = INT(MA/MB)
+
+! Use IMDIVR if both INT(MA/MB) and MOD(MA,MB) are needed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+ INTEGER NDSAVE
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMDIV ',2,MA,MB)
+ KFLAG = 0
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMDIV '
+ CALL IMNTR(2,MA,MB,2)
+ ENDIF
+
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
+ CALL IMST2M('UNKNOWN',MC)
+ KFLAG = -4
+ GO TO 110
+ ENDIF
+
+ CALL IMDIVR(MA,MB,MC,M03)
+
+ IF (MC(1) == MUNKNO) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMDIV '
+ CALL FMWARN
+ ENDIF
+
+ 110 IF (MC(1) <= 1) MC(3) = 0
+ IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMDIV
+
+ SUBROUTINE IMDIVI(MA,IDIV,MB)
+
+! MB = INT(MA/IDIV)
+
+! Use IMDVIR if both INT(MA/IDIV) and MOD(MA,IDIV) are needed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER IDIV,IREM,NDSAVE
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMDIVI',1,MA,MA)
+ KFLAG = 0
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMDIVI'
+ CALL IMNTR(2,MA,MA,1)
+ CALL IMNTRI(2,IDIV,0)
+ ENDIF
+
+ IF (MA(1) == MUNKNO) THEN
+ CALL IMST2M('UNKNOWN',MB)
+ KFLAG = -4
+ GO TO 110
+ ENDIF
+
+ CALL IMDVIR(MA,IDIV,MB,IREM)
+
+ IF (MB(1) == MUNKNO) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMDIVI'
+ CALL FMWARN
+ ENDIF
+
+ 110 IF (MB(1) <= 1) MB(3) = 0
+ IF (NTRACE /= 0) CALL IMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMDIVI
+
+ SUBROUTINE IMDIVR(MA,MB,MC,MD)
+
+! MC = INT(MA / MB), MD = Remainder from the division.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK), &
+ MD(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MDA,MDAB,MDB,MDR
+ DOUBLE PRECISION XB,XBR,XBASE,XMWA
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MAXMWA,MB1, &
+ MBM1,MBS,MCARRY,MKT,MLMAX,MQD
+ INTEGER J,JB,JL,K,KA,KB,KL,KLTFLG,KPTMWA,LCRRCT,NA1,NB1, &
+ NDSAVE,NGUARD,NL,NMBWDS,NTRSAV
+ LOGICAL IMCOMP
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMDIVR',2,MA,MB)
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMDIVR'
+ CALL IMNTR(2,MA,MB,2)
+ ENDIF
+ KFLAG = 0
+ NTRSAV = NTRACE
+ NTRACE = 0
+ IF (MBLOGS /= MBASE) CALL FMCONS
+
+! Check for special cases.
+
+ IF (MB(1) == 1 .AND. MA(1) /= MUNKNO) THEN
+ IF (MB(-1)*MB(2) == 1) THEN
+ CALL IMEQ(MA,MC)
+ MD(1) = 0
+ MD(2) = 0
+ MD(3) = 0
+ MD(-1) = 1
+ MD(0) = NINT(NDG2MX*ALOGM2)
+ GO TO 170
+ ELSE IF (MB(-1)*MB(2) == -1) THEN
+ CALL IMEQ(MA,MC)
+ IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
+ MD(1) = 0
+ MD(2) = 0
+ MD(3) = 0
+ MD(-1) = 1
+ MD(0) = NINT(NDG2MX*ALOGM2)
+ GO TO 170
+ ENDIF
+ ENDIF
+ IF (MA(1) < MB(1) .AND. MB(1) /= MUNKNO) GO TO 110
+ IF (MA(1) > NDG2MX .OR. MB(1) > NDG2MX .OR. &
+ MA(1) < 0 .OR. MB(1) < 0 .OR. MB(2) == 0) THEN
+ KFLAG = -4
+ IF (MA(1) /= MUNKNO .AND. MB(1) /= MUNKNO) THEN
+ NAMEST(NCALL) = 'IMDIVR'
+ CALL FMWARN
+ ENDIF
+ CALL IMST2M('UNKNOWN',MC)
+ CALL IMST2M('UNKNOWN',MD)
+ GO TO 170
+ ENDIF
+ IF (MA(1) <= 2) THEN
+ IF (MB(1) > 2) GO TO 110
+ IF (MB(2) == 0) GO TO 110
+ IF (MA(1) <= 1) THEN
+ MDA = MA(-1) * MA(2)
+ ELSE
+ MDA = MA(-1) * (MA(2)*MBASE + MA(3))
+ ENDIF
+ IF (MB(1) <= 1) THEN
+ MDB = MB(-1) * MB(2)
+ ELSE
+ MDB = MB(-1) * (MB(2)*MBASE + MB(3))
+ ENDIF
+ MDAB = AINT (MDA / MDB)
+ MDR = MDA - MDAB*MDB
+ IF (ABS(MDAB) < MBASE) THEN
+ MC(0) = NINT(NDG2MX*ALOGM2)
+ MC(1) = 1
+ IF (MDAB == 0) MC(1) = 0
+ IF (MDAB >= 0) THEN
+ MC(2) = MDAB
+ MC(-1) = 1
+ ELSE
+ MC(2) = -MDAB
+ MC(-1) = -1
+ ENDIF
+ MC(3) = 0
+ ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
+ MC(0) = NINT(NDG2MX*ALOGM2)
+ MC(1) = 2
+ IF (MDAB >= 0) THEN
+ MC(2) = AINT (MDAB/MBASE)
+ MC(3) = ABS(MDAB - MBASE*MC(2))
+ MC(-1) = 1
+ ELSE
+ MC(2) = AINT (-MDAB/MBASE)
+ MC(3) = ABS(-MDAB - MBASE*MC(2))
+ MC(-1) = -1
+ ENDIF
+ ELSE
+ GO TO 110
+ ENDIF
+ IF (ABS(MDR) < MBASE) THEN
+ MD(0) = MC(0)
+ MD(1) = 1
+ IF (MDR == 0) MD(1) = 0
+ IF (MDR >= 0) THEN
+ MD(2) = MDR
+ MD(-1) = 1
+ ELSE
+ MD(2) = -MDR
+ MD(-1) = -1
+ ENDIF
+ MD(3) = 0
+ GO TO 170
+ ELSE IF (ABS(MDR) < MBASE*MBASE) THEN
+ MD(0) = MC(0)
+ MD(1) = 2
+ IF (MDR >= 0) THEN
+ MD(2) = AINT (MDR/MBASE)
+ MD(3) = ABS(MDR - MBASE*MD(2))
+ MD(-1) = 1
+ ELSE
+ MD(2) = AINT (-MDR/MBASE)
+ MD(3) = ABS(-MDR - MBASE*MD(2))
+ MD(-1) = -1
+ ENDIF
+ GO TO 170
+ ENDIF
+ ENDIF
+
+ 110 KLTFLG = 0
+ MAS = MA(-1)
+ MBS = MB(-1)
+ KL = INT(MB(1))
+ IF (KL > NDG2MX) KL = 2
+ DO J = 0, KL+1
+ M01(J) = MB(J)
+ ENDDO
+ M01(-1) = 1
+ IF (KL == 1) M01(3) = 0
+ IF (MA(1) == M01(1) .AND. ABS(MA(2)) <= M01(2)) THEN
+ DO J = 2, KL+1
+ IF (MA(J) /= M01(J)) GO TO 120
+ ENDDO
+ KLTFLG = 2
+ 120 IF (KLTFLG == 0) THEN
+ DO J = 2, KL+1
+ IF (MA(J) < M01(J)) THEN
+ KLTFLG = 1
+ EXIT
+ ELSE IF (MA(J) > M01(J)) THEN
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+ IF (MA(1) < MB(1) .OR. KLTFLG >= 1) THEN
+ IF (KLTFLG /= 2) THEN
+ CALL IMEQ(MA,MD)
+ MD(-1) = ABS(MD(-1))
+ CALL IMI2M(0,MC)
+ ELSE
+ CALL IMI2M(1,MC)
+ CALL IMI2M(0,MD)
+ ENDIF
+ GO TO 160
+ ENDIF
+
+ NDIG = INT(MA(1))
+ IF (NDIG < 2) NDIG = 2
+
+ MACCA = MA(0)
+ MACCB = MB(0)
+
+! NGUARD is the number of guard digits used.
+
+ NGUARD = 1
+ NA1 = INT(MA(1)) + 1
+ NB1 = INT(MB(1)) + 1
+
+! Copy MA into the working array.
+
+ DO J = 3, NA1
+ MWA(J+1) = MA(J)
+ ENDDO
+ MWA(1) = MA(1) - MB(1) + 1
+ MWA(2) = 0
+ NL = NA1 + NGUARD + 3
+ DO J = NA1+2, NL
+ MWA(J) = 0
+ ENDDO
+
+! Save the sign of MA and MB and then work only with
+! positive numbers.
+
+ MAS = MA(-1)
+ MB1 = MB(1)
+ MBS = MB(-1)
+ MWA(3) = MA(2)
+
+! NMBWDS is the number of words of MB used to
+! compute the estimated quotient digit MQD.
+
+ NMBWDS = 4
+ IF (MBASE < 100) NMBWDS = 7
+
+! XB is an approximation of MB used in
+! estimating the quotient digits.
+
+ XBASE = DBLE(MBASE)
+ XB = 0
+ JL = NMBWDS
+ IF (JL <= NB1) THEN
+ DO J = 2, JL
+ XB = XB*XBASE + DBLE(MB(J))
+ ENDDO
+ ELSE
+ DO J = 2, JL
+ IF (J <= NB1) THEN
+ XB = XB*XBASE + DBLE(MB(J))
+ ELSE
+ XB = XB*XBASE
+ ENDIF
+ ENDDO
+ ENDIF
+ IF (JL+1 <= NB1) XB = XB + DBLE(MB(JL+1))/XBASE
+ XBR = 1.0D0/XB
+
+! MLMAX determines when to normalize all of MWA.
+
+ MBM1 = MBASE - 1
+ MLMAX = MAXINT/MBM1
+ MKT = INTMAX - MBASE
+ MLMAX = MIN(MLMAX,MKT)
+
+! MAXMWA is an upper bound on the size of values in MWA
+! divided by MBASE-1. It is used to determine whether
+! normalization can be postponed.
+
+ MAXMWA = 0
+
+! KPTMWA points to the next digit in the quotient.
+
+ KPTMWA = 2
+
+! This is the start of the division loop.
+
+! XMWA is an approximation of the active part of MWA
+! used in estimating quotient digits.
+
+ 130 KL = KPTMWA + NMBWDS - 1
+ IF (KL <= NL) THEN
+ XMWA = ((DBLE(MWA(KPTMWA))*XBASE &
+ + DBLE(MWA(KPTMWA+1)))*XBASE &
+ + DBLE(MWA(KPTMWA+2)))*XBASE &
+ + DBLE(MWA(KPTMWA+3))
+ DO J = KPTMWA+4, KL
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ ENDDO
+ ELSE
+ XMWA = DBLE(MWA(KPTMWA))
+ DO J = KPTMWA+1, KL
+ IF (J <= NL) THEN
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ ELSE
+ XMWA = XMWA*XBASE
+ ENDIF
+ ENDDO
+ ENDIF
+
+! MQD is the estimated quotient digit.
+
+ MQD = AINT(XMWA*XBR)
+ IF (MQD < 0) MQD = MQD - 1
+
+ IF (MQD > 0) THEN
+ MAXMWA = MAXMWA + MQD
+ ELSE
+ MAXMWA = MAXMWA - MQD
+ ENDIF
+
+! See if MWA must be normalized.
+
+ KA = KPTMWA + 1
+ KB = KA + INT(MB1) - 1
+ IF (MAXMWA >= MLMAX) THEN
+ DO J = KB, KA, -1
+ IF (MWA(J) < 0) THEN
+ MCARRY = INT((-MWA(J)-1)/MBASE) + 1
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ELSE IF (MWA(J) >= MBASE) THEN
+ MCARRY = -INT(MWA(J)/MBASE)
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ENDIF
+ ENDDO
+ XMWA = 0
+ IF (KL <= NL) THEN
+ DO J = KPTMWA, KL
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ ENDDO
+ ELSE
+ DO J = KPTMWA, KL
+ IF (J <= NL) THEN
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ ELSE
+ XMWA = XMWA*XBASE
+ ENDIF
+ ENDDO
+ ENDIF
+ MQD = AINT(XMWA*XBR)
+ IF (MQD < 0) MQD = MQD - 1
+ IF (MQD > 0) THEN
+ MAXMWA = MQD
+ ELSE
+ MAXMWA = -MQD
+ ENDIF
+ ENDIF
+
+! Subtract MQD*MB from MWA.
+
+ JB = KA - 2
+ IF (MQD /= 0) THEN
+
+! Major (Inner Loop)
+
+ DO J = KA, KB
+ MWA(J) = MWA(J) - MQD*MB(J-JB)
+ ENDDO
+ ENDIF
+
+ MWA(KA) = MWA(KA) + MWA(KA-1)*MBASE
+ MWA(KPTMWA) = MQD
+
+ KPTMWA = KPTMWA + 1
+ IF (KPTMWA-2 < MWA(1)) GO TO 130
+
+! Final normalization.
+
+ KPTMWA = KPTMWA - 1
+ DO J = KPTMWA, 3, -1
+ IF (MWA(J) < 0) THEN
+ MCARRY = INT((-MWA(J)-1)/MBASE) + 1
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ELSE IF (MWA(J) >= MBASE) THEN
+ MCARRY = -INT(MWA(J)/MBASE)
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ENDIF
+ ENDDO
+
+ LCRRCT = 0
+ 140 DO J = KPTMWA+INT(MB1), KPTMWA+2, -1
+ IF (MWA(J) < 0) THEN
+ MCARRY = INT((-MWA(J)-1)/MBASE) + 1
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ELSE IF (MWA(J) >= MBASE) THEN
+ MCARRY = -INT(MWA(J)/MBASE)
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ENDIF
+ ENDDO
+
+! Due to rounding, the remainder may not be between
+! 0 and ABS(MB) here. Correct if necessary.
+
+ IF (MWA(KA) < 0) THEN
+ LCRRCT = LCRRCT - 1
+ DO J = KA, KB
+ MWA(J) = MWA(J) + MB(J-JB)
+ ENDDO
+ GO TO 140
+ ELSE IF (MWA(KA) >= MBASE) THEN
+ LCRRCT = LCRRCT + 1
+ DO J = KA, KB
+ MWA(J) = MWA(J) - MB(J-JB)
+ ENDDO
+ GO TO 140
+ ENDIF
+ IF (MWA(2) /= 0 .OR. KPTMWA == 2) THEN
+ DO J = 1, INT(MWA(1))+1
+ MC(J) = MWA(J)
+ ENDDO
+ ELSE
+ DO J = 3, INT(MWA(1))+1
+ MC(J-1) = MWA(J)
+ ENDDO
+ IF (MC(2) /= 0) THEN
+ MC(1) = MWA(1) - 1
+ ELSE
+ MC(1) = 0
+ ENDIF
+ ENDIF
+ IF (MC(1) <= 1) MC(3) = 0
+ MC(0) = MIN(MACCA,MACCB)
+ MC(-1) = 1
+
+ IF (MWA(KPTMWA+1) /= 0) THEN
+ DO J = 1, INT(MB1)
+ MD(J+1) = MWA(KPTMWA+J)
+ ENDDO
+ MD(1) = MB1
+ ELSE
+ DO J = 1, INT(MB1)
+ IF (MWA(KPTMWA+J) /= 0) THEN
+ DO K = J, INT(MB1)
+ MD(K-J+2) = MWA(KPTMWA+K)
+ ENDDO
+ MD(1) = MB1 + 1 - J
+ GO TO 150
+ ENDIF
+ ENDDO
+ MD(1) = 0
+ MD(2) = 0
+ ENDIF
+ 150 IF (MD(1) <= 1) MD(3) = 0
+ MD(0) = MIN(MACCA,MACCB)
+ MD(-1) = 1
+
+! If the remainder had to be corrected, make the
+! corresponding adjustment in the quotient.
+
+ IF (MD(1) > M01(1) .OR. &
+ (MD(1) == M01(1) .AND. ABS(MD(2)) >= M01(2))) THEN
+ IF (IMCOMP(MD,'GE',M01)) THEN
+ CALL IMSUB(MD,M01,M10)
+ CALL IMEQ(M10,MD)
+ LCRRCT = LCRRCT + 1
+ ENDIF
+ ENDIF
+ IF (LCRRCT /= 0) THEN
+ CALL IMI2M(LCRRCT,M02)
+ CALL IMADD(M02,MC,M10)
+ CALL IMEQ(M10,MC)
+ ENDIF
+
+ 160 MC(-1) = 1
+ MD(-1) = 1
+ IF (MAS < 0 .AND. MBS > 0) THEN
+ IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1
+ IF (MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -1
+ ELSE IF (MAS > 0 .AND. MBS < 0) THEN
+ IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1
+ ELSE IF (MAS < 0 .AND. MBS < 0) THEN
+ IF (MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -1
+ ENDIF
+
+ 170 IF (MC(1) <= 1) MC(3) = 0
+ IF (MD(1) <= 1) MD(3) = 0
+ NTRACE = NTRSAV
+ IF (NTRACE /= 0) THEN
+ CALL IMNTR(1,MC,MC,1)
+ IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN
+ IF (NTRACE < 0) THEN
+ NDIG = MAX(2,INT(MD(1)))
+ IF (NDIG > NDG2MX) NDIG = 2
+ NTRSAV = NTRACE
+ IF (NTRACE < -2) NTRACE = -2
+ CALL IMNTRJ(MD,NDIG)
+ NTRACE = NTRSAV
+ ELSE
+ CALL IMPRNT(MD)
+ ENDIF
+ ENDIF
+ ENDIF
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMDIVR
+
+ SUBROUTINE IMDVIR(MA,IDIV,MB,IREM)
+
+! MB = INT(MA / IDIV), IREM = Remainder from the division.
+
+! Division by a one word integer. The remainder is also a
+! one word integer.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MAS,MDA,MDAB,MDB,MDR,MKT,MODINT,MVALP
+ INTEGER IDIV,IREM,J,JDIV,KA,KL,KLTFLG,KPT,N1,NDSAVE, &
+ NMVAL,NTRSAV,NV2
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMDVIR',1,MA,MA)
+ KFLAG = 0
+ NDSAVE = NDIG
+ KLTFLG = 0
+ NTRSAV = NTRACE
+ NTRACE = 0
+ MKT = ABS(IDIV)
+ IF (MKT < MBASE) THEN
+ M01(0) = MA(0)
+ M01(1) = 1
+ M01(2) = ABS(IDIV)
+ M01(-1) = 1
+ IF (IDIV < 0) M01(-1) = -1
+ M01(3) = 0
+ ELSE IF (MKT < MBASE*MBASE) THEN
+ M01(0) = MA(0)
+ M01(1) = 2
+ M01(2) = INT(MKT/MBASE)
+ M01(3) = MKT - M01(2)*MBASE
+ M01(-1) = 1
+ IF (IDIV < 0) M01(-1) = -1
+ ELSE
+ CALL IMI2M(IDIV,M01)
+ ENDIF
+ NTRACE = NTRSAV
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMDVIR'
+ CALL IMNTR(2,MA,MA,1)
+ CALL IMNTRI(2,IDIV,0)
+ ENDIF
+ JDIV = ABS(IDIV)
+
+! Check for special cases.
+
+ IF (MA(1) < 0) THEN
+ IREM = IUNKNO
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMDVIR'
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MB)
+ GO TO 150
+ ENDIF
+ IF (JDIV == 1 .AND. MA(1) /= MUNKNO) THEN
+ IF (IDIV == 1) THEN
+ CALL IMEQ(MA,MB)
+ IREM = 0
+ GO TO 150
+ ELSE
+ CALL IMEQ(MA,MB)
+ IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
+ IREM = 0
+ GO TO 150
+ ENDIF
+ ENDIF
+ IF (MA(1) > NDG2MX .OR. IDIV == 0) THEN
+ KFLAG = -4
+ IF (MA(1) /= MUNKNO) THEN
+ NAMEST(NCALL) = 'IMDVIR'
+ CALL FMWARN
+ ENDIF
+ CALL IMST2M('UNKNOWN',MB)
+ IREM = IUNKNO
+ GO TO 150
+ ENDIF
+ IF (MA(1) <= 2) THEN
+ IF (MA(1) <= 1) THEN
+ MDA = MA(-1) * MA(2)
+ ELSE
+ MDA = MA(-1) * (MA(2)*MBASE + MA(3))
+ ENDIF
+ MDB = IDIV
+ MDAB = AINT (MDA/MDB)
+ MDR = MDA - MDAB*MDB
+ IF (ABS(MDAB) < MBASE) THEN
+ MB(0) = MA(0)
+ MB(1) = 1
+ IF (MDAB == 0) MB(1) = 0
+ IF (MDAB < 0) THEN
+ MB(2) = -MDAB
+ MB(-1) = -1
+ ELSE
+ MB(2) = MDAB
+ MB(-1) = 1
+ ENDIF
+ MB(3) = 0
+ ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
+ MB(0) = MA(0)
+ MB(1) = 2
+ IF (MDAB < 0) THEN
+ MB(2) = AINT (-MDAB/MBASE)
+ MB(3) = ABS(-MDAB - MBASE*MB(2))
+ MB(-1) = -1
+ ELSE
+ MB(2) = AINT (MDAB/MBASE)
+ MB(3) = ABS(MDAB - MBASE*MB(2))
+ MB(-1) = 1
+ ENDIF
+ ELSE
+ GO TO 110
+ ENDIF
+ IREM = INT(MDR)
+ GO TO 150
+ ENDIF
+
+ 110 MAS = MA(-1)
+ M01(-1) = 1
+ KL = M01(1)
+ IF (MA(1) <= M01(1)) THEN
+ IF (MA(1) == M01(1) .AND. ABS(MA(2)) <= M01(2)) THEN
+ DO J = 2, KL+1
+ IF (MA(J) /= M01(J)) THEN
+ IF (MA(J) < M01(J)) KLTFLG = 1
+ GO TO 120
+ ENDIF
+ ENDDO
+ KLTFLG = 2
+ ENDIF
+ 120 IF (MA(1) < M01(1) .OR. KLTFLG >= 1) THEN
+ IF (KLTFLG /= 2) THEN
+ CALL IMM2I(MA,IREM)
+ IREM = ABS(IREM)
+ CALL IMI2M(0,MB)
+ ELSE
+ CALL IMI2M(1,MB)
+ IREM = 0
+ ENDIF
+ GO TO 140
+ ENDIF
+ ENDIF
+ NDIG = INT(MA(1))
+ IF (NDIG < 2) NDIG = 2
+ N1 = INT(MA(1)) + 1
+
+! If ABS(IDIV) >= MXBASE use IMDIVR.
+
+ MVALP = ABS(IDIV)
+ NMVAL = INT(MVALP)
+ NV2 = NMVAL - 1
+ IF (ABS(IDIV) > MXBASE .OR. NMVAL /= ABS(IDIV) .OR. &
+ NV2 /= ABS(IDIV)-1) THEN
+ CALL IMI2M(IDIV,M03)
+ CALL IMDIVR(MA,M03,MB,M11)
+ CALL IMEQ(M11,M03)
+ CALL IMM2I(M03,IREM)
+ GO TO 150
+ ENDIF
+
+! Find the first significant digit of the quotient.
+
+ MKT = MA(2)
+ IF (MKT >= MVALP) THEN
+ KPT = 2
+ GO TO 130
+ ENDIF
+ DO J = 3, N1
+ MKT = MKT*MBASE + MA(J)
+ IF (MKT >= MVALP) THEN
+ KPT = J
+ GO TO 130
+ ENDIF
+ ENDDO
+
+ CALL IMM2I(MA,IREM)
+ CALL IMI2M(0,MB)
+ GO TO 150
+
+! Do the rest of the division.
+
+ 130 KA = KPT + 1
+ MWA(1) = MA(1) + 2 - KPT
+ MWA(2) = INT (MKT/MVALP)
+ MODINT = MKT - MWA(2)*MVALP
+ IF (KA <= N1) THEN
+ KL = 3 - KA
+
+! (Inner Loop)
+
+ DO J = KA, N1
+ MKT = MODINT*MBASE + MA(J)
+ MWA(KL+J) = INT (MKT/MVALP)
+ MODINT = MKT - MWA(KL+J)*MVALP
+ ENDDO
+ ENDIF
+
+ MB(0) = MA(0)
+ DO J = 1, INT(MWA(1))+1
+ MB(J) = MWA(J)
+ ENDDO
+ IREM = INT(MODINT)
+
+ 140 MB(-1) = 1
+ IF (MAS < 0 .AND. IDIV > 0) THEN
+ IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1
+ IREM = -IREM
+ ELSE IF (MAS > 0 .AND. IDIV < 0) THEN
+ IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -1
+ ELSE IF (MAS < 0 .AND. IDIV < 0) THEN
+ IREM = -IREM
+ ENDIF
+
+ 150 IF (MB(1) <= 1) MB(3) = 0
+ IF (NTRACE /= 0 .AND. NCALL <= LVLTRC) THEN
+ CALL IMNTR(1,MB,MB,1)
+ CALL IMNTRI(1,IREM,0)
+ ENDIF
+
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMDVIR
+
+ SUBROUTINE IMEQ(MA,MB)
+
+! MB = MA
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ INTEGER J,KDG
+
+ KDG = MAX(2,INT(MA(1))) + 1
+ IF (KDG > LUNPCK) KDG = 3
+ DO J = -1, KDG
+ MB(J) = MA(J)
+ ENDDO
+ RETURN
+ END SUBROUTINE IMEQ
+
+ SUBROUTINE IMFM2I(MA,MB)
+
+! MB = INT(MA)
+
+! Convert from real (FM) format to integer (IM) format.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ INTEGER J,NTRSAV
+
+ NCALL = NCALL + 1
+ KFLAG = 0
+ NTRSAV = NTRACE
+ NTRACE = 0
+ CALL FMEQ(MA,MB)
+ CALL FMINT(MB,M08)
+ CALL FMEQ(M08,MB)
+ IF (MB(1) > NDIGMX) THEN
+ IF (MB(1) <= NDG2MX .OR. NCALL <= 1) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMFM2I'
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MB)
+ ENDIF
+ ELSE
+ DO J = NDIG+2, INT(MA(1))+1
+ MB(J) = 0
+ ENDDO
+ ENDIF
+ IF (MB(1) <= 1) MB(3) = 0
+ NTRACE = NTRSAV
+ NCALL = NCALL - 1
+
+ RETURN
+ END SUBROUTINE IMFM2I
+
+ SUBROUTINE IMFORM(FORM,MA,STRING)
+
+! Convert an IM number (MA) to a character string base 10 (STRING)
+! using character string FORM format.
+
+! FORM can be one of these types: Iw, Fw.d, Ew.d, 1PEw.d
+! for positive integers w,d.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(*) :: FORM,STRING
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER NDSAVE
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMFORM',1,MA,MA)
+ KFLAG = 0
+ NAMEST(NCALL) = 'IMFORM'
+ NDSAVE = NDIG
+ NDIG = INT(MA(1))
+ IF (NDIG < 2 .OR. NDIG > NDG2MX) NDIG = 2
+
+ CALL FMFORM(FORM,MA,STRING)
+
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMFORM
+
+ SUBROUTINE IMFPRT(FORM,MA)
+
+! Print an IM number (MA) on unit KW using character
+! string FORM format.
+
+! FORM can be one of these types: Iw, Fw.d, Ew.d, 1PEw.d
+! for positive integers w,d.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(*) :: FORM
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER NDSAVE
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMFPRT',1,MA,MA)
+ KFLAG = 0
+ NAMEST(NCALL) = 'IMFPRT'
+ NDSAVE = NDIG
+ NDIG = INT(MA(1))
+ IF (NDIG < 2 .OR. NDIG > NDG2MX) NDIG = 2
+
+ CALL FMFPRT(FORM,MA)
+
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMFPRT
+
+ SUBROUTINE IMGCD(MA,MB,MC)
+
+! MC is returned as the greatest common divisor of MA and MB.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+ INTEGER NDSAVE
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMGCD ',2,MA,MB)
+ KFLAG = 0
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMGCD '
+ CALL IMNTR(2,MA,MB,2)
+ ENDIF
+
+! Check for special cases.
+
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
+ CALL IMST2M('UNKNOWN',MC)
+ KFLAG = -4
+ GO TO 120
+ ELSE IF (MB(2) == 0) THEN
+ CALL IMABS(MA,MC)
+ GO TO 120
+ ELSE IF (MA(2) == 0) THEN
+ CALL IMABS(MB,MC)
+ GO TO 120
+ ELSE IF (MB(1) == 1 .AND. ABS(MB(2)) == 1) THEN
+ CALL IMI2M(1,MC)
+ GO TO 120
+ ELSE IF (MA(1) == 1 .AND. ABS(MA(2)) == 1) THEN
+ CALL IMI2M(1,MC)
+ GO TO 120
+ ELSE IF (MA(1) >= NDG2MX .OR. MB(1) >= NDG2MX .OR. &
+ MA(1) < 0 .OR. MB(1) < 0) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMGCD '
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MC)
+ GO TO 120
+ ENDIF
+
+ CALL IMABS(MA,M05)
+ CALL IMABS(MB,M04)
+ CALL IMMAX(M05,M04,M03)
+ CALL IMMIN(M05,M04,M11)
+ CALL IMEQ(M11,M04)
+ 110 CALL IMDIVR(M03,M04,MC,M05)
+ IF (M05(2) /= 0) THEN
+ CALL IMEQ(M04,M03)
+ CALL IMEQ(M05,M04)
+ GO TO 110
+ ENDIF
+ CALL IMEQ(M04,MC)
+
+ IF (MC(1) == MUNKNO) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMGCD '
+ CALL FMWARN
+ ENDIF
+
+ 120 IF (MC(1) <= 1) MC(3) = 0
+ IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMGCD
+
+ SUBROUTINE IMI2FM(MA,MB)
+
+! MB = MA
+
+! Convert from integer (IM) format to real (FM) format.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ INTEGER KDG
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMI2FM',1,MA,MA)
+ KFLAG = 0
+ KDG = MAX(2,INT(MA(1)))
+ IF (KDG > NDG2MX) KDG = 2
+ CALL FMEQU(MA,MB,KDG,NDIG)
+ MB(0) = NINT(NDG2MX*ALOGM2)
+ NCALL = NCALL - 1
+
+ RETURN
+ END SUBROUTINE IMI2FM
+
+ SUBROUTINE IMI2M(IVAL,MA)
+
+! MA = IVAL
+
+! Convert a one word integer to IM format.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER IVAL
+
+ INTEGER NDSAVE
+
+ NCALL = NCALL + 1
+ KFLAG = 0
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMI2M '
+ CALL IMNTRI(2,IVAL,1)
+
+ NDIG = 4
+ CALL FMIM(IVAL,MA)
+ IF (MA(1) > 4) THEN
+ NDIG = NDIGMX
+ CALL FMIM(IVAL,MA)
+ ENDIF
+
+ CALL IMNTR(1,MA,MA,1)
+ ELSE
+ NDIG = 4
+ CALL FMIM(IVAL,MA)
+ IF (MA(1) > 4) THEN
+ NDIG = NDIGMX
+ CALL FMIM(IVAL,MA)
+ ENDIF
+ ENDIF
+ IF (MA(1) <= 1) MA(3) = 0
+ NDIG = NDSAVE
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE IMI2M
+
+ SUBROUTINE IMINP(LINE,MA,LA,LB)
+
+! Convert an array of characters to multiple precision integer format.
+
+! LINE is an A1 character array of length LB to be converted
+! to IM format and returned in MA.
+! LA is a pointer telling the routine where in the array to begin
+! the conversion.
+! LB is a pointer to the last character of the field for that number.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER KFSAVE,NDSAVE,LA,LB
+ CHARACTER LINE(LB)
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ NCALL = NCALL + 1
+ KFLAG = 0
+ NDSAVE = NDIG
+ NAMEST(NCALL) = 'IMINP '
+
+ NDIG = NDIGMX
+ CALL FMINP(LINE,MA,LA,LB)
+ KFSAVE = KFLAG
+ CALL FMINT(MA,M08)
+ CALL FMEQ(M08,MA)
+ KFLAG = KFSAVE
+
+ IF (MA(1) > NDG2MX .AND. MA(1) < MEXPOV) THEN
+ KFLAG = -9
+ NDIG = INT(MA(1))
+ CALL FMWARN
+ MA(-1) = 1
+ MA(0) = NINT(NDG2MX*ALOGM2)
+ MA(1) = MUNKNO
+ MA(2) = 1
+ MA(3) = 0
+ ENDIF
+
+ IF (MA(1) <= 1) MA(3) = 0
+ NDIG = NDSAVE
+ IF (NTRACE /= 0) CALL IMNTR(1,MA,MA,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE IMINP
+
+ SUBROUTINE IMM2DP(MA,X)
+
+! X = MA
+
+! Convert an IM number to double precision.
+
+! If KFLAG = -4 is returned for a value of MA that is in the range
+! of the machine's double precision number system, change the
+! definition of DPMAX in routine FMSET to reflect the current machine's
+! range.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ DOUBLE PRECISION X
+
+ INTEGER KRESLT,NDSAVE
+
+ NCALL = NCALL + 1
+ KFLAG = 0
+ NAMEST(NCALL) = 'IMM2DP'
+ KRESLT = 0
+ IF (ABS(MA(1)) > MEXPAB) THEN
+ CALL FMARGS('IMM2DP',1,MA,MA,KRESLT)
+ ENDIF
+ IF (NTRACE /= 0) CALL IMNTR(2,MA,MA,1)
+ IF (KRESLT /= 0) THEN
+
+! Here no valid result can be returned. Set X to some
+! value that the user is likely to recognize as wrong.
+
+ X = DBLE(RUNKNO)
+ KFLAG = -4
+ IF (MA(1) /= MUNKNO) CALL FMWARN
+ IF (NTRACE /= 0) CALL IMNTRR(1,X,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ NDSAVE = NDIG
+ NDIG = MAX(2,INT(MA(1)))
+ IF (NDIG > NDG2MX) NDIG = 2
+ CALL FMMD(MA,X)
+
+ IF (NTRACE /= 0) CALL IMNTRR(1,X,1)
+ NDIG = NDSAVE
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE IMM2DP
+
+ SUBROUTINE IMM2I(MA,IVAL)
+
+! IVAL = MA
+
+! Convert an IM number to a one word integer.
+
+! KFLAG = 0 is returned if the conversion is exact.
+! = -4 is returned if MA is larger than INTMAX in magnitude.
+! IVAL = IUNKNO is returned as an indication that IVAL
+! could not be computed without integer overflow.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ INTEGER IVAL,NDSAVE
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMM2I ',1,MA,MA)
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMM2I '
+ CALL IMNTR(2,MA,MA,1)
+ ENDIF
+
+ NDIG = INT(MA(1))
+ IF (NDIG < 2) NDIG = 2
+ IF (NDIG > NDG2MX) NDIG = 2
+ KFLAG = 0
+ CALL FMM2I(MA,IVAL)
+
+ IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN
+ CALL IMNTRI(1,IVAL,1)
+ ENDIF
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMM2I
+
+ SUBROUTINE IMMAX(MA,MB,MC)
+
+! MC = MAX(MA,MB)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ INTEGER KWRNSV
+ LOGICAL IMCOMP
+
+ KFLAG = 0
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMMAX ',2,MA,MB)
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMMAX '
+ CALL IMNTR(2,MA,MB,2)
+ ENDIF
+
+ KWRNSV = KWARN
+ KWARN = 0
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
+ CALL IMST2M('UNKNOWN',MC)
+ KFLAG = -4
+ ELSE IF (IMCOMP(MA,'LT',MB)) THEN
+ CALL IMEQ(MB,MC)
+ ELSE
+ CALL IMEQ(MA,MC)
+ ENDIF
+
+ IF (MC(1) <= 1) MC(3) = 0
+ KWARN = KWRNSV
+ IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE IMMAX
+
+ SUBROUTINE IMMIN(MA,MB,MC)
+
+! MC = MIN(MA,MB)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ INTEGER KWRNSV
+ LOGICAL IMCOMP
+
+ KFLAG = 0
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMMIN ',2,MA,MB)
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMMIN '
+ CALL IMNTR(2,MA,MB,2)
+ ENDIF
+
+ KWRNSV = KWARN
+ KWARN = 0
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
+ CALL IMST2M('UNKNOWN',MC)
+ KFLAG = -4
+ ELSE IF (IMCOMP(MA,'GT',MB)) THEN
+ CALL IMEQ(MB,MC)
+ ELSE
+ CALL IMEQ(MA,MC)
+ ENDIF
+
+ IF (MC(1) <= 1) MC(3) = 0
+ KWARN = KWRNSV
+ IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE IMMIN
+
+ SUBROUTINE IMMOD(MA,MB,MC)
+
+! MC = MOD(MA,MB)
+
+! Use IMDIVR if both INT(MA/MB) and MOD(MA,MB) are needed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+ INTEGER NDSAVE
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMMOD ',2,MA,MB)
+ KFLAG = 0
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMMOD '
+ CALL IMNTR(2,MA,MB,2)
+ ENDIF
+
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
+ CALL IMST2M('UNKNOWN',MC)
+ KFLAG = -4
+ GO TO 110
+ ENDIF
+
+ CALL IMDIVR(MA,MB,M03,MC)
+
+ IF (MC(1) == MUNKNO) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMMOD '
+ CALL FMWARN
+ ENDIF
+
+ 110 IF (MC(1) <= 1) MC(3) = 0
+ IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMMOD
+
+ SUBROUTINE IMMPY(MA,MB,MC)
+
+! MC = MA * MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MDAB
+ INTEGER KOVFL,NDSAVE
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMMPY ',2,MA,MB)
+ KFLAG = 0
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMMPY '
+ CALL IMNTR(2,MA,MB,2)
+ ENDIF
+
+ IF (MA(1) <= 1) THEN
+ IF (MB(1) > 1) GO TO 110
+ MDAB = MA(-1) * MA(2) * MB(-1) * MB(2)
+ IF (ABS(MDAB) < MBASE) THEN
+ MC(0) = MIN(MA(0),MB(0))
+ MC(1) = 1
+ IF (MDAB == 0) MC(1) = 0
+ IF (MDAB >= 0) THEN
+ MC(2) = MDAB
+ MC(-1) = 1
+ ELSE
+ MC(2) = -MDAB
+ MC(-1) = -1
+ ENDIF
+ MC(3) = 0
+ GO TO 120
+ ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
+ MC(0) = MIN(MA(0),MB(0))
+ MC(1) = 2
+ IF (MDAB >= 0) THEN
+ MC(2) = AINT (MDAB/MBASE)
+ MC(3) = ABS(MDAB - MBASE*MC(2))
+ MC(-1) = 1
+ ELSE
+ MC(2) = AINT (-MDAB/MBASE)
+ MC(3) = ABS(-MDAB - MBASE*MC(2))
+ MC(-1) = -1
+ ENDIF
+ GO TO 120
+ ENDIF
+ ENDIF
+
+! Check for special cases.
+
+ 110 KOVFL = 0
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
+ KFLAG = -4
+ CALL IMST2M('UNKNOWN',MC)
+ GO TO 130
+ ENDIF
+ IF (MA(2) == 0 .OR. MB(2) == 0) THEN
+ MC(-1) = 1
+ MC(0) = NINT(NDG2MX*ALOGM2)
+ MC(1) = 0
+ MC(2) = 0
+ MC(3) = 0
+ GO TO 130
+ ENDIF
+ IF (MA(1) == MEXPOV .OR. MB(1) == MEXPOV) THEN
+ KOVFL = 1
+ KFLAG = -5
+ IF (MA(-1)*MB(-1) < 0) THEN
+ CALL IMST2M('-OVERFLOW',MC)
+ ELSE
+ CALL IMST2M('OVERFLOW',MC)
+ ENDIF
+ GO TO 130
+ ENDIF
+ IF (MA(1) < 0 .OR. MB(1) < 0) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMMPY '
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MC)
+ GO TO 130
+ ENDIF
+ IF (MB(1) == 1 .AND. MB(2) == 1 .AND. MB(-1) == 1) THEN
+ CALL IMEQ(MA,MC)
+ GO TO 120
+ ELSE IF (MB(1) == 1 .AND. MB(2) == 1 .AND. MB(-1) == -1) THEN
+ CALL IMEQ(MA,MC)
+ IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
+ GO TO 120
+ ELSE IF (MA(1) == 1 .AND. MA(2) == 1 .AND. MA(-1) == 1) THEN
+ CALL IMEQ(MB,MC)
+ GO TO 120
+ ELSE IF (MA(1) == 1 .AND. MA(2) == 1 .AND. MA(-1) == -1) THEN
+ CALL IMEQ(MB,MC)
+ IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -MC(-1)
+ GO TO 120
+ ENDIF
+ NDIG = INT(MA(1) + MB(1))
+ IF (NDIG > NDIGMX) THEN
+ IF (NCALL == 1 .OR. NDIG > NDG2MX) THEN
+ IF (MA(-1)*MB(-1) > 0) THEN
+ CALL IMST2M('OVERFLOW',MC)
+ ELSE
+ CALL IMST2M('-OVERFLOW',MC)
+ ENDIF
+ KFLAG = -5
+ NAMEST(NCALL) = 'IMMPY '
+ CALL FMWARN
+ GO TO 130
+ ENDIF
+ ENDIF
+
+ IF (NDIG < 2) NDIG = 2
+ IF (NDIG > NDG2MX) NDIG = NDG2MX
+ CALL IMMPY2(MA,MB)
+
+! Transfer to MC and fix the sign of the result.
+
+ NDIG = MWA(1)
+ IF (NDIG < 2) NDIG = 2
+ IF (NDIG > NDG2MX) NDIG = NDG2MX
+ IF (MA(-1)*MB(-1) < 0) THEN
+ CALL FMMOVE(MWA,MC)
+ MC(0) = NINT(NDIGMX*ALOGM2)
+ MC(-1) = -1
+ ELSE
+ CALL FMMOVE(MWA,MC)
+ MC(0) = NINT(NDIGMX*ALOGM2)
+ MC(-1) = 1
+ ENDIF
+
+ IF (NDIG > NDIGMX) NDIG = 2
+ 120 IF (MC(1) > NDIGMX) THEN
+ IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN
+ IF (MC(-1) > 0) THEN
+ CALL IMST2M('OVERFLOW',MC)
+ ELSE
+ CALL IMST2M('-OVERFLOW',MC)
+ ENDIF
+ KFLAG = -5
+ NAMEST(NCALL) = 'IMMPY '
+ IF (KOVFL /= 1) CALL FMWARN
+ ENDIF
+ ENDIF
+
+ 130 IF (MC(1) <= 1) MC(3) = 0
+ IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMMPY
+
+ SUBROUTINE IMMPY2(MA,MB)
+
+! Internal multiplication of MA*MB. The result is returned in MWA.
+! Both MA and MB are positive.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MAXMWA,MBJ,MBM1,MKT,MMAX
+ INTEGER J,JM1,K,KB,KL,KLMA,KLMB,N1
+
+ N1 = NDIG + 1
+ MWA(1) = MA(1) + MB(1)
+ MWA(N1+1) = 0
+
+! The multiplication loop begins here.
+
+! MAXMWA is an upper bound on the size of values in MWA
+! divided by (MBASE-1). It is used to determine
+! whether to normalize before the next digit is
+! multiplied.
+
+ MBM1 = MBASE - 1
+ MMAX = INTMAX - MBASE
+ MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX)
+ MBJ = MB(2)
+ MWA(2) = 0
+ KLMA = INT(MA(1))
+ DO K = KLMA+3, N1
+ MWA(K) = 0
+ ENDDO
+
+! (Inner Loop)
+
+ DO K = 2, KLMA+1
+ MWA(K+1) = MA(K)*MBJ
+ ENDDO
+ MAXMWA = MBJ
+ KLMB = INT(MB(1))
+ DO J = 3, KLMB+1
+ MBJ = MB(J)
+ IF (MBJ /= 0) THEN
+ MAXMWA = MAXMWA + MBJ
+ JM1 = J - 1
+ KL = KLMA + 1
+
+! Major (Inner Loop)
+
+ DO K = J+1, J+KLMA
+ MWA(K) = MWA(K) + MA(K-JM1)*MBJ
+ ENDDO
+ ENDIF
+
+ IF (MAXMWA > MMAX) THEN
+ MAXMWA = 0
+
+! Here normalization is only required for the
+! range of digits currently changing in MWA.
+
+ DO KB = JM1+KL, JM1+2, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ ENDDO
+ ENDIF
+ ENDDO
+
+! Perform the final normalization. (Inner Loop)
+
+ DO KB = N1, 3, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ ENDDO
+
+ RETURN
+ END SUBROUTINE IMMPY2
+
+ SUBROUTINE IMMPYI(MA,IVAL,MB)
+
+! MB = MA * IVAL
+
+! Multiplication by a one word integer.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MAS,MCARRY,MDAB,MKT,MVAL
+ INTEGER IVAL,J,KA,KB,KC,KOVFL,KSHIFT,N1,NDSAVE,NMVAL, &
+ NTRSAV,NV2
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMMPYI',1,MA,MA)
+ KFLAG = 0
+ NDSAVE = NDIG
+ NTRSAV = NTRACE
+ NTRACE = 0
+ NTRACE = NTRSAV
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMMPYI'
+ CALL IMNTR(2,MA,MA,1)
+ CALL IMNTRI(2,IVAL,0)
+ ENDIF
+ MAS = MA(-1)
+
+ IF (MA(1) <= 1) THEN
+ MDAB = MA(-1) * MA(2) * IVAL
+ IF (ABS(MDAB) < MBASE) THEN
+ MB(0) = MA(0)
+ MB(1) = 1
+ IF (MDAB == 0) MB(1) = 0
+ MB(-1) = 1
+ IF (MDAB < 0) MB(-1) = -1
+ MB(2) = ABS(MDAB)
+ MB(3) = 0
+ GO TO 120
+ ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
+ MB(0) = MA(0)
+ MB(1) = 2
+ MB(-1) = 1
+ IF (MDAB < 0) MB(-1) = -1
+ MDAB = ABS(MDAB)
+ MB(2) = AINT (MDAB/MBASE)
+ MB(3) = MDAB - MBASE*MB(2)
+ GO TO 120
+ ENDIF
+ ENDIF
+
+! Check for special cases.
+
+ KOVFL = 0
+ IF (MA(1) == MEXPOV) KOVFL = 1
+ IF (MA(1) < 0) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMMPYI'
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MB)
+ GO TO 130
+ ENDIF
+ IF (MA(1) == MUNKNO) THEN
+ KFLAG = -4
+ CALL IMST2M('UNKNOWN',MB)
+ GO TO 130
+ ELSE IF (IVAL == 0) THEN
+ CALL IMI2M(0,MB)
+ GO TO 120
+ ELSE IF (IVAL == 1) THEN
+ CALL IMEQ(MA,MB)
+ GO TO 120
+ ELSE IF (IVAL == -1) THEN
+ CALL IMEQ(MA,MB)
+ IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
+ GO TO 120
+ ELSE IF (MA(1) == 1 .AND. MA(2)*MA(-1) == 1) THEN
+ CALL IMI2M(IVAL,MB)
+ GO TO 120
+ ELSE IF (MA(1) == 1 .AND. MA(2)*MA(-1) == -1) THEN
+ CALL IMI2M(IVAL,MB)
+ IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
+ GO TO 120
+ ELSE IF (MA(1) == MEXPOV) THEN
+ KFLAG = -5
+ CALL IMST2M('OVERFLOW',MB)
+ GO TO 110
+ ENDIF
+
+! Work with positive numbers.
+
+ MVAL = ABS(IVAL)
+ NMVAL = INT(MVAL)
+ NV2 = NMVAL - 1
+ NDIG = INT(MA(1))
+ N1 = NDIG + 1
+
+! To leave room for normalization, shift the product
+! to the right KSHIFT places in MWA.
+
+ KSHIFT = INT((LOG(DBLE(MA(2)+1)*DBLE(MVAL)))/DLOGMB)
+
+! If IVAL is too big, use IMMPY.
+
+ IF (KSHIFT > NDIG .OR. MVAL > MAXINT/MBASE .OR. &
+ NMVAL /= ABS(IVAL) .OR. NV2 /= ABS(IVAL)-1) THEN
+ CALL IMI2M(IVAL,M01)
+ CALL IMMPY(MA,M01,MB)
+ GO TO 120
+ ENDIF
+
+ MWA(1) = MA(1) + KSHIFT
+ KA = 2 + KSHIFT
+ KB = N1 + KSHIFT
+ KC = NDIG + 5
+ DO J = KB, KC
+ MWA(J) = 0
+ ENDDO
+
+ MCARRY = 0
+
+! This is the main multiplication loop.
+
+ DO J = KB, KA, -1
+ MKT = MA(J-KSHIFT)*MVAL + MCARRY
+ MCARRY = INT (MKT/MBASE)
+ MWA(J) = MKT - MCARRY*MBASE
+ ENDDO
+
+! Resolve the final carry.
+
+ DO J = KA-1, 2, -1
+ MKT = INT (MCARRY/MBASE)
+ MWA(J) = MCARRY - MKT*MBASE
+ MCARRY = MKT
+ ENDDO
+
+! Now the first significant digit in the product is in
+! MWA(2) or MWA(3).
+
+ MB(0) = MA(0)
+ IF (MWA(2) == 0) THEN
+ MB(1) = MWA(1) - 1
+ DO J = 3, KB
+ MB(J-1) = MWA(J)
+ ENDDO
+ ELSE
+ MB(1) = MWA(1)
+ DO J = 2, KB
+ MB(J) = MWA(J)
+ ENDDO
+ ENDIF
+
+! Put the sign on the result.
+
+ 110 MB(-1) = 1
+ IF ((IVAL > 0 .AND. MAS < 0) .OR. (IVAL < 0 .AND.MAS > 0)) &
+ MB(-1) = -1
+
+ 120 IF (MB(1) > NDIGMX) THEN
+ IF (NCALL == 1 .OR. MB(1) > NDG2MX) THEN
+ IF (MB(-1) > 0) THEN
+ CALL IMST2M('OVERFLOW',MB)
+ ELSE
+ CALL IMST2M('-OVERFLOW',MB)
+ ENDIF
+ KFLAG = -5
+ NAMEST(NCALL) = 'IMMPYI'
+ IF (KOVFL /= 1) CALL FMWARN
+ ENDIF
+ ENDIF
+
+ 130 IF (MB(1) <= 1) MB(3) = 0
+ IF (NTRACE /= 0) CALL IMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMMPYI
+
+ SUBROUTINE IMMPYM(MA,MB,MC,MD)
+
+! MD = MA * MB mod MC
+
+! This routine is slightly faster than calling IMMPY and IMMOD
+! separately, and it works for cases where IMMPY would return
+! OVERFLOW.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK), &
+ MD(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MAS,MAXMWA,MBM1,MBS,MC1,MCARRY, &
+ MDC,MDAB,MKT,MLMAX,MQD
+ DOUBLE PRECISION XB,XBASE,XBR,XMWA
+ INTEGER J,JB,JL,K,KA,KB,KL,KLTFLG,KPTMWA,N1,NA1,NC1,NDSAVE, &
+ NGUARD,NL,NMCWDS,NTRSAV
+ LOGICAL IMCOMP
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMMPYM',2,MA,MB)
+ NDSAVE = NDIG
+ KFLAG = 0
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMMPYM'
+ CALL IMNTR(2,MA,MB,2)
+ IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
+ IF (NTRACE < 0) THEN
+ NDIG = MAX(2,INT(MC(1)))
+ IF (NDIG > NDG2MX) NDIG = 2
+ NTRSAV = NTRACE
+ IF (NTRACE < -2) NTRACE = -2
+ CALL IMNTRJ(MC,NDIG)
+ NTRACE = NTRSAV
+ NDIG = NDSAVE
+ ELSE
+ CALL IMPRNT(MC)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF (MA(1) <= 1) THEN
+ IF (MB(1) > 1) GO TO 110
+ IF (MA(1) < 0 .OR. MB(1) < 0) GO TO 110
+ MDAB = MA(-1) * MA(2) * MB(-1) * MB(2)
+ IF (MC(1) <= 2) THEN
+ IF (MC(2) == 0) GO TO 110
+ IF (MC(1) <= 1) THEN
+ MDC = MC(-1) * MC(2)
+ ELSE
+ MDC = MC(-1) * (MC(2)*MBASE + MC(3))
+ ENDIF
+ MDAB = MOD(MDAB,MDC)
+ ENDIF
+ IF (ABS(MDAB) < MBASE) THEN
+ MD(0) = MIN(MA(0),MB(0),MC(0))
+ MD(1) = 1
+ IF (MDAB == 0) MD(1) = 0
+ MD(-1) = 1
+ IF (MDAB < 0) MD(-1) = -1
+ MD(2) = ABS(MDAB)
+ MD(3) = 0
+ GO TO 160
+ ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
+ MD(0) = MIN(MA(0),MB(0),MC(0))
+ MD(1) = 2
+ MD(-1) = 1
+ IF (MDAB < 0) MD(-1) = -1
+ MDAB = ABS(MDAB)
+ MD(2) = AINT (MDAB/MBASE)
+ MD(3) = MDAB - MBASE*MD(2)
+ GO TO 160
+ ENDIF
+ ENDIF
+
+! Check for special cases.
+
+ 110 IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR. MC(1) == MUNKNO) THEN
+ KFLAG = -4
+ CALL IMST2M('UNKNOWN',MD)
+ GO TO 170
+ ELSE IF (MC(2) == 0 .OR. MA(1) < 0 .OR. MB(1) < 0 .OR. MC(1) < 0) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMMPYM'
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MD)
+ GO TO 170
+ ELSE IF (MA(2) == 0 .OR. MB(2) == 0) THEN
+ CALL IMI2M(0,MD)
+ GO TO 170
+ ELSE IF (MC(1) == 1 .AND. MC(2) == 1) THEN
+ CALL IMI2M(0,MD)
+ GO TO 170
+ ELSE IF (MB(1) == 1 .AND. MB(2) == 1 .AND. MB(-1) == 1) THEN
+ CALL IMMOD(MA,MC,MD)
+ GO TO 160
+ ELSE IF (MB(1) == 1 .AND. MB(2) == 1 .AND. MB(-1) == -1) THEN
+ CALL IMMOD(MA,MC,MD)
+ IF (MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -MD(-1)
+ GO TO 160
+ ELSE IF (MA(1) == 1 .AND. MA(2) == 1 .AND. MA(-1) == 1) THEN
+ CALL IMMOD(MB,MC,MD)
+ GO TO 160
+ ELSE IF (MA(1) == 1 .AND. MA(2) == 1 .AND. MA(-1) == -1) THEN
+ CALL IMMOD(MB,MC,MD)
+ IF (MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -MD(-1)
+ GO TO 160
+ ELSE IF (MA(1) > NDG2MX .OR. MB(1) > NDG2MX .OR. &
+ MC(1) > NDG2MX) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMMPYM'
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MD)
+ GO TO 170
+ ENDIF
+
+ NDIG = INT(MA(1) + MB(1))
+ IF (NDIG < 2) NDIG = 2
+ IF (NDIG > LMWA) NDIG = LMWA
+
+! Save the sign of MA and MB and then work only with
+! positive numbers.
+
+ MAS = MA(-1)
+ MBS = MB(-1)
+
+ N1 = NDIG + 1
+
+! It is faster if the second argument is the one
+! with fewer digits.
+
+ IF (MA(1) < MB(1)) THEN
+ CALL IMMPY2(MB,MA)
+ ELSE
+ CALL IMMPY2(MA,MB)
+ ENDIF
+
+! Now do the division to find MWA mod MC.
+
+ KLTFLG = 0
+ IF (MWA(2) == 0) THEN
+ MWA(1) = MWA(1) - 1
+ ELSE
+ DO J = N1, 2, -1
+ MWA(J+1) = MWA(J)
+ ENDDO
+ MWA(2) = 0
+ ENDIF
+ KL = INT(MC(1))
+ IF (KL > LMWA) KL = 2
+ DO J = -1, KL+1
+ M01(J) = MC(J)
+ ENDDO
+ M01(-1) = 1
+ IF (MWA(1) == M01(1) .AND. ABS(MWA(3)) <= M01(2)) THEN
+ DO J = 4, N1+1
+ M02(J-1) = MWA(J)
+ ENDDO
+ M02(2) = ABS(MWA(3))
+ M02(1) = MWA(1)
+ IF (IMCOMP(M02,'EQ',M01)) THEN
+ KLTFLG = 2
+ ELSE IF (IMCOMP(M02,'LT',M01)) THEN
+ KLTFLG = 1
+ ENDIF
+ ENDIF
+ IF (MWA(1) < MC(1) .OR. KLTFLG >= 1) THEN
+ IF (KLTFLG /= 2) THEN
+ DO J = 3, N1+1
+ MD(J-1) = MWA(J)
+ ENDDO
+ MD(1) = MWA(1)
+ MD(0) = MIN(MA(0),MB(0),MC(0))
+ ELSE
+ CALL IMI2M(0,MD)
+ ENDIF
+ GO TO 150
+ ENDIF
+
+ NDIG = INT(MWA(1))
+ IF (NDIG < 2) NDIG = 2
+
+! NGUARD is the number of guard digits used.
+
+ NGUARD = 1
+ NA1 = INT(MWA(1)) + 1
+ NC1 = INT(MC(1)) + 1
+ MWA(1) = MWA(1) - MC(1) + 1
+ NL = NA1 + NGUARD + 3
+ DO J = NA1+2, NL
+ MWA(J) = 0
+ ENDDO
+
+! Work only with positive numbers.
+
+ MC1 = MC(1)
+
+! NMCWDS is the number of words of MC used to
+! compute the estimated quotient digit MQD.
+
+ NMCWDS = 4
+ IF (MBASE < 100) NMCWDS = 7
+
+! XB is an approximation of MC used in
+! estimating the quotient digits.
+
+ XBASE = DBLE(MBASE)
+ XB = 0
+ JL = NMCWDS
+ IF (JL <= NC1) THEN
+ DO J = 2, JL
+ XB = XB*XBASE + DBLE(MC(J))
+ ENDDO
+ ELSE
+ DO J = 2, JL
+ IF (J <= NC1) THEN
+ XB = XB*XBASE + DBLE(MC(J))
+ ELSE
+ XB = XB*XBASE
+ ENDIF
+ ENDDO
+ ENDIF
+ IF (JL+1 <= NC1) XB = XB + DBLE(MC(JL+1))/XBASE
+ XBR = 1.0D0/XB
+
+! MLMAX determines when to normalize all of MWA.
+
+ MBM1 = MBASE - 1
+ MLMAX = MAXINT/MBM1
+ MKT = INTMAX - MBASE
+ MLMAX = MIN(MLMAX,MKT)
+
+! MAXMWA is an upper bound on the size of values in MWA
+! divided by MBASE-1. It is used to determine whether
+! normalization can be postponed.
+
+ MAXMWA = 0
+
+! KPTMWA points to the next digit in the quotient.
+
+ KPTMWA = 2
+
+! This is the start of the division loop.
+
+! XMWA is an approximation of the active part of MWA
+! used in estimating quotient digits.
+
+ 120 KL = KPTMWA + NMCWDS - 1
+ IF (KL <= NL) THEN
+ XMWA = ((DBLE(MWA(KPTMWA))*XBASE &
+ + DBLE(MWA(KPTMWA+1)))*XBASE &
+ + DBLE(MWA(KPTMWA+2)))*XBASE &
+ + DBLE(MWA(KPTMWA+3))
+ DO J = KPTMWA+4, KL
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ ENDDO
+ ELSE
+ XMWA = DBLE(MWA(KPTMWA))
+ DO J = KPTMWA+1, KL
+ IF (J <= NL) THEN
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ ELSE
+ XMWA = XMWA*XBASE
+ ENDIF
+ ENDDO
+ ENDIF
+
+! MQD is the estimated quotient digit.
+
+ MQD = AINT(XMWA*XBR)
+ IF (MQD < 0) MQD = MQD - 1
+
+ IF (MQD > 0) THEN
+ MAXMWA = MAXMWA + MQD
+ ELSE
+ MAXMWA = MAXMWA - MQD
+ ENDIF
+
+! See if MWA must be normalized.
+
+ KA = KPTMWA + 1
+ KB = KA + INT(MC1) - 1
+ IF (MAXMWA >= MLMAX) THEN
+ DO J = KB, KA, -1
+ IF (MWA(J) < 0) THEN
+ MCARRY = INT((-MWA(J)-1)/MBASE) + 1
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ELSE IF (MWA(J) >= MBASE) THEN
+ MCARRY = -INT(MWA(J)/MBASE)
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ENDIF
+ ENDDO
+ XMWA = 0
+ IF (KL <= NL) THEN
+ DO J = KPTMWA, KL
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ ENDDO
+ ELSE
+ DO J = KPTMWA, KL
+ IF (J <= NL) THEN
+ XMWA = XMWA*XBASE + DBLE(MWA(J))
+ ELSE
+ XMWA = XMWA*XBASE
+ ENDIF
+ ENDDO
+ ENDIF
+ MQD = AINT(XMWA*XBR)
+ IF (MQD < 0) MQD = MQD - 1
+ IF (MQD > 0) THEN
+ MAXMWA = MQD
+ ELSE
+ MAXMWA = -MQD
+ ENDIF
+ ENDIF
+
+! Subtract MQD*MC from MWA.
+
+ JB = KA - 2
+ IF (MQD /= 0) THEN
+
+! Major (Inner Loop)
+
+ DO J = KA, KB
+ MWA(J) = MWA(J) - MQD*MC(J-JB)
+ ENDDO
+ ENDIF
+
+ MWA(KA) = MWA(KA) + MWA(KA-1)*MBASE
+ MWA(KPTMWA) = MQD
+
+ KPTMWA = KPTMWA + 1
+ IF (KPTMWA-2 < MWA(1)) GO TO 120
+
+! Final normalization.
+
+ KPTMWA = KPTMWA - 1
+ DO J = KPTMWA, 3, -1
+ IF (MWA(J) < 0) THEN
+ MCARRY = INT((-MWA(J)-1)/MBASE) + 1
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ELSE IF (MWA(J) >= MBASE) THEN
+ MCARRY = -INT(MWA(J)/MBASE)
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ENDIF
+ ENDDO
+
+ 130 DO J = KPTMWA+INT(MC1), KPTMWA+2, -1
+ IF (MWA(J) < 0) THEN
+ MCARRY = INT((-MWA(J)-1)/MBASE) + 1
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ELSE IF (MWA(J) >= MBASE) THEN
+ MCARRY = -INT(MWA(J)/MBASE)
+ MWA(J) = MWA(J) + MCARRY*MBASE
+ MWA(J-1) = MWA(J-1) - MCARRY
+ ENDIF
+ ENDDO
+
+! Due to rounding, the remainder may not be between
+! 0 and ABS(MC) here. Correct if necessary.
+
+ IF (MWA(KA) < 0) THEN
+ DO J = KA, KB
+ MWA(J) = MWA(J) + MC(J-JB)
+ ENDDO
+ GO TO 130
+ ELSE IF (MWA(KA) >= MBASE) THEN
+ DO J = KA, KB
+ MWA(J) = MWA(J) - MC(J-JB)
+ ENDDO
+ GO TO 130
+ ENDIF
+
+ IF (MWA(KPTMWA+1) /= 0) THEN
+ DO J = 1, INT(MC1)
+ MD(J+1) = MWA(KPTMWA+J)
+ ENDDO
+ MD(1) = MC1
+ ELSE
+ DO J = 1, INT(MC1)
+ IF (MWA(KPTMWA+J) /= 0) THEN
+ DO K = J, INT(MC1)
+ MD(K-J+2) = MWA(KPTMWA+K)
+ ENDDO
+ MD(1) = MC1 + 1 - J
+ GO TO 140
+ ENDIF
+ ENDDO
+ MD(1) = 0
+ MD(2) = 0
+ ENDIF
+ 140 IF (MD(1) <= 1) MD(3) = 0
+ MD(0) = MIN(MA(0),MB(0),MC(0))
+
+ IF (MD(1) > M01(1) .OR. &
+ (MD(1) == M01(1) .AND. ABS(MD(2)) >= M01(2))) THEN
+ MD(-1) = 1
+ IF (IMCOMP(MD,'GE',M01)) THEN
+ CALL IMSUB(MD,M01,M10)
+ CALL IMEQ(M10,MD)
+ ENDIF
+ ENDIF
+
+ 150 MD(-1) = 1
+ IF (MAS*MBS < 0) THEN
+ IF (MD(1) /= MUNKNO .AND. MD(2) /= 0) MD(-1) = -MD(-1)
+ ENDIF
+
+ IF (NDIG > NDIGMX) NDIG = 2
+ 160 IF (MD(1) == MUNKNO) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMMPYM'
+ CALL FMWARN
+ ENDIF
+
+ 170 IF (MD(1) <= 1) MD(3) = 0
+ IF (NTRACE /= 0) CALL IMNTR(1,MD,MD,1)
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMMPYM
+
+ SUBROUTINE IMNTR(NTR,MA,MB,NARG)
+
+! Print IM numbers in base 10 format.
+! This is used for trace output from the IM routines.
+
+! NTR = 1 if a result of an IM call is to be printed.
+! = 2 to print input argument(s) to an IM call.
+
+! MA - the IM number to be printed.
+
+! MB - an optional second IM number to be printed.
+
+! NARG - the number of arguments. NARG = 1 if only MA is to be
+! printed, and NARG = 2 if both MA and MB are to be printed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER NARG,NDSAVE,NTR,NTRSAV
+ CHARACTER(6) :: NAME
+
+ IF (NTRACE == 0) RETURN
+ IF (NCALL > LVLTRC) RETURN
+ IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN
+
+ IF (NTR == 2) THEN
+ NAME = NAMEST(NCALL)
+ WRITE (KW,"(' Input to ',A6)") NAME
+ ELSE
+ NAME = NAMEST(NCALL)
+ IF (KFLAG == 0) THEN
+ WRITE (KW, &
+ "(' ',A6,15X,'Call level =',I2,5X,'MBASE ='," // &
+ "I10)" &
+ ) NAME,NCALL,INT(MBASE)
+ ELSE
+ WRITE (KW, &
+ "(' ',A6,6X,'Call level =',I2,4X,'MBASE ='," // &
+ "I10,4X,'KFLAG =',I3)" &
+ ) NAME,NCALL,INT(MBASE),KFLAG
+ ENDIF
+ ENDIF
+
+ NDSAVE = NDIG
+ IF (NTRACE < 0) THEN
+ NDIG = MAX(2,INT(MA(1)))
+ IF (NDIG > NDG2MX) NDIG = 2
+ NTRSAV = NTRACE
+ IF (NTRACE < -2) NTRACE = -2
+ CALL IMNTRJ(MA,NDIG)
+ IF (NARG == 2) THEN
+ NDIG = MAX(2,INT(MB(1)))
+ IF (NDIG > NDG2MX) NDIG = 2
+ CALL IMNTRJ(MB,NDIG)
+ ENDIF
+ NTRACE = NTRSAV
+ ENDIF
+
+ IF (NTRACE > 0) THEN
+ CALL IMPRNT(MA)
+ IF (NARG == 2) CALL IMPRNT(MB)
+ ENDIF
+
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMNTR
+
+ SUBROUTINE IMNTRI(NTR,N,KNAM)
+
+! Internal routine for trace output of integer variables.
+
+! NTR = 1 for output values
+! 2 for input values
+
+! N Integer to be printed.
+
+! KNAM is positive if the routine name is to be printed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER NTR,N,KNAM
+
+ CHARACTER(6) :: NAME
+
+ IF (NTRACE == 0) RETURN
+ IF (NCALL > LVLTRC) RETURN
+ IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN
+
+ IF (NTR == 2 .AND. KNAM > 0) THEN
+ NAME = NAMEST(NCALL)
+ WRITE (KW,"(' Input to ',A6)") NAME
+ ENDIF
+ IF (NTR == 1 .AND. KNAM > 0) THEN
+ NAME = NAMEST(NCALL)
+ IF (KFLAG == 0) THEN
+ WRITE (KW,"(' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10)") &
+ NAME,NCALL,INT(MBASE)
+ ELSE
+ WRITE (KW, &
+ "(' ',A6,6X,'Call level =',I2,4X,'MBASE ='," // &
+ "I10,4X,'KFLAG =',I3)" &
+ ) NAME,NCALL,INT(MBASE),KFLAG
+ ENDIF
+ ENDIF
+
+ WRITE (KW,"(1X,I18)") N
+
+ RETURN
+ END SUBROUTINE IMNTRI
+
+ SUBROUTINE IMNTRJ(MA,ND)
+
+! Print trace output in internal base MBASE format. The number to
+! be printed is in MA.
+
+! ND is the number of base MBASE digits to be printed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER ND
+
+ CHARACTER(50) :: FORM
+ INTEGER J,L,N,N1
+
+ N1 = ND + 1
+
+ L = INT(LOG10(DBLE(MBASE-1))) + 2
+ N = (KSWIDE-23)/L
+ IF (N > 10) N = 5*(N/5)
+ IF (ND <= N) THEN
+ WRITE (FORM,"(' (1X,I19,I',I2,',',I3,'I',I2,') ')") L+2, N-1, L
+ ELSE
+ WRITE (FORM, &
+ "(' (1X,I19,I',I2,',',I3,'I',I2,'/(22X,',I3,'I',I2,')) ')" &
+ ) L+2, N-1, L, N, L
+ ENDIF
+ IF (INT(MA(1)) >= 2) THEN
+ WRITE (KW,FORM) INT(MA(1)),INT(MA(-1)*MA(2)),(INT(MA(J)),J=3,N1)
+ ELSE
+ WRITE (KW,FORM) INT(MA(1)),INT(MA(-1)*MA(2)),(0,J=3,N1)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE IMNTRJ
+
+ SUBROUTINE IMNTRR(NTR,X,KNAM)
+
+! Internal routine for trace output of real variables.
+
+! NTR - 1 for output values
+! 2 for input values
+
+! X - Double precision value to be printed if NX == 1
+
+! KNAM - Positive if the routine name is to be printed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER NTR,KNAM
+ DOUBLE PRECISION X
+
+ CHARACTER(6) :: NAME
+
+ IF (NTRACE == 0) RETURN
+ IF (NCALL > LVLTRC) RETURN
+ IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN
+
+ IF (NTR == 2 .AND. KNAM > 0) THEN
+ NAME = NAMEST(NCALL)
+ WRITE (KW,"(' Input to ',A6)") NAME
+ ENDIF
+ IF (NTR == 1 .AND. KNAM > 0) THEN
+ NAME = NAMEST(NCALL)
+ IF (KFLAG == 0) THEN
+ WRITE (KW,"(' ',A6,15X,'Call level =',I2,5X,'MBASE =',I10)") &
+ NAME,NCALL,INT(MBASE)
+ ELSE
+ WRITE (KW, &
+ "(' ',A6,6X,'Call level =',I2,4X,'MBASE ='," // &
+ "I10,4X,'KFLAG =',I3)" &
+ ) NAME,NCALL,INT(MBASE),KFLAG
+ ENDIF
+ ENDIF
+
+ WRITE (KW,"(1X,D30.20)") X
+
+ RETURN
+ END SUBROUTINE IMNTRR
+
+ SUBROUTINE IMOUT(MA,LINE,LB)
+
+! Convert an integer multiple precision number to a character array
+! for output.
+
+! MA is an IM number to be converted to an A1 character
+! array in base 10 format
+! LINE is the CHARACTER*1 array in which the result is returned.
+! LB is the length of LINE.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER JF1SAV,JF2SAV,LB,NDSAVE
+ CHARACTER LINE(LB)
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMOUT ',1,MA,MA)
+ KFLAG = 0
+ NDSAVE = NDIG
+ NAMEST(NCALL) = 'IMOUT '
+
+ NDSAVE = NDIG
+ JF1SAV = JFORM1
+ JF2SAV = JFORM2
+ JFORM1 = 2
+ JFORM2 = 0
+ NDIG = MAX(2,INT(MA(1)))
+ IF (NDIG > NDG2MX) NDIG = 2
+ CALL FMOUT(MA,LINE,LB)
+
+ NDIG = NDSAVE
+ JFORM1 = JF1SAV
+ JFORM2 = JF2SAV
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE IMOUT
+
+ SUBROUTINE IMPACK(MA,MP)
+
+! MA is packed two base NDIG digits per word and returned in MP.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MP(-1:LPACK)
+
+ INTEGER J,KP,KMA1
+
+ KMA1 = INT(MA(1))
+ IF (KMA1 <= 2 .OR. KMA1 > NDG2MX) KMA1 = 2
+ KP = 2
+ MP(0) = MA(0)
+ MP(1) = MA(1)
+ MP(2) = ABS(MA(2))*MBASE + MA(3)
+ MP(-1) = 1
+ IF (MA(-1) < 0) MP(-1) = -1
+ IF (KMA1 >= 4) THEN
+ DO J = 4, KMA1, 2
+ KP = KP + 1
+ MP(KP) = MA(J)*MBASE + MA(J+1)
+ ENDDO
+ ENDIF
+ IF (MOD(KMA1,2) == 1) MP(KP+1) = MA(KMA1+1)*MBASE
+ RETURN
+ END SUBROUTINE IMPACK
+
+ SUBROUTINE IMPMOD(MA,MB,MC,MD)
+
+! MD = MOD(MA**MB,MC)
+
+! The binary multiplication method used requires an average of
+! 1.5 * LOG2(MB) operations.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK), &
+ MD(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MBS
+ INTEGER IREM,KWRNSV,NDSAVE,NTRSAV
+
+ KFLAG = 0
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMPMOD',2,MA,MB)
+ IF (KDEBUG == 1) CALL IMARGS('IMPMOD',1,MC,MC)
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMPMOD'
+ CALL IMNTR(2,MA,MB,2)
+ IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
+ IF (NTRACE < 0) THEN
+ NDIG = MAX(2,INT(MC(1)))
+ IF (NDIG > NDG2MX) NDIG = 2
+ NTRSAV = NTRACE
+ IF (NTRACE < -2) NTRACE = -2
+ CALL IMNTRJ(MC,NDIG)
+ NTRACE = NTRSAV
+ NDIG = NDSAVE
+ ELSE
+ CALL IMPRNT(MC)
+ ENDIF
+ ENDIF
+ ENDIF
+ MBS = MB(-1)
+ MACCA = MA(0)
+ MACCB = MB(0)
+
+! Check for special cases.
+
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR. MC(1) == MUNKNO .OR. &
+ MA(1) == MEXPOV .OR. MB(1) == MEXPOV .OR. MC(1) == MEXPOV .OR. &
+ MA(1) < 0 .OR. MB(1) < 0 .OR. MC(1) < 0 .OR. &
+ (MB(-1)*MB(2) <= 0 .AND. MA(2) == 0) .OR. MC(2) == 0) THEN
+ KFLAG = -4
+ IF (MA(1) /= MUNKNO .AND. MB(1) /= MUNKNO .AND. MC(1) /= MUNKNO) THEN
+ NAMEST(NCALL) = 'IMPMOD'
+ CALL FMWARN
+ ENDIF
+ CALL IMST2M('UNKNOWN',MD)
+ IF (NTRACE /= 0) CALL IMNTR(1,MD,MD,1)
+ NDIG = NDSAVE
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ IF (MB(2) == 0) THEN
+ CALL IMI2M(1,MD)
+ IF (NTRACE /= 0) CALL IMNTR(1,MD,MD,1)
+ NDIG = NDSAVE
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ IF (MB(1) == 1 .AND. ABS(MB(2)) == 1) THEN
+ KWRNSV = KWARN
+ KWARN = 0
+ IF (MB(-1) == 1) THEN
+ CALL IMMOD(MA,MC,MD)
+ ELSE
+ CALL IMI2M(1,M05)
+ CALL IMDIVR(M05,MA,M04,M06)
+ CALL IMMOD(M04,MC,MD)
+ ENDIF
+ IF (NTRACE /= 0) CALL IMNTR(1,MD,MD,1)
+ NDIG = NDSAVE
+ NCALL = NCALL - 1
+ KWARN = KWRNSV
+ RETURN
+ ENDIF
+
+ IF (MA(2) == 0) THEN
+ CALL IMI2M(0,MD)
+ IF (NTRACE /= 0) CALL IMNTR(1,MD,MD,1)
+ NDIG = NDSAVE
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+! Initialize.
+
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL IMABS(MB,M06)
+ CALL IMDIVR(MA,MC,M04,M05)
+ CALL IMEQ(MC,M04)
+ CALL IMDVIR(M06,2,MD,IREM)
+ IF (IREM == 0) THEN
+ CALL IMI2M(1,MD)
+ ELSE
+ CALL IMEQ(M05,MD)
+ ENDIF
+ CALL IMDVIR(M06,2,M11,IREM)
+ CALL IMEQ(M11,M06)
+
+! This is the multiplication loop.
+
+ 110 CALL IMDVIR(M06,2,M11,IREM)
+ CALL IMEQ(M11,M06)
+ CALL IMMPYM(M05,M05,M04,M13)
+ CALL IMEQ(M13,M05)
+ IF (IREM == 1) THEN
+ CALL IMMPYM(M05,MD,M04,M13)
+ CALL IMEQ(M13,MD)
+ ENDIF
+ IF (M06(2) > 0 .AND. MD(2) /= 0) GO TO 110
+
+ IF (MBS < 0) THEN
+ CALL IMI2M(1,M05)
+ CALL IMDIVR(M05,MD,M11,M06)
+ CALL IMEQ(M11,MD)
+ ENDIF
+ KWARN = KWRNSV
+ MD(0) = MIN(MACCA,MACCB)
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'IMPMOD'
+ CALL FMWARN
+ ENDIF
+ IF (MD(1) <= 1) MD(3) = 0
+ IF (NTRACE /= 0) CALL IMNTR(1,MD,MD,1)
+ NDIG = NDSAVE
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE IMPMOD
+
+ SUBROUTINE IMPRNT(MA)
+
+! Print MA in base 10 format.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ INTEGER JF1SAV,JF2SAV,NDSAVE
+
+ NDSAVE = NDIG
+ JF1SAV = JFORM1
+ JF2SAV = JFORM2
+ JFORM1 = 2
+ JFORM2 = 0
+ NDIG = MAX(2,INT(MA(1)))
+ IF (NDIG > NDG2MX) NDIG = 2
+ CALL FMPRNT(MA)
+ JFORM1 = JF1SAV
+ JFORM2 = JF2SAV
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMPRNT
+
+ SUBROUTINE IMPWR(MA,MB,MC)
+
+! MC = MA ** MB
+
+! The binary multiplication method used requires an average of
+! 1.5 * LOG2(MB) multiplications.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MAS,MBS
+ INTEGER IREM,IREMB,JSIGN,KWRNSV
+
+ KFLAG = 0
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMPWR ',2,MA,MB)
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMPWR '
+ CALL IMNTR(2,MA,MB,2)
+ ENDIF
+ MAS = MA(-1)
+ MBS = MB(-1)
+ MACCA = MA(0)
+ MACCB = MB(0)
+ KWRNSV = KWARN
+
+! Check for special cases.
+
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO .OR. MA(1) < 0 .OR. &
+ MB(1) < 0 .OR. ((MB(-1) < 0 .OR. MB(2) == 0) .AND. MA(2) == 0)) THEN
+ KFLAG = -4
+ IF (MA(1) /= MUNKNO .AND. MB(1) /= MUNKNO) THEN
+ KWARN = KWRNSV
+ NAMEST(NCALL) = 'IMPWR '
+ CALL FMWARN
+ ENDIF
+ CALL IMST2M('UNKNOWN',MC)
+ GO TO 130
+ ENDIF
+
+ IF (MB(2) == 0) THEN
+ CALL IMI2M(1,MC)
+ GO TO 130
+ ENDIF
+
+ IF (MA(1) == 1 .AND. MA(2) == 1) THEN
+ KWARN = 0
+ IF (MAS == 1) THEN
+ CALL IMI2M(1,MC)
+ ELSE
+ CALL IMI2M(2,M05)
+ CALL IMDIVR(MB,M05,M11,M06)
+ CALL IMEQ(M11,M05)
+ IF (M06(1) == MUNKNO) THEN
+ KFLAG = -4
+ KWARN = KWRNSV
+ NAMEST(NCALL) = 'IMPWR '
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MC)
+ ELSE IF (M06(2) == 0) THEN
+ CALL IMI2M(1,MC)
+ ELSE
+ CALL IMI2M(-1,MC)
+ ENDIF
+ ENDIF
+ GO TO 130
+ ENDIF
+
+ IF (MB(1) == 1 .AND. MB(2) == 1) THEN
+ KWARN = 0
+ IF (MBS == 1) THEN
+ CALL IMEQ(MA,MC)
+ ELSE
+ CALL IMI2M(1,M05)
+ CALL IMDIVR(M05,MA,MC,M06)
+ ENDIF
+ GO TO 130
+ ENDIF
+
+ IF (MA(2) == 0) THEN
+ CALL IMI2M(0,MC)
+ GO TO 130
+ ENDIF
+
+ IF (MB(1) == MEXPOV) THEN
+ IF (MBS < 0) THEN
+ CALL IMI2M(0,MC)
+ ELSE IF (MAS > 0) THEN
+ CALL IMST2M('OVERFLOW',MC)
+ KFLAG = -5
+ ELSE
+ KFLAG = -4
+ KWARN = KWRNSV
+ NAMEST(NCALL) = 'IMPWR '
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MC)
+ ENDIF
+ GO TO 130
+ ENDIF
+
+ IF (MA(1) == MEXPOV) THEN
+ JSIGN = 1
+ IF (MA(-1) < 0) JSIGN = -1
+ IF (MBS > 0) THEN
+ CALL IMDVIR(MB,2,MC,IREM)
+ CALL IMST2M('OVERFLOW',MC)
+ MC(-1) = JSIGN**IREM
+ KFLAG = -5
+ ELSE
+ CALL IMI2M(0,MC)
+ ENDIF
+ GO TO 130
+ ENDIF
+
+! Initialize.
+
+ KWARN = 0
+ CALL IMABS(MB,M06)
+
+ CALL IMEQ(MA,M05)
+
+ CALL IMDVIR(MB,2,MC,IREMB)
+ IF (IREMB == 0) THEN
+ CALL IMI2M(1,MC)
+ ELSE
+ CALL IMEQ(M05,MC)
+ ENDIF
+ CALL IMDVIR(M06,2,M11,IREM)
+ CALL IMEQ(M11,M06)
+
+! This is the multiplication loop.
+
+ 110 CALL IMDVIR(M06,2,M11,IREM)
+ CALL IMEQ(M11,M06)
+ CALL IMSQR(M05,M12)
+ CALL IMEQ(M12,M05)
+ IF (IREM == 1) THEN
+ CALL IMMPY(M05,MC,M10)
+ CALL IMEQ(M10,MC)
+ ENDIF
+ IF (M05(1) == MEXPOV) THEN
+ CALL IMEQ(M05,MC)
+ IF (MAS < 0 .AND. IREMB == 1) MC(-1) = -1
+ GO TO 120
+ ENDIF
+ IF (M06(2) > 0) GO TO 110
+
+ 120 IF (MBS < 0) THEN
+ CALL IMI2M(1,M05)
+ CALL IMDIVR(M05,MC,M11,M06)
+ CALL IMEQ(M11,MC)
+ ENDIF
+
+ MC(0) = MIN(MACCA,MACCB)
+ IF (MC(1) > NDIGMX) THEN
+ IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN
+ IF (MC(-1) > 0) THEN
+ CALL IMST2M('OVERFLOW',MC)
+ ELSE
+ CALL IMST2M('-OVERFLOW',MC)
+ ENDIF
+ KFLAG = -5
+ KWARN = KWRNSV
+ NAMEST(NCALL) = 'IMPWR '
+ CALL FMWARN
+ ENDIF
+ ENDIF
+
+ 130 IF (MC(1) <= 1) MC(3) = 0
+ KWARN = KWRNSV
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMPWR '
+ CALL IMNTR(1,MC,MC,1)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE IMPWR
+
+ SUBROUTINE IMREAD(KREAD,MA)
+
+! Read MA on unit KREAD. Multi-line numbers will have '&' as the
+! last nonblank character on all but the last line. Only one
+! number is allowed on the line(s).
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER KREAD
+
+ INTEGER NDSAVE,KWRNSV
+
+ NCALL = NCALL + 1
+ NDSAVE = NDIG
+ NDIG = NDIGMX
+ CALL FMREAD(KREAD,M02)
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMNINT(M02,MA)
+ IF (MA(1) <= 1) MA(3) = 0
+ KWARN = KWRNSV
+ NDIG = NDSAVE
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE IMREAD
+
+ SUBROUTINE IMSIGN(MA,MB,MC)
+
+! MC = SIGN(MA,MB)
+
+! MC is set to ABS(MA) if MB is positive or zero,
+! or -ABS(MA) if MB is negative.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ INTEGER KWRNSV,NDSAVE
+
+ KFLAG = 0
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMSIGN',2,MA,MB)
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMSIGN'
+ CALL IMNTR(2,MA,MB,2)
+ ENDIF
+
+ NDIG = INT(MA(1))
+ IF (NDIG < 2) NDIG = 2
+ IF (NDIG > NDG2MX) NDIG = 2
+ KWRNSV = KWARN
+ KWARN = 0
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
+ CALL IMST2M('UNKNOWN',MC)
+ KFLAG = -4
+ ELSE IF (MA(1) < 0 .OR. MB(1) < 0) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMSIGN'
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MC)
+ ELSE IF (MB(-1) >= 0) THEN
+ CALL IMEQ(MA,MC)
+ MC(-1) = 1
+ ELSE
+ CALL IMEQ(MA,MC)
+ IF (MC(1) /= MUNKNO .AND. MC(2) /= 0) MC(-1) = -1
+ ENDIF
+
+ IF (MC(1) <= 1) MC(3) = 0
+ KWARN = KWRNSV
+ IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMSIGN
+
+ SUBROUTINE IMSQR(MA,MB)
+
+! MB = MA * MA
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MDAB
+ INTEGER KOVFL,NDSAVE
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMSQR ',1,MA,MA)
+ KFLAG = 0
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMSQR '
+ CALL IMNTR(2,MA,MA,1)
+ ENDIF
+
+ IF (MA(1) <= 1) THEN
+ IF (MA(1) < 0) GO TO 110
+ MDAB = MA(2) * MA(2)
+ IF (ABS(MDAB) < MBASE) THEN
+ MB(0) = MA(0)
+ MB(1) = 1
+ IF (MDAB == 0) MB(1) = 0
+ MB(2) = MDAB
+ MB(3) = 0
+ GO TO 120
+ ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
+ MB(0) = MA(0)
+ MB(1) = 2
+ MB(2) = AINT (MDAB/MBASE)
+ MB(3) = MDAB - MBASE*MB(2)
+ GO TO 120
+ ENDIF
+ ENDIF
+
+! Check for special cases.
+
+ 110 KOVFL = 0
+ IF (MA(1) == MUNKNO) THEN
+ KFLAG = -4
+ CALL IMST2M('UNKNOWN',MB)
+ GO TO 130
+ ENDIF
+ IF (MA(2) == 0) THEN
+ MB(-1) = 1
+ MB(0) = NINT(NDG2MX*ALOGM2)
+ MB(1) = 0
+ MB(2) = 0
+ MB(3) = 0
+ GO TO 130
+ ENDIF
+ IF (MA(1) == MEXPOV) THEN
+ KOVFL = 1
+ KFLAG = -5
+ CALL IMST2M('OVERFLOW',MB)
+ GO TO 130
+ ENDIF
+ IF (MA(1) == 1 .AND. ABS(MA(2)) == 1) THEN
+ CALL IMI2M(1,MB)
+ GO TO 120
+ ELSE IF (MA(1) < 0) THEN
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMSQR '
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MB)
+ GO TO 130
+ ENDIF
+
+ NDIG = INT(MA(1) + MA(1))
+ IF (NDIG > NDIGMX) THEN
+ IF (NCALL == 1 .OR. NDIG > NDG2MX) THEN
+ CALL IMST2M('OVERFLOW',MB)
+ KFLAG = -5
+ NAMEST(NCALL) = 'IMSQR '
+ CALL FMWARN
+ GO TO 130
+ ENDIF
+ ENDIF
+
+ IF (NDIG < 2) NDIG = 2
+ IF (NDIG > NDG2MX) NDIG = NDG2MX
+
+ CALL IMSQR2(MA,MB)
+
+ IF (NDIG > NDIGMX) NDIG = 2
+ 120 IF (MB(1) > NDIGMX) THEN
+ IF (NCALL == 1 .OR. MB(1) > NDG2MX) THEN
+ IF (MB(-1) > 0) THEN
+ CALL IMST2M('OVERFLOW',MB)
+ ELSE
+ CALL IMST2M('-OVERFLOW',MB)
+ ENDIF
+ KFLAG = -5
+ NAMEST(NCALL) = 'IMSQR '
+ IF (KOVFL /= 1) CALL FMWARN
+ ENDIF
+ ENDIF
+
+ 130 IF (MB(1) <= 1) MB(3) = 0
+ MB(-1) = 1
+ IF (NTRACE /= 0) CALL IMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMSQR
+
+ SUBROUTINE IMSQR2(MA,MB)
+
+! MB = MA*MA.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MAXMAX,MAXMWA,MBJ,MBKJ,MBM1, &
+ MBNORM,MK,MKA,MKT,MMAX,MT
+ INTEGER J,JM1,K,KB,KI,KJ,KL,KNZ,KOVUN,KWA, &
+ L,N1
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > NDG2MX/2 .OR. KDEBUG == 1 .OR. &
+ MBASE*MBASE <= MXBASE/(4*MBASE)) THEN
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ IF (MA(1) == MUNKNO) KOVUN = 2
+ NCALL = NCALL + 1
+ CALL IMMPY(MA,MA,MB)
+ NCALL = NCALL - 1
+ IF ((KFLAG < 0 .AND. KOVUN == 0) .OR. &
+ (KFLAG == -4 .AND. KOVUN == 1)) THEN
+ NAMEST(NCALL) = 'IMSQR '
+ CALL FMWARN
+ ENDIF
+ GO TO 120
+ ELSE IF (MA(2) == 0) THEN
+ CALL IMEQ(MA,MB)
+ GO TO 120
+ ENDIF
+ KFLAG = 0
+ MAXMAX = 0
+
+ N1 = INT(MA(1)) + 1
+ MWA(1) = MA(1) + MA(1)
+
+ L = N1 + INT(MA(1))
+ MWA(L+1) = 0
+
+! The multiplication loop begins here.
+
+! MBNORM is the minimum number of digits that can be
+! multiplied before normalization is required.
+! MAXMWA is an upper bound on the size of values in MWA
+! divided by (MBASE-1). It is used to determine
+! whether to normalize before the next digit is
+! multiplied.
+
+ MBM1 = MBASE - 1
+ MBNORM = AINT (MAXINT/(MBM1*MBM1))
+ MMAX = INTMAX - MBASE
+ MMAX = MIN(AINT (MAXINT/MBM1 - MBM1),MMAX)
+ IF (MBNORM > 1) THEN
+ MBJ = MA(2)
+
+! Count the trailing zeros in MA.
+
+ IF (MA(N1) /= 0) THEN
+ KNZ = N1
+ ELSE
+ DO J = INT(MA(1)), 2, -1
+ IF (MA(J) /= 0) THEN
+ KNZ = J
+ GO TO 110
+ ENDIF
+ ENDDO
+ ENDIF
+
+ 110 MWA(2) = 0
+ MWA(3) = 0
+ DO K = N1+1, L
+ MWA(K) = 0
+ ENDDO
+
+! (Inner Loop)
+
+ DO K = 3, N1
+ MWA(K+1) = MA(K)*MBJ
+ ENDDO
+ MAXMWA = MBJ
+ DO J = 3, N1
+ MBJ = MA(J)
+ IF (MBJ /= 0) THEN
+ MAXMWA = MAXMWA + MBJ
+ JM1 = J - 1
+ KL = MIN(KNZ,L-JM1)
+
+! Major (Inner Loop)
+
+ DO K = 2*J, JM1+KL
+ MWA(K) = MWA(K) + MA(K-JM1)*MBJ
+ ENDDO
+ ENDIF
+
+ IF (MAXMWA > MMAX) THEN
+ MAXMAX = MAX(MAXMAX,MAXMWA)
+ MAXMWA = 0
+
+! Normalization is only required for the
+! range of digits currently changing in MWA.
+
+ DO KB = JM1+KL, 2*J, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ ENDDO
+ ENDIF
+ ENDDO
+
+! Double MWA, add the square terms, and perform
+! the final normalization. (Inner Loop)
+
+ IF (2*MAX(MAXMAX,MAXMWA)+MBASE > MMAX) THEN
+ DO KB = L, 4, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ ENDDO
+ ENDIF
+
+ DO J = 3, L-1, 2
+ IF ((J+1)/2 <= N1) THEN
+ MKA = MA((J+1)/2)
+ MWA(J) = 2*MWA(J) + MKA*MKA
+ MWA(J+1) = 2*MWA(J+1)
+ ELSE
+ MWA(J) = 2*MWA(J)
+ MWA(J+1) = 2*MWA(J+1)
+ ENDIF
+ ENDDO
+ IF (MOD(L,2) == 1) THEN
+ IF ((L+1)/2 <= N1) THEN
+ MKA = MA((L+1)/2)
+ MWA(L) = 2*MWA(L) + MKA*MKA
+ ELSE
+ MWA(L) = 2*MWA(L)
+ ENDIF
+ ENDIF
+
+ DO KB = L, 3, -1
+ MKT = INT (MWA(KB)/MBASE)
+ MWA(KB-1) = MWA(KB-1) + MKT
+ MWA(KB) = MWA(KB) - MKT*MBASE
+ ENDDO
+
+ ELSE
+
+! If normalization must be done for each digit, combine
+! the two loops and normalize as the digits are multiplied.
+
+ DO J = 2, L
+ MWA(J) = 0
+ ENDDO
+ KJ = NDIG + 2
+ DO J = 2, N1
+ KJ = KJ - 1
+ MBKJ = MA(KJ)
+ IF (MBKJ == 0) CYCLE
+ KL = L - KJ + 1
+ IF (KL > N1) KL = N1
+ KI = KL + 2
+ KWA = KL+ KJ + 1
+ MK = 0
+ DO K = 2, KL
+ MT = MA(KI-K)*MBKJ + MWA(KWA-K) + MK
+ MK = INT (MT/MBASE)
+ MWA(KWA-K) = MT - MBASE*MK
+ ENDDO
+ MWA(KWA-KL-1) = MK
+ ENDDO
+
+ ENDIF
+
+! The multiplication is complete.
+
+ NDIG = MWA(1)
+ IF (NDIG < 2) NDIG = 2
+ IF (NDIG > NDG2MX) NDIG = NDG2MX
+ CALL FMMOVE(MWA,MB)
+ MB(0) = NINT(NDIGMX*ALOGM2)
+
+ IF (KFLAG < 0) THEN
+ NAMEST(NCALL) = 'IMSQR '
+ CALL FMWARN
+ ENDIF
+
+ 120 MB(-1) = 1
+ RETURN
+ END SUBROUTINE IMSQR2
+
+ SUBROUTINE IMST2M(STRING,MA)
+
+! MA = STRING
+
+! Convert a character string to IM format.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(*) :: STRING
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ INTEGER J,LB,KFSAVE
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'IMST2M'
+ LB = MIN(LEN(STRING),LMBUFF)
+ KFSAVE = KFLAG
+
+ DO J = 1, LB
+ CMBUFF(J) = STRING(J:J)
+ ENDDO
+
+ CALL IMINP(CMBUFF,MA,1,LB)
+
+ IF (MA(1) <= 1) MA(3) = 0
+ IF (KFSAVE /= 0) KFLAG = KFSAVE
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE IMST2M
+
+ SUBROUTINE IMSUB(MA,MB,MC)
+
+! MC = MA - MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+
+ REAL (KIND(1.0D0)) :: MDA,MDAB,MDB
+ INTEGER NDSAVE
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMSUB ',2,MA,MB)
+ KFLAG = 0
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'IMSUB '
+ CALL IMNTR(2,MA,MB,2)
+ ENDIF
+
+ IF (MA(1) <= 2) THEN
+ IF (MB(1) > 2 .OR. MA(1) < 0 .OR. MB(1) < 0) GO TO 110
+ IF (MA(1) <= 1) THEN
+ MDA = MA(-1) * MA(2)
+ ELSE
+ MDA = MA(-1) * (MA(2)*MBASE + MA(3))
+ ENDIF
+ IF (MB(1) <= 1) THEN
+ MDB = MB(-1) * MB(2)
+ ELSE
+ MDB = MB(-1) * (MB(2)*MBASE + MB(3))
+ ENDIF
+ MDAB = MDA - MDB
+ IF (ABS(MDAB) < MBASE) THEN
+ MC(0) = MIN(MA(0),MB(0))
+ MC(1) = 1
+ IF (MDAB == 0) MC(1) = 0
+ MC(-1) = 1
+ IF (MDAB < 0) MC(-1) = -1
+ MC(2) = ABS(MDAB)
+ MC(3) = 0
+ IF (MDA == 0 .OR. MDB == 0) KFLAG = 1
+ GO TO 120
+ ELSE IF (ABS(MDAB) < MBASE*MBASE) THEN
+ MC(0) = MIN(MA(0),MB(0))
+ MC(1) = 2
+ MC(-1) = 1
+ IF (MDAB < 0) MC(-1) = -1
+ MDAB = ABS(MDAB)
+ MC(2) = AINT (MDAB/MBASE)
+ MC(3) = MDAB - MBASE*MC(2)
+ IF (MDA == 0 .OR. MDB == 0) KFLAG = 1
+ GO TO 120
+ ENDIF
+ ENDIF
+
+! Check for special cases.
+
+ 110 IF (MA(1) > NDG2MX .OR. MB(1) > NDG2MX .OR. &
+ MA(1) < 0 .OR. MB(1) < 0) THEN
+ IF (MA(1) == MUNKNO .OR. MB(1) == MUNKNO) THEN
+ CALL IMST2M('UNKNOWN',MC)
+ KFLAG = -4
+ GO TO 130
+ ENDIF
+ IF (MA(1) == MEXPOV) THEN
+ IF (MA(-1) == -MB(-1) .OR. MB(2) == 0) THEN
+ MC(-1) = MA(-1)
+ MC(0) = MA(0)
+ MC(1) = MA(1)
+ MC(2) = MA(2)
+ MC(3) = MA(3)
+ KFLAG = -5
+ GO TO 130
+ ELSE
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMSUB '
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MC)
+ GO TO 130
+ ENDIF
+ ENDIF
+ IF (MB(1) == MEXPOV) THEN
+ IF (-MB(-1) == MA(-1) .OR. MA(2) == 0) THEN
+ MC(-1) = -MB(-1)
+ MC(0) = MB(0)
+ MC(1) = MB(1)
+ MC(2) = MB(2)
+ MC(3) = MB(3)
+ KFLAG = -5
+ GO TO 130
+ ELSE
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMSUB '
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MC)
+ GO TO 130
+ ENDIF
+ ENDIF
+ KFLAG = -4
+ NAMEST(NCALL) = 'IMSUB '
+ CALL FMWARN
+ CALL IMST2M('UNKNOWN',MC)
+ GO TO 130
+ ENDIF
+
+! IMADD2 will negate MB and add.
+
+ KSUB = 1
+ CALL IMADD2(MA,MB,MC)
+ KSUB = 0
+
+ 120 IF (MC(1) > NDIGMX) THEN
+ IF (NCALL == 1 .OR. MC(1) > NDG2MX) THEN
+ IF (MC(-1) > 0) THEN
+ CALL IMST2M('OVERFLOW',MC)
+ ELSE
+ CALL IMST2M('-OVERFLOW',MC)
+ ENDIF
+ KFLAG = -5
+ NAMEST(NCALL) = 'IMSUB '
+ CALL FMWARN
+ ENDIF
+ ENDIF
+
+ 130 IF (MC(1) <= 1) MC(3) = 0
+ IF (NTRACE /= 0) CALL IMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ NDIG = NDSAVE
+ RETURN
+ END SUBROUTINE IMSUB
+
+ SUBROUTINE IMUNPK(MP,MA)
+
+! MP is unpacked and the value returned in MA.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MP(-1:LPACK)
+
+ INTEGER J,KP,KMA1
+
+ KMA1 = INT(MP(1))
+ IF (KMA1 <= 2 .OR. KMA1 > NDG2MX) KMA1 = 2
+ KP = 2
+ MA(0) = MP(0)
+ MA(1) = MP(1)
+ MA(2) = AINT (ABS(MP(2))/MBASE)
+ MA(3) = ABS(MP(2)) - MA(2)*MBASE
+ MA(-1) = 1
+ IF (MP(-1) < 0) MA(-1) = -1
+ IF (KMA1 >= 4) THEN
+ DO J = 4, KMA1, 2
+ KP = KP + 1
+ MA(J) = AINT (MP(KP)/MBASE)
+ MA(J+1) = MP(KP) - MA(J)*MBASE
+ ENDDO
+ ENDIF
+ IF (MOD(KMA1,2) == 1) MA(KMA1+1) = AINT (MP(KP+1)/MBASE)
+ RETURN
+ END SUBROUTINE IMUNPK
+
+ SUBROUTINE IMWRIT(KWRITE,MA)
+
+! Write MA on unit KWRITE. Multi-line numbers will have '&' as the
+! last nonblank character on all but the last line. These numbers can
+! then be read easily using IMREAD.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER KWRITE
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ INTEGER J,K,KSAVE,L,LAST,LB,ND,NDSAVE,NEXP
+
+ NCALL = NCALL + 1
+ IF (KDEBUG == 1) CALL IMARGS('IMWRIT',1,MA,MA)
+ NAMEST(NCALL) = 'IMWRIT'
+ NDSAVE = NDIG
+ NDIG = MAX(2,INT(MA(1)))
+ IF (NDIG > NDG2MX) NDIG = 2
+
+ KSAVE = KFLAG
+ ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
+ IF (ND < 2) ND = 2
+ NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
+ LB = MIN(ND+NEXP,LMBUFF)
+
+ CALL IMOUT(MA,CMBUFF,LB)
+
+ KFLAG = KSAVE
+ NDIG = NDSAVE
+ LAST = LB + 1
+ DO J = 1, LB
+ IF (CMBUFF(LAST-J) /= ' ' .OR. J == LB) THEN
+ L = LAST - J
+ IF (MOD(L,73) /= 0) THEN
+ WRITE (KWRITE,"(4X,73A1,' &')") (CMBUFF(K),K=1,L)
+ ELSE
+ IF (L > 73) WRITE (KWRITE,"(4X,73A1,' &')") &
+ (CMBUFF(K),K=1,L-73)
+ WRITE (KWRITE,"(4X,73A1)") (CMBUFF(K),K=L-72,L)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDDO
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE IMWRIT
+
+! These versions of the IM routines use packed IM numbers.
+
+
+ SUBROUTINE IPABS(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMABS(MPA,MPB)
+ CALL IMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE IPABS
+
+ SUBROUTINE IPADD(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMUNPK(MB,MPB)
+ CALL IMADD(MPA,MPB,MPC)
+ CALL IMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE IPADD
+
+ SUBROUTINE IPBIG(MA)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL IMBIG(MPB)
+ CALL IMPACK(MPB,MA)
+ RETURN
+ END SUBROUTINE IPBIG
+
+ FUNCTION IPCOMP(MA,LREL,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ LOGICAL IPCOMP,IMCOMP
+ CHARACTER(*) :: LREL
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMUNPK(MB,MPB)
+ IPCOMP = IMCOMP(MPA,LREL,MPB)
+ RETURN
+ END FUNCTION IPCOMP
+
+ SUBROUTINE IPDIM(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMUNPK(MB,MPB)
+ CALL IMDIM(MPA,MPB,MPC)
+ CALL IMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE IPDIM
+
+ SUBROUTINE IPDIV(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMUNPK(MB,MPB)
+ CALL IMDIV(MPA,MPB,MPC)
+ CALL IMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE IPDIV
+
+ SUBROUTINE IPDIVI(MA,IVAL,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ INTEGER IVAL
+ CALL IMUNPK(MA,MPA)
+ CALL IMDIVI(MPA,IVAL,MPB)
+ CALL IMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE IPDIVI
+
+ SUBROUTINE IPDIVR(MA,MB,MC,MD)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK), &
+ MD(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMUNPK(MB,MPB)
+ CALL IMDIVR(MPA,MPB,MPC,MPD)
+ CALL IMPACK(MPC,MC)
+ CALL IMPACK(MPD,MD)
+ RETURN
+ END SUBROUTINE IPDIVR
+
+ SUBROUTINE IPDVIR(MA,IVAL,MB,IREM)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ INTEGER IVAL,IREM
+ CALL IMUNPK(MA,MPA)
+ CALL IMDVIR(MPA,IVAL,MPB,IREM)
+ CALL IMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE IPDVIR
+
+ SUBROUTINE IPEQ(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMEQ(MPA,MPB)
+ CALL IMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE IPEQ
+
+ SUBROUTINE IPFM2I(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL IMFM2I(MPA,MPB)
+ CALL IMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE IPFM2I
+
+ SUBROUTINE IPFORM(FORM,MA,STRING)
+ USE FMVALS
+ IMPLICIT NONE
+ CHARACTER(*) :: FORM,STRING
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMFORM(FORM,MPA,STRING)
+ RETURN
+ END SUBROUTINE IPFORM
+
+ SUBROUTINE IPFPRT(FORM,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ CHARACTER(*) :: FORM
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMFPRT(FORM,MPA)
+ RETURN
+ END SUBROUTINE IPFPRT
+
+ SUBROUTINE IPGCD(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMUNPK(MB,MPB)
+ CALL IMGCD(MPA,MPB,MPC)
+ CALL IMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE IPGCD
+
+ SUBROUTINE IPI2FM(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMI2FM(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE IPI2FM
+
+ SUBROUTINE IPI2M(IVAL,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ INTEGER IVAL
+ CALL IMI2M(IVAL,MPA)
+ CALL IMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE IPI2M
+
+ SUBROUTINE IPINP(LINE,MA,LA,LB)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER LA,LB
+ CHARACTER LINE(LB)
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL IMINP(LINE,MPA,LA,LB)
+ CALL IMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE IPINP
+
+ SUBROUTINE IPM2DP(MA,DVAL)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ DOUBLE PRECISION DVAL
+ CALL IMUNPK(MA,MPA)
+ CALL IMM2DP(MPA,DVAL)
+ RETURN
+ END SUBROUTINE IPM2DP
+
+ SUBROUTINE IPM2I(MA,IVAL)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ INTEGER IVAL
+ CALL IMUNPK(MA,MPA)
+ CALL IMM2I(MPA,IVAL)
+ RETURN
+ END SUBROUTINE IPM2I
+
+ SUBROUTINE IPMAX(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMUNPK(MB,MPB)
+ CALL IMMAX(MPA,MPB,MPC)
+ CALL IMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE IPMAX
+
+ SUBROUTINE IPMIN(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMUNPK(MB,MPB)
+ CALL IMMIN(MPA,MPB,MPC)
+ CALL IMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE IPMIN
+
+ SUBROUTINE IPMOD(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMUNPK(MB,MPB)
+ CALL IMMOD(MPA,MPB,MPC)
+ CALL IMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE IPMOD
+
+ SUBROUTINE IPMPY(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMUNPK(MB,MPB)
+ CALL IMMPY(MPA,MPB,MPC)
+ CALL IMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE IPMPY
+
+ SUBROUTINE IPMPYI(MA,IVAL,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ INTEGER IVAL
+ CALL IMUNPK(MA,MPA)
+ CALL IMMPYI(MPA,IVAL,MPB)
+ CALL IMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE IPMPYI
+
+ SUBROUTINE IPMPYM(MA,MB,MC,MD)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK), &
+ MD(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMUNPK(MB,MPB)
+ CALL IMUNPK(MC,MPC)
+ CALL IMMPYM(MPA,MPB,MPC,MPD)
+ CALL IMPACK(MPD,MD)
+ RETURN
+ END SUBROUTINE IPMPYM
+
+ SUBROUTINE IPOUT(MA,LINE,LB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ INTEGER LB
+ CHARACTER LINE(LB)
+ CALL IMUNPK(MA,MPA)
+ CALL IMOUT(MPA,LINE,LB)
+ RETURN
+ END SUBROUTINE IPOUT
+
+ SUBROUTINE IPPMOD(MA,MB,MC,MD)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK), &
+ MD(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMUNPK(MB,MPB)
+ CALL IMUNPK(MC,MPC)
+ CALL IMPMOD(MPA,MPB,MPC,MPD)
+ CALL IMPACK(MPD,MD)
+ RETURN
+ END SUBROUTINE IPPMOD
+
+ SUBROUTINE IPPRNT(MA)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMPRNT(MPA)
+ RETURN
+ END SUBROUTINE IPPRNT
+
+ SUBROUTINE IPPWR(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMUNPK(MB,MPB)
+ CALL IMPWR(MPA,MPB,MPC)
+ CALL IMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE IPPWR
+
+ SUBROUTINE IPREAD(KREAD,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ INTEGER KREAD
+ CALL IMREAD(KREAD,MPA)
+ CALL IMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE IPREAD
+
+ SUBROUTINE IPSIGN(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMUNPK(MB,MPB)
+ CALL IMSIGN(MPA,MPB,MPC)
+ CALL IMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE IPSIGN
+
+ SUBROUTINE IPSQR(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMSQR(MPA,MPB)
+ CALL IMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE IPSQR
+
+ SUBROUTINE IPST2M(STRING,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ CHARACTER(*) :: STRING
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL IMST2M(STRING,MPA)
+ CALL IMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE IPST2M
+
+ SUBROUTINE IPSUB(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMUNPK(MB,MPB)
+ CALL IMSUB(MPA,MPB,MPC)
+ CALL IMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE IPSUB
+
+ SUBROUTINE IPWRIT(KWRITE,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER KWRITE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL IMUNPK(MA,MPA)
+ CALL IMWRIT(KWRITE,MPA)
+ RETURN
+ END SUBROUTINE IPWRIT
+
+! The ZM routines perform complex multiple-precision arithmetic.
+
+
+ SUBROUTINE ZMSET(NPREC)
+
+! Set precision to at least NPREC significant digits for using
+! ZM arithmetic.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER NPREC
+
+! Set JFORMZ to ' 1.23 + 4.56 i ' format.
+
+ JFORMZ = 1
+
+! Set JPRNTZ to print real and imaginary parts on one
+! line whenever possible.
+
+ JPRNTZ = 1
+
+! Use FMSET to initialize the other variables.
+
+ CALL FMSET(NPREC)
+
+ RETURN
+ END SUBROUTINE ZMSET
+
+ SUBROUTINE ZMABS(MA,MBFM)
+
+! MBFM = ABS(MA)
+
+! Complex absolute value. The result is a real FM number.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MBFM(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXEXP1,MXSAVE
+ INTEGER KASAVE,KOVUN,KRESLT,NDSAVE,NTRSAV
+
+ NTRSAV = NTRACE
+ IF (NTRACE /= 0) THEN
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMABS '
+ CALL ZMNTR(2,MA,MA,1)
+ NCALL = NCALL - 1
+ ENDIF
+ NTRACE = 0
+ CALL ZMENTR('ZMABS ',MA,MA,1,MZ01,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ NTRACE = NTRSAV
+ IF (KRESLT /= 0) THEN
+ CALL FMEQ(MZ01,MBFM)
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) CALL FMNTR(1,MBFM,MBFM,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KACCSW = 0
+ CALL ZMEQU(MA,MZ05,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ MXEXP1 = INT(MXEXP2/2.01D0)
+ IF (MA(2) == 0) THEN
+ CALL FMABS(MZ05(KPTIMU-1),MBFM)
+ GO TO 110
+ ELSE IF (MA(KPTIMU+2) == 0) THEN
+ CALL FMABS(MZ05,MBFM)
+ GO TO 110
+ ELSE IF (MA(1) == MEXPOV .OR. MA(KPTIMU+1) == MEXPOV) THEN
+ CALL FMI2M(1,MBFM)
+ MBFM(1) = MAX(MZ05(1),MZ05(KPTIMU+1))
+ GO TO 110
+ ELSE IF (MA(1) == MEXPUN) THEN
+ IF (MA(KPTIMU+1) > -MXEXP1+NDIG+1) THEN
+ CALL FMABS(MZ05(KPTIMU-1),MBFM)
+ ELSE
+ CALL FMST2M('UNKNOWN',MBFM)
+ KFLAG = -4
+ ENDIF
+ GO TO 110
+ ELSE IF (MA(KPTIMU+1) == MEXPUN) THEN
+ IF (MA(1) > -MXEXP1+NDIG+1) THEN
+ CALL FMABS(MZ05,MBFM)
+ ELSE
+ CALL FMST2M('UNKNOWN',MBFM)
+ KFLAG = -4
+ ENDIF
+ GO TO 110
+ ELSE IF (MA(1) /= MUNKNO .AND. MA(KPTIMU+1) /= MUNKNO) THEN
+ IF (MA(1) > MA(KPTIMU+1)+NDIG+1) THEN
+ CALL FMABS(MZ05,MBFM)
+ GO TO 110
+ ELSE IF (MA(KPTIMU+1) > MA(1)+NDIG+1) THEN
+ CALL FMABS(MZ05(KPTIMU-1),MBFM)
+ GO TO 110
+ ENDIF
+ ENDIF
+
+ CALL FMSQR(MZ05,M01)
+ CALL FMSQR(MZ05(KPTIMU-1),M02)
+ CALL FMADD(M01,M02,MBFM)
+ CALL FMSQRT_R1(MBFM)
+
+ 110 MACCMB = MBFM(0)
+ MBFM(0) = MIN(MACCMB,MARZ,MAIZ)
+ CALL ZMEXI2(MBFM,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE ZMABS
+
+ SUBROUTINE ZMACOS(MA,MB)
+
+! MB = ACOS(MA).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER J,KASAVE,KOVUN,KRESLT,NDSAVE
+
+ CALL ZMENTR('ZMACOS',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KACCSW = 0
+
+ CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ CALL FMPI(MZ01)
+ CALL FMDIVI_R1(MZ01,2)
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ GO TO 110
+ ELSE IF (MA(KPTIMU+2) == 0) THEN
+ CALL FMACOS(MZ07,MZ01)
+ IF (KFLAG == 0) THEN
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ GO TO 110
+ ENDIF
+ ENDIF
+ IF ((MA(2) == 0 .OR. MA(1)*2 <= -NDIG) .AND. &
+ (MA(KPTIMU+2) == 0 .OR. MA(KPTIMU+1)*2 <= -NDIG)) THEN
+ CALL FMPI(MZ01)
+ CALL FMDIVI_R1(MZ01,2)
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ CALL ZMSUB(MZ01,MZ07,MZ08)
+ CALL ZMEQ(MZ08,MZ01)
+ GO TO 110
+ ENDIF
+
+ CALL ZMI2M(1,MZ03)
+ CALL ZMSUB(MZ03,MZ07,MZ02)
+ CALL ZMADD(MZ03,MZ07,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ CALL ZMMPY(MZ02,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL ZMSQRT(MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ DO J = -1, NDIG+1
+ MZ03(J) = MZ02(KPTIMU+J)
+ MZ03(KPTIMU+J) = MZ02(J)
+ ENDDO
+ IF (MZ03(1) /= MUNKNO .AND. MZ03(2) /= 0) MZ03(-1) = -MZ03(-1)
+
+ IF ((MA(2) /= 0 .AND. MZ03(1) == MA(1) .AND. &
+ MZ03(-1)*MZ03(2) == MA(-1)*MA(2)) .OR. &
+ (MA(KPTIMU+2) /= 0 .AND. MZ03(KPTIMU+1) == MA(KPTIMU+1) .AND. &
+ MZ03(KPTIMU-1)*MZ03(KPTIMU+2) == MA(KPTIMU-1)*MA(KPTIMU+2)) ) THEN
+ CALL ZMADD(MZ07,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+
+ CALL FMSQR(MZ03,M04)
+ CALL FMSQR(MZ03(KPTIMU-1),M05)
+ CALL FMADD(M04,M05,M06)
+ CALL FMI2M(1,M03)
+ CALL FMSUB_R2(M06,M03)
+ IF (M03(1) < 0) THEN
+ NDIG = NDIG - INT(M03(1))
+ IF (NDIG > NDG2MX) THEN
+ NAMEST(NCALL) = 'ZMACOS'
+ KFLAG = -9
+ CALL ZMWARN
+ KRESLT = 12
+ NDIG = NDSAVE
+ CALL ZMRSLT(MB,KRESLT)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ MXEXP = MXSAVE
+ KACCSW = KASAVE
+ RETURN
+ ENDIF
+ CALL ZMEQ2_R1(MZ07,NDSAVE,NDIG)
+ CALL ZMI2M(1,MZ03)
+ CALL ZMSUB(MZ03,MZ07,MZ02)
+ CALL ZMADD(MZ03,MZ07,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ CALL ZMMPY(MZ02,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL ZMSQRT(MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ DO J = -1, NDIG+1
+ MZ03(J) = MZ02(KPTIMU+J)
+ MZ03(KPTIMU+J) = MZ02(J)
+ ENDDO
+ IF (MZ03(1) /= MUNKNO .AND. MZ03(2) /= 0) MZ03(-1) = -MZ03(-1)
+ CALL ZMADD(MZ07,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ ENDIF
+
+ CALL ZMLN(MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ DO J = -1, NDIG+1
+ MZ01(J) = MZ03(KPTIMU+J)
+ MZ01(KPTIMU+J) = MZ03(J)
+ ENDDO
+ IF (MZ01(KPTIMU+1) /= MUNKNO .AND. MZ01(KPTIMU+2) /= 0) &
+ MZ01(KPTIMU-1) = -MZ01(KPTIMU-1)
+ ELSE
+ CALL ZMSUB(MZ07,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+
+ CALL FMSQR(MZ03,M04)
+ CALL FMSQR(MZ03(KPTIMU-1),M05)
+ CALL FMADD(M04,M05,M06)
+ CALL FMI2M(1,M03)
+ CALL FMSUB_R2(M06,M03)
+ IF (M03(1) < 0) THEN
+ NDIG = NDIG - INT(M03(1))
+ IF (NDIG > NDG2MX) THEN
+ NAMEST(NCALL) = 'ZMACOS'
+ KFLAG = -9
+ CALL ZMWARN
+ KRESLT = 12
+ NDIG = NDSAVE
+ CALL ZMRSLT(MB,KRESLT)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ MXEXP = MXSAVE
+ KACCSW = KASAVE
+ RETURN
+ ENDIF
+ CALL ZMEQ2_R1(MZ07,NDSAVE,NDIG)
+ CALL ZMI2M(1,MZ03)
+ CALL ZMSUB(MZ03,MZ07,MZ02)
+ CALL ZMADD(MZ03,MZ07,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ CALL ZMMPY(MZ02,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL ZMSQRT(MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ DO J = -1, NDIG+1
+ MZ03(J) = MZ02(KPTIMU+J)
+ MZ03(KPTIMU+J) = MZ02(J)
+ ENDDO
+ IF (MZ03(1) /= MUNKNO .AND. MZ03(2) /= 0) MZ03(-1) = -MZ03(-1)
+ CALL ZMSUB(MZ07,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ ENDIF
+
+ CALL ZMLN(MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ DO J = -1, NDIG+1
+ MZ01(J) = MZ03(KPTIMU+J)
+ MZ01(KPTIMU+J) = MZ03(J)
+ ENDDO
+ IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
+ ENDIF
+
+ 110 MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE ZMACOS
+
+ SUBROUTINE ZMADD(MA,MB,MC)
+
+! MC = MA + MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ)
+
+ INTEGER KASAVE,KF1,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV
+ REAL (KIND(1.0D0)) :: MAR,MAI,MBR,MBI,MXSAVE
+
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR. &
+ ABS(MB(1)) > MEXPAB .OR. ABS(MB(KPTIMU+1)) > MEXPAB .OR. &
+ KDEBUG >= 1) THEN
+ CALL ZMENTR('ZMADD ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ NDIG = NDSAVE
+ MXEXP = MXSAVE
+ KACCSW = KASAVE
+ NTRSAV = NTRACE
+ NTRACE = 0
+ ELSE
+ NCALL = NCALL + 1
+ NTRSAV = NTRACE
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'ZMADD '
+ CALL ZMNTR(2,MA,MB,2)
+ NTRACE = 0
+ ENDIF
+ KOVUN = 0
+ ENDIF
+
+! Force FMADD to use more guard digits for user calls.
+
+ NCALL = NCALL - 1
+
+ KWRNSV = KWARN
+ KWARN = 0
+ MAR = MA(1)
+ IF (MA(2) == 0) MAR = MEXPUN - 1
+ MAI = MA(KPTIMU+1)
+ IF (MA(KPTIMU+2) == 0) MAI = MEXPUN - 1
+ MBR = MB(1)
+ IF (MB(2) == 0) MBR = MEXPUN - 1
+ MBI = MB(KPTIMU+1)
+ IF (MB(KPTIMU+2) == 0) MBI = MEXPUN - 1
+
+ CALL FMADD(MA,MB,MC)
+ KF1 = KFLAG
+ CALL FMADD(MA(KPTIMU-1),MB(KPTIMU-1),MC(KPTIMU-1))
+
+ NCALL = NCALL + 1
+ IF (NTRSAV /= 0) THEN
+ NTRACE = NTRSAV
+ NAMEST(NCALL) = 'ZMADD '
+ ENDIF
+ KWARN = KWRNSV
+ IF (KFLAG == 1) KFLAG = KF1
+ IF (KFLAG == 1) THEN
+ KFLAG = 0
+ IF (MAR <= MBR .AND. MAI <= MBI) KFLAG = 1
+ IF (MAR >= MBR .AND. MAI >= MBI) KFLAG = 1
+ ENDIF
+
+ IF (MC(1) == MUNKNO .OR. MC(KPTIMU+1) == MUNKNO) THEN
+ KFLAG = -4
+ ELSE IF (MC(1) == MEXPOV .OR. MC(KPTIMU+1) == MEXPOV) THEN
+ KFLAG = -5
+ ELSE IF (MC(1) == MEXPUN .OR. MC(KPTIMU+1) == MEXPUN) THEN
+ KFLAG = -6
+ ENDIF
+ IF ((MC(1) == MUNKNO) &
+ .OR. (MC(KPTIMU+1) == MUNKNO) &
+ .OR. (MC(1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MC(KPTIMU+1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MC(1) == MEXPOV .AND. KOVUN == 0) &
+ .OR. (MC(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
+ NAMEST(NCALL) = 'ZMADD '
+ CALL ZMWARN
+ ENDIF
+ IF (NTRACE /= 0) THEN
+ CALL ZMNTR(1,MC,MC,1)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMADD
+
+ SUBROUTINE ZMADDI(MA,INTEG)
+
+! MA = MA + INTEG Increment by one-word (real) integer.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
+ INTEGER INTEG
+
+ INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV
+ REAL (KIND(1.0D0)) :: MXSAVE
+
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR. &
+ KDEBUG >= 1) THEN
+ NTRSAV = NTRACE
+ IF (NTRACE /= 0) THEN
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMADDI'
+ CALL ZMNTR(2,MA,MA,1)
+ CALL FMNTRI(2,INTEG,0)
+ NCALL = NCALL - 1
+ ENDIF
+ NTRACE = 0
+ CALL ZMENTR('ZMADDI',MA,MA,1,MZ01,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ NTRACE = NTRSAV
+ IF (KRESLT /= 0) THEN
+ CALL FMEQ(MZ01,MA)
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) CALL ZMNTR(1,MA,MA,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ NDIG = NDSAVE
+ MXEXP = MXSAVE
+ KACCSW = KASAVE
+ NTRSAV = NTRACE
+ ELSE
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'ZMADDI'
+ CALL ZMNTR(2,MA,MA,1)
+ CALL FMNTRI(2,INTEG,0)
+ ENDIF
+ KOVUN = 0
+ ENDIF
+
+! Force FMADDI to use more guard digits for user calls.
+
+ NCALL = NCALL - 1
+ NTRSAV = NTRACE
+ NTRACE = 0
+ KWRNSV = KWARN
+ KWARN = 0
+
+ CALL FMADDI(MA,INTEG)
+
+ NTRACE = NTRSAV
+ KWARN = KWRNSV
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) NAMEST(NCALL) = 'ZMADDI'
+ IF (MA(1) == MUNKNO .OR. MA(KPTIMU+1) == MUNKNO) THEN
+ KFLAG = -4
+ ELSE IF (MA(1) == MEXPOV .OR. MA(KPTIMU+1) == MEXPOV) THEN
+ KFLAG = -5
+ ELSE IF (MA(1) == MEXPUN .OR. MA(KPTIMU+1) == MEXPUN) THEN
+ KFLAG = -6
+ ENDIF
+ IF ((MA(1) == MUNKNO) &
+ .OR. (MA(KPTIMU+1) == MUNKNO) &
+ .OR. (MA(1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MA(KPTIMU+1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MA(1) == MEXPOV .AND. KOVUN == 0) &
+ .OR. (MA(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
+ NAMEST(NCALL) = 'ZMADDI'
+ CALL ZMWARN
+ ENDIF
+ IF (NTRACE /= 0) CALL ZMNTR(1,MA,MA,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMADDI
+
+ SUBROUTINE ZMARG(MA,MBFM)
+
+! MBFM = ARG(MA)
+
+! Complex argument. The result is a real FM number.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MBFM(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MXSAVE
+ INTEGER KASAVE,KOVUN,KRESLT,NDSAVE,NTRSAV
+
+ NTRSAV = NTRACE
+ IF (NTRACE /= 0) THEN
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMARG '
+ CALL ZMNTR(2,MA,MA,1)
+ NCALL = NCALL - 1
+ ENDIF
+ NTRACE = 0
+ CALL ZMENTR('ZMARG ',MA,MA,1,MZ01,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ NTRACE = NTRSAV
+ IF (KRESLT /= 0) THEN
+ CALL FMEQ(MZ01,MBFM)
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) CALL FMNTR(1,MBFM,MBFM,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ KACCSW = 0
+ CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
+
+ CALL FMATN2(MZ07(KPTIMU-1),MZ07,MBFM)
+
+ CALL ZMEXI2(MBFM,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE ZMARG
+
+ SUBROUTINE ZMASIN(MA,MB)
+
+! MB = ASIN(MA).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER J,KASAVE,KOVUN,KRESLT,NDSAVE
+
+ CALL ZMENTR('ZMASIN',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KACCSW = 0
+
+ CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ CALL ZMI2M(0,MZ01)
+ GO TO 110
+ ELSE IF ((MA(2) == 0 .OR. MA(1)*2 <= -NDIG) .AND. &
+ (MA(KPTIMU+2) == 0 .OR. MA(KPTIMU+1)*2 <= -NDIG)) THEN
+ CALL ZMEQ(MZ07,MZ01)
+ GO TO 110
+ ELSE IF (MA(KPTIMU+2) == 0) THEN
+ CALL FMASIN(MZ07,MZ01)
+ IF (KFLAG == 0) THEN
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ GO TO 110
+ ENDIF
+ ENDIF
+
+ CALL ZMI2M(1,MZ03)
+ CALL ZMSUB(MZ03,MZ07,MZ02)
+ CALL ZMADD(MZ03,MZ07,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ CALL ZMMPY(MZ02,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL ZMSQRT(MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ DO J = -1, NDIG+1
+ MZ03(J) = MZ07(KPTIMU+J)
+ MZ03(KPTIMU+J) = MZ07(J)
+ ENDDO
+ IF (MZ03(1) /= MUNKNO .AND. MZ03(2) /= 0) MZ03(-1) = -MZ03(-1)
+
+ IF ((MZ02(2) /= 0 .AND. MZ03(1) == MZ02(1) .AND. &
+ MZ03(-1)*MZ03(2) == MZ02(-1)*MZ02(2)) .OR. &
+ (MZ02(KPTIMU+2) /= 0 .AND. MZ03(KPTIMU+1) == MZ02(KPTIMU+1) .AND. &
+ MZ03(KPTIMU-1)*MZ03(KPTIMU+2) == &
+ MZ02(KPTIMU-1)*MZ02(KPTIMU+2)) ) THEN
+ CALL ZMADD(MZ02,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ CALL FMSQR(MZ03,M04)
+ CALL FMSQR(MZ03(KPTIMU-1),M05)
+ CALL FMADD(M04,M05,M06)
+ CALL FMI2M(1,M03)
+ CALL FMSUB_R2(M06,M03)
+ IF (M03(1) < 0) THEN
+ NDIG = NDIG - INT(M03(1))
+ IF (NDIG > NDG2MX) THEN
+ NAMEST(NCALL) = 'ZMASIN'
+ KFLAG = -9
+ CALL ZMWARN
+ KRESLT = 12
+ NDIG = NDSAVE
+ CALL ZMRSLT(MB,KRESLT)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ MXEXP = MXSAVE
+ KACCSW = KASAVE
+ RETURN
+ ENDIF
+ CALL ZMEQ2_R1(MZ07,NDSAVE,NDIG)
+ CALL ZMI2M(1,MZ03)
+ CALL ZMSUB(MZ03,MZ07,MZ02)
+ CALL ZMADD(MZ03,MZ07,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ CALL ZMMPY(MZ02,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL ZMSQRT(MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ DO J = -1, NDIG+1
+ MZ03(J) = MZ07(KPTIMU+J)
+ MZ03(KPTIMU+J) = MZ07(J)
+ ENDDO
+ IF (MZ03(1) /= MUNKNO .AND. MZ03(2) /= 0) MZ03(-1) = -MZ03(-1)
+ CALL ZMADD(MZ02,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ ENDIF
+
+ CALL ZMLN(MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ DO J = -1, NDIG+1
+ MZ01(J) = MZ03(KPTIMU+J)
+ MZ01(KPTIMU+J) = MZ03(J)
+ ENDDO
+ IF (MZ01(KPTIMU+1) /= MUNKNO .AND. MZ01(KPTIMU+2) /= 0) &
+ MZ01(KPTIMU-1) = -MZ01(KPTIMU-1)
+ ELSE
+ CALL ZMSUB(MZ02,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+
+ CALL FMSQR(MZ03,M04)
+ CALL FMSQR(MZ03(KPTIMU-1),M05)
+ CALL FMADD(M04,M05,M06)
+ CALL FMI2M(1,M03)
+ CALL FMSUB_R2(M06,M03)
+ IF (M03(1) < 0) THEN
+ NDIG = NDIG - INT(M03(1))
+ IF (NDIG > NDG2MX) THEN
+ NAMEST(NCALL) = 'ZMASIN'
+ KFLAG = -9
+ CALL ZMWARN
+ KRESLT = 12
+ NDIG = NDSAVE
+ CALL ZMRSLT(MB,KRESLT)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ MXEXP = MXSAVE
+ KACCSW = KASAVE
+ RETURN
+ ENDIF
+ CALL ZMEQ2_R1(MZ07,NDSAVE,NDIG)
+ CALL ZMI2M(1,MZ03)
+ CALL ZMSUB(MZ03,MZ07,MZ02)
+ CALL ZMADD(MZ03,MZ07,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ CALL ZMMPY(MZ02,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL ZMSQRT(MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ DO J = -1, NDIG+1
+ MZ03(J) = MZ07(KPTIMU+J)
+ MZ03(KPTIMU+J) = MZ07(J)
+ ENDDO
+ IF (MZ03(1) /= MUNKNO .AND. MZ03(2) /= 0) MZ03(-1) = -MZ03(-1)
+ CALL ZMSUB(MZ02,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ ENDIF
+ CALL ZMLN(MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ DO J = -1, NDIG+1
+ MZ01(J) = MZ03(KPTIMU+J)
+ MZ01(KPTIMU+J) = MZ03(J)
+ ENDDO
+ IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
+ ENDIF
+
+ 110 MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE ZMASIN
+
+ SUBROUTINE ZMATAN(MA,MB)
+
+! MB = ATAN(MA).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER J,JTERM,KASAVE,KOVUN,KRESLT,NDSAVE
+ LOGICAL FMCOMP
+ REAL X
+
+ CALL ZMENTR('ZMATAN',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KACCSW = 0
+
+ CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ CALL ZMI2M(0,MZ04)
+ GO TO 120
+ ELSE IF ((MA(2) == 0 .OR. MA(1)*2 <= -NDIG) .AND. &
+ (MA(KPTIMU+2) == 0 .OR. MA(KPTIMU+1)*2 <= -NDIG)) THEN
+ CALL ZMEQ(MZ07,MZ04)
+ GO TO 120
+ ELSE IF (MA(KPTIMU+2) == 0) THEN
+ CALL FMATAN(MZ07,MZ04)
+ IF (KFLAG == 0) THEN
+ CALL FMI2M(0,MZ04(KPTIMU-1))
+ GO TO 120
+ ENDIF
+ ENDIF
+
+ X = 1.0E+5
+ CALL FMDPM(DBLE(X),M02)
+ CALL FMABS(MZ07,M03)
+ CALL FMABS(MZ07(KPTIMU-1),M04)
+ CALL FMADD_R2(M03,M04)
+
+ IF (FMCOMP(M04,'GE',M02)) THEN
+ CALL ZMI2M(0,MZ04)
+ CALL FMPI(MZ04)
+ CALL FMDIVI_R1(MZ04,2)
+ IF (MA(-1) < 0 .AND. MZ04(1) /= MUNKNO .AND. MZ04(2) /= 0) &
+ MZ04(-1) = -MZ04(-1)
+ CALL ZMI2M(1,MZ02)
+ CALL ZMDIV(MZ02,MZ07,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL ZMEQ(MZ02,MZ03)
+ CALL ZMSUB(MZ04,MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ04)
+ IF (MA(1) > NDIG .OR. MA(KPTIMU+1) > NDIG) GO TO 120
+ CALL ZMSQR(MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ JTERM = 1
+ 110 CALL ZMMPY(MZ03,MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ JTERM = JTERM + 2
+ CALL FMEQ(MZ03,M05)
+ CALL FMEQ(MZ03(KPTIMU-1),M06)
+ CALL ZMDIVI(MZ03,JTERM,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ CALL ZMADD(MZ04,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ04)
+ IF (KFLAG /= 0) GO TO 120
+ CALL FMEQ(M05,MZ03)
+ CALL FMEQ(M06,MZ03(KPTIMU-1))
+ CALL ZMMPY(MZ03,MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ JTERM = JTERM + 2
+ CALL FMEQ(MZ03,M05)
+ CALL FMEQ(MZ03(KPTIMU-1),M06)
+ CALL ZMDIVI(MZ03,JTERM,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ CALL ZMSUB(MZ04,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ04)
+ IF (KFLAG /= 0) GO TO 120
+ CALL FMEQ(M05,MZ03)
+ CALL FMEQ(M06,MZ03(KPTIMU-1))
+ GO TO 110
+ ELSE
+ CALL ZM2I2M(0,1,MZ02)
+ CALL ZMSUB(MZ02,MZ07,MZ03)
+ CALL ZMADD(MZ02,MZ07,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL ZMDIV(MZ02,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+
+ CALL FMSQR(MZ03,M04)
+ CALL FMSQR(MZ03(KPTIMU-1),M05)
+ CALL FMADD(M04,M05,M06)
+ CALL FMI2M(1,M03)
+ CALL FMSUB_R2(M06,M03)
+ IF (M03(1) < 0) THEN
+ NDIG = NDIG - INT(M03(1))
+ IF (NDIG > NDG2MX) THEN
+ NAMEST(NCALL) = 'ZMATAN'
+ KFLAG = -9
+ CALL ZMWARN
+ KRESLT = 12
+ NDIG = NDSAVE
+ CALL ZMRSLT(MB,KRESLT)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ MXEXP = MXSAVE
+ KACCSW = KASAVE
+ RETURN
+ ENDIF
+ CALL ZMEQ2_R1(MZ07,NDSAVE,NDIG)
+ CALL ZM2I2M(0,1,MZ02)
+ CALL ZMSUB(MZ02,MZ07,MZ03)
+ CALL ZMADD(MZ02,MZ07,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL ZMDIV(MZ02,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ ENDIF
+
+ CALL ZMLN(MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ CALL ZMDIVI(MZ03,2,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ DO J = -1, NDIG+1
+ MZ04(J) = MZ03(KPTIMU+J)
+ MZ04(KPTIMU+J) = MZ03(J)
+ ENDDO
+ IF (MZ04(1) /= MUNKNO .AND. MZ04(2) /= 0) MZ04(-1) = -MZ04(-1)
+ ENDIF
+
+ 120 MACCMB = MZ04(0)
+ MZ04(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ04(KPTIMU)
+ MZ04(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ CALL ZMEXIT(MZ04,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE ZMATAN
+
+ SUBROUTINE ZMCHSH(MA,MB,MC)
+
+! MB = COSH(MA), MC = SINH(MA).
+
+! If both the hyperbolic sine and cosine are needed, this routine
+! is faster than calling both ZMCOS and ZMSIN.
+
+! MB and MC must be distinct arrays.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NCSAVE,NDSAVE
+
+ NCSAVE = NCALL
+ CALL ZMENTR('ZMCHSH',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ NCALL = NCSAVE + 1
+ IF (KRESLT /= 0) THEN
+ CALL ZMEQ(MB,MC)
+ IF (NTRACE /= 0) THEN
+ CALL ZMNTR(1,MB,MB,1)
+ IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN
+ IF (NTRACE < 0) THEN
+ CALL ZMNTRJ(MC,NDIG)
+ ELSE
+ CALL ZMPRNT(MC)
+ ENDIF
+ ENDIF
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KACCSW = 0
+ KRSAVE = KRAD
+ KRAD = 1
+
+ CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ CALL ZMI2M(1,MZ01)
+ CALL ZMI2M(0,MC)
+ GO TO 110
+ ELSE IF (MA(KPTIMU+2) == 0) THEN
+ CALL FMCHSH(MZ07,MZ01,MC)
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ CALL FMI2M(0,MC(KPTIMU-1))
+ GO TO 110
+ ELSE IF (MA(2) == 0) THEN
+ CALL FMCSSN(MZ07(KPTIMU-1),MZ01,MC(KPTIMU-1))
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ CALL FMI2M(0,MC)
+ GO TO 110
+ ENDIF
+
+! Find SINH(REAL(MA)) and COSH(REAL(MA)).
+
+ CALL FMCHSH(MZ07,MZ02,MZ02(KPTIMU-1))
+
+! Find SIN(IMAG(MA)) and COS(IMAG(MA)).
+
+ CALL FMCSSN(MZ07(KPTIMU-1),MZ03,MZ03(KPTIMU-1))
+
+! COSH(MA) = COSH(REAL(MA))*COS(IMAG(MA)) +
+! SINH(REAL(MA))*SIN(IMAG(MA)) i
+
+ CALL FMMPY(MZ02,MZ03,MZ01)
+ CALL FMMPY(MZ02(KPTIMU-1),MZ03(KPTIMU-1),MZ01(KPTIMU-1))
+
+! SINH(MA) = SINH(REAL(MA))*COS(IMAG(MA)) +
+! COSH(REAL(MA))*SIN(IMAG(MA)) i
+
+ CALL FMMPY(MZ02(KPTIMU-1),MZ03,MC)
+ CALL FMMPY(MZ02,MZ03(KPTIMU-1),MC(KPTIMU-1))
+
+ 110 MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ MC(0) = MZ01(0)
+ MC(KPTIMU) = MZ01(KPTIMU)
+ KACCSW = KASAVE
+ CALL ZMEQ2_R1(MC,NDIG,NDSAVE)
+ CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ IF (NTRACE /= 0) THEN
+ IF (ABS(NTRACE) >= 1 .AND. NCALL+1 <= LVLTRC) THEN
+ IF (NTRACE < 0) THEN
+ CALL ZMNTRJ(MC,NDIG)
+ ELSE
+ CALL ZMPRNT(MC)
+ ENDIF
+ ENDIF
+ ENDIF
+ KRAD = KRSAVE
+ RETURN
+ END SUBROUTINE ZMCHSH
+
+ SUBROUTINE ZMCMPX(MAFM,MBFM,MC)
+
+! MC = COMPLEX( MAFM , MBFM )
+
+! MAFM and MBFM are real FM numbers, MC is a complex ZM number.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MAFM(-1:LUNPCK),MBFM(-1:LUNPCK),MC(-1:LUNPKZ)
+
+ KFLAG = 0
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMCMPX'
+ IF (NTRACE /= 0) CALL FMNTR(2,MAFM,MBFM,2,1)
+
+ CALL FMEQ(MAFM,MC)
+ CALL FMEQ(MBFM,MC(KPTIMU-1))
+
+ IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMCMPX
+
+ SUBROUTINE ZMCONJ(MA,MB)
+
+! MB = CONJG(MA)
+
+! Complex conjugate.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+
+ KFLAG = 0
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMCONJ'
+ IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)
+
+ CALL FMEQ(MA,MB)
+ CALL FMEQ(MA(KPTIMU-1),MB(KPTIMU-1))
+ IF (MB(KPTIMU+1) /= MUNKNO .AND. MB(KPTIMU+2) /= 0) &
+ MB(KPTIMU-1) = -MB(KPTIMU-1)
+
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMCONJ
+
+ SUBROUTINE ZMCOS(MA,MB)
+
+! MB = COS(MA).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE
+
+ CALL ZMENTR('ZMCOS ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KACCSW = 0
+ KRSAVE = KRAD
+ KRAD = 1
+
+ CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ CALL ZMI2M(1,MZ01)
+ GO TO 110
+ ELSE IF (MA(KPTIMU+2) == 0) THEN
+ CALL FMCOS(MZ07,MZ01)
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ GO TO 110
+ ELSE IF (MA(2) == 0) THEN
+ CALL FMCOSH(MZ07(KPTIMU-1),MZ01)
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ GO TO 110
+ ENDIF
+
+! Find COS(REAL(MA)) and SIN(REAL(MA)).
+
+ CALL FMCSSN(MZ07,MZ01,MZ01(KPTIMU-1))
+
+! Find COSH(IMAG(MA)) and SINH(IMAG(MA)).
+
+ CALL FMCHSH(MZ07(KPTIMU-1),M05,M06)
+
+! COS(MA) = COS(REAL(MA))*COSH(IMAG(MA)) -
+! SIN(REAL(MA))*SINH(IMAG(MA)) i
+
+ CALL FMMPY_R1(MZ01,M05)
+ IF (M06(1) /= MUNKNO .AND. M06(2) /= 0) M06(-1) = -M06(-1)
+ CALL FMMPY_R1(MZ01(KPTIMU-1),M06)
+
+ 110 MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ KRAD = KRSAVE
+ RETURN
+ END SUBROUTINE ZMCOS
+
+ SUBROUTINE ZMCOSH(MA,MB)
+
+! MB = COSH(MA).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE
+
+ CALL ZMENTR('ZMCOSH',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KACCSW = 0
+ KRSAVE = KRAD
+ KRAD = 1
+
+ CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ CALL ZMI2M(1,MZ01)
+ GO TO 110
+ ELSE IF (MA(2) == 0) THEN
+ CALL FMCOS(MZ07(KPTIMU-1),MZ01)
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ GO TO 110
+ ELSE IF (MA(KPTIMU+2) == 0) THEN
+ CALL FMCOSH(MZ07,MZ01)
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ GO TO 110
+ ENDIF
+
+! Find COS(IMAG(MA)) and SIN(IMAG(MA)).
+
+ CALL FMCSSN(MZ07(KPTIMU-1),MZ01,MZ01(KPTIMU-1))
+
+! Find COSH(REAL(MA)) and SINH(REAL(MA)).
+
+ CALL FMCHSH(MZ07,M05,M06)
+
+! COSH(MA) = COSH(REAL(MA))*COS(IMAG(MA)) +
+! SINH(REAL(MA))*SIN(IMAG(MA)) i
+
+ CALL FMMPY_R1(MZ01,M05)
+ CALL FMMPY_R1(MZ01(KPTIMU-1),M06)
+
+ 110 MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ KRAD = KRSAVE
+ RETURN
+ END SUBROUTINE ZMCOSH
+
+ SUBROUTINE ZMCSSN(MA,MB,MC)
+
+! MB = COS(MA), MC = SIN(MA).
+
+! If both the sine and cosine are needed, this routine is faster
+! than calling both ZMCOS and ZMSIN.
+
+! MB and MC must be distinct arrays.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NCSAVE,NDSAVE
+
+ NCSAVE = NCALL
+ CALL ZMENTR('ZMCSSN',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ NCALL = NCSAVE + 1
+ IF (KRESLT /= 0) THEN
+ CALL ZMEQ(MB,MC)
+ IF (NTRACE /= 0) THEN
+ CALL ZMNTR(1,MB,MB,1)
+ IF (ABS(NTRACE) >= 1 .AND. NCALL <= LVLTRC) THEN
+ IF (NTRACE < 0) THEN
+ CALL ZMNTRJ(MC,NDIG)
+ ELSE
+ CALL ZMPRNT(MC)
+ ENDIF
+ ENDIF
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KACCSW = 0
+ KRSAVE = KRAD
+ KRAD = 1
+
+ CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ CALL ZMI2M(1,MZ01)
+ CALL ZMI2M(0,MC)
+ GO TO 110
+ ELSE IF (MA(KPTIMU+2) == 0) THEN
+ CALL FMCSSN(MZ07,MZ01,MC)
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ CALL FMI2M(0,MC(KPTIMU-1))
+ GO TO 110
+ ELSE IF (MA(2) == 0) THEN
+ CALL FMCHSH(MZ07(KPTIMU-1),MZ01,MC(KPTIMU-1))
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ CALL FMI2M(0,MC)
+ GO TO 110
+ ENDIF
+
+! Find SIN(REAL(MA)) and COS(REAL(MA)).
+
+ CALL FMCSSN(MZ07,MZ02,MZ02(KPTIMU-1))
+
+! Find SINH(IMAG(MA)) and COSH(IMAG(MA)).
+
+ CALL FMCHSH(MZ07(KPTIMU-1),MZ03,MZ03(KPTIMU-1))
+
+! COS(MA) = COS(REAL(MA))*COSH(IMAG(MA)) -
+! SIN(REAL(MA))*SINH(IMAG(MA)) i
+
+ CALL FMMPY(MZ02,MZ03,MZ01)
+ CALL FMMPY(MZ02(KPTIMU-1),MZ03(KPTIMU-1),MZ01(KPTIMU-1))
+ IF (MZ01(KPTIMU+1) /= MUNKNO .AND. MZ01(KPTIMU+2) /= 0) &
+ MZ01(KPTIMU-1) = -MZ01(KPTIMU-1)
+
+! SIN(MA) = SIN(REAL(MA))*COSH(IMAG(MA)) +
+! COS(REAL(MA))*SINH(IMAG(MA)) i
+
+ CALL FMMPY(MZ02(KPTIMU-1),MZ03,MC)
+ CALL FMMPY(MZ02,MZ03(KPTIMU-1),MC(KPTIMU-1))
+
+ 110 MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ MC(0) = MZ01(0)
+ MC(KPTIMU) = MZ01(KPTIMU)
+ KACCSW = KASAVE
+ CALL ZMEQ2_R1(MC,NDIG,NDSAVE)
+ CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ IF (NTRACE /= 0) THEN
+ IF (ABS(NTRACE) >= 1 .AND. NCALL+1 <= LVLTRC) THEN
+ IF (NTRACE < 0) THEN
+ CALL ZMNTRJ(MC,NDIG)
+ ELSE
+ CALL ZMPRNT(MC)
+ ENDIF
+ ENDIF
+ ENDIF
+ KRAD = KRSAVE
+ RETURN
+ END SUBROUTINE ZMCSSN
+
+ SUBROUTINE ZMDIV(MA,MB,MC)
+
+! MC = MA / MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MBIZ,MBRZ,MXSAVE,MZ11SV,MZ1KSV
+ INTEGER IEXTRA,J,KASAVE,KOVUN,KRESLT,KWRNSV,NDGSV2,NDSAVE,NGOAL, &
+ NTRSAV
+
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR. &
+ ABS(MB(1)) > MEXPAB .OR. ABS(MB(KPTIMU+1)) > MEXPAB .OR. &
+ KDEBUG >= 1) THEN
+ CALL ZMENTR('ZMDIV ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'ZMDIV '
+ CALL ZMNTR(2,MA,MB,2)
+ ENDIF
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ NDIG = MAX(NDIG+NGRD52,2)
+ IF (NDIG > NDG2MX) THEN
+ NAMEST(NCALL) = 'ZMDIV '
+ KFLAG = -9
+ CALL ZMWARN
+ KRESLT = 12
+ NDIG = NDSAVE
+ CALL ZMRSLT(MC,KRESLT)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ IF (MBASE >= 100*ABS(MA(2)) .OR. &
+ MBASE >= 100*ABS(MA(KPTIMU+2))) THEN
+ NDIG = MIN(NDIG+1,NDG2MX)
+ ELSE IF (MBASE >= 100*ABS(MB(2)) .OR. &
+ MBASE >= 100*ABS(MB(KPTIMU+2))) THEN
+ NDIG = MIN(NDIG+1,NDG2MX)
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 1
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ KOVUN = 0
+ ENDIF
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
+ ENDIF
+
+ MARZ = MA(0)
+ MBRZ = MB(0)
+ MAIZ = MA(KPTIMU)
+ MBIZ = MB(KPTIMU)
+ NTRSAV = NTRACE
+ NTRACE = 0
+ KWRNSV = KWARN
+ KWARN = 0
+ IEXTRA = 0
+ MZ11SV = -MUNKNO
+ MZ1KSV = -MUNKNO
+
+ 110 CALL FMEQU(MA,M17,NDSAVE,NDIG)
+ CALL FMEQU(MA(KPTIMU-1),M18,NDSAVE,NDIG)
+ CALL FMEQU(MB,M19,NDSAVE,NDIG)
+ CALL FMEQU(MB(KPTIMU-1),M20,NDSAVE,NDIG)
+ IF (NCALL == 1) THEN
+ M17(0) = NINT(NDIG*ALOGM2)
+ M19(0) = M17(0)
+ M18(0) = M17(0)
+ M20(0) = M17(0)
+ ENDIF
+
+! Check for special cases.
+
+ IF (MB(KPTIMU+2) == 0) THEN
+ CALL FMDIVD(M17,M18,M19,MZ01,MZ01(KPTIMU-1))
+ GO TO 130
+ ELSE IF (MB(2) == 0) THEN
+ CALL FMDIVD(M18,M17,M20,MZ01,MZ01(KPTIMU-1))
+ IF (MZ01(KPTIMU+1) /= MUNKNO .AND. MZ01(KPTIMU+2) /= 0) &
+ MZ01(KPTIMU-1) = -MZ01(KPTIMU-1)
+ GO TO 130
+ ENDIF
+ IF (MA(1) == MB(1) .AND. MA(2) == MB(2) .AND. MA(-1) == MB(-1)) THEN
+ IF (MA(KPTIMU+1) == MB(KPTIMU+1) .AND. &
+ MA(KPTIMU+2) == MB(KPTIMU+2) .AND. &
+ MA(KPTIMU-1) == MB(KPTIMU-1)) THEN
+ DO J = 3, NDSAVE+1
+ IF (MA(J) /= MB(J)) GO TO 120
+ IF (MA(KPTIMU+J) /= MB(KPTIMU+J)) GO TO 120
+ ENDDO
+ IF (ABS(MA(1)) < MEXPOV .AND. ABS(MA(KPTIMU+1)) < MEXPOV &
+ .AND. ABS(MB(1)) < MEXPOV .AND. &
+ ABS(MB(KPTIMU+1)) < MEXPOV) THEN
+ CALL ZMI2M(1,MZ01)
+ GO TO 130
+ ENDIF
+ ENDIF
+ ENDIF
+ IF (MA(1) == MB(1) .AND. MA(2) == MB(2) .AND. (-MA(-1)) == MB(-1)) THEN
+ IF (MA(KPTIMU+1) == MB(KPTIMU+1) .AND. &
+ MA(KPTIMU+2) == MB(KPTIMU+2) .AND. &
+ (-MA(KPTIMU-1)) == MB(KPTIMU-1)) THEN
+ DO J = 3, NDSAVE+1
+ IF (MA(J) /= MB(J)) GO TO 120
+ IF (MA(KPTIMU+J) /= MB(KPTIMU+J)) GO TO 120
+ ENDDO
+ IF (ABS(MA(1)) < MEXPOV .AND. ABS(MA(KPTIMU+1)) < MEXPOV &
+ .AND. ABS(MB(1)) < MEXPOV .AND. &
+ ABS(MB(KPTIMU+1)) < MEXPOV) THEN
+ CALL ZMI2M(-1,MZ01)
+ GO TO 130
+ ENDIF
+ ENDIF
+ ENDIF
+ 120 IF (MZ11SV /= -MUNKNO) THEN
+
+! If a retry is being done due to cancellation, try a slower
+! but more stable form of the division formula.
+
+ CALL FMMPYE(M19,M17,M18,M19, &
+ MZ01,MZ01(KPTIMU-1),M03)
+ CALL FMMPYE(M20,M18,M17,M20, &
+ M01,M02,M04)
+ CALL FMADD_R2(M03,M04)
+ CALL FMADD_R1(MZ01,M01)
+ CALL FMSUB_R1(MZ01(KPTIMU-1),M02)
+ CALL FMDIVD(MZ01,MZ01(KPTIMU-1),M04,MZ08,MZ08(KPTIMU-1))
+ CALL ZMEQ(MZ08,MZ01)
+ IF (ABS(MZ01(1)) < MEXPOV .AND. &
+ ABS(MZ01(KPTIMU+1)) < MEXPOV) GO TO 130
+ ENDIF
+
+! Normal method for ( a + b i ) / ( c + d i ):
+
+! If abs(c) << abs(d) Then
+
+! P = c / d
+! result = ( a*P + b )/( c*P + d ) +
+! ( b*P - a )/( c*P + d ) i
+
+! Else
+
+! P = d / c
+! result = ( b*P + a )/( d*P + c ) +
+! ( b - a*P )/( d*P + c ) i
+
+ KACCSW = 0
+ IF (MB(1) <= MB(KPTIMU+1)) THEN
+ CALL FMDIV(M19,M20,M04)
+ CALL FMMPYE(M04,M17,M18,M19,MZ01,MZ01(KPTIMU-1),M03)
+ IF (MA(KPTIMU-1)*MZ01(-1) < 0) THEN
+ KACCSW = 1
+ ELSE
+ KACCSW = 0
+ ENDIF
+ CALL FMADD_R2(M18,MZ01)
+ IF (M03(-1)*MB(KPTIMU-1) < 0) THEN
+ KACCSW = 1
+ ELSE
+ KACCSW = 0
+ ENDIF
+ CALL FMADD_R1(M03,M20)
+ IF (MZ01(KPTIMU-1)*MA(-1) < 0) THEN
+ KACCSW = 0
+ ELSE
+ KACCSW = 1
+ ENDIF
+ CALL FMSUB_R1(MZ01(KPTIMU-1),M17)
+ KACCSW = 0
+ CALL FMDIVD(MZ01,MZ01(KPTIMU-1),M03,MZ08,MZ08(KPTIMU-1))
+ CALL ZMEQ(MZ08,MZ01)
+ ELSE
+ CALL FMDIV(M20,M19,M04)
+ CALL FMMPYE(M04,M18,M17,M20, &
+ MZ01,MZ01(KPTIMU-1),M03)
+ IF (MA(-1)*MZ01(-1) < 0) THEN
+ KACCSW = 1
+ ELSE
+ KACCSW = 0
+ ENDIF
+ CALL FMADD_R2(M17,MZ01)
+ IF (M03(-1)*MB(-1) < 0) THEN
+ KACCSW = 1
+ ELSE
+ KACCSW = 0
+ ENDIF
+ CALL FMADD_R1(M03,M19)
+ IF (MZ01(KPTIMU-1)*MA(KPTIMU-1) < 0) THEN
+ KACCSW = 0
+ ELSE
+ KACCSW = 1
+ ENDIF
+ CALL FMSUB_R2(M18,MZ01(KPTIMU-1))
+ KACCSW = 0
+ CALL FMDIVD(MZ01,MZ01(KPTIMU-1),M03,MZ08,MZ08(KPTIMU-1))
+ CALL ZMEQ(MZ08,MZ01)
+ ENDIF
+ KACCSW = 1
+
+! Check for too much cancellation.
+
+ IF (NCALL <= 1) THEN
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7
+ ELSE
+ NGOAL = INT(-MXEXP2)
+ ENDIF
+ IF (MZ01(0) <= NGOAL .OR. MZ01(KPTIMU) <= NGOAL) THEN
+ IF (MZ11SV-MZ01(1) >= IEXTRA-1 .AND. MZ01(KPTIMU) > NGOAL) &
+ GO TO 130
+ IF (MZ1KSV-MZ01(KPTIMU+1) >= IEXTRA-1 .AND. MZ01(0) > NGOAL) &
+ GO TO 130
+ IF (MZ11SV > -MUNKNO .AND. MZ01(0) > NGOAL .AND. &
+ MZ01(KPTIMU+2) == 0) GO TO 130
+ IF (MZ11SV > -MUNKNO .AND. MZ01(KPTIMU) > NGOAL .AND. &
+ MZ01(2) == 0) GO TO 130
+ IEXTRA = INT(REAL(MAX(NGOAL-MZ01(0),NGOAL-MZ01(KPTIMU))) &
+ /ALOGM2 + 23.03/ALOGMB) + 1
+ MZ11SV = MZ01(1)
+ MZ1KSV = MZ01(KPTIMU+1)
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ NAMEST(NCALL) = 'ZMDIV '
+ KFLAG = -9
+ CALL ZMWARN
+ NDIG = NDSAVE
+ CALL ZMST2M('UNKNOWN+UNKNOWN*i',MZ01)
+ GO TO 130
+ ENDIF
+ GO TO 110
+ ENDIF
+
+ 130 MXEXP = MXSAVE
+ NTRACE = NTRSAV
+ NDGSV2 = NDIG
+ NDIG = NDSAVE
+ KWARN = KWRNSV
+ MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)
+ CALL ZMEQ2(MZ01,MC,NDGSV2,NDSAVE)
+ IF (MC(1) >= MEXPOV .OR. MC(1) <= -MEXPOV .OR. &
+ MC(KPTIMU+1) >= MEXPOV .OR. MC(KPTIMU+1) <= -MEXPOV) THEN
+ IF (MC(1) == MUNKNO .OR. MC(KPTIMU+1) == MUNKNO) THEN
+ KFLAG = -4
+ ELSE IF (MC(1) == MEXPOV .OR. MC(KPTIMU+1) == MEXPOV) THEN
+ KFLAG = -5
+ ELSE IF (MC(1) == MEXPUN .OR. MC(KPTIMU+1) == MEXPUN) THEN
+ KFLAG = -6
+ ENDIF
+ IF ((MC(1) == MUNKNO) &
+ .OR. (MC(KPTIMU+1) == MUNKNO) &
+ .OR. (MC(1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MC(KPTIMU+1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MC(1) == MEXPOV .AND. KOVUN == 0) &
+ .OR. (MC(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
+ NAMEST(NCALL) = 'ZMDIV '
+ CALL ZMWARN
+ ENDIF
+ ENDIF
+ IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
+ KACCSW = KASAVE
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMDIV
+
+ SUBROUTINE ZMDIVI(MA,INTEG,MB)
+
+! MB = MA / INTEG Divide by one-word (real) integer.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ INTEGER INTEG
+
+ INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV
+ REAL (KIND(1.0D0)) :: MXSAVE
+
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR. &
+ KDEBUG >= 1) THEN
+ NTRSAV = NTRACE
+ IF (NTRACE /= 0) THEN
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMDIVI'
+ CALL ZMNTR(2,MA,MA,1)
+ CALL FMNTRI(2,INTEG,0)
+ NCALL = NCALL - 1
+ ENDIF
+ NTRACE = 0
+ CALL ZMENTR('ZMDIVI',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ NTRACE = NTRSAV
+ IF (KRESLT /= 0) THEN
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ NDIG = NDSAVE
+ MXEXP = MXSAVE
+ KACCSW = KASAVE
+ ELSE
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'ZMDIVI'
+ CALL ZMNTR(2,MA,MA,1)
+ CALL FMNTRI(2,INTEG,0)
+ ENDIF
+ KOVUN = 0
+ ENDIF
+
+! Force FMDIVI to use more guard digits for user calls.
+
+ NCALL = NCALL - 1
+ NTRSAV = NTRACE
+ NTRACE = 0
+ KWRNSV = KWARN
+ KWARN = 0
+
+ CALL FMDIVI(MA,INTEG,MB)
+ CALL FMDIVI(MA(KPTIMU-1),INTEG,MB(KPTIMU-1))
+
+ NTRACE = NTRSAV
+ KWARN = KWRNSV
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) NAMEST(NCALL) = 'ZMDIVI'
+ IF (MB(1) == MUNKNO .OR. MB(KPTIMU+1) == MUNKNO) THEN
+ KFLAG = -4
+ ELSE IF (MB(1) == MEXPOV .OR. MB(KPTIMU+1) == MEXPOV) THEN
+ KFLAG = -5
+ ELSE IF (MB(1) == MEXPUN .OR. MB(KPTIMU+1) == MEXPUN) THEN
+ KFLAG = -6
+ ENDIF
+ IF ((MB(1) == MUNKNO) &
+ .OR. (MB(KPTIMU+1) == MUNKNO) &
+ .OR. (MB(1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MB(KPTIMU+1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MB(1) == MEXPOV .AND. KOVUN == 0) &
+ .OR. (MB(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
+ NAMEST(NCALL) = 'ZMDIVI'
+ CALL ZMWARN
+ ENDIF
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMDIVI
+
+ SUBROUTINE ZMENTR(NROUTN,MA,MB,NARGS,MC,KRESLT,NDSAVE,MXSAVE, &
+ KASAVE,KOVUN)
+
+! Do the argument checking and increasing of precision, overflow
+! threshold, etc., upon entry to a ZM routine.
+
+! NROUTN - routine name of calling routine
+! MA - first input argument
+! MB - second input argument (optional)
+! NARGS - number of input arguments
+! MC - result argument
+! KRESLT - returned nonzero if the input arguments give the result
+! immediately (e.g., MA*0 or OVERFLOW*MB)
+! NDSAVE - saves the value of NDIG after NDIG is increased
+! MXSAVE - saves the value of MXEXP
+! KASAVE - saves the value of KACCSW
+! KOVUN - returned nonzero if an input argument is (+ or -) overflow
+! or underflow.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(6) :: NROUTN
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ),MXSAVE
+ INTEGER NARGS,KRESLT,NDSAVE,KASAVE,KOVUN
+
+ REAL (KIND(1.0D0)) :: MBS
+ INTEGER J,KWRNSV,NDS
+
+ KRESLT = 0
+ NCALL = NCALL + 1
+ KFLAG = 0
+ NAMEST(NCALL) = NROUTN
+ IF (NTRACE /= 0) CALL ZMNTR(2,MA,MB,NARGS)
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN .OR. &
+ MA(KPTIMU+1) == MEXPOV .OR. MA(KPTIMU+1) == MEXPUN) KOVUN = 1
+ IF (NARGS == 2) THEN
+ IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN .OR. &
+ MB(KPTIMU+1) == MEXPOV .OR. MB(KPTIMU+1) == MEXPUN) KOVUN = 1
+ ENDIF
+ KASAVE = KACCSW
+ MXSAVE = MXEXP
+
+! Check the validity of parameters if this is a user call.
+
+ IF (NCALL > 1 .AND. KDEBUG == 0) GO TO 130
+
+! Check NDIG.
+
+ IF (NDIG < 2 .OR. NDIG > NDIGMX) THEN
+ KFLAG = -1
+ CALL ZMWARN
+ NDS = NDIG
+ IF (NDIG < 2) NDIG = 2
+ IF (NDIG > NDIGMX) NDIG = NDIGMX
+ WRITE (KW, &
+ "(' NDIG was',I10,'. It has been changed to',I10,'.')" &
+ ) NDS,NDIG
+ KRESLT = 12
+ GO TO 130
+ ENDIF
+
+! Check MBASE.
+
+ IF (MBASE < 2 .OR. MBASE > MXBASE) THEN
+ KFLAG = -2
+ CALL ZMWARN
+ MBS = MBASE
+ IF (MBASE < 2) MBASE = 2
+ IF (MBASE > MXBASE) MBASE = MXBASE
+ WRITE (KW, &
+ "(' MBASE was',I10,'. It has been changed to',I10,'.')" &
+ ) INT(MBS),INT(MBASE)
+ CALL FMCONS
+ KRESLT = 12
+ GO TO 130
+ ENDIF
+
+! Check exponent range.
+
+ IF (MA(1) > MXEXP+1 .OR. MA(1) < -MXEXP) THEN
+ IF ((ABS(MA(1)) /= MEXPOV .AND. ABS(MA(1)) /= MUNKNO) .OR. &
+ ABS(MA(2)) /= 1) THEN
+ KFLAG = -3
+ CALL ZMWARN
+ KRESLT = 12
+ GO TO 130
+ ENDIF
+ ENDIF
+ IF (MA(KPTIMU+1) > MXEXP+1 .OR. MA(KPTIMU+1) < -MXEXP) THEN
+ IF ((ABS(MA(KPTIMU+1)) /= MEXPOV .AND. &
+ ABS(MA(KPTIMU+1)) /= MUNKNO) .OR. &
+ ABS(MA(KPTIMU+2)) /= 1) THEN
+ KFLAG = -3
+ CALL ZMWARN
+ KRESLT = 12
+ GO TO 130
+ ENDIF
+ ENDIF
+ IF (NARGS == 2) THEN
+ IF (MB(1) > MXEXP+1 .OR. MB(1) < -MXEXP) THEN
+ IF ((ABS(MB(1)) /= MEXPOV .AND. ABS(MB(1)) /= MUNKNO) .OR. &
+ ABS(MB(2)) /= 1) THEN
+ KFLAG = -3
+ CALL ZMWARN
+ KRESLT = 12
+ GO TO 130
+ ENDIF
+ ENDIF
+ IF (MB(KPTIMU+1) > MXEXP+1 .OR. MB(KPTIMU+1) < -MXEXP) THEN
+ IF ((ABS(MB(KPTIMU+1)) /= MEXPOV .AND. &
+ ABS(MB(KPTIMU+1)) /= MUNKNO) .OR. &
+ ABS(MB(KPTIMU+2)) /= 1) THEN
+ KFLAG = -3
+ CALL ZMWARN
+ KRESLT = 12
+ GO TO 130
+ ENDIF
+ ENDIF
+ ENDIF
+
+! Check for properly normalized digits in the
+! input arguments.
+
+ IF (ABS(MA(1)-INT(MA(1))) /= 0) KFLAG = 1
+ IF (ABS(MA(KPTIMU+1)-INT(MA(KPTIMU+1))) /= 0) KFLAG = KPTIMU + 1
+ IF (MA(2) <= (-1) .OR. MA(2) >= MBASE .OR. &
+ ABS(MA(2)-INT(MA(2))) /= 0) KFLAG = 2
+ IF (MA(KPTIMU+2) <= (-1) .OR. MA(KPTIMU+2) >= MBASE .OR. &
+ ABS(MA(KPTIMU+2)-INT(MA(KPTIMU+2))) /= 0) KFLAG = KPTIMU + 2
+ IF (KDEBUG == 0) GO TO 110
+ DO J = 3, NDIG+1
+ IF (MA(J) < 0 .OR. MA(J) >= MBASE .OR. &
+ ABS(MA(J)-INT(MA(J))) /= 0) THEN
+ KFLAG = J
+ GO TO 110
+ ENDIF
+ ENDDO
+ DO J = KPTIMU+3, KPTIMU+NDIG+1
+ IF (MA(J) < 0 .OR. MA(J) >= MBASE .OR. &
+ ABS(MA(J)-INT(MA(J))) /= 0) THEN
+ KFLAG = J
+ GO TO 110
+ ENDIF
+ ENDDO
+ 110 IF (KFLAG /= 0) THEN
+ J = KFLAG
+ KFLAG = -4
+ KWRNSV = KWARN
+ IF (KWARN >= 2) KWARN = 1
+ CALL ZMWARN
+ KWARN = KWRNSV
+ IF (KWARN >= 1) THEN
+ IF (J < KPTIMU) THEN
+ WRITE (KW,*) ' First invalid array element: MA(', &
+ J,') = ',MA(J)
+ ELSE
+ WRITE (KW,*) ' First invalid array element: MA(', &
+ KPTIMU,'+',J-KPTIMU,') = ',MA(J)
+ ENDIF
+ ENDIF
+ IF (KWARN >= 2) THEN
+ STOP
+ ENDIF
+ KRESLT = 12
+ GO TO 130
+ ENDIF
+ IF (NARGS == 2) THEN
+ IF (ABS(MB(1)-INT(MB(1))) /= 0) KFLAG = 1
+ IF (ABS(MB(KPTIMU+1)-INT(MB(KPTIMU+1))) /= 0) &
+ KFLAG = KPTIMU + 1
+ IF (MB(2) <= (-1) .OR. MB(2) >= MBASE .OR. &
+ ABS(MB(2)-INT(MB(2))) /= 0) KFLAG = 2
+ IF (MB(KPTIMU+2) <= (-1) .OR. MB(KPTIMU+2) >= MBASE .OR. &
+ ABS(MB(KPTIMU+2)-INT(MB(KPTIMU+2))) /= 0) &
+ KFLAG = KPTIMU + 2
+ IF (KDEBUG == 0) GO TO 120
+ DO J = 3, NDIG+1
+ IF (MB(J) < 0 .OR. MB(J) >= MBASE .OR. &
+ ABS(MB(J)-INT(MB(J))) /= 0) THEN
+ KFLAG = J
+ GO TO 120
+ ENDIF
+ ENDDO
+ DO J = KPTIMU+3, KPTIMU+NDIG+1
+ IF (MB(J) < 0 .OR. MB(J) >= MBASE .OR. &
+ ABS(MB(J)-INT(MB(J))) /= 0) THEN
+ KFLAG = J
+ GO TO 120
+ ENDIF
+ ENDDO
+ 120 IF (KFLAG /= 0) THEN
+ J = KFLAG
+ MBS = MB(J)
+ KFLAG = -4
+ KWRNSV = KWARN
+ IF (KWARN >= 2) KWARN = 1
+ CALL ZMWARN
+ KWARN = KWRNSV
+ IF (KWARN >= 1) THEN
+ IF (J < KPTIMU) THEN
+ WRITE (KW,*) ' First invalid array element: MB(', &
+ J,') = ',MB(J)
+ ELSE
+ WRITE (KW,*) ' First invalid array element: MB(', &
+ KPTIMU,'+',J-KPTIMU,') = ',MB(J)
+ ENDIF
+ ENDIF
+ IF (KWARN >= 2) THEN
+ STOP
+ ENDIF
+ KRESLT = 12
+ GO TO 130
+ ENDIF
+ ENDIF
+
+! Increase the working precision.
+
+ 130 NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ NDIG = MAX(NDIG+NGRD52,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL ZMWARN
+ KRESLT = 12
+ NDIG = NDSAVE
+ ENDIF
+ IF (MBASE >= 100*ABS(MA(2)) .OR. &
+ MBASE >= 100*ABS(MA(KPTIMU+2))) THEN
+ NDIG = MIN(NDIG+1,NDG2MX)
+ ELSE IF (NARGS == 2 .AND. (MBASE >= 100*ABS(MB(2)) .OR. &
+ MBASE >= 100*ABS(MB(KPTIMU+2)))) THEN
+ NDIG = MIN(NDIG+1,NDG2MX)
+ ENDIF
+ ENDIF
+ IF ((MA(1) == MUNKNO .AND. MA(KPTIMU+1) == MUNKNO) .OR. &
+ (MB(1) == MUNKNO .AND. MB(KPTIMU+1) == MUNKNO)) THEN
+ KFLAG = -4
+ KRESLT = 12
+ ENDIF
+ IF (KRESLT /= 0) THEN
+ NDIG = NDSAVE
+ CALL ZMRSLT(MC,KRESLT)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ KACCSW = 1
+
+! Extend the overflow/underflow threshold.
+
+ MXEXP = MXEXP2
+ RETURN
+ END SUBROUTINE ZMENTR
+
+ SUBROUTINE ZMEQ(MA,MB)
+
+! MB = MA
+
+! This is the standard form of equality, where MA and MB both
+! have precision NDIG. Use ZMEQU for assignments that also
+! change precision.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+
+ CALL FMEQ(MA,MB)
+ CALL FMEQ(MA(KPTIMU-1),MB(KPTIMU-1))
+ RETURN
+ END SUBROUTINE ZMEQ
+
+ SUBROUTINE ZMEQ2(MA,MB,NDA,NDB)
+
+! Set MB (having NDB digits) equal to MA (having NDA digits).
+
+! If MB has less precision than MA, the result is rounded to
+! NDB digits.
+
+! If MB has more precision, the result has zero digits padded on the
+! right.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ INTEGER NDA,NDB
+
+ CALL FMEQ2(MA,MB,NDA,NDB)
+ CALL FMEQ2(MA(KPTIMU-1),MB(KPTIMU-1),NDA,NDB)
+ RETURN
+ END SUBROUTINE ZMEQ2
+
+ SUBROUTINE ZMEQ2_R1(MA,NDA,NDB)
+
+! Change precision of MA from NDA digits on input to NDB digits on output.
+
+! If NDB is less than NDA the result is rounded to NDB digits.
+
+! If NDB is greater than NDA the result has zero digits padded on the
+! right.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
+ INTEGER NDA,NDB
+
+ CALL FMEQ2_R1(MA,NDA,NDB)
+ CALL FMEQ2_R1(MA(KPTIMU-1),NDA,NDB)
+ RETURN
+ END SUBROUTINE ZMEQ2_R1
+
+ SUBROUTINE ZMEQU(MA,MB,NDA,NDB)
+
+! Set MB (having NDB digits) equal to MA (having NDA digits).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ INTEGER NDA,NDB
+
+ CALL FMEQ2(MA,MB,NDA,NDB)
+ CALL FMEQ2(MA(KPTIMU-1),MB(KPTIMU-1),NDA,NDB)
+ RETURN
+ END SUBROUTINE ZMEQU
+
+ SUBROUTINE ZMEXIT(MT,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
+
+! Upon exit from an ZM routine the result MT (having precision NDIG)
+! is rounded and returned in MC (having precision NDSAVE).
+! The values of NDIG, MXEXP, and KACCSW are restored to the values
+! NDSAVE,MXSAVE,KASAVE.
+! KOVUN is nonzero if one of the routine's input arguments was overflow
+! or underflow.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MT(-1:LUNPKZ),MC(-1:LUNPKZ),MXSAVE
+ INTEGER NDSAVE,KASAVE,KOVUN
+
+ INTEGER KFSAVE,KWRNSV
+
+ KWRNSV = KWARN
+ KWARN = 0
+ MXEXP = MXSAVE
+ KFSAVE = KFLAG
+ KACCSW = KASAVE
+ CALL ZMEQ2(MT,MC,NDIG,NDSAVE)
+ IF (KFLAG /= -5 .AND. KFLAG /= -6) KFLAG = KFSAVE
+ NDIG = NDSAVE
+ KWARN = KWRNSV
+ IF (KFLAG == 1) KFLAG = 0
+ IF (MC(1) == MEXPUN .OR. MC(KPTIMU+1) == MEXPUN) KFLAG = -6
+ IF (MC(1) == MEXPOV .OR. MC(KPTIMU+1) == MEXPOV) KFLAG = -5
+ IF (MC(1) == MUNKNO .OR. MC(KPTIMU+1) == MUNKNO) THEN
+ IF (KFLAG /= -9) KFLAG = -4
+ ENDIF
+ IF ((MC(1) == MUNKNO .AND. KFLAG /= -9) .OR. &
+ (MC(KPTIMU+1) == MUNKNO .AND. KFLAG /= -9) .OR. &
+ (MC(1) == MEXPUN .AND. KOVUN == 0) .OR. &
+ (MC(KPTIMU+1) == MEXPUN .AND. KOVUN == 0) .OR. &
+ (MC(1) == MEXPOV .AND. KOVUN == 0) .OR. &
+ (MC(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) CALL ZMWARN
+ IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMEXIT
+
+ SUBROUTINE ZMEXI2(MXFM,NDSAVE,MXSAVE,KASAVE,KOVUN)
+
+! This routine is used upon exit for complex functions that
+! return real FM results.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MXFM(-1:LUNPCK),MXSAVE
+ INTEGER NDSAVE,KASAVE,KOVUN
+
+ INTEGER KFSAVE,KWRNSV
+
+ KWRNSV = KWARN
+ KWARN = 0
+ MXEXP = MXSAVE
+ KFSAVE = KFLAG
+ KACCSW = KASAVE
+ CALL FMEQ2_R1(MXFM,NDIG,NDSAVE)
+ IF (KFLAG /= -5 .AND. KFLAG /= -6) KFLAG = KFSAVE
+ NDIG = NDSAVE
+ KWARN = KWRNSV
+ IF (KFLAG == 1) KFLAG = 0
+ IF (MXFM(1) == MUNKNO) THEN
+ IF (KFLAG >= 0) KFLAG = -4
+ ELSE IF (MXFM(1) == MEXPOV) THEN
+ KFLAG = -5
+ ELSE IF (MXFM(1) == MEXPUN) THEN
+ KFLAG = -6
+ ENDIF
+ IF ((MXFM(1) == MUNKNO .AND. KFLAG /= -9) &
+ .OR. (MXFM(1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MXFM(1) == MEXPOV .AND. KOVUN == 0)) CALL ZMWARN
+ IF (NTRACE /= 0) CALL ZMNTR2(1,MXFM,MXFM,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMEXI2
+
+ SUBROUTINE ZMEXP(MA,MB)
+
+! MB = EXP(MA).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,KWRNSV,NDSAVE
+
+ CALL ZMENTR('ZMEXP ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KACCSW = 0
+ KRSAVE = KRAD
+ KRAD = 1
+
+ CALL ZMEQU(MA,MZ05,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ CALL ZMI2M(1,MZ01)
+ GO TO 110
+ ELSE IF (MA(2) == 0) THEN
+ CALL FMI2M(1,M06)
+ ELSE
+ CALL FMEXP(MZ05,M06)
+ ENDIF
+
+ CALL FMCSSN(MZ05(KPTIMU-1),MZ01,MZ01(KPTIMU-1))
+
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMMPYD(M06,MZ01,MZ01(KPTIMU-1),MZ05,MZ05(KPTIMU-1))
+ CALL ZMEQ(MZ05,MZ01)
+ KWARN = KWRNSV
+
+ 110 MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ KRAD = KRSAVE
+ RETURN
+ END SUBROUTINE ZMEXP
+
+ SUBROUTINE ZMFORM(FORM1,FORM2,MA,STRING)
+
+! Convert MA to STRING using FORM1 format for the real part and
+! FORM2 format for the imaginary part.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(*) :: FORM1,FORM2,STRING
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
+
+ INTEGER J,KWIDIM,KWIDRE,LAST,LSIGN
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMFORM'
+ STRING = ' '
+ CALL ZMFPCM(FORM1,MA,KWIDRE,CMBUFZ)
+ CALL FMEQ(MA(KPTIMU-1),M02)
+ IF (M02(-1) > 0) THEN
+ LSIGN = 1
+ ELSE
+ LSIGN = -1
+ IF (M02(1) /= MUNKNO .AND. M02(2) /= 0) M02(-1) = -M02(-1)
+ ENDIF
+ CALL ZMFPCM(FORM2,M02,KWIDIM,CMBUFF)
+
+ CMBUFZ(KWIDRE+1) = ' '
+ IF (LSIGN == 1) THEN
+ CMBUFZ(KWIDRE+2) = '+'
+ ELSE
+ CMBUFZ(KWIDRE+2) = '-'
+ ENDIF
+ CMBUFZ(KWIDRE+3) = ' '
+ DO J = 1, KWIDIM
+ CMBUFZ(KWIDRE+3+J) = CMBUFF(J)
+ ENDDO
+ CMBUFZ(KWIDRE+4+KWIDIM) = ' '
+ CMBUFZ(KWIDRE+5+KWIDIM) = 'i'
+ IF (JFORMZ == 2) CMBUFZ(KWIDRE+5+KWIDIM) = 'I'
+ LAST = KWIDRE + KWIDIM + 5
+
+ IF (M02(1) == MEXPOV .OR. M02(1) == MEXPUN) THEN
+ DO J = KWIDRE+3, LAST
+ IF (CMBUFZ(J) == 'O' .OR. CMBUFZ(J) == 'U') THEN
+ CMBUFZ(J-2) = ' '
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (LAST <= LEN(STRING)) THEN
+ DO J = 1, LAST
+ STRING(J:J) = CMBUFZ(J)
+ ENDDO
+ ELSE
+ DO J = 1, LAST
+ STRING(J:J) = '*'
+ ENDDO
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMFORM
+
+ SUBROUTINE ZMFPCM(FORM,MA,KWI,CMB)
+
+! Internal routine to convert MA to base 10 using FORM format.
+! The result is returned in CMB and the field width is KWI.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(*) :: FORM
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ INTEGER KWI
+ CHARACTER CMB(LMBUFF)
+ CHARACTER(20) :: FORMB
+ INTEGER J,JF1SAV,JF2SAV,JPT,K1,K2,K3,KD,KWD,KSAVE,LAST,LB, &
+ LENGFM,LFIRST,ND,NEXP
+
+ KSAVE = KFLAG
+ JF1SAV = JFORM1
+ JF2SAV = JFORM2
+ LENGFM = LEN(FORM)
+ KWI = 75
+ KWD = 40
+ IF (INDEX(FORM,'I') > 0 .OR. INDEX(FORM,'i') > 0) THEN
+ K1 = MAX(INDEX(FORM,'I'),INDEX(FORM,'i')) + 1
+ K2 = LENGFM
+ WRITE (FORMB,"('(I',I5,')')") K2-K1+1
+ IF (K2 >= K1) THEN
+ READ (FORM(K1:K2),FORMB) KWI
+ ELSE
+ KWI = 50
+ ENDIF
+ KWI = MAX(1,MIN(KWI,LMBUFF-11))
+ JFORM1 = 2
+ JFORM2 = 0
+ KWD = KWI + 11
+ CALL FMNINT(MA,M03)
+ IF (M03(2) /= 0) THEN
+ CALL FMOUT(M03,CMB,KWD)
+ ELSE
+ DO J = 1, KWD
+ CMB(J) = ' '
+ ENDDO
+ CMB(2) = '0'
+ ENDIF
+ LFIRST = 1
+ LAST = 1
+ DO J = 1, KWD
+ IF (CMB(KWD+1-J) /= ' ') LFIRST = KWD+1-J
+ IF (CMB(J) /= ' ') LAST = J
+ ENDDO
+ JPT = 1
+ IF (LAST-LFIRST+1 > KWI) GO TO 110
+ IF (LAST <= KWI) THEN
+ DO J = LAST, LFIRST, -1
+ JPT = KWI - LAST + J
+ CMB(JPT) = CMB(J)
+ ENDDO
+ DO J = 1, JPT-1
+ CMB(J) = ' '
+ ENDDO
+ ELSE
+ DO J = LFIRST, LAST
+ JPT = KWI - LAST + J
+ CMB(JPT) = CMB(J)
+ ENDDO
+ ENDIF
+ ELSE IF (INDEX(FORM,'F') > 0 .OR. INDEX(FORM,'f') > 0) THEN
+ K1 = MAX(INDEX(FORM,'F'),INDEX(FORM,'f')) + 1
+ K2 = INDEX(FORM(1:LENGFM),'.')
+ K3 = LENGFM
+ IF (K2 > K1) THEN
+ WRITE (FORMB,"('(I',I5,')')") K2-K1
+ READ (FORM(K1:K2-1),FORMB) KWI
+ ELSE
+ KWI = 50
+ ENDIF
+ IF (K3 > K2) THEN
+ WRITE (FORMB,"('(I',I5,')')") K3-K2
+ READ (FORM(K2+1:K3),FORMB) KD
+ ELSE
+ KD = 0
+ ENDIF
+ KWI = MAX(1,MIN(KWI,LMBUFF))
+ KD = MAX(0,MIN(KD,KWI-2))
+ JFORM1 = 2
+ JFORM2 = KD
+ ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
+ IF (ND < 2) ND = 2
+ NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
+ LB = MAX(JFORM2+NEXP,ND+NEXP)
+ LB = MIN(LB,LMBUFF)
+ KWD = LB
+ CALL FMOUT(MA,CMB,KWD)
+ LFIRST = 1
+ LAST = 1
+ DO J = 1, KWD
+ IF (CMB(KWD+1-J) /= ' ') LFIRST = KWD+1-J
+ IF (CMB(J) /= ' ') LAST = J
+ ENDDO
+ IF (LAST-LFIRST+1 > KWI) THEN
+
+! Not enough room for this F format, or FMOUT converted
+! it to E format to avoid showing no significant digits.
+! See if a shortened form will fit in E format.
+
+ NEXP = INT(LOG10((ABS(MA(1))+1)*LOG10(DBLE(MBASE))+1)+1)
+ ND = KWI - NEXP - 5
+ IF (ND < 1) THEN
+ GO TO 110
+ ELSE
+ JFORM1 = 0
+ JFORM2 = ND
+ CALL FMOUT(MA,CMB,KWI)
+ LFIRST = 1
+ LAST = 1
+ DO J = 1, KWI
+ IF (CMB(KWI+1-J) /= ' ') LFIRST = KWI+1-J
+ IF (CMB(J) /= ' ') LAST = J
+ ENDDO
+ ENDIF
+ ENDIF
+ JPT = 1
+ IF (LAST <= KWI) THEN
+ DO J = LAST, LFIRST, -1
+ JPT = KWI - LAST + J
+ CMB(JPT) = CMB(J)
+ ENDDO
+ DO J = 1, JPT-1
+ CMB(J) = ' '
+ ENDDO
+ ELSE
+ DO J = LFIRST, LAST
+ JPT = KWI - LAST + J
+ CMB(JPT) = CMB(J)
+ ENDDO
+ ENDIF
+ ELSE IF (INDEX(FORM,'1PE') > 0 .OR. INDEX(FORM,'1pe') > 0) THEN
+ K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1
+ K2 = INDEX(FORM(1:LENGFM),'.')
+ K3 = LENGFM
+ IF (K2 > K1) THEN
+ WRITE (FORMB,"('(I',I5,')')") K2-K1
+ READ (FORM(K1:K2-1),FORMB) KWI
+ ELSE
+ KWI = 50
+ ENDIF
+ IF (K3 > K2) THEN
+ WRITE (FORMB,"('(I',I5,')')") K3-K2
+ READ (FORM(K2+1:K3),FORMB) KD
+ ELSE
+ KD = 0
+ ENDIF
+ KWI = MAX(1,MIN(KWI,LMBUFF))
+ KD = MAX(0,MIN(KD,KWI-2))
+ JFORM1 = 1
+ JFORM2 = KD
+ CALL FMOUT(MA,CMB,KWI)
+ ELSE IF (INDEX(FORM,'E') > 0 .OR. INDEX(FORM,'e') > 0) THEN
+ K1 = MAX(INDEX(FORM,'E'),INDEX(FORM,'e')) + 1
+ K2 = INDEX(FORM(1:LENGFM),'.')
+ K3 = LENGFM
+ IF (K2 > K1) THEN
+ WRITE (FORMB,"('(I',I5,')')") K2-K1
+ READ (FORM(K1:K2-1),FORMB) KWI
+ ELSE
+ KWI = 50
+ ENDIF
+ IF (K3 > K2) THEN
+ WRITE (FORMB,"('(I',I5,')')") K3-K2
+ READ (FORM(K2+1:K3),FORMB) KD
+ ELSE
+ KD = 0
+ ENDIF
+ KWI = MAX(1,MIN(KWI,LMBUFF))
+ KD = MAX(0,MIN(KD,KWI-2))
+ JFORM1 = 0
+ JFORM2 = KD
+ CALL FMOUT(MA,CMB,KWI)
+ ELSE
+ GO TO 110
+ ENDIF
+
+ JFORM1 = JF1SAV
+ JFORM2 = JF2SAV
+ KFLAG = KSAVE
+ RETURN
+
+! Error condition.
+
+ 110 KFLAG = -8
+ DO J = 1, KWI
+ CMB(J) = '*'
+ ENDDO
+ JFORM1 = JF1SAV
+ JFORM2 = JF2SAV
+ KFLAG = KSAVE
+ RETURN
+ END SUBROUTINE ZMFPCM
+
+ SUBROUTINE ZMFPRT(FORM1,FORM2,MA)
+
+! Print MA in base 10 using FORM1 format for the real part and
+! FORM2 format for the imaginary part.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(*) :: FORM1,FORM2
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
+
+ CHARACTER(20) :: FORM
+ INTEGER J,K,KWIDIM,KWIDRE,LAST,LSIGN
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMFPRT'
+
+ CALL ZMFPCM(FORM1,MA,KWIDRE,CMBUFZ)
+ CALL FMEQ(MA(KPTIMU-1),M02)
+ IF (M02(-1) >= 0) THEN
+ LSIGN = 1
+ ELSE
+ LSIGN = -1
+ IF (M02(1) /= MUNKNO .AND. M02(2) /= 0) M02(-1) = -M02(-1)
+ ENDIF
+ CALL ZMFPCM(FORM2,M02,KWIDIM,CMBUFF)
+
+ CMBUFZ(KWIDRE+1) = ' '
+ IF (LSIGN == 1) THEN
+ CMBUFZ(KWIDRE+2) = '+'
+ ELSE
+ CMBUFZ(KWIDRE+2) = '-'
+ ENDIF
+ CMBUFZ(KWIDRE+3) = ' '
+ DO J = 1, KWIDIM
+ CMBUFZ(KWIDRE+3+J) = CMBUFF(J)
+ ENDDO
+ CMBUFZ(KWIDRE+4+KWIDIM) = ' '
+ CMBUFZ(KWIDRE+5+KWIDIM) = 'i'
+ IF (JFORMZ == 2) CMBUFZ(KWIDRE+5+KWIDIM) = 'I'
+ LAST = KWIDRE + KWIDIM + 5
+
+ IF (M02(1) == MEXPOV .OR. M02(1) == MEXPUN) THEN
+ DO J = KWIDRE+3, LAST
+ IF (CMBUFZ(J) == 'O' .OR. CMBUFZ(J) == 'U') THEN
+ CMBUFZ(J-2) = ' '
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+
+ WRITE (FORM,"(' (6X,',I3,'A1) ')") KSWIDE-7
+ WRITE (KW,FORM) (CMBUFZ(K),K=1,LAST)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMFPRT
+
+ SUBROUTINE ZMI2M(INTEG,MA)
+
+! MA = INTEG
+
+! The real part of MA is set to the one word integer value INTEG.
+! The imaginary part is set to zero.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER INTEG
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMI2M '
+ IF (NTRACE /= 0) CALL ZMNTRI(2,INTEG,1)
+
+ CALL FMI2M(INTEG,MA)
+ CALL FMI2M(0,MA(KPTIMU-1))
+
+ IF (NTRACE /= 0) CALL ZMNTR(1,MA,MA,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMI2M
+
+ SUBROUTINE ZM2I2M(INTEG1,INTEG2,MA)
+
+! MA = INTEG1 + INTEG2 i
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER INTEG1,INTEG2
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZM2I2M'
+ IF (NTRACE /= 0) THEN
+ CALL ZMNTRI(2,INTEG1,1)
+ CALL ZMNTRI(2,INTEG2,0)
+ ENDIF
+
+ CALL FMI2M(INTEG1,MA)
+ CALL FMI2M(INTEG2,MA(KPTIMU-1))
+
+ IF (NTRACE /= 0) CALL ZMNTR(1,MA,MA,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZM2I2M
+
+ SUBROUTINE ZMIMAG(MA,MBFM)
+
+! MBFM = IMAG(MA) imaginary part of MA
+
+! MA is a complex ZM number, MBFM is a real FM number.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MBFM(-1:LUNPCK)
+
+ KFLAG = 0
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMIMAG'
+ IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)
+
+ CALL FMEQ(MA(KPTIMU-1),MBFM)
+
+ IF (NTRACE /= 0) CALL FMNTR(1,MBFM,MBFM,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMIMAG
+
+ SUBROUTINE ZMINP(LINE,MA,LA,LB)
+
+! Convert an A1 character string to floating point multiple precision
+! complex format.
+
+! LINE is an A1 character array of length LB to be converted
+! to ZM format and returned in MA.
+! LA is a pointer telling the routine where in the array to begin
+! the conversion. This allows more than one number to be stored
+! in an array and converted in place.
+! LB is a pointer to the last character of the field for that number.
+
+! The input numbers may be in integer or any real format.
+! In exponential format the 'E' may also be 'D', 'Q', or 'M'.
+
+! The following are all valid input strings:
+
+! 1.23 + 4.56 I
+! 1.23 + 4.56*I
+! 2 + i
+! -i
+! 1.23
+! 4.56i
+! ( 1.23 , 4.56 )
+
+! So that ZMINP will convert any output from ZMOUT, LINE is tested
+! to see if the input contains any of the special symbols +OVERFLOW,
+! -OVERFLOW, +UNDERFLOW, -UNDERFLOW, or UNKNOWN.
+! For user input the abbreviations OVFL, UNFL, UNKN may be used.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER LA,LB
+ CHARACTER LINE(LB)
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
+ INTEGER J,JSTATE,K,KASAVE,KDIGFL,KFLAG1,KIFLAG,KPT, &
+ KRSAVE,KSIGN,KSTART,KSTOP,KSTOPI,KSTOPR,KSTRTI,KSTRTR, &
+ KTYPE,KVAL,NDSAVE,NTRSAV
+
+! Simulate a finite-state automaton to scan the input line
+! and build the number. States 2-8 refer to the real part,
+! states 10-16 refer to the imaginary part.
+! States of the machine:
+
+! 1. Initial entry to the subroutine
+! 2. Sign of the number
+! 3. Scanning digits before a decimal point
+! 4. Decimal point
+! 5. Scanning digits after a decimal point
+! 6. E, D, Q, or M - precision indicator before the exponent
+! 7. Sign of the exponent
+! 8. Scanning exponent
+! 9. Comma between the real and imaginary part
+! 10. Sign of the number
+! 11. Scanning digits before a decimal point
+! 12. Decimal point
+! 13. Scanning digits after a decimal point
+! 14. E, D, Q, or M - precision indicator before the exponent
+! 15. Sign of the exponent
+! 16. Scanning exponent
+! 17. Syntax error
+
+! Character types recognized by the machine:
+
+! 1. Sign (+,-)
+! 2. Numeral (0,1,...,9)
+! 3. Decimal point (.)
+! 4. Precision indicator (E,D,Q,M)
+! 5. Illegal character for number
+! 6. Comma (,)
+! 7. Character to be ignored ' ' '(' ')' '*'
+
+! All blanks are ignored. The analysis of the number proceeds as
+! follows: If the simulated machine is in state JSTATE and a character
+! of type JTYPE is encountered the new state of the machine is given by
+! JTRANS(JSTATE,JTYPE).
+
+! State 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
+
+ INTEGER :: JTRANS(16,4) = RESHAPE( (/ &
+ 2, 17, 10, 10, 10, 7, 17, 10, 10, 17, 17, 17, 17, 15, 17, 17, &
+ 3, 3, 3, 5, 5, 8, 8, 8, 11, 11, 11, 13, 13, 16, 16, 16, &
+ 4, 4, 4, 17, 17, 17, 17, 17, 12, 12, 12, 17, 17, 17, 17, 17, &
+ 6, 6, 6, 6, 6, 8, 17, 17, 14, 14, 14, 14, 14, 16, 17, 17 /) &
+ , (/ 16,4 /) )
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMINP '
+ NDSAVE = NDIG
+ KASAVE = KACCSW
+ KRSAVE = KROUND
+ KROUND = 1
+ KFLAG = 0
+
+! Initialize two hash tables that are used for character
+! look-up during input conversion.
+
+ IF (LHASH == 0) CALL FMHTBL
+
+! Since arithmetic tracing is not usually desired during
+! I/O conversion, disable tracing during this routine.
+
+ NTRSAV = NTRACE
+ NTRACE = 0
+
+! Increase the working precision.
+
+ IF (NCALL <= 2) THEN
+ K = NGRD52
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL ZMWARN
+ MA(-1) = 1
+ MA(0) = NINT(NDSAVE*ALOGM2)
+ MA(1) = MUNKNO
+ MA(2) = 1
+ MA(KPTIMU-1) = 1
+ MA(KPTIMU) = NINT(NDSAVE*ALOGM2)
+ MA(KPTIMU+1) = MUNKNO
+ MA(KPTIMU+2) = 1
+ DO J = 2, NDSAVE
+ MA(J+1) = 0
+ MA(KPTIMU+J+1) = 0
+ ENDDO
+ GO TO 110
+ ENDIF
+ ENDIF
+ KSTART = LA
+ KSTOP = LB
+ JSTATE = 1
+ KSTRTR = 0
+ KSTOPR = 0
+ KSTRTI = 0
+ KSTOPI = 0
+ KDIGFL = 0
+ KIFLAG = 0
+ KSIGN = 1
+
+! Scan the number.
+
+ DO J = KSTART, KSTOP
+ IF (LINE(J) == ' ' .OR. LINE(J) == '(' .OR. LINE(J) == ')' &
+ .OR. LINE(J) == '*') CYCLE
+ IF (LINE(J) == 'I' .OR. LINE(J) == 'i') THEN
+ KIFLAG = 1
+ IF (KSTRTI == 0) THEN
+ KSTRTI = KSTRTR
+ KSTOPI = KSTOPR
+ KSTRTR = 0
+ KSTOPR = 0
+ ENDIF
+ CYCLE
+ ENDIF
+
+ KPT = ICHAR(LINE(J))
+ IF (KPT < LHASH1 .OR. KPT > LHASH2) THEN
+ WRITE (KW, &
+ "(/' Error in input conversion.'/" // &
+ "' ICHAR function was out of range for the current'," // &
+ "' dimensions.'/' ICHAR(''',A,''') gave the value '," // &
+ "I12,', which is outside the currently'/' dimensioned'," // &
+ "' bounds of (',I5,':',I5,') for variables KHASHT '," // &
+ "'and KHASHV.'/' Re-define the two parameters '," // &
+ "'LHASH1 and LHASH2 so the dimensions will'/' contain'," // &
+ "' all possible output values from ICHAR.'//)" &
+ ) LINE(J),KPT,LHASH1,LHASH2
+ KTYPE = 5
+ KVAL = 0
+ ELSE
+ KTYPE = KHASHT(KPT)
+ KVAL = KHASHV(KPT)
+ ENDIF
+ IF (KTYPE == 2 .OR. KTYPE == 5) KDIGFL = 1
+ IF (LINE(J) == ',') THEN
+ IF (JSTATE < 9) THEN
+ JSTATE = 9
+ ELSE
+ GO TO 120
+ ENDIF
+ ELSE
+ IF (KTYPE >= 5) KTYPE = 2
+ IF (JSTATE < 17) JSTATE = JTRANS(JSTATE,KTYPE)
+ ENDIF
+ IF (JSTATE == 9 .OR. JSTATE == 10) KDIGFL = 0
+ IF (JSTATE == 2 .OR. JSTATE == 10) KSIGN = KVAL
+
+ IF (JSTATE >= 2 .AND. JSTATE <= 8) THEN
+ IF (KSTRTR == 0) KSTRTR = J
+ KSTOPR = J
+ ENDIF
+ IF (JSTATE >= 10 .AND. JSTATE <= 16) THEN
+ IF (KSTRTI == 0) KSTRTI = J
+ KSTOPI = J
+ ENDIF
+
+ ENDDO
+
+! Form the number and return.
+
+ IF (KSTRTR > 0) THEN
+ CALL FMINP(LINE,MA,KSTRTR,KSTOPR)
+ ELSE
+ CALL FMIM(0,MA)
+ ENDIF
+ KFLAG1 = KFLAG
+
+ IF (KSTRTI > 0) THEN
+ IF (KIFLAG == 1 .AND. KDIGFL == 0) THEN
+ CALL FMIM(KSIGN,MA(KPTIMU-1))
+ ELSE
+ CALL FMINP(LINE,MA(KPTIMU-1),KSTRTI,KSTOPI)
+ ENDIF
+ ELSE IF (KIFLAG == 1) THEN
+ CALL FMIM(1,MA(KPTIMU-1))
+ ELSE
+ CALL FMIM(0,MA(KPTIMU-1))
+ ENDIF
+
+ IF (KFLAG1 /= 0 .OR. KFLAG /= 0 .OR. JSTATE == 17) GO TO 120
+
+ 110 NDIG = NDSAVE
+ KACCSW = KASAVE
+ NTRACE = NTRSAV
+ KROUND = KRSAVE
+ IF (KFLAG == 1) KFLAG = 0
+ MA(0) = NINT(NDIG*ALOGM2)
+ MA(KPTIMU) = MA(0)
+ NCALL = NCALL - 1
+ RETURN
+
+! Error in converting the number.
+
+ 120 KFLAG = -7
+ CALL ZMWARN
+ MA(-1) = 1
+ MA(0) = NINT(NDIG*ALOGM2)
+ MA(1) = MUNKNO
+ MA(2) = 1
+ MA(KPTIMU-1) = 1
+ MA(KPTIMU) = NINT(NDIG*ALOGM2)
+ MA(KPTIMU+1) = MUNKNO
+ MA(KPTIMU+2) = 1
+ DO J = 2, NDSAVE
+ MA(J+1) = 0
+ MA(KPTIMU+J+1) = 0
+ ENDDO
+ GO TO 110
+ END SUBROUTINE ZMINP
+
+ SUBROUTINE ZMINT(MA,MB)
+
+! MB = INT(MA)
+
+! The integer parts of both real and imaginary values are returned.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMINT '
+ IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)
+
+ CALL FMINT(MA,MB)
+ CALL FMINT(MA(KPTIMU-1),MB(KPTIMU-1))
+
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMINT
+
+ SUBROUTINE ZMIPWR(MA,IVAL,MB)
+
+! MB = MA ** IVAL
+
+! Raise a ZM number to an integer power.
+! The binary multiplication method used requires an average of
+! 1.5 * LOG2(IVAL) multiplications.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER IVAL
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MA2,MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER I2N,K,KASAVE,KOVUN,KWRNSV,LVLSAV,NDSAVE
+ REAL XVAL
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMIPWR'
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ CALL ZMNTR(2,MA,MA,1)
+ CALL FMNTRI(2,IVAL,0)
+ ENDIF
+ KOVUN = 0
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN .OR. &
+ MA(KPTIMU+1) == MEXPOV .OR. MA(KPTIMU+1) == MEXPUN) KOVUN = 1
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KFLAG = 0
+ KASAVE = KACCSW
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+
+! Check for special cases.
+
+ IF (MA(1) == MUNKNO .OR. MA(KPTIMU+1) == MUNKNO .OR. &
+ (IVAL <= 0 .AND. MA(2) == 0 .AND. MA(KPTIMU+2) == 0)) THEN
+ MA2 = MA(2)
+ KFLAG = -4
+ IF (IVAL <= 0 .AND. MA2 == 0) CALL ZMWARN
+ CALL ZMST2M('UNKNOWN+UNKNOWN*i',MB)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ MXEXP = MXSAVE
+ RETURN
+ ENDIF
+
+ IF (IVAL == 0) THEN
+ CALL ZMI2M(1,MB)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ MXEXP = MXSAVE
+ RETURN
+ ENDIF
+
+ IF (ABS(IVAL) == 1) THEN
+ KWRNSV = KWARN
+ KWARN = 0
+ IF (IVAL == 1) THEN
+ CALL ZMEQ(MA,MB)
+ ELSE
+ K = INT((5.0D0*DLOGTN)/DLOGMB + 2.0D0)
+ NDIG = MIN(MAX(NDIG+K,2),NDG2MX)
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
+ ENDIF
+ CALL ZMI2M(1,MZ02)
+ CALL ZMEQU(MA,MZ05,NDSAVE,NDIG)
+ CALL ZMDIV(MZ02,MZ05,MB)
+ CALL ZMEQ2_R1(MB,NDIG,NDSAVE)
+ NDIG = NDSAVE
+ ENDIF
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ KWARN = KWRNSV
+ MXEXP = MXSAVE
+ RETURN
+ ENDIF
+
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ CALL ZMI2M(0,MB)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ MXEXP = MXSAVE
+ RETURN
+ ENDIF
+
+ IF (MA(KPTIMU+2) == 0) THEN
+ NCALL = NCALL - 1
+ LVLSAV = LVLTRC
+ LVLTRC = LVLTRC - 1
+ CALL FMIPWR(MA,IVAL,MB)
+ CALL FMIM(0,MB(KPTIMU-1))
+ NCALL = NCALL + 1
+ LVLTRC = LVLSAV
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'ZMIPWR'
+ CALL ZMNTR(1,MB,MB,1)
+ ENDIF
+ NCALL = NCALL - 1
+ MXEXP = MXSAVE
+ RETURN
+ ENDIF
+
+ IF (MA(2) == 0) THEN
+ NCALL = NCALL - 1
+ LVLSAV = LVLTRC
+ LVLTRC = LVLTRC - 1
+ IF (IVAL >= 0) THEN
+ I2N = MOD(IVAL,4)
+ ELSE
+ I2N = MOD(4 - MOD(ABS(IVAL),4),4)
+ ENDIF
+ IF (I2N == 0) THEN
+ CALL FMIPWR(MA(KPTIMU-1),IVAL,MB)
+ CALL FMIM(0,MB(KPTIMU-1))
+ ELSE IF (I2N == 1) THEN
+ CALL FMIPWR(MA(KPTIMU-1),IVAL,MB(KPTIMU-1))
+ CALL FMIM(0,MB)
+ ELSE IF (I2N == 2) THEN
+ CALL FMIPWR(MA(KPTIMU-1),IVAL,MB)
+ CALL FMIM(0,MB(KPTIMU-1))
+ IF (MB(1) /= MUNKNO .AND. MB(2) /= 0) MB(-1) = -MB(-1)
+ ELSE IF (I2N == 3) THEN
+ CALL FMIPWR(MA(KPTIMU-1),IVAL,MB(KPTIMU-1))
+ CALL FMIM(0,MB)
+ IF (MB(KPTIMU+1) /= MUNKNO .AND. MB(KPTIMU+2) /= 0) &
+ MB(KPTIMU-1) = -MB(KPTIMU-1)
+ ENDIF
+ NCALL = NCALL + 1
+ LVLTRC = LVLSAV
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'ZMIPWR'
+ CALL ZMNTR(1,MB,MB,1)
+ ENDIF
+ NCALL = NCALL - 1
+ MXEXP = MXSAVE
+ RETURN
+ ENDIF
+
+! Increase the working precision.
+
+ IF (NCALL == 1) THEN
+ XVAL = ABS(IVAL) + 1
+ K = INT((5.0*REAL(DLOGTN) + 1.5*LOG(XVAL))/ALOGMB + 2.0)
+ NDIG = MAX(NDIG+K,2)
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
+ ENDIF
+ ELSE
+ XVAL = ABS(IVAL) + 1
+ K = INT(LOG(XVAL)/ALOGMB + 1.0)
+ NDIG = NDIG + K
+ ENDIF
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL ZMWARN
+ NDIG = NDSAVE
+ CALL ZMST2M('UNKNOWN+UNKNOWN*i',MB)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ MXEXP = MXSAVE
+ KACCSW = KASAVE
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+! Initialize.
+
+ KWRNSV = KWARN
+ KWARN = 0
+ K = ABS(IVAL)
+
+ CALL ZMEQ2(MA,MZ02,NDSAVE,NDIG)
+
+ IF (MOD(K,2) == 0) THEN
+ CALL ZMI2M(1,MB)
+ ELSE
+ CALL ZMEQ(MZ02,MB)
+ ENDIF
+
+! This is the multiplication loop.
+
+ 110 K = K/2
+ CALL ZMSQR(MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ IF (MOD(K,2) == 1) THEN
+ CALL ZMMPY(MZ02,MB,MZ08)
+ CALL ZMEQ(MZ08,MB)
+ ENDIF
+ IF (K > 1) GO TO 110
+
+! Invert if the exponent is negative.
+
+ IF (IVAL < 0) THEN
+ CALL ZMI2M(1,MZ02)
+ CALL ZMDIV(MZ02,MB,MZ08)
+ CALL ZMEQ(MZ08,MB)
+ ENDIF
+ KWARN = KWRNSV
+
+! Round the result and return.
+
+ MACCMB = MB(0)
+ MB(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MB(KPTIMU)
+ MB(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ CALL ZMEQ(MB,MZ01)
+ CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE ZMIPWR
+
+ SUBROUTINE ZMLG10(MA,MB)
+
+! MB = LOG10(MA).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE
+
+ CALL ZMENTR('ZMLG10',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KACCSW = 0
+ KRSAVE = KRAD
+ KRAD = 1
+
+ CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
+ CALL ZMLN(MZ07,MZ02)
+ CALL FMLNI(10,M03)
+ CALL FMDIVD(MZ02,MZ02(KPTIMU-1),M03,MZ01,MZ01(KPTIMU-1))
+
+ MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ KRAD = KRSAVE
+ RETURN
+ END SUBROUTINE ZMLG10
+
+ SUBROUTINE ZMLN(MA,MB)
+
+! MB = LN(MA).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER KASAVE,KF1,KOVUN,KRESLT,KRSAVE,NDSAVE
+ LOGICAL FMCOMP
+
+ CALL ZMENTR('ZMLN ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KACCSW = 0
+ KRSAVE = KRAD
+ KRAD = 1
+
+ CALL ZMEQU(MA,MZ06,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ KFLAG = -4
+ CALL ZMST2M('UNKNOWN+UNKNOWN*i',MZ01)
+ GO TO 110
+ ELSE IF (MA(KPTIMU+2) == 0) THEN
+ IF (MA(-1) < 0) THEN
+ CALL FMEQ(MZ06,MZ01)
+ IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
+ CALL FMLN(MZ01,M13)
+ CALL FMEQ(M13,MZ01)
+ CALL FMPI(MZ01(KPTIMU-1))
+ ELSE
+ CALL FMLN(MZ06,MZ01)
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ ENDIF
+ GO TO 110
+ ELSE IF (MA(2) == 0) THEN
+ IF (MA(KPTIMU-1) < 0) THEN
+ CALL FMEQ(MZ06(KPTIMU-1),MZ01)
+ IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
+ CALL FMLN(MZ01,M13)
+ CALL FMEQ(M13,MZ01)
+ CALL FMPI(MZ01(KPTIMU-1))
+ CALL FMDIVI_R1(MZ01(KPTIMU-1),-2)
+ ELSE
+ CALL FMLN(MZ06(KPTIMU-1),MZ01)
+ CALL FMPI(MZ01(KPTIMU-1))
+ CALL FMDIVI_R1(MZ01(KPTIMU-1),2)
+ ENDIF
+ GO TO 110
+ ENDIF
+
+! Ln(a + b i) = Ln(Abs(a + b i)) + Arg(a + b i) i.
+
+ CALL FMABS(MZ06,M03)
+ CALL FMABS(MZ06(KPTIMU-1),M04)
+
+! Check for cancellation in Ln(x).
+
+ CALL FMI2M(1,M05)
+ KF1 = 0
+ IF (FMCOMP(M03,'EQ',M05) .AND. M04(1) <= (-NDIG)) KF1 = 1
+ IF (FMCOMP(M04,'EQ',M05) .AND. M03(1) <= (-NDIG)) KF1 = 1
+
+ IF (FMCOMP(M03,'GE',M04)) THEN
+ CALL FMSUB(MZ06,M05,M03)
+ CALL FMADD(MZ06,M05,M04)
+ CALL FMMPY_R1(M03,M04)
+ CALL FMSQR(MZ06(KPTIMU-1),M04)
+ CALL FMADD_R2(M03,M04)
+ ELSE
+ CALL FMSUB(MZ06(KPTIMU-1),M05,M03)
+ CALL FMADD(MZ06(KPTIMU-1),M05,M04)
+ CALL FMMPY_R1(M03,M04)
+ CALL FMSQR(MZ06,M04)
+ CALL FMADD_R2(M03,M04)
+ ENDIF
+ CALL ZMABS(MZ06,MZ01)
+ CALL FMADD(MZ01,M05,M03)
+ CALL FMDIV_R2(M04,M03)
+ IF (KF1 == 1) THEN
+ CALL FMEQ(M03,MZ01)
+ CALL FMATN2(MZ06(KPTIMU-1),MZ06,MZ01(KPTIMU-1))
+ GO TO 110
+ ELSE IF (M03(1) < 0) THEN
+ NDIG = NDIG - INT(M03(1))
+ IF (NDIG > NDG2MX) THEN
+ NAMEST(NCALL) = 'ZMLN '
+ KFLAG = -9
+ CALL ZMWARN
+ KRESLT = 12
+ NDIG = NDSAVE
+ CALL ZMRSLT(MB,KRESLT)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ MXEXP = MXSAVE
+ KACCSW = KASAVE
+ RETURN
+ ENDIF
+ CALL ZMEQ2_R1(MZ06,NDSAVE,NDIG)
+ CALL ZMABS(MZ06,MZ01)
+ ENDIF
+
+ CALL FMLN(MZ01,M13)
+ CALL FMEQ(M13,MZ01)
+ CALL FMATN2(MZ06(KPTIMU-1),MZ06,MZ01(KPTIMU-1))
+
+ 110 MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ KRAD = KRSAVE
+ RETURN
+ END SUBROUTINE ZMLN
+
+ SUBROUTINE ZMM2I(MA,INTEG)
+
+! INTEG = MA
+
+! INTEG is set to the integer value of the real part of MA
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
+ INTEGER INTEG
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMM2I '
+ IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)
+
+ CALL FMM2I(MA,INTEG)
+
+ IF (NTRACE /= 0) CALL ZMNTRI(1,INTEG,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMM2I
+
+ SUBROUTINE ZMM2Z(MA,ZVAL)
+
+! ZVAL = MA
+
+! Complex variable ZVAL is set to MA.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
+ COMPLEX ZVAL
+
+ REAL DI,DR
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMM2Z '
+ IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)
+
+ CALL FMM2SP(MA,DR)
+ CALL FMM2SP(MA(KPTIMU-1),DI)
+ ZVAL = CMPLX(DR,DI)
+
+ IF (NTRACE /= 0) CALL ZMNTRZ(1,ZVAL,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMM2Z
+
+ SUBROUTINE ZMMPY(MA,MB,MC)
+
+! MC = MA * MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MBIZ,MBRZ,MXSAVE,MZ11SV
+ INTEGER IEXTRA,KASAVE,KMETHD,KOVUN,KRESLT,KWRNSV,NDGSV2,NDSAVE, &
+ NGOAL,NTRSAV
+
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR. &
+ ABS(MB(1)) > MEXPAB .OR. ABS(MB(KPTIMU+1)) > MEXPAB .OR. &
+ KDEBUG >= 1) THEN
+ CALL ZMENTR('ZMMPY ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'ZMMPY '
+ CALL ZMNTR(2,MA,MB,2)
+ ENDIF
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ NDIG = MAX(NDIG+NGRD52,2)
+ IF (NDIG > NDG2MX) THEN
+ NAMEST(NCALL) = 'ZMMPY '
+ KFLAG = -9
+ CALL ZMWARN
+ KRESLT = 12
+ NDIG = NDSAVE
+ CALL ZMRSLT(MC,KRESLT)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ IF (MBASE >= 100*ABS(MA(2)) .OR. &
+ MBASE >= 100*ABS(MA(KPTIMU+2))) THEN
+ NDIG = MIN(NDIG+1,NDG2MX)
+ ELSE IF (MBASE >= 100*ABS(MB(2)) .OR. &
+ MBASE >= 100*ABS(MB(KPTIMU+2))) THEN
+ NDIG = MIN(NDIG+1,NDG2MX)
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 1
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ KOVUN = 0
+ ENDIF
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
+ ENDIF
+
+ MARZ = MA(0)
+ MBRZ = MB(0)
+ MAIZ = MA(KPTIMU)
+ MBIZ = MB(KPTIMU)
+ MZ11SV = -MUNKNO
+ NTRSAV = NTRACE
+ NTRACE = 0
+ KWRNSV = KWARN
+ KWARN = 0
+
+ 110 CALL FMEQU(MA,M17,NDSAVE,NDIG)
+ CALL FMEQU(MA(KPTIMU-1),M18,NDSAVE,NDIG)
+ CALL FMEQU(MB,M19,NDSAVE,NDIG)
+ CALL FMEQU(MB(KPTIMU-1),M20,NDSAVE,NDIG)
+ IF (NCALL == 1) THEN
+ M17(0) = NINT(NDIG*ALOGM2)
+ M19(0) = M17(0)
+ M18(00) = M17(0)
+ M20(00) = M17(0)
+ ENDIF
+
+! Check for special cases.
+
+ KMETHD = 1
+ IF (NDIG >= 35) KMETHD = 2
+
+ IF (MB(KPTIMU+2) == 0) THEN
+ CALL FMMPYD(M19,M17,M18,MZ01,MZ01(KPTIMU-1))
+ ELSE IF (MB(2) == 0) THEN
+ CALL FMMPYD(M20,M18,M17,MZ01,MZ01(KPTIMU-1))
+ IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
+ ELSE IF (MA(KPTIMU+2) == 0) THEN
+ CALL FMMPYD(M17,M19,M20,MZ01,MZ01(KPTIMU-1))
+ ELSE IF (MA(2) == 0) THEN
+ CALL FMMPYD(M18,M20,M19,MZ01,MZ01(KPTIMU-1))
+ IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
+ ELSE IF (KMETHD == 1) THEN
+
+! Method 1 for ( a + b i ) * ( c + d i )
+
+! result = a*c - b*d + ( a*d + b*c ) i
+
+ KACCSW = 0
+ CALL FMMPYD(M17,M19,M20,MZ01,MZ01(KPTIMU-1))
+ CALL FMMPYD(M18,M20,M19,M01,M02)
+ IF (MZ01(-1)*M01(-1) < 0) THEN
+ KACCSW = 0
+ ELSE
+ KACCSW = 1
+ ENDIF
+ CALL FMSUB_R1(MZ01,M01)
+ IF (MZ01(KPTIMU-1)*M02(-1) < 0) THEN
+ KACCSW = 1
+ ELSE
+ KACCSW = 0
+ ENDIF
+ CALL FMADD_R1(MZ01(KPTIMU-1),M02)
+ KACCSW = 1
+ ELSE
+
+! Method 2 for ( a + b i ) * ( c + d i )
+
+! P = ( a + b )*( c + d )
+! result = a*c - b*d + ( P - a*c - b*d ) i
+
+ CALL FMADD(M17,M18,M01)
+ CALL FMADD(M19,M20,M02)
+ CALL FMMPY_R1(M01,M02)
+
+ CALL FMMPY(M17,M19,M02)
+ CALL FMMPY(M18,M20,M03)
+
+ CALL FMSUB(M02,M03,MZ01)
+ CALL FMSUB(M01,M02,MZ01(KPTIMU-1))
+ CALL FMSUB_R1(MZ01(KPTIMU-1),M03)
+ ENDIF
+
+! Check for too much cancellation.
+
+ IF (NCALL <= 1) THEN
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7
+ ELSE
+ NGOAL = INT(-MXEXP2)
+ ENDIF
+ IF (MZ01(0) <= NGOAL .OR. MZ01(KPTIMU) <= NGOAL) THEN
+ IF (MZ11SV > -MUNKNO .AND. MZ01(0) > NGOAL .AND. &
+ MZ01(KPTIMU+2) == 0) GO TO 120
+ IF (MZ11SV > -MUNKNO .AND. MZ01(KPTIMU) > NGOAL .AND. &
+ MZ01(2) == 0) GO TO 120
+ IEXTRA = INT(REAL(MAX(NGOAL-MZ01(0),NGOAL-MZ01(KPTIMU))) &
+ /ALOGM2 + 23.03/ALOGMB) + 1
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ NAMEST(NCALL) = 'ZMMPY '
+ KFLAG = -9
+ CALL ZMWARN
+ NDIG = NDSAVE
+ CALL ZMST2M('UNKNOWN+UNKNOWN*i',MZ01)
+ GO TO 120
+ ENDIF
+ MZ11SV = MZ01(1)
+ GO TO 110
+ ENDIF
+
+ 120 MXEXP = MXSAVE
+ NTRACE = NTRSAV
+ NDGSV2 = NDIG
+ NDIG = NDSAVE
+ KWARN = KWRNSV
+ MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)
+ CALL ZMEQ2(MZ01,MC,NDGSV2,NDSAVE)
+ IF (MC(1) >= MEXPOV .OR. MC(1) <= -MEXPOV .OR. &
+ MC(KPTIMU+1) >= MEXPOV .OR. MC(KPTIMU+1) <= -MEXPOV) THEN
+ IF (MC(1) == MUNKNO .OR. MC(KPTIMU+1) == MUNKNO) THEN
+ KFLAG = -4
+ ELSE IF (MC(1) == MEXPOV .OR. MC(KPTIMU+1) == MEXPOV) THEN
+ KFLAG = -5
+ ELSE IF (MC(1) == MEXPUN .OR. MC(KPTIMU+1) == MEXPUN) THEN
+ KFLAG = -6
+ ENDIF
+ IF ((MC(1) == MUNKNO) &
+ .OR. (MC(KPTIMU+1) == MUNKNO) &
+ .OR. (MC(1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MC(KPTIMU+1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MC(1) == MEXPOV .AND. KOVUN == 0) &
+ .OR. (MC(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
+ NAMEST(NCALL) = 'ZMMPY '
+ CALL ZMWARN
+ ENDIF
+ ENDIF
+ IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
+ KACCSW = KASAVE
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMMPY
+
+ SUBROUTINE ZMMPYI(MA,INTEG,MB)
+
+! MB = MA * INTEG Multiply by one-word (real) integer.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ INTEGER INTEG
+
+ INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV
+ REAL (KIND(1.0D0)) :: MXSAVE
+
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR. &
+ KDEBUG >= 1) THEN
+ NTRSAV = NTRACE
+ IF (NTRACE /= 0) THEN
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMMPYI'
+ CALL ZMNTR(2,MA,MA,1)
+ CALL FMNTRI(2,INTEG,0)
+ NCALL = NCALL - 1
+ ENDIF
+ NTRACE = 0
+ CALL ZMENTR('ZMMPYI',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ NTRACE = NTRSAV
+ IF (KRESLT /= 0) THEN
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ NDIG = NDSAVE
+ MXEXP = MXSAVE
+ KACCSW = KASAVE
+ NTRSAV = NTRACE
+ ELSE
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'ZMMPYI'
+ CALL ZMNTR(2,MA,MA,1)
+ CALL FMNTRI(2,INTEG,0)
+ ENDIF
+ KOVUN = 0
+ ENDIF
+
+! Force FMMPYI to use more guard digits for user calls.
+
+ NCALL = NCALL - 1
+ NTRSAV = NTRACE
+ NTRACE = 0
+ KWRNSV = KWARN
+ KWARN = 0
+
+ CALL FMMPYI(MA,INTEG,MB)
+ CALL FMMPYI(MA(KPTIMU-1),INTEG,MB(KPTIMU-1))
+
+ NTRACE = NTRSAV
+ KWARN = KWRNSV
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) NAMEST(NCALL) = 'ZMMPYI'
+ IF (MB(1) == MUNKNO .OR. MB(KPTIMU+1) == MUNKNO) THEN
+ KFLAG = -4
+ ELSE IF (MB(1) == MEXPOV .OR. MB(KPTIMU+1) == MEXPOV) THEN
+ KFLAG = -5
+ ELSE IF (MB(1) == MEXPUN .OR. MB(KPTIMU+1) == MEXPUN) THEN
+ KFLAG = -6
+ ENDIF
+ IF ((MB(1) == MUNKNO) &
+ .OR. (MB(KPTIMU+1) == MUNKNO) &
+ .OR. (MB(1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MB(KPTIMU+1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MB(1) == MEXPOV .AND. KOVUN == 0) &
+ .OR. (MB(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
+ NAMEST(NCALL) = 'ZMMPYI'
+ CALL ZMWARN
+ ENDIF
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMMPYI
+
+ SUBROUTINE ZMNINT(MA,MB)
+
+! MB = NINT(MA)
+
+! The nearest integers to both real and imaginary parts are returned.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMNINT'
+ IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)
+
+ CALL FMNINT(MA,MB)
+ CALL FMNINT(MA(KPTIMU-1),MB(KPTIMU-1))
+
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMNINT
+
+ SUBROUTINE ZMNTR(NTR,MA,MB,NARG)
+
+! Print ZM numbers in base 10 format using ZMOUT for conversion.
+! This is used for trace output from the ZM routines.
+
+! NTR = 1 if a result of an ZM call is to be printed.
+! = 2 to print input argument(s) to an ZM call.
+
+! MA - the ZM number to be printed.
+
+! MB - an optional second ZM number to be printed.
+
+! NARG - the number of arguments. NARG = 1 if only MA is to be
+! printed, and NARG = 2 if both MA and MB are to be printed.
+
+
+! NTRACE and LVLTRC (in module FMVALS) control trace printout.
+
+! NTRACE = 0 No printout except warnings and errors.
+
+! NTRACE = 1 The result of each call to one of the routines
+! is printed in base 10, using ZMOUT.
+
+! NTRACE = -1 The result of each call to one of the routines
+! is printed in internal base MBASE format.
+
+! NTRACE = 2 The input arguments and result of each call to one
+! of the routines is printed in base 10, using ZMOUT.
+
+! NTRACE = -2 The input arguments and result of each call to one
+! of the routines is printed in base MBASE format.
+
+! LVLTRC defines the call level to which the trace is done. LVLTRC = 1
+! means only FM routines called directly by the user are traced,
+! LVLTRC = K prints traces for ZM or FM routines with call
+! levels up to and including level K.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ INTEGER NTR,NARG
+
+ CHARACTER(6) :: NAME
+
+ IF (NTRACE == 0) RETURN
+ IF (NCALL > LVLTRC) RETURN
+ IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN
+
+ IF (NTR == 2) THEN
+ NAME = NAMEST(NCALL)
+ WRITE (KW,"(' Input to ',A6)") NAME
+ ELSE
+ NAME = NAMEST(NCALL)
+ IF (KFLAG == 0) THEN
+ WRITE (KW, &
+ "(' ',A6,15X,'Call level =',I2,5X,'MBASE ='," // &
+ "I10,5X,'NDIG =',I6)" &
+ ) NAME,NCALL,INT(MBASE),NDIG
+ ELSE
+ WRITE (KW, &
+ "(' ',A6,6X,'Call level =',I2,4X,'MBASE ='," // &
+ "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)" &
+ ) NAME,NCALL,INT(MBASE),NDIG,KFLAG
+ ENDIF
+ ENDIF
+
+! Check for base MBASE internal format trace.
+
+ IF (NTRACE < 0) THEN
+ CALL ZMNTRJ(MA,NDIG)
+ IF (NARG == 2) CALL ZMNTRJ(MB,NDIG)
+ ENDIF
+
+! Check for base 10 trace using ZMOUT.
+
+ IF (NTRACE > 0) THEN
+ CALL ZMPRNT(MA)
+
+ IF (NARG == 2) THEN
+ CALL ZMPRNT(MB)
+ ENDIF
+ ENDIF
+
+ RETURN
+ END SUBROUTINE ZMNTR
+
+ SUBROUTINE ZMNTR2(NTR,MAFM,MBFM,NARG)
+
+! Print real FM numbers in base 10 format using FMOUT for conversion.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MAFM(-1:LUNPCK),MBFM(-1:LUNPCK)
+ INTEGER NTR,NARG
+
+ CHARACTER(6) :: NAME
+
+ IF (NTRACE == 0) RETURN
+ IF (NCALL > LVLTRC) RETURN
+ IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN
+
+ IF (NTR == 2) THEN
+ NAME = NAMEST(NCALL)
+ WRITE (KW,"(' Input to ',A6)") NAME
+ ELSE
+ NAME = NAMEST(NCALL)
+ IF (KFLAG == 0) THEN
+ WRITE (KW, &
+ "(' ',A6,15X,'Call level =',I2,5X,'MBASE ='," // &
+ "I10,5X,'NDIG =',I6)" &
+ ) NAME,NCALL,INT(MBASE),NDIG
+ ELSE
+ WRITE (KW, &
+ "(' ',A6,6X,'Call level =',I2,4X,'MBASE ='," // &
+ "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)" &
+ ) NAME,NCALL,INT(MBASE),NDIG,KFLAG
+ ENDIF
+ ENDIF
+
+! Check for base MBASE internal format trace.
+
+ IF (NTRACE < 0) THEN
+ CALL FMNTRJ(MAFM,NDIG)
+ IF (NARG == 2) CALL FMNTRJ(MBFM,NDIG)
+ ENDIF
+
+! Check for base 10 trace using FMOUT.
+
+ IF (NTRACE > 0) THEN
+ CALL FMPRNT(MAFM)
+
+ IF (NARG == 2) THEN
+ CALL FMPRNT(MBFM)
+ ENDIF
+ ENDIF
+
+ RETURN
+ END SUBROUTINE ZMNTR2
+
+ SUBROUTINE ZMNTRI(NTR,N,KNAM)
+
+! Internal routine for trace output of integer variables.
+
+! NTR = 1 for output values
+! 2 for input values
+
+! N Integer to be printed.
+
+! KNAM is positive if the routine name is to be printed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER NTR,N,KNAM
+
+ CHARACTER(6) :: NAME
+
+ IF (NTRACE == 0) RETURN
+ IF (NCALL > LVLTRC) RETURN
+ IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN
+
+ IF (NTR == 2 .AND. KNAM > 0) THEN
+ NAME = NAMEST(NCALL)
+ WRITE (KW,"(' Input to ',A6)") NAME
+ ENDIF
+ IF (NTR == 1 .AND. KNAM > 0) THEN
+ NAME = NAMEST(NCALL)
+ IF (KFLAG == 0) THEN
+ WRITE (KW, &
+ "(' ',A6,15X,'Call level =',I2,5X,'MBASE ='," // &
+ "I10,5X,'NDIG =',I6)" &
+ ) NAME,NCALL,INT(MBASE),NDIG
+ ELSE
+ WRITE (KW, &
+ "(' ',A6,6X,'Call level =',I2,4X,'MBASE ='," // &
+ "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)" &
+ ) NAME,NCALL,INT(MBASE),NDIG,KFLAG
+ ENDIF
+ ENDIF
+
+ WRITE (KW,"(1X,I18)") N
+
+ RETURN
+ END SUBROUTINE ZMNTRI
+
+ SUBROUTINE ZMNTRJ(MA,ND)
+
+! Print trace output in internal base MBASE format. The number to
+! be printed is in MA.
+
+! ND is the number of base MBASE digits to be printed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
+ INTEGER ND
+
+ CHARACTER(50) :: FORM
+ INTEGER J,L,N,N1
+
+ N1 = ND + 1
+
+ L = INT(LOG10(DBLE(MBASE-1))) + 2
+ N = (KSWIDE-23)/L
+ IF (N > 10) N = 5*(N/5)
+ IF (ND <= N) THEN
+ WRITE (FORM,"(' (1X,I19,I',I2,',',I3,'I',I2,') ')") L+2, N-1, L
+ ELSE
+ WRITE (FORM, &
+ "(' (1X,I19,I',I2,',',I3,'I',I2," // &
+ "'/(22X,',I3,'I',I2,')) ')" &
+ ) L+2, N-1, L, N, L
+ ENDIF
+ WRITE (KW,FORM) INT(MA(1)),INT(MA(-1)*MA(2)),(INT(MA(J)),J=3,N1)
+ WRITE (KW,FORM) INT(MA(KPTIMU+1)),INT(MA(KPTIMU-1)*MA(KPTIMU+2)), &
+ (INT(MA(KPTIMU+J)),J=3,N1)
+
+ RETURN
+ END SUBROUTINE ZMNTRJ
+
+ SUBROUTINE ZMNTRZ(NTR,X,KNAM)
+
+! Internal routine for trace output of complex variables.
+
+! NTR - 1 for output values
+! 2 for input values
+
+! X - Complex value to be printed if NX == 1
+
+! KNAM - Positive if the routine name is to be printed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER NTR,KNAM
+ COMPLEX X
+
+ CHARACTER(6) :: NAME
+ DOUBLE PRECISION XREAL,XIMAG
+
+ IF (NTRACE == 0) RETURN
+ IF (NCALL > LVLTRC) RETURN
+ IF (NTR == 2 .AND. ABS(NTRACE) == 1) RETURN
+
+ IF (NTR == 2 .AND. KNAM > 0) THEN
+ NAME = NAMEST(NCALL)
+ WRITE (KW,"(' Input to ',A6)") NAME
+ ENDIF
+ IF (NTR == 1 .AND. KNAM > 0) THEN
+ NAME = NAMEST(NCALL)
+ IF (KFLAG == 0) THEN
+ WRITE (KW, &
+ "(' ',A6,15X,'Call level =',I2,5X,'MBASE ='," // &
+ "I10,5X,'NDIG =',I6)" &
+ ) NAME,NCALL,INT(MBASE),NDIG
+ ELSE
+ WRITE (KW, &
+ "(' ',A6,6X,'Call level =',I2,4X,'MBASE ='," // &
+ "I10,4X,'NDIG =',I6,4X,'KFLAG =',I3)" &
+ ) NAME,NCALL,INT(MBASE),NDIG,KFLAG
+ ENDIF
+ ENDIF
+
+ XREAL = DBLE(X)
+ XIMAG = DBLE(AIMAG(X))
+ IF (XIMAG >= 0.0D0) THEN
+ WRITE (KW,"(1X,D30.20,' +',D30.20,' i')") XREAL,XIMAG
+ ELSE
+ WRITE (KW,"(1X,D30.20,' -',D30.20,' i')") XREAL,ABS(XIMAG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE ZMNTRZ
+
+ SUBROUTINE ZMOUT(MA,LINE,LB,LAST1,LAST2)
+
+! Convert a floating multiple precision number to a character array
+! for output.
+
+! MA is an ZM number to be converted to an A1 character
+! array in base 10 format
+! LINE is the CHARACTER*1 array in which the result is returned.
+! LB is the length of LINE.
+! LAST1 is the position of the last nonblank character of the
+! real part of the number in LINE.
+! LAST2 is the position of the last nonblank character of the
+! imaginary part of the number in LINE.
+
+! JFORM1 and JFORM2 determine the format of the two FM numbers
+! making up the complex value MA. See FMOUT for details.
+
+! JFORMZ determines the format of the real and imaginary parts.
+
+! JFORMZ = 1 normal setting : 1.23 - 4.56 i
+! = 2 use capital I : 1.23 - 4.56 I
+! = 3 parenthesis format ( 1.23 , -4.56 )
+
+! LINE should be dimensioned at least 4*(LOG10(MBASE)*NDIG + 15) on a
+! 32-bit machine to allow for up to 10 digit exponents. Replace
+! 15 by 20 if 48-bit integers are used, 25 for 64-bit integers, etc.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MI(-1:LUNPCK)
+ INTEGER LB,LAST1,LAST2
+ CHARACTER LINE(LB)
+
+ REAL (KIND(1.0D0)) :: MAIMS
+ INTEGER J,KPT,LB2,ND,NEXP
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMOUT '
+ DO J = 1, LB
+ LINE(J) = ' '
+ ENDDO
+ ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
+ IF (ND < 2) ND = 2
+ NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
+ KPT = 1
+ IF (JFORMZ == 3) KPT = 3
+ LB2 = MAX(JFORM2+NEXP,ND+NEXP)
+ LB2 = MIN(LB+1-KPT,LB2)
+ CALL FMOUT(MA,LINE(KPT),LB2)
+
+ IF (JFORMZ == 3) LINE(1) = '('
+ LAST1 = 1
+ DO J = LB2, 1, -1
+ IF (LINE(J) /= ' ') THEN
+ LAST1 = J
+ GO TO 110
+ ENDIF
+ ENDDO
+
+ 110 MAIMS = MA(KPTIMU-1)
+ DO J = -1, NDIG+1
+ MI(J) = MA(KPTIMU+J)
+ ENDDO
+ LINE(LAST1+1) = ' '
+ IF (JFORMZ == 3) THEN
+ LINE(LAST1+2) = ','
+ ELSE
+ IF (MAIMS < 0) THEN
+ MI(-1) = 1
+ LINE(LAST1+2) = '-'
+ ELSE
+ LINE(LAST1+2) = '+'
+ ENDIF
+ ENDIF
+
+ KPT = LAST1 + 3
+ LB2 = MAX(JFORM2+NEXP,ND+NEXP)
+ LB2 = MIN(LB+1-KPT,LB2+2)
+ CALL FMOUT(MI,LINE(KPT),LB2)
+ LAST1 = KPT
+ DO J = LB2+KPT-1, KPT, -1
+ IF (LINE(J) /= ' ') THEN
+ LAST2 = J
+ GO TO 120
+ ENDIF
+ ENDDO
+
+ 120 LAST2 = LAST2 + 2
+ LINE(LAST2) = 'i'
+ IF (JFORMZ == 2) LINE(LAST2) = 'I'
+ IF (JFORMZ == 3) LINE(LAST2) = ')'
+
+ IF (LINE(KPT) == ' ' .AND. LINE(KPT+1) == '+') THEN
+ DO J = KPT+2, LAST2
+ LINE(J-2) = LINE(J)
+ ENDDO
+ LINE(LAST2-1) = ' '
+ LINE(LAST2) = ' '
+ LAST2 = LAST2 - 2
+ ENDIF
+
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMOUT
+
+ SUBROUTINE ZMPACK(MA,MP)
+
+! MA is packed two base NDIG digits per word and returned in MP.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MP(-1:LPACKZ)
+ CALL FMPACK(MA,MP)
+ CALL FMPACK(MA(KPTIMU-1),MP(KPTIMP))
+ RETURN
+ END SUBROUTINE ZMPACK
+
+ SUBROUTINE ZMPRNT(MA)
+
+! Print MA in base 10 format.
+
+! ZMPRNT can be called directly by the user for easy output
+! in M format. MA is converted using ZMOUT and printed.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
+
+ CHARACTER(20) :: FORM
+ INTEGER K,KSAVE,LAST1,LAST2,LB,LBZ,ND,NEXP
+
+ KSAVE = KFLAG
+ ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
+ IF (ND < 2) ND = 2
+ NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
+ LB = MAX(JFORM2+NEXP,ND+NEXP)
+
+ IF (2*LB+7 <= LMBUFZ .AND. JPRNTZ == 1) THEN
+ LBZ = 2*LB + 7
+ CALL ZMOUT(MA,CMBUFZ,LBZ,LAST1,LAST2)
+ WRITE (FORM,"(' (6X,',I3,'A1) ')") KSWIDE-7
+ WRITE (KW,FORM) (CMBUFZ(K),K=1,LAST2)
+ ELSE
+ CALL FMPRNT(MA)
+ CALL FMPRNT(MA(KPTIMU-1))
+ ENDIF
+ KFLAG = KSAVE
+ RETURN
+ END SUBROUTINE ZMPRNT
+
+ SUBROUTINE ZMPWR(MA,MB,MC)
+
+! MC = MA ** MB.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ)
+! MZ06, MZ07
+
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MBIZ,MBRZ,MXSAVE,MTEMP
+ INTEGER IEXTRA,INTMB,J,JSIN,JCOS,JSWAP,K,KASAVE,KOVUN, &
+ KRADSV,KRESLT,KWRNSV,NDSAVE
+ LOGICAL FMCOMP
+ REAL XVAL
+
+ CALL ZMENTR('ZMPWR ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ MARZ = MA(0)
+ MBRZ = MB(0)
+ MAIZ = MA(KPTIMU)
+ MBIZ = MB(KPTIMU)
+ KACCSW = 0
+ NDIG = MIN(NDIG+1,NDG2MX)
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
+ ENDIF
+
+ CALL ZMEQU(MA,MZ06,NDSAVE,NDIG)
+ CALL ZMEQU(MB,MZ07,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ IF (MB(-1) > 0 .AND. MB(KPTIMU+2) == 0) THEN
+ CALL ZMI2M(0,MZ02)
+ GO TO 110
+ ELSE
+ KFLAG = -4
+ CALL ZMST2M('UNKNOWN+UNKNOWN*i',MZ02)
+ GO TO 110
+ ENDIF
+ ENDIF
+ IF (MB(KPTIMU+2) == 0) THEN
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMMI(MZ07,INTMB)
+ KWARN = KWRNSV
+ IF (KFLAG == 0) THEN
+ IF (NCALL == 1) THEN
+ XVAL = ABS(INTMB) + 1
+ K = INT((1.5*LOG(XVAL))/ALOGMB + 2.0)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL ZMWARN
+ NDIG = NDSAVE
+ CALL ZMST2M('UNKNOWN+UNKNOWN*i',MC)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
+ ENDIF
+ IF (MBASE >= 100*ABS(MA(2)) .OR. &
+ MBASE >= 100*ABS(MA(KPTIMU+2))) THEN
+ NDIG = MIN(NDIG+1,NDG2MX)
+ ENDIF
+ ENDIF
+ CALL ZMEQ2_R1(MZ06,NDSAVE,NDIG)
+ CALL ZMIPWR(MZ06,INTMB,MZ03)
+ CALL ZMEQ(MZ03,MZ02)
+ GO TO 110
+ ENDIF
+ ENDIF
+
+! Check for cases where ABS(MA) is very close to 1, and
+! avoid cancellation.
+
+ CALL FMABS(MZ06,M03)
+ CALL FMABS(MZ06(KPTIMU-1),M04)
+ CALL FMI2M(1,M05)
+ IF (FMCOMP(M03,'EQ',M05) .AND. &
+ (M04(1) <= (-NDIG).OR.M04(2) == 0)) THEN
+ IF (MA(-1) > 0) THEN
+
+! (1+c)**b = 1 + b*c + ...
+
+ CALL ZMI2M(1,MZ02)
+ CALL ZMSUB(MZ06,MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL ZMMPY(MZ07,MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL FMADD_R1(MZ02,M05)
+ ELSE
+
+! (-1+c)**b = (-1)**b * (1 - b*c + ... )
+
+ CALL ZMI2M(-1,MZ02)
+ CALL ZMSUB(MZ06,MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL ZMMPY(MZ07,MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL ZMMPYI(MZ02,-1,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL FMADD_R1(MZ02,M05)
+ KRADSV = KRAD
+ KRAD = 0
+ IF (MA(KPTIMU-1) >= 0) THEN
+ CALL FMMPYI(MZ07,180,M06)
+ ELSE
+ CALL FMMPYI(MZ07,-180,M06)
+ ENDIF
+ CALL FMCSSN(M06,MZ03,MZ03(KPTIMU-1))
+ KRAD = KRADSV
+ CALL FMPI(M05)
+ CALL FMMPY_R1(M05,MZ07(KPTIMU-1))
+ IF (MA(KPTIMU-1) >= 0) CALL FMMPYI_R1(M05,-1)
+ CALL FMEXP(M05,M12)
+ CALL FMEQ(M12,M05)
+ CALL FMMPYD(M05,MZ03,MZ03(KPTIMU-1),MZ08,MZ08(KPTIMU-1))
+ CALL ZMEQ(MZ08,MZ03)
+ CALL ZMMPY(MZ02,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ ENDIF
+ GO TO 110
+ ENDIF
+ IF (FMCOMP(M04,'EQ',M05) .AND. &
+ (M03(1) <= (-NDIG).OR.M03(2) == 0)) THEN
+ IF (MA(KPTIMU-1) > 0) THEN
+
+! (i+c)**b = i**b * (1 - b*c*i - ... )
+
+ CALL ZM2I2M(0,1,MZ02)
+ CALL ZMSUB(MZ06,MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL ZMMPY(MZ07,MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ DO J = -1, NDIG+1
+ MTEMP = MZ02(J)
+ MZ02(J) = MZ02(KPTIMU+J)
+ MZ02(KPTIMU+J) = MTEMP
+ ENDDO
+ IF (MZ02(KPTIMU+1) /= MUNKNO .AND. MZ02(KPTIMU+2) /= 0) &
+ MZ02(KPTIMU-1) = -MZ02(KPTIMU-1)
+ CALL FMADD_R1(MZ02,M05)
+ KRADSV = KRAD
+ KRAD = 0
+ CALL FMMPYI(MZ07,90,M06)
+ CALL FMCSSN(M06,MZ03,MZ03(KPTIMU-1))
+ KRAD = KRADSV
+ CALL FMPI(M05)
+ CALL FMMPY_R1(M05,MZ07(KPTIMU-1))
+ CALL FMDIVI_R1(M05,-2)
+ CALL FMEXP(M05,M12)
+ CALL FMEQ(M12,M05)
+ CALL FMMPYD(M05,MZ03,MZ03(KPTIMU-1),MZ08,MZ08(KPTIMU-1))
+ CALL ZMEQ(MZ08,MZ03)
+ CALL ZMMPY(MZ02,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ ELSE
+
+! (-i+c)**b = (-i)**b * (1 + b*c*i - ... )
+
+ CALL ZM2I2M(0,-1,MZ02)
+ CALL ZMSUB(MZ06,MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ CALL ZMMPY(MZ07,MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ DO J = -1, NDIG+1
+ MTEMP = MZ02(J)
+ MZ02(J) = MZ02(KPTIMU+J)
+ MZ02(KPTIMU+J) = MTEMP
+ ENDDO
+ IF (MZ02(1) /= MUNKNO .AND. MZ02(2) /= 0) MZ02(-1) = -MZ02(-1)
+ CALL FMADD_R1(MZ02,M05)
+ KRADSV = KRAD
+ KRAD = 0
+ CALL FMMPYI(MZ07,-90,M06)
+ CALL FMCSSN(M06,MZ03,MZ03(KPTIMU-1))
+ KRAD = KRADSV
+ CALL FMPI(M05)
+ CALL FMMPY_R1(M05,MZ07(KPTIMU-1))
+ CALL FMDIVI_R1(M05,2)
+ CALL FMEXP(M05,M12)
+ CALL FMEQ(M12,M05)
+ CALL FMMPYD(M05,MZ03,MZ03(KPTIMU-1),MZ08,MZ08(KPTIMU-1))
+ CALL ZMEQ(MZ08,MZ03)
+ CALL ZMMPY(MZ02,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ ENDIF
+ GO TO 110
+ ENDIF
+
+ CALL ZMLN(MZ06,MZ02)
+ CALL ZMMPY(MZ07,MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMEQ(MZ02(KPTIMU-1),MZ01)
+ CALL FMRDC(MZ01,JSIN,JCOS,JSWAP)
+ KWARN = KWRNSV
+ IF (KFLAG == -9) THEN
+ IEXTRA = INT(MZ01(1))
+ ELSE
+ IEXTRA = INT(MZ02(KPTIMU+1) - MZ01(1))
+ ENDIF
+ IF (IEXTRA > 1) THEN
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL ZMWARN
+ NDIG = NDIG - IEXTRA
+ CALL ZMST2M('UNKNOWN+UNKNOWN*i',MZ02)
+ GO TO 110
+ ENDIF
+ CALL ZMEQ2_R1(MZ06,NDSAVE,NDIG)
+ CALL ZMEQ2_R1(MZ07,NDSAVE,NDIG)
+ CALL ZMLN(MZ06,MZ02)
+ CALL ZMMPY(MZ07,MZ02,MZ08)
+ CALL ZMEQ(MZ08,MZ02)
+ ENDIF
+
+ CALL ZMEXP(MZ02,MZ06)
+ CALL ZMEQ(MZ06,MZ02)
+
+ 110 MACCMB = MZ02(0)
+ MZ02(0) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)
+ MACCMB = MZ02(KPTIMU)
+ MZ02(KPTIMU) = MIN(MACCMB,MARZ,MAIZ,MBRZ,MBIZ)
+ CALL ZMEXIT(MZ02,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE ZMPWR
+
+ SUBROUTINE ZMREAD(KREAD,MA)
+
+! Read MA on unit KREAD. Multi-line numbers will have '&' as the
+! last nonblank character on all but the last line. Only one
+! number is allowed on the line(s).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER KREAD
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
+
+ CHARACTER LINE(80)
+ INTEGER J,LB
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMREAD'
+ LB = 0
+
+ 110 READ (KREAD,"(80A1)",ERR=120,END=120) LINE
+
+! Scan the line and look for '&'
+
+ DO J = 1, 80
+ IF (LINE(J) == '&') GO TO 110
+ IF (LINE(J) /= ' ') THEN
+ LB = LB + 1
+ IF (LB > LMBUFZ) THEN
+ KFLAG = -8
+ GO TO 130
+ ENDIF
+ CMBUFZ(LB) = LINE(J)
+ ENDIF
+ ENDDO
+
+ CALL ZMINP(CMBUFZ,MA,1,LB)
+
+ NCALL = NCALL - 1
+ RETURN
+
+! If there is an error, return UNKNOWN.
+
+ 120 KFLAG = -4
+ 130 CALL ZMWARN
+ CALL ZMST2M('UNKNOWN+UNKNOWN*i',MA)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMREAD
+
+ SUBROUTINE ZMREAL(MA,MBFM)
+
+! MBFM = REAL(MA)
+
+! MA is a complex ZM number, MBFM is a real FM number.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MBFM(-1:LUNPCK)
+
+ KFLAG = 0
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMREAL'
+ IF (NTRACE /= 0) CALL ZMNTR(2,MA,MA,1)
+
+ CALL FMEQ(MA,MBFM)
+
+ IF (NTRACE /= 0) CALL FMNTR(1,MBFM,MBFM,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMREAL
+
+ SUBROUTINE ZMRPWR(MA,IVAL,JVAL,MB)
+
+! MB = MA ** (IVAL/JVAL)
+
+! Raise a ZM number to a rational power.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ INTEGER IVAL,JVAL
+ REAL (KIND(1.0D0)) :: MA2,MACCMB,MAIZ,MARZ,MR1,MXSAVE
+ INTEGER IJSIGN,INVERT,IVAL2,J,JVAL2,K,KASAVE,KOVUN,KST,L,LVAL, &
+ NDSAVE
+ REAL XVAL
+
+ DOUBLE PRECISION AR,BR,F,THETA,X
+ INTEGER NSTACK(19)
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMRPWR'
+ NDSAVE = NDIG
+ IF (NTRACE /= 0) THEN
+ CALL ZMNTR(2,MA,MA,1)
+ CALL FMNTRI(2,IVAL,0)
+ CALL FMNTRI(2,JVAL,0)
+ ENDIF
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN .OR. &
+ MA(KPTIMU+1) == MEXPOV .OR. MA(KPTIMU+1) == MEXPUN) KOVUN = 1
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KFLAG = 0
+ IJSIGN = 1
+ IVAL2 = ABS(IVAL)
+ JVAL2 = ABS(JVAL)
+ IF (IVAL > 0 .AND. JVAL < 0) IJSIGN = -1
+ IF (IVAL < 0 .AND. JVAL > 0) IJSIGN = -1
+ IF (IVAL2 > 0 .AND. JVAL2 > 0) CALL FMGCDI(IVAL2,JVAL2)
+
+! Check for special cases.
+
+ IF (MA(1) == MUNKNO .OR. MA(KPTIMU+1) == MUNKNO .OR. &
+ (IJSIGN <= 0 .AND. MA(2) == 0 .AND. MA(KPTIMU+2) == 0) .OR. &
+ JVAL == 0) THEN
+ MA2 = MA(2)
+ KFLAG = -4
+ IF (IVAL <= 0 .AND. MA2 == 0) CALL ZMWARN
+ CALL ZMST2M('UNKNOWN+UNKNOWN*i',MB)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ IF (IVAL == 0) THEN
+ CALL ZMI2M(1,MB)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+! Increase the working precision.
+
+ IF (NCALL == 1) THEN
+ XVAL = MAX(ABS(IVAL),ABS(JVAL)) + 1
+ K = INT((5.0*REAL(DLOGTN) + LOG(XVAL))/ALOGMB + 2.0)
+ NDIG = MAX(NDIG+K,2)
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
+ ENDIF
+ ELSE
+ XVAL = MAX(ABS(IVAL),ABS(JVAL)) + 1
+ K = INT(LOG(XVAL)/ALOGMB + 1.0)
+ NDIG = NDIG + K
+ ENDIF
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL ZMWARN
+ NDIG = NDSAVE
+ CALL ZMST2M('UNKNOWN+UNKNOWN*i',MB)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ IF (MBASE >= 100*ABS(MA(2)) .OR. &
+ MBASE >= 100*ABS(MA(KPTIMU+2))) THEN
+ NDIG = MIN(NDIG+1,NDG2MX)
+ ENDIF
+ KASAVE = KACCSW
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+
+ CALL ZMEQ2(MA,MZ04,NDSAVE,NDIG)
+ IF (IVAL2 == 1 .AND. JVAL2 == 2) THEN
+ CALL ZMSQRT(MZ04,MB)
+ IF (IJSIGN < 0) THEN
+ CALL ZMI2M(1,MZ01)
+ CALL ZMDIV(MZ01,MB,MZ02)
+ CALL ZMEQ(MZ02,MB)
+ ENDIF
+ GO TO 110
+ ENDIF
+
+! Generate the first approximation to MA**(1/JVAL2).
+
+ CALL ZMI2M(0,MB)
+ CALL FMDIG(NSTACK,KST)
+ NDIG = NSTACK(1)
+ CALL FMSQR(MZ04,MZ03)
+ CALL FMSQR(MZ04(KPTIMU-1),M03)
+ CALL FMADD_R1(MZ03,M03)
+ CALL FMSQRT_R1(MZ03)
+ IF (MZ03(1) >= MEXPOV) THEN
+ KFLAG = -4
+ CALL ZMWARN
+ MXEXP = MXSAVE
+ KACCSW = KASAVE
+ NDIG = NDSAVE
+ CALL ZMST2M('UNKNOWN+UNKNOWN*i',MB)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+! Invert MA if ABS(MA) > 1 and IVAL or JVAL is large.
+
+ INVERT = 0
+ IF (IVAL > 5 .OR. JVAL > 5) THEN
+ IF (MZ03(1) > 0) THEN
+ INVERT = 1
+ NDIG = NSTACK(KST)
+ CALL ZMI2M(1,MB)
+ CALL ZMDIV(MB,MZ04,MZ08)
+ CALL ZMEQ(MZ08,MZ04)
+ NDIG = NSTACK(1)
+ CALL FMDIV_R2(MB,MZ03)
+ ENDIF
+ ENDIF
+
+ CALL FMDIV(MZ04,MZ03,M03)
+ CALL FMM2DP(M03,AR)
+ CALL FMDIV(MZ04(KPTIMU-1),MZ03,M03)
+ CALL FMM2DP(M03,BR)
+ MR1 = MZ03(1)
+ MZ03(1) = 0
+ CALL FMM2DP(MZ03,X)
+ L = INT(MR1/JVAL2)
+ F = MR1/DBLE(JVAL2) - L
+ X = X**(1.0D0/JVAL2) * DBLE(MBASE)**F
+ CALL FMDPM(X,M03)
+ M03(1) = M03(1) + L
+
+ THETA = ATAN2(BR,AR)
+ X = COS(THETA/JVAL2)
+ CALL FMDPM(X,MB)
+ X = SIN(THETA/JVAL2)
+ CALL FMDPM(X,MB(KPTIMU-1))
+ CALL FMMPY_R2(M03,MB)
+ CALL FMMPY_R2(M03,MB(KPTIMU-1))
+
+! Newton iteration.
+
+ DO J = 1, KST
+ NDIG = NSTACK(J)
+ IF (J < KST) NDIG = NDIG + 1
+ LVAL = JVAL2 - 1
+ CALL ZMIPWR(MB,LVAL,MZ03)
+ CALL ZMDIV(MZ04,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MZ03)
+ CALL ZMMPYI(MB,LVAL,MZ08)
+ CALL ZMEQ(MZ08,MB)
+ CALL ZMADD(MB,MZ03,MZ08)
+ CALL ZMEQ(MZ08,MB)
+ CALL ZMDIVI(MB,JVAL2,MZ08)
+ CALL ZMEQ(MZ08,MB)
+ ENDDO
+
+ CALL ZMIPWR(MB,IJSIGN*IVAL2,MZ03)
+ CALL ZMEQ(MZ03,MB)
+ IF (INVERT == 1) THEN
+ CALL ZMI2M(1,MZ03)
+ CALL ZMDIV(MZ03,MB,MZ08)
+ CALL ZMEQ(MZ08,MB)
+ ENDIF
+
+! Round the result and return.
+
+ 110 MACCMB = MB(0)
+ MB(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MB(KPTIMU)
+ MB(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ CALL ZMEQ(MB,MZ01)
+ CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE ZMRPWR
+
+ SUBROUTINE ZMRSLT(MC,KRESLT)
+
+! Handle results that are special cases, such as overflow,
+! underflow, and unknown.
+
+! MC is the result that is returned
+
+! KRESLT is the result code. Result codes handled here:
+
+! 0 - Perform the normal operation
+! 12 - The result is 'UNKNOWN'
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MC(-1:LUNPKZ)
+ INTEGER KRESLT
+
+ INTEGER KFSAVE
+
+ KFSAVE = KFLAG
+
+ IF (KRESLT == 12 .OR. KRESLT < 0 .OR. KRESLT > 15) THEN
+ CALL ZMST2M('UNKNOWN+UNKNOWN*i',MC)
+ KFLAG = KFSAVE
+ RETURN
+ ENDIF
+
+ RETURN
+ END SUBROUTINE ZMRSLT
+
+ SUBROUTINE ZMSIN(MA,MB)
+
+! MB = SIN(MA).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE
+
+ CALL ZMENTR('ZMSIN ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KACCSW = 0
+ KRSAVE = KRAD
+ KRAD = 1
+
+ CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ CALL ZMI2M(0,MZ01)
+ GO TO 110
+ ELSE IF (MA(1) < (-NDIG) .AND. MA(KPTIMU+1) < (-NDIG)) THEN
+ CALL ZMEQ(MZ07,MZ01)
+ GO TO 110
+ ELSE IF (MA(KPTIMU+2) == 0) THEN
+ CALL FMSIN(MZ07,MZ01)
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ GO TO 110
+ ELSE IF (MA(2) == 0) THEN
+ CALL FMSINH(MZ07(KPTIMU-1),MZ01(KPTIMU-1))
+ CALL FMI2M(0,MZ01)
+ GO TO 110
+ ENDIF
+
+! Find COS(REAL(MA)) and SIN(REAL(MA)).
+
+ CALL FMCSSN(MZ07,MZ01(KPTIMU-1),MZ01)
+
+! Find COSH(IMAG(MA)) and SINH(IMAG(MA)).
+
+ CALL FMCHSH(MZ07(KPTIMU-1),M05,M06)
+
+! SIN(MA) = SIN(REAL(MA))*COSH(IMAG(MA)) +
+! COS(REAL(MA))*SINH(IMAG(MA)) i
+
+ CALL FMMPY_R1(MZ01,M05)
+ CALL FMMPY_R1(MZ01(KPTIMU-1),M06)
+
+ 110 MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ KRAD = KRSAVE
+ RETURN
+ END SUBROUTINE ZMSIN
+
+ SUBROUTINE ZMSINH(MA,MB)
+
+! MB = SINH(MA).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE
+
+ CALL ZMENTR('ZMSINH',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KACCSW = 0
+ KRSAVE = KRAD
+ KRAD = 1
+
+ CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ CALL ZMI2M(0,MZ01)
+ GO TO 110
+ ELSE IF (MA(1) < (-NDIG) .AND. MA(KPTIMU+1) < (-NDIG)) THEN
+ CALL ZMEQ(MZ07,MZ01)
+ GO TO 110
+ ELSE IF (MA(2) == 0) THEN
+ CALL FMSIN(MZ07(KPTIMU-1),MZ01(KPTIMU-1))
+ CALL FMI2M(0,MZ01)
+ GO TO 110
+ ELSE IF (MA(KPTIMU+2) == 0) THEN
+ CALL FMSINH(MZ07,MZ01)
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ GO TO 110
+ ENDIF
+
+! Find SIN(IMAG(MA)) and COS(IMAG(MA)).
+
+ CALL FMCSSN(MZ07(KPTIMU-1),MZ01,MZ01(KPTIMU-1))
+
+! Find SINH(REAL(MA)) and COSH(REAL(MA)).
+
+ CALL FMCHSH(MZ07,M05,M06)
+
+! SINH(MA) = SINH(REAL(MA))*COS(IMAG(MA)) +
+! COSH(REAL(MA))*SIN(IMAG(MA)) i
+
+ CALL FMMPY_R1(MZ01,M06)
+ CALL FMMPY_R1(MZ01(KPTIMU-1),M05)
+
+ 110 MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ KRAD = KRSAVE
+ RETURN
+ END SUBROUTINE ZMSINH
+
+ SUBROUTINE ZMSQR(MA,MB)
+
+! MB = MA * MA
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDGSV2,NDSAVE,NTRSAV
+
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR. &
+ KDEBUG >= 1) THEN
+ CALL ZMENTR('ZMSQR ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'ZMSQR '
+ CALL ZMNTR(2,MA,MA,1)
+ ENDIF
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ NDIG = MAX(NDIG+NGRD52,2)
+ IF (NDIG > NDG2MX) THEN
+ NAMEST(NCALL) = 'ZMSQR '
+ KFLAG = -9
+ CALL ZMWARN
+ KRESLT = 12
+ NDIG = NDSAVE
+ CALL ZMRSLT(MB,KRESLT)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ IF (MBASE >= 100*ABS(MA(2)) .OR. &
+ MBASE >= 100*ABS(MA(KPTIMU+2))) THEN
+ NDIG = MIN(NDIG+1,NDG2MX)
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ KOVUN = 0
+ ENDIF
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
+ ENDIF
+
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ NTRSAV = NTRACE
+ NTRACE = 0
+ KWRNSV = KWARN
+ KWARN = 0
+
+ CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
+ IF (NCALL == 1) THEN
+ MZ07(0) = NINT(NDIG*ALOGM2)
+ MZ07(KPTIMU) = MZ07(0)
+ ENDIF
+
+! Check for special cases.
+
+ IF (MA(KPTIMU+2) == 0) THEN
+ CALL FMSQR(MZ07,MZ01)
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ ELSE IF (MA(2) == 0) THEN
+ CALL FMSQR(MZ07(KPTIMU-1),MZ01)
+ IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ ELSE
+ CALL FMADD(MZ07,MZ07(KPTIMU-1),M02)
+ CALL FMSUB(MZ07,MZ07(KPTIMU-1),M03)
+ CALL FMMPY(M02,M03,MZ01)
+ CALL FMMPY(MZ07,MZ07(KPTIMU-1),M03)
+ CALL FMADD(M03,M03,MZ01(KPTIMU-1))
+ ENDIF
+
+ MXEXP = MXSAVE
+ NTRACE = NTRSAV
+ NDGSV2 = NDIG
+ NDIG = NDSAVE
+ KWARN = KWRNSV
+ MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ KACCSW = KASAVE
+ CALL ZMEQ2(MZ01,MB,NDGSV2,NDSAVE)
+ IF (MB(1) >= MEXPOV .OR. MB(1) <= -MEXPOV .OR. &
+ MB(KPTIMU+1) >= MEXPOV .OR. MB(KPTIMU+1) <= -MEXPOV) THEN
+ IF (MB(1) == MUNKNO .OR. MB(KPTIMU+1) == MUNKNO) THEN
+ KFLAG = -4
+ ELSE IF (MB(1) == MEXPOV .OR. MB(KPTIMU+1) == MEXPOV) THEN
+ KFLAG = -5
+ ELSE IF (MB(1) == MEXPUN .OR. MB(KPTIMU+1) == MEXPUN) THEN
+ KFLAG = -6
+ ENDIF
+ IF ((MB(1) == MUNKNO) &
+ .OR. (MB(KPTIMU+1) == MUNKNO) &
+ .OR. (MB(1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MB(KPTIMU+1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MB(1) == MEXPOV .AND. KOVUN == 0) &
+ .OR. (MB(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
+ NAMEST(NCALL) = 'ZMSQR '
+ CALL ZMWARN
+ ENDIF
+ ENDIF
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMSQR
+
+ SUBROUTINE ZMSQRT(MA,MB)
+
+! MB = SQRT(MA). Principal Square Root.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXEXP1,MXSAVE
+ INTEGER KASAVE,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV
+
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR. &
+ KDEBUG >= 1) THEN
+ CALL ZMENTR('ZMSQRT',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'ZMSQRT'
+ CALL ZMNTR(2,MA,MA,1)
+ ENDIF
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ NDIG = MAX(NDIG+NGRD52,2)
+ IF (NDIG > NDG2MX) THEN
+ NAMEST(NCALL) = 'ZMSQRT'
+ KFLAG = -9
+ CALL ZMWARN
+ KRESLT = 12
+ NDIG = NDSAVE
+ CALL ZMRSLT(MB,KRESLT)
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ IF (MBASE >= 100*ABS(MA(2)) .OR. &
+ MBASE >= 100*ABS(MA(KPTIMU+2))) THEN
+ NDIG = MIN(NDIG+1,NDG2MX)
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ KACCSW = 0
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ KOVUN = 0
+ ENDIF
+ IF (MBASE < 1000 .OR. KROUND /= 1 .OR. KRPERF == 1) THEN
+ IF (NCALL == 1) NDIG = MIN(NDG2MX,MAX(NDIG,2*NDSAVE+10))
+ ENDIF
+
+ NTRSAV = NTRACE
+ NTRACE = 0
+ KWRNSV = KWARN
+ KWARN = 0
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+
+ CALL ZMEQU(MA,MZ05,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ MXEXP1 = INT(MXEXP2/2.01D0)
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ CALL ZMI2M(0,MZ01)
+ GO TO 110
+ ELSE IF (MA(2) == 0) THEN
+ CALL FMABS(MZ05(KPTIMU-1),M01)
+ CALL FMDIVI(M01,2,M03)
+ CALL FMSQRT_R1(M03)
+ ELSE IF (MA(KPTIMU+2) == 0) THEN
+ CALL FMABS(MZ05,M03)
+ CALL FMSQRT_R1(M03)
+ ELSE IF (MA(1) == MEXPUN) THEN
+ IF (MA(KPTIMU+1) <= -MXEXP1+NDIG+1) THEN
+ CALL ZMST2M('UNKNOWN + UNKNOWN i',MZ01)
+ GO TO 110
+ ENDIF
+ ELSE IF (MA(KPTIMU+1) == MEXPUN) THEN
+ IF (MA(1) <= -MXEXP1+NDIG+1) THEN
+ CALL ZMST2M('UNKNOWN + UNKNOWN i',MZ01)
+ GO TO 110
+ ENDIF
+ ELSE
+ CALL FMSQR(MZ05,M01)
+ CALL FMSQR(MZ05(KPTIMU-1),M02)
+ CALL FMADD(M01,M02,M03)
+ CALL FMSQRT_R1(M03)
+ CALL FMABS(MZ05,M02)
+ CALL FMADD_R2(M02,M03)
+ CALL FMDIVI_R1(M03,2)
+ CALL FMSQRT_R1(M03)
+ ENDIF
+
+ CALL FMADD(M03,M03,M02)
+ IF (MA(-1) >= 0) THEN
+ CALL FMDIV(MZ05(KPTIMU-1),M02,MZ01(KPTIMU-1))
+ CALL FMEQ(M03,MZ01)
+ ELSE
+ IF (MA(KPTIMU-1) >= 0) THEN
+ CALL FMDIV(MZ05(KPTIMU-1),M02,MZ01)
+ CALL FMEQ(M03,MZ01(KPTIMU-1))
+ ELSE
+ CALL FMDIV(MZ05(KPTIMU-1),M02,MZ01)
+ CALL FMEQ(M03,MZ01(KPTIMU-1))
+ IF (MZ01(1) /= MUNKNO .AND. MZ01(2) /= 0) MZ01(-1) = -MZ01(-1)
+ IF (MZ01(KPTIMU+1) /= MUNKNO .AND. MZ01(KPTIMU+2) /= 0) &
+ MZ01(KPTIMU-1) = -MZ01(KPTIMU-1)
+ ENDIF
+ ENDIF
+
+ 110 MXEXP = MXSAVE
+ MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ KACCSW = KASAVE
+ CALL ZMEQ2(MZ01,MB,NDIG,NDSAVE)
+
+ IF (MB(1) == MUNKNO .OR. MB(KPTIMU+1) == MUNKNO) THEN
+ KFLAG = -4
+ ELSE IF (MB(1) == MEXPOV .OR. MB(KPTIMU+1) == MEXPOV) THEN
+ KFLAG = -5
+ ELSE IF (MB(1) == MEXPUN .OR. MB(KPTIMU+1) == MEXPUN) THEN
+ KFLAG = -6
+ ENDIF
+ NTRACE = NTRSAV
+ NDIG = NDSAVE
+ KWARN = KWRNSV
+ IF ((MB(1) == MUNKNO) &
+ .OR. (MB(KPTIMU+1) == MUNKNO) &
+ .OR. (MB(1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MB(KPTIMU+1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MB(1) == MEXPOV .AND. KOVUN == 0) &
+ .OR. (MB(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
+ NAMEST(NCALL) = 'ZMSQRT'
+ CALL ZMWARN
+ ENDIF
+ IF (NTRACE /= 0) CALL ZMNTR(1,MB,MB,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMSQRT
+
+ SUBROUTINE ZMST2M(STRING,MA)
+
+! MA = STRING
+
+! Convert a character string to FM format.
+! This is often more convenient than using ZMINP, which converts an
+! array of CHARACTER*1 values.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(*) :: STRING
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
+
+ INTEGER J,LB,KFSAVE
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMST2M'
+ LB = LEN(STRING)
+ KFSAVE = KFLAG
+
+ DO J = 1, LB
+ CMBUFZ(J) = STRING(J:J)
+ ENDDO
+
+ CALL ZMINP(CMBUFZ,MA,1,LB)
+
+ IF (KFSAVE /= 0) KFLAG = KFSAVE
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMST2M
+
+ SUBROUTINE ZMSUB(MA,MB,MC)
+
+! MC = MA - MB
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ),MC(-1:LUNPKZ)
+
+ INTEGER KASAVE,KF1,KOVUN,KRESLT,KWRNSV,NDSAVE,NTRSAV
+ REAL (KIND(1.0D0)) :: MXSAVE
+
+ IF (ABS(MA(1)) > MEXPAB .OR. ABS(MA(KPTIMU+1)) > MEXPAB .OR. &
+ ABS(MB(1)) > MEXPAB .OR. ABS(MB(KPTIMU+1)) > MEXPAB .OR. &
+ KDEBUG >= 1) THEN
+ CALL ZMENTR('ZMSUB ',MA,MB,2,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ NDIG = NDSAVE
+ MXEXP = MXSAVE
+ KACCSW = KASAVE
+ ELSE
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) THEN
+ NAMEST(NCALL) = 'ZMSUB '
+ CALL ZMNTR(2,MA,MB,2)
+ ENDIF
+ KOVUN = 0
+ ENDIF
+
+! Force FMSUB to use more guard digits for user calls.
+
+ NCALL = NCALL - 1
+ NTRSAV = NTRACE
+ NTRACE = 0
+ KWRNSV = KWARN
+ KWARN = 0
+
+ CALL FMSUB(MA,MB,MC)
+ KF1 = KFLAG
+ CALL FMSUB(MA(KPTIMU-1),MB(KPTIMU-1),MC(KPTIMU-1))
+
+ NTRACE = NTRSAV
+ KWARN = KWRNSV
+ NCALL = NCALL + 1
+ IF (NTRACE /= 0) NAMEST(NCALL) = 'ZMSUB '
+ IF (KFLAG == 1) KFLAG = KF1
+
+ IF (MC(1) == MUNKNO .OR. MC(KPTIMU+1) == MUNKNO) THEN
+ KFLAG = -4
+ ELSE IF (MC(1) == MEXPOV .OR. MC(KPTIMU+1) == MEXPOV) THEN
+ KFLAG = -5
+ ELSE IF (MC(1) == MEXPUN .OR. MC(KPTIMU+1) == MEXPUN) THEN
+ KFLAG = -6
+ ENDIF
+ IF ((MC(1) == MUNKNO) &
+ .OR. (MC(KPTIMU+1) == MUNKNO) &
+ .OR. (MC(1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MC(KPTIMU+1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MC(1) == MEXPOV .AND. KOVUN == 0) &
+ .OR. (MC(KPTIMU+1) == MEXPOV .AND. KOVUN == 0)) THEN
+ NAMEST(NCALL) = 'ZMSUB '
+ CALL ZMWARN
+ ENDIF
+ IF (NTRACE /= 0) CALL ZMNTR(1,MC,MC,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMSUB
+
+ SUBROUTINE ZMTAN(MA,MB)
+
+! MB = TAN(MA).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER IEXTRA,KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE,NGOAL
+
+ CALL ZMENTR('ZMTAN ',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KRSAVE = KRAD
+ KRAD = 1
+
+ 110 CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ CALL ZMI2M(0,MZ01)
+ GO TO 120
+ ELSE IF (MA(1) < (-NDIG) .AND. MA(KPTIMU+1) < (-NDIG)) THEN
+ CALL ZMEQ(MZ07,MZ01)
+ GO TO 120
+ ELSE IF (MA(KPTIMU+2) == 0) THEN
+ CALL FMTAN(MZ07,MZ01)
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ GO TO 120
+ ELSE IF (MA(2) == 0) THEN
+ CALL FMTANH(MZ07(KPTIMU-1),MZ01(KPTIMU-1))
+ CALL FMI2M(0,MZ01)
+ GO TO 120
+ ENDIF
+
+! Find SIN(2*REAL(MA)) and COS(2*REAL(MA)).
+
+ CALL FMADD(MZ07,MZ07,MZ01)
+ CALL FMCSSN(MZ01,MZ01(KPTIMU-1),M06)
+ CALL FMEQ(M06,MZ01)
+
+! Find SINH(2*IMAG(MA)) and COSH(2*IMAG(MA)).
+
+ CALL FMADD(MZ07(KPTIMU-1),MZ07(KPTIMU-1),M06)
+ CALL FMCHSH(M06,M05,M14)
+ CALL FMEQ(M14,M06)
+
+! TAN(MA) = SIN(2*REAL(MA)) /
+! (COS(2*REAL(MA))+COSH(2*IMAG(MA)) +
+! SINH(2*IMAG(MA)) /
+! (COS(2*REAL(MA))+COSH(2*IMAG(MA)) i
+
+ CALL FMADD_R2(MZ01(KPTIMU-1),M05)
+ IF (M05(2) == 0) THEN
+ MZ01(0) = 0
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7
+ GO TO 130
+ ELSE IF (M05(1) == MEXPOV) THEN
+ CALL FMDIV_R1(MZ01,M05)
+ CALL FMIM(1,MZ01(KPTIMU-1))
+ IF (M06(-1) < 0 .AND. MZ01(KPTIMU+1) /= MUNKNO .AND. &
+ MZ01(KPTIMU+2) /= 0) MZ01(KPTIMU-1) = -MZ01(KPTIMU-1)
+ ELSE
+ CALL FMDIVD(MZ01,M06,M05,MZ08,MZ08(KPTIMU-1))
+ CALL ZMEQ(MZ08,MZ01)
+ ENDIF
+
+! Check for too much cancellation.
+
+ 120 IF (NCALL <= 1) THEN
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7
+ ELSE
+ NGOAL = INT(-MXEXP2)
+ ENDIF
+ 130 IF (MZ01(0) <= NGOAL .OR. MZ01(KPTIMU) <= NGOAL) THEN
+ IEXTRA = INT(REAL(MAX(NGOAL-MZ01(0),NGOAL-MZ01(KPTIMU))) &
+ /ALOGM2 + 23.03/ALOGMB) + 1
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL ZMWARN
+ NDIG = NDIG - IEXTRA
+ CALL ZMST2M('UNKNOWN+UNKNOWN*i',MZ01)
+ GO TO 140
+ ENDIF
+ GO TO 110
+ ENDIF
+
+ 140 MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ KRAD = KRSAVE
+ RETURN
+ END SUBROUTINE ZMTAN
+
+ SUBROUTINE ZMTANH(MA,MB)
+
+! MB = TANH(MA).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MB(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MACCMB,MAIZ,MARZ,MXSAVE
+ INTEGER IEXTRA,KASAVE,KOVUN,KRESLT,KRSAVE,NDSAVE,NGOAL
+
+ CALL ZMENTR('ZMTANH',MA,MA,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ MARZ = MA(0)
+ MAIZ = MA(KPTIMU)
+ KRSAVE = KRAD
+ KRAD = 1
+
+ 110 CALL ZMEQU(MA,MZ07,NDSAVE,NDIG)
+
+! Check for special cases.
+
+ IF (MA(2) == 0 .AND. MA(KPTIMU+2) == 0) THEN
+ CALL ZMI2M(0,MZ01)
+ GO TO 120
+ ELSE IF (MA(1) < (-NDIG) .AND. MA(KPTIMU+1) < (-NDIG)) THEN
+ CALL ZMEQ(MZ07,MZ01)
+ GO TO 120
+ ELSE IF (MA(2) == 0) THEN
+ CALL FMTAN(MZ07(KPTIMU-1),MZ01(KPTIMU-1))
+ CALL FMI2M(0,MZ01)
+ GO TO 120
+ ELSE IF (MA(KPTIMU+2) == 0) THEN
+ CALL FMTANH(MZ07,MZ01)
+ CALL FMI2M(0,MZ01(KPTIMU-1))
+ GO TO 120
+ ENDIF
+
+! Find SIN(2*IMAG(MA)) and COS(2*IMAG(MA)).
+
+ CALL FMADD(MZ07(KPTIMU-1),MZ07(KPTIMU-1),MZ01)
+ CALL FMCSSN(MZ01,MZ01(KPTIMU-1),M06)
+ CALL FMEQ(M06,MZ01)
+
+! Find SINH(2*REAL(MA)) and COSH(2*REAL(MA)).
+
+ CALL FMADD(MZ07,MZ07,M06)
+ CALL FMCHSH(M06,M05,M14)
+ CALL FMEQ(M14,M06)
+
+! TANH(MA) = SINH(2*REAL(MA)) /
+! (COS(2*IMAG(MA))+COSH(2*REAL(MA)) +
+! SIN(2*IMAG(MA)) /
+! (COS(2*IMAG(MA))+COSH(2*REAL(MA)) i
+
+ CALL FMADD_R2(MZ01(KPTIMU-1),M05)
+ IF (M05(2) == 0) THEN
+ MZ01(0) = 0
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7
+ GO TO 130
+ ELSE IF (M05(1) == MEXPOV) THEN
+ CALL FMDIV(MZ01,M05,MZ01(KPTIMU-1))
+ CALL FMIM(1,MZ01)
+ IF (M06(-1) < 0) MZ01(-1) = -1
+ ELSE
+ CALL FMDIVD(MZ01,M06,M05,MZ08(KPTIMU-1),MZ08)
+ CALL ZMEQ(MZ08,MZ01)
+ ENDIF
+
+! Check for too much cancellation.
+
+ 120 IF (NCALL <= 1) THEN
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 7
+ ELSE
+ NGOAL = INT(-MXEXP2)
+ ENDIF
+ 130 IF (MZ01(0) <= NGOAL .OR. MZ01(KPTIMU) <= NGOAL) THEN
+ IEXTRA = INT(REAL(MAX(NGOAL-MZ01(0),NGOAL-MZ01(KPTIMU))) &
+ /ALOGM2 + 23.03/ALOGMB) + 1
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL ZMWARN
+ NDIG = NDIG - IEXTRA
+ CALL ZMST2M('UNKNOWN+UNKNOWN*i',MZ01)
+ GO TO 140
+ ENDIF
+ GO TO 110
+ ENDIF
+
+ 140 MACCMB = MZ01(0)
+ MZ01(0) = MIN(MACCMB,MARZ,MAIZ)
+ MACCMB = MZ01(KPTIMU)
+ MZ01(KPTIMU) = MIN(MACCMB,MARZ,MAIZ)
+ CALL ZMEXIT(MZ01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ KRAD = KRSAVE
+ RETURN
+ END SUBROUTINE ZMTANH
+
+ SUBROUTINE ZMUNPK(MP,MA)
+
+! MP is unpacked and the value returned in MA.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ),MP(-1:LPACKZ)
+
+ CALL FMUNPK(MP,MA)
+ CALL FMUNPK(MP(KPTIMP),MA(KPTIMU-1))
+ RETURN
+ END SUBROUTINE ZMUNPK
+
+ SUBROUTINE ZMWARN
+
+! Called by one of the ZM routines to print a warning message
+! if any error condition arises in that routine.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(6) :: NAME
+
+ INTEGER NCS
+
+ IF (KFLAG >= 0 .OR. NCALL /= 1 .OR. KWARN <= 0) RETURN
+ NCS = NCALL
+ NAME = NAMEST(NCALL)
+ WRITE (KW,"(/' Error of type KFLAG =',I3," // &
+ "' in FM package in routine ',A6/)" &
+ ) KFLAG,NAME
+
+ 110 NCALL = NCALL - 1
+ IF (NCALL > 0) THEN
+ NAME = NAMEST(NCALL)
+ WRITE (KW,"( ' called from ',A6)") NAME
+ GO TO 110
+ ENDIF
+
+ IF (KFLAG == -1) THEN
+ WRITE (KW,"(' NDIG must be between 2 and',I10/)") NDIGMX
+ ELSE IF (KFLAG == -2) THEN
+ WRITE (KW,"(' MBASE must be between 2 and',I10/)") INT(MXBASE)
+ ELSE IF (KFLAG == -3) THEN
+ WRITE (KW, &
+ "(' An input argument is not a valid FM number.'," // &
+ "' Its exponent is out of range.'/)" &
+ )
+ WRITE (KW,"(' UNKNOWN has been returned.'/)")
+ ELSE IF (KFLAG == -4 .OR. KFLAG == -7) THEN
+ WRITE (KW,"(' Invalid input argument for this routine.'/)")
+ WRITE (KW,"(' UNKNOWN has been returned.'/)")
+ ELSE IF (KFLAG == -5) THEN
+ WRITE (KW,"(' The result has overflowed.'/)")
+ ELSE IF (KFLAG == -6) THEN
+ WRITE (KW,"(' The result has underflowed.'/)")
+ ELSE IF (KFLAG == -8 .AND. NAME == 'ZMOUT ') THEN
+ WRITE (KW, &
+ "(' The result array is not big enough to hold the'," // &
+ "' output character string'/' in the current format.'/" // &
+ "' The result ''***...***'' has been returned.'/)" &
+ )
+ ELSE IF (KFLAG == -8 .AND. NAME == 'ZMREAD') THEN
+ WRITE (KW, &
+ "(' The CMBUFF array is not big enough to hold the'," // &
+ "' input character string'/" // &
+ "' UNKNOWN has been returned.'/)" &
+ )
+ ELSE IF (KFLAG == -9) THEN
+ WRITE (KW, &
+ "(' Precision could not be raised enough to'" // &
+ ",' provide all requested guard digits.'/)" &
+ )
+ WRITE (KW, &
+ "(I23,' digits were requested (NDIG).'/" // &
+ "' Maximum number of digits currently available'," // &
+ "' (NDG2MX) is',I7,'.'/)" &
+ ) NDIG,NDG2MX
+ WRITE (KW,"(' UNKNOWN has been returned.'/)")
+ ENDIF
+
+ NCALL = NCS
+ IF (KWARN >= 2) THEN
+ STOP
+ ENDIF
+ RETURN
+ END SUBROUTINE ZMWARN
+
+ SUBROUTINE ZMWRIT(KWRITE,MA)
+
+! Write MA on unit KWRITE under the current format. Multi-line numbers
+! will have '&' as the last nonblank character on all but the last
+! line of the real part and the imaginary part.
+! These numbers can then be read easily using ZMREAD.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER KWRITE
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
+
+ INTEGER J,K,KSAVE,L,LAST,LAST1,LAST2,LB,ND,NEXP
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMWRIT'
+ KSAVE = KFLAG
+ ND = INT(REAL(NDIG)*LOG10(REAL(MBASE))) + 1
+ IF (ND < 2) ND = 2
+ NEXP = INT(2.0*LOG10(REAL(MXBASE))) + 6
+ LB = 2*MAX(JFORM2+NEXP,ND+NEXP) + 3
+ LB = MIN(LB,LMBUFZ)
+ CALL ZMOUT(MA,CMBUFZ,LB,LAST1,LAST2)
+ KFLAG = KSAVE
+ LAST = LAST2 + 1
+ DO J = 1, LAST2
+ IF (CMBUFZ(LAST-J) /= ' ' .OR. J == LAST2) THEN
+ L = LAST - J
+ IF (MOD(L,73) /= 0) THEN
+ WRITE (KWRITE,"(4X,73A1,' &')") (CMBUFZ(K),K=1,L)
+ ELSE
+ WRITE (KWRITE,"(4X,73A1,' &')") (CMBUFZ(K),K=1,L-73)
+ WRITE (KWRITE,"(4X,73A1)") (CMBUFZ(K),K=L-72,L)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDDO
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMWRIT
+
+ SUBROUTINE ZMZ2M(ZVAL,MA)
+
+! MA = ZVAL
+
+! ZVAL is complex and is converted to ZM form.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ COMPLEX ZVAL
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPKZ)
+
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'ZMZ2M '
+ IF (NTRACE /= 0) CALL ZMNTRZ(2,ZVAL,1)
+
+ CALL FMSP2M(REAL(ZVAL),MA)
+ CALL FMSP2M(AIMAG(ZVAL),MA(KPTIMU-1))
+
+ IF (NTRACE /= 0) CALL ZMNTR(1,MA,MA,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE ZMZ2M
+
+! Here are the routines which work with packed ZM numbers. All names
+! are the same as unpacked versions with 'ZM' replaced by 'ZP'.
+
+! To convert a program using the ZM package from unpacked calls to
+! packed calls make these changes to the program:
+! '(-1:LUNPKZ)' to '(-1:LUNPKZ)' in dimensions.
+! 'CALL ZM' to 'CALL ZP'
+
+! This packed format is not available when using the FM, IM, or ZM
+! derived types.
+
+
+ SUBROUTINE ZPABS(MA,MBFM)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MBFM(-1:LPACK)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMABS(MPX,MPA)
+ CALL FMPACK(MPA,MBFM)
+ RETURN
+ END SUBROUTINE ZPABS
+
+ SUBROUTINE ZPACOS(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMACOS(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPACOS
+
+ SUBROUTINE ZPADD(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ),MC(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMUNPK(MB,MPY)
+ CALL ZMADD(MPX,MPY,MPZ)
+ CALL ZMPACK(MPZ,MC)
+ RETURN
+ END SUBROUTINE ZPADD
+
+ SUBROUTINE ZPADDI(MA,INTEG)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
+ INTEGER INTEG
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMADDI(MPX,INTEG)
+ CALL ZMPACK(MPX,MA)
+ RETURN
+ END SUBROUTINE ZPADDI
+
+ SUBROUTINE ZPARG(MA,MBFM)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MBFM(-1:LPACK)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMARG(MPX,MPA)
+ CALL FMPACK(MPA,MBFM)
+ RETURN
+ END SUBROUTINE ZPARG
+
+ SUBROUTINE ZPASIN(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMASIN(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPASIN
+
+ SUBROUTINE ZPATAN(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMATAN(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPATAN
+
+ SUBROUTINE ZPCHSH(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ),MC(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMCHSH(MPX,MPY,MPZ)
+ CALL ZMPACK(MPY,MB)
+ CALL ZMPACK(MPZ,MC)
+ RETURN
+ END SUBROUTINE ZPCHSH
+
+ SUBROUTINE ZPCMPX(MAFM,MBFM,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MAFM(-1:LPACK),MBFM(-1:LPACK),MC(-1:LPACKZ)
+ CALL FMUNPK(MAFM,MPA)
+ CALL FMUNPK(MBFM,MPB)
+ CALL ZMCMPX(MPA,MPB,MPX)
+ CALL ZMPACK(MPX,MC)
+ RETURN
+ END SUBROUTINE ZPCMPX
+
+ SUBROUTINE ZPCONJ(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMCONJ(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPCONJ
+
+ SUBROUTINE ZPCOS(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMCOS(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPCOS
+
+ SUBROUTINE ZPCOSH(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMCOSH(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPCOSH
+
+ SUBROUTINE ZPCSSN(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ),MC(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMCSSN(MPX,MPY,MPZ)
+ CALL ZMPACK(MPY,MB)
+ CALL ZMPACK(MPZ,MC)
+ RETURN
+ END SUBROUTINE ZPCSSN
+
+ SUBROUTINE ZPDIV(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ),MC(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMUNPK(MB,MPY)
+ CALL ZMDIV(MPX,MPY,MPZ)
+ CALL ZMPACK(MPZ,MC)
+ RETURN
+ END SUBROUTINE ZPDIV
+
+ SUBROUTINE ZPDIVI(MA,INTEG,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ INTEGER INTEG
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMDIVI(MPX,INTEG,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPDIVI
+
+ SUBROUTINE ZPEQ(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL FPEQ(MA,MB)
+ CALL FPEQ(MA(KPTIMP),MB(KPTIMP))
+ RETURN
+ END SUBROUTINE ZPEQ
+
+ SUBROUTINE ZPEQU(MA,MB,NDA,NDB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ INTEGER NDA,NDB
+ CALL FPEQU(MA,MB,NDA,NDB)
+ CALL FPEQU(MA(KPTIMP),MB(KPTIMP),NDA,NDB)
+ RETURN
+ END SUBROUTINE ZPEQU
+
+ SUBROUTINE ZPEXP(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMEXP(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPEXP
+
+ SUBROUTINE ZPFORM(FORM1,FORM2,MA,STRING)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
+ CHARACTER(*) :: FORM1,FORM2,STRING
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMFORM(FORM1,FORM2,MPX,STRING)
+ RETURN
+ END SUBROUTINE ZPFORM
+
+ SUBROUTINE ZPFPRT(FORM1,FORM2,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
+ CHARACTER(*) :: FORM1,FORM2
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMFPRT(FORM1,FORM2,MPX)
+ RETURN
+ END SUBROUTINE ZPFPRT
+
+ SUBROUTINE ZP2I2M(INTEG1,INTEG2,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER INTEG1,INTEG2
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
+ CALL ZM2I2M(INTEG1,INTEG2,MPX)
+ CALL ZMPACK(MPX,MA)
+ RETURN
+ END SUBROUTINE ZP2I2M
+
+ SUBROUTINE ZPI2M(INTEG,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER INTEG
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
+ CALL ZMI2M(INTEG,MPX)
+ CALL ZMPACK(MPX,MA)
+ RETURN
+ END SUBROUTINE ZPI2M
+
+ SUBROUTINE ZPIMAG(MA,MBFM)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MBFM(-1:LPACK)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMIMAG(MPX,MPA)
+ CALL FMPACK(MPA,MBFM)
+ RETURN
+ END SUBROUTINE ZPIMAG
+
+ SUBROUTINE ZPINT(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMINT(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPINT
+
+ SUBROUTINE ZPINP(LINE,MA,LA,LB)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER LA,LB
+ CHARACTER LINE(LB)
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
+ CALL ZMINP(LINE,MPX,LA,LB)
+ CALL ZMPACK(MPX,MA)
+ RETURN
+ END SUBROUTINE ZPINP
+
+ SUBROUTINE ZPIPWR(MA,INTEG,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ INTEGER INTEG
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMIPWR(MPX,INTEG,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPIPWR
+
+ SUBROUTINE ZPLG10(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMLG10(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPLG10
+
+ SUBROUTINE ZPLN(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMLN(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPLN
+
+ SUBROUTINE ZPM2I(MA,INTEG)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
+ INTEGER INTEG
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMM2I(MPX,INTEG)
+ RETURN
+ END SUBROUTINE ZPM2I
+
+ SUBROUTINE ZPM2Z(MA,ZVAL)
+ USE FMVALS
+ IMPLICIT NONE
+ COMPLEX ZVAL
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMM2Z(MPX,ZVAL)
+ RETURN
+ END SUBROUTINE ZPM2Z
+
+ SUBROUTINE ZPMPY(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ),MC(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMUNPK(MB,MPY)
+ CALL ZMMPY(MPX,MPY,MPZ)
+ CALL ZMPACK(MPZ,MC)
+ RETURN
+ END SUBROUTINE ZPMPY
+
+ SUBROUTINE ZPMPYI(MA,INTEG,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ INTEGER INTEG
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMMPYI(MPX,INTEG,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPMPYI
+
+ SUBROUTINE ZPNINT(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMNINT(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPNINT
+
+ SUBROUTINE ZPOUT(MA,LINE,LB,LAST1,LAST2)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
+ INTEGER LB,LAST1,LAST2
+ CHARACTER LINE(LB)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMOUT(MPX,LINE,LB,LAST1,LAST2)
+ RETURN
+ END SUBROUTINE ZPOUT
+
+ SUBROUTINE ZPPRNT(MA)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMPRNT(MPX)
+ RETURN
+ END SUBROUTINE ZPPRNT
+
+ SUBROUTINE ZPPWR(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ),MC(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMUNPK(MB,MPY)
+ CALL ZMPWR(MPX,MPY,MPZ)
+ CALL ZMPACK(MPZ,MC)
+ RETURN
+ END SUBROUTINE ZPPWR
+
+ SUBROUTINE ZPREAD(KREAD,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER KREAD
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
+ CALL ZMREAD(KREAD,MPX)
+ CALL ZMPACK(MPX,MA)
+ RETURN
+ END SUBROUTINE ZPREAD
+
+ SUBROUTINE ZPREAL(MA,MBFM)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MBFM(-1:LPACK)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMREAL(MPX,MPA)
+ CALL FMPACK(MPA,MBFM)
+ RETURN
+ END SUBROUTINE ZPREAL
+
+ SUBROUTINE ZPRPWR(MA,IVAL,JVAL,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ INTEGER IVAL,JVAL
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMRPWR(MPX,IVAL,JVAL,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPRPWR
+
+ SUBROUTINE ZPSET(NPREC)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER NPREC
+ CALL ZMSET(NPREC)
+ RETURN
+ END SUBROUTINE ZPSET
+
+ SUBROUTINE ZPSIN(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMSIN(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPSIN
+
+ SUBROUTINE ZPSINH(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMSINH(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPSINH
+
+ SUBROUTINE ZPSQR(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMSQR(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPSQR
+
+ SUBROUTINE ZPSQRT(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMSQRT(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPSQRT
+
+ SUBROUTINE ZPST2M(STRING,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ CHARACTER(*) :: STRING
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
+ CALL ZMST2M(STRING,MPX)
+ CALL ZMPACK(MPX,MA)
+ RETURN
+ END SUBROUTINE ZPST2M
+
+ SUBROUTINE ZPSUB(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ),MC(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMUNPK(MB,MPY)
+ CALL ZMSUB(MPX,MPY,MPZ)
+ CALL ZMPACK(MPZ,MC)
+ RETURN
+ END SUBROUTINE ZPSUB
+
+ SUBROUTINE ZPTAN(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMTAN(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPTAN
+
+ SUBROUTINE ZPTANH(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ),MB(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMTANH(MPX,MPY)
+ CALL ZMPACK(MPY,MB)
+ RETURN
+ END SUBROUTINE ZPTANH
+
+ SUBROUTINE ZPWRIT(KWRITE,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ INTEGER KWRITE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
+ CALL ZMUNPK(MA,MPX)
+ CALL ZMWRIT(KWRITE,MPX)
+ RETURN
+ END SUBROUTINE ZPWRIT
+
+ SUBROUTINE ZPZ2M(ZVAL,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ COMPLEX ZVAL
+ REAL (KIND(1.0D0)) :: MA(-1:LPACKZ)
+ CALL ZMZ2M(ZVAL,MPX)
+ CALL ZMPACK(MPX,MA)
+ RETURN
+ END SUBROUTINE ZPZ2M
+
+! These FM routines perform the Gamma and Related Functions.
+
+
+ SUBROUTINE FMARG2(KROUTN,NARGS,MA,MB,KRESLT)
+
+! Check the input arguments to a routine for special cases.
+
+! KROUTN - Name of the subroutine that was called
+! NARGS - The number of input arguments (1 or 2)
+! MA - First input argument
+! MB - Second input argument (if NARGS is 2)
+! KRESLT - Result code returned to the calling routine.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(6) :: KROUTN
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER NARGS,KRESLT
+
+ INTEGER NCATMA,NCATMB
+
+ INTEGER, PARAMETER :: &
+ KFACT(15) = (/ 12,12, 0,12, 0, 0, 8, 8, 8, 0, 0, 8, 0, 4, 4 /), &
+ KGAM(15) = (/ 12,12, 0,12, 0, 0, 3,12, 4, 0, 0, 8, 0, 4, 4 /), &
+ KLNGM(15) = (/ 12,12, 0,12,12,12,12,12,12, 0, 0,11, 0, 0, 4 /), &
+ KPSI(15) = (/ 12,12, 0,12, 0, 0, 4,12, 3, 0, 0, 0, 0, 0,12 /)
+
+ CALL FMARGS(KROUTN,NARGS,MA,MB,KRESLT)
+ IF (KFLAG /= 0) RETURN
+
+! Check for special cases.
+
+ CALL FMCAT(MA,NCATMA)
+ NCATMB = 0
+ IF (NARGS == 2) CALL FMCAT(MB,NCATMB)
+
+ IF (KROUTN == 'FMFACT') THEN
+ KRESLT = KFACT(NCATMA)
+ GO TO 110
+ ENDIF
+
+ IF (KROUTN == 'FMGAM ') THEN
+ KRESLT = KGAM(NCATMA)
+ GO TO 110
+ ENDIF
+
+ IF (KROUTN == 'FMLNGM') THEN
+ KRESLT = KLNGM(NCATMA)
+ GO TO 110
+ ENDIF
+
+ IF (KROUTN == 'FMPSI ') THEN
+ KRESLT = KPSI(NCATMA)
+ GO TO 110
+ ENDIF
+
+ KRESLT = 0
+ RETURN
+
+ 110 IF (KRESLT == 12) THEN
+ KFLAG = -4
+ CALL FMWRN2
+ ENDIF
+ IF (KRESLT == 3 .OR. KRESLT == 4) THEN
+ IF (NCATMA == 1 .OR. NCATMA == 7 .OR. NCATMA == 9 .OR. &
+ NCATMA == 15 .OR. NCATMB == 1 .OR. NCATMB == 7 .OR. &
+ NCATMB == 9 .OR. NCATMB == 15) THEN
+ KFLAG = -5
+ ELSE
+ KFLAG = -5
+ CALL FMWRN2
+ ENDIF
+ ENDIF
+ IF (KRESLT == 5 .OR. KRESLT == 6) THEN
+ IF (NCATMA == 1 .OR. NCATMA == 7 .OR. NCATMA == 9 .OR. &
+ NCATMA == 15 .OR. NCATMB == 1 .OR. NCATMB == 7 .OR. &
+ NCATMB == 9 .OR. NCATMB == 15) THEN
+ KFLAG = -6
+ ELSE
+ KFLAG = -6
+ CALL FMWRN2
+ ENDIF
+ ENDIF
+ RETURN
+ END SUBROUTINE FMARG2
+
+ SUBROUTINE FMBERN(N,MA,MB)
+
+! MB = MA*B(N) where B(N) is the Nth Bernoulli number.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER N
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+! MBERN is the array used to save Bernoulli numbers so they
+! do not have to be re-computed on subsequent calls.
+
+! Only the even-numbered Bernoulli numbers are stored.
+! B(2N) starts in MBERN(NPTBRN(N)) for 2N >= 28.
+! The first few numbers have small numerators and
+! denominators, and they are done using FMMPYI and FMDIVI,
+! and are not stored in MBERN.
+
+ DOUBLE PRECISION U,X,B
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MNEXP,MXSAVE
+ INTEGER IEXTRA,INTNDG,J,J2,JSIZE,K,KASAVE,KOVUN,KRESLT,L,LARGE, &
+ LARGED,N2,NBOT,NDGOAL,NDIV,NDOLD,NDP,NDSAV1,NDSAV2,NDSAVE, &
+ NEEDED,NEXTD,NEXTN,NGOAL,NMPY,NSTART,NTD,NTN,NTOP,NUMTRY,NX
+
+ IF (NTRACE /= 0) THEN
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMBERN'
+ CALL FMNTRI(2,N,1)
+ NCALL = NCALL - 1
+ ENDIF
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (ABS(MA(1)) > MEXPAB) THEN
+ CALL FMENT2('FMBERN',MA,MA,1,0,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ ELSE
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMBERN'
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MA,1,0)
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = INT(5.0/ALOGMT + 2.0 + (REAL(NDIG)*ALOGMT)**0.35/ALOGMT)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWARN
+ NDIG = NDSAVE
+ KRESLT = 12
+ CALL FMRSLT(MA,MA,MB,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+ ENDIF
+ KASAVE = KACCSW
+ MXSAVE = MXEXP
+ MXEXP = MXEXP2
+ ENDIF
+
+ KACCSW = 1
+ MACCA = MA(0)
+ CALL FMEQ2(MA,M20,NDSAVE,NDIG)
+ M20(0) = NINT(NDIG*ALOGM2)
+ NUMTRY = 0
+
+! Check for special cases.
+
+ 110 IF (N >= 2 .AND. N <= 26) THEN
+ CALL FMBER2(N,M20,M19)
+ GO TO 130
+ ELSE IF (N == 0) THEN
+ CALL FMEQ(M20,M19)
+ GO TO 130
+ ELSE IF (N == 1) THEN
+ CALL FMDIVI(M20,-2,M19)
+ GO TO 130
+ ELSE IF (MOD(N,2) == 1 .OR. N < 0) THEN
+ CALL FMI2M(0,M19)
+ GO TO 130
+ ELSE IF (MA(2) == 0) THEN
+ CALL FMI2M(0,M19)
+ GO TO 130
+ ENDIF
+
+! See if B(N) has already been computed with sufficient
+! precision.
+
+ N2 = N/2
+ IF (MBASE == MBSBRN) THEN
+ IF (N < NUMBRN .AND. NPTBRN(N2+1)-NPTBRN(N2) >= NDIG+3) THEN
+ CALL FMMPY(MBERN(NPTBRN(N2)),M20,M19)
+ GO TO 130
+ ELSE IF (N == NUMBRN .AND. NWDBRN-NPTBRN(N2) >= NDIG+2) THEN
+ CALL FMMPY(MBERN(NPTBRN(N2)),M20,M19)
+ GO TO 130
+ ENDIF
+ ENDIF
+
+ IF (MBSBRN /= MBASE) THEN
+ NUMBRN = 0
+ NWDBRN = 0
+ ENDIF
+
+! See if the MBERN array is big enough to hold the
+! additional Bernoulli numbers up to B(N).
+
+ NSTART = 28
+ IF (MBSBRN == MBASE .AND. NUMBRN >= 28) THEN
+ NSTART = NUMBRN + 2
+ DO J = 28, NUMBRN-2, 2
+ J2 = J/2
+ JSIZE = NPTBRN(J2+1) - NPTBRN(J2)
+ IF (JSIZE < NDIG+3) THEN
+ NSTART = J
+ NWDBRN = NPTBRN(J2) - 1
+ GO TO 120
+ ENDIF
+ ENDDO
+ JSIZE = NWDBRN - NPTBRN(NUMBRN/2)
+ IF (JSIZE < NDIG+2) THEN
+ NSTART = NUMBRN
+ NWDBRN = NPTBRN(NUMBRN/2) - 1
+ GO TO 120
+ ENDIF
+ ENDIF
+
+ 120 NEEDED = ((N-NSTART)/2+1)*(NDIG+3)
+ IF (NEEDED > LMBERN-NWDBRN) THEN
+ KFLAG = -11
+ CALL FMWRN2
+ WRITE (KW,*) ' Out of memory for storing Bernoulli numbers in FMBERN.'
+ WRITE (KW,*) ' For B(',N,') with NDIG = ',NDIG,', ',NEEDED+NWDBRN, &
+ ' words are needed.'
+ WRITE (KW,*) ' The current dimension of MBERN is ',LMBERN
+ WRITE (KW,*) ' '
+ MXEXP = MXSAVE
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MB)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ KACCSW = KASAVE
+ RETURN
+ ENDIF
+
+! Compute more Bernoulli numbers.
+
+ X = 1.0D0
+ B = DBLE(MBASE)
+ NDP = 0
+ DO J = 1, 80
+ X = X/B
+ IF ((1.0D0+X) <= 1.0D0) THEN
+ NDP = J-1
+ IF (NDIG <= NDP) X = 4.0D0*DPPI*DPPI
+ EXIT
+ ENDIF
+ ENDDO
+ INTNDG = INT(ALOGMX/ALOGMB + 1.0)
+ NX = INT(DBLE(NDIG)*DLOGMB/DLOGTW + 2.0D0)
+
+ DO J = NSTART, N, 2
+
+! Check to see if J is large enough so that the formula
+! B(J) = -B(J-2)*(J-1)*J/(2*pi)**2 can be used.
+
+ IF (J >= NX .AND. NDIG <= NDP .AND. J > 28) THEN
+ J2 = J/2
+ MNEXP = MBERN(NPTBRN(J2-1)+2)
+ MBERN(NPTBRN(J2-1)+2) = 0
+ CALL FMM2DP(MBERN(NPTBRN(J2-1)),U)
+ MBERN(NPTBRN(J2-1)+2) = MNEXP
+ U = -U*(J*J-J)/X
+ NPTBRN(J2) = NWDBRN + 1
+ NUMBRN = J
+ MBSBRN = MBASE
+ NWDBRN = NPTBRN(J2) + NDIG + 02
+ CALL FMDPM(U,MBERN(NPTBRN(J2)))
+ MBERN(NPTBRN(J2)+2) = MBERN(NPTBRN(J2)+2) + MNEXP
+ CYCLE
+ ENDIF
+
+ IF (J >= NX .AND. J > 28) THEN
+ J2 = J/2
+ NPTBRN(J2) = NWDBRN + 1
+ NUMBRN = J
+ MBSBRN = MBASE
+ NWDBRN = NPTBRN(J2) + NDIG + 02
+ CALL FMPI(M17)
+ CALL FMSQR_R1(M17)
+ IF (MOD(J,4) == 0 .OR. MOD(J,4) == 1) THEN
+ L = -(J*J-J)/4
+ CALL FMMPYI(MBERN(NPTBRN(J2-1)),L,M18)
+ ELSE
+ L = -(J*J-J)
+ CALL FMMPYI(MBERN(NPTBRN(J2-1)),L,M18)
+ CALL FMDIVI_R1(M18,4)
+ ENDIF
+ CALL FMDIV(M18,M17,MBERN(NPTBRN(J2)))
+ CYCLE
+ ENDIF
+
+! Use the recurrence involving a sum of binomial
+! coefficients times previous B's.
+
+ NTOP = J + 3
+ NBOT = J - 6
+ LARGE = INT(INTMAX/NTOP)
+ LARGED = MIN(LARGE,INT(MXBASE))
+ CALL FMCMBI(NTOP,NBOT,M17)
+ IF (NBOT <= 26) THEN
+ CALL FMBER2(NBOT,M17,M18)
+ ELSE
+ CALL FMMPY(MBERN(NPTBRN(NBOT/2)),M17,M18)
+ ENDIF
+ NDSAV1 = NDIG
+ DO NBOT = J-12, 0, -6
+ NTN = NBOT + 6
+ NTD = NTOP - NBOT - 5
+ NEXTN = NTN
+ NEXTD = NTD
+ IF (NBOT >= 6) THEN
+ NDSAV2 = NDIG
+ DO K = 1, 5
+ NEXTN = NEXTN - 1
+ NEXTD = NEXTD + 1
+ NMPY = NTN*NEXTN
+ NDIV = NTD*NEXTD
+ IF (NMPY <= LARGE .AND. NDIV <= LARGED) THEN
+ NTN = NMPY
+ NTD = NDIV
+ ELSE
+ CALL FMGCDI(NMPY,NDIV)
+ IF (NMPY <= LARGE .AND. NDIV <= LARGED) THEN
+ NTN = NMPY
+ NTD = NDIV
+ ELSE
+ NDIG = MAX(2,MIN(NDSAV2,INT(M17(1))+INTNDG))
+ CALL FMMPYI_R1(M17,NTN)
+ CALL FMDIVI_R1(M17,NTD)
+ NTN = NEXTN
+ NTD = NEXTD
+ ENDIF
+ ENDIF
+ ENDDO
+ NDIG = MAX(2,MIN(NDSAV2,INT(M17(1))+INTNDG))
+ CALL FMMPYI_R1(M17,NTN)
+ CALL FMDIVI_R1(M17,NTD)
+ NDIG = NDSAV2
+ ELSE
+ CALL FMCMBI(NTOP,NBOT,M17)
+ ENDIF
+ M17(0) = NINT(NDIG*ALOGM2)
+
+! Now M17 is the combination NTOP choose NBOT.
+
+ IF (NBOT <= 26) THEN
+ CALL FMBER2(NBOT,M17,M19)
+ ELSE
+ CALL FMMPY(MBERN(NPTBRN(NBOT/2)),M17,M19)
+ ENDIF
+ NDIG = NDSAV1
+ CALL FMADD_R1(M18,M19)
+ NDIG = MAX(2,NDSAV1-INT(M18(1)-M19(1)))
+ ENDDO
+
+ NDIG = NDSAV1
+ IF (MOD(J,6) == 4) THEN
+ CALL FMI2M(NTOP,M16)
+ CALL FMDIVI(M16,-6,M19)
+ CALL FMSUB_R2(M19,M18)
+ ELSE
+ CALL FMI2M(NTOP,M16)
+ CALL FMDIVI(M16,3,M19)
+ CALL FMSUB_R2(M19,M18)
+ ENDIF
+
+ J2 = J/2
+ NPTBRN(J2) = NWDBRN + 1
+ NUMBRN = J
+ MBSBRN = MBASE
+ NWDBRN = NPTBRN(J2) + NDIG + 02
+
+ CALL FMMPYI_R1(M18,6)
+ NTN = NTOP*(NTOP-1)
+ LARGE = INT(INTMAX/NTOP)
+ IF (NTN > MXBASE .OR. NTOP > LARGE) THEN
+ CALL FMDIVI_R1(M18,NTOP)
+ NTN = NTOP - 1
+ CALL FMDIVI_R1(M18,NTN)
+ NTN = NTOP - 2
+ CALL FMDIVI(M18,NTN,MBERN(NPTBRN(J2)))
+ ELSE IF (NTN*(NTOP-2) > MXBASE .OR. NTN > LARGE) THEN
+ CALL FMDIVI_R1(M18,NTN)
+ NTN = NTOP - 2
+ CALL FMDIVI(M18,NTN,MBERN(NPTBRN(J2)))
+ ELSE
+ NTN = NTN*(NTOP-2)
+ CALL FMDIVI(M18,NTN,MBERN(NPTBRN(J2)))
+ ENDIF
+ ENDDO
+
+ CALL FMMPY(MBERN(NPTBRN(N2)),M20,M19)
+
+! Check for too much cancellation.
+
+ 130 IF (NCALL <= 1) THEN
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
+ ELSE
+ NGOAL = INT(-MXEXP2)
+ ENDIF
+ IF (M19(0) <= NGOAL) THEN
+ IF (NUMTRY > 0) THEN
+ NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
+ DO J = 1, NDGOAL+1
+ IF (MRETRY(J) /= M19(J)) GO TO 140
+ ENDDO
+ GO TO 150
+ ENDIF
+ 140 IEXTRA = INT(REAL(NGOAL-M19(0))/ALOGM2 + 23.03/ALOGMB) + 1
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M19)
+ GO TO 150
+ ENDIF
+ CALL FMEQ2_R1(M20,NDSAVE,NDIG)
+ NUMTRY = NUMTRY + 1
+ CALL FMEQ2(M19,MRETRY,NDOLD,NDIG)
+ GO TO 110
+ ENDIF
+
+ 150 MACMAX = NINT(NDSAVE*ALOGM2)
+ M19(0) = MIN(M19(0),MACCA,MACMAX)
+ CALL FMEXT2(M19,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMBERN
+
+ SUBROUTINE FMBER2(N,MA,MB)
+
+! Internal routine for small Bernoulli numbers.
+
+! MB = MA*B(N) for N an even integer between 2 and 26.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER N
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER N2
+ INTEGER :: NBTOP(13) = (/ &
+ 1, 1, 1, 1, 5, -691, 7, -3617, 43867, -174611, &
+ 854513, -236364091, 8553103 /)
+ INTEGER :: NBBOT(13) = (/ &
+ 6, -30, 42, -30, 66, 2730, 6, 510, 798, 330, &
+ 138, 2730, 6 /)
+
+ IF (N <= 0) THEN
+ CALL FMEQ(MA,MB)
+ RETURN
+ ELSE IF (N == 1) THEN
+ CALL FMDIVI(MA,-2,MB)
+ RETURN
+ ELSE IF (MOD(N,2) == 1) THEN
+ CALL FMI2M(0,MB)
+ RETURN
+ ENDIF
+
+ N2 = N/2
+
+ IF (N <= 26) THEN
+ IF (NBTOP(N2) == 1) THEN
+ CALL FMDIVI(MA,NBBOT(N2),MB)
+ ELSE
+ CALL FMMPYI(MA,NBTOP(N2),MB)
+ CALL FMDIVI_R1(MB,NBBOT(N2))
+ ENDIF
+ ENDIF
+ RETURN
+ END SUBROUTINE FMBER2
+
+ SUBROUTINE FMBETA(MA,MB,MC)
+
+! MC = beta(MA,MB). beta(MA,MB) = gamma(MA) * gamma(MB) / gamma(MA+MB)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MXSAVE,MZERO
+ INTEGER IEXTRA,J,K,K10,K11,KASAVE,KB,KC,KFLKB,KFLNKB,KOVUN,KRESLT, &
+ KWRNSV,N,NB,NBOT,NDGOAL,NDOLD,NDSAVE,NGOAL,NK,NKB,NUMTRY
+ LOGICAL FMCOMP
+ REAL X
+
+ CALL FMENT2('FMBETA',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ KACCSW = 1
+ MACCA = MA(0)
+ MACCB = MB(0)
+ CALL FMEQ2(MA,M29,NDSAVE,NDIG)
+ M29(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ2(MB,M30,NDSAVE,NDIG)
+ M30(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ(M29,M32)
+ NUMTRY = 0
+
+ 110 CALL FMADD(M29,M30,M28)
+ IF (M29(2) == 0 .OR. M30(2) == 0) THEN
+ CALL FMST2M('UNKNOWN',M33)
+ KFLAG = -4
+ GO TO 140
+ ENDIF
+ IF (FMCOMP(M28,'==',M29)) THEN
+ IF (M30(1) > MEXPAB) THEN
+ CALL FMABS(M30,M23)
+ CALL FMDPM(DLOGMB,M16)
+ CALL FMMPY_R2(M16,M23)
+ J = (M29(1)+1)
+ CALL FMMPYI_R1(M23,J)
+ ELSE
+ CALL FMABS(M30,M23)
+ ENDIF
+ CALL FMI2M(1,M16)
+ CALL FMULP(M16,M17)
+ CALL FMEQ(M17,M16)
+ IF (FMCOMP(M23,'<=',M16)) THEN
+ CALL FMGAM(M30,M33)
+ GO TO 140
+ ENDIF
+ ENDIF
+ IF (FMCOMP(M28,'==',M30)) THEN
+ IF (M29(1) > MEXPAB) THEN
+ CALL FMABS(M29,M23)
+ CALL FMDPM(DLOGMB,M16)
+ CALL FMMPY_R2(M16,M23)
+ J = (M30(1)+1)
+ CALL FMMPYI_R1(M23,J)
+ ELSE
+ CALL FMABS(M29,M23)
+ ENDIF
+ CALL FMI2M(1,M16)
+ CALL FMULP(M16,M17)
+ CALL FMEQ(M17,M16)
+ IF (FMCOMP(M23,'<=',M16)) THEN
+ CALL FMGAM(M29,M33)
+ GO TO 140
+ ENDIF
+ ENDIF
+ IF (M29(1) == MEXPOV) THEN
+ IF (M29(-1)*M29(2) > 0 .AND. M30(-1) > 0 .AND. M30(1) >= 1) THEN
+ CALL FMST2M('UNDERFLOW',M33)
+ KFLAG = -6
+ GO TO 140
+ ENDIF
+ ENDIF
+ IF (M30(1) == MEXPOV) THEN
+ IF (M30(-1)*M30(2) > 0 .AND. M29(-1) > 0 .AND. M29(1) >= 1) THEN
+ CALL FMST2M('UNDERFLOW',M33)
+ KFLAG = -6
+ GO TO 140
+ ENDIF
+ ENDIF
+
+! See if any of the terms are negative integers.
+
+ CALL FMINT(M29,M18)
+ IF (M29(-1) < 0) THEN
+ IF (FMCOMP(M29,'==',M18)) THEN
+ CALL FMST2M('UNKNOWN',M33)
+ KFLAG = -4
+ GO TO 140
+ ENDIF
+ ENDIF
+ CALL FMINT(M30,M19)
+ IF (M30(-1) < 0) THEN
+ IF (FMCOMP(M30,'==',M19)) THEN
+ CALL FMST2M('UNKNOWN',M33)
+ KFLAG = -4
+ GO TO 140
+ ENDIF
+ ENDIF
+ IF (M28(2) == 0) THEN
+ CALL FMI2M(0,M33)
+ GO TO 120
+ ELSE IF (M28(-1) < 0) THEN
+ CALL FMSUB(M29,M18,M16)
+ CALL FMSUB(M30,M19,M23)
+ CALL FMADD_R2(M16,M23)
+ CALL FMINT(M23,M24)
+ IF (FMCOMP(M23,'==',M24)) THEN
+ CALL FMI2M(0,M33)
+ GO TO 120
+ ENDIF
+ ENDIF
+
+! See if any of the terms are small integers.
+
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMM2I(M29,N)
+ KFLKB = KFLAG
+ CALL FMM2I(M30,K)
+ KFLNKB = KFLAG
+ CALL FMM2I(M28,NK)
+ KWARN = KWRNSV
+ NB = N + K - 2
+ KB = N - 1
+ NKB = K - 1
+
+ IF (KFLKB == 0 .AND. KFLNKB == 0) THEN
+ IF (MIN(KB,NKB) <= 200) THEN
+ CALL FMCMBI(NB,KB,M33)
+ CALL FMI2M(N+K-1,M18)
+ CALL FMMPY_R1(M33,M18)
+ CALL FMI2M(1,M16)
+ CALL FMDIV_R2(M16,M33)
+ GO TO 120
+ ENDIF
+ ENDIF
+ NBOT = 0
+ IF (KFLKB == 0 .AND. N <= 200) THEN
+ CALL FMEQ(M30,M31)
+ CALL FMPOCH(M31,N,M15)
+ CALL FMEQ(M15,M31)
+ CALL FMFCTI(KB,M21)
+ CALL FMDIV(M21,M31,M32)
+ IF (ABS(M32(1)) < MXSAVE) THEN
+ CALL FMEQ(M32,M33)
+ GO TO 140
+ ENDIF
+ NBOT = 1
+ ELSE IF (KFLNKB == 0 .AND. K <= 200) THEN
+ CALL FMEQ(M29,M31)
+ CALL FMPOCH(M31,K,M15)
+ CALL FMEQ(M15,M31)
+ CALL FMFCTI(NKB,M21)
+ CALL FMDIV(M21,M31,M32)
+ IF (ABS(M32(1)) < MXSAVE) THEN
+ CALL FMEQ(M32,M33)
+ GO TO 140
+ ENDIF
+ NBOT = 1
+ ENDIF
+ IF (NBOT == 1) THEN
+ CALL FMEQ2(MA,M29,NDSAVE,NDIG)
+ M29(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ2(MB,M30,NDSAVE,NDIG)
+ M30(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ(M29,M32)
+ CALL FMADD(M29,M30,M28)
+ ENDIF
+
+! General case. Use FMGAM, unless one of the numbers
+! is too big. If so, use FMLNGM.
+
+ X = ALOGMB*REAL(MXEXP)
+ CALL FMSP2M(X/LOG(X),M17)
+ CALL FMABS(M28,M04)
+ CALL FMABS(M29,M05)
+ CALL FMABS(M30,M06)
+ IF (FMCOMP(M04,'>=',M17) .OR. FMCOMP(M05,'>=',M17) .OR. &
+ FMCOMP(M06,'>=',M17)) THEN
+
+! See if one argument is not very large and the other is
+! much larger. For many of these cases, Stirling's formula
+! can be used to simplify Beta and avoid cancellation.
+
+ IF (M29(1) > M30(1)) THEN
+ CALL FMEQ(M29,M20)
+ CALL FMEQ(M30,M21)
+ ELSE
+ CALL FMEQ(M30,M20)
+ CALL FMEQ(M29,M21)
+ ENDIF
+ IF (M20(1) > NDIG .AND. M20(1) >= M21(1)+NDIG) THEN
+ IF (M21(-1) < 0) THEN
+ IF (M21(1) > NDIG) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M33)
+ GO TO 140
+ ELSE
+ CALL FMI2M(2,M04)
+ CALL FMEQ(M21,M05)
+ M05(-1) = -M05(-1)
+ CALL FMINT(M05,M16)
+ CALL FMMOD(M16,M04,M22)
+ IF (M22(2) == 0) THEN
+ CALL FMADD(M20,M21,M27)
+ CALL FMLN(M27,M16)
+ CALL FMMPY(M21,M16,M27)
+ CALL FMI2M(1,M16)
+ CALL FMADD(M21,M16,M28)
+ CALL FMEQ(M21,M31)
+ CALL FMLNGM(M28,M14)
+ CALL FMEQ(M14,M28)
+ CALL FMSUB(M28,M27,M16)
+ CALL FMEXP(M16,M23)
+ CALL FMDIV_R1(M23,M31)
+ CALL FMEQ(M23,M33)
+ GO TO 120
+ ENDIF
+ ENDIF
+ ENDIF
+ CALL FMADD(M20,M21,M27)
+ CALL FMLN(M27,M16)
+ CALL FMMPY(M21,M16,M27)
+ CALL FMEQ(M21,M31)
+ CALL FMLNGM(M31,M28)
+ CALL FMSUB(M28,M27,M16)
+ CALL FMEXP(M16,M23)
+ CALL FMEQ(M23,M33)
+ GO TO 120
+ ENDIF
+
+! See if both arguments are large. For many of these cases,
+! Stirling's formula can be used to detect cases where the
+! result will underflow.
+
+ CALL FMDPM(1.0D7,M16)
+ IF (FMCOMP(M29,'>',M16) .AND. FMCOMP(M30,'>',M16)) THEN
+ CALL FMADD(M29,M30,M16)
+ CALL FMLN(M16,M26)
+ CALL FMMPY_R2(M16,M26)
+ IF (M26(1) /= MUNKNO .AND. M26(2) /= 0) M26(-1) = -M26(-1)
+ CALL FMLN(M29,M16)
+ CALL FMMPY_R2(M29,M16)
+ CALL FMADD_R1(M26,M16)
+ CALL FMLN(M30,M16)
+ CALL FMMPY_R2(M30,M16)
+ CALL FMADD_R1(M26,M16)
+ CALL FMEXP(M26,M27)
+ IF (M27(1) == MEXPUN) THEN
+ CALL FMEQ(M27,M33)
+ GO TO 140
+ ENDIF
+ ENDIF
+
+! Compute IEXTRA, the number of extra digits required
+! to compensate for cancellation error.
+
+ MZERO = 0
+ IEXTRA = INT(MAX(M28(1),M29(1),M30(1),MZERO))
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M29,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M30,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M33)
+ GO TO 140
+ ENDIF
+ CALL FMADD(M29,M30,M28)
+ CALL FMI2M(1,M20)
+ CALL FMI2M(2,M21)
+ CALL FMEQ(M28,M33)
+ K10 = 0
+ K11 = 0
+ KC = 0
+ IF (M29(-1) < 0) THEN
+ CALL FMINT(M29,M22)
+ CALL FMMOD(M22,M21,M23)
+ IF (M23(2) == 0) THEN
+ K10 = 1
+ CALL FMADD_R1(M29,M20)
+ ENDIF
+ ENDIF
+ IF (M30(-1) < 0) THEN
+ CALL FMINT(M30,M22)
+ CALL FMMOD(M22,M21,M23)
+ IF (M23(2) == 0) THEN
+ K11 = 1
+ CALL FMADD_R1(M30,M20)
+ ENDIF
+ ENDIF
+ IF (M33(-1) < 0) THEN
+ CALL FMINT(M33,M22)
+ CALL FMMOD(M22,M21,M23)
+ IF (M23(2) == 0) THEN
+ KC = 1
+ CALL FMADD_R1(M33,M20)
+ ENDIF
+ ENDIF
+ CALL FMLNGM(M29,M28)
+ CALL FMLNGM(M30,M31)
+ CALL FMADD_R1(M28,M31)
+ CALL FMLNGM(M33,M31)
+ CALL FMSUB(M28,M31,M16)
+ CALL FMEXP(M16,M28)
+ IF (K10 == 1 .OR. K11 == 1 .OR. KC == 1) THEN
+ CALL FMI2M(1,M20)
+ IF (K10 == 1) THEN
+ CALL FMSUB_R1(M29,M20)
+ CALL FMDIV_R1(M28,M29)
+ ENDIF
+ IF (K11 == 1) THEN
+ CALL FMSUB_R1(M30,M20)
+ CALL FMDIV_R1(M28,M30)
+ ENDIF
+ IF (KC == 1) THEN
+ CALL FMSUB_R1(M33,M20)
+ CALL FMMPY_R1(M28,M33)
+ ENDIF
+ ENDIF
+ CALL FMEQ(M28,M33)
+ ELSE
+ CALL FMEQ(M28,M33)
+ CALL FMGAM(M29,M31)
+ CALL FMEQ(M31,M29)
+ CALL FMGAM(M30,M31)
+ CALL FMEQ(M31,M30)
+ CALL FMGAM(M33,M31)
+ CALL FMEQ(M31,M33)
+ CALL FMMPY(M29,M30,M18)
+ CALL FMDIV_R2(M18,M33)
+ ENDIF
+
+! Check for too much cancellation.
+
+ 120 IF (NCALL <= 1) THEN
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
+ ELSE
+ NGOAL = INT(-MXEXP2)
+ ENDIF
+ IF (M33(0) <= NGOAL) THEN
+ IF (NUMTRY > 0) THEN
+ NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
+ DO J = 1, NDGOAL+1
+ IF (MRETRY(J) /= M33(J)) GO TO 130
+ ENDDO
+ GO TO 140
+ ENDIF
+ 130 IEXTRA = INT(REAL(NGOAL-M33(0))/ALOGM2 + 23.03/ALOGMB) + 1
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M33)
+ GO TO 140
+ ENDIF
+ CALL FMEQ2(MA,M29,NDSAVE,NDIG)
+ CALL FMEQ2(MB,M30,NDSAVE,NDIG)
+ NUMTRY = NUMTRY + 1
+ CALL FMEQ2(M33,MRETRY,NDOLD,NDIG)
+ GO TO 110
+ ENDIF
+
+ 140 MACMAX = NINT(NDSAVE*ALOGM2)
+ M33(0) = MIN(M33(0),MACCA,MACCB,MACMAX)
+ CALL FMEXT2(M33,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMBETA
+
+ SUBROUTINE FMCMBI(N,K,MA)
+
+! Internal routine for computing binomial coefficients for integers.
+
+! MA = N choose K.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER N,K
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ INTEGER INTNDG,J,KSTART,KT,L,LARGE,LARGED,NDIV,NDSAVE,NEXTD,NEXTN, &
+ NMPY,NTD,NTN
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ L = MIN(K,N-K)
+ IF (L <= 0) THEN
+ CALL FMI2M(1,MA)
+ RETURN
+ ENDIF
+ IF (L <= 1) THEN
+ CALL FMI2M(N,MA)
+ RETURN
+ ENDIF
+
+! Find the largest value for N choose J using integers.
+
+ NTN = N
+ NTD = 1
+ LARGE = INT(INTMAX/N)
+ DO J = 2, L
+ IF (NTN <= LARGE) THEN
+ NTN = (NTN*((N+1)-J))/J
+ ELSE
+ CALL FMI2M(NTN,MA)
+ NTN = (N+1) - J
+ NTD = J
+ GO TO 110
+ ENDIF
+ ENDDO
+
+ 110 IF (NTD == 1) THEN
+ CALL FMI2M(NTN,MA)
+ RETURN
+ ENDIF
+
+ INTNDG = INT(ALOGMX/ALOGMB + 1.0)
+ NEXTN = NTN
+ NEXTD = NTD
+ KSTART = NTD + 1
+ NDSAVE = NDIG
+
+! Compute the rest of N choose K.
+
+ LARGED = MIN(LARGE,INT(MXBASE))
+ DO KT = KSTART, L
+ NEXTN = NEXTN - 1
+ NEXTD = NEXTD + 1
+ IF (NTN >= LARGE .OR. NTD >= LARGED) THEN
+ NDIG = MAX(2,MIN(NDSAVE,INT(MA(1))+INTNDG))
+ CALL FMMPYI_R1(MA,NTN)
+ CALL FMDIVI_R1(MA,NTD)
+ NTN = NEXTN
+ NTD = NEXTD
+ CYCLE
+ ENDIF
+ NMPY = NTN*NEXTN
+ NDIV = NTD*NEXTD
+ IF (NMPY <= LARGE .AND. NDIV <= LARGED) THEN
+ NTN = NMPY
+ NTD = NDIV
+ ELSE
+ CALL FMGCDI(NMPY,NDIV)
+ IF (NMPY <= LARGE .AND. NDIV <= LARGED) THEN
+ NTN = NMPY
+ NTD = NDIV
+ ELSE
+ NDIG = MAX(2,MIN(NDSAVE,INT(MA(1))+INTNDG))
+ CALL FMMPYI_R1(MA,NTN)
+ CALL FMDIVI_R1(MA,NTD)
+ NTN = NEXTN
+ NTD = NEXTD
+ ENDIF
+ ENDIF
+ ENDDO
+ NDIG = MAX(2,MIN(NDSAVE,INT(MA(1))+INTNDG))
+ CALL FMGCDI(NTN,NTD)
+ CALL FMMPYI_R1(MA,NTN)
+ CALL FMDIVI_R1(MA,NTD)
+ NDIG = NDSAVE
+ MA(0) = NINT(ALOGM2*NDSAVE)
+
+ RETURN
+ END SUBROUTINE FMCMBI
+
+ SUBROUTINE FMCOMB(MA,MB,MC)
+
+! MC = MA choose MB. (Binomial coefficient -- uses gamma for non-integers)
+
+! MC = (MA)! / ( (MB)! * (MA-MB)! )
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MXSAVE,MZERO
+ INTEGER IEXTRA,J,K,K09,K10,K11,KASAVE,KBOT,KC,KFLGK,KFLGNK,KOVUN, &
+ KRESLT,KSIGN,KWRNSV,LARGE,N,NBOT,NDGOAL,NDOLD,NDSAVE,NGOAL, &
+ NK,NUMTRY
+ LOGICAL FMCOMP
+ LOGICAL LC1,LC2,LC3
+ REAL X
+
+ CALL FMENT2('FMCOMB',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ KSIGN = 1
+ KACCSW = 1
+ MACCA = MA(0)
+ MACCB = MB(0)
+ CALL FMEQ2(MA,M29,NDSAVE,NDIG)
+ M29(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ2(MB,M30,NDSAVE,NDIG)
+ M30(0) = NINT(NDIG*ALOGM2)
+ NUMTRY = 0
+
+ 110 CALL FMSUB(M29,M30,M28)
+ IF (M30(2) == 0) THEN
+ CALL FMI2M(1,M32)
+ GO TO 120
+ ENDIF
+
+! See if any of the terms are negative integers.
+
+ CALL FMI2M(1,M22)
+ K10 = 0
+ IF (M29(-1) < 0) THEN
+ CALL FMINT(M29,M18)
+ IF (FMCOMP(M29,'==',M18)) K10 = -1
+ ENDIF
+ K11 = 0
+ IF (M30(-1) < 0) THEN
+ CALL FMINT(M30,M19)
+ IF (FMCOMP(M30,'==',M19)) K11 = -1
+ ENDIF
+ K09 = 0
+ IF (FMCOMP(M29,'<',M30)) THEN
+ CALL FMMOD(M29,M22,M20)
+ CALL FMMOD(M30,M22,M21)
+ CALL FMSUB_R2(M20,M21)
+ CALL FMINT(M21,M20)
+ IF (FMCOMP(M21,'==',M20)) K09 = -1
+ ENDIF
+
+ CALL FMI2M(2,M21)
+
+ IF (K11 == -1) THEN
+ CALL FMI2M(0,M32)
+ GO TO 120
+ ELSE IF (M28(2) == 0) THEN
+ CALL FMI2M(1,M32)
+ GO TO 120
+ ELSE IF (K09 == -1 .AND. K10 == 0) THEN
+ CALL FMI2M(0,M32)
+ GO TO 120
+ ELSE IF (K10 == -1 .AND. K09 == 0) THEN
+ CALL FMST2M('UNKNOWN',M32)
+ KFLAG = -4
+ GO TO 140
+ ELSE IF (K10 == -1 .AND. K09 == -1) THEN
+ CALL FMMOD(M30,M21,M23)
+ IF (M23(2) /= 0) KSIGN = -1
+ CALL FMSUB(M30,M29,M23)
+ CALL FMSUB(M23,M22,M29)
+ CALL FMSUB(M29,M30,M28)
+ ENDIF
+
+! Check for an obviously overflowed result.
+
+ IF (M29(1) == MEXPOV) THEN
+ IF (M29(-1)*M29(2) > 0 .AND. M30(-1) > 0 .AND. M30(1) >= 1 &
+ .AND. M30(1) < MEXPOV) THEN
+ CALL FMST2M('OVERFLOW',M32)
+ KFLAG = -5
+ GO TO 140
+ ENDIF
+ ENDIF
+ IF (M29(1) >= 10000) THEN
+ CALL FMI2M(1,M16)
+ IF (FMCOMP(M30,'>',M16) .AND. FMCOMP(M30,'<',M29)) THEN
+ CALL FMSUB(M29,M30,M16)
+ CALL FMMIN(M30,M16,M24)
+ CALL FMSUB(M29,M24,M16)
+ CALL FMADDI(M16,1)
+ CALL FMDIV(M16,M24,M23)
+ CALL FMLN(M23,M16)
+ CALL FMADDI(M16,1)
+ CALL FMMPY(M24,M16,M23)
+ CALL FMDPM(6.283185D0,M06)
+ CALL FMMPY(M06,M24,M16)
+ CALL FMLN(M16,M06)
+ CALL FMDIVI(M06,2,M16)
+ CALL FMSUB_R1(M23,M16)
+ CALL FMEXP(M23,M12)
+ CALL FMEQ(M12,M23)
+ IF (M23(1) == MEXPOV) THEN
+ CALL FMST2M('OVERFLOW',M32)
+ KFLAG = -5
+ GO TO 140
+ ENDIF
+ ENDIF
+ ENDIF
+
+! See if any of the terms are small integers.
+
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMM2I(M29,N)
+ CALL FMM2I(M30,K)
+ KFLGK = KFLAG
+ CALL FMM2I(M28,NK)
+ KFLGNK = KFLAG
+ KWARN = KWRNSV
+
+ CALL FMI2M(1,M16)
+ CALL FMADD(M29,M16,M06)
+ CALL FMSUB_R1(M06,M16)
+ IF (KFLGK == 0 .AND. M06(2) == 0) THEN
+ CALL FMI2M(2,M32)
+ CALL FMMOD(M30,M32,M16)
+ CALL FMEQ(M16,M32)
+ IF (M32(2) == 0) THEN
+ CALL FMDIV(M29,M30,M32)
+ IF (M32(1) /= MUNKNO .AND. M32(2) /= 0) M32(-1) = -M32(-1)
+ ELSE
+ CALL FMDIV(M29,M30,M32)
+ ENDIF
+ GO TO 120
+ ENDIF
+ IF (KFLGK == 0 .AND. KFLGNK == 0 .AND. N /= 0) THEN
+ IF (MIN(K,NK) <= 200) THEN
+ CALL FMCMBI(N,K,M32)
+ GO TO 120
+ ENDIF
+ ENDIF
+ NBOT = 0
+ IF (KFLGK == 0 .AND. K <= 200) NBOT = K
+ IF (KFLGNK == 0 .AND. NK <= 200) NBOT = NK
+ IF (NBOT > 0) THEN
+ LARGE = INT(MXBASE/NBOT)
+ KBOT = 1
+ CALL FMEQ(M29,M18)
+ CALL FMEQ(M29,M19)
+ CALL FMI2M(-1,M20)
+ DO J = 2, NBOT
+ CALL FMADD_R1(M18,M20)
+ CALL FMMPY_R2(M18,M19)
+ KBOT = KBOT*J
+ IF (KBOT >= LARGE) THEN
+ CALL FMDIVI_R1(M19,KBOT)
+ KBOT = 1
+ ENDIF
+ ENDDO
+ CALL FMDIVI(M19,KBOT,M32)
+ GO TO 120
+ ENDIF
+
+! General case. Use FMFACT, unless one of the numbers
+! is too big. If so, use FMLNGM.
+
+ X = ALOGMB*REAL(MXEXP)
+ CALL FMSP2M(X/LOG(X),M17)
+ CALL FMABS(M28,M16)
+ LC1 = FMCOMP(M16,'>=',M17)
+ CALL FMABS(M29,M16)
+ LC2 = FMCOMP(M16,'>=',M17)
+ CALL FMABS(M30,M16)
+ LC3 = FMCOMP(M16,'>=',M17)
+ IF (LC1 .OR. LC2 .OR. LC3) THEN
+
+! See if the second argument is not very large and the first
+! is much larger. For many of these cases, Stirling's formula
+! can be used to simplify Comb and avoid cancellation.
+
+ IF (M29(1) > M30(1) .AND. M29(-1) > 0 .AND. &
+ M30(-1) > 0) THEN
+ CALL FMEQ(M29,M20)
+ CALL FMEQ(M30,M21)
+ ELSE
+ CALL FMI2M(1,M20)
+ CALL FMI2M(1,M21)
+ ENDIF
+ IF (M20(1) > NDIG .AND. M20(1) >= M21(1)+NDIG) THEN
+ CALL FMI2M(1,M16)
+ CALL FMADD(M21,M16,M31)
+ CALL FMLN(M20,M16)
+ CALL FMADDI(M16,-1)
+ CALL FMMPY(M21,M16,M27)
+ CALL FMADD_R2(M21,M27)
+ CALL FMLNGM(M31,M28)
+ CALL FMSUB(M27,M28,M16)
+ CALL FMEXP(M16,M23)
+ CALL FMEQ(M23,M32)
+ GO TO 120
+ ENDIF
+
+! Compute IEXTRA, the number of extra digits required
+! to compensate for cancellation error.
+
+ MZERO = 0
+ IEXTRA = INT(MAX(M28(1),M29(1),M30(1),MZERO))
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M29,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M30,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M32)
+ CALL FMEXT2(M32,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ ENDIF
+ CALL FMSUB(M29,M30,M28)
+ CALL FMI2M(1,M20)
+ CALL FMI2M(2,M21)
+ CALL FMADD(M28,M20,M32)
+ CALL FMADD_R1(M29,M20)
+ CALL FMADD_R1(M30,M20)
+ K10 = 0
+ K11 = 0
+ KC = 0
+ IF (M29(-1) < 0) THEN
+ CALL FMINT(M29,M22)
+ CALL FMMOD(M22,M21,M23)
+ IF (M23(2) == 0) THEN
+ K10 = 1
+ CALL FMADD_R1(M29,M20)
+ ENDIF
+ ENDIF
+ IF (M30(-1) < 0) THEN
+ CALL FMINT(M30,M22)
+ CALL FMMOD(M22,M21,M23)
+ IF (M23(2) == 0) THEN
+ K11 = 1
+ CALL FMADD_R1(M30,M20)
+ ENDIF
+ ENDIF
+ IF (M32(-1) < 0) THEN
+ CALL FMINT(M32,M22)
+ CALL FMMOD(M22,M21,M23)
+ IF (M23(2) == 0) THEN
+ KC = 1
+ CALL FMADD_R1(M32,M20)
+ ENDIF
+ ENDIF
+ CALL FMLNGM(M29,M28)
+ CALL FMLNGM(M30,M31)
+ CALL FMSUB_R1(M28,M31)
+ CALL FMLNGM(M32,M31)
+ CALL FMSUB_R1(M28,M31)
+ CALL FMEXP(M28,M12)
+ CALL FMEQ(M12,M28)
+ IF (K10 == 1 .OR. K11 == 1 .OR. KC == 1) THEN
+ CALL FMI2M(1,M20)
+ IF (K10 == 1) THEN
+ CALL FMSUB_R1(M29,M20)
+ CALL FMDIV_R1(M28,M29)
+ ENDIF
+ IF (K11 == 1) THEN
+ CALL FMSUB_R1(M30,M20)
+ CALL FMMPY_R1(M28,M30)
+ ENDIF
+ IF (KC == 1) THEN
+ CALL FMSUB_R1(M32,M20)
+ CALL FMMPY_R1(M28,M32)
+ ENDIF
+ ENDIF
+ CALL FMEQ(M28,M32)
+ ELSE
+ CALL FMEQ(M28,M32)
+ CALL FMFACT(M29,M31)
+ CALL FMEQ(M31,M29)
+ CALL FMFACT(M30,M31)
+ CALL FMEQ(M31,M30)
+ CALL FMFACT(M32,M31)
+ CALL FMEQ(M31,M32)
+ CALL FMMPY(M32,M30,M18)
+ CALL FMDIV(M29,M18,M32)
+ ENDIF
+
+! Check for too much cancellation.
+
+ 120 IF (NCALL <= 1) THEN
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
+ ELSE
+ NGOAL = INT(-MXEXP2)
+ ENDIF
+ IF (M32(0) <= NGOAL) THEN
+ IF (NUMTRY > 0) THEN
+ NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
+ DO J = 1, NDGOAL+1
+ IF (MRETRY(J) /= M32(J)) GO TO 130
+ ENDDO
+ GO TO 140
+ ENDIF
+ 130 IEXTRA = INT(REAL(NGOAL-M32(0))/ALOGM2 + 23.03/ALOGMB) + 1
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M32)
+ GO TO 140
+ ENDIF
+ CALL FMEQ2(MA,M29,NDSAVE,NDIG)
+ CALL FMEQ2(MB,M30,NDSAVE,NDIG)
+ NUMTRY = NUMTRY + 1
+ CALL FMEQ2(M32,MRETRY,NDOLD,NDIG)
+ GO TO 110
+ ENDIF
+
+ 140 M32(-1) = KSIGN*M32(-1)
+ MACMAX = NINT(NDSAVE*ALOGM2)
+ M32(0) = MIN(M32(0),MACCA,MACCB,MACMAX)
+ CALL FMEXT2(M32,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMCOMB
+
+ FUNCTION FMDPLG(A)
+
+! Internal routine for computing an approximation to
+! Log(Gamma(A)) using Stirling's formula.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ DOUBLE PRECISION FMDPLG,A
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ IF (A > 0.0D0) THEN
+ FMDPLG = -A + (A-0.5D0)*LOG(A) + DLOGTP/2.0D0
+ ELSE IF (A < 0.0D0) THEN
+ FMDPLG = -(A-1.0D0) - (0.5D0-A)*LOG(1.0D0-A) - &
+ DLOGTP/2.0D0 - LOG(ABS(SIN(DPPI*A))+1.0D-10) + &
+ DLOGPI
+ ELSE
+
+! A = 0 is really an approximation for some value in [-1,1].
+
+ FMDPLG = 0.0D0
+ ENDIF
+ RETURN
+ END FUNCTION FMDPLG
+
+ SUBROUTINE FMENT2(NROUTN,MA,MB,NARGS,KNAM,MC,KRESLT,NDSAVE,MXSAVE, &
+ KASAVE,KOVUN)
+
+! Do the argument checking and increasing of precision, overflow
+! threshold, etc., upon entry to an FM routine.
+
+! NROUTN - routine name of calling routine
+! MA - first input argument
+! MB - second input argument (optional)
+! NARGS - number of input arguments
+! KNAM - positive if the routine name is to be printed.
+! MC - result argument
+! KRESLT - returned nonzero if the input arguments give the result
+! immediately (e.g., MA*0 or OVERFLOW*MB)
+! NDSAVE - saves the value of NDIG after NDIG is increased
+! MXSAVE - saves the value of MXEXP
+! KASAVE - saves the value of KACCSW
+! KOVUN - returned nonzero if an input argument is (+ or -) overflow
+! or underflow.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(6) :: NROUTN
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK),MXSAVE
+ INTEGER KNAM,NARGS,KRESLT,NDSAVE,KASAVE,KOVUN
+
+ INTEGER K
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = NROUTN
+ IF (NTRACE /= 0) CALL FMNTR(2,MA,MB,NARGS,KNAM)
+ CALL FMARG2(NROUTN,NARGS,MA,MB,KRESLT)
+
+ KOVUN = 0
+ IF (MA(1) == MEXPOV .OR. MA(1) == MEXPUN) KOVUN = 1
+ IF (NARGS == 2) THEN
+ IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1
+ ENDIF
+
+! Increase the working precision.
+
+ NDSAVE = NDIG
+ MXSAVE = MXEXP
+ KASAVE = KACCSW
+ IF (NCALL == 1) THEN
+ K = INT(5.0/ALOGMT + 2.0 + (REAL(NDIG)*ALOGMT)**0.35/ALOGMT)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ KRESLT = 12
+ ENDIF
+ ENDIF
+
+ IF (KRESLT /= 0) THEN
+ IF (KRESLT == 9 .OR. KRESLT == 10 .OR. KRESLT >= 13) THEN
+ IF (KRAD == 1) THEN
+ CALL FMPI(MC)
+ ELSE
+ CALL FMI2M(180,MC)
+ ENDIF
+ IF (KRESLT <= 10) CALL FMDIVI_R1(MC,2)
+ IF (KRESLT >= 14) CALL FMDIVI_R1(MC,4)
+ CALL FMEQ2_R1(MC,NDIG,NDSAVE)
+ NDIG = NDSAVE
+ IF (KRESLT == 9 .OR. KRESLT == 14) MC(-1) = -1
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+ NDIG = NDSAVE
+ CALL FMRSLT(MA,MB,MC,KRESLT)
+ IF (NTRACE /= 0 .AND. NROUTN /= 'FMIBTA') THEN
+ CALL FMNTR(1,MC,MC,1,1)
+ ENDIF
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+! Extend the overflow/underflow threshold.
+
+ MXEXP = MXEXP2
+ RETURN
+ END SUBROUTINE FMENT2
+
+ SUBROUTINE FMEULR(MA)
+
+! MA = Euler's constant ( 0.5772156649... )
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+ CHARACTER(2315) :: STRING
+ INTEGER K,KASAVE,NDMB,NDSAVE,NDSV
+
+ IF (MBLOGS /= MBASE) CALL FMCONS
+ KFLAG = 0
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMEULR'
+ IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
+ WRITE (KW,"(' Input to FMEULR')")
+ ENDIF
+ KASAVE = KACCSW
+
+! Increase the working precision.
+
+ NDSAVE = NDIG
+ IF (NCALL == 1) THEN
+ K = INT(5.0/ALOGMT + 2.0 + (REAL(NDIG)*ALOGMT)**0.35/ALOGMT)
+ NDIG = MAX(NDIG+K,2)
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - K
+ CALL FMST2M('UNKNOWN',MA)
+ GO TO 110
+ ENDIF
+ ENDIF
+
+! Check to see if Euler's constant has previously been
+! saved in base MBASE with sufficient precision.
+
+ IF (MBSEUL == MBASE .AND. NDGEUL >= NDIG) THEN
+ CALL FMEQ2(M_EULER,MA,NDGEUL,NDSAVE)
+ ELSE
+
+! Euler's constant is slower to compute (using PSI) than the
+! other saved constants, so more digits are stored in STRING
+! for quick conversion.
+
+ NDMB = INT(2300.0*2.302585/ALOGMB)
+ IF (NDMB >= NDIG) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDMB,NDG2MX)
+ STRING = '0.57721566490153286060651209008240243104215933593'// &
+ '9923598805767234884867726777664670936947063291746749514631'// &
+ '4472498070824809605040144865428362241739976449235362535003'// &
+ '3374293733773767394279259525824709491600873520394816567085'// &
+ '3233151776611528621199501507984793745085705740029921354786'// &
+ '1466940296043254215190587755352673313992540129674205137541'// &
+ '3954911168510280798423487758720503843109399736137255306088'// &
+ '9331267600172479537836759271351577226102734929139407984301'// &
+ '0341777177808815495706610750101619166334015227893586796549'// &
+ '7252036212879226555953669628176388792726801324310104765059'// &
+ '6370394739495763890657296792960100901512519595092224350140'// &
+ '9349871228247949747195646976318506676129063811051824197444'// &
+ '8678363808617494551698927923018773910729457815543160050021'// &
+ '8284409605377243420328547836701517739439870030237033951832'// &
+ '8690001558193988042707411542227819716523011073565833967348'// &
+ '7176504919418123000406546931429992977795693031005030863034'// &
+ '1856980323108369164002589297089098548682577736428825395492'// &
+ '5873629596133298574739302373438847070370284412920166417850'// &
+ '2487333790805627549984345907616431671031467107223700218107'// &
+ '4504441866475913480366902553245862544222534518138791243457'// &
+ '3501361297782278288148945909863846006293169471887149587525'// &
+ '4923664935204732436410972682761608775950880951262084045444'// &
+ '7799229915724829251625127842765965708321461029821461795195'// &
+ '7959095922704208989627971255363217948873764210660607065982'// &
+ '5619901028807561251991375116782176436190570584407835735015'// &
+ '8005607745793421314498850078641517161519456570617043245075'// &
+ '0081687052307890937046143066848179164968425491504967243121'// &
+ '8378387535648949508684541023406016225085155838672349441878'// &
+ '8044094077010688379511130787202342639522692097160885690838'// &
+ '2511378712836820491178925944784861991185293910293099059255'// &
+ '2669172744689204438697111471745715745732039352091223160850'// &
+ '8682755889010945168118101687497547096936667121020630482716'// &
+ '5895049327314860874940207006742590918248759621373842311442'// &
+ '6531350292303175172257221628324883811245895743862398703757'// &
+ '6628551303314392999540185313414158621278864807611003015211'// &
+ '9657800681177737635016818389733896639868957932991456388644'// &
+ '3103706080781744899579583245794189620260498410439225078604'// &
+ '6036252772602291968299586098833901378717142269178838195298'// &
+ '4456079160519727973604759102510995779133515791772251502549'// &
+ '2932463250287476779484215840507599290401855764599018627262'
+ CALL FMST2M(STRING,M_EULER)
+ M_EULER(0) = NINT(NDIG*ALOGM2)
+ MBSEUL = MBASE
+ NDGEUL = NDIG
+ IF (ABS(M_EULER(1)) > 10) NDGEUL = 0
+ CALL FMEQ2(M_EULER,MA,NDIG,NDSAVE)
+ NDIG = NDSV
+ ELSE
+ NDSV = NDIG
+ NDIG = MIN(NDIG+2,NDG2MX)
+ CALL FMI2M(1,M_EULER)
+ CALL FMPSI(M_EULER,M14)
+ CALL FMEQ(M14,M_EULER)
+ M_EULER(-1) = ABS(M_EULER(-1))
+ MBSEUL = MBASE
+ NDGEUL = NDIG
+ IF (ABS(M_EULER(1)) > 10) NDGEUL = 0
+ CALL FMEQ2(M_EULER,MA,NDIG,NDSAVE)
+ NDIG = NDSV
+ ENDIF
+ ENDIF
+
+ 110 NDIG = NDSAVE
+ KACCSW = KASAVE
+ IF (NTRACE /= 0) CALL FMNTR(1,MA,MA,1,1)
+ NCALL = NCALL - 1
+ RETURN
+ END SUBROUTINE FMEULR
+
+ SUBROUTINE FMEXT2(MT,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
+
+! Upon exit from an FM routine, the result MT (having precision NDIG)
+! is rounded and returned in MC (having precision NDSAVE).
+! The values of NDIG, MXEXP, and KACCSW are restored.
+! KOVUN is nonzero if one of the routine's input arguments was overflow
+! or underflow.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MT(-1:LUNPCK),MC(-1:LUNPCK),MXSAVE
+ INTEGER NDSAVE,KASAVE,KOVUN
+
+ INTEGER KFSAVE,KWRNSV
+
+ KWRNSV = KWARN
+ KWARN = 0
+ MXEXP = MXSAVE
+ KFSAVE = KFLAG
+ CALL FMEQ2(MT,MC,NDIG,NDSAVE)
+ IF (KFLAG /= -5 .AND. KFLAG /= -6) KFLAG = KFSAVE
+ NDIG = NDSAVE
+ KWARN = KWRNSV
+ IF (KFLAG == 1) KFLAG = 0
+ IF ((MC(1) == MUNKNO .AND. KFLAG /= -9) &
+ .OR. (MC(1) == MEXPUN .AND. KOVUN == 0) &
+ .OR. (MC(1) == MEXPOV .AND. KOVUN == 0)) CALL FMWRN2
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ NCALL = NCALL - 1
+ KACCSW = KASAVE
+ RETURN
+ END SUBROUTINE FMEXT2
+
+ SUBROUTINE FMFACT(MA,MB)
+
+! MB = MA! ( = GAMMA(MA+1))
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
+ INTEGER J,KASAVE,KOVUN,KRESLT,NDSAVE
+
+ CALL FMENT2('FMFACT',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ MACCA = MA(0)
+ CALL FMEQ2(MA,MB,NDSAVE,NDIG)
+ MB(0) = NINT(NDIG*ALOGM2)
+ CALL FMADDI(MB,1)
+ CALL FMGAM(MB,M15)
+ CALL FMEQ(M15,MB)
+ MACMAX = NINT(NDSAVE*ALOGM2)
+ MB(0) = MIN(MB(0),MACCA,MACMAX)
+ DO J = -1, NDIG+1
+ M01(J) = MB(J)
+ ENDDO
+ CALL FMEXT2(M01,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMFACT
+
+ SUBROUTINE FMFCTI(NUM,MA)
+
+! MA = NUM factorial, where NUM is an integer.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER NUM
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK)
+
+ INTEGER J,JK,K,LARGE
+
+ CALL FMI2M(1,MA)
+ IF (NUM <= 1) RETURN
+ J = NUM
+ K = 1
+ LARGE = INT(INTMAX/J)
+ DO JK = 2, J
+ K = K*JK
+ IF (K > LARGE) THEN
+ CALL FMMPYI_R1(MA,K)
+ K = 1
+ ENDIF
+ ENDDO
+ IF (K > 1) CALL FMMPYI_R1(MA,K)
+ RETURN
+ END SUBROUTINE FMFCTI
+
+ SUBROUTINE FMGAM(MA,MB)
+
+! MB = GAMMA(MA)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
+ INTEGER IEXTRA,INTA,J,K,K0,K1,K2,KASAVE,KDIFF,KFL,KOVUN,KRESLT, &
+ KRFLCT,KRSAVE,KSIGN,KWRNSV,KWSAVE,LARGE,LSHIFT,NDGOAL, &
+ NDOLD,NDSAV2,NDSAVE,NGOAL,NUMTRY
+ LOGICAL FMCOMP
+
+ CALL FMENT2('FMGAM ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ KACCSW = 1
+ MACCA = MA(0)
+ CALL FMEQ2(MA,M28,NDSAVE,NDIG)
+ M28(0) = NINT(NDIG*ALOGM2)
+ NUMTRY = 0
+
+! See if there is a small integer separating this argument
+! from the last one.
+
+ IF (MBASE == MBSGAM .AND. NDIG <= NDGGAM) THEN
+ CALL FMSUB(M28,M_GAMMA_MA,M18)
+ IF (M18(2) == 0) THEN
+ CALL FMEQ(M_GAMMA_MB,M22)
+ GO TO 140
+ ENDIF
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMM2I(M18,KDIFF)
+ KWARN = KWRNSV
+ IF (KFLAG == 0 .AND. ABS(KDIFF) <= 50) THEN
+ IF (KDIFF > 0) THEN
+ CALL FMEQ(M_GAMMA_MA,M21)
+ ELSE
+ CALL FMEQ(M28,M21)
+ ENDIF
+ CALL FMEQ(M21,M20)
+ DO J = 1, ABS(KDIFF)-1
+ CALL FMI2M(1,M16)
+ CALL FMADD_R1(M21,M16)
+ CALL FMMPY_R1(M20,M21)
+ ENDDO
+ IF (KDIFF > 0) THEN
+ CALL FMMPY(M_GAMMA_MB,M20,M22)
+ ELSE
+ CALL FMDIV(M_GAMMA_MB,M20,M22)
+ ENDIF
+ GO TO 140
+ ENDIF
+ ENDIF
+
+ CALL FMEQ(M28,M_GAMMA_MB)
+
+! Near zero Gamma(x) is about 1/x.
+
+ 110 IF (M_GAMMA_MB(1) < (-NDIG-3)) THEN
+ CALL FMI2M(1,M16)
+ CALL FMDIV(M16,M_GAMMA_MB,M22)
+ GO TO 140
+ ENDIF
+
+! Check for special cases.
+
+ KRFLCT = 0
+ CALL FMDPM(DBLE(-0.5),M18)
+ IF (FMCOMP(M_GAMMA_MB,'<=',M18)) THEN
+ KRFLCT = 1
+ KFL = 0
+ IF (M28(1) <= NDSAVE) THEN
+ CALL FMINT(M_GAMMA_MB,M21)
+ IF (FMCOMP(M_GAMMA_MB,'==',M21)) KFL = -4
+ ELSE
+ KFL = -4
+ ENDIF
+ IF (KFL /= 0) THEN
+ CALL FMST2M('UNKNOWN',M22)
+ KFLAG = -4
+ GO TO 140
+ ELSE
+ CALL FMI2M(1,M16)
+ CALL FMSUB_R2(M16,M_GAMMA_MB)
+ ENDIF
+ ENDIF
+
+! To speed the asymptotic series calculation, increase
+! the argument by LSHIFT.
+
+ KWSAVE = KWARN
+ KWARN = 0
+ CALL FMM2I(M_GAMMA_MB,INTA)
+ KWARN = KWSAVE
+
+ IF (KFLAG == -4) THEN
+ LSHIFT = 0
+ ELSE
+ LSHIFT = INT(MAX(0.0,REAL(NDIG)*ALOGMB/4.46-REAL(INTA)))
+ ENDIF
+ IF (LSHIFT > 0) LSHIFT = 4*(LSHIFT/4 + 1)
+ IF (KFLAG == 0) THEN
+ IF (INTA <= 200) THEN
+ IF (INTA <= 2) THEN
+ CALL FMI2M(1,M22)
+ GO TO 120
+ ENDIF
+ INTA = INTA - 1
+ CALL FMFCTI(INTA,M22)
+ GO TO 120
+ ENDIF
+ ENDIF
+
+ IF (LSHIFT /= 0) THEN
+ CALL FMI2M(LSHIFT,M16)
+ CALL FMADD(M_GAMMA_MB,M16,M27)
+ ELSE
+ CALL FMEQ(M_GAMMA_MB,M27)
+ ENDIF
+
+! Get Gamma for the shifted argument.
+
+! Compute IEXTRA, the number of extra digits required
+! to compensate for cancellation error when the
+! argument is large.
+
+ IEXTRA = MIN(MAX(INT(M27(1))-1,0),INT(1.0+ALOGMX/ALOGMB))
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M27,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M_GAMMA_MB,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDSAV2 = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX .AND. KRFLCT == 1) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M22)
+ GO TO 140
+ ELSE IF (NDIG > NDG2MX .AND. KRFLCT == 0) THEN
+ KFLAG = -5
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('OVERFLOW',M22)
+ GO TO 140
+ ENDIF
+ CALL FMLNGM(M27,M14)
+ CALL FMEQ(M14,M27)
+ CALL FMEXP(M27,M22)
+
+ NDIG = NDSAV2
+
+! Reverse the shifting.
+! The product MA*(MA+1)*...*(MA+LSHIFT-1) is computed
+! four terms at a time to reduce the number of FMMPY calls.
+
+! M17 is Z
+! M18 is Z**2
+! M19 is Z**3
+! M20 is (Z+K)*...*(Z+K+3)
+! M23 is the current product
+
+ CALL FMEQ(M_GAMMA_MB,M17)
+ IF (LSHIFT > 0) THEN
+ CALL FMSQR(M17,M18)
+ CALL FMMPY(M17,M18,M19)
+ CALL FMSQR(M18,M20)
+ CALL FMMPYI(M19,6,M24)
+ CALL FMADD_R1(M20,M24)
+ CALL FMMPYI(M18,11,M24)
+ CALL FMADD_R1(M20,M24)
+ CALL FMMPYI(M17,6,M24)
+ CALL FMADD_R1(M20,M24)
+ CALL FMEQ(M20,M23)
+ CALL FMMPYI_R1(M19,16)
+ LARGE = INTMAX
+ DO K = 0, LSHIFT-8, 4
+ CALL FMADD_R1(M20,M19)
+ K2 = 24*(2*K + 7)
+ CALL FMMPYI(M18,K2,M24)
+ CALL FMADD_R1(M20,M24)
+ IF (K <= SQRT(REAL(LARGE)/49.0)) THEN
+ K1 = 8*(6*K*K + 42*K + 79)
+ CALL FMMPYI(M17,K1,M24)
+ CALL FMADD_R1(M20,M24)
+ ELSE
+ K1 = 48*K
+ CALL FMMPYI(M17,K1,M24)
+ CALL FMMPYI_R1(M24,K)
+ CALL FMADD_R1(M20,M24)
+ K1 = 336*K + 632
+ CALL FMMPYI(M17,K1,M24)
+ CALL FMADD_R1(M20,M24)
+ ENDIF
+ IF (K <= (REAL(LARGE)/17.0)**0.3333) THEN
+ K0 = 8*(2*K + 7)*(K*K + 7*K + 15)
+ CALL FMADDI(M20,K0)
+ ELSE IF (K <= SQRT(REAL(LARGE)*0.9)) THEN
+ K0 = 8*(2*K + 7)
+ CALL FMI2M(K0,M24)
+ K0 = K*K + 7*K + 15
+ CALL FMMPYI_R1(M24,K0)
+ CALL FMADD_R1(M20,M24)
+ ELSE
+ K0 = 8*(2*K + 7)
+ CALL FMI2M(K0,M24)
+ CALL FMMPYI(M24,K,M21)
+ CALL FMMPYI_R1(M21,K)
+ CALL FMADD_R1(M20,M21)
+ K0 = 7*K + 15
+ CALL FMMPYI_R1(M24,K0)
+ CALL FMADD_R1(M20,M24)
+ ENDIF
+ CALL FMMPY_R1(M23,M20)
+ ENDDO
+ CALL FMDIV_R1(M22,M23)
+ ENDIF
+
+! Use the reflection formula if MA was less than -1/2.
+
+ 120 IF (KRFLCT == 1) THEN
+
+! Reduce the argument before multiplying by Pi.
+
+ CALL FMNINT(M_GAMMA_MB,M18)
+ CALL FMDIVI(M18,2,M19)
+ CALL FMINT(M19,M08)
+ CALL FMEQ(M08,M19)
+ CALL FMMPYI(M19,2,M20)
+ KSIGN = -1
+ IF (FMCOMP(M18,'==',M20)) KSIGN = 1
+ CALL FMSUB(M_GAMMA_MB,M18,M21)
+ M21(0) = M_GAMMA_MB(0)
+ CALL FMPI(M23)
+ CALL FMMPY_R1(M23,M21)
+ KRSAVE = KRAD
+ KRAD = 1
+ CALL FMSIN(M23,M12)
+ CALL FMEQ(M12,M23)
+ M23(-1) = KSIGN*M23(-1)
+ KRAD = KRSAVE
+ CALL FMDIV_R2(MPISAV,M23)
+ CALL FMDIV_R2(M23,M22)
+ ENDIF
+
+! Check for too much cancellation.
+
+ IF (NCALL <= 1) THEN
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
+ ELSE
+ NGOAL = INT(-MXEXP2)
+ ENDIF
+ IF (M22(0) <= NGOAL) THEN
+ IF (NUMTRY > 0) THEN
+ NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
+ DO J = 1, NDGOAL+1
+ IF (MRETRY(J) /= M22(J)) GO TO 130
+ ENDDO
+ GO TO 140
+ ENDIF
+ 130 IEXTRA = INT(REAL(NGOAL-M22(0))/ALOGM2 + 23.03/ALOGMB) + 1
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M22)
+ GO TO 140
+ ENDIF
+ CALL FMEQ2_R1(M28,NDSAVE,NDIG)
+ CALL FMEQ(M28,M_GAMMA_MB)
+ NUMTRY = NUMTRY + 1
+ CALL FMEQ2(M22,MRETRY,NDOLD,NDIG)
+ GO TO 110
+ ENDIF
+
+ 140 MACMAX = NINT(NDSAVE*ALOGM2)
+ M22(0) = MIN(M22(0),MACCA,MACMAX)
+
+ CALL FMEQ(M28,M_GAMMA_MA)
+ CALL FMEQ(M22,M_GAMMA_MB)
+ NDGGAM = NDIG
+ IF (ABS(M_GAMMA_MB(1)) > MEXPOV) NDGGAM = 0
+ MBSGAM = MBASE
+
+ CALL FMEXT2(M22,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMGAM
+
+ SUBROUTINE FMIBTA(MX,MA,MB,MC)
+
+! MC = Incomplete Beta(MX,MA,MB)
+
+! Integral from 0 to MX of t**(MA-1) * (1-t)**(MB-1) dt.
+
+! 0 <= MX <= 1, 0 < MA, 0 <= MB.
+
+! Some comments below refer to this function and its arguments as B(x,a,b).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MX(-1:LUNPCK),MA(-1:LUNPCK),MB(-1:LUNPCK), &
+ MC(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MACCX,MACMAX,MLA,MXSAVE
+ INTEGER IEXTRA,J,J4,JCHECK,JEXTRA,K,KASAVE,KASHIFT,KBIGAB,KBSHIFT, &
+ KICK,KOVUN,KPTMJ1,KPTMJ2,KPTMJ3,KPTMJ4,KPTMJ5,KPTMJ6,KPTMJ7, &
+ KRESLT,KRS,K_RETURN_CODE,NCSAVE,NDGOAL,NDIG2,NDOLD,NDS,NDSAV1, &
+ NDSAVE,NGOAL,NMETHD,NTERMS,NUMTRY,NWDS1,NWDSAV,NWDSCH
+ LOGICAL FMCOMP
+
+ NCSAVE = NCALL
+ CALL FMENT2('FMIBTA',MX,MA,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ NCALL = NCSAVE + 1
+ KRS = KRESLT
+ IF (MB(1) == MEXPOV .OR. MB(1) == MEXPUN) KOVUN = 1
+ IF (ABS(NTRACE) >= 2 .AND. NCALL <= LVLTRC) THEN
+ NDS = NDIG
+ NDIG = NDSAVE
+ IF (NTRACE < 0) THEN
+ CALL FMNTRJ(MB,NDIG)
+ ELSE
+ CALL FMPRNT(MB)
+ ENDIF
+ NDIG = NDS
+ ENDIF
+ KRESLT = KRS
+ IF (MB(1) == MUNKNO) THEN
+ KRESLT = 12
+ KFLAG = -4
+ ENDIF
+ IF (KRESLT /= 0) THEN
+ NDIG = NDSAVE
+ CALL FMRSLT(MA,MB,MC,KRESLT)
+ IF (NTRACE /= 0) CALL FMNTR(1,MC,MC,1,1)
+ MXEXP = MXSAVE
+ KACCSW = KASAVE
+ NCALL = NCALL - 1
+ RETURN
+ ENDIF
+
+! Use more digits for smaller bases.
+
+ J = 1.06*NDSAVE + 51.0/ALOGM2 + 1.0
+ NDIG = MAX(NDIG,J)
+ NDIG = MIN(NDIG,NDG2MX-16)
+ KACCSW = 1
+ MACCX = MX(0)
+ MACCA = MA(0)
+ MACCB = MB(0)
+ CALL FMEQ2(MX,M36,NDSAVE,NDIG)
+ M36(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ2(MA,M37,NDSAVE,NDIG)
+ M37(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ2(MB,M38,NDSAVE,NDIG)
+ M38(0) = NINT(NDIG*ALOGM2)
+
+! Handle cases where at least one of X, A, B is underflow or
+! overflow. Increasing any underflowed values to 1/HUGE makes
+! the calculations more stable. If A is underflow and the final
+! result is overflow, it is safe to return overflow. If X is
+! underflow and the final result is underflow, it is safe to
+! return underflow. If B is underflow, it is replaced by zero.
+! Similarly, decreasing any overflowed A or B values to HUGE
+! and then getting a final result of underflow means it is safe
+! to return underflow.
+! Any cases where the inequalities conflict, such as
+! A = underflow, B = overflow, will return unknown.
+
+ KBIGAB = 0
+ IF (MA(1) == MEXPOV) THEN
+ CALL FMBIG(M37)
+ M37(1) = MXSAVE + 1
+ KBIGAB = -1
+ ENDIF
+ IF (MB(1) == MEXPOV) THEN
+ CALL FMBIG(M38)
+ M38(1) = MXSAVE + 1
+ KBIGAB = -1
+ ENDIF
+ IF (MX(1) == MEXPUN) THEN
+ CALL FMBIG(M36)
+ M36(1) = MXSAVE + 1
+ CALL FMI2M(1,M16)
+ CALL FMDIV_R2(M16,M36)
+ KBIGAB = -1
+ ENDIF
+ IF (MA(1) == MEXPUN) THEN
+ CALL FMBIG(M37)
+ M37(1) = MXSAVE + 1
+ CALL FMI2M(1,M16)
+ CALL FMDIV_R2(M16,M37)
+ IF (KBIGAB < 0) THEN
+ KBIGAB = -9
+ CALL FMI2M(0,M25)
+ GO TO 200
+ ELSE
+ KBIGAB = 1
+ ENDIF
+ ENDIF
+ IF (MB(1) == MEXPUN) THEN
+ CALL FMI2M(1,M16)
+ IF (FMCOMP(M36,'/=',M16)) THEN
+ CALL FMI2M(0,M38)
+ ENDIF
+ ENDIF
+ NWDSAV = NDIG
+ NUMTRY = 0
+ NDGOAL = 0
+ NWDS1 = 0
+ KASHIFT = 0
+ KBSHIFT = 0
+
+! Check for special cases.
+
+ 110 KICK = 0
+ CALL FMIBTA2(K_RETURN_CODE,MXSAVE,NTERMS,NUMTRY,NMETHD)
+ IF (K_RETURN_CODE == 1) GO TO 180
+ IF (K_RETURN_CODE == 2) GO TO 200
+
+! Determine which method to use.
+
+! NMETHD = 1 means use the convergent series for B(x,a,b),
+! = 2 means use continued fraction expansion 1
+! for B(x,a,b),
+! = 3 means use the convergent series
+! for B(1-x,b,a).
+! = 4 means use continued fraction expansion 1
+! for B(1-x,b,a).
+! = 5 means use continued fraction expansion 2
+! for B(x,a,b).
+! = 6 means use continued fraction expansion 2
+! for B(1-x,b,a).
+
+ CALL FMSQR(M37,M16)
+ CALL FMDPM(DBLE(.00173),M06)
+ CALL FMMPY(M06,M16,M05)
+ CALL FMSQR(M38,M16)
+ CALL FMDPM(DBLE(.01253),M06)
+ CALL FMMPY(M06,M16,M04)
+ CALL FMADD_R1(M05,M04)
+ CALL FMDPM(DBLE(.21583),M06)
+ CALL FMMPY(M06,M37,M04)
+ CALL FMADD_R1(M05,M04)
+ CALL FMDPM(DBLE(.03891),M06)
+ CALL FMMPY(M06,M38,M04)
+ CALL FMADD_R1(M05,M04)
+ CALL FMDPM(DBLE(9.14350),M04)
+ CALL FMADD_R1(M05,M04)
+
+ CALL FMDPM(DBLE(.11709),M06)
+ CALL FMMPY(M06,M37,M04)
+ CALL FMDPM(DBLE(.62633),M06)
+ CALL FMMPY(M06,M38,M03)
+ CALL FMADD_R1(M04,M03)
+ CALL FMADDI(M04,1)
+
+ CALL FMDIV(M04,M05,M40)
+
+ CALL FMDPM(DBLE(.29217),M06)
+ CALL FMMPY(M06,M37,M05)
+ CALL FMDPM(DBLE(2.09304),M06)
+ CALL FMMPY(M06,M38,M04)
+ CALL FMADD_R1(M05,M04)
+ CALL FMDPM(DBLE(1.53724),M04)
+ CALL FMADD_R1(M05,M04)
+
+ CALL FMDPM(DBLE(.29217),M06)
+ CALL FMMPY(M06,M37,M04)
+ CALL FMDPM(DBLE(2.09304),M06)
+ CALL FMMPY(M06,M38,M03)
+ CALL FMADD_R1(M04,M03)
+ CALL FMADDI(M04,1)
+
+ CALL FMDIV(M04,M05,M41)
+
+ CALL FMSQR(M37,M16)
+ CALL FMDPM(DBLE(.04038),M06)
+ CALL FMMPY(M06,M16,M05)
+ CALL FMSQR(M38,M16)
+ CALL FMDPM(DBLE(.05754),M06)
+ CALL FMMPY(M06,M16,M04)
+ CALL FMADD_R1(M05,M04)
+ CALL FMDPM(DBLE(.02670),M06)
+ CALL FMMPY(M06,M37,M04)
+ CALL FMADD_R1(M05,M04)
+ CALL FMDPM(DBLE(.56206),M06)
+ CALL FMMPY(M06,M38,M04)
+ CALL FMADD_R1(M05,M04)
+ CALL FMDPM(DBLE(0.13746),M04)
+ CALL FMADD_R1(M05,M04)
+
+ CALL FMDPM(DBLE(.87312),M06)
+ CALL FMMPY(M06,M37,M04)
+ CALL FMDPM(DBLE(.20334),M06)
+ CALL FMMPY(M06,M38,M03)
+ CALL FMADD_R1(M04,M03)
+ CALL FMADDI(M04,1)
+
+ CALL FMDIV(M04,M05,M42)
+
+ CALL FMDPM(DBLE(.64584),M06)
+ CALL FMMPY(M06,M37,M05)
+ CALL FMDPM(DBLE(.64584),M06)
+ CALL FMMPY(M06,M38,M04)
+ CALL FMADD_R1(M05,M04)
+ CALL FMDPM(DBLE(6.31958),M04)
+ CALL FMADD_R1(M05,M04)
+
+ CALL FMDPM(DBLE(.64584),M06)
+ CALL FMMPY(M06,M37,M04)
+ CALL FMADDI(M04,1)
+
+ CALL FMDIV(M04,M05,M43)
+
+ CALL FMSQR(M37,M16)
+ CALL FMDPM(DBLE(.11637),M06)
+ CALL FMMPY(M06,M16,M05)
+ CALL FMSQR(M38,M16)
+ CALL FMDPM(DBLE(.10718),M06)
+ CALL FMMPY(M06,M16,M04)
+ CALL FMADD_R1(M05,M04)
+ CALL FMDPM(DBLE(.92626),M06)
+ CALL FMMPY(M06,M37,M04)
+ CALL FMADD_R1(M05,M04)
+ CALL FMDPM(DBLE(.05518),M06)
+ CALL FMMPY(M06,M38,M04)
+ CALL FMADD_R1(M05,M04)
+ CALL FMDPM(DBLE(0.28962),M04)
+ CALL FMADD_R1(M05,M04)
+
+ CALL FMDPM(DBLE(.99773),M06)
+ CALL FMMPY(M06,M37,M04)
+ CALL FMDPM(DBLE(.56855),M06)
+ CALL FMMPY(M06,M38,M03)
+ CALL FMADD_R1(M04,M03)
+ CALL FMADDI(M04,1)
+
+ CALL FMDIV(M04,M05,M44)
+
+ IF (FMCOMP(M36,'<=',M40)) THEN
+ NMETHD = 1
+ ELSE IF (FMCOMP(M36,'>=',M41)) THEN
+ NMETHD = 3
+ ELSE IF (FMCOMP(M36,'<',M44)) THEN
+ IF (FMCOMP(M36,'<',M42)) THEN
+ NMETHD = 2
+ ELSE
+ NMETHD = 4
+ ENDIF
+ ELSE
+ IF (FMCOMP(M36,'<',M43)) THEN
+ NMETHD = 5
+ ELSE
+ NMETHD = 6
+ ENDIF
+ ENDIF
+ IF (M38(1) <= 0 .AND. M37(1)+NDIG < 0) THEN
+ NMETHD = 1
+ ENDIF
+ IF (NMETHD == 2) GO TO 130
+ IF (NMETHD == 5) GO TO 150
+ IF (NMETHD == 3 .OR. NMETHD == 4 .OR. NMETHD == 6) GO TO 160
+
+! Method 1. Use the Pochhammer(1-B,N)*X**N/((A+N)*N!)
+! series.
+
+! M19 and M25 hold the positive and negative parts
+! of the current sum.
+! M21 is the current term.
+! M22 is J-B.
+! M23 is 1.
+! M24 is A+J.
+
+ 120 JEXTRA = INT(0.06*NDIG)
+ IF (NDIG+JEXTRA > NDG2MX-6) JEXTRA = NDG2MX - 6 - NDIG
+ IF (NDIG+JEXTRA > NDIG) THEN
+ CALL FMEQ2_R1(M36,NDIG,NDIG+JEXTRA)
+ CALL FMEQ2_R1(M37,NDIG,NDIG+JEXTRA)
+ CALL FMEQ2_R1(M38,NDIG,NDIG+JEXTRA)
+ ENDIF
+ NDIG = NDIG + JEXTRA
+ CALL FMI2M(1,M21)
+ CALL FMDIV(M21,M37,M19)
+ CALL FMI2M(0,M25)
+ CALL FMEQ(M38,M22)
+ IF (M22(1) /= MUNKNO .AND. M22(2) /= 0) M22(-1) = -M22(-1)
+ CALL FMEQ(M37,M24)
+ CALL FMI2M(1,M23)
+ CALL FMI2M(0,M20)
+ CALL FMI2M(0,M26)
+ JCHECK = 5
+ NDSAV1 = NDIG
+
+! Method 1 summation loop.
+
+ METHOD1: DO J = 1, NTERMS
+ NDIG = NDSAV1
+ CALL FMADD_R1(M22,M23)
+ IF (M22(2) == 0) M22(0) = M23(0)
+ NDIG2 = MIN(NDSAV1,MAX(2,NDSAV1-INT(M19(1)-M21(1)), &
+ NDSAV1-INT(M25(1)-M21(1))))
+ NDIG = NDIG2
+ CALL FMMPY_R1(M21,M22)
+ CALL FMMPY_R1(M21,M36)
+ IF (J > 1) CALL FMDIVI_R1(M21,J)
+ NDIG = NDSAV1
+ CALL FMADD_R1(M24,M23)
+ NDIG = NDIG2
+ CALL FMDIV(M21,M24,M20)
+
+ NDIG = NDSAV1
+ IF (INT(M20(-1)) < 0) THEN
+ CALL FMADD_R2(M20,M25)
+ ELSE
+ CALL FMADD_R2(M20,M19)
+ ENDIF
+
+ IF (KFLAG < 0) EXIT
+ IF (MOD(J,JCHECK) == 0) THEN
+ CALL FMADD(M19,M25,M20)
+ DO K = NDIG+1, 1, -1
+ IF (M20(K) /= M26(K)) THEN
+ CALL FMEQ(M20,M26)
+ CYCLE METHOD1
+ ENDIF
+ ENDDO
+ EXIT
+ ENDIF
+ ENDDO METHOD1
+
+ CALL FMPWR(M36,M37,M16)
+ CALL FMADD(M19,M25,M06)
+ CALL FMMPY(M06,M16,M25)
+
+ IF (NMETHD == 1) THEN
+ GO TO 180
+ ELSE
+ GO TO 170
+ ENDIF
+
+! Method 2. Continued fraction expansion for B(x,a,b).
+
+! M26 is the current approximation.
+! M25 is the previous approximation.
+! M21, M22 are the latest numerators (positive part).
+! M41, M42 are the latest numerators (negative part).
+! M23, M24 are the latest denominators (positive part).
+! M43, M44 are the latest denominators (negative part).
+
+ 130 JEXTRA = INT(MAX(1.0,5.76/ALOGMB + 1.0)) + NGRD52 + INT(0.152*NDIG)
+ IF (NDIG+JEXTRA > NDG2MX-6) JEXTRA = NDG2MX - 6 - NDIG
+ IF (NDIG+JEXTRA > NDIG) THEN
+ CALL FMEQ2_R1(M36,NDIG,NDIG+JEXTRA)
+ CALL FMEQ2_R1(M37,NDIG,NDIG+JEXTRA)
+ CALL FMEQ2_R1(M38,NDIG,NDIG+JEXTRA)
+ ENDIF
+ NDIG = NDIG + JEXTRA
+ CALL FMI2M(0,M21)
+ CALL FMI2M(1,M22)
+ CALL FMI2M(1,M23)
+ CALL FMI2M(1,M24)
+ CALL FMI2M(0,M41)
+ CALL FMI2M(0,M42)
+ CALL FMI2M(0,M43)
+ CALL FMI2M(0,M44)
+ CALL FMI2M(0,M25)
+ CALL FMI2M(0,M26)
+ CALL FMADD(M37,M24,M16)
+ CALL FMMPYI(M16,2,M27)
+ CALL FMSUB(M27,M24,M16)
+ CALL FMADD(M16,M38,M06)
+ CALL FMMPY(M06,M36,M28)
+ CALL FMMPY(M38,M36,M16)
+ CALL FMMPYI(M36,3,M06)
+ CALL FMSUB(M16,M06,M32)
+ CALL FMADD(M37,M38,M16)
+ CALL FMMPY(M16,M37,M06)
+ CALL FMMPY(M06,M36,M33)
+ CALL FMMPYI(M36,2,M16)
+ CALL FMADD(M32,M16,M34)
+ CALL FMSQR(M37,M16)
+ CALL FMADD(M16,M37,M35)
+
+ JCHECK = 5
+
+! Method 2 continued fraction loop.
+
+ DO J = 0, NTERMS
+ CALL FMDIV(M33,M35,M19)
+ IF (M19(1) /= MUNKNO .AND. M19(2) /= 0) M19(-1) = -M19(-1)
+ IF (M19(-1)*M19(2) >= 0) THEN
+ CALL FMMPY(M19,M21,M16)
+ CALL FMADD(M16,M22,M21)
+ CALL FMMPY(M19,M41,M16)
+ CALL FMADD(M16,M42,M41)
+ CALL FMMPY(M19,M23,M16)
+ CALL FMADD(M16,M24,M23)
+ CALL FMMPY(M19,M43,M16)
+ CALL FMADD(M16,M44,M43)
+ ELSE
+ CALL FMEQ(M21,M40)
+ CALL FMMPY(M19,M41,M21)
+ CALL FMADD_R1(M21,M22)
+ CALL FMMPY(M19,M40,M41)
+ CALL FMADD_R1(M41,M42)
+ CALL FMEQ(M23,M40)
+ CALL FMMPY(M19,M43,M23)
+ CALL FMADD_R1(M23,M24)
+ CALL FMMPY(M19,M40,M43)
+ CALL FMADD_R1(M43,M44)
+ ENDIF
+ CALL FMADD_R1(M35,M27)
+ J4 = J*4
+ CALL FMADDI(M35,J4)
+ CALL FMDIV(M34,M35,M20)
+ IF (M20(-1) >= 0) THEN
+ CALL FMMPY(M20,M22,M16)
+ CALL FMADD(M16,M21,M22)
+ CALL FMMPY(M20,M42,M16)
+ CALL FMADD(M16,M41,M42)
+ CALL FMMPY(M20,M24,M16)
+ CALL FMADD(M16,M23,M24)
+ CALL FMMPY(M20,M44,M16)
+ CALL FMADD(M16,M43,M44)
+ ELSE
+ CALL FMEQ(M22,M40)
+ CALL FMMPY(M20,M42,M22)
+ CALL FMADD_R1(M22,M21)
+ CALL FMMPY(M20,M40,M42)
+ CALL FMADD_R1(M42,M41)
+ CALL FMEQ(M24,M40)
+ CALL FMMPY(M20,M44,M24)
+ CALL FMADD_R1(M24,M23)
+ CALL FMMPY(M20,M40,M44)
+ CALL FMADD_R1(M44,M43)
+ ENDIF
+
+! Form the quotient and check for convergence.
+
+ IF (MOD(J,JCHECK) == 0) THEN
+ CALL FMEQ(M26,M25)
+ CALL FMADD(M22,M42,M16)
+ CALL FMADD(M24,M44,M06)
+ CALL FMDIV(M16,M06,M26)
+ IF (KFLAG == -4) THEN
+ M25(0) = -2
+ GO TO 180
+ ENDIF
+ NGOAL = 1.06*(INT(REAL(NDSAVE)*ALOGM2) + 29)
+ IF (M26(0) < NGOAL) THEN
+ KICK = -2
+ EXIT
+ ENDIF
+
+ CALL FMSUB(M26,M25,M16)
+ CALL FMABS(M16,M40)
+ IF (J >= 1000*(NUMTRY+1)) THEN
+ IF (FMCOMP(M40,'>',M45)) THEN
+ KICK = -2
+ EXIT
+ ENDIF
+ ENDIF
+ CALL FMEQ(M40,M45)
+ NWDSCH = NWDSAV + 1
+ IF (NUMTRY == 1 .AND. (KASHIFT > 0 .OR. KBSHIFT > 0)) THEN
+ NWDSCH = NDIG - JEXTRA
+ ELSE IF (NUMTRY > 0 .AND. NDGOAL > 0) THEN
+ NWDSCH = NDGOAL + NWDS1 + NGRD22
+ ELSE IF (NUMTRY > 0 .AND. NDGOAL <= 0) THEN
+ NWDSCH = INT(REAL(INT(REAL(NDSAVE)*ALOGM2)+17)/ALOGM2 &
+ + 1.0) + NWDS1 + NGRD22
+ ENDIF
+ DO K = NWDSCH, 1, -1
+ IF (M25(K) /= M26(K)) GO TO 140
+ ENDDO
+ EXIT
+ ENDIF
+
+ 140 CALL FMADD_R1(M35,M27)
+ K = 4*J + 2
+ CALL FMADDI(M35,K)
+ K = 2*J
+ CALL FMMPYI(M36,K,M18)
+ CALL FMADD_R1(M33,M28)
+ CALL FMADD_R1(M33,M18)
+ CALL FMADD_R1(M34,M32)
+ CALL FMSUB_R1(M34,M18)
+ ENDDO
+
+ CALL FMLN(M36,M23)
+ CALL FMMPY_R1(M23,M37)
+ IF (M36(1)*(-10) >= NDIG) THEN
+ CALL FMEQ(M36,M19)
+ CALL FMEQ(M36,M24)
+ DO K = 2, NTERMS
+ CALL FMMPY_R1(M19,M36)
+ CALL FMDIVI(M19,K,M16)
+ CALL FMADD_R1(M24,M16)
+ IF (KFLAG /= 0) EXIT
+ ENDDO
+ CALL FMMPY(M24,M38,M16)
+ IF (M16(1) /= MUNKNO .AND. M16(2) /= 0) M16(-1) = -M16(-1)
+ ELSE
+ CALL FMI2M(1,M16)
+ CALL FMSUB_R1(M16,M36)
+ CALL FMLN(M16,M24)
+ CALL FMMPY_R1(M24,M38)
+ ENDIF
+ CALL FMADD(M23,M24,M16)
+ CALL FMEXP(M16,M25)
+ CALL FMMPY_R2(M26,M25)
+ IF (M25(1) == MUNKNO) THEN
+ IF (M26(-1)*M26(2) > 0) THEN
+ CALL FMLN(M26,M16)
+ CALL FMADD(M16,M23,M06)
+ CALL FMADD(M06,M24,M16)
+ CALL FMEXP(M16,M25)
+ ELSE
+ CALL FMEQ(M26,M17)
+ IF (M17(1) /= MUNKNO .AND. M17(2) /= 0) M17(-1) = -M17(-1)
+ CALL FMLN(M17,M16)
+ CALL FMADD(M16,M23,M06)
+ CALL FMADD(M06,M24,M16)
+ CALL FMEXP(M16,M25)
+ IF (M25(1) /= MUNKNO .AND. M25(2) /= 0) M25(-1) = -M25(-1)
+ ENDIF
+ ENDIF
+ IF (ABS(M25(1)) < MEXPOV) CALL FMDIV_R1(M25,M37)
+ IF (NMETHD == 2) THEN
+ GO TO 180
+ ELSE
+ GO TO 170
+ ENDIF
+
+! Method 5. Continued fraction expansion 2 for B(x,a,b).
+
+! M26 is the current approximation.
+! M25 is the previous approximation.
+! M21, M22 are the latest numerators (positive part).
+! M41, M42 are the latest numerators (negative part).
+! M23, M24 are the latest denominators (positive part).
+! M43, M44 are the latest denominators (negative part).
+
+ 150 JEXTRA = INT(MAX(1.0,5.76/ALOGMB + 1.0)) + INT(0.07*NDIG)
+ IF (NDIG+JEXTRA > NDG2MX-6) JEXTRA = NDG2MX - 6 - NDIG
+ IF (NDIG+JEXTRA > NDIG) THEN
+ CALL FMEQ2_R1(M36,NDIG,NDIG+JEXTRA)
+ CALL FMEQ2_R1(M37,NDIG,NDIG+JEXTRA)
+ CALL FMEQ2_R1(M38,NDIG,NDIG+JEXTRA)
+ ENDIF
+ NDIG = NDIG + JEXTRA
+ KPTMJ1 = 0
+ KPTMJ2 = (LUNPCK+3)
+ KPTMJ3 = 2*(LUNPCK+3)
+ KPTMJ4 = 3*(LUNPCK+3)
+ KPTMJ5 = 4*(LUNPCK+3)
+ KPTMJ6 = 5*(LUNPCK+3)
+ KPTMJ7 = 6*(LUNPCK+3)
+
+ CALL FMI2M(0,M21)
+ CALL FMI2M(1,M22)
+ CALL FMI2M(1,M23)
+ CALL FMI2M(0,M25)
+ CALL FMI2M(0,M26)
+
+ CALL FMSUB(M37,M22,M30)
+ CALL FMSUB(M30,M22,MJSUMS(KPTMJ5-1))
+ CALL FMSQR(M36,MJSUMS(KPTMJ4-1))
+
+ IF (NMETHD == 6) THEN
+ CALL FMADD(M37,M38,M16)
+ CALL FMMPY(M16,M36,M06)
+ CALL FMSUB(M37,M06,M29)
+ CALL FMEQ2(MX,M28,NDSAVE,NDIG)
+ CALL FMADD(M37,M38,M16)
+ CALL FMMPY(M16,M28,M06)
+ CALL FMSUB(M06,M38,M31)
+ IF (M29(0) > M31(0)) CALL FMEQ(M29,M31)
+ ELSE
+ CALL FMADD(M37,M38,M16)
+ CALL FMMPY(M16,M36,M06)
+ CALL FMSUB(M37,M06,M31)
+ ENDIF
+ IF (M31(0) == 0 .AND. M31(2) == 0) THEN
+ M31(0) = M22(0)
+ ENDIF
+
+ CALL FMI2M(0,M28)
+ CALL FMMPY(M30,M30,M29)
+
+ CALL FMMPY(MJSUMS(KPTMJ4-1),MJSUMS(KPTMJ5-1),M18)
+ CALL FMADD(MJSUMS(KPTMJ5-1),M38,M19)
+ CALL FMMPY_R1(M18,M19)
+ CALL FMADD(M38,M22,M19)
+ CALL FMMPY(M18,M19,MJSUMS(KPTMJ1-1))
+
+ CALL FMSUB(MJSUMS(KPTMJ5-1),M22,M18)
+ CALL FMMPY_R2(MJSUMS(KPTMJ5-1),M18)
+ CALL FMADD(M30,M38,M16)
+ CALL FMMPY(M16,M38,M19)
+ CALL FMSUB(M19,M18,M16)
+ CALL FMMPYI(M16,2,M18)
+ CALL FMMPY(M18,MJSUMS(KPTMJ4-1),MJSUMS(KPTMJ2-1))
+
+ CALL FMMPY(MJSUMS(KPTMJ4-1),MJSUMS(KPTMJ5-1),M18)
+ CALL FMMPYI(M18,-6,MJSUMS(KPTMJ3-1))
+
+ CALL FMMPYI_R1(MJSUMS(KPTMJ4-1),-4)
+
+ CALL FMMPYI(MJSUMS(KPTMJ5-1),4,M27)
+
+ CALL FMI2M(4,M16)
+ CALL FMADD(M38,M16,M06)
+ CALL FMSUB(M06,M37,M16)
+ CALL FMMPY(M16,M36,M18)
+ CALL FMADD(MJSUMS(KPTMJ5-1),M31,M19)
+ CALL FMMPYI(M19,3,M16)
+ CALL FMADD(M18,M16,M19)
+ CALL FMMPY(M19,M30,MJSUMS(KPTMJ5-1))
+
+ CALL FMMPYI(M37,-2,M16)
+ CALL FMADD(M16,M38,M06)
+ CALL FMADDI(M06,3)
+ CALL FMMPY(M06,M36,M18)
+ CALL FMMPYI(M37,5,M19)
+
+ CALL FMADD(M18,M19,M16)
+ CALL FMADD(M16,M31,M06)
+ CALL FMI2M(6,M16)
+ CALL FMSUB(M06,M16,M18)
+ CALL FMMPYI(M18,4,MJSUMS(KPTMJ6-1))
+
+ CALL FMI2M(2,M16)
+ CALL FMSUB(M36,M16,M18)
+ CALL FMMPYI(M18,-12,MJSUMS(KPTMJ7-1))
+
+ CALL FMADD(M22,M31,M16)
+ CALL FMMPY(M16,M37,M06)
+ CALL FMMPY(M06,M30,M31)
+
+ CALL FMADD(M22,M37,M16)
+ CALL FMMPY(M16,M30,M32)
+
+ CALL FMMPYI_R1(M30,4)
+ CALL FMDIV(M31,M32,M24)
+ CALL FMI2M(0,M41)
+ CALL FMI2M(0,M42)
+ CALL FMI2M(0,M43)
+ CALL FMI2M(0,M44)
+ IF (M24(-1) < 0) THEN
+ CALL FMEQ(M24,M44)
+ CALL FMI2M(0,M24)
+ ENDIF
+ JCHECK = 5
+
+! Method 5 continued fraction loop.
+
+ METHOD5: DO J = 1, NTERMS
+ CALL FMMPYI(MJSUMS(KPTMJ4-1),J,M18)
+ CALL FMADD_R1(M18,MJSUMS(KPTMJ3-1))
+ CALL FMMPYI_R1(M18,J)
+ CALL FMADD_R1(M18,MJSUMS(KPTMJ2-1))
+ CALL FMMPYI_R1(M18,J)
+ CALL FMADD_R1(M18,MJSUMS(KPTMJ1-1))
+
+ CALL FMADDI(M27,8)
+ CALL FMADD_R1(M28,M18)
+ CALL FMADD_R1(M29,M27)
+ CALL FMDIV(M28,M29,M18)
+
+ CALL FMMPYI(MJSUMS(KPTMJ7-1),J,M19)
+ CALL FMADD_R1(M19,MJSUMS(KPTMJ6-1))
+ CALL FMMPYI_R1(M19,J)
+ CALL FMADD_R1(M19,MJSUMS(KPTMJ5-1))
+
+ CALL FMADDI(M30,8)
+
+ CALL FMADD_R1(M31,M19)
+ CALL FMADD_R1(M32,M30)
+ CALL FMDIV(M31,M32,M19)
+
+ IF (M18(-1) >= 0 .AND. M19(-1) >= 0) THEN
+ CALL FMMPY(M18,M21,M20)
+ CALL FMMPY(M19,M22,M21)
+ CALL FMADD_R1(M20,M21)
+ CALL FMMPY(M18,M41,M40)
+ CALL FMMPY(M19,M42,M41)
+ CALL FMADD_R1(M40,M41)
+ CALL FMEQ(M22,M21)
+ CALL FMEQ(M20,M22)
+ CALL FMEQ(M42,M41)
+ CALL FMEQ(M40,M42)
+ CALL FMMPY(M18,M23,M20)
+ CALL FMMPY(M19,M24,M23)
+ CALL FMADD_R1(M20,M23)
+ CALL FMMPY(M18,M43,M40)
+ CALL FMMPY(M19,M44,M43)
+ CALL FMADD_R1(M40,M43)
+ CALL FMEQ(M24,M23)
+ CALL FMEQ(M20,M24)
+ CALL FMEQ(M44,M43)
+ CALL FMEQ(M40,M44)
+ ELSE IF (M18(-1) >= 0 .AND. M19(-1) < 0) THEN
+ CALL FMMPY(M18,M21,M16)
+ CALL FMMPY(M19,M42,M06)
+ CALL FMADD(M16,M06,M20)
+ CALL FMMPY(M18,M41,M16)
+ CALL FMMPY(M19,M22,M06)
+ CALL FMADD(M16,M06,M40)
+ CALL FMEQ(M22,M21)
+ CALL FMEQ(M20,M22)
+ CALL FMEQ(M42,M41)
+ CALL FMEQ(M40,M42)
+ CALL FMMPY(M18,M23,M16)
+ CALL FMMPY(M19,M44,M06)
+ CALL FMADD(M16,M06,M20)
+ CALL FMMPY(M18,M43,M16)
+ CALL FMMPY(M19,M24,M06)
+ CALL FMADD(M16,M06,M40)
+ CALL FMEQ(M24,M23)
+ CALL FMEQ(M20,M24)
+ CALL FMEQ(M44,M43)
+ CALL FMEQ(M40,M44)
+ ELSE IF (M18(-1) < 0 .AND. M19(-1) >= 0) THEN
+ CALL FMMPY(M18,M41,M20)
+ CALL FMMPY(M19,M22,M41)
+ CALL FMADD_R1(M20,M41)
+ CALL FMMPY(M18,M21,M40)
+ CALL FMMPY(M19,M42,M41)
+ CALL FMADD_R1(M40,M41)
+ CALL FMEQ(M22,M21)
+ CALL FMEQ(M20,M22)
+ CALL FMEQ(M42,M41)
+ CALL FMEQ(M40,M42)
+ CALL FMMPY(M18,M43,M20)
+ CALL FMMPY(M19,M24,M43)
+ CALL FMADD_R1(M20,M43)
+ CALL FMMPY(M18,M23,M40)
+ CALL FMMPY(M19,M44,M43)
+ CALL FMADD_R1(M40,M43)
+ CALL FMEQ(M24,M23)
+ CALL FMEQ(M20,M24)
+ CALL FMEQ(M44,M43)
+ CALL FMEQ(M40,M44)
+ ELSE
+ CALL FMMPY(M18,M41,M16)
+ CALL FMMPY(M19,M42,M06)
+ CALL FMADD(M16,M06,M20)
+ CALL FMMPY(M18,M21,M16)
+ CALL FMMPY(M19,M22,M06)
+ CALL FMADD(M16,M06,M40)
+ CALL FMEQ(M22,M21)
+ CALL FMEQ(M20,M22)
+ CALL FMEQ(M42,M41)
+ CALL FMEQ(M40,M42)
+ CALL FMMPY(M18,M43,M16)
+ CALL FMMPY(M19,M44,M06)
+ CALL FMADD(M16,M06,M20)
+ CALL FMMPY(M18,M23,M16)
+ CALL FMMPY(M19,M24,M06)
+ CALL FMADD(M16,M06,M40)
+ CALL FMEQ(M24,M23)
+ CALL FMEQ(M20,M24)
+ CALL FMEQ(M44,M43)
+ CALL FMEQ(M40,M44)
+ ENDIF
+
+! Form the quotient and check for convergence.
+
+ IF (MOD(J,JCHECK) == 0) THEN
+ CALL FMEQ(M26,M25)
+ CALL FMADD(M22,M42,M16)
+ CALL FMADD(M24,M44,M06)
+ CALL FMDIV(M16,M06,M26)
+ IF (KFLAG == -4) THEN
+ M25(0) = -2
+ GO TO 180
+ ENDIF
+ NGOAL = 1.06*(INT(REAL(NDSAVE)*ALOGM2) + 29)
+ IF (M26(0) < NGOAL) THEN
+ KICK = -2
+ EXIT
+ ENDIF
+
+ CALL FMSUB(M26,M25,M16)
+ CALL FMABS(M16,M40)
+ IF (J >= 1000*(NUMTRY+1)) THEN
+ IF (FMCOMP(M40,'>',M45)) THEN
+ KICK = -2
+ EXIT
+ ENDIF
+ ENDIF
+ CALL FMEQ(M40,M45)
+ NWDSCH = NWDSAV + 1
+ IF (NUMTRY >= 1 .AND. (KASHIFT > 0 .OR. KBSHIFT > 0)) THEN
+ NWDSCH = NDIG - JEXTRA
+ ELSE IF (NUMTRY > 0 .AND. NDGOAL > 0) THEN
+ NWDSCH = NDGOAL + NWDS1 + NGRD22
+ ELSE IF (NUMTRY > 0 .AND. NDGOAL <= 0) THEN
+ NWDSCH = INT(REAL(INT(REAL(NDSAVE)*ALOGM2)+17)/ALOGM2 &
+ + 1.0) + NWDS1 + NGRD22
+ ENDIF
+ DO K = NWDSCH, 1, -1
+ IF (M25(K) /= M26(K)) CYCLE METHOD5
+ ENDDO
+ EXIT
+ ENDIF
+
+ ENDDO METHOD5
+
+ CALL FMI2M(1,M16)
+ IF (FMCOMP(M36,'==',M16) .AND. NMETHD == 6) THEN
+ CALL FMEQ2(MX,M23,NDSAVE,NDIG)
+ CALL FMMPY_R1(M23,M37)
+ IF (M23(1) /= MUNKNO .AND. M23(2) /= 0) M23(-1) = -M23(-1)
+ ELSE IF (MX(1) <= -1 .AND. NMETHD == 6) THEN
+ CALL FMEQ2(MX,M23,NDSAVE,NDIG)
+ CALL FMEQ(M23,M19)
+ CALL FMEQ(M23,M24)
+ DO K = 2, NTERMS
+ CALL FMMPY_R1(M19,M23)
+ CALL FMDIVI(M19,K,M16)
+ CALL FMADD_R1(M24,M16)
+ IF (KFLAG /= 0) EXIT
+ ENDDO
+ CALL FMMPY(M24,M37,M23)
+ IF (M23(1) /= MUNKNO .AND. M23(2) /= 0) M23(-1) = -M23(-1)
+ ELSE
+ CALL FMLN(M36,M23)
+ CALL FMMPY_R1(M23,M37)
+ ENDIF
+ IF (NMETHD == 6) THEN
+ CALL FMEQ2(MX,M24,NDSAVE,NDIG)
+ CALL FMLN(M24,M13)
+ CALL FMEQ(M13,M24)
+ CALL FMMPY_R1(M24,M38)
+ ELSE IF (M36(1) <= -1) THEN
+ CALL FMEQ(M36,M19)
+ CALL FMEQ(M36,M24)
+ DO K = 2, NTERMS
+ CALL FMMPY_R1(M19,M36)
+ CALL FMDIVI(M19,K,M16)
+ CALL FMADD_R1(M24,M16)
+ IF (KFLAG /= 0) EXIT
+ ENDDO
+ CALL FMMPY_R1(M24,M38)
+ IF (M24(1) /= MUNKNO .AND. M24(2) /= 0) M24(-1) = -M24(-1)
+ ELSE
+ CALL FMI2M(1,M06)
+ CALL FMSUB(M06,M36,M16)
+ CALL FMLN(M16,M24)
+ CALL FMMPY_R1(M24,M38)
+ ENDIF
+ CALL FMADD(M23,M24,M16)
+ CALL FMEXP(M16,M25)
+ CALL FMMPY_R1(M25,M26)
+ IF (M25(1) == MUNKNO) THEN
+ IF (M26(-1)*M26(2) > 0) THEN
+ CALL FMLN(M26,M16)
+ CALL FMADD(M16,M23,M06)
+ CALL FMADD(M06,M24,M16)
+ CALL FMEXP(M16,M25)
+ ELSE
+ CALL FMEQ(M26,M17)
+ IF (M17(1) /= MUNKNO .AND. M17(2) /= 0) M17(-1) = -M17(-1)
+ CALL FMLN(M17,M16)
+ CALL FMADD(M16,M23,M06)
+ CALL FMADD(M06,M24,M16)
+ CALL FMEXP(M16,M25)
+ IF (M25(1) /= MUNKNO .AND. M25(2) /= 0) M25(-1) = -M25(-1)
+ ENDIF
+ ENDIF
+ IF (NMETHD == 5) THEN
+ GO TO 180
+ ELSE
+ GO TO 170
+ ENDIF
+
+! Method 3, 4, or 6. B(X,A,B) = B(A,B) - B(1-X,B,A).
+
+ 160 MLA = M36(0)
+ CALL FMI2M(1,M16)
+ CALL FMSUB_R2(M16,M36)
+ M36(0) = MLA
+ DO J = -1, NDIG+1
+ MLA = M37(J)
+ M37(J) = M38(J)
+ M38(J) = MLA
+ ENDDO
+ IF (NMETHD == 3) THEN
+ GO TO 120
+ ELSE IF (NMETHD == 4) THEN
+ GO TO 130
+ ELSE
+ GO TO 150
+ ENDIF
+ 170 K = NWDS1
+ CALL FMEQ(M25,M34)
+ CALL FMBETA(M37,M38,M39)
+ NWDS1 = INT(MAX(M39(1),M34(1)))
+ CALL FMSUB(M39,M34,M25)
+ NWDS1 = MAX(0,NWDS1-INT(M25(1)))
+ IF (K /= NWDS1 .AND. NUMTRY >= 1) THEN
+ IF (KASHIFT == 0 .AND. KBSHIFT == 0) M25(0) = -1
+ ENDIF
+
+! Check for too much cancellation.
+
+ 180 K = KFLAG
+ IF (KICK < 0) M25(0) = KICK
+
+! Reverse the translation if KASHIFT is positive.
+! This is used when a is small and a retry was required
+! because of cancellation.
+
+ IF (KASHIFT > 0 .AND. M25(0) > 0) THEN
+ CALL FMEQ2(MX,M26,NDSAVE,NDIG)
+ CALL FMEQ2(MA,M27,NDSAVE,NDIG)
+ CALL FMEQ2(MB,M28,NDSAVE,NDIG)
+ IF (KBSHIFT > 0) CALL FMADDI(M28,KBSHIFT)
+ CALL FMI2M(1,M23)
+ CALL FMADD(M27,M28,M20)
+ CALL FMI2M(1,M16)
+ CALL FMADD(M27,M16,M06)
+ CALL FMDIV(M20,M06,M24)
+ CALL FMI2M(1,M16)
+ CALL FMSUB(M16,M26,M21)
+ CALL FMEQ(M26,M22)
+ CALL FMMPY(M24,M26,M16)
+ CALL FMADD_R1(M23,M16)
+ CALL FMEQ(M20,M18)
+ CALL FMEQ(M27,M19)
+ CALL FMADDI(M19,1)
+ DO J = 2, KASHIFT-1
+ CALL FMADDI(M18,1)
+ CALL FMADDI(M19,1)
+ CALL FMMPY_R1(M24,M18)
+ CALL FMDIV_R1(M24,M19)
+ CALL FMMPY_R1(M22,M26)
+ CALL FMMPY(M24,M22,M17)
+ CALL FMADD_R1(M23,M17)
+ ENDDO
+ IF (M26(1)*(-10) >= NDIG) THEN
+ CALL FMEQ(M26,M19)
+ CALL FMEQ(M26,M21)
+ DO K = 2, NTERMS
+ CALL FMMPY_R1(M19,M26)
+ CALL FMDIVI(M19,K,M16)
+ CALL FMADD_R1(M21,M16)
+ IF (KFLAG /= 0) EXIT
+ ENDDO
+ CALL FMMPY(M21,M28,M16)
+ IF (M16(1) /= MUNKNO .AND. M16(2) /= 0) M16(-1) = -M16(-1)
+ CALL FMEXP(M16,M22)
+ CALL FMEQ(M23,M19)
+ CALL FMPWR(M26,M27,M16)
+ CALL FMMPY(M23,M16,M06)
+ CALL FMMPY(M06,M22,M16)
+ CALL FMDIV(M16,M27,M23)
+ IF (M23(1) == MUNKNO) THEN
+ CALL FMLN(M26,M16)
+ CALL FMMPY(M27,M16,M23)
+ CALL FMLN(M19,M16)
+ CALL FMADD_R2(M16,M23)
+ CALL FMMPY(M21,M28,M16)
+ CALL FMSUB_R1(M23,M16)
+ CALL FMLN(M27,M16)
+ CALL FMSUB_R2(M23,M16)
+ CALL FMEXP(M16,M23)
+ ENDIF
+ ELSE
+ CALL FMPWR(M26,M27,M16)
+ CALL FMMPY_R1(M23,M16)
+ CALL FMPWR(M21,M28,M16)
+ CALL FMMPY_R1(M23,M16)
+ CALL FMDIV_R1(M23,M27)
+ ENDIF
+ CALL FMMPY(M25,M24,M16)
+ CALL FMI2M(KASHIFT-1,M06)
+ CALL FMADD_R2(M20,M06)
+ CALL FMMPY_R1(M16,M06)
+ CALL FMDIV(M16,M27,M24)
+ CALL FMADD(M24,M23,M25)
+ ENDIF
+
+! Reverse the translation if KBSHIFT is positive.
+! This is used when x is close to 1, b is small,
+! and a retry was required because of cancellation.
+
+ IF (KBSHIFT > 0 .AND. M25(0) > 0) THEN
+ CALL FMEQ2(MX,M26,NDSAVE,NDIG)
+ CALL FMEQ2(MA,M27,NDSAVE,NDIG)
+ CALL FMEQ2(MB,M28,NDSAVE,NDIG)
+ CALL FMI2M(1,M23)
+ CALL FMI2M(1,M16)
+ CALL FMADD(M28,M16,M06)
+ CALL FMADD(M27,M28,M16)
+ CALL FMDIV(M16,M06,M24)
+ CALL FMADD(M27,M28,M20)
+ CALL FMI2M(1,M16)
+ CALL FMSUB(M16,M26,M21)
+ CALL FMEQ(M21,M22)
+ CALL FMMPY(M24,M22,M16)
+ CALL FMADD_R1(M23,M16)
+ CALL FMEQ(M20,M18)
+ CALL FMEQ(M28,M19)
+ CALL FMADDI(M19,1)
+ DO J = 2, KBSHIFT-1
+ CALL FMADDI(M18,1)
+ CALL FMADDI(M19,1)
+ CALL FMMPY_R1(M24,M18)
+ CALL FMDIV_R1(M24,M19)
+ CALL FMMPY_R1(M22,M21)
+ CALL FMMPY(M24,M22,M17)
+ CALL FMADD_R1(M23,M17)
+ ENDDO
+ IF (M26(1)*(-10) >= NDIG) THEN
+ CALL FMEQ(M26,M19)
+ CALL FMEQ(M26,M21)
+ DO K = 2, NTERMS
+ CALL FMMPY_R1(M19,M26)
+ CALL FMDIVI(M19,K,M16)
+ CALL FMADD_R1(M21,M16)
+ IF (KFLAG /= 0) EXIT
+ ENDDO
+ CALL FMMPY(M21,M28,M16)
+ IF (M16(1) /= MUNKNO .AND. M16(2) /= 0) M16(-1) = -M16(-1)
+ CALL FMEXP(M16,M21)
+ CALL FMPWR(M26,M27,M16)
+ CALL FMMPY(M23,M16,M06)
+ CALL FMMPY(M06,M21,M16)
+ CALL FMDIV(M16,M28,M23)
+ ELSE
+ CALL FMPWR(M26,M27,M16)
+ CALL FMMPY_R1(M23,M16)
+ CALL FMPWR(M21,M28,M16)
+ CALL FMMPY_R1(M23,M16)
+ CALL FMDIV_R1(M23,M28)
+ ENDIF
+ CALL FMMPY(M25,M24,M16)
+ CALL FMI2M(KBSHIFT-1,M06)
+ CALL FMADD_R2(M20,M06)
+ CALL FMMPY_R1(M16,M06)
+ CALL FMDIV(M16,M28,M24)
+ CALL FMSUB(M24,M23,M25)
+ ENDIF
+ IF (NCALL <= 1) THEN
+ NGOAL = 1.06*(INT(REAL(NDSAVE)*ALOGM2) + 29)
+ ELSE
+ NGOAL = INT(-MXEXP2)
+ ENDIF
+ NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
+ IF (M25(0) <= NGOAL) THEN
+ IF (NUMTRY > 0) THEN
+ IF (M25(2) == 0 .OR. K < 0) GO TO 190
+ DO J = 1, NDGOAL+1
+ IF (MRETRY(J) /= M25(J)) GO TO 190
+ ENDDO
+ CALL FMI2M(1,M19)
+ M25(0) = M19(0)
+ GO TO 200
+ ENDIF
+ 190 IEXTRA = INT(REAL(NGOAL-M25(0))/ALOGM2 + 23.03/ALOGMB) + 1
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (M25(0) < 0) NDIG = NDOLD + 10*2**NUMTRY
+ IF (NDIG > NDG2MX-6 .AND. NDOLD < NDG2MX-6) NDIG = NDG2MX - 6
+ IF (NDIG > NDG2MX-6) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDOLD
+ CALL FMST2M('UNKNOWN',M25)
+ GO TO 200
+ ENDIF
+ CALL FMEQ2_R1(M36,NDSAVE,NDIG)
+ CALL FMEQ2_R1(M37,NDSAVE,NDIG)
+ CALL FMEQ2_R1(M38,NDSAVE,NDIG)
+ IF (NMETHD == 3 .OR. NMETHD == 4 .OR. NMETHD == 6) THEN
+ CALL FMEQ2(MX,M36,NDSAVE,NDIG)
+ DO J = -1, NDIG+1
+ MLA = M37(J)
+ M37(J) = M38(J)
+ M38(J) = MLA
+ ENDDO
+ ENDIF
+
+ IF (KASHIFT > 0) THEN
+ CALL FMEQ2(MA,M37,NDSAVE,NDIG)
+ IF (KASHIFT <= 2000) THEN
+ KASHIFT = 9*KASHIFT
+ ELSE
+ KASHIFT = NDIG
+ ENDIF
+ CALL FMADDI(M37,KASHIFT)
+ ENDIF
+ IF (KBSHIFT > 0) THEN
+ CALL FMEQ2(MB,M38,NDSAVE,NDIG)
+ IF (KBSHIFT <= 2000) THEN
+ KBSHIFT = 9*KBSHIFT
+ ELSE
+ KBSHIFT = NDIG
+ ENDIF
+ CALL FMADDI(M38,KBSHIFT)
+ ENDIF
+
+! Check to see if a retry is about to be done for
+! small a and large b. If so, raise a by 2*NDIG to
+! reduce the potential cancellation error.
+
+ CALL FMI2M(200,M16)
+ IF (NUMTRY == 0 .AND. FMCOMP(M37,'<=',M16) .AND. &
+ FMCOMP(M38,'>=',M37)) THEN
+ KASHIFT = 2*NDIG
+ CALL FMADDI(M37,2*NDIG)
+ ENDIF
+
+! Check to see if a retry is about to be done for
+! a > 100 and b < 2. If so, raise b by 2*NDIG to
+! reduce the potential cancellation error.
+
+ CALL FMI2M(100,M16)
+ CALL FMI2M(2,M06)
+ IF (NUMTRY == 0 .AND. FMCOMP(M37,'>=',M16) .AND. &
+ FMCOMP(M38,'<=',M06)) THEN
+ KBSHIFT = 2*NDIG
+ CALL FMADDI(M38,2*NDIG)
+ ENDIF
+
+ CALL FMI2M(40*NUMTRY,M16)
+ CALL FMI2M(100,M06)
+ IF (NUMTRY > 0 .AND. KASHIFT == 0 .AND. FMCOMP(M37,'<=',M16) &
+ .AND. FMCOMP(M38,'>=',M06)) THEN
+ KASHIFT = 2*NDIG
+ CALL FMADDI(M37,2*NDIG)
+ ENDIF
+
+ CALL FMI2M(40*NUMTRY,M16)
+ CALL FMI2M(100,M06)
+ IF (NUMTRY > 0 .AND. KBSHIFT == 0 .AND. FMCOMP(M37,'>=',M16) &
+ .AND. FMCOMP(M38,'<=',M06)) THEN
+ KBSHIFT = 2*NDIG
+ CALL FMADDI(M38,2*NDIG)
+ ENDIF
+
+ NUMTRY = NUMTRY + 1
+ CALL FMEQ2(M25,MRETRY,NDOLD,NDIG)
+ IF (KASHIFT == 2*NDIG .OR. KBSHIFT == 2*NDIG) THEN
+ NDIG = MAX(NDIG,NDOLD+2)
+ ENDIF
+ GO TO 110
+ ENDIF
+
+ 200 MACMAX = NINT(NDSAVE*ALOGM2)
+ M25(0) = MIN(M25(0),MACCX,MACCA,MACCB,MACMAX)
+ IF (KBIGAB /= 0) THEN
+ IF ((M25(1) >= -MXSAVE .AND. KBIGAB == -1) .OR. &
+ (M25(1) <= MXSAVE+1 .AND. KBIGAB == 1) .OR. &
+ (KBIGAB == -9)) THEN
+ CALL FMST2M('UNKNOWN',M25)
+ KFLAG = -4
+ ENDIF
+ ENDIF
+ CALL FMEXT2(M25,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMIBTA
+
+ SUBROUTINE FMIBTA2(K_RETURN_CODE,MXSAVE,NTERMS,NUMTRY,NMETHD)
+
+! Check for various special cases in Incomplete Beta.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MXSAVE
+ INTEGER IEXTRA,J,J4,JSWITCH,K,KPT,K_RETURN_CODE,N,NDOLD, &
+ NDSAV1,NMETHD,NTERMS,NUMTRY,NUP
+ INTEGER, PARAMETER :: KPRIME(8) = (/ 2, 3, 5, 7, 11, 13, 17, 19 /)
+ LOGICAL FMCOMP
+
+ K_RETURN_CODE = 0
+ CALL FMI2M(0,M39)
+ CALL FMBIG(M45)
+ NDSAV1 = NDIG
+
+! If B is small, use more guard digits.
+
+ CALL FMDPM(1.0D-10,M16)
+ IF (FMCOMP(M38,'<=',M16)) THEN
+ IEXTRA = NGRD52
+ IF (NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M36,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M37,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M38,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NUMTRY > 0 .AND. NDIG > NDG2MX-6) NDIG = NDG2MX - 6
+ IF (NDIG > NDG2MX-6) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDOLD
+ CALL FMST2M('UNKNOWN',M25)
+ K_RETURN_CODE = 2
+ RETURN
+ ENDIF
+ ENDIF
+
+ NTERMS = INT(INTMAX/10)
+ NMETHD = 0
+
+! Check for special cases.
+
+ IF (M36(2) == 0) THEN
+ CALL FMI2M(0,M25)
+ K_RETURN_CODE = 1
+ RETURN
+ ENDIF
+ CALL FMI2M(1,M32)
+ IF (FMCOMP(M32,'==',M36)) THEN
+ IEXTRA = MIN(NDIG+NGRD52,NDG2MX) - NDIG
+ CALL FMEQ2_R1(M36,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M37,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M38,NDIG,NDIG+IEXTRA)
+ NDIG = NDIG + IEXTRA
+ CALL FMBETA(M37,M38,M35)
+ CALL FMEQ(M35,M25)
+ K_RETURN_CODE = 1
+ RETURN
+ ELSE IF (M36(-1) < 0 .OR. FMCOMP(M36,'>',M32)) THEN
+ CALL FMST2M('UNKNOWN',M25)
+ KFLAG = -4
+ K_RETURN_CODE = 2
+ RETURN
+ ENDIF
+ IF (M37(-1) < 0) THEN
+ CALL FMST2M('UNKNOWN',M25)
+ KFLAG = -4
+ K_RETURN_CODE = 2
+ RETURN
+ ENDIF
+ IF (M38(-1) < 0) THEN
+ CALL FMST2M('UNKNOWN',M25)
+ KFLAG = -4
+ K_RETURN_CODE = 2
+ RETURN
+ ENDIF
+ IF (M37(1) < (-NDIG) .AND. M38(1) < (-NDIG)) THEN
+ CALL FMSUB(M32,M36,M16)
+ CALL FMLN(M16,M25)
+ CALL FMDIV(M32,M37,M16)
+ CALL FMSUB(M16,M25,M17)
+ CALL FMPWR(M36,M37,M16)
+ CALL FMMPY(M17,M16,M25)
+ K_RETURN_CODE = 1
+ RETURN
+ ENDIF
+ CALL FMI2M(1,M16)
+ CALL FMSUB(M16,M38,M06)
+ CALL FMMPY(M36,M06,M16)
+ CALL FMADD(M16,M32,M06)
+ IF (FMCOMP(M06,'==',M32)) THEN
+ CALL FMLN(M36,M16)
+ CALL FMMPY(M37,M16,M25)
+ CALL FMLN(M37,M16)
+ CALL FMSUB_R2(M25,M16)
+ CALL FMEXP(M16,M25)
+ K_RETURN_CODE = 2
+ RETURN
+ ENDIF
+
+! When A or B is large, check for an underflowed result.
+
+ CALL FMDPM(1.0D+7,M16)
+ IF (FMCOMP(M37,'>',M16) .OR. FMCOMP(M38,'>',M16)) THEN
+
+! If B is much larger than A, approximate BETA(A,B) and use
+! that as an upper bound.
+
+ IF (M38(1) >= M37(1)+NDIG) THEN
+ CALL FMADD(M38,M37,M16)
+ CALL FMLN(M16,M27)
+ CALL FMMPY_R2(M37,M27)
+ CALL FMEQ(M37,M31)
+ CALL FMLNGM(M31,M28)
+ CALL FMSUB(M28,M27,M16)
+ CALL FMEXP(M16,M25)
+ IF (M25(1) <= -MXSAVE-1) THEN
+ K_RETURN_CODE = 2
+ RETURN
+ ENDIF
+ ENDIF
+
+! If A > 2 > B, use the bound
+! C = min( X , (A-2)/(A+B-2) )
+! BETA(X,A,B) < (A-1)*X/B * C**(A-2) * (1-C)**B
+!
+! An alternate bound is also tried:
+! C = min( X , (A-1)/(A+B-2) )
+! BETA(X,A,B) < C**A * (1-C)**(1-B)
+
+ CALL FMI2M(2,M16)
+ IF (FMCOMP(M37,'>',M16) .AND. FMCOMP(M37,'>',M16)) THEN
+ CALL FMI2M(2,M05)
+ CALL FMSUB(M37,M05,M16)
+ CALL FMADD(M37,M38,M06)
+ CALL FMSUB_R1(M06,M05)
+ CALL FMDIV_R1(M16,M06)
+ CALL FMMIN(M36,M16,M27)
+ CALL FMI2M(1,M16)
+ CALL FMSUB_R2(M37,M16)
+ CALL FMLN(M16,M31)
+ CALL FMLN(M36,M16)
+ CALL FMADD_R1(M31,M16)
+ CALL FMLN(M38,M16)
+ CALL FMSUB_R1(M31,M16)
+ CALL FMI2M(2,M06)
+ CALL FMSUB(M37,M06,M25)
+ CALL FMLN(M27,M16)
+ CALL FMMPY_R2(M25,M16)
+ CALL FMADD_R1(M31,M16)
+ CALL FMI2M(1,M06)
+ CALL FMSUB(M06,M27,M16)
+ CALL FMLN(M16,M25)
+ CALL FMMPY(M38,M25,M16)
+ CALL FMADD_R1(M31,M16)
+ CALL FMEXP(M31,M25)
+ IF (M25(1) <= -MXSAVE-1) THEN
+ K_RETURN_CODE = 2
+ RETURN
+ ENDIF
+ CALL FMI2M(1,M06)
+ CALL FMSUB(M37,M06,M16)
+ CALL FMADD(M37,M38,M06)
+ CALL FMI2M(2,M05)
+ CALL FMSUB_R1(M06,M05)
+ CALL FMDIV_R1(M16,M06)
+ CALL FMMIN(M36,M16,M27)
+ CALL FMI2M(1,M06)
+ CALL FMSUB(M06,M27,M16)
+ CALL FMLN(M16,M31)
+ CALL FMSUB(M38,M06,M05)
+ CALL FMMPY_R2(M05,M31)
+ CALL FMLN(M36,M16)
+ CALL FMMPY_R2(M37,M16)
+ CALL FMADD_R2(M16,M31)
+ CALL FMEXP(M31,M25)
+ IF (M25(1) <= -MXSAVE-1) THEN
+ K_RETURN_CODE = 2
+ RETURN
+ ENDIF
+ ENDIF
+
+! If A > 2 and B > 2, use the bound
+! C = min( X , (A-1)/(A+B-2) )
+! BETA(X,A,B) < X * C**(A-1) * (1-C)**(B-1)
+
+ CALL FMI2M(2,M16)
+ IF (FMCOMP(M37,'>',M16) .AND. FMCOMP(M38,'>',M16)) THEN
+ CALL FMI2M(1,M06)
+ CALL FMSUB(M37,M06,M16)
+ CALL FMADD(M37,M38,M06)
+ CALL FMI2M(2,M05)
+ CALL FMSUB_R1(M06,M05)
+ CALL FMDIV_R1(M16,M06)
+ CALL FMMIN(M36,M16,M27)
+ CALL FMI2M(1,M06)
+ CALL FMSUB(M06,M27,M16)
+ CALL FMLN(M16,M31)
+ CALL FMSUB(M38,M06,M05)
+ CALL FMMPY_R2(M05,M31)
+ CALL FMLN(M27,M16)
+ CALL FMSUB(M37,M06,M05)
+ CALL FMMPY_R2(M05,M16)
+ CALL FMADD_R2(M16,M31)
+ CALL FMLN(M36,M16)
+ CALL FMADD_R2(M16,M31)
+ CALL FMEXP(M31,M25)
+ IF (M25(1) <= -MXSAVE-1) THEN
+ K_RETURN_CODE = 2
+ RETURN
+ ENDIF
+ ENDIF
+ ENDIF
+
+! Check for cases where X is large enough so that at this
+! precision, B(X,A,B) = B(A,B). These are often unstable,
+! so it is better to use Beta.
+
+ CALL FMI2M(1,M16)
+ CALL FMI2M(2,M05)
+ CALL FMADD(M37,M38,M06)
+ IF (FMCOMP(M37,'>',M16) .AND. FMCOMP(M06,'>',M05)) THEN
+ CALL FMI2M(1,M06)
+ CALL FMSUB(M37,M06,M16)
+ CALL FMADD(M37,M38,M06)
+ CALL FMI2M(2,M05)
+ CALL FMSUB_R1(M06,M05)
+ CALL FMDIV(M16,M06,M35)
+ CALL FMI2M(1,M16)
+ CALL FMADD(M37,M38,M06)
+ CALL FMADDI(M06,-3)
+ IF (FMCOMP(M35,'<',M16) .AND. FMCOMP(M36,'>',M35) .AND. &
+ M06(2) /= 0) THEN
+ CALL FMI2M(1,M06)
+ CALL FMSUB(M37,M06,M05)
+ CALL FMSUB(M38,M06,M16)
+ CALL FMMPY_R2(M05,M16)
+ CALL FMADD(M37,M38,M05)
+ CALL FMI2M(3,M06)
+ CALL FMSUB_R2(M05,M06)
+ CALL FMDIV(M16,M06,M34)
+ IF (M34(-1) >= 0) THEN
+ CALL FMI2M(1,M06)
+ CALL FMSUB_R2(M37,M06)
+ CALL FMSQRT(M34,M16)
+ CALL FMADD(M06,M16,M34)
+ CALL FMADD(M37,M38,M06)
+ CALL FMI2M(2,M05)
+ CALL FMSUB_R1(M06,M05)
+ CALL FMDIV_R1(M34,M06)
+ ELSE
+ CALL FMDPM(DBLE(1.1),M34)
+ ENDIF
+ CALL FMI2M(1,M16)
+ IF (FMCOMP(M34,'>',M35) .AND. FMCOMP(M34,'<',M16) .AND. &
+ FMCOMP(M36,'>=',M34)) THEN
+
+! Approximate B(A,B).
+
+ CALL FMADD(M37,M38,M16)
+ IF (FMCOMP(M16,'==',M37)) THEN
+ CALL FMLN(M38,M16)
+ CALL FMDPM(0.5D0,M06)
+ CALL FMSUB_R2(M38,M06)
+ CALL FMMPY(M06,M16,M33)
+ CALL FMSUB_R1(M33,M38)
+ CALL FMDPM(DLOGTP/2.0D0,M16)
+ CALL FMSUB_R1(M33,M16)
+ CALL FMLN(M37,M16)
+ CALL FMMPY_R2(M38,M16)
+ CALL FMSUB_R1(M33,M16)
+ ELSE IF (FMCOMP(M16,'==',M38)) THEN
+ CALL FMLN(M37,M16)
+ CALL FMDP2M(0.5D0,M06)
+ CALL FMSUB_R2(M37,M06)
+ CALL FMMPY(M06,M16,M33)
+ CALL FMSUB_R1(M33,M37)
+ CALL FMDPM(DLOGTP/2.0D0,M16)
+ CALL FMSUB_R1(M33,M16)
+ CALL FMLN(M38,M16)
+ CALL FMMPY_R2(M37,M16)
+ CALL FMSUB_R1(M33,M16)
+ ELSE
+ CALL FMLN(M37,M16)
+ CALL FMDP2M(0.5D0,M06)
+ CALL FMSUB_R2(M37,M06)
+ CALL FMMPY(M06,M16,M33)
+ CALL FMLN(M38,M16)
+ CALL FMDP2M(0.5D0,M06)
+ CALL FMSUB_R2(M38,M06)
+ CALL FMMPY_R2(M06,M16)
+ CALL FMADD_R1(M33,M16)
+ CALL FMADD(M37,M38,M16)
+ CALL FMLN(M16,M06)
+ CALL FMDP2M(0.5D0,M05)
+ CALL FMSUB_R2(M16,M05)
+ CALL FMMPY(M05,M06,M16)
+ CALL FMSUB_R1(M33,M16)
+ CALL FMDPM(DLOGTP/2.0D0,M16)
+ CALL FMSUB_R1(M33,M16)
+ ENDIF
+ CALL FMEXP(M33,M12)
+ CALL FMEQ(M12,M33)
+
+! Bound the area from X to 1.
+
+ CALL FMI2M(1,M16)
+ CALL FMSUB(M16,M36,M06)
+ IF (FMCOMP(M06,'==',M16)) THEN
+ CALL FMLN(M36,M16)
+ CALL FMI2M(1,M05)
+ CALL FMSUB(M37,M05,M06)
+ CALL FMMPY(M06,M16,M32)
+ CALL FMSUB(M38,M05,M06)
+ CALL FMMPY(M36,M06,M16)
+ CALL FMSUB_R1(M32,M16)
+ CALL FMSUB(M05,M36,M16)
+ CALL FMDIVI_R1(M16,2)
+ CALL FMLN(M16,M17)
+ CALL FMSUB_R1(M32,M17)
+ ELSE
+ CALL FMLN(M36,M16)
+ CALL FMI2M(1,M05)
+ CALL FMSUB(M37,M05,M06)
+ CALL FMMPY(M06,M16,M32)
+ CALL FMSUB(M38,M05,M06)
+ CALL FMSUB(M05,M36,M16)
+ CALL FMLN(M16,M17)
+ CALL FMMPY_R2(M06,M17)
+ CALL FMADD_R1(M32,M17)
+ CALL FMDIVI_R1(M16,2)
+ CALL FMLN(M16,M17)
+ CALL FMADD_R1(M32,M17)
+ ENDIF
+ CALL FMEXP(M32,M12)
+ CALL FMEQ(M12,M32)
+ CALL FMSUB(M33,M32,M16)
+ IF (FMCOMP(M16,'==',M33)) THEN
+ CALL FMEQ(M32,M40)
+ CALL FMBETA(M37,M38,M35)
+ CALL FMSUB(M35,M40,M16)
+ IF (FMCOMP(M16,'==',M35)) THEN
+ M35(0) = 1.06*M35(0)
+ CALL FMEQ(M35,M25)
+ K_RETURN_CODE = 1
+ RETURN
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSE IF (M37(1) < 1 .AND. FMCOMP(M38,'>',M16)) THEN
+
+! Approximate B(A,B).
+
+ CALL FMADD(M37,M38,M16)
+ IF (FMCOMP(M16,'==',M37)) THEN
+ CALL FMLN(M38,M16)
+ CALL FMDP2M(0.5D0,M06)
+ CALL FMSUB_R2(M38,M06)
+ CALL FMMPY(M06,M16,M33)
+ CALL FMSUB_R1(M33,M38)
+ CALL FMDPM(DLOGTP/2.0D0,M16)
+ CALL FMSUB_R1(M33,M16)
+ CALL FMLN(M37,M16)
+ CALL FMMPY_R2(M38,M16)
+ CALL FMSUB_R1(M33,M16)
+ ELSE IF (FMCOMP(M16,'==',M38)) THEN
+ CALL FMLN(M37,M16)
+ CALL FMDP2M(0.5D0,M06)
+ CALL FMSUB_R2(M37,M06)
+ CALL FMMPY(M06,M16,M33)
+ CALL FMSUB_R1(M33,M37)
+ CALL FMDPM(DLOGTP/2.0D0,M16)
+ CALL FMSUB_R1(M33,M16)
+ CALL FMLN(M38,M16)
+ CALL FMMPY_R2(M37,M16)
+ CALL FMSUB_R1(M33,M16)
+ ELSE
+ CALL FMLN(M37,M16)
+ CALL FMDP2M(0.5D0,M06)
+ CALL FMSUB_R2(M37,M06)
+ CALL FMMPY(M06,M16,M33)
+ CALL FMLN(M38,M16)
+ CALL FMDP2M(0.5D0,M06)
+ CALL FMSUB_R2(M38,M06)
+ CALL FMMPY_R2(M06,M16)
+ CALL FMADD_R1(M33,M16)
+ CALL FMADD(M37,M38,M16)
+ CALL FMLN(M16,M06)
+ CALL FMDP2M(0.5D0,M05)
+ CALL FMSUB_R2(M16,M05)
+ CALL FMMPY(M05,M06,M16)
+ CALL FMSUB_R1(M33,M16)
+ CALL FMDPM(DLOGTP/2.0D0,M16)
+ CALL FMSUB_R1(M33,M16)
+ ENDIF
+ CALL FMEXP(M33,M12)
+ CALL FMEQ(M12,M33)
+
+! Bound the area from X to 1.
+
+ CALL FMI2M(1,M16)
+ CALL FMSUB(M16,M36,M06)
+ IF (FMCOMP(M06,'==',M16)) THEN
+ CALL FMLN(M36,M16)
+ CALL FMI2M(1,M05)
+ CALL FMSUB(M37,M05,M06)
+ CALL FMMPY(M06,M16,M32)
+ CALL FMSUB(M38,M05,M06)
+ CALL FMMPY(M36,M06,M16)
+ CALL FMSUB_R1(M32,M16)
+ CALL FMSUB(M05,M36,M16)
+ CALL FMDIVI_R1(M16,2)
+ CALL FMLN(M16,M17)
+ CALL FMSUB_R1(M32,M17)
+ CALL FMEXP(M32,M12)
+ CALL FMEQ(M12,M32)
+ ELSE
+ CALL FMLN(M36,M16)
+ CALL FMI2M(1,M05)
+ CALL FMSUB(M37,M05,M06)
+ CALL FMMPY(M06,M16,M32)
+ CALL FMSUB(M38,M05,M06)
+ CALL FMSUB(M05,M36,M16)
+ CALL FMLN(M16,M17)
+ CALL FMMPY_R2(M06,M17)
+ CALL FMADD_R1(M32,M17)
+ CALL FMDIVI_R1(M16,2)
+ CALL FMLN(M16,M17)
+ CALL FMADD_R1(M32,M17)
+ CALL FMEXP(M32,M12)
+ CALL FMEQ(M12,M32)
+ ENDIF
+ CALL FMSUB(M33,M32,M16)
+ IF (FMCOMP(M16,'==',M33)) THEN
+ CALL FMBETA(M37,M38,M35)
+ M35(0) = 1.06*M35(0)
+ CALL FMEQ(M35,M25)
+ K_RETURN_CODE = 1
+ RETURN
+ ENDIF
+ ENDIF
+
+! If B is small enough, use one of two series or an asymptotic
+! series, depending on the size of X and A.
+
+ CALL FMI2M(1,M05)
+ CALL FMADD(M05,M38,M06)
+ CALL FMADD(M37,M38,M16)
+ IF ((FMCOMP(M06,'==',M05) .AND. FMCOMP(M16,'==',M37)) ) THEN
+ CALL FMDP2M(0.5D0,M16)
+ IF (FMCOMP(M36,'<=',M16)) THEN
+ CALL FMI2M(0,M26)
+ CALL FMEQ(M36,M27)
+ CALL FMI2M(1,M06)
+ CALL FMADD(M37,M06,M16)
+ CALL FMDIV(M27,M16,M28)
+ CALL FMEQ(M37,M18)
+ CALL FMADDI(M18,1)
+ NDSAV1 = NDIG
+ DO J = 2, NTERMS
+ CALL FMADD_R1(M26,M28)
+ IF (KFLAG /= 0 .AND. J >= 3) EXIT
+ NDIG = MIN(NDSAV1,MAX(2,NDSAV1-INT(M26(1)-M28(1))+1))
+ CALL FMMPY_R1(M27,M36)
+ CALL FMADDI(M18,1)
+ CALL FMDIV(M27,M18,M28)
+ NDIG = NDSAV1
+ ENDDO
+ CALL FMPWR(M36,M37,M16)
+ CALL FMI2M(1,M05)
+ CALL FMDIV(M05,M37,M06)
+ CALL FMADD(M06,M26,M05)
+ CALL FMMPY(M16,M05,M26)
+ CALL FMEQ(M26,M25)
+ K_RETURN_CODE = 1
+ RETURN
+ ENDIF
+ CALL FMDP2M(0.5D0,M16)
+ CALL FMI2M(20,M06)
+ IF ((FMCOMP(M36,'>',M16) .AND. FMCOMP(M37,'<',M06))) THEN
+ CALL FMI2M(0,M26)
+ CALL FMI2M(1,M16)
+ CALL FMSUB(M16,M36,M29)
+ CALL FMI2M(1,M06)
+ CALL FMADD(M38,M06,M16)
+ CALL FMPWR(M29,M16,M27)
+ CALL FMI2M(1,M16)
+ CALL FMSUB(M16,M37,M06)
+ CALL FMMPY_R2(M06,M27)
+
+ CALL FMEQ(M27,M28)
+ NDSAV1 = NDIG
+ DO J = 2, NTERMS
+ CALL FMADD_R1(M26,M28)
+ IF (KFLAG /= 0 .AND. J >= 3) EXIT
+ NDIG = MIN(NDSAV1,MAX(2,NDSAV1-INT(M26(1)-M28(1))+1))
+ CALL FMI2M(J,M06)
+ CALL FMSUB(M06,M37,M16)
+ CALL FMMPY(M27,M16,M06)
+ CALL FMMPY(M06,M29,M16)
+ CALL FMDIVI(M16,J,M27)
+ CALL FMDIVI(M27,J,M28)
+ NDIG = NDSAV1
+ ENDDO
+ CALL FMLN(M29,M16)
+ CALL FMI2M(1,M06)
+ CALL FMDIV(M06,M37,M05)
+ CALL FMSUB(M05,M16,M06)
+ CALL FMSUB(M06,M26,M27)
+ CALL FMEULR(M28)
+ CALL FMI2M(1,M16)
+ CALL FMADD(M37,M16,M29)
+ CALL FMPSI(M29,M14)
+ CALL FMEQ(M14,M29)
+ CALL FMSUB(M27,M28,M16)
+ CALL FMSUB(M16,M29,M25)
+ K_RETURN_CODE = 1
+ RETURN
+ ENDIF
+
+ CALL FMDP2M(0.5D0,M16)
+ CALL FMI2M(20,M06)
+ IF ((FMCOMP(M36,'>',M16) .AND. FMCOMP(M37,'>=',M06))) THEN
+ CALL FMSP2M(0.7*REAL(NDIG)*ALOGMT,M32)
+ IF (FMCOMP(M37,'>=',M32)) THEN
+ NUP = 0
+ CALL FMEQ(M37,M39)
+ CALL FMI2M(0,M40)
+ ELSE
+ CALL FMSUB(M32,M37,M16)
+ CALL FMADDI(M16,1)
+ CALL FMM2I(M16,NUP)
+ CALL FMI2M(NUP,M16)
+ CALL FMADD(M37,M16,M39)
+ CALL FMI2M(1,M40)
+ CALL FMEQ(M37,M27)
+ NDSAV1 = NDIG
+ DO J = 1, NUP-1
+ CALL FMMPY_R1(M27,M36)
+ CALL FMI2M(J,M16)
+ CALL FMADD(M37,M16,M06)
+ CALL FMDIV(M27,M06,M28)
+ NDIG = NDSAV1
+ CALL FMADD_R1(M40,M28)
+ NDIG = MIN(NDSAV1, &
+ MAX(2,NDSAV1-INT(M40(1)-M28(1))+1))
+ ENDDO
+ NDIG = NDSAV1
+ CALL FMPWR(M36,M37,M16)
+ CALL FMMPY(M40,M16,M17)
+ CALL FMI2M(1,M06)
+ CALL FMSUB(M06,M36,M16)
+ CALL FMPWR(M16,M38,M40)
+ CALL FMMPY_R2(M17,M40)
+ CALL FMDIV_R1(M40,M37)
+ ENDIF
+
+ CALL FMI2M(1,M06)
+ CALL FMDIVI(M06,2,M16)
+ CALL FMSUB(M39,M16,M33)
+ CALL FMLN(M36,M16)
+ CALL FMMPY(M33,M16,M34)
+ IF (M34(1) /= MUNKNO .AND. M34(2) /= 0) M34(-1) = -M34(-1)
+ CALL FMIGM2(M38,M34,M35)
+ CALL FMPWR(M34,M38,M16)
+ CALL FMEQ(M34,M17)
+ IF (M17(1) /= MUNKNO .AND. M17(2) /= 0) M17(-1) = -M17(-1)
+ CALL FMEXP(M17,M06)
+ CALL FMMPY(M06,M16,M17)
+ CALL FMDIV_R1(M35,M17)
+ CALL FMEQ(M35,M26)
+ CALL FMSQR(M33,M16)
+ CALL FMMPYI(M16,4,M27)
+ CALL FMI2M(1,M28)
+ CALL FMI2M(1,M29)
+ CALL FMI2M(1,M30)
+ CALL FMLN(M36,M16)
+ CALL FMDIVI(M16,2,M06)
+ CALL FMSQR(M06,M32)
+ NDSAV1 = NDIG
+ J4 = 0
+ DO J = 1, NTERMS
+ JSWITCH = MAX(2,INT(NDIG*DLOGMB/(2.0D0*LOG(23.0)) + 2))
+ IF (J < JSWITCH) THEN
+ J4 = 0
+ CALL FMMPYI_R1(M29,4)
+ CALL FMMPYI(M30,2*J-1,M16)
+ CALL FMMPYI(M16,2*J,M30)
+ CALL FMI2M(2,M06)
+ CALL FMSUB(M06,M29,M16)
+ CALL FMDIV(M16,M30,M31)
+ CALL FMBERN(2*J,M31,M11)
+ CALL FMEQ(M11,M31)
+ ELSE
+ IF (J4 == 0) THEN
+ J4 = 1
+ N = 2*J
+ DO K = 1, 8
+ KPT = (K-1)*(NDSAV1+3)
+ CALL FMI2M(KPRIME(K),MJSUMS(KPT-1))
+ CALL FMIPWR(MJSUMS(KPT-1),N,M16)
+ CALL FMEQ(M16,MJSUMS(KPT-1))
+ ENDDO
+ ELSE
+ DO K = 1, 8
+ KPT = (K-1)*(NDSAV1+3)
+ CALL FMMPYI(MJSUMS(KPT-1),KPRIME(K)**2, &
+ MJSUMS(KPT-1))
+ ENDDO
+ ENDIF
+ CALL FMPI(M22)
+ CALL FMI2M(1,M18)
+ CALL FMI2M(1,M19)
+ DO K = 1, 8
+ KPT = (K-1)*(NDSAV1+3)
+ CALL FMEQ(MJSUMS(KPT-1),M21)
+ CALL FMI2M(KPRIME(K)**2-1,M16)
+ CALL FMSUB(M21,M18,M06)
+ CALL FMDIV_R2(M16,M06)
+ CALL FMSUB(M18,M06,M20)
+ CALL FMI2M(1,M16)
+ IF (FMCOMP(M20,'==',M16)) EXIT
+ CALL FMMPY_R1(M19,M20)
+ ENDDO
+ CALL FMEQ(MJSUMS,M21)
+ CALL FMI2M(-1,M06)
+ CALL FMSQR(M22,M17)
+ CALL FMDIV(M06,M17,M16)
+ CALL FMI2M(2,M06)
+ CALL FMSUB(M06,M21,M05)
+ CALL FMI2M(8,M06)
+ CALL FMSUB_R1(M06,M21)
+ CALL FMDIV(M05,M06,M17)
+ CALL FMMPY(M16,M17,M06)
+ CALL FMMPY(M06,M19,M20)
+ CALL FMMPY_R2(M20,M31)
+ ENDIF
+ CALL FMI2M(2*J-2,M06)
+ CALL FMADD(M38,M06,M16)
+ CALL FMMPY(M16,M35,M06)
+ CALL FMMPYI(M06,2*J-1,M35)
+ CALL FMI2M(2*J-1,M06)
+ CALL FMADD(M34,M06,M16)
+ CALL FMMPY(M28,M16,M06)
+ CALL FMADD_R1(M35,M06)
+ CALL FMDIV_R1(M35,M27)
+ CALL FMMPY_R1(M28,M32)
+ CALL FMMPY(M31,M35,M23)
+ NDIG = NDSAV1
+ CALL FMADD_R1(M26,M23)
+ IF (KFLAG /= 0 .AND. J >= 3) EXIT
+ NDIG = MIN(NDSAV1,MAX(2,NDSAV1-INT(M26(1)-M23(1))+1))
+ ENDDO
+ NDIG = NDSAV1
+ CALL FMPWR(M36,M33,M16)
+ CALL FMLN(M36,M17)
+ IF (M17(1) /= MUNKNO .AND. M17(2) /= 0) M17(-1) = -M17(-1)
+ CALL FMPWR(M17,M38,M25)
+ CALL FMMPY(M26,M16,M06)
+ CALL FMMPY_R2(M06,M25)
+ CALL FMADD_R2(M40,M25)
+ K_RETURN_CODE = 1
+ RETURN
+ ENDIF
+ ENDIF
+
+! If A or B is large in magnitude, use more guard digits.
+
+ IEXTRA = MIN(MAX(INT(M37(1)),INT(M38(1)),0) , &
+ INT(1.0+ALOGMX/ALOGMB))
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M36,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M37,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M38,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NUMTRY > 0 .AND. NDIG > NDG2MX-6) NDIG = NDG2MX - 6
+ IF (NDIG > NDG2MX-6) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDOLD
+ CALL FMST2M('UNKNOWN',M25)
+ K_RETURN_CODE = 2
+ ENDIF
+ RETURN
+ END SUBROUTINE FMIBTA2
+
+ SUBROUTINE FMIGM1(MA,MB,MC)
+
+! MC = Incomplete Gamma(MA,MB)
+
+! Integral from 0 to MB of e**(-t) * t**(MA-1) dt.
+
+! This is (lower case) gamma(a,x).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+ DOUBLE PRECISION FMDPLG,X,A,B,SMALL,BIG,TOL,T1,BIGJ
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MAXE,MODA2,MXSAVE
+ INTEGER IEXTRA,INTA,INTG,J,JCHECK,JEXTRA,JTERMS,K,KASAVE,KFLAGA, &
+ KFLAGI,KFLAGX,KFLGOK,KMID,KOVUN,KRESLT,KWRNSV,KXNEG,LESS, &
+ NDGOAL,NDIG2,NDOLD,NDSAV1,NDSAVE,NGOAL,NMETHD,NMNNDG, &
+ NMXDIF,NT,NTERMS,NUMTRY
+ LOGICAL FMCOMP
+ REAL C,C1,C2,D,T,TLNB,Y
+
+ CALL FMENT2('FMIGM1',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+
+ KACCSW = 1
+ MACCA = MA(0)
+ MACCB = MB(0)
+ CALL FMEQ2(MA,M31,NDSAVE,NDIG)
+ M31(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ2(MB,M32,NDSAVE,NDIG)
+ M32(0) = NINT(NDIG*ALOGM2)
+ NUMTRY = 0
+
+ 110 NTERMS = INT(INTMAX/10)
+
+! Check for special cases.
+
+! See if A is small enough so that the result is X**A/A.
+
+ CALL FMI2M(1,M16)
+ CALL FMADD(M31,M16,M06)
+ IF (FMCOMP(M06,'==',M16)) THEN
+ CALL FMPWR(M32,M31,M16)
+ CALL FMDIV(M16,M31,M25)
+ IF (M25(1) /= MUNKNO) GO TO 180
+ ENDIF
+
+! Check to see if X is large enough so that the result
+! is Gamma(A).
+
+ CALL FMI2M(1,M16)
+ CALL FMDIV(M31,M32,M06)
+ M06(-1) = 1
+ CALL FMDPM(DBLE(0.001),M05)
+ IF (FMCOMP(M32,'>',M16) .AND. FMCOMP(M06,'<=',M05)) THEN
+ CALL FMI2M(1,M06)
+ CALL FMSUB(M31,M06,M16)
+ CALL FMLN(M32,M17)
+ CALL FMMPY(M16,M17,M06)
+ CALL FMSUB(M06,M32,M17)
+ CALL FMEXP(M17,M30)
+ IF (M30(1) /= MUNKNO) THEN
+ CALL FMGAM(M31,M29)
+ IF (M29(1) > M30(1)+NDIG .AND. &
+ M29(1) /= MUNKNO) THEN
+ CALL FMEQ(M29,M25)
+ GO TO 180
+ ENDIF
+ ENDIF
+ ENDIF
+
+! A,X are double precision approximations to the two
+! arguments to this function.
+! INTA = A if A is a small integer. It is used to limit
+! the number of terms used in the asymptotic series
+! and in the continued fraction expansion.
+
+ INTA = NTERMS
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMM2I(M31,INTG)
+ KFLAGI = KFLAG
+ IF (KFLAG == 0) INTA = INTG
+ CALL FMM2DP(M31,A)
+ KFLAGA = KFLAG
+ IF (KFLAG /= 0 .AND. M31(1) < 0) THEN
+ A = 1.0D0/DPMAX
+ IF (M31(-1) < 0) A = -A
+ KFLAGA = 0
+ ENDIF
+ CALL FMM2DP(M32,X)
+ KFLAGX = KFLAG
+ IF (KFLAG /= 0 .AND. M32(1) < 0) THEN
+ X = 1.0D0/DPMAX
+ IF (M32(-1) < 0) X = -X
+ KFLAGX = 0
+ ENDIF
+ KWARN = KWRNSV
+
+! If A or X is large in magnitude, use more guard digits.
+
+ IEXTRA = MIN(MAX(INT(M31(1)),INT(M32(1)),0) , &
+ INT(1.0+ALOGMX/ALOGMB))
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M31,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M32,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDOLD
+ CALL FMST2M('UNKNOWN',M25)
+ GO TO 180
+ ENDIF
+
+! KXNEG = 1 if X is negative and A is a positive integer.
+
+ KXNEG = 0
+
+! MODA2 = MOD(A,2) when KXNEG is 1.
+
+ MODA2 = 0
+
+ IF (M31(1) == MEXPOV .OR. M32(1) == MEXPOV) THEN
+ IF (M31(1) == MEXPOV .AND. M31(2) /= 0 .AND. &
+ M31(-1) == 1) THEN
+ IF (M32(2) == 0) THEN
+ CALL FMI2M(0,M25)
+ GO TO 160
+ ENDIF
+ IF (M32(1) == MEXPOV .AND. M32(2) /= 0 .AND. &
+ M32(-1) == 1) THEN
+ CALL FMST2M('OVERFLOW',M25)
+ KFLAG = -5
+ GO TO 160
+ ELSE IF (M32(-1) > 0) THEN
+ CALL FMI2M(1,M25)
+ IF (FMCOMP(M32,'<=',M25)) THEN
+ CALL FMST2M('UNDERFLOW',M25)
+ KFLAG = -6
+ GO TO 160
+ ELSE
+ CALL FMST2M('OVERFLOW',M25)
+ KFLAG = -5
+ GO TO 160
+ ENDIF
+ ENDIF
+ ENDIF
+ IF (M32(1) == MEXPOV .AND. M32(2) /= 0 .AND. &
+ M32(-1) == 1) THEN
+ CALL FMGAM(M31,M30)
+ CALL FMEQ(M30,M25)
+ GO TO 160
+ ENDIF
+ IF (M32(1) == MEXPOV .AND. M32(-1) < 0 .AND. &
+ M31(-1) > 0.AND. M31(2) > 0) THEN
+ IF (M31(1) /= MEXPOV) THEN
+ CALL FMINT(M31,M24)
+ IF (FMCOMP(M31,'==',M24)) THEN
+ CALL FMI2M(2,M21)
+ CALL FMMOD(M24,M21,M16)
+ CALL FMEQ(M16,M21)
+ IF (M21(2) /= 0) THEN
+ CALL FMST2M('-OVERFLOW',M25)
+ KFLAG = -5
+ GO TO 160
+ ELSE
+ CALL FMST2M('OVERFLOW',M25)
+ KFLAG = -5
+ GO TO 160
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ CALL FMST2M('UNKNOWN',M25)
+ KFLAG = -4
+ GO TO 180
+ ENDIF
+
+ IF (M31(1) == MEXPUN .OR. M32(1) == MEXPUN) THEN
+ CALL FMABS(M31,M06)
+ CALL FMI2M(1,M16)
+ IF (FMCOMP(M06,'<',M16) .AND. M32(1) == MEXPUN) THEN
+ CALL FMST2M('UNKNOWN',M25)
+ KFLAG = -4
+ GO TO 180
+ ENDIF
+ CALL FMABS(M31,M06)
+ CALL FMI2M(1,M16)
+ IF (FMCOMP(M06,'>=',M16) .AND. M32(1) == MEXPUN .AND. &
+ M32(-1) > 0) THEN
+ CALL FMST2M('UNDERFLOW',M25)
+ KFLAG = -6
+ GO TO 180
+ ENDIF
+ ENDIF
+
+ IF (M31(-1) < 0 .OR. M31(2) == 0) THEN
+ CALL FMINT(M31,M24)
+ IF (FMCOMP(M31,'==',M24)) THEN
+ CALL FMST2M('UNKNOWN',M25)
+ KFLAG = -4
+ GO TO 180
+ ENDIF
+ ENDIF
+ IF (M32(2) == 0) THEN
+ IF (M31(-1) <= 0) THEN
+ CALL FMST2M('UNKNOWN',M25)
+ KFLAG = -4
+ GO TO 180
+ ELSE
+ CALL FMI2M(0,M25)
+ GO TO 180
+ ENDIF
+ ENDIF
+ IF (M32(-1) < 0) THEN
+ CALL FMINT(M31,M24)
+ IF (FMCOMP(M31,'==',M24)) THEN
+ KXNEG = 1
+ CALL FMI2M(2,M21)
+ CALL FMMOD(M24,M21,M16)
+ CALL FMEQ(M16,M21)
+ IF (M21(2) /= 0) MODA2 = 1
+ ELSE
+ CALL FMST2M('UNKNOWN',M25)
+ KFLAG = -4
+ GO TO 180
+ ENDIF
+ ENDIF
+ CALL FMMAX(M31,M32,M16)
+ CALL FMMIN(M31,M32,M17)
+ CALL FMDPM(1.0D6,M05)
+ CALL FMDPM(1.0D2,M06)
+ IF (FMCOMP(M16,'>=',M05) .AND. FMCOMP(M17,'>=',M06)) THEN
+ CALL FMI2M(1,M16)
+ CALL FMSUB(M31,M16,M18)
+ CALL FMMIN(M18,M32,M20)
+ CALL FMADDI(M20,-1)
+ CALL FMLN(M20,M16)
+ CALL FMMPY(M18,M16,M06)
+ CALL FMSUB(M06,M20,M16)
+ CALL FMEXP(M16,M22)
+ IF ((M22(1) == MEXPOV .AND. M22(2) /= 0 .AND. &
+ M22(-1) > 0) .OR. M22(1) > MXSAVE+1) THEN
+ CALL FMST2M('OVERFLOW',M25)
+ KFLAG = -5
+ GO TO 160
+ ENDIF
+ ENDIF
+
+! Determine which method to use.
+
+! NMETHD = 1 means use the convergent series,
+! = 2 means use the asymptotic series,
+! = 3 means use the continued fraction expansion.
+
+ CALL FMI2M(-10000,M20)
+ CALL FMI2M(10000,M21)
+ CALL FMABS(M31,M23)
+ CALL FMABS(M32,M24)
+ CALL FMSUB(M24,M23,M22)
+ IF (FMCOMP(M22,'<=',M20)) THEN
+ NMETHD = 1
+ ELSE IF (FMCOMP(M22,'>=',M21) .AND. M31(-1) > 0 &
+ .AND. M32(-1) > 0) THEN
+ NMETHD = 2
+ ELSE IF (FMCOMP(M22,'>=',M21)) THEN
+ NMETHD = 3
+ ELSE IF (M31(-1) > 0 .AND. M32(-1) > 0) THEN
+ CALL FMDP2M(SQRT(DPMAX),M20)
+ IF (FMCOMP(M32,'>=',M20)) THEN
+ KFLAG = -5
+ CALL FMST2M('OVERFLOW',M25)
+ GO TO 160
+ ENDIF
+
+ C2 = REAL(DBLE(NDSAVE)*DLOGMB)
+ C1 = REAL(DBLE(C2)/10.0D0 + A + 10.0D0)
+ C2 = REAL(MAX( 10.0D0 , DBLE(C2)/6.0D0 , &
+ A - 3.5D0*A/(SQRT(A)+1.0D0)))
+ IF (X < C1) THEN
+ NMETHD = 1
+ ELSE
+ NMETHD = 3
+ ENDIF
+ IF (X > C2) THEN
+
+! Check that the smallest term in the asymptotic series is
+! small enough to give the required accuracy.
+
+ T1 = FMDPLG(A)
+ SMALL = T1 - FMDPLG(-ABS(X)) - (A+ABS(X))*LOG(ABS(X))
+ TOL = -DBLE(NDIG+2)*DLOGMB - 12.0D0
+ B = 1.0D0
+ IF (A > ABS(X)) B = A - ABS(X)
+ BIG = T1 - FMDPLG(A-B) - B*LOG(ABS(X))
+ IF (SMALL < TOL+BIG) NMETHD = 2
+ ENDIF
+ ELSE IF (M31(-1) < 0 .AND. M32(-1) > 0) THEN
+ TLNB = REAL(NDIG)*ALOGMB
+ C = 0.75/TLNB**0.35
+ D = 0.80*TLNB**0.70
+ IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
+ T = REAL(-A) - D/C
+ Y = D + C*T/2.0 + (C/2.0)*SQRT(T**2 + T + (2.0/C)**2)
+ IF (X > Y) THEN
+ NMETHD = 3
+ ELSE
+ NMETHD = 1
+ ENDIF
+ ELSE
+ CALL FMDPM(DBLE(C),M16)
+ CALL FMMPY(M16,M31,M20)
+ M20(-1) = 1
+ IF (FMCOMP(M32,'>',M20)) THEN
+ NMETHD = 3
+ ELSE
+ NMETHD = 1
+ ENDIF
+ ENDIF
+ ELSE IF (M31(-1) > 0 .AND. M32(-1) < 0) THEN
+ CALL FMDPM(DBLE(-0.8),M16)
+ CALL FMMPY(M16,M31,M20)
+ IF (FMCOMP(M20,'<',M32)) THEN
+ NMETHD = 1
+ ELSE
+ NMETHD = 3
+ ENDIF
+ ENDIF
+
+ IF (NMETHD == 2) GO TO 130
+ IF (NMETHD == 3) GO TO 150
+
+! Method 1. Use the X**N/Pochhammer(A+1,N) series.
+
+! M25 is the current sum.
+! M21 is the current term.
+! M20 is (A+N)/X.
+! M29 is 1/X
+
+! Raise the precision if A is negative and near an integer,
+! to compensate for cancellation when (A+N)/X is near zero.
+
+ IF (M31(-1) < 0) THEN
+ CALL FMNINT(M31,M25)
+ CALL FMSUB(M31,M25,M29)
+ IEXTRA = MAX(-INT(M29(1)),0)
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M31,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M32,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDOLD
+ CALL FMST2M('UNKNOWN',M25)
+ GO TO 180
+ ENDIF
+ ENDIF
+
+ JEXTRA = 0
+
+ 120 CALL FMI2M(1,M25)
+ CALL FMI2M(1,M18)
+ CALL FMADD(M31,M18,M20)
+ CALL FMDIV(M32,M20,M21)
+ CALL FMDIV_R1(M20,M32)
+ CALL FMDIV(M18,M32,M29)
+ NDSAV1 = NDIG
+ MAXE = 1
+
+! If A is negative and ABS(A) > ABS(X), the terms in the
+! series first decrease, then increase, then decrease.
+! Try to predict the number of extra digits required to
+! keep the precision from prematurely becoming too small.
+
+ KFLGOK = 1
+ IF (M31(-1) < 0) THEN
+ IF (KFLAGA == 0) THEN
+ IF (ABS(A) > 1.0D3) THEN
+ NMETHD = 3
+ GO TO 150
+ ENDIF
+ ELSE
+ NMETHD = 3
+ GO TO 150
+ ENDIF
+ KFLGOK = 0
+ CALL FMABS(M31,M05)
+ CALL FMABS(M32,M06)
+ IF (FMCOMP(M05,'>',M06)) THEN
+ IF (JEXTRA == 0) THEN
+ IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
+ T1 = FMDPLG(A+AINT(-ABS(X)-A)) - &
+ FMDPLG(A+1.0D0+AINT(ABS(X)-A))
+ T1 = (T1 + 2.0D0*ABS(X)*LOG(ABS(X)+1.0D-10))/ &
+ DLOGMB
+ T1 = MAX(0.0D0,T1+1.0D0)
+ JEXTRA = INT(MIN(DBLE(NDIGMX),T1))
+ ENDIF
+ ENDIF
+
+! If A is negative and ABS(A) is much bigger than ABS(X),
+! the later increase in the size of the terms can be
+! ignored.
+
+ IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
+ T1 = (AINT(X-A)*LOG(ABS(X)+1.0D-10) + FMDPLG(A+1.0D0) &
+ - FMDPLG(A+1.0D0+AINT(X-A))) / DLOGMB
+ IF (T1 < -DBLE(NDIG)) KFLGOK = 1
+ ELSE
+ KFLGOK = 1
+ ENDIF
+ ENDIF
+ ENDIF
+
+ NMNNDG = NDSAV1
+ NMXDIF = 0
+
+! Method 1 summation loop.
+
+ DO J = 1, NTERMS
+ NDIG = NDSAV1
+ MAXE = MAX(MAXE,M21(1))
+ CALL FMADD_R1(M25,M21)
+ IF (KFLAG /= 0) THEN
+ IF (KFLGOK == 0 .AND. KFLAGA == 0 .AND. KFLAGX == 0) THEN
+ IF (DBLE(J) > X-A) EXIT
+ ELSE
+ EXIT
+ ENDIF
+ ENDIF
+
+ CALL FMADD_R1(M20,M29)
+
+ NDIG2 = MAX(2,NDSAV1-INT(M25(1)-M21(1)))
+ NDIG = MIN(NDSAV1,NDIG2+JEXTRA)
+ NMNNDG = MIN(NMNNDG,NDIG)
+ NMXDIF = MAX(NMXDIF,NDIG-NMNNDG)
+ CALL FMDIV_R1(M21,M20)
+ ENDDO
+
+ NDIG = NDSAV1
+ IF (NMXDIF > JEXTRA+1) THEN
+ JEXTRA = NMXDIF
+ GO TO 120
+ ENDIF
+
+ CALL FMABS(M32,M16)
+ CALL FMLN(M16,M17)
+ CALL FMMPY(M31,M17,M06)
+ CALL FMSUB(M06,M32,M29)
+ CALL FMEXP(M29,M30)
+ CALL FMDIV(M25,M31,M24)
+ CALL FMMPY(M30,M24,M23)
+ IF (M23(1) == MUNKNO) THEN
+ CALL FMLN(M25,M16)
+ CALL FMLN(M31,M17)
+ CALL FMADD(M29,M16,M06)
+ CALL FMSUB(M06,M17,M29)
+ CALL FMEXP(M29,M25)
+ ELSE
+ CALL FMEQ(M23,M25)
+ ENDIF
+ IF (KXNEG == 1 .AND. MODA2 == 1 .AND. M25(1) /= MUNKNO .AND. &
+ M25(2) /= 0) THEN
+ M25(-1) = -M25(-1)
+ ENDIF
+
+ GO TO 160
+
+! Method 2. Use the Pochhammer(A-N,N)/X**N series.
+
+! M25 is the current sum.
+! M21 is the current term.
+! M20 is (A-N)/X.
+! M29 is -1/X
+
+! Raise the precision if A is positive and near an integer,
+! to compensate for cancellation when (A-N)/X is near zero.
+
+ 130 IF (M31(-1) > 0) THEN
+ CALL FMNINT(M31,M25)
+ CALL FMSUB(M31,M25,M29)
+ IEXTRA = MAX(-INT(M29(1)),0)
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M31,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M32,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDOLD
+ CALL FMST2M('UNKNOWN',M25)
+ GO TO 180
+ ENDIF
+ ENDIF
+
+ CALL FMGAM(M31,M30)
+ IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
+ NT = INT(((A-1)*LOG(ABS(X)+1.0D-10) - X)/DLOGMB)
+ LESS = MAX(0,INT(M30(1)) - NT - 1)
+ IF (LESS > NDIG .AND. ABS(A) < ABS(X)) THEN
+ CALL FMEQ(M30,M25)
+ GO TO 160
+ ENDIF
+ ENDIF
+ IF (KFLAG /= 0) THEN
+ CALL FMEQ(M30,M25)
+ GO TO 160
+ ENDIF
+ IF (KXNEG == 0) THEN
+ CALL FMLN(M32,M29)
+ CALL FMMPY(M31,M29,M16)
+ CALL FMSUB(M16,M32,M25)
+ CALL FMSUB_R2(M25,M29)
+ CALL FMEXP(M29,M21)
+ ELSE
+ CALL FMI2M(1,M16)
+ CALL FMSUB(M31,M16,M25)
+ CALL FMPWR(M32,M25,M29)
+ CALL FMEXP(M32,M24)
+ CALL FMDIV(M29,M24,M21)
+ ENDIF
+
+! Here M21 is X**(A-1)/EXP(X).
+
+ M21(-1) = -M21(-1)
+ CALL FMEQ(M30,M25)
+ CALL FMDIV(M31,M32,M20)
+ CALL FMI2M(1,M16)
+ CALL FMDIV(M16,M32,M29)
+ IF (M29(1) /= MUNKNO .AND. M29(2) /= 0) M29(-1) = -M29(-1)
+ NDSAV1 = NDIG
+
+! Disable NDIG reduction until the terms in the sum
+! begin to decrease in size.
+
+ BIGJ = 0
+ IF (KFLAGA == 0 .AND. KFLAGX == 0) BIGJ = ABS(A) - ABS(X)
+ JTERMS = NTERMS
+ IF (KFLAGI == 0 .AND. INTA > 0) THEN
+ JTERMS = INTA
+ ELSE IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
+ T1 = A + ABS(X)
+ IF (T1 > 0 .AND. T1 < DBLE(NTERMS)) JTERMS = INT(T1) + 2
+ ENDIF
+
+! Method 2 summation loop.
+
+ DO J = 1, JTERMS
+ NDIG = NDSAV1
+ CALL FMADD_R1(M25,M21)
+ IF (KFLAG /= 0 .AND. J > 1) GO TO 140
+ CALL FMADD_R1(M20,M29)
+ IF (REAL(J) >= BIGJ) THEN
+ NDIG2 = MAX(2,NDSAV1-INT(M25(1)-M21(1)))
+ NDIG = MIN(NDSAV1,NDIG2)
+ ENDIF
+ CALL FMMPY_R1(M21,M20)
+ ENDDO
+
+ 140 NDIG = NDSAV1
+ GO TO 160
+
+! Method 3. Use the continued fraction expansion.
+
+! M29 is the current approximation.
+! M25 is the previous approximation.
+! M21, M22 are the latest numerators.
+! M23, M24 are the latest denominators.
+
+ 150 CALL FMGAM(M31,M30)
+ NDSAV1 = NDIG
+ IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
+ NT = INT(((A-1)*LOG(ABS(X)+1.0D-10) - X)/DLOGMB)
+ LESS = MAX(0,INT(M30(1)) - NT - 1)
+ IF (LESS > NDIG) THEN
+ CALL FMEQ(M30,M25)
+ GO TO 160
+ ENDIF
+ NDIG = MAX(2,NDIG-LESS)
+ ENDIF
+ JEXTRA = INT(MAX(1.0,5.76/ALOGMB + 1.0))
+ IF (NDIG+JEXTRA > NDG2MX) JEXTRA = NDG2MX - NDIG
+ IF (NDIG+JEXTRA > NDSAV1) THEN
+ CALL FMEQ2_R1(M31,NDSAV1,NDSAV1+JEXTRA)
+ CALL FMEQ2_R1(M32,NDSAV1,NDSAV1+JEXTRA)
+ ENDIF
+ NDIG = NDIG + JEXTRA
+ CALL FMI2M(0,M21)
+ CALL FMI2M(1,M22)
+ CALL FMI2M(1,M23)
+ CALL FMEQ2(M32,M24,NDSAV1,NDIG)
+ CALL FMI2M(0,M29)
+ CALL FMEQ2(M31,M20,NDSAV1,NDIG)
+ IF (M20(1) /= MUNKNO .AND. M20(2) /= 0) M20(-1) = -M20(-1)
+ CALL FMI2M(1,M19)
+
+ JCHECK = 10
+ IF (INTA == 1) CALL FMDIV(M22,M32,M29)
+
+! Method 3 continued fraction loop.
+
+ METHOD3: DO J = 1, MIN(NTERMS,INTA-1)
+ CALL FMADD_R1(M20,M19)
+ CALL FMMPY_R2(M20,M21)
+ CALL FMADD_R2(M22,M21)
+ CALL FMMPY_R2(M20,M23)
+ CALL FMADD_R2(M24,M23)
+ CALL FMMPY(M32,M21,M18)
+ CALL FMMPYI_R1(M22,J)
+ CALL FMADD_R2(M18,M22)
+ CALL FMMPY(M32,M23,M18)
+ CALL FMMPYI_R1(M24,J)
+ CALL FMADD_R2(M18,M24)
+
+! Normalize to make overflow or underflow less likely.
+
+ KMID = INT((MAX(M21(1),M22(1),M23(1),M24(1)) + &
+ MIN(M21(1),M22(1),M23(1),M24(1))) / 2)
+ M21(1) = M21(1) - KMID
+ M22(1) = M22(1) - KMID
+ M23(1) = M23(1) - KMID
+ M24(1) = M24(1) - KMID
+
+! Form the quotient and check for convergence.
+
+ IF (MOD(J,JCHECK) == 0 .OR. J == INTA-1) THEN
+ CALL FMEQ(M29,M25)
+ CALL FMDIV(M22,M24,M29)
+ DO K = NDIG-JEXTRA, 1, -1
+ IF (M25(K) /= M29(K)) CYCLE METHOD3
+ ENDDO
+ EXIT
+ ENDIF
+ ENDDO METHOD3
+
+ CALL FMEQ2_R1(M29,NDIG,NDSAV1)
+ NDIG = NDSAV1
+ IF (M32(-1) > 0) THEN
+ CALL FMLN(M32,M16)
+ CALL FMMPY(M31,M16,M06)
+ CALL FMSUB(M06,M32,M16)
+ CALL FMEXP(M16,M24)
+ ELSE IF (KFLAGI == 0) THEN
+ CALL FMEXP(M32,M25)
+ CALL FMIPWR(M32,INTA,M16)
+ CALL FMDIV(M16,M25,M24)
+ ELSE
+ CALL FMABS(M32,M16)
+ CALL FMLN(M16,M17)
+ CALL FMMPY(M31,M17,M06)
+ CALL FMSUB(M06,M32,M16)
+ CALL FMEXP(M16,M24)
+ IF (MODA2 == 1) M24(-1) = -1
+ ENDIF
+
+ IF (M24(1) /= MEXPOV) THEN
+ CALL FMMPY(M24,M29,M25)
+ ELSE IF (M24(1)+M29(1) >= MXEXP2/2) THEN
+ CALL FMEQ(M24,M25)
+ IF (M29(-1) < 0 .AND. M25(1) /= MUNKNO .AND. &
+ M25(2) /= 0) M25(-1) = -M25(-1)
+ ELSE
+ CALL FMMPY(M24,M29,M25)
+ ENDIF
+ CALL FMSUB_R2(M30,M25)
+
+! Check for too much cancellation.
+
+ 160 IF (NCALL <= 1) THEN
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
+ ELSE
+ NGOAL = INT(-MXEXP2)
+ ENDIF
+ IF (M25(0) <= NGOAL) THEN
+ IF (NUMTRY > 0) THEN
+ NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
+ DO J = 1, NDGOAL+1
+ IF (MRETRY(J) /= M25(J)) GO TO 170
+ ENDDO
+ GO TO 180
+ ENDIF
+ 170 IEXTRA = INT(REAL(NGOAL-M25(0))/ALOGM2 + 23.03/ALOGMB) + 1
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDOLD
+ CALL FMST2M('UNKNOWN',M25)
+ GO TO 180
+ ENDIF
+ CALL FMEQ2_R1(M31,NDSAVE,NDIG)
+ CALL FMEQ2_R1(M32,NDSAVE,NDIG)
+ NUMTRY = NUMTRY + 1
+ CALL FMEQ2(M25,MRETRY,NDOLD,NDIG)
+ GO TO 110
+ ENDIF
+
+ 180 MACMAX = NINT(NDSAVE*ALOGM2)
+ M25(0) = MIN(M25(0),MACCA,MACCB,MACMAX)
+ CALL FMEXT2(M25,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMIGM1
+
+ SUBROUTINE FMIGM2(MA,MB,MC)
+
+! MC = Incomplete Gamma(MA,MB)
+
+! Integral from MB to infinity of e**(-t) * t**(MA-1) dt.
+
+! This is (upper case) Gamma(a,x).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK)
+ DOUBLE PRECISION FMDPLG,X,A,B,SMALL,BIG,TOL,T1,T2,BIGJ,C1,C2
+ REAL (KIND(1.0D0)) :: MACCA,MACCB,MACMAX,MAS,MAXM09,MBS,MODA2,MXSAVE
+ INTEGER IEXTRA,INTA,INTG,J,JCHECK,JEXTRA,JTERMS,K,KABIGR,KASAVE, &
+ KFLAGA,KFLAGI,KFLAGX,KFLGOK,KMETH4,KMID,KOVUN,KRESLT, &
+ KWRNSV,KXNEG,N,NDGOAL,NDIG2,NDOLD,NDSAV1,NDSAVE,NGOAL, &
+ NMETHD,NMNNDG,NMXDIF,NTERMS,NUMTRY
+ LOGICAL FMCOMP
+
+ CALL FMENT2('FMIGM2',MA,MB,2,1,MC,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+
+ KACCSW = 1
+ MAS = MA(-1)
+ MBS = MB(-1)
+ MACCA = MA(0)
+ MACCB = MB(0)
+ CALL FMEQ2(MA,M31,NDSAVE,NDIG)
+ M31(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ2(MB,M32,NDSAVE,NDIG)
+ M32(0) = NINT(NDIG*ALOGM2)
+ KMETH4 = 0
+ NUMTRY = 0
+
+ 110 NTERMS = INT(INTMAX/10)
+
+! A,X are double precision approximations to the two
+! arguments to this function.
+! INTA = A if A is a small integer. It is used to limit
+! the number of terms used in the asymptotic series
+! and in the continued fraction expansion.
+
+ INTA = NTERMS
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMM2I(M31,INTG)
+ KFLAGI = KFLAG
+ IF (KFLAG == 0) INTA = INTG
+ CALL FMM2DP(M31,A)
+ KFLAGA = KFLAG
+ IF (KFLAG /= 0 .AND. M31(1) < 0) THEN
+ A = 1.0D0/DPMAX
+ IF (M31(-1) < 0) A = -A
+ KFLAGA = 0
+ ENDIF
+ CALL FMM2DP(M32,X)
+ KFLAGX = KFLAG
+ IF (KFLAG /= 0 .AND. M32(1) < 0) THEN
+ X = 1.0D0/DPMAX
+ IF (M32(-1) < 0) X = -X
+ KFLAGX = 0
+ ENDIF
+ KWARN = KWRNSV
+
+! If A or X is large in magnitude use more guard digits.
+
+ IEXTRA = MIN(MAX(INT(M31(1)),INT(M32(1)),0) , &
+ INT(1.0+ALOGMX/ALOGMB))
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M31,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M32,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M25)
+ GO TO 190
+ ENDIF
+
+! KXNEG = 1 if X is negative and A is a positive integer.
+
+ KXNEG = 0
+
+! MODA2 = MOD(A,2) when KXNEG is 1.
+
+ MODA2 = 0
+
+! Check for special cases.
+
+ IF (M31(1) == MEXPOV .OR. M32(1) == MEXPOV) THEN
+ IF (M31(1) == MEXPOV .AND. M31(2) /= 0 .AND. &
+ M31(-1) > 0) THEN
+ IF (M32(1) /= MEXPOV) THEN
+ CALL FMST2M('OVERFLOW',M25)
+ KFLAG = -5
+ GO TO 170
+ ENDIF
+ ENDIF
+ IF (M32(1) == MEXPOV .AND. M32(2) /= 0 .AND. &
+ M32(-1) > 0) THEN
+ CALL FMBIG(M26)
+ M26(1) = MXSAVE + 1
+ CALL FMLN(M26,M16)
+ CALL FMDIV(M26,M16,M27)
+ IF (FMCOMP(M31,'<=',M27)) THEN
+ CALL FMST2M('UNDERFLOW',M25)
+ KFLAG = -6
+ GO TO 170
+ ELSE
+ CALL FMST2M('UNKNOWN',M25)
+ KFLAG = -4
+ GO TO 190
+ ENDIF
+ ENDIF
+ IF (M32(1) == MEXPOV .AND. M32(-1) < 0 .AND. &
+ M31(-1) > 0 .AND. M31(2) /= 0) THEN
+ IF (M31(1) /= MEXPOV) THEN
+ CALL FMINT(M31,M24)
+ IF (FMCOMP(M31,'==',M24)) THEN
+ CALL FMI2M(2,M21)
+ CALL FMMOD(M24,M21,M16)
+ CALL FMEQ(M16,M21)
+ IF (M21(2) /= 0) THEN
+ CALL FMST2M('OVERFLOW',M25)
+ KFLAG = -5
+ GO TO 170
+ ELSE
+ CALL FMST2M('-OVERFLOW',M25)
+ KFLAG = -5
+ GO TO 170
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ IF (M31(1) == MEXPOV .AND. M31(-1) < 0 .AND. &
+ M31(2) /= 0) THEN
+ IF (M32(1) /= MEXPOV .AND. M32(-1) > 0 .AND. &
+ M32(2) /= 0) THEN
+ CALL FMI2M(1,M16)
+ IF (FMCOMP(M32,'<',M16)) THEN
+ CALL FMST2M('OVERFLOW',M25)
+ KFLAG = -5
+ GO TO 170
+ ELSE
+ CALL FMST2M('UNDERFLOW',M25)
+ KFLAG = -6
+ GO TO 170
+ ENDIF
+ ENDIF
+ ENDIF
+ CALL FMST2M('UNKNOWN',M25)
+ KFLAG = -4
+ GO TO 190
+ ENDIF
+
+ IF (M31(1) == MEXPUN .OR. M32(1) == MEXPUN) THEN
+ IF (M31(1) == MEXPUN .AND. M32(1) == MEXPUN) THEN
+ CALL FMST2M('UNKNOWN',M25)
+ KFLAG = -4
+ GO TO 190
+ ENDIF
+ IF (M32(1) == MEXPUN .AND. M32(-1) > 0 .AND. &
+ M32(2) /= 0) THEN
+ IF (M31(1) >= 1) THEN
+ CALL FMGAM(M31,M30)
+ CALL FMEQ(M30,M25)
+ GO TO 170
+ ELSE
+ CALL FMST2M('UNKNOWN',M25)
+ KFLAG = -4
+ GO TO 190
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF (M32(2) == 0) THEN
+ IF (M31(-1) < 0 .OR. M31(2) == 0) THEN
+ CALL FMST2M('UNKNOWN',M25)
+ KFLAG = -4
+ GO TO 190
+ ELSE
+ CALL FMGAM(M31,M30)
+ CALL FMEQ(M30,M25)
+ GO TO 170
+ ENDIF
+ ENDIF
+ IF (M32(-1) < 0) THEN
+ CALL FMINT(M31,M24)
+ IF (FMCOMP(M31,'==',M24) .AND. M31(-1)*M31(2) > 0) THEN
+ KXNEG = 1
+ CALL FMI2M(2,M21)
+ CALL FMMOD(M24,M21,M16)
+ CALL FMEQ(M16,M21)
+ IF (M21(2) /= 0) MODA2 = 1
+ ELSE
+ CALL FMST2M('UNKNOWN',M25)
+ KFLAG = -4
+ GO TO 190
+ ENDIF
+ ENDIF
+ IF (M32(1) == MEXPUN) THEN
+ CALL FMGAM(M31,M30)
+ CALL FMEQ(M30,M25)
+ GO TO 170
+ ENDIF
+ IF (M31(1) == MEXPUN) THEN
+ CALL FMI2M(0,M31)
+ MAS = 1
+ ENDIF
+ CALL FMMAX(M31,M32,M16)
+ CALL FMMIN(M31,M32,M17)
+ CALL FMDPM(1.0D6,M05)
+ CALL FMDPM(1.0D2,M06)
+ IF (FMCOMP(M16,'>=',M05) .AND. FMCOMP(M17,'>=',M06)) THEN
+ CALL FMI2M(1,M16)
+ CALL FMSUB(M31,M16,M18)
+ CALL FMMAX(M18,M32,M20)
+ CALL FMADDI(M20,1)
+ CALL FMLN(M20,M16)
+ CALL FMMPY(M18,M16,M06)
+ CALL FMSUB(M06,M20,M16)
+ CALL FMEXP(M16,M22)
+ IF ((M22(1) == MEXPOV .AND. M22(-1) > 0 .AND. &
+ M22(2) /= 0) .OR. M22(1) > MXSAVE+1) THEN
+ CALL FMST2M('OVERFLOW',M25)
+ KFLAG = -5
+ GO TO 170
+ ENDIF
+ ENDIF
+! Determine which method to use.
+
+! NMETHD = 1 means use the convergent series,
+! = 2 means use the asymptotic series,
+! = 3 means use the continued fraction expansion,
+! = 4 means use an O(A**2) formula.
+
+ CALL FMI2M(-10000,M20)
+ CALL FMI2M(10000,M21)
+ CALL FMABS(M31,M23)
+ CALL FMABS(M32,M24)
+ CALL FMSUB(M24,M23,M22)
+ KABIGR = 1
+ IF (M22(2) >= 0 .AND. M22(-1) > 0) KABIGR = 0
+ NMETHD = 0
+ IF (FMCOMP(M22,'<=',M20)) THEN
+ IF (M31(-1) > 0 .AND. M31(2) /= 0) THEN
+ NMETHD = 1
+ ELSE
+ NMETHD = 3
+ ENDIF
+ ELSE IF (FMCOMP(M22,'>=',M21) .AND. M31(-1) > 0 .AND. &
+ M31(2) > 0 .AND. M32(-1) > 0 .AND. &
+ M32(2) > 0) THEN
+ NMETHD = 2
+ ELSE IF (FMCOMP(M22,'>=',M21)) THEN
+ NMETHD = 3
+ ELSE IF (M31(-1) > 0 .AND. M32(-1) > 0 .AND. &
+ M32(2) > 0) THEN
+ CALL FMDP2M(SQRT(DPMAX),M20)
+ IF (FMCOMP(M32,'>=',M20)) THEN
+ KFLAG = -5
+ CALL FMST2M('OVERFLOW',M25)
+ GO TO 170
+ ENDIF
+
+ IF (M31(-1) > 0 .AND. M31(2) /= 0) THEN
+ C2 = DBLE(NDSAVE)*DLOGMB/6.0D0
+ C1 = MAX( 10.0D0 , C2 , A )
+ C2 = MAX( 10.0D0 , C2 , A - 6.5D0*A/(SQRT(A)+1.0D0) )
+ ELSE
+ C1 = MAX( 15.0D0 , DBLE(NDSAVE)*DLOGMB/5.0D0 )
+ C2 = C1
+ ENDIF
+ IF (X < MIN(C1,C2)) THEN
+ IF (-2*M31(1) > NDIG .OR. M31(2) == 0) THEN
+ NMETHD = 4
+ ELSE
+ NMETHD = 1
+ ENDIF
+ ELSE IF (X > C2) THEN
+
+! Check that the smallest term in the asymptotic series is
+! small enough to give the required accuracy.
+
+ T1 = FMDPLG(A)
+ SMALL = T1 - FMDPLG(-ABS(X)) - (A+ABS(X))*LOG(ABS(X))
+ TOL = -DBLE(NDIG+2)*DLOGMB - 12.0D0
+ B = 1.0D0
+ IF (A > ABS(X)) B = A - ABS(X)
+ BIG = T1 - FMDPLG(A-B) - B*LOG(ABS(X))
+ IF (SMALL < TOL+BIG) NMETHD = 2
+ ENDIF
+ IF (NMETHD == 0 .AND. X > C1) NMETHD = 3
+ IF (NMETHD == 0) NMETHD = 1
+ ELSE IF (M31(-1) < 0 .AND. M32(-1) > 0 .AND. &
+ M32(2) > 0) THEN
+ CALL FMDP2M(SQRT(DPMAX),M20)
+ IF (FMCOMP(M32,'>=',M20)) THEN
+ KFLAG = -6
+ CALL FMST2M('UNDERFLOW',M25)
+ GO TO 170
+ ENDIF
+
+ C1 = MAX( 10.0D0 , DBLE(NDSAVE)*DLOGMB/7.0D0 )
+ C2 = -2.0D0*A
+ IF (X < C1) THEN
+ IF (-2*M31(1) > NDIG) THEN
+ NMETHD = 4
+ ELSE
+ NMETHD = 1
+ ENDIF
+ ELSE IF (X > C2) THEN
+ T1 = FMDPLG(A)
+ SMALL = T1 - FMDPLG(-ABS(X)) - (A+ABS(X))*LOG(ABS(X))
+ TOL = -DBLE(NDIG+2)*DLOGMB - 12.0D0
+ B = 1.0D0
+ IF (A > ABS(X)) B = A - ABS(X)
+ BIG = T1 - FMDPLG(A-B) - B*LOG(ABS(X))
+ IF (SMALL < TOL+BIG) NMETHD = 2
+ ENDIF
+ IF (NMETHD == 0 .AND. X > C1) NMETHD = 3
+ IF (NMETHD == 0) NMETHD = 1
+ ELSE IF (M31(-1) > 0 .AND. M31(2) > 0 .AND. &
+ M32(-1) < 0) THEN
+ CALL FMEQ(M32,M20)
+ IF (M20(1) /= MUNKNO .AND. M20(2) /= 0) M20(-1) = -M20(-1)
+ CALL FMMPYI(M31,2,M21)
+ IF (FMCOMP(M20,'<',M31)) THEN
+ NMETHD = 1
+ ELSE IF (FMCOMP(M20,'<',M21)) THEN
+ NMETHD = 3
+ ELSE
+ NMETHD = 2
+ ENDIF
+ ENDIF
+
+ IF (NMETHD == 2) GO TO 130
+ IF (NMETHD == 3) GO TO 150
+ IF (NMETHD == 4) GO TO 160
+
+! Method 1. Use the X**N/Pochhammer(A+1,N) series.
+
+! M25 is the current sum.
+! M21 is the current term.
+! M20 is (A+N)/X.
+! M29 is 1/X
+
+! Raise the precision if A is negative and near an integer,
+! to compensate for cancellation when (A+N)/X is near zero.
+! Raise the precision if A is positive and near zero, since
+! there will be cancellation in subtracting the sum from
+! Gamma(A).
+! If A is a negative integer use method 3 or 4.
+
+ IEXTRA = 0
+ IF (M31(-1) < 0) THEN
+ IF (KFLAGA == 0) THEN
+ IF (ABS(A) > 1.0D3) THEN
+ NMETHD = 3
+ GO TO 150
+ ENDIF
+ ELSE
+ NMETHD = 3
+ GO TO 150
+ ENDIF
+ CALL FMNINT(M31,M25)
+ IF (FMCOMP(M25,'==',M31)) THEN
+ IF (KFLAGI == 0) THEN
+ IF (KFLAGX /= 0) THEN
+ GO TO 150
+ ELSE
+ IF (ABS(X) <= 20.0D0) THEN
+ C1 = 0.7D0*(DBLE(NDSAVE)*DLOGMB* &
+ (20.0D0-X))**0.75D0
+ IF (ABS(A) > C1) THEN
+ GO TO 150
+ ELSE
+ GO TO 160
+ ENDIF
+ ELSE
+ GO TO 150
+ ENDIF
+ ENDIF
+ ELSE
+ GO TO 150
+ ENDIF
+ ENDIF
+ CALL FMSUB(M31,M25,M29)
+ IEXTRA = MAX(-2*INT(M29(1)),-INT(M31(1))+1,0)
+ ELSE
+ IEXTRA = MAX(-INT(M31(1))+1,0)
+ ENDIF
+
+! Raise the precision further as X increases in magnitude.
+
+ IF (KFLAGX == 0 .AND. KFLAGA == 0) THEN
+ T1 = (0.92D0 + (X-A) + (A-0.5D0)*LOG(ABS(A)+1.0D-10) - &
+ (A-1.0D0)*LOG(ABS(X)+1.0D-10))/DLOGMB
+ IF (T1 > 0 .AND. ABS(X) > 1.0D0) THEN
+ IF (A < 0.0D0 .OR. X >= A) THEN
+ IEXTRA = IEXTRA + MAX(0,INT(T1)+1)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M31,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M32,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M25)
+ GO TO 190
+ ENDIF
+
+ JEXTRA = 0
+
+ 120 IF (KABIGR == 1) THEN
+ CALL FMGAM(M31,M30)
+ IF (KFLAG /= 0) THEN
+ CALL FMEQ(M30,M25)
+ GO TO 170
+ ENDIF
+ CALL FMEQ(M30,M25)
+ ELSE
+ CALL FMI2M(0,M25)
+ ENDIF
+
+ MAXM09 = M25(1)
+
+ CALL FMABS(M32,M29)
+ CALL FMLN(M29,M13)
+ CALL FMEQ(M13,M29)
+ CALL FMMPY_R2(M31,M29)
+ CALL FMSUB_R1(M29,M32)
+ CALL FMEXP(M29,M30)
+ CALL FMDIV(M30,M31,M21)
+ IF (M21(1) == MUNKNO) THEN
+ CALL FMLN(M31,M24)
+ CALL FMSUB_R1(M29,M24)
+ CALL FMEXP(M29,M21)
+ ENDIF
+ IF (KXNEG == 1 .AND. MODA2 == 1 .AND. M21(1) /= MUNKNO .AND. &
+ M21(2) /= 0) THEN
+ M21(-1) = -M21(-1)
+ ENDIF
+
+ IF (M21(1) /= MUNKNO .AND. M21(2) /= 0) THEN
+ M21(-1) = -M21(-1)
+ ENDIF
+ CALL FMADD_R1(M25,M21)
+ MAXM09 = MAX(MAXM09,M25(1))
+
+ CALL FMI2M(1,M18)
+ CALL FMADD(M31,M18,M20)
+ CALL FMDIV_R1(M21,M20)
+ CALL FMMPY_R1(M21,M32)
+ CALL FMDIV_R1(M20,M32)
+ CALL FMDIV(M18,M32,M29)
+ NDSAV1 = NDIG
+
+! If A is negative and ABS(A) > ABS(X), the terms in the
+! series first decrease, then increase, then decrease.
+! Try to predict the number of extra digits required to
+! keep the precision from prematurely becoming too small.
+
+ KFLGOK = 1
+ IF (M31(-1) < 0) THEN
+ KFLGOK = 0
+ M31(-1) = 1
+ M32(-1) = 1
+ IF (FMCOMP(M31,'>',M32)) THEN
+ IF (JEXTRA == 0) THEN
+ IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
+ T1 = FMDPLG(A+AINT(-ABS(X)-A)) - &
+ FMDPLG(A+1.0D0+AINT(ABS(X)-A))
+ T1 = (T1 + 2.0D0*ABS(X)*LOG(ABS(X)+1.0D-10))/ &
+ DLOGMB
+ T1 = MAX(0.0D0,T1+1.0D0)
+ JEXTRA = INT(MIN(DBLE(NDIGMX),T1))
+ ENDIF
+ ENDIF
+
+! If A is negative and ABS(A) is much bigger than ABS(X),
+! then the later increase in the size of the terms can be
+! ignored.
+
+ IF (KFLAGA == 0 .AND. KFLAGX == 0) THEN
+ T1 = (AINT(X-A)*LOG(ABS(X)+1.0D-10) + FMDPLG(A+1.0D0) &
+ - FMDPLG(A+1.0D0+AINT(X-A))) / DLOGMB
+ IF (T1 < -DBLE(NDIG)) KFLGOK = 1
+ ELSE
+ KFLGOK = 1
+ ENDIF
+ ENDIF
+ M31(-1) = MAS
+ M32(-1) = MBS
+ ENDIF
+
+ NMNNDG = NDSAV1
+ NMXDIF = 0
+
+! Method 1 summation loop.
+
+ DO J = 1, NTERMS
+ NDIG = NDSAV1
+ CALL FMADD_R1(M25,M21)
+ MAXM09 = MAX(MAXM09,M25(1))
+ IF (KFLAG /= 0) THEN
+ IF (KFLGOK == 0 .AND. KFLAGA == 0 .AND. KFLAGX == 0) THEN
+ IF (DBLE(J) > X-A) EXIT
+ ELSE
+ EXIT
+ ENDIF
+ ENDIF
+
+ CALL FMADD_R1(M20,M29)
+
+ NDIG2 = MAX(2,NDSAV1-INT(M25(1)-M21(1)))
+ NDIG = MIN(NDSAV1,NDIG2+JEXTRA)
+ NMNNDG = MIN(NMNNDG,NDIG)
+ NMXDIF = MAX(NMXDIF,NDIG-NMNNDG)
+ CALL FMDIV_R1(M21,M20)
+ ENDDO
+
+ NDIG = NDSAV1
+ IF (KABIGR == 0) THEN
+ CALL FMEQ(M25,M29)
+ CALL FMGAM(M31,M30)
+ IF (KFLAG /= 0) THEN
+ CALL FMEQ(M30,M25)
+ GO TO 170
+ ENDIF
+ CALL FMADD(M30,M29,M25)
+ ENDIF
+
+! If too much cancellation occurred, raise the precision
+! and do the calculation again.
+
+ IEXTRA = NDIG - NDSAVE
+ IF (INT(MAXM09-M25(1)) >= IEXTRA-NGRD52/2) THEN
+ IEXTRA = IEXTRA + NGRD52
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M31,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M32,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M25)
+ GO TO 190
+ ENDIF
+ GO TO 120
+ ENDIF
+
+ GO TO 170
+
+! Method 2. Use the Pochhammer(A-N,N)/X**N series.
+
+! M25 is the current sum.
+! M21 is the current term.
+! M20 is (A-N)/X.
+! M29 is -1/X
+
+ 130 CALL FMABS(M32,M29)
+ CALL FMLN(M29,M13)
+ CALL FMEQ(M13,M29)
+ CALL FMMPY(M31,M29,M25)
+ CALL FMSUB_R2(M25,M29)
+ CALL FMSUB_R1(M29,M32)
+ CALL FMEXP(M29,M21)
+ IF (KXNEG == 1 .AND. MODA2 == 0 .AND. M21(1) /= MUNKNO .AND. &
+ M21(2) /= 0) M21(-1) = -M21(-1)
+ IF (ABS(M21(1)) >= MXEXP2) THEN
+ CALL FMEQ(M21,M25)
+ GO TO 170
+ ENDIF
+
+! Here M21 is X**(A-1)/EXP(X).
+
+ CALL FMI2M(0,M25)
+ CALL FMEQ(M31,M20)
+ CALL FMDIV_R1(M20,M32)
+ CALL FMI2M(1,M18)
+ CALL FMDIV(M18,M32,M29)
+ IF (M29(1) /= MUNKNO .AND. M29(2) /= 0) M29(-1) = -M29(-1)
+ NDSAV1 = NDIG
+
+! Disable NDIG reduction until the terms in the sum
+! begin to decrease in size.
+
+ BIGJ = 0
+ IF (KFLAGA == 0 .AND. KFLAGX == 0) BIGJ = ABS(A) - ABS(X)
+ JTERMS = NTERMS
+ IF (KFLAGI == 0 .AND. INTA > 0) THEN
+ JTERMS = INTA
+ ELSE IF (KFLAGX == 0) THEN
+ IF (KFLAGA == 0) THEN
+ T1 = A + ABS(X)
+ IF (T1 > 0 .AND. T1 < DBLE(NTERMS)) JTERMS = INT(T1) + 2
+ ELSE IF (M31(1) < 0) THEN
+ T1 = ABS(X)
+ IF (T1 > 0 .AND. T1 < DBLE(NTERMS)) JTERMS = INT(T1) + 2
+ ENDIF
+ ENDIF
+
+! Method 2 summation loop.
+
+ DO J = 1, JTERMS
+ NDIG = NDSAV1
+ CALL FMADD_R1(M25,M21)
+ IF (KFLAG /= 0 .AND. J > 1) GO TO 140
+ CALL FMADD_R1(M20,M29)
+ IF (REAL(J) >= BIGJ) THEN
+ NDIG2 = MAX(2,NDSAV1-INT(M25(1)-M21(1)))
+ NDIG = MIN(NDSAV1,NDIG2)
+ ENDIF
+ CALL FMMPY_R1(M21,M20)
+ ENDDO
+
+ 140 NDIG = NDSAV1
+ GO TO 170
+
+! Method 3. Use the continued fraction expansion.
+
+! M29 is the current approximation.
+! M25 is the previous approximation.
+! M21, M22 are the latest numerators.
+! M23, M24 are the latest denominators.
+
+! Raise the precision so that convergence of the
+! continued fraction expansion is easier to detect.
+
+ 150 JEXTRA = INT(MAX(1.0,5.76/ALOGMB + 1.0))
+
+! Raise the precision further for small X if A is positive.
+
+ IF (KFLAGX == 0 .AND. KFLAGA == 0) THEN
+ T1 = (0.92D0 + (ABS(X)-A) + (A-0.5D0)*LOG(ABS(A)+1.0D-10) - &
+ (A-1.0D0)*LOG(ABS(X)+1.0D-10))/DLOGMB
+ IF (T1 > 0.0D0 .AND. A > 0.0D0) THEN
+ IF (ABS(X) < A) THEN
+ JEXTRA = JEXTRA + MAX(0,INT(1.5D0*T1)+1)
+ IF (NDIG+JEXTRA > NDG2MX) THEN
+ NDIG = NDIG + JEXTRA
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - JEXTRA
+ CALL FMST2M('UNKNOWN',M25)
+ GO TO 190
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ NDSAV1 = NDIG
+ IF (NDIG+JEXTRA > NDG2MX) JEXTRA = NDG2MX - NDIG
+ IF (NDIG+JEXTRA > NDSAV1) THEN
+ CALL FMEQ2_R1(M31,NDSAV1,NDSAV1+JEXTRA)
+ CALL FMEQ2_R1(M32,NDSAV1,NDSAV1+JEXTRA)
+ ENDIF
+ NDIG = NDIG + JEXTRA
+ CALL FMI2M(0,M21)
+ CALL FMI2M(1,M22)
+ CALL FMI2M(1,M23)
+ CALL FMEQ2(M32,M24,NDSAV1,NDIG)
+ CALL FMI2M(0,M29)
+ CALL FMEQ2(M31,M20,NDSAV1,NDIG)
+ IF (M20(1) /= MUNKNO .AND. M20(2) /= 0) M20(-1) = -M20(-1)
+ CALL FMI2M(1,M19)
+
+ JTERMS = NTERMS
+ JCHECK = 10
+ IF (INTA == 1) CALL FMDIV(M22,M32,M29)
+ IF (INTA > 0) JTERMS = INTA - 1
+
+! Method 3 continued fraction loop.
+
+ METHOD3: DO J = 1, JTERMS
+ CALL FMADD_R1(M20,M19)
+ CALL FMMPY_R2(M20,M21)
+ CALL FMADD_R2(M22,M21)
+ CALL FMMPY_R2(M20,M23)
+ CALL FMADD_R2(M24,M23)
+ CALL FMMPYI_R1(M22,J)
+ CALL FMMPY(M32,M21,M30)
+ CALL FMADD_R2(M30,M22)
+ CALL FMMPYI_R1(M24,J)
+ CALL FMMPY(M32,M23,M30)
+ CALL FMADD_R2(M30,M24)
+
+! Normalize to make overflow or underflow less likely.
+
+ KMID = INT((MAX(M21(1),M22(1),M23(1),M24(1)) + &
+ MIN(M21(1),M22(1),M23(1),M24(1))) / 2)
+ M21(1) = M21(1) - KMID
+ M22(1) = M22(1) - KMID
+ M23(1) = M23(1) - KMID
+ M24(1) = M24(1) - KMID
+
+! Form the quotient and check for convergence.
+
+ IF (MOD(J,JCHECK) == 0 .OR. J == INTA-1) THEN
+ CALL FMEQ(M29,M25)
+ CALL FMDIV(M22,M24,M29)
+ DO K = NDIG-JEXTRA, 1, -1
+ IF (M25(K) /= M29(K)) CYCLE METHOD3
+ ENDDO
+ EXIT
+ ENDIF
+ ENDDO METHOD3
+
+ CALL FMEQ2_R1(M29,NDIG,NDSAV1)
+ NDIG = NDSAV1
+ CALL FMABS(M32,M24)
+ CALL FMLN(M24,M13)
+ CALL FMEQ(M13,M24)
+ CALL FMMPY_R2(M31,M24)
+ CALL FMSUB_R1(M24,M32)
+ CALL FMEXP(M24,M12)
+ CALL FMEQ(M12,M24)
+ IF (KXNEG == 1 .AND. MODA2 == 1 .AND. M24(1) /= MUNKNO .AND. &
+ M24(2) /= 0) M24(-1) = -M24(-1)
+ IF (ABS(M24(1)) >= MXEXP2) THEN
+ CALL FMEQ(M24,M25)
+ IF (M29(-1) < 0 .AND. M25(1) /= MUNKNO .AND. &
+ M25(2) /= 0) M25(-1) = -M25(-1)
+ GO TO 170
+ ENDIF
+
+ CALL FMMPY(M24,M29,M25)
+ GO TO 170
+
+! Method 4. Use the O(A**2) formula when A is small.
+
+! M25 is the current term.
+! M29 is the current sum.
+
+! Raise the precision if X is larger than A
+! in magnitude. The terms initially increase in size,
+! and the final sum is small.
+
+ 160 IEXTRA = 0
+
+! If A is a negative integer, replace it by zero and later
+! use a recurrence to recover the original function value.
+
+ IF (KFLAGI == 0 .AND. INTA < 0) THEN
+ CALL FMI2M(0,M31)
+ A = 0.0D0
+ KMETH4 = 1
+ ENDIF
+
+ IF (KFLAGX == 0) THEN
+ IF (KFLAGA == 0) THEN
+ T1 = ABS(X) - ABS(A)
+ ELSE
+ T1 = ABS(X)
+ ENDIF
+ IF (T1 > 0) THEN
+ T2 = (T1 + LOG(T1))/DLOGMB
+ IF (T2 > DBLE(MXEXP2/10)) T2 = DBLE(MXEXP2/10)
+ IEXTRA = INT(MAX(0.0D0,T2))
+ ENDIF
+ T1 = ABS(X)+1.0D-10
+ T2 = (T1 - 0.5D0*LOG(6.2831853D0*T1))/DLOGMB
+ IF (T2 > DBLE(MXEXP2/10)) T2 = DBLE(MXEXP2/10)
+ IEXTRA = IEXTRA + INT(MAX(0.0D0,T2))
+ ENDIF
+
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M31,NDIG,NDIG+IEXTRA)
+ CALL FMEQ2_R1(M32,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M25)
+ GO TO 190
+ ENDIF
+
+ CALL FMEULR(M29)
+ CALL FMEQ(M29,M30)
+ M29(-1) = -1
+ CALL FMABS(M32,M25)
+ CALL FMLN(M25,M24)
+ CALL FMSUB_R1(M29,M24)
+ IF (M31(2) /= 0 .AND. M31(1) >= -NDIG-1) THEN
+ CALL FMSQR(M24,M16)
+ CALL FMMPY(M16,M31,M06)
+ CALL FMDIVI(M06,2,M25)
+ CALL FMSUB_R1(M29,M25)
+ CALL FMSQR(M30,M23)
+ CALL FMPI(M22)
+ CALL FMSQR(M22,M16)
+ CALL FMDIVI(M16,6,M22)
+ CALL FMADD(M22,M23,M16)
+ CALL FMMPY(M16,M31,M06)
+ CALL FMDIVI(M06,2,M23)
+ CALL FMADD_R1(M29,M23)
+ ENDIF
+
+ NDSAV1 = NDIG
+ CALL FMI2M(1,M23)
+ CALL FMADD(M31,M23,M22)
+ IF (FMCOMP(M23,'==',M22)) THEN
+ CALL FMI2M(-1,M25)
+ DO J = 1, NTERMS
+ NDIG2 = MAX(2,NDSAV1-INT(M29(1)-M25(1)))
+ NDIG = MIN(NDSAV1,NDIG2)
+ CALL FMMPY_R1(M25,M32)
+ IF (M25(1) /= MUNKNO .AND. M25(2) /= 0) M25(-1) = -M25(-1)
+ CALL FMDIVI_R1(M25,J)
+ CALL FMDIVI(M25,J,M24)
+ NDIG = NDSAV1
+ CALL FMADD_R1(M29,M24)
+ IF (KFLAG /= 0) EXIT
+ ENDDO
+ ELSE
+ CALL FMPWR(M32,M31,M25)
+ IF (M25(1) /= MUNKNO .AND. M25(2) /= 0) M25(-1) = -M25(-1)
+ CALL FMEQ(M31,M30)
+ DO J = 1, NTERMS
+ NDIG2 = MAX(2,NDSAV1-INT(M29(1)-M25(1)))
+ NDIG = MIN(NDSAV1,NDIG2)
+ CALL FMMPY_R1(M25,M32)
+ IF (M25(1) /= MUNKNO .AND. M25(2) /= 0) M25(-1) = -M25(-1)
+ CALL FMDIVI_R1(M25,J)
+ NDIG = NDSAV1
+ CALL FMADD_R1(M30,M23)
+ NDIG = MIN(NDSAV1,NDIG2)
+ CALL FMDIV(M25,M30,M24)
+ NDIG = NDSAV1
+ CALL FMADD_R1(M29,M24)
+ IF (KFLAG /= 0) EXIT
+ ENDDO
+ ENDIF
+ CALL FMEQ(M29,M25)
+
+! Use the recurrence relation if A was a negative integer.
+
+ IF (KFLAGI == 0 .AND. INTA < 0) THEN
+ N = -INTA
+ CALL FMI2M(1,M29)
+ CALL FMDIV_R1(M29,M32)
+ CALL FMEQ(M29,M24)
+ CALL FMEQ(M29,M23)
+ DO J = 1, N-1
+ CALL FMMPYI_R1(M24,J)
+ CALL FMMPY_R1(M24,M23)
+ IF (M24(1) /= MUNKNO .AND. M24(2) /= 0) M24(-1) = -M24(-1)
+ CALL FMADD_R1(M29,M24)
+ ENDDO
+ CALL FMEXP(M32,M23)
+ CALL FMDIV_R1(M29,M23)
+ CALL FMSUB_R1(M25,M29)
+ CALL FMFCTI(N,M23)
+ CALL FMDIV_R1(M25,M23)
+ IF (MOD(N,2) == 1 .AND. M25(1) /= MUNKNO .AND. &
+ M25(2) /= 0) M25(-1) = -M25(-1)
+ ENDIF
+
+! Check for too much cancellation.
+
+ 170 IF (NCALL <= 1) THEN
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
+ ELSE
+ NGOAL = INT(-MXEXP2)
+ ENDIF
+ IF (M25(0) <= NGOAL) THEN
+ IF (NUMTRY > 0) THEN
+ NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
+ DO J = 1, NDGOAL+1
+ IF (MRETRY(J) /= M25(J)) GO TO 180
+ ENDDO
+ GO TO 190
+ ENDIF
+ 180 IEXTRA = INT(REAL(NGOAL-M25(0))/ALOGM2 + 23.03/ALOGMB) + 1
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M25)
+ GO TO 190
+ ENDIF
+ CALL FMEQ2_R1(M31,NDSAVE,NDIG)
+ IF (KMETH4 == 1) THEN
+ CALL FMI2M(INTA,M31)
+ ENDIF
+ CALL FMEQ2_R1(M32,NDSAVE,NDIG)
+ NUMTRY = NUMTRY + 1
+ CALL FMEQ2(M25,MRETRY,NDOLD,NDIG)
+ GO TO 110
+ ENDIF
+
+ 190 MACMAX = NINT(NDSAVE*ALOGM2)
+ M25(0) = MIN(M25(0),MACCA,MACCB,MACMAX)
+ CALL FMEXT2(M25,MC,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMIGM2
+
+ SUBROUTINE FMLNGM(MA,MB)
+
+! MB = LN(GAMMA(MA))
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MAS,MXSAVE
+ INTEGER IEXTRA,INTA,J,J2,K,K0,K1,K2,KASAVE,KFL,KOVUN,KPT,KRESLT, &
+ KRSAVE,KSIGN,KWRNSV,LSHIFT,NDENOM,NDGOAL,NDIG2,NDMB,NDOLD, &
+ NDSAV1,NDSAVE,NDSV,NGOAL,NMXDIF,NTERM,NUMTRY
+ LOGICAL FMCOMP
+ CHARACTER(155) :: STRING
+
+ CALL FMENT2('FMLNGM',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ MAS = MA(-1)
+ KACCSW = 1
+ MACCA = MA(0)
+ CALL FMEQ2(MA,M25,NDSAVE,NDIG)
+ M25(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ(M25,M26)
+ NUMTRY = 0
+
+! Near zero Gamma(x) is about 1/x.
+
+ 110 IF (M26(1) < (-NDIG-3)) THEN
+ CALL FMLN(M26,M22)
+ IF (M22(1) /= MUNKNO .AND. M22(2) /= 0) M22(-1) = -M22(-1)
+ GO TO 140
+ ENDIF
+
+! Check for special cases.
+
+ IF (MAS < 0) THEN
+ KFL = 0
+ IF (M25(1) <= NDSAVE) THEN
+ CALL FMINT(M26,M21)
+ IF (FMCOMP(M26,'==',M21)) KFL = -4
+ CALL FMI2M(2,M22)
+ M21(-1) = 1
+ CALL FMMOD(M21,M22,M16)
+ CALL FMEQ(M16,M22)
+ IF (M22(2) == 0) KFL = -4
+ ELSE
+ KFL = -4
+ ENDIF
+ IF (KFL /= 0) THEN
+ CALL FMST2M('UNKNOWN',M22)
+ KFLAG = -4
+ GO TO 160
+ ELSE
+ CALL FMI2M(1,M16)
+ CALL FMSUB_R2(M16,M26)
+ ENDIF
+ ENDIF
+
+! To speed the asymptotic series calculation, increase
+! the argument by LSHIFT.
+
+ IEXTRA = 0
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMM2I(M26,INTA)
+ KWARN = KWRNSV
+
+ IF (KFLAG == -4) THEN
+ LSHIFT = 0
+ ELSE
+ LSHIFT = INT(MAX(0.0,REAL(NDIG)*ALOGMB/4.46-REAL(INTA)))
+ ENDIF
+ IF (LSHIFT > 0) LSHIFT = 4*(LSHIFT/4 + 1)
+ IF (KFLAG == 0) THEN
+ IF (LSHIFT > 0 .OR. INTA <= 10) THEN
+ IF (INTA <= 2) THEN
+ CALL FMI2M(0,M22)
+ GO TO 140
+ ENDIF
+ INTA = INTA - 1
+ CALL FMFCTI(INTA,M26)
+ CALL FMLN(M26,M22)
+ GO TO 140
+ ENDIF
+ ENDIF
+
+ IF (LSHIFT /= 0) THEN
+ CALL FMI2M(LSHIFT,M16)
+ CALL FMADD(M26,M16,M24)
+ ELSE
+ CALL FMEQ(M26,M24)
+ ENDIF
+
+! Sum the asymptotic series.
+
+! M26 is Z
+! M24 is Z + LSHIFT
+! M21 is X**J2 = (1/(Z+LSHIFT)**2)**J2
+! M22 is the current power of X
+! M23 is the current term in the sum
+! MJSUMS is the partial sum
+
+ J2 = INT(0.3*ALOGMB + 0.2*SQRT(REAL(NDIG)))
+ J2 = MAX(1,MIN(LJSUMS/(LUNPCK+3),J2))
+ NDSAV1 = NDIG
+ CALL FMI2M(1,M22)
+ J = -2*J2
+ CALL FMIPWR(M24,J,M21)
+ IF (ABS(M21(1)) >= MEXPAB) THEN
+ J2 = 1
+ CALL FMIPWR(M24,-2,M21)
+ ENDIF
+ DO J = 1, J2
+ NTERM = 2*J
+ CALL FMBERN(NTERM,M22,M23)
+ IF (KFLAG == -11) THEN
+ CALL FMST2M('UNKNOWN',M22)
+ KFLAG = -4
+ GO TO 160
+ ENDIF
+ NDENOM = NTERM*(NTERM-1)
+ KPT = (J-1)*(NDSAV1+3)
+ CALL FMDIVI(M23,NDENOM,MJSUMS(KPT-1))
+ ENDDO
+
+ NDIG2 = NDIG
+ 120 CALL FMMPY_R1(M22,M21)
+ NMXDIF = 2
+ DO J = 1, J2
+ NTERM = NTERM + 2
+ CALL FMBERN(NTERM,M22,M23)
+ IF (KFLAG == -11) THEN
+ CALL FMST2M('UNKNOWN',M22)
+ KFLAG = -4
+ GO TO 160
+ ENDIF
+ NDENOM = NTERM*(NTERM-1)
+ IF (NDENOM <= MXBASE) THEN
+ CALL FMDIVI_R1(M23,NDENOM)
+ ELSE
+ CALL FMDIVI_R1(M23,NTERM)
+ NDENOM = NTERM - 1
+ CALL FMDIVI_R1(M23,NDENOM)
+ ENDIF
+ NDIG = NDSAV1
+ KPT = (J-1)*(NDSAV1+3)
+ CALL FMADD_R1(MJSUMS(KPT-1),M23)
+ NMXDIF = MAX(NMXDIF,NDSAV1-INT(MJSUMS(KPT+1)-M23(1)))
+ NDIG = NDIG2
+ IF (KFLAG /= 0) GO TO 130
+ ENDDO
+ NDIG2 = NMXDIF
+ NDIG = NDIG2
+ GO TO 120
+
+! Put the J2 concurrent sums back together.
+
+ 130 NDIG = NDSAV1
+ IF (J2 > 1) THEN
+ KPT = (J2-1)*(NDSAV1+3)
+ CALL FMSQR(M24,M23)
+ CALL FMI2M(1,M16)
+ CALL FMDIV_R2(M16,M23)
+ CALL FMEQ(MJSUMS(KPT-1),M21)
+ DO J = J2-1, 1, -1
+ CALL FMMPY_R1(M21,M23)
+ KPT = (J-1)*(NDSAV1+3)
+ CALL FMADD_R1(M21,MJSUMS(KPT-1))
+ ENDDO
+ CALL FMEQ(M21,MJSUMS)
+ ENDIF
+
+! Add the log terms to the asymptotic series.
+
+! M22 is the current sum as the log terms are added
+! M23 is now LN(Z+LSHIFT)
+
+ CALL FMDIV(MJSUMS,M24,M22)
+ CALL FMLN(M24,M23)
+ IF (MBASE /= MBS2PI .OR. NDIG > NDG2PI) THEN
+ NDMB = INT(150.0*2.302585/ALOGMB)
+ IF (NDMB >= NDIG) THEN
+ NDSV = NDIG
+ NDIG = MIN(NDMB,NDG2MX)
+ STRING = '1.837877066409345483560659472811235279722794'// &
+ '94727556682563430308096553139185452079538948659727190'// &
+ '8395244011293249268674892733725763681587144311751830445'
+ CALL FMST2M(STRING,M_LN_2PI)
+ M_LN_2PI(0) = NINT(NDIG*ALOGM2)
+ MBS2PI = MBASE
+ NDG2PI = NDIG
+ IF (ABS(M_LN_2PI(1)) > 10) NDG2PI = 0
+ NDIG = NDSV
+ ELSE
+ NDSV = NDIG
+ NDIG = MIN(NDIG+2,NDG2MX)
+ CALL FMPI(M21)
+ CALL FMMPYI(M21,2,M16)
+ CALL FMLN(M16,M_LN_2PI)
+ MBS2PI = MBASE
+ NDG2PI = NDIG
+ IF (ABS(M_LN_2PI(1)) > 10) NDG2PI = 0
+ NDIG = NDSV
+ ENDIF
+ ENDIF
+ CALL FMSUB(M_LN_2PI,M23,M16)
+ CALL FMDIVI(M16,2,M21)
+ CALL FMADD_R1(M22,M21)
+ CALL FMSUB_R1(M22,M24)
+ CALL FMMPY(M23,M24,M21)
+ CALL FMADD_R1(M22,M21)
+
+! Now the log of gamma of the shifted argument has been
+! computed. Reverse the shifting.
+! The product MA*(MA+1)*...*(MA+LSHIFT-1) is computed
+! four terms at a time to reduce the number of FMMPY calls.
+
+! M26 is Z
+! M17 is Z**2
+! M18 is Z**3
+! M19 is (Z+K)*...*(Z+K+3)
+! M23 is the current product
+
+ IF (LSHIFT > 0) THEN
+ CALL FMSQR(M26,M17)
+ CALL FMMPY(M26,M17,M18)
+ CALL FMSQR(M17,M19)
+ CALL FMMPYI(M18,6,M24)
+ CALL FMADD_R1(M19,M24)
+ CALL FMMPYI(M17,11,M24)
+ CALL FMADD_R1(M19,M24)
+ CALL FMMPYI(M26,6,M24)
+ CALL FMADD_R1(M19,M24)
+ CALL FMEQ(M19,M23)
+ CALL FMMPYI_R1(M18,16)
+ DO K = 0, LSHIFT-8, 4
+ CALL FMADD_R1(M19,M18)
+ K2 = 24*(2*K + 7)
+ CALL FMMPYI(M17,K2,M24)
+ CALL FMADD_R1(M19,M24)
+ IF (K <= SQRT(REAL(INTMAX)/49.0)) THEN
+ K1 = 8*(6*K*K + 42*K + 79)
+ CALL FMMPYI(M26,K1,M24)
+ CALL FMADD_R1(M19,M24)
+ ELSE
+ K1 = 48*K
+ CALL FMMPYI(M26,K1,M24)
+ CALL FMMPYI_R1(M24,K)
+ CALL FMADD_R1(M19,M24)
+ K1 = 336*K + 632
+ CALL FMMPYI(M26,K1,M24)
+ CALL FMADD_R1(M19,M24)
+ ENDIF
+ IF (K <= (REAL(INTMAX)/17.0)**0.3333) THEN
+ K0 = 8*(2*K + 7)*(K*K + 7*K + 15)
+ CALL FMADDI(M19,K0)
+ ELSE IF (K <= SQRT(REAL(INTMAX)*0.9)) THEN
+ K0 = 8*(2*K + 7)
+ CALL FMI2M(K0,M24)
+ K0 = K*K + 7*K + 15
+ CALL FMMPYI_R1(M24,K0)
+ CALL FMADD_R1(M19,M24)
+ ELSE
+ K0 = 8*(2*K + 7)
+ CALL FMI2M(K0,M24)
+ CALL FMMPYI(M24,K,M21)
+ CALL FMMPYI_R1(M21,K)
+ CALL FMADD_R1(M19,M21)
+ K0 = 7*K + 15
+ CALL FMMPYI_R1(M24,K0)
+ CALL FMADD_R1(M19,M24)
+ ENDIF
+ CALL FMMPY_R1(M23,M19)
+ ENDDO
+ CALL FMLN(M23,M13)
+ CALL FMEQ(M13,M23)
+ CALL FMSUB_R1(M22,M23)
+ ENDIF
+
+! Use the reflection formula if MA was negative.
+
+ IF (MAS < 0) THEN
+
+! Reduce the argument before multiplying by Pi.
+
+ CALL FMNINT(M26,M17)
+ CALL FMDIVI(M17,2,M18)
+ CALL FMINT(M18,M08)
+ CALL FMEQ(M08,M18)
+ CALL FMMPYI(M18,2,M19)
+ KSIGN = -1
+ IF (FMCOMP(M17,'==',M19)) KSIGN = 1
+ CALL FMSUB(M26,M17,M21)
+ M21(0) = M26(0)
+ CALL FMPI(M23)
+ CALL FMMPY_R1(M23,M21)
+ KRSAVE = KRAD
+ KRAD = 1
+ CALL FMSIN(M23,M12)
+ CALL FMEQ(M12,M23)
+ M23(-1) = KSIGN*M23(-1)
+ KRAD = KRSAVE
+ CALL FMDIV_R2(MPISAV,M23)
+ CALL FMLN(M23,M13)
+ CALL FMEQ(M13,M23)
+ CALL FMSUB_R2(M23,M22)
+ ENDIF
+
+! Check for too much cancellation.
+
+ 140 IF (NCALL <= 1) THEN
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
+ ELSE
+ NGOAL = INT(-MXEXP2)
+ ENDIF
+ IF (M22(0) <= NGOAL) THEN
+ IF (NUMTRY > 0) THEN
+ NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
+ DO J = 1, NDGOAL+1
+ IF (MRETRY(J) /= M22(J)) GO TO 150
+ ENDDO
+ GO TO 160
+ ENDIF
+ 150 IEXTRA = INT(REAL(NGOAL-M22(0))/ALOGM2 + 23.03/ALOGMB) + 1
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M22)
+ GO TO 160
+ ENDIF
+ CALL FMEQ2_R1(M25,NDSAVE,NDIG)
+ CALL FMEQ(M25,M26)
+ NUMTRY = NUMTRY + 1
+ CALL FMEQ2(M22,MRETRY,NDOLD,NDIG)
+ GO TO 110
+ ENDIF
+
+ 160 MACMAX = NINT(NDSAVE*ALOGM2)
+ M22(0) = MIN(M22(0),MACCA,MACMAX)
+ CALL FMEXT2(M22,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMLNGM
+
+ SUBROUTINE FMPGAM(N,MA,MB)
+
+! MB = POLYGAMMA(N,MA) (Nth Derivative of PSI)
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ INTEGER N
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
+ INTEGER IEXTRA,INTA,J,J2,JN,JNC,JPT,JSTART,K,KASAVE,KFL,KOVUN,KPT, &
+ KPT1,KPT2,KRESLT,KRFLCT,KRSAVE,KWRNSV,LSHIFT,N1,NBOT,NC, &
+ NDGOAL,NDIG2,NDOLD,NDSAV1,NDSAVE,NDSV2,NGOAL,NMXDIF,NTERM, &
+ NTOP,NUMTRY
+
+! Set the coefficients used in computing various
+! derivatives of COT(Pi*X) for the reflection formula.
+
+ INTEGER :: KGCD(14) = &
+ (/ 1, 2, 2, 8, 8, 16, 16, 128, 128, 256, 256, 1024, &
+ 1024, 2048 /)
+ INTEGER :: KCOEFF(56) = (/ &
+ 1, 1, 3, 1, 3, 2, &
+ 15, 15, 2, 45, 60, 17, &
+ 315, 525, 231, 17, 315, 630, 378, 62, &
+ 2835, 6615, 5040, 1320, 62, &
+ 14175, 37800, 34965, 12720, 1382, &
+ 155925, 467775, 509355, 238425, 42306, 1382, &
+ 467775, 1559250, 1954260, 1121670, 280731, 21844, &
+ 6081075, 22297275, 31621590, 21531510, 7012005, &
+ 907725, 21844, &
+ 42567525, 170270100, 269594325, 212612400, 85630545, &
+ 15839460, 929569 /)
+ LOGICAL FMCOMP
+
+ IF (NTRACE /= 0) THEN
+ NCALL = NCALL + 1
+ NAMEST(NCALL) = 'FMPGAM'
+ CALL FMNTRI(2,N,1)
+ NCALL = NCALL - 1
+ ENDIF
+ CALL FMENT2('FMPGAM',MA,MA,1,0,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ KACCSW = 1
+ MACCA = MA(0)
+ CALL FMEQ2(MA,M28,NDSAVE,NDIG)
+ M28(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ(M28,M27)
+ NUMTRY = 0
+
+ 110 IF (N == 0) THEN
+ CALL FMPSI(M28,M24)
+ GO TO 150
+ ENDIF
+ IF (N < 0 .OR. MA(2) == 0) THEN
+ CALL FMST2M('UNKNOWN',M24)
+ KFLAG = -4
+ GO TO 170
+ ENDIF
+
+! Near zero PGAM(x) is about n!/(-x)**(n+1).
+
+ IF (M27(1) < (-NDIG-1)) THEN
+ CALL FMFCTI(N,M26)
+ IF (M27(1) /= MUNKNO .AND. M27(2) /= 0) M27(-1) = -M27(-1)
+ CALL FMIPWR(M27,N+1,M25)
+ CALL FMDIV(M26,M25,M24)
+ GO TO 150
+ ENDIF
+
+! Check for special cases.
+
+ KRFLCT = 0
+ CALL FMDP2M(-0.5D0,M18)
+ IF (FMCOMP(M27,'<=',M18)) THEN
+ KRFLCT = 1
+ KFL = 0
+ IF (MA(1) <= NDSAVE) THEN
+ CALL FMINT(M27,M23)
+ IF (FMCOMP(M27,'==',M23)) KFL = -4
+ ELSE
+ KFL = -4
+ ENDIF
+ IF (KFL /= 0) THEN
+ CALL FMST2M('UNKNOWN',M24)
+ KFLAG = -4
+ GO TO 170
+ ELSE
+ CALL FMI2M(1,M16)
+ CALL FMSUB_R2(M16,M27)
+ ENDIF
+ ENDIF
+ IF (MA(1) > NDIG+3) THEN
+ CALL FMIPWR(M27,-N,M24)
+ IF (M24(1) /= MEXPUN) THEN
+ CALL FMFCTI(N-1,M23)
+ CALL FMMPY_R1(M24,M23)
+ ENDIF
+ IF (MOD(N-1,2) == 1 .AND. M24(1) /= MUNKNO .AND. &
+ M24(2) /= 0) M24(-1) = -M24(-1)
+ GO TO 150
+ ENDIF
+
+! To speed the asymptotic series calculation, increase
+! the argument by LSHIFT.
+
+ IEXTRA = 0
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMM2I(M27,INTA)
+ KWARN = KWRNSV
+
+ IF (KFLAG == -4) THEN
+ LSHIFT = 0
+ ELSE
+ LSHIFT = INT(MAX(0.0,REAL(NDIG)*ALOGMB/4.46-REAL(INTA)))
+ LSHIFT = LSHIFT + (7*N)/20
+ ENDIF
+ IF (LSHIFT > 0) LSHIFT = 4*(LSHIFT/4 + 1)
+
+ IF (LSHIFT /= 0) THEN
+ CALL FMI2M(LSHIFT,M16)
+ CALL FMADD(M27,M16,M26)
+ ELSE
+ CALL FMEQ(M27,M26)
+ ENDIF
+
+! Sum the asymptotic series.
+
+ J2 = INT(0.3*ALOGMB + 0.2*SQRT(REAL(NDIG)))
+ J2 = MAX(1,MIN(LJSUMS/(LUNPCK+3),J2))
+
+! M27 is Z
+! M26 is Z + LSHIFT
+! M23 is X**J2 = (1/(Z+LSHIFT)**2)**J2
+! M24 is the current power of X times the quotient of
+! factorials in each term
+! M25 is the current term in the sum
+! M22 is (N+1)!
+! MJSUMS holds the partial sums
+
+ NDSAV1 = NDIG
+ CALL FMFCTI(N+1,M22)
+ CALL FMDIVI(M22,2,M24)
+ J = -2*J2
+ CALL FMIPWR(M26,J,M23)
+ IF (ABS(M23(1)) >= MEXPAB) THEN
+ J2 = 1
+ CALL FMIPWR(M26,-2,M23)
+ ENDIF
+ DO J = 1, J2
+ NTERM = 2*J
+ KPT = (J-1)*(NDSAV1+3)
+ CALL FMBERN(NTERM,M24,MJSUMS(KPT-1))
+ IF (KFLAG == -11) THEN
+ CALL FMST2M('UNKNOWN',M24)
+ KFLAG = -4
+ GO TO 170
+ ENDIF
+ NTOP = (N+NTERM)*(N+NTERM+1)
+ CALL FMMPYI_R1(M24,NTOP)
+ NBOT = (NTERM+1)*(NTERM+2)
+ CALL FMDIVI_R1(M24,NBOT)
+ ENDDO
+
+ NDIG2 = NDIG
+ 120 CALL FMMPY_R1(M24,M23)
+ NMXDIF = 2
+ DO J = 1, J2
+ NTERM = NTERM + 2
+ CALL FMBERN(NTERM,M24,M25)
+ IF (KFLAG == -11) THEN
+ CALL FMST2M('UNKNOWN',M24)
+ KFLAG = -4
+ GO TO 170
+ ENDIF
+ NDIG = NDSAV1
+ KPT = (J-1)*(NDSAV1+3)
+ CALL FMADD_R1(MJSUMS(KPT-1),M25)
+ IF (KFLAG /= 0) THEN
+ GO TO 130
+ ELSE
+ NMXDIF = MAX(NMXDIF,NDSAV1-INT(MJSUMS(KPT+1)-M25(1)))
+ NDIG = NDIG2
+ NTOP = (N+NTERM)*(N+NTERM+1)
+ CALL FMMPYI_R1(M24,NTOP)
+ NBOT = (NTERM+1)*(NTERM+2)
+ CALL FMDIVI_R1(M24,NBOT)
+ ENDIF
+ ENDDO
+ NDIG2 = NMXDIF
+ NDIG = NDIG2
+ GO TO 120
+
+! Put the J2 concurrent sums back together.
+
+ 130 NDIG = NDSAV1
+ IF (J2 > 1) THEN
+ KPT = (J2-1)*(NDSAV1+3)
+ CALL FMI2M(1,M23)
+ CALL FMSQR(M26,M25)
+ CALL FMDIV_R2(M23,M25)
+ CALL FMEQ(MJSUMS(KPT-1),M23)
+ DO J = J2-1, 1, -1
+ CALL FMMPY_R1(M23,M25)
+ KPT = (J-1)*(NDSAV1+3)
+ CALL FMADD_R1(M23,MJSUMS(KPT-1))
+ ENDDO
+ CALL FMEQ(M23,MJSUMS)
+ ENDIF
+ CALL FMIPWR(M26,N+2,M19)
+ CALL FMDIV_R1(MJSUMS,M19)
+
+! Add the initial terms to the asymptotic series.
+
+ CALL FMDIVI(M22,N+1,M23)
+ CALL FMDIVI(M23,N,M22)
+ CALL FMMPYI(M26,2,M20)
+ CALL FMI2M(N,M24)
+ CALL FMADD_R1(M20,M24)
+ CALL FMMPY_R1(M20,M22)
+ CALL FMMPYI_R1(M19,2)
+ CALL FMDIV_R1(M19,M26)
+ CALL FMDIV(M20,M19,M24)
+ CALL FMADD_R2(MJSUMS,M24)
+ IF (MOD(N-1,2) == 1 .AND. M24(1) /= MUNKNO .AND. &
+ M24(2) /= 0) M24(-1) = -M24(-1)
+
+! Now PGAM of the shifted argument has been
+! computed. Reverse the shifting.
+! The sum 1/(MA)**(N+1) + ... + 1/(MA+LSHIFT-1)**(N+1)
+! is computed.
+
+! M27 is Z
+! M23 is N!
+! M24 is the sum of the asymptotic series
+! M25 is the sum 1/(MA)**(N+1) + ... +
+! 1/(MA+LSHIFT-1)**(N+1)
+
+ IF (LSHIFT > 0) THEN
+ CALL FMI2M(1,M19)
+ CALL FMEQ(M27,M20)
+ N1 = -(N + 1)
+ CALL FMIPWR(M20,N1,M25)
+ DO K = 1, LSHIFT-1
+ CALL FMADD_R1(M20,M19)
+ CALL FMIPWR(M20,N1,M26)
+ CALL FMADD_R1(M25,M26)
+ ENDDO
+ CALL FMMPY_R2(M23,M25)
+ IF (MOD(N+1,2) == 1 .AND. M25(1) /= MUNKNO .AND. &
+ M25(2) /= 0) M25(-1) = -M25(-1)
+ CALL FMADD_R1(M24,M25)
+ ENDIF
+
+! Use the reflection formula if MA was less than -1/2.
+
+ IF (KRFLCT == 1) THEN
+
+! M25 is COT(Pi*Z)
+! M23 is M25**2
+
+! Reduce the argument before multiplying by Pi.
+
+ CALL FMMPYI(M27,2,M18)
+ CALL FMINT(M18,M23)
+ IF (FMCOMP(M18,'==',M23)) THEN
+ CALL FMI2M(0,M25)
+ CALL FMEQ(M25,M23)
+ ELSE
+ CALL FMNINT(M27,M18)
+ CALL FMSUB(M27,M18,M23)
+ NDSV2 = NDIG
+ 140 CALL FMPI(M25)
+ CALL FMMPY_R1(M25,M23)
+ KRSAVE = KRAD
+ KRAD = 1
+ CALL FMTAN(M25,M12)
+ CALL FMEQ(M12,M25)
+ KRAD = KRSAVE
+ IF ((M25(1) < 0 .OR. M25(1) > 1) .AND. &
+ NDSV2 == NDIG) THEN
+ IEXTRA = INT(MAX(-M25(1),M25(1)))
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M23,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M24)
+ GO TO 170
+ ENDIF
+ GO TO 140
+ ENDIF
+
+ NDIG = NDSV2
+ CALL FMI2M(1,M18)
+ CALL FMDIV_R2(M18,M25)
+ CALL FMSQR(M25,M23)
+ ENDIF
+ NC = (N+1)/2
+
+! For N up to 14, use the stored coefficients to compute
+! the Nth derivative of Cot(Pi*Z).
+! For larger N, the coefficients are generated from a
+! recurrence relation and stored as FM numbers.
+
+ IF (N <= 14) THEN
+ JSTART = (N*N + 4 - MOD(N,2))/4
+ IF (N <= 2) THEN
+ CALL FMI2M(1,M19)
+ ELSE
+ CALL FMMPYI(M23,KCOEFF(JSTART),M19)
+ ENDIF
+ DO J = 2, NC
+ CALL FMI2M(KCOEFF(JSTART+J-1),M20)
+ CALL FMADD_R1(M19,M20)
+ IF (J < NC) CALL FMMPY_R1(M19,M23)
+ ENDDO
+ IF (MOD(N,2) == 0) CALL FMMPY_R1(M19,M25)
+ IF (N > 1) CALL FMMPYI_R1(M19,KGCD(N))
+ ELSE
+ IF (NC*(NDIG+3) > LJSUMS) THEN
+ KFLAG = -12
+ CALL FMWRN2
+ WRITE (KW, &
+ "(' For PGAM(',I5,',*) with NDIG =',I5,',',I7," // &
+ "' words are needed'/' in array MJSUMS.'," // &
+ "' The current dimension of MJSUMS IS',I7/)" &
+ ) N,NDIG,NC*(NDIG+3),LJSUMS
+ MXEXP = MXSAVE
+ NDIG = NDSAVE
+ CALL FMST2M('UNKNOWN',MB)
+ IF (NTRACE /= 0) CALL FMNTR(1,MB,MB,1,1)
+ NCALL = NCALL - 1
+ KACCSW = KASAVE
+ RETURN
+ ENDIF
+
+ DO J = 1, 7
+ JPT = (J-1)*(NDIG+3)
+ CALL FMI2M(KCOEFF(J+49),MJSUMS(JPT-1))
+ CALL FMMPYI_R1(MJSUMS(JPT-1),KGCD(14))
+ ENDDO
+ DO JN = 15, N
+ JNC = (JN+1)/2
+ DO K = JNC, 2, -1
+ KPT1 = (K-2)*(NDIG+3)
+ KPT2 = (K-1)*(NDIG+3)
+ IF (K == JNC .AND. MOD(JN,2) == 1) THEN
+ CALL FMEQ(MJSUMS(KPT1-1),MJSUMS(KPT2-1))
+ ELSE
+ CALL FMADD(MJSUMS(KPT1-1),MJSUMS(KPT2-1), &
+ MJSUMS(KPT2-1))
+ CALL FMMPYI(MJSUMS(KPT2-1),JN-2*(K-1), &
+ MJSUMS(KPT2-1))
+ ENDIF
+ ENDDO
+ CALL FMMPYI_R1(MJSUMS,JN)
+ ENDDO
+
+! MJSUMS now has the coefficients needed for the polynomial
+! in Cot**2 that defines the Nth derivative of Cot.
+
+ CALL FMEQ(MJSUMS,M19)
+ DO J = 2, NC
+ CALL FMMPY_R1(M19,M23)
+ KPT = (J-1)*(NDIG+3)
+ CALL FMADD_R1(M19,MJSUMS(KPT-1))
+ ENDDO
+ IF (MOD(N,2) == 0) CALL FMMPY_R1(M19,M25)
+ ENDIF
+
+! To complete the calculation of the Nth derivative of
+! Cot, multiply the polynomial in Cot**2 by Csc**2.
+
+ CALL FMADD(M23,M18,M20)
+ CALL FMMPY_R1(M19,M20)
+
+ CALL FMIPWR(MPISAV,N+1,M20)
+ CALL FMMPY_R1(M19,M20)
+ IF (MOD(N,2) == 1 .AND. M24(1) /= MUNKNO .AND. &
+ M24(2) /= 0) M24(-1) = -M24(-1)
+ CALL FMADD_R1(M24,M19)
+ ENDIF
+
+! Check for too much cancellation.
+
+ 150 IF (NCALL <= 1) THEN
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
+ ELSE
+ NGOAL = INT(-MXEXP2)
+ ENDIF
+ IF (M24(0) <= NGOAL) THEN
+ IF (NUMTRY > 0) THEN
+ NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
+ DO J = 1, NDGOAL+1
+ IF (MRETRY(J) /= M24(J)) GO TO 160
+ ENDDO
+ GO TO 170
+ ENDIF
+ 160 IEXTRA = INT(REAL(NGOAL-M24(0))/ALOGM2 + 23.03/ALOGMB) + 1
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M24)
+ GO TO 170
+ ENDIF
+ CALL FMEQ2_R1(M28,NDSAVE,NDIG)
+ CALL FMEQ(M28,M27)
+ NUMTRY = NUMTRY + 1
+ CALL FMEQ2(M24,MRETRY,NDOLD,NDIG)
+ GO TO 110
+ ENDIF
+
+ 170 MACMAX = NINT(NDSAVE*ALOGM2)
+ M24(0) = MIN(M24(0),MACCA,MACMAX)
+ CALL FMEXT2(M24,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMPGAM
+
+ SUBROUTINE FMPOCH(MA,N,MB)
+
+! MB = MA*(MA+1)*(MA+2)*...*(MA+N-1) (Pochhammer's symbol)
+
+! MB = Gamma(MA+N)/Gamma(MA)
+
+! For negative N, Pochhammer(MA,N) = 1/Pochhammer(MA+N,-N).
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ INTEGER N
+ REAL (KIND(1.0D0)) :: MA2,MAS,MACCA,MACMAX,MBSIGN,MXSAVE
+ INTEGER IEXTRA,J,K,K0,K1,K2,KASAVE,KLAST,KM08,KMB,KOVUN,KRESLT, &
+ LT,NDGOAL,NDOLD,NDSAVE,NGOAL,NT,NUMTRY
+ LOGICAL FMCOMP
+ REAL T
+
+ CALL FMENT2('FMPOCH',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ CALL FMNTRI(2,N,0)
+ IF (KRESLT /= 0) RETURN
+
+ MA2 = MA(2)
+ MAS = MA(-1)
+ NT = N
+ KACCSW = 1
+ MACCA = MA(0)
+ CALL FMEQ2(MA,M30,NDSAVE,NDIG)
+ M30(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ(M30,M27)
+ NUMTRY = 0
+
+! Check for special cases.
+
+ 110 IEXTRA = 0
+ IF (NT < 0) THEN
+ CALL FMADDI(M30,NT)
+ CALL FMEQ(M30,M27)
+ NT = -NT
+ MA2 = M30(2)
+ MAS = M30(-1)
+ ENDIF
+ IF (MA2 == 0) THEN
+ IF (NT > 0) THEN
+ CALL FMI2M(0,M23)
+ GO TO 130
+ ELSE
+ CALL FMST2M('UNKNOWN',M23)
+ KFLAG = -4
+ GO TO 150
+ ENDIF
+ ENDIF
+ IF (NT == 0) THEN
+ CALL FMI2M(1,M23)
+ GO TO 130
+ ELSE IF (NT == 1) THEN
+ CALL FMEQ2(M30,M23,NDSAVE,NDIG)
+ GO TO 130
+ ENDIF
+ CALL FMI2M(1,M16)
+ CALL FMADD(M30,M16,M17)
+ IF (M30(1) == MEXPOV) THEN
+ CALL FMST2M('OVERFLOW',M23)
+ IF (MAS < 0) M23(-1) = (-1)**NT
+ GO TO 130
+ ELSE IF (M30(1) == MEXPUN) THEN
+ IF (NT == 2) THEN
+ CALL FMST2M('UNDERFLOW',M23)
+ IF (MAS < 0) M23(-1) = -1
+ ELSE
+ CALL FMST2M('UNKNOWN',M23)
+ KFLAG = -4
+ ENDIF
+ GO TO 150
+ ELSE IF (FMCOMP(M17,'==',M16)) THEN
+ T = NDIG
+ J = INT(15.21*SQRT(T)*ALOGMT + 42.87*SQRT(T) + 30.0)
+ IF (NT <= J) THEN
+ K1 = NT - 1
+ CALL FMFCTI(K1,M23)
+ CALL FMMPY_R2(M30,M23)
+ GO TO 130
+ ENDIF
+ ENDIF
+
+! Look for cases where overflow is easy to detect.
+
+ CALL FMI2M(NT,M21)
+ CALL FMABS(M27,M19)
+ IF (M27(1) > 0 .AND. FMCOMP(M21,'<',M19)) THEN
+ CALL FMADD(M27,M21,M20)
+ M20(-1) = 1
+ CALL FMMIN(M19,M20,M22)
+ IF (INT(M22(1))-1 > INTMAX/NT) THEN
+ CALL FMST2M('OVERFLOW',M23)
+ IF (M27(-1) > 0) THEN
+ M23(-1) = 1
+ ELSE
+ M23(-1) = (-1)**MOD(NT,2)
+ ENDIF
+ KFLAG = -5
+ GO TO 130
+ ENDIF
+ ENDIF
+
+! For large values of MA, the result is MA**NT.
+
+ LT = NDIG + 3 + INT(2.0D0*LOG(DBLE(NT))/DLOGMB)
+ IF (M30(1) > LT) THEN
+ CALL FMIPWR(M27,NT,M23)
+ GO TO 130
+ ENDIF
+
+ MBSIGN = 1
+ IF (MAS < 0) THEN
+ CALL FMINT(M27,M20)
+ CALL FMI2M(NT,M21)
+ CALL FMADD(M27,M21,M22)
+ IF (FMCOMP(M27,'==',M20)) THEN
+
+! If MA is a negative integer and MA+NT is positive,
+! then the result is zero.
+
+ IF (M22(-1)*M22(2) > 0) THEN
+ CALL FMI2M(0,M23)
+ GO TO 130
+ ENDIF
+ ENDIF
+
+! If MA is negative and MA+NT-1 is negative,
+! then use the reflection formula Pochhammer(MA,NT) =
+! (-1)**NT*Pochhammer(-MA-(NT-1),NT).
+
+ CALL FMI2M(1,M23)
+ IF (FMCOMP(M22,'<',M23)) THEN
+
+! Extra guard digits may be required to insure the
+! reflection formula is accurate.
+
+ IEXTRA = MAX(INT(M27(1)),IEXTRA)
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M27,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M23)
+ GO TO 150
+ ENDIF
+ CALL FMI2M(NT-1,M23)
+ IF (M27(1) /= MUNKNO .AND. M27(2) /= 0) M27(-1) = -M27(-1)
+ CALL FMSUB_R1(M27,M23)
+ IF (MOD(NT,2) == 1) MBSIGN = -1
+ ENDIF
+ ENDIF
+
+! If NT is large enough, it is faster to use two
+! calls to FMLNGM. The formula below gives a rough
+! approximation of where to change methods.
+
+ T = NDIG
+ J = INT(15.21*SQRT(T)*ALOGMT + 42.87*SQRT(T) + 25.03)
+ IF (NT > J) THEN
+ CALL FMI2M(NT,M16)
+ CALL FMADD(M27,M16,M28)
+
+! Compute IEXTRA, the number of extra digits required
+! to compensate for cancellation error.
+
+ IF (MAX(M27(1),M28(1)) > IEXTRA) THEN
+ IEXTRA = INT(MAX(M27(1),M28(1)))
+ ENDIF
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M27,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M23)
+ GO TO 150
+ ENDIF
+
+ CALL FMI2M(-1,M29)
+ IF (IEXTRA > 0) THEN
+ CALL FMI2M(NT,M16)
+ CALL FMADD(M27,M16,M28)
+ ENDIF
+ CALL FMI2M(2,M21)
+ KMB = 0
+ IF (M27(-1) < 0) THEN
+ CALL FMMOD(M27,M21,M20)
+ IF (FMCOMP(M20,'>',M29)) KMB = 1
+ ENDIF
+ KM08 = 0
+ IF (M28(-1) < 0) THEN
+ CALL FMMOD(M28,M21,M20)
+ IF (FMCOMP(M20,'>',M29)) KM08 = 1
+ ENDIF
+ CALL FMI2M(1,M29)
+ IF (M27(-1) < 0 .AND. KMB == 1) THEN
+ CALL FMEQ(M27,M29)
+ CALL FMI2M(1,M16)
+ CALL FMADD_R1(M27,M16)
+ CALL FMLNGM(M27,M14)
+ CALL FMEQ(M14,M27)
+ ELSE
+ CALL FMLNGM(M27,M14)
+ CALL FMEQ(M14,M27)
+ ENDIF
+ IF (M28(-1) < 0 .AND. KM08 == 1) THEN
+ CALL FMI2M(-1,M19)
+ CALL FMADD_R1(M28,M19)
+ CALL FMMPY_R1(M29,M28)
+ CALL FMLNGM(M28,M14)
+ CALL FMEQ(M14,M28)
+ ELSE
+ CALL FMLNGM(M28,M14)
+ CALL FMEQ(M14,M28)
+ ENDIF
+
+ CALL FMSUB(M28,M27,M23)
+ CALL FMEXP(M23,M12)
+ CALL FMEQ(M12,M23)
+ CALL FMMPY_R1(M23,M29)
+ GO TO 120
+ ENDIF
+
+! Compute the product Z*(Z+1)*...*(Z+NT-1)
+! four terms at a time to reduce the number of FMMPY calls.
+
+! M27 is Z
+! M18 is Z**2
+! M19 is Z**3
+! M20 is (Z+K)*...*(Z+K+3)
+! M23 is the current product
+
+! If M27 is negative and M27+NT is positive, extra
+! digits are required when M27 is close to an integer.
+
+ IF (M27(-1) < 0) THEN
+ CALL FMI2M(NT,M20)
+ CALL FMADD(M27,M20,M21)
+ IF (M21(-1)*M21(2) > 0) THEN
+ CALL FMNINT(M27,M22)
+ IF (M22(2) /= 0) THEN
+ CALL FMSUB(M27,M22,M21)
+ IEXTRA = MAX(IEXTRA,NDIG-NDSAVE)
+ IF (MAX(M27(1),M21(1)) > IEXTRA) THEN
+ IEXTRA = INT(MAX(M27(1),M21(1)))
+ ENDIF
+ IF (IEXTRA > 0 .AND. NDIG+IEXTRA <= NDG2MX) THEN
+ CALL FMEQ2_R1(M27,NDIG,NDIG+IEXTRA)
+ ENDIF
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M23)
+ GO TO 150
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+
+ CALL FMI2M(1,M23)
+ IF (NT >= 4) THEN
+ CALL FMSQR(M27,M18)
+ CALL FMMPY(M27,M18,M19)
+ CALL FMSQR(M18,M20)
+ CALL FMMPYI(M19,6,M24)
+ CALL FMADD_R1(M20,M24)
+ CALL FMMPYI(M18,11,M24)
+ CALL FMADD_R1(M20,M24)
+ CALL FMMPYI(M27,6,M24)
+ CALL FMADD_R1(M20,M24)
+ CALL FMEQ(M20,M23)
+ CALL FMMPYI_R1(M19,16)
+ DO K = 0, NT-8, 4
+ CALL FMADD_R1(M20,M19)
+ K2 = 24*(2*K + 7)
+ CALL FMMPYI(M18,K2,M24)
+ CALL FMADD_R1(M20,M24)
+ IF (K <= SQRT(REAL(INTMAX)/49.0)) THEN
+ K1 = 8*(6*K*K + 42*K + 79)
+ CALL FMMPYI(M27,K1,M24)
+ CALL FMADD_R1(M20,M24)
+ ELSE
+ K1 = 48*K
+ CALL FMMPYI(M27,K1,M24)
+ CALL FMMPYI_R1(M24,K)
+ CALL FMADD_R1(M20,M24)
+ K1 = 336*K + 632
+ CALL FMMPYI(M27,K1,M24)
+ CALL FMADD_R1(M20,M24)
+ ENDIF
+ IF (K <= (REAL(INTMAX)/17.0)**0.3333) THEN
+ K0 = 8*(2*K + 7)*(K*K + 7*K + 15)
+ CALL FMADDI(M20,K0)
+ ELSE IF (K <= SQRT(REAL(INTMAX)*0.9)) THEN
+ K0 = 8*(2*K + 7)
+ CALL FMI2M(K0,M24)
+ K0 = K*K + 7*K + 15
+ CALL FMMPYI_R1(M24,K0)
+ CALL FMADD_R1(M20,M24)
+ ELSE
+ K0 = 8*(2*K + 7)
+ CALL FMI2M(K0,M24)
+ CALL FMMPYI(M24,K,M21)
+ CALL FMMPYI_R1(M21,K)
+ CALL FMADD_R1(M20,M21)
+ K0 = 7*K + 15
+ CALL FMMPYI_R1(M24,K0)
+ CALL FMADD_R1(M20,M24)
+ ENDIF
+ CALL FMMPY_R1(M23,M20)
+ ENDDO
+ ENDIF
+
+ KLAST = (NT/4)*4
+ DO J = KLAST, NT-1
+ CALL FMI2M(J,M21)
+ CALL FMADD_R2(M27,M21)
+ CALL FMMPY_R1(M23,M21)
+ ENDDO
+
+! If the reflection formula was used, multiply by (-1)**NT.
+
+ 120 M23(-1) = MBSIGN*M23(-1)
+
+! Check for too much cancellation.
+
+ 130 IF (NCALL <= 1) THEN
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
+ ELSE
+ NGOAL = INT(-MXEXP2)
+ ENDIF
+ IF (M23(0) <= NGOAL) THEN
+ IF (NUMTRY > 0) THEN
+ NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
+ DO J = 1, NDGOAL+1
+ IF (MRETRY(J) /= M23(J)) GO TO 140
+ ENDDO
+ GO TO 150
+ ENDIF
+ 140 IEXTRA = INT(REAL(NGOAL-M23(0))/ALOGM2 + 23.03/ALOGMB) + 1
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M23)
+ GO TO 150
+ ENDIF
+ CALL FMEQ2_R1(M30,NDSAVE,NDIG)
+ CALL FMEQ(M30,M27)
+ NUMTRY = NUMTRY + 1
+ CALL FMEQ2(M23,MRETRY,NDOLD,NDIG)
+ GO TO 110
+ ENDIF
+
+ 150 MACMAX = NINT(NDSAVE*ALOGM2)
+ IF (N < 0) THEN
+ CALL FMI2M(1,M18)
+ CALL FMDIV_R2(M18,M23)
+ ENDIF
+ M23(0) = MIN(M23(0),MACCA,MACMAX)
+ CALL FMEXT2(M23,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMPOCH
+
+ SUBROUTINE FMPSI(MA,MB)
+
+! MB = PSI(MA) (Derivative of Ln(Gamma(MA))
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK)
+ REAL (KIND(1.0D0)) :: MACCA,MACMAX,MXSAVE
+ INTEGER IEXTRA,INTA,J,J2,K,K0,K0B,K1,K1B,K2,KASAVE,KFL,KOVUN,KPT, &
+ KRESLT,KRFLCT,KRSAVE,KWRNSV,LSHIFT,NDENOM,NDGOAL,NDIG2, &
+ NDOLD,NDSAV1,NDSAVE,NGOAL,NMXDIF,NTERM,NUMTRY
+ LOGICAL FMCOMP
+
+ CALL FMENT2('FMPSI ',MA,MA,1,1,MB,KRESLT,NDSAVE,MXSAVE,KASAVE, &
+ KOVUN)
+ IF (KRESLT /= 0) RETURN
+ KACCSW = 1
+ MACCA = MA(0)
+ CALL FMEQ2(MA,M25,NDSAVE,NDIG)
+ M25(0) = NINT(NDIG*ALOGM2)
+ CALL FMEQ(M25,M26)
+ NUMTRY = 0
+
+! Near zero Psi(x) is about -1/x.
+
+ 110 IF (M26(1) < (-NDIG-1)) THEN
+ CALL FMI2M(-1,M16)
+ CALL FMDIV(M16,M26,M22)
+ GO TO 140
+ ENDIF
+
+! Check for special cases.
+
+ KRFLCT = 0
+ CALL FMDPM(DBLE(-0.5),M18)
+ IF (FMCOMP(M26,'<=',M18)) THEN
+ KRFLCT = 1
+ KFL = 0
+ IF (MA(1) <= NDSAVE) THEN
+ CALL FMINT(M26,M21)
+ IF (FMCOMP(M26,'==',M21)) KFL = -4
+ ELSE
+ KFL = -4
+ ENDIF
+ IF (KFL /= 0) THEN
+ CALL FMST2M('UNKNOWN',M22)
+ KFLAG = -4
+ GO TO 160
+ ELSE
+ CALL FMI2M(1,M16)
+ CALL FMSUB_R2(M16,M26)
+ ENDIF
+ ENDIF
+
+! To speed the asymptotic series calculation, increase
+! the argument by LSHIFT.
+
+ IEXTRA = 0
+ KWRNSV = KWARN
+ KWARN = 0
+ CALL FMM2I(M26,INTA)
+ KWARN = KWRNSV
+
+ IF (KFLAG == -4) THEN
+ LSHIFT = 0
+ ELSE
+ LSHIFT = INT(MAX(0.0,REAL(NDIG)*ALOGMB/4.46-REAL(INTA)))
+ ENDIF
+ IF (LSHIFT > 0) LSHIFT = 4*(LSHIFT/4 + 1)
+
+ IF (LSHIFT /= 0) THEN
+ CALL FMI2M(LSHIFT,M16)
+ CALL FMADD(M26,M16,M24)
+ ELSE
+ CALL FMEQ(M26,M24)
+ ENDIF
+
+! Sum the asymptotic series.
+
+ J2 = INT(0.3*ALOGMB + 0.2*SQRT(REAL(NDIG)))
+ J2 = MAX(1,MIN(LJSUMS/(LUNPCK+3),J2))
+
+! M26 is Z
+! M24 is Z + LSHIFT
+! M21 is X**J2 = (1/(Z+LSHIFT)**2)**J2
+! M22 is the current power of X
+! M23 is the current term in the sum
+! MJSUMS is the partial sum
+
+ NDSAV1 = NDIG
+ CALL FMI2M(1,M22)
+ J = -2*J2
+ CALL FMIPWR(M24,J,M21)
+ IF (ABS(M21(1)) >= MEXPAB) THEN
+ J2 = 1
+ CALL FMIPWR(M24,-2,M21)
+ ENDIF
+ DO J = 1, J2
+ NTERM = 2*J
+ CALL FMBERN(NTERM,M22,M23)
+ IF (KFLAG == -11) THEN
+ CALL FMST2M('UNKNOWN',M22)
+ KFLAG = -4
+ GO TO 160
+ ENDIF
+ NDENOM = NTERM
+ KPT = (J-1)*(NDSAV1+3)
+ CALL FMDIVI(M23,NDENOM,MJSUMS(KPT-1))
+ ENDDO
+
+ NDIG2 = NDIG
+ 120 CALL FMMPY_R1(M22,M21)
+ NMXDIF = 2
+ DO J = 1, J2
+ NTERM = NTERM + 2
+ CALL FMBERN(NTERM,M22,M23)
+ IF (KFLAG == -11) THEN
+ CALL FMST2M('UNKNOWN',M22)
+ KFLAG = -4
+ GO TO 160
+ ENDIF
+ NDENOM = NTERM
+ CALL FMDIVI_R1(M23,NDENOM)
+ NDIG = NDSAV1
+ KPT = (J-1)*(NDSAV1+3)
+ CALL FMADD_R1(MJSUMS(KPT-1),M23)
+ NMXDIF = MAX(NMXDIF,NDSAV1-INT(MJSUMS(KPT+1)-M23(1)))
+ NDIG = NDIG2
+ IF (KFLAG /= 0) GO TO 130
+ ENDDO
+ NDIG2 = NMXDIF
+ NDIG = NDIG2
+ GO TO 120
+
+! Put the J2 concurrent sums back together.
+
+ 130 NDIG = NDSAV1
+ CALL FMI2M(1,M21)
+ CALL FMSQR(M24,M23)
+ CALL FMDIV_R2(M21,M23)
+ IF (J2 > 1) THEN
+ KPT = (J2-1)*(NDSAV1+3)
+ CALL FMEQ(MJSUMS(KPT-1),M21)
+ DO J = J2-1, 1, -1
+ CALL FMMPY_R1(M21,M23)
+ KPT = (J-1)*(NDSAV1+3)
+ CALL FMADD_R1(M21,MJSUMS(KPT-1))
+ ENDDO
+ CALL FMEQ(M21,MJSUMS)
+ ENDIF
+
+! Add the log term to the asymptotic series.
+
+! M22 is the current sum as the log terms are added
+! M23 is now LN(Z+LSHIFT)
+
+ CALL FMMPY(MJSUMS,M23,M22)
+ CALL FMLN(M24,M23)
+ CALL FMI2M(1,M18)
+ CALL FMDIV(M18,M24,M19)
+ CALL FMDIVI_R1(M19,2)
+ CALL FMSUB_R2(M23,M19)
+ CALL FMSUB_R2(M19,M22)
+
+! Now Psi of the shifted argument has been
+! computed. Reverse the shifting.
+! The sum 1/(MA) + ... + 1/(MA+LSHIFT-1) is computed.
+
+! M26 is Z
+! M18 is X**2
+! M19 is 16*Z**3
+! M20 is the current four-term numerator
+! M21 is the current four-term denominator
+! M23 is the current sum
+
+ IF (LSHIFT > 0) THEN
+ CALL FMSQR(M26,M18)
+ CALL FMMPY(M26,M18,M19)
+ CALL FMSQR(M18,M20)
+ CALL FMMPYI(M19,6,M24)
+ CALL FMADD_R1(M20,M24)
+ CALL FMMPYI(M18,11,M24)
+ CALL FMADD_R1(M20,M24)
+ CALL FMMPYI(M26,6,M24)
+ CALL FMADD(M20,M24,M21)
+ CALL FMMPYI(M19,4,M20)
+ CALL FMMPYI(M18,18,M24)
+ CALL FMADD_R1(M20,M24)
+ CALL FMMPYI(M26,22,M24)
+ CALL FMADD_R1(M20,M24)
+ CALL FMI2M(6,M24)
+ CALL FMADD_R1(M20,M24)
+ CALL FMDIV(M20,M21,M23)
+ CALL FMMPYI_R1(M19,16)
+ DO K = 4, LSHIFT-4, 4
+ CALL FMADD_R1(M21,M19)
+
+ CALL FMMPYI(M18,48,M24)
+ CALL FMADD_R1(M20,M24)
+
+ K2 = 8*(6*K - 3)
+ CALL FMMPYI(M18,K2,M24)
+ CALL FMADD_R1(M21,M24)
+
+ K1 = 16*(6*K - 3)
+ CALL FMMPYI(M26,K1,M24)
+ CALL FMADD_R1(M20,M24)
+
+ IF (K <= SQRT(REAL(INTMAX)/49.0)) THEN
+ K1 = 8*(6*K*K - 6*K + 7)
+ CALL FMMPYI(M26,K1,M24)
+ CALL FMADD_R1(M21,M24)
+
+ CALL FMI2M(K1,M24)
+ CALL FMADD_R1(M20,M24)
+ ELSE
+ K1 = 48*K
+ CALL FMMPYI(M26,K1,M24)
+ CALL FMMPYI_R1(M24,K)
+ CALL FMADD_R1(M21,M24)
+ K1B = 8*(-6*K + 7)
+ CALL FMMPYI(M26,K1B,M24)
+ CALL FMADD_R1(M21,M24)
+
+ CALL FMI2M(K1,M24)
+ CALL FMMPYI_R1(M24,K)
+ CALL FMADD_R1(M20,M24)
+ CALL FMI2M(K1B,M24)
+ CALL FMADD_R1(M20,M24)
+ ENDIF
+ IF (K <= (REAL(INTMAX)/17.0)**0.3333) THEN
+ K0 = 8*(2*K - 1)*(K*K - K + 3)
+ CALL FMI2M(K0,M24)
+ CALL FMADD_R1(M21,M24)
+ ELSE IF (K <= SQRT(REAL(INTMAX)*0.9)) THEN
+ K0 = 8*(2*K - 1)
+ CALL FMI2M(K0,M24)
+ K0B = K*K - K + 3
+ CALL FMMPYI_R1(M24,K0B)
+ CALL FMADD_R1(M21,M24)
+ ELSE
+ K0 = 8*(2*K - 1)
+ CALL FMI2M(K0,M24)
+ CALL FMMPYI_R1(M24,K)
+ CALL FMMPYI_R1(M24,K)
+ CALL FMADD_R1(M21,M24)
+ K0B = -K + 3
+ CALL FMI2M(K0,M24)
+ CALL FMMPYI_R1(M24,K0B)
+ CALL FMADD_R1(M21,M24)
+ ENDIF
+ CALL FMDIV(M20,M21,M24)
+ CALL FMADD_R1(M23,M24)
+ ENDDO
+ CALL FMSUB_R1(M22,M23)
+ ENDIF
+
+! Use the reflection formula if MA was less than -1/2.
+
+ IF (KRFLCT == 1) THEN
+
+! Reduce the argument before multiplying by Pi.
+
+ CALL FMNINT(M26,M18)
+ CALL FMSUB(M26,M18,M21)
+ M21(0) = M26(0)
+ CALL FMPI(M23)
+ CALL FMMPY_R1(M23,M21)
+ KRSAVE = KRAD
+ KRAD = 1
+ CALL FMTAN(M23,M12)
+ CALL FMEQ(M12,M23)
+ KRAD = KRSAVE
+ CALL FMDIV_R2(MPISAV,M23)
+ CALL FMADD_R1(M22,M23)
+ ENDIF
+
+! Check for too much cancellation.
+
+ 140 IF (NCALL <= 1) THEN
+ NGOAL = INT(REAL(NDSAVE)*ALOGM2) + 17
+ ELSE
+ NGOAL = INT(-MXEXP2)
+ ENDIF
+ IF (M22(0) <= NGOAL) THEN
+ IF (NUMTRY > 0) THEN
+ NDGOAL = INT(REAL(NGOAL)/ALOGM2 + 1.0)
+ DO J = 1, NDGOAL+1
+ IF (MRETRY(J) /= M22(J)) GO TO 150
+ ENDDO
+ GO TO 160
+ ENDIF
+ 150 IEXTRA = INT(REAL(NGOAL-M22(0))/ALOGM2 + 23.03/ALOGMB) + 1
+ NDOLD = NDIG
+ NDIG = NDIG + IEXTRA
+ IF (NDIG > NDG2MX) THEN
+ KFLAG = -9
+ CALL FMWRN2
+ NDIG = NDIG - IEXTRA
+ CALL FMST2M('UNKNOWN',M22)
+ GO TO 160
+ ENDIF
+ CALL FMEQ2_R1(M25,NDSAVE,NDIG)
+ CALL FMEQ(M25,M26)
+ NUMTRY = NUMTRY + 1
+ CALL FMEQ2(M22,MRETRY,NDOLD,NDIG)
+ GO TO 110
+ ENDIF
+
+ 160 MACMAX = NINT(NDSAVE*ALOGM2)
+ M22(0) = MIN(M22(0),MACCA,MACMAX)
+ CALL FMEXT2(M22,MB,NDSAVE,MXSAVE,KASAVE,KOVUN)
+ RETURN
+ END SUBROUTINE FMPSI
+
+ SUBROUTINE FMWRN2
+
+! Called by one of the FM routines to print a warning message
+! if any error condition arises in that routine.
+
+ USE FMVALS
+ IMPLICIT NONE
+
+ CHARACTER(6) :: NAME
+
+ INTEGER NCS
+
+ IF (KFLAG >= 0 .OR. NCALL /= 1 .OR. KWARN <= 0) RETURN
+ NCS = NCALL
+ NAME = NAMEST(NCALL)
+ WRITE (KW, &
+ "(/' Error of type KFLAG =',I3," // &
+ "' in FM package in routine ',A6/)" &
+ ) KFLAG,NAME
+
+ 110 NCALL = NCALL - 1
+ IF (NCALL > 0) THEN
+ NAME = NAMEST(NCALL)
+ WRITE (KW,"( ' called from ',A6)") NAME
+ GO TO 110
+ ENDIF
+
+ IF (KFLAG == -1) THEN
+ WRITE (KW,"(' NDIG must be between 2 and',I10/)") NDIGMX
+ ELSE IF (KFLAG == -2) THEN
+ WRITE (KW,"(' MBASE must be between 2 and',I10/)") INT(MXBASE)
+ ELSE IF (KFLAG == -3) THEN
+ WRITE (KW, &
+ "(' An input argument is not a valid FM number.'," // &
+ "' Its exponent is out of range.'/)" &
+ )
+ WRITE (KW,"(' UNKNOWN has been returned.'/)")
+ ELSE IF (KFLAG == -4 .OR. KFLAG == -7) THEN
+ WRITE (KW,"(' Invalid input argument for this routine.'/)")
+ WRITE (KW,"(' UNKNOWN has been returned.'/)")
+ ELSE IF (KFLAG == -5) THEN
+ WRITE (KW,"(' The result has overflowed.'/)")
+ ELSE IF (KFLAG == -6) THEN
+ WRITE (KW,"(' The result has underflowed.'/)")
+ ELSE IF (KFLAG == -8) THEN
+ WRITE (KW, &
+ "(' The result array is not big enough to hold the'," // &
+ "' output character string'/' in the current format.'/" // &
+ "' The result ''***...***'' has been returned.'/)" &
+ )
+ ELSE IF (KFLAG == -9) THEN
+ WRITE (KW, &
+ "(' Precision could not be raised enough to'" // &
+ ",' provide all requested guard digits.'/)" &
+ )
+ WRITE (KW, &
+ "(I23,' digits were requested (NDIG).'/" // &
+ "' Maximum number of digits currently available'," // &
+ "' (NDG2MX) is',I7,'.'/)" &
+ ) NDIG,NDG2MX
+ WRITE (KW,"(' UNKNOWN has been returned.'/)")
+ ELSE IF (KFLAG == -10) THEN
+ IF (NAMEST(NCS) == 'FMM2SP') THEN
+ WRITE (KW, &
+ "(' An FM number was too small in magnitude to '," // &
+ "'convert to single precision.'/)" &
+ )
+ ELSE
+ WRITE (KW, &
+ "(' An FM number was too small in magnitude to '," // &
+ "'convert to double precision.'/)" &
+ )
+ ENDIF
+ WRITE (KW,"(' Zero has been returned.'/)")
+ ELSE IF (KFLAG == -11) THEN
+ WRITE (KW,"(' Array MBERN is not large enough.')")
+ ELSE IF (KFLAG == -12) THEN
+ WRITE (KW,"(' Array MJSUMS is not large enough.')")
+ ENDIF
+
+ NCALL = NCS
+ IF (KWARN >= 2) THEN
+ STOP
+ ENDIF
+ RETURN
+ END SUBROUTINE FMWRN2
+
+! Packed versions of routines for special functions.
+
+ SUBROUTINE FPBERN(INT,MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ INTEGER INT
+ CALL FMUNPK(MA,MPA)
+ CALL FMBERN(INT,MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPBERN
+
+ SUBROUTINE FPBETA(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMBETA(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPBETA
+
+ SUBROUTINE FPCMBI(N,K,MA)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ INTEGER K,N
+ CALL FMCMBI(N,K,MPA)
+ CALL FMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE FPCMBI
+
+ SUBROUTINE FPCOMB(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMCOMB(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPCOMB
+
+ SUBROUTINE FPEULR(MA)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK)
+ CALL FMEULR(MPA)
+ CALL FMPACK(MPA,MA)
+ RETURN
+ END SUBROUTINE FPEULR
+
+ SUBROUTINE FPFACT(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMFACT(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPFACT
+
+ SUBROUTINE FPGAM(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMGAM(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPGAM
+
+ SUBROUTINE FPIBTA(MA,MB,MC,MD)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK),MD(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMUNPK(MC,MPC)
+ CALL FMIBTA(MPA,MPB,MPC,MPD)
+ CALL FMPACK(MPD,MD)
+ RETURN
+ END SUBROUTINE FPIBTA
+
+ SUBROUTINE FPIGM1(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMIGM1(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPIGM1
+
+ SUBROUTINE FPIGM2(MA,MB,MC)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK),MC(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMUNPK(MB,MPB)
+ CALL FMIGM2(MPA,MPB,MPC)
+ CALL FMPACK(MPC,MC)
+ RETURN
+ END SUBROUTINE FPIGM2
+
+ SUBROUTINE FPLNGM(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMLNGM(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPLNGM
+
+ SUBROUTINE FPPGAM(N,MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ INTEGER N
+ CALL FMUNPK(MA,MPA)
+ CALL FMPGAM(N,MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPPGAM
+
+ SUBROUTINE FPPOCH(MA,N,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ INTEGER N
+ CALL FMUNPK(MA,MPA)
+ CALL FMPOCH(MPA,N,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPPOCH
+
+ SUBROUTINE FPPSI(MA,MB)
+ USE FMVALS
+ IMPLICIT NONE
+ REAL (KIND(1.0D0)) :: MA(-1:LPACK),MB(-1:LPACK)
+ CALL FMUNPK(MA,MPA)
+ CALL FMPSI(MPA,MPB)
+ CALL FMPACK(MPB,MB)
+ RETURN
+ END SUBROUTINE FPPSI
+
+! Interface routines for calling with the FM, IM, and ZM derived types.
+
+ SUBROUTINE FM_ABS(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMABS(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_ACOS(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMACOS(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_ADD(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMADD(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_ADD_R1(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMADD_R1(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_ADD_R2(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMADD_R2(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_ADDI(MA,IVAL)
+ USE FMZM
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ CALL FMADDI(MA%MFM,IVAL)
+ END SUBROUTINE
+
+ SUBROUTINE FM_ASIN(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMASIN(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_ATAN(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMATAN(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_ATN2(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMATN2(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_BIG(MA)
+ USE FMZM
+ TYPE ( FM ) MA
+ CALL FMBIG(MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_CHSH(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMCHSH(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ FUNCTION FM_COMP(MA,LREL,MB)
+ USE FMZM
+ LOGICAL FM_COMP,FMCOMP
+ TYPE ( FM ) MA,MB
+ CHARACTER(*) :: LREL
+ FM_COMP = FMCOMP(MA%MFM,LREL,MB%MFM)
+ END FUNCTION
+
+ SUBROUTINE FM_COS(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMCOS(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_COSH(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMCOSH(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_CSSN(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMCSSN(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_DIM(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMDIM(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_DIV(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMDIV(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_DIV_R1(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMDIV_R1(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_DIV_R2(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMDIV_R2(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_DIVI(MA,IVAL,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ INTEGER IVAL
+ CALL FMDIVI(MA%MFM,IVAL,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_DIVI_R1(MA,IVAL)
+ USE FMZM
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ CALL FMDIVI_R1(MA%MFM,IVAL)
+ END SUBROUTINE
+
+ SUBROUTINE FM_DP2M(X,MA)
+ USE FMZM
+ TYPE ( FM ) MA
+ DOUBLE PRECISION X
+ CALL FMDP2M(X,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_DPM(X,MA)
+ USE FMZM
+ TYPE ( FM ) MA
+ DOUBLE PRECISION X
+ CALL FMDPM(X,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_EQ(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMEQ(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_EQU(MA,MB,NA,NB)
+ USE FMZM
+ INTEGER NA,NB
+ TYPE ( FM ) MA,MB
+ CALL FMEQU(MA%MFM,MB%MFM,NA,NB)
+ END SUBROUTINE
+
+ SUBROUTINE FM_EXP(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMEXP(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_FORM(FORM,MA,STRING)
+ USE FMZM
+ CHARACTER(*) :: FORM,STRING
+ TYPE ( FM ) MA
+ CALL FMFORM(FORM,MA%MFM,STRING)
+ END SUBROUTINE
+
+ SUBROUTINE FM_FPRT(FORM,MA)
+ USE FMZM
+ CHARACTER(*) :: FORM
+ TYPE ( FM ) MA
+ CALL FMFPRT(FORM,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_I2M(IVAL,MA)
+ USE FMZM
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ CALL FMI2M(IVAL,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_INP(LINE,MA,LA,LB)
+ USE FMZM
+ INTEGER LA,LB
+ CHARACTER LINE(LB)
+ TYPE ( FM ) MA
+ CALL FMINP(LINE,MA%MFM,LA,LB)
+ END SUBROUTINE
+
+ SUBROUTINE FM_INT(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMINT(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_IPWR(MA,IVAL,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ INTEGER IVAL
+ CALL FMIPWR(MA%MFM,IVAL,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_LG10(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMLG10(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_LN(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMLN(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_LNI(IVAL,MA)
+ USE FMZM
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ CALL FMLNI(IVAL,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_M2DP(MA,X)
+ USE FMZM
+ TYPE ( FM ) MA
+ DOUBLE PRECISION X
+ CALL FMM2DP(MA%MFM,X)
+ END SUBROUTINE
+
+ SUBROUTINE FM_M2I(MA,IVAL)
+ USE FMZM
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ CALL FMM2I(MA%MFM,IVAL)
+ END SUBROUTINE
+
+ SUBROUTINE FM_M2SP(MA,X)
+ USE FMZM
+ TYPE ( FM ) MA
+ REAL X
+ CALL FMM2SP(MA%MFM,X)
+ END SUBROUTINE
+
+ SUBROUTINE FM_MAX(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMMAX(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_MIN(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMMIN(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_MOD(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMMOD(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_MPY(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMMPY(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_MPY_R1(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMMPY_R1(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_MPY_R2(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMMPY_R2(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_MPYI(MA,IVAL,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ INTEGER IVAL
+ CALL FMMPYI(MA%MFM,IVAL,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_MPYI_R1(MA,IVAL)
+ USE FMZM
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ CALL FMMPYI_R1(MA%MFM,IVAL)
+ END SUBROUTINE
+
+ SUBROUTINE FM_NINT(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMNINT(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_OUT(MA,LINE,LB)
+ USE FMZM
+ INTEGER LB
+ CHARACTER LINE(LB)
+ TYPE ( FM ) MA
+ CALL FMOUT(MA%MFM,LINE,LB)
+ END SUBROUTINE
+
+ SUBROUTINE FM_PI(MA)
+ USE FMZM
+ TYPE ( FM ) MA
+ CALL FMPI(MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_PRNT(MA)
+ USE FMZM
+ TYPE ( FM ) MA
+ CALL FMPRNT(MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_PWR(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMPWR(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_READ(KREAD,MA)
+ USE FMZM
+ INTEGER KREAD
+ TYPE ( FM ) MA
+ CALL FMREAD(KREAD,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_RPWR(MA,IVAL,JVAL,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ INTEGER IVAL,JVAL
+ CALL FMRPWR(MA%MFM,IVAL,JVAL,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_SET(NPREC)
+ INTEGER NPREC
+ CALL FMSET(NPREC)
+ END SUBROUTINE
+
+ SUBROUTINE FM_SIGN(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMSIGN(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_SIN(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMSIN(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_SINH(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMSINH(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_SP2M(X,MA)
+ USE FMZM
+ TYPE ( FM ) MA
+ REAL X
+ CALL FMSP2M(X,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_SQR(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMSQR(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_SQR_R1(MA)
+ USE FMZM
+ TYPE ( FM ) MA
+ CALL FMSQR_R1(MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_SQRT(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMSQRT(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_SQRT_R1(MA)
+ USE FMZM
+ TYPE ( FM ) MA
+ CALL FMSQRT_R1(MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_ST2M(STRING,MA)
+ USE FMZM
+ TYPE ( FM ) MA
+ CHARACTER(*) :: STRING
+ CALL FMST2M(STRING,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_SUB(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMSUB(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_SUB_R1(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMSUB_R1(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_SUB_R2(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMSUB_R2(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_TAN(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMTAN(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_TANH(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMTANH(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_ULP(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMULP(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_WRIT(KWRITE,MA)
+ USE FMZM
+ INTEGER KWRITE
+ TYPE ( FM ) MA
+ CALL FMWRIT(KWRITE,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_ABS(MA,MB)
+ USE FMZM
+ TYPE ( IM ) MA,MB
+ CALL IMABS(MA%MIM,MB%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_ADD(MA,MB,MC)
+ USE FMZM
+ TYPE ( IM ) MA,MB,MC
+ CALL IMADD(MA%MIM,MB%MIM,MC%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_BIG(MA)
+ USE FMZM
+ TYPE ( IM ) MA
+ CALL IMBIG(MA%MIM)
+ END SUBROUTINE
+
+ FUNCTION IM_COMP(MA,LREL,MB)
+ USE FMZM
+ LOGICAL IM_COMP,IMCOMP
+ TYPE ( IM ) MA,MB
+ CHARACTER(*) :: LREL
+ IM_COMP = IMCOMP(MA%MIM,LREL,MB%MIM)
+ END FUNCTION
+
+ SUBROUTINE IM_DIM(MA,MB,MC)
+ USE FMZM
+ TYPE ( IM ) MA,MB,MC
+ CALL IMDIM(MA%MIM,MB%MIM,MC%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_DIV(MA,MB,MC)
+ USE FMZM
+ TYPE ( IM ) MA,MB,MC
+ CALL IMDIV(MA%MIM,MB%MIM,MC%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_DIVI(MA,IVAL,MB)
+ USE FMZM
+ TYPE ( IM ) MA,MB
+ INTEGER IVAL
+ CALL IMDIVI(MA%MIM,IVAL,MB%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_DIVR(MA,MB,MC,MD)
+ USE FMZM
+ TYPE ( IM ) MA,MB,MC,MD
+ CALL IMDIVR(MA%MIM,MB%MIM,MC%MIM,MD%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_DVIR(MA,IVAL,MB,IREM)
+ USE FMZM
+ TYPE ( IM ) MA,MB
+ INTEGER IVAL,IREM
+ CALL IMDVIR(MA%MIM,IVAL,MB%MIM,IREM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_EQ(MA,MB)
+ USE FMZM
+ TYPE ( IM ) MA,MB
+ CALL IMEQ(MA%MIM,MB%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_FM2I(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA
+ TYPE ( IM ) MB
+ CALL IMFM2I(MA%MFM,MB%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_FORM(FORM,MA,STRING)
+ USE FMZM
+ CHARACTER(*) :: FORM,STRING
+ TYPE ( IM ) MA
+ CALL IMFORM(FORM,MA%MIM,STRING)
+ END SUBROUTINE
+
+ SUBROUTINE IM_FPRT(FORM,MA)
+ USE FMZM
+ CHARACTER(*) :: FORM
+ TYPE ( IM ) MA
+ CALL IMFPRT(FORM,MA%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_GCD(MA,MB,MC)
+ USE FMZM
+ TYPE ( IM ) MA,MB,MC
+ CALL IMGCD(MA%MIM,MB%MIM,MC%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_I2FM(MA,MB)
+ USE FMZM
+ TYPE ( IM ) MA
+ TYPE ( FM ) MB
+ CALL IMI2FM(MA%MIM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_I2M(IVAL,MA)
+ USE FMZM
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ CALL IMI2M(IVAL,MA%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_INP(LINE,MA,LA,LB)
+ USE FMZM
+ INTEGER LA,LB
+ CHARACTER LINE(LB)
+ TYPE ( IM ) MA
+ CALL IMINP(LINE,MA%MIM,LA,LB)
+ END SUBROUTINE
+
+ SUBROUTINE IM_M2DP(MA,X)
+ USE FMZM
+ TYPE ( IM ) MA
+ DOUBLE PRECISION X
+ CALL IMM2DP(MA%MIM,X)
+ END SUBROUTINE
+
+ SUBROUTINE IM_M2I(MA,IVAL)
+ USE FMZM
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ CALL IMM2I(MA%MIM,IVAL)
+ END SUBROUTINE
+
+ SUBROUTINE IM_MAX(MA,MB,MC)
+ USE FMZM
+ TYPE ( IM ) MA,MB,MC
+ CALL IMMAX(MA%MIM,MB%MIM,MC%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_MIN(MA,MB,MC)
+ USE FMZM
+ TYPE ( IM ) MA,MB,MC
+ CALL IMMIN(MA%MIM,MB%MIM,MC%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_MOD(MA,MB,MC)
+ USE FMZM
+ TYPE ( IM ) MA,MB,MC
+ CALL IMMOD(MA%MIM,MB%MIM,MC%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_MPY(MA,MB,MC)
+ USE FMZM
+ TYPE ( IM ) MA,MB,MC
+ CALL IMMPY(MA%MIM,MB%MIM,MC%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_MPYI(MA,IVAL,MB)
+ USE FMZM
+ TYPE ( IM ) MA,MB
+ INTEGER IVAL
+ CALL IMMPYI(MA%MIM,IVAL,MB%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_MPYM(MA,MB,MC,MD)
+ USE FMZM
+ TYPE ( IM ) MA,MB,MC,MD
+ CALL IMMPYM(MA%MIM,MB%MIM,MC%MIM,MD%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_OUT(MA,LINE,LB)
+ USE FMZM
+ INTEGER LB
+ CHARACTER LINE(LB)
+ TYPE ( IM ) MA
+ CALL IMOUT(MA%MIM,LINE,LB)
+ END SUBROUTINE
+
+ SUBROUTINE IM_PMOD(MA,MB,MC,MD)
+ USE FMZM
+ TYPE ( IM ) MA,MB,MC,MD
+ CALL IMPMOD(MA%MIM,MB%MIM,MC%MIM,MD%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_PRNT(MA)
+ USE FMZM
+ TYPE ( IM ) MA
+ CALL IMPRNT(MA%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_PWR(MA,MB,MC)
+ USE FMZM
+ TYPE ( IM ) MA,MB,MC
+ CALL IMPWR(MA%MIM,MB%MIM,MC%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_READ(KREAD,MA)
+ USE FMZM
+ INTEGER KREAD
+ TYPE ( IM ) MA
+ CALL IMREAD(KREAD,MA%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_SET(NPREC)
+ INTEGER NPREC
+ CALL FMSET(NPREC)
+ END SUBROUTINE
+
+ SUBROUTINE IM_SIGN(MA,MB,MC)
+ USE FMZM
+ TYPE ( IM ) MA,MB,MC
+ CALL IMSIGN(MA%MIM,MB%MIM,MC%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_SQR(MA,MB)
+ USE FMZM
+ TYPE ( IM ) MA,MB
+ CALL IMSQR(MA%MIM,MB%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_ST2M(STRING,MA)
+ USE FMZM
+ TYPE ( IM ) MA
+ CHARACTER(*) :: STRING
+ CALL IMST2M(STRING,MA%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_SUB(MA,MB,MC)
+ USE FMZM
+ TYPE ( IM ) MA,MB,MC
+ CALL IMSUB(MA%MIM,MB%MIM,MC%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE IM_WRIT(KWRITE,MA)
+ USE FMZM
+ INTEGER KWRITE
+ TYPE ( IM ) MA
+ CALL IMWRIT(KWRITE,MA%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_ABS(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA
+ TYPE ( FM ) MB
+ CALL ZMABS(MA%MZM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_ACOS(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMACOS(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_ADD(MA,MB,MC)
+ USE FMZM
+ TYPE ( ZM ) MA,MB,MC
+ CALL ZMADD(MA%MZM,MB%MZM,MC%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_ADDI(MA,IVAL)
+ USE FMZM
+ TYPE ( ZM ) MA
+ INTEGER IVAL
+ CALL ZMADDI(MA%MZM,IVAL)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_ARG(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA
+ TYPE ( FM ) MB
+ CALL ZMARG(MA%MZM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_ASIN(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMASIN(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_ATAN(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMATAN(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_CHSH(MA,MB,MC)
+ USE FMZM
+ TYPE ( ZM ) MA,MB,MC
+ CALL ZMCHSH(MA%MZM,MB%MZM,MC%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_CMPX(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ TYPE ( ZM ) MC
+ CALL ZMCMPX(MA%MFM,MB%MFM,MC%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_CONJ(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMCONJ(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_COS(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMCOS(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_COSH(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMCOSH(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_CSSN(MA,MB,MC)
+ USE FMZM
+ TYPE ( ZM ) MA,MB,MC
+ CALL ZMCSSN(MA%MZM,MB%MZM,MC%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_DIV(MA,MB,MC)
+ USE FMZM
+ TYPE ( ZM ) MA,MB,MC
+ CALL ZMDIV(MA%MZM,MB%MZM,MC%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_DIVI(MA,IVAL,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ INTEGER IVAL
+ CALL ZMDIVI(MA%MZM,IVAL,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_EQ(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMEQ(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_EQU(MA,MB,NA,NB)
+ USE FMZM
+ INTEGER NA,NB
+ TYPE ( ZM ) MA,MB
+ CALL ZMEQU(MA%MZM,MB%MZM,NA,NB)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_EXP(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMEXP(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_FORM(FORM1,FORM2,MA,STRING)
+ USE FMZM
+ CHARACTER(*) :: FORM1,FORM2,STRING
+ TYPE ( ZM ) MA
+ CALL ZMFORM(FORM1,FORM2,MA%MZM,STRING)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_FPRT(FORM1,FORM2,MA)
+ USE FMZM
+ CHARACTER(*) :: FORM1,FORM2
+ TYPE ( ZM ) MA
+ CALL ZMFPRT(FORM1,FORM2,MA%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_I2M(IVAL,MA)
+ USE FMZM
+ TYPE ( ZM ) MA
+ INTEGER IVAL
+ CALL ZMI2M(IVAL,MA%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_2I2M(IVAL1,IVAL2,MA)
+ USE FMZM
+ TYPE ( ZM ) MA
+ INTEGER IVAL1,IVAL2
+ CALL ZM2I2M(IVAL1,IVAL2,MA%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_IMAG(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA
+ TYPE ( FM ) MB
+ CALL ZMIMAG(MA%MZM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_INP(LINE,MA,LA,LB)
+ USE FMZM
+ INTEGER LA,LB
+ CHARACTER LINE(LB)
+ TYPE ( ZM ) MA
+ CALL ZMINP(LINE,MA%MZM,LA,LB)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_INT(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMINT(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_IPWR(MA,IVAL,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ INTEGER IVAL
+ CALL ZMIPWR(MA%MZM,IVAL,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_LG10(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMLG10(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_LN(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMLN(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_M2I(MA,IVAL)
+ USE FMZM
+ TYPE ( ZM ) MA
+ INTEGER IVAL
+ CALL ZMM2I(MA%MZM,IVAL)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_M2Z(MA,ZVAL)
+ USE FMZM
+ TYPE ( ZM ) MA
+ COMPLEX ZVAL
+ CALL ZMM2Z(MA%MZM,ZVAL)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_MPY(MA,MB,MC)
+ USE FMZM
+ TYPE ( ZM ) MA,MB,MC
+ CALL ZMMPY(MA%MZM,MB%MZM,MC%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_MPYI(MA,IVAL,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ INTEGER IVAL
+ CALL ZMMPYI(MA%MZM,IVAL,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_NINT(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMNINT(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_OUT(MA,LINE,LB,LAST1,LAST2)
+ USE FMZM
+ INTEGER LB,LAST1,LAST2
+ CHARACTER LINE(LB)
+ TYPE ( ZM ) MA
+ CALL ZMOUT(MA%MZM,LINE,LB,LAST1,LAST2)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_PRNT(MA)
+ USE FMZM
+ TYPE ( ZM ) MA
+ CALL ZMPRNT(MA%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_PWR(MA,MB,MC)
+ USE FMZM
+ TYPE ( ZM ) MA,MB,MC
+ CALL ZMPWR(MA%MZM,MB%MZM,MC%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_READ(KREAD,MA)
+ USE FMZM
+ INTEGER KREAD
+ TYPE ( ZM ) MA
+ CALL ZMREAD(KREAD,MA%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_REAL(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA
+ TYPE ( FM ) MB
+ CALL ZMREAL(MA%MZM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_RPWR(MA,IVAL,JVAL,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ INTEGER IVAL,JVAL
+ CALL ZMRPWR(MA%MZM,IVAL,JVAL,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_SET(NPREC)
+ INTEGER NPREC
+ CALL ZMSET(NPREC)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_SIN(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMSIN(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_SINH(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMSINH(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_SQR(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMSQR(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_SQRT(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMSQRT(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_ST2M(STRING,MA)
+ USE FMZM
+ TYPE ( ZM ) MA
+ CHARACTER(*) :: STRING
+ CALL ZMST2M(STRING,MA%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_SUB(MA,MB,MC)
+ USE FMZM
+ TYPE ( ZM ) MA,MB,MC
+ CALL ZMSUB(MA%MZM,MB%MZM,MC%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_TAN(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMTAN(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_TANH(MA,MB)
+ USE FMZM
+ TYPE ( ZM ) MA,MB
+ CALL ZMTANH(MA%MZM,MB%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_WRIT(KWRITE,MA)
+ USE FMZM
+ INTEGER KWRITE
+ TYPE ( ZM ) MA
+ CALL ZMWRIT(KWRITE,MA%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE ZM_Z2M(ZVAL,MA)
+ USE FMZM
+ TYPE ( ZM ) MA
+ COMPLEX ZVAL
+ CALL ZMZ2M(ZVAL,MA%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_BERN(N,MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ INTEGER N
+ CALL FMBERN(N,MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_BETA(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMBETA(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_COMB(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMCOMB(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_EULR(MA)
+ USE FMZM
+ TYPE ( FM ) MA
+ CALL FMEULR(MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_FACT(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMFACT(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_GAM(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMGAM(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_IBTA(MA,MB,MC,MD)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC,MD
+ CALL FMIBTA(MA%MFM,MB%MFM,MC%MFM,MD%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_IGM1(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMIGM1(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_IGM2(MA,MB,MC)
+ USE FMZM
+ TYPE ( FM ) MA,MB,MC
+ CALL FMIGM2(MA%MFM,MB%MFM,MC%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_LNGM(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMLNGM(MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_PGAM(N,MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ INTEGER N
+ CALL FMPGAM(N,MA%MFM,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_POCH(MA,N,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ INTEGER N
+ CALL FMPOCH(MA%MFM,N,MB%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FM_PSI(MA,MB)
+ USE FMZM
+ TYPE ( FM ) MA,MB
+ CALL FMPSI(MA%MFM,MB%MFM)
+ END SUBROUTINE
diff --git a/src/fmlib/FMSAVE.F90 b/src/fmlib/FMSAVE.F90
new file mode 100644
index 0000000000000000000000000000000000000000..864b714a3d9a8c440684e141afa4c1d4c01fdf70
--- /dev/null
+++ b/src/fmlib/FMSAVE.F90
@@ -0,0 +1,544 @@
+ MODULE FMVALS
+
+! These are the global and saved variables used by the FM and ZM packages.
+! See the User's Manual in the ReadMe file for further description of some
+! of these variables.
+
+! They are initialized assuming the program will run on a 32-bit computer
+! with variables in FM.f having names beginning with 'M' being declared
+! as having 64-bit representations (DOUBLE PRECISION).
+
+! For a machine with a different architecture, or for setting the precision
+! level to a different value, CALL FMSET(NPREC) before doing any multiple
+! precision operations. FMSET tries to initialize the variables to the
+! best values for the given machine. To have the values chosen by FMSET
+! written on unit KW, CALL FMVARS.
+
+! Base and precision will be set to give slightly more than 50 decimal
+! digits of precision, giving the user 50 significant digits of precision
+! along with several base ten guard digits.
+
+! MBASE is set to 10**7.
+! JFORM1 and JFORM2 are set to 1PE format displaying 50 significant digits.
+
+! The trace option is set off.
+! The mode for angles in trig functions is set to radians.
+! The rounding mode is set to symmetric rounding (to nearest), with the
+! option for perfect rounding off.
+! Warning error message level is set to 1.
+! Cancellation error monitor is set off.
+! Screen width for output is set to 80 columns.
+! The exponent character for FM output is set to 'M'.
+! Debug error checking is set off.
+
+! KW, the unit number for all FM output, is set to 6.
+
+! The size of all arrays is controlled by defining two parameters:
+! NDIGMX is the maximum value the user can set NDIG,
+! NBITS is an upper bound for the number of bits used to represent
+! integers in an M-variable word.
+
+ INTEGER, PARAMETER :: NDIGMX = 55
+! Integer initialization
+! INTEGER, PARAMETER :: NDIGMX = 80
+ INTEGER, PARAMETER :: NBITS = 64
+
+ INTEGER, PARAMETER :: LPACK = (NDIGMX+1)/2 + 1
+ INTEGER, PARAMETER :: LUNPCK = (11*NDIGMX)/5 + 30
+ INTEGER, PARAMETER :: LMWA = 2*LUNPCK
+ INTEGER, PARAMETER :: LJSUMS = 8*(LUNPCK+3)
+ INTEGER, PARAMETER :: LMBUFF = ((LUNPCK+4)*(NBITS-1)*301)/2000 + 6
+
+! KW is the unit number for standard output from the
+! FM package. This includes trace output and error
+! messages.
+
+ INTEGER, SAVE :: KW = 6
+
+! MAXINT should be set to a very large integer, possibly
+! the largest representable integer for the current
+! machine. For most 32-bit machines, MAXINT is set
+! to 2**53 - 1 = 9.007D+15 when double precision
+! arithmetic is used for M-variables. Using integer
+! M-variables usually gives MAXINT = 2**31 - 1 =
+! 2147483647.
+! Setting MAXINT to a smaller number is ok, but this
+! unnecessarily restricts the permissible range of
+! MBASE and MXEXP.
+
+ REAL (KIND(1.0D0)), SAVE :: MAXINT = 9007199254740991.0D0
+! Integer initialization
+! INTEGER, SAVE :: MAXINT = 2147483647
+
+! INTMAX is a large value close to the overflow threshold
+! for integer variables. It is usually 2**31 - 1
+! for machines with 32-bit integer arithmetic.
+
+ INTEGER, SAVE :: INTMAX = 2147483647
+
+! DPMAX should be set to a value near the machine's double
+! precision overflow threshold, so that DPMAX and
+! 1.0D0/DPMAX are both representable in double
+! precision.
+
+ DOUBLE PRECISION, SAVE :: DPMAX = 1.797D+308/5.0D0
+
+! SPMAX should be set to a value near the machine's single
+! precision overflow threshold, so that 1.01*SPMAX
+! and 1.0/SPMAX are both representable in single
+! precision.
+
+ REAL, SAVE :: SPMAX = 3.40E+38/5.0
+
+! NDG2MX is the maximum value for NDIG that can be used
+! internally. FM routines may raise NDIG above
+! NDIGMX temporarily, to compute correctly
+! rounded results.
+! In the definition of LUNPCK, the '11/5' condition
+! allows for carrying at least NDIG guard digits
+! when the option for perfect rounding is selected.
+! The '+ 30' condition allows for the need to carry
+! many guard digits when using a small base like 2.
+
+ INTEGER, PARAMETER :: NDG2MX = LUNPCK - 2
+
+! MXBASE is the maximum value for MBASE.
+
+ REAL (KIND(1.0D0)), SAVE :: MXBASE = 94906265.0D0
+! Integer initialization
+! INTEGER, SAVE :: MXBASE = 46340
+
+! MBASE is the currently used base for arithmetic.
+
+ REAL (KIND(1.0D0)), SAVE :: MBASE = 1.0D7
+! Integer initialization
+! INTEGER, SAVE :: MBASE = 10000
+
+! NDIG is the number of digits currently being carried.
+
+ INTEGER, SAVE :: NDIG = 9
+! Integer initialization
+! INTEGER, SAVE :: NDIG = 14
+
+! KFLAG is the flag for error conditions.
+
+ INTEGER, SAVE :: KFLAG = 0
+
+! NTRACE is the trace switch. Default is no printing.
+
+ INTEGER, SAVE :: NTRACE = 0
+
+! LVLTRC is the trace level. Default is to trace only
+! routines called directly by the user.
+
+ INTEGER, SAVE :: LVLTRC = 1
+
+! NCALL is the call stack pointer.
+
+ INTEGER, SAVE :: NCALL = 0
+
+! NAMEST is the call stack.
+
+ INTEGER, PRIVATE :: I
+ CHARACTER(6), SAVE :: NAMEST(0:50) = (/ ('MAIN ' , I = 0, 50) /)
+
+! Some constants that are often needed are stored with the
+! maximum precision to which they have been computed in the
+! currently used base. This speeds up the trig, log, power,
+! and exponential functions.
+
+! NDIGPI is the number of digits available in the currently
+! stored value of pi (MPISAV).
+
+ INTEGER, SAVE :: NDIGPI = 0
+
+! MBSPI is the value of MBASE for the currently stored
+! value of pi.
+
+ REAL (KIND(1.0D0)), SAVE :: MBSPI = 0.0D0
+! Integer initialization
+! INTEGER, SAVE :: MBSPI = 0
+
+! NDIGE is the number of digits available in the currently
+! stored value of e (MESAV).
+
+ INTEGER, SAVE :: NDIGE = 0
+
+! MBSE is the value of MBASE for the currently stored
+! value of e.
+
+ REAL (KIND(1.0D0)), SAVE :: MBSE = 0.0D0
+! Integer initialization
+! INTEGER, SAVE :: MBSE = 0
+
+! NDIGLB is the number of digits available in the currently
+! stored value of LN(MBASE) (MLBSAV).
+
+ INTEGER, SAVE :: NDIGLB = 0
+
+! MBSLB is the value of MBASE for the currently stored
+! value of LN(MBASE).
+
+ REAL (KIND(1.0D0)), SAVE :: MBSLB = 0.0D0
+! Integer initialization
+! INTEGER, SAVE :: MBSLB = 0
+
+! NDIGLI is the number of digits available in the currently
+! stored values of the four logarithms used by FMLNI
+! MLN1 - MLN4.
+
+ INTEGER, SAVE :: NDIGLI = 0
+
+! MBSLI is the value of MBASE for the currently stored
+! values of MLN1 - MLN4.
+
+ REAL (KIND(1.0D0)), SAVE :: MBSLI = 0.0D0
+! Integer initialization
+! INTEGER, SAVE :: MBSLI = 0
+
+! MXEXP is the current maximum exponent.
+! MXEXP2 is the internal maximum exponent. This is used to
+! define the overflow and underflow thresholds.
+!
+! These values are chosen so that FM routines can raise the
+! overflow/underflow limit temporarily while computing
+! intermediate results, and so that EXP(INTMAX) is greater
+! than MXBASE**(MXEXP2+1).
+!
+! The overflow threshold is MBASE**(MXEXP+1), and the
+! underflow threshold is MBASE**(-MXEXP-1).
+! This means the valid exponents in the first word of an FM
+! number can range from -MXEXP to MXEXP+1 (inclusive).
+
+ REAL (KIND(1.0D0)), SAVE :: MXEXP = 58455923.0D0
+! Integer initialization
+! INTEGER, SAVE :: MXEXP = 99940964
+
+ REAL (KIND(1.0D0)), SAVE :: MXEXP2 = 117496405.0D0
+! Integer initialization
+! INTEGER, SAVE :: MXEXP2 = 200881337
+
+! KACCSW is a switch used to enable cancellation error
+! monitoring. Routines where cancellation is
+! not a problem run faster by skipping the
+! cancellation monitor calculations.
+! KACCSW = 0 means no error monitoring,
+! = 1 means error monitoring is done.
+
+ INTEGER, SAVE :: KACCSW = 0
+
+! MEXPUN is the exponent used as a special symbol for
+! underflowed results.
+
+ REAL (KIND(1.0D0)), SAVE :: MEXPUN = -118671369.0D0
+! Integer initialization
+! INTEGER, SAVE :: MEXPUN = -202890150
+
+! MEXPOV is the exponent used as a special symbol for
+! overflowed results.
+
+ REAL (KIND(1.0D0)), SAVE :: MEXPOV = 118671369.0D0
+! Integer initialization
+! INTEGER, SAVE :: MEXPOV = 202890150
+
+! MUNKNO is the exponent used as a special symbol for
+! unknown FM results (1/0, SQRT(-3.0), ...).
+
+ REAL (KIND(1.0D0)), SAVE :: MUNKNO = 119858082.0D0
+! Integer initialization
+! INTEGER, SAVE :: MUNKNO = 204919051
+
+! RUNKNO is returned from FM to real or double conversion
+! routines when no valid result can be expressed in
+! real or double precision. On systems that provide
+! a value for undefined results (e.g., Not A Number)
+! setting RUNKNO to that value is reasonable. On
+! other systems set it to a value that is likely to
+! make any subsequent results obviously wrong that
+! use it. In either case a KFLAG = -4 condition is
+! also returned.
+
+ REAL, SAVE :: RUNKNO = -1.01*(3.40E+38/3.0)
+
+! IUNKNO is returned from FM to integer conversion routines
+! when no valid result can be expressed as a one word
+! integer. KFLAG = -4 is also set.
+
+ INTEGER, SAVE :: IUNKNO = -117496405
+
+! JFORM1 indicates the format used by FMOUT.
+
+ INTEGER, SAVE :: JFORM1 = 1
+
+! JFORM2 indicates the number of digits used in FMOUT.
+
+ INTEGER, SAVE :: JFORM2 = 50
+
+! KRAD = 1 indicates that trig functions use radians,
+! = 0 means use degrees.
+
+ INTEGER, SAVE :: KRAD = 1
+
+! KWARN = 0 indicates that no warning message is printed
+! and execution continues when UNKNOWN or another
+! exception is produced.
+! = 1 means print a warning message and continue.
+! = 2 means print a warning message and stop.
+
+ INTEGER, SAVE :: KWARN = 1
+
+! KROUND = 1 causes all results to be rounded to the
+! nearest FM number, or to the value with
+! an even last digit if the result is halfway
+! between two FM numbers.
+! = 0 causes all results to be rounded toward zero
+! (chopped).
+! = -1 causes all results to be rounded toward minus
+! infinity.
+! = 2 causes all results to be rounded toward plus
+! infinity.
+! Regardless of KROUND, when an FM function is called
+! all intermediate operations are rounded to nearest.
+! Only the final result returned to the user is rounded
+! according to KROUND.
+
+ INTEGER, SAVE :: KROUND = 1
+
+! KRPERF = 1 causes more guard digits to be used, to get
+! perfect rounding in the mode set by KROUND.
+! This slows execution speed.
+! = 0 causes a smaller number of guard digits used,
+! to give nearly perfect rounding. This number
+! is chosen so that the last intermediate result
+! should have error less than 0.001 unit in the
+! last place of the final rounded result.
+
+ INTEGER, SAVE :: KRPERF = 0
+
+! KSWIDE defines the maximum screen width to be used for
+! all unit KW output.
+
+ INTEGER, SAVE :: KSWIDE = 80
+
+! KESWCH = 1 causes input to FMINP with no digits before
+! the exponent letter to be treated as if there
+! were a leading '1'. This is sometimes better
+! for interactive input: 'E7' converts to
+! 10.0**7.
+! = 0 causes a leading zero to be assumed. This
+! gives compatibility with Fortran: 'E7'
+! converts to 0.0.
+
+ INTEGER, SAVE :: KESWCH = 1
+
+! CMCHAR defines the exponent letter to be used for
+! FM variable output from FMOUT, as in 1.2345M+678.
+! Change it to 'E' for output to be read by a
+! non-FM program.
+
+ CHARACTER, SAVE :: CMCHAR = 'M'
+
+! KSUB is an internal flag set during subtraction so that
+! the addition routine will negate its second argument.
+
+ INTEGER, SAVE :: KSUB = 0
+
+! JRSIGN is an internal flag set during arithmetic operations
+! so that the rounding routine will know the sign of the
+! final result.
+
+ INTEGER, SAVE :: JRSIGN = 0
+
+! KDEBUG = 0 Error checking is not done for valid input
+! arguments and parameters like NDIG and MBASE
+! upon entry to each routine.
+! = 1 Error checking is done.
+
+ INTEGER, SAVE :: KDEBUG = 0
+
+! LHASH is a flag variable used to indicate when to initialize
+! two hash tables that are used for character look-up
+! during input conversion. LHASH = 1 means that the tables
+! have been built.
+! LHASH1 and LHASH2 are the array dimensions of the tables.
+! KHASHT and KHASHV are the two tables.
+
+ INTEGER, SAVE :: LHASH = 0
+ INTEGER, PARAMETER :: LHASH1 = 0
+ INTEGER, PARAMETER :: LHASH2 = 256
+ INTEGER, SAVE :: KHASHT(LHASH1:LHASH2),KHASHV(LHASH1:LHASH2)
+
+! DPEPS is the approximate machine precision.
+
+ DOUBLE PRECISION, SAVE :: DPEPS = 2.220446049250313D-16
+
+! Saved constants that depend on MBASE.
+
+ REAL (KIND(1.0D0)), SAVE :: MBLOGS = 1.0D7
+! Integer initialization
+! INTEGER, SAVE :: MBLOGS = 0
+! (Setting MBLOGS to zero here will cause the other variables that
+! depend on MBASE to automatically be defined when the first FM
+! operation is done.)
+
+ REAL, SAVE :: ALOGMB = 1.611810E+1
+ REAL, SAVE :: ALOGM2 = 2.325350E+1
+ REAL, SAVE :: ALOGMX = 3.673680E+1
+ REAL, SAVE :: ALOGMT = 7.0E0
+
+ INTEGER, SAVE :: NGRD21 = 1
+ INTEGER, SAVE :: NGRD52 = 2
+ INTEGER, SAVE :: NGRD22 = 2
+ REAL (KIND(1.0D0)), SAVE :: MEXPAB = 2.3499281D+7
+! Integer initialization
+! INTEGER, SAVE :: MEXPAB = 23499281
+
+ DOUBLE PRECISION, SAVE :: DLOGMB = 1.611809565095832D+1
+ DOUBLE PRECISION, SAVE :: DLOGTN = 2.302585092994046D+0
+ DOUBLE PRECISION, SAVE :: DLOGTW = 6.931471805599453D-1
+ DOUBLE PRECISION, SAVE :: DPPI = 3.141592653589793D+0
+ DOUBLE PRECISION, SAVE :: DLOGTP = 1.837877066409345D+0
+ DOUBLE PRECISION, SAVE :: DLOGPI = 1.144729885849400D+0
+ DOUBLE PRECISION, SAVE :: DLOGEB = 2.236222824932432D+0
+
+ REAL (KIND(1.0D0)), SAVE :: MBASEL = 0.0D0
+! Integer initialization
+! INTEGER, SAVE :: MBASEL = 0
+ REAL (KIND(1.0D0)), SAVE :: MBASEN = 0.0D0
+! Integer initialization
+! INTEGER, SAVE :: MBASEN = 0
+
+ INTEGER, SAVE :: NDIGL = 0
+ INTEGER, SAVE :: NDIGN = 0
+ INTEGER, SAVE :: NGUARL = 0
+ INTEGER, SAVE :: N21
+ INTEGER, SAVE :: NGRDN
+
+! These variables are used by FM_RANDOM_NUMBER.
+! MBRAND is the base used for the random number arithmetic.
+! It needs to remain the same even if the user changes MBASE.
+
+ REAL (KIND(1.0D0)), SAVE :: MBRAND = 1.0D7
+! Integer initialization
+! INTEGER, SAVE :: MBRAND = 10000
+
+ REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPCK) :: MRNX,MRNA,MRNM,MRNC
+ INTEGER, SAVE :: START_RANDOM_SEQUENCE = -1
+
+! Work areas for temporary FM calculations.
+
+ REAL (KIND(1.0D0)), SAVE, DIMENSION(1:LMWA) :: MWA,MWD,MWE
+ REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPCK) :: &
+ MPA,MPB,MPC,MPD,MPMA,MPMB, &
+ MLV2,MLV3,MLV4,MLV5, &
+ M01,M02,M03,M04,M05,M06,M07,M08,M09,M10, &
+ M11,M12,M13,M14,M15,M16,M17,M18,M19,M20, &
+ M21,M22,M23,M24,M25,M26,M27,M28,M29,M30, &
+ M31,M32,M33,M34,M35,M36,M37,M38,M39,M40, &
+ M41,M42,M43,M44,M45
+ REAL (KIND(1.0D0)), SAVE :: MJSUMS(-1:LJSUMS)
+ INTEGER, SAVE :: NDIGMX_BASE = 0
+ CHARACTER, SAVE :: CMBUFF(LMBUFF)
+
+! Saved FM constants.
+
+ REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPCK) :: MPISAV,MESAV, &
+ MLBSAV,MLN1,MLN2,MLN3,MLN4
+
+! Set JFORMZ to ' 1.23 + 4.56 i ' format.
+
+ INTEGER, SAVE :: JFORMZ = 1
+
+! Set JPRNTZ to print real and imaginary parts on one
+! line whenever possible.
+
+ INTEGER, SAVE :: JPRNTZ = 1
+
+! These arrays are work areas for temporary ZM calculations.
+
+ INTEGER, PARAMETER :: LPACKZ = 2*LPACK+2
+ INTEGER, PARAMETER :: LUNPKZ = 2*LUNPCK+2
+ INTEGER, PARAMETER :: KPTIMP = LPACK+1
+ INTEGER, PARAMETER :: KPTIMU = LUNPCK+1
+ REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPKZ) :: MZ01,MZ02, &
+ MZ03,MZ04,MZ05,MZ06,MZ07,MZ08,MPX,MPY,MPZ
+ INTEGER, PARAMETER :: LMBUFZ = 2*LMBUFF+10
+ CHARACTER, SAVE, DIMENSION(LMBUFZ) :: CMBUFZ
+
+! MBERN is the array used to save Bernoulli numbers so they
+! do not have to be re-computed on subsequent calls.
+! MBSBRN is the value of MBASE for the currently saved
+! Bernoulli numbers.
+
+ REAL (KIND(1.0D0)), SAVE :: MBSBRN = 0.0D0
+! Integer initialization
+! INTEGER, SAVE :: MBSBRN = 0
+
+! NWDBRN is the total number of words used for the saved
+! Bernoulli numbers.
+
+ INTEGER, SAVE :: NWDBRN = 0
+
+! NUMBRN is the number of the largest Bernoulli number
+! saved using base MBSBRN.
+
+ INTEGER, SAVE :: NUMBRN = 0
+
+! LMBERN is the size of the array MBERN for saving Bernoulli numbers.
+
+ INTEGER, PARAMETER :: LMBERN = 250000
+ REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LMBERN) :: MBERN
+
+! B(2N) starts in MBERN(NPTBRN(N)) for 2N >= 28.
+! NPTBRN(N) is -1 if B(2N) has not been computed
+! previously.
+
+ INTEGER, SAVE :: NPTBRN(LMBERN/10) = (/ (-1 , I = 1, LMBERN/10) /)
+
+! M_EULER is the saved value of Euler's constant.
+! M_GAMMA_MA is the last input value to FMGAM, and
+! M_GAMMA_MB is the corresponding output value.
+! M_LN_2PI holds the saved value of LN(2*pi).
+
+ REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPCK) :: &
+ M_EULER,M_GAMMA_MA,M_GAMMA_MB,M_LN_2PI
+
+! MBSGAM is the value of MBASE used in the currently stored
+! value of M_GAMMA_MA and M_GAMMA_MB.
+! NDGGAM is the maximum NDIG used in the currently stored
+! value of M_GAMMA_MA and M_GAMMA_MB.
+
+ REAL (KIND(1.0D0)), SAVE :: MBSGAM = 0.0D0
+! Integer initialization
+! INTEGER, SAVE :: MBSGAM = 0
+
+ INTEGER, SAVE :: NDGGAM = 0
+
+! MBS2PI is the value of MBASE used in the currently stored
+! value of LN(2*pi).
+! NDG2PI is the maximum NDIG used in the currently stored
+! value of LN(2*pi).
+
+ REAL (KIND(1.0D0)), SAVE :: MBS2PI = 0.0D0
+! Integer initialization
+! INTEGER, SAVE :: MBS2PI = 0
+
+ INTEGER, SAVE :: NDG2PI = 0
+
+! MBSEUL is the value of MBASE used in the currently stored
+! value of M_EULER.
+! NDGEUL is the maximum NDIG used in the currently stored
+! value of M_EULER.
+
+ REAL (KIND(1.0D0)), SAVE :: MBSEUL = 0.0D0
+! Integer initialization
+! INTEGER, SAVE :: MBSEUL = 0
+
+ INTEGER, SAVE :: NDGEUL = 0
+
+! MRETRY is used to detect convergence in some cases where
+! cancellation error forces a retry.
+
+ REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPCK) :: MRETRY
+
+ END MODULE
diff --git a/src/fmlib/FMZM90.F90 b/src/fmlib/FMZM90.F90
new file mode 100644
index 0000000000000000000000000000000000000000..5c309b48576bb60b4592dfd29049a14c314a5b6b
--- /dev/null
+++ b/src/fmlib/FMZM90.F90
@@ -0,0 +1,7396 @@
+ MODULE FMZM_1
+
+! FMZM 1.2 David M. Smith
+
+! This module extends the definition of Fortran-90 arithmetic and function
+! operations so they also apply to multiple precision numbers, using version
+! 1.2 of FM.
+! There are three multiple precision data types:
+! FM (multiple precision real)
+! IM (multiple precision integer)
+! ZM (multiple precision complex)
+
+! Some of the interface routines assume that the precision chosen in the
+! calling program (using FMSET) represents more significant digits than does
+! the machine's double precision.
+
+! Most of the functions defined in this module are multiple precision versions
+! of standard Fortran-90 functions. In addition, there are functions for
+! direct conversion, formatting, and some mathematical special functions.
+
+! TO_FM is a function for converting other types of numbers to type FM. Note
+! that TO_FM(3.12) converts the REAL constant to FM, but it is accurate only
+! to single precision. TO_FM(3.12D0) agrees with 3.12 to double precision
+! accuracy, and TO_FM('3.12') or TO_FM(312)/TO_FM(100) agrees to full FM
+! accuracy.
+
+! TO_IM converts to type IM, and TO_ZM converts to type ZM.
+
+! Functions are also supplied for converting the three multiple precision types
+! to the other numeric data types:
+! TO_INT converts to machine precision integer
+! TO_SP converts to single precision
+! TO_DP converts to double precision
+! TO_SPZ converts to single precision complex
+! TO_DPZ converts to double precision complex
+
+! WARNING: When multiple precision type declarations are inserted in an
+! existing program, take care in converting functions like DBLE(X),
+! where X has been declared as a multiple precision type. If X
+! was single precision in the original program, then replacing
+! the DBLE(X) by TO_DP(X) in the new version could lose accuracy.
+! For this reason, the Fortran type-conversion functions defined
+! in this module assume that results should be multiple precision
+! whenever inputs are. Examples:
+! DBLE(TO_FM('1.23E+123456')) is type FM
+! REAL(TO_FM('1.23E+123456')) is type FM
+! REAL(TO_ZM('3.12+4.56i')) is type FM = TO_FM('3.12')
+! INT(TO_FM('1.23')) is type IM = TO_IM(1)
+! INT(TO_IM('1E+23')) is type IM
+! CMPLX(TO_FM('1.23'),TO_FM('4.56')) is type ZM
+
+! Programs using this module may sometimes need to call FM, IM, or ZM routines
+! directly. This is normally the case when routines are needed that are not
+! Fortran-90 intrinsics, such as the formatting subroutine FMFORM. In a
+! program using this module, suppose MAFM has been declared with
+! TYPE ( FM ) MAFM. To use the routine FMFORM, which expects the second
+! argument to be an array and not a derived type, the call would have to be
+! CALL FMFORM('F65.60',MAFM%MFM,ST1) so that the array contained in MAFM is
+! passed.
+
+! As an alternative so the user can refer directly to the FM-, IM-, and ZM-type
+! variables and avoid the cumbersome "%MFM" suffixes, the FM package provides a
+! collection of interface routines to supply any needed argument conversions.
+! For each FM, IM, and ZM routine that is designed to be called by the user,
+! there is also a version that assumes any multiple-precision arguments are
+! derived types instead of arrays. Each interface routine has the same name as
+! the original with an underscore after the first two letters of the routine
+! name. To convert the number to a character string with F65.60 format, use
+! CALL FM_FORM('F65.60',MAFM,ST1) if MAFM is of TYPE ( FM ), or use
+! CALL FMFORM('F65.60',MA,ST1) if MA is declared as an array. All the routines
+! shown below may be used this way.
+
+! For each of the operations =, == , /= , < , <= , > , >= , +, -, *, /,
+! and **, the interface module defines all mixed mode variations involving one
+! of the three multiple precision derived types and another argument having one
+! of the types: { integer, real, double, complex, complex double, FM, IM, ZM }.
+! So mixed mode expressions such as
+! MAFM = 12
+! MAFM = MAFM + 1
+! IF (ABS(MAFM) > 1.0D-23) THEN
+! are handled correctly.
+
+! Not all the named functions are defined for all three multiple precision
+! derived types, so the list below shows which can be used. The labels "real",
+! "integer", and "complex" refer to types FM, IM, and ZM respectively, "string"
+! means the function accepts character strings (e.g., TO_FM('3.45')), and
+! "other" means the function can accept any of the machine precision data types
+! integer, real, double, complex, or complex double. For functions that accept
+! two or more arguments, like ATAN2 or MAX, all the arguments must be of the
+! same type.
+
+
+! AVAILABLE OPERATIONS:
+
+! =
+! +
+! -
+! *
+! /
+! **
+! ==
+! /=
+! <
+! <=
+! >
+! >=
+! ABS real integer complex
+! ACOS real complex
+! AIMAG complex
+! AINT real complex
+! ANINT real complex
+! ASIN real complex
+! ATAN real complex
+! ATAN2 real
+! BTEST integer
+! CEILING real complex
+! CMPLX real integer
+! CONJ complex
+! COS real complex
+! COSH real complex
+! DBLE real integer complex
+! DIGITS real integer complex
+! DIM real integer
+! DINT real complex
+! DOTPRODUCT real integer complex
+! EPSILON real
+! EXP real complex
+! EXPONENT real
+! FLOOR real integer complex
+! FRACTION real complex
+! HUGE real integer complex
+! INT real integer complex
+! LOG real complex
+! LOG10 real complex
+! MATMUL real integer complex
+! MAX real integer
+! MAXEXPONENT real
+! MIN real integer
+! MINEXPONENT real
+! MOD real integer
+! MODULO real integer
+! NEAREST real
+! NINT real integer complex
+! PRECISION real complex
+! RADIX real integer complex
+! RANGE real integer complex
+! REAL real integer complex
+! RRSPACING real
+! SCALE real complex
+! SETEXPONENT real
+! SIGN real integer
+! SIN real complex
+! SINH real complex
+! SPACING real
+! SQRT real complex
+! TAN real complex
+! TANH real complex
+! TINY real integer complex
+! TO_FM real integer complex string other
+! TO_IM real integer complex string other
+! TO_ZM real integer complex string other
+! TO_INT real integer complex
+! TO_SP real integer complex
+! TO_DP real integer complex
+! TO_SPZ real integer complex
+! TO_DPZ real integer complex
+
+! Some other functions are defined that do not correspond to machine precision
+! intrinsic functions. These include formatting functions, integer modular
+! functions and GCD, and the Gamma function and its related functions.
+! N below is a machine precision integer, J1, J2, J3 are TYPE (IM), FMT, FMTR,
+! FMTI are character strings, A,B,X are TYPE (FM), and Z is TYPE (ZM).
+! The three formatting functions return a character string containing the
+! formatted number, the three TYPE (IM) functions return a TYPE (IM) result,
+! and the 12 special functions return TYPE (FM) results.
+
+! Formatting functions:
+
+! FM_FORMAT(FMT,A) Put A into FMT (real) format
+! IM_FORMAT(FMT,J1) Put J1 into FMT (integer) format
+! ZM_FORMAT(FMTR,FMTI,Z) Put Z into (complex) format, FMTR for the real
+! part and FMTI for the imaginary part
+
+! Examples:
+! ST = FM_FORMAT('F65.60',A)
+! WRITE (*,*) ' A = ',TRIM(ST)
+! ST = FM_FORMAT('E75.60',B)
+! WRITE (*,*) ' B = ',ST(1:75)
+! ST = IM_FORMAT('I50',J1)
+! WRITE (*,*) ' J1 = ',ST(1:50)
+! ST = ZM_FORMAT('F35.30','F30.25',Z)
+! WRITE (*,*) ' Z = ',ST(1:70)
+
+! These functions are used for one-line output. The returned character
+! strings are of length 200. Avoid using the formatting function in the
+! write list, as in
+! WRITE (*,*) ' J1 = ',IM_FORMAT('I50',J1)(1:50)
+! since the formatting functions may themselves execute an internal WRITE
+! and that would cause a recursive write reference.
+
+! For higher precision numbers, the output can be broken onto multiple
+! lines automatically by calling subroutines FM_PRNT, IM_PRNT, ZM_PRNT,
+! or the line breaks can be done by hand after calling one of the
+! subroutines FM_FORM, IM_FORM, ZM_FORM.
+
+! For ZM_FORMAT the length of the output is 5 more than the sum of the
+! two field widths.
+
+! Integer functions:
+
+! GCD(J1,J2) Greatest Common Divisor of J1 and J2.
+! MULTIPLY_MOD(J1,J2,J3) J1 * J2 mod J3
+! POWER_MOD(J1,J2,J3) J1 ** J2 mod J3
+
+! Special functions:
+
+! BERNOULLI(N) Nth Bernoulli number
+! BETA(A,B) Integral (0 to 1) t**(A-1) * (1-t)**(B-1) dt
+! BINOMIAL(A,B) Binomial Coefficient A! / ( B! (A-B)! )
+! FACTORIAL(A) A!
+! GAMMA(A) Integral (0 to infinity) t**(A-1) * exp(-t) dt
+! INCOMPLETE_BETA(X,A,B) Integral (0 to X) t**(A-1) * (1-t)**(B-1) dt
+! INCOMPLETE_GAMMA1(A,X) Integral (0 to X) t**(A-1) * exp(-t) dt
+! INCOMPLETE_GAMMA2(A,X) Integral (X to infinity) t**(A-1) * exp(-t) dt
+! LOG_GAMMA(A) Ln( GAMMA(A) )
+! POLYGAMMA(N,A) Nth derivative of Psi(x), evaluated at A
+! POCHHAMMER(A,N) A*(A+1)*(A+2)*...*(A+N-1)
+! PSI(A) Derivative of Ln(Gamma(x)), evaluated at A
+
+
+! To keep the FM variables hidden from a program that uses this
+! module, these parameters are set to the same values as the
+! corresponding ones in the FM_VARIABLES module.
+
+ USE FMVALS, ONLY : NDIGMX_2 => NDIGMX
+ INTEGER, PARAMETER, PRIVATE :: LUNPCK_2 = (11*NDIGMX_2)/5 + 30
+ INTEGER, PARAMETER, PRIVATE :: LUNPKZ_2 = 2*LUNPCK_2+2
+
+ TYPE FM
+ REAL (KIND(1.0D0)) :: MFM(-1:LUNPCK_2)
+ END TYPE
+
+ TYPE IM
+ REAL (KIND(1.0D0)) :: MIM(-1:LUNPCK_2)
+ END TYPE
+
+ TYPE ZM
+ REAL (KIND(1.0D0)) :: MZM(-1:LUNPKZ_2)
+ END TYPE
+
+ REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPCK_2) :: MTFM,MUFM,MVFM
+ REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPCK_2) :: MTIM,MUIM,MVIM
+ REAL (KIND(1.0D0)), SAVE, DIMENSION(-1:LUNPKZ_2) :: MTZM,MUZM,MVZM
+
+ END MODULE FMZM_1
+
+ MODULE FMZM_2
+ USE FMZM_1
+
+! These abbreviations are used for operations
+! on the various data types.
+
+! I Integer
+! R Real
+! D Double Precision
+! Z Complex
+! C Complex Double Precision
+! FM Multiple precision real
+! IM Multiple precision integer
+! ZM Multiple precision complex
+
+! For example, the "=" procedure FMEQ_FMD is for statements like
+! X = A, where X is type FM and A is type Double Precision.
+
+ INTERFACE ASSIGNMENT (=)
+ MODULE PROCEDURE FMEQ_IFM
+ MODULE PROCEDURE FMEQ_IIM
+ MODULE PROCEDURE FMEQ_IZM
+ MODULE PROCEDURE FMEQ_RFM
+ MODULE PROCEDURE FMEQ_RIM
+ MODULE PROCEDURE FMEQ_RZM
+ MODULE PROCEDURE FMEQ_DFM
+ MODULE PROCEDURE FMEQ_DIM
+ MODULE PROCEDURE FMEQ_DZM
+ MODULE PROCEDURE FMEQ_ZFM
+ MODULE PROCEDURE FMEQ_ZIM
+ MODULE PROCEDURE FMEQ_ZZM
+ MODULE PROCEDURE FMEQ_CFM
+ MODULE PROCEDURE FMEQ_CIM
+ MODULE PROCEDURE FMEQ_CZM
+ MODULE PROCEDURE FMEQ_FMI
+ MODULE PROCEDURE FMEQ_FMR
+ MODULE PROCEDURE FMEQ_FMD
+ MODULE PROCEDURE FMEQ_FMZ
+ MODULE PROCEDURE FMEQ_FMC
+ MODULE PROCEDURE FMEQ_FMFM
+ MODULE PROCEDURE FMEQ_FMIM
+ MODULE PROCEDURE FMEQ_FMZM
+ MODULE PROCEDURE FMEQ_IMI
+ MODULE PROCEDURE FMEQ_IMR
+ MODULE PROCEDURE FMEQ_IMD
+ MODULE PROCEDURE FMEQ_IMZ
+ MODULE PROCEDURE FMEQ_IMC
+ MODULE PROCEDURE FMEQ_IMFM
+ MODULE PROCEDURE FMEQ_IMIM
+ MODULE PROCEDURE FMEQ_IMZM
+ MODULE PROCEDURE FMEQ_ZMI
+ MODULE PROCEDURE FMEQ_ZMR
+ MODULE PROCEDURE FMEQ_ZMD
+ MODULE PROCEDURE FMEQ_ZMZ
+ MODULE PROCEDURE FMEQ_ZMC
+ MODULE PROCEDURE FMEQ_ZMFM
+ MODULE PROCEDURE FMEQ_ZMIM
+ MODULE PROCEDURE FMEQ_ZMZM
+ END INTERFACE
+
+ INTERFACE OPERATOR ( == )
+ MODULE PROCEDURE FMLEQ_IFM
+ MODULE PROCEDURE FMLEQ_IIM
+ MODULE PROCEDURE FMLEQ_IZM
+ MODULE PROCEDURE FMLEQ_RFM
+ MODULE PROCEDURE FMLEQ_RIM
+ MODULE PROCEDURE FMLEQ_RZM
+ MODULE PROCEDURE FMLEQ_DFM
+ MODULE PROCEDURE FMLEQ_DIM
+ MODULE PROCEDURE FMLEQ_DZM
+ MODULE PROCEDURE FMLEQ_ZFM
+ MODULE PROCEDURE FMLEQ_ZIM
+ MODULE PROCEDURE FMLEQ_ZZM
+ MODULE PROCEDURE FMLEQ_CFM
+ MODULE PROCEDURE FMLEQ_CIM
+ MODULE PROCEDURE FMLEQ_CZM
+ MODULE PROCEDURE FMLEQ_FMI
+ MODULE PROCEDURE FMLEQ_FMR
+ MODULE PROCEDURE FMLEQ_FMD
+ MODULE PROCEDURE FMLEQ_FMZ
+ MODULE PROCEDURE FMLEQ_FMC
+ MODULE PROCEDURE FMLEQ_FMFM
+ MODULE PROCEDURE FMLEQ_FMIM
+ MODULE PROCEDURE FMLEQ_FMZM
+ MODULE PROCEDURE FMLEQ_IMI
+ MODULE PROCEDURE FMLEQ_IMR
+ MODULE PROCEDURE FMLEQ_IMD
+ MODULE PROCEDURE FMLEQ_IMZ
+ MODULE PROCEDURE FMLEQ_IMC
+ MODULE PROCEDURE FMLEQ_IMFM
+ MODULE PROCEDURE FMLEQ_IMIM
+ MODULE PROCEDURE FMLEQ_IMZM
+ MODULE PROCEDURE FMLEQ_ZMI
+ MODULE PROCEDURE FMLEQ_ZMR
+ MODULE PROCEDURE FMLEQ_ZMD
+ MODULE PROCEDURE FMLEQ_ZMZ
+ MODULE PROCEDURE FMLEQ_ZMC
+ MODULE PROCEDURE FMLEQ_ZMFM
+ MODULE PROCEDURE FMLEQ_ZMIM
+ MODULE PROCEDURE FMLEQ_ZMZM
+ END INTERFACE
+
+
+ CONTAINS
+
+! =
+
+ SUBROUTINE FMEQ_IFM(IVAL,MA)
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ INTENT (INOUT) :: IVAL
+ INTENT (IN) :: MA
+ CALL FMM2I(MA%MFM,IVAL)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_IIM(IVAL,MA)
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ INTENT (INOUT) :: IVAL
+ INTENT (IN) :: MA
+ CALL IMM2I(MA%MIM,IVAL)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_IZM(IVAL,MA)
+ TYPE ( ZM ) MA
+ INTEGER IVAL
+ INTENT (INOUT) :: IVAL
+ INTENT (IN) :: MA
+ CALL ZMM2I(MA%MZM,IVAL)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_RFM(R,MA)
+ TYPE ( FM ) MA
+ REAL R
+ INTENT (INOUT) :: R
+ INTENT (IN) :: MA
+ CALL FMM2SP(MA%MFM,R)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_RIM(R,MA)
+ TYPE ( IM ) MA
+ REAL R
+ INTENT (INOUT) :: R
+ INTENT (IN) :: MA
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMM2SP(MTFM,R)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_RZM(R,MA)
+ TYPE ( ZM ) MA
+ REAL R
+ INTENT (INOUT) :: R
+ INTENT (IN) :: MA
+ CALL ZMREAL(MA%MZM,MTFM)
+ CALL FMM2SP(MTFM,R)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_DFM(D,MA)
+ TYPE ( FM ) MA
+ DOUBLE PRECISION D
+ INTENT (INOUT) :: D
+ INTENT (IN) :: MA
+ CALL FMM2DP(MA%MFM,D)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_DIM(D,MA)
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTENT (INOUT) :: D
+ INTENT (IN) :: MA
+ CALL IMM2DP(MA%MIM,D)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_DZM(D,MA)
+ TYPE ( ZM ) MA
+ DOUBLE PRECISION D
+ INTENT (INOUT) :: D
+ INTENT (IN) :: MA
+ CALL ZMREAL(MA%MZM,MTFM)
+ CALL FMM2DP(MTFM,D)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_ZFM(Z,MA)
+ TYPE ( FM ) MA
+ COMPLEX Z
+ REAL R
+ INTENT (INOUT) :: Z
+ INTENT (IN) :: MA
+ CALL FMM2SP(MA%MFM,R)
+ Z = CMPLX( R , 0.0 )
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_ZIM(Z,MA)
+ TYPE ( IM ) MA
+ COMPLEX Z
+ DOUBLE PRECISION D
+ INTENT (INOUT) :: Z
+ INTENT (IN) :: MA
+ CALL IMM2DP(MA%MIM,D)
+ Z = CMPLX( REAL(D) , 0.0 )
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_ZZM(Z,MA)
+ TYPE ( ZM ) MA
+ COMPLEX Z
+ INTENT (INOUT) :: Z
+ INTENT (IN) :: MA
+ CALL ZMM2Z(MA%MZM,Z)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_CFM(C,MA)
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ DOUBLE PRECISION D
+ INTENT (INOUT) :: C
+ INTENT (IN) :: MA
+ CALL FMM2DP(MA%MFM,D)
+ C = CMPLX( D , 0.0D0 , KIND(0.0D0) )
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_CIM(C,MA)
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ DOUBLE PRECISION D
+ INTENT (INOUT) :: C
+ INTENT (IN) :: MA
+ CALL IMM2DP(MA%MIM,D)
+ C = CMPLX( D , 0.0D0 , KIND(0.0D0) )
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_CZM(C,MA)
+ TYPE ( ZM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ DOUBLE PRECISION D1,D2
+ INTENT (INOUT) :: C
+ INTENT (IN) :: MA
+ CALL ZMREAL(MA%MZM,MTFM)
+ CALL FMM2DP(MTFM,D1)
+ CALL ZMIMAG(MA%MZM,MTFM)
+ CALL FMM2DP(MTFM,D2)
+ C = CMPLX( D1 , D2 , KIND(0.0D0) )
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_FMI(MA,IVAL)
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: IVAL
+ CALL FMI2M(IVAL,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_FMR(MA,R)
+ TYPE ( FM ) MA
+ REAL R
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: R
+ CALL FMSP2M(R,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_FMD(MA,D)
+ TYPE ( FM ) MA
+ DOUBLE PRECISION D
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: D
+ CALL FMDP2M(D,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_FMZ(MA,Z)
+ TYPE ( FM ) MA
+ COMPLEX Z
+ REAL R
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: Z
+ R = REAL(Z)
+ CALL FMSP2M(R,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_FMC(MA,C)
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ DOUBLE PRECISION D
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: C
+ D = REAL(C,KIND(0.0D0))
+ CALL FMDP2M(D,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_FMFM(MA,MB)
+ TYPE ( FM ) MA,MB
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: MB
+ CALL FMEQ(MB%MFM,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_FMIM(MA,MB)
+ TYPE ( FM ) MA
+ TYPE ( IM ) MB
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: MB
+ CALL IMI2FM(MB%MIM,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_FMZM(MA,MB)
+ TYPE ( FM ) MA
+ TYPE ( ZM ) MB
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: MB
+ CALL ZMREAL(MB%MZM,MA%MFM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_IMI(MA,IVAL)
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: IVAL
+ CALL IMI2M(IVAL,MA%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_IMR(MA,R)
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ REAL R
+ CHARACTER(25) :: ST
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: R
+ IF (ABS(R) < HUGE(1)) THEN
+ IVAL = INT(R)
+ CALL IMI2M(IVAL,MA%MIM)
+ ELSE
+ WRITE (ST,'(E25.16)') R
+ CALL IMST2M(ST,MA%MIM)
+ ENDIF
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_IMD(MA,D)
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ DOUBLE PRECISION D
+ CHARACTER(25) :: ST
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: D
+ IF (ABS(D) < HUGE(1)) THEN
+ IVAL = INT(D)
+ CALL IMI2M(IVAL,MA%MIM)
+ ELSE
+ WRITE (ST,'(E25.16)') D
+ CALL IMST2M(ST,MA%MIM)
+ ENDIF
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_IMZ(MA,Z)
+ TYPE ( IM ) MA
+ COMPLEX Z
+ REAL R
+ CHARACTER(25) :: ST
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: Z
+ R = REAL(Z)
+ IF (ABS(R) < HUGE(1)) THEN
+ IVAL = INT(R)
+ CALL IMI2M(IVAL,MA%MIM)
+ ELSE
+ WRITE (ST,'(E25.16)') R
+ CALL IMST2M(ST,MA%MIM)
+ ENDIF
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_IMC(MA,C)
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ DOUBLE PRECISION D
+ CHARACTER(25) :: ST
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: C
+ D = REAL(C)
+ IF (ABS(D) < HUGE(1)) THEN
+ IVAL = INT(D)
+ CALL IMI2M(IVAL,MA%MIM)
+ ELSE
+ WRITE (ST,'(E25.16)') D
+ CALL IMST2M(ST,MA%MIM)
+ ENDIF
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_IMFM(MA,MB)
+ TYPE ( IM ) MA
+ TYPE ( FM ) MB
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: MB
+ CALL IMFM2I(MB%MFM,MA%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_IMIM(MA,MB)
+ TYPE ( IM ) MA,MB
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: MB
+ CALL IMEQ(MB%MIM,MA%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_IMZM(MA,MB)
+ TYPE ( IM ) MA
+ TYPE ( ZM ) MB
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: MB
+ CALL ZMREAL(MB%MZM,MTFM)
+ CALL IMFM2I(MTFM,MA%MIM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_ZMI(MA,IVAL)
+ TYPE ( ZM ) MA
+ INTEGER IVAL
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: IVAL
+ CALL ZMI2M(IVAL,MA%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_ZMR(MA,R)
+ TYPE ( ZM ) MA
+ REAL R
+ COMPLEX Z
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: R
+ Z = CMPLX(R,0.0)
+ CALL ZMZ2M(Z,MA%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_ZMD(MA,D)
+ TYPE ( ZM ) MA
+ DOUBLE PRECISION D
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: D
+ CALL FMDP2M(D,MTFM)
+ CALL FMDP2M(0.0D0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MA%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_ZMZ(MA,Z)
+ TYPE ( ZM ) MA
+ COMPLEX Z
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: Z
+ CALL ZMZ2M(Z,MA%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_ZMC(MA,C)
+ TYPE ( ZM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ DOUBLE PRECISION D
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: C
+ D = REAL(C,KIND(0.0D0))
+ CALL FMDP2M(D,MTFM)
+ D = AIMAG(C)
+ CALL FMDP2M(D,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MA%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_ZMFM(MA,MB)
+ TYPE ( FM ) MB
+ TYPE ( ZM ) MA
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: MB
+ CALL FMI2M(0,MTFM)
+ CALL ZMCMPX(MB%MFM,MTFM,MA%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_ZMIM(MA,MB)
+ TYPE ( IM ) MB
+ TYPE ( ZM ) MA
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: MB
+ CALL IMI2FM(MB%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MA%MZM)
+ END SUBROUTINE
+
+ SUBROUTINE FMEQ_ZMZM(MA,MB)
+ TYPE ( ZM ) MA,MB
+ INTENT (INOUT) :: MA
+ INTENT (IN) :: MB
+ CALL ZMEQ(MB%MZM,MA%MZM)
+ END SUBROUTINE
+
+! ==
+
+ FUNCTION FMLEQ_IFM(IVAL,MA)
+ LOGICAL FMLEQ_IFM,FMCOMP
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ FMLEQ_IFM = FMCOMP(MTFM,'EQ',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLEQ_IIM(IVAL,MA)
+ LOGICAL FMLEQ_IIM,IMCOMP
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL IMI2M(IVAL,MTIM)
+ FMLEQ_IIM = IMCOMP(MTIM,'EQ',MA%MIM)
+ END FUNCTION
+
+ FUNCTION FMLEQ_IZM(IVAL,MA)
+ LOGICAL FMLEQ_IZM,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'EQ',MUFM)
+ CALL FMI2M(0,MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'EQ',MUFM)
+ FMLEQ_IZM = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_RFM(R,MA)
+ LOGICAL FMLEQ_RFM,FMCOMP
+ TYPE ( FM ) MA
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ FMLEQ_RFM = FMCOMP(MTFM,'EQ',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLEQ_RIM(R,MA)
+ USE FMVALS
+ LOGICAL FMLEQ_RIM,FMCOMP
+ TYPE ( IM ) MA
+ INTEGER KA,NDSAVE
+ REAL R
+ INTENT (IN) :: R,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLEQ_RIM = FMCOMP(MTFM,'EQ',MUFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLEQ_RZM(R,MA)
+ LOGICAL FMLEQ_RZM,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'EQ',MUFM)
+ CALL FMI2M(0,MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'EQ',MUFM)
+ FMLEQ_RZM = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_DFM(D,MA)
+ LOGICAL FMLEQ_DFM,FMCOMP
+ TYPE ( FM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ FMLEQ_DFM = FMCOMP(MTFM,'EQ',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLEQ_DIM(D,MA)
+ USE FMVALS
+ LOGICAL FMLEQ_DIM,FMCOMP
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: D,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLEQ_DIM = FMCOMP(MTFM,'EQ',MUFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLEQ_DZM(D,MA)
+ LOGICAL FMLEQ_DZM,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'EQ',MUFM)
+ CALL FMI2M(0,MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'EQ',MUFM)
+ FMLEQ_DZM = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_ZFM(Z,MA)
+ LOGICAL FMLEQ_ZFM,FMCOMP,L1,L2
+ TYPE ( FM ) MA
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL FMSP2M(REAL(Z),MTFM)
+ L1 = FMCOMP(MTFM,'EQ',MA%MFM)
+ L2 = .TRUE.
+ IF (AIMAG(Z) /= 0.0) L2 = .FALSE.
+ FMLEQ_ZFM = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_ZIM(Z,MA)
+ USE FMVALS
+ LOGICAL FMLEQ_ZIM,FMCOMP,L1,L2
+ TYPE ( IM ) MA
+ COMPLEX Z
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: Z,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(REAL(Z),MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ L1 = FMCOMP(MTFM,'EQ',MUFM)
+ NDIG = NDSAVE
+ L2 = .TRUE.
+ IF (AIMAG(Z) /= 0.0) L2 = .FALSE.
+ FMLEQ_ZIM = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_ZZM(Z,MA)
+ LOGICAL FMLEQ_ZZM,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL ZMREAL(MTZM,MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'EQ',MUFM)
+ CALL ZMIMAG(MTZM,MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'EQ',MUFM)
+ FMLEQ_ZZM = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_CFM(C,MA)
+ LOGICAL FMLEQ_CFM,FMCOMP,L1,L2
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ L1 = FMCOMP(MTFM,'EQ',MA%MFM)
+ L2 = .TRUE.
+ IF (AIMAG(C) /= 0.0) L2 = .FALSE.
+ FMLEQ_CFM = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_CIM(C,MA)
+ USE FMVALS
+ LOGICAL FMLEQ_CIM,FMCOMP,L1,L2
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: C,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ L1 = FMCOMP(MTFM,'EQ',MUFM)
+ NDIG = NDSAVE
+ L2 = .TRUE.
+ IF (AIMAG(C) /= 0.0) L2 = .FALSE.
+ FMLEQ_CIM = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_CZM(C,MA)
+ LOGICAL FMLEQ_CZM,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'EQ',MUFM)
+ CALL FMDP2M(AIMAG(C),MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'EQ',MUFM)
+ FMLEQ_CZM = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_FMI(MA,IVAL)
+ LOGICAL FMLEQ_FMI,FMCOMP
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL FMI2M(IVAL,MTFM)
+ FMLEQ_FMI = FMCOMP(MA%MFM,'EQ',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLEQ_FMR(MA,R)
+ LOGICAL FMLEQ_FMR,FMCOMP
+ TYPE ( FM ) MA
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ FMLEQ_FMR = FMCOMP(MA%MFM,'EQ',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLEQ_FMD(MA,D)
+ LOGICAL FMLEQ_FMD,FMCOMP
+ TYPE ( FM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ FMLEQ_FMD = FMCOMP(MA%MFM,'EQ',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLEQ_FMZ(MA,Z)
+ LOGICAL FMLEQ_FMZ,FMCOMP,L1,L2
+ TYPE ( FM ) MA
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL FMSP2M(REAL(Z),MTFM)
+ L1 = FMCOMP(MA%MFM,'EQ',MTFM)
+ L2 = .TRUE.
+ IF (AIMAG(Z) /= 0.0) L2 = .FALSE.
+ FMLEQ_FMZ = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_FMC(MA,C)
+ LOGICAL FMLEQ_FMC,FMCOMP,L1,L2
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ L1 = FMCOMP(MA%MFM,'EQ',MTFM)
+ L2 = .TRUE.
+ IF (AIMAG(C) /= 0.0) L2 = .FALSE.
+ FMLEQ_FMC = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_FMFM(MA,MB)
+ LOGICAL FMLEQ_FMFM,FMCOMP
+ TYPE ( FM ) MA,MB
+ INTENT (IN) :: MA,MB
+ FMLEQ_FMFM = FMCOMP(MA%MFM,'EQ',MB%MFM)
+ END FUNCTION
+
+ FUNCTION FMLEQ_FMIM(MA,MB)
+ LOGICAL FMLEQ_FMIM,FMCOMP
+ TYPE ( FM ) MA
+ TYPE ( IM ) MB
+ INTENT (IN) :: MA,MB
+ CALL FMINT(MA%MFM,MTFM)
+ IF (FMCOMP(MA%MFM,'EQ',MTFM)) THEN
+ CALL IMI2FM(MB%MIM,MTFM)
+ FMLEQ_FMIM = FMCOMP(MA%MFM,'EQ',MTFM)
+ ELSE
+ FMLEQ_FMIM = .FALSE.
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMLEQ_FMZM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLEQ_FMZM,FMCOMP,L1,L2
+ TYPE ( FM ) MA
+ TYPE ( ZM ) MB
+ INTENT (IN) :: MA,MB
+ CALL ZMREAL(MB%MZM,MTFM)
+ L1 = FMCOMP(MA%MFM,'EQ',MTFM)
+ L2 = .TRUE.
+ IF (MB%MZM(KPTIMU+2) /= 0) L2 = .FALSE.
+ FMLEQ_FMZM = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_IMI(MA,IVAL)
+ LOGICAL FMLEQ_IMI,IMCOMP
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL IMI2M(IVAL,MTIM)
+ FMLEQ_IMI = IMCOMP(MA%MIM,'EQ',MTIM)
+ END FUNCTION
+
+ FUNCTION FMLEQ_IMR(MA,R)
+ USE FMVALS
+ LOGICAL FMLEQ_IMR,FMCOMP
+ TYPE ( IM ) MA
+ INTEGER KA,NDSAVE
+ REAL R
+ INTENT (IN) :: MA,R
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLEQ_IMR = FMCOMP(MUFM,'EQ',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLEQ_IMD(MA,D)
+ USE FMVALS
+ LOGICAL FMLEQ_IMD,FMCOMP
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,D
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLEQ_IMD = FMCOMP(MUFM,'EQ',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLEQ_IMZ(MA,Z)
+ USE FMVALS
+ LOGICAL FMLEQ_IMZ,FMCOMP,L1,L2
+ TYPE ( IM ) MA
+ COMPLEX Z
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,Z
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(REAL(Z),MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ L1 = FMCOMP(MUFM,'EQ',MTFM)
+ NDIG = NDSAVE
+ L2 = .TRUE.
+ IF (AIMAG(Z) /= 0.0) L2 = .FALSE.
+ FMLEQ_IMZ = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_IMC(MA,C)
+ USE FMVALS
+ LOGICAL FMLEQ_IMC,FMCOMP,L1,L2
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,C
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ L1 = FMCOMP(MUFM,'EQ',MTFM)
+ NDIG = NDSAVE
+ L2 = .TRUE.
+ IF (AIMAG(C) /= 0.0) L2 = .FALSE.
+ FMLEQ_IMC = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_IMFM(MA,MB)
+ LOGICAL FMLEQ_IMFM,FMCOMP
+ TYPE ( IM ) MA
+ TYPE ( FM ) MB
+ INTENT (IN) :: MA,MB
+ CALL FMINT(MB%MFM,MTFM)
+ IF (FMCOMP(MB%MFM,'EQ',MTFM)) THEN
+ CALL IMI2FM(MA%MIM,MTFM)
+ FMLEQ_IMFM = FMCOMP(MB%MFM,'EQ',MTFM)
+ ELSE
+ FMLEQ_IMFM = .FALSE.
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMLEQ_IMIM(MA,MB)
+ LOGICAL FMLEQ_IMIM,IMCOMP
+ TYPE ( IM ) MA,MB
+ INTENT (IN) :: MA,MB
+ FMLEQ_IMIM = IMCOMP(MA%MIM,'EQ',MB%MIM)
+ END FUNCTION
+
+ FUNCTION FMLEQ_IMZM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLEQ_IMZM,FMCOMP
+ TYPE ( IM ) MA
+ TYPE ( ZM ) MB
+ INTENT (IN) :: MA,MB
+ CALL ZMREAL(MB%MZM,MTFM)
+ CALL FMINT(MTFM,MUFM)
+ IF (FMCOMP(MUFM,'EQ',MTFM).AND.MB%MZM(KPTIMU+2) == 0) THEN
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLEQ_IMZM = FMCOMP(MUFM,'EQ',MTFM)
+ ELSE
+ FMLEQ_IMZM = .FALSE.
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMLEQ_ZMI(MA,IVAL)
+ USE FMVALS
+ LOGICAL FMLEQ_ZMI,FMCOMP
+ TYPE ( ZM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL ZMREAL(MA%MZM,MTFM)
+ CALL FMINT(MTFM,MUFM)
+ IF (FMCOMP(MUFM,'EQ',MTFM).AND.MA%MZM(KPTIMU+2) == 0) THEN
+ CALL FMI2M(IVAL,MUFM)
+ FMLEQ_ZMI = FMCOMP(MTFM,'EQ',MUFM)
+ ELSE
+ FMLEQ_ZMI = .FALSE.
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMLEQ_ZMR(MA,R)
+ LOGICAL FMLEQ_ZMR,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'EQ',MUFM)
+ CALL FMI2M(0,MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'EQ',MUFM)
+ FMLEQ_ZMR = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_ZMD(MA,D)
+ LOGICAL FMLEQ_ZMD,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'EQ',MUFM)
+ CALL FMI2M(0,MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'EQ',MUFM)
+ FMLEQ_ZMD = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_ZMZ(MA,Z)
+ LOGICAL FMLEQ_ZMZ,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL ZMREAL(MTZM,MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'EQ',MUFM)
+ CALL ZMIMAG(MTZM,MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'EQ',MUFM)
+ FMLEQ_ZMZ = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_ZMC(MA,C)
+ LOGICAL FMLEQ_ZMC,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'EQ',MUFM)
+ CALL FMDP2M(AIMAG(C),MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'EQ',MUFM)
+ FMLEQ_ZMC = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_ZMFM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLEQ_ZMFM,FMCOMP,L1,L2
+ TYPE ( FM ) MB
+ TYPE ( ZM ) MA
+ INTENT (IN) :: MA,MB
+ CALL ZMREAL(MA%MZM,MTFM)
+ L1 = FMCOMP(MB%MFM,'EQ',MTFM)
+ L2 = .TRUE.
+ IF (MA%MZM(KPTIMU+2) /= 0) L2 = .FALSE.
+ FMLEQ_ZMFM = L1.AND.L2
+ END FUNCTION
+
+ FUNCTION FMLEQ_ZMIM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLEQ_ZMIM,FMCOMP
+ TYPE ( IM ) MB
+ TYPE ( ZM ) MA
+ INTENT (IN) :: MA,MB
+ CALL ZMREAL(MA%MZM,MTFM)
+ CALL FMINT(MTFM,MUFM)
+ IF (FMCOMP(MUFM,'EQ',MTFM).AND.MA%MZM(KPTIMU+2) == 0) THEN
+ CALL IMI2FM(MB%MIM,MUFM)
+ FMLEQ_ZMIM = FMCOMP(MUFM,'EQ',MTFM)
+ ELSE
+ FMLEQ_ZMIM = .FALSE.
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMLEQ_ZMZM(MA,MB)
+ LOGICAL FMLEQ_ZMZM,FMCOMP,L1,L2
+ TYPE ( ZM ) MA,MB
+ INTENT (IN) :: MA,MB
+ CALL ZMREAL(MA%MZM,MTFM)
+ CALL ZMREAL(MB%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'EQ',MUFM)
+ CALL ZMIMAG(MA%MZM,MTFM)
+ CALL ZMIMAG(MB%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'EQ',MUFM)
+ FMLEQ_ZMZM = L1.AND.L2
+ END FUNCTION
+
+ END MODULE FMZM_2
+
+ MODULE FMZM_3
+ USE FMZM_1
+
+ INTERFACE OPERATOR ( /= )
+ MODULE PROCEDURE FMLNE_IFM
+ MODULE PROCEDURE FMLNE_IIM
+ MODULE PROCEDURE FMLNE_IZM
+ MODULE PROCEDURE FMLNE_RFM
+ MODULE PROCEDURE FMLNE_RIM
+ MODULE PROCEDURE FMLNE_RZM
+ MODULE PROCEDURE FMLNE_DFM
+ MODULE PROCEDURE FMLNE_DIM
+ MODULE PROCEDURE FMLNE_DZM
+ MODULE PROCEDURE FMLNE_ZFM
+ MODULE PROCEDURE FMLNE_ZIM
+ MODULE PROCEDURE FMLNE_ZZM
+ MODULE PROCEDURE FMLNE_CFM
+ MODULE PROCEDURE FMLNE_CIM
+ MODULE PROCEDURE FMLNE_CZM
+ MODULE PROCEDURE FMLNE_FMI
+ MODULE PROCEDURE FMLNE_FMR
+ MODULE PROCEDURE FMLNE_FMD
+ MODULE PROCEDURE FMLNE_FMZ
+ MODULE PROCEDURE FMLNE_FMC
+ MODULE PROCEDURE FMLNE_FMFM
+ MODULE PROCEDURE FMLNE_FMIM
+ MODULE PROCEDURE FMLNE_FMZM
+ MODULE PROCEDURE FMLNE_IMI
+ MODULE PROCEDURE FMLNE_IMR
+ MODULE PROCEDURE FMLNE_IMD
+ MODULE PROCEDURE FMLNE_IMZ
+ MODULE PROCEDURE FMLNE_IMC
+ MODULE PROCEDURE FMLNE_IMFM
+ MODULE PROCEDURE FMLNE_IMIM
+ MODULE PROCEDURE FMLNE_IMZM
+ MODULE PROCEDURE FMLNE_ZMI
+ MODULE PROCEDURE FMLNE_ZMR
+ MODULE PROCEDURE FMLNE_ZMD
+ MODULE PROCEDURE FMLNE_ZMZ
+ MODULE PROCEDURE FMLNE_ZMC
+ MODULE PROCEDURE FMLNE_ZMFM
+ MODULE PROCEDURE FMLNE_ZMIM
+ MODULE PROCEDURE FMLNE_ZMZM
+ END INTERFACE
+
+ INTERFACE OPERATOR ( > )
+ MODULE PROCEDURE FMLGT_IFM
+ MODULE PROCEDURE FMLGT_IIM
+ MODULE PROCEDURE FMLGT_RFM
+ MODULE PROCEDURE FMLGT_RIM
+ MODULE PROCEDURE FMLGT_DFM
+ MODULE PROCEDURE FMLGT_DIM
+ MODULE PROCEDURE FMLGT_FMI
+ MODULE PROCEDURE FMLGT_FMR
+ MODULE PROCEDURE FMLGT_FMD
+ MODULE PROCEDURE FMLGT_FMFM
+ MODULE PROCEDURE FMLGT_FMIM
+ MODULE PROCEDURE FMLGT_IMI
+ MODULE PROCEDURE FMLGT_IMR
+ MODULE PROCEDURE FMLGT_IMD
+ MODULE PROCEDURE FMLGT_IMFM
+ MODULE PROCEDURE FMLGT_IMIM
+ END INTERFACE
+
+ CONTAINS
+
+! /=
+
+ FUNCTION FMLNE_IFM(IVAL,MA)
+ LOGICAL FMLNE_IFM,FMCOMP
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ FMLNE_IFM = FMCOMP(MTFM,'NE',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLNE_IIM(IVAL,MA)
+ LOGICAL FMLNE_IIM,IMCOMP
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL IMI2M(IVAL,MTIM)
+ FMLNE_IIM = IMCOMP(MTIM,'NE',MA%MIM)
+ END FUNCTION
+
+ FUNCTION FMLNE_IZM(IVAL,MA)
+ LOGICAL FMLNE_IZM,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'NE',MUFM)
+ CALL FMI2M(0,MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'NE',MUFM)
+ FMLNE_IZM = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_RFM(R,MA)
+ LOGICAL FMLNE_RFM,FMCOMP
+ TYPE ( FM ) MA
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ FMLNE_RFM = FMCOMP(MTFM,'NE',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLNE_RIM(R,MA)
+ USE FMVALS
+ LOGICAL FMLNE_RIM,FMCOMP
+ TYPE ( IM ) MA
+ REAL R
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: R,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLNE_RIM = FMCOMP(MTFM,'NE',MUFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLNE_RZM(R,MA)
+ LOGICAL FMLNE_RZM,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'NE',MUFM)
+ CALL FMI2M(0,MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'NE',MUFM)
+ FMLNE_RZM = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_DFM(D,MA)
+ LOGICAL FMLNE_DFM,FMCOMP
+ TYPE ( FM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ FMLNE_DFM = FMCOMP(MTFM,'NE',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLNE_DIM(D,MA)
+ USE FMVALS
+ LOGICAL FMLNE_DIM,FMCOMP
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: D,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLNE_DIM = FMCOMP(MTFM,'NE',MUFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLNE_DZM(D,MA)
+ LOGICAL FMLNE_DZM,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'NE',MUFM)
+ CALL FMI2M(0,MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'NE',MUFM)
+ FMLNE_DZM = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_ZFM(Z,MA)
+ LOGICAL FMLNE_ZFM,FMCOMP,L1,L2
+ TYPE ( FM ) MA
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL FMSP2M(REAL(Z),MTFM)
+ L1 = FMCOMP(MTFM,'NE',MA%MFM)
+ L2 = .FALSE.
+ IF (AIMAG(Z) /= 0.0) L2 = .TRUE.
+ FMLNE_ZFM = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_ZIM(Z,MA)
+ USE FMVALS
+ LOGICAL FMLNE_ZIM,FMCOMP,L1,L2
+ TYPE ( IM ) MA
+ INTEGER KA,NDSAVE
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(REAL(Z),MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ L1 = FMCOMP(MTFM,'NE',MUFM)
+ NDIG = NDSAVE
+ L2 = .FALSE.
+ IF (AIMAG(Z) /= 0.0) L2 = .TRUE.
+ FMLNE_ZIM = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_ZZM(Z,MA)
+ LOGICAL FMLNE_ZZM,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL ZMREAL(MTZM,MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'NE',MUFM)
+ CALL ZMIMAG(MTZM,MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'NE',MUFM)
+ FMLNE_ZZM = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_CFM(C,MA)
+ LOGICAL FMLNE_CFM,FMCOMP,L1,L2
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ L1 = FMCOMP(MTFM,'NE',MA%MFM)
+ L2 = .FALSE.
+ IF (AIMAG(C) /= 0.0) L2 = .TRUE.
+ FMLNE_CFM = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_CIM(C,MA)
+ USE FMVALS
+ LOGICAL FMLNE_CIM,FMCOMP,L1,L2
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: C,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ L1 = FMCOMP(MTFM,'NE',MUFM)
+ NDIG = NDSAVE
+ L2 = .FALSE.
+ IF (AIMAG(C) /= 0.0) L2 = .TRUE.
+ FMLNE_CIM = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_CZM(C,MA)
+ LOGICAL FMLNE_CZM,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'NE',MUFM)
+ CALL FMDP2M(AIMAG(C),MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'NE',MUFM)
+ FMLNE_CZM = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_FMI(MA,IVAL)
+ LOGICAL FMLNE_FMI,FMCOMP
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL FMI2M(IVAL,MTFM)
+ FMLNE_FMI = FMCOMP(MA%MFM,'NE',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLNE_FMR(MA,R)
+ LOGICAL FMLNE_FMR,FMCOMP
+ TYPE ( FM ) MA
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ FMLNE_FMR = FMCOMP(MA%MFM,'NE',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLNE_FMD(MA,D)
+ LOGICAL FMLNE_FMD,FMCOMP
+ TYPE ( FM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ FMLNE_FMD = FMCOMP(MA%MFM,'NE',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLNE_FMZ(MA,Z)
+ LOGICAL FMLNE_FMZ,FMCOMP,L1,L2
+ TYPE ( FM ) MA
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL FMSP2M(REAL(Z),MTFM)
+ L1 = FMCOMP(MA%MFM,'NE',MTFM)
+ L2 = .FALSE.
+ IF (AIMAG(Z) /= 0.0) L2 = .TRUE.
+ FMLNE_FMZ = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_FMC(MA,C)
+ LOGICAL FMLNE_FMC,FMCOMP,L1,L2
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ L1 = FMCOMP(MA%MFM,'NE',MTFM)
+ L2 = .FALSE.
+ IF (AIMAG(C) /= 0.0) L2 = .TRUE.
+ FMLNE_FMC = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_FMFM(MA,MB)
+ LOGICAL FMLNE_FMFM,FMCOMP
+ TYPE ( FM ) MA,MB
+ INTENT (IN) :: MA,MB
+ FMLNE_FMFM = FMCOMP(MA%MFM,'NE',MB%MFM)
+ END FUNCTION
+
+ FUNCTION FMLNE_FMIM(MA,MB)
+ LOGICAL FMLNE_FMIM,FMCOMP
+ TYPE ( FM ) MA
+ TYPE ( IM ) MB
+ INTENT (IN) :: MA,MB
+ CALL FMINT(MA%MFM,MTFM)
+ IF (FMCOMP(MA%MFM,'EQ',MTFM)) THEN
+ CALL IMI2FM(MB%MIM,MTFM)
+ FMLNE_FMIM = FMCOMP(MA%MFM,'NE',MTFM)
+ ELSE
+ FMLNE_FMIM = .TRUE.
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMLNE_FMZM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLNE_FMZM,FMCOMP,L1,L2
+ TYPE ( FM ) MA
+ TYPE ( ZM ) MB
+ INTENT (IN) :: MA,MB
+ CALL ZMREAL(MB%MZM,MTFM)
+ L1 = FMCOMP(MA%MFM,'NE',MTFM)
+ L2 = .FALSE.
+ IF (MB%MZM(KPTIMU+2) /= 0) L2 = .TRUE.
+ FMLNE_FMZM = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_IMI(MA,IVAL)
+ LOGICAL FMLNE_IMI,IMCOMP
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL IMI2M(IVAL,MTIM)
+ FMLNE_IMI = IMCOMP(MA%MIM,'NE',MTIM)
+ END FUNCTION
+
+ FUNCTION FMLNE_IMR(MA,R)
+ USE FMVALS
+ LOGICAL FMLNE_IMR,FMCOMP
+ TYPE ( IM ) MA
+ INTEGER KA,NDSAVE
+ REAL R
+ INTENT (IN) :: MA,R
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLNE_IMR = FMCOMP(MUFM,'NE',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLNE_IMD(MA,D)
+ USE FMVALS
+ LOGICAL FMLNE_IMD,FMCOMP
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,D
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLNE_IMD = FMCOMP(MUFM,'NE',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLNE_IMZ(MA,Z)
+ USE FMVALS
+ LOGICAL FMLNE_IMZ,FMCOMP,L1,L2
+ TYPE ( IM ) MA
+ INTEGER KA,NDSAVE
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(REAL(Z),MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ L1 = FMCOMP(MUFM,'NE',MTFM)
+ NDIG = NDSAVE
+ L2 = .FALSE.
+ IF (AIMAG(Z) /= 0.0) L2 = .TRUE.
+ FMLNE_IMZ = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_IMC(MA,C)
+ USE FMVALS
+ LOGICAL FMLNE_IMC,FMCOMP,L1,L2
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,C
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ L1 = FMCOMP(MUFM,'NE',MTFM)
+ NDIG = NDSAVE
+ L2 = .FALSE.
+ IF (AIMAG(C) /= 0.0) L2 = .TRUE.
+ FMLNE_IMC = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_IMFM(MA,MB)
+ LOGICAL FMLNE_IMFM,FMCOMP
+ TYPE ( IM ) MA
+ TYPE ( FM ) MB
+ INTENT (IN) :: MA,MB
+ CALL FMINT(MB%MFM,MTFM)
+ IF (FMCOMP(MB%MFM,'EQ',MTFM)) THEN
+ CALL IMI2FM(MA%MIM,MTFM)
+ FMLNE_IMFM = FMCOMP(MB%MFM,'NE',MTFM)
+ ELSE
+ FMLNE_IMFM = .TRUE.
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMLNE_IMIM(MA,MB)
+ LOGICAL FMLNE_IMIM,IMCOMP
+ TYPE ( IM ) MA,MB
+ INTENT (IN) :: MA,MB
+ FMLNE_IMIM = IMCOMP(MA%MIM,'NE',MB%MIM)
+ END FUNCTION
+
+ FUNCTION FMLNE_IMZM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLNE_IMZM,FMCOMP
+ TYPE ( IM ) MA
+ TYPE ( ZM ) MB
+ INTENT (IN) :: MA,MB
+ CALL ZMREAL(MB%MZM,MTFM)
+ CALL FMINT(MTFM,MUFM)
+ IF (FMCOMP(MUFM,'EQ',MTFM).AND.MB%MZM(KPTIMU+2) == 0) THEN
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLNE_IMZM = FMCOMP(MUFM,'NE',MTFM)
+ ELSE
+ FMLNE_IMZM = .TRUE.
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMLNE_ZMI(MA,IVAL)
+ USE FMVALS
+ LOGICAL FMLNE_ZMI,FMCOMP
+ TYPE ( ZM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL ZMREAL(MA%MZM,MTFM)
+ CALL FMINT(MTFM,MUFM)
+ IF (FMCOMP(MUFM,'EQ',MTFM).AND.MA%MZM(KPTIMU+2) == 0) THEN
+ CALL FMI2M(IVAL,MUFM)
+ FMLNE_ZMI = FMCOMP(MTFM,'NE',MUFM)
+ ELSE
+ FMLNE_ZMI = .TRUE.
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMLNE_ZMR(MA,R)
+ LOGICAL FMLNE_ZMR,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'NE',MUFM)
+ CALL FMI2M(0,MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'NE',MUFM)
+ FMLNE_ZMR = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_ZMD(MA,D)
+ LOGICAL FMLNE_ZMD,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'NE',MUFM)
+ CALL FMI2M(0,MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'NE',MUFM)
+ FMLNE_ZMD = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_ZMZ(MA,Z)
+ LOGICAL FMLNE_ZMZ,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL ZMREAL(MTZM,MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'NE',MUFM)
+ CALL ZMIMAG(MTZM,MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'NE',MUFM)
+ FMLNE_ZMZ = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_ZMC(MA,C)
+ LOGICAL FMLNE_ZMC,FMCOMP,L1,L2
+ TYPE ( ZM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL ZMREAL(MA%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'NE',MUFM)
+ CALL FMDP2M(AIMAG(C),MTFM)
+ CALL ZMIMAG(MA%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'NE',MUFM)
+ FMLNE_ZMC = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_ZMFM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLNE_ZMFM,FMCOMP,L1,L2
+ TYPE ( FM ) MB
+ TYPE ( ZM ) MA
+ INTENT (IN) :: MA,MB
+ CALL ZMREAL(MA%MZM,MTFM)
+ L1 = FMCOMP(MB%MFM,'NE',MTFM)
+ L2 = .FALSE.
+ IF (MA%MZM(KPTIMU+2) /= 0) L2 = .TRUE.
+ FMLNE_ZMFM = L1.OR.L2
+ END FUNCTION
+
+ FUNCTION FMLNE_ZMIM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLNE_ZMIM,FMCOMP
+ TYPE ( IM ) MB
+ TYPE ( ZM ) MA
+ INTENT (IN) :: MA,MB
+ CALL ZMREAL(MA%MZM,MTFM)
+ CALL FMINT(MTFM,MUFM)
+ IF (FMCOMP(MUFM,'EQ',MTFM).AND.MA%MZM(KPTIMU+2) == 0) THEN
+ CALL IMI2FM(MB%MIM,MUFM)
+ FMLNE_ZMIM = FMCOMP(MUFM,'NE',MTFM)
+ ELSE
+ FMLNE_ZMIM = .TRUE.
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMLNE_ZMZM(MA,MB)
+ LOGICAL FMLNE_ZMZM,FMCOMP,L1,L2
+ TYPE ( ZM ) MA,MB
+ INTENT (IN) :: MA,MB
+ CALL ZMREAL(MA%MZM,MTFM)
+ CALL ZMREAL(MB%MZM,MUFM)
+ L1 = FMCOMP(MTFM,'NE',MUFM)
+ CALL ZMIMAG(MA%MZM,MTFM)
+ CALL ZMIMAG(MB%MZM,MUFM)
+ L2 = FMCOMP(MTFM,'NE',MUFM)
+ FMLNE_ZMZM = L1.OR.L2
+ END FUNCTION
+
+! >
+
+ FUNCTION FMLGT_IFM(IVAL,MA)
+ LOGICAL FMLGT_IFM,FMCOMP
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ FMLGT_IFM = FMCOMP(MTFM,'GT',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLGT_IIM(IVAL,MA)
+ LOGICAL FMLGT_IIM,IMCOMP
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL IMI2M(IVAL,MTIM)
+ FMLGT_IIM = IMCOMP(MTIM,'GT',MA%MIM)
+ END FUNCTION
+
+ FUNCTION FMLGT_RFM(R,MA)
+ LOGICAL FMLGT_RFM,FMCOMP
+ TYPE ( FM ) MA
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ FMLGT_RFM = FMCOMP(MTFM,'GT',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLGT_RIM(R,MA)
+ USE FMVALS
+ LOGICAL FMLGT_RIM,FMCOMP
+ TYPE ( IM ) MA
+ INTEGER KA,NDSAVE
+ REAL R
+ INTENT (IN) :: R,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLGT_RIM = FMCOMP(MTFM,'GT',MUFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLGT_DFM(D,MA)
+ LOGICAL FMLGT_DFM,FMCOMP
+ TYPE ( FM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ FMLGT_DFM = FMCOMP(MTFM,'GT',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLGT_DIM(D,MA)
+ USE FMVALS
+ LOGICAL FMLGT_DIM,FMCOMP
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: D,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLGT_DIM = FMCOMP(MTFM,'GT',MUFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLGT_FMI(MA,IVAL)
+ LOGICAL FMLGT_FMI,FMCOMP
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL FMI2M(IVAL,MTFM)
+ FMLGT_FMI = FMCOMP(MA%MFM,'GT',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLGT_FMR(MA,R)
+ LOGICAL FMLGT_FMR,FMCOMP
+ TYPE ( FM ) MA
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ FMLGT_FMR = FMCOMP(MA%MFM,'GT',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLGT_FMD(MA,D)
+ LOGICAL FMLGT_FMD,FMCOMP
+ TYPE ( FM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ FMLGT_FMD = FMCOMP(MA%MFM,'GT',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLGT_FMFM(MA,MB)
+ LOGICAL FMLGT_FMFM,FMCOMP
+ TYPE ( FM ) MA,MB
+ INTENT (IN) :: MA,MB
+ FMLGT_FMFM = FMCOMP(MA%MFM,'GT',MB%MFM)
+ END FUNCTION
+
+ FUNCTION FMLGT_FMIM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLGT_FMIM,FMCOMP
+ TYPE ( FM ) MA
+ TYPE ( IM ) MB
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,MB
+ NDSAVE = NDIG
+ KA = MB%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL IMI2FM(MB%MIM,MTFM)
+ FMLGT_FMIM = FMCOMP(MA%MFM,'GT',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLGT_IMI(MA,IVAL)
+ LOGICAL FMLGT_IMI,IMCOMP
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL IMI2M(IVAL,MTIM)
+ FMLGT_IMI = IMCOMP(MA%MIM,'GT',MTIM)
+ END FUNCTION
+
+ FUNCTION FMLGT_IMR(MA,R)
+ USE FMVALS
+ LOGICAL FMLGT_IMR,FMCOMP
+ TYPE ( IM ) MA
+ INTEGER KA,NDSAVE
+ REAL R
+ INTENT (IN) :: MA,R
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLGT_IMR = FMCOMP(MUFM,'GT',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLGT_IMD(MA,D)
+ USE FMVALS
+ LOGICAL FMLGT_IMD,FMCOMP
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,D
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLGT_IMD = FMCOMP(MUFM,'GT',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLGT_IMFM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLGT_IMFM,FMCOMP
+ TYPE ( IM ) MA
+ TYPE ( FM ) MB
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,MB
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL IMI2FM(MA%MIM,MTFM)
+ FMLGT_IMFM = FMCOMP(MTFM,'GT',MB%MFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLGT_IMIM(MA,MB)
+ LOGICAL FMLGT_IMIM,IMCOMP
+ TYPE ( IM ) MA,MB
+ INTENT (IN) :: MA,MB
+ FMLGT_IMIM = IMCOMP(MA%MIM,'GT',MB%MIM)
+ END FUNCTION
+
+ END MODULE FMZM_3
+
+ MODULE FMZM_4
+ USE FMZM_1
+
+ INTERFACE OPERATOR ( >= )
+ MODULE PROCEDURE FMLGE_IFM
+ MODULE PROCEDURE FMLGE_IIM
+ MODULE PROCEDURE FMLGE_RFM
+ MODULE PROCEDURE FMLGE_RIM
+ MODULE PROCEDURE FMLGE_DFM
+ MODULE PROCEDURE FMLGE_DIM
+ MODULE PROCEDURE FMLGE_FMI
+ MODULE PROCEDURE FMLGE_FMR
+ MODULE PROCEDURE FMLGE_FMD
+ MODULE PROCEDURE FMLGE_FMFM
+ MODULE PROCEDURE FMLGE_FMIM
+ MODULE PROCEDURE FMLGE_IMI
+ MODULE PROCEDURE FMLGE_IMR
+ MODULE PROCEDURE FMLGE_IMD
+ MODULE PROCEDURE FMLGE_IMFM
+ MODULE PROCEDURE FMLGE_IMIM
+ END INTERFACE
+
+ INTERFACE OPERATOR ( < )
+ MODULE PROCEDURE FMLLT_IFM
+ MODULE PROCEDURE FMLLT_IIM
+ MODULE PROCEDURE FMLLT_RFM
+ MODULE PROCEDURE FMLLT_RIM
+ MODULE PROCEDURE FMLLT_DFM
+ MODULE PROCEDURE FMLLT_DIM
+ MODULE PROCEDURE FMLLT_FMI
+ MODULE PROCEDURE FMLLT_FMR
+ MODULE PROCEDURE FMLLT_FMD
+ MODULE PROCEDURE FMLLT_FMFM
+ MODULE PROCEDURE FMLLT_FMIM
+ MODULE PROCEDURE FMLLT_IMI
+ MODULE PROCEDURE FMLLT_IMR
+ MODULE PROCEDURE FMLLT_IMD
+ MODULE PROCEDURE FMLLT_IMFM
+ MODULE PROCEDURE FMLLT_IMIM
+ END INTERFACE
+
+ INTERFACE OPERATOR ( <= )
+ MODULE PROCEDURE FMLLE_IFM
+ MODULE PROCEDURE FMLLE_IIM
+ MODULE PROCEDURE FMLLE_RFM
+ MODULE PROCEDURE FMLLE_RIM
+ MODULE PROCEDURE FMLLE_DFM
+ MODULE PROCEDURE FMLLE_DIM
+ MODULE PROCEDURE FMLLE_FMI
+ MODULE PROCEDURE FMLLE_FMR
+ MODULE PROCEDURE FMLLE_FMD
+ MODULE PROCEDURE FMLLE_FMFM
+ MODULE PROCEDURE FMLLE_FMIM
+ MODULE PROCEDURE FMLLE_IMI
+ MODULE PROCEDURE FMLLE_IMR
+ MODULE PROCEDURE FMLLE_IMD
+ MODULE PROCEDURE FMLLE_IMFM
+ MODULE PROCEDURE FMLLE_IMIM
+ END INTERFACE
+
+ CONTAINS
+
+! >=
+
+ FUNCTION FMLGE_IFM(IVAL,MA)
+ LOGICAL FMLGE_IFM,FMCOMP
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ FMLGE_IFM = FMCOMP(MTFM,'GE',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLGE_IIM(IVAL,MA)
+ LOGICAL FMLGE_IIM,IMCOMP
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL IMI2M(IVAL,MTIM)
+ FMLGE_IIM = IMCOMP(MTIM,'GE',MA%MIM)
+ END FUNCTION
+
+ FUNCTION FMLGE_RFM(R,MA)
+ LOGICAL FMLGE_RFM,FMCOMP
+ TYPE ( FM ) MA
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ FMLGE_RFM = FMCOMP(MTFM,'GE',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLGE_RIM(R,MA)
+ USE FMVALS
+ LOGICAL FMLGE_RIM,FMCOMP
+ TYPE ( IM ) MA
+ INTEGER KA,NDSAVE
+ REAL R
+ INTENT (IN) :: R,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLGE_RIM = FMCOMP(MTFM,'GE',MUFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLGE_DFM(D,MA)
+ LOGICAL FMLGE_DFM,FMCOMP
+ TYPE ( FM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ FMLGE_DFM = FMCOMP(MTFM,'GE',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLGE_DIM(D,MA)
+ USE FMVALS
+ LOGICAL FMLGE_DIM,FMCOMP
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: D,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLGE_DIM = FMCOMP(MTFM,'GE',MUFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLGE_FMI(MA,IVAL)
+ LOGICAL FMLGE_FMI,FMCOMP
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL FMI2M(IVAL,MTFM)
+ FMLGE_FMI = FMCOMP(MA%MFM,'GE',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLGE_FMR(MA,R)
+ LOGICAL FMLGE_FMR,FMCOMP
+ TYPE ( FM ) MA
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ FMLGE_FMR = FMCOMP(MA%MFM,'GE',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLGE_FMD(MA,D)
+ LOGICAL FMLGE_FMD,FMCOMP
+ TYPE ( FM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ FMLGE_FMD = FMCOMP(MA%MFM,'GE',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLGE_FMFM(MA,MB)
+ LOGICAL FMLGE_FMFM,FMCOMP
+ TYPE ( FM ) MA,MB
+ INTENT (IN) :: MA,MB
+ FMLGE_FMFM = FMCOMP(MA%MFM,'GE',MB%MFM)
+ END FUNCTION
+
+ FUNCTION FMLGE_FMIM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLGE_FMIM,FMCOMP
+ TYPE ( FM ) MA
+ TYPE ( IM ) MB
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,MB
+ NDSAVE = NDIG
+ KA = MB%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL IMI2FM(MB%MIM,MTFM)
+ FMLGE_FMIM = FMCOMP(MA%MFM,'GE',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLGE_IMI(MA,IVAL)
+ LOGICAL FMLGE_IMI,IMCOMP
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL IMI2M(IVAL,MTIM)
+ FMLGE_IMI = IMCOMP(MA%MIM,'GE',MTIM)
+ END FUNCTION
+
+ FUNCTION FMLGE_IMR(MA,R)
+ USE FMVALS
+ LOGICAL FMLGE_IMR,FMCOMP
+ TYPE ( IM ) MA
+ INTEGER KA,NDSAVE
+ REAL R
+ INTENT (IN) :: MA,R
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLGE_IMR = FMCOMP(MUFM,'GE',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLGE_IMD(MA,D)
+ USE FMVALS
+ LOGICAL FMLGE_IMD,FMCOMP
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,D
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLGE_IMD = FMCOMP(MUFM,'GE',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLGE_IMFM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLGE_IMFM,FMCOMP
+ TYPE ( IM ) MA
+ TYPE ( FM ) MB
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,MB
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL IMI2FM(MA%MIM,MTFM)
+ FMLGE_IMFM = FMCOMP(MTFM,'GE',MB%MFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLGE_IMIM(MA,MB)
+ LOGICAL FMLGE_IMIM,IMCOMP
+ TYPE ( IM ) MA,MB
+ INTENT (IN) :: MA,MB
+ FMLGE_IMIM = IMCOMP(MA%MIM,'GE',MB%MIM)
+ END FUNCTION
+
+! <
+
+ FUNCTION FMLLT_IFM(IVAL,MA)
+ LOGICAL FMLLT_IFM,FMCOMP
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ FMLLT_IFM = FMCOMP(MTFM,'LT',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLLT_IIM(IVAL,MA)
+ LOGICAL FMLLT_IIM,IMCOMP
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL IMI2M(IVAL,MTIM)
+ FMLLT_IIM = IMCOMP(MTIM,'LT',MA%MIM)
+ END FUNCTION
+
+ FUNCTION FMLLT_RFM(R,MA)
+ LOGICAL FMLLT_RFM,FMCOMP
+ TYPE ( FM ) MA
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ FMLLT_RFM = FMCOMP(MTFM,'LT',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLLT_RIM(R,MA)
+ USE FMVALS
+ LOGICAL FMLLT_RIM,FMCOMP
+ TYPE ( IM ) MA
+ INTEGER KA,NDSAVE
+ REAL R
+ INTENT (IN) :: R,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLLT_RIM = FMCOMP(MTFM,'LT',MUFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLLT_DFM(D,MA)
+ LOGICAL FMLLT_DFM,FMCOMP
+ TYPE ( FM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ FMLLT_DFM = FMCOMP(MTFM,'LT',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLLT_DIM(D,MA)
+ USE FMVALS
+ LOGICAL FMLLT_DIM,FMCOMP
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: D,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLLT_DIM = FMCOMP(MTFM,'LT',MUFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLLT_FMI(MA,IVAL)
+ LOGICAL FMLLT_FMI,FMCOMP
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL FMI2M(IVAL,MTFM)
+ FMLLT_FMI = FMCOMP(MA%MFM,'LT',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLLT_FMR(MA,R)
+ LOGICAL FMLLT_FMR,FMCOMP
+ TYPE ( FM ) MA
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ FMLLT_FMR = FMCOMP(MA%MFM,'LT',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLLT_FMD(MA,D)
+ LOGICAL FMLLT_FMD,FMCOMP
+ TYPE ( FM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ FMLLT_FMD = FMCOMP(MA%MFM,'LT',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLLT_FMFM(MA,MB)
+ LOGICAL FMLLT_FMFM,FMCOMP
+ TYPE ( FM ) MA,MB
+ INTENT (IN) :: MA,MB
+ FMLLT_FMFM = FMCOMP(MA%MFM,'LT',MB%MFM)
+ END FUNCTION
+
+ FUNCTION FMLLT_FMIM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLLT_FMIM,FMCOMP
+ TYPE ( FM ) MA
+ TYPE ( IM ) MB
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,MB
+ NDSAVE = NDIG
+ KA = MB%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL IMI2FM(MB%MIM,MTFM)
+ FMLLT_FMIM = FMCOMP(MA%MFM,'LT',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLLT_IMI(MA,IVAL)
+ LOGICAL FMLLT_IMI,IMCOMP
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL IMI2M(IVAL,MTIM)
+ FMLLT_IMI = IMCOMP(MA%MIM,'LT',MTIM)
+ END FUNCTION
+
+ FUNCTION FMLLT_IMR(MA,R)
+ USE FMVALS
+ LOGICAL FMLLT_IMR,FMCOMP
+ TYPE ( IM ) MA
+ INTEGER KA,NDSAVE
+ REAL R
+ INTENT (IN) :: MA,R
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLLT_IMR = FMCOMP(MUFM,'LT',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLLT_IMD(MA,D)
+ USE FMVALS
+ LOGICAL FMLLT_IMD,FMCOMP
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,D
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLLT_IMD = FMCOMP(MUFM,'LT',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLLT_IMFM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLLT_IMFM,FMCOMP
+ TYPE ( IM ) MA
+ TYPE ( FM ) MB
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,MB
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL IMI2FM(MA%MIM,MTFM)
+ FMLLT_IMFM = FMCOMP(MTFM,'LT',MB%MFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLLT_IMIM(MA,MB)
+ LOGICAL FMLLT_IMIM,IMCOMP
+ TYPE ( IM ) MA,MB
+ INTENT (IN) :: MA,MB
+ FMLLT_IMIM = IMCOMP(MA%MIM,'LT',MB%MIM)
+ END FUNCTION
+
+! <=
+
+ FUNCTION FMLLE_IFM(IVAL,MA)
+ LOGICAL FMLLE_IFM,FMCOMP
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ FMLLE_IFM = FMCOMP(MTFM,'LE',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLLE_IIM(IVAL,MA)
+ LOGICAL FMLLE_IIM,IMCOMP
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL IMI2M(IVAL,MTIM)
+ FMLLE_IIM = IMCOMP(MTIM,'LE',MA%MIM)
+ END FUNCTION
+
+ FUNCTION FMLLE_RFM(R,MA)
+ LOGICAL FMLLE_RFM,FMCOMP
+ TYPE ( FM ) MA
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ FMLLE_RFM = FMCOMP(MTFM,'LE',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLLE_RIM(R,MA)
+ USE FMVALS
+ LOGICAL FMLLE_RIM,FMCOMP
+ TYPE ( IM ) MA
+ INTEGER KA,NDSAVE
+ REAL R
+ INTENT (IN) :: R,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLLE_RIM = FMCOMP(MTFM,'LE',MUFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLLE_DFM(D,MA)
+ LOGICAL FMLLE_DFM,FMCOMP
+ TYPE ( FM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ FMLLE_DFM = FMCOMP(MTFM,'LE',MA%MFM)
+ END FUNCTION
+
+ FUNCTION FMLLE_DIM(D,MA)
+ USE FMVALS
+ LOGICAL FMLLE_DIM,FMCOMP
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: D,MA
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLLE_DIM = FMCOMP(MTFM,'LE',MUFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLLE_FMI(MA,IVAL)
+ LOGICAL FMLLE_FMI,FMCOMP
+ TYPE ( FM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL FMI2M(IVAL,MTFM)
+ FMLLE_FMI = FMCOMP(MA%MFM,'LE',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLLE_FMR(MA,R)
+ LOGICAL FMLLE_FMR,FMCOMP
+ TYPE ( FM ) MA
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ FMLLE_FMR = FMCOMP(MA%MFM,'LE',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLLE_FMD(MA,D)
+ LOGICAL FMLLE_FMD,FMCOMP
+ TYPE ( FM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ FMLLE_FMD = FMCOMP(MA%MFM,'LE',MTFM)
+ END FUNCTION
+
+ FUNCTION FMLLE_FMFM(MA,MB)
+ LOGICAL FMLLE_FMFM,FMCOMP
+ TYPE ( FM ) MA,MB
+ INTENT (IN) :: MA,MB
+ FMLLE_FMFM = FMCOMP(MA%MFM,'LE',MB%MFM)
+ END FUNCTION
+
+ FUNCTION FMLLE_FMIM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLLE_FMIM,FMCOMP
+ TYPE ( FM ) MA
+ TYPE ( IM ) MB
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,MB
+ NDSAVE = NDIG
+ KA = MB%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL IMI2FM(MB%MIM,MTFM)
+ FMLLE_FMIM = FMCOMP(MA%MFM,'LE',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLLE_IMI(MA,IVAL)
+ LOGICAL FMLLE_IMI,IMCOMP
+ TYPE ( IM ) MA
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL IMI2M(IVAL,MTIM)
+ FMLLE_IMI = IMCOMP(MA%MIM,'LE',MTIM)
+ END FUNCTION
+
+ FUNCTION FMLLE_IMR(MA,R)
+ USE FMVALS
+ LOGICAL FMLLE_IMR,FMCOMP
+ TYPE ( IM ) MA
+ INTEGER KA,NDSAVE
+ REAL R
+ INTENT (IN) :: MA,R
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLLE_IMR = FMCOMP(MUFM,'LE',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLLE_IMD(MA,D)
+ USE FMVALS
+ LOGICAL FMLLE_IMD,FMCOMP
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,D
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ FMLLE_IMD = FMCOMP(MUFM,'LE',MTFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLLE_IMFM(MA,MB)
+ USE FMVALS
+ LOGICAL FMLLE_IMFM,FMCOMP
+ TYPE ( IM ) MA
+ TYPE ( FM ) MB
+ INTEGER KA,NDSAVE
+ INTENT (IN) :: MA,MB
+ NDSAVE = NDIG
+ KA = MA%MIM(1)
+ NDIG = MAX(KA+NGRD52,NDIG)
+ CALL IMI2FM(MA%MIM,MTFM)
+ FMLLE_IMFM = FMCOMP(MTFM,'LE',MB%MFM)
+ NDIG = NDSAVE
+ END FUNCTION
+
+ FUNCTION FMLLE_IMIM(MA,MB)
+ LOGICAL FMLLE_IMIM,IMCOMP
+ TYPE ( IM ) MA,MB
+ INTENT (IN) :: MA,MB
+ FMLLE_IMIM = IMCOMP(MA%MIM,'LE',MB%MIM)
+ END FUNCTION
+
+ END MODULE FMZM_4
+
+ MODULE FMZM_5
+ USE FMZM_1
+
+ INTERFACE OPERATOR (+)
+ MODULE PROCEDURE FMADD_IFM
+ MODULE PROCEDURE FMADD_IIM
+ MODULE PROCEDURE FMADD_IZM
+ MODULE PROCEDURE FMADD_RFM
+ MODULE PROCEDURE FMADD_RIM
+ MODULE PROCEDURE FMADD_RZM
+ MODULE PROCEDURE FMADD_DFM
+ MODULE PROCEDURE FMADD_DIM
+ MODULE PROCEDURE FMADD_DZM
+ MODULE PROCEDURE FMADD_ZFM
+ MODULE PROCEDURE FMADD_ZIM
+ MODULE PROCEDURE FMADD_ZZM
+ MODULE PROCEDURE FMADD_CFM
+ MODULE PROCEDURE FMADD_CIM
+ MODULE PROCEDURE FMADD_CZM
+ MODULE PROCEDURE FMADD_FMI
+ MODULE PROCEDURE FMADD_FMR
+ MODULE PROCEDURE FMADD_FMD
+ MODULE PROCEDURE FMADD_FMZ
+ MODULE PROCEDURE FMADD_FMC
+ MODULE PROCEDURE FMADD_FMFM
+ MODULE PROCEDURE FMADD_FMIM
+ MODULE PROCEDURE FMADD_FMZM
+ MODULE PROCEDURE FMADD_IMI
+ MODULE PROCEDURE FMADD_IMR
+ MODULE PROCEDURE FMADD_IMD
+ MODULE PROCEDURE FMADD_IMZ
+ MODULE PROCEDURE FMADD_IMC
+ MODULE PROCEDURE FMADD_IMFM
+ MODULE PROCEDURE FMADD_IMIM
+ MODULE PROCEDURE FMADD_IMZM
+ MODULE PROCEDURE FMADD_ZMI
+ MODULE PROCEDURE FMADD_ZMR
+ MODULE PROCEDURE FMADD_ZMD
+ MODULE PROCEDURE FMADD_ZMZ
+ MODULE PROCEDURE FMADD_ZMC
+ MODULE PROCEDURE FMADD_ZMFM
+ MODULE PROCEDURE FMADD_ZMIM
+ MODULE PROCEDURE FMADD_ZMZM
+ MODULE PROCEDURE FMADD_FM
+ MODULE PROCEDURE FMADD_IM
+ MODULE PROCEDURE FMADD_ZM
+ END INTERFACE
+
+ INTERFACE OPERATOR (-)
+ MODULE PROCEDURE FMSUB_IFM
+ MODULE PROCEDURE FMSUB_IIM
+ MODULE PROCEDURE FMSUB_IZM
+ MODULE PROCEDURE FMSUB_RFM
+ MODULE PROCEDURE FMSUB_RIM
+ MODULE PROCEDURE FMSUB_RZM
+ MODULE PROCEDURE FMSUB_DFM
+ MODULE PROCEDURE FMSUB_DIM
+ MODULE PROCEDURE FMSUB_DZM
+ MODULE PROCEDURE FMSUB_ZFM
+ MODULE PROCEDURE FMSUB_ZIM
+ MODULE PROCEDURE FMSUB_ZZM
+ MODULE PROCEDURE FMSUB_CFM
+ MODULE PROCEDURE FMSUB_CIM
+ MODULE PROCEDURE FMSUB_CZM
+ MODULE PROCEDURE FMSUB_FMI
+ MODULE PROCEDURE FMSUB_FMR
+ MODULE PROCEDURE FMSUB_FMD
+ MODULE PROCEDURE FMSUB_FMZ
+ MODULE PROCEDURE FMSUB_FMC
+ MODULE PROCEDURE FMSUB_FMFM
+ MODULE PROCEDURE FMSUB_FMIM
+ MODULE PROCEDURE FMSUB_FMZM
+ MODULE PROCEDURE FMSUB_IMI
+ MODULE PROCEDURE FMSUB_IMR
+ MODULE PROCEDURE FMSUB_IMD
+ MODULE PROCEDURE FMSUB_IMZ
+ MODULE PROCEDURE FMSUB_IMC
+ MODULE PROCEDURE FMSUB_IMFM
+ MODULE PROCEDURE FMSUB_IMIM
+ MODULE PROCEDURE FMSUB_IMZM
+ MODULE PROCEDURE FMSUB_ZMI
+ MODULE PROCEDURE FMSUB_ZMR
+ MODULE PROCEDURE FMSUB_ZMD
+ MODULE PROCEDURE FMSUB_ZMZ
+ MODULE PROCEDURE FMSUB_ZMC
+ MODULE PROCEDURE FMSUB_ZMFM
+ MODULE PROCEDURE FMSUB_ZMIM
+ MODULE PROCEDURE FMSUB_ZMZM
+ MODULE PROCEDURE FMSUB_FM
+ MODULE PROCEDURE FMSUB_IM
+ MODULE PROCEDURE FMSUB_ZM
+ END INTERFACE
+
+ CONTAINS
+
+! +
+
+ FUNCTION FMADD_IFM(IVAL,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMADD_IFM
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ CALL FMADD(MTFM,MA%MFM,FMADD_IFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMADD_IIM(IVAL,MA)
+ USE FMVALS
+ TYPE ( IM ) MA,FMADD_IIM
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL IMI2M(IVAL,MTIM)
+ CALL IMADD(MTIM,MA%MIM,FMADD_IIM%MIM)
+ END FUNCTION
+
+ FUNCTION FMADD_IZM(IVAL,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMADD_IZM
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMADD(MTZM,MA%MZM,FMADD_IZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_RFM(R,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMADD_RFM
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL FMADD(MTFM,MA%MFM,FMADD_RFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMADD_RIM(R,MA)
+ USE FMVALS
+ TYPE ( FM ) FMADD_RIM
+ TYPE ( IM ) MA
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMADD(MTFM,MUFM,FMADD_RIM%MFM)
+ END FUNCTION
+
+ FUNCTION FMADD_RZM(R,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMADD_RZM
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMADD(MTZM,MA%MZM,FMADD_RZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_DFM(D,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMADD_DFM
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL FMADD(MTFM,MA%MFM,FMADD_DFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMADD_DIM(D,MA)
+ USE FMVALS
+ TYPE ( FM ) FMADD_DIM
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMADD(MTFM,MUFM,FMADD_DIM%MFM)
+ END FUNCTION
+
+ FUNCTION FMADD_DZM(D,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMADD_DZM
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMADD(MTZM,MA%MZM,FMADD_DZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_ZFM(Z,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMADD_ZFM
+ TYPE ( FM ) MA
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMADD(MTZM,MUZM,FMADD_ZFM%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_ZIM(Z,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMADD_ZIM
+ TYPE ( IM ) MA
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMADD(MTZM,MUZM,FMADD_ZIM%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_ZZM(Z,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMADD_ZZM
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL ZMADD(MTZM,MA%MZM,FMADD_ZZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_CFM(C,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMADD_CFM
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMADD(MTZM,MUZM,FMADD_CFM%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_CIM(C,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMADD_CIM
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMADD(MTZM,MUZM,FMADD_CIM%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_CZM(C,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMADD_CZM
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMADD(MTZM,MA%MZM,FMADD_CZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_FMI(MA,IVAL)
+ USE FMVALS
+ TYPE ( FM ) MA,FMADD_FMI
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL FMI2M(IVAL,MTFM)
+ CALL FMADD(MA%MFM,MTFM,FMADD_FMI%MFM)
+ END FUNCTION
+
+ FUNCTION FMADD_FMR(MA,R)
+ USE FMVALS
+ TYPE ( FM ) MA,FMADD_FMR
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL FMADD(MA%MFM,MTFM,FMADD_FMR%MFM)
+ END FUNCTION
+
+ FUNCTION FMADD_FMD(MA,D)
+ USE FMVALS
+ TYPE ( FM ) MA,FMADD_FMD
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL FMADD(MA%MFM,MTFM,FMADD_FMD%MFM)
+ END FUNCTION
+
+ FUNCTION FMADD_FMZ(MA,Z)
+ USE FMVALS
+ TYPE ( ZM ) FMADD_FMZ
+ TYPE ( FM ) MA
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMADD(MUZM,MTZM,FMADD_FMZ%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_FMC(MA,C)
+ USE FMVALS
+ TYPE ( ZM ) FMADD_FMC
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMADD(MUZM,MTZM,FMADD_FMC%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_FMFM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMADD_FMFM
+ INTENT (IN) :: MA,MB
+ CALL FMADD(MA%MFM,MB%MFM,FMADD_FMFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMADD_FMIM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,FMADD_FMIM
+ TYPE ( IM ) MB
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MB%MIM,MTFM)
+ CALL FMADD(MA%MFM,MTFM,FMADD_FMIM%MFM)
+ END FUNCTION
+
+ FUNCTION FMADD_FMZM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA
+ TYPE ( ZM ) MB,FMADD_FMZM
+ INTENT (IN) :: MA,MB
+ CALL FMI2M(0,MTFM)
+ CALL ZMCMPX(MA%MFM,MTFM,MTZM)
+ CALL ZMADD(MTZM,MB%MZM,FMADD_FMZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_IMI(MA,IVAL)
+ USE FMVALS
+ TYPE ( IM ) MA,FMADD_IMI
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL IMI2M(IVAL,MTIM)
+ CALL IMADD(MA%MIM,MTIM,FMADD_IMI%MIM)
+ END FUNCTION
+
+ FUNCTION FMADD_IMR(MA,R)
+ USE FMVALS
+ TYPE ( FM ) FMADD_IMR
+ TYPE ( IM ) MA
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMADD(MUFM,MTFM,FMADD_IMR%MFM)
+ END FUNCTION
+
+ FUNCTION FMADD_IMD(MA,D)
+ USE FMVALS
+ TYPE ( FM ) FMADD_IMD
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMADD(MUFM,MTFM,FMADD_IMD%MFM)
+ END FUNCTION
+
+ FUNCTION FMADD_IMZ(MA,Z)
+ USE FMVALS
+ TYPE ( ZM ) FMADD_IMZ
+ TYPE ( IM ) MA
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMADD(MUZM,MTZM,FMADD_IMZ%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_IMC(MA,C)
+ USE FMVALS
+ TYPE ( ZM ) FMADD_IMC
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMADD(MUZM,MTZM,FMADD_IMC%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_IMFM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA
+ TYPE ( FM ) MB,FMADD_IMFM
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMADD(MTFM,MB%MFM,FMADD_IMFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMADD_IMIM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA,MB,FMADD_IMIM
+ INTENT (IN) :: MA,MB
+ CALL IMADD(MA%MIM,MB%MIM,FMADD_IMIM%MIM)
+ END FUNCTION
+
+ FUNCTION FMADD_IMZM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA
+ TYPE ( ZM ) MB,FMADD_IMZM
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMADD(MUZM,MB%MZM,FMADD_IMZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_ZMI(MA,IVAL)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMADD_ZMI
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL FMI2M(IVAL,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMADD(MA%MZM,MTZM,FMADD_ZMI%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_ZMR(MA,R)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMADD_ZMR
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMADD(MA%MZM,MTZM,FMADD_ZMR%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_ZMD(MA,D)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMADD_ZMD
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMADD(MA%MZM,MTZM,FMADD_ZMD%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_ZMZ(MA,Z)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMADD_ZMZ
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL ZMADD(MA%MZM,MTZM,FMADD_ZMZ%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_ZMC(MA,C)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMADD_ZMC
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMADD(MA%MZM,MTZM,FMADD_ZMC%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_ZMFM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MB
+ TYPE ( ZM ) MA,FMADD_ZMFM
+ INTENT (IN) :: MA,MB
+ CALL FMI2M(0,MTFM)
+ CALL ZMCMPX(MB%MFM,MTFM,MTZM)
+ CALL ZMADD(MA%MZM,MTZM,FMADD_ZMFM%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_ZMIM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MB
+ TYPE ( ZM ) MA,FMADD_ZMIM
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MB%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMADD(MA%MZM,MUZM,FMADD_ZMIM%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_ZMZM(MA,MB)
+ USE FMVALS
+ TYPE ( ZM ) MA,MB,FMADD_ZMZM
+ INTENT (IN) :: MA,MB
+ CALL ZMADD(MA%MZM,MB%MZM,FMADD_ZMZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMADD_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMADD_FM
+ INTENT (IN) :: MA
+ CALL FMEQ(MA%MFM,FMADD_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMADD_IM(MA)
+ USE FMVALS
+ TYPE ( IM ) MA,FMADD_IM
+ INTENT (IN) :: MA
+ CALL IMEQ(MA%MIM,FMADD_IM%MIM)
+ END FUNCTION
+
+ FUNCTION FMADD_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMADD_ZM
+ INTENT (IN) :: MA
+ CALL ZMEQ(MA%MZM,FMADD_ZM%MZM)
+ END FUNCTION
+
+! -
+
+ FUNCTION FMSUB_IFM(IVAL,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMSUB_IFM
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ CALL FMSUB(MTFM,MA%MFM,FMSUB_IFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMSUB_IIM(IVAL,MA)
+ USE FMVALS
+ TYPE ( IM ) MA,FMSUB_IIM
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL IMI2M(IVAL,MTIM)
+ CALL IMSUB(MTIM,MA%MIM,FMSUB_IIM%MIM)
+ END FUNCTION
+
+ FUNCTION FMSUB_IZM(IVAL,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMSUB_IZM
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMSUB(MTZM,MA%MZM,FMSUB_IZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_RFM(R,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMSUB_RFM
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL FMSUB(MTFM,MA%MFM,FMSUB_RFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMSUB_RIM(R,MA)
+ USE FMVALS
+ TYPE ( FM ) FMSUB_RIM
+ TYPE ( IM ) MA
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMSUB(MTFM,MUFM,FMSUB_RIM%MFM)
+ END FUNCTION
+
+ FUNCTION FMSUB_RZM(R,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMSUB_RZM
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMSUB(MTZM,MA%MZM,FMSUB_RZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_DFM(D,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMSUB_DFM
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL FMSUB(MTFM,MA%MFM,FMSUB_DFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMSUB_DIM(D,MA)
+ USE FMVALS
+ TYPE ( FM ) FMSUB_DIM
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMSUB(MTFM,MUFM,FMSUB_DIM%MFM)
+ END FUNCTION
+
+ FUNCTION FMSUB_DZM(D,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMSUB_DZM
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMSUB(MTZM,MA%MZM,FMSUB_DZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_ZFM(Z,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMSUB_ZFM
+ TYPE ( FM ) MA
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMSUB(MTZM,MUZM,FMSUB_ZFM%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_ZIM(Z,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMSUB_ZIM
+ TYPE ( IM ) MA
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMSUB(MTZM,MUZM,FMSUB_ZIM%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_ZZM(Z,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMSUB_ZZM
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL ZMSUB(MTZM,MA%MZM,FMSUB_ZZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_CFM(C,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMSUB_CFM
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMSUB(MTZM,MUZM,FMSUB_CFM%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_CIM(C,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMSUB_CIM
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMSUB(MTZM,MUZM,FMSUB_CIM%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_CZM(C,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMSUB_CZM
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMSUB(MTZM,MA%MZM,FMSUB_CZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_FMI(MA,IVAL)
+ USE FMVALS
+ TYPE ( FM ) MA,FMSUB_FMI
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL FMI2M(IVAL,MTFM)
+ CALL FMSUB(MA%MFM,MTFM,FMSUB_FMI%MFM)
+ END FUNCTION
+
+ FUNCTION FMSUB_FMR(MA,R)
+ USE FMVALS
+ TYPE ( FM ) MA,FMSUB_FMR
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL FMSUB(MA%MFM,MTFM,FMSUB_FMR%MFM)
+ END FUNCTION
+
+ FUNCTION FMSUB_FMD(MA,D)
+ USE FMVALS
+ TYPE ( FM ) MA,FMSUB_FMD
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL FMSUB(MA%MFM,MTFM,FMSUB_FMD%MFM)
+ END FUNCTION
+
+ FUNCTION FMSUB_FMZ(MA,Z)
+ USE FMVALS
+ TYPE ( ZM ) FMSUB_FMZ
+ TYPE ( FM ) MA
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMSUB(MUZM,MTZM,FMSUB_FMZ%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_FMC(MA,C)
+ USE FMVALS
+ TYPE ( ZM ) FMSUB_FMC
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMSUB(MUZM,MTZM,FMSUB_FMC%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_FMFM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMSUB_FMFM
+ INTENT (IN) :: MA,MB
+ CALL FMSUB(MA%MFM,MB%MFM,FMSUB_FMFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMSUB_FMIM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,FMSUB_FMIM
+ TYPE ( IM ) MB
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MB%MIM,MTFM)
+ CALL FMSUB(MA%MFM,MTFM,FMSUB_FMIM%MFM)
+ END FUNCTION
+
+ FUNCTION FMSUB_FMZM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA
+ TYPE ( ZM ) MB,FMSUB_FMZM
+ INTENT (IN) :: MA,MB
+ CALL FMI2M(0,MTFM)
+ CALL ZMCMPX(MA%MFM,MTFM,MTZM)
+ CALL ZMSUB(MTZM,MB%MZM,FMSUB_FMZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_IMI(MA,IVAL)
+ USE FMVALS
+ TYPE ( IM ) MA,FMSUB_IMI
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL IMI2M(IVAL,MTIM)
+ CALL IMSUB(MA%MIM,MTIM,FMSUB_IMI%MIM)
+ END FUNCTION
+
+ FUNCTION FMSUB_IMR(MA,R)
+ USE FMVALS
+ TYPE ( FM ) FMSUB_IMR
+ TYPE ( IM ) MA
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMSUB(MUFM,MTFM,FMSUB_IMR%MFM)
+ END FUNCTION
+
+ FUNCTION FMSUB_IMD(MA,D)
+ USE FMVALS
+ TYPE ( FM ) FMSUB_IMD
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMSUB(MUFM,MTFM,FMSUB_IMD%MFM)
+ END FUNCTION
+
+ FUNCTION FMSUB_IMZ(MA,Z)
+ USE FMVALS
+ TYPE ( ZM ) FMSUB_IMZ
+ TYPE ( IM ) MA
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMSUB(MUZM,MTZM,FMSUB_IMZ%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_IMC(MA,C)
+ USE FMVALS
+ TYPE ( ZM ) FMSUB_IMC
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMSUB(MUZM,MTZM,FMSUB_IMC%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_IMFM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA
+ TYPE ( FM ) MB,FMSUB_IMFM
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMSUB(MTFM,MB%MFM,FMSUB_IMFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMSUB_IMIM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA,MB,FMSUB_IMIM
+ INTENT (IN) :: MA,MB
+ CALL IMSUB(MA%MIM,MB%MIM,FMSUB_IMIM%MIM)
+ END FUNCTION
+
+ FUNCTION FMSUB_IMZM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA
+ TYPE ( ZM ) MB,FMSUB_IMZM
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMSUB(MUZM,MB%MZM,FMSUB_IMZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_ZMI(MA,IVAL)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMSUB_ZMI
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL FMI2M(IVAL,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMSUB(MA%MZM,MTZM,FMSUB_ZMI%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_ZMR(MA,R)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMSUB_ZMR
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMSUB(MA%MZM,MTZM,FMSUB_ZMR%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_ZMD(MA,D)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMSUB_ZMD
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMSUB(MA%MZM,MTZM,FMSUB_ZMD%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_ZMZ(MA,Z)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMSUB_ZMZ
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL ZMSUB(MA%MZM,MTZM,FMSUB_ZMZ%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_ZMC(MA,C)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMSUB_ZMC
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMSUB(MA%MZM,MTZM,FMSUB_ZMC%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_ZMFM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MB
+ TYPE ( ZM ) MA,FMSUB_ZMFM
+ INTENT (IN) :: MA,MB
+ CALL FMI2M(0,MTFM)
+ CALL ZMCMPX(MB%MFM,MTFM,MTZM)
+ CALL ZMSUB(MA%MZM,MTZM,FMSUB_ZMFM%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_ZMIM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MB
+ TYPE ( ZM ) MA,FMSUB_ZMIM
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MB%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMSUB(MA%MZM,MUZM,FMSUB_ZMIM%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_ZMZM(MA,MB)
+ USE FMVALS
+ TYPE ( ZM ) MA,MB,FMSUB_ZMZM
+ INTENT (IN) :: MA,MB
+ CALL ZMSUB(MA%MZM,MB%MZM,FMSUB_ZMZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMSUB_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMSUB_FM
+ INTENT (IN) :: MA
+ CALL FMEQ(MA%MFM,MTFM)
+ IF (MTFM(1) /= MUNKNO .AND. MTFM(2) /= 0) &
+ MTFM(-1) = -MTFM(-1)
+ CALL FMEQ(MTFM,FMSUB_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMSUB_IM(MA)
+ USE FMVALS
+ TYPE ( IM ) MA,FMSUB_IM
+ INTENT (IN) :: MA
+ CALL IMEQ(MA%MIM,MTIM)
+ IF (MTIM(1) /= MUNKNO .AND. MTIM(2) /= 0) &
+ MTIM(-1) = -MTIM(-1)
+ CALL IMEQ(MTIM,FMSUB_IM%MIM)
+ END FUNCTION
+
+ FUNCTION FMSUB_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMSUB_ZM
+ INTENT (IN) :: MA
+ CALL ZMEQ(MA%MZM,MTZM)
+ IF (MTZM(1) /= MUNKNO .AND. MTZM(2) /= 0) &
+ MTZM(-1) = -MTZM(-1)
+ IF (MTZM(KPTIMU+1) /= MUNKNO .AND. MTZM(KPTIMU+2) /= 0) THEN
+ MTZM(KPTIMU-1) = -MTZM(KPTIMU-1)
+ ENDIF
+ CALL ZMEQ(MTZM,FMSUB_ZM%MZM)
+ END FUNCTION
+
+ END MODULE FMZM_5
+
+ MODULE FMZM_6
+ USE FMZM_1
+
+ INTERFACE OPERATOR (*)
+ MODULE PROCEDURE FMMPY_IFM
+ MODULE PROCEDURE FMMPY_IIM
+ MODULE PROCEDURE FMMPY_IZM
+ MODULE PROCEDURE FMMPY_RFM
+ MODULE PROCEDURE FMMPY_RIM
+ MODULE PROCEDURE FMMPY_RZM
+ MODULE PROCEDURE FMMPY_DFM
+ MODULE PROCEDURE FMMPY_DIM
+ MODULE PROCEDURE FMMPY_DZM
+ MODULE PROCEDURE FMMPY_ZFM
+ MODULE PROCEDURE FMMPY_ZIM
+ MODULE PROCEDURE FMMPY_ZZM
+ MODULE PROCEDURE FMMPY_CFM
+ MODULE PROCEDURE FMMPY_CIM
+ MODULE PROCEDURE FMMPY_CZM
+ MODULE PROCEDURE FMMPY_FMI
+ MODULE PROCEDURE FMMPY_FMR
+ MODULE PROCEDURE FMMPY_FMD
+ MODULE PROCEDURE FMMPY_FMZ
+ MODULE PROCEDURE FMMPY_FMC
+ MODULE PROCEDURE FMMPY_FMFM
+ MODULE PROCEDURE FMMPY_FMIM
+ MODULE PROCEDURE FMMPY_FMZM
+ MODULE PROCEDURE FMMPY_IMI
+ MODULE PROCEDURE FMMPY_IMR
+ MODULE PROCEDURE FMMPY_IMD
+ MODULE PROCEDURE FMMPY_IMZ
+ MODULE PROCEDURE FMMPY_IMC
+ MODULE PROCEDURE FMMPY_IMFM
+ MODULE PROCEDURE FMMPY_IMIM
+ MODULE PROCEDURE FMMPY_IMZM
+ MODULE PROCEDURE FMMPY_ZMI
+ MODULE PROCEDURE FMMPY_ZMR
+ MODULE PROCEDURE FMMPY_ZMD
+ MODULE PROCEDURE FMMPY_ZMZ
+ MODULE PROCEDURE FMMPY_ZMC
+ MODULE PROCEDURE FMMPY_ZMFM
+ MODULE PROCEDURE FMMPY_ZMIM
+ MODULE PROCEDURE FMMPY_ZMZM
+ END INTERFACE
+
+ INTERFACE OPERATOR (/)
+ MODULE PROCEDURE FMDIV_IFM
+ MODULE PROCEDURE FMDIV_IIM
+ MODULE PROCEDURE FMDIV_IZM
+ MODULE PROCEDURE FMDIV_RFM
+ MODULE PROCEDURE FMDIV_RIM
+ MODULE PROCEDURE FMDIV_RZM
+ MODULE PROCEDURE FMDIV_DFM
+ MODULE PROCEDURE FMDIV_DIM
+ MODULE PROCEDURE FMDIV_DZM
+ MODULE PROCEDURE FMDIV_ZFM
+ MODULE PROCEDURE FMDIV_ZIM
+ MODULE PROCEDURE FMDIV_ZZM
+ MODULE PROCEDURE FMDIV_CFM
+ MODULE PROCEDURE FMDIV_CIM
+ MODULE PROCEDURE FMDIV_CZM
+ MODULE PROCEDURE FMDIV_FMI
+ MODULE PROCEDURE FMDIV_FMR
+ MODULE PROCEDURE FMDIV_FMD
+ MODULE PROCEDURE FMDIV_FMZ
+ MODULE PROCEDURE FMDIV_FMC
+ MODULE PROCEDURE FMDIV_FMFM
+ MODULE PROCEDURE FMDIV_FMIM
+ MODULE PROCEDURE FMDIV_FMZM
+ MODULE PROCEDURE FMDIV_IMI
+ MODULE PROCEDURE FMDIV_IMR
+ MODULE PROCEDURE FMDIV_IMD
+ MODULE PROCEDURE FMDIV_IMZ
+ MODULE PROCEDURE FMDIV_IMC
+ MODULE PROCEDURE FMDIV_IMFM
+ MODULE PROCEDURE FMDIV_IMIM
+ MODULE PROCEDURE FMDIV_IMZM
+ MODULE PROCEDURE FMDIV_ZMI
+ MODULE PROCEDURE FMDIV_ZMR
+ MODULE PROCEDURE FMDIV_ZMD
+ MODULE PROCEDURE FMDIV_ZMZ
+ MODULE PROCEDURE FMDIV_ZMC
+ MODULE PROCEDURE FMDIV_ZMFM
+ MODULE PROCEDURE FMDIV_ZMIM
+ MODULE PROCEDURE FMDIV_ZMZM
+ END INTERFACE
+
+ CONTAINS
+
+! *
+
+ FUNCTION FMMPY_IFM(IVAL,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMMPY_IFM
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMMPYI(MA%MFM,IVAL,FMMPY_IFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMMPY_IIM(IVAL,MA)
+ USE FMVALS
+ TYPE ( IM ) MA,FMMPY_IIM
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL IMMPYI(MA%MIM,IVAL,FMMPY_IIM%MIM)
+ END FUNCTION
+
+ FUNCTION FMMPY_IZM(IVAL,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMMPY_IZM
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL ZMMPYI(MA%MZM,IVAL,FMMPY_IZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_RFM(R,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMMPY_RFM
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL FMMPY(MTFM,MA%MFM,FMMPY_RFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMMPY_RIM(R,MA)
+ USE FMVALS
+ TYPE ( FM ) FMMPY_RIM
+ TYPE ( IM ) MA
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMMPY(MTFM,MUFM,FMMPY_RIM%MFM)
+ END FUNCTION
+
+ FUNCTION FMMPY_RZM(R,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMMPY_RZM
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMMPY(MTZM,MA%MZM,FMMPY_RZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_DFM(D,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMMPY_DFM
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL FMMPY(MTFM,MA%MFM,FMMPY_DFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMMPY_DIM(D,MA)
+ USE FMVALS
+ TYPE ( FM ) FMMPY_DIM
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMMPY(MTFM,MUFM,FMMPY_DIM%MFM)
+ END FUNCTION
+
+ FUNCTION FMMPY_DZM(D,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMMPY_DZM
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMMPY(MTZM,MA%MZM,FMMPY_DZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_ZFM(Z,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMMPY_ZFM
+ TYPE ( FM ) MA
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMMPY(MTZM,MUZM,FMMPY_ZFM%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_ZIM(Z,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMMPY_ZIM
+ TYPE ( IM ) MA
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMMPY(MTZM,MUZM,FMMPY_ZIM%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_ZZM(Z,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMMPY_ZZM
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL ZMMPY(MTZM,MA%MZM,FMMPY_ZZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_CFM(C,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMMPY_CFM
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMMPY(MTZM,MUZM,FMMPY_CFM%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_CIM(C,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMMPY_CIM
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMMPY(MTZM,MUZM,FMMPY_CIM%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_CZM(C,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMMPY_CZM
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMMPY(MTZM,MA%MZM,FMMPY_CZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_FMI(MA,IVAL)
+ USE FMVALS
+ TYPE ( FM ) MA,FMMPY_FMI
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL FMMPYI(MA%MFM,IVAL,FMMPY_FMI%MFM)
+ END FUNCTION
+
+ FUNCTION FMMPY_FMR(MA,R)
+ USE FMVALS
+ TYPE ( FM ) MA,FMMPY_FMR
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL FMMPY(MA%MFM,MTFM,FMMPY_FMR%MFM)
+ END FUNCTION
+
+ FUNCTION FMMPY_FMD(MA,D)
+ USE FMVALS
+ TYPE ( FM ) MA,FMMPY_FMD
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL FMMPY(MA%MFM,MTFM,FMMPY_FMD%MFM)
+ END FUNCTION
+
+ FUNCTION FMMPY_FMZ(MA,Z)
+ USE FMVALS
+ TYPE ( ZM ) FMMPY_FMZ
+ TYPE ( FM ) MA
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMMPY(MUZM,MTZM,FMMPY_FMZ%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_FMC(MA,C)
+ USE FMVALS
+ TYPE ( ZM ) FMMPY_FMC
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMMPY(MUZM,MTZM,FMMPY_FMC%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_FMFM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMMPY_FMFM
+ INTENT (IN) :: MA,MB
+ CALL FMMPY(MA%MFM,MB%MFM,FMMPY_FMFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMMPY_FMIM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,FMMPY_FMIM
+ TYPE ( IM ) MB
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MB%MIM,MTFM)
+ CALL FMMPY(MA%MFM,MTFM,FMMPY_FMIM%MFM)
+ END FUNCTION
+
+ FUNCTION FMMPY_FMZM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA
+ TYPE ( ZM ) MB,FMMPY_FMZM
+ INTENT (IN) :: MA,MB
+ CALL FMI2M(0,MTFM)
+ CALL ZMCMPX(MA%MFM,MTFM,MTZM)
+ CALL ZMMPY(MTZM,MB%MZM,FMMPY_FMZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_IMI(MA,IVAL)
+ USE FMVALS
+ TYPE ( IM ) MA,FMMPY_IMI
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL IMMPYI(MA%MIM,IVAL,FMMPY_IMI%MIM)
+ END FUNCTION
+
+ FUNCTION FMMPY_IMR(MA,R)
+ USE FMVALS
+ TYPE ( FM ) FMMPY_IMR
+ TYPE ( IM ) MA
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMMPY(MUFM,MTFM,FMMPY_IMR%MFM)
+ END FUNCTION
+
+ FUNCTION FMMPY_IMD(MA,D)
+ USE FMVALS
+ TYPE ( FM ) FMMPY_IMD
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMMPY(MUFM,MTFM,FMMPY_IMD%MFM)
+ END FUNCTION
+
+ FUNCTION FMMPY_IMZ(MA,Z)
+ USE FMVALS
+ TYPE ( ZM ) FMMPY_IMZ
+ TYPE ( IM ) MA
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMMPY(MUZM,MTZM,FMMPY_IMZ%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_IMC(MA,C)
+ USE FMVALS
+ TYPE ( ZM ) FMMPY_IMC
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMMPY(MUZM,MTZM,FMMPY_IMC%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_IMFM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA
+ TYPE ( FM ) MB,FMMPY_IMFM
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMMPY(MTFM,MB%MFM,FMMPY_IMFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMMPY_IMIM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA,MB,FMMPY_IMIM
+ INTENT (IN) :: MA,MB
+ CALL IMMPY(MA%MIM,MB%MIM,FMMPY_IMIM%MIM)
+ END FUNCTION
+
+ FUNCTION FMMPY_IMZM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA
+ TYPE ( ZM ) MB,FMMPY_IMZM
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMMPY(MUZM,MB%MZM,FMMPY_IMZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_ZMI(MA,IVAL)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMMPY_ZMI
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL ZMMPYI(MA%MZM,IVAL,FMMPY_ZMI%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_ZMR(MA,R)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMMPY_ZMR
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMMPY(MA%MZM,MTZM,FMMPY_ZMR%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_ZMD(MA,D)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMMPY_ZMD
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMMPY(MA%MZM,MTZM,FMMPY_ZMD%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_ZMZ(MA,Z)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMMPY_ZMZ
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL ZMMPY(MA%MZM,MTZM,FMMPY_ZMZ%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_ZMC(MA,C)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMMPY_ZMC
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMMPY(MA%MZM,MTZM,FMMPY_ZMC%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_ZMFM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MB
+ TYPE ( ZM ) MA,FMMPY_ZMFM
+ INTENT (IN) :: MA,MB
+ CALL FMI2M(0,MTFM)
+ CALL ZMCMPX(MB%MFM,MTFM,MTZM)
+ CALL ZMMPY(MA%MZM,MTZM,FMMPY_ZMFM%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_ZMIM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MB
+ TYPE ( ZM ) MA,FMMPY_ZMIM
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MB%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMMPY(MA%MZM,MUZM,FMMPY_ZMIM%MZM)
+ END FUNCTION
+
+ FUNCTION FMMPY_ZMZM(MA,MB)
+ USE FMVALS
+ TYPE ( ZM ) MA,MB,FMMPY_ZMZM
+ INTENT (IN) :: MA,MB
+ CALL ZMMPY(MA%MZM,MB%MZM,FMMPY_ZMZM%MZM)
+ END FUNCTION
+
+! /
+
+ FUNCTION FMDIV_IFM(IVAL,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMDIV_IFM
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ CALL FMDIV(MTFM,MA%MFM,FMDIV_IFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMDIV_IIM(IVAL,MA)
+ USE FMVALS
+ TYPE ( IM ) MA,FMDIV_IIM
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL IMI2M(IVAL,MTIM)
+ CALL IMDIV(MTIM,MA%MIM,FMDIV_IIM%MIM)
+ END FUNCTION
+
+ FUNCTION FMDIV_IZM(IVAL,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMDIV_IZM
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMDIV(MTZM,MA%MZM,FMDIV_IZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_RFM(R,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMDIV_RFM
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL FMDIV(MTFM,MA%MFM,FMDIV_RFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMDIV_RIM(R,MA)
+ USE FMVALS
+ TYPE ( FM ) FMDIV_RIM
+ TYPE ( IM ) MA
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMDIV(MTFM,MUFM,FMDIV_RIM%MFM)
+ END FUNCTION
+
+ FUNCTION FMDIV_RZM(R,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMDIV_RZM
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMDIV(MTZM,MA%MZM,FMDIV_RZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_DFM(D,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMDIV_DFM
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL FMDIV(MTFM,MA%MFM,FMDIV_DFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMDIV_DIM(D,MA)
+ USE FMVALS
+ TYPE ( FM ) FMDIV_DIM
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMDIV(MTFM,MUFM,FMDIV_DIM%MFM)
+ END FUNCTION
+
+ FUNCTION FMDIV_DZM(D,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMDIV_DZM
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMDIV(MTZM,MA%MZM,FMDIV_DZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_ZFM(Z,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMDIV_ZFM
+ TYPE ( FM ) MA
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMDIV(MTZM,MUZM,FMDIV_ZFM%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_ZIM(Z,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMDIV_ZIM
+ TYPE ( IM ) MA
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMDIV(MTZM,MUZM,FMDIV_ZIM%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_ZZM(Z,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMDIV_ZZM
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL ZMDIV(MTZM,MA%MZM,FMDIV_ZZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_CFM(C,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMDIV_CFM
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMDIV(MTZM,MUZM,FMDIV_CFM%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_CIM(C,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMDIV_CIM
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMDIV(MTZM,MUZM,FMDIV_CIM%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_CZM(C,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMDIV_CZM
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMDIV(MTZM,MA%MZM,FMDIV_CZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_FMI(MA,IVAL)
+ USE FMVALS
+ TYPE ( FM ) MA,FMDIV_FMI
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL FMDIVI(MA%MFM,IVAL,FMDIV_FMI%MFM)
+ END FUNCTION
+
+ FUNCTION FMDIV_FMR(MA,R)
+ USE FMVALS
+ TYPE ( FM ) MA,FMDIV_FMR
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL FMDIV(MA%MFM,MTFM,FMDIV_FMR%MFM)
+ END FUNCTION
+
+ FUNCTION FMDIV_FMD(MA,D)
+ USE FMVALS
+ TYPE ( FM ) MA,FMDIV_FMD
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL FMDIV(MA%MFM,MTFM,FMDIV_FMD%MFM)
+ END FUNCTION
+
+ FUNCTION FMDIV_FMZ(MA,Z)
+ USE FMVALS
+ TYPE ( ZM ) FMDIV_FMZ
+ TYPE ( FM ) MA
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMDIV(MUZM,MTZM,FMDIV_FMZ%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_FMC(MA,C)
+ USE FMVALS
+ TYPE ( ZM ) FMDIV_FMC
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMDIV(MUZM,MTZM,FMDIV_FMC%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_FMFM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMDIV_FMFM
+ INTENT (IN) :: MA,MB
+ CALL FMDIV(MA%MFM,MB%MFM,FMDIV_FMFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMDIV_FMIM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,FMDIV_FMIM
+ TYPE ( IM ) MB
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MB%MIM,MTFM)
+ CALL FMDIV(MA%MFM,MTFM,FMDIV_FMIM%MFM)
+ END FUNCTION
+
+ FUNCTION FMDIV_FMZM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA
+ TYPE ( ZM ) MB,FMDIV_FMZM
+ INTENT (IN) :: MA,MB
+ CALL FMI2M(0,MTFM)
+ CALL ZMCMPX(MA%MFM,MTFM,MTZM)
+ CALL ZMDIV(MTZM,MB%MZM,FMDIV_FMZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_IMI(MA,IVAL)
+ USE FMVALS
+ TYPE ( IM ) MA,FMDIV_IMI
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL IMDIVI(MA%MIM,IVAL,FMDIV_IMI%MIM)
+ END FUNCTION
+
+ FUNCTION FMDIV_IMR(MA,R)
+ USE FMVALS
+ TYPE ( FM ) FMDIV_IMR
+ TYPE ( IM ) MA
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMDIV(MUFM,MTFM,FMDIV_IMR%MFM)
+ END FUNCTION
+
+ FUNCTION FMDIV_IMD(MA,D)
+ USE FMVALS
+ TYPE ( FM ) FMDIV_IMD
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMDIV(MUFM,MTFM,FMDIV_IMD%MFM)
+ END FUNCTION
+
+ FUNCTION FMDIV_IMZ(MA,Z)
+ USE FMVALS
+ TYPE ( ZM ) FMDIV_IMZ
+ TYPE ( IM ) MA
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMDIV(MUZM,MTZM,FMDIV_IMZ%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_IMC(MA,C)
+ USE FMVALS
+ TYPE ( ZM ) FMDIV_IMC
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMDIV(MUZM,MTZM,FMDIV_IMC%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_IMFM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA
+ TYPE ( FM ) MB,FMDIV_IMFM
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMDIV(MTFM,MB%MFM,FMDIV_IMFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMDIV_IMIM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA,MB,FMDIV_IMIM
+ INTENT (IN) :: MA,MB
+ CALL IMDIV(MA%MIM,MB%MIM,FMDIV_IMIM%MIM)
+ END FUNCTION
+
+ FUNCTION FMDIV_IMZM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA
+ TYPE ( ZM ) MB,FMDIV_IMZM
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMDIV(MUZM,MB%MZM,FMDIV_IMZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_ZMI(MA,IVAL)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMDIV_ZMI
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL ZMDIVI(MA%MZM,IVAL,FMDIV_ZMI%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_ZMR(MA,R)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMDIV_ZMR
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMDIV(MA%MZM,MTZM,FMDIV_ZMR%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_ZMD(MA,D)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMDIV_ZMD
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMDIV(MA%MZM,MTZM,FMDIV_ZMD%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_ZMZ(MA,Z)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMDIV_ZMZ
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL ZMDIV(MA%MZM,MTZM,FMDIV_ZMZ%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_ZMC(MA,C)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMDIV_ZMC
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMDIV(MA%MZM,MTZM,FMDIV_ZMC%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_ZMFM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MB
+ TYPE ( ZM ) MA,FMDIV_ZMFM
+ INTENT (IN) :: MA,MB
+ CALL FMI2M(0,MTFM)
+ CALL ZMCMPX(MB%MFM,MTFM,MTZM)
+ CALL ZMDIV(MA%MZM,MTZM,FMDIV_ZMFM%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_ZMIM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MB
+ TYPE ( ZM ) MA,FMDIV_ZMIM
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MB%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMDIV(MA%MZM,MUZM,FMDIV_ZMIM%MZM)
+ END FUNCTION
+
+ FUNCTION FMDIV_ZMZM(MA,MB)
+ USE FMVALS
+ TYPE ( ZM ) MA,MB,FMDIV_ZMZM
+ INTENT (IN) :: MA,MB
+ CALL ZMDIV(MA%MZM,MB%MZM,FMDIV_ZMZM%MZM)
+ END FUNCTION
+
+ END MODULE FMZM_6
+
+ MODULE FMZM_7
+ USE FMZM_1
+
+ INTERFACE OPERATOR (**)
+ MODULE PROCEDURE FMPWR_IFM
+ MODULE PROCEDURE FMPWR_IIM
+ MODULE PROCEDURE FMPWR_IZM
+ MODULE PROCEDURE FMPWR_RFM
+ MODULE PROCEDURE FMPWR_RIM
+ MODULE PROCEDURE FMPWR_RZM
+ MODULE PROCEDURE FMPWR_DFM
+ MODULE PROCEDURE FMPWR_DIM
+ MODULE PROCEDURE FMPWR_DZM
+ MODULE PROCEDURE FMPWR_ZFM
+ MODULE PROCEDURE FMPWR_ZIM
+ MODULE PROCEDURE FMPWR_ZZM
+ MODULE PROCEDURE FMPWR_CFM
+ MODULE PROCEDURE FMPWR_CIM
+ MODULE PROCEDURE FMPWR_CZM
+ MODULE PROCEDURE FMPWR_FMI
+ MODULE PROCEDURE FMPWR_FMR
+ MODULE PROCEDURE FMPWR_FMD
+ MODULE PROCEDURE FMPWR_FMZ
+ MODULE PROCEDURE FMPWR_FMC
+ MODULE PROCEDURE FMPWR_FMFM
+ MODULE PROCEDURE FMPWR_FMIM
+ MODULE PROCEDURE FMPWR_FMZM
+ MODULE PROCEDURE FMPWR_IMI
+ MODULE PROCEDURE FMPWR_IMR
+ MODULE PROCEDURE FMPWR_IMD
+ MODULE PROCEDURE FMPWR_IMZ
+ MODULE PROCEDURE FMPWR_IMC
+ MODULE PROCEDURE FMPWR_IMFM
+ MODULE PROCEDURE FMPWR_IMIM
+ MODULE PROCEDURE FMPWR_IMZM
+ MODULE PROCEDURE FMPWR_ZMI
+ MODULE PROCEDURE FMPWR_ZMR
+ MODULE PROCEDURE FMPWR_ZMD
+ MODULE PROCEDURE FMPWR_ZMZ
+ MODULE PROCEDURE FMPWR_ZMC
+ MODULE PROCEDURE FMPWR_ZMFM
+ MODULE PROCEDURE FMPWR_ZMIM
+ MODULE PROCEDURE FMPWR_ZMZM
+ END INTERFACE
+
+ INTERFACE ABS
+ MODULE PROCEDURE FMABS_FM
+ MODULE PROCEDURE FMABS_IM
+ MODULE PROCEDURE FMABS_ZM
+ END INTERFACE
+
+ INTERFACE ACOS
+ MODULE PROCEDURE FMACOS_FM
+ MODULE PROCEDURE FMACOS_ZM
+ END INTERFACE
+
+ INTERFACE AIMAG
+ MODULE PROCEDURE FMAIMAG_ZM
+ END INTERFACE
+
+ INTERFACE AINT
+ MODULE PROCEDURE FMAINT_FM
+ MODULE PROCEDURE FMAINT_ZM
+ END INTERFACE
+
+ INTERFACE ANINT
+ MODULE PROCEDURE FMANINT_FM
+ MODULE PROCEDURE FMANINT_ZM
+ END INTERFACE
+
+ INTERFACE ASIN
+ MODULE PROCEDURE FMASIN_FM
+ MODULE PROCEDURE FMASIN_ZM
+ END INTERFACE
+
+ INTERFACE ATAN
+ MODULE PROCEDURE FMATAN_FM
+ MODULE PROCEDURE FMATAN_ZM
+ END INTERFACE
+
+ INTERFACE ATAN2
+ MODULE PROCEDURE FMATAN2_FM
+ END INTERFACE
+
+ INTERFACE BTEST
+ MODULE PROCEDURE FMBTEST_IM
+ END INTERFACE
+
+ INTERFACE CEILING
+ MODULE PROCEDURE FMCEILING_FM
+ MODULE PROCEDURE FMCEILING_ZM
+ END INTERFACE
+
+ INTERFACE CMPLX
+ MODULE PROCEDURE FMCMPLX_FM
+ MODULE PROCEDURE FMCMPLX_IM
+ END INTERFACE
+
+ INTERFACE CONJG
+ MODULE PROCEDURE FMCONJG_ZM
+ END INTERFACE
+
+ INTERFACE COS
+ MODULE PROCEDURE FMCOS_FM
+ MODULE PROCEDURE FMCOS_ZM
+ END INTERFACE
+
+ INTERFACE COSH
+ MODULE PROCEDURE FMCOSH_FM
+ MODULE PROCEDURE FMCOSH_ZM
+ END INTERFACE
+
+ INTERFACE DBLE
+ MODULE PROCEDURE FMDBLE_FM
+ MODULE PROCEDURE FMDBLE_IM
+ MODULE PROCEDURE FMDBLE_ZM
+ END INTERFACE
+
+ INTERFACE DIGITS
+ MODULE PROCEDURE FMDIGITS_FM
+ MODULE PROCEDURE FMDIGITS_IM
+ MODULE PROCEDURE FMDIGITS_ZM
+ END INTERFACE
+
+ INTERFACE DIM
+ MODULE PROCEDURE FMDIM_FM
+ MODULE PROCEDURE FMDIM_IM
+ END INTERFACE
+
+ INTERFACE DINT
+ MODULE PROCEDURE FMDINT_FM
+ MODULE PROCEDURE FMDINT_ZM
+ END INTERFACE
+
+ INTERFACE DOTPRODUCT
+ MODULE PROCEDURE FMDOTPRODUCT_FM
+ MODULE PROCEDURE FMDOTPRODUCT_IM
+ MODULE PROCEDURE FMDOTPRODUCT_ZM
+ END INTERFACE
+
+ CONTAINS
+
+! **
+
+ FUNCTION FMPWR_IFM(IVAL,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMPWR_IFM
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ CALL FMPWR(MTFM,MA%MFM,FMPWR_IFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMPWR_IIM(IVAL,MA)
+ USE FMVALS
+ TYPE ( IM ) MA,FMPWR_IIM
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL IMI2M(IVAL,MTIM)
+ CALL IMPWR(MTIM,MA%MIM,FMPWR_IIM%MIM)
+ END FUNCTION
+
+ FUNCTION FMPWR_IZM(IVAL,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMPWR_IZM
+ INTEGER IVAL
+ INTENT (IN) :: IVAL,MA
+ CALL FMI2M(IVAL,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMPWR(MTZM,MA%MZM,FMPWR_IZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_RFM(R,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMPWR_RFM
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL FMPWR(MTFM,MA%MFM,FMPWR_RFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMPWR_RIM(R,MA)
+ USE FMVALS
+ TYPE ( FM ) FMPWR_RIM
+ TYPE ( IM ) MA
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMPWR(MTFM,MUFM,FMPWR_RIM%MFM)
+ END FUNCTION
+
+ FUNCTION FMPWR_RZM(R,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMPWR_RZM
+ REAL R
+ INTENT (IN) :: R,MA
+ CALL FMSP2M(R,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMPWR(MTZM,MA%MZM,FMPWR_RZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_DFM(D,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMPWR_DFM
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL FMPWR(MTFM,MA%MFM,FMPWR_DFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMPWR_DIM(D,MA)
+ USE FMVALS
+ TYPE ( FM ) FMPWR_DIM
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMPWR(MTFM,MUFM,FMPWR_DIM%MFM)
+ END FUNCTION
+
+ FUNCTION FMPWR_DZM(D,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMPWR_DZM
+ DOUBLE PRECISION D
+ INTENT (IN) :: D,MA
+ CALL FMDP2M(D,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMPWR(MTZM,MA%MZM,FMPWR_DZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_ZFM(Z,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMPWR_ZFM
+ TYPE ( FM ) MA
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMPWR(MTZM,MUZM,FMPWR_ZFM%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_ZIM(Z,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMPWR_ZIM
+ TYPE ( IM ) MA
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMPWR(MTZM,MUZM,FMPWR_ZIM%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_ZZM(Z,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMPWR_ZZM
+ COMPLEX Z
+ INTENT (IN) :: Z,MA
+ CALL ZMZ2M(Z,MTZM)
+ CALL ZMPWR(MTZM,MA%MZM,FMPWR_ZZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_CFM(C,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMPWR_CFM
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMPWR(MTZM,MUZM,FMPWR_CFM%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_CIM(C,MA)
+ USE FMVALS
+ TYPE ( ZM ) FMPWR_CIM
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMPWR(MTZM,MUZM,FMPWR_CIM%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_CZM(C,MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMPWR_CZM
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C,MA
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMPWR(MTZM,MA%MZM,FMPWR_CZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_FMI(MA,IVAL)
+ USE FMVALS
+ TYPE ( FM ) MA,FMPWR_FMI
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL FMIPWR(MA%MFM,IVAL,FMPWR_FMI%MFM)
+ END FUNCTION
+
+ FUNCTION FMPWR_FMR(MA,R)
+ USE FMVALS
+ TYPE ( FM ) MA,FMPWR_FMR
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL FMPWR(MA%MFM,MTFM,FMPWR_FMR%MFM)
+ END FUNCTION
+
+ FUNCTION FMPWR_FMD(MA,D)
+ USE FMVALS
+ TYPE ( FM ) MA,FMPWR_FMD
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL FMPWR(MA%MFM,MTFM,FMPWR_FMD%MFM)
+ END FUNCTION
+
+ FUNCTION FMPWR_FMZ(MA,Z)
+ USE FMVALS
+ TYPE ( ZM ) FMPWR_FMZ
+ TYPE ( FM ) MA
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMPWR(MUZM,MTZM,FMPWR_FMZ%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_FMC(MA,C)
+ USE FMVALS
+ TYPE ( ZM ) FMPWR_FMC
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,MUZM)
+ CALL ZMPWR(MUZM,MTZM,FMPWR_FMC%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_FMFM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMPWR_FMFM
+ INTENT (IN) :: MA,MB
+ CALL FMPWR(MA%MFM,MB%MFM,FMPWR_FMFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMPWR_FMIM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,FMPWR_FMIM
+ TYPE ( IM ) MB
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MB%MIM,MTFM)
+ CALL FMPWR(MA%MFM,MTFM,FMPWR_FMIM%MFM)
+ END FUNCTION
+
+ FUNCTION FMPWR_FMZM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA
+ TYPE ( ZM ) MB,FMPWR_FMZM
+ INTENT (IN) :: MA,MB
+ CALL FMI2M(0,MTFM)
+ CALL ZMCMPX(MA%MFM,MTFM,MTZM)
+ CALL ZMPWR(MTZM,MB%MZM,FMPWR_FMZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_IMI(MA,IVAL)
+ USE FMVALS
+ TYPE ( IM ) MA,FMPWR_IMI
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL IMI2M(IVAL,MTIM)
+ CALL IMPWR(MA%MIM,MTIM,FMPWR_IMI%MIM)
+ END FUNCTION
+
+ FUNCTION FMPWR_IMR(MA,R)
+ USE FMVALS
+ TYPE ( FM ) FMPWR_IMR
+ TYPE ( IM ) MA
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMPWR(MUFM,MTFM,FMPWR_IMR%MFM)
+ END FUNCTION
+
+ FUNCTION FMPWR_IMD(MA,D)
+ USE FMVALS
+ TYPE ( FM ) FMPWR_IMD
+ TYPE ( IM ) MA
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL IMI2FM(MA%MIM,MUFM)
+ CALL FMPWR(MUFM,MTFM,FMPWR_IMD%MFM)
+ END FUNCTION
+
+ FUNCTION FMPWR_IMZ(MA,Z)
+ USE FMVALS
+ TYPE ( ZM ) FMPWR_IMZ
+ TYPE ( IM ) MA
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMPWR(MUZM,MTZM,FMPWR_IMZ%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_IMC(MA,C)
+ USE FMVALS
+ TYPE ( ZM ) FMPWR_IMC
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMPWR(MUZM,MTZM,FMPWR_IMC%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_IMFM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA
+ TYPE ( FM ) MB,FMPWR_IMFM
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMPWR(MTFM,MB%MFM,FMPWR_IMFM%MFM)
+ END FUNCTION
+
+ FUNCTION FMPWR_IMIM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA,MB,FMPWR_IMIM
+ INTENT (IN) :: MA,MB
+ CALL IMPWR(MA%MIM,MB%MIM,FMPWR_IMIM%MIM)
+ END FUNCTION
+
+ FUNCTION FMPWR_IMZM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA
+ TYPE ( ZM ) MB,FMPWR_IMZM
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMPWR(MUZM,MB%MZM,FMPWR_IMZM%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_ZMI(MA,IVAL)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMPWR_ZMI
+ INTEGER IVAL
+ INTENT (IN) :: MA,IVAL
+ CALL ZMIPWR(MA%MZM,IVAL,FMPWR_ZMI%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_ZMR(MA,R)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMPWR_ZMR
+ REAL R
+ INTENT (IN) :: MA,R
+ CALL FMSP2M(R,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMPWR(MA%MZM,MTZM,FMPWR_ZMR%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_ZMD(MA,D)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMPWR_ZMD
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA,D
+ CALL FMDP2M(D,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMPWR(MA%MZM,MTZM,FMPWR_ZMD%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_ZMZ(MA,Z)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMPWR_ZMZ
+ COMPLEX Z
+ INTENT (IN) :: MA,Z
+ CALL ZMZ2M(Z,MTZM)
+ CALL ZMPWR(MA%MZM,MTZM,FMPWR_ZMZ%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_ZMC(MA,C)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMPWR_ZMC
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: MA,C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MTZM)
+ CALL ZMPWR(MA%MZM,MTZM,FMPWR_ZMC%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_ZMFM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MB
+ TYPE ( ZM ) MA,FMPWR_ZMFM
+ INTENT (IN) :: MA,MB
+ CALL FMI2M(0,MTFM)
+ CALL ZMCMPX(MB%MFM,MTFM,MTZM)
+ CALL ZMPWR(MA%MZM,MTZM,FMPWR_ZMFM%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_ZMIM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MB
+ TYPE ( ZM ) MA,FMPWR_ZMIM
+ INTENT (IN) :: MA,MB
+ CALL IMI2FM(MB%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,MUZM)
+ CALL ZMPWR(MA%MZM,MUZM,FMPWR_ZMIM%MZM)
+ END FUNCTION
+
+ FUNCTION FMPWR_ZMZM(MA,MB)
+ USE FMVALS
+ TYPE ( ZM ) MA,MB,FMPWR_ZMZM
+ INTENT (IN) :: MA,MB
+ CALL ZMPWR(MA%MZM,MB%MZM,FMPWR_ZMZM%MZM)
+ END FUNCTION
+
+! ABS
+
+ FUNCTION FMABS_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMABS_FM
+ INTENT (IN) :: MA
+ CALL FMABS(MA%MFM,FMABS_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMABS_IM(MA)
+ USE FMVALS
+ TYPE ( IM ) MA,FMABS_IM
+ INTENT (IN) :: MA
+ CALL IMABS(MA%MIM,FMABS_IM%MIM)
+ END FUNCTION
+
+ FUNCTION FMABS_ZM(MA)
+ USE FMVALS
+ TYPE ( FM ) FMABS_ZM
+ TYPE ( ZM ) MA
+ INTENT (IN) :: MA
+ CALL ZMABS(MA%MZM,FMABS_ZM%MFM)
+ END FUNCTION
+
+! ACOS
+
+ FUNCTION FMACOS_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMACOS_FM
+ INTENT (IN) :: MA
+ CALL FMACOS(MA%MFM,FMACOS_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMACOS_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMACOS_ZM
+ INTENT (IN) :: MA
+ CALL ZMACOS(MA%MZM,FMACOS_ZM%MZM)
+ END FUNCTION
+
+! AIMAG
+
+ FUNCTION FMAIMAG_ZM(MA)
+ USE FMVALS
+ TYPE ( FM ) FMAIMAG_ZM
+ TYPE ( ZM ) MA
+ INTENT (IN) :: MA
+ CALL ZMIMAG(MA%MZM,FMAIMAG_ZM%MFM)
+ END FUNCTION
+
+! AINT
+
+ FUNCTION FMAINT_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMAINT_FM
+ INTENT (IN) :: MA
+ CALL FMINT(MA%MFM,FMAINT_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMAINT_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMAINT_ZM
+ INTENT (IN) :: MA
+ CALL ZMINT(MA%MZM,FMAINT_ZM%MZM)
+ END FUNCTION
+
+! ANINT
+
+ FUNCTION FMANINT_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMANINT_FM
+ INTENT (IN) :: MA
+ CALL FMNINT(MA%MFM,FMANINT_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMANINT_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMANINT_ZM
+ INTENT (IN) :: MA
+ CALL ZMNINT(MA%MZM,FMANINT_ZM%MZM)
+ END FUNCTION
+
+! ASIN
+
+ FUNCTION FMASIN_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMASIN_FM
+ INTENT (IN) :: MA
+ CALL FMASIN(MA%MFM,FMASIN_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMASIN_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMASIN_ZM
+ INTENT (IN) :: MA
+ CALL ZMASIN(MA%MZM,FMASIN_ZM%MZM)
+ END FUNCTION
+
+! ATAN
+
+ FUNCTION FMATAN_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMATAN_FM
+ INTENT (IN) :: MA
+ CALL FMATAN(MA%MFM,FMATAN_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMATAN_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMATAN_ZM
+ INTENT (IN) :: MA
+ CALL ZMATAN(MA%MZM,FMATAN_ZM%MZM)
+ END FUNCTION
+
+! ATAN2
+
+ FUNCTION FMATAN2_FM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMATAN2_FM
+ INTENT (IN) :: MA,MB
+ CALL FMATN2(MA%MFM,MB%MFM,FMATAN2_FM%MFM)
+ END FUNCTION
+
+! BTEST
+
+ FUNCTION FMBTEST_IM(MA,POS)
+ TYPE ( IM ) MA
+ INTEGER POS
+ LOGICAL FMBTEST_IM
+ INTENT (IN) :: MA,POS
+ CALL IMI2M(2,MTIM)
+ CALL IMI2M(POS,MUIM)
+ CALL IMPWR(MTIM,MUIM,MVIM)
+ CALL IMDIV(MA%MIM,MVIM,MUIM)
+ MUIM(-1) = 1
+ CALL IMMOD(MUIM,MTIM,MVIM)
+ IF (MVIM(2) == 0) THEN
+ FMBTEST_IM = .FALSE.
+ ELSE
+ FMBTEST_IM = .TRUE.
+ ENDIF
+ END FUNCTION
+
+! CEILING
+
+ FUNCTION FMCEILING_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMCEILING_FM
+ INTENT (IN) :: MA
+ CALL FMINT(MA%MFM,MTFM)
+ CALL FMSUB(MA%MFM,MTFM,MUFM)
+ IF (MUFM(2) == 0) THEN
+ CALL FMEQ(MA%MFM,FMCEILING_FM%MFM)
+ ELSE IF (MA%MFM(-1) > 0) THEN
+ CALL FMADDI(MTFM,1)
+ CALL FMEQ(MTFM,FMCEILING_FM%MFM)
+ ELSE
+ CALL FMEQ(MTFM,FMCEILING_FM%MFM)
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMCEILING_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMCEILING_ZM
+ INTENT (IN) :: MA
+ CALL FMINT(MA%MZM,MTFM)
+ CALL FMSUB(MA%MZM,MTFM,MUFM)
+ IF (MUFM(2) == 0) THEN
+ CALL FMEQ(MA%MZM,MVFM)
+ ELSE IF (MA%MZM(-1) > 0) THEN
+ CALL FMADDI(MTFM,1)
+ CALL FMEQ(MTFM,MVFM)
+ ELSE
+ CALL FMEQ(MTFM,MVFM)
+ ENDIF
+ CALL FMINT(MA%MZM(KPTIMU-1),MTFM)
+ CALL FMSUB(MA%MZM(KPTIMU-1),MTFM,MUFM)
+ IF (MUFM(2) == 0) THEN
+ CALL FMEQ(MA%MZM(KPTIMU-1),MUFM)
+ ELSE IF (MA%MZM(KPTIMU-1) > 0) THEN
+ CALL FMADDI(MTFM,1)
+ CALL FMEQ(MTFM,MUFM)
+ ELSE
+ CALL FMEQ(MTFM,MUFM)
+ ENDIF
+ CALL ZMCMPX(MVFM,MUFM,FMCEILING_ZM%MZM)
+ END FUNCTION
+
+! CMPLX
+
+ FUNCTION FMCMPLX_FM(MA,MB)
+ USE FMVALS
+ TYPE ( ZM ) FMCMPLX_FM
+ TYPE ( FM ) MA
+ TYPE ( FM ), OPTIONAL :: MB
+ INTENT (IN) :: MA,MB
+ IF (PRESENT(MB)) THEN
+ CALL ZMCMPX(MA%MFM,MB%MFM,FMCMPLX_FM%MZM)
+ ELSE
+ CALL FMI2M(0,MTFM)
+ CALL ZMCMPX(MA%MFM,MTFM,FMCMPLX_FM%MZM)
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMCMPLX_IM(MA,MB)
+ USE FMVALS
+ TYPE ( ZM ) FMCMPLX_IM
+ TYPE ( IM ) MA
+ TYPE ( IM ), OPTIONAL :: MB
+ INTENT (IN) :: MA,MB
+ IF (PRESENT(MB)) THEN
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL IMI2FM(MB%MIM,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,FMCMPLX_IM%MZM)
+ ELSE
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,FMCMPLX_IM%MZM)
+ ENDIF
+ END FUNCTION
+
+! CONJG
+
+ FUNCTION FMCONJG_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) FMCONJG_ZM,MA
+ INTENT (IN) :: MA
+ CALL ZMCONJ(MA%MZM,FMCONJG_ZM%MZM)
+ END FUNCTION
+
+! COS
+
+ FUNCTION FMCOS_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMCOS_FM
+ INTENT (IN) :: MA
+ CALL FMCOS(MA%MFM,FMCOS_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMCOS_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMCOS_ZM
+ INTENT (IN) :: MA
+ CALL ZMCOS(MA%MZM,FMCOS_ZM%MZM)
+ END FUNCTION
+
+! COSH
+
+ FUNCTION FMCOSH_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMCOSH_FM
+ INTENT (IN) :: MA
+ CALL FMCOSH(MA%MFM,FMCOSH_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMCOSH_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMCOSH_ZM
+ INTENT (IN) :: MA
+ CALL ZMCOSH(MA%MZM,FMCOSH_ZM%MZM)
+ END FUNCTION
+
+! DBLE
+
+ FUNCTION FMDBLE_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMDBLE_FM
+ INTENT (IN) :: MA
+ CALL FMEQ(MA%MFM,FMDBLE_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMDBLE_IM(MA)
+ USE FMVALS
+ TYPE ( FM ) FMDBLE_IM
+ TYPE ( IM ) MA
+ INTENT (IN) :: MA
+ CALL IMI2FM(MA%MIM,FMDBLE_IM%MFM)
+ END FUNCTION
+
+ FUNCTION FMDBLE_ZM(MA)
+ USE FMVALS
+ TYPE ( FM ) FMDBLE_ZM
+ TYPE ( ZM ) MA
+ INTENT (IN) :: MA
+ CALL ZMREAL(MA%MZM,FMDBLE_ZM%MFM)
+ END FUNCTION
+
+! DIGITS
+
+ FUNCTION FMDIGITS_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA
+ INTEGER FMDIGITS_FM
+ INTENT (IN) :: MA
+ FMDIGITS_FM = NDIG
+ END FUNCTION
+
+ FUNCTION FMDIGITS_IM(MA)
+ USE FMVALS
+ TYPE ( IM ) MA
+ INTEGER FMDIGITS_IM
+ INTENT (IN) :: MA
+ FMDIGITS_IM = NDIGMX
+ END FUNCTION
+
+ FUNCTION FMDIGITS_ZM(MA)
+ USE FMVALS
+ INTEGER FMDIGITS_ZM
+ TYPE ( ZM ) MA
+ INTENT (IN) :: MA
+ FMDIGITS_ZM = NDIG
+ END FUNCTION
+
+! DIM
+
+ FUNCTION FMDIM_FM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMDIM_FM
+ INTENT (IN) :: MA,MB
+ CALL FMDIM(MA%MFM,MB%MFM,FMDIM_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMDIM_IM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA,MB,FMDIM_IM
+ INTENT (IN) :: MA,MB
+ CALL IMDIM(MA%MIM,MB%MIM,FMDIM_IM%MIM)
+ END FUNCTION
+
+! DINT
+
+ FUNCTION FMDINT_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMDINT_FM
+ INTENT (IN) :: MA
+ CALL FMINT(MA%MFM,FMDINT_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMDINT_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMDINT_ZM
+ INTENT (IN) :: MA
+ CALL ZMINT(MA%MZM,FMDINT_ZM%MZM)
+ END FUNCTION
+
+! DOTPRODUCT
+
+ FUNCTION FMDOTPRODUCT_FM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA(:),MB(:),FMDOTPRODUCT_FM
+ INTEGER J,JA,JB,NDSAVE
+ INTENT (IN) :: MA,MB
+ IF (SIZE(MA) == SIZE(MB)) THEN
+ NDSAVE = NDIG
+ J = MAX(NGRD52,2)
+ NDIG = MIN(MAX(NDIG+J,2),NDG2MX)
+ CALL FMI2M(0,FMDOTPRODUCT_FM%MFM)
+ DO J = 1, SIZE(MA)
+ JA = LBOUND(MA,DIM=1) + J - 1
+ JB = LBOUND(MB,DIM=1) + J - 1
+ CALL FMEQ2(MA(JA)%MFM,MUFM,NDSAVE,NDIG)
+ CALL FMEQ2(MB(JB)%MFM,MVFM,NDSAVE,NDIG)
+ CALL FMMPY(MUFM,MVFM,MTFM)
+ CALL FMADD_R1(FMDOTPRODUCT_FM%MFM,MTFM)
+ ENDDO
+ CALL FMEQ2(FMDOTPRODUCT_FM%MFM,MTFM,NDIG,NDSAVE)
+ CALL FMEQ(MTFM,FMDOTPRODUCT_FM%MFM)
+ NDIG = NDSAVE
+ ELSE
+ CALL FMI2M(1,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL FMDIV(MTFM,MUFM,FMDOTPRODUCT_FM%MFM)
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMDOTPRODUCT_IM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA(:),MB(:),FMDOTPRODUCT_IM
+ INTEGER J,JA,JB
+ INTENT (IN) :: MA,MB
+ IF (SIZE(MA) == SIZE(MB)) THEN
+ CALL IMI2M(0,FMDOTPRODUCT_IM%MIM)
+ DO J = 1, SIZE(MA)
+ JA = LBOUND(MA,DIM=1) + J - 1
+ JB = LBOUND(MB,DIM=1) + J - 1
+ CALL IMMPY(MA(JA)%MIM,MB(JB)%MIM,MTIM)
+ CALL IMADD(FMDOTPRODUCT_IM%MIM,MTIM,MUIM)
+ CALL IMEQ(MUIM,FMDOTPRODUCT_IM%MIM)
+ ENDDO
+ ELSE
+ CALL IMI2M(1,MTIM)
+ CALL IMI2M(0,MUIM)
+ CALL IMDIV(MTIM,MUIM,FMDOTPRODUCT_IM%MIM)
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMDOTPRODUCT_ZM(MA,MB)
+ USE FMVALS
+ TYPE ( ZM ) MA(:),MB(:),FMDOTPRODUCT_ZM
+ INTEGER J,JA,JB,NDSAVE
+ INTENT (IN) :: MA,MB
+ IF (SIZE(MA) == SIZE(MB)) THEN
+ NDSAVE = NDIG
+ J = MAX(NGRD52,2)
+ NDIG = MIN(MAX(NDIG+J,2),NDG2MX)
+ CALL ZMI2M(0,FMDOTPRODUCT_ZM%MZM)
+ DO J = 1, SIZE(MA)
+ JA = LBOUND(MA,DIM=1) + J - 1
+ JB = LBOUND(MB,DIM=1) + J - 1
+ CALL ZMEQ2(MA(JA)%MZM,MUZM,NDSAVE,NDIG)
+ CALL ZMEQ2(MB(JB)%MZM,MVZM,NDSAVE,NDIG)
+ CALL ZMMPY(MUZM,MVZM,MTZM)
+ CALL ZMADD(FMDOTPRODUCT_ZM%MZM,MTZM,MUZM)
+ CALL ZMEQ(MUZM,FMDOTPRODUCT_ZM%MZM)
+ ENDDO
+ CALL ZMEQ2(FMDOTPRODUCT_ZM%MZM,MTZM,NDIG,NDSAVE)
+ CALL ZMEQ(MTZM,FMDOTPRODUCT_ZM%MZM)
+ NDIG = NDSAVE
+ ELSE
+ CALL ZMI2M(1,MTZM)
+ CALL ZMI2M(0,MUZM)
+ CALL ZMDIV(MTZM,MUZM,FMDOTPRODUCT_ZM%MZM)
+ ENDIF
+ END FUNCTION
+
+ END MODULE FMZM_7
+
+ MODULE FMZM_8
+ USE FMZM_1
+
+ INTERFACE EPSILON
+ MODULE PROCEDURE FMEPSILON_FM
+ END INTERFACE
+
+ INTERFACE EXP
+ MODULE PROCEDURE FMEXP_FM
+ MODULE PROCEDURE FMEXP_ZM
+ END INTERFACE
+
+ INTERFACE EXPONENT
+ MODULE PROCEDURE FMEXPONENT_FM
+ END INTERFACE
+
+ INTERFACE FLOOR
+ MODULE PROCEDURE FMFLOOR_FM
+ MODULE PROCEDURE FMFLOOR_IM
+ MODULE PROCEDURE FMFLOOR_ZM
+ END INTERFACE
+
+ INTERFACE FRACTION
+ MODULE PROCEDURE FMFRACTION_FM
+ MODULE PROCEDURE FMFRACTION_ZM
+ END INTERFACE
+
+ INTERFACE HUGE
+ MODULE PROCEDURE FMHUGE_FM
+ MODULE PROCEDURE FMHUGE_IM
+ MODULE PROCEDURE FMHUGE_ZM
+ END INTERFACE
+
+ INTERFACE INT
+ MODULE PROCEDURE FMINT_FM
+ MODULE PROCEDURE FMINT_IM
+ MODULE PROCEDURE FMINT_ZM
+ END INTERFACE
+
+ INTERFACE LOG
+ MODULE PROCEDURE FMLOG_FM
+ MODULE PROCEDURE FMLOG_ZM
+ END INTERFACE
+
+ INTERFACE LOG10
+ MODULE PROCEDURE FMLOG10_FM
+ MODULE PROCEDURE FMLOG10_ZM
+ END INTERFACE
+
+ INTERFACE MATMUL
+ MODULE PROCEDURE FMMATMUL_FM
+ MODULE PROCEDURE FMMATMUL_IM
+ MODULE PROCEDURE FMMATMUL_ZM
+ END INTERFACE
+
+ INTERFACE MAX
+ MODULE PROCEDURE FMMAX_FM
+ MODULE PROCEDURE FMMAX_IM
+ END INTERFACE
+
+ INTERFACE MAXEXPONENT
+ MODULE PROCEDURE FMMAXEXPONENT_FM
+ END INTERFACE
+
+ INTERFACE MIN
+ MODULE PROCEDURE FMMIN_FM
+ MODULE PROCEDURE FMMIN_IM
+ END INTERFACE
+
+ INTERFACE MINEXPONENT
+ MODULE PROCEDURE FMMINEXPONENT_FM
+ END INTERFACE
+
+ INTERFACE MOD
+ MODULE PROCEDURE FMMOD_FM
+ MODULE PROCEDURE FMMOD_IM
+ END INTERFACE
+
+ INTERFACE MODULO
+ MODULE PROCEDURE FMMODULO_FM
+ MODULE PROCEDURE FMMODULO_IM
+ END INTERFACE
+
+ INTERFACE NEAREST
+ MODULE PROCEDURE FMNEAREST_FM
+ END INTERFACE
+
+ INTERFACE NINT
+ MODULE PROCEDURE FMNINT_FM
+ MODULE PROCEDURE FMNINT_IM
+ MODULE PROCEDURE FMNINT_ZM
+ END INTERFACE
+
+ INTERFACE PRECISION
+ MODULE PROCEDURE FMPRECISION_FM
+ MODULE PROCEDURE FMPRECISION_ZM
+ END INTERFACE
+
+ INTERFACE RADIX
+ MODULE PROCEDURE FMRADIX_FM
+ MODULE PROCEDURE FMRADIX_IM
+ MODULE PROCEDURE FMRADIX_ZM
+ END INTERFACE
+
+ INTERFACE RANGE
+ MODULE PROCEDURE FMRANGE_FM
+ MODULE PROCEDURE FMRANGE_IM
+ MODULE PROCEDURE FMRANGE_ZM
+ END INTERFACE
+
+ INTERFACE REAL
+ MODULE PROCEDURE FMREAL_FM
+ MODULE PROCEDURE FMREAL_IM
+ MODULE PROCEDURE FMREAL_ZM
+ END INTERFACE
+
+ INTERFACE RRSPACING
+ MODULE PROCEDURE FMRRSPACING_FM
+ END INTERFACE
+
+ INTERFACE SCALE
+ MODULE PROCEDURE FMSCALE_FM
+ MODULE PROCEDURE FMSCALE_ZM
+ END INTERFACE
+
+ INTERFACE SETEXPONENT
+ MODULE PROCEDURE FMSETEXPONENT_FM
+ END INTERFACE
+
+ INTERFACE SIGN
+ MODULE PROCEDURE FMSIGN_FM
+ MODULE PROCEDURE FMSIGN_IM
+ END INTERFACE
+
+ CONTAINS
+
+! EPSILON
+
+ FUNCTION FMEPSILON_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMEPSILON_FM
+ INTENT (IN) :: MA
+ CALL FMI2M(1,MTFM)
+ CALL FMULP(MTFM,FMEPSILON_FM%MFM)
+ END FUNCTION
+
+! EXP
+
+ FUNCTION FMEXP_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMEXP_FM
+ INTENT (IN) :: MA
+ CALL FMEXP(MA%MFM,FMEXP_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMEXP_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMEXP_ZM
+ INTENT (IN) :: MA
+ CALL ZMEXP(MA%MZM,FMEXP_ZM%MZM)
+ END FUNCTION
+
+! EXPONENT
+
+ FUNCTION FMEXPONENT_FM(MA)
+ TYPE ( FM ) MA
+ INTEGER FMEXPONENT_FM
+ INTENT (IN) :: MA
+ FMEXPONENT_FM = INT(MA%MFM(1))
+ END FUNCTION
+
+! FLOOR
+
+ FUNCTION FMFLOOR_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMFLOOR_FM
+ INTENT (IN) :: MA
+ CALL FMINT(MA%MFM,MTFM)
+ CALL FMSUB(MA%MFM,MTFM,MUFM)
+ IF (MUFM(2) == 0) THEN
+ CALL FMEQ(MA%MFM,FMFLOOR_FM%MFM)
+ ELSE IF (MA%MFM(-1) < 0) THEN
+ CALL FMADDI(MTFM,-1)
+ CALL FMEQ(MTFM,FMFLOOR_FM%MFM)
+ ELSE
+ CALL FMEQ(MTFM,FMFLOOR_FM%MFM)
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMFLOOR_IM(MA)
+ USE FMVALS
+ TYPE ( IM ) MA,FMFLOOR_IM
+ INTENT (IN) :: MA
+ CALL IMEQ(MA%MIM,FMFLOOR_IM%MIM)
+ END FUNCTION
+
+ FUNCTION FMFLOOR_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMFLOOR_ZM
+ INTENT (IN) :: MA
+ CALL FMINT(MA%MZM,MTFM)
+ CALL FMSUB(MA%MZM,MTFM,MUFM)
+ IF (MUFM(2) == 0) THEN
+ CALL FMEQ(MA%MZM,MVFM)
+ ELSE IF (MA%MZM(-1) < 0) THEN
+ CALL FMADDI(MTFM,-1)
+ CALL FMEQ(MTFM,MVFM)
+ ELSE
+ CALL FMEQ(MTFM,MVFM)
+ ENDIF
+ CALL FMINT(MA%MZM(KPTIMU-1),MTFM)
+ CALL FMSUB(MA%MZM(KPTIMU-1),MTFM,MUFM)
+ IF (MUFM(2) == 0) THEN
+ CALL FMEQ(MA%MZM(KPTIMU-1),MUFM)
+ ELSE IF (MA%MZM(KPTIMU-1) < 0) THEN
+ CALL FMADDI(MTFM,-1)
+ CALL FMEQ(MTFM,MUFM)
+ ELSE
+ CALL FMEQ(MTFM,MUFM)
+ ENDIF
+ CALL ZMCMPX(MVFM,MUFM,FMFLOOR_ZM%MZM)
+ END FUNCTION
+
+! FRACTION
+
+ FUNCTION FMFRACTION_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMFRACTION_FM
+ INTENT (IN) :: MA
+ CALL FMEQ(MA%MFM,MTFM)
+ MTFM(1) = 0
+ CALL FMEQ(MTFM,FMFRACTION_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMFRACTION_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMFRACTION_ZM
+ INTENT (IN) :: MA
+ CALL ZMEQ(MA%MZM,MTZM)
+ MTZM(1) = 0
+ MTZM(KPTIMU+1) = 0
+ CALL ZMEQ(MTZM,FMFRACTION_ZM%MZM)
+ END FUNCTION
+
+! HUGE
+
+ FUNCTION FMHUGE_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMHUGE_FM
+ INTENT (IN) :: MA
+ CALL FMBIG(FMHUGE_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMHUGE_IM(MA)
+ USE FMVALS
+ TYPE ( IM ) MA,FMHUGE_IM
+ INTENT (IN) :: MA
+ CALL IMBIG(FMHUGE_IM%MIM)
+ END FUNCTION
+
+ FUNCTION FMHUGE_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMHUGE_ZM
+ INTENT (IN) :: MA
+ CALL FMBIG(MTFM)
+ CALL ZMCMPX(MTFM,MTFM,FMHUGE_ZM%MZM)
+ END FUNCTION
+
+! INT
+
+ FUNCTION FMINT_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA
+ TYPE ( IM ) FMINT_FM
+ INTENT (IN) :: MA
+ CALL FMINT(MA%MFM,MTFM)
+ CALL IMFM2I(MTFM,FMINT_FM%MIM)
+ END FUNCTION
+
+ FUNCTION FMINT_IM(MA)
+ USE FMVALS
+ TYPE ( IM ) MA,FMINT_IM
+ INTENT (IN) :: MA
+ CALL IMEQ(MA%MIM,FMINT_IM%MIM)
+ END FUNCTION
+
+ FUNCTION FMINT_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA
+ TYPE ( IM ) FMINT_ZM
+ INTENT (IN) :: MA
+ CALL ZMREAL(MA%MZM,MTFM)
+ CALL FMINT(MTFM,MUFM)
+ CALL IMFM2I(MUFM,FMINT_ZM%MIM)
+ END FUNCTION
+
+! LOG
+
+ FUNCTION FMLOG_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMLOG_FM
+ INTENT (IN) :: MA
+ CALL FMLN(MA%MFM,FMLOG_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMLOG_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMLOG_ZM
+ INTENT (IN) :: MA
+ CALL ZMLN(MA%MZM,FMLOG_ZM%MZM)
+ END FUNCTION
+
+! LOG10
+
+ FUNCTION FMLOG10_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMLOG10_FM
+ INTENT (IN) :: MA
+ CALL FMLG10(MA%MFM,FMLOG10_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMLOG10_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMLOG10_ZM
+ INTENT (IN) :: MA
+ CALL ZMLG10(MA%MZM,FMLOG10_ZM%MZM)
+ END FUNCTION
+
+! MATMUL
+
+ FUNCTION FMMATMUL_FM(MA,MB) RESULT(MC)
+ USE FMVALS
+ TYPE ( FM ) MA(:,:),MB(:,:)
+ TYPE ( FM ), DIMENSION(SIZE(MA,DIM=1),SIZE(MB,DIM=2)) :: MC
+ INTEGER I,J,K,NDSAVE
+ INTENT (IN) :: MA,MB
+ DO J = 1, SIZE(MA,DIM=1)
+ DO K = 1, SIZE(MB,DIM=2)
+ ENDDO
+ ENDDO
+ IF (SIZE(MA,DIM=2) == SIZE(MB,DIM=1)) THEN
+ NDSAVE = NDIG
+ J = MAX(NGRD52,2)
+ NDIG = MIN(MAX(NDIG+J,2),NDG2MX)
+ DO I = LBOUND(MA,DIM=1), UBOUND(MA,DIM=1)
+ DO J = LBOUND(MB,DIM=2), UBOUND(MB,DIM=2)
+ CALL FMI2M(0,MTFM)
+ DO K = LBOUND(MA,DIM=2), UBOUND(MA,DIM=2)
+ CALL FMEQ2(MA(I,K)%MFM,MUFM,NDSAVE,NDIG)
+ CALL FMEQ2(MB(K,J)%MFM,MVFM,NDSAVE,NDIG)
+ CALL FMMPY(MUFM,MVFM,M01)
+ CALL FMADD_R1(MTFM,M01)
+ ENDDO
+ CALL FMEQ2_R1(MTFM,NDIG,NDSAVE)
+ CALL FMEQ(MTFM,MC(I,J)%MFM)
+ ENDDO
+ ENDDO
+ NDIG = NDSAVE
+ ELSE
+ CALL FMI2M(1,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL FMDIV(MTFM,MUFM,MVFM)
+ DO I = 1, SIZE(MA,DIM=1)
+ DO J = 1, SIZE(MB,DIM=2)
+ CALL FMEQ(MVFM,MC(I,J)%MFM)
+ ENDDO
+ ENDDO
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMMATMUL_IM(MA,MB) RESULT(MC)
+ USE FMVALS
+ TYPE ( IM ) MA(:,:),MB(:,:)
+ TYPE ( IM ), DIMENSION(SIZE(MA,DIM=1),SIZE(MB,DIM=2)) :: MC
+ INTEGER I,J,K
+ INTENT (IN) :: MA,MB
+ DO J = 1, SIZE(MA,DIM=1)
+ DO K = 1, SIZE(MB,DIM=2)
+ ENDDO
+ ENDDO
+ IF (SIZE(MA,DIM=2) == SIZE(MB,DIM=1)) THEN
+ DO I = LBOUND(MA,DIM=1), UBOUND(MA,DIM=1)
+ DO J = LBOUND(MB,DIM=2), UBOUND(MB,DIM=2)
+ CALL IMI2M(0,MTIM)
+ DO K = LBOUND(MA,DIM=2), UBOUND(MA,DIM=2)
+ CALL IMMPY(MA(I,K)%MIM,MB(K,J)%MIM,M01)
+ CALL IMADD(MTIM,M01,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDDO
+ CALL IMEQ(MTIM,MC(I,J)%MIM)
+ ENDDO
+ ENDDO
+ ELSE
+ CALL IMI2M(1,MTIM)
+ CALL IMI2M(0,MUIM)
+ CALL IMDIV(MTIM,MUIM,MC(1,1)%MIM)
+ DO I = 1, SIZE(MA,DIM=1)
+ DO J = 1, SIZE(MB,DIM=2)
+ IF (I > 1 .OR. J > 1) CALL IMEQ(MC(1,1)%MIM,MC(I,J)%MIM)
+ ENDDO
+ ENDDO
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMMATMUL_ZM(MA,MB) RESULT(MC)
+ USE FMVALS
+ TYPE ( ZM ) MA(:,:),MB(:,:)
+ TYPE ( ZM ), DIMENSION(SIZE(MA,DIM=1),SIZE(MB,DIM=2)) :: MC
+ INTEGER I,J,K,NDSAVE
+ INTENT (IN) :: MA,MB
+ DO J = 1, SIZE(MA,DIM=1)
+ DO K = 1, SIZE(MB,DIM=2)
+ ENDDO
+ ENDDO
+ IF (SIZE(MA,DIM=2) == SIZE(MB,DIM=1)) THEN
+ NDSAVE = NDIG
+ J = MAX(NGRD52,2)
+ NDIG = MIN(MAX(NDIG+J,2),NDG2MX)
+ DO I = LBOUND(MA,DIM=1), UBOUND(MA,DIM=1)
+ DO J = LBOUND(MB,DIM=2), UBOUND(MB,DIM=2)
+ CALL ZMI2M(0,MTZM)
+ DO K = LBOUND(MA,DIM=2), UBOUND(MA,DIM=2)
+ CALL ZMEQ2(MA(I,K)%MZM,MUZM,NDSAVE,NDIG)
+ CALL ZMEQ2(MB(K,J)%MZM,MVZM,NDSAVE,NDIG)
+ CALL ZMMPY(MUZM,MVZM,MZ02)
+ CALL ZMADD(MTZM,MZ02,MUZM)
+ CALL ZMEQ(MUZM,MTZM)
+ ENDDO
+ CALL ZMEQ2_R1(MTZM,NDIG,NDSAVE)
+ CALL ZMEQ(MTZM,MC(I,J)%MZM)
+ ENDDO
+ ENDDO
+ NDIG = NDSAVE
+ ELSE
+ CALL ZMI2M(1,MTZM)
+ CALL ZMI2M(0,MUZM)
+ CALL ZMDIV(MTZM,MUZM,MC(1,1)%MZM)
+ DO I = 1, SIZE(MA,DIM=1)
+ DO J = 1, SIZE(MB,DIM=2)
+ IF (I > 1 .OR. J > 1) CALL ZMEQ(MC(1,1)%MZM,MC(I,J)%MZM)
+ ENDDO
+ ENDDO
+ ENDIF
+ END FUNCTION
+
+! MAX
+
+ FUNCTION FMMAX_FM(MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMMAX_FM
+ TYPE ( FM ), OPTIONAL :: MC,MD,ME,MF,MG,MH,MI,MJ
+ INTENT (IN) :: MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ
+ CALL FMMAX(MA%MFM,MB%MFM,MTFM)
+ IF (PRESENT(MC)) THEN
+ CALL FMMAX(MTFM,MC%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ IF (PRESENT(MD)) THEN
+ CALL FMMAX(MTFM,MD%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ IF (PRESENT(ME)) THEN
+ CALL FMMAX(MTFM,ME%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ IF (PRESENT(MF)) THEN
+ CALL FMMAX(MTFM,MF%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ IF (PRESENT(MG)) THEN
+ CALL FMMAX(MTFM,MG%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ IF (PRESENT(MH)) THEN
+ CALL FMMAX(MTFM,MH%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ IF (PRESENT(MI)) THEN
+ CALL FMMAX(MTFM,MI%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ IF (PRESENT(MJ)) THEN
+ CALL FMMAX(MTFM,MJ%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ CALL FMEQ(MTFM,FMMAX_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMMAX_IM(MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ)
+ USE FMVALS
+ TYPE ( IM ) MA,MB,FMMAX_IM
+ TYPE ( IM ), OPTIONAL :: MC,MD,ME,MF,MG,MH,MI,MJ
+ INTENT (IN) :: MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ
+ CALL IMMAX(MA%MIM,MB%MIM,MTIM)
+ IF (PRESENT(MC)) THEN
+ CALL IMMAX(MTIM,MC%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ IF (PRESENT(MD)) THEN
+ CALL IMMAX(MTIM,MD%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ IF (PRESENT(ME)) THEN
+ CALL IMMAX(MTIM,ME%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ IF (PRESENT(MF)) THEN
+ CALL IMMAX(MTIM,MF%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ IF (PRESENT(MG)) THEN
+ CALL IMMAX(MTIM,MG%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ IF (PRESENT(MH)) THEN
+ CALL IMMAX(MTIM,MH%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ IF (PRESENT(MI)) THEN
+ CALL IMMAX(MTIM,MI%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ IF (PRESENT(MJ)) THEN
+ CALL IMMAX(MTIM,MJ%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ CALL IMEQ(MTIM,FMMAX_IM%MIM)
+ END FUNCTION
+
+! MAXEXPONENT
+
+ FUNCTION FMMAXEXPONENT_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA
+ INTEGER FMMAXEXPONENT_FM
+ INTENT (IN) :: MA
+ FMMAXEXPONENT_FM = INT(MXEXP) + 1
+ END FUNCTION
+
+! MIN
+
+ FUNCTION FMMIN_FM(MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMMIN_FM
+ TYPE ( FM ), OPTIONAL :: MC,MD,ME,MF,MG,MH,MI,MJ
+ INTENT (IN) :: MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ
+ CALL FMMIN(MA%MFM,MB%MFM,MTFM)
+ IF (PRESENT(MC)) THEN
+ CALL FMMIN(MTFM,MC%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ IF (PRESENT(MD)) THEN
+ CALL FMMIN(MTFM,MD%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ IF (PRESENT(ME)) THEN
+ CALL FMMIN(MTFM,ME%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ IF (PRESENT(MF)) THEN
+ CALL FMMIN(MTFM,MF%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ IF (PRESENT(MG)) THEN
+ CALL FMMIN(MTFM,MG%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ IF (PRESENT(MH)) THEN
+ CALL FMMIN(MTFM,MH%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ IF (PRESENT(MI)) THEN
+ CALL FMMIN(MTFM,MI%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ IF (PRESENT(MJ)) THEN
+ CALL FMMIN(MTFM,MJ%MFM,MUFM)
+ CALL FMEQ(MUFM,MTFM)
+ ENDIF
+ CALL FMEQ(MTFM,FMMIN_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMMIN_IM(MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ)
+ USE FMVALS
+ TYPE ( IM ) MA,MB,FMMIN_IM
+ TYPE ( IM ), OPTIONAL :: MC,MD,ME,MF,MG,MH,MI,MJ
+ INTENT (IN) :: MA,MB,MC,MD,ME,MF,MG,MH,MI,MJ
+ CALL IMMIN(MA%MIM,MB%MIM,MTIM)
+ IF (PRESENT(MC)) THEN
+ CALL IMMIN(MTIM,MC%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ IF (PRESENT(MD)) THEN
+ CALL IMMIN(MTIM,MD%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ IF (PRESENT(ME)) THEN
+ CALL IMMIN(MTIM,ME%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ IF (PRESENT(MF)) THEN
+ CALL IMMIN(MTIM,MF%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ IF (PRESENT(MG)) THEN
+ CALL IMMIN(MTIM,MG%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ IF (PRESENT(MH)) THEN
+ CALL IMMIN(MTIM,MH%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ IF (PRESENT(MI)) THEN
+ CALL IMMIN(MTIM,MI%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ IF (PRESENT(MJ)) THEN
+ CALL IMMIN(MTIM,MJ%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ CALL IMEQ(MTIM,FMMIN_IM%MIM)
+ END FUNCTION
+
+! MINEXPONENT
+
+ FUNCTION FMMINEXPONENT_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA
+ INTEGER FMMINEXPONENT_FM
+ INTENT (IN) :: MA
+ FMMINEXPONENT_FM = -INT(MXEXP)
+ END FUNCTION
+
+! MOD
+
+ FUNCTION FMMOD_FM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMMOD_FM
+ INTENT (IN) :: MA,MB
+ CALL FMMOD(MA%MFM,MB%MFM,FMMOD_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMMOD_IM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA,MB,FMMOD_IM
+ INTENT (IN) :: MA,MB
+ CALL IMMOD(MA%MIM,MB%MIM,FMMOD_IM%MIM)
+ END FUNCTION
+
+! MODULO
+
+ FUNCTION FMMODULO_FM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMMODULO_FM
+ INTENT (IN) :: MA,MB
+ CALL FMMOD(MA%MFM,MB%MFM,MTFM)
+ IF (MTFM(2) /= 0) THEN
+ IF ((MA%MFM(2) > 0 .AND. MA%MFM(-1) > 0 .AND. &
+ MB%MFM(2) > 0 .AND. MB%MFM(-1) < 0) .OR. &
+ (MA%MFM(2) > 0 .AND. MA%MFM(-1) < 0 .AND. &
+ MB%MFM(2) > 0 .AND. MB%MFM(-1) > 0)) THEN
+ CALL FMADD_R1(MTFM,MB%MFM)
+ ENDIF
+ ENDIF
+ CALL FMEQ(MTFM,FMMODULO_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMMODULO_IM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA,MB,FMMODULO_IM
+ INTENT (IN) :: MA,MB
+ CALL IMMOD(MA%MIM,MB%MIM,MTIM)
+ IF (MTIM(2) /= 0) THEN
+ IF ((MA%MIM(2) > 0 .AND. MA%MIM(-1) > 0 .AND. &
+ MB%MIM(2) > 0 .AND. MB%MIM(-1) < 0) .OR. &
+ (MA%MIM(2) > 0 .AND. MA%MIM(-1) < 0 .AND. &
+ MB%MIM(2) > 0 .AND. MB%MIM(-1) > 0)) THEN
+ CALL IMADD(MTIM,MB%MIM,MUIM)
+ CALL IMEQ(MUIM,MTIM)
+ ENDIF
+ ENDIF
+ CALL IMEQ(MTIM,FMMODULO_IM%MIM)
+ END FUNCTION
+
+! NEAREST
+
+ FUNCTION FMNEAREST_FM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMNEAREST_FM
+ LOGICAL FMCOMP
+ INTENT (IN) :: MA,MB
+ IF (MA%MFM(2) == 0) THEN
+ IF (MB%MFM(-1) > 0) THEN
+ CALL FMBIG(MTFM)
+ CALL FMI2M(1,MUFM)
+ CALL FMDIV(MUFM,MTFM,FMNEAREST_FM%MFM)
+ ELSE
+ CALL FMBIG(MTFM)
+ CALL FMI2M(-1,MUFM)
+ CALL FMDIV(MUFM,MTFM,FMNEAREST_FM%MFM)
+ ENDIF
+ ELSE
+ IF (MB%MFM(-1) > 0) THEN
+ CALL FMULP(MA%MFM,MTFM)
+ MTFM(-1) = 1
+ CALL FMADD(MA%MFM,MTFM,MUFM)
+ CALL FMULP(MUFM,MVFM)
+ CALL FMABS(MVFM,MUFM)
+ IF (FMCOMP(MTFM,'LE',MUFM)) THEN
+ CALL FMADD(MA%MFM,MTFM,FMNEAREST_FM%MFM)
+ ELSE
+ CALL FMADD(MA%MFM,MUFM,FMNEAREST_FM%MFM)
+ ENDIF
+ ELSE
+ CALL FMULP(MA%MFM,MTFM)
+ MTFM(-1) = 1
+ CALL FMSUB(MA%MFM,MTFM,MUFM)
+ CALL FMULP(MUFM,MVFM)
+ CALL FMABS(MVFM,MUFM)
+ IF (FMCOMP(MTFM,'LE',MUFM)) THEN
+ CALL FMSUB(MA%MFM,MTFM,FMNEAREST_FM%MFM)
+ ELSE
+ CALL FMSUB(MA%MFM,MUFM,FMNEAREST_FM%MFM)
+ ENDIF
+ ENDIF
+ ENDIF
+ END FUNCTION
+
+! NINT
+
+ FUNCTION FMNINT_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA
+ TYPE ( IM ) FMNINT_FM
+ INTENT (IN) :: MA
+ CALL FMNINT(MA%MFM,MTFM)
+ CALL IMFM2I(MTFM,FMNINT_FM%MIM)
+ END FUNCTION
+
+ FUNCTION FMNINT_IM(MA)
+ USE FMVALS
+ TYPE ( IM ) MA,FMNINT_IM
+ INTENT (IN) :: MA
+ CALL IMEQ(MA%MIM,FMNINT_IM%MIM)
+ END FUNCTION
+
+ FUNCTION FMNINT_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA
+ TYPE ( IM ) FMNINT_ZM
+ INTENT (IN) :: MA
+ CALL ZMREAL(MA%MZM,MTFM)
+ CALL FMNINT(MTFM,MUFM)
+ CALL IMFM2I(MUFM,FMNINT_ZM%MIM)
+ END FUNCTION
+
+! PRECISION
+
+ FUNCTION FMPRECISION_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA
+ INTEGER FMPRECISION_FM
+ INTENT (IN) :: MA
+ FMPRECISION_FM = INT(LOG10(REAL(MBASE))*(NDIG-1) + 1)
+ END FUNCTION
+
+ FUNCTION FMPRECISION_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA
+ INTEGER FMPRECISION_ZM
+ INTENT (IN) :: MA
+ FMPRECISION_ZM = INT(LOG10(REAL(MBASE))*(NDIG-1) + 1)
+ END FUNCTION
+
+! RADIX
+
+ FUNCTION FMRADIX_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA
+ INTEGER FMRADIX_FM
+ INTENT (IN) :: MA
+ FMRADIX_FM = INT(MBASE)
+ END FUNCTION
+
+ FUNCTION FMRADIX_IM(MA)
+ USE FMVALS
+ TYPE ( IM ) MA
+ INTEGER FMRADIX_IM
+ INTENT (IN) :: MA
+ FMRADIX_IM = INT(MBASE)
+ END FUNCTION
+
+ FUNCTION FMRADIX_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA
+ INTEGER FMRADIX_ZM
+ INTENT (IN) :: MA
+ FMRADIX_ZM = INT(MBASE)
+ END FUNCTION
+
+! RANGE
+
+ FUNCTION FMRANGE_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA
+ INTEGER FMRANGE_FM
+ INTENT (IN) :: MA
+ FMRANGE_FM = INT(MXEXP*LOG10(REAL(MBASE)))
+ END FUNCTION
+
+ FUNCTION FMRANGE_IM(MA)
+ USE FMVALS
+ TYPE ( IM ) MA
+ INTEGER FMRANGE_IM
+ INTENT (IN) :: MA
+ FMRANGE_IM = INT(NDIGMX*LOG10(REAL(MBASE)))
+ END FUNCTION
+
+ FUNCTION FMRANGE_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA
+ INTEGER FMRANGE_ZM
+ INTENT (IN) :: MA
+ FMRANGE_ZM = INT(MXEXP*LOG10(REAL(MBASE)))
+ END FUNCTION
+
+! REAL
+
+ FUNCTION FMREAL_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMREAL_FM
+ INTENT (IN) :: MA
+ CALL FMEQ(MA%MFM,FMREAL_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMREAL_IM(MA)
+ USE FMVALS
+ TYPE ( FM ) FMREAL_IM
+ TYPE ( IM ) MA
+ INTENT (IN) :: MA
+ CALL IMI2FM(MA%MIM,FMREAL_IM%MFM)
+ END FUNCTION
+
+ FUNCTION FMREAL_ZM(MA)
+ USE FMVALS
+ TYPE ( FM ) FMREAL_ZM
+ TYPE ( ZM ) MA
+ INTENT (IN) :: MA
+ CALL ZMREAL(MA%MZM,FMREAL_ZM%MFM)
+ END FUNCTION
+
+! RRSPACING
+
+ FUNCTION FMRRSPACING_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMRRSPACING_FM
+ INTENT (IN) :: MA
+ CALL FMABS(MA%MFM,MTFM)
+ MTFM(1) = NDIG
+ CALL FMEQ(MTFM,FMRRSPACING_FM%MFM)
+ END FUNCTION
+
+! SCALE
+
+ FUNCTION FMSCALE_FM(MA,L)
+ USE FMVALS
+ TYPE ( FM ) MA,FMSCALE_FM
+ INTEGER L
+ INTENT (IN) :: MA,L
+ CALL FMEQ(MA%MFM,MTFM)
+ IF (ABS(MTFM(1)+L) < MXEXP) THEN
+ MTFM(1) = MTFM(1) + L
+ CALL FMEQ(MTFM,FMSCALE_FM%MFM)
+ ELSE
+ CALL FMI2M(INT(MBASE),MUFM)
+ CALL FMIPWR(MUFM,L,MVFM)
+ CALL FMMPY(MA%MFM,MVFM,FMSCALE_FM%MFM)
+ ENDIF
+ END FUNCTION
+
+ FUNCTION FMSCALE_ZM(MA,L)
+ USE FMVALS
+ INTEGER L
+ TYPE ( ZM ) MA,FMSCALE_ZM
+ INTENT (IN) :: MA,L
+ CALL ZMEQ(MA%MZM,MTZM)
+ IF (ABS(MTZM(1)+L) < MXEXP .AND. &
+ ABS(MTZM(KPTIMU+1)+L) < MXEXP) THEN
+ MTZM(1) = MTZM(1) + L
+ MTZM(KPTIMU+1) = MTZM(KPTIMU+1) + L
+ CALL ZMEQ(MTZM,FMSCALE_ZM%MZM)
+ ELSE
+ CALL ZMI2M(INT(MBASE),MUZM)
+ CALL ZMIPWR(MUZM,L,MVZM)
+ CALL ZMMPY(MA%MZM,MVZM,FMSCALE_ZM%MZM)
+ ENDIF
+ END FUNCTION
+
+! SETEXPONENT
+
+ FUNCTION FMSETEXPONENT_FM(MA,L)
+ USE FMVALS
+ TYPE ( FM ) MA,FMSETEXPONENT_FM
+ INTEGER L
+ INTENT (IN) :: MA,L
+ CALL FMEQ(MA%MFM,MTFM)
+ MTFM(1) = L
+ CALL FMEQ(MTFM,FMSETEXPONENT_FM%MFM)
+ END FUNCTION
+
+! SIGN
+
+ FUNCTION FMSIGN_FM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMSIGN_FM
+ INTENT (IN) :: MA,MB
+ CALL FMSIGN(MA%MFM,MB%MFM,FMSIGN_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMSIGN_IM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA,MB,FMSIGN_IM
+ INTENT (IN) :: MA,MB
+ CALL IMSIGN(MA%MIM,MB%MIM,FMSIGN_IM%MIM)
+ END FUNCTION
+
+ END MODULE FMZM_8
+
+ MODULE FMZM_9
+ USE FMZM_1
+
+ INTERFACE SIN
+ MODULE PROCEDURE FMSIN_FM
+ MODULE PROCEDURE FMSIN_ZM
+ END INTERFACE
+
+ INTERFACE SINH
+ MODULE PROCEDURE FMSINH_FM
+ MODULE PROCEDURE FMSINH_ZM
+ END INTERFACE
+
+ INTERFACE SPACING
+ MODULE PROCEDURE FMSPACING_FM
+ END INTERFACE
+
+ INTERFACE SQRT
+ MODULE PROCEDURE FMSQRT_FM
+ MODULE PROCEDURE FMSQRT_ZM
+ END INTERFACE
+
+ INTERFACE TAN
+ MODULE PROCEDURE FMTAN_FM
+ MODULE PROCEDURE FMTAN_ZM
+ END INTERFACE
+
+ INTERFACE TANH
+ MODULE PROCEDURE FMTANH_FM
+ MODULE PROCEDURE FMTANH_ZM
+ END INTERFACE
+
+ INTERFACE TINY
+ MODULE PROCEDURE FMTINY_FM
+ MODULE PROCEDURE FMTINY_IM
+ MODULE PROCEDURE FMTINY_ZM
+ END INTERFACE
+
+ INTERFACE TO_FM
+ MODULE PROCEDURE FM_I
+ MODULE PROCEDURE FM_R
+ MODULE PROCEDURE FM_D
+ MODULE PROCEDURE FM_Z
+ MODULE PROCEDURE FM_C
+ MODULE PROCEDURE FM_FM
+ MODULE PROCEDURE FM_IM
+ MODULE PROCEDURE FM_ZM
+ MODULE PROCEDURE FM_ST
+ END INTERFACE
+
+ INTERFACE TO_IM
+ MODULE PROCEDURE IM_I
+ MODULE PROCEDURE IM_R
+ MODULE PROCEDURE IM_D
+ MODULE PROCEDURE IM_Z
+ MODULE PROCEDURE IM_C
+ MODULE PROCEDURE IM_FM
+ MODULE PROCEDURE IM_IM
+ MODULE PROCEDURE IM_ZM
+ MODULE PROCEDURE IM_ST
+ END INTERFACE
+
+ INTERFACE TO_ZM
+ MODULE PROCEDURE ZM_I
+ MODULE PROCEDURE ZM_R
+ MODULE PROCEDURE ZM_D
+ MODULE PROCEDURE ZM_Z
+ MODULE PROCEDURE ZM_C
+ MODULE PROCEDURE ZM_FM
+ MODULE PROCEDURE ZM_IM
+ MODULE PROCEDURE ZM_ZM
+ MODULE PROCEDURE ZM_ST
+ END INTERFACE
+
+ INTERFACE TO_INT
+ MODULE PROCEDURE FM_2INT
+ MODULE PROCEDURE IM_2INT
+ MODULE PROCEDURE ZM_2INT
+ END INTERFACE
+
+ INTERFACE TO_SP
+ MODULE PROCEDURE FM_2SP
+ MODULE PROCEDURE IM_2SP
+ MODULE PROCEDURE ZM_2SP
+ END INTERFACE
+
+ INTERFACE TO_DP
+ MODULE PROCEDURE FM_2DP
+ MODULE PROCEDURE IM_2DP
+ MODULE PROCEDURE ZM_2DP
+ END INTERFACE
+
+ INTERFACE TO_SPZ
+ MODULE PROCEDURE FM_2SPZ
+ MODULE PROCEDURE IM_2SPZ
+ MODULE PROCEDURE ZM_2SPZ
+ END INTERFACE
+
+ INTERFACE TO_DPZ
+ MODULE PROCEDURE FM_2DPZ
+ MODULE PROCEDURE IM_2DPZ
+ MODULE PROCEDURE ZM_2DPZ
+ END INTERFACE
+
+
+ INTERFACE FM_FORMAT
+ MODULE PROCEDURE FMFORMAT_FM
+ END INTERFACE
+
+ INTERFACE IM_FORMAT
+ MODULE PROCEDURE IMFORMAT_IM
+ END INTERFACE
+
+ INTERFACE ZM_FORMAT
+ MODULE PROCEDURE ZMFORMAT_ZM
+ END INTERFACE
+
+ INTERFACE GCD
+ MODULE PROCEDURE GCD_IM
+ END INTERFACE
+
+ INTERFACE MULTIPLY_MOD
+ MODULE PROCEDURE MULTIPLYMOD_IM
+ END INTERFACE
+
+ INTERFACE POWER_MOD
+ MODULE PROCEDURE POWERMOD_IM
+ END INTERFACE
+
+ INTERFACE FM_RANDOM_SEED
+ MODULE PROCEDURE FM_SEED
+ END INTERFACE
+
+ INTERFACE BERNOULLI
+ MODULE PROCEDURE FMBERNOULLI_FM
+ END INTERFACE
+
+ INTERFACE BETA
+ MODULE PROCEDURE FMBETA_FM
+ END INTERFACE
+
+ INTERFACE BINOMIAL
+ MODULE PROCEDURE FMBINOMIAL_FM
+ END INTERFACE
+
+ INTERFACE FACTORIAL
+ MODULE PROCEDURE FMFACTORIAL_FM
+ END INTERFACE
+
+ INTERFACE GAMMA
+ MODULE PROCEDURE FMGAMMA_FM
+ END INTERFACE
+
+ INTERFACE INCOMPLETE_BETA
+ MODULE PROCEDURE FMINCOMPLETE_BETA_FM
+ END INTERFACE
+
+ INTERFACE INCOMPLETE_GAMMA1
+ MODULE PROCEDURE FMINCOMPLETE_GAMMA1_FM
+ END INTERFACE
+
+ INTERFACE INCOMPLETE_GAMMA2
+ MODULE PROCEDURE FMINCOMPLETE_GAMMA2_FM
+ END INTERFACE
+
+ INTERFACE LOG_GAMMA
+ MODULE PROCEDURE FMLOG_GAMMA_FM
+ END INTERFACE
+
+ INTERFACE POLYGAMMA
+ MODULE PROCEDURE FMPOLYGAMMA_FM
+ END INTERFACE
+
+ INTERFACE POCHHAMMER
+ MODULE PROCEDURE FMPOCHHAMMER_FM
+ END INTERFACE
+
+ INTERFACE PSI
+ MODULE PROCEDURE FMPSI_FM
+ END INTERFACE
+
+ CONTAINS
+
+! SIN
+
+ FUNCTION FMSIN_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMSIN_FM
+ INTENT (IN) :: MA
+ CALL FMSIN(MA%MFM,FMSIN_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMSIN_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMSIN_ZM
+ INTENT (IN) :: MA
+ CALL ZMSIN(MA%MZM,FMSIN_ZM%MZM)
+ END FUNCTION
+
+! SINH
+
+ FUNCTION FMSINH_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMSINH_FM
+ INTENT (IN) :: MA
+ CALL FMSINH(MA%MFM,FMSINH_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMSINH_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMSINH_ZM
+ INTENT (IN) :: MA
+ CALL ZMSINH(MA%MZM,FMSINH_ZM%MZM)
+ END FUNCTION
+
+! SPACING
+
+ FUNCTION FMSPACING_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMSPACING_FM
+ INTENT (IN) :: MA
+ CALL FMABS(MA%MFM,MTFM)
+ CALL FMULP(MTFM,FMSPACING_FM%MFM)
+ END FUNCTION
+
+! SQRT
+
+ FUNCTION FMSQRT_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMSQRT_FM
+ INTENT (IN) :: MA
+ CALL FMSQRT(MA%MFM,FMSQRT_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMSQRT_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMSQRT_ZM
+ INTENT (IN) :: MA
+ CALL ZMSQRT(MA%MZM,FMSQRT_ZM%MZM)
+ END FUNCTION
+
+! TAN
+
+ FUNCTION FMTAN_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMTAN_FM
+ INTENT (IN) :: MA
+ CALL FMTAN(MA%MFM,FMTAN_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMTAN_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMTAN_ZM
+ INTENT (IN) :: MA
+ CALL ZMTAN(MA%MZM,FMTAN_ZM%MZM)
+ END FUNCTION
+
+! TANH
+
+ FUNCTION FMTANH_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMTANH_FM
+ INTENT (IN) :: MA
+ CALL FMTANH(MA%MFM,FMTANH_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FMTANH_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMTANH_ZM
+ INTENT (IN) :: MA
+ CALL ZMTANH(MA%MZM,FMTANH_ZM%MZM)
+ END FUNCTION
+
+! TINY
+
+ FUNCTION FMTINY_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMTINY_FM
+ INTEGER J
+ INTENT (IN) :: MA
+ FMTINY_FM%MFM(-1) = 1
+ FMTINY_FM%MFM(0) = NINT(NDIG*ALOGM2)
+ FMTINY_FM%MFM(1) = -MXEXP
+ FMTINY_FM%MFM(2) = 1
+ DO J = 3, NDIG+1
+ FMTINY_FM%MFM(J) = 0
+ ENDDO
+ END FUNCTION
+
+ FUNCTION FMTINY_IM(MA)
+ USE FMVALS
+ TYPE ( IM ) MA,FMTINY_IM
+ INTENT (IN) :: MA
+ CALL IMI2M(1,FMTINY_IM%MIM)
+ END FUNCTION
+
+ FUNCTION FMTINY_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) MA,FMTINY_ZM
+ INTEGER J
+ INTENT (IN) :: MA
+ MTFM(-1) = 1
+ MTFM(0) = NINT(NDIG*ALOGM2)
+ MTFM(1) = -MXEXP
+ MTFM(2) = 1
+ DO J = 3, NDIG+1
+ MTFM(J) = 0
+ ENDDO
+ CALL ZMCMPX(MTFM,MTFM,FMTINY_ZM%MZM)
+ END FUNCTION
+
+! TO_FM
+
+ FUNCTION FM_I(IVAL)
+ USE FMVALS
+ TYPE ( FM ) FM_I
+ INTEGER IVAL
+ INTENT (IN) :: IVAL
+ CALL FMI2M(IVAL,FM_I%MFM)
+ END FUNCTION
+
+ FUNCTION FM_R(R)
+ USE FMVALS
+ TYPE ( FM ) FM_R
+ REAL R
+ INTENT (IN) :: R
+ CALL FMSP2M(R,FM_R%MFM)
+ END FUNCTION
+
+ FUNCTION FM_D(D)
+ USE FMVALS
+ TYPE ( FM ) FM_D
+ DOUBLE PRECISION D
+ INTENT (IN) :: D
+ CALL FMDP2M(D,FM_D%MFM)
+ END FUNCTION
+
+ FUNCTION FM_Z(Z)
+ USE FMVALS
+ TYPE ( FM ) FM_Z
+ COMPLEX Z
+ INTENT (IN) :: Z
+ CALL FMSP2M(REAL(Z),FM_Z%MFM)
+ END FUNCTION
+
+ FUNCTION FM_C(C)
+ USE FMVALS
+ TYPE ( FM ) FM_C
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),FM_C%MFM)
+ END FUNCTION
+
+ FUNCTION FM_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) FM_FM,MA
+ INTENT (IN) :: MA
+ CALL FMEQ(MA%MFM,FM_FM%MFM)
+ END FUNCTION
+
+ FUNCTION FM_IM(MA)
+ USE FMVALS
+ TYPE ( FM ) FM_IM
+ TYPE ( IM ) MA
+ INTENT (IN) :: MA
+ CALL IMI2FM(MA%MIM,FM_IM%MFM)
+ END FUNCTION
+
+ FUNCTION FM_ST(ST)
+ USE FMVALS
+ TYPE ( FM ) FM_ST
+ CHARACTER(*) :: ST
+ INTENT (IN) :: ST
+ CALL FMST2M(ST,FM_ST%MFM)
+ END FUNCTION
+
+ FUNCTION FM_ZM(MA)
+ USE FMVALS
+ TYPE ( FM ) FM_ZM
+ TYPE ( ZM ) MA
+ INTENT (IN) :: MA
+ CALL ZMREAL(MA%MZM,FM_ZM%MFM)
+ END FUNCTION
+
+! TO_IM
+
+ FUNCTION IM_I(IVAL)
+ USE FMVALS
+ TYPE ( IM ) IM_I
+ INTEGER IVAL
+ INTENT (IN) :: IVAL
+ CALL IMI2M(IVAL,IM_I%MIM)
+ END FUNCTION
+
+ FUNCTION IM_R(R)
+ USE FMVALS
+ TYPE ( IM ) IM_R
+ REAL R
+ CHARACTER(25) :: ST
+ INTENT (IN) :: R
+ IF (ABS(R) < HUGE(1)) THEN
+ IVAL = INT(R)
+ CALL IMI2M(IVAL,IM_R%MIM)
+ ELSE
+ WRITE (ST,'(E25.16)') R
+ CALL IMST2M(ST,IM_R%MIM)
+ ENDIF
+ END FUNCTION
+
+ FUNCTION IM_D(D)
+ USE FMVALS
+ TYPE ( IM ) IM_D
+ DOUBLE PRECISION D
+ CHARACTER(25) :: ST
+ INTENT (IN) :: D
+ IF (ABS(D) < HUGE(1)) THEN
+ IVAL = INT(D)
+ CALL IMI2M(IVAL,IM_D%MIM)
+ ELSE
+ WRITE (ST,'(E25.16)') D
+ CALL IMST2M(ST,IM_D%MIM)
+ ENDIF
+ END FUNCTION
+
+ FUNCTION IM_Z(Z)
+ USE FMVALS
+ TYPE ( IM ) IM_Z
+ COMPLEX Z
+ REAL R
+ CHARACTER(25) :: ST
+ INTENT (IN) :: Z
+ R = REAL(Z)
+ IF (ABS(R) < HUGE(1)) THEN
+ IVAL = INT(R)
+ CALL IMI2M(IVAL,IM_Z%MIM)
+ ELSE
+ WRITE (ST,'(E25.16)') R
+ CALL IMST2M(ST,IM_Z%MIM)
+ ENDIF
+ END FUNCTION
+
+ FUNCTION IM_C(C)
+ USE FMVALS
+ TYPE ( IM ) IM_C
+ COMPLEX (KIND(0.0D0)) :: C
+ DOUBLE PRECISION D
+ CHARACTER(25) :: ST
+ INTENT (IN) :: C
+ D = REAL(C)
+ IF (ABS(D) < HUGE(1)) THEN
+ IVAL = INT(D)
+ CALL IMI2M(IVAL,IM_C%MIM)
+ ELSE
+ WRITE (ST,'(E25.16)') D
+ CALL IMST2M(ST,IM_C%MIM)
+ ENDIF
+ END FUNCTION
+
+ FUNCTION IM_FM(MA)
+ USE FMVALS
+ TYPE ( IM ) IM_FM
+ TYPE ( FM ) MA
+ INTENT (IN) :: MA
+ CALL IMFM2I(MA%MFM,IM_FM%MIM)
+ END FUNCTION
+
+ FUNCTION IM_IM(MA)
+ USE FMVALS
+ TYPE ( IM ) IM_IM,MA
+ INTENT (IN) :: MA
+ CALL IMEQ(MA%MIM,IM_IM%MIM)
+ END FUNCTION
+
+ FUNCTION IM_ST(ST)
+ USE FMVALS
+ TYPE ( IM ) IM_ST
+ CHARACTER(*) :: ST
+ INTENT (IN) :: ST
+ CALL IMST2M(ST,IM_ST%MIM)
+ END FUNCTION
+
+ FUNCTION IM_ZM(MA)
+ USE FMVALS
+ TYPE ( IM ) IM_ZM
+ TYPE ( ZM ) MA
+ INTENT (IN) :: MA
+ CALL ZMREAL(MA%MZM,MTFM)
+ CALL IMFM2I(MTFM,IM_ZM%MIM)
+ END FUNCTION
+
+! TO_ZM
+
+ FUNCTION ZM_I(IVAL)
+ USE FMVALS
+ TYPE ( ZM ) ZM_I
+ INTEGER IVAL
+ INTENT (IN) :: IVAL
+ CALL ZMI2M(IVAL,ZM_I%MZM)
+ END FUNCTION
+
+ FUNCTION ZM_R(R)
+ USE FMVALS
+ TYPE ( ZM ) ZM_R
+ REAL R
+ INTENT (IN) :: R
+ CALL FMSP2M(R,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,ZM_R%MZM)
+ END FUNCTION
+
+ FUNCTION ZM_D(D)
+ USE FMVALS
+ TYPE ( ZM ) ZM_D
+ DOUBLE PRECISION D
+ INTENT (IN) :: D
+ CALL FMDP2M(D,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,ZM_D%MZM)
+ END FUNCTION
+
+ FUNCTION ZM_Z(Z)
+ USE FMVALS
+ TYPE ( ZM ) ZM_Z
+ COMPLEX Z
+ INTENT (IN) :: Z
+ CALL ZMZ2M(Z,ZM_Z%MZM)
+ END FUNCTION
+
+ FUNCTION ZM_C(C)
+ USE FMVALS
+ TYPE ( ZM ) ZM_C
+ COMPLEX (KIND(0.0D0)) :: C
+ INTENT (IN) :: C
+ CALL FMDP2M(REAL(C,KIND(0.0D0)),MTFM)
+ CALL FMDP2M(AIMAG(C),MUFM)
+ CALL ZMCMPX(MTFM,MUFM,ZM_C%MZM)
+ END FUNCTION
+
+ FUNCTION ZM_FM(MA)
+ USE FMVALS
+ TYPE ( ZM ) ZM_FM
+ TYPE ( FM ) MA
+ INTENT (IN) :: MA
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MA%MFM,MUFM,ZM_FM%MZM)
+ END FUNCTION
+
+ FUNCTION ZM_IM(MA)
+ USE FMVALS
+ TYPE ( ZM ) ZM_IM
+ TYPE ( IM ) MA
+ INTENT (IN) :: MA
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMI2M(0,MUFM)
+ CALL ZMCMPX(MTFM,MUFM,ZM_IM%MZM)
+ END FUNCTION
+
+ FUNCTION ZM_ST(ST)
+ USE FMVALS
+ TYPE ( ZM ) ZM_ST
+ CHARACTER(*) :: ST
+ INTENT (IN) :: ST
+ CALL ZMST2M(ST,ZM_ST%MZM)
+ END FUNCTION
+
+ FUNCTION ZM_ZM(MA)
+ USE FMVALS
+ TYPE ( ZM ) ZM_ZM,MA
+ INTENT (IN) :: MA
+ CALL ZMEQ(MA%MZM,ZM_ZM%MZM)
+ END FUNCTION
+
+! TO_INT
+
+ FUNCTION FM_2INT(MA)
+ TYPE ( FM ) MA
+ INTEGER FM_2INT
+ INTENT (IN) :: MA
+ CALL FMM2I(MA%MFM,FM_2INT)
+ END FUNCTION
+
+ FUNCTION IM_2INT(MA)
+ TYPE ( IM ) MA
+ INTEGER IM_2INT
+ INTENT (IN) :: MA
+ CALL IMM2I(MA%MIM,IM_2INT)
+ END FUNCTION
+
+ FUNCTION ZM_2INT(MA)
+ TYPE ( ZM ) MA
+ INTEGER ZM_2INT
+ INTENT (IN) :: MA
+ CALL ZMM2I(MA%MZM,ZM_2INT)
+ END FUNCTION
+
+! TO_SP
+
+ FUNCTION FM_2SP(MA)
+ TYPE ( FM ) MA
+ REAL FM_2SP
+ INTENT (IN) :: MA
+ CALL FMM2SP(MA%MFM,FM_2SP)
+ END FUNCTION
+
+ FUNCTION IM_2SP(MA)
+ TYPE ( IM ) MA
+ REAL IM_2SP
+ INTENT (IN) :: MA
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMM2SP(MTFM,IM_2SP)
+ END FUNCTION
+
+ FUNCTION ZM_2SP(MA)
+ TYPE ( ZM ) MA
+ REAL ZM_2SP
+ INTENT (IN) :: MA
+ CALL ZMREAL(MA%MZM,MTFM)
+ CALL FMM2SP(MTFM,ZM_2SP)
+ END FUNCTION
+
+! TO_DP
+
+ FUNCTION FM_2DP(MA)
+ TYPE ( FM ) MA
+ DOUBLE PRECISION FM_2DP
+ INTENT (IN) :: MA
+ CALL FMM2DP(MA%MFM,FM_2DP)
+ END FUNCTION
+
+ FUNCTION IM_2DP(MA)
+ TYPE ( IM ) MA
+ DOUBLE PRECISION IM_2DP
+ INTENT (IN) :: MA
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMM2DP(MTFM,IM_2DP)
+ END FUNCTION
+
+ FUNCTION ZM_2DP(MA)
+ TYPE ( ZM ) MA
+ DOUBLE PRECISION ZM_2DP
+ INTENT (IN) :: MA
+ CALL ZMREAL(MA%MZM,MTFM)
+ CALL FMM2DP(MTFM,ZM_2DP)
+ END FUNCTION
+
+! TO_SPZ
+
+ FUNCTION FM_2SPZ(MA)
+ TYPE ( FM ) MA
+ COMPLEX FM_2SPZ
+ REAL R
+ INTENT (IN) :: MA
+ CALL FMM2SP(MA%MFM,R)
+ FM_2SPZ = CMPLX( R , 0.0 )
+ END FUNCTION
+
+ FUNCTION IM_2SPZ(MA)
+ TYPE ( IM ) MA
+ COMPLEX IM_2SPZ
+ REAL R
+ INTENT (IN) :: MA
+ CALL IMI2FM(MA%MIM,MTFM)
+ CALL FMM2SP(MTFM,R)
+ IM_2SPZ = CMPLX( R , 0.0 )
+ END FUNCTION
+
+ FUNCTION ZM_2SPZ(MA)
+ TYPE ( ZM ) MA
+ COMPLEX ZM_2SPZ
+ INTENT (IN) :: MA
+ CALL ZMM2Z(MA%MZM,ZM_2SPZ)
+ END FUNCTION
+
+! TO_DPZ
+
+ FUNCTION FM_2DPZ(MA)
+ TYPE ( FM ) MA
+ COMPLEX (KIND(0.0D0)) :: FM_2DPZ
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA
+ CALL FMM2DP(MA%MFM,D)
+ FM_2DPZ = CMPLX( D , 0.0D0 , KIND(0.0D0) )
+ END FUNCTION
+
+ FUNCTION IM_2DPZ(MA)
+ TYPE ( IM ) MA
+ COMPLEX (KIND(0.0D0)) :: IM_2DPZ
+ DOUBLE PRECISION D
+ INTENT (IN) :: MA
+ CALL IMM2DP(MA%MIM,D)
+ IM_2DPZ = CMPLX( D , 0.0D0 , KIND(0.0D0) )
+ END FUNCTION
+
+ FUNCTION ZM_2DPZ(MA)
+ TYPE ( ZM ) MA
+ COMPLEX (KIND(0.0D0)) :: ZM_2DPZ
+ DOUBLE PRECISION D1,D2
+ INTENT (IN) :: MA
+ CALL ZMREAL(MA%MZM,MTFM)
+ CALL FMM2DP(MTFM,D1)
+ CALL ZMIMAG(MA%MZM,MTFM)
+ CALL FMM2DP(MTFM,D2)
+ ZM_2DPZ = CMPLX( D1 , D2 , KIND(0.0D0) )
+ END FUNCTION
+
+! FM_RANDOM_SEED
+
+ SUBROUTINE FM_SEED(PUT,GET,SIZE)
+
+! Interface routine for FM_RANDOM_SEED, used to initialize the random sequence
+! from FM_RANDOM_NUMBER.
+
+! Like the Fortran intrinsic function RANDOM_SEED, exactly one of the three
+! arguments must be present, and the call should be with an argument keyword.
+
+! CALL FM_RANDOM_SEED(SIZE=J) returns J=7 to the calling program, indicating
+! that the seed array has length 7.
+
+! CALL FM_RANDOM_SEED(GET=SEED) returns SEED(1) through SEED(7) as the current
+! seed for the generator, but see the comments in routine FM_RANDOM_NUMBER.
+
+! CALL FM_RANDOM_SEED(PUT=SEED) initializes the FM_RANDOM_NUMBER generator.
+
+! The typical usage is to call FM_RANDOM_SEED once with PUT defined as an
+! integer array of length 7 containing seven seed values used to initialize
+! the generator. This initializes the table used by the mixed congruential
+! generator. Then each call to FM_RANDOM_NUMBER gets the next random value.
+
+! This example seeds the generator and then fills the double precision array R
+! with random values between 0 and 1.
+
+! SEED = (/ 314159,265358,979323,846264,338327,950288,419716 /)
+! CALL FM_RANDOM_SEED(PUT=SEED)
+! DO J = 1, N
+! CALL FM_RANDOM_NUMBER(R(J))
+! ENDDO
+
+ USE FMVALS
+
+ IMPLICIT NONE
+
+ INTEGER, OPTIONAL, INTENT(IN) :: PUT(7)
+ INTEGER, OPTIONAL, INTENT(OUT) :: GET(7)
+ INTEGER, OPTIONAL, INTENT(OUT) :: SIZE
+
+ REAL (KIND(1.0D0)) :: MSAVE
+ INTEGER J,K
+
+
+ IF (PRESENT(SIZE)) THEN
+ SIZE = 7
+ RETURN
+ ENDIF
+ MSAVE = MBASE
+ MBASE = MBRAND
+ IF (PRESENT(PUT)) THEN
+ K = 10**7
+ CALL IMI2M(ABS(PUT(1)),MRNX)
+ DO J = 2, 7
+ CALL IMMPYI(MRNX,K,MTIM)
+ CALL IMI2M(ABS(PUT(J)),M04)
+ CALL IMADD(MTIM,M04,MRNX)
+ ENDDO
+ CALL IMST2M('2070613773952029032014000773560846464373793273739',M04)
+ CALL IMMOD(MRNX,M04,MTIM)
+ CALL IMEQ(MTIM,MRNX)
+ START_RANDOM_SEQUENCE = 1
+ MBASE = MSAVE
+ RETURN
+ ENDIF
+ IF (PRESENT(GET)) THEN
+ K = 10**7
+ CALL IMI2M(K,M05)
+ CALL IMEQ(MRNX,M04)
+ DO J = 7, 1, -1
+ CALL IMMOD(M04,M05,M06)
+ CALL IMM2I(M06,GET(J))
+ CALL IMDIVI(M04,K,MTIM)
+ CALL IMEQ(MTIM,M04)
+ ENDDO
+ MBASE = MSAVE
+ RETURN
+ ENDIF
+ END SUBROUTINE
+
+! FM_FORMAT
+
+ FUNCTION FMFORMAT_FM(FMT,MA)
+ USE FMVALS
+ CHARACTER(*) :: FMT
+ TYPE ( FM ) MA
+ CHARACTER(200) :: FMFORMAT_FM
+ INTENT (IN) :: FMT,MA
+ CALL FMFORM(FMT,MA%MFM,FMFORMAT_FM)
+ END FUNCTION
+
+! IM_FORMAT
+
+ FUNCTION IMFORMAT_IM(FMT,MA)
+ USE FMVALS
+ CHARACTER(*) :: FMT
+ CHARACTER(200) :: IMFORMAT_IM
+ TYPE ( IM ) MA
+ INTENT (IN) :: FMT,MA
+ CALL IMFORM(FMT,MA%MIM,IMFORMAT_IM)
+ END FUNCTION
+
+! ZM_FORMAT
+
+ FUNCTION ZMFORMAT_ZM(FMTR,FMTI,MA)
+ USE FMVALS
+ CHARACTER(*) :: FMTR,FMTI
+ CHARACTER(200) :: ZMFORMAT_ZM
+ TYPE ( ZM ) MA
+ INTENT (IN) :: FMTR,FMTI,MA
+ CALL ZMFORM(FMTR,FMTI,MA%MZM,ZMFORMAT_ZM)
+ END FUNCTION
+
+! GCD
+
+ FUNCTION GCD_IM(MA,MB)
+ USE FMVALS
+ TYPE ( IM ) MA,MB,GCD_IM
+ INTENT (IN) :: MA,MB
+ CALL IMGCD(MA%MIM,MB%MIM,GCD_IM%MIM)
+ END FUNCTION
+
+! MULTIPLY_MOD
+
+ FUNCTION MULTIPLYMOD_IM(MA,MB,MC)
+ USE FMVALS
+ TYPE ( IM ) MA,MB,MC,MULTIPLYMOD_IM
+ INTENT (IN) :: MA,MB,MC
+ CALL IMMPYM(MA%MIM,MB%MIM,MC%MIM,MULTIPLYMOD_IM%MIM)
+ END FUNCTION
+
+! POWER_MOD
+
+ FUNCTION POWERMOD_IM(MA,MB,MC)
+ USE FMVALS
+ TYPE ( IM ) MA,MB,MC,POWERMOD_IM
+ INTENT (IN) :: MA,MB,MC
+ CALL IMPMOD(MA%MIM,MB%MIM,MC%MIM,POWERMOD_IM%MIM)
+ END FUNCTION
+
+! BERNOULLI
+
+ FUNCTION FMBERNOULLI_FM(N)
+ USE FMVALS
+ TYPE ( FM ) FMBERNOULLI_FM
+ INTEGER N
+ INTENT (IN) :: N
+ CALL FMI2M(1,MTFM)
+ CALL FMBERN(N,MTFM,FMBERNOULLI_FM%MFM)
+ END FUNCTION
+
+! BETA
+
+ FUNCTION FMBETA_FM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMBETA_FM
+ INTENT (IN) :: MA,MB
+ CALL FMBETA(MA%MFM,MB%MFM,FMBETA_FM%MFM)
+ END FUNCTION
+
+! BINOMIAL
+
+ FUNCTION FMBINOMIAL_FM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMBINOMIAL_FM
+ INTENT (IN) :: MA,MB
+ CALL FMCOMB(MA%MFM,MB%MFM,FMBINOMIAL_FM%MFM)
+ END FUNCTION
+
+! FACTORIAL
+
+ FUNCTION FMFACTORIAL_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMFACTORIAL_FM
+ INTENT (IN) :: MA
+ CALL FMFACT(MA%MFM,FMFACTORIAL_FM%MFM)
+ END FUNCTION
+
+! GAMMA
+
+ FUNCTION FMGAMMA_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMGAMMA_FM
+ INTENT (IN) :: MA
+ CALL FMGAM(MA%MFM,FMGAMMA_FM%MFM)
+ END FUNCTION
+
+! INCOMPLETE_BETA
+
+ FUNCTION FMINCOMPLETE_BETA_FM(MX,MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MX,MA,MB,FMINCOMPLETE_BETA_FM
+ INTENT (IN) :: MX,MA,MB
+ CALL FMIBTA(MX%MFM,MA%MFM,MB%MFM,FMINCOMPLETE_BETA_FM%MFM)
+ END FUNCTION
+
+! INCOMPLETE_GAMMA1
+
+ FUNCTION FMINCOMPLETE_GAMMA1_FM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMINCOMPLETE_GAMMA1_FM
+ INTENT (IN) :: MA,MB
+ CALL FMIGM1(MA%MFM,MB%MFM,FMINCOMPLETE_GAMMA1_FM%MFM)
+ END FUNCTION
+
+! INCOMPLETE_GAMMA2
+
+ FUNCTION FMINCOMPLETE_GAMMA2_FM(MA,MB)
+ USE FMVALS
+ TYPE ( FM ) MA,MB,FMINCOMPLETE_GAMMA2_FM
+ INTENT (IN) :: MA,MB
+ CALL FMIGM2(MA%MFM,MB%MFM,FMINCOMPLETE_GAMMA2_FM%MFM)
+ END FUNCTION
+
+! LOG_GAMMA
+
+ FUNCTION FMLOG_GAMMA_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMLOG_GAMMA_FM
+ INTENT (IN) :: MA
+ CALL FMLNGM(MA%MFM,FMLOG_GAMMA_FM%MFM)
+ END FUNCTION
+
+! POLYGAMMA
+
+ FUNCTION FMPOLYGAMMA_FM(N,MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMPOLYGAMMA_FM
+ INTEGER N
+ INTENT (IN) :: N,MA
+ CALL FMPGAM(N,MA%MFM,FMPOLYGAMMA_FM%MFM)
+ END FUNCTION
+
+! POCHHAMMER
+
+ FUNCTION FMPOCHHAMMER_FM(MA,N)
+ USE FMVALS
+ TYPE ( FM ) MA,FMPOCHHAMMER_FM
+ INTEGER N
+ INTENT (IN) :: N,MA
+ CALL FMPOCH(MA%MFM,N,FMPOCHHAMMER_FM%MFM)
+ END FUNCTION
+
+! PSI
+
+ FUNCTION FMPSI_FM(MA)
+ USE FMVALS
+ TYPE ( FM ) MA,FMPSI_FM
+ INTENT (IN) :: MA
+ CALL FMPSI(MA%MFM,FMPSI_FM%MFM)
+ END FUNCTION
+
+ END MODULE FMZM_9
+
+ MODULE FMZM
+
+ USE FMZM_1
+ USE FMZM_2
+ USE FMZM_3
+ USE FMZM_4
+ USE FMZM_5
+ USE FMZM_6
+ USE FMZM_7
+ USE FMZM_8
+ USE FMZM_9
+
+ END MODULE FMZM
diff --git a/src/fmlib/Makefile b/src/fmlib/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..1c1612e0f8f7627a5994f1a8278a3b57e5e1c138
--- /dev/null
+++ b/src/fmlib/Makefile
@@ -0,0 +1,73 @@
+#===============================================================================
+#
+# Makefile for FMLIB
+#
+#-------------------------------------------------------------------------------
+#
+# Copyright (C) 2011 Yoshifumi Nakamura
+#
+# This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+#
+# BQCD is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# BQCD is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+#
+#===============================================================================
+DIR = ../
+include $(DIR)Makefile.in
+MODULES_DIR = $(DIR)modules
+
+
+FAST_MAKE = make -j 1
+
+ifdef FPP2
+ fpp = $(FPP2)
+else
+ fpp = $(FPP)
+endif
+
+.SUFFIXES:
+.SUFFIXES: .a .o .F90
+
+.F90.o:
+ $(fpp) -I../include $(MYFLAGS) $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
+
+OBJS = \
+ FMSAVE.o \
+ FMZM90.o \
+ FM.o
+# SampleFM.o \
+# TestFM.o
+
+fast:
+ifdef FMLIB
+ $(FAST_MAKE) lib_FM.a
+endif
+
+lib_FM.a: $(OBJS)
+ $(AR) $(ARFLAGS) rv $@ $(OBJS)
+
+TestFM: $(OBJS) TestFM.o
+ $(F90) -o $@ TestFM.o $(OBJS)
+
+SampleFM: $(OBJS) SampleFM.o
+ $(F90) -o $@ SampleFM.o $(OBJS)
+
+test: TestFM SampleFM
+ ./TestFM | tee TestFM.log
+ ./SampleFM | tee SampleFM.log
+
+clobber:
+ rm -f *.[Tiod] *.f90 *.mod *.log *.LOG
+ rm -f lib_FM.a
+ rm -f TestFM SampleFM
diff --git a/src/fmlib/ReadMe b/src/fmlib/ReadMe
new file mode 100644
index 0000000000000000000000000000000000000000..fa13ca65e4c66b6965459a5cd19471c9098379c5
--- /dev/null
+++ b/src/fmlib/ReadMe
@@ -0,0 +1,1626 @@
+
+This is a list of the files for version 1.2 of FMLIB.
+
+1. FMSAVE.f90 Module for FM internal global variables
+
+2. FMZM90.f90 Modules for interfaces and definitions of derived-types
+
+3. FM.f90 Subroutine library for multiple-precision operations
+
+4. TestFM.f90 Test program for most of the FM routines
+
+5. SampleFM.f90 Small sample program using FM
+
+6. SAMPLE.CHK Expected output file SAMPLE.LOG from SampleFM.f90
+
+
+Here is an example set of compiler/linker commands for building
+the programs. For lines on which there is no *.f90 file listed,
+the f90 script skips the compiler and calls the linker.
+Options:
+ -c compile to object code -- don't make executable
+ -O optimization on
+ -f free Fortran-90 free source form
+ -o output file name
+
+
+f90 FMSAVE.f90 -c -f free -o FMSAVE.o
+
+
+f90 FMZM90.f90 -c -f free -o FMZM90.o
+
+
+f90 FM.f90 -O -c -f free -o FM.o
+
+
+f90 TestFM.f90 -c -f free -o TestFM.o
+
+f90 TestFM.o FMSAVE.o FMZM90.o FM.o -o TestFM
+
+
+f90 SampleFM.f90 -c -f free -o SampleFM.o
+
+f90 SampleFM.o FMSAVE.o FMZM90.o FM.o -o SampleFM
+
+
+Basically the first three files are compiled as object code libraries, and
+then a program using FM is compiled and linked to those three libraries.
+
+Most compilers also produce files FMVALS.mod, FMZM.mod, etc., containing
+module information from the first two files.
+
+
+Troubleshooting
+
+1. After downloading the files, if the compiler gives many error messages or
+ it appears to see no code in the file at all, check that the lines in the
+ file have the proper end-of-line characters for your system.
+
+ For a PC, this means each line should end with both a carriage return <cr>
+ character (ascii 13) and a line feed <lf> character (ascii 10). If the
+ file appears to be one huge line when viewed in an editor, one of these
+ two characters is probably missing and should be added to each line.
+
+ To use FM on a Unix system, lines end with <lf>, and for a Mac system they
+ end with <cr>. On these systems, failing to fix the end-of-line characters
+ might mean the file seems to have twice the expected number of lines, with
+ a blank line between each line of code when viewed in an editor.
+
+ Many good editors will recognize a foreign end-of-line format and
+ automatically fix each file the first time it is opened.
+
+2. Compiler gives an "out of memory" error message or crashes during compile
+ of FM.f90 or FMZM90.f90.
+
+ It might be necessary to break the file into smaller pieces or split it
+ into separate files for each routine or module. This could be caused by
+ lack of system memory, lack of virtual memory, or a bug (memory leak) in
+ the compiler.
+
+ Some compilers have an option (-split) to do this automatically.
+
+3. Most of the routines compile, but a few fail with error messages like
+ "symbol 120 is not the label of a branch target statement".
+ However, looking at the code shows there is a label 120 in that routine.
+
+ This might happen in the larger routines. Some compilers may require
+ additional options be enabled (e.g., to force 32-bit branches or addresses
+ to be used). Check in the compiler manual and try turning on any options
+ that mention "long branches", "32-bit addresses", etc.
+
+4. All files compile, but the TestFM program reports a few errors when it runs.
+ There are other possibilities, but one thing to check is whether the
+ compiler has any options controlling arithmetic precision of intermediate
+ results.
+
+ Because the FM numbers are stored as integer values in double precision
+ arrays, any sloppy rounding can cause problems. In one case, a compiler
+ optimized an expression by leaving the result of a division in an 80-bit
+ register and then used that result later in the calculation. Rounding
+ the division back to double precision would have fixed the error, but
+ using the inaccurate extended precision value caused the final result to
+ be off by one when it was returned to an integer value.
+
+ This compiler had an option (-ap) to force intermediate results to not be
+ left in registers, and that fixed the problem.
+
+ Another way to check to see if this is the problem is to create a version
+ of FM that uses integer arrays instead of double precision. See the section
+ titled "EFFICIENCY" below to see how to make this change. On most machines,
+ there is little if any speed penalty for using integer arrays as long as the
+ precision is under 100 significant digits (i.e., NDIG < 15 or so with MBASE
+ = 10**7).
+
+5. Several messages like this appear:
+ C:\t\FMZM90.f90(6563) : Info: This variable has not been used. [MA]
+ FUNCTION FMTINY_ZM(MA)
+
+ This and the other messages of the same type are not errors. The argument
+ for functions like TINY is not used for anything except telling the
+ compiler which routine to call by checking the argument's type. The same
+ is true of the Fortran intrinsic function TINY. If we say TINY(1.0) or
+ TINY(2.0), the input argument is not used, other than to indicate that we
+ want the single precision value of TINY.
+
+
+
+================================================================================
+================================================================================
+
+
+ USER'S GUIDE FOR THE FM PACKAGE
+
+
+The various lists of available multiple precision operations and
+routines have been collected here, along with some general advice
+on using the package.
+
+See the program SampleFM.f90 for some examples of initializing and
+using the package.
+
+
+INITIALIZATION: The default precision for the multiple-precision numbers
+ is about 50 significant digits.
+
+ To set precision to a different value, put
+ CALL FMSET(N)
+ in the main program before any multiple precision
+ operations are done, with N replaced by the number
+ of decimal digits of accuracy to be used.
+
+ROUTINE NAMES: For each multiple precision operation there are
+ several routines with related names that perform
+ variations of that operation. For example, the
+ addition operation has these forms:
+
+ Using the Fortran-90 interface module, to perform
+ real (floating-point) multiple precision addition,
+ declare the variables as FM derived types with
+
+ USE FMZM
+ TYPE ( FM ) A,B,C
+
+ and then add using
+
+ C = A + B
+
+ Normally, using the interface module avoids the need
+ to know the name of the FM routine being called. For
+ some operations, usually those that are not Fortran-90
+ functions (such as formatting a number), a direct call
+ may be needed. The addition above can be done as
+
+ CALL FM_ADD(A,B,C)
+
+ It is rare for a program to bypass the derived types
+ and work directly with the arrays that define the
+ multiple-precision numbers. The only real drawback
+ to using the derived types is a small performance
+ penalty (that varies from one compiler to another).
+ If FM.f90 is used without the interface module, then
+ the multiple precision numbers are declared as arrays
+
+ DOUBLE PRECISION A(-1:LUNPCK),B(-1:LUNPCK),C(-1:LUNPCK)
+
+ where LUNPCK is defined in FMSAVE.f90. The numbers are
+ then added by calling the FM routine where the arguments
+ are assumed to be arrays, not TYPE (FM) derived types:
+
+ CALL FMADD(A,B,C)
+
+ For each of the routines listed below (like FMADD),
+ there is a version that assumes the arguments have
+ the appropriate derived type. These have the same
+ names, except "_" has been inserted after the first
+ two letters of the name (like FM_ADD).
+
+ If direct calls are done instead of using the
+ interface module, there is another form for these
+ routine names that is used when the arrays have been
+ declared in a packed format that takes roughly half
+ as much space:
+
+ DOUBLE PRECISION A(-1:LPACK),B(-1:LPACK),C(-1:LPACK)
+
+ The routines that work with packed arrays have names
+ where the second letter has been changed from M to P:
+
+ CALL FPADD(A,B,C)
+
+ The packed versions are slower.
+
+ For multiple precision integer (IM) or complex (ZM)
+ operations there are similar Fortran-90 derived types
+ and the various routines:
+
+ USE FMZM
+ ...
+ TYPE ( IM ) A,B,C
+ TYPE ( ZM ) X,Y,Z
+ ...
+ C = A + B
+ ...
+ Z = X + Y
+
+ with explicit calls of the form
+
+ CALL IM_ADD(A,B,C)
+ CALL ZM_ADD(X,Y,Z)
+
+ Without using the interface module:
+
+ DOUBLE PRECISION A(-1:LUNPCK),B(-1:LUNPCK),C(-1:LUNPCK)
+ DOUBLE PRECISION X(-1:LUNPKZ),Y(-1:LUNPKZ),Z(-1:LUNPKZ)
+ ...
+ CALL IMADD(A,B,C)
+ ...
+ CALL ZMADD(X,Y,Z)
+
+ Packed format without the interface module:
+
+ DOUBLE PRECISION A(-1:LPACK),B(-1:LPACK),C(-1:LPACK)
+ DOUBLE PRECISION X(-1:LPACKZ),Y(-1:LPACKZ),Z(-1:LPACKZ)
+ ...
+ CALL IPADD(A,B,C)
+ ...
+ CALL ZPADD(X,Y,Z)
+
+
+
+--------------------------------------------------------------------------------
+----------------------- Fortran-90 Interface Notes -------------------------
+
+
+
+
+There are three multiple precision data types:
+ FM (multiple precision real)
+ IM (multiple precision integer)
+ ZM (multiple precision complex)
+
+Some of the interface routines assume that the precision chosen in the
+calling program (using FMSET) represents more significant digits than does
+the machine's double precision.
+
+Most of the functions defined in this module are multiple precision versions
+of standard Fortran-90 functions. In addition, there are functions for
+direct conversion, formatting, and some mathematical special functions.
+
+TO_FM is a function for converting other types of numbers to type FM. Note
+that TO_FM(3.12) converts the REAL constant to FM, but it is accurate only
+to single precision. TO_FM(3.12D0) agrees with 3.12 to double precision
+accuracy, and TO_FM('3.12') or TO_FM(312)/TO_FM(100) agrees to full FM
+accuracy.
+
+TO_IM converts to type IM, and TO_ZM converts to type ZM.
+
+Functions are also supplied for converting the three multiple precision types
+to the other numeric data types:
+ TO_INT converts to machine precision integer
+ TO_SP converts to single precision
+ TO_DP converts to double precision
+ TO_SPZ converts to single precision complex
+ TO_DPZ converts to double precision complex
+
+WARNING: When multiple precision type declarations are inserted in an
+ existing program, take care in converting functions like DBLE(X),
+ where X has been declared as a multiple precision type. If X
+ was single precision in the original program, then replacing
+ the DBLE(X) by TO_DP(X) in the new version could lose accuracy.
+ For this reason, the Fortran type-conversion functions defined
+ in this module assume that results should be multiple precision
+ whenever inputs are. Examples:
+ DBLE(TO_FM('1.23E+123456')) is type FM
+ REAL(TO_FM('1.23E+123456')) is type FM
+ REAL(TO_ZM('3.12+4.56i')) is type FM = TO_FM('3.12')
+ INT(TO_FM('1.23')) is type IM = TO_IM(1)
+ INT(TO_IM('1E+23')) is type IM
+ CMPLX(TO_FM('1.23'),TO_FM('4.56')) is type ZM
+
+Programs using this module may sometimes need to call FM, IM, or ZM routines
+directly. This is normally the case when routines are needed that are not
+Fortran-90 intrinsics, such as the formatting subroutine FMFORM. In a
+program using this module, suppose MAFM has been declared with
+TYPE ( FM ) MAFM. To use the routine FMFORM, which expects the second
+argument to be an array and not a derived type, the call would have to be
+CALL FMFORM('F65.60',MAFM%MFM,ST1) so that the array contained in MAFM is
+passed.
+
+As an alternative so the user can refer directly to the FM-, IM-, and ZM-type
+variables and avoid the cumbersome "%MFM" suffixes, the FM package provides a
+collection of interface routines to supply any needed argument conversions.
+For each FM, IM, and ZM routine that is designed to be called by the user,
+there is also a version that assumes any multiple-precision arguments are
+derived types instead of arrays. Each interface routine has the same name as
+the original with an underscore after the first two letters of the routine
+name. To convert the number to a character string with F65.60 format, use
+CALL FM_FORM('F65.60',MAFM,ST1) if MAFM is of TYPE ( FM ), or use
+CALL FMFORM('F65.60',MA,ST1) if MA is declared as an array. All the routines
+shown below may be used this way.
+
+For each of the operations =, == , /= , < , <= , > , >= , +, -, *, /,
+and **, the interface module defines all mixed mode variations involving one
+of the three multiple precision derived types and another argument having one
+of the types: { integer, real, double, complex, complex double, FM, IM, ZM }.
+So mixed mode expressions such as
+ MAFM = 12
+ MAFM = MAFM + 1
+ IF (ABS(MAFM) > 1.0D-23) THEN
+are handled correctly.
+
+Not all the named functions are defined for all three multiple precision
+derived types, so the list below shows which can be used. The labels "real",
+"integer", and "complex" refer to types FM, IM, and ZM respectively, "string"
+means the function accepts character strings (e.g., TO_FM('3.45')), and
+"other" means the function can accept any of the machine precision data types
+integer, real, double, complex, or complex double. For functions that accept
+two or more arguments, like ATAN2 or MAX, all the arguments must be of the
+same type.
+
+
+AVAILABLE OPERATIONS:
+
+ =
+ +
+ -
+ *
+ /
+ **
+ ==
+ /=
+ <
+ <=
+ >
+ >=
+ ABS real integer complex
+ ACOS real complex
+ AIMAG complex
+ AINT real complex
+ ANINT real complex
+ ASIN real complex
+ ATAN real complex
+ ATAN2 real
+ BTEST integer
+ CEILING real complex
+ CMPLX real integer
+ CONJ complex
+ COS real complex
+ COSH real complex
+ DBLE real integer complex
+ DIGITS real integer complex
+ DIM real integer
+ DINT real complex
+ DOTPRODUCT real integer complex
+ EPSILON real
+ EXP real complex
+ EXPONENT real
+ FLOOR real integer complex
+ FRACTION real complex
+ HUGE real integer complex
+ INT real integer complex
+ LOG real complex
+ LOG10 real complex
+ MATMUL real integer complex
+ MAX real integer
+ MAXEXPONENT real
+ MIN real integer
+ MINEXPONENT real
+ MOD real integer
+ MODULO real integer
+ NEAREST real
+ NINT real integer complex
+ PRECISION real complex
+ RADIX real integer complex
+ RANGE real integer complex
+ REAL real integer complex
+ RRSPACING real
+ SCALE real complex
+ SETEXPONENT real
+ SIGN real integer
+ SIN real complex
+ SINH real complex
+ SPACING real
+ SQRT real complex
+ TAN real complex
+ TANH real complex
+ TINY real integer complex
+ TO_FM real integer complex string other
+ TO_IM real integer complex string other
+ TO_ZM real integer complex string other
+ TO_INT real integer complex
+ TO_SP real integer complex
+ TO_DP real integer complex
+ TO_SPZ real integer complex
+ TO_DPZ real integer complex
+
+Some other functions are defined that do not correspond to machine precision
+intrinsic functions. These include formatting functions, integer modular
+functions and GCD, and the Gamma function and its related functions.
+N below is a machine precision integer, J1, J2, J3 are TYPE (IM), FMT, FMTR,
+FMTI are character strings, A,B,X are TYPE (FM), and Z is TYPE (ZM).
+The three formatting functions return a character string containing the
+formatted number, the three TYPE (IM) functions return a TYPE (IM) result,
+and the 12 special functions return TYPE (FM) results.
+
+Formatting functions:
+
+ FM_FORMAT(FMT,A) Put A into FMT (real) format
+ IM_FORMAT(FMT,J1) Put J1 into FMT (integer) format
+ ZM_FORMAT(FMTR,FMTI,Z) Put Z into (complex) format, FMTR for the real
+ part and FMTI for the imaginary part
+
+ Examples:
+ ST = FM_FORMAT('F65.60',A)
+ WRITE (*,*) ' A = ',TRIM(ST)
+ ST = FM_FORMAT('E75.60',B)
+ WRITE (*,*) ' B = ',ST(1:75)
+ ST = IM_FORMAT('I50',J1)
+ WRITE (*,*) ' J1 = ',ST(1:50)
+ ST = ZM_FORMAT('F35.30','F30.25',Z)
+ WRITE (*,*) ' Z = ',ST(1:70)
+
+ These functions are used for one-line output. The returned character
+ strings are of length 200. Avoid using the formatting function in the
+ write list, as in
+ WRITE (*,*) ' J1 = ',IM_FORMAT('I50',J1)(1:50)
+ since the formatting functions may themselves execute an internal WRITE
+ and that would cause a recursive write reference.
+
+ For higher precision numbers, the output can be broken onto multiple
+ lines automatically by calling subroutines FM_PRNT, IM_PRNT, ZM_PRNT,
+ or the line breaks can be done by hand after calling one of the
+ subroutines FM_FORM, IM_FORM, ZM_FORM.
+
+ For ZM_FORMAT the length of the output is 5 more than the sum of the
+ two field widths.
+
+Integer functions:
+
+ GCD(J1,J2) Greatest Common Divisor of J1 and J2.
+ MULTIPLY_MOD(J1,J2,J3) J1 * J2 mod J3
+ POWER_MOD(J1,J2,J3) J1 ** J2 mod J3
+
+Special functions:
+
+ BERNOULLI(N) Nth Bernoulli number
+ BETA(A,B) Integral (0 to 1) t**(A-1) * (1-t)**(B-1) dt
+ BINOMIAL(A,B) Binomial Coefficient A! / ( B! (A-B)! )
+ FACTORIAL(A) A!
+ GAMMA(A) Integral (0 to infinity) t**(A-1) * exp(-t) dt
+ INCOMPLETE_BETA(X,A,B) Integral (0 to X) t**(A-1) * (1-t)**(B-1) dt
+ INCOMPLETE_GAMMA1(A,X) Integral (0 to X) t**(A-1) * exp(-t) dt
+ INCOMPLETE_GAMMA2(A,X) Integral (X to infinity) t**(A-1) * exp(-t) dt
+ LOG_GAMMA(A) Ln( GAMMA(A) )
+ POLYGAMMA(N,A) Nth derivative of Psi(x), evaluated at A
+ POCHHAMMER(A,N) A*(A+1)*(A+2)*...*(A+N-1)
+ PSI(A) Derivative of Ln(Gamma(x)), evaluated at A
+
+
+
+--------------------------------------------------------------------------------
+------------------------------ FM.f90 Notes --------------------------------
+
+
+
+The routines in this package perform multiple precision arithmetic and
+functions on three kinds of numbers.
+FM routines handle floating-point real multiple precision numbers,
+IM routines handle integer multiple precision numbers, and
+ZM routines handle floating-point complex multiple precision numbers.
+
+
+1. INITIALIZING THE PACKAGE
+
+The variables that contain values to be shared among the different routines
+are located in module FMVALS in file FMSAVE.f90. Variables that are described
+below for controlling various features of the FM package are found in this
+module. They are initialized to default values assuming 32-bit integers and
+64-bit double precision representation of the arrays holding multiple
+precision numbers. The base and number of digits to be used are initialized
+to give slightly more than 50 decimal digits. Subroutine FMVARS can be used
+to get a list of these variables and their values.
+
+The intent of module FMVALS is to hide the FM internal variables from the
+user's program, so that no name conflicts can occur. Subroutine FMSETVAR can
+be used to change the variables listed below to new values. It is not always
+safe to try to change these variables directly by putting USE FMVALS into the
+calling program and then changing them by hand. Some of the saved constants
+depend upon others, so that changing one variable may cause errors if others
+depending on that one are not also changed. FMSETVAR automatically updates
+any others that depend upon the one being changed.
+
+Subroutine FMSET also initializes these variables. It tries to compute the
+best value for each, and it checks several of the values set in FMVALS to see
+that they are reasonable for a given machine. FMSET can also be called to
+set or change the current precision level for the multiple precision numbers.
+
+Calling FMSET is optional in version 1.2 of the FM package. In previous
+versions one call was required before any other routine in the package could
+be used.
+
+The routine ZMSET from version 1.1 is no longer needed, and the complex
+operations are automatically initialized in FMVALS. It has been left in the
+package for compatibility with version 1.1.
+
+
+2. REPRESENTATION OF FM NUMBERS
+
+MBASE is the base in which the arithmetic is done. MBASE must be
+ bigger than one, and less than or equal to the square root of
+ the largest representable integer. For best efficiency MBASE
+ should be large, but no more than about 1/4 of the square root
+ of the largest representable integer. Input and output
+ conversions are much faster when MBASE is a power of ten.
+
+NDIG is the number of base MBASE digits that are carried in the
+ multiple precision numbers. NDIG must be at least two. The
+ upper limit for NDIG is defined in FMVALS and is restricted
+ only by the amount of memory available.
+
+Sometimes it is useful to dynamically vary NDIG during the program. Routine
+FMEQU should be used to round numbers to lower precision or zero-pad them to
+higher precision when changing NDIG.
+
+The default value of MBASE is a large power of ten. FMSET also sets MBASE to
+a large power of ten. For an application where another base is used, such as
+simulating a given machine's base two arithmetic, use subroutine FMSETVAR to
+change MBASE, so that the other internal values depending on MBASE will be
+changed accordingly.
+
+There are two representations for a floating point multiple precision number.
+The unpacked representation used by the routines while doing the computations
+is base MBASE and is stored in NDIG+2 words. A packed representation is
+available to store the numbers in the user's program in compressed form. In
+this format, the NDIG (base MBASE) digits of the mantissa are packed two per
+word to conserve storage. Thus the external, packed form of a number
+requires (NDIG+1)/2+2 words.
+
+This version uses double precision arrays to hold the numbers. Version 1.0
+of FM used integer arrays, which are faster on some machines. The package
+can be changed to use integer arrays --- see section 11 on EFFICIENCY below.
+
+The unpacked format of a floating multiple precision number is as follows.
+A number MA is kept in an array with MA(1) containing the exponent, and
+MA(2) through MA(NDIG+1) each containing one digit of the mantissa, expressed
+in base MBASE. The array is dimensioned to start at MA(-1), with the
+sign of the number (+1 or -1) held in MA(-1), and the approximate number
+of bits of precision stored in MA(0). This precision value is intended to
+be used by FM functions that need to monitor cancellation error in addition
+and subtraction. The cancellation monitor code is usually disabled for user
+calls, and FM functions only check for cancellation when they must. Tracking
+cancellation causes most routines to run slower, with addition and
+subtraction being affected the most. The exponent is a power of MBASE and
+the implied radix point is immediately before the first digit of the
+mantissa. Every nonzero number is normalized so that the second array
+element (the first digit of the mantissa) is nonzero.
+
+In both representations the sign of the number is carried on the second array
+element only. Elements 3,4,... are always nonnegative. The exponent is a
+signed integer and may be as large in magnitude as MXEXP.
+
+For MBASE = 10,000 and NDIG = 4, the number -pi would have these
+representations:
+ Word 1 2 3 4 5
+
+ Unpacked: 1 -3 1415 9265 3590
+ Packed: 1 -31415 92653590
+
+In both formats MA(0) would be 42, indicating that the mantissa has about 42
+bits of precision, and MA(-1) = -1 since the number is negative.
+
+Because of normalization in a large base, the equivalent number of base 10
+significant digits for an FM number may be as small as
+LOG10(MBASE)*(NDIG-1) + 1.
+
+The integer routines use the FM format to represent numbers, without the
+number of digits (NDIG) being fixed. Integers in IM format are essentially
+variable precision, using the minimum number of words to represent each
+value.
+
+For programs using both FM and IM numbers, FM routines should not be called
+with IM numbers, and IM routines should not be called with FM numbers, since
+the implied value of NDIG used for an IM number may not match the explicit
+NDIG expected by an FM routine. Use the conversion routines IMFM2I and
+IMI2FM to change between the FM and IM formats.
+
+The format for complex FM numbers (called ZM numbers below) is very similar
+to that for real FM numbers. Each ZM array holds two FM numbers to represent
+the real and imaginary parts of a complex number. Each ZM array is twice as
+long as a corresponding FM array, with the imaginary part starting at the
+midpoint of the array. As with FM, there are packed and unpacked formats for
+the numbers.
+
+
+3. INPUT/OUTPUT ROUTINES
+
+All versions of the input routines perform free-format conversion from
+characters to FM numbers.
+
+a. Conversion to or from a character array
+
+ FMINP converts from a character*1 array to an FM number.
+
+ FMOUT converts an FM number to base 10 and formats it for output as an
+ array of type character*1. The output is left justified in the
+ array, and the format is defined by two variables in module FMVALS,
+ so that a separate format definition does not have to be provided
+ for each output call.
+
+ JFORM1 and JFORM2 define a default output format.
+
+ JFORM1 = 0 E format ( .314159M+6 )
+ = 1 1PE format ( 3.14159M+5 )
+ = 2 F format ( 314159.000 )
+
+ JFORM2 is the number of significant digits to display (if JFORM1 =
+ 0 or 1). If JFORM2 = 0 then a default number of digits is chosen.
+ The default is roughly the full precision of the number.
+ JFORM2 is the number of digits after the decimal point (if JFORM1 = 2).
+ See the FMOUT documentation for more details.
+
+b. Conversion to or from a character string
+
+ FMST2M converts from a character string to an FM number.
+
+ FMFORM converts an FM number to a character string according to a format
+ provided in each call. The format description is more like that of
+ a Fortran FORMAT statement, and integer or fixed-point output is
+ right justified.
+
+c. Direct read or write
+
+ FMPRNT uses FMOUT to print one FM number.
+
+ FMFPRT uses FMFORM to print one FM number.
+
+ FMWRIT writes FM numbers for later input using FMREAD.
+
+ FMREAD reads FM numbers written by FMWRIT.
+
+The values given to JFORM1 and JFORM2 can be used to define a default output
+format when FMOUT or FMPRNT are called. The explicit format used in a call
+to FMFORM or FMFPRT overrides the settings of JFORM1 and JFORM2.
+
+KW is the unit number to be used for standard output from the package,
+ including error and warning messages, and trace output.
+
+For multiple precision integers, the corresponding routines IMINP, IMOUT,
+IMST2M, IMFORM, IMPRNT, IMFPRT, IMWRIT, and IMREAD provide similar input and
+output conversions. For output of IM numbers, JFORM1 and JFORM2 are ignored
+and integer format (JFORM1=2, JFORM2=0) is used.
+
+For ZM numbers, the corresponding routines ZMINP, ZMOUT, ZMST2M, ZMFORM,
+ZMPRNT, ZMFPRT, ZMWRIT, and ZMREAD provide similar input and output
+conversions.
+
+For the output format of ZM numbers, JFORM1 and JFORM2 determine the default
+format for the individual parts of a complex number as with FM numbers.
+
+ JFORMZ determines the combined output format of the real and
+ imaginary parts.
+
+ JFORMZ = 1 normal setting : 1.23 - 4.56 i
+ = 2 use capital I : 1.23 - 4.56 I
+ = 3 parenthesis format: ( 1.23 , -4.56 )
+
+ JPRNTZ controls whether to print real and imaginary parts
+ on one line whenever possible.
+
+ JPRNTZ = 1 print both parts as a single string :
+ 1.23456789M+321 - 9.87654321M-123 i
+ = 2 print on separate lines without the 'i' :
+ 1.23456789M+321
+ -9.87654321M-123
+
+For further description of these routines, see sections 9 and 10 below.
+
+
+4. ARITHMETIC TRACING
+
+NTRACE and LVLTRC control trace printout from the package.
+
+NTRACE = 0 No output except warnings and errors. (Default)
+ = 1 The result of each call to one of the routines
+ is printed in base 10, using FMOUT.
+ = -1 The result of each call to one of the routines
+ is printed in internal base MBASE format.
+ = 2 The input arguments and result of each call to one
+ of the routines is printed in base 10, using FMOUT.
+ = -2 The input arguments and result of each call to one
+ of the routines is printed in base MBASE format.
+
+LVLTRC defines the call level to which the trace is done. LVLTRC = 1
+ means only FM routines called directly by the user are traced,
+ LVLTRC = 2 also prints traces for FM routines called by other
+ FM routines called directly by the user, etc. Default is 1.
+
+In the above description, internal MBASE format means the number is
+printed as it appears in the array --- an exponent followed by NDIG
+base MBASE digits.
+
+
+5. ERROR CONDITIONS
+
+KFLAG is a condition value returned by the package after each call to one of
+ the routines. Negative values indicate conditions for which a warning
+ message will be printed unless KWARN = 0.
+ Positive values indicate conditions that may be of interest but are not
+ errors. No warning message is printed if KFLAG is nonnegative.
+
+Subroutine FMFLAG is provided to give the user access to the current
+condition code. For example, to set the user's local variable LFLAG
+to FM's internal KFLAG value: CALL FMFLAG(LFLAG)
+
+ KFLAG = 0 Normal operation.
+
+ = 1 One of the operands in FMADD or FMSUB was insignificant with
+ respect to the other, so that the result was equal to
+ the argument of larger magnitude.
+ = 2 In converting an FM number to a one word integer in FMM2I,
+ the FM number was not exactly an integer. The next
+ integer toward zero was returned.
+
+ = -1 NDIG was less than 2 or more than NDIGMX.
+ = -2 MBASE was less than 2 or more than MXBASE.
+ = -3 An exponent was out of range.
+ = -4 Invalid input argument(s) to an FM routine.
+ UNKNOWN was returned.
+ = -5 + or - OVERFLOW was generated as a result from an
+ FM routine.
+ = -6 + or - UNDERFLOW was generated as a result from an
+ FM routine.
+ = -7 The input string (array) to FMINP was not legal.
+ = -8 The character array was not large enough in an
+ input or output routine.
+ = -9 Precision could not be raised enough to provide all
+ requested guard digits. Increasing the value
+ of NDIGMX in file FMSAVE.f90 may fix this.
+ UNKNOWN was returned.
+ = -10 An FM input argument was too small in magnitude to
+ convert to the machine's single or double
+ precision in FMM2SP or FMM2DP. Check that the
+ definitions of SPMAX and DPMAX in file FMSAVE.f90
+ are correct for the current machine.
+ Zero was returned.
+ = -11 Array MBERN is not dimensioned large enough for the
+ requested number of Bernoulli numbers.
+ = -12 Array MJSUMS is not dimensioned large enough for
+ the number of coefficients needed in the
+ reflection formula in FMPGAM.
+
+When a negative KFLAG condition is encountered, the value of KWARN
+determines the action to be taken.
+
+KWARN = 0 Execution continues and no message is printed.
+ = 1 A warning message is printed and execution continues.
+ = 2 A warning message is printed and execution stops.
+
+The default setting is KWARN = 1.
+
+When an overflow or underflow is generated for an operation in which an input
+argument was already an overflow or underflow, no additional message is
+printed. When an unknown result is generated and an input argument was
+already unknown, no additional message is printed. In these cases the
+negative KFLAG value is still returned.
+
+IM routines handle exceptions like OVERFLOW or UNKNOWN in the same way as FM
+routines. When using IMMPY, the product of two large positive integers will
+return +OVERFLOW. The routines IMMPYM and IMPMOD can be used to obtain a
+modular result without overflow. The largest representable IM integer is
+MBASE**NDIGMX - 1. For example, if MBASE is 10**7 and NDIGMX is set to 256,
+integers less than 10**1792 can be used.
+
+
+6. OTHER OPTIONS
+
+KRAD = 0 All angles in the trigonometric functions and inverse functions
+ are measured in degrees.
+ = 1 All angles are measured in radians. (Default)
+
+KROUND = -1 All results are rounded toward minus infinity.
+ = 0 All results are rounded toward zero (chopped).
+ = 1 All results are rounded to the nearest FM number, or to the
+ value with an even last digit if the result is halfway
+ between two FM numbers. (Default)
+ = 2 All results are rounded toward plus infinity.
+
+ In all cases, while a function is being computed all intermediate
+ results are rounded to nearest, with only the final result being
+ rounded according to KROUND.
+
+KRPERF = 0 A smaller number of guard digits used, to give nearly perfect
+ rounding. This number is chosen so that the last intermediate
+ result should have error less than 0.001 unit in the last place
+ of the final rounded result. (Default)
+ = 1 Causes more guard digits to be used, to get perfect rounding in
+ the mode set by KROUND. This slows execution speed.
+
+ If a small base is used for the arithmetic, like MBASE = 2, 10, or 16,
+ FM assumes that the arithmetic hardware for some machine is being
+ simulated, so perfect rounding is done without regard for the value
+ of KRPERF.
+ If KROUND = 1, then KRPERF = 1 means returned results are no more than
+ 0.500 units in the last place from the exact mathematical result,
+ versus 0.501 for KRPERF = 0.
+ If KROUND is not 1, then KRPERF = 1 means returned results are no more
+ than 1.000 units in the last place from the exact mathematical result,
+ versus 1.001 for KRPERF = 0.
+
+KSWIDE defines the maximum screen width to be used for all unit KW output.
+ Default is 80.
+
+KESWCH controls the action taken in FMINP and other input routines for
+ strings like 'E7' that have no digits before the exponent field.
+ This is sometimes a convenient abbreviation when doing interactive
+ keyboard input.
+ KESWCH = 1 causes 'E7' to translate like '1.0E+7'. (Default)
+ KESWCH = 0 causes 'E7' to translate like '0.0E+7' and give 0.
+
+CMCHAR defines the exponent letter to be used for FM variable output.
+ Default is 'M', as in 1.2345M+678.
+ Change it to 'E' for output to be read by a non-FM program.
+
+KDEBUG = 0 No error checking is done to see if input arguments are valid
+ and parameters like NDIG and MBASE are correct upon entry to
+ each routine. (Default)
+ = 1 Some error checking is done. (Slower speed)
+
+See module FMVALS in file FMSAVE.f90 for additional description of these and
+other variables defining various FM conditions.
+
+
+7. ARRAY DIMENSIONS
+
+The dimensions of the arrays in the FM package are defined using parameters
+NDIGMX and NBITS.
+NDIGMX is the maximum value the user may set for NDIG.
+NBITS is the number of bits used to represent integers for a given machine.
+ See the EFFICIENCY discussion below.
+
+The standard version of FM sets NDIGMX = 55, so on a 32-bit machine using
+MBASE = 10**7 the maximum precision is about 7*54+1 = 379 significant
+digits. Previous versions of FM set NDIGMX = 256. Two reasons for making
+this change are:
+(a) Almost all applications using FM use only 30 to 50 significant digits
+ for checking double or quadruple precision results, and the larger
+ arrays are wasted space.
+(b) Most FM applications use the derived type interface so that the number
+ of changes to existing code is minimized. Many compilers implement the
+ FM interface by doing copy in / copy out argument passing of the derived
+ types. Copying the entire large array when only a small part of it is
+ being used causes the derived type arithmetic to be slow compared to
+ making direct calls to the subroutines. Setting NDIGMX to be only
+ slightly higher than a program actually uses minimizes any performance
+ penalty for the derived type arithmetic.
+
+To change dimensions so that 10,000 significant digit calculation can be
+done, NDIGMX needs to be at least 10**4/7 + 5 = 1434. This allows for a
+few user guard digits to be defined when the precision is changed using
+CALL FMSET(10000). Changing 'NDIGMX = 55' to 'NDIGMX = 1434' in FMSAVE.f90
+will define all the new array sizes.
+
+If NDIG much greater than 256 is to be used and elementary functions will
+be needed, they will be faster if array MJSUMS is larger. The parameter
+defining the size of MJSUMS is set in the standard version by
+ LJSUMS = 8*(LUNPCK+2)
+The 8 means that up to eight concurrent sums can be used by the elementary
+functions. The approximate number needed for best speed is given by
+ 0.051*Log(MBASE)*NDIG**0.333 + 1.85
+For example, with MBASE=10**7 and NDIG=1434 this gives 11. Changing
+'LJSUMS = 8*(LUNPCK+2)' to 'LJSUMS = 11*(LUNPCK+2)' in FMSAVE.f90 will give
+slightly better speed.
+
+FM numbers in packed format have dimension -1:LPACK, and those in unpacked
+format have dimension -1:LUNPCK.
+
+The parameters LPACKZ and LUNPKZ define the size of the packed and unpacked
+ZM arrays. The real part starts at the beginning of the array, and the
+imaginary part starts at word KPTIMP for packed format or at word KPTIMU for
+unpacked format.
+
+
+8. PORTABILITY
+
+In FMSET several variables are set to machine-dependent values, and many of
+the variables initialized in module FMVALS in file FMSAVE.f90 are checked to
+see that they have reasonable values. FMSET will print warning messages on
+unit KW for any of the FMVALS variables that seem to be poorly initialized.
+
+If an FM run fails, call FMVARS to get a list of all the FMVALS variables
+printed on unit KW. Setting KDEBUG = 1 at the start may also identify some
+errors.
+
+Some compilers object to a function like FMCOMP with side effects such as
+changing KFLAG or other module variables. Blocks of code in FMCOMP and
+IMCOMP that modify these variables are identified so they may be removed or
+commented out to produce a function without side effects. This disables
+trace printing in FMCOMP and IMCOMP, and error codes are not returned in
+KFLAG. See FMCOMP and IMCOMP for further details.
+
+In FMBER2 and FMPGAM several constants are used that require the machine's
+integer word size to be at least 32 bits.
+
+
+9. LIST OF ROUTINES - Shown after section 11 below.
+
+
+10. NEW FOR VERSION 1.2
+
+Version 1.2 is written in Fortran-90 free source format.
+
+The routines for the Gamma function and related mathematical special
+functions are new in version 1.2.
+
+Several new derived-type function interfaces are included in module FMZM in
+file FMZM90.f90, such as integer multiple precision operations GCD, modular
+multiplication, and modular powers. There are also formatting functions and
+function interfaces for the Gamma and related special functions.
+
+Two new rounding modes have been added, round toward -infinity and round
+toward +infinity. See the description of KROUND above.
+An option has been added to force more guard digits to be used, so that basic
+arithmetic operations will always round perfectly. See the description of
+KRPERF above.
+These options are included for applications that use FM to check IEEE
+hardware arithmetic. They are not normally useful for most multiple
+precision calculations.
+
+The random number routine FM_RANDOM_NUMBER uses 49-digit prime numbers in a
+shuffled multiplicative congruential generator. Historically, some popular
+random number routines tried so hard for maximum speed that they were later
+found to fail some tests for randomness. FM_RANDOM_NUMBER tries to return
+high-quality random values. It is much slower than other generators, but can
+return about 60,000 numbers per second on a 400 MHz single-processor machine.
+This is usually fast enough to be used as a check for suspicious monte carlo
+results from other generators.
+For more details, see the comments in the routine.
+
+The arrays for multiple precision numbers were dimensioned starting at 0 in
+version 1.1, and now begin at -1. Array(-1) now holds the sign of the number
+instead of combining the sign with Array(2) as before. The reason for moving
+the sign bit is that many of the original routines, written before Fortran-90
+existed, simplified the logic by temporarily making input arguments positive,
+working with positive values, then restoring the signs to the input arguments
+upon return. This became illegal under Fortran-90 when used with the derived
+type interface, which demands the inputs to functions for arithmetic operator
+overloading be declared with INTENT(IN).
+
+The common blocks of earlier versions have been replaced by module FMVALS.
+This makes it easier to hide the FM internal variable names from the calling
+program, and these variables can be initialized in the module so the
+initializing call to FMSET is no longer mandatory. Several new routines are
+provided to set or return the values for some of these variables. See the
+descriptions for FMSETVAR, FMFLAG, and FMVARS above.
+
+Version 1.0 used integer arrays and integer arithmetic internally to perform
+the multiple precision operations. Later versions use double precision
+arithmetic and arrays internally. This is usually faster at higher
+precisions, and on many machines it is also faster at lower precisions.
+Version 1.2 is written so that the arithmetic used can easily be changed from
+double precision to integer, or any other available arithmetic type. This
+permits the user to make the best use of a given machine's arithmetic
+hardware. See the EFFICIENCY discussion below.
+
+
+11. EFFICIENCY
+
+When the derived type interface is used to access the FM routines, there may
+be a loss of speed if the arrays used to define the multiple precision data
+types are larger than necessary. See comment (b) in the section above on
+array dimensions.
+
+To take advantage of hardware architecture on different machines, the package
+has been designed so that the arithmetic used to perform the multiple
+precision operations can easily be changed. All variables that must be
+changed to get a different arithmetic have names beginning with 'M' and are
+declared using REAL (KIND(1.0D0)) ...
+
+For example, to change the package to use integer arithmetic internally, make
+these two changes everywhere in the FM.f90 file.
+Change 'REAL (KIND(1.0D0))' to 'INTEGER'.
+Change 'AINT (' to 'INT('. Note the blank between AINT and (.
+On some systems, changing 'AINT (' to '(' may give better speed.
+
+In most places in FM, an AINT function is not supposed to be changed. These
+are written 'AINT(', with no embedded blank, so they will not be changed by
+the global change above.
+
+The first of these changes must also be made throughout the files FMZM90.f90
+and FMSAVE.f90.
+Change 'REAL (KIND(1.0D0))' to 'INTEGER'.
+
+Many of the variables in FMSAVE.f90 are initialized when they are declared,
+so the initialization values should be changed to integer values.
+Find the lines beginning '! Integer initialization' in file FMSAVE.f90 and
+change the values. The values needed for 32-bit integer arithmetic are next
+to the double precision values, but commented out. In every case, the line
+before the '! Integer initialization' should have '!' inserted in column 1
+and the line after should have the '!' removed from column 1. If a different
+wordsize is used, the first call to FMSET will check the values defined in
+file FMSAVE.f90 and write messages (on unit KW) if any need to be changed.
+
+When changing to a different type of arithmetic, any FM arrays in the user's
+program must be changed to agree. If derived types are used instead of
+direct calls, no changes should be needed in the calling program.
+
+For example, in the test program TestFM.f90, change all
+'REAL (KIND(1.0D0))' to 'INTEGER', as with the other files.
+
+This version of FM restricts the base used to be also representable in
+integer variables, so using precision above double usually does not save much
+time unless integers can also be declared at a higher precision. Using IEEE
+Extended would allow a base of around 10**9 to be chosen, but the delayed
+digit-normalization method used for multiplication and division means that a
+slightly smaller base like 10**8 would probably run faster. This would
+usually not be much faster than using the usual base 10**7 with double
+precision.
+
+The value of NBITS defined as a parameter in FMVALS refers to the number of
+bits used to represent integers in an M-variable word. Typical values for
+NBITS are: 24 for IEEE single precision, 32 for integer, 53 for IEEE double
+precision. NBITS controls only array size, so setting it too high is ok, but
+then the program will use slightly more memory than necessary.
+
+For cases where special compiler directives or minor re-writing of the code
+may improve speed, several of the most important loops in FM are identified
+by comments containing the string '(Inner Loop)'.
+
+
+
+--------------------------------------------------------------------------------
+--------------- Routines for Real Floating-Point Operations ----------------
+
+
+
+These are the FM routines that are designed to be called by the user.
+All are subroutines except logical function FMCOMP.
+MA, MB, MC refer to FM format numbers.
+
+In Fortran-90 and later versions of the Fortran standard, it is potentially
+unsafe to use the same array more than once in the calling sequence. The
+operation MA = MA + MB should not be written as
+ CALL FMADD(MA,MB,MA)
+since the compiler is allowed to pass the three arguments with a copy in /
+copy out mechanism. This means the third argument, containing the result,
+might not be copied out last, and then a later copy out of the original
+input MA could destroy the computed result.
+
+One solution is to use a third array and then put the result back in MA:
+ CALL FMADD(MA,MB,MC)
+ CALL FMEQ(MC,MA)
+
+When the first call is doing one of the "fast" operations like addition,
+the extra call to move the result back to MA can cause a noticeable loss
+in efficiency. To avoid this, separate routines are provided for the basic
+arithmetic operations when the result is to be returned in the same array
+as one of the inputs.
+
+A routine name with a suffix of "_R1" returns the result in the first input
+array, and a suffix of "_R2" returns the result in the second input array.
+The example above would then be:
+ CALL FMADD_R1(MA,MB)
+
+These routines each have one less argument than the original version, since
+the output is re-directed to one of the inputs. The result array should not
+be the same as any input array when the original version of the routine is
+used.
+
+The routines that can be used this way are listed below. For others, like
+ CALL FMEXP(MA,MA)
+the relative cost of doing an extra copy is small. This one should become
+ CALL FMEXP(MA,MB)
+ CALL FMEQ(MB,MA)
+
+If the derived-type interface is used, as in
+ TYPE (FM) A,B
+ ...
+ A = A + B
+there is no problem putting the result back into A, since the interface routine
+creates a temporary scratch array for the result of A + B, allowing copy in /
+copy out to work.
+
+For each of these routines there is also a version available for which the
+argument list is the same but all FM numbers are in packed format. The
+routines using packed numbers have the same names except 'FM' is replaced by
+'FP' at the start of each name.
+
+
+FMABS(MA,MB) MB = ABS(MA)
+
+FMACOS(MA,MB) MB = ACOS(MA)
+
+FMADD(MA,MB,MC) MC = MA + MB
+
+FMADD_R1(MA,MB) MA = MA + MB
+
+FMADD_R2(MA,MB) MB = MA + MB
+
+FMADDI(MA,IVAL) MA = MA + IVAL Increment an FM number by a one word
+ integer. Note this call does not have
+ an "MB" result like FMDIVI and FMMPYI.
+
+FMASIN(MA,MB) MB = ASIN(MA)
+
+FMATAN(MA,MB) MB = ATAN(MA)
+
+FMATN2(MA,MB,MC) MC = ATAN2(MA,MB)
+
+FMBIG(MA) MA = Biggest FM number less than overflow.
+
+FMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA).
+ Faster than making two separate calls.
+
+FMCOMP(MA,LREL,MB) Logical comparison of MA and MB.
+ LREL is a CHARACTER*2 value identifying
+ which of the six comparisons is to be made.
+ Example: IF (FMCOMP(MA,'GE',MB)) ...
+ Also can be: IF (FMCOMP(MA,'>=',MB)) ...
+ CHARACTER*1 is ok: IF (FMCOMP(MA,'>',MB)) ...
+
+FMCONS Set several saved constants that depend on MBASE,
+ the base being used. FMCONS should be called
+ immediately after changing MBASE.
+
+FMCOS(MA,MB) MB = COS(MA)
+
+FMCOSH(MA,MB) MB = COSH(MA)
+
+FMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA).
+ Faster than making two separate calls.
+
+FMDIG(NSTACK,KST) Find a set of precisions to use during Newton
+ iteration for finding a simple root starting with
+ about double precision accuracy.
+
+FMDIM(MA,MB,MC) MC = DIM(MA,MB)
+
+FMDIV(MA,MB,MC) MC = MA / MB
+
+FMDIV_R1(MA,MB) MA = MA / MB
+
+FMDIV_R2(MA,MB) MB = MA / MB
+
+FMDIVI(MA,IVAL,MB) MB = MA/IVAL IVAL is a one word integer.
+
+FMDIVI_R1(MA,IVAL) MA = MA/IVAL
+
+FMDP2M(X,MA) MA = X Convert from double precision to FM.
+
+FMDPM(X,MA) MA = X Convert from double precision to FM.
+ Faster than FMDP2M, but MA agrees with X only
+ to D.P. accuracy. See the comments in the
+ two routines.
+
+FMEQ(MA,MB) MB = MA Both have precision NDIG.
+ This is the version to use for standard
+ B = A statements.
+
+FMEQU(MA,MB,NA,NB) MB = MA Version for changing precision.
+ MA has NA digits (i.e., MA was computed
+ using NDIG = NA), and MB will be defined
+ having NB digits.
+ MB is rounded if NB < NA
+ MB is zero-padded if NB > NA
+
+FMEXP(MA,MB) MB = EXP(MA)
+
+FMFLAG(K) K = KFLAG get the value of the FM condition
+ flag -- stored in the internal FM
+ variable KFLAG in module FMVALS.
+
+FMFORM(FORM,MA,STRING) MA is converted to a character string using format
+ FORM and returned in STRING. FORM can represent
+ I, F, E, or 1PE formats. Example:
+ CALL FMFORM('F60.40',MA,STRING)
+
+FMFPRT(FORM,MA) Print MA on unit KW using FORM format.
+
+FMI2M(IVAL,MA) MA = IVAL Convert from one word integer to FM.
+
+FMINP(LINE,MA,LA,LB) MA = LINE Input conversion.
+ Convert LINE(LA) through LINE(LB)
+ from characters to FM.
+
+FMINT(MA,MB) MB = INT(MA) Integer part of MA.
+
+FMIPWR(MA,IVAL,MB) MB = MA**IVAL Raise an FM number to a one word
+ integer power.
+
+FMLG10(MA,MB) MB = LOG10(MA)
+
+FMLN(MA,MB) MB = LOG(MA)
+
+FMLNI(IVAL,MA) MA = LOG(IVAL) Natural log of a one word integer.
+
+FMM2DP(MA,X) X = MA Convert from FM to double precision.
+
+FMM2I(MA,IVAL) IVAL = MA Convert from FM to integer.
+
+FMM2SP(MA,X) X = MA Convert from FM to single precision.
+
+FMMAX(MA,MB,MC) MC = MAX(MA,MB)
+
+FMMIN(MA,MB,MC) MC = MIN(MA,MB)
+
+FMMOD(MA,MB,MC) MC = MA mod MB
+
+FMMPY(MA,MB,MC) MC = MA * MB
+
+FMMPY_R1(MA,MB) MA = MA * MB
+
+FMMPY_R2(MA,MB) MB = MA * MB
+
+FMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer.
+
+FMMPYI_R1(MA,IVAL) MA = MA*IVAL
+
+FMNINT(MA,MB) MB = NINT(MA) Nearest FM integer.
+
+FMOUT(MA,LINE,LB) LINE = MA Convert from FM to character.
+ LINE is a character array of length LB.
+
+FMPI(MA) MA = pi
+
+FMPRNT(MA) Print MA on unit KW using current format.
+
+FMPWR(MA,MB,MC) MC = MA**MB
+
+FM_RANDOM_NUMBER(X) X is returned as a double precision random number,
+ uniform on (0,1). High-quality, long-period
+ generator.
+ Note that X is double precision, unlike the similar
+ Fortran intrinsic random number routine, which
+ returns a single-precision result.
+ See the comments in section 10 below and also those
+ in the routine for more details.
+
+FMREAD(KREAD,MA) MA is returned after reading one (possibly multi-line)
+ FM number on unit KREAD. This routine reads
+ numbers written by FMWRIT.
+
+FMRPWR(MA,K,J,MB) MB = MA**(K/J) Rational power.
+ Faster than FMPWR for functions like the cube root.
+
+FMSET(NPREC) Set the internal FM variables so that the precision
+ is at least NPREC base 10 digits plus three base 10
+ guard digits.
+
+FMSETVAR(STRING) Define a new value for one of the internal FM
+ variables in module FMVALS that controls one of the
+ FM options. STRING has the form variable = value.
+ Example: To change the screen width for FM output:
+ CALL FMSETVAR(' KSWIDE = 120 ')
+ The variables that can be changed and the options
+ they control are listed in sections 2 through 6
+ above. Only one variable can be set per call.
+ The variable name in STRING must have no embedded
+ blanks. The value part of STRING can be in any
+ numerical format, except in the case of variable
+ CMCHAR, which is character type. To set CMCHAR to
+ 'E', don't use any quotes in STRING:
+ CALL FMSETVAR(' CMCHAR = E ')
+
+FMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer.
+
+FMSIN(MA,MB) MB = SIN(MA)
+
+FMSINH(MA,MB) MB = SINH(MA)
+
+FMSP2M(X,MA) MA = X Convert from single precision to FM.
+
+FMSQR(MA,MB) MB = MA * MA Faster than FMMPY.
+
+FMSQR_R1(MA) MA = MA * MA
+
+FMSQRT(MA,MB) MB = SQRT(MA)
+
+FMSQRT_R1(MA) MA = SQRT(MA)
+
+FMST2M(STRING,MA) MA = STRING
+ Convert from character string to FM.
+ STRING may be in any numerical format.
+ Often more convenient than FMINP, which converts
+ an array of CHARACTER*1 values. Example:
+ CALL FMST2M('123.4',MA)
+
+FMSUB(MA,MB,MC) MC = MA - MB
+
+FMSUB_R1(MA,MB) MA = MA - MB
+
+FMSUB_R2(MA,MB) MB = MA - MB
+
+FMTAN(MA,MB) MB = TAN(MA)
+
+FMTANH(MA,MB) MB = TANH(MA)
+
+FMULP(MA,MB) MB = One Unit in the Last Place of MA.
+
+FMVARS Write the current values of the internal FM
+ variables on unit KW.
+
+FMWRIT(KWRITE,MA) Write MA on unit KWRITE.
+ Multi-line numbers will have '&' as the last
+ nonblank character on all but the last line. These
+ numbers can then be read easily using FMREAD.
+
+
+
+These are the Gamma and Related Functions.
+
+FMBERN(N,MA,MB) MB = MA*B(N) Multiply by Nth Bernoulli number
+
+FMBETA(MA,MB,MC) MC = Beta(MA,MB)
+
+FMCOMB(MA,MB,MC) MC = Combination MA choose MB (Binomial coeff.)
+
+FMEULR(MA) MA = Euler's constant ( 0.5772156649... )
+
+FMFACT(MA,MB) MB = MA Factorial (Gamma(MA+1))
+
+FMGAM(MA,MB) MB = Gamma(MA)
+
+FMIBTA(MX,MA,MB,MC) MC = Incomplete Beta(MX,MA,MB)
+
+FMIGM1(MA,MB,MC) MC = Incomplete Gamma(MA,MB). Lower case Gamma(a,x)
+
+FMIGM2(MA,MB,MC) MC = Incomplete Gamma(MA,MB). Upper case Gamma(a,x)
+
+FMLNGM(MA,MB) MB = Ln(Gamma(MA))
+
+FMPGAM(N,MA,MB) MB = Polygamma(N,MA) (Nth derivative of Psi)
+
+FMPOCH(MA,N,MB) MB = MA*(MA+1)*(MA+2)*...*(MA+N-1) (Pochhammer)
+
+FMPSI(MA,MB) MB = Psi(MA) (Derivative of Ln(Gamma(MA))
+
+
+
+
+--------------------------------------------------------------------------------
+--------------------- Routines for Integer Operations ----------------------
+
+
+
+These are the integer routines that are designed to be called by the user.
+All are subroutines except logical function IMCOMP. MA, MB, MC refer to IM
+format numbers. In each case the version of the routine to handle packed IM
+numbers has the same name, with 'IM' replaced by 'IP'.
+
+IMABS(MA,MB) MB = ABS(MA)
+
+IMADD(MA,MB,MC) MC = MA + MB
+
+IMBIG(MA) MA = Biggest IM number less than overflow.
+
+IMCOMP(MA,LREL,MB) Logical comparison of MA and MB.
+ LREL is a CHARACTER*2 value identifying which of
+ the six comparisons is to be made.
+ Example: IF (IMCOMP(MA,'GE',MB)) ...
+ Also can be: IF (IMCOMP(MA,'>=',MB))
+ CHARACTER*1 is ok: IF (IMCOMP(MA,'>',MB)) ...
+
+IMDIM(MA,MB,MC) MC = DIM(MA,MB)
+
+IMDIV(MA,MB,MC) MC = int(MA/MB)
+ Use IMDIVR if the remainder is also needed.
+
+IMDIVI(MA,IVAL,MB) MB = int(MA/IVAL)
+ IVAL is a one word integer.
+ Use IMDVIR to get the remainder also.
+
+IMDIVR(MA,MB,MC,MD) MC = int(MA/MB), MD = MA mod MB
+ When both the quotient and remainder are needed,
+ this routine is twice as fast as calling both
+ IMDIV and IMMOD.
+
+IMDVIR(MA,IVAL,MB,IREM) MB = int(MA/IVAL), IREM = MA mod IVAL
+ IVAL and IREM are one word integers.
+
+IMEQ(MA,MB) MB = MA
+
+IMFM2I(MAFM,MB) MB = MAFM Convert from real (FM) format to
+ integer (IM) format.
+
+IMFORM(FORM,MA,STRING) MA is converted to a character string using format
+ FORM and returned in STRING. FORM can represent
+ I, F, E, or 1PE formats. Example:
+ CALL IMFORM('I70',MA,STRING)
+
+IMFPRT(FORM,MA) Print MA on unit KW using FORM format.
+
+IMGCD(MA,MB,MC) MC = greatest common divisor of MA and MB.
+
+IMI2FM(MA,MBFM) MBFM = MA Convert from integer (IM) format to
+ real (FM) format.
+
+IMI2M(IVAL,MA) MA = IVAL Convert from one word integer to IM.
+
+IMINP(LINE,MA,LA,LB) MA = LINE Input conversion.
+ Convert LINE(LA) through LINE(LB)
+ from characters to IM.
+
+IMM2DP(MA,X) X = MA Convert from IM to double precision.
+
+IMM2I(MA,IVAL) IVAL = MA Convert from IM to one word integer.
+
+IMMAX(MA,MB,MC) MC = MAX(MA,MB)
+
+IMMIN(MA,MB,MC) MC = MIN(MA,MB)
+
+IMMOD(MA,MB,MC) MC = MA mod MB
+
+IMMPY(MA,MB,MC) MC = MA*MB
+
+IMMPYI(MA,IVAL,MB) MB = MA*IVAL Multiply by a one word integer.
+
+IMMPYM(MA,MB,MC,MD) MD = MA*MB mod MC
+ Slightly faster than calling IMMPY and IMMOD
+ separately, and it works for cases where IMMPY
+ would return OVERFLOW.
+
+IMOUT(MA,LINE,LB) LINE = MA Convert from IM to character.
+ LINE is a character array of length LB.
+
+IMPMOD(MA,MB,MC,MD) MD = MA**MB mod MC
+
+IMPRNT(MA) Print MA on unit KW.
+
+IMPWR(MA,MB,MC) MC = MA**MB
+
+IMREAD(KREAD,MA) MA is returned after reading one (possibly multi-line)
+ IM number on unit KREAD.
+ This routine reads numbers written by IMWRIT.
+
+IMSIGN(MA,MB,MC) MC = SIGN(MA,MB) Sign transfer.
+
+IMSQR(MA,MB) MB = MA*MA Faster than IMMPY.
+
+IMST2M(STRING,MA) MA = STRING
+ Convert from character string to IM.
+ Often more convenient than IMINP, which converts an
+ array of CHARACTER*1 values. Example:
+ CALL IMST2M('12345678901',MA)
+
+IMSUB(MA,MB,MC) MC = MA - MB
+
+IMWRIT(KWRITE,MA) Write MA on unit KWRITE.
+ Multi-line numbers will have '&' as the last nonblank
+ character on all but the last line.
+ These numbers can then be read easily using IMREAD.
+
+
+
+
+--------------------------------------------------------------------------------
+-------------- Routines for Complex Floating-Point Operations --------------
+
+
+
+These are the complex routines that are designed to be called by the user.
+All are subroutines, and in each case the version of the routine to handle
+packed ZM numbers has the same name, with 'ZM' replaced by 'ZP'.
+
+MA, MB, MC refer to ZM format complex numbers.
+MAFM, MBFM, MCFM refer to FM format real numbers.
+INTEG is a Fortran INTEGER variable.
+ZVAL is a Fortran COMPLEX variable.
+
+ZMABS(MA,MBFM) MBFM = ABS(MA) Result is real.
+
+ZMACOS(MA,MB) MB = ACOS(MA)
+
+ZMADD(MA,MB,MC) MC = MA + MB
+
+ZMADDI(MA,INTEG) MA = MA + INTEG Increment an ZM number by a one word
+ integer. Note this call does not have
+ an "MB" result like ZMDIVI and ZMMPYI.
+
+ZMARG(MA,MBFM) MBFM = Argument(MA) Result is real.
+
+ZMASIN(MA,MB) MB = ASIN(MA)
+
+ZMATAN(MA,MB) MB = ATAN(MA)
+
+ZMCHSH(MA,MB,MC) MB = COSH(MA), MC = SINH(MA).
+ Faster than 2 calls.
+
+ZMCMPX(MAFM,MBFM,MC) MC = CMPLX(MAFM,MBFM)
+
+ZMCONJ(MA,MB) MB = CONJG(MA)
+
+ZMCOS(MA,MB) MB = COS(MA)
+
+ZMCOSH(MA,MB) MB = COSH(MA)
+
+ZMCSSN(MA,MB,MC) MB = COS(MA), MC = SIN(MA).
+ Faster than 2 calls.
+
+ZMDIV(MA,MB,MC) MC = MA / MB
+
+ZMDIVI(MA,INTEG,MB) MB = MA / INTEG
+
+ZMEQ(MA,MB) MB = MA
+
+ZMEQU(MA,MB,NDA,NDB) MB = MA Version for changing precision.
+ (NDA and NDB are as in FMEQU)
+
+ZMEXP(MA,MB) MB = EXP(MA)
+
+ZMFORM(FORM1,FORM2,MA,STRING) STRING = MA
+ MA is converted to a character string using format
+ FORM1 for the real part and FORM2 for the imaginary
+ part. The result is returned in STRING. FORM1 and
+ FORM2 can represent I, F, E, or 1PE formats. Example:
+ CALL ZMFORM('F20.10','F15.10',MA,STRING)
+ A 1PE in the first format does not carry over to the
+ other format descriptor, as it would in an ordinary
+ FORMAT statement.
+
+ZMFPRT(FORM1,FORM2,MA) Print MA on unit KW using formats FORM1 and FORM2.
+
+ZMI2M(INTEG,MA) MA = CMPLX(INTEG,0)
+
+ZM2I2M(INTEG1,INTEG2,MA) MA = CMPLX(INTEG1,INTEG2)
+
+ZMIMAG(MA,MBFM) MBFM = IMAG(MA) Imaginary part.
+
+ZMINP(LINE,MA,LA,LB) MA = LINE Input conversion.
+ Convert LINE(LA) through LINE(LB) from
+ characters to ZM. LINE is a character array
+ of length at least LB.
+
+ZMINT(MA,MB) MB = INT(MA) Integer part of both Real
+ and Imaginary parts of MA.
+
+ZMIPWR(MA,INTEG,MB) MB = MA ** INTEG Integer power function.
+
+ZMLG10(MA,MB) MB = LOG10(MA)
+
+ZMLN(MA,MB) MB = LOG(MA)
+
+ZMM2I(MA,INTEG) INTEG = INT(REAL(MA))
+
+ZMM2Z(MA,ZVAL) ZVAL = MA
+
+ZMMPY(MA,MB,MC) MC = MA * MB
+
+ZMMPYI(MA,INTEG,MB) MB = MA * INTEG
+
+ZMNINT(MA,MB) MB = NINT(MA) Nearest integer of both Real
+ and Imaginary.
+
+ZMOUT(MA,LINE,LB,LAST1,LAST2) LINE = MA
+ Convert from FM to character.
+ LINE is the returned character*1 array.
+ LB is the dimensioned size of LINE.
+ LAST1 is returned as the position in LINE of
+ the last character of REAL(MA).
+ LAST2 is returned as the position in LINE
+ of the last character of AIMAG(MA).
+
+ZMPRNT(MA) Print MA on unit KW using current format.
+
+ZMPWR(MA,MB,MC) MC = MA ** MB
+
+ZMREAD(KREAD,MA) MA is returned after reading one (possibly multi-line)
+ ZM number on unit KREAD.
+ This routine reads numbers written by ZMWRIT.
+
+ZMREAL(MA,MBFM) MBFM = REAL(MA) Real part.
+
+ZMRPWR(MA,IVAL,JVAL,MB) MB = MA ** (IVAL/JVAL)
+
+ZMSET(NPREC) Set precision to the equivalent of a few more than NPREC
+ base 10 digits. This is now the same as FMSET, but is
+ retained for compatibility with earlier versions of the
+ package.
+
+ZMSIN(MA,MB) MB = SIN(MA)
+
+ZMSINH(MA,MB) MB = SINH(MA)
+
+ZMSQR(MA,MB) MB = MA*MA Faster than ZMMPY.
+
+ZMSQRT(MA,MB) MB = SQRT(MA)
+
+ZMST2M(STRING,MA) MA = STRING
+ Convert from character string to ZM.
+ Often more convenient than ZMINP, which
+ converts an array of CHARACTER*1 values.
+ Example: CALL ZMST2M('123.4+5.67i',MA).
+
+ZMSUB(MA,MB,MC) MC = MA - MB
+
+ZMTAN(MA,MB) MB = TAN(MA)
+
+ZMTANH(MA,MB) MB = TANH(MA)
+
+ZMWRIT(KWRITE,MA) Write MA on unit KWRITE. Multi-line numbers are
+ formatted for automatic reading with ZMREAD.
+
+ZMZ2M(ZVAL,MA) MA = ZVAL
+
+
+
+================================================================================
+================================================================================
diff --git a/src/fmlib/SAMPLE.CHK b/src/fmlib/SAMPLE.CHK
new file mode 100644
index 0000000000000000000000000000000000000000..bd84e0610eda4fe06e51ab45d985c3ad5a438d95
--- /dev/null
+++ b/src/fmlib/SAMPLE.CHK
@@ -0,0 +1,107 @@
+
+
+ Sample 1. Real root of f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.
+
+
+ Iteration Newton Approximation
+
+ 0 3.120000000000000000000000000000000000000000000000000000000000
+
+ 1 3.120656718532108533919391265947916793506741449899073468862023
+
+ 2 3.120656215327022122238354686569835883519704471397219749798884
+
+ 3 3.120656215326726500470956115551705969611230193197937042123082
+
+ 4 3.120656215326726500470956013523797484654623935599078168006617
+
+ 5 3.120656215326726500470956013523797484654623935599066014988828
+
+ 6 3.120656215326726500470956013523797484654623935599066014988828
+
+
+
+ Sample 2. Find the root above to 300 decimal places.
+
+ 3.12065621532672650047095601352379748465462393559906601498882843581902649995179546
+ 89783257450017151095811923431332682839420040840535954560118152245371792881305271951
+ 01711893889821240366205830730398354737691328200011005827350420283867070989561927541
+ 348452154928259189115694520078941581838752951201099960
+
+
+
+ Sample 3. 109 terms were added in the Zeta sum
+
+ Zeta(3) = 1.202056903159594285399738161511449990764986292340498881792272
+
+
+
+ Sample 4. 57 values were checked before finding a prime p.
+
+ p = 5468317884572019103692012212053793153845065543480825746529998049913561
+
+
+
+ Sample 5. Check that Gamma(1/2) = Sqrt(pi)
+
+ Gamma(1/2) = 1.772453850905516027298167483341145182797549456122387128213808
+
+
+
+ Sample 6. Psi and Polygamma functions.
+
+ Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) =
+ .013499486145413024755107829105035147950644978635837270816327
+
+
+
+ Sample 7. Incomplete gamma and Gamma functions.
+
+ Probability = .19373313011487144632751025918250599953472318607121386973066
+
+
+
+ Sample 8. Complex root of f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.
+
+
+ Iteration Newton Approximation
+
+ 0 .560000000000000000000000000000 + 1.060000000000000000000000000000 i
+
+ 1 .561964780980333719745880263787 + 1.061135231152741154895778904059 i
+
+ 2 .561958308372772219534516409947 + 1.061134679566247415769456345141 i
+
+ 3 .561958308335403235495113920123 + 1.061134679604332556981397796290 i
+
+ 4 .561958308335403235498111195347 + 1.061134679604332556983391239059 i
+
+ 5 .561958308335403235498111195347 + 1.061134679604332556983391239059 i
+
+
+
+ Sample 9. 44 terms were added to get Exp(1.23-2.34i)
+
+ Result= -2.379681796854777515745457977697 - 2.458032970832342652397461908326 i
+
+
+
+ Sample 10. Exception handling.
+
+ Iterate Exp(x) starting at 1.0 until overflow occurs.
+
+
+ Iteration 1 2.718281828459045235360287471352662497757M+0
+
+ Iteration 2 1.515426224147926418976043027262991190553M+1
+
+ Iteration 3 3.814279104760220592209219594098203571024M+6
+
+ Iteration 4 2.331504399007195462289689911012137666332M+1656520
+
+ Iteration 5 + OVERFLOW
+
+ Overflow was correctly detected.
+
+
+ All results were ok.
diff --git a/src/fmlib/SampleFM.F90 b/src/fmlib/SampleFM.F90
new file mode 100644
index 0000000000000000000000000000000000000000..4753d33cc058921cbe81f0f98fa71360ebde6762
--- /dev/null
+++ b/src/fmlib/SampleFM.F90
@@ -0,0 +1,639 @@
+ PROGRAM SAMPLE
+
+! David M. Smith
+
+! This is a sample program using the FM Fortran-90 modules for
+! doing arithmetic using the FM, IM, and ZM derived types.
+
+! The output is saved in file SAMPLE.LOG. A comparison file,
+! SAMPLE.CHK, is provided showing the expected output from 32-bit
+! (IEEE arithmetic) machines. When run on other computers, all the
+! numerical results should still be the same, but the number of terms
+! needed for some of the results might be slightly different. The
+! program checks all the results and the last line of the log file
+! should be "All results were ok."
+
+! In a few places, an explicit call is made to an FM or ZM routine.
+! For a call like CALL FM_FORM('F65.60',MAFM,ST1), note that the
+! "FM_" form is used since MAFM is a TYPE (FM) variable and not just
+! an array. See the discussion in FMZM90.f.
+
+
+ USE FMZM
+
+ IMPLICIT NONE
+
+ TYPE ( FM ) MAFM,MBFM,MCFM,MDFM
+ TYPE ( IM ) MAIM,MBIM,MCIM
+ TYPE ( ZM ) MAZM,MBZM,MCZM,MDZM
+
+ CHARACTER(80) :: ST1
+ CHARACTER(175) :: FMT
+ INTEGER ITER,J,K,KLOG,LFLAG,NERROR
+ INTEGER SEED(7)
+ DOUBLE PRECISION VALUE
+
+! Write output to the screen (unit *), and also to the
+! file SAMPLE.LOG.
+
+ KLOG = 18
+ OPEN (KLOG,FILE='SAMPLE.LOG')
+
+ NERROR = 0
+
+
+! 1. Find a root of the equation
+! f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.
+
+! Set precision to give at least 60 significant digits.
+
+ CALL FM_SET(60)
+
+! Use Newton's method with initial guess x = 3.12.
+! This version is not tuned for speed. See the FMSQRT
+! routine for possible ways to increase speed.
+! Horner's rule is used to evaluate the function.
+
+! MAFM is the previous iterate.
+! MBFM is the current iterate.
+
+! TO_FM is a function for converting other types of numbers
+! to type FM. Note that TO_FM(3.12) converts the REAL
+! constant to FM, but it is accurate only to single
+! precision. TO_FM(3.12D0) agrees with 3.12 to double
+! precision accuracy, and TO_FM('3.12') or
+! TO_FM(312)/TO_FM(100) agrees to full FM accuracy.
+! Here, TO_FM(3.12) would be ok, since Newton iteration
+! will correct the error coming from single precision,
+! but it is a good habit to use the more accurate form.
+
+ MAFM = TO_FM('3.12')
+
+! Print the first iteration.
+
+ FMT = "(//' Sample 1. Real root of f(x) = x**5 - 3x**4 + ',"// &
+ "'x**3 - 4x**2 + x - 6 = 0.'///" // &
+ "' Iteration Newton Approximation')"
+ WRITE (*,FMT)
+ WRITE (KLOG,FMT)
+
+! FM_FORMAT is a formatting function that returns a
+! character string (of length 200).
+! Avoid using FM_FORMAT in the write list, since this
+! function itself does internal WRITE operations, and
+! some compilers object to recursive WRITE references.
+
+ ST1 = FM_FORMAT('F65.60',MAFM)
+ WRITE (* ,"(/I10,4X,A)") 0,TRIM(ST1)
+ WRITE (KLOG,"(/I10,4X,A)") 0,TRIM(ST1)
+
+ DO ITER = 1, 10
+
+! MCFM is f(MAFM).
+
+ MCFM = ((((MAFM-3)*MAFM+1)*MAFM-4)*MAFM+1)*MAFM-6
+
+! MDFM is f'(MAFM).
+
+ MDFM = (((5*MAFM-12)*MAFM+3)*MAFM-8)*MAFM+1
+
+ MBFM = MAFM - MCFM/MDFM
+
+! Print each iteration.
+
+! FM_FORM is a formatting subroutine. FM_FORM can
+! handle output strings longer that 200 characters.
+
+ CALL FM_FORM('F65.60',MBFM,ST1)
+ WRITE (* ,"(/I10,4X,A)") ITER,TRIM(ST1)
+ WRITE (KLOG,"(/I10,4X,A)") ITER,TRIM(ST1)
+
+! Stop iterating if MAFM and MBFM agree to over 60 places.
+
+ MDFM = ABS(MAFM-MBFM)
+ IF (MDFM < 1.0D-61) EXIT
+
+! Set MAFM = MBFM for the next iteration.
+
+ MAFM = MBFM
+ ENDDO
+
+! Check the answer.
+
+ MCFM = TO_FM('3.120656215326726500470956013523797484654623'// &
+ '9355990660149888284358')
+
+! It is slightly safer to do this test with .NOT. instead of
+! IF (ABS(MCFM-MBFM) >= 1.0D-61) THEN
+! because if the result of ABS(MCFM-MBFM) is FM's UNKNOWN value,
+! the comparison returns false for all comparisons.
+
+ IF (.NOT.(ABS(MCFM-MBFM) < 1.0D-61)) THEN
+ NERROR = NERROR + 1
+ WRITE (* ,"(/' Error in sample case number 1.'/)")
+ WRITE (KLOG,"(/' Error in sample case number 1.'/)")
+ ENDIF
+
+
+! 2. Higher Precision. Compute the root above to 300 decimal places.
+
+ CALL FM_SET(300)
+
+! It is tempting to just say MAFM = MCFM here to initialize the
+! start of the higher precision iterations to be the check value
+! defined above. That will not work, because precision has
+! changed. Most of the digits of MCFM may be undefined at the
+! new precision.
+! The usual way to pad a lower precision value with zeros when
+! raising precision is to use subroutine FM_EQU, but here it is
+! easier to define MAFM from scratch at the new precision.
+
+ MAFM = TO_FM('3.120656215326726500470956013523797484654623'// &
+ '9355990660149888284358')
+
+ DO ITER = 1, 10
+
+! MCFM is f(MAFM).
+
+ MCFM = ((((MAFM-3)*MAFM+1)*MAFM-4)*MAFM+1)*MAFM-6
+
+! MDFM is f'(MAFM).
+
+ MDFM = (((5*MAFM-12)*MAFM+3)*MAFM-8)*MAFM+1
+
+ MBFM = MAFM - MCFM/MDFM
+
+! Stop iterating if MAFM and MBFM agree to over 300 places.
+
+ MDFM = ABS(MAFM-MBFM)
+ IF (MDFM < TO_FM('1.0E-301')) EXIT
+
+! Set MAFM = MBFM for the next iteration.
+
+ MAFM = MBFM
+ ENDDO
+
+! For very high precision output, it is sometimes more
+! convenient to use FM_PRNT to format and print the numbers,
+! since the line breaks are handled automatically.
+! The unit number for the output, KW, and the format codes
+! to be used, JFORM1 and JFORM2, are internal FM variables.
+! Subroutine FMSETVAR is used to re-define these, and the
+! new values will remain in effect for any further calls
+! to FM_PRNT.
+
+! Other variables that can be changed and the options they
+! control are listed in the documentation at the top of file
+! FM.f.
+
+! Set the format to F305.300
+
+ CALL FMSETVAR(' JFORM1 = 2 ')
+ CALL FMSETVAR(' JFORM2 = 300 ')
+
+! Set the output screen width to 90 columns.
+
+ CALL FMSETVAR(' KSWIDE = 90 ')
+
+ WRITE (* ,"(///' Sample 2. Find the root above to 300 decimal places.'/)")
+ WRITE (KLOG,"(///' Sample 2. Find the root above to 300 decimal places.'/)")
+
+! Write to the log file.
+
+ CALL FMSETVAR(' KW = 18 ')
+ CALL FM_PRNT(MBFM)
+
+! Write to the screen (unit 6).
+
+ CALL FMSETVAR(' KW = 6 ')
+ CALL FM_PRNT(MBFM)
+
+! Check the answer.
+
+ MCFM = TO_FM('3.12065621532672650047095601352379748465462393559906601'// &
+ '4988828435819026499951795468978325745001715109581192343'// &
+ '1332682839420040840535954560118152245371792881305271951'// &
+ '0171189388982124036620583073039835473769132820001100582'// &
+ '7350420283867070989561927541348452154928259189115694520'// &
+ '0789415818387529512010999602155131321076797099026664236')
+
+ IF (.NOT.(ABS(MCFM-MBFM) < TO_FM('1.0E-301'))) THEN
+ NERROR = NERROR + 1
+ WRITE (* ,"(/' Error in sample case number 2.'/)")
+ WRITE (KLOG,"(/' Error in sample case number 2.'/)")
+ ENDIF
+
+
+! 3. Compute the Riemann Zeta function for s=3.
+
+! Use Gosper's formula: Zeta(3) =
+! (5/4)*Sum[ (-1)**k * (k!)**2 / ((k+1)**2 * (2k+1)!) ]
+! while k = 0, 1, ....
+
+! MAFM is the current partial sum.
+! MBFM is the current term.
+! MCFM is k!
+! MDFM is (2k+1)!
+
+ CALL FM_SET(60)
+ MAFM = 1
+ MCFM = 1
+ MDFM = 1
+ DO K = 1, 200
+ MCFM = K*MCFM
+ J = 2*K*(2*K+1)
+ MDFM = J*MDFM
+ MBFM = MCFM**2
+ J = (K+1)*(K+1)
+ MBFM = (MBFM/J)/MDFM
+ IF (MOD(K,2) == 0) THEN
+ MAFM = MAFM + MBFM
+ ELSE
+ MAFM = MAFM - MBFM
+ ENDIF
+
+! Test for convergence.
+
+ IF (MAFM-MBFM == MAFM) THEN
+ WRITE (* , &
+ "(///' Sample 3.',8X,I5,' terms were added in the Zeta sum'/)") K
+ WRITE (KLOG, &
+ "(///' Sample 3.',8X,I5,' terms were added in the Zeta sum'/)") K
+ EXIT
+ ENDIF
+ ENDDO
+
+! Print the result.
+
+ MAFM = (5*MAFM)/4
+ CALL FM_FORM('F62.60',MAFM,ST1)
+ WRITE (* ,"(' Zeta(3) = ',A)") TRIM(ST1)
+ WRITE (KLOG,"(' Zeta(3) = ',A)") TRIM(ST1)
+
+! Check the answer.
+
+ MCFM = TO_FM('1.20205690315959428539973816151144999076498'// &
+ '6292340498881792271555')
+ IF (.NOT.(ABS(MAFM-MCFM) < 1.0D-61)) THEN
+ NERROR = NERROR + 1
+ WRITE (* ,"(/' Error in sample case number 3.'/)")
+ WRITE (KLOG,"(/' Error in sample case number 3.'/)")
+ ENDIF
+
+
+! 4. Integer multiple precision calculations.
+
+! Fermat's theorem says x**(p-1) mod p = 1
+! when p is prime and x is not a multiple of p.
+! If x**(p-1) mod p gives 1 for some p with
+! several different x's, then it is very likely
+! that p is prime (but it is not certain until
+! further tests are done).
+
+! Find a 70-digit number p that is "probably" prime.
+
+! Use FM_RANDOM_NUMBER to generate a random 70-digit
+! starting value and search for a prime from that point.
+! Initialize the generator.
+! Note that VALUE is double precision, unlike the similar
+! Fortran intrinsic random number routine, which returns
+! a single-precision result.
+
+ CALL FM_SET(80)
+ SEED = (/ 2718281,8284590,4523536,0287471,3526624,9775724,7093699 /)
+ CALL FM_RANDOM_SEED(PUT=SEED)
+
+! MAIM is the value p being tested.
+
+ MAIM = 0
+ MCIM = TO_IM(10)**13
+ DO J = 1, 6
+ CALL FM_RANDOM_NUMBER(VALUE)
+ MBIM = 1.0D+13*VALUE
+ MAIM = MAIM*MCIM + MBIM
+ ENDDO
+ MCIM = TO_IM(10)**70
+ MAIM = MOD(MAIM,MCIM)
+
+! To speed up the search, test only values that are
+! not multiples of 2, 3, 5, 7, 11, 13.
+
+ K = 2*3*5*7*11*13
+ MAIM = (MAIM/K)*K + K + 1
+ MCIM = 3
+
+ DO J = 1, 100
+ MBIM = MAIM - 1
+
+! Compute 3**(p-1) mod p
+
+ MCIM = POWER_MOD(MCIM,MBIM,MAIM)
+ IF (MCIM == 1) THEN
+
+! Check that 7**(p-1) mod p is also 1.
+
+ MCIM = 7
+ MCIM = POWER_MOD(MCIM,MBIM,MAIM)
+ IF (MCIM == 1) THEN
+ FMT = "(///' Sample 4.',8X,I5,' values were"// &
+ " checked before finding a prime p.'/)"
+ WRITE (* ,FMT) J
+ WRITE (KLOG,FMT) J
+ EXIT
+ ENDIF
+ ENDIF
+
+ MCIM = 3
+ MAIM = MAIM + K
+ ENDDO
+
+! Print the result.
+
+ CALL IM_FORM('I72',MAIM,ST1)
+ WRITE (* ,"(' p =',A)") TRIM(ST1)
+ WRITE (KLOG,"(' p =',A)") TRIM(ST1)
+
+! Check the answer.
+
+ MCIM = TO_IM('546831788457201910369201221205379315384'// &
+ '5065543480825746529998049913561')
+ IF (.NOT.(MAIM == MCIM)) THEN
+ NERROR = NERROR + 1
+ WRITE (* ,"(/' Error in sample case number 4.'/)")
+ WRITE (KLOG,"(/' Error in sample case number 4.'/)")
+ ENDIF
+
+
+! 5. Gamma function.
+
+! Check that Gamma(1/2) is Sqrt(pi)
+
+ CALL FM_SET(60)
+ WRITE (* ,"(///' Sample 5. Check that Gamma(1/2) = Sqrt(pi)'/)")
+ WRITE (KLOG,"(///' Sample 5. Check that Gamma(1/2) = Sqrt(pi)'/)")
+
+ MBFM = GAMMA(TO_FM('0.5'))
+
+! Print the result.
+
+ CALL FM_FORM('F62.60',MBFM,ST1)
+ WRITE (* ,"(' Gamma(1/2) = ',A)") TRIM(ST1)
+ WRITE (KLOG,"(' Gamma(1/2) = ',A)") TRIM(ST1)
+
+! Check the answer.
+
+ MCFM = SQRT(4*ATAN(TO_FM(1)))
+ IF (.NOT.(ABS(MCFM-MBFM) < 1.0D-61)) THEN
+ NERROR = NERROR + 1
+ WRITE (* ,"(/' Error in sample case number 5.'/)")
+ WRITE (KLOG,"(/' Error in sample case number 5.'/)")
+ ENDIF
+
+
+! 6. Psi and Polygamma functions.
+
+! Rational series can often be summed using these functions.
+! Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) =
+! 16*(Psi(1) - Psi(9/8)) + Polygamma(1,1) + Polygamma(1,9/8)
+! Ref: Abramowitz & Stegun, Handbook of Mathematical Functions,
+! chapter 6, Example 10.
+
+ WRITE (* ,"(///' Sample 6. Psi and Polygamma functions.'/)")
+ WRITE (KLOG,"(///' Sample 6. Psi and Polygamma functions.'/)")
+
+ MBFM = 16*(PSI(TO_FM(1)) - PSI(TO_FM(9)/8)) + &
+ POLYGAMMA(1,TO_FM(1)) + POLYGAMMA(1,TO_FM(9)/8)
+
+! Print the result.
+
+ CALL FM_FORM('F65.60',MBFM,ST1)
+ WRITE (* ,"(' Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) = '/9X,A)") TRIM(ST1)
+ WRITE (KLOG,"(' Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) = '/9X,A)") TRIM(ST1)
+
+! Check the answer.
+
+ MCFM = TO_FM('1.34994861454130247551078291050351479506449786'// &
+ '35837270816327396M-2')
+ IF (.NOT.(ABS(MCFM-MBFM) < 1.0D-61)) THEN
+ NERROR = NERROR + 1
+ WRITE (* ,"(/' Error in sample case number 6.'/)")
+ WRITE (KLOG,"(/' Error in sample case number 6.'/)")
+ ENDIF
+
+
+! 7. Incomplete gamma and Gamma functions.
+
+! Find the probability that an observed chi-square for a correct
+! model should be less that 2.3 when the number of degrees of
+! freedom is 5.
+! Ref: Knuth, Volume 2, 3rd ed., Page 56, and Press, Flannery,
+! Teukolsky, Vetterling, Numerical Recipes, 1st ed., Page 165.
+
+ WRITE (* ,"(///' Sample 7. Incomplete gamma and Gamma functions.'/)")
+ WRITE (KLOG,"(///' Sample 7. Incomplete gamma and Gamma functions.'/)")
+
+ MAFM = TO_FM(5)/2
+ MBFM = INCOMPLETE_GAMMA1(MAFM,TO_FM('2.3')/2) / GAMMA(MAFM)
+
+! Print the result.
+
+ CALL FM_FORM('F61.60',MBFM,ST1)
+ WRITE (* ,"(' Probability = ',A)") TRIM(ST1)
+ WRITE (KLOG,"(' Probability = ',A)") TRIM(ST1)
+
+! Check the answer.
+
+ MCFM = TO_FM('0.193733130114871446327510259182505999534723186'// &
+ '07121386973066283739')
+ IF (.NOT.(ABS(MCFM-MBFM) < 1.0D-61)) THEN
+ NERROR = NERROR + 1
+ WRITE (* ,"(/' Error in sample case number 7.'/)")
+ WRITE (KLOG,"(/' Error in sample case number 7.'/)")
+ ENDIF
+
+
+! Complex arithmetic.
+
+! Set precision to give at least 30 significant digits.
+
+ CALL FM_SET(30)
+
+
+! 8. Find a complex root of the equation
+! f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.
+
+! Newton's method with initial guess x = .56 + 1.06 i.
+! This version is not tuned for speed. See the ZMSQRT
+! routine for possible ways to increase speed.
+! Horner's rule is used to evaluate the function.
+
+! MAZM is the previous iterate.
+! MBZM is the current iterate.
+
+ MAZM = TO_ZM('.56 + 1.06 i')
+
+! Print the first iteration.
+
+ FMT = "(///' Sample 8. Complex root of f(x) = x**5 - 3x**4 + ',"// &
+ "'x**3 - 4x**2 + x - 6 = 0.'///" // &
+ "' Iteration Newton Approximation')"
+ WRITE (*,FMT)
+ WRITE (KLOG,FMT)
+ CALL ZM_FORM('F32.30','F32.30',MAZM,ST1)
+ WRITE (* ,"(/I6,4X,A)") 0,TRIM(ST1)
+ WRITE (KLOG,"(/I6,4X,A)") 0,TRIM(ST1)
+
+ DO ITER = 1, 10
+
+! MCZM is f(MAZM).
+
+ MCZM = ((((MAZM-3)*MAZM+1)*MAZM-4)*MAZM+1)*MAZM-6
+
+! MDZM is f'(MAZM).
+
+ MDZM = (((5*MAZM-12)*MAZM+3)*MAZM-8)*MAZM+1
+
+ MBZM = MAZM - MCZM/MDZM
+
+! Print each iteration.
+
+ CALL ZM_FORM('F32.30','F32.30',MBZM,ST1)
+ WRITE (* ,"(/I6,4X,A)") ITER,TRIM(ST1)
+ WRITE (KLOG,"(/I6,4X,A)") ITER,TRIM(ST1)
+
+! Stop iterating if MAZM and MBZM agree to over 30 places.
+
+ IF (ABS(MAZM-MBZM) < 1.0D-31) EXIT
+
+! Set MAZM = MBZM for the next iteration.
+
+ MAZM = MBZM
+ ENDDO
+
+! Check the answer.
+
+ MCZM = TO_ZM('0.561958308335403235498111195347453 +'// &
+ '1.061134679604332556983391239058885 i')
+ IF (.NOT.(ABS(MCZM-MBZM) < 1.0D-31)) THEN
+ NERROR = NERROR + 1
+ WRITE (* ,"(/' Error in sample case number 8.'/)")
+ WRITE (KLOG,"(/' Error in sample case number 8.'/)")
+ ENDIF
+
+
+! 9. Compute Exp(1.23-2.34i).
+
+! Use the direct Taylor series. See the ZMEXP routine
+! for a faster way to get Exp(x).
+
+! MAZM is x.
+! MBZM is the current term, x**n/n!.
+! MCZM is the current partial sum.
+
+ MAZM = TO_ZM('1.23-2.34i')
+ MBZM = 1
+ MCZM = 1
+ DO K = 1, 100
+ MBZM = MBZM*MAZM/K
+ MDZM = MCZM + MBZM
+
+! Test for convergence.
+
+ IF (MDZM == MCZM) THEN
+ FMT = "(///' Sample 9.',8X,I5,' terms were added ',"// &
+ "'to get Exp(1.23-2.34i)'/)"
+ WRITE (* ,FMT) K
+ WRITE (KLOG,FMT) K
+ EXIT
+ ENDIF
+ MCZM = MDZM
+ ENDDO
+
+! Print the result.
+
+ CALL ZM_FORM('F33.30','F32.30',MCZM,ST1)
+ WRITE (* ,"(' Result= ',A)") TRIM(ST1)
+ WRITE (KLOG,"(' Result= ',A)") TRIM(ST1)
+
+! Check the answer.
+
+ MDZM = TO_ZM('-2.379681796854777515745457977696745 -'// &
+ ' 2.458032970832342652397461908326042 i')
+ IF (.NOT.(ABS(MDZM-MCZM) < 1.0D-31)) THEN
+ NERROR = NERROR + 1
+ WRITE (* ,"(/' Error in sample case number 9.'/)")
+ WRITE (KLOG,"(/' Error in sample case number 9.'/)")
+ ENDIF
+
+
+! 10. Exception handling.
+! Iterate (real) Exp(x) starting at 1.0 until overflow occurs.
+!
+! Testing type FM numbers directly using an IF can
+! be tricky. When MAFM is +overflow, the statement
+! IF (MAFM == TO_FM(' +OVERFLOW ')) THEN
+! will return false, since the comparison routine cannot be
+! sure that two different overflowed results would have been
+! equal if the overflow threshold had been higher.
+!
+! In this case, calling subroutine FMFLAG will tell when
+! an exception has happened.
+!
+! However, for a complicated expression that generates several
+! FM calls using the derived type numbers, note that the FM
+! result flag may be zero at the end of the expression even if
+! an exception occurred. For example, if EXP(A) overflows in
+! X = (3 + 1/EXP(A))*2
+! then the result is 6 with a flag of zero, since the exception
+! caused no loss of accuracy in the final result. A warning
+! message will still appear because of the overflow.
+!
+! The FM warning message is written on unit KW, so in this test
+! it appears on the screen and not in the log file.
+!
+! The final result is checked by formatting the result and finding
+! that the output string is '+ OVERFLOW'.
+
+ CALL FM_SET(60)
+
+ MAFM = TO_FM(1)
+
+ FMT = "(///' Sample 10. Exception handling.'//" // &
+ "12X,' Iterate Exp(x) starting at 1.0 until overflow occurs.'//" // &
+ "12X,' An FM warning message will be printed before the last iteration.'/)"
+ WRITE (*,FMT)
+ FMT = "(///' Sample 10. Exception handling.'//" // &
+ "12X,' Iterate Exp(x) starting at 1.0 until overflow occurs.'/)"
+ WRITE (KLOG,FMT)
+
+ DO J = 1, 10
+ MAFM = EXP(MAFM)
+ CALL FMFLAG(LFLAG)
+ CALL FM_FORM('1PE60.40',MAFM,ST1)
+ WRITE (* ,"(/' Iteration',I3,5X,A)") J,TRIM(ST1)
+ WRITE (KLOG,"(/' Iteration',I3,5X,A)") J,TRIM(ST1)
+ IF (LFLAG < 0) EXIT
+ ENDDO
+
+! Check that the last result was +overflow.
+
+ IF (FM_FORMAT('E60.40',MAFM) == FM_FORMAT('E60.40',TO_FM('+OVERFLOW'))) THEN
+ WRITE (* ,"(/' Overflow was correctly detected.')")
+ WRITE (KLOG,"(/' Overflow was correctly detected.')")
+ ELSE
+ NERROR = NERROR + 1
+ WRITE (* ,"(/' Error in sample case number 10.'/)")
+ WRITE (* ,"(/' Overflow was not correctly detected.')")
+ WRITE (KLOG ,"(/' Error in sample case number 10.'/)")
+ WRITE (KLOG ,"(/' Overflow was not correctly detected.')")
+ ENDIF
+
+ IF (NERROR == 0) THEN
+ WRITE (* ,"(//A/)") ' All results were ok.'
+ WRITE (KLOG,"(//A/)") ' All results were ok.'
+ ELSE
+ WRITE (* ,"(//I3,A/)") NERROR,' error(s) found.'
+ WRITE (KLOG,"(//I3,A/)") NERROR,' error(s) found.'
+ ENDIF
+
+ END PROGRAM SAMPLE
diff --git a/src/fmlib/TestFM.F90 b/src/fmlib/TestFM.F90
new file mode 100644
index 0000000000000000000000000000000000000000..79dda01ab9c0838847bf591f2490f56c31eefb3f
--- /dev/null
+++ b/src/fmlib/TestFM.F90
@@ -0,0 +1,10944 @@
+
+! David M. Smith
+
+! This is a test program for FMLIB 1.2, a multiple-precision
+! arithmetic package. Most of the FM (floating-point real)
+! and ZM (floating-point complex) routines are tested.
+! Precision is set to 50 significant digits and the results
+! are checked to that accuracy.
+! Most of the IM (integer) routines are tested, with exact
+! results required to pass the tests.
+! Most of the USE FMZM derived type interface routines are
+! tested in the same manner as those described above.
+
+! If all tests are completed successfully, this line is printed:
+
+! 935 cases tested. No errors were found.
+
+ MODULE TEST_VARS
+
+ USE FMVALS
+ USE FMZM
+
+! Declare arrays for FM variables.
+
+ REAL (KIND(1.0D0)) :: MA(-1:LUNPCK),MB(-1:LUNPCK),MC(-1:LUNPCK), &
+ MD(-1:LUNPCK),ME(-1:LUNPCK),MP1(-1:LPACK), &
+ MP2(-1:LPACK),MP3(-1:LPACK)
+ REAL (KIND(1.0D0)) :: ZA(-1:LUNPKZ),ZB(-1:LUNPKZ),ZC(-1:LUNPKZ), &
+ ZD(-1:LUNPKZ),ZE(-1:LUNPKZ)
+ REAL (KIND(1.0D0)) :: MLNSV2(-1:LUNPCK),MLNSV3(-1:LUNPCK), &
+ MLNSV5(-1:LUNPCK),MLNSV7(-1:LUNPCK)
+
+! Declare derived type variables.
+
+ TYPE (FM), SAVE :: M_A,M_B,M_C,M_D,MFM1,MFM2,MFM3,MFM4,MFM5,MFM6, &
+ MSMALL,MFMV1(3),MFMV2(3),MFMA(3,3),MFMB(3,3),MFMC(3,3)
+ TYPE (IM), SAVE :: M_J,M_K,M_L,MIM1,MIM2,MIM3,MIM4,MIM5,MIMV1(3), &
+ MIMV2(3),MIMA(2,2),MIMB(2,2),MIMC(2,2)
+ TYPE (ZM), SAVE :: M_X,M_Y,M_Z,MZM1,MZM2,MZM3,MZM4,MZM5,MZMV1(3), &
+ MZMV2(3),MZMA(2,3),MZMB(3,4),MZMC(2,4)
+
+ INTEGER, SAVE :: J1,J2,J3,J4,J5
+ REAL, SAVE :: R1,R2,R3,R4,R5,RSMALL
+ DOUBLE PRECISION, SAVE :: D1,D2,D3,D4,D5,DSMALL
+ COMPLEX, SAVE :: C1,C2,C3,C4,C5
+ COMPLEX (KIND(0.0D0)), SAVE :: CD1,CD2,CD3,CD4
+
+ END MODULE TEST_VARS
+
+ PROGRAM TEST
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+! Character strings used for input and output.
+
+ CHARACTER(80) :: ST1,ST2
+ CHARACTER(160) :: STZ1,STZ2
+
+ INTEGER KLOG,KWSAVE,NCASE,NERROR
+ REAL TIME1,TIME2
+
+! Write output to the standard FM output (unit KW, defined
+! in subroutine FMSET), and also to the file TESTFM.LOG.
+
+ KLOG = 18
+ OPEN (KLOG,FILE='TESTFM.LOG')
+ KWSAVE = KW
+ KW = KLOG
+
+! Set precision to give at least 50 significant digits
+! and initialize the FM package.
+! This call also checks many of the initialization values
+! used in module FMVALS (file FMSAVE.f90). Set KW = KLOG for
+! this call so that any messages concerning these values will
+! appear in file TESTFM.LOG.
+
+ CALL FMSET(50)
+ KW = KWSAVE
+
+ CALL TIMEIT(TIME1)
+
+ J2 = 131
+ R2 = 241.21
+ D2 = 391.61D0
+ C2 = ( 411.11D0 , 421.21D0 )
+ CD2 = ( 431.11D0 , 441.21D0 )
+ CALL FM_ST2M('581.21',MFM1)
+ CALL FM_ST2M('-572.42',MFM2)
+ CALL IM_ST2M('661',MIM1)
+ CALL IM_ST2M('-602',MIM2)
+ CALL ZM_ST2M('731.51 + 711.41 i',MZM1)
+ CALL ZM_ST2M('-762.12 - 792.42 i',MZM2)
+
+! NERROR is the number of errors found.
+! NCASE is the number of cases tested.
+
+ NERROR = 0
+
+! Test input and output conversion.
+
+ CALL TEST1(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test add and subtract.
+
+ CALL TEST2(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test multiply, divide and square root.
+
+ CALL TEST3(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test stored constants.
+
+ CALL TEST4(NCASE,NERROR,KLOG)
+
+! Test exponentials.
+
+ CALL TEST5(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test logarithms.
+
+ CALL TEST6(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test trigonometric functions.
+
+ CALL TEST7(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test inverse trigonometric functions.
+
+ CALL TEST8(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test hyperbolic functions.
+
+ CALL TEST9(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test integer input and output conversion.
+
+ CALL TEST10(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test integer add and subtract.
+
+ CALL TEST11(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test integer multiply and divide.
+
+ CALL TEST12(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test conversions between FM and IM format.
+
+ CALL TEST13(NCASE,NERROR,KLOG)
+
+! Test integer power and GCD functions.
+
+ CALL TEST14(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test integer modular functions.
+
+ CALL TEST15(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test complex input and output conversion.
+
+ CALL TEST16(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Test complex add and subtract.
+
+ CALL TEST17(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Test complex multiply, divide and square root.
+
+ CALL TEST18(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Test complex exponentials.
+
+ CALL TEST19(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Test complex logarithms.
+
+ CALL TEST20(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Test complex trigonometric functions.
+
+ CALL TEST21(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Test complex inverse trigonometric functions.
+
+ CALL TEST22(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Test complex hyperbolic functions.
+
+ CALL TEST23(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Test the derived type = interface.
+
+ CALL TEST24(NCASE,NERROR,KLOG)
+
+! Test the derived type == interface.
+
+ CALL TEST25(NCASE,NERROR,KLOG)
+
+! Test the derived type /= interface.
+
+ CALL TEST26(NCASE,NERROR,KLOG)
+
+! Test the derived type > interface.
+
+ CALL TEST27(NCASE,NERROR,KLOG)
+
+! Test the derived type >= interface.
+
+ CALL TEST28(NCASE,NERROR,KLOG)
+
+! Test the derived type < interface.
+
+ CALL TEST29(NCASE,NERROR,KLOG)
+
+! Test the derived type <= interface.
+
+ CALL TEST30(NCASE,NERROR,KLOG)
+
+! Test the derived type + interface.
+
+ CALL TEST31(NCASE,NERROR,KLOG)
+
+! Test the derived type - interface.
+
+ CALL TEST32(NCASE,NERROR,KLOG)
+
+! Test the derived type * interface.
+
+ CALL TEST33(NCASE,NERROR,KLOG)
+
+! Test the derived type / interface.
+
+ CALL TEST34(NCASE,NERROR,KLOG)
+
+! Test the derived type ** interface.
+
+ CALL TEST35(NCASE,NERROR,KLOG)
+
+! Test the derived type functions ABS, ..., CEILING interface.
+
+ CALL TEST36(NCASE,NERROR,KLOG)
+
+! Test the derived type functions CMPLX, ..., EXPONENT interface.
+
+ CALL TEST37(NCASE,NERROR,KLOG)
+
+! Test the derived type functions FLOOR, ..., MIN interface.
+
+ CALL TEST38(NCASE,NERROR,KLOG)
+
+! Test the derived type functions MINEXPONENT, ..., RRSPACING interface.
+
+ CALL TEST39(NCASE,NERROR,KLOG)
+
+! Test the derived type functions SCALE, ..., TINY interface.
+
+ CALL TEST40(NCASE,NERROR,KLOG)
+
+! Test the derived type functions TO_FM, TO_IM, TO_ZM, ..., TO_DPZ interface.
+
+ CALL TEST41(NCASE,NERROR,KLOG)
+
+! Test the derived type functions ADDI, ..., Z2M interface.
+
+ CALL TEST42(NCASE,NERROR,KLOG)
+
+! Test Bernoulli numbers, Pochhammer's function, Euler's constant.
+
+ CALL TEST43(NCASE,NERROR,KLOG)
+
+! Test Gamma, Factorial, Log(Gamma), Beta, Binomial.
+
+ CALL TEST44(NCASE,NERROR,KLOG)
+
+! Test Incomplete Gamma, Incomplete Beta.
+
+ CALL TEST45(NCASE,NERROR,KLOG)
+
+! Test Polygamma, Psi.
+
+ CALL TEST46(NCASE,NERROR,KLOG)
+
+! Test the different rounding modes.
+
+ CALL TEST47(NCASE,NERROR,KLOG)
+
+! End of tests.
+
+ CALL TIMEIT(TIME2)
+
+ IF (NERROR == 0) THEN
+ WRITE (KW, &
+ "(///1X,I5,' cases tested. No errors were found.'/)" &
+ ) NCASE
+ WRITE (KLOG, &
+ "(///1X,I5,' cases tested. No errors were found.'/)" &
+ ) NCASE
+ ELSE IF (NERROR == 1) THEN
+ WRITE (KW, &
+ "(///1X,I5,' cases tested. 1 error was found.'/)" &
+ ) NCASE
+ WRITE (KLOG, &
+ "(///1X,I5,' cases tested. 1 error was found.'/)" &
+ ) NCASE
+ ELSE
+ WRITE (KW, &
+ "(///1X,I5,' cases tested.',I4,' errors were found.'/)" &
+ ) NCASE,NERROR
+ WRITE (KLOG, &
+ "(///1X,I5,' cases tested.',I4,' errors were found.'/)" &
+ ) NCASE,NERROR
+ ENDIF
+
+ IF (NERROR >= 1) THEN
+ KWSAVE = KW
+ KW = KLOG
+
+! Write some of the initialized values in common.
+
+ CALL FMVARS
+ KW = KWSAVE
+ ENDIF
+
+ WRITE (KW,*) ' '
+ WRITE (KW,"(F10.2,A)") TIME2-TIME1,' Seconds for TestFM.'
+ WRITE (KW,*) ' '
+ WRITE (KLOG,*) ' '
+ WRITE (KLOG,"(F10.2,A)") TIME2-TIME1,' Seconds for TestFM.'
+ WRITE (KLOG,*) ' '
+
+ WRITE (KW,*)' End of run.'
+
+ STOP
+ END PROGRAM TEST
+
+ SUBROUTINE TEST1(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Input and output testing.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+! Logical function for comparing FM numbers.
+
+ LOGICAL FMCOMP
+
+ CHARACTER(80) :: ST1,ST2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing input and output routines.')")
+
+ NCASE = 1
+ CALL FMST2M('123',MA)
+ CALL FMI2M(123,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-48,ME)
+ CALL FMEQ(ME,MB)
+
+! Use the .NOT. because FMCOMP returns FALSE for special
+! cases like MD = UNKNOWN, and these should be treated
+! as errors for these tests.
+
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMST2M',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 2
+ ST1 = '1.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMI2M(131,MB)
+ CALL FMI2M(97,MC)
+ CALL FMDIV(MB,MC,ME)
+ CALL FMEQ(ME,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMST2M',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 3
+ ST1 = '1.3505154639175257731958762886597938144329896907216495E-2'
+ CALL FMST2M(ST1,MA)
+ CALL FMI2M(131,MB)
+ CALL FMI2M(9700,MC)
+ CALL FMDIV(MB,MC,ME)
+ CALL FMEQ(ME,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-52',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMST2M',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 4
+ ST1 = '1.3505154639175257731958762886597938144329896907216495E-2'
+ CALL FMST2M(ST1,MA)
+ CALL FMFORM('F40.30',MA,ST2)
+ CALL FMST2M(ST2,MA)
+ ST1 = ' .013505154639175257731958762887'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('0',MB)
+ IF ((.NOT.FMCOMP(MD,'LE',MB)) .OR. ST1 /= ST2) THEN
+ CALL ERRPRTFM('FMFORM',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 5
+ ST1 = '1.3505154639175257731958762886597938144329896907216495E+16'
+ CALL FMST2M(ST1,MA)
+ CALL FMFORM('F53.33',MA,ST2)
+ CALL FMST2M(ST2,MA)
+ ST1 = '13505154639175257.731958762886597938144329896907216'
+ CALL FMST2M(ST1,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('0',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMFORM',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 6
+ ST1 = '1.3505154639175257731958762886597938144329896907216495E+16'
+ CALL FMST2M(ST1,MA)
+ CALL FMFORM('I24',MA,ST2)
+ CALL FMST2M(ST2,MA)
+ ST1 = '13505154639175258'
+ CALL FMST2M(ST1,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('0',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMFORM',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 7
+ ST1 ='-1.3505154639175257731958762886597938144329896907216495E+16'
+ CALL FMST2M(ST1,MA)
+ CALL FMFORM('E55.49',MA,ST2)
+ CALL FMST2M(ST2,MA)
+ ST1 = '-1.350515463917525773195876288659793814432989690722D16'
+ CALL FMST2M(ST1,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('0',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMFORM',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 8
+ ST1 ='-1.3505154639175257731958762886597938144329896907216495E+16'
+ CALL FMST2M(ST1,MA)
+ CALL FMFORM('1PE54.46',MA,ST2)
+ CALL FMST2M(ST2,MA)
+ ST1 = '-1.350515463917525773195876288659793814432989691M+16'
+ CALL FMST2M(ST1,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('0',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMFORM',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST1
+
+ SUBROUTINE TEST2(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test add and subtract.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+
+ CHARACTER(80) :: ST1,ST2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing add and subtract routines.')")
+
+ NCASE = 9
+ CALL FMST2M('123',MA)
+ CALL FMST2M('789',MB)
+ CALL FMADD(MA,MB,ME)
+ CALL FMEQ(ME,MA)
+ CALL FMI2M(912,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('0',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMADD ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 10
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ ST1 = '0.7319587628865979381443298969072164948453608247422680'
+ CALL FMST2M(ST1,MB)
+ CALL FMADD(MA,MB,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '1.0824742268041237113402061855670103092783505154639175'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMADD ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 11
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ ST1 = '0.7319587628865979381443298969072164948453608247422680'
+ CALL FMST2M(ST1,MB)
+ CALL FMSUB(MA,MB,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '-.3814432989690721649484536082474226804123711340206185'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMSUB ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 12
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ ST1 = '0.3505154639175257731443298969072164948453608247422680'
+ CALL FMST2M(ST1,MB)
+ CALL FMSUB(MA,MB,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '5.15463917525773195876288659793815M-20'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMSUB ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 13
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMADDI(MA,1)
+ ST2 = '1.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMADDI',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 14
+ ST1 = '4.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMADDI(MA,5)
+ ST2 = '9.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMADDI',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST2
+
+ SUBROUTINE TEST3(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test multiply, divide and square root.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+
+ CHARACTER(80) :: ST1,ST2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing multiply, divide and square root routines.')")
+
+ NCASE = 15
+ CALL FMST2M('123',MA)
+ CALL FMST2M('789',MB)
+ CALL FMMPY(MA,MB,ME)
+ CALL FMEQ(ME,MA)
+ CALL FMI2M(97047,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('0',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMMPY ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 16
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ ST1 = '0.7319587628865979381443298969072164948453608247422680'
+ CALL FMST2M(ST1,MB)
+ CALL FMMPY(MA,MB,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.2565628653416941226485280051014985652035285365075991'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMMPY ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 17
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ ST1 = '0.7319587628865979381443298969072164948453608247422680'
+ CALL FMST2M(ST1,MB)
+ CALL FMDIV(MA,MB,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.4788732394366197183098591549295774647887323943661972'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMDIV ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 18
+ ST1 = '0.7319587628865979381443298969072164948453608247422680'
+ CALL FMST2M(ST1,MA)
+ CALL FMMPYI(MA,14,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '10.2474226804123711340206185567010309278350515463917526'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMMPYI',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 19
+ ST1 = '0.7319587628865979381443298969072164948453608247422680'
+ CALL FMST2M(ST1,MA)
+ CALL FMDIVI(MA,24,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.0304982817869415807560137457044673539518900343642612'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMDIVI',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 20
+ ST1 = '-0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMSQR(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.1228610904453183122542246784993091720692953555106813'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMSQR ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 21
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMSQRT(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.5920434645509785316136003710368759268547372945659987'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMSQRT',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST3
+
+ SUBROUTINE TEST4(NCASE,NERROR,KLOG)
+
+! Test stored constants.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+
+ REAL (KIND(1.0D0)) :: MBSAVE
+ INTEGER J,JEXP,KLOG,NCASE,NDGSAV,NERROR
+
+ WRITE (KW,"(/' Testing stored constants.'//' Check e.'/)")
+
+! Switch to base 10 and check the stored digits.
+
+ IF (NDIGMX < 55) THEN
+ WRITE (KLOG,*) ' '
+ WRITE (KLOG,*) &
+ ' To test these constants at their stored precision requires'
+ WRITE (KLOG,*) &
+ ' setting NDIG=55 (number of digits). The current maximum'
+ WRITE (KLOG,*) ' for NDIG is NDIGMX = ',NDIGMX
+ WRITE (KLOG,*) ' Skip the tests for stored constants.'
+ RETURN
+ ENDIF
+
+ MBSAVE = MBASE
+ NDGSAV = NDIG
+ NCASE = 22
+ CALL FMSETVAR(' MBASE = 1000 ')
+ CALL FMSETVAR(' NDIG = 55 ')
+ CALL FMCONS
+ CALL FMI2M(1,MB)
+ CALL FMEXP(MB,MC)
+ DO J = 49, 51
+ NDIG = J
+ NDIGE = 0
+ CALL FMI2M(1,MB)
+ CALL FMEXP(MB,MA)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMI2M(1000,MB)
+ JEXP = -J + 1
+ CALL FMIPWR(MB,JEXP,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM(' e ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ EXIT
+ ENDIF
+ ENDDO
+
+ NCASE = 23
+ CALL FMSETVAR(' MBASE = 1000 ')
+ CALL FMSETVAR(' NDIG = 55 ')
+ CALL FMI2M(2,MB)
+ CALL FMLN(MB,MC)
+ CALL FMEQ(MLN1,MLNSV2)
+ CALL FMEQ(MLN2,MLNSV3)
+ CALL FMEQ(MLN3,MLNSV5)
+ CALL FMEQ(MLN4,MLNSV7)
+ WRITE (KW,"(' Check ln(2).'/)")
+ DO J = 49, 51
+ NDIG = J
+ NDIGLI = 0
+ CALL FMI2M(2,MB)
+ CALL FMLN(MB,MA)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMI2M(1000,MB)
+ JEXP = -J
+ CALL FMIPWR(MB,JEXP,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM(' ln(2)',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ EXIT
+ ENDIF
+ ENDDO
+
+ NCASE = 24
+ CALL FMSETVAR(' MBASE = 1000 ')
+ CALL FMSETVAR(' NDIG = 55 ')
+ WRITE (KW,"(' Check ln(3).'/)")
+ CALL FMEQ(MLNSV3,MC)
+ DO J = 49, 51
+ NDIG = J
+ NDIGLI = 0
+ CALL FMI2M(3,MB)
+ CALL FMLN(MB,MA)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMI2M(1000,MB)
+ JEXP = -J + 1
+ CALL FMIPWR(MB,JEXP,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM(' ln(3)',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ EXIT
+ ENDIF
+ ENDDO
+
+ NCASE = 25
+ CALL FMSETVAR(' MBASE = 1000 ')
+ CALL FMSETVAR(' NDIG = 55 ')
+ WRITE (KW,"(' Check ln(5).'/)")
+ CALL FMEQ(MLNSV5,MC)
+ DO J = 49, 51
+ NDIG = J
+ NDIGLI = 0
+ CALL FMI2M(5,MB)
+ CALL FMLN(MB,MA)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMI2M(1000,MB)
+ JEXP = -J + 1
+ CALL FMIPWR(MB,JEXP,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM(' ln(5)',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ EXIT
+ ENDIF
+ ENDDO
+
+ NCASE = 26
+ CALL FMSETVAR(' MBASE = 1000 ')
+ CALL FMSETVAR(' NDIG = 55 ')
+ WRITE (KW,"(' Check ln(7).'/)")
+ CALL FMEQ(MLNSV7,MC)
+ DO J = 49, 51
+ NDIG = J
+ NDIGLI = 0
+ CALL FMI2M(7,MB)
+ CALL FMLN(MB,MA)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMI2M(1000,MB)
+ JEXP = -J + 1
+ CALL FMIPWR(MB,JEXP,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM(' ln(7)',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ EXIT
+ ENDIF
+ ENDDO
+
+ NCASE = 27
+ CALL FMSETVAR(' MBASE = 1000 ')
+ CALL FMSETVAR(' NDIG = 55 ')
+ WRITE (KW,"(' Check pi.')")
+ CALL FMPI(MC)
+ DO J = 49, 51
+ NDIG = J
+ NDIGPI = 0
+ CALL FMPI(MA)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMI2M(1000,MB)
+ JEXP = -J + 1
+ CALL FMIPWR(MB,JEXP,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM(' pi ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ EXIT
+ ENDIF
+ ENDDO
+
+! Restore base and precision.
+
+ MBASE = MBSAVE
+ NDIG = NDGSAV
+ CALL FMCONS
+ RETURN
+ END SUBROUTINE TEST4
+
+ SUBROUTINE TEST5(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test exponentials.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+
+ CHARACTER(80) :: ST1,ST2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing exponential routines.')")
+
+ NCASE = 28
+ ST1 = '-0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMEXP(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.7043249420381570899426746185150096342459216636010743'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMEXP ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 29
+ ST1 = '5.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMEXP(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '210.7168868293979289717186453717687341395104929999527672'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-48',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMEXP ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 30
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMIPWR(MA,13,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '1.205572620050170403854527299272882946980306577287581E-6'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-56',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMIPWR',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 31
+ ST1 = '0.7319587628865979381443298969072164948453608247422680'
+ CALL FMST2M(ST1,MA)
+ CALL FMIPWR(MA,-1234,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '1.673084074011006302103793189789209370839697748745938E167'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E+120',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMIPWR',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 32
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ ST1 = '0.7319587628865979381443298969072164948453608247422680'
+ CALL FMST2M(ST1,MB)
+ CALL FMPWR(MA,MB,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.4642420045002127676457665673753493595170650613692580'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMPWR ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 33
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ ST1 = '-34.7319587628865979381443298969072164948453608247422680'
+ CALL FMST2M(ST1,MB)
+ CALL FMPWR(MA,MB,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '6.504461581246879800523526109766882955934341922848773E15'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-34',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMPWR ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 34
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMRPWR(MA,1,3,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.7050756680967220302067310420367584779561732592049823'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMRPWR',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 35
+ ST1 = '0.7319587628865979381443298969072164948453608247422680'
+ CALL FMST2M(ST1,MA)
+ CALL FMRPWR(MA,-17,5,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '2.8889864895853344043562747681699203201333872009477318'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMRPWR',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST5
+
+ SUBROUTINE TEST6(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test logarithms.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+
+ CHARACTER(80) :: ST1,ST2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing logarithm routines.')")
+
+ NCASE = 36
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMLN(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '-1.0483504538872214324499548823726586101452117557127813'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-49',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMLN ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 37
+ ST1 = '0.3505154639175257731958762886597938144329896907216495E123'
+ CALL FMST2M(ST1,MA)
+ CALL FMLN(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '282.1696159843803977017629940438041389247902713456262947'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-47',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMLN ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 38
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMLG10(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '-0.4552928172239897280304530226127473926500843247517120'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-49',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMLG10',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 39
+ CALL FMLNI(210,MA)
+ ST2 = '5.3471075307174686805185894350500696418856767760333836'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-49',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMIPWR',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 40
+ CALL FMLNI(211,MA)
+ ST2 = '5.3518581334760664957419562654542801180411581735816684'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-49',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMPWR ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST6
+
+ SUBROUTINE TEST7(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test trigonometric functions.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+
+ CHARACTER(80) :: ST1,ST2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing trigonometric routines.')")
+
+ NCASE = 41
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMCOS(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.9391958366109693586000906984500978377093121163061328'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMCOS ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 42
+ ST1 = '-43.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMCOS(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.8069765551968063243992244125871029909816207609700968'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMCOS ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 43
+ ST1 = '-0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMSIN(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '-0.3433819746180939949443652360333010581867042625893927'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMSIN ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 44
+ ST1 = '43.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMSIN(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '-0.5905834736620182429243173169772978155668602154136946'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMSIN ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 45
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMTAN(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.3656127521360899712035823015565426347554405301360773'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMTAN ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 46
+ ST1 = '43.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMTAN(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '-0.7318471272291003544610122296764031536071117330470298'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMTAN ',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 47
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMCSSN(MA,ME,MC)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.9391958366109693586000906984500978377093121163061328'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMCSSN',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 48
+ ST1 = '-43.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMCSSN(MA,ME,MC)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.8069765551968063243992244125871029909816207609700968'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMCSSN',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 49
+ ST1 = '-0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMCSSN(MA,MC,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '-0.3433819746180939949443652360333010581867042625893927'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMCSSN',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 50
+ ST1 = '43.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMCSSN(MA,MC,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '-0.5905834736620182429243173169772978155668602154136946'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMCSSN',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST7
+
+ SUBROUTINE TEST8(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test inverse trigonometric functions.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+
+ CHARACTER(80) :: ST1,ST2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing inverse trigonometric routines.')")
+
+ NCASE = 51
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMACOS(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '1.2126748979730954046873545995574544481988102502510807'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMACOS',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 52
+ ST1 = '-0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMACOS(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '1.9289177556166978337752887837220484359983591491240252'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMACOS',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 53
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMASIN(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.3581214288218012145439670920822969938997744494364723'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMASIN',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 54
+ ST1 = '-0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMASIN(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '-0.3581214288218012145439670920822969938997744494364723'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMASIN',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 55
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMATAN(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.3371339561772373443347761845672381725353758541616570'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMATAN',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 56
+ ST1 = '43.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMATAN(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '1.5477326406586162039457549832092678908202994134569781'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMATAN',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST8
+
+ SUBROUTINE TEST9(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test hyperbolic functions.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+
+ CHARACTER(80) :: ST1,ST2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing hyperbolic routines.')")
+
+ NCASE = 57
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMCOSH(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '1.0620620786534654254819884264931372964608741056397718'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-49',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMCOSH',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 58
+ ST1 = '-43.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMCOSH(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '3.356291383454381441662669560464886179346554730604556E+18'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-31',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMCOSH',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 59
+ ST1 = '-0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMSINH(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '-0.3577371366153083355393138079781276622149524420386975'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMSINH',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 60
+ ST1 = '43.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMSINH(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '3.356291383454381441662669560464886179197580776059111E+18'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-31',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMSINH',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 61
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMTANH(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.3368326049912874057089491946232983472275659538703038'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMTANH',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 62
+ ST1 = '43.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMTANH(MA,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '0.9999999999999999999999999999999999999556135217341837'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMTANH',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 63
+ ST1 = '0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMCHSH(MA,ME,MC)
+ CALL FMEQ(ME,MA)
+ ST2 = '1.0620620786534654254819884264931372964608741056397718'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-49',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMCHSH',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 64
+ ST1 = '-43.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMCHSH(MA,ME,MC)
+ CALL FMEQ(ME,MA)
+ ST2 = '3.356291383454381441662669560464886179346554730604556E+18'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-31',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMCHSH',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 65
+ ST1 = '-0.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMCHSH(MA,MC,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '-0.3577371366153083355393138079781276622149524420386975'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-50',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMCHSH',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 66
+ ST1 = '43.3505154639175257731958762886597938144329896907216495'
+ CALL FMST2M(ST1,MA)
+ CALL FMCHSH(MA,MC,ME)
+ CALL FMEQ(ME,MA)
+ ST2 = '3.356291383454381441662669560464886179197580776059111E+18'
+ CALL FMST2M(ST2,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('1.0E-31',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('FMCHSH',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST9
+
+ SUBROUTINE TEST10(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Input and output testing for IM routines.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+! Logical function for comparing IM numbers.
+
+ LOGICAL IMCOMP
+
+ CHARACTER(80) :: ST1,ST2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing integer input and output routines.')")
+
+ NCASE = 67
+ CALL IMST2M('123',MA)
+ CALL IMI2M(123,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMST2M',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 68
+ ST1 = '-350515'
+ CALL IMST2M(ST1,MA)
+ CALL IMI2M(-350515,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMST2M',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 69
+ ST1 = '19895113660064588580108197261066338165074766609'
+ CALL IMST2M(ST1,MA)
+ CALL IMI2M(23,MB)
+ CALL IMI2M(34,MC)
+ CALL IMPWR(MB,MC,ME)
+ CALL IMEQ(ME,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMPWR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 70
+ ST1 = '-20800708073664542533904165663516279809808659679033703'
+ CALL IMST2M(ST1,MA)
+ CALL IMI2M(-567,MB)
+ CALL IMI2M(19,MC)
+ CALL IMPWR(MB,MC,ME)
+ CALL IMEQ(ME,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMPWR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 71
+ ST1 = '19895113660064588580108197261066338165074766609'
+ CALL IMST2M(ST1,MA)
+ CALL IMFORM('I53',MA,ST2)
+ CALL IMST2M(ST2,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMFORM',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 72
+ ST1 = '-20800708073664542533904165663516279809808659679033703'
+ CALL IMST2M(ST1,MA)
+ CALL IMFORM('I73',MA,ST2)
+ CALL IMST2M(ST2,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMFORM',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST10
+
+ SUBROUTINE TEST11(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test add and subtract for IM routines.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL IMCOMP
+
+ CHARACTER(80) :: ST1,ST2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing integer add and subtract routines.')")
+
+ NCASE = 73
+ CALL IMST2M('123',MA)
+ CALL IMST2M('789',MB)
+ CALL IMADD(MA,MB,ME)
+ CALL IMEQ(ME,MA)
+ CALL IMI2M(912,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMADD ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 74
+ ST1 = '3505154639175257731958762886597938144329896907216495'
+ CALL IMST2M(ST1,MA)
+ ST1 = '7319587628865979381443298969072164948453608247422680'
+ CALL IMST2M(ST1,MB)
+ CALL IMADD(MA,MB,ME)
+ CALL IMEQ(ME,MA)
+ ST2 = '10824742268041237113402061855670103092783505154639175'
+ CALL IMST2M(ST2,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMADD ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 75
+ ST1 = '3505154639175257731958762886597938144329896907216495'
+ CALL IMST2M(ST1,MA)
+ ST1 = '7319587628865979381443298969072164948453608247422680'
+ CALL IMST2M(ST1,MB)
+ CALL IMSUB(MA,MB,ME)
+ CALL IMEQ(ME,MA)
+ ST2 = '-3814432989690721649484536082474226804123711340206185'
+ CALL IMST2M(ST2,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMSUB ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 76
+ ST1 = '3505154639175257731958762886597938144329896907216495'
+ CALL IMST2M(ST1,MA)
+ ST1 = '3505154639175257731443298969072164948453608247422680'
+ CALL IMST2M(ST1,MB)
+ CALL IMSUB(MA,MB,ME)
+ CALL IMEQ(ME,MA)
+ ST2 = '515463917525773195876288659793815'
+ CALL IMST2M(ST2,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMSUB ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST11
+
+ SUBROUTINE TEST12(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test integer multiply and divide.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL IMCOMP
+
+ CHARACTER(80) :: ST1,ST2
+ INTEGER IREM,KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing integer multiply, divide and square routines.')")
+
+ NCASE = 77
+ CALL IMST2M('123',MA)
+ CALL IMST2M('789',MB)
+ CALL IMMPY(MA,MB,ME)
+ CALL IMEQ(ME,MA)
+ CALL IMI2M(97047,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMMPY ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 78
+ ST1 = '10430738374625018354698'
+ CALL IMST2M(ST1,MA)
+ ST1 = '2879494424799214514791045985'
+ CALL IMST2M(ST1,MB)
+ CALL IMMPY(MA,MB,ME)
+ CALL IMEQ(ME,MA)
+ ST2 = '30035252996271960952238822892375588336807158787530'
+ CALL IMST2M(ST2,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMMPY ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 79
+ CALL IMST2M('12347',MA)
+ CALL IMST2M('47',MB)
+ CALL IMDIV(MA,MB,ME)
+ CALL IMEQ(ME,MA)
+ CALL IMST2M('262',MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMDIV ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 80
+ ST1 = '2701314697583086005158008013691015597308949443159762'
+ CALL IMST2M(ST1,MA)
+ ST1 = '-978132616472842669976589722394'
+ CALL IMST2M(ST1,MB)
+ CALL IMDIV(MA,MB,ME)
+ CALL IMEQ(ME,MA)
+ CALL IMST2M('-2761705981469115610382',MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMDIV ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 81
+ CALL IMST2M('12368',MA)
+ CALL IMST2M('67',MB)
+ CALL IMMOD(MA,MB,ME)
+ CALL IMEQ(ME,MB)
+ CALL IMST2M('40',MC)
+ IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMMOD ',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 82
+ ST1 = '2701314697583086005158008013691015597308949443159762'
+ CALL IMST2M(ST1,MA)
+ ST1 = '-978132616472842669976589722394'
+ CALL IMST2M(ST1,MB)
+ CALL IMMOD(MA,MB,ME)
+ CALL IMEQ(ME,MB)
+ CALL IMST2M('450750319653685523300198865254',MC)
+ IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMMOD ',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 83
+ CALL IMST2M('1234',MA)
+ CALL IMST2M('17',MB)
+ CALL IMDIVR(MA,MB,MC,MD)
+ CALL IMEQ(MC,MA)
+ CALL IMEQ(MD,MB)
+ CALL IMST2M('72',MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMDIVR',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+ CALL IMST2M('10',MC)
+ IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMDIVR',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 84
+ ST1 = '34274652243817531418235301715935108945364446765801943'
+ CALL IMST2M(ST1,MA)
+ ST1 = '-54708769795848731641842224621693'
+ CALL IMST2M(ST1,MB)
+ CALL IMDIVR(MA,MB,MC,MD)
+ CALL IMEQ(MC,MA)
+ CALL IMEQ(MD,MB)
+ CALL IMST2M('-626492834178447772323',MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMDIVR',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+ CALL IMST2M('31059777254296217822749494999104',MC)
+ IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMDIVR',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 85
+ CALL IMST2M('4866',MA)
+ CALL IMMPYI(MA,14,ME)
+ CALL IMEQ(ME,MA)
+ CALL IMST2M('68124',MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMMPYI',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 86
+ CALL IMST2M('270131469758308600515800801369101559730894',MA)
+ CALL IMMPYI(MA,-2895,ME)
+ CALL IMEQ(ME,MA)
+ CALL IMST2M('-782030604950303398493243319963549015420938130',MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMMPYI ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 87
+ CALL IMST2M('-37179',MA)
+ CALL IMDIVI(MA,129,ME)
+ CALL IMEQ(ME,MA)
+ CALL IMST2M('-288',MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMDIVI',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 88
+ ST1 = '8267538919383255454483790743961990401918726073065738'
+ CALL IMST2M(ST1,MA)
+ CALL IMDIVI(MA,1729,ME)
+ CALL IMEQ(ME,MA)
+ ST2 = '4781688212483085861471249707323302719444028960708'
+ CALL IMST2M(ST2,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMDIVI',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 89
+ CALL IMST2M('-71792',MA)
+ CALL IMDVIR(MA,65,MC,IREM)
+ CALL IMEQ(MC,MA)
+ CALL IMST2M('-1104',MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMDVIR',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+ CALL IMI2M(IREM,MB)
+ CALL IMI2M(-32,MC)
+ IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMDVIR',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 90
+ ST1 = '97813261647284266997658972239417958580120170263408655'
+ CALL IMST2M(ST1,MA)
+ CALL IMDVIR(MA,826,MC,IREM)
+ CALL IMEQ(MC,MA)
+ ST2 = '118417992309060855929369215786220288837917881674828'
+ CALL IMST2M(ST2,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMDVIR',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+ CALL IMI2M(IREM,MB)
+ CALL IMI2M(727,MC)
+ IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMDVIR',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 91
+ CALL IMST2M('538',MA)
+ CALL IMSQR(MA,ME)
+ CALL IMEQ(ME,MA)
+ CALL IMST2M('289444',MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMSQR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 92
+ CALL IMST2M('-47818191879814587168242632',MA)
+ CALL IMSQR(MA,ME)
+ CALL IMEQ(ME,MA)
+ ST2 = '2286579474654765721668058416662636606051551222287424'
+ CALL IMST2M(ST2,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMSQR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST12
+
+ SUBROUTINE TEST13(NCASE,NERROR,KLOG)
+
+! Test conversions between FM and IM format.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP,IMCOMP
+
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing conversions between FM and IM format.')")
+
+ NCASE = 93
+ CALL IMST2M('123',MA)
+ CALL IMI2FM(MA,MB)
+ CALL FMI2M(123,MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('0',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('IMI2FM',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 94
+ CALL IMST2M('979282999076598337488362000995916',MA)
+ CALL IMI2FM(MA,MB)
+ CALL FMST2M('979282999076598337488362000995916',MC)
+ CALL FMSUB(MA,MC,MD)
+ CALL FMABS(MD,ME)
+ CALL FMEQ(ME,MD)
+ CALL FMST2M('0',MB)
+ IF (.NOT.FMCOMP(MD,'LE',MB)) THEN
+ CALL ERRPRTFM('IMI2FM',MA,'MA',MC,'MC',MD,'MD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 95
+ CALL FMST2M('123.4',MA)
+ CALL IMFM2I(MA,MB)
+ CALL IMI2M(123,MC)
+ IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMFM2I',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 96
+ CALL FMST2M('979282999076598337488362000995916',MA)
+ CALL IMFM2I(MA,MB)
+ CALL IMST2M('979282999076598337488362000995916',MC)
+ IF (.NOT.IMCOMP(MB,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMFM2I',MB,'MB',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST13
+
+ SUBROUTINE TEST14(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test integer power and GCD functions.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL IMCOMP
+
+ CHARACTER(80) :: ST1,ST2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing integer GCD and power routines.')")
+
+ NCASE = 97
+ CALL IMST2M('123',MA)
+ CALL IMST2M('789',MB)
+ CALL IMGCD(MA,MB,ME)
+ CALL IMEQ(ME,MA)
+ CALL IMI2M(3,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMGCD ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 98
+ ST1 = '431134020618556701030927835051546391752577319587628885'
+ CALL IMST2M(ST1,MA)
+ ST1 = '900309278350515463917525773195876288659793814432989640'
+ CALL IMST2M(ST1,MB)
+ CALL IMGCD(MA,MB,ME)
+ CALL IMEQ(ME,MA)
+ CALL IMST2M('615',MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMGCD ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 99
+ ST1 = '5877631675869176172956662762822298812326084745145447940'
+ CALL IMST2M(ST1,MA)
+ ST1 = '10379997509886032090765062511740075746391432253007667'
+ CALL IMST2M(ST1,MB)
+ CALL IMGCD(MA,MB,ME)
+ CALL IMEQ(ME,MA)
+ CALL IMST2M('1',MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMGCD ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 100
+ CALL IMST2M('47',MA)
+ CALL IMST2M('34',MB)
+ CALL IMPWR(MA,MB,ME)
+ CALL IMEQ(ME,MA)
+ ST2 = '710112520079088427392020925014421733344154169313556279969'
+ CALL IMST2M(ST2,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMPWR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 101
+ CALL IMST2M('2',MA)
+ CALL IMST2M('187',MB)
+ CALL IMPWR(MA,MB,ME)
+ CALL IMEQ(ME,MA)
+ ST2 = '196159429230833773869868419475239575503198607639501078528'
+ CALL IMST2M(ST2,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMPWR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 102
+ CALL IMST2M('-3',MA)
+ CALL IMST2M('101',MB)
+ CALL IMPWR(MA,MB,ME)
+ CALL IMEQ(ME,MA)
+ ST2 = '-1546132562196033993109383389296863818106322566003'
+ CALL IMST2M(ST2,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMPWR ',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST14
+
+ SUBROUTINE TEST15(ST1,ST2,NCASE,NERROR,KLOG)
+
+! Test integer modular functions.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL IMCOMP
+
+ CHARACTER(80) :: ST1,ST2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing integer modular routines.')")
+
+ NCASE = 103
+ CALL IMST2M('123',MA)
+ CALL IMST2M('789',MB)
+ CALL IMST2M('997',MC)
+ CALL IMMPYM(MA,MB,MC,ME)
+ CALL IMEQ(ME,MA)
+ CALL IMI2M(338,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMMPYM',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 104
+ ST1 = '431134020618556701030927835051546391752577319587628885'
+ CALL IMST2M(ST1,MA)
+ ST1 = '36346366019557973241042306587666640486264616086971724'
+ CALL IMST2M(ST1,MB)
+ ST1 = '900309278350515463917525773195876288659793814432989640'
+ CALL IMST2M(ST1,MC)
+ CALL IMMPYM(MA,MB,MC,ME)
+ CALL IMEQ(ME,MA)
+ ST2 = '458279704440780378752997531208983184411293504187816380'
+ CALL IMST2M(ST2,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMMPYM',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 105
+ ST1 = '914726194238000125985765939883182'
+ CALL IMST2M(ST1,MA)
+ ST1 = '-75505764717193044779376979508186553225192'
+ CALL IMST2M(ST1,MB)
+ ST1 = '18678872625055834600521936'
+ CALL IMST2M(ST1,MC)
+ CALL IMMPYM(MA,MB,MC,ME)
+ CALL IMEQ(ME,MA)
+ ST2 = '-7769745969769966093344960'
+ CALL IMST2M(ST2,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMMPYM',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 106
+ CALL IMST2M('123',MA)
+ CALL IMST2M('789',MB)
+ CALL IMST2M('997',MC)
+ CALL IMPMOD(MA,MB,MC,ME)
+ CALL IMEQ(ME,MA)
+ CALL IMI2M(240,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMPMOD',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 107
+ ST1 = '431134020618556701030927835051546391752577319587628885'
+ CALL IMST2M(ST1,MA)
+ ST1 = '36346366019557973241042306587666640486264616086971724'
+ CALL IMST2M(ST1,MB)
+ ST1 = '900309278350515463917525773195876288659793814432989640'
+ CALL IMST2M(ST1,MC)
+ CALL IMPMOD(MA,MB,MC,ME)
+ CALL IMEQ(ME,MA)
+ ST2 = '755107893576299697276281907390144058060594744720442385'
+ CALL IMST2M(ST2,MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMPMOD',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 108
+ CALL IMST2M('314159',MA)
+ CALL IMST2M('1411695892374393248272691827763664225585897550',MB)
+ CALL IMST2M('1411695892374393248272691827763664225585897551',MC)
+ CALL IMPMOD(MA,MB,MC,ME)
+ CALL IMEQ(ME,MA)
+ CALL IMST2M('1',MC)
+ IF (.NOT.IMCOMP(MA,'EQ',MC)) THEN
+ CALL ERRPRTIM('IMPMOD',MA,'MA',MC,'MC',NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST15
+
+ SUBROUTINE TEST16(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Complex input and output testing.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+! Logical function for comparing FM numbers.
+
+ LOGICAL FMCOMP
+
+ CHARACTER(160) :: STZ1,STZ2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing complex input and output routines.')")
+
+ NCASE = 109
+ CALL ZMST2M('123 + 456 i',ZA)
+ CALL ZM2I2M(123,456,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-48,ME)
+ CALL FMEQ(ME,MB)
+
+! Use the .NOT. because FMCOMP returns FALSE for special
+! cases like ZD = UNKNOWN, and these should be treated
+! as errors for these tests.
+
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMST2M',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 110
+ STZ1 = '0.3505154639175257731958762886597938144329896907216495 + ' &
+ // '0.7319587628865979381443298969072164948453608247422680 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZM2I2M(34,71,ZC)
+ CALL ZMDIVI(ZC,97,ZE)
+ CALL ZMEQ(ZE,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMST2M',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 111
+ STZ1 = '0.3505154639175257731958762886597938144329896907216495E-5 ' &
+ //'+ 0.7319587628865979381443298969072164948453608247422680D-5 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZM2I2M(34,71,ZC)
+ CALL ZMDIVI(ZC,9700000,ZE)
+ CALL ZMEQ(ZE,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-55,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMST2M',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 112
+ STZ1 = '7.699115044247787610619469026548672566371681415929204e 03 ' &
+ //'- 5.221238938053097345132743362831858407079646017699115M 03 I'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZM2I2M(87,-59,ZC)
+ CALL ZMDIVI(ZC,113,ZE)
+ CALL ZMEQ(ZE,ZC)
+ CALL ZMMPYI(ZC,10000,ZE)
+ CALL ZMEQ(ZE,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-47,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMST2M',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 113
+ STZ1 = '7.699115044247787610619469026548672566371681415929204e+3 ' &
+ //'- 5.221238938053097345132743362831858407079646017699115M+3 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMFORM('F53.33','F50.30',ZA,STZ2)
+ CALL ZMST2M(STZ2,ZA)
+ STZ1 = '7699.115044247787610619469026548673 ' &
+ // '-5221.238938053097345132743362831858 i'
+ CALL ZMST2M(STZ1,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-30,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMFORM',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 114
+ STZ1 = '7.699115044247787610619469026548672566371681415929204e+3 ' &
+ //'- 5.221238938053097345132743362831858407079646017699115M+3 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMFORM('I9','I7',ZA,STZ2)
+ CALL ZMST2M(STZ2,ZA)
+ STZ1 = '7699 -5221 i'
+ CALL ZMST2M(STZ1,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(0,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMFORM',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 115
+ STZ1 = '7.699115044247787610619469026548672566371681415929204e+3 ' &
+ //'- 5.221238938053097345132743362831858407079646017699115M+3 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMFORM('E59.50','E58.49',ZA,STZ2)
+ CALL ZMST2M(STZ2,ZA)
+ STZ1 = '7.6991150442477876106194690265486725663716814159292E3' &
+ //'- 5.221238938053097345132743362831858407079646017699E3 i'
+ CALL ZMST2M(STZ1,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-48,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMFORM',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 116
+ STZ1 = '7.699115044247787610619469026548672566371681415929204e+3 ' &
+ //'- 5.221238938053097345132743362831858407079646017699115M+3 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMFORM('1PE59.50','1PE58.49',ZA,STZ2)
+ CALL ZMST2M(STZ2,ZA)
+ CALL ZMST2M(STZ1,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-44,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMFORM',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST16
+
+ SUBROUTINE TEST17(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Test complex add and subtract.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+
+ CHARACTER(160) :: STZ1,STZ2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing complex add and subtract routines.')")
+
+ NCASE = 117
+ CALL ZMST2M('123 + 456 i',ZA)
+ CALL ZMST2M('789 - 543 i',ZB)
+ CALL ZMADD(ZA,ZB,ZE)
+ CALL ZMEQ(ZE,ZA)
+ CALL ZM2I2M(912,-87,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(0,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMADD ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 118
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ STZ1 = '.3505154639175257731958762886597938144329896907216495 ' &
+ //'+ .7319587628865979381443298969072164948453608247422680 i'
+ CALL ZMST2M(STZ1,ZB)
+ CALL ZMADD(ZA,ZB,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '1.1204269683423045342578231913146610710701578323145698 ' &
+ //'+ 0.2098348690812882036310555606240306541373962229723565 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-49,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMADD ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 119
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ STZ1 = '.3505154639175257731958762886597938144329896907216495 ' &
+ //'+ .7319587628865979381443298969072164948453608247422680 i'
+ CALL ZMST2M(STZ1,ZB)
+ CALL ZMSUB(ZA,ZB,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.4193960405072529878660706139950734422041784508712709 ' &
+ //'- 1.2540826566919076726576042331904023355533254265121795 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-49,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMSUB ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 120
+ STZ1 = '.7699115044247787610619469026548672566371681415929204E3 ' &
+ //'- .5221238938053097345132743362831858407079646017699115E3 i'
+ CALL ZMST2M(STZ1,ZA)
+ STZ1 = '.3505154639175257731958762886597938144329896907216495 ' &
+ //'+ .7319587628865979381443298969072164948453608247422680 i'
+ CALL ZMST2M(STZ1,ZB)
+ CALL ZMSUB(ZA,ZB,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '769.5609889608612352887510263662074628227351519021987045 ' &
+ //'- 522.8558525681963324514186661800930572028099625946537725 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-47,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMSUB ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST17
+
+ SUBROUTINE TEST18(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Test complex multiply, divide and square root.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+
+ CHARACTER(160) :: STZ1,STZ2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW, &
+ "(/' Testing complex multiply, divide and square root routines.')")
+
+ NCASE = 121
+ CALL ZMST2M('123 + 456 i',ZA)
+ CALL ZMST2M('789 - 543 i',ZB)
+ CALL ZMMPY(ZA,ZB,ZE)
+ CALL ZMEQ(ZE,ZA)
+ CALL ZM2I2M(344655,292995,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(0,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMMPY ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 122
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ STZ1 = '.3505154639175257731958762886597938144329896907216495 ' &
+ //'+ .7319587628865979381443298969072164948453608247422680 i'
+ CALL ZMST2M(STZ1,ZB)
+ CALL ZMMPY(ZA,ZB,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.6520390475321594745005017790347596022260742632971444 ' &
+ //'+ 0.3805309734513274336283185840707964601769911504424779 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMMPY ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 123
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ STZ1 = '.3505154639175257731958762886597938144329896907216495 ' &
+ //'+ .7319587628865979381443298969072164948453608247422680 i'
+ CALL ZMST2M(STZ1,ZB)
+ CALL ZMDIV(ZA,ZB,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '-.1705178497731560089737969128653459210208765017614861 ' &
+ //'- 1.1335073636829696356072949942949842987114804337239972 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-49,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMDIV ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 124
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMMPYI(ZA,36,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '27.7168141592920353982300884955752212389380530973451327 ' &
+ //'- 18.7964601769911504424778761061946902654867256637168142 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-48,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMMPYI',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 125
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMDIVI(ZA,37,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '2.080841903850753408275532169337479071992346328629514E-2 ' &
+ //'- 1.411145658933269552738579287251853623535039464243004E-2 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-52,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMDIVI',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 126
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMSQR(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.3201503641632077688150990680554467851828647505677813 ' &
+ //'- 0.8039783851515388832328295089670295246299631921058814 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMSQR ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 127
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMSQRT(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.9219999909012323458336720551458583330580388434229845 ' &
+ //'- 0.2831474506279259570386845864488094697732718981999941 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMSQRT',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST18
+
+ SUBROUTINE TEST19(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Test complex exponentials.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+
+ CHARACTER(160) :: STZ1,STZ2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing complex exponential routines.')")
+
+ NCASE = 128
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMEXP(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '1.8718374504057787925867989348073888855260008469310002 ' &
+ //'- 1.0770279996847678711699041910427261417963102075889234 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-49,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMEXP ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 129
+ STZ1 = '5.7699115044247787610619469026548672566371681415929204 ' &
+ //'- 4.5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMEXP(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '-60.6144766542152809520229386164396710991242264070603612 ' &
+ //'+ 314.7254994809539691403004121118801578835669635535466592 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-47,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMEXP ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 130
+ STZ1 = '1.7699115044247787610619469026548672566371681415929204 ' &
+ //'- 1.5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMIPWR(ZA,45,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '31595668743300099.70429472191424818167262151605608585179 ' &
+ //'- 19209634448276799.67717448173630165852744930837930753788 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-33,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMIPWR',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 131
+ STZ1 = '1.7699115044247787610619469026548672566371681415929204 ' &
+ //'- 1.5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMIPWR(ZA,-122,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '3.1000215641022021714480000129414241564868699479432E-46 ' &
+ //'- 1.1687846789859477815450163510927243367234863123667E-45 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-93,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMIPWR',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 132
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ STZ1 = '.3505154639175257731958762886597938144329896907216495 ' &
+ //'+ .7319587628865979381443298969072164948453608247422680 i'
+ CALL ZMST2M(STZ1,ZB)
+ CALL ZMPWR(ZA,ZB,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '1.4567089343012352449621841355636496276866203747888724 ' &
+ //'- 0.3903177712261966292764255714390622205129978923650749 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-49,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMPWR ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 133
+ STZ1 = '.3505154639175257731958762886597938144329896907216495 ' &
+ //'+ .7319587628865979381443298969072164948453608247422680 i'
+ CALL ZMST2M(STZ1,ZA)
+ STZ1 = '2.7699115044247787610619469026548672566371681415929204 ' &
+ //'- 0.5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZB)
+ CALL ZMPWR(ZA,ZB,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '-1.0053105716678380336247948739245187868180079734997482 ' &
+ // '- 0.0819537653234704467729051473979237153087038930127116 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-49,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMPWR ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 134
+ STZ1 = '0.7699115044247787610619469026548672566371681415929204 ' &
+ //'- 0.5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMRPWR(ZA,2,7,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.9653921326136512316639621651337975772631340364271270 ' &
+ //'- 0.1659768285667051396562270035411852432430188906482848 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMRPWR',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 135
+ STZ1 = '0.7699115044247787610619469026548672566371681415929204 ' &
+ //'- 0.5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMRPWR(ZA,-19,7,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '-0.0567985880053556315170006800325686036902111276420647 ' &
+ // '+ 1.2154793972711356706410882510363594270389067962568571 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-49,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMRPWR',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST19
+
+ SUBROUTINE TEST20(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Test complex logarithms.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+
+ CHARACTER(160) :: STZ1,STZ2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing complex logarithm routines.')")
+
+ NCASE = 136
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMLN(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '-0.0722949652393911311212450699415231782692434885813725 ' &
+ //'- 0.5959180055163009910007765127008371205749515965219804 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMLN ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 137
+ STZ1 = '.7699115044247787610619469026548672566371681415929204E28 ' &
+ //'- .5221238938053097345132743362831858407079646017699115E28 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMLN(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '64.4000876385938880213825156612206746345615981930242708 ' &
+ //'- 0.5959180055163009910007765127008371205749515965219804 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-48,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMLN ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 138
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMLG10(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '-0.0313973044728549715287589498363619677438302809470943 ' &
+ //'- 0.2588039014625211035392823012785304771809982053965284 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMLG10',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 139
+ STZ1 = '.7699115044247787610619469026548672566371681415929204E82 ' &
+ //'- .5221238938053097345132743362831858407079646017699115E82 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMLG10(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '81.9686026955271450284712410501636380322561697190529057 ' &
+ //'- 0.2588039014625211035392823012785304771809982053965284 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-48,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMLG10',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST20
+
+ SUBROUTINE TEST21(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Test complex trigonometric functions.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+
+ CHARACTER(160) :: STZ1,STZ2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing complex trigonometric routines.')")
+
+ NCASE = 140
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMCOS(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.8180802525254482451348613286211514555816444253416895 ' &
+ //'+ 0.3801751200076938035500853542125525088505055292851393 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMCOS ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 141
+ STZ1 = '34.7699115044247787610619469026548672566371681415929204 ' &
+ //'- 42.5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMCOS(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '-1432925478410268113.5816466154230974355002592549420099 ' &
+ //'- 309002816679456015.00151246245263842483282458519462258 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-31,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMCOS ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 142
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMSIN(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.7931260548991613428648822413402447097755865697557818 ' &
+ //'- 0.3921366045897070762848927655743167937790944353110710 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMSIN ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 143
+ STZ1 = '34.7699115044247787610619469026548672566371681415929204 ' &
+ //'- 42.5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMSIN(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '-3.090028166794560150015124624526384249047272360765358E17 ' &
+ //'+ 1.432925478410268113581646615423097435166828182950161E18 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-31,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMSIN ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 144
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMTAN(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.6141156219447569167198437040270236055089243090199979 ' &
+ //'- 0.7647270337230070156308196055474639461102792169274526 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMTAN ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 145
+ STZ1 = '35.7699115044247787610619469026548672566371681415929204 ' &
+ //'- 43.5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMTAN(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '2.068934241218867332441292427642153175237611151321340E-38 ' &
+ //'- 1.000000000000000000000000000000000000023741659169354 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-49,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMTAN ',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 146
+ STZ1 = '0.3505154639175257731958762886597938144329896907216495 ' &
+ //'+ 0.7319587628865979381443298969072164948453608247422680 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMCSSN(ZA,ZE,ZC)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '1.2022247452809115256533054407001508718694617802593324 ' &
+ //'- 0.2743936538120352873902095801531325075994392065668943 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-49,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMCSSN',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 147
+ STZ1 = '0.3505154639175257731958762886597938144329896907216495 ' &
+ //'+ 0.7319587628865979381443298969072164948453608247422680 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMCSSN(ZA,ZC,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.4395486978082638069281369170831952476351663772871008 ' &
+ //'+ 0.7505035100906417134864779281080728222900154610025883 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMCSSN',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST21
+
+ SUBROUTINE TEST22(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Test complex inverse trigonometric functions.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+
+ CHARACTER(160) :: STZ1,STZ2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing complex inverse trigonometric routines.')")
+
+ NCASE = 148
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMACOS(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.8797127900868121872960714368309657795959216549012347 ' &
+ //'+ 0.6342141347945396859119941874681961111936156338608130 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMACOS',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 149
+ STZ1 = '.7699115044247787610619469026548672566371681415929204E12 ' &
+ //'- .5221238938053097345132743362831858407079646017699115E12 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMACOS(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.5959180055163009910007767810953294528367807973983794 ' &
+ //'+28.2518733312491023865118844008522768856672089946951468 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-48,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMACOS',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 150
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMASIN(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.6910835367080844319352502548087856625026630447863182 ' &
+ //'- 0.6342141347945396859119941874681961111936156338608130 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMASIN',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 151
+ STZ1 = '.7699115044247787610619469026548672566371681415929204E13 ' &
+ //'- .5221238938053097345132743362831858407079646017699115E13 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMASIN(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.9748783212785956282305451762549693982010148111568094 ' &
+ //'-30.5544584242431480705298759613446206186670533428066404 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-48,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMASIN',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 152
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMATAN(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.7417952692265900376512911713942700568648670953521258 ' &
+ //'- 0.3162747143126729004878357203292329539837025170484857 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMATAN',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 153
+ STZ1 = '.7699115044247787610619469026548672566371681415929204E13 ' &
+ //'- .5221238938053097345132743362831858407079646017699115E13 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMATAN(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = ' 1.570796326794807650905529836436131532596233124329403 ' &
+ //'-6.033484162895927601809954710695221401671437742867605E-14 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-49,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMATAN',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST22
+
+ SUBROUTINE TEST23(STZ1,STZ2,NCASE,NERROR,KLOG)
+
+! Test complex hyperbolic functions.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ LOGICAL FMCOMP
+
+ CHARACTER(160) :: STZ1,STZ2
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing complex hyperbolic routines.')")
+
+ NCASE = 154
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMCOSH(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '1.1365975275870879962259716562608779977957563621412079 ' &
+ //'- 0.4230463404769118342540441830446134405410543954181579 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-49,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMCOSH',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 155
+ STZ1 = '34.7699115044247787610619469026548672566371681415929204 ' &
+ //'- 42.5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMCOSH(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '69552104658681.7558589320148420094288419217262200765435 ' &
+ //'+ 626163773308016.884007302915197616300902876551542156676 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-35,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMCOSH',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 156
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMSINH(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.7352399228186907963608272785465108877302444847897922 ' &
+ //'- 0.6539816592078560369158600079981127012552558121707655 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMSINH',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 157
+ STZ1 = '34.7699115044247787610619469026548672566371681415929204 ' &
+ //'- 42.5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMSINH(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '6.955210465868175585893201484192181376093291191637290E 13 ' &
+ //'+ 6.261637733080168840073029151984050820616907795167046E 14 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-35,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMSINH',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 158
+ STZ1 = '.7699115044247787610619469026548672566371681415929204 ' &
+ //'- .5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMTANH(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.7562684782933185240709480231996041186654551038993505 ' &
+ //'- 0.2938991498221693198532255749292372853685311106820169 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMTANH',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 159
+ STZ1 = '35.7699115044247787610619469026548672566371681415929204 ' &
+ //'- 43.5221238938053097345132743362831858407079646017699115 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMTANH(ZA,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '9.999999999999999999999999999998967653135180689424497E-01 ' &
+ //'+ 1.356718776492102400812550018433337461876455254467192E-31 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMTANH',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 160
+ STZ1 = '0.3505154639175257731958762886597938144329896907216495 ' &
+ //'+ 0.7319587628865979381443298969072164948453608247422680 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMCHSH(ZA,ZE,ZC)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.7900326499280864816444807620997665088044412803737969 ' &
+ //'+ 0.2390857359988804105051429301542214823277594407302781 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMCHSH',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 161
+ STZ1 = '0.3505154639175257731958762886597938144329896907216495 ' &
+ //'+ 0.7319587628865979381443298969072164948453608247422680 i'
+ CALL ZMST2M(STZ1,ZA)
+ CALL ZMCHSH(ZA,ZC,ZE)
+ CALL ZMEQ(ZE,ZA)
+ STZ2 = '0.2661087555034471983220879532235334422670297141428191 ' &
+ //'+ 0.7098057980612199357870532628105009808447460332437714 i'
+ CALL ZMST2M(STZ2,ZC)
+ CALL ZMSUB(ZA,ZC,ZD)
+ CALL ZMABS(ZD,MA)
+ CALL FMI2M(10,MB)
+ CALL FMIPWR(MB,-50,ME)
+ CALL FMEQ(ME,MB)
+ IF (.NOT.FMCOMP(MA,'LE',MB)) THEN
+ CALL ERRPRTZM('ZMCHSH',ZA,'ZA',ZC,'ZC',ZD,'ZD', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST23
+
+ SUBROUTINE TEST24(NCASE,NERROR,KLOG)
+
+! Test the = assignment interface.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+ IMPLICIT NONE
+
+ INTEGER NERROR,NCASE,KLOG
+ LOGICAL FM_COMP,IM_COMP
+
+ WRITE (KW,"(/' Testing the derived type = interface.')")
+
+ RSMALL = EPSILON(1.0)*100.0
+ DSMALL = EPSILON(1.0D0)*100.0
+ MSMALL = EPSILON(TO_FM(1))*10000.0
+ NCASE = 162
+ J4 = MFM1
+ IF (J4 /= 581) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 163
+ J4 = MIM1
+ IF (J4 /= 661) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 164
+ J4 = MZM1
+ IF (J4 /= 731) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 165
+ R4 = MFM1
+ IF (ABS((R4-581.21)/581.21) > RSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 166
+ R4 = MIM1
+ IF (ABS((R4-661.0)/661.0) > RSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 167
+ R4 = MZM1
+ IF (ABS((R4-731.51)/731.51) > RSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 168
+ D4 = MFM1
+ IF (ABS((D4-581.21D0)/581.21D0) > DSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 169
+ D4 = MIM1
+ IF (ABS((D4-661.0D0)/661.0D0) > DSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 170
+ D4 = MZM1
+ IF (ABS((D4-731.51D0)/731.51D0) > DSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 171
+ C4 = MFM1
+ IF (ABS((C4-581.21)/581.21) > RSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 172
+ C4 = MIM1
+ IF (ABS((C4-661.0)/661.0) > RSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 173
+ C4 = MZM1
+ IF (ABS((C4-(731.51,711.41))/(731.51,711.41)) > RSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 174
+ CD4 = MFM1
+ IF (ABS((CD4-581.21D0)/581.21D0) > DSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 175
+ CD4 = MIM1
+ IF (ABS((CD4-661.0D0)/661.0D0) > DSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 176
+ CD4 = MZM1
+ IF (ABS((CD4-(731.51D0,711.41D0))/(731.51D0,711.41D0)) > DSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 177
+ MFM3 = J2
+ CALL FM_I2M(131,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ST2M('0',MFM3)
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 178
+ MFM3 = R2
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = RSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 179
+ MFM3 = D2
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = DSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 180
+ MFM3 = C2
+ CALL FM_ST2M('411.11',MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = RSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 181
+ MFM3 = CD2
+ CALL FM_ST2M('431.11',MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = DSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 182
+ MFM3 = MFM1
+ CALL FM_ST2M('581.21',MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_EQ(MSMALL,MFM3)
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 183
+ MFM3 = MIM1
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ST2M('0',MFM3)
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 184
+ MFM3 = MZM1
+ CALL FM_ST2M('731.51',MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = MSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 185
+ MIM3 = J2
+ CALL IM_I2M(131,MIM4)
+ CALL IM_SUB(MIM3,MIM4,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ CALL IM_ST2M('0',MIM3)
+ IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 186
+ MIM3 = R2
+ CALL IM_ST2M('241',MIM4)
+ CALL IM_SUB(MIM3,MIM4,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ CALL IM_ST2M('0',MIM3)
+ IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 187
+ MIM3 = D2
+ CALL IM_ST2M('391',MIM4)
+ CALL IM_SUB(MIM3,MIM4,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ CALL IM_ST2M('0',MIM3)
+ IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 188
+ MIM3 = C2
+ CALL IM_ST2M('411',MIM4)
+ CALL IM_SUB(MIM3,MIM4,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ CALL IM_ST2M('0',MIM3)
+ IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 189
+ MIM3 = CD2
+ CALL IM_ST2M('431',MIM4)
+ CALL IM_SUB(MIM3,MIM4,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ CALL IM_ST2M('0',MIM3)
+ IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 190
+ MIM3 = MFM1
+ CALL IM_ST2M('581',MIM4)
+ CALL IM_SUB(MIM3,MIM4,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ CALL IM_ST2M('0',MIM3)
+ IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 191
+ MIM3 = MIM1
+ CALL IM_ST2M('661',MIM4)
+ CALL IM_SUB(MIM3,MIM4,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ CALL IM_ST2M('0',MIM3)
+ IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 192
+ MIM3 = MZM1
+ CALL IM_ST2M('731',MIM4)
+ CALL IM_SUB(MIM3,MIM4,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ CALL IM_ST2M('0',MIM3)
+ IF (IM_COMP(MIM4,'GT',MIM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 193
+ MZM3 = J2
+ CALL ZM_I2M(131,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ CALL FM_ST2M('0',MFM3)
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 194
+ MZM3 = R2
+ CALL ZM_ST2M('241.21',MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ MFM3 = RSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 195
+ MZM3 = D2
+ CALL ZM_ST2M('391.61',MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ MFM3 = DSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 196
+ MZM3 = C2
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ MFM3 = RSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 197
+ MZM3 = CD2
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ MFM3 = DSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 198
+ MZM3 = MFM1
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ MFM3 = MSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 199
+ MZM3 = MIM1
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ CALL FM_ST2M('0',MFM3)
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 200
+ MZM3 = MZM1
+ CALL ZM_ST2M('731.51 + 711.41 i',MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ MFM3 = MSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ END SUBROUTINE TEST24
+
+ SUBROUTINE TEST25(NCASE,NERROR,KLOG)
+
+! Test the derived type == interface.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ INTEGER KLOG,NCASE,NERROR
+ LOGICAL FM_COMP
+
+ WRITE (KW,"(/' Testing the derived type == interface.')")
+
+ NCASE = 201
+ M_A = 123
+ M_B = M_A
+ IF (.NOT.FM_COMP(M_A,'==',M_B)) THEN
+ CALL ERRPRT_FM(' == ',M_A,'M_A',M_B,'M_B',M_B,'M_B', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 202
+ M_A = 123
+ M_B = M_A
+ IF (.NOT.FM_COMP(M_A,'EQ',M_B)) THEN
+ CALL ERRPRT_FM(' == ',M_A,'M_A',M_B,'M_B',M_B,'M_B', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 203
+ J1 = 123
+ M_A = J1
+ IF (.NOT.(M_A == J1)) THEN
+ CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 204
+ J1 = 123
+ M_A = J1
+ IF (.NOT.(J1 == M_A)) THEN
+ CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 205
+ J1 = 123
+ M_J = J1
+ IF (.NOT.(M_J == J1)) THEN
+ CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 206
+ J1 = 123
+ M_J = J1
+ IF (.NOT.(J1 == M_J)) THEN
+ CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 207
+ J1 = 123
+ M_Z = J1
+ IF (.NOT.(M_Z == J1)) THEN
+ CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 208
+ J1 = 123
+ M_Z = J1
+ IF (.NOT.(J1 == M_Z)) THEN
+ CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 209
+ R1 = 12.3
+ M_A = R1
+ IF (.NOT.(M_A == R1)) THEN
+ CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 210
+ R1 = 12.3
+ M_A = R1
+ IF (.NOT.(R1 == M_A)) THEN
+ CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 211
+ R1 = 123
+ M_J = R1
+ IF (.NOT.(M_J == R1)) THEN
+ CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 212
+ R1 = 123
+ M_J = R1
+ IF (.NOT.(R1 == M_J)) THEN
+ CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 213
+ R1 = 12.3
+ M_Z = R1
+ IF (.NOT.(M_Z == R1)) THEN
+ CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 214
+ R1 = 12.3
+ M_Z = R1
+ IF (.NOT.(R1 == M_Z)) THEN
+ CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 215
+ D1 = 12.3
+ M_A = D1
+ IF (.NOT.(M_A == D1)) THEN
+ CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 216
+ D1 = 12.3
+ M_A = D1
+ IF (.NOT.(D1 == M_A)) THEN
+ CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 217
+ D1 = 123
+ M_J = D1
+ IF (.NOT.(M_J == D1)) THEN
+ CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 218
+ D1 = 123
+ M_J = D1
+ IF (.NOT.(D1 == M_J)) THEN
+ CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 219
+ D1 = 12.3
+ M_Z = D1
+ IF (.NOT.(M_Z == D1)) THEN
+ CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 220
+ D1 = 12.3
+ M_Z = D1
+ IF (.NOT.(D1 == M_Z)) THEN
+ CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 221
+ C1 = 12.3
+ M_A = C1
+ IF (.NOT.(M_A == C1)) THEN
+ CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 222
+ C1 = 12.3
+ M_A = C1
+ IF (.NOT.(C1 == M_A)) THEN
+ CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 223
+ C1 = 123
+ M_J = C1
+ IF (.NOT.(M_J == C1)) THEN
+ CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 224
+ C1 = 123
+ M_J = C1
+ IF (.NOT.(C1 == M_J)) THEN
+ CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 225
+ C1 = (12.3 , 45.6)
+ M_Z = C1
+ IF (.NOT.(M_Z == C1)) THEN
+ CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 226
+ C1 = (12.3 , 45.6)
+ M_Z = C1
+ IF (.NOT.(C1 == M_Z)) THEN
+ CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 227
+ CD1 = 12.3
+ M_A = CD1
+ IF (.NOT.(M_A == CD1)) THEN
+ CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 228
+ CD1 = 12.3
+ M_A = CD1
+ IF (.NOT.(CD1 == M_A)) THEN
+ CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 229
+ CD1 = 123
+ M_J = CD1
+ IF (.NOT.(M_J == CD1)) THEN
+ CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 230
+ CD1 = 123
+ M_J = CD1
+ IF (.NOT.(CD1 == M_J)) THEN
+ CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 231
+ CD1 = (12.3 , 45.6)
+ M_Z = CD1
+ IF (.NOT.(M_Z == CD1)) THEN
+ CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 232
+ CD1 = (12.3 , 45.6)
+ M_Z = CD1
+ IF (.NOT.(CD1 == M_Z)) THEN
+ CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 233
+ M_B = 12.3
+ M_A = M_B
+ IF (.NOT.(M_A == M_B)) THEN
+ CALL ERRPRT_FM(' == ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 234
+ M_B = 123
+ M_J = M_B
+ IF (.NOT.(M_J == M_B)) THEN
+ CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 235
+ M_B = 123
+ M_J = M_B
+ IF (.NOT.(M_B == M_J)) THEN
+ CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 236
+ M_B = (12.3 , 45.6)
+ M_Z = M_B
+ IF (.NOT.(M_Z == M_B)) THEN
+ CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 237
+ M_B = (12.3 , 45.6)
+ M_Z = M_B
+ IF (.NOT.(M_B == M_Z)) THEN
+ CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 238
+ M_K = 123
+ M_J = M_K
+ IF (.NOT.(M_J == M_K)) THEN
+ CALL ERRPRT_IM(' == ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 239
+ M_K = (12.3 , 45.6)
+ M_Z = M_K
+ IF (.NOT.(M_Z == M_K)) THEN
+ CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 240
+ M_K = (12.3 , 45.6)
+ M_Z = M_K
+ IF (.NOT.(M_K == M_Z)) THEN
+ CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 241
+ M_Y = (12.3 , 45.6)
+ M_Z = M_Y
+ IF (.NOT.(M_Y == M_Z)) THEN
+ CALL ERRPRT_ZM(' == ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST25
+
+ SUBROUTINE TEST26(NCASE,NERROR,KLOG)
+
+! Test the derived type /= interface.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ INTEGER KLOG,NCASE,NERROR
+ LOGICAL FM_COMP
+
+ WRITE (KW,"(/' Testing the derived type /= interface.')")
+
+ NCASE = 242
+ M_A = 123
+ M_B = 124
+ IF (.NOT.FM_COMP(M_A,'/=',M_B)) THEN
+ CALL ERRPRT_FM(' == ',M_A,'M_A',M_B,'M_B',M_B,'M_B', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 243
+ M_A = 123
+ M_B = 124
+ IF (.NOT.FM_COMP(M_A,'NE',M_B)) THEN
+ CALL ERRPRT_FM(' == ',M_A,'M_A',M_B,'M_B',M_B,'M_B', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 244
+ J1 = 123
+ M_A = 1 + J1
+ IF (.NOT.(M_A /= J1)) THEN
+ CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 245
+ J1 = 123
+ M_A = 1 + J1
+ IF (.NOT.(J1 /= M_A)) THEN
+ CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 246
+ J1 = 123
+ M_J = 1 + J1
+ IF (.NOT.(M_J /= J1)) THEN
+ CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 247
+ J1 = 123
+ M_J = 1 + J1
+ IF (.NOT.(J1 /= M_J)) THEN
+ CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 248
+ J1 = 123
+ M_Z = 1 + J1
+ IF (.NOT.(M_Z /= J1)) THEN
+ CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 249
+ J1 = 123
+ M_Z = 1 + J1
+ IF (.NOT.(J1 /= M_Z)) THEN
+ CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 250
+ R1 = 12.3
+ M_A = 1 + R1
+ IF (.NOT.(M_A /= R1)) THEN
+ CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 251
+ R1 = 12.3
+ M_A = 1 + R1
+ IF (.NOT.(R1 /= M_A)) THEN
+ CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 252
+ R1 = 123
+ M_J = 1 + R1
+ IF (.NOT.(M_J /= R1)) THEN
+ CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 253
+ R1 = 123
+ M_J = 1 + R1
+ IF (.NOT.(R1 /= M_J)) THEN
+ CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 254
+ R1 = 12.3
+ M_Z = 1 + R1
+ IF (.NOT.(M_Z /= R1)) THEN
+ CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 255
+ R1 = 12.3
+ M_Z = 1 + R1
+ IF (.NOT.(R1 /= M_Z)) THEN
+ CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 256
+ D1 = 12.3
+ M_A = 1 + D1
+ IF (.NOT.(M_A /= D1)) THEN
+ CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 257
+ D1 = 12.3
+ M_A = 1 + D1
+ IF (.NOT.(D1 /= M_A)) THEN
+ CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 258
+ D1 = 123
+ M_J = 1 + D1
+ IF (.NOT.(M_J /= D1)) THEN
+ CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 259
+ D1 = 123
+ M_J = 1 + D1
+ IF (.NOT.(D1 /= M_J)) THEN
+ CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 260
+ D1 = 12.3
+ M_Z = 1 + D1
+ IF (.NOT.(M_Z /= D1)) THEN
+ CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 261
+ D1 = 12.3
+ M_Z = 1 + D1
+ IF (.NOT.(D1 /= M_Z)) THEN
+ CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 262
+ C1 = 12.3
+ M_A = 1 + C1
+ IF (.NOT.(M_A /= C1)) THEN
+ CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 263
+ C1 = 12.3
+ M_A = 1 + C1
+ IF (.NOT.(C1 /= M_A)) THEN
+ CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 264
+ C1 = 123
+ M_J = 1 + C1
+ IF (.NOT.(M_J /= C1)) THEN
+ CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 265
+ C1 = 123
+ M_J = 1 + C1
+ IF (.NOT.(C1 /= M_J)) THEN
+ CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 266
+ C1 = (12.3 , 45.6)
+ M_Z = 1 + C1
+ IF (.NOT.(M_Z /= C1)) THEN
+ CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 267
+ C1 = (12.3 , 45.6)
+ M_Z = 1 + C1
+ IF (.NOT.(C1 /= M_Z)) THEN
+ CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 268
+ CD1 = 12.3
+ M_A = 1 + CD1
+ IF (.NOT.(M_A /= CD1)) THEN
+ CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 269
+ CD1 = 12.3
+ M_A = 1 + CD1
+ IF (.NOT.(CD1 /= M_A)) THEN
+ CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 270
+ CD1 = 123
+ M_J = 1 + CD1
+ IF (.NOT.(M_J /= CD1)) THEN
+ CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 271
+ CD1 = 123
+ M_J = 1 + CD1
+ IF (.NOT.(CD1 /= M_J)) THEN
+ CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 272
+ CD1 = (12.3 , 45.6)
+ M_Z = 1 + CD1
+ IF (.NOT.(M_Z /= CD1)) THEN
+ CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 273
+ CD1 = (12.3 , 45.6)
+ M_Z = 1 + CD1
+ IF (.NOT.(CD1 /= M_Z)) THEN
+ CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 274
+ M_B = 12.3
+ M_A = 1 + M_B
+ IF (.NOT.(M_A /= M_B)) THEN
+ CALL ERRPRT_FM(' /= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 275
+ M_B = 123
+ M_J = 1 + M_B
+ IF (.NOT.(M_J /= M_B)) THEN
+ CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 276
+ M_B = 123
+ M_J = 1 + M_B
+ IF (.NOT.(M_B /= M_J)) THEN
+ CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 277
+ M_B = (12.3 , 45.6)
+ M_Z = 1 + M_B
+ IF (.NOT.(M_Z /= M_B)) THEN
+ CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 278
+ M_B = (12.3 , 45.6)
+ M_Z = 1 + M_B
+ IF (.NOT.(M_B /= M_Z)) THEN
+ CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 279
+ M_K = 123
+ M_J = 1 + M_K
+ IF (.NOT.(M_J /= M_K)) THEN
+ CALL ERRPRT_IM(' /= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 280
+ M_K = (12.3 , 45.6)
+ M_Z = 1 + M_K
+ IF (.NOT.(M_Z /= M_K)) THEN
+ CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 281
+ M_K = (12.3 , 45.6)
+ M_Z = 1 + M_K
+ IF (.NOT.(M_K /= M_Z)) THEN
+ CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 282
+ M_Y = (12.3 , 45.6)
+ M_Z = 1 + M_Y
+ IF (.NOT.(M_Y /= M_Z)) THEN
+ CALL ERRPRT_ZM(' /= ',M_Z,'M_Z',M_Z,'M_Z',M_Z,'M_Z', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST26
+
+ SUBROUTINE TEST27(NCASE,NERROR,KLOG)
+
+! Test the derived type > interface.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ INTEGER KLOG,NCASE,NERROR
+ LOGICAL FM_COMP
+
+ WRITE (KW,"(/' Testing the derived type > interface.')")
+
+ NCASE = 283
+ M_A = 125
+ M_B = 124
+ IF (.NOT.FM_COMP(M_A,'>',M_B)) THEN
+ CALL ERRPRT_FM(' > ',M_A,'M_A',M_B,'M_B',M_B,'M_B', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 284
+ M_A = 125
+ M_B = 124
+ IF (.NOT.FM_COMP(M_A,'GT',M_B)) THEN
+ CALL ERRPRT_FM(' > ',M_A,'M_A',M_B,'M_B',M_B,'M_B', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 285
+ J1 = 123
+ M_A = J1 + 1
+ IF (.NOT.(M_A > J1)) THEN
+ CALL ERRPRT_FM(' > ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 286
+ J1 = 123
+ M_A = J1 - 1
+ IF (.NOT.(J1 > M_A)) THEN
+ CALL ERRPRT_FM(' > ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 287
+ J1 = 123
+ M_J = J1 + 1
+ IF (.NOT.(M_J > J1)) THEN
+ CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 288
+ J1 = 123
+ M_J = J1 - 1
+ IF (.NOT.(J1 > M_J)) THEN
+ CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 289
+ R1 = 12.3
+ M_A = R1 + 1
+ IF (.NOT.(M_A > R1)) THEN
+ CALL ERRPRT_FM(' > ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 290
+ R1 = 12.3
+ M_A = R1 - 1
+ IF (.NOT.(R1 > M_A)) THEN
+ CALL ERRPRT_FM(' > ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 291
+ R1 = 123
+ M_J = R1 + 1
+ IF (.NOT.(M_J > R1)) THEN
+ CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 292
+ R1 = 123
+ M_J = R1 - 1
+ IF (.NOT.(R1 > M_J)) THEN
+ CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 293
+ D1 = 12.3
+ M_A = D1 + 1
+ IF (.NOT.(M_A > D1)) THEN
+ CALL ERRPRT_FM(' > ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 294
+ D1 = 12.3
+ M_A = D1 - 1
+ IF (.NOT.(D1 > M_A)) THEN
+ CALL ERRPRT_FM(' > ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 295
+ D1 = 123
+ M_J = D1 + 1
+ IF (.NOT.(M_J > D1)) THEN
+ CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 296
+ D1 = 123
+ M_J = D1 - 1
+ IF (.NOT.(D1 > M_J)) THEN
+ CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 297
+ M_B = 12.3
+ M_A = M_B + 1
+ IF (.NOT.(M_A > M_B)) THEN
+ CALL ERRPRT_FM(' > ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 298
+ M_B = 123
+ M_J = M_B + 1
+ IF (.NOT.(M_J > M_B)) THEN
+ CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 299
+ M_B = 123
+ M_J = M_B - 1
+ IF (.NOT.(M_B > M_J)) THEN
+ CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 300
+ M_K = 123
+ M_J = M_K + 1
+ IF (.NOT.(M_J > M_K)) THEN
+ CALL ERRPRT_IM(' > ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST27
+
+ SUBROUTINE TEST28(NCASE,NERROR,KLOG)
+
+! Test the derived type >= interface.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ INTEGER KLOG,NCASE,NERROR
+ LOGICAL FM_COMP
+
+ WRITE (KW,"(/' Testing the derived type >= interface.')")
+
+ NCASE = 301
+ M_A = 125
+ M_B = 124
+ IF (.NOT.FM_COMP(M_A,'>=',M_B)) THEN
+ CALL ERRPRT_FM(' >= ',M_A,'M_A',M_B,'M_B',M_B,'M_B', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 302
+ M_A = 125
+ M_B = 124
+ IF (.NOT.FM_COMP(M_A,'GE',M_B)) THEN
+ CALL ERRPRT_FM(' >= ',M_A,'M_A',M_B,'M_B',M_B,'M_B', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 303
+ J1 = 123
+ M_A = J1 + 1
+ IF (.NOT.(M_A >= J1)) THEN
+ CALL ERRPRT_FM(' >= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 304
+ J1 = 123
+ M_A = J1 - 1
+ IF (.NOT.(J1 >= M_A)) THEN
+ CALL ERRPRT_FM(' >= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 305
+ J1 = 123
+ M_J = J1 + 1
+ IF (.NOT.(M_J >= J1)) THEN
+ CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 306
+ J1 = 123
+ M_J = J1 - 1
+ IF (.NOT.(J1 >= M_J)) THEN
+ CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 307
+ R1 = 12.3
+ M_A = R1 + 1
+ IF (.NOT.(M_A >= R1)) THEN
+ CALL ERRPRT_FM(' >= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 308
+ R1 = 12.3
+ M_A = R1 - 1
+ IF (.NOT.(R1 >= M_A)) THEN
+ CALL ERRPRT_FM(' >= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 309
+ R1 = 123
+ M_J = R1 + 1
+ IF (.NOT.(M_J >= R1)) THEN
+ CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 310
+ R1 = 123
+ M_J = R1 - 1
+ IF (.NOT.(R1 >= M_J)) THEN
+ CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 311
+ D1 = 12.3
+ M_A = D1 + 1
+ IF (.NOT.(M_A >= D1)) THEN
+ CALL ERRPRT_FM(' >= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 312
+ D1 = 12.3
+ M_A = D1 - 1
+ IF (.NOT.(D1 >= M_A)) THEN
+ CALL ERRPRT_FM(' >= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 313
+ D1 = 123
+ M_J = D1 + 1
+ IF (.NOT.(M_J >= D1)) THEN
+ CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 314
+ D1 = 123
+ M_J = D1 - 1
+ IF (.NOT.(D1 >= M_J)) THEN
+ CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 315
+ M_B = 12.3
+ M_A = M_B + 1
+ IF (.NOT.(M_A >= M_B)) THEN
+ CALL ERRPRT_FM(' >= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 316
+ M_B = 123
+ M_J = M_B + 1
+ IF (.NOT.(M_J >= M_B)) THEN
+ CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 317
+ M_B = 123
+ M_J = M_B - 1
+ IF (.NOT.(M_B >= M_J)) THEN
+ CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 318
+ M_K = 123
+ M_J = M_K + 1
+ IF (.NOT.(M_J >= M_K)) THEN
+ CALL ERRPRT_IM(' >= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST28
+
+ SUBROUTINE TEST29(NCASE,NERROR,KLOG)
+
+! Test the derived type < interface.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ INTEGER KLOG,NCASE,NERROR
+ LOGICAL FM_COMP
+
+ WRITE (KW,"(/' Testing the derived type < interface.')")
+
+ NCASE = 319
+ M_A = 123
+ M_B = 124
+ IF (.NOT.FM_COMP(M_A,'<',M_B)) THEN
+ CALL ERRPRT_FM(' < ',M_A,'M_A',M_B,'M_B',M_B,'M_B', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 320
+ M_A = 123
+ M_B = 124
+ IF (.NOT.FM_COMP(M_A,'LT',M_B)) THEN
+ CALL ERRPRT_FM(' < ',M_A,'M_A',M_B,'M_B',M_B,'M_B', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 321
+ J1 = 123
+ M_A = J1 - 2
+ IF (.NOT.(M_A < J1)) THEN
+ CALL ERRPRT_FM(' < ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 322
+ J1 = 123
+ M_A = J1 + 2
+ IF (.NOT.(J1 < M_A)) THEN
+ CALL ERRPRT_FM(' < ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 323
+ J1 = 123
+ M_J = J1 - 2
+ IF (.NOT.(M_J < J1)) THEN
+ CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 324
+ J1 = 123
+ M_J = J1 + 2
+ IF (.NOT.(J1 < M_J)) THEN
+ CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 325
+ R1 = 12.3
+ M_A = R1 - 2
+ IF (.NOT.(M_A < R1)) THEN
+ CALL ERRPRT_FM(' < ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 326
+ R1 = 12.3
+ M_A = R1 + 2
+ IF (.NOT.(R1 < M_A)) THEN
+ CALL ERRPRT_FM(' < ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 327
+ R1 = 123
+ M_J = R1 - 2
+ IF (.NOT.(M_J < R1)) THEN
+ CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 328
+ R1 = 123
+ M_J = R1 + 2
+ IF (.NOT.(R1 < M_J)) THEN
+ CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 329
+ D1 = 12.3
+ M_A = D1 - 2
+ IF (.NOT.(M_A < D1)) THEN
+ CALL ERRPRT_FM(' < ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 330
+ D1 = 12.3
+ M_A = D1 + 2
+ IF (.NOT.(D1 < M_A)) THEN
+ CALL ERRPRT_FM(' < ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 331
+ D1 = 123
+ M_J = D1 - 2
+ IF (.NOT.(M_J < D1)) THEN
+ CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 332
+ D1 = 123
+ M_J = D1 + 2
+ IF (.NOT.(D1 < M_J)) THEN
+ CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 333
+ M_B = 12.3
+ M_A = M_B - 2
+ IF (.NOT.(M_A < M_B)) THEN
+ CALL ERRPRT_FM(' < ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 334
+ M_B = 123
+ M_J = M_B - 2
+ IF (.NOT.(M_J < M_B)) THEN
+ CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 335
+ M_B = 123
+ M_J = M_B + 2
+ IF (.NOT.(M_B < M_J)) THEN
+ CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 336
+ M_K = 123
+ M_J = M_K - 2
+ IF (.NOT.(M_J < M_K)) THEN
+ CALL ERRPRT_IM(' < ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST29
+
+ SUBROUTINE TEST30(NCASE,NERROR,KLOG)
+
+! Test the derived type <= interface.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ INTEGER KLOG,NCASE,NERROR
+ LOGICAL FM_COMP
+
+ WRITE (KW,"(/' Testing the derived type <= interface.')")
+
+ NCASE = 337
+ M_A = 123
+ M_B = 124
+ IF (.NOT.FM_COMP(M_A,'<=',M_B)) THEN
+ CALL ERRPRT_FM(' <= ',M_A,'M_A',M_B,'M_B',M_B,'M_B', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 338
+ M_A = 123
+ M_B = 124
+ IF (.NOT.FM_COMP(M_A,'LE',M_B)) THEN
+ CALL ERRPRT_FM(' <= ',M_A,'M_A',M_B,'M_B',M_B,'M_B', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 339
+ J1 = 123
+ M_A = J1 - 2
+ IF (.NOT.(M_A <= J1)) THEN
+ CALL ERRPRT_FM(' <= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 340
+ J1 = 123
+ M_A = J1 + 2
+ IF (.NOT.(J1 <= M_A)) THEN
+ CALL ERRPRT_FM(' <= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 341
+ J1 = 123
+ M_J = J1 - 2
+ IF (.NOT.(M_J <= J1)) THEN
+ CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 342
+ J1 = 123
+ M_J = J1 + 2
+ IF (.NOT.(J1 <= M_J)) THEN
+ CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 343
+ R1 = 12.3
+ M_A = R1 - 2
+ IF (.NOT.(M_A <= R1)) THEN
+ CALL ERRPRT_FM(' <= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 344
+ R1 = 12.3
+ M_A = R1 + 2
+ IF (.NOT.(R1 <= M_A)) THEN
+ CALL ERRPRT_FM(' <= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 345
+ R1 = 123
+ M_J = R1 - 2
+ IF (.NOT.(M_J <= R1)) THEN
+ CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 346
+ R1 = 123
+ M_J = R1 + 2
+ IF (.NOT.(R1 <= M_J)) THEN
+ CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 347
+ D1 = 12.3
+ M_A = D1 - 2
+ IF (.NOT.(M_A <= D1)) THEN
+ CALL ERRPRT_FM(' <= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 348
+ D1 = 12.3
+ M_A = D1 + 2
+ IF (.NOT.(D1 <= M_A)) THEN
+ CALL ERRPRT_FM(' <= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 349
+ D1 = 123
+ M_J = D1 - 2
+ IF (.NOT.(M_J <= D1)) THEN
+ CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 350
+ D1 = 123
+ M_J = D1 + 2
+ IF (.NOT.(D1 <= M_J)) THEN
+ CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 351
+ M_B = 12.3
+ M_A = M_B - 2
+ IF (.NOT.(M_A <= M_B)) THEN
+ CALL ERRPRT_FM(' <= ',M_A,'M_A',M_A,'M_A',M_A,'M_A', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 352
+ M_B = 123
+ M_J = M_B - 2
+ IF (.NOT.(M_J <= M_B)) THEN
+ CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 353
+ M_B = 123
+ M_J = M_B + 2
+ IF (.NOT.(M_B <= M_J)) THEN
+ CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 354
+ M_K = 123
+ M_J = M_K - 2
+ IF (.NOT.(M_J <= M_K)) THEN
+ CALL ERRPRT_IM(' <= ',M_J,'M_J',M_J,'M_J', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST30
+
+ SUBROUTINE TEST31(NCASE,NERROR,KLOG)
+
+! Test the '+' arithmetic operator.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+ IMPLICIT NONE
+
+ INTEGER KLOG,NERROR,NCASE
+
+ WRITE (KW,"(/' Testing the derived type + interface.')")
+
+ RSMALL = EPSILON(1.0)*100.0
+ DSMALL = EPSILON(1.0D0)*100.0
+
+ NCASE = 355
+ MFM3 = J2 + MFM1
+ CALL FM_ST2M('131',MFM4)
+ CALL FM_ADD(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 356
+ MIM3 = J2 + MIM1
+ CALL IM_ST2M('131',MIM4)
+ CALL IM_ADD(MIM4,MIM1,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 357
+ MZM3 = J2 + MZM1
+ CALL ZM_ST2M('131',MZM4)
+ CALL ZM_ADD(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 358
+ MFM3 = R2 + MFM1
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_ADD(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 359
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_ST2M('661',MFM3)
+ CALL FM_ADD(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = R2 + MIM1
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 360
+ MZM3 = R2 + MZM1
+ CALL ZM_ST2M('241.21',MZM4)
+ CALL ZM_ADD(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 361
+ MFM3 = D2 + MFM1
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_ADD(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 362
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_ST2M('661',MFM3)
+ CALL FM_ADD(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = D2 + MIM1
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 363
+ MZM3 = D2 + MZM1
+ CALL ZM_ST2M('391.61',MZM4)
+ CALL ZM_ADD(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 364
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_ST2M('581.21',MZM3)
+ CALL ZM_ADD(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = C2 + MFM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 365
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_ST2M('661',MZM3)
+ CALL ZM_ADD(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = C2 + MIM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 366
+ MZM3 = C2 + MZM1
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_ADD(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 367
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_ST2M('581.21',MZM3)
+ CALL ZM_ADD(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = CD2 + MFM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 368
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_ST2M('661',MZM3)
+ CALL ZM_ADD(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = CD2 + MIM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 369
+ MZM3 = CD2 + MZM1
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_ADD(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 370
+ MFM3 = MFM1 + J2
+ CALL FM_ST2M('131',MFM4)
+ CALL FM_ADD(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 371
+ MFM3 = MFM1 + R2
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_ADD(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 372
+ MFM3 = MFM1 + D2
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_ADD(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 373
+ CALL ZM_ST2M('581.21',MZM3)
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_ADD(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MFM1 + C2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 374
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_ADD(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MFM1 + CD2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 375
+ MFM3 = MFM1 + MFM2
+ CALL FM_ADD(MFM1,MFM2,MFM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 376
+ MFM3 = MFM1 + MIM1
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_ADD(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 377
+ MZM3 = MFM1 + MZM1
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_ADD(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 378
+ MIM3 = MIM1 + J2
+ CALL IM_ST2M('131',MIM4)
+ CALL IM_ADD(MIM1,MIM4,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 379
+ CALL FM_ST2M('241.21',MFM3)
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_ADD(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = MIM1 + R2
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 380
+ CALL FM_ST2M('391.61',MFM3)
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_ADD(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = MIM1 + D2
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 381
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM3)
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_ADD(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MIM1 + C2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 382
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_ADD(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MIM1 + CD2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 383
+ MFM3 = MIM1 + MFM1
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_ADD(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 384
+ MIM3 = MIM1 + MIM2
+ CALL IM_ADD(MIM1,MIM2,MIM4)
+ IF (MIM4 /= MIM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 385
+ MZM3 = MIM1 + MZM1
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_ADD(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 386
+ MZM3 = MZM1 + J2
+ CALL ZM_ST2M('131',MZM4)
+ CALL ZM_ADD(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 387
+ MZM3 = MZM1 + R2
+ CALL ZM_ST2M('241.21',MZM4)
+ CALL ZM_ADD(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 388
+ MZM3 = MZM1 + D2
+ CALL ZM_ST2M('391.61',MZM4)
+ CALL ZM_ADD(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 389
+ MZM3 = MZM1 + C2
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_ADD(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 390
+ MZM3 = MZM1 + CD2
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_ADD(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 391
+ MZM3 = MZM1 + MFM1
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_ADD(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 392
+ MZM3 = MZM1 + MIM1
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_ADD(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 393
+ MZM3 = MZM1 + MZM2
+ CALL ZM_ADD(MZM1,MZM2,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 394
+ MFM3 = +MFM1
+ CALL FM_EQ(MFM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 395
+ MIM3 = +MIM1
+ CALL IM_EQ(MIM1,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 396
+ MZM3 = +MZM1
+ CALL ZM_EQ(MZM1,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ END SUBROUTINE TEST31
+
+ SUBROUTINE TEST32(NCASE,NERROR,KLOG)
+
+! Test the '-' arithmetic operator.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+ IMPLICIT NONE
+
+ INTEGER KLOG,NERROR,NCASE
+
+ WRITE (KW,"(/' Testing the derived type - interface.')")
+
+ RSMALL = EPSILON(1.0)*100.0
+ DSMALL = EPSILON(1.0D0)*100.0
+
+ NCASE = 397
+ MFM3 = J2 - MFM1
+ CALL FM_ST2M('131',MFM4)
+ CALL FM_SUB(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 398
+ MIM3 = J2 - MIM1
+ CALL IM_ST2M('131',MIM4)
+ CALL IM_SUB(MIM4,MIM1,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 399
+ MZM3 = J2 - MZM1
+ CALL ZM_ST2M('131',MZM4)
+ CALL ZM_SUB(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 400
+ MFM3 = R2 - MFM1
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_SUB(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 401
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_ST2M('661',MFM3)
+ CALL FM_SUB(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = R2 - MIM1
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 402
+ MZM3 = R2 - MZM1
+ CALL ZM_ST2M('241.21',MZM4)
+ CALL ZM_SUB(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 403
+ MFM3 = D2 - MFM1
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_SUB(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 404
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_ST2M('661',MFM3)
+ CALL FM_SUB(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = D2 - MIM1
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 405
+ MZM3 = D2 - MZM1
+ CALL ZM_ST2M('391.61',MZM4)
+ CALL ZM_SUB(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 406
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_ST2M('581.21',MZM3)
+ CALL ZM_SUB(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = C2 - MFM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 407
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_ST2M('661',MZM3)
+ CALL ZM_SUB(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = C2 - MIM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 408
+ MZM3 = C2 - MZM1
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_SUB(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 409
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_ST2M('581.21',MZM3)
+ CALL ZM_SUB(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = CD2 - MFM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 410
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_ST2M('661',MZM3)
+ CALL ZM_SUB(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = CD2 - MIM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 411
+ MZM3 = CD2 - MZM1
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_SUB(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 412
+ MFM3 = MFM1 - J2
+ CALL FM_ST2M('131',MFM4)
+ CALL FM_SUB(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 413
+ MFM3 = MFM1 - R2
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_SUB(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 414
+ MFM3 = MFM1 - D2
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_SUB(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 415
+ CALL ZM_ST2M('581.21',MZM3)
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MFM1 - C2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 416
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_SUB(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MFM1 - CD2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 417
+ MFM3 = MFM1 - MFM2
+ CALL FM_SUB(MFM1,MFM2,MFM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 418
+ MFM3 = MFM1 - MIM1
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_SUB(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 419
+ MZM3 = MFM1 - MZM1
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_SUB(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 420
+ MIM3 = MIM1 - J2
+ CALL IM_ST2M('131',MIM4)
+ CALL IM_SUB(MIM1,MIM4,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 421
+ CALL FM_ST2M('241.21',MFM3)
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_SUB(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = MIM1 - R2
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 422
+ CALL FM_ST2M('391.61',MFM3)
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_SUB(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = MIM1 - D2
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 423
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM3)
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_SUB(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MIM1 - C2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 424
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_SUB(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MIM1 - CD2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 425
+ MFM3 = MIM1 - MFM1
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_SUB(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 426
+ MIM3 = MIM1 - MIM2
+ CALL IM_SUB(MIM1,MIM2,MIM4)
+ IF (MIM4 /= MIM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 427
+ MZM3 = MIM1 - MZM1
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_SUB(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 428
+ MZM3 = MZM1 - J2
+ CALL ZM_ST2M('131',MZM4)
+ CALL ZM_SUB(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 429
+ MZM3 = MZM1 - R2
+ CALL ZM_ST2M('241.21',MZM4)
+ CALL ZM_SUB(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 430
+ MZM3 = MZM1 - D2
+ CALL ZM_ST2M('391.61',MZM4)
+ CALL ZM_SUB(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 431
+ MZM3 = MZM1 - C2
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_SUB(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 432
+ MZM3 = MZM1 - CD2
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_SUB(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 433
+ MZM3 = MZM1 - MFM1
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_SUB(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 434
+ MZM3 = MZM1 - MIM1
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_SUB(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 435
+ MZM3 = MZM1 - MZM2
+ CALL ZM_SUB(MZM1,MZM2,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 436
+ MFM3 = -MFM1
+ CALL FM_I2M(0,MFM4)
+ CALL FM_SUB(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 437
+ MIM3 = -MIM1
+ CALL IM_I2M(0,MIM4)
+ CALL IM_SUB(MIM4,MIM1,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 438
+ MZM3 = -MZM1
+ CALL ZM_I2M(0,MZM4)
+ CALL ZM_SUB(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ END SUBROUTINE TEST32
+
+ SUBROUTINE TEST33(NCASE,NERROR,KLOG)
+
+! Test the '*' arithmetic operator.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+ IMPLICIT NONE
+
+ INTEGER KLOG,NERROR,NCASE
+
+ WRITE (KW,"(/' Testing the derived type * interface.')")
+
+ RSMALL = EPSILON(1.0)*100.0
+ DSMALL = EPSILON(1.0D0)*100.0
+
+ NCASE = 439
+ MFM3 = J2 * MFM1
+ CALL FM_ST2M('131',MFM4)
+ CALL FM_MPY(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 440
+ MIM3 = J2 * MIM1
+ CALL IM_ST2M('131',MIM4)
+ CALL IM_MPY(MIM4,MIM1,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 441
+ MZM3 = J2 * MZM1
+ CALL ZM_ST2M('131',MZM4)
+ CALL ZM_MPY(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 442
+ MFM3 = R2 * MFM1
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_MPY(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 443
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_ST2M('661',MFM3)
+ CALL FM_MPY(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = R2 * MIM1
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 444
+ MZM3 = R2 * MZM1
+ CALL ZM_ST2M('241.21',MZM4)
+ CALL ZM_MPY(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 445
+ MFM3 = D2 * MFM1
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_MPY(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 446
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_ST2M('661',MFM3)
+ CALL FM_MPY(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = D2 * MIM1
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 447
+ MZM3 = D2 * MZM1
+ CALL ZM_ST2M('391.61',MZM4)
+ CALL ZM_MPY(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 448
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_ST2M('581.21',MZM3)
+ CALL ZM_MPY(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = C2 * MFM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 449
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_ST2M('661',MZM3)
+ CALL ZM_MPY(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = C2 * MIM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 450
+ MZM3 = C2 * MZM1
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_MPY(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 451
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_ST2M('581.21',MZM3)
+ CALL ZM_MPY(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = CD2 * MFM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 452
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_ST2M('661',MZM3)
+ CALL ZM_MPY(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = CD2 * MIM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 453
+ MZM3 = CD2 * MZM1
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_MPY(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 454
+ MFM3 = MFM1 * J2
+ CALL FM_ST2M('131',MFM4)
+ CALL FM_MPY(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 455
+ MFM3 = MFM1 * R2
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_MPY(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 456
+ MFM3 = MFM1 * D2
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_MPY(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 457
+ CALL ZM_ST2M('581.21',MZM3)
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_MPY(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MFM1 * C2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 458
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_MPY(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MFM1 * CD2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 459
+ MFM3 = MFM1 * MFM2
+ CALL FM_MPY(MFM1,MFM2,MFM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 460
+ MFM3 = MFM1 * MIM1
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_MPY(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 461
+ MZM3 = MFM1 * MZM1
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_MPY(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 462
+ MIM3 = MIM1 * J2
+ CALL IM_ST2M('131',MIM4)
+ CALL IM_MPY(MIM1,MIM4,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 463
+ CALL FM_ST2M('241.21',MFM3)
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_MPY(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = MIM1 * R2
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 464
+ CALL FM_ST2M('391.61',MFM3)
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_MPY(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = MIM1 * D2
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 465
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM3)
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_MPY(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MIM1 * C2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 466
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_MPY(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MIM1 * CD2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 467
+ MFM3 = MIM1 * MFM1
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_MPY(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 468
+ MIM3 = MIM1 * MIM2
+ CALL IM_MPY(MIM1,MIM2,MIM4)
+ IF (MIM4 /= MIM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 469
+ MZM3 = MIM1 * MZM1
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_MPY(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 470
+ MZM3 = MZM1 * J2
+ CALL ZM_ST2M('131',MZM4)
+ CALL ZM_MPY(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 471
+ MZM3 = MZM1 * R2
+ CALL ZM_ST2M('241.21',MZM4)
+ CALL ZM_MPY(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 472
+ MZM3 = MZM1 * D2
+ CALL ZM_ST2M('391.61',MZM4)
+ CALL ZM_MPY(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 473
+ MZM3 = MZM1 * C2
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_MPY(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 474
+ MZM3 = MZM1 * CD2
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_MPY(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 475
+ MZM3 = MZM1 * MFM1
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_MPY(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 476
+ MZM3 = MZM1 * MIM1
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_MPY(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 477
+ MZM3 = MZM1 * MZM2
+ CALL ZM_MPY(MZM1,MZM2,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ END SUBROUTINE TEST33
+
+ SUBROUTINE TEST34(NCASE,NERROR,KLOG)
+
+! Test the '/' arithmetic operator.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+ IMPLICIT NONE
+
+ INTEGER KLOG,NERROR,NCASE
+
+ WRITE (KW,"(/' Testing the derived type / interface.')")
+
+ RSMALL = EPSILON(1.0)*100.0
+ DSMALL = EPSILON(1.0D0)*100.0
+
+ NCASE = 478
+ MFM3 = J2 / MFM1
+ CALL FM_ST2M('131',MFM4)
+ CALL FM_DIV(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 479
+ MIM3 = J2 / MIM1
+ CALL IM_ST2M('131',MIM4)
+ CALL IM_DIV(MIM4,MIM1,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 480
+ MZM3 = J2 / MZM1
+ CALL ZM_ST2M('131',MZM4)
+ CALL ZM_DIV(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 481
+ MFM3 = R2 / MFM1
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_DIV(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 482
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_ST2M('661',MFM3)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = R2 / MIM1
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 483
+ MZM3 = R2 / MZM1
+ CALL ZM_ST2M('241.21',MZM4)
+ CALL ZM_DIV(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 484
+ MFM3 = D2 / MFM1
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_DIV(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 485
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_ST2M('661',MFM3)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = D2 / MIM1
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 486
+ MZM3 = D2 / MZM1
+ CALL ZM_ST2M('391.61',MZM4)
+ CALL ZM_DIV(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 487
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_ST2M('581.21',MZM3)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = C2 / MFM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 488
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_ST2M('661',MZM3)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = C2 / MIM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 489
+ MZM3 = C2 / MZM1
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_DIV(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 490
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_ST2M('581.21',MZM3)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = CD2 / MFM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 491
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_ST2M('661',MZM3)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = CD2 / MIM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 492
+ MZM3 = CD2 / MZM1
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_DIV(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 493
+ MFM3 = MFM1 / J2
+ CALL FM_ST2M('131',MFM4)
+ CALL FM_DIV(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 494
+ MFM3 = MFM1 / R2
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_DIV(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 495
+ MFM3 = MFM1 / D2
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_DIV(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 496
+ CALL ZM_ST2M('581.21',MZM3)
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_DIV(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MFM1 / C2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 497
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MFM1 / CD2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 498
+ MFM3 = MFM1 / MFM2
+ CALL FM_DIV(MFM1,MFM2,MFM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 499
+ MFM3 = MFM1 / MIM1
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_DIV(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 500
+ MZM3 = MFM1 / MZM1
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_DIV(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 501
+ MIM3 = MIM1 / J2
+ CALL IM_ST2M('131',MIM4)
+ CALL IM_DIV(MIM1,MIM4,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 502
+ CALL FM_ST2M('241.21',MFM3)
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = MIM1 / R2
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 503
+ CALL FM_ST2M('391.61',MFM3)
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = MIM1 / D2
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 504
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM3)
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MIM1 / C2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 505
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MIM1 / CD2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 506
+ MFM3 = MIM1 / MFM1
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_DIV(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 507
+ MIM3 = MIM1 / MIM2
+ CALL IM_DIV(MIM1,MIM2,MIM4)
+ IF (MIM4 /= MIM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 508
+ MZM3 = MIM1 / MZM1
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_DIV(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 509
+ MZM3 = MZM1 / J2
+ CALL ZM_ST2M('131',MZM4)
+ CALL ZM_DIV(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 510
+ MZM3 = MZM1 / R2
+ CALL ZM_ST2M('241.21',MZM4)
+ CALL ZM_DIV(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 511
+ MZM3 = MZM1 / D2
+ CALL ZM_ST2M('391.61',MZM4)
+ CALL ZM_DIV(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 512
+ MZM3 = MZM1 / C2
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_DIV(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 513
+ MZM3 = MZM1 / CD2
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_DIV(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 514
+ MZM3 = MZM1 / MFM1
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_DIV(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 515
+ MZM3 = MZM1 / MIM1
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_DIV(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 516
+ MZM3 = MZM1 / MZM2
+ CALL ZM_DIV(MZM1,MZM2,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ END SUBROUTINE TEST34
+
+ SUBROUTINE TEST35(NCASE,NERROR,KLOG)
+
+! Test the '**' arithmetic operator.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+ IMPLICIT NONE
+
+ INTEGER KLOG,NERROR,NCASE
+
+ WRITE (KW,"(/' Testing the derived type ** interface.')")
+
+! Use a larger error tolerance for large exponents.
+
+ RSMALL = EPSILON(1.0)*10000.0
+ DSMALL = EPSILON(1.0D0)*10000.0
+
+ NCASE = 517
+ MFM3 = J2 ** MFM1
+ CALL FM_ST2M('131',MFM4)
+ CALL FM_PWR(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 518
+ J4 = 2
+ MIM3 = J4 ** MIM1
+ CALL IM_ST2M('2',MIM4)
+ CALL IM_PWR(MIM4,MIM1,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 519
+ MZM3 = J2 ** MZM1
+ CALL ZM_ST2M('131',MZM4)
+ CALL ZM_PWR(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 520
+ MFM3 = R2 ** MFM1
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_PWR(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+
+ NCASE = 521
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_ST2M('661',MFM3)
+ CALL FM_PWR(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = R2 ** MIM1
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 522
+ MZM3 = R2 ** MZM1
+ CALL ZM_ST2M('241.21',MZM4)
+ CALL ZM_PWR(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 523
+ MFM3 = D2 ** MFM1
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_PWR(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 524
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_ST2M('661',MFM3)
+ CALL FM_PWR(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = D2 ** MIM1
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 525
+ MZM3 = D2 ** MZM1
+ CALL ZM_ST2M('391.61',MZM4)
+ CALL ZM_PWR(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 526
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_ST2M('581.21',MZM3)
+ CALL ZM_PWR(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = C2 ** MFM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 527
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_ST2M('661',MZM3)
+ CALL ZM_PWR(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = C2 ** MIM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 528
+ MZM3 = C2 ** MZM1
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_PWR(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 529
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_ST2M('581.21',MZM3)
+ CALL ZM_PWR(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = CD2 ** MFM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 530
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_ST2M('661',MZM3)
+ CALL ZM_PWR(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = CD2 ** MIM1
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 531
+ MZM3 = CD2 ** MZM1
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_PWR(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 532
+ MFM3 = MFM1 ** J2
+ CALL FM_ST2M('131',MFM4)
+ CALL FM_PWR(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 533
+ MFM3 = MFM1 ** R2
+ CALL FM_ST2M('241.21',MFM4)
+ CALL FM_PWR(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 534
+ MFM3 = MFM1 ** D2
+ CALL FM_ST2M('391.61',MFM4)
+ CALL FM_PWR(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 535
+ CALL ZM_ST2M('581.21',MZM3)
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_PWR(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MFM1 ** C2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 536
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_PWR(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MFM1 ** CD2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 537
+ MFM3 = MFM1 ** MFM2
+ CALL FM_PWR(MFM1,MFM2,MFM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 538
+ MFM3 = MFM1 ** MIM1
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_PWR(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 539
+ MZM3 = MFM1 ** MZM1
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_PWR(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 540
+ J4 = 17
+ MIM3 = MIM1 ** J4
+ CALL IM_ST2M('17',MIM4)
+ CALL IM_PWR(MIM1,MIM4,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 541
+ CALL FM_ST2M('241.21',MFM3)
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_PWR(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = MIM1 ** R2
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 542
+ CALL FM_ST2M('391.61',MFM3)
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_PWR(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = MIM1 ** D2
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 543
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM3)
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_PWR(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MIM1 ** C2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 544
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM3)
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_PWR(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ MZM3 = MIM1 ** CD2
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 545
+ MFM3 = MIM1 ** MFM1
+ CALL FM_ST2M('661',MFM4)
+ CALL FM_PWR(MFM4,MFM1,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM4 /= MFM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 546
+ MIM4 = 19
+ MIM3 = MIM1 ** MIM4
+ CALL IM_PWR(MIM1,MIM4,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ IF (MIM4 /= MIM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 547
+ MZM3 = MIM1 ** MZM1
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_PWR(MZM4,MZM1,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 548
+ MZM3 = MZM1 ** J2
+ CALL ZM_ST2M('131',MZM4)
+ CALL ZM_PWR(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 549
+ MZM3 = MZM1 ** R2
+ CALL ZM_ST2M('241.21',MZM4)
+ CALL ZM_PWR(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 550
+ MZM3 = MZM1 ** D2
+ CALL ZM_ST2M('391.61',MZM4)
+ CALL ZM_PWR(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 551
+ MZM3 = MZM1 ** C2
+ CALL ZM_ST2M('411.11 + 421.21 i',MZM4)
+ CALL ZM_PWR(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > RSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 552
+ MZM3 = MZM1 ** CD2
+ CALL ZM_ST2M('431.11 + 441.21 i',MZM4)
+ CALL ZM_PWR(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ IF (MFM4 > DSMALL) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 553
+ MZM3 = MZM1 ** MFM1
+ CALL ZM_ST2M('581.21',MZM4)
+ CALL ZM_PWR(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 554
+ MZM3 = MZM1 ** MIM1
+ CALL ZM_ST2M('661',MZM4)
+ CALL ZM_PWR(MZM1,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 555
+ MZM3 = MZM1 ** MZM2
+ CALL ZM_PWR(MZM1,MZM2,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM4 /= MZM3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ END SUBROUTINE TEST35
+
+ SUBROUTINE TEST36(NCASE,NERROR,KLOG)
+
+! Test functions ABS, ..., CEILING.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+ IMPLICIT NONE
+
+ INTEGER J,JERR,KLOG,NERROR,NCASE
+
+ WRITE (KW,"(/' Testing the derived type ABS, ..., CEILING interfaces.')")
+
+ NCASE = 556
+ MFM3 = ABS(MFM1)
+ CALL FM_ABS(MFM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 557
+ MIM3 = ABS(MIM1)
+ CALL IM_ABS(MIM1,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 558
+ MFM3 = ABS(MZM1)
+ CALL ZM_ABS(MZM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 559
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = ACOS(MFM4)
+ CALL FM_ACOS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 560
+ CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
+ MZM3 = ACOS(MZM4)
+ CALL ZM_ACOS(MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 561
+ CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
+ MFM3 = AIMAG(MZM4)
+ CALL ZM_IMAG(MZM4,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 562
+ MFM3 = AINT(MFM1)
+ CALL FM_INT(MFM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 563
+ MZM3 = AINT(MZM1)
+ CALL ZM_INT(MZM1,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 564
+ MFM3 = ANINT(MFM1)
+ CALL FM_NINT(MFM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 565
+ MZM3 = ANINT(MZM1)
+ CALL ZM_NINT(MZM1,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 566
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = ASIN(MFM4)
+ CALL FM_ASIN(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 567
+ CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
+ MZM3 = ASIN(MZM4)
+ CALL ZM_ASIN(MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 568
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = ATAN(MFM4)
+ CALL FM_ATAN(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 569
+ CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
+ MZM3 = ATAN(MZM4)
+ CALL ZM_ATAN(MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 570
+ MFM3 = ATAN2(MFM1,MFM2)
+ CALL FM_ATN2(MFM1,MFM2,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 571
+ JERR = -1
+ DO J = 0, 10
+ IF (BTEST(661,J)) THEN
+ IF (.NOT.BTEST(MIM1,J)) JERR = J
+ ELSE
+ IF (BTEST(MIM1,J)) JERR = J
+ ENDIF
+ ENDDO
+ IF (JERR >= 0) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 572
+ CALL FM_ST2M('12.37654',MFM4)
+ MFM3 = CEILING(MFM4)
+ CALL FM_ST2M('13',MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 573
+ CALL FM_ST2M('-12.7654',MFM4)
+ MFM3 = CEILING(MFM4)
+ CALL FM_ST2M('-12',MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 574
+ CALL ZM_ST2M('12.37654 - 22.54 i',MZM4)
+ MZM3 = CEILING(MZM4)
+ CALL ZM_ST2M('13 - 22 i',MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 575
+ CALL ZM_ST2M('-12.7654 + 22.31 i',MZM4)
+ MZM3 = CEILING(MZM4)
+ CALL ZM_ST2M('-12 + 23 i',MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ END SUBROUTINE TEST36
+
+ SUBROUTINE TEST37(NCASE,NERROR,KLOG)
+
+! Test functions CMPLX, ..., EXPONENT.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+ IMPLICIT NONE
+
+ INTEGER J,KLOG,NERROR,NCASE
+
+ WRITE (KW,"(/"// &
+ "' Testing the derived type CMPLX, ..., EXPONENT interfaces.')")
+
+ NCASE = 576
+ MZM3 = CMPLX(MFM1,MFM2)
+ CALL ZM_CMPX(MFM1,MFM2,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 577
+ MZM3 = CMPLX(MIM1,MIM2)
+ CALL IM_I2FM(MIM1,MFM3)
+ CALL IM_I2FM(MIM2,MFM4)
+ CALL ZM_CMPX(MFM3,MFM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 578
+ MZM3 = CMPLX(MFM1)
+ CALL FM_I2M(0,MFM4)
+ CALL ZM_CMPX(MFM1,MFM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 579
+ MZM3 = CMPLX(MIM1)
+ CALL IM_I2FM(MIM1,MFM3)
+ CALL FM_I2M(0,MFM4)
+ CALL ZM_CMPX(MFM3,MFM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 580
+ MZM3 = CONJG(MZM1)
+ CALL ZM_CONJ(MZM1,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 581
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = COS(MFM4)
+ CALL FM_COS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 582
+ CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
+ MZM3 = COS(MZM4)
+ CALL ZM_COS(MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 583
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = COSH(MFM4)
+ CALL FM_COSH(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 584
+ CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
+ MZM3 = COSH(MZM4)
+ CALL ZM_COSH(MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 585
+ MFM3 = DBLE(MFM1)
+ CALL FM_EQ(MFM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 586
+ MFM3 = DBLE(MIM1)
+ CALL IM_I2FM(MIM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 587
+ MFM3 = DBLE(MZM1)
+ CALL ZM_REAL(MZM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 588
+ J = DIGITS(MFM1)
+ IF (J /= NDIG) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 589
+ J = DIGITS(MIM1)
+ IF (J /= NDIGMX) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 590
+ J = DIGITS(MZM1)
+ IF (J /= NDIG) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 591
+ MFM3 = DIM(MFM1,MFM2)
+ CALL FM_DIM(MFM1,MFM2,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 592
+ MIM3 = DIM(MIM1,MIM2)
+ CALL IM_DIM(MIM1,MIM2,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 593
+ MFM3 = DINT (MFM1)
+ CALL FM_INT(MFM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 594
+ MZM3 = DINT (MZM1)
+ CALL ZM_INT(MZM1,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 595
+ CALL FM_ST2M('1.23',MFMV1(1))
+ CALL FM_ST2M('2.23',MFMV1(2))
+ CALL FM_ST2M('3.23',MFMV1(3))
+ CALL FM_ST2M('4.23',MFMV2(1))
+ CALL FM_ST2M('5.23',MFMV2(2))
+ CALL FM_ST2M('6.23',MFMV2(3))
+ MFM3 = DOTPRODUCT(MFMV1,MFMV2)
+ MFM4 = 0
+ DO J = 1, 3
+ MFM4 = MFM4 + MFMV1(J)*MFMV2(J)
+ ENDDO
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 596
+ CALL IM_ST2M('12',MIMV1(1))
+ CALL IM_ST2M('23',MIMV1(2))
+ CALL IM_ST2M('34',MIMV1(3))
+ CALL IM_ST2M('-14',MIMV2(1))
+ CALL IM_ST2M('-5',MIMV2(2))
+ CALL IM_ST2M('16',MIMV2(3))
+ MIM3 = DOTPRODUCT(MIMV1,MIMV2)
+ MIM4 = 0
+ DO J = 1, 3
+ MIM4 = MIM4 + MIMV1(J)*MIMV2(J)
+ ENDDO
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 597
+ CALL ZM_ST2M('1.23 + 1.67 i',MZMV1(1))
+ CALL ZM_ST2M('2.23 - 2.56 i',MZMV1(2))
+ CALL ZM_ST2M('3.23 + 3.45 i',MZMV1(3))
+ CALL ZM_ST2M('4.23 - 4.34 i',MZMV2(1))
+ CALL ZM_ST2M('5.23 + 5.23 i',MZMV2(2))
+ CALL ZM_ST2M('6.23 - 6.12 i',MZMV2(3))
+ MZM3 = DOTPRODUCT(MZMV1,MZMV2)
+ MZM4 = 0
+ DO J = 1, 3
+ MZM4 = MZM4 + MZMV1(J)*MZMV2(J)
+ ENDDO
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 598
+ MFM3 = EPSILON(MFM1)
+ CALL FM_I2M(1,MFM4)
+ CALL FM_ULP(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 599
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = EXP(MFM4)
+ CALL FM_EXP(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 600
+ CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
+ MZM3 = EXP(MZM4)
+ CALL ZM_EXP(MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 601
+ J = EXPONENT(MFM1)
+ IF (J /= INT(MFM1%MFM(1))) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ END SUBROUTINE TEST37
+
+ SUBROUTINE TEST38(NCASE,NERROR,KLOG)
+
+! Test functions FLOOR, ..., MIN.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+ IMPLICIT NONE
+
+ INTEGER I,J,KLOG,NERROR,NCASE
+
+ WRITE (KW,"(/"// &
+ "' Testing the derived type FLOOR, ..., MIN interfaces.')")
+
+ NCASE = 602
+ CALL FM_ST2M('12.37654',MFM4)
+ MFM3 = FLOOR(MFM4)
+ CALL FM_ST2M('12',MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 603
+ CALL FM_ST2M('-12.7654',MFM4)
+ MFM3 = FLOOR(MFM4)
+ CALL FM_ST2M('-13',MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 604
+ CALL IM_ST2M('12',MIM4)
+ MIM3 = FLOOR(MIM4)
+ CALL IM_ST2M('12',MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 605
+ CALL IM_ST2M('-123',MIM4)
+ MIM3 = FLOOR(MIM4)
+ CALL IM_ST2M('-123',MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 606
+ CALL ZM_ST2M('12.37654 - 22.54 i',MZM4)
+ MZM3 = FLOOR(MZM4)
+ CALL ZM_ST2M('12 - 23 i',MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 607
+ CALL ZM_ST2M('-12.7654 + 22.31 i',MZM4)
+ MZM3 = FLOOR(MZM4)
+ CALL ZM_ST2M('-13 + 22 i',MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 608
+ CALL FM_ST2M('12.37654',MFM4)
+ MFM3 = FRACTION(MFM4)
+ MFM4%MFM(1) = 0
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 609
+ CALL ZM_ST2M('12.37654 - 22.54',MZM4)
+ MZM3 = FRACTION(MZM4)
+ MZM4%MZM(1) = 0
+ MZM4%MZM(KPTIMU+01) = 0
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 610
+ MFM3 = HUGE(MFM1)
+ CALL FM_BIG(MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 611
+ MIM3 = HUGE(MIM1)
+ CALL IM_BIG(MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 612
+ MZM3 = HUGE(MZM1)
+ CALL FM_BIG(MFM4)
+ CALL ZM_CMPX(MFM4,MFM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 613
+ MIM3 = INT(MFM1)
+ CALL FM_INT(MFM1,MFM4)
+ CALL IM_FM2I(MFM4,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 614
+ MIM3 = INT(MIM1)
+ CALL IM_EQ(MIM1,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 615
+ MIM3 = INT(MZM1)
+ CALL ZM_INT(MZM1,MZM4)
+ CALL ZM_REAL(MZM4,MFM4)
+ CALL IM_FM2I(MFM4,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 616
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = LOG(MFM4)
+ CALL FM_LN(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 617
+ CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
+ MZM3 = LOG(MZM4)
+ CALL ZM_LN(MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 618
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = LOG10(MFM4)
+ CALL FM_LG10(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 619
+ CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
+ MZM3 = LOG10(MZM4)
+ CALL ZM_LG10(MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 620
+ DO I = 1, 3
+ DO J = 1, 3
+ MFMA(I,J) = 3*(J-1) + I
+ MFMB(I,J) = 3*(I-1) + J + 10
+ ENDDO
+ ENDDO
+ MFMC = MATMUL(MFMA,MFMB)
+ MFM3 = ABS(MFMC(1,1)-186)+ABS(MFMC(1,2)-198)+ABS(MFMC(1,3)-210)+ &
+ ABS(MFMC(2,1)-228)+ABS(MFMC(2,2)-243)+ABS(MFMC(2,3)-258)+ &
+ ABS(MFMC(3,1)-270)+ABS(MFMC(3,2)-288)+ABS(MFMC(3,3)-306)
+ IF (MFM3 /= 0) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 621
+ DO I = 1, 2
+ DO J = 1, 2
+ MIMA(I,J) = 2*(J-1) + I + 20
+ MIMB(I,J) = 2*(I-1) + J + 30
+ ENDDO
+ ENDDO
+ MIMC = MATMUL(MIMA,MIMB)
+ MIM3 = ABS(MIMC(1,1)-1410) + ABS(MIMC(1,2)-1454) + &
+ ABS(MIMC(2,1)-1474) + ABS(MIMC(2,2)-1520)
+ IF (MIM3 /= 0) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 622
+ DO I = 1, 2
+ DO J = 1, 3
+ MZMA(I,J) = CMPLX(TO_FM(2*(J-1)+I+10),TO_FM(2*(J-1)+I+20))
+ ENDDO
+ ENDDO
+ DO I = 1, 3
+ DO J = 1, 4
+ MZMB(I,J) = CMPLX(TO_FM(4*(I-1)+J+50),TO_FM(4*(I-1)+J+30))
+ ENDDO
+ ENDDO
+ MZMC = MATMUL(MZMA,MZMB)
+ MFM3 = ABS(MZMC(1,1)-TO_ZM('-270 + 5192 i')) + &
+ ABS(MZMC(1,2)-TO_ZM('-300 + 5300 i')) + &
+ ABS(MZMC(1,3)-TO_ZM('-330 + 5408 i')) + &
+ ABS(MZMC(1,4)-TO_ZM('-360 + 5516 i')) + &
+ ABS(MZMC(2,1)-TO_ZM('-210 + 5462 i')) + &
+ ABS(MZMC(2,2)-TO_ZM('-240 + 5576 i')) + &
+ ABS(MZMC(2,3)-TO_ZM('-270 + 5690 i')) + &
+ ABS(MZMC(2,4)-TO_ZM('-300 + 5804 i'))
+ IF (MFM3 /= 0) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 623
+ MFM3 = MAX(MFM1,MFM2)
+ CALL FM_MAX(MFM1,MFM2,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 624
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = MAX(MFM2,MFM1,MFM4)
+ CALL FM_MAX(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_MAX(MFM2,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 625
+ MIM3 = MAX(MIM1,MIM2)
+ CALL IM_MAX(MIM1,MIM2,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 626
+ CALL IM_ST2M('7654',MIM4)
+ CALL IM_ST2M('-1654',MIM3)
+ MIM3 = MAX(MIM2,MIM1,MIM3,MIM4)
+ CALL IM_ST2M('7654',MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 627
+ J = MAXEXPONENT(MFM1)
+ IF (J /= INT(MXEXP)+1) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 628
+ MFM3 = MIN(MFM1,MFM2)
+ CALL FM_MIN(MFM1,MFM2,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 629
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = MIN(MFM2,MFM1,MFM4)
+ CALL FM_MIN(MFM1,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_MIN(MFM2,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 630
+ MIM3 = MIN(MIM1,MIM2)
+ CALL IM_MIN(MIM1,MIM2,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 631
+ CALL IM_ST2M('7654',MIM4)
+ CALL IM_ST2M('-1654',MIM3)
+ MIM3 = MIN(MIM2,MIM1,MIM3,MIM4)
+ CALL IM_ST2M('-1654',MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ END SUBROUTINE TEST38
+
+ SUBROUTINE TEST39(NCASE,NERROR,KLOG)
+
+! Test functions MINEXPONENT, ..., RRSPACING.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+ IMPLICIT NONE
+
+ INTEGER J,KLOG,NERROR,NCASE
+
+ WRITE (KW,"(/"// &
+ "' Testing the derived type MINEXPONENT, ..., RRSPACING interfaces.')")
+
+ NCASE = 632
+ J = MINEXPONENT(MFM1)
+ IF (J /= -INT(MXEXP)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 633
+ CALL FM_ST2M('8',MFM3)
+ CALL FM_ST2M('5',MFM4)
+ MFM3 = MOD(MFM3,MFM4)
+ CALL FM_ST2M('3',MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 634
+ CALL FM_ST2M('-8',MFM3)
+ CALL FM_ST2M('5',MFM4)
+ MFM3 = MOD(MFM3,MFM4)
+ CALL FM_ST2M('-3',MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 635
+ CALL FM_ST2M('8',MFM3)
+ CALL FM_ST2M('-5',MFM4)
+ MFM3 = MOD(MFM3,MFM4)
+ CALL FM_ST2M('3',MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 636
+ CALL FM_ST2M('-8',MFM3)
+ CALL FM_ST2M('-5',MFM4)
+ MFM3 = MOD(MFM3,MFM4)
+ CALL FM_ST2M('-3',MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 637
+ CALL IM_ST2M('8',MIM3)
+ CALL IM_ST2M('5',MIM4)
+ MIM3 = MOD(MIM3,MIM4)
+ CALL IM_ST2M('3',MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 638
+ CALL IM_ST2M('-8',MIM3)
+ CALL IM_ST2M('5',MIM4)
+ MIM3 = MOD(MIM3,MIM4)
+ CALL IM_ST2M('-3',MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 639
+ CALL IM_ST2M('8',MIM3)
+ CALL IM_ST2M('-5',MIM4)
+ MIM3 = MOD(MIM3,MIM4)
+ CALL IM_ST2M('3',MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 640
+ CALL IM_ST2M('-8',MIM3)
+ CALL IM_ST2M('-5',MIM4)
+ MIM3 = MOD(MIM3,MIM4)
+ CALL IM_ST2M('-3',MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 641
+ CALL FM_ST2M('8',MFM3)
+ CALL FM_ST2M('5',MFM4)
+ MFM3 = MODULO(MFM3,MFM4)
+ CALL FM_ST2M('3',MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 642
+ CALL FM_ST2M('-8',MFM3)
+ CALL FM_ST2M('5',MFM4)
+ MFM3 = MODULO(MFM3,MFM4)
+ CALL FM_ST2M('2',MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 643
+ CALL FM_ST2M('8',MFM3)
+ CALL FM_ST2M('-5',MFM4)
+ MFM3 = MODULO(MFM3,MFM4)
+ CALL FM_ST2M('-2',MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 644
+ CALL FM_ST2M('-8',MFM3)
+ CALL FM_ST2M('-5',MFM4)
+ MFM3 = MODULO(MFM3,MFM4)
+ CALL FM_ST2M('-3',MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 645
+ CALL IM_ST2M('8',MIM3)
+ CALL IM_ST2M('5',MIM4)
+ MIM3 = MODULO(MIM3,MIM4)
+ CALL IM_ST2M('3',MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 646
+ CALL IM_ST2M('-8',MIM3)
+ CALL IM_ST2M('5',MIM4)
+ MIM3 = MODULO(MIM3,MIM4)
+ CALL IM_ST2M('2',MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 647
+ CALL IM_ST2M('8',MIM3)
+ CALL IM_ST2M('-5',MIM4)
+ MIM3 = MODULO(MIM3,MIM4)
+ CALL IM_ST2M('-2',MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 648
+ CALL IM_ST2M('-8',MIM3)
+ CALL IM_ST2M('-5',MIM4)
+ MIM3 = MODULO(MIM3,MIM4)
+ CALL IM_ST2M('-3',MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 649
+ CALL FM_ST2M('0',MFM4)
+ CALL FM_ST2M('1',MFM3)
+ CALL FM_BIG(MFM5)
+ CALL FM_DIV(MFM3,MFM5,MFM6)
+ CALL FM_EQ(MFM6,MFM5)
+ MFM3 = NEAREST(MFM4,MFM3)
+ IF (MFM3 /= MFM5) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 650
+ CALL FM_ST2M('0',MFM4)
+ CALL FM_ST2M('-1',MFM3)
+ CALL FM_BIG(MFM5)
+ CALL FM_DIV(MFM3,MFM5,MFM6)
+ CALL FM_EQ(MFM6,MFM5)
+ MFM3 = NEAREST(MFM4,MFM3)
+ IF (MFM3 /= MFM5) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 651
+ CALL FM_ST2M('2.345',MFM4)
+ CALL FM_ST2M('1',MFM3)
+ MFM3 = NEAREST(MFM4,MFM3)
+ CALL FM_ULP(MFM4,MFM5)
+ CALL FM_ADD(MFM4,MFM5,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 652
+ CALL FM_ST2M('2.345',MFM4)
+ CALL FM_ST2M('-1',MFM3)
+ MFM3 = NEAREST(MFM4,MFM3)
+ CALL FM_ULP(MFM4,MFM5)
+ CALL FM_SUB(MFM4,MFM5,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 653
+ CALL FM_ST2M('1',MFM4)
+ CALL FM_ST2M('-1',MFM3)
+ MFM3 = NEAREST(MFM4,MFM3)
+ CALL FM_ST2M('0.99',MFM5)
+ CALL FM_ULP(MFM5,MFM6)
+ CALL FM_EQ(MFM6,MFM5)
+ CALL FM_SUB(MFM4,MFM5,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 654
+ CALL FM_ST2M('-1',MFM4)
+ CALL FM_ST2M('12',MFM3)
+ MFM3 = NEAREST(MFM4,MFM3)
+ CALL FM_ST2M('-0.99',MFM5)
+ CALL FM_ULP(MFM5,MFM6)
+ CALL FM_EQ(MFM6,MFM5)
+ CALL FM_SUB(MFM4,MFM5,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 655
+ MIM3 = NINT(MFM1)
+ CALL FM_NINT(MFM1,MFM4)
+ CALL IM_FM2I(MFM4,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 656
+ MIM3 = NINT(MIM1)
+ CALL IM_EQ(MIM1,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 657
+ MIM3 = NINT(MZM1)
+ CALL ZM_NINT(MZM1,MZM4)
+ CALL ZM_REAL(MZM4,MFM4)
+ CALL IM_FM2I(MFM4,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 658
+ J = PRECISION(MFM1)
+ IF (J /= INT(LOG10(REAL(MBASE))*(NDIG-1) + 1)) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 659
+ J = PRECISION(MZM1)
+ IF (J /= INT(LOG10(REAL(MBASE))*(NDIG-1) + 1)) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 660
+ J = RADIX(MFM1)
+ IF (J /= INT(MBASE)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 661
+ J = RADIX(MIM1)
+ IF (J /= INT(MBASE)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 662
+ J = RADIX(MZM1)
+ IF (J /= INT(MBASE)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 663
+ J = RANGE(MFM1)
+ IF (J /= INT(MXEXP*LOG10(REAL(MBASE)))) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 664
+ J = RANGE(MIM1)
+ IF (J /= INT(NDIGMX*LOG10(REAL(MBASE)))) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 665
+ J = RANGE(MZM1)
+ IF (J /= INT(MXEXP*LOG10(REAL(MBASE)))) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 666
+ MFM3 = REAL(MFM1)
+ CALL FM_EQ(MFM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 667
+ MFM3 = REAL(MIM1)
+ CALL IM_I2FM(MIM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 668
+ MFM3 = REAL(MZM1)
+ CALL ZM_REAL(MZM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 669
+ MFM3 = RRSPACING(MFM1)
+ CALL FM_ABS(MFM1,MFM4)
+ MFM4%MFM(1) = NDIG
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ END SUBROUTINE TEST39
+
+ SUBROUTINE TEST40(NCASE,NERROR,KLOG)
+
+! Test functions SCALE, ..., TINY.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+ IMPLICIT NONE
+
+ INTEGER KLOG,NERROR,NCASE
+
+ WRITE (KW,"(/"// &
+ "' Testing the derived type SCALE, ..., TINY interfaces.')")
+
+ NCASE = 670
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = SCALE(MFM4,1)
+ CALL FM_MPYI(MFM4,INT(MBASE),MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 671
+ CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
+ MZM3 = SCALE(MZM4,-2)
+ CALL ZM_DIVI(MZM4,INT(MBASE),MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIVI(MZM4,INT(MBASE),MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 672
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = SETEXPONENT(MFM4,1)
+ CALL FM_MPYI(MFM4,INT(MBASE),MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 673
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = SIGN(MFM4,MFM2)
+ CALL FM_SIGN(MFM4,MFM2,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 674
+ CALL IM_ST2M('231',MIM4)
+ MIM3 = SIGN(MIM4,MIM2)
+ CALL IM_SIGN(MIM4,MIM2,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 675
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = SIN(MFM4)
+ CALL FM_SIN(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 676
+ CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
+ MZM3 = SIN(MZM4)
+ CALL ZM_SIN(MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 677
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = SINH(MFM4)
+ CALL FM_SINH(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 678
+ CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
+ MZM3 = SINH(MZM4)
+ CALL ZM_SINH(MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 679
+ CALL FM_ST2M('-0.7654',MFM4)
+ MFM3 = SPACING(MFM4)
+ CALL FM_ULP(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 680
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = SQRT(MFM4)
+ CALL FM_SQRT(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 681
+ CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
+ MZM3 = SQRT(MZM4)
+ CALL ZM_SQRT(MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 682
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = TAN(MFM4)
+ CALL FM_TAN(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 683
+ CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
+ MZM3 = TAN(MZM4)
+ CALL ZM_TAN(MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 684
+ CALL FM_ST2M('0.7654',MFM4)
+ MFM3 = TANH(MFM4)
+ CALL FM_TANH(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 685
+ CALL ZM_ST2M('0.7654 - 0.3456 i',MZM4)
+ MZM3 = TANH(MZM4)
+ CALL ZM_TANH(MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 686
+ CALL FM_BIG(MFM4)
+ CALL FM_I2M(1,MFM3)
+ CALL FM_DIV(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = TINY(MFM1)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 687
+ MIM3 = TINY(MIM1)
+ CALL IM_I2M(1,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 688
+ CALL FM_BIG(MFM4)
+ CALL FM_I2M(1,MFM3)
+ CALL FM_DIV(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL ZM_CMPX(MFM4,MFM4,MZM4)
+ MZM3 = TINY(MZM1)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ END SUBROUTINE TEST40
+
+ SUBROUTINE TEST41(NCASE,NERROR,KLOG)
+
+! Test functions TO_FM, TO_IM, TO_ZM, ..., TO_DPZ.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+ IMPLICIT NONE
+
+ INTEGER KLOG,NERROR,NCASE
+ LOGICAL FM_COMP
+
+ WRITE (KW,"(/"// &
+ "' Testing the derived type TO_FM, ..., TO_DPZ interfaces.')")
+
+ RSMALL = EPSILON(1.0)*100.0
+ DSMALL = EPSILON(1.0D0)*100.0
+
+ NCASE = 689
+ MFM3 = TO_FM(123)
+ CALL FM_I2M(123,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 690
+ MFM3 = TO_FM(123.4)
+ CALL FM_SP2M(123.4,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = RSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 691
+ MFM3 = TO_FM(123.45D0)
+ CALL FM_DP2M(123.45D0,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = DSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+
+ NCASE = 692
+ MFM3 = TO_FM(CMPLX(123.4,567.8))
+ CALL FM_SP2M(123.4,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = RSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 693
+ MFM3 = TO_FM(CMPLX(123.4D0,567.8D0,KIND(1.0D0)))
+ CALL FM_DP2M(123.4D0,MFM4)
+ CALL FM_SUB(MFM3,MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_DIV(MFM4,MFM3,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ CALL FM_ABS(MFM4,MFM6)
+ CALL FM_EQ(MFM6,MFM4)
+ MFM3 = DSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 694
+ MFM3 = TO_FM(MFM1)
+ CALL FM_EQ(MFM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 695
+ MFM3 = TO_FM(MIM1)
+ CALL IM_I2FM(MIM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 696
+ MFM3 = TO_FM(MZM1)
+ CALL ZM_REAL(MZM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 697
+ MFM3 = TO_FM('-123.654')
+ CALL FM_ST2M('-123.654',MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 698
+ MIM3 = TO_IM(123)
+ CALL IM_I2M(123,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 699
+ MIM3 = TO_IM(123.4)
+ CALL FM_SP2M(123.4,MFM4)
+ CALL IM_FM2I(MFM4,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 700
+ MIM3 = TO_IM(123.45D0)
+ CALL FM_DP2M(123.45D0,MFM4)
+ CALL IM_FM2I(MFM4,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 701
+ MIM3 = TO_IM(CMPLX(123.4,567.8))
+ CALL FM_SP2M(123.4,MFM4)
+ CALL IM_FM2I(MFM4,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 702
+ MIM3 = TO_IM(CMPLX(123.4D0,567.8D0,KIND(1.0D0)))
+ CALL FM_DP2M(123.4D0,MFM4)
+ CALL IM_FM2I(MFM4,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 703
+ MIM3 = TO_IM(MFM1)
+ CALL FM_EQ(MFM1,MFM4)
+ CALL IM_FM2I(MFM4,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 704
+ MIM3 = TO_IM(MIM1)
+ CALL IM_I2FM(MIM1,MFM4)
+ CALL IM_FM2I(MFM4,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 705
+ MIM3 = TO_IM(MZM1)
+ CALL ZM_REAL(MZM1,MFM4)
+ CALL IM_FM2I(MFM4,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 706
+ MIM3 = TO_IM('-123654')
+ CALL IM_ST2M('-123654',MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 707
+ MZM3 = TO_ZM(123)
+ CALL ZM_I2M(123,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 708
+ MZM3 = TO_ZM(123.4)
+ CALL FM_SP2M(123.4,MFM4)
+ CALL FM_I2M(0,MFM5)
+ CALL ZM_CMPX(MFM4,MFM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ MFM3 = RSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 709
+ MZM3 = TO_ZM(123.45D0)
+ CALL FM_DP2M(123.45D0,MFM4)
+ CALL FM_I2M(0,MFM5)
+ CALL ZM_CMPX(MFM4,MFM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ MFM3 = DSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 710
+ MZM3 = TO_ZM(CMPLX(123.4,567.8))
+ CALL FM_SP2M(123.4,MFM4)
+ CALL FM_SP2M(567.8,MFM5)
+ CALL ZM_CMPX(MFM4,MFM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ MFM3 = RSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 711
+ MZM3 = TO_ZM(CMPLX(123.4D0,567.8D0,KIND(1.0D0)))
+ CALL FM_DP2M(123.4D0,MFM4)
+ CALL FM_DP2M(567.8D0,MFM5)
+ CALL ZM_CMPX(MFM4,MFM5,MZM4)
+ CALL ZM_SUB(MZM3,MZM4,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_DIV(MZM4,MZM3,MZM5)
+ CALL ZM_EQ(MZM5,MZM4)
+ CALL ZM_ABS(MZM4,MFM4)
+ MFM3 = DSMALL
+ IF (FM_COMP(MFM4,'GT',MFM3)) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 712
+ MZM3 = TO_ZM(MFM1)
+ CALL FM_EQ(MFM1,MFM4)
+ CALL FM_I2M(0,MFM5)
+ CALL ZM_CMPX(MFM4,MFM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 713
+ MZM3 = TO_ZM(MIM1)
+ CALL IM_I2FM(MIM1,MFM4)
+ CALL FM_I2M(0,MFM5)
+ CALL ZM_CMPX(MFM4,MFM5,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 714
+ MZM3 = TO_ZM(MZM1)
+ CALL ZM_EQ(MZM1,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 715
+ MZM3 = TO_ZM('-123.654 + 98.7 i')
+ CALL ZM_ST2M('-123.654 + 98.7 i',MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 716
+ CALL FM_M2I(MFM1,J3)
+ IF (TO_INT(MFM1) /= J3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 717
+ CALL IM_M2I(MIM1,J3)
+ IF (TO_INT(MIM1) /= J3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 718
+ CALL ZM_M2I(MZM1,J3)
+ IF (TO_INT(MZM1) /= J3) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 719
+ CALL FM_M2SP(MFM1,R3)
+ IF (ABS((TO_SP(MFM1)-R3)/R3) > RSMALL) THEN
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+ ENDIF
+
+ NCASE = 720
+ CALL IM_M2DP(MIM1,D3)
+ R3 = D3
+ IF (ABS((TO_SP(MIM1)-R3)/R3) > RSMALL) THEN
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+ ENDIF
+
+ NCASE = 721
+ CALL ZM_REAL(MZM1,MFM4)
+ CALL FM_M2SP(MFM4,R3)
+ IF (ABS((TO_SP(MZM1)-R3)/R3) > RSMALL) THEN
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+ ENDIF
+
+ NCASE = 722
+ CALL FM_M2DP(MFM1,D3)
+ IF (ABS((TO_DP(MFM1)-D3)/D3) > DSMALL) THEN
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+ ENDIF
+
+ NCASE = 723
+ CALL IM_M2DP(MIM1,D3)
+ IF (ABS((TO_DP(MIM1)-D3)/D3) > DSMALL) THEN
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+ ENDIF
+
+ NCASE = 724
+ CALL ZM_REAL(MZM1,MFM4)
+ CALL FM_M2DP(MFM4,D3)
+ IF (ABS((TO_DP(MZM1)-D3)/D3) > DSMALL) THEN
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+ ENDIF
+
+ NCASE = 725
+ CALL FM_M2SP(MFM1,R3)
+ C3 = R3
+ IF (ABS((TO_SPZ(MFM1)-C3)/C3) > RSMALL) THEN
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+ ENDIF
+
+ NCASE = 726
+ CALL IM_M2DP(MIM1,D3)
+ C3 = D3
+ IF (ABS((TO_SPZ(MIM1)-C3)/C3) > RSMALL) THEN
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+ ENDIF
+
+ NCASE = 727
+ CALL ZM_M2Z(MZM1,C3)
+ IF (ABS((TO_SPZ(MZM1)-C3)/C3) > RSMALL) THEN
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+ ENDIF
+
+ NCASE = 728
+ CALL FM_M2DP(MFM1,D3)
+ CD3 = D3
+ IF (ABS((TO_DPZ(MFM1)-CD3)/CD3) > DSMALL) THEN
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+ ENDIF
+
+ NCASE = 729
+ CALL IM_M2DP(MIM1,D3)
+ CD3 = D3
+ IF (ABS((TO_DPZ(MIM1)-CD3)/CD3) > DSMALL) THEN
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+ ENDIF
+
+ NCASE = 730
+ CALL ZM_REAL(MZM1,MFM4)
+ CALL FM_M2DP(MFM4,D3)
+ CALL ZM_IMAG(MZM1,MFM4)
+ CALL FM_M2DP(MFM4,D4)
+ CD3 = CMPLX( D3 , D4 , KIND(0.0D0) )
+ IF (ABS((TO_DPZ(MZM1)-CD3)/CD3) > DSMALL) THEN
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+ ENDIF
+
+ END SUBROUTINE TEST41
+
+ SUBROUTINE TEST42(NCASE,NERROR,KLOG)
+
+! Test the derived-type interface routines that are not
+! used elsewhere in this program.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+ IMPLICIT NONE
+
+ CHARACTER(80) :: STRING
+ INTEGER KLOG,NERROR,NCASE
+
+ WRITE (KW,"(/"// &
+ "' Testing the derived type ADDI, ..., Z2M interfaces.')")
+
+ RSMALL = EPSILON(1.0)*100.0
+ DSMALL = EPSILON(1.0D0)*100.0
+ MSMALL = EPSILON(TO_FM(1))*10000.0
+
+ NCASE = 731
+ MFM3 = MFM1 + 123
+ MFM4 = MFM1
+ CALL FM_ADDI(MFM4,123)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 732
+ CALL FM_CHSH(MFM1,MFM4,MFM3)
+ MFM3 = COSH(MFM1)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 733
+ CALL FM_CHSH(MFM1,MFM3,MFM4)
+ MFM3 = SINH(MFM1)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 734
+ CALL FM_CSSN(MFM1,MFM4,MFM3)
+ MFM3 = COS(MFM1)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 735
+ CALL FM_CSSN(MFM1,MFM3,MFM4)
+ MFM3 = SIN(MFM1)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 736
+ MFM3 = MFM1 / 123
+ CALL FM_DIVI(MFM1,123,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 737
+ MFM3 = 123.45D0
+ CALL FM_DPM(123.45D0,MFM4)
+ IF (ABS((MFM3-MFM4)/MFM4) > DSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 738
+ CALL FM_FORM('F70.56',MFM1,STRING)
+ CALL FM_ST2M(STRING(1:70),MFM4)
+ IF (ABS((MFM1-MFM4)/MFM4) > MSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 739
+ STRING = FM_FORMAT('F70.56',MFM1)
+ CALL FM_ST2M(STRING(1:70),MFM4)
+ IF (ABS((MFM1-MFM4)/MFM4) > MSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 740
+ MFM3 = MFM1 ** 123
+ CALL FM_IPWR(MFM1,123,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 741
+ MFM3 = LOG(TO_FM(123))
+ CALL FM_LNI(123,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 742
+ D4 = MFM1
+ CALL FM_M2DP(MFM1,D5)
+ IF (ABS((D4-D5)/D4) > DSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 743
+ J4 = MFM1
+ CALL FM_M2I(MFM1,J5)
+ IF (J4 /= J5) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 744
+ R4 = MFM1
+ CALL FM_M2SP(MFM1,R5)
+ IF (ABS((R4-R5)/R4) > RSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 745
+ MFM3 = 2.67
+ CALL FM_MOD(MFM1,MFM3,MFM4)
+ MFM3 = MOD(MFM1,MFM3)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 746
+ CALL FM_PI(MFM4)
+ MFM3 = 4*ATAN(TO_FM(1))
+ IF (ABS((MFM3-MFM4)/MFM4) > MSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 747
+ MFM3 = MFM1 ** (TO_FM(1)/TO_FM(3))
+ CALL FM_RPWR(MFM1,1,3,MFM4)
+ IF (ABS((MFM3-MFM4)/MFM4) > MSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 748
+ CALL FM_SQR(MFM1,MFM4)
+ MFM3 = MFM1*MFM1
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 749
+ MIM3 = MIM1 / 13
+ CALL IM_DIVI(MIM1,13,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 750
+ MIM3 = 13
+ CALL IM_DIVR(MIM1,MIM3,MIM5,MIM4)
+ MIM3 = MOD(MIM1,MIM3)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 751
+ MIM3 = 13
+ CALL IM_DIVR(MIM1,MIM3,MIM5,MIM4)
+ CALL IM_EQ(MIM5,MIM3)
+ MIM4 = MIM1 / 13
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 752
+ MIM3 = MIM1 / 13
+ CALL IM_DVIR(MIM1,13,MIM4,J5)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 753
+ J4 = MOD(MIM1,TO_IM(13))
+ CALL IM_DVIR(MIM1,13,MIM4,J5)
+ IF (J4 /= J5) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 754
+ CALL IM_FORM('I70',MIM1,STRING)
+ CALL IM_ST2M(STRING(1:70),MIM4)
+ IF (MIM1 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 755
+ STRING = IM_FORMAT('I70',MIM1)
+ CALL IM_ST2M(STRING(1:70),MIM4)
+ IF (MIM1 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 756
+ MIM3 = 40833
+ MIM4 = 16042
+ CALL IM_GCD(MIM3,MIM4,MIM5)
+ CALL IM_EQ(MIM5,MIM4)
+ IF (MIM4 /= 13) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 757
+ MIM3 = 40833
+ MIM4 = 16042
+ MIM4 = GCD(MIM3,MIM4)
+ IF (MIM4 /= 13) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 758
+ D4 = MIM1
+ CALL IM_M2DP(MIM1,D5)
+ IF (ABS((D4-D5)/D4) > DSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 759
+ J4 = MIM1
+ CALL IM_M2I(MIM1,J5)
+ IF (J4 /= J5) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 760
+ MIM3 = 6
+ CALL IM_MOD(MIM1,MIM3,MIM4)
+ MIM3 = MOD(MIM1,MIM3)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 761
+ MIM3 = MIM1 * 123
+ CALL IM_MPYI(MIM1,123,MIM4)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 762
+ MIM2 = 3141
+ MIM3 = 133
+ CALL IM_MPYM(MIM1,MIM2,MIM3,MIM4)
+ MIM3 = MOD(MIM1*MIM2,MIM3)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 763
+ MIM2 = 3141
+ MIM3 = 133
+ MIM4 = MULTIPLY_MOD(MIM1,MIM2,MIM3)
+ MIM3 = MOD(MIM1*MIM2,MIM3)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 764
+ MIM2 = 31
+ MIM3 = 147
+ CALL IM_PMOD(MIM1,MIM2,MIM3,MIM4)
+ MIM3 = MOD(MIM1**MIM2,MIM3)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 765
+ MIM2 = 31
+ MIM3 = 147
+ MIM4 = POWER_MOD(MIM1,MIM2,MIM3)
+ MIM3 = MOD(MIM1**MIM2,MIM3)
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 766
+ CALL IM_SQR(MIM1,MIM4)
+ MIM3 = MIM1*MIM1
+ IF (MIM3 /= MIM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 767
+ MZM3 = MZM1 + 123
+ MZM4 = MZM1
+ CALL ZM_ADDI(MZM4,123)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 768
+ MFM3 = ATAN2(AIMAG(MZM1),REAL(MZM1))
+ CALL ZM_ARG(MZM1,MFM4)
+ IF (MFM3 /= MFM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 769
+ CALL ZM_CHSH(MZM1,MZM4,MZM3)
+ MZM3 = COSH(MZM1)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 770
+ CALL ZM_CHSH(MZM1,MZM3,MZM4)
+ MZM3 = SINH(MZM1)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 771
+ CALL ZM_CSSN(MZM1,MZM4,MZM3)
+ MZM3 = COS(MZM1)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 772
+ CALL ZM_CSSN(MZM1,MZM3,MZM4)
+ MZM3 = SIN(MZM1)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 773
+ CALL ZM_FORM('F35.26','F35.26',MZM1,STRING)
+ CALL ZM_ST2M(STRING(1:75),MZM4)
+ IF (ABS((MZM1-MZM4)/MZM4) > MSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 774
+ STRING = ZM_FORMAT('F35.26','F35.26',MZM1)
+ CALL ZM_ST2M(STRING(1:75),MZM4)
+ IF (ABS((MZM1-MZM4)/MZM4) > MSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 775
+ MZM3 = TO_ZM('123-456i')
+ CALL ZM_2I2M(123,-456,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 776
+ MZM3 = MZM1 ** 123
+ CALL ZM_IPWR(MZM1,123,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 777
+ J4 = MZM1
+ CALL ZM_M2I(MZM1,J5)
+ IF (J4 /= J5) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 778
+ C4 = MZM1
+ CALL ZM_M2Z(MZM1,C5)
+ IF (ABS((C4-C5)/C4) > RSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 779
+ MZM3 = MZM1 * 123
+ CALL ZM_MPYI(MZM1,123,MZM4)
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 780
+ MZM3 = MZM1 ** (TO_ZM(1)/TO_ZM(3))
+ CALL ZM_RPWR(MZM1,1,3,MZM4)
+ IF (ABS((MZM3-MZM4)/MZM4) > MSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 781
+ CALL ZM_SQR(MZM1,MZM4)
+ MZM3 = MZM1*MZM1
+ IF (MZM3 /= MZM4) CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ NCASE = 782
+ MZM3 = C2
+ CALL ZM_Z2M(C2,MZM4)
+ IF (ABS((MZM3-MZM4)/MZM3) > RSMALL) &
+ CALL PRTERR(KW,KLOG,NCASE,NERROR)
+
+ END SUBROUTINE TEST42
+
+ SUBROUTINE TEST43(NCASE,NERROR,KLOG)
+
+! Test Bernoulli numbers, Pochhammer's function, Euler's constant.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ INTEGER KLOG,NCASE,NERROR,NDGSAV
+
+ WRITE (KW,"(/' Testing Bernoulli, Pochhammer, Euler.')")
+
+ NCASE = 783
+ M_A = 1
+ CALL FM_BERN(10,M_A,M_C)
+ M_D = TO_FM('7.5757575757575757575757575757575757575757575757575758M-2')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 784
+ M_A = 1
+ CALL FM_BERN(0,M_A,M_C)
+ M_D = TO_FM('1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 785
+ M_A = 1
+ CALL FM_BERN(1,M_A,M_C)
+ M_D = TO_FM('-0.5')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 786
+ M_A = 1
+ CALL FM_BERN(41,M_A,M_C)
+ M_D = TO_FM('0')
+ M_D = ABS(M_C - M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 787
+ M_A = 0
+ CALL FM_BERN(52,M_A,M_C)
+ M_D = TO_FM('0')
+ M_D = ABS(M_C - M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 788
+ M_A = TO_FM('.7699115044247787610619469026548672566371681415929204')
+ CALL FM_BERN(102,M_A,M_C)
+ M_D = TO_FM('5.7022917356035929245914353639470138260075545712953255M+80')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 789
+ M_A = TO_FM('.7699115044247787610619469026548672566371681415929204')
+ CALL FM_BERN(76,M_A,M_C)
+ M_D = TO_FM('-6.3274121765674850311763600458139008604123253720098077M+50')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 790
+ M_A = TO_FM('.7699115044247787610619469026548672566371681415929204')
+ M_C = BERNOULLI(76)*M_A
+ M_D = TO_FM('-6.3274121765674850311763600458139008604123253720098077M+50')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BERN ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 791
+ M_A = TO_FM('769.9115044247787610619469026548672566371681415929204')
+ CALL FM_POCH(M_A,10,M_C)
+ M_D = TO_FM('7.7568981408767238023000514593534249181767332686451635M+28')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 792
+ M_A = TO_FM('7699.115044247787610619469026548672566371681415929204')
+ CALL FM_POCH(M_A,2222,M_C)
+ M_D = TO_FM('1.3306321985792900130409652455318897459921360351317942M+8763')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 793
+ M_A = TO_FM('-7')
+ CALL FM_POCH(M_A,12,M_C)
+ M_D = TO_FM('0')
+ M_D = ABS(M_C - M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 794
+ M_A = TO_FM('7.7568981408767238023000514593534249181767332686451635M+281')
+ CALL FM_POCH(M_A,6,M_C)
+ M_D = TO_FM('2.1783543710019819738631136312604490177244818356538937M+1691')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 795
+ M_A = TO_FM('7.7568981408767238023000514593534249181767332686451635M-281')
+ CALL FM_POCH(M_A,8,M_C)
+ M_D = TO_FM('3.9094766630018687963592259355141261587610735673971624M-277')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 796
+ M_A = TO_FM('7.7568981408767238023000514593534249181767332686451635M-281')
+ CALL FM_POCH(M_A,1,M_C)
+ M_D = TO_FM('7.7568981408767238023000514593534249181767332686451635M-281')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 797
+ M_A = TO_FM('7.7568981408767238023000514593534249181767332686451635M-281')
+ CALL FM_POCH(M_A,0,M_C)
+ M_D = TO_FM('1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 798
+ M_A = TO_FM('0')
+ CALL FM_POCH(M_A,8,M_C)
+ M_D = TO_FM('0')
+ M_D = ABS(M_C - M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 799
+ M_A = TO_FM('769.9115044247787610619469026548672566371681415929204')
+ M_C = POCHHAMMER(M_A,10)
+ M_D = TO_FM('7.7568981408767238023000514593534249181767332686451635M+28')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' POCH ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 800
+ CALL FM_EULR(M_C)
+ M_D = TO_FM('.5772156649015328606065120900824024310421593359399236')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' EULR ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 801
+ NDGSAV = NDIG
+ NDIG = MIN(NDIGMX,INT(1785*DLOGTN/DLOGMB)+2)
+ CALL FM_EULR(M_C)
+ M_D = TO_FM( &
+ ' .5772156649015328606065120900824024310421593359399235988057672348848677267'// &
+ '776646709369470632917467495146314472498070824809605040144865428362241739976'// &
+ '449235362535003337429373377376739427925952582470949160087352039481656708532'// &
+ '331517766115286211995015079847937450857057400299213547861466940296043254215'// &
+ '190587755352673313992540129674205137541395491116851028079842348775872050384'// &
+ '310939973613725530608893312676001724795378367592713515772261027349291394079'// &
+ '843010341777177808815495706610750101619166334015227893586796549725203621287'// &
+ '922655595366962817638879272680132431010476505963703947394957638906572967929'// &
+ '601009015125195950922243501409349871228247949747195646976318506676129063811'// &
+ '051824197444867836380861749455169892792301877391072945781554316005002182844'// &
+ '096053772434203285478367015177394398700302370339518328690001558193988042707'// &
+ '411542227819716523011073565833967348717650491941812300040654693142999297779'// &
+ '569303100503086303418569803231083691640025892970890985486825777364288253954'// &
+ '925873629596133298574739302373438847070370284412920166417850248733379080562'// &
+ '754998434590761643167103146710722370021810745044418664759134803669025532458'// &
+ '625442225345181387912434573501361297782278288148945909863846006293169471887'// &
+ '149587525492366493520473243641097268276160877595088095126208404544477992299'// &
+ '157248292516251278427659657083214610298214617951957959095922704208989627971'// &
+ '255363217948873764210660607065982561990102880756125199137511678217643619057'// &
+ '058440783573501580056077457934213144988500786415171615194565706170432450750'// &
+ '081687052307890937046143066848179164968425491504967243121837838753564894950'// &
+ '868454102340601622508515583867234944187880440940770106883795111307872023426'// &
+ '395226920971608856908382511378712836820491178925944784861991185293910293099'// &
+ '059255266917274468920443869711147174571574573203935209122316085086828')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= MAX(TO_FM('1.0E-1785'),10*EPSILON(M_C)))) THEN
+ CALL ERRPRT_FM(' EULR ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+ NDIG = NDGSAV
+
+ RETURN
+ END SUBROUTINE TEST43
+
+ SUBROUTINE TEST44(NCASE,NERROR,KLOG)
+
+! Test Gamma, Factorial, Log(Gamma), Beta, Binomial.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing Gamma, Factorial, Log(Gamma), Beta, Binomial.')")
+
+ NCASE = 802
+ M_A = 19
+ CALL FM_GAM(M_A,M_C)
+ M_D = TO_FM('6.402373705728M+15')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 803
+ M_A = TO_FM('.7699115044247787610619469026548672566371681415929204')
+ CALL FM_GAM(M_A,M_C)
+ M_D = TO_FM('1.1998023858495967876496039855917100290498970370440326')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 804
+ M_A = TO_FM('.7699115044247787610619469026548672566371681415929204')
+ CALL FM_GAM(M_A,M_C)
+ M_D = TO_FM('1.1998023858495967876496039855917100290498970370440326')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 805
+ M_A = TO_FM('5.7699115044247787610619469026548672566371681415929204')
+ CALL FM_GAM(M_A,M_C)
+ M_D = TO_FM('8.1434691207877806133071511233406796488474685081500979M+1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 806
+ M_A = TO_FM('7.7568981408767238023000514593534249181767332686451635M-281')
+ CALL FM_GAM(M_A,M_C)
+ M_D = TO_FM('1.2891751081921193691625844770542239587773115818085396M+280')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 807
+ M_A = TO_FM('2')
+ CALL FM_GAM(M_A,M_C)
+ M_D = TO_FM('1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 808
+ M_A = TO_FM('5.7699115044247787610619469026548672566371681415929204')
+ M_C = GAMMA(M_A)
+ M_D = TO_FM('8.1434691207877806133071511233406796488474685081500979M+1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' GAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 809
+ M_A = 33
+ CALL FM_FACT(M_A,M_C)
+ M_D = TO_FM('8.68331761881188649551819440128M+36')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' FACT ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 810
+ M_A = TO_FM('769.9115044247787610619469026548672566371681415929204')
+ CALL FM_FACT(M_A,M_C)
+ M_D = TO_FM('5.9982590033571347622193071279165294725603013413394492M+1889')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' FACT ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 811
+ M_A = TO_FM('769.9115044247787610619469026548672566371681415929204')
+ M_C = FACTORIAL(M_A)
+ M_D = TO_FM('5.9982590033571347622193071279165294725603013413394492M+1889')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' FACT ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 812
+ M_A = TO_FM('1.0M-222')
+ CALL FM_LNGM(M_A,M_C)
+ M_D = TO_FM('5.1117389064467814185199410293992885408744453047558760M+2')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' LNGM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 813
+ M_A = TO_FM('2')
+ CALL FM_LNGM(M_A,M_C)
+ M_D = TO_FM('0')
+ M_D = ABS(M_C - M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' LNGM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 814
+ M_A = TO_FM('33')
+ CALL FM_LNGM(M_A,M_C)
+ M_D = TO_FM('8.1557959456115037178502968666011206687099284403417368M+1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' LNGM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 815
+ M_A = TO_FM('2.00000000000000000001')
+ CALL FM_LNGM(M_A,M_C)
+ M_D = TO_FM('4.2278433509846713939671258025183870114019600466320121M-21')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' LNGM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 816
+ M_C = LOG_GAMMA(TO_FM('33'))
+ M_D = TO_FM('8.1557959456115037178502968666011206687099284403417368M+1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' LNGM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 817
+ M_A = TO_FM('2.0706137739520290320140007735608464643737932737070189M-223')
+ M_B = TO_FM('.78')
+ CALL FM_BETA(M_A,M_B,M_C)
+ M_D = TO_FM('4.8294858876137637017880452468052846823385248996130407M+222')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 818
+ M_A = TO_FM('.78')
+ M_B = TO_FM('2.0706137739520290320140007735608464643737932737070189M-223')
+ CALL FM_BETA(M_A,M_B,M_C)
+ M_D = TO_FM('4.8294858876137637017880452468052846823385248996130407M+222')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 819
+ M_A = TO_FM('-4.5')
+ M_B = TO_FM('4.5')
+ CALL FM_BETA(M_A,M_B,M_C)
+ M_D = TO_FM('0')
+ M_D = ABS(M_C - M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 820
+ M_A = TO_FM('-5.5')
+ M_B = TO_FM('4.5')
+ CALL FM_BETA(M_A,M_B,M_C)
+ M_D = TO_FM('0')
+ M_D = ABS(M_C - M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 821
+ M_A = TO_FM('10')
+ M_B = TO_FM('4')
+ CALL FM_BETA(M_A,M_B,M_C)
+ M_D = TO_FM('3.4965034965034965034965034965034965034965034965034965M-4')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 822
+ M_A = TO_FM('1.0M+1234')
+ M_B = TO_FM('2.2')
+ CALL FM_BETA(M_A,M_B,M_C)
+ M_D = TO_FM('1.7462392672319547876554292922652110015806932440139209M-2715')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 823
+ M_A = TO_FM('10')
+ M_B = TO_FM('5.3')
+ CALL FM_BETA(M_A,M_B,M_C)
+ M_D = TO_FM('7.0836036771097107530120640698518155187687458162734679M-5')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 824
+ M_A = TO_FM('10.3')
+ M_B = TO_FM('5')
+ CALL FM_BETA(M_A,M_B,M_C)
+ M_D = TO_FM('8.8146035423244390793072072569173028531206477712519934M-5')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 825
+ M_A = TO_FM('10.3')
+ M_B = TO_FM('5')
+ M_C = BETA(M_A,M_B)
+ M_D = TO_FM('8.8146035423244390793072072569173028531206477712519934M-5')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' BETA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 826
+ M_A = TO_FM('12.5')
+ M_B = TO_FM('0')
+ CALL FM_COMB(M_A,M_B,M_C)
+ M_D = TO_FM('1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 827
+ M_A = TO_FM('5')
+ M_B = TO_FM('-2')
+ CALL FM_COMB(M_A,M_B,M_C)
+ M_D = TO_FM('0')
+ M_D = ABS(M_C - M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 828
+ M_A = TO_FM('12.5')
+ M_B = TO_FM('12.5')
+ CALL FM_COMB(M_A,M_B,M_C)
+ M_D = TO_FM('1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 829
+ M_A = TO_FM('-4.5')
+ M_B = TO_FM('4.5')
+ CALL FM_COMB(M_A,M_B,M_C)
+ M_D = TO_FM('0')
+ M_D = ABS(M_C - M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 830
+ M_A = TO_FM('-4.5')
+ M_B = TO_FM('4.5')
+ CALL FM_COMB(M_A,M_B,M_C)
+ M_D = TO_FM('0')
+ M_D = ABS(M_C - M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 831
+ M_A = TO_FM('-10')
+ M_B = TO_FM('3')
+ CALL FM_COMB(M_A,M_B,M_C)
+ M_D = TO_FM('-220')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 832
+ M_A = TO_FM('52')
+ M_B = TO_FM('5')
+ CALL FM_COMB(M_A,M_B,M_C)
+ M_D = TO_FM('2.59896M+6')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 833
+ M_A = TO_FM('1.0M+1234')
+ M_B = TO_FM('7')
+ CALL FM_COMB(M_A,M_B,M_C)
+ M_D = TO_FM('1.9841269841269841269841269841269841269841269841269841M+8634')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 834
+ M_A = TO_FM('1.0M+123')
+ M_B = TO_FM('2.2')
+ CALL FM_COMB(M_A,M_B,M_C)
+ M_D = TO_FM('1.6423797032130683531106846289429264567307029528308099M+270')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 835
+ M_A = TO_FM('1.0M-100')
+ M_B = TO_FM('4')
+ CALL FM_COMB(M_A,M_B,M_C)
+ M_D = TO_FM('-2.5M-101')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 836
+ M_A = TO_FM('1.0M+123')
+ M_B = TO_FM('2.2')
+ M_C = BINOMIAL(M_A,M_B)
+ M_D = TO_FM('1.6423797032130683531106846289429264567307029528308099M+270')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' COMB ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST44
+
+ SUBROUTINE TEST45(NCASE,NERROR,KLOG)
+
+! Test Incomplete Gamma, Incomplete Beta.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing Incomplete Gamma, Incomplete Beta.')")
+
+ NCASE = 837
+ M_A = TO_FM('2.0706137739520290320140007735608464643737932737070189M-145')
+ M_B = TO_FM('.34')
+ CALL FM_IGM1(M_A,M_B,M_C)
+ M_D = TO_FM('4.8294858876137637017880452468052846823385248996130407M+144')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 838
+ M_A = TO_FM('1.0E-50')
+ M_B = TO_FM('1.0E+555')
+ CALL FM_IGM1(M_A,M_B,M_C)
+ M_D = TO_FM('9.9999999999999999999999999999999999999999999999999423M+49')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 839
+ M_A = TO_FM('1.2')
+ M_B = TO_FM('2.3')
+ CALL FM_IGM1(M_A,M_B,M_C)
+ M_D = TO_FM('7.9163089830797686672658085698101181778608009481363580M-1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 840
+ M_A = TO_FM('23.4')
+ M_B = TO_FM('456.7')
+ CALL FM_IGM1(M_A,M_B,M_C)
+ M_D = TO_FM('3.9191215305400046110416169991395759293572844563673750M+21')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 841
+ M_A = TO_FM('1.2')
+ M_B = TO_FM('0')
+ CALL FM_IGM1(M_A,M_B,M_C)
+ M_D = TO_FM('0')
+ M_D = ABS(M_C - M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 842
+ M_A = TO_FM('-1234.5')
+ M_B = TO_FM('3.4')
+ CALL FM_IGM1(M_A,M_B,M_C)
+ M_D = TO_FM('-2.0892439131810030556730824779643382797767198269736235M-661')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 843
+ M_A = TO_FM('10.3')
+ M_B = TO_FM('230.7')
+ CALL FM_IGM1(M_A,M_B,M_C)
+ M_D = TO_FM('7.1643068906237524454762965471616445342244699109269471M+5')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 844
+ M_A = TO_FM('1.2')
+ M_B = TO_FM('2.3')
+ M_C = INCOMPLETE_GAMMA1(M_A,M_B)
+ M_D = TO_FM('7.9163089830797686672658085698101181778608009481363580M-1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM1 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 845
+ M_A = TO_FM('0')
+ M_B = TO_FM('4.5')
+ CALL FM_IGM2(M_A,M_B,M_C)
+ M_D = TO_FM('2.0734007547146144328855938695797884889319725701443004M-3')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 846
+ M_A = TO_FM('4.5')
+ M_B = TO_FM('0')
+ CALL FM_IGM2(M_A,M_B,M_C)
+ M_D = TO_FM('1.1631728396567448929144224109426265262108918305803166M+1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 847
+ M_A = TO_FM('1.2')
+ M_B = TO_FM('2.3')
+ CALL FM_IGM2(M_A,M_B,M_C)
+ M_D = TO_FM('1.2653784409178374391437079820481858290074190484504480M-1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 848
+ M_A = TO_FM('3.4')
+ M_B = TO_FM('456.7')
+ CALL FM_IGM2(M_A,M_B,M_C)
+ M_D = TO_FM('1.1043526800164195407100289367720949121507981651704628M-192')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 849
+ M_A = TO_FM('1.0E-30')
+ M_B = TO_FM('40.7')
+ CALL FM_IGM2(M_A,M_B,M_C)
+ M_D = TO_FM('5.0619447546123889551107110735110897294460083487536391M-20')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 850
+ M_A = TO_FM('-8000.3')
+ M_B = TO_FM('1.0e-10')
+ CALL FM_IGM2(M_A,M_B,M_C)
+ M_D = TO_FM('1.2499531266327356460522174653022492899665091451890036M+79999')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 851
+ M_A = TO_FM('1')
+ M_B = TO_FM('-10.7')
+ CALL FM_IGM2(M_A,M_B,M_C)
+ M_D = TO_FM('4.4355855130297866938628363428602120081387560278336788M+4')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 852
+ M_A = TO_FM('1.2')
+ M_B = TO_FM('2.3')
+ M_C = INCOMPLETE_GAMMA2(M_A,M_B)
+ M_D = TO_FM('1.2653784409178374391437079820481858290074190484504480M-1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IGM2 ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 853
+ M_A = TO_FM('0.1')
+ M_B = TO_FM('23.4')
+ M_C = TO_FM('34.5')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('5.8731980918960730463350151650813268739874201571164800M-27')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 854
+ M_A = TO_FM('8.115640517330775M-1')
+ M_B = TO_FM('2.00853601446773')
+ M_C = TO_FM('1.59735792202923')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('2.0112520048150164306467955877563719782378767062440103M-1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 855
+ M_A = TO_FM('9.01737835258975M-1')
+ M_B = TO_FM('2.00853601446773')
+ M_C = TO_FM('1.59735792202923')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('2.2512248738228585976753517954889151150428002974819213M-1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 856
+ M_A = TO_FM('9.6097615596216720E-01')
+ M_B = TO_FM('1.970425178583792')
+ M_C = TO_FM('5.5680052333367')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('2.8619456987740165364092968281459448023932520843535423M-2')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 857
+ M_A = TO_FM('4.764360371097952E-01')
+ M_B = TO_FM('1.161514683661584E+01')
+ M_C = TO_FM('2.937801562768354E-01')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('2.3604503996731113868791517339909092506365724801689105M-5')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 858
+ M_A = TO_FM('0.9')
+ M_B = TO_FM('23.4')
+ M_C = TO_FM('34.5')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('7.3148127865937299821246829407023943740949130742928268M-18')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 859
+ M_A = TO_FM('9.99496253868099M-1')
+ M_B = TO_FM('2.47067979368109M+6')
+ M_C = TO_FM('6.09475681774953M-100')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('1.7681753021411259894614747665450637683755190050365931M-544')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 860
+ M_A = TO_FM('6.213433771653724M-1')
+ M_B = TO_FM('8.854622686031200M-1')
+ M_C = TO_FM('5.00000854049816M-121')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('1.1281271573737080091147788530326864610276172049831497M+0')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 861
+ M_A = TO_FM('5.304391676698501M-15')
+ M_B = TO_FM('4.870186358377400M+2')
+ M_C = TO_FM('4.999955247889730M-98')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('8.7892314482956847896604128106803662527479433068750459M-6956')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 862
+ M_A = TO_FM('1.882803169800314M-7')
+ M_B = TO_FM('1.591547060066600M-169')
+ M_C = TO_FM('3.521822614438970M+6')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('6.2831946669434576663925763649227277100409122269443137M+168')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 863
+ M_A = TO_FM('.9999999999999')
+ M_B = TO_FM('8.591098092677430M+2')
+ M_C = TO_FM('1.863210949748253M+1')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('3.9062929191651064065641350979581425238442928803700306M-40')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 864
+ M_A = TO_FM('2.531772074701081M-99')
+ M_B = TO_FM('3.547571261801072M+2')
+ M_C = TO_FM('1.974896958876250M+6')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('4.0957237103166196693191012056689839835950377114705018M-34981')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 865
+ M_A = TO_FM('.99999999999999')
+ M_B = TO_FM('1.0E-123')
+ M_C = TO_FM('1.0E-134')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('1.0M+123')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 866
+ M_A = TO_FM('1')
+ M_B = TO_FM('2.65')
+ M_C = TO_FM('4.88')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('1.5020204575152306127604878970920601604169827852591720M-2')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 867
+ M_A = TO_FM('0')
+ M_B = TO_FM('2.65')
+ M_C = TO_FM('4.88')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('0')
+ M_D = ABS(M_C - M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 868
+ M_A = TO_FM('.998')
+ M_B = TO_FM('759.6')
+ M_C = TO_FM('4.95e-57')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('9.7133692099062434492386763673434080317019087637060970M-2')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 869
+ M_A = TO_FM('4.764360371097952E-01')
+ M_B = TO_FM('1.161514683661584E+01')
+ M_C = TO_FM('2.937801562768354E-01')
+ M_C = INCOMPLETE_BETA(M_A,M_B,M_C)
+ M_D = TO_FM('2.3604503996731113868791517339909092506365724801689105M-5')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST45
+
+ SUBROUTINE TEST46(NCASE,NERROR,KLOG)
+
+! Test the Polygamma, Psi functions.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ INTEGER KLOG,NCASE,NERROR
+
+ WRITE (KW,"(/' Testing Polygamma, Psi.')")
+
+
+ NCASE = 870
+ M_A = TO_FM('4.5')
+ CALL FM_PGAM(0,M_A,M_C)
+ M_D = TO_FM('1.3888709263595289015114046193821968137592213477205183M+0')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 871
+ M_A = TO_FM('1.0E-123')
+ CALL FM_PGAM(1,M_A,M_C)
+ M_D = TO_FM('1.0M+246')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 872
+ M_A = TO_FM('1.0E-123')
+ CALL FM_PGAM(2,M_A,M_C)
+ M_D = TO_FM('-2.0M+369')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 873
+ M_A = TO_FM('2.0706137739520290320140007735608464643737932737070189M-1')
+ CALL FM_PGAM(1,M_A,M_C)
+ M_D = TO_FM('2.4580954480899934124966756607870377560864828849100481M+1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 874
+ M_A = TO_FM('2.0706137739520290320140007735608464643737932737070189M-1')
+ CALL FM_PGAM(6,M_A,M_C)
+ M_D = TO_FM('-4.4120531379423056741117517146346730469682094212273241M+7')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 875
+ M_A = TO_FM('2.0706137739520290320140007735608464643737932737070189M-1')
+ CALL FM_PGAM(23,M_A,M_C)
+ M_D = TO_FM('6.7006365293376930742991440911935017694098601683947073M+38')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 876
+ M_A = TO_FM('1.0E+123')
+ CALL FM_PGAM(4,M_A,M_C)
+ M_D = TO_FM('-6.0M-492')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 877
+ M_A = TO_FM('-6.499999840238790109')
+ CALL FM_PGAM(4,M_A,M_C)
+ M_D = TO_FM('1.0135142464863270830609416082237513111216512170936928M-16')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 878
+ M_C = POLYGAMMA(2,TO_FM('1.0E-123'))
+ M_D = TO_FM('-2.0M+369')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PGAM ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 879
+ M_A = TO_FM('1.0E-135')
+ CALL FM_PSI(M_A,M_C)
+ M_D = TO_FM('-1.0M+135')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 880
+ M_A = TO_FM('1.2')
+ CALL FM_PSI(M_A,M_C)
+ M_D = TO_FM('-2.8903989659218829554720796244995210482558827420664281M-1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 881
+ M_A = TO_FM('-3.4')
+ CALL FM_PSI(M_A,M_C)
+ M_D = TO_FM('2.3844508141180140670320531380285019520468887144980679M+0')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 882
+ M_A = TO_FM('57')
+ CALL FM_PSI(M_A,M_C)
+ M_D = TO_FM('4.0342536898816977739559850955847848905386809772893269M+0')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 883
+ M_A = TO_FM('1.0E+56')
+ CALL FM_PSI(M_A,M_C)
+ M_D = TO_FM('1.2894476520766655830500752146232439562566168336321129M+2')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 884
+ M_A = TO_FM('1.0')
+ CALL FM_PSI(M_A,M_C)
+ M_D = TO_FM('-5.7721566490153286060651209008240243104215933593992360M-1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 885
+ M_A = TO_FM('1.0E+23456')
+ CALL FM_PSI(M_A,M_C)
+ M_D = TO_FM('5.4009435941268335564326007561076446853491436517276499M+4')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 886
+ M_A = TO_FM('1.46163214496836234126266')
+ CALL FM_PSI(M_A,M_C)
+ M_D = TO_FM('4.4287869692570149446165609601581442013784186419176534M-25')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 887
+ M_C = PSI(TO_FM('1.2'))
+ M_D = TO_FM('-2.8903989659218829554720796244995210482558827420664281M-1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-49'))) THEN
+ CALL ERRPRT_FM(' PSI ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST46
+
+ SUBROUTINE TEST47(NCASE,NERROR,KLOG)
+
+! Test the different rounding modes.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ INTEGER KLOG,NCASE,NERROR
+ INTEGER SEED(7)
+
+ WRITE (KW,"(/' Testing the different rounding modes.')")
+
+
+ CALL FMSETVAR(' MBASE = 10 ')
+ CALL FMSETVAR(' NDIG = 20 ')
+ M_A = 0
+
+ NCASE = 888
+ CALL FMSETVAR(' KROUND = 1 ')
+ M_C = TO_FM('2')/TO_FM('3')
+ M_D = TO_FM('.66666666666666666667')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 889
+ CALL FMSETVAR(' KROUND = -1 ')
+ M_C = TO_FM('2')/TO_FM('3')
+ M_D = TO_FM('.66666666666666666666')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 890
+ CALL FMSETVAR(' KROUND = 0 ')
+ M_C = TO_FM('2')/TO_FM('3')
+ M_D = TO_FM('.66666666666666666666')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 891
+ CALL FMSETVAR(' KROUND = 2 ')
+ M_C = TO_FM('2')/TO_FM('3')
+ M_D = TO_FM('.66666666666666666667')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 892
+ CALL FMSETVAR(' KROUND = 1 ')
+ M_C = TO_FM('1')/TO_FM('3')
+ M_D = TO_FM('.33333333333333333333')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 893
+ CALL FMSETVAR(' KROUND = -1 ')
+ M_C = TO_FM('1')/TO_FM('3')
+ M_D = TO_FM('.33333333333333333333')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 894
+ CALL FMSETVAR(' KROUND = 0 ')
+ M_C = TO_FM('1')/TO_FM('3')
+ M_D = TO_FM('.33333333333333333333')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 895
+ CALL FMSETVAR(' KROUND = 2 ')
+ M_C = TO_FM('1')/TO_FM('3')
+ M_D = TO_FM('.33333333333333333334')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 896
+ CALL FMSETVAR(' KROUND = 1 ')
+ M_C = TO_FM('-1')/TO_FM('3')
+ M_D = TO_FM('-.33333333333333333333')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 897
+ CALL FMSETVAR(' KROUND = -1 ')
+ M_C = TO_FM('-1')/TO_FM('3')
+ M_D = TO_FM('-.33333333333333333334')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 898
+ CALL FMSETVAR(' KROUND = 0 ')
+ M_C = TO_FM('-1')/TO_FM('3')
+ M_D = TO_FM('-.33333333333333333333')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 899
+ CALL FMSETVAR(' KROUND = 2 ')
+ M_C = TO_FM('-1')/TO_FM('3')
+ M_D = TO_FM('-.33333333333333333333')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 900
+ CALL FMSETVAR(' KROUND = 1 ')
+ M_C = TO_FM('-2')/TO_FM('3')
+ M_D = TO_FM('-.66666666666666666667')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 901
+ CALL FMSETVAR(' KROUND = -1 ')
+ M_C = TO_FM('-2')/TO_FM('3')
+ M_D = TO_FM('-.66666666666666666667')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 902
+ CALL FMSETVAR(' KROUND = 0 ')
+ M_C = TO_FM('-2')/TO_FM('3')
+ M_D = TO_FM('-.66666666666666666666')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 903
+ CALL FMSETVAR(' KROUND = 2 ')
+ M_C = TO_FM('-2')/TO_FM('3')
+ M_D = TO_FM('-.66666666666666666666')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 904
+ CALL FMSETVAR(' KROUND = 1 ')
+ M_C = TO_FM('1') + TO_FM('3E-555')
+ M_D = TO_FM('1.0000000000000000000')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 905
+ CALL FMSETVAR(' KROUND = -1 ')
+ M_C = TO_FM('1') + TO_FM('3E-555')
+ M_D = TO_FM('1.0000000000000000000')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 906
+ CALL FMSETVAR(' KROUND = 0 ')
+ M_C = TO_FM('1') + TO_FM('3E-555')
+ M_D = TO_FM('1.0000000000000000000')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 907
+ CALL FMSETVAR(' KROUND = 2 ')
+ M_C = TO_FM('1') + TO_FM('3E-555')
+ M_D = TO_FM('1.0000000000000000001')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 908
+ CALL FMSETVAR(' KROUND = 1 ')
+ M_C = TO_FM('1') - TO_FM('3E-555')
+ M_D = TO_FM('1.0000000000000000000')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 909
+ CALL FMSETVAR(' KROUND = -1 ')
+ M_C = TO_FM('1') - TO_FM('3E-555')
+ M_D = TO_FM('.99999999999999999999')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 910
+ CALL FMSETVAR(' KROUND = 0 ')
+ M_C = TO_FM('1') - TO_FM('3E-555')
+ M_D = TO_FM('.99999999999999999999')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 911
+ CALL FMSETVAR(' KROUND = 2 ')
+ M_C = TO_FM('1') - TO_FM('3E-555')
+ M_D = TO_FM('1.0000000000000000000')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 912
+ CALL FMSETVAR(' KROUND = 1 ')
+ M_C = TO_FM('-1') + TO_FM('3E-555')
+ M_D = TO_FM('-1.0000000000000000000')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 913
+ CALL FMSETVAR(' KROUND = -1 ')
+ M_C = TO_FM('-1') + TO_FM('3E-555')
+ M_D = TO_FM('-1.0000000000000000000')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 914
+ CALL FMSETVAR(' KROUND = 0 ')
+ M_C = TO_FM('-1') + TO_FM('3E-555')
+ M_D = TO_FM('-.99999999999999999999')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 915
+ CALL FMSETVAR(' KROUND = 2 ')
+ M_C = TO_FM('-1') + TO_FM('3E-555')
+ M_D = TO_FM('-.99999999999999999999')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 916
+ CALL FMSETVAR(' KROUND = 1 ')
+ M_C = TO_FM('-1') - TO_FM('3E-555')
+ M_D = TO_FM('-1.0000000000000000000')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 917
+ CALL FMSETVAR(' KROUND = -1 ')
+ M_C = TO_FM('-1') - TO_FM('3E-555')
+ M_D = TO_FM('-1.0000000000000000001')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 918
+ CALL FMSETVAR(' KROUND = 0 ')
+ M_C = TO_FM('-1') - TO_FM('3E-555')
+ M_D = TO_FM('-1.0000000000000000000')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 919
+ CALL FMSETVAR(' KROUND = 2 ')
+ M_C = TO_FM('-1') - TO_FM('3E-555')
+ M_D = TO_FM('-1.0000000000000000000')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ CALL FMSETVAR(' MBASE = 2 ')
+ CALL FMSETVAR(' NDIG = 53 ')
+ NCASE = 920
+ M_A = TO_FM('0.125')
+ M_B = TO_FM('23.25')
+ M_C = TO_FM('34.5')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('6.1345805065305141873M-25')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 921
+ M_A = TO_FM('0.52')
+ M_B = TO_FM('2.01')
+ M_C = TO_FM('1.6')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('1.0304844627978347604M-1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 922
+ M_A = TO_FM('9.01737835258975M-1')
+ M_B = TO_FM('2.00853601446773')
+ M_C = TO_FM('1.59735792202923')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('2.2512248738228585986M-1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 923
+ M_A = TO_FM('9.6097615596216720E-01')
+ M_B = TO_FM('1.970425178583792')
+ M_C = TO_FM('5.5680052333367')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('2.8619456987740165927M-2')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 924
+ M_A = TO_FM('4.764360371097952E-01')
+ M_B = TO_FM('1.161514683661584E+01')
+ M_C = TO_FM('2.937801562768354E-01')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('2.3604503996731113869M-5')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 925
+ M_A = TO_FM('0.9')
+ M_B = TO_FM('23.4')
+ M_C = TO_FM('34.5')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('7.3148127865937395334M-18')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-15'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ CALL FMSETVAR(' MBASE = 3 ')
+ CALL FMSETVAR(' NDIG = 55 ')
+ NCASE = 926
+ M_A = TO_FM('0.1')
+ M_B = TO_FM('23.4')
+ M_C = TO_FM('34.5')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('5.87319809189607304633501593392681M-27')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 927
+ M_A = TO_FM('0.52')
+ M_B = TO_FM('2.1')
+ M_C = TO_FM('1.6')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('9.25745341552810210762563659429375M-2')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 928
+ M_A = TO_FM('9.01737835258975M-1')
+ M_B = TO_FM('2.00853601446773')
+ M_C = TO_FM('1.59735792202923')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('2.25122487382285859767535178829535M-1')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 929
+ M_A = TO_FM('9.6097615596216720E-01')
+ M_B = TO_FM('1.970425178583792')
+ M_C = TO_FM('5.5680052333367')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('2.861945698774016536409296855493M-2')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 930
+ M_A = TO_FM('4.764360371097952E-01')
+ M_B = TO_FM('1.161514683661584E+01')
+ M_C = TO_FM('2.937801562768354E-01')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('2.36045039967311138687915158221269M-5')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 931
+ M_A = TO_FM('0.9')
+ M_B = TO_FM('23.4')
+ M_C = TO_FM('34.5')
+ CALL FM_IBTA(M_A,M_B,M_C,MFM6)
+ CALL FM_EQ(MFM6,M_C)
+ M_D = TO_FM('7.31481278659372998212468424608367M-18')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN
+ CALL ERRPRT_FM(' IBTA ',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 932
+ CALL FPST2M('1.67',MP1)
+ CALL FPST2M('2.64',MP2)
+ CALL FPADD(MP1,MP2,MP3)
+ CALL FPEQ(MP3,MP1)
+ CALL FPST2M('-3.91',MP2)
+ CALL FPSUB(MP1,MP2,MP3)
+ CALL FPEQ(MP3,MP1)
+ CALL FPST2M('4.58',MP2)
+ CALL FPMPY(MP1,MP2,MP3)
+ CALL FPEQ(MP3,MP1)
+ CALL FPST2M('0.27',MP2)
+ CALL FPDIV(MP1,MP2,MP3)
+ CALL FPEQ(MP3,MP1)
+ CALL FPADDI(MP1,2)
+ CALL FPMPYI(MP1,13,MP3)
+ CALL FPEQ(MP3,MP1)
+ CALL FPDIVI(MP1,11,MP3)
+ CALL FPEQ(MP3,MP1)
+ CALL FPLN(MP1,MP3)
+ CALL FPEQ(MP3,MP1)
+ CALL FPSIN(MP1,MP3)
+ CALL FPEQ(MP3,MP1)
+ CALL FPCOS(MP1,MP3)
+ CALL FPEQ(MP3,MP1)
+ CALL FPEXP(MP1,MP3)
+ CALL FPEQ(MP3,MP1)
+ CALL FPGAM(MP1,MP3)
+ CALL FPEQ(MP3,MP1)
+ CALL FMUNPK(MP1,M_C%MFM)
+ M_D = TO_FM('0.941122001974472326543759839200398')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-25'))) THEN
+ CALL ERRPRT_FM(' Pack ',M_C,'M_C',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 933
+ SEED = (/ 2718281,8284590,4523536,0287471,3526624,9775724,7093699 /)
+ CALL FM_RANDOM_SEED(PUT=SEED)
+ DO J1 = 1, 10
+ CALL FM_RANDOM_NUMBER(D1)
+ ENDDO
+ M_C = D1
+ M_D = TO_FM('0.945608442536777')
+ M_D = ABS((M_C - M_D)/M_D)
+ IF (.NOT.(M_D <= TO_FM('1.0E-10'))) THEN
+ CALL ERRPRT_FM(' Rand ',M_C,'M_C',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ CALL FMSETVAR(' MBASE = 10000 ')
+ CALL FMSETVAR(' NDIG = 5 ')
+
+ NCASE = 934
+ CALL FMSETVAR(' KROUND = 1 ')
+ CALL FMSETVAR(' KRPERF = 1 ')
+ M_C = SQRT( TO_FM('.49841718043038996023') )
+ M_D = TO_FM('.70598667156709832621')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ NCASE = 935
+ CALL FMSETVAR(' KROUND = 1 ')
+ CALL FMSETVAR(' KRPERF = 0 ')
+ M_C = SQRT( TO_FM('.49841718043038996023') )
+ M_D = TO_FM('.70598667156709832622')
+ IF (.NOT.(M_D == M_C)) THEN
+ CALL ERRPRT_FM(' Round',M_A,'M_A',M_C,'M_C',M_D,'M_D', &
+ NCASE,NERROR,KLOG)
+ ENDIF
+
+ RETURN
+ END SUBROUTINE TEST47
+
+ SUBROUTINE ERRPRTFM(NROUT,M1,NAME1,M2,NAME2,M3,NAME3, &
+ NCASE,NERROR,KLOG)
+
+! Print error messages for testing of real (FM) routines.
+
+! M1 is the value to be tested, as computed by the routine named NROUT.
+! M2 is the reference value, usually converted using FMST2M.
+! M3 is ABS(M1-M2), and ERRPRT is called if this is too big.
+! NAME1,NAME2,NAME3 are strings identifying which variables in the
+! calling routine correspond to M1,M2,M3.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: M1(-1:LUNPCK),M2(-1:LUNPCK),M3(-1:LUNPCK)
+
+ CHARACTER(2) :: NAME1,NAME2,NAME3
+ CHARACTER(6) :: NROUT
+ INTEGER KLOG,KWSAVE,NCASE,NERROR
+
+ NERROR = NERROR + 1
+ WRITE (KW, &
+ "(//' Error in case',I4,'. The routine',' being tested was ',A6)" &
+ ) NCASE,NROUT
+ WRITE (KLOG, &
+ "(//' Error in case',I4,'. The routine',' being tested was ',A6)" &
+ ) NCASE,NROUT
+
+! Temporarily change KW to KLOG so FMPRNT
+! will write to the log file.
+
+ KWSAVE = KW
+ KW = KLOG
+ WRITE (KLOG,"(1X,A,' =')") NAME1
+ CALL FMPRNT(M1)
+ WRITE (KLOG,"(1X,A,' =')") NAME2
+ CALL FMPRNT(M2)
+ WRITE (KLOG,"(1X,A,' =')") NAME3
+ CALL FMPRNT(M3)
+ KW = KWSAVE
+ RETURN
+ END SUBROUTINE ERRPRTFM
+
+ SUBROUTINE ERRPRTIM(NROUT,M1,NAME1,M2,NAME2, &
+ NCASE,NERROR,KLOG)
+
+! Print error messages for testing of integer (IM) routines.
+
+! M1 is the value to be tested, as computed by the routine named NROUT.
+! M2 is the reference value, usually converted using IMST2M.
+! NAME1,NAME2 are strings identifying which variables in the calling routine
+! correspond to M1,M2.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: M1(-1:LUNPCK),M2(-1:LUNPCK)
+
+ CHARACTER(2) :: NAME1,NAME2
+ CHARACTER(6) :: NROUT
+ INTEGER KLOG,KWSAVE,NCASE,NERROR
+
+ NERROR = NERROR + 1
+ WRITE (KW, &
+ "(//' Error in case',I4,'. The routine',' being tested was ',A6)" &
+ ) NCASE,NROUT
+ WRITE (KLOG, &
+ "(//' Error in case',I4,'. The routine',' being tested was ',A6)" &
+ ) NCASE,NROUT
+
+! Temporarily change KW to KLOG so IMPRNT
+! will write to the log file.
+
+ KWSAVE = KW
+ KW = KLOG
+ WRITE (KLOG,"(1X,A,' =')") NAME1
+ CALL IMPRNT(M1)
+ WRITE (KLOG,"(1X,A,' =')") NAME2
+ CALL IMPRNT(M2)
+ KW = KWSAVE
+ END SUBROUTINE ERRPRTIM
+
+ SUBROUTINE ERRPRTZM(NROUT,M1,NAME1,M2,NAME2,M3,NAME3, &
+ NCASE,NERROR,KLOG)
+
+! Print error messages.
+
+! M1 is the value to be tested, as computed by the routine named NROUT.
+! M2 is the reference value, usually converted using ZMST2M.
+! M3 is ABS(M1-M2), and ERRPRTZM is called if this is too big.
+! NAME1,NAME2,NAME3 are strings identifying which variables in the
+! calling routine correspond to M1,M2,M3.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ REAL (KIND(1.0D0)) :: M1(-1:LUNPKZ),M2(-1:LUNPKZ),M3(-1:LUNPKZ)
+
+ CHARACTER(2) :: NAME1,NAME2,NAME3
+ CHARACTER(6) :: NROUT
+ INTEGER KLOG,KWSAVE,NCASE,NERROR
+
+ NERROR = NERROR + 1
+ WRITE (KW, &
+ "(//' Error in case',I4,'. The routine',' being tested was ',A6)" &
+ ) NCASE,NROUT
+ WRITE (KLOG, &
+ "(//' Error in case',I4,'. The routine',' being tested was ',A6)" &
+ ) NCASE,NROUT
+
+! Temporarily change KW to KLOG so ZMPRNT
+! will write to the log file.
+
+ KWSAVE = KW
+ KW = KLOG
+ WRITE (KLOG,"(1X,A,' =')") NAME1
+ CALL ZMPRNT(M1)
+ WRITE (KLOG,"(1X,A,' =')") NAME2
+ CALL ZMPRNT(M2)
+ WRITE (KLOG,"(1X,A,' =')") NAME3
+ CALL ZMPRNT(M3)
+ KW = KWSAVE
+ END SUBROUTINE ERRPRTZM
+
+ SUBROUTINE ERRPRT_FM(NROUT,M1,NAME1,M2,NAME2,M3,NAME3, &
+ NCASE,NERROR,KLOG)
+
+! Print error messages for testing of TYPE (FM) interface routines.
+
+! M1 is the value to be tested, as computed by the routine named NROUT.
+! M2 is the reference value, usually converted using FMST2M.
+! M3 is ABS(M1-M2), and ERRPRT_FM is called if this is too big.
+! NAME1,NAME2,NAME3 are strings identifying which variables in the
+! calling routine correspond to M1,M2,M3.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ TYPE (FM) M1,M2,M3
+
+ CHARACTER(3) :: NAME1,NAME2,NAME3
+ CHARACTER(6) :: NROUT
+ INTEGER KLOG,KWSAVE,NCASE,NERROR
+
+ NERROR = NERROR + 1
+ WRITE (KW, &
+ "(//' Error in case',I4,'. The interface',' being tested was ',A6)" &
+ ) NCASE,NROUT
+ WRITE (KLOG, &
+ "(//' Error in case',I4,'. The interface',' being tested was ',A6)" &
+ ) NCASE,NROUT
+
+! Temporarily change KW to KLOG so FMPRNT
+! will write to the log file.
+
+ KWSAVE = KW
+ KW = KLOG
+ WRITE (KLOG,"(1X,A,' =')") NAME1
+ CALL FM_PRNT(M1)
+ WRITE (KLOG,"(1X,A,' =')") NAME2
+ CALL FM_PRNT(M2)
+ WRITE (KLOG,"(1X,A,' =')") NAME3
+ CALL FM_PRNT(M3)
+ KW = KWSAVE
+ END SUBROUTINE ERRPRT_FM
+
+ SUBROUTINE ERRPRT_IM(NROUT,M1,NAME1,M2,NAME2, &
+ NCASE,NERROR,KLOG)
+
+! Print error messages for testing of TYPE (IM) interface routines.
+
+! M1 is the value to be tested, as computed by the routine named NROUT.
+! M2 is the reference value, usually converted using IMST2M.
+! NAME1,NAME2 are strings identifying which variables in the calling routine
+! correspond to M1,M2.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ TYPE (IM) M1,M2
+
+ CHARACTER(3) :: NAME1,NAME2
+ CHARACTER(6) :: NROUT
+ INTEGER KLOG,KWSAVE,NCASE,NERROR
+
+ NERROR = NERROR + 1
+ WRITE (KW, &
+ "(//' Error in case',I4,'. The interface',' being tested was ',A6)" &
+ ) NCASE,NROUT
+ WRITE (KLOG, &
+ "(//' Error in case',I4,'. The interface',' being tested was ',A6)" &
+ ) NCASE,NROUT
+
+! Temporarily change KW to KLOG so IMPRNT
+! will write to the log file.
+
+ KWSAVE = KW
+ KW = KLOG
+ WRITE (KLOG,"(1X,A,' =')") NAME1
+ CALL IM_PRNT(M1)
+ WRITE (KLOG,"(1X,A,' =')") NAME2
+ CALL IM_PRNT(M2)
+ KW = KWSAVE
+ END SUBROUTINE ERRPRT_IM
+
+ SUBROUTINE ERRPRT_ZM(NROUT,M1,NAME1,M2,NAME2,M3,NAME3, &
+ NCASE,NERROR,KLOG)
+
+! Print error messages for testing of TYPE (ZM) interface routines.
+
+! M1 is the value to be tested, as computed by the routine named NROUT.
+! M2 is the reference value, usually converted using ZMST2M.
+! M3 is ABS(M1-M2), and ERRPRT_ZM is called if this is too big.
+! NAME1,NAME2,NAME3 are strings identifying which variables in the calling routine
+! correspond to M1,M2,M3.
+
+ USE FMVALS
+ USE FMZM
+ USE TEST_VARS
+
+ IMPLICIT NONE
+
+ TYPE (ZM) M1,M2,M3
+
+ CHARACTER(3) :: NAME1,NAME2,NAME3
+ CHARACTER(6) :: NROUT
+ INTEGER KLOG,KWSAVE,NCASE,NERROR
+
+ NERROR = NERROR + 1
+ WRITE (KW, &
+ "(//' Error in case',I4,'. The interface',' being tested was ',A6)" &
+ ) NCASE,NROUT
+ WRITE (KLOG, &
+ "(//' Error in case',I4,'. The interface',' being tested was ',A6)" &
+ ) NCASE,NROUT
+
+! Temporarily change KW to KLOG so ZMPRNT
+! will write to the log file.
+
+ KWSAVE = KW
+ KW = KLOG
+ WRITE (KLOG,"(1X,A,' =')") NAME1
+ CALL ZM_PRNT(M1)
+ WRITE (KLOG,"(1X,A,' =')") NAME2
+ CALL ZM_PRNT(M2)
+ WRITE (KLOG,"(1X,A,' =')") NAME3
+ CALL ZM_PRNT(M3)
+ KW = KWSAVE
+ END SUBROUTINE ERRPRT_ZM
+
+ SUBROUTINE PRTERR(KW,KLOG,NCASE,NERROR)
+ IMPLICIT NONE
+ INTEGER KW,KLOG,NCASE,NERROR
+
+ WRITE (KW,*) ' Error in case ',NCASE
+ WRITE (KLOG,*) ' '
+ WRITE (KLOG,*) ' Error in case ',NCASE
+ NERROR = NERROR + 1
+ END SUBROUTINE PRTERR
+
+ SUBROUTINE TIMEIT(TIME)
+
+ INTEGER JTIME,JRATE
+ REAL TIME
+
+! Return the system time. f90 version.
+
+ CALL SYSTEM_CLOCK(JTIME,JRATE)
+ TIME = REAL(JTIME)/REAL(JRATE)
+ RETURN
+ END SUBROUTINE TIMEIT
diff --git a/src/gauge/Makefile b/src/gauge/Makefile
index 82b7f4099e3c68b01fa6e4e0590a3d2d9a79b0a7..fe77fd120646a339953f3c574097c977aae1cd78 100644
--- a/src/gauge/Makefile
+++ b/src/gauge/Makefile
@@ -59,4 +59,3 @@ lib_gauge.a: $(OBJS)
clobber:
rm -f *.[Tiod] *.f90 *.mod lib_gauge.a
-clean:;make clobber
diff --git a/src/gauge/dsg.F90 b/src/gauge/dsg.F90
index b016084ca2e49a443ce0e1cfc5e80e9fef9bb383..29c11f821d66b47b8e8be645db0099d57cd5d90d 100644
--- a/src/gauge/dsg.F90
+++ b/src/gauge/dsg.F90
@@ -31,6 +31,7 @@ subroutine dsg(p, plaq, step)
use module_action_type
use module_vol
use module_staple
+ use module_switches
implicit none
GENERATOR_FIELD, intent(inout) :: p
@@ -61,6 +62,8 @@ subroutine dsg(p, plaq, step)
enddo
enddo
+ if (switches%boundary_sf) call dsg_sfdiff(p, plaq, step)
+
call nonactive(p) !! for ddhmc
call hmc_forces_new(p, step, plaq%fid)
diff --git a/src/gauge/dsig.F90 b/src/gauge/dsig.F90
index 50eb3b1efbce05f7c1e85fd75fa0bc95bc1d7ec9..4a55da21f5f277c15847bcbb3722d864dbafe52b 100644
--- a/src/gauge/dsig.F90
+++ b/src/gauge/dsig.F90
@@ -29,6 +29,91 @@ subroutine dsig(p, impg, step)
use module_field
use module_action_type
use module_vol
+ use module_switches
+ implicit none
+
+ GENERATOR_FIELD, intent(inout) :: p
+ type(type_impg), intent(in) :: impg
+ REAL, intent(in) :: step
+ REAL :: s1, s2, s3
+ SU3 :: uuu, w
+ integer :: mu, eo, i
+
+ COMPLEX, allocatable :: w1(:, :, :, :, :)
+ COMPLEX, allocatable :: w2(:, :, :, :, :)
+ COMPLEX, allocatable :: w3(:, :, :, :, :)
+ integer :: ierr
+
+
+ if (impg%beta1 == ZERO) return
+ if (step == ZERO) return
+
+ TIMING_START(timing_bin_dsig)
+ DEBUG2S("Start: dsig")
+
+ allocate(w1(NCOL, NCOL, volh_tot, EVEN:ODD, DIM), STAT = ierr)
+ allocate(w2(NCOL, NCOL, volh_tot, EVEN:ODD, DIM), STAT = ierr)
+ allocate(w3(NCOL, NCOL, volh_tot, EVEN:ODD, DIM), STAT = ierr)
+
+ call hmc_forces_old(p)
+ s1 = -step * impg%beta1 / THREE
+ s2 = -step * impg%beta2 / THREE
+ s3 = -step * impg%beta3 / THREE
+
+ do mu = 1, DIM
+ call r_staple(w1, gauge(1)%u(1,1,1,0,1), mu)
+ if (switches%boundary_sf) call schr_boundary_zero4(w1)
+ do eo = EVEN, ODD
+ !$omp parallel do private(uuu, w)
+ do i = 1, volh
+ call staple_r_fat(uuu, gauge(1)%u(1,1,1,0,1), w1, i, eo, mu)
+ call uu(w, gauge(1)%u(1, 1, i, eo, mu), uuu)
+ call im_tr_j(p(1, i, eo, mu), w, s1)
+ enddo
+ enddo
+
+ call u_staple(w1, gauge(1)%u(1,1,1,0,1), mu)
+ call d_staple(w2, gauge(1)%u(1,1,1,0,1), mu)
+ call l_staple(w3, gauge(1)%u(1,1,1,0,1), mu)
+
+ if (switches%boundary_sf) call schr_boundary_zero4(w1)
+ if (switches%boundary_sf) call schr_boundary_zero4(w2)
+ if (switches%boundary_sf) call schr_boundary_zero4(w3)
+
+ do eo = EVEN, ODD
+ !$omp parallel do private(uuu, w)
+ do i = 1, volh
+ call staple_udl(uuu, gauge(1)%u(1,1,1,0,1), w1, w2, w3, i, eo, mu)
+ call uu(w, gauge(1)%u(1, 1, i, eo, mu), uuu)
+ call im_tr_j(p(1, i, eo, mu), w, s1)
+ enddo
+ enddo
+
+ if (s2 /= ZERO) call die("imp_action ERROR") ! chai
+ if (s3 /= ZERO) call die("imp_action ERROR") ! para
+ enddo
+
+ if (switches%boundary_sf) call dsig_sfdiff(p, impg, step)
+
+ call nonactive(p) !! for ddhmc
+
+ call hmc_forces_new(p, step, impg%fid)
+
+
+ deallocate(w1, STAT = ierr)
+ deallocate(w2, STAT = ierr)
+
+ DEBUG2S("End: dsig")
+ TIMING_STOP(timing_bin_dsig)
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine dsig_old(p, impg, step)
+ use module_field
+ use module_action_type
+ use module_vol
+ use module_switches
implicit none
GENERATOR_FIELD, intent(inout) :: p
@@ -69,6 +154,7 @@ subroutine dsig(p, impg, step)
do mu = 1, DIM
call r_staple(w1, gauge(1)%u(1,1,1,0,1), mu)
+if (switches%boundary_sf) call schr_boundary_zero4(w1)
do eo = EVEN, ODD
!$omp parallel do private(uuu, w)
do i = 1, volh
@@ -81,6 +167,9 @@ subroutine dsig(p, impg, step)
call ul_staple(w1, gauge(1)%u(1,1,1,0,1), mu)
call dl_staple(w2, gauge(1)%u(1,1,1,0,1), mu)
+if (switches%boundary_sf) call schr_boundary_zero4(w1)
+if (switches%boundary_sf) call schr_boundary_zero4(w2)
+
do eo = EVEN, ODD
!$omp parallel do private(uuu, w)
do i = 1, volh
diff --git a/src/gauge/sig.F90 b/src/gauge/sig.F90
index 4fda40d86ba40f083994722c15e5f57a34025dd9..d4df57fdbd2fd9e54ea75fa9a4aa8ebbf6dbf7e7 100644
--- a/src/gauge/sig.F90
+++ b/src/gauge/sig.F90
@@ -40,16 +40,25 @@ REAL function sig(s_p, plaq, rect) ! returns S_g , s_plaq=sg(u)
use module_field
use module_action
use module_s_plaq
+ use module_switches
implicit none
REAL,intent(out) :: s_p, plaq(3), rect(3)
- REAL, external :: s_rect
+ REAL, external :: s_rect, s_plaq_sfdiff, s_rect_sfdiff
+ REAL :: tmp
s_p = s_plaq(gauge(1)%u, plaq)
sig = action%plaq%beta * s_p
+ if (switches%boundary_sf) sig = sig + action%plaq%beta * s_plaq_sfdiff(gauge(1)%u)
+!!write(*,*)sig
+
+
if (action%impg%beta1 /= ZERO) then
- sig = sig + action%impg%beta1 * s_rect(gauge(1)%u, rect)
+ tmp = s_rect(gauge(1)%u, rect)
+ if (switches%boundary_sf) tmp = tmp + s_rect_sfdiff(gauge(1)%u)
+ sig = sig + action%impg%beta1 * tmp
+!!write(*,*) action%impg%beta1 * tmp
else
rect=0
endif
@@ -134,6 +143,7 @@ REAL function s_rect(u, rect) ! returns S_rest
use module_lattice
use module_nn
use module_vol
+ use module_switches
implicit none
GAUGE_FIELD, intent(in) :: u
@@ -192,12 +202,16 @@ REAL function s_rect(u, rect) ! returns S_rest
call xbound_g(w1, e, nu)
call xbound_g(w2, e, mu)
enddo
+if (switches%boundary_sf) call schr_boundary_zero4(w1)
+if (switches%boundary_sf) call schr_boundary_zero4(w2)
#endif
do e = EVEN, ODD
o = EVEN + ODD - e
#ifndef D500
call xbound_g_rect_ind(w1, o, nu, mu, FWD)
call xbound_g_rect_ind(w2, o, mu, nu, FWD)
+if (switches%boundary_sf) call schr_boundary_zero4(w1)
+if (switches%boundary_sf) call schr_boundary_zero4(w2)
#endif
p = ZERO
!$omp parallel do reduction(+: p) private(j1, j2, uuu)
diff --git a/src/gauge/staple_imp.F90 b/src/gauge/staple_imp.F90
index e9f903dab2f041e271005d7ce9abf56b30ffbce2..6e739e256003a9c51b0f1bf21143fec3b109b406 100644
--- a/src/gauge/staple_imp.F90
+++ b/src/gauge/staple_imp.F90
@@ -195,6 +195,47 @@ subroutine staple_r_fat(uuu, u, u_tmp1, i, e, mu)
end
+!-------------------------------------------------------------------------------
+subroutine staple_ud(uuu, u, u_tmp1, u_tmp2, i, e, mu)
+
+ use module_nn
+ use module_vol
+ implicit none
+
+ SU3, intent(out) :: uuu
+ GAUGE_FIELD, intent(in) :: u, u_tmp1, u_tmp2
+ integer, intent(in) :: i, e, mu
+ integer :: o, nu, j1, j2, j3, j4
+
+ o = EVEN + ODD - e
+ uuu = 0
+
+ do nu = 1, DIM
+ if (nu /= mu) then
+ ! (j2,o) --<-- x nu
+ ! | |
+ ! v ^ ^
+ ! | | |
+ ! (i,e) -->-- (j1,o) x--> mu
+ ! | |
+ ! ^ v
+ ! | |
+ ! (j3,o) --<-- (j4,e)
+ j1 = nn(i, e, mu, FWD)
+ j2 = nn(i, e, nu, FWD)
+ j3 = nn(i, e, nu, BWD)
+ j4 = nn(j3,o, mu, FWD)
+ call uddp(uuu, u(1, 1, j1, o, nu), &
+ u_tmp1(1, 1, j2, o, nu), &
+ u(1, 1, i , e, nu))
+ call ddup(uuu, u(1, 1, j4, e, nu), &
+ u_tmp2(1, 1, j3, o, nu), &
+ u(1, 1, j3, o, nu))
+ endif
+ enddo
+
+end
+
!-------------------------------------------------------------------------------
subroutine staple_udl(uuu, u, u_tmp1, u_tmp2, u_tmp3, i, e, mu)
@@ -390,6 +431,7 @@ subroutine u_staple(u_out, u, mu)
u(1, 1, j2, o, mu), &
u(1, 1, j1, o, nu))
enddo
+ call xbound_g(u_out, e, nu)
enddo
endif
enddo
@@ -427,6 +469,7 @@ subroutine d_staple(u_out, u, mu)
u(1, 1, j1, o, mu), &
u(1, 1, j2, e, nu))
enddo
+ call xbound_g(u_out, e, nu)
enddo
endif
enddo
@@ -464,6 +507,7 @@ subroutine l_staple(u_out, u, mu)
u(1, 1, j1, o, nu), &
u(1, 1, j2, e, mu))
enddo
+ call xbound_g(u_out, e, nu)
enddo
endif
enddo
diff --git a/src/gauge/stout.F90 b/src/gauge/stout.F90
index 6c43ce07773d51673278ed0dce0f58312971ad51..859680f517d9d1ddda9279ce68c52ab6701a2c7c 100644
--- a/src/gauge/stout.F90
+++ b/src/gauge/stout.F90
@@ -205,6 +205,7 @@ subroutine stout_link_smearing_up(u, alpha, stout, dobs)
use module_nn
use module_vol
use module_staple
+ use module_switches
implicit none
type(type_stout), intent(out) :: stout
@@ -263,6 +264,8 @@ subroutine stout_link_smearing_up(u, alpha, stout, dobs)
call xbound_g_field(stout%u(1,1,1,0,1))
TIMING_STOP(timing_bin_hmc_xbound_g)
+!! if (switches%boundary_sf) call schr_boundary_zero4(stout%u)
+ if (switches%boundary_sf) call schr_boundary_gauge(stout%u)
TIMING_STOP(timing_bin_stout_smear)
DEBUG2S("End: stout_link_smearing_up")
@@ -493,6 +496,7 @@ subroutine stout_link_smearing_down(ff, u, stout, alpha)
use module_vol
use module_p_interface
use module_staple
+ use module_switches
implicit none
GAUGE_FIELD, intent(inout) :: ff
@@ -532,6 +536,8 @@ subroutine stout_link_smearing_down(ff, u, stout, alpha)
call xbound_g_field(lam(1,1,1,0,1))
TIMING_STOP(timing_bin_hmc_xbound_g)
+ if (switches%boundary_sf) call schr_boundary_zero4(lam)
+
!---------------------------- new force matrix
do mu = 1, DIM
do eo = EVEN, ODD
@@ -547,6 +553,11 @@ subroutine stout_link_smearing_down(ff, u, stout, alpha)
enddo
!---------------------------------------------
+
+
+ if (switches%boundary_sf) call schr_boundary_zero4(ff)
+ if (switches%boundary_sf) call schr_boundary_zero3(ff)
+
TIMING_STOP(timing_bin_stout_diffe)
DEBUG2S("End: stout_link_smearing_down")
diff --git a/src/ildg/Makefile b/src/ildg/Makefile
index cf9ad100ea3f5d721f6c7885b1e8bd1ac0d3042d..8af756ecb472a9ed44e0713e1a415897cfba1257 100644
--- a/src/ildg/Makefile
+++ b/src/ildg/Makefile
@@ -51,6 +51,10 @@ OBJS = \
ildg_seq_r4.o \
ildg_xml.o
+ifdef LEMON
+OBJS += ildg_lemon.o
+endif
+
$(LIBILDG):
fast:
diff --git a/src/ildg/ildg.c b/src/ildg/ildg.c
index d9edf5da3fc3ae8bff12a316f151d3a2ec1409c7..b344827a27dfaf1809da998128943be408f49cb5 100644
--- a/src/ildg/ildg.c
+++ b/src/ildg/ildg.c
@@ -142,6 +142,10 @@ void ILDG_READ(void *buffer, INT8 *bytes)
n_uint64_t nbytes = *bytes;
status = limeReaderReadData(buffer, &nbytes, r);
+ if (status != LIME_SUCCESS)
+ die("failed to read Data (status=%d)", status);
+ if (nbytes != *bytes)
+ die("failed to read Data, read bytes /= requested bytes (status=%d)", status);
CKSUM_ADD(buffer, bytes);
}
@@ -156,6 +160,8 @@ void ILDG_WRITE(void *buffer, INT8 *bytes)
n_uint64_t nbytes = *bytes;
status = limeWriteRecordData(buffer, &nbytes, w);
+ if (status != LIME_SUCCESS)
+ die("failed to write Data (status=%d)", status);
CKSUM_ADD(buffer, bytes);
}
diff --git a/src/ildg/ildg.h b/src/ildg/ildg.h
index 87c67d340ec9a122465f55b19f150ce825ae1ce0..bd2b3db30308785ab3b7d124b77b53d9cfc8b451 100644
--- a/src/ildg/ildg.h
+++ b/src/ildg/ildg.h
@@ -34,6 +34,12 @@
# define ILDG_WRITE ildg_write
# define ILDG_CLOSE_R ildg_close_r
# define ILDG_CLOSE_W ildg_close_w
+# define ILDG_OPEN_W_LEMON ildg_open_w_lemon
+# define ILDG_OPEN_R_LEMON ildg_open_r_lemon
+# define ILDG_CLOSE_W_LEMON ildg_close_w_lemon
+# define ILDG_CLOSE_R_LEMON ildg_close_r_lemon
+# define ILDG_WRITE_LEMON ildg_write_lemon
+# define ILDG_READ_LEMON ildg_read_lemon
#endif
#ifdef NamesToLower_
@@ -43,6 +49,12 @@
# define ILDG_WRITE ildg_write_
# define ILDG_CLOSE_R ildg_close_r_
# define ILDG_CLOSE_W ildg_close_w_
+# define ILDG_OPEN_W_LEMON ildg_open_w_lemon_
+# define ILDG_OPEN_R_LEMON ildg_open_r_lemon_
+# define ILDG_CLOSE_W_LEMON ildg_close_w_lemon_
+# define ILDG_CLOSE_R_LEMON ildg_close_r_lemon_
+# define ILDG_WRITE_LEMON ildg_write_lemon_
+# define ILDG_READ_LEMON ildg_read_lemon_
#endif
#ifdef NamesToLower__
@@ -52,6 +64,12 @@
# define ILDG_WRITE ildg_write__
# define ILDG_CLOSE_R ildg_close_r__
# define ILDG_CLOSE_W ildg_close_w__
+# define ILDG_OPEN_W_LEMON ildg_open_w_lemon__
+# define ILDG_OPEN_R_LEMON ildg_open_r_lemon__
+# define ILDG_CLOSE_W_LEMON ildg_close_w_lemon__
+# define ILDG_CLOSE_R_LEMON ildg_close_r_lemon__
+# define ILDG_WRITE_LEMON ildg_write_lemon__
+# define ILDG_READ_LEMON ildg_read_lemon__
#endif
@@ -65,15 +83,30 @@ void ILDG_OPEN_W(char *filename,
int *Lx, int *Ly, int *Lz, int *Lt,
int *precision,
INT8 *bytes_total);
+void ILDG_OPEN_R_LEMON(char *filename,
+ int *Lx, int *Ly, int *Lz, int *Lt,
+ int npe[4], int *precision,
+ INT8 *bytes_total);
+void ILDG_OPEN_W_LEMON(char *filename,
+ int *Lx, int *Ly, int *Lz, int *Lt,
+ int npe[4], int *precision,
+ INT8 *bytes_total);
+
+
void ILDG_READ(void *buffer, INT8 *bytes);
void ILDG_WRITE(void *buffer, INT8 *bytes);
+void ILDG_READ_LEMON(void *buffer,int L[4], int *vol, int *precision);
+void ILDG_WRITE_LEMON(void *buffer,int L[4], int *vol, int *precision);
void ILDG_CLOSE_R(INT8 *cksum, INT8 *bytes_total, char *lfn, int *len);
void ILDG_CLOSE_W(INT8 *cksum, INT8 *bytes_total, char *lfn);
-
+void ILDG_CLOSE_R_LEMON(INT8 *cksum, INT8 *bytes_total, char *lfn, int *len);
+void ILDG_CLOSE_W_LEMON(INT8 *cksum, INT8 *bytes_total, char *lfn);
/* prototypes for C functions called from C */
void ildg_find_record(char *record);
void ildg_read_string(char *record, char *s, int len);
+void ildg_find_record_lemon(char *record);
+void ildg_read_string_lemon(char *record, char *s, int len);
/*===========================================================================*/
diff --git a/src/ildg/ildg_conf.F90 b/src/ildg/ildg_conf.F90
index c81db5591de9bf63db5f2e2e4fe4f21cdac95deb..17c45b48710de588f261b2e87eacee967eab8048 100644
--- a/src/ildg/ildg_conf.F90
+++ b/src/ildg/ildg_conf.F90
@@ -5,6 +5,7 @@
!-------------------------------------------------------------------------------
!
! Copyright (C) 2007-2008 Hinnerk Stueben
+! 2010 Yoshifumi Nakamura
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
@@ -60,12 +61,23 @@ subroutine conf_read_ildg(restart, para, conf)
FILENAME :: filename
integer :: len_lfn
INT8 :: bytes_read
+ integer :: i, mu, eo
call begin(UREC, "ILDGread")
ALLOCATE_G_FIELD_ILDG(u_ildg)
call ildg_lime_file(filename, READ, restart)
+#if defined(LEMON) && !defined(MPI_1)
+ call ildg_open_r_lemon(filename, lx, ly, lz, lt, para%NPE, precision, bytes)
+ call ildg_check()
+ call ildg_set_sizes()
+ TIMING_START(timing_bin_u_read_ildg)
+ call ildg_io_lemon(READ, u_ildg, precision)
+ TIMING_STOP(timing_bin_u_read_ildg)
+ len_lfn = len(lfn) - 1
+ call ildg_close_r_lemon(cksum, bytes_read, lfn, len_lfn)
+#else
call ildg_open_r(filename, lx, ly, lz, lt, precision, bytes)
call ildg_check()
call ildg_set_sizes()
@@ -76,6 +88,7 @@ subroutine conf_read_ildg(restart, para, conf)
len_lfn = len(lfn) - 1
call ildg_close_r(cksum, bytes_read, lfn, len_lfn)
+#endif
if (my_pe() == 0) then
call ildg_check2(restart)
@@ -85,6 +98,10 @@ subroutine conf_read_ildg(restart, para, conf)
endif
call ildg_seq(READ, conf(1)%u, u_ildg)
+
+ call conf_normalize(conf(1)%u)
+ call conf_check(conf(1)%u)
+
call xbound_g_field(conf(1)%u)
conf(1)%former = 1
@@ -136,7 +153,31 @@ subroutine conf_write_ildg(restart, para, conf)
call ildg_check()
call ildg_seq(WRITE, conf(1)%u, u_ildg)
-
+
+
+#if defined(LEMON) && !defined(MPI_1)
+ call ildg_open_w_lemon(filename, lx, ly, lz, lt, para%NPE, precision, bytes)
+ TIMING_START(timing_bin_u_write_ildg)
+ call ildg_io_lemon(WRITE, u_ildg, precision)
+ TIMING_STOP(timing_bin_u_write_ildg)
+ call cksum_get(cksum, bytes_written)
+ call ildg_set_lfn(filename, restart)
+ call ildg_close_w_lemon(cksum0, bytes_written, lfn)
+
+ if (my_pe() == 0) then
+ call ildg_rec(WRITE, filename)
+ if (.not. restart) then
+ i = index(lfn, ascii_null)
+ ASSERT(i > 0)
+ call ildg_meta("ensemble", para, conf, lfn(1:i-1), plaquette, precision, cksum)
+ call ildg_meta("conf", para, conf, lfn(1:i-1), plaquette, precision, cksum)
+ endif
+ ASSERT(cksum0 == cksum)
+ ASSERT(bytes == bytes_written)
+ endif
+
+#else
+
if (my_pe() == 0) then
call ildg_open_w(filename, lx, ly, lz, lt, precision, bytes)
endif
@@ -162,6 +203,7 @@ subroutine conf_write_ildg(restart, para, conf)
ASSERT(bytes == bytes_written)
endif
+#endif
call end(UREC, "ILDGwrite")
end
diff --git a/src/ildg/ildg_lemon.c b/src/ildg/ildg_lemon.c
new file mode 100644
index 0000000000000000000000000000000000000000..f9e235a3f14f51c6eda0414aa2a52f15073484b0
--- /dev/null
+++ b/src/ildg/ildg_lemon.c
@@ -0,0 +1,285 @@
+/*
+!===============================================================================
+!
+! ildg_lemon.c - read/write configuration in ILDG lime format with LEMON
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2010 Yoshifumi Nakamura
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+*/
+# include <sys/types.h>
+# include <stdio.h>
+# include <string.h>
+# include <mpi.h>
+# include "c_defs.h"
+# include "c_util.h"
+# include "cksum.h"
+# include "ildg.h"
+# include "lemon.h"
+
+static MPI_File fp;
+static LemonReader *r;
+static LemonWriter *w;
+static LemonRecordHeader *h;
+
+static char xmldoc[1024];
+static int len_xmldoc = 1023;
+
+int status;
+uint64_t nbytes;
+/*----------------------------------------------------------------------------*/
+void ILDG_OPEN_R_LEMON(char *filename,
+ int *Lx, int *Ly, int *Lz, int *Lt,
+ int npe[4], int *precision,
+ INT8 *bytes_total)
+{
+ /* filename (input)
+ * Lx, Ly, Lz, Lt lattice size (output)
+ * precision 32|64 (output)
+ * bytes_total bytes of configuration (output)
+ */
+ int latDist[] = {2, 1, 2, 1};
+ int periods[] = {1, 1, 1, 1};
+
+ latDist[0]=npe[3];
+ latDist[1]=npe[2];
+ latDist[2]=npe[1];
+ latDist[3]=npe[0];
+
+ MPI_Comm cartesian;
+ MPI_Cart_create(MPI_COMM_WORLD, 4, latDist, periods, 1, &cartesian);
+ MPI_File_open(cartesian, filename, MPI_MODE_RDONLY, MPI_INFO_NULL, &fp);
+ r = lemonCreateReader(&fp, cartesian);
+
+ ildg_find_record_lemon("ildg-format");
+ ildg_read_string_lemon("ildg-format", xmldoc, len_xmldoc);
+
+ ildg_xml_check_value(xmldoc, "<version>", "1.0");
+ ildg_xml_check_value(xmldoc, "<field>", "su3gauge");
+ ildg_xml_get_int(xmldoc, "<precision>", precision);
+ ildg_xml_get_int(xmldoc, "<lx>", Lx);
+ ildg_xml_get_int(xmldoc, "<ly>", Ly);
+ ildg_xml_get_int(xmldoc, "<lz>", Lz);
+ ildg_xml_get_int(xmldoc, "<lt>", Lt);
+
+ ildg_find_record_lemon("ildg-binary");
+
+ *bytes_total = lemonReaderBytes(r);
+
+ CKSUM_INIT();
+}
+
+/*----------------------------------------------------------------------------*/
+void ILDG_OPEN_W_LEMON(char *filename,
+ int *Lx, int *Ly, int *Lz, int *Lt,
+ int npe[4], int *precision,
+ INT8 *bytes_total)
+{
+ /* filename (input)
+ * Lx, Ly, Lz, Lt lattice size (input)
+ * precision 32|64 (input)
+ * bytes_total bytes of configuration (input)
+ */
+
+ int latDist[] = {2, 1, 2, 1};
+ int periods[] = {1, 1, 1, 1};
+
+ latDist[0]=npe[3];
+ latDist[1]=npe[2];
+ latDist[2]=npe[1];
+ latDist[3]=npe[0];
+
+ MPI_Comm cartesian;
+ // MPI_Comm_size(MPI_COMM_WORLD, &mpisize);
+ // MPI_Dims_create(mpisize, 4, latDist);
+ // printf("latDist %d %d %d %d\n",latDist[0],latDist[1],latDist[2],latDist[3]);
+
+ MPI_Cart_create(MPI_COMM_WORLD, 4, latDist, periods, 1, &cartesian);
+ MPI_File_open(cartesian, filename, MPI_MODE_WRONLY | MPI_MODE_CREATE, MPI_INFO_NULL, &fp);
+ MPI_File_set_size(fp, 0);
+ w = lemonCreateWriter(&fp, cartesian);
+
+ sprintf(xmldoc,
+ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
+ "<ildgFormat>\n"
+ " <version>1.0</version>\n"
+ " <field>su3gauge</field>\n"
+ " <precision>%d</precision>\n"
+ " <lx>%d</lx> <ly>%d</ly> <lz>%d</lz> <lt>%d</lt>\n"
+ "</ildgFormat>\n",
+ *precision, *Lx, *Ly, *Lz, *Lt);
+ nbytes = strlen(xmldoc);
+
+ h = lemonCreateHeader(1, 0, "ildg-format", nbytes);
+
+ status=lemonWriteRecordHeader(h, w);
+ if (status != LEMON_SUCCESS)
+ die("failed to lemonWriteRecordHeader (status=%d)\n", status);
+
+ lemonDestroyHeader(h);
+
+ status=lemonWriteRecordData(xmldoc, &nbytes, w);
+ if (status != LEMON_SUCCESS)
+ die("failed to lemonWriteRecordData (status=%d)\n", status);
+
+ lemonWriterCloseRecord(w);
+
+ nbytes = *bytes_total;
+ h = lemonCreateHeader(0, 1, "ildg-binary-data", nbytes);
+
+ status=lemonWriteRecordHeader(h, w);
+ if (status != LEMON_SUCCESS)
+ die("failed to lemonWriteRecordData (status=%d)\n", status);
+
+ lemonDestroyHeader(h);
+
+ CKSUM_INIT();
+}
+
+/*----------------------------------------------------------------------------*/
+void ILDG_READ_LEMON(void *buffer, int L[4], int *vol, int *precision)
+{
+ /* buffer (input)
+ * bytes (input)
+ */
+
+ int const mapping[] = {0, 1, 2, 3};
+ uint64_t siteSize=sizeof(double) * 2* 3*3*4;
+ if (*precision == 32) siteSize/=2;
+ // INT8 bytes=siteSize * (INT8)*vol;
+
+ status=lemonReadLatticeParallelMapped(r, buffer, siteSize, L, mapping);
+ if (status != LEMON_SUCCESS)
+ die("failed lemonReadLatticeParallelMapped (status=%d\n)", status);
+ lemonReaderCloseRecord(r);
+}
+
+/*----------------------------------------------------------------------------*/
+void ILDG_WRITE_LEMON(void *buffer, int L[4], int *vol, int *precision)
+{
+ /* buffer (output)
+ * bytes (input)
+ */
+
+ int const mapping[] = {0, 1, 2, 3};
+ uint64_t siteSize=sizeof(double) * 2* 3*3*4;
+ if (*precision == 32) siteSize/=2;
+ // INT8 bytes=siteSize * (INT8)&vol;
+
+ // printf("ILDG_WRITE_LEMON siteSize:%llu\n",siteSize);
+ //status=lemonWriteLatticeParallel(w, buffer, siteSize, latSizes);
+
+ status=lemonWriteLatticeParallelMapped(w, buffer, siteSize, L, mapping);
+ if (status != LEMON_SUCCESS)
+ die("failed lemonWriteLatticeParallelMapped (status=%d\n)", status);
+ lemonWriterCloseRecord(w);
+}
+
+/*----------------------------------------------------------------------------*/
+void ILDG_CLOSE_R_LEMON(INT8 *cksum, INT8 *bytes_total, char *lfn, int *len)
+{
+ /* cksum CRC check sum (output)
+ * bytes_total (output) (from cksum())
+ * lfn logical file name (output)
+ * len input: max. length of "lfn"
+ * output: actual length of "lfn"
+ */
+
+ // fseek(fp, 0, SEEK_SET); how should I change?
+ do {
+ status = lemonReaderNextRecord(r);
+ if (status == LEMON_EOF)
+ break;
+ } while (strncmp(lemonReaderType(r), "ildg-data-lfn", 13) != 0);
+
+
+ if (status == LEMON_EOF)
+ strcpy(lfn, "UNDEFINED");
+ else
+ ildg_read_string_lemon("ildg-data-lfn", lfn, *len);
+
+ *len = strlen(lfn);
+
+ lemonDestroyReader(r);
+ MPI_File_close(&fp);
+ CKSUM_GET(cksum, bytes_total);
+}
+
+/*----------------------------------------------------------------------------*/
+void ILDG_CLOSE_W_LEMON(INT8 *cksum, INT8 *bytes_total, char *lfn)
+{
+ /* cksum CRC check sum (output)
+ * bytes_total (output) (from cksum())
+ * lfn logical file name (input)
+ */
+
+ nbytes = strlen(lfn);
+
+ h = lemonCreateHeader(1, 1, "ildg-data-lfn", nbytes);
+
+ status=lemonWriteRecordHeader(h, w);
+ if (status != LEMON_SUCCESS)
+ die("failed lemonWriteRecordHeader (status=%d)\n", status);
+
+ lemonDestroyHeader(h);
+
+ status=lemonWriteRecordData(lfn, &nbytes, w);
+ if (status != LEMON_SUCCESS)
+ die("failed lemonWriteRecordData (status=%d)\n", status);
+
+ lemonDestroyWriter(w);
+ MPI_File_close(&fp);
+ CKSUM_GET(cksum, bytes_total);
+
+}
+
+/*----------------------------------------------------------------------------*/
+void ildg_find_record_lemon(char *record)
+{
+ /* record (input)
+ */
+
+ // fseek(fp, 0, SEEK_SET); how should I change?
+ do {
+ status = lemonReaderNextRecord(r);
+ if (status == LEMON_EOF)
+ die("unexpected end-of-file");
+ } while (strncmp(lemonReaderType(r), record, (int) strlen(record)) != 0);
+}
+
+/*----------------------------------------------------------------------------*/
+void ildg_read_string_lemon(char *record, char *s, int len)
+{
+ /* record (input)
+ * s string read (output)
+ * len max. length of "s"
+ */
+
+ nbytes = lemonReaderBytes(r);
+ if (nbytes > len)
+ die("string (length=%d) too small for reading record %s", len, record);
+
+ status = lemonReaderReadData(s, &nbytes, r);
+ if (status != LEMON_SUCCESS)
+ die("failed to read record %s (status=%d)", record, status);
+ s[nbytes] = '\0';
+}
+
+/*============================================================================*/
diff --git a/src/include/c_defs.h b/src/include/c_defs.h
index 9f8b3912ff3a9f3fd5e1bb2b3b7d5c3cd55b9c18..1ae9acbf225afdca1cc81de1cfb3379e4b2f2a06 100644
--- a/src/include/c_defs.h
+++ b/src/include/c_defs.h
@@ -1,3 +1,5 @@
+#ifndef BQCD_C_DEFS_H
+#define BQCD_C_DEFS_H
/*
!===============================================================================
!
@@ -5,7 +7,7 @@
!
!-------------------------------------------------------------------------------
!
-! Copyright (C) 2007 Hinnerk Stueben
+! Copyright (C) 2007-2011 Hinnerk Stueben
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
@@ -25,6 +27,26 @@
!-------------------------------------------------------------------------------
*/
+# define CAT(A, B) A ## B
+# define STRCAT(A, B) CAT(A, B)
+# define STRCAT3(A, B, C) STRCAT(STRCAT(A, B), C)
+# define STRING(s) SSTRING(s)
+# define SSTRING(s) #s
+
+# define DIM 4
+# define NCOL 3
+# define NDIRAC 4
+# define NGEN 8
+# define EVEN 0
+# define ODD 1
+# define FWD 0
+# define BWD 1
+
+# define SIZE_COMPLEX 2
+
+# define FWD_BWD 2
+# define EVEN_ODD 2
+
#ifdef LongLong
# define INT8 long long
#else
@@ -32,6 +54,68 @@
#endif
+#ifdef PRECISION_R4
+typedef float REAL;
+#else
+typedef double REAL;
+#endif
+
+typedef int INTEGER;
+typedef struct { REAL r; REAL i; } COMPLEX;
+
+typedef COMPLEX (*SPINCOL_FIELD)[NCOL][NDIRAC];
+typedef COMPLEX (*REORDERED_GAUGE_FIELD)[NCOL][NCOL+NCOL];
+typedef COMPLEX (*SC2_FLD)[NCOL][2];
+
+# define Re(z) (z).r
+# define Im(z) (z).i
+
+static const REAL ZERO = 0;
+static const REAL ONE = 1;
+static const REAL TWO = 2;
+
+# include "../include_auto/c_timing.h"
+
+# define timing_bin_d_dag_xf timing_bin_d_xf
+# define timing_bin_d_dag_xb timing_bin_d_xb
+# define timing_bin_d_dag_yf timing_bin_d_yf
+# define timing_bin_d_dag_yb timing_bin_d_yb
+# define timing_bin_d_dag_zf timing_bin_d_zf
+# define timing_bin_d_dag_zb timing_bin_d_zb
+# define timing_bin_d_dag_t timing_bin_d_t
+# define timing_bin_d_dag timing_bin_d
+
+#ifdef TIMING
+
+#ifdef NamesToLower
+# define TIMING_START(bin) timing_start(&bin)
+# define TIMING_STOP(bin) timing_stop(&bin)
+void timing_start(const int*);
+void timing_stop(const int*);
+#endif
+
+#ifdef NamesToLower_
+# define TIMING_START(bin) timing_start_(&bin)
+# define TIMING_STOP(bin) timing_stop_(&bin)
+void timing_start_(const int*);
+void timing_stop_(const int*);
+#endif
+
+#ifdef NamesToLower__
+# define TIMING_START(bin) timing_start__(&bin)
+# define TIMING_STOP(bin) timing_stop__(&bin)
+void timing_start__(const int*);
+void timing_stop__(const int*);
+#endif
+
+#else
+
+# define TIMING_START(bin)
+# define TIMING_STOP(bin)
+
+#endif /* TIMING */
+
+
/* prototypes for Fortran Functions called from C */
#ifdef NamesToLower
@@ -52,3 +136,4 @@
void ABBRUCH(void);
/*===========================================================================*/
+#endif /* BQCD_C_DEFS_H */
diff --git a/src/include/cksum.h b/src/include/cksum.h
index 4b1700c495bb8bd8500d7e46bce241086047e361..f59d8cc6e17a5364992fe3d9acbf24122fc9cffa 100644
--- a/src/include/cksum.h
+++ b/src/include/cksum.h
@@ -31,18 +31,21 @@
# define CKSUM_INIT cksum_init
# define CKSUM_ADD cksum_add
# define CKSUM_GET cksum_get
+# define CKSUM_BCAST cksum_bcast
#endif
#ifdef NamesToLower_
# define CKSUM_INIT cksum_init_
# define CKSUM_ADD cksum_add_
# define CKSUM_GET cksum_get_
+# define CKSUM_BCAST cksum_bcast_
#endif
#ifdef NamesToLower__
# define CKSUM_INIT cksum_init__
# define CKSUM_ADD cksum_add__
# define CKSUM_GET cksum_get__
+# define CKSUM_BCAST cksum_bcast__
#endif
/* prototypes for those functions */
@@ -51,4 +54,7 @@ void CKSUM_INIT(void);
void CKSUM_ADD(void *, INT8 *);
void CKSUM_GET(INT8 *, INT8 *);
+/*this is just for */
+void CKSUM_BCAST(int * np);
+
/*===========================================================================*/
diff --git a/src/include/defs.h b/src/include/defs.h
index f44d051cdae2337a2a4f33da31f906beea7e43a4..f2db000245b9e4305d4ccce32597138f52b297ae 100644
--- a/src/include/defs.h
+++ b/src/include/defs.h
@@ -35,9 +35,21 @@
# define STRCAT3(A, B, C) STRCAT(STRCAT(A, B), C)
#ifdef PRECISION_R4
+#// efine D_R4_INTERNAL
# define RKIND 4
# define DKIND 8
# define BQCD_REAL mpi_real4
+# include "../include_auto/precision_r4.h"
+#elif defined(PRECISION_R16)
+#// efine D_R16_INTERNAL
+# define RKIND 16
+# define DKIND 16
+# define BQCD_REAL mpi_real16
+# include "../include_auto/precision_r16.h"
+# define global_sum_vec global_sum_vec_r16
+# define global_sum global_sum_r16
+# define global_min global_min_r16
+# define global_max global_max_r16
#else
# define RKIND 8
# define DKIND 8
@@ -70,9 +82,11 @@
# define DOUBLE real(DKIND)
# define REAL4 real(4)
# define REAL8 real(8)
+# define REAL16 real(16)
# define COMPLEX complex(RKIND)
# define COMPLEX4 complex(4)
# define COMPLEX8 complex(8)
+# define COMPLEX16 complex(16)
# define INTEGER integer(4)
# define INT4 integer(4)
# define INT8 integer(8)
@@ -145,7 +159,7 @@
# define HALF STRCAT(0.5_, RKIND)
# define EIGHTH STRCAT(0.125_, RKIND)
-#include "timing.h"
+#include "../include_auto/timing.h"
# define timing_bin_d_dag_xf timing_bin_d_xf
# define timing_bin_d_dag_xb timing_bin_d_xb
@@ -204,6 +218,7 @@
# define FULL_SOURCE 0
# define RANDOM_SOURCE 1
# define WALL_SOURCE 2
+# define LOCAL_SOURCE 3
# define EO_NORMAL 1
# define UN_NORMAL 2
diff --git a/src/include/defs_c.h b/src/include/defs_c.h
deleted file mode 100644
index a800bf7acc4a3ff68a345dd11ca3f1eb993aa9e4..0000000000000000000000000000000000000000
--- a/src/include/defs_c.h
+++ /dev/null
@@ -1,40 +0,0 @@
-#ifndef BQCD_DEFS_C_H
-#define BQCD_DEFS_C_H
-
-# define DIM 4
-# define NCOL 3
-# define NDIRAC 4
-# define NGEN 8
-# define EVEN 0
-# define ODD 1
-# define FWD 0
-# define BWD 1
-
-# define SIZE_COMPLEX 2
-
-# define FWD_BWD 2
-# define EVEN_ODD 2
-
-typedef double REAL;
-typedef int INTEGER;
-typedef struct { REAL r; REAL i; } COMPLEX;
-typedef COMPLEX SU3[NCOL][NCOL];
-typedef REAL GENERATOR[NGEN];
-
-typedef COMPLEX SPINCOL_FIELD[][NCOL][NDIRAC];
-typedef struct { COMPLEX (*sc)[NCOL][2]; } SC2_FIELD[FWD_BWD][DIM];
-typedef struct { INTEGER (*nn)[DIM]; } NN2[FWD_BWD][EVEN_ODD];
-
-# define Re(z) (z).r
-# define Im(z) (z).i
-
-# define CAT(A, B) A ## B
-# define STRCAT(A, B) CAT(A, B)
-# define STRCAT3(A, B, C) STRCAT(STRCAT(A, B), C)
-# define STRING(s) SSTRING(s)
-# define SSTRING(s) #s
-
-# define ZERO 0.0
-# define ONE 1.0
-
-#endif
diff --git a/src/include/gamma.h b/src/include/gamma.h
new file mode 100644
index 0000000000000000000000000000000000000000..cb681aa0ad72381535be4fc1dee30c4993197eaf
--- /dev/null
+++ b/src/include/gamma.h
@@ -0,0 +1,52 @@
+#/*
+#!===============================================================================
+#!
+#! gamma.h -- Gamma matrix
+#!
+#!-------------------------------------------------------------------------------
+#!
+#! Copyright (C) 2007 Yoshifumi Nakamura
+#!
+#! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+#!
+#! BQCD is free software: you can redistribute it and/or modify
+#! it under the terms of the GNU General Public License as published by
+#! the Free Software Foundation, either version 3 of the License, or
+#! (at your option) any later version.
+#!
+#! BQCD is distributed in the hope that it will be useful,
+#! but WITHOUT ANY WARRANTY; without even the implied warranty of
+#! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+#! GNU General Public License for more details.
+#!
+#! You should have received a copy of the GNU General Public License
+#! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+#!
+#!-------------------------------------------------------------------------------
+#*/
+
+
+
+# define G0 1
+# define G1 2
+# define G2 3
+# define G3 4
+# define G5 5
+# define G01 6
+# define G02 7
+# define G03 8
+# define G05 9
+# define G15 10
+# define G25 11
+# define G35 12
+# define G12 13
+# define G23 14
+# define G31 15
+# define CGm 16
+# define UNP 17
+# define POL 18
+
+
+# define Gi 93
+# define G0i 94
+# define Gi5 95
diff --git a/src/init_modules.F90 b/src/init_modules.F90
index 77ed0e79540840a8c6a1a8fd272cdbaddd0a8117..cee71e0fb77a32dc35b61ee5c131a2d5d9ee3e94 100644
--- a/src/init_modules.F90
+++ b/src/init_modules.F90
@@ -30,7 +30,7 @@ subroutine init_modules()
call init_module_decomp()
call init_module_lattice_io()
call init_module_sc_size()
- call init_module_sc_size_r4()
+!! call init_module_sc_size_r4()
call init_module_surface()
end
diff --git a/src/mc/hmc.F90 b/src/mc/hmc.F90
index 1f9218c66688afa704f4727d71c5531452b3b28a..5b6c0f2beab0854010cbf587e976bb63044f9425 100644
--- a/src/mc/hmc.F90
+++ b/src/mc/hmc.F90
@@ -66,7 +66,7 @@ subroutine hmc(para, conf, out, force_accept, test)
use module_input
implicit none
- type(hmc_para), intent(in) :: para
+ type(hmc_para), intent(inout) :: para
type(hmc_conf), intent(inout) :: conf
type(hmc_out), intent(out) :: out
integer, intent(in) :: force_accept
@@ -74,19 +74,30 @@ subroutine hmc(para, conf, out, force_accept, test)
P_GAUGE_FIELD, save :: u_bck
!! P_SPINCOL_FIELD, save :: phi_bck
- P_GENERATOR_FIELD, save :: p
+ P_GENERATOR_FIELD, save :: p, p_bck
integer :: i
- REAL :: sd_old, sd_new, sd_dif
+ REAL :: sd_old, sd_new, sd_dif
REAL :: sf1_old, sf1_new, sf1_dif
REAL :: sf2_old, sf2_new, sf2_dif
REAL :: sf3_old, sf3_new, sf3_dif
- REAL :: sg_old, sg_new, sg_dif
- REAL :: sp_old, sp_new, sp_dif
- REAL :: hg_old, hg_new, hg_dif
- REAL :: h_old, h_new, h_dif
+ REAL :: sg_old, sg_new, sg_dif
+ REAL :: sp_old, sp_new, sp_dif
+ REAL :: hg_old, hg_new, hg_dif
+ REAL :: h_old, h_new, h_dif
+ REAL :: sd_old1, sd_new1, sd_dif1
+ REAL :: sf1_old1, sf1_new1, sf1_dif1
+ REAL :: sf2_old1, sf2_new1, sf2_dif1
+ REAL :: sf3_old1, sf3_new1, sf3_dif1
+ REAL :: sg_old1, sg_new1, sg_dif1
+ REAL :: sp_old1, sp_new1, sp_dif1
+ REAL :: hg_old1, hg_new1, hg_dif1
+ REAL :: h_old1, h_new1, h_dif1
REAL :: plaq, plaq_old(3), plaq_new(3), rect_old(3), rect_new(3)
+ REAL :: plaq_new1(3), rect_new1(3)
+ REAL, save :: replay_threshold
REAL, external :: sp, sig, sg
+ logical :: replayed
DEBUG2S("Start HMC")
TIMING_START(timing_bin_hmc)
@@ -125,6 +136,11 @@ subroutine hmc(para, conf, out, force_accept, test)
ALLOCATE_GEN_FIELD(p)
ALLOCATE_G_FIELD(u_bck)
!! ALLOCATE_SC_FIELD(phi_bck)
+ if (switches%replay) then
+ read(input%replay_trick_threshold,*)replay_threshold
+ nullify(p_bck)
+ ALLOCATE_GEN_FIELD(p_bck)
+ endif
endif
@@ -143,11 +159,9 @@ subroutine hmc(para, conf, out, force_accept, test)
TIMING_START(timing_bin_hmc_h_old)
! initialize momenta p, phi, phi2 and old action:
-#ifdef ZERO_MOMENTUM
- p = 0
-#else
call hmc_init_p(p)
-#endif
+ if (switches%boundary_sf) call schr_boundary_p(p)
+ if (switches%replay) p_bck=p
call hmc_init_phi(sf1_old, sf2_old, sf3_old)
@@ -168,6 +182,8 @@ subroutine hmc(para, conf, out, force_accept, test)
!------------------------------------------------------- calculate Hamiltonian:
DEBUG2S("Start calculate Hamiltonian")
TIMING_START(timing_bin_hmc_h_new)
+
+ if (switches%boundary_sf) call schr_boundary_p(p)
sp_new = sp(p)
hg_new = sig(sg_new, plaq_new, rect_new)
call clover_action_sum(sd_new)
@@ -191,6 +207,117 @@ subroutine hmc(para, conf, out, force_accept, test)
if (force_accept /= 0) then
out%accepted = 1
+ elseif (switches%replay) then
+ replayed = .false.
+ if (abs(h_dif) > replay_threshold) then
+ if (my_pe()==0) then
+ write(*,*)"replay_trcik: start replay mode"
+ write(*,*)"replay_trcik: h_dif before replaying =",h_dif
+ endif
+
+ !
+ ! reset integrator
+ !
+ call swap_integer(para%ntau, input%replay_trick_ntau)
+ call delete_integrator()
+ call init_hmc(para)
+
+ !
+ ! copy back gauge field and initialization
+ !
+ call gauge_copy(gauge(1)%u, u_bck)
+ gauge(1:size(gauge))%init = .true.
+ if(associated(stout)) stout(1:size(stout))%init = .true.
+ if(associated(clover))clover(1:size(clover))%init = .true.
+ hg_new = ZERO
+ sg_new = ZERO
+ sp_new = ZERO
+ sd_new = ZERO
+ sf1_new = ZERO
+ sf2_new = ZERO
+ sf3_new = ZERO
+
+ !
+ ! replay with new ntau
+ !
+ call integrate(p_bck, para, conf, sf1_new, sf2_new, sf3_new)
+
+ sp_new = sp(p_bck)
+ hg_new = sig(sg_new, plaq_new, rect_new)
+ call clover_action_sum(sd_new)
+ h_new = sd_new + sp_new + hg_new + sf1_new + sf2_new + sf3_new
+
+ hg_dif = hg_new - hg_old
+ sp_dif = sp_new - sp_old
+ sd_dif = sd_new - sd_old
+ sf1_dif = sf1_new - sf1_old
+ sf2_dif = sf2_new - sf2_old
+ sf3_dif = sf3_new - sf3_old
+ h_dif = sd_dif + sp_dif + hg_dif + sf1_dif + sf2_dif + sf3_dif
+ out%exp_dh = exp( - h_dif)
+ if (my_pe()==0) then
+ write(*,*)"replay_trcik: replayed h_dif =",h_dif
+ endif
+
+
+ !
+ ! reconstruct integrator with normal parameters
+ !
+ call swap_integer(para%ntau, input%replay_trick_ntau)
+ call delete_integrator()
+ call init_hmc(para)
+
+ replayed = .true.
+ endif
+
+ if (ran_number() < out%exp_dh) then
+ out%accepted = 1
+ else
+ out%accepted = 0
+ endif
+
+ if ( replayed ) then
+ if (out%accepted == 1) then
+ hg_old1 = hg_new
+ sp_old1 = sp_new
+ sd_old1 = sd_new
+ sf1_old1 = sf1_new
+ sf2_old1 = sf2_new
+ sf3_old1 = sf3_new
+ p_bck = - p_bck
+ hg_new1 = ZERO
+ sg_new1 = ZERO
+ sp_new1 = ZERO
+ sd_new1 = ZERO
+ sf1_new1 = ZERO
+ sf2_new1 = ZERO
+ sf3_new1 = ZERO
+
+ call integrate(p_bck, para, conf, sf1_new1, sf2_new1, sf3_new1)
+
+ sp_new1 = sp(p_bck)
+ hg_new1 = sig(sg_new1, plaq_new1, rect_new1)
+ call clover_action_sum(sd_new1)
+ h_new1 = sd_new1 + sp_new1 + hg_new1 + sf1_new1 + sf2_new1 + sf3_new1
+
+ hg_dif1 = hg_new1 - hg_old1
+ sp_dif1 = sp_new1 - sp_old1
+ sd_dif1 = sd_new1 - sd_old1
+ sf1_dif1 = sf1_new1 - sf1_old1
+ sf2_dif1 = sf2_new1 - sf2_old1
+ sf3_dif1 = sf3_new1 - sf3_old1
+ h_dif1 = sd_dif1 + sp_dif1 + hg_dif1 + sf1_dif1 + sf2_dif1 + sf3_dif1
+ if (abs(h_dif1) < replay_threshold) then
+ out%accepted = 0
+ if (my_pe()==0) write(*,*)"replay_trcik: reversibility is NOT ok"
+ else
+ if (my_pe()==0) write(*,*)"replay_trcik: reversibility is ok"
+ endif
+ else
+ if (my_pe()==0) write(*,*)"replay_trcik, replayed but rejected"
+ endif
+ endif
+
else
if (ran_number() < out%exp_dh) then
out%accepted = 1
diff --git a/src/mc/hmc_init_p.F90 b/src/mc/hmc_init_p.F90
index e609dce81f6bb0731d5a4beac0778dd07241620c..f49e7f8a43d5bfc29388db12ce09720fbb973198 100644
--- a/src/mc/hmc_init_p.F90
+++ b/src/mc/hmc_init_p.F90
@@ -38,12 +38,16 @@ subroutine hmc_init_p(p)
TIMING_START(timing_bin_hmc_init_p)
! ALLOCATE_G_FIELD(tmp)
-p=ZERO
+ p=ZERO
do mu = 1, DIM
do eo = EVEN, ODD
call ran_gauss_volh(NGEN/2, p(1,1,eo,mu), ONE, eo)
enddo
enddo
+#ifdef ZERO_MOMENTUM
+ p=ZERO
+#endif
+
call nonactive(p) !! for ddhmc
diff --git a/src/mc/hmc_test.F90 b/src/mc/hmc_test.F90
index fcefe45cacb5b5826d9a19270248b9f6d75a5276..5ec243b23ba067e11f524329d0d1dfda742abf3f 100644
--- a/src/mc/hmc_test.F90
+++ b/src/mc/hmc_test.F90
@@ -1,10 +1,11 @@
!===============================================================================
!
-! hmc_test.F90 - forward/backward leap frog integration
+! hmc_test.F90 - forward/backward integration
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2003 Hinnerk Stueben
+! 2010 Yoshifumi Nakamura
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
@@ -30,6 +31,7 @@ subroutine hmc_test(para, conf)
use typedef_hmc
use module_function_decl
use module_vol
+ use module_switches
implicit none
type(hmc_para), intent(inout) :: para
@@ -38,6 +40,9 @@ subroutine hmc_test(para, conf)
call begin(UREC, "HMCtest")
+ if (.not. switches%fixtad) &
+ call die("ERROR hmc_test: non-fix-tadpole imp. is not suitable for HMCtest")
+
call hmc(para, conf, out, .true., HMC_TEST_FORWARDS)
call write_out("forward ")
@@ -97,7 +102,7 @@ subroutine hmc_test_report(test, p, u, hp, hg, hf1, hf2, hd)
REAL, save :: hf2_start
REAL, save :: hd_start
- REAL :: diff_p, diff_u
+ REAL :: diff_p, diff_u, tdiff_p, tdiff_u, tdiff_u1,tmpr, tmpi
integer :: i, eo, mu, j, c1, c2
if (.not. associated(p_start)) then
@@ -119,12 +124,16 @@ subroutine hmc_test_report(test, p, u, hp, hg, hf1, hf2, hd)
diff_p = ZERO
diff_u = ZERO
+ tdiff_p = ZERO
+ tdiff_u = ZERO
+ tdiff_u1= ZERO
do mu = 1, DIM
do eo = EVEN, ODD
do i = 1, volh
do j = 1, NGEN
diff_p = max(diff_p, abs(p_start(j,i,eo,mu) - p(j,i,eo,mu)))
+ tdiff_p = tdiff_p + (p_start(j,i,eo,mu) - p(j,i,eo,mu))**2
enddo
do c2 = 1, NCOL
do c1 = 1, NCOL
@@ -134,12 +143,22 @@ subroutine hmc_test_report(test, p, u, hp, hg, hf1, hf2, hd)
diff_u = max(diff_u, &
abs(relative_change(Im(u_start(c1,c2,i,eo,mu)), &
Im(u(c1,c2,i,eo,mu)))))
+ tmpr= Re(u_start(c1,c2,i,eo,mu))-Re(u(c1,c2,i,eo,mu))
+ tmpi= Im(u_start(c1,c2,i,eo,mu))-Im(u(c1,c2,i,eo,mu))
+ tdiff_u = tdiff_u + tmpr**2 + tmpi**2
+ tdiff_u1 =tdiff_u1 + abs(tmpr) + abs(tmpi)
enddo
enddo
enddo
enddo
enddo
+ diff_p =global_max(diff_p)
+ diff_u =global_max(diff_u)
+ tdiff_p =global_sum(tdiff_p)
+ tdiff_u =global_sum(tdiff_u)
+ tdiff_u1=global_sum(tdiff_u1)
+
if (my_pe() == 0) then
write(UREC, *)
write(UREC,400) "Configuration changes (maximal abs. relative changes):"
@@ -148,6 +167,13 @@ subroutine hmc_test_report(test, p, u, hp, hg, hf1, hf2, hd)
write(UREC,410) "Gauge field: ", diff_u
write(UREC, *)
write(UREC, *)
+ write(UREC,400) "Configuration changes (total changes):"
+ write(UREC, *)
+ write(UREC,410) "Generator field:", tdiff_p
+ write(UREC,410) "Gauge field:x2 ", tdiff_u
+ write(UREC,410) "Gauge field:abs ", tdiff_u1
+ write(UREC, *)
+ write(UREC, *)
write(UREC,400) "Energy changes:"
write(UREC, *)
write(UREC,420) "Energy ", "old value", "rel.change"
@@ -161,7 +187,7 @@ subroutine hmc_test_report(test, p, u, hp, hg, hf1, hf2, hd)
endif
400 format (1x, a)
-410 format (1x, a, e8.1)
+410 format (1x, a, e15.5)
420 format (1x, a, a20, a12)
430 format (1x, a, e20.10, e12.1)
diff --git a/src/mc/hmc_u.F90 b/src/mc/hmc_u.F90
index 5cb11f2e25678d6c18f0500424c05476d30c791b..3d9215891bd75250894654e165aae5ea8119ec84 100644
--- a/src/mc/hmc_u.F90
+++ b/src/mc/hmc_u.F90
@@ -46,7 +46,7 @@ subroutine hmc_integrator_q(p, para, conf, step)
call hmc_u(p, conf, step, para)
-!! if (switches%boundary_sf) call schr_boundary_gauge(gauged(1)%u)
+ if (switches%boundary_sf) call schr_boundary_gauge(gauge(1)%u)
gauge(1:size(gauge))%init = .true.
if (associated(stout)) stout(1:size(stout))%init = .true.
diff --git a/src/mc/integrator.F90 b/src/mc/integrator.F90
index 7b0fd3a2a83745ec1bc60875a75e9503bd096c78..d20323e7296a3449a4b52ffae5a4e27d1b077f12 100644
--- a/src/mc/integrator.F90
+++ b/src/mc/integrator.F90
@@ -37,6 +37,7 @@ module module_integrator
integer,save :: iscale
REAL, save :: len
+ logical, save :: initialized = .false.
end
!-------------------------------------------------------------------------------
@@ -90,10 +91,10 @@ subroutine init_integrator(traj_length, tau)
implicit none
REAL, intent(in) :: traj_length, tau
- integer,save :: count = 0
+!! integer,save :: count = 0
integer :: i
- if (count /= 0 .and. tau > 0 ) return
+ if (initialized .and. tau > 0 ) return
len = traj_length
if (tau < 0) len = - len
@@ -125,10 +126,24 @@ subroutine init_integrator(traj_length, tau)
itraj = 0
iscale = 0
call subintegrator(ONE)
- count = count + 1
+!! count = count + 1
+ initialized = .true.
end
+!-------------------------------------------------------------------------------
+subroutine delete_integrator()
+ use module_integrator
+ implicit none
+
+ deallocate(scale, m_scale, jscale)
+ deallocate(step, step_p)
+ deallocate(step_q)
+ if (associated(step_ppq))deallocate(step_ppq)
+ deallocate(integrator)
+ initialized = .false.
+end
+
!-------------------------------------------------------------------------------
subroutine subintegrator(fac)
use module_integrator
diff --git a/src/mc/mc.F90 b/src/mc/mc.F90
index 628f74e652995353415e0252adeec4e6c13db639..88aee9b7169a7460751fe3ed69648cf3fa9806c1 100644
--- a/src/mc/mc.F90
+++ b/src/mc/mc.F90
@@ -44,6 +44,7 @@ subroutine mc(para, conf)
use module_counter
use module_function_decl
use module_switches
+ use module_input
use module_vol
implicit none
@@ -171,10 +172,16 @@ subroutine mc(para, conf)
call traces(para%hmc(i), conf(i), counter%traj, i, j)
!! call traces2(counter%traj)
endif
+
+!! if (switches%measure_chemical .and. &
+!! mod(counter%traj,input%measure_chemical)==0) call chemical_determinant(counter%traj)
+ if (switches%measure_schrpcac .and. &
+ mod(counter%traj,input%measure_schrpcac)==0) call schr_pcac(counter%job, counter%traj)
+
if (switches%measure_polyakov_loop) &
call polyakov_loop(conf(i), counter%traj, i, j)
call cooling(conf(i)%u, counter%traj, i, j)
- call correlations(para%hmc(i), conf(i), counter%traj, i, j)
+ call correlations(counter%traj)
DEBUG2S("End: measurements")
enddo
diff --git a/src/measure/Makefile b/src/measure/Makefile
index f1f318c73fceefdd7e33693d10e08b80a1a93d10..2f2b5ad809da76f04da09ec5bba762fe7a29915e 100644
--- a/src/measure/Makefile
+++ b/src/measure/Makefile
@@ -27,13 +27,13 @@ include $(DIR)Makefile.in
MODULES_DIR = $(DIR)modules
ifdef FPP2
- fpp = $(FPP2) -I$(DIR)include $(MYFLAGS)
+ fpp = $(FPP2) -I$(DIR)include -I$(DIR)fermi/mult $(MYFLAGS)
else
- fpp = $(FPP) -I$(DIR)include $(MYFLAGS)
+ fpp = $(FPP) -I$(DIR)include -I$(DIR)fermi/mult $(MYFLAGS)
endif
.SUFFIXES:
-.SUFFIXES: .a .o .F90
+.SUFFIXES: .a .o .F90 .c
.F90.o:
$(fpp) $< > $*.f90
@@ -45,20 +45,22 @@ OBJS = \
cooling.o \
traces.o \
traces2.o \
- cdotc_12.o \
- vector12.o \
+ gamma.o \
make_source.o \
- reduction_space.o \
correlations.o \
- change_info_file.o
+ change_info_file.o \
+ schr_pcac.o
+# dirac_matrix.o determinant.o
+
+ifdef cuda
+OBJS+=cublas_wrap.o
+MYFLAGS+= -D_CUDA
+endif
ifdef libdi
#OBJS += chemicalp.o
endif
-
-# correlation_tt.o \
-# correlation_p5p.o \
-# ppp.o
+# phmc_read.o \
fast:
$(FAST_MAKE) lib_measure.a
diff --git a/src/measure/correlation_p5p.F90 b/src/measure/correlation_p5p.F90
deleted file mode 100644
index 30deb988b093d0fe4ca1be29aa5df01f7be85d33..0000000000000000000000000000000000000000
--- a/src/measure/correlation_p5p.F90
+++ /dev/null
@@ -1,120 +0,0 @@
-!===============================================================================
-!
-! correlation_p5p.F90 - correlation psi_gamma5_psi and psi_gamma5_psi
-!
-!-------------------------------------------------------------------------------
-!
-! Copyright (C) 2007 Yoshifumi Nakamura
-!
-! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
-!
-! BQCD is free software: you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation, either version 3 of the License, or
-! (at your option) any later version.
-!
-! BQCD is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License
-! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
-!
-!-------------------------------------------------------------------------------
-# include "defs.h"
-# include "defs_imp_2p1.h"
-
-!-------------------------------------------------------------------------------
-subroutine correlation_p5p(c_t0t1, &
- psi1_e,psi2_e,eta1_e,eta2_e,&
- psi1_o,psi2_o,eta1_o,eta2_o)
-
- use module_vol
- implicit none
-
- COMPLEX, dimension(0:LT-2,0:1),intent(out):: c_t0t1
- SPINCOL_FIELD, intent(in) :: psi1_e, psi2_e, psi1_o, psi2_o
- SPINCOL_FIELD, intent(in) :: eta1_e, eta2_e, eta1_o, eta2_o
- COMPLEX,dimension(volh) :: psi_e, psi_o, eta_e, eta_o
- COMPLEX,dimension(vol ) :: psi, eta ! <--------std
- COMPLEX, external :: correlation_tt
- COMPLEX :: c
- integer :: lt, t0, dis_t0_t1, std_t1, coord(DIM)
-
- lt = decomp%std%L(4)
- nt = decomp%std%N(4)
-
- call real_coord(coord)
- c_t0t1 = ZERO
-
- call psi_g5_psi(psi_e, psi1_e, psi2_e)
- call psi_g5_psi(psi_o, psi1_o, psi2_o)
- call psi_g5_psi(eta_e, eta1_e, eta2_e)
- call psi_g5_psi(eta_o, eta1_o, eta2_o)
- call reduction_eo_std(psi, psi_e, psi_o)
- call reduction_eo_std(eta, eta_e, eta_o)
-
-
- do dd = 0, lt - 2
- do it = 0, lt - 1
- jt = it + dd
- do ix = 0, lx - 1
- do iy = 0, ly - 1
- do iz = 0, lz - 1
- do jx = 0, lx - 1
- do jy = 0, ly - 1
- do jz = 0, lz - 1
-
- in1(ix,iy,iz,it)*in1(jx,jy,jz,jt)
-
-
-
-
-
-
- do dis_t0_t1 = 0, lt - 2
- do t0 = 0, nt - 1
-
-
- std_t1 = coord(4) + t0 + dis_t0_t1
- c = correlation_tt(t0, dis_t0_t1, psi, eta)
- if (std_t1 < L(4)) then
- c_t0t1(dis_t0_t1,0) = c_t0t1(dis_t0_t1,0) + c
- else
- c_t0t1(dis_t0_t1,1) = c_t0t1(dis_t0_t1,1) + c
- endif
- enddo
- c_t0t1(dis_t0_t1,0) = c_t0t1(dis_t0_t1,0) / dble( LT - dis_t0_t1 )
- if (dis_t0_t1 /= 0) then
- c_t0t1(dis_t0_t1,1) = c_t0t1(dis_t0_t1,1) / dble( dis_t0_t1 )
- endif
- enddo
-
-end
-
-!-------------------------------------------------------------------------------
-subroutine psi_g5_psi(p5p,psi1,psi2)
-
- use module_vol
- use module_p_interface
- implicit none
- SPINCOL_FIELD, intent(in) :: psi1, psi2
- COMPLEX,dimension(volh),intent(out) :: p5p
- P_SPINCOL_FIELD, save :: tmp
- COMPLEX, external :: cdotc_12
- integer :: i
-
- ALLOCATE_SC_FIELD(tmp)
-
- tmp=psi2
- call gamma5(tmp,volh)
-
- !$omp parallel do
- do i = 1, volh
- p5p(i) = cdotc_12(psi1(1,1,i), tmp(1,1,i))
- enddo
-
-end
-
-!===============================================================================
diff --git a/src/measure/correlations.F90 b/src/measure/correlations.F90
index f64ddb86eb5688dc70909c5f2398dbbb0de12f9d..fb76e4f1beb36122ae79f1501924d45fb6cd83aa 100644
--- a/src/measure/correlations.F90
+++ b/src/measure/correlations.F90
@@ -23,9 +23,394 @@
!
!-------------------------------------------------------------------------------
# include "defs.h"
+# include "gamma.h"
!-------------------------------------------------------------------------------
-subroutine correlations(para, conf, traj, i_ensemble1, i_ensemble2)
+module hadron_corr
+ implicit none
+ integer, save :: n_mom=1
+ type quark_prop
+ COMPLEX, dimension(:,:,:,:,:,:), pointer :: g
+ end type
+
+ type(quark_prop), dimension(:),pointer,save :: qprop
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine correlations(traj)
+ use module_field
+ use module_action
+ use module_input
+ use hadron_corr
+ use module_vol
+ use module_switches
+ implicit none
+ integer, intent(in) :: traj
+ integer :: fid, mid, src_at(4)
+
+ if (.not. switches%measure_correlations) return
+ call gamma_init()
+ fid = input%hmc_mpf_mass
+ mid = action%fermi(fid)%mid1
+
+ allocate(qprop(1))
+ allocate(qprop(1)%g(4,4,3,3,volh, EVEN:ODD))
+
+ src_at = (/2, 2, 2, 11/)
+
+ call get_qprop(qprop(1), mid, LOCAL_SOURCE, src_at)
+ call meson(qprop(1), qprop(1))
+ call baryon(qprop(1),qprop(1),qprop(1))
+end
+
+!-------------------------------------------------------------------------------
+subroutine meson(qprop0, qprop1) ! full meason prop
+ use gamma
+ use hadron_corr
+ use module_lattice
+ use module_function_decl
+ implicit none
+ type(quark_prop), intent(in) :: qprop0, qprop1
+ COMPLEX, dimension(DIM, DIM, DIM, DIM, n_mom, 0:lt-1) :: meason_corr
+ integer :: is1, is2, is3, is4, ic1, ic2, ix,iy,iz,it, j(4), coord(4), ii, eo, imom, igop1, igop2
+ COMPLEX :: ctmp, c_local(n_mom), pexp_fac_c, m_corr(0:lt-1,n_mom), g1(4,4), g2(4,4)
+ integer, external :: e_o, std_xyzt2i
+
+ pexp_fac_c=ONE
+ call pe2coord(my_pe(), coord)
+
+ meason_corr = 0
+
+ do is1 = 1, 4
+ do is2 = 1, 4
+ do is3 = 1, 4
+ do is4 = 1, 4
+ do it = 0, nt-1
+ c_local(:) = 0
+ do iz = 0, nz-1
+ do iy = 0, ny-1
+ do ix = 0, nx-1
+ ctmp = 0
+ j = (/ix, iy, iz, it/)
+ ii = std_xyzt2i(j)
+ eo = e_o(j)
+ do ic1 = 1, 3
+ do ic2 = 1, 3
+ ctmp = ctmp + qprop0%g(is1,is2,ic1,ic2,ii,eo) &
+ * conjg(qprop1%g(is4,is3,ic1,ic2,ii,eo))
+ enddo
+ enddo
+ do imom = 1, n_mom
+!! c_local(imom) = c_local(imom) + pexp_fac_c(imom,ix,iy,iz) * ctmp
+ c_local(imom) = c_local(imom) + pexp_fac_c * ctmp
+ enddo
+ enddo
+ enddo
+ enddo
+ meason_corr(is1,is2,is3,is4,1:n_mom, it + nt*coord(4) ) = c_local(1:n_mom)
+ enddo
+ enddo ! is4
+ enddo ! is3
+ enddo ! is2
+ enddo ! is1
+
+
+
+ call global_sum_vec(256*n_mom*lt *2, meason_corr)
+
+!! do igop1 = 1, ngop
+!! do igop2 = 1, ngop
+ do igop1 = 5, 5
+ do igop2 = 5, 5
+ call spin_mul(g1, gamma_op(G5)%c, gamma_op(igop1)%c) ! gop1 = gamma5 * gop1
+ call spin_mul(g2, gamma_op(igop2)%c, gamma_op(G5)%c) ! gop2 = gop2 * gamma5
+ do imom = 1, n_mom
+ do it = 0, lt - 1
+ ctmp=0
+ do is1 = 1, 4
+ do is2 = 1, 4
+ do is3 = 1, 4
+ do is4 = 1, 4
+ if (g1(is4, is1) /= 0 .and. g2(is2, is3) /= 0) then
+ ctmp= ctmp + g1(is4, is1) * g2(is2, is3) * meason_corr(is1,is2,is3,is4, imom, it)
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ m_corr(it, imom) = ctmp
+ enddo
+ enddo
+ write(*,*)igop1, igop2
+ do it = 0, lt-1
+ write(*,*)m_corr(it, 1)
+ enddo
+ enddo
+ enddo
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine baryon(qp1, qp2, qp3) ! full baryon prop
+ use gamma
+ use hadron_corr
+ use module_lattice
+ use module_function_decl
+ implicit none
+ type(quark_prop), intent(in) :: qp1, qp2, qp3
+ COMPLEX, dimension(n_mom, 0:lt-1) :: baryon_corr
+ integer :: ix,iy,iz,it, j(4), coord(4), ii, eo, imom, c1, c2
+ COMPLEX :: ctmp, s_local(n_mom,0:nt-1), pexp_fac_c, b_corr(0:lt-1,n_mom)
+ COMPLEX, dimension(4,4,3,3) :: g_aap, g_bbp, g_ccp, tmp1, tmp2, tmp3
+ COMPLEX, dimension(4,4) :: tt0
+ integer, external :: e_o, std_xyzt2i
+ COMPLEX, external :: tracespin2
+
+ pexp_fac_c=ONE
+ call pe2coord(my_pe(), coord)
+
+ baryon_corr = 0
+
+ do it = 0, nt-1
+ do iz = 0, nz-1
+ do iy = 0, ny-1
+ do ix = 0, nx-1
+
+ j = (/ix, iy, iz, it/)
+ ii = std_xyzt2i(j)
+ eo = e_o(j)
+ g_aap = qp1%g(:,:,:,:,ii,eo)
+ g_bbp = qp2%g(:,:,:,:,ii,eo)
+ g_ccp = qp3%g(:,:,:,:,ii,eo)
+
+ do c1=1, NCOL
+ do c2=1, NCOL
+ call spin_mul( tmp1(1,1,c1,c2), g_bbp(1,1,c1,c2), gamma_op(G31)%c)
+ call spin_mul( tmp2(1,1,c1,c2), gamma_op(G31)%c, g_bbp(1,1,c1,c2))
+ enddo
+ enddo
+ call contraction13(tmp3, tmp1, tmp2)
+
+ call tracecol1(tt0 , g_aap, tmp3)
+ ctmp = tracespin2(gamma_op(POL)%c,tt0)
+ call tracecol2(tt0 , g_aap, tmp3)
+ ctmp = ctmp + tracespin2(gamma_op(POL)%c,tt0)
+
+ do imom = 1, n_mom
+!!! s_local(imom,it) = s_local(imom,it) + ctmp * epsi_epsip * pexp_fac_c(imom,ix,iy,iz)
+ s_local(imom,it) = s_local(imom,it) + ctmp * pexp_fac_c
+ enddo
+ enddo
+ enddo
+ enddo
+ baryon_corr(:,it+nt*coord(4)) = s_local(:,it)
+ enddo
+
+ call global_sum_vec(n_mom*lt *2, baryon_corr)
+
+ do imom = 1, n_mom
+ do it = 0, lt - 1
+ b_corr(it, imom) = baryon_corr(imom,it)
+ enddo
+ enddo
+
+ write(*,*)"Baryon"
+ do it = 0, lt-1
+ write(*,*)b_corr(it, 1)
+ enddo
+end
+
+!-------------------------------------------------------------------------------
+!!subroutine baryon(qp1, qp2, qp3) ! full baryon prop
+!! use gamma
+!! use hadron_corr
+!! use module_lattice
+!! use module_function_decl
+!! implicit none
+!! type(quark_prop), intent(in) :: qp1, qp2, qp3
+!! COMPLEX, dimension(DIM, DIM, n_mom, 0:lt-1) :: baryon_corr
+!! integer :: is1, is2, is3, is4, ic1, ic2, ix,iy,iz,it, j(4), coord(4), ii, eo, imom, epsi_l, epsi_lp, a, b,c ,ap,bp,cp, epsi, epsi_epsip
+!! COMPLEX :: ctmp, s_local(4,4,n_mom,0:nt-1), pexp_fac_c, b_corr(0:lt-1,n_mom)
+!! COMPLEX, dimension(4,4) :: g_aap, g_bbp, g_ccp, g_bbpccp, g_aapbbpccp, tmp
+!! integer, external :: e_o, std_xyzt2i
+!! COMPLEX, external :: spintr
+!! COMPLEX, external :: tracespin2
+!! pexp_fac_c=ONE
+!! call pe2coord(my_pe(), coord)
+!!
+!! baryon_corr = 0
+!!
+!! do it = 0, nt-1
+!! do epsi_l = 0, 1
+!! do a = 1, NCOL
+!! b = mod(a+epsi_l , NCOL) + 1
+!! c = mod(a-epsi_l+1, NCOL) + 1
+!! epsi = (1-2*epsi_l)
+!! do epsi_lp = 0, 1
+!! do ap = 1, NCOL
+!! bp = mod(ap+epsi_lp , NCOL) + 1
+!! cp = mod(ap-epsi_lp+1, NCOL) + 1
+!! epsi_epsip = epsi*(1-2*epsi_lp)
+!!
+!! do iz = 0, nz-1
+!! do iy = 0, ny-1
+!! do ix = 0, nx-1
+!!
+!! j = (/ix, iy, iz, it/)
+!! ii = std_xyzt2i(j)
+!! eo = e_o(j)
+!! g_aap = qp1%g(:,:,a,ap,ii,eo)
+!! g_bbp = qp2%g(:,:,b,bp,ii,eo)
+!! g_ccp = qp3%g(:,:,c,cp,ii,eo)
+!! call g31xg31t(tmp, g_bbp)
+!! call spin_mul(g_bbpccp, tmp, g_ccp)
+!! call spin_mul(g_aapbbpccp, g_aap, g_bbpccp)
+!! tmp = spintr(g_bbpccp) * g_aap + g_aapbbpccp
+!!
+!! do imom = 1, n_mom
+!!!!! s_local(:,:,imom,it) = s_local(:,:,imom,it) + tmp * epsi_epsip * pexp_fac_c(imom,ix,iy,iz)
+!! s_local(:,:,imom,it) = s_local(:,:,imom,it) + tmp * epsi_epsip * pexp_fac_c
+!! enddo
+!!
+!!
+!! enddo
+!! enddo
+!! enddo
+!! enddo
+!! enddo
+!! enddo
+!! enddo
+!! baryon_corr(:,:,:,it+nt*coord(4)) = s_local(:,:,:,it)
+!! enddo
+!!
+!! call global_sum_vec(16*n_mom*lt *2, baryon_corr)
+!!
+!! do imom = 1, n_mom
+!! do it = 0, lt - 1
+!!!! b_corr(it, imom) = spintr(baryon_corr(1,1,imom,it))
+!! b_corr(it, imom) = tracespin2(gamma_op(UNP)%c, baryon_corr(1,1,imom,it))
+!! enddo
+!! enddo
+!! write(*,*)"Baryon"
+!! do it = 0, lt-1
+!! write(*,*)b_corr(it, 1)
+!! enddo
+!!
+!!
+!!end
+
+!-------------------------------------------------------------------------------
+subroutine get_qprop(qprop0, mid, source_type, src_at)
+ use hadron_corr
+ use module_vol
+ implicit none
+ type(quark_prop), intent(out) :: qprop0
+ integer, intent(in) :: mid, source_type, src_at(4)
+ SPINCOL_FIELD :: inp_e, inp_o, out_e, out_o
+ integer :: is, ic
+
+ call init_quark(mid)
+ call make_source_local(inp_e, inp_o, src_at)
+ call make_quark_source(qprop0%g(1,1,1,1,1,0), qprop0%g(1,1,1,1,1,1), inp_e, inp_o)
+
+ do ic = 1, 3
+ do is = 1, 4
+ call get_quark_source(inp_e, inp_o, qprop0%g(1,1,1,1,1,0), qprop0%g(1,1,1,1,1,1), is, ic)
+ call solve(mid, out_e, out_o, inp_e, inp_o)
+ call put_quark_source(qprop0%g(1,1,1,1,1,0), qprop0%g(1,1,1,1,1,1), out_e, out_o, is, ic)
+ enddo
+ enddo
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine contraction13(qout, q1, q2)
+ implicit none
+ COMPLEX, dimension(4,4,3,3) :: qout, q1, q2
+ integer :: i, j, k, ip, jp, kp, ieps, jeps, eps1, eps2
+ integer :: a, b, c
+
+ qout=ZERO
+ do ieps = 0, 1
+ do i = 1, NCOL
+ j = mod(i + ieps , NCOL) + 1
+ k = mod(i - ieps+1, NCOL) + 1
+ eps1 = (1-2*ieps)
+ do jeps = 0, 1
+ do ip = 1, NCOL
+ jp = mod(ip + jeps , NCOL) + 1
+ kp = mod(ip - jeps+1, NCOL) + 1
+ eps2 = (1-2*jeps)
+
+ do a =1, DIM
+ do b =1, DIM
+ do c =1, DIM
+ qout(a,b,kp,k) = qout(a,b,kp,k) &
+ + eps1 * eps2 * q1(c,a,i,ip) * q2(c,b,j,jp)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+end
+
+!-------------------------------------------------------------------------------
+subroutine tracecol1(qout, q1, q2) ! traceColor (q1 * traceSpin(q2))
+ implicit none
+ COMPLEX, dimension(4,4) :: qout
+ COMPLEX, dimension(4,4,3,3) :: q1, q2
+ COMPLEX :: tmp
+ integer :: i, j
+
+ qout=ZERO
+ do i = 1, NCOL
+ do j = 1, NCOL
+ tmp = q2(1,1,j,i)+q2(2,2,j,i)+q2(3,3,j,i)+q2(4,4,j,i)
+ qout(:,:) = qout(:,:) + q1(:,:,i,j) * tmp
+ enddo
+ enddo
+end
+
+!-------------------------------------------------------------------------------
+subroutine tracecol2(qout, q1, q2) ! traceColor (q1 * q2)
+ implicit none
+ COMPLEX, dimension(4,4) :: qout
+ COMPLEX, dimension(4,4,3,3) :: q1, q2
+ integer :: i, j
+
+ qout=ZERO
+ do i = 1, NCOL
+ do j = 1, NCOL
+ qout(:,:) = qout(:,:) + q1(:,:,i,j) * q2(:,:,j,i)
+ enddo
+ enddo
+end
+
+!-------------------------------------------------------------------------------
+COMPLEX function tracespin2(q1, q2) ! traceSpin (q1 * q2)
+ implicit none
+ COMPLEX, dimension(4,4) :: q1, q2
+ COMPLEX :: tmp
+ integer :: i, j
+
+ tmp=ZERO
+ do i = 1, DIM
+ do j = 1, DIM
+ tmp = tmp + q1(i,j) * q2(j,i)
+ enddo
+ enddo
+ tracespin2 = tmp
+end
+
+!-------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
+!
+! this subroutine is for cross check, for Dirk's analysis code for theta
+!
+subroutine quark_prop_test(para, conf, traj, i_ensemble1, i_ensemble2)
use module_field
use module_action
@@ -127,3 +512,109 @@ subroutine correlations(para, conf, traj, i_ensemble1, i_ensemble2)
end
!===============================================================================
+!===============================================================================
+!
+! copy form old version vector12.F90
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2007 Yoshifumi Nakamura
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+# include "defs.h"
+
+!-------------------------------------------------------------------------------
+subroutine global_sum_vector12(sc,in_e,in_o)
+
+ use module_function_decl
+ use module_vol
+ implicit none
+ COMPLEX, dimension(DIM,NCOL), intent(out) :: sc
+ SPINCOL_FIELD, intent(in) :: in_e, in_o
+ COMPLEX :: tmp
+ REAL :: re, im
+ integer :: i, mu, c
+
+ do c = 1, 3
+ do mu = 1, 4
+ tmp = ZERO
+ !$omp parallel do reduction(+: tmp)
+ do i = 1, volh
+ tmp = tmp + in_e(mu,c,i)
+ enddo
+ !$omp parallel do reduction(+: tmp)
+ do i = 1, volh
+ tmp = tmp + in_o(mu,c,i)
+ enddo
+ re = global_sum(dble(tmp))
+ im = global_sum(dimag(tmp))
+ sc(mu,c) = cmplx( re, im, kind = RKIND)
+ enddo
+ enddo
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine write_vector12_0000_sum(in_e,in_o,name)
+
+ use module_function_decl
+ use module_vol
+ implicit none
+ SPINCOL_FIELD, intent(in) :: in_e, in_o
+ character( len = 6), intent(in) :: name
+
+ COMPLEX, dimension(DIM,NCOL) :: sc
+ character( len = 10) :: name1, name2
+
+ call global_sum_vector12(sc, in_e, in_o)
+
+ write(name1,10)name,"0000"
+ write(name2,10)name,"_sum"
+
+ call write_vector12(0, in_e(1,1,1), name1)
+ call write_vector12(0, sc, name2)
+
+10 format (2a)
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine write_vector12(pe,sc,name)
+
+ use module_function_decl
+ implicit none
+ COMPLEX, dimension(DIM,NCOL), intent(in) :: sc
+ integer, intent(in) :: pe
+ character( len = 10) :: name
+ integer :: mu, c
+
+
+ if (my_pe() == pe) then
+ do c = 1, 3
+ do mu = 1, 4
+ write(*,100)"%%%",name,&
+ my_pe(),mu,c,dble(sc(mu,c)),dimag(sc(mu,c))
+ enddo
+ enddo
+ endif
+
+100 format (1x, 2a, 3i3, 2ES17.7)
+
+end
+
+!===============================================================================
diff --git a/src/measure/cublas_wrap.c b/src/measure/cublas_wrap.c
new file mode 100644
index 0000000000000000000000000000000000000000..7d890c3fea815c8f08b286fa409a402fe3afe3e0
--- /dev/null
+++ b/src/measure/cublas_wrap.c
@@ -0,0 +1,346 @@
+/*
+!===============================================================================
+!
+! cublas_wrap.c - cuda version for some lapack functions
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2011 Yoshifumi Nakamura
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+*/
+#ifdef NamesToLower
+# define ZMINV_NV zminv_nv
+# define ZGETF2_NV zgetf2_nv
+# define ZGEMM_NV zgemm_nv
+#endif
+#ifdef NamesToLower_
+# define ZMINV_NV zminv_nv_
+# define ZGETF2_NV zgetf2_nv_
+# define ZGEMM_NV zgemm_nv_
+#endif
+#ifdef NamesToLower__
+# define ZMINV_NV zminv_nv__
+# define ZGETF2_NV zgetf2_nv__
+# define ZGEMM_NV zgemm_nv__
+#endif
+
+#include <cublas.h>
+#include <stdio.h>
+#define min(a, b) ((a) < (b) ? (a) : (b))
+
+void ZMINV_NV(const int* m, const int* n, const double* A, const int* lda,
+ int* ipiv, int* info){
+
+ // printf ("now zminv_nv_ started\n");
+
+ int stat, i;
+ cuDoubleComplex *devA, *devW, *zero;
+ cuDoubleComplex mone, one, tmp, ttmp;
+ one=make_cuDoubleComplex( 1, 0);
+ mone=make_cuDoubleComplex(-1, 0);
+
+ zero=( cuDoubleComplex * )malloc(*n *16);
+ for (i=0; i< *n; i++){ zero[i]=make_cuDoubleComplex( 0, 0);}
+
+
+ *info=0;
+ stat = cublasInit();
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("cublasInit failed");
+ *info =1;
+ return;
+ }
+
+ int mm=(*m);
+ int nn=(*n);
+ int size=mm * nn;
+
+ stat = cublasAlloc (size, 16, (void**)&devA);
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("device memory allocation failed %d %d\n",stat,size);
+ cublasShutdown();
+ *info=1;
+ return;
+ }
+ stat = cublasAlloc (nn, 16, (void**)&devW);
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("device memory allocation failed %d %d\n",stat,nn);
+ cublasShutdown();
+ *info=1;
+ return;
+ }
+ cublasSetMatrix(*m, *n, 16, A, *n, devA, *m);
+
+//ZGETF2 start
+ int j, j0n, j1n, jp;
+ for (j=0; j<min(mm,nn); j++) {
+ j0n= j * nn;
+ j1n= (j+1) * nn;
+ jp = j - 1 + cublasIzamax( mm-j, &devA[ j+j0n ], 1 ) ;
+
+ ipiv[ j ] = jp + 1 ;
+ // if (j0n+j >= nn*mm || j0n+j <0){printf ("zgetf2_nv_ j0n+j =%d \n",j0n+j );exit;}
+ // if (j0n+jp >= nn*mm || j0n+jp <0){printf ("zgetf2_nv_ j0n+jp =%d \n",j0n+jp );exit;}
+ // if (j >= nn*mm || j <0){printf ("zgetf2_nv_ j =%d \n",j );exit;}
+ // if (jp >= nn*mm || jp <0){printf ("zgetf2_nv_ jp =%d \n",jp );exit;}
+
+ cublasGetMatrix(1, 1, 16, &devA[ j0n+jp ], 1, (void*)&tmp, 1);
+
+ if(!( tmp.x == 0.0d && tmp.y == 0.0d) ) {
+ if( jp != j) cublasZswap(nn, &devA[ j ], *lda, &devA[ jp ], *lda);
+ cublasGetMatrix(1, 1, 16, &devA[j0n+j], 1, (void*)&tmp, 1);
+ ttmp = cuCdiv(one , tmp);
+ if( j < mm-1) cublasZscal(mm-j-1, ttmp, &devA[ j+1+j0n], 1);
+ } else if( *info == 0 ) {
+ printf ("zgetf2_nv_ tmp=0 at j=%d\n",j);
+ *info = j;
+ }
+ if ( j < min(mm,nn)-1)
+ cublasZgeru( mm-j-1, nn-j-1, mone, &devA[ j+1+j0n ], 1, &devA[ j+j1n ], *lda, &devA[ j+1+j1n ], *lda);
+ //ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA )
+ }
+//ZGETF2 end
+
+//ZTRTI2 for Upper & No-unit start
+ for (j=0;j<nn;j++) {
+ j0n= j * nn;
+ cublasGetMatrix(1, 1, 16, &devA[j0n+j], 1, (void*)&tmp, 1);
+ ttmp = cuCdiv(one , tmp);
+ cublasSetMatrix(1, 1, 16, (void*)&ttmp, 1, &devA[j0n+j], 1);
+ ttmp.x = -ttmp.x;
+ ttmp.y = -ttmp.y;
+ cublasZtrmv('U','N', 'N', j, devA, *lda, &devA[j0n],1);
+ cublasZscal( j, ttmp, &devA[j0n],1);
+ }
+//ZTRTI2 for Upper & No-unit end
+
+//===============================================================
+//ZGETRI unblocked start
+ for (j=nn-1;j>=0;j--) {
+ j0n= j * nn;
+ j1n= (j+1) * nn;
+ if (j!=nn-1)cublasZcopy(nn-j-1, &devA[j0n+j+1], 1, devW, 1);
+ if (j!=nn-1)cublasSetVector(nn-j-1, 16, zero, 1, &devA[j0n+j+1], 1);
+ if( j < nn-1 )
+ cublasZgemv('N', nn, nn-j-1, mone, &devA[j1n], *lda, devW, 1, one, &devA[ j0n],1);
+ }
+//ZGETRI unblocked end
+
+// interchange
+ for (j=nn-2;j>=0;j--) {
+ jp=ipiv[j]-1;
+ if (jp != j) cublasZswap(nn, &devA[j*nn],1, &devA[jp*nn],1);
+ }
+
+ free(zero);
+ cublasGetMatrix(*m, *n, 16, devA, *n, (void*)A, *m);
+ stat = cublasFree(devA);
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("cublasFree failed");
+ *info =1;
+ return;
+ }
+
+ stat = cublasFree(devW);
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("cublasFree failed");
+ *info =1;
+ return;
+ }
+
+ cublasShutdown();
+ //if (stat != CUBLAS_STATUS_SUCCESS) {
+ // printf ("cublasShutdown failed");
+ // *info =1;
+ // return;
+ // }
+ //fflush(stdout);
+}
+
+
+void ZGETF2_NV(const int* m, const int* n, const double* A, const int* lda,
+ int* ipiv, int* info){
+ int stat, i;
+ cuDoubleComplex *devA, *devW, *zero;
+ cuDoubleComplex mone, one, tmp, ttmp;
+ one=make_cuDoubleComplex( 1, 0);
+ mone=make_cuDoubleComplex(-1, 0);
+
+ zero=( cuDoubleComplex * )malloc(*n *16);
+ for (i=0; i< *n; i++){ zero[i]=make_cuDoubleComplex( 0, 0);}
+
+
+ *info=0;
+ stat = cublasInit();
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("cublasInit failed");
+ *info =1;
+ return;
+ }
+
+ int mm=(*m);
+ int nn=(*n);
+ int size=mm * nn;
+
+ stat = cublasAlloc (size, 16, (void**)&devA);
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("device memory allocation failed %d %d\n",stat,size);
+ cublasShutdown();
+ *info=1;
+ return;
+ }
+ stat = cublasAlloc (nn, 16, (void**)&devW);
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("device memory allocation failed %d %d\n",stat,nn);
+ cublasShutdown();
+ *info=1;
+ return;
+ }
+ cublasSetMatrix(*m, *n, 16, A, *n, devA, *m);
+
+//ZGETF2 start
+ int j, j0n, j1n, jp;
+ for (j=0; j<min(mm,nn); j++) {
+ j0n= j * nn;
+ j1n= (j+1) * nn;
+ jp = j - 1 + cublasIzamax( mm-j, &devA[ j+j0n ], 1 ) ;
+
+ ipiv[ j ] = jp + 1 ;
+ // if (j0n+j >= nn*mm || j0n+j <0){printf ("zgetf2_nv_ j0n+j =%d \n",j0n+j );exit;}
+ // if (j0n+jp >= nn*mm || j0n+jp <0){printf ("zgetf2_nv_ j0n+jp =%d \n",j0n+jp );exit;}
+ // if (j >= nn*mm || j <0){printf ("zgetf2_nv_ j =%d \n",j );exit;}
+ // if (jp >= nn*mm || jp <0){printf ("zgetf2_nv_ jp =%d \n",jp );exit;}
+
+ cublasGetMatrix(1, 1, 16, &devA[ j0n+jp ], 1, (void*)&tmp, 1);
+
+ if(!( tmp.x == 0.0d && tmp.y == 0.0d) ) {
+ if( jp != j) cublasZswap(nn, &devA[ j ], *lda, &devA[ jp ], *lda);
+ cublasGetMatrix(1, 1, 16, &devA[j0n+j], 1, (void*)&tmp, 1);
+ ttmp = cuCdiv(one , tmp);
+ if( j < mm-1) cublasZscal(mm-j-1, ttmp, &devA[ j+1+j0n], 1);
+ } else if( *info == 0 ) {
+ printf ("zgetf2_nv_ tmp=0 at j=%d\n",j);
+ *info = j;
+ }
+ if ( j < min(mm,nn)-1)
+ cublasZgeru( mm-j-1, nn-j-1, mone, &devA[ j+1+j0n ], 1, &devA[ j+j1n ], *lda, &devA[ j+1+j1n ], *lda);
+ //ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA )
+ }
+//ZGETF2 end
+
+ free(zero);
+ cublasGetMatrix(*m, *n, 16, devA, *n, (void*)A, *m);
+ stat = cublasFree(devA);
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("cublasFree failed");
+ *info =1;
+ return;
+ }
+
+ stat = cublasFree(devW);
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("cublasFree failed");
+ *info =1;
+ return;
+ }
+ cublasShutdown();
+}
+
+
+//================================================================================
+ void ZGEMM_NV(const char *transa, const char *transb, const int *m,
+ const int *n, const int *k, const cuDoubleComplex *alpha,
+ const cuDoubleComplex *A, const int *lda,
+ const cuDoubleComplex *B, const int *ldb,
+ const cuDoubleComplex *beta, const cuDoubleComplex *C,
+ const int *ldc, int *info)
+
+{
+ // printf ("now zgemm_nv_ started\n");
+
+ cuDoubleComplex *devA, *devB, *devC ;
+ int size=(int)(*m) * (int)(*n) ;
+ int stat;
+
+ *info=0;
+ cublasInit();
+ //if (stat != CUBLAS_STATUS_SUCCESS) {
+ // printf ("cublasInit failed");
+ // *info =1;
+ // return;
+ //}
+
+ stat = cublasAlloc (size, 16, (void**)&devA);
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("device memory allocation failed %d %d\n",stat,size);
+ *info =1;
+ return;
+ }
+ stat = cublasAlloc (size, 16, (void**)&devB);
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("device memory allocation failed %d %d\n",stat,size);
+ *info =1;
+ return;
+ }
+ stat = cublasAlloc (size, 16, (void**)&devC);
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("device memory allocation failed %d %d\n",stat,size);
+ *info =1;
+ return;
+ }
+ // printf ("cublasAlloc done\n");
+
+ cublasSetMatrix(*m, *n, 16, A, *n, devA, *m);
+ cublasSetMatrix(*m, *n, 16, B, *n, devB, *m);
+
+ // cublasSetMatrix(*m, *n, 16, C, *n, devC, *m);
+ // printf ("cublasSetMatrix done\n");
+
+ cublasZgemm (transa[0], transb[0], *m, *n, *k, *alpha, devA, *lda, devB, *ldb, *beta, devC, *ldc);
+ // cublasZgemm (transa[0], transb[0], *m, *n, *k, *alpha, devA, *lda, devB, *ldb, *beta, devC, *ldc);
+
+ cublasGetMatrix(*m, *n, 16, devC, *n, (void*)C, *m);
+ // printf ("cublasGetMatrix done\n");
+
+ stat = cublasFree(devA);
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("cublasFree failed");
+ *info =1;
+ return;
+ }
+ stat = cublasFree(devB);
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("cublasFree failed");
+ *info =1;
+ return;
+ }
+ stat = cublasFree(devC);
+ if (stat != CUBLAS_STATUS_SUCCESS) {
+ printf ("cublasFree failed");
+ *info =1;
+ return;
+ }
+
+ cublasShutdown();
+ //if (stat != CUBLAS_STATUS_SUCCESS) {
+ // printf ("cublasShutdown failed");
+ // *info =1;
+ // return;
+ //}
+}
diff --git a/src/measure/desc.h b/src/measure/desc.h
new file mode 100644
index 0000000000000000000000000000000000000000..89c1cc40d36accd744aa690ba457af1bf342c74e
--- /dev/null
+++ b/src/measure/desc.h
@@ -0,0 +1,5 @@
+INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, &
+ LLD_, MB_, M_, NB_, N_, RSRC_
+PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1, &
+ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6, &
+ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
diff --git a/src/measure/dirac_matrix.F90 b/src/measure/dirac_matrix.F90
new file mode 100644
index 0000000000000000000000000000000000000000..d26246231db056a58f9a598de223777d56233271
--- /dev/null
+++ b/src/measure/dirac_matrix.F90
@@ -0,0 +1,739 @@
+!===============================================================================
+!
+! dirac_matrix.F90
+!
+! make Dirac operator as matrix form,
+! matrix shape for parallel computing is (12, volume/NPE, 12, volume)
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2011 Yoshifumi Nakamura
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+# include "defs.h"
+
+!-------------------------------------------------------------------------------
+module module_dirac_matrix
+ implicit none
+ COMPLEX,dimension(4,4),save :: proj_1_p_gamma1, proj_1_m_gamma1
+ COMPLEX,dimension(4,4),save :: proj_1_p_gamma2, proj_1_m_gamma2
+ COMPLEX,dimension(4,4),save :: proj_1_p_gamma3, proj_1_m_gamma3
+ COMPLEX,dimension(4,4),save :: proj_1_p_gammac, proj_1_m_gammac
+ COMPLEX,dimension(4,4),save :: proj_1_p_gamman, proj_1_m_gamman
+
+ integer, pointer, save :: ieo2_around_i(:,:,:)
+ integer, pointer, save :: ieo2_around_is(:,:,:)
+ integer, pointer, save :: ieo2_around_it(:,:,:)
+end module
+
+!-------------------------------------------------------------------------------
+subroutine checkmat(id)
+ use module_field
+ use module_action
+ use module_vol
+ implicit none
+ integer, intent(in) :: id
+ SPINCOL_FIELD :: eta_e, eta_o, zeta_e, zeta_o
+ COMPLEX,allocatable :: zeta(:), eta(:), zeta1(:), mat(:,:)
+ REAL :: fac1, fac2
+
+ call stderr2("Now check mat-vec mult with chemical potential")
+
+ allocate(zeta(12*vol), zeta1(12*vol), eta(12*vol), mat(12*vol, 12*volume))
+
+ call make_source(eta_e, eta_o, RANDOM_SOURCE)
+ call sceo2sc(eta, eta_e, eta_o)
+ !
+ ! result multiplied by using d
+ !
+! call d(se, so, zeta_e, eta_o, gauge(2)%u(1,1,1,0,1))
+! call sc_xpby(zeta_e, eta_e, - action%mtilde(id)%kappa)
+! call d(so, se, zeta_o, eta_e, gauge(2)%u(1,1,1,0,1))
+! call sc_xpby(zeta_o, eta_o, - action%mtilde(id)%kappa)
+! call clover_mult_a(zeta_e, clover(action%mtilde(id)%cid)%a(1,1,se), eta_e, volh)
+! call clover_mult_a(zeta_o, clover(action%mtilde(id)%cid)%a(1,1,so), eta_o, volh)
+
+ fac1=exp( chemi)
+ fac2=exp(-chemi)
+ if (chemi /= 0)call emuu4(gauge(2)%u, fac1, fac2, .false.)
+ call unprec_wmul(zeta_e, zeta_o, eta_e, eta_o, id)
+ if (chemi /= 0)call emuu4(gauge(2)%u, ONE/fac1, ONE/fac2, .false.)
+
+ call sceo2sc(zeta, zeta_e, zeta_o)
+ call make_dirac_op(mat, id, exp(chemi), exp(-chemi))
+ call matvec_mul(mat, zeta1, eta, 12*vol, 12*volume)
+ call compare_sc(zeta, zeta1, 24*vol)
+
+ deallocate(zeta, zeta1, eta, mat)
+!! call comm_finalize()
+!! call die("stop")
+end
+
+!-------------------------------------------------------------------------------
+# define CLOVER_AS_COMPLEX_ARRAY
+# include "clover.h"
+subroutine clover_put(mat, eo, a, offset)
+ use module_dirac_matrix
+ use module_vol
+ implicit none
+ COMPLEX, dimension(18, 2, *) :: a
+ COMPLEX:: mat(3,4,vol,3,4,volume), cl1(6,6), cl2(6,6), clp(6,6), clm(6,6)
+ integer :: c1, s1, c2, s2, ii, i, eo, sc1, sc2, offset, jj
+
+ call init_dirac_matrix()
+ do i=1, volh
+ ii=ieo2_around_i(i,eo,0)
+ jj=ii + offset
+# undef J
+# define J 1
+ cl1(1,1) =A11 ; cl1(1,2) =A12 ; cl1(1,3) =A13 ; cl1(1,4) =A14 ; cl1(1,5) =A15 ; cl1(1,6) =A16
+ cl1(2,1) =A21 ; cl1(2,2) =A22 ; cl1(2,3) =A23 ; cl1(2,4) =A24 ; cl1(2,5) =A25 ; cl1(2,6) =A26
+ cl1(3,1) =A31 ; cl1(3,2) =A32 ; cl1(3,3) =A33 ; cl1(3,4) =A34 ; cl1(3,5) =A35 ; cl1(3,6) =A36
+ cl1(4,1) =A41 ; cl1(4,2) =A42 ; cl1(4,3) =A43 ; cl1(4,4) =A44 ; cl1(4,5) =A45 ; cl1(4,6) =A46
+ cl1(5,1) =A51 ; cl1(5,2) =A52 ; cl1(5,3) =A53 ; cl1(5,4) =A54 ; cl1(5,5) =A55 ; cl1(5,6) =A56
+ cl1(6,1) =A61 ; cl1(6,2) =A62 ; cl1(6,3) =A63 ; cl1(6,4) =A64 ; cl1(6,5) =A65 ; cl1(6,6) =A66
+# undef J
+# define J 2
+ cl2(1,1) =A11 ; cl2(1,2) =A12 ; cl2(1,3) =A13 ; cl2(1,4) =A14 ; cl2(1,5) =A15 ; cl2(1,6) =A16
+ cl2(2,1) =A21 ; cl2(2,2) =A22 ; cl2(2,3) =A23 ; cl2(2,4) =A24 ; cl2(2,5) =A25 ; cl2(2,6) =A26
+ cl2(3,1) =A31 ; cl2(3,2) =A32 ; cl2(3,3) =A33 ; cl2(3,4) =A34 ; cl2(3,5) =A35 ; cl2(3,6) =A36
+ cl2(4,1) =A41 ; cl2(4,2) =A42 ; cl2(4,3) =A43 ; cl2(4,4) =A44 ; cl2(4,5) =A45 ; cl2(4,6) =A46
+ cl2(5,1) =A51 ; cl2(5,2) =A52 ; cl2(5,3) =A53 ; cl2(5,4) =A54 ; cl2(5,5) =A55 ; cl2(5,6) =A56
+ cl2(6,1) =A61 ; cl2(6,2) =A62 ; cl2(6,3) =A63 ; cl2(6,4) =A64 ; cl2(6,5) =A65 ; cl2(6,6) =A66
+
+ clp=cl1+cl2
+ clm=cl1-cl2
+ do s1=1,2; do s2=1,2
+ do c1=1,3; do c2=1,3
+ sc1=(s1-1)*3+c1
+ sc2=(s2-1)*3+c2
+ mat(c1,s1 ,ii,c2,s2 ,jj)=clp(sc1,sc2)
+ mat(c1,s1+2,ii,c2,s2+2,jj)=clp(sc1,sc2)
+ mat(c1,s1 ,ii,c2,s2+2,jj)=clm(sc1,sc2)
+ mat(c1,s1+2,ii,c2,s2 ,jj)=clm(sc1,sc2)
+ enddo; enddo
+ enddo; enddo
+ enddo
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine clover_put_3d(mat, eo, a, offset)
+ use module_dirac_matrix
+ use module_vol
+ use module_lattice
+ implicit none
+ COMPLEX, dimension(18, 2, *) :: a
+ COMPLEX:: mat(3,4,nx*ny*nz,3,4,lx*ly*lz,lt), cl1(6,6), cl2(6,6), clp(6,6), clm(6,6)
+ integer :: c1, s1, c2, s2, is, it, i, eo, sc1, sc2, jj, offset
+
+ call init_dirac_matrix()
+ do i=1, volh
+ is=ieo2_around_is(i,eo,0)
+ it=ieo2_around_it(i,eo,0)
+ jj=is + offset
+# undef J
+# define J 1
+ cl1(1,1) =A11 ; cl1(1,2) =A12 ; cl1(1,3) =A13 ; cl1(1,4) =A14 ; cl1(1,5) =A15 ; cl1(1,6) =A16
+ cl1(2,1) =A21 ; cl1(2,2) =A22 ; cl1(2,3) =A23 ; cl1(2,4) =A24 ; cl1(2,5) =A25 ; cl1(2,6) =A26
+ cl1(3,1) =A31 ; cl1(3,2) =A32 ; cl1(3,3) =A33 ; cl1(3,4) =A34 ; cl1(3,5) =A35 ; cl1(3,6) =A36
+ cl1(4,1) =A41 ; cl1(4,2) =A42 ; cl1(4,3) =A43 ; cl1(4,4) =A44 ; cl1(4,5) =A45 ; cl1(4,6) =A46
+ cl1(5,1) =A51 ; cl1(5,2) =A52 ; cl1(5,3) =A53 ; cl1(5,4) =A54 ; cl1(5,5) =A55 ; cl1(5,6) =A56
+ cl1(6,1) =A61 ; cl1(6,2) =A62 ; cl1(6,3) =A63 ; cl1(6,4) =A64 ; cl1(6,5) =A65 ; cl1(6,6) =A66
+# undef J
+# define J 2
+ cl2(1,1) =A11 ; cl2(1,2) =A12 ; cl2(1,3) =A13 ; cl2(1,4) =A14 ; cl2(1,5) =A15 ; cl2(1,6) =A16
+ cl2(2,1) =A21 ; cl2(2,2) =A22 ; cl2(2,3) =A23 ; cl2(2,4) =A24 ; cl2(2,5) =A25 ; cl2(2,6) =A26
+ cl2(3,1) =A31 ; cl2(3,2) =A32 ; cl2(3,3) =A33 ; cl2(3,4) =A34 ; cl2(3,5) =A35 ; cl2(3,6) =A36
+ cl2(4,1) =A41 ; cl2(4,2) =A42 ; cl2(4,3) =A43 ; cl2(4,4) =A44 ; cl2(4,5) =A45 ; cl2(4,6) =A46
+ cl2(5,1) =A51 ; cl2(5,2) =A52 ; cl2(5,3) =A53 ; cl2(5,4) =A54 ; cl2(5,5) =A55 ; cl2(5,6) =A56
+ cl2(6,1) =A61 ; cl2(6,2) =A62 ; cl2(6,3) =A63 ; cl2(6,4) =A64 ; cl2(6,5) =A65 ; cl2(6,6) =A66
+
+ clp=cl1+cl2
+ clm=cl1-cl2
+ do s1=1,2; do s2=1,2
+ do c1=1,3; do c2=1,3
+ sc1=(s1-1)*3+c1
+ sc2=(s2-1)*3+c2
+ mat(c1,s1 ,is,c2,s2 ,jj,it)=clp(sc1,sc2)
+ mat(c1,s1+2,is,c2,s2+2,jj,it)=clp(sc1,sc2)
+ mat(c1,s1 ,is,c2,s2+2,jj,it)=clm(sc1,sc2)
+ mat(c1,s1+2,is,c2,s2 ,jj,it)=clm(sc1,sc2)
+ enddo; enddo
+ enddo; enddo
+ enddo
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine one_put(mat, m, n, offset)
+ implicit none
+ integer, intent(in) :: m, n, offset
+ COMPLEX,intent(inout) :: mat(12,m,12,n)
+ integer :: i
+
+ do i = 1, m
+ mat( 1, i, 1, i + offset )=ONE
+ mat( 2, i, 2, i + offset )=ONE
+ mat( 3, i, 3, i + offset )=ONE
+ mat( 4, i, 4, i + offset )=ONE
+ mat( 5, i, 5, i + offset )=ONE
+ mat( 6, i, 6, i + offset )=ONE
+ mat( 7, i, 7, i + offset )=ONE
+ mat( 8, i, 8, i + offset )=ONE
+ mat( 9, i, 9, i + offset )=ONE
+ mat(10, i,10, i + offset )=ONE
+ mat(11, i,11, i + offset )=ONE
+ mat(12, i,12, i + offset )=ONE
+ enddo
+end
+
+!-------------------------------------------------------------------------------
+subroutine one_put_3d(mat, m, n, offset, t)
+ implicit none
+ integer, intent(in) :: m, n, offset, t
+ COMPLEX,intent(inout) :: mat(12, m, 12, n, t)
+ integer :: i
+
+ do i = 1, t
+ call one_put(mat(:,:,:,:,i), m, n, offset)
+ enddo
+end
+
+!-------------------------------------------------------------------------------
+subroutine hop_put(mat, gp, gm, i, eo, dir, ii, kappa, fac1, fac2)
+ use module_nn
+ use module_vol
+ use module_dirac_matrix
+ use module_field
+ implicit none
+ integer, intent(in) :: i, eo, dir, ii
+ COMPLEX, intent(in) :: gp(4,4), gm(4,4)
+ COMPLEX, intent(inout) :: mat(3,4,vol,3,4,volume)
+ REAL, intent(in) :: kappa, fac1, fac2
+ integer :: s1, s2, col1, col2, jm, jj, jb
+
+ jm=nn(i, eo, dir, BWD)
+ jj=ieo2_around_i(i,eo,1 + 2*(dir-1) )
+ jb=ieo2_around_i(i,eo,2 + 2*(dir-1) )
+
+ do s1 = 1, 4
+ do s2 = 1, 4
+ if ( gp(s1, s2) /=0 ) then
+ do col1 = 1, 3
+ do col2 = 1, 3
+ mat(col1,s1,ii,col2,s2,jj)=mat(col1,s1,ii,col2,s2,jj) &
+ -kappa* gauge(2)%u(col1,col2, i, eo,dir) *gp(s1,s2)*fac1
+ enddo
+ enddo
+ endif
+ if ( gm(s1, s2) /=0 ) then
+ do col1 = 1, 3
+ do col2 = 1, 3
+ mat(col1,s1,ii,col2,s2,jb)=mat(col1,s1,ii,col2,s2,jb) &
+ -kappa*conjg(gauge(2)%u(col2,col1, jm,1-eo,dir))*gm(s1,s2)*fac2
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+end
+
+!-------------------------------------------------------------------------------
+subroutine hop_put_3d(mat, gp, gm, i, eo, dir, is, it, itoffset, kappa)
+ use module_nn
+ use module_lattice
+ use module_dirac_matrix
+ use module_field
+ implicit none
+ integer, intent(in) :: i, eo, dir, is, it, itoffset
+ COMPLEX, intent(in) :: gp(4,4), gm(4,4)
+ COMPLEX, intent(inout) :: mat(3,4,nx*ny*nz,3,4,lx*ly*lz,lt)
+ REAL, intent(in) :: kappa
+ integer :: s1, s2, col1, col2, jm, jj, jb, it1
+
+ jm=nn(i, eo, dir, BWD)
+ jj=ieo2_around_is(i,eo,1 + 2*(dir-1) )
+ jb=ieo2_around_is(i,eo,2 + 2*(dir-1) )
+ it1=it + itoffset
+
+ do s1 = 1, 4
+ do s2 = 1, 4
+ if ( gp(s1, s2) /=0 ) then
+ do col1 = 1, 3
+ do col2 = 1, 3
+ mat(col1,s1,is,col2,s2,jj, it)=mat(col1,s1,is,col2,s2,jj,it) &
+ -kappa* gauge(2)%u(col1,col2, i, eo,dir) *gp(s1,s2)
+ enddo
+ enddo
+ endif
+ if ( gm(s1, s2) /=0 ) then
+ do col1 = 1, 3
+ do col2 = 1, 3
+ mat(col1,s1,is,col2,s2,jb, it1)=mat(col1,s1,is,col2,s2,jb,it1) &
+ -kappa*conjg(gauge(2)%u(col2,col1, jm,1-eo,dir))*gm(s1,s2)
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+end
+
+!-------------------------------------------------------------------------------
+subroutine make_dirac_op(mat, id, fac1, fac2) ! for one node
+ use module_dirac_matrix
+ use module_vol
+ use module_field
+ use module_action
+ use module_function_decl
+ implicit none
+ integer, intent(in) :: id
+ REAL, intent(in) :: fac1, fac2
+ COMPLEX,intent(out) :: mat(3,4,vol,3,4,volume)
+ REAL :: kappa
+ integer :: ii, i, eo, offset
+
+ call init_dirac_matrix()
+ kappa=action%mtilde(id)%kappa
+
+ mat=ZERO
+ offset = my_pe()*vol
+ if (action%mtilde(id)%cswkappa == 0) then
+ call one_put(mat, vol, volume, offset)
+ else
+ call clover_put(mat, EVEN, clover(action%mtilde(id)%cid)%a(1,1,se), offset)
+ call clover_put(mat, ODD, clover(action%mtilde(id)%cid)%a(1,1,so), offset)
+ endif
+
+ if (kappa /= 0) then
+ do eo=EVEN, ODD
+ do i=1, volh
+ ii=ieo2_around_i(i,eo,0)
+ call hop_put(mat, proj_1_p_gamma1, proj_1_m_gamma1, i, eo, 1, ii, kappa, ONE, ONE) ! x-dir
+ call hop_put(mat, proj_1_p_gamma2, proj_1_m_gamma2, i, eo, 2, ii, kappa, ONE, ONE) ! y-dir
+ call hop_put(mat, proj_1_p_gamma3, proj_1_m_gamma3, i, eo, 3, ii, kappa, ONE, ONE) ! z-dir
+ call hop_put(mat, proj_1_m_gamman, proj_1_p_gamman, i, eo, 4, ii, kappa,fac1,fac2) ! t-dir
+ enddo
+ enddo
+ endif
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine make_dirac_op_3d(mat3,matt, id) ! for one node
+ use module_dirac_matrix
+ use module_lattice
+ use module_vol
+ use module_nn
+ use module_field
+ use module_action
+ use module_function_decl
+ implicit none
+ integer, intent(in) :: id
+ REAL :: kappa
+ COMPLEX:: mat3(3,4,nx*ny*nz,3,4,lx*ly*lz,lt)
+ COMPLEX:: matt(3,4,nx*ny*nz,3,4,lx*ly*lz,2*lt)
+ integer :: col1, s1, col2, s2, is, it, jj, i, j, eo, jb, jm, offset
+
+ call init_dirac_matrix()
+ kappa=action%mtilde(id)%kappa
+
+ mat3=ZERO
+ matt=ZERO
+ offset = my_pe()*vol/nt
+ if (action%mtilde(id)%cswkappa == 0) then
+ call one_put_3d(mat3, vol/nt, volume/nt, offset, nt)
+! do it=1,nt
+! do i=1,vol/nt
+! do col1=1,3
+! do s1=1,4
+! mat3(col1,s1,i, col1,s1,i,it)=ONE
+! enddo
+! enddo
+! enddo
+! enddo
+ else
+ call clover_put_3d(mat3, EVEN, clover(action%mtilde(id)%cid)%a(1,1,se), offset)
+ call clover_put_3d(mat3, ODD, clover(action%mtilde(id)%cid)%a(1,1,so), offset)
+ endif
+
+ if (kappa /= 0) then
+ do eo=EVEN, ODD
+ do i=1, volh
+ is=ieo2_around_is(i,eo,0)
+ it=ieo2_around_it(i,eo,0)
+ call hop_put_3d(mat3, proj_1_p_gamma1, proj_1_m_gamma1, i, eo, 1, is, it, 0, kappa) ! x-dir
+ call hop_put_3d(mat3, proj_1_p_gamma2, proj_1_m_gamma2, i, eo, 2, is, it, 0, kappa) ! y-dir
+ call hop_put_3d(mat3, proj_1_p_gamma3, proj_1_m_gamma3, i, eo, 3, is, it, 0, kappa) ! z-dir
+ call hop_put_3d(matt, proj_1_m_gamman, proj_1_p_gamman, i, eo, 4, is, it,lt, kappa) ! t-dir
+
+!! !
+!! ! x-dir
+!! !
+!! jj=ieo2_around_is(i,eo,1)
+!! jb=ieo2_around_is(i,eo,2)
+!! jm=nn(i, eo, 1, BWD)
+!! do s1=1,4; do s2=1,4
+!! if (proj_1_p_gamma1(s1,s2) /=0) then
+!! do col1=1,3; do col2=1,3
+!! mat3(col1,s1,is,col2,s2,jj,it)=mat3(col1,s1,is,col2,s2,jj,it) -kappa* gauge(1)%u(col1,col2, i, eo,1) *proj_1_p_gamma1(s1,s2)
+!! mat3(col1,s1,is,col2,s2,jb,it)=mat3(col1,s1,is,col2,s2,jb,it) -kappa*conjg(gauge(1)%u(col2,col1, jm,1-eo,1))*proj_1_m_gamma1(s1,s2)
+!! enddo; enddo
+!! endif
+!! enddo; enddo
+!! !
+!! ! y-dir
+!! !
+!! jj=ieo2_around_is(i,eo,3)
+!! jb=ieo2_around_is(i,eo,4)
+!! jm=nn(i, eo, 2, BWD)
+!! do s1=1,4; do s2=1,4
+!! if (proj_1_p_gamma2(s1,s2) /=0) then
+!! do col1=1,3; do col2=1,3
+!! mat3(col1,s1,is,col2,s2,jj,it)=mat3(col1,s1,is,col2,s2,jj,it) -kappa* gauge(1)%u(col1,col2, i, eo,2) *proj_1_p_gamma2(s1,s2)
+!! mat3(col1,s1,is,col2,s2,jb,it)=mat3(col1,s1,is,col2,s2,jb,it) -kappa*conjg(gauge(1)%u(col2,col1, jm,1-eo,2))*proj_1_m_gamma2(s1,s2)
+!! enddo; enddo
+!! endif
+!! enddo; enddo
+!! !
+!! ! z-dir
+!! !
+!! jj=ieo2_around_is(i,eo,5)
+!! jb=ieo2_around_is(i,eo,6)
+!! jm=nn(i, eo, 3, BWD)
+!! do s1=1,4; do s2=1,4
+!! if (proj_1_p_gamma3(s1,s2) /=0) then
+!! do col1=1,3; do col2=1,3
+!! mat3(col1,s1,is,col2,s2,jj,it)=mat3(col1,s1,is,col2,s2,jj,it) -kappa* gauge(1)%u(col1,col2, i, eo,3) *proj_1_p_gamma3(s1,s2)
+!! mat3(col1,s1,is,col2,s2,jb,it)=mat3(col1,s1,is,col2,s2,jb,it) -kappa*conjg(gauge(1)%u(col2,col1, jm,1-eo,3))*proj_1_m_gamma3(s1,s2)
+!! enddo; enddo
+!! endif
+!! enddo; enddo
+!! !
+!! ! t-dir
+!! !
+!! jj=ieo2_around_is(i,eo,7)
+!! jb=ieo2_around_is(i,eo,8)
+!! jm=nn(i, eo, 4, BWD)
+!! do s1=1,4; do s2=1,4
+!! if (proj_1_m_gamman(s1,s2) /=0) then
+!! do col1=1,3; do col2=1,3
+!! matt(col1,s1,is,col2,s2,jj,it)=matt(col1,s1,is,col2,s2,jj,it) -kappa* gauge(2)%u(col1,col2, i, eo,4) *proj_1_m_gamman(s1,s2)
+!! enddo; enddo
+!! endif
+!! if (proj_1_p_gamman(s1,s2) /=0) then
+!! do col1=1,3; do col2=1,3
+!! matt(col1,s1,is,col2,s2,jb,it+nt)=matt(col1,s1,is,col2,s2,jb,it+nt) -kappa*conjg(gauge(2)%u(col2,col1, jm,1-eo,4))*proj_1_p_gamman(s1,s2)
+!! enddo; enddo
+!! endif
+!! enddo; enddo
+ enddo
+ enddo
+ endif
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine init_dirac_matrix()
+ use module_dirac_matrix
+ use module_lattice
+ use module_vol
+ implicit none
+ integer :: i, eo, ll(4)
+
+ if (.not. associated(ieo2_around_i)) then
+ allocate(ieo2_around_i(volh,0:1, 0:8))
+ allocate(ieo2_around_is(volh,0:1, 0:8))
+ allocate(ieo2_around_it(volh,0:1, 0:8))
+ proj_1_m_gamma1=0
+ proj_1_p_gamma1=0
+ proj_1_m_gamma2=0
+ proj_1_p_gamma2=0
+ proj_1_m_gamma3=0
+ proj_1_p_gamma3=0
+ proj_1_m_gammac=0
+ proj_1_p_gammac=0
+ proj_1_m_gamman=0
+ proj_1_p_gamman=0
+
+ do i=1,4
+ proj_1_m_gamma1(i,i)=ONE
+ proj_1_p_gamma1(i,i)=ONE
+ proj_1_m_gamma2(i,i)=ONE
+ proj_1_p_gamma2(i,i)=ONE
+ proj_1_m_gamma3(i,i)=ONE
+ proj_1_p_gamma3(i,i)=ONE
+ proj_1_m_gammac(i,i)=ONE
+ proj_1_p_gammac(i,i)=ONE
+ enddo
+
+ proj_1_m_gamman(3,3)=TWO
+ proj_1_m_gamman(4,4)=TWO
+ proj_1_p_gamman(1,1)=TWO
+ proj_1_p_gamman(2,2)=TWO
+
+ proj_1_m_gamma1(1,4)=cmplx(ZERO,ONE)
+ proj_1_m_gamma1(2,3)=cmplx(ZERO,ONE)
+ proj_1_m_gamma1(3,2)=cmplx(ZERO,-ONE)
+ proj_1_m_gamma1(4,1)=cmplx(ZERO,-ONE)
+ proj_1_p_gamma1(1,4)=cmplx(ZERO,-ONE)
+ proj_1_p_gamma1(2,3)=cmplx(ZERO,-ONE)
+ proj_1_p_gamma1(3,2)=cmplx(ZERO,ONE)
+ proj_1_p_gamma1(4,1)=cmplx(ZERO,ONE)
+
+ proj_1_m_gamma2(1,4)= ONE
+ proj_1_m_gamma2(2,3)=-ONE
+ proj_1_m_gamma2(3,2)=-ONE
+ proj_1_m_gamma2(4,1)= ONE
+ proj_1_p_gamma2(1,4)=-ONE
+ proj_1_p_gamma2(2,3)= ONE
+ proj_1_p_gamma2(3,2)= ONE
+ proj_1_p_gamma2(4,1)=-ONE
+
+ proj_1_m_gamma3(1,3)=cmplx(ZERO, ONE)
+ proj_1_m_gamma3(2,4)=cmplx(ZERO,-ONE)
+ proj_1_m_gamma3(3,1)=cmplx(ZERO,-ONE)
+ proj_1_m_gamma3(4,2)=cmplx(ZERO, ONE)
+ proj_1_p_gamma3(1,3)=cmplx(ZERO,-ONE)
+ proj_1_p_gamma3(2,4)=cmplx(ZERO, ONE)
+ proj_1_p_gamma3(3,1)=cmplx(ZERO, ONE)
+ proj_1_p_gamma3(4,2)=cmplx(ZERO,-ONE)
+
+ proj_1_m_gammac(1,3)=-ONE
+ proj_1_m_gammac(2,4)=-ONE
+ proj_1_m_gammac(3,1)= ONE
+ proj_1_m_gammac(4,2)= ONE
+ proj_1_p_gammac(1,3)= ONE
+ proj_1_p_gammac(2,4)= ONE
+ proj_1_p_gammac(3,1)=-ONE
+ proj_1_p_gammac(4,2)=-ONE
+
+
+ do eo=EVEN, ODD
+ do i=1, volh
+ call i2xyzt(i, eo, ll)
+ ieo2_around_i(i,eo,0)= 1 + ll(1) + ll(2)*nx + ll(3)*nx*ny + ll(4)*nx*ny*nz
+ ieo2_around_is(i,eo,0)= 1 + ll(1) + ll(2)*nx + ll(3)*nx*ny
+ ieo2_around_it(i,eo,0)= 1 + ll(4)
+
+ call ieo_offset_global(i, eo, 1, FWD, ieo2_around_i(i,eo,1), ieo2_around_is(i,eo,1), ieo2_around_it(i,eo,1))
+ call ieo_offset_global(i, eo, 1, BWD, ieo2_around_i(i,eo,2), ieo2_around_is(i,eo,2), ieo2_around_it(i,eo,2))
+ call ieo_offset_global(i, eo, 2, FWD, ieo2_around_i(i,eo,3), ieo2_around_is(i,eo,3), ieo2_around_it(i,eo,3))
+ call ieo_offset_global(i, eo, 2, BWD, ieo2_around_i(i,eo,4), ieo2_around_is(i,eo,4), ieo2_around_it(i,eo,4))
+ call ieo_offset_global(i, eo, 3, FWD, ieo2_around_i(i,eo,5), ieo2_around_is(i,eo,5), ieo2_around_it(i,eo,5))
+ call ieo_offset_global(i, eo, 3, BWD, ieo2_around_i(i,eo,6), ieo2_around_is(i,eo,6), ieo2_around_it(i,eo,6))
+ call ieo_offset_global(i, eo, 4, FWD, ieo2_around_i(i,eo,7), ieo2_around_is(i,eo,7), ieo2_around_it(i,eo,7))
+ call ieo_offset_global(i, eo, 4, BWD, ieo2_around_i(i,eo,8), ieo2_around_is(i,eo,8), ieo2_around_it(i,eo,8))
+ enddo
+ enddo
+
+ endif
+
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine ieo_offset_global(i, eo , dir, fb, i4, i3, it)
+ use module_function_decl
+ use module_lattice
+ use module_nnpe
+ use module_nn
+ use module_vol
+ implicit none
+ integer, intent(in) :: i, eo, dir, fb
+ integer, intent(out):: i4, i3, it
+ integer :: j, ll(4), pe(4), ip
+ integer, save :: nxy, nxyz, count=0
+
+ if (count==0) then
+ nxy = nx * ny
+ nxyz= nxy * nz
+ count=-1
+ endif
+
+ pe = 0
+ j = nn(i, eo, dir, fb)
+ call i2xyzt(j, 1-eo, ll)
+
+ if ( j > volh ) then
+ if ( ll(dir) == -1 ) then
+ pe(dir) = -1
+ ll(dir) = n(dir)-1
+ elseif( ll(dir) == n(dir) ) then
+ pe(dir) = 1
+ ll(dir) = 0
+ endif
+ endif
+
+ ip=nnpe( pe(1), pe(2), pe(3), pe(4))
+
+ it = 1 + ll(4)
+ i3 = 1 + ll(1) + ll(2) * nx + ll(3) * nxy
+ i4 = i3+ ll(4) * nxyz
+
+ i3 = i3 + ip * nxyz
+ i4 = i4 + ip * vol
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine compare_sc(in1, in2, size)
+ use module_function_decl
+ implicit none
+ integer :: i, size
+ REAL :: in1(size), in2(size), res, tmp
+
+ res=0
+ do i=1, size
+ tmp=(in1(i)-in2(i))**2
+ res=res+tmp
+ if (tmp > 0.00001)write(*,*)i, tmp,in1(i),in2(i)
+ enddo
+ res=global_sum(res)
+ call stderr2_real("vector difference",1,res)
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine sceo2sc(out, in_e, in_o)
+ use module_lattice
+ use module_vol
+ implicit none
+ integer :: id, ix, iy, iz, it, i, ii, j(4), spin, col
+
+ SPINCOL_FIELD :: in_e, in_o
+ COMPLEX :: out(3,4,vol)
+ integer, external :: std_xyzt2i, e_o
+
+ i=0
+ do it=0,nt-1
+ do iz=0,nz-1
+ do iy=0,ny-1
+ do ix=0,nx-1
+ i=i+1
+ j = (/ix, iy, iz, it/)
+ ii = std_xyzt2i(j)
+ if (e_o(j) == EVEN) then
+ do col=1, 3
+ do spin=1, 4
+ out(col,spin,i)=in_e(spin,col,ii)
+ enddo
+ enddo
+ else
+ do col=1, 3
+ do spin=1, 4
+ out(col,spin,i)=in_o(spin,col,ii)
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+end
+
+!===============================================================================
+! for checking
+!-------------------------------------------------------------------------------
+module phmc_read
+ integer, save :: ipeo=0
+
+ type su3_obj
+ complex(8) :: u(3,3)
+ end type
+
+ type gsf_eo_wg_obj
+ type(su3_obj) :: s(0:2,0:5,0:5,0:5)
+ integer :: ieo,idummy(3)
+ end type
+
+ type gvf_eo_wg_obj
+ type(gsf_eo_wg_obj) :: mu(4)
+ integer :: ieo,idummy(3)
+ end type
+
+ type gvf_wg_obj
+ type(gvf_eo_wg_obj) :: eo(0:1)
+ end type
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine read_phmc_config()
+ use phmc_read
+ use module_vol
+ use module_field
+ implicit none
+ type(gvf_wg_obj) :: phmc_u
+ integer :: ix, iy, iz, it, ieo, imu, j(4), itb, jmu(4) , ee, jj, ic,jc
+ integer :: ntx, nty, ntz, ntt
+ integer :: ndx, ndy, ndz, ndt
+ REAL :: plq, tmp
+ GAUGE_FIELD ::u
+ REAL, external :: sg
+ integer, external :: std_xyzt2i, e_o
+
+ write(*,*)"read_phmc_config: start"
+
+ open(40,file="config.x0y0z0",status='unknown',form='unformatted')
+ write(*,*)"read_phmc_config: open config.x0y0z0"
+
+ read(40)phmc_u
+ write(*,*)"read_phmc_config: have read config.x0y0z0"
+
+ read(40)NTX,NTY,NTZ,NTT
+ read(40)NDX,NDY,NDZ
+ read(40)plq
+
+ jmu(1)=4
+ jmu(2)=3
+ jmu(3)=2
+ jmu(4)=1
+
+
+ do imu = 1,4
+ do it=1,4
+ itb=it/2
+ do iz=1,4
+ do iy=1,4
+ do ix=1,4
+ ieo=mod(ix + iy + iz + it, 2)
+ j=(/ ix-1 , iy-1, iz-1, it-1/)
+ jj=std_xyzt2i(j)
+ ee=e_o(j)
+ u(:,:, jj ,ee, imu )=phmc_u%eo(ieo)%mu(imu)%s(itb,iz,iy,ix)%u
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+
+ gauge(1)%u=u
+
+ call xbound_g_field(gauge(1)%u)
+ call d_g_init(gauge(1)%u)
+ call conf_check(gauge(1)%u)
+
+ !!call conf_hot(gauge(1)%u)
+ tmp=sg(gauge(1)%u)
+ write(*,*)"plaq value calculated by bqcd", ONE - tmp / (SIX * volume)
+
+end
+
+!===============================================================================
diff --git a/src/measure/gamma.F90 b/src/measure/gamma.F90
new file mode 100644
index 0000000000000000000000000000000000000000..ec7ec0a262ab18a68d84c9ae411c59ff3cc52f99
--- /dev/null
+++ b/src/measure/gamma.F90
@@ -0,0 +1,295 @@
+!===============================================================================
+!
+! gamma.F90
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2007 Yoshifumi Nakamura
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+# include "defs.h"
+# include "gamma.h"
+
+!-------------------------------------------------------------------------------
+module gamma
+ implicit none
+ integer, parameter :: ngop=20
+
+ type gamma_matrix
+ complex(8) :: c(4,4)
+ end type
+ type(gamma_matrix), save :: gamma_op(ngop)
+
+ logical, save :: ginit=.false.
+
+
+ integer, dimension(4,4), save :: igamma
+ COMPLEX, dimension(4,4), save :: zgamma
+
+end module gamma
+
+!-------------------------------------------------------------------------------
+subroutine gamma_init()
+ use gamma
+ implicit none
+ complex(8), dimension(4,4) :: g1,g2,g3,g4, gc
+ integer :: i, j
+ COMPLEX :: i_times, c
+ i_times(c) = cmplx(-aimag(c), real(c), kind = RKIND)
+
+ if (ginit) return
+ DEBUG2S("Start: gamma_init")
+
+ g1=ZERO
+ g2=ZERO
+ g3=ZERO
+ g4=ZERO
+ gc=ZERO
+
+ do i = 1, ngop
+ gamma_op(i)%c = ZERO
+ enddo
+
+ g1(1, 4) = cmplx(ZERO,-ONE)
+ g1(2, 3) = cmplx(ZERO,-ONE)
+ g1(3, 2) = cmplx(ZERO, ONE)
+ g1(4, 1) = cmplx(ZERO, ONE)
+ g2(1, 4) = -ONE
+ g2(2, 3) = ONE
+ g2(3, 2) = ONE
+ g2(4, 1) = -ONE
+ g3(1, 3) = cmplx(ZERO,-ONE)
+ g3(2, 4) = cmplx(ZERO, ONE)
+ g3(3, 1) = cmplx(ZERO, ONE)
+ g3(4, 2) = cmplx(ZERO,-ONE)
+ g4(1, 1) = ONE
+ g4(2, 2) = ONE
+ g4(3, 3) =-ONE
+ g4(4, 4) =-ONE
+ gc(1, 4) = ONE
+ gc(2, 3) = ONE
+ gc(3, 2) = ONE
+ gc(4, 1) = ONE
+
+
+#ifdef GAMMA_NOTATION_CHROMA
+ not yet
+#elif defined GAMMA_NOTATION_CHIRAL
+ not yet
+#elif defined GAMMA_NOTATION_DDHMC
+ not yet
+#elif defined GAMMA_NOTATION_BQCD
+ gamma_op(G1)%c= -g1
+ gamma_op(G2)%c= -g2
+ gamma_op(G3)%c= -g3
+ gamma_op(G0)%c= g4
+#endif
+
+ call spin_mul(g1,gamma_op(G1)%c, gamma_op(G2)%c)
+ call spin_mul(g2,gamma_op(G3)%c, gamma_op(G0)%c)
+ call spin_mul(gamma_op(G5)%c, g1, g2)
+
+ call spin_mul(gamma_op(G01)%c, gamma_op(G0)%c, gamma_op(G1)%c)
+ call spin_mul(gamma_op(G02)%c, gamma_op(G0)%c, gamma_op(G2)%c)
+ call spin_mul(gamma_op(G03)%c, gamma_op(G0)%c, gamma_op(G3)%c)
+
+ call spin_mul(gamma_op(G05)%c, gamma_op(G0)%c, gamma_op(G5)%c)
+ call spin_mul(gamma_op(G15)%c, gamma_op(G1)%c, gamma_op(G5)%c)
+ call spin_mul(gamma_op(G25)%c, gamma_op(G2)%c, gamma_op(G5)%c)
+ call spin_mul(gamma_op(G35)%c, gamma_op(G3)%c, gamma_op(G5)%c)
+
+ call spin_mul(gamma_op(G12)%c, gamma_op(G1)%c, gamma_op(G2)%c)
+ call spin_mul(gamma_op(G23)%c, gamma_op(G2)%c, gamma_op(G3)%c)
+ call spin_mul(gamma_op(G31)%c, gamma_op(G3)%c, gamma_op(G1)%c) !! = CG5
+
+ g1=HALF * (gamma_op(G2)%c + cmplx(ZERO, ONE) * gamma_op(G1)%c )
+ call spin_mul(g2, gamma_op(G02)%c, g1)
+ gamma_op(CGm)%c = - g2
+
+ gamma_op(UNP)%c = gamma_op(G0)%c
+ gamma_op(UNP)%c(1,1) = gamma_op(UNP)%c(1,1) + ONE
+ gamma_op(UNP)%c(2,2) = gamma_op(UNP)%c(2,2) + ONE
+ gamma_op(UNP)%c(3,3) = gamma_op(UNP)%c(3,3) + ONE
+ gamma_op(UNP)%c(4,4) = gamma_op(UNP)%c(4,4) + ONE
+ gamma_op(UNP)%c = gamma_op(UNP)%c * HALF
+
+ do i = 1, DIM
+ do j = 1, DIM
+ g1(i,j) = i_times(gamma_op(G35)%c(i,j))
+ enddo
+ enddo
+ g1(1,1) = g1(1,1) + ONE
+ g1(2,2) = g1(2,2) + ONE
+ g1(3,3) = g1(3,3) + ONE
+ g1(4,4) = g1(4,4) + ONE
+
+ call spin_mul(gamma_op(POL)%c, gamma_op(UNP)%c, g1)
+
+
+ call igamma_zgamma()
+ ginit=.true.
+
+ DEBUG2S("End: gamma_init")
+end
+
+!-------------------------------------------------------------------------------
+subroutine spin_mul(g1, g2, g3) ! g1 = g2 * g3
+ implicit none
+ complex(8), dimension(4,4) :: g1, g2, g3
+ integer :: i, j, k
+
+ g1=0
+ do i=1, 4
+ do j=1, 4
+ do k=1, 4
+ g1(i,j) = g1(i,j) + g2(i, k) * g3(k, j)
+ enddo
+ enddo
+ enddo
+end
+
+!-------------------------------------------------------------------------------
+COMPLEX function spintr(g)
+ implicit none
+ complex(8), dimension(4,4) :: g
+ integer :: i
+
+ spintr=0
+ do i=1, 4
+ spintr = spintr + g(i,i)
+ enddo
+end
+
+!===============================================================================
+! C= gamma2 gamma4
+! gamma- = (gamma2 + i gamma1)/2
+!
+!
+! Definition used: ( 1 0 0 0 )
+! ( 0 0 0 0 )
+! Cgamma- = ( 0 0 1 0 )
+! ( 0 0 0 0 )
+!
+!
+subroutine cgmxcgmt(out, in) ! (Cgamma- * in Cgamma-)^T
+ implicit none
+ COMPLEX, dimension(4,4), intent(out) :: out
+ COMPLEX, dimension(4,4), intent(in) :: in
+
+ out(1,1) = in(1,1)
+ out(2,1) = ZERO
+ out(3,1) = in(1,3)
+ out(4,1) = ZERO
+
+ out(1,2) = ZERO
+ out(2,2) = ZERO
+ out(3,2) = ZERO
+ out(4,2) = ZERO
+
+ out(1,3) = in(3,1)
+ out(2,3) = ZERO
+ out(3,3) = in(3,3)
+ out(4,3) = ZERO
+
+ out(1,4) = ZERO
+ out(2,4) = ZERO
+ out(3,4) = ZERO
+ out(4,4) = ZERO
+
+end
+
+!-------------------------------------------------------------------------------
+!//
+!// copy from K.-I. Ishikawa's code
+!// This is same as BQCD gamma notation
+!//
+subroutine igamma_zgamma()
+ use gamma
+ implicit none
+ COMPLEX, parameter :: z1=(ONE, ZERO), zi=(ZERO, ONE)
+ integer :: mu
+
+ mu=1
+ igamma(1,mu) = 4
+ zgamma(1,mu) = -zi
+ igamma(2,mu) = 3
+ zgamma(2,mu) = -zi
+ igamma(3,mu) = 2
+ zgamma(3,mu) = zi
+ igamma(4,mu) = 1
+ zgamma(4,mu) = zi
+ mu=2
+ igamma(1,mu) = 4
+ zgamma(1,mu) = -z1
+ igamma(2,mu) = 3
+ zgamma(2,mu) = z1
+ igamma(3,mu) = 2
+ zgamma(3,mu) = z1
+ igamma(4,mu) = 1
+ zgamma(4,mu) = -z1
+ mu=3
+ igamma(1,mu) = 3
+ zgamma(1,mu) = -zi
+ igamma(2,mu) = 4
+ zgamma(2,mu) = zi
+ igamma(3,mu) = 1
+ zgamma(3,mu) = zi
+ igamma(4,mu) = 2
+ zgamma(4,mu) = -zi
+ mu=4
+ igamma(1,mu) = 1
+ zgamma(1,mu) = z1
+ igamma(2,mu) = 2
+ zgamma(2,mu) = z1
+ igamma(3,mu) = 3
+ zgamma(3,mu) = -z1
+ igamma(4,mu) = 4
+ zgamma(4,mu) = -z1
+
+end
+
+!-------------------------------------------------------------------------------
+!//
+!// copy from Dirk's T3E version
+!//
+subroutine g31xg31t(out, in) ! (G31 * in G31)^T
+ implicit none
+ COMPLEX, dimension(4,4), intent(out) :: out
+ COMPLEX, dimension(4,4), intent(in) :: in
+
+ out(1,1) = -in(2,2)
+ out(2,1) = in(2,1)
+ out(3,1) = -in(2,4)
+ out(4,1) = in(2,3)
+
+ out(1,2) = in(1,2)
+ out(2,2) = -in(1,1)
+ out(3,2) = in(1,4)
+ out(4,2) = -in(1,3)
+
+ out(1,3) = -in(4,2)
+ out(2,3) = in(4,1)
+ out(3,3) = -in(4,4)
+ out(4,3) = in(4,3)
+
+ out(1,4) = in(3,2)
+ out(2,4) = -in(3,1)
+ out(3,4) = in(3,4)
+ out(4,4) = -in(3,3)
+
+end
diff --git a/src/measure/make_source.F90 b/src/measure/make_source.F90
index 1b9f77790a141c6ee2fb36da10f7b63c6b1bdb98..de681826b26fe522b784f49282f30fe0a7a2fd5f 100644
--- a/src/measure/make_source.F90
+++ b/src/measure/make_source.F90
@@ -39,6 +39,8 @@ subroutine make_source(even, odd, sourcetype)
elseif (sourcetype == RANDOM_SOURCE) then
call ran_gauss_volh(NDIRAC * NCOL, even, HALF, EVEN)
call ran_gauss_volh(NDIRAC * NCOL, odd, HALF, ODD)
+ elseif (sourcetype == LOCAL_SOURCE) then
+!! call make_source_local(even, odd, src_at)
elseif (sourcetype == WALL_SOURCE) then
if (my_pe()==0) call warn("wall source called S=1, C=1, T=0")
call make_source_wall(1,1,0,even,odd)
@@ -48,6 +50,98 @@ subroutine make_source(even, odd, sourcetype)
end
+!-------------------------------------------------------------------------------
+subroutine make_source_local(even, odd, src_at)
+ use module_lattice
+ use module_vol
+ use module_function_decl
+ implicit none
+ integer :: coord(4), j(4)
+ integer :: it,iz,iy,ix,ii
+ integer, intent(in) :: src_at(4)
+ SPINCOL_FIELD, intent(out) :: even, odd
+ integer, external :: std_xyzt2i, e_o
+
+ call pe2coord(my_pe(), coord)
+ even = ZERO
+ odd = ZERO
+
+ it = src_at(4) - nt*coord(4)
+ iz = src_at(3) - nz*coord(3)
+ iy = src_at(2) - ny*coord(2)
+ ix = src_at(1) - nx*coord(1)
+
+ if ( 0<=it .and. it < nt .and. &
+ 0<=iz .and. iz < nz .and. &
+ 0<=iy .and. iy < ny .and. &
+ 0<=ix .and. ix < nx) then
+
+ j = (/ix, iy, iz, it/)
+ ii = std_xyzt2i(j)
+ if (e_o(j) == EVEN) then
+ even(:,:,ii) = ONE
+ else
+ odd(:,:,ii) = ONE
+ endif
+ endif
+end
+
+!-------------------------------------------------------------------------------
+subroutine make_quark_source(qeven,qodd, even, odd)
+ use module_vol
+ implicit none
+ integer :: is, ic, i
+ complex(8), dimension(4,4,3,3,volh), intent(out) :: qeven,qodd
+ SPINCOL_FIELD, intent(in) :: even, odd
+
+ do i = 1, volh
+ do ic = 1, 3
+ do is = 1, 4
+ qeven(is,is,ic,ic,i)= even(is,ic,i)
+ qodd( is,is,ic,ic,i)= odd(is,ic,i)
+ enddo
+ enddo
+ enddo
+end
+
+!-------------------------------------------------------------------------------
+subroutine get_quark_source(even, odd, qeven,qodd, is0, ic0)
+ use module_vol
+ implicit none
+ integer :: is, ic, i
+ integer, intent(in) :: is0, ic0
+ complex(8), dimension(4,4,3,3,volh), intent(in) :: qeven,qodd
+ SPINCOL_FIELD, intent(out) :: even, odd
+
+ do i = 1, volh
+ do ic = 1, 3
+ do is = 1, 4
+ even(is,ic,i) = qeven(is,is0,ic,ic0,i)
+ odd( is,ic,i) = qodd( is,is0,ic,ic0,i)
+ enddo
+ enddo
+ enddo
+end
+
+!-------------------------------------------------------------------------------
+subroutine put_quark_source(qeven,qodd, even, odd, is0, ic0)
+ use module_vol
+ implicit none
+ integer :: is, ic, i
+ integer, intent(in) :: is0, ic0
+ complex(8), dimension(4,4,3,3,volh), intent(out) :: qeven,qodd
+ SPINCOL_FIELD, intent(in) :: even, odd
+
+ do i = 1, volh
+ do ic = 1, 3
+ do is = 1, 4
+ qeven(is,is0,ic,ic0,i) = even(is,ic,i)
+ qodd( is,is0,ic,ic0,i) = odd( is,ic,i)
+ enddo
+ enddo
+ enddo
+end
+
!-------------------------------------------------------------------------------
subroutine make_source_wall(is, ic, src_t, even, odd)
use module_lattice
@@ -85,9 +179,8 @@ subroutine make_source_wall(is, ic, src_t, even, odd)
end
-
!-------------------------------------------------------------------------------
-subroutine make_source_0000(even, odd)
+subroutine make_source_0000(even, odd) !! for test
use module_vol
use module_function_decl
diff --git a/src/measure/phmc_read.F90 b/src/measure/phmc_read.F90
new file mode 100644
index 0000000000000000000000000000000000000000..c977227cfa3c443ed5066823eda8eddd7c06a9d9
--- /dev/null
+++ b/src/measure/phmc_read.F90
@@ -0,0 +1,169 @@
+!===============================================================================
+!
+! phmc_read.F90 - read phmc config
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2011 Yoshifumi Nakamura
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+# include "defs.h"
+
+!-------------------------------------------------------------------------------
+module phmc_read
+ integer, save :: ipeo=0
+
+ type su3_obj
+ complex(8) :: u(3,3)
+ end type
+
+ type gsf_eo_wg_obj
+ type(su3_obj) :: s(0:2,0:5,0:5,0:5)
+ integer :: ieo,idummy(3)
+ end type
+
+ type gvf_eo_wg_obj
+ type(gsf_eo_wg_obj) :: mu(4)
+ integer :: ieo,idummy(3)
+ end type
+
+ type gvf_wg_obj
+ type(gvf_eo_wg_obj) :: eo(0:1)
+ end type
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine read_phmc_config()
+ use phmc_read
+ use module_vol
+ use module_field
+ implicit none
+ type(gvf_wg_obj) :: phmc_u
+ integer :: ix, iy, iz, it, ieo, imu, j(4), itb, jmu(4) , ee, jj, ic,jc
+ integer :: ntx, nty, ntz, ntt
+ integer :: ndx, ndy, ndz, ndt
+ REAL :: plq, tmp
+ GAUGE_FIELD ::u
+ REAL, external :: sg
+ integer, external :: std_xyzt2i, e_o
+
+ write(*,*)"read_phmc_config: start"
+
+ open(40,file="config.x0y0z0",status='unknown',form='unformatted')
+ write(*,*)"read_phmc_config: open config.x0y0z0"
+
+ read(40)phmc_u
+ write(*,*)"read_phmc_config: have read config.x0y0z0"
+
+ read(40)NTX,NTY,NTZ,NTT
+ read(40)NDX,NDY,NDZ
+ read(40)plq
+
+ jmu(1)=4
+ jmu(2)=3
+ jmu(3)=2
+ jmu(4)=1
+
+ do imu = 1,4
+ do it=1,4
+ itb=it/2
+ do iz=1,4
+ do iy=1,4
+ do ix=1,4
+ ieo=mod(ix + iy + iz + it, 2)
+ j=(/ ix-1 , iy-1, iz-1, it-1/)
+ jj=std_xyzt2i(j)
+ ee=e_o(j)
+ u(:,:, jj ,ee, imu )=phmc_u%eo(ieo)%mu(imu)%s(itb,iz,iy,ix)%u
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+
+ gauge(1)%u=u
+
+ call xbound_g_field(gauge(1)%u)
+ call d_g_init(gauge(1)%u)
+ call conf_check(gauge(1)%u)
+
+ !!call conf_hot(gauge(1)%u)
+ tmp=sg(gauge(1)%u)
+ write(*,*)"plaq value calculated by bqcd", ONE - tmp / (SIX * volume)
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine read_phmc_sf_config()
+ use module_vol
+ use module_field
+ implicit none
+ integer :: ix, iy, iz, it, ieo, imu, j(4), itb, jmu(4) , ee, jj, ic,jc
+ integer :: ntx, nty, ntz, ntt
+ integer :: ndx, ndy, ndz, ndt
+ COMPLEX, dimension(3,3,0:4,4,4,4,4) :: ue, uo
+ REAL :: plq, tmp
+ GAUGE_FIELD ::u
+ REAL, external :: sg
+ integer, external :: std_xyzt2i, e_o
+
+ write(*,*)"read_phmc_sf_config: start"
+
+ open(40,file="config.x0y0z0",status='unknown',form='unformatted')
+ write(*,*)"read_phmc_config: open config.x0y0z0"
+
+ read(40)ue, uo
+ write(*,*)"read_phmc_config: have read config.x0y0z0"
+
+ jmu(1)=4
+ jmu(2)=3
+ jmu(3)=2
+ jmu(4)=1
+
+ do imu = 1,4
+ do it=1,8
+ itb=it/2
+ do iz=1,4
+ do iy=1,4
+ do ix=1,4
+ ieo=mod(ix + iy + iz + it, 2)
+ j=(/ ix-1 , iy-1, iz-1, it-1/)
+ jj=std_xyzt2i(j)
+ ee=e_o(j)
+ if (ieo == 0) u(:,:, jj ,ee, imu ) = ue(:,:,itb,iz,iy,ix,imu)
+ if (ieo == 1) u(:,:, jj ,ee, imu ) = uo(:,:,itb,iz,iy,ix,imu)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+
+ gauge(1)%u=u
+
+ call xbound_g_field(gauge(1)%u)
+ call d_g_init(gauge(1)%u)
+ call conf_check(gauge(1)%u)
+
+ !!call conf_hot(gauge(1)%u)
+ tmp=sg(gauge(1)%u)
+ write(*,*)"plaq value calculated by bqcd", ONE - tmp / (SIX * volume)
+ call flush(6)
+end
+
+!===============================================================================
diff --git a/src/measure/ppp.F90 b/src/measure/ppp.F90
deleted file mode 100644
index c7eb7d86d23269b56f35333452c6712d16d28f94..0000000000000000000000000000000000000000
--- a/src/measure/ppp.F90
+++ /dev/null
@@ -1,93 +0,0 @@
-!===============================================================================
-!
-! ppp.F90
-!
-!-------------------------------------------------------------------------------
-!
-! Copyright (C) 2007 Yoshifumi Nakamura
-!
-! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
-!
-! BQCD is free software: you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation, either version 3 of the License, or
-! (at your option) any later version.
-!
-! BQCD is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License
-! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
-!
-!-------------------------------------------------------------------------------
-# include "defs.h"
-# include "defs_imp_2p1.h"
-
-!-------------------------------------------------------------------------------
-subroutine ppp(tmp,tmp_e,tmp_o,name)
-
- use module_function_decl
- use module_lattice_io
- use module_decomp
- use module_vol
- implicit none
- SPINCOL_FIELD,intent(in) :: tmp_e,tmp_o
- SPINCOL_FIELD_XYZT,intent(out) :: tmp
-
- character(len=3) :: name
- integer, dimension(DIM) :: j
- integer :: x, y, z, t, i, eo, mu, c
- integer, external :: std_xyzt2i, e_o
-
- do t = 0, NT - 1
- do z = 0, NZ - 1
- do y = 0, NY - 1
- do x = 0, NX - 1
-
- j = (/x, y, z, t/)
-
- i = std_xyzt2i(j)
- eo = e_o(j)
-
- do mu = 1, DIM
- do c = 1, NCOL
-! if (action == "read") then
-! u(c1, c2, i, eo, mu) = u_io(c1, c2, mu, x, y, z, t)
-! else
- if (eo == EVEN )tmp(mu, c, x, y, z, t) = tmp_e(mu, c, i)
- if (eo == ODD )tmp(mu, c, x, y, z, t) = tmp_o(mu, c, i)
-! endif
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
-
-if (my_pe()==0)then
- do t = 0, 0!NT - 1
- do z = 0, 0!NZ - 1
- do y = 0, 0!NY - 1
- do x = 0, 0!NX - 1
- do c = 1, 3
- do mu = 1, 4
- if (Re(tmp(mu,c,x,y,z,t)) /= ZERO .or.&
- Im(tmp(mu,c,x,y,z,t)) /= ZERO )&
- write(*,100)"%%%",name,&
- my_pe(),mu,c,x,y,z,t, &
- Re(tmp(mu,c,x,y,z,t)),Im(tmp(mu,c,x,y,z,t))
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
-endif
-
-100 format (1x, 2a, 7i3, 2ES17.7)
-
-end
-
-!===============================================================================
diff --git a/src/measure/reduction_space.F90 b/src/measure/reduction_space.F90
deleted file mode 100644
index 5a70c9d49e10a30033e3798ab2f954037fbf5fdd..0000000000000000000000000000000000000000
--- a/src/measure/reduction_space.F90
+++ /dev/null
@@ -1,64 +0,0 @@
-!===============================================================================
-!
-! reduction_space.F90
-!
-!-------------------------------------------------------------------------------
-!
-! Copyright (C) 2007 Yoshifumi Nakamura
-!
-! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
-!
-! BQCD is free software: you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation, either version 3 of the License, or
-! (at your option) any later version.
-!
-! BQCD is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License
-! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
-!
-!-------------------------------------------------------------------------------
-# include "defs.h"
-
-!-------------------------------------------------------------------------------
-subroutine reduction_eo_std(out,in_e,in_o)
-
- use module_decomp
- use module_vol
- implicit none
- COMPLEX, dimension(volh), intent(in) :: in_e,in_o
- COMPLEX, dimension(vol ), intent(out) :: out
-
- integer, dimension(DIM) :: j
- integer :: x, y, z, t, i, eo, icount
- integer :: nx, ny, nz, nt
- integer, external :: std_xyzt2i, e_o
-
- nx = decomp%std%N(1)
- ny = decomp%std%N(2)
- nz = decomp%std%N(3)
- nt = decomp%std%N(4)
-
- icount = 1
- do t = 0, nt - 1
- do z = 0, nz - 1
- do y = 0, ny - 1
- do x = 0, nx - 1
- j = (/x, y, z, t/)
- i = std_xyzt2i(j)
- eo = e_o(j)
- if (eo == EVEN )out(icount) = in_e(i)
- if (eo == ODD )out(icount) = in_o(i)
- icount = icount + 1
- enddo
- enddo
- enddo
- enddo
-
-end
-
-!===============================================================================
diff --git a/src/measure/schr_pcac.F90 b/src/measure/schr_pcac.F90
new file mode 100644
index 0000000000000000000000000000000000000000..dda0d08d4f5f986bdebc59ab4ae20acd45cf6b16
--- /dev/null
+++ b/src/measure/schr_pcac.F90
@@ -0,0 +1,295 @@
+!===============================================================================
+!
+! schr_pcac.F90 - pcac for SF
+!
+!-------------------------------------------------------------------------------
+!
+! Copyright (C) 2011 Yoshifumi Nakamura
+!
+! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+!
+! BQCD is free software: you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation, either version 3 of the License, or
+! (at your option) any later version.
+!
+! BQCD is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+!
+!-------------------------------------------------------------------------------
+# include "defs.h"
+
+!-------------------------------------------------------------------------------
+subroutine schr_pcac(job,traj)
+ use module_action
+ use module_input
+ use hadron_corr
+ use module_vol
+ use module_switches
+ use module_lattice
+ use module_function_decl
+ implicit none
+ integer, intent(in) :: job, traj
+ integer :: mid, it
+ REAL, dimension(lt) :: fa0, fp0, fa1, fp1
+ logical, save :: fileopen = .false.
+ character(len = 15) :: filename
+
+ if (.not. switches%boundary_sf) return
+ DEBUG2S("Start: schr_pcac")
+
+ call gamma_init()
+ mid = action%fermi( input%hmc_mpf_mass )%mid1
+
+ allocate(qprop(1))
+ allocate(qprop(1)%g(4,4,3,3,volh, EVEN:ODD))
+ call get_qprop_schrpcac(qprop(1), mid, 0) ; call fafp(qprop(1), fa0, fp0)
+ call get_qprop_schrpcac(qprop(1), mid, 1) ; call fafp(qprop(1), fa1, fp1)
+ if (.not. fileopen) then
+ write(filename, "(a, i6.6)" ) "fAfPhist.", job
+ open(60, file = filename, action = "write")
+ fileopen = .true.
+ endif
+
+ if (my_pe()==0) then
+!! do it = 1, lt
+!! write(60,'(I6,I3,4E24.16)')traj, it,-fa0( it ), fp0( it ), &
+!! fa1(lt-it+1), fp1(lt-it+1)
+!! enddo
+ do it = 1, lt-1
+ write(60,'(I6,I3,4E24.16)')traj, it+1,-fa0( it+1), fp0( it+1), &
+ fa1(lt-it+1), fp1(lt-it+1)
+ enddo
+ endif
+ deallocate(qprop)
+
+ DEBUG2S("End: schr_pcac")
+end
+
+!-------------------------------------------------------------------------------
+subroutine fafp(qprop0, fa, fp)
+ use gamma
+ use hadron_corr
+ use module_lattice
+ use module_function_decl
+ implicit none
+ type(quark_prop), intent(in) :: qprop0
+ REAL, intent(out) :: fa(0:lt-1), fp(0:lt-1)
+ integer :: is0, is1, is2, ic1, ic2, ix,iy,iz,it, j(4), coord(4), ii, eo
+ COMPLEX :: ctmpa, ctmpp, zgm
+ integer, external :: e_o, std_xyzt2i
+
+ call pe2coord(my_pe(), coord)
+ fa = ZERO
+ fp = ZERO
+
+ do it = 0, nt-1
+ ctmpa = ZERO
+ ctmpp = ZERO
+ do is1 = 1, 4
+ is0 =igamma(is1,4)
+ zgm =zgamma(is1,4)
+ do is2 = 1, 4
+ do iz = 0, nz-1
+ do iy = 0, ny-1
+ do ix = 0, nx-1
+ j = (/ix, iy, iz, it/)
+ ii = std_xyzt2i(j)
+ eo = e_o(j)
+ do ic1 = 1, 3
+ do ic2 = 1, 3
+ ctmpa = ctmpa + zgm * qprop0%g(is0,is2,ic1,ic2,ii,eo) &
+ * conjg(qprop0%g(is1,is2,ic1,ic2,ii,eo))
+ ctmpp = ctmpp + qprop0%g(is1,is2,ic1,ic2,ii,eo) &
+ * conjg(qprop0%g(is1,is2,ic1,ic2,ii,eo))
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo ! is2
+ enddo ! is1
+ fa( it + nt*coord(4) ) = ctmpa
+ fp( it + nt*coord(4) ) = ctmpp
+ enddo
+
+ call global_sum_vec(lt, fa)
+ call global_sum_vec(lt, fp)
+ fa=fa/dble(2*lx*ly*lz)
+ fp=fp/dble(2*lx*ly*lz)
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine get_qprop_schrpcac(qprop0, mid, prime)
+ use hadron_corr
+ use module_vol
+ implicit none
+ type(quark_prop), intent(out) :: qprop0
+ integer, intent(in) :: mid, prime
+ SPINCOL_FIELD :: inp_e, inp_o, out_e, out_o
+ integer :: is, ic
+
+ DEBUG2S("Start: get_qprop_schrpcac")
+ call init_quark(mid)
+ do ic = 1, 3
+ do is = 1, 4
+ call make_source_schrpcac(inp_e, inp_o, is, ic, prime)
+ call solve(mid, out_e, out_o, inp_e, inp_o)
+ call put_quark_source(qprop0%g(1,1,1,1,1,0), &
+ qprop0%g(1,1,1,1,1,1), out_e, out_o, is, ic)
+ enddo
+ enddo
+ DEBUG2S("End: get_qprop_schrpcac")
+end
+
+!-------------------------------------------------------------------------------
+subroutine make_source_schrpcac(even, odd, is, ic, prime)
+ use module_vol
+ use module_field
+ use module_stout_field
+ implicit none
+ integer, intent(in) :: is,ic,prime
+ SPINCOL_FIELD, intent(out) :: even, odd
+
+ if (gauge(2)%sid == 0) then
+ call make_source_schrpcac_u(even, odd, is, ic, prime, gauge(1)%u)
+ else
+ call make_source_schrpcac_u(even, odd, is, ic, prime, stout(1)%iter(stout(1)%n)%u)
+ endif
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine make_source_schrpcac_u(even, odd, is, ic, prime, u)
+ use module_lattice
+ use module_vol
+ use module_function_decl
+ use module_nn
+ implicit none
+ integer :: coord(4), j(4)
+ integer :: it,iz,iy,ix,ii,jj,eo,src_t
+ integer, intent(in) :: is,ic,prime
+ SPINCOL_FIELD, intent(out) :: even, odd
+ GAUGE_FIELD, intent(in) :: u
+ integer, external :: std_xyzt2i, e_o
+
+ DEBUG2S("Start: make_source_schrpcac_u")
+
+ call pe2coord(my_pe(), coord)
+ even = ZERO
+ odd = ZERO
+ select case (prime)
+ case (0) ! for [\psi(x)\zeta(y)]
+ if (is == 3 .or. is == 4) return
+ src_t = 1
+ it = src_t - nt*coord(4)
+ if ( 0<=it .and. it < nt) then
+ do iz=0,nz-1
+ do iy=0,ny-1
+ do ix=0,nx-1
+ j = (/ix, iy, iz, it/)
+ ii = std_xyzt2i(j)
+ eo = e_o(j)
+ jj = nn(ii, eo, 4, BWD)
+ if (eo == EVEN) then
+ even(is,:,ii) = dconjg(u(ic, :, jj, 1-eo, 4))
+ else
+ odd(is,:,ii) = dconjg(u(ic, :, jj, 1-eo, 4))
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ case (1) ! for [\psi(x)\zeta'(y)]
+ if (is == 1 .or. is == 2) return
+ src_t = lt - 1
+ it = src_t - nt*coord(4)
+ if ( 0<=it .and. it < nt) then
+ do iz=0,nz-1
+ do iy=0,ny-1
+ do ix=0,nx-1
+ j = (/ix, iy, iz, it/)
+ ii = std_xyzt2i(j)
+ eo = e_o(j)
+ if (eo == EVEN) then
+ even(is,:,ii) = u(:, ic, ii, eo, 4)
+ else
+ odd(is,:,ii) = u(:, ic, ii, eo, 4)
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ case default
+ call die("make_source_schrpcac_u: Invalid prime")
+ end select
+
+ DEBUG2S("End: make_source_schrpcac_u")
+end
+
+!===============================================================================
+! for checking
+!-------------------------------------------------------------------------------
+subroutine read_phmc_sf_config()
+ use module_vol
+ use module_field
+ implicit none
+ integer :: ix, iy, iz, it, ieo, imu, j(4), itb, jmu(4) , ee, jj, ic,jc
+ integer :: ntx, nty, ntz, ntt
+ integer :: ndx, ndy, ndz, ndt
+ COMPLEX, dimension(3,3,0:4,4,4,4,4) :: ue, uo
+ REAL :: plq, tmp
+ GAUGE_FIELD ::u
+ REAL, external :: sg
+ integer, external :: std_xyzt2i, e_o
+
+ write(*,*)"read_phmc_sf_config: start"
+
+ open(40,file="config.x0y0z0",status='unknown',form='unformatted')
+ write(*,*)"read_phmc_config: open config.x0y0z0"
+
+ read(40)ue, uo
+ write(*,*)"read_phmc_config: have read config.x0y0z0"
+
+ jmu(1)=4
+ jmu(2)=3
+ jmu(3)=2
+ jmu(4)=1
+
+ do imu = 1,4
+ do it=1,8
+ itb=it/2
+ do iz=1,4
+ do iy=1,4
+ do ix=1,4
+ ieo=mod(ix + iy + iz + it, 2)
+ j=(/ ix-1 , iy-1, iz-1, it-1/)
+ jj=std_xyzt2i(j)
+ ee=e_o(j)
+ if (ieo == 0) u(:,:, jj ,ee, imu ) = ue(:,:,itb,iz,iy,ix,imu)
+ if (ieo == 1) u(:,:, jj ,ee, imu ) = uo(:,:,itb,iz,iy,ix,imu)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+
+ gauge(1)%u=u
+
+ call xbound_g_field(gauge(1)%u)
+ call d_g_init(gauge(1)%u)
+ call conf_check(gauge(1)%u)
+
+ !!call conf_hot(gauge(1)%u)
+ tmp=sg(gauge(1)%u)
+ write(*,*)"plaq value calculated by bqcd", ONE - tmp / (SIX * volume)
+!! call flush(6)
+end
+
+!===============================================================================
diff --git a/src/measure/traces.F90 b/src/measure/traces.F90
index 52d1acc071dbeb9f188bf9bd76b451a2b57dc1c1..63ca56dc067216eb74f086bd802dc1d2260f26f9 100644
--- a/src/measure/traces.F90
+++ b/src/measure/traces.F90
@@ -194,7 +194,7 @@ subroutine eo_solve(mid, out_e, out_o, in_e, in_o) ! solves: M out = in
SPINCOL_FIELD, intent(in) :: in_e, in_o
P_SPINCOL_FIELD, save :: tmp
- REAL :: a, b, res
+ REAL :: a, b, res, fac1, fac2
integer :: iterations, cid
DEBUG2S("Start: solve_eo")
@@ -204,8 +204,13 @@ subroutine eo_solve(mid, out_e, out_o, in_e, in_o) ! solves: M out = in
b = action%mtilde(mid)%kappa / (ONE + action%mtilde(mid)%h**2)
cid = action%mtilde(mid)%cid
-! in : xi
-! out : phi
+ fac1=exp( chemi)
+ fac2=exp(-chemi)
+ if (chemi /= 0)call emuu4(gauge(2)%u, fac1, fac2, .false.)
+
+
+ ! in : xi
+ ! out : phi
! (Moo)^{-1} xi_o
if (action%mtilde(mid)%cswkappa /= ZERO) then
@@ -221,8 +226,9 @@ subroutine eo_solve(mid, out_e, out_o, in_e, in_o) ! solves: M out = in
! xi_e = xi_e - Meo Moo^-1 xi_o
call d(se, so, out_e, out_o, gauge(2)%u)
call sc_xpby(out_e, in_e, b)
+ if (chemi /= 0)call emuu4(gauge(2)%u, ONE, ONE, .false.)
-! phi_e = phi_e = (\tilde{M}^{\dagger}\tilde{M})^{-1} \tilde{M}^{\dagger} xi_e
+ ! phi_e = phi_e = (\tilde{M}^{\dagger}\tilde{M})^{-1} \tilde{M}^{\dagger} xi_e
#ifdef OMTDTD
if (action%mtilde(mid)%cswkappa /= ZERO) then
call clover_mult_ao(clover(cid)%i(1,1,se), out_e, volh)
@@ -234,19 +240,22 @@ subroutine eo_solve(mid, out_e, out_o, in_e, in_o) ! solves: M out = in
call mtil_dag(tmp, out_e, mid)
call cg_outer(out_e, tmp, mid, 0, CG_MC)
-! Moe phi_e
+ ! Moe phi_e
+ if (chemi /= 0)call emuu4(gauge(2)%u, fac1, fac2, .false.)
call d(so, se, out_o, out_e, gauge(2)%u)
-! xi_o - Moe phi_e
+ ! xi_o - Moe phi_e
call sc_axpby(out_o, in_o, b, a)!(inout, in, b, a) ! inout = b * inout + a * in
-! phi_o = Moo^{-1} ( xi_o - Moe phi_e )
+ ! phi_o = Moo^{-1} ( xi_o - Moe phi_e )
if (action%mtilde(mid)%cswkappa /= ZERO) then
call clover_mult_ao(clover(cid)%i(1,1,so), out_o, volh)
else
if (action%mtilde(mid)%h /= ZERO) call h_mult_b(-action%mtilde(mid)%h, out_o, volh)
endif
+ if (chemi /= 0)call emuu4(gauge(2)%u, ONE, ONE, .false.)
+
DEBUG2S("End: solve_eo")
end
@@ -292,7 +301,7 @@ subroutine check_solution(mid, zeta_e, zeta_o, eta_e, eta_o)
integer, intent(in) :: mid
SPINCOL_FIELD, intent(in) :: zeta_e, zeta_o, eta_e, eta_o
P_SPINCOL_FIELD, save :: tmp1, tmp2
- REAL :: kappa, residual1, residual2, bb
+ REAL :: kappa, residual1, residual2, bb, fac1, fac2
integer :: cid
ALLOCATE_SC_FIELD(tmp1)
@@ -301,8 +310,11 @@ subroutine check_solution(mid, zeta_e, zeta_o, eta_e, eta_o)
cid = action%mtilde(mid)%cid
kappa = action%mtilde(mid)%kappa
- bb=sc_norm2(eta_e) + sc_norm2(eta_o) ; bb=global_sum(bb)
+ fac1 = exp( chemi)
+ fac2 = exp(-chemi)
+ if (chemi /= 0)call emuu4(gauge(2)%u, fac1, fac2, .false.)
+ bb=sc_norm2(eta_e) + sc_norm2(eta_o) ; bb=global_sum(bb)
! (1) Mee zeta_e + Meo zeta_o = eta_e
! (2) Moe zeta_e + Moo zeta_o = eta_o
@@ -331,52 +343,7 @@ subroutine check_solution(mid, zeta_e, zeta_o, eta_e, eta_o)
if (my_pe()==0)write(0,*) "residual of solution |b-Dx|/|b|: ", &
sqrt(residual1+residual2)/sqrt(bb)
-end
-
-!-------------------------------------------------------------------------------
-subroutine make_propagator()
- use module_field
- use module_action
- use module_input
- use module_function_decl
- use module_p_interface
- use module_vol
- use module_cg
- implicit none
-
- P_SPINCOL_FIELD, save :: in_e, in_o, out_e, out_o
- SECONDS :: time0, sekunden, time
- integer :: fid, mid, cid, iters, mu, col
- DOUBLE :: res
-
- fid = max(input%hmc_mpf_dd_mass,input%hmc_mpf_mass)
- fid = max(input%hmc_mpf_hh_mass,fid)
- fid = max(input%hmc_mpf_un_mass,fid)
-
- if (fid <= 0 .or. fid > 5 ) call die("traces: unexpected fid")
- mid = action%fermi(fid)%mid1
-
- ALLOCATE_SC_FIELD(in_e)
- ALLOCATE_SC_FIELD(in_o)
- ALLOCATE_SC_FIELD(out_e)
- ALLOCATE_SC_FIELD(out_o)
-
- call init_cg_stat(cg_stat)
- call init_imp_all(.true.)
-
- if (my_pe()==0) write(0,*) "WALL SOURCE"
- call make_source_wall(1,1,0,in_e,in_o)
- call solve(mid, out_e, out_o, in_e, in_o) ! solves: M out = in
-
- if (my_pe()==0) then
- write(0,*)"solver summary:CG"
- write(0,*)"first 12 components"
- do col=1,3
- do mu=1,4
- write(0,*)mu,col,out_e(mu,col,1)
- enddo
- enddo
- endif
+ if (chemi /= 0)call emuu4(gauge(2)%u, ONE, ONE, .false.)
end
diff --git a/src/measure/vector12.F90 b/src/measure/vector12.F90
deleted file mode 100644
index 9ca29afa602caf6e69a86db06f2f57c5e1d6fcd0..0000000000000000000000000000000000000000
--- a/src/measure/vector12.F90
+++ /dev/null
@@ -1,106 +0,0 @@
-!===============================================================================
-!
-! vector12.F90
-!
-!-------------------------------------------------------------------------------
-!
-! Copyright (C) 2007 Yoshifumi Nakamura
-!
-! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
-!
-! BQCD is free software: you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation, either version 3 of the License, or
-! (at your option) any later version.
-!
-! BQCD is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License
-! along with BQCD. If not, see <http://www.gnu.org/licenses/>.
-!
-!-------------------------------------------------------------------------------
-# include "defs.h"
-
-!-------------------------------------------------------------------------------
-subroutine global_sum_vector12(sc,in_e,in_o)
-
- use module_function_decl
- use module_vol
- implicit none
- COMPLEX, dimension(DIM,NCOL), intent(out) :: sc
- SPINCOL_FIELD, intent(in) :: in_e, in_o
- COMPLEX :: tmp
- REAL :: re, im
- integer :: i, mu, c
-
- do c = 1, 3
- do mu = 1, 4
- tmp = ZERO
- !$omp parallel do reduction(+: tmp)
- do i = 1, volh
- tmp = tmp + in_e(mu,c,i)
- enddo
- !$omp parallel do reduction(+: tmp)
- do i = 1, volh
- tmp = tmp + in_o(mu,c,i)
- enddo
- re = global_sum(dble(tmp))
- im = global_sum(dimag(tmp))
- sc(mu,c) = cmplx( re, im, kind = RKIND)
- enddo
- enddo
-
-end
-
-!-------------------------------------------------------------------------------
-subroutine write_vector12_0000_sum(in_e,in_o,name)
-
- use module_function_decl
- use module_vol
- implicit none
- SPINCOL_FIELD, intent(in) :: in_e, in_o
- character( len = 6), intent(in) :: name
-
- COMPLEX, dimension(DIM,NCOL) :: sc
- character( len = 10) :: name1, name2
-
- call global_sum_vector12(sc, in_e, in_o)
-
- write(name1,10)name,"0000"
- write(name2,10)name,"_sum"
-
- call write_vector12(0, in_e(1,1,1), name1)
- call write_vector12(0, sc, name2)
-
-10 format (2a)
-
-end
-
-!-------------------------------------------------------------------------------
-subroutine write_vector12(pe,sc,name)
-
- use module_function_decl
- implicit none
- COMPLEX, dimension(DIM,NCOL), intent(in) :: sc
- integer, intent(in) :: pe
- character( len = 10) :: name
- integer :: mu, c
-
-
- if (my_pe() == pe) then
- do c = 1, 3
- do mu = 1, 4
- write(*,100)"%%%",name,&
- my_pe(),mu,c,dble(sc(mu,c)),dimag(sc(mu,c))
- enddo
- enddo
- endif
-
-100 format (1x, 2a, 3i3, 2ES17.7)
-
-end
-
-!===============================================================================
diff --git a/src/modules/Makefile b/src/modules/Makefile
index 1207e00488ef5281db5f1dffe93f536a116a4005..370bf1c26cab61bb8ffb33a670ea346e32447735 100644
--- a/src/modules/Makefile
+++ b/src/modules/Makefile
@@ -36,7 +36,13 @@ fpp = $(FPP) -I../include $(MYFLAGS)
MODULES_DIR = .
-MODULES = \
+ifdef quad
+MODULES = typedef_clover_r16.o
+else
+MODULES =
+endif
+
+MODULES += \
typedef_cksum.o \
typedef_clover.o \
typedef_clover_r4.o \
@@ -73,16 +79,38 @@ MODULES = \
module_schr_weight.o \
module_surface.o
+ifdef quad
+MODULES += \
+ module_p_interface_r16.o \
+ module_mre_r16.o
+endif
+
modules: $(MODULES)
fast:
$(MAKE)
+module_mre_r16.o: module_mre.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
+
typedef_clover_r4.o: typedef_clover.F90
+ $(fpp) -DPRECISION_R4 $< > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
+
+typedef_clover_r16.o: typedef_clover.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
typedef_hmc_r4.o: typedef_hmc.F90
module_p_interface_r4.o: module_p_interface.F90
+ $(fpp) -DPRECISION_R4 $< > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
+
+module_p_interface_r16.o: module_p_interface.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
module_input.o: module_input.F90
m4 test.m4 >ttt.h
diff --git a/src/modules/module_action.F90 b/src/modules/module_action.F90
index e021ea41113db27cfaab4a6ed6d4e436af68dc57..5ce9c8306225defc52c68bb0347b71f24598836a 100644
--- a/src/modules/module_action.F90
+++ b/src/modules/module_action.F90
@@ -135,6 +135,8 @@ module module_action
integer, parameter :: so = 1
#endif
+ REAL, save :: chemi
+
end
!===============================================================================
diff --git a/src/modules/module_bqcd.F90 b/src/modules/module_bqcd.F90
index 85eee13544997acd0d7090f9f9b0139e2db7b83c..56682d09bdd0e0d2e09b52dd513144b8724ed5f4 100644
--- a/src/modules/module_bqcd.F90
+++ b/src/modules/module_bqcd.F90
@@ -30,7 +30,7 @@ module module_bqcd
character(len = *), parameter :: prog_name = "bqcd"
- character(len = *), parameter :: prog_version = "4.0.0"
+ character(len = *), parameter :: prog_version = "4.1.0"
character(len = n), parameter :: prog_revision = &
" (revision" // trim(svn_revision(11:n-1)) // ")"
diff --git a/src/modules/module_cg.F90 b/src/modules/module_cg.F90
index 7e4b5243810f915064e6a5fcf354deac795c74d0..079b6482ba85ba4256b76e951dd29f772ab41d79 100644
--- a/src/modules/module_cg.F90
+++ b/src/modules/module_cg.F90
@@ -223,7 +223,7 @@ end subroutine update_cg_stat
!-------------------------------------------------------------------------------
logical function stop_condition(rtr, res, b)
implicit none
- REAL,intent(in) :: rtr, res, b
+ REAL8,intent(in) :: rtr, res, b
stop_condition = .false.
@@ -235,6 +235,22 @@ logical function stop_condition(rtr, res, b)
end function stop_condition
+!-------------------------------------------------------------------------------
+#ifdef QUAD
+logical function stop_condition_r16(rtr, res, b)
+ implicit none
+ REAL16,intent(in) :: rtr, res, b
+
+ stop_condition_r16 = .false.
+
+ if (criterion == 0) then
+ stop_condition_r16 = (rtr <= res)
+ else
+ stop_condition_r16 = (rtr <= b*res**2 )
+ endif
+
+end function stop_condition_r16
+#endif
!-------------------------------------------------------------------------------
REAL function res_cg_inner(res, rtr, b, n)
implicit none
diff --git a/src/modules/module_field.F90 b/src/modules/module_field.F90
index 212d2ec1c3349aff2e60c4d81e1ecdb854e22e27..e30a25672939040ca62d3a3188f6f1687ea97e40 100644
--- a/src/modules/module_field.F90
+++ b/src/modules/module_field.F90
@@ -41,6 +41,11 @@ module module_field
type(gauge_field_r4), dimension(:),pointer,save :: gauge_r4
type(clover_field_r4), dimension(:),pointer,save :: clover_r4
+#ifdef QUAD
+ type(gauge_field_r16), dimension(:),pointer,save :: gauge_r16
+ type(clover_field_r16), dimension(:),pointer,save :: clover_r16
+#endif
+
#ifdef BAGEL
COMPLEX, dimension (:,:,:,:,:), pointer, save :: bagel_u
#endif
diff --git a/src/modules/module_function_decl.F90 b/src/modules/module_function_decl.F90
index c1b0c1f6ae21f4b60abe84affa0a8aee19a8de0e..d4b04c2c4437d89221473614e93da85dfd94e26f 100644
--- a/src/modules/module_function_decl.F90
+++ b/src/modules/module_function_decl.F90
@@ -58,6 +58,12 @@ module module_function_decl
REAL, external :: global_min
REAL, external :: global_max
+#ifdef QUAD
+!! REAL, external :: dotprod
+ REAL, external :: global_sum_r16
+ REAL, external :: global_min_r16
+ REAL, external :: global_max_r16
+#endif
! sc-field (-> sc.F90)
@@ -71,6 +77,14 @@ module module_function_decl
REAL4, external :: sc_dot_r4
COMPLEX4, external :: sc_cdotc_r4
+ ! sc-field (-> sc_r16.F90)
+
+#ifdef QUAD
+ REAL16, external :: sc_norm2_r16
+ REAL16, external :: sc_dot_r16
+ COMPLEX16, external :: sc_cdotc_r16
+#endif
+
! random numbers (-> ran/.../ran.F90):
RAN_NAME, external :: ran_name
diff --git a/src/modules/module_input.F90 b/src/modules/module_input.F90
index bb628849c45d3d79f3066258826a19b658d39ab3..75af28dafbb892a63cb743f2fdd3d57a6a71a7d6 100644
--- a/src/modules/module_input.F90
+++ b/src/modules/module_input.F90
@@ -180,6 +180,7 @@ contains
allocate(input%n_stout(size))
allocate(input%alpha(size))
allocate(input%theta(size))
+ allocate(input%chemi(size))
allocate(input%u04(size))
allocate(input%start_info_file(size))
@@ -206,6 +207,7 @@ contains
input%n_stout = "0"
input%alpha = "0.0"
input%theta = "0.0"
+ input%chemi = "0.0"
input%u04 = "0.0"
input%start_info_file = ""
@@ -241,6 +243,7 @@ contains
deallocate(input%n_stout)
deallocate(input%alpha)
deallocate(input%theta)
+ deallocate(input%chemi)
deallocate(input%u04)
deallocate(input%start_info_file)
diff --git a/src/modules/module_input.h b/src/modules/module_input.h
index a631e3f53649ce27f1924dc97a0ec6a230579a68..e89db44aaccecc391c350de5cc794ba8cce4330b 100644
--- a/src/modules/module_input.h
+++ b/src/modules/module_input.h
@@ -6,7 +6,7 @@
#-------------------------------------------------------------------------------
#
# Copyright (C) 2003-2010 Hinnerk Stueben
-# 2007-2010 Yoshifumi Nakamura
+# 2007-2011 Yoshifumi Nakamura
#
# This file is part of BQCD -- Berlin Quantum ChromoDynamics program
#
@@ -72,6 +72,8 @@ INPUT_INPUT(ran_ranlux_level, integer, 2)
INPUT_INPUT(measure_cooling_list, FILENAME, "")
INPUT_INPUT(measure_polyakov_loop, integer, 0)
INPUT_INPUT(measure_traces, integer, 0)
+INPUT_INPUT(measure_chemical, integer, 0)
+INPUT_INPUT(measure_schrpcac, integer, 0)
INPUT_INPUT(tuning_xbound_sc_i, integer, 1)
INPUT_INPUT(tuning_xbound_g_i, integer, 1)
@@ -120,6 +122,7 @@ INPUT_INPUT(kappa_strange, INPUT_ARRAY_ENSEMBLES, "0.0")
INPUT_INPUT(n_stout, INPUT_ARRAY_ENSEMBLES, "0")
INPUT_INPUT(alpha, INPUT_ARRAY_ENSEMBLES, "0.0")
INPUT_INPUT(theta, INPUT_ARRAY_ENSEMBLES, "0.0")
+INPUT_INPUT(chemi, INPUT_ARRAY_ENSEMBLES, "0.0")
INPUT_INPUT(hmc_integrator1, character(para_len), "LPFSTS")
INPUT_INPUT(hmc_integrator2, character(para_len), "LPFSTS")
@@ -192,6 +195,11 @@ INPUT_INPUT(solver_defsapgcr_nkv, integer, 16)
INPUT_INPUT(solver_defsapgcr_nsp, integer, 8)
INPUT_INPUT(solver_numkrylov_mtdmtdd, integer, 10)
INPUT_INPUT(solver_numdefvec_mtdmtdd, integer, 0)
+
+INPUT_INPUT(solver_gcrodr_numarstep, integer, 10)
+INPUT_INPUT(solver_gcrodr_numdefvec, integer, 5)
+
+
INPUT_INPUT(fullsolver, character(para_len), "eo")
INPUT_INPUT(measure_minmax, integer, 0)
@@ -205,6 +213,11 @@ INPUT_INPUT(boundary_sf, integer, 0)
INPUT_INPUT(nonactivelink, integer, 0)
INPUT_INPUT(tuning_approx_range, integer, 0)
INPUT_INPUT(tuning_approx_range_list, FILENAME, "")
+INPUT_INPUT(tuning_fraction_tolerance, FILENAME, "")
+
+INPUT_INPUT(replay_trick_ntau, integer, 0)
+INPUT_INPUT(replay_trick_threshold, character(para_len), "1.0")
+
!
! TEST
diff --git a/src/modules/module_mre.F90 b/src/modules/module_mre.F90
index f111bb8b353595c7e4c4826edf62aec776b1f86c..607f45a059a2016698c3b9ad8915e9e5b16b8fac 100644
--- a/src/modules/module_mre.F90
+++ b/src/modules/module_mre.F90
@@ -48,7 +48,7 @@ module module_mre2
integer, save :: mre2_n_vec = 0
type mre2_pointer
- complex(8),pointer :: x(:)
+ COMPLEX,pointer :: x(:)
end type mre2_pointer
type type_mre2
@@ -63,8 +63,8 @@ module mre2_get_interface
subroutine mre2_get(matrix, basis, trial, phi, id, ip)
use module_mre2
type(type_mre2), intent(inout) :: basis
- complex(8), intent(out) :: trial(:)
- complex(8),target,intent(in) :: phi(:)
+ COMPLEX, intent(out) :: trial(:)
+ COMPLEX,target,intent(in) :: phi(:)
external :: matrix
integer, intent(in) :: id
integer,optional, intent(in) :: ip
diff --git a/src/modules/module_rhmc.F90 b/src/modules/module_rhmc.F90
index c8b157e37d36ffa3a0cb06c8efb6ad587d472cc2..f978bdc64f036611c47d0abd248b9de1d9a18f7c 100644
--- a/src/modules/module_rhmc.F90
+++ b/src/modules/module_rhmc.F90
@@ -39,6 +39,8 @@ module module_rhmc
type(rational_approx), save :: ratapp(0:10)
+ REAL,dimension(:),pointer, save :: relax
+
end
!===============================================================================
diff --git a/src/modules/module_svn.F90 b/src/modules/module_svn.F90
index 26fa5557ae10506b64977675f38d108e3b5971f7..a83423c14364a65ab06904ddce1c9c39a80d67dc 100644
--- a/src/modules/module_svn.F90
+++ b/src/modules/module_svn.F90
@@ -7,7 +7,7 @@
!
! The modification is to increment "count" (see target "commit" in ../Makefile):
!
-!count= 78
+!count= 124
!
!-------------------------------------------------------------------------------
!
@@ -32,8 +32,8 @@
module module_svn
- character(*), parameter :: svn_revision = "$Revision: 274 $"
- character(*), parameter :: svn_date = "$Date: 2010-06-14 20:03:24 +0200 (Mon, 14 Jun 2010) $"
+ character(*), parameter :: svn_revision = "$Revision: 354 $"
+ character(*), parameter :: svn_date = "$Date: 2011-10-14 09:33:50 +0200 (Fri, 14 Oct 2011) $"
end
diff --git a/src/modules/module_switches.F90 b/src/modules/module_switches.F90
index eb76be9cdd78b7dab3a680f5101c07791bffadeb..08e5fac54dd367dca3d32fc1bb07a7d96879e58f 100644
--- a/src/modules/module_switches.F90
+++ b/src/modules/module_switches.F90
@@ -35,6 +35,8 @@ module module_switches
logical :: hmc_test
logical :: measure_polyakov_loop
logical :: measure_traces
+ logical :: measure_chemical
+ logical :: measure_schrpcac
logical :: improved_gauge
logical :: rhmc
@@ -52,6 +54,7 @@ module module_switches
logical :: measure_correlations
logical :: measurement_only
logical :: boundary_sf
+ logical :: replay
end type type_switches
diff --git a/src/modules/typedef.F90 b/src/modules/typedef.F90
index 09980f8fdc5a47f824b2ff46025e1eea8440938e..dfe079451047276d65899bd44e448c24e338074e 100644
--- a/src/modules/typedef.F90
+++ b/src/modules/typedef.F90
@@ -28,11 +28,19 @@
# define P_CLOVER_FIELD_A_R4 type(type_clover_a_r4), dimension(:, :, :), pointer
# define P_CLOVER_FIELD_B_R4 type(type_clover_b_r4), dimension(:, :, :), pointer
+# define P_GAUGE_FIELD_R16 complex(16), dimension(:, :, :, :, :), pointer
+# define P_CLOVER_FIELD_A_R16 type(type_clover_a_r16), dimension(:, :, :), pointer
+# define P_CLOVER_FIELD_B_R16 type(type_clover_b_r16), dimension(:, :, :), pointer
+
!-------------------------------------------------------------------------------
module typedef
use typedef_clover
use typedef_clover_r4
+#ifdef QUAD
+ use typedef_clover_r16
+#endif
+
type :: sc_field
P_SPINCOL_FIELD :: sc
P_SPINCOL_FIELD :: sc_e
@@ -78,6 +86,23 @@ module typedef
P_CLOVER_FIELD_B_R4 :: b
end type clover_field_r4
+#ifdef QUAD
+ type gauge_field_r16
+ logical :: init
+ integer :: sid
+ P_GAUGE_FIELD_R16 :: u
+ end type gauge_field_r16
+
+ type clover_field_r16
+ logical :: init
+ integer :: nf
+ real(16) :: kappa, csw, cswkappa, theta
+ P_CLOVER_FIELD_A_R16 :: a
+ P_CLOVER_FIELD_A_R16 :: i
+ P_CLOVER_FIELD_B_R16 :: b
+ end type clover_field_r16
+#endif
+
end
!===============================================================================
diff --git a/src/modules/typedef_hmc.F90 b/src/modules/typedef_hmc.F90
index e85831b45917aa1cbdc721b0c91668158fcb0dde..666322fec08f2c7d3edb20b1327f1341b0360b61 100644
--- a/src/modules/typedef_hmc.F90
+++ b/src/modules/typedef_hmc.F90
@@ -39,6 +39,7 @@ module typedef_hmc
integer :: n_stout
REAL :: alpha
REAL :: theta
+ REAL :: chemi
REAL :: h
REAL :: traj_length
REAL :: tau
@@ -63,6 +64,7 @@ module typedef_hmc
character(len = 20) :: n_stout
character(len = 20) :: alpha
character(len = 20) :: theta
+ character(len = 20) :: chemi
character(len = 20) :: h
character(len = 20) :: traj_length
character(len = 20) :: tau
diff --git a/src/platform/FMLIB_makefile b/src/platform/FMLIB_makefile
new file mode 100644
index 0000000000000000000000000000000000000000..c77cf11740c4533089b8a698bd8d1e5a90a1dc59
--- /dev/null
+++ b/src/platform/FMLIB_makefile
@@ -0,0 +1,46 @@
+#===============================================================================
+#
+# Sample Makefile for FMLIB
+#
+#-------------------------------------------------------------------------------
+#
+# Copyright (C) 2011 Yoshifumi Nakamura
+#
+# This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+#
+# BQCD is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# BQCD is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+#
+#===============================================================================
+
+.SUFFIXES:
+.SUFFIXES: .a .o .f90
+
+F90=gfortran -O3
+
+.f90.o:
+ $(F90) -c $(FFLAGS) $*.f90
+
+OBJS = \
+ FMSAVE.o \
+ FMZM90.o \
+ FM.o
+# SampleFM.o \
+# TestFM.o
+
+lib_FM.a: $(OBJS)
+ ar rv $@ $(OBJS)
+
+clobber:
+ rm -f *.[Tiod] *.mod work.pc work.pcl
+ rm -f lib_FM.a
diff --git a/src/platform/Makefile-EXPLAINED.var b/src/platform/Makefile-EXPLAINED.var
index 0bfa87ed4f309209ee717e95fd7a98d611382a60..5c9bf8bf6edfb298b9f62b7a2196d364b690fa76 100644
--- a/src/platform/Makefile-EXPLAINED.var
+++ b/src/platform/Makefile-EXPLAINED.var
@@ -41,7 +41,7 @@ ARFLAGS = # additional flags (to "rv")
LDFLAGS = # loader flags (loader = ${F90})
SYSLIBS = # system libraries (e.g. for BLAS)
-FAST_MAKE = gmake -j 8 # parallel make
+FAST_MAKE = gmake -j 1 # parallel make (currently make has to run serial)
BLAS_O = # not used any more
CKSUM_O = cksum.o # or "cksum_dummy.o"
diff --git a/src/platform/Makefile-altix.var b/src/platform/Makefile-altix.var
index 73a5c77fb81ecfb2370d4d0699a426cbaff639ba..e9440c7be7af166e7b770a8518df3df5c36ef082 100644
--- a/src/platform/Makefile-altix.var
+++ b/src/platform/Makefile-altix.var
@@ -49,7 +49,7 @@ ARFLAGS =
LDFLAGS = -Vaxlib -lmpi
SYSLIBS =
-FAST_MAKE = gmake -j 8
+FAST_MAKE = gmake -j 1
BLAS_O = blas.o
CKSUM_O = cksum.o
diff --git a/src/platform/Makefile-altix2.var b/src/platform/Makefile-altix2.var
index d684a0ad3c9528e6aa403b8ba36f18a1552f85f6..4d32111da588dffb78b9453277ae65cf0d7ff93e 100644
--- a/src/platform/Makefile-altix2.var
+++ b/src/platform/Makefile-altix2.var
@@ -43,14 +43,14 @@ CC = icc
MODULES_FLAG = -I$(MODULES_DIR)
MYFLAGS = -DINTEL -DALTIX -DMPI_1
-FFLAGS_STD= $(MODULES_FLAG)
+FFLAGS_STD= $(MODULES_FLAG) -fno-alias
CFLAGS_STD= -DNamesToLower_
ARFLAGS =
LDFLAGS = -Vaxlib -lmpi
SYSLIBS =
-FAST_MAKE = gmake -j 8
+FAST_MAKE = gmake -j 1
CKSUM_O = cksum.o
UUU_O = uuu_f90.o
@@ -70,10 +70,14 @@ endif
ifdef mpi
LIBCOMM = lib_mpi.a
LDFLAGS += -lsma
+else
+ MYFLAGS += -DNONMPI
+ CFLAGS_STD+= -DNONMPI
endif
ifdef omp
F90 += -openmp
+ CC += -openmp
MYFLAGS += -D_OPENMP
endif
diff --git a/src/platform/Makefile-bluegene1-epcc.var b/src/platform/Makefile-bluegene1-epcc.var
index 2b4b30f22a3e215354ad2a5a247382b9f1fcdf43..c98e0e9df3da63e84d7e096c5388a0f9aa3066e7 100644
--- a/src/platform/Makefile-bluegene1-epcc.var
+++ b/src/platform/Makefile-bluegene1-epcc.var
@@ -61,7 +61,7 @@ ARFLAGS =
LDFLAGS = -L$(BGLSYS)/lib
SYSLIBS = -lmpich.rts -lfmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts
-FAST_MAKE = gmake -j 8
+FAST_MAKE = gmake -j 1
CKSUM_O = cksum.o
UUU_O = uuu_f90.o
diff --git a/src/platform/Makefile-cray.var b/src/platform/Makefile-cray.var
index 1a9cb777d4872edb675a7023343766afd74209cd..d42be97b04b417fb6df97bdac24f1f535a1ed24c 100644
--- a/src/platform/Makefile-cray.var
+++ b/src/platform/Makefile-cray.var
@@ -41,7 +41,7 @@ ARFLAGS =
LDFLAGS =
SYSLIBS =
-FAST_MAKE = NPROC=4 make
+FAST_MAKE = NPROC=1 make
BLAS_O =
CKSUM_O = cksum.o
diff --git a/src/platform/Makefile-gnu.var b/src/platform/Makefile-gnu.var
index 5c4faba27d4b61b921ea6843770cb1a6ee255afb..c65e669d408d1909ff10b9b97719fa5a11d5015f 100644
--- a/src/platform/Makefile-gnu.var
+++ b/src/platform/Makefile-gnu.var
@@ -23,9 +23,9 @@
#
#-------------------------------------------------------------------------------
-timing = 1
+timing =1
mpi =
-omp =
+omp =
shmem =
shmempi =
debug =
@@ -37,15 +37,14 @@ random = ranlux-3.2
SHELL = /bin/ksh
FPP = cpp -E -C -P
-FPP2 =
-F90 = gfortran -ffree-line-length-none -fno-range-check
+F90 = gfortran
CC = gcc
MODULES_FLAG = -I$(MODULES_DIR)
-MYFLAGS = -DNONMPI
-FFLAGS_STD= $(MODULES_FLAG)
-CFLAGS_STD= -DNamesToLower_ -DNONMPI
+MYFLAGS =
+FFLAGS_STD= $(MODULES_FLAG) -ffree-line-length-none -fno-range-check
+CFLAGS_STD= -DNamesToLower_ -DLongLong
ARFLAGS =
LDFLAGS =
@@ -69,7 +68,11 @@ endif
ifdef mpi
LIBCOMM = lib_mpi.a
- LDFLAGS += -lsma
+ F90 = mpif90
+ CC = mpicc
+else
+ MYFLAGS += -DNONMPI
+ CFLAGS_STD+= -DNONMPI
endif
ifdef omp
diff --git a/src/platform/Makefile-hitachi-omp.var b/src/platform/Makefile-hitachi-omp.var
index f4d7a74f7050da026cb569c8159f34028c92d0e2..1798517d55dcab634e00b6f511f03fd16de3bde6 100644
--- a/src/platform/Makefile-hitachi-omp.var
+++ b/src/platform/Makefile-hitachi-omp.var
@@ -40,7 +40,7 @@ ARFLAGS =
LDFLAGS = +BTLB -omp -rdma
SYSLIBS = /usr/local/lib/liblrz.a -lf90c -lpl
-FAST_MAKE = JOBTYPE=SS prun -p IAPAR gmake -j 8
+FAST_MAKE = JOBTYPE=SS prun -p IAPAR gmake -j 1
BLAS_O = blas.o
CKSUM_O = cksum.o
diff --git a/src/platform/Makefile-hitachi.var b/src/platform/Makefile-hitachi.var
index ff915d8cfd67e3f10f4a407d24d7a465f4b7e335..5e28c8eaf78857d4b4c37308d4e79121501d4270 100644
--- a/src/platform/Makefile-hitachi.var
+++ b/src/platform/Makefile-hitachi.var
@@ -39,7 +39,7 @@ ARFLAGS =
LDFLAGS = +BTLB
SYSLIBS = /usr/local/lib/liblrz.a -lf90c -lpl
-FAST_MAKE = JOBTYPE=SS prun -p IAPAR gmake -j 8
+FAST_MAKE = JOBTYPE=SS prun -p IAPAR gmake -j 1
BLAS_O = blas.o
CKSUM_O = cksum.o
diff --git a/src/platform/Makefile-hlrn2.var b/src/platform/Makefile-hlrn2.var
index 946a0f2d752fedfb7e10ab0107a661d2f5ddd60f..4f8d3890f1f0e9eaace2cf9ed899259bde8ad790 100644
--- a/src/platform/Makefile-hlrn2.var
+++ b/src/platform/Makefile-hlrn2.var
@@ -4,7 +4,7 @@
#
#-------------------------------------------------------------------------------
#
-# Copyright (C) 2008 Hinnerk Stueben
+# Copyright (C) 2008-2011 Hinnerk Stueben
#
# This file is part of BQCD -- Berlin Quantum ChromoDynamics program
#
@@ -45,14 +45,14 @@ CC = icc
MODULES_FLAG = -I$(MODULES_DIR)
MYFLAGS = -DINTEL -DALTIX -DMPI_1
-FFLAGS_STD= $(MODULES_FLAG)
-CFLAGS_STD= -DNamesToLower_
+FFLAGS_STD= $(MODULES_FLAG) -fno-alias
+CFLAGS_STD= -DNamesToLower_ -DMPI_1
ARFLAGS =
LDFLAGS = -Vaxlib
SYSLIBS =
-FAST_MAKE = gmake -j 8
+FAST_MAKE = make
CKSUM_O = cksum.o
UUU_O = uuu_f90.o
@@ -89,6 +89,7 @@ endif
ifdef omp
F90 += -openmp
+ CC += -openmp
MYFLAGS += -D_OPENMP
endif
@@ -116,4 +117,18 @@ else
LIBD = libd$(libd).a
endif
+### Scalapack (use MKL):
+
+MKL_LIBDIR = $(MKLROOT)/lib/em64t
+
+LDFLAGS += -Wl,-rpath,$(MKL_LIBDIR) -L$(MKL_LIBDIR)
+
+ifdef omp
+ LAPACK = -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core
+else
+ LAPACK = -lmkl_intel_lp64 -lmkl_sequential -lmkl_core
+endif
+
+SCALAPACK = -lmkl_blacs_intelmpi_lp64 -lmkl_scalapack_lp64 -lmkl_blacs_intelmpi_lp64 $(LAPACK)
+
#===============================================================================
diff --git a/src/platform/Makefile-ibm.var b/src/platform/Makefile-ibm.var
index d70147940f99dbf6faa1a7097ffb7a9341c7ad2a..56b9d0f7b5fd2bdd3dedfb81532b40b37b2704c2 100644
--- a/src/platform/Makefile-ibm.var
+++ b/src/platform/Makefile-ibm.var
@@ -64,7 +64,7 @@ ARFLAGS =
LDFLAGS =
SYSLIBS =
-FAST_MAKE = gmake -j 8
+FAST_MAKE = gmake -j 1
CKSUM_O = cksum.o
UUU_O = uuu_f90.o
diff --git a/src/platform/Makefile-intel.var b/src/platform/Makefile-intel.var
index 58151a089088ed5d0251a69fcbd4ef2113dd3f18..5a181a769b78cb966e1332073229f2205fa30be3 100644
--- a/src/platform/Makefile-intel.var
+++ b/src/platform/Makefile-intel.var
@@ -5,6 +5,7 @@
#-------------------------------------------------------------------------------
#
# Copyright (C) 2002-2008 Hinnerk Stueben
+# 2011 Yoshifumi Nakamura
#
# This file is part of BQCD -- Berlin Quantum ChromoDynamics program
#
@@ -23,37 +24,71 @@
#
#-------------------------------------------------------------------------------
-random = ranlux-3.2
-
+omp =
+timing = 1
+libd = 100
+random = ranlux-3.2
+cuda =
#-------------------------------------------------------------------------------
SHELL = /bin/ksh
FPP = cpp -C -P
-F90 = ifort
-CC = icc
+F90 = mpiifort
+CC = mpiicc
MODULES_FLAG = -I$(MODULES_DIR)
-MYFLAGS =
-FFLAGS = $(MODULES_FLAG)
-CFLAGS = -DLongLong -DNamesToLower_
+MYFLAGS =
+FFLAGS_STD= $(MODULES_FLAG) -xSSE3 -align all
+CFLAGS_STD= -DLongLong -DNamesToLower_ -I./include
ARFLAGS =
-LDFLAGS = -Vaxlib
+LDFLAGS =
SYSLIBS =
-FAST_MAKE = gmake -j 2
+FAST_MAKE = gmake -j 1
BLAS_O = blas.o
CKSUM_O = cksum.o
RANDOM_O = ran.o ranf.o
UUU_O = uuu_f90.o
-LIBD = libd2.a
-LIBCOMM = lib_single_pe.a
+LIBD = libd.a
+LIBCOMM = lib_mpi.a
LIBCLOVER = libclover.a
LIBILDG = ildg_stubs.o
LIBRANDOM = ran/$(random)/libran.a
+#-------------------------------------------------------------------------------
+
+ifdef timing
+ MYFLAGS += -DTIMING
+endif
+
+ifeq ($(libd),1)
+ LIBD = libd.a
+else
+ LIBD = libd$(libd).a
+endif
+
+ifdef debug
+ FFLAGS = -g -O0 $(FFLAGS_STD)
+ CFLAGS = -g -O0 $(CFLAGS_STD)
+else
+ FFLAGS = -O3 $(FFLAGS_STD)
+ CFLAGS = -O2 $(CFLAGS_STD)
+endif
+
+ifdef omp
+ F90 += -openmp
+ MYFLAGS += -D_OPENMP
+endif
+
+ifdef cuda
+ CFLAGS += -I/usr/local/cuda/include/
+ LDFLAGS+= -L/usr/local/cuda/lib64
+ SYSLIBS+= -lcublas
+endif
+
#===============================================================================
diff --git a/src/platform/Makefile-jubl.var b/src/platform/Makefile-jubl.var
index 04f6501dc99add30a1e2175ab9fe15abf658c496..a4380918e3bce219cf0d7a2e7f5d27b6e2a4cdc3 100644
--- a/src/platform/Makefile-jubl.var
+++ b/src/platform/Makefile-jubl.var
@@ -60,7 +60,7 @@ ARFLAGS =
LDFLAGS = -L$(BGLSYS)/lib
SYSLIBS = -lmpich.rts -lfmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts
-FAST_MAKE = gmake -j 8
+FAST_MAKE = gmake -j 1
BLAS_O = blas.o
CKSUM_O = cksum.o
diff --git a/src/platform/Makefile-jugene.var b/src/platform/Makefile-jugene.var
index b39da4e7bfd00082d89931e58f4b6dd26cc54087..c3234632cfb359c4b1c6b0434da2dc492d669a0c 100644
--- a/src/platform/Makefile-jugene.var
+++ b/src/platform/Makefile-jugene.var
@@ -37,7 +37,7 @@ libd = 520
# for all other libd's -mapfile must be XYZT as well
# for testing begin with libd100:
-libd = 100
+#libd = 100
random = ranlux-3.2
omp =
diff --git a/src/platform/Makefile-linux.var b/src/platform/Makefile-linux.var
index 3ff1471d0150e4aa04b65bd92ad703a536e33a10..9de7c2f9ff58b0cd2c1d4e4fc5d039ed0c8fb8d8 100644
--- a/src/platform/Makefile-linux.var
+++ b/src/platform/Makefile-linux.var
@@ -29,7 +29,7 @@ omp =
shmem =
shmempi =
debug =
-libd = 2
+libd = 100
random = ranlux-3.2
#-------------------------------------------------------------------------------
@@ -43,9 +43,9 @@ CC = gcc
MODULES_FLAG = -I$(MODULES_DIR)
-MYFLAGS = -DNONMPI
+MYFLAGS =
FFLAGS_STD= $(MODULES_FLAG) -ffree-line-length-none -fno-range-check
-CFLAGS_STD= -DNamesToLower_ -DNONMPI
+CFLAGS_STD= -DNamesToLower_
ARFLAGS =
LDFLAGS =
@@ -71,6 +71,9 @@ endif
ifdef mpi
F90 = mpif90
LIBCOMM = lib_mpi.a
+else
+ MYFLAGS += -DNONMPI
+ CFLAGS_STD+= -DNONMPI
endif
ifdef omp
diff --git a/src/platform/Makefile-supermig.var b/src/platform/Makefile-supermig.var
new file mode 100644
index 0000000000000000000000000000000000000000..b4c1253b13e7778e0cf12dd9dcb23279454395e2
--- /dev/null
+++ b/src/platform/Makefile-supermig.var
@@ -0,0 +1,126 @@
+#===============================================================================
+#
+# Makefile-supermig.var - settings on SuperMIG (IBM iDataPlex)
+#
+#-------------------------------------------------------------------------------
+#
+# Copyright (C) 2011 Hinnerk Stueben
+#
+# This file is part of BQCD -- Berlin Quantum ChromoDynamics program
+#
+# BQCD is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# BQCD is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with BQCD. If not, see <http://www.gnu.org/licenses/>.
+#
+#-------------------------------------------------------------------------------
+
+## mpi = { <empty> | poe | impi }
+
+timing = 1
+mpi = impi
+omp =
+shmem =
+shmempi =
+debug =
+libd = 100
+random = ranlux-3.2
+
+#-------------------------------------------------------------------------------
+
+SHELL = /bin/ksh
+
+FPP = cpp -E -C -P
+F90 = ifort
+CC = icc
+
+MODULES_FLAG = -I$(MODULES_DIR)
+
+MYFLAGS = -DINTEL
+FFLAGS_STD= $(MODULES_FLAG) -fno-alias
+CFLAGS_STD= -DNamesToLower_
+ARFLAGS =
+
+LDFLAGS =
+SYSLIBS =
+
+FAST_MAKE = gmake -j 1
+
+CKSUM_O = cksum.o
+UUU_O = uuu_f90.o
+
+LIBD =
+LIBCOMM = lib_single_pe.a
+LIBCLOVER = libclover.a
+LIBILDG = ildg_stubs.o
+LIBRANDOM = ran/$(random)/libran.a
+
+#-------------------------------------------------------------------------------
+
+ifdef timing
+ MYFLAGS += -DTIMING
+endif
+
+ifdef mpi
+ LIBCOMM = lib_mpi.a
+ F90 = mpiifort
+ CC = mpiicc
+else
+ MYFLAGS += -DNONMPI
+ CFLAGS_STD+= -DNONMPI
+endif
+
+ifdef omp
+ F90 += -openmp
+ CC += -openmp
+ MYFLAGS += -D_OPENMP
+endif
+
+ifdef debug
+ FFLAGS = -g -O0 $(FFLAGS_STD)
+ CFLAGS = -g -O0 $(CFLAGS_STD)
+else
+ FFLAGS = -O3 $(FFLAGS_STD)
+ CFLAGS = -O2 $(CFLAGS_STD)
+endif
+
+ifeq ($(libd),1)
+ LIBD = libd.a
+else
+ LIBD = libd$(libd).a
+endif
+
+LIME = $(HOME)/supermig/lib-serial/lime-1.3.1
+
+### Scalapack (use MKL if possible):
+
+#LIBBLAS = $(HOME)/supermig/lib-serial/BLAS/blas_LINUX.a
+#LIBLAPACK = $(HOME)/supermig/lib-serial/lapack-3.3.1/lapack_LINUX.a
+LIBBLACS = $(HOME)/supermig/lib-mpi-ibm/BLACS/LIB/blacsF77init_MPI-LINUX-0.a \
+ $(HOME)/supermig/lib-mpi-ibm/BLACS/LIB/blacs_MPI-LINUX-0.a
+LIBSCALAPACK = $(HOME)/supermig/lib-mpi-ibm/scalapack-1.8.0/libscalapack.a
+
+LDFLAGS += -Wl,-rpath,$(MKL_LIBDIR) -L$(MKL_LIBDIR)
+
+#LAPACK = $(LIBLAPACK) $(LIBBLAS)
+ifdef omp
+ LAPACK = -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core
+else
+ LAPACK = -lmkl_intel_lp64 -lmkl_sequential -lmkl_core
+endif
+
+ifeq ($(mpi),impi)
+ SCALAPACK = -lmkl_blacs_intelmpi_lp64 -lmkl_scalapack_lp64 -lmkl_blacs_intelmpi_lp64 $(LAPACK)
+else
+ SCALAPACK = $(LIBSCALAPACK) $(LIBBLACS)
+endif
+
+#===============================================================================
diff --git a/src/measure/correlation_tt.F90 b/src/platform/service-k.F90
similarity index 50%
rename from src/measure/correlation_tt.F90
rename to src/platform/service-k.F90
index a202e1325f30e881b7f11cb0f18ac0d62fd2d779..cc2a9fd142dae21d4bfd5ac22cdb9577515b3383 100644
--- a/src/measure/correlation_tt.F90
+++ b/src/platform/service-k.F90
@@ -1,10 +1,10 @@
!===============================================================================
!
-! correlation_tt.F90
+! service-K.F90 - calls to service routine for K
!
!-------------------------------------------------------------------------------
!
-! Copyright (C) 2007 Yoshifumi Nakamura
+! Copyright (C) 2011 Yoshifumi Nakamura
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
@@ -23,48 +23,56 @@
!
!-------------------------------------------------------------------------------
# include "defs.h"
-# include "defs_imp_2p1.h"
!-------------------------------------------------------------------------------
-COMPLEX function correlation_tt(t0,dis,in1,in2)
+subroutine abbruch()
- use module_decomp
- implicit none
- integer, intent(in) :: t0, dis
- COMPLEX_FIELD_ST, intent(in) :: in1,in2
- integer, external :: std_xyzt2i, e_o
- integer :: vols ,t, t1, , coord(DIM)
+ integer(4) status
+ status = 1
+ call exit(status)
+end
+!-------------------------------------------------------------------------------
+function rechner() ! returns hostname
- nx = decomp%std%N(1)
- ny = decomp%std%N(2)
- nz = decomp%std%N(3)
- nt = decomp%std%N(4)
+ character(len = 20) rechner
+ character(len = 32) r
+ call hostnm(r)
+ rechner = r
+end
- vols = NX*NY*NZ
- t1 = dis + t0
- tt = dis / NT
- tr = mod(dis,NT)
+!-------------------------------------------------------------------------------
+SECONDS function sekunden()
+ use module_function_decl
+ call cpu_time(sekunden)
+ sekunden=sekunden/num_threads()
- npe(1) = LX/NX
- npe(2) = LY/NY
- npe(3) = LZ/NZ
+end
- do xx = 0, npe(1) - 1
- do yy = 0, npe(2) - 1
- do zz = 0, npe(3) - 1
- pe_shift = nnpe(xx, yy, zz, tt)
+!-------------------------------------------------------------------------------
+subroutine pxfgetarg(iarg, arg, larg, status)
- do i = 1, vols
- do j = 1, vols
- in1(i, t0)*in2(j, tr)
- enddo
- enddo
+ implicit none
+ integer :: iarg, larg, status
+ character(len = *) :: arg
+ character(100) :: a
+
+ call getarg(iarg, a)
+ larg = len_trim(a)
+ arg = a
+ status = 0
+end
- correlation_tt = ZERO
+!-------------------------------------------------------------------------------
+integer function ipxfargc()
+ ipxfargc = iargc()
+end
+!-------------------------------------------------------------------------------
+logical function is_big_endian()
+ is_big_endian = .true.
end
!===============================================================================
diff --git a/src/platform/service-supermig.F90 b/src/platform/service-supermig.F90
new file mode 120000
index 0000000000000000000000000000000000000000..6f01ff08d84e6d07ecc55f8e3081b5100b220e73
--- /dev/null
+++ b/src/platform/service-supermig.F90
@@ -0,0 +1 @@
+service-intel.F90
\ No newline at end of file
diff --git a/src/precision.H b/src/precision.H
new file mode 100644
index 0000000000000000000000000000000000000000..1c3895995d5bee762de8f60dfcd9c8034eac9324
--- /dev/null
+++ b/src/precision.H
@@ -0,0 +1,183 @@
+
+# define module_mre
+# define module_mre2
+# define type_mre
+# define type_mre2
+# define mre_pointer_to_sc_field
+# define mre2_pointer
+# define mre2_get_interface
+# define mre2_get
+# define mre2_put
+# define mre_pointer
+# define mre_get
+# define mre_put
+# define mre_allocate
+# define mre2_allocate
+# define mre_gram_schmidt
+# define mre_gauss_jordan
+# define mre2_gram_schmidt
+# define mre2_gauss_jordan
+# define mre_n_vec
+
+# define allocate_clover_field_a
+# define allocate_clover_field_b
+# define allocate_gen_field
+# define allocate_g_field
+# define allocate_g_field_ildg
+# define allocate_g_field_io
+# define allocate_sc2_field
+# define allocate_sc_field
+# define allocate_sc_field_io
+# define allocate_sc_overindexed
+# define _bwd
+# define cg
+# define clover
+# define clover_mult_a
+# define clover_mult_a2_block
+# define clover_mult_ao
+# define clover_mult_ao_block
+# define clover_mult_ao2_block
+# define clover_mult_b
+#ifndef D_R4_INTERNAL
+# define d
+# define d_dag
+#endif
+# define d_block
+# define d_dag_block
+
+# define d_projection
+# define d_projection_block
+# define d_dag_projection
+# define d_dag_projection_block
+
+# define d_xyzt
+
+# define d_t
+# define d_xb
+# define d_xf
+# define d_yb
+# define d_yf
+# define d_zb
+# define d_zf
+# define d_dag_t
+# define d_dag_xb
+# define d_dag_xf
+# define d_dag_yb
+# define d_dag_yf
+# define d_dag_zb
+# define d_dag_zf
+
+# define d_t_block
+# define d_x_block
+# define d_y_block
+# define d_z_block
+# define d_t_block2
+# define d_x_block2
+# define d_y_block2
+# define d_z_block2
+
+# define d_dag_t_block
+# define d_dag_x_block
+# define d_dag_y_block
+# define d_dag_z_block
+# define d_dag_t_block2
+# define d_dag_x_block2
+# define d_dag_y_block2
+# define d_dag_z_block2
+
+# define d_xbound
+
+
+
+
+# define _fwd
+# define gauge
+# define hmc_conf
+# define h_mult_a
+# define h_mult_b
+# define h_mult_c
+# define init_xbound
+# define init_xbound_d_proj
+# define init_xbound_g
+# define init_xbound_g_rect
+# define init_xbound_sc
+# define init_xbound_sc2
+# define init_xch_bound
+# define init_xch_bound_no_diagonal
+# define mdag
+# define mmul
+# define module_d21
+# define module_d_g
+# define module_m_mult_block
+# define module_p_interface
+# define module_p_interface
+# define module_xbound
+# define module_xbound_d_proj
+# define module_xbound_g
+# define module_xbound_g_rect
+# define module_xbound_sc
+# define module_xbound_sc2
+# define mtdagmt
+# define mtil
+# define mtil_dag
+# define sc_axpby
+# define sc_axpy
+# define sc_axpy_block
+# define sc_cax2
+# define sc_caxpy
+# define sc_caxpy2
+# define sc_cdotc
+# define sc_copy
+# define sc_dot
+# define sc_dprod_block
+# define sc_norm2
+# define sc_scale
+# define sc_xmy
+# define sc_xpby
+# define sc_xpby_block
+# define sc_zero
+# define sc_zero_halo
+# define swap_p_clover_field_a
+# define swap_p_clover_field_b
+# define swap_p_g_field
+# define swap_p_sc_field
+# define type_clover_a
+# define type_clover_b
+# define typedef_clover
+# define unprec_cmul
+# define unprec_mdag
+# define unprec_mdagm
+# define unprec_mmul
+# define unprec_wdag
+# define unprec_wdagw
+# define unprec_wmul
+# define u_reorder
+# define wdag
+# define wdag_block
+# define w_dagger_w
+# define wdagw
+# define wdagw_block
+# define wmul
+# define wmul_block
+# define w_mult
+# define w_mult_dag
+# define xbound_d_proj
+# define xbound_d_proj_i
+# define xbound_d_proj_sr
+# define xbound_g
+# define xbound_g_field
+# define xbound_g_field_rect
+# define xbound_g_i
+# define xbound_g_rect
+# define xbound_g_rect_i
+# define xbound_g_rect_i_ind
+# define xbound_g_rect_ind
+# define xbound_g_rect_sr
+# define xbound_g_rect_sr_ind
+# define xbound_g_sr
+# define xbound_sc
+# define xbound_sc2
+# define xbound_sc2_field
+# define xbound_sc2_field_i
+# define xbound_sc_field
+# define xbound_sc_field_i
diff --git a/src/service.F90 b/src/service.F90
index ce7439ee66470b3939be1882175b8bb76ae80719..e41a1f90d167f8d9fcd3ae545485b35aefd6f640 120000
--- a/src/service.F90
+++ b/src/service.F90
@@ -1 +1 @@
-platform/service-linux.F90
\ No newline at end of file
+platform/service-gnu.F90
\ No newline at end of file
diff --git a/src/su3sc/Makefile b/src/su3sc/Makefile
index 18c57ffb55c22122eb5e3cb8d8e3fd27782159ca..33d45c124823be3d14196118633446ff15c84c78 100644
--- a/src/su3sc/Makefile
+++ b/src/su3sc/Makefile
@@ -26,9 +26,9 @@ DIR = ../
include ../Makefile.in
ifdef FPP2
- fpp = $(FPP2)
+ fpp = $(FPP2) -I../include $(MYFLAGS)
else
- fpp = $(FPP)
+ fpp = $(FPP) -I../include $(MYFLAGS)
endif
FAST_MAKE = make -j 1
@@ -37,7 +37,7 @@ FAST_MAKE = make -j 1
.SUFFIXES: .a .o .F90
.F90.o:
- $(fpp) -I../include $(MYFLAGS) $< > $*.f90
+ $(fpp) $< > $*.f90
$(F90) -c $(FFLAGS) $*.f90
MODULES_DIR = ../modules
@@ -56,6 +56,10 @@ OBJS = \
su3.o \
vec.o
+ifdef quad
+OBJS += sc_r16.o
+endif
+
fast:
$(FAST_MAKE) lib_su3sc.a
-cp *.mod $(MODULES_DIR)
@@ -66,3 +70,10 @@ lib_su3sc.a: $(OBJS)
clobber:
rm -f *.[Tiod] *.f90 *.mod work.pc work.pcl
rm -f lib_su3sc.a
+
+sc_r4.o: sc.F90
+ $(fpp) -DPRECISION_R4 $< > $*.f90
+ $(F90) -c $(FFLAGS32) $*.f90
+sc_r16.o: sc.F90
+ $(fpp) -DPRECISION_R16 $< > $*.f90
+ $(F90) -c $(FFLAGS) $*.f90
diff --git a/src/su3sc/init_sc.F90 b/src/su3sc/init_sc.F90
index 8d914e7a8c3f071eb62601ff0a9b7cda4749b6c8..4d19e26756a08391fa2b1fd367e286aa575cb017 100644
--- a/src/su3sc/init_sc.F90
+++ b/src/su3sc/init_sc.F90
@@ -45,23 +45,23 @@ subroutine init_module_sc_size()
end
!-------------------------------------------------------------------------------
-module module_sc_size_r4
-
- integer :: sc_n_real ! number of real numbers of an sc-field
- integer :: sc_n_complex ! number of complex numbers of an sc-field
-
-end
-
-!-------------------------------------------------------------------------------
-subroutine init_module_sc_size_r4()
-
- use module_sc_size_r4
- use module_vol
- implicit none
-
- sc_n_complex = NDIRAC * NCOL * volh
- sc_n_real = NDIRAC * NCOL * volh * SIZE_COMPLEX
-
-end
-
+!!module module_sc_size_r4
+!!
+!! integer :: sc_n_real ! number of real numbers of an sc-field
+!! integer :: sc_n_complex ! number of complex numbers of an sc-field
+!!
+!!end
+!!
+!!!-------------------------------------------------------------------------------
+!!subroutine init_module_sc_size_r4()
+!!
+!! use module_sc_size_r4
+!! use module_vol
+!! implicit none
+!!
+!! sc_n_complex = NDIRAC * NCOL * volh
+!! sc_n_real = NDIRAC * NCOL * volh * SIZE_COMPLEX
+!!
+!!end
+!!
!===============================================================================
diff --git a/src/su3sc/su3.F90 b/src/su3sc/su3.F90
index ee97976bc2dea56b21e19fea08335c71a790e566..be8454929e42032be82d7024da7b1f528888a4dd 100644
--- a/src/su3sc/su3.F90
+++ b/src/su3sc/su3.F90
@@ -303,9 +303,14 @@ subroutine su3_check_det(u)
- u(1,2) * u(2,1) * u(3,3) &
- u(1,3) * u(2,2) * u(3,1)
- if (abs(Re(det) - ONE) > eps) call die("check_su3_det(): Re(det) /= 1")
- if (abs(Im(det)) > eps) call die("check_su3_det(): Im(det) /= 0")
-
+ if (abs(Re(det) - ONE) > eps) then
+ write(0,*)"check_su3_det(): Re(det) /= 1, det=", det
+ call die("check_su3_det(): Re(det) /= 1")
+ endif
+ if (abs(Im(det)) > eps) then
+ write(0,*)"check_su3_det(): Im(det) /= 0, det=", det
+ call die("check_su3_det(): Im(det) /= 0")
+ endif
end
!-------------------------------------------------------------------------------
diff --git a/src/su3sc/su3_2.F90 b/src/su3sc/su3_2.F90
index 2542b332bfffff5f3391688bdc5682a8d74ccb1c..584928fab9b420cf8460206c2b81eca26e1cb3fc 100644
--- a/src/su3sc/su3_2.F90
+++ b/src/su3sc/su3_2.F90
@@ -363,6 +363,7 @@ end
subroutine gen_m_force(p, uuu)
use module_field
use module_vol
+ use module_switches
implicit none
GENERATOR_FIELD, intent(inout) :: p
@@ -370,6 +371,8 @@ subroutine gen_m_force(p, uuu)
integer :: mu, eo, i
SU3 :: w
+ if (switches%boundary_sf) call schr_boundary_zero3(uuu)
+
do mu = 1, DIM
do eo = EVEN, ODD
!$omp parallel do private(w)
diff --git a/src/su3sc/vec.F90 b/src/su3sc/vec.F90
index bfd3452045852c65c6a0f8dabdec1a7f298f344f..00e69cc32d3a5ad02a5544bb8cf22858a38c4160 100644
--- a/src/su3sc/vec.F90
+++ b/src/su3sc/vec.F90
@@ -35,6 +35,12 @@ module vec
complex(4), pointer :: in(:)
end
+#ifdef QUAD
+ real(16) function vec_norm2_c16(in)
+ complex(16), pointer :: in(:)
+ end
+#endif
+
real(8) function vec_dot_c8(x,y)
complex(8), pointer :: x(:),y(:)
end
@@ -42,12 +48,23 @@ module vec
complex(4), pointer :: x(:),y(:)
end
+#ifdef QUAD
+ real(16) function vec_dot_c16(x,y)
+ complex(16), pointer :: x(:),y(:)
+ end
+#endif
+
complex(8) function vec_cdotc_c8(x,y)
complex(8), pointer :: x(:),y(:)
end
complex(8) function vec_cdotc_c4(x,y)
complex(4), pointer :: x(:),y(:)
end
+#ifdef QUAD
+ complex(16) function vec_cdotc_c16(x,y)
+ complex(16), pointer :: x(:),y(:)
+ end
+#endif
end interface
end module vec
@@ -140,4 +157,54 @@ complex(8) function vec_cdotc_c4(x, y) ! Sum_i conjg(x_i) * y_i
enddo
vec_cdotc_c4 = tmp
end function vec_cdotc_c4
+!-------------------------------------------------------------------------------
+! c16
+!-------------------------------------------------------------------------------
+
+#ifdef QUAD
+
+real(16) function vec_norm2_c16(in) ! Sum_i abs(in_i)**2
+ implicit none
+ complex(16), pointer :: in(:)
+ real(16) :: tmp
+ integer :: i
+
+ tmp = 0
+ !$omp parallel do reduction(+: tmp)
+ do i = 1, size(in)
+ tmp = tmp + conjg(in(i)) * in(i)
+ enddo
+ vec_norm2_c16 = tmp
+end function vec_norm2_c16
+!-------------------------------------------------------------------------------
+real(16) function vec_dot_c16(x, y) ! Sum_i [Re(x_i) * Re(y_i) + Im(x_i) * Im(y_i)]
+ implicit none
+ complex(16), pointer :: x(:), y(:)
+ real(16) :: tmp
+ integer :: i
+
+ tmp = 0
+ !$omp parallel do reduction(+: tmp)
+ do i = 1, size(x)
+ tmp = tmp + y(i) * conjg(x(i))
+ enddo
+ vec_dot_c16 = tmp
+end function vec_dot_c16
+!-------------------------------------------------------------------------------
+complex(16) function vec_cdotc_c16(x, y) ! Sum_i conjg(x_i) * y_i
+ implicit none
+ complex(16), pointer :: x(:), y(:)
+ complex(16) :: tmp
+ integer :: i
+
+ tmp = 0
+ !$omp parallel do reduction(+: tmp)
+ do i = 1, size(x)
+ tmp = tmp + y(i) * conjg(x(i))
+ enddo
+ vec_cdotc_c16 = tmp
+end function vec_cdotc_c16
+
+#endif
+
!===============================================================================
diff --git a/src/util/copy.F90 b/src/util/copy.F90
index b704baaaf34d9617a10917276ed1e6d879055fd3..370ec10849b9cefd507636c06e50c0d691157855 100644
--- a/src/util/copy.F90
+++ b/src/util/copy.F90
@@ -28,6 +28,8 @@
# define GAUGE_FIELD_R4 complex(4), dimension (NCOL, NCOL, volh_tot, EVEN:ODD, DIM)
# define CLOVER_FIELD_A_R4 type(type_clover_a_r4), dimension(2, volh, EVEN:ODD)
# define CLOVER_FIELD_B_R4 type(type_clover_b_r4), dimension(2, volh, EVEN:ODD)
+# define CLOVER_FIELD_A_R16 type(type_clover_a_r16), dimension(2, volh, EVEN:ODD)
+# define CLOVER_FIELD_B_R16 type(type_clover_b_r16), dimension(2, volh, EVEN:ODD)
!-------------------------------------------------------------------------------
subroutine gauge_copy_r8_to_r4(u4, u8)
@@ -96,6 +98,50 @@ subroutine clover_b_copy_r8_to_r4(b4, b8)
end
+!-------------------------------------------------------------------------------
+#ifdef QUAD
+subroutine clover_a_copy_r8_to_r16(out, in)
+ use typedef_clover
+ use typedef_clover_r16
+ use module_vol
+ implicit none
+ CLOVER_FIELD_A_R16, intent(out) :: out
+ CLOVER_FIELD_A , intent(in) :: in
+ integer :: i, j, eo
+
+ do eo = EVEN, ODD
+ !$omp parallel do private(j)
+ do i = 1, VOLH
+ do j = 1, 2
+ call type_clover_a_copy_r8_to_r16(out(j, i, eo), in(j, i, eo))
+ enddo
+ enddo
+ enddo
+
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine clover_b_copy_r8_to_r16(out, in)
+ use typedef_clover
+ use typedef_clover_r16
+ use module_vol
+ implicit none
+ CLOVER_FIELD_B_R16, intent(out) :: out
+ CLOVER_FIELD_B , intent(in) :: in
+ integer :: i, j, eo
+
+ do eo = EVEN, ODD
+ !$omp parallel do private(j)
+ do i = 1, VOLH
+ do j = 1, 2
+ call type_clover_b_copy_r8_to_r16(out(j, i, eo), in(j, i, eo))
+ enddo
+ enddo
+ enddo
+
+end
+#endif
!-------------------------------------------------------------------------------
subroutine type_clover_a_copy_r8_to_r4(a4, a8)
use typedef_clover
@@ -160,6 +206,71 @@ subroutine type_clover_b_copy_r8_to_r4(b4, b8)
end
+!-------------------------------------------------------------------------------
+#ifdef QUAD
+subroutine type_clover_a_copy_r8_to_r16(out, in)
+ use typedef_clover
+ use typedef_clover_r16
+ implicit none
+ type(type_clover_a_r16), intent(out) :: out
+ type(type_clover_a), intent(in) :: in
+
+ out%i11 = in%i11
+ out%i22 = in%i22
+ out%i12 = in%i12
+ out%i13 = in%i13
+ out%i14 = in%i14
+ out%i15 = in%i15
+ out%i16 = in%i16
+ out%i23 = in%i23
+ out%i24 = in%i24
+ out%i25 = in%i25
+ out%i26 = in%i26
+ out%i33 = in%i33
+ out%i44 = in%i44
+ out%i34 = in%i34
+ out%i35 = in%i35
+ out%i36 = in%i36
+ out%i45 = in%i45
+ out%i46 = in%i46
+ out%i55 = in%i55
+ out%i66 = in%i66
+ out%i56 = in%i56
+
+end
+
+!-------------------------------------------------------------------------------
+subroutine type_clover_b_copy_r8_to_r16(out, in)
+ use typedef_clover
+ use typedef_clover_r16
+ implicit none
+ type(type_clover_b_r16), intent(out) :: out
+ type(type_clover_b), intent(in) :: in
+
+ out%i21 = in%i21
+ out%i31 = in%i31
+ out%i32 = in%i32
+ out%i41 = in%i41
+ out%i42 = in%i42
+ out%i43 = in%i43
+ out%i51 = in%i51
+ out%i52 = in%i52
+ out%i53 = in%i53
+ out%i54 = in%i54
+ out%i61 = in%i61
+ out%i62 = in%i62
+ out%i63 = in%i63
+ out%i64 = in%i64
+ out%i65 = in%i65
+ out%i11 = in%i11
+ out%i22 = in%i22
+ out%i33 = in%i33
+ out%i44 = in%i44
+ out%i55 = in%i55
+ out%i66 = in%i66
+
+end
+#endif
!-------------------------------------------------------------------------------
subroutine type_clover_a_copy_r8(out, in)
use typedef_clover
diff --git a/src/util/init_confs2.F90 b/src/util/init_confs2.F90
index 2ebe72907fdd13a2cc4c3740148aab0962dfbe0b..ae40afefd44569195cbe73fe323b65a2459cf72e 100644
--- a/src/util/init_confs2.F90
+++ b/src/util/init_confs2.F90
@@ -35,6 +35,9 @@ subroutine init_confs2(para, conf)
use typedef_para
use module_p_interface
use module_p_interface_r4
+#ifdef QUAD
+ use module_p_interface_r16
+#endif
use module_switches
use module_dd
implicit none
@@ -77,14 +80,21 @@ subroutine init_confs2(para, conf)
endif
allocate(gauge(count)) ! for u ds cl
allocate(gauge_r4(count)) ! for u ds cl
+#ifdef QUAD
+ allocate(gauge_r16(count)) ! for u ds cl
+#endif
gauge(1:count)%init = .true.
- do i = 2, count
+ do i = 2, 2!!count
nullify(gauge(i)%u)
call allocate_g_field(gauge(i)%u)
enddo
if (switches%dynamical) then
nullify(gauge_r4(2)%u)
call allocate_g_field_r4(gauge_r4(2)%u)
+#ifdef QUAD
+ nullify(gauge_r16(2)%u)
+ call allocate_g_field_r16(gauge_r16(2)%u)
+#endif
if (switches%stout_ds) then
gauge(2)%sid = 1
else
@@ -105,6 +115,7 @@ subroutine init_confs2(para, conf)
endif
endif
gauge(1)%u => conf(1)%u !!! conf(1)%u must have "target" attribution
+ if (switches%boundary_sf) call schr_boundary_gauge(gauge(1)%u)
if (switches%stout) then
allocate(stout(1))
@@ -128,6 +139,9 @@ subroutine init_clover_field(para)
use module_input
use module_p_interface
use module_p_interface_r4
+#ifdef QUAD
+ use module_p_interface_r16
+#endif
implicit none
type(hmc_para) :: para
integer, dimension(:), allocatable :: nf
@@ -167,6 +181,10 @@ subroutine init_clover_field(para)
nullify(clover_r4)
allocate(clover(cid)) ! # of kappa
allocate(clover_r4(cid)) ! # of kappa
+#ifdef QUAD
+ nullify(clover_r16)
+ allocate(clover_r16(cid)) ! # of kappa
+#endif
allocate(nf(cid))
allocate(theta(cid))
allocate(csw(cid))
@@ -184,6 +202,14 @@ subroutine init_clover_field(para)
call allocate_clover_field_a_r4(clover_r4(i)%a)
call allocate_clover_field_a_r4(clover_r4(i)%i)
call allocate_clover_field_b_r4(clover_r4(i)%b)
+#ifdef QUAD
+ nullify(clover_r16(i)%a)
+ nullify(clover_r16(i)%i)
+ nullify(clover_r16(i)%b)
+ call allocate_clover_field_a_r16(clover_r16(i)%a)
+ call allocate_clover_field_a_r16(clover_r16(i)%i)
+ call allocate_clover_field_b_r16(clover_r16(i)%b)
+#endif
enddo
endif
diff --git a/src/util/init_imp.F90 b/src/util/init_imp.F90
index 35b58ec49bf8ce23c382d5081362aa19a8b5d990..feea07cdb86430e7666890513b0970ed30446e3b 100644
--- a/src/util/init_imp.F90
+++ b/src/util/init_imp.F90
@@ -101,6 +101,9 @@ subroutine init_imp_all(doall)
call init_clover(i)
enddo
endif
+
+ call init_rid() !! just to initialize rid for next print
+
!
! check
!
@@ -215,7 +218,7 @@ subroutine init_gauge(id)
if (id == 2) then
select case (version_of_d())
- case(4,45,8,85,520,100)
+ case(4,45,8,85,520,100,101,102,103)
call d_g_init(gauge(2)%u)
end select
call u2ddu(gauge(2)%u)
@@ -248,12 +251,19 @@ subroutine init_clover(id)
!! write(0,*)id, size(clover), size(gauge)
!! stop
- call clover_init(clover(id)%a, clover(id)%i, clover(id)%b, gauge(1)%u, &
+ call clover_init(clover(id)%a, clover(id)%i, clover(id)%b, gauge(3)%u, &
clover(id)%cswkappa, m1, m2)
DEBUG2S("Start: init_clover 3")
call clover_a_copy_r8_to_r4(clover_r4(id)%a, clover(id)%a)
call clover_a_copy_r8_to_r4(clover_r4(id)%i, clover(id)%i)
call clover_b_copy_r8_to_r4(clover_r4(id)%b, clover(id)%b)
+ DEBUG2S("Start: init_clover 3-5")
+
+#ifdef QUAD
+ call clover_a_copy_r8_to_r16(clover_r16(id)%a, clover(id)%a)
+ call clover_a_copy_r8_to_r16(clover_r16(id)%i, clover(id)%i)
+ call clover_b_copy_r8_to_r16(clover_r16(id)%b, clover(id)%b)
+#endif
DEBUG2S("Start: init_clover 4")
call clover2cloverdd(id)