program main !*****************************************************************************80 ! !! MAIN is the main program for CIRCLE_POINTS. ! ! Discussion: ! ! CIRCLE_POINTS writes a file containing points on a circle. ! ! Usage: ! ! circle_points number center_x center_y radius angle1 angle2 file_name ! ! Modified: ! ! 15 November 2005 ! ! Author: ! ! John Burkardt ! implicit none real ( kind = 8 ) angle real ( kind = 8 ) angle1 real ( kind = 8 ) angle2 integer arg_num real ( kind = 8 ) center_x real ( kind = 8 ) center_y integer iarg integer iargc integer ierror character ( len = 80 ) input_file_name integer ios integer j integer length integer number character ( len = 80 ) output_file_name integer output_unit real ( kind = 8 ), allocatable, dimension ( :, : ) :: p real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) radius character ( len = 80 ) string character ( len = 80 ) word call timestamp ( ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CIRCLE_POINTS' write ( *, '(a)' ) ' FORTRAN90 version' write ( *, '(a)' ) ' Write points on a circle to a file' ierror = 0 arg_num = iargc ( ) ! ! Argument 1 is the number of points. ! if ( 1 <= arg_num ) then iarg = 1 call getarg ( iarg, word ) call s_to_i4 ( word, number, ierror, length ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CIRCLE_POINTS:' write ( *, '(a)' ) ' Please enter the number of points.' read ( *, '(a)' ) number end if ! ! Argument 2 is the X center. ! if ( 2 <= arg_num ) then iarg = 2 call getarg ( iarg, word ) call s_to_r8 ( word, center_x, ierror, length ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CIRCLE_POINTS:' write ( *, '(a)' ) ' Please enter the X coordinate of the center.' read ( *, '(a)' ) center_x end if ! ! Argument 3 is the Y center. ! if ( 3 <= arg_num ) then iarg = 3 call getarg ( iarg, word ) call s_to_r8 ( word, center_y, ierror, length ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CIRCLE_POINTS:' write ( *, '(a)' ) ' Please enter the Y coordinate of the center.' read ( *, '(a)' ) center_y end if ! ! Argument 4 is the radius. ! if ( 4 <= arg_num ) then iarg = 4 call getarg ( iarg, word ) call s_to_r8 ( word, radius, ierror, length ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CIRCLE_POINTS:' write ( *, '(a)' ) ' Please enter the radius of the circle.' read ( *, '(a)' ) radius end if ! ! Argument 5 is the initial angle ! if ( 5 <= arg_num ) then iarg = 5 call getarg ( iarg, word ) call s_to_r8 ( word, angle1, ierror, length ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CIRCLE_POINTS:' write ( *, '(a)' ) ' Please enter the initial angle (in degrees).' read ( *, '(a)' ) angle1 end if ! ! Argument 6 is the final angle ! if ( 6 <= arg_num ) then iarg = 6 call getarg ( iarg, word ) call s_to_r8 ( word, angle2, ierror, length ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CIRCLE_POINTS:' write ( *, '(a)' ) ' Please enter the final angle (in degrees).' read ( *, '(a)' ) angle2 end if ! ! Argument 7 is the output file name. ! if ( 7 <= arg_num ) then iarg = 7 call getarg ( iarg, output_file_name ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CIRCLE_POINTS:' write ( *, '(a)' ) ' Please enter the name of the output file.' read ( *, '(a)' ) output_file_name end if allocate ( p(1:2,1:number) ) do j = 1, number angle = ( real ( number - j, kind = 8 ) * angle1 & + real ( j - 1, kind = 8 ) * angle2 ) & / real ( number - 1, kind = 8 ) angle = angle * pi / 180.0D+00 p(1,j) = center_x + radius * cos ( angle ) p(2,j) = center_y + radius * sin ( angle ) end do call get_unit ( output_unit ) open ( unit = output_unit, file = output_file_name, & status = 'replace', iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CIRCLE_POINTS - Fatal error!' write ( *, '(a,i6)' ) ' Could not open the output file "' // & trim ( output_file_name ) // '" on unit ', output_unit stop end if call timestring ( string ) write ( output_unit, '(a)' ) '# ' // trim ( output_file_name ) write ( output_unit, '(a)' ) '# created by CIRCLE_POINTS.F90' write ( output_unit, '(a)' ) '# at ' // trim ( string ) write ( output_unit, '(a)' ) '#' write ( output_unit, '(a,i6)' ) '# Number of points = ', number write ( output_unit, '(a,g14.6)' ) '# Center X = ', center_x write ( output_unit, '(a,g14.6)' ) '# Center Y = ', center_y write ( output_unit, '(a,g14.6)' ) '# Radius = ', radius write ( output_unit, '(a,g14.6)' ) '# Angle 1 = ', angle1 write ( output_unit, '(a,g14.6)' ) '# Angle 2 = ', angle2 write ( output_unit, '(a)' ) '#' do j = 1, number write ( output_unit, '(2x,g14.6,2x,g14.6)' ) p(1:2,j) end do close ( unit = output_unit ) deallocate ( p ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The data was written to "' & // trim ( output_file_name ) // '".' write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CIRCLE_POINTS' write ( *, '(a)' ) ' Normal end of execution.' write ( *, '(a)' ) ' ' call timestamp ( ) stop end subroutine ch_cap ( c ) !*****************************************************************************80 ! !! CH_CAP capitalizes a single character. ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character C, the character to capitalize. ! implicit none character c integer itemp itemp = ichar ( c ) if ( 97 <= itemp .and. itemp <= 122 ) then c = char ( itemp - 32 ) end if return end function ch_eqi ( c1, c2 ) !*****************************************************************************80 ! !! CH_EQI is a case insensitive comparison of two characters for equality. ! ! Examples: ! ! CH_EQI ( 'A', 'a' ) is TRUE. ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C1, C2, the characters to compare. ! ! Output, logical CH_EQI, the result of the comparison. ! implicit none character c1 character c1_cap character c2 character c2_cap logical ch_eqi c1_cap = c1 c2_cap = c2 call ch_cap ( c1_cap ) call ch_cap ( c2_cap ) if ( c1_cap == c2_cap ) then ch_eqi = .true. else ch_eqi = .false. end if return end subroutine ch_to_digit ( c, digit ) !*****************************************************************************80 ! !! CH_TO_DIGIT returns the integer value of a base 10 digit. ! ! Example: ! ! C DIGIT ! --- ----- ! '0' 0 ! '1' 1 ! ... ... ! '9' 9 ! ' ' 0 ! 'X' -1 ! ! Modified: ! ! 04 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the decimal digit, '0' through '9' or blank ! are legal. ! ! Output, integer DIGIT, the corresponding integer value. If C was ! 'illegal', then DIGIT is -1. ! implicit none character c integer digit if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then digit = ichar ( c ) - 48 else if ( c == ' ' ) then digit = 0 else digit = -1 end if return end subroutine get_unit ( iunit ) !*****************************************************************************80 ! !! GET_UNIT returns a free FORTRAN unit number. ! ! Discussion: ! ! A "free" FORTRAN unit number is an integer between 1 and 99 which ! is not currently associated with an I/O device. A free FORTRAN unit ! number is needed in order to open a file with the OPEN command. ! ! If IUNIT = 0, then no free FORTRAN unit could be found, although ! all 99 units were checked (except for units 5, 6 and 9, which ! are commonly reserved for console I/O). ! ! Otherwise, IUNIT is an integer between 1 and 99, representing a ! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 ! are special, and will never return those values. ! ! Modified: ! ! 18 September 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer IUNIT, the free unit number. ! implicit none integer i integer ios integer iunit logical lopen iunit = 0 do i = 1, 99 if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then inquire ( unit = i, opened = lopen, iostat = ios ) if ( ios == 0 ) then if ( .not. lopen ) then iunit = i return end if end if end if end do return end subroutine s_blank_delete ( s ) !*****************************************************************************80 ! !! S_BLANK_DELETE removes blanks from a string, left justifying the remainder. ! ! Comment: ! ! All TAB characters are also removed. ! ! Modified: ! ! 26 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none character c integer get integer put integer nchar character ( len = * ) s character, parameter :: TAB = char ( 9 ) put = 0 nchar = len_trim ( s ) do get = 1, nchar c = s(get:get) if ( c /= ' ' .and. c /= TAB ) then put = put + 1 s(put:put) = c end if end do s(put+1:nchar) = ' ' return end subroutine s_to_i4 ( s, ival, ierror, length ) !*****************************************************************************80 ! !! S_TO_I4 reads an I4 from a string. ! ! Modified: ! ! 28 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string to be examined. ! ! Output, integer IVAL, the integer value read from the string. ! If the string is blank, then IVAL will be returned 0. ! ! Output, integer IERROR, an error flag. ! 0, no error. ! 1, an error occurred. ! ! Output, integer LENGTH, the number of characters of S used to make IVAL. ! implicit none character c integer i integer ierror integer isgn integer istate integer ival integer length character ( len = * ) s ierror = 0 istate = 0 isgn = 1 ival = 0 do i = 1, len_trim ( s ) c = s(i:i) ! ! Haven't read anything. ! if ( istate == 0 ) then if ( c == ' ' ) then else if ( c == '-' ) then istate = 1 isgn = -1 else if ( c == '+' ) then istate = 1 isgn = + 1 else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then istate = 2 ival = ichar ( c ) - ichar ( '0' ) else ierror = 1 return end if ! ! Have read the sign, expecting digits. ! else if ( istate == 1 ) then if ( c == ' ' ) then else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then istate = 2 ival = ichar ( c ) - ichar ( '0' ) else ierror = 1 return end if ! ! Have read at least one digit, expecting more. ! else if ( istate == 2 ) then if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then ival = 10 * ival + ichar ( c ) - ichar ( '0' ) else ival = isgn * ival length = i - 1 return end if end if end do ! ! If we read all the characters in the string, see if we're OK. ! if ( istate == 2 ) then ival = isgn * ival length = len_trim ( s ) else ierror = 1 length = 0 end if return end subroutine s_to_r8 ( s, dval, ierror, length ) !*****************************************************************************80 ! !! S_TO_R8 reads an R8 from a string. ! ! Discussion: ! ! The routine will read as many characters as possible until it reaches ! the end of the string, or encounters a character which cannot be ! part of the number. ! ! Legal input is: ! ! 1 blanks, ! 2 '+' or '-' sign, ! 2.5 blanks ! 3 integer part, ! 4 decimal point, ! 5 fraction part, ! 6 'E' or 'e' or 'D' or 'd', exponent marker, ! 7 exponent sign, ! 8 exponent integer part, ! 9 exponent decimal point, ! 10 exponent fraction part, ! 11 blanks, ! 12 final comma or semicolon, ! ! with most quantities optional. ! ! Examples: ! ! S DVAL ! ! '1' 1.0 ! ' 1 ' 1.0 ! '1A' 1.0 ! '12,34,56' 12.0 ! ' 34 7' 34.0 ! '-1E2ABCD' -100.0 ! '-1X2ABCD' -1.0 ! ' 2E-1' 0.2 ! '23.45' 23.45 ! '-4.2E+2' -420.0 ! '17d2' 1700.0 ! '-14e-2' -0.14 ! 'e2' 100.0 ! '-12.73e-9.23' -12.73 * 10.0**(-9.23) ! ! Modified: ! ! 07 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string containing the ! data to be read. Reading will begin at position 1 and ! terminate at the end of the string, or when no more ! characters can be read to form a legal real. Blanks, ! commas, or other nonnumeric data will, in particular, ! cause the conversion to halt. ! ! Output, real ( kind = 8 ) DVAL, the value read from the string. ! ! Output, integer IERROR, error flag. ! 0, no errors occurred. ! 1, 2, 6 or 7, the input number was garbled. The ! value of IERROR is the last type of input successfully ! read. For instance, 1 means initial blanks, 2 means ! a plus or minus sign, and so on. ! ! Output, integer LENGTH, the number of characters read ! to form the number, including any terminating ! characters such as a trailing comma or blanks. ! implicit none logical ch_eqi character c real ( kind = 8 ) dval integer ierror integer ihave integer isgn integer iterm integer jbot integer jsgn integer jtop integer length integer nchar integer ndig real ( kind = 8 ) rbot real ( kind = 8 ) rexp real ( kind = 8 ) rtop character ( len = * ) s nchar = len_trim ( s ) ierror = 0 dval = 0.0D+00 length = -1 isgn = 1 rtop = 0 rbot = 1 jsgn = 1 jtop = 0 jbot = 1 ihave = 1 iterm = 0 do length = length + 1 if ( nchar < length+1 ) then exit end if c = s(length+1:length+1) ! ! Blank character. ! if ( c == ' ' ) then if ( ihave == 2 ) then else if ( ihave == 6 .or. ihave == 7 ) then iterm = 1 else if ( 1 < ihave ) then ihave = 11 end if ! ! Comma. ! else if ( c == ',' .or. c == ';' ) then if ( ihave /= 1 ) then iterm = 1 ihave = 12 length = length + 1 end if ! ! Minus sign. ! else if ( c == '-' ) then if ( ihave == 1 ) then ihave = 2 isgn = -1 else if ( ihave == 6 ) then ihave = 7 jsgn = -1 else iterm = 1 end if ! ! Plus sign. ! else if ( c == '+' ) then if ( ihave == 1 ) then ihave = 2 else if ( ihave == 6 ) then ihave = 7 else iterm = 1 end if ! ! Decimal point. ! else if ( c == '.' ) then if ( ihave < 4 ) then ihave = 4 else if ( 6 <= ihave .and. ihave <= 8 ) then ihave = 9 else iterm = 1 end if ! ! Scientific notation exponent marker. ! else if ( ch_eqi ( c, 'E' ) .or. ch_eqi ( c, 'D' ) ) then if ( ihave < 6 ) then ihave = 6 else iterm = 1 end if ! ! Digit. ! else if ( ihave < 11 .and. lle ( '0', c ) .and. lle ( c, '9' ) ) then if ( ihave <= 2 ) then ihave = 3 else if ( ihave == 4 ) then ihave = 5 else if ( ihave == 6 .or. ihave == 7 ) then ihave = 8 else if ( ihave == 9 ) then ihave = 10 end if call ch_to_digit ( c, ndig ) if ( ihave == 3 ) then rtop = 10.0D+00 * rtop + real ( ndig, kind = 8 ) else if ( ihave == 5 ) then rtop = 10.0D+00 * rtop + real ( ndig, kind = 8 ) rbot = 10.0D+00 * rbot else if ( ihave == 8 ) then jtop = 10 * jtop + ndig else if ( ihave == 10 ) then jtop = 10 * jtop + ndig jbot = 10 * jbot end if ! ! Anything else is regarded as a terminator. ! else iterm = 1 end if ! ! If we haven't seen a terminator, and we haven't examined the ! entire string, go get the next character. ! if ( iterm == 1 ) then exit end if end do ! ! If we haven't seen a terminator, and we have examined the ! entire string, then we're done, and LENGTH is equal to NCHAR. ! if ( iterm /= 1 .and. length+1 == nchar ) then length = nchar end if ! ! Number seems to have terminated. Have we got a legal number? ! Not if we terminated in states 1, 2, 6 or 7! ! if ( ihave == 1 .or. ihave == 2 .or. ihave == 6 .or. ihave == 7 ) then ierror = ihave write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'S_TO_R8 - Serious error!' write ( *, '(a)' ) ' Illegal or nonnumeric input:' write ( *, '(a)' ) ' ' // trim ( s ) return end if ! ! Number seems OK. Form it. ! if ( jtop == 0 ) then rexp = 1.0D+00 else if ( jbot == 1 ) then rexp = 10.0D+00 ** ( jsgn * jtop ) else rexp = 10.0D+00 ** ( real ( jsgn * jtop, kind = 8 ) & / real ( jbot, kind = 8 ) ) end if end if dval = real ( isgn, kind = 8 ) * rexp * rtop / rbot return end subroutine timestamp ( ) !*****************************************************************************80 ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! Example: ! ! 31 May 2001 9:45:54.872 AM ! ! Modified: ! ! 06 August 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none character ( len = 8 ) ampm integer d integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s integer values(8) integer y call date_and_time ( values = values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end subroutine timestring ( string ) !*****************************************************************************80 ! !! TIMESTRING writes the current YMDHMS date into a string. ! ! Example: ! ! STRING = 'May 31 2001 9:45:54.872 AM' ! ! Modified: ! ! 15 March 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) STRING, contains the date information. ! A character length of 40 should always be sufficient. ! implicit none character ( len = 8 ) ampm integer d character ( len = 8 ) date integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s character ( len = * ) string character ( len = 10 ) time integer values(8) integer y character ( len = 5 ) zone call date_and_time ( date, time, zone, values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( string, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end subroutine word_extract ( s, w ) !*****************************************************************************80 ! !! WORD_EXTRACT extracts the next word from a string. ! ! Discussion: ! ! A "word" is a string of characters terminated by a blank or ! the end of the string. ! ! Modified: ! ! 31 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string. On output, the first ! word has been removed, and the remaining string has been shifted left. ! ! Output, character ( len = * ) W, the leading word of the string. ! implicit none integer get1 integer get2 integer length character ( len = * ) s character ( len = * ) w w = ' ' length = len_trim ( s ) if ( length < 1 ) then return end if ! ! Find the first nonblank. ! get1 = 0 do get1 = get1 + 1 if ( length < get1 ) then return end if if ( s(get1:get1) /= ' ' ) then exit end if end do ! ! Look for the last contiguous nonblank. ! get2 = get1 do if ( length <= get2 ) then exit end if if ( s(get2+1:get2+1) == ' ' ) then exit end if get2 = get2 + 1 end do ! ! Copy the word. ! w = s(get1:get2) ! ! Shift the string. ! s(1:get2) = ' ' s = adjustl ( s(get2+1:) ) return end