program dix implicit none c c Dump indexed files. C Version Author date comment C 1.0 F.S. 19-jan-1991 Initial release C 1.1 F.S. 1-mar-1991 Support for sequential files c 2.0 F.S. 1-jan-1992 Use of smg routines C 2.1 F.S. 26-feb-1992 Support block io C 2.2 F.S. 27-feb-1992 Support fieldnames for bits values C 2.3 F.S. 18-mar-1992 Support for multiple files c 3.0 F.S. 1-jul-1998 Multiple changes c support for parameters c support for run-time evaluation of expressions C 3.1 F.S. 10-mar-2003 Support for scripting in interactive mode c 3.2 F.S. 16-Jun-2003 Added user defined keys c 4.0 F.S. 7-may-2004 Added user defined types c 5.0 F.S. 19-apr-2006 Added a lot of new features, see the release_notes c c For further info the the Help file (DIX_HELP.HLB) and the release notes c c Start of coding c# include 'dix_def.inc' include '($stsdef)' include '($jpidef)' include '($dcdef)' include '($dvidef)' include '($syidef)' c C Function declaration C character*(max_line_length) line,libnam,defdir integer*4 nk,istat,k,nk_lib,nk_def,dt(2),timer_context logical may_update c external lib$get_input logical dix_dcl_parse logical cli$dispatch logical*4 cli$present integer*4 dix_main logical dix_main_check_library c record /control/ control c c Set global debug flag to all flags c call lib$get_symbol('DIX_DEBUG',line,nk) call str$upcase(line(1:1),line(1:1)) if(line(1:1) .eq. 'Y') control.debug = -1 call lib$get_symbol('DIX_STATISTICS',line,nk) call str$upcase(line(1:1),line(1:1)) if(line(1:1) .eq. 'Y') then call lib$init_timer(timer_context) else timer_context = 0 endif c c Open a channel to sys$output, for console messages c call lib$get_lun(control.lun_console) open(control.lun_console, 1 file='sys$output',recl=255, 1 status='new', 1 carriagecontrol='list') c c call sys$gettim(dt) if(2*(dt(1)/2) .eq. dt(1)) dt(1) = dt(1) + 1 !make odd c control.magic = magic_control control.prompt = 'DIX#>' control.nk_prompt = 5 c c Initial all control parameters c Get the current platform (vax,alpha,ia64) c call lib$getsyi(syi$_arch_name,,line) if (line(1:1) .eq. 'V') then control.platform = platform_vax elseif(line(1:1) .eq. 'A') then control.platform = platform_alpha elseif(line(1:1) .eq. 'I') then control.platform = platform_ipf endif c control.inter_control = substitute_symbols .or. 1 substitute_verb c control.search_block_size = 0 !max fastsearch block size control.n_vm_area_crea = 0 control.n_vm_area_dele = 0 control.n_memfiles_opened = 0 control.n_memfiles_closed = 0 c control.ran_seed = dt(1) !take low prec word control.dis_err = 0 !no error display yet control.nk_symb = 0 !no symbols yet control.nk_fnam_out = 0 !length of output filename control.real_size = 4 !set real size to 4 control.integer_size= 4 !set integer size to 4 control.smg_window = 0 !output in inteactive mode to SMG control.one_rec = .false. !We have a record selected control.help_depth = 0 !help depth to 0 control.include_binary = include_binary_dot control.bold_set = 0 !not yet bolded control.forward = .true. !search in foward mode control.msgmask = 0 !default all parts of message control.lun_out = 0 !no output file yet control.csv.csv = .false. !assume not csv format control.nb_save = 0 !no saved data yet control.input_flags = 0 !no special input flags control.decimal_ndig= 10 !#digits for divide control.decimal_round= .true. !round mode control.editor = dix_edit_internal !use internal editor control.got_pasteboard = .false. !no pasteboard yet control.n_descr = 0 !#desciptors control.top_descr = 0 !pointer to first descriptor control.n_file = 0 !#files open control.top_file = 0 !pointer to first file control.nk_userlib = 0 !length of user .tlb name control.nk_syslib = 0 !length of syslib .tlb anme control.strict_mode = 0 !no flags for strict mode control.use_mouse = .false. !assume no mouse usage control.paged = 0 !no paging mode control.depth = 0 !no depth control.wide_display= .false. !normal display control.top_level = 0 !pointer to top commandfile level control.cur_level = 0 !pointer to current commandifle level control.p_link_history = 0 !Pointer to link history do k=1,max_link_history control.link_history(k).p_file = 0 end do c call dix_search_init_search(control) control.lun_select = 0 c control.old_filep = -1 control.old_desp = -1 c c Set the format strings for reals c control.format_real4 = default_format_real4 control.format_real8 = default_format_real8 control.format_real16 = default_format_real16 c control.format_integer4 = default_format_integer4 control.format_integer8 = default_format_integer8 c c first check if sys$input is a terminal, if not screen is not possible c call lib$getdvi(dvi$_devclass,,'sys$input',k) control.is_term = k .eq. dc$_term c c Initialize keyboard mapping c call smg$create_virtual_keyboard(control.keyboard_id) call smg$create_key_table(control.keytable_id) c c Get command line in common block, so we can reparse it later c call lib$get_foreign(line,,nk) control.command_line = 'DIX '//line(1:nk) control.nk_command_line = nk + 4 c if(dix_dcl_parse(control, 1 control.command_line(1:control.nk_command_line), 1 .true.,.false.)) then c c Set debug flag c call dix_main_debug('debug',control) c c Init the symbol table c call dix_symbol_init(control) c c Init some memory zones c call init_vm(control,control.zone_file ,0,'FILES',.false.) call init_vm(control,control.zone_cfile ,0,'COMMAND_FILE',.false.) call init_vm(control,control.zone_general,0,'GENERAL',.false.) call init_vm(control,control.zone_descr ,0,'DESCRIPTIONS',.false.) call init_vm(control,control.zone_links ,0,'LINKS',.false.) c c Set keyboard type c control.keyboard = keyboard_normal if(cli$present('keyboard.pc')) control.keyboard = keyboard_pc if(cli$present('keyboard.laptop')) 1 control.keyboard = keyboard_laptop c call keydefs_init(control,.false.) c c Fill in the name of the text librarys (if found) c 1. system library c 2. userlibrary c call lib$getjpi(jpi$_imagname,,,,defdir,nk_def) call dix_util_file_parse(defdir(1:nk_def),'D',nk,nk_def) call cli$get_value('SYSTEM_LIBRARY',line,nk) if(dix_main_check_library(line(1:nk),libnam,nk_lib,may_update, 1 defdir(1:nk_def))) then control.may_write_to_syslib = may_update control.syslib_name = libnam(1:nk_lib) control.nk_syslib = nk_lib endif c call cli$get_value('USER_LIBRARY',line,nk) if(dix_main_check_library(line(1:nk),libnam,nk_lib,may_update, 1 'SYS$LOGIN:')) then control.may_write_to_userlib = .true. control.userlib_name = libnam(1:nk_lib) control.nk_userlib = nk_lib endif c c Check if startup file specified c call cli$get_value('startup',line,nk) if(nk .gt. 0) then c c Startup processing destroys the cld settings c so after the startup processing reparse the input line. c control.ncols = 80 !set width for now call dix_process_Startup(control,line(1:nk)) c call dix_dcl_parse(control, 1 control.command_line(1:control.nk_command_line), 1 .false.,.true.) endif c c If debug wanted, print keyboard mapping c if(control.debug .and. debug_keys .ne. 0) 1 call keydefs_dump(control,'sys$output', 1 ' ','*') c c Go parse the specific parts c istat = cli$dispatch(control) c c If no error seen, (and mode <> none (help)) do it c if(istat) then if(control.mode .ne. mode_none) istat = dix_main(control) endif call delete_vm(control,control.zone_file ) call delete_vm(control,control.zone_cfile ) call delete_vm(control,control.zone_general) call delete_vm(control,control.zone_descr ) call delete_vm(control,control.zone_links ) c endif c c Close output file again c close(control.lun_console) call lib$free_lun(control.lun_console) c if(timer_context .ne. 0) then call lib$show_timer(timer_context) endif c istat = istat .or. sts$m_inhib_msg !do not let DCL signal error call sys$exit(%val(istat)) !but return the status to $status end c function dix_main(control) implicit none include 'dix_def.inc' c c Main work routine c record /control/ control !:io: control structure integer*4 dix_main !:f: function result c# integer*4 cli$present logical dix_main_get_files integer*4 dix_inter_open_level integer*4 dix_dump integer*4 dix_search_search_file integer*4 dix_dump_get_rfa c external rms$_fnf external dix_msg_nofilmat c C Local vars c record /file_info/ file pointer (p_file ,file) c record /dis_pars/ dis c character*(max_line_length) line,err integer*4 iterm,istat,nk,k logical*4 multi_file,do_del integer*4 max_rfas,n_rfas parameter (max_rfas=2) record /rfa/ rfas(max_rfas) c external dix_msg_nomrkres external dix_msg_filnotop external dix_msg_general c c Copy the control.is_term to the dis.is_term c dis.is_term = control.is_term dis.rfa = .true. dis.recnr = .true. dis.recsiz= .true. dis.data = .true. dis.vfc = .true. c c Make a pasteboard, if not VT type terminal mode wil be set to mode_interactive c if(control.mode .eq. mode_screen .or. 1 control.mode .eq. mode_interactive) then call get_pasteboard(control) endif c c Open the output file, if /nooutput, take NL device c if(control.nk_fnam_out .eq. 0) then control.fnam_out = 'NL:' control.nk_fnam_out = 3 endif c call lib$get_lun(control.lun_out) open(control.lun_out, 1 file=control.fnam_out(1:control.nk_fnam_out), 1 status='new', 1 carriagecontrol='list', 1 recl=max_command_length) c c Specific parts of the modes c if(control.mode .eq. mode_screen) then c c Get the display parameters c call dix_main_get_dis(dis) c call smg$erase_pasteboard(control.paste_id) c c screen mode, there is a pasteboard c call dix_smg_out_of_band(control) call smg$create_virtual_display(3,control.ncols,control.dis_kop) call smg$paste_virtual_display(control.dis_kop, 1 control.paste_id,1,1) elseif(control.mode .eq. mode_interactive) then c c Interative mode c Get display parameters c call dix_main_get_dis(dis) c c See if script is specified c do_del = .false. if(control.nk_script_file .ne. 0) then line = control.script_file nk = control.nk_script_file if(line(1:1) .eq. '@') then c c It is already a command file, just strip the @ and go c line = line(2:) nk = nk - 1 else do_del = .true. endif else line = 'SYS$INPUT' nk = 9 endif c c Open a command level , each @ will depeer the command level c istat = dix_inter_open_level(control,line(1:nk),' ') if(do_del) call lib$delete_file(line(1:nk)) if(.not. istat) goto 81 c c Since open level uses dcl_parse, we must save the cuRRent command c call dix_dcl_parse(control, 1 control.command_line(1:control.nk_command_line), 1 .false.,.true.) dis.is_term = control.is_term call dix_smg_out_of_band(control) !enable control-c c elseif(control.mode .eq. mode_file) then c c File mode c call dix_main_get_dis(dis) c c Get the display parameters (recnr,recsiz,fra,data,vfc_data) c call dix_main_set_display(control,dis) else c c Info mode, All done c end if c c Get all the files specified C since get_files uses DCL_PARSE, we must save/restore DCL context c multi_file = cli$present('multi_file') call dix_main_get_files(control,'p1',' ',' ',.false., 1 multi_file) c c Restore the DCL context c call dix_dcl_parse(control, 1 control.command_line(1:control.nk_command_line), 1 .false.,.true.) c c c If no files found, we can continue if mode=interactive c if(control.n_file .eq. 0) then if(control.mode .ne. mode_interactive) then istat = %loc(rms$_fnf) goto 90 endif endif c if(control.mode .eq. mode_info) then p_file = control.top_file do while (p_file .ne. 0) if(file.cur_des .ne. 0) then c c Try expansion, we need a record to expand c so try to read the first record c call dix_rms_get(control,file) c c And now expand the (current) description c call dix_des_expand(control,%val(file.cur_des),file,.true.) endif call dix_rms_file_info(control,file) p_file = file.link.forw end do istat = 1 goto 60 endif c c Take the first file (might be empty) , and go c control.cur_file = control.top_file p_file = control.cur_file c c dump the data file, first define the $FILE symbol c if(%loc(file) .ne. 0) then if(file.cur_des .eq. 0) file.cur_des = file.top_des call dix_symbol_add_str(control,'$FILE', 1 file.fnam(1:file.nk_fnam),err) else nk = 0 call dix_symbol_add_str(control,'$FILE',line(1:nk),err) endif c c See if search specified, if so do it now c if(control.mode .eq. mode_screen .or. 1 control.mode .eq. mode_interactive) then if(%loc(file) .ne. 0) then if(control.search.count .gt. 0) then call dix_search_stats_init(control) istat = dix_search_search_file(control,file,.true., 1 max_rfas,rfas,n_rfas,.false.) call dix_search_stats_show(control) if(istat) istat = dix_dump_get_rfa(control,file,rfas(2)) if(.not. istat) then k = control.mode !force normal message control.mode = mode_interactive call dix_message(control,%val(istat)) control.mode = k goto 60 endif endif endif endif c c To work!!!!! c 55 istat = dix_dump(control,iterm,dis) if(.not. istat) goto 60 c c This returns a iterm, with the wanted action (only modechange) c if(iterm .eq. key_modechange) then c c Change mode from interactive <> screen c if(control.mode .eq. mode_screen) then c c We were in screen mode c call smg$delete_virtual_display(control.dis_kop) control.mode = mode_interactive if(control.depth .eq. 0) then c c Have not yet been here c call sys$fao('!AS',nk,line,'SYS$INPUT:') istat = dix_inter_open_level(control,line(1:nk),' ') if(.not. istat) goto 81 dis.is_term = control.is_term endif elseif(control.mode .eq. mode_interactive) then c c We were in interactive mode c control.mode = mode_screen call smg$create_virtual_display(3,control.ncols,control.dis_kop) call smg$paste_virtual_display(control.dis_kop, 1 control.paste_id,1,1) endif goto 55 endif c c Thats all, close input file c 60 p_file = control.top_file do while(p_file .ne. 0) call file_close(control,file) k = file.link.forw call free_vm(control,sizeof(file),p_file,control.zone_file) p_file = k end do goto 90 c c Here if we cannot open a command level c signal the error and return istat for main routine c 81 call dix_message(control,dix_msg_filnotop,line(1:nk)) call dix_message(control,%val(istat)) c c All done , finish up c 90 if(control.mode .eq. mode_screen) then call dix_main_wait_message(control) if(control.got_pasteboard) then c c LEave text on screen c call smg$delete_pasteboard(control.paste_id,0) endif if(control.keyboard_id .ne. 0) then call smg$delete_virtual_keyboard(control.keyboard_id) endif end if c 99 dix_main = istat return end subroutine dix_main_get_dis(dis) implicit none c c Get all deafult display parameters c c /long/word/byte c /raw/iterpreted c /hex/decimal c /number_hex, _decimal c include 'dix_def.inc' record /dis_pars/ dis !:o: dispay parameters c# integer*4 cli$present c c Get the display variables c dis.unsigned = cli$present('unsigned') c dis.magic = magic_dis_pars dis.show_des = .false. dis.word = 4 if(cli$present('WORD')) dis.word = 2 if(cli$present('BYTE')) dis.word = 1 c dis.raw = cli$present('RAW') c dis.number = cli$present('NUMBER') if(.not. dis.raw) then c c defaults for Interpreted mode c dis.hex = des_flag_translate_nor if(cli$present('HEX')) dis.hex = des_flag_translate_hex if(cli$present('OCTAL')) dis.hex = des_flag_translate_oct if(cli$present('BINARY')) dis.hex = des_flag_translate_bin else c c defaults for raw mode c dis.hex = des_flag_translate_hex if(cli$present('DECIMAL')) dis.hex = des_flag_translate_nor if(cli$present('OCTAL')) dis.hex = des_flag_translate_oct if(cli$present('BINARY')) dis.hex = des_flag_translate_bin endif c dis.number_hex = dis.hex if(cli$present('NUMBER.HEX')) dis.number_hex = .true. if(cli$present('NUMBER.DECIMAL')) dis.number_hex = .false. c dis.compres = cli$present('COMPRES') dis.field = cli$present('dfield') return end function dix_main_rfa_restore(control,mark) implicit none c c Restore a file from an RFA Mark c include 'dix_def.inc' record /control/ control !:io: the control character*(*) mark !:i: the mark to restore to integer*4 dix_main_rfa_restore !:f: function result c# integer*4 k,istat c integer*4 dix_rms_set_rfa external dix_msg_nomrkres c record /file_info/ file pointer (p_file,file) c k = control.top_file p_file = control.cur_file c call dix_rms_save_rfa('__DIXRFA_UNDO',%val(file.rabadr),file.rec_nr) if(.not. dix_rms_set_rfa(control,k,mark)) then istat = %loc(dix_msg_nomrkres) c c Was a problem, so return to previous mark c k = control.top_file call dix_rms_set_rfa(control,k,'__DIXRFA_UNDO') else istat = 1 endif c c got it, k points to the correct file , now set cur_file correct c control.cur_file = k dix_main_rfa_restore = istat return end c function dix_main_follow(control,auto,open_flag,link_rec, 1 value,link_fnam,err_arg) implicit none c c (try to) follow a link from a descripto entry to another file c include 'dix_def.inc' record /control/ control !:io: control structure logical auto !:i: automatic opne file integer*4 open_flag !:i: open mode record /link_rec/ link_rec !:i: the link info record /value/ value !:i: the key/record value character*(*) link_fnam !:i: link filename character*(*) err_arg !:i: link filename integer*4 dix_main_follow !:f: function result c# record /file_info/ file pointer (p_file ,file) c character*(max_filename_length) deffile character*(max_line_length) line,name,keyascval,txt integer*4 nk,nk_def,k,istat,keyopt,length,nk1,nk_t logical filenotf,mod_wanted,answer,string,ascending c logical dix_main_question logical dix_main_get_files integer*4 dix_main_get_rec_int integer*4 dix_rms_get_keyed integer*4 dix_rms_keyinfo integer*4 dix_util_get_len_fu c external dix_msg_nofilmat external dix_msg_keyisint external dix_msg_keyischar external dix_msg_filnotfol c c Follow link to file, try to find the wanted file in open file list c err_arg = ' ' p_file = control.cur_file nk = dix_util_get_len_fu(link_fnam) if(nk .eq. 0) goto 58 !current file c c Get the file disk,directory,name, this is used ad a default for the c possible fileopens if the link file is not found c deffile = file.fnam call dix_util_file_parse(deffile,'T',k,nk_def) c filenotf = .true. istat = 1 if(open_flag .eq. 0) then mod_wanted = file.modify else mod_wanted = open_flag .eq. 1 endif nk_t = 0 if(mod_wanted) then call sys$fao('for write',nk_t,txt) else call sys$fao('for read',nk_t,txt) endif c c Go through chain of files, and check if we found it c First get the full file name of the file c skip the version c call dix_util_file_parse(link_fnam(1:nk),'T',k,nk1) inquire(file=link_fnam(1:nk1), 1 defaultfile = deffile(1:nk_def), 1 name=name, 1 err=54) c p_file = control.top_file do while(p_file .ne. 0) if(file.fnam(1:file.nk_fnam) .eq. name) goto 58 p_file = file.link.forw end do c c No filename match, ask if the user wants to add it c answer = auto !!used to automatic if(.not. answer) answer = dix_main_question(control,'File '// 1 link_fnam(1:nk)// 1 ' not (yet) opened '//txt(1:nk_t)// 1 ', open it',.true.) if(answer) then c c To make it easy, make a command line c line = 'DIX '//link_fnam(1:nk) nk = nk + 4 if(mod_wanted) then line(nk+1:) = '/MODIFY' nk = nk + 7 endif call dix_dcl_parse(control,line(1:nk),.false.,.false.) if(dix_main_get_files(control,'p1', 1 deffile(1:nk_def),' ',.false., 1 .true.)) then c c Now it must be at the end of the list c p_file = control.top_file do while(file.link.forw .ne. 0) p_file = file.link.forw end do goto 58 endif else istat = %loc(dix_msg_filnotfol) err_arg = link_fnam(1:nk1) goto 90 endif c c Either do not open, or file not found c 54 istat = %loc(dix_msg_nofilmat) err_arg = link_fnam(1:nk1) goto 90 c c We have the file, try to find the record c 58 if(link_rec.key_nr .lt. 0) then c c Record access, keyfield must be integer c if(value.type .eq. symb_typ_int) then istat = dix_main_get_rec_int(control,file,value.ival) value.i8val(2) = 0 else istat = %loc(dix_msg_keyisint) endif else c c Keyed access c keyopt = link_rec.match istat = dix_rms_keyinfo(file,link_rec.key_nr, 1 string,length,ascending,name) if(istat) then if(string) then if(value.type.eq.symb_typ_char)then c c Make a key completely blank c and fill with the data from the record c keyascval = ' ' nk = min(len(keyascval),zext(value.strdes.dsc$w_maxstrlen)) call lib$movc3(nk,%val(value.strdes.dsc$a_pointer), 1 %ref(keyascval)) c istat = dix_rms_get_keyed(control,file,keyopt,length, 1 %ref(keyascval),link_rec.key_nr) else istat = %loc(dix_msg_keyischar) endif else if(value.type.eq.symb_typ_int)then istat = dix_rms_get_keyed(control,file,keyopt,length, 1 value.ival,link_rec.key_nr) else istat = %loc(dix_msg_keyisint) endif !type is integer endif !string type endif !succesfull direction endif !keyded access if(istat) then c c We found the record, increment history pointer c if(control.p_link_history .eq. max_link_history) then c c No more room, remove oldest c do k=2,max_link_history control.link_history(k-1) = control.link_history(k) end do else control.p_link_history = control.p_link_history + 1 endif c c And save return point c control.link_history(control.p_link_history).p_file=control.cur_file control.cur_file = p_file p_file = control.link_history(control.p_link_history).p_file call dix_rms_compute_rfa(%val(file.rabadr),file.rec_nr, 1 control.link_history(control.p_link_history).rfainfo,nk) endif 90 dix_main_follow = istat return end function dix_main_follow_back(control,log_it) implicit none c c Follwo the backlink from a previous link c include 'dix_def.inc' record /control/ control !:io: control strucuture logical log_it !:i: log the switch? integer*4 dix_main_follow_back !:f: function result c# integer*4 save_p_file,istat c record /file_info/ file pointer (p_file,file) c integer*4 dix_rms_set_rfa_val c external dix_msg_nohist external dix_msg_folhist external dix_msg_nomrkres c save_p_file = 0 if(control.p_link_history .ne. 0) then c c Get history file c save_p_file = control.link_history(control.p_link_history).p_file c c Try to set pointer in history file (should work, unless somebody c else removed record). c istat = dix_rms_set_rfa_val(control,save_p_file, 1 control.link_history(control.p_link_history).rfainfo) c control.p_link_history = control.p_link_history - 1 c if(.not. istat)then c c Sorry could not restore record, the pointer is already removed, so the next c time it is not used again c call dix_message(control,dix_msg_nomrkres,%descr('Link history')) else c c Got the record, so make this file the active one c control.cur_file = save_p_file p_file = save_p_file c c And log it (is wanted) c if(log_it) call dix_message(control, 1 dix_msg_folhist,file.fnam(1:file.nk_fnam)) endif else c c Sorry, no history present c istat = %loc(dix_msg_nohist) endif dix_main_follow_back = istat return end subroutine dix_main_wait_message(control) implicit none c include 'dix_def.inc' record /control/ control !:i: control structure c# c The user wants to exit, make sure he has read all messages c integer*4 k external dix_msg_exiting c if(control.dis_err .ne. 0) then call dix_message(control,dix_msg_exiting) call dix_get_key(control,k,k,k,' ') end if return end subroutine dix_message(control,mes_code, 1 arg1,arg2,arg3,arg4,arg5,arg6,arg7) implicit none c c Print a message (either via SMG or via write to terminal) c include 'dix_def.inc' record /control/ control !control block integer*4 mes_code !message code integer*4 arg1 !arg1 up arg7 integer*4 arg2 integer*4 arg3 integer*4 arg4 integer*4 arg5 integer*4 arg6 integer*4 arg7 !upto 7 c# integer*4 args(10),narg,nk,nk1 integer*4 did,drow,dcol,fao_count logical use_smg,update_mes character*(max_line_length) line,line1 c external dix_msg_disontop,dix_msg_clear c narg = iargcount() - 2 if(narg .gt. 0) args(1) = %loc(arg1) if(narg .gt. 1) args(2) = %loc(arg2) if(narg .gt. 2) args(3) = %loc(arg3) if(narg .gt. 3) args(4) = %loc(arg4) if(narg .gt. 4) args(5) = %loc(arg5) if(narg .gt. 5) args(6) = %loc(arg6) if(narg .gt. 6) args(7) = %loc(arg7) c use_smg = control.mode .eq. mode_Screen .or. 1 control.smg_window .ne. 0 c if(%loc(mes_code) .eq. %loc(dix_msg_clear)) then c c In screen mode,clear error display c if(use_smg) then if(control.dis_err .ne. 0) call 1 smg$delete_virtual_display(control.dis_err) control.dis_err = 0 endif elseif(%loc(mes_code) .eq. %loc(dix_msg_disontop)) then c c Make sure error display is on top c if(use_smg) then call smg$find_cursor_display(control.paste_id,did) call smg$return_cursor_pos(did,drow,dcol) call smg$repaste_virtual_display(control.dis_err, 1 control.paste_id, 1 control.nrows-control.nlin_dis_err+1, 1 control.ncols-control.ncol_dis_err+1) c c Restore cursor c call smg$set_cursor_abs(did,drow,dcol) endif else c c Normal messages c call dix_main_get_message(control,mes_code,nk,line, 1 fao_count,update_mes) call sys$faol(line(1:nk),nk1,line1,args) if(use_smg) then call dix_mes(control,line1(1:nk1),update_mes) else if(control.mode .eq. mode_interactive .and. 1 control.depth .gt. 0) then c call dix_write_file(control,line1(1:nk1),.true.) else c c For file mode, do not display update messages c if(.not. update_mes) call 1 dix_write_console(control,line1(1:nk1)) endif endif endif return end subroutine dix_main_get_message(control,mes_code,nk,line, 1 fao_count,update_mes) implicit none c c return message fro message section. c include 'dix_def.inc' record /control/ control !:i: control block integer*4 mes_code !:i: message integer*4 nk !:o: length of message character*(*) line !:o: the text of the mess integer*4 fao_count !:o: fao count logical*4 update_mes !:o: is this an update message c# logical use_smg integer*4 msg_mask,nk1 byte flags(4) c character*(max_line_length) line1 c integer*4 sys$getmsg external dix_msg_noname c use_smg = control.mode .eq. mode_Screen .or. 1 control.smg_window .ne. 0 c c In interactive mode, use the current settings of msgmask c else user 1 (text only) c msg_mask = control.msgmask if(use_smg) msg_mask = 1 if(.not. sys$getmsg(mes_code,nk,line,%val(msg_mask),flags)) then c c Shoul not happen, but if so replace by useful?? message c call sys$getmsg(dix_msg_noname,nk1,line1,%val(msg_mask),flags) call sys$fao(line1(1:nk1),nk,line,%val(mes_code)) endif fao_count = zext(flags(2)) update_mes = flags(3) .ne. 0 return end function dix_write_console(control,line) implicit none c c Write to sys$output c include 'dix_def.inc' record /control/ control !:i: control structure character*(*) line !:i: the line to print integer*4 dix_write_console !:f: function result c# integer*4 bpos,epos,width,nkar,istat c c The first line it printed normally c the second and third lines are indented by 2 c nkar = max(1,len(line)) width = max(132,control.ncols) c bpos = 1 do while(bpos .le. len(line)) epos = min(len(line),bpos + width - 1) if(bpos .eq. 1) then write(control.lun_console,1000,err=80) line(bpos:epos) 1000 format(a) width = width - 2 else write(control.lun_console,1010,err=80) line(bpos:epos) 1010 format(2x,a) endif bpos = epos + 1 end do istat = 1 goto 90 80 call errsns(,istat) 90 dix_write_console = istat return end subroutine dix_mes(control,mes,update) implicit none c c Print a message to an SMG window c include 'dix_def.inc' record /control/ control !:i: control structure character*(*) mes !:i: message text logical*4 update c# integer*4 nkar,k,nl,nc,ipos logical*4 do_upd c include '($smgdef)' character*(*) ident parameter (ident='Messages') c c Compute #lines for the display c nkar = len(mes) c c Compute ncols c nc = max(len(ident)+1,min(nkar,control.ncols)) c c Compute nrows c nl = (nkar+nc-1)/nc if(control.dis_err .eq. 0) then c c Create new empty display with enough room for message c control.nlin_dis_err = nl control.ncol_dis_err = nc call smg$create_virtual_display(control.nlin_dis_err, 1 control.ncol_dis_err,control.dis_err) call smg$paste_virtual_display(control.dis_err, 1 control.paste_id, 1 control.nrows-control.nlin_dis_err+1, 1 control.ncols-control.ncol_dis_err+1) call smg$label_border(control.dis_err,ident) else c c display was there, enlarge it c if(update) then c c Message with #@ in begin, do not enlarge window c do_upd = .false. if(nl .gt. control.nlin_dis_err) then control.nlin_dis_err = nl do_upd = .true. endif c if(nc .gt. control.ncol_dis_err) then control.ncol_dis_err = nc do_upd = .true. endif else c c Normal message, just enlarge display c control.nlin_dis_err = control.nlin_dis_err + nl do_upd = .true. if(nc .gt. control.ncol_dis_err) control.ncol_dis_err = nc endif c if(do_upd) then c c The size of the display need to be changed, do it c call smg$change_virtual_display(control.dis_err, 1 control.nlin_dis_err,control.ncol_dis_err) call smg$repaste_virtual_display(control.dis_err, 1 control.paste_id, 1 control.nrows-control.nlin_dis_err+1, 1 control.ncols-control.ncol_dis_err+1) endif end if c c Now print the text to the display c ipos = 1 do k=1,nl call smg$put_chars(control.dis_err, 1 mes(ipos:min(nkar,k*control.ncols)), 1 control.nlin_dis_err-nl+k,1, 1 smg$m_erase_to_eol,smg$m_bold) ipos = ipos+control.ncols end do return end subroutine dix_main_fill_rec(control,file) implicit none c c Fil a record to defaults (space for test, NULL for binary c include 'dix_def.inc' record /control/ control !:i: control structure record /file_info/ file !:io: file structure/record c# record /des_rec/ des_recs(1) pointer (p_des_recs,des_recs) c logical dix_con_typ_is_text external dix_msg_reccrea integer*4 dix_des_expand c integer*4 k,offs,max_size,max_offs c record /des_expanded/ des_expanded pointer (p_des_expanded, des_expanded) c record /des_info/ des_info pointer (p_des_info,des_info) c c CHeck if changed data present c call dix_main_check_mod_record(control,file) c c Fill record with all 0 c file.data.nb_data = file.maxrecl call dix_util_fill(0,file.data.nb_data,file.data.data_rec) c c fill the vfc record to zero's c call dix_util_fill(0,max_vfc_size,file.data.vfc_data) c c Try to locate a fixed format description c (no string, or lstring or something else variable) c p_des_expanded = file.top_des do while(p_des_expanded .ne. 0) p_des_info = des_expanded.p_des_info if(des_info.fixed) goto 10 p_des_Expanded = des_expanded.link.forw end do c c Could not find fixed one, so use the first c p_des_expanded = file.top_des c c If there is no description, skip the rest c if(p_des_expanded .eq. 0) goto 90 p_des_info = des_expanded.p_des_info c c Got a valid description, so gogogogogo c c Expand the record, since we have no data this can only work c if nothing variable c c Expand descriptions c 10 if(.not. dix_des_expand(control,des_expanded,file,.true.)) goto 90 max_size = des_expanded.max_name_size max_offs = 0 c c Go through al descriptions c p_des_recs = des_expanded.table_nor.address do k=1,des_expanded.table_nor.count offs = des_recs(k).bit_offset/8 if(dix_con_typ_is_text(des_recs(k).ent_type)) then c c Is text, so fill with spaces c call dix_util_fill(%ref(SPACE),des_recs(k).size/8, 1 file.data.data_rec(offs+1)) end if if(offs+des_recs(k).size/8 .gt. max_offs) 1 max_offs = offs+des_recs(k).size/8 end do c c And now the vfc data c p_des_recs = des_expanded.table_vfc.address do k=1,des_expanded.table_vfc.count offs = des_recs(k).bit_offset/8 if(dix_con_typ_is_text(des_recs(k).ent_type)) then call dix_util_fill(%ref(SPACE),des_recs(k).size/8, 1 file.data.vfc_data(offs+1)) end if end do c c For a fixed record length c if(.not. file.fixed) file.data.nb_data = max_offs c 90 call dix_message(control,dix_msg_reccrea,%val(file.data.nb_data)) return end function dix_main_set_initial_key(control,file) implicit none c c Set the record to the values given by the user c c /record or /key=,/lt../gt= c include 'dix_def.inc' record /control/ control !:i: control structure record /file_info/ file !:i: file information logical*4 dix_main_set_initial_key !:f: function result c# c function declaration c function declaration c integer*4 cli$present logical*4 dix_rms_set_rfa logical*4 dix_main_get_keyvals integer*4 dix_util_get_len_fu c c Local vars c integer*4 istat,nk1 logical got_one character*(max_line_length) line c c c Start of coding c external dix_msg_sfirstrec c got_one = .false. c c See indexed/non indexed c if(cli$present('MARK')) then istat = dix_rms_set_rfa(control,%loc(file),'DIXRFA') if(istat) then got_one = .true. control.one_rec = .true. else call dix_message(control,%val(istat),%descr('DIXRFA')) call dix_message(control,dix_msg_sfirstrec) istat = 1 endif else istat = dix_main_get_keyvals(control,file,got_one, 1 .true.,.true.,line) endif 80 if(got_one) then c c Only dump one record c if(file.count .eq. 0) file.count = 1 endif c if(.not. istat) then nk1 = dix_util_get_len_fu(line) call dix_message(control,%val(istat),line(1:nk1)) endif C dix_main_set_initial_key = istat 90 return end c function dix_main_get_keyvals(control,file,got_one, 1 trans,rewind,err_arg) implicit none c c Set the record to the values given by the user c c /record or /key=,/lt../gt= c include 'dix_def.inc' record /control/ control !:i: control structure record /file_info/ file !:i: file information logical*4 got_one !:i: asked for a specific key logical*4 trans !:i: allow translation logical*4 rewind !:i: rewind om empty key character*(*) err_arg !:o: message argument logical*4 dix_main_get_keyvals !:f: function result c# c function declaration c function declaration c integer*4 cli$get_value,cli$present logical*4 dix_main_get_rec_keyed integer*4 dix_main_get_rec integer*4 dix_main_get_rfa logical*4 dix_rms_get c external dix_msg_ignored external dix_msg_illkeyn external dix_msg_dupkeyval c c Local vars c integer*4 keyopt,nk1 c character*(max_line_length) key_str,line integer*4 nkar,istat,key c err_arg = ' ' c if(file.indexed .and. file.block_size .eq. 0) then c C Keyed file and not opened in block mode c Get key number c call util_cli_get_number('key',0,key) c c If KEY does not exist, this returns an error c if(key .lt.0 .or. key .ge. file.nkey) then call dix_message(control,dix_msg_illkeyn, 1 %val(key),%val(file.nkey)) istat = 0 !signal failure goto 90 endif c c If user specified /record, find the correct record c call cli$get_value('record',key_str,nkar) if(nkar .gt. 0) then c c Reewind to the correct key c call dix_rms_rewind(control,file,key) c c And skip the records c control.one_rec = .true. got_one = .true. istat = dix_main_get_rec(control,file,key_str(1:nkar)) else file.cur_key = key c c See if user specified rfa c if(cli$present('rfa')) then c c Get first part (block/bucket number) c istat = dix_main_get_rfa(control,file) got_one = .true. else c c Get key value c C C See if somebody specified /**=value c will return keyopt = C -2 LT search C -1 LE search C 0 EQ search C 1 GE search c 2 GT search c 3 No search ,so rewind on specified key c keyopt = key_opt_seq !assume no key value nkar = 0 !signal no key value c call cli$get_value('LT',line,nk1) if(nk1 .gt. 0) then if(keyopt .ne. key_opt_seq) goto 49 keyopt = key_opt_lt nkar = nk1 key_str = line(1:nk1) endif call cli$get_value('LE',line,nk1) if(nk1 .gt. 0) then if(keyopt .ne. key_opt_seq) goto 49 keyopt = key_opt_le nkar = nk1 key_str = line(1:nk1) endif call cli$get_value('EQ',line,nk1) if(nk1 .gt. 0) then if(keyopt .ne. key_opt_seq) goto 49 keyopt = key_opt_eq nkar = nk1 key_str = line(1:nk1) endif call cli$get_value('GE',line,nk1) if(nk1 .gt. 0) then if(keyopt .ne. key_opt_seq) goto 49 keyopt = key_opt_ge nkar = nk1 key_str = line(1:nk1) endif call cli$get_value('GT',line,nk1) if(nk1 .gt. 0) then if(keyopt .ne. key_opt_seq) goto 49 keyopt = key_opt_gt nkar = nk1 key_str = line(1:nk1) endif goto 50 c 49 istat = %loc(dix_msg_dupkeyval) goto 90 c c now do the settings on the file c 50 istat = dix_main_get_rec_keyed(control,file,key,key_str,nkar, 1 keyopt,trans,rewind) c c Equal search means we want one record c got_one = keyopt .eq. key_opt_eq .and. nkar .gt. 0 endif endif else C C sequential file, get record number c Give messages for ignored qualifiers c if(cli$present('key')) call dix_message(control, 1 dix_msg_ignored,%descr('/key')) c if(cli$present('LT') .or. 1 cli$present('LE') .or. 1 cli$present('EQ') .or. 1 cli$present('GE') .or. 1 cli$present('GT')) then call dix_message(control, 1 dix_msg_ignored,'Key value') endif c C can be sequential (var length) or C direct access c if(cli$present('rfa')) then c c Get first part (block/bucket number) c file.cur_key = 0 istat = dix_main_get_rfa(control,file) got_one = .true. else C call cli$get_value('record',key_str,nkar) if(nkar .gt. 0) then control.one_rec = .true. got_one = .true. istat = dix_main_get_rec(control,file,key_str(1:nkar)) else c c Just read the first record c istat = dix_rms_get(control,file) endif endif end if c 90 dix_main_get_keyvals = istat return end function dix_main_get_rfa(control,file) implicit none c c Read a record from a /rfa qualifiers c either /rfa=(bucketl,bucketh,offset) c or /rfa=(bucket,offset) c include 'dix_def.inc' record /control/ control record /file_info/ file integer*4 dix_main_get_rfa c character*(max_short_line_length) vals(3) integer*4 nkar(3),istat,k,nb_f record /rfa/ rfa integer*4 dix_con_type_ascint integer*4 dix_rms_get_rfa c external dix_msg_invrfa c do k=1,3 call cli$get_value('rfa',vals(k),nkar(k)) end do c if(nkar(3) .gt. 0) then c do k=1,3 istat = dix_con_type_ascint(vals(k)(1:nkar(k)),16, 1 rfa.rfa(k),enttyp_uint,control,nb_f) if(.not. istat) goto 50 end do call cli$get_value('rfa',vals(1),nkar(1)) if(nkar(1) .gt. 0) goto 50 else istat = dix_con_type_ascint(vals(1)(1:nkar(1)),32, 1 rfa.bbnr,enttyp_uint,control,nb_f) if(.not. istat) goto 50 istat = dix_con_type_ascint(vals(2)(1:nkar(2)),16, 1 rfa.offset,enttyp_uint,control,nb_f) if(.not. istat) goto 50 endif c istat = dix_rms_get_rfa(control,file,file.cur_key,rfa) goto 90 c c Error in rfa c 50 istat = %loc(dix_msg_invrfa) c 90 dix_main_get_rfa = istat return end function dix_main_get_rec_keyed(control,file,key,keyval,nkar, 1 keyopt,translate_percent,rewind) implicit none c c Read the data according to the requested value for an indexed file c include 'dix_def.inc' record /control/ control record /file_info/ file !:i: fiel information integer*4 key !:i: key number character*(*) keyval !:i: key value to search integer*4 nkar !:i: #kars in keyval (can be 0) integer*4 keyopt !:i: keyoption 0=eq,1=ge,2=gt logical translate_percent !:i: is %xx converted to hex char? logical*4 rewind !:i: do we want a rewind logical*4 dix_main_get_rec_keyed !:F: result c# logical*4 string,ascending,signal integer*4 length,nkar_key,istat character*(max_rms_key_name_length) keynam byte datab(256) c logical*4 dix_con_int_ascint logical*4 dix_rms_rewind logical*4 dix_rms_get logical*4 dix_rms_get_keyed logical dix_con_hex_in_string c external dix_msg_warnperc c c Get key information c signal = .false. call dix_rms_keyinfo(file,key,string,length,ascending,keynam) c c For not strings, convert to binary c nkar_key = nkar if(nkar .gt. 0) then if(.not. string) then c c For non string convert from ascii to binary, check for keylength c nkar_key = length istat=dix_con_int_ascint(keyval(1:nkar),datab,length*8,' ', 1 0,0,control,.false.) if(.not. istat) goto 90 else c c String type, justcopy c for equal case, the whole key is used, else only the text upto nkar_data c if(keyopt .eq. 0) nkar_key = length if(translate_percent) then signal = dix_con_hex_in_string(keyval,nkar_key,.true.) endif c c Move and fill with spaces c call lib$movc5(len(keyval),%ref(keyval),32,nkar_key,datab) end if end if if(nkar_key .eq. 0) then c c Only /key or nothing c if(rewind) then istat = dix_rms_rewind(control,file,key) else istat = 1 endif if(istat) istat = dix_rms_get(control,file) else c c keyvalue is given c istat = dix_rms_get_keyed(control,file,keyopt,nkar_key, 1 datab,key) if(.not. istat .and. signal) then call dix_message(control,dix_msg_warnperc) endif endif 90 dix_main_get_rec_keyed = istat return end function dix_main_get_rec(control,file,recasc) implicit none c c Read the data according to the requested value for a non-indexed file c include 'dix_def.inc' record /control/ control !:i: control structure record /file_info/ file !:i: file information character*(*) recasc !:i: rec nr in ascii logical*4 dix_main_get_rec !:F: result c# integer*4 recnr,istat c logical*4 dix_con_int_ascint logical*4 dix_main_get_rec_int c external dix_msg_sfirstrec c recnr = 1 if(recasc .ne. ' ') then istat = dix_con_int_ascint(recasc,recnr,32,' ', 1 0,0,control,.false.) if(recnr .le. 0) then call dix_message(control,dix_msg_sfirstrec) recnr = 1 endif end if istat = dix_main_get_rec_int(control,file,recnr) dix_main_get_rec = istat return end c function dix_main_get_rec_int(control,file,recnr) implicit none c c Read the data according to the requested value for a non-indexed file c include 'dix_def.inc' record /control/ control !:i: control structure record /file_info/ file !:i: file information integer*4 recnr !:i: the wanted record mumber logical*4 dix_main_get_rec_int !:F: result c# integer*4 istat c logical*4 dix_rms_get_direct logical*4 dix_rms_skip logical*4 dix_rms_get c external dix_msg_firstrec c if(recnr .le. 0) then istat = %loc(dix_msg_firstrec) else if(file.fixed .or. file.block_size .ne. 0 .or. 1 file.relative .and. .not. file.indexed) then c c Fixed record file, so we can directly read the record c istat = dix_rms_get_direct(control,file,recnr) else c c Variable file, skip n-1 records (or indexed file) c call dix_rms_rewind(control,file,-1) istat = dix_rms_skip(control,file,recnr-1) istat = dix_rms_get(control,file) end if endif dix_main_get_rec_int = istat return end function dix_main_get_files(control,label, 1 deffile,handle,logit,multi_file) implicit none c c Open one or more files, and attach the .DES reords to it(them) c include 'dix_def.inc' record /control/ control character*(*) label !:i: the label for cli$get_value character*(*) deffile !:i: the default file spec character*(*) handle !:i: the tag to give to the file logical logit !:i: signal file opens? logical multi_file !:i: multi file allowed logical dix_main_get_files !:f: return true if a file opened c# record /file_info/ file pointer (p_file ,file) c integer*4 nk_fnam,block_size,nk_fnam_d,context,nfnd,nk integer*4 temp_lun,top_file,istat,ipos,count,old_n_file integer*4 nfnd_d c include '($climsgdef)' c logical modify,got,got_file,oplock,rrl,all,check_handle character*(max_filename_length) fnam,fnam_d character*(2*max_line_length) line character*(max_handle_name_length) local_handle character kar c logical cli$get_value logical cli$present logical lib$find_file logical dix_des_get_all logical memtab_read integer*4 dix_util_get_len integer*4 dix_main_set_initial_key logical dix_main_select_file integer*4 dix_symbol_get_symbol c logical dix_rms_open external dix_msg_filnotf external dix_msg_nomatch external dix_msg_filopen external dix_msg_tagchngd c c Since the processing of the descriptions takes dcl_parse c We can open the file with all its options, but c the processing of the descriptions has to be done later c got_file = %loc(dix_msg_filnotf) call memtab_init(control,temp_lun,'filenames') old_n_file = control.n_file top_file = 0 c c Now process all lines from temp_lun c 10 do while(cli$get_value(label,fnam,nk_fnam)) c nfnd = control.n_file c c check if wildcards found, See if more than one file specified c modify = cli$present('modify') block_size = 0 if(cli$present('BLOCKED')) then call util_cli_get_number('BLOCKED',0,block_size) block_size = min(63,max(1,block_size)) endif c c if(control.mode .eq. mode_file) then c c For file mode, set the max record count to print c call util_cli_get_number('count',0,count) endif oplock = .false. rrl = .false. if(control.mode .ne. mode_info) then oplock = cli$present('locking.optimistic') rrl = cli$present('locking.rrl') endif c c GEt all descriptions and save them c c c Got a filename c context = 0 do while(lib$find_file(fnam(1:nk_fnam),line,context,deffile)) C## call get_vm(control,sizeof(file),p_file,control.zone_file, 1 .false.,'FILE') c c Init file control block data c file.magic = magic_file_info file.modify = modify file.count = count file.block_size = block_size file.fnam = line file.nk_fnam = dix_util_get_len(line) if(handle .eq. ' ') then c c Caller did not specify handle, see if one on command line c Check if changed if handle <> ' ' c istat = dix_symbol_get_symbol('tag',local_handle,nk) If(.not. istat) then call dix_message(control,%val(istat),local_handle(1:nk)) local_handle = ' ' endif check_handle = local_handle .ne. ' ' else c c Caller did specify handle, use this one (and check if changed) c local_handle = handle check_handle = .true. endif call dix_main_make_tag(control,file.handle,local_handle,line) file.nk_handle = dix_util_get_len(file.handle) if(check_handle) then if(local_handle .ne. file.handle) call dix_message(control, 1 dix_msg_tagchngd,file.handle(1:file.nk_handle)) endif file.top_des = 0 file.cur_des = 0 file.cur_key = 0 file.rec_nr = 0 file.rrl = rrl file.oplock = oplock file.ptr_keyinfo= 0 !no key control blocks yet file.got_record = .false. file.data.nb_data= 0 file.data.nb_vfc = 0 c c If opening is requested, open it c if(.not. dix_rms_open(control,file)) then call free_vm(control,sizeof(file),p_file,control.zone_file) else c c Get descriptions, but only for non-blocked files c if(file.block_size .eq. 0) then kar = 'N' if(cli$present('ALL')) kar = 'Y' c c If /NODES, add norecords c if /DES=a,b,c Add 3 records with a,b,c c if nothing Add 1 record with null filename c istat = cli$present('DESCRIPTION') if(istat .ne. cli$_locneg) then c nfnd_d = 0 do while(cli$get_value('DESCRIPTION',fnam_d,nk_fnam_d)) c c Add a record to the memtab c filename//0//desciption_file_name c We cannot process it now, since description processing c uses dcl_parse, and that will destroy our current DCL parsing c if(nk_fnam_d .gt. 0) then nfnd_d = nfnd_d + 1 call memtab_add_record(control,temp_lun, 1 kar//file.fnam(1:file.nk_fnam)//NULL// 1 fnam_d(1:nk_fnam_d)) endif end do c if(nfnd_d .eq. 0) then c c Add one record with a null value c call memtab_add_record(control,temp_lun, 1 kar//file.fnam(1:file.nk_fnam)//NULL//NULL) istat = 1 endif endif endif c c Remember the first file c if(top_file .eq. 0) top_file = p_file c if(logit) call dix_message(control,dix_msg_filopen, 1 file.fnam(1:file.nk_fnam)) c got_file = 1 c c Link in c call dix_util_link_in(file.link,control.top_file) control.n_file = control.n_file + 1 c c Get the first record, depending on command qualifiers /ge/eq/rec etc c if(control.mode .ne. mode_info) then istat = dix_main_set_initial_key(control,file) if(.not. istat) call dix_message(control,%val(istat)) endif endif !open successful c end do !try the next file of the find_file call lib$find_file_end(context) c if(nfnd .eq. control.n_file) then call dix_message(control,dix_msg_filnotf,fnam(1:nk_fnam)) endif end do !get the next filename c c Now we have all the files , Get all des files for all filenames c p_file = top_file do while(p_file .ne. 0) c c Now we have the file, look for the description files c got = .false. !Assume /nodes c c Go through the whole table, and look for descriptions for c this file c call memtab_rewind(temp_lun) do while(memtab_read(temp_lun,nk,line)) c c File the file name c byte 1 : flag byte (all descriptions) c byte 2..n : the file name c byte n+1 : NULL c byte n+2:nk : The desciption file name (or NULL) c ipos = index(line(1:nk),NULL) if(line(2:ipos-1) .eq. file.fnam(1:file.nk_fnam)) then c c We found a description for this file, now process it c all = line(1:1) .eq. 'Y' fnam_d = line(ipos+1:nk) nk_fnam_d = nk - ipos c c And all via the extra /description items c if(fnam_d(1:1) .eq. NULL) then got = .true. !do the general get all else c c We have a description filename, got get it (maybe all matches) c if(dix_des_get_all(control,file,fnam_d(1:nk_fnam_d), 1 .false.,all)) then c c Successful, c else c c Error, no description found c call dix_message(control,dix_msg_nomatch, 1 fnam_d(1:nk_fnam_d)) endif endif end if !name matches end do !all memtab records c c Now see if we had an explicit /des (got set) of /nodes c if not try to find a description from the filename c if(got) then c c User did not specify the /NODES, get all matching desciptions c (could still return 0) c call dix_des_get_all(control,file,' ',.false.,all) endif c c Now next file c p_file = file.link.forw end do c c Delete memtab file c call memtab_close(control,temp_lun) c c If more then one found, and .not. multi_file, let the user c select one. c if(control.n_File-old_n_file .gt. 1 .and. .not. multi_file) then if(.not. dix_main_select_file(control)) got_file = .false. endif c c And return the final status c 90 dix_main_get_files = got_file return end subroutine dix_main_make_tag(control,file_handle,handle,fnam) implicit none c c Make a (unique) tag from the filename c If no tag given, take the body of the file c include 'dix_def.inc' record /control/ control !:i: control structure character*(*) file_handle !:o: file handle result character*(*) handle !:i: user given name character*(*) fnam !:i: filename c# character*(max_short_line_length) sernr integer*4 nk_w,nk1,icnt,bpos,epos c record /file_info/ file pointer (p_file,file) c integer*4 dix_util_get_len c c Make a unique handle c if(handle .eq. ' ') then c c Take body of file c call dix_util_file_parse(fnam,'N',bpos,epos) file_handle = fnam(bpos:epos) else file_handle = handle !take user defined part endif nk_w = dix_util_get_len(file_handle) c c See if no duplicate found c icnt = 0 10 p_file = control.top_file do while(p_file .ne. 0) if(file.handle .eq. file_handle) then c c Yes we have a duplicate, append _nn and try again c icnt = icnt + 1 call sys$fao('_!UL',nk1,sernr,%val(icnt)) c c See if it fits, if not skip last chars for WERK c if(nk_w + nk1 .gt. len(file_handle)) nk_w = len(file_handle) - nk1 c c Append _idx and retry for uniqueness c file_handle(nk_w+1:nk_w+nk1) = sernr(1:nk1) goto 10 endif p_file = file.link.forw end do c return end subroutine dix_main_close_files(control,file_mask,log_it) implicit none c c Close one or more files c if mask is empty : the current file, and switch to the first c if mask is filled: Close the file(s) that matches the mask c with the name(wildcard) or the mask (equal) c include 'dix_def.inc' record /control/ control !:i: control structure character*(*) file_mask !:i: filename(handle) mask logical*4 log_it !:i: log the closing? c# record /file_info/ file pointer (p_file,file) c integer*4 nk,nclos,ptr_file c integer*4 dix_dump_inter_next_file external dix_msg_fileclose external dix_msg_nofilmat c nclos = 0 10 ptr_file = 0 if(dix_dump_inter_next_file(control,ptr_file,file_mask, 1 wildcard_flag_standard)) then p_file = ptr_file if(log_it) then nk = file.nk_handle call dix_message(control,dix_msg_fileclose, 1 file.fnam(1:file.nk_fnam), 1 file.handle(1:nk)) endif nclos = nclos + 1 call file_close(control,file) call dix_util_link_out(file.link,control.top_file) call free_vm(control,sizeof(file),p_file,control.zone_file) control.n_file = control.n_file - 1 control.cur_file = control.top_file goto 10 end if c if(control.cur_file .eq. 0) control.cur_file = control.top_file if(nclos .eq. 0) call dix_message(control,dix_msg_nofilmat, 1 file_mask) return end subroutine file_close(control,file) implicit none c c Close a file, and return all des info to memory c include 'dix_def.inc' record /control / control !:io: control structure record /file_info/ file !:io: file control block c# integer*4 k record /des_expanded/ des_expanded pointer (p_des_expanded, des_expanded) p_des_expanded = file.top_des do while(p_des_expanded .ne. 0) k = des_expanded.link.forw call dix_des_link_out(control,file,des_expanded) p_des_expanded = k end do call dix_rms_close(control,file) c c If we had a fastion open, close it now c if(file.ptr_fast_search .ne. 0) then call dix_fastio_close(control,file) endif c return end function dix_help_rout(control) implicit none c c Easy interfase to the help function c include 'dix_def.inc' record /control/ control !:i: control block integer*4 dix_help_rout !:f: fcuntion result c# character*(max_line_length) line integer*4 nk,istat c integer*4 cli$present integer*4 dix_help c control.ncols = 80 call cli$get_value('p1',line,nk) istat = dix_help('DIX '//line(1:nk)) control.mode = mode_none control.use_mouse = cli$present('use_mouse') dix_help_rout = istat if(.not. istat) call dix_message(control,%val(istat)) return end function dix_mode_interactive(control) implicit none c c SMG call for interactive mode c set control fields for interactive mode c include 'dix_def.inc' record /control/ control !:io: control structure integer*4 dix_mode_interactive !:f: function result c# character*(max_line_length) line,err integer*4 nkar,lun logical cli$get_value logical cli$present integer*4 dix_util_get_len_fu c include '($dvidef)' c call cli$get_value('output',control.fnam_out,control.nk_fnam_out) c c Now set the width for the output c default = width of terminal, if file output, width = 132 c take the filename as input, it will return the width of the c terminal (80/132) or (if it is a file) 512. Max at 132 c call lib$getdvi(dvi$_devbufsiz,, 1 control.fnam_out(1:control.nk_fnam_out),control.ncols) c control.ncols = min(max(80,control.ncols),132) c control.nk_script_file = 0 c call cli$get_value('script',line,nkar) if(nkar .gt. 0) then c c There was a script file c line = '@'//line(1:nkar) nkar = nkar + 1 else c c Get the command to a temporary file c if(cli$present('command')) then call lib$get_lun(lun) call sys$fao('SYS$SCRATCH:DIX_TEMP.temp_input',nkar,line) open(lun,file=line(1:nkar),status='new') do while(cli$get_value('command',line,nkar)) write(lun,'(a)') line(1:nkar) end do inquire(lun,name=line) nkar = dix_util_get_len_fu(line) close(lun) endif endif c control.nk_script_file = nkar control.script_file = line(1:nkar) c control.mode = mode_interactive c call dix_symbol_add_int(control,'$NRARGS',0,err) c call dix_main_get_strict(control.strict_mode) call dix_main_add_defines(control) c c Set search parameters c call dix_search_set_flags(control,2,8) c call dix_main_set_format(control) control.use_mouse = cli$present('use_mouse') dix_mode_interactive = 1 return end subroutine dix_main_set_format(control) implicit none c include 'dix_def.inc' record /control/control c integer*4 cli$present c control.include_binary = include_binary_dot c if(cli$present('format.passall')) 1 control.include_binary = include_binary_bin if(cli$present('format.dump')) 1 control.include_binary = include_binary_fancy if(cli$present('format.hex')) 1 control.include_binary = include_binary_hex return end subroutine dix_main_add_defines(control) implicit none c include 'dix_def.inc' record /control/ control c character*(max_line_length) line,value,err integer*4 ipos,nkar,nk_val,ival,istat c logical*4 cli$get_value integer*4 dix_util_check_name logical dix_con_i4 c do while(cli$get_value('define',line,nkar)) ipos = index(line(1:nkar),'=') if(ipos .ne. 0) then c c Ad string parameter c value = line(ipos+1:nkar) nk_val = nkar-ipos nkar = ipos-1 istat = dix_util_check_name(line(1:nkar)) if(.not. istat)then call dix_message(control,%val(istat),line(1:nkar)) else if(dix_con_i4(value,nk_val,ival,.false., 1 control,.true.)) then call dix_symbol_add_int(control,line(1:nkar),ival,err) else call dix_symbol_add_str(control,line(1:nkar), 1 value(1:nk_val),err) endif endif else c c Add string parameter c istat = dix_util_check_name(line(1:nkar)) if(.not. istat)then call dix_message(control,%val(istat),line(1:nkar)) else call dix_symbol_add_int(control,line(1:nkar),1,err) endif endif end do return end function dix_mode_info(control) implicit none c cSMG call for INFO mode c set control block fields for info mode c include 'dix_def.inc' record /control/ control !:o: control block integer*4 dix_mode_info !:f: function result c# include '($dvidef)' integer*4 cli$present c call cli$get_value('output',control.fnam_out,control.nk_fnam_out) c c Set width 80 default, unless /wide, then take 132 c c c Now set the width for the output c default = width of terminal, if file output, width = 132 c take the filename as input, it will return the width of the c terminal (80/132) or (if it is a file) 512. Max at 132 c call lib$getdvi(dvi$_devbufsiz,, 1 control.fnam_out(1:control.nk_fnam_out),control.ncols) c control.ncols = min(max(80,control.ncols),132) c if(cli$present('wide')) control.ncols = 132 c c If /width present, take that value and min/max c if(cli$present('width')) then c c User specified wide c call util_cli_get_number('width',80,control.ncols) control.ncols = max(80,min(control.ncols,max_command_length)) endif c control.mode = mode_info dix_mode_info = 1 return end subroutine dix_main_get_strict(strict) implicit none include 'dix_def.inc' c c Set the strict mode flag c integer*4 strict !:i: mode flags c# logical cli$present c strict = 0 if(cli$present('STRICT.typing')) strict = strict + strict_typing if(cli$present('STRICT.declaration')) 1 strict = strict + strict_declaration if(cli$present('STRICT.local')) 1 strict = strict+strict_declaration+strict_declaration_local return end c function dix_mode_file(control) implicit none c c CLD routine for dix/file c Set control fields for file mode c include 'dix_def.inc' record /control/ control !:io: control structure integer*4 dix_mode_file c# logical cli$present c c Get qualifiers for file_mode c dix_mode_file = 0 !assume problems control.mode = mode_file c call cli$get_value('output',control.fnam_out,control.nk_fnam_out) call cli$get_value('symbol',control.symbol ,control.nk_symb) call dix_search_set_flags(control,2,8) call dix_main_get_list(control,'SELECT',control.lun_select,.false.) c control.csv.csv = .false. call dix_main_parse_csv(control) c call dix_main_add_defines(control) c control.ncols = 80 if(cli$present('wide')) control.ncols = 132 if(cli$present('width')) then c c User specified wide c call util_cli_get_number('width',80,control.ncols) control.ncols = max(80,min(control.ncols,max_command_length)) else c c If not specified and CSV , set to max c if(control.csv.csv) control.ncols = max_command_length endif c c Check for the display portions c call dix_main_set_format(control) c dix_mode_file = 1 !all oke c 90 return end subroutine dix_main_set_display(control,dis) implicit none c include 'dix_def.inc' record /control/ control record /dis_pars/ dis !:io: display structure c logical*4 flag logical*4 cli$present c if(cli$present('display')) then flag = .true. !assume all display call dix_util_set_flag('display.all',flag) dis.data = flag dis.vfc = flag dis.recnr = flag dis.recsiz = flag dis.rfa = flag c call dix_util_set_flag('display.data' ,dis.data) call dix_util_set_flag('display.vfc' ,dis.vfc) call dix_util_set_flag('display.recnr' ,dis.recnr) call dix_util_set_flag('display.recsiz',dis.recsiz) call dix_util_set_flag('display.rfa' ,dis.rfa) else c c no display present, take defaults for csv or not c if(control.csv.csv) then dis.recnr = .false. dis.recsiz = .false. dis.data = .true. dis.vfc = .false. dis.rfa = .false. else dis.recnr = .true. dis.recsiz = .true. dis.data = .true. dis.vfc = .true. dis.rfa = .true. endif end if return end c function dix_mode_screen(control) implicit none c c CLD entry for mode screen c set control fields for mode SCREEN c include 'dix_def.inc' record /control/ control !:o: control block integer*4 dix_mode_screen c include '($dvidef)' integer*4 cli$present c# control.fnam_out = 'SYS$OUTPUT' control.nk_fnam_out = 11 control.mode = mode_screen dix_mode_screen = 1 c call dix_main_add_defines(control) c c Set search parameters c call dix_search_set_flags(control,2,8) c c Set the width from the terminal c call lib$getdvi(dvi$_devbufsiz,,'SYS$INPUT',control.ncols) c call dix_main_set_format(control) control.use_mouse = cli$present('use_mouse') return end options /exte subroutine dix_main_parse_csv(control) implicit none c include 'dix_def.inc' record /control/ control c logical*4 cli$present external cli$_negated character*(max_short_line_length) line integer*4 k,nk c control.csv.csv = .false. if(cli$present('csv')) then control.csv.csv = .true. control.csv.header = cli$present('csv.header') control.csv.quotes = cli$present('csv.quote') .ne. 1 %loc(cli$_negated) control.csv.all_quotes = cli$present('csv.all_quotes') c control.csv.separator = ',' if(cli$present('csv.separator.space')) control.csv.separator = ' ' if(cli$present('csv.separator.comma')) control.csv.separator = ',' if(cli$present('csv.separator.colon')) control.csv.separator = ';' if(cli$present('csv.separator.colon')) control.csv.separator = ';' if(cli$present('csv.separator.tab')) control.csv.separator = char(9) call cli$get_value('csv.separator.character',line,nk) if(nk .gt. 0) then read(line(1:nk),2000) k 2000 format(i10) control.csv.separator = char(k) endif c control.csv.quote = '"' if(cli$present('csv.quote.quote')) control.csv.quote = '''' if(cli$present('csv.quote.doublequote')) control.csv.quote = '"' call cli$get_value('csv.quote.character',line,nk) if(nk .gt. 0) then read(line(1:nk),2000) k control.csv.quote = char(k) endif end if return end subroutine get_pasteboard(control) implicit none c C Get pastboard id for SMG c include 'dix_def.inc' record /control/ control !:io: control block c# integer*4 termtype include '($smgdef)' include '($tt2def)' external dix_msg_noscreen c integer*4 flags,old2 c c Mode was screen, this is only possible on a (vt-) terminal c screen is default, so we must check if it is possible, if not switch c to interactive c c sys$input is a terminal, so now depending on the /screen qualifier (default) c the mode is either screen or interactive c Try to create a paste_board, and see if terminal supports vt c flags = smg$m_keep_contents call smg$create_pasteboard(control.paste_id,,control.nrows, 1 control.ncols,flags,termtype) c control.ncols = min(control.ncols,max_screen_width) if(termtype .ne. smg$k_vttermtable) then control.mode = mode_interactive call dix_message(control,dix_msg_noscreen) else control.got_pasteboard = .true. endif c c Get current insert/overstrike mode c call smg$set_term_characteristics(control.paste_id,,,,,,old2) if((old2 .and. tt2$m_insert) .ne. 0) control.input_flags = 1 control.input_flags .or. input_flag_insert if((old2 .and. tt2$m_editing) .ne. 0) control.input_flags = 1 control.input_flags .or. input_flag_editing return end function dix_main_select_file(control) implicit none c c If the user entered a file mask with multiple matches and he did c not enter /MULTI, let him select one of the files c include 'dix_def.inc' record /control/ control !:io: control structure logical dix_main_select_file c# include '($smgdef)' c c Found n_file files, if wild than all ok, start with the first c else ask for correct file c record /file_info/ file pointer (p_file ,file) c character*(max_line_length) line integer*4 nk,temp_file_p,i_file,k,width,dis_id integer*4 view_rows,top_row,ikey,krow,kcol c character*(*) context parameter (context = 'SELFILES') c record /dyn_help/ help_des c width = control.ncols - 4 dix_main_select_file = .false. i_file = 0 p_file = control.top_file if(control.mode .eq. mode_screen) then call smg$create_virtual_display(control.n_file,width,dis_id) call smg$label_border(dis_id,'Select file') call help_init_std(control,help_des,'File selection',20,14,context) call help_key(control,help_des,key_exit, 1 'Select all and exit',context) call help_key(control,help_des,key_enter, 1 'Select this file',context) call help_key(control,help_des,key_fileinfo, 1 'Show info for this file',context) call help_topic_2(help_des,'Left mouse','Go to this line') call help_topic_2(help_des,'Middle mouse','Scroll up/down') call help_topic_2(help_des,'Right mouse','Select this file') call dix_smg_stack_help(control,help_des) endif c do while (p_file .ne. 0) c c Let user signal which file c tell him which files found c i_file = i_file + 1 if(control.mode .eq. mode_screen) then call lib$trim_filespec(file.fnam(1:file.nk_fnam),line, 1 width,nk) call smg$put_chars(dis_id,line(1:nk),i_file,1) else write(*,1004) i_file,file.fnam(1:file.nk_fnam) 1004 format(i4,':',a) endif c p_file = file.link.forw end do c c Let the user select c if(control.mode .eq. mode_screen) then top_row = 1 view_rows = min(control.n_file,20) call smg$create_viewport(dis_id,1,1,view_rows,width) call smg$paste_virtual_display(dis_id,control.paste_id,3,3) c i_file = 1 40 i_file = max(1,min(i_file,control.n_file)) c c Make sure line in view c do while(i_file-top_row .ge. view_rows) top_row = top_row + 1 call smg$scroll_viewport(dis_id,smg$m_up,1) enddo do while(i_file .lt. top_row) call smg$scroll_viewport(dis_id,smg$m_down,1) top_row = top_row - 1 enddo c call smg$set_cursor_abs(dis_id,i_file,1) call dix_get_key(control,ikey,krow,kcol,' ') if(ikey .eq. key_mouse_left) then if(krow .gt. 2 .and. krow .le. 2+view_rows) then i_file = krow - 2 !map row is 3 endif goto 40 elseif(ikey .eq. key_mouse_middle) then if(krow .lt. control.nrows/2) then ikey = key_prev else ikey = key_next endif elseif(ikey .eq. key_mouse_right) then if(krow .gt. 2 .and. krow .le. 2+view_rows) then i_file = krow - 2 !map row is 3 goto 80 endif goto 40 endif c if(ikey .eq. key_fileinfo) then p_file = control.top_file do k=1,i_file-1 p_file = file.link.forw end do call dix_smg_file_info_scr(control,file) elseif(ikey .eq. key_up) then i_file = i_file - 1 elseif(ikey .eq. key_down) then i_file = i_file + 1 elseif(ikey .eq. key_top) then i_file = 1 elseif(ikey .eq. key_down) then i_file = control.n_file elseif(ikey .eq. key_prev) then i_file = i_file - 10 elseif(ikey .eq. key_next) then i_file = i_file + 10 elseif(ikey .eq. key_help) then call dix_smg_help(control,context) elseif(ikey .eq. key_exit) then goto 90 elseif(ikey .eq. key_enter .or. 1 ikey .eq. key_select) then goto 80 else call dix_mes_invkey(control,context) endif goto 40 else call sys$fao('$Found !UL files, select one (^z=all) :', 1 nk,line,%val(control.n_file)) i_file = 0 do while(i_file .lt. 1 .or. i_file .gt. control.n_file) write(*,1005) line(1:nk) 1005 format(a) read(*,2005,err=90,end=90) i_file 2005 format(i6) 5 end do endif c c We got one, so now remove all others and return memory c 80 p_file = control.top_file do k=1,control.n_file if(k .eq. i_file) then control.top_file = p_file p_file = file.link.forw else temp_file_p = file.link.forw call file_close(control,file) call dix_util_link_out(file.link,control.top_file) call free_vm(control,sizeof(file),p_file,control.zone_file) control.n_file = control.n_file - 1 p_file = temp_file_p end if end do 90 p_file = control.top_file dix_main_select_file = .true. if(control.mode .eq. mode_screen) then call help_exit(help_des) call dix_smg_unstack_help(control) call smg$delete_virtual_display(dis_id) endif return end function dix_write_file(control,line,wrap) implicit none c c Write to file mode c include 'dix_interactive.inc' record /control/ control !:io: control block character*(*) line !:1: the line to write logical*4 wrap !:i: wrap wanted? integer dix_write_file !:f: function result c# character kar integer*4 pagsiz,lun_out,bpos,istat,width,nb c external rms$_eof integer*4 memtab_add_record c control.linenr = control.linenr + 1 c if(control.smg_window .ne. 0) then istat = memtab_add_record(control,control.smg_window,line) else if(control.mode .eq. mode_interactive) then c c Interactive mode. check for paged c pagsiz = 0 if(control.paged .eq. 1) pagsiz = control.nrows if(pagsiz .gt. 0) then if(mod(control.linenr,pagsiz-1) .eq. 0) then write(*,1001,err=80) 1001 format('$Type return to continue:') read(*,2000,end=70,err=80) kar 2000 format(a) endif endif call dix_inter_get_file_level_info(control,'LU',lun_out,kar) else c c Non interactive, keep gooing c lun_out = control.lun_out endif if(line(1:1) .eq. ':') then bpos = 2 else bpos = 1 end if c c If no output file yet, take the sys$output c if(lun_out .eq. 0) lun_out = control.lun_console c c Make sure the output will fit on a line c 15 if(wrap) then c inquire(lun_out,recl=width) width = control.ncols nb = min(len(line)-bpos+1,width) else nb = len(line) - bpos + 1 endif write(lun_out,1000,err=80) line(bpos:bpos+nb-1) 1000 format(a) bpos = bpos+nb if(bpos .le. len(line)) goto 15 istat = 1 endif goto 90 70 istat = %loc(rms$_eof) goto 90 80 call errsns(,istat) goto 90 90 dix_write_file = istat return end function dix_main_check_mod_record(control,file) implicit none c c Checks if the buffer has changed, and if so c if the user wants to write it out c In batch mode always update c include 'dix_def.inc' record /control/ control !:i: control block record /file_info/ file !:i: file structure integer*4 dix_main_check_mod_record !:f: function result c# logical dix_dump_record_changed logical dix_main_question external dix_msg_recchang integer*4 dix_rms_update c character*(max_line_length) line,question integer*4 nk,nk_q,bpos,epos,istat,fao_count,update_mes logical*4 do_update c istat = 1 if(file.modify) then if(file.got_record) then if(dix_dump_record_changed(file.data)) then 10 if(control.is_term) then call dix_main_get_message(control,dix_msg_recchang,nk,line, 1 fao_count,update_mes) call dix_util_file_parse(file.fnam,'N',bpos,epos) call sys$fao(line(1:nk),nk_q,question,file.fnam(bpos:epos)) do_update = dix_main_question(control,question(1:nk_q),.true.) else do_update = .true. !batch mode endif if(do_update) then istat = dix_rms_update(control,file,.true.) if(.not. istat) then call dix_message(control,%val(istat)) if(control.is_term) goto 10 !ask again (not in batch) endif endif !question to Y or batch endif !changed endif !got record endif !in modify dix_main_check_mod_record = istat return end function dix_main_question(control,question,def_answer) implicit none c c Ask a (yes/no) question and get an answer. Possibly with a default c include 'dix_def.inc' c record /control/ control !:i: control block character*(*) question !:i: the question logical def_answer !:i: answer in batch mode logical dix_main_question !:f: the answer c# logical answer character kar c logical dix_smg_question character dix_util_upcase_kar c external dix_msg_useryes external dix_msg_userno c if(control.mode .eq. mode_Screen) then c c Screen mode c answer = dix_smg_question(control,question,def_answer) else c c Text mode c if(control.is_term) then 20 if(def_answer) then write(*,1080) question 1080 format('$',a,' ([y]/n):') else write(*,1081) question 1081 format('$',a,' (y/[n]):') endif read(*,2000,end=20) kar 2000 format(a) if(kar .eq. ' ') then kar = 'N' if(def_answer) kar = 'Y' endif kar = dix_util_upcase_kar(kar) if(kar .ne. 'Y' .and. kar .ne. 'N') goto 20 answer = kar .eq. 'Y' else answer = def_answer endif endif if(answer) then dix_main_question = %loc(dix_msg_useryes) else dix_main_question = %loc(dix_msg_userno) endif return end function dix_main_check_library(line,libnam,nk_lib,may_update,defdir) implicit none c c Check if a library can be opened c character*(*) line !:i: the name character*(*) libnam !:o: the name integer*4 nk_lib !:o: length of libnam logical may_update !:o: updates allowed? character*(*) defdir !:i: default directory logical dix_main_check_library !:f: function result c# include '($lbrdef)' c integer*4 lbr_index integer*4 lbr$open c character*(*) deftype parameter (deftype = '.TLB') c if(line .eq. ' ') then nk_lib = 0 else call lbr$ini_control(lbr_index,lbr$c_update,lbr$c_typ_txt) if(lbr$open(lbr_index,line,,defdir//deftype,,libnam,nk_lib)) then call lbr$close(lbr_index) may_update = .true. else call lbr$ini_control(lbr_index,lbr$c_read,lbr$c_typ_txt) if(lbr$open(lbr_index,line,,defdir//deftype,,libnam,nk_lib)) then call lbr$close(lbr_index) else nk_lib = 0 endif endif endif dix_main_check_library = nk_lib .gt. 0 return end function dix_main_get_record(control,file,key,keyopt, 1 keyval,translate_percent) implicit none c c Get a record from a file c include 'dix_def.inc' record /control/ control !:i: control structure record /file_info/ file !:io: file structure integer*4 key !:i: key number integer*4 keyopt !:i: key -1 is seq, 0=eq,1=ge,2=gt character*(*) keyval !:i: key value logical translate_percent !:i: translate %dd to hex char?? integer*4 dix_main_get_record !:f: function result c# integer*4 istat c integer*4 dix_main_get_rec integer*4 dix_rms_get integer*4 dix_main_get_rec_keyed c if(keyopt .eq. key_opt_seq) then c c sequential read, wit or without record number c if(len(keyval) .gt. 0) then c c We did specify a record number c istat = dix_main_get_rec(control,file,keyval) else c c No , so just sequential read c istat = dix_rms_get(control,file) endif else c c Indexed, so go to keyed routine c file.cur_key = key istat = dix_main_get_rec_keyed(control,file, 1 key,keyval,len(keyval),keyopt, 1 translate_percent,.true.) end if dix_main_get_record = istat return end subroutine dix_main_get_list(control,item,lun,case) implicit none c include 'dix_def.inc' c cBuild a list of cli items in a MEMTAB file c record /control/ control!:i: control block character*(*) item !:i: cli name integer*4 lun !:o: lun for memtab (0=no list) logical*4 case !:i: case sensitive? c# character*(max_line_length) line integer*4 nk integer*4 cli$get_value c if(lun .ne. 0) call memtab_close(control,lun) lun = 0 do while(cli$get_value(item,line,nk)) if(lun .eq. 0) call memtab_init(control,lun,'LIST_'//item) if(.not. case) call str$upcase(line(1:nk),line(1:nk)) call memtab_add_record(control,lun,line(1:nk)) end do return end function dix_dcl_parse(control,string,append,quiet) implicit none c c A shell around cli$dcl_parse, since vax/alpha/ia64 have different c calling for externals c include 'dix_def.inc' record /control/ control!:io: command block character*(*) string !:i: the line to parse logical append !:i: if true, append extra prompt info to control.command_line logical*4 quiet !:i: ingore messages integer dix_dcl_parse !:f: result c# integer dix_dcl_parse_table external my_get_input c integer*4 nk_extra character*(max_command_length) line_extra common /common_my_get_input/ nk_extra,line_extra c nk_extra = 0 c dix_dcl_parse = dix_dcl_parse_table(string,my_get_input,quiet) if(append) then call dix_append(control.nk_command_line, 1 control.command_line, 1 line_extra(1:nk_extra)) endif return end c function my_get_input(result,prompt,nk) implicit none c c Execute a lib$get_input, but save extra input in line_extra c include 'dix_def.inc' character*(*) result !:o: string read in character*(*) prompt !:i: prompt line integer*4 nk !:o: length integer*4 my_get_input !:f: function result c# integer*4 nk_extra character*(max_command_length) line_extra common /common_my_get_input/ nk_extra,line_extra c integer*4 istat integer*4 lib$get_input c istat = lib$get_input(result,prompt,nk) c c Append read in string to line_extra c line_extra(nk_extra+1:) = ' '//result(1:nk) nk_extra = nk_extra + nk + 1 !+ 1 space c my_get_input = istat return end subroutine dix_main_debug(parameter,control) implicit none c c Set debug parameters c include 'dix_def.inc' c character*(*) parameter record /control/ control !:io: debug param set c# call dix_main_debug_set(parameter//'.all', 1 control.debug,-1) c call dix_main_debug_set(parameter//'.fp_conversions', 1 control.debug,debug_fp) c call dix_main_debug_set(parameter//'.descriptions', 1 control.debug,debug_des) c call dix_main_debug_set(parameter//'.keys', 1 control.debug,debug_keys) c call dix_main_debug_set(parameter//'.symbols', 1 control.debug,debug_symbols) c call dix_main_debug_set(parameter//'.command_file', 1 control.debug,debug_command) c call dix_main_debug_set(parameter//'.expand', 1 control.debug,debug_expand) c call dix_main_debug_set(parameter//'.file', 1 control.debug,debug_file) c call dix_main_debug_set(parameter//'.find', 1 control.debug,debug_find) c call dix_main_debug_set(parameter//'.vm', 1 control.debug,debug_vm) c call dix_main_debug_set(parameter//'.fastio', 1 control.debug,debug_fastio) return end subroutine dix_main_debug_show(control,line,nk) implicit none c c Show debug settings c include 'dix_def.inc' c record /control/ control !:i: control block character*(*) line !:o: the line integer*4 nk !:o: length of line c# nk = 0 if((control.debug .and. debug_fp) .ne. 0) 1 call dix_append(nk,line,'FP_CONVERSION,') if((control.debug .and. debug_des) .ne. 0) 1 call dix_append(nk,line,'DESCRIPTIONS,') if((control.debug .and. debug_keys) .ne. 0) 1 call dix_append(nk,line,'KEYS,') if((control.debug .and. debug_symbols) .ne. 0) 1 call dix_append(nk,line,'SYMBOLS,') if((control.debug .and. debug_command) .ne. 0) 1 call dix_append(nk,line,'COMMAND_FILE,') if((control.debug .and. debug_expand) .ne. 0) 1 call dix_append(nk,line,'EXPAND,') if((control.debug .and. debug_file) .ne. 0) 1 call dix_append(nk,line,'FILE,') if((control.debug .and. debug_find) .ne. 0) 1 call dix_append(nk,line,'FIND,') if((control.debug .and. debug_vm) .ne. 0) 1 call dix_append(nk,line,'VM,') if((control.debug .and. debug_fastio) .ne. 0) 1 call dix_append(nk,line,'FASTIO,') if(nk .gt. 0) then nk = nk - 1 endif return end subroutine dix_main_debug_set(param,debug_flag,value) implicit none c c Set debug flag c include '($climsgdef)' c character*(*) param !:i: parameter name integer*4 debug_flag !:i: the bit flag integer*4 value !:io: the debug flag c# logical*4 flag integer*4 dix_util_set_flag c if(dix_util_set_flag(param,flag)) then c c User specified /name or /noname c flag contains the value c if(flag) then debug_flag = debug_flag .or. value else debug_flag = debug_flag .and. .not. value endif endif return end subroutine dix_main_print_debug(control,flag,line) implicit none c c Print debug line if flag-bit of debug flag is set c include 'dix_def.inc' record /control/ control !:i: control block integer*4 flag !:i: the debug flag bit to be set character*(*) line !:i: the debug info c# external dix_msg_debug character*(max_short_line_length) name integer*4 nkn,save c if((control.debug .and. flag) .ne. 0) then c c Get the name ofg the debug flag c save = control.debug control.debug = flag call dix_main_debug_show(control,name,nkn) control.debug = save call dix_message(control,dix_msg_debug,name(1:nkn),line) endif return end