+++ /dev/null
-! { 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
+++ /dev/null
-! { 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
-
-
-
projects / gcc.git / commitdiff