      PROGRAM LEFTI
C
C      (LEAST SQUARES FITTING, TRANSFORMATION, AND INTERPOLATION)
C
C
C     PURPOSE:
C
C     TO DERIVE TRANSFORMATION PARAMETERS BETWEEN TWO COORDINATE
C     SYSTEMS AND TRANSFORM THE GEODETIC STATION POSITIONS FROM
C     ONE COORDINATE SYSTEM TO A SECOND.
C
C
C     SUROUTINE USE FOR LEFTI:
C
C     INFORM,PRTYPE,DMSTOR,CKOBS,PRINTR,RTODMS,PAGE,TOGRID,REFINE,
C     SORT,SECOND,METERS,TOGEO
C
C
C
C     PROGRAMMER: T. VINCENTY
C     CONVERTED BY: EDWARD CARLSON
C
C     LAST UPDATE: 11/13/87     VERSION NUMBER 3
C
C
C
 
      PARAMETER (NSTA=500)
 
 
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER*30 NAME
      CHARACTER*1 YORN
      CHARACTER*32 TITLE
      INTEGER RS1,RS2,COUNT
      CHARACTER*80 COMFILE,INFILE,OUTFILE,CARDR,CARD,CARDRC
      CHARACTER*80 FNAME1
      CHARACTER*80 FNAME2
      CHARACTER*14 GNO
      CHARACTER*12 P1
      CHARACTER*8 SNAME,BL
      CHARACTER*1 ANSW,ANS1,ANS2,ANS3,ANS4,ANS5,ANS6
      CHARACTER*4 TYPEL,CKNUM,CARDT
       REAL*8 INLTS
       REAL*8 INLNS
       REAL*8 LATMTR
       REAL*8 LONMTR
       REAL*8 OLDLAT
       REAL*8 OLDLON
      DIMENSION SNAME(NSTA,4),X1(NSTA),Y1(NSTA)
      DIMENSION X2(NSTA),Y2(NSTA),FLAT(NSTA),FLON(NSTA)
      DIMENSION OLDLAT(NSTA),OLDLON(NSTA),V(2*NSTA)
      DIMENSION ICOM(NSTA),IFL(8),ANS(6)
      DIMENSION PREC(6),Q(21)
      DIMENSION BL(1)
      DIMENSION IFLL(2)
 
      COMMON ROSEC,RODEG,PI
C
      DATA BL/'        '/
      DATA TYPEL/'*  *'/
      DATA CARDT/'    '/
      COUNT=0
C
C
C     GET ALL THE INPUT FILES AND CHECK TO IF THEY VALID
C
      PRINT *, '              '
      PRINT *, '              '
      PRINT *, '              '
      WRITE(6,5000)'             PROGRAM LEFTI        '
      WRITE(6,5000)'           LAST UPDATE 11/13/87'
      WRITE(6,5000)'           VERSION NUMBER 3 '
      WRITE(6,5000)'     '
C
 4999 WRITE(6,5000)' NAME OF POSITION DECK TO BE TRANSFORMED '
      WRITE(6,5000)'  (USERS BLUE BOOK DECK) '
      WRITE(6,5000)'  IE: DIRECTORY NAME AND FILE NAME    '
      WRITE(6,5000)'  EXAMPLE  C:BLUEBOOK THIS IS FOR FILE BLUEBOOK'
      WRITE(6,5000)'  IN DIRECTORY C '
      WRITE(6,5000)' TYPE FILE NAME ??    '
      READ(5,5000) INFILE
      OPEN (91,FILE=INFILE,STATUS='OLD',ERR=5001)
      GO TO 5002
 5001 PRINT *,INFILE
      PRINT *,' THIS FILE DOES NOT EXIST'
      GO TO 4999
 5002 WRITE(6,5000)'  NAME OF COMMON FILE RECORDS -- '
      WRITE(6,5000)'  (COMMON STATIONS ) '
      WRITE(6,5000)'  IE: SAME FORMAT AS ABOVE '
      WRITE(6,5000)' TYPE FILE NAME ??    '
      READ(5,5000) COMFILE
 
      OPEN (90,FILE=COMFILE,STATUS='OLD',ERR=5003)
      GO TO 5004
 5003 PRINT *,COMFILE
      PRINT *,' THIS FILE DOES NOT EXIST'
      GO TO 5002
 5004 CONTINUE
      OPEN (3,STATUS='SCRATCH',FORM='UNFORMATTED')
      OPEN (4,STATUS='SCRATCH',FORM='UNFORMATTED')
      OPEN (8,STATUS='SCRATCH',FORM='UNFORMATTED')
      OPEN (9,STATUS='SCRATCH',FORM='FORMATTED')
      OPEN (7,STATUS='SCRATCH',FORM='UNFORMATTED')
      OPEN (10,STATUS='SCRATCH',FORM='FORMATTED')
      FNAME2=INFILE
      FNAME1=COMFILE
 
      WRITE(6,5000)'  NAME OF OUTPUT FILE TO BE USED '
      WRITE(6,5000)'  IE: SAME FORMAT AS ABOVE '
      WRITE(6,5000)' TYPE FILE NAME ??    '
      READ(5,5000) OUTFILE
 4000 OPEN(11,FILE=OUTFILE,STATUS='NEW',ERR=4005)
      GO TO 4010
 4005 PRINT *, OUTFILE
      PRINT *,' THIS FILE ALREADY EXISTS OR THE FILE NAME FORMAT'
      PRINT *,' IS WRONG. '
      WRITE(6,5000)' DO YOU WANT TO WRITE OVER THIS FILE? '
      WRITE(6,5000)' ANSWER Y OR N '
      WRITE(6,5000)' TYPE ANSWER !!!  '
      READ(5,5000) YORN
 
       IF(YORN.EQ.'Y') THEN
        OPEN(11,FILE=OUTFILE,STATUS='UNKNOWN')
       ELSE
        WRITE(6,5000)'  NAME OF OUTPUT FILE TO BE USED '
        WRITE(6,5000)'  IE: SAME FORMAT AS ABOVE '
        WRITE(6,5000)' TYPE FILE NAME ??    '
        READ(5,5000) OUTFILE
        GO TO 4000
       ENDIF
 4010 CONTINUE
 5000 FORMAT(A)
      REWIND(UNIT=90)
      REWIND(UNIT=91)
      REWIND(UNIT=3)
      REWIND(UNIT=4)
      REWIND(UNIT=8)
      REWIND(UNIT=9)
      REWIND(UNIT=7)
      REWIND(UNIT=11)
      REWIND(UNIT=10)
C
      IUNIT=7
      CALL INFORM(ER1,RF1,ER2,RF2,TITLE,IFL)
C
      CALL PRTYPE(ANSW,ANS1,ANS2,ANS3,ANS4,ANS5,ANS6,IFLL)
C
      PI=DATAN(1.D0)*4.D0
      RODEG=180.D0/PI
      ROSEC=RODEG*3600.D0
      E2=0.0066943800229D0
      SUMXL=0.
      SUMLAT=0.
      SECIN=IFLL(1)*60.+IFLL(2)*6.
      INTS=SECIN +0.5
      IF(INTS.LT.60) INTS=450
      I=0
      NEWFIX=0
C
C      BASE STATIONS, NEW COORDINATES (COMMON STATIONS)
C
  100 CONTINUE
      I=I+1
      READ(90,101,END=200)GNO,(SNAME(I,J),J=1,4),ID,IM,SLAT,JD,JM,SLON,
     &  P1
  101 FORMAT(A14,3A8,A6,T45,2I2,BZ,F7.5,T57,I3,I2,BZ,F7.5,A12)
      IF(SNAME(I,1).EQ.BL(1)) GO TO 200
      NEWFIX=NEWFIX + 1
C
C     TEST NUMBER OF COMMON STATIONS
C
       IF(NEWFIX.GT.500) THEN
        PRINT *,'        '
        PRINT *,'  NUMBER OF COMMON STATIONS ALLOWED EXCEEDED '
        PRINT *,'        '
        PRINT *, '            ********* JOB HALTED ********* '
            GO TO 9010
       ENDIF
 
      WRITE(3)GNO,(SNAME(I,J),J=1,4),ID,IM,SLAT,JD,JM,SLON,
     & P1
      CALL DMSTOR(ID,IM,SLAT,FLAT(I))
      CALL DMSTOR(JD,JM,SLON,FLON(I))
      FLON(I)=-FLON(I)
      SUMXL=SUMXL+FLON(I)
      SUMLAT=SUMLAT+FLAT(I)
      GO TO 100
C
  200 CONTINUE
 
 
      CM=SUMXL/NEWFIX
      FN=ER2*(SUMLAT/NEWFIX)
      K=(CM*RODEG)*60-0.5
      CM=K
      CM=CM*60./ROSEC
      DO 201 I=1,NEWFIX
      ICOM(I) = 0
  201 OLDLAT(I)=0.
      TEST=0.0003
      NOLSTA=0
      NCOMN=0
C
C      OLD COORDINATES
C
  210 CONTINUE
      READ(91,901,END=300) CARDR
 901  FORMAT(A80)
       IF(CARDR(7:10).EQ.'    ') THEN
         CALL CKOBS(CARDR,TYPEL,CKNUM,CARDT,FNAME2)
       ELSEIF (CARDR(7:10).NE.'*80*') THEN
         CALL PRINTR(CARDR,TYPEL,CARDT,COUNT)
         GO TO 210
       ENDIF
C
       IF(CKNUM.EQ.'TRUE') THEN
         GO TO 300
       ENDIF
      READ(CARDR,102)GNO,NAME,ID,IM,SLAT,JD,JM,SLON,
     &  P1
  102 FORMAT(A14,A30,2I2,BZ,F7.5,1X,I3,I2,BZ,F7.5,A12)
C
      CARDT=GNO(7:10)
      COUNT=COUNT+1
C
C
       IF(NAME(1:8).EQ.BL(1)) GO TO 300
      CALL DMSTOR(ID,IM,SLAT,XLAT)
      CALL DMSTOR(JD,JM,SLON,XLON)
      KK=0
      XLON=-XLON
      DO 211 K=1,NEWFIX
      IF(NAME(1:8).NE.SNAME(K,1).OR.NAME(9:16).NE.SNAME(K,2).OR.
     & NAME(17:24).NE.SNAME(K,3).OR.NAME(25:30).NE.SNAME(K,4)) GO TO 211
      IF(DABS(XLAT-FLAT(K)).LT.TEST.AND.DABS(XLON-FLON(K)).LT.
     &  TEST) GO TO 213
      WRITE(6,290) NAME,ID,IM,SLAT,JD,JM,SLON
  290 FORMAT(1X, 3A8,A6,2(I5,I3,F9.5), 2X,'REJECTED')
      FLAT(K)=0.
      ICOM(K) = 1
      GO TO 210
  213 CONTINUE
      NCOMN=NCOMN+1
      OLDLAT(K)=XLAT
      OLDLON(K)=XLON
      KK=K
      ICOM(K) = 1
      GO TO 214
  211 CONTINUE
  214 CONTINUE
      NOLSTA=NOLSTA+1
      WRITE(3)GNO,NAME,ID,IM,SLAT,JD,JM,SLON,P1
      WRITE(4) NAME,XLAT,XLON,KK
      GO TO 210
  300 CONTINUE
C
C     CHECK FOR MISSING OLD STATIONS
C     (I.E. , A BASE STATION DOES NOT HAVE A CORRESPONDING OLD STATION)
C
      IFLAGZ=0
      DO 320 III = 1,NEWFIX
      IF(ICOM(III) .EQ. 0) GO TO 330
  320 CONTINUE
  325 IF(IFLAGZ .EQ. 1) GO TO 9000
      GO TO 350
  330 WRITE(6,335) (SNAME(III,J),J=1,4)
  335 FORMAT(///20X,' COMMON STATION THAT DOES NOT HAVE AN OLD STATION
     1-  ',4A8)
      IFLAGZ=1
      GO TO 325
C
C      OUTPUT OLD AND NEW COORDINATES OF COMMON STATIONS
C
C
C
C
  350 KOUNT=0
      KIND=1
      IPAGE=0
      DO 301 I=1,NEWFIX
      IF(OLDLAT(I).EQ.0.) GO TO 301
      CALL RTODMS(OLDLAT(I),IDOLD,IMOLD,ASOLD)
      CALL RTODMS(-OLDLON(I),JDOLD,JMOLD,BSOLD)
      CALL RTODMS(FLAT(I),IDNEW,IMNEW,ASNEW)
      CALL RTODMS(-FLON(I),JDNEW,JMNEW,BSNEW)
         IF((ANSW.EQ.'Y').OR.(ANS1.EQ.'Y')) THEN
      CALL PAGE(IPAGE,KOUNT,KIND)
      WRITE(6,390) (SNAME(I,J),J=1,4),IDOLD,IMOLD,ASOLD, JDOLD,
     & JMOLD,BSOLD,IDNEW,IMNEW,ASNEW,JDNEW,JMNEW,BSNEW
  390 FORMAT(1X,3A8,A6,BZ,4(I6,I3,F9.5))
         ENDIF
      WRITE(8) (SNAME(I,J),J=1,4),IDNEW,IMNEW,ASNEW,JDNEW,JMNEW,BSNEW
  301 CONTINUE
C
C      TRANSFORMATION CONSTANTS (GEO TO GRID AND VICE VERSA)
C
      CM2=CM
      CM1=CM2
      BB1=ER1*(1.-1./RF1)
      EPS1=(ER1**2-BB1**2)/BB1**2
      PRC1=ER1**2/BB1
      EN1=(ER1-BB1)/(ER1+BB1)
      A1=1.+3.*EN1*(-1.+1.75D0*EN1*(1.-1.47*EN1))
      B1=(A1-1.)/A1+.4E-10
      C1=-2.5D0*EN1*(1.+1.86D0*EN1)
      D1=1.234*C1
      BB2=ER2*(1.-1./RF2)
      EPS2=(ER2**2-BB2**2)/BB2**2
      PRC2=ER2**2/BB2
      EN2=(ER2-BB2)/(ER2+BB2)
      A2=1.+3.*EN2*(-1.+1.75D0*EN2*(1.-1.47*EN2))
      B2=(A2-1.)/A2+.4E-10
      C2=-2.5D0*EN2*(1.+1.86D0*EN2)
      D2=1.234*C2
      F2=1.-A2+1.4E-10
      G2=3.5D0*EN2*(1.-3.059*EN2)
      H2=1.388*G2
      IF(IFL(1).NE.0.AND.NCOMN.LT.4) IFL(1)=0
C
C      CONVERT BASE STATION COORDINATES TO X,Y. 1=OLD,2=NEW.
C
      DO 400 I=1,NEWFIX
      IF(OLDLAT(I).EQ.0.) FLAT(I)=0.
      CALL TOGRID(CM1,PRC1,EPS1,A1,B1,C1,D1,OLDLAT(I),OLDLON(I),FN,
     &   X1(I),Y1(I))
      CALL TOGRID(CM2,PRC2,EPS2,A2,B2,C2,D2,FLAT(I),FLON(I),FN,
     & X2(I),Y2(I))
  400 CONTINUE
C
C      ADJUSTMENT OF DATA
 
C
      IF (IFL(1).NE.0) GO TO 507
      CALL ROSTRA(X1,Y1,X2,Y2,NEWFIX,NCOMN,SIGMA,ANS,PREC,Q,V,IUNIT)
      GO TO 508
  507 CONTINUE
      CALL AFFINE(X1,Y1,X2,Y2,NEWFIX,NCOMN,SIGMA,ANS,PREC,Q,V,IUNIT)
  508 CONTINUE
C
C   OUTPUT FIXED STATIONS AND RESIDUALS
C
      KOUNT=0
      KIND=2
      REWIND 3
      REWIND 4
      REWIND 8
 1000 DO 500 I=1,NEWFIX
      READ(3) GNO,NAME,ID,IM,SLAT,JD,JM,SLON,P1
      READ(8) (SNAME(I,J),J=1,4),IDNEW,IMNEW,ASNEW,JDNEW,JMNEW,BSNEW
C
C
      ISEC = ASNEW * 1.0D5 + 0.5D0
      JSEC = BSNEW * 1.0D5 + 0.5D0
      WRITE(9,594) GNO,NAME,IDNEW,IMNEW,ISEC,
     1JDNEW,JMNEW,JSEC,P1
C
         IF((ANSW.EQ.'Y').OR.(ANS2.EQ.'Y')) THEN
C
      CALL PAGE(IPAGE,KOUNT,KIND)
      WRITE(6,590) NAME,IDNEW,IMNEW,ASNEW,JDNEW,JMNEW,BSNEW
  590 FORMAT(1X,A30,BZ,2(I5,I3,F9.5))
      IF(X1(I).EQ.0.) GO TO 500
      K=I+I-1
      L=K+1
      WRITE(6,591) V(K),V(L)
  591 FORMAT(1H+,70X,2F8.3)
         ENDIF
  500 CONTINUE
C
C      OUTPUT ALL STATIONS
C
      XMAX=0.
      XMIN=ER1
      YMAX=0.
      YMIN=XMIN
      KOUNT=0
      KIND=3
      DO 501 I=1,NOLSTA
      READ(3) GNO,NAME,ID,IM,SLAT,JD,JM,SLON,P1
      READ(4) NAME,XLAT,XLON,KK
      IF(KK.EQ.0) GO TO 502
      XLAT=FLAT(KK)
      XLON=FLON(KK)
      GO TO 503
  502 CONTINUE
C
C      MAXIMUM AND MINIMUM VALUES OF COORDINATES
C
      XMAX=DMAX1(XMAX,XLAT)
      XMIN=DMIN1(XMIN,XLAT)
      YMAX=DMAX1(YMAX,-XLON)
      YMIN=DMIN1(YMIN,-XLON)
      CALL TOGRID(CM1,PRC1,EPS1,A1,B1,C1,D1,XLAT,XLON,FN,XX,YY)
      IF(IFL(1).NE.0) GO TO 511
      XX=ANS(1)+ANS(3)*(-YY)+ANS(4)*XX
      YY=ANS(2)+ANS(3)*(XX)+ANS(4)*YY
      GO TO 512
  511 CONTINUE
      XX=ANS(1)+ANS(2)*YY+ANS(3)*XX
      YY= ANS(4)+ANS(5)*XX+ANS(6)*YY
  512 CONTINUE
      IF(KK.NE.0) GO TO 504
      CALL REFINE(X2,Y2,V,NEWFIX,NCOMN,XX,YY,CX,CY)
  504 CONTINUE
      CALL TOGEO(CM2,PRC2,EPS2,A2,F2,G2,H2,XX,YY,FN,XLAT,XLON)
  503 CONTINUE
      XLON=-XLON
      CALL RTODMS(XLAT,IDNEW,IMNEW,ASNEW)
      CALL RTODMS(XLON,JDNEW,JMNEW,BSNEW)
      ISEC = ASNEW * 1.0D5 + 0.5D0
      JSEC = BSNEW * 1.0D5 + 0.5D0
      WRITE(9,594) GNO,NAME,IDNEW,IMNEW,ISEC,
     1JDNEW,JMNEW,JSEC,P1
      IF(KK.NE.0) GO TO 505
      CALL PAGE(IPAGE,KOUNT,KIND)
      WRITE(6,592) NAME,ID,IM,SLAT,JD,JM,SLON,
     &  IDNEW,IMNEW,ASNEW,JDNEW,JMNEW,BSNEW
  592 FORMAT(1X,A30,BZ,4(I6,I3,F9.5))
      WRITE(6,593) CX,CY
  593 FORMAT(1H+,102X,2F10.3)
C
C
      WRITE(10,595) NAME,ID,IM,SLAT,JD,JM,SLON,
     &              IDNEW,IMNEW,ASNEW,JDNEW,JMNEW,BSNEW
C
C
      GO TO 501
  505 CONTINUE
  594 FORMAT(A14,A30,2I2.2,I7.7,1HN,I3.3,I2.2,I7.7,A12)
  595 FORMAT(A30,2X,I2.2,2X,I2.2,F9.5,2X,I3.3,2X,I2.2,F9.5,
     &       2X,I2.2,2X,I2.2,F9.5,2X,I3.3,2X,I2.2,F9.5)
  501 CONTINUE
C
C
      REWIND(UNIT=91)
      REWIND(UNIT=9)
      CALL SORT
C
C
C      SHIFTS AT INTERSECTIONS
C
C
C
C
      KOUNT=0
      KIND=4
      MINX=XMIN*ROSEC
      MAXX=XMAX*ROSEC
      MINY=YMIN*ROSEC
      MAXY=YMAX*ROSEC
      MINX=(MINX/INTS)*INTS-INTS
      MAXX=(MAXX/INTS)*INTS+INTS
      MINY=(MINY/INTS)*INTS-INTS
      MAXY=(MAXY/INTS)*INTS+INTS
C
      DO 600 I=MINX,MAXX,INTS
      DO 600 J=MINY,MAXY,INTS
      XLAT=I/ROSEC
      XLON=-J/ROSEC
      CALL TOGRID(CM1,PRC1,EPS1,A1,B1,C1,D1,XLAT,XLON,FN,XX,YY)
      IF(IFL(1).NE.0) GO TO 611
      XX=ANS(1)+ANS(3)*(-YY)+ANS(4)*XX
      YY=ANS(2)+ANS(3)*XX+ANS(4)*YY
      GO TO 612
  611 CONTINUE
      XX=ANS(1)+ANS(2)*YY+ANS(3)*XX
      YY=ANS(4)+ANS(5)*XX+ANS(6)*YY
  612 CONTINUE
      CALL REFINE(X2,Y2,V,NEWFIX,NCOMN,XX,YY,CX,CY)
      CALL TOGEO(CM2,PRC2,EPS2,A2,F2,G2,H2,XX,YY,FN,CLAT,CLON)
      SHLATS=(CLAT-XLAT)*ROSEC
      SHLONS=-(CLON-XLON)*ROSEC
      CALL RTODMS(XLAT,IDX,IMX,SECLAT)
      CALL RTODMS(-XLON,IDY,IMY,SECLON)
      ISLAT=SECLAT+0.5
      ISLON=SECLON+0.5
C
C
C     COMPUTE SHIFTS IN METERS A INTERSECTION POINTS
C
      CALL RTODMS(CLAT,INLTD,INLTM,INLTS)
      CALL RTODMS(-CLON,INLND,INLNM,INLNS)
 
      AVLAT=(CLAT+XLAT)/2.0D0
 
      W=DSQRT(1.0D0-E2*DSIN(AVLAT)**2)
 
      LM=ER2*(1.0D0-E2)/(W**3*ROSEC)
      LP=ER2*DCOS(AVLAT)/(W*ROSEC)
 
      LATMTR=LM*SHLATS
      LONMTR=LP*SHLONS
 
C
          IF((ANSW.EQ.'Y').OR.(ANS4.EQ.'Y')) THEN
      CALL PAGE(IPAGE,KOUNT,KIND)
C
      WRITE(6,601)IDX,IMX,ISLAT,IDY,IMY,ISLON,SHLATS,SHLONS,
     & INLTD,INLTM,INLTS,INLND,INLNM,INLNS,LATMTR,LONMTR
  601 FORMAT(1X,2(I8,2I3),2F12.5,T57,I2.2,T60,I2.2,T63,F8.5,
     &  T74,I3.3,T78,I2.2,T81,F8.5,T94,F7.2,T105,F7.2)
 
          ENDIF
 
  600 CONTINUE
C
C      JOB DATA
C
  605 ROT=DATAN2(ANS(3),ANS(4))*ROSEC
      SIGROT=PREC(3)*ROSEC
      SCALE=(DSQRT(ANS(3)**2+ANS(4)**2)-1.)*1.D06
      SIGSC=PREC(4)*1.D06
      CM1=-CM1*RODEG
      CM2=-CM2*RODEG
      IPAGE=IPAGE+1
      WRITE(6,800) IPAGE,TITLE
  800 FORMAT(1H1,100X,'PAGE',I4,//,1X,'JOB STATISTICS',//,1X,
     & 'PROJECT TITLE:', 2X, A32,///)
      IF(IFL(1).EQ.1) GO TO 810
      WRITE(6,801)
  801 FORMAT(9X,'OLD',12X,'NEW',39X,'SHIFT N',3X,'SHIFT E', 4X,
     & 'ROT.ANGLE',3X,'SCALE (PPM)',/)
      WRITE(6,802) ER1,ER2,ANS(1),ANS(2),ROT,SCALE
  802 FORMAT(1X,'A',2F15.3,27X,'VALUE',F9.3,F10.3,F11.3,F12.2)
      WRITE(6,803) RF1,RF2,PREC(1),PREC(2),SIGROT,SIGSC
  803 FORMAT(1X,'1/F', F13.7,F15.7,27X,'S.E',2F10.3,F11.3,F12.2)
      GO TO 811
  810 CONTINUE
      WRITE(6,890)
  890 FORMAT(1X,'TRANSFORMATION CONSTANTS',//,6X,'OLD',15X,'NEW',17X,
     & 'K1',10X,'K2',12X,'K3',10X,'K4',10X,'K5',12X,'K6',/)
      WRITE(6,891) ER1,ER2,(ANS(J),J=1,6)
  891 FORMAT(1X,'A',2F15.3,8X,2(F10.3,2F14.9))
      WRITE(6,892) RF1,RF2,(PREC(J),J=1,6)
  892 FORMAT(1X,'1/F',F13.7,F15.7,5X,'S.E.',2(F9.3,2F14.9,1X))
  811 CONTINUE
      WRITE(6,804) CM1,CM2,SIGMA
  804 FORMAT(1X,'C.M.', F12.7,F15.7,//,1X,'GAUSS-KRUEGER PROJECTION',
     & //,1X,'STANDARD ERROR OF UNIT WEIGHT =', F8.3,/)
      WRITE(6,805) NOLSTA,NCOMN
  805 FORMAT(I5, ' STATIONS',/, I5, ' COMMON STATIONS')
 9000 IF( IFLAGZ .EQ. 1) WRITE(6,9005)
 9005 FORMAT(////40X,'*****  JOB HALTED  *****'//)
C
      IF((ANSW.EQ.'Y').OR.(ANS5.EQ.'Y')) THEN
       REWIND (UNIT=10)
       CALL SECOND
      ENDIF
 
      IF ((ANSW.EQ.'Y').OR.(ANS6.EQ.'Y')) THEN
       REWIND (UNIT=10)
       CALL METERS
      ENDIF
C
C   CLOSE ALL FILES
C
 9010 CLOSE(UNIT=90,STATUS='KEEP')
      CLOSE(UNIT=91,STATUS='KEEP')
      CLOSE(UNIT=11,STATUS='KEEP')
      CLOSE (UNIT=3,STATUS='DELETE')
      CLOSE (UNIT=4,STATUS='DELETE')
      CLOSE (UNIT=8,STATUS='DELETE')
      CLOSE (UNIT=9,STATUS='DELETE')
      CLOSE (UNIT=7,STATUS='DELETE')
      CLOSE (UNIT=10,STATUS='DELETE')
 
      STOP
      END
