subroutine directive_domacro(line) implicit none include 'parameters.inc' include 'tables.inc' include 'io_control.inc' character*(*) line integer*4 line_length,i,j,k,l,m,n,o,nextloc,table_loc,entry,im character*31 name logical in_table,error,free_form integer*4 quote_nest,table_pos character*(max_line_length) argument(max_argument) free_form=.false. goto 1 entry directive_domacro_freeform(line,table_pos) free_form=.true. 1 continue do i=1,max_argument argument(i)=' ' enddo line_length=len(line) if(free_form)then table_loc=table_pos i=1 else call skip_blanks(line,i) if(i.eq.0)then call log_error(' ****DOMACRO no opening parren****') return elseif(line(i:i).ne.'(')then call log_error(' ****DOMACRO no opening parren****') return endif i=i+1 call get_name(line(i:line_length),nextloc, 1 name,table_loc,in_table,error) if(error)then call log_error(' ****DOMACRO error getting macro name****') return elseif(.not.in_table)then call log_error(' ****DOMACRO '//name//' not defined****') return elseif(name_table(table_loc).type.ne.type_macro)then call log_error( ' ****DOMACRO '//name//' not a macro****') return endif i=i+nextloc-1 call skip_blanks(line(i:line_length),j) if(j.eq.0)then call log_error(' ****DOMACRO no closeing parren****') return elseif(line(i+j-1:i+j-1).ne.')')then call log_error(' ****DOMACRO no closeing parren****') return endif i=i+j endif c now scan for any arguments that have been declared n=1 do while(n.le.max_argument) if(i.gt.line_length)goto 200 call skip_blanks(line(i:line_length),m) if(m.eq.0)goto 200 i=i+m-1 if(line(i:i).ne.'(')goto 200 l=1 quote_nest=0 if(i.gt.line_length)goto 150 if(line(i:i).eq.')'.and.quote_nest.eq.0)goto 150 do while(.true.) if(line(i:i).eq.quote_char)then if(quote_nest.eq.0)then quote_nest=1 else quote_nest=0 endif endif argument(n)(l:l)=line(i:i) if(line(i:i).eq.esc_char)then i=i+1 l=l+1 argument(n)(l:l)=line(i:i) endif i=i+1 l=l+1 if(i.gt.line_length)goto 150 if(line(i:i).eq.')'.and.quote_nest.eq.0)goto 150 enddo 150 argument(n)(l:l)=')' if(line(i:i).ne.')')then call log_error( 1 ' ****DOMACRO bad argument termination****') return endif n=n+1 i=i+1 enddo 200 continue n=n-1 current_unit=current_unit+1 if(current_unit-input_unit.gt.max_include_nest)then call log_error(' ****DOMACRO includes nested too deep****') current_unit=current_unit-1 return endif input_stream(current_unit-input_unit).file_io=.false. input_stream(current_unit-input_unit).first_string=0 input_stream(current_unit-input_unit).current_string=0 input_stream(current_unit-input_unit).line_count=0 do m=1,n call back_skip_blanks(argument(m),o) call get_new_string(entry) string_table(entry).string(1:o+4)='*set'//argument(m)(1:o) string_table(entry).in_use=.true. if(input_stream(current_unit-input_unit).first_string 1 .eq.0)then input_stream(current_unit-input_unit).first_string=entry input_stream(current_unit-input_unit).current_string=entry else im=input_stream(current_unit-input_unit).current_string input_stream(current_unit-input_unit).current_string=entry string_table(im).next_string=entry endif enddo k=name_table(table_loc).first_line_loc do while(k.ne.0) call back_skip_blanks(string_table(k).string,l) call get_new_string(entry) string_table(entry).string(1:l)=string_table(k).string(1:l) string_table(entry).in_use=.true. if(input_stream(current_unit-input_unit).first_string 1 .eq.0)then input_stream(current_unit-input_unit).first_string=entry input_stream(current_unit-input_unit).current_string=entry else im=input_stream(current_unit-input_unit).current_string input_stream(current_unit-input_unit).current_string=entry string_table(im).next_string=entry endif k=string_table(k).next_string enddo do m=1,n o=index(argument(m),'=') argument(m)(o:o)=')' call get_new_string(entry) string_table(entry).string(1:o+7)='*remove'//argument(m)(1:o) string_table(entry).in_use=.true. if(input_stream(current_unit-input_unit).first_string 1 .eq.0)then input_stream(current_unit-input_unit).first_string=entry input_stream(current_unit-input_unit).current_string=entry else im=input_stream(current_unit-input_unit).current_string input_stream(current_unit-input_unit).current_string=entry string_table(im).next_string=entry endif enddo if(l_list)then l_list=.false. call get_new_string(entry) string_table(entry).string(1:22)='*option(l_list=.true.)' string_table(entry).in_use=.true. if(input_stream(current_unit-input_unit).first_string 1 .eq.0)then input_stream(current_unit-input_unit).first_string=entry input_stream(current_unit-input_unit).current_string=entry else im=input_stream(current_unit-input_unit).current_string input_stream(current_unit-input_unit).current_string=entry string_table(im).next_string=entry endif endif input_stream(current_unit-input_unit).current_string= 1 input_stream(current_unit-input_unit).first_string return end