PROGRAM Scale_DIG ! ! Reads a .dig file and applies constant scale factors ! to both x and y coordinates, and then adds constants to x and y, ! and finally writes a revised .dig file. ! ! by Peter Bird ! Department Earth, Planetary, and Space Sciences ! University of California ! Los Angeles, CA 90095-1567 ! pbird@epss.ucla.edu ! May 2001; slightly revised March 2019 ! !(c) Copyright 2001, 2019 by Peter Bird and the Regents ! of the University of California. ! IMPLICIT NONE CHARACTER*80 :: input_file_name, line, output_file_name, suggestion INTEGER :: dot_place, i, ios INTEGER :: mt_flashby_count = 1, mt_flashby_limit = 100 ! for Prompt_for_ routines LOGICAL :: do_another, includes_TF, more_dig LOGICAL :: mt_flashby = .FALSE. ! for Prompt_for routines REAL :: x, x_addon, x_factor, y, y_addon, y_factor WRITE (*,"(//' ----------------------------------------------------------------------'& &/' Scale_DIG'& &/' Reads a .dig file and applies constant scale factors'& &/' to both x and y, and then adds constants to x and y,'& &/' and finally writes a revised .dig file.'& &/' by Peter Bird, UCLA, 2001 & 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:'& &/' |F0469N | <- a title line (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 *** |<- end marker (first *** required)'& &/' |F0453N |<- title of next polyline (optional)'& &/' | -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: Optional. Use 0, 1, 2, ...? lines to label your'& &/' polylines. (This allows for personal codes in which symbols, text'& &/' or other information about the location might be embedded in the '& &/' title lines.) Title lines are simply passed unchanged to converted'& &/' .dig files. They do not usually appear in the .ai map files.'& &/' Number formats: Column 1 blank. Column 2 holds sign. Columns 3~13'& &/' hold the first real number, preferably in scientific notation.'& &/' Column 14 is a comma. Column 15 is a sign. Columns 16~26 hold'& &/' the second real number. 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 -.'& &/' (x,y) data can be in units of meters, kilometers, centimeters, miles,'& &/' or feet. However, it MUST give the actual sizes of features on'& &/' the planet, NOT their reduced sizes on some map! Any origin and'& &/' any orientation of the (x,y) system is permissible, as long as'& &/' the +y axis is 90 degrees counterclockwise from the +x axis.'& &/' ----------------------------------------------------------------------')") 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 (*,"(/' Here are some initial lines from your .dig file:')") WRITE (*,"(' -------------------------------------------------')") DO i = 1, 12 READ (1, "(A)", IOSTAT = ios) line IF (ios /= 0) EXIT WRITE (*,"(' ',A)") TRIM(line) END DO WRITE (*,"(' -------------------------------------------------')") CLOSE(1) WRITE (*,"(' Please take note of the units of your data!'/)") !- - - - - - - - PROMPT FOR CONVERSION - - - - - - - - - - CALL Prompt_for_Real('What factor shall be applied to x values?', 1.0, x_factor) CALL Prompt_for_Real('What factor shall be applied to y values?', 1.0, y_factor) WRITE (*,"(' Then, after multiplication...')") CALL Prompt_for_Real('What constant shall be added to x values?', 0.0, x_addon) CALL Prompt_for_Real('What constant shall be added to y values?', 0.0, y_addon) !- - - - - - - - DO CONVERSION - - - - - - - - - - - - - - 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)//'_fixed.dig' ELSE ! input_file_name does not include .dig or .DIG suggestion = TRIM(ADJUSTL(input_file_name))//'_fixed.dig' END IF 500 CALL Prompt_for_String('What filename shall be used for the revised output file?',TRIM(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 getting_xy: DO READ (1, "(A)", IOSTAT = ios) line IF (ios == -1) EXIT getting_xy ! end of input file !Test for 'T', 't', 'F', 'f' in the line; !when one of these begins a word, list-directed input !processing treats it as .TRUE. or .FALSE. and converts !this value to 1.0 or 0.0, causing mis-alignment of !data and/or ficticious data points. For example, !the title line "TX" was read as .TRUE., converted to REAL !1.0, and assigned to the longitude, and then the !first number of the next line was read for the latitude! !Another time, the title line " 129 Tonga-1" was !interpreted as (+129.00E, +1.00N), causing an unwanted !great-circle arc to that point! includes_TF = ((SCAN(line,'T') > 0).AND.(SCAN(line,'T') < 25)).OR. & & ((SCAN(line,'t') > 0).AND.(SCAN(line,'t') < 25)).OR. & & ((SCAN(line,'F') > 0).AND.(SCAN(line,'F') < 25)).OR. & & ((SCAN(line,'f') > 0).AND.(SCAN(line,'f') < 25)) IF (includes_TF) THEN ! this is always a title line WRITE (2,"(A)") TRIM(line) ELSE ! may still be a title line (without T,F) or an *** (end) READ (line, *, IOSTAT = ios) x, y IF (ios == 0) THEN ! line had 2 numbers x = x * x_factor y = y * y_factor x = x + x_addon y = y + y_addon WRITE (2,"(1X, SP, ES12.5, ',', ES12.5)") x, y ELSE ! line was a title or *** (end) WRITE (2,"(A)") TRIM(line) END IF END IF END DO getting_xy CLOSE(1) CLOSE(2) WRITE (*,"(/' Converted file has been written.'/)") ! - - - - - POSSIBLE LOOP FOR MORE THAN ONE .dig FILE - - - - - - - - - WRITE (*,"(' ')") CALL Prompt_for_Logical('Do you want to process another .dig file?', .FALSE., do_another) IF (do_another) GO TO 100 CONTAINS 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 Scale_dig