1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
|
! { 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
|