Procedures as arguments - set dummy arguments

9 views
Skip to first unread message

vincent...@polytechnique.org

unread,
Nov 21, 2007, 12:39:13 AM11/21/07
to
Hello everyone

I am quite experienced with FORTRAN but I really have problems with
this issue.
I am trying to make the following code, where I want to use something
like function overloading, by setting one argument of one function to
a definite value when it is called (see NON working line)

I do not want to put the variable a as a global one for parallel-
processing reasons, but I cannot think of any way to make this code
work

Any help would be greatly appreciated

Best regards

Vincent

program dbg
implicit none

integer, parameter :: N = 10
real, dimension(N) :: xval

real :: junk

integer :: i

interface
function f1(x) result(res)
implicit none
real :: x, res
end function f1
end interface

interface
function f2(x, a) result(res)
implicit none
real :: x, res, a
end function f2
end interface

do i = 1, N
xval(i) = (i-1.)/N*5.
print *, "INIT :", xval(i), f1(x=xval(i)), f2(x=xval(i), a=2.)
end do

call print_values(xval, N, f=f1)
! call print_values(xval, N, f=f2(SOMETHING, a=2.)) <=== WILL NOT
WORK

contains

subroutine print_values(x, npts, f)
implicit none
interface
function f(x) result(res)
implicit none
real :: x
real :: res
end function f
end interface

real :: junk

integer :: i, npts
real, dimension(:) :: x

do i = 1, npts
junk = f(x(i))
print *, x(i), junk
end do

end subroutine print_values

end program dbg

function f1(x) result(res)
real :: res, x

res = 2.*x

end function f1

function f2(x, a) result(res)
real :: res, x
real :: a

res = 2.*x*a

end function f2

Richard Maine

unread,
Nov 21, 2007, 1:14:53 AM11/21/07
to
<vincent...@polytechnique.org> wrote:

> I am trying to make the following code, where I want to use something
> like function overloading, by setting one argument of one function to
> a definite value when it is called (see NON working line)
>
> I do not want to put the variable a as a global one for parallel-
> processing reasons, but I cannot think of any way to make this code
> work

[much elided]


> call print_values(xval, N, f=f1)
> ! call print_values(xval, N, f=f2(SOMETHING, a=2.)) <=== WILL NOT

As you noted, you can't do that. You can't do anything very much like it
either I'm afraid. There are really only two things you can do with a
function as an actual argument.

First, you can pass the function as an argument, as in your first call
above. That's fine.

Second, you can evaluate the function and pass the function result as an
actual argument. In that case, all that gets passed is the result - not
the function. If the function returns a real, as in these examples, the
corresponding dummy argument would just be a real - nothing to do with
functions. This isn't really anything special relating to functions -
just a particular case of evaluating an expression and passing the
expression result as an actual argument.

What you are basically looking to do is generate another function, based
on f2. There isn't any concept like that in the language.

One way to do something like this is to actually write another function,
I'll call it f3 for illustrative purposes, which calls f2. But then f3
is going to have to get the value for the "a" argument form somewhere.
I'm afraid that "somewhere" pretty much has to be a global variable. If
internal procedures could be actual arguments (they can't), you could
make f3 an internal procedure and get the value of "a" via host
association, which is at least better than a globa variable. You might
have a compiler that allows that nonstandard feature.

About the only other thing I can think of is to mae the call to
print_values look like

call print_values(xval, N, f=f2, a=2.)

and have print_values reference f(whatever,a)

Then both f1 and f2 would have to accept the extra argument (their
interface has to be the same), but f1 could ignore it. A variant of
that, if you don't want to modify f1 (I could imagine many reasons why
you might not want to), would be to write a wrapper function
f1_with_extra_argument, which has the extra argument, but just ignores
it and calls f1. Something like

function f1_with_extra_argument(x,a), result(res)
...
res = f1(x)
end

Basically, the language doesn't have the functionality you are looking
for. Yes, I've seen people look for things like that before; there have
been times when I would have found something like that convenient. But
it isn't there. So you have to craft something using what the language
does have.

--
Richard Maine | Good judgement comes from experience;
email: last name at domain . net | experience comes from bad judgement.
domain: summertriangle | -- Mark Twain

James Van Buskirk

unread,
Nov 21, 2007, 1:42:10 AM11/21/07
to
<vincent...@polytechnique.org> wrote in message
news:5e314b82-f662-4967...@41g2000hsh.googlegroups.com...

> I am quite experienced with FORTRAN but I really have problems with
> this issue.
> I am trying to make the following code, where I want to use something
> like function overloading, by setting one argument of one function to
> a definite value when it is called (see NON working line)

> I do not want to put the variable a as a global one for parallel-
> processing reasons, but I cannot think of any way to make this code
> work

The f08 way:

C:\Program Files\Microsoft Visual Studio 8\James\clf\extra_args>type
extra_args.
f90
module create_arg
implicit none
contains
recursive subroutine create_f2_arg(a, callback)
real a
interface
subroutine callback(f2)
interface
function f2(x)
real x
real f2


end function f2
end interface

end subroutine callback
end interface

call callback(f2)
contains
function f2(x)
real x
real f2

f2 = 2*x*a
end function f2
end subroutine create_f2_arg
end module create_arg

module main
implicit none
contains
subroutine main_first_half
use create_arg

call create_f2_arg(a = 2.0, callback = main_second_half)
end subroutine main_first_half

subroutine main_second_half(f2)


integer, parameter :: N = 10

real, save :: xval(N)


real junk
integer i
interface
function f1(x)

implicit none
real f1
real x


end function f1
end interface

interface
function f2(x)
implicit none
real f2
real x


end function f2
end interface
do i = 1, N

xval(i) = (i-1.0)/N*5
write(*,*) "INIT :", xval(i), f1(x=xval(i)), f2(x=xval(i))
end do

call print_values(xval, N, f = f1)

call print_values(xval, N, f = f2)
end subroutine main_second_half

subroutine print_values(x, npts, f)
interface
function f(x)
implicit none
real x
real f


end function f
end interface
real junk

integer i
integer npts
real x(:)

do i = 1, npts
junk = f(x(i))

write(*,*) x(i), junk


end do
end subroutine print_values

end module main

program dbg
use main
implicit none

call main_first_half
end program dbg

function f1(x)
implicit none
real x
real f1

f1 = 2*x
end function f1

C:\Program Files\Microsoft Visual Studio 8\James\clf\extra_args>ifort
extra_args
.f90
Intel(R) Fortran Compiler for Intel(R) EM64T-based applications, Version 9.1
Build 20061104
Copyright (C) 1985-2006 Intel Corporation. All rights reserved.

Microsoft (R) Incremental Linker Version 8.00.40310.39
Copyright (C) Microsoft Corporation. All rights reserved.

-out:extra_args.exe
-subsystem:console
extra_args.obj

C:\Program Files\Microsoft Visual Studio 8\James\clf\extra_args>extra_args
INIT : 0.0000000E+00 0.0000000E+00 0.0000000E+00
INIT : 0.5000000 1.000000 2.000000
INIT : 1.000000 2.000000 4.000000
INIT : 1.500000 3.000000 6.000000
INIT : 2.000000 4.000000 8.000000
INIT : 2.500000 5.000000 10.00000
INIT : 3.000000 6.000000 12.00000
INIT : 3.500000 7.000000 14.00000
INIT : 4.000000 8.000000 16.00000
INIT : 4.500000 9.000000 18.00000
0.0000000E+00 0.0000000E+00
0.5000000 1.000000
1.000000 2.000000
1.500000 3.000000
2.000000 4.000000
2.500000 5.000000
3.000000 6.000000
3.500000 7.000000
4.000000 8.000000
4.500000 9.000000
0.0000000E+00 0.0000000E+00
0.5000000 2.000000
1.000000 4.000000
1.500000 6.000000
2.000000 8.000000
2.500000 10.00000
3.000000 12.00000
3.500000 14.00000
4.000000 16.00000
4.500000 18.00000

--
write(*,*) transfer((/17.392111325966148d0,6.5794487871554595D-85, &
6.0134700243160014d-154/),(/'x'/)); end


Reinhold Bader

unread,
Nov 21, 2007, 5:05:59 AM11/21/07
to
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1

Richard Maine wrote:

>
> One way to do something like this is to actually write another function,
> I'll call it f3 for illustrative purposes, which calls f2. But then f3
> is going to have to get the value for the "a" argument form somewhere.
> I'm afraid that "somewhere" pretty much has to be a global variable.

This is a case where Fortran 2003 polymorphism will actually come in
very useful in getting around using globals ...

one possibility to recode this would then be

module mod_xp
implicit none
type, abstract :: foo
end type
abstract interface
function func(x, a)
import :: foo
real :: x, func
class(foo), intent(in) :: a
end function func
end interface
contains
subroutine print_values(x, f, a)
implicit none
procedure(func) :: f
class(foo), intent(in) :: a(:)
real, dimension(:) :: x

real :: junk

integer :: i

do i = 1, min(size(x),size(a))
junk = f(x(i),a(i))


print *, x(i), junk
end do
end subroutine print_values

end module mod_xp
module user_defined
use mod_xp
implicit none
type, extends(foo) :: mine
real :: x
end type
contains


function f2(x, a) result(res)
real :: res, x

class(foo), intent(in) :: a
select type(a)
class is (mine)
res = 2.*x*a%x
end select
end function f2
function f1(x, a) result(res)
real :: res, x
class(foo), intent(in) :: a


res = 2.*x
end function f1

end module user_defined
program xp
use user_defined


implicit none
integer, parameter :: N = 10
real, dimension(N) :: xval

integer :: i
class(foo), allocatable :: a(:)
allocate(mine :: a(N))


do i = 1, N
xval(i) = (i-1.)/N*5.

select type(a)
class is (mine)
a(i)%x=2.0 ! don't care in f1 call what this is
end select
print *, "INIT :", xval(i), f1(xval(i), a(i)), f2(xval(i), a(i))
end do

call print_values(xval, f1, a)
call print_values(xval, f2, a)
end program xp

although NAG's present compiler seems to bomb out on the
procedure(func) line ... replacing this by a suitable interface
works.

Regards

-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.4.2 (GNU/Linux)
Comment: Using GnuPG with SUSE - http://enigmail.mozdev.org

iD8DBQFHRAMHFVLhKuD7VgsRAgCPAKDKziUBx3ElDdVnUgTYRfclOs8yXACfRkxx
1XGkh9ZgY0oWF6d4rNaFl4I=
=l067
-----END PGP SIGNATURE-----

paul.rich...@gmail.com

unread,
Nov 21, 2007, 11:08:56 AM11/21/07
to
Vincent,

I suppose that this must be one of the F95 solutions closest to what
you are after:

program dbg


implicit none
integer, parameter :: N = 10
real, dimension(N) :: xval

real :: junk
integer :: i
interface

function f1(x, a) result(res)


implicit none
real :: x, res

real, optional :: a


end function f1
end interface

interface
function f2(x, a) result(res)
implicit none
real :: x, res, a
end function f2
end interface

do i = 1, N
xval(i) = (i-1.)/N*5.

print *, "INIT :", xval(i), f1(x=xval(i)), f2(x=xval(i), a=2.)
end do

call print_values(xval, N, g=f1)
call print_values(xval, N, g=f2, a=2.)
contains
subroutine print_values(x, npts, g, a)
implicit none
real, optional :: a
interface f
function g(x, a) result(res)


implicit none
real :: x, res

real, optional :: a
end function g


end interface
real :: junk
integer :: i, npts
real, dimension(:) :: x
do i = 1, npts

junk = f(x(i), a)


print *, x(i), junk
end do
end subroutine print_values

end program dbg

function f1(x, a) result(res)
real :: res, x

real, optional :: a
res = 2.*x
if (present(a)) print *, "Bad arg to A"
end function f1

function f2(x, a) result(res)
real :: res, x

real, optional :: a
if (.not.present(a)) print *, "Bad arg to B"


res = 2.*x*a
end function f2

It bombs gfortran (PR31213 - a patch is on its way) but it does the
right thing with other compilers.

Paul Thomas

James Van Buskirk

unread,
Nov 21, 2007, 11:28:40 AM11/21/07
to
<paul.rich...@gmail.com> wrote in message
news:b22cf14a-4e80-49a6...@e1g2000hsh.googlegroups.com...

> gfortran

C:\gfortran\clf\WriteFun>type WriteFun.f90
module gwinty
use ISO_C_BINDING
implicit none
private
public StartupInfo
type, bind(C) :: StartupInfo
integer(C_INT32_T) cb
type(C_PTR) lpReserved
type(C_PTR) lpDesktop
type(C_PTR) lpTitle
integer(C_INT32_T) dwX
integer(C_INT32_T) dwY
integer(C_INT32_T) dwXSize
integer(C_INT32_T) dwYSize
integer(C_INT32_T) dwXCountChars
integer(C_INT32_T) dwYCountChars
integer(C_INT32_T) dwFillAttribute
integer(C_INT32_T) dwFlags
integer(C_INT16_T) wShowWindow
integer(C_INT16_T) cbReserved2
type(C_PTR) lpReserved2
integer(C_INTPTR_T) hStdInput
integer(C_INTPTR_T) hStdOutput
integer(C_INTPTR_T) hStdError
end type StartupInfo

public SecurityAttributes
type, bind(C) :: SecurityAttributes
integer(C_INT32_T) nLength
type(C_PTR) lpSecurityDescriptor
integer(C_INT) bInheritHandle
end type SecurityAttributes

public ProcessInformation
type, bind(C) :: ProcessInformation
integer(C_INTPTR_T) hProcess
integer(C_INTPTR_T) hThread
integer(C_INT32_T) dwProcessId
integer(C_INT32_T) dwThreadId
end type ProcessInformation

public CREATE_DEFAULT_ERROR_MODE
integer(C_INT32_T), parameter :: CREATE_DEFAULT_ERROR_MODE = ishft(1,26)

public CREATE_NO_WINDOW
integer(C_INT32_T), parameter :: CREATE_NO_WINDOW = ishft(1,27)

public INFINITE
integer(C_INT32_T), parameter :: INFINITE = -1

public WAIT_FAILED
integer(C_INT32_T), parameter :: WAIT_FAILED = -1

public STARTF_USESHOWWINDOW
integer(C_INT32_T), parameter :: STARTF_USESHOWWINDOW = 1

public SW_SHOWNORMAL
integer(C_INT16_T), parameter :: SW_SHOWNORMAL = 1

public CREATE_NEW_PROCESS_GROUP
integer(C_INT32_T), parameter :: CREATE_NEW_PROCESS_GROUP = ishft(1,9)

public NORMAL_PRIORITY_CLASS
integer(C_INT32_T), parameter :: NORMAL_PRIORITY_CLASS = ishft(1,5)
end module gwinty

module gwin
use gwinty
use ISO_C_BINDING
implicit none
private
public CreateProcessA
interface
function CreateProcessA(lpApplicationName, &
lpCommandLine, lpProcessAttributes, lpThreadAttributes, &
bInheritHandles, dwCreationFlags, lpEnvironment, &
lpCurrentDirectory, lpStartupInfo, lpProcessInformation &
) bind(C,name='CreateProcessA')
use gwinty
use ISO_C_BINDING
implicit none
integer(C_INT) CreateProcessA
! character(kind=C_CHAR) lpApplicationName
type(C_PTR), value :: lpApplicationName
! character(kind=C_CHAR) lpCommandLine
type(C_PTR), value :: lpCommandLine
! type(SecurityAttributes) lpProcessAttributes
type(C_PTR), value :: lpProcessAttributes
! type(SecurityAttributes) lpThreadAttributes
type(C_PTR), value :: lpThreadAttributes
integer(C_INT), value :: bInheritHandles
integer(C_INT32_T), value :: dwCreationFlags
type(C_PTR), value :: lpEnvironment
! character(kind=C_CHAR) lpCurrentDirectory
type(C_PTR), value :: lpCurrentDirectory
type(StartupInfo) lpStartupInfo
type(ProcessInformation) lpProcessInformation
end function CreateProcessA
end interface

public WaitForSingleObject
interface
function WaitForSingleObject(hHandle, &
dwMilliseconds) bind(C,name='WaitForSingleObject')
use ISO_C_BINDING
implicit none
integer(C_INT32_T) WaitForSingleObject
integer(C_INTPTR_T), value :: hHandle
integer(C_INT32_T), value :: dwMilliSeconds
end function WaitForSingleObject
end interface

public GetLastError
interface
function GetLastError() bind(C,name='GetLastError')
use ISO_C_BINDING
implicit none
integer(C_INT32_T) GetLastError
end function GetLastError
end interface

public LoadLibraryA
interface
function LoadLibraryA(lpFileName) bind(C,name='LoadLibraryA')
use ISO_C_BINDING
implicit none
integer(C_INTPTR_T) LoadLibraryA
character(kind=C_CHAR) lpFileName
end function LoadLibraryA
end interface

public GetProcAddress
interface
function GetProcAddress(hModule, lpProcName) &
bind(C,name='GetProcAddress')
use ISO_C_BINDING
implicit none
type(C_FUNPTR) GetProcAddress
integer(C_INTPTR_T), value :: hModule
character(kind=C_CHAR) lpProcName
end function GetProcAddress
end interface

public CloseHandle
interface
function CloseHandle(hObject) bind(C,name='CloseHandle')
use ISO_C_BINDING
implicit none
integer(C_INT) CloseHandle
integer(C_INTPTR_T), value :: hObject
end function CloseHandle
end interface

public FreeLibrary
interface
function FreeLibrary(hModule) bind(C,name='FreeLibrary')
use ISO_C_BINDING
implicit none
integer(C_INTPTR_T), value :: hModule
integer(C_INT) FreeLibrary
end function FreeLibrary
end interface
end module gwin

module pv_mod
implicit none


contains
subroutine print_values(x, npts, f)

interface
function f(x)
implicit none
real x
real f
end function f
end interface
real junk


integer i
integer npts
real x(:)

do i = 1, npts
junk = f(x(i))
write(*,*) x(i), junk


end do
end subroutine print_values

end module pv_mod

program WriteFun
use gwinty
use gwin
use ISO_C_BINDING
implicit none
type(StartupInfo) lpStartupInfo
integer(C_INT) cpResult
character(len=256, kind=C_CHAR), target :: lpCommandLine
character(80) source_file
type(ProcessInformation) lpProcessInformation
integer(C_INT32_T) wResult
type(C_PTR) C_NULL_PTR1
character(len=80, kind=C_CHAR), target :: lpTitle
character(len=80, kind=C_CHAR), target :: empty
integer(C_INTPTR_T) lResult
type(C_FUNPTR) cf2
integer(C_INT) chResult
integer(C_INT) flResult
character(len=80, kind=C_CHAR) f2_name
! Oog. procedure pointers not yet implemented in gfortran
! interface
! function f(x)
! use ISO_C_BINDING
! implicit none
! real(C_FLOAT) f
! real(C_FLOAT) x
! end function f
! end interface
! procedure(f), pointer :: f2
interface
subroutine main_second_half(cf2) bind(C)
use ISO_C_BINDING
implicit none
type(C_FUNPTR), value :: cf2
end subroutine main_second_half
end interface

f2_name = 'f'
source_file = 'testme'
open(10,file=trim(source_file)//'.f90',status='replace')
write(10,'(a)') 'function '//trim(f2_name)//"(x) bind(C,name='"// &
trim(f2_name)//"')"
write(10,'(a)') ' use ISO_C_BINDING'
write(10,'(a)') ' implicit none'
write(10,'(a)') ' real(C_FLOAT) x'
write(10,'(a)') ' real(C_FLOAT) '//trim(f2_name)
write(10,'(a)') ' real(C_FLOAT), parameter :: a = 2.0'
write(10,'(a)') ''
write(10,'(a)') ' '//trim(f2_name)//' = 2*x*a'
write(10,'(a)') 'end function '//trim(f2_name)
close(10)
lpCommandLine = 'C:\gfortran\win64\bin\x86_64-pc-mingw32-gfortran.exe '//
&
'-fno-backslash ' //trim(source_file)//'.f90 '//'-shared '// &
'-s '//'-o'//trim(source_file)//'.dll'//achar(0)
!write(*,'(a)') lpCommandLine(1:index(lpCommandLine,achar(0))-1)
lpTitle = "gfortran Command Prompt"//achar(0)
! Argh. Keywords not allowed in structure constructors
! lpStartupInfo = StartupInfo( &
! cb = size(transfer(lpStartupInfo,(/1_C_INT8_T/))), &
! lpReserved = C_NULL_PTR, &
! lpDesktop = C_NULL_PTR, &
! lpTitle = C_LOC(lpTitle(1:1)), &
! dwX = 0, &
! dwY = 0, &
! dwXSize = 0, &
! dwYSize = 0, &
! dwXCountChars = 0, &
! dwYCountChars = 0, &
! dwFillAttribute = 0, &
! dwFlags = 0, &
! wShowWindow = 0, &
! cbReserved2 = 0, &
! lpReserved2 = C_NULL_PTR, &
! hStdInput = 0_C_INTPTR_T, &
! hStdOutput = 0_C_INTPTR_T, &
! hStdError = 0_C_INTPTR_T )
lpStartupInfo = StartupInfo( &
size(transfer(lpStartupInfo,(/1_C_INT8_T/))) , & ! cb
C_NULL_PTR, & ! lpReserved
C_NULL_PTR, & ! lpDesktop
C_LOC(lpTitle(1:1)), & ! lpTitle
0, & ! dwX
0, & ! dwY
0, & ! dwXSize
0, & ! dwYSize
0, & ! dwXCountChars
0, & ! dwYCountChars
0, & ! dwFillAttribute
0, & ! dwFlags
0, & ! wShowWindow
0, & ! cbReserved2
C_NULL_PTR, & ! lpReserved2
0_C_INTPTR_T, & ! hStdInput
0_C_INTPTR_T, & ! hStdOutput
0_C_INTPTR_T ) ! hStdError
cpResult = CreateProcessA( &
lpApplicationName = C_NULL_PTR, &
lpCommandLine = C_LOC(lpCommandLine(1:1)), &
lpProcessAttributes = C_NULL_PTR, &
lpThreadAttributes = C_NULL_PTR, &
bInheritHandles = 0, & ! FALSE
dwCreationFlags = ior(CREATE_DEFAULT_ERROR_MODE, &
CREATE_NO_WINDOW), &
lpEnvironment = C_NULL_PTR, &
lpCurrentDirectory = C_NULL_PTR, &
lpStartupInfo = lpStartupInfo, &
lpProcessInformation = lpProcessInformation )
if(cpResult == 0) then
write(*,*) 'Error in CreateProcessA'
write(*,*) GetLastError()
stop
end if
wResult = WaitForSingleObject( &
hHandle = lpProcessInformation%hProcess, &
dwMilliseconds = INFINITE)
if(wResult == WAIT_FAILED) then
write(*,*) 'Error in WaitForSingleObject'
write(*,*) GetLastError()
write(*,'(z32.32)') lpProcessInformation
stop
end if
chResult = CloseHandle(lpProcessInformation%hProcess)
chResult = CloseHandle(lpProcessInformation%hThread)
lResult = LoadLibraryA(trim(source_file)//'.dll'//achar(0))
if(lResult == 0) then
write(*,*) 'Error in LoadLibraryA'
write(*,*) GetLastError()
stop
end if
cf2 = GetProcAddress(lResult, trim(f2_name)//achar(0))
if(.NOT.C_ASSOCIATED(cf2)) then
write(*,*) 'Error in GetProcAddress'
write(*,*) GetLastError()
stop
end if
! call C_F_PROCPOINTER(cf2,f2)
! Bitter necessity: procedure pointers not yet available
call main_second_half(cf2)
flResult = FreeLibrary(lResult)
if(flResult == 0) then
write(*,*) 'Error in FreeLibrary'
write(*,*) GetLastError()
stop
end if
open(10,file=trim(source_file)//'.dll')
close(10,status='delete')
open(10,file=trim(source_file)//'.f90')
close(10,status='delete')
end program WriteFun

subroutine main_second_half(f2) bind(C)
use pv_mod
implicit none
interface
function f1(x)


real f1
real x
end function f1

function f2(x) bind(C)
use ISO_C_BINDING
implicit none
real(C_FLOAT) f2
real(C_FLOAT) x


end function f2
end interface

integer, parameter :: N = 10

real xval(N)
real junk
integer i

do i = 1, N


xval(i) = (i-1.0)/N*5
write(*,*) "INIT :", xval(i), f1(x=xval(i)), f2(x=xval(i))

end do

call print_values(xval, N, f=f1)
call print_values(xval, N, f=f2)
end subroutine main_second_half

function f1(x)
implicit none
real f1
real x

f1 = 2*x
end function f1

C:\gfortran\clf\WriteFun>C:\gfortran\win64\bin\x86_64-pc-mingw32-gfortran
WriteF
un.f90 -fno-backslash -oWriteFun

C:\gfortran\clf\WriteFun>WriteFun
INIT : 0.000000 0.000000 0.000000


INIT : 0.5000000 1.000000 2.000000
INIT : 1.000000 2.000000 4.000000
INIT : 1.500000 3.000000 6.000000
INIT : 2.000000 4.000000 8.000000
INIT : 2.500000 5.000000 10.00000
INIT : 3.000000 6.000000 12.00000
INIT : 3.500000 7.000000 14.00000
INIT : 4.000000 8.000000 16.00000
INIT : 4.500000 9.000000 18.00000

0.000000 0.000000


0.5000000 1.000000
1.000000 2.000000
1.500000 3.000000
2.000000 4.000000
2.500000 5.000000
3.000000 6.000000
3.500000 7.000000
4.000000 8.000000
4.500000 9.000000

0.000000 0.000000

James Van Buskirk

unread,
Nov 22, 2007, 3:17:10 AM11/22/07
to
<vincent...@polytechnique.org> wrote in message
news:5e314b82-f662-4967...@41g2000hsh.googlegroups.com...

> I am quite experienced with FORTRAN but I really have problems with


> this issue.
> I am trying to make the following code, where I want to use something
> like function overloading, by setting one argument of one function to
> a definite value when it is called (see NON working line)

> I do not want to put the variable a as a global one for parallel-
> processing reasons, but I cannot think of any way to make this code
> work

Here's another example, but this time we use a global variable
ensuring, however, that it's thread private via OMP directives.
I think that OMP is some kind of standard, not ifort-specific.

C:\Program Files\Microsoft Visual Studio 8\James\clf\omp_test>type mycom.i90
! File: mycom.i90
! Public domain 2007 James Van Buskirk
integer(selected_int_kind(9)) mycom_var
common /mycom/ mycom_var
!$OMP THREADPRIVATE(/mycom/)
! End of file: mycom.i90

C:\Program Files\Microsoft Visual Studio 8\James\clf\omp_test>type
omp_test.f90
! File: omp_test.f90
! Public domain 2007 James Van Buskirk
program omp_test
use IFPORT
implicit none
include 'mycom.i90'
integer i
integer(selected_int_kind(9)) values(8)
integer j
integer, parameter :: N = 7
integer, parameter :: nsteps = 7
integer, parameter :: nsleep = 100


interface
function f(x)
implicit none

integer f
integer x


end function f
end interface

interface
function OMP_GET_THREAD_NUM()
implicit none
integer(selected_int_kind(9)) OMP_GET_THREAD_NUM
end function OMP_GET_THREAD_NUM
end interface

!$OMP PARALLEL DO DEFAULT(PRIVATE)


do i = 1, N

mycom_var = i
do j = 1, nsteps
call sleepqq(nsleep)
!$OMP CRITICAL(WRITE_STUFF)
call date_and_time(values=values)
write(*,'(2(a,i0),a,i4,a,i2,2(a,i2.2),a,i3.3)') &
'Thread = ', OMP_GET_THREAD_NUM(), ' i = ', i, &
' f(i) = ', f(i), ' time = ', values(5),':',values(6), &
':',values(7),'.',values(8)
!$OMP END CRITICAL(WRITE_STUFF)
end do
end do
!$OMP END PARALLEL DO
end program omp_test

function f(x)
implicit none
integer f
integer x
include 'mycom.i90'

f = mycom_var*x
end function f
! End of file: omp_test.f90

C:\Program Files\Microsoft Visual Studio 8\James\clf\omp_test>ifort /Qopenmp
omp
_test.f90


Intel(R) Fortran Compiler for Intel(R) EM64T-based applications, Version 9.1
Build 20061104
Copyright (C) 1985-2006 Intel Corporation. All rights reserved.

C:\Program Files\Microsoft Visual Studio
8\James\clf\omp_test\omp_test.f90(27) :
(col. 7) remark: OpenMP DEFINED LOOP WAS PARALLELIZED.


Microsoft (R) Incremental Linker Version 8.00.40310.39
Copyright (C) Microsoft Corporation. All rights reserved.

-out:omp_test.exe
-subsystem:console
-nodefaultlib:libguide_stats.lib
-nodefaultlib:libguide40_stats.lib
-defaultlib:libguide.lib
omp_test.obj

C:\Program Files\Microsoft Visual Studio 8\James\clf\omp_test>omp_test
Thread = 1 i = 5 f(i) = 25 time = 1:10:19.875
Thread = 0 i = 1 f(i) = 1 time = 1:10:19.875
Thread = 0 i = 1 f(i) = 1 time = 1:10:19.984
Thread = 1 i = 5 f(i) = 25 time = 1:10:19.984
Thread = 1 i = 5 f(i) = 25 time = 1:10:20.093
Thread = 0 i = 1 f(i) = 1 time = 1:10:20.093
Thread = 1 i = 5 f(i) = 25 time = 1:10:20.203
Thread = 0 i = 1 f(i) = 1 time = 1:10:20.203
Thread = 0 i = 1 f(i) = 1 time = 1:10:20.312
Thread = 1 i = 5 f(i) = 25 time = 1:10:20.312
Thread = 0 i = 1 f(i) = 1 time = 1:10:20.421
Thread = 1 i = 5 f(i) = 25 time = 1:10:20.421
Thread = 1 i = 5 f(i) = 25 time = 1:10:20.531
Thread = 0 i = 1 f(i) = 1 time = 1:10:20.531
Thread = 1 i = 6 f(i) = 36 time = 1:10:20.640
Thread = 0 i = 2 f(i) = 4 time = 1:10:20.640
Thread = 0 i = 2 f(i) = 4 time = 1:10:20.750
Thread = 1 i = 6 f(i) = 36 time = 1:10:20.750
Thread = 1 i = 6 f(i) = 36 time = 1:10:20.859
Thread = 0 i = 2 f(i) = 4 time = 1:10:20.859
Thread = 1 i = 6 f(i) = 36 time = 1:10:20.968
Thread = 0 i = 2 f(i) = 4 time = 1:10:20.968
Thread = 1 i = 6 f(i) = 36 time = 1:10:21.078
Thread = 0 i = 2 f(i) = 4 time = 1:10:21.078
Thread = 1 i = 6 f(i) = 36 time = 1:10:21.187
Thread = 0 i = 2 f(i) = 4 time = 1:10:21.187
Thread = 0 i = 2 f(i) = 4 time = 1:10:21.296
Thread = 1 i = 6 f(i) = 36 time = 1:10:21.296
Thread = 1 i = 7 f(i) = 49 time = 1:10:21.406
Thread = 0 i = 3 f(i) = 9 time = 1:10:21.406
Thread = 0 i = 3 f(i) = 9 time = 1:10:21.515
Thread = 1 i = 7 f(i) = 49 time = 1:10:21.515
Thread = 1 i = 7 f(i) = 49 time = 1:10:21.625
Thread = 0 i = 3 f(i) = 9 time = 1:10:21.625
Thread = 1 i = 7 f(i) = 49 time = 1:10:21.734
Thread = 0 i = 3 f(i) = 9 time = 1:10:21.734
Thread = 1 i = 7 f(i) = 49 time = 1:10:21.843
Thread = 0 i = 3 f(i) = 9 time = 1:10:21.843
Thread = 0 i = 3 f(i) = 9 time = 1:10:21.953
Thread = 1 i = 7 f(i) = 49 time = 1:10:21.953
Thread = 1 i = 7 f(i) = 49 time = 1:10:22.062
Thread = 0 i = 3 f(i) = 9 time = 1:10:22.062
Thread = 0 i = 4 f(i) = 16 time = 1:10:22.171
Thread = 0 i = 4 f(i) = 16 time = 1:10:22.281
Thread = 0 i = 4 f(i) = 16 time = 1:10:22.390
Thread = 0 i = 4 f(i) = 16 time = 1:10:22.500
Thread = 0 i = 4 f(i) = 16 time = 1:10:22.609
Thread = 0 i = 4 f(i) = 16 time = 1:10:22.718
Thread = 0 i = 4 f(i) = 16 time = 1:10:22.828

You can see how the threads are chugging along in parallel,
slowed down by the sleepqq call so that some overlap is
forced. Each thread gets its own copy of /mycom/ so function
f is behaving differently for each thread without them stepping
on each others' toes.

Reply all
Reply to author
Forward
0 new messages