Skip to content

Commit 343fdf2

Browse files
jacobwilliamsjacobwilliams
committed
added new functions
ceil, floor, gamma, hypot, max, min, modulo, mod, and sign
1 parent c478684 commit 343fdf2

File tree

2 files changed

+348
-86
lines changed

2 files changed

+348
-86
lines changed

‎src/function_parser.f90

Lines changed: 293 additions & 51 deletions
Original file line numberDiff line numberDiff line change
@@ -62,70 +62,106 @@ module function_parser
6262
cAtan2 = 21, & ! atan2 must precede atan to prevent aliasing.
6363
cAtan = 22, &
6464
cPi = 23, & ! Pi (function with zero arguments)
65-
cIf = 24 ! Test function with 3 arguments (returns sum of arguments).
66-
integer, parameter :: VarBegin = 25
65+
cCeil = 24, &
66+
cFloor = 25, &
67+
cGamma = 26, &
68+
cHypot = 27, &
69+
cMax = 28, &
70+
cMin = 29, &
71+
cModulo = 30, &
72+
cMod = 31, &
73+
cSign = 32, &
74+
cIf = 33 ! if (three arguments)
75+
integer, parameter :: VarBegin = 34
6776

6877
character(len=1), dimension(cAdd:cPow), parameter :: operators = [ '+', & ! plus
6978
'-', & ! minus
7079
'*', & ! multiply
7180
'/', & ! divide
7281
'^' ] ! power
7382

74-
character(len=5), dimension(cAbs:cIf), parameter :: functions = [ 'abs ', &
75-
'exp ', &
76-
'log10', &
77-
'log ', &
78-
'sqrt ', &
79-
'sinh ', &
80-
'cosh ', &
81-
'tanh ', &
82-
'sin ', &
83-
'cos ', &
84-
'tan ', &
85-
'asin ', &
86-
'acos ', &
87-
'atan2', &
88-
'atan ', &
89-
'pi ', &
90-
'if ' ]
83+
character(len=7), dimension(cAbs:cIf), parameter :: functions = [ 'abs ', &
84+
'exp ', &
85+
'log10 ', &
86+
'log ', &
87+
'sqrt ', &
88+
'sinh ', &
89+
'cosh ', &
90+
'tanh ', &
91+
'sin ', &
92+
'cos ', &
93+
'tan ', &
94+
'asin ', &
95+
'acos ', &
96+
'atan2 ', &
97+
'atan ', &
98+
'pi ', &
99+
'ceiling', &
100+
'floor ', &
101+
'gamma ', &
102+
'hypot ', &
103+
'max ', &
104+
'min ', &
105+
'modulo ', &
106+
'mod ', &
107+
'sign ', &
108+
'if ' ]
91109

92110
! Specify the number of required arguments each `functions` element must have.
93111
integer, dimension(cAbs:cIf), parameter :: required_args = [ 1, & ! abs
94-
1, & ! exp
95-
1, & ! log10
96-
1, & ! log
97-
1, & ! sqrt
98-
1, & ! sinh
99-
1, & ! cosh
100-
1, & ! tanh
101-
1, & ! sin
102-
1, & ! cos
103-
1, & ! tan
104-
1, & ! asin
105-
1, & ! acos
106-
2, & ! atan2
107-
1, & ! atan
108-
0, & ! pi
109-
3 ] ! if
112+
1, & ! exp
113+
1, & ! log10
114+
1, & ! log
115+
1, & ! sqrt
116+
1, & ! sinh
117+
1, & ! cosh
118+
1, & ! tanh
119+
1, & ! sin
120+
1, & ! cos
121+
1, & ! tan
122+
1, & ! asin
123+
1, & ! acos
124+
2, & ! atan2
125+
1, & ! atan
126+
0, & ! pi
127+
1, & ! Ceiling
128+
1, & ! Floor
129+
1, & ! Gamma
130+
2, & ! Hypot
131+
2, & ! Max
132+
2, & ! Min
133+
2, & ! Modulo
134+
2, & ! Mod
135+
2, & ! Sign
136+
3 ] ! if
110137

111138
! Specify the number of optional arguments each `functions` element might have.
112139
integer, dimension(cAbs:cIf), parameter :: optional_args = [ 0, & ! abs
113-
0, & ! exp
114-
0, & ! log10
115-
0, & ! log
116-
0, & ! sqrt
117-
0, & ! sinh
118-
0, & ! cosh
119-
0, & ! tanh
120-
0, & ! sin
121-
0, & ! cos
122-
0, & ! tan
123-
0, & ! asin
124-
0, & ! acos
125-
0, & ! atan2
126-
1, & ! atan
127-
0, & ! pi
128-
0 ] ! if
140+
0, & ! exp
141+
0, & ! log10
142+
0, & ! log
143+
0, & ! sqrt
144+
0, & ! sinh
145+
0, & ! cosh
146+
0, & ! tanh
147+
0, & ! sin
148+
0, & ! cos
149+
0, & ! tan
150+
0, & ! asin
151+
0, & ! acos
152+
0, & ! atan2
153+
1, & ! atan
154+
0, & ! pi
155+
0, & ! Ceiling
156+
0, & ! Floor
157+
0, & ! Gamma
158+
0, & ! Hypot
159+
0, & ! Max
160+
0, & ! Min
161+
0, & ! Modulo
162+
0, & ! Mod
163+
0, & ! Sign
164+
0 ] ! if
129165

130166
! The maximum number of arguments any `functions` element might have.
131167
integer, parameter :: max_func_args = maxval(required_args + optional_args)
@@ -1063,6 +1099,201 @@ subroutine cPi_func(me,ip,dp,sp,val,ierr)
10631099
end subroutine cPi_func
10641100
!******************************************************************
10651101

1102+
!******************************************************************
1103+
!>
1104+
! ceiling function
1105+
1106+
subroutine cceil_func(me,ip,dp,sp,val,ierr)
1107+
1108+
implicit none
1109+
1110+
class(fparser),intent(inout) :: me
1111+
integer,intent(in) :: ip !! instruction pointer
1112+
integer,intent(inout) :: dp !! data pointer
1113+
integer,intent(inout) :: sp !! stack pointer
1114+
real(wp),dimension(:),intent(in) :: val !! variable values
1115+
integer,intent(out) :: ierr !! error flag
1116+
1117+
me%stack(sp) = ceiling(me%stack(sp))
1118+
ierr = 0
1119+
1120+
end subroutine cceil_func
1121+
!******************************************************************
1122+
1123+
!******************************************************************
1124+
!>
1125+
! floor function
1126+
1127+
subroutine cfloor_func(me,ip,dp,sp,val,ierr)
1128+
1129+
implicit none
1130+
1131+
class(fparser),intent(inout) :: me
1132+
integer,intent(in) :: ip !! instruction pointer
1133+
integer,intent(inout) :: dp !! data pointer
1134+
integer,intent(inout) :: sp !! stack pointer
1135+
real(wp),dimension(:),intent(in) :: val !! variable values
1136+
integer,intent(out) :: ierr !! error flag
1137+
1138+
me%stack(sp) = floor(me%stack(sp))
1139+
ierr = 0
1140+
1141+
end subroutine cfloor_func
1142+
!******************************************************************
1143+
1144+
!******************************************************************
1145+
!>
1146+
! gamma function
1147+
1148+
subroutine cgamma_func(me,ip,dp,sp,val,ierr)
1149+
1150+
implicit none
1151+
1152+
class(fparser),intent(inout) :: me
1153+
integer,intent(in) :: ip !! instruction pointer
1154+
integer,intent(inout) :: dp !! data pointer
1155+
integer,intent(inout) :: sp !! stack pointer
1156+
real(wp),dimension(:),intent(in) :: val !! variable values
1157+
integer,intent(out) :: ierr !! error flag
1158+
1159+
me%stack(sp) = gamma(me%stack(sp))
1160+
ierr = 0
1161+
1162+
end subroutine cgamma_func
1163+
!******************************************************************
1164+
1165+
!******************************************************************
1166+
!>
1167+
! hypot function
1168+
1169+
subroutine chypot_func(me,ip,dp,sp,val,ierr)
1170+
1171+
implicit none
1172+
1173+
class(fparser),intent(inout) :: me
1174+
integer,intent(in) :: ip !! instruction pointer
1175+
integer,intent(inout) :: dp !! data pointer
1176+
integer,intent(inout) :: sp !! stack pointer
1177+
real(wp),dimension(:),intent(in) :: val !! variable values
1178+
integer,intent(out) :: ierr !! error flag
1179+
1180+
me%stack(sp-1) = hypot(me%stack(sp-1), me%stack(sp))
1181+
sp = sp - 1
1182+
ierr = 0
1183+
1184+
end subroutine chypot_func
1185+
!******************************************************************
1186+
1187+
!******************************************************************
1188+
!>
1189+
! max function
1190+
1191+
subroutine cmax_func(me,ip,dp,sp,val,ierr)
1192+
1193+
implicit none
1194+
1195+
class(fparser),intent(inout) :: me
1196+
integer,intent(in) :: ip !! instruction pointer
1197+
integer,intent(inout) :: dp !! data pointer
1198+
integer,intent(inout) :: sp !! stack pointer
1199+
real(wp),dimension(:),intent(in) :: val !! variable values
1200+
integer,intent(out) :: ierr !! error flag
1201+
1202+
me%stack(sp-1) = max(me%stack(sp-1), me%stack(sp))
1203+
sp = sp - 1
1204+
ierr = 0
1205+
1206+
end subroutine cmax_func
1207+
!******************************************************************
1208+
1209+
!******************************************************************
1210+
!>
1211+
! min function
1212+
1213+
subroutine cmin_func(me,ip,dp,sp,val,ierr)
1214+
1215+
implicit none
1216+
1217+
class(fparser),intent(inout) :: me
1218+
integer,intent(in) :: ip !! instruction pointer
1219+
integer,intent(inout) :: dp !! data pointer
1220+
integer,intent(inout) :: sp !! stack pointer
1221+
real(wp),dimension(:),intent(in) :: val !! variable values
1222+
integer,intent(out) :: ierr !! error flag
1223+
1224+
me%stack(sp-1) = min(me%stack(sp-1), me%stack(sp))
1225+
sp = sp - 1
1226+
ierr = 0
1227+
1228+
end subroutine cmin_func
1229+
!******************************************************************
1230+
1231+
!******************************************************************
1232+
!>
1233+
! mod function
1234+
1235+
subroutine cmod_func(me,ip,dp,sp,val,ierr)
1236+
1237+
implicit none
1238+
1239+
class(fparser),intent(inout) :: me
1240+
integer,intent(in) :: ip !! instruction pointer
1241+
integer,intent(inout) :: dp !! data pointer
1242+
integer,intent(inout) :: sp !! stack pointer
1243+
real(wp),dimension(:),intent(in) :: val !! variable values
1244+
integer,intent(out) :: ierr !! error flag
1245+
1246+
me%stack(sp-1) = mod(me%stack(sp-1), me%stack(sp))
1247+
sp = sp - 1
1248+
ierr = 0
1249+
1250+
end subroutine cmod_func
1251+
!******************************************************************
1252+
1253+
!******************************************************************
1254+
!>
1255+
! modulo function
1256+
1257+
subroutine cmodulo_func(me,ip,dp,sp,val,ierr)
1258+
1259+
implicit none
1260+
1261+
class(fparser),intent(inout) :: me
1262+
integer,intent(in) :: ip !! instruction pointer
1263+
integer,intent(inout) :: dp !! data pointer
1264+
integer,intent(inout) :: sp !! stack pointer
1265+
real(wp),dimension(:),intent(in) :: val !! variable values
1266+
integer,intent(out) :: ierr !! error flag
1267+
1268+
me%stack(sp-1) = modulo(me%stack(sp-1), me%stack(sp))
1269+
sp = sp - 1
1270+
ierr = 0
1271+
1272+
end subroutine cmodulo_func
1273+
!******************************************************************
1274+
1275+
!******************************************************************
1276+
!>
1277+
! sign function
1278+
1279+
subroutine csign_func(me,ip,dp,sp,val,ierr)
1280+
1281+
implicit none
1282+
1283+
class(fparser),intent(inout) :: me
1284+
integer,intent(in) :: ip !! instruction pointer
1285+
integer,intent(inout) :: dp !! data pointer
1286+
integer,intent(inout) :: sp !! stack pointer
1287+
real(wp),dimension(:),intent(in) :: val !! variable values
1288+
integer,intent(out) :: ierr !! error flag
1289+
1290+
me%stack(sp-1) = sign(me%stack(sp-1), me%stack(sp))
1291+
sp = sp - 1
1292+
ierr = 0
1293+
1294+
end subroutine csign_func
1295+
!******************************************************************
1296+
10661297
!******************************************************************
10671298
!>
10681299
! If function with three arguments.
@@ -1749,6 +1980,17 @@ subroutine add_compiled_byte (me, b, num_args)
17491980
case (2); me%bytecode_ops(me%bytecodesize)%f => catan2_func
17501981
end select
17511982
case (cPi); me%bytecode_ops(me%bytecodesize)%f => cPi_func
1983+
1984+
case(cCeil); me%bytecode_ops(me%bytecodesize)%f => cceil_func
1985+
case(cFloor); me%bytecode_ops(me%bytecodesize)%f => cfloor_func
1986+
case(cGamma); me%bytecode_ops(me%bytecodesize)%f => cgamma_func
1987+
case(cHypot); me%bytecode_ops(me%bytecodesize)%f => chypot_func
1988+
case(cMax); me%bytecode_ops(me%bytecodesize)%f => cmax_func
1989+
case(cMin); me%bytecode_ops(me%bytecodesize)%f => cmin_func
1990+
case(cMod); me%bytecode_ops(me%bytecodesize)%f => cmod_func
1991+
case(cModulo); me%bytecode_ops(me%bytecodesize)%f => cmodulo_func
1992+
case(cSign); me%bytecode_ops(me%bytecodesize)%f => csign_func
1993+
17521994
case (cIf); me%bytecode_ops(me%bytecodesize)%f => cif_func
17531995
case default; me%bytecode_ops(me%bytecodesize)%f => cdefault_func
17541996
end select

0 commit comments

Comments
 (0)