PROGRAM ReframeGPS ! A utility program to transform geodetic velocities at benchmarks ! (which are expressed in Peter Bird's .gps format) into a ! new reference frame, by the addition of one Euler rotation-rate. ! ! The Euler vector for the correction may be specified directly, ! or else determined from velocity corrections at two different ! locations, input by the user in terms of Northward and Eastward ! velocity components in mm/year. ! ! Note that station names, coordinates, and error information !(standard deviations of velocity components, and their correlation) ! are not affected by this transformation. ! ! by Peter Bird, UCLA, 2002.08.02; revised 2019.04.11 (to use REAL*8). USE DSphere IMPLICIT NONE CHARACTER*15 :: first_frame, new_frame, reference_frame CHARACTER*60 :: in_file_name, out_file_name CHARACTER*132 :: identifier, title_line, gps_format, headers, line INTEGER :: benchmark_sequence, ios LOGICAL :: got_Euler, mixed_frames, proceed_anyway REAL*8 :: correlation, & & E_lon_deg, & & Euler_rate_rps, Euler_rate_degpMa, & & latitude1, latitude2, longitude1, longitude2, & & midpoint_rps, & & N_lat_deg, & & pole_latitude, pole_longitude, & & R_km, R_m, & & t, twist_1_rps, twist_2_rps, & & v_add_1_scalar_SI, v_add_2_scalar_SI, & & vE_add_mmpa, vE_add_SI, vE_mmpa, vE_add_1_mmpa, vE_add_2_mmpa, vE_sigma, & & vN_add_mmpa, vN_add_SI, vN_mmpa, vN_add_1_mmpa, vN_add_2_mmpa, vN_sigma REAL*8, DIMENSION(3) :: around1, around2, around1_uvec, around2_uvec, & & benchmark_radius_m, benchmark_uvec, & & Euler_uvec, Euler_vector, & & midpoint_uvec, ortho_pole_vector, site1, site2, tvec, & & unit_theta, unit_phi, & & v_add_1_SI, v_add_2_SI, v_add_mean_SI, velocity_correction_SI WRITE (*,"( ' ReframeGPS:')") WRITE (*,"(/' A utility program to transform geodetic velocities at benchmarks')") WRITE (*,"( ' (which are expressed in Peter Bird''s .gps format) into a')") WRITE (*,"( ' new reference frame, by the addition of one Euler rotation-rate.')") WRITE (*,"(/' The Euler vector for the correction may be entered directly, ')") WRITE (*,"( ' or determined from velocity corrections at two different ')") WRITE (*,"( ' locations, input by the user in terms of Northward and Eastward')") WRITE (*,"( ' velocity components in mm/year.')") WRITE (*,"(/' Note that station names, coordinates, and error information')") WRITE (*,"( ' (standard deviations of velocity components, and their correlation)')") WRITE (*,"( ' are not affected by this transformation.')") WRITE (*,"(/' by Peter Bird, UCLA, 2002.08.02; revised 2019.04.11')") 1 WRITE (*,"(/' Enter name of (existing) .gps file of geodetic velocities:')") READ (*,"(A)") in_file_name OPEN (UNIT = 1, STATUS = "OLD", FILE = in_file_name, PAD = "YES", IOSTAT = ios) IF (ios /= 0) THEN WRITE (*,"(' ERROR: File not found (in this directory).')") WRITE (*,"(' Please move existing file to current directory,')") WRITE (*,"(' or type file name more carefully.')") WRITE (*,"(' Try again:')") WRITE (*,"(' ')") GO TO 1 END IF READ (1,"(A)") title_line WRITE (*,"(/' ',A)") TRIM(title_line) READ (1,"(A)") gps_format READ (1,"(A)") headers benchmark_sequence = 0 mixed_frames = .FALSE. review: DO READ (1, gps_format, IOSTAT = ios) E_lon_deg, N_lat_deg, & & vE_mmpa, vN_mmpa, & & vE_sigma, vN_sigma, & & correlation, & & reference_frame, & & identifier IF (ios > 0) THEN BACKSPACE 1 READ (1,"(A)") line WRITE (*,"(' ERROR: After successful reading of ', I6, ' benchmarks,' & /' a line was encountered which could not be read with ' & /' the specified format:' & /' ', A & /' The IOSTAT error code was ', I6)") & benchmark_sequence, TRIM(line), ios STOP END IF IF (ios == -1) EXIT review benchmark_sequence = benchmark_sequence + 1 IF (benchmark_sequence == 1) THEN first_frame = reference_frame ELSE IF (reference_frame /= first_frame) mixed_frames = .TRUE. END IF END DO review CLOSE (1) IF (mixed_frames) THEN WRITE (*,"( ' ')") WRITE (*,"( ' ')") WRITE (*,"(/' *** CAUTION! ***')") WRITE (*,"(/' The benchmarks listed in this input file have velocities expressed in more')") WRITE (*,"( ' than one reference frame. No single rotation-rate added by this program')") WRITE (*,"( ' could bring them into a common reference frame! No single reference-frame')") WRITE (*,"( ' label could describe the result of this operation. If you continue with')") WRITE (*,"( ' this processing, the results may be SERIOUSLY MISLEADING!')") WRITE (*,"(/' What you probably should do is:')") WRITE (*,"( ' (1) Terminate ReframeGPS at this point.')") WRITE (*,"( ' (2) Divide your .gps file into several files, according to existing frame.')") WRITE (*,"( ' (3) Run ReframeGPS on each files separately, specifying the rotation')") WRITE (*,"( ' needed to bring it to a common desired frame.')") WRITE (*,"( ' (4) Merge these new .gps files AFTER processing by ReframeGPS.')") WRITE (*,"(/' However, if you are sure that you know what you are doing, you may choose')") WRITE (*,"( ' to proceed. This might be appropriate if the reference-frame labels differ')") WRITE (*,"( ' only because of omissions or because of careless typing or misalignment.')") WRITE (*,"( ' ')") CALL Prompt_for_Logical("Do you wish to proceed with ReframeGPS?",.FALSE.,proceed_anyway) IF (.NOT.proceed_anyway) STOP ELSE IF ((first_frame == "FI").OR.(first_frame == "fi")) THEN WRITE (*, "(' ERROR: Velocity vectors that are labelled ""FI"" (Frame-Independent),')") WRITE (*, "(' such as differential .gps datasets produced by utility program GPS_Change,')") WRITE (*, "(' may NOT be Reframed. That would falsify the data!')") CALL Pause() STOP ELSE WRITE (*,"(/' All benchmark velocities are expressed in reference frame:'/' ',A)") TRIM(first_frame) END IF WRITE (*,"(/' Enter radius of the planet, in km: '\)") READ (*,*) R_km R_m = R_km * 1000.0 WRITE (*, *) CALL Prompt_for_Logical("Do you know the Euler pole for the global rotation that you wish& & to add to all benchmark velocities?", .TRUE., got_Euler) WRITE (*, *) IF (got_Euler) THEN !------------------ begin direct method for getting Euler pole ----------------------------- CALL Prompt_for_Real("Pole latitude in degrees North?", 0.0D0, pole_latitude) CALL Prompt_for_Real("Pole longitude in degrees East?", 0.0D0, pole_longitude) CALL DLonLat_2_Uvec(pole_longitude, pole_latitude, Euler_uvec) CALL Prompt_for_Real("Rotation rate in degree/Ma (counterclockwise is +)?", 0.0D0, Euler_rate_degpMa) Euler_rate_rps = Euler_rate_degpMa / (degrees_per_radian * 3.15576D13) Euler_vector = Euler_uvec * Euler_rate_rps !-------------------- end direct method for getting Euler pole ----------------------------- ELSE ! .NOT. got_Euler !------------------ begin 2-point method for getting Euler pole ----------------------------- WRITE (*,"(/' Please enter data regarding LOCATION #1:')") WRITE (*,"( ' Longitude (degrees East): '\)") READ (*,*) longitude1 210 WRITE (*,"( ' Latitude (degrees North): '\)") READ (*,*) latitude1 IF (ABS(latitude1) >= 90.0D0) THEN WRITE (*,"(' ERROR: ABS(latitude) must be less than 90. Try again...')") GO TO 210 END IF WRITE (*,"( ' Add how much Northward velocity (mm/year)?: '\)") READ (*,*) vN_add_1_mmpa WRITE (*,"( ' Add how much Eastward velocity (mm/year)?: '\)") READ (*,*) vE_add_1_mmpa CALL DLonLat_2_Uvec (longitude1, latitude1, site1) CALL DLocal_Theta (site1, unit_theta) CALL DLocal_Phi (site1, unit_phi) v_add_1_SI = 3.1688D-11 * (-vN_add_1_mmpa * unit_theta + vE_add_1_mmpa * unit_phi) v_add_1_scalar_SI = DLength (v_add_1_SI) WRITE (*,"(/' Please enter data regarding LOCATION #2:')") WRITE (*,"( ' Longitude (degrees East): '\)") READ (*,*) longitude2 220 WRITE (*,"( ' Latitude (degrees North): '\)") READ (*,*) latitude2 IF (ABS(latitude1) >= 90.0D0) THEN WRITE (*,"(' ERROR: ABS(latitude) must be less than 90. Try again...')") GO TO 220 END IF WRITE (*,"( ' Add how much Northward velocity (mm/year)?: '\)") READ (*,*) vN_add_2_mmpa WRITE (*,"( ' Add how much Eastward velocity (mm/year)?: '\)") READ (*,*) vE_add_2_mmpa CALL DLonLat_2_Uvec (longitude2, latitude2, site2) CALL DLocal_Theta (site2, unit_theta) CALL DLocal_Phi (site2, unit_phi) v_add_2_SI = 3.1688D-11 * (-vN_add_2_mmpa * unit_theta + vE_add_2_mmpa * unit_phi) v_add_2_scalar_SI = DLength (v_add_2_SI) IF ((v_add_1_scalar_SI <= 0.0D0).AND.(v_add_2_scalar_SI <= 0.0D0)) STOP !NOTE: Finding the Euler pole is a problem with 3 DOF trying to satisfy 4 data. ! Different solution methods are NOT equivalent. ! One obvious method (taking cross-product of velocity corrections) ! was found to be extremely unstable, leading to wild pole-position and rate errors. !midpoint of sites: tvec = site1 + site2 CALL DMake_Uvec (tvec, midpoint_uvec) !mean vorticity about this site: CALL DCross (midpoint_uvec, site1, around1) ! length = sin(distance), points horizontal and ccw about midpoint CALL DMake_Uvec (around1, around1_uvec) ! length = 1, points " " " " twist_1_rps = DDot (around1_uvec, v_add_1_SI) / (DLength(around1) * R_m) CALL DCross (midpoint_uvec, site2, around2) CALL DMake_Uvec (around2, around2_uvec) twist_2_rps = DDot (around2_uvec, v_add_2_SI) / (DLength(around2) * R_m) midpoint_rps = 0.5D0 * (twist_1_rps + twist_2_rps) !average (non-rotational) correction velocity, at midpoint: v_add_mean_SI = 0.5D0 * (v_add_1_SI + v_add_2_SI) !small correction: make mean velocity exactly horizontal: t = DDot (v_add_mean_SI, midpoint_uvec) v_add_mean_SI = v_add_mean_SI - t * midpoint_uvec !find component pole 90 degrees from midpoint which will yield average (non-rot.) correction velocity: CALL DCross (midpoint_uvec, v_add_mean_SI, tvec) ! note: 2 factors are already orthogonal, so tvec has length = length(v_add_mean_SI) ortho_pole_vector = tvec / R_m Euler_vector = ortho_pole_vector + midpoint_rps * midpoint_uvec !-------------------- end 2-point method for getting Euler pole ----------------------------- END IF ! got_Euler, or .NOT. ! NOTE: By either branch, preceding code must have defined the value of ! Euler_vector, which is expressed by 3 Cartesian components ! in units of radians per second, with counterclockwise rotation !(as seen from outside the Earth) considered positive. CALL DMake_Uvec (Euler_vector, Euler_uvec) CALL DUvec_2_LonLat (Euler_uvec, pole_longitude, pole_latitude) WRITE (*,"(/' Euler pole longitude (deg. E) = ', F9.4)") pole_longitude WRITE (*,"( ' Euler pole latitude (deg. N) = ', F9.4)") pole_latitude Euler_rate_rps = DLength (Euler_vector) Euler_rate_degpMa = Euler_rate_rps * degrees_per_radian * 3.15576D13 WRITE (*,"( ' Euler pole rate (deg./Ma) = ', F9.4)") Euler_rate_degpMa CALL Pause() OPEN (UNIT = 1, STATUS = "OLD", FILE = in_file_name, PAD = "YES") WRITE (*,"(/' Enter name for (new) .gps file with reframed geodetic velocities:')") READ (*,"(A)") out_file_name OPEN (UNIT = 2, FILE = out_file_name) ! unconditional OPEN, overwrites any old file WRITE (*,"(/' Enter revised title-and-source line for modified .gps file:')") READ (*,"(A)") title_line WRITE (*, *) CALL Prompt_for_String("What tag [left-justified, and limited to 15 characters]& & should be used to describe the new velocity reference frame?", & &" ", new_frame) READ (1, *) !to get past old title line WRITE (2,"(A)") TRIM(title_line) READ (1,"(A)") gps_format WRITE (2,"(A)") TRIM(gps_format) READ (1,"(A)") headers WRITE (2,"(A)") TRIM(headers) DO READ (1, gps_format, IOSTAT = ios) E_lon_deg, N_lat_deg, & & vE_mmpa, vN_mmpa, & & vE_sigma, vN_sigma, & & correlation, & & reference_frame, & & identifier IF (ios /= 0) EXIT CALL DLonLat_2_Uvec (E_lon_deg, N_lat_deg, benchmark_uvec) benchmark_radius_m = benchmark_uvec * R_m CALL DCross (Euler_vector, benchmark_radius_m, velocity_correction_SI) CALL DLocal_Theta (benchmark_uvec, unit_theta) CALL DLocal_Phi (benchmark_uvec, unit_phi) vN_add_SI = -DDot (velocity_correction_SI, unit_theta) vE_add_SI = DDot (velocity_correction_SI, unit_phi) vN_add_mmpa = vN_add_SI * 1000.0 * 3.15576D7 vE_add_mmpa = vE_add_SI * 1000.0 * 3.15576D7 vN_mmpa = vN_mmpa + vN_add_mmpa ! <===== changed !!! vE_mmpa = vE_mmpa + vE_add_mmpa ! <===== changed !!! WRITE(2, gps_format, IOSTAT = ios) E_lon_deg, N_lat_deg, & & vE_mmpa, vN_mmpa, & ! <===== changed !!! & vE_sigma, vN_sigma, & & correlation, & & new_frame, & ! <===== changed !!! & identifier END DO CLOSE (1) CLOSE (2) WRITE (*,"(/' Job completed.')") CALL Pause() CONTAINS CHARACTER*10 FUNCTION ASCII10(x) ! Returns a right-justified 10-byte (or shorter) version of a ! floating-point number, in "human" format, with no more ! than 4 significant digits. IMPLICIT NONE REAL*8, INTENT(IN) :: x CHARACTER*10 :: temp10 CHARACTER*20 :: temp20 INTEGER :: j, k1, k10, zeros LOGICAL :: punt REAL*8 :: x_log, y IF (x == 0.0D0) THEN ASCII10=' 0' RETURN ELSE IF (x > 0.0D0) THEN punt = (x >= 999999999.5D0).OR.(x < 0.0000100D0) ELSE ! x < 0.0 punt = (x <= -99999999.5D0).OR.(x > -0.000100D0) END IF IF (punt) THEN ! need exponential notation; use Fortran utility WRITE (temp10, '(1P, E10.3)') x !consider possible improvements, from left to right: IF (temp10(3:6) == '.000') THEN ! right-shift 4 spaces over it temp20(7:10) = temp10(7:10) temp20(5:6) = temp10(1:2) temp20(1:4) = ' ' temp10 = temp20(1:10) ELSE IF (temp10(5:6) == '00') THEN ! right-shift 2 spaces over it temp20(7:10) = temp10(7:10) temp20(3:6) = temp10(1:4) temp20(1:2) = ' ' temp10 = temp20(1:10) ELSE IF (temp10(6:6) == '0') THEN ! right-shift 1 space over it temp20(7:10) = temp10(7:10) temp20(2:6) = temp10(1:5) temp20(1:1) = ' ' temp10 = temp20(1:10) END IF IF (temp10(8:8) == '+') THEN ! right-shift over + sign in exponent temp20(9:10) = temp10(9:10) temp20(2:8) = temp10(1:7) temp20(1:1) = ' ' temp10 = temp20(1:10) END IF IF (temp10(9:9) == '0') THEN ! right-shift over leading 0 in exponent temp20(10:10) = temp10(10:10) temp20(2:9) = temp10(1:8) temp20(1:1) = ' ' temp10 = temp20(1:10) END IF ASCII10 = temp10 ELSE ! can represent without exponential notation x_log = LOG10(ABS(x)) zeros = Int_Below(x_log) - 3 y = (10.D0**zeros) * NINT(ABS(x) / (10.D0**zeros)) IF (x < 0.0) y = -y WRITE (temp20,"(F20.9)") y ! byte 11 is the '.' !Avoid results like "0.7400001" due to rounding error! IF (temp20(19:20) == '01') temp20(19:20) = '00' !Find first important byte from right; change 0 -> ' ' k10 = 10 ! (if no non-0 found to right of .) right_to_left: DO j = 20, 12, -1 IF (temp20(j:j) == '0') THEN temp20(j:j) = ' ' ELSE k10 = j EXIT right_to_left END IF END DO right_to_left !put leading (-)0 before . of fractions, if it fits IF (x > 0.0) THEN IF (temp20(10:11) == ' .') temp20(10:11) = '0.' ELSE ! x < 0.0 IF (k10 <= 18) THEN IF (temp20(9:11) == ' -.') temp20(9:11) = '-0.' END IF END IF k1 = k10 - 9 ASCII10 = temp20(k1:k10) END IF ! punt, or not END FUNCTION ASCII10 INTEGER FUNCTION Int_Below (x) ! Returns integer equal to, or less than, x. ! (Note: INT() is different; always truncates toward zero.) IMPLICIT NONE REAL*8, INTENT(IN) :: x INTEGER :: i REAL*8 :: y i = INT(x) IF (x >= 0.0D0) THEN Int_Below = i ELSE ! x < 0. y = 1.0D0 * i IF (y <= x) THEN Int_Below = i ELSE ! most commonly Int_Below = i - 1 END IF END IF END FUNCTION Int_Below SUBROUTINE Pause() IMPLICIT NONE WRITE (*,"(' Press [Enter]...'\)") READ (*,*) END SUBROUTINE Pause 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 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 READ (*,"(A)") inbyte IF (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*8, INTENT(IN) :: default REAL*8, INTENT(OUT) :: answer CHARACTER*11 :: instring, suggested INTEGER :: blank_at, bytes, ios, point, written LOGICAL :: finished REAL*8 :: trial !------------------------------------------------------------------------------------ !This code worked (provided 4 significant digits), but left unecessary trailing zeros ("20.00"; "6.000E+07") !IF (((ABS(default) >= 0.1).AND.(ABS(default) < 1000.)).OR.(default == 0.0)) THEN ! ! Provide 4 significant digits by using Gxx.4 (the suffix shows significant digits, NOT digits after the decimal point!) ! WRITE (suggested,"(G11.4)") default !ELSE ! ! Use 1P,E because it avoids wasted and irritating leading 0 ("0.123E+4"). ! WRITE (suggested,"(1P,E11.3)") default !END IF !------------------------------------------------------------------------------------ !So I replaced it with the following: !(1) Use ASCII10 to get 4 significant digits (but no unecessary trailing zeroes): suggested = ASCII10(default) !(2) Be sure that the number contains some sign that it is floating-point, not integer: IF (INDEX(suggested, '.') == 0) THEN IF ((INDEX(suggested, 'E') == 0).AND.(INDEX(suggested, 'e') == 0).AND. & & (INDEX(suggested, 'D') == 0).AND.(INDEX(suggested, 'd') == 0)) THEN suggested = ADJUSTL(suggested) point = LEN_TRIM(suggested) + 1 suggested(point:point) = '.' END IF 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 READ (*,"(A)") instring IF (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". ! 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 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 (*,"(' ?: '\)") READ (*,"(A)") trial IF (LEN_TRIM(trial) == 0) THEN answer = TRIM(default) ELSE answer = TRIM(trial) END IF END SUBROUTINE Prompt_for_String END PROGRAM reframeGPS