c**********************************************************************c
c Description: Host primitive for testing sending and receiving        c
c              message from X-Midas primitive to Java                  c
c                                                                      c
c Author: JPH                                                          c
c                                                                      c
c Version: $Id: nxmoptmsg.for,v 1.5 2006/06/08 17:54:40 jxc Exp $
c                                                                      c
c**********************************************************************c
      program NXMOPTMSG

      implicit none
      include 'primitive.inc'
      include 'qmessdef.inc'
      include 'qmessdecl.inc'
      include 'assert.inc'

c.. Structures
      structure /DADMSG_STRUCTURE/
        real*8 dval1
        character*8 aval
        real*8 dval2
      end structure
      record /DADMSG_STRUCTURE/ dadmsg

c.. Inputs
      integer*4 msgid    ! Id to which this prim sends messages
      integer*4 msgidBAD ! Message not sent back to correct id
c.. Functions
      integer*4 compareHeader
c.. Locals
      logical*4 dbg
      logical*4 idPresent
      logical*4 done
      integer*4 status     ! Return status for functions

      if(dbg)call debug('Starting NXMOPTMSG...')
      call M$CHECKIN

      call assert_init(m$get_pswitch('VERBOSE'))

      !******* Check to debug the primitive
      dbg       = M$GET_PSWITCH('DEBUG')
      idPresent = M$GET_PSWITCH('ID')
      if (.NOT.idPresent) then
        call m$error('You must run this primitive with an ID switch')
      endif
      msgid = m$lpick(1)
      if (msgid .LE. 0) then
        msgid = 1
        call m$warning('Invalid receiver msg id given, '
     &               //'using default=1')
      endif
      msgidBAD = m$lpick(2)
      if (msgid .LE. 0) then
        msgidBAD = 999
        call m$warning('Invalid receiver msg id given, using
     &                  default=999')
      endif

      if(dbg)call debug('Before m$sync...')

      call M$SYNC()

      ! Message not sent to NeXtMidas macro    
      call m$send_msgl('TEST0', 0, msgidBAD, 4 , 0, 0, ' ',mqd, 0)

      ! Unconfigured message no data
      call m$send_msgl('TEST1', 0, msgid  , 99, 0, 0, ' ',mqd, 0)

      ! Unconfigured message with data
      dadmsg.dval1 = 1.0 
      dadmsg.aval  = 'Two'
      dadmsg.dval2 = 3.0 
      call m$send_msgl('TEST2',0,msgid,7,0,3,'DAD',dadmsg,0)

      ! Matches configured message
      mqd.SETL.object = 'MyObj'
      mqd.SETL.value  = 1
      mqd.SETL.value2 = 1
      call m$send_msg(mqh_SETL, mqd, msgid, 0)

      done = .false.
      do while (.not. done .AND. .not. Mc.break)
        status = m$get_msg(mqh, mqd, L_mqd, 0.0, 0)
        if (status .EQ. 1) then
          write(*,*) 'NXMOPTMSG got msg ',mqh.name
          
          if (mqh.name(1:4) .EQ. 'EXIT') then
            done = .true.
          else
            if (mqh.name(1:6) .EQ. 'TESTN0') then
              ! Should not receive this message, fail if we do
              call assert('Unexpected msg '//mqh.name, .FALSE.)
            
            elseif (mqh.name(1:6) .EQ. 'TESTN1') then

            elseif (mqh.name(1:6) .EQ. 'TESTN2') then
c The sizeof(..) function not supported by PFC
c              call m$move(mqd, dadMsg, sizeof(dadMsg))
              call m$move(mqd, dadMsg, 24)
              status = compareHeader(mqh, 10, 3,'DAD',
     &                               'Unconfigured header')
              if (status .EQ. 0) then
                call assert_reset()
                call assert('Unconfigured data DVAL1',
     &                      (dadMsg.dval1.EQ.10.0))
                call assert('Unconfigured data AVAL',
     &                      (dadMsg.aval.EQ.'TWO'))
                call assert('Unconfigured data DVAL2',
     &                      (dadMsg.dval2.EQ.30.0))
              else
                write(*,*) 'Name ',mqh.name,' info ',mqh.info
     &                    ,' ndata ',mqh.ndata  ,' types ',mqh.types
              endif
            elseif (mqh.name .EQ. mqh_SETL.name) then
              status = compareHeader(mqh, 30, 3, 'A2L',
     &                      'Configured msg header')
              if (status.EQ.0) then
                call assert_reset()
                call assert('Object data',
     &                      (mqd.SETL.object.EQ.'NmObj'))
                call assert('Value data', (mqd.SETL.value.EQ.20))
                call assert('Value2 data', (mqd.SETL.value2.EQ.30))
                if (assert_getNumFailed().GT.0) then
                  write(*,*) 'Object "',mqd.SETL.object
                  write(*,*) 'Value  "',mqd.SETL.value
                  write(*,*) 'Value2 "',mqd.SETL.value2
                endif
              else
                write(*,*) 'Name ',mqh.name,' info ',mqh.info
     &                    ,' ndata ',mqh.ndata ,' types ',mqh.types
              endif

            else
              call m$warning('Unrecognized msg '//mqh.name)
            endif

          endif
        else
          call m$pause(0.5)
        endif
        
      enddo
      
      if(dbg)call debug('Returning')
      call M$RETURN
      end
      
!********************************************************************
      integer*4 FUNCTION compareHeader(mqhin, info, ndata, types, msg)

      implicit none

      include 'primitive.inc'
      include 'qmessdef.inc'
      include 'assert.inc'
c..   Inputs
      record /MQ_HEADER/ mqhin
      integer*4 info
      integer*4 ndata
      character*(*) types
      character*(*) msg
c..   Locals
      integer*4 status
      integer*4 lmsg
      integer*4 ltypes

      ltypes = m$length(types)
      lmsg = m$length(msg)
      call assert_reset()
      call assert(msg(1:lmsg)//'-> INFO', (mqhin.info.EQ.info))
      call assert(msg(1:lmsg)//'-> NDATA', (mqhin.ndata.EQ.ndata))
      call assert(msg(1:lmsg)//'-> TYPES', (mqhin.types.EQ.types))

      write(*,*) 'Compare header , num failed=',assert_getNumFailed()
      compareHeader = status
      end
!*********************************************************************
      subroutine debug (str)
      
      implicit none
      include 'primitive.inc'
c.. Inputs
      character*(*) str

      write(*,*) 'NM.FOR: '//str(1:M$LENGTH(str))
      end
      
      include 'assert.for'
