DISPATCH
aux_mod.f90
1 !===============================================================================
2 !> Module with which one can register any number of pointers to real or integer
3 !> arrays, and then output the contents of the links later
4 !>
5 !> USE aux_mod
6 !> real, pointer:: a1(10), a2(11,12), a3(13,14,15)
7 !> ...
8 !> call aux%register ('a1', a1)
9 !> call aux%register ('a2', a2)
10 !> call aux%register ('a3', a3)
11 !> ...
12 !> call aux%output ('test.aux')
13 !===============================================================================
14 MODULE aux_mod
15  USE io_mod
16  USE io_unit_mod
17  USE trace_mod
18  USE dll_mod
19  implicit none
20  private
21  !
22  integer, save:: max_select=30
23  type, public, extends(dll_t):: aux_t
24  integer:: unit=-1
25  contains
26  procedure:: prepare
27  procedure:: new_item
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
34  procedure:: test
35  end type
36  !
37  type, extends(dll_node_t):: item_t
38  class(*), pointer:: c1(:)=>null(), c2(:,:)=>null(), c3(:,:,:)=>null(), &
39  c4(:,:,:,:)=>null()
40  real, pointer:: r1(:)=>null(), r2(:,:)=>null(), r3(:,:,:)=>null(), &
41  r4(:,:,:,:)=>null()
42  character(len=32):: name
43  integer:: rank
44  contains
45  procedure:: output => output_item
46  end type
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(:)
50  !type(aux_t), public:: aux
51 CONTAINS
52 
53 !===============================================================================
54 FUNCTION new_item (self, name)
55  class(aux_t) :: self
56  character(len=*) :: name
57  logical :: new_item
58  class(dll_node_t), pointer:: item
59  !-----------------------------------------------------------------------------
60  new_item = .true.
61  item => self%head
62  do while (associated(item))
63  select type (item)
64  class is (item_t)
65  if (trim(item%name) == trim(name)) then
66  new_item = .false.
67  return
68  end if
69  end select
70  item => item%next
71  end do
72  if (verbose > 2) &
73  write (stdout,*) 'new aux item: ', trim(name)
74 END FUNCTION
75 
76 !===============================================================================
77 SUBROUTINE register1r (self, name, r)
78  class(aux_t) :: self
79  character(len=*) :: name
80  real , pointer :: r(:)
81  class(*), pointer :: c(:)
82  c => r
83  call register1 (self, name, c)
84 END SUBROUTINE
85 !===============================================================================
86 SUBROUTINE register2r (self, name, r)
87  class(aux_t) :: self
88  character(len=*) :: name
89  real , pointer :: r(:,:)
90  class(*), pointer :: c(:,:)
91  c => r
92  call register2 (self, name, c)
93 END SUBROUTINE
94 !===============================================================================
95 SUBROUTINE register3r (self, name, r)
96  class(aux_t) :: self
97  character(len=*) :: name
98  real , pointer :: r(:,:,:)
99  class(dll_node_t), pointer:: item
100  !-----------------------------------------------------------------------------
101  call trace%begin ('aux_t%register3')
102  if (self%new_item (name)) then
103  allocate (item_t:: item)
104  select type (item)
105  class is (item_t)
106  item%rank = 3
107  item%name = name
108  item%r3 => r
109  end select
110  call self%append (item)
111  if (verbose > 2) &
112  write (stdout,*) self%n, ' items registered'
113  end if
114  call trace%end()
115 END SUBROUTINE register3r
116 
117 !===============================================================================
118 SUBROUTINE register4r (self, name, r)
119  class(aux_t) :: self
120  character(len=*) :: name
121  real , pointer :: r(:,:,:,:)
122  class(dll_node_t), pointer:: item
123  !-----------------------------------------------------------------------------
124  call trace%begin ('aux_t%register4')
125  if (self%new_item (name)) then
126  allocate (item_t:: item)
127  select type (item)
128  class is (item_t)
129  item%rank = 4
130  item%name = name
131  item%r4 => r
132  end select
133  call self%append (item)
134  if (verbose > 2) &
135  write (stdout,*) self%n, ' items registered'
136  end if
137  call trace%end()
138 END SUBROUTINE
139 
140 !===============================================================================
141 SUBROUTINE register1 (self, name, c)
142  class(aux_t) :: self
143  character(len=*) :: name
144  class(*), pointer :: c(:)
145  class(dll_node_t), pointer:: item
146  !-----------------------------------------------------------------------------
147  if (self%new_item (name)) then
148  allocate (item_t:: item)
149  select type (item)
150  class is (item_t)
151  item%rank = 1
152  item%name = name
153  item%c1 => c
154  end select
155  call self%append (item)
156  end if
157 END SUBROUTINE register1
158 
159 !===============================================================================
160 SUBROUTINE register2 (self, name, c)
161  class(aux_t) :: self
162  character(len=*) :: name
163  class(*), pointer :: c(:,:)
164  class(dll_node_t), pointer:: item
165  !-----------------------------------------------------------------------------
166  if (self%new_item (name)) then
167  allocate (item_t:: item)
168  select type (item)
169  class is (item_t)
170  item%rank = 2
171  item%name = name
172  item%c2 => c
173  end select
174  call self%append (item)
175  end if
176 END SUBROUTINE register2
177 
178 !===============================================================================
179 SUBROUTINE output_aux (self, iout, id, singlefile)
180  class(aux_t):: self
181  integer:: iout, id
182  character(len=*), optional:: singlefile
183  !.............................................................................
184  character(len=64):: filename
185  class(dll_node_t), pointer:: item
186  logical:: ok
187  integer:: i
188  !-----------------------------------------------------------------------------
189  ! Make sure only one output runs at a time, so there is no interference of
190  ! reading stdin and deciding of to write messages only once
191  !-----------------------------------------------------------------------------
192  if (.not. do_aux) &
193  return
194  call trace%begin ('aux_t%output')
195  !$omp critical (aux_cr)
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')
201  else
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')
205  end if
206  if (verbose > 2) &
207  write (io_unit%log,*) filename
208  write (self%unit) version, id
209  item => self%head
210  do while (associated(item))
211  select type (item)
212  class is (item_t)
213  ok = .false.
214  do i=1,max_select
215  if (trim(select(i)) == trim(item%name)) then
216  ok = .true.
217  exit
218  end if
219  end do
220  if (ok) 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)
225  end if
226  end select
227  item => item%next
228  end do
229  iout_prv = iout
230  close (self%unit)
231  do_aux=on
232  !$omp end critical (aux_cr)
233  call trace%end()
234 END SUBROUTINE output_aux
235 
236 !===============================================================================
237 SUBROUTINE prepare (self, iout)
238  class(aux_t):: self
239  integer:: iout
240  !.............................................................................
241  namelist /aux_params/ on, select, verbose
242  integer:: iostat, i
243  !-----------------------------------------------------------------------------
244  call trace%begin ('aux_t%open')
245  if (self%unit < 0) then
246  !---------------------------------------------------------------------------
247  ! The first time we acquire a unique unit number, and allocate select
248  !---------------------------------------------------------------------------
249  uniq = uniq+1
250  self%unit = uniq
251  if (.not.allocated(select)) then
252  allocate (select(max_select))
253  select(:) = ''
254  rewind(stdin)
255  read (stdin, aux_params, iostat=iostat)
256  write (stdout,'(a,/1x,a,l2,",",/1x,a,i2,",",/,1x,a,$)') '&AUX_PARAMS', &
257  'ON=', on, &
258  'VERBOSE=', verbose, &
259  'SELECT='
260  do i=1,max_select
261  if (trim(select(i)) /= '') then
262  if (i > 1) &
263  write (stdout,'(a,$)') ', '
264  write (stdout,'(a,$)') "'"//trim(select(i))//"'"
265  end if
266  end do
267  write (stdout,'(/,a)') '/'
268  end if
269  else
270  !---------------------------------------------------------------------------
271  ! Only do this once per new snapshot
272  !---------------------------------------------------------------------------
273  if (iout > iout_prv) then
274  rewind(stdin)
275  read (stdin, aux_params, iostat=iostat)
276  end if
277  end if
278  call trace%end()
279 END SUBROUTINE prepare
280 
281 !===============================================================================
282 SUBROUTINE output_item (self, unit)
283  class(item_t):: self
284  integer:: unit, rank
285  !-----------------------------------------------------------------------------
286  call trace%begin ('item_t%output_item')
287  write (unit) self%name ! write: name
288  write (unit) self%rank ! write: rank
289  rank = self%rank
290  select case (rank)
291  case(1)
292  call write1 (self%r1)
293  case(2)
294  call write2 (self%r2)
295  case(3)
296  if (associated (self%r3)) then
297  if (verbose > 1) then
298  write (stdout,*) trim(self%name), ' shape:', shape(self%r3)
299  flush (stdout)
300  end if
301  call write3 (unit, self%r3) ! write: value
302  else
303  write (stderr,*) 'self%r3 pointer not associated for ', trim(self%name)
304  end if
305  case(4)
306  if (associated (self%r4)) then
307  if (verbose > 1) then
308  write (stdout,*) trim(self%name), ' shape:', shape(self%r4)
309  flush (stdout)
310  end if
311  call write4 (unit, self%r4)
312  else
313  write (stderr,*) 'self%r4 pointer not associated for ', trim(self%name)
314  end if
315  end select
316  flush (unit)
317  call trace%end()
318 !===============================================================================
319 contains
320 subroutine write1 (c)
321  real, pointer:: c(:)
322  write (unit) shape(c)
323  write (unit) 'r1'
324  write (unit) c
325 end subroutine write1
326 subroutine write2 (c)
327  real, pointer:: c(:,:)
328  write (unit) shape(c)
329  write (unit) 'r2'
330  write (unit) c
331 end subroutine write2
332 END SUBROUTINE
333 
334 !===============================================================================
335 subroutine write3 (unit, r)
336  integer:: unit
337  real, pointer:: r(:,:,:)
338  !-----------------------------------------------------------------------------
339  call trace%begin ('write3')
340  write (unit) shape(r)
341  if (verbose > 2) write (stdout,*) 'r3', shape(r)
342  write (unit) 'r3'
343  write (unit) r
344  call trace%end()
345 end subroutine write3
346 
347 subroutine write4 (unit, r)
348  integer:: unit
349  real, pointer:: r(:,:,:,:)
350  call trace%begin ('write4')
351  write (unit) shape(r)
352  if (verbose > 2) write (stdout,*) 'r4', shape(r)
353  write (unit) 'r4'
354  write (unit) r
355  call trace%end()
356 end subroutine write4
357 
358 !===============================================================================
359 SUBROUTINE test (self)
360  class(aux_t):: self
361  class(item_t), pointer:: item
362  real, pointer:: r1(:), r2(:,:), r3(:,:,:)
363  type(aux_t):: aux
364  !-----------------------------------------------------------------------------
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')
370 END SUBROUTINE
371 
372 END MODULE aux_mod
Doubly linked list (DLL), carrying anything, as simply as possible.
Definition: dll_mod.f90:4
Definition: io_mod.f90:4
Module with which one can register any number of pointers to real or integer arrays, and then output the contents of the links later.
Definition: aux_mod.f90:14