c************
c   Description : X-Midas real-time control queued message utilities.  These 
c		  routines queue up, remove, messages from a global message 
c		  queue.
c
c   Author :    SES   12//92
c
c   2020-06-26 Multiple updates contributed by Duy as part of GFC support update
c   
c   The following line directs xpc to turn the Sun FORTRAN compiler
c   optimization down to level 1 due to its inability to correctly optimize
c   the code referencing pointers
c   #_SUN OPTIMIZATION -O1
c
c************



	subroutine M$EXPAND_HTYPE (types, pos, length, nelem, type, bpe)

	implicit none
	include 'types.inc'
c Arguments
	character*(*) types	! (IN) message types string
	integer*4 pos		! (IN/OUT) current index into types string
	integer*4 length	! (IN) total length of types string
	integer*4 nelem		! (OUT) number of elements parsed at pos
	character*1 type	! (OUT) indicates type parsed at pos
	integer*4 bpe		! (OUT) bytes/element of type parsed at pos
c Locals
	integer*4 lpos		! as pos is incremented lpos is used as a
				! place holder for the beginning of a token
	integer*4 nvals		! number read from [] type token
c Code
	nelem = 1

	if (pos.le.length) then
	  lpos = pos
	  type = ' '
	  bpe = 0
	  do while (pos.le.length)
	    if (M$TYPE(types(pos:pos)).ne.1) goto 90
	    pos = pos + 1
	  enddo
  90	  continue 
	  if (pos.le.length) type = types(pos:pos)
	  if (type.eq.'L' .or. type.eq.'F') then
	    bpe = 4
	  elseif (type.eq.'I') then
	    bpe = 2
	  elseif (type.eq.'B' .or. type.eq.'S' .or. type.eq.'U') then
	    bpe = 1
	  else
	    bpe = 8
	  endif
	  if (pos .ne. lpos) read(types(lpos:pos-1), *) nelem
	  pos = pos + 1
	  lpos = pos
	  do while (pos.le.length)
	    if (type.ne.types(pos:pos)) goto 91
	    nelem = nelem + 1
	    pos = pos + 1
	  enddo
  91	  continue 
	  if (pos.le.length) then
	    if (types(pos:pos) .eq. '[') then
	      if (lpos.lt.pos) then
	        nelem = nelem - 1
	        pos = pos - 1
	      else			! read # from "[....]"
	        nvals = 1
	        pos = pos + 1
	        lpos = pos
	        do while (pos.le.length)
		  if (M$TYPE(types(pos:pos)).ne.1) goto 92
		  pos = pos + 1
	        enddo
  92		continue 
	        if (lpos.ne.pos) read(types(lpos:pos-1), *) nvals
	        if (pos.le.length) then
	          if (types(pos:pos) .eq. ']') pos = pos + 1
	        endif
	        bpe = bpe * nvals
	      endif
	    endif
	  endif
	endif
	return
	end


	subroutine M$SEND_MESSAGE (name, rid, info, ndata, types, mqd)
	implicit none
	include 'queue.inc'
	character*(*) name, types
	integer*4 rid, info, ndata
	record /MQ_QUEUESLOT/ mqd(*)
	call M$SEND_MSGL (name, 0, rid, info, 0, ndata, types, mqd, 0)
	return
	end

	function M$GETW_MESSAGE (name, sid, info, ndata, types, mqd, wait)
	implicit none
	include 'types.inc'
	include 'queue.inc'
	character*(*) name, types
	integer*4 sid, info, ndata, mode
	record /MQ_QUEUESLOT/ mqd(*)
	real*4 wait
	M$GETW_MESSAGE = M$GET_MSGL(name, sid, 0, info, mode, ndata, 
     &		types, mqd, 128, wait, 0)
	return
	entry M$GET_MESSAGE (name, sid, info, ndata, types, mqd)
	M$GET_MESSAGE = M$GET_MSGL(name, sid, 0, info, mode, ndata, 
     &		types, mqd, 128, 0.0, 0)
	return
	end
	
	subroutine M$SEND_MSGL (name,sid,rid,info,mode,ndata,types,mqd,mask)
c
	implicit none
	include 'types.inc'
	include 'midas.inc'
c	include 'tables.inc'
	include 'queue.inc'

	character*(*) name, types
	integer*4 sid,rid,info,mode,ndata,mask
	record /MQ_QUEUESLOT/ mqd(*)
	character*1 type
	integer*4 i,nlen,nelem,nbytes,bpe,n,sps

	record /MQ_HEADER/ mqh
#ifdef _GFC
 	save :: mqh ! Intel does this implicitly; here it is critical
#endif
c
c	if (Mu.id.le.0 .or. Mt.nmessage.le.0) return

	mqh.info   = info
	mqh.mode   = mode
	mqh.name   = name
	mqh.sender = sid

	nlen = max (0, M$LENGTHQ(types))

	if (nlen.gt.1) then			! heterogeneous
	  mqh.type = 'H'
	  mqh.types = types(1:nlen)
	  i = 1
	  n = 1
	  nbytes = 0
	  do while (n.le.ndata)
	    if (i.gt.nlen) nelem = ndata - n + 1
	    if (i.le.nlen) call M$EXPAND_HTYPE (types,i,nlen,nelem,type,bpe)
	    nbytes = nbytes + nelem * bpe
	    n = n + nelem
	  enddo
	  mqh.nhslots = SLOTS_PER_HET_MQH
	else					! homogeneous
          if (nlen.eq.1) then
            mqh.type = types
          else                                  ! nlen == 0
c           Intel and GFC will assign a space to mqh.type if types
c           contains unprintable characters (like null). PGF will
c           either leave it null or copies the null. This causes
c           problems downstream in the intrinsic (message.cc). So
c           if no types are provided at all, initialize to a space.
            mqh.type = ' '
            mqh.types = ' '
          endif
	  if (types.eq.'F' .or. types.eq.'L') then
	    nbytes = 4 * ndata
	  elseif (types.eq.'I') then
	    nbytes = 2 * ndata
	  elseif (types.eq.'B' .or. types.eq.'S' .or. types.eq.'U') then
	    nbytes = ndata
	  else
	    nbytes = 8 * ndata
	  endif
	  mqh.nhslots = SLOTS_PER_HOM_MQH
	endif
	mqh.nslots = mqh.nhslots + (nbytes+BYTES_PER_SLOT-1)/BYTES_PER_SLOT
	mqh.ntype = nlen
	mqh.ndata = ndata
	if (nlen .gt. 0) mqh.types = types(1:nlen)
	call M$SEND_MSG (mqh, mqd, rid, mask)
c
	return
	end


	function M$GET_MSGL (name, sid, rid, info, mode, 
     &			ndata, types, mqd, size, wait, mask)
c
	implicit none
	include 'types.inc'
c	include 'tables.inc'
	include 'queue.inc'

	character*(*) name, types
	integer*4 rid,sid,info,mode,ndata,size,mask
	real*4 wait
	record /MQ_HEADER/ mqh
	record /MQ_QUEUESLOT/ mqd(*)
#ifdef _GFC
 	save :: mqh ! Intel does this implicitly; here it is critical
#endif
c
	M$GET_MSGL = 0
	mqh.name   = name
	mqh.mode   = mode
	mqh.reader = rid
	mqh.sender = sid
	if (M$GET_MSG(mqh,mqd,size,wait,mask).eq.0) return

	if (BTEST(mask,MQB_ANYREADER)) rid = mqh.reader
	sid   = mqh.sender
	if (mqh.type.eq.'H') then
	  types = mqh.types
	else
	  types = mqh.type
	endif
	info  = mqh.info
	mode  = mqh.mode
	name  = mqh.name
	ndata = mqh.ndata
	M$GET_MSGL = 1
	return
	end

