tools/OAD_support/OAD_tape.F90

module OAD_tape

  implicit none

  private :: increment , dtt, itt, ltt, stt

  public :: &
       oad_dt, oad_dt_ptr, oad_dt_sz, oad_dt_grow, &
       oad_it, oad_it_ptr, oad_it_sz, oad_it_grow, &
       oad_lt, oad_lt_ptr, oad_lt_sz, oad_lt_grow, &
       oad_st, oad_st_ptr, oad_st_sz, oad_st_grow, &
       oad_tape_init, &
       oad_dump_tapestats
       
  double precision, dimension(:), allocatable :: oad_dt, dtt
  integer, dimension(:), allocatable :: oad_it, itt
  logical, dimension(:), allocatable :: oad_lt, ltt
  character(80), dimension(:), allocatable :: oad_st, stt
  integer :: oad_dt_ptr=0, oad_it_ptr=0
  integer :: oad_dt_sz=0, oad_it_sz=0
  integer :: oad_lt_ptr=0, oad_st_ptr=0
  integer :: oad_lt_sz=0, oad_st_sz=0
  integer :: increment

  interface oad_tape_init
    module procedure init
  end interface 

  interface oad_dump_tapestats
     module procedure dump_tapestats
  end interface

  interface oad_dt_grow
    module procedure dt_grow
  end interface

  interface oad_it_grow
    module procedure it_grow
  end interface

  interface oad_lt_grow
    module procedure lt_grow
  end interface

  interface oad_st_grow
    module procedure st_grow
  end interface

contains

  subroutine init
    integer :: initialSize=1048576
    increment=16777216
    ! DT
    oad_dt_ptr=1
    if (allocated(oad_dt)) then 
       deallocate(oad_dt)
    end if
    oad_dt_sz=initialSize
    allocate(oad_dt(oad_dt_sz))
    ! IT
    oad_it_ptr=1
    if (allocated(oad_it)) then 
       deallocate(oad_it)
    end if
    oad_it_sz=initialSize
    allocate(oad_it(oad_it_sz))
    ! LT
    oad_lt_ptr=1
    if (allocated(oad_lt)) then 
       deallocate(oad_lt)
    end if
    oad_lt_sz=initialSize
    allocate(oad_lt(oad_lt_sz))
    ! ST
    oad_st_ptr=1
    if (allocated(oad_st)) then 
       deallocate(oad_st)
    end if
    oad_st_sz=initialSize
    allocate(oad_st(oad_st_sz))
  end subroutine init

  subroutine dump_tapestats()
    write(*,'(3(A,I9))',ADVANCE='NO') & 
         ' TD:',oad_dt_ptr,' TI:',oad_it_ptr, ' TS:',oad_st_ptr
  end subroutine dump_tapestats

  subroutine dt_grow
    integer status
    print *, "OAD: DT+ ", oad_dt_sz
    allocate(dtt(oad_dt_sz),STAT=status)
    if (status .gt. 0 ) then
       print *,'OAD: allocation (1)failed with', status
       stop
    end if
    dtt=oad_dt
    deallocate(oad_dt)
    allocate(oad_dt(oad_dt_sz+increment),STAT=status)
    if (status .gt. 0 ) then
       print *,'OAD: allocation (2)failed with', status
       stop
    end if
    oad_dt(1:oad_dt_sz) = dtt
    deallocate(dtt)
    oad_dt_sz=oad_dt_sz+increment
  end subroutine dt_grow

  subroutine it_grow
    integer status
    print *, "OAD: IT+ ", oad_it_sz
    allocate(itt(oad_it_sz),STAT=status)
    if (status .gt. 0 ) then
       print *,'OAD: allocation (1)failed with', status
       stop
    end if
    itt=oad_it
    deallocate(oad_it)
    allocate(oad_it(oad_it_sz+increment),STAT=status)
    if (status .gt. 0 ) then
       print *,'OAD: allocation (2)failed with', status
       stop
    end if
    oad_it(1:oad_it_sz) = itt
    deallocate(itt)
    oad_it_sz=oad_it_sz+increment
  end subroutine it_grow

  subroutine lt_grow
    integer status
    print *, "OAD: LT+ ", oad_lt_sz
    allocate(ltt(oad_lt_sz),STAT=status)
    if (status .gt. 0 ) then
       print *,'OAD: allocation (1)failed wlth', status
       stop
    end if
    ltt=oad_lt
    deallocate(oad_lt)
    allocate(oad_lt(oad_lt_sz+increment),STAT=status)
    if (status .gt. 0 ) then
       print *,'OAD: allocation (2)failed wlth', status
       stop
    end if
    oad_lt(1:oad_lt_sz) = ltt
    deallocate(ltt)
    oad_lt_sz=oad_lt_sz+increment
  end subroutine lt_grow

  subroutine st_grow
    integer status
    print *, "OAD: ST+ ", oad_st_sz
    allocate(stt(oad_st_sz),STAT=status)
    if (status .gt. 0 ) then
       print *,'OAD: allocation (1)failed wsth', status
       stop
    end if
    stt=oad_st
    deallocate(oad_st)
    allocate(oad_st(oad_st_sz+increment),STAT=status)
    if (status .gt. 0 ) then
       print *,'OAD: allocation (2)failed wsth', status
       stop
    end if
    oad_st(1:oad_st_sz) = stt
    deallocate(stt)
    oad_st_sz=oad_st_sz+increment
  end subroutine st_grow

end module
1	heimbach	1.1	module OAD_tape
2
3			implicit none
4
5			private :: increment , dtt, itt, ltt, stt
6
7			public :: &
8			oad_dt, oad_dt_ptr, oad_dt_sz, oad_dt_grow, &
9			oad_it, oad_it_ptr, oad_it_sz, oad_it_grow, &
10			oad_lt, oad_lt_ptr, oad_lt_sz, oad_lt_grow, &
11			oad_st, oad_st_ptr, oad_st_sz, oad_st_grow, &
12			oad_tape_init, &
13			oad_dump_tapestats
14
15			double precision, dimension(:), allocatable :: oad_dt, dtt
16			integer, dimension(:), allocatable :: oad_it, itt
17			logical, dimension(:), allocatable :: oad_lt, ltt
18			character(80), dimension(:), allocatable :: oad_st, stt
19			integer :: oad_dt_ptr=0, oad_it_ptr=0
20			integer :: oad_dt_sz=0, oad_it_sz=0
21			integer :: oad_lt_ptr=0, oad_st_ptr=0
22			integer :: oad_lt_sz=0, oad_st_sz=0
23			integer :: increment
24
25			interface oad_tape_init
26			module procedure init
27			end interface
28
29			interface oad_dump_tapestats
30			module procedure dump_tapestats
31			end interface
32
33			interface oad_dt_grow
34			module procedure dt_grow
35			end interface
36
37			interface oad_it_grow
38			module procedure it_grow
39			end interface
40
41			interface oad_lt_grow
42			module procedure lt_grow
43			end interface
44
45			interface oad_st_grow
46			module procedure st_grow
47			end interface
48
49			contains
50
51			subroutine init
52			integer :: initialSize=1048576
53			increment=16777216
54			! DT
55			oad_dt_ptr=1
56			if (allocated(oad_dt)) then
57			deallocate(oad_dt)
58			end if
59			oad_dt_sz=initialSize
60			allocate(oad_dt(oad_dt_sz))
61			! IT
62			oad_it_ptr=1
63			if (allocated(oad_it)) then
64			deallocate(oad_it)
65			end if
66			oad_it_sz=initialSize
67			allocate(oad_it(oad_it_sz))
68			! LT
69			oad_lt_ptr=1
70			if (allocated(oad_lt)) then
71			deallocate(oad_lt)
72			end if
73			oad_lt_sz=initialSize
74			allocate(oad_lt(oad_lt_sz))
75			! ST
76			oad_st_ptr=1
77			if (allocated(oad_st)) then
78			deallocate(oad_st)
79			end if
80			oad_st_sz=initialSize
81			allocate(oad_st(oad_st_sz))
82			end subroutine init
83
84			subroutine dump_tapestats()
85			write(*,'(3(A,I9))',ADVANCE='NO') &
86			' TD:',oad_dt_ptr,' TI:',oad_it_ptr, ' TS:',oad_st_ptr
87			end subroutine dump_tapestats
88
89			subroutine dt_grow
90			integer status
91			print *, "OAD: DT+ ", oad_dt_sz
92			allocate(dtt(oad_dt_sz),STAT=status)
93			if (status .gt. 0 ) then
94			print *,'OAD: allocation (1)failed with', status
95			stop
96			end if
97			dtt=oad_dt
98			deallocate(oad_dt)
99			allocate(oad_dt(oad_dt_sz+increment),STAT=status)
100			if (status .gt. 0 ) then
101			print *,'OAD: allocation (2)failed with', status
102			stop
103			end if
104			oad_dt(1:oad_dt_sz) = dtt
105			deallocate(dtt)
106			oad_dt_sz=oad_dt_sz+increment
107			end subroutine dt_grow
108
109			subroutine it_grow
110			integer status
111			print *, "OAD: IT+ ", oad_it_sz
112			allocate(itt(oad_it_sz),STAT=status)
113			if (status .gt. 0 ) then
114			print *,'OAD: allocation (1)failed with', status
115			stop
116			end if
117			itt=oad_it
118			deallocate(oad_it)
119			allocate(oad_it(oad_it_sz+increment),STAT=status)
120			if (status .gt. 0 ) then
121			print *,'OAD: allocation (2)failed with', status
122			stop
123			end if
124			oad_it(1:oad_it_sz) = itt
125			deallocate(itt)
126			oad_it_sz=oad_it_sz+increment
127			end subroutine it_grow
128
129			subroutine lt_grow
130			integer status
131			print *, "OAD: LT+ ", oad_lt_sz
132			allocate(ltt(oad_lt_sz),STAT=status)
133			if (status .gt. 0 ) then
134			print *,'OAD: allocation (1)failed wlth', status
135			stop
136			end if
137			ltt=oad_lt
138			deallocate(oad_lt)
139			allocate(oad_lt(oad_lt_sz+increment),STAT=status)
140			if (status .gt. 0 ) then
141			print *,'OAD: allocation (2)failed wlth', status
142			stop
143			end if
144			oad_lt(1:oad_lt_sz) = ltt
145			deallocate(ltt)
146			oad_lt_sz=oad_lt_sz+increment
147			end subroutine lt_grow
148
149			subroutine st_grow
150			integer status
151			print *, "OAD: ST+ ", oad_st_sz
152			allocate(stt(oad_st_sz),STAT=status)
153			if (status .gt. 0 ) then
154			print *,'OAD: allocation (1)failed wsth', status
155			stop
156			end if
157			stt=oad_st
158			deallocate(oad_st)
159			allocate(oad_st(oad_st_sz+increment),STAT=status)
160			if (status .gt. 0 ) then
161			print *,'OAD: allocation (2)failed wsth', status
162			stop
163			end if
164			oad_st(1:oad_st_sz) = stt
165			deallocate(stt)
166			oad_st_sz=oad_st_sz+increment
167			end subroutine st_grow
168
169			end module