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