function dix_dump(control,iterm,dis) implicit none c c Duump the data, either c 1. screen mode c 2. file mode (either interactive or not) c include 'dix_def.inc' record /control/ control !:io: control structure integer*4 iterm !:o: the terminator function record /dis_pars/ dis !:i: display parameters integer*4 dix_dump !:f: function result c# record /file_info/ file !:io: the file pointer (p_file,file) c integer*4 istat logical*4 mult c integer*4 dix_dump_screen integer*4 dix_dump_interactive integer*4 dix_dump_file c if(control.mode .eq. mode_screen) then c c Screen mode c istat = dix_dump_screen (control,iterm,dis) elseif(control.mode .eq. mode_interactive) then c c Interactive mode c istat = dix_dump_interactive(control,iterm,dis,.false.) else c c File mode c p_file = control.top_file mult = file.link.forw .ne. 0 do while(p_file .ne. 0) control.rewind = .true. istat = dix_dump_file (control,file,iterm,dis,mult) p_file = file.link.forw end do end if dix_dump = istat return end subroutine dix_dump_vars(control,dis,kpl,fldsiz,posasc) implicit none c c Compute raw_dump varables depending on screen width c include 'dix_def.inc' record /control/ control !:i: control strucutre record /dis_pars/ dis !:i: display parameters integer*4 kpl !:o: bytes /line integer*4 fldsiz !:o: field size integer*4 posasc !:o: the position of the ascii display c# c if(dis.hex .eq. des_flag_translate_hex) then c c HEx display c fldsiz = dis.word*2+1 if(control.ncols .ge. 132) then kpl = 32 if(dis.word .eq. 1) kpl = 24 else kpl = 16 endif elseif(dis.hex .eq. des_flag_translate_oct) then c c Octal display, c if(dis.word .eq. 1) then fldsiz = 4 if(control.ncols .ge. 132) then kpl = 24 else kpl = 12 endif elseif(dis.word .eq. 2) then fldsiz = 7 if(control.ncols .ge. 132) then kpl = 20 else kpl = 12 endif else fldsiz = 12 if(control.ncols .ge. 132) then kpl = 24 else kpl = 16 endif endif elseif(dis.hex .eq. des_flag_translate_bin) then if(dis.word .eq. 1) then fldsiz = 9 if(control.ncols .ge. 132) then kpl = 12 else kpl = 6 endif elseif(dis.word .eq. 2) then fldsiz = 17 if(control.ncols .ge. 132) then kpl = 12 else kpl = 4 endif else fldsiz = 33 if(control.ncols .ge. 132) then kpl = 12 else kpl = 4 endif endif else !must be decimal if(dis.word .eq. 1) then fldsiz = 5 if(control.ncols .ge. 132) then kpl = 16 else kpl = 8 endif elseif(dis.word .eq. 2) then fldsiz = 7 if(control.ncols .ge. 132) then kpl = 24 else kpl = 16 endif else fldsiz = 12 if(control.ncols .ge. 132) then kpl = 24 else kpl = 16 endif end if end if posasc = kpl/dis.word*fldsiz return end function dix_dump_raw_line(control,byte_offs,kpl, 1 nb_data,data_rec,dis,posasc, 1 begpos_bol,endpos_bol,n_bol,line, 1 ppos,fldsiz,file) implicit none c c Dump one line of raw data c include 'dix_def.inc' record /control/ control !:i: control structure integer*4 byte_offs !:i: byte offset integer*4 kpl !:i: byte/line displayed integer*4 nb_data !:i: number of bytes in dta byte data_rec(*) !:i: the data record /dis_pars/ dis !:i: display parameters integer*4 posasc !:i: pos of ascii display integer*4 begpos_bol(*) !:o: start of bold printing integer*4 endpos_bol(*) !:o: end of bold printing integer*4 n_bol !:o: nbold parts (part of current key) character*(*) line !:o: the line integer*4 ppos !:o: length of line integer*4 fldsiz !:i: size of field record /file_info/ file !:i: file info integer*4 dix_dump_raw_line c# character dix_util_kar_conv logical*4 dix_rms_offset_in_key c integer*4 ipos,l,nkar,max_len,istat c include '($smgdef)' c character*(max_short_line_length) tline integer*4 data4 record /des_rec/ des_rec c istat = 1 ipos = byte_offs c c setup record offset at end of record c n_bol = 0 line = ' ' ppos = 0 c c go through all bytes to do c if(dis.hex .ne. des_flag_translate_hex) then c c Decimal dump c do l=kpl,1,-dis.word nkar = dis.word if(ipos+dis.word .gt. nb_data) nkar = nb_data-ipos data4 = 0 call dix_util_copy(nkar,data_rec(ipos+l-dis.word+1),data4) c if(ipos+l-dis.word .lt. nb_data) then c c Insert the integer format data c if(dis.unsigned) then des_rec.ent_type = enttyp_uint else des_rec.ent_type = enttyp_int endif des_rec.size = dis.word*bits_per_byte des_rec.bit_offset = 0 call dix_util_clear_descr(des_rec.fldnam,.false.) c call dix_con_intasc(nb_data,des_rec,data4,tline,nkar, 1 dis.hex,max_len,control) line(ppos+1:ppos+fldsiz) = ' ' line(ppos+fldsiz-nkar:ppos+fldsiz+1) = tline(1:nkar) if(dix_rms_offset_in_key(file,ipos+l-dis.word,nkar)) then c c Is key field c n_bol = n_bol + 1 begpos_bol(n_bol) = ppos+fldsiz-nkar endpos_bol(n_bol) = ppos+fldsiz-1 end if endif ppos = ppos + fldsiz end do else c c Hex mode c do l=kpl,1,-1 if((l .ne. kpl) .and. (mod(l,dis.word) .eq. 0)) ppos = ppos + 1 if(ipos+l .le. nb_data) then c c Insert hex (long)word format (per byte) c write(line(ppos+1:ppos+2),1010) data_rec(ipos+l) 1010 format(z2.2) if(dix_rms_offset_in_key(file,ipos+l-1,1)) then c c Is key field, so make highlight c if(n_bol .eq. 0) goto 51 if(endpos_bol(n_bol)+1 .eq. ppos+1) goto 52 51 n_bol = n_bol + 1 begpos_bol(n_bol) = ppos+1 52 endpos_bol(n_bol) = ppos+2 end if end if ppos = ppos + 2 end do end if c c now do the ascii data c ppos = posasc data4 = 0 do l=1,kpl c c set the ASCII data c if(ipos+l .le. nb_data) then call dix_util_copy(1,data_rec(ipos+l),data4) line(ppos+1:ppos+1) = dix_util_kar_conv(char(data4)) if(dix_rms_offset_in_key(file,ipos+l-1,1)) then if(n_bol .eq. 0 .or. endpos_bol(n_bol)+1 .ne. ppos+1) then n_bol = n_bol + 1 begpos_bol(n_bol) = ppos+1 end if endpos_bol(n_bol) = ppos+1 end if end if ppos = ppos + 1 end do c c insert offset if needed c if(dis.number) then c c Insert the offset c if(dis.number_hex) then ppos = ppos + 1 write(line(ppos+1:ppos+7),1000) ipos 1000 format(z7.7) ppos = ppos + 7 else ppos = ppos + 1 write(line(ppos+1:ppos+7),1001) ipos 1001 format(i7) ppos = ppos + 7 endif end if 90 dix_dump_raw_line = istat return end c function dix_dump_print_line(control,indent,line) implicit none c c Print line to file with indent c include 'dix_def.inc' record /control/ control !:io: control structure integer*4 indent !:i: indentation wanted character*(*) line !:i: the line to print logical*4 dix_dump_print_line c# integer*4 bpos,epos,istat logical first c external dix_msg_ctrlcseen logical dix_write_file c character*(max_line_length) indentasc c dix_dump_print_line = .false. c if(control.control_c_seen) then istat = %loc(dix_msg_ctrlcseen) goto 90 end if bpos = 1 first = .true. istat = 1 do while(first .or. (bpos .le. len(line))) epos = min(bpos+control.ncols-1-indent,len(line)) if(indent .gt. 0) indentasc(1:indent) = ' ' istat = dix_write_file(control, 1 indentasc(1:indent)//line(bpos:epos), 1 .false.) if(.not. istat) goto 90 bpos = epos+1 first = .false. end do 90 dix_dump_print_line = istat return end function dix_dump_print_par(control,n_par,pars,mask,hex) implicit none c c Print out parameters c include 'dix_def.inc' integer*4 n_par !:i: # parameters record /param/ pars(*) !:i: parameter data character*(*) mask !:i: print mask logical hex !:i: print in hex? record/control/ control !:io: control structure integer*4 dix_dump_print_par !:f: function result c# integer*4 nk,k,nk1,l,istat,conmask character*(max_line_length) line character*(max_short_line_length) temp c integer*4 dix_util_get_len logical*4 dix_dump_print_line logical dix_util_match_string_wild c istat = 1 do k=1,n_par nk = dix_util_get_len(pars(k).name) if(dix_util_match_string_wild(pars(k).name(1:nk),mask, 1 .false.,.false.)) then conmask = hex if(conmask .eq. des_flag_translate_nor) conmask = pars(k).hex c if(conmask .eq. des_flag_translate_hex) then call sys$fao('''!XL''X',nk1,temp,%val(pars(k).value)) elseif(conmask .eq. des_flag_translate_oct) then call sys$fao('''!OL''O',nk1,temp,%val(pars(k).value)) elseif(conmask .eq. des_flag_translate_bin) then temp = ' ' nk1 = 32 l = pars(k).value do while(l .ne. 0) temp(nk1:nk1) = '0' if(l) temp(nk1:nk1) = '1' l = ishft(l,-1) nk1 = nk1 - 1 end do if(nk1 .eq. 32) then temp(nk1:nk1) = '0' nk1 = nk1 - 1 endif temp = ''''//temp(nk1+1:32)//'''B' nk1 = 1 + 32-nk1 +1 + 2 else call sys$fao('!SL', nk1,temp,%val(pars(k).value)) endif call sys$fao('Parameter !AS = !AS',nk,line, 1 pars(k).name(1:nk),temp(1:nk1)) istat = dix_dump_print_line(control,0,line(1:nk)) if(.not. istat) goto 90 end if end do 90 dix_dump_print_par = istat return end function dix_dump_print_line_int(control,ndes,des,first_var) implicit none c c Print out descriptions (in internal-expanded format) c include 'dix_def.inc' c record /control/ control !:io: control structure integer*4 ndes !:i: ndescriptions record /des_rec_fil/des(*) !:i: descriptions integer*4 first_var !:i: first variable integer*4 dix_dump_print_line_int c# character*(max_command_length) line integer*4 nk,k,siz,depth,nk1,conmask,flag,istat integer*4 dix_dump_print_line integer*4 dix_dump_print_line_br integer*4 dix_util_get_len c logical*4 field_mode c field_mode = .false. c istat = 1 depth = 1 do k=1,ndes call dix_util_get_type_name(des(k).ent_type,line,nk,flag) if(line(1:1) .eq. '#') then c c The special commands #IF,#ELSEIF .. c if((des(k).flags .and. des_flag_has_limit) .ne. 0) then call sys$fao(' !AS',nk1,line(nk+1:),des(k).limit_value) nk = nk + nk1 endif goto 34 endif if(des(k).ent_type .eq. enttyp_field ) field_mode = .true. if(des(k).ent_type .eq. enttyp_endfield) field_mode = .false. siz = des(k).size if(.not. field_mode) siz = siz/bits_per_byte if(des(k).size_asc.dsc$w_maxstrlen .ne. 0) then nk1 = dix_util_get_len(des(k).size_asc) call sys$fao('*(!AS=!UL)',nk1,line(nk+1:), 1 des(k).size_asc,%val(siz)) nk = nk + nk1 elseif(des(k).size .gt. 0) then call sys$fao('*!UL',nk1,line(nk+1:),%val(siz)) nk = nk + nk1 endif c if((des(k).flags .and. des_flag_is_vfc) .ne. 0) then call dix_append(nk,line,'/VFC') endif c conmask = des(k).flags .and. des_flag_translate_mask if(conmask .ne. des_flag_translate_nor) then if(conmask .eq. des_flag_translate_hex) line(nk+1:) = '/HEX' if(conmask .eq. des_flag_translate_oct) line(nk+1:) = '/OCT' if(conmask .eq. des_flag_translate_bin) line(nk+1:) = '/BIN' nk = nk + 4 endif c conmask = des(k).flags .and. des_flag_case_mask if(conmask .ne. des_flag_case_no_case) then if(conmask .eq. des_flag_case_upper) line(nk+1:) = '/UPP' if(conmask .eq. des_flag_case_lower) line(nk+1:) = '/LOW' nk = nk + 4 endif c if(des(k).username .ne. ' ') then call dix_append(nk,line,'/USER='//des(k).username) endif c if((des(k).flags .and. des_flag_readonly) .ne. 0) then call dix_append(nk,line,'/READ') endif c if((des(k).flags .and. des_flag_no_display) .ne. 0) then call dix_append(nk,line,'/NODIS') endif c if((des(k).flags .and. des_flag_is_relative) .ne. 0) then call dix_append(nk,line,'/RELATIVE') endif c if((des(k).flags .and. des_flag_has_limit) .ne. 0) then call sys$fao('/LIM=!AS',nk1,line(nk+1:),des(k).limit_value) nk = nk + nk1 endif c nk = max(10,nk+2) nk = max(nk,20-depth) line(nk+1:) = des(k).name c if(des(k).ent_type .ne. enttyp_map) then nk = nk + des(k).nam_len call insert_dims(line,des(k).rep,nk) else if(des(k).rep.dim(1).low_name.dsc$w_maxstrlen .gt. 0) then if(des(k).rep.dim(1).low_is_star) then line(nk+1:nk+1) = '*' nk = nk + 1 else call sys$fao('!AS=!AS',nk1,line(nk+1:), 1 des(k).rep.dim(1).low_name, 1 des(k).rep.dim(1).high_name) nk = nk + nk1 endif endif endif c 34 if(des(k).ent_type .eq. enttyp_endstructure .or. 1 des(k).ent_type .eq. enttyp_endunion .or. 1 des(k).ent_type .eq. enttyp_endfield .or. 1 des(k).ent_type .eq. enttyp_endrange .or. 1 des(k).ent_type .eq. enttyp_endif .or. 1 des(k).ent_type .eq. enttyp_else .or. 1 des(k).ent_type .eq. enttyp_elseif .or. 1 des(k).ent_type .eq. enttyp_endmap) depth = depth - 2 c istat = dix_dump_print_line(control,depth,line(1:nk)) if(.not. istat) goto 90 if(des(k).fldnam.dsc$w_maxstrlen .ne. 0) then istat = dix_dump_print_line_br(control,depth+4,des(k).fldnam) if(.not. istat) goto 90 endif c siz = des(k).pad_value if(siz .ne. 0) then if(.not. field_mode) siz = siz/bits_per_byte call sys$fao('ALIGN !UL',nk,line,%val(siz)) istat = dix_dump_print_line(control,depth,line(1:nk)) if(.not. istat) goto 90 endif c if(des(k).ent_type .eq. enttyp_structure .or. 1 des(k).ent_type .eq. enttyp_union .or. 1 des(k).ent_type .eq. enttyp_field .or. 1 des(k).ent_type .eq. enttyp_range .or. 1 des(k).ent_type .eq. enttyp_if .or. 1 des(k).ent_type .eq. enttyp_else .or. 1 des(k).ent_type .eq. enttyp_elseif .or. 1 des(k).ent_type .eq. enttyp_map) depth = depth + 2 end do c call sys$fao('First variable line = !UL',nk,line,%val(first_var)) istat = dix_dump_print_line(control,depth,line(1:nk)) c 90 dix_dump_print_line_int = istat return end function dix_dump_print_line_br(control,indent_in,line) implicit none c c Print out line in brackets c include 'dix_def.inc' record /control/ control !:io: cotnrol strucutre integer*4 indent_in !:i: indent wanted character*(*) line !:i: the line logical*4 dix_dump_print_line_br c# logical*4 dix_dump_print_line dix_dump_print_line_br = dix_dump_print_line(control,indent_in, 1 '['//line//']') return end subroutine insert_dims(line,rep,nk) implicit none c c Insert dimensions afte a name c include 'dix_def.inc' character*(*) line !:io: the line record /repeat/ rep !:i: the repeat structure (max 3 dimensions) integer*4 nk !:io: length of line c# logical*4 hebwat,hebiets integer*4 k,nk1,bpos c hebwat = .false. bpos = nk+1 line(bpos:bpos) = '(' bpos = bpos+1 do k=1,max_dimension hebiets = .false. if(rep.dim(k).low_name.dsc$w_maxstrlen .ne. 0) then call sys$fao('!AS=!SL:',nk1,line(bpos:), 1 rep.dim(k).low_name,%val(rep.dim(k).low)) bpos = bpos + nk1 hebiets = .true. elseif(rep.dim(k).low .ne. rep.dim(k).high) then if(rep.dim(k).low .ne. 1) then call sys$fao('!SL:',nk1,line(bpos:),%val(rep.dim(k).low)) bpos = bpos + nk1 hebiets = .true. endif endif if(rep.dim(k).high_name.dsc$w_maxstrlen .ne. 0) then call sys$fao('!AS=!SL',nk1,line(bpos:), 1 rep.dim(k).high_name,%val(rep.dim(k).high)) bpos = bpos + nk1 hebiets = .true. elseif(rep.dim(k).high .ne. 1) then call sys$fao('!SL',nk1,line(bpos:),%val(rep.dim(k).high)) bpos = bpos + nk1 hebiets = .true. endif if(hebiets) then hebwat = .true. line(bpos:bpos) = ',' bpos=bpos + 1 endif end do bpos=bpos - 1 line(bpos:bpos) = ')' if(.not. hebwat) then line(nk+1:) = ' ' else nk = bpos end if return end subroutine dix_dump_copy(file) implicit none c c Copy data to save area c include 'dix_def.inc' record /file_info/ file !:io: file block c# if(file.modify) then file.data.nb_sav = file.data.nb_data call lib$movc3(file.data.nb_data,file.data.data_rec, 1 file.data.data_sav) call lib$movc3(file.data.nb_vfc, file.data.vfc_data, 1 file.data.vfc_data_sav) endif file.got_record = .true. file.rewound = .false. return end c function dix_dump_record_changed(data) implicit none c c Return true if record changed c include 'dix_def.inc' record /data_info/ data logical dix_dump_record_changed c# c logical*4 dix_dump_diff c c Assume changed c dix_dump_record_changed = .true. c c Check length first c if(dix_dump_diff(data.nb_sav,data.data_sav, 1 data.nb_data,data.data_rec)) goto 90 c if(dix_dump_diff(data.nb_vfc,data.vfc_data_sav, 1 data.nb_vfc,data.vfc_data)) goto 90 c dix_dump_record_changed = .false. 90 return end c function dix_dump_diff(nb1,data1,nb2,data2) implicit none c c See if data1(1:nb1) is differnet from data2(1:nb2) c integer*4 nb1 !:i: length of data1 byte data1(*) !:i: data1 integer*4 nb2 !:i: length of data2 byte data2(*) !:i: data2 logical*4 dix_dump_diff !:f: trus is different c# logical diff integer*4 k c diff = .true. c if(nb1 .ne. nb2) goto 90 c c Now the normal buffer data c do k=1,nb1 if(data1(k) .ne. data2(k)) goto 90 end do c diff = .false. 90 dix_dump_diff = diff return end function dix_dump_set_link(control,i_des,des_recs,err_arg, 1 file,log_it,link_rec, 1 value,link_fnam) implicit none c include 'dix_def.inc' record /control/ control !:io: the control structure integer*4 i_des !:i: the description line wanted record /des_rec/ des_recs(*) !:i: the desciptions character*(*) err_arg !:o: error argument record /file_info/ file !:i: the file logical log_it !:i: do you want to log it record /link_rec/ link_rec !:o: the link record record /value/ value !:o: the value for key/record number character*(*) link_fnam !:o: return link filename logical dix_dump_set_link !:f: the function result c# integer*4 istat,nk c external dix_msg_nolink external dix_msg_notchar external dix_msg_folrec external dix_msg_folkey external dix_msg_notlog external dix_msg_ifnottrue integer*4 dix_eval_expression c logical is_symb,is_defined c character*(max_line_length) expression,fieldname c record /link_rec/ wlink_rec pointer (p_wlink_rec,wlink_rec) c is_defined = .false. if(des_recs(i_des).p_link_rec .eq. 0) then istat = %loc(dix_msg_nolink) err_arg = ' ' call lib$movc3(des_recs(i_des).nam.dsc$w_maxstrlen, 1 %val(des_recs(i_des).nam.dsc$a_pointer), 1 %ref(err_arg)) else p_wlink_rec = des_recs(i_des).p_link_rec link_rec = wlink_rec c c Define a symbol with the name $FIELD c call dix_util_copy_string(des_recs(i_des).nam,fieldname) nk = des_recs(i_des).nam.dsc$w_maxstrlen c c store the value of the field to the symbol $FIELD c call dix_eval_cvt(control,des_recs(i_des),file,value) call dix_symbol_add(control,'$FIELD',value,err_arg) is_defined = .true. c c Evaluate the filename c nk = link_rec.nk_link_file link_fnam = link_rec.link_file(1:nk) c if(nk .gt. 0) then call dix_dump_substitute(link_fnam,nk, 1 fieldname(1:des_recs(i_des).nam.dsc$w_maxstrlen)) c istat = dix_eval_expression(control,link_fnam(1:nk), 1 value,.false.,err_arg,.false.,is_symb) if(.not. istat) goto 90 c c Result must be character c if(value.type .ne. symb_typ_char) then istat = %loc(dix_msg_notchar) goto 90 endif c link_fnam = ' ' call dix_eval_copy_char_fix(value.strdes,link_fnam,nk) endif c c First check if the IF expression is valid c if(link_rec.if_line.dsc$w_maxstrlen .ne. 0) then c c Evaluatie the (IF-)expression c call dix_util_copy_string(link_rec.IF_line,expression) nk = link_rec.if_line.dsc$w_maxstrlen call dix_dump_substitute(expression,nk, 1 fieldname(1:des_recs(i_des).nam.dsc$w_maxstrlen)) istat = dix_eval_expression(control,expression(1:nk), 1 value,.false.,err_arg,.false.,is_symb) if(.not. istat) goto 90 if(value.type .ne. symb_typ_log) then istat = %loc(dix_msg_notlog) err_arg = expression(1:nk) goto 90 endif if(.not. value.lval) then err_arg = expression(1:nk) istat = %loc(dix_msg_ifnottrue) goto 90 endif endif c c Check if compute field c if(link_rec.comp_line.dsc$w_maxstrlen .eq. 0) then c c No, so take the contents of the field c call dix_eval_cvt(control,des_recs(i_des),file,value) istat = 1 else c c Evaluate c call dix_util_copy_string(link_rec.comp_line,expression) nk = link_rec.comp_line.dsc$w_maxstrlen c c Now substitute 'thisfield' by the name of the field c call dix_dump_substitute(expression,nk, 1 fieldname(1:des_recs(i_des).nam.dsc$w_maxstrlen)) istat = dix_eval_expression(control,expression(1:nk), 1 value,.false.,err_arg,.false.,is_symb) endif if(istat) then if(log_it) then call dix_con_value_intasc(control,value,expression, 1 nk,des_flag_translate_nor) if(link_rec.key_nr .lt. 0) then c c Follow link record c call dix_message(control,dix_msg_folrec, 1 link_rec.link_file(1:link_rec.nk_link_file), 1 expression(1:nk)) else c c Following link key c call dix_message(control,dix_msg_folkey, 1 link_rec.link_file(1:link_rec.nk_link_file), 1 expression(1:nk),%val(link_rec.key_nr)) endif endif endif endif 90 if(is_defined) then call dix_symbol_delete(control,'$FIELD',.false.,.true.,.false.) endif dix_dump_set_link = istat return end subroutine dix_dump_substitute(expression,nk,fieldname) implicit none c c Replace 'this_field' with the name of the field c character*(*) expression integer*4 nk character*(*) fieldname c# character*(*) thisfield parameter (thisfield='''THISFIELD''') c integer*4 ipos c 20 ipos = index(expression(1:nk),thisfield) if(ipos .ne. 0) then expression = expression(1:ipos-1)// 1 fieldname//expression(ipos+len(thisfield):nk) nk = nk - len(thisfield) + len(fieldname) goto 20 endif return end function dix_dump_check_deposit(control,file,des_rec, 1 n_des_recs,des_recs, 1 ascdat,dis,repaint,is_getfields,in_vfc) implicit none c c We have a new value in the ascdat c Return false if convert is not oke c include 'dix_def.inc' record /control/ control !:io: control structure record /file_info/ file !:io: the file+data record /des_rec/ des_rec !:i: the current des_rec integer*4 n_des_recs !:i: #des recs record /des_rec/ des_recs(*) !:i: the des_recs character*(*) ascdat !:i: the (modified) data record /dis_pars/ dis !:i: display mode wanted logical repaint !:o: signal record repaint logical is_getfields !:i: was key getfields? logical*4 in_vfc !:i: in vfc buffer? integer*4 dix_dump_check_deposit c# record /data_info/ temp_data integer*4 nbits_f,k,stat,total_size integer*4 pos1,siz1,pos2,siz2,pad_value,n_padded logical larger,is_rec_size,allow_change_recl c record /des_rec_fil/ des_rec_fil pointer (p_des_rec_fil,des_rec_fil) c logical dix_con_ascint logical dix_main_question logical dix_util_overlap external dix_msg_reclchg external dix_msg_rectrunc external dix_msg_cannotchg external dix_msg_canmaxrel c c Assume convert of text went wrong, and repaint is not needed c dix_dump_check_deposit = .false. repaint = .false. c allow_change_recl = (file.indexed .or. file.relative) .and. 1 .not. file.fixed if(is_getfields) goto 10 c c If des_rec points to the recordsize the bit_offset is <0 c (.nb_data is before .data_rec) c is_rec_size = des_rec.bit_offset .lt. 0 c c Try to convert, this can modify temp_data c if(in_vfc) then stat = dix_con_ascint(ascdat,temp_data.vfc_data,des_rec, 1 dis.hex,nbits_f,control) else stat = dix_con_ascint(ascdat,temp_data.data_rec,des_rec, 1 dis.hex,nbits_f,control) endif if(stat) then c c Conversion success c if(is_rec_size) then c c check if the record length is changed c if(file.data.nb_data .eq. temp_data.nb_data) goto 80 c c Record length has changed, see if possible c if(.not. allow_change_recl) then c c Cannot really change recl c call dix_message(control,dix_msg_cannotchg) goto 90 endif c c Now set larger flag (for the message) and set the new length c if(file.maxrecl .ne. 0) then if(temp_data.nb_data .gt. file.maxrecl) then call dix_message(control,dix_msg_canmaxrel, 1 %val(temp_data.nb_data), 1 %val(file.maxrecl)) goto 90 endif endif c larger = file.data.nb_data .gt. temp_data.nb_data file.data.nb_data = temp_data.nb_data else c c Check for room for data c total_size = des_rec.size + des_rec.pad_value if((nbits_f .ne. des_rec.size)) then c c check for .pad_value c c c Now the total allowed size is .size + .pad_value c The new length must be <=total_size c and > total_size-pad_value c p_des_rec_fil = des_rec.link_back pad_value = des_rec_fil.pad_value !get original pad value c c Now compute new pad value c n_padded = mod(des_rec.bit_offset + nbits_f,pad_value) if(n_padded .ne. 0) n_padded = pad_value - n_padded c c If n_padded >0, fill the bits after nbits_f with 0 c this is max 32 bits, so an integer*4 (0 filled) will suffice c if(n_padded .gt. 0) then k = 0 call dix_util_move_bits(n_padded,k,0, 1 temp_data.data_rec,des_rec.bit_offset+nbits_f, 1 n_padded,.false.) endif c if(nbits_f .gt. total_size .or. 1 nbits_f .le. total_size-pad_value) then c c Does not fit in original field, c Now compute the new pad size and adapt nbits_f c nbits_f = nbits_f + n_padded else c c Still fits in original space, adjust the size c des_rec.pad_value = n_padded !new pad value des_rec.size = nbits_f !new actual size nbits_f = nbits_f + n_padded !copy so many bits goto 40 !just insert the data endif else goto 40 !new_size=old_size, just insert endif !new_size=old_size c c Size changed, check if var type record c either by explicitly changing record length or by c modifying variable field c changing record length is possible for c indexed/relative file (if not fixed record length) c in all other cases this means lost data (recl>) or c new data (recl<0) c if(.not. allow_change_recl) then c c ASk the user if he is really sure c if(.not. dix_main_question(control, 1 'Cannot change record length, continue', 1 .true.)) goto 90 end if c c Yes we want to do it, insert the new data (if data has changed) c pos1 = des_rec.bit_offset/bits_per_byte siz1 = total_size/bits_per_byte !orig size siz2 = nbits_f/bits_per_byte !new size larger = siz2 .gt. siz1 if(larger) then c c Large new data, move the rest of the buffer to the end c this can only happen in "non-field" mode, so we can use c byte mode moves c do k=1,file.data.nb_data-pos1-siz1 file.data.data_rec(file.data.nb_data-k+1+ 1 siz2-siz1) = 1 file.data.data_rec(file.data.nb_data-k+1) end do else c c Smaller new data, move the rest of the buffer down c this can only happen in "non-field" mode, so we can use c byte mode moves c call dix_util_copy(file.data.nb_data-pos1-siz1, 1 file.data.data_rec(pos1+1+siz1), 1 file.data.data_rec(pos1+1+siz2)) c end if c c Check if record length can be changed c if(.not. allow_change_recl) then c file.data.nb_data = file.data.nb_data + 1 (nbits_f - total_size)/bits_per_byte file.data.nb_data = max(file.minrecl,file.data.nb_data) c if(file.maxrecl .ne. 0) then file.data.nb_data = min(file.maxrecl,file.data.nb_data) end if endif endif c if(larger) then call dix_message(control,dix_msg_reclchg, 1 %val(file.data.nb_Data)) else call dix_message(control,dix_msg_rectrunc, 1 %val(file.data.nb_Data)) end if !recl changed repaint = .true. c c Copy data in c 40 if(in_vfc) then call dix_util_move_bits(nbits_f, 1 temp_data.vfc_data,des_rec.bit_offset, 1 file.data.vfc_data,des_rec.bit_offset, 1 nbits_f,.false.) c else call dix_util_move_bits(nbits_f, 1 temp_data.data_rec,des_rec.bit_offset, 1 file.data.data_rec,des_rec.bit_offset, 1 nbits_f,.false.) endif c else c c Convert went wrong c goto 90 endif c c Because of map (data overlying other data), we must check if something c changed for other fields, and if so do repaint the line c c If someone is dependend on this value, signal a repaint c and do the repaint c c Get the pos/size of the (changed) data c 10 if(in_vfc) goto 80 pos1 = des_rec.bit_offset siz1 = des_rec.size c if((des_rec.flags .and. des_flag_has_dependancy).ne.0)repaint =.true. if(repaint) goto 80 c do k=1,n_des_recs pos2 = des_recs(k).bit_offset siz2 = des_recs(k).size if(dix_util_overlap(pos1,siz1,pos2,siz2)) then if((des_recs(k).flags .and. des_flag_has_dependancy) .ne. 0) then repaint = .true. goto 80 endif end if end do c c 80 dix_dump_check_deposit = .true. 90 return end c function dix_dump_display_all(control,offset_in,data,nb_data,file, 1 modified,screen_mode,fieldname) implicit none c c Display data in all formats, and let user modify (if /mod ) c include 'dix_def.inc' record /control/ control !:i: control block byte data(*) !:i: the ddata integer*4 nb_data !:i: the record size record /file_info/ file !;I; file information integer*4 offset_in !:i: start offset logical*4 modified !:o: true if byte modified logical screen_mode !:i: screen mode ? character*(*) fieldname !:i: fieldname integer*4 dix_dump_display_all !:f: function result c# record /dyn_help/ help_des record /des_rec/ des_rec c integer*4 iterm,dis_id,nkar,offset,k,col,ind,row,gotnr,l,offset_old integer*4 max_len,width,nkar1,krow,kcol,nrows,nk,istat character*(max_screen_width) line,line1 logical*4 hex character*(*) context parameter (context='DISPLAY_ALL') c include '($smgdef)' c logical*4 dix_util_kar_in_ran logical*4 dix_dump_in_modify logical*4 dix_con_ascint integer*4 dix_dump_print_line c integer*4 n_convs parameter (n_convs=22) integer*4 con_types(n_convs) integer*4 con_sizes(n_convs) integer*4 max_names_width parameter (max_names_width=11) character*(max_names_width) con_names(0:n_convs) logical*1 con_valid(n_convs) c data con_types/enttyp_int ,enttyp_int ,enttyp_int , 1 enttyp_uint ,enttyp_uint ,enttyp_uint , 1 enttyp_real_F,enttyp_real_G,enttyp_real_H, 1 enttyp_real_D,enttyp_real_S,enttyp_real_T, 1 enttyp_real_x, 1 enttyp_log ,enttyp_uic ,enttyp_chr , 1 enttyp_dat ,enttyp_dat ,enttyp_prot , 1 enttyp_revint,enttyp_fid ,enttyp_bits/ data con_sizes/ 1, 2, 4, 1 1, 2, 4, 1 4, 8, 16, 1 8, 4, 8, 1 16, 1 1, 4, 4, 1 4, 8, 2, 1 4, 6, 1/ data con_names/'Raw data ', 1 'INTEGER*1 ','INTEGER*2 ','INTEGER*4 ', 1 'UINTEGER*1 ','UINTEGER*2 ','UINTEGER*4 ', 1 'REAL_F*4 ','REAL_G*8 ','REAL_H*16 ', 1 'REAL_D*8 ','REAL_S*4 ','REAL_T*8 ', 1 'REAL_X*8 ', 1 'LOGICAL*1 ','UIC ','CHARACTER*4', 1 'DATE*4 ','DATE*8 ','PROTECTION', 1 'RINTEGER ','FILEID ','BITS '/ c external dix_msg_converr c c Create help page c hex = des_flag_translate_nor istat = 1 c modified = .false. if(screen_mode) then call help_init(help_des,'Dump_all formats',20,0) c call help_topic(help_des,'Moves') call help_key(control,help_des,key_left, 1 'offset one position left',context) call help_key(control,help_des,key_right, 1 'Offset one position right',context) call help_key(control,help_des,key_up, 1 'previous item',context) call help_key(control,help_des,key_down, 1 'next item',context) call help_key(control,help_des,key_swap_dis, 1 'Toggle hex/decimal input',context) call help_key(control,help_des,key_swap_num, 1 'Lets user input new offset',context) call help_key(control,help_des,key_top, 1 'first line',context) call help_key(control,help_des,key_bot, 1 'last line',context) call help_topic(help_des,'other keys') c call help_key(control,help_des,key_exit, 1 'exit show mode',context) call help_text(help_des, 1 'Enter or Printable character will enter edit field') call dix_smg_stack_help(control,help_des) c endif offset = offset_in/bits_per_byte c col = sizeof(con_names(1))+2 c c We need to display 16 bytes (space,xx) so the 16*3 c width = col+16*3 + 2 if(screen_mode) then nrows = n_convs+2 call smg$create_virtual_display(nrows,width,dis_id) call smg$paste_virtual_display(dis_id,control.paste_id,2, 1 control.ncols-width-1) c call smg$put_chars(dis_id,con_names(0),1,1) do k=1,n_convs call smg$put_chars(dis_id,con_names(k),k+1,1) end do c call smg$draw_line(dis_id,2,col-1,2,width) call smg$draw_line(dis_id,1,col-1,n_convs+1,col-1) endif c ind = 1 10 if(screen_mode) then call sys$fao('All format display at offset !UL',nkar,line, 1 %val(offset)) call smg$label_border(dis_id,line(1:nkar)) endif do k=1,16 write(line(k*3-2:k*3),1010) data(offset+k) 1010 format(z2.2,1x) end do nkar = 48 c if(screen_mode) then call smg$put_chars(dis_id,line,1,col) !,,smg$m_underline) else call sys$fao('!5UL|!AS',nkar1,line1,%val(offset),fieldname) istat = dix_dump_print_line(control,0,line1(1:nkar1)// 1 '|'//con_names(0)//'|'//line(1:nkar)) if(.not. istat) goto 90 endif c gotnr = 0 do k=1,n_convs l = con_sizes(k) if(l+offset-1 .ge. nb_data) then call sys$fao('**OUT OF BUFFER**',nkar,line) con_valid(k) = .false. else des_rec.ent_type = con_types(k) des_rec.size = con_sizes(k)*bits_per_byte call dix_util_clear_descr(des_rec.fldnam,.false.) des_rec.min_val = 0 des_rec.max_val = 0 des_rec.flags = 0 call dix_con_intasc(con_sizes(k),des_rec, 1 data(offset+1),line,nkar,hex,max_len,control) if(gotnr .eq. 0) gotnr = k con_valid(k) = .true. end if if(screen_mode) then call smg$put_chars(dis_id,line(1:nkar),k+1,col,smg$m_erase_to_eol) else istat = dix_dump_print_line(control,nkar1,'|'//con_names(k)// 1 '|'//line(1:nkar)) if(.not. istat) goto 90 endif end do if(.not. screen_mode) goto 99 c 20 if(.not. con_valid(ind)) ind = gotnr row = ind+1 c call smg$set_cursor_abs(dis_id,row,col) call dix_get_key(control,iterm,krow,kcol,' ') c offset_old = offset c if(iterm .eq. key_mouse_left) then krow = krow - 2 !pasted at row 2 and row 1 is header if(con_valid(krow)) ind = krow !select if valid goto 20 elseif(iterm .eq. key_mouse_middle) then krow = krow - 1 kcol = kcol -control.ncols-width-1 if(krow .ge. 1 .and. krow .le. nrows/4) then iterm = key_up elseif(krow .ge. 3*nrows/4 .and. krow .le. nrows) then iterm = key_down elseif(kcol .ge. 1 .and. kcol .le. width/4) then iterm = key_left elseif(kcol .ge. 3*width/4 .and. kcol .le. width) then iterm = key_right else goto 20 endif elseif(iterm .eq. key_mouse_right .or. iterm .eq. key_menu) then nk = 0 call sys$fao(nk,line,'Exit,Offset') if(hex .eq. des_flag_translate_nor) then call dix_append(nk,line,',Decimal') elseif(hex .eq. des_flag_translate_oct) then call dix_append(nk,line,',Octal') elseif(hex .eq. des_flag_translate_bin) then call dix_append(nk,line,',Binary') else call dix_append(nk,line,',Hex') endif c call dix_smg_select_menu(control,line(1:nk), 1 line,.false.,'Choises',0,0,.true.) if(line(1:1) .eq. 'B') then iterm = key_display_binary elseif(line(1:1) .eq. 'D') then iterm = key_display_decimal elseif(line(1:1) .eq. 'E') then iterm = key_exit elseif(line(1:1) .eq. 'H') then iterm = key_display_hex elseif(line(1:2) .eq. 'OC') then iterm = key_display_octal elseif(line(1:2) .eq. 'OF') then iterm = key_swap_num else goto 20 endif endif if(iterm .eq. key_top) then ind = 1 do while(.not. con_valid(ind)) ind = ind+1 end do elseif(iterm .eq. key_up) then k = ind-1 do while(k .gt. 1 .and. .not. con_valid(k)) k = k-1 end do if(con_valid(k)) ind = k elseif(iterm .eq. key_display_hex) then hex = des_flag_translate_hex goto 10 elseif(iterm .eq. key_display_decimal) then hex = des_flag_translate_nor goto 10 elseif(iterm .eq. key_display_octal) then hex = des_flag_translate_oct goto 10 elseif(iterm .eq. key_display_binary) then hex = des_flag_translate_bin goto 10 elseif(iterm .eq. key_swap_num) then call dix_smg_get_int(control,'Offset value',offset, 1 0,nb_data-1) elseif(iterm .eq. key_bot) then ind = n_convs do while (.not. con_valid(ind)) ind = ind-1 end do elseif(iterm .eq. key_down) then k = ind+1 do while(k .lt. n_convs .and. .not. con_valid(k)) k = k+1 end do if(con_valid(k)) ind=k elseif(iterm .eq. key_left) then offset = max(0,offset-1) elseif(iterm .eq. key_right) then offset = min(nb_data-1,offset+1) elseif(iterm .eq. key_help) then call dix_smg_help(control,context) elseif(iterm .eq. key_exit) then goto 90 elseif(dix_util_kar_in_ran(iterm) .or. 1 iterm .eq. key_enter) then if(dix_dump_in_modify(control,file.modify,.false.)) then call dix_smg_get_string(control,dis_id,row,col,30, 1 line,0,iterm,nkar,.false.) des_rec.ent_type = con_types(ind) des_rec.size = con_sizes(ind)*bits_per_byte call dix_util_clear_descr(des_rec.fldnam,.false.) des_rec.flags = 0 if(dix_con_ascint(line(1:nkar),data(offset+1), 1 des_rec,hex,k,control)) then modified = .true. else call dix_message(control,dix_msg_converr) end if goto 10 end if else call dix_mes_invkey(control,context) end if if(offset .ne. offset_old) goto 10 goto 20 90 call smg$delete_virtual_display(dis_id) call dix_smg_unstack_help(control) call help_exit(help_des) 99 dix_dump_display_all = istat return end function dix_dump_get_rfa(control,file,rfa_wanted) implicit none c c Set the file to the wanted rfa c if the rfa is already oke, do nothing c include 'dix_def.inc' record /control/ control !:i: control block record /file_info/ file !:io: file block record /rfa/ rfa_wanted !:i: wanted rfa integer*4 dix_dump_get_rfa !:f: result c record /rfa/ rfa integer*4 istat c integer*4 dix_rms_get_rfa c c GEt current rfa c call dix_rms_return_rfa(file,rfa) c c See if different c if(rfa.bbnr .eq. rfa_wanted.bbnr .and. 1 rfa.offset .eq. rfa_wanted.offset) then c c No so all oke c istat = 1 else c c Force the new read c istat = dix_rms_get_rfa(control,file,file.cur_key,rfa_wanted) endif dix_dump_get_rfa = istat return end subroutine dix_dump_create_header3(line,nk,kpl,fldsiz,dis,posasc) implicit none c c Compute a heqader line for a binary dumpc c part 1 : the offsets for the binary part c part 2 : the offsdet for the ascii part c include 'dix_def.inc' character*(*) line integer*4 nk integer*4 kpl record /dis_pars/ dis integer*4 fldsiz integer*4 posasc c integer*4 k,l,row,col character kar c line = ' ' do k=0,kpl-1 c c Take the low 4 bits (in 32 byte display two times the same) c l = iand(k,15) c c The kar fotr the ascii part, increasing c if(l .gt. 9) then kar = char(l+ichar('A')-10) else kar = char(l+ichar('0')) end if c c Now kar = 0..9 or A..Z c now insert asc_kar in ascii part c l = k*bits_per_byte call dix_dump_get_coord(l,.true.,dis,kpl,posasc,fldsiz,row,col) line(col:col) = kar nk = col c c And now for the binary part c call dix_dump_get_coord(l,.false.,dis,kpl,posasc,fldsiz,row,col) c c Now for bin/hex display all offset positions c if(dis.hex .eq. des_flag_translate_nor .or. 1 dis.hex .eq. des_flag_translate_nor) then c c But for dec/octal onlty the word size offsets c if(mod(K,dis.word) .ne. 0) col = -1 end if c c now insert bin_kar in binary part c if(col .gt. 0) line(col:col) = kar end do return end c subroutine dix_dump_get_coord(indx,ascdis, 1 dis,kpl,posasc,fldsiz,row,col) implicit none c c Compute the correct coordinates in disp c the input is indx the bit offset c the output is row,col c include 'dix_def.inc' include 'dix_screen_def.inc' integer*4 indx !:i: the bit offset logical*4 ascdis record /dis_pars/ dis !:i: display params integer*4 kpl !:i: #bytes/line integer*4 posasc !:i: position of ascii part integer*4 fldsiz !:i: width for decimal display integer*4 row !:o: the row integer*4 col !:o: the col c integer*4 k,l,offset,bits_per_char c c c Comput row/col on screen c 3 modes Both of them in data and vfc buffer c 1. Ascii mode c 2. Binary/hex c 2. binary/dec c offset = indx/bits_per_byte row = offset/kpl+1 c if(ascdis) then c c Mode 1 ascii c col = posasc + mod(offset,kpl) + 1 else c c Mode 2 binary part c c if(dis.hex .eq. des_flag_translate_hex) then bits_per_char = 4 elseif(dis.hex .eq. des_flag_translate_bin) then bits_per_char = 1 elseif(dis.hex .eq. des_flag_translate_oct) then bits_per_char = 3 else bits_per_char = dis.word*bits_per_byte endif c c Now compute the how may'th word we are c k = mod(indx,kpl*bits_per_byte) c c Now k = 0..kpl*8-1, Reverse the index c k = kpl*bits_per_byte-1- k c c Now k=kpl*8-1..0 c Earch word has dis.word*bits_per_byte bits c k = k/(dis.word*bits_per_byte) c c Now we are in the 'k'th word (0..n-1) c Set the cursor ar the end of the 'k'th word c col = (k+1)*fldsiz-1 c c For binary/octal display, we can position to all characters, so now c adjust c c# if(dis.hex .eq. des_flag_translate_bin .or. c# 1 dis.hex .eq. des_flag_translate_hex) then if(dis.hex .ne. des_flag_translate_nor) then c l = mod(indx,dis.word*bits_per_byte) c c L is the bit-offset in the word, each 'incr' bits takes one char c col = col - l/bits_per_char end if c end if return end