PROGRAM ReverseDIG ! ! Reads a .DIG file and characterizes each polyline as a loop or curve ! with information about rotation or progress/dip, respectively. ! Prompts user to decide whether this polyline should be reversed. ! ! by Peter Bird ! Department of Earth, Planetary, and Space Sciences ! University of California ! Los Angeles, CA 90095-1567 ! pbird@epss.ucla.edu ! May 2001; revised April 2019 ! !(c) Copyright 2001, 2002, 2012, 2019 by Peter Bird and the Regents ! of the University of California. ! USE DSphere ! module containing spherical-geometry operations IMPLICIT NONE !Lines of storage for headers (above a single polyline): INTEGER, PARAMETER :: headSpace = 100 !Storage for strings of (lon, lat) points (in a single polyline): INTEGER, PARAMETER :: maximum = 100000 !Determine KIND of REAL required for 11 significant digits !and a magnitude range from at least 1.E-36 to 1.E+36: INTEGER, PARAMETER :: High = SELECTED_REAL_KIND (11, 36) CHARACTER*40 :: terminator ! e.g., "*** end of polyline ***" CHARACTER*40, DIMENSION(maximum) :: pointLines CHARACTER*132 :: input_file_name, line, output_file_name, suggestion CHARACTER*132, DIMENSION(headSpace) :: headerList INTEGER :: count, dot_place, i, ios, headLines, high_count, lineType INTEGER :: mt_flashby_count = 1, mt_flashby_limit = 100 ! for Prompt_for_ routines LOGICAL :: guess, inStream, loop, more_dig, mt_flashby = .FALSE., reverse_it REAL*8 :: angle_sum, center_Elon, center_NLat, circles, gap_radians, latitude, longitude, ta1, ta2, total_length, & & trend_degrees, dip_degrees REAL*8, DIMENSION(3) :: center_uvec, tvec, uvec, v1_uvec, v2_uvec REAL*8, DIMENSION(3, maximum) :: uvecs WRITE (*,"(//' ----------------------------------------------------------------------'& & /' ReverseDIG'& &//' Reads a .DIG file in (longitude, latitude) format,'& & /' with zero, one, or more header line(s) per polyline,'& & /' characterizes each polyline as a loop or a progressive line,'& & /' with information about rotation or progress/dip, respectively.'& & /' Prompts user to decide whether this polyline should be reversed?'& &//' by Peter Bird, UCLA, 2002 & 2012 & 2019'& & /' ----------------------------------------------------------------------')") CALL Prompt_for_Logical('Do you want more information about .DIG files?',.FALSE.,more_dig) IF (more_dig) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About .DIG Files'& &/' The box below contains the first 12 lines of a typical .DIG file.'& &/' ----------------------------- Notice:'& &/' |F1234N My fault, NV | <- a title line (strongly recommended)'& &/' |dip_degrees 75 | <- additional header(s) (optional)'& &/' | -1.05875E+02,+3.87835E+01 | <- 1st (lon,lat) pair in polyline'& &/' | -1.05849E+02,+3.87731E+01 |'& &/' | -1.05826E+02,+3.87534E+01 |'& &/' | -1.05801E+02,+3.87355E+01 | <-(polyline can have any number of'& &/' | -1.05777E+02,+3.87195E+01 | points)'& &/' | -1.05769E+02,+3.87104E+01 |<- last (lon,lat) pair in polyline'& &/' |*** end of polyline *** |<- standard end record (*** required)'& &/' |F7732R Greased fault, SC |<- title of next polyline (recommended)'& &/' | -1.05023E+02,+3.76613E+01 |'& &/' | -1.05040E+02,+3.76794E+01 |'& &/' | -1.05050E+02,+3.76995E+01 | et cetera, et cetera......'& &/' -----------------------------'& &/' ----------------------------------------------------------------------')") END IF ! more_dig IF (more_dig) CALL Prompt_for_Logical('Do you want more information about .DIG files?',.FALSE.,more_dig) IF (more_dig) THEN WRITE (*,& &"(//' ----------------------------------------------------------------------'& &/' About .DIG Files'& &/' Titles of polylines: Recommended. Label each polyline with a one-line'& &/' title. Such title/header lines may NOT start with a blank space.'& &/' Number formats: Column 1 blank. Column 2 holds sign. Columns 3~13'& &/' hold the longitude, preferably in scientific notation.'& &/' Column 14 is a comma. Column 15 is a sign. Columns 16~26 hold'& &/' the latitude. To write such data from a Fortran 90 program,'& &/' use FORMAT (1X, SP, ES12.5, '', '', ES12.5).'& &/' (lon,lat) data has longitude before latitude in each pair. Units are'& &/' degrees (e.g., 24 degrees 17 minutes 5 seconds -> 24.2847 degrees).'& &/' East longitude is +, West is -. North latitude is +, South is -.'& &/' ----------------------------------------------------------------------')") END IF ! more_dig 100 WRITE (*,"(//' Enter [path\]filename of your input .DIG file: ')") READ (*,"(A)") input_file_name input_file_name = ADJUSTL(input_file_name) OPEN (UNIT = 1, FILE = input_file_name, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found (in this directory). Try again:')") GOTO 100 END IF ! file not found WRITE (*,"(' ')") OPEN (UNIT = 1, FILE = input_file_name, STATUS = 'OLD', IOSTAT = ios, PAD = 'YES') dot_place = INDEX(input_file_name, '.dig', .TRUE.) IF (dot_place <= 0) dot_place = INDEX(input_file_name, '.DIG', .TRUE.) IF (dot_place > 0) THEN ! input_file_name includes .dig or .DIG suggestion = input_file_name(1:dot_place-1) // '_reversed.dig' ELSE ! input_file_name does not include .dig or .DIG suggestion = TRIM(ADJUSTL(input_file_name)) // '_reversed.dig' END IF 500 CALL Prompt_for_String('What filename shall be used for the output file?', suggestion, output_file_name) OPEN (UNIT = 2, FILE = output_file_name, STATUS = 'NEW', IOSTAT = ios) IF (ios /= 0) THEN CLOSE (UNIT = 2, IOSTAT = ios) WRITE (*,"(' ERROR: File already exists. Try again:')") suggestion = output_file_name GOTO 500 END IF ! file already exists terminator = "*** end of polyline ***" ! just in case a single-polyline input .DIG ends before including the preferred terminator (unlikely). high_count = 0 ! initialization getting_polylines: DO headLines = 0 ! header lines, for this particular polyline count = 0 ! of (lon, lat) points in this polyline inStream = .FALSE. ! not (necessarily) past the headers, and into the point-list (yet) getting_headers_and_points: DO ! contents of a single polyline group of records READ (1, "(A)", IOSTAT = ios) line IF (ios /= 0) THEN ! probably hit the EOF IF (inStream) THEN WRITE (2, "(A)") TRIM(terminator) END IF EXIT getting_polylines END IF ! hit EOF !OK, we got a line of input. Now, characterize and memorize it: IF (line(1:3) == "***") THEN lineType = 3 ! terminator terminator = TRIM(line) !instream = .FALSE. ! correct, but redundant EXIT getting_headers_and_points ELSE IF ((line(1:2) == " +").OR.(line(1:2) == " -").OR.(line(1:2) == " ")) THEN lineType = 2 ! point count = count + 1 IF (count > maximum) THEN WRITE (*,"(' Increase INTEGER, PARAMETER :: maximum')") CALL PAUSE() STOP END IF pointLines(count) = TRIM(line) inStream = .TRUE. ELSE ! a header IF (inStream) EXIT getting_headers_and_points ! Apparently a terminator was missing, and we are starting a new polyline(?) lineType = 1 headLines = headLines + 1 IF (headLines > headSpace) THEN WRITE (*,"(' Increase INTEGER, PARAMETER :: headSpace')") CALL PAUSE() STOP END IF headerList(headLines) = TRIM(line) END IF END DO getting_headers_and_points high_count = MAX(high_count, count) IF (count > 1) THEN ! polyline should be considered for possible reversal, so analyze it: !Interpret pointLines as (#, #) and convert to uvecs: DO i = 1, count line = pointLines(i) READ (line, *, IOSTAT = ios) longitude, latitude IF (ios /= 0) THEN WRITE (*, "(' ERROR: The following input line did NOT contain two readable numbers:' / ' ', A)") TRIM(line) CALL Pause() STOP END IF CALL DLonLat_2_Uvec (longitude, latitude, uvec) uvecs(1:3, i) = uvec(1:3) END DO !Find average center point for this loop tvec = 0.0D0 ! all 3 components of non-unit vector for center point DO i = 2, count v1_uvec(1:3) = uvecs(1:3, i-1) v2_uvec(1:3) = uvecs(1:3, i) !accumulate length-weighted sum of vertex vectors, as nominal center-point: tvec(1:3) = tvec(1:3) + uvecs(1:3, i) * DArc(v1_uvec, v2_uvec) END DO CALL DMake_Uvec(tvec, center_uvec) !Determine sense of rotation about this center total_length = 0.0D0 angle_sum = 0.0D0 DO i = 2, count v1_uvec(1:3) = uvecs(1:3, i-1) v2_uvec(1:3) = uvecs(1:3, i) IF ((v1_uvec(1) == v2_uvec(1)).AND. & &(v1_uvec(2) == v2_uvec(2)).AND. & &(v1_uvec(3) == v2_uvec(3))) CYCLE !accumulate total length (in radians of arc): total_length = total_length + DArc(v1_uvec, v2_uvec) !accumulate length-weighted sum of vertex vectors, as nominal center-point: tvec(1:3) = tvec(1:3) + uvecs(1:3, i)*DArc(v1_uvec, v2_uvec) !angle at central point: ta1 = DRelative_Compass (from_uvec = center_uvec, to_uvec = v1_uvec) ta2 = DRelative_Compass (from_uvec = center_uvec, to_uvec = v2_uvec) !(after fixing possible cycle shifts) IF (ABS(ta2 - ta1) > Pi) THEN IF (ta2 > ta1) THEN ta2 = ta2 - Two_Pi ELSE ta1 = ta1 - Two_Pi END IF END IF angle_sum = angle_sum + (ta2 - ta1) END DO ! i = 2, count circles = ABS(angle_sum) / Two_Pi !check for any gap between start and finish v1_uvec(1:3) = uvecs(1:3,1) v2_uvec(1:3) = uvecs(1:3,count) gap_radians = DArc(v2_uvec, v1_uvec) IF (headLines == 0) THEN WRITE (*, "(/' Anonymous polyline with NO HEADER LINE(s):')") ELSE WRITE (*, "(/' Polyline entitled:')") DO i = 1, headLines WRITE (*, "(' ', A)") TRIM(headerList(i)) END DO END IF loop = ((circles > 0.90D0).AND.(circles < 1.10D0).AND.(gap_radians < (0.10D0 * total_length))) IF (loop) THEN WRITE (* ,"(' is a loop of ', I6, ' points which')") count IF (angle_sum < 0.0D0) THEN WRITE (*, "(' rotates ', F5.2, ' circle(s) counterclockwise.')") circles guess = .FALSE. ELSE WRITE (*, "(' rotates ', F5.2, ' circle(s) CLOCKWISE.')") circles guess = .TRUE. END IF ELSE IF (gap_radians < (0.10D0 * total_length)) THEN CALL DUvec_2_LonLat(center_uvec, center_ELon, center_NLat) WRITE (*, "(' is perplexing, because it closes (or ~closes) on itself,')") WRITE (*, "(' and yet the computed number of rotations (', ES 12.4, ') is NOT ~1')") circles WRITE (*, "(' This probably happened because the computed ""center-point"" ')')") WRITE (*, "(' at (', F10.4, ',', F10.4, ')')") center_Elon, center_NLat WRITE (*, "(' is not actually inside the curve.')") WRITE (*, "(' This indicates a pathological polyline, OR a flaw in the logic of this program!')") ELSE ! progressive open curve (or simple line): CALL DUvec_2_LonLat(v1_uvec, longitude, latitude) WRITE (* ,"(' is an open curve of ', I6, ' points')") count WRITE (* ,"(' from (', F8.3, 'E, ', F7.3, 'N)')") longitude, latitude CALL DUvec_2_LonLat(v2_uvec, longitude, latitude) WRITE (* ,"(' to (', F8.3, 'E, ', F7.3, 'N)')") longitude, latitude trend_degrees = DRelative_Compass (v1_uvec, v2_uvec) * degrees_per_radian IF (trend_degrees < 0.0D0) trend_degrees = trend_degrees + 360.0D0 dip_degrees = trend_degrees - 90.0D0 IF (dip_degrees < 0.0D0) dip_degrees = dip_degrees + 360.0D0 WRITE (*, "(' trending ', F5.1, ' which implies dip toward ', F5.1, ' degrees.')") trend_degrees, dip_degrees guess = .FALSE. END IF CALL Prompt_for_Logical("Should this polyline be reversed?", guess, reverse_it) ELSE ! no need for analysis reverse_it = .FALSE. END IF ! (count > 1); (so this polyline needs to be analyzed, and user's decision requested) !OUTPUT SECTION: ------------------------------------------------------------------------ !Headers (if any): IF (headLines > 0) THEN DO i = 1, headLines WRITE (2, "(A)") TRIM(headerList(i)) END DO END IF !Points (if any): IF (count > 0) THEN IF (reverse_it) THEN DO i = count, 1, -1 WRITE (2, "(A)") TRIM(pointLines(i)) END DO ELSE ! same order as in input .DIG file... DO i = 1, count WRITE (2, "(A)") TRIM(pointLines(i)) END DO END IF END IF !Terminator (using same record as we found in the input .DIG file) WRITE (2, "(A)") TRIM(terminator) !---------------------------------------------------------------------------------------- END DO getting_polylines CLOSE (1) CLOSE (2) WRITE (*,"(/' Output file ', A, ' has been written.' /)") TRIM(output_file_name) WRITE (*,"( ' Greatest number of points in any polyline was ', I6)") high_count CALL Pause() CONTAINS SUBROUTINE Pause () IMPLICIT NONE WRITE (*, "(/' Press [Enter] to continue...')") READ (*, *) RETURN END SUBROUTINE Pause SUBROUTINE Prompt_for_Integer (prompt_text, default, answer) ! Writes a line to the default (*) unit, with: ! "prompt_text" ["default"]: ! and accepts an answer with an integer value. ! If [Enter] is pressed with nothing preceding it, ! then "answer" takes the value "default". ! This also occurs IF (mt_flashby), without waiting for user. ! Note that prompt_text should usually end with '?'. ! It can be more than 52 bytes long if necessary, but cannot ! contain line breaks, tabs, or other formatting. ! Trailing blanks in prompt_text are ignored. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: prompt_text INTEGER, INTENT(IN) :: default INTEGER, INTENT(OUT) :: answer CHARACTER*11 :: instring, suggested INTEGER :: blank_at, bytes, ios, trial, written LOGICAL :: finished IF (mt_flashby_count > mt_flashby_limit) THEN ! quash inf.-loop! WRITE (*, "(/' mt_flashby_count > mt_flashby_limit = ',I4,'; returning to manual.')") mt_flashby_limit mt_flashby = .FALSE. mt_flashby_count = 0 END IF WRITE (suggested,"(I11)") default suggested = ADJUSTL(suggested) bytes = LEN_TRIM(prompt_text) finished = .FALSE. DO WHILE (.NOT. finished) written = 0 DO WHILE ((bytes - written) > 52) blank_at = written + INDEX(prompt_text((written+1):(written+52)),' ',.TRUE.) ! searching L from end for ' ' IF (blank_at < (written + 2)) blank_at = written + 52 WRITE (*,"(' ',A)") prompt_text((written+1):blank_at) written = blank_at END DO WRITE (*,"(' ',A,' [',A']: '\)") prompt_text((written+1):bytes), TRIM(suggested) finished = .TRUE. ! unless changed below IF (mt_flashby) THEN WRITE (*, *) mt_flashby_count = mt_flashby_count + 1 ELSE READ (*,"(A)") instring END IF IF (instring == "'") mt_flashby = .TRUE. IF (mt_flashby.OR.(LEN_TRIM(instring) == 0)) THEN answer = default ELSE !The following lead to occoasional abends !under Digital Visual Fortran 5.0D !(memory violations caught by WinNT): !READ (instring, *, IOSTAT = ios) trial !The following fix leads to a compiler error: !BACKSPACE (*) !READ (*, *, IOSTAT = ios) trial !and the following fix lead to an immediate abend: !BACKSPACE (5) !READ (*, *, IOSTAT = ios) trial !So, I am creating and then reading a dummy file: OPEN (UNIT = 72, FILE = 'trash') WRITE (72, "(A)") instring CLOSE (72) OPEN (UNIT = 72, FILE = 'trash') READ (72, *, IOSTAT = ios) trial CLOSE (72, STATUS = 'DELETE') IF (ios /= 0) THEN ! bad string WRITE (*,"(' ERROR: Your response (',A,') was not recognized.')") TRIM(instring) WRITE (*,"(' Enter an integer of 9 digits or less.')") WRITE (*,"(' Please try again:')") finished = .FALSE. ELSE answer = trial END IF ! problem with string, or not? END IF ! some bytes were entered END DO ! until finished END SUBROUTINE Prompt_for_Integer SUBROUTINE Prompt_for_Logical (prompt_text, default, answer) ! Writes a line to the default (*) unit, with: ! "prompt_text" ["default"]: ! and accepts an answer with a logical value. ! If [Enter] is pressed with nothing preceding it, ! then "answer" takes the value "default". ! The same happens IF (mt_flashby), without waiting for the user. ! Note that prompt_text should usually end with '?'. ! It can be more than 70 bytes long if necessary, but cannot ! contain line breaks, tabs, or other formatting. ! Trailing blanks in prompt_text are ignored. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: prompt_text LOGICAL, INTENT(IN) :: default LOGICAL, INTENT(OUT) :: answer CHARACTER*1 :: inbyte CHARACTER*3 :: yesno INTEGER :: blank_at, bytes, written LOGICAL :: finished IF (mt_flashby_count > mt_flashby_limit) THEN ! quash inf.-loop! WRITE (*, "(/' mt_flashby_count > mt_flashby_limit = ',I4,'; returning to manual.')") mt_flashby_limit mt_flashby = .FALSE. mt_flashby_count = 0 END IF bytes = LEN_TRIM(prompt_text) finished = .FALSE. DO WHILE (.NOT. finished) IF (default) THEN yesno = 'Yes' ELSE yesno = 'No' END IF written = 0 DO WHILE ((bytes - written) > 70) blank_at = written + INDEX(prompt_text((written+1):(written+70)),' ',.TRUE.) ! searching L from end for ' ' IF (blank_at < (written + 2)) blank_at = written + 70 WRITE (*,"(' ',A)") prompt_text((written+1):blank_at) written = blank_at END DO WRITE (*,"(' ',A,' [',A']: '\)") prompt_text((written+1):bytes), TRIM(yesno) finished = .TRUE. ! unless changed below IF (mt_flashby) THEN WRITE (*, *) mt_flashby_count = mt_flashby_count + 1 ELSE READ (*,"(A)") inbyte END IF IF (inbyte == "'") mt_flashby = .TRUE. IF (mt_flashby.OR.(LEN_TRIM(inbyte) == 0)) THEN answer = default ELSE SELECT CASE (inbyte) CASE ('Y') answer = .TRUE. CASE ('y') answer = .TRUE. CASE ('T') answer = .TRUE. CASE ('t') answer = .TRUE. CASE ('R') answer = .TRUE. CASE ('r') answer = .TRUE. CASE ('O') answer = .TRUE. CASE ('o') answer = .TRUE. CASE ('N') answer = .FALSE. CASE ('n') answer = .FALSE. CASE ('F') answer = .FALSE. CASE ('f') answer = .FALSE. CASE ('W') answer = .FALSE. CASE ('w') answer = .FALSE. CASE DEFAULT WRITE (*,"(' ERROR: Your response (',A,') was not recognized.')") inbyte WRITE (*,"(' (Only the first letter of your answer is used.)')") WRITE (*,"(' To agree, enter Y, y, T, t, O, o, R, or r.')") WRITE (*,"(' To disagree, enter N, n, F, f, W, or w.')") WRITE (*,"(' Please try again:')") finished = .FALSE. END SELECT END IF ! a byte was entered END DO ! until finished END SUBROUTINE Prompt_for_Logical SUBROUTINE Prompt_for_Real (prompt_text, default, answer) ! Writes a line to the default (*) unit, with: ! "prompt_text" ["default"]: ! and accepts an answer with a real value. ! If [Enter] is pressed with nothing preceding it, ! then "answer" takes the value "default". ! The same happens IF (mt_flashby), without waiting for the user. ! Note that prompt_text should usually end with '?'. ! It can be more than 52 bytes long if necessary, but cannot ! contain line breaks, tabs, or other formatting. ! Trailing blanks in prompt_text are ignored. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: prompt_text REAL, INTENT(IN) :: default REAL, INTENT(OUT) :: answer CHARACTER*11 :: instring, suggested INTEGER :: blank_at, bytes, ios, written LOGICAL :: finished REAL :: trial IF (mt_flashby_count > mt_flashby_limit) THEN ! quash inf.-loop! WRITE (*, "(/' mt_flashby_count > mt_flashby_limit = ',I4,'; returning to manual.')") mt_flashby_limit mt_flashby = .FALSE. mt_flashby_count = 0 END IF IF (((ABS(default) >= 0.1).AND.(ABS(default) < 1000.)).OR.(default == 0.0)) THEN ! Use G format because it eliminates unnecessary trailing zeros and decimal points. WRITE (suggested,"(G11.3)") default ELSE ! Use 1P,E because it avoids wasted and irritating leading 0 ("0.123E+4"). WRITE (suggested,"(1P,E11.3)") default END IF suggested = ADJUSTL(suggested) bytes = LEN_TRIM(prompt_text) finished = .FALSE. DO WHILE (.NOT. finished) written = 0 DO WHILE ((bytes - written) > 52) blank_at = written + INDEX(prompt_text((written+1):(written+52)),' ',.TRUE.) ! searching L from end for ' ' IF (blank_at < (written + 2)) blank_at = written + 52 WRITE (*,"(' ',A)") prompt_text((written+1):blank_at) written = blank_at END DO WRITE (*,"(' ',A,' [',A']: '\)") prompt_text((written+1):bytes), TRIM(suggested) finished = .TRUE. ! unless changed below IF (mt_flashby) THEN WRITE (*, *) mt_flashby_count = mt_flashby_count + 1 ELSE READ (*,"(A)") instring END IF IF (instring == "'") mt_flashby = .TRUE. IF (mt_flashby.OR.(LEN_TRIM(instring) == 0)) THEN answer = default ELSE !The following lead to occoasional abends !under Digital Visual Fortran 5.0D !(memory violations caught by WinNT): !READ (instring, *, IOSTAT = ios) trial !The following fix leads to a compiler error: !BACKSPACE (*) !READ (*, *, IOSTAT = ios) trial !and the following fix lead to an immediate abend: !BACKSPACE (5) !READ (*, *, IOSTAT = ios) trial !So, I am creating and then reading a dummy file: OPEN (UNIT = 72, FILE = 'trash') WRITE (72, "(A)") instring CLOSE (72) OPEN (UNIT = 72, FILE = 'trash') READ (72, *, IOSTAT = ios) trial CLOSE (72, STATUS = 'DELETE') IF (ios /= 0) THEN ! bad string WRITE (*,"(' ERROR: Your response (',A,') was not recognized.')") TRIM(instring) WRITE (*,"(' Enter an real number using 11 characters (or less).')") WRITE (*,"(' Please try again:')") finished = .FALSE. ELSE answer = trial END IF ! problem with string, or not? END IF ! some bytes were entered END DO ! until finished END SUBROUTINE Prompt_for_Real SUBROUTINE Prompt_for_String (prompt_text, default, answer) ! Writes a line to the default (*) unit, with: ! "prompt_text" ["default"]: ! and accepts an answer with a character-string value. ! If [Enter] is pressed with nothing preceding it, ! then "answer" takes the value "default". ! The same happens IF (mt_flashby), without waiting for the user. ! Note that prompt_text should usually end with '?'. ! It can be more than 70 bytes long if necessary, but cannot ! contain line breaks, tabs, or other formatting. ! Trailing blanks in prompt_text are ignored. IMPLICIT NONE CHARACTER*(*), INTENT(IN) :: prompt_text CHARACTER*(*), INTENT(IN) :: default CHARACTER*(*), INTENT(OUT) :: answer CHARACTER*80 trial INTEGER :: blank_at, default_bytes, leftover, & & prompt_bytes, written IF (mt_flashby_count > mt_flashby_limit) THEN ! quash inf.-loop! WRITE (*, "(/' mt_flashby_count > mt_flashby_limit = ',I4,'; returning to manual.')") mt_flashby_limit mt_flashby = .FALSE. mt_flashby_count = 0 END IF prompt_bytes = LEN_TRIM(prompt_text) default_bytes = LEN_TRIM(default) written = 0 leftover = 79 - prompt_bytes - 4 ! unless changed below DO WHILE ((prompt_bytes - written) > 70) blank_at = written + INDEX(prompt_text((written+1):(written+70)),' ',.TRUE.) ! searching L from end for ' ' IF (blank_at < (written + 2)) blank_at = written + 70 WRITE (*,"(' ',A)") prompt_text((written+1):blank_at) leftover = 79 - (blank_at - (written+1) + 1) - 4 written = blank_at END DO IF (leftover >= default_bytes) THEN WRITE (*,"(' ',A,' [',A,']')") prompt_text(written+1:prompt_bytes), TRIM(default) ELSE WRITE (*,"(' ',A)") prompt_text(written+1:prompt_bytes) WRITE (*,"(' [',A,']')") TRIM(default) END IF WRITE (*,"(' ?: '\)") IF (mt_flashby) THEN mt_flashby_count = mt_flashby_count + 1 ELSE READ (*,"(A)") trial END IF IF (trial == "'") mt_flashby = .TRUE. IF (mt_flashby.OR.(LEN_TRIM(trial) == 0)) THEN answer = TRIM(default) ELSE answer = TRIM(trial) END IF END SUBROUTINE Prompt_for_String END PROGRAM ReverseDIG