C SccsID = "@(#)gppcgp.f 1.3 07/23/03" C PROGRAM GPPCGP C C C ********************************************************************** C C THIS PROGRAM IS FURNISHED BY THE GOVERNMENT AND IS ACCEPTED AND C USED BY THE RECIPIENT WITH THE EXPRESS UNDERSTANDING THAT THE C UNITED STATES GOVERNMENT MAKES NO WARRANTIES, EXPRESSED OR C IMPLIED, CONCERNING THE ACCURACY, COMPLETENESS, RELIABILITY, C USABILITY, OR SUITABILITY FOR ANY PARTICULAR PURPOSE OF THE C INFORMATION AND DATA CONTAINED IN THIS PROGRAM OR FURNISHED IN C CONNECTION THEREWITH, AND THE UNITED STATES SHALL BE UNDER NO C LIABILITY WHATSOEVER TO ANY PERSON BY REASON OF ANY USE MADE C THEREOF. THE PROGRAM BELONGS TO THE GOVERNMENT, THEREFORE THE C RECIPIENT FURTHER AGREES NOT TO ASSERT ANY PROPRIETARY RIGHTS C THEREIN OR TO REPRESENT THIS PROGRAM TO ANYONE AS OTHER THAN A C GOVERNMENT PROGRAM. C C ********************************************************************** C C PURPOSE: TO CONVERT STATE PLANE COORDINATES TO GPS. C C INPUT: A BLUE BOOK DECK WITH *81* RECORDS C C OUTPUT: A BLUE BOOK DECK WITH *80* RECORDS C C PROGRAMMER: ANNA-MARY MILLER C C COVERSION DONE BY: EDWARD CARLSON C C ORIGINAL VERSION DATE ON THE PC: 02/13/86 C C VERSION 2: 02/27/86 (MADE ALL BLANK IN NUMMERIC FIELDS C PRINT ZEROS) C C C C VERSION 2.1 03/23/03 C Removed minus sign in Latitude via IABS() C for Southern Hemisphere output REAL*8 RHOSEC,SLAT,SLON,FLAT,FLON,X,Y,S,A,CSEC INTEGER*4 GNUM(2),HEIGHT(3),STATE(2) INTEGER*4 SQNUM,STNUM,OLD,NZONE,TZONE,ILTSEC,ILNSEC INTEGER*4 ZONE,LATD,LATM,LOND,LONM CHARACTER*4 IGP,IPC,ICODE,CARDT,EIGHTY CHARACTER*11 EXTRA CHARACTER*1 DIRW,DIRN,ANS,ANSQ CHARACTER*80 INFILE,OUTFILE,CARDR,CARDP DIMENSION NAME(8) LOGICAL FILPRT DATA RHOSEC/2.062648062471D05/,IGP/'GPPC'/,IPC/'PCGP'/, * ICODE/'PCGP'/ LINES=50 FILPRT=.FALSE. ANS='N' C OPEN(3,FILE='SCRATCH',STATUS='UNKNOWN',FORM='FORMATTED') REWIND(UNIT=3) C C WRITE(6,5000)' DO YOU WANT TO CONVERT PLANE COORDINATES ' WRITE(6,5000)' TO GEODETIC POSITIONS ??? ' WRITE(6,5000)' ANSWER Y OR N ' WRITE(6,5000)' TYPE ANSWER ?? ' READ(5,5000) ANSQ C C IF ((ANSQ.EQ.'N').OR.(ANSQ.EQ.'n')) THEN GO TO 10 ELSEIF ((ANSQ.EQ.'Y').OR.(ANSQ.EQ.'y')) THEN GO TO 30 ELSE GO TO 50 ENDIF C C C GP TO PC SECTION C 10 CALL INFPC(OLD,FILPRT) C ICODE=IGP 11 READ (91,FMT='(A80)',END=60) CARDP IF (CARDP(7:10).EQ.'*80*') THEN READ(CARDP,101,ERR=500) NAME,LATD,LATM,SLAT,LOND,LONM,SLON IF (LINES.LT.50) GO TO 15 IF(.NOT.(FILPRT)) THEN WRITE (6,301) WRITE (6,201) ENDIF LINES=0 CALL GETNEW(OLD,ZONE,FOUND) 15 FLAT = (DBLE((LATD*60+LATM)*60)+SLAT)/RHOSEC FLON = (DBLE((LOND*60+LONM)*60)+SLON)/RHOSEC IF (ZONE.EQ.0) GO TO 11 CALL DSPTCH (ICODE,ZONE,FLAT,FLON,STATE,X,Y,S,A,IERR) IF (IERR.EQ.1) GO TO 55 CALL TODMS (A,ICD,ICM,CSEC) IF (ZONE.EQ.30) LATD = -LATD ****** WRITE OUTPUT TO FILE OR SCREEN ******* IF(FILPRT) THEN IF(ANS.EQ.'N') THEN WRITE(93,301) WRITE(93,201) ANS='Y' ENDIF WRITE (93,102) NAME,LATD,LATM,SLAT,LOND,LONM,SLON,X,Y, 1 STATE,ICD,ICM,CSEC,S ELSE WRITE (6,102) NAME,LATD,LATM,SLAT,LOND,LONM,SLON,X,Y, 1 STATE,ICD,ICM,CSEC,S ENDIF LINES = LINES+1 GO TO 11 ELSE GO TO 11 ENDIF C C C C C PC TO GP SECTION 30 CALL INFGP ICODE=IPC 31 READ (91,104,END=60) CARDR CARDT=CARDR(7:10) IF (CARDT.EQ.'*81*') THEN READ (CARDR,103,ERR=502) SQNUM,STNUM,NAME,X,Y,OLD,EXTRA DATA EIGHTY/'*80*'/,DIRN/'N'/,DIRW/'W'/ LINES=0 CALL GETNEW (OLD,NZONE,FOUND) IF (NZONE.EQ.TZONE) GO TO 40 TZONE=NZONE WRITE (6,302) WRITE (6,306) OLD 306 FORMAT (1X,21HOLD PLANE COOR ZONE -,1X,I4) WRITE (6,304) NZONE 304 FORMAT (1X,21HNEW PLANE COOR ZONE -,1X,I3/) WRITE (6,202) 40 CALL DSPTCH (ICODE,NZONE,FLAT,FLON,STATE,X,Y,S,A,IERR) IF (IERR.EQ.1) GO TO 55 CALL TODMS (FLAT,LATD,LATM,SLAT) CALL TODMS (FLON,LOND,LONM,SLON) ILTSEC=(SLAT+5.E-06)*1.E+05 ILNSEC=(SLON+5.E-06)*1.E+05 LATD = IABS(LATD) WRITE (6,105) NAME,X,Y,LATD,LATM,SLAT,LOND,LONM,SLON, 1 OLD WRITE (92,106) SQNUM,EIGHTY,STNUM,NAME,LATD,LATM,ILTSEC, 1 DIRN,LOND,LONM,ILNSEC,DIRW,EXTRA LINES=LINES+1 GO TO 31 C ELSE WRITE(92,104) CARDR GO TO 31 ENDIF C 50 WRITE (6,203) ICODE GO TO 60 55 WRITE (6,204) NAME,ZONE C GO TO 60 500 WRITE(6,501) CARDP GO TO 60 502 WRITE(6,503) CARDR 60 CONTINUE CLOSE (3,STATUS='DELETE') STOP 101 FORMAT (T15,7A4,A2,T45,I2,I2,F7.5,T57,I3,I2,F7.5) 102 FORMAT (10X,7A4,A2,2I3,F9.5,2X,2I3,F9.5,2X,F11.3,F12.3, 1 1X,A2,1X,A2,2I3,F6.2,1X,F12.10) 103 FORMAT (BZ,I6,4X,BZ,I3,1X,7A4,A2,BZ,F10.3,BZ,F11.3,I4,A11) 104 FORMAT (A80) 105 FORMAT (9X,7A4,A2,2X,F11.3,F12.3,3X,BZ,I2,1X,BZ,I2,1X,BZ, 1 F8.5,2X,BZ,I3,1X,BZ,I2,1X,BZ,F8.5,3X,I4,4X,I2) 106 FORMAT (I6.6,A4,I3.3,1X,7A4,A2,I2.2,I2.2,I7.7,A1,I3.3, 1 I2.2,I7.7,A1,A11) 201 FORMAT (T14,12HSTATION NAME,T45,8HLATITUDE,T61, 1 9HLONGITUDE,T81,1HX,T93,1HY,T99,4HZONE,T105,11HCONVERGENCE, 2 T117,12HSCALE FACTOR/) 202 FORMAT (T14,12HSTATION NAME,T47,1HX,T59,1HY,T70, 1 8HLATITUDE,T86,9HLONGITUDE,T103,4HZONE/) 203 FORMAT (1X,36HOPTION CARD HAS IMPROPER PARAMETER -,1X,A4, 1 14H - JOB ABORTED) 204 FORMAT (1X,30HIMPROPER ZONE(S) - JOB ABORTED/2X,7A4,A2,1X,3I3) 301 FORMAT(1H1/48H STATE PLANE COORDINATES FROM GEODETIC POSITIONS/) 302 FORMAT(1H1/48H GEODETIC POSITIONS FROM STATE PLANE COORDINATES/) 501 FORMAT('0 IMPROPER *80* RECORD = ',A80) 503 FORMAT('0 IMPROPER *81* RECORD = ',A80) 5000 FORMAT(A) END