432 lines
9.1 KiB
Fortran
432 lines
9.1 KiB
Fortran
subroutine DLOG_OPEN_W(FILE) !!
|
|
!! ============================
|
|
!!
|
|
!! open dlog file for write
|
|
!!
|
|
character*(*) FILE !! (in) filename
|
|
|
|
include 'tecs_dlog.inc'
|
|
|
|
logical done
|
|
integer i,iostat
|
|
data lunw/0/
|
|
|
|
if (lunw .ne. 0) then
|
|
print *,'DLOG_OPEN_W: file already open for write'
|
|
return
|
|
endif
|
|
lunw=38
|
|
|
|
vers=0
|
|
|
|
open(lunw, name=file, status='old', access='direct', shared
|
|
1 , recl=recl, iostat=iostat)
|
|
if (iostat .eq. 0) then
|
|
read(lunw, rec=1) vers, stim, etim, wrec, rrec, wdir
|
|
if (vers .ne. version) then
|
|
close(lunw, status='delete')
|
|
endif
|
|
else ! delete file
|
|
open(lunw, name=file, status='old', iostat=iostat, shared)
|
|
if (iostat .eq. 0) close(lunw, status='delete')
|
|
vers=0
|
|
endif
|
|
if (vers .ne. version) then
|
|
print *,'DLOG_OPEN_W: create new file'
|
|
vers=version
|
|
do i=0,dirlen-1
|
|
wdir(i)=0
|
|
enddo
|
|
stim=0
|
|
etim=0
|
|
wrec=-1
|
|
rrec=0
|
|
open(lunw, name=file, status='new', access='direct', shared
|
|
1 , recl=recl, err=93)
|
|
else
|
|
read(lunw, rec=wrec+2, iostat=iostat) wdat
|
|
endif
|
|
|
|
call dlog_write_block(1)
|
|
|
|
return
|
|
|
|
93 print *,'DLOG_OPEN_W: can not open file for write'
|
|
print *,file
|
|
close(lunw)
|
|
lunw=0
|
|
end
|
|
|
|
|
|
subroutine DLOG_PUT(TIME, N, DAT) !!
|
|
!! =================================
|
|
!!
|
|
!! put data for N channels to logfile.
|
|
!! by default the file is updated in every call (see also DLOG_UPDATE)
|
|
!!
|
|
integer N, TIME !! (in) convention: time is in seconds since UNIX
|
|
real DAT(N) !! (in) data (0 is none)
|
|
|
|
include 'tecs_dlog.inc'
|
|
|
|
integer p,r,i,j,btim
|
|
data update/.true./
|
|
|
|
entry dlog_put_(time, n, dat) ! C interface for VMS
|
|
|
|
if (lunw .le. 0) then
|
|
if (lunw .eq. 0) print *,'DLOG_PUT: file not open'
|
|
lunw=-1
|
|
return
|
|
endif
|
|
|
|
if (stim .eq. 0) then
|
|
stim=time
|
|
endif
|
|
|
|
if (n .eq. 0) return
|
|
|
|
! check if value fits in actual record
|
|
if (wrec .lt. 0) then
|
|
btim=time+1
|
|
else
|
|
btim=wdir(wrec)
|
|
endif
|
|
if (time .lt. btim .or. time .ge. btim+recs*step) then
|
|
if (.not. update .and. wrec .ge. 0) then
|
|
call dlog_write_block(wrec+2)
|
|
call dlog_write_block(1)
|
|
endif
|
|
wrec=mod(wrec+1,dirlen)
|
|
btim=time-step/2
|
|
wdir(wrec)=btim
|
|
wdir(mod(wrec+1,dirlen))=0 ! disable next block
|
|
rrec=mod(wrec+2,dirlen)
|
|
if (wdir(rrec) .eq. 0) rrec=0
|
|
stim=wdir(rrec)
|
|
do i=0,recs-1
|
|
do j=1,mdat
|
|
wdat(j,i)=undef
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
i=(time-btim)/step
|
|
do j=1,min(n,mdat)
|
|
wdat(j,i)=dat(j)
|
|
enddo
|
|
|
|
etim=time
|
|
if (update) then
|
|
call dlog_write_block(wrec+2)
|
|
call dlog_write_block(1)
|
|
endif
|
|
end
|
|
|
|
|
|
subroutine DLOG_UPDATE(ALWAYS) !!
|
|
!! ==============================
|
|
!!
|
|
!! update file. ALWAYS: switch on/off automatic update after DLOG_PUT
|
|
!!
|
|
include 'tecs_dlog.inc'
|
|
logical always
|
|
|
|
if (wrec .ge. 0) call dlog_write_block(wrec+2)
|
|
call dlog_write_block(1)
|
|
update=always
|
|
end
|
|
|
|
|
|
subroutine DLOG_CLOSE_W !!
|
|
!! =======================
|
|
!!
|
|
!! close data file for write
|
|
!!
|
|
include 'tecs_dlog.inc'
|
|
|
|
entry dlog_close_w_
|
|
|
|
if (.not. update) then
|
|
call dlog_write_block(wrec+2)
|
|
call dlog_write_block(1)
|
|
endif
|
|
if (lunw .gt. 0) close(lunw)
|
|
lunw=0
|
|
end
|
|
|
|
|
|
subroutine DLOG_OPEN_R(FILE, FIRST, LAST, OFFSET) !!
|
|
!! =================================================
|
|
!!
|
|
!! open dlog file for read
|
|
!!
|
|
character*(*) FILE !! (in) filename
|
|
integer FIRST !! first time
|
|
integer LAST !! last time
|
|
integer OFFSET !! recommended offset for DLOG_GET:
|
|
!! last Monday 0h00 before FIRST
|
|
|
|
include 'tecs_dlog.inc'
|
|
|
|
logical done
|
|
integer iostat
|
|
data lunr/0/
|
|
|
|
if (lunr .ne. 0) then
|
|
print *,'DLOG_OPEN_R: file already open for read'
|
|
return
|
|
endif
|
|
|
|
lunr=39
|
|
|
|
open(lunr, name=file, status='old', access='direct', shared
|
|
1 , recl=recl, err=99, readonly)
|
|
call dlog_read_block(1, done)
|
|
if (.not. done) then
|
|
close(lunr)
|
|
goto 99
|
|
endif
|
|
|
|
first=stim
|
|
last=etim
|
|
offset=first-mod(first+3*24*3600,7*24*3600)
|
|
return
|
|
|
|
99 print *,'DLOG_OPEN_R: can not open'
|
|
lunr=0
|
|
end
|
|
|
|
|
|
subroutine DLOG_GET(NDIM,NDAT,OFFSET,XMIN,XMAX,UNDEF_VALUE,X,Y,NRES) !!
|
|
!! ====================================================================
|
|
!!
|
|
!! Get data from logfile in the range XMIN..XMAX
|
|
!! not available data is represented by 0
|
|
!! for precision reasons, and because time is internally stored
|
|
!! as integer seconds since UNIX (1 Jan 1970), a time offset is used.
|
|
!! X(i)+OFFSET, XMIN+OFFSET, XMAX+OFFSET is in seconds since UNIX
|
|
!!
|
|
integer NDIM, NDAT !! (in) dimensions
|
|
integer OFFSET !! (in) time zero point (use value from DLOG_OPEN)
|
|
real XMIN, XMAX !! (in) start and end time
|
|
real UNDEF_VALUE !! (in) value to be returned for undefined data
|
|
real X(NDIM), Y(NDIM, NDAT) !! (out) data
|
|
integer NRES !! (out) returned size
|
|
|
|
include 'tecs_dlog.inc'
|
|
|
|
integer r,rtim,ftim,ltim,btim,ntim,xtim
|
|
integer irec
|
|
integer i,j,i1,i2,iostat,n,d
|
|
logical done
|
|
|
|
real ys(mdat),yj
|
|
integer ns(mdat)
|
|
|
|
if (lunr .eq. 0) return ! file not open
|
|
|
|
! print *,xmin,xmax
|
|
n=min(mdat,ndat)
|
|
nres=0
|
|
call dlog_read_block(1, done)
|
|
if (.not. done) return ! record locked
|
|
|
|
ftim=max(stim,offset+nint(max(-2147480000.-offset,xmin)))
|
|
ltim=min(etim,offset+nint(min( 2147480000.-offset,xmax)))
|
|
|
|
do j=1,mdat
|
|
ys(j)=0
|
|
ns(j)=0
|
|
enddo
|
|
|
|
xtim=0
|
|
rtim=ftim
|
|
ntim=0
|
|
d=step
|
|
|
|
do irec=rrec,rrec+dirlen-2
|
|
r=mod(irec,dirlen)
|
|
btim=rdir(r)
|
|
rtim=max(rtim,btim,ftim)
|
|
i1=(rtim-btim+step/2)/step
|
|
if (i1 .lt. recs) then
|
|
call dlog_read_block(r+2, done)
|
|
if (.not. done) return ! record locked
|
|
|
|
i2=min((ltim-btim+step/2)/step,recs-1)
|
|
do i=i1,i2
|
|
|
|
rtim=btim+step*i
|
|
|
|
if (rtim .ge. ntim) then ! next point
|
|
if (xtim .ne. 0) then ! some data already cumulated
|
|
if (nres .lt. ndim) then
|
|
nres=nres+1
|
|
! we calculate over how long time we have to average in order not to exceed NDIM
|
|
d=max(step,(ltim-rtim)/(ndim-nres+1)+1)
|
|
x(nres)=xtim+d/2-offset
|
|
do j=1,n
|
|
if (ns(j) .eq. 0) then
|
|
y(nres,j)=undef_value
|
|
else
|
|
y(nres,j)=ys(j)/ns(j)
|
|
! if (j .eq. 1) print *,'get',x(nres),y(nres,j)
|
|
endif
|
|
enddo
|
|
do j=n+1,ndat
|
|
y(nres,j)=undef_value
|
|
enddo
|
|
do j=1,mdat
|
|
ys(j)=0
|
|
ns(j)=0
|
|
enddo
|
|
endif
|
|
xtim=0
|
|
elseif (ntim+120 .lt. rtim .and. ntim .ne. 0) then ! no reading for 120 secnds
|
|
if (nres .lt. ndim) then ! put a undef_value for separation
|
|
nres=nres+1
|
|
x(nres)=rtim-offset
|
|
do j=1,ndat
|
|
y(nres,j)=undef_value
|
|
enddo
|
|
! print *,'get undef',x(nres)
|
|
endif
|
|
ntim=0
|
|
endif
|
|
endif
|
|
|
|
do j=1,n
|
|
yj=rdat(j,i)
|
|
if (yj .ne. undef) then
|
|
if (xtim .eq. 0) then
|
|
xtim=rtim
|
|
ntim=xtim+d
|
|
endif
|
|
ns(j)=ns(j)+1
|
|
ys(j)=ys(j)+yj
|
|
endif
|
|
enddo
|
|
|
|
enddo !i
|
|
endif
|
|
enddo ! irec
|
|
|
|
if (xtim .ne. 0 .and. nres .lt. ndim) then
|
|
nres=nres+1
|
|
x(nres)=xtim+d/2-offset
|
|
do j=1,n
|
|
if (ns(j) .eq. 0) then
|
|
y(nres,j)=undef_value
|
|
else
|
|
y(nres,j)=ys(j)/ns(j)
|
|
! if (j .eq. 1) print *,'get last',x(nres),y(nres,j)
|
|
endif
|
|
enddo
|
|
do j=n+1,ndat
|
|
y(nres,j)=undef_value
|
|
enddo
|
|
endif
|
|
end
|
|
|
|
|
|
subroutine DLOG_CLOSE_R !!
|
|
!! =======================
|
|
!!
|
|
!! close data file for read
|
|
!!
|
|
include 'tecs_dlog.inc'
|
|
|
|
if (lunr .ne. 0) close(lunr)
|
|
lunr=0
|
|
end
|
|
|
|
|
|
|
|
subroutine dlog_write_block(recno)
|
|
|
|
integer recno
|
|
|
|
include 'tecs_dlog.inc'
|
|
|
|
integer iostat
|
|
real s
|
|
|
|
s=0
|
|
1 if (recno .eq. 1) then
|
|
write(lunw, rec=1, iostat=iostat) vers, stim, etim, wrec, rrec, wdir
|
|
else
|
|
write(lunw, rec=recno, iostat=iostat) wdat
|
|
! print *,'write',recno-2,wdat(1,0),wdat(1,recs-1)
|
|
endif
|
|
if (iostat .eq. 52) then ! record locked
|
|
if (s .eq. 0) then
|
|
s=secnds(0.0)
|
|
elseif (secnds(s) .gt. 2.0) then
|
|
print *,'DLOG_PUT: record locked'
|
|
return
|
|
endif
|
|
goto 1
|
|
endif
|
|
if (s .ne. 0) print *,'DLOG_PUT: locked for ',secnds(s),' seconds'
|
|
end
|
|
|
|
|
|
subroutine dlog_read_block(recno, done)
|
|
|
|
integer recno
|
|
logical done
|
|
|
|
include 'tecs_dlog.inc'
|
|
|
|
integer iostat, i
|
|
real s
|
|
|
|
s=0
|
|
1 if (recno .eq. 1) then
|
|
read(lunr, rec=1, iostat=iostat) vers, stim, etim, i, rrec, rdir
|
|
else
|
|
read(lunr, rec=recno, iostat=iostat) rdat
|
|
endif
|
|
if (iostat .eq. 52) then ! record locked
|
|
if (s .eq. 0) then
|
|
s=secnds(0.0)
|
|
elseif (secnds(s) .gt. 2.0) then
|
|
print *,'DLOG_PUT: record locked'
|
|
done=.false.
|
|
return
|
|
endif
|
|
read(lunr, rec=mod(recno-2,dirlen)+1, iostat=iostat) i ! dummy read to wait
|
|
goto 1
|
|
elseif (iostat .ne. 0) then
|
|
print *,'DLOG_GET: can not read record'
|
|
done=.false.
|
|
else
|
|
if (s .ne. 0) print *,'DLOG_GET: locked for ',secnds(s),' seconds'
|
|
done=.true.
|
|
endif
|
|
end
|
|
|
|
|
|
!
|
|
! C interface
|
|
!
|
|
subroutine dlog_open_write(cfile)
|
|
|
|
byte cfile(*) ! C char*
|
|
|
|
integer m, i, j
|
|
character file*128
|
|
|
|
entry dlog_open_write_(cfile) ! C interface for VMS
|
|
|
|
do i=2,128
|
|
if (cfile(i) .eq. 0) then
|
|
write(file, '(128a1)') (cfile(j), j=1,i-1)
|
|
call dlog_open_w(file(1:i-1))
|
|
return
|
|
endif
|
|
enddo
|
|
print *,'DLOG_OPEN_WRITE: filename too long'
|
|
end
|