linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

minor changes

Browse Source
This commit is contained in:
cvs
2000-05-24 15:11:09 +00:00
parent 9053ae4e2d
commit 1a56fbc568
14 changed files with 643 additions and 212 deletions
Download Patch File Download Diff File Expand all files Collapse all files

200
tecs/tecs_dlog.f
View File

@@ -1,5 +1,9 @@
subroutine DLOG_OPEN_W(FILE) !!
!! ============================
subroutine tecs_dlog
stop 'TECS_DLOG: do not call module header'
end
integer function DLOG_OPEN_W(FILE) !!
!! ==================================
!!
!! open dlog file for write
!!
@@ -12,7 +16,8 @@
data lunw/0/
if (lunw .ne. 0) then
print *,'DLOG_OPEN_W: file already open for write'
call err_msg('file already open for write')
dlog_open_w=-1 ! failure
return
endif
lunw=38
@@ -22,17 +27,16 @@
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
read(lunw, rec=1, iostat=iostat) vers, stim, etim, wrec, rrec, wdir
if (vers .ne. version .or. iostat .ne. 0) 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')
call sys_remove_file(file)
vers=0
endif
if (vers .ne. version) then
print *,'DLOG_OPEN_W: create new file'
dlog_open_w=1 ! new file created
vers=version
do i=0,dirlen-1
wdir(i)=0
@@ -44,22 +48,26 @@
open(lunw, name=file, status='new', access='direct', shared
1 , recl=recl, err=93)
else
dlog_open_w=1 ! reopened
read(lunw, rec=wrec+2, iostat=iostat) wdat
endif
call dlog_write_block(1)
call dlog_write_block(1, done)
if (.not. done) then
call err_txt('dlog_write_block(1,done)')
goto 99
endif
return
93 print *,'DLOG_OPEN_W: can not open file for write'
print *,file
93 call err_msg('can not open file for write')
99 dlog_open_w=-1 ! failure
close(lunw)
lunw=0
end
subroutine DLOG_PUT(TIME, N, DAT) !!
!! =================================
integer function 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)
@@ -71,11 +79,18 @@
integer p,r,i,j,btim
data update/.true./
logical done
integer dlog_put_
entry dlog_put_(time, n, dat) ! C interface for VMS
dlog_put=0 ! assume success
if (lunw .le. 0) then
if (lunw .eq. 0) print *,'DLOG_PUT: file not open'
if (lunw .eq. 0) then ! return error message only once
call err_msg('file not open')
dlog_put=-1
endif
lunw=-1
return
endif
@@ -94,8 +109,16 @@
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)
call dlog_write_block(wrec+2, done)
if (.not. done) then
call err_txt('dlog_write_block(wrec+2,done)')
goto 99
endif
call dlog_write_block(1, done)
if (.not. done) then
call err_txt('dlog_write_block(1,done)')
goto 99
endif
endif
wrec=mod(wrec+1,dirlen)
btim=time-step/2
@@ -118,23 +141,48 @@
etim=time
if (update) then
call dlog_write_block(wrec+2)
call dlog_write_block(1)
call dlog_write_block(wrec+2, done)
if (.not. done) then
call err_txt('dlog_write_block(wrec+2,done)')
goto 99
endif
call dlog_write_block(1, done)
if (.not. done) then
call err_txt('dlog_write_block(1,done)')
goto 99
endif
endif
return
99 dlog_put=-1
end
subroutine DLOG_UPDATE(ALWAYS) !!
!! ==============================
integer function DLOG_UPDATE(ALWAYS) !!
!! ====================================
!!
!! update file. ALWAYS: switch on/off automatic update after DLOG_PUT
!!
include 'tecs_dlog.inc'
logical always
logical always, done
if (wrec .ge. 0) call dlog_write_block(wrec+2)
call dlog_write_block(1)
if (wrec .ge. 0) then
call dlog_write_block(wrec+2, done)
if (.not. done) then
call err_txt('dlog_write_block(wrec+2,done)')
goto 99
endif
endif
call dlog_write_block(1, done)
if (.not. done) then
call err_txt('dlog_write_block(1,done)')
goto 99
endif
update=always
dlog_update=0
return
99 dlog_update=-1
end
@@ -144,20 +192,21 @@
!! close data file for write
!!
include 'tecs_dlog.inc'
logical done
entry dlog_close_w_
if (.not. update) then
call dlog_write_block(wrec+2)
call dlog_write_block(1)
call dlog_write_block(wrec+2, done)
call dlog_write_block(1, done)
endif
if (lunw .gt. 0) close(lunw)
lunw=0
end
subroutine DLOG_OPEN_R(FILE, FIRST, LAST, OFFSET) !!
!! =================================================
integer function DLOG_OPEN_R(FILE, FIRST, LAST, OFFSET) !!
!! =======================================================
!!
!! open dlog file for read
!!
@@ -173,8 +222,11 @@
integer iostat
data lunr/0/
integer sys_gmt_off
if (lunr .ne. 0) then
print *,'DLOG_OPEN_R: file already open for read'
dlog_open_r=1
call err_msg('file already open for read')
return
endif
@@ -190,50 +242,71 @@
first=stim
last=etim
offset=first-mod(first+3*24*3600,7*24*3600)
offset=first-mod(first+3*24*3600,7*24*3600)-sys_gmt_off()
dlog_open_r=0
return
99 print *,'DLOG_OPEN_R: can not open'
99 call err_msg('can not open')
dlog_open_r=-1
lunr=0
end
subroutine DLOG_GET(NDIM,NDAT,OFFSET,XMIN,XMAX,UNDEF_VALUE,X,Y,NRES) !!
!! ====================================================================
integer function DLOG_GET(NDIM,NDAT,OFFSET,XMIN,XMAX,UNDEF_VALUE,X,Y) !!
!! =====================================================================
!!
!! 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
!! return value is the number of values returned or a negative value
!! if an error occured
!!
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 XMIN !! (in) start time (XMIN=0: first used time, XMIN<0 seconds before XMAX)
real XMAX !! (in) end time (XMAX=0: last used 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 irec, nres
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
if (lunr .eq. 0) then
call err_msg('file not open')
dlog_get=-1
return
endif
! print *,xmin,xmax
n=min(mdat,ndat)
nres=0
call dlog_read_block(1, done)
if (.not. done) return ! record locked
if (.not. done) then
call err_txt('dlog_read_block(1,done)')
dlog_get=-1
return ! record locked
endif
ftim=max(stim,offset+nint(max(-2147480000.-offset,xmin)))
ltim=min(etim,offset+nint(min( 2147480000.-offset,xmax)))
if (xmax .eq. 0) then
ltim=etim
else
ltim=min(etim,offset+nint(min( 2147480000.-offset,xmax)))
endif
if (xmin .eq. 0) then
ftim=stim
elseif (xmin .lt. 0) then
ftim=ltim+nint(xmin)
else
ftim=max(stim,offset+nint(max(-2147480000.-offset,xmin)))
endif
do j=1,mdat
ys(j)=0
@@ -252,7 +325,11 @@
i1=(rtim-btim+step/2)/step
if (i1 .lt. recs) then
call dlog_read_block(r+2, done)
if (.not. done) return ! record locked
if (.not. done) then
call err_txt('dlog_read_block(r+2,done)')
dlog_get=-1
return ! record locked
endif
i2=min((ltim-btim+step/2)/step,recs-1)
do i=i1,i2
@@ -264,14 +341,13 @@
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)
d=max(step,(ltim-rtim)/max(ndim-nres-1,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
@@ -290,7 +366,6 @@
do j=1,ndat
y(nres,j)=undef_value
enddo
! print *,'get undef',x(nres)
endif
ntim=0
endif
@@ -320,13 +395,13 @@
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
dlog_get=nres
end
@@ -343,9 +418,10 @@
subroutine dlog_write_block(recno)
subroutine dlog_write_block(recno, done)
integer recno
logical done
include 'tecs_dlog.inc'
@@ -357,18 +433,21 @@
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'
done=.false.
call err_msg('record locked')
return
endif
goto 1
endif
if (s .ne. 0) print *,'DLOG_PUT: locked for ',secnds(s),' seconds'
done=.true.
! if (s .ne. 0) then
! print *,'DLOG_PUT: locked for ',secnds(s),' seconds'
! endif
end
@@ -381,6 +460,8 @@
integer iostat, i
real s
character*24 msg
save msg
s=0
1 if (recno .eq. 1) then
@@ -392,17 +473,20 @@
if (s .eq. 0) then
s=secnds(0.0)
elseif (secnds(s) .gt. 2.0) then
print *,'DLOG_PUT: record locked'
call err_msg('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'
write(msg, '(a,i5)') 'read error ',iostat
call err_msg(msg)
done=.false.
else
if (s .ne. 0) print *,'DLOG_GET: locked for ',secnds(s),' seconds'
! if (s .ne. 0) then
! print *,'DLOG_GET: locked for ',secnds(s),' seconds'
! endif
done=.true.
endif
end
@@ -411,21 +495,25 @@
!
! C interface
!
subroutine dlog_open_write(cfile)
integer function dlog_open_write(cfile)
byte cfile(*) ! C char*
integer m, i, j
character file*128
integer dlog_open_w
integer dlog_open_write_
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))
dlog_open_write_=dlog_open_w(file(1:i-1))
return
endif
enddo
print *,'DLOG_OPEN_WRITE: filename too long'
dlog_open_write_=0
call err_msg('filename too long')
end