C SccsID = "@(#)utms.f 1.6 01/27/05 /ngslib/source/Utms/SCCS/s.utms.f" PROGRAM UTMS * * THIS PROGRAM CONVERTS GPS TO UNIVERSIAL TRANSVERSE MERACTOR COORDINATES * AND VICE VERSA FOR THE NAD27 AND NAD83 DATUM. * THIS PROGRAM WAS WRITTEN BY E. CARLSON * SUBROUTINES TMGRID, TCONST, TMGEOD, TCONPC, * WERE WRITTEN BY T. VINCENTY, NGS, IN JULY 1984 . * THE ORGINAL PROGRAM WAS WRITTEN IN SEPTEMBER OF 1988. * * THIS PROGRAM WAS UPDATED ON FEBUARY 16, 1989. THE UPDATE WAS * HAVING THE OPTION OF SAVING AND *81* RECORD FILE. * * * THIS PROGRAM WAS UPDATED ON APRIL 3, 1990. THE FOLLOWING UPDATE * WERE MADE: * 1. CHANGE FROM JUST A CHOICE OF NAD27 OF NAD83 REFERENCE * ELLIPSOIDS TO; CLARKE 1866, GRS80/WGS84, INTERNATIONAL, AND * ALLOW FOR USER DEFINED OTHER. * 2. ALLOW USE OF LATITUDES IN SOUTHERN HEMISPHERE AND LONGITUDES * UP TO 360 DEGREES WEST. * * THIS PROGRAM WAS UPDATED ON DECEMBER 1, 1993. THE FOLLOWING UPDATE * WAS MADE: * 1. THE NORTHINGS WOULD COMPUTE THE RIGHT LATITUDE IN THE SOUTHERN * HEMISHPERE. * 2. THE COMPUTED LATITUDE ON LONGIDUTES WOULD BE EITHER IN E OR W. * ***************************************************************** * * DISCLAIMER * * * * THIS PROGRAM AND SUPPORTING INFORMATION IS FURNISHED BY THE * * GOVERNMENT OF THE UNITED STATES OF AMERICA, AND IS ACCEPTED AND * * USED BY THE RECIPIENT WITH THE UNDERSTANDING THAT THE UNITED STATES * * 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 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. * * * *********************************************************************** IMPLICIT DOUBLE PRECISION(A-H,O-Z) CHARACTER*1 YN,DATNUM,DATUM COMMON/CONST/RAD,ER,RF,ESQ,PI COMMON/DATUM/DATNUM PI=4.D0*DATAN(1.D0) RAD=180.D0/PI PRINT *, ' *** PROGRAM UTMS *****' PRINT *, ' ' PRINT *, ' WRITTEN ON 09/23/88 ' PRINT *, ' UPDATED ON 04/03/90 ' PRINT *, ' UPDATED ON 12/01/93 ' PRINT *, ' UPDATED ON 01/27/05 ' PRINT *, ' ' 5 WRITE(6,10) 10 FORMAT(' DO YOU WANT TO COMPUTE:',//, & ' 1 GEODETIC POSITIONS TO UTM COORDINATES',/, & ' 2 UTM COORDINATES TO GEODETIC POSITIONS'/, & ' 3 PRINT THE OUTPUT FILE ON THE PRINTER'//, & ' TYPE NUMBER',/) READ(5,15) INUM 15 FORMAT(I1) IF(INUM.EQ.3) THEN CALL LSTFTN WRITE(6,16) READ(5,21) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN CLOSE(2,STATUS='KEEP') GO TO 5 ELSE GO TO 25 ENDIF ENDIF **** **** CALL DATUMM(ER,RF,F,ESQ,DATNUM) *** *** USE THE NUM TO DO THE CORRECT FUNCTION IF(INUM.EQ.1) THEN CALL GPUT83 WRITE(6,16) 16 FORMAT('0 DO YOU WANT TO GO TO ANOTHER',/, & ' FUNCTION (Y/N)',//, & ' TYPE ANSWER',/) READ(5,21) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN CLOSE(2,STATUS='KEEP') GO TO 5 ELSE GO TO 25 ENDIF ELSEIF(INUM.EQ.2) THEN CALL UTGP83 WRITE(6,16) READ(5,21) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN CLOSE(2,STATUS='KEEP') GO TO 5 ELSE GO TO 25 ENDIF ELSE WRITE(6,20) 20 FORMAT('0 YOU ENTERED A WRONG NUMBER'/, & ' DO WANT TO TRY AGAIN (Y/N)',//, & ' TYPE ANSWER',/) READ(5,21) YN 21 FORMAT(A1) IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN GO TO 5 ENDIF ENDIF 25 WRITE(6,30) 30 FORMAT('0END OF PROGRAM UMTS ') STOP END ******************************************************************** SUBROUTINE UTGP83 * *********************************************************************** IMPLICIT DOUBLE PRECISION(A-H,O-Z) CHARACTER*1 YN COMMON/CONST/RAD,ER,RF,ESQ,PI WRITE(6,10) 10 FORMAT('0*** ROUTINE UTMs TO GP ***'//, * ' DO YOU WANT TO RUN INTERACTIVELY (Y/N)?',/, * ' TYPE ANSWER',/) READ(5,20) YN 20 FORMAT(A1) IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN CALL IUTPC ELSE CALL BUTPC ENDIF WRITE(6,30) 30 FORMAT('0END OF ROUTINE UTMs TO GP') RETURN END ***************************************************************** SUBROUTINE GPUT83 * *********************************************************************** IMPLICIT DOUBLE PRECISION(A-H,O-Z) CHARACTER*1 YN COMMON/CONST/RAD,ER,RF,ESQ,PI WRITE(6,10) 10 FORMAT('0*** ROUTINE GPs TO UTMs ***'//, * ' DO YOU WANT TO RUN INTERACTIVELY (Y/N)?',/, * ' TYPE ANSWER:',/) READ(5,20) YN 20 FORMAT(A1) IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN CALL IUTGP ELSE CALL BUTGP ENDIF WRITE(6,30) 30 FORMAT('0END OF ROUTINE GPs TO UTMs') RETURN END ****************************************************************** SUBROUTINE BUTPC *************************************************************** IMPLICIT REAL*8 (A-H,O-Z) CHARACTER*30 GPPFIL,PCFIL,GPFIL CHARACTER*80 CARDR CHARACTER*1 ANS,YN CHARACTER*1 DATUM,DATNUM LOGICAL FILFLAG,FILPRT REAL*8 NORTH COMMON/XY/NORTH,EAST COMMON/FILES/I3,I4,I2,ICON COMMON/DATUM/DATNUM FILFLAG=.TRUE. FILPRT=.FALSE. ICON=0 5 WRITE(6,10) 10 FORMAT('0NAME OF INPUT BLUEBOOK FILE WITH *81* RECORDS- ') READ(5,20) PCFIL 20 FORMAT(A30) OPEN(2,STATUS='OLD',FILE=PCFIL,ERR=900) GO TO 25 900 WRITE(6,901) 901 FORMAT('0 FILE DOES NOT EXISTS, DO YOU WANT TO',/, & ' TRY AGAIN (Y/N)',/, & ' TYPE ANSWER',/) READ(5,902) YN 902 FORMAT(A1) IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN GO TO 5 ELSE GO TO 99 ENDIF 25 WRITE(6,30) 30 FORMAT('0NAME OF BLUEBOOK OUTPUT FILE WITH *80* RECORDS- ') READ(5,20) GPFIL OPEN(3,STATUS='NEW',FILE=GPFIL,ERR=910) GO TO 400 910 WRITE(6,911) 911 FORMAT('0 FILE ALREADY EXIST, DO YOU WANT TO',/, & ' WRITE OVER IT (Y/N)',/, & ' TYPE ANSWER :',/) READ(5,902) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN OPEN(3,STATUS='UNKNOWN',FILE=PCFIL) ELSE GO TO 25 ENDIF 400 WRITE(6,31) 31 FORMAT(' DO YOU WANT THE OUTPUT LISTING SAVED ON A FILE (Y/N)'/) READ(5,32) ANS 32 FORMAT(A1) IF ((ANS.EQ.'Y').OR.(ANS.EQ.'y')) THEN FILPRT=.TRUE. 401 WRITE(6,33) 33 FORMAT('0 FILE NAME:') READ(5,34) GPPFIL 34 FORMAT(A30) OPEN(4,STATUS='NEW',FILE=GPPFIL,ERR=920) GO TO 405 920 WRITE(6,911) READ(5,902) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN OPEN(4,STATUS='UNKNOWN',FILE=GPPFIL) ELSE GO TO 401 ENDIF 405 CALL HDUTPC ENDIF 40 READ(2,45,END=99) CARDR 45 FORMAT(A80) IF(CARDR(7:10).EQ.'*81*') THEN IF(DATNUM.NE.'2') THEN READ(CARDR,50,ERR=9000) EAST,NORTH,ICODE 50 FORMAT(T45,F10.3,T55,F11.3,T66,I4) GO TO 51 ENDIF IF(DATNUM.EQ.'2') THEN READ(CARDR,52,ERR=9000) NORTH,EAST,ICODE 52 FORMAT(T45,F11.3,T56,F10.3,T66,I4) GO TO 51 ENDIF 51 CALL DRUTGP(CARDR,ICODE,FILFLAG,FILPRT) GO TO 40 ELSE WRITE(3,45) CARDR GO TO 40 ENDIF GO TO 99 9000 WRITE(6,9001) CARDR 9001 FORMAT('0 ERROR IN BLUE BOOK INPUT RECORD',/,A80) 99 RETURN END *********************************************************** SUBROUTINE BUTGP ********************************************************** IMPLICIT REAL*8 (A-H,O-Z) CHARACTER*5 GGVAL,GDVAL CHARACTER*8 TITLE,GNUM DIMENSION GDNUM(1001),GDVAL(1001) CHARACTER*30 NAME,PCFIL,GPFIL,FIL81 CHARACTER*80 CARDR CHARACTER*1 YN LOGICAL FILFLAG LOGICAL FIL81FL COMMON/LATLON/LD,LM,SLAT,LOD,LOM,SLON COMMON/FILES/I3,I4,I2,ICON COMMON/IPRINT/IPRT COMMON/DONUM/ISN COMMON/GEODS/GDVAL,GDNUM COMMON/TITLE/GNUM FILFLAG=.FALSE. FIL81FL=.FALSE. ICON = 0 ISN = 0 5 WRITE(6,10) 10 FORMAT(' NAME OF INPUT FILE OF *80* RECORDS - ') READ(5,20) GPFIL 20 FORMAT(A30) OPEN(2,STATUS='OLD',FILE=GPFIL,ERR=900) GO TO 25 900 WRITE(6,901) 901 FORMAT(' FILE DOES NOT EXITS, DO YOU WANT TO',/, & ' TRY AGAIN (Y/N)'/, & ' TYPE ANSWER',/) READ(5,902) YN 902 FORMAT(A1) IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN GO TO 5 ELSE GO TO 99 ENDIF 25 PRINT *,' DO YOU WANT THE OUTPUT LISTING SAVED ON A FILE (Y/N) ' READ(*,902) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN 27 WRITE(6,30) 30 FORMAT(' FILE NAME -') READ(5,20) PCFIL OPEN(3,STATUS='NEW',FILE=PCFIL,ERR=910) FILFLAG = .TRUE. GO TO 400 910 WRITE(6,911) 911 FORMAT(' FILE ALREADY EXIST, DO YOU WANT TO',/, & ' WRITE OVER IT (Y/N)',/, & ' TYPE ANSWER :',/) READ(5,902) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN OPEN(3,STATUS='UNKNOWN',FILE=PCFIL) FILFLAG = .TRUE. ELSE GO TO 27 ENDIF 400 PRINT *,' ' PRINT *,' ' PRINT *,' THE TYPE OF COORDINATE LISING : ' PRINT *,' ' PRINT *,' 1 - PRELIMINARY (BEFORE FINAL ADJUSTMENT)' PRINT *,' 2 - FINAL (AFTER A COMPLETED PROJECT)' PRINT *,' ' PRINT *,' TYPE NUMBER: ' READ(5,FMT='(I1)') IPRT PRINT *,' ' PRINT *,' ' PRINT *,' TYPE THE PROJECT NUMBER IE; G-12345 OR' PRINT *,' GPS-1234 (8 CHARACTERS MAX) ' PRINT *,' ' PRINT *, ' TYPE THE NUMBER : ' READ(5,FMT='(A8)') GNUM ENDIF *** ** FIND THE NAME OF THE *81* RECORD FILE IF WANTED ** 250 WRITE(6,310) 310 FORMAT(' DO YOU WANT TO SAVED AN *81* RECORD FILE (Y/N)? ') READ(5,902)YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN 325 WRITE(6,330) 330 FORMAT(' FILE NAME:') READ(5,20) FIL81 OPEN(4,STATUS='NEW',FILE=FIL81,ERR=800) FIL81FL=.TRUE. ENDIF GO TO 326 800 WRITE(6,801) 801 FORMAT(' FILE ALREADY EXIST, DO YOU WANT TO',/, & ' WRITE OVER IT (Y/N)',/, & ' TYPE ANSWER ',/) READ(5,902) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN OPEN(4,STATUS='UNKNOWN',FILE=FIL81) FIL81FL=.TRUE. ELSE GO TO 325 ENDIF 326 PRINT *,' ' PRINT *,' ' PRINT *, ' PROGRAM IS EXCUTING NOW !!!!!!! ' PRINT *,' ' PRINT *,' ' IF(FILFLAG) THEN CALL HDUTGP ENDIF *** READ INPUT FILE AND SET ARRAYS FOR THE GEOD HTS 100 READ(2,45,END=199) CARDR IF(CARDR(7:10).EQ.'*84*') THEN ISN = ISN + 1 GGVAL=' ' READ(CARDR,FMT='(T11,I3)') IGDNUM READ(CARDR,FMT='(T72,A5)') GGVAL GDNUM(ISN)= IGDNUM GDVAL(ISN)= GGVAL GO TO 100 ELSE GO TO 100 ENDIF 199 REWIND(2) 40 READ(2,45,END=99) CARDR 45 FORMAT(A80) IF(CARDR(7:10).EQ.'*80*') THEN CALL DRGPUT(CARDR,FILFLAG,FIL81FL) GO TO 40 ELSE GO TO 40 ENDIF GO TO 99 9000 WRITE(6,9001) CARDR 9001 FORMAT(' ERROR IN BLUE BOOK INPUT RECORD',/,A80) 99 RETURN END ******************************************************* SUBROUTINE HDUTGP ****************************************************** INTEGER*4 IPRT CHARACTER*1 DATNUM,DATUM CHARACTER*8 TITLE,GNUM COMMON/FILES/I3,I4,I2,ICON COMMON/IPRINT/IPRT COMMON/TITLE/GNUM COMMON/DATUM/DATNUM IF(IPRT.EQ.1) THEN WRITE(3,5) GNUM 5 FORMAT('1',/,T50,'PRELIMINARY COORDINATE LISTING ',/ , & T59,'FOR ',A8,//) ELSEIF(IPRT.EQ.2) THEN WRITE(3,6) GNUM 6 FORMAT('1',/,T54,'FINAL COORDINATE LISTING ',/, & T60,'FOR ',A8,//) ELSE WRITE(3,7) 7 FORMAT('1',//////) ENDIF IF(DATNUM.EQ.'1') THEN WRITE(3,10) 10 FORMAT(T54,'NATIONAL GEODETIC SURVEY',/, * T58,'GP TO UTMs PROGRAM',T118,'VERSION 2.1',/,T55, * 'CLARKE 1866 ELLIPSOID',//, * 1X,' STATION NAME',T34,'LATITUDE', * T50,'LONGITUDE',T68,'NORTHING(Y)',T80,'EASTING(X)', * T92,'ZONE',T97,'CONVERGENCE',T110,'SCALE',T121,'ELEV', * T129,'GEOID',/,T68,'METER', * T80,'METER',T97,'D',T100,'M',T104,'S', * T110,'FACTOR',T121,'(M)',T129,'HT(M)',//) ENDIF IF(DATNUM.EQ.'2') THEN WRITE(3,12) 12 FORMAT(T54,'NATIONAL GEODETIC SURVEY',/, * T58,'GP TO UTMs PROGRAM',T118,'VERSION 2.1',/,T56, * 'GRS80/WGS84 ELLIPSOID',//, * 1X,' STATION NAME',T34,'LATITUDE', * T50,'LONGITUDE',T68,'NORTHING(Y)',T80,'EASTING(X)', * T92,'ZONE',T97,'CONVERGENCE',T110,'SCALE',T121,'ELEV', * T129,'GEOID',/,T68,'METER', * T80,'METER',T97,'D',T100,'M',T104,'S', * T110,'FACTOR',T121,'(M)',T129,'HT(M)',//) ENDIF IF(DATNUM.EQ.'3') THEN WRITE(3,13) 13 FORMAT(T54,'NATIONAL GEODETIC SURVEY',/, * T58,'GP TO UTMs PROGRAM',T118,'VERSION 2.1',/,T53, * 'INTERNATIONAL 1910 ELLIPSOID',//, * 1X,' STATION NAME',T34,'LATITUDE', * T50,'LONGITUDE',T68,'NORTHING(Y)',T80,'EASTING(X)', * T92,'ZONE',T97,'CONVERGENCE',T110,'SCALE',T121,'ELEV', * T129,'GEOID',/,T68,'METER', * T80,'METER',T97,'D',T100,'M',T104,'S', * T110,'FACTOR',T121,'(M)',T129,'HT(M)',//) ENDIF IF(DATNUM.EQ.'4') THEN WRITE(3,14) 14 FORMAT(T54,'NATIONAL GEODETIC SURVEY',/, * T58,'GP TO UTMs PROGRAM',T118,'VERSION 2.1',/,T59, * 'WGS72 ELLIPSOID',//, * 1X,' STATION NAME',T34,'LATITUDE', * T50,'LONGITUDE',T68,'NORTHING(Y)',T80,'EASTING(X)', * T92,'ZONE',T97,'CONVERGENCE',T110,'SCALE',T121,'ELEV', * T129,'GEOID',/,T68,'METER', * T80,'METER',T97,'D',T100,'M',T104,'S', * T110,'FACTOR',T121,'(M)',T129,'HT(M)',//) ENDIF IF(DATNUM.EQ.'5') THEN WRITE(3,15) 15 FORMAT(T54,'NATIONAL GEODETIC SURVEY',/, * T58,'GP TO UTMs PROGRAM',T118,'VERSION 2.1',/,T59, * 'OTHER ELLIPSOID',//, * 1X,' STATION NAME',T34,'LATITUDE', * T50,'LONGITUDE',T68,'NORTHING(Y)',T80,'EASTING(X)', * T92,'ZONE',T97,'CONVERGENCE',T110,'SCALE',T121,'ELEV', * T129,'GEOID',/,T68,'METER', * T80,'METER',T97,'D',T100,'M',T104,'S', * T110,'FACTOR',T121,'(M)',T129,'HT(M)',//) ENDIF RETURN END ****************************************************************** SUBROUTINE HDUTPC ****************************************************************** CHARACTER*1 DATUM,DATNUM COMMON/DATUM/DATNUM IF(DATNUM.EQ.'1') THEN WRITE(4,10) 10 FORMAT('1',//,T54,'NATIONAL GEODETIC SURVEY',/,'PROGRAM UTMS ', * T56,'UTMs TO GP PROGRAM',T121,'VERSION 2.1',/,T55, * 'CLARKE 1866 ELLIPSOID',//, * 'NAME',27X,'NORTH(Y)',9X,'EAST(X)',9X, * 'LATITUDE',9X,'LONGITUDE',9X,'ZONE',T106,' CONVERGENCE', * T119,'SCALE FACTOR',/) ENDIF IF(DATNUM.EQ.'2') THEN WRITE(4,15) 15 FORMAT('1',//,T54,'NATIONAL GEODETIC SURVEY',/,'PROGRAM UTMS ', * T56,'UTMs TO GP PROGRAM',T121,'VERSION 2.1',/,T56, * 'GRS80/WGS84 ELLIPSOID',//, * 'NAME',27X,'NORTH(Y)',9X,'EAST(X)',9X, * 'LATITUDE',9X,'LONGITUDE',9X,'ZONE',T106,' CONVERGENCE', * T119,'SCALE FACTOR',/) ENDIF IF(DATNUM.EQ.'3') THEN WRITE(4,25) 25 FORMAT('1',//,T54,'NATIONAL GEODETIC SURVEY',/,'PROGRAM UTMS ', * T56,'UTMs TO GP PROGRAM',T121,'VERSION 2.1',/,T53, * 'INTERNATIONAL 1910 ELLIPSOID',//, * 'NAME',27X,'NORTH(Y)',9X,'EAST(X)',9X, * 'LATITUDE',9X,'LONGITUDE',9X,'ZONE',T106,' CONVERGENCE', * T119,'SCALE FACTOR',/) ENDIF IF(DATNUM.EQ.'4') THEN WRITE(4,35) 35 FORMAT('1',//,T54,'NATIONAL GEODETIC SURVEY',/,'PROGRAM UTMS ', * T56,'UTMs TO GP PROGRAM',T121,'VERSION 2.1',/,T59, * 'WGS72 ELLIPSOID',//, * 'NAME',27X,'NORTH(Y)',9X,'EAST(X)',9X, * 'LATITUDE',9X,'LONGITUDE',9X,'ZONE',T106,' CONVERGENCE', * T119,'SCALE FACTOR',/) ENDIF IF(DATNUM.EQ.'5') THEN WRITE(4,45) 45 FORMAT('1',//,T54,'NATIONAL GEODETIC SURVEY',/,'PROGRAM UTMS ', * T56,'UTMs TO GP PROGRAM',T121,'VERSION 2.1',/,T59, * 'OTHER ELLIPSOID',//, * 'NAME',27X,'NORTH(Y)',9X,'EAST(X)',9X, * 'LATITUDE',9X,'LONGITUDE',9X,'ZONE',T106,' CONVERGENCE', * T119,'SCALE FACTOR',/) ENDIF RETURN END ********************************************************************* SUBROUTINE IUTPC ****************************************************************** IMPLICIT REAL*8(A-H,O-Z) LOGICAL FILFLAG,FILPRT CHARACTER*1 EORW CHARACTER*1 YN CHARACTER*1 DATUM,DATNUM CHARACTER*30 NAME,GPPFIL,GPFIL CHARACTER*80 CARDR REAL*8 NORTH COMMON/XY/NORTH,EAST COMMON/DATUM/DATNUM FILFLAG=.FALSE. FILPRT=.FALSE. WRITE(6,10) 10 FORMAT(' DO YOU WANT THE OUTPUT LISTING SAVED ON A FILE (Y/N)? ') READ(5,20) YN 20 FORMAT(A1) IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN 25 WRITE(6,30) 30 FORMAT('0FILE NAME:') READ(5,40) GPPFIL 40 FORMAT(A30) OPEN(4,STATUS='NEW',FILE=GPPFIL,ERR=900) FILPRT=.TRUE. CALL HDUTPC ENDIF GO TO 950 900 WRITE(6,901) 901 FORMAT('0 FILE ALREADY EXIST, DO YOU WANT TO'/, & ' WRITE OVER IT (Y/N)',/, & ' TYPE ANSWER ',/) READ(5,20) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN OPEN(4,STATUS='UNKNOWN',FILE=GPPFIL) FILPRT=.TRUE. CALL HDUTPC ELSE GO TO 25 ENDIF 950 WRITE(6,951) 951 FORMAT('0 DO YOU WANT TO SAVE AN *80* RECORD FILE',/, & ' OUTPUT FILE (Y/N)'/, & ' TYPE ANSWER ',/) READ(5,20) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN 959 WRITE(6,960) 960 FORMAT('0 TYPE FILE NAME:',/) READ(5,40) GPFIL OPEN(3,STATUS='NEW',FILE=GPFIL,ERR=1000) FILFLAG=.TRUE. FILPRT=.TRUE. ENDIF GO TO 50 1000 WRITE(6,1001) 1001 FORMAT('0 FILE ALREADY EXISTS, DO YOU WANT TO',/, & ' WRITE OVER IT (Y/N)',/, & ' TYPE ANSWER ',/) READ(5,20) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN OPEN(3,STATUS='UNKNOWN',FILE=GPFIL) FILFLAG=.TRUE. FILPRT=.TRUE. GO TO 50 ELSE GO TO 959 ENDIF 50 WRITE(CARDR,45) 45 FORMAT(T7,'*81*') IF(FILPRT) THEN WRITE(6,52) 52 FORMAT('0ENTER STATION NAME:') READ(5,40) NAME WRITE(CARDR,41) NAME 41 FORMAT(T15,A30) ELSE NAME=' ' WRITE(CARDR,41) NAME ENDIF WRITE(6,60) 60 FORMAT('0ENTER NORTHING IN METERS:'/, * ' NNNNNNNN.NNN'/) READ(5,62) NORTH 62 FORMAT(F12.3) PRINT *, ' IS THE NORTHING IN THE SOUTHERN HEMISPHERE ?' PRINT *, ' ANSWER Y/N ' READ(*,FMT='(A1)') YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN NORTH = 20000000.D0 - NORTH ENDIF WRITE(6,64) 64 FORMAT('0ENTER EASTING IN METERS:'/, * ' EEEEEEE.EEE'/) READ(5,66)EAST 66 FORMAT(F11.3) PRINT *, ' DO YOU WANT THE LONGITUDE COORDINATES WRITTEN ' PRINT *, ' AS EAST (E) OR WEST (W) ' PRINT *, ' ANSWER E/W ' READ(*,FMT='(A1)') EORW CARDR(69:69)= EORW WRITE(6,68) 68 FORMAT('0ENTER THE UTM ZONE NUMBER ',/) READ(5,70)ICODE 70 FORMAT(I4) CALL DRUTGP(CARDR,ICODE,FILFLAG,FILPRT) WRITE(6,80) 80 FORMAT('0ANY MORE COMPUTATIONS (Y/N)? ') READ(5,20) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) GO TO 50 RETURN END ******************************************************************* SUBROUTINE IUTGP ******************************************************************* IMPLICIT REAL*8(A-H,O-Z) CHARACTER*1 YN CHARACTER*1 EORW CHARACTER*1 NORS CHARACTER*11 CLAT CHARACTER*12 CLON CHARACTER*30 NAME,PCFIL,FIL81 CHARACTER*80 CARDR LOGICAL FILFLAG LOGICAL FIL81FL FILFLAG=.FALSE. FIL81FL=.FALSE. WRITE(6,10) 10 FORMAT(' DO YOU WANT THE OUTPUT LISTING SAVED ON A FILE (Y/N)? ') READ(5,20) YN 20 FORMAT(A1) IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN 25 WRITE(6,30) 30 FORMAT('0FILE NAME:') READ(5,40) PCFIL 40 FORMAT(A30) OPEN(3,STATUS='NEW',FILE=PCFIL,ERR=900) FILFLAG=.TRUE. CALL HDUTGP ENDIF GO TO 50 900 WRITE(6,901) 901 FORMAT(' FILE ALREADY EXIST, DO YOU WANT TO',/, & ' WRITE OVER IT (Y/N)',/, & ' TYPE ANSWER ',/) READ(5,20) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN OPEN(3,STATUS='UNKNOWN',FILE=PCFIL) FILFLAG=.TRUE. CALL HDUTGP ELSE GO TO 25 ENDIF *** ** FIND THE NAME OF THE *81* RECORD FILE IF WANTED ** 50 WRITE(6,110) 110 FORMAT(' DO YOU WANT TO SAVED AN *81* RECORD FILE (Y/N)? ') READ(5,20) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN 125 WRITE(6,130) 130 FORMAT('0FILE NAME:') READ(5,40) FIL81 OPEN(4,STATUS='NEW',FILE=FIL81,ERR=800) FIL81FL=.TRUE. ENDIF GO TO 250 800 WRITE(6,801) 801 FORMAT(' FILE ALREADY EXIST, DO YOU WANT TO',/, & ' WRITE OVER IT (Y/N)',/, & ' TYPE ANSWER ',/) READ(5,20) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) THEN OPEN(4,STATUS='UNKNOWN',FILE=FIL81) FIL81FL=.TRUE. ELSE GO TO 125 ENDIF 250 IF(FILFLAG) THEN WRITE(6,52) 52 FORMAT('0ENTER STATION NAME:') READ(5,40) NAME ELSE NAME=' ' ENDIF WRITE(6,60) 60 FORMAT('0ENTER LATITUDE:'/, * ' DD MM SS.SSSSS'/) READ(*,62) LD,LM,SLAT 62 FORMAT(I2,1X,I2,1X,F8.5) PRINT *,' ' PRINT *,' DIRECTION OF LATITUDE - N OR S ' PRINT *,' TYPE N OR S NOW ' READ(5,FMT='(A1)') NORS WRITE(6,64) 64 FORMAT('0ENTER LONGITUDE:'/, * ' NOTE IF THE DEGREES ARE LESS THAN 100',/, * ' YOU MUST ENTER A ZERO FIRST',/, * ' 94 DEGREES WILL BE 094',/, * ' DDD MM SS.SSSSS'/) READ(5,66)LOD,LOM,SLON 66 FORMAT(I3,1X,I2,1X,F8.5) PRINT *,' ' PRINT *,' DIRECTION OF LONGITUDE - E OR W ' PRINT *,' TYPE E OR W NOW ' READ(*,FMT='(A1)') EORW ISEC = SLAT * 1.0D5 + 0.5D0 JSEC = SLON * 1.0D5 + 0.5D0 WRITE(CLAT,67) LD,LM,ISEC 67 FORMAT(I2.2,I2.2,I7.7) WRITE(CLON,68) LOD,LOM,JSEC 68 FORMAT(I3.3,I2.2,I7.7) WRITE(CARDR,70) NAME,CLAT,NORS,CLON,EORW 70 FORMAT(T7,'*80*',T15,A30,T45,A11,A1,T57,A12,A1) CALL DRGPUT(CARDR,FILFLAG,FIL81FL) WRITE(6,80) 80 FORMAT('0ANY MORE COMPUTATIONS (Y/N)? ') READ(5,20) YN IF((YN.EQ.'Y').OR.(YN.EQ.'y')) GO TO 250 RETURN END ************************************************************************ SUBROUTINE DRGPUT(CARDR,FILFLAG,FIL81FL) ********************************************************************** * * * THIS IS THE DRIVER TO COMPUTE UTM NORTHINGS AND EASTINGS * FOR EACH PRIMARY ZONE AND THE AJACENT ZONE IF THE LONGITUDE * IS WITH 5 MINUTES OF THE ZONE BOUNDARIES * * THE OUTPUT IS FOR THE DATA SHEET PROGRAM * * VARIABLES * CARDR = A MODIFIED 80 RECORD CARD WITH A LENGTH OF 211 COLS * ER = EQUATORIAL RADIUS OF THE ELLIPSOID (SEMI-MAJOR AXIS) * RF = RECIPROCAL OF FLATTING OF THE ELLIPSOD * ESQ= E SQUARED * RAD = RADIAN CONVERSION FACTOR * CM = CENTRAL MERIDIAN ( COMPUTED USEING THE LONGITUDE) * SF = SCALE FACTOR OF CENTRAL MERIDIAN ( ALWAYS .9996 FOR UTM) * OR = SOUTHERNMOST PARALLEL OF LATITUDE ( ALWAYS ZERO FOR UTM) * R, A, B, C, U, V, W = ELLIPSOID CONSTANTS USED FOR COMPUTING * MERIDIONAL DISTANCE FROM LATITUDE * SO = MERIDIONAL DISTANCE (MULTIPLIED BY SCALE FACTOR ) * FROM THE EQUATOR TO THE SOUTHERNMOST PARALLEL OF LATITUDE * ( ALWAYS ZERO FOR UTM) * IMPLICIT REAL*8 (A-H,O-Z) CHARACTER*80 CARDR CHARACTER*1 EORW CHARACTER*1 NORS CHARACTER*30 NAME CHARACTER*4 ZONE INTEGER*4 LD,LM,LOD,LOM,FOUND REAL*8 SLAT,SLON,FI,LAM,LCM,UCM REAL*8 KP REAL*8 GRIDAZ REAL*8 TD,TM,ND,NM REAL*8 NORTH REAL*8 LOD1 LOGICAL FILFLAG LOGICAL FIL81FL COMMON/CONST/RAD,ER,RF,ESQ,PI READ(CARDR,50)LD,LM,SLAT,NORS,LOD,LOM,SLON,EORW 50 FORMAT(T45,I2,I2,F7.5,A1,I3,I2,F7.5,A1) * * CONVERT THE LATITUDE AND LONGITUDE TO PI AND LAM * TD=DBLE(FLOAT(LD)) TM=DBLE(FLOAT(LM)) FI=(TD+(TM+SLAT/60.D0)/60.D0)/RAD ND=DBLE(FLOAT(LOD)) NM=DBLE(FLOAT(LOM)) IF((EORW.EQ.'E').OR.(EORW.EQ.'e')) THEN LAM=(360.D0-(ND+(NM+SLON/60.D0)/60.D0))/RAD LOD1=(360.D0-(ND+(NM+SLON/60.D0)/60.D0)) LOD=DINT(LOD1) ENDIF IF((EORW.EQ.'W').OR.(EORW.EQ.'w')) THEN LAM=(ND+(NM+SLON/60.D0)/60.D0)/RAD LOD=LOD ENDIF * * FIND THE ZONE FOR LONGITUDE LESS THAN 180 DEGREES * IF(LOD.LT.180) THEN IZ=LOD/6 IZ= 30 -IZ ICM=(183-(6*IZ)) CM=DBLE(FLOAT(ICM))/RAD UCM=(ICM+3)/RAD LCM=(ICM-3)/RAD ENDIF * * FIND THE ZONE FOR LONGITUDE GREATER THAN 180 DEGREES * IF(LOD.GE.180) THEN IZ=(LOD)/6 IZ= 90 - IZ ICM=(543 - (6*IZ)) CM= DBLE(FLOAT(ICM))/RAD UCM=(ICM+3)/RAD LCM=(ICM-3)/RAD ENDIF TOL=(5.0D0/60.0D0)/RAD FN = 0.D0 IF((NORS.EQ.'S').OR.(NORS.EQ.'s')) THEN FN = 10000000.D0 ENDIF IF((NORS.EQ.'N').OR.(NORS.EQ.'n')) THEN FN = 0.D0 ENDIF FE=500000.0D0 SF=0.9996D0 OR=0.0D0 FOUND=0 CALL TCONST(ER,RF,SF,OR,ESQ,EPS,R,A,B,C,U,V,W,SO, & CM,FE,FN) * * COMPUTE THE NORTH AND EASTINGS * 200 CALL TMGRID(FI,LAM,NORTH,EAST,CONV,KP,ER,ESQ,EPS,CM, & FE,FN,SF,SO,R,A,B,C,U,V,W) * * WRITE THE ZONE NUMBER * IF (IZ.GT.9) THEN WRITE(ZONE,600) IZ 600 FORMAT(1X,I2) ELSE WRITE(ZONE,605) IZ 605 FORMAT(1X,I2.2) ENDIF * * WRITE THE OUTPUT TO THE PLANE FILE FOR THE DATA SHEET * PROGRAM * CALL DATAUT(CARDR,NORTH,EAST,CONV,KP,ZONE,FILFLAG,FOUND,FIL81FL) * * DO THE TEST TO SEE IF THE LONGITUDE IS WITHIN 5 MINUTES * OF THE BOUNDARIES FOR THE ZONE AND IF SO COMPUTE THE * NORHT AND EASTING FOR THE ADJACENT ZONE * IF(FOUND.NE.0) THEN RETURN ENDIF IF(DABS(UCM-LAM).LE.TOL) THEN CM=DBLE(FLOAT(ICM+6))/RAD IZ=IZ-1 IF(IZ.EQ.0) IZ=60 FOUND=FOUND+1 GO TO 200 ENDIF IF(DABS(LCM-LAM).LE.TOL) THEN CM=DBLE(FLOAT(ICM-6))/RAD IZ=IZ+1 IF(IZ.EQ.61) IZ=1 FOUND=FOUND+1 GO TO 200 ENDIF RETURN END ******************************************************************* SUBROUTINE DRUTGP(CARDR,ICODE,FILFLAG,FILPRT) * * * * THIS IS THE DRIVER TO COMPUTE LATITUDES AND LONGITUDES FROM * THE UTMs FOR EACH ZONE * * * VARIABLES * CARDR = A MODIFIED 80 RECORD CARD WITH A LENGTH OF 211 COLS * ER = EQUATORIAL RADIUS OF THE ELLIPSOID (SEMI-MAJOR AXIS) * RF = RECIPROCAL OF FLATTING OF THE ELLIPSOD * ESQ= E SQUARED * RAD = RADIAN CONVERSION FACTOR * CM = CENTRAL MERIDIAN ( COMPUTED USEING THE LONGITUDE) * SF = SCALE FACTOR OF CENTRAL MERIDIAN ( ALWAYS .9996 FOR UTM) * OR = SOUTHERNMOST PARALLEL OF LATITUDE ( ALWAYS ZERO FOR UTM) * R, A, B, C, U, V, W = ELLIPSOID CONSTANTS USED FOR COMPUTING * MERIDIONAL DISTANCE FROM LATITUDE * SO = MERIDIONAL DISTANCE (MULTIPLIED BY SCALE FACTOR ) * FROM THE EQUATOR TO THE SOUTHERNMOST PARALLEL OF LATITUDE * ( ALWAYS ZERO FOR UTM) * IMPLICIT REAL*8 (A-H,O-Z) CHARACTER*80 CARDR CHARACTER*30 NAME CHARACTER*1 NORS CHARACTER*4 ZONE INTEGER*4 FOUND REAL*8 LAT,LON,LCM,UCM REAL*8 KP REAL*8 NORTH,EAST LOGICAL FILFLAG,FILPRT COMMON/CONST/RAD,ER,RF,ESQ,PI COMMON/XY/NORTH,EAST * * FIND THE CENTRAL MERIDAIN IF THE ZONE NUMBER IS LESS THAN 30 * IF(ICODE.LT.30) THEN IZ=ICODE ICM=(183-(6*IZ)) CM=DBLE(FLOAT(ICM))/RAD UCM=(ICM+3)/RAD LCM=(ICM-3)/RAD ENDIF * * FIND THE CENTRAL MERIDAN IF THE ZONE NUMBER IS LARGER THAN 30 * IF(ICODE.GE.30) THEN IZ=ICODE ICM=(543 - (6*IZ)) CM= DBLE(FLOAT(ICM))/RAD UCM=(ICM+3)/RAD LCM=(ICM-3)/RAD ENDIF TOL=(5.0D0/60.0D0)/RAD IF(NORTH.GT.10000000.0) THEN FN= 10000000.0D0 NORS= 'S' ELSE FN=0.D0 NORS='N' ENDIF FE=500000.0D0 SF=0.9996D0 OR=0.0D0 FOUND=0 CALL TCONPC (SF,OR,EPS,R,SO,V0,V2,V4,V6,ER,ESQ,RF) * * COMPUTE THE LATITUDES AND LONGITUDES * 200 CALL TMGEOD (NORTH,EAST,LAT,LON,EPS,CM,FE,SF,SO,R,V0,V2, & V4,V6,FN,ER,ESQ,CONV,KP) * * WRITE THE ZONE NUMBER * IF (IZ.GT.9) THEN WRITE(ZONE,600) IZ 600 FORMAT(1X,I2) ELSE WRITE(ZONE,605) IZ 605 FORMAT(1X,I2.2) ENDIF * * WRITE THE OUTPUT TO THE PLANE FILE FOR THE DATA SHEET * PROGRAM * CALL DATAGP(CARDR,LAT,LON,FILFLAG,FOUND,FILPRT,ZONE,CONV,KP,NORS) * * DO THE TEST TO SEE IF THE LONGITUDE IS WITHIN 5 MINUTES * OF THE BOUNDARIES FOR THE ZONE AND IF SO COMPUTE THE * NORHT AND EASTING FOR THE ADJACENT ZONE * IF(FOUND.NE.0) THEN RETURN ENDIF IF(DABS(UCM-LAM).LE.TOL) THEN CM=DBLE(FLOAT(ICM+6))/RAD IZ=IZ-1 IF(IZ.EQ.0) IZ=60 FOUND=FOUND+1 GO TO 200 ENDIF IF(DABS(LCM-LAM).LE.TOL) THEN CM=DBLE(FLOAT(ICM-6))/RAD IZ=IZ+1 IF(IZ.EQ.61) IZ=1 FOUND=FOUND+1 GO TO 200 ENDIF RETURN END ********************************************************************** SUBROUTINE DATAUT(CARDR,NORTH,EAST,CONV,KP,ZONE,FILFLAG,J, & FIL81FL) ********************************************************************* * IMPLICIT REAL*8 (A-H,O-Z) CHARACTER*5 XGD,GDVAL DIMENSION GDVAL(1001),GDNUM(1001) LOGICAL FILFLAG LOGICAL FIL81FL REAL*8 NORTH,KP REAL*8 SLAT,SLON INTEGER*4 LD,LM,LOD,LOM CHARACTER*1 PM,ESGN,GSGN CHARACTER*1 ELEVT CHARACTER*1 EORW CHARACTER*1 NORS CHARACTER*1 DATUM,DATNUM CHARACTER*2 ORDER CHARACTER*2 ELXX CHARACTER*6 GD CHARACTER*80 CARDR INTEGER*4 STANUM CHARACTER*4 ELEV CHARACTER*11 REST CHARACTER*7 ELNUM CHARACTER*4 ZONE CHARACTER*30 NAME CHARACTER*11 ANORTH CHARACTER*10 AEAST CHARACTER*1 BUFF(20) COMMON/FILES/I3,I4,I2,ICON COMMON/IPRINT/IPRT COMMON/DONUM/ISN COMMON/GEODS/GDVAL,GDNUM COMMON/DATUM/DATNUM IF (CONV.LT.0) THEN PM='-' ELSE PM=' ' ENDIF CALL TODMS(DABS(CONV),IDEG,IMIN,CSEC) IF(FILFLAG) THEN IF(ICON.GE.48) THEN CALL HDUTGP ICON = 0 ENDIF READ(CARDR,50) STANUM,NAME,ELEV,ELXX,ELEVT,ORDER 50 FORMAT(T11,I3,T15,A30,T70,A4,A2,A1,T79,A2) READ(CARDR,51) LD,LM,SLAT,NORS,LOD,LOM,SLON,EORW 51 FORMAT(T45,I2,I2,F7.5,A1,I3,I2,F7.5,A1) IF((ORDER(1:1).EQ.'4').AND.(ELEVT.EQ.' ')) THEN ELNUM=' ' ELSEIF((ORDER(1:1).EQ.' ').AND.(ELEVT.EQ.' ')) THEN ELNUM=' ' ELSEIF((ELEVT.EQ.'B').OR.(ELEVT.EQ.'L')) THEN WRITE(ELNUM,200) ELEV,ELXX 200 FORMAT(A4,'.',A2) ELSEIF((ELEVT.EQ.'R').OR.(ELEVT.EQ.'T')) THEN WRITE(ELNUM,205) ELEV,ELXX(1:1) 205 FORMAT(A4,'.',A1,' ') ELSEIF((ELEVT.EQ.'P').OR.(ELEVT.EQ.'E').OR. & (ELEVT.EQ.'V')) THEN WRITE(ELNUM,210) ELEV 210 FORMAT(A4,'. ') ELSE WRITE(ELNUM,215) ELEV 215 FORMAT(A4,' SC') ENDIF *** DO THE DO LOOP TO FIND THE GEOD HT GD=' ' XGD=' ' DO 60 I=1,ISN IF(GDNUM(I).EQ.STANUM) THEN XGD=GDVAL(I) ENDIF 60 CONTINUE IF(XGD.NE.' ') THEN READ(XGD,FMT='(F5.1)') GEOD GSGN=' ' IF(GEOD.LE.0.0D0) THEN GSGN='-' ENDIF GEOD=DABS(GEOD) WRITE(GD,FMT='(F6.2)') GEOD GD(1:1)=GSGN ENDIF IF(J.EQ.0) THEN WRITE(3,10) NAME,LD,LM,SLAT,NORS,LOD,LOM,SLON,EORW, & NORTH,EAST,ZONE,PM,IDEG,IMIN,CSEC,KP,ELNUM, & GD 10 FORMAT(1X,A30,T34,I2,1X,I2,1X,F8.5,A1,T50,I3.3,1X,I2.2,1X, & F8.5,A1,T67,F12.3,T80,F11.3,T92,A4,T97,A1,I1,1X,I2,1X,F5.2, & T109,F10.8,T120,A7,T128,A6) ICON= ICON + 1 ELSE WRITE(3,20) NORTH,EAST,ZONE,PM,IDEG,IMIN,CSEC,KP 20 FORMAT(T67,F12.3,T80,F11.3,T92,A4,T97,A1,I1,1X,I2,1X, & F5.2,T109,F10.8) ICON = ICON + 1 ENDIF ELSE IF(DATNUM.EQ.'1') THEN PRINT *, ' UTMS FOR THE CLARK 1866 ELLIPSOID (NAD27 DATUM) ' PRINT *,' ' ENDIF IF(DATNUM.EQ.'2') THEN PRINT *,' UTMS FOR THE GRS80/WGS84 ELLIP (NAD83 DATUM) ' PRINT *,' ' ENDIF IF(DATNUM.EQ.'3') THEN PRINT *,' UTMS FOR THE INTERNATIONAL ELLIP (INT24 DATUM) ' PRINT *,' ' ENDIF IF(DATNUM.EQ.'4') THEN PRINT *,' UTMS FOR THE WGS72 ELLIPSOID ' PRINT *,' ' ENDIF IF(DATNUM.EQ.'5') THEN PRINT *,' UTMS FOR THE OTHER ELLIPSOID ' PRINT *,' ' ENDIF WRITE(*,30) 30 FORMAT(' NORTH(Y) EAST(X) ZONE ', * ' CONVERGENCE SCALE') WRITE(*,40)NORTH,EAST,ZONE,PM,IDEG,IMIN,CSEC,KP 40 FORMAT(1X,F12.3,1X,F11.3,2X,A4,2X,A1,I1,1X,I2,1X, * F5.2,3X,F10.8) ENDIF IF(FIL81FL) THEN CALL CHGDEC(11,3,EAST,BUFF) AEAST(1:1) = BUFF(1) AEAST(2:2) = BUFF(2) AEAST(3:3) = BUFF(3) AEAST(4:4) = BUFF(4) AEAST(5:5) = BUFF(5) AEAST(6:6) = BUFF(6) AEAST(7:7) = BUFF(7) AEAST(8:8) = BUFF(9) AEAST(9:9) = BUFF(10) AEAST(10:10) = BUFF(11) CALL CHGDEC(12,3,NORTH,BUFF) ANORTH(1:1) = BUFF(1) ANORTH(2:2) = BUFF(2) ANORTH(3:3) = BUFF(3) ANORTH(4:4) = BUFF(4) ANORTH(5:5) = BUFF(5) ANORTH(6:6) = BUFF(6) ANORTH(7:7) = BUFF(7) ANORTH(8:8) = BUFF(8) ANORTH(9:9) = BUFF(10) ANORTH(10:10) = BUFF(11) ANORTH(11:11) = BUFF(12) READ(CARDR,300) STANUM,NAME,REST 300 FORMAT(T11,I3,T15,A30,T70,A11) IF(DATNUM.EQ.'1') THEN WRITE(4,310) STANUM,NAME,AEAST,ANORTH,ZONE(2:3),REST 310 FORMAT(T7,'*81*',T11,I3,T15,A30,T45,A10,T55,A11, & T66,'00',A2,T70,A11) ENDIF IF(DATNUM.EQ.'2') THEN WRITE(4,320) STANUM,NAME,ANORTH,AEAST,ZONE(2:3),REST 320 FORMAT(T7,'*81*',T11,I3,T15,A30,T45,A11,T56,A10, & T66,'00',A2,T70,A11) ENDIF IF(DATNUM.EQ.'3') THEN WRITE(4,310) STANUM,NAME,AEAST,ANORTH,ZONE(2:3),REST ENDIF IF(DATNUM.EQ.'4') THEN WRITE(4,310) STANUM,NAME,AEAST,ANORTH,ZONE(2:3),REST ENDIF IF(DATNUM.EQ.'4') THEN WRITE(4,310) STANUM,NAME,AEAST,ANORTH,ZONE(2:3),REST ENDIF IF(DATNUM.EQ.'5') THEN WRITE(4,310) STANUM,NAME,AEAST,ANORTH,ZONE(2:3),REST ENDIF ENDIF RETURN END ********************************************************************* SUBROUTINE DATAGP(CARDR,LAT,LON,FILFLAG,J,FILPRT,ZONE,CONV,KP, & NORS) ********************************************************************** *** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL FILFLAG,FILPRT REAL*8 NORTH,EAST,KP,LAT,LON,CONV INTEGER*4 IDEG,IMIN CHARACTER*2 AD1,AM1,AM2 CHARACTER*3 AD2 CHARACTER*1 NORS CHARACTER*1 WORE CHARACTER*7 AS1,AS2 CHARACTER*1 ADIR1,ADIR2,PM CHARACTER*1 DATUM,DATNUM CHARACTER*4 ZONE CHARACTER*30 NAME CHARACTER*80 CARDR COMMON/XY/NORTH,EAST COMMON/FILES/I3,I4,I2,ICON COMMON/DATUM/DATNUM COMMON/CONST/RAD,ER,RF,ESQ,PI R360 = 360.D0/RAD C WORE = 'W' IF (CARDR(7:10) .EQ. '*80*') THEN READ(CARDR,FMT='(T69,A1)') WORE ELSE WORE = 'W' ENDIF IF((WORE.EQ.'E').OR.(WORE.EQ.'e')) THEN LON = R360 - LON ENDIF CALL TODMS(LAT,LD,LM,SLAT) CALL TODMS(LON,LOD,LOM,SLON) IF (CONV.LT.0) THEN PM='-' ELSE PM=' ' ENDIF CALL TODMS(DABS(CONV),IDEG,IMIN,CSEC) IF(FILPRT) THEN IF(ICON.GE.48) THEN CALL HDUTPC ICON=0 ENDIF READ(CARDR,5) NAME 5 FORMAT(T15,A30) IF(J.EQ.0) THEN WRITE(4,10) NAME,NORTH,EAST,LD,LM,SLAT,NORS,LOD,LOM,SLON, & WORE,ZONE,PM,IDEG,IMIN,CSEC,KP 10 FORMAT(A30,T31,F12.3,T46,F11.3,T62,I2.2,1X,I2.2,1X,F8.5,T77,A1, & T79,I3.3,1X,I2.2,1X,F8.5,T95,A1,T100,A4,T106,A1,1X,I1,1X,I2.2, & 1X,F5.2,T119,F10.8) ELSE WRITE(4,20) LD,LM,SLAT,NORS,LOD,LOM,SLON,WORE,ZONE,PM, & IDEG,IMIN,CSEC,KP 20 FORMAT(T62,I2.2,1X,I2.2,1X,F8.5,T77,A1, & T79,I3.3,1X,I2.2,1X,F8.5,T95,A1,T100,A4,T106,A1,1X,I1, & 1X,I2.2,1X,F5.2,T119,F10.8) ENDIF ELSE IF(DATNUM.EQ.'1') THEN PRINT *, ' UTMS FOR THE NAD27 DATUM' PRINT *, ' ' ENDIF IF(DATNUM.EQ.'2') THEN PRINT *, ' UTMS FOR THE NAD83 DATUM' PRINT *, ' ' ENDIF WRITE(6,30) 30 FORMAT('0 LATITUDE',T20,'LONGITUDE',T37,'ZONE ', & T42,' CONVERGENCE ',T56,'SCALE FACTOR') WRITE(6,40)LD,LM,SLAT,NORS,LOD,LOM,SLON,WORE,ZONE, & PM,IDEG,IMIN,CSEC,KP 40 FORMAT(1X,I2.2,1X,I2.2,1X,F8.5,T17,A1,T19,I3.3,1X,I2.2,1X,F8.5, & T35,A1,T37,A4,T42,A1,1X,I1,1X,I2.2,1X,F5.2,2X,F10.8) ENDIF IF(FILFLAG) THEN *** UPDATE RECORD CARDR(7:10)='*80*' CALL TODMS(LAT,ID1,IM1,S1) ADIR1 = NORS IF(LON.LT.0) THEN WORE='E' ENDIF CALL TODMS(DABS(LON),ID2,IM2,S2) ADIR2 = WORE IS1=S1*100000.D0+0.5D0 IS2=S2*100000.D0+0.5D0 WRITE(AD1,4) ID1 WRITE(AM1,4) IM1 WRITE(AS1,2) IS1 WRITE(AD2,3) ID2 WRITE(AM2,4) IM2 WRITE(AS2,2) IS2 4 FORMAT(I2.2) 2 FORMAT(I7.7) 3 FORMAT(I3.3) CARDR(45:46)=AD1 CARDR(47:48)=AM1 CARDR(49:55)=AS1 CARDR(56:56)=ADIR1 CARDR(57:59)=AD2 CARDR(60:61)=AM2 CARDR(62:68)=AS2 CARDR(69:69)=ADIR2 *** PROCESS THE NEW *80* RECORD WRITE(3,50) CARDR 50 FORMAT(A80) ENDIF ICON= ICON + 1 RETURN END ********************************************************************* SUBROUTINE TODMS(RAD,IDG,MIN,SEC) ********************************************************************* C RADIANS TO DEGREES,MINUTES AND SECONDS C REAL*8 RAD,SEC,RHOSEC DATA RHOSEC/2.062648062471D05/ SEC=RAD*RHOSEC IDG=SEC/3600.D0 SEC=SEC-DBLE(IDG*3600) MIN=SEC/60.D0 SEC=SEC-DBLE(MIN*60) IF((60.D0-DABS(SEC)).GT.5.D-6) GO TO 100 SEC=SEC-DSIGN(60.D0,SEC) MIN=MIN+ISIGN(1,MIN) 100 IF(IABS(MIN).LT.60) GO TO 101 MIN=MIN-ISIGN(60,MIN) IDG=IDG+ISIGN(1,IDG) 101 MIN=IABS(MIN) SEC=DABS(SEC) IF(RAD.GE.0.D0) GO TO 102 IF(IDG.EQ.0) MIN=-MIN IF(IDG.EQ.0.AND.MIN.EQ.0)SEC=-SEC 102 RETURN END ******************************************************************** ******************************************************************* SUBROUTINE LSTFTN ***************************************************************** CHARACTER*133 TXT CHARACTER*80 FOLD CHARACTER*1 FF FF=CHAR(12) PRINT *,' ' PRINT *,' ' PRINT *,' SUBROUTINE LSTFTN ' PRINT *,' ' PRINT *,' NOTE: MAKE SURE THE PRINTER IS TURNED ON ' PRINT *,' ' OPEN(2,FILE='PRN',FORM='FORMATTED') PRINT *,' NAME OF INPUT FILE WRITTEN WITH ' PRINT *,' FORTRAN OPTIONS. ' PRINT *,' ' PRINT *,' TYPE NAME: ' READ(5,50) FOLD 50 FORMAT(A80) OPEN(3,FILE=FOLD,STATUS='OLD') 100 READ(3,150,END=900) TXT 150 FORMAT(A133) IF(TXT(1:1).EQ.'1') THEN WRITE(2,200) FF 200 FORMAT(A) ELSE WRITE(2,150) TXT ENDIF GO TO 100 900 WRITE(2,200) FF WRITE(2,200) FF CLOSE(UNIT=3) CLOSE(UNIT=2) PRINT *,' JOB COMPLETED ' PRINT *,' ' RETURN END ********************************************************************** SUBROUTINE CHGDEC (NNN,MMM,SS,CHAR) C ----------------------------------------------------- CHARACTER*1 DASH,ZERO,DOL,BLK1,CHAR(*),IB(20),TT CHARACTER*20 JB INTEGER*4 IDG,MIN REAL*8 S,SS,DEC,W,SEC,TEN,TOL C EQUIVALENCE (IB,JB) C DATA BLK1,DOL,ZERO,DASH/' ','$','0','-'/,TEN/10.0D0/ C C CHAR 1-16 LENGTH OF CHARACTER ARRAY FIELD C NR 1-13 LENGTH OF FIELD TO BE USED FROM LEFT C NP 7-13 LOCATION OF DECIMAL POINT FROM RIGHT C NEG CHAR(1) PUT THE MINUS SIGN HERE C EXAMPLE: RANGE NR=14 AND WITH A POINT NP=6 C W= -3600.376541 C C CHAR FIELD 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 C BLANK FILLED B B B B B B B B B B B B B B B B BLANK C NR ADDED |B B B B B B B B B B B B B B| B B LIMIT C NP ADDED |B B B B B B B . B B B B B B| B B POINT C W ENTERED |B B - 3 6 0 0 . 3 7 6 5 4 1| 8 4 C DOL (SIGN) |B B - 3 6 0 0 . 3 7 6 5 4 1| $ 4 C NEG (SIGN) |B B - 3 6 0 0 . 3 7 6 5 4 1| $ 4 C C ------------------------------- C SETUP OUTSIDE CONSTANTS C NR=NNN NP=MMM DEC=SS C C CHECK TO SEE IF NR AND NF ARE WITHIN LIMITS C NNP=IABS(NP) KTST=0 M=IABS(NR) C C IF NR IS GREATER THAN ZERO -- DECIMAL NUMBER C IF(NR.GT.0)GOTO 1 C ------------------------------------- C THIS IS A DEG-MIN-SEC FORMAT C IF(NNP.GT.5)NNP=5 C C ENTRY IS DDD-MM-SS.SS C OR HH-MM-SS.SS C DEC=DABS(DEC) SEC=DEC*3600.0D0 IDG=SEC/3600.0D0 SEC=SEC-DBLE(FLOAT(IDG))*3600.0D0 MIN=SEC/60.0D0 SEC=SEC-DBLE(FLOAT(MIN))*60.0D0 DEC=DBLE(FLOAT(IDG))*1000000.0D0+DBLE(FLOAT(MIN))*1000.0D0+SEC C KTST=1 M=15 C C ROUND THE DECIMAL NUMBER C 1 IP=-1*(NNP+1) TOL=5.0D0*(TEN**IP) W=(DABS(DEC) + TOL) IF(DEC.LT.0.0D0) W=-W DEC=W C N=NNP IF(M.GT.15)M=15 IF(M.LT.4)M=4 IF(N.GE.M)N=M-1 W=DEC C C CONVERT THE DECIMAL NUMBER C WRITE(JB,100) W 100 FORMAT(F20.10) C C BLANK FILL THE ARRAY C DO 5 IQ=1,16 5 CHAR(IQ)=BLK1 C C LOOK FOR THE FIRST NON-BLANK CHARACTER C DO 6 I=1,10 TT=IB(I) 6 IF(TT.NE.BLK1)GOTO 7 C C COMPUTE THE PROPER NUMBER LENGTH WITH THE PROPER DECIMALS C 7 K=11-I K=K+N IF(K.GT.M)M=K L=10-(M-N) IF(L.LE.0)L=0 C MM=M+1 J=0 IDEC=0 DO 30 I=1,MM K=I+L IF(K.GT.20)K=20 J=J+1 CHAR(J)=IB(K) 30 IF(CHAR(J).EQ.'.') IDEC=J N=IDEC+NNP+1 C IF(KTST.EQ.0)GOTO 40 C C FILL-OUT THE DEG-MIN-SEC FIELD C CHAR(4)=DASH CHAR(7)=DASH C C ZERO-OUT ALL BLANK CHARACTERS C DO 10 I=1,9 10 IF(CHAR(I).EQ.BLK1)CHAR(I)=ZERO C 40 CHAR(N)=DOL C RETURN END ************************************************************ SUBROUTINE DATUMM(ER,RF,F,ESQ,DATNUM) CHARACTER*1 ANS,DATNUM REAL*8 ER REAL*8 RF REAL*8 F REAL*8 ESQ 50 PRINT *, ' ' PRINT *, ' WHICH ELLIPSOID DO YOU WANT ANSWER: ' PRINT *, ' 1. CLARKE 1866 ' PRINT *, ' 2. GRS80/WGS84 ' PRINT *, ' 3. INTERNATIONAL 1910 ' PRINT *, ' 4. WGS72 ' PRINT *, ' 5. OTHER ELLIPSOID ' PRINT *, ' TYPE NUMBER: ' READ(5,FMT='(A1)') ANS ** ** FIND THE RIGHT SEMI MAJOR AXIS AND FLATTING ** IF(ANS.EQ.'1') THEN ** FOR THE NAD 27 DATUM ** ER=6378206.4D0 RF=294.978698D0 F=1.D0/RF ESQ=(F+F-F*F) ELSEIF (ANS.EQ.'2') THEN ** FOR THE NAD83 DATUM ** ER=6378137.D0 RF=298.257222101D0 F=1.D0/RF ESQ=(F+F-F*F) ELSEIF (ANS.EQ.'3') THEN ** FOR THE INT24 DATUM ** ER=6378388.D0 RF=297.0D0 F=1.D0/RF ESQ=(F+F-F*F) ELSEIF (ANS.EQ.'4') THEN ** FOR THE WGS72 ** ER=6378135.D0 RF=298.26D0 F=1.D0/RF ESQ=(F+F-F*F) ELSEIF (ANS.EQ.'5') THEN ** FOR THE OTHER DATUM ** 10 PRINT *,' ' PRINT *,' SEMIMAJOR AXIS (meters) ' PRINT *,' TYPE VALUE NOW: ' READ(*,FMT='(F12.0)') ER IF((ER.LE.6376400.D0).OR.(ER.GT.6378500.D0)) THEN PRINT *,' ' PRINT *,' SEMIMAJOR AXIS IS OUT OF RANGE - DO YOU' PRINT *,' WANT TO TRY AGAIN ' PRINT *,' TYPE Y OR N ' READ(*,FMT='(A1)') ANS IF((ANS.EQ.'Y').OR.(ANS.EQ.'y')) THEN GO TO 10 ELSE GO TO 50 ENDIF ENDIF 20 PRINT *,' ' PRINT *,' FLATTENING ' PRINT *,' TYPE VALUE NOW: ' READ(*,FMT='(F11.0)') RF IF((RF.LE.290.D0).OR.(RF.GT.302.D0)) THEN PRINT *,' ' PRINT *,' FLATTENING IS OUT OF RANGE - DO YOU ' PRINT *,' WANT TO TRY AGAIN ' PRINT *,' TYPE Y OR N ' READ(*,FMT='(A1)') ANS IF((ANS.EQ.'Y').OR.(ANS.EQ.'y')) THEN GO TO 20 ELSE GO TO 50 ENDIF ENDIF F=1.D0/RF ESQ=(F+F-F*F) ELSE PRINT *, ' YOU TYPED THE INCORRECT NUMBER ' PRINT *, ' SO LET TRY AGAIN ' PRINT *, ' ' GO TO 50 ENDIF DATNUM=ANS RETURN END