program chrpak_prb
!
!*******************************************************************************
!
!! CHRPAK_PRB tests routines from the CHRPAK library.
!
implicit none
!
call timestamp ( )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'CHRPAK_PRB'
write ( *, '(a)' ) ' Run CHRPAK tests.'
call test039
call test0041
call test00415
call test0042
call test001
call test002
call test003
call test004
call test0045
call test005
call test006
call test0065
call test007
call test008
call test009
call test0095
call test010
call test011
call test012
call test013
call test014
call test0145
call test015
call test016
call test0165
call test017
call test018
call test019
call test020
call test021
call test022
call test0225
call test023
call test024
call test027
call test028
call test029
call test030
call test031
call test032
call test033
call test034
call test035
call test036
call test037
call test038
call test0384
call test0385
call test040
call test041
call test042
call test043
call test044
call test0445
call test045
call test046
call test047
call test048
call test0483
call test0484
call test0485
call test049
call test050
call test051
call test052
call test053
call test054
call test055
call test056
call test057
call test058
call test059
call test0595
call test060
call test061
call test062
call test063
call test064
call test065
call test066
call test067
call test068
call test069
call test070
call test0705
call test071
call test072
call test073
call test0735
call test074
call test075
call test076
call test077
call test078
call test079
call test080
call test081
call test0249
call test025
call test026
call test082
call test083
call test084
call test085
call test086
call test087
call test088
call test089
call test090
call test091
call test092
call test093
call test094
call test095
call test096
call test097
call test098
call test099
call test0995
call test100
call test101
call test102
call test103
call test104
call test105
call test106
call test107
call test108
call test109
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'CHRPAK_PRB'
write ( *, '(a)' ) ' Normal end of execution.'
stop
end
subroutine test039
!
!*******************************************************************************
!
!! TEST039 tests A_TO_I.
!! TEST039 tests I_TO_A.
!
implicit none
!
character a
integer a_to_i
integer i
character i_to_a
integer i2
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST039'
write ( *, '(a)' ) ' A_TO_I: Alphabetic character => I'
write ( *, '(a)' ) ' I_TO_A: I => Alphabetic character'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' 1:26 = A:Z'
write ( *, '(a)' ) ' 27:52 = a:z'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I ==> A ==> I'
write ( *, '(a)' ) ' '
do i = 0, 55, 3
a = i_to_a ( i )
i2 = a_to_i ( a )
write ( *, '(i6,5x,a1,5x,i6)' ) i, a, i2
end do
return
end
subroutine test0041
!
!*******************************************************************************
!
!! TEST0041 tests B4_IEEE_TO_R.
!! TEST0041 tests R_TO_B4_IEEE.
!
implicit none
!
integer, parameter :: ntest = 16
!
character ( len = 32 ) bits
integer e
integer f
integer i
real r1
real r2
real, dimension ( ntest ) :: rtest = (/ &
0.25E+00, 0.5E+00, 1.0E+00, 2.0E+00, 4.0E+00, &
1.5E+00, 1.75E+00, 1.875E+00, 6.5E+00, -6.5E+00, &
99.0E+00, 100.0E+00, 101.0E+00, 0.0E+00, -1.0E+00, &
huge ( 1.0E+00 ) /)
integer s
integer word
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0041'
write ( *, '(a)' ) ' B4_IEEE_TO_R: 32 bit string => word'
write ( *, '(a)' ) ' R_TO_B4_IEEE: word => 32 bit string'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' R1 --------------Word-------------- R2'
write ( *, '(a)' ) ' '
do i = 1, ntest
r1 = rtest(i)
call r_to_b4_ieee ( r1, word )
call r_to_bits ( word, bits )
call b4_ieee_to_r ( word, r2 )
write ( *, '(g20.12,2x,a32,2x,g20.12)' ) r1, bits, r2
end do
!
! Extra test values, some of which are unnormalized real quantities.
!
s = 0
e = -125
f = 3
call sef_to_r ( s, e, f, r1 )
call r_to_b4_ieee ( r1, word )
call r_to_bits ( word, bits )
call b4_ieee_to_r ( word, r2 )
write ( *, '(g20.12,2x,a32,2x,g20.12)' ) r1, bits, r2
s = 0
e = -127
f = 3
call sef_to_r ( s, e, f, r1 )
call r_to_b4_ieee ( r1, word )
call r_to_bits ( word, bits )
call b4_ieee_to_r ( word, r2 )
write ( *, '(g20.12,2x,a32,2x,g20.12)' ) r1, bits, r2
s = 0
e = -129
f = 3
call sef_to_r ( s, e, f, r1 )
call r_to_b4_ieee ( r1, word )
call r_to_bits ( word, bits )
call b4_ieee_to_r ( word, r2 )
write ( *, '(g20.12,2x,a32,2x,g20.12)' ) r1, bits, r2
s = 0
e = -132
f = 7
call sef_to_r ( s, e, f, r1 )
call r_to_b4_ieee ( r1, word )
call r_to_bits ( word, bits )
call b4_ieee_to_r ( word, r2 )
write ( *, '(g20.12,2x,a32,2x,g20.12)' ) r1, bits, r2
s = 0
e = -135
f = 15
call sef_to_r ( s, e, f, r1 )
call r_to_b4_ieee ( r1, word )
call r_to_bits ( word, bits )
call b4_ieee_to_r ( word, r2 )
write ( *, '(g20.12,2x,a32,2x,g20.12)' ) r1, bits, r2
return
end
subroutine test00415
!
!*******************************************************************************
!
!! TEST00415 tests B4_IEEE_TO_SEF.
!! TEST00415 tests SEF_TO_B4_IEEE.
!
implicit none
!
integer, parameter :: ntest = 26
!
character ( len = 32 ) bits
integer e
integer e2
integer, parameter, dimension ( ntest) :: etest = (/ &
-2, -1, 0, 1, 2, &
-1, -2, -3, -1, -1, &
0, 2, 0, 0, 0, &
104, -125, -127, -129, -132, &
-135, 0, 0, 128, 128, &
128 /)
integer f
integer f2
integer, parameter, dimension ( ntest) :: ftest = (/ &
1, 1, 1, 1, 1, &
3, 7, 15, 13, 13, &
99, 25, 101, 0, 1, &
16777215, 3, 3, 3, 7, &
15, 0, 0, 1, 1, &
0 /)
integer i
integer s
integer s2
integer, parameter, dimension ( ntest) :: stest = (/ &
0, 0, 0, 0, 0, &
0, 0, 0, 0, 1, &
0, 0, 0, 0, 1, &
0, 0, 0, 0, 0, &
0, 0, 1, 0, 1, &
0 /)
integer word
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST00415'
write ( *, '(a)' ) ' B4_IEEE_TO_SEF converts a real IEEE word to SEF form.'
write ( *, '(a)' ) ' SEF_TO_B4_IEEE converts SEF form to a real IEEE word.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' S is the sign bit (0 = positive, 1 = negative)'
write ( *, '(a)' ) ' E is the exponent base 2'
write ( *, '(a)' ) ' F is the mantissa'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) &
'S E F SEEEEEEEEFFFFFFFFFFFFFFFFFFFFFFF S2 E2 F2'
write ( *, '(a)' ) ' '
do i = 1, ntest
s = stest(i)
e = etest(i)
f = ftest(i)
call sef_to_b4_ieee ( s, e, f, word )
call r_to_bits ( word, bits )
call b4_ieee_to_sef ( word, s2, e2, f2 )
write ( *, '(i2,i5,i10,2x,a32,2x,i2,i5,i10)' ) s, e, f, bits, s2, e2, f2
end do
return
end
subroutine test0042
!
!*******************************************************************************
!
!! TEST0042 tests B4_ULTRIX_TO_R.
!! TEST0042 tests R_TO_B4_ULTRIX.
!
implicit none
!
integer, parameter :: ntest = 16
!
character ( len = 32 ) bits
integer i
real r1
real r2
real, dimension ( ntest ) :: rtest = (/ &
0.25E+00, 0.5E+00, 1.0E+00, 2.0E+00, 4.0E+00, &
1.5E+00, 1.75E+00, 1.875E+00, 6.5E+00, -6.5E+00, &
99.0E+00, 100.0E+00, 101.0E+00, 0.0E+00, -1.0E+00, &
huge ( 1.0E+00 ) /)
integer word
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0042'
write ( *, '(a)' ) ' B4_ULTRIX_TO_R: 32 bit string => word'
write ( *, '(a)' ) ' R_TO_B4_ULTRIX: word => 32 bit string'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' R1 --------------Word-------------- R2'
write ( *, '(a)' ) ' '
do i = 1, ntest
r1 = rtest(i)
call r_to_b4_ultrix ( r1, word )
call r_to_bits ( word, bits )
call b4_ultrix_to_r ( word, r2 )
write ( *, '(g20.12,2x,a32,2x,g20.12)' ) r1, bits, r2
end do
return
end
subroutine test001
!
!*******************************************************************************
!
!! TEST001 tests BASE_TO_I.
!! TEST001 tests I_TO_BASE.
!
implicit none
!
integer, parameter :: ntest = 6
!
integer base
integer, dimension ( ntest ) :: base_test = (/ -1, 1, 2, 3, 4, 8 /)
integer i
integer i1
integer i2
integer intval
integer, dimension ( ntest ) :: i_test = (/ 5, 5, 21, -243, 16, 15 /)
character ( len = 20 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST001'
write ( *, '(a)' ) ' BASE_TO_I converts an integer in some other'
write ( *, '(a)' ) ' base into base 10.'
write ( *, '(a)' ) ' I_TO_BASE converts an integer base 10 to '
write ( *, '(a)' ) ' its representation in another base;'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' BASE, I, I_TO_BASE(I), BASE_TO_I(I_TO_BASE(I))'
write ( *, '(a)' ) ' '
do i = 1, ntest
i1 = i_test(i)
base = base_test(i)
call i_to_base ( i1, base, s )
call base_to_i ( s, base, i2 )
write ( *, '(i8,2x,i8,2x,a,i8)' ) base, i1, s, i2
end do
return
end
subroutine test002
!
!*******************************************************************************
!
!! TEST002 tests BINARY_TO_I.
!! TEST002 tests I_TO_BINARY.
!
implicit none
!
integer, parameter :: ntest = 4
!
integer i
integer i1
integer i2
integer, dimension ( ntest ) :: i_test = (/ 21, -32, 2, 128 /)
character ( len = 10 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST002'
write ( *, '(a)' ) ' BINARY_TO_I converts a binary to an integer.'
write ( *, '(a)' ) ' I_TO_BINARY converts an integer to binary,'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I, I_TO_BINARY(I), BINARY_TO_I(I_TO_BIN(I))'
write ( *, '(a)' ) ' '
do i = 1, ntest
i1 = i_test(i)
call i_to_binary ( i1, s )
call binary_to_i ( s, i2 )
write ( *, '(2x,i6,2x,a,2x,i6)' ) i1, s, i2
end do
return
end
subroutine test003
!
!*******************************************************************************
!
!! TEST003 tests BINARY_TO_R.
!! TEST003 tests R_TO_BINARY.
!
implicit none
!
integer, parameter :: ntest = 3
!
integer i
real r1
real r2
real rtest(ntest)
character ( len = 20 ) s
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST003'
write ( *, '(a)' ) ' BINARY_TO_R: binary string => real.'
write ( *, '(a)' ) ' R_TO_BINARY: real => binary string;'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' R => S => R'
write ( *, '(a)' ) ' '
rtest(1) = - 10.75E+00
rtest(2) = 0.25E+00 + 0.125E+00 + 0.03125E+00 + 0.015625E+00
rtest(3) = 2.0E+00 / 3.0E+00
do i = 1, ntest
r1 = rtest(i)
call r_to_binary ( r1, s )
call binary_to_r ( s, r2 )
write ( *, '(f12.6, 2x, a, 2x, f12.6)' ) r1, s, r2
end do
return
end
subroutine test004
!
!*******************************************************************************
!
!! TEST004 tests BITS_TO_I.
!! TEST004 tests I_TO_BITS.
!
implicit none
!
integer, parameter :: ntest = 11
!
integer i
integer i1
integer i2
integer, dimension ( ntest ) :: itest = &
(/ 0, 1, 2, 3, 64, -1, -2, -3, -64, 1234567, huge ( 1 ) /)
integer nbits
character ( len = 32 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST004'
write ( *, '(a)' ) ' BITS_TO_I: 32 bit string => word'
write ( *, '(a)' ) ' I_TO_BITS: word => 32 bit string'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I1 --------------Word-------------- I2'
write ( *, '(a)' ) ' '
do i = 1, ntest
i1 = itest(i)
call i_to_bits ( i1, s )
call bits_to_i ( s, i2 )
write ( *, '(i12,2x,a32,2x,i12)' ) i1, s, i2
end do
return
end
subroutine test0045
!
!*******************************************************************************
!
!! TEST0045 tests BITS_TO_R.
!! TEST0045 tests R_TO_BITS.
!
implicit none
!
integer, parameter :: ntest = 11
!
integer i
integer nbits
real r1
real r2
real rtest(ntest)
character ( len = 32 ) s
!
rtest(1:10) = (/ 1.0E+00, 1.5E+00, 1.75E+00, 2.0E+00, 3.0E+00, &
4.0E+00, 100.0E+00, 0.0E+00, -1.0E+00, 0.25E+00 /)
rtest(11) = huge ( rtest(11) )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0045'
write ( *, '(a)' ) ' BITS_TO_R: 32 bit string => word'
write ( *, '(a)' ) ' R_TO_BITS: word => 32 bit string'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' R1 --------------Word-------------- R2'
write ( *, '(a)' ) ' '
do i = 1, ntest
r1 = rtest(i)
call r_to_bits ( r1, s )
call bits_to_r ( s, r2 )
write ( *, '(g20.12,2x,a32,2x,g20.12)' ) r1, s, r2
end do
return
end
subroutine test005
!
!*******************************************************************************
!
!! TEST005 tests I_BYTE_SWAP.
!
implicit none
!
integer, parameter :: n = 10
!
integer i
integer ios
real pi
real temp
real x(n)
!
pi = 4.0E+00 * atan2 ( 1.0E+00, 1.0E+00 )
temp = 1.0E+00
do i = 1, n
temp = - pi * temp
x(i) = temp
end do
!
! Tell the user our data.
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST005'
write ( *, '(a)' ) ' I_BYTE_SWAP swaps bytes in a 4 byte word.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Data from a different computer can be'
write ( *, '(a)' ) ' read this way, if necessary.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Here is the data written to the file:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(g14.6)' ) x(i)
end do
!
! Write the data to a fixed length record file.
!
open ( unit = 1, file = 'chrprb.dat', form = 'unformatted', &
access = 'direct', recl = 4, iostat = ios, status = 'replace' )
if ( ios /= 0 ) then
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Fatal error!'
write ( *, '(a)' ) ' Error while opening unit 1.'
stop
end if
do i = 1, n
write ( 1, rec = i ) x(i)
end do
close ( unit = 1 )
return
end
subroutine test006
!
!*******************************************************************************
!
!! TEST006 tests I_BYTE_SWAP.
!
implicit none
!
integer, parameter :: n = 10
!
integer bytes(4)
integer i
integer ios
real temp
real x(n)
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST006'
write ( *, '(a)' ) ' I_BYTE_SWAP swaps bytes.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Read the data in CHRPRB.DAT.'
!
! Read the data from a fixed length record file.
!
open ( unit = 1, file = 'chrprb.dat', form = 'unformatted', &
access = 'direct', recl = 4, iostat = ios, status = 'old' )
if ( ios /= 0 ) then
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Fatal error!'
write ( *, '(a)' ) ' Error while opening unit 1.'
stop
end if
do i = 1, n
read ( 1, rec = i ) x(i)
end do
close ( unit = 1, status = 'delete' )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Here is the plain data from the file:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(g14.6)' ) x(i)
end do
bytes = (/ 4, 3, 2, 1 /)
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Using byte order:'
write ( *, '(a)' ) ' '
write ( *, '(4i1)' ) bytes
write ( *, '(a)' ) ' our data becomes:'
write ( *, '(a)' ) ' '
do i = 1, n
temp = x(i)
call i_byte_swap ( temp, bytes )
write ( *, '(g14.6)' ) temp
end do
bytes = (/ 2, 1, 4, 3 /)
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Using byte order:'
write ( *, '(a)' ) ' '
write ( *, '(4i1)' ) bytes
write ( *, '(a)' ) ' our data becomes:'
write ( *, '(a)' ) ' '
do i = 1, n
temp = x(i)
call i_byte_swap ( temp, bytes )
write ( *, '(g14.6)' ) temp
end do
bytes = (/ 3, 4, 1, 2 /)
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Using byte order:'
write ( *, '(a)' ) ' '
write ( *, '(4i1)' ) bytes
write ( *, '(a)' ) ' our data becomes:'
write ( *, '(a)' ) ' '
do i = 1, n
temp = x(i)
call i_byte_swap ( temp, bytes )
write ( *, '(g14.6)' ) temp
end do
bytes = (/ 2, 2, 2, 4 /)
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Using byte order:'
write ( *, '(a)' ) ' '
write ( *, '(4i1)' ) bytes
write ( *, '(a)' ) ' our data becomes:'
write ( *, '(a)' ) ' '
do i = 1, n
temp = x(i)
call i_byte_swap ( temp, bytes )
write ( *, '(g14.6)' ) temp
end do
return
end
subroutine test0065
!
!*******************************************************************************
!
!! TEST0065 tests CH_COUNT_FILE_ADD.
!
implicit none
!
integer count(0:255)
character ( len = 80 ) :: file_name = 'chrpak_prb.f90'
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0065'
write ( *, '(a)' ) ' CH_COUNT_FILE_ADD adds the characters in a file'
write ( *, '(a)' ) ' to a character count.'
call ch_count_init ( count )
call ch_count_file_add ( file_name, count )
call ch_count_print ( count, 'Raw character count data:' )
call ch_count_histogram_print ( count, file_name )
return
end
subroutine test007
!
!*******************************************************************************
!
!! TEST007 tests CH_EXTRACT.
!
implicit none
!
character c
character ( len = 80 ) s
!
s = ' A bc $ '
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST007'
write ( *, '(a)' ) ' CH_EXTRACT extracts characters from a string.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' The string: ' // trim ( s )
write ( *, '(a)' ) ' '
do
call ch_extract ( s, c )
if ( c == ' ' ) then
exit
end if
write ( *, '(4x,a)' ) c
end do
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Reached the last character.'
return
end
subroutine test008
!
!*******************************************************************************
!
!! TEST008 tests CH_INDEX.
!
implicit none
!
character c
integer ch_index
integer iloc
character ( len = 40 ) s
!
c = 'g'
s = 'Joel prefers graphics to graphs.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST008'
write ( *, '(a)' ) ' CH_INDEX searches a string for a character.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' String = ' // trim ( s )
write ( *, '(a)' ) ' Character = ' // c
iloc = ch_index ( s, c )
write ( *, '(a)' ) ' Character occurs at location ', iloc
return
end
subroutine test009
!
!*******************************************************************************
!
!! TEST009 tests CH_NEXT.
!
implicit none
!
character c
logical done
character ( len = 20 ) s
!
s = 'A B, C DE F'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST009'
write ( *, '(a)' ) ' CH_NEXT returns characters from a string.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Input: ' // trim ( s )
done = .true.
do
call ch_next ( s, c, done )
if ( done ) then
write ( *, '(a)' ) ' No more characters.'
exit
end if
write ( *, '(2x,a)' ) c
end do
return
end
subroutine test0095
!
!*******************************************************************************
!
!! TEST0095 tests CH_ROMAN_TO_I.
!
implicit none
!
integer ch_roman_to_i
character c
logical done
integer ival
character ( len = 20 ) s
!
s = 'IJVXLCDMijvxlcdm0 W%'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0095'
write ( *, '(a)' ) ' CH_ROMAN_TO_I converts a Roman numeral character'
write ( *, '(a)' ) ' to its corresponding integer value.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Input: ' // trim ( s )
done = .true.
do
call ch_next ( s, c, done )
if ( done ) then
exit
end if
ival = ch_roman_to_i ( c )
write ( *, '(2x,a,2x,i6)' ) c, ival
end do
return
end
subroutine test010
!
!*******************************************************************************
!
!! TEST010 tests CH_TO_BRAILLE.
!
implicit none
!
integer i
integer j
integer ncol
integer ncol2
character ( len = 6 ) braille(3)
character ( len = 12 ) :: s = 'SOS Titanic!'
character ( len = 100 ) string2(3)
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST010'
write ( *, '(a)' ) ' CH_TO_BRAILLE converts a character to Braille.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Here is the string to be converted:'
write ( *, '(a)' ) ' '
write ( *, '(4x,a)' ) trim ( s )
string2(1:3) = ' '
ncol2 = 0
do i = 1, len_trim ( s )
call ch_to_braille ( s(i:i), ncol, braille )
if ( ncol > 0 ) then
do j = 1, 3
string2(j)(ncol2+1:ncol2+ncol) = braille(j)(1:ncol)
end do
ncol2 = ncol2 + ncol
end if
end do
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Braille translation:'
write ( *, '(a)' ) ' '
do i = 1, 3
write ( *, '(4x,a)' ) string2(i)(1:ncol2)
end do
return
end
subroutine test011
!
!*******************************************************************************
!
!! TEST011 tests CH_TO_AMINO_NAME.
!! TEST011 tests CH_TO_CH3_AMINO.
!! TEST011 tests CH3_TO_CH_AMINO.
!! TEST011 tests I_TO_AMINO_CODE.
!
implicit none
!
character ( len = 27 ) amino_name
character c
character ch_back
character ( len = 3 ) c3
integer i
character i_to_a
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST011'
write ( *, '(a)' ) ' CH_TO_CH3_AMINO converts a 1 character amino'
write ( *, '(a)' ) ' acid code to 3 characters,'
write ( *, '(a)' ) ' CH3_TO_CH_AMINO converts a 3 character amino'
write ( *, '(a)' ) ' acid code to 1 character.'
write ( *, '(a)' ) ' CH_TO_AMINO_NAME converts a 1 character amino'
write ( *, '(a)' ) ' acid code to an amino acid name.'
write ( *, '(a)' ) ' I_TO_AMINO_CODE converts an integer to an'
write ( *, '(a)' ) ' amino code.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I -> A -> CCC -> C'
write ( *, '(a)' ) ' '
do i = 1, 26
c = i_to_a ( i )
call ch_to_ch3_amino ( c, c3 )
call ch3_to_ch_amino ( c3, ch_back )
write ( *, '(2x,i2,4x,a1,4x,a3,4x,a1)' ) i, c, c3, ch_back
end do
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I -> Alpha -> AMINO_NAME'
write ( *, '(a)' ) ' '
do i = 1, 26
c = i_to_a ( i )
call ch_to_amino_name ( c, amino_name )
write ( *, '(2x,i2,4x,a1,4x,a27)' ) i, c, amino_name
end do
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I -> AMINO_CODE -> AMINO_NAME'
write ( *, '(a)' ) ' '
do i = 1, 23
call i_to_amino_code ( i, c )
call ch_to_amino_name ( c, amino_name )
write ( *, '(2x,i2,4x,a1,4x,a27)' ) i, c, amino_name
end do
return
end
subroutine test012
!
!*******************************************************************************
!
!! TEST012 tests CH_TO_DIGIT.
!! TEST012 tests DIGIT_TO_C.
!
implicit none
!
character c
integer i
integer i2
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST012'
write ( *, '(a)' ) ' CH_TO_DIGIT: character -> decimal digit'
write ( *, '(a)' ) ' DIGIT_TO_C: decimal digit -> character.'
write ( *, '(a)' ) ' '
do i = -2, 11
call digit_to_ch ( i, c )
call ch_to_digit ( c, i2 )
write ( *, '(2x,i6,a6,i6)' ) i, c, i2
end do
return
end
subroutine test013
!
!*******************************************************************************
!
!! TEST013 tests CH_TO_DIGIT_HEX.
!! TEST013 tests DIGIT_HEX_TO_C.
!
implicit none
!
character c
integer i
integer i2
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST013'
write ( *, '(a)' ) ' CH_TO_DIGIT_HEX: character -> hexadecimal'
write ( *, '(a)' ) ' DIGIT_HEX_TO_C: hexadecimal -> character.'
write ( *, '(a)' ) ' '
do i = -2, 17
call digit_hex_to_ch ( i, c )
call ch_to_digit_hex ( c, i2 )
write ( *, '(2x,i6,a6,i6)' ) i, c, i2
end do
return
end
subroutine test014
!
!*******************************************************************************
!
!! TEST014 tests CH_TO_DIGIT_OCT.
!! TEST014 tests DIGIT_OCT_TO_C.
!
implicit none
!
character c
integer i
integer i2
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST014'
write ( *, '(a)' ) ' CH_TO_DIGIT_OCT: character -> hexadecimal'
write ( *, '(a)' ) ' DIGIT_OCT_TO_C: hexadecimal -> character.'
write ( *, '(a)' ) ' '
do i = -2, 9
call digit_oct_to_ch ( i, c )
call ch_to_digit_oct ( c, i2 )
write ( *, '(2x,i6,a6,i6)' ) i, c, i2
end do
return
end
subroutine test0145
!
!*******************************************************************************
!
!! TEST0145 tests CH_TO_MILITARY.
!! TEST0145 tests MILITARY_TO_C.
!
implicit none
!
character c
character ch_back
character ( len = 8 ) c8
integer i
character i_to_a
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0145'
write ( *, '(a)' ) ' CH_TO_MILITARY converts a character to military code.'
write ( *, '(a)' ) ' MILITARY_TO_CH converts a military code to a character.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I -> C -> Mil -> C'
write ( *, '(a)' ) ' '
do i = 1, 52, 4
c = i_to_a ( i )
call ch_to_military ( c, c8 )
call military_to_ch ( c8, ch_back )
write ( *, '(4x,i2,4x,a1,4x,a8,4x,a1)' ) i, c, c8, ch_back
end do
return
end
subroutine test015
!
!*******************************************************************************
!
!! TEST015 tests CH_TO_MORSE.
!! TEST015 tests S_CAT1.
!
implicit none
!
integer i
character ( len = 6 ) morse
character ( len = 20 ) s
character ( len = 80 ) s2
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST015'
write ( *, '(a)' ) ' CH_TO_MORSE converts ASCII to Morse.'
write ( *, '(a)' ) ' S_CAT1 concatenates strings with a blank separator.'
s = 'SOS Titanic!'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' The string to be converted:'
write ( *, '(a)' ) ' '
write ( *, '(4x,a)' ) trim ( s )
s2 = ' '
do i = 1, len_trim ( s )
call ch_to_morse ( s(i:i), morse )
call s_cat1 ( s2, morse, s2 )
end do
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Morse translation:'
write ( *, '(a)' ) ' '
write ( *, '(4x,a)' ) trim ( s2 )
return
end
subroutine test016
!
!*******************************************************************************
!
!! TEST016 tests CH_TO_SOUNDEX.
!
implicit none
!
integer i
character ( len = 30 ) s1
character ( len = 30 ) s2
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST016'
write ( *, '(a)' ) ' CH_TO_SOUNDEX converts ASCII characters'
write ( *, '(a)' ) ' to Soundex characters (digits).'
s1 = 'SOS - Titanic & Mayflower!'
s2 = ' '
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Here is the string to be converted:'
write ( *, '(a)' ) ' '
write ( *, '(4x,a)' ) trim ( s1 )
do i = 1, len_trim ( s1 )
call ch_to_soundex ( s1(i:i), s2(i:i) )
end do
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Soundex translation:'
write ( *, '(a)' ) ' '
write ( *, '(4x,a)' ) trim ( s2 )
return
end
subroutine test0165
!
!*******************************************************************************
!
!! TEST0165 tests CH_TO_SYM.
!! TEST0165 tests SYM_TO_CH.
!
implicit none
!
character ch
character ch2
character ( len = 4 ) failok
integer i
integer ihi
logical ch_is_printable
character ( len = 4 ) sym
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0165'
write ( *, '(a)' ) ' CH_TO_SYM converts ANY charcter to a printable symbol.'
write ( *, '(a)' ) ' SYM_TO_CH converts a printable symbol to a character.'
write ( *, '(a)' ) ' '
do i = 0, 255
ch = char ( i )
call ch_to_sym ( ch, sym )
call sym_to_ch ( sym, ch2, ihi )
if ( ch == ch2 ) then
failok = 'OK'
else
failok = 'FAIL'
end if
if ( ch_is_printable ( ch ) ) then
write ( *, '(a4,2x,i3,2x,a1,4x,a4,4x,a1)' ) failok, i, ch, sym, ch2
else
write ( *, '(a4,2x,i3,2x,1x,4x,a4,4x,1x)' ) failok, i, sym
end if
end do
return
end
subroutine test017
!
!*******************************************************************************
!
!! TEST017 tests CH4_TO_I.
!! TEST017 tests I_TO_CH4.
!
implicit none
!
integer, parameter :: ntest = 4
!
integer i
integer intval
character ( len = 4 ) word(ntest)
character ( len = 4 ) word2
!
word(1) = 'Adam'
word(2) = 'Bill'
word(3) = 'Crow'
word(4) = 'Dave'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST017'
write ( *, '(a)' ) ' I_TO_CH4: Integer -> 4 characters;'
write ( *, '(a)' ) ' CH4_TO_I: 4 characters -> Integer.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'CH4 --> CH4_TO_I(CH4) --> I_TO_CH4(CH4_TO_I(CH4))'
write ( *, '(a)' ) ' '
do i = 1, ntest
call ch4_to_i ( word(i), intval )
call i_to_ch4 ( intval, word2 )
write ( *, '(a4,2x,i12,2x,a4)' ) word(i), intval, word2
end do
do i = 1, ntest
call s_reverse ( word(i) )
end do
do i = 1, ntest
call ch4_to_i ( word(i), intval )
call i_to_ch4 ( intval, word2 )
write ( *, '(a4,2x,i12,2x,a4)' ) word(i), intval, word2
end do
return
end
subroutine test018
!
!*******************************************************************************
!
!! TEST018 tests CH4_TO_R.
!! TEST018 tests R_TO_CH4.
!
implicit none
!
integer, parameter :: ntest = 4
!
integer i
real rval
character ( len = 4 ) word(ntest)
character ( len = 4 ) word2
!
word(1) = 'Adam'
word(2) = 'Bill'
word(3) = 'Crow'
word(4) = 'Dave'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST018'
write ( *, '(a)' ) ' CH4_TO_R: 4 character => real.'
write ( *, '(a)' ) ' R_TO_CH4: real => 4 character.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' word --> CH4_TO_R(word) --> R_TO_CH4(CH4_TO_R(word))'
write ( *, '(a)' ) ' '
do i = 1, ntest
call ch4_to_r ( word(i), rval )
call r_to_ch4 ( rval, word2 )
write ( *, '(a4,2x,g14.6,2x,a4)' ) word(i), rval, word2
end do
return
end
subroutine test019
!
!*******************************************************************************
!
!! TEST019 tests CENTER.
!! TEST019 tests LEFT.
!! TEST019 tests RIGHT.
!
implicit none
!
character ( len = 10 ) string1
character ( len = 30 ) string2
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST019'
write ( *, '(a)' ) ' LEFT inserts a string left of another;'
write ( *, '(a)' ) ' CENTER inserts it in the center;'
write ( *, '(a)' ) ' RIGHT inserts it to the right.'
write ( *, '(a)' ) ' '
string1 = 'ZOWIE'
string2 = '123456789012345678901234567890'
write ( *, '(a)' ) ' The string to be inserted is: ' // trim ( string1 )
write ( *, '(a)' ) ' The string in which we insert is: ' // trim ( string2 )
call left ( string1, string2 )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Result, calling LEFT: ' // trim ( string2 )
string1 = 'ZOWIE'
string2 = '123456789012345678901234567890'
call center ( string1, string2 )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Result, calling CENTER: ' // trim ( string2 )
string1 = 'ZOWIE'
string2 = '123456789012345678901234567890'
call right ( string1, string2 )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Result, calling RIGHT: ' // trim ( string2 )
return
end
subroutine test020
!
!*******************************************************************************
!
!! TEST020 tests CHR4_TO_8.
!! TEST020 tests CHR8_TO_4.
!
implicit none
!
character chrtmp
character chrtmp2
integer i
integer ichr
integer j
character ( len = 256 ) s1
character ( len = 512 ) s2
character ( len = 256 ) s3
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST020'
write ( *, '(a)' ) ' CHR8_TO_4 convert characters to pairs of hexadecimals.'
write ( *, '(a)' ) ' CHR4_TO_8 converts pairs of hexadecimals to characters.'
write ( *, '(a)' ) ' '
do i = 1, 256
s1(i:i) = char(i-1)
end do
call chr8_to_4 ( s1, s2 )
call chr4_to_8 ( s2, s3 )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Coded characters that can''t be printed are shown as blanks.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' ASCII Coded Decoded'
write ( *, '(a)' ) ' '
do i = 1, 256
ichr = i - 1
j = 2 * i - 1
if ( ichr >= 33 .and. ichr <= 127 ) then
chrtmp = s1(i:i)
chrtmp2 = s3(i:i)
else
chrtmp = ' '
chrtmp2 = ' '
end if
write ( *, '(i3,1x,a1,6x,a2,7x,a1)' ) ichr, chrtmp, s2(j:j+1), chrtmp2
end do
return
end
subroutine test021
!
!*******************************************************************************
!
!! TEST021 tests CHRASS.
!
implicit none
!
integer, parameter :: ntest = 8
!
integer i
character ( len = 20 ) lhs
character ( len = 20 ) rhs
character ( len = 20 ) s(ntest)
!
s(1) = 'a = 1.0'
s(2) = 'n = -17'
s(3) = 'scale = +5.3E-2'
s(4) = 'filename = myprog.f'
s(5) = ' = A pot of gold'
s(6) = 'Fred'
s(7) = ' = Bob'
s(8) = '1 = 2, 2 = 3, 3 = 4'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST021'
write ( *, '(a)' ) ' CHRASS parses an assignment statement.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'STRING LHS RHS'
write ( *, '(a)' ) ' '
do i = 1, ntest
call chrass ( s(i), lhs, rhs )
write ( *, '(a20,2x,a20,2x,a20)' ) s(i), lhs, rhs
end do
return
end
subroutine test022
!
!*******************************************************************************
!
!! TEST022 tests CHRCTP.
!
implicit none
!
integer, parameter :: ntest = 10
!
complex cval
integer i
integer ierror
integer lchar
character ( len = 20 ) string(ntest)
!
string ( 1) = '(1,1)'
string ( 2) = '(,)'
string ( 3) = '( 20 , 99 )'
string ( 4) = '(-1.2E+2, +30E-2)'
string ( 5) = '(1)'
string ( 6) = '(1,2,3)'
string ( 7) = '(4,5('
string ( 8) = '(6,)'
string ( 9) = '(7;8)'
string (10) = '9'
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST022'
write ( *, '(a)' ) ' CHRCTP accepts a string of characters'
write ( *, '(a)' ) ' and extracts a complex value from them,'
write ( *, '(a)' ) ' assuming the format (A,B) for complex numbers.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'STRING CVAL IERROR LCHAR'
write ( *, '(a)' ) ' '
do i = 1, ntest
call chrctp ( string(i), cval, ierror, lchar )
write ( *, '(a20,2x,2f8.1,2x,i2,6x,i2)' ) string(i), cval, ierror, lchar
end do
return
end
subroutine test0225
!
!*******************************************************************************
!
!! TEST0225 tests D_TO_S_LEFT.
!! TEST0225 tests D_TO_S_RIGHT.
!! TEST0225 tests S_TO_D.
!
implicit none
!
integer, parameter :: ntest = 4
!
integer i
integer ierror
integer lchar
double precision r
character ( len = 20 ) stest(ntest)
character ( len = 20 ) s
character ( len = 14 ) s2
!
stest(1) = '52.134ABCDE'
stest(2) = ' 2.0/6.0'
stest(3) = ' 12D-1, 34, 56'
stest(4) = '0.0001234'
write ( *, '(a)') ' '
write ( *, '(a)' ) 'TEST0225'
write ( *, '(a)' ) ' S_TO_D, string -> double precision number;'
write ( *, '(a)' ) ' D_TO_S_LEFT, double precision number -> left string.'
write ( *, '(a)' ) ' D_TO_S_RIGHT, double precision number -> right string.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' S --> S_TO_D --> D_TO_S_LEFT'
write ( *, '(a)' ) ' '
do i = 1, ntest
s = stest(i)
call s_to_d ( s, r, ierror, lchar )
call d_to_s_left ( r, s2 )
write ( *, '(2x,a20,2x,g14.6,2x,a14)' ) s, r, s2
end do
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' S --> S_TO_D --> D_TO_S_RIGHT'
write ( *, '(a)' ) ' '
do i = 1, ntest
s = stest(i)
call s_to_d ( s, r, ierror, lchar )
call d_to_s_right ( r, s2 )
write ( *, '(2x,a20,2x,g14.6,2x,a14)' ) s, r, s2
end do
return
end
subroutine test023
!
!*******************************************************************************
!
!! TEST023 tests HEX_TO_S.
!! TEST023 tests S_TO_HEX.
!
implicit none
!
integer, parameter :: ntest = 3
!
character ( len = 5 ) chrval(ntest)
character ( len = 5 ) chrval2
character ( len = 10 ) hexstr
integer i
!
chrval(1) = 'ABC'
chrval(2) = 'Wow!!'
chrval(3) = '1234'
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST023'
write ( *, '(a)' ) ' S_TO_HEX: string -> hexadecimal;'
write ( *, '(a)' ) ' HEX_TO_S: hexadecimal -> string.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' String Hexadecimal Recovered string'
write ( *, '(a)' ) ' '
do i = 1, ntest
call s_to_hex ( chrval(i), hexstr )
call hex_to_s ( hexstr, chrval2 )
write ( *, '(a5,2x,a10,2x,a5)' ) chrval(i), hexstr, chrval2
end do
return
end
subroutine test024
!
!*******************************************************************************
!
!! TEST024 tests S_S_INSERT.
!
implicit none
!
integer ipos
character ( len = 40 ) s
character ( len = 4 ) s2
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST024'
write ( *, '(a)' ) ' S_S_INSERT inserts one string into another.'
write ( *, '(a)' ) ' '
s = 'Where are the snows of yesteryear?'
s2 = 'plow'
ipos = 19
write ( *, '(a,i6,a)' ) 'Insert ''' // trim ( s2 ) // '" into position ', &
ipos, ' of '
write ( *, '(a)' ) trim ( s )
call s_s_insert ( s, ipos, s2 )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Result:'
write ( *, '(a)' ) trim ( s )
return
end
subroutine test027
!
!*******************************************************************************
!
!! TEST027 tests COMMA.
!
implicit none
!
character ( len = 30 ) input
character ( len = 30 ) output
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST027'
write ( *, '(a)' ) ' COMMA shifts commas left through blanks.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) '--------Input------- -------Output-------'
write ( *, '(a)' ) ' '
input = ' To Henry , our dog ,'
output = input
call comma ( output )
write ( *, '(a,2x,a)' ) input, output
input = ' 14 , 15 , 16 ,'
output = input
call comma ( output )
write ( *, '(a,2x,a)' ) input, output
input = ' , , , '
output = input
call comma ( output )
write ( *, '(a,2x,a)' ) input, output
return
end
subroutine test028
!
!*******************************************************************************
!
!! TEST028 tests CHVEC_TO_S.
!! TEST028 tests S_TO_CHVEC.
!
implicit none
!
integer, parameter :: ntest = 20
!
character chvec(20)
integer i
integer n
character ( len = 20 ) s
!
s = 'Yabba Blabba'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST028'
write ( *, '(a)' ) ' CHVEC_TO_S: character vector => string;'
write ( *, '(a)' ) ' S_TO_CHVEC: string to character vector.'
write ( *, '(a)' ) ' '
n = 0
call s_to_chvec ( s, n, chvec )
write ( *, '(a)' ) ' String: ' // trim ( s )
write ( *, '(a)' ) ' '
write ( *, '(a,20(1x,a1))' ) 'CHVEC: ', ( chvec(i), i = 1, n )
s = ' '
call chvec_to_s ( n, chvec, s )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Recovered string: ' // trim ( s )
return
end
subroutine test029
!
!*******************************************************************************
!
!! TEST029 tests DEC_TO_S_LEFT.
!! TEST029 tests S_TO_DEC.
!
implicit none
!
integer, parameter :: ntest = 20
!
integer i
integer i2
integer, dimension ( ntest ) :: itest = (/ &
0, 21, -3, -31, 147, 16, 34, 123, 123, 123, &
123, 123, -123, -123, -123, -123, -123, 34, 99, 99 /)
integer j
integer j2
integer, dimension ( ntest ) :: jtest = (/ &
0, 3, 0, -2, -2, -5, 30, -19, -20, -21, &
-22, -23, -19, -20, -21, -22, -23, -30, -99, 99 /)
integer k
integer length
character ( len = 22 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST029'
write ( *, '(a)' ) ' For decimals I * 10**J,'
write ( *, '(a)' ) ' DEC_TO_S_LEFT: -> decimal to left string;'
write ( *, '(a)' ) ' S_TO_DEC: string to decimal.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I J S_LEFT ' &
// ' LENGTH I2 J2'
write ( *, '(a)' ) '--------- --------- ' // &
'---------------------- ------ --------------'
write ( *, '(a)' ) ' '
do k = 1, ntest
i = itest(k)
j = jtest(k)
call dec_to_s_left ( i, j, s )
call s_to_dec ( s, i2, j2, length )
write ( *, '(i10,i10,2x,a22,2x,i3,2x,i10,i10)' ) i, j, s, length, i2, j2
end do
return
end
subroutine test030
!
!*******************************************************************************
!
!! TEST030 tests DEC_TO_S_RIGHT.
!! TEST030 tests S_TO_DEC.
!
implicit none
!
integer, parameter :: ntest = 20
!
integer i
integer i2
integer, dimension ( ntest ) :: itest = (/ &
0, 21, -3, -31, 147, 16, 34, 123, 123, 123, &
123, 123, -123, -123, -123, -123, -123, 34, 99, 99 /)
integer j
integer j2
integer, dimension ( ntest ) :: jtest = (/ &
0, 3, 0, -2, -2, -5, 30, -19, -20, -21, &
-22, -23, -19, -20, -21, -22, -23, -30, -99, 99 /)
integer k
integer length
character ( len = 22 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST030'
write ( *, '(a)' ) ' For decimals I * 10**J,'
write ( *, '(a)' ) ' DEC_TO_S_RIGHT: -> decimal to right string.'
write ( *, '(a)' ) ' S_TO_DEC: string to decimal.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I J S_RIGHT ' &
// ' LENGTH I2 J2'
write ( *, '(a)' ) '--------- --------- ' // &
'---------------------- ------ --------------'
write ( *, '(a)' ) ' '
do k = 1, ntest
i = itest(k)
j = jtest(k)
call dec_to_s_right ( i, j, s )
call s_to_dec ( s, i2, j2, length )
write ( *, '(i10,i10,2x,a22,2x,i3,2x,i10,i10)' ) i, j, s, length, i2, j2
end do
return
end
subroutine test031
!
!*******************************************************************************
!
!! TEST031 tests DEC_TO_S_LEFT.
!! TEST031 tests S_TO_DEC.
!
implicit none
!
integer, parameter :: ntest = 11
!
integer i
integer j
integer k
integer length
character ( len = 10 ) s
character ( len = 22 ) s2
character ( len = 10 ), dimension ( ntest ) :: stest = (/ &
'1 ', '1A ', '+12,34,56 ', ' 34 7 ', &
'-1 E2ABCD ', '-1 X2ABCD ', ' 2E-1 ', '23.45 ', &
'Inf ', 'NaN ', ' c ' /)
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST031'
write ( *, '(a)' ) ' For decimals I * 10**J,'
write ( *, '(a)' ) ' DEC_TO_S_LEFT: -> decimal to left string;'
write ( *, '(a)' ) ' S_TO_DEC: string to decimal.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' S in I J' &
// ' LENGTH S out '
write ( *, '(a)' ) '---------------------- ------ ------' &
// ' ------ ---------------------'
write ( *, '(a)' ) ' '
do k = 1, ntest
s = stest(k)
call s_to_dec ( s, i, j, length )
call dec_to_s_left ( i, j, s2 )
write ( *, '(a,2x,i6,2x,i6,2x,i6,2x,a)' ) s, i, j, length, s2
end do
return
end
subroutine test032
!
!*******************************************************************************
!
!! TEST032 tests EBCDIC_TO_S.
!
implicit none
!
character ( len = 13 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST032'
write ( *, '(a)' ) ' EBCDIC_TO_S converts a EBCDIC string to ASCII.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' We will not print out the "before" string!'
write ( *, '(a)' ) ' '
s = char(200) // char(133) // char(147) // char(147) // char(150) // &
char(107) // char( 64) // char(166) // char(150) // char(153) // &
char(147) // char(132) // char( 90)
call ebcdic_to_s ( s )
write ( *, '(a)' ) ' After conversion:'
write ( *, '(a)' ) ' '
write ( *, '(4x,a)' ) trim ( s )
return
end
subroutine test033
!
!*******************************************************************************
!
!! TEST033 tests FLT_TO_S.
!! TEST033 tests R_TO_FLT.
!
implicit none
!
integer, parameter :: ntest = 10
!
integer i
integer iexp
integer isgn
integer mant
integer ndig
real rtest(ntest)
real rval
character ( len = 40 ) s
!
rtest(1) = 1.0E+00
rtest(2) = 10.0E+00
rtest(3) = 100.0E+00
rtest(4) = 101.0E+00
rtest(5) = 99.0E+00
rtest(6) = 0.0E+00
rtest(7) = -1.0E+00
rtest(8) = -123.456E+00
rtest(9) = -0.123456E+00
rtest(10) = 0.000000123456E+00
ndig = 5
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST033'
write ( *, '(a)' ) ' R_TO_FLT: real -> scientific representation;'
write ( *, '(a)' ) ' FLT_TO_S: scientific representation -> string:'
write ( *, '(a)' ) ' '
write ( *, '(a,i6)' ) ' The number of digits used is ', ndig
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' RVAL ISGN MANT IEXP S'
write ( *, '(a)' ) ' '
do i = 1, ntest
rval = rtest(i)
call r_to_flt ( rval, isgn, mant, iexp, ndig )
mant = isgn * mant
call flt_to_s ( mant, iexp, ndig, s )
write ( *, '(g14.6,2x,i2,2x,i6,2x,i6,2x,a40)' ) rval, isgn, mant, iexp, s
end do
return
end
subroutine test034
!
!*******************************************************************************
!
!! TEST034 tests HEX_TO_I.
!! TEST034 tests I_TO_HEX.
!
implicit none
!
integer, parameter :: ntest = 3
!
character ( len = 8 ) hexstr
integer i
integer intval
integer intval2
integer itest(ntest)
!
itest(1) = 21
itest(2) = -32
itest(3) = 1776
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST034'
write ( *, '(a)' ) ' HEX_TO_I, hexadecimal->integer.'
write ( *, '(a)' ) ' I_TO_HEX, integer->hexadecimal'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I, I_TO_HEX(I), HEX_TO_I(I_TO_HEX(I)) '
write ( *, '(a)' ) ' '
do i = 1, ntest
intval = itest(i)
call i_to_hex ( intval, hexstr )
call hex_to_i ( hexstr, intval2 )
write ( *, '(i8,2x,a8,2x,i8)' ) intval, hexstr, intval2
end do
return
end
subroutine test035
!
!*******************************************************************************
!
!! TEST035 tests I_EXTRACT.
!
implicit none
!
integer i
integer ierror
character ( len = 80 ) s
!
s = ' 123 45 789'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST035'
write ( *, '(a)' ) ' I_EXTRACT extracts integers from a string.'
write ( *, '(a)' ) ' '
write ( *, '(4x,a)' ) trim ( s )
write ( *, '(a)' ) ' '
do
call i_extract ( s, i, ierror )
if ( ierror /= 0 ) then
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Reached the last integer.'
exit
end if
write ( *, '(i8)' ) i
end do
return
end
subroutine test036
!
!*******************************************************************************
!
!! TEST036 tests I_LENGTH.
!
implicit none
!
integer, parameter :: ntest = 6
!
integer i
integer i_length
integer itest(ntest)
integer j
!
itest(1) = 0
itest(2) = 1
itest(3) = -1
itest(4) = 140
itest(5) = -1952
itest(6) = 123456
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST036'
write ( *, '(a)' ) ' I_LENGTH computes an integer''s "length".'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Integer Length'
write ( *, '(a)' ) ' '
do i = 1, ntest
j = i_length ( itest(i) )
write ( *, '(2x,i6,2x,i6,2x,i6)' ) itest(i), j
end do
return
end
subroutine test037
!
!*******************************************************************************
!
!! TEST037 tests I_NEXT_READ.
!
implicit none
!
integer i
integer ierror
integer intval
character ( len = 80 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST037'
write ( *, '(a)' ) ' I_NEXT_READ extracts integers from a string.'
s = 'Data set #12 extends from (5,-43) and is worth $4.56'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'String to be analyzed:'
write ( *, '(a)' ) ' '
write ( *, '(4x,a)' ) trim ( s )
ierror = -1
i = 0
write ( *, '(a)' ) ' '
write ( *, '(a)' ) '# Integer'
write ( *, '(a)' ) ' '
do
call i_next_read ( s, intval, ierror )
if ( ierror /= 0 ) then
write ( *, '(a)' ) ' '
write ( *, '(a,i6)' ) 'Number of integers found was ', i
exit
end if
i = i + 1
write ( *, '(i3,2x,i10)' ) i, intval
if ( i >= 99 ) then
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Test037 - Fatal error!'
write ( *, '(a)' ) ' Reading phantom data from string.'
stop
end if
end do
return
end
subroutine test038
!
!*******************************************************************************
!
!! TEST038 tests I_TO_BINARY.
!! TEST038 tests I_SQZ.
!! TEST038 tests SQZ_I.
!
implicit none
!
integer, parameter :: idim = 30
integer, parameter :: jdim = 12
!
integer i
integer ibits
integer intval
integer ivec(idim)
integer iwords
integer jbits
integer jvec(jdim)
integer jwords
character ( len = 32 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST038'
write ( *, '(a)' ) ' I_TO_BINARY converts integer to binary rep;'
write ( *, '(a)' ) ' I_SQZ compresses a vector'
write ( *, '(a)' ) ' of integers into less space.'
write ( *, '(a)' ) ' SQZ_I uncompresses them.'
write ( *, '(a)' ) ' '
!
! If the maximum value is 30, the least number of bits we can use
! is 6, since 2**(6-1)-1 = 31.
!
do i = 1, idim
ivec(i) = i
end do
ibits = 32
jbits = 6
write ( *, '(a,i6,a)' ) ' Input numbers use ', ibits, ' bits.'
write ( *, '(a,i6,a)' ) ' Input numbers used ', idim, ' words.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Input words:'
write ( *, '(a)' ) ' '
write ( *, '(i15)' ) ivec(1:idim)
write ( *, '(a)' ) ' '
call i_sqz ( ivec, idim, ibits, jvec, jdim, jbits, jwords )
write ( *, '(a,i6,a)' ) ' Output numbers use ', jbits, ' bits.'
write ( *, '(a,i6,a)' ) ' Output numbers used ', jwords, ' words.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Output words:'
write ( *, '(a)' ) ' '
write ( *, '(i15)' ) jvec(1:jwords)
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Use I_TO_BINARY to print binary representation'
write ( *, '(a)' ) ' of the first output number:'
intval = jvec(1)
write ( *, '(a)' ) ' '
write ( *, '(a,i6)' ) ' Decimal value = ', intval
call i_to_binary ( intval, s )
write ( *, '(a)' ) ' String = ' // trim ( s )
write ( *, '(a,i6,a)' ) ' Input numbers use ', jbits, ' bits.'
write ( *, '(a,i6,a)' ) ' Input numbers used ', jwords, ' words.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Input words:'
write ( *, '(a)' ) ' '
write ( *, '(i15)' ) ( jvec(i), i = 1, jwords )
write ( *, '(a)' ) ' '
call sqz_i ( ivec, idim, ibits, jvec, jdim, jbits, iwords )
write ( *, '(a,i6,a)' ) ' Output numbers use ', ibits, ' bits.'
write ( *, '(a,i6,a)' ) ' Output numbers used ', iwords, ' words.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Output words:'
write ( *, '(a)' ) ' '
write ( *, '(i15)' ) ivec(1:iwords)
return
end
subroutine test0384
!
!*******************************************************************************
!
!! TEST0384 tests I_TO_NUNARY.
!
implicit none
!
integer, parameter :: ntest = 3
!
integer i
integer intval
integer, dimension ( ntest ) :: itest = (/ -5, 0, 7 /)
character ( len = 20 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0384'
write ( *, '(a)' ) ' I_TO_NUNARY converts an integer to negative unary.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I, I_TO_NUNARY(I)'
write ( *, '(a)' ) ' '
do i = 1, ntest
call i_to_nunary ( itest(i), s )
write ( *, '(2x,i6,2x,a)' ) itest(i), s
end do
return
end
subroutine test0385
!
!*******************************************************************************
!
!! TEST0385 tests I_TO_UNARY.
!
implicit none
!
integer, parameter :: ntest = 3
!
integer i
integer intval
integer, dimension ( ntest ) :: itest = (/ -5, 0, 7 /)
character ( len = 10 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0385'
write ( *, '(a)' ) ' I_TO_UNARY converts an integer to unary.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I, I_TO_UNARY(I)'
write ( *, '(a)' ) ' '
do i = 1, ntest
call i_to_unary ( itest(i), s )
write ( *, '(2x,i6,2x,a)' ) itest(i), s
end do
return
end
subroutine test040
!
!*******************************************************************************
!
!! TEST040 tests I_TO_BINHEX.
!
implicit none
!
integer i
character i_to_binhex
character ( len = 64 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST040'
write ( *, '(a)' ) ' I_TO_BINHEX: I => BINHEX character'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' The BINHEX alphabet'
write ( *, '(a)' ) ' '
do i = 1, 64
s(i:i) = i_to_binhex ( i )
end do
write ( *, '(a)' ) s
return
end
subroutine test041
!
!*******************************************************************************
!
!! TEST041 tests I_TO_MONTH_NAME;
!! TEST041 tests MONTH_NAME_TO_I.
!
implicit none
!
integer, parameter :: ntest = 9
!
integer i
integer month
character ( len = 9 ) month_name
character ( len = 9 ) test(ntest)
!
test(1) = 'J'
test(2) = 'Febooary'
test(3) = 'Dec.'
test(4) = 'April'
test(5) = 'Aug'
test(6) = 'Mar'
test(7) = 'May'
test(8) = 'o'
test(9) = 'nO'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST041'
write ( *, '(a)' ) ' I_TO_MONTH_NAME: I => Month_Name'
write ( *, '(a)' ) ' MONTH_NAME_TO_I: Month_Name => I.'
write ( *, '(a)' ) ' '
do i = 1, ntest
call month_name_to_i ( test(i), month )
call i_to_month_name ( month, month_name )
write ( *, '(a3,2x,i2,2x,a9)' ) test(i), month, month_name
end do
return
end
subroutine test042
!
!*******************************************************************************
!
!! TEST042 tests I_TO_OCT.
!! TEST042 tests OCT_TO_I.
!
implicit none
!
integer, parameter :: ntest = 3
!
integer i
integer i1
integer i2
integer itest(ntest)
character ( len = 10 ) s
!
itest(1) = 21
itest(2) = -32
itest(3) = 1776
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST042'
write ( *, '(a)' ) ' I_TO_OCT, integer->octal'
write ( *, '(a)' ) ' OCT_TO_I, octal->integer.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I, I_TO_OCT(I), OCT_TO_I(I_TO_OCT(I)) '
write ( *, '(a)' ) ' '
do i = 1, ntest
i1 = itest(i)
call i_to_oct ( i1, s )
call oct_to_i ( s, i2 )
write ( *, '(i8,2x,a10,2x,i8)' ) i1, s, i2
end do
return
end
subroutine test043
!
!*******************************************************************************
!
!! TEST043 tests I_TO_S_LEFT
!! TEST043 tests S_TO_I;
!
implicit none
!
integer, parameter :: ntest = 4
!
integer i
integer i2
integer ierror
integer lchar
character ( len = 20 ) s1
character ( len = 20 ) s2
character ( len = 20 ) s_test(ntest)
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST043'
write ( *, '(a)' ) ' I_TO_S_LEFT: I -> left-justified string;'
write ( *, '(a)' ) ' S_TO_I: string->I.'
s_test(1) = ' -124 56 AbC'
s_test(2) = '25,50,5'
s_test(3) = '+15.9'
s_test(4) = ' 123abc'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' STRING ==> S_TO_I ==> I_TO_S_LEFT'
write ( *, '(a)' ) ' '
do i = 1, ntest
s1 = s_test(i)
call s_to_i ( s1, i2, ierror, lchar )
call i_to_s_left ( i2, s2 )
write ( *, '(a,2x,i6,2x,a)' ) s1, i2, s2
end do
return
end
subroutine test044
!
!*******************************************************************************
!
!! TEST044 tests I_TO_S_LEFT.
!! TEST044 tests I_TO_S_RIGHT.
!! TEST044 tests I_TO_S_ZERO.
!
implicit none
!
integer, parameter :: ntest = 7
!
integer i
integer intval
integer itest(ntest)
character ( len = 6 ) s1
character ( len = 6 ) s2
character ( len = 6 ) s3
!
itest(1) = 0
itest(2) = 1
itest(3) = -1
itest(4) = 140
itest(5) = -1952
itest(6) = 123456
itest(7) = 1234567
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST044'
write ( *, '(a)' ) ' I_TO_S_LEFT: I -> Left-justified string;'
write ( *, '(a)' ) ' I_TO_S_RIGHT: I -> Right-justified string;'
write ( *, '(a)' ) ' I_TO_S_ZERO: I -> Zero-padded string.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Integer S_RIGHT S_LEFT S_ZERO'
write ( *, '(a)' ) ' '
do i = 1, ntest
intval = itest(i)
call i_to_s_right ( intval, s1 )
call i_to_s_left ( intval, s2 )
call i_to_s_zero ( intval, s3 )
write ( *, '(2x,i8,2x,a6,2x,a6,2x,a6)' ) intval, s1, s2, s3
end do
return
end
subroutine test0445
!
!*******************************************************************************
!
!! TEST0445 tests I_TO_S_ROMAN.
!! TEST0445 tests S_ROMAN_TO_I.
!
implicit none
!
integer, parameter :: ntest = 5
!
integer i
integer i2
integer, dimension ( ntest ) :: i_test = (/ 99, 157, 486, 1999, 4999 /)
integer j
character ( len = 20 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0445'
write ( *, '(a)' ) ' I_TO_S_ROMAN: Integer -> Roman Numerals'
write ( *, '(a)' ) ' S_ROMAN_TO_I: Roman Numerals -> Integer.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I ==> S'
write ( *, '(a)' ) ' '
do j = -5, 10
i = j
call i_to_s_roman ( i, s )
call s_roman_to_i ( s, i2 )
write ( *, '(i6,2x,a,2x,i6)' ) i, s, i2
end do
do j = 1, ntest
i = i_test(j)
call i_to_s_roman ( i, s )
call s_roman_to_i ( s, i2 )
write ( *, '(i6,2x,a,2x,i6)' ) i, s, i2
end do
return
end
subroutine test045
!
!*******************************************************************************
!
!! TEST045 tests I_TO_S32.
!! TEST045 tests S32_TO_I.
!
implicit none
!
integer, parameter :: ntest = 4
!
character ( len = 32 ) i_to_s32
character ( len = 32 ) cval
integer i
integer s32_to_i
integer, dimension ( ntest ) :: ival = (/ 0, 1, -1, 15 /)
integer ival2
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST045'
write ( *, '(a)' ) ' I_TO_S32: integer => character ( len = 32 );'
write ( *, '(a)' ) ' S32_TO_I: character ( len = 32 ) => integer.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I I_TO_S32(I) S32_TO_I(I_TO_S32(I))'
write ( *, '(a)' ) ' '
do i = 1, ntest
cval = i_to_s32 ( ival(i) )
ival2 = s32_to_i ( cval )
write ( *, '( i12, 2x, a32, 2x, i12 )' ) ival(i), cval, ival2
end do
return
end
subroutine test046
!
!*******************************************************************************
!
!! TEST046 tests I_TO_UUDECODE.
!
implicit none
!
integer i
character i_to_uudecode
character ( len = 64 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST046'
write ( *, '(a)' ) ' I_TO_UUDECODE: I => UUDECODE character'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' The UUDECODE alphabet'
write ( *, '(a)' ) ' '
do i = 1, 64
s(i:i) = i_to_uudecode ( i )
end do
write ( *, '(a)' ) s
return
end
subroutine test047
!
!*******************************************************************************
!
!! TEST047 tests I_TO_XXDECODE.
!
integer i
character i_to_xxdecode
character ( len = 64 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST047'
write ( *, '(a)' ) ' I_TO_XXDECODE: I => XXDECODE character'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' The XXDECODE alphabet'
write ( *, '(a)' ) ' '
do i = 1, 64
s(i:i) = i_to_xxdecode ( i )
end do
write ( *, '(a)' ) s
return
end
subroutine test048
!
!*******************************************************************************
!
!! TEST048 tests ISTRCMP.
!! TEST048 tests ISTRNCMP.
!
implicit none
!
integer, parameter :: ntest = 5
!
integer i
integer istrcmp
integer istrncmp
integer itemp1
integer itemp2
integer nchar
character ( len = 15 ) s1(ntest)
character ( len = 15 ) s2(ntest)
!
nchar = 5
s1(1) = 'Alex'
s1(2) = 'Barney'
s1(3) = 'Cray YMP'
s1(4) = 'ZULU'
s1(5) = 'BeHanna'
s2(1) = 'Alexander'
s2(2) = 'Babushka'
s2(3) = 'Zulu'
s2(4) = 'Zulu'
s2(5) = 'BeHanna'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST048'
write ( *, '(a)' ) ' ISTRCMP, C-like string comparison.'
write ( *, '(a)' ) ' ISTRNCMP, C-like string comparisons.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'String1 String2 ISTRNCMP ISTRCMP'
write ( *, '(a)' ) ' '
do i = 1, ntest
itemp1 = istrncmp ( s1(i), s2(i), nchar )
itemp2 = istrcmp ( s1(i), s2(i) )
write ( *, '(a,2x,a,2x,i2,2x,i2)' ) s1(i), s2(i), itemp1, itemp2
end do
return
end
subroutine test0483
!
!*******************************************************************************
!
!! TEST0483 tests CH4VEC_TO_IVEC.
!! TEST0483 tests IVEC_TO_CH4VEC.
!
implicit none
!
integer, parameter :: n = 11
!
integer i
integer ivec(n)
integer ivec2(n)
character ( len = 4 * n ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0483'
write ( *, '(a)') ' For vectors of integers and character*4 strings:'
write ( *, '(a)' ) ' CH4VEC_TO_IVEC: CH4 => I.'
write ( *, '(a)' ) ' IVEC_TO_CH4VEC: I => CH4.'
do i = 1, n
ivec(i) = i - ( n / 2 )
end do
call ivec_to_ch4vec ( n, ivec, s )
call ch4vec_to_ivec ( n, s, ivec2 )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I Input Output'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(i3,2x,2(i6))' ) i, ivec(i), ivec2(i)
end do
return
end
subroutine test0484
!
!*******************************************************************************
!
!! TEST0484 tests CH4VEC_TO_IVEC.
!! TEST0484 tests IVEC_TO_CH4VEC.
!
implicit none
!
integer, parameter :: n = 3
!
integer i
integer ivec(n)
character ( len = 4*n ) s
character ( len = 4*n ) s2
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0484'
write ( *, '(a)' ) ' For vectors of integers and character*4 strings:'
write ( *, '(a)' ) ' CH4VEC_TO_IVEC: CH4 => I.'
write ( *, '(a)' ) ' IVEC_TO_CH4VEC: I => CH4.'
s = 'Bartleby !'
call ch4vec_to_ivec ( n, s, ivec )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Input string: ' // trim ( s(1:4*n) )
call ivec_print ( n, ivec, ' Integer vector:' )
call ivec_to_ch4vec ( n, ivec, s2 )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Output string: ' // trim ( s2(1:4*n) )
return
end
subroutine test0485
!
!*******************************************************************************
!
!! TEST0485 tests LOWER.
!
implicit none
!
integer, parameter :: ntest = 5
!
integer i
character ( len = 20 ) lower
character ( len = 20 ) s(ntest)
!
s(1) = 'HELLO World !! ! '
s(2) = '12345678901234567890'
s(3) = 'Abc Def Ghi Jkl Mno '
s(4) = '!@#$%a^&A(){}[]\\|<>?'
s(5) = 'a waste is a terrible thing to mind.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0485'
write ( *, '(a)' ) ' LOWER lowercases all characters in a string;'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) '---------S---------- -----LOWER(S)-------'
write ( *, '(a)' ) ' '
do i = 1, ntest
write ( *, '(a20,2x,a20)' ) s(i), lower ( s(i) )
end do
return
end
subroutine test049
!
!*******************************************************************************
!
!! TEST049 tests S_IS_F77_NAME.
!! TEST049 tests S_IS_F90_NAME.
!
implicit none
!
integer, parameter :: ntest = 9
!
integer i
logical s_is_f77_name
logical s_is_f90_name
character ( len = 10 ), dimension ( ntest ) :: s = (/ &
'arthur ', 'art hur ', ' Mario ', '3.14159 ', &
'zo#wy ', ' ', 'R2D2 ', 'A_1 ', &
'_A1 ' /)
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST049'
write ( *, '(a)' ) ' S_IS_F77_NAME reports if a string is a'
write ( *, '(a)' ) ' legal FORTRAN-77 identifier.'
write ( *, '(a)' ) ' S_IS_F90_NAME reports if a string is a'
write ( *, '(a)' ) ' legal FORTRAN-90 identifier.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' -------String------- F77? F90?'
write ( *, '(a)' ) ' '
do i = 1, ntest
write ( *, '(2x,a,5x,l1,9x,l1)' ) s(i), s_is_f77_name ( s(i) ), &
s_is_f90_name ( s(i) )
end do
return
end
subroutine test050
!
!*******************************************************************************
!
!! TEST050 tests S_GEI.
!! TEST050 tests S_GTI.
!! TEST050 tests S_LEI.
!! TEST050 tests S_LTI.
!! TEST050 tests S_NEI.
!! TEST050 tests S_EQI.
!! TEST050 tests S_EQIDB.
!
implicit none
!
integer, parameter :: ntest = 5
!
character ( len = 7 ) a(ntest)
character ( len = 7 ) b(ntest)
logical comp(ntest,14)
integer i
integer j
logical s_eqi
logical s_eqidb
logical s_gei
logical s_gti
logical s_lei
logical s_lti
logical s_nei
!
a(1) = 'NixoN'
b(1) = 'niXon'
a(2) = 'animal'
b(2) = 'CRACKER'
a(3) = 'Yes'
b(3) = 'y'
a(4) = 'ALPHA'
b(4) = 'zeta'
a(5) = 'NIX on'
b(5) = 'Nixon'
do i = 1, ntest
comp(i,1) = a(i) == b(i)
comp(i,2) = a(i) == b(i)
comp(i,3) = lge ( a(i) ,b(i) )
comp(i,4) = lgt ( a(i), b(i) )
comp(i,5) = lle ( a(i), b(i) )
comp(i,6) = llt ( a(i), b(i) )
comp(i,7) = a(i) /= b(i)
comp(i,8) = s_eqi ( a(i), b(i) )
comp(i,9) = s_eqidb ( a(i), b(i) )
comp(i,10) = s_gei ( a(i), b(i) )
comp(i,11) = s_gti ( a(i), b(i) )
comp(i,12) = s_lei ( a(i), b(i) )
comp(i,13) = s_lti ( a(i), b(i) )
comp(i,14) = s_nei ( a(i), b(i) )
end do
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST050'
write ( *, '(a)' ) ' For implicitly capitalized strings S1 and S2'
write ( *, '(a)' ) ' S_EQI, S1 = S2'
write ( *, '(a)' ) ' S_EQIDB, S1 = S2, blank insensitive'
write ( *, '(a)' ) ' S_GEI S1 >= S2'
write ( *, '(a)' ) ' S_GTI S1 > S2'
write ( *, '(a)' ) ' S_LEI S1 <= S2'
write ( *, '(a)' ) ' S_LTI S1 < S2'
write ( *, '(a)' ) ' S_NEI S1 != S2'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Results of "A compare B"'
write ( *, '(a)' ) 'First line is FORTRAN (case sensitive)'
write ( *, '(a)' ) 'Second line is CHRPAK (case insensitive)'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' A B = = = > > < = < = / = '
write ( *, '(a)' ) ' '
do i = 1, ntest
write ( *, '(a7,2x,a7,7(3x,l1))' ) a(i), b(i), comp(i,1:7)
write ( *, '(7x,2x,7x,7(3x,l1))' ) comp(i,8:14)
write ( *, '(a)' ) ' '
end do
return
end
subroutine test051
!
!*******************************************************************************
!
!! TEST051 tests NAMEFL.
!
implicit none
!
integer, parameter :: ntest = 4
!
integer i
character ( len = 30 ) name(ntest)
character ( len = 30 ) s
!
name(1) = 'Brown, Charlie'
name(2) = 'Cher'
name(3) = 'Howell, James Thurston'
name(4) = 'Shakespeare Joe Bob'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST051'
write ( *, '(a)' ) ' NAMEFL takes a name in the '
write ( *, '(a)' ) ' last name, first name order and restores the'
write ( *, '(a)' ) ' first name, last name order.'
write ( *, '(a)' ) ' '
do i = 1, ntest
s = name(i)
call namefl ( s )
write ( *, '(a30,2x,a30)' ) name(i), s
end do
return
end
subroutine test052
!
!*******************************************************************************
!
!! TEST052 tests NAMELF.
!
implicit none
!
integer, parameter :: ntest = 3
!
integer i
character ( len = 30 ) name(ntest)
character ( len = 30 ) s
!
name(1) = 'Charlie Brown'
name(2) = 'Cher'
name(3) = 'James Thurston Howell'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST052'
write ( *, '(a)' ) ' NAMELF moves a last name first.'
write ( *, '(a)' ) ' '
do i = 1, ntest
s = name(i)
call namelf ( s )
write ( *, '(a30,2x,a30)' ) name(i), s
end do
return
end
subroutine test053
!
!*******************************************************************************
!
!! TEST053 tests NEXCHR.
!
implicit none
!
integer, parameter :: ntest = 6
!
character chr
integer i
integer ichr
integer jchr
character ( len = 16 ) string(ntest)
!
string(1) = 'Here I am!'
string(2) = ' O !'
string(3) = 'D o u b l e'
string(4) = 'T r i p l e'
string(5) = 'F a r'
string(6) = ' 1 '
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST053'
write ( *, '(a)' ) ' NEXCHR finds the next nonblank in a string.'
write ( *, '(a)' ) ' '
do i = 1, ntest
jchr = 0
do
if ( jchr == 0 ) then
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'String is ' // trim ( string(i) )
write ( *, '(a)' ) ' '
end if
call nexchr ( string(i)(jchr+1:), ichr, chr )
if ( ichr <= 0 ) then
write ( *, '(a)' ) 'No more nonblanks!'
exit
end if
jchr = jchr + ichr
write ( *, '(a)' ) 'Next character is ' // chr
end do
end do
return
end
subroutine test054
!
!*******************************************************************************
!
!! TEST054 tests NEXSTR.
!
implicit none
!
integer, parameter :: ntest = 6
!
integer i
integer isub
integer jsub
integer nsub
character ( len = 16 ) s(ntest)
character ( len = 2 ) sub
!
s(1) = 'Here I am!'
s(2) = ' O !'
s(3) = 'D o u b l e'
s(4) = 'T r i p l e'
s(5) = 'F a r'
s(6) = ' 1 '
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST054'
write ( *, '(a)' ) ' NEXSTR finds the next several characters in a string.'
write ( *, '(a)' ) ' '
nsub = 2
do i = 1, ntest
jsub = 0
do
if ( jsub == 0 ) then
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'String is ' // trim ( s(i) )
write ( *, '(a)' ) ' '
end if
call nexstr ( s(i)(jsub+1:), nsub, isub, sub )
if ( isub <= 0 ) then
write ( *, '(a)' ) 'No more nonblanks!'
exit
end if
write ( *, '(a)' ) 'Next substring: ' // trim ( sub )
jsub = jsub + isub
end do
end do
return
end
subroutine test055
!
!*******************************************************************************
!
!! TEST055 tests R_EXTRACT.
!
implicit none
!
integer ierror
character ( len = 80 ) input
real r
!
input = ' 12.3 45 -0.789'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST055'
write ( *, '(a)' ) ' R_EXTRACT extracts reals from a string.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) trim ( input )
write ( *, '(a)' ) ' '
do
call r_extract ( input, r, ierror )
if ( ierror /= 0 ) then
exit
end if
write ( *, '(g14.6)' ) r
end do
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Reached the last real value.'
return
end
subroutine test056
!
!*******************************************************************************
!
!! TEST056 tests R_TO_SEF.
!! TEST056 tests SEF_TO_R.
!
implicit none
!
integer, parameter :: ntest = 16
!
integer e
integer e2
integer f
integer f2
integer i
real r
real r2
real, dimension ( ntest ) :: rtest = (/ &
0.25E+00, 0.5E+00, 1.0E+00, 2.0E+00, 4.0E+00, &
1.5E+00, 1.75E+00, 1.875E+00, 6.5E+00, -6.5E+00, &
99.0E+00, 100.0E+00, 101.0E+00, 0.0E+00, -1.0E+00, &
huge ( 1.0E+00 ) /)
integer s
integer s2
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST056'
write ( *, '(a)' ) ' R_TO_SEF converts a real to SEF form.'
write ( *, '(a)' ) ' SEF_TO_R converts SEF form to a real value.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' S is the sign bit (0 = positive, 1 = negative)'
write ( *, '(a)' ) ' E is the exponent base 2'
write ( *, '(a)' ) ' F is the mantissa'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' R S E F R2'
write ( *, '(a)' ) ' '
do i = 1, ntest
r = rtest(i)
call r_to_sef ( r, s, e, f )
call sef_to_r ( s, e, f, r2 )
write ( *, '(g16.8,i2,i8,i12,g16.8)' ) r, s, e, f, r2
end do
!
! Extra test values, some of which are unnormalized real quantities.
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'S E F R S2 E2 F2'
write ( *, '(a)' ) ' '
s = 0
e = -125
f = 3
call sef_to_r ( s, e, f, r )
call r_to_sef ( r, s2, e2, f2 )
write ( *, '(i2,i5,i10,g14.6,i2,i5,i10)' ) s, e, f, r, s2, e2, f2
s = 0
e = -127
f = 3
call sef_to_r ( s, e, f, r )
call r_to_sef ( r, s2, e2, f2 )
write ( *, '(i2,i5,i10,g14.6,i2,i5,i10)' ) s, e, f, r, s2, e2, f2
s = 0
e = -129
f = 3
call sef_to_r ( s, e, f, r )
call r_to_sef ( r, s2, e2, f2 )
write ( *, '(i2,i5,i10,g14.6,i2,i5,i10)' ) s, e, f, r, s2, e2, f2
s = 0
e = -132
f = 7
call sef_to_r ( s, e, f, r )
call r_to_sef ( r, s2, e2, f2 )
write ( *, '(i2,i5,i10,g14.6,i2,i5,i10)' ) s, e, f, r, s2, e2, f2
s = 0
e = -135
f = 15
call sef_to_r ( s, e, f, r )
call r_to_sef ( r, s2, e2, f2 )
write ( *, '(i2,i5,i10,g14.6,i2,i5,i10)' ) s, e, f, r, s2, e2, f2
return
end
subroutine test057
!
!*******************************************************************************
!
!! TEST057 tests R_TO_FLT.
!
implicit none
!
integer, parameter :: ntest = 10
!
integer i
integer iexp
integer isgn
integer mant
integer ndig
real rtest(ntest)
real rval
real sval
!
rtest(1) = 1.0E+00
rtest(2) = 10.0E+00
rtest(3) = 100.0E+00
rtest(4) = 101.0E+00
rtest(5) = 99.0E+00
rtest(6) = 0.0E+00
rtest(7) = -1.0E+00
rtest(8) = -123.456E+00
rtest(9) = -0.123456E+00
rtest(10) = 0.000000123456E+00
ndig = 5
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST057'
write ( *, '(a)' ) ' R_TO_FLT computes the scientific representation'
write ( *, '(a)' ) ' (floating point, base 10) of a real number.'
write ( *, '(a)' ) ' '
do ndig = 1, 6
write ( *, '(a)' ) ' '
write ( *, '(a,i6)' ) 'The number of digits used is ', ndig
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' RVAL ISGN MANT IEXP SVAL'
write ( *, '(a)' ) ' '
do i = 1, ntest
rval = rtest(i)
call r_to_flt ( rval, isgn, mant, iexp, ndig )
sval = isgn * mant * 10.0E+00**iexp
write ( *, '(g14.6,3i8,g14.6)' ) rval, isgn, mant, iexp, sval
end do
end do
return
end
subroutine test058
!
!*******************************************************************************
!
!! TEST058 tests R_TO_S_LEFT.
!! TEST020 tests R_TO_S_RIGHT.
!! TEST020 tests S_BLANKS_INSERT.
!
implicit none
!
real rval
character ( len = 40 ) s
character ( len = 14 ) s2
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST058'
write ( *, '(a)' ) ' R_TO_S_LEFT: real -> left justified string;'
write ( *, '(a)' ) ' R_TO_S_RIGHT: real -> right justified string.'
write ( *, '(a)' ) ' S_BLANKS_INSERT inserts blanks in a string;'
write ( *, '(a)' ) ' '
s = 'There were guests.'
write ( *, '(a)' ) ' Before call, string = ' // trim ( s )
call s_blanks_insert ( s, 11, 18 )
write ( *, '(a)' ) ' After inserting blanks, string = ' // trim ( s )
write ( *, '(a)' ) ' Use R_TO_S_RIGHT to turn a real value into a '
write ( *, '(a)' ) ' right-justified string:'
s = 'There were guests.'
call s_blanks_insert ( s, 11, 25 )
rval = 78.25
call r_to_s_right ( rval, s2 )
s(12:25) = s2
write ( *, '(a)' ) ' After inserting blanks, string = ' // trim ( s )
write ( *, '(a)' ) ' Repeat for R_TO_S_LEFT:'
s = 'There were guests.'
call s_blanks_insert ( s, 11, 25 )
rval = 78.25
call r_to_s_left ( rval, s2 )
s(12:25) = s2
write ( *, '(a)' ) ' After inserting blanks, string = ' // trim ( s )
return
end
subroutine test059
!
!*******************************************************************************
!
!! TEST059 tests R_TO_S_LEFT.
!! TEST059 tests S_TO_R.
!
implicit none
!
integer, parameter :: ntest = 3
!
integer i
integer ierror
integer lchar
real r
character ( len = 14 ) stest(ntest)
character ( len = 14 ) s
character ( len = 14 ) s2
!
stest(1) = ' 52.134ABCDE'
stest(2) = ' 8.0/2.0'
stest(3) = '12E1, 34, 56'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST059'
write ( *, '(a)' ) ' S_TO_R, string -> real number;'
write ( *, '(a)' ) ' R_TO_S_LEFT, real number -> string.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' S --> S_TO_R --> R_TO_S_LEFT'
write ( *, '(a)' ) ' '
do i = 1, ntest
s = stest(i)
call s_to_r ( s, r, ierror, lchar )
call r_to_s_left ( r, s2 )
write ( *, '(2x,a14,g14.6,a14)' ) s, r, s2
end do
return
end
subroutine test0595
!
!*******************************************************************************
!
!! TEST0595 tests S_TO_RVEC
!
implicit none
!
integer, parameter :: n = 3
integer, parameter :: ntest = 3
!
integer i
integer ierror
real rvec(n)
character ( len = 20 ) stest(ntest)
character ( len = 20 ) s
!
stest(1) = ' 1 2 3'
stest(2) = '1.5 2.25 3.75'
stest(3) = '10, 21.0, 32.0, 43.0'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0595'
write ( *, '(a)' ) ' S_TO_RVEC, string -> real vector;'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) '--------String------ R(1) R(2) R(3)'
write ( *, '(a)' ) ' '
do i = 1, ntest
s = stest(i)
call s_to_rvec ( s, n, rvec, ierror )
write ( *, '(a20,3f10.4)' ) s, rvec(1:n)
end do
return
end
subroutine test060
!
!*******************************************************************************
!
!! TEST060 tests R_TO_S32.
!! TEST060 tests S32_TO_R.
!
implicit none
!
integer, parameter :: ntest = 4
!
integer i
character ( len = 32 ) r_to_s32
real rval(ntest)
real rval2
character ( len = 32 ) s
real s32_to_r
!
rval(1) = 0.0E+00
rval(2) = 1.0E+00
rval(3) = 7.0E+00
rval(4) = 15.0E+00
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST060'
write ( *, '(a)' ) ' R_TO_S32 and S32_TO_R convert between'
write ( *, '(a)' ) ' real and character ( len = 32 ) values.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' R R_TO_S32(R) S32_TO_R(R_TO_S32(R))'
write ( *, '(a)' ) ' '
do i = 1, ntest
s = r_to_s32 ( rval(i) )
rval2 = s32_to_r ( s )
write ( *, '( g14.6, 2x, a32, 2x, g14.6 )' ) rval(i), s, rval2
end do
return
end
subroutine test061
!
!*******************************************************************************
!
!! TEST061 tests RANGER.
!
implicit none
!
integer, parameter :: maxval = 30
!
integer i
integer ival(maxval)
integer nval
character ( len = 40 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST061'
write ( *, '(a)' ) ' RANGER interprets a range description.'
write ( *, '(a)' ) ' '
s = ' 4:8 2 14:20 2:-1 81:81 10'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' The input string is:'
write ( *, '(2x,a)' ) s
call ranger ( s, maxval, nval, ival )
if ( nval <= 0 ) then
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' RANGER found no integers.'
else
write ( *, '(a)' ) ' '
write ( *, '(a,i6,a)' ) ' RANGER found ', nval, ' integers:'
write ( *, '(a)' ) ' '
do i = 1, nval
write ( *, '(i8)' ) ival(i)
end do
end if
return
end
subroutine test062
!
!*******************************************************************************
!
!! TEST062 tests RAT_TO_S_LEFT.
!! TEST062 tests RAT_TO_S_RIGHT.
!
implicit none
!
integer, parameter :: ntest = 8
!
integer i
integer itest(ntest)
integer ival
integer jtest(ntest)
integer jval
character ( len = 22 ) s1
character ( len = 22 ) s2
!
itest(1) = 12
jtest(1) = 10
itest(2) = 48
jtest(2) = -96
itest(3) = -44
jtest(3) = -44
itest(4) = 23
jtest(4) = 0
itest(5) = -99
jtest(5) = 0
itest(6) = 0
jtest(6) = 0
itest(7) = 123456789
jtest(7) = 987654321
itest(8) = 0
jtest(8) = 909
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST062'
write ( *, '(a)' ) ' RAT_TO_S_LEFT prints a ratio left justified,'
write ( *, '(a)' ) ' RAT_TO_S_RIGHT prints it right justified.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' IVAL JVAL Right ' // &
' Left '
write ( *, '(a)' ) '--------- --------- ---------------------- ' // &
'----------------------'
write ( *, '(a)' ) ' '
do i = 1, ntest
ival = itest(i)
jval = jtest(i)
call rat_to_s_right ( ival, jval, s1 )
call rat_to_s_left ( ival, jval, s2 )
write ( *, '(i10,i10,2x,a22,2x,a22)' ) ival, jval, s1, s2
end do
return
end
subroutine test063
!
!*******************************************************************************
!
!! TEST063 tests RUBOUT.
!
implicit none
!
character, parameter :: bs = char ( 8 )
integer irep
character ( len = 50 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST063'
write ( *, '(a)' ) ' RUBOUT deletes CHARACTER+Backspace pairs.'
write ( *, '(a)' ) ' '
s = '_#T_#e_#x_#t is B#B#B#Bo#o#o#ol#l#l#ld#d#d#d'
call s_rep_ch ( s, '#', bs )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' The original string'
write ( *, '(4x,a)' ) trim ( s )
call rubout ( s )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' The cleaned up string:'
write ( *, '(4x,a)' ) trim ( s )
return
end
subroutine test064
!
!*******************************************************************************
!
!! TEST064 tests RVEC_TO_S.
!
implicit none
!
integer, parameter :: n = 6
!
integer i
character ( len = 100 ) s
real x(n)
!
x(1) = 1234.56E+00
x(2) = - 0.00125E+00
x(3) = 0.0E+00
x(4) = 10203040506.0E+00
x(5) = 77.0E+00
x(6) = 1.5E+00
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST064'
write ( *, '(a)' ) ' RVEC_TO_S writes a real vector to a string.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' The real vector data:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(i6,g14.6)' ) i, x(i)
end do
call rvec_to_s ( n, x, s )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' As written to a string:'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) trim ( s )
return
end
subroutine test065
!
!*******************************************************************************
!
!! TEST065 tests S_AFTER_SS_COPY.
!! TEST065 tests S_BEFORE_SS_COPY.
!
implicit none
!
integer, parameter :: ntest = 6
!
character ( len = 3 ) her
integer i
integer ii
character paren
character ( len = 30 ) s(ntest)
character ( len = 30 ) s2
!
paren = '('
her = 'her'
s(1) = 'John (or Jack)'
s(2) = 'Jill St John (her real name)'
s(3) = 'Jeff is OK (Rather!)'
s(4) = 'FUNCTION SDOT(N,X,INCX,Y,INCY)'
s(5) = 'Another remarkable string.'
s(6) = 'On the (other (hand!!)'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST065'
write ( *, '(a)' ) ' S_BEFORE_SS_COPY copies a string'
write ( *, '(a)' ) ' before the first occurrence of a substring.'
write ( *, '(a)' ) ' S_AFTER_SS_COPY copies a string'
write ( *, '(a)' ) ' after the first occurrence of a substring.'
write ( *, '(a)' ) ' '
do ii = 1, 2
write ( *, '(a)' ) ' '
if ( ii == 1 ) then
write ( *, '(a)' ) 'Our flag string is ' // paren
else
write ( *, '(a)' ) 'Our flag string is ' // her
end if
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'String Copy'
write ( *, '(a)' ) ' '
do i = 1, ntest
if ( ii == 1 ) then
call s_before_ss_copy ( s(i), paren, s2 )
else
call s_before_ss_copy ( s(i), her, s2 )
end if
write ( *, '(a30,2x,a30)' ) s(i), s2
end do
end do
do ii = 1, 2
write ( *, '(a)' ) ' '
if ( ii == 1 ) then
write ( *, '(a)' ) 'Our flag string is ' // paren
else
write ( *, '(a)' ) 'Our flag string is ' // her
end if
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'String Copy'
write ( *, '(a)' ) ' '
do i = 1, ntest
if ( ii == 1 ) then
call s_after_ss_copy ( s(i), paren, s2 )
else
call s_after_ss_copy ( s(i), her, s2 )
end if
write ( *, '(a30,2x,a30)' ) s(i), s2
end do
end do
return
end
subroutine test066
!
!*******************************************************************************
!
!! TEST066 tests S_ALPHA_LAST
!
implicit none
!
integer, parameter :: ntest = 4
!
integer i
integer iloc
character ( len = 20 ) s(ntest)
!
s(1) = 'HELLO World !! ! '
s(2) = '12345678901234567890'
s(3) = '0.314159E+01'
s(4) = '!@#$%a^&A(){}[]\\|<>?'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST066'
write ( *, '(a)' ) ' S_ALPHA_LAST returns the location of the '
write ( *, '(a)' ) ' last alphabetic character;'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) '------String------ S_ALPHA_LAST'
write ( *, '(a)' ) ' '
do i = 1, ntest
call s_alpha_last ( s(i), iloc )
write ( *, '(a20,2x,i6)' ) s(i), iloc
end do
return
end
subroutine test067
!
!*******************************************************************************
!
!! TEST067 tests S_ANY_ALPHA.
!
implicit none
!
integer, parameter :: ntest = 4
!
integer i
logical s_any_alpha
character ( len = 20 ) s(ntest)
!
s(1) = 'HELLO World !! ! '
s(2) = '12345678901234567890'
s(3) = '0.314159E+01'
s(4) = '!@#$%a^&A(){}[]\\|<>?'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST067'
write ( *, '(a)' ) ' S_ANY_ALPHA reports if a string'
write ( *, '(a)' ) ' contains any alphabetic characters'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) '------String------ --S_ANY_ALPHA--'
write ( *, '(a)' ) ' '
do i = 1, ntest
write ( *, '(a20,2x,l1)' ) s(i), s_any_alpha ( s(i) )
end do
return
end
subroutine test068
!
!*******************************************************************************
!
!! TEST068 tests S_BEGIN.
!
! 'Bob' 'BOB' TRUE
! ' B o b ' ' bo b' TRUE
! 'Bob' 'Bobby' TRUE
! 'Bobo' 'Bobb' FALSE
! ' ' 'Bob' TRUE (because blank matches anything)
!
implicit none
!
integer, parameter :: ntest = 6
!
integer i
logical s_begin
character ( len = 12 ) s1
character ( len = 12 ) s2
character ( len = 12 ) stest1(ntest)
character ( len = 12 ) stest2(ntest)
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST068'
write ( *, '(a)' ) ' S_BEGIN checks the beginning of a string for a'
write ( *, '(a)' ) ' substring, ignoring case and spaces.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' S1 S2 S_BEGIN(S1,S2)'
write ( *, '(a)' ) ' '
stest1(1) = 'Bob'
stest1(2) = ' B o b'
stest1(3) = 'Bob'
stest1(4) = 'Bobo'
stest1(5) = ' '
stest1(6) = 'cubic meter'
stest2(1) = 'BOB'
stest2(2) = ' bo b'
stest2(3) = 'BOBBY'
stest2(4) = 'Bobb'
stest2(5) = 'Bob'
stest2(6) = 'cubic meter'
do i = 1, ntest
s1 = stest1(i)
s2 = stest2(i)
write ( *, '(a,2x,a,2x,l1)' ) s1, s2, s_begin ( s1, s2 )
end do
return
end
subroutine test069
!
!*******************************************************************************
!
!! TEST069 tests S_BLANK_DELETE.
!! TEST069 tests S_BLANKS_DELETE.
!
implicit none
!
character ( len = 20 ) s
!
s = 'HELLO World !! ! '
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST069'
write ( *, '(a)' ) ' S_BLANK_DELETE removes all blanks.'
write ( *, '(a)' ) ' S_BLANKS_DELETE removes double blanks.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Input: ' // trim ( s )
call s_blank_delete ( s )
write ( *, '(a)' ) ' S_BLANK_DELETE Output: ' // trim ( s )
s = 'HELLO World !! ! '
call s_blanks_delete ( s )
write ( *, '(a)' ) ' S_BLANKS_DELETE Output: ' // trim ( s )
return
end
subroutine test070
!
!*******************************************************************************
!
!! TEST070 tests S_CH_DELETE.
!
implicit none
!
integer, parameter :: ntest = 4
!
character c(ntest)
integer i
character ( len = 35 ) s(ntest)
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST070'
write ( *, '(a)' ) ' S_CH_DELETE removes a character from a string.'
write ( *, '(a)' ) ' '
s(1) = 'A man, a plan, a canal, Panama!'
c(1) = ' '
s(2) = 'A man, a plan, a canal, Panama!'
c(2) = 'a'
s(3) = 'A man, a plan, a canal, Panama!'
c(3) = 'n'
s(4) = 'aaaaannnnnQ!'
c(4) = 'n'
do i = 1, ntest
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Remove "' // c(i) // '" from "' // trim ( s(i) ) // '"'
write ( *, '(a)' )
call s_ch_delete ( s(i), c(i) )
write ( *, '(a)' ) 'Result: ' // trim ( s(i) )
end do
return
end
subroutine test0705
!
!*******************************************************************************
!
!! TEST0705 tests S_CH_LAST.
!
implicit none
!
integer, parameter :: ntest = 5
!
integer i
character ( len = 20 ) s(ntest)
character s_ch_last
!
s(1) = 'HELLO World !! ! '
s(2) = '12345678901234567890'
s(3) = 'Abc Def Ghi Jkl Mno '
s(4) = '!@#$%a^&A(){}[]\\|<>?'
s(5) = 'a waste is a terrible thing to mind.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0705'
write ( *, '(a)' ) ' S_CH_LAST returns the last nonblank in a string.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) '------String------ Last'
write ( *, '(a)' ) ' '
do i = 1, ntest
write ( *, '(a20,10x,a1)' ) s(i), s_ch_last ( s(i) )
end do
return
end
subroutine test071
!
!*******************************************************************************
!
!! TEST071 tests S_CAP.
!! TEST071 tests S_LOW.
!! TEST071 tests S_W_CAP.
!
implicit none
!
integer, parameter :: ntest = 5
!
integer i
character ( len = 20 ) s(ntest)
character ( len = 20 ) s1
character ( len = 20 ) s2
character ( len = 20 ) s3
!
s(1) = 'HELLO World !! ! '
s(2) = '12345678901234567890'
s(3) = 'Abc Def Ghi Jkl Mno '
s(4) = '!@#$%a^&A(){}[]\\|<>?'
s(5) = 'a waste is a terrible thing to mind.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST071'
write ( *, '(a)' ) ' S_CAP capitalizes all characters in a string;'
write ( *, '(a)' ) ' S_LOW lowercases all characters;'
write ( *, '(a)' ) ' S_W_CAP initial-capitalizes words in a string;'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) '------Original------ -----Capitalized-----' // &
'-----Lower Cased----- -----Word_Caps-----'
write ( *, '(a)' ) ' '
do i = 1, ntest
s1 = s(i)
call s_cap ( s1 )
s2 = s(i)
call s_low ( s2 )
s3 = s(i)
call s_w_cap ( s3 )
write ( *, '(a20,2x,a20,2x,a20,2x,a20)' ) s(i), s1, s2, s3
end do
return
end
subroutine test072
!
!*******************************************************************************
!
!! TEST072 tests S_CAT.
!! TEST072 tests S_CAT1.
!
implicit none
!
character ( len = 5 ) s1
character ( len = 5 ) s2
character ( len = 10 ) s3
character ( len = 10 ) s4
character ( len = 10 ) s5
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST072'
write ( *, '(a)' ) ' // concatenates two strings;'
write ( *, '(a)' ) ' S_CAT concatenates two strings, trimming blanks;'
write ( *, '(a)' ) ' S_CAT1 concatenates two strings with a'
write ( *, '(a)' ) ' single blank separator.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) &
'--S1- --S2- --S1//S2-- --S_CAT-- --S_CAT1--'
write ( *, '(a)' ) ' '
s1 = 'Cat'
s2 = 'fish'
s3 = s1 // s2
call s_cat ( s1, s2, s4 )
call s_cat1 ( s1, s2, s5 )
write ( *, '(a,5x,a,5x,a,5x,a,5x,a)' ) s1, s2, s3, s4, s5
return
end
subroutine test073
!
!*******************************************************************************
!
!! TEST073 tests S_CHOP.
!
implicit none
!
integer ihi
integer ilo
character ( len = 30 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST073'
write ( *, '(a)' ) ' S_CHOP chops out part of a string.'
write ( *, '(a)' ) ' '
s = 'CHRPAK is not working today!'
write ( *, '(a)' ) ' Original string = ' // trim ( s )
ilo = 11
ihi = 14
write ( *, '(a,i6,a,i6)' ) ' We delete entries ', ilo, ' to ', ihi
call s_chop ( s, ilo, ihi )
write ( *, '(a)' ) ' Chopped string = ' // trim ( s )
return
end
subroutine test0735
!
!*******************************************************************************
!
!! TEST0735 tests S_DETAG.
!
implicit none
!
integer ihi
integer ilo
character ( len = 60 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0735'
write ( *, '(a)' ) ' S_DETAG removes HTML tags from a string.'
s = 'This is italic whereas this boldly goes on!'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Original string:'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) trim ( s )
call s_detag ( s )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Detagged string:'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) trim ( s )
s = 'This is an example of a link .'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Original string:'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) trim ( s )
call s_detag ( s )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Detagged string:'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) trim ( s )
return
end
subroutine test074
!
!*******************************************************************************
!
!! TEST074 tests S_FILL.
!
implicit none
!
character c
character ( len = 10 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST074'
write ( *, '(a)' ) ' S_FILL fills a string with a character.'
write ( *, '(a)' ) ' '
s = 'My word!'
write ( *, '(2x,a,a)' ) 'Before: ', trim ( s )
c = '$'
call s_fill ( s, c )
write ( *, '(2x,a,a)' ) 'After: ', trim ( s )
return
end
subroutine test075
!
!*******************************************************************************
!
!! TEST075 tests S_INDEX_SET.
!
implicit none
!
character blank
character hat
integer i
integer loc_new
integer loc_old
character ( len = 40 ) s
character ( len = 10 ) s2
integer s_index_set
!
blank = ' '
hat = '^'
s2 = '0123456789'
s = '1 way 4 U 2 deb8 of10 is 2 Rgu!'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST075'
write ( *, '(a)' ) ' S_INDEX_SET searches a string for any character'
write ( *, '(a)' ) ' in a given set.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' String: ' // trim ( s )
write ( *, '(a)' ) ' Set: ' // trim ( s2 )
write ( *, '(a)' ) ' '
loc_new = 0
do
loc_old = loc_new
loc_new = s_index_set ( s(loc_old+1:), s2 ) + loc_old
if ( loc_new == loc_old ) then
exit
end if
write ( *, '(a)' ) ' '
write ( *, '(a)' ) trim ( s )
write ( *, '(40a)' ) ( blank, i = 1, loc_new-1 ), hat
end do
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' No more matches found.'
return
end
subroutine test076
!
!*******************************************************************************
!
!! TEST076 tests S_INDEXI.
!! TEST076 tests S_INDEX_LAST.
!
implicit none
!
integer i1
integer i2
integer i3
integer i4
integer s_indexi
integer s_index_last
character ( len = 30 ) s
character ( len = 10 ) substring
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST076'
write ( *, '(a)' ) ' S_INDEXI reports the first occurrence of a'
write ( *, '(a)' ) ' substring, case and trailing space'
write ( *, '(a)' ) ' insensitive.'
write ( *, '(a)' ) ' S_INDEX_LAST reports the LAST occurrence'
write ( *, '(a)' ) ' of a substring.'
write ( *, '(a)' ) ' INDEX is a case and trailing space sensitive'
write ( *, '(a)' ) ' routine which reports the first occurrence'
write ( *, '(a)' ) ' of a substring.'
s = 'Bob is debobbing the bobber!'
substring = 'bob'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' String = ' // trim ( s )
write ( *, '(a)' ) ' Substring is ' // trim ( substring )
i1 = index ( s, substring )
i2 = index ( s, trim ( substring ) )
i3 = s_indexi ( s, substring )
i4 = s_index_last ( s, substring )
write ( *, '(a,i6)' ) ' '
write ( *, '(a,i6)' ) 'INDEX = ', i1
write ( *, '(a,i6)' ) 'INDEX (restricted) = ', i2
write ( *, '(a,i6)' ) 'INDEXI = ', i3
write ( *, '(a,i6)' ) 'S_INDEX_LAST = ', i4
return
end
subroutine test077
!
!*******************************************************************************
!
!! TEST077 tests S_IS_DIGIT.
!! TEST077 tests S_IS_I.
!
implicit none
!
integer, parameter :: ntest = 6
!
integer i
integer ival
logical lval1
logical lval2
logical s_is_digit
logical s_is_i
character ( len = 10 ) s(ntest)
!
s(1) = '123 '
s(2) = ' 1.2 - 3'
s(3) = ' A4'
s(4) = '-3.14E+2'
s(5) = ' 2 3 4 '
s(6) = ' +2, '
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST077'
write ( *, '(a)' ) ' S_IS_DIGIT reports whether a string'
write ( *, '(a)' ) ' contains only digits.'
write ( *, '(a)' ) ' S_IS_I reports whether a string'
write ( *, '(a)' ) ' represents a single integer.'
write ( *, '(a)' ) ' '
ival = 0
do i = 1, ntest
lval1 = s_is_digit ( s(i) )
lval2 = s_is_i ( s(i), ival )
write ( *, '(a10,2x,l1,2x,l1,2x,i8)' ) s(i), lval1, lval2, ival
end do
return
end
subroutine test078
!
!*******************************************************************************
!
!! TEST078 tests S_IS_R.
!
implicit none
!
integer, parameter :: ntest = 6
!
integer i
logical lval
real rval
character ( len = 10 ) s(ntest)
!
s(1) = '123 '
s(2) = ' 1.2 - 3'
s(3) = ' A4.5'
s(4) = '-3.14E+2'
s(5) = ' 2 3 4 '
s(6) = ' +2.3, '
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST078'
write ( *, '(a)' ) ' S_IS_R reports whether a string'
write ( *, '(a)' ) ' represents a single real value.'
write ( *, '(a)' ) ' '
do i = 1, ntest
call s_is_r ( s(i), rval, lval )
write ( *, '(a10,2x,l1,2x,g14.6)' ) s(i), lval, rval
end do
return
end
subroutine test079
!
!*******************************************************************************
!
!! TEST079 tests S_LEFT.
!! TEST079 tests S_RIGHT.
!
implicit none
!
integer, parameter :: ntest = 3
!
integer i
character ( len = 10 ) s(ntest)
character ( len = 10 ) s1
character ( len = 10 ) s2
!
s(1) = ' Hello! '
s(2) = 'Ouch!'
s(3) = ' A B C '
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST079'
write ( *, '(a)' ) ' S_LEFT justifies a string to the left;'
write ( *, '(a)' ) ' S_RIGHT justifies a string to the right.'
write ( *, '(a)' ) ' '
write ( *, '(a)' )' Original S_LEFT S_RIGHT'
write ( *, '(a)' )'---------- ---------- ----------'
write ( *, '(a)' ) ' '
do i = 1, ntest
s1 = s(i)
call s_left ( s1 )
s2 = s(i)
call s_right ( s2 )
write ( *, '(a10,2x,a10,2x,a10)' ) s(i), s1, s2
end do
return
end
subroutine test080
!
!*******************************************************************************
!
!! TEST080 tests S_ONLY_ALPHAB.
!! TEST080 tests S_ONLY_DIGITB.
!
implicit none
!
integer, parameter :: ntest = 9
!
integer i
character ( len = 4 ) s(ntest)
logical s_only_alphab
logical s_only_digitb
!
s(1) = '1984'
s(2) = 'Fred'
s(3) = 'C3PO'
s(4) = '/#4D'
s(5) = ' Bc'
s(6) = '2 34'
s(7) = '-198'
s(8) = '8 +4'
s(9) = '10*8'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST080'
write ( *, '(a)' ) ' S_ONLY_ALPHAB reports if a string is only'
write ( *, '(a)' ) ' alphabetic and blanks.'
write ( *, '(a)' ) ' S_ONLY_DIGITB reports if a string is only digits and blanks.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'S S_ONLY_DIGITB S_ONLY_ALPHAB'
write ( *, '(a)') ' '
do i = 1, ntest
write ( *, '(3x,a4,5x,l1,5x,l1)' ) s(i), s_only_digitb(s(i)), &
s_only_alphab(s(i))
end do
return
end
subroutine test081
!
!*******************************************************************************
!
!! TEST081 tests S_OVERLAP.
!
implicit none
!
integer, parameter :: ntest = 5
!
integer i
integer overlap
character ( len = 10 ) s1
character ( len = 10 ), save, dimension ( ntest ) :: s1_test = (/ &
'timber ', 'timber ', 'beret ', 'beret ', 'beret ' /)
character ( len = 10 ) s2
character ( len = 10 ), save, dimension ( ntest ) :: s2_test = (/ &
'beret ', 'timber ', 'timber ', 'berets ', 'berth ' /)
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST081'
write ( *, '(a)' ) ' S_OVERLAP measures the overlap between two strings.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'S1 S2 Overlap'
write ( *, '(a)' ) ' '
do i = 1, ntest
s1 = s1_test(i)
s2 = s2_test(i)
call s_overlap ( s1, s2, overlap )
write ( *, '(a,3x,a,3x,i2)' ) s1, s2, overlap
end do
return
end
subroutine test0249
!
!*******************************************************************************
!
!! TEST0249 tests S_REP_CH.
!
implicit none
!
character c1
character c2
character ( len = 15 ) s
character ( len = 15 ) :: s_old = 'No pennies now.'
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0249'
write ( *, '(a)' ) ' S_REP_CH replaces one character by another;'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' C1 C2 Original String Modified String'
write ( *, '(a)' ) ' '
c1 = 'n'
c2 = 't'
s = s_old
call s_rep_ch ( s, c1, c2 )
write ( *, '(3x,a1,3x,a1,2x,a,2x,a)' ) c1, c2, s_old, s
return
end
subroutine test025
!
!*******************************************************************************
!
!! TEST025 tests S_REP_REC.
!
implicit none
!
integer irep
character ( len = 35 ) s
character ( len = 2 ) sub1a
character sub2a
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST025'
write ( *, '(a)' ) ' S_REP_REC recursively replaces a string.'
write ( *, '(a)' ) ' '
s = 'aaaaannnnnBC'
sub1a = 'an'
sub2a = 'a'
write ( *, '(a)' ) ' Replace all occurrences of '
write ( *, '(4x,a)' ) trim ( sub1a ) // ' by ' // trim ( sub2a ) &
// ' in ' // trim ( s )
write ( *, '(a)' ) ' '
call s_rep_rec ( s, sub1a, sub2a, irep )
write ( *, '(a)' ) ' Result: ' // trim ( s )
write ( *, '(i6,a)' ) irep, ' replacements were made.'
return
end
subroutine test026
!
!*******************************************************************************
!
!! TEST026 tests S_REP.
!
implicit none
!
integer i
integer irep
character ( len = 35 ) string
character ( len = 3 ) sub1
character ( len = 3 ) sub2
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST026'
write ( *, '(a)' ) ' S_REP replaces a pattern in a string.'
write ( *, '(a)' ) ' '
do i = 1, 3
string = 'A man, a plan, a canal, Panama!'
if ( i == 1 ) then
sub1 = 'an'
sub2 = '&@'
else if ( i == 2 ) then
sub1 = 'an,'
sub2 = '8'
else if ( i == 3 ) then
sub1 = 'a'
sub2 = 'oro'
end if
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Replace all occurrences of '
write ( *, '(4x,a)' ) trim ( sub1 ) // ' by ' // trim ( sub2 ) &
// ' in ' // trim ( string )
write ( *, '(a)' )
call s_rep ( string, sub1, sub2, irep )
write ( *, '(a)' ) 'Result: ' // trim ( string )
write ( *, '(i6,a)' ) irep, ' replacements were made.'
end do
return
end
subroutine test082
!
!*******************************************************************************
!
!! TEST082 tests S_REVERSE.
!
implicit none
!
character ( len = 35 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST082'
write ( *, '(a)' ) ' S_REVERSE reverses a string.'
write ( *, '(a)' ) ' '
s = 'A man, a plan, a canal, Panama!'
write ( *, '(2x,a,a)' ) ' Before: ', trim ( s )
call s_reverse ( s )
write ( *, '(2x,a,a)' ) ' After: ', trim ( s )
return
end
subroutine test083
!
!*******************************************************************************
!
!! TEST083 tests S_S_DELETE.
!
implicit none
!
integer, parameter :: ntest = 4
!
integer i
integer irep
character ( len = 35 ) s(ntest)
character ( len = 5 ) sub(ntest)
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST083'
write ( *, '(a)' ) ' S_S_DELETE removes a substring;'
write ( *, '(a)' ) ' '
s(1) = 'A man, a plan, a canal, Panama!'
sub(1) = ','
s(2) = 'A man, a plan, a canal, Panama!'
sub(2) = 'an'
s(3) = 'A man, a plan, a canal, Panama!'
sub(3) = 'canal'
s(4) = 'aaaaannnnnQ!'
sub(4) = 'an'
do i = 1, ntest
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Removes substring "' // &
trim ( sub(i) ) // '" from "' // trim ( s(i) ) // '"'
call s_s_delete ( s(i), trim ( sub(i) ), irep )
write ( *, '(a)' )
write ( *, '(a)' ) ' Result: ' // trim ( s(i) )
write ( *, '(i6,a)' ) irep, ' removals'
end do
return
end
subroutine test084
!
!*******************************************************************************
!
!! TEST084 tests S_S_DELETE2.
!
implicit none
!
integer, parameter :: ntest = 4
!
integer i
integer irep
character ( len = 35 ) s(ntest)
character ( len = 5 ) sub(ntest)
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST084'
write ( *, '(a)' ) ' S_S_DELETE2 recursively removes a substring;'
write ( *, '(a)' ) ' '
s(1) = 'A man, a plan, a canal, Panama!'
sub(1) = ','
s(2) = 'A man, a plan, a canal, Panama!'
sub(2) = 'an'
s(3) = 'A man, a plan, a canal, Panama!'
sub(3) = 'canal'
s(4) = 'aaaaannnnnQ!'
sub(4) = 'an'
do i = 1, ntest
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' S_S_DELETE2 removes the substring "' // &
trim ( sub(i) ) // '" from "' // trim ( s(i) ) // '"'
write ( *, '(a)' ) ' '
call s_s_delete2 ( s(i), trim ( sub(i) ), irep )
write ( *, '(a)' ) ' Result: ' // trim ( s(i) )
write ( *, '(i6,a)' ) irep, ' removals'
end do
return
end
subroutine test085
!
!*******************************************************************************
!
!! TEST085 tests S_SHIFT_CIRCULAR.
!! TEST085 tests S_SHIFT_LEFT.
!! TEST085 tests S_SHIFT_RIGHT.
!
implicit none
!
integer ishft
character ( len = 6 ) string
character ( len = 6 ) string1
character ( len = 6 ) string2
character ( len = 6 ) string3
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST085'
write ( *, '(a)' ) ' S_SHIFT_CIRCULAR, right circular shift.'
write ( *, '(a)' ) ' S_SHIFT_LEFT, left shift, blank pad.'
write ( *, '(a)' ) ' S_SHIFT_RIGHT, right shift, blank pad.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' String Shift Shift_Circular Shift_Right Shift_Left'
write ( *, '(a)' ) ' '
ishft = 2
string = 'Abcde '
string1 = string
call s_shift_circular ( string1, ishft )
string2 = string
call s_shift_right ( string2, ishft )
string3 = string
call s_shift_left ( string3, ishft )
write ( *, '(a6,2x,i6,2x,a6,2x,a6,2x,a6)' ) &
string, ishft, string1, string2, string3
ishft = 3
string = '123456'
string1 = string
call s_shift_circular ( string1, ishft )
string2 = string
call s_shift_right ( string2, ishft )
string3 = string
call s_shift_left ( string3, ishft )
write ( *, '(a6,2x,i6,2x,a6,2x,a6,2x,a6)' ) &
string, ishft, string1, string2, string3
ishft = -2
string = 'Shazam'
string1 = string
call s_shift_circular ( string1, ishft )
string2 = string
call s_shift_right ( string2, ishft )
string3 = string
call s_shift_left ( string3, ishft )
write ( *, '(a6,2x,i6,2x,a6,2x,a6,2x,a6)' ) &
string, ishft, string1, string2, string3
return
end
subroutine test086
!
!*******************************************************************************
!
!! TEST086 tests S_SKIP_SET.
!
implicit none
!
character blank
character hat
integer i
integer locnew
integer locold
character ( len = 20 ) s
character ( len = 10 ) s2
integer s_skip_set
!
blank = ' '
hat = '^'
s2 = '0123456789'
s = '1 way 4 U 2 deb8!'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST086'
write ( *, '(a)' ) ' S_SKIP_SET finds the next character that '
write ( *, '(a)' ) ' IS NOT part of a given set of characters;'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Our string is'
write ( *, '(a)' ) trim ( s )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Our character set is'
write ( *, '(a)' ) trim ( s2 )
locnew = 0
do
locold = locnew
locnew = s_skip_set ( s(locold+1:), s2 ) + locold
if ( locnew == locold ) then
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' No more matches.'
exit
end if
write ( *, '(a)' ) ' '
write ( *, '(a)' ) trim ( s )
write ( *, '(40a)' ) ( blank, i = 1, locnew-1 ), hat
end do
return
end
subroutine test087
!
!*******************************************************************************
!
!! TEST087 tests S_SPLIT.
!
implicit none
!
integer, parameter :: ntest = 4
!
integer i
character ( len = 250 ) output
character ( len = 50 ) s
character ( len = 50 ) s_test(ntest)
character ( len = 50 ) s1
character ( len = 50 ) s2
character ( len = 50 ) s3
character ( len = 50 ) sub
character ( len = 50 ) sub_test(ntest)
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST087'
write ( *, '(a)' ) ' S_SPLIT splits a string at a substring.'
write ( *, '(a)' ) ' '
s_test(1) = ' REAL FUNCTION GRAMMA ( X, Y, Z )'
sub_test(1) = 'real function'
s_test(2) = ' real function gramma ( x, y, z )'
sub_test(2) = 'real function'
s_test(3) = ' REAL FUNCTION GRAMMA ( X, Y, Z )'
sub_test(3) = 'unc'
s_test(4) = ' real function gramma ( x, y, z )'
sub_test(4) = 'lemon'
do i = 1, ntest
s = s_test(i)
sub = sub_test(i)
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' String = ' // trim ( s )
write ( *, '(a)' ) ' Substring = '// trim ( sub )
call s_split ( s, sub, s1, s2, s3 )
if ( s2 == ' ' ) then
write ( *, '(a)' ) 'No match'
else
output = s1 // ' // ' // s2 // ' // ' // s3
call s_blanks_delete ( output )
write ( *, '(a)' ) trim ( output )
end if
end do
return
end
subroutine test088
!
!*******************************************************************************
!
!! TEST088 tests S_TAB_BLANKS.
!
implicit none
!
integer, parameter :: ntest = 4
character, parameter :: TAB = char ( 9 )
!
integer i
character ( len = 80 ) s
character ( len = 80 ) test(ntest)
!
test(1) = 'No tabs in me.'
test(2) = 'I''ve got one' // TAB // 'tab here!'
test(3) = 'I' // TAB // 'have' // TAB // 'three' // TAB // '!'
test(4) = TAB // 'I begin and end with them!' // TAB
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST088'
write ( *, '(a)' ) ' S_TAB_BLANKS replaces TAB''s by 6 spaces.'
do i = 1, ntest
write ( *, '(a)' ) ' '
s = test(i)
write ( *, '(a)' ) trim ( s )
call s_tab_blanks ( s )
write ( *, '(a)' ) trim ( s )
end do
return
end
subroutine test089
!
!*******************************************************************************
!
!! TEST089 tests S_TO_L.
!
implicit none
!
integer, parameter :: ntest = 22
!
integer i
integer ierror
integer lchar
logical logval
character ( len = 10 ) string(ntest)
!
string(1) = '.TRUE.'
string(2) = 'TRUE'
string(3) = 'True'
string(4) = ' TRUE '
string(5) = 'Trump'
string(6) = 'Ture'
string(7) = 'T'
string(8) = 'Talleyrand'
string(9) = 'Garbage'
string(10) = 'F'
string(11) = 'Furbelow'
string(12) = '0'
string(13) = '1'
string(14) = '2'
string(15) = ' 1 '
string(16) = '17'
string(17) = '1A'
string(18) = '12,34,56'
string(19) = ' 34 7'
string(20) = '-1E2ABCD'
string(21) = 'I am TRUE'
string(22) = ' '
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST089'
write ( *, '(a)' ) ' S_TO_L reads logical data from a string.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'String Logval Length IERROR'
write ( *, '(a)' ) ' '
do i = 1, ntest
call s_to_l ( string(i), logval, ierror, lchar )
write ( *, '(a10,2x,l1,4x,i2,4x,i2)' ) string(i), logval, lchar, ierror
end do
return
end
subroutine test090
!
!*******************************************************************************
!
!! TEST090 tests S_TO_ROT13.
!
implicit none
!
integer, parameter :: ntest = 3
!
integer i
character ( len = 30 ) s(ntest)
!
s(1) = 'abcdefghijklmnopqrstuvwxyz'
s(2) = 'Cher'
s(3) = 'James Thurston Howell'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST090'
write ( *, '(a)' ) ' S_TO_ROT13 encrypts a string.'
write ( *, '(a)' ) ' '
do i = 1, ntest
write ( *, '(a)' ) ' '
write ( *, '(a,a30)' )' Original: ', trim ( s(i) )
call s_to_rot13 ( s(i) )
write ( *, '(a,a30)' )' Rotated once: ', trim ( s(i) )
call s_to_rot13 ( s(i) )
write ( *, '(a,a30)' )' Rotated twice: ', trim ( s(i) )
end do
return
end
subroutine test091
!
!*******************************************************************************
!
!! TEST091 tests S_TO_SOUNDEX.
!
implicit none
!
integer, parameter :: ntest = 14
!
character ( len = 4 ) code
integer i
character ( len = 15 ) s_test(ntest)
!
s_test(1) = 'Ellery'
s_test(2) = 'Euler'
s_test(3) = 'Gauss'
s_test(4) = 'Ghosh'
s_test(5) = 'Heilbronn'
s_test(6) = 'hi-lo-ball'
s_test(7) = 'Hilbert'
s_test(8) = 'Kant'
s_test(9) = 'Knuth'
s_test(10) = 'Ladd'
s_test(11) = 'Lloyd'
s_test(12) = 'Lissajous'
s_test(13) = 'Lukasiewicz'
s_test(14) = 'Bob'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST091'
write ( *, '(a)' ) ' S_TO_SOUNDEX converts a string to a Soundex code.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' I String Code'
write ( *, '(a)' ) ' '
do i = 1, ntest
call s_to_soundex ( s_test(i), code )
write ( *, '(i3,2x,a15,2x,a4)' ) i, s_test(i), code
end do
return
end
subroutine test092
!
!*******************************************************************************
!
!! TEST092 tests S_TO_Z.
!
implicit none
!
integer, parameter :: ntest = 8
!
complex cval
integer i
integer ierror
integer lchar
character ( len = 20 ) s(ntest)
!
s(1) = '1'
s(2) = '2+I'
s(3) = '3 + 4 I'
s(4) = '5 + 6*I'
s(5) = 'I'
s(6) = '7 I'
s(7) = '-8 * I'
s(8) = '44 * 99'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST092'
write ( *, '(a)' ) ' S_TO_Z accepts a string of characters'
write ( *, '(a)' ) ' and extracts a complex value from them,'
write ( *, '(a)' ) ' assuming a format of A+BI for complex values.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'String CVAL IERROR LCHAR'
write ( *, '(a)' ) ' '
do i = 1, ntest
call s_to_z ( s(i), cval, ierror, lchar )
write ( *, '(a20,2x,2f8.1,2x,i2,6x,i2)' ) s(i), cval, ierror, lchar
end do
return
end
subroutine test093
!
!*******************************************************************************
!
!! TEST093 tests S_TOKEN_EQUAL.
!
implicit none
!
integer, parameter :: nset = 5
!
integer i
integer iset
character ( len = 10 ) set(nset)
character ( len = 10 ) s
!
set(1) = 'Bob'
set(2) = 'Archie'
set(3) = 'Veronica'
set(4) = 'Jughead'
set(5) = 'Betty'
s = 'verONICa'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST093'
write ( *, '(a)' ) ' S_TOKEN_EQUAL searches for whether'
write ( *, '(a)' ) ' a string is in a set. Here, the string is'
write ( *, '(a)' ) trim ( s )
write ( *, '(a)' ) ' and the set is'
do i = 1, nset
write ( *, '(a)' ) trim ( set(i) )
end do
call s_token_equal ( s, set, nset, iset )
write ( *, '(a)' ) ' '
if ( iset /= 0 ) then
write ( *, '(a)' ) ' The matching entry is ' // trim ( set(iset) )
else
write ( *, '(a)' ) ' No match.'
end if
return
end
subroutine test094
!
!*******************************************************************************
!
!! TEST094 tests S_TOKEN_MATCH.
!
implicit none
!
integer, parameter :: token_num = 4
!
integer match
character ( len = 40 ) s
character ( len = 20 ) token(token_num)
integer token_i
!
s = 'TommyGun'
token(1) = 'Tom'
token(2) = 'Zebra'
token(3) = 'TommY'
token(4) = 'TommyKnocker'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST094'
write ( *, '(a)' ) ' S_TOKEN_MATCH finds longest token match.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Our string is'
write ( *, '(a)' ) trim ( s )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Our tokens are:'
write ( *, '(a)' ) ' '
do token_i = 1, token_num
write ( *, '(a)' ) token(token_i)
end do
call s_token_match ( s, token_num, token, match )
write ( *, '(a)' ) ' '
if ( match == 0 ) then
write ( *, '(a)' ) ' No matching token was found.'
else
write ( *, '(a,i6)' ) ' Maximum match occurs with token ', match
end if
return
end
subroutine test095
!
!*******************************************************************************
!
!! TEST095 tests S_SET_DELETE.
!
implicit none
!
integer i
character ( len = 20 ) s
character ( len = 10 ) s2
!
s2 = '0123456789'
s = '1 way 4 U 2 deb8'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST095'
write ( *, '(a)' ) ' S_SET_DELETE removes all occurrences of a set'
write ( *, '(a)' ) ' of characters.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' String: ' // trim ( s )
write ( *, '(a)' ) ' Set: ' // trim ( s2 )
write ( *, '(a)' ) ' '
call s_set_delete ( s, s2 )
write ( *, '(a)' ) 'Result:'
write ( *, '(a)' ) trim ( s )
return
end
subroutine test096
!
!*******************************************************************************
!
!! TEST096 tests SVEC_LAB.
!
implicit none
!
integer, parameter :: n = 15
!
integer i
integer ident(n)
integer nuniq
character ( len = 20 ) string(n)
!
string(1) = 'ALPHA'
string(2) = 'BETA'
string(3) = ' '
string(4) = 'ALPHA'
string(5) = 'Alpha'
string(6) = 'GAMMA'
string(7) = 'BETA'
string(8) = 'BETA'
string(9) = 'ALPHA'
string(10) = 'GAMMA'
string(11) = ' '
string(12) = ' '
string(13) = 'RHO'
string(14) = 'EPSILON'
string(15) = 'Alpha'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST096'
write ( *, '(a)' ) ' SVEC_LAB marks unique strings in a list.'
call svec_lab ( n, nuniq, string, ident )
write ( *, '(a)' ) ' '
write ( *, '(a,i6)' ) ' Number of unique entries = ', nuniq
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' String, ID'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(2x,a20,2x,i6)' ) string(i), ident(i)
end do
return
end
subroutine test097
!
!*******************************************************************************
!
!! TEST097 tests SVEC_MERGE.
!
implicit none
!
integer, parameter :: na = 10
integer, parameter :: nb = 10
!
character ( len = 4 ) a(na)
character ( len = 4 ) b(nb)
character ( len = 4 ) c(na+nb)
integer i
integer nc
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST097'
write ( *, '(a)' ) ' SVEC_MERGE merges two sorted character arrays.'
write ( *, '(a)' ) ' '
a(1) = 'Adam'
a(2) = 'Bill'
a(3) = 'Bob'
a(4) = 'Carl'
a(5) = 'Carl'
a(6) = 'Earl'
a(7) = 'Fred'
a(8) = 'Jean'
a(9) = 'Lynn'
a(10) = 'Zeke'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Input vector A:'
write ( *, '(a)' ) ' '
do i = 1, na
write ( *, '(a4)' ) a(i)
end do
b(1) = 'Ada'
b(2) = 'Barb'
b(3) = 'Cath'
b(4) = 'Deb'
b(5) = 'Eve'
b(6) = 'Inez'
b(7) = 'Jane'
b(8) = 'Jean'
b(9) = 'Jill'
b(10) = 'Lynn'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Input vector B:'
write ( *, '(a)' ) ' '
do i = 1, nb
write ( *, '(a4)' ) b(i)
end do
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Call SVEC_MERGE to merge the two lists.'
call svec_merge ( na, a, nb, b, nc, c )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Merged output vector C:'
write ( *, '(a)' ) ' '
do i = 1, nc
write ( *, '(a4)' ) c(i)
end do
return
end
subroutine test098
!
!*******************************************************************************
!
!! TEST098 tests SVEC_SORT_HEAP_A;
!! TEST098 tests SVECI_SORT_HEAP_A.
!
implicit none
!
integer, parameter :: n = 14
!
character ( len = 10 ) svec(n)
integer i
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST098'
write ( *, '(a)' ) ' Sort an array of character strings:'
write ( *, '(a)' ) ' SVEC_SORT_HEAP_A, case-sensitive;'
write ( *, '(a)' ) ' SVECI_SORT_HEAP_A, case-insensitive.'
write ( *, '(a)' ) ' '
svec(1) = 'FRED'
svec(2) = 'fred'
svec(3) = 'Abacus'
svec(4) = 'beetles'
svec(5) = 'XYLOPHONE'
svec(6) = 'banana'
svec(7) = 'goofball'
svec(8) = 'abbot'
svec(9) = 'BARBECUE'
svec(10) = 'abbots'
svec(11) = ' indented'
svec(12) = '123456'
svec(13) = 'beetles'
svec(14) = 'Abacus'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Unsorted list:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(a)' ) svec(i)
end do
call svec_sort_heap_a ( n, svec )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Sorted list:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(a)' ) svec(i)
end do
svec(1) = 'FRED'
svec(2) = 'fred'
svec(3) = 'Abacus'
svec(4) = 'beetles'
svec(5) = 'XYLOPHONE'
svec(6) = 'banana'
svec(7) = 'goofball'
svec(8) = 'abbot'
svec(9) = 'BARBECUE'
svec(10) = 'abbots'
svec(11) = ' indented'
svec(12) = '123456'
svec(13) = 'beetles'
svec(14) = 'Abacus'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Now do a case-insensitive sort:'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Unsorted list:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(a)' ) svec(i)
end do
call sveci_sort_heap_a ( n, svec )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Sorted list:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(a)' ) svec(i)
end do
return
end
subroutine test099
!
!*******************************************************************************
!
!! TEST099 tests SVEC_SORT_HEAP_A_INDEX;
!! TEST099 tests SVECI_SORT_HEAP_A_INDEX.
!
implicit none
!
integer, parameter :: n = 14
!
character ( len = 10 ) carray(n)
integer i
integer indx(n)
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST099'
write ( *, '(a)' ) ' Indexed heap sort of strings:'
write ( *, '(a)' ) ' SVEC_SORT_HEAP_A_INDEX, case-sensitive;'
write ( *, '(a)' ) ' SVECI_SORT_HEAP_A_INDEX, case-insensitive.'
write ( *, '(a)' ) ' '
carray(1) = 'FRED'
carray(2) = 'fred'
carray(3) = 'Abacus'
carray(4) = 'beetles'
carray(5) = 'XYLOPHONE'
carray(6) = 'banana'
carray(7) = 'goofball'
carray(8) = 'abbot'
carray(9) = 'BARBECUE'
carray(10) = 'abbots'
carray(11) = ' indented'
carray(12) = '123456'
carray(13) = 'beetles'
carray(14) = 'Abacus'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Unsorted list:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(a)' ) carray(i)
end do
call svec_sort_heap_a_index ( n, carray, indx )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Sorted list:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(a)' ) carray(indx(i))
end do
carray(1) = 'FRED'
carray(2) = 'fred'
carray(3) = 'Abacus'
carray(4) = 'beetles'
carray(5) = 'XYLOPHONE'
carray(6) = 'banana'
carray(7) = 'goofball'
carray(8) = 'abbot'
carray(9) = 'BARBECUE'
carray(10) = 'abbots'
carray(11) = ' indented'
carray(12) = '123456'
carray(13) = 'beetles'
carray(14) = 'Abacus'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Now do a case-insensitive sort:'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Unsorted list:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(a)' ) carray(i)
end do
call sveci_sort_heap_a_index ( n, carray, indx )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Sorted list:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(a)' ) carray(indx(i))
end do
return
end
subroutine test0995
!
!*******************************************************************************
!
!! TEST0995 tests UPPER.
!
implicit none
!
integer, parameter :: ntest = 5
!
integer i
character ( len = 20 ) s(ntest)
character ( len = 20 ) upper
!
s(1) = 'HELLO World !! ! '
s(2) = '12345678901234567890'
s(3) = 'Abc Def Ghi Jkl Mno '
s(4) = '!@#$%a^&A(){}[]\\|<>?'
s(5) = 'a waste is a terrible thing to mind.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST0995'
write ( *, '(a)' ) ' UPPER capitalizes all characters in a string;'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) '---------S---------- -----UPPER(S)-------'
write ( *, '(a)' ) ' '
do i = 1, ntest
write ( *, '(a20,2x,a20)' ) s(i), upper ( s(i) )
end do
return
end
subroutine test100
!
!*******************************************************************************
!
!! TEST100 tests WORD_COUNT.
!
implicit none
!
integer, parameter :: ntest = 4
!
integer i
integer nword
character ( len = 32 ) s(ntest)
!
s(1) = '?'
s(2) = 'A man, a plan, a canal - Panama!'
s(3) = ' justone!word,-@#$ '
s(4) = 'How about a day in the park?'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST100'
write ( *, '(a)' ) ' WORD_COUNT counts the words in a string'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' STRING Words'
write ( *, '(a)' ) ' '
do i = 1, ntest
call word_count ( s(i), nword )
write ( *, '( a32, 2x, i12 )' ) s(i), nword
end do
return
end
subroutine test101
!
!*******************************************************************************
!
!! TEST101 tests WORD_EXTRACT.
!
implicit none
!
character ( len = 80 ) input
character ( len = 80 ) word
!
input = 'Just an incontrovertible sample of text!'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST101'
write ( *, '(a)' ) ' WORD_EXTRACT extracts words from a string.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) trim ( input )
write ( *, '(a)' ) ' '
do
call word_extract ( input, word )
if ( len_trim ( word ) <= 0 ) then
exit
end if
write ( *, '(a)' ) trim ( word )
end do
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Reached the last word.'
return
end
subroutine test102
!
!*******************************************************************************
!
!! TEST102 tests WORD_FIND.
!
implicit none
!
integer iword
integer nword
character ( len = 30 ) s
character ( len = 10 ) word
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST102'
write ( *, '(a)' ) ' WORD_FIND looks for a particular word in a string.'
write ( *, '(a)' ) ' '
s = 'Fred is following me around!'
write ( *, '(a)' ) ' string = ' // s
iword = 4
write ( *, '(a,i6)' ) ' We want to find word number ', iword
call word_find ( s, iword, word, nword )
if ( nword == 0 ) then
write ( *, '(a)' ) ' WORD_FIND could not find the requested word.'
else
write ( *, '(a,i6)' ) ' Word has length ', nword
write ( *, '(a)' ) ' The requested word is ' // trim ( word )
end if
return
end
subroutine test103
!
!*******************************************************************************
!
!! TEST103 tests WORD_INC.
!
implicit none
!
integer i
integer ierror
character ( len = 30 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST103'
write ( *, '(a)' ) ' WORD_INC can "increment" strings.'
s = 'Tax'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Starting string: ' // trim ( s )
do i = 1, 5
call word_inc ( s, ierror )
write ( *, '(a)' ) trim ( s )
end do
s = 'aB34c* 8zY'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Starting string: ' // trim ( s )
do i = 1, 5
call word_inc ( s, ierror )
write ( *, '(a)' ) trim ( s )
end do
return
end
subroutine test104
!
!*******************************************************************************
!
!! TEST104 tests WORD_LAST_READ.
!
implicit none
!
integer i
character ( len = 80 ) input
character ( len = 80 ) word
!
input = 'Just an incontrovertible sample of text!'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST104'
write ( *, '(a)' ) ' WORD_LAST_READ returns the last word from a string.'
do i = 1, 2
if ( i == 1 ) then
input = 'Just, an incontrovertible (sample of) text!'
else
input = 'A "second" string.'
end if
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Input string:'
write ( *, '(a)' ) trim ( input )
call word_last_read ( input, word )
write ( *, '(a)' ) 'Last word: ' // trim ( word )
end do
return
end
subroutine test105
!
!*******************************************************************************
!
!! TEST105 tests WORD_INDEX.
!
implicit none
!
integer ihi
integer ilo
integer iword
character ( len = 30 ) s
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST105'
write ( *, '(a)' ) ' WORD_INDEX finds the Nth word in a string.'
write ( *, '(a)' ) ' '
s = 'Fred is following me around!'
write ( *, '(a)' ) ' String = ' // trim ( s )
iword = 4
write ( *, '(a,i6)' ) ' We want to find word number ', iword
call word_index ( s, iword, ilo, ihi )
if ( ilo == 0 .and. ihi == 0 ) then
write ( *, '(a)' ) ' WORD_NDX could not find the requested word.'
else
write ( *, '(a,i6,a,i6)' ) ' Word lies between locations ', ilo, &
' and ', ihi
write ( *, '(a)' ) ' The requested word is ' // s(ilo:ihi)
end if
return
end
subroutine test106
!
!*******************************************************************************
!
!! TEST106 tests WORD_NEXT.
!
implicit none
!
integer ihi
integer ilo
character ( len = 80 ) input
!
input = 'Just an incontrovertible sample of text!'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST106'
write ( *, '(a)' ) ' WORD_NEXT returns each word from a string.'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) input
write ( *, '(a)' ) ' '
do
call word_next ( input, ilo, ihi )
if ( ilo <= 0 ) then
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Reached the last word.'
exit
end if
write ( *, '(a)' ) input(ilo:ihi)
end do
return
end
subroutine test107
!
!*******************************************************************************
!
!! TEST107 tests WORD_NEXT2.
!
implicit none
!
character ( len = 80 ) first
character ( len = 80 ) input
character ( len = 80 ) last
!
input = 'Just an incontrovertible sample of text!'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST107'
write ( *, '(a)' ) ' WORD_NEXT2 returns each word from a string.'
write ( *, '(a)' ) ' '
write ( *, '(4x,a)' ) input
write ( *, '(a)' ) ' '
do
call word_next2 ( input, first, last )
if ( len_trim ( first ) <= 0 ) then
write ( *, '(a)' ) ' '
write ( *, '(2x,a)' ) 'Reached the last word.'
exit
end if
write ( *, '(4x,a)' ) trim ( first )
input = last
end do
return
end
subroutine test108
!
!*******************************************************************************
!
!! TEST108 tests WORD_NEXT_READ.
!
implicit none
!
logical done
integer i
character ( len = 80 ) input
character ( len = 80 ) word
!
input = 'Just an incontrovertible sample of text!'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST108'
write ( *, '(a)' ) ' WORD_NEXT_READ returns each word '
write ( *, '(a)' ) ' in order, from a string.'
do i = 1, 2
if ( i == 1 ) then
input = 'Just, an incontrovertible (sample of) text!'
else
input = 'A "second" string.'
end if
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Input string:'
write ( *, '(4x,a)' ) trim ( input )
done = .true.
do
call word_next_read ( input, word, done )
if ( done ) then
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'No more words in the string.'
exit
end if
write ( *, '(4x,a)' ) trim ( word )
end do
end do
return
end
subroutine test109
!
!*******************************************************************************
!
!! TEST109 tests WORD_SWAP.
!
implicit none
!
integer iword1
integer iword2
character ( len = 80 ) line
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'TEST109'
write ( *, '(a)' ) ' WORD_SWAP swaps two words in a string'
line = 'This is the true story of six roommates who '
write ( *, '(4x,a)' ) trim ( line )
iword1 = 4
iword2 = 8
write ( *, '(a)' ) ' '
write ( *, '(a,i6,a,i6)' ) ' Now swap words ', iword1, ' and ', iword2
call word_swap ( line, iword1, iword2 )
write ( *, '(a)' ) ' '
write ( *, '(4x,a)' ) trim ( line )
return
end
subroutine drwcgm ( x, y )
!
!*******************************************************************************
!
!! DRWCGM is a dummy routine required for using CHRPLT.
!
implicit none
!
real x
real y
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'CHRPRB:DRWCGM - Fatal error!'
write ( *, '(a)' ) ' This is a dummy routine you called!'
write ( *, '(a,2g14.6)' ) ' X,Y = ', x, y
stop
end
subroutine movcgm ( x, y )
!
!*******************************************************************************
!
!! MOVCGM is a dummy routine required for using CHRPLT.
!
implicit none
!
real x
real y
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'CHRPRB:MOVCGM - Fatal error!'
write ( *, '(a)' ) ' This is a dummy routine you called!'
write ( *, '(a,2g14.6)' ) ' X,Y = ', x, y
stop
end