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_f90.F

5391 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
cbjs The below line would produce a format string a_fmt="( 2i)"
cbjs which is a syntactic error since the 'i' does not have
cbjs a width specified. ifort, f95, and pgf95 did not reject it.
cbjs However, it was rejected by g95 and gfortran.
cbjs f95 treated the 'i' as 'i0'. The others treated it as 'i12'.
cbjs Modification will force a '0' for the field width
cbjs causing a_fmt="( 2i0)" (when i_num=2)
c write(a_fmt,'(a,i2,a,a)') '(',i_num,a_intfmt(1:max(rdflen(a_intfmt),1)),')'
write(a_fmt,'(a,i2,a,"0",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)),',1x))'
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