c************
c   Description : Copy a data source stream/pipe to a Midas file/pipe
c
c   Author :    JGS   6//92
c
c   $Revision: 1.1 $
c   $Modtime:   17 Aug 1997 12:09:02  $
c   Modifications: SINKFILE fails to connecto to new file
c		   cjb - 07-Jun-04
c   
c************
c
	program SINKFILE
c
	implicit none
	include 'primitive.inc'
	record /HEADER/ HIN,HOUT
c
	integer*4 L_bbuf
	parameter (L_bbuf=32768)
	character*4 newform
	real*8 dstart,dend,ddur,doff,dslip
	real*8 tstart,tdelta,size,dnext,dval,dmbpe,dtogo
	logical*4 absc,noblock,over,firsttime,rtfile,autoc,EXITMSG
	integer*4 idelta,ired,tl,lbuf
	integer*4 mab, mgo,idg,ido,idd,idr,ids,ida,idc,isok, iskip
	integer*4 icopy, iper, ibuf, nsk, ngot, npot
	common /clip/ dstart,dend,ddur,doff,tstart,tdelta,size,
     &			idelta,ired,absc
c
	call M$CHECKIN
c
c open and check input file
	HIN.file_name = M$APICK(1)
	HIN.type_allow = ' '
	HIN.format_allow = ' '
	call M$INOK(HIN)
c
c get thinning parameters
	doff   = M$DPICK(3)	
	ddur   = M$DPICK(4)	
	ired   = M$LPICK(5)	
	absc   = M$SPICK(6)
	dslip  = M$DPICK(7)
c
c is reformatting desired ?
	newform = M$APICK(8)
	if (newform.ne.' ') then
	  newform = M$TEST_FORMAT(newform,' ')
	  newform = HIN.format(1:1)//newform(2:2)
	  newform = M$PROMOTE_FORMAT ( HIN.format, newform, 'SB')
	else
	  newform = HIN.format
	endif
c
c set pertinent start delta fields
	if (HIN.class .eq. 2) then
	  tstart = HIN.ystart
	  tdelta = HIN.ydelta
	else
	  tstart = HIN.xstart
	  tdelta = HIN.xdelta
	endif
c
c get bounded start/stop indices
	size = HIN.size
	call CLIPRANGE ()
c
c get the transfer length switch
	tl = M$GET_SWITCH('TL')
c
c can we allow blocking this file
	noblock = HIN.ape.gt.1 .or. HIN.spa .gt.2
c
c write over existing file ?
	over = M$GET_SSWITCH('OVER') 
c
c use the file header pipe fields for real-time output file ?
	rtfile = M$GET_SSWITCH('RTFILE') 
	if (rtfile) HIN.flush = .true.
c
c automatically entr consume mode when transfer finishes ?
	autoc = M$GET_SSWITCH('AUTOC') 
c
c fill out header and open output file
	if (over) then
	  call M$ERROR('Overwrite mode not coded yet')
	else
	  size = dend-dstart
	  call M$PROPAGATE (HIN,HOUT)
c DR 11294, also added tp sourcefile
	  HOUT.flush = .TRUE.
	  HOUT.label = M$UPICK(2)
	  HOUT.file_name = M$APICK(2)
	  if (HOUT.class .eq. 2) then
	    HOUT.ystart = HIN.ystart + dstart*HIN.ydelta
	    HOUT.ydelta = HIN.ydelta * idelta
	  else
	    HOUT.xstart = HIN.xstart + dstart*HIN.xdelta
	    HOUT.xdelta = HIN.xdelta * idelta
	  endif
	  HOUT.format = newform
	  HOUT.size  = DINT( (size-1.d0)/idelta ) + 1.d0
	  call M$ALLOCATE (HOUT)
	  call M$FEOF (HOUT)
	endif
c
c get startup modes
	mab = 1
	if (absc) mab = 2
	mgo = M$GET_SWITCH('REPLAY')
	if (mgo.ge.0 .and. Mc.mode.eq.0) then
	  call M$WARNING('/REPLAY option ignored in non-piped macro')
	  mgo = -1
	endif
c
c set up real time controls
	idg = M$MWINIT('Replay Mode',mgo,
     &	    'REPLAY;Play One,Continuous,Stop Top,Stop Now,'//
     &	'New File,NewFile & One,NewFile & Cont,Abort,Consume')
	ido = M$DWINIT('Start',    doff, 1.d0, -1.d0 , 1.d0)
	idd = M$DWINIT('Duration', ddur, 1.d0, -1.d0 , 1.d0)
	idr = M$LWINIT('Reduction',ired, -512, 512, 1)
	ids = M$DWINIT('Slip',     dslip, 1.d0, -1.d0 , 1.d-05)
	ida = M$MWINIT('Addressing',mab,'Index,Abscissa')
	idc = M$DWINIT('Current',  0.d0, 0.d0, HOUT.size , 1.d0)
c
c signal start of processing block
	lbuf = 0 ! dynamic memory pointer
	firsttime = .true.
	call M$SYNC()
c
c top of throttle loop
  	isok = M$MWGET(idg,mgo)
c====DR #502244 MODIFICATION===================
c-Moved '1' Label down one line----------------
  1	do while (mgo.eq.0 .or. mgo.gt.2 .or. .not.HOUT.open) 
	  if (mgo.eq.8) then
	    goto 999
	  elseif (mgo.eq.9) then
	    call M$HCBFUNC (HIN,HCBF_SKIP,-1)
	  elseif (mgo.ge.5) then
	    call M$CLOSE(HOUT)
	    if (M$RFIND(HOUT.label,HOUT.file_name,dval).ne.'A')
     &	    call M$WARNING('New file label untranslatable: '//HOUT.label)
	    HOUT.switch = 'NOABORT'
	    HOUT.size = size
	    call M$ALLOCATE(HOUT)
	    call M$FEOF (HOUT)
	    if (HOUT.open) then
	      mgo = mgo - 5
	      mab = 0  ! force control change
	    else
	      call M$WARNING('New file open failure : '//HOUT.file_name)
	      mgo = 4
 	    endif
	    call M$MWPUT(idg,mgo)
	  elseif ((mgo.eq.3 .or. mgo.eq.4) .and. HOUT.open) then
	    mgo = 0  ! stop but already stopped
	    call M$MWPUT(idg,mgo)
 	  endif
	  call M$PAUSE(Mc.pause)
	  isok = M$MWGET(idg,mgo)
	  if (Mc.break .or. EXITMSG() ) goto 999
	enddo
c
c get new real time controls
  2	isok = 	M$DWGET(ido,doff)  +
     &		M$DWGET(idd,ddur)  +
     &		M$LWGET(idr,ired)  +
     &		M$DWGET(ids,dslip) +
     &		M$MWGET(ida,mab)
c
c recalculate specs only if a control has changed
	if (isok.ne.0 .or. firsttime) then
	  firsttime = .false.
	  absc = mab.eq.2
	  size = HOUT.size
	  call CLIPRANGE ()
	  if (ired.lt.-1 .and. noblock) then
	    call M$WARNING('Cannot perform blocking on input data type')
	    ired = 1
	  endif
	  iskip = 1
	  icopy = HIN.bpe
	  HIN.buf_type = HIN.format(2:2)
	  if (icopy.lt.0 .and. iabs(ired).gt.1) then	! bit data
	    icopy = -icopy
	    HIN.buf_type = 'B'
	  endif
	  dmbpe = max( HIN.dbpe*idelta, HOUT.dbpe*idelta )
	  if (icopy*(ired-1).gt.512) then		! large stride
	    iper = 1 
	    iskip = idelta
	  else
	    iper = tl
	    if (iper.le.0) iper = max(1, NINT(L_bbuf/dmbpe) )
	  endif
	  call M$REMALLOC (NINT(iper*dmbpe), lbuf)
	  HOUT.buf_type = HIN.buf_type
	endif
c
c reset write counters if not append mode
	if (mgo.ge.0) HOUT.offset = dstart
	dtogo = DNINT(dend-dstart)
	nsk = 0
c
c loop through buffers of data
	do while (dtogo.gt.0 .and. Mu.okio .and. .not.Mc.break)
	  if (EXITMSG()) goto 999
	  HIN.xfer_len = min(DBLE(iper),dtogo)
	  call M$GRABX (HIN,%val(lbuf),ngot)
	  dtogo = dtogo - ngot*iskip
c
c large or no skip
	  if (iper.eq.1 .or. idelta.eq.1) then	
	    npot = ngot
c
c regular thinning/blocking operation
	  else				
	    npot = (ngot+idelta-1)/idelta
	    if (ired.ge.0) then				! thinning
	      call M$VMOVN (%val(lbuf),idelta,%val(lbuf),1,npot,icopy)
	    else					! blocking
	      HOUT.buf_type = HOUT.format(2:2)
	      call M$REFORMAT (%val(lbuf),HIN.format,
     &		%val(lbuf),HOUT.buf_type, npot*idelta)
	      call M$VTYPE (HOUT.buf_type)
	      if (HIN.spa .eq. 2) then
		call M$CVBLK (%val(lbuf),%val(lbuf),idelta,ngot)
	      else
		call M$VBLK (%val(lbuf),%val(lbuf),idelta,ngot)
	      endif
	    endif
	  endif

	  call M$FILAD (HOUT,%val(lbuf),npot)
	  call M$DWPUT (idc, HOUT.offset)
c
c update header pipe fields for real-time files
	  if (rtfile) then
	    HOUT.in_byte = HOUT.in_byte + npot*HOUT.dbpe
	    call M$FWRITE (HOUT, HOUT, 0.d0, 512, npot)
	  endif
c
c check throttle control widget
	  isok = M$MWGET(idg,mgo)
	  if (mgo.ge.4) dtogo = 0
c
	enddo
c
c go back for replay
  3	if (mgo.ge.0) then
	  if (mgo.ne.2) call M$MWPUT(idg,0)
	  if (mgo.ne.2 .and. autoc) call M$MWPUT(idg,9)
	  if (Mu.okio .and. .not.Mc.break) goto 1
	else
	  mgo = mgo + 1
	  if (mgo.lt.0 .and. Mu.okio .and. .not.Mc.break) goto 1
	endif
c
c close input/output files
  999	call M$CLOSE(HIN)
	call M$CLOSE(HOUT)
c
	call M$RETURN
	end


	subroutine CLIPRANGE ()
c
	real*8 dstart,dend,ddur,doff,dslip,tstart,tdelta,size
	logical*4 absc
	integer*4 idelta,ired
	common /clip/ dstart,dend,ddur,doff,tstart,tdelta,size,
     &			idelta,ired,absc
c
	if (ired.eq.0) ired = 1
	idelta = iabs(ired)
c
	if (absc) then
	  dstart = DNINT((doff-tstart)/tdelta)
	  if (ddur.gt.0.d0) dend = DNINT(dstart+ddur/tdelta)
	else
	  dstart = DNINT(doff-1.d0)
	  if (ddur.gt.0.d0) dend = DNINT(dstart+ddur)
	endif
	if (ddur.lt.0.d0) dend = DNINT(dstart-ddur*idelta)
	if (dstart.lt.0.d0) then
	  call M$WARNING ('START is before beginning of file - shifting')
	  dend = dend - dstart
	  dstart = 0
	endif
	if (ddur.eq.0.d0) then
	  dend = size
	elseif (dend.gt.size) then
	  call M$WARNING ('END past end of file - shifting')
	  dstart = size - (dend-dstart)
	  dend = size
	endif
	return
	end


	logical*4 function EXITMSG ()
	include 'primitive.inc'
	include 'qmessages.inc'
	EXITMSG = .false.
	if (Mu.id .le. 0) return
	if (M$GET_MSG (mqh, mqd, L_mqd, 0.0, 0) .le. 0) return
	if (mqh.name .eq. MQH_EXIT.name) then
	  EXITMSG = .true.
	else
	  call M$WARNING ('Unsupported message: '//mqh.name)
	endif
	return
	end
