subroutine directive_set(line) implicit none include 'parameters.inc' include 'tables.inc' character*(*) line character*31 name character*(max_line_length) line2 integer*4 line_length,i,j,name_entry,string_entry,k logical first,found,error integer*4 type,result_value,result_string_length,scan_next logical result_logical character*(max_line_length) result_string integer*4 action_required,do_set,do_replace,do_default parameter (do_set=1,do_replace=2,do_default=3) action_required=do_set goto 1 entry directive_replace(line) action_required=do_replace goto 1 entry directive_default(line) action_required=do_default 1 continue name=' ' line_length=len(line) call convert_case(line,line2) c scan to left parren i=1 do while(line(i:i).ne.'('.and.i.le.line_length) i=i+1 enddo if(i.gt.line_length)then call log_error( 1 ' ****SET/REPLACE syntax error-no left parren****') return endif i=i+1 if(i.gt.line_length)then call log_error( 1 ' ****SET/REPLACE syntax error-nothing after left paren****') return endif c find start of name call skip_blanks(line(i:line_length),j) if(j.eq.0)then call log_error(' ****SET/REPLACE syntax error-no name****') return endif i=i+j-1 c .load name into name string call get_name(line2(i:line_length),j, 1 name,name_entry,found,error) if(error)return i=i+j-1 if(name.eq.' ')then call log_error( 1 ' ****SET/REPLACE syntax error-no name specified****') return endif if(found.and.(action_required.eq.do_set))then call log_error( 1 ' ****SET/REPLACE '//name//' already defined****') return elseif(.not.found.and.(action_required.eq.do_replace))then call log_error( 1 ' ****SET/REPLACE '//name//' not defined****') elseif(found.and.(action_required.eq.do_default))then return endif call skip_blanks(line(i:line_length),j) if(j.eq.0)then call log_error( 1 ' ****SET/REPLACE syntax error-no = after var name****') return endif i=i+j-1 if(line(i:i).ne.'=')then call log_error( 1 ' ****SET/REPLACE no = after var name****') return endif i=i+1 c find start of value assigned call skip_blanks(line(i:line_length),j) if(j.eq.0)then call log_error( 1 ' ****SET/REPLACE syntax error-no value specified****') return endif i=i+j-1 call evaluate(line(i:line_length),type,result_logical,result_value, 1 result_string,result_string_length,scan_next) c when doing a replace-all that really needs to be deleted is any c strings or lists or macro entries assosiated with the entry. c the name table entry is immediately reused so any values c are overwritten if(found.and.action_required.eq.do_replace)then if(name_table(name_entry).type.eq.type_string)then j=name_table(name_entry).string_loc if(j.ne.0)then string_table(j).next_string=0 string_table(j).string=' ' string_table(j).in_use=.false. endif elseif(name_table(name_entry).type.eq.type_list)then j=name_table(name_entry).string_loc do while(j.ne.0) k=string_table(j).next_string string_table(j).next_string=0 string_table(j).string=' ' string_table(j).in_use=.false. j=k enddo elseif(name_table(name_entry).type.eq.type_macro)then j=name_table(name_entry).first_line_loc do while(j.ne.0) k=string_table(j).next_string string_table(j).next_string=0 string_table(j).string=' ' string_table(j).in_use=.false. j=k enddo endif endif if(type.eq.res_string)then call get_new_string(string_entry) name_table(name_entry).name=name name_table(name_entry).inuse=.true. name_table(name_entry).type=type_string name_table(name_entry).string_loc=string_entry string_table(string_entry).in_use=.true. string_table(string_entry).next_string=0 string_table(string_entry).string=result_string elseif(type.eq.res_integer)then name_table(name_entry).name=name name_table(name_entry).inuse=.true. name_table(name_entry).type=type_value name_table(name_entry).integer_value=result_value elseif(type.eq.res_logical)then name_table(name_entry).name=name name_table(name_entry).inuse=.true. name_table(name_entry).type=type_logical name_table(name_entry).logical_value=result_logical else call log_error(' ****SET/REPLACE unknown/illegal type****') endif i=i+scan_next-1 call skip_blanks(line(i:line_length),j) if(j.eq.0)then call log_error(' ****SET/REPLACE no closeing parren****') return endif i=i+j-1 if(i.gt.line_length)then call log_error(' ****SET/REPLACE no closeing parren****') return endif if(line(i:i).ne.')')then call log_error(' ****SET/REPLACE no closeing parren****') return endif return end