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	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