Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in
Toggle navigation
Open sidebar
McMule
handyG
Commits
bdc545ff
Commit
bdc545ff
authored
Jul 09, 2019
by
ulrich_y
Browse files
Undid some stuff related to ieps
parent
522fa0b7
Changes
6
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
52 additions
and
1643 deletions
+52
-1643
src/gpl_module.f90
src/gpl_module.f90
+24
-20
src/ieps.f90
src/ieps.f90
+0
-144
src/maths_functions.f90
src/maths_functions.f90
+28
-5
src/other_stuff/functions_old.F95
src/other_stuff/functions_old.F95
+0
-1284
src/other_stuff/global_def_old.f95
src/other_stuff/global_def_old.f95
+0
-87
src/other_stuff/shuffle_algebra.f90
src/other_stuff/shuffle_algebra.f90
+0
-103
No files found.
src/gpl_module.f90
View file @
bdc545ff
...
...
@@ -18,7 +18,7 @@ CONTAINS
integer
::
l
type
(
inum
)
::
y
complex
(
kind
=
prec
)
::
GPL_zero_zi
GPL_zero_zi
=
1.0_prec
/
factorial
(
l
)
*
log
(
y
)
**
l
GPL_zero_zi
=
1.0_prec
/
factorial
(
l
)
*
log
(
y
%
c
)
**
l
END
FUNCTION
GPL_zero_zi
FUNCTION
is_convergent
(
z
,
y
)
...
...
@@ -103,7 +103,7 @@ CONTAINS
!res = pending_integral(p,2,[sub_ieps(g(1))]) - pending_integral(p,2,[cmplx(0.0)]) &
! + G_flat(p(2:size(p)), p(1)) * log(-sub_ieps(g(1)))
res
=
pending_integral
(
p
,
2
,[
g
(
1
)])
-
pending_integral
(
p
,
2
,[
izero
])
&
+
G_flat
(
p
(
2
:
size
(
p
)),
p
(
1
))
*
log
(
neg
(
g
(
1
)
))
+
G_flat
(
p
(
2
:
size
(
p
)),
p
(
1
))
*
(
log
(
-
g
(
1
)
%
c
)
+
cmplx
(
0
,
2
*
pi
))
return
end
if
...
...
@@ -248,16 +248,19 @@ CONTAINS
! improves the convergence by applying the Hoelder convolution to G(z1,...zk,1)
type
(
inum
)
::
z
(:),
oneminusz
(
size
(
z
))
complex
(
kind
=
prec
)
::
res
type
(
inum
),
parameter
::
p
=
inum
(
2.0
,
+1
)
complex
(
kind
=
prec
),
parameter
::
p
=
2.0
integer
::
k
,
j
if
(
verb
>=
30
)
print
*
,
'requires Hoelder convolution'
oneminusz
=
ione
-
z
!TODO ieps?!??
do
j
=
1
,
size
(
z
)
oneminusz
(
j
)
=
inum
(
1.
-
z
(
j
)
%
c
,
-
z
(
j
)
%
i0
)
enddo
k
=
size
(
z
)
res
=
G_flat
(
z
,
i
one
/
p
)
! first term of the sum
res
=
res
+
(
-1
)
**
k
*
G_flat
(
oneminusz
(
k
:
1
:
-1
),
i
one
-
ione
/
p
)
res
=
G_flat
(
z
,
i
num
(
1.
/
p
,
di0
)
)
! first term of the sum
res
=
res
+
(
-1
)
**
k
*
G_flat
(
oneminusz
(
k
:
1
:
-1
),
i
num
(
1.
-1
/
p
,
di0
)
)
do
j
=
1
,
k
-1
res
=
res
+
(
-1
)
**
j
*
G_flat
(
oneminusz
(
j
:
1
:
-1
),
i
one
-
ione
/
p
)
*
G_flat
(
z
(
j
+1
:
k
),
i
one
/
p
)
res
=
res
+
(
-1
)
**
j
*
G_flat
(
oneminusz
(
j
:
1
:
-1
),
i
num
(
1.
-1
/
p
,
di0
)
)
*
G_flat
(
z
(
j
+1
:
k
),
i
num
(
1.
/
p
,
di0
)
)
end
do
END
FUNCTION
improve_convergence
...
...
@@ -274,7 +277,7 @@ CONTAINS
if
(
size
(
z_flat
)
==
1
)
then
if
(
abs
(
z_flat
(
1
)
-
y
)
<=
zero
)
then
if
(
abs
(
z_flat
(
1
)
%
c
-
y
%
c
)
<=
zero
)
then
res
=
0
return
end
if
...
...
@@ -289,16 +292,16 @@ CONTAINS
! is just a logarithm?
if
(
all
(
abs
(
z_flat
)
<
zero
))
then
if
(
verb
>=
70
)
print
*
,
'all z are zero'
res
=
log
(
y
)
**
size
(
z_flat
)
/
factorial
(
size
(
z_flat
))
res
=
log
(
y
%
c
)
**
size
(
z_flat
)
/
factorial
(
size
(
z_flat
))
return
end
if
if
(
size
(
z_flat
)
==
1
)
then
if
(
verb
>=
70
)
print
*
,
'is just a logarithm'
if
(
abs
(
z_flat
(
1
))
<=
zero
)
then
res
=
log
(
y
)
res
=
log
(
y
%
c
)
return
end
if
res
=
log
((
z_flat
(
1
)
-
y
)/
z_flat
(
1
))
res
=
plog1
(
y
,
z_flat
(
1
))
!
log((z_flat(1) - y)/z_flat(1))
return
end
if
...
...
@@ -309,7 +312,7 @@ CONTAINS
if
(
is_depth_one
)
then
! case m >= 2, other already handled above
if
(
verb
>=
70
)
print
*
,
'is just a polylog'
res
=
-
polylog
(
m_1
,
y
/
z_flat
(
m_1
))
res
=
-
polylog
(
m_1
,
y
,
z_flat
(
m_1
))
!-polylog(m_1,
y/z_flat(m_1))
return
end
if
...
...
@@ -324,7 +327,7 @@ CONTAINS
if
(
verb
>=
30
)
print
*
,
'need to remove trailing zeroes'
allocate
(
s
(
j
,
j
))
s
=
shuffle_with_zero
(
z_flat
(
1
:
j
-1
))
res
=
log
(
y
)
*
G_flat
(
z_flat
(
1
:
size
(
z_flat
)
-1
),
y
)
res
=
log
(
y
%
c
)
*
G_flat
(
z_flat
(
1
:
size
(
z_flat
)
-1
),
y
)
do
i
=
1
,
size
(
s
,
1
)
res
=
res
-
G_flat
([
s
(
i
,:),
z_flat
(
j
),
zeroes
(
kminusj
-1
)],
y
)
end
do
...
...
@@ -342,7 +345,8 @@ CONTAINS
! requires Hoelder convolution?
if
(
any
(
1.0
<=
abs
(
z_flat
%
c
/
y
%
c
)
.and.
abs
(
z_flat
%
c
/
y
%
c
)
<=
1.1
)
)
then
res
=
improve_convergence
(
z_flat
/
y
)
!TODO
res
=
improve_convergence
(
toinum
(
z_flat
%
c
/
y
%
c
))
return
end
if
...
...
@@ -390,8 +394,8 @@ CONTAINS
! assumes zero arguments expressed through the m's
integer
::
m
(:),
k
,
i
type
(
inum
)
::
z
(:),
y
,
x
(
k
),
z_flat
(
sum
(
m
))
complex
(
kind
=
prec
)
::
res
type
(
inum
)
::
z
(:),
y
,
z_flat
(
sum
(
m
))
complex
(
kind
=
prec
)
::
res
,
x
(
k
)
! print*, 'called G_condensed with args'
! print*, 'm = ', m
...
...
@@ -418,15 +422,15 @@ CONTAINS
res
=
G_flat
(
z_flat
,
y
)
return
end
if
x
(
1
)
=
y
/
z
(
1
)
!TODO is that okay?
x
(
1
)
=
y
%
c
/
z
(
1
)
%
c
do
i
=
2
,
k
x
(
i
)
=
z
(
i
-1
)/
z
(
i
)
x
(
i
)
=
z
(
i
-1
)
%
c
/
z
(
i
)
%
c
end
do
! print*, 'computed using Li with '
! print*, 'm = ', m
! print*, 'x = ', x
res
=
(
-1
)
**
k
*
MPL
(
m
,
x
%
c
)
res
=
(
-1
)
**
k
*
MPL
(
m
,
x
)
END
FUNCTION
G_condensed
...
...
src/ieps.f90
View file @
bdc545ff
...
...
@@ -15,27 +15,9 @@ MODULE ieps
type
(
inum
),
parameter
::
marker
=
inum
(
0.
,
5
)
interface
operator
(
*
)
module
procedure
multinumss
,
multinumvs
end
interface
operator
(
*
)
interface
operator
(
+
)
module
procedure
addinumss
,
addinumvs
end
interface
operator
(
+
)
interface
operator
(
-
)
module
procedure
subinumss
,
subinumvs
,
subinumsv
end
interface
operator
(
-
)
interface
operator
(
**
)
module
procedure
powinum
end
interface
operator
(
**
)
interface
operator
(/)
module
procedure
divint
,
divinumss
,
divinumvs
end
interface
operator
(/)
interface
abs
module
procedure
absinum
,
absinumv
end
interface
abs
interface
log
module
procedure
loginum
end
interface
log
interface
toinum
module
procedure
toinum_cmplx
,
toinum_real
,
toinum_int
...
...
@@ -47,79 +29,6 @@ MODULE ieps
module
procedure
realis
,
realiv
end
interface
real
CONTAINS
FUNCTION
NEG
(
n1
)
implicit
none
type
(
inum
),
intent
(
in
)
::
n1
type
(
inum
)
::
neg
neg
=
inum
(
-
n1
%
c
,
-
n1
%
i0
)
END
FUNCTION
FUNCTION
MULTINUMSS
(
n1
,
n2
)
implicit
none
type
(
inum
),
intent
(
in
)
::
n1
,
n2
type
(
inum
)
::
multinumss
multinumss
=
inum
(
n1
%
c
*
n2
%
c
,
int
(
sign
(
1._prec
,
real
(
n1
%
c
)
*
n2
%
i0
+
real
(
n2
%
c
)
*
n1
%
i0
))
)
END
FUNCTION
MULTINUMSS
FUNCTION
MULTINUMVS
(
n1
,
n2
)
implicit
none
type
(
inum
),
intent
(
in
)
::
n1
(:),
n2
type
(
inum
)
::
multinumvs
(
size
(
n1
))
integer
i
do
i
=
1
,
size
(
n1
)
multinumvs
(
i
)
=
inum
(
n1
(
i
)
%
c
*
n2
%
c
,
int
(
sign
(
1._prec
,
real
(
n1
(
i
)
%
c
)
*
n2
%
i0
+
real
(
n2
%
c
)
*
n1
(
i
)
%
i0
))
)
enddo
END
FUNCTION
MULTINUMVS
FUNCTION
ADDINUMSS
(
n1
,
n2
)
implicit
none
type
(
inum
),
intent
(
in
)
::
n1
,
n2
type
(
inum
)
::
addinumss
!TODO: what *is* the sum?
addinumss
=
inum
(
n1
%
c
+
n2
%
c
,
n1
%
i0
)
END
FUNCTION
ADDINUMSS
FUNCTION
ADDINUMVS
(
n1
,
n2
)
implicit
none
type
(
inum
),
intent
(
in
)
::
n1
(:),
n2
type
(
inum
)
::
addinumvs
(
size
(
n1
))
!TODO: what *is* the sum?
integer
i
do
i
=
1
,
size
(
n1
)
addinumvs
(
i
)
=
inum
(
n1
(
i
)
%
c
+
n2
%
c
,
n1
(
i
)
%
i0
)
enddo
END
FUNCTION
ADDINUMVS
FUNCTION
SUBINUMSS
(
n1
,
n2
)
implicit
none
type
(
inum
),
intent
(
in
)
::
n1
,
n2
type
(
inum
)
::
subinumss
!TODO: what *is* the sum?
subinumss
=
inum
(
n1
%
c
-
n2
%
c
,
n1
%
i0
)
END
FUNCTION
SUBINUMSS
FUNCTION
SUBINUMVS
(
n1
,
n2
)
implicit
none
type
(
inum
),
intent
(
in
)
::
n1
(:),
n2
type
(
inum
)
::
subinumvs
(
size
(
n1
))
!TODO: what *is* the sum?
integer
i
do
i
=
1
,
size
(
n1
)
subinumvs
(
i
)
=
inum
(
n1
(
i
)
%
c
-
n2
%
c
,
n1
(
i
)
%
i0
)
enddo
END
FUNCTION
SUBINUMvs
FUNCTION
SUBINUMSV
(
n2
,
n1
)
implicit
none
type
(
inum
),
intent
(
in
)
::
n1
(:),
n2
type
(
inum
)
::
subinumsv
(
size
(
n1
))
!TODO: what *is* the sum?
integer
i
do
i
=
1
,
size
(
n1
)
subinumsv
(
i
)
=
inum
(
n2
%
c
-
n1
(
i
)
%
c
,
n1
(
i
)
%
i0
)
enddo
END
FUNCTION
SUBINUMSV
FUNCTION
ABSINUM
(
n1
)
implicit
none
type
(
inum
),
intent
(
in
)
::
n1
...
...
@@ -134,59 +43,6 @@ CONTAINS
absinumv
=
abs
(
n1
%
c
)
END
FUNCTION
ABSINUMV
FUNCTION
POWINUM
(
n1
,
m
)
implicit
none
type
(
inum
),
intent
(
in
)
::
n1
integer
,
intent
(
in
)
::
m
type
(
inum
)
::
powinum
if
(
aimag
(
n1
%
c
)
<
zero
)
then
powinum
=
inum
(
cmplx
(
real
(
n1
%
c
)
**
m
,
0.
),
int
(
sign
(
1._prec
,
real
(
n1
%
c
)
**
m
))
)
else
powinum
=
inum
(
n1
%
c
**
m
,
n1
%
i0
)
endif
END
FUNCTION
POWINUM
FUNCTION
DIVINT
(
n1
,
m
)
implicit
none
type
(
inum
),
intent
(
in
)
::
n1
integer
,
intent
(
in
)
::
m
type
(
inum
)
::
divint
divint
=
inum
(
n1
%
c
/
m
,
n1
%
i0
*
sign
(
1
,
m
))
END
FUNCTION
DIVINT
FUNCTION
DIVINUMss
(
n1
,
n2
)
implicit
none
type
(
inum
),
intent
(
in
)
::
n1
,
n2
type
(
inum
)
::
divinumss
divinumss
=
inum
(
n1
%
c
/
n2
%
c
,
int
(
sign
(
1.
,
real
(
n2
%
c
)
*
n1
%
i0
-
real
(
n1
%
c
)
*
n2
%
i0
)))
END
FUNCTION
DIVINUMss
FUNCTION
DIVINUMvs
(
n1
,
n2
)
implicit
none
type
(
inum
),
intent
(
in
)
::
n1
(:),
n2
type
(
inum
)
::
divinumvs
(
size
(
n1
))
integer
i
do
i
=
1
,
size
(
n1
)
divinumvs
(
i
)
=
inum
(
n1
(
i
)
%
c
/
n2
%
c
,
int
(
sign
(
1.
,
real
(
n2
%
c
)
*
n1
(
i
)
%
i0
-
real
(
n1
(
i
)
%
c
)
*
n2
%
i0
)))
enddo
END
FUNCTION
DIVINUMvs
FUNCTION
LOGINUM
(
n1
)
implicit
none
type
(
inum
),
intent
(
in
)
::
n1
complex
(
kind
=
prec
)
::
loginum
if
(
abs
(
aimag
(
n1
%
c
))
.lt.
zero
)
then
loginum
=
log
(
abs
(
real
(
n1
%
c
)))
if
(
real
(
n1
%
c
)
<
0
)
then
loginum
=
loginum
+
cmplx
(
0
,
n1
%
i0
*
pi
)
endif
else
loginum
=
log
(
n1
%
c
)
endif
END
FUNCTION
LOGINUM
FUNCTION
TOINUM_cmplx
(
z
,
s
)
complex
(
kind
=
prec
)
::
z
(:)
type
(
inum
)
::
toinum_cmplx
(
size
(
z
))
...
...
src/maths_functions.f90
View file @
bdc545ff
...
...
@@ -3,6 +3,9 @@ MODULE maths_functions
use
globals
use
utils
implicit
none
interface
polylog
module
procedure
polylog1
,
polylog2
end
interface
polylog
CONTAINS
FUNCTION
zeta
(
n
)
...
...
@@ -297,11 +300,11 @@ CONTAINS
END
FUNCTION
RECURSIVE
FUNCTION
polylog
(
m
,
x
)
result
(
res
)
RECURSIVE
FUNCTION
polylog
1
(
m
,
x
)
result
(
res
)
! computes the polylog
integer
::
m
type
(
inum
)
::
x
type
(
inum
)
::
x
,
inv
complex
(
kind
=
prec
)
::
res
if
(
verb
>=
70
)
print
*
,
'called polylog('
,
m
,
','
,
x
%
c
,
x
%
i0
,
')'
...
...
@@ -312,8 +315,9 @@ CONTAINS
res
=
-
(
1.
-
2.
**
(
1
-
m
))
*
zeta
(
m
)
return
else
if
(
abs
(
x
)
.gt.
1
)
then
res
=
(
-1
)
**
(
m
-1
)
*
polylog
(
m
,
ione
/
x
)
&
-
cmplx
(
0
,
2
*
pi
)
**
m
*
bernoulli_polynomial
(
m
,
0.5
-
cmplx
(
0.
,
1.
)
*
log
(
neg
(
x
))/
2
/
pi
)
/
factorial
(
m
)
inv
=
inum
(
1.
/
x
%
c
,
x
%
i0
)
res
=
(
-1
)
**
(
m
-1
)
*
polylog
(
m
,
inv
)
&
-
cmplx
(
0
,
2
*
pi
)
**
m
*
bernoulli_polynomial
(
m
,
0.5
-
cmplx
(
0.
,
1.
)
*
conjg
(
log
(
-
x
%
c
))/
2
/
pi
)
/
factorial
(
m
)
return
endif
...
...
@@ -324,7 +328,26 @@ CONTAINS
else
res
=
naive_polylog
(
m
,
x
%
c
)
end
if
END
FUNCTION
polylog
END
FUNCTION
polylog1
RECURSIVE
FUNCTION
polylog2
(
m
,
x
,
y
)
result
(
res
)
type
(
inum
)
::
x
,
y
integer
m
complex
(
kind
=
prec
)
::
res
res
=
polylog1
(
m
,
inum
(
x
%
c
/
y
%
c
,
di0
))
END
FUNCTION
POLYLOG2
FUNCTION
PLOG1
(
a
,
b
)
! calculates log(1-a/b)
implicit
none
type
(
inum
)
::
a
,
b
complex
(
kind
=
prec
)
plog1
plog1
=
log
(
1.
-
a
%
c
/
b
%
c
)
END
FUNCTION
END
MODULE
maths_functions
...
...
src/other_stuff/functions_old.F95
deleted
100644 → 0
View file @
522fa0b7
This diff is collapsed.
Click to expand it.
src/other_stuff/global_def_old.f95
deleted
100644 → 0
View file @
522fa0b7
MODULE
GLOBAL_DEF
implicit
none
!! ----------
!! parameters
!! ----------
integer
,
parameter
::
prec
=
selected_real_kind
(
15
,
32
)
real
(
kind
=
prec
),
parameter
::
cw
=
0.876613
real
(
kind
=
prec
),
parameter
::
sw
=
0.481196
real
(
kind
=
prec
),
parameter
::
pi
=
3.14159265358979323846_prec
real
(
kind
=
prec
),
parameter
::
z3
=
1.20205690315959428540_prec
real
(
kind
=
prec
),
parameter
::
log2
=
0.693147180559945309417_prec
real
(
kind
=
prec
),
parameter
::
conv
=
3.893850E+8
! convert GeV to pb
real
(
kind
=
prec
),
parameter
::
xsc
=
0._prec
! FDH=>1 vs HV=>0
real
(
kind
=
prec
),
parameter
::
Nc
=
3._prec
real
(
kind
=
prec
),
parameter
::
Tf
=
0.5_prec
real
(
kind
=
prec
),
parameter
::
Cf
=
(
Nc
**
2-1
)/(
2
*
Nc
)
real
(
kind
=
prec
),
parameter
::
Nh
=
1._prec
real
(
kind
=
prec
),
parameter
::
Nf
=
5._prec
complex
(
kind
=
prec
),
parameter
::
imag
=
(
0.0_prec
,
1.0_prec
)
real
(
kind
=
prec
),
parameter
::
zero
=
1.0E-50_prec
real
(
kind
=
prec
),
parameter
::
alpha_ew
=
0.03394_prec
! real (kind=prec), parameter :: alpha = 1/127.9_prec
! real (kind=prec), parameter :: alpha = 1./137.0359997_prec
! real (kind=prec), parameter :: GF = 1.16637E-11_prec ! MeV^-2
real
(
kind
=
prec
),
parameter
::
GF
=
1._prec
real
(
kind
=
prec
),
parameter
::
alpha
=
1._prec
real
(
kind
=
prec
),
parameter
::
Mmu
=
105.658372_prec
! MeV
real
(
kind
=
prec
),
parameter
::
Mel
=
0.51099893_prec
! MeV
! real (kind=prec), parameter :: Mel = 10._prec ! MeV
real
(
kind
=
prec
),
parameter
::
Mtau
=
1776.82_prec
! MeV
real
(
kind
=
prec
),
parameter
::
xi_sep
=
1.0E-10_prec
real
(
kind
=
prec
),
parameter
::
del_sep
=
1.0E-10_prec
! character (len=3), parameter :: cgamma = "exp"
character
(
len
=
3
),
parameter
::
cgamma
=
"gam"
integer
print_ok
,
throw_away
!! ---------
!! variables
!! ---------
integer
::
ran_seed
=
1
real
(
kind
=
prec
)
::
p1
(
4
),
p2
(
4
),
p3
(
4
),
p4
(
4
),
p5
(
4
),
p6
(
4
),
p7
(
4
),
&
p8
(
4
),
p9
(
4
),
pol1
(
4
)
real
(
kind
=
prec
)
::
mu
,
musq
,
delcut
,
xinormcut
real
(
kind
=
prec
)
::
xinormcut1
,
xinormcut2
character
(
len
=
8
)
::
flavour
real
(
kind
=
prec
)
::
Mm
! MeV
real
(
kind
=
prec
)
::
Me
! MeV
contains
SUBROUTINE
CRASH
(
function_name
)
character
(
len
=*
)
::
function_name
write
(
6
,
*
)
"Program crashes because of a call to the function "
,
&
function_name
stop
END
SUBROUTINE
CRASH
END
MODULE
GLOBAL_DEF
src/other_stuff/shuffle_algebra.f90
deleted
100644 → 0
View file @
522fa0b7
! An implementation of the shuffle algebra
! in accordance with 1904.07279v1, polylogs for the masses, p.7-8
! This implementation defines words as strings of characters and shuffles them
! into sums of words.
PROGRAM
shuffle_algebra
implicit
none
! Currently words can be no longer than the following values
! Might need to be adjusted
integer
,
parameter
::
max_word_size
=
6
integer
,
parameter
::
max_word_sum_size
=
1000
type
word
character
(
len
=
max_word_size
)
::
letters
integer
::
length
endtype
word
type
word_sum
type
(
word
),
dimension
(
max_word_sum_size
)
::
words
integer
::
length
end
type
word_sum
type
(
word
)
::
v1
=
word
(
"abc"
,
3
)
type
(
word
)
::
v2
=
word
(
"123"
,
3
)
type
(
word
)
::
w1
type
(
word_sum
)
::
ws
,
ws1
,
ws2
ws
=
shuffle_product
(
v1
,
v2
)
print
*
,
ws
%
words
CONTAINS
RECURSIVE
FUNCTION
shuffle_product
(
v1
,
v2
)
result
(
res
)
! takes two words and returns shuffle product as a word sum
type
(
word_sum
)
::
res
,
p1
,
p2
,
s1
,
s2
type
(
word
)
::
v1
,
v2
,
w1
,
w2
type
(
character
)
::
alpha
,
beta
! print*, '----------------------'
! print*, 'v1 = ', v1
! print*, 'v2 = ', v2
if
(
v1
%
length
==
0
)
then
res
=
word_sum
((/
v2
/),
1
)
else
if
(
v2
%
length
==
0
)
then
res
=
word_sum
((/
v1
/),
1
)
else
alpha
=
v1
%
letters
(
1
:
1
)
beta
=
v2
%
letters
(
1
:
1
)
w1
=
word
(
v1
%
letters
(
2
:),
v1
%
length
-1
)
w2
=
word
(
v2
%
letters
(
2
:),
v2
%
length
-1
)
p1
=
shuffle_product
(
w1
,
v2
)
p2
=
shuffle_product
(
v1
,
w2
)
s1
=
times
(
alpha
,
p1
)
s2
=
times
(
beta
,
p2
)
res
=
combined_word_sum
(
s1
,
s2
)
end
if
END
FUNCTION
shuffle_product
FUNCTION
combined_word_sum
(
s1
,
s2
)
! combines word sums s1 and s2 into s
type
(
word_sum
)
::
s1
,
s2
,
combined_word_sum
type
(
word
),
dimension
(
s1
%
length
+
s2
%
length
)
::
combined_words
integer
::
length
length
=
s1
%
length
+
s2
%
length
combined_words
(
1
:
s1
%
length
)
=
s1
%
words
(
1
:
s1
%
length
)
combined_words
(
s1
%
length
+1
:
length
)
=
s2
%
words
(
1
:
s2
%
length
)
combined_word_sum
=
word_sum
(
combined_words
,
length
)
END
FUNCTION
combined_word_sum
FUNCTION
times
(
l
,
ws
)
! computes word sum from letter times word sum, e.g. a(bc + cd) = abc + acd
character
::
l
type
(
word_sum
)
::
ws
type
(
word_sum
)
::
times
integer
::
i
times
%
length
=
ws
%
length
do
i
=
1
,
ws
%
length
times
%
words
(
i
)
%
letters
=
l
//
ws
%
words
(
i
)
%
letters
end
do
END
FUNCTION
times
SUBROUTINE
print_word_sum
(
ws
)
! prints a sum of word with plusses for easy readibility
integer
::
i
type
(
word_sum
)
::
ws
do
i
=
1
,
ws
%
length
write
(
*
,
fmt
=
"(1xai0)"
,
advance
=
"no"
)
ws
%
words
(
i
)
%
letters
if
(
i
/
=
ws
%
length
)
then
write
(
*
,
fmt
=
"(1xai0)"
,
advance
=
"no"
)
" + "
end
if
end
do
END
SUBROUTINE
print_word_sum
END
PROGRAM
shuffle_algebra
ulrich_y
@ulrich_y
mentioned in commit
3b2d170d
·
Sep 18, 2019
mentioned in commit
3b2d170d
mentioned in commit 3b2d170d66e4d67a20a2aa7f2d7f91f6e0044ff4
Toggle commit list
ulrich_y
@ulrich_y
mentioned in commit
09592838
·
Oct 03, 2019
mentioned in commit
09592838
mentioned in commit 09592838d02d3fe6257aaba011ef9900130f02aa
Toggle commit list
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment