subroutine tecs_dlog stop 'TECS_DLOG: do not call module header' end integer function 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 call err_msg('file already open for write') dlog_open_w=-1 ! failure 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, 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 call sys_remove_file(file) vers=0 endif if (vers .ne. version) then dlog_open_w=1 ! new file created 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 dlog_open_w=1 ! reopened read(lunw, rec=wrec+2, iostat=iostat) wdat endif call dlog_write_block(1, done) if (.not. done) then call err_txt('dlog_write_block(1,done)') goto 99 endif return 93 call err_msg('can not open file for write') 99 dlog_open_w=-1 ! failure close(lunw) lunw=0 end 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) !! 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./ 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) then ! return error message only once call err_msg('file not open') dlog_put=-1 endif 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, 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 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, 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 integer function DLOG_UPDATE(ALWAYS) !! !! ==================================== !! !! update file. ALWAYS: switch on/off automatic update after DLOG_PUT !! include 'tecs_dlog.inc' logical always, done 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 subroutine DLOG_CLOSE_W !! !! ======================= !! !! 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, done) call dlog_write_block(1, done) endif if (lunw .gt. 0) close(lunw) lunw=0 end integer function 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/ integer sys_gmt_off if (lunr .ne. 0) then dlog_open_r=1 call err_msg('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)-sys_gmt_off() dlog_open_r=0 return 99 call err_msg('can not open') dlog_open_r=-1 lunr=0 end 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 !! (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 include 'tecs_dlog.inc' integer r,rtim,ftim,ltim,btim,ntim,xtim integer irec, nres integer i,j,i1,i2,iostat,n,d logical done real ys(mdat),yj integer ns(mdat) if (lunr .eq. 0) then call err_msg('file not open') dlog_get=-1 return endif n=min(mdat,ndat) nres=0 call dlog_read_block(1, done) if (.not. done) then call err_txt('dlog_read_block(1,done)') dlog_get=-1 return ! record locked endif 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 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) 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 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)/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) 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 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) endif enddo do j=n+1,ndat y(nres,j)=undef_value enddo endif dlog_get=nres 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, done) integer recno logical done 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 endif if (iostat .eq. 52) then ! record locked if (s .eq. 0) then s=secnds(0.0) elseif (secnds(s) .gt. 2.0) then done=.false. call err_msg('record locked') return endif goto 1 endif done=.true. ! if (s .ne. 0) then ! print *,'DLOG_PUT: locked for ',secnds(s),' seconds' ! endif end subroutine dlog_read_block(recno, done) integer recno logical done include 'tecs_dlog.inc' integer iostat, i real s character*24 msg save msg 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 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 write(msg, '(a,i5)') 'read error ',iostat call err_msg(msg) done=.false. else ! if (s .ne. 0) then ! print *,'DLOG_GET: locked for ',secnds(s),' seconds' ! endif done=.true. endif end ! ! C interface ! 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) dlog_open_write_=dlog_open_w(file(1:i-1)) return endif enddo dlog_open_write_=0 call err_msg('filename too long') end