c************
c   Description : Copy a data source stream/pipe to a Midas file/pipe
c
c   Author :    JGS   4//90
c
c   $Revision: 1.1 $
c   $Modtime:   17 Aug 1997 12:21:44  $
c
c  11-03 EHG DR 500002 Changed type to write for Intel Compiler
c   
c************
c
	program SOURCEFILE
c
	implicit none
c
	include 'primitive.inc'
	record /HEADER/ HIN,HOUT
c
	integer*4 L_bbuf
	parameter (L_bbuf=32768)
	character*4 newform,origrep
	real*8 dstart,dend,ddur,doff,dslip, dbyte
	real*8 tstart,tdelta,size,dnext,dval,dmbpe,dtogo
	logical*4 absc,noblock,inmem,firsttime,rtfile,EXITMSG
	integer*4 idelta,ired,tl,lbuf, nlost
	common /clip/ dstart,dend,ddur,doff,tstart,tdelta,size,
     &			idelta,ired,absc
	integer*4 mab,mgo,idg,ido,idd,idr,ids,ida,idc
	integer*4 iper,npot,nsk,nget,not,nski,ngot,isok,iskip, icopy
c
	call M$CHECKIN
c
c open and check input file
	HIN.label = M$UPICK(1)
	HIN.file_name = M$APICK(1)
	HIN.type_allow = ' '
	HIN.format_allow = ' '
	call M$INOK(HIN)
c
c is this kosher
	if (HIN.pipe.ne.0) call M$WARNING 
     &	('Sourcefile is not meant to be fed from a pipe - be careful')
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
	size = HIN.size
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 get bounded start/stop indices
	call CLIPRANGE ()
c
c keep the segment in memory ?
	inmem = M$GET_SWITCH('INMEM') .gt. 0
c
c use the real-time file pipe fields ?
	rtfile = M$GET_SSWITCH('RTFILE')
	if (rtfile) HIN.flush = .true.
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 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 fill out header and open output file
	call M$PROPAGATE (HIN,HOUT)
c DR 11294, also added tp sinkfile
	HOUT.flush = .TRUE.
	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( (dend-dstart-1.d0)/idelta ) + 1.d0
   	if (mgo .lt. 0) HOUT.size = -mgo*HOUT.size                                   
	call M$ALLOCATE (HOUT)
c
c set up real time controls
	idg = M$MWINIT('Replay Mode',mgo,
     &	    'REPLAY;Play One,Continuous,Stop Top,Stop Now,'//
     &	    'New File & Wait,New File & One,New File & Cont,Abort')
	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, HIN.size , 1.d0)
c
c signal start of processing block
	dbyte = 0
	firsttime = .true.
	lbuf = 0 ! dynamic memory location init
	call M$SYNC()
c
c top of throttle loop
  1	isok = M$MWGET(idg,mgo)
	do while (mgo.eq.0 .or. mgo.gt.2 .or. .not.HIN.open) 	! wait loop
	  if (mgo.ge.5 .and. mgo.le.7) then	! new file
	    call M$CLOSE(HIN)
	    if (M$RFIND(HIN.label,HIN.file_name,dval).ne.'A') 
     &	    call M$WARNING('New file label untranslatable : '//HIN.label)
	    HIN.switch = 'NOABORT'
	    call M$INOK(HIN)
	    if (HIN.open) then
	      mgo = mgo - 5
	      mab = 0	 ! force control change
	    else
	      call M$WARNING('New file open failure : '//HIN.file_name)
	      mgo = 4
	    endif
	    call M$MWPUT(idg,mgo)
	  elseif ((mgo.eq.3 .or. mgo.eq.4) .and. HIN.open) then	
	    mgo = 0	! stop but already stopped
	    call M$MWPUT(idg,mgo)
	  endif
	  call M$PAUSE(0.1)
	  isok = M$MWGET(idg,mgo)
	  if (Mc.break .or. mgo.eq.8 .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 = HIN.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 packed
	    icopy = -icopy
	    HIN.buf_type = 'B'
	  endif
	  dmbpe = max( HIN.dbpe*idelta, HOUT.dbpe*idelta )
	  if (inmem) then
	    iper = NINT(dend-dstart)
	  elseif (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
c
c check for inmemory mode and take the short way out.  Remember the first call
c to FILAD already performed the type and rep translation IN PLACE.  Set 
c fields temporily to keep FILAD from translating again.
c
	elseif (inmem) then
	  origrep  = HOUT.data_rep
	  HOUT.data_rep = Mc.machine
	  HOUT.buf_type = HOUT.format(2:2)
	  call M$FILAD (HOUT,%val(lbuf),npot)
	  HOUT.data_rep = origrep
	  goto 3
	endif
c
c reset read counters
	HIN.offset = dstart
	dtogo = DNINT(dend-dstart)
	dnext = dstart + 1
	nsk = 0
c
c check for falling behind real-time file data ?
C DR 12581 SAR 1/14/03
C Changed to nest the IF commands so that the 2nd expression is not
C evaluated when not in rtfile mode.
c	if (rtfile .and. 
c     &		HIN.in_byte-dbyte .gt. dtogo*HIN.dbpe) then
	if (rtfile) then
          if (HIN.in_byte-dbyte .gt. dtogo*HIN.dbpe) then
	    nlost = (HIN.in_byte-dbyte)/HIN.dbpe/dtogo
	    write(*,*) 'Lost ',nlost,' buffers in RTFILE mode'
	    dbyte = dbyte + nlost*HIN.dbpe*dtogo
	  endif
	endif
C end DR 12581

c
c loop through buffers of data
	do while (dtogo.gt.0 .and. .not.Mc.break)
	  if (EXITMSG()) goto 999
	  nget = min(DBLE(iper),dtogo)
c
c wait for real-time file data ?
	  if (rtfile) then
	    do while (HIN.in_byte-dbyte .lt. nget*HIN.dbpe)
	      call M$PAUSE(0.1)
	      isok = M$MWGET(idg,mgo)
	      if (Mc.break .or. mgo.eq.8) goto 999
	      call M$FREAD (HIN, HIN, 0.d0, 512, ngot)
	    enddo	      
	  endif
c
c grab the next buffer
	  call M$GRAB (HIN,%val(lbuf),dnext,nget,ngot)
	  call M$DWPUT (idc, HIN.offset)
	  dtogo = dtogo - ngot*iskip
	  dnext = dnext + ngot*iskip
	  dbyte = dbyte + ngot*HIN.dbpe
c
c did slip force a grab past the EOF - dupe front of buffer
	  if (ngot.ne.nget) then
	    call M$MOVE(%val(lbuf),%val(lbuf+ngot*icopy),
     &					NINT(dtogo)*icopy)
	    ngot = ngot + dtogo
	    dtogo = 0
	  endif
c
c adjust for slip
	  isok = M$DWGET(ids,dslip)
	  if (dslip.ne.0.d0) then
	    nski = NINT( (dnext-1-dstart)*dslip ) - nsk
	    dnext = dnext + DBLE(nski)/HIN.ape
	    nsk = nsk + nski
	  endif
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.buf_type,
     &		%val(lbuf),HOUT.buf_type, npot*idelta*HIN.spa)
	      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)
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.eq.1.or.mgo.eq.3.or.mgo.eq.4) call M$MWPUT(idg,0)
	  if (mgo.ne.8 .and. .not.Mc.break) goto 1
	else
	  mgo = mgo + 1	! replicate mode
	  call M$MWPUT(idg,mgo)
	  if (mgo.lt.0 .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

