c************
c  Description: Remote Message
c
c  Author:      Jeff Schoen 12/99
c
c @author Jeff Schoen
c @version $Id: rmsg.for,v 1.6 2012/07/03 18:19:39 lmt Exp $
c
c Oct 2009 NTN
c   BUG 1991    Updated R2T method to be 64-bit safe and not to sit in
c                 tight loop if nk variable has junk value (e.g. bad
c                 command-line arguments provided)
c
c************
        program RMSG

        implicit none

        include 'primitive.inc'
        include 'qmessages.inc'
        include 'flags.inc'

        character func*8,prefix*32
        integer*4 rmifid,lp,ld,ns,ls

        STRUCTURE /PKTMSGSTRUCT/
          character*40  addr
          character*8   func
          character*(L_mqd-48) data
        ENDSTRUCTURE
        RECORD /PKTMSGSTRUCT/ pmsg

        call M$CHECKIN

        func = M$UPICK(1)
        rmifid = M$GET_SWITCH('RMIFID')
        lp = M$UAPICK(6,prefix,0)

        if (func.eq.'SEND') then

          call M$MOVE(MQH_RPKT,mqh,56)
          pmsg.addr = M$APICK(2)
          pmsg.func = M$APICK(3)
          if (lp.gt.0) then
            call R2T (prefix(1:lp),pmsg.data,ld)
          else
            ld = M$UAPICK(5,pmsg.data,UAP_TRANSLATE)
          endif
          ns = (ld+7)/8
          if (ns*8.gt.ld) pmsg.data(ld+1:ns*8) = ' '
          write(mqh.types(12:14),'(i3.3)') ld
          mqh.nslots = mqh.nhslots + 6 + ns
          call M$SEND_MSG (mqh,pmsg,rmifid,0)

        elseif (func.eq.'T2R') then

          ld = M$UAPICK(5,pmsg.data,UAP_TRANSLATE)
          call T2R (prefix(1:lp),pmsg.data,ld)

        elseif (func.eq.'R2T') then

          call R2T (prefix(1:lp),pmsg.data,ld)
          call M$ARSLT (M$UPICK(5),pmsg.data(1:ld))

        else
          call M$WARNING('Unsupported func: '//func)
        endif

        call M$SYNC
        call M$RETURN

        end


c**********************************************************************c
c Convert results to table (string format)
c**********************************************************************c
        subroutine R2T (prefix,string,ld)

        implicit none
        include 'types.inc'
        character prefix*(*),string*(*),type,label*16,cnum*4
        integer*4 ls,ld,n,nk,lc,mask
c Oct 2009 NTN: BUG 1991 64-bit support for R2T function
#if _64BIT
        integer*8 locs  ! 64-bit address
#else
        integer*4 locs  ! 32-bit address
#endif

! Oct 2009 NTN: need to init nk othersize junk value cause tight loop
        nk = 0
        locs = %loc(string)
        ls = LEN(string)
        label = 'L:'//prefix//'NK'
        lc = M$GET_RESULT(label,nk,4,0,type,mask)
        ld = 1
        string(ld:ld) = '{'
        do n = 1,nk
          lc = M$L2A(n,cnum)
          label = 'A:'//prefix//'K'//cnum
          lc = M$GET_RESULT(label,%val(locs+ld),ls-ld,0,type,mask)
          ld = ld+lc+1
          string(ld:ld) = '='
          label = 'A:'//prefix//'V'//cnum
          lc = M$GET_RESULT(label,%val(locs+ld),ls-ld,0,type,mask)
          ld = ld+lc+1
          string(ld:ld) = ','
        enddo
        string(ld:ld) = '}'

        return
        end

c**********************************************************************c
c Convert table (string format) to results
c**********************************************************************c
        subroutine T2R (prefix,string,ld)

        implicit none
        include 'types.inc'
        character prefix*(*),string*(*),type,label*16,cnum*4
        integer*4 i,j,k,ls,ld,nk,lc,len

        k = 1
        nk = 0
        len = ld
        if (string(1:1).ne.'{') then
          k = 0
          len = len+1
        endif
        do while (k .lt. len)
          nk = nk+1
          i = INDEX(string(k+1:len),'=')
          j = INDEX(string(k+1:len),',')
          if (j.eq.0) j=len-k
          if (i.eq.0) i=j
          j = max(i+1,j)
          lc = M$L2A(nk,cnum)
          ! Allowable syntax:  KEY="9", KEY=D:9, D:KEY=9, and KEY=9
          !Changes for DR 2619 to support H:/h: table syntax <begin>
          !Looking for "=" in the value part, or a leading "H:" or "h:"
          !in the key string
          if ((INDEX(string(k+i+1:k+j-1), '=').gt.0)
     &        .or.(string(k+1:k+1) .eq. 'H')
     &        .or.(string(k+1:k+1) .eq. 'h') ) then
            ! jts - xm4.8.0 was giving ERROR: bad lineno: -2>428 [IF]",
            ! if the leading "H:" was left on, so strip it off if there
            if ((string(k+1:k+1).eq.'H')
     &        .or.(string(k+1:k+1).eq.'h')) then
              call M$ARSLT(prefix//'K'//cnum(1:lc),string(k+3:k+i-1))
            else
              call M$ARSLT(prefix//'K'//cnum(1:lc),string(k+1:k+i-1))
            endif
            call M$ARSLT(prefix//'V'//cnum(1:lc),string(k+i+1:k+j-1))
          !if ((string(k+i+1:k+i+1) .eq. '"') .and.
          !Changes for DR 2619 <end>

          elseif ((string(k+i+1:k+i+1) .eq. '"') .and.
     &        (string(k+j-1:k+j-1) .eq. '"')) then
            type = 'A'
            call M$ARSLT(prefix//'K'//cnum(1:lc),string(k+1:k+i-1))
            call M$ARSLT(type//':'//prefix//'V'//cnum(1:lc),
     &                  string(k+i+2:k+j-2))

          elseif (string(k+i+2:k+i+2) .eq. ':') then
            type = string(k+i+1:k+i+1)
            call M$ARSLT(prefix//'K'//cnum(1:lc),string(k+1:k+i-1))
            call M$ARSLT(type//':'//prefix//'V'//cnum(1:lc),
     &                  string(k+i+3:k+j-1))

          elseif (string(k+2:k+2) .eq. ':') then
            type = string(k+1:k+1)
            call M$ARSLT(prefix//'K'//cnum(1:lc),string(k+3:k+i-1))
            call M$ARSLT(type//':'//prefix//'V'//cnum(1:lc),
     &                  string(k+i+1:k+j-1))
          else
            call M$ARSLT(prefix//'K'//cnum(1:lc),string(k+1:k+i-1))
            call M$ARSLT(prefix//'V'//cnum(1:lc),string(k+i+1:k+j-1))
          endif
          k = k+j
        enddo
        call M$LRSLT(prefix//'NK',nk)

        return
        end
