KJ135
/
ISCE_INSAR
mirror of http://172.16.0.12:5000/WBJY/ISCE_INSAR.git
4
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
ISCE_INSAR/components/isceobj/Util/src/rdf_reader.F

5383 lines
130 KiB
Fortran
Raw Blame History

c****************************************************************
character*(*) function rdfversion()
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
call rdf_trace('RDFVERSION')
rdfversion = a_version
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_init(a_data)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_data
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i
integer i_lun
integer i_iostat
integer i_tabs(10)
integer i_val
character*320 a_vals(100)
character*320 a_keyw
character*320 a_valu
character*320 a_unit
character*320 a_dimn
character*320 a_elem
character*320 a_oper
character*320 a_cmnt
character*320 a_errtmp
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
character*320 rdftrim
external rdftrim
character*320 rdfupper
external rdfupper
c DATA STATEMENTS:
data i_errflag / 1, 0, 0 /
data i_error / 0 /
data a_errfile / 'message' /
data i_fsizes / 40, 10, 6, 4, 4, 11, 3, 0, 0, 0/
data i_prelen / 0 /
data i_suflen / 0 /
data i_stack / 0 /
data a_prefix / ' ' /
data a_suffix / ' ' /
data a_prfx / ' ' /
data a_sufx / ' ' /
data a_intfmt / 'i' /
data a_realfmt / 'f' /
data a_dblefmt / '*' /
data a_cmdl(0) / '!' /
data a_cmdl(1) / ';' /
data a_cmdl(2) / ' ' /
data i_delflag / 0, 0, 0, 0 /
data a_version /'<< RDF_READER Version 30.0 30-September-1999 >>'/
c PROCESSING STEPS:
call rdf_trace('RDF_INIT')
if (a_data .ne. ' ') then
call rdf_parse(a_data,a_keyw,a_unit,a_dimn,a_elem,a_oper,a_valu,a_cmnt)
a_keyw = rdfupper(a_keyw)
if (a_keyw .eq. ' ') then
call rdf_error('Command field blank. ')
else if (a_keyw .eq. 'ERRFILE') then
write(6,*) 'Error file = ',a_valu(1:max(1,rdflen(a_valu)))
if (rdfupper(a_errfile) .eq. 'SCREEN') then
i_errflag(1) = 1
i_errflag(2) = 0
i_errflag(3) = 0
a_errfile = ' '
else if (rdfupper(a_errfile) .eq. 'MESSAGE') then
i_errflag(1) = 0
i_errflag(2) = 1
i_errflag(3) = 0
a_errfile = ' '
else
i_errflag(1) = 0
i_errflag(2) = 0
i_errflag(3) = 1
a_errfile = a_valu
endif
else if (a_keyw .eq. 'ERROR_SCREEN') then
if (rdfupper(a_valu) .eq. 'ON') then
i_errflag(1) = 1
else
i_errflag(1) = 0
endif
else if (a_keyw .eq. 'ERROR_BUFFER') then
if (rdfupper(a_valu) .eq. 'ON') then
i_errflag(2) = 1
else
i_errflag(2) = 0
endif
else if (a_keyw .eq. 'ERROR_OUTPUT') then
if (a_valu .eq. ' ' .or. rdfupper(a_valu) .eq. 'OFF') then
i_errflag(3) = 0
a_errfile = ' '
else
i_errflag(3) = 1
a_errfile = a_valu
endif
else if (a_keyw .eq. 'COMMENT') then
do i=1,3
a_cmdl(i-1) = ' '
end do
call rdf_parse(a_data,a_keyw,a_unit,a_dimn,a_elem,a_oper,a_valu,a_cmnt)
call rdf_getfields(a_valu,i_val,a_vals)
do i=1,3
if (i .le. i_val) then
a_cmdl(i-1) = a_vals(i)
else
a_cmdl(i-1) = ' '
end if
end do
else if (a_keyw .eq. 'COMMENT0') then
a_cmdl(0) = a_valu
else if (a_keyw .eq. 'COMMENT1') then
a_cmdl(1) = a_valu
else if (a_keyw .eq. 'COMMENT2') then
a_cmdl(2) = a_valu
else if (a_keyw .eq. 'COMMENT_DELIMITOR_SUPPRESS') then
if (rdfupper(a_valu) .eq. 'ON') then
i_delflag(1) = 1
else
i_delflag(1) = 0
endif
else if (a_keyw .eq. 'TABS') then
read(a_valu,fmt=*,iostat=i_iostat) (i_tabs(i),i=1,7)
if (i_iostat .ne. 0) then
a_errtmp = 'Unable to parse tab command. '// a_data(1:max(1,rdflen(a_data)))
call rdf_error(a_errtmp)
endif
write(6,*) 'tabs = ',(i_tabs(i),i=1,7)
i_fsizes(1) = i_tabs(1)
do i = 2,7
i_fsizes(i) = i_tabs(i) - i_tabs(i-1)
enddo
write(6,*) 'fields = ',(i_fsizes(i),i=1,7)
else if (a_keyw .eq. 'KEYWORD FIELD SIZE') then
read(a_valu,fmt=*,iostat=i_iostat) i_fsizes(1)
if (i_iostat .ne. 0) then
a_errtmp = 'Unable to parse keyword field size. '//a_data(1:max(1,rdflen(a_data)))
call rdf_error(a_errtmp)
endif
else if (a_keyw .eq. 'UNIT FIELD SIZE') then
read(a_valu,fmt=*,iostat=i_iostat) i_fsizes(2)
if (i_iostat .ne. 0) then
a_errtmp = 'Unable to parse unit field size. '//a_data(1:max(1,rdflen(a_data)))
call rdf_error(a_errtmp)
endif
else if (a_keyw .eq. 'DIMENSION FIELD SIZE') then
read(a_valu,fmt=*,iostat=i_iostat) i_fsizes(3)
if (i_iostat .ne. 0) then
a_errtmp = 'Unable to parse dimension field size. '//a_data(1:max(1,rdflen(a_data)))
call rdf_error(a_errtmp)
endif
else if (a_keyw .eq. 'ELEMENT FIELD SIZE') then
read(a_valu,fmt=*,iostat=i_iostat) i_fsizes(4)
if (i_iostat .ne. 0) then
a_errtmp = 'Unable to parse element field size. '//a_data(1:max(1,rdflen(a_data)))
call rdf_error(a_errtmp)
endif
else if (a_keyw .eq. 'OPERATOR FIELD SIZE') then
read(a_valu,fmt=*,iostat=i_iostat) i_fsizes(5)
if (i_iostat .ne. 0) then
a_errtmp = 'Unable to parse operator field size. '//a_data(1:max(1,rdflen(a_data)))
call rdf_error(a_errtmp)
endif
else if (a_keyw .eq. 'VALUE FIELD SIZE') then
read(a_valu,fmt=*,iostat=i_iostat) i_fsizes(6)
if (i_iostat .ne. 0) then
a_errtmp = 'Unable to parse value field size. '//a_data(1:max(1,rdflen(a_data)))
call rdf_error(a_errtmp)
endif
else if (a_keyw .eq. 'COMMENT FIELD SIZE') then
read(a_valu,fmt=*,iostat=i_iostat) i_fsizes(7)
if (i_iostat .ne. 0) then
a_errtmp = 'Unable to parse comment field size. '// a_data(1:max(1,rdflen(a_data)))
call rdf_error(a_errtmp)
endif
else if (a_keyw .eq. 'INTEGER FORMAT') then
a_intfmt = a_valu
c if (index(rdfupper(a_intfmt),'I') .eq. 0) then
c call rdf_error('Unable to parse integer format. '//
c & a_data(1:max(1,rdflen(a_data))))
c endif
else if (a_keyw .eq. 'REAL FORMAT') then
a_realfmt = a_valu
c if (index(rdfupper(a_realfmt),'F') .eq. 0) then
c call rdf_error('Unable to parse real format. '//
c & a_data(1:max(1,rdflen(a_data))))
c endif
else if (a_keyw .eq. 'DOUBLE FORMAT') then
a_dblefmt = a_valu
c if (index(rdfupper(a_dblefmt),'F') .eq. 0) then
c call rdf_error('Unable to parse dble format. '//
c & a_data(1:max(1,rdflen(a_data))))
c endif
else
a_errtmp = 'Command not recognized. '// a_data(1:max(1,rdflen(a_data)))
call rdf_error(a_errtmp)
endif
endif
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_read(a_rdfname)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c** rdf_merge
c**
c** NOTES:
c** rdf_merge actually reads the file. rdf_read is a special case where
c** you zero out all of the existing data loading into memory
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_rdfname
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
data i_nums /0/
c FUNCTION_STATEMENTS:
c PROCESSING STEPS:
call rdf_trace('RDF_READ')
i_nums = 0 ! zeros out all loaded data fields
i_pntr = 0
call rdf_merge(a_rdfname)
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_clear()
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
integer i
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
c PROCESSING STEPS:
call rdf_trace('RDF_CLEAR')
do i=1,i_nums
a_dsets(i) = ' '
a_matks(i) = ' '
a_strts(i) = ' '
a_prfxs(i) = ' '
a_sufxs(i) = ' '
a_keyws(i) = ' '
a_units(i) = ' '
a_dimns(i) = ' '
a_elems(i) = ' '
a_opers(i) = ' '
a_valus(i) = ' '
a_cmnts(i) = ' '
enddo
i_nums = 0
i_pntr = 0
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_num(i_num)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
integer i_num
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
c PROCESSING STEPS:
call rdf_trace('RDF_NUM')
i_num = i_nums
c i_pntr = i_nums
call rdf_trace(' ')
return
end
c****************************************************************
integer*4 function rdfnum()
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
c PROCESSING STEPS:
call rdf_trace('RDFNUM')
i_pntr = i_nums
rdfnum = i_nums
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_insert(a_data)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_data
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i
integer i_flg
integer i_indx
integer i_loc
integer i_indxx
integer i_iostat
character*320 a_keyw
character*320 a_valu
character*320 a_unit
character*320 a_dimn
character*320 a_elem
character*320 a_oper
character*320 a_cmnt
character*320 a_kkkk
character*320 a_dset
character*320 a_errtmp
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
character*320 rdftrim
external rdftrim
character*320 rdfupper
external rdfupper
character*320 rdfcullsp
external rdfcullsp
character*320 rdfint1
external rdfint1
c PROCESSING STEPS:
call rdf_trace('RDF_INSERT')
if (i_pntr .eq. 0) then
i_indx=1
else
i_indx=i_pntr
endif
call rdf_parse(a_data,a_keyw,a_unit,a_dimn,a_elem,a_oper,a_valu,a_cmnt)
if (a_keyw .ne. ' ') call rdf_index(a_keyw,i_indxx,i_flg)
c if (i_flg .gt. 0) then
c call rdf_error('Parameter already exists. '//
c & a_keyw(1:max(rdflen(a_keyw),1)))
c else
if (.true.) then
if (i_nums .ge. I_PARAMS) then
a_errtmp = 'RDF Buffer full, unable to insert parameter. '//
& a_keyw(1:max(rdflen(a_keyw),1))
call rdf_error(a_errtmp)
else if (i_indx .lt. 1 .or. i_indx .gt. i_nums+1) then
a_errtmp = 'Index not within valid range 1 to i_nums+1. '//
& a_keyw(1:max(rdflen(a_keyw),1))//' '//rdfint1(i_indx)
call rdf_error(a_errtmp)
else
i_loc = index(a_keyw,':')
if (i_loc .gt. 0) then
a_kkkk = rdftrim(a_keyw(i_loc+1:))
if (i_loc .gt. 1) then
a_dset = rdftrim(a_keyw(1:i_loc-1))
else
a_dset = ' '
endif
else
a_kkkk = rdftrim(a_keyw)
a_dset = ' '
endif
if (rdfupper(a_kkkk) .eq. 'PREFIX') then
a_prfx = a_valu
a_prefix = a_prfx
call rdf_unquote(a_prefix,i_prelen)
else if (rdfupper(a_kkkk) .eq. 'SUFFIX') then
a_sufx = a_valu
a_suffix = a_sufx
call rdf_unquote(a_suffix,i_suflen)
else
do i=i_nums,i_indx,-1
a_dsets(i+1) = a_dsets(i)
a_matks(i+1) = a_matks(i)
a_strts(i+1) = a_strts(i)
a_prfxs(i+1) = a_prfxs(i)
a_sufxs(i+1) = a_sufxs(i)
a_keyws(i+1) = a_keyws(i)
a_valus(i+1) = a_valus(i)
a_units(i+1) = a_units(i)
a_dimns(i+1) = a_dimns(i)
a_elems(i+1) = a_elems(i)
a_opers(i+1) = a_opers(i)
a_cmnts(i+1) = a_cmnts(i)
enddo
i_nums = i_nums + 1
a_dsets(i_indx) = a_dset
a_strts(i_indx) = ' '
a_keyws(i_indx) = a_kkkk
a_valus(i_indx) = a_valu
a_units(i_indx) = a_unit
a_dimns(i_indx) = a_dimn
a_elems(i_indx) = a_elem
a_opers(i_indx) = a_oper
a_cmnts(i_indx) = a_cmnt
if (a_keyws(i_indx) .ne. ' ') then
a_prfxs(i_indx) = a_prfx
a_sufxs(i_indx) = a_sufx
if (i_prelen .gt. 0) then
a_matks(i_indx) = rdfupper(rdfcullsp(rdftrim(a_prefix(1:i_prelen)//a_keyws(i_indx))))
else
a_matks(i_indx) = rdfupper(rdfcullsp(rdftrim(a_keyws(i_indx))))
endif
a_matks(i_indx) = a_matks(i_indx)(1:rdflen(a_matks(i_indx)))//rdfupper(rdfcullsp(a_suffix))
else
a_prfxs(i_indx) = ' '
a_sufxs(i_indx) = ' '
a_matks(i_indx) = ' '
endif
endif
i_pntr = 0
if (a_keyw .ne. ' ') call rdf_index(a_keyw,i_indxx,i_flg)
i_pntr = i_indx
endif
endif
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_append(a_data)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
integer i
integer i_flg
character*(*) a_data
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_loc
integer i_lun
integer i_indx
integer i_indxx
integer i_iostat
character*320 a_keyw
character*320 a_valu
character*320 a_unit
character*320 a_dimn
character*320 a_elem
character*320 a_oper
character*320 a_cmnt
character*320 a_kkkk
character*320 a_dset
character*320 a_errtmp
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
character*320 rdftrim
external rdftrim
character*320 rdfupper
external rdfupper
character*320 rdfcullsp
external rdfcullsp
character*320 rdfint1
external rdfint1
c PROCESSING STEPS:
call rdf_trace('RDF_APPEND')
if (i_pntr .eq. 0) then
i_indx=i_nums
else
i_indx=i_pntr
endif
call rdf_parse(a_data,a_keyw,a_unit,a_dimn,a_elem,a_oper,a_valu,a_cmnt)
i_flg = 0
if (a_keyw .ne. ' ') call rdf_index(a_keyw,i_indxx,i_flg)
if (i_flg .gt. 0) then
a_errtmp = 'Parameter already exists. '//
& a_keyw(1:max(rdflen(a_keyw),1))
call rdf_error(a_errtmp)
else
if (i_nums .ge. I_PARAMS) then
a_errtmp = 'Buffer full, unable to insert parameter. '//
& a_keyw(1:max(rdflen(a_keyw),1))
call rdf_error(a_errtmp)
else if (i_indx .lt. 0 .or. i_indx .gt. i_nums) then
a_errtmp = 'Index not within valid range 1 to i_nums+1. '//
& a_keyw(1:max(rdflen(a_keyw),1))//' '//rdfint1(i_indx)
call rdf_error(a_errtmp)
else
i_loc = index(a_keyw,':')
if (i_loc .gt. 0) then
a_kkkk = rdftrim(a_keyw(i_loc+1:))
if (i_loc .gt. 1) then
a_dset = rdftrim(a_keyw(1:i_loc-1))
else
a_dset = ' '
endif
else
a_kkkk = rdftrim(a_keyw)
a_dset = ' '
endif
if (rdfupper(a_kkkk) .eq. 'PREFIX') then
a_prfx = a_valu
a_prefix = a_prfx
call rdf_unquote(a_prefix,i_prelen)
else if (rdfupper(a_kkkk) .eq. 'SUFFIX') then
a_sufx = a_valu
a_suffix = a_sufx
call rdf_unquote(a_suffix,i_suflen)
else
do i=i_nums,i_indx+1,-1
a_dsets(i+1) = a_dsets(i)
a_matks(i+1) = a_matks(i)
a_strts(i+1) = a_strts(i)
a_prfxs(i+1) = a_prfxs(i)
a_sufxs(i+1) = a_sufxs(i)
a_keyws(i+1) = a_keyws(i)
a_valus(i+1) = a_valus(i)
a_units(i+1) = a_units(i)
a_dimns(i+1) = a_dimns(i)
a_elems(i+1) = a_elems(i)
a_opers(i+1) = a_opers(i)
a_cmnts(i+1) = a_cmnts(i)
enddo
i_nums = i_nums+1
a_dsets(i_indx+1) = a_dset
a_strts(i_indx+1) = ' '
a_keyws(i_indx+1) = a_kkkk
a_valus(i_indx+1) = a_valu
a_units(i_indx+1) = a_unit
a_dimns(i_indx+1) = a_dimn
a_elems(i_indx+1) = a_elem
a_opers(i_indx+1) = a_oper
a_cmnts(i_indx+1) = a_cmnt
if (a_keyws(i_indx+1) .ne. ' ') then
a_prfxs(i_indx+1) = a_prfx
a_sufxs(i_indx+1) = a_sufx
if (i_prelen .gt. 0) then
a_matks(i_indx+1) = rdfupper(rdfcullsp(rdftrim(a_prefix(1:i_prelen)//a_keyws(i_indx+1))))
else
a_matks(i_indx+1) = rdfupper(rdfcullsp(rdftrim(a_keyws(i_indx+1))))
endif
a_matks(i_indx+1) = a_matks(i_indx+1)(1:rdflen(a_matks(i_indx+1)))//rdfupper(rdfcullsp(a_suffix))
else
a_prfxs(i_indx+1) = ' '
a_sufxs(i_indx+1) = ' '
a_matks(i_indx+1) = ' '
endif
endif
i_pntr = 0
if (a_keyw .ne. ' ') call rdf_index(a_keyw,i_indxx,i_flg)
i_pntr = i_indx+1
endif
endif
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_insertcols(a_keyw,a_valu,a_unit,a_dimn,a_elem,a_oper,a_cmnt)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
character*(*) a_valu
character*(*) a_unit
character*(*) a_dimn
character*(*) a_elem
character*(*) a_oper
character*(*) a_cmnt
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i
integer i_flg
integer i_loc
integer i_lun
integer i_indx
integer i_indxx
character*320 a_kkkk
character*320 a_dset
character*320 a_errtmp
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
character*320 rdftrim
external rdftrim
character*320 rdfupper
external rdfupper
character*320 rdfcullsp
external rdfcullsp
character*320 rdfint1
external rdfint1
c PROCESSING STEPS:
call rdf_trace('RDF_INSERTCOLS')
if (i_pntr .eq. 0) then
i_indx=1
else
i_indx=i_pntr
endif
if (i_nums .ge. I_PARAMS) then
a_errtmp = 'Buffer full, unable to insert parameter. '//
& a_keyw(1:max(rdflen(a_keyw),1))
call rdf_error(a_errtmp)
else if (i_indx .lt. 1 .or. i_indx .gt. i_nums+1) then
a_errtmp = 'Index not within valid range 1 to i_nums+1. '//
& a_keyw(1:max(rdflen(a_keyw),1))//' '//rdfint1(i_indx)
call rdf_error(a_errtmp)
else
i_loc = index(a_keyw,':')
if (i_loc .gt. 0) then
a_kkkk = rdftrim(a_keyw(i_loc+1:))
if (i_loc .gt. 1) then
a_dset = rdfupper(rdfcullsp(rdftrim(a_keyw(1:i_loc-1))))
else
a_dset = ' '
endif
else
a_kkkk = rdftrim(a_keyw)
a_dset = ' '
endif
do i=i_nums,i_indx,-1
a_dsets(i+1) = a_dsets(i)
a_matks(i+1) = a_matks(i)
a_strts(i+1) = a_strts(i)
a_prfxs(i+1) = a_prfxs(i)
a_sufxs(i+1) = a_sufxs(i)
a_keyws(i+1) = a_keyws(i)
a_valus(i+1) = a_valus(i)
a_units(i+1) = a_units(i)
a_dimns(i+1) = a_dimns(i)
a_elems(i+1) = a_elems(i)
a_opers(i+1) = a_opers(i)
a_cmnts(i+1) = a_cmnts(i)
enddo
i_nums = i_nums + 1
a_dsets(i_indx) = a_dset
a_strts(i_indx) = ' '
a_keyws(i_indx) = a_kkkk
a_valus(i_indx) = a_valu
a_units(i_indx) = a_unit
a_dimns(i_indx) = a_dimn
a_elems(i_indx) = a_elem
a_opers(i_indx) = a_oper
a_cmnts(i_indx) = a_cmnt
if (a_keyws(i_indx) .ne. ' ') then
a_prfxs(i_indx) = a_prfx
a_sufxs(i_indx) = a_sufx
if (i_prelen .gt. 0) then
a_matks(i_indx) = rdfupper(rdfcullsp(rdftrim(a_prefix(1:i_prelen)//a_keyws(i_indx))))
else
a_matks(i_indx) = rdfupper(rdfcullsp(rdftrim(a_keyws(i_indx))))
endif
a_matks(i_indx) = a_matks(i_indx)(1:rdflen(a_matks(i_indx)))//rdfupper(rdfcullsp(a_suffix))
else
a_prfxs(i_indx) = ' '
a_sufxs(i_indx) = ' '
a_matks(i_indx) = ' '
endif
i_pntr = 0
if (a_keyw .ne. ' ') call rdf_index(a_keyw,i_indxx,i_flg)
i_pntr = i_indx
endif
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_appendcols(a_keyw,a_valu,a_unit,a_dimn,a_elem,a_oper,a_cmnt)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
character*(*) a_valu
character*(*) a_unit
character*(*) a_dimn
character*(*) a_elem
character*(*) a_oper
character*(*) a_cmnt
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i
integer i_flg
integer i_loc
integer i_lun
integer i_indx
integer i_indxx
character*320 a_kkkk
character*320 a_dset
character*320 a_errtmp
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
character*320 rdftrim
external rdftrim
character*320 rdfint1
external rdfint1
character*320 rdfupper
external rdfupper
character*320 rdfcullsp
external rdfcullsp
c PROCESSING STEPS:
call rdf_trace('RDF_APPENDCOLS')
if (i_pntr .eq. 0) then
i_indx=i_nums
else
i_indx=i_pntr
endif
if (i_nums .ge. I_PARAMS) then
a_errtmp = 'Buffer full, unable to insert parameter. '//
& a_keyw(1:max(rdflen(a_keyw),1))
call rdf_error(a_errtmp)
else if (i_indx .lt. 0 .or. i_indx .gt. i_nums) then
a_errtmp = 'Index not within valid range 1 to i_nums+1. '//
& a_keyw(1:max(rdflen(a_keyw),1))//' '//rdfint1(i_indx-1)
call rdf_error(a_errtmp)
else
i_loc = index(a_keyw,':')
if (i_loc .gt. 0) then
a_kkkk = rdftrim(a_keyw(i_loc+1:))
if (i_loc .gt. 1) then
a_dset = rdfupper(rdfcullsp(rdftrim(a_keyw(1:i_loc-1))))
else
a_dset = ' '
endif
else
a_kkkk = rdftrim(a_keyw)
a_dset = ' '
endif
if (rdfupper(a_kkkk) .eq. 'PREFIX') then
a_prfx = a_valu
a_prefix = a_prfx
call rdf_unquote(a_prefix,i_prelen)
else if (rdfupper(a_kkkk) .eq. 'SUFFIX') then
a_sufx = a_valu
a_suffix = a_sufx
call rdf_unquote(a_suffix,i_suflen)
else
do i=i_nums,i_indx+1,-1
a_dsets(i+1) = a_dsets(i)
a_strts(i+1) = a_strts(i)
a_prfxs(i+1) = a_prfxs(i)
a_sufxs(i+1) = a_sufxs(i)
a_keyws(i+1) = a_keyws(i)
a_valus(i+1) = a_valus(i)
a_units(i+1) = a_units(i)
a_dimns(i+1) = a_dimns(i)
a_elems(i+1) = a_elems(i)
a_opers(i+1) = a_opers(i)
a_cmnts(i+1) = a_cmnts(i)
enddo
a_dsets(i_indx+1) = a_dset
a_strts(i_indx+1) = ' '
a_keyws(i_indx+1) = a_kkkk
a_valus(i_indx+1) = a_valu
a_units(i_indx+1) = a_unit
a_dimns(i_indx+1) = a_dimn
a_elems(i_indx+1) = a_elem
a_opers(i_indx+1) = a_oper
a_cmnts(i_indx+1) = a_cmnt
if (a_keyws(i_indx+1) .ne. ' ') then
a_prfxs(i_indx+1) = a_prfx
a_sufxs(i_indx+1) = a_sufx
if (i_prelen .gt. 0) then
a_matks(i_indx+1) = rdfupper(rdfcullsp(rdftrim(a_prefix(1:i_prelen)//a_keyws(i_indx+1))))
else
a_matks(i_indx+1) = rdfupper(rdfcullsp(rdftrim(a_keyws(i_indx+1))))
endif
a_matks(i_indx+1) = a_matks(i_indx+1)(1:rdflen(a_matks(i_indx+1)))//rdfupper(rdfcullsp(a_suffix))
else
a_prfxs(i_indx+1) = ' '
a_sufxs(i_indx+1) = ' '
a_matks(i_indx+1) = ' '
endif
i_pntr = 0
if (a_keyw .ne. ' ') call rdf_index(a_keyw,i_indxx,i_flg)
i_pntr = i_indx+1
i_nums = i_nums + 1
endif
endif
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_entercols(i_indx,a_keyw,a_valu,a_unit,a_dimn,a_elem,a_oper,a_cmnt)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
integer i
integer i_indx
character*(*) a_keyw
character*(*) a_valu
character*(*) a_unit
character*(*) a_dimn
character*(*) a_elem
character*(*) a_oper
character*(*) a_cmnt
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_flg
integer i_loc
integer i_lun
integer i_indxx
integer i_indxxx
character*320 a_kkkk
character*320 a_dset
character*320 a_errtmp
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
character*320 rdftrim
external rdftrim
character*320 rdfupper
external rdfupper
character*320 rdfcullsp
external rdfcullsp
character*320 rdfint1
external rdfint1
c PROCESSING STEPS:
call rdf_trace('RDF_ENTERCOLS')
if (i_indx .eq. 0) then
i_indxx=i_pntr
else
i_indxx=i_indx
endif
if (i_nums .ge. I_PARAMS) then
a_errtmp = 'Buffer full, unable to insert parameter. '//
& a_keyw(1:max(rdflen(a_keyw),1))
call rdf_error(a_errtmp)
else if (i_indxx .lt. 1 .or. i_indxx .gt. i_nums+1) then
a_errtmp = 'Index not within valid range 1 to i_nums+1. '//
& a_keyw(1:max(rdflen(a_keyw),1))//' '//rdfint1(i_indxx)
call rdf_error(a_errtmp)
else
i_loc = index(a_keyw,':')
if (i_loc .gt. 0) then
a_kkkk = rdftrim(a_keyw(i_loc+1:))
if (i_loc .gt. 1) then
a_dset = rdfupper(rdfcullsp(rdftrim(a_keyw(1:i_loc-1))))
else
a_dset = ' '
endif
else
a_kkkk = rdftrim(a_keyw)
a_dset = ' '
endif
do i=i_nums,i_indxx,-1
a_dsets(i+1) = a_dsets(i)
a_strts(i+1) = a_strts(i)
a_prfxs(i+1) = a_prfxs(i)
a_sufxs(i+1) = a_sufxs(i)
a_keyws(i+1) = a_keyws(i)
a_valus(i+1) = a_valus(i)
a_units(i+1) = a_units(i)
a_dimns(i+1) = a_dimns(i)
a_elems(i+1) = a_elems(i)
a_opers(i+1) = a_opers(i)
a_cmnts(i+1) = a_cmnts(i)
enddo
i_nums = i_nums + 1
a_dsets(i_indxx) = a_dset
a_strts(i_indxx) = ' '
a_keyws(i_indxx) = a_kkkk
a_valus(i_indxx) = a_valu
a_units(i_indxx) = a_unit
a_dimns(i_indxx) = a_dimn
a_elems(i_indxx) = a_elem
a_opers(i_indxx) = a_oper
a_cmnts(i_indxx) = a_cmnt
if (a_keyws(i_indxx) .ne. ' ') then
a_prfxs(i_indxx) = a_prfx
a_sufxs(i_indxx) = a_sufx
if (i_prelen .gt. 0) then
a_matks(i_indxx) = rdfupper(rdfcullsp(rdftrim(a_prefix(1:i_prelen)//a_keyws(i_indxx))))
else
a_matks(i_indxx) = rdfupper(rdfcullsp(rdftrim(a_keyws(i_indxx))))
endif
a_matks(i_indxx) = a_matks(i_indxx)(1:rdflen(a_matks(i_indxx)))//rdfupper(rdfcullsp(a_suffix))
else
a_prfxs(i_indxx) = ' '
a_sufxs(i_indxx) = ' '
a_matks(i_indxx) = ' '
endif
i_pntr = 0
if (a_keyw .ne. ' ') call rdf_index(a_keyw,i_indxxx,i_flg)
i_pntr = i_indxx
endif
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_view(i_indx,a_data)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
integer i_indx
c OUTPUT VARIABLES:
character*(*) a_data
c LOCAL VARIABLES:
integer i_lun
character*320 a_keyw
character*320 a_valu
character*320 a_unit
character*320 a_dimn
character*320 a_elem
character*320 a_oper
character*320 a_cmnt
character*320 a_errtmp
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
character*320 rdfint1
external rdfint1
c PROCESSING STEPS:
call rdf_trace('RDF_VIEW')
i_pntr = max(min(i_indx,i_nums),0)
if (i_indx .ge. 1 .and. i_indx .le. i_nums) then
if (a_dsets(i_indx) .eq. ' ') then
a_keyw = a_matks(i_indx)
else
a_keyw = a_dsets(i_indx)(1:rdflen(a_dsets(i_indx)))//':'//a_matks(i_indx)
endif
a_valu = a_valus(i_indx)
a_unit = a_units(i_indx)
a_dimn = a_dimns(i_indx)
a_elem = a_elems(i_indx)
a_oper = a_opers(i_indx)
a_cmnt = a_cmnts(i_indx)
c type *,'a_keyw =',a_keyw(1:max(rdflen(a_keyw),1)),rdflen(a_keyw)
c type *,'a_unit =',a_unit(1:max(rdflen(a_unit),1)),rdflen(a_unit)
c type *,'a_dimn =',a_dimn(1:max(rdflen(a_dimn),1)),rdflen(a_dimn)
c type *,'a_elem =',a_elem(1:max(rdflen(a_elem),1)),rdflen(a_elem)
c type *,'a_oper =',a_oper(1:max(rdflen(a_oper),1)),rdflen(a_oper)
c type *,'a_valu =',a_valu(1:max(rdflen(a_valu),1)),rdflen(a_valu)
c type *,'a_cmnt =',a_cmnt(1:max(rdflen(a_cmnt),1)),rdflen(a_cmnt)
call rdf_unparse(a_data,a_keyw,a_unit,a_dimn,a_elem,a_oper,a_valu,a_cmnt)
c type *,'a_data =',a_data(1:max(rdflen(a_data),1)),rdflen(a_data)
else
a_valu = ' '
a_unit = ' '
a_dimn = ' '
a_elem = ' '
a_oper = ' '
a_cmnt = ' '
if (i_indx .ne. 0) then
a_errtmp = 'Requested buffer entry does not contain valid data. '
& //rdfint1(i_indx)
call rdf_error(a_errtmp)
endif
a_data = ' '
endif
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_viewcols(i_indx,a_keyw,a_valu,a_unit,a_dimn,a_elem,a_oper,a_cmnt)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
integer i_indx
c OUTPUT VARIABLES:
character*(*) a_keyw
character*(*) a_valu
character*(*) a_unit
character*(*) a_dimn
character*(*) a_elem
character*(*) a_oper
character*(*) a_cmnt
character*320 a_errtmp
c LOCAL VARIABLES:
integer i_lun
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
character*320 rdfint1
external rdfint1
c PROCESSING STEPS:
call rdf_trace('RDF_VIEWCOLS')
i_pntr = max(min(i_indx,i_nums),0)
if (i_indx .ge. 1 .and. i_indx .le. i_nums) then
if (a_dsets(i_indx) .eq. ' ') then
a_keyw = a_keyws(i_indx)
else
a_keyw = a_dsets(i_indx)(1:rdflen(a_dsets(i_indx)))//':'//a_keyws(i_indx)
endif
a_valu = a_valus(i_indx)
a_unit = a_units(i_indx)
a_dimn = a_dimns(i_indx)
a_elem = a_elems(i_indx)
a_oper = a_opers(i_indx)
a_cmnt = a_cmnts(i_indx)
c i_pntr = i_indx
else
a_valu = ' '
a_unit = ' '
a_dimn = ' '
a_elem = ' '
a_oper = ' '
a_cmnt = ' '
if (i_indx .ne. 0) then
a_errtmp = 'Requested buffer entry does not contain valid data. '
& //rdfint1(i_indx)
call rdf_error(a_errtmp)
endif
endif
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_find(a_keyw,a_data)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
character*320 a_valu
character*320 a_unit
character*320 a_dimn
character*320 a_elem
character*320 a_oper
character*320 a_cmnt
character*320 a_errtmp
character*(*) a_data
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_indx
integer i_flg
integer i_lun
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
character*320 rdfint1
external rdfint1
c PROCESSING STEPS:
call rdf_trace('RDF_FIND')
call rdf_index(a_keyw,i_indx,i_flg)
if (i_flg .ge. 1) then
a_valu = a_valus(i_indx)
a_unit = a_units(i_indx)
a_dimn = a_dimns(i_indx)
a_elem = a_elems(i_indx)
a_oper = a_opers(i_indx)
a_cmnt = a_cmnts(i_indx)
call rdf_unparse(a_data,a_keyw,a_unit,a_dimn,a_elem,a_oper,a_valu,a_cmnt)
endif
if (i_flg .eq. 0) then ! Data not found
a_errtmp = 'Keyword not found. '//a_keyw(1:max(min(rdflen(a_keyw),150),2))
call rdf_error(a_errtmp)
else if (i_flg .ge. 2) then
a_errtmp = 'Multiple matching keywords found, returning last one found. '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))//' '//rdfint1(i_flg)
call rdf_error(a_errtmp)
endif
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_findcols(a_keyw,a_valu,a_unit,a_dimn,a_elem,a_oper,a_cmnt)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
character*(*) a_valu
character*(*) a_unit
character*(*) a_dimn
character*(*) a_elem
character*(*) a_oper
character*(*) a_cmnt
character*320 a_errtmp
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_indx
integer i_flg
integer i_lun
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
character*320 rdfint1
external rdfint1
c PROCESSING STEPS:
call rdf_trace('RDF_FINDCOLS')
call rdf_index(a_keyw,i_indx,i_flg)
if (i_flg .eq. 1) then
a_valu = a_valus(i_indx)
a_unit = a_units(i_indx)
a_dimn = a_dimns(i_indx)
a_elem = a_elems(i_indx)
a_oper = a_opers(i_indx)
a_cmnt = a_cmnts(i_indx)
endif
if (i_flg .eq. 0) then ! Data not found
a_errtmp = 'Keyword not found. '//a_keyw(1:max(min(rdflen(a_keyw),150),2))
call rdf_error(a_errtmp)
else if (i_flg .ge. 2) then
a_errtmp = 'Multiple matching keywords found, returning last one found. '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))//' '//rdfint1(i_flg)
call rdf_error(a_errtmp)
endif
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_remove(a_keyw)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i
integer i_flg
integer i_indx
character*320 a_kkkk
character*320 a_dset
character*320 a_errtmp
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDF_REMOVE')
call rdf_index(a_keyw,i_indx,i_flg)
if (i_flg .eq. 0) then
a_errtmp = 'Keyword not found. '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))
call rdf_error(a_errtmp)
else
if (i_flg .gt. 1) then
a_errtmp = 'Multiple Keywords found. Deleting last occurance. '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))
call rdf_error(a_errtmp)
endif
i_pntr = i_indx
do i = i_indx+1,i_nums
a_dsets(i-1) = a_dsets(i)
a_matks(i-1) = a_matks(i)
a_strts(i-1) = a_strts(i)
a_prfxs(i-1) = a_prfxs(i)
a_sufxs(i-1) = a_sufxs(i)
a_keyws(i-1) = a_keyws(i)
a_valus(i-1) = a_valus(i)
a_units(i-1) = a_units(i)
a_dimns(i-1) = a_dimns(i)
a_elems(i-1) = a_elems(i)
a_opers(i-1) = a_opers(i)
a_cmnts(i-1) = a_cmnts(i)
enddo
endif
i_nums = i_nums - 1
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_update(a_data)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_data
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
character*320 a_keyw
character*320 a_valu
character*320 a_unit
character*320 a_dimn
character*320 a_elem
character*320 a_oper
character*320 a_cmnt
character*320 a_errtmp
integer i_flg
integer i_indx
integer i_lun
integer i_iostat
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDF_UPDATE')
call rdf_unparse(a_data,a_keyw,a_unit,a_dimn,a_elem,a_oper,a_valu,a_cmnt)
call rdf_index(a_keyw,i_indx,i_flg)
if (i_flg .ge. 1) then
a_valus(i_indx) = a_valu
a_units(i_indx) = a_unit
a_dimns(i_indx) = a_dimn
a_elems(i_indx) = a_elem
a_opers(i_indx) = a_oper
a_cmnts(i_indx) = a_cmnt
endif
if (i_flg .eq. 0) then
if (i_nums .lt. I_PARAMS) then
a_errtmp = 'Keyword not found, inserting at end. '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))
call rdf_error(a_errtmp)
call rdf_insertcols(a_keyw,a_valu,a_unit,a_dimn,a_elem,a_oper,a_cmnt)
else
a_errtmp = 'Buffer Full, cannot add parameter '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))
call rdf_error(a_errtmp)
endif
endif
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_updatecols(a_keyw,a_unit,a_dimn,a_elem,a_oper,a_cmnt,a_valu)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
character*(*) a_valu
character*(*) a_unit
character*(*) a_dimn
character*(*) a_elem
character*(*) a_oper
character*(*) a_cmnt
character*320 a_errtmp
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_flg
integer i_indx
integer i_lun
integer i_iostat
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDF_UPDATECOLS')
call rdf_index(a_keyw,i_indx,i_flg)
if (i_flg .ge. 1) then
a_valus(i_indx) = a_valu
a_units(i_indx) = a_unit
a_dimns(i_indx) = a_dimn
a_elems(i_indx) = a_elem
a_opers(i_indx) = a_oper
a_cmnts(i_indx) = a_cmnt
endif
if (i_flg .eq. 0) then
if (i_nums .lt. I_PARAMS) then
a_errtmp = 'Keyword not found, inserting at end. '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))
call rdf_error(a_errtmp)
call rdf_insertcols(a_keyw,a_valu,a_unit,a_dimn,a_elem,a_oper,a_cmnt)
else
a_errtmp = 'Buffer Full, cannot add parameter '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))
call rdf_error(a_errtmp)
endif
endif
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_index(a_keyw,i_indx,i_flg)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
c OUTPUT VARIABLES:
integer i_indx
integer i_flg
c LOCAL VARIABLES:
integer i
integer i_loc
integer i_ocr
integer i_ocl
integer i_cnt
integer i_stat
character*320 a_kkkk
character*320 a_dset
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
character*320 rdfupper
external rdfupper
character*320 rdftrim
external rdftrim
character*320 rdfcullsp
external rdfcullsp
data i_ocl / 0/
save i_ocl
data i_cnt / 0/
save i_cnt
c PROCESSING STEPS:
call rdf_trace('RDF_INDEX')
i_loc = index(a_keyw,':')
if (i_loc .gt. 0) then
a_kkkk = rdfupper(rdfcullsp(rdftrim(a_keyw(i_loc+1:))))
if (i_loc .gt. 1) then
a_dset = rdfupper(rdfcullsp(rdftrim(a_keyw(1:i_loc-1))))
else
a_dset = ' '
endif
else
a_kkkk = rdfupper(rdfcullsp(rdftrim(a_keyw)))
a_dset = ' '
endif
i_loc = index(a_kkkk,';')
if (i_loc .gt. 0) then
read(a_kkkk(i_loc+1:),'(i10)',iostat=i_stat) i_ocr
if (i_stat .ne. 0) call rdf_error('Error reading i_ocr')
if (i_loc .gt. 1) then
a_kkkk = a_kkkk(1:i_loc-1)
else
a_kkkk = ' '
endif
else
i_ocr = 0
endif
i_flg = 0
i_indx = 0
c type *,'a_kkkk=',a_kkkk(1:max(1,rdflen(a_kkkk)))
c type *,'i_ocr =',i_ocr,i_ocl
if (a_kkkk .ne. ' ') then
if (i_pntr .ge. 1 .and. i_pntr .le. i_nums) then
if (a_kkkk .eq. a_matks(i_pntr) .and.
& (a_dset .eq. a_dsets(i_pntr) .or. a_dset .eq. ' ') .and.
& ((i_ocr .eq. 0 .and. i_cnt .eq. 1).or. (i_ocr .eq. i_ocl)) ) then ! Found a match
i_indx = i_pntr
if (i_ocr .eq. 0) then
i_flg = i_cnt
else
i_flg = 1
endif
call rdf_trace(' ')
return
endif
endif
i_pntr = 0
i_ocl = 0
i_cnt = 0
i_flg = 0
do i = 1,i_nums
if (a_kkkk .eq. a_matks(i) .and.
& (a_dset .eq. a_dsets(i) .or. a_dset .eq. ' ') ) then ! Found a match
i_cnt = i_cnt + 1
c type *,'a_kkkk=a_matks(i)',i_cnt,' ',a_matks(i)(1:max(1,rdflen(a_matks(i))))
if (i_ocr .eq. i_cnt .or. i_ocr .eq. 0) then
i_flg = i_flg + 1
i_indx = i
i_pntr = i
i_ocl = i_cnt
endif
endif
enddo
endif
c type *,'i_flg=',i_flg
call rdf_trace(' ')
return
end
c****************************************************************
integer*4 function rdfindx(a_keyw)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
character*320 a_errtmp
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_flg
integer i_indx
integer i_lun
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
character*320 rdfint1
external rdfint1
c PROCESSING STEPS:
call rdf_trace('RDFINDX')
call rdf_index(a_keyw,i_indx,i_flg)
if (i_flg .eq. 0) then ! Data not found
a_errtmp = 'Keyword not found. '//a_keyw(1:max(min(rdflen(a_keyw),150),2))
call rdf_error(a_errtmp)
else if (i_flg .ge. 2) then
a_errtmp = 'Multiple matching keywords found, returning index of last. '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))//' '//rdfint1(i_flg)
call rdf_error(a_errtmp)
endif
rdfindx = i_indx
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfvalu(a_keyw)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_flg
integer i_indx
integer i_lun
integer i_iostat
character*320 a_valu
character*320 a_data
character*320 a_errtmp
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
character*320 rdfint1
external rdfint1
c PROCESSING STEPS:
call rdf_trace('RDFVALU')
a_valu = ' '
call rdf_index(a_keyw,i_indx,i_flg)
if (i_flg .eq. 1) then
a_valu = a_valus(i_indx)
else if (i_flg .eq. 0) then ! Data not found
a_errtmp = 'Keyword not found. '//a_keyw(1:max(min(rdflen(a_keyw),150),2))
call rdf_error(a_errtmp)
a_valu = ' '
else if (i_flg .ge. 2) then
a_errtmp = 'Multiple matching keywords found, returning index of last. '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))//' '//rdfint1(i_flg)
call rdf_error(a_errtmp)
a_valu = a_valus(i_indx)
endif
rdfvalu = a_valu
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfunit(a_keyw)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_flg
integer i_indx
integer i_lun
character*320 a_unit
character*320 a_errtmp
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
character*320 rdfint1
external rdfint1
c PROCESSING STEPS:
call rdf_trace('RDFUNIT')
a_unit = ' '
call rdf_index(a_keyw,i_indx,i_flg)
if (i_flg .eq. 1) then
a_unit = a_units(i_indx)
else if (i_flg .eq. 0) then ! Data not found
a_errtmp = 'Keyword not found. '//a_keyw(1:max(min(rdflen(a_keyw),150),2))
call rdf_error(a_errtmp)
else if (i_flg .ge. 2) then
a_errtmp = 'Multiple matching keywords found, returning index of last. '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))//' '//rdfint1(i_flg)
call rdf_error(a_errtmp)
endif
rdfunit = a_unit
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfdimn(a_keyw)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_flg
integer i_indx
integer i_lun
character*320 a_dimn
character*320 a_errtmp
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
character*320 rdfint1
external rdfint1
c PROCESSING STEPS:
call rdf_trace('RDFDIMN')
a_dimn = ' '
call rdf_index(a_keyw,i_indx,i_flg)
if (i_flg .eq. 1) then
a_dimn = a_dimns(i_indx)
else if (i_flg .eq. 0) then ! Data not found
a_errtmp = 'Keyword not found. '//a_keyw(1:max(min(rdflen(a_keyw),150),2))
call rdf_error(a_errtmp)
else if (i_flg .ge. 2) then
a_errtmp = 'Multiple matching keywords found, returning index of last. '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))//' '//rdfint1(i_flg)
call rdf_error(a_errtmp)
endif
rdfdimn = a_dimn
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfelem(a_keyw)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_flg
integer i_indx
integer i_lun
character*320 a_elem
character*320 a_errtmp
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
character*320 rdfint1
external rdfint1
c PROCESSING STEPS:
call rdf_trace('RDFELEM')
a_elem = ' '
call rdf_index(a_keyw,i_indx,i_flg)
if (i_flg .eq. 1) then
a_elem = a_elems(i_indx)
else if (i_flg .eq. 0) then ! Data not found
a_errtmp = 'Keyword not found. '//a_keyw(1:max(min(rdflen(a_keyw),150),2))
call rdf_error(a_errtmp)
else if (i_flg .ge. 2) then
a_errtmp = 'Multiple matching keywords found, returning index of last. '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))//' '//rdfint1(i_flg)
call rdf_error(a_errtmp)
endif
rdfelem = a_elem
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfoper(a_keyw)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_flg
integer i_indx
integer i_lun
character*320 a_oper
character*320 a_errtmp
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
integer rdflen
external rdflen
character*320 rdfint1
external rdfint1
c FUNCTION_STATEMENTS:
c PROCESSING STEPS:
call rdf_trace('RDFOPER')
a_oper = ' '
call rdf_index(a_keyw,i_indx,i_flg)
if (i_flg .eq. 1) then
a_oper = a_opers(i_indx)
else if (i_flg .eq. 0) then ! Data not found
a_errtmp = 'Keyword not found. '//a_keyw(1:max(min(rdflen(a_keyw),150),2))
call rdf_error(a_errtmp)
else if (i_flg .ge. 2) then
a_errtmp = 'Multiple matching keywords found, returning index of last. '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))//' '//rdfint1(i_flg)
call rdf_error(a_errtmp)
endif
rdfoper = a_oper
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfcmnt(a_keyw)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_flg
integer i_indx
integer i_lun
character*320 a_cmnt
character*320 a_errtmp
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
character*320 rdfint1
external rdfint1
c PROCESSING STEPS:
call rdf_trace('RDFCMNT')
a_cmnt = ' '
call rdf_index(a_keyw,i_indx,i_flg)
if (i_flg .eq. 1) then
a_cmnt = a_cmnts(i_indx)
else if (i_flg .eq. 0) then ! Data not found
a_errtmp = 'Keyword not found. '//a_keyw(1:max(min(rdflen(a_keyw),150),1))
call rdf_error(a_errtmp)
else if (i_flg .ge. 2) then
a_errtmp = 'Multiple matching keywords found, returning index of last. '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))//' '//rdfint1(i_flg)
call rdf_error(a_errtmp)
endif
rdfcmnt = a_cmnt
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfval(a_keyw,a_unit)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c** This routine is just to maintain backward compatibility
c** with older versions of rdf_reader. Should use rdfdata.
c**
c** ROUTINES CALLED:
c** rdfdata
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
character*(*) a_keyw
character*(*) a_unit
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
character*320 rdfdata
external rdfdata
c PROCESSING STEPS:
call rdf_trace('RDFVAL')
rdfval = rdfdata(a_keyw,a_unit)
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfdata(a_keyw,a_ounit)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
character*(*) a_ounit
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_flg
integer i_indx
integer i_lun
character*320 a_valu
character*320 a_unit
character*320 a_dimn
character*320 a_elem
character*320 a_oper
character*320 a_cmnt
character*320 a_errtmp
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
character*320 rdfint1
external rdfint1
c PROCESSING STEPS:
call rdf_trace('RDFDATA')
a_valu = ' '
a_unit = ' '
a_dimn = ' '
a_elem = ' '
a_oper = ' '
a_cmnt = ' '
call rdf_index(a_keyw,i_indx,i_flg)
if (i_flg .eq. 1) then
a_valu = a_valus(i_indx)
a_unit = a_units(i_indx)
a_dimn = a_dimns(i_indx)
a_elem = a_elems(i_indx)
a_oper = a_opers(i_indx)
a_cmnt = a_cmnts(i_indx)
endif
if (i_flg .eq. 0) then ! Data not found
a_errtmp = 'Keyword not found. '//a_keyw(1:max(min(rdflen(a_keyw),150),2))
call rdf_error(a_errtmp)
else if (i_flg .ge. 2) then
a_errtmp = 'Multiple matching keywords found, returning index of last. '//
& a_keyw(1:max(min(rdflen(a_keyw),150),2))//' '//rdfint1(i_flg)
call rdf_error(a_errtmp)
else
call rdf_cnvrt(a_ounit,a_unit,a_valu)
endif
rdfdata = a_valu
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_cnvrt(a_ounit,a_unit,a_valu)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_ounit
character*(*) a_unit
character*(*) a_valu
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i
integer ii
integer i_stat
integer i_type
integer i_uinp
integer i_uout
integer i_lun
integer i_iostat
integer i_val
real*8 r_val
character*320 a_uinp(100)
character*320 a_uout(100)
character*320 a_vals(100)
character*320 a_fmt
character*320 a_errtmp
real*8 r_addit1
real*8 r_addit2
real*8 r_scale1
real*8 r_scale2
real*8 r_cnv(20,20,2)
integer i_cnv(20)
character*20 a_cnv(20,20)
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
character*320 rdflower
external rdflower
character*320 rdftrim
external rdftrim
c DATA STATEMENTS:
data i_cnv(1) /9/ ! length
data a_cnv(1,1) /'nm'/, r_cnv(1,1,1) /1.e-9/, r_cnv(1,1,2) /0./
data a_cnv(1,2) /'um'/, r_cnv(1,2,1) /1.e-6/, r_cnv(1,2,2) /0./
data a_cnv(1,3) /'mm'/, r_cnv(1,3,1) /1.e-3/, r_cnv(1,3,2) /0./
data a_cnv(1,4) /'cm'/, r_cnv(1,4,1) /1.e-2/, r_cnv(1,4,2) /0./
data a_cnv(1,5) /'m' /, r_cnv(1,5,1) /1.0 /, r_cnv(1,5,2) /0./
data a_cnv(1,6) /'km'/, r_cnv(1,6,1) /1.e+3/, r_cnv(1,6,2) /0./
data a_cnv(1,7) /'in'/, r_cnv(1,7,1) /2.54e-2/, r_cnv(1,7,2) /0./
data a_cnv(1,8) /'ft'/, r_cnv(1,8,1) /3.048e-1/, r_cnv(1,8,2) /0./
data a_cnv(1,9) /'mi'/, r_cnv(1,9,1) /1.609344e3/, r_cnv(1,9,2) /0./
data i_cnv(2) /7/ ! area
data a_cnv(2,1) /'mm*mm'/, r_cnv(2,1,1) /1.e-6/, r_cnv(2,1,2) /0./
data a_cnv(2,2) /'cm*cm'/, r_cnv(2,2,1) /1.e-4/, r_cnv(2,2,2) /0./
data a_cnv(2,3) /'m*m' /, r_cnv(2,3,1) /1.0 /, r_cnv(2,3,2) /0./
data a_cnv(2,4) /'km*km'/, r_cnv(2,4,1) /1.e+6/, r_cnv(2,4,2) /0./
data a_cnv(2,5) /'in*in'/, r_cnv(2,5,1) /6.4516e-4/, r_cnv(2,5,2) /0./
data a_cnv(2,6) /'ft*ft'/, r_cnv(2,6,1) /9.290304e-2/, r_cnv(2,6,2) /0./
data a_cnv(2,7) /'mi*mi'/, r_cnv(2,7,1) /2.58995511e6/, r_cnv(2,7,2) /0./
data i_cnv(3) /7/ ! time
data a_cnv(3,1) /'ns'/, r_cnv(3,1,1) /1.e-9/, r_cnv(3,1,2) /0./
data a_cnv(3,2) /'us'/, r_cnv(3,2,1) /1.e-6/, r_cnv(3,2,2) /0./
data a_cnv(3,3) /'ms'/, r_cnv(3,3,1) /1.e-3/, r_cnv(3,3,2) /0./
data a_cnv(3,4) /'s' /, r_cnv(3,4,1) /1.0/, r_cnv(3,4,2) /0./
data a_cnv(3,5) /'min'/,r_cnv(3,5,1) /6.0e1/, r_cnv(3,5,2) /0./
data a_cnv(3,6) /'hr' /,r_cnv(3,6,1) /3.6e3/, r_cnv(3,6,2) /0./
data a_cnv(3,7) /'day'/,r_cnv(3,7,1) /8.64e4/, r_cnv(3,7,2) /0./
data i_cnv(4) /6/ ! velocity
data a_cnv(4,1) /'cm/s'/, r_cnv(4,1,1) /1.e-2/, r_cnv(4,1,2) /0./
data a_cnv(4,2) /'m/s'/, r_cnv(4,2,1) /1.0/, r_cnv(4,2,2) /0./
data a_cnv(4,3) /'km/s'/, r_cnv(4,3,1) /1.e3/, r_cnv(4,3,2) /0./
data a_cnv(4,4) /'km/hr'/, r_cnv(4,4,1) /2.77777778e-1/, r_cnv(4,4,2) /0./
data a_cnv(4,5) /'ft/s'/, r_cnv(4,5,1) /3.04878e-1/, r_cnv(4,5,2) /0./
data a_cnv(4,6) /'mi/hr'/, r_cnv(4,6,1) /4.4704e-1/, r_cnv(4,6,2) /0./
data i_cnv(5) /5/ ! power
data a_cnv(5,1) /'mw'/, r_cnv(5,1,1) /1.e-3/, r_cnv(5,1,2) /0./
data a_cnv(5,2) /'w'/, r_cnv(5,2,1) /1.0/, r_cnv(5,2,2) /0./
data a_cnv(5,3) /'kw'/, r_cnv(5,3,1) /1.e3/, r_cnv(5,3,2) /0./
data a_cnv(5,4) /'dbm'/,r_cnv(5,4,1) /1.e-3/, r_cnv(5,4,2) /0./
data a_cnv(5,5) /'dbw'/,r_cnv(5,5,1) /1.0/, r_cnv(5,5,2) /0./
data i_cnv(6) /4/ ! frequency
data a_cnv(6,1) /'hz'/, r_cnv(6,1,1) /1.0/, r_cnv(6,1,2) /0./
data a_cnv(6,2) /'khz'/,r_cnv(6,2,1) /1.0e3/, r_cnv(6,2,2) /0./
data a_cnv(6,3) /'mhz'/,r_cnv(6,3,1) /1.0e6/, r_cnv(6,3,2) /0./
data a_cnv(6,4) /'ghz'/,r_cnv(6,4,1) /1.0e9/, r_cnv(6,4,2) /0./
data i_cnv(7) /3/ ! angle
data a_cnv(7,1) /'deg'/,r_cnv(7,1,1) /1.0/, r_cnv(7,1,2) /0./
data a_cnv(7,2) /'rad'/,r_cnv(7,2,1) /57.29577951/, r_cnv(7,2,2) /0./
data a_cnv(7,3) /'arc'/,r_cnv(7,3,1) /0.000277778/, r_cnv(7,3,2) /0./
data i_cnv(8) /7/ ! data
data a_cnv(8,1) /'bits'/, r_cnv(8,1,1) /1./, r_cnv(8,1,2) /0./
data a_cnv(8,2) /'kbits'/, r_cnv(8,2,1) /1.e3/, r_cnv(8,2,2) /0./
data a_cnv(8,3) /'mbits'/, r_cnv(8,3,1) /1.e6/, r_cnv(8,3,2) /0./
data a_cnv(8,4) /'bytes'/, r_cnv(8,4,1) /8./, r_cnv(8,4,2) /0./
data a_cnv(8,5) /'kbytes'/,r_cnv(8,5,1) /8320./, r_cnv(8,5,2) /0./
data a_cnv(8,6) /'mbytes'/,r_cnv(8,6,1) /8388608./, r_cnv(8,6,2) /0./
data a_cnv(8,7) /'words'/, r_cnv(8,7,1) /32./, r_cnv(8,7,2) /0./
data i_cnv(9) /7/ ! data rate
data a_cnv(9,1) /'bits/s'/, r_cnv(9,1,1) /1./, r_cnv(9,1,2) /0./
data a_cnv(9,2) /'kbits/s'/, r_cnv(9,2,1) /1.e3/, r_cnv(9,2,2) /0./
data a_cnv(9,3) /'mbits/s'/, r_cnv(9,3,1) /1.e6/, r_cnv(9,3,2) /0./
data a_cnv(9,4) /'bytes/s'/, r_cnv(9,4,1) /8./, r_cnv(9,4,2) /0./
data a_cnv(9,5) /'kbytes/s'/,r_cnv(9,5,1) /8320./, r_cnv(9,5,2) /0./
data a_cnv(9,6) /'mbytes/s'/,r_cnv(9,6,1) /8388608./, r_cnv(9,6,2) /0./
data a_cnv(9,7) /'baud'/, r_cnv(9,7,1) /1./, r_cnv(9,7,2) /0./
data i_cnv(10) /3/ ! temperature
data a_cnv(10,1) /'deg c'/,r_cnv(10,1,1) /1.0/, r_cnv(10,1,2) /0.0/
data a_cnv(10,2) /'deg k'/,r_cnv(10,2,1) /1.0/, r_cnv(10,2,2) /273.0/
data a_cnv(10,3) /'deg f'/,r_cnv(10,3,1) /0.555556/, r_cnv(10,3,2) /-32/
data i_cnv(11) /2/ ! ratio
data a_cnv(11,1) /'-'/, r_cnv(11,1,1) /1.0/, r_cnv(11,1,2) /0.0/
data a_cnv(11,2) /'db'/,r_cnv(11,2,1) /1.0/, r_cnv(11,2,2) /0.0/
data i_cnv(12) /2/ ! fringe rate
data a_cnv(12,1) /'deg/m'/,r_cnv(12,1,1) /1.0/ , r_cnv(12,1,2) /0.0/
data a_cnv(12,2) /'rad/m'/,r_cnv(12,2,1) /57.29577951/, r_cnv(12,2,2) /0.0/
save i_cnv,r_cnv,a_cnv
c PROCESSING STEPS:
if (a_valu .eq. ' ') return
if (a_unit .eq. ' ') return
if (a_ounit .eq. ' ') return
if (a_unit .eq. '&') return
if (a_ounit .eq. '&') return
if (a_unit .eq. '?') return
if (a_ounit .eq. '?') return
call rdf_trace('RDF_CNVRT')
i_uinp = 1
a_uinp(1) = ' '
do i=1,rdflen(a_unit)
if (a_unit(i:i) .eq. ',') then
i_uinp = i_uinp + 1
a_uinp(i_uinp) = ' '
else
a_uinp(i_uinp)(rdflen(a_uinp(i_uinp))+1:) = rdflower(a_unit(i:i))
endif
enddo
i_uout = 1
a_uout(1) = ' '
do i=1,rdflen(a_ounit)
if (a_ounit(i:i) .eq. ',') then
i_uout = i_uout + 1
a_uout(i_uout) = ' '
else
a_uout(i_uout)(rdflen(a_uout(i_uout))+1:) = rdflower(a_ounit(i:i))
endif
enddo
if (i_uinp .ne. i_uout .and. i_uinp .gt. 1 .and. i_uout .gt. 1) then
a_errtmp = 'Number of units input not equal to number of units output. '//
& a_unit(1:max(min(rdflen(a_unit),150),2))//' '//a_ounit(1:max(min(rdflen(a_ounit),150),2))
call rdf_error(a_errtmp)
call rdf_trace(' ')
return
endif
call rdf_getfields(a_valu,i_val,a_vals)
if (i_uinp .eq. 1 .and. i_val .gt. 1) then
do ii = 2,i_val
a_uinp(ii) = a_uinp(1)
enddo
i_uinp = i_val
endif
if (i_uout .eq. 1 .and. i_val .gt. 1) then
do ii = 2,i_val
a_uout(ii) = a_uout(1)
enddo
i_uout = i_val
endif
do ii = i_uinp+1,i_val
a_uinp(ii) = ' '
enddo
do ii = i_uout+1,i_val
a_uout(ii) = ' '
enddo
do ii = 1,i_val
if ((a_uinp(ii) .ne. ' ' .and. a_uinp(ii) .ne. '&') .and.
& (a_uout(ii) .ne. ' ' .and. a_uout(ii) .ne. '&')) then
i_stat=0
if (a_uinp(ii) .ne. a_uout(ii) ) then
do i_type = 1,12
if (i_stat .eq. 0) then
r_scale1 = 0.
r_scale2 = 0.
do i=1,i_cnv(i_type)
if (a_uinp(ii) .eq. a_cnv(i_type,i)) then
r_scale1 = r_cnv(i_type,i,1)
r_addit1 = r_cnv(i_type,i,2)
endif
if (a_uout(ii) .eq. a_cnv(i_type,i)) then
r_scale2 = r_cnv(i_type,i,1)
r_addit2 = r_cnv(i_type,i,2)
endif
enddo
if (r_scale1 .ne. 0. .and. r_scale2 .ne. 0.) then
read(a_vals(ii),*,iostat=i_iostat) r_val
if (i_iostat .eq. 0) then
if (index(a_uinp(ii),'db') .gt. 0) r_val = 10.0**(r_val/10.)
r_val = (r_val+r_addit1)*r_scale1/r_scale2 - r_addit2
if (index(a_uout(ii),'db') .gt. 0) r_val = 10.0*dlog10(r_val)
if (a_dblefmt .eq. '*') then
write(a_vals(ii),fmt=*,iostat=i_iostat) r_val
else
a_fmt='('//a_dblefmt(1:max(1,rdflen(a_dblefmt)))//')'
write(a_vals(ii),fmt=a_fmt,iostat=i_iostat) r_val
endif
if (i_iostat .ne. 0 ) write(6,*) 'Internal write error ',i_iostat,r_val,a_vals(ii)
a_vals(ii) = rdftrim(a_vals(ii))
i_stat = 1
else
i_stat = 2
endif
endif
endif
enddo
if (i_stat .ne. 1) then
a_errtmp = 'Unit conversion error '//
& a_uinp(ii)(1:max(1,rdflen(a_uinp(ii))))//' > '//a_uout(ii)(1:max(1,rdflen(a_uout(ii))))//
& ' val:'//a_vals(ii)
call rdf_error(a_errtmp)
endif
endif
endif
enddo
a_valu=' '
do ii=1,i_val
if (rdflen(a_valu) .eq. 0) then
a_valu=a_vals(ii)
else
a_valu=a_valu(:rdflen(a_valu))//' '//a_vals(ii)
endif
enddo
c write(6,*) a_valu(1:max(1,rdflen(a_valu)))
call rdf_trace(' ')
return
end
c****************************************************************
integer*4 function rdferr(a_err)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
c OUTPUT VARIABLES:
character*(*) a_err
c LOCAL VARIABLES:
integer i
integer i_err
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
c PROCESSING STEPS:
call rdf_trace('RDFERR')
i_err = max(i_error,0)
if (i_error .gt. 0) then
a_err = a_error(1)
do i = 1,i_error-1
a_error(i) = a_error(i+1)
enddo
i_error = i_error - 1
else
a_err = ' '
i_error = 0
endif
rdferr = i_err
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdftrim(a_input)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
character*(*) a_input
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
character*320 a_value
integer i
integer i_len
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
c PROCESSING STEPS:
i_len=len(a_input)
i_len = rdflen(a_input)
call rdf_trace('RDFTRIM')
a_value = a_input
if (i_len .gt. 0) then
if (i_len .gt. 320) then
write(6,*) 'String rdflen exceeds 320 in rdftrim ',i_len
write(6,*) a_input
endif
i = 1
do while ((i .lt. i_len) .and.
& (a_value(i:i) .eq. char(32) .or. a_value(i:i) .eq. char(9)))
i = i + 1
enddo
a_value = a_value(i:)
i_len = i_len - i + 1
do while ((i_len .gt. 1) .and.
& (a_value(i_len:i_len) .eq. char(32) .or. a_value(i_len:i_len) .eq. char(9)))
i_len = i_len - 1
enddo
a_value = a_value(1:i_len)
if (a_value(1:1) .eq. char(9)) a_value = a_value(2:)
endif
rdftrim = a_value
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfcullsp(a_temp)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
integer i_pos
integer i_len
character*(*) a_temp
character*320 a_temp2
character*320 a_string
integer*4 rdflen
external rdflen
call rdf_trace('RDFCULLSP')
a_string=a_temp ! replace tabs with spaces
c type *,'a_string=',a_string(1:max(1,rdflen(a_string)))
i_pos = index(a_string,char(9))
do while (i_pos .ne. 0)
a_string(i_pos:i_pos) = ' '
c type *,'a_string=',a_string(1:max(1,rdflen(a_string))),i_pos
i_pos = index(a_string,char(9))
end do
c type *,' '
i_len = rdflen(a_string)
i_pos = index(a_string,' ') ! convert multiple spaces to single spaces
do while (i_pos .ne. 0 .and. i_pos .lt. rdflen(a_string))
a_string=a_string(:i_pos)//a_string(i_pos+2:)
c type *,'a_string=',a_string(1:max(1,rdflen(a_string))),i_pos
i_len = i_len-1
i_pos = index(a_string,' ')
end do
a_temp2 = a_string ! (1:max(1,rdflen(a_string)))
rdfcullsp = a_temp2
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdflower(a_inpval)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
character*(*) a_inpval
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
character*320 a_outval
integer i
integer i_len
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDFLOWER')
i_len = rdflen(a_inpval)
a_outval = ' '
do i=1,i_len
if (ichar(a_inpval(i:i)) .ge. 65 .and. ichar(a_inpval(i:i)) .le. 90 ) then
a_outval(i:i) = char(ichar(a_inpval(i:i))+32)
else
a_outval(i:i) = a_inpval(i:i)
endif
enddo
rdflower=a_outval
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfupper(a_inpval)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
character*(*) a_inpval
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
character*320 a_outval
integer i
integer i_len
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDFUPPER')
i_len = rdflen(a_inpval)
a_outval = ' '
do i=1,i_len
if (ichar(a_inpval(i:i)) .ge. 97 .and. ichar(a_inpval(i:i)) .le. 122 ) then
a_outval(i:i) = char(ichar(a_inpval(i:i))-32)
else
a_outval(i:i) = a_inpval(i:i)
endif
enddo
rdfupper=a_outval
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfint(i_num,i_data)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
integer i_num
integer i_data(*)
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i
character*320 a_fmt
character*320 a_outval
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDFINT')
if (a_intfmt .eq. '*') then
write(unit=a_outval,fmt=*) (i_data(i),i=1,i_num)
else
write(a_fmt,'(a,i2,a,a)') '(',i_num,a_intfmt(1:max(rdflen(a_intfmt),1)),')'
write(unit=a_outval,fmt=a_fmt) (i_data(i),i=1,i_num)
endif
rdfint=a_outval
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfint1(i_data)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
integer i_data
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
character*320 a_outval
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDFINT1')
write(a_outval,*) i_data
rdfint1=a_outval
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfint2(i_data1,i_data2)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
integer i_data1
integer i_data2
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
character*320 a_outval
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDFINT2')
write(a_outval,*) i_data1,i_data2
rdfint2=a_outval
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfint3(i_data1,i_data2,i_data3)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
integer i_data1
integer i_data2
integer i_data3
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
character*320 a_outval
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDFINT3')
write(a_outval,*) i_data1,i_data2,i_data3
rdfint3=a_outval
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfreal(i_num,r_data)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
integer*4 i_num
real*4 r_data(*)
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i
character*320 a_fmt
character*320 a_outval
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDFREAL')
if (a_realfmt .eq. '*') then
write(unit=a_outval,fmt=*) (r_data(i),i=1,i_num)
else
write(a_fmt,'(a,i2,a,a)') '(',i_num,a_realfmt(1:max(rdflen(a_realfmt),1)),')'
write(unit=a_outval,fmt=a_fmt) (r_data(i),i=1,i_num)
endif
rdfreal=a_outval
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfreal1(r_data)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
real*4 r_data
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
character*320 a_outval
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDFREAL1')
write(a_outval,*) r_data
rdfreal1=a_outval
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfreal2(r_data1,r_data2)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
real*4 r_data1,r_data2
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
character*320 a_outval
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDFREAL2')
write(a_outval,*) r_data1,r_data2
rdfreal2=a_outval
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfreal3(r_data1,r_data2,r_data3)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
real*4 r_data1,r_data2,r_data3
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
character*320 a_outval
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDFREAL3')
write(a_outval,*) r_data1,r_data2,r_data3
rdfreal3=a_outval
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfdble(i_num,r_data)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
integer*4 i_num
real*8 r_data(*)
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i
character*320 a_fmt
character*320 a_outval
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDFDBLE')
if (a_dblefmt .eq. '*') then
write(unit=a_outval,fmt=*) (r_data(i),i=1,i_num)
else
write(a_fmt,'(a,i2,a,a)') '(',i_num,'('//a_dblefmt(1:max(rdflen(a_dblefmt),1)),',x))'
write(unit=a_outval,fmt=a_fmt) (r_data(i),i=1,i_num)
endif
rdfdble=a_outval
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfdble1(r_data)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
real*8 r_data
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
character*320 a_outval
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDFDBLE1')
write(a_outval,*) r_data
rdfdble1=a_outval
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfdble2(r_data1,r_data2)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
real*8 r_data1,r_data2
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
character*320 a_outval
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDFDBLE2')
write(a_outval,*) r_data1,r_data2
rdfdble2=a_outval
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfdble3(r_data1,r_data2,r_data3)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
real*8 r_data1,r_data2,r_data3
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
character*320 a_outval
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDFDBLE3')
write(a_outval,*) r_data1,r_data2,r_data3
rdfdble3=a_outval
call rdf_trace(' ')
return
end
c****************************************************************
integer*4 function rdflen(a_string)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION: This function returns the position
c** of the last none blank character in the string.
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
character*(*) a_string
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_len
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
c PROCESSING STEPS:
call rdf_trace('RDFLEN')
i_len=len(a_string)
do while(i_len .gt. 0 .and. (a_string(i_len:i_len) .eq. ' ' .or.
& ichar(a_string(i_len:i_len)) .eq. 0))
i_len=i_len-1
c write(6,*) i_len,' ',ichar(a_string(i_len:i_len)),' ',a_string(i_len:i_len)
enddo
rdflen=i_len
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfquote(a_string)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
character*(*) a_string
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_string
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
C FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDFQUOTE')
i_string = rdflen(a_string)
rdfquote = '"'//a_string(1:i_string)//'"'
call rdf_trace(' ')
return
end
c****************************************************************
character*(*) function rdfunquote(a_string)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
character*(*) a_string
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i_string
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
C FUNCTION_STATEMENTS:
c PROCESSING STEPS:
call rdf_trace('UNRDFQUOTE')
call rdf_unquote(a_string,i_string)
rdfunquote = a_string
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_unquote(a_string,i_string)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
character*(*) a_string
c OUTPUT VARIABLES:
integer i_string
c LOCAL VARIABLES:
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
C FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDF_UNQUOTE')
i_string = rdflen(a_string)
if (i_string .gt. 1) then
if (a_string(1:1) .eq. '"' .and. a_string(i_string:i_string) .eq. '"' ) then
if (i_string .eq. 2) then
a_string = ' '
else
a_string = a_string(2:i_string-1)
endif
i_string = i_string-2
endif
endif
call rdf_trace(' ')
return
end
c****************************************************************
integer*4 function rdfmap(i,j,k)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
integer i
integer j
integer k
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
C FUNCTION_STATEMENTS:
c PROCESSING STEPS:
call rdf_trace('RDF_MAP')
if (k .eq. 0) then
rdfmap = 0
else if (k .eq. 1) then
rdfmap = i
else if (k .eq. 2) then
rdfmap = j
else
rdfmap = 0
endif
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_indices(a_dimn,i_dimn,i_strt,i_stop,i_order)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
character*(*) a_dimn
c OUTPUT VARIABLES:
integer i_dimn
integer i_order(20)
integer i_strt(20)
integer i_stop(20)
c LOCAL VARIABLES:
integer i
integer i_pos
integer i_stat
integer i_fields
character*320 a_fields(100)
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
C FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDF_INDICES')
call rdf_getfields(a_dimn,i_fields,a_fields)
do i=1,i_fields
i_pos = index(a_fields(i),'-')
if (i_pos .gt. 0) then
if (i_pos .gt. 1) then
read(a_fields(i)(1:i_pos-1),'(i10)',iostat=i_stat) i_order(i)
if (i_stat .ne. 0) then
write(6, *) '*** RDF ERROR *** Cannot parse indices order field ',a_fields(i)(1:i_pos-1)
i_order(i) = 1
endif
else
i_order(i) = i
endif
a_fields(i) = a_fields(i)(i_pos+1:)
else
i_order(i) = i
endif
i_pos = index(a_fields(i),':')
if (i_pos .gt. 0) then
if (i_pos .gt. 1) then
read(a_fields(i)(1:i_pos-1),'(i10)',iostat=i_stat) i_strt(i)
if (i_stat .ne. 0) then
write(6, *) '*** RDF ERROR *** Cannot parse indices start field ',a_fields(i)(1:i_pos-1)
i_strt(i) = 1
endif
else
i_strt(i) = 1
endif
a_fields(i) = a_fields(i)(i_pos+1:)
else
i_strt(i) = 1
endif
i_pos=max(1,rdflen(a_fields(i))) ! inserted for Vax compatibility
read(unit=a_fields(i)(1:i_pos),fmt='(i10)',iostat=i_stat) i_stop(i)
if (i_stat .ne. 0) then
write(6, *) '*** RDF ERROR *** Cannot parse indices stop field: ',rdflen(a_fields(i)),':',
& a_fields(i)(1:max(1,rdflen(a_fields(i))))
i_stop(i) = i_strt(i)
endif
enddo
i_dimn = i_fields
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_getfields(a_string,i_values,a_values)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INPUT VARIABLES:
character*(*) a_string
c OUTPUT VARIABLES:
character*(*) a_values(*)
integer i_values
c LOCAL VARIABLES:
integer i
integer i_on
integer i_cnt
integer i_quote
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
C FUNCTION_STATEMENTS:
c PROCESSING STEPS:
call rdf_trace('RDF_GETFIELDS')
i_on = 0
i_cnt = 0
i_values = 0
i_quote = 0
do i=1,len(a_string)
if (i_quote .eq. 1 .or. (
& a_string(i:i) .ne. ' ' .and.
& a_string(i:i) .ne. ',' .and.
& a_string(i:i) .ne. char(9)) ) then
if (i_on .eq. 0) then
i_on = 1
i_cnt = 0
i_values=min(i_values+1,100)
a_values(i_values)=' '
endif
if (a_string(i:i) .eq. '"') then
i_quote=1-i_quote
endif
i_cnt = i_cnt+1
a_values(i_values)(i_cnt:i_cnt) = a_string(i:i)
else
if (i_quote .eq. 0) then
i_on = 0
i_cnt = 0
endif
endif
enddo
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_parse(a_data,a_keyw,a_unit,a_dimn,a_elem,a_oper,a_valu,a_cmnt)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
integer i
character*(*) a_data
c OUTPUT VARIABLES:
character*(*) a_keyw
character*(*) a_valu
character*(*) a_unit
character*(*) a_dimn
character*(*) a_elem
character*(*) a_oper
character*(*) a_cmnt
character*320 a_errtmp
c LOCAL VARIABLES:
integer i_type
integer i_keyw
integer i_valu
integer i_unit
integer i_dimn
integer i_elem
integer i_oper
integer i_cmnt
integer i_lun
integer i_iostat
c COMMON BLOCKS:
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
character*320 rdftrim
external rdftrim
c PROCESSING STEPS:
call rdf_trace('RDF_PARSE')
a_keyw = ' '
a_valu = ' '
a_oper = ' '
a_unit = ' '
a_dimn = ' '
a_elem = ' '
a_cmnt = ' '
i_keyw = 0
i_valu = 0
i_oper = 0
i_unit = 0
i_elem = 0
i_dimn = 0
i_cmnt = 0
i_type = 1
do i=1,rdflen(a_data)
if (i_type .eq. 0) then
i_cmnt = i_cmnt + 1
if (i_cmnt .le. I_MCPF) a_cmnt(i_cmnt:i_cmnt) = a_data(i:i)
else if (a_data(i:i) .eq. a_cmdl(0) .and. a_cmdl(0) .ne. ' ') then
i_type = 0
else if (a_data(i:i) .eq. a_cmdl(1) .and. a_cmdl(1) .ne. ' ') then
i_type = 0
else if (a_data(i:i) .eq. a_cmdl(2) .and. a_cmdl(2) .ne. ' ') then
i_type = 0
else if (i_type .eq. 10) then
i_valu = i_valu + 1
if (i_valu .le. I_MCPF) then
a_valu(i_valu:i_valu) = a_data(i:i)
else if (i_valu .eq. I_MCPF+1) then
a_errtmp = '*** WARNING *** RDF_PARSE - Value field exceeds max characters per line. '//
& a_cmnt
call rdf_error(a_errtmp)
endif
else if (a_data(i:i) .eq. '(' ) then
i_type = 2
else if (a_data(i:i) .eq. ')' ) then
i_type = 1
else if (a_data(i:i) .eq. '[' ) then
i_type = 3
else if (a_data(i:i) .eq. ']' ) then
i_type = 1
else if (a_data(i:i) .eq. '{' ) then
i_type = 4
else if (a_data(i:i) .eq. '}' ) then
i_type = 1
else if (a_data(i:i) .eq. '=' ) then
i_type = 10
a_oper = '='
else if (a_data(i:i) .eq. '<' ) then
i_type = 10
a_oper = '<'
else if (a_data(i:i) .eq. '>' ) then
i_type = 10
a_oper = '>'
else if (i_type .eq. 1) then
i_keyw = i_keyw + 1
if (i_keyw .le. I_MCPF) a_keyw(i_keyw:i_keyw) = (a_data(i:i))
else if (i_type .eq. 2) then
i_unit = i_unit + 1
if (i_unit .le. I_MCPF) a_unit(i_unit:i_unit) = (a_data(i:i))
else if (i_type .eq. 3) then
i_dimn = i_dimn + 1
if (i_dimn .le. I_MCPF) a_dimn(i_dimn:i_dimn) = (a_data(i:i))
else if (i_type .eq. 4) then
i_elem = i_elem + 1
if (i_elem .le. I_MCPF) a_elem(i_elem:i_elem) = (a_data(i:i))
endif
enddo
if (i_cmnt .eq. I_MCPF+1) then
a_errtmp = '*** WARNING *** Comment field exceeds max characters per line. '//
& a_cmnt
call rdf_error(a_errtmp)
endif
if (i_keyw .eq. I_MCPF+1) then
a_errtmp = 'Keyword field exceeds max characters per line. '//
& a_cmnt
call rdf_error(a_errtmp)
endif
if (i_unit .eq. I_MCPF+1) then
a_errtmp = 'Unit field exceeds max characters per line. '//
& a_unit
call rdf_error(a_errtmp)
endif
if (i_dimn .eq. I_MCPF+1) then
a_errtmp = 'Dimension field exceeds max characters per line. '//
& a_dimn
call rdf_error(a_errtmp)
endif
if (i_elem .eq. I_MCPF+1) then
a_errtmp = 'Element field exceeds max characters per line. '//
& a_elem
call rdf_error(a_errtmp)
endif
a_keyw = rdftrim(a_keyw)
a_valu = rdftrim(a_valu)
a_unit = rdftrim(a_unit)
a_dimn = rdftrim(a_dimn)
a_elem = rdftrim(a_elem)
a_oper = rdftrim(a_oper)
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_unparse(a_data,a_keyw,a_unit,a_dimn,a_elem,a_oper,a_valu,a_cmnt)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_keyw
character*(*) a_valu
character*(*) a_unit
character*(*) a_dimn
character*(*) a_elem
character*(*) a_oper
character*(*) a_cmnt
c OUTPUT VARIABLES:
character*(*) a_data
c LOCAL VARIABLES:
integer i
integer i_tabs(10)
integer i_keyw
integer i_valu
integer i_unit
integer i_dimn
integer i_elem
integer i_oper
integer i_cmnt
character*320 a_ktemp
character*320 a_otemp
character*320 a_vtemp
character*320 a_ctemp
character*320 a_utemp
character*320 a_dtemp
character*320 a_etemp
character*320 a_cdel
c COMMON BLOCKS
c EQUIVALENCE STATEMENTS:
c DATA STATEMENTS:
c FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
c PROCESSING STEPS:
call rdf_trace('RDF_UNPARSE')
if (a_keyw .eq. ' ' .and. a_unit .eq. ' ' .and.
& a_valu .eq. ' ' .and. a_oper .eq. ' ') then
if (a_cmnt .eq. ' ') then
a_data = ' '
else
a_cdel = a_cmdl(0)
c if (a_cdel .eq. ' ') a_cdel = '!'
c a_data = a_cdel(1:max(rdflen(a_cdel),1))//' '//a_cmnt(1:rdflen(a_cmnt))
if (a_cdel .eq. ' ') then
a_data = ' '
else
a_data = a_cdel(1:max(rdflen(a_cdel),1))//' '//a_cmnt(1:rdflen(a_cmnt))
endif
endif
else
a_cdel = a_cmdl(0)
c if (a_cdel .eq. ' ') a_cdel = '!'
if (a_cmnt .eq. ' ' .and. i_delflag(1) .eq. 1) a_cdel = ' '
a_ktemp = a_keyw
a_otemp = a_oper
a_vtemp = a_valu
a_utemp = ' '
a_dtemp = ' '
a_etemp = ' '
if (a_cdel .eq. ' ') then
a_ctemp = ' '
else
a_ctemp = a_cdel(1:max(rdflen(a_cdel),1))//' '//a_cmnt(1:max(rdflen(a_cmnt),1))
endif
if (a_unit .ne. ' ') a_utemp = '('//a_unit(1:max(rdflen(a_unit),1))//')'
if (a_dimn .ne. ' ') a_dtemp = '['//a_dimn(1:max(rdflen(a_dimn),1))//']'
if (a_elem .ne. ' ') a_etemp = '{'//a_elem(1:max(rdflen(a_elem),1))//'}'
i_tabs(1) = i_fsizes(1)
do i = 2,7
i_tabs(i) = i_tabs(i-1) + i_fsizes(i)
enddo
i_keyw = min(max(rdflen(a_ktemp) + 1, i_tabs(1) ),320)
i_unit = min(max(rdflen(a_utemp) + 1, i_tabs(2) - i_keyw),320)
i_dimn = min(max(rdflen(a_dtemp) + 1, i_tabs(3) - i_unit - i_keyw),320)
i_elem = min(max(rdflen(a_etemp) + 1, i_tabs(4) - i_dimn - i_unit - i_keyw),320)
i_oper = min(max(rdflen(a_otemp) + 1, i_tabs(5) - i_elem - i_dimn - i_unit - i_keyw),320)
i_valu = min(max(rdflen(a_vtemp) + 1, i_tabs(6) - i_oper - i_elem - i_dimn - i_unit - i_keyw),320)
i_cmnt = min(max(rdflen(a_ctemp) + 1, i_tabs(7) - i_valu - i_oper - i_elem - i_dimn - i_unit - i_keyw),320)
a_data = a_ktemp(1:i_keyw)//a_utemp(1:i_unit)//a_dtemp(1:i_dimn)//a_etemp(1:i_elem)//
& a_otemp(1:i_oper)//a_vtemp(1:i_valu)//a_ctemp(1:i_cmnt)
endif
call rdf_trace(' ')
return
end
c****************************************************************
subroutine rdf_trace(a_routine)
c****************************************************************
c**
c** FILE NAME: rdf_reader.f
c**
c** DATE WRITTEN: 15-Sept-1997
c**
c** PROGRAMMER: Scott Shaffer
c**
c** FUNCTIONAL DESCRIPTION:
c**
c** ROUTINES CALLED:
c**
c** NOTES:
c**
c** UPDATE LOG:
c**
c** Date Changed Reason Changed CR # and Version #
c** ------------ ---------------- -----------------
c**
c*****************************************************************
implicit none
c INCLUDE FILES
include 'rdf_common.inc'
c INPUT VARIABLES:
character*(*) a_routine
c OUTPUT VARIABLES:
c LOCAL VARIABLES:
integer i
integer i_setup
c COMMON BLOCKS
c EQUIVALENCE STATEMENTS:
c FUNCTION_STATEMENTS:
integer*4 rdflen
external rdflen
c DATA STATEMENTS:
data i_setup /0/
save i_setup
c PROCESSING STEPS:
if (i_setup .eq. 0) then
i_stack = 0
i_setup = 1
endif
if (a_routine .ne. ' ') then
i_stack = i_stack+1
if (i_stack .gt. 0 .and. i_stack .le. 10) a_stack(i_stack) = a_routine
c type *,'TRACE IN: i_stack=',i_stack,' ',a_stack(i_stack)
else
c type *,'TRACE OUT: i_stack=',i_stack,' ',a_stack(i_stack)
if (i_stack .gt. 0 .and. i_stack .le. 10) a_stack(i_stack) = ' '
i_stack = max(i_stack - 1, 0)
endif
return
end
c The following is a commented out version of the include file that must accompany the source code
cc PARAMETER STATEMENTS:
c integer I_PARAMS
c parameter(I_PARAMS = 500)
c
c integer I_MCPF
c parameter(I_MCPF = 320)
c
c integer i_nums
c integer i_pntr
c character*320 a_dsets(I_PARAMS)
c character*320 a_prfxs(I_PARAMS)
c character*320 a_sufxs(I_PARAMS)
c character*320 a_strts(I_PARAMS)
c character*320 a_matks(I_PARAMS)
c character*320 a_keyws(I_PARAMS)
c character*320 a_units(I_PARAMS)
c character*320 a_dimns(I_PARAMS)
c character*320 a_elems(I_PARAMS)
c character*320 a_opers(I_PARAMS)
c character*320 a_cmnts(I_PARAMS)
c character*320 a_valus(I_PARAMS)
c common /params/ i_pntr,i_nums,a_dsets,a_prfxs,a_sufxs,a_strts,a_matks,
c & a_keyws,a_units,a_dimns,a_elems,a_opers,a_valus,a_cmnts
c
c integer i_errflag(3)
c integer i_error
c character*320 a_error(I_PARAMS)
c character*320 a_errfile
c common /errmsg/ i_errflag,i_error,a_error,a_errfile
c
c integer i_fsizes(10)
c character*320 a_intfmt
c character*320 a_realfmt
c character*320 a_dblefmt
c common /inital/ i_fsizes,a_intfmt,a_realfmt,a_dblefmt
c
c integer i_prelen
c integer i_suflen
c character*320 a_prfx
c character*320 a_sufx
c character*320 a_prefix
c character*320 a_suffix
c common /indata/ a_prfx,a_sufx,a_prefix,a_suffix,i_prelen,i_suflen
c 3456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012
c 1 2 3 4 5 6 7 8 9 100 110 120 130
Reference in New Issue View Git Blame Copy Permalink