C SccsID = "@(#)usng_get.f 1.7 07/23/04" C--------------------------------------------------------- SUBROUTINE OPEN_OUTFILE() CHARACTER*80 OUTFILE INTEGER INUNIT, OUTUNIT CHARACTER*8 RESPONSE LOGICAL IS_THERE COMMON /UNITS/INUNIT, OUTUNIT OUTUNIT = 12 OUTFILE = ' ' OUTFILE = 'usng.out' INQUIRE(FILE=OUTFILE, EXIST=IS_THERE) IF (IS_THERE .EQV. .TRUE.) THEN WRITE(6, 30) OUTFILE 30 FORMAT (/, * ' -----------------------------------------------------',/, * ' WARNING - Output file "', A8, '" already exists.',/, * ' Okay to delete (Y/N) ?') READ (5, 45) RESPONSE 45 FORMAT(A1) IF ((RESPONSE(1:1) .EQ. 'Y').OR.(RESPONSE(1:1) .EQ. 'y')) THEN OPEN(OUTUNIT, FILE=OUTFILE, STATUS='UNKNOWN', * ACCESS='SEQUENTIAL', ERR=49) ELSE WRITE(6, 46) 46 FORMAT(/, 'RUN TERMINATED', /) STOP ENDIF ELSE OPEN(OUTUNIT, FILE=OUTFILE, STATUS='NEW', * ACCESS='SEQUENTIAL', ERR=49) ENDIF GOTO 60 49 WRITE(6, 50) OUTFILE 50 FORMAT ('ERROR - Could not open Output File ', A80) STOP 60 CONTINUE RETURN END C------------------------------------------------------ SUBROUTINE BY_PROMPT CHARACTER*10 CON_TYPE CHARACTER*13 IN_LAT CHARACTER*14 IN_LON CHARACTER*2 IN_DATUM CHARACTER*25 USNG_VALUE CHARACTER*14 IN_EAST, IN_NORTH CHARACTER*2 IN_ZONE CHARACTER*4 IN_ACCURACY INTEGER PCODE CHARACTER*80 RESPONSE INTEGER INUNIT, OUTUNIT COMMON/PRECISE/PCODE COMMON /UNITS/INUNIT, OUTUNIT INUNIT = 0 OUTUNIT = 0 CALL GET_OUTFILE_STATUS() CON_TYPE = ' ' CALL GET_CON_TYPE(CON_TYPE) IN_DATUM = ' ' CALL GET_DATUM(IN_DATUM) 10 CONTINUE IN_LAT = ' ' IN_LON = ' ' USNG_VALUE = ' ' IN_EAST = ' ' IN_NORTH = ' ' IN_ZONE = ' ' IN_ACCURACY = ' ' IF (CON_TYPE .EQ. 'GP2US') THEN CALL GET_LAT(IN_LAT) CALL GET_LON(IN_LON) CALL GP_TO_US(IN_LAT, IN_LON, IN_DATUM) ELSEIF (CON_TYPE .EQ. 'US2GP') THEN CALL GET_USNG(USNG_VALUE) CALL US_TO_GP (USNG_VALUE, IN_DATUM) ELSEIF (CON_TYPE .EQ. 'UTM2US') THEN CALL GET_ZONE(IN_ZONE) CALL GET_EAST(IN_EAST) CALL GET_NORTH(IN_NORTH) CALL GET_ACCURACY(IN_ACCURACY) IF(IN_ACCURACY .EQ. 'A100') THEN PCODE = 3 ELSEIF (IN_ACCURACY .EQ. 'A10') THEN PCODE = 2 ELSE PCODE = 1 ENDIF CALL UTM_TO_US(IN_ZONE, IN_EAST, IN_NORTH, IN_DATUM) ELSEIF (CON_TYPE .EQ. 'US2UTM') THEN CALL GET_USNG(USNG_VALUE) CALL US_TO_UTM (USNG_VALUE, IN_DATUM) ENDIF WRITE(6, 100) 100 FORMAT('Run Again (y/n) ?') RESPONSE = ' ' READ (5, 110) RESPONSE 110 FORMAT(A1) IF((RESPONSE(1:1) .NE. 'Y').AND.(RESPONSE(1:1) .NE. 'y')) THEN GOTO 1000 ELSE GOTO 10 ENDIF 1000 CONTINUE IF (OUTUNIT .GT. 6) THEN WRITE(6, 5000) 5000 FORMAT(//, * ' ----------------------------------------------------',/, * ' Output File = "usng.out"', /, * ' ----------------------------------------------------',/) ENDIF CALL WAIT_FOR_INPUT() RETURN END C--------------------------------------------------------- SUBROUTINE GET_OUTFILE_STATUS() CHARACTER*8 RESPONSE RESPONSE = ' ' WRITE(6, 10) 10 FORMAT (/, *'----------------- Output FILE Option -------------------',/, *' Do you want output saved to a file (y/n) ?') READ(5, 20) RESPONSE 20 FORMAT(A1) IF ((RESPONSE(1:1) .EQ. 'Y').OR.(RESPONSE(1:1) .EQ. 'y')) THEN CALL OPEN_OUTFILE() WRITE(6, 30) 30 FORMAT("Output will be saved to file 'usng.out'",/) ELSE OUTUNIT = 0 ENDIF RETURN END C--------------------------------------------------------- SUBROUTINE GET_CON_TYPE(CON_TYPE) CHARACTER*10 CON_TYPE CHARACTER*1 RESPONSE 10 CONTINUE CON_TYPE = ' ' WRITE(6, 100) 100 FORMAT (/, *'------------- DIRECTION OF CONVERSION ------------',/, *' 1. Lat/Lon to USNG',/, *' 2. UTM to USNG',/, *' 3. USNG to Lat/Lon',/, *' 4. USNG to UTM',/, *' Q. QUIT',/, *'--------------------------------------------------',//, *'ENTER 1,2,3,4 or Q:') RESPONSE = ' ' READ(5, 200, ERR=10) RESPONSE 200 FORMAT(A1) CALL TO_UPPER(RESPONSE, 1) IF (RESPONSE .EQ. '1') THEN CON_TYPE = 'GP2US' ELSEIF (RESPONSE .EQ. '2') THEN CON_TYPE = 'UTM2US' ELSEIF (RESPONSE .EQ. '3') THEN CON_TYPE = 'US2GP' ELSEIF (RESPONSE .EQ. '4') THEN CON_TYPE = 'US2UTM' ELSEIF (RESPONSE .EQ. 'Q') THEN WRITE(6, *) 'RUN TERMINATED' STOP ELSE CALL PRINT_ERROR() GOTO 10 ENDIF RETURN END C------------------------------------------------------ SUBROUTINE GET_LAT(LAT) CHARACTER*13 LAT CHARACTER*13 RESPONSE INTEGER ERR_STATUS 10 CONTINUE LAT = ' ' ERR_STATUS=9 WRITE(6, 100) 100 FORMAT (/, *'------------- INPUT Latitude ------------',/, *'Enter Latitude:',/, *'N385322.08',//, *'NDDMMSS.nn') RESPONSE = ' ' READ(5, 200, ERR=10) RESPONSE 200 FORMAT(A13) CALL TO_UPPER(RESPONSE, 13) CALL CHECK_IN_LAT(RESPONSE, 0, ERR_STATUS) IF (ERR_STATUS .EQ. 1) THEN CALL PRINT_ERROR() GOTO 10 ELSE LAT = RESPONSE ENDIF RETURN END C------------------------------------------------------ SUBROUTINE GET_LON(LON) CHARACTER*14 LON CHARACTER*14 RESPONSE INTEGER ERR_STATUS 10 CONTINUE LON = ' ' ERR_STATUS=9 WRITE(6, 100) 100 FORMAT (/, *'------------- INPUT Longitude ------------',/, *'Enter Longitude:',/, *'W0770206.86',//, *'WDDDMMSS.nn') RESPONSE = ' ' READ(5, 200, ERR=10) RESPONSE 200 FORMAT(A14) CALL TO_UPPER(RESPONSE, 14) CALL CHECK_IN_LON(RESPONSE, 0, ERR_STATUS) IF (ERR_STATUS .EQ. 1) THEN CALL PRINT_ERROR() GOTO 10 ELSE LON = RESPONSE ENDIF RETURN END C------------------------------------------------------ SUBROUTINE GET_DATUM(DATUM) CHARACTER*2 DATUM CHARACTER*2 RESPONSE INTEGER ERR_STATUS 10 CONTINUE DATUM = ' ' ERR_STATUS=9 WRITE(6, 100) 100 FORMAT (/, *'------------- INPUT datum ------------',/, *'Enter datum:',/, *'83 or 27') RESPONSE = ' ' READ(5, 200, ERR=10) RESPONSE 200 FORMAT(A2) CALL CHECK_IN_DATUM(RESPONSE, 0, ERR_STATUS) IF (ERR_STATUS .EQ. 1) THEN CALL PRINT_ERROR() GOTO 10 ELSE DATUM = RESPONSE ENDIF RETURN END C------------------------------------------------------ SUBROUTINE GET_USNG(USNG) CHARACTER*25 USNG CHARACTER*25 RESPONSE INTEGER ERR_STATUS 10 CONTINUE USNG = ' ' ERR_STATUS=9 WRITE(6, 100) 100 FORMAT (/, *'------------- INPUT USNG ------------',/, *'Enter USNG:',/, *'18SUJ2348306479',//, *'nnAAAnnnnnnnnnn') RESPONSE = ' ' READ(5, 200, ERR=10) RESPONSE 200 FORMAT(A25) CALL TO_UPPER(RESPONSE, 25) CALL CHECK_IN_USNG(RESPONSE, 0, ERR_STATUS) IF (ERR_STATUS .EQ. 1) THEN CALL PRINT_ERROR() GOTO 10 ELSE USNG = RESPONSE ENDIF RETURN END C------------------------------------------------------ SUBROUTINE GET_EAST(EAST) CHARACTER*14 EAST CHARACTER*14 RESPONSE INTEGER ERR_STATUS 10 CONTINUE EAST = ' ' ERR_STATUS=9 WRITE(6, 100) 100 FORMAT (/, *'------------- INPUT East ------------',/, *'Enter East:',/, *'323483.2',//, *'NNNNNN.n') RESPONSE = ' ' READ(5, 200, ERR=10) RESPONSE 200 FORMAT(A14) CALL TO_UPPER(RESPONSE, 14) CALL CHECK_IN_EAST(RESPONSE, 0, ERR_STATUS) IF (ERR_STATUS .EQ. 1) THEN CALL PRINT_ERROR() GOTO 10 ELSE EAST = RESPONSE ENDIF RETURN END C------------------------------------------------------ SUBROUTINE GET_NORTH(NORTH) CHARACTER*14 NORTH CHARACTER*14 RESPONSE INTEGER ERR_STATUS 10 CONTINUE NORTH = ' ' ERR_STATUS=9 WRITE(6, 100) 100 FORMAT (/, *'------------- INPUT North ------------',/, *'Enter North:',/, *'4306479.5',//, *'NNNNNNN.n') RESPONSE = ' ' READ(5, 200, ERR=10) RESPONSE 200 FORMAT(A14) CALL TO_UPPER(RESPONSE, 14) CALL CHECK_IN_NORTH(RESPONSE, 0, ERR_STATUS) IF (ERR_STATUS .EQ. 1) THEN CALL PRINT_ERROR() GOTO 10 ELSE NORTH = RESPONSE ENDIF RETURN END C------------------------------------------------------ SUBROUTINE GET_ZONE(ZONE) CHARACTER*2 ZONE CHARACTER*2 RESPONSE INTEGER ERR_STATUS 10 CONTINUE ZONE = ' ' ERR_STATUS=9 WRITE(6, 100) 100 FORMAT (/, *'------------- INPUT Zone ------------',/, *'Enter UTM Zone:',/, *'A number between 1 and 60') RESPONSE = ' ' READ(5, 200, ERR=10) RESPONSE 200 FORMAT(A2) CALL CHECK_IN_ZONE(RESPONSE, 0, ERR_STATUS) IF (ERR_STATUS .EQ. 1) THEN CALL PRINT_ERROR() GOTO 10 ELSE ZONE = RESPONSE ENDIF RETURN END C------------------------------------------------------ SUBROUTINE GET_ACCURACY(ACCURACY) CHARACTER*4 ACCURACY CHARACTER*1 RESPONSE 10 CONTINUE ACCURACY = ' ' WRITE(6, 100) 100 FORMAT (/, *'------------- INPUT UTM Accuracy ------------',/, *' 1. Good to 1 meter',/, *' 2. Good to 10 meter',/, *' 3. Good to 100 meter',/, *'--------------------------------------------------',//, *'ENTER 1,2,or 3:') RESPONSE = ' ' READ(5, 200, ERR=10) RESPONSE 200 FORMAT(A1) CALL TO_UPPER(RESPONSE, 1) IF (RESPONSE .EQ. '1') THEN ACCURACY = 'A1' ELSEIF (RESPONSE .EQ. '2') THEN ACCURACY = 'A10' ELSEIF (RESPONSE .EQ. '3') THEN ACCURACY = 'A100' ELSE CALL PRINT_ERROR() GOTO 10 ENDIF RETURN END C------------------------------------------------------ SUBROUTINE PRINT_ERROR() WRITE(6, 10) 10 FORMAT(/, *' *********** ERROR...',/, *' ************* ERROR...',/, *' ************* ERROR...',/, *'----------------------------------------------',/, *' INVALID INPUT, Please Try Again...',/, *'----------------------------------------------',/) RETURN END C------------------------------------------------------------ SUBROUTINE PRINT_GP2US_HEADER() INTEGER INUNIT, OUTUNIT COMMON /UNITS/INUNIT, OUTUNIT WRITE(6, 11) IF (OUTUNIT .GT. 6) THEN WRITE(OUTUNIT, 11) ENDIF 11 FORMAT(/, *'Latitude Longitude Datum USNG',/, *'---------- ----------- ------ ', *'-----------------------') RETURN END C------------------------------------------------------------ SUBROUTINE PRINT_US2GP_HEADER() INTEGER INUNIT, OUTUNIT COMMON /UNITS/INUNIT, OUTUNIT WRITE(6, 11) IF (OUTUNIT .GT. 6) THEN WRITE(OUTUNIT, 11) ENDIF 11 FORMAT(/, *'USNG Latitude Longitude Datum',/, *'----------------------- ---------- ----------- -----') RETURN END C------------------------------------------------------------ SUBROUTINE PRINT_UTM2US_HEADER() INTEGER INUNIT, OUTUNIT COMMON /UNITS/INUNIT, OUTUNIT WRITE(6, 11) IF (OUTUNIT .GT. 6) THEN WRITE(OUTUNIT, 11) ENDIF 11 FORMAT(/, *'ZN East North Sigma Datum USNG',/, *'-- ------------- ------------- ------ ------ ', *'-----------------------') RETURN END C------------------------------------------------------------ SUBROUTINE PRINT_US2UTM_HEADER() INTEGER INUNIT, OUTUNIT COMMON /UNITS/INUNIT, OUTUNIT WRITE(6, 11) IF (OUTUNIT .GT. 6) THEN WRITE(OUTUNIT, 11) ENDIF 11 FORMAT(/, *'USNG ZN East North Sigma ', *'Datum',/, *'----------------------- -- ---------- ----------- ------ ', *'------') RETURN END C------------------------------------------------------- SUBROUTINE PRINT_VERSION() CHARACTER*5 VERSION VERSION = '2.1' WRITE(6, 10) VERSION 10 FORMAT (/, *'--------------------------------------------------------',/, *' NATIONAL GEODETIC SURVEY',/, *' U.S. National Grid Conversion Program',/, *' usng',/, *' Version ', A5,/, *' ',/, *' Converts Geodetic Latitude, Longitude or UTM', /, *' to U.S National Grid and vice versa.', /, *' ',/, *' EMail Author = Craig.Larrimore@noaa.gov',/, *' Documentation = usng.doc',/, *' ',/, *'--------------------------------------------------------') CALL WAIT_FOR_INPUT() RETURN END C---------------------------------------------------------- SUBROUTINE WAIT_FOR_INPUT() CHARACTER*8 RESPONSE WRITE(6, 10) 10 FORMAT (/,'Press RETURN to continue...') READ(5, 20) RESPONSE 20 FORMAT(A80) RETURN END C--------------------------------------------------------- SUBROUTINE PRINT_DISCLAIMER() WRITE(6, 10) 10 FORMAT (/, *' DISCLAIMER ',/, *' ',/, *'This program and supporting information is', *' furnished by the government of',/, *'the United States of America, and is ', *'accepted/used by the recipient with',/, *'the understanding that the U. S. government', *' makes no warranties, express or',/, *'implied, concerning the accuracy, completeness,', *' reliability, or suitability',/, *'of this program, of its constituent parts,', *' or of any supporting data.',/, *' ',/, *'The government of the United States of America', *' shall be under no liability ',/, *'whatsoever resulting from any use of this program.', *' This program should',/, *'not be relied upon as the sole basis for solving', *' a problem whose incorrect',/, *'solution could result in injury to person', *' or property.',/, *' ',/, *'This program is the property of the government', *' of the United States of',/, *'America. Therefore, the recipient further agrees', *' not to assert proprietary',/, *'rights therein and not to represent this program', *' to anyone as being other',/, *'than a government program.') CALL WAIT_FOR_INPUT() RETURN END