3 ! This test is based on the second case in the PGInsider article at
4 ! https://www.pgroup.com/lit/articles/insider/v6n2a3.htm
6 ! The complete original code is at:
7 ! https://www.pgroup.com/lit/samples/pginsider/stack.f90
9 ! Thanks to Mark LeAir.
11 ! Copyright (c) 2015, NVIDIA CORPORATION. All rights reserved.
13 ! NVIDIA CORPORATION and its licensors retain all intellectual property
14 ! and proprietary rights in and to this software, related documentation
15 ! and any modifications thereto. Any use, reproduction, disclosure or
16 ! distribution of this software and related documentation without an express
17 ! license agreement from NVIDIA CORPORATION is strictly prohibited.
20 ! THIS CODE AND INFORMATION ARE PROVIDED "AS IS" WITHOUT
21 ! WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT
22 ! NOT LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR
23 ! FITNESS FOR A PARTICULAR PURPOSE.
28 type, abstract
:: stack
30 class(*), allocatable
:: item
! an item on the stack
31 class(stack
), pointer :: next
=>null() ! next item on the stack
33 procedure
:: empty
! returns true if stack is empty
34 procedure
:: delete ! empties the stack
37 type, extends(stack
) :: integer_stack
39 procedure
:: push
=> push_integer
! add integer item to stack
40 procedure
:: pop
=> pop_integer
! remove integer item from stack
41 procedure
:: compare
=> compare_integer
! compare with an integer array
42 end type integer_stack
44 type, extends(integer_stack
) :: io_stack
46 procedure
,private
:: wio_stack
47 procedure
,private
:: rio_stack
48 procedure
,private
:: dump_stack
49 generic
:: write(unformatted
) => wio_stack
! write stack item to file
50 generic
:: read(unformatted
) => rio_stack
! push item from file
51 generic
:: write(formatted
) => dump_stack
! print all items from stack
56 subroutine rio_stack (dtv
, unit
, iostat
, iomsg
)
58 ! read item from file and add it to stack
60 class(io_stack
), intent(inout
) :: dtv
61 integer, intent(in
) :: unit
62 integer, intent(out
) :: iostat
63 character(len
=*), intent(inout
) :: iomsg
67 read(unit
,IOSTAT
=iostat
,IOMSG
=iomsg
) item
69 if (iostat
.ne
. 0) then
73 end subroutine rio_stack
75 subroutine wio_stack(dtv
, unit
, iostat
, iomsg
)
77 ! pop an item from stack and write it to file
79 class(io_stack
), intent(in
) :: dtv
80 integer, intent(in
) :: unit
81 integer, intent(out
) :: iostat
82 character(len
=*), intent(inout
) :: iomsg
86 write(unit
,IOSTAT
=iostat
,IOMSG
=iomsg
) item
88 end subroutine wio_stack
90 subroutine dump_stack(dtv
, unit
, iotype
, v_list
, iostat
, iomsg
)
92 ! Pop all items off stack and write them out to unit
93 ! Assumes default LISTDIRECTED output
95 class(io_stack
), intent(in
) :: dtv
96 integer, intent(in
) :: unit
97 character(len
=*), intent(in
) :: iotype
98 integer, intent(in
) :: v_list(:)
99 integer, intent(out
) :: iostat
100 character(len
=*), intent(inout
) :: iomsg
101 character(len
=80) :: buffer
104 if (iotype
.ne
. 'LISTDIRECTED') then
106 iomsg
= 'dump_stack: unsupported iotype'
110 do while( (.not
. dtv
%empty()) .and
. (iostat
.eq
. 0) )
112 write(unit
, '(I6/)',IOSTAT
=iostat
,IOMSG
=iomsg
) item
115 end subroutine dump_stack
117 logical function empty(this
)
119 if (.not
.associated(this
%next
)) then
126 subroutine push_integer(this
,item
)
127 class(integer_stack
) :: this
129 type(integer_stack
), allocatable
:: new_item
132 allocate(new_item
%item
, source
=item
)
133 new_item
%next
=> this
%next
134 allocate(this
%next
, source
=new_item
)
135 end subroutine push_integer
137 function pop_integer(this
) result(item
)
138 class(integer_stack
) :: this
139 class(stack
), pointer :: dealloc_item
142 if (this
%empty()) then
143 stop 'Error! pop_integer invoked on empty stack'
145 select
type(top
=>this
%next
)
146 type is (integer_stack
)
147 select
type(i
=> top
%item
)
151 stop 'Error #1! pop_integer encountered non-integer stack item'
153 dealloc_item
=> this
%next
154 this
%next
=> top
%next
155 deallocate(dealloc_item
)
157 stop 'Error #2! pop_integer encountered non-integer_stack item'
159 end function pop_integer
161 ! gfortran addition to check read/write
162 logical function compare_integer (this
, array
, error
)
163 class(integer_stack
), target
:: this
164 class(stack
), pointer :: ptr
, next
165 integer :: array(:), i
, j
, error
166 compare_integer
= .true
.
168 do j
= 0, size (array
, 1)
169 if (compare_integer
.eqv
. .false
.) return
171 type is (integer_stack
)
172 select
type(k
=> ptr
%item
)
174 if (k
.ne
. array(j
)) error
= 1
177 compare_integer
= .false
.
182 compare_integer
= .false
.
186 if (associated (next
)) then
188 else if (j
.ne
. size (array
, 1)) then
190 compare_integer
= .false
.
195 subroutine delete (this
)
196 class(stack
), target
:: this
197 class(stack
), pointer :: ptr1
, ptr2
200 do while (associated (ptr1
))
203 if (associated (ptr1
)) ptr2
=> ptr1
%next
214 integer i
, k(10), error
215 class(io_stack
), allocatable
:: stk
218 k
= [3,1,7,0,2,9,4,8,5,6]
220 ! step 1: set up an 'output' file > changed to 'scratch'
222 open(10, status
='scratch', form
='unformatted')
224 ! step 2: add values to stack
227 ! write(*,*) 'Adding ',i,' to the stack'
231 ! step 3: pop values from stack and write them to file
234 ! write(*,*) 'Removing each item from stack and writing it to file.'
236 do while(.not
.stk
%empty())
240 ! step 4: close file and reopen it for read > changed to rewind.
244 ! step 5: read values back into stack
245 ! write(*,*) 'Reading each value from file and adding it to stack:'
248 ! write(*,*), 'Reading ',i,' from file. Adding it to stack'
254 ! step 6: Dump stack to standard out
257 ! write(*,*), 'Removing every element from stack and writing it to screen:'
260 ! gfortran addition to check read/write
261 if (.not
. stk
%compare (k
, error
)) then
264 print *, "values do not match"
266 print *, "non integer found in stack"
268 print *, "type mismatch in stack"
270 print *, "too few values in stack"
277 ! Clean up - valgrind indicates no leaks.
280 end program stack_demo