program main !*****************************************************************************80 ! !! stripper() allows a user to interactively modify a file. ! ! Discussion: ! ! This program can do a lot of things, but you'd best go look ! at the HELP routine to get a sketchy idea of what and how. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 August 2009 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: lunit1 = 2 integer, parameter :: lunit2 = 3 integer, parameter :: mmax = 5000 logical back character ( len = 6 ) chunk character ( len = 2 ) combeg character ( len = 2 ) comend character ( len = 80 ) command logical commentout integer iblank integer icap integer icapf integer icapfc integer icolumn integer icomment integer icon character ( len = 40 ) cut character ( len = 80 ) input integer ios integer ireph integer irepv integer join character ( len = 40 ) keep integer keep_max integer keep_min character ( len = 40 ) kill character ( len = 10 ) lang logical left logical lexist integer lwrap integer margel integer marger integer mreci integer mreco integer nchunk integer number character ( len = 80 ) output logical page logical pause logical dorot13 logical s_eqi logical shocon character ( len = 10 ) showme call timestamp ( ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'stripper():' write ( *, '(a)' ) ' FORTRAN90 version' ! ! Shut FTNCHEK's whining. ! back = .false. commentout = .false. lang = ' ' ! ! Say hello. ! call hello command = 'DEFAULTS' do ! ! No command. ! if ( command == ' ' ) then ! ! BACK command ! else if ( s_eqi ( command, 'BACK' ) ) then back = .not. back showme = 'back' ! ! BREAK command ! else if ( s_eqi ( command, 'BREAK' ) ) then join = -1 showme = 'break' ! ! CHUNK = ! else if ( s_eqi ( command(1:5), 'CHUNK' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:6), 'CHUNK=' ) ) then chunk = command(7:) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Enter chunking (FNAME, LINE, LINEP, or WORD):' read ( *, '(a)', iostat = ios ) chunk if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'chunk' ! ! COMBEG= ! else if ( s_eqi ( command(1:6), 'COMBEG' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:7), 'COMBEG=' ) ) then combeg = command(8:) else write ( *, '(a)' ) 'Enter "comment begin" characters:' read ( *, '(a)', iostat = ios ) combeg if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'COMBEG' ! ! COMEND= ! else if ( s_eqi ( command(1:6), 'COMEND' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:7), 'COMEND=' ) ) then comend = command(8:) else write ( *, '(a)' ) 'Enter "comment end" characters:' read ( *, '(a)', iostat = ios ) comend if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'COMEND' ! ! COMMENTOUT ! else if ( s_eqi ( command, 'COMMENTOUT' ) ) then commentout = .not. commentout showme = 'COMMENTOUT' ! ! CUT= ! else if ( s_eqi ( command, 'CUT' ) .or. & s_eqi ( command(1:4), 'CUT=' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:4), 'CUT=' ) ) then cut = command(5:) else write ( *, '(a)' ) 'Enter the CUT string:' read ( *, '(a)', iostat = ios ) cut if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'CUT' ! ! DEFAULTS ! else if ( s_eqi ( command(1:3), 'DEF' ) ) then call init ( back, chunk, combeg, comend, commentout, cut, iblank, icap, & icapf, icapfc, icolumn, icomment, icon, input, ireph, irepv, join, keep, & keep_max, keep_min, kill, lang, left, lwrap, margel, marger, & mmax, mreci, mreco, nchunk, number, output, page, pause, dorot13, shocon ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'All options set to default values.' showme = 'NONE' ! ! GO ! else if ( s_eqi ( command(1:2), 'GO' ) ) then call stripit ( back, chunk, combeg, comend, commentout, cut, iblank, & icap, icapf, icapfc, icolumn, icomment, icon, input, ireph, irepv, join, & keep, keep_max, keep_min, kill, lang, left, lunit1, lunit2, lwrap, & margel, marger, mreci, mreco, nchunk, number, output, page, pause, & dorot13, shocon ) showme = 'NONE' ! ! HELP ! else if ( s_eqi ( command(1:1), 'H' ) ) then call help showme = 'NONE' ! ! IBLANK command ! else if ( s_eqi ( command(1:6), 'IBLANK' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:7), 'IBLANK=' ) ) then read ( command(8:), *, iostat = ios ) iblank if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter IBLANK = 0, 1 or 2:' read ( *, *, iostat = ios ) iblank if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'IBLANK' ! ! ICAP= ! else if ( s_eqi ( command(1:4), 'ICAP' ) .and. & .not. s_eqi ( command(1:5), 'ICAPF' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:5), 'ICAP=' ) ) then read ( command(6:), *, iostat = ios ) icap if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter ICAP option:' write ( *, '(a)' ) '-1: Lowercase each character;' write ( *, '(a)' ) ' 0: Leave alone;' write ( *, '(a)' ) '+1: Uppercase each character;' write ( *, '(a)' ) '+2: Uppercase each word;' write ( *, '(a)' ) '+3: Uppercase each line.' read ( *, *, iostat = ios ) icap if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'ICAP' ! ! ICAPF= ! else if ( s_eqi ( command(1:5), 'ICAPF' ) .and. & .not. s_eqi ( command(1:6), 'ICAPFC' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:6), 'ICAPF=' ) ) then read ( command(7:), *, iostat = ios ) icapf if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter ICAPF option for ' // trim ( lang ) & // ' statements:' write ( *, '(a)' ) '-1: Lowercase each character;' write ( *, '(a)' ) ' 0: Leave alone;' write ( *, '(a)' ) '+1: Uppercase each character;' write ( *, '(a)' ) '+2: Uppercase each word.' write ( *, '(a)' ) '+3: Uppercase each line.' read ( *, *, iostat = ios ) icapf if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'ICAPF' ! ! ICAPFC= ! else if ( s_eqi ( command(1:6), 'ICAPFC' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:7), 'ICAPFC=' ) ) then read ( command(8:), *, iostat = ios ) icapfc if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter ICAPFC option for ' // trim ( lang ) & // ' comments:' write ( *, '(a)' ) '-1: Lowercase each character;' write ( *, '(a)' ) ' 0: Leave alone;' write ( *, '(a)' ) '+1: Uppercase each character;' write ( *, '(a)' ) '+2: Uppercase each word.' write ( *, '(a)' ) '+3: Uppercase each line.' read ( *, *, iostat = ios ) icapfc if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'ICAPFC' ! ! ICOLUMN = ! else if ( s_eqi ( command(1:7), 'ICOLUMN' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:8), 'ICOLUMN=' ) ) then read ( command(9:), *, iostat = ios ) icolumn if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter column value, or 0:' read ( *, *, iostat = ios ) icolumn if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'ICOLUMN' ! ! ICOMMENT = (0 no action, 1 delete comments, 2 delete noncomments) ! else if ( s_eqi ( command(1:8), 'ICOMMENT' ) ) then if ( s_eqi ( command(1:9), 'ICOMMENT = ' ) ) then read ( command(10:), *, iostat = ios ) icomment if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter ICOMMENT = 0/1/2:' read ( *, *, iostat = ios ) icomment if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'ICOMMENT' ! ! ICON= ! else if ( s_eqi ( command(1:4), 'ICON' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:5), 'ICON=' ) ) then read ( command(6:), *, iostat = ios ) icon if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Enter control character option ICON:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) '-1: Symbols become control characters.' write ( *, '(a)' ) ' 0: Control characters will be preserved.' write ( *, '(a)' ) ' 1: Control characters become symbols.' write ( *, '(a)' ) ' 2: Control characters replaced by blanks.' write ( *, '(a)' ) ' 3: Control characters removed.' read ( *, *, iostat = ios ) icon if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'ICON' ! ! INPUT = filename ! or ! < filename ! else if ( s_eqi ( command(1:5), 'INPUT' ) .or. command(1:1) == '<' ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:6), 'INPUT=' ) ) then input = command(7:) else if ( command(1:1) == '<' ) then input = command(2:) else write ( *, '(a)' ) 'Enter the name of the input file:' read ( *, '(a)', iostat = ios ) input if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'INPUT' if ( input /= '*' ) then inquire ( file = input, exist = lexist ) if ( .not. lexist ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' The input file does not exist!' showme = 'NONE' end if end if ! ! IREPH= ! else if ( s_eqi ( command(1:5), 'IREPH' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:6), 'IREPH=' ) ) then read ( command(7:), *, iostat = ios ) ireph if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter horizontal line repeat factor.' read ( *, *, iostat = ios ) ireph if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'IREPH' ! ! IREPV= ! else if ( s_eqi ( command(1:5), 'IREPV' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:6), 'IREPV=' ) ) then read ( command(7:), *, iostat = ios ) irepv if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter vertical line repeat factor.' read ( *, *, iostat = ios ) irepv if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'IREPV' ! ! JOIN command ! else if ( s_eqi ( command, 'JOIN' ) ) then join = +1 showme = 'join' ! ! KEEP= ! else if ( s_eqi ( command, 'KEEP' ) .or. & s_eqi ( command(1:5), 'KEEP=' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:5), 'KEEP=' ) ) then keep = command(6:) else write ( *, '(a)' ) 'Enter the KEEP string:' write ( *, '(a)' ) ' (Use "<" or ">" to specify the string must' write ( *, '(a)' ) ' begin in the first column, or end in the last.)' write ( *, '(a)' ) ' (Use ANY_ALPHA to keep lines with any' write ( *, '(a)' ) ' alphabetic characters)' read ( *, '(a)', iostat = ios ) keep if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'KEEP' ! ! KEEP_MAX= ! else if ( s_eqi ( command(1:8), 'KEEP_MAX' ) ) then call s_blank_delete ( command ) if ( command(9:9) == '=' ) then read ( command(10:), *, iostat = ios ) keep_max if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter the maximum KEEP length:' read ( *, *, iostat = ios ) keep_max if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'KEEP_MAX' ! ! KEEP_MIN= ! else if ( s_eqi ( command(1:8), 'KEEP_MIN' ) ) then call s_blank_delete ( command ) if ( command(9:9) == '=' ) then read ( command(10:), *, iostat = ios ) keep_min if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter the minimum KEEP length:' read ( *, *, iostat = ios ) keep_min if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'KEEP_MIN' ! ! KILL= ! else if ( s_eqi ( command(1:4), 'KILL' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:5), 'KILL=' ) ) then kill = command(6:) else write ( *, '(a)' ) 'Enter the KILL string:' write ( *, '(a)' ) ' (Use "<" to begin in the first column, ' write ( *, '(a)' ) ' or ">" to end in the last.)' read ( *, '(a)', iostat = ios ) kill if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'KILL' ! ! LANG= ! else if ( s_eqi ( command(1:4), 'LANG' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:5), 'LANG=' ) ) then lang = command(6:) else if ( s_eqi ( command(1:9), 'LANGUAGE=' ) ) then lang = command(10:) else write ( *, '(a)' ) 'Enter the language' write ( *, '(a)' ) ' (ADA/C/C++/F77/F90/TEXT/UNIX):' read ( *, '(a)', iostat = ios ) lang if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'LANG' if ( s_eqi ( lang, 'ADA' ) ) then combeg = '--' comend = ' ' else if ( s_eqi ( lang, 'C' ) ) then combeg = '/*' comend = '*/' else if ( s_eqi ( lang, 'C++' ) ) then combeg = '//' comend = ' ' else if ( s_eqi ( lang, 'F77' ) ) then combeg = '!' comend = ' ' else if ( s_eqi ( lang, 'F90' ) ) then combeg = '!' comend = ' ' else if ( s_eqi ( lang, 'TEXT' ) ) then combeg = ' ' comend = ' ' else if ( s_eqi ( lang, 'UNIX' ) ) then combeg = '#' comend = ' ' end if ! ! LEFT ! else if ( s_eqi ( command, 'LEFT' ) ) then left = .not. left showme = 'LEFT' ! ! LWRAP= ! else if ( s_eqi ( command(1:5), 'LWRAP' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:6), 'LWRAP=' ) ) then read ( command(7:), *, iostat = ios ) lwrap if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter line wrapping length' read ( *, *, iostat = ios ) lwrap if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'LWRAP' ! ! MARGEL = ! else if ( s_eqi ( command(1:6), 'MARGEL' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:7), 'MARGEL=' ) ) then read ( command(8:), *, iostat = ios ) margel if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter left margin:' read ( *, *, iostat = ios ) margel if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'MARGEL' ! ! MARGER = ! else if ( s_eqi ( command(1:6), 'MARGER' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:7), 'MARGER=' ) ) then read ( command(8:), *, iostat = ios ) marger if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter right margin:' read ( *, *, iostat = ios ) marger if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if if ( marger > mmax ) then write ( *, '(a)' ) 'STRIPPER - Error!' write ( *, '(a,i6)' ) ' The maximum column cannot be greater than', mmax marger = mmax end if showme = 'MARGER' ! ! MRECI = ! else if ( s_eqi ( command(1:5), 'MRECI' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:6), 'MRECI=' ) ) then read ( command(7:), *, iostat = ios ) mreci if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter maximum number of input records' read ( *, *, iostat = ios ) mreci if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'MRECI' ! ! MRECO = ! else if ( s_eqi ( command(1:5), 'MRECO' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:6), 'MRECO=' ) ) then read ( command(7:), *, iostat = ios ) mreco if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter maximum number of output records' read ( *, *, iostat = ios ) mreco if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'MRECO' ! ! NCHUNK= ! else if ( s_eqi ( command(1:6), 'NCHUNK' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:7), 'NCHUNK=' ) ) then read ( command(8:), *, iostat = ios ) nchunk if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter number of characters to read.' read ( *, *, iostat = ios ) nchunk if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if if ( nchunk < 1 ) then nchunk = 80 write ( *, '(a)' ) 'NCHUNK cannot be less than 1!' end if showme = 'NCHUNK' ! ! NUMBER command ! else if ( s_eqi ( command(1:6), 'NUMBER' ) ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:7), 'NUMBER=' ) ) then read ( command(8:), *, iostat = ios ) number if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if else write ( *, '(a)' ) 'Enter number option, -1, 0, +1:' read ( *, *, iostat = ios ) number if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'NUMBER' ! ! OUTPUT = filename ! or ! > filename ! else if ( s_eqi ( command(1:6), 'OUTPUT' ) .or. command(1:1) == '>' ) then call s_blank_delete ( command ) if ( s_eqi ( command(1:7), 'OUTPUT=' ) ) then output = command(8:) else if ( command(1:1) == '>' ) then output = command(2:) else write ( *, '(a)' ) 'Enter the name of the output file:' read ( *, '(a)', iostat = ios ) output if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end if showme = 'OUTPUT' ! ! PAGE command ! else if ( s_eqi ( command, 'PAGE' ) ) then page = .not. page showme = 'PAGE' ! ! PAUSE command ! else if ( s_eqi ( command, 'PAUSE' ) ) then pause = .not. pause showme = 'PAUSE' ! ! QUIT command ! else if ( s_eqi ( command(1:2), 'QY' ) .or. & s_eqi ( command, 'EXIT' ) .or. & s_eqi ( command, 'QUIT' ) .or. & s_eqi ( command, 'STOP' ) ) then showme = 'none' exit else if ( s_eqi ( command(1:1), 'Q' ) ) then showme = 'NONE' write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Enter "Y" to confirm you want to stop.' read ( *, '(a)', iostat = ios ) command if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if if ( s_eqi ( command(1:1), 'Y' ) ) then exit end if ! ! ROT13 ! else if ( s_eqi ( command, 'ROT13' ) ) then dorot13 = .not. dorot13 showme = 'ROT13' ! ! SHOCON ! else if ( s_eqi ( command, 'SHOCON' ) ) then shocon = .not. shocon showme = 'SHOCON' ! ! SHOW command ! else if ( s_eqi ( command, 'SHOW' ) ) then showme = 'ALL' ! ! Unrecognized command. ! else showme = 'NONE' write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Warning!' write ( *, '(a)' ) ' Unrecognized command: ' // trim ( command ) end if ! ! Show results of current command. ! call show ( back, chunk, combeg, comend, commentout, cut, iblank, icap, & icapf, icapfc, icolumn, icomment, icon, input, ireph, irepv, join, keep, & kill, lang, left, lwrap, margel, marger, mmax, mreci, mreco, & nchunk, number, output, page, pause, dorot13, shocon, showme ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Enter command (H for help)' read ( *, '(a)', iostat = ios ) command if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER - Fatal error!' write ( *, '(a)' ) ' Error reading user input.' stop end if end do ! ! Terminate. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPPER:' write ( *, '(a)' ) ' Normal end of execution.' write ( *, '(a)' ) ' ' call timestamp ( ) stop end subroutine ch_cap ( c ) !*****************************************************************************80 ! !! ch_cap() capitalizes a single character. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character C, the character to capitalize. ! implicit none character c integer itemp itemp = ichar ( c ) if ( 97 <= itemp .and. itemp <= 122 ) then c = char ( itemp - 32 ) end if return end function ch_is_alpha ( c ) !*****************************************************************************80 ! !! ch_is_alpha() returns TRUE if C is an alphabetic character. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, a character to check. ! ! Output, logical CH_IS_ALPHA is TRUE if C is an alphabetic character. ! implicit none character c logical ch_is_alpha if ( ( lle ( 'a', c ) .and. lle ( c, 'z' ) ) .or. & ( lle ( 'A', c ) .and. lle ( c, 'Z' ) ) ) then ch_is_alpha = .true. else ch_is_alpha = .false. end if return end function ch_is_control ( c ) !*****************************************************************************80 ! !! ch_is_control() reports whether a character is a control character or not. ! ! Discussion: ! ! A "control character" has ASCII code <= 31 or ASCII code => 127. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the character to be tested. ! ! Output, logical CH_IS_CONTROL, TRUE if C is a control character, and ! FALSE otherwise. ! implicit none character c logical ch_is_control if ( ichar ( c ) <= 31 .or. ichar ( c ) >= 127 ) then ch_is_control = .true. else ch_is_control = .false. end if return end subroutine ch_low ( c ) !*****************************************************************************80 ! !! ch_low() lowercases a single character. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character C, the character to be lowercased. ! implicit none character c integer itemp itemp = ichar ( c ) if ( 65 <= itemp .and. itemp <= 90 ) then c = char ( itemp + 32 ) end if return end function ch_to_rot13 ( c ) !*****************************************************************************80 ! !! ch_to_rot13() converts a character to its ROT13 equivalent. ! ! Discussion: ! ! Two applications of CH_TO_ROT13 to a character will return the original. ! ! Example: ! ! Input: Output: ! ! a n ! C P ! J W ! 5 5 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the character to be converted. ! ! Output, character CH_TO_ROT13, the ROT13 equivalent of the character. ! implicit none character c character ch_to_rot13 integer itemp itemp = ichar ( c ) if ( itemp >= 65 .and. itemp <= 77 ) then itemp = itemp + 13 else if ( itemp >= 78 .and. itemp <= 90 ) then itemp = itemp - 13 else if ( itemp >= 97 .and. itemp <= 109 ) then itemp = itemp + 13 else if ( itemp >= 110 .and. itemp <= 122 ) then itemp = itemp - 13 end if ch_to_rot13 = char ( itemp ) return end subroutine ch_to_sym ( c, sym ) !*****************************************************************************80 ! !! ch_to_sym() returns a printable symbol for any ASCII character. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the character to be represented. ! ! Output, character ( len = 4 ) SYM, is the printable symbol for CHR. ! implicit none character c integer i integer iput character ( len = 4 ) sym i = ichar ( c ) sym = ' ' iput = 0 ! ! Characters 128-255 are symbolized with a ! prefix. ! Then shift them down by 128. ! Now all values of I are between 0 and 127. ! if ( i >= 128 ) then i = mod ( i, 128 ) iput = iput + 1 sym(iput:iput) = '!' end if ! ! Characters 0-31 are symbolized with a ^ prefix. ! Shift them up by 64. Now all values of I are between 32 and 127. ! if ( i <= 31 ) then i = i + 64 iput = iput + 1 sym(iput:iput) = '^' end if ! ! Characters 32 through 126 are themselves. ! if ( i <= 126 ) then iput = iput + 1 sym(iput:iput) = char ( i ) ! ! Character 127 is DEL. ! else iput = iput + 1 sym(iput:iput+2) = 'DEL' end if return end subroutine chra_to_s ( s1, s2 ) !*****************************************************************************80 ! !! chra_to_s() replaces control characters by printable symbols. ! ! Table: ! ! ICHAR(c) Symbol ! -------- ------ ! 0 ^@ ! 1 ^A ! ... ... ! 31 ^_ ! 32 (space) ! ... ... ! 126 ~ ! 127 DEL ! 128 !^@ ! ... ... ! 159 !^_ ! 160 !(space) ! ... ... ! 254 !~ ! 255 !DEL ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, the string to be operated on. ! ! Output, character ( len = * ) S2, a copy of S1, except that each ! control character has been replaced by a symbol. ! implicit none logical ch_is_control integer iget integer iput integer lsym integer nchar1 character ( len = * ) s1 character ( len = * ) s2 character ( len = 4 ) sym nchar1 = len_trim ( s1 ) s2 = ' ' iput = 1 do iget = 1, nchar1 if ( ch_is_control ( s1(iget:iget) ) ) then call ch_to_sym ( s1(iget:iget), sym ) lsym = len_trim ( sym ) s2(iput:iput+lsym-1) = sym(1:lsym) iput = iput + lsym else s2(iput:iput) = s1(iget:iget) iput = iput + 1 end if end do return end subroutine chrdt6 ( line ) !*****************************************************************************80 ! !! chrdt6() replaces TAB characters by 6 spaces. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) LINE, the line to be modified. On ! output, some significant characters at the end of LINE may have ! been lost. ! implicit none integer i integer iget integer iput integer lenc integer lens character ( len = * ) line integer ntab character, parameter :: TAB = char(9) ! ! If no TAB's occur in the line, there is nothing to do. ! if ( index ( line, TAB ) == 0 ) then return end if ! ! Otherwise, find out how long the line is. ! lenc = len_trim ( line ) lens = len ( line ) ! ! Count the number of TAB's in the line. ! ntab = 0 do i = 1, lenc if ( line(i:i) == TAB ) then ntab = ntab + 1 end if end do ! ! Now copy the line onto itself, going backwards. ! As soon as we've processed the first TAB, we're done. ! iput = lenc + 5 * ntab do iget = lenc, 1, - 1 if ( line(iget:iget) /= TAB ) then if ( iput <= lens ) then line(iput:iput) = line(iget:iget) end if iput = iput - 1 else do i = iput, iput - 5, -1 if ( i <= lens ) then line(i:i) = ' ' end if end do iput = iput - 6 ntab = ntab - 1 if ( ntab == 0 ) then return end if end if end do return end subroutine chrs_to_a ( s1, s2 ) !*****************************************************************************80 ! !! chrs_to_a() replaces all control symbols by control characters. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 August 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1 is the string to be operated on. ! ! Output, character ( len = * ) S2 is a copy of S1, except that each ! control symbol has been replaced by a control character. ! implicit none character c integer ihi integer ilo integer iput integer nchar1 integer nchar2 character ( len = * ) s1 character ( len = * ) s2 nchar1 = len_trim ( s1 ) nchar2 = len ( s2 ) ihi = 0 iput = 0 do if ( ihi >= nchar1 ) then return end if ilo = ihi + 1 call sym_to_ch ( s1, c(ilo:), ihi ) iput = iput + 1 if ( iput > nchar2 ) then exit end if s2(iput:iput) = c end do return end subroutine doml ( line, margel, marger ) !*****************************************************************************80 ! !! doml() handles the left margin of the line of text. ! ! Discussion: ! ! DOML takes the current line of text, and "resets" it ! so that the MARGEL-th character becomes the first character. ! ! MARGEL may be positive, or nonpositive. Nonpositive values ! result in left-padding by blanks. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) LINE, the line to be reset. ! ! Input, integer MARGEL, MARGER, the left and right "margins". ! In effect, the string LINE(MARGEL:MARGER) will overwrite the ! string LINE. MARGEL may be zero or negative, in which case ! a certain number of blank characters will be generated. ! implicit none character ( len = * ) line character ( len = 256 ) line2 integer margel integer marger ! ! Blank out everything to the right of the upper bound. ! if ( marger > 0 ) then line(marger+1:) = ' ' end if ! ! Either delete characters in positions 1 through MARGEL-1, or ! insert characters in positions 1..1-MARGEL. ! if ( margel > 1 ) then line2 = line(margel:) line = line2 else if ( margel < 1 ) then line2(1:1-margel) = ' ' line2(2-margel:) = line line = line2 end if return end subroutine get_unit ( iunit ) !*****************************************************************************80 ! !! get_unit() returns a free FORTRAN unit number. ! ! Discussion: ! ! A "free" FORTRAN unit number is an integer between 1 and 99 which ! is not currently associated with an I/O device. A free FORTRAN unit ! number is needed in order to open a file with the OPEN command. ! ! If IUNIT = 0, then no free FORTRAN unit could be found, although ! all 99 units were checked (except for units 5, 6 and 9, which ! are commonly reserved for console I/O). ! ! Otherwise, IUNIT is an integer between 1 and 99, representing a ! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 ! are special, and will never return those values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 September 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer IUNIT, the free unit number. ! implicit none integer i integer ios integer iunit logical lopen iunit = 0 do i = 1, 99 if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then inquire ( unit = i, opened = lopen, iostat = ios ) if ( ios == 0 ) then if ( .not. lopen ) then iunit = i return end if end if end if end do return end subroutine getinp ( chunk, ierror, input, line, lunit1, mreci, nchunk, nreci ) !*****************************************************************************80 ! !! getinp() reads the next chunk of input from the input file. ! ! Discussion: ! ! Depending on the user's request, it reads ! * a line, ! * a given number of characters, ! * a word, or ! * a FORTRAN name. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) CHUNK, specifies how input is to be read. ! 'FNAME', means return the next FORTRAN token on each call; ! 'LINE', means return a line on each call; ! 'LINEP', means read NCHUNK characters, if possible. ! 'WORD', means return the next blank-separated word on each call; ! 'RETURN', means that the text of LINE should be 'returned' to the ! input file, until called for later. ! ! Output, integer IERROR, records whether an error occurred. ! ! Input, character ( len = * ) INPUT, the name of the input file, or '*' ! if input comes directly from a user terminal. ! ! Output, character ( len = * ) LINE, the next chunk of input. ! ! Input, integer LUNIT1, is the FORTRAN unit number of the file ! from which input is read, unless the input file is '*'. ! ! Input, integer MRECI, is the maximum number of input records ! that may be read. ! ! Input/output integer NRECI, is the current number of input records ! read. ! implicit none integer, parameter :: mmax = 5000 character ( len = 6 ) chunk character ( len = 20 ) error integer ierror integer ihi integer ilo integer, save :: indx = 0 character ( len = 80 ) input integer iread integer lenmy logical s_eqi character ( len = * ) line integer lunit1 integer mreci character ( len = mmax ), save :: myline = ' ' integer nchunk integer nreci integer nuread ierror = 0 ! ! If CHUNK = 'RETURN', then the user is returning some input that ! was not needed at this time, but which should be stored for ! later requests. ! if ( s_eqi ( chunk, 'RETURN' ) ) then ! ! Read a word or FORTRAN name at a time. ! else if ( s_eqi ( chunk, 'FNAME' ) .or. s_eqi ( chunk, 'WORD' ) ) then if ( indx == 0 ) then if ( nreci >= mreci ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GETINP - Warning!' write ( *, '(a)' ) ' Maximum number of input records reached.' write ( *, '(a)' ) ' (Use MRECI = to increase this limit.)' ierror = 1 return end if call getlin ( 'READ', error, input, myline, lunit1, nreci ) if ( error /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GETINP - Warning!' write ( *, '(a)' ) ' GETLIN reported an error of type' write ( *, '(3x,a)' ) trim ( error ) write ( *, '(a)' ) ' while trying to read a line.' ierror = 1 return end if indx = 1 end if 10 continue if ( s_eqi ( chunk, 'WORD' ) ) then call word_index ( myline, indx, ilo, ihi ) else if ( s_eqi ( chunk, 'FNAME' ) ) then call token_ndx ( myline, indx, ilo, ihi ) end if if ( ilo == 0 ) then if ( nreci >= mreci ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GETINP - Warning!' write ( *, '(a)' ) ' Maximum number of input records reached.' write ( *, '(a)' ) ' (Use MRECI = to increase this limit.)' ierror = 1 return end if call getlin ( 'READ', error, input, myline, lunit1, nreci ) if ( error /= ' ' ) then ierror = 1 return end if indx = 1 go to 10 else indx = indx + 1 line = myline(ilo:ihi) end if ! ! Read one line of input. ! else if ( s_eqi ( chunk, 'LINE' ) ) then if ( nreci >= mreci ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GETINP - Warning!' write ( *, '(a)' ) ' Maximum number of input records reached.' write ( *, '(a)' ) ' (Use MRECI = to increase this limit.)' ierror = 1 return end if call getlin ( 'READ', error, input, line, lunit1, nreci ) if ( error /= ' ' ) then ierror = 1 return end if ! ! "Packed line": read NREAD characters from input. ! else if ( s_eqi ( chunk, 'LINEP' ) ) then if ( nreci >= mreci ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GETINP - Warning!' write ( *, '(a)' ) ' Maximum number of input records reached.' write ( *, '(a)' ) ' (Use MRECI = to increase this limit.)' ierror = 1 return end if iread = 0 line = ' ' 20 continue call getlin ( 'READ', error, input, myline, lunit1, nreci ) ! ! Suppress an error return if we read some information successfully. ! if ( error /= ' ' ) then if ( iread > 0 ) then ierror = 0 else ierror = 1 end if return end if lenmy = len_trim ( myline ) if ( lenmy > 0 ) then nuread = min ( lenmy, nchunk - iread ) line(iread+1:iread+nuread) = myline(1:nuread) iread = iread + nuread ! ! Put remainder of line, if any, back into input. ! if ( nuread < lenmy ) then myline = myline(nuread+1: ) call getlin ( 'UNREAD', error, input, myline, lunit1, nreci ) end if end if if ( iread < nchunk ) then go to 20 end if else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GETINP - Fatal error!' write ( *, '(a)' ) ' Illegal value of CHUNK = ' // trim ( chunk ) write ( *, '(a)' ) ' Legal values: ' write ( *, '(a)' ) ' FNAME, LINE, LINEP, RETURN, WORD.' stop end if return end subroutine getlin ( action, error, input, line, lunit, nrec ) !*****************************************************************************80 ! !! getlin() reads (or "unreads") lines from a file. ! ! Discussion: ! ! It can also be asked to flush its buffer. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) ACTION, tells what GETLIN is being asked ! to do: ! 'FLUSH', means discard any current lines in the buffer; ! 'READ', means return a line, reading from the file if necessary; ! 'UNREAD', means a line is being returned to the buffer. ! ! Output, character ( len = * ) ERROR, tells if an error occurred: ! ' ', no error. ! 'End-of-File' means that no more input could be read. ! 'Read-error' means an "ERR=" error occurred during a read. ! ! Input, character ( len = * ) INPUT, is the name of the input file, or ! '*' if input is being read from the user terminal. ! ! Input/output, character ( len = * ) LINE. ! ! If ACTION is 'UNREAD', then LINE is an input quantity, and is the ! line to be returned to the buffer. ! ! If ACTION is 'READ', then LINE is an output quantity, and is the ! line of input read from the file. ! ! If ACTION is 'FLUSH', then LINE is unused. ! ! Input, integer LUNIT, the logical unit from which input is ! to be read. ! ! Input/output, integer NREC, is the actual number of successful ! FORTRAN READ statements carried out. The user is responsible for ! initializing this quantity. GETLIN simply increments it when a READ ! is carried out. ! implicit none integer, parameter :: MAXLIN = 10 integer, parameter :: MMAX = 5000 character ( len = * ) action character ( len = * ) error integer i character ( len = * ) input integer ios character ( len = * ) line character ( len = MMAX ) lines(MAXLIN) integer lunit integer, save :: nline = 0 integer nrec character ( len = MMAX ) nuline logical s_eqi error = ' ' if ( s_eqi ( action, 'FLUSH' ) ) then nline = 0 else if ( s_eqi ( action, 'READ' ) ) then if ( nline <= 0 ) then if ( input == '*' ) then read ( *, '(a)', iostat = ios ) nuline if ( ios /= 0 ) then error = 'End-of-File' return end if if ( nuline(1:1) == '.' ) then error = 'End-of-File' return end if else read ( lunit, '(a)', iostat = ios ) nuline if ( ios /= 0 ) then error = 'End-of-File' return end if end if nrec = nrec + 1 nline = 1 lines(nline) = nuline end if line = lines(nline) nline = nline-1 else if ( s_eqi ( action, 'UNREAD' ) ) then if ( nline >= MAXLIN ) then do i = 1, MAXLIN-1 lines(i) = lines(i+nline+1-MAXLIN) end do nline = MAXLIN - 1 end if nline = nline + 1 lines(nline) = line else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GETLIN - Error!' write ( *, '(a)' ) ' The input argument ACTION is unrecognized:' write ( *, '(2x,a)' ) trim ( action ) stop end if return end subroutine hello !*****************************************************************************80 ! !! hello() prints out the program's name and last date of revision. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 October 2002 ! ! Author: ! ! John Burkardt ! implicit none write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' CUT command chops off lines after a string.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' # lines accepted as C/C++/F77/F90 comments.' write ( *, '(a)' ) ' F77/F90 lines now automatically de-TABbed.' write ( *, '(a)' ) ' Added "<" and ">" options.' write ( *, '(a)' ) ' Corrected ICAP/ICAPF/ICAPFC confusion.' write ( *, '(a)' ) ' Implemented F77/F90 join.' write ( *, '(a)' ) ' Added CHUNK = LINEP option.' write ( *, '(a)' ) ' HELP output pauses after a screenful.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' F77/F90 comment lines begin with "!"' write ( *, '(a)' ) ' and are corrected automatically.' write ( *, '(a)' ) ' "D" now accepted as F77/F90 comment character.' write ( *, '(a)' ) ' Set LWRAP to MMAX ( = 5000).' write ( *, '(a)' ) ' Backslash replaced by CHAR(92).' write ( *, '(a)' ) ' Started implementing "breaks";' write ( *, '(a)' ) ' (just a "wrap" right now");' write ( *, '(a)' ) ' Input is now "buffered" can be "unread";' write ( *, '(a)' ) ' STRIPIT can join UNIX lines;' write ( *, '(a)' ) ' CHRPAD changed, to fix MARGEL/MARGER problems.' return end subroutine help !*****************************************************************************80 ! !! help() prints out the command options. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 August 1999 ! ! Author: ! ! John Burkardt ! implicit none write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'HELP - Note:' write ( *, '(a)' ) ' Legal commands to STRIPPER:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Back Remove character+BACKSPACE sequences;' write ( *, '(a)' ) 'Break Break long lines;' write ( *, '(a)' ) ' (ADA/C/C++/F77/F90/TEXT/UNIX not tested.)' write ( *, '(a)' ) 'Chunk = FNAME, LINE, LINEP, or WORD;' write ( *, '(a)' ) 'COMBEG = Set comment begin characters;' write ( *, '(a)' ) 'COMEND = Set comment end characters;' write ( *, '(a)' ) 'CommentOut Comment out the text;' write ( *, '(a)' ) 'CUT = Cut off lines after given string.' write ( *, '(a)' ) 'Defaults Restore defaults;' write ( *, '(a)' ) 'Go Carry out the stripping;' write ( *, '(a)' ) 'Help Print this information;' write ( *, '(a)' ) 'IBlank = Remove 0 no, 1 all, or 2 multi blank lines;' write ( *, '(a)' ) 'ICap = -1 lower, +1 upper, +2 first upper text;' write ( *, '(a)' ) & 'ICapF = -1 lower, +1 upper, +2 first upper language text;' read ( *, * ) write ( *, '(a)' ) & 'ICapFC = -1 lower, +1 upper, +2 first upper language comments;' write ( *, '(a)' ) 'IColumn = Read column ICOLUMN of a table;' write ( *, '(a)' ) 'IComment = 0 do nothing, 1 = delete comments, ' write ( *, '(a)' ) ' 2 = delete noncomments;' write ( *, '(a)' ) 'ICon = -1: Symbol-->control, 0: preserve ' write ( *, '(a)' ) ' 1: Control-->symbol, 2: blanks 3: nothing;' write ( *, '(a)' ) 'Input = Specify input file, * = screen;' write ( *, '(a)' ) '< filename Specify input file, * for screen;' write ( *, '(a)' ) 'IRepH = Horizontal line repeats;' write ( *, '(a)' ) 'IRepV = Vertical line repeats;' write ( *, '(a)' ) 'Join = Join ADA/C/C++/F77/F90/TEXT/UNIX lines;' write ( *, '(a)' ) ' (ADA/C/C++/TEXT not implemented).' write ( *, '(a)' ) 'Keep = Define keep string;' write ( *, '(a)' ) ' (Use "<" or ">" to force the string to' write ( *, '(a)' ) ' start in column 1, or end in the last.)' write ( *, '(a)' ) 'Keep_Max = Maximum length of keeper lines.' write ( *, '(a)' ) 'Keep_Min = Minimum length of keeper lines.' write ( *, '(a)' ) 'Kill = Define kill string;' write ( *, '(a)' ) ' (Use "<" or ">" to force the string to' write ( *, '(a)' ) ' start in column 1, or end in the last.)' write ( *, '(a)' ) 'Lang = Set language (ADA/C/C++/F77/F90/TEXT/UNIX);' write ( *, '(a)' ) 'Left Output file will be left justified;' read ( *, * ) write ( *, '(a)' ) 'LWrap = Set line wrapping margin;' write ( *, '(a)' ) 'MargeL = Set left margin of input;' write ( *, '(a)' ) 'MargeR = Set right margin of output;' write ( *, '(a)' ) 'MRecI = Maximum number of input records;' write ( *, '(a)' ) 'MRecO = Maximum number of output records;' write ( *, '(a)' ) 'Number = -1 delete, 0 preserve, +1 add line numbers;' write ( *, '(a)' ) 'Output = Specify the output file, * = screen;' write ( *, '(a)' ) '> filename Specify output file, * for screen;' write ( *, '(a)' ) 'Page Remove form feeds (new page controls);' write ( *, '(a)' ) 'Pause Pause when printing output to screen;' write ( *, '(a)' ) 'Quit Stop the program;' write ( *, '(a)' ) 'ROT13 Encode/decode the output.' write ( *, '(a)' ) 'ShoCon Show control characters;' write ( *, '(a)' ) 'Show Show current settings.' return end subroutine init ( back, chunk, combeg, comend, commentout, cut, iblank, & icap, icapf, icapfc, icolumn, icomment, icon, input, ireph, irepv, join, & keep, keep_max, keep_min, kill, lang, left, lwrap, margel, marger, mmax, & mreci, mreco, nchunk, number, output, page, pause, dorot13, shocon ) !*****************************************************************************80 ! !! init() sets or restores the default values of the user options. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, logical BACK, is TRUE if character+BACKSPACE combinations ! are to be removed. ! implicit none logical back character ( len = 6 ) chunk character ( len = 2 ) combeg character ( len = 2 ) comend logical commentout character ( len = 40 ) cut integer iblank integer icap integer icapf integer icapfc integer icolumn integer icomment integer icon character ( len = 80 ) input integer ireph integer irepv integer join character ( len = 40 ) keep integer keep_max integer keep_min character ( len = 40 ) kill character ( len = 10 ) lang logical left integer lwrap integer margel integer marger integer mmax integer mreci integer mreco integer nchunk integer number character ( len = 80 ) output logical page logical pause logical dorot13 logical shocon back = .false. chunk = 'LINE' combeg = '!' comend = ' ' commentout = .false. cut = ' ' iblank = 0 icap = 0 icapf = 0 icapfc = 0 icolumn = 0 icomment = 0 icon = 0 input = ' ' ireph = 1 irepv = 1 join = 0 keep = ' ' keep_max = mmax keep_min = 0 kill = ' ' lang = 'TEXT' left = .FALSE. lwrap = mmax margel = 1 marger = mmax mreci = 1000000 mreco = 1000000 nchunk = 80 number = 0 output = ' ' page = .false. pause = .false. dorot13 = .false. shocon = .false. return end function lalpha ( string ) !*****************************************************************************80 ! !! lalpha() returns .TRUE. if STRING contains only alphabetic characters. ! ! Discussion: ! ! Alphabetic characters are 'A' through 'Z' and 'a' through 'z' and ! blanks. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) STRING, the string to be checked. ! ! Output, logical LALPHA, .TRUE. if STRING contains only ! alphabetic characters and blanks, .FALSE. otherwise. ! implicit none character chrtmp integer i integer itemp logical lalpha integer lenc character ( len = * ) string lenc = len ( string ) lalpha = .false. do i = 1, lenc chrtmp = string(i:i) itemp = ichar ( string(i:i) ) if ( chrtmp /= ' ' ) then if ( .not. ( itemp >= 65 .and. itemp <= 90 ) ) then if ( .not. ( itemp >= 97 .and. itemp <= 122 ) ) then return end if end if end if end do lalpha = .true. return end function ldigit ( string ) !*****************************************************************************80 ! !! ldigit() returns .TRUE. if STRING contains only digits or blanks. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) STRING, the string to be checked. ! ! Output, logical LDIGIT, .TRUE. if STRING contains only digits and ! blanks, .FALSE. otherwise. ! implicit none character chrtmp integer i logical ldigit integer lenc character ( len = * ) string lenc = len ( string ) ldigit = .false. do i = 1, lenc chrtmp = string(i:i) if ( chrtmp /= ' ' ) then if ( llt ( chrtmp, '0' ) .or. lgt ( chrtmp, '9' ) ) then return end if end if end do ldigit = .true. return end subroutine line_get ( chunk, ierror, input, join, lang, line, lunit1, lwrap, & mreci, nchunk, nreci ) !*****************************************************************************80 ! !! line_get() gets the next input line. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! implicit none integer, parameter :: mmax = 5000 character ( len = 6 ) chunk character ( len = 20 ) error integer ierror character ( len = 80 ) input integer join character ( len = 10 ) lang integer lenl character ( len = * ) line character ( len = mmax ) line2 integer lunit1 integer lwrap integer mreci integer nchunk integer nreci character s_c_last logical s_eqi ierror = 0 ! ! Get the next input line (or word). ! call getinp ( chunk, ierror, input, line, lunit1, mreci, nchunk, nreci ) if ( ierror /= 0 ) then return end if ! ! If the JOIN option is enabled (join = +1), then ... ! (We have to say "CHAR(92)" rather than "\" because idiotic UNIX ! compilers will otherwise take "\" literally. ! if ( join == 1 ) then if ( s_eqi ( lang, 'ADA' ) ) then else if ( s_eqi ( lang, 'C' ) ) then else if ( s_eqi ( lang, 'C++' ) ) then ! ! How do we "look ahead" here? ! else if ( s_eqi ( lang, 'F77' ) ) then if ( line(1:1) /= '!' ) then 91 continue if ( s_c_last ( line ) == '&' ) then lenl = len_trim ( line ) line(lenl:lenl) = ' ' call getinp ( chunk, ierror, input, line2, lunit1, mreci, nchunk, & nreci ) if ( ierror == 0 ) then call s_cat ( line, line2, line ) go to 91 end if end if end if else if ( s_eqi ( lang, 'F90' ) ) then if ( line(1:1) /= '!' ) then do while ( s_c_last ( line ) == '&' ) lenl = len_trim ( line ) line(lenl:lenl) = ' ' call getinp ( chunk, ierror, input, line2, lunit1, mreci, nchunk, & nreci ) if ( ierror /= 0 ) then exit end if call s_cat ( line, line2, line ) end do end if ! ! TEXT logic. ! ! Have a current buffer < max. ! Have a current new line. ! ! If length of current buffer + new line <= max, ! add line to buffer, ! get another line. ! ! If length of current buffer + new line up to some word <= max, ! add partial line to buffer, print partial line, come again. ! ! If length of current buffer + new line word(1) > max, then ! if ( current buffer > 0 ) ! print buffer and come again ! else ! add line up to max -1, add a continuing dash, ! print buffer, come again. ! else if ( s_eqi ( lang, 'TEXT' ) ) then else if ( s_eqi ( lang, 'UNIX' ) ) then if ( line(1:1) /= '#' ) then 21 continue if ( s_c_last ( line ) == char(92) ) then lenl = len_trim ( line ) line(lenl:lenl) = ' ' call getinp ( chunk, ierror, input, line2, lunit1, mreci, & nchunk, nreci ) if ( ierror == 0 ) then call s_cat ( line, line2, line ) go to 21 end if end if end if end if ! ! ...else if the BREAK operation is enabled (JOIN = -1) then ! else if ( join == -1 ) then if ( s_eqi ( chunk, 'LINE' ) ) then lenl = len_trim ( line ) if ( lenl > lwrap ) then if ( s_eqi ( lang, 'ADA' ) ) then call getlin ( 'UNREAD', error, input, line(lwrap+1:lenl), & lunit1, nreci ) if ( error /= ' ') then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LINE_GET - Warning!' write ( *, '(a)' ) ' GETLIN reported an error of type:' write ( *, '(2x,a)' ) error write ( *, '(a)' ) ' trying to "UNREAD" a long line.' end if line = line(1:lwrap) else if ( s_eqi ( lang, 'C' ) ) then call getlin ( 'UNREAD', error, input, line(lwrap+1:lenl), & lunit1, nreci ) if ( error /= ' ') then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LINE_GET - Warning!' write ( *, '(a)' ) ' GETLIN reported an error of type:' write ( *, '(3x,a)' ) error write ( *, '(a)' ) ' trying to "UNREAD" a long line.' end if line = line(1:lwrap) else if ( s_eqi ( lang, 'C++') ) then else if ( s_eqi ( lang, 'F77' ) ) then call getlin ( 'UNREAD', error, input, line(lwrap+1:lenl), & lunit1, nreci ) if ( error /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LINE_GET - Warning!' write ( *, '(a)' ) ' GETLIN reported an error of type:' write ( *, '(2x,a)' ) error write ( *, '(a)' ) ' trying to "UNREAD" a long line.' end if line = line(1:lwrap) else if ( s_eqi ( lang, 'F90' ) ) then call getlin ( 'UNREAD', error, input, line(lwrap+1:lenl), & lunit1, nreci ) if ( error /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LINE_GET - Warning!' write ( *, '(a)' ) ' GETLIN reported an error of type:' write ( *, '(3x,a)' ) error write ( *, '(a)' ) ' trying to "UNREAD" a long line.' end if line = line(1:lwrap) else if ( s_eqi ( lang, 'TEXT' ) ) then call getlin ( 'UNREAD', error, input, line(lwrap+1:lenl), & lunit1, nreci ) if ( error /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LINE_GET - Warning!' write ( *, '(a)' ) ' GETLIN reported an error of type:' write ( *, '(3x,a)' ) error write ( *, '(a)' ) ' trying to "UNREAD" a long line.' end if line = line(1:lwrap) else if ( s_eqi ( lang, 'UNIX' ) ) then call getlin ( 'UNREAD', error, input, line(lwrap+1:lenl), & lunit1, nreci ) if ( error /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LINE_GET - Warning!' write ( *, '(a)' ) ' GETLIN reported an error of type:' write ( *, '(3x,a)' ) error write ( *, '(a)' ) ' trying to "UNREAD" a long line.' end if line = line(1:lwrap) end if end if end if end if return end subroutine line_put ( ierror, ireph, irepv, isay, line, lunit2, lwrap, mreco, & nreco, output, pause ) !*****************************************************************************80 ! !! line_put() writes the line to the output file. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer IERROR, error flag. ! 0, no error occurred. ! nonzero, an error occurred. ! ! Input, integer IREPH, the number of horizontal repetitions ! of each line. ! ! Input, integer IREPV, the number of vertical repetitions ! of each line. ! ! ???, integer ISAY, ??? ! ! Input, character ( len = * ) LINE, ??? ! ! Input, integer LUNIT2, the output unit. ! ! Input, integer LWRAP, the "wrapping length". ! ! Input/output, integer MRECO, ??? ! ! Input/output, integer NRECO, ??? ! ! Input, character ( len = * ) OUTPUT, the output file name, or '*' if output ! is directly to the screen. ! ! Input, logical PAUSE, is .TRUE. if output to the screen is to ! pause. ! implicit none integer, parameter :: mmax = 5000 integer i integer ierror integer ihi integer ilo integer ios integer ireph integer irepv character isay integer jrepeat integer lenl character ( len = mmax ) line integer lunit2 integer lwrap integer mreco integer nreco character ( len = 80 ) output logical pause ierror = 0 lenl = len_trim ( line ) ! ! IREPH: Repeat the line, horizontally. ! Logically, this operation comes AFTER most others! ! if ( ireph > 1 ) then ihi = min ( ireph * lenl, mmax ) do i = lenl+1, ihi line(i:i) = line(i-lenl:i-lenl) end do lenl = ihi end if ! ! IREPV: Repeat the line vertically. ! Logically, this operation comes AFTER most others! ! if ( output == '*' ) then if ( isay == '?' .and. pause ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'When the output pauses, press RETURN' write ( *, '(a)' ) 'to continue, or any other character to quit.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Press RETURN now.' write ( *, '(a)' ) ' ' read ( *, '(a)', iostat = ios ) isay if ( ios /= 0 ) then ierror = 1 return end if if ( isay /= ' ' ) then ierror = 1 return end if end if do jrepeat = 1, irepv ihi = max ( lenl, 1 ) do ilo = 1, max ( lenl, 1 ), lwrap ihi = min ( ilo+lwrap-1, lenl ) if ( ihi >= ilo ) then write ( *, '(a)' ) line(ilo:ihi) else write ( *, '(a)' ) ' ' end if nreco = nreco + 1 if ( nreco >= mreco ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LINE_PUT - Warning!' write ( *, '(a)' ) ' Maximum number of output lines reached.' write ( *, '(a)' ) ' (Use MRECO = to increase this limit.)' return end if end do end do if ( pause .and. mod ( nreco, 20 ) == 19 ) then read ( *, '(a)', iostat = ios ) isay if ( ios /= 0 ) then ierror = 1 return end if if ( isay .ne. ' ' ) then ierror = 1 return end if end if else do jrepeat = 1, irepv do ilo = 1, max ( lenl, 1 ), lwrap ihi = min ( lenl, ilo+lwrap-1 ) if ( ihi >= ilo ) then write ( lunit2, '(a)' ) line(ilo:ihi) else write ( lunit2, '(a)' ) end if nreco = nreco + 1 if ( nreco >= mreco ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LINE_PUT: Warning!' write ( *, '(a)' ) ' Maximum number of output lines reached.' return end if end do end do end if return end function numcon ( line ) !*****************************************************************************80 ! !! numcon() counts the number of control characters in a line of text. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 August 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) LINE, the string of characters to be examined. ! ! Output, integer NUMCON is the number of control characters ! in LINE. ! implicit none character c logical ch_is_control integer i integer lchar character ( len = * ) line integer numcon numcon = 0 lchar = len_trim ( line ) do i = 1, lchar c = line(i:i) if ( ch_is_control ( c ) ) then numcon = numcon + 1 end if end do return end subroutine rubout ( s ) !*****************************************************************************80 ! !! rubout() deletes the pair "character" + BACKSPACE from a string. ! ! Discussion: ! ! RUBOUT will also remove a backspace if it is the first character ! on the line. RUBOUT is recursive. In other words, given the ! string of 8 characters: ! 'ABCD###E' ! where we are using "#" to represent a backspace, RUBOUT will ! return the string 'AE'. ! ! RUBOUT was written for use in "cleaning up" UNICOS MAN pages. ! The raw text of these MAN pages is unreadable for two reasons: ! ! Passages which are to be underlined are written so: ! "_#T_#e_#x_#t" when what is meant is that "Text" is to be ! underlined if possible. Note that the seemingly equivalent ! "T#_e#_x#_t#_" is NOT used. This is because, in the olden ! days, certain screen terminals could backspace, but would only ! display the new character, obliterating rather than ! overwriting the old one. This convention allows us to know ! that we want to delete "character" + Backspace, rather than ! Backspace + "character". ! ! Passages which are meant to be in BOLDFACE are written so: ! "U#U#U#Ug#g#g#gl#l#l#ly#y#y#y", when what is meant is that ! "Ugly" is to be printed as boldly as possible. These boldface ! passages may also be cleaned up using the same rule of ! removing all occurrences of "character" + Backspace. ! ! It is truly a fright to look at the text of one of these MAN ! pages with all the ugly Backspace's, which display on VMS as ^H. ! These files print or type properly, but look awful in an editor. ! Moreoever, the lavish use of boldface means that text that is ! meant to fit in 80 columns can sometimes require 7 times as much ! space to describe. This can cause a VMS editor to abort, or to ! skip the line, since 255 characters is the maximum for EDT. ! ! A FORTRAN program that tries to read a long line like that will ! also fail if not careful, since a formatted sequential file ! on VMS has a default maximum record length of something like ! 133 characters. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S. On input, the line of ! text to be cleaned. On output, any leading backspace ! character has been deleted, and all pairs of ! "character"+Backspace have been deleted. ! implicit none character, parameter :: BS = char ( 8 ) integer i integer nchar character ( len = * ) s nchar = len_trim ( s ) i = 1 do while ( i <= nchar ) if ( s(i:i) == BS ) then if ( i == 1 ) then call s_chop ( s, i, i ) nchar = nchar - 1 i = i - 1 else call s_chop ( s, i-1, i ) nchar = nchar - 2 i = i - 2 end if end if i = i + 1 end do return end subroutine s_blank_delete ( s ) !*****************************************************************************80 ! !! s_blank_delete() removes blanks from a string, left justifying the remainder. ! ! Discussion: ! ! All TAB characters are also removed. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none character c integer iget integer iput character ( len = * ) s character ( len = 1 ), parameter :: TAB = char ( 9 ) iput = 0 do iget = 1, len ( s ) c = s(iget:iget) if ( c /= ' ' .and. c /= TAB ) then iput = iput + 1 s(iput:iput) = c end if end do s(iput+1:) = ' ' return end function s_c_last ( s ) !*****************************************************************************80 ! !! s_c_last() returns the last nonblank character in a string. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be examined. ! ! Output, character S_C_LAST, the last nonblank character in S, ! or ' ' if S is all blank. ! implicit none integer lenc character ( len = * ) s character s_c_last lenc = len_trim ( s ) if ( lenc > 0 ) then s_c_last = s(lenc:lenc) else s_c_last = ' ' end if return end subroutine s_cap ( s ) !*****************************************************************************80 ! !! s_cap() replaces any lowercase letters by uppercase ones in a string. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none character c integer i integer nchar character ( len = * ) s nchar = len_trim ( s ) do i = 1, nchar c = s(i:i) call ch_cap ( c ) s(i:i) = c end do return end subroutine s_cat ( s1, s2, s3 ) !*****************************************************************************80 ! !! s_cat() concatenates two strings to make a third string. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, the "prefix" string. ! ! Input, character ( len = * ) S2, the "postfix" string. ! ! Output, character ( len = * ) S3, the string made by ! concatenating S1 and S2, ignoring any trailing blanks. ! implicit none character ( len = * ) s1 character ( len = * ) s2 character ( len = * ) s3 s3 = trim ( s1 ) // trim ( s2 ) return end subroutine s_chop ( s, ilo, ihi ) !*****************************************************************************80 ! !! s_chop() "chops out" a portion of a string, and closes up the hole. ! ! Example: ! ! S = 'Fred is not a jerk!' ! ! call s_chop ( S, 9, 12 ) ! ! S = 'Fred is a jerk! ' ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! ! Input, integer ILO, IHI, the locations of the first and last ! characters to be removed. ! implicit none integer ihi integer ihi2 integer ilo integer ilo2 integer lens character ( len = * ) s lens = len ( s ) ilo2 = max ( ilo, 1 ) ihi2 = min ( ihi, lens ) if ( ilo2 > ihi2 ) then return end if s(ilo2:lens+ilo2-ihi2-1) = s(ihi2+1:lens) s(lens+ilo2-ihi2:lens) = ' ' return end function s_contains_any_alpha ( s ) !*****************************************************************************80 ! !! s_contains_any_alpha() is TRUE if the string contains any alphabetic character. ! ! Example: ! ! Input Output ! ! Riding Hood TRUE ! 123 + 34 FALSE ! Seven Eleven TRUE ! 1.0E+11 TRUE ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string to be checked. ! ! Output, logical S_CONTAINS_ANY_ALPHA is TRUE if any character in string ! is an alphabetic character. ! implicit none logical ch_is_alpha integer i integer lens logical s_contains_any_alpha character ( len = * ) s lens = len ( s ) s_contains_any_alpha = .true. do i = 1, lens if ( ch_is_alpha ( s(i:i) ) ) then return end if end do s_contains_any_alpha = .false. return end subroutine s_control_blank ( s ) !*****************************************************************************80 ! !! s_control_blank() replaces control characters with blanks. ! ! Discussion: ! ! A "control character" has ASCII code <= 31 or ASCII code => 127. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none logical ch_is_control integer i character ( len = * ) s do i = 1, len ( s ) if ( ch_is_control ( s(i:i) ) ) then s(i:i) = ' ' end if end do return end subroutine s_control_delete ( s ) !*****************************************************************************80 ! !! s_control_delete() removes all control characters from a string. ! ! Discussion: ! ! The string is collapsed to the left, and padded on the right with ! blanks to replace the removed characters. ! ! A "control character" has ASCII code <= 31 or 127 <= ASCII code. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, is the string to be transformed. ! implicit none logical ch_is_control integer iget integer iput character ( len = * ) s iput = 0 do iget = 1, len ( s ) if ( .not. ch_is_control ( s(iget:iget) ) ) then iput = iput + 1 s(iput:iput) = s(iget:iget) end if end do ! ! Pad the end of the string with blanks ! s(iput+1:) = ' ' return end function s_eqi ( strng1, strng2 ) !*****************************************************************************80 ! !! s_eqi() is a case insensitive comparison of two strings for equality. ! ! Example: ! ! S_EQI ( 'Anjana', 'ANJANA' ) is .TRUE. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) STRNG1, STRNG2, the strings to compare. ! ! Output, logical S_EQI, the result of the comparison. ! implicit none integer i integer len1 integer len2 integer lenc logical s_eqi character s1 character s2 character ( len = * ) strng1 character ( len = * ) strng2 len1 = len ( strng1 ) len2 = len ( strng2 ) lenc = min ( len1, len2 ) s_eqi = .false. do i = 1, lenc s1 = strng1(i:i) s2 = strng2(i:i) call ch_cap ( s1 ) call ch_cap ( s2 ) if ( s1 /= s2 ) then return end if end do do i = lenc + 1, len1 if ( strng1(i:i) /= ' ' ) then return end if end do do i = lenc + 1, len2 if ( strng2(i:i) /= ' ' ) then return end if end do s_eqi = .true. return end function s_indexi ( s, sub ) !*****************************************************************************80 ! !! s_indexi() is a case-insensitive INDEX function. ! ! Discussion: ! ! The function returns the location in the string at which the ! substring SUB is first found, or 0 if the substring does not ! occur at all. ! ! The routine is also trailing blank insensitive. This is very ! important for those cases where you have stored information in ! larger variables. If S is of length 80, and SUB is of ! length 80, then if S = 'FRED' and SUB = 'RED', a match would ! not be reported by the standard FORTRAN INDEX, because it treats ! both variables as being 80 characters long! This routine assumes that ! trailing blanks represent garbage! ! ! Because of the suppression of trailing blanks, this routine cannot be ! used to find, say, the first occurrence of the two-character ! string 'A '. However, this routine treats as a special case the ! occurrence where S or SUB is entirely blank. Thus you can ! use this routine to search for occurrences of double or triple blanks ! in a string, for example, although INDEX itself would be just as ! suitable for that problem. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be searched. ! ! Input, character ( len = * ) SUB, the substring to search for. ! ! Output, integer S_INDEXI. 0 if SUB does not occur in ! the string. Otherwise S(S_INDEXI:S_INDEXI+LENS-1) = SUB, ! where LENS is the length of SUB, and is the first place ! this happens. However, note that this routine ignores case, ! unlike the standard FORTRAN INDEX function. ! implicit none integer i integer llen1 integer llen2 character ( len = * ) s logical s_eqi integer s_indexi character ( len = * ) sub s_indexi = 0 llen1 = len_trim ( s ) llen2 = len_trim ( sub ) ! ! In case S or SUB is blanks, use LEN. ! if ( llen1 == 0 ) then llen1 = len ( s ) end if if ( llen2 == 0 ) then llen2 = len ( sub ) end if if ( llen2 > llen1 ) then return end if do i = 1, llen1 + 1 - llen2 if ( s_eqi ( s(i:i+llen2-1), sub ) ) then s_indexi = i return end if end do return end subroutine s_low ( string ) !*****************************************************************************80 ! !! s_low() replaces all uppercase letters by lowercase ones. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) STRING, the string to be ! transformed. On output, the string is all lowercase. ! implicit none integer i integer nchar character ( len = * ) string nchar = len ( string ) do i = 1, nchar call ch_low ( string(i:i) ) end do return end function s_only_alphab ( s ) !*****************************************************************************80 ! !! s_only_alphab() checks if a string is only alphabetic and blanks. ! ! Discussion: ! ! Acceptable characters are 'A' through 'Z' and 'a' through 'z' and blanks. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be checked. ! ! Output, logical S_ONLY_ALPHAB, .TRUE. if the string contains only ! alphabetic characters and blanks, .FALSE. otherwise. ! implicit none character c integer i integer itemp character ( len = * ) s logical s_only_alphab s_only_alphab = .false. do i = 1, len ( s ) c = s(i:i) if ( c /= ' ' ) then itemp = ichar ( c ) if ( .not. ( itemp >= 65 .and. itemp <= 90 ) ) then if ( .not. ( itemp >= 97 .and. itemp <= 122 ) ) then return end if end if end if end do s_only_alphab = .true. return end function s_only_digitb ( s ) !*****************************************************************************80 ! !! s_only_digitb() returns .TRUE. if the string contains only digits or blanks. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be checked. ! ! Output, logical S_ONLY_DIGITB, .TRUE. if the string contains only digits ! and blanks, .FALSE. otherwise. ! implicit none character c integer i character ( len = * ) s logical s_only_digitb s_only_digitb = .false. do i = 1, len ( s ) c = s(i:i) if ( c /= ' ' ) then if ( llt ( c, '0' ) .or. lgt ( c, '9' ) ) then return end if end if end do s_only_digitb = .true. return end subroutine s_to_rot13 ( s ) !*****************************************************************************80 ! !! s_to_rot13() "rotates" the alphabetical characters in a string by 13 positions. ! ! Discussion: ! ! Two applications of the routine will return the original string. ! ! Example: ! ! Input: Output: ! ! abcdefghijklmnopqrstuvwxyz nopqrstuvwxyzabcdefghijklm ! Cher Pure ! James Thurston Howell Wnzrf Guhefgba Ubjryy ! 12345 12345 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, a string to be "rotated". ! implicit none character ch_to_rot13 integer i integer lens character ( len = * ) s lens = len_trim ( s ) do i = 1, lens s(i:i) = ch_to_rot13 ( s(i:i) ) end do return end subroutine show ( back, chunk, combeg, comend, commentout, cut, iblank, & icap, icapf, icapfc, icolumn, icomment, icon, input, ireph, irepv, join, & keep, kill, lang, left, lwrap, margel, marger, mmax, mreci, mreco, nchunk, & number, output, page, pause, dorot13, shocon, showme ) !*****************************************************************************80 ! !! show() displays the values of the user variables. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 October 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, logical BACK, is TRUE if character+BACKSPACE combinations ! are to be removed. ! ! Input, character ( len = 40 ) CUT, is nonblank if lines containing ! this string are to be cut at that string. ! implicit none logical back character ( len = 6 ) chunk character ( len = 2 ) combeg character ( len = 2 ) comend logical commentout character ( len = 40 ) cut integer iblank integer icap integer icapf integer icapfc integer icolumn integer icomment integer icon character ( len = 80 ) input integer ireph integer irepv integer join character ( len = 40 ) keep character ( len = 40 ) kill character ( len = 10 ) lang integer lchar logical left logical s_eqi integer lwrap integer margel integer marger integer mmax integer mreci integer mreco integer nchunk integer number character ( len = 80 ) output logical page logical pause logical dorot13 logical shocon character ( len = 10 ) showme if ( s_eqi ( showme, 'NONE' ) ) then return end if ! ! BACK ! if ( s_eqi ( showme, 'ALL' ) .or. s_eqi ( showme, 'BACK' ) ) then if ( back ) then write ( *, '(a)' ) ' All character+BACKSPACE sequences will be deleted.' else write ( *, '(a)' ) ' Character+BACKSPACE sequences will NOT be deleted.' end if end if ! ! BREAK ! if ( s_eqi ( showme, 'ALL' ) .or. s_eqi ( showme, 'BREAK' ) ) then if ( join == -1 ) then write ( *, '(a)' ) ' Long ' // trim ( lang ) // ' lines will be broken.' else write ( *, '(a)' ) ' Long ' // trim ( lang ) // & ' lines will NOT be broken.' end if end if ! ! CHUNK / NCHUNK ! if ( s_eqi ( showme, 'ALL' ) .or. s_eqi ( showme, 'CHUNK' ) .or. & s_eqi ( showme, 'NCHUNK' ) ) then write ( *, '(a)' ) ' Text is digested in chunks of ' // trim ( chunk ) write ( *, '(a,i6,a)' ) ' The chunk size is NCHUNK = ', nchunk, & ' characters.' end if ! ! COMBEG ! if ( s_eqi ( showme, 'ALL' ) .or. s_eqi ( showme, 'COMBEG' ) ) then lchar = len_trim ( combeg ) if ( lchar > 0 ) then write ( *, '(a)' ) ' Comments will begin with "' // combeg(1:lchar) & // '".' end if end if ! ! COMEND ! if ( s_eqi ( showme, 'ALL' ) .or. s_eqi ( showme, 'COMEND' ) ) then lchar = len_trim ( comend ) if ( lchar > 0 ) then write ( *, '(a)' ) ' Comments will end with "' // comend(1:lchar) & // '".' end if end if ! ! COMMENTOUT ! if ( s_eqi ( showme, 'ALL' ) .or. s_eqi ( showme, 'COMMENTOUT' ) ) then if ( commentout ) then write ( *, '(a)' ) ' Text will commented out.' else write ( *, '(a)' ) ' Text will NOT be commented out.' end if end if ! ! CUT ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'CUT' ) ) then write ( *, '(a)' ) ' The cut string is "' // trim ( cut ) // '".' end if ! ! IBLANK ! if ( s_eqi ( showme, 'ALL' ) .or. s_eqi ( showme, 'IBLANK' ) ) then if ( iblank == 1 ) then write ( *, '(a)' ) ' All blank lines will be removed.' else if ( iblank == 2 ) then write ( *, '(a)' ) ' Double blank lines will be removed.' else write ( *, '(a)' ) ' Blank lines will NOT be removed.' end if end if ! ! ICAP ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'icap') ) then if ( icap == -1 ) then write ( *, '(a)' ) ' Lowercase text characters.' else if ( icap == 0 ) then write ( *, '(a)' ) ' No case changes made to text.' else if ( icap == 1 ) then write ( *, '(a)' ) ' Capitalize text characters.' else if ( icap == 2 ) then write ( *, '(a)' ) ' Initial capitalize every word.' else if ( icap == 3 ) then write ( *, '(a)' ) ' Initial capitalize every line.' end if end if ! ! ICAPF ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'ICAPF') ) then if ( icapf == -1 ) then write ( *, '(a)' ) ' Lowercase '// trim ( lang ) // ' characters.' else if ( icapf == 0 ) then write ( *, '(a)' ) ' No case changes will be made for ' // & trim ( lang ) // '.' else if ( icapf == 1 ) then write ( *, '(a)' ) ' Capitalize '// trim ( lang ) //' characters.' else if ( icapf == 2 ) then write ( *, '(a)' ) ' Initial capitalize '// trim ( lang ) // ' words.' else if ( icapf == 3 ) then write ( *, '(a)' ) ' Initial capitalize '// trim ( lang ) // ' lines.' end if end if ! ! ICAPFC ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'icapfc') ) then if ( icapfc == -1 ) then write ( *, '(a)' ) ' Lowercase '// trim ( lang ) // ' comments.' else if ( icapfc == 0 ) then write ( *, '(a)' ) ' No case changes will be made for ' & // trim ( lang ) // ' comments.' else if ( icapfc == 1 ) then write ( *, '(a)' ) ' Capitalize '// trim ( lang ) // ' comments.' else if ( icapfc == 2 ) then write ( *, '(a)' ) & ' Initial capitalize '// trim ( lang ) // ' comment words.' else if ( icapfc == 3 ) then write ( *, '(a)' ) ' Initial capitalize ' // trim ( lang ) // & ' comment lines.' end if end if ! ! ICOLUMN ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'icolumn') ) then if ( icolumn == 0 ) then write ( *, '(a)' ) ' No special column of the input is chosen.' else write ( *, '(a,i6,a)' ) ' User picks column ', icolumn, ' from table.' end if end if ! ! ICON ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'ICON') ) then if ( icon == -1 ) then write ( *, '(a)' ) ' Symbols become control characters.' else if ( icon == 0 ) then write ( *, '(a)' ) ' Control characters will be preserved.' else if ( icon == 1 ) then write ( *, '(a)' ) ' Control characters become symbols.' else if ( icon == 2 ) then write ( *, '(a)' ) ' Control characters replaced by blanks.' else if ( icon == 3 ) then write ( *, '(a)' ) ' Control characters will be removed.' end if end if ! ! ICOMMENT ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'ICOMMENT') ) then if ( icomment == 0 ) then write ( *, '(a)' ) & ' No special delete/save of ' // trim ( lang ) //' comments.' else if ( icomment == 1 ) then write ( *, '(a)' ) ' All '// trim ( lang ) //' comments will be removed.' else write ( *, '(a)' ) & ' ALL '// trim ( lang ) //' NONcomments will be removed.' end if end if ! ! INPUT ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'INPUT') ) then if ( len_trim ( input ) > 0 ) then if ( input == '*' ) then write ( *, '(a)' ) ' The input file is the screen.' write ( *, '(a)' ) ' Terminate input with a period in column 1.' else write ( *, '(a)' ) ' The input file is "'// trim ( input ) // '".' end if end if end if ! ! IREPH ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'IREPH') ) then if ( ireph > 1 ) then write ( *, '(a,i6,a)' ) & ' Each line is repeated ', ireph, ' times horizontally.' else write ( *, '(a)' ) ' Each line is NOT repeated horizontally.' end if end if ! ! IREPV ! if ( s_eqi ( showme, 'ALL' ) .or. s_eqi ( showme, 'IREPV' ) ) then if ( irepv > 1 ) then write ( *, '(a,i6,a)' ) & ' Each line will is repeated ', irepv, ' times vertically.' else write ( *, '(a)' ) ' Each line is NOT repeated vertically.' end if end if ! ! JOIN ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'JOIN' ) ) then if ( join == 1 ) then write ( *, '(a)' ) ' Broken ' // trim ( lang ) // & ' lines will be joined.' else write ( *, '(a)') & ' Broken ' // trim ( lang ) // ' lines will NOT be joined.' end if end if ! ! KEEP ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'KEEP' ) ) then write ( *, '(a)' ) ' The keep string is "' // trim ( keep ) // '".' end if ! ! KILL ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'KILL' ) ) then write ( *, '(a)' ) ' The kill string is "' // trim ( kill ) // '".' end if ! ! LANG ! if ( s_eqi ( showme, 'ALL' ) .or. s_eqi ( showme, 'lang' ) ) then write ( *, '(a)' ) ' The text format is '// trim ( lang ) end if ! ! LEFT ! if ( s_eqi ( showme, 'ALL' ) .or. s_eqi ( showme, 'left' ) ) then if ( left ) then write ( *, '(a)' ) ' Output will be left justified.' else write ( *, '(a)' ) ' Output will NOT be left justified.' end if end if ! ! LWRAP ! if ( s_eqi ( showme, 'ALL' ) .or. s_eqi ( showme, 'lwrap' ) ) then write ( *, '(a,i6,a)' ) ' Lines will wrap after ', lwrap, ' characters.' end if ! ! MARGEL ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'margel') ) then write ( *, '(a,i6)' ) ' First column read will be ', margel end if ! ! MARGER ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'marger') ) then write ( *, '(a,i6)' ) ' Last column read will be ', marger end if ! ! MMAX ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'MMAX') ) then write ( *, '(a,i6,a)' ) ' Maximum input line length = ', mmax, & ' characters.' end if ! ! MRECI ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'MRECI') ) then write ( *, '(a,i12)' ) ' Maximum number of input records is ', mreci end if ! ! MRECO ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'MRECO') ) then write ( *, '(a,i12)' ) ' Maximum number of output records is ', mreco end if ! ! NUMBER command ! if ( s_eqi ( showme, 'ALL' ) .or. s_eqi ( showme, 'NUMBER' ) ) then if ( number < 0 ) then write ( *, '(a)' ) ' Initial line numbers will be stripped.' else if ( number == 0 ) then write ( *, '(a)' ) ' No special numbering option.' else if ( number > 0 ) then write ( *, '(a)' ) ' Initial line numbers will be inserted.' end if end if ! ! OUTPUT ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'output' ) ) then if ( lchar > 0 ) then if ( output == '*' ) then write ( *, '(a)' ) ' The output file is the screen.' else write ( *, '(a)' ) ' The output file is "' // trim ( output ) // '".' end if end if end if ! ! PAGE ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'PAGE' ) ) then if (page) then write ( *, '(a)' ) ' New Page (FF) controls will be removed.' else write ( *, '(a)' ) ' New Page (FF) controls will NOT be removed.' end if end if ! ! PAUSE ! if ( s_eqi ( showme, 'ALL') .or. s_eqi ( showme, 'PAUSE' ) ) then if (pause) then write ( *, '(a)' ) ' Output to the screen will pause.' else write ( *, '(a)' ) ' Output to the screen will NOT pause.' end if end if ! ! ROT13 ! if ( s_eqi ( showme, 'ALL' ) .or. s_eqi ( showme, 'ROT13' ) ) then if ( dorot13 ) then write ( *, '(a)' ) ' Output will be ROT13 encoded/decoded.' else write ( *, '(a)' ) ' Output will NOT be ROT13 encoded/decoded.' end if end if ! ! SHOCON ! if ( s_eqi ( showme, 'ALL' ) .or. s_eqi ( showme, 'SHOCON' ) ) then if ( shocon ) then write ( *, '(a)' ) ' Control characters will be identified.' else write ( *, '(a)' ) ' Control characters will NOT be identified.' end if end if return end subroutine stripit ( back, chunk, combeg, comend, commentout, cut, iblank, & icap, icapf, icapfc, icolumn, icomment, icon, input, ireph, irepv, join, & keep, keep_max, keep_min, kill, lang, left, lunit1, lunit2, lwrap, margel, & marger, mreci, mreco, nchunk, number, output, page, pause, dorot13, shocon ) !*****************************************************************************80 ! !! stripit() processes the file. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 October 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, logical BACK, is TRUE if character+BACKSPACE combinations ! are to be removed. ! implicit none integer, parameter :: mmax = 5000 logical back character c logical ch_is_control character ( len = 6 ) chunk character ( len = 2 ) combeg character ( len = 2 ) comend logical comment logical commentout character ( len = 40 ) cut character ffchar integer i integer iblank integer icap integer icapf integer icapfc integer icolumn integer icomment integer icon integer ierror integer ihi integer ilo integer imhere character ( len = 80 ) input integer ios integer ireph integer irepv integer isblnk character isay integer itwo integer join integer jsblnk character ( len = 40 ) keep integer keep_max integer keep_min character ( len = 40 ) kill character ( len = 10 ) lang integer lchar logical ldigit logical left integer lenl logical s_eqi character ( len = mmax ) line character ( len = mmax ) line2 logical lnexcom logical l_temp integer lunit1 integer lunit2 integer lwrap integer margel integer marger integer mleni integer mleno integer mnumi integer mnumo integer mreci integer mreco integer nblank integer nchri integer nchro integer nchunk integer nconi integer ncut integer nff integer nkeep integer nkill integer nreci integer nreco integer number integer numcon character ( len = 80 ) output logical page logical pause logical dorot13 logical shocon logical s_contains_any_alpha integer s_indexi ierror = 0 isay = '?' isblnk = 1 itwo = 1 jsblnk = 1 line2 = ' ' mleni = 0 mleno = 0 mnumi = 0 mnumo = 0 nblank = 0 nchri = 0 nchro = 0 nconi = 0 ncut = 0 nff = 0 nkeep = 0 nkill = 0 nreci = 0 nreco = 0 ! ! The user must have specified an input file name. ! if ( len_trim ( input ) <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPIT: Error!' write ( *, '(a)' ) ' Please specify an input file!' return end if ! ! The user must have specified an output file name. ! if ( len_trim ( output ) <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPIT: Not enough information!' write ( *, '(a)' ) ' Please specify an output file first!' return end if ! ! Open the input file. ! if ( input /= '*' ) then open ( unit = lunit1, file = input, status = 'old', iostat = ios, & form = 'formatted', access = 'sequential' ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPIT - Warning!' write ( *, '(a)' ) ' Error while trying to open the input file:' write ( *, '(a)' ) trim ( input ) return end if end if ! ! Open the output file. ! if ( output /= '*' ) then open ( unit = lunit2, file = output, status = 'new', iostat = ios, & form = 'formatted', access = 'sequential' ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STRIPIT - Warning!' write ( *, '(a)' ) ' Error while trying to open the output file:' write ( *, '(a)' ) trim ( output ) return end if end if ! !******************************************************************************* ! ! READ A LOGICAL LINE. ! !******************************************************************************* ! ! A logical line may be the result of joining several physical lines, ! or dividing a physical input line into smaller pieces. ! do call line_get ( chunk, ierror, input, join, lang, line, lunit1, & lwrap, mreci, nchunk, nreci ) if ( ierror /= 0 ) then exit end if ! !******************************************************************************* ! ! UPDATE INPUT LINE STATISTICS. ! !******************************************************************************* ! lenl = len_trim ( line ) nchri = nchri + lenl if ( lenl > mleni ) then mleni = lenl mnumi = nreci end if nconi = nconi + numcon ( line ) ! !******************************************************************************* ! ! ADJUST THE INPUT LINE. ! !******************************************************************************* ! ! MARGIN: Handle the left and right margins. ! call doml ( line, margel, marger ) ! ! If we're only reading one column, extract column ICOLUMN. ! if ( icolumn > 0 ) then call word_index ( line, icolumn, ilo, ihi ) line = line(ilo:ihi) end if ! ! DETAB the input if it is F77/F90. ! if ( s_eqi ( lang, 'F77' ) .or. s_eqi ( lang, 'F90' ) ) then call chrdt6 ( line ) end if ! !******************************************************************************* ! ! PROCESS THE INPUT LINE. ! !******************************************************************************* ! ! Determine if this line begins, continues, or ends a ! series of comment lines. ! ! Let's pretend there are only two kinds of comments: ! INLINE comments, which trail a statement, and ! MULTILINE comments, comprising one or more full line comments. ! ! In that case, I've handled the MULTILINE case, and can't ! handle the INLINE case yet. ! ! LNEXCOM = ! TRUE: the next line MUST be a comment line. ! FALSE: the next line may be a comment or executable line. ! if ( s_eqi ( lang, 'ADA' ) ) then lnexcom = .false. if ( line(1:2) == '--' ) then comment = .true. else comment = .false. end if else if ( s_eqi ( lang, 'C' ) ) then if ( line(1:2) == '/*' ) then comment = .true. if ( index(line(3:), '*/' ) == 0 ) then lnexcom = .true. else lnexcom = .false. end if else if ( line(1:1) == '#' ) then comment = .true. else if ( lnexcom ) then comment = .true. if ( index ( line, '*/' ) == 0 ) then lnexcom = .true. else lnexcom = .false. end if else comment = .false. end if else if ( s_eqi ( lang, 'C++' ) ) then lnexcom = .false. if ( line(1:2) == '//' ) then comment = .true. else if ( line(1:1) == '#' ) then comment = .true. else comment = .false. end if else if ( s_eqi ( lang, 'F77' ) .or. s_eqi ( lang, 'F90' ) ) then lnexcom = .false. if ( line(1:1) == 'c' .or. line(1:1) == 'C' .or. & line(1:1) == 'd' .or. line(1:1) == 'D' .or. & line(1:1) == '*' .or. line(1:1) == '#' .or. & line(1:1) == '!' ) then comment = .true. line(1:1) = '!' else comment = .false. end if else if ( s_eqi ( lang, 'UNIX' ) ) then lnexcom = .false. if ( line(1:1) == '#' ) then comment = .true. else comment = .false. end if else comment = .false. lnexcom = .false. end if ! ! If KEEP is nonblank, see if LINE contains the token, and either ! save or discard those lines. Sneakily pre- and postpend "<" and ! ">" to allow the specification of first and last columns in a ! token. ! if ( keep /= ' ' ) then if ( s_eqi ( keep, 'ANY_ALPHA' ) ) then l_temp = s_contains_any_alpha ( line ) if ( l_temp ) then nkeep = nkeep + 1 else go to 60 end if else if ( len_trim ( line ) <= 0 ) then go to 60 else line2 = '<' // trim ( line ) // '>' lchar = len_trim ( keep ) imhere = s_indexi ( line2, keep(1:lchar) ) if ( imhere == 0 ) then go to 60 else nkeep = nkeep + 1 end if end if end if end if ! ! Check that the line length is between KEEP_MIN and KEEP_MAX ! lenl = len_trim ( line ) if ( lenl < keep_min .or. lenl > keep_max ) then go to 60 end if ! ! If KILL is nonblank, see if LINE contains the token, and either ! save or discard those lines. Sneakily pre- and postpend "<" and ! ">" to allow the specification of first and last columns in a ! token. ! if ( kill /= ' ' ) then if ( len_trim ( line ) > 0 ) then line2 = '<' // trim ( line ) // '>' imhere = s_indexi ( line2, trim ( kill ) ) if ( imhere /= 0 ) then nkill = nkill + 1 go to 60 end if end if end if ! ! If CUT is nonblank, see if LINE contains the token and cut the line. ! if ( cut /= ' ' ) then if ( len_trim ( line ) <= 0 ) then go to 60 end if lchar = len_trim ( cut ) imhere = s_indexi ( line, cut(1:lchar) ) if ( imhere /= 0 ) then ncut = ncut + 1 if ( imhere == 1 ) then line = ' ' lenl = 0 else line = line(1:imhere-1) lenl = imhere - 1 end if end if end if ! ! BACK: character+BACKSPACE deletion ! if ( back ) then call rubout ( line ) lenl = len_trim ( line ) end if ! ! COMMENTOUT ! if ( commentout ) then lchar = len_trim ( combeg ) if ( len_trim ( combeg ) > 0 ) then line(lchar+3:) = trim ( line ) line(1:lchar) = combeg(1:lchar) line(lchar+1:lchar+2) = ' ' end if lchar = len_trim ( comend ) if ( len_trim ( comend ) > 0 ) then lenl = len_trim ( line ) line(lenl+1:lenl+1) = ' ' line(lenl+2:lenl+lchar+1) = comend(1:lchar) end if end if ! ! If LANG = F77, force the continuation character to be '&'. ! if ( s_eqi ( lang, 'F77' ) ) then if ( .not. comment .and. line(6:6) /= ' ' ) then line(6:6) = '&' end if end if ! ! IBLANK: Handle blank or double blank lines. ! jsblnk = isblnk isblnk = 0 if ( lenl == 0 ) then isblnk = 1 if ( iblank == 1 ) then nblank = nblank + 1 go to 60 else if ( iblank == 2 .and. jsblnk == 1 ) then nblank = nblank + 1 go to 60 end if end if ! ! ICAP ! if ( icap == -1 ) then call s_low ( line ) else if ( icap == 1 ) then call s_cap ( line ) else if ( icap == 2 ) then call word_cap ( line ) else if ( icap == 3 ) then call ch_cap ( line(1:1) ) end if ! ! ICAPF ! if ( s_eqi ( lang, 'ADA' ) .or. & s_eqi ( lang, 'C' ) .or. & s_eqi ( lang, 'C++' ) .or. & s_eqi ( lang, 'F77' ) .or. & s_eqi ( lang, 'F90' ) .or. & s_eqi ( lang, 'UNIX' ) ) then if ( .not. comment ) then if ( icapf == -1 ) then call s_low ( line ) else if ( icapf == 1 ) then call s_cap ( line ) else if ( icapf == 2 ) then call word_cap ( line ) else if ( icapf == 3 ) then call ch_cap ( line(1:1) ) end if end if end if ! ! ICAPFC ! if ( s_eqi ( lang, 'ADA' ) .or. s_eqi ( lang, 'C' ) .or. & s_eqi ( lang, 'C++' ) .or. s_eqi ( lang, 'F77' ) .or. & s_eqi ( lang, 'F90' ) .or. s_eqi ( lang, 'UNIX' ) ) then if ( comment ) then if ( icapfc == -1 ) then call s_low ( line ) else if ( icapf == 1 ) then call s_cap ( line ) else if ( icapf == 2 ) then call word_cap ( line ) else if ( icapf == 3 ) then call ch_cap ( line(1:1) ) end if end if end if ! ! ICON: ! -1 Symbols become controls; ! 0 No action; ! +1 Controls go to symbols; ! +2 Controls go to blanks; ! +3 Controls go to nothing. ! if ( icon == -1 ) then call chrs_to_a ( line, line2 ) line = line2 else if ( icon == 1 ) then call chra_to_s ( line, line2 ) line = line2 else if ( icon == 2 ) then call s_control_blank ( line ) else if ( icon == 3 ) then call s_control_delete ( line ) end if ! ! ICOMMENT: Do nothing, or remove comments or remove noncomments. ! if ( s_eqi ( lang, 'ADA' ) .or. s_eqi ( lang, 'C' ) .or. & s_eqi ( lang, 'C++' ) .or. s_eqi ( lang, 'F77' ) .or. & s_eqi ( lang, 'F90' ) .or. s_eqi ( lang, 'UNIX' ) ) then if ( icomment == 1 ) then if ( comment ) go to 60 else if ( icomment == 2 ) then if ( .not. comment ) go to 60 end if end if ! ! LEFT: Left justify the text. ! if ( left ) then line = adjustl ( line ) lenl = len_trim ( line ) end if ! ! NUMBER: Remove or insert initial digits. ! if ( number < 0 ) then lenl = len_trim ( line ) do i = 1, lenl if ( ldigit ( line(i:i) ) ) then line(i:i) = ' ' else exit end if end do line = adjustl ( line ) lenl = len_trim ( line ) else if ( number > 0 ) then lenl = len_trim ( line ) line(1+5:lenl+5) = line(1:lenl) write ( line(1:4), '(i4)' ) nreci line(5:5) = ' ' end if ! ! PAGE: remove FF (new page) controls. ! if ( page ) then ffchar = char ( 12 ) lenl = len_trim ( line ) do i = 1, lenl if ( line(i:i) == ffchar ) then line(i:i) = ' ' nff = nff + 1 end if end do end if ! ! SHOCON: Identify control characters ! if ( shocon ) then do i = 1, lenl c = line(i:i) if ( ch_is_control ( c ) ) then write ( *, '(a,i6,a,i6,a,i6)' ) & 'Line ', nreci, ' Column = ', i, ' ASCII # = ', ichar ( c ) end if end do end if ! ! Now, just before output, apply ROT13, if requested. ! if ( dorot13 ) then call s_to_rot13 ( line ) end if ! !******************************************************************************* ! ! UPDATE THE OUTPUT LINE STATISTICS. ! !******************************************************************************* ! lenl = len_trim ( line ) lenl = max ( 1, lenl ) ! ! Compute the output statistics. ! nchro = nchro + lenl if ( lenl > mleno ) then mleno = lenl mnumo = nreco + 1 end if ! !******************************************************************************* ! ! WRITE THE OUTPUT LINE. ! !******************************************************************************* ! call line_put ( ierror, ireph, irepv, isay, line, lunit2, & lwrap, mreco, nreco, output, pause ) if ( ierror /= 0 ) then exit end if 60 continue ! ! Print running indicator of number of lines processed so far. ! if ( nreci == itwo ) then if ( output /= '*' ) then if ( itwo == 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Input Output' write ( *, '(a)' ) ' ' end if write ( *, '(2i8)' ) nreci, nreco end if itwo = 2 * itwo end if end do ! !******************************************************************************* ! ! PRINT THE STATISTICS. ! !******************************************************************************* ! if ( nreci /= 2 * itwo ) then if ( output /= '*' ) then write ( *, '(2i8)' ) nreci, nreco end if end if if ( input /= '*' ) then close ( unit = lunit1 ) end if if ( output /= '*' ) then close ( unit = lunit2 ) end if write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Input Output' write ( *, '(a)' ) ' ' write ( *, '(a,i8,2x,i8)' ) ' Lines: ', nreci, nreco write ( *, '(a,i8,2x,i8)' ) ' Characters: ', nchri, nchro write ( *, '(a,i8 )' ) ' Controls: ', nconi write ( *, '(a,i8,2x,i8)' ) ' Longest line: ', mleni, mleno write ( *, '(a,i8,2x,i8)' ) ' (line number:) ', mnumi, mnumo write ( *, '(a)' ) ' ' if ( nff > 0 ) then write ( *, '(a,i6,a)' ) ' Removed ', nff, ' form feeds.' end if if ( iblank /= 0 ) then write ( *, '(a,i6,a)' ) ' Removed ', nblank, ' blank lines.' end if if ( keep /= ' ' ) then write ( *, '(a,i6,a)' ) ' Kept ', nkeep, ' lines with KEEP string.' end if if ( kill /= ' ' ) then write ( *, '(a,i6,a)' ) ' Killed ', nkill, ' lines with KILL string.' end if if ( cut /= ' ' ) then write ( *, '(a,i6,a)' ) ' Cut ', ncut, ' lines with CUT string.' end if return end subroutine sym_to_ch ( sym, c, ihi ) !*****************************************************************************80 ! !! sym_to_ch() returns the character represented by a symbol. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) SYM is a string containing printable symbols. ! ! Output, character C, is the ASCII character represented by the ! first symbol in SYM. ! ! Output, integer IHI, C is represented by SYM(1:IHI). ! IHI = 0 if there was a problem. ! implicit none character c integer ialt integer ichr integer ictl integer ihi integer nchar logical s_eqi character ( len = * ) sym c = ' ' nchar = len_trim ( sym ) if ( nchar <= 0 ) then c = ' ' ihi = 0 return end if ialt = 0 ictl = 0 ihi = 1 ! ! Could it be an ALT character? ! if ( sym(ihi:ihi) == '!' .and. ihi < nchar ) then ialt = 1 ihi = ihi + 1 end if ! ! Could it be a control character? ! if ( sym(ihi:ihi) == '^' .and. ihi < nchar ) then ictl = 1 ihi = ihi + 1 end if ! ! Could it be a DEL character? ! ichr = ichar ( sym(ihi:ihi) ) if ( ihi+2 <= nchar ) then if ( s_eqi ( sym(ihi:ihi+2), 'DEL' ) ) then ichr = 127 ihi = ihi + 2 end if end if ! ! Could it be an SP character? ! if ( ihi + 1 <= nchar ) then if ( s_eqi ( sym(ihi:ihi+1), 'SP' ) ) then ichr = 32 ihi = ihi + 1 end if end if ! ! Interpret the character. ! if ( ialt == 1 ) then ichr = ichr + 128 end if if ( ictl == 1 ) then ichr = ichr - 64 end if c = char ( ichr ) return end subroutine timestamp ( ) !*****************************************************************************80 ! !! timestamp() prints the current YMDHMS date as a time stamp. ! ! Example: ! ! 31 May 2001 9:45:54.872 AM ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 May 2013 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none character ( len = 8 ) ampm integer d integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s integer values(8) integer y call date_and_time ( values = values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end subroutine token_ndx ( string, indx, ilo, ihi ) !*****************************************************************************80 ! !! token_ndx() finds the N-th FORTRAN variable name in a string. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) STRING is the string of words to be analyzed. ! ! Input, integer INDX is the index of the desired token. ! ! Output, integer ILO is the index of the first character of the ! INDX-th token, or 0 if there was no INDX-th token. ! ! Output, integer IHI is the index of the last character of the ! INDX-th token, or 0 if there was no INDX-th token. ! implicit none integer i integer ihi integer ilo integer indx character ( len = * ) string ihi = 0 ilo = 0 do i = 1, indx call token_next ( string, ilo, ihi) if ( ilo == 0 ) then return end if end do return end subroutine token_next ( s, ilo, ihi ) !*****************************************************************************80 ! !! token_next() finds the next FORTRAN variable name in a string. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S is the string of words to be analyzed. ! ! Output, integer ILO is the location of the first character of ! the next word, or 0 if there was no next word. ! ! Input/output, integer IHI. ! On input, IHI is taken to be the LAST character of the ! PREVIOUS word, or 0 if the first word is sought. ! ! On output, IHI is the index of the last character of ! the next word, or 0 if there was no next word. ! implicit none integer ihi integer ilo integer lchar character ( len = * ) s logical s_only_alphab logical s_only_digitb lchar = len_trim ( s ) ilo = ihi if ( ilo < 0 ) then ilo = 0 end if ! ! Find ILO, the index of the next alphabetic character. ! do ilo = ilo + 1 if ( ilo > lchar ) then ilo = 0 ihi = 0 return end if if ( s_only_alphab ( s(ilo:ilo) ) ) then exit end if end do ! ! Find the index of the next character which is neither ! alphabetic nor numeric. ! ihi = ilo do ihi = ihi + 1 if ( ihi > lchar ) then ihi = lchar return end if if ( .not. ( s_only_alphab ( s(ihi:ihi) ) ) .and. & .not. ( s_only_digitb ( s(ihi:ihi) ) ) ) then exit end if end do ihi = ihi - 1 return end subroutine word_cap ( s ) !*****************************************************************************80 ! !! word_cap() capitalizes the first character of each word in a string. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none integer ihi integer ilo character ( len = * ) s ilo = 0 ihi = 0 do call word_next ( s, ilo, ihi ) if ( ilo <= 0 ) then exit end if call ch_cap ( s(ilo:ilo) ) end do return end subroutine word_index ( s, indx, ilo, ihi ) !*****************************************************************************80 ! !! word_index() finds the word of a given index in a string. ! ! Discussion: ! ! The routine returns in ILO and IHI the beginning and end of the INDX-th ! word, or 0 and 0 if there is no INDX-th word. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S is the string of words to be analyzed. ! ! Input, integer INDX is the index of the desired token. ! ! Output, integer ILO is the index of the first character of the ! INDX-th word, or 0 if there was no INDX-th word. ! ! Output, integer IHI is the index of the last character of ! the INDX-th word, or 0 if there was no INDX-th word. ! implicit none integer i integer ihi integer ilo integer indx character ( len = * ) s ihi = 0 ilo = 0 do i = 1, indx call word_next ( s, ilo, ihi ) if ( ilo == 0 ) then return end if end do return end subroutine word_next ( s, ilo, ihi ) !*****************************************************************************80 ! !! word_next() finds the next (blank separated) word in a string. ! ! Discussion: ! ! This routine is usually used repetitively on a fixed string. On each ! call, it accepts IHI, the index of the last character of the ! previous word extracted from the string. ! ! It then computes ILO and IHI, the first and last characters of ! the next word in the string. ! ! It is assumed that words are separated by one or more spaces. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string of words to be analyzed. ! ! Output, integer ILO is the location of the first character of ! the next word, or 0 if there was no next word. ! ! Input/output, integer IHI. ! ! On input, IHI is taken to be the LAST character of the ! PREVIOUS word, or 0 if the first word is sought. ! ! On output, IHI is the index of the last character of ! the next word, or 0 if there was no next word. ! implicit none integer ihi integer ilo integer lchar character ( len = * ) s lchar = len_trim ( s ) ! ! Find ILO, the index of the first nonblank character after ! (the old value of) IHI. ! if ( ihi < 0 ) then ilo = 0 else ilo = ihi end if do ilo = ilo + 1 if ( ilo > lchar ) then ilo = 0 ihi = 0 return end if if ( s(ilo:ilo) /= ' ') then exit end if end do ! ! Find IHI, the index of the next blank character, or end of line. ! ihi = ilo do ihi = ihi + 1 if ( ihi >= lchar ) then ihi = lchar return end if if ( s(ihi:ihi) == ' ' ) then exit end if end do ! ! Decrement IHI to point to the previous, nonblank, character. ! ihi = ihi - 1 return end subroutine word_next2 ( s, first, last ) !*****************************************************************************80 ! !! word_next2() returns the first word in a string. ! ! Discussion: ! ! "Words" are any string of characters, separated by commas or blanks. ! ! The routine returns: ! * FIRST, the first string of nonblank, noncomma characters; ! * LAST, the characters of STRING that occur after FIRST and ! the commas and blanks. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S is the string to be analyzed. ! ! Output, character ( len = * ) FIRST, the next word in the string. ! ! Output, character ( len = * ) LAST, the text of the remaining words in the ! string. ! implicit none character c character ( len = * ) first integer i integer ido integer ifirst integer ilast character ( len = * ) last integer lenf integer lenl integer lens character ( len = * ) s first = ' ' last = ' ' ifirst = 0 ilast = 0 lens = len_trim ( s ) lenf = len ( first ) lenl = len ( last ) ido = 0 do i = 1, lens c = s(i:i) if ( ido == 0 ) then if ( c /= ' ' .and. c /= ',' ) then ido = 1 end if end if if ( ido == 1 ) then if ( c /= ' ' .and. c /= ',' ) then ifirst = ifirst + 1 if ( ifirst <= lenf ) then first(ifirst:ifirst) = c end if else ido = 2 end if end if if ( ido == 2 ) then if ( c /= ' ' .and. c /= ',' ) then ido = 3 end if end if if ( ido == 3 ) then ilast = ilast + 1 if ( ilast <= lenl ) then last(ilast:ilast) = c end if end if end do return end