Procedures as arguments - set dummy arguments
vincent...@polytechnique.org
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
> 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
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
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
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
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
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.