function a_to_i ( a ) ! !******************************************************************************* ! !! A_TO_I returns the index of an alphabetic character. ! ! ! Examples: ! ! A A_TO_I ! ! 'A' 1 ! 'B' 2 ! ... ! 'Z' 26 ! 'a' 27 ! 'b' 28 ! ... ! 'z' 52 ! '$' 0 ! ! Modified: ! ! 22 February 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character A, a character. ! ! Output, integer A_TO_I, is the alphabetic index of the character, ! between 1 and 26 if the character is a capital letter, ! between 27 and 52 if it is lower case, and 0 otherwise. ! implicit none ! character a integer a_to_i integer, parameter :: cap_shift = 64 integer, parameter :: low_shift = 96 ! if ( lle ( 'A', a ) .and. lle ( a, 'Z' ) ) then a_to_i = ichar ( a ) - cap_shift else if ( lle ( 'a', a ) .and. lle ( a, 'z' ) ) then a_to_i = ichar ( a ) - low_shift + 26 else a_to_i = 0 end if return end subroutine b4_ieee_to_r ( word, r ) ! !******************************************************************************* ! !! B4_IEEE_TO_R converts a 4 byte IEEE word into a real value. ! ! ! Discussion: ! ! This routine does not seem to working reliably for unnormalized data. ! ! The word containing the real value may be interpreted as: ! ! /SEEEEEEE/EFFFFFFF/FFFFFFFF/FFFFFFFF/ ! ! /33222222/22222222/22222100/00000000/ ! /10987654/32109876/54321098/76543210/ <-- Bit numbering ! ! where ! ! S is the sign bit, ! E are the exponent bits, ! F are the mantissa bits. ! ! The mantissa is usually "normalized"; that is, there is an implicit ! leading 1 which is not stored. However, if the exponent is set to ! its minimum value, this is no longer true. ! ! The exponent is "biased". That is, you must subtract a bias value ! from the exponent to get the true value. ! ! If we read the three fields as integers S, E and F, then the ! value of the resulting real number R can be determined by: ! ! * if E = 255 ! if F is nonzero, then R = NaN; ! if F is zero and S is 1, R = -Inf; ! if F is zero and S is 0, R = +Inf; ! * else if E > 0 then R = (-1)**(S) * 2**(E-127) * (1 + (F/2**24)) ! * else if E = 0 ! if F is nonzero, R = (-1)**(S) * 2**(E-126) * (F/2**24) ! if F is zero and S is 1, R = -0; ! if F is zero and S is 0, R = +0; ! ! Reference: ! ! ANSI/IEEE Standard 754-1985, ! Standard for Binary Floating Point Arithmetic. ! ! Modified: ! ! 10 November 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer WORD, the word to be decoded. ! ! Output, real R, the value of the real number. ! implicit none ! integer e integer f real r integer s integer word ! ! Read the fields. ! s = 0 call mvbits ( word, 31, 1, s, 0 ) e = 0 call mvbits ( word, 23, 8, e, 0 ) f = 0 call mvbits ( word, 0, 23, f, 0 ) ! ! Don't bother trying to return NaN or Inf just yet. ! if ( e == 255 ) then r = 0.0E+00 else if ( e > 0 ) then r = ( -1.0E+00 )**s * 2.0E+00**(e-127-23) * real ( 8388608 + f ) else if ( e == 0 ) then r = ( -1.0E+00 )**s * 2.0E+00**(-126-23) * real ( f ) end if return end subroutine b4_ieee_to_sef ( word, s, e, f ) ! !******************************************************************************* ! !! B4_IEEE_TO_SEF converts an IEEE real word to S * 2**E * F format. ! ! ! Modified: ! ! 22 November 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer WORD, a word containing an IEEE real number. ! ! Output, integer S, the sign bit: ! 0, if R is nonnegative; ! 1, if R is negative. ! ! Output, integer E, the exponent base 2. ! ! Output, integer F, the mantissa. ! implicit none ! integer e integer e2 integer f integer s integer word ! s = 0 call mvbits ( word, 31, 1, s, 0 ) e2 = 0 call mvbits ( word, 23, 8, e2, 0 ) if ( e2 == 255 ) then e = 128 call mvbits ( word, 0, 23, f, 0 ) if ( f == 0 ) then f = 0 else f = 2**23 - 1 end if else if ( e2 > 0 ) then e = e2 - 127 - 23 f = 2**23 call mvbits ( word, 0, 23, f, 0 ) do while ( mod ( f, 2 ) == 0 ) f = f / 2 e = e + 1 end do else if ( e2 == 0 ) then e = e2 - 127 - 23 f = 0 call mvbits ( word, 0, 23, f, 0 ) if ( f == 0 ) then e = 0 else do while ( f > 0 .and. mod ( f, 2 ) == 0 ) f = f / 2 e = e + 1 end do end if end if return end subroutine b4_ultrix_to_r ( word, r ) ! !******************************************************************************* ! !! B4_ULTRIX_TO_R converts a 4 byte ULTRIX word into a real value. ! ! ! Discussion: ! ! The routine should be able to interpret such a word, even if run on a ! different computer. ! ! The MIL-STD bit routines BTEST and MVBITS are used. ! ! The word containing the real value may be interpreted as: ! ! /SEEEEEEE/EFFFFFFF/FFFFFFFF/FFFFFFFF/ ! ! /33222222/22222222/22222100/00000000/ ! /10987654/32109876/54321098/76543210/ <-- Bit numbering ! ! where ! ! S is the sign bit, ! E are the exponent bits, ! F are the mantissa bits. ! ! S is 0 for if R is positive, and 1 if R is negative. ! ! The exponent E is "biased" by 126. That is, you must subtract 126 ! from the exponent to get the true value. ! ! The mantissa F is "normalized". That is, there is an implicit ! leading 1 which is not stored. ! ! It then uses the following formula: ! ! R = (-1)**S * 2.0**(E-126) * real ( F ) / 2.0**24 ! ! Modified: ! ! 13 November 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer WORD, the word to be decoded. ! ! Output, real R, the value of the real number. ! implicit none ! integer e integer f real r integer s integer word ! ! Read bit 31, the sign bit. ! if ( btest ( word, 31 ) ) then s = 1 else s = 0 end if ! ! Read bits 23 through 30, the exponent, biased by 126. ! e = 0 call mvbits ( word, 23, 8, e, 0 ) if ( e /= 0 ) then ! ! Read bits 0 through 22, the mantissa. ! First store the implicit leading bit. ! f = 2**23 call mvbits ( word, 0, 23, f, 0 ) else f = 0 end if ! ! The division by 2**24 reflects the shifting of ! the mantissa from an integer to a normalized value! ! It's 24 because, remember, we have that implicit bit! ! r = real ( (-1)**s ) * 2.0E+00**(e-126) * real ( f ) / 2.0E+00**24 return end subroutine b4_vms_to_r ( word, isgn, iexp, mant, r ) ! !******************************************************************************* ! !! B4_VMS_TO_R converts a 4 byte VMS word into a real value. ! ! ! Discussion: ! ! The routine should be able to interpret such a word, even if run on a ! different computer. ! ! The MIL-STD bit routines BTEST and MVBITS are used. ! ! The bytes of the original VMS word must be unscrambled first. ! If we write the word as stored by VMS as "ABCD", we must read ! the word as "CDAB". ! ! Having done that, the resulting word may then be interpreted as: ! ! /SEEEEEEE/EFFFFFFF/FFFFFFFF/FFFFFFFF/ ! 3 2 1 ! /10987654/32109876/54321098/76543210/ <-- Bit numbering ! ! where ! ! S is the sign bit, ! E are the exponent bits, ! F are the mantissa bits. ! ! The mantissa is "normalized". That is, there is an implicit ! leading 1 which is not stored. ! ! The exponent is "biased" by 128. That is, you must subtract 128 ! from the exponent to get the true value. ! ! Internally, the routine unscrambles the bits, and constructs the ! values of the sign (ISGN), the exponent (IEXP), and the mantissa ! (MANT). ! ! It then uses the following formula to reconstruct the real ! number: ! ! R = ISGN * 2.0**(IEXP) * REAL(MANT)/2.0**24 ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer WORD, the word that contains a VMS real number. ! ! Output, integer ISGN, +1 or -1, the sign of the real number. ! ! Output, integer IEXP, the exponent of the real number, ! with the bias removed. ! ! Output, integer MANT, the mantissa of the real number, ! which must be divided by 2**24 to create the actual ! mantissa. ! ! Output, real R, the value of the real number coded by IWORD. ! implicit none ! integer iexp integer isgn integer mant real r integer word ! ! Read VMS sign bit. ! if ( btest ( word, 15 ) ) then isgn = -1 else isgn = 1 end if ! ! Read VMS exponent bits. ! iexp = 0 call mvbits ( word, 7, 8, iexp, 0 ) if ( iexp /= 0 ) then iexp = iexp - 128 ! ! Read VMS mantissa. ! mant = 2**23 call mvbits ( word, 0, 7, mant, 16 ) call mvbits ( word, 16, 16, mant, 0 ) else mant = 0 end if ! ! The final multiplication by 2**-24 reflects the shifting of ! the mantissa from an integer to a normalized value! ! It's 24 because remember we have that implicit bit! ! r = isgn * mant * 2.0E+00**( iexp - 24 ) return end subroutine base_to_i ( s, base, i ) ! !******************************************************************************* ! !! BASE_TO_I returns the value of an integer represented in some base. ! ! ! Examples: ! ! Input Output ! ------------- ------ ! S BASE I ! ------ ----- ------ ! '101' 2 5 ! '-1000' 3 -27 ! '100' 4 16 ! '111111' 2 63 ! '111111' -2 21 ! '111111' 1 6 ! '111111' -1 0 ! ! Modified: ! ! 27 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string. The elements of S are ! blanks, a plus or minus sign, and digits. Normally, the digits ! are representations of integers between 0 and |BASE-1|. In the ! special case of base 1 or base -1, we allow both 0 and 1 as digits. ! ! Input, integer BASE, the base in which the representation is given. ! Normally, 2 <= BASE <= 16. However, there are two exceptions. ! ! BASE = 1 is allowed, in which case we allow the digits '1' and '0', ! and we simply count the '1' digits for the result. ! ! Negative bases between -16 and -2 are allowed. ! ! The base -1 is allowed, and essentially does a parity check on ! a string of 1's. ! ! Output, integer I, the integer. ! implicit none ! integer base character c integer i integer ichr integer idig integer isgn integer istate integer nchar character ( len = * ) s ! i = 0 nchar = len_trim ( s ) if ( base == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BASE_TO_I - Serious error!' write ( *, '(a)' ) ' The input base is zero.' return end if if ( abs ( base ) > 16 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BASE_TO_I - Serious error!' write ( *, '(a)' ) ' The input base is greater than 16!' return end if istate = 0 isgn = 1 ichr = 1 do while ( ichr <= nchar ) c = s(ichr:ichr) ! ! Blank. ! if ( c == ' ' ) then if ( istate == 2 ) then exit end if ! ! Sign, + or -. ! else if ( c == '-' ) then if ( istate /= 0 ) then exit end if istate = 1 isgn = - 1 else if ( c == '+' ) then if ( istate /= 0 ) then exit end if istate = 1 else ! ! Digit? ! call ch_to_digit_hex ( c, idig ) if ( abs ( base ) == 1 .and. idig == 0 .or. idig == 1 ) then i = base * i + idig istate = 2 else if ( 0 <= idig .and. idig < abs ( base ) ) then i = base * i + idig istate = 2 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BASE_TO_I - Serious error!' write ( *, '(a)' ) ' Illegal digit = "' // c // '"' write ( *, '(a)' ) ' Conversion halted prematurely!' return end if end if ichr = ichr + 1 end do ! ! Once we're done reading information, we expect to be in state 2. ! if ( istate /= 2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BASE_TO_I - Serious error!' write ( *, '(a)' ) ' Unable to decipher input!' return end if ! ! Account for the sign. ! i = isgn * i return end subroutine binary_to_i ( s, i ) ! !******************************************************************************* ! !! BINARY_TO_I converts a binary representation into an integer value. ! ! ! Examples: ! ! S I ! ! '101' 5 ! '-1000' -8 ! '1' 1 ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the binary representation. ! ! Output, integer I, the integer whose representation was input. ! implicit none ! character c integer i integer ichr integer isgn integer istate integer nchar character ( len = * ) s ! nchar = len_trim ( s ) i = 0 ichr = 1 istate = 0 isgn = 1 do while ( ichr <= nchar ) c = s(ichr:ichr) ! ! Blank. ! if ( c == ' ' ) then if ( istate == 2 ) then istate = 3 end if ! ! Sign, + or -. ! else if ( c == '-' ) then if ( istate == 0 ) then istate = 1 isgn = - 1 else istate = - 1 end if else if ( c == '+' ) then if ( istate == 0 ) then istate = 1 else istate = - 1 end if ! ! Digit, 0 or 1. ! else if ( c == '1' ) then i = 2 * i i = i + 1 istate = 2 else if ( c == '0' ) then i = 2 * i istate = 2 ! ! Illegal or unknown sign. ! else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BINARY_TO_I - Serious error!' write ( *, '(a)' ) ' Illegal digit = "' // c // '"' write ( *, '(a)' ) ' Conversion halted prematurely!' return end if if ( istate == -1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BINARY_TO_I - Serious error!' write ( *, '(a)' ) ' Unable to decipher input!' return end if if ( istate >= 3 ) then exit end if ichr = ichr + 1 end do ! ! Apply the sign. ! i = isgn * i return end subroutine binary_to_r ( s, r ) ! !******************************************************************************* ! !! BINARY_TO_R converts a binary representation into a real value. ! ! ! Examples: ! ! S R ! ! -1010.11 -10.75 ! 0.011011 0.4218750 ! 0.01010101010101010101010 0.3333333 ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the binary representation. ! ! Output, real R, the real number whose representation was input. ! implicit none ! character c integer ichr integer intval integer isgn integer istate integer nchar integer power real r character ( len = * ) s ! nchar = len_trim ( s ) intval = 0 ichr = 1 istate = 0 isgn = 1 r = 0.0E+00 power = 0 do while ( ichr <= nchar ) c = s(ichr:ichr) ! ! Blank. ! if ( c == ' ' ) then if ( istate == 4 ) then istate = 5 end if ! ! Sign, + or -. ! else if ( c == '-' ) then if ( istate == 0 ) then istate = 1 isgn = - 1 else istate = - 1 end if else if ( c == '+' ) then if ( istate == 0 ) then istate = 1 else istate = - 1 end if ! ! Digit, 0 or 1. ! else if ( c == '1' ) then intval = 2 * intval + 1 if ( istate == 0 .or. istate == 1 ) then istate = 2 else if ( istate == 3 ) then istate = 4 end if if ( istate == 4 ) then power = power + 1 end if else if ( c == '0' ) then intval = 2 * intval if ( istate == 0 .or. istate == 1 ) then istate = 2 else if ( istate == 3 ) then istate = 4 end if if ( istate == 4 ) then power = power + 1 end if ! ! Decimal point. ! else if ( c == '.' ) then if ( istate <= 2 ) then istate = 3 else istate = - 1 end if ! ! Illegal or unknown sign. ! else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BINARY_TO_R - Serious error!' write ( *, '(a)' ) ' Illegal character = "' // c // '"' write ( *, '(a)' ) ' Conversion halted prematurely!' stop end if if ( istate == -1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BINARY_TO_R - Serious error!' write ( *, '(a)' ) ' Unable to decipher input!' stop end if if ( istate >= 5 ) then exit end if ichr = ichr + 1 end do ! ! Apply the sign and the scale factor. ! r = real ( isgn * intval ) / 2.0E+00**power return end subroutine bits_to_i ( s, i ) ! !******************************************************************************* ! !! BITS_TO_I converts a bit string into a 32 bit integer. ! ! ! Examples: ! ! S I ! '00000000000000000000000000000001' 1 ! ! Modified: ! ! 29 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = 32 ) S, a string containing '0' and ! '1' representing the bit pattern of a word. ! ! S should only contain '0' and '1' values. However, ! any character that is not equal to '1' will be ! interpreted as a '0'. ! ! S should contain at least as many characters as the ! word, which is typically 32. S may contain more ! characters, in which case only characters 1 through 32 ! will be used. If S contains fewer characters than ! needed, the remainder will be assumed to equal '0'. ! ! Output, integer I, a variable whose bit pattern is equal to S. ! The bit pattern '00..00101' would generally return the value 5. ! Note that negative integers have an initial '1'. ! implicit none ! integer, parameter :: nbits = 32 ! character c integer i integer j integer lens integer pos character ( len = nbits ) s ! ! Get the length of the input word. ! lens = len_trim ( s ) i = 0 ! ! Set bits 0 to NBITS-1 of the word, using characters 1 through ! NBITS of the string. ! do pos = 0, nbits - 1 j = nbits - pos if ( j <= lens ) then c = s(j:j) else c = '0' end if if ( c == '1' ) then i = ibset ( i, pos ) else i = ibclr ( i, pos ) end if end do return end subroutine bits_to_r ( s, r ) ! !******************************************************************************* ! !! BITS_TO_R converts a bit string into a 32 bit real. ! ! ! Modified: ! ! 08 November 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = 32 ) S, a string containing '0' and ! '1' representing the bit pattern of a word. ! ! S should only contain '0' and '1' values. However, ! any character that is not equal to '1' will be ! interpreted as a '0'. ! ! S should contain at least as many characters as the ! word, which is typically 32. S may contain more ! characters, in which case only characters 1 through 32 ! will be used. If S contains fewer characters than ! needed, the remainder will be assumed to equal '0'. ! ! Output, real R, a variable whose bit pattern is equal to S. ! (Internal to the routine, R is declared an integer, but ! don't worry about that!) ! implicit none ! integer, parameter :: nbits = 32 ! character c integer j integer lens integer pos integer r character ( len = nbits ) s ! ! Get the length of the input word. ! lens = len_trim ( s ) r = 0 ! ! Set bits 0 to NBITS-1 of the word, using characters 1 through ! NBITS of the string. ! do pos = 0, nbits - 1 j = nbits - pos if ( j <= lens ) then c = s(j:j) else c = '0' end if if ( c == '1' ) then r = ibset ( r, pos ) else r = ibclr ( r, pos ) end if end do return end subroutine ch_cap ( c ) ! !******************************************************************************* ! !! CH_CAP capitalizes a single character. ! ! ! 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 subroutine ch_count_chvec_add ( n, chvec, count ) ! !******************************************************************************* ! !! CH_COUNT_CHVEC_ADD adds a character vector to a character count. ! ! ! Modified: ! ! 05 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, character CHVEC(N), a vector of characters. ! ! Input/output, integer COUNT(0:255), the character counts. ! implicit none ! integer n ! integer count(0:255) character chvec(n) integer i integer j ! do i = 1, n j = ichar ( chvec(i) ) count(j) = count(j) + 1 end do return end subroutine ch_count_file_add ( file_name, count ) ! !******************************************************************************* ! !! CH_COUNT_FILE_ADD adds characters in a file to a character count. ! ! ! Discussion: ! ! Each line is counted up to the last nonblank. ! ! Modified: ! ! 05 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the file to examine. ! ! Output, integer COUNT(0:255), the character counts. ! implicit none ! integer count(0:255) character ( len = * ) file_name integer ios integer iunit character ( len = 256 ) line ! ! Open the file. ! call get_unit ( iunit ) open ( unit = iunit, file = file_name, status = 'old', iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'C_COUNT_FILE_ADD - Fatal error!' write ( *, '(a)' ) ' Could not open the file:' write ( *, '(a)' ) ' ' // trim ( file_name ) return end if do read ( iunit, '(a)', iostat = ios ) line if ( ios /= 0 ) then exit end if call ch_count_s_add ( trim ( line ), count ) end do close ( unit = iunit ) return end subroutine ch_count_histogram_print ( count, title ) ! !******************************************************************************* ! !! CH_COUNT_HISTOGRAM_PRINT prints a histogram of a set of character counts. ! ! ! Modified: ! ! 05 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer COUNT(0:255), the character counts. ! ! Input, character ( len = * ) TITLE, a title to be printed. ! implicit none ! character c character ( len = 4 ) ch4(0:255) integer count(0:255) integer i integer ihi integer ilo integer percent integer row character ( len = 4 ) s(0:255) character ( len = * ) title integer total ! total = sum ( count ) do i = 0, 255 c = char ( i ) call ch_to_sym ( c, ch4(i) ) end do do i = 0, 255 if ( total == 0 ) then percent = 0 else percent = nint ( real ( 100 * count(i) ) / real ( total ) ) end if if ( percent == 0 ) then s(i) = ' .' else write ( s(i), '(i4)' ) percent end if end do if ( len_trim ( title ) > 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Character Histogram (Percentages).' write ( *, '(a)' ) ' ' do row = 1, 16 ilo = ( row - 1 ) * 16 ihi = row * 16 - 1 write ( *, '(i3,a4,i3,3x,16a4)' ) ilo, ' to ', ihi, ch4(ilo:ihi) write ( *, '(10x,16a4)' ) s(ilo:ihi) end do return end subroutine ch_count_init ( count ) ! !******************************************************************************* ! !! CH_COUNT_INIT initializes a character count. ! ! ! Modified: ! ! 05 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer COUNT(0:255), the character counts. ! implicit none ! integer count(0:255) ! count(0:255) = 0 return end subroutine ch_count_print ( count, title ) ! !******************************************************************************* ! !! CH_COUNT_PRINT prints a set of character counts. ! ! ! Modified: ! ! 05 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer COUNT(0:255), the character counts. ! ! Input, character ( len = * ) TITLE, a title to be printed. ! implicit none ! character c character ( len = 4 ) ch4(0:255) integer count(0:255) integer i real percent character ( len = * ) title integer total ! total = sum ( count ) do i = 0, 255 c = char ( i ) call ch_to_sym ( c, ch4(i) ) end do if ( len_trim ( title ) > 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Char Count Percentages.' write ( *, '(a)' ) ' ' do i = 0, 255 if ( count(i) > 0 ) then if ( total == 0 ) then percent = 0.0E+00 else percent = real ( 100 * count(i) ) / real ( total ) end if write ( *, '(a4,2x,i8,2x,f6.3)' ) ch4(i), count(i), percent end if end do return end subroutine ch_count_s_add ( s, count ) ! !******************************************************************************* ! !! CH_COUNT_S_ADD adds a character string to a character histogram. ! ! ! Modified: ! ! 05 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string to be examined. ! ! Input/output, integer COUNT(0:255), the character counts. ! implicit none ! integer count(0:255) integer i integer j character ( len = * ) s ! do i = 1, len ( s ) j = ichar ( s(i:i) ) count(j) = count(j) + 1 end do return end function ch_eqi ( c1, c2 ) ! !******************************************************************************* ! !! CH_EQI is a case insensitive comparison of two characters for equality. ! ! ! Examples: ! ! CH_EQI ( 'A', 'a' ) is .TRUE. ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C1, C2, the characters to compare. ! ! Output, logical CH_EQI, the result of the comparison. ! implicit none ! character c1 character c1_cap character c2 character c2_cap logical ch_eqi ! c1_cap = c1 c2_cap = c2 call ch_cap ( c1_cap ) call ch_cap ( c2_cap ) if ( c1_cap == c2_cap ) then ch_eqi = .true. else ch_eqi = .false. end if return end subroutine ch_extract ( s, c ) ! !******************************************************************************* ! !! CH_EXTRACT extracts the next nonblank character from a string. ! ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string. On output, the ! first nonblank character has been removed, and the string ! has been shifted left. ! ! Output, character C, the leading character of the string. ! implicit none ! character c integer iget integer lchar character ( len = * ) s ! lchar = len_trim ( s ) c = ' ' iget = 1 do while ( iget <= lchar ) if ( s(iget:iget) /= ' ' ) then c = s(iget:iget) call s_shift_left ( s, iget ) exit end if iget = iget + 1 end do return end function ch_index ( s, c ) ! !******************************************************************************* ! !! CH_INDEX is the first occurrence of a character in a string. ! ! ! Modified: ! ! 14 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be searched. ! ! Input, character C, the character to be searched for. ! ! Output, integer CH_INDEX, the location of the first occurrence of C ! in the string, or 0 if C does not occur. ! implicit none ! character c integer ch_index integer i character ( len = * ) s ! ch_index = 0 do i = 1, len ( s ) if ( s(i:i) == c ) then ch_index = i return end if end do return end function ch_indexi ( s, c ) ! !******************************************************************************* ! !! CH_INDEXI is the (case insensitive) first occurrence of a character in a string. ! ! ! Modified: ! ! 14 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be searched. ! ! Input, character C, the character to be searched for. ! ! Output, integer CH_INDEXI, the location of the first occurrence of C ! (upper or lowercase), or 0 if C does not occur. ! implicit none ! character c logical ch_eqi integer ch_indexi integer i character ( len = * ) s ! ch_indexi = 0 do i = 1, len ( s ) if ( ch_eqi ( s(i:i), c ) ) then ch_indexi = i return end if end do return end function ch_is_alpha ( c ) ! !******************************************************************************* ! !! CH_IS_ALPHA returns TRUE if C is an alphabetic character. ! ! ! 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_alphanumeric ( c ) ! !******************************************************************************* ! !! CH_IS_ALPHANUMERIC = the character C is alphanumeric. ! ! ! Discussion: ! ! Alphanumeric characters are 'A' through 'Z', 'a' through 'z' and ! '0' through '9'. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the character to be checked. ! ! Output, logical CH_IS_ALPHANUMERIC, .TRUE. if the character is ! alphabetic or numeric, .FALSE. otherwise. ! implicit none ! character c logical ch_is_alphanumeric integer i ! i = ichar ( c ) if ( ( i >= 65 .and. i <= 90 ) .or. & ( i >= 97 .and. i <= 122 ) .or. & ( i >= 48 .and. i <= 57 ) ) then ch_is_alphanumeric = .true. else ch_is_alphanumeric = .false. end if return end function ch_is_control ( c ) ! !******************************************************************************* ! !! CH_IS_CONTROL reports whether a character is a control character or not. ! ! ! Definition: ! ! A "control character" has ASCII code <= 31 or ASCII code => 127. ! ! 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 function ch_is_digit ( c ) ! !******************************************************************************* ! !! CH_IS_DIGIT returns .TRUE. if a character is a decimal digit. ! ! ! Modified: ! ! 09 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the character to be analyzed. ! ! Output, logical CH_IS_DIGIT, .TRUE. if C is a digit, .FALSE. otherwise. ! implicit none ! character c logical ch_is_digit ! if ( lge ( c, '0' ) .and. lle ( c, '9' ) ) then ch_is_digit = .true. else ch_is_digit = .false. end if return end function ch_is_lower ( c ) ! !******************************************************************************* ! !! CH_IS_LOWER returns .TRUE. if a character is a lower case letter. ! ! ! Modified: ! ! 02 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the character to be analyzed. ! ! Output, logical CH_IS_LOWER, .TRUE. if C is a lower case letter, ! .FALSE. otherwise. ! implicit none ! character c logical ch_is_lower ! if ( lge ( c, 'a' ) .and. lle ( c, 'z' ) ) then ch_is_lower = .true. else ch_is_lower = .false. end if return end function ch_is_printable ( ch ) ! !******************************************************************************* ! !! CH_IS_PRINTABLE determines if a character is printable. ! ! ! Modified: ! ! 31 October 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character CH, a character to check. ! ! Output, logical CH_IS_PRINTABLE is TRUE if C is a printable character. ! implicit none ! character ch logical ch_is_printable integer i ! i = ichar ( ch ) if ( 32 <= i .and. i <= 127 ) then ch_is_printable = .true. else ch_is_printable = .false. end if return end function ch_is_upper ( c ) ! !******************************************************************************* ! !! CH_IS_UPPER returns .TRUE. if a character is an upper case letter. ! ! ! Modified: ! ! 02 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the character to be analyzed. ! ! Output, logical CH_IS_UPPER, .TRUE. if C is an upper case letter, ! .FALSE. otherwise. ! implicit none ! character c logical ch_is_upper ! if ( lge ( c, 'A' ) .and. lle ( c, 'Z' ) ) then ch_is_upper = .true. else ch_is_upper = .false. end if return end subroutine ch_low ( c ) ! !******************************************************************************* ! !! CH_LOW lowercases a single character. ! ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character C, the character to be lowercased. ! implicit none ! character c integer i ! i = ichar ( c ) if ( 65 <= i .and. i <= 90 ) then c = char ( i + 32 ) end if return end subroutine ch_next ( s, c, done ) ! !******************************************************************************* ! !! CH_NEXT reads the next character from a string, ignoring blanks and commas. ! ! ! Example: ! ! Input: ! ! S = ' A B, C DE F' ! ! Output: ! ! 'A', 'B', 'C', 'D', 'E', 'F', and then blanks. ! ! Modified: ! ! 18 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string of characters. Blanks and ! commas are considered insignificant. ! ! Output, character C. If DONE is FALSE, then C contains the ! "next" character. If DONE is TRUE, then C is blank. ! ! Input/output, logical DONE. ! On input with a fresh value of S, the user should set ! DONE to TRUE. ! On output, the routine sets DONE to FALSE if another character ! was read, or TRUE if no more characters could be read. ! implicit none ! character c logical done integer i integer, save :: next = 1 character ( len = * ) s ! if ( done ) then next = 1 done = .false. end if do i = next, len ( s ) if ( s(i:i) /= ' ' .and. s(i:i) /= ',' ) then c = s(i:i) next = i + 1 return end if end do done = .true. next = 1 c = ' ' return end function ch_not_control ( c ) ! !******************************************************************************* ! !! CH_NOT_CONTROL = character is NOT a control character. ! ! ! Modified: ! ! 05 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C is the character to be tested. ! ! Output, logical LNCON, TRUE if C is not a control character, ! and FALSE otherwise. ! implicit none ! character c logical ch_not_control ! if ( ichar ( c ) <= 31 .or. ichar ( c ) >= 128 ) then ch_not_control = .true. else ch_not_control = .false. end if return end subroutine ch_random ( clo, chi, c ) ! !******************************************************************************* ! !! CH_RANDOM returns a random character in a given range. ! ! ! Modified: ! ! 23 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character CLO, CHI, the minimum and maximum acceptable characters. ! ! Output, character C, the randomly chosen character. ! implicit none ! character c character chi character clo integer i integer ihi integer ilo ! ilo = ichar ( clo ) ihi = ichar ( chi ) call i_random ( ilo, ihi, i ) c = char ( i ) return end function ch_roman_to_i ( c ) ! !******************************************************************************* ! !! CH_ROMAN_TO_I returns the integer value of a single digit of a Roman numeral. ! ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, a Roman numeral. ! ! Output, integer CH_ROMAN_TO_I, the value of the Roman numeral. ! If the Roman numeral was not recognized, 0 is returned. ! implicit none ! character c integer ch_roman_to_i integer i logical s_eqi ! if ( s_eqi ( c, 'M' ) ) then i = 1000 else if ( s_eqi ( c, 'D' ) ) then i = 500 else if ( s_eqi ( c, 'C' ) ) then i = 100 else if ( s_eqi ( c, 'L' ) ) then i = 50 else if ( s_eqi ( c, 'X' ) ) then i = 10 else if ( s_eqi ( c, 'V' ) ) then i = 5 else if ( s_eqi ( c, 'I' ) .or. s_eqi ( c, 'J' ) ) then i = 1 else i = 0 end if ch_roman_to_i = i return end subroutine ch_swap ( c1, c2 ) ! !******************************************************************************* ! !! CH_SWAP swaps two characters. ! ! ! Modified: ! ! 30 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character C1, C2. On output, the values of C1 and ! C2 have been interchanged. ! implicit none ! character c1 character c2 character c3 ! c3 = c1 c1 = c2 c2 = c3 return end subroutine ch_to_amino_name ( c, amino_name ) ! !******************************************************************************* ! !! CH_TO_AMINO_NAME converts a character to an amino acid name. ! ! ! Reference: ! ! Carl Branden and John Tooze, ! Introduction to Protein Structure, ! Garland Publishing, 1991. ! ! Modified: ! ! 16 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the one letter code for an amino acid. ! Lower and upper case letters are treated the same. ! ! Output, character ( len = * ) AMINO_NAME, the full name of the corresponding ! amino acid. The longest name is 27 characters. If the input code ! is not recognized, then AMINO_NAME will be set to '???'. ! implicit none ! integer, parameter :: n = 23 ! character ( len = * ) amino_name character ( len = 27 ), dimension ( n ) :: amino_table = (/ & 'Alanine ', & 'Aspartic acid or Asparagine', & 'Cysteine ', & 'Aspartic acid ', & 'Glutamic acid ', & 'Phenylalanine ', & 'Glycine ', & 'Histidine ', & 'Isoleucine ', & 'Lysine ', & 'Leucine ', & 'Methionine ', & 'Asparagine ', & 'Proline ', & 'Glutamine ', & 'Arginine ', & 'Serine ', & 'Threonine ', & 'Valine ', & 'Tryptophan ', & 'Undetermined amino acid ', & 'Tyrosine ', & 'Glutamic acid or Glutamine ' /) character c logical ch_eqi character, dimension ( n ) :: ch_table = (/ & 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'K', & 'L', 'M', 'N', 'P', 'Q', 'R', 'S', 'T', 'V', 'W', & 'X', 'Y', 'Z' /) integer i ! do i = 1, n if ( ch_eqi ( c, ch_table(i) ) ) then amino_name = amino_table(i) return end if end do amino_name = '???' return end subroutine ch_to_braille ( c, ncol, braille ) ! !******************************************************************************* ! !! CH_TO_BRAILLE converts an ASCII character to a Braille character string. ! ! ! Modified: ! ! 24 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the ASCII character. ! ! Output, integer NCOL, the number of columns used to represent the ! character. ! ! Output, character ( len = 6 ) BRAILLE(3), contains, in rows 1 ! through 3 and character columns 1 through NCOL, either a '*' or a ' '. ! implicit none ! integer, parameter :: num_symbol = 37 ! character ( len = 6 ) braille(3) character c logical ch_is_digit logical ch_is_upper integer i integer iascii integer ic_to_ibraille integer ibraille integer ncol ! ! space Aa1 Bb2 Cc3 Dd4 ! Ee5 Ff6 Gg7 Hh8 Ii9 ! Jj0 Kk Ll Mm Nn ! Oo Pp Qq Rr Ss ! Tt Uu Vv Ww Xx ! Yy Zz & , ; ! : . ! () "? ! ' - ! character ( len = 6 ), parameter, dimension ( num_symbol ) :: symbol = (/ & ' ', '* ', '* * ', '** ', '** * ', & '* * ', '*** ', '**** ', '* ** ', ' ** ', & ' *** ', '* * ', '* * * ', '** * ', '** ** ', & '* ** ', '*** * ', '***** ', '* *** ', ' ** * ', & ' **** ', '* **', '* * **', ' *** *', '** **', & '** ***', '* ***', '*** **', ' * ', ' * * ', & ' ** ', ' ** *', ' *** ', ' ****', ' * **', & ' * ', ' **' /) ! ncol = 0 braille(1)(1:6) = ' ' braille(2)(1:6) = ' ' braille(3)(1:6) = ' ' ! ! A space is treated specially. ! if ( c == ' ' ) then braille(1)(1:2) = ' ' braille(2)(1:2) = ' ' braille(3)(1:2) = ' ' ncol = 2 return end if ! ! Get the ASCII numeric code of the character. ! iascii = ichar ( c ) ! ! Get the index of the Braille equivalent. ! ibraille = ic_to_ibraille ( iascii ) if ( ibraille >= 0 ) then ! ! Upper case characters are preceded by a special mark. ! if ( ch_is_upper ( c ) ) then braille(1)(1:3) = ' ' braille(2)(1:3) = ' ' braille(3)(1:3) = ' * ' ncol = 3 ! ! Digits are preceded by a special mark. ! else if ( ch_is_digit ( c ) ) then braille(1)(1:3) = ' * ' braille(2)(1:3) = ' * ' braille(3)(1:3) = '** ' ncol = 3 end if braille(1)(ncol+1:ncol+2) = symbol(ibraille)(1:2) braille(2)(ncol+1:ncol+2) = symbol(ibraille)(3:4) braille(3)(ncol+1:ncol+2) = symbol(ibraille)(5:6) ncol = ncol + 2 ! ! Add a trailing "half space". ! braille(1)(ncol+1:ncol+1) = ' ' braille(2)(ncol+1:ncol+1) = ' ' braille(3)(ncol+1:ncol+1) = ' ' ncol = ncol + 1 end if return end subroutine ch_to_ch3_amino ( c, c3 ) ! !******************************************************************************* ! !! CH_TO_CH3_AMINO converts a 1 character code to a 3 character code for an amino acid. ! ! ! Reference: ! ! Carl Branden and John Tooze, ! Introduction to Protein Structure, ! Garland Publishing, 1991. ! ! Modified: ! ! 18 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the one letter code for an amino acid. ! Lower and upper case letters are treated the same. ! ! Output, character ( len = 3 ) C3, the three letter code for the ! amino acid. If the input code is not recognized, then C3 will be '???'. ! implicit none ! integer, parameter :: n = 23 ! character c logical ch_eqi character, parameter, dimension ( n ) :: ch_table = (/ & 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'K', & 'L', 'M', 'N', 'P', 'Q', 'R', 'S', 'T', 'V', 'W', & 'X', 'Y', 'Z' /) character ( len = 3 ) c3 character ( len = 3 ), parameter, dimension ( n ) :: ch3_table = (/ & 'Ala', 'Asx', 'Cys', 'Asp', 'Glu', 'Phe', 'Gly', 'His', 'Ise', 'Lys', & 'Leu', 'Met', 'Asn', 'Pro', 'Gln', 'Arg', 'Ser', 'Thr', 'Val', 'Trp', & 'X ', 'Tyr', 'Glx' /) integer i ! do i = 1, n if ( ch_eqi ( c, ch_table(i) ) ) then c3 = ch3_table(i) return end if end do c3 = '???' return end subroutine ch_to_digit ( c, digit ) ! !******************************************************************************* ! !! CH_TO_DIGIT returns the integer value of a base 10 digit. ! ! ! Example: ! ! C DIGIT ! --- ----- ! '0' 0 ! '1' 1 ! ... ... ! '9' 9 ! ' ' 0 ! 'X' -1 ! ! Modified: ! ! 04 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the decimal digit, '0' through '9' or blank ! are legal. ! ! Output, integer DIGIT, the corresponding integer value. If C was ! 'illegal', then DIGIT is -1. ! implicit none ! character c integer digit ! if ( lge ( c, '0' ) .and. lle ( c, '9' ) ) then digit = ichar ( c ) - 48 else if ( c == ' ' ) then digit = 0 else digit = -1 end if return end subroutine ch_to_digit_bin ( c, digit ) ! !******************************************************************************* ! !! CH_TO_DIGIT_BIN returns the integer value of a binary digit. ! ! ! Discussion: ! ! This routine handles other traditional binary pairs of "digits" ! besides '0' and '1'. ! ! Example: ! ! C DIGIT ! --- ----- ! '0' 0 ! '1' 1 ! 'T' 1 ! 'F' 0 ! 'Y' 1 ! 'N' 0 ! '+' 1 ! '-' 0 ! ! Modified: ! ! 07 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the binary digit. ! ! Output, integer DIGIT, the corresponding integer value. If C was ! 'illegal', then DIGIT is -1. ! implicit none ! character c integer digit ! if ( c == '0' .or. c == 'F' .or. c == 'f' .or. c == '-' .or. c == 'N' .or. & c == 'n' ) then digit = 0 else if ( c == '1' .or. c == 'T' .or. c == 't' .or. c == '+' .or. & c == 'Y' .or. c == 'y' ) then digit = 1 else digit = - 1 end if return end subroutine ch_to_digit_hex ( c, i ) ! !******************************************************************************* ! !! CH_TO_DIGIT_HEX returns the integer value of a hexadecimal digit. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the hexadecimal digit, '0' ! through '9', or 'A' through 'F', or also 'a' through 'f' ! are allowed. ! ! Output, integer I, the corresponding integer, or -1 if C was illegal. ! implicit none ! character c integer i ! i = ichar ( c ) if ( lge ( c, '0' ) .and. lle ( c, '9' ) ) then i = i - 48 else if ( i >= 65 .and. i <= 70 ) then i = i - 55 else if ( i >= 97 .and. i <= 102 ) then i = i - 87 else if ( c == ' ' ) then i = 0 else i = -1 end if return end subroutine ch_to_digit_oct ( c, i ) ! !******************************************************************************* ! !! CH_TO_DIGIT_OCT returns the integer value of an octal digit. ! ! ! Modified: ! ! 07 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the octal digit, '0' through '7'. ! ! Output, integer I, the corresponding integer value, or ! -1 if C was illegal. ! implicit none ! character c integer i ! i = ichar ( c ) if ( lge ( c, '0' ) .and. lle ( c, '7' ) ) then i = i - 48 else if ( c == ' ' ) then i = 0 else i = - 1 end if return end function ch_to_ebcdic ( c ) ! !******************************************************************************* ! !! CH_TO_EBCDIC converts a character to EBCDIC. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the ASCII character. ! ! Output, character CH_TO_EBCDIC, the corresponding EBCDIC character, or a ! blank character if no correspondence holds. ! implicit none ! character c character ch_to_ebcdic integer i integer ic_to_iebcdic ! i = ic_to_iebcdic ( ichar ( c ) ) if ( i /= -1 ) then ch_to_ebcdic = char ( i ) else ch_to_ebcdic = ' ' end if return end subroutine ch_to_military ( c, military ) ! !******************************************************************************* ! !! CH_TO_MILITARY converts an ASCII character to a Military code word. ! ! ! Example: ! ! 'A' 'Alpha' ! 'B' 'Bravo' ! 'Z' 'Zulu' ! 'a' 'alpha' ! '7' '7' ! '%' '%' ! ! Modified: ! ! 07 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the ASCII character. ! ! Output, character ( len = 8 ) MILITARY, the military code word. ! If C is not an alphabetic letter, then MILITARY is simply set equal to C. ! implicit none ! integer a_to_i character c character ( len = 8 ), parameter, dimension ( 26 ) :: code = (/ & 'alpha ', 'bravo ', 'charlie ', 'delta ', 'echo ', & 'foxtrot ', 'golf ', 'hotel ', 'india ', 'juliet ', & 'kilo ', 'lima ', 'mike ', 'november', 'oscar ', & 'papa ', 'quebec ', 'romeo ', 'sierra ', 'tango ', & 'uniform ', 'victor ', 'whiskey ', 'x-ray ', 'yankee ', & 'zulu ' /) integer i character ( len = * ) military ! i = a_to_i ( c ) if ( 1 <= i .and. i <= 26 ) then military = code(i) call ch_cap ( military(1:1) ) else if ( 27 <= i .and. i <= 52 ) then military = code(i-26) else military = c end if return end subroutine ch_to_morse ( c, morse ) ! !******************************************************************************* ! !! CH_TO_MORSE converts an ASCII character to a Morse character string. ! ! ! Modified: ! ! 26 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the ASCII character. ! ! Output, character ( len = 6 ) MORSE, the Morse character string. ! implicit none ! integer, parameter :: num_symbol = 45 ! character c integer i integer iascii integer ic_to_imorse integer imorse character ( len = 6 ) morse character ( len = 6 ), parameter, dimension ( NUM_SYMBOL ) :: msymbol = (/ & ' ', '.- ', '-... ', '-.-. ', '-.. ', & '. ', '..-. ', '--. ', '.... ', '.. ', & '.--- ', '-.- ', '.-.. ', '-- ', '-. ', & '--- ', '.--. ', '--.- ', '.-. ', '... ', & '- ', '..- ', '...- ', '.-- ', '-..- ', & '-.-- ', '--.. ', '.---- ', '..--- ', '...-- ', & '....- ', '..... ', '-.... ', '--... ', '---.. ', & '----. ', '----- ', '.-.-.-', '--..--', '---...', & '..--..', '.----.', '-....-', '-..-. ', '.-..-.' /) iascii = ichar ( c ) imorse = ic_to_imorse ( iascii ) if ( imorse == -1 ) then morse = ' ' else morse = msymbol ( imorse ) end if return end function ch_to_rot13 ( c ) ! !******************************************************************************* ! !! CH_TO_ROT13 converts a character to its ROT13 equivalent. ! ! ! Discussion: ! ! Two applications of CH_TO_ROT13 to a character will return the original. ! ! Examples: ! ! Input: Output: ! ! a n ! C P ! J W ! 5 5 ! ! 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_soundex ( c, soundex ) ! !******************************************************************************* ! !! CH_TO_SOUNDEX converts an ASCII character to a Soundex character. ! ! ! Discussion: ! ! The soundex code is used to replace words by a code of up to four ! digits. Similar sounding words will often have identical soundex ! codes. ! ! Soundex Letters ! ------- --------------- ! 0 A E I O U Y H W ! 1 B B P V ! 2 C G J K Q S X Z ! 3 D T ! 4 L ! 5 M N ! 6 R ! ! Modified: ! ! 05 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the ASCII character. ! ! Output, character SOUNDEX, the Soundex character, which is ! '0', '1', '2', '3', '4', '5', '6', or ' '. ! implicit none ! character c integer iascii integer ic_to_isoundex integer isoundex character soundex ! iascii = ichar ( c ) isoundex = ic_to_isoundex ( iascii ) if ( isoundex == -1 ) then soundex = ' ' else soundex = char ( isoundex ) end if return end subroutine ch_to_sym ( c, sym ) ! !******************************************************************************* ! !! CH_TO_SYM returns a printable symbol for any ASCII character. ! ! ! Modified: ! ! 02 April 2001 ! ! 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 ! ! Character 32 becomes SP. ! Characters 32 through 126 are themselves. ! Character 127 is DEL. ! if ( i == 32 ) then iput = iput + 1 sym(iput:iput+1) = 'SP' else if ( i <= 126 ) then iput = iput + 1 sym(iput:iput) = char ( i ) else if ( i == 127 ) then iput = iput + 1 sym(iput:iput+2) = 'DEL' end if return end subroutine ch3_to_ch_amino ( c3, c ) ! !******************************************************************************* ! !! CH3_TO_CH_AMINO converts a 3 character code to a 1 character code for an amino acid. ! ! ! Reference: ! ! Carl Branden and John Tooze, ! Introduction to Protein Structure, ! Garland Publishing, 1991. ! ! Modified: ! ! 18 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = 3 ) C3, presumably the 3 letter code for an ! amino acid. Lower and upper case letters are treated the same. ! ! Output, character C, the one letter code for the amino acid. ! If the input code is not recognized, then C will be '?'. ! implicit none ! integer, parameter :: n = 23 ! character c character, parameter, dimension ( n ) :: ch_table = (/ & 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'K', & 'L', 'M', 'N', 'P', 'Q', 'R', 'S', 'T', 'V', 'W', & 'X', 'Y', 'Z' /) character ( len = 3 ) c3 character ( len = 3 ), parameter, dimension ( n ) :: ch3_table = (/ & 'Ala', 'Asx', 'Cys', 'Asp', 'Glu', 'Phe', 'Gly', 'His', 'Ise', 'Lys', & 'Leu', 'Met', 'Asn', 'Pro', 'Gln', 'Arg', 'Ser', 'Thr', 'Val', 'Trp', & 'X ', 'Tyr', 'Glx' /) integer i logical s_eqi ! do i = 1, n if ( s_eqi ( c3, ch3_table(i) ) ) then c = ch_table(i) return end if end do c = '?' return end subroutine ch4_to_i ( ch4, i ) ! !******************************************************************************* ! !! CH4_TO_I converts a four character string to an integer. ! ! ! Modified: ! ! 28 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = 4 ) CH4, the character value. ! ! Output, integer I, a corresponding integer value. ! implicit none ! character ( len = 4 ) ch4 integer i ! read ( ch4, '(a4)' ) i return end subroutine ch4_to_r ( ch4, r ) ! !******************************************************************************* ! !! CH4_TO_R converts a 4 character string to a real. ! ! ! Modified: ! ! 28 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = 4 ) CH4, the character value. ! ! Output, real R, a corresponding real value. ! implicit none ! character ( len = 4 ) ch4 real r ! read ( ch4, '(a4)' ) r return end subroutine ch4vec_to_ivec ( n, s, ivec ) ! !******************************************************************************* ! !! CH4VEC_TO_IVEC converts an string of characters into an array of integers. ! ! ! Discussion: ! ! This routine can be useful when trying to write character data to an ! unformatted direct access file. ! ! Modified: ! ! 27 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of sets of 4 characters in the string. ! ! Input, character ( len = 4*N ) S, the string of characters. ! Each set of 4 characters is assumed to represent an integer. ! ! Output, integer IVEC(N), the integers encoded in the string. ! implicit none ! integer n ! integer i integer ivec(n) integer j character ( len = 4*n ) s ! do i = 1, n j = 4 * ( i - 1 ) + 1 call ch4_to_i ( s(j:j+3), ivec(i) ) end do return end subroutine center ( s1, s2 ) ! !******************************************************************************* ! !! CENTER inserts one string into the center of another. ! ! ! Discussion: ! ! The receiving string is not blanked out first. Therefore, if there is ! already information in it, some of it may still be around ! after the insertion. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, a string to be inserted into S2. ! ! Output, character ( len = * ) S2, the string to receive S1. ! implicit none ! integer ihi integer ilo integer jhi integer jlo integer len1 integer len2 integer m character ( len = * ) s1 character ( len = * ) s2 ! len1 = len_trim ( s1 ) len2 = len ( s2 ) if ( len1 < len2 ) then m = len2 - len1 ilo = 1 ihi = len1 jlo = ( m / 2 ) + 1 jhi = jlo + len1 - 1 else if ( len1 > len2 ) then m = len1 - len2 ilo = ( m / 2 ) + 1 ihi = ilo + len2 - 1 jlo = 1 jhi = len2 else ilo = 1 ihi = len1 jlo = 1 jhi = len2 end if s2(jlo:jhi) = s1(ilo:ihi) return end subroutine chr4_to_8 ( s1, s2 ) ! !******************************************************************************* ! !! CHR4_TO_8 replaces pairs of hexadecimal digits by a character. ! ! ! Modified: ! ! 05 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, the string to be decoded. ! ! Output, character ( len = * ) S2, the output string. ! implicit none ! integer i integer i1 integer j1 integer k1 integer nchar1 integer nchar2 integer nroom character ( len = * ) s1 character ( len = * ) s2 ! ! Set NCHAR1 to the number of characters to be copied. ! nchar2 = 0 nchar1 = len ( s1 ) if ( mod ( nchar1, 2 ) == 1 ) then nchar1 = nchar1 - 1 end if if ( nchar1 <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHR4_TO_8 - Serious error!' write ( *, '(a)' ) ' The input string has nonpositive length!' return end if ! ! Make sure we have enough room. ! nroom = len ( s2 ) if ( nchar1 > 2 * nroom ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHR4_TO_8 - Warning!' write ( *, '(a)' ) ' Not enough room in the output string.' write ( *, '(a,i6)' ) ' Positions available = ', nroom write ( *, '(a,i6)' ) ' Positions needed = ', nchar1 / 2 write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The program will drop excess characters.' nchar1 = 2 * nroom end if do i = 1, nchar1, 2 call ch_to_digit_hex ( s1(i:i), j1 ) call ch_to_digit_hex ( s1(i+1:i+1), k1 ) ! ! Make sure that the values of J1 and K1 are legal. If not, ! set I1 so that it returns a blank character. ! if ( ( 0 <= j1 .and. j1 <= 15) .and. ( 0 <= k1 .and. k1 <= 15) ) then i1 = 16 * j1 + k1 else i1 = 0 end if nchar2 = nchar2 + 1 s2(nchar2:nchar2) = char ( i1 ) end do return end subroutine chr8_to_4 ( s1, s2 ) ! !******************************************************************************* ! !! CHR8_TO_4 replaces characters by a pair of hexadecimal digits. ! ! ! Discussion: ! ! Unprintable characters (0 through 31, or 128 through 255) ! can be displayed. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, the string to be replaced. ! ! Output, character ( len = * ) S2, the output string. ! implicit none ! character c integer i integer i1 integer j integer j1 integer k1 integer nchar1 integer nroom character ( len = * ) s1 character ( len = * ) s2 ! ! Set NCHAR1 to the number of characters to be copied. ! nchar1 = len ( s1 ) if ( nchar1 <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHR8_TO_4 - Serious error!' write ( *, '(a)' ) ' The input string has nonpositive length!' return end if ! ! Make sure we have enough room. ! nroom = len ( s2 ) if ( 2 * nchar1 > nroom ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHR8_TO_4 - Warning!' write ( *, '(a)' ) ' The output string isn''t long enough to hold' write ( *, '(a)' ) ' all the information!' write ( *, '(a,i6)' ) ' Positions available: ', nroom write ( *, '(a,i6)' ) ' Positions needed: ', 2*nchar1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' We will do a partial conversion.' nchar1 = nroom / 2 end if j = 0 do i = 1, nchar1 c = s1(i:i) i1 = ichar ( c ) ! ! Compute J1 and K1 so that I1 = J1*16+K1. ! j1 = i1 / 16 k1 = i1 - 16 * j1 j = j + 1 call digit_hex_to_ch ( j1, s2(j:j) ) j = j + 1 call digit_hex_to_ch ( k1, s2(j:j) ) end do return end subroutine chra_to_s ( s1, s2 ) ! !******************************************************************************* ! !! 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 ! ! 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 chrasc ( iascii, nascii, string ) ! !******************************************************************************* ! !! CHRASC converts a vector of ASCII codes into character strings. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IASCII(NASCII), a vector presumed to ! contain entries between 0 and 255, the ASCII codes of ! individual characters. ! ! Input, integer NASCII, the number of ASCII codes input. ! ! Output, character ( len = * ) STRING(*). STRING is assumed to be ! a vector of sufficient size to contain the information ! input in IASCII. ! ! The length of the strings is determined via the ! LEN function. The entries in IASCII are converted and ! stored into the characters of STRING(1), and when that is ! full, into STRING(2) and so on until all the entries have ! been converted. ! ! If any entry of IASCII is less than 0, or greater than ! 255, it is handled as though it were 0. ! implicit none ! integer i integer iascii(*) integer ihi integer itemp integer ix integer j integer nascii integer nchar character ( len = * ) string(*) ! nchar = len ( string(1) ) ix = 0 ihi = ( (nascii-1) / nchar ) + 1 do i = 1, ihi do j = 1, nchar ix = ix + 1 if ( ix >= nascii ) then return end if itemp = iascii ( ix ) if ( itemp < 0 .or. itemp > 255 ) then itemp = 0 end if string(i)(j:j) = char ( itemp ) end do end do return end subroutine chrass ( s, lhs, rhs ) ! !******************************************************************************* ! !! CHRASS "understands" an assignment statement of the form LHS = RHS. ! ! ! Discussion: ! ! CHRASS returns a string containing the left hand side, and another ! string containing the right hand side. ! ! Leading and trailing spaces are removed from the right hand side ! and the left hand side. ! ! Examples: ! ! S Rhs Lhs ! ! 'a = 1.0' 'a' '1.0' ! 'n = -17' 'n' '-17' ! 'scale = +5.3E-2' 'scale' '+5.3E-2' ! 'filename = myprog.f' 'filename' 'myprog.f' ! '= A pot of gold' ' ' 'A pot of gold' ! 'Fred' 'Fred' ' ' ! '= Bob' ' ' 'Bob' ! '1=2, 2=3, 3=4' '1' '2, 2=3, 3=4' ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the assignment statement to be broken up. ! ! Output, character ( len = * ) LHS. ! ! LHS contains the left hand side of the assignment statement. ! ! Normally, this will be the name of a variable, which is ! assumed to be whatever appears before the first equals ! sign in the string. ! ! If the input line was blank, then LHS will equal ' '. ! ! If the input line contains an equal sign, but nothing ! before the equals sign except blanks, then LHS will be ' '. ! ! If the input line does not contain an "=" sign, then ! NAME will contain the text of the whole line. ! ! If an error occurred while trying to process the ! input line, NAME will contain the text of the line.. ! ! If the line began with "#", then NAME will contain the ! text of the line. ! ! If the line equals "end-of-input", then NAME will contain ! the text of the line. ! ! Output, character ( len = * ) RHS. ! ! RHS contains the right hand side of the assignment statement. ! ! RHS is whatever appears on the right hand side of the ! first equals sign in the string. ! ! If S is blank, then RHS is ' '. ! ! If the string contains no equals sign, then RHS is ' '. ! ! If the string contains nothing to the right of the first equals ! sign, but blanks, then RHS is ' '. ! ! The user may read the data in RHS by ! ! calling S_TO_D to read double precision data, ! calling CHRCTR to read real data, ! calling CHRCTI to read integer data, ! calling CHRCTL to read logical data, ! calling CHRCTC to read complex data. ! implicit none ! integer first integer iequal integer lens character ( len = * ) lhs character ( len = * ) rhs character ( len = * ) s integer s_first_nonblank ! ! Set default values ! lhs = ' ' rhs = ' ' ! ! Find the last nonblank. ! lens = len_trim ( s ) if ( lens <= 0 ) then return end if ! ! Look for the first equals sign. ! iequal = index ( s, '=' ) ! ! If no equals sign, then LHS = S and return. ! if ( iequal == 0 ) then first = s_first_nonblank ( s ) lhs = s(first:lens) return end if ! ! Otherwise, copy LHS = S(1:IEQUAL-1), RHS = S(IEQUAL+1:). ! lhs = s(1:iequal-1) if ( iequal + 1 <= lens ) then rhs = s(iequal+1:) end if ! ! Now shift the strings to the left. ! lhs = adjustl ( lhs ) rhs = adjustl ( rhs ) return end subroutine chrctf ( s, itop, ibot, ierror, lchar ) ! !******************************************************************************* ! !! CHRCTF reads an integer or rational fraction from a string. ! ! ! Discussion: ! ! The integer may be in real format, for example '2.25'. The routine ! returns ITOP and IBOT. If the input number is an integer, ITOP ! equals that integer, and IBOT is 1. But in the case of 2.25, ! the program would return ITOP = 225, IBOT = 100. ! ! Legal input is: ! ! blanks, ! initial sign, ! blanks, ! integer part, ! decimal point, ! fraction part, ! 'E' or 'e' or 'D' or 'd', exponent marker, ! exponent sign, ! exponent integer part, ! blanks, ! final comma or semicolon. ! ! with most quantities optional. ! ! Examples: ! ! S ITOP IBOT ! ! '1' 1 1 ! ' 1 ' 1 1 ! '1A' 1 1 ! '12,34,56' 12 1 ! ' 34 7' 34 1 ! '-1E2ABCD' -100 1 ! '-1X2ABCD' -1 1 ! ' 2E-1' 2 10 ! '23.45' 2345 100 ! ! Modified: ! ! 07 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string containing the ! data to be read. Reading will begin at position 1 and ! terminate when no more characters ! can be read to form a legal integer. Blanks, commas, ! or other nonnumeric data will, in particular, cause ! the conversion to halt. ! ! Output, integer ITOP, the integer read from the string, ! assuming that no negative exponents or fractional parts ! were used. Otherwise, the 'integer' is ITOP/IBOT. ! ! Output, integer IBOT, the integer divisor required to ! represent numbers which are in real format or have a ! negative exponent. ! ! Output, integer IERROR, error flag. ! 0 if no errors, ! Value of IHAVE when error occurred otherwise. ! ! Output, integer LCHAR, number of characters read from ! the string to form the number. ! implicit none ! logical ch_eqi character c integer ibot integer ierror integer ihave integer isgn integer iterm integer itop integer jsgn integer jtop integer lchar integer nchar integer ndig character ( len = * ) s ! nchar = len_trim ( s ) ierror = 0 lchar = - 1 isgn = 1 itop = 0 ibot = 1 jsgn = 1 jtop = 0 ihave = 1 iterm = 0 do while ( lchar < nchar ) lchar = lchar + 1 c = s(lchar+1:lchar+1) ! ! Blank. ! if ( c == ' ' ) then if ( ihave == 2 ) then else if ( ihave == 6 .or. ihave == 7 ) then iterm = 1 else if ( ihave > 1 ) then ihave = 11 end if ! ! Comma. ! else if ( c == ',' .or. c == ';' ) then if ( ihave /= 1 ) then iterm = 1 ihave = 12 lchar = lchar + 1 end if ! ! Minus sign. ! else if ( c == '-' ) then if ( ihave == 1 ) then ihave = 2 isgn = - 1 else if ( ihave == 6 ) then ihave = 7 jsgn = - 1 else iterm = 1 end if ! ! Plus sign. ! else if ( c == '+' ) then if ( ihave == 1 ) then ihave = 2 else if ( ihave == 6 ) then ihave = 7 else iterm = 1 end if ! ! Decimal point. ! else if ( c == '.' ) then if ( ihave < 4 ) then ihave = 4 else iterm = 1 end if ! ! Exponent marker. ! else if ( ch_eqi ( c, 'E' ) .or. ch_eqi ( c, 'D' ) ) then if ( ihave < 6 ) then ihave = 6 else iterm = 1 end if ! ! Digit. ! else if ( lge ( c, '0' ) .and. lle ( c, '9' ) .and. ihave < 11 ) then if ( ihave <= 2 ) then ihave = 3 else if ( ihave == 4 ) then ihave = 5 else if ( ihave == 6 .or. ihave == 7 ) then ihave = 8 end if call ch_to_digit ( c, ndig ) if ( ihave == 3 ) then itop = 10 * itop + ndig else if ( ihave == 5 ) then itop = 10 * itop + ndig ibot = 10 * ibot else if ( ihave == 8 ) then jtop = 10 * jtop + ndig end if ! ! Anything else is regarded as a terminator. ! else iterm = 1 end if if ( iterm == 1 ) then exit end if end do if ( iterm /= 1 .and. lchar+1 == nchar ) then lchar = nchar end if ! ! Number seems to have terminated. Have we got a legal number? ! if ( ihave == 1 .or. ihave == 2 .or. ihave == 6 .or. ihave == 7 ) then ierror = ihave write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHRCTF - Serious error!' write ( *, '(a)' ) ' Illegal input:' // trim ( s ) return end if ! ! Number seems OK. Form it. ! if ( jsgn == 1 ) then itop = itop * 10**jtop else ibot = ibot * 10**jtop end if itop = isgn * itop return end subroutine chrctg ( s, itop, ibot, ierror, lchar ) ! !******************************************************************************* ! !! CHRCTG reads an integer, decimal fraction or a ratio from a string. ! ! ! Discussion: ! ! CHRCTG returns an equivalent ratio (ITOP/IBOT). ! ! If the input number is an integer, ITOP equals that integer, and ! IBOT is 1. But in the case of 2.25, the program would return ! ITOP = 225, IBOT = 100. ! ! A ratio is either ! a number ! or ! a number, "/", a number. ! ! A "number" is defined as: ! ! blanks, ! initial sign, ! integer part, ! decimal point, ! fraction part, ! E, ! exponent sign, ! exponent integer part, ! blanks, ! final comma or semicolon, ! ! Examples of a number: ! ! 15, 15.0, -14E-7, E2, -12.73E-98, etc. ! ! Examples of a ratio: ! ! 15, 1/7, -3/4.9, E2/-12.73 ! ! Examples: ! ! S ITOP IBOT ! ! '1' 1 1 ! ' 1 ' 1 1 ! '1A' 1 1 ! '12,34,56' 12 1 ! ' 34 7' 34 1 ! '-1E2ABCD' -100 1 ! '-1X2ABCD' -1 1 ! ' 2E-1' 2 10 ! '23.45' 2345 100 ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string containing the ! data to be read. Reading will begin at position 1 and ! terminate when no more characters ! can be read to form a legal integer. Blanks, commas, ! or other nonnumeric data will, in particular, cause ! the conversion to halt. ! ! Output, integer ITOP, the integer read from the string, ! assuming that no negative exponents or fractional parts ! were used. Otherwise, the 'integer' is ITOP/IBOT. ! ! Output, integer IBOT, the integer divisor required to ! represent numbers which are in decimal format or have a ! negative exponent. ! ! Output, integer IERROR, error flag. ! 0 if no errors, ! Value of IHAVE in CHRCTF when error occurred otherwise. ! ! Output, integer LCHAR, the number of characters read. ! implicit none ! integer i integer i_gcd integer ibot integer ibotb integer ierror integer itemp integer itop integer itopb integer lchar integer lchar2 integer nchar character ( len = * ) s ! itop = 0 ibot = 1 lchar = 0 call chrctf ( s, itop, ibot, ierror, lchar ) if ( ierror /= 0) then return end if ! ! The number is represented as a fraction. ! If the next nonblank character is "/", then read another number. ! nchar = len_trim ( s ) do i = lchar+1, nchar-1 if ( s(i:i) == '/' ) then call chrctf ( s(i+1:), itopb, ibotb, ierror, lchar2 ) if ( ierror /= 0 ) then return end if itop = itop * ibotb ibot = ibot * itopb itemp = i_gcd ( itop, ibot ) itop = itop / itemp ibot = ibot / itemp lchar = i + lchar2 return else if ( s(i:i) /= ' ' ) then return end if end do return end subroutine chrcti2 ( s, intval, ierror, lchar ) ! !******************************************************************************* ! !! CHRCTI2 finds and reads an integer from a string. ! ! ! Discussion: ! ! The routine is given a string which may contain one or more integers. ! Starting at the first character position, it looks for the first ! substring that could represent an integer. If it finds such a string, ! it returns the integer's value, and the position of the last character ! read. ! ! Examples: ! ! S INTVAL LCHAR ! ! 'Apollo 13' 13 9 ! ' 1 ' 1 6 ! '1A' 1 1 ! '12,34,56' 12 2 ! 'A1A2A3' 1 2 ! '-1E2ABCD' -1 2 ! '-X20ABCD' 20 4 ! '23.45' 23 2 ! ' N = 34, $' 34 7 ! 'Oops!' 0 0 ! ! Modified: ! ! 26 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be read. ! Reading will begin at position 1 and terminate at the end of the ! string, or when no more characters can be read to form a legal integer. ! Blanks, commas, or other nonnumeric data will, in particular, ! cause the conversion to halt. ! ! Output, integer INTVAL, the integer read from the string, or 0 ! if there was an error. ! ! Output, integer IERROR, 0 an integer was found, 1 if no integer found. ! ! Output, integer LCHAR, the number of characters read. ! implicit none ! character c integer i integer idig integer ierror integer ihave integer intval integer isgn integer iterm integer lchar integer nchar character ( len = * ) s ! nchar = len_trim ( s ) ierror = 0 i = 0 isgn = 1 intval = 0 ihave = 0 iterm = 0 ! ! Examine the next character. ! do while ( iterm /= 1 ) i = i + 1 if ( i > nchar ) then iterm = 1 else c = s(i:i) ! ! Minus sign. ! if ( c == '-' ) then if ( ihave == 0 ) then ihave = 1 isgn = -1 else iterm = 1 end if ! ! Plus sign. ! else if ( c == '+' ) then if ( ihave == 0 ) then ihave = 1 else iterm = 1 end if ! ! Digit. ! else if ( lge ( c, '0' ) .and. lle ( c, '9' ) ) then ihave = 2 call ch_to_digit ( c, idig ) intval = 10 * intval + idig ! ! Blank or TAB. ! else if ( ihave == 2 ) then iterm = 1 else ihave = 0 end if end if end if end do if ( ihave == 2 ) then lchar = i - 1 intval = isgn * intval else ierror = 0 lchar = 0 intval = 0 end if return end subroutine chrctp ( s, cval, ierror, lchar ) ! !******************************************************************************* ! !! CHRCTP reads a parenthesized complex number from a string. ! ! ! Discussion: ! ! The routine will read as many characters as possible until it reaches ! the end of the string, or encounters a character which cannot be ! part of the number. ! ! Legal input is: ! ! 1 blanks, ! ! 2 left parenthesis, REQUIRED ! ! 3 blanks ! 4 '+' or '-' sign, ! 5 blanks ! 6 integer part, ! 7 decimal point, ! 8 fraction part, ! 9 'E' or 'e' or 'D' or 'd', exponent marker, ! 10 exponent sign, ! 11 exponent integer part, ! 12 exponent decimal point, ! 13 exponent fraction part, ! 14 blanks, ! ! 15 comma, REQUIRED ! ! 16 blanks ! 17 '+' or '-' sign, ! 18 blanks ! 19 integer part, ! 20 decimal point, ! 21 fraction part, ! 22 'E' or 'e' or 'D' or 'd', exponent marker, ! 23 exponent sign, ! 24 exponent integer part, ! 25 exponent decimal point, ! 26 exponent fraction part, ! 27 blanks, ! ! 28 right parenthesis, REQUIRED ! ! Examples: ! ! S CVAL IERROR LCHAR ! ! '(1, 1)' 1 + 1 i 0 5 ! '( 20 , 99 )' 20+99i 0 11 ! '(-1.2E+2, +30E-2)' -120+0.3i 0 17 ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string containing the ! data to be read. Reading will begin at position 1 and ! terminate at the end of the string, or when no more ! characters can be read to form a legal real. Blanks, ! commas, or other nonnumeric data will, in particular, ! cause the conversion to halt. ! ! Output, complex CVAL, the value that was read from the string. ! ! Output, integer IERROR, error flag. ! ! 0, no errors occurred. ! 1, the string was empty. ! 2, Did not find left parenthesis. ! 3, Could not read A correctly. ! 4, Did not find the comma. ! 5, Could not read B correctly. ! 6, Did not find right parenthesis. ! ! Output, integer LCHAR, the number of characters read. ! implicit none ! real aval real bval character c complex cval integer ichr integer ierror integer lchar character ( len = * ) s ! ! Initialize the return arguments. ! ierror = 0 aval = 0 bval = 0 cval = cmplx ( aval, bval ) lchar = 0 ! ! Get the length of the line, and if it's zero, return. ! if ( len_trim ( s ) <= 0 ) then ierror = 1 return end if ! ! Is the next character a left parenthesis, like it must be? ! call nexchr ( s, ichr, c ) if ( c /= '(' ) then ierror = 2 return end if lchar = ichr ! ! Is the next character a comma? Then a = 0. ! call nexchr ( s(lchar+1:), ichr, c ) if ( c == ',' ) then aval = 0 lchar = lchar + ichr ! ! Read the A value. ! else call s_to_r ( s(lchar+1:), aval, ierror, ichr ) if ( ierror /= 0 ) then ierror = 3 lchar = 0 return end if lchar = lchar + ichr ! ! Expect to read the comma ! if ( s(lchar:lchar) /= ',' ) then ierror = 4 lchar = 0 return end if end if ! ! Is the next character a left parenthesis? Then b = 0. ! call nexchr ( s(lchar+1:), ichr, c ) if ( c == ')' ) then bval = 0 lchar = lchar + ichr ! ! Read the B value. ! else call s_to_r ( s(lchar+1:), bval, ierror, ichr ) if ( ierror /= 0 ) then ierror = 5 lchar = 0 return end if lchar = lchar + ichr ! ! Expect to read the right parenthesis. ! call nexchr ( s(lchar+1:), ichr, c ) if ( c /= ')' ) then ierror = 6 lchar = 0 return end if end if lchar = lchar + ichr cval = cmplx ( aval, bval ) return end subroutine chrs_to_a ( s1, s2 ) ! !******************************************************************************* ! !! CHRS_TO_A replaces all control symbols by control characters. ! ! ! Modified: ! ! 14 April 1999 ! ! 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(ilo:), c, ihi ) iput = iput + 1 if ( iput > nchar2 ) then exit end if s2(iput:iput) = c end do return end subroutine chvec_permute ( n, a, p ) ! !******************************************************************************* ! !! CHVEC_PERMUTE permutes a character vector in place. ! ! ! Note: ! ! This routine permutes an array of character "objects", but the same ! logic can be used to permute an array of objects of any arithmetic ! type, or an array of objects of any complexity. The only temporary ! storage required is enough to store a single object. The number ! of data movements made is N + the number of cycles of order 2 or more, ! which is never more than N + N/2. ! ! Example: ! ! Input: ! ! N = 5 ! P = ( 2, 4, 5, 1, 3 ) ! A = ( 'B', 'D', 'E', 'A', 'C' ) ! ! Output: ! ! A = ( 'A', 'B', 'C', 'D', 'E' ). ! ! Modified: ! ! 20 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects. ! ! Input/output, character A(N), the array to be permuted. ! ! Input, integer P(N), the permutation. P(I) = J means ! that the I-th element of the output array should be the J-th ! element of the input array. P must be a legal permutation ! of the integers from 1 to N, otherwise the algorithm will ! fail catastrophically. ! implicit none ! integer n ! character a(n) character a_temp integer i integer ierror integer iget integer iput integer istart integer p(n) ! call perm_check ( n, p, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHVEC_PERMUTE - Fatal error!' write ( *, '(a)' ) ' The input array does not represent' write ( *, '(a)' ) ' a proper permutation. In particular, the' write ( *, '(a,i6)' ) ' array is missing the value ', ierror stop end if ! ! Search for the next element of the permutation that has not been used. ! do istart = 1, n if ( p(istart) < 0 ) then cycle else if ( p(istart) == istart ) then p(istart) = - p(istart) cycle else a_temp = a(istart) iget = istart ! ! Copy the new value into the vacated entry. ! do iput = iget iget = p(iget) p(iput) = - p(iput) if ( iget < 1 .or. iget > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHVEC_PERMUTE - Fatal error!' stop end if if ( iget == istart ) then a(iput) = a_temp exit end if a(iput) = a(iget) end do end if end do ! ! Restore the signs of the entries. ! p(1:n) = - p(1:n) return end subroutine chvec_print ( n, a, title ) ! !******************************************************************************* ! !! CHVEC_PRINT prints a character vector. ! ! ! Modified: ! ! 20 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, character A(N), the vector to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none ! integer n ! character a(n) logical ch_is_printable integer i integer ihi integer ilo integer j character ( len = 80 ) string character ( len = * ) title ! if ( title /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do ilo = 1, n, 80 ihi = min ( ilo + 79, n ) string = ' ' do i = ilo, ihi j = i + 1 - ilo if ( ch_is_printable ( a(i) ) ) then string(j:j) = a(i) end if end do write ( *, '(a)' ) trim ( string ) end do return end subroutine chvec_reverse ( n, x ) ! !******************************************************************************* ! !! CHVEC_REVERSE reverses the elements of a character vector. ! ! ! Example: ! ! Input: ! ! N = 4, X = ( 'L', 'I', 'V', 'E' ). ! ! Output: ! ! X = ( 'E', 'V', 'I', 'L' ). ! ! Modified: ! ! 26 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input/output, character X(N), the array to be reversed. ! implicit none ! integer n ! character cval integer i character x(n) ! do i = 1, n/2 cval = x(i) x(i) = x(n+1-i) x(n+1-i) = cval end do return end subroutine chvec_to_s ( n, chvec, s ) ! !******************************************************************************* ! !! CHVEC_TO_S converts a character vector to a string. ! ! ! Modified: ! ! 23 March 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of characters to convert. ! ! Input, character CHVEC(N), a vector of characters. ! ! Output, character ( len = * ) S, a string of characters. ! implicit none ! integer n ! character chvec(n) integer i character ( len = * ) s ! do i = 1, min ( n, len ( s ) ) s(i:i) = chvec(i) end do return end subroutine chvec2_print ( m, a, n, b, title ) ! !******************************************************************************* ! !! CHVEC2_PRINT prints two vectors of characters. ! ! ! Modified: ! ! 09 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the length of the first sequence. ! ! Input, character A(M), the first sequence. ! ! Input, integer N, the length of the second sequence. ! ! Input, character B(N), the second sequence. ! ! Input, character ( len = * ), a title. ! implicit none ! integer m integer n ! character a(m) character ai character b(n) character bi integer i character ( len = * ) title ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) write ( *, '(a)' ) ' ' do i = 1, max ( m, n ) if ( i <= m ) then ai = a(i) else ai = ' ' end if if ( i <= n ) then bi = b(i) else bi = ' ' end if write ( *, '(i3,2x,a1,2x,a1)' ) i, ai, bi end do return end subroutine comma ( s ) ! !******************************************************************************* ! !! COMMA moves commas left through blanks in a string. ! ! ! Examples: ! ! Input: Output: ! ----- ------ ! "To Henry , our dog" "To Henry, our dog" ! " , , ," ",,, " ! " 14.0 ," " 14.0, " ! ! Modified: ! ! 07 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, a string in which the ! commas are to be shifted left through blanks. ! implicit none ! integer iblank integer icomma character ( len = * ) s ! icomma = len_trim ( s ) do while ( icomma > 1 ) if ( s(icomma:icomma) == ',' ) then iblank = icomma do while ( iblank > 1 ) if ( s(iblank-1:iblank-1) /= ' ' ) then exit end if iblank = iblank - 1 end do if ( icomma /= iblank ) then s(icomma:icomma) = ' ' s(iblank:iblank) = ',' end if end if icomma = icomma - 1 end do return end subroutine d_to_s_left ( d, s ) ! !******************************************************************************* ! !! D_TO_S_LEFT writes a double precision value into a left justified string. ! ! ! Method: ! ! A 'G14.6' format is used with a WRITE statement. ! ! Modified: ! ! 31 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision D, the number to be written into the string. ! ! Output, character ( len = * ) S, the string into which ! the real number is to be written. If the string is less than 14 ! characters long, it will will be returned as a series of asterisks. ! implicit none ! double precision d integer i integer nchar character ( len = * ) s character ( len = 14 ) s2 ! nchar = len ( s ) if ( nchar < 14 ) then do i = 1, nchar s(i:i) = '*' end do else if ( d == 0.0D+00 ) then s(1:14) = ' 0.0 ' else write ( s2, '(g14.6)' ) d s(1:14) = s2 end if ! ! Shift the string left. ! s = adjustl ( s ) return end subroutine d_to_s_right ( d, s ) ! !******************************************************************************* ! !! D_TO_S_LEFT writes a double precision value into a right justified string. ! ! ! Method: ! ! A 'G14.6' format is used with a WRITE statement. ! ! Modified: ! ! 31 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision D, the number to be written into the string. ! ! Output, character ( len = * ) S, the string into which ! the real number is to be written. If the string is less than 14 ! characters long, it will will be returned as a series of asterisks. ! implicit none ! double precision d integer i integer nchar character ( len = * ) s character ( len = 14 ) s2 ! nchar = len ( s ) if ( nchar < 14 ) then do i = 1, nchar s(i:i) = '*' end do else if ( d == 0.0D+00 ) then s(1:14) = ' 0.0 ' else write ( s2, '(g14.6)' ) d s(1:14) = s2 end if ! ! Shift the string right. ! call s_right ( s ) return end subroutine dec_to_s_left ( ival, jval, s ) ! !******************************************************************************* ! !! DEC_TO_S_LEFT returns a left-justified representation of IVAL * 10**JVAL. ! ! ! Examples: ! ! IVAL JVAL S ! ---- ---- ------ ! 0 0 0 ! 21 3 21000 ! -3 0 -3 ! 147 -2 14.7 ! 16 -5 0.00016 ! 34 30 Inf ! 123 -21 0.0000000000000000012 ! 34 -30 0.0 ! ! Modified: ! ! 13 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IVAL, JVAL, integers which represent the decimal. ! ! Output, character ( len = * ) S, the representation of the value. ! The string is 'Inf' or '0.0' if the value was too large ! or small to represent with a fixed point format. ! implicit none ! character ( len = 22 ) chrrep integer i integer iget1 integer iget2 integer iput1 integer iput2 integer ival integer jval integer maxdigit integer ndigit integer nleft character ( len = * ) s ! s = ' ' if ( ival == 0 ) then s = '0' return end if maxdigit = len ( s ) ! ! Store a representation of IVAL in CHRREP. ! write ( chrrep, '(i22)' ) ival call s_blank_delete ( chrrep ) ndigit = len_trim ( chrrep ) ! ! Inf if JVAL is positive, and NDIGIT + JVAL > MAXDIGIT. ! if ( jval > 0 ) then if ( ndigit + jval > maxdigit ) then s = 'Inf' return end if end if ! ! Underflow if JVAL is negative, and 3 + NDIGIT - JVAL > MAXDIGIT. ! if ( jval < 0 ) then if ( ival > 0 ) then if ( 3 - ndigit - jval > maxdigit ) then s = '0.0' return end if else if ( 5 - ndigit - jval > maxdigit ) then s = '0.0' return end if end if end if ! ! If JVAL is nonnegative, insert trailing zeros. ! if ( jval >= 0 ) then s(1:ndigit) = chrrep(1:ndigit) do i = ndigit+1, ndigit+jval s(i:i) = '0' end do else if ( jval < 0 ) then iput2 = 0 iget2 = 0 ! ! Sign. ! if ( ival < 0 ) then iput1 = 1 iput2 = 1 iget2 = 1 s(iput1:iput2) = '-' ndigit = ndigit - 1 end if ! ! Digits of the integral part. ! if ( ndigit + jval > 0 ) then iput1 = iput2 + 1 iput2 = iput1 + ndigit + jval -1 iget1 = iget2 + 1 iget2 = iget1 + ndigit+jval - 1 s(iput1:iput2) = chrrep(iget1:iget2) else iput1 = iput2 + 1 iput2 = iput1 s(iput1:iput2) = '0' end if ! ! Decimal point. ! iput1 = iput2 + 1 iput2 = iput1 s(iput1:iput2) = '.' ! ! Leading zeroes. ! do i = 1, - jval - ndigit iput1 = iput2 + 1 iput2 = iput1 s(iput1:iput2) = '0' end do nleft = min ( -jval, ndigit ) nleft = min ( nleft, maxdigit - iput2 ) iput1 = iput2 + 1 iput2 = iput1 + nleft - 1 iget1 = iget2 + 1 iget2 = iget1 + nleft - 1 s(iput1:iput2) = chrrep(iget1:iget2) end if return end subroutine dec_to_s_right ( ival, jval, s ) ! !******************************************************************************* ! !! DEC_TO_S_RIGHT returns a right justified representation of IVAL * 10**JVAL. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IVAL, JVAL, the two integers which represent the ! decimal fraction. ! ! Output, character ( len = * ) S, a right justified string ! containing the representation of the decimal fraction. ! implicit none ! integer ival integer jval character ( len = * ) s ! call dec_to_s_left ( ival, jval, s ) call s_right ( s ) return end function degrees_to_radians ( angle ) ! !******************************************************************************* ! !! DEGREES_TO_RADIANS converts an angle from degrees to radians. ! ! ! Modified: ! ! 10 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ANGLE, an angle in degrees. ! ! Output, real DEGREES_TO_RADIANS, the equivalent angle ! in radians. ! implicit none ! real angle real degrees_to_radians real, parameter :: pi = 3.14159265358979323846264338327950288419716939937510E+00 ! degrees_to_radians = ( angle / 180.0E+00 ) * pi return end subroutine digit_bin_to_ch ( intval, c ) ! !******************************************************************************* ! !! DIGIT_BIN_TO_CH returns the character representation of a binary digit. ! ! ! Modified: ! ! 07 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer INTVAL, the integer, between 0 and 1. ! ! Output, character C, the character representation of INTVAL. ! implicit none ! character c integer intval ! if ( intval == 0 ) then c = '0' else if ( intval == 1 ) then c = '1' else c = '*' end if return end subroutine digit_hex_to_ch ( intval, c ) ! !******************************************************************************* ! !! DIGIT_HEX_TO_CH returns the character representation of a hexadecimal digit. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer INTVAL, the integer, between 0 and 15. ! ! Output, character C, the hexadecimal representation of INTVAL. ! implicit none ! character c integer intval ! if ( intval >= 0 .and. intval <= 9 ) then c = char ( intval + 48 ) else if ( intval >= 10 .and. intval <= 15 ) then c = char ( intval + 55 ) else c = '*' end if return end subroutine digit_inc ( c ) ! !******************************************************************************* ! !! DIGIT_INC increments a decimal digit. ! ! ! Example: ! ! Input Output ! ----- ------ ! '0' '1' ! '1' '2' ! ... ! '8' '9' ! '9' '0' ! 'A' 'A' ! ! Modified: ! ! 04 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character C, a digit to be incremented. ! implicit none ! character c integer digit ! call ch_to_digit ( c, digit ) if ( digit == -1 ) then return end if digit = digit + 1 if ( digit == 10 ) then digit = 0 end if call digit_to_ch ( digit, c ) return end subroutine digit_oct_to_ch ( intval, c ) ! !******************************************************************************* ! !! DIGIT_OCT_TO_CH returns the character representation of an octal digit. ! ! ! Modified: ! ! 07 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer INTVAL, the integer, between 0 and 7. ! ! Output, character C, the character representation of INTVAL. ! character c integer intval ! if ( intval >= 0 .and. intval <= 7 ) then c = char ( intval + 48 ) else c = '*' end if return end subroutine digit_to_ch ( digit, c ) ! !******************************************************************************* ! !! DIGIT_TO_CH returns the character representation of a decimal digit. ! ! ! Example: ! ! DIGIT C ! ----- --- ! 0 '0' ! 1 '1' ! ... ... ! 9 '9' ! 17 '*' ! ! Modified: ! ! 04 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer DIGIT, the digit value between 0 and 9. ! ! Output, character C, the corresponding character, or '*' if DIGIT ! was illegal. ! implicit none ! character c integer digit ! if ( 0 <= digit .and. digit <= 9 ) then c = char ( digit + 48 ) else c = '*' end if return end function ebcdic_to_ch ( e ) ! !******************************************************************************* ! !! EBCDIC_TO_CH converts an EBCDIC character to ASCII. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character E, the EBCDIC character. ! ! Output, character EBCDIC_TO_CH, the corresponding ASCII ! character, or a blank character if no correspondence holds. ! implicit none ! character e character ebcdic_to_ch integer i integer iebcdic_to_ic ! i = iebcdic_to_ic ( ichar ( e ) ) if ( i /= -1 ) then ebcdic_to_ch = char ( i ) else ebcdic_to_ch = ' ' end if return end subroutine ebcdic_to_s ( s ) ! !******************************************************************************* ! !! EBCDIC_TO_S converts a string of EBCDIC characters to ASCII. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S. ! On input, the EBCDIC string. ! On output, the ASCII string. ! implicit none ! character ebcdic_to_ch integer i character ( len = * ) s ! do i = 1, len ( s ) s(i:i) = ebcdic_to_ch ( s(i:i) ) end do return end subroutine fillch ( s, field, s2 ) ! !******************************************************************************* ! !! FILLCH writes a string into a subfield of a string. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, a string which is presumed ! to contain, somewhere, a substring that is to be filled in. ! The substring might be '?', for instance. ! ! On output, the substring has been overwritten. ! ! Input, character ( len = * ) FIELD, a substring to be searched for in ! S, which denotes the spot where the value should be placed. ! Trailing blanks are ignored. ! ! Input, character ( len = * ) S2, the character string to be written ! into the subfield. Trailing blanks are ignored. ! implicit none ! character ( len = * ) field integer i integer lenc integer s_indexi character ( len = * ) s character ( len = * ) s2 ! i = s_indexi ( s, field ) if ( i /= 0 ) then lenc = len_trim ( field ) call s_chop ( s, i, i+lenc-1 ) lenc = len_trim ( s2 ) call s_s_insert ( s, i, s2(1:lenc) ) end if return end subroutine fillin ( s, field, ival ) ! !******************************************************************************* ! !! FILLIN writes an integer into a subfield of a string. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, a string which is presumed ! to contain, somewhere, a substring that is to be filled in. ! The substring might be '?', for instance. ! ! On output, the substring has been overwritten by the value of IVAL. ! ! Input, character ( len = * ) FIELD, a substring to be searched for in ! S, which denotes the spot where the value should be placed. ! Trailing blanks are ignored. ! ! Input, integer IVAL, the value to be written into the subfield. ! implicit none ! character ( len = * ) field integer i integer ival integer lenc integer s_indexi character ( len = * ) s character ( len = 14 ) sval ! i = s_indexi ( s, field ) if ( i /= 0 ) then lenc = len_trim ( field ) call s_chop ( s, i, i+lenc-1 ) call i_to_s_left ( ival, sval ) lenc = len_trim ( sval ) call s_s_insert ( s, i, sval(1:lenc) ) end if return end subroutine fillrl ( s, field, r ) ! !******************************************************************************* ! !! FILLRL writes a real into a subfield of a string. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, a string which is presumed ! to contain, somewhere, a substring that is to be filled in. ! The substring might be '?', for instance. ! ! On output, the substring has been overwritten by the value. ! ! Input, character ( len = * ) FIELD, a substring to be searched for in ! S, which denotes the spot where the value should be placed. ! Trailing blanks are ignored. ! ! Input, integer R, the value to be written into the subfield. ! implicit none ! character ( len = * ) field integer i integer lenc real r character ( len = * ) s integer s_indexi character ( len = 10 ) sval ! i = s_indexi ( s, field ) if ( i /= 0 ) then lenc = len_trim ( field ) call s_chop ( s, i, i+lenc-1 ) call r_to_s_right ( r, sval ) call s_blank_delete ( sval ) lenc = len_trim ( sval ) call s_s_insert ( s, i, sval(1:lenc) ) end if return end subroutine flt_to_s ( mant, iexp, ndig, s ) ! !******************************************************************************* ! !! FLT_TO_S returns a representation of MANT * 10**IEXP. ! ! ! Examples: ! ! MANT IEXP S ! ! 1 2 100 ! 101 -1 10.1 ! 23 -3 0.023 ! ! Modified: ! ! 27 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MANT, the mantissa of the representation. ! This is an integer whose magnitude is between 0 and ! 10**NDIG, that is, 0 <= MANT < 10**NDIG. ! ! Input, integer IEXP, the exponent of 10 that multiplies MULT. ! ! Input, integer NDIG, the number of digits of accuracy ! in the representation. ! ! Output, character ( len = * ) S, the representation of the quantity. ! implicit none ! integer iexp integer jexp integer mant integer ndig character ( len = * ) s ! ! Get the length of the string, and set it all to blanks. ! s = ' ' ! ! If the mantissa is zero, the number is zero, and we have ! a special case: S = '0'. ! if ( mant == 0 ) then s = '0' return else if ( mant > 0 ) then s(1:2) = ' ' else if ( mant < 0 ) then s(1:2) = '- ' end if ! ! Now write the mantissa into S in positions 3 to NDIG+2. ! call i_to_s_left ( abs ( mant ), s(3:ndig+2) ) ! ! Insert a decimal place after the first digit. ! s(2:2) = s(3:3) s(3:3) = '.' ! ! Place the "e" representing the exponent. ! s(ndig+3:ndig+3) = 'e' ! ! Write the exponent. ! jexp = 0 do while ( abs ( mant ) >= 10**jexp ) jexp = jexp + 1 end do jexp = jexp + iexp - 1 call i_to_s_zero ( jexp, s(ndig+4:ndig+6) ) ! ! Remove all blanks, effectively shifting the string left too. ! call s_blank_delete ( s ) return end subroutine forcom ( s, fortran, comment ) ! !******************************************************************************* ! !! FORCOM splits a FORTRAN line into "fortran" and "comment". ! ! ! Discussion: ! ! The "comment" portion is everything following the first occurrence ! of an exclamation mark (and includes the exclamation mark). ! ! The "fortran" portion is everything before the first exclamation ! mark. ! ! Either or both the data and comment portions may be blank. ! ! Examples: ! ! S FORTRAN COMMENT ! ! ' x = 1952 ! Wow' ' x = 1952' '! Wow' ! ' continue' ' continue' ' ' ! '! Hey, Abbott!' ' ' '! Hey, Abbott!' ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be analyzed. ! ! Output, character ( len = * ) FORTRAN, the initial portion of the string, ! containing a FORTRAN statement. ! ! Output, character COMMENT, the final portion of the string, ! containing a comment. ! implicit none ! character ( len = * ) comment character ( len = * ) fortran integer i character ( len = * ) s ! i = index ( s, '!' ) if ( i == 0 ) then fortran = s comment = ' ' else if ( i == 1 ) then fortran = ' ' comment = s else fortran = s ( 1:i-1) comment = s ( i: ) end if return end subroutine get_unit ( iunit ) ! !******************************************************************************* ! !! 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. ! ! Modified: ! ! 02 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer IUNIT. ! ! If IUNIT = 0, then no free FORTRAN unit could be found, although ! all 99 units were checked (except for units 5 and 6). ! ! 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. ! implicit none ! integer i integer ios integer iunit logical lopen ! iunit = 0 do i = 1, 99 if ( i /= 5 .and. i /= 6 ) 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 hex_to_i ( s, intval ) ! !******************************************************************************* ! !! HEX_TO_I converts a hexadecimal string to its integer value. ! ! ! Modified: ! ! 07 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string of hexadecimal digits. ! ! Output, integer INTVAL, the corresponding integer value. ! implicit none ! integer first integer idig integer intval integer isgn integer j integer nchar character ( len = * ) s ! nchar = len_trim ( s ) ! ! Determine if there is a plus or minus sign. ! isgn = 1 first = nchar + 1 do j = 1, nchar if ( s(j:j) == '-' ) then isgn = - 1 else if ( s(j:j) == '+' ) then isgn = + 1 else if ( s(j:j) /= ' ' ) then first = j exit end if end do ! ! Read the numeric portion of the string. ! intval = 0 do j = first, nchar call ch_to_digit_hex ( s(j:j), idig ) intval = intval * 16 + idig end do intval = isgn * intval return end subroutine hex_to_s ( hex, s ) ! !******************************************************************************* ! !! HEX_TO_S converts a hexadecimal string into characters. ! ! ! Examples: ! ! Input: ! ! '414243' ! ! Output: ! ! 'ABC'. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) HEX, a string of pairs of hexadecimal values. ! ! Output, character ( len = * ) S, the corresponding character string. ! implicit none ! character ( len = * ) hex integer i integer intval integer j integer ndo integer nhex integer nstr character ( len = * ) s ! nstr = len ( s ) nhex = len_trim ( hex ) ndo = min ( nhex/2, nstr ) s = ' ' do i = 1, ndo j = 2 * i - 1 call hex_to_i ( hex(j:j+1), intval ) s(i:i) = char ( intval ) end do return end subroutine i_byte_swap ( iword, bytes ) ! !******************************************************************************* ! !! I_BYTE_SWAP swaps bytes in a 4-byte word. ! ! ! Discussion: ! ! This routine uses the MVBITS routines to carry out the swaps. The ! relationship between the bits in the word (0 through 31) and the ! bytes (1 through 4) is machine dependent. That is, byte 1 may ! comprise bits 0 through 7, or bits 24 through 31. So some ! experimentation may be necessary the first time this routine ! is used. ! ! This routine was originally written simply to take the drudgery ! out of swapping bytes in a VAX word that was to be read by ! another machine. ! ! The statement ! ! call i_byte_swap ( IWORD, (/ 1, 2, 3, 4 /) ) ! ! will do nothing to IWORD, and ! ! call i_byte_swap ( IWORD, (/ 4, 3, 2, 1 /) ) ! ! will reverse the bytes in IWORD, and ! ! call i_byte_swap ( IWORD, (/ 2, 2, 2, 2 /) ) ! ! will replace IWORD with a word containing byte(2) repeated 4 times. ! ! Modified: ! ! 29 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer IWORD, the word whose bits are to be swapped. ! ! Input, integer BYTES(4), indicates which byte in the input word ! should overwrite each byte of the output word. ! implicit none ! integer, parameter :: NUM_BYTES = 4 ! integer, parameter :: bit_length = 8 integer bytes(NUM_BYTES) integer from_pos integer i integer iword integer jword integer to_pos ! jword = iword do i = 1, NUM_BYTES if ( bytes(i) < 1 .or. bytes(i) > NUM_BYTES ) then cycle end if if ( bytes(i) == i ) then cycle end if from_pos = 8 * ( bytes(i) - 1 ) to_pos = 8 * ( i - 1 ) call mvbits ( jword, from_pos, bit_length, iword, to_pos ) end do return end function i_gcd ( i, j ) ! !******************************************************************************* ! !! I_GCD finds the greatest common divisor of I and J. ! ! ! Modified: ! ! 03 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, J, two numbers whose greatest common divisor ! is desired. ! ! Output, integer I_GCD, the greatest common divisor of I and J. ! ! Note that only the absolute values of I and J are ! considered, so that the result is always nonnegative. ! ! If I or J is 0, I_GCD is returned as max ( 1, abs ( I ), abs ( J ) ). ! ! If I and J have no common factor, I_GCD is returned as 1. ! ! Otherwise, using the Euclidean algorithm, I_GCD is the ! largest common factor of I and J. ! implicit none ! integer i integer i_gcd integer ip integer iq integer ir integer j ! i_gcd = 1 ! ! Return immediately if either I or J is zero. ! if ( i == 0 ) then i_gcd = max ( 1, abs ( j ) ) return else if ( j == 0 ) then i_gcd = max ( 1, abs ( i ) ) return end if ! ! Set IP to the larger of I and J, IQ to the smaller. ! This way, we can alter IP and IQ as we go. ! ip = max ( abs ( i ), abs ( j ) ) iq = min ( abs ( i ), abs ( j ) ) ! ! Carry out the Euclidean algorithm. ! do ir = mod ( ip, iq ) if ( ir == 0 ) then exit end if ip = iq iq = ir end do i_gcd = iq return end subroutine i_extract ( s, i, ierror ) ! !******************************************************************************* ! !! I_EXTRACT "extracts" an integer from the beginning of a string. ! ! ! Modified: ! ! 22 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S; on input, a string from ! whose beginning an integer is to be extracted. On output, ! the integer, if found, has been removed. ! ! Output, integer I. If IERROR is 0, then I contains the ! next integer read from S; otherwise I is 0. ! ! Output, integer IERROR. ! 0, no error. ! nonzero, an integer could not be extracted from the beginning of the ! string. I is 0 and S is unchanged. ! implicit none ! integer i integer ierror integer lchar character ( len = * ) s ! i = 0 call s_to_i ( s, i, ierror, lchar ) if ( ierror /= 0 .or. lchar == 0 ) then ierror = 1 i = 0 else call s_shift_left ( s, lchar ) end if return end subroutine i_input ( string, value, ierror ) ! !******************************************************************************* ! !! I_INPUT prints a prompt string and reads an integer from the user. ! ! ! Discussion: ! ! If the input line starts with a comment character ('#') or is ! blank, the routine ignores that line, and tries to read the next one. ! ! Modified: ! ! 27 March 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) STRING, the prompt string. ! ! Output, integer VALUE, the value input by the user. ! ! Output, integer IERROR, an error flag, which is zero if no error occurred. ! implicit none ! integer ierror integer last character ( len = 80 ) line character ( len = * ) string integer value ! ierror = 0 value = huge ( value ) ! ! Write the prompt. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( string ) do read ( *, '(a)', iostat = ierror ) line if ( ierror /= 0 ) then return end if ! ! If the line begins with a comment character, go back and read the next line. ! if ( line(1:1) == '#' ) then cycle end if if ( len_trim ( line ) == 0 ) then cycle end if ! ! Extract integer information from the string. ! call s_to_i ( line, value, ierror, last ) if ( ierror /= 0 ) then value = huge ( value ) return end if exit end do return end function i_length ( i ) ! !******************************************************************************* ! !! I_LENGTH computes the number of characters needed to print an integer. ! ! ! Examples: ! ! I I_LENGTH ! ! 0 1 ! 1 1 ! -1 2 ! 1952 4 ! 123456 6 ! ! Modified: ! ! 27 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the integer whose length is desired. ! ! Output, integer I_LENGTH, the number of characters required ! to print the integer. ! implicit none ! integer i integer i_copy integer i_length ! if ( i < 0 ) then i_length = 1 else if ( i == 0 ) then i_length = 1 return else if ( i > 0 ) then i_length = 0 end if i_copy = abs ( i ) do while ( i_copy /= 0 ) i_length = i_length + 1 i_copy = i_copy / 10 end do return end subroutine i_next ( s, ival, done ) ! !******************************************************************************* ! !! I_NEXT "reads" integers from a string, one at a time. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string, presumably containing ! integers. These may be separated by spaces or commas. ! ! Output, integer IVAL. If DONE is FALSE, then IVAL contains the ! "next" integer read. If DONE is TRUE, then IVAL is zero. ! ! Input/output, logical DONE. ! On input with a fresh string, the user should set DONE to TRUE. ! On output, the routine sets DONE to FALSE if another integer ! was read, or TRUE if no more integers could be read. ! implicit none ! logical done integer ierror integer ival integer lchar integer, save :: next = 1 character ( len = * ) s ! ival = 0 if ( done ) then next = 1 done = .false. end if if ( next > len ( s ) ) then done = .true. return end if call s_to_i ( s(next:), ival, ierror, lchar ) if ( ierror /= 0 .or. lchar == 0 ) then done = .true. next = 1 else done = .false. next = next + lchar end if return end subroutine i_next_read ( s, intval, ierror ) ! !******************************************************************************* ! !! I_NEXT_READ finds and reads the next integer in a string. ! ! ! Discussion: ! ! This routine can be used to extract, one at a time, the integers in ! a string. ! ! Example: ! ! Input: ! ! S = 'Data set #12 extends from (5,-43) and is worth $4.56' ! IERROR = -1 ! ! Output: ! ! (on successive calls) ! ! INTVAL IERROR ! ------ ------ ! 1 0 ! 2 0 ! 5 0 ! -43 0 ! 4 0 ! 56 0 ! 0 1 ! ! Modified: ! ! 24 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be examined. ! ! Output, integer INTVAL, the next integer in the string, or 0 ! if no integer could be found. ! ! Input/output, integer IERROR. ! ! On the first call for a given string, set IERROR = -1. ! ! Thereafter, the routine will return IERROR = 0 if another ! integer was found, or 1 if no more integers were found. ! implicit none ! integer ierror integer intval integer, save :: istart = 1 integer lchar character ( len = * ) s ! if ( ierror == -1 ) then istart = 1 end if ierror = 0 intval = 0 if ( istart > len_trim ( s ) ) then ierror = 1 return end if call chrcti2 ( s(istart:), intval, ierror, lchar ) if ( ierror == 0 .and. lchar > 0 ) then istart = istart + lchar else ierror = 1 end if return end subroutine i_random ( ilo, ihi, i ) ! !******************************************************************************* ! !! I_RANDOM returns a random integer in a given range. ! ! ! Modified: ! ! 23 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ILO, IHI, the minimum and maximum acceptable values. ! ! Output, integer I, the randomly chosen integer. ! implicit none ! integer i integer ihi integer ilo real r real rhi real rlo logical, save :: seed = .false. ! if ( .not. seed ) then call random_seed seed = .true. end if ! ! Pick a random number in (0,1). ! call random_number ( harvest = r ) ! ! Set a real interval [RLO,RHI] which contains the integers [ILO,IHI], ! each with a "neighborhood" of width 1. ! rlo = real ( ilo ) - 0.5E+00 rhi = real ( ihi ) + 0.5E+00 ! ! Set I to the integer that is nearest the scaled value of R. ! i = nint ( ( 1.0E+00 - r ) * rlo + r * rhi ) ! ! In case of oddball events at the boundary, enforce the limits. ! i = max ( i, ilo ) i = min ( i, ihi ) return end subroutine i_range_input ( string, value1, value2, ierror ) ! !******************************************************************************* ! !! I_RANGE_INPUT reads a pair of integers from the user, representing a range. ! ! ! Discussion: ! ! If the input line starts with a comment character ('#') or is blank, ! the routine ignores that line, and tries to read the next one. ! ! The pair of integers may be separated by spaces or a comma or both. ! ! Modified: ! ! 27 March 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) STRING, the prompt string. ! ! Output, integer VALUE1, VALUE2, the values entered by the user. ! ! Output, integer IERROR, an error flag, which is zero if no error occurred. ! implicit none ! character, parameter :: comma = ',' integer ierror integer last integer last2 character ( len = 80 ) line character, parameter :: space = ' ' character ( len = * ) string integer value1 integer value2 ! ierror = 0 value1 = huge ( value1 ) value2 = huge ( value2 ) ! ! Write the prompt. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( string ) do read ( *, '(a)', iostat = ierror ) line if ( ierror /= 0 ) then return end if ! ! If the line begins with a comment character, go back and read the next line. ! if ( line(1:1) == '#' ) then cycle end if if ( len_trim ( line ) == 0 ) then cycle end if ! ! Remove commas. ! call s_rep_ch ( line, comma, space ) ! ! Extract integer information from the string. ! call s_to_i ( line, value1, ierror, last ) if ( ierror /= 0 ) then value1 = huge ( value1 ) return end if call s_to_i ( line(last+1:), value2, ierror, last2 ) if ( ierror /= 0 ) then value2 = huge ( value2 ) return end if exit end do return end subroutine i_sqz ( ivec, idim, ibits, jvec, jdim, jbits, jwords ) ! !******************************************************************************* ! !! I_SQZ compresses the integer information in IVEC into JVEC. ! ! ! Discussion: ! ! It is assumed that a standard integer word requires IBITS bits ! and that the user requires only JBITS bits. Thus if IBITS ! is 32 and JBITS is 4, 8 'tiny' integers can be crammed into ! a single integer word. SQZINT can retrieve this information later. ! ! The input integers must lie in the range -MAX to MAX, where ! MAX = 2**(JBITS-1)-1. If we let MULT = 2**JBITS, then if integers ! A, B, C and D are input, and we are packing 4 integers to a ! word, and all four integers are positive, then the output ! integer will be ( (A*MULT+B) * MULT + C ) * MULT + D. ! Negative integers are first made positive, and then increased ! by MAX+1. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IVEC(IDIM), contains IDIM integers which ! are to be compressed. ! ! Input, integer IDIM, the number of integers to compress. ! ! Input, integer IBITS, the number of bits available in an ! integer word. Normally, this would be the word size on ! the computer used. Thus on a VAX IBITS should be 32, and ! on a Cray, 64. However, IBITS is only used to determine ! how much room there is in the output words. Using a ! number less than the machine maximum will simply result ! in some wasted space. ! ! Output, integer JVEC(JDIM), the compressed information. ! ! Input, integer JDIM, the number of words available for ! use in JVEC. ! ! Input, integer JBITS, the number of bits to use for ! numeric representation of the individual output integers. ! JBITS should be no greater than IBITS. If JBITS = IBITS, ! in fact, no compression is done at all. If ! JBITS = IBITS/2, two integers will be crammed into one ! word, and so on. ! ! Output, integer JWORDS, the number of words of JVEC that ! were actually needed to store the compressed output words. ! implicit none ! integer idim integer jdim ! integer i integer ibits integer inc integer inum integer, save :: iover = 0 integer ivec(idim) integer j integer jbits integer jnum integer jvec(jdim) integer jwords integer maxi integer mult ! inc = ibits / jbits if ( inc /= 1 ) then mult = 2**jbits else mult = 1 end if maxi = 2**(jbits-1) - 1 jwords = 0 do i = 1, idim, inc jwords = jwords + 1 jnum = 0 do j = i, i+inc-1 if ( j <= idim ) then inum = ivec(j) else inum = 0 end if if ( inum > 0 ) then if ( inum > maxi ) then inum = maxi if ( iover == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_SQZ - Warning!' write ( *, '(a,i6)' ) ' Input norm exceeds ', maxi iover = 1 end if end if else if ( inum < 0 ) then if ( inum < -maxi ) then inum = - maxi if ( iover == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_SQZ - Warning!' write ( *, '(a,i6)' ) ' Input norm exceeds ', maxi iover = 1 end if end if inum = - inum + maxi + 1 end if jnum = jnum * mult + inum end do jvec(jwords) = jnum end do return end function i_to_a ( i ) ! !******************************************************************************* ! !! I_TO_A returns the I-th alphabetic character. ! ! ! Examples: ! ! I I_TO_A ! ! -8 ' ' ! 0 ' ' ! 1 'A' ! 2 'B' ! .. ! 26 'Z' ! 27 'a' ! 52 'z' ! 53 ' ' ! 99 ' ' ! ! Modified: ! ! 23 February 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the index of the letter to be returned. ! 0 is a space; ! 1 through 26 requests 'A' through 'Z', (ASCII 65:90); ! 27 through 52 requests 'a' through 'z', (ASCII 97:122); ! ! Output, character I_TO_A, the requested alphabetic letter. ! implicit none ! integer, parameter :: cap_shift = 64 integer i character i_to_a integer, parameter :: low_shift = 96 ! if ( i <= 0 ) then i_to_a = ' ' else if ( 1 <= i .and. i <= 26 ) then i_to_a = char ( cap_shift + i ) else if ( 27 <= i .and. i <= 52 ) then i_to_a = char ( low_shift + i - 26 ) else if ( i >= 53 ) then i_to_a = ' ' end if return end subroutine i_to_amino_code ( i, c ) ! !******************************************************************************* ! !! I_TO_AMINO_CODE converts an integer to an amino code. ! ! ! Reference: ! ! Carl Branden and John Tooze, ! Introduction to Protein Structure, ! Garland Publishing, 1991. ! ! Modified: ! ! 27 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the index of an amino acid, between 1 and 23. ! ! Output, character C, the one letter code for an amino acid. ! implicit none ! integer, parameter :: n = 23 ! character c character, dimension ( n ) :: ch_table = (/ & 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'K', & 'L', 'M', 'N', 'P', 'Q', 'R', 'S', 'T', 'V', 'W', & 'X', 'Y', 'Z' /) integer i ! if ( 1 <= i .and. i <= 23 ) then c = ch_table(i) else c = '?' end if return end subroutine i_to_base ( intval, base, s ) ! !******************************************************************************* ! !! I_TO_BASE represents an integer in any base up to 16. ! ! ! Examples: ! ! Input Output ! ------------- -------- ! INTVAL BASE S ! ! 5 -1 '101010101' ! 5 1 '11111' ! 5 2 '101' ! 5 3 '12' ! 5 4 '11' ! -5 5 '-10' ! 5 6 '5' ! ! Modified: ! ! 27 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer INTVAL, the integer whose representation is desired. ! ! Input, integer BASE, the base in which the representation is ! given. BASE must be greater than 0 and no greater than 16. ! ! Output, character ( len = * ) S, the string. ! implicit none ! integer base integer i integer icopy integer idig integer intval integer jdig integer lens character ( len = * ) s ! s = ' ' lens = len ( s ) ! ! Check the base. ! if ( base < -1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_TO_BASE - Serious error!' write ( *, '(a)' ) ' The input base is less than -1!' return end if if ( base == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_TO_BASE - Serious error!' write ( *, '(a)' ) ' The input base is zero.' return end if if ( base > 16 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_TO_BASE - Serious error!' write ( *, '(a)' ) ' The input base is greater than 16!' return end if ! ! Special treatment for base 1 and -1. ! if ( base == 1 ) then call i_to_unary ( intval, s ) return else if ( base == -1 ) then call i_to_nunary ( intval, s ) return end if ! ! Do repeated mod's ! jdig = 0 icopy = abs ( intval ) do if ( ( intval >= 0 .and. jdig >= lens ) .or. & ( intval < 0 .and. jdig >= lens-1 ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_TO_BASE - Fatal error!' do i = 1, lens s(i:i) = '*' end do return end if jdig = jdig + 1 idig = mod ( icopy, base ) icopy = ( icopy - idig ) / base call digit_hex_to_ch ( idig, s(lens+1-jdig:lens+1-jdig) ) if ( icopy == 0 ) then exit end if end do ! ! Take care of the minus sign. ! if ( intval < 0 ) then jdig = jdig + 1 s(lens+1-jdig:lens+1-jdig) = '-' end if return end subroutine i_to_binary ( i, s ) ! !******************************************************************************* ! !! I_TO_BINARY produces the binary representation of an integer. ! ! ! Example: ! ! I S ! -- ------ ! 1 '1' ! 2 '10' ! 3 '11' ! 4 '100' ! -9 '-1001' ! ! Modified: ! ! 17 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, an integer to be represented. ! ! Output, character ( len = * ) S, the binary representation. ! implicit none ! integer i integer i_copy integer j character ( len = * ) s ! i_copy = abs ( i ) s = ' ' j = len ( s ) do while ( j > 0 ) if ( mod ( i_copy, 2 ) == 1 ) then s(j:j) = '1' else s(j:j) = '0' end if i_copy = i_copy / 2 if ( i_copy == 0 ) then exit end if j = j - 1 end do if ( i_copy /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_TO_BINARY - Serious error!' write ( *, '(a)' ) ' Not enough room in the string to represent the value.' end if if ( i < 0 ) then if ( j > 1 ) then j = j - 1 s(j:j) = '-' else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_TO_BINARY - Serious error!' write ( *, '(a)' ) ' No room to prefix minus sign!' end if end if return end function i_to_binhex ( i ) ! !******************************************************************************* ! !! I_TO_BINHEX returns the I-th character in the BINHEX encoding. ! ! ! Examples: ! ! I I_TO_BINHEX ! ! 1 '!' ! 2 '"' ! 3 '#' ! .. ! 64 'r' ! ! Modified: ! ! 27 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the index of the character. ! 1 <= I <= 64. ! ! Output, character I_TO_BINHEX, the requested character. ! implicit none ! integer i character i_to_binhex character ( len = 64 ), parameter :: string = & '!"#$%&''()*+,-012345689@ABCDEFGHIJKLMNPQRSTVWXYZ[`abcdefhijklmnpqr' if ( 1 <= i .and. i <= 64 ) then i_to_binhex = string(i:i) else i_to_binhex = ' ' end if return end subroutine i_to_bits ( i, s ) ! !******************************************************************************* ! !! I_TO_BITS converts an integer to a string of 32 bits. ! ! ! Modified: ! ! 29 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the value whose bit pattern is desired. ! ! Output, character ( len = 32 ) S, a string of '0' and '1' ! which should be the actual internal bit pattern for the word. ! implicit none ! integer, parameter :: nbits = 32 ! integer i integer ihi integer ii integer j integer lens integer pos character ( len = nbits ) s ! ! Get the length of the string, and blank it out. ! lens = len ( s ) s = ' ' ! ! Set the DO loop index so that we transfer no more than the number ! of bits we have, and the number of character positions available. ! ihi = min ( nbits-1, lens-1 ) ! ! Translate one bit at a time into a character. ! do ii = 0, ihi pos = nbits - 1 - ii j = ii + 1 if ( btest ( i, pos ) ) then s(j:j) = '1' else s(j:j) = '0' end if end do return end subroutine i_to_ch4 ( i, ch4 ) ! !******************************************************************************* ! !! I_TO_CH4 converts an integer to a 4 character string. ! ! ! Modified: ! ! 28 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the integer value. ! ! Output, character ( len = 4 ) CH4, a corresponding character value. ! implicit none ! character ( len = 4 ) ch4 integer i ! write ( ch4, '(a4)' ) i return end subroutine i_to_hex ( i, s ) ! !******************************************************************************* ! !! I_TO_HEX produces the hexadecimal representation of an integer. ! ! ! Examples: ! ! I S ! --- --- ! 0 '0' ! 9 '9' ! 10 'A' ! 15 'F' ! 16 '10' ! 100 '64' ! -12 '-C' ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the integer to be represented. ! ! Output, character ( len = * ) S, the hexadecimal representation. ! implicit none ! integer i integer i1 integer ichr integer intcpy integer isgn integer nchar character ( len = * ) s ! nchar = len ( s ) intcpy = i isgn = 1 if ( intcpy < 0 ) then isgn = - 1 intcpy = - intcpy end if s = ' ' ! ! Point to the position just after the end of the string. ! ichr = nchar + 1 ! ! Moving left, fill in the next digit of the string. ! do ichr = ichr - 1 if ( ichr <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_TO_HEX - Serious error!' write ( *, '(a)' ) ' Ran out of room in the string!' return end if i1 = mod ( intcpy, 16 ) intcpy = intcpy / 16 call digit_hex_to_ch ( i1, s(ichr:ichr) ) if ( intcpy == 0 ) then if ( isgn == -1 ) then if ( ichr > 1 ) then ichr = ichr - 1 s(ichr:ichr) = '-' else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_TO_HEX - Serious error!' write ( *, '(a)' ) ' No room to prefix minus sign!' end if end if return end if end do return end subroutine i_to_month_name ( m, month_name ) ! !******************************************************************************* ! !! I_TO_MONTH_NAME returns the name of a given month. ! ! ! Modified: ! ! 12 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the number of the month, which should ! be between 1 and 12. ! ! Output, character ( len = * ) MONTH_NAME, a string containing as much of the ! month's name as will fit. To get the typical 3-letter abbreviations ! for the months, simply declare ! character ( len = 3 ) MONTH_NAME ! or pass in MONTH_NAME(1:3). ! implicit none ! integer i integer lens integer m character ( len = * ) month_name character ( len = 9 ), parameter, dimension(12) :: name = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) ! if ( m < 1 .or. m > 12 ) then do i = 1, len ( month_name ) month_name(i:i) = '?' end do else month_name = name(m) end if return end subroutine i_to_nunary ( intval, s ) ! !******************************************************************************* ! !! I_TO_NUNARY produces the "base -1" representation of an integer. ! ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer INTVAL, an integer to be represented. ! ! Output, character ( len = * ) S, the negative unary representation. ! implicit none ! integer i integer intval character ( len = * ) s ! s = ' ' if ( intval < 0 ) then do i = 1, abs ( intval ) s(2*i-1:2*i) = '10' end do else if ( intval == 0 ) then s = '0' else if ( intval > 0 ) then s(1:1) = '1' do i = 2, intval s(2*i-2:2*i-1) = '01' end do end if s = adjustr ( s ) return end subroutine i_to_oct ( i, s ) ! !******************************************************************************* ! !! I_TO_OCT produces the octal representation of an integer. ! ! ! Examples: ! ! INTVAL S ! 0 '0' ! 9 '11' ! 10 '12' ! 15 '17' ! 16 '20' ! 100 '144' ! -12 '-14' ! ! Modified: ! ! 07 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the integer to be represented. ! ! Output, character ( len = * ) S, the octal representation. ! implicit none ! integer i integer i1 integer ichr integer intcpy integer isgn integer nchar character ( len = * ) s ! nchar = len ( s ) intcpy = i isgn = 1 if ( intcpy < 0 ) then isgn = - 1 intcpy = - intcpy end if s = ' ' ! ! Point to the position just after the end of the string. ! ichr = nchar + 1 ! ! Moving left, fill in the next digit of the string. ! do ichr = ichr - 1 if ( ichr <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_TO_OCT - Serious error!' write ( *, '(a)' ) ' Ran out of room in the string!' return end if i1 = mod ( intcpy, 8 ) intcpy = intcpy / 8 call digit_oct_to_ch ( i1, s(ichr:ichr) ) if ( intcpy == 0 ) then if ( isgn == -1 ) then if ( ichr > 1 ) then ichr = ichr - 1 s(ichr:ichr) = '-' else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_TO_OCT - Serious error!' write ( *, '(a)' ) ' No room to prefix minus sign!' end if end if return end if end do return end subroutine i_to_s_left ( intval, s ) ! !******************************************************************************* ! !! I_TO_S_LEFT converts an integer to a left-justified string. ! ! ! Examples: ! ! Assume that S is 6 characters long: ! ! INTVAL S ! ! 1 1 ! -1 -1 ! 0 0 ! 1952 1952 ! 123456 123456 ! 1234567 ****** <-- Not enough room! ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer INTVAL, an integer to be converted. ! ! Output, character ( len = * ) S, the representation of the integer. ! The integer will be left-justified. If there is not enough space, ! the string will be filled with stars. ! implicit none ! character c integer i integer idig integer ihi integer ilo integer intval integer ipos integer ival character ( len = * ) s ! s = ' ' ilo = 1 ihi = len ( s ) if ( ihi <= 0 ) then return end if ! ! Make a copy of the integer. ! ival = intval ! ! Handle the negative sign. ! if ( ival < 0 ) then if ( ihi <= 1 ) then s(1:1) = '*' return end if ival = - ival s(1:1) = '-' ilo = 2 end if ! ! The absolute value of the integer goes into S(ILO:IHI). ! ipos = ihi ! ! Find the last digit of IVAL, strip it off, and stick it into the string. ! do idig = mod ( ival, 10 ) ival = ival / 10 if ( ipos < ilo ) then do i = 1, ihi s(i:i) = '*' end do return end if call digit_to_ch ( idig, c ) s(ipos:ipos) = c ipos = ipos - 1 if ( ival == 0 ) then exit end if end do ! ! Shift the string to the left. ! s(ilo:ilo+ihi-ipos-1) = s(ipos+1:ihi) s(ilo+ihi-ipos:ihi) = ' ' return end subroutine i_to_s_right ( intval, s ) ! !******************************************************************************* ! !! I_TO_S_RIGHT converts an integer to a right justified string. ! ! ! Examples: ! ! Assume that S is 6 characters long: ! ! INTVAL S ! ! 1 1 ! -1 -1 ! 0 0 ! 1952 1952 ! 123456 123456 ! 1234567 ****** <-- Not enough room! ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer INTVAL, an integer to be converted. ! ! Output, character ( len = * ) S, the representation of the integer. ! The integer will be right-justified. If there is not enough space, ! the string will be filled with stars. ! implicit none ! character c integer i integer idig integer ihi integer ilo integer intval integer ipos integer ival character ( len = * ) s ! s = ' ' ilo = 1 ihi = len ( s ) if ( ihi <= 0 ) then return end if ! ! Make a copy of the integer. ! ival = intval ! ! Handle the negative sign. ! if ( ival < 0 ) then if ( ihi <= 1 ) then s(1:1) = '*' return end if ival = - ival s(1:1) = '-' ilo = 2 end if ! ! The absolute value of the integer goes into S(ILO:IHI). ! ipos = ihi ! ! Find the last digit of IVAL, strip it off, and stick it into the string. ! do idig = mod ( ival, 10 ) ival = ival / 10 if ( ipos < ilo ) then do i = 1, ihi s(i:i) = '*' end do return end if call digit_to_ch ( idig, c ) s(ipos:ipos) = c ipos = ipos - 1 if ( ival == 0 ) then exit end if end do ! ! Shift the minus sign, if any. ! if ( s(1:1) == '-' ) then if ( ipos /= 1 ) then s(1:1) = ' ' s(ipos:ipos) = '-' end if end if return end subroutine i_to_s_roman ( intval, s ) ! !******************************************************************************* ! !! I_TO_S_ROMAN converts an integer to a string of Roman numerals. ! ! ! Examples: ! ! INTVAL S ! ! -2 -II <-- Not a Roman numeral ! -1 -I <-- Not a Roman numeral ! 0 0 <-- Not a Roman numeral ! 1 I ! 2 II ! 3 III ! 4 IV ! 5 V ! 10 X ! 20 XX ! 30 XXX ! 40 XL ! 50 L ! 60 LX ! 70 LXX ! 80 LXXX ! 90 XC ! 100 C ! 500 D ! 1000 M ! 4999 MMMMCMLXLIX ! ! Discussion: ! ! To generate numbers greater than 4999, the numeral 'V' had a bar ! above it, representing a value of 5000, a barred 'X' represented ! 10,000 and so on. ! ! In the subtractive representation of 4 by 'IV', 9 by 'IX' and so on, ! 'I' can only subtract from 'V' or 'X', ! 'X' can only subtract from 'L' or 'C', ! 'C' can only subtract from 'D' or 'M'. ! Under these rules, 1999 cannot be written IMM! ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer INTVAL, an integer to be converted. If the integer ! has absolute value greater than 4999, the string '?' will be returned. ! If the integer is 0, then the string '0' will be returned. If ! the integer is negative, then a minus sign will precede it, even ! though this has nothing to do with Roman numerals. ! ! Output, character ( len = * ) S, the representation of the integer ! as a Roman numeral. ! implicit none ! integer icopy integer intval character ( len = * ) s ! s = ' ' icopy = intval if ( abs ( icopy ) > 4999 ) then s = '?' return end if if ( icopy == 0 ) then s = '0' return end if if ( icopy <= 0 ) then s = '-' icopy = - icopy end if do while ( icopy > 0 ) if ( icopy >= 1000 ) then call s_cat ( s, 'M', s ) icopy = icopy - 1000 else if ( icopy >= 900 ) then call s_cat ( s, 'CM', s ) icopy = icopy - 900 else if ( icopy >= 500 ) then call s_cat ( s, 'D', s ) icopy = icopy - 500 else if ( icopy >= 400 ) then call s_cat ( s, 'CD', s ) icopy = icopy - 400 else if ( icopy >= 100 ) then call s_cat ( s, 'C', s ) icopy = icopy - 100 else if ( icopy >= 90 ) then call s_cat ( s, 'XC', s ) icopy = icopy - 90 else if ( icopy >= 50 ) then call s_cat ( s, 'L', s ) icopy = icopy - 50 else if ( icopy >= 40 ) then call s_cat ( s, 'XL', s ) icopy = icopy - 40 else if ( icopy >= 10 ) then call s_cat ( s, 'X', s ) icopy = icopy - 10 else if ( icopy >= 9 ) then call s_cat ( s, 'IX', s ) icopy = icopy - 9 else if ( icopy >= 5 ) then call s_cat ( s, 'V', s ) icopy = icopy - 5 else if ( icopy >= 4 ) then call s_cat ( s, 'IV', s ) icopy = icopy - 4 else call s_cat ( s, 'I', s ) icopy = icopy - 1 end if end do return end subroutine i_to_s_zero ( intval, s ) ! !******************************************************************************* ! !! I_TO_S_ZERO converts an integer to a string, with zero padding. ! ! ! Examples: ! ! Assume that S is 6 characters long: ! ! INTVAL S ! ! 1 000001 ! -1 -00001 ! 0 000000 ! 1952 001952 ! 123456 123456 ! 1234567 ****** <-- Not enough room! ! ! Modified: ! ! 04 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer INTVAL, an integer to be converted. ! ! Output, character ( len = * ) S, the representation of the integer. ! The integer will be right justified, and zero padded. ! If there is not enough space, the string will be filled with stars. ! implicit none ! character c integer i integer idig integer ihi integer ilo integer intval integer ipos integer ival character ( len = * ) s ! s = ' ' ilo = 1 ihi = len ( s ) if ( ihi <= 0 ) then return end if ! ! Make a copy of the integer. ! ival = intval ! ! Handle the negative sign. ! if ( ival < 0 ) then if ( ihi <= 1 ) then s(1:1) = '*' return end if ival = - ival s(1:1) = '-' ilo = 2 end if ! ! Working from right to left, strip off the digits of the integer ! and place them into S(ILO:IHI). ! ipos = ihi do while ( ival /= 0 .or. ipos == ihi ) idig = mod ( ival, 10 ) ival = ival / 10 if ( ipos < ilo ) then do i = 1, ihi s(i:i) = '*' end do return end if call digit_to_ch ( idig, c ) s(ipos:ipos) = c ipos = ipos - 1 end do ! ! Fill the empties with zeroes. ! do i = ilo, ipos s(i:i) = '0' end do return end function i_to_s32 ( ival ) ! !******************************************************************************* ! !! I_TO_S32 converts an integer to a 32 character string. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IVAL, the integer to be coded. ! ! Output, character ( len = 32 ) I_TO_S32, the character variable that ! corresponds to the integer. ! implicit none ! character ( len = 32 ) chr32 integer i character ( len = 32 ) i_to_s32 integer icopy integer ival ! icopy = abs ( ival ) ! ! Sign bit ! chr32(1:1) = '0' ! ! Binary digits: ! do i = 32, 2, -1 if ( mod ( icopy, 2 ) == 1 ) then chr32(i:i) = '1' else chr32(i:i) = '0' end if icopy = icopy / 2 end do ! ! If original number was negative, then reverse all bits. ! if ( ival < 0 ) then do i = 1, 32 if ( chr32(i:i) == '0' ) then chr32(i:i) = '1' else chr32(i:i) = '0' end if end do end if i_to_s32 = chr32 return end subroutine i_to_unary ( intval, s ) ! !******************************************************************************* ! !! I_TO_UNARY produces the "base 1" representation of an integer. ! ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer INTVAL, an integer to be represented. ! ! Output, character ( len = * ) S, the unary representation. ! implicit none ! integer i integer intval integer nchar character ( len = * ) s ! nchar = len ( s ) s = ' ' if ( intval < 0 ) then if ( nchar < intval+1 ) then s = '?' return end if s(1:1) = '-' do i = 2, abs ( intval ) + 1 s(i:i) = '1' end do else if ( intval == 0 ) then s = '0' else if ( intval > 0 ) then if ( nchar < intval ) then s = '?' return end if do i = 1, intval s(i:i) = '1' end do end if s = adjustr ( s ) return end function i_to_uudecode ( i ) ! !******************************************************************************* ! !! I_TO_UUDECODE returns the I-th character in the UUDECODE encoding. ! ! ! Examples: ! ! I I_TO_UUDECODE ! ! 1 '`' ! 2 '!' ! 3 '"' ! .. ! 64 '_' ! ! Modified: ! ! 27 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the index of the character. ! 1 <= I <= 64. ! ! Output, character I_TO_UUDECODE, the requested character. ! implicit none ! integer i character i_to_uudecode character ( len = 64 ), parameter :: string = & '`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_' if ( 1 <= i .and. i <= 64 ) then i_to_uudecode = string(i:i) else i_to_uudecode = ' ' end if return end function i_to_xxdecode ( i ) ! !******************************************************************************* ! !! I_TO_XXDECODE returns the I-th character in the XXDECODE encoding. ! ! ! Examples: ! ! I I_TO_UUDECODE ! ! 1 '+' ! 2 '-' ! 3 '0' ! .. ! 64 'z' ! ! Modified: ! ! 27 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the index of the character. ! 1 <= I <= 64. ! ! Output, character I_TO_XXDECODE, the requested character. ! implicit none ! integer i character i_to_xxdecode character ( len = 64 ), parameter :: string = & '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' if ( 1 <= i .and. i <= 64 ) then i_to_xxdecode = string(i:i) else i_to_xxdecode = ' ' end if return end subroutine i2_byte_swap ( iword, bytes ) ! !******************************************************************************* ! !! I2_BYTE_SWAP swaps bytes in an 8-byte word. ! ! ! Discussion: ! ! This routine uses the MVBITS routines to carry out the swaps. The ! relationship between the bits in the word (0 through 63) and the ! bytes (1 through 8) is machine dependent. That is, byte 1 may ! comprise bits 0 through 7, or bits 56 through 63. So some ! experimentation may be necessary the first time this routine ! is used. ! ! This routine was originally written simply to take the drudgery ! out of swapping bytes in a VAX word that was to be read by ! another machine. ! ! The statement ! ! call i2_byte_swap ( IWORD, (/ 1, 2, 3, 4, 5, 6, 7, 8 /) ) ! ! will do nothing to IWORD, and ! ! call i2_byte_swap ( IWORD, (/ 8, 7, 6, 5, 4, 3, 2, 1 /) ) ! ! will reverse the bytes in IWORD, and ! ! call i2_byte_swap ( IWORD, (/ 2, 2, 2, 2, 2, 2, 2, 2 /) ) ! ! will replace IWORD with a word containing byte(2) repeated 8 times. ! ! Modified: ! ! 28 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer IWORD, the word whose bits are to be swapped. ! ! Input, integer BYTES(8), indicates which byte in the input word ! should overwrite each byte of the output word. ! implicit none ! integer, parameter :: NUM_BYTES = 8 ! integer bytes(NUM_BYTES) integer i integer iword integer jword ! jword = iword do i = 1, NUM_BYTES if ( bytes(i) < 1 .or. bytes(i) > NUM_BYTES ) then cycle end if if ( bytes(i) == i ) then cycle end if call mvbits ( jword, (bytes(i)-1)*8, 8, iword, 0 ) end do return end function ic_to_ibraille ( ic ) ! !******************************************************************************* ! !! IC_TO_IBRAILLE converts an ASCII integer code to a Braille code. ! ! ! Modified: ! ! 02 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IC, the integer code for the ASCII character. ! ! Output, integer IC_TO_BRAILLE, the integer code for the Braille character, ! or -1 if no corresponding code is available. ! implicit none ! integer i integer ic integer ic_to_ibraille integer, parameter, dimension ( 0:255 ) :: junk = (/ & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & 1, 33, 35, -1, -1, -1, 28, 36, 34, 34, -1, -1, 29, 37, 32, -1, & 11, 02, 04, 05, 06, 07, 08, 09, 10, -1, 31, 30, -1, -1, -1, 35, & -1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, & 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, -1, -1, -1, -1, -1, & -1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, & 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1 /) ! ic_to_ibraille = junk(ic) return end function ic_to_iebcdic ( ic ) ! !******************************************************************************* ! !! IC_TO_IEBCDIC converts an ASCII character code to an EBCDIC code. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IC, the integer code for the ASCII character. ! ! Output, integer IC_TO_IEBCDIC, the integer code for the EBCDIC character, ! or -1 if no corresponding EBCDIC code is available. ! implicit none ! integer i integer ic integer ic_to_iebcdic integer, parameter, dimension ( 0:255 ) :: junk = (/ & 0, 1, 2, 3, 56, 45, 46, 47, 22, 5, 37, 11, 12, 13, 60, 61, & 16, 17, 18, -1, -1, -1, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31, & 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, -1, 97, & 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111, & 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214, & 215,216,217,226,227,228,229,230,231,232,233, -1, -1, -1, -1,109, & -1,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150, & 151,152,153,162,163,164,165,166,167,168,169, -1, 79, -1, -1, 7, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1 /) ! ic_to_iebcdic = junk(ic) return end function ic_to_imorse ( ic ) ! !******************************************************************************* ! !! IC_TO_IMORSE converts an ASCII integer code to a Morse integer code. ! ! ! Modified: ! ! 26 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IC, the integer code for the ASCII character. ! ! Output, integer IC_TO_IMORSE, the integer code for the Morse character, ! or -1 if no corresponding Morse code is available. ! implicit none ! integer i integer ic integer ic_to_imorse integer, parameter, dimension ( 0:255 ) :: junk = (/ & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & 1, -1, 45, -1, -1, -1, -1, 42, -1, -1, -1, -1, 39, 43, 38, 44, & 37, 28, 29, 30, 31, 32, 33, 34, 35, 36, 40, -1, -1, -1, -1, 41, & -1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, & 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, -1, -1, -1, -1, -1, & -1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, & 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1 /) ! ic_to_imorse = junk(ic) return end function ic_to_isoundex ( ic ) ! !******************************************************************************* ! !! IC_TO_ISOUNDEX converts an ASCII integer code to a Soundex integer code. ! ! ! Modified: ! ! 05 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IC, the integer code for the ASCII character. ! ! Output, integer IC_TO_ISOUNDEX, the integer code for the Soundex character, ! or -1 if no corresponding Soundex code is available. ! implicit none ! integer i integer ic integer ic_to_isoundex integer, parameter, dimension ( 0:255 ) :: junk = (/ & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, 48, 49, 50, 51, 48, 49, 50, 48, 48, 50, 50, 52, 53, 53, 48, & 49, 50, 54, 50, 51, 48, 49, 48, 50, 48, 50, -1, -1, -1, -1, -1, & -1, 48, 49, 50, 51, 48, 49, 50, 48, 48, 50, 50, 52, 53, 53, 48, & 49, 50, 54, 50, 51, 48, 49, 48, 50, 48, 50, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1 /) ! ic_to_isoundex = junk(ic) return end function iebcdic_to_ic ( ival ) ! !******************************************************************************* ! !! IEBCDIC_TO_IC converts an EBCDIC character code to ASCII. ! ! ! Discussion: ! ! What this actually means is the following: ! ! If the letter "A" is entered into a file on an EBCDIC machine, ! it is coded internally as character 193. Should this character ! be read on an ASCII machine, it will not be displayed as "A", ! but rather as an unprintable character! But passing 193 in to ! IEBCDIC_TO_IC, out will come 65, the ASCII code for "A". Thus, the ! correct character to display on an ASCII machine is ! ! CHAR ( ICHAR ( IEBCDIC_TO_IC ( EBCDIC Character ) ) ). ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IVAL, the integer code for the EBCDIC character. ! ! Output, integer IEBCDIC_TO_IC, the integer code for the ASCII character, ! or -1 if no corresponding ASCII code is available. ! implicit none ! integer i integer iebcdic_to_ic integer ival integer, parameter, dimension ( 0:255 ) :: junk = (/ & 0, 1, 2, 3, -1, 9, -1,127, -1, -1, -1, 11, 12, 13, 14, 15, & 16, 17, 18, -1, -1, -1, 8, -1, 24, 25, -1, -1, 28, 29, 30, 31, & -1, -1, -1, -1, -1, 10, 23, 27, -1, -1, -1, -1, -1, 5, 6, 7, & -1, -1, 22, -1, -1, -1, -1, -1, 4, -1, -1, -1, 14, 15, -1, 26, & 32, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 60, 40, 43,124, & 38, -1, -1, -1, -1, -1, -1, -1, -1, -1, 33, 36, 42, 41, 59, -1, & 45, 47, -1, -1, -1, -1, -1, -1, -1, -1, -1, 44, 37, 95, 62, 63, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 58, 35, 64, 39, 61, 34, & -1, 97, 98, 99,100,101,102,103,104,105, -1, -1, -1, -1, -1, -1, & -1,106,107,108,109,110,111,112,113,114, -1, -1, -1, -1, -1, -1, & -1, -1,115,116,117,118,119,120,121,122, -1, -1, -1, -1, -1, -1, & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & -1, 65, 66, 67, 68, 69, 70, 71, 72, 73, -1, -1, -1, -1, -1, -1, & -1, 74, 75, 76, 77, 78, 79, 80, 81, 82, -1, -1, -1, -1, -1, -1, & -1, -1, 83, 84, 85, 86, 87, 88, 89, 90, -1, -1, -1, -1, -1, -1, & 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, -1, -1, -1, -1, -1, -1 /) ! iebcdic_to_ic = junk(ival) return end function istrcmp ( s1, s2 ) ! !******************************************************************************* ! !! ISTRCMP compares two strings, returning +1, 0, or -1. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, S2, the strings to be compared. ! ! Output, integer ISTRCMP: ! -1 if S1 < S2, ! 0 if S1 = S2 ! +1 if S1 > S2. ! implicit none ! integer istrcmp integer nchar integer nchar1 integer nchar2 character ( len = * ) s1 character ( len = * ) s2 ! nchar1 = len ( s1 ) nchar2 = len ( s2 ) nchar = min ( nchar1, nchar2 ) if ( llt ( s1(1:nchar), s2(1:nchar) ) ) then istrcmp = - 1 else if ( llt ( s2(1:nchar), s1(1:nchar) ) ) then istrcmp = 1 else if ( s1(1:nchar) == s2(1:nchar) ) then if ( nchar1 == nchar2 ) then istrcmp = 0 else if ( nchar1 < nchar2 ) then istrcmp = -1 else istrcmp = 1 end if end if return end function istrncmp ( s1, s2, nchar ) ! !******************************************************************************* ! !! ISTRNCMP compares the start of two strings, returning +1, 0, or -1. ! ! ! Discussion: ! ! If either string is shorter than NCHAR characters, then it is ! treated as though it were padded with blanks. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, S2, the strings to be compared. ! ! Input, integer NCHAR, the number of characters to be compared. ! ! Output, integer ISTRNCMP: ! +1 if S1(1:NCHAR) is lexically greater than S2(1:NCHAR), ! 0 if they are equal, and ! -1 if S1(1:NCHAR) is lexically less than S2(1:NCHAR). ! implicit none ! character c1 character c2 integer i integer istrncmp integer nchar integer nchar1 integer nchar2 character ( len = * ) s1 character ( len = * ) s2 ! ! Figure out the maximum number of characters we will examine, ! which is the minimum of NCHAR and the lengths of the two ! strings. ! istrncmp = 0 nchar1 = len ( s1 ) nchar2 = len ( s2 ) do i = 1, nchar if ( i <= nchar1 ) then c1 = s1(i:i) else c1 = ' ' end if if ( i <= nchar2 ) then c2 = s2(i:i) else c2 = ' ' end if if ( llt ( c1, c2 ) ) then istrncmp = - 1 return else if ( lgt ( c1, c2 ) ) then istrncmp = 1 return end if end do return end subroutine ivec_print ( n, a, title ) ! !******************************************************************************* ! !! IVEC_PRINT prints an integer vector. ! ! ! Modified: ! ! 28 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, integer A(N), the vector to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none ! integer n ! integer a(n) integer big integer i character ( len = * ) title ! if ( title /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if big = maxval ( abs ( a(1:n) ) ) write ( *, '(a)' ) ' ' if ( big < 1000 ) then do i = 1, n write ( *, '(i6,1x,i4)' ) i, a(i) end do else if ( big < 1000000 ) then do i = 1, n write ( *, '(i6,1x,i7)' ) i, a(i) end do else do i = 1, n write ( *, '(i6,i11)' ) i, a(i) end do end if return end subroutine ivec_to_ch4vec ( n, ivec, s ) ! !******************************************************************************* ! !! IVEC_TO_CH4VEC converts an array of integers into a string. ! ! ! Discussion: ! ! This routine can be useful when trying to read character data from an ! unformatted direct access file, for instance. ! ! Modified: ! ! 27 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of integers. ! ! Input, integer IVEC(N), the integers. ! ! Output, character ( len = * ) S, a string of 4 * N characters ! representing the integer information. ! implicit none ! integer n ! integer i integer ivec(n) integer j integer len_s character ( len = * ) s ! len_s = len ( s ) if ( len_s < 4 * n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IVEC_TO_CH4VEC - Fatal error!' write ( *, '(a)' ) ' String S is too small for the data.' stop end if s(1:4*n) = ' ' do i = 1, n j = 4 * ( i - 1 ) + 1 call i_to_ch4 ( ivec(i), s(j:j+3) ) end do return end subroutine left ( s1, s2 ) ! !******************************************************************************* ! !! LEFT inserts one string flush left into another. ! ! ! Discussion: ! ! S2 is not blanked out first. Therefore, if there is ! already information in S2, some of it may still be around ! after S1 is written into S2. Users may want to first ! assign S2 = ' ' if this is not the effect desired. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, a string to be inserted into S2. Only ! the portion of S1 up to the last nonblank will be used. ! ! Output, character ( len = * ) S2, a string which will contain, ! on output, a left flush copy of S1. ! implicit none ! integer ihi integer ilo integer jhi integer jlo integer len1 integer len2 character ( len = * ) s1 character ( len = * ) s2 ! len1 = len_trim ( s1 ) len2 = len ( s2 ) if ( len1 < len2 ) then ilo = 1 ihi = len1 jlo = 1 jhi = len1 else if ( len1 > len2 ) then ilo = 1 ihi = len2 jlo = 1 jhi = len2 else ilo = 1 ihi = len1 jlo = 1 jhi = len2 end if s2(jlo:jhi) = s1(ilo:ihi) return end function len_nonnull ( s ) ! !******************************************************************************* ! !! LEN_NONNULL returns the length of a string up to the last non-null character. ! ! ! Modified: ! ! 26 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to measure. ! ! Output, integer LEN_NONNULL, the length of the string, up to the last ! non-null character. ! implicit none ! integer i integer len_nonnull integer len_s character, parameter :: NULL = char ( 0 ) character ( len = * ) s ! len_s = len ( s ) do i = len_s, 1, -1 if ( s(i:i) /= NULL ) then len_nonnull = i return end if end do len_nonnull = 0 return end function lower ( s ) ! !******************************************************************************* ! !! LOWER returns a lowercase version of a string. ! ! ! Discussion: ! ! LOWER is a string function of undeclared length. The length ! of the argument returned is determined by the declaration of ! LOWER in the calling routine. ! ! Modified: ! ! 11 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string. ! ! Output, character ( len = * ) LOWER, a lowercase copy of the string. ! implicit none ! integer i integer j character ( len = * ) lower integer n character ( len = * ) s ! lower = s n = len_trim ( lower ) do i = 1, n j = ichar ( lower(i:i) ) if ( 65 <= j .and. j <= 90 ) then lower(i:i) = char ( j + 32 ) end if end do return end function malphnum2 ( s ) ! !******************************************************************************* ! !! MALPHNUM2 returns .TRUE. if a string contains only alphanumerics and underscores. ! ! ! Discussion: ! ! Alphanumeric characters are 'A' through 'Z', 'a' through 'z', ! '0' through '9' and the underscore character. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be checked. ! ! Output, logical MALPHNUM2, .TRUE. if the string contains only ! alphabetic characters, numerals, and underscores, .FALSE. ! otherwise. ! implicit none ! integer i integer itemp logical malphnum2 character ( len = * ) s ! malphnum2 = .false. do i = 1, len ( s ) if ( s(i:i) /= '_' ) then itemp = ichar ( s(i:i) ) if ( .not. ( itemp >= 65 .and. itemp <= 90 ) ) then if ( .not. ( itemp >= 97 .and. itemp <= 122 ) ) then if ( .not. ( itemp >= 48 .and. itemp <= 57 ) ) then return end if end if end if end if end do malphnum2 = .true. return end subroutine military_to_ch ( military, c ) ! !******************************************************************************* ! !! MILITARY_TO_CH converts a Military code word to an ASCII character. ! ! ! Example: ! ! 'Alpha' 'A' ! 'Bravo' 'B' ! 'Zulu' 'Z' ! 'alpha' 'a' ! '7' '7' ! '%' '%' ! 'Adam' 'A' ! 'Anthrax' 'A' ! 'amoeba' 'a' ! ! Modified: ! ! 07 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = 8 ) MILITARY, the military code word. ! ! Output, character C, the ASCII character. If MILITARY was not ! a recognized military code word, then C is set to MILITARY(1:1). ! implicit none ! integer a_to_i character c character ( len = 8 ), dimension ( 26 ) :: code = (/ & 'alpha ', 'bravo ', 'charlie ', 'delta ', 'echo ', & 'foxtrot ', 'golf ', 'hotel ', 'india ', 'juliet ', & 'kilo ', 'lima ', 'mike ', 'november', 'oscar ', & 'papa ', 'quebec ', 'romeo ', 'sierra ', 'tango ', & 'uniform ', 'victor ', 'whiskey ', 'x-ray ', 'yankee ', & 'zulu ' /) integer i character ( len = * ) military logical s_eqi ! c = military(1:1) i = a_to_i ( c ) if ( 1 <= i .and. i <= 26 ) then if ( s_eqi ( military, code(i) ) ) then c = military(1:1) end if else if ( 27 <= i .and. i <= 52 ) then if ( s_eqi ( military, code(i-26) ) ) then c = military(1:1) end if end if return end subroutine month_name_to_i ( month_name, month ) ! !******************************************************************************* ! !! MONTH_NAME_TO_I returns the month number of a given month ! ! ! Discussion: ! ! Capitalization is ignored. The month name has to match up to ! the unique beginning of a month name, and the rest is ignored. ! Here are the limits: ! ! JAnuary ! February ! MARch ! APril ! MAY ! JUNe ! JULy ! AUgust ! September ! October ! November ! December ! ! Modified: ! ! 06 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) MONTH_NAME, a string containing a month ! name or abbreviation. ! ! Output, integer MONTH, the number of the month, or -1 if the name ! could not be recognized. ! implicit none ! integer month character ( len = * ) month_name character ( len = 3 ) string ! string = month_name call s_cap ( string ) if ( string(1:2) == 'JA' ) then month = 1 else if ( string(1:1) == 'F' ) then month = 2 else if ( string(1:3) == 'MAR' ) then month = 3 else if ( string(1:2) == 'AP' ) then month = 4 else if ( string(1:3) == 'MAY' ) then month = 5 else if ( string(1:3) == 'JUN' ) then month = 6 else if ( string(1:3) == 'JUL' ) then month = 7 else if ( string(1:2) == 'AU' ) then month = 8 else if ( string(1:1) == 'S' ) then month = 9 else if ( string(1:1) == 'O' ) then month = 10 else if ( string(1:1) == 'N' ) then month = 11 else if ( string(1:1) == 'D' ) then month = 12 else month = - 1 end if return end subroutine namefl ( s ) ! !******************************************************************************* ! !! NAMEFL replaces "lastname, firstname" by "firstname lastname". ! ! ! Discussion: ! ! As part of the process, all commas and double blanks are ! removed, and the first character of the output string is ! never a blank. ! ! A one-word name is left unchanged. ! ! Examples: ! ! Input Output ! ! Brown, Charlie Charlie Brown ! Cher Cher ! Howell, James Thurston James Thurston Howell ! Shakespeare Joe Bob Joe Bob Shakespeare ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S. ! ! On input, a series of words separated by spaces. ! ! On output, if S contained a single word, it is ! unchanged. Otherwise, the first word has been moved ! to the end of S, and any trailing comma removed. ! ! As part of this process, all double blanks are removed ! from S, and the output S never begins with ! a blank (unless the input S was entirely blank). ! ! Any commas in the input string are deleted. ! ! This routine cannot handle more than 256 characters in S. ! implicit none ! character ( len = 256 ) s2 integer i integer lens character ( len = * ) s ! s2 = ' ' ! ! Remove all commas. ! lens = len_trim ( s ) do i = 1, lens if ( s(i:i) == ',') then s(i:i) = ' ' end if end do ! ! Remove double blanks. ! This also guarantees the string is flush left. ! call s_blanks_delete ( s ) ! ! Get length of string. ! lens = len_trim ( s ) if ( lens <= 2 ) then return end if if ( lens > 256 ) then lens = len_trim ( s(1:256) ) end if ! ! Find the first blank in the string. ! do i = 2, lens-1 if ( s(i:i) == ' ' ) then s2(1:lens-i) = s(i+1:lens) s2(lens-i+1:lens-i+1) = ' ' s2(lens-i+2:lens) = s(1:i-1) s = s2(1:lens) end if end do return end subroutine namelf ( s ) ! !******************************************************************************* ! !! NAMELF replaces "firstname lastname" by "lastname, firstname". ! ! ! Discussion: ! ! A one-word name is left unchanged. ! ! Examples: ! ! Input: Output: ! ! Charlie Brown Brown, Charlie ! Cher Cher ! James Thurston Howell Howell, James Thurston ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S. ! ! On input, S contains a series of words separated by spaces. ! ! On output, if S contained a single word, it is ! unchanged. Otherwise, the last word has been moved ! to the beginning of S, and followed by a comma. ! ! As part of this process, all double blanks are removed ! from S, and the output S never begins with ! a blank (unless the input S was entirely blank). ! ! Moreover, any commas in the input string are deleted. ! ! This routine cannot handle more than 256 characters ! in S. If S is longer than that, only the ! first 256 characters will be considered. ! implicit none ! character ( len = 256 ) s2 integer i integer lens character ( len = * ) s ! s2 = ' ' ! ! Remove all commas. ! lens = len_trim ( s ) do i = 1, lens if ( s(i:i) == ',' ) then s(i:i) = ' ' end if end do ! ! Remove all double blanks, and make string flush left. ! call s_blanks_delete ( s ) ! ! Get length of string. ! lens = len_trim ( s ) if ( lens <= 2 ) then return end if if ( lens > 256 ) then lens = len_trim ( s(1:256) ) end if ! ! Find the last blank in the string. ! do i = lens, 2, -1 if ( s(i:i) == ' ' ) then s2(1:lens-i) = s(i+1:lens) s2(lens-i+1:lens-i+2) = ', ' s2(lens-i+3:lens+1) = s(1:i-1) s = s2(1:lens+1) end if end do return end subroutine namels ( name, ierror, rhs, value ) ! !******************************************************************************* ! !! NAMELS reads a NAMELIST line, returning the variable name and value. ! ! ! Discussion: ! ! NAMELS is a simple program, and can only handle simple input. ! In particular, it cannot handle: ! ! multiple assignments on one line, ! a single assignment extended over multiple lines, ! assignments to character or complex variables, ! assignments to arrays. ! ! Typical input would be of the form: ! ! name = value ! ! including, for instance: ! ! a = 1.0 ! n = -17 ! scale = +5.3E-2 ! ! Spaces are ignored, and case is not important. Integer values ! will be returned as real, but this is never a ! problem as long as the integers are "small". ! ! If a line begins with the character "#", it is assumed to be ! a comment, and is ignored. IERROR is returned as 6. ! ! If a line begins with the characters "end-of-input", it is ! assumed to be an "end-of-input" marker, and IERROR is returned ! as 7. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) NAME. ! ! NAME contains the left hand side of the assignment statement. ! ! Normally, this will be the name of a variable. ! ! If the input line was blank, then NAME will equal ' '. ! ! If an error occurred while trying to process the ! input line, NAME will contain the text of the line.. ! ! If the line began with "#", then NAME will contain the ! text of the line. ! ! If the line equals "end-of-input", then NAME will contain ! the text of the line. ! ! Output, integer IERROR. ! ! 0, no errors were detected. ! 1, the line was blank. ! 2, the line did not contain an "=" sign. ! 3, the line did not contain a variable name to the ! left of the "=" sign. ! 4, the right hand side of the assignment did not make ! sense. ! 5, end of input. ! 6, the line began with "#", signifying a comment. ! The text of the line is returned in NAME. ! 7, the line began with "end-of-input". ! ! Output, character ( len = * ) RHS. ! RHS contains the right hand side of the assignment statement. ! ! Output, real VALUE. ! ! VALUE contains the right hand side of the assignment statement. ! Normally, this will be a real value. ! ! But if the input line was blank, or if an error occurred ! while trying to process the input line, or if input ! terminated, then VALUE will simply be set to 0. ! implicit none ! integer iequal integer ierror integer ios integer lchar character ( len = 80 ) line character ( len = * ) name integer nchar character ( len = * ) rhs logical s_eqi real value ! ! Set default values ! ierror = 0 name = ' ' rhs = ' ' value = 0 ! ! Read a line ! read ( *, '(a)', iostat = ios ) line if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NAMELS - Reached end of input.' ierror = 5 return end if ! ! Empty lines are OK ! if ( len_trim ( line ) <= 0 ) then ierror = 1 return end if ! ! Check for comment. ! if ( line(1:1) == '#' ) then ierror = 6 name = line return end if ! ! Check for "end-of-line". ! if ( s_eqi ( line, 'END-OF-INPUT' ) ) then ierror = 7 name = line return end if ! ! Does the line contain an = sign? ! if ( index ( line, '=' ) <= 0 ) then ierror = 2 value = 0 name = line return end if ! ! Find the name of the variable to be assigned. ! iequal = index ( name, '=' ) if ( iequal > 0 ) then rhs = line(iequal+1:) else rhs = line end if call s_before_ss_copy ( line, '=', name ) call s_blank_delete ( name ) if ( len_trim ( name ) <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NAMELS - Warning!' write ( *, '(a)' ) ' The following input line was ignored, because' write ( *, '(a)' ) ' there was no variable name on the left hand' write ( *, '(a)' ) ' side of the assignment statement:' write ( *, '(a)' ) line write ( *, '(a)' ) ' ' ierror = 3 return end if ! ! Read the value, as a real number. ! nchar = index ( line, '=' ) call s_to_r ( line(nchar+1:), value, ierror, lchar ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NAMELS - Warning!' write ( *, '(a)' ) ' The following input line was ignored, because' write ( *, '(a)' ) ' the right hand side of the assignment ' write ( *, '(a)' ) ' statement did not seem to make sense:' write ( *, '(a)' ) line write ( *, '(a)' ) ' ' ierror = 4 end if return end subroutine nexchr ( s, i, c ) ! !******************************************************************************* ! !! NEXCHR returns the next nonblank character from a string. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be examined. ! ! Output, integer I. If I is 0, then there were no ! nonblank characters in the string. Otherwise I is ! the index of the first nonblank character in the string. ! ! Output, character C, the first nonblank character in the string. ! implicit none ! character c integer i character ( len = * ) s integer s_first_nonblank ! i = s_first_nonblank ( s ) if ( i > 0 ) then c = s(i:i) else c = ' ' end if return end subroutine nexstr ( s, nsub, isub, sub ) ! !******************************************************************************* ! !! NEXSTR returns the next nonblank characters from a string. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be examined. ! ! Input, integer NSUB, the number of nonblank characters desired. ! ! Output, integer ISUB, the index of the NSUB-th nonblank ! character. However, if ISUB is 0, there were NO nonblank ! characters. And if there are less than NSUB nonblank characters ! ISUB is the location of the last one of them. ! ! Output, character ( len = NSUB ) SUB, the first NSUB nonblanks. ! implicit none ! integer nsub ! integer i integer isub integer jsub integer s_first_nonblank character ( len = * ) s character ( len = nsub ) sub ! sub = ' ' isub = 0 do i = 1, nsub jsub = s_first_nonblank ( s(isub+1:) ) if ( jsub <= 0 ) then return end if isub = isub + jsub sub(i:i) = s(isub:isub) end do return end subroutine number_inc ( s ) ! !******************************************************************************* ! !! NUMBER_INC increments the integer represented by a string. ! ! ! Example: ! ! Input Output ! ----- ------ ! '17' '18' ! 'cat3' 'cat4' ! '2for9' '3for0' ! '99thump' '00thump' ! ! Discussion: ! ! If the string contains characters that are not digits, they will ! simply be ignored. If the integer is all 9's on input, then ! the output will be all 0's. ! ! Modified: ! ! 15 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, a string representing an integer. ! implicit none ! logical ch_is_digit integer i character ( len = * ) s ! do i = len ( s ), 1, -1 if ( ch_is_digit ( s(i:i) ) ) then call digit_inc ( s(i:i) ) if ( s(i:i) /= '0' ) then return end if end if end do return end subroutine oct_to_i ( s, intval ) ! !******************************************************************************* ! !! OCT_TO_I converts an octal string to its integer value. ! ! ! Warning: ! ! If too many digits are strung together, the computation will overflow. ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string of digits. ! ! Output, integer INTVAL, the corresponding integer value. ! implicit none ! integer first integer i integer idig integer intval integer isgn integer nchar character ( len = * ) s ! nchar = len_trim ( s ) ! ! Determine if there is a plus or minus sign. ! isgn = 1 first = nchar do i = 1, nchar - 1 if ( s(i:i) == '-' ) then isgn = - 1 else if ( s(i:i) == '+' ) then isgn = + 1 else if ( s(i:i) /= ' ' ) then first = i exit end if end do ! ! Read the numeric portion of the string. ! intval = 0 do i = first, nchar call ch_to_digit_oct ( s(i:i), idig ) intval = intval * 8 + idig end do intval = isgn * intval return end subroutine r_extract ( s, r, ierror ) ! !******************************************************************************* ! !! R_EXTRACT "extracts" a real from the beginning of a string. ! ! ! Modified: ! ! 02 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S; on input, a string from ! whose beginning a real is to be extracted. On output, ! the real, if found, has been removed. ! ! Output, real R. If IERROR is 0, then R contains the ! next real read from the string; otherwise R is 0. ! ! Output, integer IERROR. ! 0, no error. ! nonzero, a real could not be extracted from the beginning of the ! string. R is 0.0 and S is unchanged. ! implicit none ! integer ierror integer lchar real r character ( len = * ) s ! r = 0.0E+00 call s_to_r ( s, r, ierror, lchar ) if ( ierror /= 0 .or. lchar == 0 ) then ierror = 1 r = 0.0E+00 else call s_shift_left ( s, lchar ) end if return end subroutine r_input ( string, value, ierror ) ! !******************************************************************************* ! !! R_INPUT prints a prompt string and reads a real value from the user. ! ! ! Discussion: ! ! If the input line starts with a comment character ('#') or is blank, ! the routine ignores that line, and tries to read the next one. ! ! Modified: ! ! 27 March 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) STRING, the prompt string. ! ! Output, real VALUE, the value input by the user. ! ! Output, integer IERROR, an error flag, which is zero if no error occurred. ! implicit none ! integer ierror integer last character ( len = 80 ) line character ( len = * ) string real value ! ierror = 0 value = huge ( value ) ! ! Write the prompt. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( string ) do read ( *, '(a)', iostat = ierror ) line if ( ierror /= 0 ) then return end if ! ! If the line begins with a comment character, go back and read the next line. ! if ( line(1:1) == '#' ) then cycle end if if ( len_trim ( line ) == 0 ) then cycle end if ! ! Extract integer information from the string. ! call s_to_r ( line, value, ierror, last ) if ( ierror /= 0 ) then value = huge ( value ) return end if exit end do return end subroutine r_next ( s, r, done ) ! !******************************************************************************* ! !! R_NEXT "reads" real numbers from a string, one at a time. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string, presumably containing real ! numbers. These may be separated by spaces or commas. ! ! Output, real R. If DONE is FALSE, then R contains the ! "next" real value read from the string. If DONE is TRUE, then ! R is zero. ! ! Input/output, logical DONE. ! On input with a fresh string, the user should set DONE to TRUE. ! On output, the routine sets DONE to FALSE if another real ! value was read, or TRUE if no more reals could be read. ! implicit none ! logical done integer ierror integer lchar integer, save :: next = 1 real r character ( len = * ) s ! r = 0.0E+00 if ( done ) then next = 1 done = .false. end if if ( next > len ( s ) ) then done = .true. return end if call s_to_r ( s(next:), r, ierror, lchar ) if ( ierror /= 0 .or. lchar == 0 ) then done = .true. next = 1 else done = .false. next = next + lchar end if return end subroutine r_print ( ierror, maxrow, ncol, nrow, value ) ! !******************************************************************************* ! !! R_PRINT prints a scalar, vector or array. ! ! ! Discussion: ! ! The routine tries to print out integer valued reals in compact format. ! It transposes column vectors. It can print up to 5 columns of ! an array or vector per line. For an array, it will label the ! columns. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer IERROR, error flag. ! 0 if no errors. ! 1 if NROW or NCOL were less than or equal to 0. ! ! Input, integer MAXROW, the declared first dimension of VALUE. ! ! Input, integer NCOL, the number of columns in the array in VALUE. ! ! Input, integer NROW, the number of rows in the array in VALUE. ! ! Input, real VALUE(MAXROW,NCOL), contains an NROW by NCOL ! array which is to be printed out. ! implicit none ! integer maxrow integer ncol ! real, parameter :: BIG = 1000000.0E+00 integer i integer i1 integer ierror integer ihi integer ii integer ilo integer iv integer j integer jhi integer jlo integer ndim integer nrow character ( len = 14 ) out(5) character ( len = 80 ) output character ( len = 6 ) string1 character ( len = 6 ) string2 real v real value(maxrow,ncol) ! ! Check that NROW and NCOL make sense. ! if ( nrow <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R_PRINT - Serious error!' write ( *, '(a,i6)' ) ' Illegal NROW = ', nrow ierror = 1 return else if ( ncol <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R_PRINT - Serious error!' write ( *, '(a,i6)' ) ' Illegal NCOL = ', ncol ierror = 1 return end if ! ! Print out a scalar value. ! if ( nrow == 1 .and. ncol == 1 ) then v = value(1,1) write ( output, '(g14.6)' ) v if ( abs ( v ) < BIG ) then iv = int ( v ) if ( real ( iv ) == v ) then write ( output, '(i7)' ) iv end if end if write ( *, '(a)' ) trim ( output ) ! ! Print out a vector value. ! else if ( nrow == 1 .or. ncol == 1 ) then if ( nrow /= 1) then write ( *, '(a)' ) 'Transposed vector:' end if ndim = nrow * ncol do ilo = 1, ndim, 5 ihi = min ( ilo + 4, ndim ) ii = 0 output = ' ' do i = ilo, ihi ii = ii + 1 if ( nrow == 1 ) then v = value(1, i) else v = value(i,1) end if write ( out(ii), '(g14.6)' ) v if ( abs ( v ) < BIG ) then iv = int ( v ) if ( real ( iv ) == v ) then write ( out(ii), '(i7)' ) iv end if end if i1 = ( ii - 1 ) * 14 + 1 output(i1:i1+13) = out(ii) end do write ( *, '(a)' ) trim ( output ) end do ! ! Print out a 2D array. ! else do jlo = 1, ncol, 5 jhi = min ( jlo+4, ncol ) write ( *, '(a)' ) ' ' if ( jhi /= jlo ) then call i_to_s_left ( jlo, string1 ) call i_to_s_left ( jhi, string2 ) output = 'columns ' // string2 // ' to ' // string2 else call i_to_s_left ( jlo, string1 ) output = 'column ' // string1 end if write ( *, '(a)' ) trim ( output ) do i = 1, nrow ii = 0 output = ' ' do j = jlo, jhi ii = ii + 1 v = value(i,j) write ( out(ii), '(g14.6)' ) v if ( abs ( v ) < BIG ) then iv = int ( v ) if ( real ( iv ) == v ) then write ( out(ii), '(i7)' ) iv end if end if i1 = ( ii - 1 ) * 14 + 1 output(i1:i1+13) = out(ii) end do write ( *, '(a)' ) trim ( output ) end do end do end if return end subroutine r_to_b4_ieee ( r, word ) ! !******************************************************************************* ! !! R_TO_B4_IEEE converts a real value to a 4 byte IEEE word. ! ! ! Discussion: ! ! This routine does not seem to working reliably for unnormalized data. ! ! Examples: ! ! 0 00000000 00000000000000000000000 = 0 ! 1 00000000 00000000000000000000000 = -0 ! ! 0 11111111 00000000000000000000000 = Infinity ! 1 11111111 00000000000000000000000 = -Infinity ! ! 0 11111111 00000100000000000000000 = NaN ! 1 11111111 00100010001001010101010 = NaN ! ! 0 01111110 00000000000000000000000 = +1 * 2**(126-127) * 1.0 = 0.5 ! 0 01111111 00000000000000000000000 = +1 * 2**(127-127) * 1.0 = 1 ! 0 10000000 00000000000000000000000 = +1 * 2**(128-127) * 1.0 = 2 ! 0 10000001 00000000000000000000000 = +1 * 2**(129-127) * 1.0 = 4 ! ! 0 10000001 10100000000000000000000 = +1 * 2**(129-127) * 1.101 = 6.5 ! 1 10000001 10100000000000000000000 = -1 * 2**(129-127) * 1.101 = -6.5 ! ! 0 00000001 00000000000000000000000 = +1 * 2**( 1-127) * 1.0 = 2**(-126) ! 0 00000000 10000000000000000000000 = +1 * 2**( 0-126) * 0.1 = 2**(-127) ! 0 00000000 00000000000000000000001 = +1 * 2**( 0-126) * ! 0.00000000000000000000001 = ! 2**(-149) (Smallest positive value) ! ! Reference: ! ! ANSI/IEEE Standard 754-1985, ! Standard for Binary Floating Point Arithmetic. ! ! Modified: ! ! 11 November 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real R, the real number to be converted. ! ! Output, integer WORD, the IEEE representation of the number. ! implicit none ! integer e integer f real r real r_copy integer s integer word ! r_copy = r ! ! Determine S, the sign bit. ! if ( r_copy >= 0.0E+00 ) then s = 0 else s = 1 r_copy = - r_copy end if ! ! Determine E, the exponent. ! (FOR NOW, IGNORE UNNORMALIZED NUMBERS) ! e = 0 if ( r == 0.0E+00 ) then else do while ( r_copy >= 2.0E+00 ) e = e + 1 r_copy = r_copy / 2.0E+00 end do do while ( r_copy < 1.0E+00 .and. e > -127 ) e = e - 1 r_copy = r_copy * 2.0E+00 end do e = e + 127 end if ! ! Determine F, the fraction. ! if ( r == 0.0E+00 ) then f = 0 else if ( e > 0 ) then r_copy = r_copy - 1.0E+00 f = int ( r_copy * 2.0E+00**23 ) else if ( e == 0 ) then f = int ( r_copy * 2.0E+00**23 ) end if ! ! Set the bits corresponding to S, E, F. ! call mvbits ( s, 0, 1, word, 31 ) call mvbits ( e, 0, 8, word, 23 ) call mvbits ( f, 0, 23, word, 0 ) return end subroutine r_to_b4_ultrix ( r, word ) ! !******************************************************************************* ! !! R_TO_B4_ULTRIX converts a real value to a 4 byte ULTRIX word. ! ! ! Discussion: ! ! The routine assumes that the real value R can be written in ! terms of 3 integer quantities S, E, and F, so that: ! ! R = (-1)**S * 2.0**(E-126) * real ( F ) / 2.0**24 ! ! Modified: ! ! 13 November 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real R, the real number to be converted. ! ! Output, integer WORD, the ULTRIX representation of the number. ! implicit none ! integer e integer f real r real r_copy integer s integer word ! r_copy = r ! ! Determine S, the sign bit. ! if ( r_copy >= 0.0E+00 ) then s = 0 else s = 1 r_copy = - r_copy end if ! ! Determine E, the exponent. ! ! (FOR NOW, IGNORE UNNORMALIZED NUMBERS) ! if ( r == 0.0E+00 ) then else e = 0 do while ( r_copy >= 1.0 ) e = e + 1 r_copy = r_copy / 2.0 end do do while ( r_copy < 0.5 ) e = e - 1 r_copy = r_copy * 2.0 end do e = e + 126 end if ! ! Determine F, the fraction. ! if ( r == 0.0 ) then else r_copy = r_copy - 1.0 f = int ( r_copy * 2**24 ) end if ! ! Set the bits corresponding to S, E, F. ! call mvbits ( s, 0, 1, word, 31 ) call mvbits ( e, 0, 8, word, 23 ) call mvbits ( f, 0, 23, word, 0 ) return end subroutine r_to_binary ( r, s ) ! !******************************************************************************* ! !! R_TO_BINARY represents a real value as a string of binary digits. ! ! ! Discussion: ! ! No check is made to ensure that the string is long enough. ! ! The binary digits are a faithful representation of the real ! number in base 2. ! ! Examples: ! ! R S ! ! -10.75000 -1010.11 ! 0.4218750 0.011011 ! 0.3333333 0.01010101010101010101010 ! ! Modified: ! ! 24 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real R, the real number. ! ! Output, character ( len = * ) S, the binary representation. ! implicit none ! integer i integer iexp integer ilo integer lens real r real rcopy character ( len = * ) s ! lens = len ( s ) if ( lens < 1 ) then return end if rcopy = r s = ' ' if ( rcopy == 0.0E+00 ) then s = '0' return end if ilo = 0 if ( rcopy < 0.0E+00 ) then ilo = 1 s(ilo:ilo) = '-' rcopy = - rcopy end if ! ! Figure out the divisor. ! iexp = 0 do while ( rcopy >= 1.0E+00 ) rcopy = rcopy / 2.0E+00 iexp = iexp + 1 end do do while ( rcopy < 0.5E+00 ) rcopy = rcopy * 2.0E+00 iexp = iexp - 1 end do ! ! Now 0.5 <= RCOPY < 1. ! ! If IEXP < 0, print leading zeroes. ! if ( iexp == 0 ) then ilo = ilo + 1 s(ilo:ilo) = '0' else if ( iexp < 0 ) then ilo = ilo + 1 s(ilo:ilo) = '0' ilo = ilo + 1 s(ilo:ilo) = '.' do i = 1, -iexp ilo = ilo + 1 s(ilo:ilo) = '0' end do end if ! ! Now repeatedly double RCOPY. ! Every time you exceed 1, that's a '1' digit. ! iexp = iexp + 1 do rcopy = 2.0E+00 * rcopy iexp = iexp - 1 if ( iexp == 0 ) then ilo = ilo + 1 s(ilo:ilo) = '.' if ( ilo >= lens ) then return end if end if ilo = ilo + 1 if ( rcopy >= 1.0E+00 ) then rcopy = rcopy - 1.0E+00 s(ilo:ilo) = '1' else s(ilo:ilo) = '0' end if if ( ilo >= lens ) then return end if if ( rcopy == 0.0E+00 ) then exit end if end do return end subroutine r_to_bits ( r, s ) ! !******************************************************************************* ! !! R_TO_BITS converts a real to a string of 32 bits. ! ! ! Discussion: ! ! The 32 bits constitute the computer's internal representation ! of the number, and require some interpretation! ! ! Modified: ! ! 08 November 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real R, the value whose bit pattern is desired. ! (Internally, the variable is declared to be an integer, ! but this should not be of any concern.) ! ! Output, character ( len = 32 ) S, a string of '0' and '1' ! which should be the actual internal bit pattern for the word. ! implicit none ! integer, parameter :: nbits = 32 ! integer i integer ihi integer ii integer j integer lens integer r character ( len = nbits ) s ! ! Get the length of the string, and blank it out. ! lens = len ( s ) s = ' ' ! ! Set the DO loop index so that we transfer no more than the number ! of bits we have, and the number of character positions available. ! ihi = min ( nbits-1, lens-1 ) ! ! Translate one bit at a time into a character. ! do ii = 0, ihi i = nbits - 1 - ii j = ii + 1 if ( btest ( r, i ) ) then s(j:j) = '1' else s(j:j) = '0' end if end do return end subroutine r_to_ch4 ( r, ch4 ) ! !******************************************************************************* ! !! R_TO_CH4 converts a real value to a 4 character string. ! ! ! Modified: ! ! 28 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real R, the real value. ! ! Output, character ( len = 4 ) CH4, a corresponding character value. ! implicit none ! character ( len = 4 ) ch4 real r ! write ( ch4, '(a4)' ) r return end subroutine r_to_flt ( r, isgn, mant, iexp, ndig ) ! !******************************************************************************* ! !! R_TO_FLT computes the scientific representation of a real number. ! ! ! Discussion: ! ! The routine is given a real number R and computes a sign ISGN, ! an integer mantissa MANT and an integer exponent IEXP so ! that ! ! R = ISGN * MANT * 10 ** IEXP ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real R, the real number whose scientific ! representation is desired. ! ! Output, integer ISGN, the sign of the number: ! ! -1, if R is negative. ! 0, if R is zero. ! 1, if R is positive. ! ! Output, integer MANT, the mantissa of the representation. ! This is an integer between 0 and 10**NDIG, that is, ! ! 0 <= MANT < 10**NDIG. ! ! Output, integer IEXP, the exponent of 10 that multiplies MULT. ! ! Input, integer NDIG, the number of decimal digits. ! implicit none ! integer i integer idig integer iexp integer isgn integer mant integer ndig real rmant real r ! mant = 0 iexp = 0 isgn = 0 ! ! Find the first digit. ! That is, write the value in the form RMANT * 10**IEXP ! where 1/10 < RMANT <= 1. ! if ( r == 0.0E+00 ) then return else if ( r < 0.0E+00 ) then isgn = -1 rmant = abs ( r ) else isgn = 1 rmant = r end if do while ( rmant > 1.0E+00 ) rmant = rmant / 10.0E+00 iexp = iexp + 1 end do do while ( rmant <= 0.1E+00 ) rmant = rmant * 10.0E+00 iexp = iexp - 1 end do ! ! Now read off NDIG digits of RMANT. ! do i = 1, ndig rmant = rmant * 10.0E+00 idig = int ( rmant ) rmant = rmant - idig mant = 10 * mant + idig iexp = iexp - 1 end do ! ! Now do rounding. ! idig = int ( rmant * 10.0E+00 ) mant = 10 * mant + idig mant = nint ( real ( mant ) / 10.0E+00 ) ! ! Now chop off trailing zeroes. ! do while ( mod ( mant, 10 ) == 0 ) mant = mant / 10 iexp = iexp + 1 end do return end subroutine r_to_s_left ( r, s ) ! !******************************************************************************* ! !! R_TO_S_LEFT writes a real into a left justified character string. ! ! ! Method: ! ! A 'G14.6' format is used with a WRITE statement. ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real R, the real number to be written into the string. ! ! Output, character ( len = * ) S, the string into which ! the real number is to be written. If the string is less than 14 ! characters long, it will will be returned as a series of ! asterisks. ! implicit none ! integer i integer nchar real r character ( len = * ) s character ( len = 14 ) s2 ! nchar = len ( s ) if ( nchar < 14 ) then do i = 1, nchar s(i:i) = '*' end do else if ( r == 0.0E+00 ) then s(1:14) = ' 0.0 ' else write ( s2, '(g14.6)' ) r s(1:14) = s2 end if ! ! Shift the string left. ! s = adjustl ( s ) return end subroutine r_to_s_right ( r, s ) ! !******************************************************************************* ! !! R_TO_S_RIGHT writes a real into a right justified character string. ! ! ! Method: ! ! A 'G14.6' format is used with a WRITE statement. ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real R, the real number to be written into the string. ! ! Output, character ( len = * ) S, the string into which ! the real number is to be written. If the string is less than 14 ! characters long, it will will be returned as a series of ! asterisks. ! implicit none ! integer i integer nchar real r character ( len = * ) s character ( len = 14 ) s2 ! nchar = len ( s ) if ( nchar < 14 ) then do i = 1, nchar s(i:i) = '*' end do else if ( r == 0.0E+00 ) then s(1:14) = ' 0.0 ' else write ( s2, '(g14.6)' ) r s(1:14) = s2 end if call s_right ( s ) return end function r_to_s32 ( r ) ! !******************************************************************************* ! !! R_TO_S32 encodes a real number as 32 characters. ! ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real R, the real number to be coded. ! ! Output, character ( len = 32 ) R_TO_S32, the character variable that ! corresponds to the real number. ! implicit none ! character ( len = 32 ) chr32 integer i integer iexp integer ii integer j real r character ( len = 32 ) r_to_s32 real rcopy ! rcopy = r ! ! Sign bit ! if ( rcopy < 0.0E+00 ) then chr32(1:1) = '1' else chr32(1:1) = '0' end if rcopy = abs ( rcopy ) ! ! Exponent: 'excess 128' format, legal values of IEXP are 1 to 255. ! if ( rcopy == 0.0E+00 ) then iexp = 0 else iexp = 128 if ( rcopy < 1.0E+00 ) then do while ( iexp > 1 ) rcopy = 2.0E+00 * rcopy iexp = iexp - 1 end do else if ( rcopy >= 2.0E+00 ) then do while ( iexp < 255 ) rcopy = 0.5E+00 * rcopy iexp = iexp + 1 end do end if end if ! ! Write characters 2 through 9 that represent exponent. ! do i = 1, 8 ii = 10 - i j = mod ( iexp, 2 ) iexp = iexp / 2 if ( j == 0 ) then chr32(ii:ii) = '0' else chr32(ii:ii) = '1' end if end do ! ! Write mantissa in positions 10 through 32. ! Note that, unless exponent equals 0, the most significant bit is ! assumed to be 1 and hence is not stored. ! if ( rcopy /= 0.0E+00 ) then rcopy = rcopy - 1.0E+00 end if do i = 10, 32 rcopy = 2.0E+00 * rcopy if ( rcopy >= 1.0E+00 ) then chr32(i:i) = '1' rcopy = rcopy - 1.0E+00 else chr32(i:i) = '0' end if end do r_to_s32 = chr32 return end subroutine r_to_sef ( r, s, e, f ) ! !******************************************************************************* ! !! R_TO_SEF represents a real number as R = S * 2**E * F. ! ! ! Discussion: ! ! Assuming no arithmetic problems, in fact, this equality should be ! exact, that is, S, E and F should exactly express the value ! as stored on the computer. ! ! Modified: ! ! 12 November 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real R, the real number. ! ! Output, integer S, the sign bit: ! 0, if R is nonnegative; ! 1, if R is negative. ! ! Output, integer E, the exponent base 2. ! ! Output, integer F, the mantissa. ! implicit none ! integer e integer f real r real r_copy integer s ! if ( r == 0.0E+00 ) then s = 0 e = 0 f = 0 return end if r_copy = r ! ! Set S. ! if ( r_copy >= 0.0E+00 ) then s = 0 else s = 1 r_copy = - r_copy end if ! ! Extracting the exponent leaves 0.5 <= R_COPY < 1.0. ! e = 0 do while ( r_copy < 0.5E+00 ) r_copy = r_copy * 2.0E+00 e = e - 1 end do do while ( r_copy >= 1.0E+00 ) r_copy = r_copy / 2.0E+00 e = e + 1 end do ! ! Get the binary mantissa, adjusting the exponent as you go. ! f = 0 e = e + 1 do f = 2 * f e = e - 1 if ( r_copy >= 1.0E+00 ) then f = f + 1 r_copy = r_copy - 1.0E+00 end if if ( r_copy == 0.0E+00 ) then exit end if r_copy = 2.0E+00 * r_copy end do return end subroutine ranger ( s, maxval, nval, ival ) ! !******************************************************************************* ! !! RANGER "understands" a range defined by a string like '4:8'. ! ! ! Discussion: ! ! The range can be much more complicated, as in ! ! '4:8 10 2 14:20' ! ! or (commas are optional) ! ! '4:8,10, 2 , 14:20' ! ! RANGER will return the values ! ! 4, 5, 6, 7, 8, 10, 2, 14, 15, 16, 17, 18, 19, 20 ! ! 0 and negative integers are acceptable. So are pairs ! of values that are equal, as in '4:4', which just represents ! 4, and pairs that represent descending sequences, as ! in '4:-2'. ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, contains a string of integers, ! representing themselves, and pairs of integers representing ! themselves and all integers between them. ! ! Input, integer MAXVAL, the dimension of the IVAL vector, ! which represents the maximum number of integers that may ! be read from the string. ! ! Output, integer NVAL, the number of integers read from the string. ! ! Output, integer IVAL(MAXVAL). The first NVAL entries of ! IVAL contain the integers read from the string. ! implicit none ! integer maxval ! integer i integer ierror integer ilo integer inc integer intval integer ival(maxval) integer lchar integer lens integer next integer nval character ( len = * ) s ! nval = 0 ! ! Replace all commas by blanks. ! call s_ch_blank ( s, ',' ) ! ! Replace multiple consecutive blanks by one blank. ! call s_blanks_delete ( s ) ! ! Get the length of the string to the last nonblank. ! lens = len_trim ( s ) ! ! Set a pointer to the next location to be examined. ! next = 1 do while ( next <= lens ) ! ! Find the next integer in the string. ! call s_to_i ( s(next:), intval, ierror, lchar ) if ( ierror /= 0 ) then return end if ! ! Move the pointer. ! next = next + lchar ! ! If there's room, add the value to the list. ! if ( nval >= maxval ) then return end if nval = nval + 1 ival(nval) = intval ! ! Have we reached the end of the string? ! if ( next > lens ) then return end if ! ! Skip past the next character if it is a space. ! if ( s(next:next) == ' ' ) then next = next + 1 if ( next > lens ) then return end if end if ! ! Is the next character a colon? ! if ( s(next:next) /= ':' ) then cycle end if ! ! Increase the pointer past the colon. ! next = next + 1 if ( next > lens ) then return end if ! ! Find the next integer in the string. ! call s_to_i ( s(next:), intval, ierror, lchar ) if ( ierror /= 0 ) then return end if ! ! Move the pointer. ! next = next + lchar ! ! Generate integers between the two values. ! ilo = ival(nval) if ( intval >= ilo ) then inc = + 1 else inc = - 1 end if do i = ilo+inc, intval, inc if ( nval >= maxval ) then return end if nval = nval + 1 ival(nval) = i end do end do return end subroutine rat_to_s_left ( ival, jval, s ) ! !******************************************************************************* ! !! RAT_TO_S_LEFT returns a left-justified representation of IVAL/JVAL. ! ! ! Discussion: ! ! If the ratio is negative, a minus sign precedes IVAL. ! A slash separates IVAL and JVAL. ! ! Modified: ! ! 01 February 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IVAL, JVAL, the integers whose ratio IVAL/JVAL is to ! be represented. ! ! If IVAL is nonzero and JVAL is 0, the string will be returned as "Inf" ! or "-Inf" (Infinity), and if both IVAL and JVAL are zero, the string ! will be returned as "NaN" (Not-a-Number). ! ! Output, character ( len = * ) S, a left-justified string ! containing the representation of IVAL/JVAL. ! implicit none ! integer ival integer ival2 integer jval integer jval2 character ( len = * ) s character ( len = 22 ) s2 ! ! Take care of simple cases right away. ! if ( ival == 0 ) then if ( jval /= 0 ) then s2 = '0' else s2 = 'NaN' end if else if ( jval == 0 ) then if ( ival > 0 ) then s2 = 'Inf' else s2 = '-Inf' end if ! ! Make copies of IVAL and JVAL. ! else ival2 = ival jval2 = jval if ( jval2 == 1 ) then write ( s2, '(i11)' ) ival2 else write ( s2, '(i11, ''/'', i10)' ) ival2, jval2 end if call s_blank_delete ( s2 ) end if s = s2 return end subroutine rat_to_s_right ( ival, jval, s ) ! !******************************************************************************* ! !! RAT_TO_S_RIGHT returns a right-justified representation of IVAL/JVAL. ! ! ! Discussion: ! ! If the ratio is negative, a minus sign precedes IVAL. ! A slash separates IVAL and JVAL. ! ! Modified: ! ! 01 February 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IVAL, JVAL, the two integers whose ! ratio IVAL/JVAL is to be represented. ! ! Note that if IVAL is nonzero and JVAL is 0, the string will ! be returned as "Inf" or "-Inf" (Infinity), and if both ! IVAL and JVAL are zero, the string will be returned as "NaN" ! (Not-a-Number). ! ! Output, character ( len = * ) S, a right-justified string ! containing the representation of IVAL/JVAL. ! implicit none ! integer ival integer jval character ( len = * ) s ! call rat_to_s_left ( ival, jval, s ) call s_right ( s ) return end subroutine right ( s1, s2 ) ! !******************************************************************************* ! !! RIGHT inserts a string flush right into another. ! ! ! Discussion: ! ! S2 is not blanked out first. If there is already information in S2, ! some of it may still be around after S1 is written into S2. Users may ! want to first assign S2 = ' ' if this is not the effect desired. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, a string which is to be ! inserted into S2. Only the portion of S1 up to the last ! nonblank will be used. ! ! Output, character ( len = * ) S2, a string whose length ! will be determined by a call to LEN, and which will ! contain, on output, a right flush copy of S1. ! implicit none ! integer ihi integer ilo integer jhi integer jlo integer len1 integer len2 character ( len = * ) s1 character ( len = * ) s2 ! len1 = len_trim ( s1 ) len2 = len ( s2 ) if ( len1 < len2 ) then ilo = 1 ihi = len1 jlo = len2 + 1 - len1 jhi = len2 else if ( len1 > len2 ) then ilo = len1 + 1 - len2 ihi = len1 jlo = 1 jhi = len2 else ilo = 1 ihi = len1 jlo = 1 jhi = len2 end if s2(jlo:jhi) = s1(ilo:ihi) return end subroutine rubout ( s ) ! !******************************************************************************* ! !! 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. ! ! 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 rvec_to_s ( n, x, s ) ! !******************************************************************************* ! !! RVEC_TO_S "writes" a real vector into a string. ! ! ! Discussion: ! ! The values will be separated by commas and a single space. ! If the string is too short, then data will be lost. ! ! Modified: ! ! 30 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of X. ! ! Input, real X(N), a vector to be written to a string. ! ! Output, character ( len = * ) S, a string to which the real vector ! has been written. ! implicit none ! integer n ! integer i character ( len = * ) s character ( len = 14 ) s2 real x(n) ! do i = 1, n if ( x(i) == 0.0E+00 ) then s2 = '0' else if ( abs ( x(i) ) >= 1.0E+10 ) then write ( s2, '(g14.6)' ) x(i) call s_trim_zeros ( s2 ) else if ( real ( int ( x(i) ) ) == x(i) ) then write ( s2, '(i12)' ) int ( x(i) ) else write ( s2, '(g14.6)' ) x(i) call s_trim_zeros ( s2 ) end if if ( i == 1 ) then s = adjustl ( s2 ) else s = trim ( s ) // ', ' // adjustl ( s2 ) end if end do return end subroutine s_after_ss_copy ( s, ss, s2 ) ! !******************************************************************************* ! !! S_AFTER_SS_COPY copies a string after a given substring. ! ! ! Discussion: ! ! S and S2 can be the same object, in which case the string is ! overwritten by a copy of itself after the substring. ! ! Example: ! ! Input: ! ! S = 'ABCDEFGH' ! SS = 'EF' ! ! Output: ! ! S2 = 'GH'. ! ! Modified: ! ! 21 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be copied. ! ! Input, character ( len = * ) SS, the substring after which the copy begins. ! ! Output, character ( len = * ) S2, the copied portion of S. ! implicit none ! integer first integer last integer last_s2 character ( len = * ) s character ( len = * ) s2 character ( len = * ) ss ! ! Find the first occurrence of the substring. ! first = index ( s, ss ) ! ! If the substring doesn't occur at all, then S2 is blank. ! if ( first == 0 ) then s2 = ' ' return end if ! ! Redefine FIRST to point to the first character to copy after ! the substring. ! first = first + len ( ss ) ! ! Measure the two strings. ! last = len ( s ) last_s2 = len ( s2 ) ! ! Adjust effective length of S if S2 is short. ! last = min ( last, last_s2 + first - 1 ) ! ! Copy the string. ! s2(1:last+1-first) = s(first:last) ! ! Clear out the rest of the copy. ! s2(last+2-first:last_s2) = ' ' return end subroutine s_alpha_last ( s, iloc ) ! !******************************************************************************* ! !! S_ALPHA_LAST returns the location of the last alphabetic character. ! ! ! Modified: ! ! 02 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be searched. ! ! Output, integer ILOC, the location of the last alphabetic ! character in the string. If there are no alphabetic ! characters, ILOC is returned as 0. ! implicit none ! logical ch_is_alpha integer i integer iloc character ( len = * ) s ! do i = len ( s ), 1, -1 if ( ch_is_alpha ( s(i:i) ) ) then iloc = i return end if end do iloc = 0 return end function s_any_alpha ( s ) ! !******************************************************************************* ! !! S_ANY_ALPHA is TRUE if a string contains any alphabetic character. ! ! ! Examples: ! ! Input Output ! ! Riding Hood TRUE ! 123 + 34 FALSE ! Seven Eleven TRUE ! 1.0E+11 TRUE ! ! Modified: ! ! 05 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string to be checked. ! ! Output, logical S_ANY_ALPHA is TRUE if any character in string ! is an alphabetic character. ! implicit none ! logical ch_is_alpha integer i character ( len = * ) s logical s_any_alpha ! s_any_alpha = .true. do i = 1, len ( s ) if ( ch_is_alpha ( s(i:i) ) ) then return end if end do s_any_alpha = .false. return end function s_any_control ( s ) ! !******************************************************************************* ! !! S_ANY_CONTROL is TRUE if a string contains any control characters. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, is the string to check. ! ! Output, logical S_ANY_CONTROL, is TRUE if any character is a control ! character. ! implicit none ! logical ch_is_control integer i character ( len = * ) s logical s_any_control ! do i = 1, len ( s ) if ( ch_is_control ( s(i:i) ) ) then s_any_control = .true. return end if end do s_any_control = .false. return end subroutine s_before_ss_copy ( s, ss, s2 ) ! !******************************************************************************* ! !! S_BEFORE_SS_COPY copies a string up to a given substring. ! ! ! Discussion: ! ! S and S2 can be the same object, in which case the string is ! overwritten by a copy of itself up to the substring, followed ! by blanks. ! ! Example: ! ! Input: ! ! S = 'ABCDEFGH' ! SS = 'EF' ! ! Output: ! ! S2 = 'ABCD'. ! ! Modified: ! ! 21 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be copied. ! ! Input, character ( len = * ) SS, the substring before which the copy stops. ! ! Output, character ( len = * ) S2, the copied portion of S. ! implicit none ! integer last integer last_s2 character ( len = * ) s character ( len = * ) s2 character ( len = * ) ss ! ! Find the first occurrence of the substring. ! last = index ( s, ss ) ! ! If the substring doesn't occur at all, behave as though it begins ! just after the string terminates. ! ! Now redefine LAST to point to the last character to copy before ! the substring begins. ! if ( last == 0 ) then last = len ( s ) else last = last - 1 end if ! ! Now adjust again in case the copy holder is "short". ! last_s2 = len ( s2 ) last = min ( last, last_s2 ) ! ! Copy the beginning of the string. ! Presumably, compilers now understand that if LAST is 0, we don't ! copy anything. ! Clear out the rest of the copy. ! s2(1:last) = s(1:last) s2(last+1:last_s2) = ' ' return end function s_begin ( s1, s2 ) ! !******************************************************************************* ! !! S_BEGIN is TRUE if one string matches the beginning of the other. ! ! ! Examples: ! ! S1 S2 S_BEGIN ! ! 'Bob' 'BOB' TRUE ! ' B o b ' ' bo b' TRUE ! 'Bob' 'Bobby' TRUE ! 'Bobo' 'Bobb' FALSE ! ' ' 'Bob' FALSE (Do not allow a blank to match ! anything but another blank string.) ! ! Modified: ! ! 20 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, S2, the strings to be compared. ! ! Output, logical S_BEGIN, .TRUE. if the strings match up to ! the end of the shorter string, ignoring case, ! FALSE otherwise. ! implicit none ! logical ch_eqi integer i1 integer i2 integer len1 integer len2 logical s_begin character ( len = * ) s1 character ( len = * ) s2 ! len1 = len_trim ( s1 ) len2 = len_trim ( s2 ) ! ! If either string is blank, then both must be blank to match. ! Otherwise, a blank string matches anything, which is not ! what most people want. ! if ( len1 == 0 .or. len2 == 0 ) then if ( len1 == 0 .and. len2 == 0 ) then s_begin = .true. else s_begin = .false. end if return end if i1 = 0 i2 = 0 ! ! Find the next nonblank in S1. ! do do i1 = i1 + 1 if ( i1 > len1 ) then s_begin = .true. return end if if ( s1(i1:i1) /= ' ' ) then exit end if end do ! ! Find the next nonblank in S2. ! do i2 = i2 + 1 if ( i2 > len2 ) then s_begin = .true. return end if if ( s2(i2:i2) /= ' ' ) then exit end if end do ! ! If the characters match, get the next pair. ! if ( .not. ch_eqi ( s1(i1:i1), s2(i2:i2) ) ) then exit end if end do s_begin = .false. return end subroutine s_blank_delete ( s ) ! !******************************************************************************* ! !! S_BLANK_DELETE removes blanks from a string, left justifying the remainder. ! ! ! Comment: ! ! All TAB characters are also removed. ! ! 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 integer nchar character ( len = * ) s character, parameter :: TAB = char ( 9 ) ! iput = 0 nchar = len_trim ( s ) do iget = 1, nchar c = s(iget:iget) if ( c /= ' ' .and. c /= TAB ) then iput = iput + 1 s(iput:iput) = c end if end do s(iput+1:nchar) = ' ' return end subroutine s_blanks_delete ( s ) ! !******************************************************************************* ! !! S_BLANKS_DELETE replaces consecutive blanks by one blank. ! ! ! Discussion: ! ! The remaining characters are left justified and right padded with blanks. ! TAB characters are converted to spaces. ! ! Modified: ! ! 26 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none ! integer i integer j character newchr character oldchr character ( len = * ) s character, parameter :: TAB = char ( 9 ) ! j = 0 newchr = ' ' do i = 1, len ( s ) oldchr = newchr newchr = s(i:i) if ( newchr == TAB ) then newchr = ' ' end if s(i:i) = ' ' if ( oldchr /= ' ' .or. newchr /= ' ' ) then j = j + 1 s(j:j) = newchr end if end do return end subroutine s_blanks_insert ( s, ilo, ihi ) ! !******************************************************************************* ! !! S_BLANKS_INSERT inserts blanks into a string, sliding old characters over. ! ! ! Discussion: ! ! Characters at the end of the string "drop off" and are lost. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! ! Input, integer ILO, the location where the first blank is to be inserted. ! ! Input, integer IHI, the location where the last blank is to be inserted. ! implicit none ! character c integer i integer iget integer ihi integer ilo integer imax integer imin integer iput integer nchar integer nmove character ( len = * ) s ! nchar = len ( s ) if ( ilo > ihi .or. ilo > nchar ) then return end if if ( ihi <= nchar ) then imax = ihi else imax = nchar end if if ( ilo >= 1 ) then imin = ilo else imin = 1 end if nmove = nchar - imax do i = 1, nmove iput = nchar + 1 - i iget = nchar - imax + imin - i c = s(iget:iget) s(iput:iput) = c end do do i = imin, imax s(i:i) = ' ' end do return end subroutine s_ch_blank ( s, c ) ! !******************************************************************************* ! !! S_CH_BLANK replaces each occurrence of a particular character by a blank. ! ! ! Modified: ! ! 28 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! ! Input, character C, the character to be removed. ! implicit none ! character c integer i integer nchar character ( len = * ) s ! nchar = len_trim ( s ) do i = 1, nchar if ( s(i:i) == c ) then s(i:i) = ' ' end if end do return end subroutine s_ch_delete ( s, c ) ! !******************************************************************************* ! !! S_CH_DELETE removes all occurrences of a character from a string. ! ! ! Discussion: ! ! Each time the given character is found in the string, the characters ! to the right of the string are shifted over one position. ! ! Modified: ! ! 28 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! ! Input, character C, the character to be removed. ! implicit none ! character c integer iget integer iput integer nchar character ( len = * ) s ! nchar = len_trim ( s ) iput = 1 do iget = 1, nchar if ( s(iget:iget) == c ) then else if ( iput == iget ) then iput = iput + 1 else s(iput:iput) = s(iget:iget) iput = iput + 1 end if end do s(iput:nchar) = ' ' return end function s_ch_last ( s ) ! !******************************************************************************* ! !! S_CH_LAST returns the last nonblank character in a string. ! ! ! Modified: ! ! 05 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be examined. ! ! Output, character S_CH_LAST, the last nonblank character in S, ! or ' ' if S is all blank. ! implicit none ! integer lenc character ( len = * ) s character s_ch_last ! lenc = len_trim ( s ) if ( lenc > 0 ) then s_ch_last = s(lenc:lenc) else s_ch_last = ' ' end if return end subroutine s_cap ( s ) ! !******************************************************************************* ! !! S_CAP replaces any lowercase letters by uppercase ones in a string. ! ! ! 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 ) ! !******************************************************************************* ! !! S_CAT concatenates two strings to make a third string. ! ! ! Modified: ! ! 18 September 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 ! if ( s1 == ' ' .and. s2 == ' ' ) then s3 = ' ' else if ( s1 == ' ' ) then s3 = s2 else if ( s2 == ' ' ) then s3 = s1 else s3 = trim ( s1 ) // trim ( s2 ) end if return end subroutine s_cat1 ( s1, s2, s3 ) ! !******************************************************************************* ! !! S_CAT1 concatenates two strings, with a single blank separator. ! ! ! Examples: ! ! S1 S2 S ! ! 'cat' 'dog' 'cat dog' ! ! Modified: ! ! 18 September 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, a blank, and S2, ignoring any trailing blanks. ! implicit none ! character ( len = * ) s1 character ( len = * ) s2 character ( len = * ) s3 ! if ( s1 == ' ' .and. s2 == ' ' ) then s3 = ' ' else if ( s1 == ' ' ) then s3 = s2 else if ( s2 == ' ' ) then s3 = s1 else s3 = trim ( s1 ) // ' ' // trim ( s2 ) end if return end subroutine s_chop ( s, ilo, ihi ) ! !******************************************************************************* ! !! 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! ' ! ! 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 subroutine s_control_blank ( s ) ! !******************************************************************************* ! !! S_CONTROL_BLANK replaces control characters with blanks. ! ! ! Definition: ! ! A "control character" has ASCII code <= 31 or ASCII code => 127. ! ! 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 integer nchar character ( len = * ) s ! nchar = len_trim ( s ) do i = 1, nchar if ( ch_is_control ( s(i:i) ) ) then s(i:i) = ' ' end if end do return end subroutine s_control_count ( s, ifound ) ! !******************************************************************************* ! !! S_CONTROL_COUNT returns the number of control characters in a string. ! ! ! Definition: ! ! A "control character" has ASCII code <= 31 or ASCII code => 127. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be searched. ! ! Output, integer IFOUND, the number of control characters. ! implicit none ! logical ch_is_control integer ifound integer i integer nchar character ( len = * ) s ! ifound = 0 nchar = len_trim ( s ) do i = 1, nchar if ( ch_is_control ( s(i:i) ) ) then ifound = ifound + 1 end if end do return end subroutine s_control_delete ( s ) ! !******************************************************************************* ! !! 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. ! ! Definition: ! ! A "control character" has ASCII code <= 31 or ASCII code => 127. ! ! 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 integer nchar character ( len = * ) s ! iput = 0 nchar = len_trim ( s ) do iget = 1, nchar 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 subroutine s_detag ( s ) ! !******************************************************************************* ! !! S_DETAG removes from a string all substrings marked by angle brackets. ! ! ! Example: ! ! Input: ! ! S = 'This is Italic whereas this is boldly not!' ! ! Output: ! ! S = ' whereas this is not!' ! ! Discussion: ! ! This routine was written to help extract some data that was hidden ! inside an elaborate HTML table. ! ! Modified: ! ! 18 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none ! integer i1 integer i2 integer i3 character ( len = * ) s ! do i3 = len_trim ( s ) if ( len_trim ( s ) == 0 ) then exit end if i1 = index ( s, '<' ) if ( i1 <= 0 .or. i1 >= i3 ) then exit end if i2 = index ( s(i1+1:), '>' ) if ( i2 == 0 ) then exit end if i2 = i2 + i1 ! ! Shift. ! s(i1:i3+i1-i2-1) = s(i2+1:i3) ! ! Pad. ! s(i3+i1-i2:) = ' ' end do return end function s_eqi ( s1, s2 ) ! !******************************************************************************* ! !! S_EQI is a case insensitive comparison of two strings for equality. ! ! ! Examples: ! ! S_EQI ( 'Anjana', 'ANJANA' ) is .TRUE. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, S2, the strings to compare. ! ! Output, logical S_EQI, the result of the comparison. ! implicit none ! character c1 character c2 integer i integer len1 integer len2 integer lenc logical s_eqi character ( len = * ) s1 character ( len = * ) s2 ! len1 = len ( s1 ) len2 = len ( s2 ) lenc = min ( len1, len2 ) s_eqi = .false. do i = 1, lenc c1 = s1(i:i) c2 = s2(i:i) call ch_cap ( c1 ) call ch_cap ( c2 ) if ( c1 /= c2 ) then return end if end do do i = lenc + 1, len1 if ( s1(i:i) /= ' ' ) then return end if end do do i = lenc + 1, len2 if ( s2(i:i) /= ' ' ) then return end if end do s_eqi = .true. return end function s_eqidb ( s1, s2 ) ! !******************************************************************************* ! !! S_EQIDB compares two strings, ignoring case and blanks. ! ! ! Examples: ! ! S_EQIDB ( 'Nor Way', 'NORway' ) is .TRUE. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Modified: ! ! 19 July 1998 ! ! Parameters: ! ! Input, character ( len = * ) S1, S2, the strings to compare. ! ! Output, logical S_EQIDB, the result of the comparison. ! implicit none ! character c1 character c2 integer i1 integer i2 integer len1 integer len2 logical s_eqidb character ( len = * ) s1 character ( len = * ) s2 ! ! Get the length of each string to the last nonblank. ! len1 = len_trim ( s1 ) len2 = len_trim ( s2 ) ! ! Assume we're going to fail. ! s_eqidb = .false. ! ! Initialize the pointers to characters in each string. ! i1 = 0 i2 = 0 do ! ! If we've matched all the nonblank characters in both strings, ! then return with S_EQIDB = .TRUE. ! if ( i1 == len1 .and. i2 == len2 ) then s_eqidb = .true. return end if ! ! Get the next nonblank character in the first string. ! do i1 = i1 + 1 if ( i1 > len1 ) then return end if if ( s1(i1:i1) /= ' ' ) then exit end if end do c1 = s1(i1:i1) call ch_cap ( c1 ) ! ! Get the next nonblank character in the second string. ! do i2 = i2 + 1 if ( i2 > len2 ) then return end if c2 = s2(i2:i2) if ( c2 /= ' ' ) then exit end if end do call ch_cap ( c2 ) if ( c1 /= c2 ) then exit end if end do return end subroutine s_fill ( s, c ) ! !******************************************************************************* ! !! S_FILL overwrites every character of a string by a given character. ! ! ! Modified: ! ! 28 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) S, the string to be overwritten. ! ! Input, character C, the overwriting character. ! implicit none ! character c integer i integer nchar character ( len = * ) s ! nchar = len ( s ) do i = 1, nchar s(i:i) = c end do return end function s_first_nonblank ( s ) ! !******************************************************************************* ! !! S_FIRST_NONBLANK returns the location of the first nonblank. ! ! ! Discussion: ! ! If all characters are blanks, a 0 is returned. ! ! Modified: ! ! 23 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be examined. ! ! Output, integer S_FIRST_NONBLANK, the location of the first ! nonblank character in the string, or 0 if all are blank. ! implicit none ! integer i character ( len = * ) s integer s_first_nonblank ! do i = 1, len ( s ) if ( s(i:i) /= ' ' ) then s_first_nonblank = i return end if end do s_first_nonblank = 0 return end function s_index_set ( s, s2 ) ! !******************************************************************************* ! !! S_INDEX_SET searches a string for any of a set of characters. ! ! ! Modified: ! ! 27 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be examined. ! ! Input, character ( len = * ) S2, the characters to search for. ! ! Output, integer S_INDEX_SET, the first location of a character from ! S2 in S, or 0 if no character from S2 occurs in S. ! implicit none ! integer i integer j integer k character ( len = * ) s character ( len = * ) s2 integer s_index_set ! j = len ( s ) + 1 do i = 1, len ( s2 ) k = index ( s, s2(i:i) ) if ( k /= 0 ) then j = min ( j, k ) end if end do if ( j == len ( s ) + 1 ) then j = 0 end if s_index_set = j return end function s_indexi ( s, sub ) ! !******************************************************************************* ! !! 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. ! ! 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 function s_index_last ( s, sub ) ! !******************************************************************************* ! !! S_INDEX_LAST finds the LAST occurrence of a given substring. ! ! ! Discussion: ! ! It 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! ! ! This means that this routine cannot be used to find, say, the last ! occurrence of a substring 'A ', since it assumes the blank space ! was not specified by the user, but is, rather, padding by the ! system. However, as a special case, this routine can properly handle ! the case where either S or SUB is all blanks. ! ! 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_INDEX_LAST. 0 if SUB does not occur in ! the string. Otherwise S_INDEX_LAST = I, where S(I:I+LENS-1) = SUB, ! where LENS is the length of SUB, and is the last place ! this happens. ! implicit none ! integer i integer j integer llen1 integer llen2 character ( len = * ) s integer s_index_last character ( len = * ) sub ! s_index_last = 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 j = 1, llen1+1-llen2 i = llen1 + 2 - llen2 - j if ( s(i:i+llen2-1) == sub ) then s_index_last = i return end if end do return end function s_gei ( s1, s2 ) ! !******************************************************************************* ! !! S_GEI = ( S1 is lexically greater than or equal to S2 ). ! ! ! Discussion: ! ! The comparison is done in a case-insensitive way. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, S2, the strings to compare. ! ! Output, logical S_GEI, the result of the comparison. ! implicit none ! character c1 character c2 integer i integer len1 integer len2 integer lenc logical s_gei character ( len = * ) s1 character ( len = * ) s2 ! len1 = len_trim ( s1 ) len2 = len_trim ( s2 ) lenc = min ( len1, len2 ) do i = 1, lenc c1 = s1(i:i) c2 = s2(i:i) call ch_cap ( c1 ) call ch_cap ( c2 ) if ( lgt ( c1, c2 ) ) then s_gei = .true. return else if ( llt ( c1, c2 ) ) then s_gei = .false. return end if end do if ( len1 < len2 ) then s_gei = .false. else s_gei = .true. end if return end function s_gti ( s1, s2 ) ! !******************************************************************************* ! !! S_GTI = ( S1 is lexically greater than S2 ). ! ! ! Discussion: ! ! The comparison is done in a case-insensitive way. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, S2, the strings to compare. ! ! Output, logical S_GTI, the result of the comparison. ! implicit none ! character c1 character c2 integer i integer len1 integer len2 integer lenc logical s_gti character ( len = * ) s1 character ( len = * ) s2 ! len1 = len ( s1 ) len2 = len ( s2 ) lenc = min ( len1, len2 ) do i = 1, lenc c1 = s1(i:i) c2 = s2(i:i) call ch_cap ( c1 ) call ch_cap ( c2 ) if ( lgt ( c1, c2 ) ) then s_gti = .true. return else if ( llt ( c1, c2 ) ) then s_gti = .false. return end if end do if ( len1 <= len2 ) then s_gti = .false. else s_gti = .true. end if return end subroutine s_input ( string, value, ierror ) ! !******************************************************************************* ! !! S_INPUT prints a prompt string and reads a string from the user. ! ! ! Discussion: ! ! If the input line starts with a comment character ('#'), or is blank, ! the routine ignores that line, and tries to read the next one. ! ! Modified: ! ! 27 March 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) STRING, the prompt string. ! ! Output, character ( len = * ) VALUE, the value input by the user. ! ! Output, integer IERROR, an error flag, which is zero if no error occurred. ! implicit none ! integer ierror character ( len = 80 ) line character ( len = * ) string character ( len = * ) value ! ierror = 0 value = ' ' ! ! Write the prompt. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( string ) do read ( *, '(a)', iostat = ierror ) line if ( ierror /= 0 ) then value = 'S_INPUT: Input error!' return end if ! ! If the line begins with a comment character, go back and read the next line. ! if ( line(1:1) == '#' ) then cycle end if if ( len_trim ( line ) == 0 ) then cycle end if value = line exit end do return end function s_is_alpha ( s ) ! !******************************************************************************* ! !! S_IS_ALPHA returns .TRUE. if the string contains only alphabetic characters. ! ! ! Discussion: ! ! Here, alphabetic characters are 'A' through 'Z' and 'a' through 'z'. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be checked. ! ! Output, logical S_IS_ALPHA, .TRUE. if the string contains only ! alphabetic characters, .FALSE. otherwise. ! implicit none ! logical ch_is_alpha integer i character ( len = * ) s logical s_is_alpha ! s_is_alpha = .false. do i = 1, len ( s ) if ( .not. ch_is_alpha ( s(i:i) ) ) then return end if end do s_is_alpha = .true. return end function s_is_alphanumeric ( s ) ! !******************************************************************************* ! !! S_IS_ALPHANUMERIC = string contains only alphanumeric characters. ! ! ! Discussion: ! ! Alphanumeric characters are 'A' through 'Z', 'a' through 'z' and ! '0' through '9'. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be checked. ! ! Output, logical S_IS_ALPHANUMERIC, .TRUE. if the string contains only ! alphabetic characters and numerals, .FALSE. otherwise. ! implicit none ! integer i integer itemp character ( len = * ) s logical s_is_alphanumeric ! s_is_alphanumeric = .false. do i = 1, len ( s ) itemp = ichar ( s(i:i) ) if ( .not. ( itemp >= 65 .and. itemp <= 90 ) ) then if ( .not. ( itemp >= 97 .and. itemp <= 122 ) ) then if ( .not. ( itemp >= 48 .and. itemp <= 57 ) ) then return end if end if end if end do s_is_alphanumeric = .true. return end function s_is_digit ( s ) ! !******************************************************************************* ! !! S_IS_DIGIT returns .TRUE. if a string contains only decimal digits. ! ! ! Discussion: ! ! This is a strict comparison. ! The check is made from the first character to the last nonblank. ! Each character in between must be one of '0', '1', ..., '9'. ! ! Modified: ! ! 14 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be checked. ! ! Output, logical S_IS_DIGIT, .TRUE. if S contains only ! digits, and .FALSE. otherwise. ! implicit none ! character c integer i integer lenc character ( len = * ) s logical s_is_digit ! lenc = len_trim ( s ) s_is_digit = .false. do i = 1, lenc c = s(i:i) if ( llt ( c, '0' ) .or. lgt ( c, '9' ) ) then return end if end do s_is_digit = .true. return end function s_is_f77_name ( s ) ! !******************************************************************************* ! !! S_IS_F77_NAME = input string represent a legal FORTRAN-77 identifier. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be examined. ! ! Output, logical S_IS_F77_NAME, is TRUE if the string is a legal FORTRAN-77 ! identifier. That is, the string must begin with an alphabetic ! character, and all subsequent characters must be alphanumeric. ! The string may terminate with blanks. No underscores are allowed. ! implicit none ! logical ch_is_alpha integer lenc character ( len = * ) s logical s_is_alphanumeric logical s_is_f77_name ! s_is_f77_name = .false. lenc = len_trim ( s ) if ( lenc <= 0 ) then return end if if ( .not. ch_is_alpha ( s(1:1) ) ) then return end if if ( .not. s_is_alphanumeric ( s(2:lenc) ) ) then return end if s_is_f77_name = .true. return end function s_is_f90_name ( s ) ! !******************************************************************************* ! !! S_IS_F90_NAME = input string represent a legal FORTRAN 90 identifier. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be examined. ! ! Output, logical S_IS_F90_NAME, is TRUE if the string is a legal ! FORTRAN 90 identifier. That is, the string must begin with an alphabetic ! character, and all subsequent characters must be alphanumeric ! or underscores. The string may terminate with blanks. ! implicit none ! logical ch_is_alpha integer i integer lenc logical malphnum2 character ( len = * ) s logical s_is_f90_name ! s_is_f90_name = .false. lenc = len_trim ( s ) if ( lenc <= 0 ) then return end if if ( .not. ch_is_alpha ( s(1:1) ) ) then return end if do i = 2, lenc if ( .not. malphnum2 ( s(i:i) ) ) then return end if end do s_is_f90_name = .true. return end function s_is_i ( s, i ) ! !******************************************************************************* ! !! S_IS_I is TRUE if a string represents an integer. ! ! ! Modified: ! ! 14 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be checked. ! ! Output, integer I. If the string represents an integer, I is the ! integer represented. Otherwise I is 0. ! ! Output, logical S_IS_I, .TRUE. if the string represents an integer. ! implicit none ! integer i integer ierror integer lchar integer lenc character ( len = * ) s logical s_is_i ! lenc = len_trim ( s ) call s_to_i ( s, i, ierror, lchar ) if ( ierror == 0 .and. lchar >= lenc ) then s_is_i = .true. else s_is_i = .false. i = 0 end if return end subroutine s_is_r ( s, r, lval ) ! !******************************************************************************* ! !! S_IS_R is TRUE if a string represents a real number. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be checked. ! ! Output, real R. If the string represents a real number, then R ! is the real number represented. Otherwise R is 0. ! ! Output, logical LVAL, is TRUE if the string represents a real number. ! implicit none ! integer ierror integer lchar integer lenc logical lval real r character ( len = * ) s ! lenc = len_trim ( s ) call s_to_r ( s, r, ierror, lchar ) if ( ierror == 0 .and. lchar >= lenc ) then lval = .true. else lval = .false. r = 0.0E+00 end if return end subroutine s_left ( s ) ! !******************************************************************************* ! !! S_LEFT flushes a string left. ! ! ! Discussion: ! ! Both blanks and tabs are treated as "white space". ! ! Examples: ! ! Input Output ! ! ' Hello' 'Hello ' ! ' Hi there! ' 'Hi there! ' ! 'Fred ' 'Fred ' ! ! Modified: ! ! 31 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S. ! ! On input, S is a string of characters. ! ! On output, any initial blank or tab characters have been cut. ! implicit none ! integer i integer lchar integer nonb character ( len = * ) s character, parameter :: TAB = char ( 9 ) ! ! Check the length of the string to the last nonblank. ! If nonpositive, return. ! lchar = len_trim ( s ) if ( lchar <= 0 ) then return end if ! ! Find NONB, the location of the first nonblank, nontab. ! nonb = 0 do i = 1, lchar if ( s(i:i) /= ' ' .and. s(i:i) /= TAB ) then nonb = i exit end if end do if ( nonb == 0 ) then s = ' ' return end if ! ! Shift the string left. ! if ( nonb > 1 ) then do i = 1, lchar + 1 - nonb s(i:i) = s(i+nonb-1:i+nonb-1) end do end if ! ! Blank out the end of the string. ! s(lchar+2-nonb:lchar) = ' ' return end function s_lei ( s1, s2 ) ! !******************************************************************************* ! !! S_LEI = ( S1 is lexically less than or equal to S2 ). ! ! ! Discussion: ! ! The comparison is done in a case-insensitive way. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, S2, the strings to compare. ! ! Output, logical S_LEI, the result of the comparison. ! implicit none ! character c1 character c2 integer i integer len1 integer len2 integer lenc logical s_lei character ( len = * ) s1 character ( len = * ) s2 ! len1 = len ( s1 ) len2 = len ( s2 ) lenc = min ( len1, len2 ) do i = 1, lenc c1 = s1(i:i) c2 = s2(i:i) call ch_cap ( c1 ) call ch_cap ( c2 ) if ( llt ( c1, c2 ) ) then s_lei = .true. return else if ( lgt ( c1, c2 ) ) then s_lei = .false. return end if end do if ( len1 <= len2 ) then s_lei = .true. else s_lei = .false. end if return end subroutine s_low ( s ) ! !******************************************************************************* ! !! S_LOW replaces all uppercase letters by lowercase ones. ! ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be ! transformed. On output, the string is all lowercase. ! implicit none ! integer i integer nchar character ( len = * ) s ! nchar = len_trim ( s ) do i = 1, nchar call ch_low ( s(i:i) ) end do return end function s_lti ( s1, s2 ) ! !******************************************************************************* ! !! S_LTI = ( S1 is lexically less than S2 ). ! ! ! Discussion: ! ! The comparison is done in a case-insensitive way. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, S2, the strings to compare. ! ! Output, logical S_LTI, the result of the comparison. ! implicit none ! character c1 character c2 integer i integer len1 integer len2 integer lenc logical s_lti character ( len = * ) s1 character ( len = * ) s2 ! len1 = len ( s1 ) len2 = len ( s2 ) lenc = min ( len1, len2 ) do i = 1, lenc c1 = s1(i:i) c2 = s2(i:i) call ch_cap ( c1 ) call ch_cap ( c2 ) if ( llt ( c1, c2 ) ) then s_lti = .true. return else if ( lgt ( c1, c2 ) ) then s_lti = .false. return end if end do if ( len1 < len2 ) then s_lti = .true. else s_lti = .false. end if return end function s_nei ( s1, s2 ) ! !******************************************************************************* ! !! S_NEI compares two strings for non-equality, ignoring case. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, S2, the strings to compare. ! ! Output, logical S_NEI, the result of the comparison. ! implicit none ! character c1 character c2 integer i integer len1 integer len2 integer lenc logical s_nei character ( len = * ) s1 character ( len = * ) s2 ! len1 = len ( s1 ) len2 = len ( s2 ) lenc = min ( len1, len2 ) s_nei = .true. do i = 1, lenc c1 = s1(i:i) c2 = s2(i:i) call ch_cap ( c1 ) call ch_cap ( c2 ) if ( c1 /= c2 ) then return end if end do do i = lenc+1, len1 if ( s1(i:i) /= ' ' ) then return end if end do do i = lenc+1, len2 if ( s2(i:i) /= ' ' ) then return end if end do s_nei = .false. return end function s_no_control ( s ) ! !******************************************************************************* ! !! S_NO_CONTROL = string contains no control characters. ! ! ! Discussion: ! ! Non-control characters are ASCII codes 32 through 127 inclusive. ! ! Modified: ! ! 05 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, is the string to be checked. ! ! Output, logical S_NO_CONTROL, is TRUE if S contains only printable ! characters, FALSE otherwise. ! implicit none ! logical ch_is_control integer i logical s_no_control character ( len = * ) s ! s_no_control = .false. do i = 1, len ( s ) if ( ch_is_control ( s(i:i) ) ) then return end if end do s_no_control = .true. return end function s_of_i ( i ) ! !******************************************************************************* ! !! S_OF_I converts an integer to a left-justified string. ! ! ! Examples: ! ! I S ! ! 1 1 ! -1 -1 ! 0 0 ! 1952 1952 ! 123456 123456 ! ! Modified: ! ! 13 February 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, an integer to be converted. ! ! Output, character ( len = 11 ) S_OF_I, the representation of the ! integer. The integer will be left-justified. ! implicit none ! character c integer i integer idig integer ihi integer ilo integer ipos integer ival integer j character ( len = 11 ) s character ( len = 11 ) s_of_i ! s = ' ' ilo = 1 ihi = 11 ! ! Make a copy of the integer. ! ival = i ! ! Handle the negative sign. ! if ( ival < 0 ) then if ( ihi <= 1 ) then s(1:1) = '*' return end if ival = - ival s(1:1) = '-' ilo = 2 end if ! ! The absolute value of the integer goes into S(ILO:IHI). ! ipos = ihi ! ! Find the last digit, strip it off, and stick it into the string. ! do idig = mod ( ival, 10 ) ival = ival / 10 if ( ipos < ilo ) then do j = 1, ihi s(j:j) = '*' end do return end if call digit_to_ch ( idig, c ) s(ipos:ipos) = c ipos = ipos - 1 if ( ival == 0 ) then exit end if end do ! ! Shift the string to the left. ! s(ilo:ilo+ihi-ipos-1) = s(ipos+1:ihi) s(ilo+ihi-ipos:ihi) = ' ' s_of_i = s return end function s_only_alphab ( s ) ! !******************************************************************************* ! !! 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. ! ! 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 ) ! !******************************************************************************* ! !! S_ONLY_DIGITB returns .TRUE. if the string contains only digits or blanks. ! ! ! 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_overlap ( s1, s2, overlap ) ! !******************************************************************************* ! !! S_OVERLAP determines the overlap between two strings. ! ! ! Discussion: ! ! To determine the overlap, write the first word followed immediately ! by the second word. Find the longest substring S which is both ! a suffix of S1 and a prefix of S2. The length of this substring ! is the overlap. ! ! Examples: ! ! S1 S2 OVERLAP ! ! 'timber' 'beret' 3 ! 'timber' 'timber' 6 ! 'beret' 'timber' 1 ! 'beret' 'berets' 5 ! 'beret' 'berth' 0 ! ! Modified: ! ! 04 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, S2, the strings to be checked. ! ! Output, integer OVERLAP, the length of the overlap. ! implicit none ! integer i integer len1 integer len2 integer len3 integer overlap character ( len = * ) s1 character ( len = * ) s2 ! overlap = 0 len1 = len_trim ( s1 ) len2 = len_trim ( s2 ) len3 = min ( len1, len2 ) do i = 1, len3 if ( s1(len1+1-i:len1) == s2(1:i) ) then overlap = i end if end do return end function s_paren_check ( s ) ! !******************************************************************************* ! !! S_PAREN_CHECK checks the parentheses in a string. ! ! ! Discussion: ! ! Blanks are removed from the string, and then the following checks ! are made: ! ! 1) as we read the string left to right, there must never be more ! right parentheses than left ones; ! 2) there must be an equal number of left and right parentheses; ! 3) there must be no occurrences of the abutting packages '...)(...'. ! 4) there must be no occurrences of the empty package '()'. ! ! Modified: ! ! 20 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to check. ! ! Output, logical S_PAREN_CHECK is TRUE if the string passed the checks. ! implicit none ! integer i integer isum character ( len = * ) s character ( len = 256 ) s_copy integer s_len logical s_paren_check ! s_copy = s call s_blank_delete ( s_copy) s_len = len_trim ( s_copy ) ! ! 1) Letting '(' = +1 and ')' = -1, check that the running parentheses sum ! is always nonnegative. ! isum = 0 do i = 1, s_len if ( s_copy(i:i) == '(' ) then isum = isum + 1 end if if ( s_copy(i:i) == ')' ) then isum = isum - 1 if ( isum < 0 ) then s_paren_check = .false. return end if end if end do ! ! 2) Check that the final parentheses sum is zero. ! if ( isum /= 0 ) then s_paren_check = .false. return end if ! ! 3) Check that there are no ")(" pairs. ! do i = 2, s_len if ( s_copy(i-1:i) == ')(' ) then s_paren_check = .false. return end if end do ! ! 4) Check that there are no "()" pairs. ! do i = 2, s_len if ( s_copy(i-1:i) == '()' ) then s_paren_check = .false. return end if end do ! ! The checks were passed. ! s_paren_check = .true. return end subroutine s_plot ( angle, cwide, pwide, s, x, y, flush ) ! !******************************************************************************* ! !! S_PLOT plots a character string onto a graphics image. ! ! ! Discussion: ! ! The string can be at any angle and at any size. ! ! The plot is assumed to be of size PWIDE by PHITE, although PHITE ! itself is not input. ! ! Warning: ! ! This routine must be modified to work with a particular graphics package. ! The current code calls two routines: ! MOVCGM ( X, Y ) moves to a point (X,Y) in the plot; ! DRWCGM ( X, Y ) draws a line from the current point to (X,Y). ! ! Modified: ! ! 21 November 2000 ! ! Parameters: ! ! Input, real ANGLE, the angle in degrees at which the ! string is to be drawn. 0 is typical. 90 degrees would ! cause the string to be written from top to bottom. ! ! Input, real CWIDE, the width of the characters. This ! is measured in the same units as the plot width PWIDE. ! For PWIDE = 1, a plot size of 0.025 would be reasonable, ! since 40 characters would fit, but 2.0 would be nonsense. ! ! Input, real PWIDE, the width of the plot, in the same ! units as CWIDE. ! ! Input, character ( len = * ) S, contains the text to be plotted. ! Only characters with ASCII codes between 32 and 126 will actually ! be plotted. Any other characters are "unprintable", and will be ! plotted as blanks. ! ! Input, real X, Y, the coordinates of a point which ! determines where the string is drawn. The string will ! be drawn starting at, centered or, or ending at (X,Y), ! depending on the value of FLUSH. ! ! Input, character ( len = * ) FLUSH, a string which specifies how to ! place the string. Only the first character of FLUSH is examined, and ! the case of the character is not important. ! ! 'L' - the string will be drawn flush left. ! 'C' - the string will be centered. ! 'R' - the string will be drawn flush right. ! implicit none ! real angle real ca character c real cwide real degrees_to_radians character ( len = * ) flush integer i integer iascii integer icr integer, save, dimension ( 1617 ) :: ifont integer ip integer ipen integer, save, dimension ( 95 ) :: ipoint integer iv integer nchar integer nmax integer nvec real pwide logical rotate character ( len = * ) s real sa real scl2 real x real xb real xc real xcopy real xnew real xold real xrot real xt real y real yb real yc real ycopy real ynew real yold real yrot real yt ! ! IPOINT is a pointer array into IFONT. ! ! IPOINT(I) records where the "strokes" for character I begin ! in the IFONT array. ! data ( ipoint(i), i = 1, 95 ) / & 1, 3, 26, 45, 66, 102, 130, 156, 166, 186, 206, 222, 233, & 249, 255, 267, 273, 293, 306, 328, 353, 363, 383, 411, 423, 457, & 483, 506, 533, 541, 552, 560, 587, 625, 638, 665, 683, 699, 714, & 727, 754, 770, 786, 805, 818, 826, 838, 848, 868, 884, 909, 930, & 956, 967, 981, 989,1001,1012,1025,1035,1045,1051,1061,1069,1075, & 1081,1108,1131,1149,1172,1194,1214,1243,1260,1284,1307,1323,1336, & 1364,1381,1401,1424,1447,1464,1486,1499,1516,1524,1536,1547,1560, & 1570,1586,1592,1608 / ! ! IFONT contains the strokes defining the various symbols. ! data ( ifont(i), i = 1, 396 ) / & 1, 0, 2,10,11, 9,22,10,23,11,22,10,11, 0, 9, 7, 9, 9,11, 9,11, 7, & 9, 7, 0, 2, 8,17, 7,23, 9,23, 8,17, 0,14,17,13,23,15,23,14,17, 0, & 4, 9,23, 7, 7, 0,13,23,11, 7, 0, 5,17,15,17, 0, 5,13,15,13, 0, 3, & 15,19,13,21, 9,21, 7,19, 7,17, 9,15,13,15,15,13,15,11,13, 9, 9, 9, & 7,11, 0, 9,23, 9, 7, 0,13,23,13, 7, 0, 3, 5,23, 9,23, 9,19, 5,19, & 5,23, 0,17,23, 5, 7, 0,13, 7,13,11,17,11,17, 7,13, 7, 0, 1,17, 7, & 7,17, 7,19, 9,21,13,21,15,19,15,17, 5,13, 5,11, 9, 7,13, 7,17,15, & 0, 1,10,17, 9,23,11,23,10,17, 0, 1,12,23,11,21,10,19, 9,17, 9,15, & 9,13,10,11,11, 9,12, 7, 0, 1,12,23,13,21,14,19,15,17,15,15,15,13, & 14,11,13, 9,12, 7, 0, 3, 7,15,15,15, 0,13,19, 9,11, 0, 9,19,13,11, & 0, 2, 7,15,15,15, 0,11,19,11,11, 0, 1,11, 7, 9, 7, 9, 9,11, 9,11, & 7,11, 6,10, 4, 0, 1, 7,15,15,15, 0, 1, 9, 7, 9, 9,11, 9,11, 7, 9, & 7, 0, 1,15,23, 7, 7, 0, 1, 9,23,13,23,15,19,15,11,13, 7, 9, 7, 7, & 11, 7,19, 9,23, 0, 2, 7,21, 9,23, 9, 7, 0, 7, 7,11, 7, 0, 1, 5,21, & 9,23,15,23,17,21,17,19,15,17, 7,13, 5,10, 5, 7,17, 7, 0, 2, 5,23, & 17,23,15,17,13,15, 9,15, 0,13,15,17,13,17,10,14, 7, 8, 7, 5,10, 0, & 1,13, 7,13,23, 5,13,17,13, 0, 1,17,23, 5,23, 5,17,13,17,17,15,17, & 11,13, 7, 9, 7, 5,11, 0, 1,17,19,13,23, 9,23, 5,19, 5,13, 9,15,13 / data ( ifont(i), i = 397, 792 ) / & 15,17,13,17,11,13, 7, 9, 7, 5,11, 5,13, 0, 1, 5,19, 5,23,17,23,11, & 15,11, 7, 0, 1, 8,15, 6,17, 6,21, 8,23,14,23,16,21,16,17,14,15, 8, & 15, 5,13, 5, 9, 8, 7,14, 7,17, 9,17,13,14,15, 0, 1,17,17,15,15, 7, & 15, 5,17, 5,21, 7,23,15,23,17,21,17,11,15, 7, 7, 7, 5,11, 0, 2, 9, & 13, 9,15,11,15,11,13, 9,13, 0, 9, 7, 9, 9,11, 9,11, 7, 9, 7, 0, 2, & 9,13, 9,15,11,15,11,13, 9,13, 0,11, 7, 9, 7, 9, 9,11, 9,11, 7,11, & 6,10, 4, 0, 1,17,21, 5,15,17, 9, 0, 2, 7,15,15,15, 0, 7, 9,15, 9, & 0, 1, 5,21,17,15, 5, 9, 0, 2, 7,21, 9,23,13,23,15,21,15,19,11,15, & 11,11, 0,10, 7,10, 9,12, 9,12, 7,10, 7, 0, 1,13, 7, 9, 7, 5,11, 5, & 19, 9,23,13,23,17,19,17,11,15, 9,13,11,12,10,10,10, 9,11, 9,15,10, & 16,12,16,13,15,13,11, 0, 2, 5, 7,11,23,17, 7, 0, 8,15,14,15, 0, 2, & 5, 7, 5,23,15,23,17,21,17,17,15,15, 5,15, 0,15,15,17,13,17, 9,15, & 7, 5, 7, 0, 1,17,19,13,23, 9,23, 5,19, 5,11, 9, 7,13, 7,17,11, 0, & 1, 5, 7, 5,23,13,23,17,19,17,11,13, 7, 5, 7, 0, 2,17,23, 5,23, 5, & 7,17, 7, 0, 5,15,12,15, 0, 2, 5, 7, 5,23,17,23, 0, 5,15,12,15, 0, & 2,17,19,13,23, 9,23, 5,19, 5,11, 9, 7,13, 7,17,11,17,15,13,15, 0, & 17,11,17, 7, 0, 3, 5, 7, 5,23, 0, 5,15,17,15, 0,17,23,17, 7, 0, 3, & 9,23,13,23, 0,11,23,11, 7, 0, 9, 7,13, 7, 0, 2,15,23,15,11,12, 7 / data ( ifont(i), i = 793, 1188 ) / & 8, 7, 5,11, 5,13, 0,13,23,17,23, 0, 2, 5, 7, 5,23, 0,17,23, 5,15, & 17, 7, 0, 1, 5,23, 5, 7,17, 7, 0, 1, 5, 7, 5,23,11,11,17,23,17, 7, & 0, 1, 5, 7, 5,23,17, 7,17,23, 0, 1,17,19,13,23, 9,23, 5,19, 5,11, & 9, 7,13, 7,17,11,17,19, 0, 1, 5, 7, 5,23,13,23,17,21,17,17,13,15, & 5,15, 0, 2,17,19,13,23, 9,23, 5,19, 5,11, 9, 7,13, 7,17,11,17,19, & 0,13,11,17, 7, 0, 2, 5, 7, 5,23,13,23,17,21,17,17,13,15, 5,15, 0, & 13,15,17, 7, 0, 1,17,19,13,23, 9,23, 5,20, 5,18, 9,15,13,15,17,12, & 17,10,13, 7, 9, 7, 5,10, 0, 2, 5,23,17,23, 0,11,23,11, 7, 0, 1, 5, & 23, 5,10, 8, 7,14, 7,17,10,17,23, 0, 1, 5,23,11, 7,17,23, 0, 1, 5, & 23, 8, 7,11,17,14, 7,17,23, 0, 2, 5,23,17, 7, 0,17,23, 5, 7, 0, 2, & 5,23,11,13,17,23, 0,11,13,11, 7, 0, 1, 5,23,17,23, 5, 7,17, 7, 0, & 1,11,23, 7,23, 7, 7,11, 7, 0, 1, 7,23,15, 7, 0, 1, 7,23,11,23,11, & 7, 7, 7, 0, 1, 7,21,11,23,15,21, 0, 1, 5, 3,17, 3, 0, 1, 9,23,13, & 19, 0, 2, 7,14, 9,15,13,15,15,14,15, 7, 0,15,12, 9,12, 7,11, 7, 8, & 9, 7,13, 7,15, 8, 0, 2, 7,23, 7, 7, 0, 7,13, 9,15,13,15,15,13,15, & 9,13, 7, 9, 7, 7, 9, 0, 1,15,13,13,15, 9,15, 7,13, 7, 9, 9, 7,13, & 7,15, 9, 0, 2,15,13,13,15, 9,15, 7,13, 7, 9, 9, 7,13, 7,15, 9, 0, & 15,23,15, 7, 0, 1, 7,11,15,11,15,13,13,15, 9,15, 7,13, 7, 9, 9, 7 / data ( ifont(i), i = 1189, 1584 ) / & 13, 7,15, 9, 0, 3, 9, 7, 9,23,13,23,13,22, 0, 8,15,12,15, 0, 8, 7, & 11, 7, 0, 2,15,13,13,15, 9,15, 7,13, 7, 9, 9, 7,13, 7,15, 9, 0,15, & 13,15, 3,13, 1, 9, 1, 7, 3, 0, 2, 7, 7, 7,23, 0, 7,14, 9,15,13,15, & 15,14,15, 7, 0, 3, 9,15,11,15,11, 7, 0, 9, 7,13, 7, 0, 9,17, 9,19, & 11,19,11,17, 9,17, 0, 2, 9,15,11,15,11, 1, 7, 1, 7, 3, 0, 9,17,11, & 17,11,19, 9,19, 9,17, 0, 3, 7, 7, 7,23, 0,15,15, 7,10, 0, 9,11,15, & 7, 0, 2, 9,23,11,23,11, 7, 0, 9, 7,13, 7, 0, 3, 7,15, 7, 7, 0, 7, & 14, 8,15,10,15,11,14,11, 7, 0,11,14,12,15,14,15,15,14,15, 7, 0, 2, & 7, 7, 7,15, 0, 7,14, 9,15,13,15,15,14,15, 7, 0, 1, 7,13, 9,15,13, & 15,15,13,15, 9,13, 7, 9, 7, 7, 9, 7,13, 0, 2, 7,13, 9,15,13,15,15, & 13,15, 9,13, 7, 9, 7, 7, 9, 0, 7,14, 7, 1, 0, 2,15,13,13,15, 9,15, & 7,13, 7, 9, 9, 7,13, 7,15, 9, 0,15,14,15, 1, 0, 2, 7,15, 9,15, 9, & 7, 0, 9,13,11,15,13,15,15,13, 0, 1,15,13,13,15, 9,15, 7,13, 9,11, & 13,11,15, 9,13, 7, 9, 7, 7, 9, 0, 2, 9,23, 9, 7,11, 7, 0, 7,17,11, & 17, 0, 2, 7,15, 7, 9, 9, 7,13, 7,15, 9, 0,15,15,15, 7, 0, 1, 7,15, & 11, 7,15,15, 0, 1, 7,15, 9, 7,11,11,13, 7,15,15, 0, 2, 7,15,15, 7, & 0, 7, 7,15,15, 0, 2, 7,15,11, 7, 0,15,15,10, 5, 7, 1, 0, 1, 7,15, & 15,15, 7, 7,15, 7, 0, 1,11,23, 7,23, 9,17, 7,15, 9,13, 7, 7,11, 7 / data ( ifont(i), i = 1585, 1617 ) / & 0, 1, 9,23, 9, 7, 0, 1, 7,23,11,23, 9,17,11,15, 9,13,11, 7, 7, 7, & 0, 1, 5,21, 7,23,15,21,17,23, 0 / ! nchar = len_trim ( s ) if ( pwide <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_PLOT - Serious error!' write ( *, '(a)' ) ' The plot width PWIDE is negative!' write ( *, '(a,g14.6)' ) ' PWIDE = ', pwide return end if ! ! Chop titles that are too long. To do this, we need to know the ! width of the plot (PWIDE) in same units as CWIDE. ! nmax = int ( pwide / cwide ) if ( nchar > nmax ) then nchar = nmax end if ! ! Shift string if centering or right flush option used. ! if ( flush(1:1) == 'l' .or. flush(1:1) == 'L' ) then xcopy = x ycopy = y else if ( flush(1:1) == 'c' .or. flush(1:1) == 'C' ) then xcopy = x - 0.5E+00 * nchar * cwide * cos ( degrees_to_radians ( angle ) ) ycopy = y - 0.5E+00 * nchar * cwide * sin ( degrees_to_radians ( angle ) ) else if ( flush(1:1) == 'r' .or. flush(1:1) == 'R' ) then xcopy = x - nchar * cwide * cos ( degrees_to_radians ( angle ) ) ycopy = y - nchar * cwide * sin ( degrees_to_radians ( angle ) ) else xcopy = x ycopy = y end if ! ! Note that screen coordinates are used. ! Thus a width of 0.1 is intended to mean 1/10 of screen size. ! ! Set the scale factor for character height. ! scl2 = cwide / 16.0E+00 ! ! Set the starting point for the line of text, the lower left ! corner of the first character. ! ! Set the origin about which rotation is performed. ! xb = xcopy xrot = xcopy yb = ycopy yrot = ycopy ! ! Get trig functions if rotation required, converting from ! degrees to radians. ! if ( angle == 0.0E+00 ) then rotate = .false. else ca = cos ( degrees_to_radians ( angle ) ) sa = sin ( degrees_to_radians ( angle ) ) rotate = .true. end if ! ! Loop over all characters in the string. ! do icr = 1, nchar xold = x yold = y xnew = x ynew = y ! ! Get the ASCII code for the character and shift by 31 so that ! the first printable character becomes code 1. ! c = s(icr:icr) iascii = ichar ( c ) - 31 ! ! Replace any nonprintable characters with blanks. ! if ( iascii < 1 .or. iascii > 95 ) then iascii = 1 end if ! ! Get the pointer to this character in font table. ! ip = ipoint(iascii) ! ! Get the number of "vectors" required to draw the character. ! Here "vectors" means the number of times the pen is lowered, not ! the number of pen strokes. ! ! For blanks, this number is 1, due to the way the ! algorithm is coded. ! nvec = ifont(ip) ! ! Loop over all required pen movements. ! do iv = 1, nvec ipen = 3 ip = ip + 1 do while ( ifont(ip) /= 0 ) xc = xb + scl2 * ( ifont(ip) - 1 ) yc = yb + scl2 * ( ifont(ip+1) - 7 ) ! ! Apply rotation if necessary. ! if ( rotate ) then xt = xc - xrot yt = yc - yrot xc = xrot + ca * xt - sa * yt yc = yrot + sa * xt + ca * yt end if ! ! Plot the pen stroke. ! if ( ipen == 3 ) then xnew = xc ynew = yc else xold = xnew yold = ynew xnew = xc ynew = yc call movcgm ( xold, yold ) call drwcgm ( xnew, ynew ) end if ipen = 2 ip = ip + 2 end do end do ! ! Advance the base to compensate for character just drawn. ! xb = xb + cwide end do return end subroutine s_rep_ch ( s, c1, c2 ) ! !******************************************************************************* ! !! S_REP_CH replaces all occurrences of one character by another. ! ! ! Modified: ! ! 27 March 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string. ! ! Input, character C1, C2, the character to be replaced, and the ! replacement character. ! implicit none ! character c1 character c2 integer i character ( len = * ) s ! do i = 1, len ( s ) if ( s(i:i) == c1 ) then s(i:i) = c2 end if end do return end subroutine s_rep_rec ( s, sub1, sub2, irep ) ! !******************************************************************************* ! !! S_REP_REC is a recursive replacement of one string by another. ! ! ! Discussion: ! ! All occurrences of SUB1 should be replaced by SUB2. ! This is not always true if SUB2 is longer than SUB1. ! The replacement is recursive. In other words, replacing all ! occurrences of "ab" by "a" in "abbbbb" will return "a" rather ! than "abbbb". ! ! Modified: ! ! 27 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S. On input, ! the string in which occurrences are to be replaced. On ! output, the revised string. ! ! Input, character ( len = * ) SUB1, the string which is to be replaced. ! ! Input, character ( len = * ) SUB2, the replacement string. ! ! Output, integer IREP, the number of replacements made. ! If IREP is negative, then its absolute value is the ! number of replacements made, and SUB2 is longer than ! SUB1, and at least one substring SUB1 could not be ! replaced by SUB2 because there was no more space in ! S. (If S = 'aab' and SUB1 = 'a' and SUB2 = 'cc' ! then the result would be S = 'cca'. The first 'a' ! was replaced, the 'b' fell off the end, the second 'a' ! was not replaced because the replacement 'cc' would ! have fallen off the end) ! implicit none ! integer irep integer len1 integer len2 integer lens integer loc character ( len = * ) s character ( len = * ) sub1 character ( len = * ) sub2 ! irep = 0 lens = len ( s ) if ( lens <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_REP_REC - Serious error!' write ( *, '(a)' ) ' Null string not allowed!' return end if len1 = len ( sub1 ) if ( len1 <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_REP_REC - Serious error!' write ( *, '(a)' ) ' Null SUB1 not allowed!' return end if len2 = len ( sub2 ) if ( len2 == len1 ) then if ( sub1 == sub2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_REP_REC - Warning!' write ( *, '(a)' ) ' Replacement = original!' return end if do loc = index ( s, sub1 ) if ( loc == 0 ) then exit end if irep = irep + 1 s(loc:loc+len1-1) = sub2 end do else if ( len2 < len1 ) then do loc = index ( s, sub1 ) if ( loc == 0 ) then exit end if irep = irep + 1 s(loc:loc+len2-1) = sub2 call s_chop ( s, loc+len2, loc+len1-1 ) end do else do loc = index ( s, sub1 ) if ( loc == 0 ) then exit end if irep = irep + 1 if ( loc + len2 - 1 > lens ) then irep = - irep write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_REP_REC - Warning!' write ( *, '(a)' ) ' Some replaceable elements remain!' return end if call s_blanks_insert ( s, loc, loc+len2-1-len1 ) s(loc:loc+len2-1) = sub2 end do end if return end subroutine s_rep ( s, sub1, sub2, irep ) ! !******************************************************************************* ! !! S_REP replaces all occurrences of SUB1 by SUB2 in a string. ! ! ! Discussion: ! ! This is not always true if SUB2 is longer than SUB1. The ! replacement is NOT recursive. In other words, replacing all ! occurrences of "ab" by "a" in "abbbbb" will return "abbbb" ! rather than "a". ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S. On input, ! the string in which occurrences are to be replaced. ! On output, the revised string. ! ! Input, character ( len = * ) SUB1, the string which is to be replaced. ! Trailing blank characters are ignored. The routine is case sensitive. ! ! Input, character ( len = * ) SUB2, the replacement string. ! ! Output, integer IREP, the number of replacements made. ! If IREP is negative, then its absolute value is the ! number of replacements made, and SUB2 is longer than ! SUB1, and at least one substring SUB1 could not be ! replaced by SUB2 because there was no more space. ! (If S = 'aab' and SUB1 = 'a' and SUB2 = 'cc' ! then the result would be S = 'cca'. The first 'a' ! was replaced, the 'b' fell off the end, the second 'a' ! was not replaced because the replacement 'cc' would have ! fallen off the end) ! implicit none ! integer ilo integer irep integer len1 integer len2 integer lens integer loc character ( len = * ) s character ( len = * ) sub1 character ( len = * ) sub2 ! irep = 0 lens = len ( s ) if ( lens <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_REP - Serious error!' write ( *, '(a)' ) ' Null string not allowed!' return end if len1 = len_trim ( sub1 ) if ( len1 <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_REP - Serious error!' write ( *, '(a)' ) ' Null SUB1 not allowed!' return end if len2 = len_trim ( sub2 ) if ( len2 == len1 ) then if ( sub1(1:len1) == sub2(1:len2) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_REP - Warning!' write ( *, '(a)' ) ' Replacement = original!' return end if ilo = 1 do loc = index ( s(ilo:lens), sub1(1:len1) ) if ( loc == 0 ) then exit end if loc = loc + ilo - 1 irep = irep + 1 s(loc:loc+len1-1) = sub2(1:len2) ilo = loc + len1 if ( ilo > lens ) then exit end if end do else if ( len2 < len1 ) then ilo = 1 do loc = index ( s(ilo:lens), sub1(1:len1) ) if ( loc == 0 ) then exit end if irep = irep + 1 loc = loc + ilo - 1 s(loc:loc+len2-1) = sub2(1:len2) call s_chop ( s, loc+len2, loc+len1-1 ) ilo = loc + len2 if ( ilo > lens ) then exit end if end do else ilo = 1 do loc = index ( s(ilo:lens), sub1(1:len1) ) if ( loc == 0 ) then exit end if loc = loc + ilo - 1 irep = irep + 1 if ( loc + len2 - 1 > lens ) then irep = - irep write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_REP - Warning!' write ( *, '(a)' ) ' Some replaceable elements remain!' exit end if call s_blanks_insert ( s, loc, loc+len2-1-len1 ) s(loc:loc+len2-1) = sub2(1:len2) ilo = loc + len2 end do end if return end subroutine s_repi ( s, sub1, sub2 ) ! !******************************************************************************* ! !! S_REPI replaces all occurrences of SUB1 by SUB2 in a string. ! ! ! Discussion: ! ! Matches are made without regard to case. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S. On input, ! the string in which occurrences are to be replaced. ! On output, the revised string. ! ! Input, character ( len = * ) SUB1, the string which is to be replaced. ! ! Input, character ( len = * ) SUB2, the replacement string. ! ! Output, integer IREP, the number of replacements made. ! If IREP is negative, then its absolute value is the ! number of replacements made, and SUB2 is longer than ! SUB1, and at least one substring SUB1 could not be ! replaced by SUB2 because there was no more space. ! (If S = 'aab' and SUB1 = 'a' and SUB2 = 'cc' ! then the result would be S = 'cca'. The first 'a' ! was replaced, the 'b' fell off the end, the second 'a' ! was not replaced because the replacement 'cc' would have ! fallen off the end) ! implicit none ! integer ilo integer len1 integer len2 integer lens integer s_indexi character ( len = * ) s character ( len = * ) sub1 character ( len = * ) sub2 ! lens = len ( s ) if ( lens <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_REPI - Serious error!' write ( *, '(a)' ) ' Null string not allowed!' return end if len1 = len ( sub1 ) if ( len1 <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_REPI - Serious error!' write ( *, '(a)' ) ' Null SUB1 not allowed!' return end if len2 = len ( sub2 ) ilo = s_indexi ( s, sub1 ) ! ! If the match string has been found, then insert the replacement. ! if ( ilo /= 0 ) then s(ilo+len2:lens+len2-len1) = s(ilo+len1:lens) s(ilo:ilo+len2-1) = sub2(1:len2) end if return end subroutine s_reverse ( s ) ! !******************************************************************************* ! !! S_REVERSE reverses the characters in a string. ! ! ! Examples: ! ! Input Output ! ! ' Cat' 'taC ' ! 'Goo gol ' 'log ooG ' ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to reverse. ! Trailing blanks are ignored. ! implicit none ! integer i integer j integer nchar character ( len = * ) s ! ! CFT can't handle the string assignment S(I:I) = S(J:J) ! so we have to do some mumbo jumbo. ! nchar = len_trim ( s ) do i = 1, nchar / 2 j = nchar + 1 - i call ch_swap ( s(i:i), s(j:j) ) end do return end subroutine s_right ( s ) ! !******************************************************************************* ! !! S_RIGHT flushes a string right. ! ! ! Examples: ! ! Input Output ! 'Hello ' ' Hello' ! ' Hi there! ' ' Hi there!' ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, on output, trailing blank ! characters have been cut, and pasted back onto the front. ! implicit none ! integer i integer lchar integer nonb character ( len = * ) s ! ! Check the full length of the string. ! lchar = len ( s ) ! ! Find the occurrence of the last nonblank. ! nonb = len_trim ( s ) ! ! Shift the string right. ! do i = lchar, lchar + 1 - nonb, -1 s(i:i) = s(i-lchar+nonb:i-lchar+nonb) end do ! ! Blank out the beginning of the string. ! s(1:lchar-nonb) = ' ' return end subroutine s_roman_to_i ( s, i ) ! !******************************************************************************* ! !! S_ROMAN_TO_I converts a Roman numeral to an integer. ! ! ! Example: ! ! S I ! ! X 10 ! XIX 19 ! MI 1001 ! CXC 190 ! ! Discussion: ! ! The subroutine does not check carefully as to whether the Roman numeral ! is properly formed. In particular, it will accept a string like 'IM' ! and return 999, even though this is not a well formed Roman numeral. ! ! Modified: ! ! 10 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string containing a Roman numeral. ! ! Output, integer I, the corresponding value. ! implicit none ! integer ch_roman_to_i character c1 character c2 logical done integer i integer i1 integer i2 character ( len = * ) s ! i = 0 done = .true. do call ch_next ( s, c2, done ) if ( done ) then return end if i2 = ch_roman_to_i ( c2 ) if ( i2 == 0 .and. c2 /= ' ' ) then return end if do c1 = c2 i1 = i2 call ch_next ( s, c2, done ) if ( done ) then i = i + i1 return end if i2 = ch_roman_to_i ( c2 ) if ( i2 == 0 .and. c2 /= ' ' ) then i = i + i1 return end if if ( i1 < i2 ) then i = i + i2 - i1 c1 = ' ' c2 = ' ' exit end if i = i + i1 end do end do return end subroutine s_s_delete ( s, sub, irep ) ! !******************************************************************************* ! !! S_S_DELETE removes all occurrences of a substring from a string. ! ! ! Discussion: ! ! The remainder is left justified and padded with blanks. ! ! The deletion is not recursive. Removing all occurrences of "ab" from ! "aaaaabbbbbQ" results in "aaaabbbbQ" rather than "Q". ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! ! Input, character ( len = * ) SUB1, the substring to be removed. ! ! Output, integer IREP, the number of occurrences of SUB1 ! which were found. ! implicit none ! integer ihi integer ilo integer irep integer loc integer nsub character ( len = * ) s character ( len = * ) sub ! nsub = len_trim ( sub ) irep = 0 ilo = 1 ihi = len_trim ( s ) do while ( ilo <= ihi ) loc = index ( s(ilo:ihi), sub ) if ( loc == 0 ) then return end if irep = irep + 1 loc = loc + ilo - 1 call s_chop ( s, loc, loc+nsub-1 ) ilo = loc ihi = ihi - nsub end do return end subroutine s_s_delete2 ( s, sub, irep ) ! !******************************************************************************* ! !! S_S_DELETE2 recursively removes a substring from a string. ! ! ! Discussion: ! ! The remainder is left justified and padded with blanks. ! ! The substitution is recursive, so ! that, for example, removing all occurrences of "ab" from ! "aaaaabbbbbQ" results in "Q". ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! ! Input, character ( len = * ) SUB, the substring to be removed. ! ! Output, integer IREP, the number of occurrences of the substring. ! implicit none ! integer ihi integer irep integer loc integer nchar integer nsub character ( len = * ) s character ( len = * ) sub ! nchar = len ( s ) nsub = len ( sub ) irep = 0 ihi = nchar do while ( ihi > 0 ) loc = index ( s(1:ihi), sub ) if ( loc == 0 ) then return end if irep = irep + 1 call s_chop ( s, loc, loc+nsub-1 ) ihi = ihi - nsub end do return end subroutine s_s_insert ( s, ipos, s2 ) ! !******************************************************************************* ! !! S_S_INSERT inserts a substring into a string. ! ! ! Discussion: ! ! Characters in the string are moved to the right to make room, and ! hence the trailing characters, if any, are lost. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string into which ! the second string is to be inserted. ! ! Input, integer IPOS, the position in S at which S2 is to be inserted. ! ! Input, character ( len = * ) S2, the string to be inserted. ! implicit none ! integer ihi integer ipos integer nchar integer nchar2 character ( len = * ) s character ( len = * ) s2 ! nchar = len ( s ) nchar2 = len_trim ( s2 ) ihi = min ( nchar, ipos+nchar2-1 ) call s_blanks_insert ( s, ipos, ihi ) s(ipos:ihi) = s2 return end subroutine s_set_delete ( s, s2 ) ! !******************************************************************************* ! !! S_SET_DELETE removes any characters in one string from another string. ! ! ! Discussion: ! ! When an element is removed, the rest of the string is shifted to the ! left, and padded with blanks on the right. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be examined. ! ! Input, character ( len = * ) S2, the characters to be removed. ! implicit none ! integer i integer j integer nlen integer nset character ( len = * ) s character ( len = * ) s2 ! nlen = len ( s ) nset = len ( s2 ) i = 0 do while ( i < nlen ) i = i + 1 do j = 1, nset if ( s(i:i) == s2(j:j) ) then call s_chop ( s, i, i ) nlen = nlen - 1 i = i - 1 exit end if end do end do return end subroutine s_shift_circular ( s, ishft ) ! !******************************************************************************* ! !! S_SHIFT_CIRCULAR circular shifts the characters in a string to the right. ! ! ! Discussion: ! ! Thus, a shift of -1 would change "Violin" to "iolinV", and a shift ! of 1 would change it to "nVioli". ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be shifted. ! ! Input, integer ISHFT, the number of positions to the ! right to shift the characters. ! implicit none ! character chrin character chrout integer icycle integer idid integer igoto integer imove integer ishft integer jshft integer nchar character ( len = * ) s ! nchar = len ( s ) if ( nchar <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_SHIFT_CIRCULAR - Serious error!' write ( *, '(a)' ) ' String has nonpositive length!' return end if ! ! Force the shift to be positive and between 0 and NCHAR. ! jshft = ishft do while ( jshft < 0 ) jshft = jshft + nchar end do do while ( jshft > nchar ) jshft = jshft - nchar end do if ( jshft == 0 ) then return end if ! ! Shift the first character. Shift the character that got ! displaced by the first character...Repeat until you've shifted ! all, or have "cycled" back to the first character early. ! ! If you've cycled, start again at the second character, and ! so on. ! icycle = 0 idid = 0 imove = 0 do while ( idid < nchar ) if ( imove == icycle ) then imove = imove + 1 icycle = icycle + 1 chrin = s(imove:imove) end if idid = idid + 1 igoto = imove + jshft if ( igoto > nchar ) then igoto = igoto - nchar end if chrout = s(igoto:igoto) s(igoto:igoto) = chrin chrin = chrout imove = igoto end do return end subroutine s_shift_left ( s, ishft ) ! !******************************************************************************* ! !! S_SHIFT_LEFT shifts the characters in a string to the left and blank pads. ! ! ! Discussion: ! ! A shift of 2 would change "Violin" to "olin ". ! A shift of -2 would change "Violin" to " Violin". ! ! Modified: ! ! 22 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be shifted. ! ! Input, integer ISHFT, the number of positions to the ! left to shift the characters. ! implicit none ! integer i integer ishft integer nchar character ( len = * ) s ! nchar = len ( s ) if ( ishft > 0 ) then do i = 1, nchar - ishft s(i:i) = s(i+ishft:i+ishft) end do do i = nchar - ishft + 1, nchar s(i:i) = ' ' end do else if ( ishft < 0 ) then do i = nchar, - ishft + 1, - 1 s(i:i) = s(i+ishft:i+ishft) end do do i = - ishft, 1, -1 s(i:i) = ' ' end do end if return end subroutine s_shift_right ( s, ishft ) ! !******************************************************************************* ! !! S_SHIFT_RIGHT shifts the characters in a string to the right and blank pads. ! ! ! Discussion: ! ! A shift of 2 would change "Violin" to " Viol". ! A shift of -2 would change "Violin" to "olin ". ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be shifted. ! ! Input, integer ISHFT, the number of positions to the ! right to shift the characters. ! implicit none ! integer i integer ishft integer nchar character ( len = * ) s ! nchar = len ( s ) if ( nchar <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_SHIFT_RIGHT - Serious error!' write ( *, '(a)' ) ' String has nonpositive length!' return end if if ( ishft > 0 ) then do i = nchar, ishft + 1, - 1 s(i:i) = s(i-ishft:i-ishft) end do do i = ishft, 1, -1 s(i:i) = ' ' end do else if ( ishft < 0 ) then do i = 1, nchar + ishft s(i:i) = s(i-ishft:i-ishft) end do do i = nchar + ishft + 1, nchar s(i:i) = ' ' end do end if end function s_skip_set ( s, s2 ) ! !******************************************************************************* ! !! S_SKIP_SET finds the first entry of a string that is NOT in a set. ! ! ! Modified: ! ! 27 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be examined. ! ! Input, character ( len = * ) S2, the characters to skip. ! ! Output, integer S_SKIP_SET, the location of the first character in S ! that is not in S2, or 0 if no such index was found. ! implicit none ! integer i character ( len = * ) s character ( len = * ) s2 integer s_skip_set ! do i = 1, len ( s ) if ( index ( s2, s(i:i) ) == 0 ) then s_skip_set = i return end if end do s_skip_set = 0 return end subroutine s_split ( s, sub, s1, s2, s3 ) ! !******************************************************************************* ! !! S_SPLIT divides a string into three parts, given the middle. ! ! ! Discussion: ! ! This version of the routine is case-insensitive. ! ! Examples: ! ! Input: ! ! S = 'aBCdEfgh' ! S2 = 'eF' ! ! Output: ! ! S1 = 'aBCd' ! S2 = 'gh' ! ! Modified: ! ! 01 March 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be analyzed. ! ! Input, character ( len = * ) SUB, the substring used to "split" S. ! Trailing blanks in SUB are ignored. ! ! Output, character ( len = * ) S1, the entries in the string, up ! to, but not including, the first occurrence, if any, ! of SUB. If SUB occurs immediately, then S1 = ' '. ! If SUB is not long enough, trailing entries will be lost. ! ! Output, character ( len = * ) S2, the part of the string that matched SUB. ! If S2 is ' ', then there wasn't a match. ! ! Output, character ( len = * ) S3, the part of the string after the match. ! If there was no match, then S3 is blank. ! implicit none ! integer i integer lenm integer lens character ( len = * ) s integer s_indexi character ( len = * ) s1 character ( len = * ) s2 character ( len = * ) s3 character ( len = * ) sub ! lens = len_trim ( s ) lenm = len_trim ( sub ) if ( lenm == 0 ) then lenm = 1 end if i = s_indexi ( s, sub ) ! ! The substring did not occur. ! if ( i == 0 ) then s1 = s s2 = ' ' s3 = ' ' ! ! The substring begins immediately. ! else if ( i == 1 ) then s1 = ' ' s2 = s(1:lenm) s3 = s(lenm+1:) ! ! What am I checking here? ! else if ( i + lenm > lens ) then s1 = s s2 = ' ' s3 = ' ' ! ! The substring occurs in the middle. ! else s1 = s(1:i-1) s2 = s(i:i+lenm-1) s3 = s(i+lenm: ) end if ! ! Drop leading blanks. ! s1 = adjustl ( s1 ) s2 = adjustl ( s2 ) s3 = adjustl ( s3 ) return end subroutine s_swap ( s1, s2 ) ! !******************************************************************************* ! !! S_SWAP swaps two strings. ! ! ! Modified: ! ! 30 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S1, S2. On output, the values of S1 ! and S2 have been interchanged. ! implicit none ! character ( len = * ) s1 character ( len = * ) s2 character ( len = 256 ) s3 ! s3 = s1 s1 = s2 s2 = s3 return end subroutine s_tab_blank ( s ) ! !******************************************************************************* ! !! S_TAB_BLANK replaces each TAB character by one space. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none ! integer i integer nchar character ( len = * ) s character, parameter :: TAB = char ( 9 ) ! do i = 1, len ( s ) if ( s(i:i) == TAB ) then s(i:i) = ' ' end if end do return end subroutine s_tab_blanks ( s ) ! !******************************************************************************* ! !! S_TAB_BLANKS replaces TAB characters by 6 spaces. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be modified. On ! output, some significant characters at the end of S may have ! been lost. ! implicit none ! integer i integer iget integer iput integer lenc integer lens integer ntab character ( len = * ) s character, parameter :: TAB = char ( 9 ) ! ! If no TAB's occur in the line, there is nothing to do. ! if ( index ( s, TAB ) == 0 ) then return end if ! ! Otherwise, find out how long the string is. ! lenc = len_trim ( s ) lens = len ( s ) ! ! Count the TAB's. ! ntab = 0 do i = 1, lenc if ( s(i:i) == TAB ) then ntab = ntab + 1 end if end do ! ! Now copy the string 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 ( s(iget:iget) /= TAB ) then if ( iput <= lens ) then s(iput:iput) = s(iget:iget) end if iput = iput - 1 else do i = iput, iput - 5, -1 if ( i <= lens ) then s(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 s_to_chvec ( s, n, chvec ) ! !******************************************************************************* ! !! S_TO_CHVEC converts a string to a character vector. ! ! ! Modified: ! ! 23 March 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string of characters. ! ! Input/output, integer N. ! if N is -1, extract characters from 1 to len(S); ! if N is 0, extract characters up to the last nonblank; ! if N is positive, extract characters from 1 to N. ! ! On output, N is the number of characters successfully extracted. ! ! Output, character CHVEC(N), the characters extracted from S. ! implicit none ! character chvec(*) integer i integer n character ( len = * ) s ! if ( n <= - 1 ) then n = len ( s ) else if ( n == 0 ) then n = len_trim ( s ) else n = min ( n, len ( s ) ) end if do i = 1, n chvec(i) = s(i:i) end do return end subroutine s_to_d ( s, dval, ierror, lchar ) ! !******************************************************************************* ! !! S_TO_D reads a double precision number from a string. ! ! ! Discussion: ! ! The routine will read as many characters as possible until it reaches ! the end of the string, or encounters a character which cannot be ! part of the number. ! ! Legal input is: ! ! 1 blanks, ! 2 '+' or '-' sign, ! 2.5 blanks ! 3 integer part, ! 4 decimal point, ! 5 fraction part, ! 6 'E' or 'e' or 'D' or 'd', exponent marker, ! 7 exponent sign, ! 8 exponent integer part, ! 9 exponent decimal point, ! 10 exponent fraction part, ! 11 blanks, ! 12 final comma or semicolon, ! ! with most quantities optional. ! ! Examples: ! ! S DVAL ! ! '1' 1.0 ! ' 1 ' 1.0 ! '1A' 1.0 ! '12,34,56' 12.0 ! ' 34 7' 34.0 ! '-1E2ABCD' -100.0 ! '-1X2ABCD' -1.0 ! ' 2E-1' 0.2 ! '23.45' 23.45 ! '-4.2E+2' -420.0 ! '17d2' 1700.0 ! '-14e-2' -0.14 ! 'e2' 100.0 ! '-12.73e-9.23' -12.73 * 10.0**(-9.23) ! ! Modified: ! ! 31 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string containing the ! data to be read. Reading will begin at position 1 and ! terminate at the end of the string, or when no more ! characters can be read to form a legal real. Blanks, ! commas, or other nonnumeric data will, in particular, ! cause the conversion to halt. ! ! Output, double precision DVAL, the value read from the string. ! ! Output, integer IERROR, error flag. ! ! 0, no errors occurred. ! ! 1, 2, 6 or 7, the input number was garbled. The ! value of IERROR is the last type of input successfully ! read. For instance, 1 means initial blanks, 2 means ! a plus or minus sign, and so on. ! ! Output, integer LCHAR, the number of characters read ! to form the number, including any terminating ! characters such as a trailing comma or blanks. ! implicit none ! logical ch_eqi character c double precision dval integer ierror integer ihave integer isgn integer iterm integer jbot integer jsgn integer jtop integer lchar integer nchar integer ndig double precision rbot double precision rexp double precision rtop character ( len = * ) s ! nchar = len_trim ( s ) ierror = 0 dval = 0.0D+00 lchar = -1 isgn = 1 rtop = 0 rbot = 1 jsgn = 1 jtop = 0 jbot = 1 ihave = 1 iterm = 0 do lchar = lchar + 1 if ( lchar+1 > nchar ) then exit end if c = s(lchar+1:lchar+1) ! ! Blank character. ! if ( c == ' ' ) then if ( ihave == 2 ) then else if ( ihave == 6 .or. ihave == 7 ) then iterm = 1 else if ( ihave > 1 ) then ihave = 11 end if ! ! Comma. ! else if ( c == ',' .or. c == ';' ) then if ( ihave /= 1 ) then iterm = 1 ihave = 12 lchar = lchar + 1 end if ! ! Minus sign. ! else if ( c == '-' ) then if ( ihave == 1 ) then ihave = 2 isgn = -1 else if ( ihave == 6 ) then ihave = 7 jsgn = -1 else iterm = 1 end if ! ! Plus sign. ! else if ( c == '+' ) then if ( ihave == 1 ) then ihave = 2 else if ( ihave == 6 ) then ihave = 7 else iterm = 1 end if ! ! Decimal point. ! else if ( c == '.' ) then if ( ihave < 4 ) then ihave = 4 else if ( ihave >= 6 .and. ihave <= 8 ) then ihave = 9 else iterm = 1 end if ! ! Scientific notation exponent marker. ! else if ( ch_eqi ( c, 'E' ) .or. ch_eqi ( c, 'D' ) ) then if ( ihave < 6 ) then ihave = 6 else iterm = 1 end if ! ! Digit. ! else if ( ihave < 11 .and. lge ( c, '0' ) .and. lle ( c, '9' ) ) then if ( ihave <= 2 ) then ihave = 3 else if ( ihave == 4 ) then ihave = 5 else if ( ihave == 6 .or. ihave == 7 ) then ihave = 8 else if ( ihave == 9 ) then ihave = 10 end if call ch_to_digit ( c, ndig ) if ( ihave == 3 ) then rtop = 10.0D+00 * rtop + dble ( ndig ) else if ( ihave == 5 ) then rtop = 10.0D+00 * rtop + dble ( ndig ) rbot = 10.0D+00 * rbot else if ( ihave == 8 ) then jtop = 10 * jtop + ndig else if ( ihave == 10 ) then jtop = 10 * jtop + ndig jbot = 10 * jbot end if ! ! Anything else is regarded as a terminator. ! else iterm = 1 end if ! ! If we haven't seen a terminator, and we haven't examined the ! entire string, go get the next character. ! if ( iterm == 1 ) then exit end if end do ! ! If we haven't seen a terminator, and we have examined the ! entire string, then we're done, and LCHAR is equal to NCHAR. ! if ( iterm /= 1 .and. lchar+1 == nchar ) then lchar = nchar end if ! ! Number seems to have terminated. Have we got a legal number? ! Not if we terminated in states 1, 2, 6 or 7! ! if ( ihave == 1 .or. ihave == 2 .or. ihave == 6 .or. ihave == 7 ) then ierror = ihave write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_TO_D - Serious error!' write ( *, '(a)' ) ' Illegal or nonnumeric input:' write ( *, '(a)' ) ' ' // trim ( s ) return end if ! ! Number seems OK. Form it. ! if ( jtop == 0 ) then rexp = 1.0D+00 else if ( jbot == 1 ) then rexp = 10.0D+00 ** ( jsgn * jtop ) else rexp = 10.0D+00 ** ( dble ( jsgn * jtop ) / dble ( jbot ) ) end if end if dval = dble ( isgn ) * rexp * rtop / rbot return end subroutine s_to_date ( s1, s2 ) ! !******************************************************************************* ! !! S_TO_DATE converts the F90 date string to a more usual format. ! ! ! Examples: ! ! S1 S2 ! -------- ---------------- ! 20010204 4 February 2001 ! 17760704 4 July 1776 ! 19520310 10 March 1952 ! ! Modified: ! ! 04 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = 8 ) S1, the F90 date string returned by ! the routine DATE_AND_TIME. ! ! Output, character ( len = * ) S2, a more usual format for the date. ! Allowing 16 characters for S2 should be sufficient for the ! forseeable future. ! implicit none ! integer i integer m character ( len = 8 ) month character ( len = * ) s1 character ( len = * ) s2 ! if ( s1(7:7) == '0' ) then s2(1:1) = s1(8:8) i = 1 else s2(1:2) = s1(7:8) i = 2 end if i = i + 1 s2(i:i) = ' ' read ( s1(5:6), '(i2)' ) m call i_to_month_name ( m, month ) s2(i+1:) = month i = i + len_trim ( month ) i = i + 1 s2(i:i) = ' ' s2(i+1:i+4) = s1(1:4) i = i + 4 return end subroutine s_to_dec ( s, itop, ibot, length ) ! !******************************************************************************* ! !! S_TO_DEC reads a number from a string, returning a decimal result. ! ! ! Discussion: ! ! The integer may be in real format, for example '2.25'. It ! returns ITOP and IBOT. If the input number is an integer, ITOP ! equals that integer, and IBOT is 1. But in the case of 2.25, ! the program would return ITOP = 225, IBOT = 100. ! ! Legal input is ! ! blanks, ! 2 initial sign, ! blanks, ! 3 whole number, ! 4 decimal point, ! 5 fraction, ! 6 'E' or 'e' or 'D' or 'd', exponent marker, ! 7 exponent sign, ! 8 exponent, ! blanks ! 9 comma or semicolon ! 10end of information ! ! Examples: ! ! S ITOP IBOT Length Meaning ! ! '1' 1 0 1 1 ! ' 1 ' 1 0 6 1 ! '1A' 1 0 1 1 ! '12,34,56' 12 0 3 12 ! ' 34 7' 34 0 4 34 ! '-1E2ABCD' -1 2 4 -100 ! '-1X2ABCD' -1 0 2 -1 ! ' 2E-1' 2 -1 5 0.2 ! '23.45' 2345 -2 5 23.45 ! ! Modified: ! ! 04 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string containing the ! data to be read. Reading begins at position 1 and ! terminate when no more characters ! can be read to form a legal integer. Blanks, commas, ! or other nonnumeric data will, in particular, cause ! the conversion to halt. ! ! Output, integer ITOP, the integer read from the string, ! assuming that no negative exponents or fractional parts ! were used. Otherwise, the 'integer' is ITOP/IBOT. ! ! Output, integer IBOT, the integer divisor required to ! represent numbers which are in real format or have a ! negative exponent. ! ! Output, integer LENGTH, the number of characters used. ! implicit none ! logical ch_is_digit character c integer digit integer exponent integer exponent_sign integer ibot integer ihave integer iterm integer itop integer length integer mantissa_sign character ( len = * ) s logical s_eqi ! itop = 0 ibot = 0 if ( len ( s ) <= 0 ) then length = 0 return end if length = - 1 exponent_sign = 0 mantissa_sign = 1 exponent = 0 ihave = 1 iterm = 0 ! ! Consider the next character in the string. ! do length = length + 1 c = s(length+1:length+1) ! ! Blank. ! if ( c == ' ' ) then if ( ihave == 1 ) then else if ( ihave == 2 ) then else iterm = 1 end if ! ! Comma or semicolon. ! else if ( c == ',' .or. c == ';' ) then if ( ihave /= 1 ) then iterm = 1 ihave = 9 length = length + 1 end if ! ! Minus sign. ! else if ( c == '-' ) then if ( ihave == 1 ) then ihave = 2 mantissa_sign = - 1 else if ( ihave == 6 ) then ihave = 7 exponent_sign = -1 else iterm = 1 end if ! ! Plus sign. ! else if ( c == '+' ) then if ( ihave == 1 ) then ihave = 2 mantissa_sign = +1 else if ( ihave == 6 ) then ihave = 7 exponent_sign = +1 else iterm = 1 end if ! ! Decimal point. ! else if ( c == '.' ) then if ( ihave < 4 ) then ihave = 4 else iterm = 1 end if ! ! Exponent marker. ! else if ( s_eqi ( c, 'E' ) .or. s_eqi ( c, 'D' ) ) then if ( ihave < 6 ) then ihave = 6 else iterm = 1 end if ! ! Digit. ! else if ( ch_is_digit ( c ) ) then if ( ihave <= 3 ) then ihave = 3 call ch_to_digit ( c, digit ) itop = 10 * itop + digit else if ( ihave <= 5 ) then ihave = 5 call ch_to_digit ( c, digit ) itop = 10 * itop + digit ibot = ibot - 1 else if ( ihave <= 8 ) then ihave = 8 call ch_to_digit ( c, digit ) exponent = 10 * exponent + digit else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_TO_DEC: Fatal error!' write ( *, '(a,i6)' ) ' IHAVE = ', ihave stop end if ! ! Anything else is regarded as a terminator. ! else iterm = 1 end if if ( iterm == 1 ) then exit end if if ( length + 1 >= len ( s ) ) then length = len ( s ) exit end if end do ! ! Number seems to have terminated. ! Have we got a legal number? ! if ( ihave == 1 ) then return else if ( ihave == 2 .or. ihave == 6 .or. ihave == 7 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_TO_DEC - Serious error!' write ( *, '(a)' ) ' Illegal or nonnumeric input:' write ( *, '(a)' ) trim ( s ) return end if ! ! Normalize. ! if ( itop > 0 ) then do while ( mod ( itop, 10 ) == 0 ) itop = itop / 10 ibot = ibot + 1 end do end if ! ! Consolidate the number in the form ITOP * 10**IBOT. ! ibot = ibot + exponent_sign * exponent itop = mantissa_sign * itop if ( itop == 0 ) then ibot = 0 end if return end subroutine s_to_ebcdic ( s ) ! !******************************************************************************* ! !! S_TO_EBCDIC converts a character string from ASCII to EBCDIC. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S. On input, the ASCII ! string, on output, the EBCDIC string. ! implicit none ! character ch_to_ebcdic integer i character ( len = * ) s ! do i = 1, len ( s ) s(i:i) = ch_to_ebcdic ( s(i:i) ) end do return end subroutine s_to_hex ( s, hex ) ! !******************************************************************************* ! !! S_TO_HEX replaces a character string by a hexadecimal representation. ! ! ! Examples: ! ! The string 'ABC' causes the hexadecimal string '414243' to be returned. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string of characters. ! ! Output, character ( len = * ) HEX, the string of hex values. ! implicit none ! character ( len = * ) hex integer i integer intval integer j integer ndo integer nhex integer nstr character ( len = * ) s ! nstr = len_trim ( s ) nhex = len ( hex ) ndo = min ( nhex / 2, nstr ) hex = ' ' do i = 1, ndo j = 2 * i - 1 intval = ichar ( s(i:i) ) call i_to_hex ( intval, hex(j:j+1) ) end do return end subroutine s_to_i ( s, ival, ierror, last ) ! !******************************************************************************* ! !! S_TO_I reads an integer value from a string. ! ! ! Modified: ! ! 28 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string to be examined. ! ! Output, integer IVAL, the integer value read from the string. ! If the string is blank, then IVAL will be returned 0. ! ! Output, integer IERROR, an error flag. ! 0, no error. ! 1, an error occurred. ! ! Output, integer LAST, the last character of S used to make IVAL. ! implicit none ! character c integer i integer ierror integer isgn integer istate integer ival integer last character ( len = * ) s ! ierror = 0 istate = 0 isgn = 1 ival = 0 do i = 1, len_trim ( s ) c = s(i:i) ! ! Haven't read anything. ! if ( istate == 0 ) then if ( c == ' ' ) then else if ( c == '-' ) then istate = 1 isgn = -1 else if ( c == '+' ) then istate = 1 isgn = + 1 else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then istate = 2 ival = ichar ( c ) - ichar ( '0' ) else ierror = 1 return end if ! ! Have read the sign, expecting digits. ! else if ( istate == 1 ) then if ( c == ' ' ) then else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then istate = 2 ival = ichar ( c ) - ichar ( '0' ) else ierror = 1 return end if ! ! Have read at least one digit, expecting more. ! else if ( istate == 2 ) then if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then ival = 10 * ival + ichar ( c ) - ichar ( '0' ) else ival = isgn * ival last = i - 1 return end if end if end do ! ! If we read all the characters in the string, see if we're OK. ! if ( istate == 2 ) then ival = isgn * ival last = len_trim ( s ) else ierror = 1 last = 0 end if return end subroutine s_to_l ( s, logval, ierror, lchar ) ! !******************************************************************************* ! !! S_TO_L reads a logical value from a string. ! ! ! Discussion: ! ! The routine will read as many characters as possible until it reaches ! the end of the string, or encounters a character which cannot be ! part of the value. ! ! There are several ways of representing logical data that this routine ! recognizes: ! ! False True ! ----- ---- ! ! F T ! FALSE TRUE ! .FALSE. .TRUE. ! 0 1 ! ! The routine is not case sensitive. 'TRUE' may also be spelled 'true' ! or 'True'. ! ! The routine is not "space" sensitive. There may be spaces before or ! after the representation of the logical value. But there may ! not be spaces between the letters! If the routine was given the ! input "TRUE", it would read all four characters. But the input ! "T R U E" would cause the routine to read only the first character. ! ! The routine doesn't care what follows the data it reads. The ! representation for the logical value may be followed by blanks, ! commas, numeric values, or any kind of data. ! ! Examples: ! ! S LOGVAL LCHAR IERROR ! ! '.TRUE.' T 6 0 ! 'TRUE' T 4 0 ! 'True' T 4 0 ! ' TRUE' T 6 0 ! 'Trump' T 1 0 ! 'Ture' T 1 0 ! 'T' T 1 0 ! 'Talleyrand' T 1 0 ! 'Garbage' F 0 2 ! 'F' F 1 0 ! 'Furbelow' F 1 0 ! '0' F 1 0 ! '1' T 1 0 ! '2' F 0 2 ! ' 1' T 6 0 ! '17' T 1 0 ! '1A' T 1 0 ! '12,34,56' T 1 0 ! ' 34 7' F 0 2 ! '-1E2ABCD' F 0 2 ! 'I am TRUE' F 0 2 ! ' ' F 0 1 ! ! Modified: ! ! 24 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string containing the ! data to be read. Reading will begin at position 1 and ! terminate at the end of the string, or when no more ! characters can be read to form a legal integer. Blanks, ! commas, or other nonnumeric data will, in particular, ! cause the conversion to halt. ! ! Output, logical LOGVAL, the logical value read from the string. ! ! Output, integer IERROR, error flag. ! ! 0, no errors. ! 1, input string was entirely blank. ! 2, input string did not begin with a logical value. ! ! Output, integer LCHAR, number of characters read from ! the string to form the logical value. ! implicit none ! integer first integer ierror integer j integer last logical logval integer lchar integer lens character ( len = 7 ), parameter, dimension ( 8 ) :: pat = (/ & '0 ', & '1 ', & 'F ', & 'T ', & 'TRUE ', & 'FALSE ', & '.TRUE. ', & '.FALSE.' /) character ( len = * ) s logical s_eqi integer s_first_nonblank logical, parameter, dimension ( 8 ) :: val = (/ & .FALSE., .TRUE., .FALSE., .TRUE., .TRUE., .FALSE., .TRUE., .FALSE. /) ! ! Set the default output values. ! ierror = 0 logval = .false. lchar = 0 ! ! Find the first nonblank character in the string. ! first = s_first_nonblank ( s ) if ( first <= 0 ) then ierror = 1 return end if ! ! Compare string to the eight legal patterns, going by decreasing ! size. ! lens = len_trim ( s ) do j = 8, 1, -1 last = first + len_trim ( pat(j) ) - 1 if ( last <= lens ) then if ( s_eqi ( pat(j), s(first:last) ) ) then logval = val(j) lchar = last return end if end if end do ! ! Input string did not contain a logical value. ! ierror = 2 return end subroutine s_to_r ( s, r, ierror, lchar ) ! !******************************************************************************* ! !! S_TO_R reads a real number from a string. ! ! ! Discussion: ! ! This routine will read as many characters as possible until it reaches ! the end of the string, or encounters a character which cannot be ! part of the real number. ! ! Legal input is: ! ! 1 blanks, ! 2 '+' or '-' sign, ! 2.5 spaces ! 3 integer part, ! 4 decimal point, ! 5 fraction part, ! 6 'E' or 'e' or 'D' or 'd', exponent marker, ! 7 exponent sign, ! 8 exponent integer part, ! 9 exponent decimal point, ! 10 exponent fraction part, ! 11 blanks, ! 12 final comma or semicolon. ! ! with most quantities optional. ! ! Examples: ! ! S R ! ! '1' 1.0 ! ' 1 ' 1.0 ! '1A' 1.0 ! '12,34,56' 12.0 ! ' 34 7' 34.0 ! '-1E2ABCD' -100.0 ! '-1X2ABCD' -1.0 ! ' 2E-1' 0.2 ! '23.45' 23.45 ! '-4.2E+2' -420.0 ! '17d2' 1700.0 ! '-14e-2' -0.14 ! 'e2' 100.0 ! '-12.73e-9.23' -12.73 * 10.0**(-9.23) ! ! Modified: ! ! 12 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string containing the ! data to be read. Reading will begin at position 1 and ! terminate at the end of the string, or when no more ! characters can be read to form a legal real. Blanks, ! commas, or other nonnumeric data will, in particular, ! cause the conversion to halt. ! ! Output, real R, the real value that was read from the string. ! ! Output, integer IERROR, error flag. ! ! 0, no errors occurred. ! ! 1, 2, 6 or 7, the input number was garbled. The ! value of IERROR is the last type of input successfully ! read. For instance, 1 means initial blanks, 2 means ! a plus or minus sign, and so on. ! ! Output, integer LCHAR, the number of characters read from ! the string to form the number, including any terminating ! characters such as a trailing comma or blanks. ! implicit none ! character c logical ch_eqi integer ierror integer ihave integer isgn integer iterm integer jbot integer jsgn integer jtop integer lchar integer nchar integer ndig real r real rbot real rexp real rtop character ( len = * ) s character, parameter :: TAB = char ( 9 ) ! nchar = len_trim ( s ) ierror = 0 r = 0.0E+00 lchar = - 1 isgn = 1 rtop = 0.0E+00 rbot = 1.0E+00 jsgn = 1 jtop = 0 jbot = 1 ihave = 1 iterm = 0 do lchar = lchar + 1 c = s(lchar+1:lchar+1) ! ! Blank or TAB character. ! if ( c == ' ' .or. c == TAB ) then if ( ihave == 2 ) then else if ( ihave == 6 .or. ihave == 7 ) then iterm = 1 else if ( ihave > 1 ) then ihave = 11 end if ! ! Comma. ! else if ( c == ',' .or. c == ';' ) then if ( ihave /= 1 ) then iterm = 1 ihave = 12 lchar = lchar + 1 end if ! ! Minus sign. ! else if ( c == '-' ) then if ( ihave == 1 ) then ihave = 2 isgn = - 1 else if ( ihave == 6 ) then ihave = 7 jsgn = - 1 else iterm = 1 end if ! ! Plus sign. ! else if ( c == '+' ) then if ( ihave == 1 ) then ihave = 2 else if ( ihave == 6 ) then ihave = 7 else iterm = 1 end if ! ! Decimal point. ! else if ( c == '.' ) then if ( ihave < 4 ) then ihave = 4 else if ( ihave >= 6 .and. ihave <= 8 ) then ihave = 9 else iterm = 1 end if ! ! Exponent marker. ! else if ( ch_eqi ( c, 'E' ) .or. ch_eqi ( c, 'D' ) ) then if ( ihave < 6 ) then ihave = 6 else iterm = 1 end if ! ! Digit. ! else if ( ihave < 11 .and. lge ( c, '0' ) .and. lle ( c, '9' ) ) then if ( ihave <= 2 ) then ihave = 3 else if ( ihave == 4 ) then ihave = 5 else if ( ihave == 6 .or. ihave == 7 ) then ihave = 8 else if ( ihave == 9 ) then ihave = 10 end if call ch_to_digit ( c, ndig ) if ( ihave == 3 ) then rtop = 10.0E+00 * rtop + real ( ndig ) else if ( ihave == 5 ) then rtop = 10.0E+00 * rtop + real ( ndig ) rbot = 10.0E+00 * rbot else if ( ihave == 8 ) then jtop = 10 * jtop + ndig else if ( ihave == 10 ) then jtop = 10 * jtop + ndig jbot = 10 * jbot end if ! ! Anything else is regarded as a terminator. ! else iterm = 1 end if ! ! If we haven't seen a terminator, and we haven't examined the ! entire string, go get the next character. ! if ( iterm == 1 .or. lchar+1 >= nchar ) then exit end if end do ! ! If we haven't seen a terminator, and we have examined the ! entire string, then we're done, and LCHAR is equal to NCHAR. ! if ( iterm /= 1 .and. lchar+1 == nchar ) then lchar = nchar end if ! ! Number seems to have terminated. Have we got a legal number? ! Not if we terminated in states 1, 2, 6 or 7! ! if ( ihave == 1 .or. ihave == 2 .or. ihave == 6 .or. ihave == 7 ) then ierror = ihave return end if ! ! Number seems OK. Form it. ! if ( jtop == 0 ) then rexp = 1.0E+00 else if ( jbot == 1 ) then rexp = 10.0E+00**( jsgn * jtop ) else rexp = jsgn * jtop rexp = rexp / jbot rexp = 10.0E+00**rexp end if end if r = isgn * rexp * rtop / rbot return end subroutine s_to_rvec ( s, n, rvec, ierror ) ! !******************************************************************************* ! !! S_TO_RVEC reads a real vector from a string. ! ! ! Modified: ! ! 19 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be read. ! ! Input, integer N, the number of values expected. ! ! Output, real RVEC(N), the values read from the string. ! ! Output, integer IERROR, error flag. ! 0, no errors occurred. ! -K, could not read data for entries -K through N. ! implicit none ! integer n ! integer i integer ierror integer ilo integer lchar real rvec(n) character ( len = * ) s ! i = 0 ilo = 1 do while ( i < n ) i = i + 1 call s_to_r ( s(ilo:), rvec(i), ierror, lchar ) if ( ierror /= 0 ) then ierror = -i exit end if ilo = ilo + lchar end do return end subroutine s_to_rot13 ( s ) ! !******************************************************************************* ! !! S_TO_ROT13 "rotates" the alphabetical characters in a string by 13 positions. ! ! ! Discussion: ! ! Two applications of the routine will return the original string. ! ! Examples: ! ! Input: Output: ! ! abcdefghijklmnopqrstuvwxyz nopqrstuvwxyzabcdefghijklm ! Cher Pure ! James Thurston Howell Wnzrf Guhefgba Ubjryy ! 12345 12345 ! ! 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 s_to_soundex ( s, code ) ! !******************************************************************************* ! !! S_TO_SOUNDEX computes the Soundex code of a string. ! ! ! Examples: ! ! Input: Output: ! ! Ellery E460 ! Euler E460 ! Gauss G200 ! Ghosh G200 ! Heilbronn H416 ! Hilbert H416 ! Kant K530 ! Knuth K530 ! Ladd L300 ! Lloyd L300 ! Lissajous L222 ! Lukasiewicz L222 ! ! Reference: ! ! Donald Knuth, ! Sorting and Searching, ! The Art of Computer Programming, Volume 3, ! Addison-Wesley, 1973, page 391-392. ! ! Modified: ! ! 01 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string to be converted. ! ! Output, character ( len = 4 ) CODE, the Soundex code for the string. ! implicit none ! character c logical ch_is_alpha character ch_s character ch_s_old character ( len = 4 ) code integer iget integer iput integer nget character put character ( len = * ) s ! ch_s = '0' code = ' ' nget = len_trim ( s ) iget = 0 ! ! Try to fill position IPUT of the code. ! do iput = 1, 4 do if ( iget >= nget ) then put = '0' exit end if iget = iget + 1 c = s(iget:iget) call ch_cap ( c ) if ( .not. ch_is_alpha ( c ) ) then cycle end if ch_s_old = ch_s call ch_to_soundex ( c, ch_s ) if ( iput == 1 ) then put = c exit else if ( ch_s /= ch_s_old .and. ch_s /= '0' ) then put = ch_s exit end if end do code(iput:iput) = put end do return end subroutine s_to_z ( s, cval, ierror, lchar ) ! !******************************************************************************* ! !! S_TO_Z reads a complex number from a string. ! ! ! Discussion: ! ! S_TO_CH will read as many characters as possible until it reaches ! the end of the string, or encounters a character which cannot be ! part of the number. ! ! Legal input is: ! ! 1 blanks, ! 2 '+' or '-' sign, ! 3 integer part, ! 4 decimal point, ! 5 fraction part, ! 6 'E' or 'e' or 'D' or 'd', exponent marker, ! 7 exponent sign, ! 8 exponent integer part, ! 9 exponent decimal point, ! 10 exponent fraction part, ! 11 blanks, ! 12 '+' or '-' sign, ! 13 integer part, ! 14 decimal point, ! 15 fraction part, ! 16 'E' or 'e' or 'D' or 'd', exponent marker, ! 17 exponent sign, ! 18 exponent integer part, ! 19 exponent decimal point, ! 20 exponent fraction part, ! 21 blanks, ! 22 "*" ! 23 spaces ! 24 I ! 25 comma or semicolon ! ! with most quantities optional. ! ! Examples: ! ! S CVAL IERROR LCHAR ! ! '1' 1 0 1 ! '1+I' 1 + 1 i 0 3 ! '1+1 i' 1 + 1 i 0 5 ! '1+1*i' 1 + 1 i 0 5 ! 'i' 1 i 0 1 ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string containing the ! data to be read. Reading will begin at position 1 and ! terminate at the end of the string, or when no more ! characters can be read to form a legal real. Blanks, ! commas, or other nonnumeric data will, in particular, ! cause the conversion to halt. ! ! Output, complex CVAL, the value that was read from the string. ! ! Output, integer IERROR, error flag. ! ! 0, no errors occurred. ! 1, the string was empty. ! 2, could not read A correctly. ! 3, could not read B correctly. ! 4, could not read I correctly. ! ! Output, integer LCHAR, the number of characters read from ! the string to form the number, including any terminating ! characters such as a trailing comma or blanks. ! implicit none ! real aval real bval logical ch_eqi character c character c2 complex cval integer ichr integer ichr2 integer ierror integer lchar logical s_nei character ( len = * ) s ! ! Initialize the return arguments. ! ierror = 0 aval = 0.0E+00 bval = 0.0E+00 cval = cmplx ( aval, bval ) lchar = 0 ! ! Get the length of the line, and if it's zero, return. ! if ( len_trim ( s ) <= 0 ) then ierror = 1 return end if call nexchr ( s, ichr, c ) ! ! If the next character is "I", then this number is 0+I. ! if ( ch_eqi ( c, 'I' ) ) then aval = 0.0E+00 bval = 1.0E+00 lchar = lchar + ichr cval = cmplx ( aval, bval ) return end if ! ! OK, the next string has to be a number! ! call s_to_r ( s, aval, ierror, ichr ) if ( ierror /= 0 ) then ierror = 2 lchar = 0 return end if lchar = lchar + ichr ! ! See if this is a pure real number, because: ! ! 1) There's no more input left. ! if ( len_trim ( s(lchar+1:) ) == 0 ) then cval = cmplx ( aval, bval ) return end if ! ! 2) The last character read was a comma. ! if ( s(lchar:lchar) == ',' .or. s(lchar:lchar) == ';' ) then cval = cmplx ( aval, bval ) return end if ! ! If the very next character is "I", then this is a pure ! imaginary number! ! call nexchr ( s(lchar+1:), ichr, c ) if ( ch_eqi ( c, 'I' ) ) then bval = aval aval = 0.0E+00 lchar = lchar + ichr cval = cmplx ( aval, bval ) return end if ! ! If the very next character is "*" and the one after that is ! "I", then this is a pure imaginary number! ! if ( c == '*' ) then call nexchr ( s(lchar+ichr+1:), ichr2, c2 ) if ( ch_eqi ( c2, 'I' ) ) then bval = aval aval = 0.0E+00 lchar = lchar + ichr + ichr2 end if cval = cmplx ( aval, bval ) return end if ! ! OK, now we've got A. We have to be careful because the next ! thing we see MIGHT be "+ I" or "- I" which we can't let CHRCTR ! see, because it will have fits. So let's check these two ! possibilities. ! call nexchr ( s(lchar+1:), ichr, c ) call nexchr ( s(lchar+1+ichr:), ichr2, c2 ) if ( ch_eqi ( c2, 'I' ) ) then if ( c == '+' ) then bval = 1 lchar = lchar + ichr + ichr2 cval = cmplx ( aval, bval ) return else if ( c == '-' ) then bval = - 1 lchar = lchar + ichr + ichr2 cval = cmplx ( aval, bval ) return end if end if ! ! Read the next real number. ! call s_to_r ( s(lchar+1:), bval, ierror, ichr ) if ( ierror /= 0 ) then ierror = 3 lchar = 0 return end if lchar = lchar + ichr ! ! If the next character is a "*", that's OK, advance past it. ! call nexchr ( s(lchar+1:), ichr, c ) if ( c == '*' ) then lchar = lchar + ichr end if ! ! Now we really do want the next character to be "I". ! call nexchr ( s(lchar+1:), ichr, c ) if ( s_nei ( c, 'I' ) ) then ierror = 4 lchar = 0 return end if ! ! Form the complex number. ! cval = cmplx ( aval, bval ) return end subroutine s_token_equal ( s, set, nset, iset ) ! !******************************************************************************* ! !! S_TOKEN_EQUAL checks whether a string is equal to any of a set of strings. ! ! ! Discussion: ! ! The comparison is case-insensitive. ! ! Trailing blanks in S and the elements of SET are ignored. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to check. ! ! Input, character ( len = * ) SET(NSET), the set of strings. ! ! Input, integer NSET, the number of elements of SET. ! ! Output, integer ISET, equals 0 if no element of SET ! equals S. If ISET is nonzero, then SET(ISET) equals ! S, disregarding case. ! implicit none ! integer i integer iset integer nset character ( len = * ) s logical s_eqi character ( len = * ) set(*) ! iset = 0 do i = 1, nset if ( s_eqi ( s, set(i) ) ) then iset = i return end if end do return end subroutine s_token_match ( s, token_num, token, match ) ! !******************************************************************************* ! !! S_TOKEN_MATCH matches the beginning of a string and a set of tokens. ! ! ! Example: ! ! Input: ! ! S = 'TOMMYGUN' ! TOKEN = 'TOM', 'ZEBRA', 'TOMMY', 'TOMMYKNOCKER' ! ! Output: ! ! MATCH = 3 ! ! Discussion: ! ! The longest possible match is taken. ! Matching is done without regard to case or trailing blanks. ! ! Modified: ! ! 21 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be examined. ! ! Input, integer TOKEN_NUM, the number of tokens to be compared. ! ! Input, character ( len = * ) TOKEN(TOKEN_NUM), the tokens. ! ! Output, integer MATCH, the index of the (longest) token that matched ! the string, or 0 if no match was found. ! implicit none ! integer token_num ! integer match integer match_length character ( len = * ) s logical s_eqi integer string_length integer token_i integer token_length character ( len = * ) token(token_num) ! match = 0 match_length = 0 string_length = len_trim ( s ) do token_i = 1, token_num token_length = len_trim ( token ( token_i ) ) if ( token_length > match_length ) then if ( token_length <= string_length ) then if ( s_eqi ( s(1:token_length), token(token_i)(1:token_length) ) ) then match_length = token_length match = token_i end if end if end if end do return end subroutine s_trim_zeros ( s ) ! !******************************************************************************* ! !! S_TRIM_ZEROS removes trailing zeros from a string. ! ! ! Example: ! ! Input: ! ! S = '1401.072500' ! ! Output: ! ! S = '1401.0725' ! ! Modified: ! ! 30 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be operated on. ! implicit none ! integer i character ( len = * ) s ! i = len_trim ( s ) do while ( i > 0 .and. s(i:i) == '0' ) s(i:i) = ' ' i = i - 1 end do return end subroutine s_w_cap ( s ) ! !******************************************************************************* ! !! S_W_CAP capitalizes the first character of each word in a string. ! ! ! Example: ! ! Input: ! ! S = 'a waste is a terrible thing to mind' ! ! Output: ! ! S = 'A Waste Is A Terrible Thing To Mind' ! ! 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 ! call s_low ( 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 function s32_to_i ( s32 ) ! !******************************************************************************* ! !! S32_TO_I returns an integer equivalent to a 32 character string. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = 32 ) S32, the character value. ! ! Output, integer S32_TO_I, a corresponding integer value. ! implicit none ! integer i integer intval character ( len = 32 ) s32 integer s32_to_i character ( len = 32 ) scopy ! scopy = s32 if ( scopy(1:1) == '1' ) then do i = 2, 32 if ( scopy(i:i) == '0' ) then scopy(i:i) = '1' else scopy(i:i) = '0' end if end do end if intval = 0 do i = 2, 32 intval = 2 * intval if ( scopy(i:i) == '1' ) then intval = intval + 1 end if end do if ( scopy(1:1) == '1' ) then intval = -intval end if s32_to_i = intval return end function s32_to_r ( s32 ) ! !******************************************************************************* ! !! S32_TO_R converts a 32-character variable into a real. ! ! ! Discussion: ! ! The first bit is 1 for a negative real, or 0 for a ! positive real. Bits 2 through 9 are the exponent. Bits 10 ! through 32 are used for a normalized representation of the ! mantissa. Since it is assumed that normalization means the first ! digit of the mantissa is 1, this 1 is in fact not stored. ! ! The special case of 0 is represented by all 0 bits. ! ! It is believed that this method corresponds to the format used ! in VMS FORTRAN for reals. ! ! Because of the limits on the mantissa, many Cray numbers are not ! representable at all by this method. These numbers are very big ! or very small in magnitude. Other numbers will simply be ! represented with less accuracy. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = 32 ) S32, the character variable to be decoded. ! ! Output, real RCHAR32, the corresponding real value. ! implicit none ! integer i integer iexp integer j integer mant character ( len = 32 ) s32 real s32_to_r real sgn ! ! Read sign bit. ! if ( s32(1:1) == '1' ) then sgn = -1.0E+00 else sgn = 1.0E+00 end if ! ! Construct exponent from bits 2 through 9, subtract 128. ! iexp = 0 do i = 2, 9 if ( s32(i:i) == '0' ) then j = 0 else j = 1 end if iexp = 2 * iexp + j end do if ( iexp == 0 ) then s32_to_r = 0.0E+00 return end if iexp = iexp - 128 ! ! Read mantissa from positions 10 through 32. ! Note that, unless exponent equals 0, the most significant bit is ! assumed to be 1 and hence is not stored. ! mant = 1 do i = 10, 32 mant = 2 * mant if ( s32(i:i) == '1' ) then mant = mant + 1 end if end do s32_to_r = sgn * mant * ( 2.0E+00 ** ( iexp - 23 ) ) return end subroutine sef_to_b4_ieee ( s, e, f, word ) ! !******************************************************************************* ! !! SEF_TO_B4_IEEE converts SEF information to a 4 byte IEEE real word. ! ! ! Modified: ! ! 22 November 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer S, the sign bit: ! 0, if R is nonnegative; ! 1, if R is negative. ! ! Input, integer E, the exponent, base 2. ! Normally, -127 < E <= 127. ! If E = 128, then the data is interpreted as NaN, Inf, or -Inf. ! If -127 < E <= 127, the data is a normalized value. ! If E < -127, then the data is a denormalized value. ! ! Input, integer F, the mantissa. ! ! Output, integer WORD, the real number stored in IEEE format. ! implicit none ! integer e integer e2 integer f integer, parameter :: f_max = 2**24 integer, parameter :: f_min = 2**23 integer f2 integer i integer s integer s2 integer word ! s2 = s e2 = e f2 = f ! ! Handle +Inf and -Inf. ! if ( f /= 0 .and. e == 128 ) then e2 = e2 + 127 f2 = 2**23 - 1 call mvbits ( s2, 0, 1, word, 31 ) call mvbits ( e2, 0, 8, word, 23 ) call mvbits ( f2, 0, 23, word, 0 ) return end if ! ! Handle NaN. ! if ( f == 0 .and. e == 128 ) then e2 = e2 + 127 f2 = 0 call mvbits ( s2, 0, 1, word, 31 ) call mvbits ( e2, 0, 8, word, 23 ) call mvbits ( f2, 0, 23, word, 0 ) return end if ! ! Handle +0 and -0. ! if ( f == 0 ) then e2 = 0 call mvbits ( s2, 0, 1, word, 31 ) call mvbits ( e2, 0, 8, word, 23 ) call mvbits ( f2, 0, 23, word, 0 ) return end if ! ! Normalize. ! if ( f < 0 ) then s2 = 1 - s2 f2 = -f2 end if e2 = e2 + 127 + 23 do while ( f2 >= f_max ) f2 = f2 / 2 e2 = e2 + 1 end do do while ( f2 < f_min ) f2 = f2 * 2 e2 = e2 - 1 end do ! ! The biased exponent cannot be negative. ! Shift it up to zero, and reduce F2. ! do while ( e2 < 0 .and. f2 /= 0 ) e2 = e2 + 1 f2 = f2 / 2 end do ! ! Normalized values drop the leading 1. ! if ( e2 > 0 ) then call mvbits ( s2, 0, 1, word, 31 ) call mvbits ( e2, 0, 8, word, 23 ) f2 = f2 - f_min call mvbits ( f2, 0, 23, word, 0 ) ! ! Denormalized values have a biased exponent of 0. ! else call mvbits ( s2, 0, 1, word, 31 ) call mvbits ( e2, 0, 8, word, 23 ) call mvbits ( f2, 0, 23, word, 0 ) end if return end subroutine sef_to_b4_ieee_old ( s, e, f, word ) ! !******************************************************************************* ! !! SEF_TO_B4_IEEE converts SEF information to a 4 byte IEEE real word. ! ! ! Modified: ! ! 15 November 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer S, the sign bit: ! 0, if R is nonnegative; ! 1, if R is negative. ! ! Input, integer E, the exponent, base 2. ! ! Input, integer F, the mantissa. ! ! Output, integer WORD, the real number stored in IEEE format. ! implicit none ! integer e integer f integer i integer s integer word ! call mvbits ( s, 0, 1, word, 31 ) ! ! We want to add 127 to E. ! call mvbits ( e+127, 0, 8, word, 23 ) ! ! We want to ignore the high bit of F. ! call mvbits ( f, 0, 23, word, 0 ) return end subroutine sef_to_r ( s, e, f, r ) ! !******************************************************************************* ! !! SEF_TO_R converts SEF information to a real number as R = S * 2.0**E * F. ! ! ! Discussion: ! ! Assuming no arithmetic problems, in fact, this equality should be ! exact, that is, S, E and F should exactly express the value ! as stored on the computer. ! ! Modified: ! ! 11 November 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer S, the sign bit: ! 0, if R is nonnegative; ! 1, if R is negative. ! ! Input, integer E, the exponent, base 2. ! ! Input, integer F, the mantissa. ! ! Output, real R, the real number. ! implicit none ! integer e integer f integer i real r integer s ! if ( f == 0 ) then r = 0.0E+00 return end if if ( s == 0 ) then r = 1.0E+00 else if ( s == 1 ) then r = -1.0E+00 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SEF_TO_R - Fatal error!' write ( *, '(a,i6)' ) ' Illegal input value of S = ', s stop end if r = r * real ( f ) if ( e > 0 ) then do i = 1, e r = r * 2.0E+00 end do else if ( e < 0 ) then do i = 1, -e r = r / 2.0E+00 end do end if return end subroutine sort_heap_external ( n, indx, i, j, isgn ) ! !******************************************************************************* ! !! SORT_HEAP_EXTERNAL externally sorts a list of items into linear order. ! ! ! Discussion: ! ! The actual list of data is not passed to the routine. Hence this ! routine may be used to sort integers, reals, numbers, names, ! dates, shoe sizes, and so on. After each call, the routine asks ! the user to compare or interchange two items, until a special ! return value signals that the sorting is completed. ! ! Modified: ! ! 12 November 2000 ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Parameters: ! ! Input, integer N, the number of items to be sorted. ! ! Input/output, integer INDX, the main communication signal. ! ! The user must set INDX to 0 before the first call. ! Thereafter, the user should not change the value of INDX until ! the sorting is done. ! ! On return, if INDX is ! ! greater than 0, ! * interchange items I and J; ! * call again. ! ! less than 0, ! * compare items I and J; ! * set ISGN = -1 if I precedes J, ISGN = +1 if J precedes I; ! * call again. ! ! equal to 0, the sorting is done. ! ! Output, integer I, J, the indices of two items. ! On return with INDX positive, elements I and J should be interchanged. ! On return with INDX negative, elements I and J should be compared, and ! the result reported in ISGN on the next call. ! ! Input, integer ISGN, results of comparison of elements I and J. ! (Used only when the previous call returned INDX less than 0). ! ISGN <= 0 means I precedes J; ! ISGN => 0 means J precedes I. ! implicit none ! integer i integer indx integer isgn integer j integer, save :: k = 0 integer, save :: k1 = 0 integer n integer, save :: n1 = 0 ! ! INDX = 0: This is the first call. ! if ( indx == 0 ) then n1 = n k = n / 2 k1 = k ! ! INDX < 0: The user is returning the results of a comparison. ! else if ( indx < 0 ) then if ( indx == -2 ) then if ( isgn < 0 ) then i = i + 1 end if j = k1 k1 = i indx = - 1 return end if if ( isgn > 0 ) then indx = 2 return end if if ( k <= 1 ) then if ( n1 == 1 ) then indx = 0 else i = n1 n1 = n1 - 1 j = 1 indx = 1 end if return end if k = k - 1 k1 = k ! ! INDX > 0, the user was asked to make an interchange. ! else if ( indx == 1 ) then k1 = k end if do i = 2 * k1 if ( i == n1 ) then j = k1 k1 = i indx = - 1 return else if ( i <= n1 ) then j = i + 1 indx = - 2 return end if if ( k <= 1 ) then exit end if k = k - 1 k1 = k end do if ( n1 == 1 ) then indx = 0 else i = n1 n1 = n1 - 1 j = 1 indx = 1 end if return end subroutine sqz_i ( ivec, idim, ibits, jvec, jdim, jbits, iwords ) ! !******************************************************************************* ! !! SQZ_I uncompresses JVEC to extract integers stored there. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer IVEC(IDIM), contains IWORDS integers which ! were extracted from JVEC. ! ! Input, integer IDIM, the dimension of IVEC ! ! Input, integer IBITS, the value of IBITS that was used ! with INTSQZ. ! ! Input, integer JVEC(JDIM), the compressed information. ! ! Input, integer JDIM, the number of words in JVEC that ! contain information. ! ! Input, integer JBITS, the number of bits to use for ! numeric representation of the individual output integers. ! ! Output, integer IWORDS, the number of integers written into IVEC. ! implicit none ! integer idim integer jdim ! integer i integer ibits integer ihi integer inc integer inum integer ivec(idim) integer iwords integer j integer jback integer jbits integer jnum integer jvec(jdim) integer jwords integer maxi integer mult ! inc = ibits / jbits if ( inc /= 1 ) then mult = 2**jbits else mult = 1 end if maxi = 2**(jbits-1) - 1 jwords = 0 iwords = 0 do i = 1, idim, inc jwords = jwords + 1 jnum = jvec(jwords) ihi = i + inc - 1 do j = i, ihi jback = ihi + i - j inum = mod ( jnum, mult ) if ( inum > maxi) then inum = - inum + maxi + 1 end if if ( jback <= idim ) then ivec(jback) = inum iwords = iwords + 1 else inum = 0 end if jnum = jnum / mult end do end do return end subroutine svec_lab ( n, nuniq, svec, ident ) ! !******************************************************************************* ! !! SVEC_LAB makes an index array for an array of (repeated) strings. ! ! ! Discussion: ! ! The routine is given an array of strings. It assigns an integer ! to each unique string, and returns an equivalent array of ! these values. ! ! Note that blank strings are treated specially. Any blank ! string gets an identifier of 0. Blank strings are not ! counted in the value of NUNIQ. ! ! Examples: ! ! SVEC IDENT ! ! ALPHA 1 ! ALPHA -1 ! BETA 2 ! ALPHA -1 ! BETA -2 ! GAMMA 3 ! ALPHA -1 ! ! Modified: ! ! 19 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries. ! ! Output, integer NUNIQ, the number of unique nonblank entries. ! ! Input, character ( len = * ) SVEC(N), the list of strings. ! ! Output, integer IDENT(N), the identifiers assigned to the ! strings. If SVEC(I) is blank, then IDENT(I) is 0. ! Otherwise, if SVEC(I) is the first occurrence of a ! given string, then it is assigned a positive identifier. ! If SVEC(I) is a later occurrence of a string, then ! it is assigned a negative identifier, whose absolute ! value is the identifier of the first occurrence. ! implicit none ! integer n ! integer i integer ident(n) integer j integer match integer nuniq character ( len = * ) svec(n) ! nuniq = 0 do i = 1, n if ( svec(i) == ' ' ) then ident(i) = 0 else match = 0 do j = 1, i-1 if ( ident(j) > 0 ) then if ( svec(j) == svec(i) ) then ident(i) = - ident(j) match = j exit end if end if end do if ( match == 0 ) then nuniq = nuniq + 1 ident(i) = nuniq end if end if end do return end subroutine svec_merge ( na, a, nb, b, nc, c ) ! !******************************************************************************* ! !! SVEC_MERGE merges two sorted string arrays. ! ! ! Discussion: ! ! The elements of A and B should be sorted in ascending order. ! ! The elements in the output array C will also be in ascending order, ! and unique. ! ! Modified: ! ! 06 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NA, the dimension of A. ! ! Input, character ( len = * ) A(NA), the first sorted array. ! ! Input, integer NB, the dimension of B. ! ! Input, character ( len = * ) B(NB), the second sorted array. ! ! Output, integer NC, the number of elements in the output array. ! Note that C should usually be dimensioned at least NA+NB in the ! calling routine. ! ! Output, character ( len = * ) C(NC), the merged unique sorted array. ! implicit none ! integer na integer nb ! character ( len = * ) a(na) character ( len = * ) b(nb) character ( len = * ) c(na+nb) integer j integer ja integer jb integer nc ! ja = 0 jb = 0 nc = 0 do ! ! If we've used up all the entries of A, stick the rest of B on the end. ! if ( ja >= na ) then do j = 1, nb - jb jb = jb + 1 if ( nc == 0 ) then nc = nc + 1 c(nc) = b(jb) else if ( llt ( c(nc), b(jb) ) ) then nc = nc + 1 c(nc) = b(jb) end if end do exit ! ! If we've used up all the entries of B, stick the rest of A on the end. ! else if ( jb >= nb ) then do j = 1, na - ja ja = ja + 1 if ( nc == 0 ) then nc = nc + 1 c(nc) = a(ja) else if ( llt ( c(nc), a(ja) ) ) then nc = nc + 1 c(nc) = a(ja) end if end do exit ! ! Otherwise, if the next entry of A is smaller, that's our candidate. ! else if ( lle ( a(ja+1), b(jb+1) ) ) then ja = ja + 1 if ( nc == 0 ) then nc = nc + 1 c(nc) = a(ja) else if ( llt ( c(nc), a(ja) ) ) then nc = nc + 1 c(nc) = a(ja) end if ! ! ...or if the next entry of B is the smaller, consider that. ! else jb = jb + 1 if ( nc == 0 ) then nc = nc + 1 c(nc) = b(jb) else if ( llt ( c(nc), b(jb) ) ) then nc = nc + 1 c(nc) = b(jb) end if end if end do return end subroutine svec_sort_heap_a ( n, a ) ! !******************************************************************************* ! !! SVEC_SORT_HEAP_A ascending sorts a vector of character strings using heap sort. ! ! ! Discussion: ! ! The ASCII collating sequence is used. This means ! A < B < C < .... < Y < Z < a < b < .... < z. ! Numbers and other symbols may also occur, and will be sorted according to ! the ASCII ordering. ! ! Modified: ! ! 27 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of strings ! ! Input/output, character ( len = * ) A(N); ! On input, an array of strings to be sorted. ! On output, the sorted array. ! implicit none ! integer n ! character ( len = * ) a(n) integer i integer indx integer isgn integer j ! ! Do the sorting using the external heap sort routine. ! i = 0 indx = 0 isgn = 0 j = 0 do call sort_heap_external ( n, indx, i, j, isgn ) if ( indx > 0 ) then call s_swap ( a(i), a(j) ) else if ( indx < 0 ) then if ( lle ( a(i), a(j) ) ) then isgn = - 1 else isgn = + 1 end if else if ( indx == 0 ) then exit end if end do return end subroutine svec_sort_heap_a_index ( n, sarray, indx ) ! !******************************************************************************* ! !! SVEC_SORT_HEAP_A_INDEX does a case-sensitive indexed heap sort of a vector of strings. ! ! ! Discussion: ! ! The sorting is not actually carried out. ! Rather an index array is created which defines the sorting. ! This array may be used to sort or index the array, or to sort or ! index related arrays keyed on the original array. ! ! The ASCII collating sequence is used, and case is significant. ! This means ! ! A < B < C < .... < Y < Z < a < b < .... < z. ! ! Numbers and other symbols may also occur, and will be sorted according to ! the ASCII ordering. ! ! Modified: ! ! 27 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in SARRAY. ! ! Input, character ( len = * ) SARRAY(N), an array to be sorted. ! ! Output, integer INDX(N), contains the sort index. The ! I-th element of the sorted array is SARRAY ( INDX(I) ). ! implicit none ! integer, parameter :: MAX_CHAR = 255 integer n ! integer i integer indx(n) integer indxt integer ir integer j integer l character ( len = * ) sarray(n) character ( len = MAX_CHAR ) string ! do i = 1, n indx(i) = i end do l = n / 2 + 1 ir = n do if ( l > 1 ) then l = l - 1 indxt = indx(l) string = sarray(indxt) else indxt = indx(ir) string = sarray(indxt) indx(ir) = indx(1) ir = ir - 1 if ( ir == 1 ) then indx(1) = indxt return end if end if i = l j = l + l do while ( j <= ir ) if ( j < ir ) then if ( llt ( sarray ( indx(j) ), sarray ( indx(j+1) ) ) ) then j = j + 1 end if end if if ( llt ( string, sarray ( indx(j) ) ) ) then indx(i) = indx(j) i = j j = j + j else j = ir + 1 end if end do indx(i) = indxt end do return end subroutine sveci_sort_heap_a ( n, sarray ) ! !******************************************************************************* ! !! SVECI_SORT_HEAP_A heap sorts a vector of implicitly capitalized strings. ! ! ! Discussion: ! ! The ASCII collating sequence is used, except that all ! alphabetic characters are treated as though they were uppercase. ! ! This means ! ! A = a < B = b < C = c < .... < Y = y < Z = z. ! ! Numbers and other symbols may also occur, and will be sorted ! according to the ASCII ordering. ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in SARRAY. ! ! Input/output, character ( len = * ) SARRAY(N), the array to be sorted. ! implicit none ! integer, parameter :: MAX_CHAR = 255 integer n ! integer l integer l1 logical s_gei logical s_lti integer m integer n1 character ( len = * ) sarray(n) character ( len = MAX_CHAR ) s ! n1 = n l = n / 2 s = sarray(l) l1 = l do m = 2 * l1 if ( m <= n1 ) then if ( m < n1 ) then if ( s_gei ( sarray(m+1), sarray(m) ) ) then m = m + 1 end if end if if ( s_lti ( s, sarray(m) ) ) then sarray(l1) = sarray(m) l1 = m cycle end if end if sarray(l1) = s if ( l > 1 ) then l = l - 1 s = sarray(l) l1 = l cycle end if if ( n1 < 2 ) then exit end if s = sarray(n1) sarray(n1) = sarray(1) n1 = n1 - 1 l1 = l end do return end subroutine sveci_sort_heap_a_index ( n, sarray, indx ) ! !******************************************************************************* ! !! SVECI_SORT_HEAP_A_INDEX index heap sorts a vector of implicitly capitalized strings. ! ! ! Discussion: ! ! The sorting is not actually carried out, ! but rather an index vector is returned, which defines the ! sorting. This index vector may be used to sort the array, or ! to sort related arrays keyed on the first one. ! ! The ASCII collating sequence is used, except that all ! alphabetic characters are treated as though they were uppercase. ! ! This means ! ! A = a < B = b < C = c < .... < Y = y < Z = z. ! ! Numbers and other symbols may also occur, and will be sorted according to ! the ASCII ordering. ! ! Modified: ! ! 16 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in SARRAY. ! ! Input, character ( len = * ) SARRAY(N), an array to be sorted. ! ! Output, integer INDX(N), contains the sort index. The ! I-th element of the sorted array is SARRAY ( INDX(I) ). ! implicit none ! integer, parameter :: MAX_CHAR = 255 integer n ! integer i integer indx(n) integer indxt integer ir integer j integer l logical s_lti character ( len = * ) sarray(n) character ( len = MAX_CHAR ) s ! do i = 1, n indx(i) = i end do l = n / 2 + 1 ir = n do if ( l > 1 ) then l = l - 1 indxt = indx(l) s = sarray(indxt) else indxt = indx(ir) s = sarray(indxt) indx(ir) = indx(1) ir = ir - 1 if ( ir == 1 ) then indx(1) = indxt return end if end if i = l j = l + l do while ( j <= ir ) if ( j < ir ) then if ( s_lti ( sarray ( indx(j) ), sarray ( indx(j+1) ) ) ) then j = j + 1 end if end if if ( s_lti ( s, sarray ( indx(j) ) ) ) then indx(i) = indx(j) i = j j = j + j else j = ir + 1 end if end do indx(i) = indxt end do return end subroutine sym_to_ch ( sym, c, ihi ) ! !******************************************************************************* ! !! SYM_TO_CH returns the character represented by a symbol. ! ! ! 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 ( ) ! !******************************************************************************* ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! ! Example: ! ! May 31 2001 9:45:54.872 AM ! ! Modified: ! ! 31 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none ! character ( len = 8 ) ampm integer d character ( len = 8 ) date 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 character ( len = 10 ) time integer values(8) integer y character ( len = 5 ) zone ! call date_and_time ( date, time, zone, 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 ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end subroutine token_expand ( s, tokens ) ! !******************************************************************************* ! !! TOKEN_EXPAND makes sure certain tokens have spaces surrounding them. ! ! ! Modified: ! ! 05 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be examined. ! ! Input, character ( len = * ) TOKENS, a string of characters. Every ! occurrence of a character from TOKENS in S must be ! preceded and followed by a blank space, except if the occurrence ! is in the first or last positions of S, in which a ! preceding or trailing blank space is implicit. ! implicit none ! integer,parameter :: MAX_CHAR = 255 ! character c1 character c2 character c3 integer i integer iput integer j integer lenc integer lent character ( len = * ) s character ( len = MAX_CHAR ) s2 character ( len = * ) tokens ! lenc = len_trim ( s ) lent = len_trim ( tokens ) s2 = ' ' iput = 0 c2 = ' ' c3 = s(1:1) do i = 1, lenc c1 = c2 c2 = c3 if ( i < lenc ) then c3 = s(i+1:i+1) else c3 = ' ' end if do j = 1, lent if ( c2 == tokens(j:j) ) then if ( c1 /= ' ' ) then iput = iput + 1 if ( iput <= MAX_CHAR ) then s2(iput:iput) = ' ' end if end if end if end do iput = iput + 1 if ( iput <= MAX_CHAR ) then s2(iput:iput) = c2 end if do j = 1, lent if ( c2 == tokens(j:j) ) then if ( c3 /= ' ' ) then iput = iput + 1 if ( iput <= MAX_CHAR ) then s2(iput:iput) = ' ' end if end if end if end do end do s = s2 return end subroutine token_extract ( s, token_num, token, match ) ! !******************************************************************************* ! !! TOKEN_EXTRACT "extracts" a token from the beginning of a string. ! ! ! Modified: ! ! 22 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S; on input, a string from ! whose beginning a token is to be extracted. On output, ! the token, if found, has been removed. ! ! Input, integer TOKEN_NUM, the number of tokens to be compared. ! ! Input, character ( len = * ) TOKEN(TOKEN_NUM), the tokens. ! ! Output, integer MATCH, the index of the (longest) token that matched ! the string, or 0 if no match was found. ! implicit none ! integer token_num ! integer left integer match character ( len = * ) s character ( len = * ) token(token_num) ! call s_token_match ( s, token_num, token, match ) if ( match /= 0 ) then left = len_trim ( token(match) ) call s_shift_left ( s, left ) end if return end subroutine token_index ( s, indx, ilo, ihi ) ! !******************************************************************************* ! !! TOKEN_INDEX finds the N-th FORTRAN variable name in a string. ! ! ! 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 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 = * ) s ! ihi = 0 ilo = 0 do i = 1, indx call token_next ( s, ilo, ihi) if ( ilo == 0 ) then return end if end do return end subroutine token_next ( s, ilo, ihi ) ! !******************************************************************************* ! !! TOKEN_NEXT finds the next FORTRAN variable name in a string. ! ! ! 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 function upper ( s ) ! !******************************************************************************* ! !! UPPER returns an uppercase version of a string. ! ! ! Discussion: ! ! UPPER is a string function of undeclared length. The length ! of the argument returned is determined by the declaration of ! UPPER in the calling routine. ! ! Modified: ! ! 11 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string. ! ! Output, character ( len = * ) UPPER, an uppercase copy of the string. ! implicit none ! integer i integer j integer n character ( len = * ) s character ( len = * ) upper ! upper = s n = len_trim ( upper ) do i = 1, n j = ichar ( upper(i:i) ) if ( 97 <= j .and. j <= 122 ) then upper(i:i) = char ( j - 32 ) end if end do return end subroutine word_cap ( s ) ! !******************************************************************************* ! !! WORD_CAP capitalizes the first character of each word in a string. ! ! ! Modified: ! ! 23 May 2001 ! ! 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_count ( s, nword ) ! !******************************************************************************* ! !! WORD_COUNT counts the number of "words" in a string. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be examined. ! ! Output, integer NWORD, the number of "words" in the string. ! Words are presumed to be separated by one or more blanks. ! implicit none ! logical blank integer i integer lens integer nword character ( len = * ) s ! nword = 0 lens = len ( s ) if ( lens <= 0 ) then return end if blank = .true. do i = 1, lens if ( s(i:i) == ' ' ) then blank = .true. else if ( blank ) then nword = nword + 1 blank = .false. end if end do return end subroutine word_extract ( s, w ) ! !******************************************************************************* ! !! WORD_EXTRACT extracts the next word from a string. ! ! ! Discussion: ! ! A "word" is a string of characters terminated by a blank or ! the end of the string. ! ! Modified: ! ! 31 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string. On output, the first ! word has been removed, and the remaining string has been shifted left. ! ! Output, character ( len = * ) W, the leading word of the string. ! implicit none ! integer iget1 integer iget2 integer lchar character ( len = * ) s character ( len = * ) w ! w = ' ' lchar = len_trim ( s ) ! ! Find the first nonblank. ! iget1 = 0 do iget1 = iget1 + 1 if ( iget1 > lchar ) then return end if if ( s(iget1:iget1) /= ' ' ) then exit end if end do ! ! Look for the last contiguous nonblank. ! iget2 = iget1 do if ( iget2 >= lchar ) then exit end if if ( s(iget2+1:iget2+1) == ' ' ) then exit end if iget2 = iget2 + 1 end do ! ! Copy the word. ! w = s(iget1:iget2) ! ! Shift the string. ! s(1:iget2) = ' ' s = adjustl ( s(iget2+1:) ) return end subroutine word_find ( s, iword, word, nchar ) ! !******************************************************************************* ! !! WORD_FIND finds the word of a given index in a string. ! ! ! Discussion: ! ! A "word" is any string of nonblank characters, separated from other ! words by one or more blanks or TABS. ! ! Modified: ! ! 01 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be searched. ! ! Input, integer IWORD, the index of the word to be ! searched for. If IWORD is positive, then the IWORD-th ! word is sought. If IWORD is zero or negative, then ! assuming that the string has N words in it, the ! N+IWORD-th word will be sought. ! ! Output, character ( len = * ) WORD, the IWORD-th word of the ! string, or ' ' if the WORD could not be found. ! ! Output, integer NCHAR, the number of characters in WORD, ! or 0 if the word could not be found. ! implicit none ! integer i integer iblank integer ihi integer ilo integer iword integer jhi integer jlo integer jword integer kword integer lchar integer nchar character ( len = * ) s character, parameter :: TAB = char ( 9 ) character ( len = * ) word ! ilo = 0 ihi = 0 lchar = len_trim ( s ) if ( lchar <= 0 ) then return end if if ( iword > 0 ) then if ( s(1:1) == ' ' .or. s(1:1) == TAB ) then iblank = 1 jword = 0 jlo = 0 jhi = 0 else iblank = 0 jword = 1 jlo = 1 jhi = 1 end if i = 1 do i = i + 1 if ( i > lchar ) then if ( jword == iword ) then ilo = jlo ihi = lchar nchar = lchar + 1 - jlo word = s(ilo:ihi) else ilo = 0 ihi = 0 nchar = 0 word = ' ' end if return end if if ( ( s(i:i) == ' ' .or. s(i:i) == TAB ) .and. iblank == 0 ) then jhi = i - 1 iblank = 1 if ( jword == iword ) then ilo = jlo ihi = jhi nchar = jhi + 1 - jlo word = s(ilo:ihi) return end if else if ( s(i:i) /= ' ' .and. s(i:i) /= TAB .and. iblank == 1 ) then jlo = i jword = jword + 1 iblank = 0 end if end do else iblank = 0 kword = 1 - iword jword = 1 jlo = lchar jhi = lchar i = lchar do i = i - 1 if ( i <= 0 ) then if ( jword == kword ) then ilo = 1 ihi = jhi nchar = jhi word = s(ilo:ihi) else ilo = 0 ihi = 0 nchar = 0 word = ' ' end if return end if if ( ( s(i:i) == ' ' .or. s == TAB ) .and. iblank == 0 ) then jlo = i + 1 iblank = 1 if ( jword == kword ) then ilo = jlo ihi = jhi nchar = jhi + 1 - jlo word = s(ilo:ihi) return end if else if ( s(i:i) /= ' ' .and. s(i:i) /= TAB .and. iblank == 1 ) then jhi = i jword = jword + 1 iblank = 0 end if end do end if return end subroutine word_inc ( s, ierror ) ! !******************************************************************************* ! !! WORD_INC "increments" a word. ! ! ! Discussion: ! ! The routine tries to produce the next string, in dictionary order, ! following the input value of a string. Digits, spaces, and other ! nonalphabetic characters are ignored. Case is respected; in other ! words, the case of every alphabetic character on input will be the ! same on output. ! ! The following error conditions can occur: ! ! There are no alphabetic characters in the string. No ! incrementing is possible. ! ! All alphabetic characters are equal to 'Z' or 'z'. In this ! case, an error value is returned, but the string is also "wrapped ! around" so that all alphabetic characters are "A" or "a". ! ! If the word "Tax" were input, the successive outputs would be ! "Tay", "Taz", "Tba", "Tbb", ... If the input word "January 4, 1989" ! were input, the output would be "Januarz 4, 1989". ! ! This routine could be useful when trying to create a unique file ! name or variable name at run time. ! ! Modified: ! ! 01 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string whose ! alphabetic successor is desired. On output, if IERROR = 0, ! S has been replaced by its successor. If IERROR = 2, ! S will be "wrapped around" so that all alphabetic ! characters equal "A" or "a". ! ! Output, integer IERROR, an error flag. ! 0, no error. ! 1, no alphabetic characters occur in the string. ! 2, all alphabetic characters are "Z" or "z". S is wrapped around so ! that all alphabetic characters are "A" or "a". ! implicit none ! integer ierror integer ihi integer ilo integer iloc character ( len = * ) s ! ierror = 0 ilo = 1 ihi = len ( s ) ! ! Find the last alphabetic character in the string. ! do call s_alpha_last ( s(ilo:ihi), iloc ) ! ! If there is no alphabetic character, we can't help. ! if ( iloc == 0 ) then ierror = 1 exit end if if ( s(iloc:iloc) == char ( 122 ) ) then s(iloc:iloc) = char ( 97 ) ihi = iloc - 1 if ( ihi <= 0 ) then ierror = 2 exit end if else if ( s(iloc:iloc) == char ( 90 ) ) then s(iloc:iloc) = char ( 65 ) ihi = iloc - 1 if ( ihi <= 0 ) then ierror = 2 exit end if else s(iloc:iloc) = char ( ichar ( s(iloc:iloc) ) + 1 ) exit end if end do return end subroutine word_last_read ( s, word ) ! !******************************************************************************* ! !! WORD_LAST_READ returns the last word from a string. ! ! ! Modified: ! ! 01 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string containing words separated ! by spaces. ! ! Output, character ( len = * ) WORD, the last word. ! implicit none ! integer first integer last character ( len = * ) s character ( len = * ) word ! last = len_trim ( s ) if ( last <= 0 ) then word = ' ' return end if first = last do if ( first <= 1 ) then exit end if if ( s(first-1:first-1) == ' ' ) then exit end if first = first - 1 end do word = s(first:last) return end subroutine word_index ( s, indx, ilo, ihi ) ! !******************************************************************************* ! !! 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. ! ! 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 ) ! !******************************************************************************* ! !! 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. ! ! 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 ) ! !******************************************************************************* ! !! 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 the string that occur after FIRST and ! the commas and blanks. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string of words to be analyzed. ! ! Output, character ( len = * ) FIRST, the next word in the string. ! ! Output, character ( len = * ) LAST, the remaining 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 subroutine word_next_read ( s, word, done ) ! !******************************************************************************* ! !! WORD_NEXT_READ "reads" words from a string, one at a time. ! ! ! Special cases: ! ! The following characters are considered to be a single word, ! whether surrounded by spaces or not: ! ! " ( ) { } [ ] ! ! Also, if there is a trailing comma on the word, it is stripped off. ! This is to facilitate the reading of lists. ! ! Modified: ! ! 23 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string, presumably containing words ! separated by spaces. ! ! Output, character ( len = * ) WORD. ! ! If DONE is FALSE, then WORD contains the "next" word read. ! If DONE is TRUE, then WORD is blank, because there was no more to read. ! ! Input/output, logical DONE. ! ! On input with a fresh string, set DONE to TRUE. ! ! On output, the routine sets DONE: ! FALSE if another word was read, ! TRUE if no more words could be read. ! implicit none ! logical done integer ilo integer, save :: lenc = 0 integer, save :: next = 1 character ( len = * ) s character, parameter :: TAB = char ( 9 ) character ( len = * ) word ! ! We "remember" LENC and NEXT from the previous call. ! ! An input value of DONE = TRUE signals a new line of text to examine. ! if ( done ) then next = 1 done = .false. lenc = len_trim ( s ) if ( lenc <= 0 ) then done = .true. word = ' ' return end if end if ! ! Beginning at index NEXT, search the string for the next nonblank, ! which signals the beginning of a word. ! ilo = next ! ! ...S(NEXT:) is blank. Return with WORD = ' ' and DONE = TRUE. ! do if ( ilo > lenc ) then word = ' ' done = .true. next = lenc + 1 return end if ! ! If the current character is blank, skip to the next one. ! if ( s(ilo:ilo) /= ' ' .and. s(ilo:ilo) /= TAB ) then exit end if ilo = ilo + 1 end do ! ! ILO is the index of the next nonblank character in the string. ! ! If this initial nonblank is a special character, ! then that's the whole word as far as we're concerned, ! so return immediately. ! if ( s(ilo:ilo) == '"' .or. & s(ilo:ilo) == '(' .or. & s(ilo:ilo) == ')' .or. & s(ilo:ilo) == '{' .or. & s(ilo:ilo) == '}' .or. & s(ilo:ilo) == '[' .or. & s(ilo:ilo) == ']' ) then word = s(ilo:ilo) next = ilo + 1 return end if ! ! Now search for the last contiguous character that is not a ! blank, TAB, or special character. ! next = ilo + 1 do while ( next <= lenc ) if ( s(next:next) == ' ' ) then exit else if ( s(next:next) == TAB ) then exit else if ( s(next:next) == '"' ) then exit else if ( s(next:next) == '(' ) then exit else if ( s(next:next) == ')' ) then exit else if ( s(next:next) == '{' ) then exit else if ( s(next:next) == '}' ) then exit else if ( s(next:next) == '[' ) then exit else if ( s(next:next) == ']' ) then exit end if next = next + 1 end do ! ! Ignore a trailing comma. ! if ( s(next-1:next-1) == ',' ) then word = s(ilo:next-2) else word = s(ilo:next-1) end if return end subroutine word_next_wr ( s, word, done ) ! !******************************************************************************* ! !! WORD_NEXT_WR tries to append a word to a line. ! ! ! Discussion: ! ! A blank space will separate the word from the text already ! in the line. ! ! The routine warns the user if the word will not fit. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, a line of text. On first call ! with DONE = TRUE, S is blanked out. ! On output, with DONE = FALSE, the input WORD has been appended ! to the line. ! ! Input, character ( len = * ) WORD, a word to be added to the line. ! ! Output, logical DONE, is FALSE if we were able to append the ! word to the line. DONE is TRUE if we were not able to append ! the word. The user may want to process the current LINE, ! blank it out, and call again with the same WORD, and DONE ! reset to TRUE. ! implicit none ! logical done integer, save :: lenl = 0 integer lenw integer, save :: next = 0 character ( len = * ) s character ( len = * ) word ! if ( done ) then next = 0 done = .false. s = ' ' lenl = len ( s ) end if lenw = len_trim ( word ) if ( next+lenw > lenl ) then done = .true. return end if if ( next > 0 ) then s(next:next) = ' ' end if s(next+1:next+lenw) = word(1:lenw) next = next + lenw + 1 return end subroutine word_swap ( s, i1, i2 ) ! !******************************************************************************* ! !! WORD_SWAP swaps two words in a given string. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, a string of characters. ! "Words" in the string are presumed to be separated by blanks. ! ! Input, integer I1, I2, the indices of the words to be swapped. ! If either I1 or I2 is nonpositive, or greater than the number of ! words in the string, then nothing is done to the string. Otherwise, ! words I1 and I2 are swapped. ! implicit none ! logical blank integer i integer i1 integer i2 integer j1 integer j1beg integer j1end integer j2 integer j2beg integer j2end integer lens integer nword character ( len = * ) s character ( len = 80 ) s2 ! lens = len_trim ( s ) if ( lens <= 0 ) then return end if if ( lens > 80 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'WORD_SWAP - Warning!' write ( *, '(a)' ) ' The internal temporary string is too short' write ( *, '(a)' ) ' to copy your string. Errors may result!' stop end if ! ! We need to make a copy of the input arguments, because we ! might alter them. We want to ensure that J1 <= J2. ! j1 = min ( i1, i2) j2 = max ( i1, i2) if ( j1 <= 0 ) then return else if ( j2 <= 0 ) then return else if ( j1 == j2 ) then return end if j1beg = 0 j1end = 0 j2beg = 0 j2end = 0 nword = 0 blank = .true. do i = 1, lens if ( s(i:i) == ' ' ) then if ( j1beg /= 0 .and. j1end == 0 ) then j1end = i - 1 else if ( j2beg /= 0 .and. j2end == 0 ) then j2end = i - 1 end if blank = .true. else if ( blank ) then nword = nword + 1 if ( nword == j1 ) then j1beg = i else if ( nword == j2 ) then j2beg = i end if blank = .false. end if end do if ( j1beg /= 0 .and. j1end == 0 ) then j1end = lens else if ( j2beg /= 0 .and. j2end == 0 ) then j2end = lens end if if ( j1 > nword .or. j2 > nword ) then return end if ! ! OK, we can swap words J1 and J2. ! s2 = s ! ! Copy word 2. ! s( j1beg : j1beg + j2end - j2beg ) = s2 ( j2beg : j2end ) ! ! Copy (possibly null) string between word 1 and word 2. ! s ( j1beg + j2end - j2beg + 1 : j1beg + j2end - j1end - 1 ) & = s2 ( j1end + 1 : j2beg - 1 ) ! ! Copy word 1. ! s ( j1beg + j2end - j1end : j2end ) = s2 ( j1beg : j1end ) return end