c************
c  Description: X-Midas APIs routines implemented in Fortran for XBC that is
c               not in another .for source file (e.g. math.for, aop.for, etc.)
c
c  Author: Jeff Schoen / J. Czechowski IV / Neon Ngo
c
c************

c*******************************************************************************
	integer*4 function M$SUBS (stringa, rtnstring, string1, string2)
c
c Substitute string2 for the first instance of string1.  Uses
c M$LENGTH to compute lengths of input strings, thus white space
c is not supported.
c
c Returns length of return string.
c
	implicit none
c Inputs
	character*(*) stringa
	character*(*) string1
	character*(*) string2
c Outputs
	character*(*) rtnstring

	integer*4 M$SUBSL

	M$SUBS = M$SUBSL (stringa,-1, rtnstring, string1,-1, string2,-1)

	end

c*******************************************************************************
	integer*4 function M$SUBSL (stringa, inls, rtnstring, string1,
     &                              inls1, string2, inls2)
c
c Same as M$SUBS, except that input of lengths on input strings
c allows support of white space
c
c Returns length of return string.
c
	implicit none

	include 'midas.inc'
c Inputs
	character*(*) stringa
	integer*4     inls     ! input length of 'stringa'
	character*(*) string1
	integer*4     inls1   ! input length of 'string1'
	character*(*) string2
	integer*4     inls2   ! input length of 'string2'
c Outputs
	character*(*) rtnstring
c Locals
	character*(L_cmd_chars) stringb, stringi
	integer*4 lsi   ! length of 'stringi'
	integer*4 ls    ! length of 'string'
	integer*4 ls1   ! length of 'string1'
	integer*4 ls2   ! length of 'string2'
	integer*4 i, j, l2 ! dummies and loop counters

	integer*4 M$LENGTH, M$SEARCH

	stringb = stringa	! local copy to work on
	ls  = inls
	ls1 = inls1
	ls2 = inls2

	if (ls .LE. 0)  ls = M$LENGTH(stringb)
	if (ls1 .LE. 0) ls1 = M$LENGTH(string1)
	if (ls2 .LE. 0) ls2 = M$LENGTH(string2)
	if (ls1 .gt. 0) then
	  i = M$SEARCH( stringb(1:ls), string1(1:ls1) )
	  if (i.gt.0) then
	    !!! ls2 = M$LENGTH(string2)
	    l2 = ls - ls1 + ls2
	    if (ls2 .gt. ls1) then
	! because sun wont copy strings backwards
	      stringi(i+ls1:ls) = stringb(i+ls1:ls)
	      stringb(i+ls2:l2) = stringi(i+ls1:ls)
	    else
	      stringb(i+ls2:l2) = stringb(i+ls1:ls)
	    endif
	    stringb(i:i+ls2-1) = string2(1:ls2)
	    ls = l2
	  endif
	endif				! if 1st string non-blank

	rtnstring = stringb(1:ls)
	M$SUBSL = ls

	end

c*******************************************************************************
	integer*4 FUNCTION M$GSUB (stringa, rtnstring, string1, string2)
c
c Global SUBStitute:  substitute string2 for every instance of string1.
c NO support for white space as input.
c
c Returns length of return string.
c
	implicit none

c Inputs
	character*(*) stringa,string1,string2
c Outputs
	character*(*) rtnstring

	integer*4 M$GSUBL

	M$GSUB=M$GSUBL (stringa,-1, rtnstring, string1,-1, string2,-1)

	end

c*******************************************************************************
	integer*4 FUNCTION M$GSUBL (stringa, inls, rtnstring, string1,
     &                              inls1, string2, inls2)
c
c Same as M$GSUB, except that input of lengths on input strings
c allows support of white space as input.

	implicit none

	include 'midas.inc'
c NTN comment out include 'types.inc' to remove warning (Bug 1681)
c	include 'types.inc'
c Inputs
	character*(*) stringa
	integer*4     inls ! input length of stringa, computed if LE 0
	character*(*) string1
	integer*4     inls1 ! input length of string1, computed if LE 0
	character*(*) string2
	integer*4     inls2 ! input length of string2, computed if LE 0
c Outputs
	character*(*) rtnstring
c Locals
	character*(L_cmd_chars) stringb, stringi
	integer*4 lsi   ! length of 'stringi'
	integer*4 ls    ! length of 'string'
	integer*4 ls1   ! local length of 'string1', computed if LE 0
	integer*4 ls2   ! local length of 'string2', computed if LE 0
	integer*4 i     ! dummies and loop counters

c NTN uncomment following declaration (Bug 1681)
	integer*4 M$LENGTH

	stringb = stringa  ! local copy
	ls  = inls   ! Copying input parameters to local vars prevents
	ls1 = inls1  ! errors if user passes explicit numbers, i.e. -1
	ls2 = inls2  ! to this routine

	if (ls .LE. 0) ls = M$LENGTH(stringb)
	if (ls1 .LE. 0) ls1 = M$LENGTH(string1)
	if (ls1 .gt. 0) then
	  if (ls2 .LE. 0) ls2 = M$LENGTH(string2)

	  stringi(1:ls) = stringb(1:ls)
	  stringi(ls+1:ls+1) = char(0) ! dont match trailing spaces
	  lsi = ls
	  i = 0
	  ls = 0
	  do while (i .lt. lsi)
	    if (string1(1:ls1) .eq. stringi(i+1:i+ls1)) then ! match
	      i = i + ls1
	      if (ls2 .gt. 0) stringb(ls+1:ls+ls2) = string2(1:ls2)
	      ls = ls + ls2
	    else
	      i = i + 1
	      ls = ls + 1
	      stringb(ls:ls) = stringi(i:i)
	    endif
	  enddo
	endif			! if 1st string is non-blank

	rtnstring = stringb(1:ls)
	M$GSUBL = ls

	end


c*******************************************************************************
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Since 2.5.0 the common Mu and Mc structures are defined in C. This
! method just sets the Fortran references to point to them. This is
! ONLY called from m$chkin(..) or m_checkin() in xmlibc.c.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	subroutine m$xbc_setcommons (ptrMc,ptrMu)
	include 'midas.inc'
	include 'types.inc'
	record /M_PTR/ ptrMc
	record /M_PTR/ ptrMu
	pMc = ptrMc.p
	pMu = ptrMu.p
	end

c*******************************************************************************
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c These two methods are pasted from commolink.for in X-Midas 3.8.3
c note that the VMS portion was removed.
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	function M$DELETE(filespec)

	character*(*) filespec
	integer*4 unlink
	integer*4 lfilespec,lname	! New DR 15181
	character*1024	name		! New DR 15181

	lfilespec = M$LENGTH(filespec)
	call M$LOWERCASE(filespec(1:lfilespec))
	call unix_fort_expand_filename( filespec , name )
	lname = M$LENGTH(name)
	if (unlink(name(1:lname)) .eq. 0) then
	  M$DELETE = 1
	else
	  M$DELETE = 0
	endif

	return
	end

c*******************************************************************************
	function M$RENAME(filespec1, filespec2)
	character*(*) filespec1, filespec2
	integer*4 rename

	lfilespec1 = M$LENGTH(filespec1)
	lfilespec2 = M$LENGTH(filespec2)

	call M$LOWERCASE(filespec1)
	call M$LOWERCASE(filespec2)

	istat = rename(filespec1(1:lfilespec1),
     &	               filespec2(1:lfilespec2))
	if (istat .eq. 0) then
	  M$RENAME = 1
	else
	  M$RENAME = 0
	endif

	return
	end

c*******************************************************************************
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c This method is pasted from commolink.for in X-Midas 3.8.3 note that
c the VMS portion was removed since XBC does not support VMS yet.
c
c JC4: I made a minor change for getting the login_path, see the code
c      marked "JC4:".
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
#if _VMS
	function M$FILE(operation,lunit,name)
        call M$ERROR('M$FILE: XBC does not support VMS at this time.')
        end
#else
	function M$FILE(operation, lunit, filename)
c
	implicit none
c
	include 'midas.inc'
	include 'types.inc'
c Arguments
	character*(*)	operation
	integer*4	lunit
	character*(*)	filename
c Locals
	character*1024	name
	character*30	errormsg
	integer*4	i, lrec
	character*11	xform
	character*7	xstatus
	logical*4	xread,xerror,xcclist,xdirect,xappend,exist

c JC4: START - Get login_path
        character*1024 login_path
c JC4: END - Get login_path

#if _PGF77|_HPUX
	integer*4	ios
#endif
c+++
c DR 5392
	integer*4 check_if_dir
c---
c
c CODE
c
	call M$LOWERCASE(filename)

	xerror = M$SEARCH(operation,'/e').ne.0

	name = filename
	call unix_fort_expand_filename( filename , name )

	if (BTEST(Mc.debug, 0)) write (*,*)
     &	  'M$FILE '//operation//' on '//
     &	  filename(1:M$LENGTHQ(filename))

	if (operation(1:4).eq.'OPEN') then

	  xform = 'FORMATTED'
	  if (M$SEARCH(operation,'/B').ne.0) xform = 'UNFORMATTED'
	  xcclist = M$SEARCH(operation,'/L').ne.0
	  xdirect = M$SEARCH(operation,'/D').ne.0
	  xappend = M$SEARCH(operation,'/A').ne.0
	  xread = M$SEARCH(operation,'/W').eq.0 .and. .not. xappend

c On the Sun, 'NEW' will error out if the file exists.  On the VAX, this
c simply creates a new ;version file, but we have to use 'UNKNOWN' here.

	  xstatus = 'UNKNOWN'
	  if (xread) xstatus = 'OLD'
	  if (M$SEARCH(operation,'/N').ne.0) xstatus = 'UNKNOWN'
	  if (M$SEARCH(operation,'/O').ne.0) xstatus = 'OLD'

	  lrec = M$SEARCH(operation,'/RL=')
	  if (lrec.gt.0) then
	    i = M$SEARCH(operation(lrec+4:),'/')
	    if (i.eq.0) i = LEN(operation) - lrec - 2
	    read(operation(lrec+4:lrec+i+2),*,err=93) lrec
	  endif

	  if (xread) then
#if _PGF77|_HPUX
	    if (xdirect) then
	      open(UNIT=lunit, FILE=name, STATUS=xstatus, FORM=xform,
     &		ACCESS='DIRECT', RECL=lrec, READONLY, err=91,IOSTAT=ios)

	    elseif (xcclist) then
	      open(UNIT=lunit, FILE=name, STATUS=xstatus, FORM=xform,
#if _HPUX
     &          READONLY, IOSTAT=ios,err=91)
#else
     &		READONLY, CARRIAGECONTROL='LIST', IOSTAT=ios,err=91)
#endif
	    else
	      open(UNIT=lunit, FILE=name, STATUS=xstatus, FORM=xform,
     &		READONLY,  IOSTAT=ios,err=91)
	    endif
#else
	    if (xdirect) then
	      open(UNIT=lunit, FILE=name, STATUS=xstatus, FORM=xform,
     &		ACCESS='DIRECT', RECL=lrec, READONLY, SHARED, err=91)
	    elseif (xcclist) then
	      open(UNIT=lunit, FILE=name, STATUS=xstatus, FORM=xform,
     &		READONLY, SHARED, CARRIAGECONTROL='LIST', err=91)
	    else
	      open(UNIT=lunit, FILE=name, STATUS=xstatus, FORM=xform,
     &		READONLY, SHARED, err=91)
	    endif
#endif
	  else
	    if (xappend) then
	      open(UNIT=lunit, FILE=name, STATUS=xstatus, FORM=xform,
     &		ACCESS='APPEND', err=91)
	    else if (xdirect) then
	      open(UNIT=lunit, FILE=name, STATUS=xstatus, FORM=xform,
     &		ACCESS='DIRECT', RECL=lrec, err=91)
	    else if (xcclist) then
	      open(UNIT=lunit, FILE=name, STATUS=xstatus, FORM=xform,
#if _HPUX
     &          err=91)
#else
     &		CARRIAGECONTROL='LIST', err=91)
#endif
	    else
	      open(UNIT=lunit, FILE=name, STATUS=xstatus, FORM=xform,
     &		err=91)
	    endif
	  endif

	elseif (operation(1:5).eq.'CLOSE') then
	  close(UNIT=lunit, err=92)

	elseif (operation(1:7).eq.'INQUIRE') then

c+++
c DR 13587
c New
#if _LINX
c JC4: START - Get login_path
c	  if (name(1:1) .eq. '~') then
c	    name = Mc.login_path(1:M$LENGTH(Mc.login_path)) // name(3:)
c	  endif
	  if (name(1:1) .eq. '~') then
            call M$ARSLT('AUX.HOME', login_path)
            name = login_path(1:M$LENGTH(login_path)) // name(3:)
	  endif
c JC4: END - Get login_path
#endif
c---
	  inquire(FILE=name, EXIST=exist)
	  if (exist) then
	    if (M$SEARCH(operation, '/NAME') .ne. 0)
     &	      inquire(FILE=name, NAME=filename)

	    M$FILE = 1
c+++
c DR 5392
#if _UNIX
	    if (check_if_dir(name) > 0.5) then
	      M$FILE = 0
	    endif
#endif
c---
	  else
	    M$FILE = 0
	  endif
	  return

	else
	  call M$ERROR('Illegal operation in M$FILE: '//operation)
	endif

	M$FILE = 1
	return

  91	M$FILE = 0
	if (xerror) return
#if _PGF77
        if (IOS .eq. 207) then
	   call M$INFO
     & ('Portland Group F77 unable to open a file twice in the same process')
        endif
#endif
	call GERROR(errormsg)
	call M$ERROR(errormsg//': Cannot open '//name)
  92	M$FILE = 0
	if (xerror) return
	call GERROR(errormsg)
	call M$ERROR(errormsg//': Cannot close '//name)
  93	call M$ERROR('Reading record length string')

	end

#endif


	function M$FILENAMEOPT (area,name,ext,fullname,opt)
	character*(*) area,name,ext,fullname,opt
	iopt = M$LENGTH(opt)
	if (iopt.le.0) then
	  M$FILENAMEOPT = M$FILENAME (area,name,ext,fullname)
	else
	  ln = M$LENGTHQ(name)
	  lo = M$SEARCH(name(1:ln),';')
	  if (lo.ne.0) ln = lo-1
	  M$FILENAMEOPT = M$FILENAME (area,name(1:ln)//';'//opt,ext,fullname)
	endif
	return
	end

c*******************************************************************************
	function M$FILENAME (given_area,name,ext,fullname)

	include 'midas.inc'
	include 'types.inc'

	character*(*) given_area,name,ext,fullname
	character*(L_max_ascii)  unxroot, area, option
	integer*4		 i,j

	area = given_area

	la = M$LENGTH(area)
	ln = M$LENGTH(name)
	le = M$LENGTH(ext)

	i = INDEX(name(1:ln),';')
	if (i.gt.0) then
	  lo = ln - i
	  if (lo.gt.0) option = name(i+1:ln)
	  ln = i-1
	else
	  lo = 0
	endif

	if (Mc.os_type(1:3) .eq. 'VMS') then
	  do i = 1, la
	    if (area(i:i) .eq. '/') area(i:i) = '.'
	  enddo
	endif

	if (name(1:1).eq.'%') then
	  la = M$LENGTHQ(Mc.home_path)
	  fullname = Mc.home_path(1:la)//name(2:ln)
	  ln = ln - 1
	elseif (M$TYPE(area).eq.1) then
	  read(area(1:la),*) laux
	  la = M$FORM_PATH(laux,Mc.read_id,fullname)
	  fullname = fullname(1:la)//name(1:ln)
	elseif (area.eq.'HOME') then
	  la = M$LENGTHQ(Mc.home_path)
	  fullname = Mc.home_path(1:la)//name(1:ln)
	elseif (area.eq.'LOGIN') then
	  la = M$LENGTHQ(Mc.login_path)
	  fullname = Mc.login_path(1:la)//name(1:ln)
	elseif (area.eq.'TEMP' .and. lo.eq.0) then
	  la = M$IMPORT('XM_TEMP',fullname)
	  if (la .le. 0) then
	    fullname = name(1:ln)
	  else
	    fullname = fullname(1:la)//name(1:ln)
	  endif
	else
	  if (area.eq.'ROOT') then
	    fullname = 'XMAREA:[000000]'
	    la = M$LENGTH(fullname)
	  else
	    fullname = 'XMAREA:['//area(1:la)//']'
	    la = la + 9
	  endif

	  if (lo.gt.0) then
	    j = INDEX(option(1:lo),'$')
	    if (j.eq.0) j = INDEX(option(1:lo),'.')
	    if (j.eq.0) then
	      fullname = 'XMAREA_'//option(1:lo)//fullname(7:la)//
     &		name(1:ln)
	    else   ! peel extension off end of option string
	      fullname = 'XMAREA_'//option(1:j-1)//fullname(7:la)//
     &		name(1:ln)//option(j:lo)
	    endif
	    la = la + lo + 1
	  else
	    fullname = fullname(1:la)//name(1:ln)
	  endif
	endif

	lf = la + ln
	if (le.gt.0) then
	  lf = lf + le + 1
	  fullname(lf-le:lf) = '.'//ext(1:le)
	endif
c
c 1 exception
	if (Mc.os_type(1:3).ne.'VMS') then
	  i = M$SEARCH(fullname,':[')
	  if (i.gt.0) then
	    lunx = M$IMPORT (fullname(1:i-1),unxroot)
	    if (lunx .le. 0) call M$ERROR
     &		('Option '//fullname(8:i-1)//' is not defined')
	    if (fullname(i+1:i+8).eq.'[000000]') i = i+7
	    fullname = unxroot(1:lunx)//'/'//fullname(i+2:lf)
	    lf = lf - i + lunx
	    i = M$SEARCH(fullname,']')
	    if (i.gt.0) fullname(i:i) = '/'
	  endif
	  ! AVL DR 3342
	  i = M$SEARCH(fullname,'$')
	  if (i.gt.0) then		! if the path contains a dollar sign
             Do While (i.gt.0)
	        j = M$SEARCH(fullname(i:lf),'/')
	        i = M$SEARCH(fullname(i+1:lf),'$')
                if ((i.gt.0) .and. (j.gt.0)) then
                   call M$LOWERCASE(fullname(j:i))
	        elseif (j.gt.0) then
                   call M$LOWERCASE(fullname(j:lf))
	        endif
             enddo
c	    i = M$SEARCH(fullname,'/')  ! find out where the first slash is
c	    if (i.gt.0) then		! if there is a slash just lower case from
c	      call M$LOWERCASE(fullname(i:lf))	! the first slash to the end of the string
c	    endif
	  else
	    call M$LOWERCASE(fullname(1:lf))
	  endif
	endif

	M$FILENAME = lf
	return
	end

c*******************************************************************************
c       TODO implement this in C or Java
        function M$_PICK (n, aval, dval)
        implicit none
c
        include 'midas.inc'
        include 'types.inc'
c Arguments
        integer*4       n
        character*(*)   aval
        real*8          dval
c Locals
        character*1     type, picktype
        integer*4       lparse
        integer*4       i, j
c
c CODE
c
        M$_PICK  = ' '
        picktype = ' '
        dval = 0
c        lparse = M$PARSE(Mc.command_string,n+1,aval)
        if (lparse .eq. 0) return
        if (iabs(lparse) .gt. LEN(aval)) call M$WARNING
     &    ('Argument truncated in M$_PICK')
c
c Test for the cases:
c 1. ASCII quoted string (ASCII literal)
c 2. possible results parameter
c    a. ASCII literal (unquoted, looks like possible result name)
c    b. valid ASCII or numeric result (arguments echoed back out from RFIND)
c 3. possible in-line calculation (try M$A2D)
c 4. ASCII literal (unquoted)

        if (lparse .lt. 0) then ! quoted string
          picktype = ' '
          dval = -lparse        ! report string length

        else if (M$RGOOD(aval(1:lparse), type, i, j)) then
          picktype = M$RFIND(aval(1:j)//' ', aval, dval)
          if (picktype .eq. ' ') dval = lparse

        else if (M$A2D(aval, dval).gt.0) then
          aval = ' '
          picktype = 'D'

        else
          dval = lparse         ! report original string length

        endif
c
        M$_PICK = picktype
        return
        end

