DISPATCH
legacy_io_mod.f90
1 MODULE legacy_io_mod
2  USE io_mod
3  USE trace_mod
4  USE patch_mod
5  USE kinds_mod
6  implicit none
7  private
8  type, public:: legacy_io_t
9  contains
10  procedure, nopass:: output => output
11  procedure, nopass:: input => input
12  procedure, nopass:: check_error
13  end type
14  type(legacy_io_t), public:: legacy_io
15 CONTAINS
16 
17 !===============================================================================
18 !> Write results to disk, placing the files belonging to each snapshot in a
19 !> separate directory, to avoid the slowdown sometimes associated with having
20 !> many files in the same directory.
21 !===============================================================================
22 SUBROUTINE output (self, experiment_name)
23  class(patch_t):: self
24  character(len=64) filename, logname, experiment_name
25  optional:: experiment_name
26  !.............................................................................
27  integer:: iv, li(3)=0, ui(3)=0, l(3), u(3), no, jo, it, i
28  real:: ds(3)
29  logical:: first_time=.true.
30  integer:: it1, it2, n(3)
31  real:: pt, qt
32  real(4), dimension(:,:,:), pointer:: buf
33  real(8):: time, t1, t2
34  ! integer, save:: iodir=-1
35  !-----------------------------------------------------------------------------
36  call trace%begin('legacy_io%output')
37  !$omp critical (output_cr)
38  !-----------------------------------------------------------------------------
39  ! Check number of patches written and issue a message when all done
40  !-----------------------------------------------------------------------------
41  self%max_files = self%max_files-1
42  if (self%max_files <= 0) then
43  write (io_unit%log,*) 'TOO MANY FILES'
44  stop
45  end if
46  !-----------------------------------------------------------------------------
47  ! If guard_zones is true, include the guard zones. If time_derivs is >0
48  ! write out the time derivatives also.
49  !-----------------------------------------------------------------------------
50  if (io%guard_zones) then
51  l = self%mesh%lb
52  u = self%mesh%ub
53  else
54  l = self%mesh%li
55  u = self%mesh%ui
56  end if
57  if (io%time_derivs>0) then
58  no = min(2,self%nw)
59  else
60  no = 1
61  end if
62  if (io%out_time==0.0) then
63  !$omp atomic read
64  time = self%time
65  !$omp end atomic
66  else if (io%time_derivs>0) then
67  !$omp atomic read
68  time = self%t(self%nt-2)
69  !$omp end atomic
70  else
71  !$omp atomic read
72  time = self%out_next
73  !$omp end atomic
74  end if
75  !-----------------------------------------------------------------------------
76  ! Set io%format
77  !-----------------------------------------------------------------------------
78  if (self%no_mans_land) then
79  io%format = 1
80  else
81  io%format = 2
82  end if
83  !-----------------------------------------------------------------------------
84  ! Write a binary file with the data cube.
85  !-----------------------------------------------------------------------------
86  if (self%id < 100000) then
87  write (filename,'(a,i5.5,"/",i5.5)') trim(io%outputname), self%iout, self%id
88  else if (self%id < 1000000) then
89  write (filename,'(a,i5.5,"/",i6.6)') trim(io%outputname), self%iout, self%id
90  else
91  write (filename,'(a,i5.5,"/",i7.7)') trim(io%outputname), self%iout, self%id
92  end if
93  n = u-l+1
94  open (io_unit%data, file=trim(filename)//'.dat', form='unformatted', access='direct', &
95  status='unknown', recl=kind(buf)*product(n))
96  do jo=1,no
97  do iv=1,self%nv
98  allocate (buf(n(1),n(2),n(3)))
99  !-------------------------------------------------------------------------
100  ! If we write out time derivatives we want a pair of consistent values
101  ! and time derivatives, which we have at iit(nt-2); time will select that.
102  !-------------------------------------------------------------------------
103  !$omp atomic read
104  it1 = self%iit(self%nt-2)
105  !$omp end atomic
106  !$omp atomic read
107  it2 = self%iit(self%nt-1)
108  !$omp end atomic
109  if (io%out_time == 0.0) then
110  buf = self%mem(l(1):u(1),l(2):u(2),l(3):u(3),iv,self%it,jo)
111  !-------------------------------------------------------------------------
112  ! Normally, we write out only variable values, which can then be interpolated
113  ! to the exact output time, self%out_next, the update of which must come
114  ! after this point
115  !-------------------------------------------------------------------------
116  else
117  !$omp atomic read
118  t1 = self%t(it1)
119  !$omp end atomic
120  !$omp atomic read
121  t2 = self%t(it2)
122  !$omp end atomic
123  pt = (time-t1)/max(t2-t1,1d-30)
124  if (t2==t1) pt=0.0
125  qt = 1.0-pt
126  buf = self%mem(l(1):u(1),l(2):u(2),l(3):u(3),iv,it1,jo)*qt &
127  + self%mem(l(1):u(1),l(2):u(2),l(3):u(3),iv,it2,jo)*pt
128  end if
129  call check_error(self, buf, "output 2")
130  if (io%verbose>1) &
131  write (io_unit%log,'(1x,a,2i5,i3,1p,3e11.3)') &
132  trim(filename),iv,it1,jo,minval(buf),maxval(buf),pt
133  write (io_unit%data,rec=iv+(jo-1)*self%nv) buf
134  if (io%verbose>1 .and. iv==self%idx%d) &
135  print *,'rho minmax',minval(buf), maxval(buf)
136  deallocate (buf)
137  end do
138  end do
139  close (io_unit%data)
140  !$omp end critical (output_cr)
141  call trace%end()
142 END SUBROUTINE output
143 
144 !===============================================================================
145 !> Check for y-redundancy
146 !===============================================================================
147 SUBROUTINE check_error (patch, a, label, error)
148  class(patch_t):: patch
149  character(len=*), optional:: label
150  integer, optional:: error(3)
151  integer:: loc(3), it, l(3), u(3), n(3), iy
152  real(4), dimension(:,:,:), pointer:: a, b
153  integer, save:: nerror=4
154  !-----------------------------------------------------------------------------
155  if (.not.io%do_debug) return
156  if (io%guard_zones) then
157  l = patch%mesh%lb
158  u = patch%mesh%ub
159  else
160  l = patch%mesh%li
161  u = patch%mesh%ui
162  end if
163  n = u-l+1
164  allocate (b(n(1),n(2),n(3)))
165  do iy=l(2),u(2)
166  b(:,iy,:)=a(:,iy,:)-a(:,1,:)
167  end do
168  if (any(b /= 0.0)) then
169  loc = maxloc(abs(b)) + l-1
170  if (present(label)) print*,'legacy_io::error ', label
171  print*,'legacy_io::error loc :', loc
172  print*,'legacy_io::error it,new,iit :', patch%it, patch%new, patch%iit
173  do iy=l(2),u(2)
174  print*,'legacy_io::error iy, a:', iy, a(loc(1),iy,loc(3))
175  end do
176  if (present(error)) then
177  error=loc
178  return
179  else
180  if (nerror<=0) stop
181  nerror=nerror-1
182  end if
183  else
184  if (present(label)) then
185  print*,'legacy_io::check_error maxval ', label, maxval(abs(a))
186  else
187  print*,'legacy_io::check_error maxval', maxval(abs(a))
188  end if
189  end if
190  deallocate(b)
191 END SUBROUTINE check_error
192 
193 !===============================================================================
194 !> Read snapshot from disk
195 !===============================================================================
196 SUBROUTINE input (self, ok)
197  class(patch_t):: self
198  logical:: ok
199  character(len=64) filename, line, fmt
200  integer:: iv, l(3), u(3), ioformat
201  real(8):: time
202  logical, save:: do_print=.true.
203  !-----------------------------------------------------------------------------
204  ok = .false.
205  if (self%id==io%id_debug) &
206  print *,'MK input', self%id, self%restart
207  if (self%restart < 0) return
208  call trace_begin('legacy_io_t%input')
209  !$omp critical (output_cr)
210  !---------------------------------------------------------------------------
211  ! If guard_zones is true, include the guard zones.
212  !---------------------------------------------------------------------------
213  l = merge(self%mesh%lb, self%mesh%li, io%guard_zones)
214  u = merge(self%mesh%ub, self%mesh%ui, io%guard_zones)
215  !---------------------------------------------------------------------------
216  ! Read the binary file with the data cube.
217  !---------------------------------------------------------------------------
218  if (self%id < 100000) then
219  write (filename,'(a,i5.5,"/",i5.5)') trim(io%inputdir), self%restart, self%id
220  else if (self%id < 1000000) then
221  write (filename,'(a,i5.5,"/",i6.6)') trim(io%inputdir), self%restart, self%id
222  else
223  write (filename,'(a,i5.5,"/",i7.7)') trim(io%inputdir), self%restart, self%id
224  end if
225  inquire (file=trim(filename)//'.dat', exist=ok)
226  if (.not.ok) then
227  call io%abort('MK input_legacy: no .dat file'//trim(filename)//'.dat')
228  end if
229  if (ok) then
230  open (io_unit%data, file=trim(filename)//'.dat', form='unformatted', &
231  access='direct', status='unknown', recl=kind(self%mem)*product(u-l+1))
232  do iv=1,self%nv
233  read (io_unit%data,rec=iv) self%mem(l(1):u(1),l(2):u(2),l(3):u(3),iv,self%it,1)
234  end do
235  if (io%master .and. io%verbose>0 .or. self%track) &
236  print*, 'legacy_io%input_legacy: ', trim(filename), time
237  close (io_unit%data)
238  if (self%id==io%id_debug) &
239  print *,'MK input_legacy', self%id, ok, self%mem(18,18,36,1,self%it,1)
240  !---------------------------------------------------------------------------
241  ! Update the iout and out_next for continued experiment
242  !---------------------------------------------------------------------------
243  self%out_next = (int(self%time/io%out_time)+1)*io%out_time
244  end if
245  !$omp end critical (output_cr)
246  call trace_end
247 END SUBROUTINE input
248 
249 END MODULE legacy_io_mod
Template module for patches, which adds pointers to memory and mesh, and number of dimensions and var...
Definition: patch_mod.f90:6
Definition: io_mod.f90:4