22 integer,
save:: max_select=30
28 procedure,
private:: register1r
29 procedure,
private:: register2r
30 procedure,
private:: register3r
31 procedure,
private:: register4r
32 generic:: register => register1r, register2r, register3r, register4r
33 procedure:: output => output_aux
38 class(*),
pointer:: c1(:)=>null(), c2(:,:)=>null(), c3(:,:,:)=>null(), &
40 real,
pointer:: r1(:)=>null(), r2(:,:)=>null(), r3(:,:,:)=>null(), &
42 character(len=32):: name
45 procedure:: output => output_item
47 integer:: version=1, verbose=0, uniq=200, iout_prv=-1
48 logical:: first_time=.true., second_time=.true., on=.false., do_aux=.true.
49 character(len=32),
allocatable:: select(:)
54 FUNCTION new_item (self, name)
56 character(len=*) :: name
62 do while (
associated(item))
65 if (trim(item%name) == trim(name))
then 73 write (stdout,*)
'new aux item: ', trim(name)
77 SUBROUTINE register1r (self, name, r)
79 character(len=*) :: name
80 real ,
pointer :: r(:)
81 class(*),
pointer :: c(:)
83 call register1 (self, name, c)
86 SUBROUTINE register2r (self, name, r)
88 character(len=*) :: name
89 real ,
pointer :: r(:,:)
90 class(*),
pointer :: c(:,:)
92 call register2 (self, name, c)
95 SUBROUTINE register3r (self, name, r)
97 character(len=*) :: name
98 real ,
pointer :: r(:,:,:)
101 call trace%begin (
'aux_t%register3')
102 if (self%new_item (name))
then 103 allocate (item_t:: item)
110 call self%append (item)
112 write (stdout,*) self%n,
' items registered' 115 END SUBROUTINE register3r
118 SUBROUTINE register4r (self, name, r)
120 character(len=*) :: name
121 real ,
pointer :: r(:,:,:,:)
124 call trace%begin (
'aux_t%register4')
125 if (self%new_item (name))
then 126 allocate (item_t:: item)
133 call self%append (item)
135 write (stdout,*) self%n,
' items registered' 141 SUBROUTINE register1 (self, name, c)
143 character(len=*) :: name
144 class(*),
pointer :: c(:)
147 if (self%new_item (name))
then 148 allocate (item_t:: item)
155 call self%append (item)
157 END SUBROUTINE register1
160 SUBROUTINE register2 (self, name, c)
162 character(len=*) :: name
163 class(*),
pointer :: c(:,:)
166 if (self%new_item (name))
then 167 allocate (item_t:: item)
174 call self%append (item)
176 END SUBROUTINE register2
179 SUBROUTINE output_aux (self, iout, id, singlefile)
182 character(len=*),
optional:: singlefile
184 character(len=64):: filename
194 call trace%begin (
'aux_t%output')
196 call self%prepare (iout)
197 if (
present(singlefile))
then 198 filename = singlefile
199 open (self%unit, file=trim(singlefile), form=
'unformatted', &
200 access=
'sequential', status=
'unknown')
202 write (filename,
'(a,i5.5"/",i5.5,".aux")') trim(io%outputname), iout, id
203 open (self%unit, file=trim(filename), form=
'unformatted', &
204 access=
'sequential', status=
'unknown')
207 write (io_unit%log,*) filename
208 write (self%unit) version, id
210 do while (
associated(item))
215 if (trim(
select(i)) == trim(item%name))
then 221 if (verbose > 0 .or. iout > iout_prv) &
222 write (stdout,
'(a,i5,2x,a)')
'aux_t%output: snapshot =', &
223 iout, trim(item%name)
224 call item%output (self%unit)
234 END SUBROUTINE output_aux
237 SUBROUTINE prepare (self, iout)
241 namelist /aux_params/ on,
select, verbose
244 call trace%begin (
'aux_t%open')
245 if (self%unit < 0)
then 251 if (.not.
allocated(select))
then 252 allocate (
select(max_select))
255 read (stdin, aux_params, iostat=iostat)
256 write (stdout,
'(a,/1x,a,l2,",",/1x,a,i2,",",/,1x,a,$)')
'&AUX_PARAMS', &
258 'VERBOSE=', verbose, &
261 if (trim(
select(i)) /=
'')
then 263 write (stdout,
'(a,$)')
', ' 264 write (stdout,
'(a,$)')
"'"//trim(
select(i))//
"'" 267 write (stdout,
'(/,a)')
'/' 273 if (iout > iout_prv)
then 275 read (stdin, aux_params, iostat=iostat)
279 END SUBROUTINE prepare
282 SUBROUTINE output_item (self, unit)
286 call trace%begin (
'item_t%output_item')
287 write (unit) self%name
288 write (unit) self%rank
292 call write1 (self%r1)
294 call write2 (self%r2)
296 if (
associated (self%r3))
then 297 if (verbose > 1)
then 298 write (stdout,*) trim(self%name),
' shape:', shape(self%r3)
301 call write3 (unit, self%r3)
303 write (stderr,*)
'self%r3 pointer not associated for ', trim(self%name)
306 if (
associated (self%r4))
then 307 if (verbose > 1)
then 308 write (stdout,*) trim(self%name),
' shape:', shape(self%r4)
311 call write4 (unit, self%r4)
313 write (stderr,*)
'self%r4 pointer not associated for ', trim(self%name)
320 subroutine write1 (c)
322 write (unit) shape(c)
325 end subroutine write1
326 subroutine write2 (c)
327 real,
pointer:: c(:,:)
328 write (unit) shape(c)
331 end subroutine write2
335 subroutine write3 (unit, r)
337 real,
pointer:: r(:,:,:)
339 call trace%begin (
'write3')
340 write (unit) shape(r)
341 if (verbose > 2)
write (stdout,*)
'r3', shape(r)
345 end subroutine write3
347 subroutine write4 (unit, r)
349 real,
pointer:: r(:,:,:,:)
350 call trace%begin (
'write4')
351 write (unit) shape(r)
352 if (verbose > 2)
write (stdout,*)
'r4', shape(r)
356 end subroutine write4
359 SUBROUTINE test (self)
361 class(item_t),
pointer:: item
362 real,
pointer:: r1(:), r2(:,:), r3(:,:,:)
365 allocate (
real:: r1(10), r2(2,3), r3(3,4,5))
366 call aux%register (
'r1', r1)
367 call aux%register (
'r2', r2)
368 call aux%register (
'r3', r3)
369 call aux%output (3, 1,
'test.aux')
Doubly linked list (DLL), carrying anything, as simply as possible.
Module with which one can register any number of pointers to real or integer arrays, and then output the contents of the links later.