F200x programs?

"John Appleyard" <john.spamtrap@polyhedron.com> wrote in message
news:jjvneu$ikh$1@dont-email.me...

> Does anyone know of any decently sized sample programs that exercise the
> new features in F200x?

F03GL does some C interop.

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

On Saturday, March 17, 2012 8:36:58 PM UTC+9, Andrew Mai wrote:
> On 03/16/2012 09:31 PM, michaelmetcalf@compuserve.com wrote:
>
> > We would like to think that Appendix E of "Modern Fortran Explained" is just such an example (of OO-programming).
>
> I tried four compilers with this short program. All failed. xlf2003 came the closest:
>
> % xlf2003 Metcalf_oo.f90
> ** anylist_m === End of Compilation 1 ===
> "Metcalf_oo.f90", line 273.18: 1514-668 (S) Dummy argument this of overridden binding print was
> declared without the INTENT(IN) attribute. The corresponding dummy argument of overriding binding
> print must not be declared with the INTENT(IN) attribute.
> ** myitem_list_m === End of Compilation 2 ===
> "Metcalf_oo.f90", line 303.7: 1514-219 (S) Unable to access module symbol file for module
> myitem_list_m. Check path and file permissions of file. Use association not done for this module.
> 1501-511 Compilation failed for file Metcalf_oo.f90.
>
Sorry for this error, which can be corrected by adding intent(in) to the line after subroutine print(this).

Regards,

Mike Metcalf

Op vrijdag 16 maart 2012 16:49:50 UTC+1 schreef John Appleyard het volgende:
> Does anyone know of any decently sized sample programs that exercise the
> new features in F200x?
> --
> JA

I have a whole bunch of sample programs, many of which use F2003 features,
though not all. I can send to you.

Regards,

Arjen

On 3/19/2012 6:00 AM, michaelmetcalf@compuserve.com wrote:
> On Saturday, March 17, 2012 8:36:58 PM UTC+9, Andrew Mai wrote:
>> On 03/16/2012 09:31 PM, michaelmetcalf@compuserve.com wrote:
>>
>>> We would like to think that Appendix E of "Modern Fortran Explained" is just such an example (of OO-programming).
>>
>> I tried four compilers with this short program. All failed. xlf2003 came the closest:
>>
>> % xlf2003 Metcalf_oo.f90
>> ** anylist_m === End of Compilation 1 ===
>> "Metcalf_oo.f90", line 273.18: 1514-668 (S) Dummy argument this of overridden binding print was
>> declared without the INTENT(IN) attribute. The corresponding dummy argument of overriding binding
>> print must not be declared with the INTENT(IN) attribute.
>> ** myitem_list_m === End of Compilation 2 ===
>> "Metcalf_oo.f90", line 303.7: 1514-219 (S) Unable to access module symbol file for module
>> myitem_list_m. Check path and file permissions of file. Use association not done for this module.
>> 1501-511 Compilation failed for file Metcalf_oo.f90.
>>
> Sorry for this error, which can be corrected by adding intent(in) to the line after subroutine print(this).
>

Current ifort compiles (but doesn't run) oo.f90 with this correction.


--
Tim Prince

On 3/17/2012 1:04 PM, Ian Chivers wrote:
> intel requires
> /stand:f03 or /std03.

The /stand (or -std) switch in Intel Fortran does not affect which
language features are supported - that is a standards diagnostic option
only. Perhaps you are thinking of /standard-semantics (or
-standard-semantics), which changes default behaviors in some areas to
conform to Fortran 2003.

I note that even with this option, Intel Fortran does not like Mike's
source file. I will look at this more closely.

--
Steve Lionel
Developer Products Division
Intel Corporation
Merrimack, NH

For email address, replace "invalid" with "com"

User communities for Intel Software Development Products
http://software.intel.com/en-us/forums/
Intel Software Development Products Support
http://software.intel.com/sites/support/
My Fortran blog
http://www.intel.com/software/drfortran

Refer to http://software.intel.com/en-us/arti...ization-notice
for more information regarding performance and optimization choices in
Intel software products.

Walt Brainerd wrote:
> I have a nice coarray example (heat xfer on a plate)
> that runs on four images. Works on Intel and Cray.

Walt, where is this coarray example? I can't seem to find it in the
TGZ, nor by searching the www site. I'm interested because I'm starting
to play with coarrays to see if it'll be suitable for parallelising a
program of ours (and the more coarray examples I can find, the better).

Thanks, Tom

Op maandag 19 maart 2012 15:08:02 UTC+1 schreef Tom Micevski het volgende:
> Walt Brainerd wrote:
> > I have a nice coarray example (heat xfer on a plate)
> > that runs on four images. Works on Intel and Cray.
>
> Walt, where is this coarray example? I can't seem to find it in the
> TGZ, nor by searching the www site. I'm interested because I'm starting
> to play with coarrays to see if it'll be suitable for parallelising a
> program of ours (and the more coarray examples I can find, the better).
>
> Thanks, Tom

I have two coarray examples for you.

Regards,

Arjen

On 3/19/2012 7:08 AM, Tom Micevski wrote:
> Walt Brainerd wrote:
>> I have a nice coarray example (heat xfer on a plate)
>> that runs on four images. Works on Intel and Cray.
>
> Walt, where is this coarray example? I can't seem to find it in the TGZ,
> nor by searching the www site. I'm interested because I'm starting to
> play with coarrays to see if it'll be suitable for parallelising a
> program of ours (and the more coarray examples I can find, the better).
>
> Thanks, Tom

Sorry, I didn't know if anybody would actually be interested.

It is now at http://www.fortran.com/heat4_caf.f90

We have Dick Hendrickson to thank for the one-image version,
especially the clever use of the pointers n, e, w, and s.
Any strangeness in the coarray stuff is strictly mine.

--
Walt Brainerd

> I have a whole bunch of sample programs, many of which use F2003 features,
> though not all. I can send to you.
>
> Regards,
>
> Arjen

In that case then, Arjen, you might recognise the code below! The ! { dg
....... } things are testsuite directives.

Cheers

Paul

[pault@localhost ~]# cat
/svn/trunk/gcc/testsuite/gfortran.dg/typebound_operator_9.f03
! { dg-do run }
! { dg-add-options ieee }
! { dg-skip-if "Too big for local store" { spu-*-* } { "*" } { "" } }
!
! Solve a diffusion problem using an object-oriented approach
!
! Author: Arjen Markus (comp.lang.fortran)
! This version: pault@gcc.gnu.org
!
! Note:
! (i) This could be turned into a more sophisticated program
! using the techniques described in the chapter on
! mathematical abstractions.
! (That would allow the selection of the time integration
! method in a transparent way)
!
! (ii) The target procedures for process_p and source_p are
! different to the typebound procedures for dynamic types
! because the passed argument is not type(base_pde_object).
!
! (iii) Two solutions are calculated, one with the procedure
! pointers and the other with typebound procedures. The sums
! of the solutions are compared.

! (iv) The source is a delta function in the middle of the
! mesh, whilst the process is quartic in the local value,
! when it is positive.
!
! base_pde_objects --
! Module to define the basic objects
!
module base_pde_objects
implicit none
type, abstract :: base_pde_object
! No data
procedure(process_p), pointer, pass :: process_p
procedure(source_p), pointer, pass :: source_p
contains
procedure(process), deferred :: process
procedure(source), deferred :: source
procedure :: initialise
procedure :: nabla2
procedure :: print
procedure(real_times_obj), pass(obj), deferred :: real_times_obj
procedure(obj_plus_obj), deferred :: obj_plus_obj
procedure(obj_assign_obj), deferred :: obj_assign_obj
generic :: operator(*) => real_times_obj
generic :: operator(+) => obj_plus_obj
generic :: assignment(=) => obj_assign_obj
end type
abstract interface
function process_p (obj)
import base_pde_object
class(base_pde_object), intent(in) :: obj
class(base_pde_object), allocatable :: process_p
end function process_p
end interface
abstract interface
function source_p (obj, time)
import base_pde_object
class(base_pde_object), intent(in) :: obj
real, intent(in) :: time
class(base_pde_object), allocatable :: source_p
end function source_p
end interface
abstract interface
function process (obj)
import base_pde_object
class(base_pde_object), intent(in) :: obj
class(base_pde_object), allocatable :: process
end function process
end interface
abstract interface
function source (obj, time)
import base_pde_object
class(base_pde_object), intent(in) :: obj
real, intent(in) :: time
class(base_pde_object), allocatable :: source
end function source
end interface
abstract interface
function real_times_obj (factor, obj) result(newobj)
import base_pde_object
real, intent(in) :: factor
class(base_pde_object), intent(in) :: obj
class(base_pde_object), allocatable :: newobj
end function real_times_obj
end interface
abstract interface
function obj_plus_obj (obj1, obj2) result(newobj)
import base_pde_object
class(base_pde_object), intent(in) :: obj1
class(base_pde_object), intent(in) :: obj2
class(base_pde_object), allocatable :: newobj
end function obj_plus_obj
end interface
abstract interface
subroutine obj_assign_obj (obj1, obj2)
import base_pde_object
class(base_pde_object), intent(inout) :: obj1
class(base_pde_object), intent(in) :: obj2
end subroutine obj_assign_obj
end interface
contains
! print --
! Print the concentration field
subroutine print (obj)
class(base_pde_object) :: obj
! Dummy
end subroutine print
! initialise --
! Initialise the concentration field using a specific function
subroutine initialise (obj, funcxy)
class(base_pde_object) :: obj
interface
real function funcxy (coords)
real, dimension(, intent(in) :: coords
end function funcxy
end interface
! Dummy
end subroutine initialise
! nabla2 --
! Determine the divergence
function nabla2 (obj)
class(base_pde_object), intent(in) :: obj
class(base_pde_object), allocatable :: nabla2
! Dummy
end function nabla2
end module base_pde_objects
! cartesian_2d_objects --
! PDE object on a 2D cartesian grid
!
module cartesian_2d_objects
use base_pde_objects
implicit none
type, extends(base_pde_object) :: cartesian_2d_object
real, dimension(:,, allocatable :: c
real :: dx
real :: dy
contains
procedure :: process => process_cart2d
procedure :: source => source_cart2d
procedure :: initialise => initialise_cart2d
procedure :: nabla2 => nabla2_cart2d
procedure :: print => print_cart2d
procedure, pass(obj) :: real_times_obj => real_times_cart2d
procedure :: obj_plus_obj => obj_plus_cart2d
procedure :: obj_assign_obj => obj_assign_cart2d
end type cartesian_2d_object
interface grid_definition
module procedure grid_definition_cart2d
end interface
contains
function process_cart2d (obj)
class(cartesian_2d_object), intent(in) :: obj
class(base_pde_object), allocatable :: process_cart2d
allocate (process_cart2d,source = obj)
select type (process_cart2d)
type is (cartesian_2d_object)
process_cart2d%c = -sign (obj%c, 1.0)*obj%c** 4
class default
call abort
end select
end function process_cart2d
function process_cart2d_p (obj)
class(base_pde_object), intent(in) :: obj
class(base_pde_object), allocatable :: process_cart2d_p
allocate (process_cart2d_p,source = obj)
select type (process_cart2d_p)
type is (cartesian_2d_object)
select type (obj)
type is (cartesian_2d_object)
process_cart2d_p%c = -sign (obj%c, 1.0)*obj%c** 4
end select
class default
call abort
end select
end function process_cart2d_p
function source_cart2d (obj, time)
class(cartesian_2d_object), intent(in) :: obj
real, intent(in) :: time
class(base_pde_object), allocatable :: source_cart2d
integer :: m, n
m = size (obj%c, 1)
n = size (obj%c, 2)
allocate (source_cart2d, source = obj)
select type (source_cart2d)
type is (cartesian_2d_object)
if (allocated (source_cart2d%c)) deallocate (source_cart2d%c)
allocate (source_cart2d%c(m, n))
source_cart2d%c = 0.0
if (time .lt. 5.0) source_cart2d%c(m/2, n/2) = 0.1
class default
call abort
end select
end function source_cart2d

function source_cart2d_p (obj, time)
class(base_pde_object), intent(in) :: obj
real, intent(in) :: time
class(base_pde_object), allocatable :: source_cart2d_p
integer :: m, n
select type (obj)
type is (cartesian_2d_object)
m = size (obj%c, 1)
n = size (obj%c, 2)
class default
call abort
end select
allocate (source_cart2d_p,source = obj)
select type (source_cart2d_p)
type is (cartesian_2d_object)
if (allocated (source_cart2d_p%c)) deallocate (source_cart2d_p%c)
allocate (source_cart2d_p%c(m,n))
source_cart2d_p%c = 0.0
if (time .lt. 5.0) source_cart2d_p%c(m/2, n/2) = 0.1
class default
call abort
end select
end function source_cart2d_p

! grid_definition --
! Initialises the grid
!
subroutine grid_definition_cart2d (obj, sizes, dims)
class(base_pde_object), allocatable :: obj
real, dimension( :: sizes
integer, dimension( :: dims
allocate( cartesian_2d_object :: obj )
select type (obj)
type is (cartesian_2d_object)
allocate (obj%c(dims(1), dims(2)))
obj%c = 0.0
obj%dx = sizes(1)/dims(1)
obj%dy = sizes(2)/dims(2)
class default
call abort
end select
end subroutine grid_definition_cart2d
! print_cart2d --
! Print the concentration field to the screen
!
subroutine print_cart2d (obj)
class(cartesian_2d_object) :: obj
character(len=20) :: format
write( format, '(a,i0,a)' ) '(', size(obj%c,1), 'f6.3)'
write( *, format ) obj%c
end subroutine print_cart2d
! initialise_cart2d --
! Initialise the concentration field using a specific function
!
subroutine initialise_cart2d (obj, funcxy)
class(cartesian_2d_object) :: obj
interface
real function funcxy (coords)
real, dimension(, intent(in) :: coords
end function funcxy
end interface
integer :: i, j
real, dimension(2) :: x
obj%c = 0.0
do j = 2,size (obj%c, 2)-1
x(2) = obj%dy * (j-1)
do i = 2,size (obj%c, 1)-1
x(1) = obj%dx * (i-1)
obj%c(i,j) = funcxy (x)
enddo
enddo
end subroutine initialise_cart2d
! nabla2_cart2d
! Determine the divergence
function nabla2_cart2d (obj)
class(cartesian_2d_object), intent(in) :: obj
class(base_pde_object), allocatable :: nabla2_cart2d
integer :: m, n
real :: dx, dy
m = size (obj%c, 1)
n = size (obj%c, 2)
dx = obj%dx
dy = obj%dy
allocate (cartesian_2d_object :: nabla2_cart2d)
select type (nabla2_cart2d)
type is (cartesian_2d_object)
allocate (nabla2_cart2d%c(m,n))
nabla2_cart2d%c = 0.0
nabla2_cart2d%c(2:m-1,2:n-1) = &
-(2.0 * obj%c(2:m-1,2:n-1) - obj%c(1:m-2,2:n-1) -
obj%c(3:m,2:n-1)) / dx**2 &
-(2.0 * obj%c(2:m-1,2:n-1) - obj%c(2:m-1,1:n-2) -
obj%c(2:m-1,3:n)) / dy**2
class default
call abort
end select
end function nabla2_cart2d
function real_times_cart2d (factor, obj) result(newobj)
real, intent(in) :: factor
class(cartesian_2d_object), intent(in) :: obj
class(base_pde_object), allocatable :: newobj
integer :: m, n
m = size (obj%c, 1)
n = size (obj%c, 2)
allocate (cartesian_2d_object :: newobj)
select type (newobj)
type is (cartesian_2d_object)
allocate (newobj%c(m,n))
newobj%c = factor * obj%c
class default
call abort
end select
end function real_times_cart2d
function obj_plus_cart2d (obj1, obj2) result( newobj )
class(cartesian_2d_object), intent(in) :: obj1
class(base_pde_object), intent(in) :: obj2
class(base_pde_object), allocatable :: newobj
integer :: m, n
m = size (obj1%c, 1)
n = size (obj1%c, 2)
allocate (cartesian_2d_object :: newobj)
select type (newobj)
type is (cartesian_2d_object)
allocate (newobj%c(m,n))
select type (obj2)
type is (cartesian_2d_object)
newobj%c = obj1%c + obj2%c
class default
call abort
end select
class default
call abort
end select
end function obj_plus_cart2d
subroutine obj_assign_cart2d (obj1, obj2)
class(cartesian_2d_object), intent(inout) :: obj1
class(base_pde_object), intent(in) :: obj2
select type (obj2)
type is (cartesian_2d_object)
obj1%c = obj2%c
class default
call abort
end select
end subroutine obj_assign_cart2d
end module cartesian_2d_objects
! define_pde_objects --
! Module to bring all the PDE object types together
!
module define_pde_objects
use base_pde_objects
use cartesian_2d_objects
implicit none
interface grid_definition
module procedure grid_definition_general
end interface
contains
subroutine grid_definition_general (obj, type, sizes, dims)
class(base_pde_object), allocatable :: obj
character(len=*) :: type
real, dimension( :: sizes
integer, dimension( :: dims
select case (type)
case ("cartesian 2d")
call grid_definition (obj, sizes, dims)
case default
write(*,*) 'Unknown grid type: ', trim (type)
stop
end select
end subroutine grid_definition_general
end module define_pde_objects
! pde_specific --
! Module holding the routines specific to the PDE that
! we are solving
!
module pde_specific
implicit none
contains
real function patch (coords)
real, dimension(, intent(in) :: coords
if (sum ((coords-[50.0,50.0])**2) < 40.0) then
patch = 1.0
else
patch = 0.0
endif
end function patch
end module pde_specific
! test_pde_solver --
! Small test program to demonstrate the usage
!
program test_pde_solver
use define_pde_objects
use pde_specific
implicit none
class(base_pde_object), allocatable :: solution, deriv
integer :: i
real :: time, dtime, diff, chksum(2)

call simulation1 ! Use proc pointers for source and process
define_pde_objects
select type (solution)
type is (cartesian_2d_object)
deallocate (solution%c)
end select
select type (deriv)
type is (cartesian_2d_object)
deallocate (deriv%c)
end select
deallocate (solution, deriv)

call simulation2 ! Use typebound procedures for source and process
if (chksum(1) .ne. chksum(2)) call abort
if ((chksum(1) - 0.881868720)**2 > 1e-4) call abort
contains
subroutine simulation1
!
! Create the grid
!
call grid_definition (solution, "cartesian 2d", [100.0, 100.0],
[16, 16])
call grid_definition (deriv, "cartesian 2d", [100.0, 100.0],
[16, 16])
!
! Initialise the concentration field
!
call solution%initialise (patch)
!
! Set the procedure pointers
!
solution%source_p => source_cart2d_p
solution%process_p => process_cart2d_p
!
! Perform the integration - explicit method
!
time = 0.0
dtime = 0.1
diff = 5.0e-3

! Give the diffusion coefficient correct dimensions.
select type (solution)
type is (cartesian_2d_object)
diff = diff * solution%dx * solution%dy / dtime
end select

! write(*,*) 'Time: ', time, diff
! call solution%print
do i = 1,100
deriv = solution%nabla2 ()
solution = solution + diff * dtime * deriv + solution%source_p
(time) + solution%process_p ()
! if ( mod(i, 25) == 0 ) then
! write(*,*)'Time: ', time
! call solution%print
! endif
time = time + dtime
enddo
! write(*,*) 'End result 1: '
! call solution%print
select type (solution)
type is (cartesian_2d_object)
chksum(1) = sum (solution%c)
end select
end subroutine
subroutine simulation2
!
! Create the grid
!
call grid_definition (solution, "cartesian 2d", [100.0, 100.0],
[16, 16])
call grid_definition (deriv, "cartesian 2d", [100.0, 100.0],
[16, 16])
!
! Initialise the concentration field
!
call solution%initialise (patch)
!
! Set the procedure pointers
!
solution%source_p => source_cart2d_p
solution%process_p => process_cart2d_p
!
! Perform the integration - explicit method
!
time = 0.0
dtime = 0.1
diff = 5.0e-3

! Give the diffusion coefficient correct dimensions.
select type (solution)
type is (cartesian_2d_object)
diff = diff * solution%dx * solution%dy / dtime
end select

! write(*,*) 'Time: ', time, diff
! call solution%print
do i = 1,100
deriv = solution%nabla2 ()
solution = solution + diff * dtime * deriv + solution%source
(time) + solution%process ()
! if ( mod(i, 25) == 0 ) then
! write(*,*)'Time: ', time
! call solution%print
! endif
time = time + dtime
enddo
! write(*,*) 'End result 2: '
! call solution%print
select type (solution)
type is (cartesian_2d_object)
chksum(2) = sum (solution%c)
end select
end subroutine
end program test_pde_solver
! { dg-final { cleanup-modules "pde_specific define_pde_objects
cartesian_2d_objects base_pde_objects" } }

Arjen Markus wrote:
> Op maandag 19 maart 2012 15:08:02 UTC+1 schreef Tom Micevski het volgende:
>> Walt Brainerd wrote:
>>> I have a nice coarray example (heat xfer on a plate)
>>> that runs on four images. Works on Intel and Cray.
>>
>> Walt, where is this coarray example? I can't seem to find it in the
>> TGZ, nor by searching the www site. I'm interested because I'm starting
>> to play with coarrays to see if it'll be suitable for parallelising a
>> program of ours (and the more coarray examples I can find, the better).
>>
>> Thanks, Tom
>
> I have two coarray examples for you.

Thanks Arjen and Walt.

My email is: tom.micevski /at\ newcastle.edu.au

Tom

Hi Paul,

indeed I do .

Regards,

Arjen

On 2012-03-19 20:56, Paul Thomas wrote:
>
>> I have a whole bunch of sample programs, many of which use F2003
>> features,
>> though not all. I can send to you.
>>
>> Regards,
>>
>> Arjen
>
> In that case then, Arjen, you might recognise the code below! The ! { dg
> ...... } things are testsuite directives.
>
> Cheers
>
> Paul
>
> [pault@localhost ~]# cat
> /svn/trunk/gcc/testsuite/gfortran.dg/typebound_operator_9.f03
> ! { dg-do run }
> ! { dg-add-options ieee }
> ! { dg-skip-if "Too big for local store" { spu-*-* } { "*" } { "" } }
> !
> ! Solve a diffusion problem using an object-oriented approach
> !
> ! Author: Arjen Markus (comp.lang.fortran)
> ! This version: pault@gcc.gnu.org
> !
> ! Note:
> ! (i) This could be turned into a more sophisticated program
> ! using the techniques described in the chapter on
> ! mathematical abstractions.
> ! (That would allow the selection of the time integration
> ! method in a transparent way)
> !
> ! (ii) The target procedures for process_p and source_p are
> ! different to the typebound procedures for dynamic types
> ! because the passed argument is not type(base_pde_object).
> !
> ! (iii) Two solutions are calculated, one with the procedure
> ! pointers and the other with typebound procedures. The sums
> ! of the solutions are compared.
>
> ! (iv) The source is a delta function in the middle of the
> ! mesh, whilst the process is quartic in the local value,
> ! when it is positive.
> !
> ! base_pde_objects --
> ! Module to define the basic objects
> !
> module base_pde_objects
> implicit none
> type, abstract :: base_pde_object
> ! No data
> procedure(process_p), pointer, pass :: process_p
> procedure(source_p), pointer, pass :: source_p
> contains
> procedure(process), deferred :: process
> procedure(source), deferred :: source
> procedure :: initialise
> procedure :: nabla2
> procedure :: print
> procedure(real_times_obj), pass(obj), deferred :: real_times_obj
> procedure(obj_plus_obj), deferred :: obj_plus_obj
> procedure(obj_assign_obj), deferred :: obj_assign_obj
> generic :: operator(*) => real_times_obj
> generic :: operator(+) => obj_plus_obj
> generic :: assignment(=) => obj_assign_obj
> end type
> abstract interface
> function process_p (obj)
> import base_pde_object
> class(base_pde_object), intent(in) :: obj
> class(base_pde_object), allocatable :: process_p
> end function process_p
> end interface
> abstract interface
> function source_p (obj, time)
> import base_pde_object
> class(base_pde_object), intent(in) :: obj
> real, intent(in) :: time
> class(base_pde_object), allocatable :: source_p
> end function source_p
> end interface
> abstract interface
> function process (obj)
> import base_pde_object
> class(base_pde_object), intent(in) :: obj
> class(base_pde_object), allocatable :: process
> end function process
> end interface
> abstract interface
> function source (obj, time)
> import base_pde_object
> class(base_pde_object), intent(in) :: obj
> real, intent(in) :: time
> class(base_pde_object), allocatable :: source
> end function source
> end interface
> abstract interface
> function real_times_obj (factor, obj) result(newobj)
> import base_pde_object
> real, intent(in) :: factor
> class(base_pde_object), intent(in) :: obj
> class(base_pde_object), allocatable :: newobj
> end function real_times_obj
> end interface
> abstract interface
> function obj_plus_obj (obj1, obj2) result(newobj)
> import base_pde_object
> class(base_pde_object), intent(in) :: obj1
> class(base_pde_object), intent(in) :: obj2
> class(base_pde_object), allocatable :: newobj
> end function obj_plus_obj
> end interface
> abstract interface
> subroutine obj_assign_obj (obj1, obj2)
> import base_pde_object
> class(base_pde_object), intent(inout) :: obj1
> class(base_pde_object), intent(in) :: obj2
> end subroutine obj_assign_obj
> end interface
> contains
> ! print --
> ! Print the concentration field
> subroutine print (obj)
> class(base_pde_object) :: obj
> ! Dummy
> end subroutine print
> ! initialise --
> ! Initialise the concentration field using a specific function
> subroutine initialise (obj, funcxy)
> class(base_pde_object) :: obj
> interface
> real function funcxy (coords)
> real, dimension(, intent(in) :: coords
> end function funcxy
> end interface
> ! Dummy
> end subroutine initialise
> ! nabla2 --
> ! Determine the divergence
> function nabla2 (obj)
> class(base_pde_object), intent(in) :: obj
> class(base_pde_object), allocatable :: nabla2
> ! Dummy
> end function nabla2
> end module base_pde_objects
> ! cartesian_2d_objects --
> ! PDE object on a 2D cartesian grid
> !
> module cartesian_2d_objects
> use base_pde_objects
> implicit none
> type, extends(base_pde_object) :: cartesian_2d_object
> real, dimension(:,, allocatable :: c
> real :: dx
> real :: dy
> contains
> procedure :: process => process_cart2d
> procedure :: source => source_cart2d
> procedure :: initialise => initialise_cart2d
> procedure :: nabla2 => nabla2_cart2d
> procedure :: print => print_cart2d
> procedure, pass(obj) :: real_times_obj => real_times_cart2d
> procedure :: obj_plus_obj => obj_plus_cart2d
> procedure :: obj_assign_obj => obj_assign_cart2d
> end type cartesian_2d_object
> interface grid_definition
> module procedure grid_definition_cart2d
> end interface
> contains
> function process_cart2d (obj)
> class(cartesian_2d_object), intent(in) :: obj
> class(base_pde_object), allocatable :: process_cart2d
> allocate (process_cart2d,source = obj)
> select type (process_cart2d)
> type is (cartesian_2d_object)
> process_cart2d%c = -sign (obj%c, 1.0)*obj%c** 4
> class default
> call abort
> end select
> end function process_cart2d
> function process_cart2d_p (obj)
> class(base_pde_object), intent(in) :: obj
> class(base_pde_object), allocatable :: process_cart2d_p
> allocate (process_cart2d_p,source = obj)
> select type (process_cart2d_p)
> type is (cartesian_2d_object)
> select type (obj)
> type is (cartesian_2d_object)
> process_cart2d_p%c = -sign (obj%c, 1.0)*obj%c** 4
> end select
> class default
> call abort
> end select
> end function process_cart2d_p
> function source_cart2d (obj, time)
> class(cartesian_2d_object), intent(in) :: obj
> real, intent(in) :: time
> class(base_pde_object), allocatable :: source_cart2d
> integer :: m, n
> m = size (obj%c, 1)
> n = size (obj%c, 2)
> allocate (source_cart2d, source = obj)
> select type (source_cart2d)
> type is (cartesian_2d_object)
> if (allocated (source_cart2d%c)) deallocate (source_cart2d%c)
> allocate (source_cart2d%c(m, n))
> source_cart2d%c = 0.0
> if (time .lt. 5.0) source_cart2d%c(m/2, n/2) = 0.1
> class default
> call abort
> end select
> end function source_cart2d
>
> function source_cart2d_p (obj, time)
> class(base_pde_object), intent(in) :: obj
> real, intent(in) :: time
> class(base_pde_object), allocatable :: source_cart2d_p
> integer :: m, n
> select type (obj)
> type is (cartesian_2d_object)
> m = size (obj%c, 1)
> n = size (obj%c, 2)
> class default
> call abort
> end select
> allocate (source_cart2d_p,source = obj)
> select type (source_cart2d_p)
> type is (cartesian_2d_object)
> if (allocated (source_cart2d_p%c)) deallocate (source_cart2d_p%c)
> allocate (source_cart2d_p%c(m,n))
> source_cart2d_p%c = 0.0
> if (time .lt. 5.0) source_cart2d_p%c(m/2, n/2) = 0.1
> class default
> call abort
> end select
> end function source_cart2d_p
>
> ! grid_definition --
> ! Initialises the grid
> !
> subroutine grid_definition_cart2d (obj, sizes, dims)
> class(base_pde_object), allocatable :: obj
> real, dimension( :: sizes
> integer, dimension( :: dims
> allocate( cartesian_2d_object :: obj )
> select type (obj)
> type is (cartesian_2d_object)
> allocate (obj%c(dims(1), dims(2)))
> obj%c = 0.0
> obj%dx = sizes(1)/dims(1)
> obj%dy = sizes(2)/dims(2)
> class default
> call abort
> end select
> end subroutine grid_definition_cart2d
> ! print_cart2d --
> ! Print the concentration field to the screen
> !
> subroutine print_cart2d (obj)
> class(cartesian_2d_object) :: obj
> character(len=20) :: format
> write( format, '(a,i0,a)' ) '(', size(obj%c,1), 'f6.3)'
> write( *, format ) obj%c
> end subroutine print_cart2d
> ! initialise_cart2d --
> ! Initialise the concentration field using a specific function
> !
> subroutine initialise_cart2d (obj, funcxy)
> class(cartesian_2d_object) :: obj
> interface
> real function funcxy (coords)
> real, dimension(, intent(in) :: coords
> end function funcxy
> end interface
> integer :: i, j
> real, dimension(2) :: x
> obj%c = 0.0
> do j = 2,size (obj%c, 2)-1
> x(2) = obj%dy * (j-1)
> do i = 2,size (obj%c, 1)-1
> x(1) = obj%dx * (i-1)
> obj%c(i,j) = funcxy (x)
> enddo
> enddo
> end subroutine initialise_cart2d
> ! nabla2_cart2d
> ! Determine the divergence
> function nabla2_cart2d (obj)
> class(cartesian_2d_object), intent(in) :: obj
> class(base_pde_object), allocatable :: nabla2_cart2d
> integer :: m, n
> real :: dx, dy
> m = size (obj%c, 1)
> n = size (obj%c, 2)
> dx = obj%dx
> dy = obj%dy
> allocate (cartesian_2d_object :: nabla2_cart2d)
> select type (nabla2_cart2d)
> type is (cartesian_2d_object)
> allocate (nabla2_cart2d%c(m,n))
> nabla2_cart2d%c = 0.0
> nabla2_cart2d%c(2:m-1,2:n-1) = &
> -(2.0 * obj%c(2:m-1,2:n-1) - obj%c(1:m-2,2:n-1) -
> obj%c(3:m,2:n-1)) / dx**2 &
> -(2.0 * obj%c(2:m-1,2:n-1) - obj%c(2:m-1,1:n-2) -
> obj%c(2:m-1,3:n)) / dy**2
> class default
> call abort
> end select
> end function nabla2_cart2d
> function real_times_cart2d (factor, obj) result(newobj)
> real, intent(in) :: factor
> class(cartesian_2d_object), intent(in) :: obj
> class(base_pde_object), allocatable :: newobj
> integer :: m, n
> m = size (obj%c, 1)
> n = size (obj%c, 2)
> allocate (cartesian_2d_object :: newobj)
> select type (newobj)
> type is (cartesian_2d_object)
> allocate (newobj%c(m,n))
> newobj%c = factor * obj%c
> class default
> call abort
> end select
> end function real_times_cart2d
> function obj_plus_cart2d (obj1, obj2) result( newobj )
> class(cartesian_2d_object), intent(in) :: obj1
> class(base_pde_object), intent(in) :: obj2
> class(base_pde_object), allocatable :: newobj
> integer :: m, n
> m = size (obj1%c, 1)
> n = size (obj1%c, 2)
> allocate (cartesian_2d_object :: newobj)
> select type (newobj)
> type is (cartesian_2d_object)
> allocate (newobj%c(m,n))
> select type (obj2)
> type is (cartesian_2d_object)
> newobj%c = obj1%c + obj2%c
> class default
> call abort
> end select
> class default
> call abort
> end select
> end function obj_plus_cart2d
> subroutine obj_assign_cart2d (obj1, obj2)
> class(cartesian_2d_object), intent(inout) :: obj1
> class(base_pde_object), intent(in) :: obj2
> select type (obj2)
> type is (cartesian_2d_object)
> obj1%c = obj2%c
> class default
> call abort
> end select
> end subroutine obj_assign_cart2d
> end module cartesian_2d_objects
> ! define_pde_objects --
> ! Module to bring all the PDE object types together
> !
> module define_pde_objects
> use base_pde_objects
> use cartesian_2d_objects
> implicit none
> interface grid_definition
> module procedure grid_definition_general
> end interface
> contains
> subroutine grid_definition_general (obj, type, sizes, dims)
> class(base_pde_object), allocatable :: obj
> character(len=*) :: type
> real, dimension( :: sizes
> integer, dimension( :: dims
> select case (type)
> case ("cartesian 2d")
> call grid_definition (obj, sizes, dims)
> case default
> write(*,*) 'Unknown grid type: ', trim (type)
> stop
> end select
> end subroutine grid_definition_general
> end module define_pde_objects
> ! pde_specific --
> ! Module holding the routines specific to the PDE that
> ! we are solving
> !
> module pde_specific
> implicit none
> contains
> real function patch (coords)
> real, dimension(, intent(in) :: coords
> if (sum ((coords-[50.0,50.0])**2) < 40.0) then
> patch = 1.0
> else
> patch = 0.0
> endif
> end function patch
> end module pde_specific
> ! test_pde_solver --
> ! Small test program to demonstrate the usage
> !
> program test_pde_solver
> use define_pde_objects
> use pde_specific
> implicit none
> class(base_pde_object), allocatable :: solution, deriv
> integer :: i
> real :: time, dtime, diff, chksum(2)
>
> call simulation1 ! Use proc pointers for source and process
> define_pde_objects
> select type (solution)
> type is (cartesian_2d_object)
> deallocate (solution%c)
> end select
> select type (deriv)
> type is (cartesian_2d_object)
> deallocate (deriv%c)
> end select
> deallocate (solution, deriv)
>
> call simulation2 ! Use typebound procedures for source and process
> if (chksum(1) .ne. chksum(2)) call abort
> if ((chksum(1) - 0.881868720)**2 > 1e-4) call abort
> contains
> subroutine simulation1
> !
> ! Create the grid
> !
> call grid_definition (solution, "cartesian 2d", [100.0, 100.0], [16,
> 16])
> call grid_definition (deriv, "cartesian 2d", [100.0, 100.0], [16,
> 16])
> !
> ! Initialise the concentration field
> !
> call solution%initialise (patch)
> !
> ! Set the procedure pointers
> !
> solution%source_p => source_cart2d_p
> solution%process_p => process_cart2d_p
> !
> ! Perform the integration - explicit method
> !
> time = 0.0
> dtime = 0.1
> diff = 5.0e-3
>
> ! Give the diffusion coefficient correct dimensions.
> select type (solution)
> type is (cartesian_2d_object)
> diff = diff * solution%dx * solution%dy / dtime
> end select
>
> ! write(*,*) 'Time: ', time, diff
> ! call solution%print
> do i = 1,100
> deriv = solution%nabla2 ()
> solution = solution + diff * dtime * deriv + solution%source_p
> (time) + solution%process_p ()
> ! if ( mod(i, 25) == 0 ) then
> ! write(*,*)'Time: ', time
> ! call solution%print
> ! endif
> time = time + dtime
> enddo
> ! write(*,*) 'End result 1: '
> ! call solution%print
> select type (solution)
> type is (cartesian_2d_object)
> chksum(1) = sum (solution%c)
> end select
> end subroutine
> subroutine simulation2
> !
> ! Create the grid
> !
> call grid_definition (solution, "cartesian 2d", [100.0, 100.0], [16,
> 16])
> call grid_definition (deriv, "cartesian 2d", [100.0, 100.0], [16,
> 16])
> !
> ! Initialise the concentration field
> !
> call solution%initialise (patch)
> !
> ! Set the procedure pointers
> !
> solution%source_p => source_cart2d_p
> solution%process_p => process_cart2d_p
> !
> ! Perform the integration - explicit method
> !
> time = 0.0
> dtime = 0.1
> diff = 5.0e-3
>
> ! Give the diffusion coefficient correct dimensions.
> select type (solution)
> type is (cartesian_2d_object)
> diff = diff * solution%dx * solution%dy / dtime
> end select
>
> ! write(*,*) 'Time: ', time, diff
> ! call solution%print
> do i = 1,100
> deriv = solution%nabla2 ()
> solution = solution + diff * dtime * deriv + solution%source
> (time) + solution%process ()
> ! if ( mod(i, 25) == 0 ) then
> ! write(*,*)'Time: ', time
> ! call solution%print
> ! endif
> time = time + dtime
> enddo
> ! write(*,*) 'End result 2: '
> ! call solution%print
> select type (solution)
> type is (cartesian_2d_object)
> chksum(2) = sum (solution%c)
> end select
> end subroutine
> end program test_pde_solver
> ! { dg-final { cleanup-modules "pde_specific define_pde_objects
> cartesian_2d_objects base_pde_objects" } }
>
>
>

On 17.03.12 22:14, glen herrmannsfeldt wrote:
> Rafik Zurob<nospam@hotmail.com> wrote:
>
> (snip)
>> Since print has intent(in) in one type and no specified intent
>> (same as intent(inout)) in the other, the program does not conform
>> to the above rules.
>
> Having no INTENT is similar to, but not the same as, INTENT(INOUT).
>
> -- glen

Sorry for the digression, but: really? What's the difference? I'm surprised.

Paul

Paul Anton Letnes <paul.anton.letnes@nospam.gmail.kthxbai.com> wrote:

> On 17.03.12 22:14, glen herrmannsfeldt wrote:

> > Having no INTENT is similar to, but not the same as, INTENT(INOUT).

> Sorry for the digression, but: really? What's the difference? I'm surprised.

There are quite a few differences, actually. Having no INTENT is...
quirky, mostly because of compatibilty requirements with pre-f90 codes.

One of the major differences is that the actual argument for an
INTENT(INOUT) dummy is required to be definable. That's regardless of
whether anything in the subroutine actually ever tries to define the
dummy or not. Just having INTENT(INOUT) (or INTENT(OUT)) is sufficient
to trigger the requirement. Though not strictlt required by the
standard, you can reasonably expect compilers to diagnose the error of
having a non-definable actual argument for an intent(INOUT) dummy if
there is an explicit interface. The simplest and most common case of a
non-definable actual argument is a literal constant.

That, of course, is not at all the case for having no intent. After all,
all pre-f90 arguments had no intent, and literal constant actual
arguments were common. It was also reasonably common error to use a
literal constant actual argument and then illegally define the dummy.
That is illegal, (but also is often not diagnosed at compile time).

For an argument without intent, the rule is that the actual argument has
to be definable if the code actually defines the dummy. I might note
that this is a run-time rule (ok, not on those words) in that it applies
only if a particular execution of the subroutine does such definition of
the dummy. There could be code in the subroutine that potentially does a
redefinition, as long as that cpde was not executed for the particular
call. Yes, there were cases where the same argument was sometimes used
for input and sometimes used fo routput, depending on the value of some
other argument. That wasn't as rare as you might think; I've run into it
several times.

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

In article <jkf6qq$geg$1@dont-email.me>,
Paul Anton Letnes <paul.anton.letnes@nospam.gmail.kthxbai.com>
wrote:

> On 17.03.12 22:14, glen herrmannsfeldt wrote:
> > Rafik Zurob<nospam@hotmail.com> wrote:
> >
> > (snip)
> >> Since print has intent(in) in one type and no specified intent
> >> (same as intent(inout)) in the other, the program does not conform
> >> to the above rules.
> >
> > Having no INTENT is similar to, but not the same as, INTENT(INOUT).
> >
> > -- glen
>
> Sorry for the digression, but: really? What's the difference? I'm surprised.

This discussion is about object oriented features of the language,
and I'm not familiar enough with those to answer the question in
that context.

But in F90, the difference is that you can, for example, pass a
constant actual argument to a dummy argument with no intent, but if
you pass a constant actual argument to an INTENT(INOUT) dummy, the
compiler will flag that as an error. In the former case, the
programmer must ensure that the argument is not modified, and the
compiler cannot know when a violation might occur (e.g. when the
caller and callee are compiled separately). In the latter case, the
INTENT declaration says that the input value is needed and that the
value will be changed. Either or both of those things don't
necessarily have to happen of course, but that is what the INTENT
says. So in this case the compiler knows (at compile time) that it
is an error to associate a constant with that dummy argument. These
same INTENT mismatches can be caught with, for example INTENT(IN)
actual arguments that are associated with INTENT(INOUT) dummy
arguments, and so on. I think now there is a PROTECTED attribute
for module variables that can be used to achieve this same kind of
thing.

If you think about it, you realize that it is a really good thing to
be able to declare INTENT like that. It catches a lot of errors
early in the code writing process that would not be noticed
otherwise, particularly when the different parts of the code are
written by different people.

$.02 -Ron Shepard

Richard Maine <nospam@see.signature> schrieb:

> For an argument without intent, the rule is that the actual argument has
> to be definable if the code actually defines the dummy.

Depending on the implementation, this could lead to funny results.

For example, using Fortran on MVS, you could do

program main
call bar(3)
print *,3
end

subroutine bar(i)
i = 42
end

and it would print 42.

This was sometimes known as "variation of constants" or "variation of
parameters", and was a way to introduce hard-to-find bugs in your
programs.