From: EXPCOL 5-JUL-1983 17:21 To: MANAGER c c program to reformat a file, or create a blank file with a given format c program fix_file character line*512, last*512, t*80, - infile*80, outfile*80, org*10, rec*10 integer*2 i, j, k, l, llen, lastlen, get_next_atom, case, length, - nkeys, key( 5 ), nfields, field( 0:15 ), ndupls, dupl( 5 ), - trn_int integer*4 stat logical*1 copy, fixp, abbr c c parse the command line: c set up defaults c line = '$_Output File: '! the input prompt llen = 15 ! & its length infile = ' ' ! no input file yet rec = 'variable' ! recordtype org = 'sequential' ! file organization length = -1 ! record length depends on fields case = 0 ! file doesn't get upcased nfields = 0 ! lines aren't divided into fields nkeys = 0 ! no indexing keys ndupls = 0 ! don't get rid of duplicates copy = .true. ! use an input file fixp = .false. ! and don't fix the fields c c start parsing c i = 1 do while ( i .ne. 0 ) i = get_next_atom( t, j, line( :llen )) ! get the next bit of command if ( i .eq. 1 ) then ! is it a qualifier? if ( abbr( 'noi*nput', t( :j ))) then copy = .false. else if ( abbr( 'f*ix', t( :j ))) then fixp = .true. else if ( abbr( 'nof*ix', t( :j ))) then fixp = .false. else if ( abbr( 'i*nput', t( :j ))) then copy = .true. call get_value( infile, j ) else if ( abbr( 'o*rganization', t( :j ))) then call get_value( t, j ) if ( abbr( 's*equential', t( :j ))) then org = 'sequential' else if ( abbr( 'r*elative', t( :j ))) then org = 'relative' else if ( abbr( 'i*ndexed', t( :j ))) then org = 'indexed' else type *, '%Unrecognised file organization' end if else if ( abbr( 're*cord_type', t( :j ))) then call get_value( t, j ) if ( abbr( 'v*ariable', t( :j ))) then rec = 'variable' else if ( abbr( 'f*ixed', t( :j ))) then rec = 'fixed' else if ( abbr( 's*egmented', t( :j ))) then type *, '%Sorry, no segmented files' else type *, '%Unrecognised record type' end if else if ( abbr( 'le*ngth', t( :j ))) then call get_value( t, j ) length = trn_int( t( :j )) else if ( abbr( 'fie*lds', t( :j ))) then call get_value( t, j ) call trn_list( t( :j ), field( 1 ), nfields ) else if ( abbr( 'k*eys', t( :j ))) then call get_value( t, j ) call trn_list( t( :j ), key, nkeys ) else if ( abbr( 'ri*dupl', t( :j ))) then call get_value( t, j ) call trn_list( t( :j ), dupl, ndupls ) else if ( abbr( 'nor*idupl', t( :j ))) then ndupls = 0 else if ( abbr( 'u*pcase', t( :j ))) then case = 1 else if ( abbr( 'lo*wcase', t( :j ))) then case = -1 else if ( abbr( 'noc*ase', t( :j ))) then case = 0 else type *, '%Unrecognised qualifier:', t( :j ) end if else if ( i .gt. 0 ) then ! if it's not a qualifier, outfile = t ! it must be a parameter llen = 0 ! since we have the parameter, no more prompting end if end do c c translate the fields array to the way I want it c field( 0 ) = 0 do i = 1, nfields field( i ) = field( i ) + field( i-1 ) end do c c if no input file, use same name as output file c if ( infile .eq. ' ' ) then infile = outfile end if c c if no length spec, use maxfields c if ( length .lt. 0 ) length = field( nfields ) c c open the input file, if using one c if ( copy ) open( 1, file=infile, status='old', readonly ) c c open the output file, as per instructions c if ( org .ne. 'indexed' ) then open( 2, file=outfile, status='new', carriagecontrol='list', - organization=org, recordtype=rec, recl=length ) else if ( nkeys .le. 0 ) then type *, '%No keys specified' call exit else if ( nkeys .eq. 1 ) then open( 2, file=outfile, status='new', carriagecontrol='list', - organization=org, recordtype=rec, recl=length, - key=( field( key(1)-1 )+1 : field( key(1)))) else if ( nkeys .eq. 2 ) then open( 2, file=outfile, status='new', carriagecontrol='list', - organization=org, recordtype=rec, recl=length, - key=( field( key(1)-1 )+1 : field( key(1)), - field( key(2)-1 )+1 : field( key(2)))) else if ( nkeys .eq. 3 ) then open( 2, file=outfile, status='new', carriagecontrol='list', - organization=org, recordtype=rec, recl=length, - key=( field( key(1)-1 )+1 : field( key(1)), - field( key(2)-1 )+1 : field( key(2)), - field( key(3)-1 )+1 : field( key(3)))) else type *, '%Too many keys specified' call exit end if if ( .not. copy ) call exit c c copy from input to output, "fixing" as we go along c i = 0 ! # of lines input j = 0 ! # of lines output do while ( .true. ) read( 1, 1000, end=900 ) llen, line ! input a line i = i + 1 if ( mod( i, 500 ) .eq. 0 ) type *, 'at line', i ! give status update if ( fixp ) then do k = 1, nfields ! if fixing, do call fix( line( field(k-1)+1 : field(k)), 0 ) end do end if if ( case .gt. 0 ) then ! change case, call upcase( line( :llen )) ! if told to do so else if ( case .lt. 0 ) then call lowcase( line( :llen )) end if if ( ndupls .ne. 0 ) then ! are we checking for duplicates? copy = .true. ! copy is true if line is a duplicate do k = 1, ndupls ! look for differences l = dupl( k ) if ( line( field(l-1)+1 : field(l)) .ne. - last( field(l-1)+1 : field(l))) then copy = .false. ! found one! if ( field(l) - field(l-1) .lt. 6 ) goto 500 if ( line( field(l-1)+1 : field(l-1)+6 ) .ne. - last( field(l-1)+1 : field(l-1)+6 )) goto 500 end if ! if serious, give up end do if ( .not. copy ) then ! if minor differences were found, ... type *, 'Do these lines look the same to you?' type *, '1 : "' // last( :lastlen ) // '"' type *, '2 : "' // line( :llen ) // '"' call lib$get_input( t, 'Well? ' ) ! ask the user if ( t(:1) .eq. 'Y' .or. t(:1) .eq. 'y' ) copy = .true. end if else copy = .false. ! if not checking, it's not a duplicate end if 500 if ( .not. copy ) then ! if not a duplicate, write( 2, 2000 ) line( :llen ) ! output it j = j + 1 last = line ! & remember it to campare next time lastlen = llen end if end do 900 continue ! exit the program type *, i, ' lines input' ! giving statistics, of course type *, j, ' lines output' close( 1 ) close( 2 ) call exit 1000 format( q, a ) 2000 format( a ) end c c----------------------------------------------------------------------- c translates a list of integers from string form to array form c subroutine trn_list( str, list, num ) character*(*) str integer*2 num, list(*), p, t, l_blank, trn_int p = 1 + l_blank( str ) if ( str( p:p ) .eq. '(' ) then num = 0 p = p + 1 + l_blank( str( p+1: )) 10 num = num + 1 list( num ) = trn_int( str( p: ), t ) p = p + t + l_blank( str( p+t: )) if ( str( p:p ) .eq. ',' ) then p = p + 1 goto 10 end if else list( 1 ) = trn_int( str, t ) num = 1 end if return end