C
C
C
C    THIS VERSION WAS DONE     DATE 01/31/86
C                              E. CARLSON
C
C
C
      SUBROUTINE INFORM(ER1,RF1,ER2,RF2,TITLE,IFL)
C
C
      CHARACTER*1 YORN
      CHARACTER*32 TITLE
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER RS1,RS2
      DIMENSION IFL(8)
C
      WRITE(6,1000)'  ARE YOU TRANSFORMING STATIONS FROM NAD27 '
      WRITE(6,1000)'  TO GRS 80 (NAD83)  ? '
      WRITE(6,1000)'  TYPE Y OR N ??? '
      READ(5,1005) YORN
C
      IF(YORN.EQ.'Y') THEN
         ER1=6378206.400D0
         RF1=294.9786982D0
         ER2=6378137.000D0
         RF2=298.2572221D0
      ELSE
         WRITE(6,1000)'  TYPE THE NUMBER OF THE OLD REFERENCE ELLIPSOID'
         WRITE(6,1000)'   1 - CLARKE 1866 (US STANDARD DATUM, NAD,'
         WRITE(6,1000)'       NAD27 )'
         WRITE(6,1000)'   2 - BESSEL '
         WRITE(6,1000)'   3 - GRS 80 (NAD83) '
         WRITE(6,1000)'   4 - OTHER '
         WRITE(6,1000)'  TYPE CORRECT NUMBER ?  '
         READ(5,1001) RS1
C
         CALL OLDSHD(RS1,ER1,RF1)
C
         WRITE(6,1000)'  TYPE THE NUMBER OF THE NEW REFERENCE ELLIPSOID'
         WRITE(6,1000)'   1 - CLARKE 1866 (US STANDARD DATUM, NAD,'
         WRITE(6,1000)'       NAD27 )'
         WRITE(6,1000)'   2 - BESSEL '
         WRITE(6,1000)'   3 - GRS 80 (NAD83) '
         WRITE(6,1000)'   4 - OTHER '
         WRITE(6,1000)'  TYPE CORRECT NUMBER ?  '
         READ(5,1001) RS2
C
         CALL NEWSHD(RS2,ER2,RF2)
      ENDIF
C
      IFL(1)=0
C
 400  WRITE(6,1000)' TYPE THE TITLE (32 CHARACTERS MAX) ?     '
      READ(5,1004) TITLE
C
 1000 FORMAT(A)
 1001 FORMAT(BZ,I1)
 1002 FORMAT(BZ,I2)
 1003 FORMAT(BZ,I1,I1)
 1004 FORMAT(A32)
 1005 FORMAT(A1)
C
      RETURN
      END
C
C
      SUBROUTINE OLDSHD(RS1,ER1,RF1)
C
      IMPLICIT REAL*8(A-H,O-Z)
      INTEGER RS1
      GO TO (1,2,3,4),RS1
    1 ER1=6378206.400D0
      RF1=294.9786982D0
      RETURN
    2 ER1=6377397.000D0
      RF1=299.1500000D0
      RETURN
    3 ER1=6378137.000D0
      RF1=298.2572221D0
      RETURN
    4 WRITE(6,1000)'  TYPE OLD EQUATORIAL RADIUS OF THE EARTH (METERS)'
      WRITE(6,1000)'  IE: 6378137.000 TO THREE DECIMAL PLACES  '
      WRITE(6,1000)'  TYPE THE VALUE ??  '
      READ(5,1001) ER1
C
      WRITE(6,1000)'  TYPE OLD FLATTENING OF THE REFERENCE ELLIPSOID '
      WRITE(6,1000)'  IE: 298.25722222 TO SEVEN DECIMAL PLACES  '
      WRITE(6,1000)'  TYPE THE VALUE ??  '
      READ(5,1002) RF1
C
 1000 FORMAT(A)
 1001 FORMAT(BZ,F12.4)
 1002 FORMAT(BZ,F12.8)
C
      RETURN
      END
C
C
      SUBROUTINE NEWSHD(RS2,ER2,RF2)
C
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER RS2
      GO TO (1,2,3,4),RS2
    1 ER2=6378206.400D0
      RF2=294.9786982D0
      RETURN
    2 ER2=6377397.000D0
      RF2=299.1500000D0
      RETURN
    3 ER2=6378137.000D0
      RF2=298.2572221D0
      RETURN
    4 WRITE(6,1000)'  TYPE NEW EQUATORIAL RADIUS OF THE EARTH (METERS)'
      WRITE(6,1000)'  IE: 6378137.000 TO THREE DECIMAL PLACES  '
      WRITE(6,1000)'  TYPE THE VALUE ??  '
      READ(5,1001) ER2
C
      WRITE(6,1000)'  TYPE NEW FLATTENING OF THE REFERENCE ELLIPSOID '
      WRITE(6,1000)'  IE: 298.25722222 TO SEVEN DECIMAL PLACES  '
      WRITE(6,1000)'  TYPE THE VALUE ??  '
      READ(5,1002) RF2
C
 1000 FORMAT(A)
 1001 FORMAT(BZ,F12.4)
 1002 FORMAT(BZ,F12.8)
C
      RETURN
      END
C
      SUBROUTINE CKOBS(CARDR,TYPEL,CKNUM,CARDT,FNAME2)
C
      CHARACTER*4 TYPEL,CKNUM,CARDT
      CHARACTER*80 CARDR
      CHARACTER*80 FNAME
      CHARACTER*80 FNAME2
      FNAME=FNAME2
C
      IF(CARDT.EQ.TYPEL) THEN
        CKNUM='TRUE'
      ELSE
        CALL ABORT(CARDR,FNAME)
      ENDIF
      RETURN
      END
C
C
      SUBROUTINE ABORT(CARDR,FNAME)
C
      CHARACTER*80 CARDR
      CHARACTER*80 FNAME
C
      WRITE(6,1)
 1    FORMAT('0')
      WRITE(6,2)
 2    FORMAT(1X,120('*'))
 
      PRINT *, FNAME,'  HAS INVALID RECORD'
      PRINT *, CARDR,'  LAST RECORD READ'
 
      WRITE(6,3)
 3    FORMAT(//' ***** FATEL TERMINATION - - FATAL TERMINATION !!'/)
      WRITE(6,2)
      STOP
      END
C
C
      SUBROUTINE PRINTR(CARDR,TYPEL,CARDT,COUNT)
C
      CHARACTER*80 CARDR
      CHARACTER*4 TYPEL,CARDT
      INTEGER COUNT
C
      COUNT=COUNT+1
      IF(COUNT.LE.1) THEN
        TYPEL=CARDR(7:10)
      ELSE
        CARDT=CARDR(7:10)
      ENDIF
      RETURN
      END
C
C
      SUBROUTINE SORT
C
      CHARACTER*80 CARDRC
C
 50      READ(91,100,END=200) CARDRC
 100     FORMAT(A80)
         IF(CARDRC(7:10).NE.'*80*') THEN
            WRITE(11,100) CARDRC
         ELSE
            CALL SAMERC(CARDRC)
         ENDIF
       GO TO 50
 200  CONTINUE
         RETURN
         END
C
C
      SUBROUTINE SAMERC(CARDRC)
C
      CHARACTER*80 CARDRC,CARD
C
 50      READ(9,100,END=200) CARD
 100     FORMAT(A80)
           IF(CARDRC(15:44).EQ.CARD(15:44)) THEN
             WRITE(11,120) CARD(1:68),CARDRC(69:80)
 120          FORMAT(A68,A12)
             GO TO 200
           ENDIF
      GO TO 50
 200  CONTINUE
      RETURN
      END
C
C
      SUBROUTINE CKFILE(FNAME1,FNAME2)
C
      CHARACTER*80 CARDR
      CHARACTER*80 FNAME
      CHARACTER*80 FNAME1,FNAME2
C
 50   READ(90,100,END=200) CARDR
       IF(CARDR(7:10).EQ.'    ') THEN
        GO TO 50
       ELSE
        FNAME=FNAME1
        CALL ABORT(CARDR,FNAME)
       ENDIF
 100   FORMAT(A80)
 200   CONTINUE
 150  READ(91,100,END=250) CARDR
        IF(CARDR(7:7).EQ.'*') THEN
         GO TO 150
        ELSE
         FNAME=FNAME2
         CALL ABORT(CARDR,FNAME)
        ENDIF
 250  CONTINUE
       RETURN
       END