! ! view ! ! dump current record we are editing ! integer function view byte buffer(32768),edit_buffer(32768) common /buf/ buffer,edit_buffer,length_total call special(edit_buffer,length_total,1,' ',1) view=1 return end ! ! show current ! ! show current macro definition we are working with ! integer function show_current implicit integer*4 (a-z) character*255 macro_name,macro_definition common /mine/ macro_definition,macro_name character*1 blank data blank /' '/ i=index(macro_definition,blank)-1 if (i.le.0) then type 10 10 format(' No current macro definition') else type 20,macro_definition(1:i) 20 format(' Current macro definition is '/x,a) endif show_current=1 return end ! ! contains utility fortran subroutines for fdmp ! integer function show_flags() include 'flags.inc' logical reverse_on common /rflag/ reverse_on call do_flag('Byte reversal on input is',reverse_on) call do_flag('Display of record contents is',display_on) call do_flag('Printing of record contents is',print_on) call do_flag('Display of record lengths is',summary_on) call do_flag('Full-screen dump is ',full_screen) call do_flag('Currently reading commands from file?',readin) call do_flag('Echo of commands read in from file?',echo_on) call do_flag('Writing commands to log file?',logging) show_flags=1 return end subroutine do_flag(text,flag) logical flag character*(*) text character*5 state if (flag) then state='True' else state='False' endif type 10,text,state 10 format(x,a,x,a) return end integer function clean_up open(unit=9,type='old',name='fdmpwork1',err=8000) close(unit=9,dispose='delete') 8000 open(unit=10,type='old',name='fdmpwork2',err=9000) close(unit=10,dispose='delete') 9000 continue return end integer function out_file character*63 file_name common /files/ file_name character*80 real_file_name character*1 blank data blank /' '/ open(unit=3,name=file_name,type='old',readonly,err=20,shared) inquire(3,name=real_file_name) close(unit=3) ireal=index(real_file_name,blank)-1 type 10,real_file_name(1:ireal) 10 format(/' Current file is:'/,x,a/) 20 out_file=1 return end integer function check_file character*63 file_name character*15 format common /files/ file_name include 'flags.inc' bad_file_open=.false. open(unit=3,type='old',name=file_name,readonly,shared,err=10) close(unit=3) if (scratch_variable.eq.1) then variable=.true. else variable=.false. endif check_file=1 return 10 type 20,file_name 20 format(/' Unable to open file: '/3x,a/) bad_file_open=.true. variable=.false. check_file=1 return end subroutine store_macro(idef,iname) ! ! define things for common buffer ! character*255 macro_definition,macro_name common /mine/ macro_definition,macro_name character*255 macro_defs(20),macro_names(20) common /macros/ macro_defs,macro_names,no_defined if (idef.eq.0) then type 5 5 format(/' Invalid macro definition '/) return endif no_defined=no_defined+1 if (no_defined.gt.20) then type 10 10 format(/' Too many macros defined -- ignored '/) return endif macro_names(no_defined)=macro_name(1:iname) macro_defs(no_defined)=macro_definition(1:idef) return end ! ! get macro definitions ! subroutine get_def(ilength) character*255 macro_defs(20),macro_names(20) common /macros/ macro_defs,macro_names,no_defined character*255 macro_definition,macro_name common /mine/ macro_definition,macro_name macro_definition=' ' do i=1,no_defined if (macro_name(1:ilength).eq. 1 macro_names(i)(1:ilength)) macro_definition= 2 macro_defs(i) enddo return end ! ! show macro definitions ! subroutine show_def(ilength,dump_all) logical dump_all character*255 macro_definition,macro_name common /mine/ macro_definition,macro_name character*255 macro_defs(20),macro_names(20) common /macros/ macro_defs,macro_names,no_defined if (no_defined.le.0) then type 5 5 format(' No macros defined') return endif if (dump_all) then type 10 10 format(/x,'Name',10x,'Definition'/) endif do i=1,no_defined if (dump_all) then call out_def(i) else if (macro_name(1:ilength).eq. 1 macro_names(i)(1:ilength)) 2 call out_def(i) endif enddo return end ! ! routine to display macro definitions ! subroutine out_def(idef) character*255 macro_defs(20),macro_names(20) common /macros/ macro_defs,macro_names,no_defined character*1 blnk data blnk /' '/ iblnk=index(macro_names(idef),blnk)-1 if (iblnk.le.1) iblnk=1 if (iblnk.le.8) ispace=jmax0(14-iblnk,1) iblnk1=index(macro_defs(idef),blnk)-1 if (iblnk1.le.1) iblnk1=1 type 20,macro_names(idef)(1:iblnk),macro_defs(idef)(1:iblnk1) 20 format(x,a,x,a) return end ! ! remove macro definitions ! subroutine remove_macro(ilength,kill_all) logical kill_all character*255 macro_definition,macro_name common /mine/ macro_definition,macro_name character*255 macro_defs(20),macro_names(20) common /macros/ macro_defs,macro_names,no_defined if (no_defined.le.0) then type 5 5 format(' No macros defined') return endif ikept=0 do 100 i=1,no_defined if (kill_all) then goto 100 else if (macro_name(1:ilength).eq. 1 macro_names(i)(1:ilength)) 2 goto 100 endif ikept=ikept+1 macro_names(ikept)=macro_names(i) macro_defs(ikept)=macro_defs(i) 100 continue no_defined=ikept if (no_defined.eq.0) then do i=1,255 macro_definition(i:i)=char(0) enddo endif return end ! ! stop current command processing ! subroutine forget_command(array) real*8 array logical attention_flag,display_message common /control_c/ attention_flag,display_message attention_flag=.true. return end integer function open_file character*63 command_file common /reading/ command_file include 'flags.inc' open_file=.true. open(unit=2,name=command_file,type='old',readonly,err=9000,shared) readin=.true. return 9000 readin=.false. type 9010,command_file 9010 format(/' Error opening:'/3x,a/ 1 ' for reading '/) return end