Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Keyboard shortcuts
?
Submit feedback
Sign in
Toggle navigation
H
handyG
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Analytics
Analytics
Repository
Value Stream
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Commits
Open sidebar
McMule
handyG
Commits
bdc545ff
Commit
bdc545ff
authored
Jul 09, 2019
by
ulrich_y
2
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
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
),
ione
/
p
)
res
=
res
+
(
-1
)
**
j
*
G_flat
(
oneminusz
(
j
:
1
:
-1
),
i
num
(
1.
-1
/
p
,
di0
))
*
G_flat
(
z
(
j
+1
:
k
),
inum
(
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