1! Copyright 2019-2021 Free Software Foundation, Inc. 2! 3! This program is free software; you can redistribute it and/or modify 4! it under the terms of the GNU General Public License as published by 5! the Free Software Foundation; either version 3 of the License, or 6! (at your option) any later version. 7! 8! This program is distributed in the hope that it will be useful, 9! but WITHOUT ANY WARRANTY; without even the implied warranty of 10! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11! GNU General Public License for more details. 12! 13! You should have received a copy of the GNU General Public License 14! along with this program. If not, see <http://www.gnu.org/licenses/> . 15 16! Source code for function-calls.exp. 17 18subroutine no_arg_subroutine() 19end subroutine 20 21logical function no_arg() 22 no_arg = .TRUE. 23end function 24 25subroutine run(a) 26 external :: a 27 call a() 28end subroutine 29 30logical function one_arg(x) 31 logical, intent(in) :: x 32 one_arg = x 33end function 34 35integer(kind=4) function one_arg_value(x) 36 integer(kind=4), value :: x 37 one_arg_value = x 38end function 39 40integer(kind=4) function several_arguments(a, b, c) 41 integer(kind=4), intent(in) :: a 42 integer(kind=4), intent(in) :: b 43 integer(kind=4), intent(in) :: c 44 several_arguments = a + b + c 45end function 46 47integer(kind=4) function mix_of_scalar_arguments(a, b, c) 48 integer(kind=4), intent(in) :: a 49 logical(kind=4), intent(in) :: b 50 real(kind=8), intent(in) :: c 51 mix_of_scalar_arguments = a + floor(c) 52 if (b) then 53 mix_of_scalar_arguments=mix_of_scalar_arguments+1 54 end if 55end function 56 57real(kind=4) function real4_argument(a) 58 real(kind=4), intent(in) :: a 59 real4_argument = a 60end function 61 62integer(kind=4) function return_constant() 63 return_constant = 17 64end function 65 66character(40) function return_string() 67 return_string='returned in hidden first argument' 68end function 69 70recursive function fibonacci(n) result(item) 71 integer(kind=4) :: item 72 integer(kind=4), intent(in) :: n 73 select case (n) 74 case (0:1) 75 item = n 76 case default 77 item = fibonacci(n-1) + fibonacci(n-2) 78 end select 79end function 80 81complex function complex_argument(a) 82 complex, intent(in) :: a 83 complex_argument = a 84end function 85 86integer(kind=4) function array_function(a) 87 integer(kind=4), dimension(11) :: a 88 array_function = a(ubound(a, 1, 4)) 89end function 90 91integer(kind=4) function pointer_function(int_pointer) 92 integer, pointer :: int_pointer 93 pointer_function = int_pointer 94end function 95 96integer(kind=4) function hidden_string_length(string) 97 character*(*) :: string 98 hidden_string_length = len(string) 99end function 100 101integer(kind=4) function sum_some(a, b, c) 102 integer :: a, b 103 integer, optional :: c 104 sum_some = a + b 105 if (present(c)) then 106 sum_some = sum_some + c 107 end if 108end function 109 110module derived_types_and_module_calls 111 type cart 112 integer :: x 113 integer :: y 114 end type 115 type cart_nd 116 integer :: x 117 integer, allocatable :: d(:) 118 end type 119 type nested_cart_3d 120 type(cart) :: d 121 integer :: z 122 end type 123contains 124 type(cart) function pass_cart(c) 125 type(cart) :: c 126 pass_cart = c 127 end function 128 integer(kind=4) function pass_cart_nd(c) 129 type(cart_nd) :: c 130 pass_cart_nd = ubound(c%d,1,4) 131 end function 132 type(nested_cart_3d) function pass_nested_cart(c) 133 type(nested_cart_3d) :: c 134 pass_nested_cart = c 135 end function 136 type(cart) function build_cart(x,y) 137 integer :: x, y 138 build_cart%x = x 139 build_cart%y = y 140 end function 141end module 142 143program function_calls 144 use derived_types_and_module_calls 145 implicit none 146 interface 147 logical function no_arg() 148 end function 149 logical function one_arg(x) 150 logical, intent(in) :: x 151 end function 152 integer(kind=4) function pointer_function(int_pointer) 153 integer, pointer :: int_pointer 154 end function 155 integer(kind=4) function several_arguments(a, b, c) 156 integer(kind=4), intent(in) :: a 157 integer(kind=4), intent(in) :: b 158 integer(kind=4), intent(in) :: c 159 end function 160 complex function complex_argument(a) 161 complex, intent(in) :: a 162 end function 163 real(kind=4) function real4_argument(a) 164 real(kind=4), intent(in) :: a 165 end function 166 integer(kind=4) function return_constant() 167 end function 168 character(40) function return_string() 169 end function 170 integer(kind=4) function one_arg_value(x) 171 integer(kind=4), value :: x 172 end function 173 integer(kind=4) function sum_some(a, b, c) 174 integer :: a, b 175 integer, optional :: c 176 end function 177 integer(kind=4) function mix_of_scalar_arguments(a, b, c) 178 integer(kind=4), intent(in) :: a 179 logical(kind=4), intent(in) :: b 180 real(kind=8), intent(in) :: c 181 end function 182 integer(kind=4) function array_function(a) 183 integer(kind=4), dimension(11) :: a 184 end function 185 integer(kind=4) function hidden_string_length(string) 186 character*(*) :: string 187 end function 188 end interface 189 logical :: untrue, no_arg_return 190 complex :: fft, fft_result 191 integer(kind=4), dimension (11) :: integer_array 192 real(kind=8) :: real8 193 real(kind=4) :: real4 194 integer, pointer :: int_pointer 195 integer, target :: pointee, several_arguments_return 196 integer(kind=4) :: integer_return 197 type(cart) :: c, cout 198 type(cart_nd) :: c_nd 199 type(nested_cart_3d) :: nested_c 200 character(40) :: returned_string, returned_string_debugger 201 real8 = 3.00 202 real4 = 9.3 203 integer_array = 17 204 fft = cmplx(2.1, 3.3) 205 print *, fft 206 untrue = .FALSE. 207 int_pointer => pointee 208 pointee = 87 209 c%x = 2 210 c%y = 4 211 c_nd%x = 4 212 allocate(c_nd%d(4)) 213 c_nd%d = 6 214 nested_c%z = 3 215 nested_c%d%x = 1 216 nested_c%d%y = 2 217 ! Use everything so it is not elided by the compiler. 218 call no_arg_subroutine() 219 no_arg_return = no_arg() .AND. one_arg(.FALSE.) 220 several_arguments_return = several_arguments(1,2,3) + return_constant() 221 integer_return = array_function(integer_array) 222 integer_return = mix_of_scalar_arguments(2, untrue, real8) 223 real4 = real4_argument(3.4) 224 integer_return = pointer_function(int_pointer) 225 c = pass_cart(c) 226 integer_return = pass_cart_nd(c_nd) 227 nested_c = pass_nested_cart(nested_c) 228 integer_return = hidden_string_length('string of implicit length') 229 call run(no_arg_subroutine) 230 integer_return = one_arg_value(10) 231 integer_return = sum_some(1,2,3) 232 returned_string = return_string() 233 cout = build_cart(4,5) 234 fft_result = complex_argument(fft) 235 print *, cout 236 print *, several_arguments_return 237 print *, fft_result 238 print *, real4 239 print *, integer_return 240 print *, returned_string_debugger 241 deallocate(c_nd%d) ! post_init 242end program 243