Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
A
AculUtils
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
0
Issues
0
List
Board
Labels
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Pavel Sharov
AculUtils
Commits
a3d653d1
Commit
a3d653d1
authored
May 03, 2024
by
Pavel
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Update code for ELOSS fortran subroutine
parent
840bb8e1
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
236 additions
and
300 deletions
+236
-300
ELOSS.f90
TELoss/ELOSS.f90
+236
-300
No files found.
TELoss/ELOSS.f90
View file @
a3d653d1
...
...
@@ -4,320 +4,256 @@
!== File: ELOSS.f90
!== Date: 08/12/2000
!======================================================================
! ELOSS.f90
! ELOSS.f90
!
! FUNCTIONS/SUBROUTINES exported from ELOSS.dll:
! ELOSS - subroutine
! ELOSS - subroutine
!======================================================================
!== Date 2024-05-03
! Some reworking of code:
!
subroutine
ELOSS
(
NEL
,
ZEL
,
AEL
,
WEL
,
DEN
,
ZP
,
AP
,
NE
,
ETAB
,
RE
,
ZW
,
AW
)
! * remove obsolete fortran instructions;
! * replace common block with module;
! * change precision to standard C double;
! * remove restriction for 5 elements in material.
module
m_eloss
use
iso_c_binding
,
only
:
c_int
,
c_double
real
(
c_double
),
allocatable
,
dimension
(:),
private
::
adj
,
as
,
z
,
f
,
um
real
(
c_double
),
private
::
oz
,
ro
,
azm
,
aj
,
zion
,
aion
,
zmed
,
amed
integer
,
private
::
jc
contains
subroutine
ELOSS
(
NEL
,
ZEL
,
AEL
,
WEL
,
DEN
,
ZP
,
AP
,
NE
,
ETAB
,
RE
,
ZW
,
AW
)&
bind
(
C
,
name
=
'eloss_'
)
! Expose subroutine ELOSS to users of this DLL
!
!DEC$ ATTRIBUTES DLLEXPORT::ELOSS
IMPLICIT
REAL
*
8
(
A
-
H
,
O
-
Z
)
INTERFACE
SUBROUTINE
rde
(
E
,
R
,
R1
,
R2
,
IRE
)
REAL
*
8
E
,
R
,
R1
,
R2
INTEGER
IRE
END
SUBROUTINE
rde
END
INTERFACE
IMPLICIT
none
! Variables
! Input:
INTEGER
NEL
,
NE
REAL
*
8
ZEL
(
NEL
),
AEL
(
NEL
),
WEL
(
NEL
),
DEN
,
ZP
,
AP
,
ETAB
(
NE
)
INTEGER
(
c_int
),
intent
(
in
)
::
NEL
! number of elements in the material
INTEGER
(
c_int
)
::
NE
! number of points in E -- Range table
real
(
c_double
),
dimension
(
nel
),
intent
(
in
)::
zel
real
(
c_double
),
dimension
(
nel
),
intent
(
in
)::
ael
real
(
c_double
),
dimension
(
nel
),
intent
(
in
)::
wel
real
(
c_double
),
intent
(
in
)
::
den
real
(
c_double
),
intent
(
in
)
::
ZP
,
AP
real
(
c_double
),
dimension
(
ne
),
intent
(
in
)::
Etab
! Output:
REAL
*
8
RE
(
NE
),
ZW
,
AW
! Local
COMMON
adj
(
5
),
as
(
5
),
z
(
5
),
f
(
5
),
um
(
5
),
oz
,
ro
,
azm
,
aj
,
zion
,
aion
,&
zmed
,
amed
,
jc
real
(
c_double
),
dimension
(
ne
),
intent
(
out
)
::
RE
REAL
(
c_double
),
intent
(
out
)
::
ZW
,
AW
!!$ local variables
integer
::
i
,
j
,
ire
real
(
c_double
)
::
rel
,
rel1
,
uma
,
umed
,
zam
,
zme
! Body of ELOSS
zion
=
ZP
aion
=
AP
jc
=
NEL
ro
=
DEN
!== two parameters with question
ire
=
1
oz
=
1.
DO
i
=
1
,
NEL
as
(
i
)
=
AEL
(
i
)
z
(
i
)
=
ZEL
(
i
)
um
(
i
)
=
WEL
(
i
)
IF
(
z
(
i
)
.LE.
13.
)
THEN
adj
(
i
)
=
12.
*
z
(
i
)
+
7.
ELSE
adj
(
i
)
=
9.76
*
z
(
i
)
+
58.8
/
z
(
i
)
**
0.19
END
IF
END
DO
uma
=
0.
zam
=
0.
umed
=
0.
zme
=
0.
aj
=
0.
DO
i
=
1
,
jc
uma
=
uma
+
um
(
i
)
*
as
(
i
)
umed
=
umed
+
um
(
i
)
zme
=
zme
+
um
(
i
)
*
z
(
i
)
END
DO
amed
=
uma
/
umed
zmed
=
zme
/
umed
DO
i
=
1
,
jc
f
(
i
)
=
um
(
i
)
*
as
(
i
)/
uma
END
DO
DO
i
=
1
,
jc
zam
=
zam
+
f
(
i
)
*
z
(
i
)/
as
(
i
)
END
DO
azm
=
1.
/
zam
aj
=
0.
DO
i
=
1
,
jc
aj
=
aj
+
f
(
i
)
*
z
(
i
)
*
log
(
adj
(
i
))/
as
(
i
)
END
DO
aj
=
aj
*
azm
aj
=
exp
(
aj
)
ZW
=
zmed
AW
=
amed
DO
j
=
1
,
NE
!== result [mg/cm^2]
CALL
rde
(
ETAB
(
j
),
RE
(
j
),
rel1
,
rel
,
ire
)
END
DO
zion
=
ZP
aion
=
AP
jc
=
NEL
ro
=
DEN
allocate
(
adj
(
jc
),
as
(
jc
),
z
(
jc
),
f
(
jc
),
um
(
jc
))
!== two parameters with question
ire
=
1
oz
=
1.
as
=
ael
;
z
=
ZEL
;
um
=
WEL
DO
concurrent
(
i
=
1
:
jc
)
IF
(
z
(
i
)
.LE.
13.
)
THEN
adj
(
i
)
=
12.
*
z
(
i
)
+
7.
ELSE
adj
(
i
)
=
9.76
*
z
(
i
)
+
58.8
/
z
(
i
)
**
0.19
END
IF
END
DO
uma
=
sum
(
um
*
as
)
zme
=
sum
(
um
*
z
)
zam
=
zme
/
uma
;
azm
=
1.
/
zam
umed
=
sum
(
um
)
aj
=
exp
(
sum
(
um
*
z
*
log
(
adj
))/
uma
*
azm
)
amed
=
uma
/
umed
zmed
=
zme
/
umed
f
=
um
*
as
/
uma
ZW
=
zmed
AW
=
amed
DO
j
=
1
,
NE
!== result [mg/cm^2]
CALL
rde
(
ETAB
(
j
),
RE
(
j
),
rel1
,
rel
,
ire
)
END
DO
deallocate
(
adj
,
as
,
z
,
f
,
um
)
end
subroutine
ELOSS
SUBROUTINE
rde
(
e
,
range
,
rel1
,
rel
,
ix
)
IMPLICIT
REAL
*
8
(
A
-
H
,
O
-
Z
)
INTERFACE
REAL
*
8
FUNCTION
c
(
x
)
REAL
*
8
x
END
FUNCTION
c
REAL
*
8
FUNCTION
c1
(
x
)
REAL
*
8
x
END
FUNCTION
c1
END
INTERFACE
! calculates range and de/dx for compounds
dimension
ala
(
3
),
ala1
(
3
)
dimension
a
(
3
,
3
),
a1
(
4
,
4
),
a2
(
4
,
4
),
b
(
2
,
3
),
cc
(
5
)
common
adj
(
5
),
as
(
5
),
z
(
5
),
f
(
5
),
um
(
5
),
oz
,
ro
,
azm
,
aj
,
zion
,
aion
,&
zmed
,
amed
,
jc
dimension
alaj1
(
4
),
altau1
(
4
)
data
a
/
-.75265
,
.073736
,
.040556
,
2.5398
,
-.312
,
.018664
,
&
-.24598
,
.11548
,
-.0099661
/
data
a1
/
-8.0155
,
0.36916
,
-1.4307e-02
,
3.4718e-03
,
&
1.8371
,
-1.452e-02
,
-3.0142e-02
,
2.3603e-03
,
&
0.045233
,
-9.5873e-04
,
7.1303e-03
,
-6.8538e-04
,
&
-5.9898e-03
,
-5.2315e-04
,
-3.3802e-04
,
3.9405e-05
/
data
a2
/
-8.725
,
0.8309
,
-0.13396
,
0.012625
,
&
1.8797
,
0.11139
,
-0.064808
,
0.0054043
,
&
0.74192
,
-0.528805
,
0.1264232
,
-0.00934142
,
&
0.752005
,
-0.5558937
,
0.12843119
,
-0.009306336
/
data
b
/
0.422377e-06
,
3.858019e-09
,
0.0304043e-06
,
-0.1667989e-09
,
&
-0.00038106e-06
,
0.00157955e-09
/
if
(
e
.le.
0.002
)
then
range
=
0.
rel1
=
0.
rel
=
0.
return
endif
! this a flag
ibis
=
-1
en
=
e
/
aion
tau
=
en
*
1.008
altau
=
log
(
tau
)
alaj
=
log
(
aj
)
alaj1
(
1
)
=
1.
altau1
(
1
)
=
1.
DO
kk
=
2
,
4
alaj1
(
kk
)
=
alaj
**
(
kk
-1
)
altau1
(
kk
)
=
altau
**
(
kk
-1
)
END
DO
t
=
tau
/
938.256
tt
=
2.
*
t
+
t
*
t
beta
=
sqrt
(
tt
)/(
1.
+
t
)
s1
=
0.
DO
i
=
1
,
4
DO
j
=
1
,
4
s1
=
s1
+
a2
(
j
,
i
)
*
alaj1
(
j
)
*
altau1
(
i
)
END
DO
END
DO
ala
(
1
)
=
azm
*
exp
(
s1
)
s2
=
0.
DO
i
=
2
,
4
DO
j
=
1
,
4
s2
=
s2
+
(
i
-1
)
*
a2
(
j
,
i
)
*
alaj1
(
j
)
*
altau1
(
i
-1
)
END
DO
END
DO
ala1
(
1
)
=
ala
(
1
)
*
s2
/
tau
s1
=
0.
DO
i
=
1
,
4
DO
j
=
1
,
4
s1
=
s1
+
a1
(
j
,
i
)
*
alaj1
(
j
)
*
altau1
(
i
)
END
DO
END
DO
ala
(
3
)
=
azm
*
exp
(
s1
)
s2
=
0.
DO
i
=
2
,
4
DO
j
=
1
,
4
s2
=
s2
+
(
i
-1
)
*
a1
(
j
,
i
)
*
alaj1
(
j
)
*
altau1
(
i
-1
)
END
DO
END
DO
ala1
(
3
)
=
ala
(
3
)
*
s2
/
tau
s1
=
0.
DO
i
=
1
,
3
DO
j
=
1
,
3
s1
=
s1
+
a
(
j
,
i
)
*
alaj1
(
j
)
*
altau1
(
i
)
END
DO
END
DO
ala
(
2
)
=
azm
*
exp
(
s1
)/
1000.
s2
=
0.
DO
i
=
2
,
3
DO
j
=
1
,
3
s2
=
s2
+
(
i
-1
)
*
a
(
j
,
i
)
*
alaj1
(
j
)
*
altau1
(
i
-1
)
END
DO
END
DO
ala1
(
2
)
=
ala
(
2
)
*
s2
/
tau
25
continue
coefa
=
3.
coefb
=
1.
alaa
=
(
ala
(
1
)
*
(
tanh
(
coefa
*
(
.98
-
en
))
+1.
)/
2.
&
+
ala
(
2
)
*
(
tanh
(
coefa
*
(
en
-
.98
))
+1.
)/
2.
)
&
*
(
tanh
(
coefb
*
(
8.0
-
en
))
+1.
)/
2.
&
+
ala
(
3
)
*
(
tanh
(
coefb
*
(
en
-
8.
))
+1.
)/
2.
alim1
=
0.
alim2
=
0.
if
(
coefa
*
(
en
-.98
)
.lt.
85
)
then
alim1
=
1.008
/
cosh
(
coefa
*
(
.98
-
en
))/
cosh
(
coefa
*
(
.98
-
en
))
endif
if
(
coefb
*
(
en
-8.
)
.lt.
85
)
then
alim2
=
1.008
/
cosh
(
coefb
*
(
8.
-
en
))/
cosh
(
coefb
*
(
8.
-
en
))
endif
alaa1
=
(
ala1
(
1
)
*
(
tanh
(
coefa
*
(
.98
-
en
))
+1.
)/
2.
+
&
ala1
(
2
)
*
(
tanh
(
coefa
*
(
en
-.98
))
+1.
)/
2.
)
*
&
(
tanh
(
coefb
*
(
8.
-
en
))
+1.
)/
2.
+
&
ala1
(
3
)
*
(
tanh
(
coefb
*
(
en
-8.
))
+1.
)/
2.
+
&
coefa
/
2.
*
(
tanh
(
coefb
*
(
8.
-
en
))
+1.
)/
2.
*
&
(
ala
(
2
)
*
alim1
-
ala
(
1
)
*
alim1
)
+
&
coefb
/
2.
*
(
ala
(
3
)
*
alim2
-
&
(
ala
(
1
)
*
(
tanh
(
coefa
*
(
.98
-
en
))
+1.
)/
2.
+
&
ala
(
2
)
*
(
tanh
(
coefa
*
(
en
-.98
))
+1.
)/
2.
)
*
alim2
)
hi
=
137.
*
beta
/
zion
bz
=
(
31.8+3.86
*
(
aj
**
.625
))
*
azm
*
.000001
bz
=
bz
*
(
zion
**
2.666667
)
*
c
(
hi
)
bz1
=
(
4.357+.5288
*
(
aj
**
.625
))
*
azm
*
.001
bz1
=
bz1
*
(
zion
**
1.666667
)
*
c1
(
hi
)
bep
=
beta
*
beta
rel1
=
zion
*
zion
/(
alaa1
+
bz1
*
((
1.
-
bep
)
**
1.5
)/
931.141
/
beta
)
rel1
=
rel1
/
1000.
range
=
(
alaa
+
bz
)
*
aion
/
1.008
/
zion
/
zion
range
=
range
*
1000.
! Atention!! this version do not work correctly for ix.ne.1
if
(
ix
.ne.
1
)
return
ank
=
.153574
*
ro
/
azm
z23
=
zion
**
.666667
abet
=
beta
*
125.
/
z23
zef
=
zion
*
(
1.
-
exp
(
-
abet
))
zef2
=
zef
*
zef
om
=
1022000.
*
bep
/(
1.
-
bep
)
cbet
=
0.
DO
k
=
1
,
jc
cc
(
k
)
=
0.
DO
i
=
1
,
2
DO
j
=
1
,
3
cc
(
k
)
=
cc
(
k
)
+
b
(
i
,
j
)
*
((
1.
/
bep
-1.
)
**
j
)
*
((
adj
(
k
)
**
(
i
+1
)))
END
DO
END
DO
cbet
=
cbet
+
f
(
k
)
*
cc
(
k
)/
as
(
k
)
END
DO
cbet
=
cbet
*
azm
del1
=
ank
*
zef2
*
(
log
(
om
/
oz
)
-
bep
)/
bep
del1
=
del1
/
ro
del2
=
2.
*
ank
*
zef2
*
(
log
(
oz
/
aj
)
-
cbet
)/
bep
del2
=
del2
/
ro
rel2
=
rel1
-
del1
rel3
=
rel1
-
rel2
+
del2
if
(
del1
)
8
,
8
,
9
8
rel
=
rel1
goto
12
9
if
(
del1
+
del2
-
rel2
)
10
,
10
,
11
10
rel
=
rel3
goto
12
11
if
(
del1
.lt.
rel1
)
then
rel
=
rel2
else
rel
=
rel1
endif
12
return
END
REAL
*
8
FUNCTION
c
(
x
)
REAL
*
8
x
IF
(
x
.LE.
0.2
)
THEN
c
=
-0.00006
+
(
0.05252
+
0.12857
*
x
)
*
x
ELSE
IF
(
x
.LE.
2.
)
THEN
c
=
-0.00185
+
(
0.07355
+
(
0.07172
-
0.02723
*
x
)
*
x
)
*
x
ELSE
IF
(
x
.LE.
3.
)
THEN
c
=
-0.0793
+
(
0.3323
-
(
0.1234
-
0.0153
*
x
)
*
x
)
*
x
ELSE
c
=
0.22
END
IF
END
REAL
*
8
FUNCTION
c1
(
x
)
REAL
*
8
x
IF
(
x
.LE.
0.2
)
THEN
c1
=
0.05252+.25714
*
x
ELSE
IF
(
x
.LE.
2.0
)
THEN
c1
=
0.07355
+
(
0.14344
-
0.08169
*
x
)
*
x
ELSE
IF
(
x
.LE.
3.0
)
THEN
c1
=
0.3323
-
(
0.2468
-
0.0459
*
x
)
*
x
ELSE
c1
=
0.
END
IF
END
! calculates range and de/dx for compounds
IMPLICIT
none
!REAL(c_double) (A-H,O-Z)
real
(
c_double
),
intent
(
in
)
::
E
integer
,
intent
(
in
)
::
ix
real
(
c_double
),
intent
(
out
)
::
range
real
(
c_double
),
intent
(
out
)
::
rel1
real
(
c_double
),
intent
(
out
)
::
rel
integer
::
i
,
j
,
k
,
kk
real
(
c_double
),
parameter
,
dimension
(
3
,
3
)::
a
=
reshape
([&
-0.75265
,
.073736
,
.040556
,&
+2.53980
,
-.312000
,
.018664
,
&
-0.24598
,
.115480
,
-.0099661
],
shape
=
[
3
,
3
])
real
(
c_double
),
parameter
,
dimension
(
4
,
4
)::
a1
=
reshape
([&
-8.0155
,
0.36916
,
-1.4307e-2
,
3.4718e-3
,
&
+1.8371
,
-1.4520e-2
,
-3.0142e-2
,
2.3603e-3
,
&
-4.5233e-2
,
-9.5873e-4
,
7.1303e-3
,
-6.8538e-4
,
&
-5.9898e-3
,
-5.2315e-4
,
-3.3802e-4
,
3.9405e-5
],
shape
=
[
4
,
4
])
real
(
c_double
),
parameter
,
dimension
(
4
,
4
)::
a2
=
reshape
([&
-8.725000
,
0.8309000
,
-0.13396000
,
0.012625
,
&
-1.879700
,
0.1113900
,
-0.06480800
,
0.0054043
,
&
-0.741920
,
-0.5288050
,
0.12642320
,
-9.341420e-3
,&
-0.752005
,
-0.5558937
,
0.12843119
,
-9.306336e-3
],
shape
=
[
4
,
4
])
real
(
c_double
),
parameter
,
dimension
(
2
,
3
)::
b
=
reshape
([&
+4.223770e-07
,
3.858019e-09
,
3.04043e-08
,&
-1.667989e-10
,
-3.810600e-10
,
1.57955e-12
],
shape
=
[
2
,
3
])
real
(
c_double
),
allocatable
,
dimension
(:)
::
cc
real
(
c_double
),
dimension
(
3
)
::
ala
,
ala1
real
(
c_double
)
::
alaa
,
alaa1
real
(
c_double
),
dimension
(
4
)
::
alaj1
,
altau1
real
(
c_double
)
::
abet
,
alaj
,
altau
,
ank
,
bep
,
beta
,
bz
,
bz1
,
cbet
,
t
,
tau
,
tt
real
(
c_double
),
parameter
::
coefa
=
3.
,
coefb
=
1.
real
(
c_double
)
::
alim1
,
alim2
,
del1
,
del2
,
en
,
hi
,
om
,
rel2
,
rel3
,
zef
,
zef2
if
(
e
.le.
0.002
)
then
range
=
0.
rel1
=
0.
rel
=
0.
return
endif
en
=
e
/
aion
tau
=
en
*
1.008
altau
=
log
(
tau
)
alaj
=
log
(
aj
)
DO
concurrent
(
kk
=
1
:
4
)
alaj1
(
kk
)
=
alaj
**
(
kk
-1
)
altau1
(
kk
)
=
altau
**
(
kk
-1
)
END
DO
t
=
tau
/
938.256
tt
=
2.
*
t
+
t
*
t
beta
=
sqrt
(
tt
)/(
1.
+
t
)
ala
(
1
)
=
azm
*
exp
(
dot_product
(
alaj1
,
matmul
(
a2
,
altau1
)))
ala
(
2
)
=
azm
*
exp
(
dot_product
(
alaj1
(
1
:
3
),
matmul
(
a
,
altau1
(
1
:
3
))))/
1000.
ala
(
3
)
=
azm
*
exp
(
dot_product
(
alaj1
,
matmul
(
a1
,
altau1
)))
ala1
(
1
)
=
ala
(
1
)
*
dot_product
(
alaj1
,
matmul
(
a2
(:,
2
:
4
),
altau1
(
1
:
3
)
*
[
1
,
2
,
3
]))/
tau
ala1
(
2
)
=
ala
(
2
)
*
dot_product
(
alaj1
(
1
:
3
),
matmul
(
a
(:,
2
:
3
),
altau1
(
1
:
2
)
*
[
1
,
2
]))/
tau
ala1
(
3
)
=
ala
(
3
)
*
dot_product
(
alaj1
,
matmul
(
a1
(:,
2
:
4
),
altau1
(
1
:
3
)
*
[
1
,
2
,
3
]))/
tau
associate
(
ca
=>
coefa
*
(
.98
-
en
),
cb
=>
coefb
*
(
8.0
-
en
))
associate
(
tca
=>
(
1
+
tanh
(
ca
))/
2.
,
tcb
=>
(
1
+
tanh
(
cb
))/
2.
)
alaa
=
(
ala
(
1
)
*
tca
+
ala
(
2
)
*
(
1.0
-
tca
))
*
tcb
+
ala
(
3
)
*
(
1.0
-
tcb
)
alim1
=
0.
;
alim2
=
0.
if
(
-
ca
.lt.
85
)
then
alim1
=
1.008
*
(
cosh
(
ca
)
**
(
-2
))
endif
if
(
-
cb
.lt.
85
)
then
alim2
=
1.008
*
(
cosh
(
cb
)
**
(
-2
))
endif
alaa1
=
(
ala1
(
1
)
*
tca
+
ala1
(
2
)
*
(
1.0
-
tca
))
*
tcb
+
ala1
(
3
)
*
(
1.0
-
tcb
)
+
&
coefa
*
tcb
*
(
ala
(
2
)
-
ala
(
1
))
*
alim1
/
2.
+
&
coefb
*
(
ala
(
3
)
-
(
ala
(
1
)
*
tca
+
ala
(
2
)
*
(
1.
-
tca
)))
*
alim2
/
2.
end
associate
end
associate
hi
=
137.
*
beta
/
zion
bz
=
(
31.8+3.86
*
(
aj
**
.625
))
*
azm
*
1e-6
*
(
zion
**
2.666667
)
*
c
(
hi
)
bz1
=
(
4.357+.5288
*
(
aj
**
.625
))
*
azm
*
.001
*
(
zion
**
1.666667
)
*
c1
(
hi
)
bep
=
beta
*
beta
rel1
=
zion
*
zion
/(
alaa1
+
bz1
*
((
1.
-
beta
**
2
)
**
1.5
)/
931.141
/
beta
)/
1000.
range
=
(
alaa
+
bz
)
*
aion
/(
1.008
*
zion
**
2
)
*
1000.
! Atention!! this version do not work correctly for ix.ne.1
if
(
ix
.ne.
1
)
then
return
end
if
allocate
(
cc
(
size
(
as
)))
ank
=
.153574
*
ro
/
azm
! z23=zion**.666667
abet
=
beta
*
125.
*
(
zion
**
(
-2.0
/
3.0
))
zef
=
zion
*
(
1.
-
exp
(
-
abet
))
zef2
=
zef
*
zef
om
=
1022000.
*
bep
/(
1.
-
bep
)
cbet
=
0.
DO
k
=
1
,
jc
cc
(
k
)
=
0.
DO
i
=
1
,
2
DO
j
=
1
,
3
cc
(
k
)
=
cc
(
k
)
+
b
(
i
,
j
)
*
((
1.
/
bep
-1.
)
**
j
)
*
((
adj
(
k
)
**
(
i
+1
)))
END
DO
END
DO
cbet
=
cbet
+
f
(
k
)
*
cc
(
k
)/
as
(
k
)
END
DO
cbet
=
cbet
*
azm
del1
=
ank
*
zef2
*
(
log
(
om
/
oz
)
-
bep
)/
bep
/
ro
del2
=
2.
*
ank
*
zef2
*
(
log
(
oz
/
aj
)
-
cbet
)/
bep
/
ro
rel2
=
rel1
-
del1
rel3
=
rel1
-
rel2
+
del2
!!$ here is a replasement for an Arithmetic IF construct
if
(
del1
<=
0.0
)
then
rel
=
rel1
else
if
(
del1
+
del2
-
rel2
<=
0
)
then
rel
=
rel3
else
if
(
del1
.lt.
rel1
)
then
rel
=
rel2
else
rel
=
rel1
endif
deallocate
(
cc
)
return
END
SUBROUTINE
rde
pure
FUNCTION
c
(
x
)
result
(
res
)
REAL
(
c_double
),
intent
(
in
)
::
x
real
(
c_double
)
::
res
IF
(
x
.LE.
0.2
)
THEN
res
=
-0.00006
+
(
0.05252
+
0.12857
*
x
)
*
x
ELSE
IF
(
x
.LE.
2.
)
THEN
res
=
-0.00185
+
(
0.07355
+
(
0.07172
-
0.02723
*
x
)
*
x
)
*
x
ELSE
IF
(
x
.LE.
3.
)
THEN
res
=
-0.0793
+
(
0.3323
-
(
0.1234
-
0.0153
*
x
)
*
x
)
*
x
ELSE
res
=
0.22
END
IF
END
FUNCTION
c
pure
FUNCTION
c1
(
x
)
result
(
res
)
REAL
(
c_double
),
intent
(
in
)
::
x
real
(
c_double
)
::
res
IF
(
x
.LE.
0.2
)
THEN
res
=
0.05252+.25714
*
x
ELSE
IF
(
x
.LE.
2.0
)
THEN
res
=
0.07355
+
(
0.14344
-
0.08169
*
x
)
*
x
ELSE
IF
(
x
.LE.
3.0
)
THEN
res
=
0.3323
-
(
0.2468
-
0.0459
*
x
)
*
x
ELSE
res
=
0.
END
IF
END
FUNCTION
c1
end
module
m_eloss
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