c**********************************************************************c
c  Description: Preliminary HOST NOOP routine this should always be
c               called as follows:
c                  /FOO/BAR=2
c
c  Author:      JPH, JC4, Neon Ngo
c**********************************************************************c
        program TEST_XBC
        implicit none
        include 'primitive.inc'
        include 'assert.inc'

        call M$CHECKIN

        call ASSERT_AUTOINIT('DEBUG','STAT')

        call M$SYNC

        call TEST_MISC()          ! Misc tests without a home
        call TEST_STRINGS()       ! String substitution, length, etc.
        call TEST_SWITCHES()      ! Test getting switches
        call TEST_RESULTS()       ! Test getting/setting results
        call TEST_FILEIO()        ! Test file I/O
        call TEST_KEYWORDS()      ! Test keyword access
        call TEST_KEYWORDS_NEXT() ! Test keyword access
        call TEST_UTILITIES()     ! Test utilties libraries
        call TEST_XFER_LENGTH()

        call M$RETURN
        call ASSERT_AUTOREPORT()
        end


c**********************************************************************c
c       Tests getting and setting results.
c         Expects a result TEST_RES_1 to exist and be equal to L:4,
c         TEST_RES_2 should not exist, and TEST_RES_3 is "abc".
c**********************************************************************c
        subroutine TEST_RESULTS()
          implicit none
          include 'primitive.inc'
          integer*4          val

          call TRY_GET_RESULT('TEST_RES_1','L',' ',4d0)
          call TRY_GET_RESULT('TEST_RES_2',' ',' ',-1d0)
          call TRY_GET_RESULT('TEST_RES_3','A','abc',3d0)
          call TRY_RFIND('TEST_RES_1','L',' ',4d0)
          call TRY_RFIND('TEST_RES_2',' ',' ',0d0)
          call TRY_RFIND('TEST_RES_3','A','abc',3d0)

          val = M$PUT_RESULT('TEST_RES_2', 'Hello', 5, 0, 'A', 0)
          call ASSERT('Testing M$PUT_RESULT for TEST_RES_2, val=5',
     &                (val .eq. 5))
          call TRY_RFIND('TEST_RES_2','A','Hello',5d0)

          call M$TRSLT('TEST_RES_SEC', 100d0, 0.42d0)
          call TRY_RFIND('TEST_RES_SEC','D',' ',100.42d0)
          call M$TRSLT('TEST_RES_WSEC|TEST_RES_FSEC', 100d0, 0.42d0)
          call TRY_RFIND('TEST_RES_WSEC','D',' ',100d0)
          call TRY_RFIND('TEST_RES_FSEC','D',' ',0.42d0)
          call M$TRSLT('A:TEST_RES_SEC', 100d0, 0.42d0)
          call TRY_RFIND('TEST_RES_SEC','A','00:01:40.420000',15d0)
          call M$TRSLT('TV:TEST_RES_SEC', 100d0, 0.42d0)
          call TRY_RFIND('TEST_RES_SEC','A',
     &                   '01-JAN-1950:00:01:40.420000',27d0)


          call TRY_RFIND('TEST_RES_2','A','Hello',5d0)

          call M$RCAST('D', 'TEST_RES_4', 3.14d0)
          call TRY_RFIND('TEST_RES_4','D',' ',3.14d0)
          call M$RCAST('D', 'TEST_RES_4', 3d0)
          call TRY_RFIND('TEST_RES_4','D',' ',3d0)
          call M$RCAST('F', 'TEST_RES_4', 3d0)
          call TRY_RFIND('TEST_RES_4','F',' ',3d0)
          call M$RCAST('X', 'TEST_RES_4', 3.14d0)
          call TRY_RFIND('TEST_RES_4','X',' ',3d0)
          call M$RCAST('L', 'TEST_RES_4', 3.14d0)
          call TRY_RFIND('TEST_RES_4','L',' ',3d0)
          call M$RCAST('I', 'TEST_RES_4', 3.14d0)
          call TRY_RFIND('TEST_RES_4','I',' ',3d0)
          call M$RCAST('B', 'TEST_RES_4', 3.14d0)
          call TRY_RFIND('TEST_RES_4','B',' ',3d0)

          val = M$STR2RESULT('D:TEST_RES_4', '3.14', 0)
          call ASSERT('Testing M$STR2RESULT for TEST_RES_4, val=5',
     &                (val .eq. 4))
          call TRY_RFIND('TEST_RES_4','D',' ',3.14d0)

        end

c**********************************************************************c
c       Calls M$RFIND and tests its return values.
c       @param name  Name of the result to find.
c       @param etype Expected type.
c       @param eaval Expected ASCII value.
c       @param edval Expected double value.
c**********************************************************************c
        subroutine TRY_RFIND(name,etype,eaval,edval)
          implicit none
          include 'primitive.inc'

          character*(*)           name
          character*1             etype
          character*(*)           eaval
          real*8                  edval
          character*1             atype
          character*(L_max_ascii) aaval
          real*8                  adval
          character*(L_max_ascii) str
          character*(L_max_ascii) num
          integer*4               lstr
          integer*4               lnum
          integer*4               lestr
          integer*4               lastr

          str  = 'Testing M$RFIND for '//name(1:M$LENGTH(name))
          lstr = M$LENGTH(str)
          lnum = M$D2A(edval,num)

          atype = M$RFIND(name, aaval, adval)
          call ASSERT(str(1:lstr)//' type='//etype,
     &                (atype.eq.etype))

          if (etype .eq. atype) then
            if (etype .ne. ' ') then
              call ASSERT(str(1:lstr)//' dval='//num(1:lnum),
     &                    (edval .eq. adval))
            endif
            if (etype .eq. 'A') then
              lestr = NINT(edval)
              lastr = NINT(adval)
              call ASSERT(str(1:lstr)//' aval='//eaval(1:lestr),
     &              (lestr .eq. lastr) .and.
     &              (eaval(1:lestr) .eq. aaval(1:lastr)))
            endif
          endif
        end

c**********************************************************************c
c       Calls M$RFIND and tests its return values.
c       @param name  Name of the result to find.
c       @param etype Expected type.
c       @param eaval Expected ASCII value.
c       @param edval Expected double value.
c**********************************************************************c
        subroutine TRY_GET_RESULT(name,etype,eaval,edval)
          implicit none
          include 'primitive.inc'

          character*(*)           name
          character*1             etype
          character*(*)           eaval
          real*8                  edval
          character*1             atype
          character*(L_max_ascii) str
          character*(L_max_ascii) num
          integer*4               lstr
          integer*4               lnum

          integer*4 L_bbuf
          parameter (L_bbuf=L_cmd_chars)
          include 'buffers.inc'
          record /BUFFER/    buf
          integer*4          lbuf
          character*1        type
          integer*4          attrmask

          str  = 'Testing M$GET_RESULT for '//name(1:M$LENGTH(name))
          lstr = M$LENGTH(str)
          lnum = M$D2A(edval,num)

          lbuf = M$GET_RESULT(name,buf,L_bbuf,0,atype,attrmask)
          call ASSERT(str(1:lstr)//' type='//etype,
     &                (atype.eq.etype))

          if (etype .eq. atype) then
            if (etype .eq. ' ') then
              call ASSERT(str(1:lstr)//' lbuf=<0',(lbuf .lt. 0))
            elseif (etype .eq. 'D') then
              call ASSERT(str(1:lstr)//' lbuf=8',(lbuf .eq. 8))
              call ASSERT(str(1:lstr)//' val='//num(1:lnum),
     &                    (buf.dbuf(1) .eq. edval))
            elseif (etype .eq. 'F') then
              call ASSERT(str(1:lstr)//' lbuf=4',(lbuf .eq. 4))
              call ASSERT(str(1:lstr)//' val='//num(1:lnum),
     &                    (buf.fbuf(1) .eq. edval))
            elseif (etype .eq. 'L') then
              call ASSERT(str(1:lstr)//' lbuf=4',(lbuf .eq. 4))
              call ASSERT(str(1:lstr)//' val='//num(1:lnum),
     &                    (buf.lbuf(1) .eq. edval))
            elseif (etype .eq. 'I') then
              call ASSERT(str(1:lstr)//' lbuf=2',(lbuf .eq. 2))
              call ASSERT(str(1:lstr)//' val='//num(1:lnum),
     &                    (buf.ibuf(1) .eq. edval))
            elseif (etype .eq. 'B') then
              call ASSERT(str(1:lstr)//' lbuf=1',(lbuf .eq. 1))
              call ASSERT(str(1:lstr)//' val='//num(1:lnum),
     &                    (buf.bbuf(1) .eq. edval))
            elseif (etype .eq. 'A') then
              call ASSERT(str(1:lstr)//' lbuf='//num(1:lnum),
     &                    (lbuf .eq. edval))
              call ASSERT(str(1:lstr)//' val='//eaval(1:lbuf),
     &                    (buf.abuf(1)(1:lbuf) .eq. eaval(1:lbuf)))
            endif
          endif
        end

c**********************************************************************c
c       Tests keywords. Takes in a message and then expected/actual
c       pairs of value, key, buffer, type.
c**********************************************************************c
        subroutine TEST_KEYWORD(msg,eval,aval,ekey,akey,ebuf,
     &                          abuf,etype,atype)
          implicit none
          include 'primitive.inc'
          character*(*) msg
          integer*4     eval
          integer*4     aval
          character*(*) ekey
          character*(*) akey
          character*(*) ebuf
          character*(*) abuf
          character*1   etype
          character*1   atype

          logical*4     status
          character*128 temp
          integer*4     ltemp

          ltemp = M$L2A(eval, temp)
          call ASSERT(msg//', val='//temp(1:ltemp), (eval .eq. aval))

          call ASSERT(msg//', type='//etype, (etype .eq. atype))

          if (aval .gt. 0 .and. eval .gt. 0) then
            status = ekey(1:M$LENGTH(ekey)) .eq. akey(1:M$LENGTH(akey))

            call ASSERT(msg//', key='//ekey(1:M$LENGTH(ekey)),status)

            status = ebuf(1:M$LENGTH(ebuf)) .eq. abuf(1:M$LENGTH(abuf))
            call ASSERT(msg//', buf='//ebuf(1:M$LENGTH(ebuf)),status)
          endif
        end


c**********************************************************************c
c       Tests keyword access.
c**********************************************************************c
        subroutine TEST_KEYWORDS()
        implicit none
        include 'primitive.inc'
        record /HEADER/         HCB
        character*10            str
        integer*4               status
        integer*4               val
        character*(L_cmd_chars) cbuf
        character*1             type

        ! Test getting and removing keywords. Note that the file
        ! is INPUT only so any changes are not written to disk.
        call M$INIT(HCB, 'ram:cone5000', ' ', ' ', 0)
        call M$OPEN(HCB, HCBF_INPUT)

        str  = 'COLOR'
        val  = M$GET_KEYWORD(HCB, str, cbuf)
        call TEST_KEYWORD('Testing M$GET_KEYWORD for COLOR',
     &                    3,val,'COLOR',str,'2.0',cbuf,'A','A')

        str = 'THICK'
        val = M$GET_KEYWORD(HCB, str, cbuf)
        call TEST_KEYWORD('Testing M$GET_KEYWORD for THICK',
     &                    3,val,'THICK',str,'1.0',cbuf,'A','A')


        str  = 'THICK'
        val  = M$DEL_KEYWORD(HCB,str)
        call assert('Testing M$DEL_KEYWORD for THICK', (val.ge.1))
        val = M$GET_KEYWORD(HCB, str, cbuf)
        call TEST_KEYWORD('Testing M$DEL_KEYWORD for THICK',
     &                    -1,val,'COLOR',str,' ',cbuf,'A','A')

        str = 'NONEXISTENT'
        val = M$GET_KEYWORD(HCB, str, cbuf)
        call TEST_KEYWORD('Testing M$GET_KEYWORD for NONEXISTENT',
     &                    -1,val,'NONEXISTENT',str,' ',cbuf,'A','A')

        str  = 'NONEXISTENT'
        val  = M$DEL_KEYDATA(HCB,str,MK_Normal)
        call assert('Testing M$DEL_KEYDATA for NONEXISTENT',(val.eq.-1))
        val = M$GET_KEYWORD(HCB, str, cbuf)
        call TEST_KEYWORD('Testing M$DEL_KEYDATA for NONEXISTENT',
     &                    -1,val,'NONEXISTENT',str,' ',cbuf,'A','A')


        str  = 'NONEXISTENT'
        val  = M$DEL_KEYWORD(HCB,str)
        call assert('Testing M$DEL_KEYWORD for NONEXISTENT',(val.eq.-1))
        val = M$GET_KEYWORD(HCB, str, cbuf)
        call TEST_KEYWORD('Testing M$DEL_KEYWORD for NONEXISTENT',
     &                    -1,val,'NONEXISTENT',str,' ',cbuf,'A','A')

        str  = 'COLOR'
        type = 'A'
        val  = M$GET_KEYDATA(HCB,str,cbuf,L_cmd_chars,
     &                       MK_Typetag,type)
        call TEST_KEYWORD('Testing M$GET_KEYDATA mode=MK_Typetag',
     &                    3,val,'D:COLOR',str,'2.0',cbuf,'A',type)

        str  = 'COLOR'
        val  = M$DEL_KEYDATA(HCB,str,MK_Normal)
        call assert('Testing M$DEL_KEYDATA for COLOR', (val.ge.1))
        val = M$GET_KEYWORD(HCB, str, cbuf)
        call TEST_KEYWORD('Testing M$DEL_KEYDATA for COLOR',
     &                    -1,val,'COLOR',str,' ',cbuf,'A','A')

c       test using string literal (constant) with mode=0 for BUG 1378
        val = M$PUT_KEYDATA(HCB, 'MYKW', 123456, 4, 0, 'L')
        call assert('Testing M$PUT_KEYDATA rtn val', (val.ge.4))
        val = M$GET_KEYWORD(HCB, 'MYKW', cbuf)
        call TEST_KEYWORD('Testing M$PUT_KEYDATA for MYKW',6,val,
     &                    'MYKW','MYKW','123456',cbuf(1:val),'L','L')

c       JC4: TODO: Still need tests for mode=MK_Typeasis, mode=MK_Main,
c            and mode=MK_Next
c
c       JC4: TODO: Add tests for PUT_KEYWORD, REPL_KEYWORD

        call M$CLOSE (HCB)

        ! Test keyword handling of read-only strings. These are
        ! special tests that would cause Signal 11 errors on some
        ! systems under NeXtMidas 2.5.0 (see Bug 1196).
        call M$INIT(HCB, 'ram:cone5000', ' ', ' ', 0)
        call M$OPEN(HCB, HCBF_INPUT)

        val  = M$GET_KEYDATA(HCB,'COLOR',cbuf,L_cmd_chars,0,'A')
        call TEST_KEYWORD('Testing M$GET_KEYDATA for COLOR',3,val,
     &                    'COLOR','COLOR','2.0',cbuf(1:val),'A','A')
        call M$CLOSE (HCB)


        ! Test scope issues
        call M$INIT(HCB,'nxm.sys.test.listtemplate.tmp',' ',' ',0)
        call M$OPEN(HCB, HCBF_INPUT)

        str    = 'COMMENT'
        cbuf   = ' '
        status = M$SCOPE_KEYWORD(HCB, 'MAIN')
        val    = M$GET_KEYWORD(HCB, str, cbuf)
        call assert('Testing set scope MAIN', (status.eq.1))
        call TEST_KEYWORD('Testing M$GET_KEYWORD for COMMENT',
     &                    24,val,'COMMENT',str,
     &                    'X-DataList template file',cbuf,'A','A')

        str    = 'COMMENT'
        cbuf   = ' '
        status = M$SCOPE_KEYWORD(HCB, 'EXT')
        val    = M$GET_KEYWORD(HCB, str, cbuf)
        call assert('Testing set scope EXT', (status.eq.1))
        call TEST_KEYWORD('Testing M$GET_KEYWORD for COMMENT',
     &                    18,val,'COMMENT',str,
     &                    'list template file',cbuf,'A','A')

        str    = 'COMMENT'
        cbuf   = ' '
        status = M$SCOPE_KEYWORD(HCB, 'SECTION=XDATALIST')
        val    = M$GET_KEYWORD(HCB, str, cbuf)
        call assert('Testing set scope SECTION=XDATALIST',(status.eq.1))
        call TEST_KEYWORD('Testing M$GET_KEYWORD for COMMENT',
     &                    -1,val,'COMMENT',str,' ',cbuf,'A','A')

        str    = 'COMMENT'
        cbuf   = ' '
        status = M$SCOPE_KEYWORD(HCB, ' ') ! A space indicates no scope
        val    = M$GET_KEYWORD(HCB, str, cbuf)
!!!      write(*,*) '-------> SCOPE " " len ',val,' ',cbuf(1:M$LENGTH(cbuf))
        call assert('Testing set scope " " status',(status.eq.1))
        call TEST_KEYWORD('Testing M$GET_KEYWORD '//
     &                    'for COMMENT SCOPE=" "',
     &                    24,val,'COMMENT',str,
     &                    'X-DataList template file',cbuf,'A','A')

        status = M$SCOPE_KEYWORD_QUIET(HCB, 'SECTION=JUNK')
        call assert('Testing set scope SECTION=JUNK',(status.eq.-1))

        call M$CLOSE (HCB)
        end

        subroutine TEST_KEYWORDS_NEXT()
        implicit none
        include 'primitive.inc'
        record /HEADER/ HCB
        integer*4 i
        integer*4 lkey, lVal,
     &            lKeyExp, lValExp
        character*(L_MAX_ASCII) keyName, keyVal,
     &                          keyNameExpect, keyValExpect
        character*1 bufType
        logical*4 assertion

        call M$INIT(HCB, 'nxm.xbc.dat.test_xbc_keywords.tmp',
     &                   ' ', ' ', 0)
        call M$OPEN(HCB, HCBF_INPUT)

        keyName = '**INIT**'
        bufType = 'A'
        lVal = M$GET_KEYDATA(HCB, keyName, keyVal, L_MAX_ASCII,
     &                        MK_Next, bufType)
        i = 1
        do while (lVal .gt. 0)
          lkey = M$LENGTH(keyName)
c          write(*,*) 'Found key ',keyName(1:lkey)
c     &              ,' # ',i
c     &              ,' type ',bufType
c     &              ,' val ',keyVal(1:lVal)
          if      (i .EQ. 1) then
            keyNameExpect = 'CREATOR'
            keyValExpect = keyVal(1:lval) ! Bypass CREATOR check
          else if (i.EQ.2 .OR. i.EQ.4) then
            keyNameExpect = 'DVAL'
            if (i.EQ.2) then
              keyValExpect = '1.0'
            else
              keyValExpect = '2.0'
            endif
          else if (i.EQ.3 .OR. i.EQ.5) then
            keyNameExpect = 'NAME'
            if (i.EQ.3) then
              keyValExpect = 'string 1'
            else
              keyValExpect = 'string 2'
            endif
          else
            write(*,*) 'TEST_XBC: M$GET_KEYDATA - '//
     &                 'unexpected number of keywords = ',i
            call assert('Testing M$GET_KEYDATA (NEXT) for '//
     &                  'expected number of keywords', (0.eq.1))
          endif
          lKeyExp = M$LENGTH(keyNameExpect)
          lValExp = M$LENGTH(keyValExpect)
c          write(*,*) 'Expected key ',keyNameExpect(1:lKeyExp)
c     &              ,' val ',keyValExpect(1:lValExp)

          if (keyName .EQ. 'CREATOR' .OR.
     &        keyName .EQ. 'DVAL'    .OR.
     &        keyName .EQ. 'NAME') then
            ! Valid keyword
            assertion = ( keyName(1:lkey).eq.keyNameExpect(1:lKeyExp)
     &                            .AND.
     &                    keyVal(1:lVal) .eq. keyValExpect(1:lValExp)
     &                  )
            call assert('Testing M$GET_KEYDATA (NEXT) for '//
     &                  'keyname/val = expected',assertion)
          else
            ! Invalid keyword name
            write(*,*) 'TEST_XBC: found unexpected keyword ',
     &                 keyName(1:lkey)
            call assert('Testing GET_KEYDATA for unknown keyword',
     &                 (0.eq.1))
          endif
          lVal = M$GET_KEYDATA(HCB, keyName, keyVal, L_MAX_ASCII,
     &                          MK_Next, bufType)
          i = i + 1
        enddo
        call M$CLOSE (HCB)
        end
c**********************************************************************c
c       Tests file access.
c**********************************************************************c
        subroutine TEST_FILEIO()
          implicit none
          include 'primitive.inc'
          integer*4 L_bbuf
          parameter (L_bbuf=L_cmd_chars)
          include 'buffers.inc'
          record /BUFFER/         buffer
          record /HEADER/         HCB
          character*(L_max_ascii) fname0
          character*(L_max_ascii) fname1
          character*(L_max_ascii) fname2
          character*(L_max_ascii) fname3
          character*(L_max_ascii) fname4
          character*(L_max_ascii) fname5
          character*(L_max_ascii) fname6
          character*(L_max_ascii) fnameA
          character*(L_max_ascii) fnameBlank
          character*(L_max_ascii) fnameExists
          character*(L_max_ascii) fnameNoExist
          character*(L_max_ascii) fullname
          integer*4               len
          integer*4               index
          logical*4               init
          real*8                  expected

          fname1 = 'ram:temp_test_xbc'
          fname2 = 'ram:test3000_ieee'
          fname3 = 'ram:test3000_eeei'
          fname4 = 'ram:world'
          fname5 = 'ram:apenny'
          fname6 = 'ram:apenny2'
          fnameA = 'cone5000'

c         Try the basic file opening tests twice. The first with
c         M$INIT being called (init=.true.) and then without it
c         being called (init=.false.).
          init = .true.
          call TRY_OPEN(fname1,'2000','VD',.false.,3,init,2000,'VD',0d0,1d0)
          call TRY_OPEN(fname2,' ',   ' ', .true.,3,init,3000,'NH',0d0,1d0)
          call TRY_OPEN(fname3,' ',   ' ', .true.,3,init,3000,'NH',0d0,1d0)
          call TRY_OPEN(fname4,'1000','CF',.true.,1,init,1999,'CF',1d0,1d0)
          call TRY_OPEN(fname4,'1000','CF',.true.,2,init,1999,'CF',1d0,1d0)
          call TRY_OPEN(fname5,'2000','SB',.true.,1,init,2000,'SB',0d0,1d0)
          call TRY_OPEN(fname5,'2000','SB',.true.,2,init,2000,'SB',0d0,1d0)

          init = .false.
          call TRY_OPEN(fname1,'2000','VD',.false.,3,init,2000,'VD',0d0,1d0)
          call TRY_OPEN(fname2,' ',   ' ', .true.,3,init,3000,'NH',0d0,1d0)
          call TRY_OPEN(fname3,' ',   ' ', .true.,3,init,3000,'NH',0d0,1d0)
          call TRY_OPEN(fname4,'1000','CF',.true.,1,init,1999,'CF',1d0,1d0)
          call TRY_OPEN(fname4,'1000','CF',.true.,2,init,1999,'CF',1d0,1d0)
          call TRY_OPEN(fname5,'2000','SB',.true.,1,init,2000,'SB',0d0,1d0)
          call TRY_OPEN(fname5,'2000','SB',.true.,2,init,2000,'SB',0d0,1d0)

          fnameBlank   = ''
          fnameExists  = 'nxm.sys.dat.apenny.prm'
          fnameNoExist = 'nxm.sys.dat.nonexistant.prm'
          call TRY_OPEN_OPTIONAL (fnameExists,  .true.)
          call TRY_OPEN_OPTIONAL (fnameBlank,   .false.)

          call TRY_OPEN_NOABORT  (fnameExists,  .true.)
          call TRY_OPEN_NOABORT  (fnameNoExist, .false.)

          call TEST_INOK_OPTIONAL()

          ! Check M$EXISTENCE when file is already open.
          !
          ! Duy found this bug (Bug 688) he was doing the following:
          !   m$open(hcb,...)
          !   m$existence(hcb,...)
          !   m$filad(hcb,...)
          ! After the call to M$EXISTENCE the M$FILAD did not work.
          len = M$LENGTH(fname6)
          call M$INIT(HCB, fname6(1:len), ' ', ' ', 0)
          call M$OPEN(HCB, HCBF_APPEND)
          call M$INFO('____This will print out a warning below________')
          call M$EXISTENCE(HCB, HCBF_INPUT)
          call ASSERT('Testing M$EXISTENCE for '//fname6(1:len)
     &                //', exists', (HCB.exist))
          do index = 1,128
            buffer.bbuf(index) = index-1
          enddo
c         check hcb.offset after m$open(HCBF_APPEND) for Bug 1745
          expected = HCB.size
          call ASSERT('Testing HCB.offset after M$OPEN(HCBF_APPEND)',
     &                 HCB.offset .eq. expected)

          call M$FILAD(HCB, buffer, 1)
c         check hcb.offset after m$filad(..) for Bug 1745
          expected = expected+1
          call ASSERT('Testing HCB.offset after M$FILAD',
     &                HCB.offset .eq. expected)

c         test M$SEEK for Bug 1745
          expected = 5d0
          call M$SEEK(HCB, expected+1)
          call ASSERT('Testing HCB.offset after M$SEEK',
     &                HCB.offset .eq. expected)
          call M$CLOSE(HCB)
          ! Tests for updates to fname6 done in the macro (test_xbc.mm)


          ! Check M$EXISTENCE for a file that exists
          len = M$LENGTH(fnameA)
          call M$INIT(HCB, fnameA(1:len), ' ', ' ', 0)
          call M$EXISTENCE(HCB, HCBF_INPUT)
          call ASSERT('Testing M$EXISTENCE for '//fnameA(1:len)
     &                //', exists', (HCB.exist))
          call ASSERT('Testing M$EXISTENCE for '//fnameA(1:len)
     &                //', sets file_name',
     &               (M$LENGTH(HCB.file_name) .gt. len))
          call M$CLOSE (HCB)


          ! Check M$EXISTENCE when file is not open yet.
          len = M$LENGTH(fnameNoExist)
          call M$INIT(HCB, fnameNoExist(1:len), ' ', ' ', 0)
          call M$EXISTENCE(HCB, HCBF_INPUT)
          call ASSERT('Testing M$EXISTENCE for '//fnameNoExist(1:len)
     &                //', exists', (.not. HCB.exist))
          call M$CLOSE (HCB)

          call TRY_READ1000('test1000_ieee', 'test1000_eeei',  1d0, 8)
          call TRY_READ1000('test1000_ieee', 'test1000_eeei', 25d0, 4)

          call TRY_READ3000('test3000_ieee', 'test3000_eeei', 1d0)
          call TRY_READ3000('test3000_ieee', 'test3000_eeei', 4d0)

          call TRY_APPEND3000(fname2)
          call TRY_APPEND3000(fname3)

          call TEST_GRABT()

          ! Check some file names
! JC4: Not sure how to do a platform-independant test for this.
!          len = M$FILENAMEOPT ('dat','apenny','prm',fullname,'SYS')
!          call M$INFO('----> apenny.prm='//fullname(1:len))
!          len = M$FILENAME ('dat','apenny;SYS','prm',fullname)
!          call M$INFO('----> apenny.prm='//fullname(1:len))
        end

c**********************************************************************c
c       Called by TEST_FILEIO to test reading from a type 1000 file.
c       Both test1000_ieee and test1000_eeei are read and compared
c       against each other to make sure endianess is handled correctly.
c       Additionally, the starting read position (start) and number of
c       elements read (ngot) should be <= nget (# elements to read).
c       Since NeXtMidas 2.7.0
c**********************************************************************c
        subroutine TRY_READ1000(fname1, fname2, start, nget)
          implicit none
          include 'primitive.inc'
          integer*4 L_bbuf
          parameter (L_bbuf=L_cmd_chars)
          include 'buffers.inc'
          record /HEADER/  HCB1
          record /HEADER/  HCB2
          character*(*)    fname1
          character*(*)    fname2
          real*8           start
          real*8           expected
          integer*4        nget
          integer*4        len1
          integer*4        len2
          integer*4        ngot1
          integer*4        ngot2
          integer*4        elem
          integer*4        ii
          character*128    tempstr

          real*4           buf1(nget)
          real*4           buf2(nget)

          len1 = M$LENGTH(fname1)
          len2 = M$LENGTH(fname2)

c         read file fname1 into buf1
          call M$INIT(HCB1, fname1(1:len1), ' ', ' ', 0)
          call M$INOK(HCB1)
          call M$GRAB(HCB1, buf1, start, nget, ngot1)
          call M$CLOSE(HCB1)

c         read file fname2 into buf2
          call M$INIT(HCB2, fname2(1:len2), ' ', ' ', 0)
          call M$INOK(HCB2)
          call M$GRAB(HCB2, buf2, start, nget, ngot2)
          call M$CLOSE(HCB2)

c          print *, "READ type 1000: start=",start, "nget=",nget
c          print *, "                ngot1=",ngot1, "ngot2=",ngot2
c          print *, "     buf1=", buf1
c          print *, "     buf2=", buf2
c          print *

          call ASSERT('Testing read for '//fname1(1:len1)
     &                //', ngot <= nget', (ngot1 .le. nget))

          call ASSERT('Testing read for '//fname2(1:len2)
     &                //', ngot <= nget', (ngot2 .le. nget))

c         verify contents of read data are the same (both files)
          ii = 1
          do elem = start, (start+ngot1-1)
            write(tempstr,'(i2,f10.1,f10.1)') elem, buf1(ii), buf2(ii)
            call ASSERT("Testing read at element="//tempstr
     &                  ,( buf1(ii) .eq. buf2(ii) ) )
            ii = ii + 1
          end do

c         verify hcb.offset after M$GRAB for Bug 1745
          expected = start + ngot1 - 1
          call ASSERT('Testing HCB.offset after M$GRAB for '
     &                //fname1(1:len1), HCB1.offset .eq. expected)
          expected = start + ngot2 - 1
          call ASSERT('Testing HCB.offset after M$GRAB for '
     &                //fname2(1:len2), HCB2.offset .eq. expected)

        end

c**********************************************************************c
c       Called by TEST_FILEIO to test reading from a type 3000 file.
c       Both test3000_ieee and test3000_eeei are read and compared
c       against each other to make sure endianess is handled correctly.
c       Additionally, the starting read position (start) and number of
c       elements read (ngot) should be <= nget (# elements to read).
c       Since NeXtMidas 2.7.0
c**********************************************************************c
        subroutine TRY_READ3000(fname1, fname2, start)
          implicit none
          include 'primitive.inc'
          integer*4 L_bbuf
          parameter (L_bbuf=L_cmd_chars)
          include 'buffers.inc'
          record /HEADER/  HCB1
          record /HEADER/  HCB2
          character*(*)    fname1
          character*(*)    fname2
          real*8           start
          integer*4        nget
          integer*4        len1
          integer*4        len2
          integer*4        ngot1
          integer*4        ngot2

          character*128 temp
          integer*4 ltemp

          STRUCTURE /MYREC/
            real*4 absc
            real*4 ord
            real*4 ord2
            real*4 ord3
          END STRUCTURE
          record /MYREC/ buf1
          record /MYREC/ buf2

          nget = 1
          len1 = M$LENGTH(fname1)
          len2 = M$LENGTH(fname2)

          call M$INIT(HCB1, fname1(1:len1), ' ', ' ', 0)
          call M$INOK(HCB1)
          call M$GRAB(HCB1, buf1, start, nget, ngot1)
          call M$CLOSE(HCB1)

          call M$INIT(HCB2, fname2(1:len2), ' ', ' ', 0)
          call M$INOK(HCB2)
          call M$GRAB(HCB2, buf2, start, nget, ngot2)
          call M$CLOSE(HCB2)

c          print *, "READ type 3000: start=",start, "nget=",nget
c          print *, "                ngot1=",ngot1, "ngot2=",ngot2
c          print *, "     buf1=", buf1
c          print *, "     buf2=", buf2
c          print *

          call ASSERT('Testing read for '//fname1(1:len1)
     &                //', ngot <= nget', (ngot1 .le. nget))

          call ASSERT('Testing read for '//fname2(1:len2)
     &                //', ngot <= nget', (ngot2 .le. nget))

c         verify read data are the same (to both endian files)
          call ASSERT("Testing read sub-record, absc"
     &               ,(buf1.absc .eq. buf2.absc))
          call ASSERT("Testing read sub-record, ord"
     &               ,(buf1.ord .eq. buf2.ord))
          call ASSERT("Testing read sub-record, ord2"
     &               ,(buf1.ord2 .eq. buf2.ord2))
          call ASSERT("Testing read sub-record, ord3"
     &               ,(buf1.ord3 .eq. buf2.ord3))

        end

c**********************************************************************c
c       Called by TEST_FILEIO to test appending to a file expects to
c       add a record to the end of test3000_ieee or test3000_eeei.
c**********************************************************************c
        subroutine TRY_APPEND3000(fname)
          implicit none
          include 'primitive.inc'
          integer*4 L_bbuf
          parameter (L_bbuf=L_cmd_chars)
          include 'buffers.inc'
          record /HEADER/  HCB
          record /HEADER/  HCB2
          character*(*)    fname
          integer*4        len
          integer*4        ngot

          character*128 temp
          integer*4 ltemp

          STRUCTURE /MYREC/
            real*4 absc
            real*4 ord
            real*4 ord2
            real*4 ord3
          END STRUCTURE
          record /MYREC/ buf1
          record /MYREC/ buf2
          record /MYREC/ expect

          expect.absc = 10d0
          expect.ord  = 2.2d4
          expect.ord2 = 3.3d-3
          expect.ord3 = -4.4d8

c         need to copy expected/insert data into buf1 b/c M$FILAD can
c         convert data buffer rep from machine endian to file's data rep
c         and/or reformat the data buffer in place
          buf1 = expect

          len = M$LENGTH(fname)

c          print *, "Appending (write) to ", fname(1:len)
c          print *, "  buf1=", buf1
c          print *

          call M$INIT(HCB, fname(1:len), ' ', ' ', 0)
          call M$INOKW(HCB)
          call M$HCBFUNC(HCB, HCBF_APPEND, 0)
c         test hcb.offset after m$hcbfunc(HCBF_APPEND) for Bug 1745
          call ASSERT('Testing HCB.offset after M$HCBFUNC(HCBF_APPEND)',
     &              HCB.offset .eq. HCB.size)
          call M$FILAD(HCB, buf1, 1)
          call M$CLOSE(HCB)

          HCB.xfer_len = 4
          HCB.cons_len = 4
          HCB.buf_type = 'F'

c         need to make sure ngot is NOT -1 (otherwise M$GRAB will NOT
c         update ngot and cause test case to fail)
          ngot = 0

          call M$INIT(HCB2, fname(1:len), ' ', ' ', 0)
          call M$INOK(HCB2)
c         read last element in file (HCB2.size) to buf2
          call M$GRAB(HCB2, buf2, HCB2.size, 1, ngot)
          call M$CLOSE(HCB2)

c          print *, "DEBUG: ngot=", ngot
c          print *, " write buf1=", buf1
c          print *, "  read buf2=", buf2
c          print *, "   expected=", expect
c          print *

          call ASSERT('Testing HCBF_APPEND for '//fname(1:len)
     &                //', ngot', (ngot .eq. 1))
          if (ngot .eq. 1) then
          call ASSERT('Testing HCBF_APPEND for '//fname(1:len)
     &                //', absc', (expect.absc .eq. buf2.absc))
          call ASSERT('Testing HCBF_APPEND for '//fname(1:len)
     &                //', ord', (expect.ord .eq. buf2.ord))
          call ASSERT('Testing HCBF_APPEND for '//fname(1:len)
     &                //', ord2', (expect.ord2 .eq. buf2.ord2))
          call ASSERT('Testing HCBF_APPEND for '//fname(1:len)
     &                //', ord3', (expect.ord3 .eq. buf2.ord3))
          endif

        end

c**********************************************************************c
c       Test M$GRABT - Bug 1495
c       NTN: updated to test HEADER.offset (Bug 1745)
c**********************************************************************c
        subroutine TEST_GRABT()
          implicit none
          include 'primitive.inc'
          record /HEADER/  HCB, HCBT
          integer*4 nget, ngot, i
c         test case only covers reading the 1st 3 elements of test file
          parameter (nget=3)
          character*3 tmpstr
          real*4      elp3
          real*8      start
          real*8      expected

          STRUCTURE /MYREC/
            integer*4 pos1
            integer*4 pos2
            integer*4 pos3
            real*4 elp1
            real*4 elp2
            real*4 elp3
            character*8 name
          END STRUCTURE
          record /MYREC/ buf(nget)

          HCB.file_name = 'ellipseflags5000'
          call M$INIT(HCB, HCB.file_name, ' ', ' ', 0)
          call M$OPEN(HCB, HCBF_INPUT)

          call M$INITIALIZE(HCBT)
          HCBT.type = 5001
          call M$ADDCOMP(HCBT, 'POS',  'VL', 6, 5)
          call M$ADDCOMP(HCBT, 'ELPS', 'VF', 0, 0)
          call M$ADDCOMP(HCBT, 'NAME', '1A', 0, 0)
          start = 1d0

          call M$INFO('____This may print an ERROR below______________')
          call M$GRABT(HCB, buf, start, nget, ngot, HCBT)

          call M$CLOSE(HCB)

c          print *, 'ngot=',ngot,'nget=',nget,'offset=',HCB.offset
c          print *, 'buf=', buf
          elp3 = 0
          do i = 1, ngot
           if (i .gt. 1) then
             elp3 = elp3 + 15
           endif
           write(tmpstr,'(i2)') i
           call ASSERT('Testing M$GRABT elem'//tmpstr//'subrecord POS',
     &           (0 .eq. buf(i).pos1) .and. (0 .eq. buf(i).pos1)
     &                                .and. (45 .eq. buf(i).pos3))
           call ASSERT('Testing M$GRABT elem'//tmpstr//'subrecord ELPS',
     &          (300000 .eq. buf(i).elp1) .and. (70000 .eq. buf(i).elp2)
     &                                    .and. (elp3 .eq. buf(i).elp3))
           call ASSERT('Testing M$GRABT elem'//tmpstr//'subrecord NAME',
     &          ('TONY' .eq. buf(i).name))
          enddo

c         test hcb.offset after m$grabt for Bug 1745
          expected = start + ngot - 1
          call ASSERT('Testing HCB.offset after M$GRABT',
     &                HCB.offset .eq. expected)
        end

c**********************************************************************c
c       Tests file with M$INOK (mode=1), M$INOKW (mode=2),
c       M$OPEN for input/noabort (mode=3)
c**********************************************************************c
        subroutine TRY_OPEN(fname,types,formats,open,mode,init,
     &                      type,format,xstart,xdelta)
          implicit none
          include 'primitive.inc'
          character*(*) fname
          character*(*) types
          character*(*) formats
          logical*4     open
          integer*4     mode
          logical*4     init
          integer*4     type
          character*2   format
          real*8        xstart
          real*8        xdelta

          record /HEADER/ HCB
          character*128   modestr
          integer*4       lmodestr
          character*128   str
          integer*4       lstr

          if (init) then
            call M$INIT(HCB, fname, types, formats, 0)
          else
            HCB.file_name    = fname
            HCB.format_allow = formats
            HCB.type_allow   = types
          endif

          if (mode .eq. 1) then
            call M$INOK(HCB)
            modestr  = 'M$INOK'
            lmodestr = 6
          elseif (mode .eq. 2) then
            call M$INOKW(HCB)
            modestr  = 'M$INOKW'
            lmodestr = 7
          elseif (mode .eq. 3) then
            call M$OPEN(HCB,HCBF_INPUT+HCBF_NOABORT)
            modestr  = 'M$OPEN'
            lmodestr = 6
          else
            call m$error('TRY_OPEN: unknown mode.')
          endif

          str  = 'Testing '//modestr(1:lmodestr)//' for '
     &           //fname(1:M$LENGTH(fname))//','
          lstr = M$LENGTH(str)

          call ASSERT(str(1:lstr)//' opened', (HCB.open.eqv.open))
          if ((HCB.open.eqv.open) .and. (open .eqv. .true.)) then
            call ASSERT(str(1:lstr)//' type',  (HCB.type.eq.type))
            call ASSERT(str(1:lstr)//' format',(HCB.format.eq.format))
            call ASSERT(str(1:lstr)//' xstart',(HCB.xstart.eq.xstart))
            call ASSERT(str(1:lstr)//' xdelta',(HCB.xdelta.eq.xdelta))
          endif

          call M$CLOSE (HCB)
        end

c**********************************************************************c
c       Tests file with M$OPEN with OPTIONAL flag/switch.
c**********************************************************************c
        subroutine TRY_OPEN_OPTIONAL(fname,open)
          implicit none
          include 'primitive.inc'
          character*(*)   fname
          integer*4       open
          integer*4       len
          record /HEADER/ HCB

          ! Open using OPTIONAL flag
          len = M$LENGTH(fname)
          call M$INIT(HCB, fname(1:len), ' ', ' ', 0)
          call M$OPEN(HCB, HCBF_INPUT+HCBF_OPTIONAL)
          call ASSERT('Testing M$OPEN optional flag "'
     &                //fname(1:len)
     &                //'", open', (open.EQV.HCB.open))
          call ASSERT('Testing M$OPEN optional flag "'
     &                //fname(1:len)
     &                //'", mc.break', (.NOT.mc.break))
          call M$CLOSE(HCB)

          ! Open using OPTIONAL switch
          len = M$LENGTH(fname)
          call M$INIT(HCB, fname(1:len), ' ', ' ', 0)
          HCB.switch = 'OPTIONAL'
          call M$OPEN(HCB, HCBF_INPUT)
          call ASSERT('Testing M$OPEN optional switch "'
     &                //fname(1:len)
     &                //'", open', (open.EQV.open))
          call ASSERT('Testing M$OPEN optional switch "'
     &                //fname(1:len)
     &                //'", mc.break', (.NOT.mc.break))
          call M$CLOSE(HCB)
        end

c**********************************************************************c
c       Tests file with M$OPEN with NOABORT flag.
c**********************************************************************c
        subroutine TRY_OPEN_NOABORT(fname,open)
          implicit none
          include 'primitive.inc'
          character*(*)   fname
          integer*4       open
          integer*4       len
          record /HEADER/ HCB

          ! Open using NOABORT flag
          len = M$LENGTH(fname)
          call M$INIT(HCB, fname(1:len), ' ', ' ', 0)
          call M$OPEN(HCB, HCBF_INPUT+HCBF_NOABORT)
          call ASSERT('Testing M$OPEN no abort flag "'
     &                //fname(1:len)
     &                //'", open', (open.EQV.HCB.open))
          call ASSERT('Testing M$OPEN no abort flag "'
     &                //fname(1:len)
     &                //'", mc.break', (.NOT.mc.break))
          call M$CLOSE(HCB)
        end

c**********************************************************************c
c       Test for Bug 1515 M$INOK with HCB.switch = 'OPTIONAL switch
c       should NOT print a warning message for blank/null file_name.
c       It should still print warning for non-existent filenames.
c       Since NeXtMidas 2.7.0
c**********************************************************************c
        subroutine TEST_INOK_OPTIONAL()
          implicit none
          include 'primitive.inc'
          record /HEADER/ HCB

c         set switch='OPTIONAL and blank filename for test case
          HCB.switch = 'OPTIONAL'
          HCB.file_name = ' '
          HCB.type_allow = ' '
          HCB.format_allow = ' '

          call M$INFO('This should NOT WARN that M$INOK could not open'
     &               //' file.')
          call M$INOK(HCB)
          call ASSERT('M$INOK with blank filename and switch="OPTIONAL"'
     &               //', HCB.open is false', (.not. HCB.open))
          call M$CLOSE(HCB)

c         make sure, nonexisting filename still print warning
          HCB.file_name = ' test_nonexistent_filename_xyz12345.tmp '
          call M$INFO('____This should WARN that M$INOK could not open '
     &               //'file:'//HCB.file_name)
          call M$INOK(HCB)
          call ASSERT('M$INOK with non-existent filename and switch="'
     &               //'OPTIONAL", HCB.open is false', (.not. HCB.open))
          call M$CLOSE(HCB)
        end

c**********************************************************************c
c       Tests getting switches
c**********************************************************************c
        subroutine TEST_SWITCHES()
          implicit none
          include 'primitive.inc'

          integer*4 length
          character*(L_max_ascii) origText
          character*(L_max_ascii) newText

          call ASSERT('Testing M$GET_SWITCH  for FOO',
     &                (M$GET_SWITCH('FOO') .eqv. 1))
          call ASSERT('Testing M$GET_PSWITCH for FOO',
     &                (M$GET_PSWITCH('FOO') .eqv. 1))
          call ASSERT('Testing M$GET_SSWITCH for FOO',
     &                (M$GET_SSWITCH('FOO') .eqv. 1))
          call ASSERT('Testing M$GET_DSWITCH for FOO',
     &                (M$GET_DSWITCH('FOO') .eq. 1))
          call ASSERT('Testing M$GET_SWITCH  for BAR',
     &                (M$GET_SWITCH('BAR') .eqv. 2))
          call ASSERT('Testing M$GET_PSWITCH for BAR',
     &                (M$GET_PSWITCH('BAR') .eqv. 1))
          call ASSERT('Testing M$GET_DSWITCH for BAR',
     &                (M$GET_DSWITCH('BAR') .eq. 2))
          call ASSERT('Testing M$GET_SWITCH  for BAZ',
     &                (M$GET_SWITCH('BAZ') .eqv. -1))
          call ASSERT('Testing M$GET_PSWITCH for BAZ',
     &                (M$GET_PSWITCH('BAZ') .eqv. 0))
          call ASSERT('Testing M$GET_SSWITCH for BAZ',
     &                (M$GET_SSWITCH('BAZ') .eqv. 0))
          call ASSERT('Testing M$GET_DSWITCH for BAZ',
     &                (M$GET_DSWITCH('BAZ') .eq. -1))


          call ASSERT('Testing M$GET_SWITCH_DEF  for FOO',
     &                (M$GET_SWITCH_DEF('FOO', 7) .eqv. 1))
          call ASSERT('Testing M$GET_SSWITCH_DEF for FOO',
     &                (M$GET_SSWITCH_DEF('FOO', 0) .eqv. 1))
          call ASSERT('Testing M$GET_DSWITCH_DEF for FOO',
     &                (M$GET_DSWITCH_DEF('FOO', 7d0) .eq. 1))
          call ASSERT('Testing M$GET_SWITCH_DEF  for BAR',
     &                (M$GET_SWITCH_DEF('BAR', 7) .eqv. 2))
          call ASSERT('Testing M$GET_DSWITCH_DEF for BAR',
     &                (M$GET_DSWITCH_DEF('BAR', 7d0) .eq. 2))
          call ASSERT('Testing M$GET_SWITCH_DEF  for BAZ',
     &                (M$GET_SWITCH_DEF('BAZ', 7) .eqv. 7))
          call ASSERT('Testing M$GET_SSWITCH_DEF for BAZ (def val=1)',
     &                (M$GET_SSWITCH_DEF('BAZ', 1) .eqv. 1))
          call ASSERT('Testing M$GET_SSWITCH_DEF for BAZ (def val=0)',
     &                (M$GET_SSWITCH_DEF('BAZ', 0) .eqv. 0))
          call ASSERT('Testing M$GET_SSWITCH_DEF for BAZ (def val=4)',
     &                (M$GET_SSWITCH_DEF('BAZ', 4) .eqv. 4))
          call ASSERT('Testing M$GET_DSWITCH_DEF for BAZ',
     &                (M$GET_DSWITCH_DEF('BAZ', 7d0) .eq. 7))

        ! Test for a uswitch not on the command line, make sure string
        ! is unchanged and the return value is -1 (see Bug 687)
          origText = 'should not be changed'
          newText  = 'should not be changed'
          length = M$GET_USWITCH('MISSINGUSWITCH', newText)
          call ASSERT('Testing M$GET_USWITCH for missing switch, '
     &                //'length=-1', (length .eq. -1))
          call ASSERT('Testing M$GET_USWITCH for missing switch, '
     &                //'text unchanged',
     &                (origText(1:M$LENGTH(origText)) .eq.
     &                  newText(1:M$LENGTH(origText))))

        ! Test for a uswitch on the command line (defined as
        ! /USWITCH=ten where result ten=10)
          origText = 'should not be changed'
          newText  = 'should not be changed'
          length = M$GET_USWITCH('USWITCH', newText)
          call ASSERT('Testing M$GET_USWITCH for /USWITCH=TEN, '
     &                //'length=3', (length .eq. 3))
          call ASSERT('Testing M$GET_USWITCH for /USWITCH=TEN, '
     &                //'text="TEN"', (newText(1:3) .eq. 'TEN'))
          call ASSERT('Testing M$GET_DSWITCH for /USWITCH=TEN, '
     &                //'val=10', (M$GET_DSWITCH('USWITCH') .eq. 10))
        end


c**********************************************************************c
c       Compares two state values
c**********************************************************************c
        subroutine CHECK_STATE(msg,expected,actual)
          implicit none
          include 'primitive.inc'
          character*(*) msg
          logical*4     expected
          logical*4     actual

          if (expected) then
            call ASSERT(msg, .not. actual)
          else
            call ASSERT(msg, actual)
          endif
        end

c**********************************************************************c
c       Misc String (SEDIT) tests
c**********************************************************************c
        subroutine TEST_STRINGS()
          implicit none
          include 'types.inc'

          integer*4    L_STR2
          parameter (L_STR2=4)
          character*(80) in_str
          character*(80) out_str
          character*(L_STR2) out_str2
          character*(80) exp_str
          integer*4      in_len
          integer*4      out_len
          integer*4      exp_len

          call ASSERT('Testing M$LENGTH',(M$LENGTH('12345') .eq. 5))

          ! ==== M$SUBS =============================
          ! No match -> no change + trim string
          in_str  = 'The quick brown fox jumped over the lazy dog.  '
          exp_str = 'The quick brown fox jumped over the lazy dog.'
          in_len  = M$LENGTH(in_str)  + 2
          exp_len = M$LENGTH(exp_str)
          out_len = M$SUBS(in_str, out_str, 'mouse', 'buffalo')
          call ASSERT('Testing M$SUBS mouse->buffalo (len)',
     &                out_len .eq. exp_len)
          call ASSERT('Testing M$SUBS mouse->buffalo (str)',
     &                out_str(1:exp_len) .eq. exp_str(1:exp_len))

          ! One match -> one change + trim string
          in_str  = 'The quick brown fox jumped over the lazy dog.  '
          exp_str = 'The quick brown buffalo jumped over the lazy dog.'
          in_len  = M$LENGTH(in_str)  + 2
          exp_len = M$LENGTH(exp_str)
          out_len = M$SUBS(in_str, out_str, 'fox', 'buffalo')
          call ASSERT('Testing M$SUBS fox->buffalo (len)',
     &                out_len .eq. exp_len)
          call ASSERT('Testing M$SUBS fox->buffalo (str)',
     &                out_str(1:exp_len) .eq. exp_str(1:exp_len))

          ! Two matches -> one change + trim string
          in_str  = 'The quick brown fox jumped over the lazy dog.  '
          exp_str = 'That quick brown fox jumped over the lazy dog.'
          in_len  = M$LENGTH(in_str)  + 2
          exp_len = M$LENGTH(exp_str)
          out_len = M$SUBS(in_str, out_str, 'he', 'hat')
          call ASSERT('Testing M$SUBS he->hat (len)',
     &                out_len .eq. exp_len)
          call ASSERT('Testing M$SUBS he->hat (str)',
     &                out_str(1:exp_len) .eq. exp_str(1:exp_len))


          ! ==== M$SUBSL ============================
          ! No match -> no change (don't trim string)
          in_str  = 'The quick brown fox jumped over the lazy dog.  '
          exp_str = 'The quick brown fox jumped over the lazy dog.  '
          in_len  = M$LENGTH(in_str)  + 2
          exp_len = M$LENGTH(exp_str) + 2
          out_len = M$SUBSL(in_str, in_len, out_str, 'mouse', 5,
     &                      'buffalo', 7)
          call ASSERT('Testing M$SUBSL mouse->buffalo (len)',
     &                out_len .eq. exp_len)
          call ASSERT('Testing M$SUBSL mouse->buffalo (str)',
     &                out_str(1:exp_len) .eq. exp_str(1:exp_len))

          ! One match -> one change (don't trim string)
          in_str  = 'The quick brown fox jumped over the lazy dog.  '
          exp_str = 'The quick brown buffalo jumped over the lazy dog.  '
          in_len  = M$LENGTH(in_str)  + 2
          exp_len = M$LENGTH(exp_str) + 2
          out_len = M$SUBSL(in_str, in_len, out_str, 'fox', 3,
     &                      'buffalo', 7)
          call ASSERT('Testing M$SUBSL fox->buffalo (len)',
     &                out_len .eq. exp_len)
          call ASSERT('Testing M$SUBSL fox->buffalo (str)',
     &                out_str(1:exp_len) .eq. exp_str(1:exp_len))

          ! Two matches -> one change (don't trim string)
          in_str  = 'The quick brown fox jumped over the lazy dog.  '
          exp_str = 'That quick brown fox jumped over the lazy dog.  '
          in_len  = M$LENGTH(in_str)  + 2
          exp_len = M$LENGTH(exp_str) + 2
          out_len = M$SUBSL(in_str, in_len, out_str, 'he', 2,
     &                      'hat', 3)
          call ASSERT('Testing M$SUBSL he->hat (len)',
     &                out_len .eq. exp_len)
          call ASSERT('Testing M$SUBSL he->hat (str)',
     &                out_str(1:exp_len) .eq. exp_str(1:exp_len))


          ! ==== M$GSUB =============================
          ! No match -> no change + trim string
          in_str  = 'The quick brown fox jumped over the lazy dog.  '
          exp_str = 'The quick brown fox jumped over the lazy dog.'
          in_len  = M$LENGTH(in_str) + 2
          exp_len = M$LENGTH(exp_str)
          out_len = M$GSUB(in_str, out_str, 'mouse', 'buffalo')
          call ASSERT('Testing M$GSUB mouse->buffalo (len)',
     &                out_len .eq. exp_len)
          call ASSERT('Testing M$GSUB mouse->buffalo (str)',
     &                out_str(1:exp_len) .eq. exp_str(1:exp_len))

          ! One match -> one change + trim string
          in_str  = 'The quick brown fox jumped over the lazy dog.  '
          exp_str = 'The quick brown buffalo jumped over the lazy dog.'
          in_len  = M$LENGTH(in_str)  + 2
          exp_len = M$LENGTH(exp_str)
          out_len = M$GSUB(in_str, out_str, 'fox', 'buffalo')
          call ASSERT('Testing M$GSUB fox->buffalo (len)',
     &                out_len .eq. exp_len)
          call ASSERT('Testing M$GSUB fox->buffalo (str)',
     &                out_str(1:exp_len) .eq. exp_str(1:exp_len))

          ! Two matches -> two changes + trim string
          in_str  = 'The quick brown fox jumped over the lazy dog.  '
          exp_str = 'That quick brown fox jumped over that lazy dog.'
          in_len  = M$LENGTH(in_str)  + 2
          exp_len = M$LENGTH(exp_str)
          out_len = M$GSUB(in_str, out_str, 'he', 'hat')
          call ASSERT('Testing M$GSUB he->hat (len)',
     &                out_len .eq. exp_len)
          call ASSERT('Testing M$GSUB he->hat (str)',
     &                out_str(1:exp_len) .eq. exp_str(1:exp_len))

          ! Many matches -> NO changes + trim string
          ! Note that in fortran ' ' is the same as the empty string, and
          ! in this case is ignored.
          in_str  = 'The quick brown fox jumped over the lazy dog.  '
          exp_str = 'The quick brown fox jumped over the lazy dog.'
          in_len  = M$LENGTH(in_str)  + 2
          exp_len = M$LENGTH(exp_str)
          out_len = M$GSUB(in_str, out_str, ' ', '_')
          call ASSERT('Testing M$GSUB _->_ (len)',
     &                out_len .eq. exp_len)
          call ASSERT('Testing M$GSUB _->_ (str)',
     &                out_str(1:exp_len) .eq. exp_str(1:exp_len))


          ! ==== M$GSUBL ============================
          ! No match -> no change (don't trim string)
          in_str  = 'The quick brown fox jumped over the lazy dog.  '
          exp_str = 'The quick brown fox jumped over the lazy dog.  '
          in_len  = M$LENGTH(in_str)  + 2
          exp_len = M$LENGTH(exp_str) + 2
          out_len = M$GSUBL(in_str, in_len, out_str, 'mouse', 5,
     &                      'buffalo', 7)
          call ASSERT('Testing M$GSUBL mouse->buffalo (len)',
     &                out_len .eq. exp_len)
          call ASSERT('Testing M$GSUBL mouse->buffalo (str)',
     &                out_str(1:exp_len) .eq. exp_str(1:exp_len))

          ! One match -> one change (don't trim string)
          in_str  = 'The quick brown fox jumped over the lazy dog.  '
          exp_str = 'The quick brown buffalo jumped over the lazy dog.  '
          in_len  = M$LENGTH(in_str)  + 2
          exp_len = M$LENGTH(exp_str) + 2
          out_len = M$GSUBL(in_str, in_len, out_str, 'fox', 3,
     &                      'buffalo', 7)
          call ASSERT('Testing M$GSUBL fox->buffalo (len)',
     &                out_len .eq. exp_len)
          call ASSERT('Testing M$GSUBL fox->buffalo (str)',
     &                out_str(1:exp_len) .eq. exp_str(1:exp_len))

          ! Two matches -> one change (don't trim string)
          in_str  = 'The quick brown fox jumped over the lazy dog.  '
          exp_str = 'That quick brown fox jumped over that lazy dog.  '
          in_len  = M$LENGTH(in_str)  + 2
          exp_len = M$LENGTH(exp_str) + 2
          out_len = M$GSUBL(in_str, in_len, out_str, 'he', 2,'hat', 3)
          call ASSERT('Testing M$GSUBL he->hat (len)',
     &                out_len .eq. exp_len)
          call ASSERT('Testing M$GSUBL he->hat (str)',
     &                out_str(1:exp_len) .eq. exp_str(1:exp_len))

          ! Many matches -> many changes + trim string
          in_str  = 'The quick brown fox jumped over the lazy dog.  '
          exp_str = 'The_quick_brown_fox_jumped_over_the_lazy_dog.__'
          in_len  = M$LENGTH(in_str)  + 2
          exp_len = M$LENGTH(exp_str)
          out_len = M$GSUBL(in_str, in_len, out_str, ' ', 1, '_', 1)
          call ASSERT('Testing M$GSUBL _->_ (len)',
     &                out_len .eq. exp_len)
          call ASSERT('Testing M$GSUBL _->_ (str)',
     &                out_str(1:exp_len) .eq. exp_str(1:exp_len))

c     ==== M$STRIM ============================
c     Test string and it's expected result should be longer than L_STR2
          in_str  = '   1 AbcDefGhiJklMnoPqrStuVwxYz   9   '
          exp_str = '1 AbcDefGhiJklMnoPqrStuVwxYz   9'
          in_len  = M$LENGTH(in_str) + 3
          exp_len = M$LENGTH(exp_str)
          out_len = M$STRIM(in_str, out_str)
          call ASSERT('Testing M$STRIM (len)', out_len .eq. exp_len)
          call ASSERT('Testing M$STRIM (str equals)',
     &                out_str(1:out_len) .eq. exp_str(1:exp_len))

c     test case where output string is shorter than trimmed of in_str
          out_len = M$STRIM(in_str, out_str2)
          call ASSERT('Testing M$STRIM short outstr (len)',
     &                out_len .eq. L_STR2)
          call ASSERT('Testing M$STRIM short outstr (str equals)',
     &                out_str(1:out_len) .eq. exp_str(1:L_STR2))

c     ==== M$HEAD and M$TAIL ========================
          in_str  = '/tmp/path/to/filename.ext'
          exp_str = '/tmp/path/to/'
          exp_len = M$LENGTH(exp_str)
          out_len = M$HEAD(in_str, out_str)
          call ASSERT('Testing M$HEAD (ostr len)', out_len .eq. exp_len)
          call ASSERT('Testing M$HEAD (ostr equals)',
     &                out_str(1:out_len) .eq. exp_str(1:exp_len))

          exp_str = 'filename.ext'
          exp_len = M$LENGTH(exp_str)
          out_len = M$TAIL(in_str, out_str)
          call ASSERT('Testing M$TAIL (ostr len)', out_len .eq. exp_len)
          call ASSERT('Testing M$TAIL (ostr equals)',
     &                out_str(1:out_len) .eq. exp_str(1:exp_len))
        end

c**********************************************************************c
c       Misc tests without a home
c**********************************************************************c
        subroutine TEST_MISC()
          implicit none
          include 'primitive.inc'
          character*(L_max_ascii) aval
          integer*4               len
          integer*4               val
          real*8                  dval
          real*8                  wsec, fsec
          integer*4               mvtype, mstype
          include 'parameters.inc'

          call ASSERT('Testing Mc.command_name',
     &                (Mc.command_name .eq. 'TEST_XBC'))
          call ASSERT('Testing Mu.command_name',
     &                (Mu.command_name .eq. 'TEST_XBC'))

          call ASSERT('Testing Mc.break',    (.NOT. Mc.break))
          call ASSERT('Testing Mc.pause',    (Mc.pause.eq.0.001))
          call ASSERT('Testing Mc.seed',     (Mc.seed.eq.12345678))
          call ASSERT('Testing Mc.tolerance',(Mc.tolerance.eq.1.0e-6))
          call ASSERT('Testing Mc.nformat',(Mc.nformat(1:3).eq.'GEN'))

          call ASSERT('Testing Mu.id',(Mu.id .eq. M$GET_SWITCH('ID')))
          call CHECK_STATE('Testing Mu.alert',
     &                     M$GET_PSWITCH('NOALERT'), Mu.alert)
          call CHECK_STATE('Testing Mu.warn',
     &                     M$GET_PSWITCH('NOWARN'), Mu.warn)
          call CHECK_STATE('Testing Mu.verbose',
     &                     M$GET_PSWITCH('QUIET'), Mu.verbose)

c         test that M$VINIT was called by M$CHECKIN - Bug 1506
          call MD$VTYPEQ(mvtype)
          call MD$STYPEQ(mstype)
          call ASSERT('Testing M$VINIT, MD$VTYPEQ and MD$STYPEQ',
     &                (mvtype .eq. MP_FLOAT .and. mstype .eq. MP_FLOAT))

          call M$NOW(wsec, fsec)
          call ASSERT('Testing M$NOW wsec',(wsec .gt. 1767996829d0))
          call ASSERT('Testing M$NOW fsec',(fsec .ge. 0d0))

          val = M$A2D('35e6', dval)
          call ASSERT('Testing M$A2D for 35e6',(dval .eq. 35d6))
          val = M$A2D('1K', dval)
          call ASSERT('Testing M$A2D for 1K',(dval .eq. 1024))
          val = M$D2A(3.14d0, aval)
          call ASSERT('Testing M$D2A for 35d6',(aval(1:5).eq.'3.140'))
          val = M$D2A(1024d0, aval)
          call ASSERT('Testing M$D2A for 1024',(aval(1:4).eq.'1024'))
          val = M$L2A(1024, aval)
          call ASSERT('Testing M$L2A for 1024',(aval(1:4).eq.'1024'))

          len = M$IMPORT('NMROOT', aval)
          if (aval(len:len) .ne. '/') then
            len = len + 1
            aval(len:len) = '/'
          endif
          call TRY_RFIND('ENV.NMROOT','A',aval,DBLE(len))

          len = M$GET_DEFAULT(aval)
          call TRY_RFIND('AUX.CWD','A',aval(1:len),DBLE(len))
        end

        subroutine TEST_UTILITIES()
          implicit none
          include 'primitive.inc'

c          call TEST_NPM()
          call TEST_TEST_FORMAT()
        end

c       Test case for m$npm
c       Since NeXtMidas 2.7.0
        subroutine TEST_NPM()
          implicit none
          include 'primitive.inc'
          integer*4    npm, i
          integer*4    len
          parameter(len=12)
          character*1  modes(len)
          integer*4    expected(len)
          character*10 tempstr
          character*1  ch1,ch2
          parameter(ch1=char(128))
          parameter(ch2=char(255))

          DATA (modes(i), i=1,len,1) /'S','C','V','Q','M','X','T','U',
     &                                '0','9',ch1,ch2/                   ! 3.9.3 for gfc
          DATA (expected(i), i=1,len,1) /1,2,3,4,9,10,16,1,0,9,1,128/

          do i = 1, len
            npm = M$NPM(modes(i))
            if (ichar(modes(i)) .gt. 127) then
              write(tempstr,'(i3,a,i3)') ichar(modes(i)),' = ',
     &                                   expected(i)
            else
              write(tempstr,'(a,i3)') modes(i)//' =',expected(i)
            endif
            call ASSERT('Testing M$NPM mode '//tempstr
     &                 ,(npm .eq. expected(i)))
          enddo
        end

c       Test case for m$test_format
c       Since NeXtMidas 2.7.2
        subroutine TEST_TEST_FORMAT()
          implicit none
          include 'primitive.inc'

          integer*4   i
          integer*4   numFormats
          parameter(numFormats=24)
          character*7 formats(numFormats)
          character*2 expected(numFormats)
          character*2 res

c         initialize test data and expected results
          DATA (formats(i),i=1,numFormats,1) /'SF','R*04','FLOAT','FLO',
     &      'F','REAL','SX','I*08','XLONG','XLO','X',  'SL','I*04',
     &      'LONG','LON','L',  'NH', 'COMPLEX', 'COM', 'OB01','OFFSET',
     &      'BYTE','B*01','I*01'/
          DATA (expected(i),i=1,numFormats,1) /'SF','SF','SF','SF',
     &      'SF','SF' ,'SX','SX'  ,'SX'   ,'SX' ,'SX', 'SL','SL'  ,
     &      'SL'  ,'SL' ,'SL', 'NH', 'CF'     , 'CF' , 'SO'  ,'SO',
     &      'SB'  ,'SB'  ,'SB'/

          do i = 1, numFormats
            res = M$TEST_FORMAT(formats(i),' ')
            call ASSERT('Testing M$TEST_FORMAT format '//formats(i)//
     &                  ' got '//res,(res .eq. expected(i)))
          enddo

c         test against allow list (positive - should pass)
          res = M$TEST_FORMAT('9A','#A')
          call ASSERT('Testing M$TEST_FORMAT format 9A allow=#A'//
     &                ' got '//res,(res .eq. '9A'))

          res = M$TEST_FORMAT('CF','S*,C#,V*')
          call ASSERT('Testing M$TEST_FORMAT format CF allow=C#'//
     &                ' got '//res,(res .eq. 'CF'))

          res = M$TEST_FORMAT('VX','S*,C#,V*')
          call ASSERT('Testing M$TEST_FORMAT format VX allow=V*'//
     &                ' got '//res,(res .eq. 'VX'))

c Begin test cases for invalid inputs (which will print error msgs)
          call M$INFO('____This should print out several ERROR messages'
     &              //' below________________')

c         test against allow format list (negative - should error)
          res = M$TEST_FORMAT('CD','S#')
          call ASSERT('Testing M$TEST_FORMAT format CD allow=S#'//
     &                ' got '//res,(res .eq. ''))

          res = M$TEST_FORMAT('SI','#A')
          call ASSERT('Testing M$TEST_FORMAT format SI allow=#A'//
     &                ' got '//res,(res .eq. ''))

          res = M$TEST_FORMAT('',' ')
          call ASSERT('Testing M$TEST_FORMAT format  '//
     &                ' got '//res,(res .eq. ''))

          res = M$TEST_FORMAT('BAD',' ')
          call ASSERT('Testing M$TEST_FORMAT format BAD'//
     &                ' got '//res,(res .eq. ''))

          call M$INFO('____End of several ERROR messages above_________'
     &              //'______________________')
        end

c       Test case for m$xfer_length
c       Since NeXtMidas 2.7.3
        subroutine TEST_XFER_LENGTH()
          implicit none
          include 'primitive.inc'
          integer*4  xferLength
          integer*4  bpe
          integer*4  L_buf
          parameter (L_buf=32768)

          ! Bug 1935 - zero bpe
          call M$INFO('____This will print out an ERROR below________')
          bpe = 0
          xferLength = m$xfer_length(bpe, L_buf)
          call ASSERT('Testing M$XFER_LENGTH zero bpe - Bug 1935',
     &                (xferLength .eq. 0))
        end

c**********************************************************************c
c       Include assertion facility.
c**********************************************************************c
        include 'assert.for'
