3 USE stel_kinds,
ONLY: dp
6 INTEGER :: rec_length, data_size, block_size, num_rows
7 INTEGER :: iunit_da=0, blocks_per_row, recs_per_block
8 INTEGER :: irec_pos, byte_size_rec, byte_size_dp
9 CHARACTER(LEN=256) :: filename
13 SUBROUTINE opendafile(datasize, blksize, blocksperrow, &
14 & filename_in, iunit, iflag)
15 INTEGER,
INTENT(in) :: datasize, blksize, blocksperrow, &
17 INTEGER,
INTENT(inout) :: iunit
18 CHARACTER*(*),
INTENT(in) :: filename_in
19 INTEGER,
PARAMETER :: CreateNew=0, openexisting=1, scratch=2
22 CHARACTER(LEN=10) :: Status
27 INQUIRE(iolength=byte_size_rec) dummy
28 byte_size_dp = kind(dummy)
31 rec_length = byte_size_rec*datasize
32 block_size = byte_size_dp*blksize
33 blocks_per_row = blocksperrow
34 filename = filename_in
36 recs_per_block = max(1,blksize/datasize)
41 IF (iflag .eq. createnew)
THEN
43 ELSE IF (iflag .eq. openexisting)
THEN
50 CALL safe_open(iunit, ierr, filename, status,
'unformatted', &
51 & rec_length,
'DIRECT')
56 WRITE (6,
'(a7,i4)')
'Status code: ', status,
' Error stat: ', ierr
57 stop
'Error creating Direct Access file!'
60 END SUBROUTINE opendafile
63 SUBROUTINE changedafileparams(datasize, blksize, &
64 & blocksperrow, new_filename, nrows)
65 INTEGER,
INTENT(in) :: datasize, blksize, blocksperrow, nrows
66 INTEGER :: ierr, new_data_size, new_block_size, new_rec_length, &
67 & new_blocks_per_row, new_recs_per_block, inew_da
68 INTEGER :: i, j, k, boffset, recloc, nsplit, isplit, new_row_offset
69 CHARACTER*(*) :: new_filename
70 REAL(dp),
ALLOCATABLE :: DataItem(:)
74 new_data_size = datasize
75 new_rec_length = byte_size_rec*datasize
76 new_block_size = byte_size_dp*blksize
77 new_blocks_per_row = blocksperrow
79 new_recs_per_block = max(1,blksize/datasize)
82 IF ((rec_length.eq.new_rec_length) .and.
83 & (block_size.eq.new_block_size))
RETURN
87 ierr = index(filename,
'.',back=.true.)
89 filename = new_filename
91 CALL safe_open(inew_da, ierr, filename,
'replace',
'unformatted',
92 & new_rec_length,
'DIRECT')
93 IF (ierr .ne. 0) stop
'Error opening existing Direct Access file!'
95 ALLOCATE (dataitem(new_data_size), stat=ierr)
96 IF (ierr .ne. 0) stop
'Allocation error in ChangeDAFileParams'
99 IF (irec_pos .eq. 0)
THEN
101 DO j = 1, blocks_per_row
103 DO k = 1, recs_per_block
104 CALL readdaitem1(dataitem(boffset), i, j, k)
105 boffset = boffset + recs_per_block
108 recloc = 1 + new_recs_per_block*((j-1) + new_blocks_per_row
109 WRITE (inew_da, rec=recloc, iostat=ierr) dataitem
124 DO i = nsplit, nrows, 3
126 DO j = 1, blocks_per_row
129 new_row_offset = 2-j+i
130 IF (new_row_offset.lt.1 .or. new_row_offset.gt.nrows) cycle
131 DO k = 1, recs_per_block
133 CALL readdaitem_seq(dataitem(boffset), isplit, j, k)
134 boffset = boffset + recs_per_block
137 recloc = 1 + new_recs_per_block*((j-1) + new_blocks_per_row
138 WRITE (inew_da, rec=recloc, iostat=ierr) dataitem
143 IF (isplit .ne. nrows) stop
'isplit != nrows'
148 CLOSE (iunit_da, status=
'DELETE')
151 data_size = new_data_size
152 rec_length = new_rec_length
153 block_size = new_block_size
154 blocks_per_row = new_blocks_per_row
155 recs_per_block = new_recs_per_block
158 READ(inew_da, rec=2) dataitem
161 DEALLOCATE (dataitem)
163 END SUBROUTINE changedafileparams
166 SUBROUTINE closedafile
168 IF (iunit_da .gt. 0)
THEN
173 END SUBROUTINE closedafile
176 SUBROUTINE deletedafile (filename)
177 CHARACTER*(*) :: filename
178 INTEGER :: ierr, rec_length=1
180 IF (iunit_da .eq. 0)
THEN
182 CALL safe_open(iunit_da, ierr, filename,
'replace',
'unformatted'
183 & rec_length,
'DIRECT')
184 IF (ierr .ne. 0)
THEN
185 print *,
'Unable to open existing ScratchFile'
190 CLOSE (iunit_da, status=
'DELETE')
193 END SUBROUTINE deletedafile
196 SUBROUTINE writedaitem_ra(DataItem, BlockRowIndex, ColIndex, IndexInBlock)
197 REAL(dp),
INTENT(in) :: DataItem(data_size)
198 INTEGER,
INTENT(in) :: BlockRowIndex, ColIndex, IndexInBlock
199 INTEGER :: recloc, ierr
200 INTEGER :: StartIndex
202 IF (colindex > blocks_per_row) stop
'ColIndex > Block_Per_Row in WriteDAItem'
203 IF (indexinblock > recs_per_block) stop
'IndexInBloc > skip_size in WriteDAItem'
206 startindex = indexinblock
207 IF (recs_per_block .eq. 1) startindex = 1
208 recloc = startindex + recs_per_block*((colindex-1) + blocks_per_row
210 WRITE (iunit_da, rec=recloc, iostat=ierr) dataitem
211 IF (ierr .ne. 0)
THEN
212 WRITE (6,*)
'Ierr = ', ierr,
' in WriteDAItem'
216 END SUBROUTINE writedaitem_ra
219 SUBROUTINE writedaitem_seq(DataItem)
220 REAL(dp),
INTENT(in) :: DataItem(data_size)
225 irec_pos = irec_pos+1
227 WRITE (iunit_da, rec=irec_pos, iostat=ierr) dataitem
228 IF (ierr .ne. 0)
THEN
229 WRITE (6,*)
'Ierr = ', ierr,
' in WriteDAItem'
233 END SUBROUTINE writedaitem_seq
236 SUBROUTINE readdaitem1(DataItem, BlockRowIndex, ColIndex, StartIndex)
237 REAL(dp),
INTENT(out) :: DataItem(data_size)
238 INTEGER,
INTENT(in) :: BlockRowIndex, ColIndex, StartIndex
239 INTEGER :: recloc, ierr
242 recloc = startindex + recs_per_block*((colindex-1) + blocks_per_row
243 READ (iunit_da, rec=recloc, iostat=ierr) dataitem
244 IF (ierr .ne. 0)
THEN
245 WRITE (6,*)
'Ierr = ', ierr,
' in ReadDAItem'
249 END SUBROUTINE readdaitem1
252 SUBROUTINE readdaitem2(DataItem, BlockRowIndex, ColIndex)
253 REAL(dp),
INTENT(out) :: DataItem(data_size)
254 INTEGER,
INTENT(in) :: BlockRowIndex, ColIndex
255 INTEGER :: recloc, ierr
258 recloc = 1 + recs_per_block*((colindex-1) + blocks_per_row*(blockrowindex
259 READ (iunit_da, rec=recloc, iostat=ierr) dataitem
260 IF (ierr .ne. 0)
THEN
261 WRITE (6,*)
'Ierr = ', ierr,
' in ReadDAItem'
265 END SUBROUTINE readdaitem2
268 SUBROUTINE readdaitem_seq(DataItem, BlockRowIndex, BlockTypeIndex, ColIndex)
269 REAL(dp),
INTENT(out) :: DataItem(data_size)
270 INTEGER,
INTENT(in) :: BlockRowIndex, ColIndex, BlockTypeIndex
271 INTEGER :: recloc, ierr
273 recloc = blocktypeindex + blocks_per_row*(blockrowindex-1+num_rows
274 READ (iunit_da, rec=recloc, iostat=ierr) dataitem
275 IF (ierr .ne. 0)
THEN
276 WRITE (6,*)
'Ierr = ', ierr,
' in ReadDAItem'
280 END SUBROUTINE readdaitem_seq
283 END MODULE directaccess