PR94725 - deleting gfortran.dg/dtio_5.f90 and pdt_5.f03
This commit is contained in:
Paul Thomas
parent
03afbf3357
commit
31e6f82933
2 changed files with 0 additions and 503 deletions
|
|
@ -1,280 +0,0 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! This test is based on the second case in the PGInsider article at
|
||||
! https://www.pgroup.com/lit/articles/insider/v6n2a3.htm
|
||||
!
|
||||
! The complete original code is at:
|
||||
! https://www.pgroup.com/lit/samples/pginsider/stack.f90
|
||||
!
|
||||
! Thanks to Mark LeAir.
|
||||
!
|
||||
! Copyright (c) 2015, NVIDIA CORPORATION. All rights reserved.
|
||||
!
|
||||
! NVIDIA CORPORATION and its licensors retain all intellectual property
|
||||
! and proprietary rights in and to this software, related documentation
|
||||
! and any modifications thereto. Any use, reproduction, disclosure or
|
||||
! distribution of this software and related documentation without an express
|
||||
! license agreement from NVIDIA CORPORATION is strictly prohibited.
|
||||
!
|
||||
|
||||
! THIS CODE AND INFORMATION ARE PROVIDED "AS IS" WITHOUT
|
||||
! WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT
|
||||
! NOT LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR
|
||||
! FITNESS FOR A PARTICULAR PURPOSE.
|
||||
!
|
||||
|
||||
module stack_mod
|
||||
|
||||
type, abstract :: stack
|
||||
private
|
||||
class(*), allocatable :: item ! an item on the stack
|
||||
class(stack), pointer :: next=>null() ! next item on the stack
|
||||
contains
|
||||
procedure :: empty ! returns true if stack is empty
|
||||
procedure :: delete ! empties the stack
|
||||
end type stack
|
||||
|
||||
type, extends(stack) :: integer_stack
|
||||
contains
|
||||
procedure :: push => push_integer ! add integer item to stack
|
||||
procedure :: pop => pop_integer ! remove integer item from stack
|
||||
procedure :: compare => compare_integer ! compare with an integer array
|
||||
end type integer_stack
|
||||
|
||||
type, extends(integer_stack) :: io_stack
|
||||
contains
|
||||
procedure,private :: wio_stack
|
||||
procedure,private :: rio_stack
|
||||
procedure,private :: dump_stack
|
||||
generic :: write(unformatted) => wio_stack ! write stack item to file
|
||||
generic :: read(unformatted) => rio_stack ! push item from file
|
||||
generic :: write(formatted) => dump_stack ! print all items from stack
|
||||
end type io_stack
|
||||
|
||||
contains
|
||||
|
||||
subroutine rio_stack (dtv, unit, iostat, iomsg)
|
||||
|
||||
! read item from file and add it to stack
|
||||
|
||||
class(io_stack), intent(inout) :: dtv
|
||||
integer, intent(in) :: unit
|
||||
integer, intent(out) :: iostat
|
||||
character(len=*), intent(inout) :: iomsg
|
||||
|
||||
integer :: item
|
||||
|
||||
read(unit,IOSTAT=iostat,IOMSG=iomsg) item
|
||||
|
||||
if (iostat .ne. 0) then
|
||||
call dtv%push(item)
|
||||
endif
|
||||
|
||||
end subroutine rio_stack
|
||||
|
||||
subroutine wio_stack(dtv, unit, iostat, iomsg)
|
||||
|
||||
! pop an item from stack and write it to file
|
||||
|
||||
class(io_stack), intent(in) :: dtv
|
||||
integer, intent(in) :: unit
|
||||
integer, intent(out) :: iostat
|
||||
character(len=*), intent(inout) :: iomsg
|
||||
integer :: item
|
||||
|
||||
item = dtv%pop()
|
||||
write(unit,IOSTAT=iostat,IOMSG=iomsg) item
|
||||
|
||||
end subroutine wio_stack
|
||||
|
||||
subroutine dump_stack(dtv, unit, iotype, v_list, iostat, iomsg)
|
||||
|
||||
! Pop all items off stack and write them out to unit
|
||||
! Assumes default LISTDIRECTED output
|
||||
|
||||
class(io_stack), intent(in) :: dtv
|
||||
integer, intent(in) :: unit
|
||||
character(len=*), intent(in) :: iotype
|
||||
integer, intent(in) :: v_list(:)
|
||||
integer, intent(out) :: iostat
|
||||
character(len=*), intent(inout) :: iomsg
|
||||
character(len=80) :: buffer
|
||||
integer :: item
|
||||
|
||||
if (iotype .ne. 'LISTDIRECTED') then
|
||||
! Error
|
||||
iomsg = 'dump_stack: unsupported iotype'
|
||||
iostat = 1
|
||||
else
|
||||
iostat = 0
|
||||
do while( (.not. dtv%empty()) .and. (iostat .eq. 0) )
|
||||
item = dtv%pop()
|
||||
write(unit, '(I6/)',IOSTAT=iostat,IOMSG=iomsg) item
|
||||
enddo
|
||||
endif
|
||||
end subroutine dump_stack
|
||||
|
||||
logical function empty(this)
|
||||
class(stack) :: this
|
||||
if (.not.associated(this%next)) then
|
||||
empty = .true.
|
||||
else
|
||||
empty = .false.
|
||||
end if
|
||||
end function empty
|
||||
|
||||
subroutine push_integer(this,item)
|
||||
class(integer_stack) :: this
|
||||
integer :: item
|
||||
type(integer_stack), allocatable :: new_item
|
||||
|
||||
allocate(new_item)
|
||||
allocate(new_item%item, source=item)
|
||||
new_item%next => this%next
|
||||
allocate(this%next, source=new_item)
|
||||
end subroutine push_integer
|
||||
|
||||
function pop_integer(this) result(item)
|
||||
class(integer_stack) :: this
|
||||
class(stack), pointer :: dealloc_item
|
||||
integer item
|
||||
|
||||
if (this%empty()) then
|
||||
stop 'Error! pop_integer invoked on empty stack'
|
||||
endif
|
||||
select type(top=>this%next)
|
||||
type is (integer_stack)
|
||||
select type(i => top%item)
|
||||
type is(integer)
|
||||
item = i
|
||||
class default
|
||||
stop 'Error #1! pop_integer encountered non-integer stack item'
|
||||
end select
|
||||
dealloc_item => this%next
|
||||
this%next => top%next
|
||||
deallocate(dealloc_item)
|
||||
class default
|
||||
stop 'Error #2! pop_integer encountered non-integer_stack item'
|
||||
end select
|
||||
end function pop_integer
|
||||
|
||||
! gfortran addition to check read/write
|
||||
logical function compare_integer (this, array, error)
|
||||
class(integer_stack), target :: this
|
||||
class(stack), pointer :: ptr, next
|
||||
integer :: array(:), i, j, error
|
||||
compare_integer = .true.
|
||||
ptr => this
|
||||
do j = 0, size (array, 1)
|
||||
if (compare_integer .eqv. .false.) return
|
||||
select type (ptr)
|
||||
type is (integer_stack)
|
||||
select type(k => ptr%item)
|
||||
type is(integer)
|
||||
if (k .ne. array(j)) error = 1
|
||||
class default
|
||||
error = 2
|
||||
compare_integer = .false.
|
||||
end select
|
||||
class default
|
||||
if (j .ne. 0) then
|
||||
error = 3
|
||||
compare_integer = .false.
|
||||
end if
|
||||
end select
|
||||
next => ptr%next
|
||||
if (associated (next)) then
|
||||
ptr => next
|
||||
else if (j .ne. size (array, 1)) then
|
||||
error = 4
|
||||
compare_integer = .false.
|
||||
end if
|
||||
end do
|
||||
end function
|
||||
|
||||
subroutine delete (this)
|
||||
class(stack), target :: this
|
||||
class(stack), pointer :: ptr1, ptr2
|
||||
ptr1 => this%next
|
||||
ptr2 => ptr1%next
|
||||
do while (associated (ptr1))
|
||||
deallocate (ptr1)
|
||||
ptr1 => ptr2
|
||||
if (associated (ptr1)) ptr2 => ptr1%next
|
||||
end do
|
||||
end subroutine
|
||||
|
||||
end module stack_mod
|
||||
|
||||
program stack_demo
|
||||
|
||||
use stack_mod
|
||||
implicit none
|
||||
|
||||
integer i, k(10), error
|
||||
class(io_stack), allocatable :: stk
|
||||
allocate(stk)
|
||||
|
||||
k = [3,1,7,0,2,9,4,8,5,6]
|
||||
|
||||
! step 1: set up an 'output' file > changed to 'scratch'
|
||||
|
||||
open(10, status='scratch', form='unformatted')
|
||||
|
||||
! step 2: add values to stack
|
||||
|
||||
do i=1,10
|
||||
! write(*,*) 'Adding ',i,' to the stack'
|
||||
call stk%push(k(i))
|
||||
enddo
|
||||
|
||||
! step 3: pop values from stack and write them to file
|
||||
|
||||
! write(*,*)
|
||||
! write(*,*) 'Removing each item from stack and writing it to file.'
|
||||
! write(*,*)
|
||||
do while(.not.stk%empty())
|
||||
write(10) stk
|
||||
enddo
|
||||
|
||||
! step 4: close file and reopen it for read > changed to rewind.
|
||||
|
||||
rewind(10)
|
||||
|
||||
! step 5: read values back into stack
|
||||
! write(*,*) 'Reading each value from file and adding it to stack:'
|
||||
do while(.true.)
|
||||
read(10,END=9999) i
|
||||
! write(*,*), 'Reading ',i,' from file. Adding it to stack'
|
||||
call stk%push(i)
|
||||
enddo
|
||||
|
||||
9999 continue
|
||||
|
||||
! step 6: Dump stack to standard out
|
||||
|
||||
! write(*,*)
|
||||
! write(*,*), 'Removing every element from stack and writing it to screen:'
|
||||
! write(*,*) stk
|
||||
|
||||
! gfortran addition to check read/write
|
||||
if (.not. stk%compare (k, error)) then
|
||||
select case (error)
|
||||
case(1)
|
||||
print *, "values do not match"
|
||||
case(2)
|
||||
print *, "non integer found in stack"
|
||||
case(3)
|
||||
print *, "type mismatch in stack"
|
||||
case(4)
|
||||
print *, "too few values in stack"
|
||||
end select
|
||||
STOP 1
|
||||
end if
|
||||
|
||||
close(10)
|
||||
|
||||
! Clean up - valgrind indicates no leaks.
|
||||
call stk%delete
|
||||
deallocate (stk)
|
||||
end program stack_demo
|
||||
|
|
@ -1,223 +0,0 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! Third, complete example from the PGInsider article:
|
||||
! "Object-Oriented Programming in Fortran 2003 Part 3: Parameterized Derived Types"
|
||||
! by Mark Leair
|
||||
!
|
||||
! Copyright (c) 2013, NVIDIA CORPORATION. All rights reserved.
|
||||
!
|
||||
! NVIDIA CORPORATION and its licensors retain all intellectual property
|
||||
! and proprietary rights in and to this software, related documentation
|
||||
! and any modifications thereto. Any use, reproduction, disclosure or
|
||||
! distribution of this software and related documentation without an express
|
||||
! license agreement from NVIDIA CORPORATION is strictly prohibited.
|
||||
!
|
||||
|
||||
! THIS CODE AND INFORMATION ARE PROVIDED "AS IS" WITHOUT
|
||||
! WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT
|
||||
! NOT LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR
|
||||
! FITNESS FOR A PARTICULAR PURPOSE.
|
||||
!
|
||||
! Note that modification had to be made all of which are commented.
|
||||
!
|
||||
module matrix
|
||||
|
||||
type :: base_matrix(k,c,r)
|
||||
private
|
||||
integer, kind :: k = 4
|
||||
integer, len :: c = 1
|
||||
integer, len :: r = 1
|
||||
end type base_matrix
|
||||
|
||||
type, extends(base_matrix) :: adj_matrix
|
||||
private
|
||||
class(*), pointer :: m(:,:) => null()
|
||||
end type adj_matrix
|
||||
|
||||
interface getKind
|
||||
module procedure getKind4
|
||||
module procedure getKind8
|
||||
end interface getKind
|
||||
|
||||
interface getColumns
|
||||
module procedure getNumCols4
|
||||
module procedure getNumCols8
|
||||
end interface getColumns
|
||||
|
||||
interface getRows
|
||||
module procedure getNumRows4
|
||||
module procedure getNumRows8
|
||||
end interface getRows
|
||||
|
||||
interface adj_matrix
|
||||
module procedure construct_4 ! kind=4 constructor
|
||||
module procedure construct_8 ! kind=8 constructor
|
||||
end interface adj_matrix
|
||||
|
||||
interface assignment(=)
|
||||
module procedure m2m4 ! assign kind=4 matrix
|
||||
module procedure a2m4 ! assign kind=4 array
|
||||
module procedure m2m8 ! assign kind=8 matrix
|
||||
module procedure a2m8 ! assign kind=8 array
|
||||
module procedure m2a4 ! assign kind=4 matrix to array
|
||||
module procedure m2a8 ! assign kind=8 matrix to array
|
||||
end interface assignment(=)
|
||||
|
||||
|
||||
contains
|
||||
|
||||
function getKind4(this) result(rslt)
|
||||
class(adj_matrix(4,*,*)) :: this
|
||||
integer :: rslt
|
||||
rslt = this%k
|
||||
end function getKind4
|
||||
|
||||
function getKind8(this) result(rslt)
|
||||
class(adj_matrix(8,*,*)) :: this
|
||||
integer :: rslt
|
||||
rslt = this%k
|
||||
end function getKind8
|
||||
|
||||
function getNumCols4(this) result(rslt)
|
||||
class(adj_matrix(4,*,*)) :: this
|
||||
integer :: rslt
|
||||
rslt = this%c
|
||||
end function getNumCols4
|
||||
|
||||
function getNumCols8(this) result(rslt)
|
||||
class(adj_matrix(8,*,*)) :: this
|
||||
integer :: rslt
|
||||
rslt = this%c
|
||||
end function getNumCols8
|
||||
|
||||
function getNumRows4(this) result(rslt)
|
||||
class(adj_matrix(4,*,*)) :: this
|
||||
integer :: rslt
|
||||
rslt = this%r
|
||||
end function getNumRows4
|
||||
|
||||
function getNumRows8(this) result(rslt)
|
||||
class(adj_matrix(8,*,*)) :: this
|
||||
integer :: rslt
|
||||
rslt = this%r
|
||||
end function getNumRows8
|
||||
|
||||
|
||||
function construct_4(k,c,r) result(mat)
|
||||
integer(4) :: k
|
||||
integer :: c
|
||||
integer :: r
|
||||
class(adj_matrix(4,:,:)),allocatable :: mat
|
||||
|
||||
allocate(adj_matrix(4,c,r)::mat)
|
||||
|
||||
end function construct_4
|
||||
|
||||
function construct_8(k,c,r) result(mat)
|
||||
integer(8) :: k
|
||||
integer :: c
|
||||
integer :: r
|
||||
class(adj_matrix(8,:,:)),allocatable :: mat
|
||||
|
||||
allocate(adj_matrix(8,c,r)::mat)
|
||||
|
||||
end function construct_8
|
||||
|
||||
subroutine a2m4(d,s)
|
||||
class(adj_matrix(4,:,:)),allocatable :: d
|
||||
class(*),dimension(:,:) :: s
|
||||
|
||||
if (allocated(d)) deallocate(d)
|
||||
! allocate(adj_matrix(4,size(s,1),size(s,2))::d) ! generates assembler error
|
||||
allocate(d, mold = adj_matrix(4,size(s,1),size(s,2)))
|
||||
allocate(d%m(size(s,1),size(s,2)),source=s)
|
||||
end subroutine a2m4
|
||||
|
||||
subroutine a2m8(d,s)
|
||||
class(adj_matrix(8,:,:)),allocatable :: d
|
||||
class(*),dimension(:,:) :: s
|
||||
|
||||
if (allocated(d)) deallocate(d)
|
||||
! allocate(adj_matrix(8,size(s,1),size(s,2))::d) ! generates assembler error
|
||||
allocate(d, mold = adj_matrix(8_8,size(s,1),size(s,2))) ! Needs 8_8 to match arg1 of 'construct_8'
|
||||
allocate(d%m(size(s,1),size(s,2)),source=s)
|
||||
end subroutine a2m8
|
||||
|
||||
subroutine m2a8(a,this)
|
||||
class(adj_matrix(8,*,*)), intent(in) :: this ! Intents required for
|
||||
real(8),allocatable, intent(out) :: a(:,:) ! defined assignment
|
||||
select type (array => this%m) ! Added SELECT TYPE because...
|
||||
type is (real(8))
|
||||
if (allocated(a)) deallocate(a)
|
||||
allocate(a,source=array)
|
||||
end select
|
||||
! allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran
|
||||
end subroutine m2a8
|
||||
|
||||
subroutine m2a4(a,this)
|
||||
class(adj_matrix(4,*,*)), intent(in) :: this ! Intents required for
|
||||
real(4),allocatable, intent(out) :: a(:,:) ! defined assignment
|
||||
select type (array => this%m) ! Added SELECT TYPE because...
|
||||
type is (real(4))
|
||||
if (allocated(a)) deallocate(a)
|
||||
allocate(a,source=array)
|
||||
end select
|
||||
! allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran
|
||||
end subroutine m2a4
|
||||
|
||||
subroutine m2m4(d,s)
|
||||
CLASS(adj_matrix(4,:,:)),allocatable, intent(OUT) :: d ! Intents required for
|
||||
CLASS(adj_matrix(4,*,*)), intent(in) :: s ! defined assignment
|
||||
|
||||
if (allocated(d)) deallocate(d)
|
||||
allocate(d,source=s)
|
||||
end subroutine m2m4
|
||||
|
||||
subroutine m2m8(d,s)
|
||||
CLASS(adj_matrix(8,:,:)),allocatable, intent(OUT) :: d ! Intents required for
|
||||
CLASS(adj_matrix(8,*,*)), intent(in) :: s ! defined assignment
|
||||
|
||||
if (allocated(d)) deallocate(d)
|
||||
allocate(d,source=s)
|
||||
end subroutine m2m8
|
||||
|
||||
|
||||
end module matrix
|
||||
|
||||
|
||||
program adj3
|
||||
|
||||
use matrix
|
||||
implicit none
|
||||
integer(8) :: i
|
||||
|
||||
class(adj_matrix(8,:,:)),allocatable :: adj ! Was TYPE: Fails in
|
||||
real(8) :: a(2,3) ! defined assignment
|
||||
real(8),allocatable :: b(:,:)
|
||||
|
||||
class(adj_matrix(4,:,:)),allocatable :: adj_4 ! Ditto and ....
|
||||
real(4) :: a_4(3,2) ! ... these declarations were
|
||||
real(4),allocatable :: b_4(:,:) ! added to check KIND=4
|
||||
|
||||
! Check constructor of PDT and instrinsic assignment
|
||||
adj = adj_matrix(INT(8,8),2,4)
|
||||
if (adj%k .ne. 8) STOP 1
|
||||
if (adj%c .ne. 2) STOP 2
|
||||
if (adj%r .ne. 4) STOP 3
|
||||
a = reshape ([(i, i = 1, 6)], [2,3])
|
||||
adj = a
|
||||
b = adj
|
||||
if (any (b .ne. a)) STOP 4
|
||||
|
||||
! Check allocation with MOLD of PDT. Note that only KIND parameters set.
|
||||
allocate (adj_4, mold = adj_matrix(4,3,2)) ! Added check of KIND = 4
|
||||
if (adj_4%k .ne. 4) STOP 5
|
||||
a_4 = reshape (a, [3,2])
|
||||
adj_4 = a_4
|
||||
b_4 = adj_4
|
||||
if (any (b_4 .ne. a_4)) STOP 6
|
||||
|
||||
end program adj3
|
||||
|
||||
|
||||
|
||||
Loading…
Add table
Reference in a new issue