aboutsummaryrefslogtreecommitdiff
path: root/htdp.for
diff options
context:
space:
mode:
authorSriReddy-NOAA <Srinivas.Reddy@noaa.gov>2021-04-09 00:11:44 -0400
committerSriReddy-NOAA <Srinivas.Reddy@noaa.gov>2021-04-09 00:11:44 -0400
commite1fc5ad517ae4dc12c532841abe9e28b0486c954 (patch)
treef07205cb4ecd3bba207d38e951fffea37cc40533 /htdp.for
parent47aa45faf1c9503106c6a501d4b8c431fc2cc270 (diff)
Version 3.2.8
Diffstat (limited to 'htdp.for')
-rw-r--r--htdp.for9123
1 files changed, 0 insertions, 9123 deletions
diff --git a/htdp.for b/htdp.for
deleted file mode 100644
index 4c7baff..0000000
--- a/htdp.for
+++ /dev/null
@@ -1,9123 +0,0 @@
- PROGRAM HTDP
-
-**************************************************************
-* NAME: HTDP (Horizontal Time-Dependent Positioning)
-*
-* WRITTEN BY: Richard A. Snay & Chris Pearson
-*
-* PURPOSE: Transform coordinates across time
-* and between reference frames
-*
-****************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
-
- character HTDP_version*10
- CHARACTER OPTION*1
- character cont*5
-
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
- COMMON /VERSION/ HTDP_version
-
-C You must change HTDP version here if necessary
-
- HTDP_version = 'v3.2.7'
-
-*** Introduce variables for file id's
-
- LUIN = 5
-* interactive input
- LUOUT = 6
-* interactive output
- I1 = 11
-* input of velocity grid in GETVEL
-* input of earthquake parameters in GETEQ
-* input of blue-book BFILE in DLACE, VELOC, UPDATE and TRFPOS
-* input of blue-book GFILE in UPDATE
- I2 = 12
-* output of predicted displacements in DLACE
-* output of predicted velocities in VELOC
-* output of updated blue-book BFILE in UPDATE
-* output of updated blue-book GFILE in UPDATE
-* output of updated coordinates in UPDATE
- I3 = 13
-* output of point-velocity records in VELOC
- I4 = 14
-* storage of reference latitude & longitude & region
- I5 = 15
-* storage of earthquake parameters
-C OPEN(I5, FILE='TEMPQK' , ACCESS = 'DIRECT', RECL = 72,
-C 1 FORM='UNFORMATTED')
- I6 = 16
-* output of transformed blue-book BFILE in TRFPOS
-
-*** Obtain parameters defining crustal motion model
- CALL MODEL
-
-*** Initialize transformation parameters between reference frames
- CALL SETTP
-
-*** Initialize conversion table between reference frame identifiers
- CALL SETRF
-
- WRITE(LUOUT,5) HTDP_version
- 5 FORMAT(
- 1 '********************************************************'/
- 1 '* HTDP (Horizontal Time-Dependent Positioning) *'/
- 1 '* SOFTWARE VERSION ',a10 /
- 1 '* *'/)
- WRITE(LUOUT,501)
- 501 FORMAT(
- 1 '* AUTHORS: Richard Snay, Chris Pearson & Jarir Saleh *'/
- 1 '* Email: ngs.cors.htdp@noaa.gov *'/
- 1 '* *'/
- 1 '********************************************************'/)
- WRITE(LUOUT,10)
- 10 FORMAT(
- 1 ' This software incorporates numerical models that',/
- 3 ' characterize continuous crustal motion as well as ',/
- 3 ' the episodic motion associated with earthquakes.'/)
- WRITE(LUOUT,11)
- 11 FORMAT(
- 5 ' The User Guide contains additional information and a set'/
- 5 ' of exercises to familiarize users with the software.'//
- 5 ' Hit ENTER or RETURN to continue. ')
- read(luin, '(a5)',err=51,iostat=ios) cont
- if (ios /= 0) goto 51
-
- 25 WRITE(LUOUT,26)
- 26 FORMAT(' ***************************************'/
- 1 ' MAIN MENU:',/
- 6 ' 0... Exit software.',/
- 7 ' 1... Estimate displacements between two dates.'/
- 8 ' 2... Estimate velocities.'/
- 9 ' 3... Update positions and/or observations '
- & ,'to a specified date.'/
- & ' 4... Transform positions between reference frames. '/
- & ' 5... Transform velocities between reference frames. ')
- 30 READ(LUIN,35,err=52,iostat=ios) OPTION
- if (ios /= 0) goto 52
- 35 FORMAT(A1)
- IF(OPTION .EQ. '0') THEN
- GO TO 50
- ELSEIF(OPTION .EQ. '1') THEN
- CALL DPLACE
- ELSEIF(OPTION .EQ. '2') THEN
- CALL VELOC
- ELSEIF(OPTION .EQ. '3') THEN
- CALL UPDATE(HTDP_version)
- elseif(option .eq. '4') then
- call TRFPOS
- elseif(option .eq. '5') then
- call TRFVEL
- ELSE
- WRITE(LUOUT,40)
- 40 FORMAT(' Improper entry--select again ')
- GO TO 30
- ENDIF
- GO TO 25
- 50 CONTINUE
- stop
-C CLOSE(I5, STATUS = 'DELETE')
-
- 51 write (*,'(/)')
- write (*,*) 'You did not hit enter : ios = ',ios
- write (*,*) "ABNORMAL TERMINATION"
- STOP
-
- 52 write (*,'(/)')
- write (*,*) 'Problem with reading OPTION: ios = ',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- STOP
-
- END
-*****************************************************************************
- SUBROUTINE MODEL
-
-*** Obtain parameters defining crustal motion model
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
- COMMON /TIMREF/ ITREF
-
- A = 6.378137D06
- F = 1.D0 / 298.257222101D0
- E2 = 0.6694380022903146D-2
- AF = A / (1.D0 -F)
- EPS = F*(2.D0 - F) / ((1.D0 -F)**2)
- PI = 4.D0 * DATAN(1.D0)
- RHOSEC = (180.D0 * 3600.D0) / PI
- TWOPI = PI + PI
-
-C*** Set default reference epoch to Jan. 1, 2010
- IYRREF = 2010
- IMOREF = 1
- IDYREF = 1
- CALL IYMDMJ (IYRREF, IMOREF, IDYREF, MJD)
- ITREF = MJD * 24 * 60
-
- CALL GETBDY
-
- RETURN
- END
-
-*******************************************************************
- SUBROUTINE GETBDY
-
-*** Obtain coordinates for vertices that form the polygons
-*** that correspond to the boundaries for the regions.
-*** Region 1 is the San Andreas fault in central California
-*** Region 2 is southern California
-*** Region 3 is Northern California
-*** Region 4 is the Pacific Noerthwest
-*** Region 5 is western CONUS
-*** Region 6 is CONUS
-*** Region 7 is St. Elias, Alaska
-*** Region 8 is south-central Alaska
-*** Region 9 is southeast Alaska
-*** Region 10 is All Mainland Alaska
-*** Region 11 is the North American plate
-*** Region 12 is the Caribbean plate
-*** Region 13 is the Pacific plate
-*** Region 14 is the Juan de Fuca plate
-*** Region 15 is the Cocos plate
-*** Region 16 is the Mariana plate
-*** REGION 17 is the Philippine Sea plate
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (NMREGN = 17)
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
- COMMON /BNDRY/ X(4000), Y(4000), NPOINT(30)
-
- IEND = NPOINT(NMREGN + 1) - 1
- DO 10 J = 1, IEND
- X(J) = (X(J) * 3600.D0)/RHOSEC
- Y(J) = (Y(J) * 3600.D0)/RHOSEC
- 10 CONTINUE
- RETURN
- END
-*******************************************************************
- SUBROUTINE GETREG(X0,YKEEP,JREGN)
-
-*** Determine the region containing a given point.
-
- IMPLICIT DOUBLE PRECISION(A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (NMREGN = 17)
- COMMON /BNDRY/ X(4000), Y(4000), NPOINT(30)
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
- COMMON /CONST/ A, F, E2, EPS, AF, PI, TWOPI, RHOSEC
-
- Y0 = TWOPI - YKEEP
- IF (Y0 .lt. 0.d0) Y0 = Y0 + TWOPI
- IR = 0
- 1 IR = IR + 1
- IF(IR .GT. NMREGN) THEN
- JREGN = 0
- RETURN
- ENDIF
- IBEGIN = NPOINT(IR)
- NUMVER = NPOINT(IR + 1) - IBEGIN
- CALL POLYIN(X0,Y0,X(IBEGIN),Y(IBEGIN), NUMVER, NTEST)
- IF(NTEST .EQ. 0) GO TO 1
- JREGN = IR
-
- RETURN
- END
-********************************************************
- SUBROUTINE POLYIN (X0,Y0,X,Y,N,NPC)
-C SUBROUTINE TO DETERMINE IF A POINT AT (X0,Y0) IS INSIDE OR
-C OUTSIDE OF A CLOSED FIGURE DESCRIBED BY A SEQUENCE OF CONNECTED
-C STRAIGHT LINE SEGMENTS WITH VERTICES AT X, Y.
-C
-C INPUT -
-C X0, Y0 COORDINATES OF A POINT TO BE TESTED
-C Y0 corresponds to longitude and must be a number
-C between 0.0 and 2*PI
-C X, Y ARRAYS CONTAINING THE VERTICES, IN ORDER, OF A
-C CLOSED FIGURE DESCRIBED BY STRAIGHT LINE SEGMNENTS.
-C FOR EACH 'I', THE STRAIGHT LINE FROM (XI),Y(I)) TO
-C TO (X(I+1),Y(I+1)), IS AN EDGE OF THE FIGURE.
-C N DIMENSION OF X AND Y, NUMBER OF VERTICES, AND NUMBER
-C OF STRAIGHT LINE SEGMENTS IN FIGURE.
-C OUTPUT -
-C NPC NPC=0 WHEN X0,Y0 IS OUTSIDE OF FIGURE DESCRIBED
-C BY X,Y
-C NPC=1 WHEN X0,Y0 IS INSIDE FIGURE
-C NPC=2 WHEN X0,Y0 IS ON BORDER OF FIGURE
-C METHOD -
-C A COUNT IS MADE OF THE NUMBER OF TIMES THE LINE FROM (X0,Y0) TO
-C (X0,+ INFINITY) CROSSES THE BORDER OF THE FIGURE. IF THE COUNT
-C IS ODD, THE POINT IS INSIDE; IF THE COUNT IS EVEN THE POINT
-C IS OUTSIDE.
-C LIMITATIONS -
-C NONE. THE PROGRAM LOGIC IS VALID FOR ALL CLOSED FIGURES,
-C NO MATTER HOW COMPLEX.
-C ACCURACY -
-C MAINTAINS FULL ACCURACY OF INPUT COORDINATES.
-C
- IMPLICIT INTEGER*4 (I-N)
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- DIMENSION X(N),Y(N)
- DATA I6/6/
- IS=0
- NPC=0
-C
-C FIND STARTING POINT WHERE X(I).NE.X0
- IP=0
- 10 IP=IP+1
- IF ((X(IP)-X0) == 0) goto 12
- IF ((X(IP)-X0) < 0) goto 15
- IF ((X(IP)-X0) > 0) goto 16
-c IF (X(IP)-X0) 15,12,16
- 12 IF(IP.LE.N) GO TO 10
- WRITE(I6,6001)
- 6001 FORMAT('0 POLYGON INPUT ERROR - ALL POINTS ON LINE X = X0')
- STOP
- 15 IL=-1
- GO TO 20
- 16 IL=1
- 20 XL=X(IP)
- YL=Y(IP)
-C
-C SET UP SEARCH LOOP
-C
- IP1=IP+1
- IPN=IP+N
- DO 100 II=IP1,IPN
- I=II
- IF(I.GT.N) I=I-N
- IF(IL == 0) goto 50
- IF(IL < 0) goto 30
- IF(IL > 0) goto 40
-c IF(IL) 30,50,40
-
- 30 IF(X(I)-X0 == 0) goto 32
- IF(X(I)-X0 < 0) goto 90
- IF(X(I)-X0 > 0) goto 34
-c 30 IF(X(I)-X0) 90,32,34
- 32 IS=-1
- GO TO 60
- 34 IL=1
- GO TO 80
- 40 IF(X(I)-X0 == 0) goto 44
- IF(X(I)-X0 < 0) goto 42
- IF(X(I)-X0 > 0) goto 90
-c 40 IF(X(I)-X0) 42,44,90
- 42 IL=-1
- GO TO 80
- 44 IS=1
- GO TO 60
- 50 IF(X(I)-X0 == 0) goto 55
- IF(X(I)-X0 < 0) goto 52
- IF(X(I)-X0 > 0) goto 54
-c 50 IF(X(I)-X0) 52,55,54
- 52 IL=-1
- IF(IS == 0) goto 140
- IF(IS < 0) goto 90
- IF(IS > 0) goto 80
-c IF(IS) 90,140,80
- 54 IL=1
- IF(IS == 0) goto 140
- IF(IS < 0) goto 80
- IF(IS > 0) goto 90
-c IF(IS) 80,140,90
-
- 55 IF(Y(I)-Y0 == 0) goto 120
- IF(Y(I)-Y0 < 0) goto 57
- IF(Y(I)-Y0 > 0) goto 58
-c 55 IF(Y(I)-Y0) 57,120,58
-
- 57 IF(YL-Y0 == 0) goto 120
- IF(YL-Y0 < 0) goto 90
- IF(YL-Y0 > 0) goto 120
-c 57 IF(YL-Y0) 90,120,120
-
- 58 IF(YL-Y0 == 0) goto 120
- IF(YL-Y0 < 0) goto 120
- IF(YL-Y0 > 0) goto 90
-c 58 IF(YL-Y0) 120,120,90
-C
- 60 IL=0
- IF(Y(I)-Y0 == 0) goto 120
- IF(Y(I)-Y0 < 0) goto 90
- IF(Y(I)-Y0 > 0) goto 90
-c IF(Y(I)-Y0) 90,120,90
-
- 80 IF(YL-Y0+(Y(I)-YL)*(X0-XL)/(X(I)-XL) == 0) goto 120
- IF(YL-Y0+(Y(I)-YL)*(X0-XL)/(X(I)-XL) < 0) goto 90
- IF(YL-Y0+(Y(I)-YL)*(X0-XL)/(X(I)-XL) > 0) goto 85
-c 80 IF(YL-Y0+(Y(I)-YL)*(X0-XL)/(X(I)-XL)) 90,120,85
- 85 NPC=NPC+1
- 90 XL=X(I)
- YL=Y(I)
- 100 CONTINUE
- NPC=MOD(NPC,2)
- RETURN
- 120 NPC=2
- RETURN
- 140 WRITE(I6,6002)
- 6002 FORMAT('0 POLYGON LOGIC ERROR - PROGRAM SHOULD NOT REACH THIS',
- . ' POINT')
- RETURN
- END
-*****************************************************************
- SUBROUTINE RADR8T (YLAT,VN,VE,VNR,VER)
-
-C Convert horizontal velocities from mm/yr to rad/yr
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
-
- CALL RADII (YLAT,RADMER,RADPAR)
-c write (*,*) "From RADR8T",RADMER,RADPAR
- VNR = VN / (1000.D0 * RADMER)
- VER = VE / (1000.D0 * RADPAR)
-c write (*,*) "From RADR8T",VNR,VER
-
- RETURN
- END
-*****************************************************************
- SUBROUTINE COMVEL(YLAT,YLON,JREGN,VN,VE,VU)
-C
-C Compute the NAD_83(CORS96) velocity at a point in mm/yr !Not anymore since 09/12/2014
- !Now the velocity refer to ITRF2008
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (NUMGRD = 10)
- parameter (NMREGN = 17)
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
- COMMON /FILES/ LUIN, LUOUT, I1,I2,I3,I4,I5,I6
- COMMON /VGRID/ B(210000)
- DIMENSION WEI(2,2), VEL(2,2,3)
-
-c WRITE (6, 1001) JREGN
-c1001 FORMAT( 'JREGN = ', I6)
-
- IF(JREGN .GT. NUMGRD .AND. JREGN .LE. NMREGN) THEN
-*** Use tectonic plate model to compute velocity relative
-*** to ITRF2008
- IPLATE = JREGN - NUMGRD
- ELON = - YLON
- HT = 0.D0
- CALL TOXYZ(YLAT, ELON, HT, X, Y, Z)
- CALL PLATVL(IPLATE, X, Y, Z, VX, VY, VZ)
- VX = VX * 1000.D0
- VY = VY * 1000.D0
- VZ = VZ * 1000.D0
-*** Convert ITRF2008 velocity to NAD_83(CORS96) velocity
-c CALL VTRANF(X, Y, Z, VX, VY, VZ, 15, 1) !No Do not. Leave the velocity in ITRF2008
- CALL TOVNEU(YLAT, ELON, VX, VY, VZ, VN, VE, VU)
-
- ELSEIF(JREGN .GE. 1 .AND. JREGN .LE. NUMGRD) THEN
-
-C*** Get indices for the lower left hand corner of the grid
-C*** and get the weights for the four corners
- CALL GRDWEI (YLON, YLAT, JREGN, I, J, WEI)
-c write (*,*) 'HHHHHHHHHHHHHHHHHHHHHHHHH',JREGN,WEI
-c write (*,*) 'HHHHHHHHHHHHHHHHHHHHHHHHH',i,j
-
-C*** Get the velocity vectors at the four corners
- CALL GRDVEC (JREGN, I, J, VEL, B)
-
- VN = WEI(1,1) * VEL(1,1,1) + WEI(1,2) * VEL(1,2,1)
- * + WEI(2,1) * VEL(2,1,1) + WEI(2,2) * VEL(2,2,1)
-
- VE = WEI(1,1) * VEL(1,1,2) + WEI(1,2) * VEL(1,2,2)
- * + WEI(2,1) * VEL(2,1,2) + WEI(2,2) * VEL(2,2,2)
-
- VU = WEI(1,1) * VEL(1,1,3) + WEI(1,2) * VEL(1,2,3)
- * + WEI(2,1) * VEL(2,1,3) + WEI(2,2) * VEL(2,2,3)
-
-c write (*,*) 'From COMVEL ',VN,VE,VU
-c write (*,*) 'From COMVEL ',I,J
-
-C*** If the point in one of the four Alaskan regions,
-C*** then set its vertical velocity to 0.0
- IF(JREGN .GE. 7 .AND. JREGN .LE. 10) THEN
- VU = 0.D0
- ENDIF
-
-C*** If the point is in one of the first ten regions, then
-c*** the velocity grids contain the ITRF2008 velocity.
-c*** Hence, the following code transforms this ITRF2008 velocity
-c*** to the corresponding NAD 83 (CORS96) velocity.
-C
-c IF(JREGN .LE. NUMGRD) THEN !Starting09/12/2014, the velocities
-c ELON = - YLON !coming out of this routine are in ITRF2008
-c HT = 0.D0
-c CALL TOXYZ(YLAT, ELON, HT, X, Y, Z)
-c CALL TOVXYZ(YLAT, ELON, VN, VE, VU, VX, VY, VZ)
-c CALL VTRANF( X, Y, Z, VX, VY, VZ, 15, 1)
-c CALL TOVNEU(YLAT, ELON, VX, VY, VZ, VN, VE, VU)
-c ENDIF
-
- ELSE
- WRITE(LUOUT,100) JREGN
- 100 FORMAT(' Improper region identifier ',I4,'in COMVEL.')
- STOP
- ENDIF
- RETURN
- END
-****************************************
- SUBROUTINE PLATVL(IPLATE, X, Y, Z, VX, VY, VZ)
-*** Compute the ITRF2008 velocity at point on plate = IPLATE
-*** with coordinates X, Y, Z (in meters)
-*** The resulting velocities--VX, VY, and VZ--will be in meters/yr
-*** References
-*** Altamimi et al. 2012 = JGR (Paper on ITRF2008 plate motion)
-*** DeMets et al. 2010 = Geophysical Journal Int'l, vol 181,
-*** Snay 2003 = SALIS, Vol 63, No 1 (Paper on Frames for Pacific)
-
- IMPLICIT DOUBLE PRECISION (A-H, O-Z)
- IMPLICIT INTEGER*4 (I-N)
- DIMENSION WX(7), WY(7), WZ(7)
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
-
-*** IPLATE = 1 --> North America (from Altamimi et al. 2012)
-*** 2 --> Caribbean (from Altamimi et al. 2012)
-*** 3 --> Pacific (from Altamimi et al. 2012)
-*** 4 --> Juan de Fuca (from DeMets et al. 2010)
-*** 5 --> Cocos (from DeMets et al. 2010)
-*** 6 --> Mariana (from Snay, 2003)
-*** 7 --> Philippine Sea (from DeMets et al. 2010)
- DATA WX /0.170D-9, 0.238D-9, -1.993D-9,
- 1 6.626D-9, -10.390D-9, -.097D-9, -0.841D-9/
- DATA WY /-3.209D-9, -5.275D-9, 5.023D-9,
- 1 11.708D-9, -14.954D-9, .509D-9, 3.989D-9/
- DATA WZ /-0.485D-9, 3.219D-9,-10.501D-9,
- 1 -10.615D-9, 9.148D-9,-1.682D-9, -10.626D-9/
-
- IF (IPLATE .LE. 0 .OR. IPLATE .GT. 7) THEN
- WRITE (LUOUT, 1) IPLATE
- 1 FORMAT(' Improper plate ID in PLATVL = ', I6)
- STOP
- ENDIF
-
- VX = -WZ(IPLATE) * Y + WY(IPLATE) * Z
- VY = WZ(IPLATE) * X - WX(IPLATE) * Z
- VZ = -WY(IPLATE) * X + WX(IPLATE) * Y
-
-*** The parameters--WX, WY, and WZ--refer to ITRF2000
-*** for the Mariana Plate (Snay, 2003). Hence,
-*** for this plate, VX, VY, and VZ, correspond to ITRF2000.
-*** The following code converts these to ITRF2008 velocities for
-*** this plate.
- IF (IPLATE .EQ. 6) THEN
- VX = VX*1000.d0
- VY = VY*1000.d0
- VZ = VZ*1000.d0
- CALL VTRANF(X, Y, Z, VX, VY, VZ, 11, 15)
- VX = VX/1000.d0
- VY = VY/1000.d0
- VZ = VZ/1000.d0
-*** The following translations rates are added per Altamimi et al. (2012)
-*** for the other six plates
- ELSE
- VX = 0.00041d0 + VX
- VY = 0.00022d0 + VY
- VZ = 0.00041d0 + VZ
- ENDIF
-
- RETURN
- END
-**********************************************************************
- SUBROUTINE PVPRNT(LATD,LATM,SLAT,LOND,LONM,SLON,VN,VE,VU)
-
-*** Print out a point-velocity (PV) record
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- COMMON /FILES/ LUIN,LUOUT,I1,I2,I3,I4,I5, I6
-
- LATS = IDINT(SLAT*100.D0 + 0.5D0)
- LONS = IDINT(SLON*100.D0 + 0.5D0)
- IVN = IDINT( VN*100.D0 + 0.5D0)
- IVE = IDINT( VE*100.D0 + 0.5D0)
- IVU = IDINT( VU*100.D0 + 0.5D0)
- JVN = 300
- JVE = 300
- JVU = 500
-
- WRITE(I3,10) LATD,LATM,LATS,LOND,LONM,LONS,
- 1 IVN,JVN,IVE,JVE,IVU,JVU
- 10 FORMAT('PV',I3,I2.2,I4.4,'N',I3,I2.2,I4.4,'W',6I6)
- RETURN
- END
-****************************************************************************
- SUBROUTINE DSDA(LOCISN, LOCJSN, MIN1, MIN2, DS, DA)
-
-** Compute change in distance and change in azimuth.
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
-
- HTF = 0.0D0
- HTT = 0.0D0
-
- READ(I4,REC=LOCISN,err=50,iostat=ios) YLATF,YLONF,VNF,VEF,VUF
- if (ios /= 0) goto 50
- READ(I4,REC=LOCJSN,err=51,iostat=ios) YLATT,YLONT,VNT,VET,VUT
- if (ios /= 0) goto 51
-
- CALL COMPSN(YLATF1,YLONF1,HTF1,YLATF,YLONF,HTF,
- 1 MIN1, VNF, VEF, VUF)
- CALL COMPSN(YLATF2,YLONF2,HTF2,YLATF,YLONF,HTF,
- 1 MIN2, VNF, VEF, VUF)
- CALL COMPSN(YLATT1,YLONT1,HTT1,YLATT,YLONT,HTT,
- 1 MIN1, VNT, VET, VUT)
- CALL COMPSN(YLATT2,YLONT2,HTT2,YLATT,YLONT,HTT,
- 1 MIN2, VNT, VET, VUT)
-
- CALL HELINV(YLATF1,YLONF1,YLATT1,YLONT1,FAZ1,BAZ1,S1)
- CALL HELINV(YLATF2,YLONF2,YLATT2,YLONT2,FAZ2,BAZ2,S2)
- DS = S2 - S1
- DA = FAZ2 - FAZ1
- RETURN
-
- 50 write (*,'(/)')
- write (*,*) "wrong input for the 1st reading in DSDA:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 51 write (*,'(/)')
- write (*,*) "wrong input for the 2nd reading in DSDA:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- END
-*********************************************************************
- SUBROUTINE HELINV(GLAT1,GLON1,GLAT2,GLON2,FAZ,BAZ,S)
-C
-C *** SOLUTION OF THE GEODETIC INVERSE PROBLEM AFTER T.VINCENTY.
-C *** MODIFIED RAINSFORD WITH HELMERT ELLIPTICAL TERMS.
-C *** EFFECTIVE IN ANY AZIMUTH AND AT ANY DISTANCE SHORT OF ANTIPODAL.
-C *** STANDPOINT/FOREPOINT MUST NOT BE THE GEOGRAPHIC POLE .
-C
-C INPUT
-C GLAT1 = Latitude of from point (radians, positive north)
-C GLON1 = Longitude of from point (radians, positive west)
-C GLAT2 = Latitude of to point (radians, positive north)
-C GLON2 = Longitude of to point (radians, positive west)
-C
-C OUTPUT
-C FAZ = Foward azimuth (radians, clockwise from north)
-C BAZ = Back azimuth (radians, clockwise from north)
-C S = Distance (meters)
-C
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- COMMON/CONST/A,F,EPS2,EPS,AF,PI,TWOPI,RHOSEC
- DATA TOL/0.5D-14/
- R = 1.0D0-F
- TU1 = R*DSIN(GLAT1)/DCOS(GLAT1)
- TU2 = R*DSIN(GLAT2)/DCOS(GLAT2)
- CU1 = 1.0D0/DSQRT(TU1*TU1+1.0D0)
- SU1 = CU1*TU1
- CU2 = 1.0D0/DSQRT(TU2*TU2+1.0D0)
- S = CU1*CU2
- BAZ = S*TU2
- FAZ = BAZ*TU1
- X = GLON1-GLON2
- 100 SX = DSIN(X)
- CX = DCOS(X)
- TU1 = CU2*SX
- TU2 = SU1*CU2*CX-BAZ
- SY = DSQRT(TU1*TU1+TU2*TU2)
- CY = S*CX+FAZ
- Y = DATAN2(SY,CY)
- SA = S*SX/SY
- C2A = -SA*SA+1.0D0
- CZ = FAZ+FAZ
- IF(C2A .GT. 0.0D0)CZ = -CZ/C2A+CY
- E = CZ*CZ*2.0D0-1.0D0
- C = ((-3.0D0*C2A+4.0D0)*F+4.0D0)*C2A*F/16.0D0
- D = X
- X = ((E*CY*C+CZ)*SY*C+Y)*SA
- X = (1.0D0-C)*X*F+GLON1-GLON2
- IF(DABS(D-X) .GT. TOL)GO TO 100
- FAZ = DATAN2(-TU1,TU2)
- BAZ = DATAN2(CU1*SX,BAZ*CX-SU1*CU2)
- FAZ = FAZ + PI
- BAZ = BAZ + PI
- IF(FAZ .LT. 0.0D0)FAZ = FAZ+TWOPI
- IF(BAZ .LT. 0.0D0)BAZ = BAZ+TWOPI
- IF(FAZ .GT. TWOPI)FAZ = FAZ - TWOPI
- IF(BAZ .GT. TWOPI)BAZ = BAZ - TWOPI
- X = DSQRT((1.0D0/R/R-1.0D0)*C2A+1.0D0)+1.0D0
- X = (X-2.0D0)/X
- C = 1.0D0-X
- C = (X*X/4.0D0+1.0D0)/C
- D = (0.375D0*X*X-1.0D0)*X
- X = E*CY
- S = 1.0D0-E-E
- S = ((((SY*SY*4.0D0-3.0D0)*S*CZ*D/6.0D0-X)*D/4.0D0+CZ)*SY*D+Y)
- 1 *C*A*R
- RETURN
- END
-*************************************************************************
-
-c SUBROUTINE TODMSA(val,id,im,s)
-
-*** convert position radians to deg,min,sec
-*** range is [-twopi to +twopi]
-
-c implicit double precision(a-h,o-z)
-c IMPLICIT INTEGER*4 (I-N)
-c common/CONST/A,F,E2,EP2,AF,PI,TWOPI,RHOSEC
-
-c 1 if(val.gt.twopi) then
-c val=val-twopi
-c go to 1
-c endif
-
-c 2 if(val.lt.-twopi) then
-c val=val+twopi
-c go to 2
-c endif
-
-c if(val.lt.0.d0) then
-c isign=-1
-c else
-c isign=+1
-c endif
-
-c s=dabs(val*RHOSEC/3600.D0)
-c id=idint(s)
-c s=(s-id)*60.d0
-c im=idint(s)
-c s=(s-im)*60.d0
-
-*** account for rounding error
-
-c is=idnint(s*1.d5)
-c if(is.ge.6000000) then
-c s=0.d0
-c im=im+1
-c endif
-c if(im.ge.60) then
-c im=0
-c id=id+1
-c endif
-
-c id = isign*id
-c im = isign*im
-c s = isign*s
-
-c return
-c end
-*********************************************************
- SUBROUTINE TRFDAT(CARD,DATE,IREC12,IYEAR1,IYEAR2,MINS)
-
-C Convert blue-book date to time in minutes
-
- IMPLICIT DOUBLE PRECISION (A-H, O-Z)
- IMPLICIT INTEGER*4 (I-N)
- CHARACTER CARD*80
- CHARACTER DATE*6
- COMMON /FILES/ LUIN,LUOUT, I1, I2, I3, I4, I5, I6
-
- IF (IREC12 .EQ. 0) THEN
- WRITE (LUOUT, 5)
- 5 FORMAT(' ABORT: The blue-book needs a valid *12* record.')
- STOP
- ENDIF
-
- READ (DATE, 10,err=50,iostat=ios) IYEAR, MONTH, IDAY
- if (ios /= 0) goto 50
- 10 FORMAT (3I2)
-
- IF ( IYEAR1 .LE. (1900 + IYEAR) .AND.
- 1 (1900 + IYEAR) .LE. IYEAR2) THEN
- IYEAR = 1900 + IYEAR
- ELSEIF ( IYEAR1 .LE. (2000 + IYEAR) .AND.
- 1 (2000 + IYEAR) .LE. IYEAR2) THEN
- IYEAR = 2000 + IYEAR
- ELSEIF ( IYEAR1 .LE. (1800 + IYEAR) .AND.
- 1 (1800 + IYEAR) .LE. IYEAR2) THEN
- IYEAR = 1800 + IYEAR
- ELSE
- WRITE (LUOUT, 20) CARD
- 20 FORMAT(' ABORT: The following record has a date'/
- 1 ' which is inconsistent with the *12* record'/
- 1 3x, A80)
- ENDIF
-
- IF (IYEAR .LE. 1906) THEN
- WRITE (LUOUT, 30)
- 30 FORMAT(' ***WARNING***'/
- 1 ' The blue-book file contains an observation that'/
- 1 ' predates 1906. The TDP model may not be valid'/
- 1 ' and the computed corrections may be erroneous.')
- ENDIF
-
- IF (IDAY .EQ. 0) IDAY = 15
-
- IF (MONTH .EQ. 0) THEN
- MONTH = 7
- IDAY = 1
- ENDIF
-
-C CALL TOTIME(IYEAR,MONTH,IDAY, MINS)
- CALL IYMDMJ(IYEAR,MONTH,IDAY, MJD)
- MINS = MJD * 24 * 60
- RETURN
-
- 50 write (*,'(/)')
- write (*,*) 'wrong IYEAR, IMONTH, IDAY:ios =',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
-
- END
-*********************************************************
- SUBROUTINE TNFDAT(DATE,MINS)
-
-C Convert blue-book date to time in years
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- character DATE*8
- COMMON /FILES/ LUIN,LUOUT, I1, I2, I3, I4, I5, I6
- READ(DATE,10) IYEAR,MONTH,IDAY
- 10 FORMAT(I4,I2,I2)
- IF(IYEAR .LE. 1906) THEN
- WRITE(LUOUT,20)
- 20 FORMAT(' ***WARNING***'/
- 1 ' The blue-book file contains an observation that'/
- 2 ' predates 1906. The TDP model is not valid and the'/
- 3 ' computed correction may be erroneous.')
- ENDIF
- IF(IDAY .EQ. 0) IDAY = 15
- IF(MONTH .EQ. 0) THEN
- MONTH = 7
- IDAY = 1
- ENDIF
-C CALL TOTIME(IYEAR,MONTH,IDAY,MINS)
- CALL IYMDMJ(IYEAR,MONTH,IDAY,MJD)
- MINS = MJD * 24 * 60
- RETURN
- END
-***************************************************************
-C SUBROUTINE GETTIM(MONTH, IDAY, IYEAR, DATE, MINS, TEST)
-C
-*** Read month-day-year and convert to decimal years
-*** and Julian time in minutes
-*** MONTH input - number from 1 to 12
-*** IDAY input - number from 1 to 31
-*** IYEAR input - must be after 1906
-*** DATE output - corresponding time in decimal years
-*** MINS output - corresponding julian time in minutes
-*** TEST output - if (true) then there is an error
-C
-C IMPLICIT DOUBLE PRECISION (A-H,O-Z)
-C IMPLICIT INTEGER*4 (I-N)
-C LOGICAL TEST
-C COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
-
-C READ(LUIN,*) MONTH,IDAY,IYEAR
-
-C IF(IYEAR .le. 1906) THEN
-C WRITE(LUOUT,10)
-C 10 FORMAT(' The model is not valid for dates prior ',
-C 1 'to 1906.'/)
-C TEST = .TRUE.
-C RETURN
-C ENDIF
-
-C IF(MONTH .le. 0 .or. MONTH .gt. 12) THEN
-C WRITE(LUOUT,20)
-C 20 FORMAT(' Improper month specified.'/)
-C TEST = .TRUE.
-C RETURN
-C ENDIF
-
-C IF(IDAY .le. 0 .or. IDAY .gt. 31) THEN
-C WRITE(LUOUT,30)
-C 30 FORMAT(' Improper day specified.'/)
-C TEST = .TRUE.
-C RETURN
-C ENDIF
-
-C CALL TOTIME(IYEAR, MONTH, IDAY, MINS)
-C CALL TOTIME(IYEAR, 1, 1, MIN00)
-C DATE = DBLE(IYEAR) + DBLE(MINS - MIN00)/525600.D0
-C TEST = .FALSE.
-C RETURN
-C END
-
-C************************************************************************
- SUBROUTINE TOXYZ(glat,glon,eht,x,y,z)
-
-*** compute x,y,z
-*** ref p.17 geometric geodesy notes vol 1, osu, rapp
-
- implicit double precision(a-h,o-z)
- common/CONST/ a,f,e2,ep2,af,pi,twopi,rhosec
-
- slat=dsin(glat)
- clat=dcos(glat)
- w=dsqrt(1.d0-e2*slat*slat)
- en=a/w
-
- x=(en+eht)*clat*dcos(glon)
- y=(en+eht)*clat*dsin(glon)
- z=(en*(1.d0-e2)+eht)*slat
-
- return
- end
-C************************************************************************
- logical function FRMXYZ(x,y,z,glat,glon,eht)
-
-*** convert x,y,z into geodetic lat, lon, and ellip. ht
-*** ref: eq a.4b, p. 132, appendix a, osu #370
-*** ref: geom geod notes gs 658, rapp
-
- implicit double precision(a-h,o-z)
- parameter(maxint=10,tol=1.d-13)
- common/CONST/ a,f,e2,ep2,af,pi,twopi,rhosec
-
- ae2=a*e2
-
-*** compute initial estimate of reduced latitude (eht=0)
-
- p=dsqrt(x*x+y*y)
- icount=0
- tgla=z/p/(1.d0-e2)
-
-*** iterate to convergence, or to max # iterations
-
- 1 if(icount.le.maxint) then
- tglax=tgla
- tgla=z/(p-(ae2/dsqrt(1.d0+(1.d0-e2)*tgla*tgla)))
- icount=icount+1
- if(dabs(tgla-tglax).gt.tol) go to 1
-
-*** convergence achieved
-
- frmxyz=.true.
- glat=datan(tgla)
- slat=dsin(glat)
- clat=dcos(glat)
- glon=datan2(y,x)
- w=dsqrt(1.d0-e2*slat*slat)
- en=a/w
- if(dabs(glat).le.0.7854d0) then
- eht=p/clat-en
- else
- eht=z/slat-en+e2*en
- endif
- glon=datan2(y,x)
-
-*** too many iterations
-
- else
- frmxyz=.false.
- glat=0.d0
- glon=0.d0
- eht=0.d0
- endif
-
- return
- end
-*********************************************************************
- SUBROUTINE RADII(YLAT,RADMER,RADPAR)
-C
-C Computes the radius of curvature in the meridian
-C and the radius of curvature in a parallel of latitude
-C
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
- COSLAT = DCOS(YLAT)
- DENOM = DSQRT(1.D0 + EPS*COSLAT*COSLAT)
- RADMER = AF/(DENOM**3)
- RADPAR = AF*COSLAT/DENOM
- RETURN
- END
-*********************************************************************
- SUBROUTINE GETGRD(NAMEG,MINLAT,MAXLAT,ILAT,MINLON,MAXLON,ILON)
-
-*** Interactively obtain specifications for a grid.
-
- IMPLICIT INTEGER*4 (I-N)
- COMMON /FILES/ LUIN,LUOUT, I1, I2, I3, I4, I5, I6
- CHARACTER NAMEG*10
- WRITE(LUOUT,200)
- 200 FORMAT(' Enter name for grid (10 character max). ')
- READ(LUIN,210,err=50,iostat=ios) NAMEG
- if (ios /= 0) goto 50
- 210 FORMAT(A10)
- WRITE(LUOUT,220)
- 220 FORMAT(' Enter minimum latitude for grid in deg-min-sec'/
- 1 ' in free format (integer values only). ')
- READ(LUIN,*,err=51,iostat=ios) ID1, IM1, IS1
- if (ios /= 0) goto 51
- WRITE(LUOUT,230)
- 230 FORMAT(' Enter maximum latitude in same format. ')
- READ(LUIN,*,err=52,iostat=ios) ID2, IM2, IS2
- if (ios /= 0) goto 52
- WRITE(LUOUT,240)
- 240 FORMAT(' Enter latitude increment in seconds ',
- 1 ' (integer value). ')
- READ(LUIN,*,err=53,iostat=ios) ILAT
- if (ios /= 0) goto 53
- WRITE(LUOUT,250)
- 250 FORMAT(' Enter minimum longitude with positive being west. ')
- READ(LUIN,*,err=54,iostat=ios) JD1, JM1, JS1
- if (ios /= 0) goto 54
- WRITE(LUOUT,260)
- 260 FORMAT(' Enter maximum longitude. ')
- READ(LUIN,*,err=55,iostat=ios) JD2, JM2, JS2
- if (ios /= 0) goto 55
- WRITE(LUOUT,270)
- 270 FORMAT(' Enter longitude increment in seconds ',
- 1 ' (integer value). ')
- READ(LUIN,*,err=56,iostat=ios) ILON
- if (ios /= 0) goto 56
- MINLAT = 3600*ID1 + 60*IM1 + IS1
- MAXLAT = 3600*ID2 + 60*IM2 + IS2
- MINLON = 3600*JD1 + 60*JM1 + JS1
- MAXLON = 3600*JD2 + 60*JM2 + JS2
- RETURN
-
- 50 write (*,'(/)')
- write (*,*) "Wrong grid name in GETGRD:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 51 write (*,'(/)')
- write (*,*) "Wrong min lat in GETGRD:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 52 write (*,'(/)')
- write (*,*) "Wrong max lat in GETGRD:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 53 write (*,'(/)')
- write (*,*) "Wrong ILAT in GETGRD:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 54 write (*,'(/)')
- write (*,*) "Wrong min lon in GETGRD:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 55 write (*,'(/)')
- write (*,*) "Wrong max lon in GETGRD:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 56 write (*,'(/)')
- write (*,*) "Wrong ILON in GETGRD:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- END
-*********************************************************************
- SUBROUTINE GETLYN(NAMEG,XLAT,XLON,FAZ,BAZ,XMIN,XMAX,XINC)
-
-*** Interactively obtain the specifications for a line.
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- COMMON /FILES/ LUIN,LUOUT,I1,I2,I3,I4,I5,I6
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
- CHARACTER NAMEG*10
-
- WRITE(LUOUT,100)
- 100 FORMAT(' Enter name for line (10 character max.) ')
- READ(LUIN,110,err=50,iostat=ios) NAMEG
- if (ios /= 0) goto 50
- 110 FORMAT(A10)
- WRITE(LUOUT,120)
- 120 Format(' Specify the latitude for the origin of the line'/
- 1 ' in deg-min-sec in free format. For example'/
- 2 ' 35 17 28.3'/
- 3 ' Positive is north. ')
- READ(LUIN,*,err=51,iostat=ios) LATD,LATM,SLAT
- if (ios /= 0) goto 51
- XLAT = (DBLE(3600*LATD + 60*LATM)+SLAT)/RHOSEC
- WRITE(LUOUT,130)
- 130 FORMAT(' Specify the longitude for the origin of the line'/
- 1 ' in free format with west being positive. ')
- READ(LUIN,*,err=52,iostat=ios) LOND,LONM,SLON
- if (ios /= 0) goto 52
- XLON = (DBLE(3600*LOND+60*LONM)+SLON)/RHOSEC
- WRITE(LUOUT,140)
- 140 FORMAT(' Specify the orientation of the line clockwise from'/
- 1 ' north in decimal degrees, eg., 43.7. ')
- READ(LUIN,*,err=53,iostat=ios) FAZ
- if (ios /= 0) goto 53
- FAZ = 3600.D0*FAZ/RHOSEC
- BAZ = FAZ + PI
- IF(BAZ .GT. TWOPI) BAZ = BAZ - TWOPI
- WRITE(LUOUT,150)
- 150 FORMAT(' Specify minimum and maximum distance from origin in'/
- 1 ' meters, eg., -40000. 30000. '/
- 2 ' NOTE: negative distance corresponds to distance in'/
- 3 ' the opposite direction. ')
- READ(LUIN,*,err=54,iostat=ios) XMIN,XMAX
- if (ios /= 0) goto 54
- WRITE(LUOUT,160)
- 160 FORMAT(' Specify distance increment in meters. ')
- READ(LUIN,*,err=55,iostat=ios) XINC
- if (ios /= 0) goto 55
- RETURN
-
- 50 write (*,'(/)')
- write (*,*) 'Wrong name of line in GETLYN: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 51 write (*,'(/)')
- write (*,*) 'Wrong LATD,LATM,SLAT in GETLYN: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 52 write (*,'(/)')
- write (*,*) 'Wrong LOND,LONM,SLON in GETLYN: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 53 write (*,'(/)')
- write (*,*) 'Wrong FAZ in GETLYN: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 54 write (*,'(/)')
- write (*,*) 'Wrong min and max D in GETLYN: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 55 write (*,'(/)')
- write (*,*) 'Wrong increment in GETLYN: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- END
-*******************************************************************
- SUBROUTINE DIRCT1(GLAT1,GLON1,GLAT2,GLON2,FAZ,BAZ,S)
-C
-C *** SOLUTION OF THE GEODETIC DIRECT PROBLEM AFTER T.VINCENTY
-C *** MODIFIED RAINSFORD'S METHOD WITH HELMERT'S ELLIPTICAL TERMS
-C *** EFFECTIVE IN ANY AZIMUTH AND AT ANY DISTANCE SHORT OF ANTIPODAL
-C
-C *** A IS THE SEMI-MAJOR AXIS OF THE REFERENCE ELLIPSOID
-C *** FINV IS THE FLATTENING OF THE REFERENCE ELLIPSOID
-C *** LATITUDES AND LONGITUDES IN RADIANS POSITIVE NORTH AND EAST
-C *** AZIMUTHS IN RADIANS CLOCKWISE FROM NORTH
-C *** GEODESIC DISTANCE S ASSUMED IN UNITS OF SEMI-MAJOR AXIS A
-C
-C *** PROGRAMMED FOR CDC-6600 BY LCDR L.PFEIFER NGS ROCKVILLE MD 20FEB75
-C *** MODIFIED FOR SYSTEM 360 BY JOHN G GERGEN NGS ROCKVILLE MD 750608
-C
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- COMMON /CONST/ A,FINV,E2,EPI,AF,PI,TWOPI,RHOSEC
- DATA EPS/0.5D-13/
- R=1.D0-FINV
- TU=R*DSIN(GLAT1)/DCOS(GLAT1)
- SF=DSIN(FAZ)
- CF=DCOS(FAZ)
- BAZ=0.D0
- IF(CF.NE.0.D0) BAZ=DATAN2(TU,CF)*2.D0
- CU=1.D0/DSQRT(TU*TU+1.D0)
- SU=TU*CU
- SA=CU*SF
- C2A=-SA*SA+1.D0
- X=DSQRT((1.D0/R/R-1.D0)*C2A+1.D0)+1.D0
- X=(X-2.D0)/X
- C=1.D0-X
- C=(X*X/4.D0+1.D0)/C
- D=(0.375D0*X*X-1.D0)*X
- TU=S/R/A/C
- Y=TU
- 100 SY=DSIN(Y)
- CY=DCOS(Y)
- CZ=DCOS(BAZ+Y)
- E=CZ*CZ*2.D0-1.D0
- C=Y
- X=E*CY
- Y=E+E-1.D0
- Y=(((SY*SY*4.D0-3.D0)*Y*CZ*D/6.D0+X)*D/4.D0-CZ)*SY*D+TU
- IF(DABS(Y-C).GT.EPS)GO TO 100
- BAZ=CU*CY*CF-SU*SY
- C=R*DSQRT(SA*SA+BAZ*BAZ)
- D=SU*CY+CU*SY*CF
- GLAT2=DATAN2(D,C)
- C=CU*CY-SU*SY*CF
- X=DATAN2(SY*SF,C)
- C=((-3.D0*C2A+4.D0)*FINV+4.D0)*C2A*FINV/16.D0
- D=((E*CY*C+CZ)*SY*C+Y)*SA
- GLON2=GLON1+X-(1.D0-C)*D*FINV
- IF (GLON2.GE.TWOPI) GLON2=GLON2-TWOPI
- IF(GLON2.LT.0.D0) GLON2=GLON2+TWOPI
- BAZ=DATAN2(SA,BAZ)+PI
- IF (BAZ.GE.TWOPI) BAZ=BAZ-TWOPI
- IF (BAZ.LT.0.D0) BAZ=BAZ+TWOPI
- RETURN
- END
-***********************************************************
- SUBROUTINE TOCHAR(ORIG,CHAR14)
-
-*** Convert double precision real number to character*14
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- CHARACTER CHAR14*14
-
- ORIG = ORIG*10000.D0
- WRITE(CHAR14,10) ORIG
- 10 FORMAT(F14.0)
- RETURN
- END
-*********************************************************
-
- SUBROUTINE DDXYZ(ISN, JSN, MIN1, MIN2,
- 1 DDX, DDY, DDZ)
-
-** Compute change in DX,DY,DZ-vector from time MIN1 to MIN2.
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- character PIDs*6
- parameter (nbbdim = 10000)
- COMMON /ARRAYS/ HT(nbbdim), LOC(nbbdim),PIDs(nbbdim)
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
-
- READ(I4,REC=LOC(ISN),err=50,iostat=ios) GLATI,GLONI,VNI,VEI,VUI
- if (ios /= 0) goto 50
- READ(I4,REC=LOC(JSN),err=51,iostat=ios) GLATJ,GLONJ,VNJ,VEJ,VUJ
- if (ios /= 0) goto 51
-
- CALL COMPSN(YLATI1,YLONI1,HTI1,GLATI,GLONI,HT(ISN),
- 1 MIN1,VNI, VEI, VUI)
- CALL COMPSN(YLATI2,YLONI2,HTI2,GLATI,GLONI,HT(ISN),
- 1 MIN2, VNI, VEI, VUI)
- CALL COMPSN(YLATJ1,YLONJ1,HTJ1,GLATJ,GLONJ,HT(JSN),
- 1 MIN1, VNJ, VEJ, VUJ)
- CALL COMPSN(YLATJ2,YLONJ2,HTJ2,GLATJ,GLONJ,HT(JSN),
- 1 MIN2, VNJ, VEJ, VUJ)
-
- XLONI1 = -YLONI1
- XLONI2 = -YLONI2
- XLONJ1 = -YLONJ1
- XLONJ2 = -YLONJ2
-
- CALL TOXYZ(YLATI1,XLONI1,HTI1,XI1,YI1,ZI1)
- CALL TOXYZ(YLATI2,XLONI2,HTI2,XI2,YI2,ZI2)
- CALL TOXYZ(YLATJ1,XLONJ1,HTJ1,XJ1,YJ1,ZJ1)
- CALL TOXYZ(YLATJ2,XLONJ2,HTJ2,XJ2,YJ2,ZJ2)
-
- DDX = (XJ2 - XI2) - (XJ1 - XI1)
- DDY = (YJ2 - YI2) - (YJ1 - YI1)
- DDZ = (ZJ2 - ZI2) - (ZJ1 - ZI1)
-
- RETURN
-
- 50 write (*,'(/)')
- write (*,*) "Failed in 1st read statement in DDXYZ:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 51 write (*,'(/)')
- write (*,*) "Failed in 2nd read statement in DDXYZ:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- END
-*************************************************************
- SUBROUTINE DISLOC (YLAT,YLON,STRIKE,HL,EQLAT,EQLON,
- & SS,DS,DIP,DEPTH,WIDTH,DNORTH,DWEST,DUP)
-
-*** Compute 3-dimensional earthquake displacement at point
-*** using dislocation theory
-*
-* INPUT:
-* YLAT = Latitude in radians (positive north)
-* YLON = Longitude in radians (positive west)
-* STRIKE = strike in radians clockwise from north such
-* that the direction of dip is pi/2 radians
-* counterclockwise from the direction of strike
-* HL = Half-length in meters
-* EQLAT = Latitude in radians of midpoint of the
-* rectangle's upper edge (positive north)
-* EQLON = Longitude in radians of midpoint of the
-* rectangle's upper edge (positive west)
-* SS = strike slip in meters (positive = right lateral)
-* DS = dip slip in meters (positive = normal faulting)
-* DIP = dip in radians
-* DEPTH = Vertical depth of rectangle's upper edge
-* in meters
-* WIDTH = width of rectangle in meters
-*
-* OUTPUT:
-* DNORTH = northward displacement in radians
-* DWEST = westward displacement in radians
-* DUP = upward displacement in meters
-**************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
-
-*** Compute radii of curvature at fault center
- CALL RADII (EQLAT, RMER, RPAR)
-
-*** Compute planar coordinates in meters
- DLAT = (YLAT - EQLAT) * RMER
- DLON = (YLON - EQLON) * RPAR
- COSSTR = DCOS(STRIKE)
- SINSTR = DSIN(STRIKE)
- X1 = COSSTR*DLAT - SINSTR*DLON
- X2 = SINSTR*DLAT + COSSTR*DLON
-
-*** Compute displacements in fault-oriented coordinates
- CALL OKADA(X1,X2,HL,DEPTH,WIDTH,DIP,U1SS,U2SS,
- & U3SS,U1DS,U2DS,U3DS)
- U1 = U1SS*SS + U1DS*DS
- U2 = U2SS*SS + U2DS*DS
- DUP = U3SS*SS + U3DS*DS
-
-*** Convert horizontal displacements to radians
-*** in north-west coordinate system
- DNORTH = ( COSSTR*U1 + SINSTR*U2) / RMER
- DWEST = (-SINSTR*U1 + COSSTR*U2) / RPAR
-
- RETURN
- END
-****************************************************
- SUBROUTINE OKADA(X1,X2,XL,DU,W,DIP,
- 1 U1SS,U2SS,U3SS,U1DS,U2DS,U3DS)
-
-************************************************************
-* This subroutine computes displacements at the point X1,X2
-* on the Earth's surface due to 1.0 meter of right-lateral
-* strike slip (SS) and 1.0 meter of normal dip slip (DS)
-* along a rectangular fault.
-*
-* The rectangular fault dips in the direction of the positive
-* X2-axis. The rectangle's strike parallels the X1-axis.
-* With the X3-axis directed upward out of the Earth, the X1-,
-* X2-, and X3-axes form a right-handed system.
-*
-* The equations of dislocation theory are employed whereby
-* Earth is represented an a homogeneous, isotropic half-space
-* with a Poisson ratio of PNU.
-*
-* REFERENCE: Okada, Y., Surface deformation due to shear and
-* tensile faults in a half-space, Bulletin of the
-* Seismological Society of America, vol. 75, pp. 1135-1154 (1985)
-*
-* The X3 = 0 plane corresponds to the Earth's surface. The plane's
-* origin is located directly above the midpoint of the rectangle's
-* upper edge.
-*
-* INPUT:
-* X1,X2 - Location in meters
-* XL - Rectangle's half-length in meters
-* DU - Vertical depth to rectangle's upper edge in meters
-* (always positive or zero)
-* W - Rectangle's width in meters
-* DIP - Rectangle's dip in radians (always between 0 and PI/2
-*
-* OUTPUT
-* U1SS - Displacement in X1-direction due to 1.0 meters
-* of right-lateral strike slip
-* U2SS - Displacement in X2-direction due to 1.0 meters
-* of right-lateral strike slip
-* U3SS - Displacement in X3-direction due to 1.0 meters
-* of right-lateral strike slip
-* U1DS - Displacement in X1-direction due to 1.0 meters
-* of normal dip slip
-* U2DS - Displacement in X2-direction due to 1.0 meters
-* of normal dip slip
-* U3DS - Displacement in X3-direction due to 1.0 meters
-* of normal dip slip
-*******************************************************************
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- LOGICAL VERT
- PI = 3.141593D0
- TWOPI = PI + PI
- PNU = 0.25D0
- RATIO = 1.D0 - 2.D0*PNU
-
- IF(DABS(PI/2.D0 - DIP) .LT. .01D0)THEN
- DIPK = -PI/2.D0
- VERT = .TRUE.
- ELSE
- DIPK = -DIP
- VERT = .FALSE.
- ENDIF
-
- SDIP = DSIN(DIPK)
- CDIP = DCOS(DIPK)
- P = X2*CDIP + DU*SDIP
- Q = X2*SDIP - DU*CDIP
-
- PSI = X1 + XL
- ETA = P
- CALL OKADAW(PSI,ETA,Q,SDIP,CDIP,RATIO,TWOPI,
- 1 VERT,U1SS,U2SS,U3SS,U1DS,U2DS,U3DS)
-
- PSI = X1 + XL
- ETA = P - W
- CALL OKADAW(PSI,ETA,Q,SDIP,CDIP,RATIO,TWOPI,
- 1 VERT,C1SS,C2SS,C3SS,C1DS,C2DS,C3DS)
- U1SS = U1SS - C1SS
- U2SS = U2SS - C2SS
- U3SS = U3SS - C3SS
- U1DS = U1DS - C1DS
- U2DS = U2DS - C2DS
- U3DS = U3DS - C3DS
-
- PSI = X1 - XL
- ETA = P
- CALL OKADAW(PSI,ETA,Q,SDIP,CDIP,RATIO,TWOPI,
- 1 VERT,C1SS,C2SS,C3SS,C1DS,C2DS,C3DS)
- U1SS = U1SS - C1SS
- U2SS = U2SS - C2SS
- U3SS = U3SS - C3SS
- U1DS = U1DS - C1DS
- U2DS = U2DS - C2DS
- U3DS = U3DS - C3DS
-
- PSI = X1 - XL
- ETA = P - W
- CALL OKADAW(PSI,ETA,Q,SDIP,CDIP,RATIO,TWOPI,
- 1 VERT,C1SS,C2SS,C3SS,C1DS,C2DS,C3DS)
- U1SS = U1SS + C1SS
- U2SS = U2SS + C2SS
- U3SS = U3SS + C3SS
- U1DS = U1DS + C1DS
- U2DS = U2DS + C2DS
- U3DS = U3DS + C3DS
- RETURN
- END
-*************************************************************
- SUBROUTINE OKADAW(PSI,ETA,Q,SDIP,CDIP,RATIO,TWOPI,
- 1 VERT,U1SS,U2SS,U3SS,U1DS,U2DS,U3DS)
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- LOGICAL VERT
-
- YBAR = ETA*CDIP + Q*SDIP
- DBAR = ETA*SDIP - Q*CDIP
- R = DSQRT(PSI*PSI + ETA*ETA + Q*Q)
- X = DSQRT(PSI*PSI + Q*Q)
- IF(DABS(Q) .LE. 0.1d0) THEN
- TERM = 0.D0
- ELSE
- TERM = DATAN(PSI*ETA/(Q*R))
- ENDIF
-
- IF(VERT) THEN
- F5 = -RATIO*PSI*SDIP/(R + DBAR)
- F4 = -RATIO*Q/(R + DBAR)
- F3 = 0.5D0*RATIO*(ETA/(R + DBAR)
- 1 + YBAR*Q/((R + DBAR)*(R + DBAR))
- 2 - DLOG(R + ETA))
- F1 = -0.5D0*RATIO*PSI*Q/
- 1 ((R + DBAR)*(R + DBAR))
- ELSE
- IF(DABS(PSI) .LE. 0.1D0) then
- F5 = 0.d0
- ELSE
- F5 = 2.D0*RATIO*
- 1 DATAN((ETA*(X+Q*CDIP)+X*(R+X)*SDIP)/(PSI*(R+X)*CDIP))
- 2 /CDIP
- ENDIF
- F4 = RATIO*(DLOG(R+DBAR)-SDIP*DLOG(R+ETA))/CDIP
- F3 = RATIO*(YBAR/(CDIP*(R+DBAR)) - DLOG(R+ETA))
- 1 + SDIP*F4/CDIP
- F1 = -RATIO*(PSI/(CDIP*(R+DBAR))) - SDIP*F5/CDIP
- ENDIF
- F2 = -RATIO*DLOG(R+ETA) - F3
-
- U1SS = -(PSI*Q/(R*(R+ETA))
- 1 + TERM + F1*SDIP)/TWOPI
- U2SS = -(YBAR*Q/(R*(R+ETA))
- 1 + Q*CDIP/(R+ETA)
- 2 + F2*SDIP)/TWOPI
- U3SS = -(DBAR*Q/(R*(R+ETA))
- 1 + Q*SDIP/(R+ETA)
- 2 + F4*SDIP)/TWOPI
- U1DS = -(Q/R - F3*SDIP*CDIP)/TWOPI
- U2DS = -(YBAR*Q/(R*(R+PSI))
- 1 + CDIP*TERM - F1*SDIP*CDIP)/TWOPI
- U3DS = -(DBAR*Q/(R*(R+PSI))
- 1 + SDIP*TERM - F5*SDIP*CDIP)/TWOPI
- RETURN
- END
-*******************************************************************
-
-C SUBROUTINE GRDCHK (POSX, POSY, INSIDE)
-
-C
-C ROUTINE CHECKS IF THE POINT HAVING COORDINATES (POSX, POSY)
-C IS WITHIN THE REGION SPANNED BY THE GRID
-C
-C IMPLICIT DOUBLE PRECISION (A-H,O-Z)
-C IMPLICIT INTEGER*4 (I-N)
-C LOGICAL INSIDE
-C COMMON /CDGRID/ GRDLX, GRDUX, GRDLY, GRDUY, ICNTX, ICNTY
-
-C INSIDE = .TRUE.
-
-C IF (POSX .LT. GRDLX .OR. POSX .GT. GRDUX) THEN
-C INSIDE = .FALSE.
-C ENDIF
-C IF (POSY .LT. GRDLY .OR. POSY .GT. GRDUY) THEN
-C INSIDE = .FALSE.
-C ENDIF
-
-C RETURN
-C END
-
-*******************************************************************
-
- SUBROUTINE GRDWEI (YLON, YLAT, JREGN, I, J, WEI)
-
-C
-C********1*********2*********3*********4*********5*********6*********7**
-C
-C NAME: GRDWEI
-C VERSION: 9302.01 (YYMM.DD)
-C WRITTEN BY: MR. C. RANDOLPH PHILIPP
-C PURPOSE: THIS SUBROUTINE RETURNS THE INDICES OF THE LOWER-LEFT
-C HAND CORNER OF THE GRID CELL CONTAINING THE POINT
-C AND COMPUTES NORMALIZED WEIGHTS FOR
-C BI-LINEAR INTERPOLATION OVER A PLANE
-C
-C INPUT PARAMETERS FROM ARGUMENT LIST:
-C ------------------------------------
-C YLON LONGITUDE OF POINT IN RADIANS, POSITIVE WEST
-C YLAT LATITUDE OF POINT IN RADIANS, POSITIVE NORTH
-C JREGN ID OF GEOGRAPHIC REGION CONTAINING POINT
-C
-C OUTPUT PARAMETERS FROM ARGUMENT LIST:
-C -------------------------------------
-C I, J THE COORDINATES OF LOWER LEFT CORNER OF THE GRID
-C CONTAINING THE ABOVE POSITION
-C WEI A TWO BY TWO ARRAY CONTAINING THE NORMALIZED WEIGHTS
-C FOR THE CORNER VECTORS
-C
-C GLOBAL VARIABLES AND CONSTANTS:
-C -------------------------------
-C NONE
-C
-C THIS MODULE CALLED BY: COMVEL
-C
-C THIS MODULE CALLS: NONE
-C
-C INCLUDE FILES USED: NONE
-C
-C COMMON BLOCKS USED: /CDGRID/, /CONST/
-C
-C REFERENCES: SEE RICHARD SNAY
-C
-C COMMENTS:
-C
-C********1*********2*********3*********4*********5*********6*********7**
-C MOFICATION HISTORY:
-C::9302.11, CRP, ORIGINAL CREATION FOR DYNAP
-C::9511.09, RAS, MODIFIED FOR HTDP
-C::9712.05, RAS, MODIFIED TO ACCOUNT FOR MULTIPLE GRIDS
-C********1*********2*********3*********4*********5*********6*********7**
-
-C**** COMPUTES THE WEIGHTS FOR AN ELEMENT IN A GRID
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (NUMGRD = 10)
- DIMENSION WEI(2,2)
- COMMON /CDGRID/ GRDLX(NUMGRD), GRDUX(NUMGRD),
- 1 GRDLY(NUMGRD), GRDUY(NUMGRD),
- 1 ICNTX(NUMGRD), ICNTY(NUMGRD), NBASE(NUMGRD)
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
-
-C*** Convert input coordinates to degrees
- POSX = (TWOPI - YLON) * 180.D0 / PI
- POSY = YLAT * 180.D0 / PI
-
-C*** Obtain indices for the lower-left corner of the cell
-C*** containing the point
- STEPX = (GRDUX(JREGN) - GRDLX(JREGN)) / ICNTX(JREGN)
- STEPY = (GRDUY(JREGN) - GRDLY(JREGN)) / ICNTY(JREGN)
- I = IDINT((POSX - GRDLX(JREGN))/STEPX) + 1
- J = IDINT((POSY - GRDLY(JREGN))/STEPY) + 1
-c write(6,1001) JREGN, I, J
-c1001 format(1x, 'jregn = ', I5 /
-c 1 1x, ' i = ', I5 /
-c 1 1x, ' j = ', I5)
-
-C*** Compute the limits of the grid cell
- GRLX = GRDLX(JREGN) + (I - 1) * STEPX
- GRUX = GRLX + STEPX
- GRLY = GRDLY(JREGN) + (J - 1) * STEPY
- GRUY = GRLY + STEPY
-
-C*** Compute the normalized weights for the point
- DENOM = (GRUX - GRLX) * (GRUY - GRLY)
- WEI(1,1) = (GRUX - POSX) * (GRUY - POSY) / DENOM
- WEI(2,1) = (POSX - GRLX) * (GRUY - POSY) / DENOM
- WEI(1,2) = (GRUX - POSX) * (POSY - GRLY) / DENOM
- WEI(2,2) = (POSX - GRLX) * (POSY - GRLY) / DENOM
-
- RETURN
- END
-
-C*********************************************************************
-C
- SUBROUTINE GRDVEC (JREGN, I, J, VEL, B)
-C
-C********1*********2*********3*********4*********5*********6*********7**
-C
-C NAME: GRDVEC
-C VERSION: 9302.01 (YYMM.DD)
-C WRITTEN BY: MR. C. RANDOLPH PHILIPP
-C PURPOSE: THIS SUBROUTINE RETRIEVES THE APPROXIMATE VALUES OF THE
-C GRID NODE VELOCITIES FOR GRID (I,J)
-C
-C INPUT PARAMETERS FROM ARGUMENT LIST:
-C ------------------------------------
-C JREGN ID OF GEOGRAPHIC REGION CORRESPONDING TO GRID
-C I, J THE COORDINATES OF LOWER LEFT CORNER OF THE GRID
-C CONTAINING THE ABOVE POSITION
-C B THE ARRAY CONTAINING ALL THE APPROXIMATE VALUES
-C FOR THE ADJUSTMENT
-C
-C OUTPUT PARAMETERS FROM ARGUMENT LIST:
-C -------------------------------------
-C VEL A TWO BY TWO ARRAY CONTAINING THE VELOCITY VECTORS
-C FOR THE CORNERS OF THE GRID
-C
-C GLOBAL VARIABLES AND CONSTANTS:
-C -------------------------------
-C NONE
-C
-C THIS MODULE CALLED BY: COMVEL
-C
-C THIS MODULE CALLS: NONE
-C
-C INCLUDE FILES USED: NONE
-C
-C COMMON BLOCKS USED: NONE
-C
-C REFERENCES: SEE RICHARD SNAY
-C
-C COMMENTS:
-C
-C********1*********2*********3*********4*********5*********6*********7**
-C MOFICATION HISTORY:
-C::9302.11, CRP, ORIGINAL CREATION FOR DYNAP
-C::9712.05, RAS, MODIFIED FOR HTDP (version 2.2)
-C********1*********2*********3*********4*********5*********6*********7**
-
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- DIMENSION VEL(2,2,3), B(*)
-
- DO 30 II = 0,1
- DO 20 IJ = 0,1
- DO 10 IVEC = 1, 3
- INDEX = IUNGRD(JREGN, I + II, J + IJ, IVEC)
- VEL(II + 1, IJ + 1, IVEC) = B(INDEX)
- 10 CONTINUE
- 20 CONTINUE
- 30 CONTINUE
-
- RETURN
- END
-
-C***************************************************
-
- SUBROUTINE RDEG (INPUT,VAL,CNEG)
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
-
- CHARACTER INPUT*10
- CHARACTER CNEG*1
- INTEGER DEG, MIN, ISEC
-
- DO 10 I = 1, 9
- IF (INPUT(I:I).EQ.' ') THEN
- INPUT(I:I) = '0'
- ENDIF
- 10 CONTINUE
-
- READ (INPUT,20) DEG, MIN, ISEC
-
- 20 FORMAT(I3,I2,I4)
-
- SEC = ISEC/100.D0
-
- VAL = (DEG + (MIN/60.D0) + (SEC/3600.D0) )
-
- IF (INPUT(10:10).EQ.CNEG) THEN
- VAL = -VAL
- ENDIF
-
- RETURN
- END
-
-C***************************************************
-
- INTEGER FUNCTION IUNGRD(IREGN, I, J, IVEC)
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (NUMGRD = 10)
- COMMON /CDGRID/ GRDLX(NUMGRD), GRDUX(NUMGRD),
- 1 GRDLY(NUMGRD), GRDUY(NUMGRD),
- 1 ICNTX(NUMGRD), ICNTY(NUMGRD), NBASE(NUMGRD)
-
- IUNGRD = NBASE(IREGN) +
- 1 3 * ((J - 1) * (ICNTX(IREGN) + 1) + (I - 1)) + IVEC
-
- RETURN
- END
-
-C*********************************************************
-C
- SUBROUTINE TOMNT( IYR, IMON, IDAY, IHR, IMN, MINS )
-C
-C********1*********2*********3*********4*********5*********6*********7**
-C
-C NAME: TOMNT (ORIGINALLY IYMDMJ)
-C VERSION: 9004.17
-C WRITTEN BY: M. SCHENEWERK
-C PURPOSE: CONVERT DATE TO MODIFIED JULIAN DATE PLUS UT
-C
-C INPUT PARAMETERS FROM THE ARGUEMENT LIST:
-C -----------------------------------------
-C IDAY DAY
-C IMON MONTH
-C IYR YEAR
-C
-C OUTPUT PARAMETERS FROM ARGUEMENT LIST:
-C --------------------------------------
-C MINS MODIFIED JULIAN DATE IN MINUTES
-C
-C
-C LOCAL VARIABLES AND CONSTANTS:
-C ------------------------------
-C A TEMPORARY STORAGE
-C B TEMPORARY STORAGE
-C C TEMPORARY STORAGE
-C D TEMPORARY STORAGE
-C IMOP TEMPORARY STORAGE
-C IYRP TEMPORARY STORAGE
-C
-C GLOBAL VARIABLES AND CONSTANTS:
-C ------------------------------
-C
-C
-C THIS MODULE CALLED BY: GENERAL USE
-C
-C THIS MODULE CALLS: DINT
-C
-C INCLUDE FILES USED:
-C
-C COMMON BLOCKS USED:
-C
-C REFERENCES: DUFFETT-SMITH, PETER 1982, 'PRACTICAL
-C ASTRONOMY WITH YOUR CALCULATOR', 2ND
-C EDITION, CAMBRIDGE UNIVERSITY PRESS,
-C NEW YORK, P.9
-C
-C COMMENTS: THIS SUBROUTINE REQUIRES THE FULL YEAR,
-C I.E. 1992 RATHER THAN 92.
-C
-C********1*********2*********3*********4*********5*********6*********7**
-C::LAST MODIFICATION
-C::8909.06, MSS, DOC STANDARD IMPLIMENTED
-C::9004.17, MSS, CHANGE ORDER YY MM DD
-C********1*********2*********3*********4*********5*********6*********7**
-C
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER*4 (I-N)
-C
- INTEGER*4 A, B, C, D
-
- IYRP = IYR
-C
-C........ 0.0 EXPLICIT INITIALIZATION
-C
- IF( IMON .LT. 3 ) THEN
- IYRP= IYRP - 1
- IMOP= IMON + 12
- ELSE
- IMOP= IMON
- END IF
-C
-C........ 1.0 CALCULATION
-C
- A= IYRP*0.01D0
- B= 2 - A + DINT( A*0.25D0 )
- C= 365.25D0*IYRP
- D= 30.6001D0*(IMOP + 1)
- MINS = (B + C + D + IDAY - 679006) * (24 * 60)
- & + (60 * IHR) + IMN
-C
- RETURN
- END
-*****************************************************
- SUBROUTINE TOVNEU(GLAT,GLON,VX,VY,VZ,VN,VE,VU)
-
-*** Convert velocities from vx,vy,vz to vn,ve,vu
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
-
- SLAT = DSIN(GLAT)
- CLAT = DCOS(GLAT)
- SLON = DSIN(GLON)
- CLON = DCOS(GLON)
-
- VN = -SLAT*CLON*VX - SLAT*SLON*VY + CLAT*VZ
- VE = -SLON*VX + CLON*VY
- VU = CLAT*CLON*VX + CLAT*SLON*VY + SLAT*VZ
-
- RETURN
- END
-***************************************************
- SUBROUTINE TOVXYZ(GLAT,GLON,VN,VE,VU,VX,VY,VZ)
-*** Convert velocities from vn,ve,vu to vx,vy,vz
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
-
- SLAT = DSIN(GLAT)
- CLAT = DCOS(GLAT)
- SLON = DSIN(GLON)
- CLON = DCOS(GLON)
-
- VX = -SLAT*CLON*VN - SLON*VE + CLAT*CLON*VU
- VY = -SLAT*SLON*VN + CLON*VE + CLAT*SLON*VU
- VZ = CLAT*VN + SLAT*VU
-
- RETURN
- END
-*****************************************************
- SUBROUTINE DPLACE
-
-*** Predict displacements between two dates.
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (numref = 16)
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
- COMMON /FILES/ LUIN,LUOUT, I1, I2, I3, I4, I5, I6
- CHARACTER CARD*80
- CHARACTER record*120
- CHARACTER NAMEF*30,NAME*30,NAMEBB*30, NAMEIF*30
- CHARACTER NAME24
- CHARACTER BLAB*17
- CHARACTER NAMEG*10
- CHARACTER TYPE*4
- CHARACTER OPTION*1,JN*1,JW*1, VOPT*1
- CHARACTER LATDIR*1, LONDIR*1
- CHARACTER ANSWER*1
- character frame1*24
- LOGICAL TEST
-
- BLAB = 'OUTSIDE OF REGION'
-
- WRITE(LUOUT,10)
- 10 FORMAT(
- 1 ' Displacements will be predicted from time T1 to time T2.')
- WRITE(LUOUT,* ) ' Please enter T1 '
- 20 CALL GETMDY(MONTH1,IDAY1,IYEAR1,DATE1,MIN1,TEST)
- IF(TEST) then
- write(luout,*) ' Do you wish to re-enter T1? (y/n)'
- read (luin,21,err=600,iostat=ios) ANSWER
- if (ios /= 0) goto 600
- 21 format( A1 )
- IF (ANSWER .eq. 'y' .or. ANSWER .eq. 'Y') GO TO 20
- RETURN
- ENDIF
- WRITE(LUOUT,*) ' Please enter T2 '
- 35 CALL GETMDY(MONTH2,IDAY2,IYEAR2,DATE2,MIN2,TEST)
- IF(TEST) then
- write(luout,*) ' Do you wish to re-enter T2? (y/n) '
- read(luin,21,err=600,iostat=ios) ANSWER
- if (ios /= 0) goto 600
- if (ANSWER .eq. 'y' .or. ANSWER .eq. 'Y') GO TO 35
- RETURN
- ENDIF
-
- WRITE(LUOUT,45)
- 45 FORMAT(
- 1 ' Please enter the name for the file to contain'/
- 2 ' the predicted displacements. ')
- READ(LUIN,50,err=601,iostat=ios) NAMEF
- if (ios /= 0) goto 601
- 50 FORMAT(A30)
- OPEN(I2,FILE=NAMEF,STATUS='UNKNOWN')
- CALL HEADER
-
-*** Choosing reference frame for displacements
- 56 WRITE(LUOUT,55)
- 55 FORMAT(' ************************************************'/
- 1 ' Select the reference frame to be used for specifying'/
- 2 ' positions and displacements. '/)
- call MENU1(iopt, frame1)
-
- IF(IOPT .GE. 1 .AND . IOPT .LE. numref) THEN
- WRITE(I2,57) frame1
- 57 FORMAT(' DISPLACEMENTS IN METERS RELATIVE TO ', a24)
- ELSE
- WRITE(LUOUT,70)
- 70 FORMAT(' Improper selection--try again. ')
- GO TO 56
- ENDIF
-
- WRITE(I2,71) MONTH1,IDAY1,IYEAR1,MONTH2,IDAY2,IYEAR2,
- 1 DATE1, DATE2
- 71 FORMAT (
- 1 ' FROM ',I2.2,'-',I2.2,'-',I4,' TO ',
- 2 I2.2,'-',I2.2,'-',I4,' (month-day-year)'/
- 2 ' FROM ',F8.3, ' TO ',F8.3, ' (decimal years)'//
- 3 'NAME OF SITE LATITUDE LONGITUDE ',
- 4 ' NORTH EAST UP ')
- 75 WRITE(LUOUT,80)
- 80 FORMAT(' ********************************'/
- 1 ' Displacements will be predicted at each point whose',/
- 2 ' horizontal position is specified.',/
- 4 ' Please indicate how you wish to supply positions.'/ )
- 85 WRITE(LUOUT,86)
- 86 FORMAT(
- 5 ' 0. No more points. Return to main menu.'/
- 6 ' 1. Individual points entered interactively.'/
- 7 ' 2. Points on a specified grid.'/
- 8 ' 3. The *80* records in a specified blue-book file.'/
- 9 ' 4. Points on a specified line. ' /
- 1 ' 5. Batch file of delimited records of form: ' /
- 2 ' LAT,LON,TEXT ' /
- 4 ' LAT = latitude in degrees (positive north/DBL PREC)' /
- 5 ' LON = longitude in degrees (positive west/DBL PREC)' /
- 7 ' TEXT = Descriptive text (CHARACTER*24) ' /
- 8 ' Example: ' /
- 9 ' 40.731671553,112.212671753,SALT AIR '/)
- READ(LUIN,'(A1)',err=602,iostat=ios) OPTION
- if (ios /= 0) goto 602
-
- IF(OPTION .EQ. '0') THEN
- GO TO 510
- ELSEIF(OPTION .EQ. '1') THEN
- CALL GETPNT(LATD,LATM,SLAT,LATDIR,LOND,LONM,SLON,
- 1 LONDIR,NAME24, X,Y,Z,YLAT,YLON,EHT)
- ELON = - YLON
- call GETVLY(YLAT,ELON,VX,VY,VZ,VN,VE,VU,VOPT,210)
- if (vopt .eq. '0') then
- call PREDV( ylat, ylon, eht, date1, iopt,
- 1 jregn, vn, ve, vu)
- if (jregn .eq. 0) then
- write(luout, 140)
- go to 85
- endif
- endif
- call NEWCOR(ylat, ylon, eht, min1, min2,
- 1 ylatt, ylont, ehtnew, dn, de, du, vn, ve, vu)
- 140 FORMAT(' ****************************************'/
- 1 ' A displacement can not be predicted because'/
- 1 ' the point is outside of the modeled region.'/
- 2 ' For additional displacements, please indicate how'/
- 3 ' you wish to supply the horizontal coordinates.'/)
- WRITE(LUOUT,150) DN, DE,DU
- 150 FORMAT(' *************************************'/
- 1 ' Northward displacement = ',F7.3,' meters.'/
- 1 ' Eastward displacement = ',F7.3,' meters.'/
- 1 ' Upward displacement = ',F7.3,' meters.'/
- 1 ' ****************************************'//
- 2 ' For additional displacements, please indicate how'/
- 3 ' you wish to supply the horizontal coordinates.'/)
- WRITE(I2,160) NAME24,LATD,LATM,SLAT,LATDIR,
- 1 LOND,LONM,SLON,LONDIR,DN,DE,DU
- 160 FORMAT(A24,1X,I2,1X,I2,1X,F8.5,1X,A1,2X,
- 1 I3,1X,I2,1X,F8.5,1X,A1,1X,3F8.3)
- ELSEIF(OPTION .EQ. '2') THEN
- CALL GETGRD(NAMEG,MINLAT,MAXLAT,IDS,MINLON,MAXLON,JDS)
- I = -1
- 280 I = I + 1
- LAT = MINLAT + I*IDS
- IF(LAT .GT. MAXLAT) GO TO 296
- XLAT = DBLE(LAT)/RHOSEC
- CALL TODMSS(XLAT,LATD,LATM,SLAT,ISIGN)
- LATDIR = 'N'
- IF (ISIGN .eq. -1) LATDIR = 'S'
- J = -1
- 290 J = J + 1
- YLAT = XLAT
- LON = MINLON + J*JDS
- IF(LON .GT. MAXLON) GO TO 280
- YLON = DBLE(LON)/RHOSEC
- CALL TODMSS(YLON,LOND,LONM,SLON,ISIGN)
- LONDIR = 'W'
- IF (ISIGN .eq. -1) LONDIR = 'E'
- EHT = 0.D0
- call PREDV(ylat,ylon, eht, date1, iopt,
- 1 jregn, vn, ve, vu)
- IF(JREGN .eq. 0) THEN
- WRITE(I2,291)NAMEG,I,J,LATD,LATM,SLAT,LATDIR,LOND,
- 1 LOND,LONM,SLON,LONDIR,BLAB
- 291 FORMAT(A10,2I4, 7X,I2,1X,I2,1X,F8.5,1X,A1,2X,I3,
- 1 1X,I2,1X,F8.5,1X,A1,1X,A17)
- ELSE
- call NEWCOR( ylat, ylon, eht, min1, min2,
- 1 ylatt, ylont, ehtnew, dn, de, du, vn, ve, vu)
- WRITE(I2,295)NAMEG,I,J,LATD,LATM,SLAT,LATDIR,
- 1 LOND,LONM,SLON,LONDIR,DN,DE,DU
- 295 FORMAT(A10,2I4, 7X,I2,1X,I2,1X,F8.5,1X,A1,2X,I3,1X,I2,
- 1 1X,F8.5,1X,A1,1X,3F8.3)
- ENDIF
- GO TO 290
- 296 WRITE(LUOUT,297)
- 297 FORMAT(' ***********************************'/
- 1 ' Displacements have been calculated for the specified'/
- 2 ' grid. If you wish to calculate additional displacements,'/
- 3 ' please indicate how you will supply the coordinates.'/)
- ELSEIF(OPTION .EQ. '3') THEN
- VOPT = '0'
- WRITE(LUOUT,300)
- 300 FORMAT(' Enter name of blue-book file ')
- READ(LUIN,310,err=603,iostat=ios) NAMEBB
- if (ios /= 0) goto 603
- 310 FORMAT(A30)
- OPEN(I1,FILE=NAMEBB,STATUS='OLD')
- 320 READ(I1,330,END=350,err=604,iostat=ios) CARD
- if (ios /= 0) goto 604
- 330 FORMAT(A80)
- TYPE = CARD(7:10)
- IF(TYPE .EQ. '*80*') THEN
- READ(CARD,340,err=605,iostat=ios) NAME,LATD,LATM,SLAT,JN,
- 1 LOND,LONM,SLON,JW
- if (ios /= 0) goto 605
- 340 FORMAT(BZ,14X,A30,I2,I2,F7.5,A1,I3,I2,F7.5,A1)
- NAME24 = NAME(1:24)
-C IF(JN.EQ.'S' .OR. JW.EQ.'E')GO TO 320
- YLAT =(DBLE((LATD*60+LATM)*60)+SLAT)/RHOSEC
- IF (JN .eq. 'S') YLAT = -YLAT
- YLON =(DBLE((LOND*60+LONM)*60)+SLON)/RHOSEC
- IF (JW .eq. 'E') YLON = -YLON
- EHT = 0.D0
- call PREDV( ylat, ylon, eht, date1, iopt,
- 1 jregn, vn, ve, vu)
- IF(JREGN .EQ. 0) THEN
- WRITE(I2,345)NAME24,LATD,LATM,SLAT,JN,LOND,LONM,SLON,
- 1 JW,BLAB
- 345 FORMAT(A24,1X,I2,1X,I2,1X,F8.5,1X,A1,2X,I3,1X,I2,1X,
- 1 F8.5,1X,A1,1X,A17)
- ELSE
- call NEWCOR( ylat, ylon, eht, min1, min2,
- 1 ylatt, ylont, ehtnew, dn, de, du, vn, ve, vu)
- WRITE(I2,160)NAME24,LATD,LATM,SLAT,JN,LOND,LONM,SLON,
- 1 JW,DN,DE,DU
- ENDIF
- ENDIF
- GO TO 320
- 350 CLOSE(I1,STATUS='KEEP')
- WRITE(LUOUT,360)
- 360 FORMAT(' ************************************'/
- 1 ' Displacements have been calculated for the specified'/
- 2 ' blue-book file. If you wish to calculate additional'/
- 3 ' displacements, please indicate how you will supply'/
- 4 ' the horizontal coordinates.'/)
- ELSEIF(OPTION .EQ. '4') THEN
- VOPT = '0'
- CALL GETLYN(NAMEG,XLAT,XLON,FAZ,BAZ,XMIN,XMAX,XINC)
- XLON = TWOPI - XLON
- I = -1
- 400 I = I + 1
- S = XMIN + I*XINC
- IF(S .GT. XMAX) GO TO 430
- IF(S .LT. 0.0D0) THEN
- S1 = -S
- AZ = BAZ
- ELSE
- S1 = S
- AZ = FAZ
- ENDIF
- CALL DIRCT1(XLAT,XLON,YLAT,YLON,AZ,AZ1,S1)
- YLON = TWOPI - YLON
- CALL TODMSS(YLAT,LATD,LATM,SLAT,ISIGN)
- LATDIR = 'N'
- IF (ISIGN .eq. -1) LATDIR = 'S'
- CALL TODMSS(YLON,LOND,LONM,SLON,ISIGN)
- LONDIR = 'W'
- IF (ISIGN .eq. -1) LONDIR = 'E'
- EHT = 0.D0
- call PREDV( ylat, ylon, eht, date1, iopt,
- 1 jregn, vn, ve, vu)
- IF(JREGN .eq. 0) THEN
- WRITE(I2,405)NAMEG,I,LATD,LATM,SLAT,LATDIR,
- 1 LOND,LONM,SLON,LONDIR, BLAB
- 405 FORMAT(A10,I4,11X,I2,1X,I2,1X,F8.5,1X,A1,2X,I3,1X,I2,1X,
- 1 F8.5,1X,A1,1X,A17)
- ELSE
- call NEWCOR( ylat, ylon, eht, min1, min2,
- 1 ylatt, ylont, ehtnew, dn, de, du, vn, ve, vu)
- WRITE(I2,410)NAMEG,I,LATD,LATM,SLAT,LATDIR,LOND,LONM,
- 1 SLON,LONDIR,DN,DE,DU
- 410 FORMAT(A10,I4,11X,I2,1X,I2,1X,F8.5,1X,A1,2X,I3,1X,I2,
- 1 1X,F8.5,1X,A1,1X,3F8.3)
- ENDIF
- GO TO 400
- 430 WRITE(LUOUT,440)
- 440 FORMAT(' ***************************************'/
- 1 ' Displacements have been calculated for the specified'/
- 2 ' line. If you wish to calculate additional displacements,'/
- 3 ' please indicate how you will supply the coordinates.'/)
- ELSEIF(OPTION .EQ. '5') THEN
- VOPT = '0'
- EHT = 0.0D0
- write(luout,450)
- 450 format(' Enter name of batch file ')
- read(luin, 451,err=606,iostat=ios) NAMEIF
- if (ios /= 0) goto 606
- 451 format(a30)
- open(I1,FILE=NAMEIF,STATUS='OLD')
- 455 read(I1,'(a)',END=460,err=607,iostat=ios) record
- if (ios /= 0) goto 607
-c write(i2, 457) record
- call interprate_latlon_record (record,XLAT,XLON,name24)
-c write (i2,456) xlat, xlon
-c write(i2,457) record
-c 457 format (a50)
-c 456 format(1x,' xlat = ', f15.3, 'xlon = ', f15.3)
- YLAT = (XLAT*3600.D0)/RHOSEC
- YLON = (XLON*3600.D0)/RHOSEC
- CALL TODMSS(YLAT,LATD,LATM,SLAT,ISIGN)
- IF (ISIGN .EQ. 1) THEN
- JN = 'N'
- ELSE
- JN = 'S'
- ENDIF
- CALL TODMSS(YLON, LOND,LONM,SLON,ISIGN)
- IF (ISIGN .EQ. 1) THEN
- JW = 'W'
- ELSE
- JW = 'E'
- ENDIF
- CALL PREDV(YLAT,YLON,EHT,DATE1,IOPT,
- 1 JREGN,VN,VE,VU)
- IF (JREGN .EQ. 0) THEN
- Write(I2,345) NAME24,LATD,LATM,SLAT, JN,
- 1 LOND,LONM,SLON,JW, BLAB
- ELSE
- CALL NEWCOR (YLAT, YLON, EHT, MIN1, MIN2,
- 1 YLATT, YLONT, EHTNEW, DN,DE,DU,VN,VE,VU)
- WRITE(I2, 160) NAME24, LATD, LATM, SLAT, JN,
- 1 LOND, LONM, SLON, JW, DN, DE , DU
- ENDIF
- GO TO 455
- 460 CLOSE(I1, STATUS = 'KEEP')
- write(LUOUT, 470)
- 470 format(' ******************************************'/
- 1 ' Displacements have been calculated for the specified'/
- 1 ' file. If you wish to calculate additional displacements,'/
- 1 ' please indicate how you will supply the horizontal '/
- 1 ' coordinates.'/)
- ELSE
- WRITE(LUOUT,500)
- 500 FORMAT(' Improper entry--select again. ')
- ENDIF
- GO TO 85
- 510 CONTINUE
- CLOSE(I2, STATUS = 'KEEP')
- RETURN
-
- 600 write (*,'(/)')
- write (*,*) 'Wrong answer in DPLACE: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 601 write (*,'(/)')
- write (*,*) 'Wrong file name in DPLACE: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 602 write (*,'(/)')
- write (*,*) 'Wrong OPTION in DPLACE: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 603 write (*,'(/)')
- write (*,*) 'Wrong bbname in DPLACE: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 604 write (*,'(/)')
- write (*,*) 'Wrong CARD from bbfile in DPLACE:ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 605 write (*,'(/)')
- write (*,*) 'Wrong CARD80 from bbfile in DPLACE:ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 606 write (*,'(/)')
- write (*,*) 'Wrong batch file name in DPLACE:ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 607 write (*,'(/)')
- write (*,*) 'Wrong record from batch in DPLACE:ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- END
-********************************************************************
- SUBROUTINE VELOC
-
-*** Compute velocities at specified locations
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (numref = 16)
- parameter (nrsrch = 0)
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
- COMMON /FILES/ LUIN,LUOUT, I1, I2, I3, I4, I5, I6
- CHARACTER CARD*80
- CHARACTER NAMEF*30,NAME*30,NAMEBB*30,PVFILE*30
- CHARACTER NAME24*24
- CHARACTER BLAB*17
- CHARACTER NAMEG*10
- CHARACTER TYPE*4
- CHARACTER OPTION*1,JN*1,JW*1,PVOUT*1
- CHARACTER LATDIR*1, LONDIR*1
- character frame1*24
- character record*120
-
-*** temporary code to plot results ****************
- character TEMPNA
-
- TEMPNA = ' '
- DUMMY = 0.0D0
-*** end of temporary code *************************
-
- BLAB = 'OUTSIDE OF REGION'
-
- WRITE(LUOUT,10)
- 10 FORMAT(' Please enter name for the file to contain the'/
- 1 ' predicted velocities. ')
- READ(LUIN,20,err=700,iostat=ios) NAMEF
- if (ios /= 0) goto 700
- 20 FORMAT(A30)
- OPEN(I2,FILE=NAMEF,STATUS='UNKNOWN')
- CALL HEADER
-
- if (nrsrch .eq. 1) then
- WRITE(LUOUT,21)
- 21 FORMAT(
- 1 ' Do you want to create a file of point-velocity (PV)'/
- 1 ' records for use with the DYNAPG software (y/n)? ')
- READ(LUIN,'(A1)',err=701,iostat=ios) PVOUT
- if (ios /= 0) goto 701
- IF(PVOUT .EQ. 'Y' .OR. PVOUT .EQ. 'y') THEN
- PVOUT = 'Y'
- WRITE(LUOUT,22)
- 22 FORMAT(' Enter name for the file that is to contain'/
- 1 ' the PV records. ')
- READ(LUIN,'(A30)',err=702,iostat=ios) PVFILE
- if (ios /= 0) goto 702
- OPEN(I3,FILE = PVFILE, STATUS = 'UNKNOWN')
- ENDIF
- else
- PVOUT = 'N'
- endif
-
-*** Choosing reference system for velocities
- 1000 WRITE(LUOUT,1001)
- 1001 FORMAT(' **************************************************'/
- 1 ' Select the reference frame to be used for specifying'/
- 2 ' positions and velocities. '/
-c 6 ' 0...Positions in NAD 83 and velocities relative to'/
-c 6 ' a specified point having a specified velocity.')
- 6 )
- call MENU1(iopt, frame1)
- if (iopt .ge. 1 .and. iopt .le. numref) then
- WRITE(I2,1002) frame1
- 1002 FORMAT('VELOCITIES IN MM/YR RELATIVE TO ', a24 /)
- RVN = 0.0D0
- RVE = 0.0D0
- RVU = 0.0D0
- ELSEIF(IOPT .EQ. 0) THEN
- WRITE(LUOUT,1010)
- CALL GETPNT(LATD,LATM,SLAT,LATDIR,LOND,LONM,SLON,
- 1 LONDIR, NAME24, X,Y,Z,YLAT,YLON,EHT)
- CALL GETREG(YLAT,YLON,JREGN)
- IF(JREGN .EQ. 0 ) THEN
- WRITE(LUOUT,1008)
- 1008 FORMAT(' **********************************'/
- 1 ' Point is not in modeled region and it can not'/
- 1 ' be used as the reference location.'/)
- GO TO 1000
- ENDIF
- WRITE(I2,1009)
- 1009 FORMAT('VELOCITIES IN MM/YR IN A REFERENCE FRAME FOR ',
- 1 'WHICH THE FIRST POINT LISTED'/
- 2 'BELOW HAS THE VELOCITY AS LISTED'//
- 4 '**************REFERENCE SITE')
- 1010 FORMAT(' For the reference point...'/)
- WRITE(LUOUT,1030)
- 1030 FORMAT(' Enter northward velocity of reference location'/
- 1 ' in mm/yr. ')
- READ(LUIN,*,err=703,iostat=ios) SVN
- if (ios /= 0) goto 703
- WRITE(LUOUT,1040)
- 1040 FORMAT(' Enter eastward velocity of reference location'/
- 1 ' in mm/yr. ')
- READ(LUIN,*,err=703,iostat=ios) SVE
- if (ios /= 0) goto 703
- WRITE(LUOUT,1050)
- 1050 FORMAT(' Enter upward velocity of the reference location'/
- 1 ' in mm/yr. ')
- READ(LUIN,*,err=703,iostat=ios) SVU
- if (ios /= 0) goto 703
- CALL COMVEL(YLAT,YLON,JREGN,VN,VE,VU)
- RVN = SVN - VN
- RVE = SVE - VE
- RVU = SVU - VU
- GLON = -YLON
- CALL TOVXYZ(YLAT,GLON,SVN,SVE,SVU,SVX,SVY,SVZ)
- WRITE(I2,1060) NAME24,LATD,LATM,SLAT,LATDIR,SVN,LOND,LONM,
- 1 SLON,LONDIR,SVE,EHT,SVU,X,SVX,Y,SVY,Z,SVZ
- 1060 FORMAT(/10X,A24,/
- 1'LATITUDE = ',2I3,F9.5,1X,A1,' NORTH VELOCITY =',F7.2,' mm/yr'/
- 2'LONGITUDE = ',2I3,F9.5,1X,A1,' EAST VELOCITY =',F7.2,' mm/yr'/
- 3'ELLIPS. HT. = ',F10.3,' m', 6X,'UP VELOCITY =',F7.2,' mm/yr'/
- 4'X =',F13.3,' m',14X, 'X VELOCITY =',F7.2,' mm/yr'/
- 5'Y =',F13.3,' m',14X, 'Y VELOCITY =',F7.2,' mm/yr'/
- 6'Z =',F13.3,' m',14X, 'Z VELOCITY =',F7.2,' mm/yr')
- WRITE(I2,1070)
- 1070 FORMAT('******************************')
- ELSE
- write(luout, 1080)
- 1080 format(' Improper selection -- try again. ')
- GO TO 1000
- ENDIF
-
-*** Choosing input format for locations where velocities are to be predicted
- WRITE(LUOUT,30)
- 30 FORMAT(' ************************************************'/
- 1 ' Velocities will be predicted at each point whose'/
- 2 ' horizontal position is specified. Please indicate'/
- 4 ' how you wish to supply positions.'/)
- 40 WRITE(LUOUT,50)
- 50 FORMAT(
- 1 ' 0... No more points. Return to main menu.'/
- 2 ' 1... Individual points entered interactively.'/
- 3 ' 2... Points on a specified grid.'/
- 4 ' 3... The *80* records in a specified blue-book file.'/
- 5 ' 4... Points on a specified line. '/
- 6 ' 5... Batch file of delimited records of form: '/
- 7 ' LAT,LON,TEXT '/
- 8 ' LAT = latitude in degrees (positive north/DBL PREC) '/
- 9 ' LON = longitude in degrees (positive west/DBL PREC) '/
- 1 ' TEXT = Descriptive text (CHARACTER*24) '/
- 1 ' Example: '/
- 2 ' 40.731671553,112.212671753,SALT AIR '/)
-
- READ(LUIN,60,err=704,iostat=ios) OPTION
- if (ios /= 0) goto 704
- 60 FORMAT(A1)
-
- IF(OPTION .EQ. '0') THEN
- GO TO 610
- ELSEIF(OPTION .EQ. '1') THEN
- CALL GETPNT(LATD,LATM,SLAT,LATDIR,LOND,LONM,SLON,
- 1 LONDIR, NAME24, X,Y,Z,YLAT,YLON,EHT)
- CALL GTOVEL(YLAT,YLON,EHT,RVN,RVE,RVU,
- 1 VN,VE,VU,VX,VY,VZ,JREGN,IOPT)
- IF(JREGN .eq. 0 ) THEN
- WRITE(LUOUT,80)
- 80 FORMAT(' *************************************'/
- 1 ' A velocity can not be predicted because'/
- 1 ' the point is outside of the modeled region.'/
- 2 ' For additional velocities, please indicate how'/
- 3 ' you wish to supply the horizontal coordinates.'/)
- ELSE
- WRITE(LUOUT,90) VN, VE, VU, VX, VY, VZ
- 90 FORMAT(' **************************************'/
- 1 ' Northward velocity = ',F6.2,' mm/yr'/
- 1 ' Eastward velocity = ',F6.2,' mm/yr'/
- 1 ' Upward velocity = ',F6.2,' mm/yr'//
- 1 ' X-dim. velocity = ',F6.2,' mm/yr'/
- 1 ' Y-dim. velocity = ',F6.2,' mm/yr'/
- 1 ' Z-dim. velocity = ',F6.2,' mm/yr'/
- 1 ' **************************************'//
- 2 ' For additional velocities, please indicate how'/
- 3 ' you wish to specify the horizontal coordinates.'/)
- WRITE(I2,1060)NAME24,LATD,LATM,SLAT,LATDIR,VN,LOND,LONM,
- 1 SLON, LONDIR, VE, EHT,VU,X,VX,Y,VY,Z,VZ
- 100 FORMAT(A24,1X,I2,1X,I2,1X,F8.5,1X,A1,2X,I3,1X,I2,1X,F8.5,
- 1 1X,A1,1X,3F8.2)
- IF(PVOUT .EQ. 'Y') THEN
- CALL PVPRNT(LATD,LATM,SLAT,LOND,LONM,SLON,VN,VE,VU)
- ENDIF
- ENDIF
- ELSEIF(OPTION .EQ. '2') THEN
- EHT = 0.D0
- WRITE(I2,105)
- 105 FORMAT(
- 1 'NAME OF SITE',14X,'LATITUDE LONGITUDE ',
- 2 ' NORTH EAST UP'/)
- 106 FORMAT(
- 1 'NAME OF LINE', 6X,'LATITUDE LONGITUDE ',
- 2 ' NORTH EAST UP'/)
- CALL GETGRD(NAMEG,MINLAT,MAXLAT,IDS,MINLON,MAXLON,JDS)
- I = -1
- 110 I = I + 1
- LAT = MINLAT + I*IDS
- IF(LAT .GT. MAXLAT) GO TO 150
- XLAT = DBLE(LAT)/RHOSEC
- CALL TODMSS(XLAT,LATD,LATM,SLAT,ISIGN)
- LATDIR = 'N'
- IF (ISIGN .eq. -1) LATDIR = 'S'
- J = -1
- 120 J = J + 1
- YLAT = XLAT
- ON = MINLON + J*JDS
- IF(LON .GT. MAXLON) GO TO 110
- YLON = DBLE(LON)/RHOSEC
- CALL TODMSS(YLON,LOND,LONM,SLON,ISIGN)
- LONDIR = 'W'
- IF (ISIGN .eq. -1) LONDIR = 'E'
- CALL GTOVEL(YLAT,YLON,EHT,RVN,RVE,RVU,
- 1 VN,VE,VU,VX,VY,VZ,JREGN,IOPT)
- IF(JREGN .EQ. 0 ) THEN
- WRITE(I2,125)NAMEG,I,J,LATD,LATM,SLAT,LATDIR,LOND,LONM,
- 1 SLON,LONDIR,BLAB
- 125 FORMAT(A10,2I4, 7X,I2,1X,I2,1X,F8.5,1X,A1,2X,I3,1X,I2,
- 1 1X,F8.5,1X,A1, 1X,A17)
- ELSE
-
-*** temporary code to plot results
- ZLAT = DBLE(LATD) + DBLE(LATM)/60.D0 + SLAT/3600.D0
- ZLON = DBLE(LOND) + DBLE(LONM)/60.D0 + SLON/3600.D0
- ZLON = 360.D0 - ZLON
- TOTVEL = DSQRT(VN*VN + VE*VE)
-
-*** code to create vectors to be plotted
-c IF (TOTVEL .GE. 5.0D0 .AND. TOTVEL .LE. 50.D0) THEN
-c TVE = VE/10.D0
-c TVN = VN/10.D0
-c WRITE(I2,129) ZLON,ZLAT,TVE,TVN,DUMMY,DUMMY,DUMMY,
-c 1 TEMPNA
-c 129 FORMAT(F10.6, 2x, F9.6, 2X, 5(F7.2, 2x), A8)
-c ENDIF
-
-*** code to create contour plots
-C WRITE(I2,129) ZLON, ZLAT, TOTVEL
-C 129 FORMAT(F6.2, 1X, F6.2, 1X, F5.1)
-
-*** end of temporary code
-
-*** beginning of original code
- WRITE(I2,130)NAMEG,I,J,LATD,LATM,SLAT,LATDIR,
- 1 LOND,LONM,SLON,LONDIR,VN,VE,VU
- 130 FORMAT(A10,2I4, 7X,I2,1X,I2,1X,F8.5,1X,A1,2X,
- 1 I3,1X,I2,1X,F8.5,1X,A1,1X,3F8.2)
-*** end of original code
-
- IF(PVOUT .EQ. 'Y') THEN
- CALL PVPRNT(LATD,LATM,SLAT,LOND,LONM,SLON,VN,VE,VU)
- ENDIF
- ENDIF
- GO TO 120
- 150 WRITE(LUOUT,160)
- 160 FORMAT(' **********************************************'/
- 1 ' Velocities have been calculated for the specified grid.'/
- 2 ' If you wish to calculate additional velocities, please'/
- 3 ' indicate how you will specify positional coordinates.'/)
- ELSEIF(OPTION .EQ. '3') THEN
- EHT = 0.D0
- WRITE(I2,105)
- WRITE(LUOUT,200)
- 200 FORMAT(' Enter name of blue-book file. ')
- READ(LUIN,210,err=705,iostat=ios) NAMEBB
- if (ios /= 0) goto 705
- 210 FORMAT(A30)
- OPEN(I1,FILE=NAMEBB,STATUS='OLD')
- 220 READ(I1,230,END=250,err=706,iostat=ios) CARD
- if (ios /= 0) goto 706
- 230 FORMAT(A80)
- TYPE = CARD(7:10)
- IF(TYPE .EQ. '*80*') THEN
- READ(CARD,240,err=707,iostat=ios)NAME,LATD,LATM,SLAT,JN,
- 1 LOND,LONM,SLON,JW
- if (ios /= 0) goto 707
- 240 FORMAT(BZ,14X,A30,I2,I2,F7.5,A1,I3,I2,F7.5,A1)
- NAME24 = NAME(1:24)
- YLAT =(DBLE((LATD*60+LATM)*60)+SLAT)/RHOSEC
- YLON =(DBLE((LOND*60+LONM)*60)+SLON)/RHOSEC
- if (jn .eq. 'S') ylat = -ylat
- if (jw .eq. 'E') ylon = -ylon
- CALL GTOVEL(YLAT,YLON,EHT,RVN,RVE,RVU,
- 1 VN,VE,VU,VX,VY,VZ,JREGN,IOPT)
- IF(JREGN .EQ. 0 ) THEN
- WRITE(I2,245)NAME24,LATD,LATM,SLAT,JN,LOND,LONM,
- 1 SLON,JW,BLAB
- 245 FORMAT(A24,1X,I2,1X,I2,1X,F8.5,1X,A1,2X,I3,1X,I2,
- 1 1X,F8.5,1X,A1,1X,A17)
- ELSE
- WRITE(I2,100)NAME24,LATD,LATM,SLAT,JN,LOND,LONM,
- 1 SLON,JW,VN,VE,VU
- IF(PVOUT .EQ. 'Y') THEN
- CALL PVPRNT(LATD,LATM,SLAT,LOND,LONM,SLON,VN,VE,VU)
- ENDIF
- ENDIF
- ENDIF
- GO TO 220
- 250 CLOSE(I1,STATUS='KEEP')
- WRITE(LUOUT,260)
- 260 FORMAT(' ****************************************'/
- 1 ' Velocities have been calculated for the specified '/
- 2 ' blue-book file. If you wish to calculate additional'/
- 3 ' velocities, please indicate how you will supply the'/
- 4 ' horizontal coordinates.'/)
- ELSEIF(OPTION .EQ. '4') THEN
- EHT = 0.D0
- WRITE(I2,106)
- CALL GETLYN(NAMEG,XLAT,XLON,FAZ,BAZ,XMIN,XMAX,XINC)
- XLON = TWOPI - XLON
- I = -1
- 300 I= I+1
- S = XMIN + I*XINC
- IF(S .GT. XMAX) GO TO 330
- IF(S .LT. 0.0D0) THEN
- S1 = -S
- AZ = BAZ
- ELSE
- S1 = S
- AZ = FAZ
- ENDIF
- CALL DIRCT1(XLAT,XLON,YLAT,YLON,AZ,AZ1,S1)
- YLON = TWOPI - YLON
- CALL TODMSS(YLAT,LATD,LATM,SLAT,ISIGN)
- LATDIR = 'N'
- IF (ISIGN .eq. -1) LATDIR = 'S'
- CALL TODMSS(YLON,LOND,LONM,SLON,ISIGN)
- LONDIR = 'W'
- IF (ISIGN .eq. -1) LONDIR = 'E'
- CALL GTOVEL(YLAT,YLON,EHT,RVN,RVE,RVU,
- 1 VN,VE,VU,VX,VY,VZ,JREGN,IOPT)
- IF(JREGN .EQ. 0 ) THEN
- WRITE(I2,305)NAMEG,I,LATD,LATM,SLAT,LATDIR,LOND,LONM,
- 1 SLON,LONDIR,BLAB
- 305 FORMAT(A10,I4,3X,I2,1X,I2,1X,F8.5,1X,A1,2X,I3,1X,
- 1 I2,1X,F8.5,1X,A1,1X,A17)
- ELSE
- WRITE(I2,310)NAMEG,I,LATD,LATM,SLAT,LATDIR,LOND,LONM,SLON,
- 1 LONDIR,VN,VE,VU
- 310 FORMAT(A10,I4,3X,I2,1X,I2,1X,F8.5,1X,A1,2X,I3,1X,I2,1X,
- 1 F8.5,1X,A1,1X,3F8.2)
- IF(PVOUT .EQ. 'Y') THEN
- CALL PVPRNT(LATD,LATM,SLAT,LOND,LONM,SLON,VN,VE,VU)
- ENDIF
- ENDIF
- GO TO 300
- 330 WRITE(LUOUT,340)
- 340 FORMAT(' ***********************************************'/
- 1 ' Velocities have been calculated for the specified line.'/
- 2 ' If you wish to calculate additional velocities, please'/
- 3 ' indicate how you will specify positional coordinates.'/)
- ELSEIF(OPTION .EQ. '5') THEN
- EHT = 0.0D0
- WRITE(I2, 105)
- WRITE(LUOUT,400)
- 400 FORMAT(' Enter name of input file. ')
- READ(LUIN,410,err=708,iostat=ios) NAMEBB
- if (ios /= 0) goto 708
- 410 FORMAT(A30)
- OPEN(I1,FILE=NAMEBB,STATUS='OLD')
- 420 READ(I1,'(a)',END=450,err=709,iostat=ios) record
- call interprate_latlon_record (record,XLAT,XLON,NAME24)
- if (ios /= 0) goto 709
- YLAT = (XLAT*3600.D0)/RHOSEC
- YLON = XLON*3600.d0/RHOSEC
- CALL TODMSS(YLAT, LATD, LATM, SLAT, ISIGN)
- IF (ISIGN .eq. 1) then
- JN = 'N'
- Else
- JN = 'S'
- endif
- call TODMSS(YLON, LOND, LONM, SLON, ISIGN)
- IF (ISIGN .eq. 1) then
- JW = 'W'
- else
- JW = 'E'
- endif
- CALL GTOVEL(YLAT,YLON,EHT,RVN,RVE, RVU,
- 1 VN,VE,VU,VX,VY,VZ,JREGN,IOPT)
- IF (JREGN .eq. 0) then
- write(I2,245)NAME24,LATD,LATM,SLAT,JN,
- 1 LOND,LONM,SLON,JW,BLAB
- ELSE
- write(I2,100)NAME24,LATD,LATM,SLAT,JN,
- 1 LOND,LONM,SLON,JW,VN,VE,VU
- IF(PVOUT .EQ. 'Y') then
- call PVPRNT(LATD,LATM,SLAT,LOND,LONM,SLON,VN,VE,VU)
- ENDIF
- ENDIF
- GO TO 420
- 450 CLOSE(I1, STATUS = 'KEEP')
- write(LUOUT, 460)
- 460 format(' ********************************'/
- 1 ' Velocities have been calculated for the specified'/
- 2 ' file. if you wish to calculate additional velocities, '/
- 3 ' please indicate how you will supply the coordinates.'/)
- ELSE
- WRITE(LUOUT,600)
- 600 FORMAT(' Improper entry--select again. ')
- ENDIF
- GO TO 40
- 610 CONTINUE
- CLOSE(I2, STATUS = 'KEEP')
- IF( PVOUT .EQ. 'Y') CLOSE(I3, STATUS = 'KEEP')
- RETURN
-
- 700 write (*,'(/)')
- write (*,*) 'Failed to read file name: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 701 write (*,'(/)')
- write (*,*) 'Failed to read answer: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 702 write (*,'(/)')
- write (*,*) 'Failed to read file name: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 703 write (*,'(/)')
- write (*,*) 'Failed to read velocity: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 704 write (*,'(/)')
- write (*,*) 'Failed to read OPTION: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 705 write (*,'(/)')
- write (*,*) 'Failed to read name of bbfile: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 706 write (*,'(/)')
- write (*,*) 'Failed to read card from bbfile: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 707 write (*,'(/)')
- write (*,*) 'Failed to read card80 from bbfile: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 708 write (*,'(/)')
- write (*,*) 'Failed to read file name: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 709 write (*,'(/)')
- write (*,*) 'Failed to read bbfile: ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
-
- END
-**************************************************************************
- SUBROUTINE GTOVEL(YLAT,YLON,EHT,RVN,RVE,RVU,
- 1 VN,VE,VU,VX,VY,VZ,JREGN,IOPT)
-
-*** Compute velocity in appropriate reference frame for point with
-*** latitude YLAT (radians), longitude YLON (radians, positive west)
-*** and ellipsoid height EHT (meters) in this reference frame.
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- logical Is_iopt_NAD83
-
- Is_iopt_NAD83 = (IOPT == 1)
-
-*** Get reference latitude RLAT and reference longitude RLON in NAD 83
-c IF(IOPT .EQ. 0 .OR. IOPT .EQ. 1) THEN !Not NAD83 antmore
- IF(IOPT .EQ. 15) THEN
- RLAT = YLAT
- RLON = YLON
- ELSE
- ELON = -YLON
- CALL TOXYZ(YLAT,ELON,EHT,X,Y,Z)
- DATE = 2010.0d0
-c CALL XTONAD(X,Y,Z,RLAT,RLON,EHTNAD,DATE,IOPT) !Removed on 09/12/2014. The velocity grids are not converted to NAD83 anymore.
- CALL XTO08 (X,Y,Z,RLAT,RLON,EHT08,DATE,IOPT) !They are in ITRF2008
- ENDIF
-
-*** Get velocity in NAD 83 !Not anymore since 09/12/2014. Now it is in ITRF2008
- CALL GETREG(RLAT,RLON,JREGN)
- IF (JREGN .EQ. 0) RETURN
- CALL COMVEL(RLAT,RLON,JREGN,VN,VE,VU)
-
- VN = VN + RVN
- VE = VE + RVE
- VU = VU + RVU
- ELON = -YLON
- CALL TOVXYZ(YLAT,ELON,VN,VE,VU,VX,VY,VZ)
-
-*** Convert velocity into another reference frame if needed
-c IF(IOPT .NE. 0 .AND. IOPT .NE. 1) THEN !Commented out on 09/12/2014
- IF(IOPT .NE. 15) THEN
- IF(Is_iopt_NAD83) THEN
-c CALL VTRANF(X,Y,Z,VX,VY,VZ, 1, IOPT) !No longer NAD83
- CALL VTRANF(X,Y,Z,VX,VY,VZ, 15, IOPT) !No longer NAD83
- else
- CALL VTRANF_IERS(X,Y,Z,VX,VY,VZ, 15, IOPT) !Now ITRF2008
- endif
- CALL TOVNEU(YLAT, ELON, VX, VY, VZ, VN, VE, VU)
- ENDIF
-
- RETURN
- END
-****************************************************************************
- SUBROUTINE XTO08 (X,Y,Z,RLAT,WLON,EHT08,DATE,IOPT)
-
-*** Converts X,Y,Z in specified datum to latitude and
-*** longitude (in radians) and height (meters) in ITRF2008
-*** datum with longitude positive west.
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- LOGICAL FRMXYZ
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
-
-*** Convert to cartesian coordinates in ITRF2008
-c if (iopt .eq. 0 .or. iopt .eq. 1) then
- if (iopt .eq. 15) then
- x2 = x
- y2 = y
- z2 = z
- elseif (iopt .eq. 1) then
- call toit94(x,y,z,x1,y1,z1,date,iopt)
- call frit94(x1,y1,z1,x2,y2,z2,date,15)
- else
- call toit94_iers(x,y,z,x1,y1,z1,date,iopt)
- call frit94_iers(x1,y1,z1,x2,y2,z2,date,15)
- endif
-
-***Convert to geodetic coordinates
- IF(.NOT.FRMXYZ(X2,Y2,Z2,RLAT,ELON,EHT08))STOP 666
-
- WLON = -ELON
- 100 IF(WLON .LT. 0.D0) THEN
- WLON = WLON + TWOPI
- GO TO 100
- ENDIF
-
-c write (*,*) "FROM XT08 ",RLAT*180.d0/pi,WLON*180.d0/pi,EHT08
- RETURN
- END
-
-****************************************************************************
- SUBROUTINE XTONAD (X,Y,Z,RLAT,WLON,EHTNAD,DATE,IOPT)
-
-*** Converts X,Y,Z in specified datum to latitude and
-*** longitude (in radians) and height (meters) in NAD 83
-*** datum with longitude positive west.
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- LOGICAL FRMXYZ
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
-
-*** Convert to cartesian coordinates in NAD 83
- if (iopt .eq. 0 .or. iopt .eq. 1) then
- x2 = x
- y2 = y
- z2 = z
- else
- call toit94(x,y,z,x1,y1,z1,date,iopt)
- jopt = 1
- call frit94(x1,y1,z1,x2,y2,z2,date,jopt)
- endif
-
-***Convert to geodetic coordinates
- IF(.NOT.FRMXYZ(X2,Y2,Z2,RLAT,ELON,EHTNAD))STOP 666
-
- WLON = -ELON
- 100 IF(WLON .LT. 0.D0) THEN
- WLON = WLON + TWOPI
- GO TO 100
- ENDIF
- RETURN
- END
-
-******************************************************
- subroutine TRFPOS
-
-*** Transform position between reference frames
-
- implicit double precision (a-h,o-z)
- implicit integer*4 (i-n)
- parameter (numref = 16)
- parameter (nbbdim = 10000)
- parameter (rad2deg = 180.d0/3.14159265358979d0)
-
- double precision lat,lon
- character card*80,namebb*80,nameif*80,name24*80
- character record*120
- character namef*30
- character frame1*24, frame2*24
- character jn*1,jw*1,LATDIR*1,LONDIR*1
- character option*1, answer*1, vopt*1
- character PID*6,PIDs*6
- character HTDP_version*10
- LOGICAL FRMXYZ
- LOGICAL TEST
- LOGICAL Is_inp_NAD83,Is_out_NAD83
- LOGICAL Is_inp_NAD83PAC,Is_out_NAD83PAC
- LOGICAL Is_inp_NAD83MAR,Is_out_NAD83MAR
- logical am_I_in_or_near_AK
- logical am_I_in_or_near_AS
- logical am_I_in_or_near_CONUS
- logical am_I_in_or_near_CQ
- logical am_I_in_or_near_Guam
- logical am_I_in_or_near_HI
- logical am_I_in_or_near_PR
- logical am_I_in_or_near_VQ
- logical am_I_in_or_near_KW
-
- COMMON /CONST/ A, F, E2, EPS, AF, PI, TWOPI, RHOSEC
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
- COMMON /ARRAYS/ HT(nbbdim), LOC(nbbdim),PIDs(nbbdim)
- COMMON /VERSION/ HTDP_version
-
- write(luout,80)
- 80 format(
- 1 ' Please enter the name for the file to contain'/
- 2 ' the transformed positions. ')
- read(luin,'(a30)',err=600,iostat=ios) namef
- if (ios /= 0) goto 600
- open(i2, file = namef, status = 'unknown')
- CALL HEADER
-
- 95 write(luout,100)
- 100 format (' *******************************************'/
- 1 ' Enter the reference frame of the input positions')
- call MENU1(iopt1, frame1)
- if (iopt1 .lt. 1 .or. iopt1 .gt. numref) then
- write(luout,*) ' Improper selection -- try again. '
- go to 95
- endif
- Is_inp_NAD83 = (iopt1 == 1 .and. frame1(1:3) /= "WGS")
- Is_inp_NAD83PAC = (iopt1 == 12)
- Is_inp_NAD83MAR = (iopt1 == 13)
-
- 105 write(luout,110)
- 110 format (/' Enter the reference frame for the output positions')
- call MENU1(iopt2, frame2)
- if (iopt2 .lt. 1 .or. iopt2 .gt. numref) then
- write(luout,*) ' Improper selection -- try again. '
- go to 105
- endif
- Is_out_NAD83 = (iopt2 == 1 .and. frame1(1:3) /= "WGS")
- Is_out_NAD83PAC = (iopt2 == 12)
- Is_out_NAD83MAR = (iopt2 == 13)
-
- write(luout,120)
- 120 format (/
- 1 ' Enter the reference date of the input positions.')
- 121 CALL GETMDY(MONTH1, IDAY1, IYEAR1, DATE1, MIN1, TEST)
- IF(TEST) then
- write(luout,*) ' Do you wish to re-enter the date? (y/n)'
- read(luin, '(A1)',err=601,iostat=ios) ANSWER
- if (ios /= 0) goto 601
- if(ANSWER .eq. 'y' .or. ANSWER .eq. 'Y')GO TO 121
- RETURN
- ENDIF
-
- write(luout,130)
- 130 format(/
- 1 ' Enter the reference date for the output positions. ')
- 131 CALL GETMDY(MONTH2, IDAY2, IYEAR2, DATE2, MIN2, TEST)
- IF(TEST) then
- write(luout,*) ' Do you wish to re-enter the date? (y/n)'
- read(luin, '(A1)',err=601,iostat=ios) ANSWER
- if (ios /= 0) goto 601
- if(ANSWER .eq. 'Y' .or. ANSWER .eq. 'y') GO TO 131
- RETURN
- ENDIF
-
- write(i2, 150) frame1, month1, iday1, iyear1, date1,
- 1 frame2, month2, iday2, iyear2, date2
- 150 format(' TRANSFORMING POSITIONS FROM ',A24,' (EPOCH = ',
- 1 I2.2,'-',I2.2,'-',I4,' (',F9.4,'))'/26X,
- 1 'TO ', A24, ' (EPOCH = ',I2.2,'-',I2.2,'-',I4,' (',F9.4,'))'/)
-c 1 13X,'INPUT COORDINATES OUTPUT COORDINATES',
-c 1 4x, 'INPUT VELOCITY' /)
-
- 160 write(luout, 170)
- 170 format (/' ***************************************'/
- 1 ' Coordinates will be transformed at each specified point.'/
- 1 ' Please indicate how you wish to supply positions.'/
- 1 ' 0... No more points. Return to main menu.'/
- 1 ' 1... Individual points entered interactively.'/
- 1 ' 2... The *80* records in a specified blue-book file. '/
- 1 ' 3... Transform positions contained in batch file '/
- 1 ' of delimited records of the form: '/
- 1 ' LAT,LON,EHT,TEXT' /
- 1 ' LAT = latitude in degrees (positive north/DBL PREC)'/
- 1 ' LON = longitude in degrees (positive west/DBL PREC)'/
- 1 ' EHT = ellipsoid height in meters (DBL PREC)'/
- 1 ' TEXT = Descriptive text (CHARACTER*24) '/
- 1 ' Example: '/
- 1 ' 40.731671553,112.212671753,34.241,SALT AIR '/
- 1 ' 4... Transform positions contained in batch file '/
- 1 ' of delimited records of the form: '/
- 1 ' X, Y, Z,TEXT' /
- 1 ' X, Y, Z are Cartesian coordinates of the station'/
- 1 ' TEXT = Descriptive text (CHARACTER*24) '/
- 1 ' Example: '/
- 1 ' -86682.104,-5394026.861,3391189.647,SALT AIR '/
- 1 ' Necessary velocities predicted by HTDP '/
- 1 ' 5... Transform positions using velocities contained in a '/
- 1 ' batch file of delimited records of the form: '/
- 1 ' X, Y, Z, Vx, Vy, Vz, TEXT' /
- 1 ' X, Y, Z are Cartesian coordinates of the station'/
- 1 ' Vx,Vy,Vz are Cartesian velocities in m/year '/
- 1 ' TEXT = Descriptive text (CHARACTER*24) '/
- 1 ' Example: '/
- 1'-86682.104,-5394026.861,3391189.647,-0.012,-0.001,-0.001,SALT'/)
-
- read(luin,'(a1)',err=602,iostat=ios) option
- if (ios /= 0) goto 602
-
-c write (*,*) "Starting to look at options"
-
- if (option .eq. '0') then
- go to 500
- elseif (option .eq. '1') then
- vxsave = 0.d0
- vysave = 0.d0
- vzsave = 0.d0
- vnsave = 0.d0
- vesave = 0.d0
- vusave = 0.d0
- 180 call GETPNT(latd, latm, slat, LATDIR, lond, lonm, slon,
- 1 LONDIR, name24, x, y, z, ylat, ylon, eht)
-
-C Added by JS on 07/22/2015 to limit NAD83 to the US*****************************************************
-C This was reversed on 05/11/2017 *****************************************************
-
-c if (Is_inp_NAD83 .or. Is_out_NAD83) then
-c lat = ylat*rad2deg ; lon = 360.d0 - ylon*rad2deg
-c if (lon < 0.d0) lon = lon + 360.d0
-c if(.not. am_I_in_or_near_AK (lat,lon) .and.
-c & .not. am_I_in_or_near_CONUS(lat,lon) .and.
-c & .not. am_I_in_or_near_PR (lat,lon) .and.
-c & .not. am_I_in_or_near_VQ (lat,lon)) then
-c write (luout,'(10x,a,8x,a)')
-c & "NAD83 (2011) is defined only in US territories",name24
-c stop
-c endif
-c endif
-
-c if(.not. am_I_in_or_near_AK (lat,lon) .and.
-c & .not. am_I_in_or_near_AS (lat,lon) .and.
-c & .not. am_I_in_or_near_CONUS(lat,lon) .and.
-c & .not. am_I_in_or_near_CQ (lat,lon) .and.
-c & .not. am_I_in_or_near_Guam (lat,lon) .and.
-c & .not. am_I_in_or_near_HI (lat,lon) .and.
-c & .not. am_I_in_or_near_PR (lat,lon) .and.
-c & .not. am_I_in_or_near_VQ (lat,lon) .and.
-c & .not. am_I_in_or_near_KW (lat,lon)) then
-c write (luout,'(10x,a,8x,a)')
-c & "FYI, NAD83 (2011) is defined only in US territories",name24
-c stop
-c endif
-
-c if (Is_inp_NAD83MAR .or. Is_out_NAD83MAR) then
-c lat = ylat*rad2deg ; lon = 360.d0 - ylon*rad2deg
-c if (lon < 0.d0) lon = lon + 360.d0
-c if(.not. am_I_in_or_near_GUAM (lat,lon) .and.
-c & .not. am_I_in_or_near_CQ (lat,lon)) then
-c write (luout,'(10x,a,8x,a)')
-c & "NAD83 (2011) is defined only in US territories",name24
-c stop
-c endif
-c endif
-
-C Until here on 07/22/2015 to limit NAD83 to the US******************************************************
-
-C Added by JS on 09/10/2014
-
- if (Is_inp_NAD83 .or. Is_out_NAD83) then
- call TOIT94(x, y, z, x1, y1, z1, date1, iopt1)
- call FRIT94(x1, y1, z1, x2, y2, z2, date1, iopt2)
- else
- call TOIT94_IERS(x, y, z, x1, y1, z1, date1, iopt1)
- call FRIT94_IERS(x1, y1, z1, x2, y2, z2, date1, iopt2)
- endif
- if (min1 .ne. min2) then !i.e., if the input and output dates are different
- if(.not.FRMXYZ(x2,y2,z2,ylat1,elon1,eht1)) STOP 666
- ylon1 = -elon1
- if(ylon1 .lt. 0.d0) ylon1 = ylon1 + twopi
-c write (*,*) ylon1*180.d0/pi,ylat1*180.d0/pi,eht1
- call GETVLY(ylat1,elon1,vx,vy,vz,vn,ve,vu,vopt,210)
-c write (*,*) vx,vy,vz,vn,ve,vu
- if (vopt .eq. '0') then
- call PREDV(ylat1,ylon1,eht1,date1,iopt1,jregn,vn,ve,vu)
-c write (*,*) jregn,vn,ve,vu
- if (jregn .eq. 0) then
- write(luout, 200)
- 200 format(/' ****************************************'/
- 1 ' These coordinates can not be transformed to a different'/
- 1 ' date because the point is outside of the modeled region.'/)
- go to 220
- else
- call TOVXYZ( ylat1, elon1, vn, ve, vu, vx, vy, vz)
-c write (*,*) vx,vy,vz,vn,ve,vu
- endif
- endif
- vxsave = vx
- vysave = vy
- vzsave = vz
- vnsave = vn
- vesave = ve
- vusave = vu
- if (Is_inp_NAD83 .or. Is_out_NAD83) then
- call VTRANF( x, y, z, vx, vy, vz, iopt1, iopt2)
- else
- call VTRANF_IERS( x, y, z, vx, vy, vz, iopt1, iopt2)
- endif
- call TOVNEU( ylat1, elon1, vx, vy, vz, vn, ve, vu)
-c write (*,*) "Passed TOVNEU",vn, ve, vu
- call NEWCOR( ylat1, ylon1, eht1, min1, min2,
- 1 ylatt, ylont, ehtnew, dn, de, du, vn, ve, vu)
-c write (*,*) "Passed NEWCOR",vn, ve, vu
- call TOXYZ(ylatt,-ylont, ehtnew, xt, yt, zt)
-c write (*,*) "Passed TOXYZ"
- else
- xt = x2
- yt = y2
- zt = z2
- if(.not.(FRMXYZ(xt,yt,zt,ylatt,elont,ehtnew))) STOP 666
- ylont = -elont
- if(ylont .lt. 0.0d0) ylont = ylont + twopi
-c write (*,*) ylont*180.d0/pi,ylatt*180.d0/pi,ehtnew
- endif
-
- call PRNTTP(x, y, z, xt, yt, zt, ylat, ylatt,
- 1 ylon, ylont, eht, ehtnew, name24, 1,
- 2 vxsave, vysave, vzsave, vnsave, vesave, vusave)
-
- 220 write(luout,*) ' Transform more positions? (y/n) '
- read(luin,'(a1)',err=601,iostat=ios) answer
- if (ios /= 0) goto 601
- if(answer .eq. 'Y' .or. answer .eq. 'y') go to 180
- close (i2, status = 'keep')
- elseif (option .eq. '2') then !Blue book input and output
- vxsave = 0.d0
- vysave = 0.d0
- vzsave = 0.d0
- vnsave = 0.d0
- vesave = 0.d0
- vusave = 0.d0
- write(luout, 300)
- 300 format(/
- 1 ' Enter name of the blue-book file: ')
- read(luin, '(a)',err=603,iostat=ios) namebb
- if (ios /= 0) goto 603
- open (i1, file = namebb, status = 'old')
-
-*** Obtaining the ellipsoid heights from the blue book file
-
- do i = 1, nbbdim
- ht(i) = 0.d0
- enddo
-
- 302 read (i1, '(a80)', end = 309,err=604,iostat=ios) card
- if (ios /= 0) goto 604
-
- if (card(7:10) .eq. '*80*') then
-c read (card, 303) isn, eht
-c 303 format (bz, 10x, i4, t70, f6.2)
- read (card, 303,err=605,iostat=ios) PID,isn,eht
- if (ios /= 0) goto 605
- 303 format (a6,4x,i4, t70, f6.2)
- if (ht(isn) .eq. 0.d0) ht(isn) = eht
- PIDs(isn) = PID
-
- elseif (card(7:10) .eq. '*86*') then
- if (card(46:52) .ne. ' ') then
- read (card, 304,err=606,iostat=ios) isn, eht
- if (ios /= 0) goto 606
- 304 format (bz, 10x, i4, t46, f7.3)
- ht(isn) = eht
- else
- read (card, 305,err=606,iostat=ios) isn, oht, ght
- if (ios /= 0) goto 606
- 305 format (bz, 10x, i4, t17, f7.3, t36, f7.3)
- ht(isn) = oht + ght
- endif
- endif
- go to 302
- 309 rewind i1
-c open (i6,file='transformed_'//namebb)
-
-C write some comments in the transformed files
-
- call extract_name (namebb,iii)
-c write (I2,1309) namebb(1:iii)
-c write (I2,1309) trim(namebb)
- 1309 format (/'The file, transformed_',a,
- & ', contains the transformed input file.'/)
-
- write (i2,1310) HTDP_version
- 1310 format (' ***CAUTION: This file was processed using HTDP',
- & ' version ',a10, '***')
- write (i2,1311) frame2
- 1311 format (' ***CAUTION: Coordinates in this file are in ',
- & a24, '***')
- WRITE (i2, 1312) MONTH2, IDAY2, IYEAR2, DATE2
- 1312 FORMAT(' ***CAUTION: Coordinates in this file have been ',
- * 'updated to ',I2,'-',I2.2,'-',I4, '=(',F8.3,') ***'/)
-
-*** Reread blue book file to get latitudes and longitudes
-*** and to perform transformations
-*** and to write transformed lat and lon to the *80* records of the output bfile
-*** and to write transformed ellip. h to the *86* records of the output bfile
-
- 310 read(i1, '(a80)', end = 390,err=604,iostat=ios) card
- if (ios /= 0) goto 604
- if (card(7:10) .eq. '*80*') then
-c write (*,'(a80)' ) card
- read(card,320,err=605,iostat=ios) isn,name24(1:30),latd,
- & latm,slat,jn,lond, lonm, slon, jw
-c write (*,321) latd, latm, slat, jn, lond, lonm, slon, jw
-
- if (ios /= 0) goto 605
- 320 format(10x, i4, a30, i2, i2, f7.5, a1,
- & i3, i2, f7.5, a1)
- 321 format(i2, i2, f7.5, a1,3x, i3, i2, f7.5, a1)
- ylat = (dble((latd*60 + latm)*60) + slat) / rhosec
- ylon = (dble((lond*60 + lonm)*60) + slon) / rhosec
- if (jn .eq. 'S') ylat = -ylat
- if (jw .eq. 'E') ylon = -ylon
- eht = ht(isn)
- call TOXYZ(ylat, -ylon, eht, x, y, z)
-
-C Modified in 09/15/2014 by JS to accommodate the IERS 96-97 trans. par.
- if (Is_inp_NAD83 .or. Is_out_NAD83) then
- call TOIT94(x, y, z, x1, y1, z1, date1, iopt1)
- call FRIT94(x1, y1, z1, x2, y2, z2, date1, iopt2)
- else
- call TOIT94_IERS(x, y, z, x1, y1, z1, date1, iopt1)
- call FRIT94_IERS(x1, y1, z1, x2, y2, z2, date1, iopt2)
- endif
-C End changes
-
- if (min1 .ne. min2) then
- if(.not.FRMXYZ(x2,y2,z2,ylat1,elon1,eht1)) STOP 666
- ylon1 = -elon1
- if (ylon1 .lt. 0.0d0) ylon1 = ylon1 + twopi
- call PREDV(ylat1, ylon1, eht1, date1, iopt1,
- 1 jregn, vn, ve, vu)
- if (jregn .eq. 0) then
- write(i2, 330) name24
- 330 format (/ 1x,a,
- 1 ' is outside of the modeled region.'/)
- go to 310
- else
- call TOVXYZ(ylat1,elon1,vn,ve,vu,vx,vy,vz)
- vxsave = vx
- vysave = vy
- vzsave = vz
- vnsave = vn
- vesave = ve
- vusave = vu
-
-C Modified on 09/15/2014 by JS to accomodate the IERS trans. par.
- if (Is_inp_NAD83 .or. Is_out_NAD83) then
- call VTRANF(x,y,z,vx,vy,vz,iopt1,iopt2)
- else
- call VTRANF_IERS( x, y, z, vx, vy, vz, iopt1, iopt2)
- endif
-C End changes
- call TOVNEU(ylat1,elon1,vx,vy,vz,vn,ve,vu)
- call NEWCOR(ylat1,ylon1,eht1,min1,min2,
- 1 ylatt,ylont,ehtnew,dn,de,dui,vn,ve,vu)
- call TOXYZ(ylatt,-ylont,ehtnew,xt,yt,zt)
- endif
- else
- xt = x2
- yt = y2
- zt = z2
- if(.not.FRMXYZ(xt,yt,zt,ylatt,elont,ehtnew))STOP 666
- ylont = -elont
- if (ylont .lt. 0.0d0) ylont = ylont + twopi
- endif
-c call PRNTTP(x,y,z, xt,yt, zt, ylat, ylatt,
-c 1 ylon, ylont, eht, ehtnew, name24, 0,
-c 1 vxsave, vysave, vzsave, vnsave, vesave, vusave)
-
-C Now write output *80* records to the output bfile
-
- call TODMSS (ylatt,latdeg,latmin,seclat,isign)
- latsec = nint(100000*seclat)
- latdir = 'N'
- if (isign .eq. -1) latdir = 'S'
- call TODMSS (ylont,londeg,lonmin,seclon,isign)
- lonsec = nint(100000*seclon)
- londir = 'W'
- if (isign .eq. -1) londir = 'E'
- write (card(45:46),'(i2)') latdeg
- write (card(47:48),'(i2)') latmin
- write (card(49:55),'(i7)') latsec
- do i=45,55
- if (card(i:i) == ' ') card(i:i) = '0'
- enddo
- write (card(56:56),'(a1)') latdir
-
- write (card(57:59),'(i3)') londeg
- write (card(60:61),'(i2)') lonmin
- write (card(62:68),'(i7)') lonsec
- do i=57,68
- if (card(i:i) == ' ') card(i:i) = '0'
- enddo
- write (card(69:69),'(a1)') londir
- write (i2,'(a)') card
-c write (*,'(a)') card
-
-C Now write output *86* records
-
- elseif (card(8:9) == '86') then
-c write (*,'(a)') card
- write (card(46:52),'(i7)') nint(ehtnew*1000)
- write (i2,'(a)') card
-c write(*, '(a80)') card
- else
- write (i2,'(a)') card
- endif
- go to 310
- 390 close (i1, status = 'keep')
-c close (i6, status = 'keep')
- close (i2, status = 'keep')
-
- elseif (option .eq. '3') then
- vxsave = 0.d0
- vysave = 0.d0
- vzsave = 0.d0
- vnsave = 0.d0
- vesave = 0.d0
- vusave = 0.d0
- write (luout, 400)
- 400 format (' Enter name of input file: ')
- read (luin,'(a)',err=608,iostat=ios) nameif
- if (ios /= 0) goto 608
- open (i1, file = nameif, status = 'old')
-C open (i6,file='transformed_'//nameif)
-
-C write some comments in the transformed files
-
- call extract_name (nameif,iii)
-c write (I2,1309) nameif(1:iii)
-c write (I2,1309) trim(nameif)
- write (i2,1310) HTDP_version
- write (i2,1311) frame2
- WRITE (I2, 1312) MONTH2, IDAY2, IYEAR2, DATE2
-c const = 180.d0/PI
-
- 410 read (i1,'(a)',end=450,err=607,iostat=ios) record
- if (ios /= 0) goto 607
- call interprate_XYZ_record (record,xlat,xlon,eht,name24)
- ylat = (xlat*3600.d0) / rhosec
- ylon = (xlon*3600.d0) / rhosec
- elon = -ylon
- call TOXYZ(ylat, elon, eht, x, y, z)
-
-C Modified in 09/15/2014 by JS to accommodate the IERS 96-97 trans. par.
-
- if (Is_inp_NAD83 .or. Is_out_NAD83) then
- call TOIT94 (x,y,z,x1,y1,z1,date1,iopt1)
- call FRIT94 (x1,y1,z1,x2,y2,z2,date1,iopt2)
- else
- call TOIT94_IERS(x, y, z, x1, y1, z1, date1, iopt1)
- call FRIT94_IERS(x1, y1, z1, x2, y2, z2, date1, iopt2)
- endif
-
-C End changes
-
- if (min1 .ne. min2) then
- if(.not.FRMXYZ(x2,y2,z2,ylat1,elon1,eht1)) STOP 666
- ylon1 = -elon1
- if (ylon1 .lt. 0.d0) ylon1 = ylon1 + twopi
- call PREDV (ylat1, ylon1, eht1, date1, iopt1, jregn,
- 1 vn, ve, vu)
- if (jregn .eq. 0) then
- write(i2, 330) name24
- go to 410
- else
- call TOVXYZ(ylat1,elon1,vn,ve,vu,vx,vy,vz)
- vxsave = vx
- vysave = vy
- vzsave = vz
- vnsave = vn
- vesave = ve
- vusave = vu
-
-C Modified on 09/15/2014 by JS to accomodate the IERS trans. par.
-
- if (Is_inp_NAD83 .or. Is_out_NAD83) then
- call VTRANF(x,y,z,vx,vy,vz,iopt1,iopt2)
- else
- call VTRANF_IERS( x, y, z, vx, vy, vz, iopt1, iopt2)
- endif
-C End changes
-
- call TOVNEU(ylat1, elon1,vx,vy,vz,vn,ve,vu)
- call NEWCOR (ylat1, ylon1, eht1, min1, min2,
- 1 ylatt,ylont,ehtnew,dn,de,du,vn,ve,vu)
- call TOXYZ(ylatt,-ylont,ehtnew,xt,yt,zt)
- endif
- else
- xt = x2
- yt = y2
- zt = z2
- if(.not.FRMXYZ(xt,yt,zt,ylatt,elont,ehtnew)) STOP 666
- ylont = -elont
- if (ylont .lt. 0.d0) ylont = ylont + twopi
- endif
-c call PRNTTP(x,y,z,xt,yt,zt,ylat,ylatt,ylon,ylont,eht,ehtnew,
-c 1 name24,0,vxsave,vysave,vzsave,vnsave,vesave,vusave)
- outlat = ylatt*rad2deg
- outlon = ylont*rad2deg
- call extract_name (name24,iii)
-
-C Added by JS on 07/22/2015 to limit the use in NAD83 to the US
-c Reversed on 05/11/2017
-
-c if (Is_inp_NAD83 .or. Is_out_NAD83) then
-c lat = ylat*rad2deg ; lon = 360.d0 - ylon*rad2deg
-c if(.not. am_I_in_or_near_AK (lat,lon) .and.
-c & .not. am_I_in_or_near_AS (lat,lon) .and.
-c & .not. am_I_in_or_near_CONUS(lat,lon) .and.
-c & .not. am_I_in_or_near_CQ (lat,lon) .and.
-c & .not. am_I_in_or_near_Guam (lat,lon) .and.
-c & .not. am_I_in_or_near_HI (lat,lon) .and.
-c & .not. am_I_in_or_near_PR (lat,lon) .and.
-c & .not. am_I_in_or_near_VQ (lat,lon) .and.
-c & .not. am_I_in_or_near_KW (lat,lon)) then
-c write (i2,'(10x,a,8x,a)')
-c & "FYI, NAD83(2011) is defined only in US territories",name24
-c endif
-c endif
- write (i2,449) outlat,outlon,ehtnew,name24(1:iii)
-
-C Until here on 07/22/2015 to limit the use in NAD83 to the US
-
-c write (i6,449) outlat,outlon,ehtnew,trim(name24)
- 449 format (2f16.10,f10.3,4x,a)
- go to 410
-
- 450 close(i1, status = 'keep')
-c close(i6, status = 'keep')
- close(i2, status = 'keep')
-
- elseif (option .eq. '4') then
- vxsave = 0.d0
- vysave = 0.d0
- vzsave = 0.d0
- vnsave = 0.d0
- vesave = 0.d0
- vusave = 0.d0
- write (luout, 4001)
-4001 format (' Enter name of input file: ')
- read (luin, '(a)',err=600,iostat=ios) nameif
- if (ios /= 0) goto 600
- open (i1, file = nameif, status = 'old')
-c open (i6,file='transformed_'//nameif)
-
-C write some comments in the transformed files
-
- call extract_name (nameif,iii)
-c write (i2,1309) nameif(1:iii)
-c write (i2,1309) trim(nameif)
-c write (i6,1310) HTDP_version
-c write (i6,1311) frame2
-c WRITE (i6, 1312) MONTH2, IDAY2, IYEAR2, DATE2
-c const = 180.d0/PI
- 411 read (i1,'(a)',end=451,err=607,iostat=ios) record
- if (ios /= 0) goto 607
- call interprate_XYZ_record (record,x,y,z,name24)
- if(.not.FRMXYZ(x,y,z,ylat,elon,eht)) STOP 666
- ylon = -elon
- if (ylon .lt. 0.d0) ylon = ylon + twopi
-
-C Modified in 09/15/2014 by JS to accommodate the IERS 96-97 trans. par.
-
- if (Is_inp_NAD83 .or. Is_out_NAD83) then
- call TOIT94 (x,y,z,x1,y1,z1,date1,iopt1)
- call FRIT94 (x1,y1,z1,x2,y2,z2,date1,iopt2)
- else
- call TOIT94_IERS(x, y, z, x1, y1, z1, date1, iopt1)
- call FRIT94_IERS(x1, y1, z1, x2, y2, z2, date1, iopt2)
- endif
-
-C End changes
-
- if (min1 .ne. min2) then
- if(.not.FRMXYZ(x2,y2,z2,ylat1,elon1,eht1)) STOP 666
- ylon1 = -elon1
- if (ylon1 .lt. 0.d0) ylon1 = ylon1 + twopi
- call PREDV (ylat1,ylon1,eht1,date1,iopt1,jregn,vn,ve,vu)
- if (jregn .eq. 0) then
- write(i2, 330) name24
- go to 411
- else
- call TOVXYZ(ylat1,elon1,vn,ve,vu,vx,vy,vz)
- vxsave = vx
- vysave = vy
- vzsave = vz
- vnsave = vn
- vesave = ve
- vusave = vu
- write (*,*) vn,ve,vu
- write (*,*) vx,vy,vz
-
-C Modified on 09/15/2014 by JS to accomodate the IERS trans. par.
-
- if (Is_inp_NAD83 .or. Is_out_NAD83) then
- call VTRANF(x,y,z,vx,vy,vz,iopt1,iopt2)
- else
- call VTRANF_IERS( x, y, z, vx, vy, vz, iopt1, iopt2)
- endif
-C End changes
-
- call TOVNEU(ylat1, elon1,vx,vy,vz,vn,ve,vu)
- write (*,*) vn,ve,vu
- call NEWCOR (ylat1, ylon1, eht1, min1, min2,
- 1 ylatt,ylont,ehtnew,dn,de,du,vn,ve,vu)
- call TOXYZ(ylatt,-ylont,ehtnew,xt,yt,zt)
- endif
- else
- xt = x2
- yt = y2
- zt = z2
- if(.not.FRMXYZ(xt,yt,zt,ylatt,elont,ehtnew)) STOP 666
- ylont = -elont
- if (ylont .lt. 0.d0) ylont = ylont + twopi
- endif
-c call PRNTTP(x,y,z,xt,yt,zt,ylat,ylatt,ylon,ylont,eht,ehtnew,
-c 1 name24,0,vxsave,vysave,vzsave,vnsave,vesave,vusave)
- call extract_name (name24,iii)
-
-C Added by JS on 07/22/2015 to limit the use in NAD83 to the US
-
-c if (Is_inp_NAD83 .or. Is_out_NAD83) then
-c lat = ylatt*rad2deg ; lon = 360.d0 - ylont*rad2deg
-c if(.not. am_I_in_or_near_AK (lat,lon) .and.
-c & .not. am_I_in_or_near_AS (lat,lon) .and.
-c & .not. am_I_in_or_near_CONUS(lat,lon) .and.
-c & .not. am_I_in_or_near_CQ (lat,lon) .and.
-c & .not. am_I_in_or_near_Guam (lat,lon) .and.
-c & .not. am_I_in_or_near_HI (lat,lon) .and.
-c & .not. am_I_in_or_near_PR (lat,lon) .and.
-c & .not. am_I_in_or_near_VQ (lat,lon) .and.
-c & .not. am_I_in_or_near_KW (lat,lon)) then
-c write (i2,'(10x,a,8x,a)')
-c & "FYI, NAD83(2011) is defined only in US territories",name24
-c write (i2,1449) xt,yt,zt,name24(1:iii)
-c endif
-c else
- write (i2,1449) xt,yt,zt,name24(1:iii)
-c endif
-
-C Until here on 07/22/2015 to limit the use in NAD83 to the US
-
-c write (i6,1449) xt,yt,zt,trim(name24)
- 1449 format (3f20.3,4x,a)
- go to 411
-
- 451 close(i1, status = 'keep')
- close(i2, status = 'keep')
-
- elseif (option .eq. '5') then
- vxsave = 0.d0
- vysave = 0.d0
- vzsave = 0.d0
- vnsave = 0.d0
- vesave = 0.d0
- vusave = 0.d0
- write (luout, 5001)
-5001 format (' Enter name of input file: ')
- read (luin, '(a)',err=600,iostat=ios) nameif
- if (ios /= 0) goto 600
- open (i1, file = nameif, status = 'old')
-c open (i6,file='transformed_'//nameif)
-
-C write some comments in the transformed files
-
- call extract_name (nameif,iii)
-c write (i2,1309) nameif(1:iii)
-c write (i2,1309) trim(nameif)
-c write (i6,1310) HTDP_version
-c write (i6,1311) frame2
-c WRITE (i6, 1312) MONTH2, IDAY2, IYEAR2, DATE2
-c const = 180.d0/PI
- 511 read (i1,'(a)',end=551,err=607,iostat=ios) record
- if (ios /= 0) goto 607
- call interprate_XYZVxVyVz_record (record,x,y,z,Vx,Vy,Vz,name24)
-c write (*,*) X,Y,Z
-c write (*,*) Vx,Vy,Vz
- if(.not.FRMXYZ(x,y,z,ylat,elon,eht)) STOP 666
- ylon = -elon
- if (ylon .lt. 0.d0) ylon = ylon + twopi
-
-C Modified in 09/15/2014 by JS to accommodate the IERS 96-97 trans. par.
-
- if (Is_inp_NAD83 .or. Is_out_NAD83) then
- call TOIT94 (x,y,z,x1,y1,z1,date1,iopt1)
- call FRIT94 (x1,y1,z1,x2,y2,z2,date1,iopt2)
- else
- call TOIT94_IERS(x, y, z, x1, y1, z1, date1, iopt1)
- call FRIT94_IERS(x1, y1, z1, x2, y2, z2, date1, iopt2)
- endif
-
-C End changes on 09/15/2014
-
- if (min1 .ne. min2) then
- if(.not.FRMXYZ(x2,y2,z2,ylat1,elon1,eht1)) STOP 666
- ylon1 = -elon1
- if (ylon1 .lt. 0.d0) ylon1 = ylon1 + twopi
-c call PREDV (ylat1,ylon1,eht1,date1,iopt1,jregn,vn,ve,vu)
-c if (jregn .eq. 0) then
-c write(i2, 330) name24
-c go to 411
-c else
-c call TOVXYZ(ylat1,elon1,vn,ve,vu,vx,vy,vz)
-
- call TOVNEU(ylat1,elon1,vx,vy,vz,vn,ve,vu)
- vxsave = vx
- vysave = vy
- vzsave = vz
- vnsave = vn
- vesave = ve
- vusave = vu
-c write (*,*) vn,ve,vu
-
-C Modified on 09/15/2014 by JS to accomodate the IERS trans. par.
-
- if (Is_inp_NAD83 .or. Is_out_NAD83) then
- call VTRANF(x,y,z,vx,vy,vz,iopt1,iopt2)
- else
- call VTRANF_IERS( x, y, z, vx, vy, vz, iopt1, iopt2)
- endif
-C End changes
-
- call TOVNEU(ylat1, elon1,vx,vy,vz,vn,ve,vu)
- call NEWCOR (ylat1, ylon1, eht1, min1, min2,
- 1 ylatt,ylont,ehtnew,dn,de,du,vn,ve,vu)
- call TOXYZ(ylatt,-ylont,ehtnew,xt,yt,zt)
-c endif
- else
- xt = x2
- yt = y2
- zt = z2
- if(.not.FRMXYZ(xt,yt,zt,ylatt,elont,ehtnew)) STOP 666
- ylont = -elont
- if (ylont .lt. 0.d0) ylont = ylont + twopi
- endif
-c call PRNTTP(x,y,z,xt,yt,zt,ylat,ylatt,ylon,ylont,eht,ehtnew,
-c 1 name24,0,vxsave,vysave,vzsave,vnsave,vesave,vusave)
- call extract_name (name24,iii)
-
-C Added by JS on 07/22/2015 to limit the use in NAD83 to the US
-
-c if (Is_inp_NAD83 .or. Is_out_NAD83) then
-c lat = ylatt*rad2deg ; lon = 360.d0 - ylont*rad2deg
-c if(.not. am_I_in_or_near_AK (lat,lon) .and.
-c & .not. am_I_in_or_near_AS (lat,lon) .and.
-c & .not. am_I_in_or_near_CONUS(lat,lon) .and.
-c & .not. am_I_in_or_near_CQ (lat,lon) .and.
-c & .not. am_I_in_or_near_Guam (lat,lon) .and.
-c & .not. am_I_in_or_near_HI (lat,lon) .and.
-c & .not. am_I_in_or_near_PR (lat,lon) .and.
-c & .not. am_I_in_or_near_VQ (lat,lon) .and.
-c & .not. am_I_in_or_near_KW (lat,lon)) then
-c write (i2,'(10x,a,8x,a)')
-c & "FYI, NAD83(2011) is defined only in US territories",name24
-c write (i2,1449) xt,yt,zt,name24(1:iii)
-c endif
-c else
- write (i2,1449) xt,yt,zt,name24(1:iii)
-c endif
-
-C Until here on 07/22/2015 to limit the use in NAD83 to the US
-
-c write (i6,1449) xt,yt,zt,trim(name24)
- go to 511
-
- 551 close(i1, status = 'keep')
- close(i2, status = 'keep')
- else
- write(luout,*) ' Improper selection -- try again. '
- go to 160
- endif
-
- 500 continue
-c close(i2, status = 'keep')
- return
-
- 600 write (*,'(/)')
- write (*,*) "Wrong output file name in TRFPOS: ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 601 write (*,'(/)')
- write (*,*) "Wrong answer in TRFPOS: ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 602 write (*,'(/)')
- write (*,*) "Wrong option in TRFPOS: ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 603 write (*,'(/)')
- write (*,*) "Wrong bbname in TRFPOS: ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 604 write (*,'(/)')
- write (*,*) "Wrong card in TRFPOS: ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 605 write (*,'(/)')
- write (*,*) "Failed to read 80 record in TRFPOS: ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 606 write (*,'(/)')
- write (*,*) "Failed to read 86 record in TRFPOS: ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 607 write (*,*) "Failed reading input file in TRFPOS: ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 608 write (*,'(/)')
- write (*,*) "Wrong input file name in TRFPOS: ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- end
-C*******************************************8*****************************************************
- subroutine PRNTTP(x, y, z, x1, y1, z1, ylat,
- 1 ylatt, ylon, ylont, eht, ehtnew, name24, iprint,
- 2 vx, vy, vz, vn, ve, vu )
-
-** Print updated and/or transformed parameters
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
- CHARACTER NAME24*24
- CHARACTER LATDIR*1, LONDIR*1, LATDR*1, LONDR*1
-
- CALL TODMSS(YLATT,LATDN,LATMN,SLATN,ISIGN)
- LATDIR = 'N'
- if (isign .eq. -1) LATDIR = 'S'
- CALL TODMSS(YLONT,LONDN,LONMN,SLONN,ISIGN)
- LONDIR = 'W'
- if (isign .eq. -1) LONDIR = 'E'
-
- if (iprint .eq. 1) then
- WRITE(LUOUT,1065)LATDN,LATMN,SLATN,LATDIR,LONDN,LONMN,
- 1 SLONN,LONDIR, EHTNEW, X1,Y1,Z1
- 1065 FORMAT(' ****************************************'/
- 1 ' New latitude = ',I3,1X,I2,1X,F8.5,1X,A1 /
- 2 ' New longitude = ',I3,1x,I2,1X,F8.5,1X,A1 /
- 2 ' New Ellip. Ht. = ', F12.3 ,' meters' /
- 3 ' New X = ',F12.3 ,' meters' /
- 4 ' New Y = ',F12.3 ,' meters' /
- 5 ' New Z = ',F12.3 ,' meters' /
- 3 ' ****************************************'/)
- endif
-
- call TODMSS(ylat,latd,latm,slat,isign)
- latdr = 'N'
- if(isign .eq. -1) latdr = 'S'
- call TODMSS(ylon, lond,lonm,slon,isign)
- londr = 'W'
- if(isign .eq. -1) londr = 'E'
- WRITE(I2,1070)NAME24,
- 1 LATD,LATM,SLAT,latdr,LATDN,LATMN,SLATN,latdir,vn,
- 1 LOND,LONM,SLON,londr,LONDN,LONMN,SLONN,londir,ve,
- 1 EHT, EHTNEW, vu, X, X1, vx,
- 1 Y, Y1, vy, Z, Z1, vz
- 1070 FORMAT(1X,A24,/
- 1 2X, 'LATITUDE ',2(2X,I3,1X,I2.2,1X,F8.5,1X,A1,2X),
- 1 2X, f8.2, ' mm/yr north' /
- 1 2X, 'LONGITUDE ',2(2X,I3,1X,I2.2,1X,F8.5,1X,A1,2X),
- 1 2X, f8.2, ' mm/yr east' /
- 1 2X, 'ELLIP. HT.',2(6X,F14.3),' m ',
- 1 f8.2, ' mm/yr up' /
- 1 2X, 'X ',2(6X,F14.3),' m ', f8.2, ' mm/yr' /
- 1 2X, 'Y ',2(6X,F14.3),' m ', f8.2, ' mm/yr' /
- 1 2X, 'Z ',2(6X,F14.3),' m ', f8.2, ' mm/yr'/ )
- RETURN
- END
-
-**********************************************************
- subroutine SETTP
-
-*** Specify transformation parameters from ITRF94
-*** to other reference frames
-**************************************
-C Important note:
-C The parameters in common block tranpa are computed using the IGS values of ITRF96==>ITRF97
-C The parameters in common block tranpa1 are computed using the IERS values of ITRF96==>ITRF97
-C The latter parameters were added to HTDP in 09/2014. They will be used to transform between
-C ITRF systems. They will not be used if the transformation involves NAD83 or WGS84 (transit).
-C They will be used for the Pacific branches of NAD83.
-
-
- implicit double precision (a-h, o-z)
- implicit integer*4 (i-n)
- parameter (numref = 16)
-
- common /const/ a, f, e2, eps, af, pi, twopi, rhosec
- common /tranpa/ tx(numref), ty(numref), tz(numref),
- & dtx(numref), dty(numref), dtz(numref),
- & rx(numref), ry(numref), rz(numref),
- & drx(numref), dry(numref), drz(numref),
- & scale(numref), dscale(numref), refepc(numref)
- common /tranpa1/ tx1(numref), ty1(numref), tz1(numref),
- & dtx1(numref), dty1(numref), dtz1(numref),
- & rx1(numref), ry1(numref), rz1(numref),
- & drx1(numref), dry1(numref), drz1(numref),
- & scale1(numref), dscale1(numref), refepc1(numref)
-
-C Parameters computed with the IGS values of ITRF96==>ITRF97
-
-*** From ITRF94 to NAD 83
- tx(1) = 0.9910d0
- ty(1) = -1.9072d0
- tz(1) = -.5129d0
- dtx(1) = 0.d0
- dty(1) = 0.d0
- dtz(1) = 0.d0
- rx(1) = 1.25033d-7
- ry(1) = 0.46785d-7
- rz(1) = 0.56529d-7
- drx(1) = 0.00258d-7
- dry(1) = -.03599d-7
- drz(1) = -.00153d-7
- scale(1) = 0.d0
- dscale(1) = 0.0d0
- refepc(1) = 1997.0d0
-
-*** From ITRF94 to ITRF88
- tx(2) = 0.018d0
- ty(2) = 0.000d0
- tz(2) = -.092d0
- dtx(2) = 0.0d0
- dty(2) = 0.0d0
- dtz(2) = 0.0d0
- rx(2) = -.0001d0 / rhosec
- ry(2) = 0.0d0
- rz(2) = 0.0d0
- drx(2) = 0.0d0
- dry(2) = 0.0d0
- drz(2) = 0.0d0
- scale(2) = 0.74d-8
- dscale(2) = 0.0d0
- refepc(2) = 1988.0d0
-
-*** From ITRF94 to ITRF89
- tx(3) = 0.023d0
- ty(3) = 0.036d0
- tz(3) = -.068d0
- dtx(3) = 0.0d0
- dty(3) = 0.0d0
- dtz(3) = 0.0d0
- rx(3) = 0.0d0
- ry(3) = 0.0d0
- rz(3) = 0.0d0
- drx(3) = 0.0d0
- dry(3) = 0.0d0
- drz(3) = 0.0d0
- scale(3) = 0.43d-8
- dscale(3) = 0.0d0
- refepc(3) = 1988.0d0
-
-*** From ITRF94 to ITRF90
- tx(4) = 0.018d0
- ty(4) = 0.012d0
- tz(4) = -.030d0
- dtx(4) = 0.0d0
- dty(4) = 0.0d0
- dtz(4) = 0.0d0
- rx(4) = 0.0d0
- ry(4) = 0.0d0
- rz(4) = 0.0d0
- drx(4) = 0.0d0
- dry(4) = 0.0d0
- drz(4) = 0.0d0
- scale(4) = 0.09d-8
- dscale(4) = 0.0d0
- refepc(4) = 1988.0d0
-
-*** From ITRF94 to ITRF91
- tx(5) = 0.020d0
- ty(5) = 0.016d0
- tz(5) = -.014d0
- dtx(5) = 0.0d0
- dty(5) = 0.0d0
- dtz(5) = 0.0d0
- rx(5) = 0.0d0
- ry(5) = 0.0d0
- rz(5) = 0.0d0
- drx(5) = 0.0d0
- dry(5) = 0.0d0
- drz(5) = 0.0d0
- scale(5) = 0.06d-8
- dscale(5) = 0.0d0
- refepc(5) = 1988.0d0
-
-*** From ITRF94 to ITRF92
- tx(6) = 0.008d0
- ty(6) = 0.002d0
- tz(6) = -.008d0
- dtx(6) = 0.0d0
- dty(6) = 0.0d0
- dtz(6) = 0.0d0
- rx(6) = 0.0d0
- ry(6) = 0.0d0
- rz(6) = 0.0d0
- drx(6) = 0.0d0
- dry(6) = 0.0d0
- drz(6) = 0.0d0
- scale(6) = -.08d-8
- dscale(6) = 0.0d0
- refepc(6) = 1988.0d0
-
-*** From ITRF94 to ITRF93
- tx(7) = 0.006d0
- ty(7) = -.005d0
- tz(7) = -.015d0
- dtx(7) = -.0029d0
- dty(7) = 0.0004d0
- dtz(7) = 0.0008d0
- rx(7) = 0.00039d0 / rhosec
- ry(7) = -.00080d0 / rhosec
- rz(7) = 0.00096d0 / rhosec
- drx(7) = .00011d0 / rhosec
- dry(7) = .00019d0 / rhosec
- drz(7) =-.00005d0 / rhosec
- scale(7) = 0.04d-8
- dscale(7) = 0.0d0
- refepc(7) = 1988.0d0
-
-*** From ITRF94 to ITRF96
- tx(8) = 0.d0
- ty(8) = 0.d0
- tz(8) = 0.d0
- dtx(8) = 0.d0
- dty(8) = 0.d0
- dtz(8) = 0.d0
- rx(8) = 0.d0
- ry(8) = 0.d0
- rz(8) = 0.d0
- drx(8) = 0.d0
- dry(8) = 0.d0
- drz(8) = 0.d0
- scale(8) = 0.d0
- dscale(8) = 0.0d0
- refepc(8) = 1996.0d0
-
-*** From ITRF94 to ITRF97 (based on IGS adopted values)
-*** According to IERS: ITRF97 = ITRF96 = ITRF94
- tx(9) = 0.00207d0
- ty(9) = 0.00021d0
- tz(9) = -0.00995d0
- dtx(9) = -0.00069d0
- dty(9) = 0.00010d0
- dtz(9) = -0.00186d0
- rx(9) = -0.00012467d0 / rhosec
- ry(9) = 0.00022355d0 / rhosec
- rz(9) = 0.00006065d0 / rhosec
- drx(9) = -0.00001347d0 / rhosec
- dry(9) = 0.00001514d0 / rhosec
- drz(9) = -0.00000027d0 / rhosec
- scale(9) = 0.93496d-9
- dscale(9) = 0.19201d-9
- refepc(9) = 1997.0d0
-
-*** From ITRF94 to WGS 72 (composition of ITRF94 -> NAD_83 -> WGS_72)
- tx(10) = 0.9910d0
- ty(10) = -1.9072d0
- tz(10) = -.5129d0 - 4.5d0
- dtx(10) = 0.d0
- dty(10) = 0.d0
- dtz(10) = 0.d0
- rx(10) = 1.25033d-7
- ry(10) = 0.46785d-7
- rz(10) = 0.56529d-7 + 26.85868d-7
- drx(10) = 0.00258d-7
- dry(10) = -.03599d-7
- drz(10) = -.00153d-7
- scale(10) = 0.d0 - 0.2263d-6
- dscale(10) = 0.0d0
- refepc(10) = 1997.0d0
-
-*** From ITRF94 to ITRF00
-*** assumes that ITRF94 = ITRF96 and
-*** uses IGS values for ITRF96 -> ITRF97
-*** and IERS values for ITRF97 -> ITRF00
- tx(11) = -.00463d0
- ty(11) = -.00589d0
- tz(11) = +.00855d0
- dtx(11) = -0.00069d0
- dty(11) = 0.00070d0
- dtz(11) = -0.00046d0
- rx(11) = -.00012467d0 / rhosec
- ry(11) = 0.00022355d0 / rhosec
- rz(11) = 0.00006065d0 / rhosec
- drx(11) = -0.00001347d0 / rhosec
- dry(11) = 0.00001514d0 / rhosec
- drz(11) = 0.00001973d0 / rhosec
- scale(11) = -0.61504d-9
- dscale(11) = 0.18201d-9
- refepc(11) = 1997.0d0
-
-*** From ITRF94 to PACP00
-*** use PA/ITRF00 rotation rates from Beavan et al., (2002)
- tx(12) = 0.9056d0
- ty(12) = -2.0200d0
- tz(12) = -0.5516d0
- dtx(12) = -.00069d0
- dty(12) = 0.00070d0
- dtz(12) = -0.00046d0
- rx(12) = 0.027616d0 / rhosec
- ry(12) = 0.013692d0 / rhosec
- rz(12) = 0.002773d0 / rhosec
- drx(12) = -.000397d0 / rhosec
- dry(12) = 0.001022d0 / rhosec
- drz(12) = -.002166d0 / rhosec
- scale(12) = -0.61504d-9
- dscale(12) = 0.18201d-9
- refepc(12) = 1997.0d0
-
-*** From ITRF94 to MARP00
-*** Use velocity of GUAM
- tx(13) = 0.9056d0
- ty(13) = -2.0200d0
- tz(13) = -0.5516d0
- dtx(13) = -0.00069d0
- dty(13) = 0.00070d0
- dtz(13) = -0.00046d0
- rx(13) = .028847d0 / rhosec
- ry(13) = .010644d0 / rhosec
- rz(13) = 0.008989d0 / rhosec
- drx(13) = -0.000033d0 / rhosec
- dry(13) = 0.000120d0 / rhosec
- drz(13) = -0.000327d0 / rhosec
- scale(13) = -0.61504d-9
- dscale(13) = 0.18201d-9
- refepc(13) = 1997.00d0
-
-*** From ITRF94 to ITRF2005
-*** assumes that ITRF94 = ITRF96
-*** uses IGS values for ITRF96 -> ITRF97
-*** uses IERS values for ITRF97 -> ITRF2000
-*** uses IERS values for ITRF2000 -> ITRF2005
- tx(14) = -0.00533d0
- ty(14) = -0.00479d0
- tz(14) = 0.00895d0
- dtx(14) = -0.00049d0
- dty(14) = 0.00060d0
- dtz(14) = 0.00134d0
- rx(14) = -.00012467d0 / rhosec
- ry(14) = 0.00022355d0 / rhosec
- rz(14) = 0.00006065d0 / rhosec
- drx(14) = -0.00001347d0 / rhosec
- dry(14) = 0.00001514d0 / rhosec
- drz(14) = 0.00001973d0 / rhosec
- scale(14) = -0.77504d-9
- dscale(14) = 0.10201d-9
- refepc(14) = 1997.0d0
-
-*** From ITRF94 to ITRF2008 (also IGS08 and IGB08)
-*** assumes that ITRF94 = ITRF96
-*** uses IGS values for ITRF96 -> ITRF97
-*** uses IERS values for ITRF97 -> ITRF2000
-*** uses IERS values for ITRF2000-> ITRF2005
-*** uses IERS values for ITRF2005 -> ITRF2008 (and IGS08 and IGB08)
-
- tx(15) = -0.00243d0
- ty(15) = -0.00389d0
- tz(15) = 0.01365d0
- dtx(15) = -0.00079d0
- dty(15) = 0.00060d0
- dtz(15) = 0.00134d0
- rx(15) = -0.00012467d0 / rhosec
- ry(15) = 0.00022355d0 / rhosec
- rz(15) = 0.00006065d0 / rhosec
- drx(15) = -0.00001347d0 / rhosec
- dry(15) = 0.00001514d0 / rhosec
- drz(15) = 0.00001973d0 / rhosec
- scale(15) = -1.71504d-9
- dscale(15) = 0.10201d-9
- refepc(15) = 1997.0d0
-
-*** From ITRF94 to ITRF2014
-*** assumes that ITRF94 = ITRF96
-*** uses IGS values for ITRF96 -> ITRF97
-*** uses IERS values for ITRF97 -> ITRF2000
-*** uses IERS values for ITRF2000-> ITRF2005
-*** uses IERS values for ITRF2005 -> ITRF2008 (and IGS08 and IGB08)
-*** uses IERS values for ITRF2008 -> ITRF2014
-
-c tx(16) = -0.00403d0 !Differs from ITRF2008
- tx(16) = -0.01430d0
-c ty(16) = -0.00579d0 !Differs from ITRF2008
- ty(16) = 0.00201d0
-c tz(16) = 0.01125d0 !Differs from ITRF2008
- tz(16) = 0.02867d0
-
- dtx(16) = -0.00079d0 !Like ITRF2008
- dty(16) = 0.00060d0 !Like ITRF2008
- dtz(16) = 0.00144d0 !Differs from ITRF2008
-
-c rx(16) = -0.00012467d0 / rhosec !Like ITRF2008
- rx(16) = -0.00029978d0 / rhosec
-c ry(16) = 0.00022355d0 / rhosec !Like ITRF2008
- ry(16) = 0.00042037d0 / rhosec
-c rz(16) = 0.00006065d0 / rhosec !Like ITRF2008
- rz(16) = 0.00031714d0 / rhosec
- drx(16) = -0.00001347d0 / rhosec !Like ITRF2008
- dry(16) = 0.00001514d0 / rhosec !Like ITRF2008
- drz(16) = 0.00001973d0 / rhosec !Like ITRF2008
-
-C scale(16) = -1.69504d-9 !Differs from ITRF2008, but only insignificantly
- scale(16) = -0.36891d-9
- dscale(16) = 0.07201d-9 !Differs from ITRF2008, but only insignificantly
- refepc(16) = 2010.0d0 !Differs from ITRF2008
-
-C*************************************************************************************************************************
-C Parameters computed with the IERS values of ITRF96==>ITRF97
-
-*** From ITRF94 to NAD 83
- tx1(1) = 0.9910d0
- ty1(1) = -1.9072d0
- tz1(1) = -.5129d0
- dtx1(1) = 0.d0
- dty1(1) = 0.d0
- dtz1(1) = 0.d0
- rx1(1) = 1.25033d-7
- ry1(1) = 0.46785d-7
- rz1(1) = 0.56529d-7
- drx1(1) = 0.00258d-7
- dry1(1) = -.03599d-7
- drz(1) = -.00153d-7
- scale(1) = 0.d0
- dscale1(1) = 0.0d0
- refepc1(1) = 1997.0d0
-
-*** From ITRF94 to ITRF88
- tx1(2) = 0.018d0
- ty1(2) = 0.000d0
- tz1(2) = -.092d0
- dtx1(2) = 0.0d0
- dty1(2) = 0.0d0
- dtz1(2) = 0.0d0
- rx1(2) = -.0001d0 / rhosec
- ry1(2) = 0.0d0
- rz1(2) = 0.0d0
- drx1(2) = 0.0d0
- dry1(2) = 0.0d0
- drz1(2) = 0.0d0
- scale1(2) = 0.74d-8
- dscale1(2) = 0.0d0
- refepc1(2) = 1988.0d0
-
-*** From ITRF94 to ITRF89
- tx1(3) = 0.023d0
- ty1(3) = 0.036d0
- tz1(3) = -.068d0
- dtx1(3) = 0.0d0
- dty1(3) = 0.0d0
- dtz1(3) = 0.0d0
- rx1(3) = 0.0d0
- ry1(3) = 0.0d0
- rz1(3) = 0.0d0
- drx1(3) = 0.0d0
- dry1(3) = 0.0d0
- drz1(3) = 0.0d0
- scale1(3) = 0.43d-8
- dscale1(3) = 0.0d0
- refepc1(3) = 1988.0d0
-
-*** From ITRF94 to ITRF90
- tx1(4) = 0.018d0
- ty1(4) = 0.012d0
- tz1(4) = -.030d0
- dtx1(4) = 0.0d0
- dty1(4) = 0.0d0
- dtz1(4) = 0.0d0
- rx1(4) = 0.0d0
- ry1(4) = 0.0d0
- rz1(4) = 0.0d0
- drx1(4) = 0.0d0
- dry1(4) = 0.0d0
- drz1(4) = 0.0d0
- scale1(4) = 0.09d-8
- dscale1(4) = 0.0d0
- refepc1(4) = 1988.0d0
-
-*** From ITRF94 to ITRF91
- tx1(5) = 0.020d0
- ty1(5) = 0.016d0
- tz1(5) = -.014d0
- dtx1(5) = 0.0d0
- dty1(5) = 0.0d0
- dtz1(5) = 0.0d0
- rx1(5) = 0.0d0
- ry1(5) = 0.0d0
- rz1(5) = 0.0d0
- drx1(5) = 0.0d0
- dry1(5) = 0.0d0
- drz1(5) = 0.0d0
- scale1(5) = 0.06d-8
- dscale1(5) = 0.0d0
- refepc1(5) = 1988.0d0
-
-*** From ITRF94 to ITRF92
- tx1(6) = 0.008d0
- ty1(6) = 0.002d0
- tz1(6) = -.008d0
- dtx1(6) = 0.0d0
- dty1(6) = 0.0d0
- dtz1(6) = 0.0d0
- rx1(6) = 0.0d0
- ry1(6) = 0.0d0
- rz1(6) = 0.0d0
- drx1(6) = 0.0d0
- dry1(6) = 0.0d0
- drz1(6) = 0.0d0
- scale1(6) = -.08d-8
- dscale1(6) = 0.0d0
- refepc1(6) = 1988.0d0
-
-*** From ITRF94 to ITRF93
- tx1(7) = 0.006d0
- ty1(7) = -.005d0
- tz1(7) = -.015d0
- dtx1(7) = -.0029d0
- dty1(7) = 0.0004d0
- dtz1(7) = 0.0008d0
- rx1(7) = 0.00039d0 / rhosec
- ry1(7) = -.00080d0 / rhosec
- rz1(7) = 0.00096d0 / rhosec
- drx1(7) = .00011d0 / rhosec
- dry1(7) = .00019d0 / rhosec
- drz1(7) =-.00005d0 / rhosec
- scale1(7) = 0.04d-8
- dscale1(7) = 0.0d0
- refepc1(7) = 1988.0d0
-
-*** From ITRF94 to ITRF96
- tx1(8) = 0.d0
- ty1(8) = 0.d0
- tz1(8) = 0.d0
- dtx1(8) = 0.d0
- dty1(8) = 0.d0
- dtz1(8) = 0.d0
- rx1(8) = 0.d0
- ry1(8) = 0.d0
- rz1(8) = 0.d0
- drx1(8) = 0.d0
- dry1(8) = 0.d0
- drz1(8) = 0.d0
- scale1(8) = 0.d0
- dscale1(8) = 0.0d0
- refepc1(8) = 1996.0d0
-
-*** From ITRF94 to ITRF97 (based on IERS adopted values)
-*** According to IERS: ITRF97 = ITRF96 = ITRF94
- tx1(9) = 0.00000d0
- ty1(9) = 0.00000d0
- tz1(9) = 0.00000d0
- dtx1(9) = 0.00000d0
- dty1(9) = 0.00000d0
- dtz1(9) = 0.00000d0
- rx1(9) = 0.00000000d0
- ry1(9) = 0.00000000d0
- rz1(9) = 0.00000000d0
- drx1(9) = 0.00000000d0
- dry1(9) = 0.00000000d0
- drz1(9) = 0.00000000d0
- scale1(9) = 0.d0
- dscale1(9) = 0.d0
- refepc1(9) = 2000.0d0
-
-*** From ITRF94 to WGS 72 (composition of ITRF94 -> NAD_83 -> WGS_72)
- tx1(10) = 0.9910d0
- ty1(10) = -1.9072d0
- tz1(10) = -.5129d0 - 4.5d0
- dtx1(10) = 0.d0
- dty1(10) = 0.d0
- dtz1(10) = 0.d0
- rx1(10) = 1.25033d-7
- ry1(10) = 0.46785d-7
- rz1(10) = 0.56529d-7 + 26.85868d-7
- drx1(10) = 0.00258d-7
- dry1(10) = -.03599d-7
- drz1(10) = -.00153d-7
- scale1(10) = 0.d0 - 0.2263d-6
- dscale1(10) = 0.0d0
- refepc1(10) = 1997.0d0
-
-*** From ITRF94 to ITRF00
-*** assumes that ITRF94 = ITRF96 and
-*** uses IERS values for ITRF96 -> ITRF97
-*** and IERS values for ITRF97 -> ITRF00
- tx1(11) = -.00670d0
- ty1(11) = -.00430d0
- tz1(11) = +.02270d0
- dtx1(11) = 0.00000d0
- dty1(11) = 0.00060d0
- dtz1(11) = 0.00140d0
- rx1(11) = 0.00000000d0 / rhosec
- ry1(11) = 0.00000000d0 / rhosec
- rz1(11) = +0.00006000d0 / rhosec
- drx1(11) = 0.00000000d0 / rhosec
- dry1(11) = 0.00000000d0 / rhosec
- drz1(11) = +0.00002000d0 / rhosec
- scale1(11) = -1.58000d-9
- dscale1(11) = -0.01000d-9
- refepc1(11) = 2000.0d0
-
-*** From ITRF94 to PACP00
-*** use PA/ITRF00 rotation rates from Beavan et al., (2002)
- tx1(12) = 0.9035d0
- ty1(12) = -2.0202d0
- tz1(12) = -0.5417d0
- dtx1(12) = 0.00000d0
- dty1(12) = 0.00060d0
- dtz1(12) = 0.0014d0
- rx1(12) = 0.027741d0 / rhosec
- ry1(12) = 0.013469d0 / rhosec
- rz1(12) = 0.002712d0 / rhosec
- drx1(12) = -.000384d0 / rhosec
- dry1(12) = 0.001007d0 / rhosec
- drz1(12) = -.002166d0 / rhosec
- scale1(12) = -1.55000d-9
- dscale1(12) = -0.010000d-9
- refepc1(12) = 1997.0d0
-
-*** From ITRF94 to MARP00
-*** Use velocity of GUAM
- tx1(13) = 0.9035d0
- ty1(13) = -2.0202d0
- tz1(13) = -0.5417d0
- dtx1(13) = -0.00000d0
- dty1(13) = 0.00060d0
- dtz1(13) = 0.00140d0
- rx1(13) = .028971d0 / rhosec
- ry1(13) = .01042d0 / rhosec
- rz1(13) = 0.008928d0 / rhosec
- drx1(13) = -0.00002d0 / rhosec
- dry1(13) = 0.000105d0 / rhosec
- drz1(13) = -0.000327d0 / rhosec
- scale1(13) = -1.55000d-9
- dscale1(13) = -0.01000d-9
- refepc1(13) = 1997.00d0
-
-*** From ITRF94 to ITRF2005
-*** assumes that ITRF94 = ITRF96
-*** uses IERS values for ITRF96 -> ITRF97
-*** uses IERS values for ITRF97 -> ITRF2000
-*** uses IERS values for ITRF2000 -> ITRF2005
- tx1(14) = -0.00680d0
- ty1(14) = -0.00350d0
- tz1(14) = 0.0285d0
- dtx1(14) = 0.00020d0
- dty1(14) = 0.00050d0
- dtz1(14) = 0.00320d0
- rx1(14) = 0.00000000d0 / rhosec
- ry1(14) = 0.00000000d0 / rhosec
- rz1(14) = +0.00006000d0 / rhosec
- drx1(14) = 0.00000000d0 / rhosec
- dry1(14) = 0.00000000d0 / rhosec
- drz1(14) = +0.00002000d0 / rhosec
- scale1(14) = -1.98000d-9
- dscale1(14) = -0.09000d-9
- refepc1(14) = 2000.0d0
-
-*** From ITRF94 to ITRF2008 (also IGS08 and IGB08)
-*** assumes that ITRF94 = ITRF96
-*** uses IERS values for ITRF96 -> ITRF97
-*** uses IERS values for ITRF97 -> ITRF2000
-*** uses IERS values for ITRF2000-> ITRF2005
-*** uses IERS values for ITRF2005 -> ITRF2008 (and IGS08 and IGB08)
- tx1(15) = -0.00480d0
- ty1(15) = -0.00260d0
- tz1(15) = 0.03320d0
- dtx1(15) = -0.00010d0
- dty1(15) = 0.00050d0
- dtz1(15) = 0.00320d0
- rx1(15) = 0.00000000d0 / rhosec
- ry1(15) = 0.00000000d0 / rhosec
- rz1(15) = +0.00006000d0 / rhosec
- drx1(15) = -0.00000000d0 / rhosec
- dry1(15) = 0.00000000d0 / rhosec
- drz1(15) = +0.00002000d0 / rhosec
- scale1(15) = -2.92d-9
- dscale1(15) = -0.09d-9
- refepc1(15) = 2000.0d0
-
-*** From ITRF94 to ITRF2014
-*** assumes that ITRF94 = ITRF96
-*** uses IERS values for ITRF96 -> ITRF97
-*** uses IERS values for ITRF97 -> ITRF2000
-*** uses IERS values for ITRF2000-> ITRF2005
-*** uses IERS values for ITRF2005 -> ITRF2008 (and IGS08 and IGB08)
-*** uses IERS values for ITRF2008 -> ITRF2014
-
-c tx1(16) = -0.00640d0 !Differ from ITRF2008
- tx1(16) = -0.00740d0
-c ty1(16) = -0.00450d0 !Differ from ITRF2008
- ty1(16) = 0.00050d0
-c tz1(16) = 0.03080d0 !Differ from ITRF2008
- tz1(16) = 0.06280d0
-
- dtx1(16) = -0.00010d0 !Like ITRF2008
- dty1(16) = 0.00050d0 !Like ITRF2008
- dtz1(16) = 0.00330d0 !Differ from ITRF2008
-
- rx1(16) = 0.00000000d0 / rhosec !Like ITRF2008
- ry1(16) = 0.00000000d0 / rhosec !Like ITRF2008
-c rz1(16) = +0.00006000d0 / rhosec !Like ITRF2008
- rz1(16) = +0.00026000d0 / rhosec
- drx1(16) = -0.00000000d0 / rhosec !Like ITRF2008
- dry1(16) = 0.00000000d0 / rhosec !Like ITRF2008
- drz1(16) = +0.00002000d0 / rhosec !Like ITRF2008
-
-c scale1(16) = -2.90d-9 !Differ from ITRF2008, but only insignificantly
- scale1(16) = -3.80d-9
- dscale1(16) = -0.12d-9 !Differ from ITRF2008, but only insignificantly
-
- refepc1(16) = 2010.0d0 !Differ from ITRF2008
-
- return
- end
-*************************************************************
- subroutine frit94(x1, y1, z1, x2, y2, z2, date, jopt)
-
-*** Converts ITRF94 cartesian coordinates to cartesian
-*** coordinates in the specified reference frame for the
-*** given date
-****************
-C Important note:
-C The parameters in common block tranpa are computed using the IGS values of ITRF96==>ITRF97
-C The parameters in common block tranpa1 are computed using the IERS values of ITRF96==>ITRF97
-
-*** (x1, y1, z1) --> input ITRF94 coordiates (meters)
-*** (x2, y2, z2) --> output coordinates (meters)
-*** date --> time (decimal years) to which the input & output
-*** coordinates correspond
-*** jopt --> input specifier of output reference frame
-
- implicit double precision (a-h, o-z)
- implicit integer*4 (i-n)
- parameter (numref = 16)
-
- common /tranpa/ tx(numref), ty(numref), tz(numref),
- & dtx(numref), dty(numref), dtz(numref),
- & rx(numref), ry(numref), rz(numref),
- & drx(numref), dry(numref), drz(numref),
- & scale(numref), dscale(numref), refepc(numref)
-
- if (jopt .eq. 0) then
- iopt = 1
- else
- iopt = jopt
- endif
-
- dtime = date - refepc(iopt)
- tranx = tx(iopt) + dtx(iopt)*dtime
- trany = ty(iopt) + dty(iopt)*dtime
- tranz = tz(iopt) + dtz(iopt)*dtime
- rotnx = rx(iopt) + drx(iopt)*dtime
- rotny = ry(iopt) + dry(iopt)*dtime
- rotnz = rz(iopt) + drz(iopt)*dtime
- ds = 1.d0 + scale(iopt) + dscale(iopt)*dtime
-
- x2 = tranx + ds*x1 + rotnz*y1 - rotny*z1
- y2 = trany - rotnz*x1 + ds*y1 + rotnx*z1
- z2 = tranz + rotny*x1 - rotnx*y1 + ds*z1
-c write (*,*) "FROM TIIT94 ",dtime
-c write (*,*) "FROM TIIT94 ",tx(iopt),ty(iopt),tz(iopt)
-c write (*,*) "FROM TIIT94 ",dtx(iopt),dty(iopt),dtz(iopt)
-c write (*,*) "FROM TIIT94 ",rx(iopt),ry(iopt),rz(iopt)
-c write (*,*) "FROM TIIT94 ",drx(iopt),dry(iopt),drz(iopt)
-c write (*,*) "FROM TIIT94 ",scale(iopt),dscale(iopt)
-c write (*,*) "FROM TIIT94 ",x2,y2,z2
-
- return
- end
-*************************************************************************************
- subroutine frit94_IERS (x1, y1, z1, x2, y2, z2, date, jopt)
-
-*** Converts ITRF94 cartesian coordinates to cartesian
-*** coordinates in the specified reference frame for the
-*** given date
-****************
-C Important note:
-C The parameters in common block tranpa are computed using the IGS values of ITRF96==>ITRF97
-C The parameters in common block tranpa1 are computed using the IERS values of ITRF96==>ITRF97
-
-*** (x1, y1, z1) --> input ITRF94 coordiates (meters)
-*** (x2, y2, z2) --> output coordinates (meters)
-*** date --> time (decimal years) to which the input & output
-*** coordinates correspond
-*** jopt --> input specifier of output reference frame
-
- implicit double precision (a-h, o-z)
- implicit integer*4 (i-n)
- parameter (numref = 16)
-
- common /tranpa1/ tx1(numref), ty1(numref), tz1(numref),
- & dtx1(numref), dty1(numref), dtz1(numref),
- & rx1(numref), ry1(numref), rz1(numref),
- & drx1(numref), dry1(numref), drz1(numref),
- & scale1(numref), dscale1(numref), refepc1(numref)
-
-
- if (jopt .eq. 0) then
- iopt = 1
- else
- iopt = jopt
- endif
-
- dtime = date - refepc1(iopt)
- tranx = tx1(iopt) + dtx1(iopt)*dtime
- trany = ty1(iopt) + dty1(iopt)*dtime
- tranz = tz1(iopt) + dtz1(iopt)*dtime
- rotnx = rx1(iopt) + drx1(iopt)*dtime
- rotny = ry1(iopt) + dry1(iopt)*dtime
- rotnz = rz1(iopt) + drz1(iopt)*dtime
- ds = 1.d0 + scale1(iopt) + dscale1(iopt)*dtime
-
- x2 = tranx + ds*x1 + rotnz*y1 - rotny*z1
- y2 = trany - rotnz*x1 + ds*y1 + rotnx*z1
- z2 = tranz + rotny*x1 - rotnx*y1 + ds*z1
-c write (*,*) "FROM TIIT94_IERS ",dtime
-c write (*,*) "FROM TIIT94_IERS ",tx1(iopt),ty1(iopt),tz1(iopt)
-c write (*,*) "FROM TIIT94_IERS ",dtx1(iopt),dty1(iopt),dtz1(iopt)
-c write (*,*) "FROM TIIT94_IERS ",rx1(iopt),ry1(iopt),rz1(iopt)
-c write (*,*) "FROM TIIT94_IERS ",drx1(iopt),dry1(iopt),drz1(iopt)
-c write (*,*) "FROM TIIT94_IERS ",scale1(iopt),dscale1(iopt)
-c write (*,*) "FROM TIIT94_IERS ",x2,y2,z2
-
- return
- end
-
-***********************************************************
- subroutine toit94(x1, y1, z1, x2, y2, z2, date, jopt)
-
-*** Converts cartesian coordinates in a specified reference
-*** to ITRF94 cartesian coordinates for the given date
-****************
-C Important note:
-C The parameters in common block tranpa are computed using the IGS values of ITRF96==>ITRF97
-C The parameters in common block tranpa1 are computed using the IERS values of ITRF96==>ITRF97
-
-*** (x1, y1, z1) --> input coordiates (meters)
-*** (x2, y2, z2) --> output ITRF94 coordinates (meters)
-*** date --> time (decimal years) to which the input & output
-*** coordinates correspond
-*** jopt --> input specifier of input reference frame
-
- implicit double precision (a-h, o-z)
- implicit integer*4 (i-n)
- parameter (numref = 16)
-
- common /tranpa/ tx(numref), ty(numref), tz(numref),
- & dtx(numref), dty(numref), dtz(numref),
- & rx(numref), ry(numref), rz(numref),
- & drx(numref), dry(numref), drz(numref),
- & scale(numref), dscale(numref), refepc(numref)
-
- if (jopt .eq. 0) then
- iopt = 1
- else
- iopt = jopt
- endif
-
- dtime = date - refepc(iopt)
- tranx = -(tx(iopt) + dtx(iopt)*dtime)
- trany = -(ty(iopt) + dty(iopt)*dtime)
- tranz = -(tz(iopt) + dtz(iopt)*dtime)
- rotnx = -(rx(iopt) + drx(iopt)*dtime)
- rotny = -(ry(iopt) + dry(iopt)*dtime)
- rotnz = -(rz(iopt) + drz(iopt)*dtime)
- ds = 1.d0 - (scale(iopt) + dscale(iopt)*dtime)
-
- x2 = tranx + ds*x1 + rotnz*y1 - rotny*z1
- y2 = trany - rotnz*x1 + ds*y1 + rotnx*z1
- z2 = tranz + rotny*x1 - rotnx*y1 + ds*z1
-c write (*,*) "TO TIIT94 ",dtime
-c write (*,*) "TO TIIT94 ",tx(iopt),ty(iopt),tz(iopt)
-c write (*,*) "TO TIIT94 ",dtx(iopt),dty(iopt),dtz(iopt)
-c write (*,*) "TO TIIT94 ",rx(iopt),ry(iopt),rz(iopt)
-c write (*,*) "TO TIIT94 ",drx(iopt),dry(iopt),drz(iopt)
-c write (*,*) "TO TIIT94 ",scale(iopt),dscale(iopt)
-c write (*,*) "TO TIIT94 ",x2,y2,z2
-
- return
- end
-
-*****************************************************************
- subroutine toit94_IERS(x1, y1, z1, x2, y2, z2, date, jopt)
-
-*** Converts cartesian coordinates in a specified reference
-*** to ITRF94 cartesian coordinates for the given date
-****************
-C Important note:
-C The parameters in common block tranpa are computed using the IGS values of ITRF96==>ITRF97
-C The parameters in common block tranpa1 are computed using the IERS values of ITRF96==>ITRF97
-
-*** (x1, y1, z1) --> input coordiates (meters)
-*** (x2, y2, z2) --> output ITRF94 coordinates (meters)
-*** date --> time (decimal years) to which the input & output
-*** coordinates correspond
-*** jopt --> input specifier of input reference frame
-
- implicit double precision (a-h, o-z)
- implicit integer*4 (i-n)
- parameter (numref = 16)
-
- common /tranpa1/ tx1(numref), ty1(numref), tz1(numref),
- & dtx1(numref), dty1(numref), dtz1(numref),
- & rx1(numref), ry1(numref), rz1(numref),
- & drx1(numref), dry1(numref), drz1(numref),
- & scale1(numref), dscale1(numref), refepc1(numref)
-
-
- if (jopt .eq. 0) then
- iopt = 1
- else
- iopt = jopt
- endif
-
- dtime = date - refepc1(iopt)
- tranx = -(tx1(iopt) + dtx1(iopt)*dtime)
- trany = -(ty1(iopt) + dty1(iopt)*dtime)
- tranz = -(tz1(iopt) + dtz1(iopt)*dtime)
- rotnx = -(rx1(iopt) + drx1(iopt)*dtime)
- rotny = -(ry1(iopt) + dry1(iopt)*dtime)
- rotnz = -(rz1(iopt) + drz1(iopt)*dtime)
- ds = 1.d0 - (scale1(iopt) + dscale1(iopt)*dtime)
-
- x2 = tranx + ds*x1 + rotnz*y1 - rotny*z1
- y2 = trany - rotnz*x1 + ds*y1 + rotnx*z1
- z2 = tranz + rotny*x1 - rotnx*y1 + ds*z1
-c write (*,*) "TO TIIT94_IERS ",dtime
-c write (*,*) "TO TIIT94_IERS ",tx1(iopt),ty1(iopt),tz1(iopt)
-c write (*,*) "TO TIIT94_IERS ",dtx1(iopt),dty1(iopt),dtz1(iopt)
-c write (*,*) "TO TIIT94_IERS ",rx1(iopt),ry1(iopt),rz1(iopt)
-c write (*,*) "TO TIIT94_IERS ",drx1(iopt),dry1(iopt),drz1(iopt)
-c write (*,*) "TO TIIT94_IERS ",scale1(iopt),dscale1(iopt)
-c write (*,*) "TO TIIT94_IERS ",x2,y2,z2
-
- return
- end
-*****************************************************************
- subroutine MENU1(kopt, mframe)
-
-** Write out options for reference frames
-
- implicit integer*4 (i-n)
- character mframe*24, nframe*24
- dimension nframe(24)
- dimension iframe(24)
- common /files/ luin, luout, i1, i2, i3, i4, i5, i6
-
- iframe(1) = 1
- nframe(1) = 'NAD_83(2011/CORS96/2007)'
- iframe(2) = 12
- nframe(2) = 'NAD_83(PA11/PACP00) '
- iframe(3) = 13
- nframe(3) = 'NAD_83(MA11/MARP00) '
- iframe(4) = 10
- nframe(4) = 'WGS_72 '
- iframe(5) = 1
- nframe(5) = 'WGS_84(transit) '
-c iframe(6) = 6 (This was incorrect in all versions of HTDP)
- iframe(6) = 5
- nframe(6) = 'WGS_84(G730) '
- iframe(7) = 8
- nframe(7) = 'WGS_84(G873) '
- iframe(8) = 11
- nframe(8) = 'WGS_84(G1150) '
- iframe(9) = 15
- nframe(9) = 'WGS_84(G1674) '
-c iframe(10)= 4
-c nframe(10)= 'PNEOS_90 or NEOS_90 '
- iframe(10)= 15
- nframe(10)= 'WGS_84(G1762) '
- iframe(11)= 5
- nframe(11)= 'SIO/MIT_92 '
- iframe(12)= 2
- nframe(12)= 'ITRF88 '
- iframe(13)= 3
- nframe(13)= 'ITRF89 '
- iframe(14)= 4
- nframe(14)= 'ITRF90 '
- iframe(15)= 5
- nframe(15)= 'ITRF91 '
- iframe(16)= 6
- nframe(16)= 'ITRF92 '
- iframe(17)= 7
- nframe(17)= 'ITRF93 '
- iframe(18)= 8
- nframe(18)= 'ITRF94 '
- iframe(19)= 8
- nframe(19)= 'ITRF96 '
- iframe(20)= 9
- nframe(20)= 'ITRF97 or IGS97 '
- iframe(21)= 11
- nframe(21)= 'ITRF2000 or IGS00/IGb00 '
- iframe(22)= 14
- nframe(22)= 'ITRF2005 or IGS05 '
- iframe(23)= 15
- nframe(23)= 'ITRF2008 or IGS08/IGB08 '
- iframe(24)= 16
- nframe(24)= 'ITRF2014 or IGS14 '
-
- write(luout, 100)
- 100 format(
- 1' 1...NAD_83(2011/CORS96/2007) (North American plate fixed) '/
- 1' 2...NAD_83(PA11/PACP00) (Pacific plate fixed) '/
- 1' 3...NAD_83(MA11/MARP00) (Mariana plate fixed) '/
- 1' '/
-c 1' 4...WGS_72 '/
- 1' 5...WGS_84(transit) (NAD_83(2011) used) 15...ITRF91 '/
- 1' 6...WGS_84(G730) (ITRF91 used) 16...ITRF92 '/
- 1' 7...WGS_84(G873) (ITRF94 used) 17...ITRF93 '/
- 1' 8...WGS_84(G1150) (ITRF2000 used) 18...ITRF94 '/
- 1' 9...WGS_84(G1674) (ITRF2008 used) 19...ITRF96 '/
-c 1' 10...PNEOS_90 or NEOS_90 (ITRF90 used) 20...ITRF97 or IGS97'/
- 1' 10...WGS_84(G1762) (IGb08 used) 20...ITRF97 or IGS97'/
- 1' 11...SIO/MIT_92 (ITRF91 used) 21...ITRF2000 or IGS00/IGb00'/
- 1' 12...ITRF88 22...ITRF2005 or IGS05 '/
- 1' 13...ITRF89 23...ITRF2008 or IGS08/IGb08'/
- 1' 14...ITRF90 or (PNEOS90/NEOS90) 24...ITRF2014 or IGS14 '/ )
-c 1' 14...ITRF90 '/ )
-
- read (luin, *,err=50,iostat=ios) iopt
- if (ios /= 0) goto 50
- if ( 1 .le. iopt .and. iopt .le. 24) then
- mframe = nframe(iopt)
- kopt = iframe(iopt)
- else
- mframe = ' '
- kopt = iopt
- endif
- return
-
- 50 write (*,*) 'Failed to read option in MENU1:ios=',ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- end
-
-***************************************************************
- SUBROUTINE UPDATE(HTDP_version)
-
-** Update positions and/or observations to a specified date.
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (numref = 16)
- parameter (nbbdim = 10000)
- CHARACTER OLDBB*30,NEWBB*30, NAMEIF*30
- CHARACTER NAME24*24
- CHARACTER OPT*1,ANSWER*1,BBTYPE*1,VOPT*1
- CHARACTER LATDIR*1, LONDIR*1, LATDR*1, LONDR*1
- character frame1*24, frame2*24
- character HTDP_version*10
- LOGICAL TEST
- LOGICAL Is_iopt_NAD83
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
- COMMON /CAUTION/ MONTH2, IDAY2, IYEAR2, DATE2,frame1
-
- WRITE(LUOUT,20)
- 20 FORMAT(' ********************************************'/
- 1 ' Please enter the time to which the updated'/
- 1 ' positions and/or observations are to correspond.')
- 15 CALL GETMDY(MONTH2,IDAY2,IYEAR2,DATE2,MIN2,TEST)
- IF(TEST) then
- write(luout,*) ' Do you wish to re-enter the time? (y/n)'
- read (luin, '(A1)',err=500,iostat=ios) ANSWER
- if (ios /= 0) goto 500
- if (ANSWER .eq. 'y' .or. ANSWER .eq. 'Y') GO TO 15
- RETURN
- ENDIF
-
-** Choosing reference frame for positions
- 35 WRITE(LUOUT,30)
- 30 FORMAT(' **************************************************'/
- 1 ' Select the reference frame to be used for specifying'/
- 2 ' positions. '/)
- call MENU1( iopt, frame1)
- IF(IOPT .LT. 1 .OR. IOPT .GT. numref) THEN
- WRITE(LUOUT,40)
- 40 FORMAT(' Improper selection--try again. ')
- GO TO 35
- ENDIF
- Is_iopt_NAD83 = (iopt == 1)
-
- 999 WRITE(LUOUT,1000)
- 1000 FORMAT(' ******************************'/
- 1 ' Select option:'/
- 2 ' 0...No more updates. Return to main menu.'/
- 3 ' 1...Update positions for individual points',
- 4 ' entered interactively.'/
- 5 ' 2...Update positions for blue book stations.'/
- 6 ' 3...Update values for blue book observations.'/
- 7 ' 4...Update both the positions for blue book',
- 8 ' stations'/
- 9 ' and the values for blue book',
- 9 ' observations.'/
- 9 ' 5...Update positions contained in batch file '/
- 9 ' of delimited records of the form: '/
- 9 ' LAT,LON,EHT,"TEXT" ' /
- 9 ' LAT = latitude in degrees (positive north/DBL PREC)'/
- 9 ' LON = longitude in degrees (positive west/DBL PREC)'/
- 9 ' EHT = ellipsoid height in meters (DBL PREC)'/
- 9 ' TEXT = Descriptive text (CHARACTER*24) '/
- 9 ' Example: '/
- 9 ' 40.731671553,112.212671753,34.241,"SALT AIR" '/)
- READ(LUIN,'(A1)',err=501,iostat=ios) OPT
- if (ios /= 0) goto 501
- IF(OPT .eq. '0') THEN
- RETURN
- ELSEIF(OPT .eq. '1') THEN
- WRITE(LUOUT,1020)
- 1020 FORMAT(' ************************************'/
- 1 ' Enter the time',
- 2 ' to which the input positions will correspond. ')
- 1025 CALL GETMDY(MONTH1,IDAY1,IYEAR1,DATE1,MIN1,TEST)
- IF(TEST) then
- write(luout,*) ' Do you wish to re-enter the time? (y/n)'
- read(luin,'(A1)',err=500,iostat=ios) ANSWER
- if (ios /= 0) goto 500
- if(ANSWER .eq. 'Y' .or. ANSWER .eq. 'y') GO TO 1025
- RETURN
- ENDIF
- WRITE(LUOUT,1030)
- 1030 FORMAT(' ENTER file to save updated positions. ')
- READ(LUIN,'(A30)',err=502,iostat=ios) NEWBB
- if (ios /= 0) goto 502
- OPEN(I2,FILE=NEWBB,STATUS='UNKNOWN')
- CALL HEADER
-
- WRITE(I2,1031) frame1
- 1031 FORMAT(' UPDATED POSITIONS IN ', a24)
-
- WRITE(I2,1040) MONTH1,IDAY1,IYEAR1,MONTH2,IDAY2,IYEAR2,
- 1 DATE1, DATE2
- 1040 FORMAT(' FROM ',I2,'-',I2.2,'-',I4,
- 1 ' TO ',I2,'-',I2.2,'-',I4,' (month-day-year)'/
- 1 ' FROM ',F8.3, ' TO ',F8.3, ' (decimal years)'//
- 2 16X,'OLD COORDINATE NEW COORDINATE',
- 3 4X,'VELOCITY DISPLACEMENT',/)
- 1050 CALL GETPNT(LATD,LATM,SLAT,LATDIR,LOND,LONM,SLON,
- 1 LONDIR, NAME24, X,Y,Z,YLAT,YLON,EHT)
- ELON = -YLON
- call GETVLY(YLAT,ELON,VX,VY,VZ,VN,VE,VU,VOPT,210)
- IF ( VOPT .EQ. '0') then
- call PREDV( ylat, ylon, eht, date1, iopt,
- 1 jregn, vn, ve, vu)
- IF(JREGN .eq. 0) THEN
- WRITE(LUOUT,1060)
- 1060 FORMAT(' **************************************'/
- 1 ' Can not update the position of this point'/
- 2 ' because it is outside of the modeled region.'/)
- GO TO 1075
- ELSE
- call TOVXYZ(ylat,elon,vn,ve,vu,vx,vy,vz)
- ENDIF
- ENDIF
- call NEWCOR(ylat,ylon,eht,min1,min2,
- 1 ylatt,ylont,ehtnew,dn,de,du,vn,ve,vu)
- CALL TODMSS(YLATT,LATDN,LATMN,SLATN,ISIGN)
- LATDR = 'N'
- IF (ISIGN .eq. -1) LATDR = 'S'
- CALL TODMSS(YLONT,LONDN,LONMN,SLONN,ISIGN)
- LONDR = 'W'
- IF (ISIGN .eq. -1) LONDR = 'E'
- ELONT = -YLONT
- CALL TOXYZ(YLATT,ELONT,EHTNEW,X1,Y1,Z1)
- DX = X1 - X
- DY = Y1 - Y
- DZ = Z1 - Z
- WRITE(LUOUT,1065)LATDN,LATMN,SLATN,LATDR,LONDN,LONMN,SLONN,
- 1 LONDR, EHTNEW, X1,Y1,Z1
- 1065 FORMAT(' ****************************************'/
- 1 ' Updated latitude = ',I3,I3,1X,F8.5,1X,A1 /
- 2 ' Updated longitude = ',I3,I3,1X,F8.5,1X,A1 /
- 2 ' Updated Ellip. Ht. = ', F12.3 ,' meters' /
- 3 ' Updated X = ',F12.3 ,' meters' /
- 4 ' Updated Y = ',F12.3 ,' meters' /
- 5 ' Updated Z = ',F12.3 ,' meters' /
- 3 ' ****************************************'/)
- WRITE(I2,1070)NAME24,
- 1 LATD,LATM,SLAT,LATDIR,LATDN,LATMN,SLATN,LATDR,vn,DN,
- 1 LOND,LONM,SLON,LONDIR,LONDN,LONMN,SLONN,LONDR,ve,DE,
- 1 EHT, EHTNEW, vu,DU, X, X1, vx,DX,
- 1 Y, Y1, vy,DY, Z, Z1, vz,DZ
- 1070 FORMAT(1X,A24,/
- 1 1X, 'LATITUDE ',2(2X,I3,I3.2,1X,F8.5,1X,A1),
- 1 F8.2, ' mm/yr', f8.3, ' m north'/
- 1 1X, 'LONGITUDE ',2(2X,I3,I3.2,1X,F8.5,1x,A1),
- 1 f8.2, ' mm/yr',f8.3,' m east'/
- 1 1X, 'ELLIP. HT.',2(6X,F13.3),
- 1 f8.2, ' mm/yr',F8.3,' m up'/
- 1 1X, 'X ',2(6X,F13.3),
- 1 f8.2, ' mm/yr',F8.3,' m '/
- 1 1X, 'Y ',2(6X,F13.3),
- 1 f8.2, ' mm/yr',f8.3, ' m'/
- 1 1X, 'Z ',2(6X,F13.3),
- 1 f8.2, ' mm/yr',F8.3,' m'/)
- 1075 WRITE(LUOUT,1080)
- 1080 FORMAT(' Update more positions? (y/n) ')
- READ(LUIN,'(A1)',err=500,iostat=ios) ANSWER
- if (ios /= 0) goto 500
- IF(ANSWER .eq. 'Y' .or. ANSWER .eq. 'y') GO TO 1050
- CLOSE(I2,STATUS='KEEP')
- RETURN
-
-*** Updating a blue book
-
- ELSEIF(OPT .eq. '2' .or. OPT .eq. '3' .or. OPT .eq. '4') THEN
-
- if (nbbdim .eq. 10000) then
- 90 WRITE(LUOUT,91)
- 91 FORMAT(
- 1 ' Identify type of blue book:'/
- 2 ' 1...Standard (4-digit SSN)'/
- 3 ' 2...Non-standard (5-digit SSN) ')
- READ(LUIN,'(A1)',err=503,iostat=ios) BBTYPE
- if (ios /= 0) goto 503
- IF(BBTYPE .NE. '1' .AND. BBTYPE .NE. '2') GO TO 90
- else
- BBTYPE = '1'
- endif
-
- WRITE(LUOUT,100)
- 100 FORMAT(' Enter name of the blue book file to be updated.'/)
- READ(LUIN,110,err=502,iostat=ios) OLDBB
- if (ios /= 0) goto 502
- 110 FORMAT(A30)
- WRITE(LUOUT,120)
- 120 FORMAT(' Enter name for the new blue book file that is to '/
- 1 'contain the updated information.'/)
- READ(LUIN,110,err=502,iostat=ios) NEWBB
- if (ios /= 0) goto 502
- OPEN(I1,FILE = OLDBB , STATUS = 'OLD')
-
- OPEN(I4, ACCESS = 'DIRECT', RECL = 40,
- 1 FORM = 'UNFORMATTED', STATUS = 'SCRATCH')
-
- IF(OPT .eq. '2' .or. OPT .eq. '4') THEN
- WRITE(LUOUT,122)
- 122 FORMAT(' *********************************************'/
- 1 ' Enter the time',
- 1 ' to which the input positions correspond.'/)
- 123 CALL GETMDY(MONTH1,IDAY1,IYEAR1,DATE1,MIN1,TEST)
- IF(TEST) then
- write(luout,*) ' Do you wish to re-enter the time? (y/n)'
- read(luin, '(A1)',err=500,iostat=ios) ANSWER
- if (ios /= 0) goto 500
- IF (ANSWER .eq. 'y' .or. ANSWER .eq. 'Y') GO TO 123
- RETURN
- ENDIF
- ENDIF
-
-*** Retrieve geodetic positions from old blue-book file
-
- IF(BBTYPE .EQ. '1') THEN
- CALL GETPO4(IOPT, DATE1)
- ELSEIF(BBTYPE .EQ. '2') THEN
- CALL GETPO5(IOPT, DATE1)
- ENDIF
-
-*** Create new blue book file
-
- OPEN(I2,FILE = NEWBB, STATUS = 'UNKNOWN')
-
- write (i2,127) HTDP_version
- 127 format (' ***CAUTION: This file was processed using HTDP',
- & ' version ',a10, '***')
- write (i2,128) frame1
- 128 format (' ***CAUTION: Coordinates in this file are in ',
- & a24, '***')
- IF (OPT .EQ. '2' .OR. OPT .EQ. '4') THEN
- WRITE(I2, 129) MONTH2, IDAY2, IYEAR2, DATE2
- 129 FORMAT(' ***CAUTION: Coordinates in this file have been ',
- * 'updated to ',I2,'-',I2.2,'-',I4, ' = (',F8.3,') ***')
- ENDIF
-
-c IF (OPT .EQ. '3' .OR. OPT .EQ. '4') THEN
-c WRITE(I2, 130) MONTH2, IDAY2, IYEAR2, DATE2
-c 130 FORMAT(' ***CAUTION: Observations in this file have been ',
-c * 'updated to ',I2,'-',I2.2,'-',I4, ' = (',F8.3,') ***')
-c ENDIF
-
- IF(BBTYPE .EQ. '1') THEN
- CALL UPBB4(MIN1,MIN2,OPT,IOPT)
- ELSEIF(BBTYPE .EQ. '2') THEN
- CALL UPBB5(MIN1,MIN2,OPT,IOPT)
- ENDIF
- CLOSE(I1, STATUS = 'KEEP')
- CLOSE(I2, STATUS = 'KEEP')
-
-*** Update G-FILE
-
- IF(OPT .eq. '3' .or. OPT .eq. '4') THEN
- 605 WRITE(LUOUT,610)
- 610 FORMAT(/' Is there a G-FILE to be updated? (y/n) ')
- READ(LUIN,'(A1)',err=500,iostat=ios) ANSWER
- if (ios /= 0) goto 500
- IF(ANSWER .eq. 'N' .or. ANSWER .eq. 'n') THEN
- CONTINUE
- ELSEIF(ANSWER .eq. 'Y' .or. ANSWER .eq. 'y')THEN
- WRITE(LUOUT,620)
- 620 FORMAT(' Enter name of old G-FILE to be updated. ')
- READ(LUIN,'(A30)',err=502,iostat=ios) OLDBB
- if (ios /= 0) goto 502
- WRITE(LUOUT,630)
- 630 FORMAT(' Enter name for the new updated G-FILE. ')
- READ(LUIN,'(A30)',err=502,iostat=ios) NEWBB
- if (ios /= 0) goto 502
- OPEN(I1,FILE=OLDBB,STATUS='OLD')
- OPEN(I2,FILE=NEWBB,STATUS='UNKNOWN')
- WRITE(I2,130) MONTH2, IDAY2, IYEAR2, DATE2
- 130 FORMAT(' ***CAUTION: Observations in this file have been ',
- * 'updated to ',I2,'-',I2.2,'-',I4, ' = (',F8.3,') ***')
-
- 634 WRITE(LUOUT, 632)
- 632 FORMAT(/' ***************************'/
- * ' To what reference frame should the GPS'/
- * ' vectors be transformed?'/
- * ' -1...Do not transform GPS vectors.')
- CALL MENU1(kopt, frame2)
- IF(KOPT .LT. -1 .OR. KOPT .GT. numref) THEN
- WRITE(LUOUT, 40)
- GO TO 634
- ELSEIF (1 .LE. KOPT .AND. KOPT .LE. numref) then
- write( I2, 640) frame2
- 640 format( ' ***CAUTION: All GPS interstation vectors',
- 1 ' have been transformed to ', a24, ' ***')
- write( I2, 641) HTDP_version
- 641 format(' ***CAUTION: Observations were transformed using'
- 1 ,' HTDP version ', a10, ' ***')
- ENDIF
-
- IF(BBTYPE .EQ. '1') THEN
- CALL UPGFI4(DATE2, MIN2, IOPT, KOPT,
- * MONTH2, IDAY2, IYEAR2)
- ELSEIF(BBTYPE .EQ. '2') THEN
- CALL UPGFI5(DATE2, MIN2, IOPT, KOPT,
- * MONTH2, IDAY2, IYEAR2)
- ENDIF
- CLOSE(I1, STATUS = 'KEEP')
- CLOSE(I2, STATUS = 'KEEP')
- ELSE
- WRITE(LUOUT,700)
- GO TO 605
- ENDIF
- ENDIF
- CLOSE(I4, STATUS = 'DELETE')
- RETURN
- ELSEIF (OPT .eq. '5') then
- write (luout, 710)
- 710 format(' Enter name of input file ')
- read( luin, 711,err=502,iostat=ios) NAMEIF
- if (ios /= 0) goto 502
- 711 format( a30 )
- open(I1, FILE=NAMEIF, STATUS = 'OLD')
- write(luout, 1020)
- 720 call GETMDY(MONTH1,IDAY1,IYEAR1,DATE1,MIN1,TEST)
- if(TEST) then
- write(luout,*) ' Do you wish to re-enter the time? (y/n)'
- read(luin, '(A1)',err=500,iostat=ios) ANSWER
- if (ios /= 0) goto 500
- if(ANSWER .eq. 'Y' .or. ANSWER .eq. 'y') GO TO 720
- RETURN
- endif
- write(luout, 1030)
- read(luin, '(a30)',err=502,iostat=ios)NEWBB
- if (ios /= 0) goto 502
- open(I2, FILE=NEWBB, STATUS='UNKNOWN')
- CALL HEADER
- write(I2, 1031) frame1
- write(I2, 1040) MONTH1,IDAY1,IYEAR1,
- 1 MONTH2,IDAY2,IYEAR2,DATE1,DATE2
- 730 read(I1,*,END = 750,err=504,iostat=ios) XLAT, XLON, EHT, NAME24
- if (ios /= 0) goto 504
- YLAT = (XLAT*3600.d0) / rhosec
- Ylon = (XLON*3600.d0) / rhosec
- ELON = -YLON
- call TODMSS(ylat,latd,latm,slat,ISIGN)
- if (ISIGN .eq. 1) then
- latdir = 'N'
- else
- latdir = 'S'
- endif
- call TODMSS (ylon,lond,lonm,slon,isign)
- if (isign .eq. 1) then
- londir = 'W'
- else
- londir = 'E'
- endif
- call PREDV(ylat,ylon,eht,date1,iopt,jregn,vn,ve,vu)
- if(jregn .eq. 0) then
- write(I2, 735) name24, latd,latm,slat,latdir,
- 1 lond,lonm,slon,londir
- 735 format(1x,a24,/
- 1 1x, 'LATITUDE ', 2x,i3,i3.2,1x,f8.5,1x,a1,3x,
- 1 'POINT LOCATED OUTSIDE OF MODELED REGION'/
- 1 1x, 'LONGITUDE ', 1x,i3,i3.2,1x,f8.5,1x,a1 /)
- else
- call TOVXYZ(ylat,elon,vn,ve,vu,vx,vy,vz)
- call NEWCOR(ylat,ylon,eht,min1,min2,ylatt,ylont,ehtnew,
- 1 dn,de,du,vn,ve,vu)
- call TODMSS(YLATT,latdn,latmn,slatn,isign)
- latdr = 'N'
- if (isign .eq. -1) latdr = 'S'
- call TODMSS(ylont,londn,lonmn,slonn,isign)
- londr = 'W'
- if (isign .eq. -1) londr = 'E'
- call TOXYZ(ylat,elon,eht,x,y,z)
- elont = -ylont
- call TOXYZ(ylatt,elont,ehtnew,x1,y1,z1)
- dx = x1 - x
- dy = y1 - y
- dz = z1 - z
- write(I2, 1070) NAME24, latd,latm,slat,latdir,
- 1 latdn,latmn,slatn,latdr,vn,dn,
- 1 lond,lonm,slon,londir,londn,lonmn,slonn,londr,ve,de,
- 1 eht,ehtnew,vu,du, x, x1,vx,dx,
- 1 y, y1,vy,dy, z, z1, vz,dz
- endif
- go to 730
- 750 close(I1, STATUS='KEEP')
- close(I2, status = 'KEEP')
- return
- ELSE
- WRITE(LUOUT,700)
- 700 FORMAT(' Improper entry !'/)
- GO TO 999
- ENDIF
-
- 500 write (*,'(/)')
- write (*,*) "Failed to read answer in UPDATE:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 501 write (*,'(/)')
- write (*,*) "Failed to read OPTION in UPDATE:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 502 write (*,'(/)')
- write (*,*) "Failed to read file name in UPDATE:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 503 write (*,'(/)')
- write (*,*) "Failed to read BBTYPE in UPDATE:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 504 write (*,'(/)')
- write (*,*) "Failed to read input in UPDATE:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- END
-*******************************************************************
- SUBROUTINE GETPO4(IOPT, DATE)
-
-*** Retrieve geodetic coordinates from the blue book
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (nbbdim = 10000)
- CHARACTER JN*1,JW*1
- CHARACTER TYPE*4
- CHARACTER CARD*80
- CHARACTER PIDs*6
-
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
- COMMON /ARRAYS/ HT(nbbdim),LOC(nbbdim),PIDs(nbbdim)
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
-
- DO 100 I = 1, 10000
- LOC(I) = 0
- HT(I) = 0.D0
- 100 CONTINUE
-
- JREC = 0
- 125 READ(I1,130,END=160,err=200,iostat=ios) CARD
- if (ios /= 0) goto 200
- 130 FORMAT(A80)
- TYPE = CARD(7:10)
- IF(TYPE .EQ. '*80*') THEN
- JREC = JREC + 1
- READ(CARD,140,err=201,iostat=ios) ISN,LATD,LATM,SLAT,JN,LOND,
- & LONM,SLON,JW,OH
- if (ios /= 0) goto 201
- 140 FORMAT(BZ,10X,I4,T45,2I2,F7.5,A1,I3,I2,F7.5,A1,F6.2)
- LOC(ISN) = JREC
-C HT(ISN) = HT(ISN) + OH
- IF ( HT(ISN) .EQ. 0.D0 ) HT(ISN) = OH
-c write (*,*) SLAT,SLON,HT(ISN) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- YLAT = (DBLE((LATD*60+LATM)*60)+SLAT)/RHOSEC
- YLON = (DBLE((LOND*60+LONM)*60)+SLON)/RHOSEC
- IF(JN .EQ. 'S') YLAT = -YLAT
- IF(JW .EQ. 'E') YLON = -YLON
-c write (*,*) ylat,ylon !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- call PREDV( ylat, ylon, ht(isn), date, iopt,
- 1 IDG, vn, ve, vu)
-c write (*,*) 'IDG ',IDG !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- IF(IDG .eq. 0) THEN
- WRITE(LUOUT,150) CARD
- 150 FORMAT(' **WARNING** The following point is outside of ',
- 1 'the modeled region.'/
- 2 ' It will be assumed that this point has not moved.'/A80/)
- ENDIF
- WRITE(I4, REC = JREC) YLAT, YLON, VN, VE, VU
-C ELSEIF(TYPE .eq. '*84*') THEN
-C READ(CARD,155) ISN,GH
-C 155 FORMAT(BZ,10X,I4,T70,F6.2)
-C HT(ISN) = HT(ISN) + GH
- ELSEIF(TYPE .eq. '*86*') THEN
- IF(CARD(46:52) .ne. ' ') THEN
- READ(CARD,156,err=202,iostat=ios) ISN, EHT
- if (ios /= 0) goto 202
- 156 FORMAT(BZ,10X,I4,T46,F7.3)
- HT(ISN) = EHT
- ELSE
- READ(CARD,157,err=202,iostat=ios) ISN, OHT, GHT
- if (ios /= 0) goto 202
- 157 FORMAT(BZ,10X,I4,T17,F7.3,T36,F7.3)
- HT(ISN) = OHT + GHT
- ENDIF
- ENDIF
- GO TO 125
- 160 REWIND I1
- RETURN
-
- 200 write (*,'(/)')
- write (*,*) "Failed 1st reading in GETPO4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 201 write (*,'(/)')
- write (*,*) "Failed reading *80* record in GETPO4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 202 write (*,'(/)')
- write (*,*) "Failed reading *86* record in GETPO4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- END
-******************************************************************
- SUBROUTINE GETPO5(IOPT, DATE)
-
-*** Retrieve geodetic position from blue book with 5-digit SSN
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (nbbdim = 10000)
- CHARACTER JN*1,JW*1
- CHARACTER TYPE*3
- CHARACTER CARD*80
- CHARACTER PIDs*6
-
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
- COMMON /ARRAYS/ HT(nbbdim),LOC(nbbdim),PIDs(nbbdim)
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
-
- DO 100 I = 1, 10000
- LOC(I) = 0
- HT(I) = 0.D0
- 100 CONTINUE
-
- JREC = 0
-
- 125 READ(I1,130,END=160,err=200,iostat=ios) CARD
- if (ios /= 0) goto 200
- 130 FORMAT(A80)
- TYPE = CARD(7:9)
- IF(TYPE .EQ. '*80') THEN
- JREC = JREC + 1
- READ(CARD,140,err=201,iostat=ios) ISN,LATD,LATM,SLAT,JN,LOND,
- & LONM,SLON,JW,OH
- if (ios /= 0) goto 200
- 140 FORMAT(BZ, 9X,I5,T45,2I2,F7.5,A1,I3,I2,F7.5,A1,F6.2)
- LOC(ISN) = JREC
-C HT(ISN) = HT(ISN) + OH
- IF ( HT(ISN) .EQ. 0.D0 ) HT(ISN) = OH
- YLAT = (DBLE((LATD*60+LATM)*60)+SLAT)/RHOSEC
- YLON = (DBLE((LOND*60+LONM)*60)+SLON)/RHOSEC
- IF(JN .EQ. 'S') YLAT = -YLAT
- IF(JW .EQ. 'E') YLON = -YLON
- call PREDV( ylat, ylon, ht(isn), date, iopt,
- 1 idg, vn, ve, vu)
- IF(IDG .eq. 0) THEN
- WRITE(LUOUT,150) CARD
- 150 FORMAT(' **WARNING** The following point is outside of ',
- 1 'the modeled region.'/
- 2 ' It will be assumed that this point has not moved.'/A80/)
- ENDIF
- WRITE(I4, REC = JREC) YLAT, YLON, VN, VE, VU
-C ELSEIF(TYPE .eq. '*84') THEN
-C READ(CARD,155) ISN,GH
-C 155 FORMAT(BZ, 9X,I5,T70,F6.2)
-C HT(ISN) = HT(ISN) + GH
- ELSEIF(TYPE .eq. '*86') THEN
- IF(CARD(46:52) .ne. ' ') THEN
- READ(CARD,156,err=202,iostat=ios) ISN, EHT
- if (ios /= 0) goto 202
- 156 FORMAT(BZ, 9X,I5,T46,F7.3)
- HT(ISN) = EHT
- ELSE
- READ(CARD,157,err=202,iostat=ios) ISN, OHT, GHT
- if (ios /= 0) goto 202
- 157 FORMAT(BZ, 9X,I5,T17,F7.3,T36,F7.3)
- HT(ISN) = OHT + GHT
- ENDIF
- ENDIF
- GO TO 125
- 160 REWIND I1
- RETURN
-
- 200 write (*,'(/)')
- write (*,*) "Failed 1st reading in GETPO4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 201 write (*,'(/)')
- write (*,*) "Failed reading *80* record in GETPO4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 202 write (*,'(/)')
- write (*,*) "Failed reading *86* record in GETPO4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- END
-******************************************************************
- SUBROUTINE UPBB4(MIN1,MIN2,OPT,IOPT)
-
-*** Update blue book
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
-
- parameter (nbbdim = 10000)
-
- CHARACTER CARD*80
- CHARACTER DATE*6
- CHARACTER TYPE*4
- CHARACTER OPT*1,JN*1,JW*1
- CHARACTER LATDIR*1, LONDIR*1
- CHARACTER PIDs*6
- LOGICAL TEST, TEST1
- COMMON /ARRAYS/ HT(nbbdim),LOC(nbbdim) ,PIDs(nbbdim)
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
-
-C*** To update classical observations an *12* record
-C*** is needed to identify the correct century, as
-C*** classical observation records contain only a 2-digit year
- IREC12 = 0
-
- 170 READ(I1,175,END=600,err=700,iostat=ios) CARD
- if (ios /= 0) goto 700
- 175 FORMAT(A80)
- TYPE = CARD(7:10)
- IF(TYPE .EQ. '*A1*' .OR.
- 1 TYPE .EQ. '*AA*' .OR.
- 1 TYPE .EQ. '*10*' .OR.
- 1 TYPE .EQ. '*11*' .OR.
- 1 TYPE .EQ. '*13*' .OR.
- 1 TYPE .EQ. '*21*' .OR.
- 1 TYPE .EQ. '*25*' .OR.
- 1 TYPE .EQ. '*26*' .OR.
- 1 TYPE .EQ. '*27*' .OR.
- 1 TYPE .EQ. '*28*' .OR.
- 1 TYPE .EQ. '*29*' ) THEN
- CONTINUE
- ELSEIF(TYPE .EQ. '*31*' .OR.
- 1 TYPE .EQ. '*40*' .OR.
- 1 TYPE .EQ. '*41*' .OR.
- 1 TYPE .EQ. '*42*' .OR.
- 1 TYPE .EQ. '*45*' .OR.
- 1 TYPE .EQ. '*46*' .OR.
- 1 TYPE .EQ. '*47*' .OR.
- 1 TYPE .EQ. '*70*' .OR.
- 1 TYPE .EQ. '*81*' .OR.
- 1 TYPE .EQ. '*82*' .OR.
- 1 TYPE .EQ. '*83*' .OR.
- 1 TYPE .EQ. '*84*' .OR.
- 1 TYPE .EQ. '*85*' .OR.
- 1 TYPE .EQ. '*86*' .OR.
- 1 TYPE .EQ. '*90*') THEN
- CONTINUE
-
- ELSEIF (TYPE .EQ. '*12*') THEN
- IF( CARD(11:14) .EQ. ' ' .OR.
- 1 CARD(17:20) .EQ. ' ') THEN
- WRITE ( LUOUT, 176 )
- 176 FORMAT( ' ERROR: The *12* record does not contain'/
- 1 ' appropriate dates.')
- ELSE
- READ ( CARD, 177,err=701,iostat=ios) IYEAR1, IYEAR2
- if (ios /= 0) goto 701
- 177 FORMAT ( 10X, I4, 2X, I4)
- IF ( (IYEAR2 - IYEAR1) .LT. 0 .OR.
- 1 (IYEAR2 - IYEAR1) .GT. 99 ) THEN
- WRITE (LUOUT, 178)
- 178 FORMAT(' ERROR: The dates in the *12* record are in'/
- 1 ' error. Either they span more than 99 years or '/
- 1 ' the end date preceedes the start date.'/
- 1 ' If they span more than 99 years, then the Bluebook'/
- 1 ' will need to divided into two or more bluebooks'/
- 1 ' with the observations in each spanning no more'/
- 1 ' than 99 years.')
- ELSE
- IREC12 = 1
- ENDIF
- ENDIF
-
-*** Regular distance
-
- ELSEIF(TYPE .EQ. '*50*' .OR.
- 1 TYPE .EQ. '*51*' .OR.
- 1 TYPE .EQ. '*52*') THEN
- IF(OPT .eq. '3' .or. OPT .eq. '4')THEN
- READ(CARD,180,err=702,iostat=ios) ISN,DATE,JSN,OBS
- if (ios /= 0) goto 702
- 180 FORMAT(BZ,10X,I4,T35,A6,T46,I4,T64,F9.4)
- CALL CHECK(ISN,JSN,CARD,TEST)
- IF(TEST) THEN
- CALL TRFDAT(CARD,DATE,IREC12,IYEAR1,IYEAR2,MINO)
- CALL DSDA(LOC(ISN),LOC(JSN),MINO,MIN2,DS,DA)
- IOBS = IDNINT((OBS+DS)*10000.D0)
- WRITE(CARD(64:72),190) IOBS
- 190 FORMAT(I9)
- ENDIF
- ENDIF
-
-*** Azimuth
-
- ELSEIF(TYPE .EQ. '*60*' .OR. TYPE .EQ. '*61*') THEN
- IF(OPT .eq. '3' .or. OPT .eq. '4') THEN
- READ(CARD,200,err=703,iostat=ios)ISN,DATE,JSN,IDEG,MIN,SEC
- if (ios /= 0) goto 703
- 200 FORMAT(BZ,10X,I4,T40,A6,T51,I4,T64,I3,I2,F3.1)
- CALL CHECK(ISN,JSN,CARD,TEST)
- IF(TEST) THEN
- CALL TRFDAT(CARD,DATE,IREC12, IYEAR1, IYEAR2, MINO)
- CALL DSDA(LOC(ISN),LOC(JSN),MINO,MIN2,DS,DA)
- OBS = (DBLE((IDEG*60+MIN)*60)+SEC)/RHOSEC
- OBS = OBS + DA
- IF(OBS .GE. TWOPI) THEN
- OBS = OBS - TWOPI
- ELSEIF(OBS .LT. 0.D0) THEN
- OBS = OBS + TWOPI
- ENDIF
- CALL TODMSS(OBS,IDEG,MIN,SEC,ISIGN)
- ISEC = IDNINT(SEC*10.D0)
- WRITE(CARD(64:71),210) IDEG,MIN,ISEC
- 210 FORMAT(I3,I2.2,I3.3)
- ENDIF
- ENDIF
-
-*** Direction observation
-
- ELSEIF(TYPE .EQ. '*20*') THEN
- IF(OPT .eq. '3' .or. OPT .eq. '4') THEN
- READ(CARD,220,err=704,iostat=ios) ISN0,LIST0,DATE,JSN
- if (ios /= 0) goto 704
- 220 FORMAT(BZ,10X,I4,I2,T40,A6,T51,I4)
- CALL CHECK(ISN0,JSN,CARD,TEST)
- CALL TRFDAT(CARD,DATE,IREC12, IYEAR1, IYEAR2, MINO)
- IF(TEST) THEN
- CALL DSDA(LOC(ISN0),LOC(JSN),MINO,MIN2,DS,DA0)
- ELSE
- DA0 = 0.D0
- ENDIF
- ENDIF
- ELSEIF(TYPE .EQ. '*22*') THEN
- IF(OPT .eq. '3' .or. OPT .eq. '4') THEN
- READ(CARD,230,err=705,iostat=ios) ISN,LIST,JSN,IDEG,MIN,SEC
- if (ios /= 0) goto 705
- 230 FORMAT(BZ,10X,I4,I2,T51,I4,T64,I3,I2,F4.2)
- IF(LIST.NE.LIST0 .OR. ISN.NE.ISN0) THEN
- WRITE(LUOUT,240) CARD
- 240 FORMAT(' Blue-book file has incorrect structure.'/
- 1 ' A *22* record disagrees with its corresponding'/
- 2 ' *20* record. The record reads:'/A80)
- STOP
- ENDIF
- CALL CHECK(ISN,JSN,CARD,TEST)
- IF(TEST) THEN
- CALL DSDA(LOC(ISN),LOC(JSN),MINO,MIN2,DS,DA)
- OBS=(DBLE((IDEG*60+MIN)*60)+SEC)/RHOSEC
- OBS = OBS + DA - DA0
- IF(OBS .GT. TWOPI) THEN
- OBS = OBS - TWOPI
- ELSEIF(OBS .LT. 0.D0) THEN
- OBS = OBS + TWOPI
- ENDIF
- CALL TODMSS(OBS,IDEG,MIN,SEC,ISIGN)
- ISEC = IDNINT(SEC*100.D0)
- WRITE(CARD(64:72),250) IDEG,MIN,ISEC
- 250 FORMAT(I3.3,I2.2,I4.4)
- ENDIF
- ENDIF
-
-*** Long distance
-
- ELSEIF(TYPE .EQ. '*53*' .OR.
- 1 TYPE .EQ. '*54*') THEN
- IF(OPT .eq. '3' .or. OPT .eq. '4') THEN
- READ(CARD,260,err=706,iostat=ios) ISN,DATE,JSN,OBS
- if (ios /= 0) goto 706
- 260 FORMAT(BZ,10X,I4,T35,A6,T46,I4,T64,F10.3)
- CALL CHECK(ISN,JSN,CARD,TEST)
- IF(TEST) THEN
- CALL TRFDAT(CARD,DATE,IREC12, IYEAR1, IYEAR2, MINO)
- CALL DSDA(LOC(ISN),LOC(JSN),MINO,MIN2,DS,DA)
- IOBS = IDNINT((OBS + DS)*1000.D0)
- WRITE(CARD(64:73),270) IOBS
- 270 FORMAT(I10)
- ENDIF
- ENDIF
-
-*** Horizontal angle
-
- ELSEIF(TYPE .EQ. '*30*' .OR.
- 1 TYPE .EQ. '*32*') THEN
- IF(OPT .eq. '3' .or. OPT .eq. '4') THEN
- READ(CARD,280,err=707,iostat=ios) ISN,JSN,IDEG,MIN,SEC,KSN
- if (ios /= 0) goto 707
- 280 FORMAT(BZ,10X,I4,T51,I4,T64,I3,I2,F3.1,I4)
- IF(TYPE.EQ.'*30*') THEN
- DATE = CARD(40:45)
- CALL TRFDAT(CARD,DATE,IREC12, IYEAR1, IYEAR2, MINO)
- ENDIF
- CALL CHECK(ISN,JSN,CARD,TEST)
- CALL CHECK(ISN,KSN,CARD,TEST1)
- IF(TEST .and. TEST1) THEN
- CALL DSDA(LOC(ISN), LOC(JSN),
- 1 MINO, MIN2, DS, DA0)
- CALL DSDA(LOC(ISN), LOC(KSN),
- 1 MINO, MIN2, DS, DA)
- OBS=(DBLE((IDEG*60+MIN)*60)+SEC)/RHOSEC
- OBS = OBS + DA - DA0
- IF(OBS .GE. TWOPI) THEN
- OBS = OBS - TWOPI
- ELSEIF(OBS .LT. 0.D0) THEN
- OBS = OBS + TWOPI
- ENDIF
- CALL TODMSS(OBS,IDEG,MIN,SEC,ISIGN)
- ISEC = IDNINT(SEC*10.D0)
- WRITE(CARD(64:71),290)IDEG,MIN,SEC
- 290 FORMAT(I3.3,I2.2,I3.3)
- ENDIF
- ENDIF
-
-*** position record
-
- ELSEIF(TYPE .EQ. '*80*') THEN
- IF(OPT .eq. '2' .or. OPT .eq. '4') THEN
- READ(CARD,300,err=708,iostat=ios) ISN,LATD,LATM,
- & SLAT,JN,LOND,LONM,SLON,JW
- if (ios /= 0) goto 708
- 300 FORMAT(BZ,10X,I4,T45,2I2,F7.5,A1,I3,I2,F7.5,A1)
- YLAT = (DBLE((LATD*60+LATM)*60)+SLAT)/RHOSEC
- YLON = (DBLE((LOND*60+LONM)*60)+SLON)/RHOSEC
- IF(JN .EQ. 'S') YLAT = -YLAT
- IF(JW .EQ. 'E') YLON = -YLON
-C READ(I4, REC = LOC(ISN)) RLAT, RLON, IDG
- READ(I4, REC = LOC(ISN),err=709,iostat=ios) RLAT,
- & RLON, VN, VE, VU
- if (ios /= 0) goto 709
- call NEWCOR( ylat, ylon, ht(isn), min1, min2,
- 1 ylatt, ylont, ehtnew, dn, de, du, vn, ve, vu)
-C CALL NWCORD(YLAT,YLON,HT(ISN),
-C 1 RLAT,RLON,IDG,MIN1,MIN2,
-C 1 YLATT,YLONT,EHTNEW,DN,DE,DU,IOPT)
- CALL TODMSS(YLATT,LATDN,LATMN,SLATN,ISIGN)
- LATDIR = 'N'
- IF (ISIGN .eq. -1) LATDIR = 'S'
- CALL TODMSS(YLONT,LONDN,LONMN,SLONN,ISIGN)
- LONDIR = 'W'
- IF (ISIGN .eq. -1) LONDIR = 'E'
- LATS = IDNINT(SLATN*100000.D0)
- LONS = IDNINT(SLONN*100000.D0)
- WRITE(CARD(45:56),310) LATDN,LATMN,LATS,LATDIR
- 310 FORMAT(I2,I2.2,I7.7,A1)
- WRITE(CARD(57:69),320) LONDN,LONMN,LONS,LONDIR
- 320 FORMAT(I3,I2.2,I7.7,A1)
- ENDIF
-
-*** Unrecognized blue book record
-
- ELSE
-c WRITE(LUOUT,500) TYPE
- 500 FORMAT(' This software does not recognize an ',A4,/
- 1 ' record. The record will be copied to the new'/
- 2 ' file without change.')
- ENDIF
- WRITE(I2,175) CARD
- GO TO 170
- 600 CONTINUE
- RETURN
-
- 700 write (*,'(/)')
- write (*,*) "Failed to read card in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 701 write (*,'(/)')
- write (*,*) "Failed to read card *12* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 702 write (*,'(/)')
- write (*,*) "Failed to read *50,51,52* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 703 write (*,'(/)')
- write (*,*) "Failed to read *60,61* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 704 write (*,'(/)')
- write (*,*) "Failed to read *20* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 705 write (*,'(/)')
- write (*,*) "Failed to read *22* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 706 write (*,'(/)')
- write (*,*) "Failed to read *53,54* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 707 write (*,'(/)')
- write (*,*) "Failed to read *30,32* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 708 write (*,'(/)')
- write (*,*) "Failed to read *80* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 709 write (*,'(/)')
- write (*,*) "Failed to read I4 of *80* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- END
-***************************************************************
- SUBROUTINE UPBB5(MIN1,MIN2,OPT,IOPT)
-
-*** Update 5-digit blue book
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (nbbdim = 10000)
- CHARACTER CARD*212
- CHARACTER SUBCRD*80
-C CHARACTER DATE*6
- CHARACTER DATE8*8
- CHARACTER TYPE*3
- CHARACTER OPT*1,SIGN*1,JN*1,JW*1
- CHARACTER LATDIR*1,LONDIR*1
- CHARACTER PIDs*6
- LOGICAL TEST
- COMMON /ARRAYS/ HT(nbbdim),LOC(nbbdim) ,PIDs(nbbdim)
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
-
- 170 READ(I1,175,END=600,err=700,iostat=ios) CARD
- if (ios /= 0) goto 700
- 175 FORMAT(A212)
- SUBCRD = CARD(1:80)
- TYPE = CARD(7:9)
- IF(TYPE .EQ. '*A1' .OR.
- 1 TYPE .EQ. '*AA' .OR.
- 1 TYPE .EQ. '*10' .OR.
- 1 TYPE .EQ. '*11' .OR.
- 1 TYPE .EQ. '*12' .OR.
- 1 TYPE .EQ. '*13' .OR.
- 1 TYPE .EQ. '*21' .OR.
- 1 TYPE .EQ. '*25' .OR.
- 1 TYPE .EQ. '*26' .OR.
- 1 TYPE .EQ. '*27' .OR.
- 1 TYPE .EQ. '*28' .OR.
- 1 TYPE .EQ. '*29' ) THEN
- CONTINUE
- ELSEIF(TYPE .EQ. '*31' .OR.
- 1 TYPE .EQ. '*40' .OR.
- 1 TYPE .EQ. '*41' .OR.
- 1 TYPE .EQ. '*42' .OR.
- 1 TYPE .EQ. '*45' .OR.
- 1 TYPE .EQ. '*46' .OR.
- 1 TYPE .EQ. '*47' .OR.
- 1 TYPE .EQ. '*70' .OR.
- 1 TYPE .EQ. '*81' .OR.
- 1 TYPE .EQ. '*82' .OR.
- 1 TYPE .EQ. '*83' .OR.
- 1 TYPE .EQ. '*84' .OR.
- 1 TYPE .EQ. '*85' .OR.
- 1 TYPE .EQ. '*86' .OR.
- 1 TYPE .EQ. '*90') THEN
- CONTINUE
-
-*** Regular distance
-
- ELSEIF(TYPE .EQ. '*50' .OR.
- 1 TYPE .EQ. '*51' .OR.
- 1 TYPE .EQ. '*52') THEN
- IF(OPT .eq. '3' .or. OPT .eq. '4')THEN
-C READ(CARD,180) ISN,DATE,JSN,OBS
-C 180 FORMAT(BZ, 9X,I5,T35,A6,T46,I5,T64,F9.4)
- READ(CARD,180,err=702,iostat=ios) ISN,JSN,OBS,DATE8
- if (ios /= 0) goto 702
- 180 FORMAT(BZ, 9X,I5,T46,I5,T64,F9.4,T101,A8)
- CALL CHECK(ISN,JSN,SUBCRD,TEST)
- IF(TEST) THEN
- CALL TNFDAT(DATE8,MINO)
- CALL DSDA(LOC(ISN),LOC(JSN),MINO,MIN2,DS,DA)
- IOBS = IDNINT((OBS+DS)*10000.D0)
- WRITE(CARD(64:72),190) IOBS
- 190 FORMAT(I9)
- WRITE(CARD(174:181),191) DS
- 191 FORMAT(F8.4)
- ENDIF
- ENDIF
-
-*** Azimuth
-
- ELSEIF(TYPE .EQ. '*60' .OR. TYPE .EQ. '*61') THEN
- IF(OPT .eq. '3' .or. OPT .eq. '4') THEN
-C READ(CARD,200) ISN,DATE,JSN,IDEG,MIN,SEC
-C 200 FORMAT(BZ, 9X,I5,T40,A6,T51,I5,T64,I3,I2,F3.1)
- READ(CARD,200,err=703,iostat=ios) ISN,JSN,IDEG,MIN,
- & SEC,DATE8
- if (ios /= 0) goto 703
- 200 FORMAT(BZ, 9X,I5,T51,I5,T64,I3,I2,F3.1,T101,A8)
- CALL CHECK(ISN,JSN,SUBCRD,TEST)
- IF(TEST) THEN
- CALL TNFDAT(DATE8,MINO)
- CALL DSDA(LOC(ISN),LOC(JSN),MINO,MIN2,DS,DA)
- OBS = (DBLE((IDEG*60+MIN)*60)+SEC)/RHOSEC
- OBS = OBS + DA
- IF(OBS .GE. TWOPI) THEN
- OBS = OBS - TWOPI
- ELSEIF(OBS .LT. 0.D0) THEN
- OBS = OBS + TWOPI
- ENDIF
- CALL TODMSS(OBS,IDEG,MIN,SEC,ISIGN)
- ISEC = IDNINT(SEC*10.D0)
- WRITE(CARD(64:71),210) IDEG,MIN,ISEC
- 210 FORMAT(I3,I2.2,I3.3)
- IF(DA .GE. 0.0D0) THEN
- SIGN = ' '
- ELSE
- SIGN = '-'
- ENDIF
- ANGLE = DABS(DA)
- CALL TODMSS(ANGLE,IDEG,MIN,SEC,ISIGN)
- ISEC1 = SEC
- ISEC2 = IDNINT((SEC - DBLE(ISEC1)) * 100.D0)
- WRITE(CARD(152:162),211)SIGN,IDEG,MIN,ISEC1,ISEC2
- 211 FORMAT(A1,I3.3,I2.2,I2.2,'.',I2.2)
- ENDIF
- ENDIF
-
-*** Direction observation
-
- ELSEIF(TYPE .EQ. '*20') THEN
- IF(OPT .eq. '3' .or. OPT .eq. '4') THEN
-C READ(CARD,220) ISN0,LIST0,DATE,JSN
-C 220 FORMAT(BZ, 9X,I5,I2,T40,A6,T51,I5)
- READ(CARD,220,err=704,iostat=ios) ISN0,LIST0,JSN,DATE8
- if (ios /= 0) goto 704
- 220 FORMAT(BZ, 9X,I5,I2,T51,I5,T101,A8)
- CALL CHECK(ISN0,JSN,SUBCRD,TEST)
- CALL TNFDAT(DATE8,MINO)
- IF(TEST) THEN
- CALL DSDA(LOC(ISN0),LOC(JSN),MINO,MIN2,DS,DA0)
- ELSE
- DA0 = 0.D0
- ENDIF
- CARD(132:142) = ' 0000000.00'
- ENDIF
- ELSEIF(TYPE .EQ. '*22') THEN
- IF(OPT .eq. '3' .or. OPT .eq. '4') THEN
- READ(CARD,230,err=705,iostat=ios) ISN,LIST,JSN,IDEG,
- & MIN,SEC
- if (ios /= 0) goto 705
- 230 FORMAT(BZ, 9X,I5,I2,T51,I5,T64,I3,I2,F4.2)
- IF(LIST.NE.LIST0 .OR. ISN.NE.ISN0) THEN
- WRITE(LUOUT,240) CARD
- 240 FORMAT(' Blue-book file has incorrect structure.'/
- 1 ' A *22* record disagrees with its corresponding'/
- 2 ' *20* record. The record reads:'/A212)
- STOP
- ENDIF
- CALL CHECK(ISN,JSN,SUBCRD,TEST)
- IF(TEST) THEN
- CALL DSDA(LOC(ISN),LOC(JSN),MINO,MIN2,DS,DA)
- ELSE
- DA = 0.D0
- ENDIF
- OBS=(DBLE((IDEG*60+MIN)*60)+SEC)/RHOSEC
- OBS = OBS + DA - DA0
- IF(OBS .GT. TWOPI) THEN
- OBS = OBS - TWOPI
- ELSEIF(OBS .LT. 0.D0) THEN
- OBS = OBS + TWOPI
- ENDIF
- CALL TODMSS(OBS,IDEG,MIN,SEC,ISIGN)
- ISEC = IDNINT(SEC*100.D0)
- WRITE(CARD(64:72),250) IDEG,MIN,ISEC
- 250 FORMAT(I3.3,I2.2,I4.4)
- IF((DA-DA0) .GE. 0.D0) THEN
- SIGN = ' '
- ELSE
- SIGN = '-'
- ENDIF
- ANGLE = DABS(DA - DA0)
- CALL TODMSS(ANGLE,IDEG,MIN,SEC,ISIGN)
- ISEC1 = SEC
- ISEC2 = IDNINT((SEC-DBLE(ISEC1))*100.D0)
- WRITE(CARD(132:142),251) SIGN,IDEG,MIN,ISEC1,ISEC2
- 251 FORMAT(A1,I3.3,I2.2,I2.2,'.',I2.2)
- ENDIF
-
-*** Long distance
-
- ELSEIF(TYPE .EQ. '*53' .OR.
- 1 TYPE .EQ. '*54') THEN
- IF(OPT .eq. '3' .or. OPT .eq. '4') THEN
-C READ(CARD,260) ISN,DATE,JSN,OBS
-C 260 FORMAT(BZ, 9X,I5,T35,A6,T46,I5,T64,F10.3)
- READ(CARD,260,err=706,iostat=ios) ISN,JSN,OBS,DATE8
- if (ios /= 0) goto 706
- 260 FORMAT(BZ, 9X,I5,T46,I5,T64,F10.3,T101,A8)
- CALL CHECK(ISN,JSN,SUBCRD,TEST)
- IF(TEST) THEN
- CALL TNFDAT(DATE8,MINO)
- CALL DSDA(LOC(ISN),LOC(JSN),MINO,MIN2,DS,DA)
- IOBS = IDNINT((OBS + DS)*1000.D0)
- WRITE(CARD(64:73),270) IOBS
- 270 FORMAT(I10)
- CORR = IDNINT(DS*10000.D0)
- WRITE(CARD(174:181),271) CORR
- 271 FORMAT(F8.4)
- ENDIF
- ENDIF
-
-*** position record
-
- ELSEIF(TYPE .EQ. '*80') THEN
- IF(OPT .eq. '2' .or. OPT .eq. '4') THEN
- READ(CARD,300,err=708,iostat=ios) ISN,LATD,LATM,
- & SLAT,JN,LOND,LONM,SLON,JW
- if (ios /= 0) goto 708
- 300 FORMAT(BZ,9X,I5,T45,2I2,F7.5,A1,I3,I2,F7.5,A1)
- YLAT = (DBLE((LATD*60+LATM)*60)+SLAT)/RHOSEC
- YLON = (DBLE((LOND*60+LONM)*60)+SLON)/RHOSEC
- IF(JN .EQ. 'S') YLAT = -YLAT
- IF(JW .EQ. 'E') YLON = -YLON
-C READ(I4, REC = LOC(ISN)) RLAT, RLON, IDG
-C CALL NWCORD(YLAT,YLON,HT(ISN),
-C 1 RLAT,RLON,IDG,MIN1,MIN2,
-C 1 YLATT,YLONT,EHTNEW,DN,DE,DU,IOPT)
- READ(I4, REC = LOC(ISN),err=709,iostat=ios) RLAT, RLON,
- & VN, VE, VU
- if (ios /= 0) goto 709
- call NEWCOR( ylat, ylon, ht(isn), min1, min2,
- 1 ylatt, ylont, ehtnew, dn, de, du, vn, ve, vu)
- CALL TODMSS(YLATT,LATDN,LATMN,SLATN,ISIGN)
- LATDIR = 'N'
- IF (ISIGN .eq. -1) LATDIR = 'S'
- CALL TODMSS(YLONT,LONDN,LONMN,SLONN,ISIGN)
- LONDIR = 'W'
- IF (ISIGN .eq. -1) LONDIR = 'E'
- LATS = IDNINT(SLATN*100000.D0)
- LONS = IDNINT(SLONN*100000.D0)
- WRITE(CARD(45:56),310) LATDN,LATMN,LATS,LATDIR
- 310 FORMAT(I2,I2.2,I7.7,A1)
- WRITE(CARD(57:69),320) LONDN,LONMN,LONS,LONDIR
- 320 FORMAT(I3,I2.2,I7.7,A1)
- ENDIF
-
-*** Unrecognized blue book record
-
- ELSE
- WRITE(LUOUT,500) TYPE
- 500 FORMAT(' This software does not recognize an ',A3,/
- 1 ' record. The record will be copied to the new'/
- 2 ' file without change.')
- ENDIF
- WRITE(I2,175) CARD
- GO TO 170
- 600 CONTINUE
- RETURN
-
- 700 write (*,'(/)')
- write (*,*) "Failed to read card in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 701 write (*,'(/)')
- write (*,*) "Failed to read card *12* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 702 write (*,'(/)')
- write (*,*) "Failed to read *50,51,52* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 703 write (*,'(/)')
- write (*,*) "Failed to read *60,61* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 704 write (*,'(/)')
- write (*,*) "Failed to read *20* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 705 write (*,'(/)')
- write (*,*) "Failed to read *22* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 706 write (*,'(/)')
- write (*,*) "Failed to read *53,54* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 707 write (*,'(/)')
- write (*,*) "Failed to read *30,32* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 708 write (*,'(/)')
- write (*,*) "Failed to read *80* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 709 write (*,'(/)')
- write (*,*) "Failed to read I4 of *80* in UPBB4:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- END
-***************************************************************
- SUBROUTINE CHECK(ISN,JSN,CARD,TEST)
-
-*** Check if stations have *80* records
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (nbbdim = 10000)
- CHARACTER CARD*80
- CHARACTER PIDs*6
- LOGICAL TEST
- COMMON /ARRAYS/ HT(nbbdim),LOC(nbbdim),PIDs(nbbdim)
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
-
- TEST = .TRUE.
-
- IF(LOC(ISN) .eq. 0) THEN
- WRITE(LUOUT,100) ISN, CARD
- 100 FORMAT(' No *80* record for SSN = ',I4/A80/)
- TEST = .FALSE.
- ENDIF
-
- IF(LOC(JSN) .eq. 0) THEN
- WRITE(LUOUT,100) JSN, CARD
- TEST = .FALSE.
- ENDIF
-
- RETURN
- END
-C*************************************************
- SUBROUTINE UPGFI4(DATE2, MIN2, IOPT, KOPT,
- * MONTH, IDAY, IYEAR)
-
-*** Update G-FILE of blue book
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
-c CHARACTER*80 CARD
- CHARACTER CARD*120
- CHARACTER TYPE*1
- CHARACTER NRF*2
- CHARACTER ZT*2
- CHARACTER CHAR14*14
- LOGICAL TEST
- LOGICAL Is_inp_NAD83,Is_out_NAD83,Is_out1_NAD83
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
-
- ZT = 'ZT'
-
-*** Obtain blue-book reference frame identifier
-*** corresponding to KOPT (output frame for vectors)
- IF (KOPT .NE. -1) THEN
- CALL RFCON1(KOPT, NBBREF)
- WRITE(NRF,10) NBBREF
- 10 FORMAT(I2.2)
- ENDIF
-
- 90 READ(I1,100,END=200,err=300,iostat=ios) CARD
- if (ios /= 0) goto 300
-c 100 FORMAT(A80)
- 100 FORMAT(A120)
- TYPE = CARD(1:1)
- IF(TYPE .eq. 'A') THEN
- IF (CARD(79:80) .EQ. ZT) THEN
- WRITE(LUOUT, 103)
- 103 FORMAT(
- 1 ' *****************************************************'/
- 1 ' * ERROR: The input GFILE contains the letters, ZT, *'/
- 1 ' * in columns 79-80 of its A-record. This indicates *'/
- 1 ' * that the GPS vectors in this file have already *'/
- 1 ' * been updated to a common date. This software *'/
- 1 ' * will not further modify the GPS vectors. *'/
- 1 ' *****************************************************'/)
- RETURN
- ENDIF
- WRITE(CARD(79:80),101) ZT
- 101 FORMAT(A2)
- WRITE(CARD(4:11), 102) IYEAR, MONTH, IDAY
- 102 FORMAT(I4, I2.2, I2.2)
- WRITE(CARD(12:19), 102) IYEAR, MONTH, IDAY
-
- ELSEIF(TYPE .eq. 'B') THEN
- READ(CARD,110,err=301,iostat=ios)IYEAR1,MONTH1,IDAY1,
- 1 IYEAR2,MONTH2,IDAY2,IBBREF
- if (ios /= 0) goto 301
- 110 FORMAT(1X,I4,I2,I2,4X,I4,I2,I2,30X,I2)
-C CALL TOTIME(IYEAR1,MONTH1,IDAY1,MINO1)
-C CALL TOTIME(IYEAR1, 1, 1, MIN00)
-C DECYR1 = DBLE(IYEAR1) + DBLE(MINO1 - MIN00)/525600.D0
-C CALL TOTIME(IYEAR2,MONTH2,IDAY2,MINO2)
-C CALL TOTIME(IYEAR2, 1, 1, MIN00)
-C DECYR2 = DBLE(IYEAR2) + DBLE(MINO2 - MIN00)/525600.D0
-
- CALL IYMDMJ(IYEAR1,MONTH1,IDAY1,MJD1)
- MINO1 = MJD1 * 24 * 60
- CALL IYMDMJ(IYEAR1, 1, 1, MJD0)
- DECYR1 = DBLE(IYEAR1) + DBLE(MJD1 - MJD0)/365.D0
- CALL IYMDMJ(IYEAR2,MONTH2,IDAY2, MJD2)
- MINO2 = MJD2 * 24 * 60
- CALL IYMDMJ(IYEAR2, 1, 1, MJD0)
- DECYR2 = DBLE(IYEAR2) + DBLE(MJD2 - MJD0)/365.D0
- MINO = (MINO1 + MINO2) / 2
- DECYR = (DECYR1 + DECYR2) / 2.D0
- CALL RFCON(IBBREF, JREF) !JREF is the current frame or frame of input
- IF (KOPT .NE. -1) THEN
- CARD(52:53) = NRF
- ENDIF
- Is_inp_NAD83 = (JREF == 1)
- Is_out_NAD83 = (IOPT == 1) !IOPT is the frame of the positions
- Is_out1_NAD83 = (KOPT == 1) !IOPT is the frame of the positions
- ELSEIF(TYPE .eq. 'C') THEN
- READ(CARD,120,err=302,iostat=ios)ISN,JSN,DX,DY,DZ
- if (ios /= 0) goto 302
- 120 FORMAT(BZ,1X,2I4,F11.4,5X,F11.4,5X,F11.4)
-
- CALL CHECK(ISN, JSN, CARD, TEST)
- IF (TEST) THEN
- CALL DDXYZ(ISN, JSN,
- 1 MINO, MIN2, DDX, DDY, DDZ)
-*** Convert vector from JREF to IOPT frame
- if (Is_inp_NAD83 .or. Is_out_NAD83) then
- call TRAVEC (DX, DY, DZ, DECYR, JREF, IOPT)
- else
- call TRAVEC_IERS (DX, DY, DZ, DECYR, JREF, IOPT)
- endif
- DX = DX + DDX
- DY = DY + DDY
- DZ = DZ + DDZ
-
-*** Convert GPS vector from IOPT to KOPT reference frame
- IF (KOPT .NE. -1) THEN
- if (Is_out_NAD83 .or. Is_out1_NAD83) then
- CALL TRAVEC(DX, DY, DZ, DATE2, IOPT, KOPT)
- else
- CALL TRAVEC_IERS(DX, DY, DZ, DATE2, IOPT, KOPT)
- endif
- ELSE
- if (Is_inp_NAD83 .or. Is_out_NAD83) then
- CALL TRAVEC(DX, DY, DZ, DATE2, IOPT, JREF)
- else
- CALL TRAVEC_IERS(DX, DY, DZ, DATE2, IOPT, JREF)
- endif
- ENDIF
-
-*** Rewrite GPS observational record
- CALL TOCHAR(DX,CHAR14)
- CARD(10:20) = CHAR14(3:13)
-
- CALL TOCHAR(DY,CHAR14)
- CARD(26:36) = CHAR14(3:13)
-
- CALL TOCHAR(DZ,CHAR14)
- CARD(42:52) = CHAR14(3:13)
- ENDIF
-
- ELSEIF(TYPE .eq. 'F') THEN
- READ(CARD,140,err=303,iostat=ios)ISN,JSN,DX,DY,DZ
- if (ios /= 0) goto 303
- 140 FORMAT(BZ,1X,2I4,F13.4,5X,F13.4,5X,F13.4)
-
- CALL CHECK(ISN, JSN, CARD, TEST)
- IF (TEST) THEN
- CALL DDXYZ(ISN, JSN,
- 1 MINO, MIN2, DDX, DDY, DDZ)
-
- if (Is_inp_NAD83 .or. Is_out_NAD83) then
- call TRAVEC( DX, DY, DZ, DECYR, JREF, IOPT)
- else
- call TRAVEC_IERS( DX, DY, DZ, DECYR, JREF, IOPT)
- endif
-
- DX = DX + DDX
- DY = DY + DDY
- DZ = DZ + DDZ
-
-*** Convert GPS vector to output reference frame
- IF (KOPT .NE. -1) THEN
- if (Is_out_NAD83 .or. Is_out1_NAD83) then
- CALL TRAVEC(DX, DY, DZ, DATE2, IOPT, KOPT)
- else
- CALL TRAVEC_IERS (DX, DY, DZ, DATE2, IOPT, KOPT)
- endif
- ELSE
- if (Is_out_NAD83 .or. Is_out1_NAD83) then
- CALL TRAVEC(DX, DY, DZ, DATE2, IOPT, JREF)
- else
- CALL TRAVEC_IERS (DX, DY, DZ, DATE2, IOPT, JREF)
- endif
- ENDIF
-
-*** Rewrite GPS observational record
- CALL TOCHAR(DX,CHAR14)
- CARD(10:22) = CHAR14(1:13)
-
- CALL TOCHAR(DY,CHAR14)
- CARD(28:40) = CHAR14(1:13)
-
- CALL TOCHAR(DZ,CHAR14)
- CARD(46:58) = CHAR14(1:13)
- ENDIF
- ENDIF
- WRITE(I2,100) CARD
- GO TO 90
- 200 CONTINUE
- RETURN
-
- 300 write (*,'(/)')
- write (*,*) "Failed to read gfile in UPGFIG:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 301 write (*,'(/)')
- write (*,*) "Failed to read B card in UPGFIG:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 302 write (*,'(/)')
- write (*,*) "Failed to read C card in UPGFIG:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 303 write (*,'(/)')
- write (*,*) "Failed to read F card in UPGFIG:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- END
-*********************************************************
- SUBROUTINE UPGFI5(DATE2, MIN2, IOPT, KOPT,
- * MONTH, IDAY, IYEAR)
-
-*** Update G-FILE of 5-digit blue book
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- CHARACTER CARD*180
- CHARACTER SUBCRD*80
- CHARACTER TYPE*1
- CHARACTER NRF*2
- CHARACTER ZT*2
- CHARACTER CHAR14*14
- LOGICAL TEST
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
-
- ZT = 'ZT'
-
-*** Obtain blue-book reference frame identifier
-*** corresponding to IOPT
- IF (KOPT .NE. -1) THEN
- CALL RFCON1(KOPT, NBBREF)
- WRITE(NRF, 10) NBBREF
- 10 FORMAT(I2.2)
- ENDIF
-
- 90 READ(I1,100,END=200,err=300,iostat=ios) CARD
- if (ios /= 0) goto 300
- 100 FORMAT(A180)
- TYPE = CARD(1:1)
-
- IF (TYPE .eq. 'A') THEN
- IF (CARD(79:80) .EQ. ZT) THEN
- WRITE(LUOUT, 103)
- 103 FORMAT(
- 1 ' *****************************************************'/
- 1 ' * ERROR: The input GFILE contains the letters, ZT, *'/
- 1 ' * in columns 79-80 of its A-record. This indicates *'/
- 1 ' * that the GPS vectors in this file have already *'/
- 1 ' * been updated to a common date. This software *'/
- 1 ' * will not further modify the GPS vectors. *'/
- 1 ' *****************************************************'/)
- RETURN
- ENDIF
- WRITE(CARD(79:80), 101) ZT
- 101 FORMAT(A2)
- WRITE(CARD(4:11), 102) IYEAR, MONTH, IDAY
- 102 FORMAT(I4, I2.2, I2.2)
- WRITE(CARD(12:19), 102) IYEAR, MONTH, IDAY
-
- ELSEIF(TYPE .eq. 'B') THEN
- READ(CARD,110,err=301,iostat=ios)IYEAR1,MONTH1,IDAY1,
- 1 IYEAR2,MONTH2,IDAY2,IBBREF
- if (ios /= 0) goto 301
- 110 FORMAT(1X,I4,I2,I2,4X,I4,I2,I2,30X,I2)
-C CALL TOTIME(IYEAR1,MONTH1,IDAY1,MINO1)
-C CALL TOTIME(IYEAR1, 1, 1, MIN00)
-C DECYR1 = DBLE(IYEAR1) + DBLE(MINO1 - MIN00)/525600.D0
-C CALL TOTIME(IYEAR2,MONTH2,IDAY2,MINO2)
-C CALL TOTIME(IYEAR2, 1, 1, MIN00)
- CALL IYMDMJ(IYEAR1,MONTH1,IDAY1,MJD1)
- MINO1 = MJD1 * 24 * 60
- CALL IYMDMJ(IYEAR1, 1, 1, MJD0)
- DECYR1 = DBLE(IYEAR1) + DBLE(MJD1 - MJD0)/365.D0
- CALL IYMDMJ(IYEAR2, MONTH2,IDAY2, MJD2)
- MINO2 = MJD2 * 24 * 60
- CALL IYMDMJ(IYEAR2, 1, 1, MJD0)
- DECYR2 = DBLE(IYEAR2) + DBLE(MJD2 - MJD0)/365.D0
-C DECYR2 = DBLE(IYEAR2) + DBLE(MINO2 - MIN00)/525600.D0
- MINO = (MINO1 + MINO2) / 2
- DECYR = (DECYR1 + DECYR2) / 2.D0
- CALL RFCON(IBBREF, JREF)
- IF (KOPT .NE. -1) THEN
- CARD(52:53) = NRF
- ENDIF
-
- ELSEIF(TYPE .eq. 'F') THEN
- READ(CARD,140,err=303,iostat=ios)ISN,DX,DY,DZ,JSN
- if (ios /= 0) goto 303
- 140 FORMAT(BZ,1X,I5,3X,F13.4,5X,F13.4,5X,F13.4,T81,I5)
-
- SUBCRD = CARD(1:80)
- CALL CHECK(ISN, JSN, SUBCRD, TEST)
- IF (TEST) THEN
- CALL DDXYZ(ISN, JSN,
- 1 MINO,MIN2,DDX, DDY, DDZ)
-
- call TRAVEC( DX, DY, DZ, DECYR, JREF, IOPT)
-
- DX = DX + DDX
- DY = DY + DDY
- DZ = DZ + DDZ
-
-*** Convert GPS vector to outout reference frame
- IF (KOPT .NE. -1) THEN
- CALL TRAVEC(DX, DY, DZ, DATE2, IOPT, KOPT)
- ELSE
- CALL TRAVEC(DX, DY, DZ, DATE2, IOPT, JREF)
- ENDIF
-
-*** Rewrite GPS observational record
- CALL TOCHAR(DX,CHAR14)
- CARD(10:22) = CHAR14(1:13)
-
- CALL TOCHAR(DY,CHAR14)
- CARD(28:40) = CHAR14(1:13)
-
- CALL TOCHAR(DZ,CHAR14)
- CARD(46:58) = CHAR14(1:13)
-
- ISHIFT = IDNINT(DDX * 10000.D0)
- WRITE(CARD(115:121),150) ISHIFT
- 150 FORMAT(I7)
-
- ISHIFT = IDNINT(DDY * 10000.D0)
- WRITE(CARD(125:131),150) ISHIFT
-
- ISHIFT = IDNINT(DDZ * 10000.D0)
- WRITE(CARD(135:141),150) ISHIFT
- ENDIF
-
- ENDIF
- WRITE(I2,100) CARD
- GO TO 90
- 200 CONTINUE
- RETURN
-
- 300 write (*,'(/)')
- write (*,*) "Failed to read gfile in UPGFIG:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 301 write (*,'(/)')
- write (*,*) "Failed to read B card in UPGFIG:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 302 write (*,'(/)')
- write (*,*) "Failed to read C card in UPGFIG:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 303 write (*,'(/)')
- write (*,*) "Failed to read F card in UPGFIG:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- END
-*********************************************************
- SUBROUTINE TODMSS(val,id,im,s,isign)
-
-*** convert position radians to deg,min,sec
-*** range is [-twopi to +twopi]
-
- implicit double precision(a-h,o-z)
- IMPLICIT INTEGER*4 (I-N)
- common/CONST/A,F,E2,EP2,AF,PI,TWOPI,RHOSEC
-
- 1 if(val.gt.twopi) then
- val=val-twopi
- go to 1
- endif
-
- 2 if(val.lt.-twopi) then
- val=val+twopi
- go to 2
- endif
-
- if(val.lt.0.d0) then
- isign=-1
- else
- isign=+1
- endif
-
- s=dabs(val*RHOSEC/3600.D0)
- id=idint(s)
- s=(s-id)*60.d0
- im=idint(s)
- s=(s-im)*60.d0
-
-*** account for rounding error
-
- is=idnint(s*1.d5)
- if(is.ge.6000000) then
- s=0.d0
- im=im+1
- endif
- if(im.ge.60) then
- im=0
- id=id+1
- endif
-
- return
- end
-*********************************************************
- SUBROUTINE SETRF
-
-*** Specify arrays that may be used to convert
-*** a reference frame identifier in the blue book
-*** to a reference frame identifier in HTDP and back
-
- IMPLICIT INTEGER*4 (I-N)
- parameter ( numref = 16 )
- COMMON /REFCON/ IRFCON(36), JRFCON(numref)
-
-*** From blue book identifier to HTDP indentifier
-*** WGS 72 Precise
-c IRFCON(1) = 10
- IRFCON(1) = 1
-C HTDP no longer supports WGS 72. Hence, if a BlueBook
-C file contains WGS 72 coordinates, HTDP treats these
-C coordinates as if they were NAD 83(2011)coordinates.
-
-*** WGS 84 (orig) Precise (set equal to NAD 83)
- IRFCON(2) = 1
-
-*** WGS 72 Broadcast
-c IRFCON(3) = 10
- IRFCON(3) = 1
-C HTDP no longer supports WGS 72. Hence, if a BlueBook
-C file contains WGS 72 coordinates, HTDP treats these
-C coordinates as if they were NAD 83(2011)coordinates.
-
-*** WGS 84 (orig) Broadcast (set equal to NAD 83)
- IRFCON(4) = 1
-
-*** ITRF89
- IRFCON(5) = 3
-
-*** PNEOS 90 or NEOS 91.25 (set equal to ITRF90)
- IRFCON(6) = 4
-
-*** NEOS 90 (set equal to ITRF90)
- IRFCON(7) = 4
-
-*** ITRF91
- IRFCON(8) = 5
-
-*** SIO/MIT 92.57 (set equal to ITRF91)
- IRFCON(9) = 5
-
-*** ITRF91
- IRFCON(10) = 5
-
-*** ITRF92
- IRFCON(11) = 6
-
-*** ITRF93
- IRFCON(12) = 7
-
-*** WGS 84 (G730) Precise (set equal to ITRF91)
- IRFCON(13) = 5
-
-*** WGS 84 (G730) Broadcast (set equal to ITRF91)
- IRFCON(14) = 5
-
-*** ITRF94
- IRFCON(15) = 8
-
-*** WGS 84 (G873) Precise (set equal to ITRF94)
- IRFCON(16) = 8
-
-*** WGS 84 (G873) Broadcast (set equal to ITRF94)
- IRFCON(17) = 8
-
-*** ITRF96
- IRFCON(18) = 8
-
-*** ITRF97
- IRFCON(19) = 9
-
-*** IGS97
- IRFCON(20) = 9
-
-*** ITRF00
- IRFCON(21) = 11
-
-*** IGS00
- IRFCON(22) = 11
-
-*** WGS 84 (G1150)
- IRFCON(23) = 11
-
-*** IGb00
- IRFCON(24) = 11
-
-*** ITRF2005
- IRFCON(25) = 14
-
-*** IGS05
- IRFCON(26) = 14
-
-*** IGS08
- IRFCON(27) = 15
-
-*** IGB08
- IRFCON(28) = 15
-
-*** ITRF2008
- IRFCON(29) = 15
-
-*** WGS84 (G1674)
- IRFCON(30) = 15
-
-*** WGS84 (G1762)
- IRFCON(31) = 15
-
-*** ITRF2014
- IRFCON(32) = 16
-
-*** IGB14
- IRFCON(33) = 16
-
-*** NAD83 (2011/2007/CORS96/FBN/HARN)
- IRFCON(34) = 1
-
-*** NAD83 (PA11)
- IRFCON(35) = 12
-
-*** NAD83 (MA11)
- IRFCON(36) = 13
-
-*** From HTDP identifier to blue book identifier
-*** NAD 83 (set equal to WGS 84 (transit))
-c JRFCON(1) = 2
- JRFCON(1) = 34
-
-*** ITRF88 (set equal to ITRF89)
- JRFCON(2) = 5
-
-*** ITRF89
- JRFCON(3) = 5
-
-*** ITRF90 (set equal to NEOS 90)
- JRFCON(4) = 7
-
-*** ITRF91
- JRFCON(5) = 8
-
-*** ITRF92
- JRFCON(6) = 11
-
-*** ITRF93
- JRFCON(7) = 12
-
-*** ITRF96 (= ITRF94)
- JRFCON(8) = 18
-
-*** ITRF97
- JRFCON(9) = 19
-
-*** WGS 72
- JRFCON(10) = 1
-
-*** ITRF00
- JRFCON(11) = 21
-
-*** NAD 83 (PACP00) or NAD 83 (PA11)
-c JRFCON(12) = 0
-c JRFCON(12) = 2
- JRFCON(12) = 35
-C Michael Dennis requested that HTDP identify
-C NAD 83 (PA11) coordinates as WGS 84(transit)
-C coordinates in the Bluebook context
-
-*** NAD 83 (MARP00) or NAD 83 (MA11)
-c JRFCON(13) = 0
-c JRFCON(13) = 2
- JRFCON(13) = 36
-C Michael Dennis requested that HTDP identify
-C NAD 83 (MA11) coordinates as WGS 84(transit)
-C coordinates in the Bluebook context
-
-*** ITRF2005 or IGS05
- JRFCON(14) = 26
-
-*** ITRF2008 or IGS08
- JRFCON(15) = 27
-
-*** IGB08
- JRFCON(15) = 28
-
-*** ITRF2014 or IGS14
- JRFCON(16) = 33
-
- RETURN
- END
-***************************************************
- SUBROUTINE RFCON(IBBREF, JREF)
-
-*** Convert reference frame identifier from
-*** system used in the blue-book to the
-*** system used in HTDP
-
- IMPLICIT INTEGER*4 (I-N)
- parameter ( numref = 16 )
- COMMON /REFCON/ IRFCON(36), JRFCON(numref)
-
- IF (1 .LE. IBBREF .AND. IBBREF .LE. 36) THEN
- JREF = IRFCON(IBBREF)
- ELSE
- WRITE(6, 10) IBBREF
- 10 FORMAT(' Improper reference frame identifier (=',
- 1 I4, ')' /
- 1 ' appearing in B-record of the G-FILE')
- STOP
- ENDIF
-
- RETURN
- END
-*******************************************************
- SUBROUTINE RFCON1(JREF, IBBREF)
-
-*** Convert reference frame identifier from
-*** system used in HTDP to the system
-*** used in the blue-book
-
- IMPLICIT INTEGER*4 (I-N)
- parameter ( numref = 16 )
- COMMON /REFCON/ IRFCON(36), JRFCON(numref)
-
- IF (JREF .EQ. 0) THEN
- I = 1
- ELSE
- I = JREF
- ENDIF
-
- IF(1. LE. I .AND. I .LE. numref) THEN
- IBBREF = JRFCON(I)
- IF ( IBBREF .eq. 0) THEN
- write(6,5) JREF
- 5 format(' ERROR: The BlueBook does not recognize '/
- * 'this reference frame, HTDP ID = ',I2)
- stop
- ENDIF
-
- ELSE
- WRITE(6, 10) JREF
- 10 FORMAT(' Improper reference frame identifier (=',
- * I4, ')' / 'appearing in routine RFCON1')
- STOP
- ENDIF
-
- RETURN
- END
-*****************************************************************
-
- subroutine TRAVEC(dxi, dyi, dzi, date, jopt1, jopt2)
-
-*** Transform GPS or other vector from one reference frame to another
-*** for the given date
-****************
-C Important note:
-C The parameters in common block tranpa are computed using the IGS values of ITRF96==>ITRF97
-C The parameters in common block tranpa1 are computed using the IERS values of ITRF96==>ITRF97
-
-*** (dxi, dyi, dzi) --> (input) components of input vector in meters
-*** --> (output) components of transformed vector in meters
-
-*** date --> (input) time (decimal years) to which the input & output
-*** vectors correspond
-
-*** jopt1 --> (input) specifier of reference frame for input vector
-*** jopt2 --> (input) specifier of reference frame for output vector
-
- implicit double precision (a-h, o-z)
- implicit integer*4 (i-n)
- parameter (numref = 16)
-
- common /tranpa/ tx(numref), ty(numref), tz(numref),
- & dtx(numref), dty(numref), dtz(numref),
- & rx(numref), ry(numref), rz(numref),
- & drx(numref), dry(numref), drz(numref),
- & scale(numref), dscale(numref), refepc(numref)
-
-*** Transform input vector to ITRF94 reference frame
- if (jopt1 .eq. 0) then
- iopt = 1
- else
- iopt = jopt1
- endif
-
- dtime = date - refepc(iopt)
- rotnx = -(rx(iopt) + drx(iopt)*dtime)
- rotny = -(ry(iopt) + dry(iopt)*dtime)
- rotnz = -(rz(iopt) + drz(iopt)*dtime)
- ds = 1.d0 - (scale(iopt) + dscale(iopt)*dtime)
-
- dxt = + ds*dxi + rotnz*dyi - rotny*dzi
- dyt = - rotnz*dxi + ds*dyi + rotnx*dzi
- dzt = + rotny*dxi - rotnx*dyi + ds*dzi
-
-*** Transform ITRF94 vector to new reference frame
- if (jopt2 .eq. 0) then
- iopt = 1
- else
- iopt = jopt2
- endif
-
- dtime = date - refepc(iopt)
- rotnx = rx(iopt) + drx(iopt)*dtime
- rotny = ry(iopt) + dry(iopt)*dtime
- rotnz = rz(iopt) + drz(iopt)*dtime
- ds = 1.d0 + scale(iopt) + dscale(iopt)*dtime
-
- dxi = + ds*dxt + rotnz*dyt - rotny*dzt
- dyi = - rotnz*dxt + ds*dyt + rotnx*dzt
- dzi = + rotny*dxt - rotnx*dyt + ds*dzt
-
- return
- end
-
-***********************************************************
-
- subroutine TRAVEC_IERS(dxi, dyi, dzi, date, jopt1, jopt2)
-
-*** Transform GPS or other vector from one reference frame to another
-*** for the given date, using the IERS 96-97 transformation parameters
-****************
-C Important note:
-C The parameters in common block tranpa are computed using the IGS values of ITRF96==>ITRF97
-C The parameters in common block tranpa1 are computed using the IERS values of ITRF96==>ITRF97
-
-*** (dxi, dyi, dzi) --> (input) components of input vector in meters
-*** --> (output) components of transformed vector in meters
-
-*** date --> (input) time (decimal years) to which the input & output
-*** vectors correspond
-
-*** jopt1 --> (input) specifier of reference frame for input vector
-*** jopt2 --> (input) specifier of reference frame for output vector
-
- implicit double precision (a-h, o-z)
- implicit integer*4 (i-n)
- parameter (numref = 16)
-
- common /tranpa1/ tx1(numref), ty1(numref), tz1(numref),
- & dtx1(numref), dty1(numref), dtz1(numref),
- & rx1(numref), ry1(numref), rz1(numref),
- & drx1(numref), dry1(numref), drz1(numref),
- & scale1(numref), dscale1(numref), refepc1(numref)
-
-
-*** Transform input vector to ITRF94 reference frame
- if (jopt1 .eq. 0) then
- iopt = 1
- else
- iopt = jopt1
- endif
-
- dtime = date - refepc1(iopt)
- rotnx = -(rx1(iopt) + drx1(iopt)*dtime)
- rotny = -(ry1(iopt) + dry1(iopt)*dtime)
- rotnz = -(rz1(iopt) + drz1(iopt)*dtime)
- ds = 1.d0 - (scale1(iopt) + dscale1(iopt)*dtime)
-
- dxt = + ds*dxi + rotnz*dyi - rotny*dzi
- dyt = - rotnz*dxi + ds*dyi + rotnx*dzi
- dzt = + rotny*dxi - rotnx*dyi + ds*dzi
-
-*** Transform ITRF94 vector to new reference frame
- if (jopt2 .eq. 0) then
- iopt = 1
- else
- iopt = jopt2
- endif
-
- dtime = date - refepc1(iopt)
- rotnx = rx1(iopt) + drx1(iopt)*dtime
- rotny = ry1(iopt) + dry1(iopt)*dtime
- rotnz = rz1(iopt) + drz1(iopt)*dtime
- ds = 1.d0 + scale1(iopt) + dscale1(iopt)*dtime
-
- dxi = + ds*dxt + rotnz*dyt - rotny*dzt
- dyi = - rotnz*dxt + ds*dyt + rotnx*dzt
- dzi = + rotny*dxt - rotnx*dyt + ds*dzt
-
- return
- end
-
-***********************************************************
- SUBROUTINE GETPNT(LATD,LATM,SLAT,LATDIR,LOND,LONM,SLON,
- 1 LONDIR, NAME, X,Y,Z,XLAT,XLON,EHT)
-
-*** Interactively obtain name and coordinates for a point.
-*** Output longitude will be positive west.
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- CHARACTER NAME*24
- CHARACTER COPT*1,LATDIR*1,LONDIR*1
- LOGICAL FRMXYZ
- COMMON /FILES/ LUIN,LUOUT, I1, I2, I3, I4, I5, I6
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
-
- WRITE(LUOUT,100)
- 100 FORMAT(' Enter name for point (24 character max). ')
- READ(LUIN,105,err=200,iostat=ios) NAME
- if (ios /= 0) goto 200
- 105 FORMAT(A24)
-
- 110 WRITE(LUOUT,111)
- 111 FORMAT(' How do you wish to specify positional coordinates:'/
- 1 ' 1...geodetic latitude, longitude, ellipsoid height'/
- 2 ' 2...Cartesian (X,Y,Z) coordinates. ')
- READ(LUIN,'(A1)',err=201,iostat=ios) COPT
- if (ios /= 0) goto 201
-
- IF(COPT .EQ. '1') THEN
- WRITE(LUOUT,115)
- 115 FORMAT(
- 1 ' Enter latitude degrees-minutes-seconds in free format'/,
- 2 ' with north being positive. For example, 35,17,28.3 '/
- 2 ' For a point in the southern hemisphere, enter a minus sign'/
- 3 ' before each value. For example, -35,-17,-28.3')
- READ(LUIN,*,err=202,iostat=ios) LATD, LATM, SLAT
- if (ios /= 0) goto 202
- WRITE(LUOUT,120)
- 120 FORMAT(
- 1 ' Enter longitude degrees-minutes-seconds in free format'/,
- 2 ' with west being positive. To express a longitude measured'/
- 3 ' eastward, enter a minus sign before each value.')
- READ(LUIN,*,err=203,iostat=ios) LOND, LONM, SLON
- if (ios /= 0) goto 203
- WRITE(LUOUT, 125)
- 125 FORMAT(
- 1 ' Enter ellipsoid height in meters. (Note that'/,
- 1 ' predicted motions are independent of this height.) ')
- READ(LUIN,*,err=204,iostat=ios) EHT
- if (ios /= 0) goto 204
- XLAT = (DBLE((LATD*60 + LATM)*60) + SLAT)/RHOSEC
- LATDIR = 'N'
- IF (XLAT .lt. 0.0D0) then
- LATD = - LATD
- LATM = - LATM
- SLAT = - SLAT
- LATDIR = 'S'
- ENDIF
- XLON = (DBLE((LOND*60 + LONM)*60) + SLON)/RHOSEC
- ELON = -XLON
- CALL TOXYZ(XLAT,ELON,EHT,X,Y,Z)
- LONDIR = 'W'
- IF (XLON .lt. 0.0D0) then
- LOND = -LOND
- LONM = -LONM
- SLON = -SLON
- LONDIR = 'E'
- ENDIF
-
- ELSEIF(COPT .EQ. '2') THEN
- WRITE(LUOUT,130)
- 130 FORMAT(' Enter X coordinate in meters. ')
- READ(LUIN,*,err=205,iostat=ios) X
- if (ios /= 0) goto 205
- WRITE(LUOUT,140)
- 140 FORMAT(' Enter Y coordinate in meters. ')
- READ(LUIN,*,err=206,iostat=ios) Y
- if (ios /= 0) goto 206
- WRITE(LUOUT,150)
- 150 FORMAT(' Enter Z coordinate in meters. ')
- READ(LUIN,*,err=207,iostat=ios) Z
- if (ios /= 0) goto 207
- IF(.NOT.FRMXYZ(X,Y,Z,XLAT,XLON,EHT)) STOP 666
- XLON = -XLON
- IF(XLON .LT. 0.0D0) XLON = XLON + TWOPI
- CALL TODMSS(XLAT,LATD,LATM,SLAT,ISIGN)
- LATDIR = 'N'
- IF (ISIGN .eq. -1) LATDIR = 'S'
- CALL TODMSS(XLON,LOND,LONM,SLON,ISIGN)
- LONDIR = 'W'
- IF (ISIGN .eq. -1) LONDIR = 'E'
- ELSE
- WRITE(LUOUT,*) ' Improper response -- try again. '
- GO TO 110
- ENDIF
-
- RETURN
-
- 200 write (*,'(/)')
- write (*,*) "Failed to read point name: ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 201 write (*,'(/)')
- write (*,*) "Failed to read Coord. form option:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 202 write (*,'(/)')
- write (*,*) "Failed to read latitude:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 203 write (*,'(/)')
- write (*,*) "Failed to read longitude:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 204 write (*,'(/)')
- write (*,*) "Failed to read ellipsoidal height:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 205 write (*,'(/)')
- write (*,*) "Failed to read the X coordinate:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 206 write (*,'(/)')
- write (*,*) "Failed to read the Y coordinate:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 207 write (*,'(/)')
- write (*,*) "Failed to read the Z coordinate:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- END
-*****************************************************************
- SUBROUTINE GETVLY(GLAT, GLON, VX, VY, VZ,
- 1 VNORTH, VEAST, VUP, VOPT, IFORM)
-
-*** Interactively obtain velocity for a point
-
- IMPLICIT DOUBLE PRECISION (A-H, O-Z)
- IMPLICIT INTEGER*4 (I-N)
- CHARACTER VOPT*1
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
-
- 200 CONTINUE
- IF (IFORM .eq. 210) then
- WRITE(LUOUT, 210)
- 210 FORMAT(' What is the velocity of this site relative to '/
- 1 ' the input reference frame:'/
- 1 ' 0...use velocity predicted by this software.'/
- 1 ' 1...user will specify the north-east-up'/
- 1 ' components of site velocity.'/
- 1 ' 2...user will specify the global x-y-z'/
- 1 ' components of site velocity.' )
- else
- write(luout, 211)
- 211 FORMAT(' How do you wish to specify the velocity: '/
- 1 ' 1...north-east-up components.'/
- 1 ' 2...global x-y-z components.' )
- endif
-
- READ(LUIN, '(A1)',err=300,iostat=ios) VOPT
- if (ios /= 0) goto 300
-
- IF (VOPT .EQ. '0') THEN
- CONTINUE
- ELSEIF (VOPT .EQ. '1') THEN
- WRITE(LUOUT, 220)
- 220 FORMAT( ' Enter north-south component of velocity in mm/yr'/
- 1 ' with north being positive and south being negative')
- READ(LUIN, *,err=301,iostat=ios) VNORTH
- if (ios /= 0) goto 301
- WRITE(LUOUT, 221)
- 221 FORMAT( ' Enter east-west component of velocity in mm/yr'/
- 1 ' with east being positive and west being negative')
- READ(LUIN, *,err=302,iostat=ios) VEAST
- if (ios /= 0) goto 302
- WRITE(LUOUT, 222)
- 222 FORMAT( ' Enter vertical component of velocity in mm/yr'/
- 1 ' with up being positive and down being negative'/
- 1 ' or enter 0.0 if unknown.')
- READ(LUIN, *,err=303,iostat=ios) VUP
- if (ios /= 0) goto 303
- CALL TOVXYZ( GLAT, GLON, VNORTH, VEAST, VUP, VX, VY, VZ)
- ELSEIF (VOPT .EQ. '2') THEN
- WRITE(LUOUT, *) ' Enter x-component of velocity in mm/yr.'
- READ(LUIN, *,err=304,iostat=ios) VX
- if (ios /= 0) goto 304
- WRITE(LUOUT, *) ' Enter y-component of velocity in mm/yr.'
- READ(LUIN, *,err=305,iostat=ios) VY
- if (ios /= 0) goto 305
- WRITE(LUOUT, *) ' Enter z-component of velocity in mm/yr.'
- READ(LUIN, *,err=306,iostat=ios) VZ
- if (ios /= 0) goto 306
- CALL TOVNEU(GLAT, GLON, VX, VY, VZ, VNORTH, VEAST, VUP)
- ELSE
- WRITE(LUOUT, *) 'Improper response -- try again. '
- GO TO 200
- ENDIF
- RETURN
-
- 300 write (*,'(/)')
- write (*,*) "Failed to read form of velocity:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 301 write (*,'(/)')
- write (*,*) "Failed to read North velocity:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 302 write (*,'(/)')
- write (*,*) "Failed to read East velocity:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 303 write (*,'(/)')
- write (*,*) "Failed to read Up velocity:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 304 write (*,'(/)')
- write (*,*) "Failed to read X velocity:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 305 write (*,'(/)')
- write (*,*) "Failed to read Y velocity:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 306 write (*,'(/)')
- write (*,*) "Failed to read Z velocity:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- END
-
-************************************************************************
- SUBROUTINE COMPSN(YLATT,YLONT,HTT,YLAT,YLON,HT,
- 1 MIN,VN, VE, VU)
-
-*** Compute the position of a point at specified time
-*** Upon input VN, VE, and VU are in mm/yr
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (NDLOC = 2195)
-
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
- COMMON /TIMREF/ ITREF
- COMMON /QPARM/ STRIKE(NDLOC), HL(NDLOC), EQLAT(NDLOC),
- 1 EQLON(NDLOC), SSLIP(NDLOC), DSLIP(NDLOC),
- 1 DIP(NDLOC), DEPTH(NDLOC), WIDTH(NDLOC),
- 1 EQLATR(50),EQLONR(50),EQRAD(50),
- 1 ITEQK(50),NLOC(50),NFP(50),NUMEQ
- COMMON /FILES/ LUIN,LUOUT, I1, I2, I3, I4, I5, I6
-
-** Compute the contribution due to constant velocity
- DTIME = DBLE(MIN - ITREF) / 525960.D0
- CALL RADR8T(YLAT,VN,VE,VNR,VER)
- YLATT = YLAT + VNR*DTIME
- YLONT = YLON - VER*DTIME
- HTT = HT + ((VU * DTIME) /1000.D0)
-c write (*,*) "FROM COMPSN ",YLATT*180.d0/pi,YLONT*180.d0/pi,
-c & HTT
-c write (*,*) "FROM COMPSN ",ITREF,MIN,DTIME
-
-** Compute the contribution due to earthquakes.
-** It is assumed that the components of displacement,
-** DNORTH,DWEST,DUP, do not vary from one reference
-** frame to another given the accuracy of dislocation
-** models.
- DO 10 I = 1, NUMEQ
- IF(ITEQK(I) .GT. ITREF) THEN
- NTIME = 1
- ELSE
- NTIME = 0
- ENDIF
- IF(MIN .LT. ITEQK(I)) NTIME = NTIME - 1
- IF(NTIME .NE. 0) THEN
- CALL RADII(EQLATR(I),RADMER,RADPAR)
- DDLAT = (YLAT - EQLATR(I))*RADMER
- DDLON = (YLON - EQLONR(I))*RADPAR
- DIST = DSQRT(DDLAT*DDLAT + DDLON*DDLON)
- IF(DIST .LE. EQRAD(I)) THEN
- ISTART = NLOC(I)
- IEND = NLOC(I) + NFP(I) - 1
- DO 5 JREC = ISTART,IEND
- CALL DISLOC(YLAT,YLON,STRIKE(JREC),HL(JREC),
- & EQLAT(JREC),EQLON(JREC),SSLIP(JREC),
- & DSLIP(JREC),DIP(JREC),DEPTH(JREC),
- & WIDTH(JREC),DNORTH,DWEST,DUP)
- YLATT = YLATT + NTIME*DNORTH
- YLONT = YLONT + NTIME*DWEST
- HTT = HTT + NTIME*DUP
- 5 CONTINUE
- ENDIF
- ENDIF
- 10 CONTINUE
-
-*** Compute contribution due to postseismic deformation
- CALL PSDISP(YLAT, YLON, MIN, DNORTH, DEAST, DUP)
-c write (*,*) "FROM COMPSN DISP ",DNORTH, DEAST, DUP
- CALL RADII (YLAT, RMER, RPAR)
- YLATT = YLATT + DNORTH/RMER
- YLONT = YLONT - DEAST/RPAR
- HTT = HTT + DUP
- RETURN
- END
-***************************************************************
- SUBROUTINE NEWCOR(YLAT,YLON,HTOLD,MIN1,MIN2,
- 1 YLAT3,YLON3,HTNEW,DN,DE,DU,VN, VE, VU)
-
-*** Predict coordinates at time MIN2 given coordinates at time MIN1.
-*** Predict displacements from time MIN1 to time MIN2.
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
-
- HT = HTOLD
-
- CALL COMPSN(YLAT1,YLON1,HT1,YLAT,YLON,HT,
- 1 MIN1,VN, VE, VU)
-
- CALL COMPSN(YLAT2,YLON2,HT2,YLAT,YLON,HT,
- 1 MIN2, VN, VE, VU)
-
- YLAT3 = YLAT + YLAT2 - YLAT1
- YLON3 = YLON + YLON2 - YLON1
- HTNEW = HT + HT2 - HT1
-c write (*,*) "FROM NEWCOR ",YLAT3*180.d0/pi,YLON3*180.d0/pi,
-c & HTNEW
-
- CALL RADII(YLAT,RADMER,RADPAR)
-
- DN = RADMER * (YLAT2 - YLAT1)
- DE = -RADPAR * (YLON2 - YLON1)
- DU = HT2 - HT1
-c write (*,*) "FROM NEWCOR displacement ",DN,DE,DU
-c write (*,*) "FROM NEWCOR ",YLAT*180.d0/pi,YLON*180.d0/pi,HT
-c write (*,*) "FROM NEWCOR ",YLAT1*180.d0/pi,YLON1*180.d0/pi,HT1
-c write (*,*) "FROM NEWCOR ",YLAT2*180.d0/pi,YLON2*180.d0/pi,HT2
-c write (*,*) "FROM NEWCOR ",YLAT3*180.d0/pi,YLON3*180.d0/pi,HTNEW
-
- RETURN
- END
-******************************************************************
- subroutine PREDV (ylat,ylon,eht,date,iopt,jregn,vn,ve,vu)
-
-** Predict velocity in iopt reference frame
-
-** ylat input - north latitude (radians)
-** ylon input - west longitude (radians)
-** eht input - ellipsoid height (meters)
-** date input - date (decimal years)
-** iopt input - reference frame
-** jregn output - deformation region
-** vn output - northward velocity in mm/yr
-** ve output - eastward velocity in mm/yr
-** vu output - upward velocity in mm/yr
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- logical Is_iopt_NAD83
-
-** Get reference latitude (RLAT) and reference longitude (RLON)
-
-C The following 2 lines were added on 07/22/2015 after Rich found this bug
- elon = -ylon
- call TOXYZ(ylat, elon, eht, x, y, z)
-
-c IF(IOPT .EQ. 0 .OR. IOPT .EQ. 1) THEN !Velocity grids are No longer in NAD83
- IF(IOPT .EQ. 15) THEN !They are in ITRF2008
- RLAT = YLAT
- RLON = YLON
- ELSE
-c elon = -ylon !Was a bug, commented out on 07222015
-c call TOXYZ(ylat, elon, eht, x, y, z) !Was a bug, commented out on 07222015
-c CALL XTONAD(X,Y,Z,RLAT,RLON,EHTNAD,DATE,IOPT) !No longer NAD83
- CALL XTO08 (X,Y,Z,RLAT,RLON,EHTNAD,DATE,IOPT) !Positions should be in ITRF2008
- ENDIF
-
-** Get deformation region
-
- CALL GETREG(RLAT,RLON,JREGN)
-c write (*,*) JREGN
- IF (JREGN .EQ. 0) THEN
- VN = 0.D0
- VE = 0.D0
- VU = 0.D0
- RETURN
- ENDIF
- CALL COMVEL( RLAT, RLON, JREGN, VN, VE, VU) !Those velocities are in ITRF2008
-
-** Convert velocity to reference of iopt, if iopt != NAD83 !No, was in ITRF2008, not in NAD83 (since 09/12/2014)
-
- Is_iopt_NAD83 = (iopt == 1)
-c IF (IOPT .NE. 0 .AND. IOPT .NE. 1) THEN
- IF (IOPT .NE. 15) THEN
- CALL TOVXYZ( YLAT, ELON, VN, VE, VU, VX, VY, VZ)
- if (Is_iopt_NAD83) then
-c CALL VTRANF( X, Y, Z, VX, VY, VZ, 1, IOPT)
- CALL VTRANF( X, Y, Z, VX, VY, VZ, 15, IOPT)
- else
- CALL VTRANF_IERS( X, Y, Z, VX, VY, VZ, 15, IOPT)
- endif
- CALL TOVNEU( YLAT, ELON, VX, VY, VZ, VN, VE, VU)
- ENDIF
-c write (*,*) "From PREDV ",VN, VE, VU
-
- RETURN
- END
-
-****************************************************************
- subroutine TRFVEL
-
-*** Transform velocities from one reference frame to another
-
- implicit double precision (a-h, o-z)
- implicit integer*4 (i-n)
- parameter (numref = 16)
- character nameif*80,name24*80
- character namef*30
- character frame1*24, frame2*24
- character option*1
- character vopt*1, LATDIR*1,LONDIR*1
- character record*120
- LOGICAL Is_inp_NAD83,Is_out_NAD83
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
- COMMON /CONST/ A, F, E2, EPS, AF, PI, TWOPI, RHOSEC
-
- write( luout, 100)
- 100 format(
- 1 ' Please enter the name of the file to contain '/
- 1 ' the transformed velocities. ')
- read( luin, '(a30)',err=600,iostat=ios) namef
- if (ios /= 0) goto 600
-
- open( i2, file = namef, status = 'unknown')
- CALL HEADER
-
- 105 write( luout, 110)
- 110 format( /'*******************************'/
- 1 ' Enter the reference frame of the input velocities.')
- call MENU1(iopt1, frame1)
- if (iopt1 .lt. 1 .or. iopt1 .gt. numref) then
- write( luout, *) ' Improper selection -- try again.'
- go to 105
- endif
- Is_inp_NAD83 = (iopt1 == 1)
-
- 115 write( luout, 120)
- 120 format( /' Enter the reference frame for the output velocities.')
- call MENU1(iopt2, frame2)
- if (iopt2 .lt. 1 .or. iopt2 .gt. numref) then
- write( luout, *) 'Improper selection -- try again.'
- go to 115
- endif
- Is_out_NAD83 = (iopt2 == 1)
-
- write( i2, 125) frame1, frame2
- 125 format( ' TRANSFORMING VELOCITIES FROM ', A24, ' TO ', a24//
- 1 16X, ' INPUT VELOCITIES OUTPUT VELOCITIES'/)
-
- 130 write( luout, 140)
- 140 format( /'**********************************'/
- 1 ' Velocities will be transformed at each specified point.'/
- 1 ' Please indicate how you wish to input points.'/
- 1 ' 0...No more points. Return to main menu.'/
- 1 ' 1...Individual points entered interactively.'/
- 1 ' 2...Transform velocities contained in batch file '/
- 1 ' of delimited records of the form: '/
- 1 ' LAT,LON,VN,VE,VU,TEXT ' /
- 1 ' LAT = latitude in degrees (positive north/DBL PREC)'/
- 1 ' LON = longitude in degrees (positive west/DBL PREC)'/
- 1 ' VN = northward velocity in mm/yr (DBL PREC) '/
- 1 ' VE = eastwars velocity in mm/yr (DBL PREC) '/
- 1 ' VU = upward velocity in mm/yr (DBL PREC) '/
- 1 ' TEXT = descriptive text (CHARACTER*24) '/
- 1 ' Example: '/
- 1 ' 40.731671553,112.212671753, 3.7,3.8,-2.4,SALT AIR '/)
- read( luin,'(a1)',err=601,iostat=ios) option
- if (ios /= 0) goto 601
- if (option .eq. '0') then
- go to 500
- elseif (option .eq. '1') then
- call GETPNT( latd, latm, slat, LATDIR, lond, lonm, slon,
- 1 LONDIR, name24, x, y, z, ylat, ylon, eht)
- elon = - ylon
- call GETVLY( ylat, elon, vx, vy, vz, vn, ve, vu, vopt, 211)
- vx1 = vx
- vy1 = vy
- vz1 = vz
- if (Is_inp_NAD83 .or. Is_out_NAD83) then
- call VTRANF( x, y, z, vx1, vy1, vz1, iopt1, iopt2)
- else
- call VTRANF_IERS( x, y, z, vx1, vy1, vz1, iopt1, iopt2)
- endif
- call TOVNEU( ylat, elon, vx1, vy1, vz1, vn1, ve1, vu1)
- xlat = (ylat*rhosec)/3600.d0
- xlon = (ylon*rhosec)/3600.d0
- call PRNTVL(vn, ve, vu, vx, vy, vz, vn1, ve1, vu1,
- 1 vx1, vy1, vz1, name24, 1,xlat, xlon)
-
- go to 130
- elseif (option .eq. '2') then
- eht = 0.d0
- write (luout, 200)
- 200 format(/' Enter name of input file: ')
- read(luin, '(a)',err=602,iostat=ios) nameif
- if (ios /= 0) goto 602
-
- open (i1, file = nameif, status = 'old')
- 210 read(i1,'(a)',end = 220,err=603,iostat=ios) record
-c 210 read(i1, *, end = 220,err=603,iostat=ios) xlat, xlon,vn,ve,vu, name24
- call interprate_velocity_record (record,xlat,xlon,vn,ve,
- & vu,name24)
- if (ios /= 0) goto 603
- ylat = (xlat*3600.d0) / rhosec
- ylon = (xlon*3600.d0) / rhosec
- elon = -ylon
- call TOXYZ (ylat, elon, eht, x, y, z)
- call TOVXYZ (ylat, elon, vn,ve,vu,vx,vy,vz)
- vx1 = vx
- vy1 = vy
- vz1 = vz
- if (Is_inp_NAD83 .or. Is_out_NAD83) then
- call VTRANF ( x, y, z, vx1, vy1, vz1, iopt1, iopt2)
- else
- call VTRANF_IERS ( x, y, z, vx1, vy1, vz1, iopt1, iopt2)
- endif
- call TOVNEU (ylat, elon, vx1, vy1, vz1, vn1, ve1, vu1)
- call PRNTVL (vn, ve,vu,vx,vy,vz,vn1,ve1,vu1,vx1,vy1,vz1,
- 1 name24, 0, xlat, xlon)
- go to 210
- 220 close (i1, status = 'keep')
- endif
- 500 continue
- close (i2, status = 'keep')
- return
-
- 600 write (*,'(/)')
- write (*,*) "Failed to read file name in TRFVEL:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 601 write (*,'(/)')
- write (*,*) "Failed to read option in TRFVEL:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 602 write (*,'(/)')
- write (*,*) "Failed to read input file name in TRFVEL:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 603 write (*,'(/)')
- write(*,*)"Failed to read input file format in TRFVEL:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- end
-*******************************************************************
- SUBROUTINE VTRANF(X,Y,Z,VX,VY,VZ, IOPT1, IOPT2)
-
-*** Convert velocity from reference frame of IOPT1 to
-*** reference frame of IOPT2.
-****************
-C Important note:
-C The parameters in common block tranpa are computed using the IGS values of ITRF96==>ITRF97
-C The parameters in common block tranpa1 are computed using the IERS values of ITRF96==>ITRF97
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (numref = 16)
- common /tranpa/ tx(numref), ty(numref), tz(numref),
- & dtx(numref), dty(numref), dtz(numref),
- & rx(numref), ry(numref), rz(numref),
- & drx(numref), dry(numref), drz(numref),
- & scale(numref), dscale(numref), refepc(numref)
-
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
-
- IF(IOPT1 .le. numref .and. IOPT2. le. numref
- & .and. IOPT1 .gt. 0 .and. IOPT2 .gt. 0 ) THEN
-
-*** Convert from mm/yr to m/yr
- VX = VX /1000.d0
- VY = VY / 1000.d0
- VZ = VZ / 1000.d0
-
-*** From IOPT1 to ITRF94
-*** (following equations use approximations assuming
-*** that rotations and scale change are small)
- WX = -drx(iopt1)
- WY = -dry(iopt1)
- WZ = -drz(iopt1)
- DS = -dscale(iopt1)
- VX = VX - dtx(iopt1) + DS*X + WZ*Y - WY*Z
- VY = VY - dty(iopt1) - WZ*X +DS*Y + WX*Z
- VZ = VZ - dtz(iopt1) + WY*X - WX*Y + DS*Z
-
-*** From ITRF94 to IOPT2 reference frame
-*** (following equations use approximations assuming
-*** that rotations and scale change are small)
- WX = drx(iopt2)
- WY = dry(iopt2)
- WZ = drz(iopt2)
- DS = dscale(iopt2)
- VX = VX + dtx(iopt2) + DS*X + WZ*Y - WY*Z
- VY = VY + dty(iopt2) - WZ*X + DS*Y + WX*Z
- VZ = VZ + dtz(iopt2) + WY*X - WX*Y + DS*Z
-
-*** FROM m/yr to mm/yr
- VX = VX * 1000.d0
- VY = VY * 1000.d0
- VZ = VZ * 1000.d0
-
- ELSE
- write(luout,*) ' Improper reference frame in routine vtranf'
- stop
- ENDIF
-c write (*,*) "Inside VTRANF ",Vx,Vy,Vz
-
- RETURN
- END
-******************************************************
- SUBROUTINE VTRANF_IERS(X,Y,Z,VX,VY,VZ, IOPT1, IOPT2)
-
-*** Convert velocity from reference frame of IOPT1 to
-*** reference frame of IOPT2.
-****************
-C Important note:
-C The parameters in common block tranpa are computed using the IGS values of ITRF96==>ITRF97
-C The parameters in common block tranpa1 are computed using the IERS values of ITRF96==>ITRF97
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (numref = 16)
- common /tranpa1/ tx1(numref), ty1(numref), tz1(numref),
- & dtx1(numref), dty1(numref), dtz1(numref),
- & rx1(numref), ry1(numref), rz1(numref),
- & drx1(numref), dry1(numref), drz1(numref),
- & scale1(numref), dscale1(numref), refepc1(numref)
-
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
-
- IF(IOPT1 .le. numref .and. IOPT2. le. numref
- & .and. IOPT1 .gt. 0 .and. IOPT2 .gt. 0 ) THEN
-
-*** Convert from mm/yr to m/yr
- VX = VX /1000.d0
- VY = VY / 1000.d0
- VZ = VZ / 1000.d0
-
-*** From IOPT1 to ITRF94
-*** (following equations use approximations assuming
-*** that rotations and scale change are small)
- WX = -drx1(iopt1)
- WY = -dry1(iopt1)
- WZ = -drz1(iopt1)
- DS = -dscale1(iopt1)
- VX = VX - dtx1(iopt1) + DS*X + WZ*Y - WY*Z
- VY = VY - dty1(iopt1) - WZ*X +DS*Y + WX*Z
- VZ = VZ - dtz1(iopt1) + WY*X - WX*Y + DS*Z
-
-*** From ITRF94 to IOPT2 reference frame
-*** (following equations use approximations assuming
-*** that rotations and scale change are small)
- WX = drx1(iopt2)
- WY = dry1(iopt2)
- WZ = drz1(iopt2)
- DS = dscale1(iopt2)
- VX = VX + dtx1(iopt2) + DS*X + WZ*Y - WY*Z
- VY = VY + dty1(iopt2) - WZ*X + DS*Y + WX*Z
- VZ = VZ + dtz1(iopt2) + WY*X - WX*Y + DS*Z
-
-*** FROM m/yr to mm/yr
- VX = VX * 1000.d0
- VY = VY * 1000.d0
- VZ = VZ * 1000.d0
-
- ELSE
- write(luout,*) ' Improper reference frame in routine vtranf'
- stop
- ENDIF
-
- RETURN
- END
-******************************************************
- subroutine PRNTVL(VN, VE, VU, VX, VY, VZ, VN1, VE1, VU1,
- 1 VX1, VY1, VZ1, NAME24, IPRINT,XLAT,XLON)
-
-*** Print transformed velocities
-
- implicit double precision (a-h, o-z)
- implicit integer*4 (i-n)
- character name24*80
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
-
- if (iprint .eq. 1) then
- write( luout, 100) vn1, ve1, vu1, vx1, vy1, vz1
- 100 format( ' ****************************************'/
- 1 ' New northward velocity = ', f8.2, ' mm/yr' /
- 1 ' New eastward velocity = ', f8.2, ' mm/yr'/
- 1 ' New upward velocity = ', f8.2, ' mm/yr'/
- 1 ' New x velocity = ', f8.2, ' mm/yr'/
- 1 ' New y velocity = ', f8.2, ' mm/yr'/
- 1 ' New z velocity = ', f8.2, ' mm/yr'/)
- endif
-
- write( i2, 200) name24, xlat, xlon,
- 1 vn, vn1, ve, ve1, vu, vu1,
- 1 vx, vx1, vy, vy1, vz, vz1
- 200 format(1x, a24 /
- 1 1x, 'latitude = ',F14.9,2x,'longitude = ',F14.9 /
- 1 5x, 'northward velocity ', f8.2, 6x, f8.2, ' mm/yr' /
- 1 5x, 'eastward velocity ', f8.2, 6x, f8.2, ' mm/yr' /
- 1 5x, 'upward velocity ', f8.2, 6x, f8.2, ' mm/yr' /
- 1 5x, 'x velocity ', f8.2, 6x, f8.2, ' mm/yr' /
- 1 5x, 'y velocity ', f8.2, 6x, f8.2, ' mm/yr' /
- 1 5x, 'z velocity ', f8.2, 6x, f8.2, ' mm/yr' /)
-
- return
- end
-*******************************************************************
- SUBROUTINE HEADER
-
- IMPLICIT DOUBLE PRECISION (A-H, O-Z)
- IMPLICIT INTEGER*4 (I-N)
- character HTDP_version*10
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
- COMMON /VERSION/ HTDP_version
-
- WRITE(I2, 10) HTDP_version
- 10 FORMAT(' HTDP (VERSION ',a,') OUTPUT' / )
- RETURN
- END
-*********************************************
- SUBROUTINE GETMDY(MONTH, IDAY, IYEAR, DATE, MINS, TEST)
-
-*** Read month-day-year and convert to decimal years
-*** and Julian time in minutes
-*** MONTH output - number from 1 to 12
-*** IDAY output - number from 1 to 31
-*** IYEAR output - must be after 1906
-*** DATE output - corresponding time in decimal years
-*** MINS output - corresponding julian time in minutes
-*** TEST output - if (true) then there is an error
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- DIMENSION M(12)
- LOGICAL TEST
- CHARACTER TOPT*1
- COMMON /FILES/ LUIN, LUOUT, I1, I2, I3, I4, I5, I6
-
- M(1) = 31
- M(2) = 28
- M(3) = 31
- M(4) = 30
- M(5) = 31
- M(6) = 30
- M(7) = 31
- M(8) = 31
- M(9) = 30
- M(10) = 31
- M(11) = 30
- M(12) = 31
-
- 3 WRITE (LUOUT,1)
- 1 FORMAT (' How do you wish to enter the time?'/
- 1 ' 1. month-day-year in free format'/
- 1 ' for example, 5,12,1979'/
- 1 ' represents May 12, 1979'/
- 1 ' 2. decimal year'/
- 1 ' for example the entry 1979.359'/
- 1 ' represents UTC midnight at the begining'/
- 1 ' of May 12, 1979.'/)
-
- READ (LUIN,5,err=100,iostat=ios) TOPT
- if (ios /= 0) goto 100
- 5 format (A1)
-
- IF (TOPT .EQ. '1') Then
- write (luout,*) ' Enter month-day-year '
- READ(LUIN,*,err=101,iostat=ios) MONTH,IDAY,IYEAR
- if (ios /= 0) goto 101
-
- IF(IYEAR .le. 1906) THEN
- WRITE(LUOUT,10)
- 10 FORMAT(' The model is not valid for dates prior ',
- 1 'to 1906.'/)
- TEST = .TRUE.
- RETURN
- ENDIF
-
- IF(MONTH .le. 0 .or. MONTH .gt. 12) THEN
- WRITE(LUOUT,20)
- 20 FORMAT(' Improper month specified.'/)
- TEST = .TRUE.
- RETURN
- ENDIF
-
- IF(IDAY .le. 0 .or. IDAY .gt. 31) THEN
- WRITE(LUOUT,30)
- 30 FORMAT(' Improper day specified.'/)
- TEST = .TRUE.
- RETURN
- ENDIF
-
- CALL IYMDMJ(IYEAR, MONTH, IDAY, MJD)
- CALL IYMDMJ(IYEAR, 1, 1, MJD0)
- IYEAR1 = IYEAR + 1
- CALL IYMDMJ(IYEAR1, 1, 1, MJD1)
- DAY = DBLE(MJD - MJD0)
- DENOM = DBLE(MJD1 - MJD0)
- DATE = DBLE(IYEAR) + (DAY / DENOM)
- MINS = MJD * 24 * 60
- TEST = .FALSE.
- RETURN
-
- ELSEIF (TOPT .EQ. '2') then
- write(luout,*) ' Enter decimal year '
- READ (LUIN, *,err=102,iostat=ios) DATE
- if (ios /= 0) goto 102
-
- IF (DATE .lt. 1906.0d0) then
- write (luout, 10)
- TEST = .TRUE.
- RETURN
- ENDIF
-**** add small increment to circumvent round-off error
-c DATE = DATE + 0.0004D0
-****
- IYEAR = DATE
- CALL IYMDMJ(IYEAR, 1, 1, MJD0)
- IYEAR1 = IYEAR + 1
- CALL IYMDMJ(IYEAR1, 1, 1, MJD1)
- LEAP = 0
- IF ((MJD1 - MJD0) .eq. 366) LEAP = 1
- REMDAY = (DATE - IYEAR)* (MJD1 - MJD0)
- IBEGIN = 0
- ITOTAL = 31
- IF (REMDAY .LT. ITOTAL) then
- MONTH = 1
- IDAY = REMDAY - IBEGIN + 1
- CALL IYMDMJ(IYEAR,MONTH,IDAY,MJD)
- MINS = MJD * 24 * 60
- TEST = .FALSE.
- RETURN
- ENDIF
- IBEGIN = ITOTAL
- ITOTAL = ITOTAL + LEAP
- DO I = 2, 12
- ITOTAL = ITOTAL + M(I)
- IF (REMDAY .LT. ITOTAL) then
- MONTH = I
- IDAY = REMDAY - IBEGIN + 1
- TEST = .FALSE.
- CALL IYMDMJ(IYEAR,MONTH,IDAY,MJD)
- MINS = MJD * 24 * 60
- RETURN
- ENDIF
- IBEGIN = ITOTAL
- ENDDO
- Write(LUOUT, 60)
- 60 Format (' Error could not convert Decimal years to '
- 1 ,'month-day-year')
- TEST = .TRUE.
- RETURN
- ELSE
- write (luout, 70)
- 70 format (' Improper entry')
- Go TO 3
- ENDIF
-
- 100 write (*,'(/)')
- write (*,*) "Failed to read option in GETDMY:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 101 write (*,'(/)')
- write (*,*) "Wrong MDY input in GETDMY:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- 102 write (*,'(/)')
- write (*,*) "Wrong decimal year in GETDMY:ios=",ios
- write (*,*) "ABNORMAL TERMINATION"
- write (*,*) "PLEASE CHECK YOUR INPUT FILE AND TRY AGAIN"
- stop
-
- END
-************************************
- SUBROUTINE IYMDMJ( IYR, IMON, IDAY, MJD )
-C
-C********1*********2*********3*********4*********5*********6*********7**
-C
-C NAME: IYMDMJ
-C VERSION: Sep. 17, 2010
-C WRITTEN BY: R. SNAY (after M. SCHENEWERK)
-C PURPOSE: CONVERT DATE TO MODIFIED JULIAN DATE
-C
-C INPUT PARAMETERS FROM THE ARGUEMENT LIST:
-C -----------------------------------------
-C IDAY DAY
-C IMON MONTH
-C IYR YEAR
-C
-C OUTPUT PARAMETERS FROM ARGUEMENT LIST:
-C --------------------------------------
-C MJD MODIFIED JULIAN DATE
-C
-C
-C LOCAL VARIABLES AND CONSTANTS:
-C ------------------------------
-C A TEMPORARY STORAGE
-C B TEMPORARY STORAGE
-C C TEMPORARY STORAGE
-C D TEMPORARY STORAGE
-C IMOP TEMPORARY STORAGE
-C IYRP TEMPORARY STORAGE
-C
-C GLOBAL VARIABLES AND CONSTANTS:
-C ------------------------------
-C
-C
-C THIS MODULE CALLED BY: GENERAL USE
-C
-C THIS MODULE CALLS: DINT
-C
-C INCLUDE FILES USED:
-C
-C COMMON BLOCKS USED:
-C
-C REFERENCES: DUFFETT-SMITH, PETER 1982, 'PRACTICAL
-C ASTRONOMY WITH YOUR CALCULATOR', 2ND
-C EDITION, CAMBRIDGE UNIVERSITY PRESS,
-C NEW YORK, P.9
-C
-C COMMENTS: THIS SUBROUTINE REQUIRES THE FULL YEAR,
-C I.E. 1992 RATHER THAN 92.
-C
-C********1*********2*********3*********4*********5*********6*********7**
-C::LAST MODIFICATION
-C::8909.06, MSS, DOC STANDARD IMPLIMENTED
-C::9004.17, MSS, CHANGE ORDER YY MM DD
-C********1*********2*********3*********4*********5*********6*********7**
-C
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER*4 (I-N)
-C
- INTEGER*4 A, B, C, D
-
- IYRP = IYR
-C
-C........ 0.0 EXPLICIT INITIALIZATION
-C
- IF( IMON .LT. 3 ) THEN
- IYRP= IYRP - 1
- IMOP= IMON + 12
- ELSE
- IMOP= IMON
- END IF
-C
-C........ 1.0 CALCULATION
-C
- A= IYRP*0.01D0
- B= 2 - A + DINT( A*0.25D0 )
- C= 365.25D0*IYRP
- D= 30.6001D0*(IMOP + 1)
- MJD = (B + C + D + IDAY - 679006)
-C
- RETURN
- END
-*****************************************************
- SUBROUTINE PSDISP(YLAT, YLON, MIN, DNORTH, DEAST, DUP)
-********
-* Compute total postseismic displacement for all earthquakes
-*
-* INPUT
-* YLAT latitude of point in radians, positive north
-* YLON longitude of point in radians, positive west
-* MIN modified julian date of reference epoch for new coordinates
-* in minutes
-*
-* DNORTH Total northward postseismic displacement at point during
-* period from ITREF to MIN in meters
-* DEAST TOTAL eastward postseismic displacement
-* DUP Total upward postseismic displacement
-*******
-
- IMPLICIT DOUBLE PRECISION (A-H, O-Z)
- IMPLICIT INTEGER*4 (I-N)
- LOGICAL INSIDE
-
- parameter (NUMPSG = 1)
- COMMON /CONST/ A, F,E2,EPS,AF,PI,TWOPI,RHOSEC
- COMMON /TIMREF/ ITREF
- COMMON /PSGRID/ PSGLX(NUMPSG), PSGUX(NUMPSG),
- 1 PSGLY(NUMPSG), PSGUY(NUMPSG),
- 1 ICNTPX(NUMPSG), ICNTPY(NUMPSG), NBASEP(NUMPSG)
- COMMON /PGRID/ PS(18000)
- DIMENSION ITEQ(NUMPSG)
- DIMENSION TAU(NUMPSG)
- DIMENSION WEI(2,2)
- DIMENSION AMP(2,2,3)
-
-*** Relaxation constant (in years) for 2002 Denali earthquake
- TAU(1) = 5.0D0
-
-*** Modofied Julian Date (in minutes) for the 2002 Denali earthquake
- IYEAR = 2002
- IMO = 11
- IDAY = 3
- CALL IYMDMJ(IYEAR,IMO,IDAY, MJD)
- ITEQ(1) = MJD*60*24
-
- DNORTH = 0.0D0
- DEAST = 0.0D0
- DUP = 0.0D0
-
- DO K = 1, NUMPSG
-*** Check if the point is inside the grid
- POSX = YLON*180.d0/PI
- POSX = 360.d0 - POSX
- IF (POSX .GT. 360.D0) POSX = POSX - 360.D0
- POSY = YLAT*180.D0/PI
- CALL GRDCHK(POSX, POSY, PSGLX(K), PSGUX(K),
- 1 PSGLY(K), PSGUY(K), INSIDE)
-
- IF (INSIDE ) THEN
-*** Get the indices for the lower left-hand corner of the grid
- CALL PSGWEI(POSX,POSY,K,I,J,WEI)
-*** Get the displacement amplitude at the four corners
- CALL GRDAMP(K,I,J,AMP,PS)
-
- ANORTH = WEI(1,1)*AMP(1,1,1) + WEI(1,2)*AMP(1,2,1)
- 1 + WEI(2,1)*AMP(2,1,1) + WEI(2,2)*AMP(2,2,1)
- AEAST = WEI(1,1)*AMP(1,1,2) + WEI(1,2)*AMP(1,2,2)
- 1 + WEI(2,1)*AMP(2,1,2) + WEI(2,2)*AMP(2,2,2)
- AUP = WEI(1,1)*AMP(1,1,3) + WEI(1,2)*AMP(1,2,3)
- 1 + WEI(2,1)*AMP(2,1,3) + WEI(2,2)*AMP(2,2,3)
-
-c write (6, 30) anorth, aeast, aup
-c 30 format (1x, 3f15.5)
-
-*** Convert amplitudes from mm to meters
- ANORTH = ANORTH / 1000.D0
- AEAST = AEAST / 1000.D0
- AUP = AUP / 1000.D0
-
- IF (MIN .GT. ITEQ(K)) THEN
- DTIME = DBLE(MIN - ITEQ(K))/(60.D0*24.D0*365.D0)
- FACTOR = 1.D0 - DEXP(-DTIME/TAU(K))
- DNORTH = DNORTH + ANORTH*FACTOR
- DEAST = DEAST + AEAST*FACTOR
- DUP = DUP + AUP*FACTOR
- ENDIF
- IF (ITREF .GT. ITEQ(K)) THEN
- DTIME = DBLE(ITREF - ITEQ(K))/(60.D0*24.D0*365.D0)
- FACTOR = 1.D0 - DEXP(-DTIME/TAU(K))
- DNORTH = DNORTH - ANORTH*FACTOR
- DEAST = DEAST - AEAST*FACTOR
- DUP = DUP - AUP*FACTOR
- ENDIF
- ENDIF
- ENDDO
- RETURN
- END
-
-****************************************************
- SUBROUTINE GRDCHK (POSX, POSY, GRDLX, GRDUX,
- 1 GRDLY, GRDUY, INSIDE)
-
-C
-C ROUTINE CHECKS IF THE POINT HAVING COORDINATES (POSX, POSY)
-C IS WITHIN THE REGION SPANNED BY THE GRID
-C
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- LOGICAL INSIDE
-
- INSIDE = .TRUE.
-
- IF (POSX .LT. GRDLX .OR. POSX .GT. GRDUX) THEN
- INSIDE = .FALSE.
- ENDIF
- IF (POSY .LT. GRDLY .OR. POSY .GT. GRDUY) THEN
- INSIDE = .FALSE.
- ENDIF
-
- RETURN
- END
-*******************************************************************
- SUBROUTINE PSGWEI (POSX, POSY, K, I, J, WEI)
-
-C
-C********1*********2*********3*********4*********5*********6*********7**
-C
-C PURPOSE: THIS SUBROUTINE RETURNS THE INDICES OF THE LOWER-LEFT
-C HAND CORNER OF THE GRID CELL CONTAINING THE POINT
-C AND COMPUTES NORMALIZED WEIGHTS FOR
-C BI-LINEAR INTERPOLATION OVER A PLANE
-C
-C INPUT PARAMETERS FROM ARGUMENT LIST:
-C ------------------------------------
-C POSX LONGITUDE OF POINT IN DEGREES, POSITIVE EAST
-C POSY LATITUDE OF POINT IN DEGREES, POSITIVE NORTH
-C K ID OF EARTHQUAKE GRID
-C
-C OUTPUT PARAMETERS FROM ARGUMENT LIST:
-C -------------------------------------
-C I, J THE COORDINATES OF LOWER LEFT CORNER OF THE GRID
-C CONTAINING THE ABOVE POSITION
-C WEI A TWO BY TWO ARRAY CONTAINING THE NORMALIZED WEIGHTS
-C FOR THE CORNER VECTORS
-C
-C GLOBAL VARIABLES AND CONSTANTS:
-C -------------------------------
-C NONE
-C
-C THIS MODULE CALLED BY: PSDISP
-C
-C THIS MODULE CALLS: NONE
-C
-C INCLUDE FILES USED: NONE
-C
-C COMMON BLOCKS USED: /PSGRID/, /CONST/
-C
-C REFERENCES: SEE RICHARD SNAY
-C
-C COMMENTS:
-C
-C********1*********2*********3*********4*********5*********6*********7**
-C MOFICATION HISTORY:
-C::9302.11, CRP, ORIGINAL CREATION FOR DYNAP
-C::9511.09, RAS, MODIFIED FOR HTDP
-C::9712.05, RAS, MODIFIED TO ACCOUNT FOR MULTIPLE GRIDS
-C********1*********2*********3*********4*********5*********6*********7**
-
-C**** COMPUTES THE WEIGHTS FOR AN ELEMENT IN A GRID
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (NUMPSG = 1)
- DIMENSION WEI(2,2)
- COMMON /PSGRID/ PSGLX(NUMPSG), PSGUX(NUMPSG),
- 1 PSGLY(NUMPSG), PSGUY(NUMPSG),
- 1 ICNTPX(NUMPSG), ICNTPY(NUMPSG), NBASEP(NUMPSG)
- COMMON /CONST/ A,F,E2,EPS,AF,PI,TWOPI,RHOSEC
-
-C*** Obtain indices for the lower-left corner of the cell
-C*** containing the point
- STEPX = (PSGUX(K) - PSGLX(K)) / ICNTPX(K)
- STEPY = (PSGUY(K) - PSGLY(K)) / ICNTPY(K)
- I = IDINT((POSX - PSGLX(K))/STEPX) + 1
- J = IDINT((POSY - PSGLY(K))/STEPY) + 1
-c write(6,1001) K, I, J
-c1001 format(1x, 'quake = ', I5 /
-c 1 1x, ' i = ', I5 /
-c 1 1x, ' j = ', I5)
-
-C*** Compute the limits of the grid cell
- GRLX = PSGLX(K) + (I - 1) * STEPX
- GRUX = GRLX + STEPX
- GRLY = PSGLY(K) + (J - 1) * STEPY
- GRUY = GRLY + STEPY
-
-C*** Compute the normalized weights for the point
- DENOM = (GRUX - GRLX) * (GRUY - GRLY)
- WEI(1,1) = (GRUX - POSX) * (GRUY - POSY) / DENOM
- WEI(2,1) = (POSX - GRLX) * (GRUY - POSY) / DENOM
- WEI(1,2) = (GRUX - POSX) * (POSY - GRLY) / DENOM
- WEI(2,2) = (POSX - GRLX) * (POSY - GRLY) / DENOM
-
- RETURN
- END
-
-C*********************************************************************
- SUBROUTINE GRDAMP (K, I, J, AMP, PS)
-C********1*********2*********3*********4*********5*********6*********7**
-C
-C PURPOSE: THIS SUBROUTINE RETRIEVES THE AMPLITUDES OF THE FOUR
-C GRID NODES OFGRID K WHERE I,J ARE THE INDICES OF
-C THE LOWER LEFT HAND CORNER
-C
-C INPUT PARAMETERS FROM ARGUMENT LIST:
-C ------------------------------------
-C
-C K ID OF EARTHQUAKE CORRESPONDING TO GRID
-C I, J THE COORDINATES OF LOWER LEFT CORNER OF THE GRID
-C CONTAINING THE ABOVE POSITION
-C PS THE ARRAY CONTAINING ALL THE GRIDDED AMPLITUDES
-C
-C OUTPUT PARAMETERS FROM ARGUMENT LIST:
-C -------------------------------------
-C AMP A TWO BY TWO ARRAY CONTAINING THE 3D AMPLITUDES
-C FOR THE CORNERS OF THE GRID
-C
-C GLOBAL VARIABLES AND CONSTANTS:
-C -------------------------------
-C NONE
-C
-C THIS MODULE CALLED BY: PSDISP
-C
-C THIS MODULE CALLS: NONE
-C
-C INCLUDE FILES USED: NONE
-C
-C COMMON BLOCKS USED: NONE
-C
-C REFERENCES: SEE RICHARD SNAY
-C
-C COMMENTS:
-C
-C********1*********2*********3*********4*********5*********6*********7**
-C MOFICATION HISTORY:
-C::2011.08.17, RAS, ORIGINAL CREATION FOR TRANS4D
-C********1*********2*********3*********4*********5*********6*********7**
-
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- DIMENSION AMP(2,2,3), PS(*)
-
- DO 30 II = 0,1
- DO 20 IJ = 0,1
- DO 10 IVEC = 1, 3
- INDEX = IPSGRD(K, I + II, J + IJ, IVEC)
- AMP(II + 1, IJ + 1, IVEC) = PS(INDEX)
- 10 CONTINUE
- 20 CONTINUE
- 30 CONTINUE
-
- RETURN
- END
-
-C***************************************************
- INTEGER FUNCTION IPSGRD(IGRID, I, J, IVEC)
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER*4 (I-N)
- parameter (NUMPSG = 1)
- COMMON /PSGRID/ PSGLX(NUMPSG), PSGUX(NUMPSG),
- 1 PSGLY(NUMPSG), PSGUY(NUMPSG),
- 1 ICNTPX(NUMPSG), ICNTPY(NUMPSG), NBASEP(NUMPSG)
-
- IPSGRD = NBASEP(IGRID) +
- 1 3 * ((J - 1) * (ICNTPX(IGRID) + 1) + (I - 1)) + IVEC
-
- RETURN
- END
-C---------------------------------------------------------------------
- subroutine extract_name (name,i)
-
-C In f90, use trim(name) to truncate all spaces after the name.
-C But "trim" were not available in f77. This is what this subroutine is for
-
- implicit none
- integer*4 i
- character name*80,scratch*80
-
- do i=80,1,-1
- if (name(i:i) /= ' ') exit
- enddo
- scratch = name(1:i)
- name = scratch
-
- return
- end
-C-----------------------------------------------------------------------------------
- subroutine interprate_XYZ_record (record,x,y,z,name)
-
- implicit none
-
- integer*4 i,j,length
- real*8 x,y,z
- character name*80,record*120,record1*120,chars*120
- character xxxx*80,yyyy*80,zzzz*80
-
- record1 = trim(adjustl(record))
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == ' ') then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get x or phi
-
- xxxx = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- xxxx(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1))
- read (xxxx,*) x
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get y or lamda
-
- yyyy = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- yyyy(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1))
- read (yyyy,*) y
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get z or h
-
- zzzz = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- zzzz(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1))
- read (zzzz,*) z
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get name
-
- name = trim(record1)
-
-C Done
-
- return
- end
-C-----------------------------------------------------------------------------------
- subroutine interprate_XYZVxVyVz_record (record,x,y,z,Vx,Vy,Vz,
- & name)
-
- implicit none
-
- integer*4 i,j,length
- real*8 x,y,z,Vx,Vy,Vz
- character name*80,record*120,record1*120,chars*120
- character xxxx*80,yyyy*80,zzzz*80
-
- record1 = trim(adjustl(record))
- length = len_trim(record1)
- chars = ' '
-
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == ' ') then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get x or phi
-
- xxxx = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- xxxx(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1))
- read (xxxx,*) x
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get y or lamda
-
- yyyy = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- yyyy(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1))
- read (yyyy,*) y
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get z or h
-
- zzzz = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- zzzz(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1))
- read (zzzz,*) z
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get Vx
-
- xxxx = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- xxxx(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1))
- read (xxxx,*) Vx
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get Vy
-
- yyyy = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- yyyy(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1))
- read (yyyy,*) Vy
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get z or h
-
- zzzz = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- zzzz(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1))
- read (zzzz,*) Vz
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-C Get name
-
- name = trim(record1)
-
-C Done
-
- return
- end
-C-----------------------------------------------------------------------------------
- subroutine interprate_latlon_record (record,x,y,name)
-
- implicit none
-
- integer*4 i,j,length
- real*8 x,y,z
- character name*24,record*120,record1*120,chars*120
- character xxxx*80,yyyy*80,zzzz*80
-
- record1 = trim(adjustl(record))
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == ' ') then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get x or phi
-
- xxxx = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- xxxx(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1))
- read (xxxx,*) x
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get y or lamda
-
- yyyy = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- yyyy(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1))
- read (yyyy,*) y
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get name
-
- name = trim(record1)
-
-C Done
-
- return
- end
-C-----------------------------------------------------------------------------------
- subroutine interprate_velocity_record (record,x,y,vn,ve,
- & vu,name)
-
- implicit none
-
- integer*4 i,j,length
- real*8 x,y,vn,ve,vu
- character name*80,record*120,record1*120,chars*120
- character xxxx*80,yyyy*80,vnnn*80,veee*80,vuuu*80
-
- record1 = trim(adjustl(record))
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == ' ') then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get x or phi
-
- xxxx = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- xxxx(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1)) !adjust left then trim all trailing spaces
- read (xxxx,*) x
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get y or lamda
-
- yyyy = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- yyyy(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1))
- read (yyyy,*) y
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get vn
-
- vnnn = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- vnnn(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1))
- read (vnnn,*) vn
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get ve
-
- veee = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- veee(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1))
- read (veee,*) ve
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get vu
-
- vuuu = '0'
- do i=1,length
- if (chars(i:i) == '1') then
- vuuu(i:i) = record1(i:i)
- record1(i:i) = ' '
- elseif (chars(i:i) == '0') then
- exit
- endif
- enddo
- record = trim(adjustl(record1))
- read (vuuu,*) vu
- if (record(1:1) == ',') then
- record(1:1) = ' '
- endif
- record1 = adjustl(record)
- length = len_trim(record1)
- chars = ' '
- do i=1,length
- if (record1(i:i) == ' ' .or. record1(i:i) == ',' .or.
- & record1(i:i) == " ") then
- chars(i:i) = '0'
- else
- chars(i:i) = '1'
- endif
- enddo
-
-C Get name
-
- name = trim(record1)
-
-C Done
-
- return
- end
-C-----------------------------------------------------------------------------------
- logical function am_I_in_or_near_CONUS (fi,la)
-
- implicit none
-
- integer*4 nrows,ncols,xcell,ycell,rec_num
- integer*2 sea,code,code_UL,code_UR,code_LL,code_LR
- real*8 fi,la,fi_max,la_min,dlamda,dfi,fi_min
- real*8 fi1,la1,fi2,la2,la_max
-
- character grid*80
-c logical am_I_in_or_near_CONUS,CONUS_on_land
- logical CONUS_on_land
-
-C Constants
-
- parameter (fi_max = 50.d0,
- & fi_min = 23.5d0,
- & la_min = 235.d0,
- & la_max = 295.d0,
- & sea = 0)
-
-C Initialize this function
-
- am_I_in_or_near_CONUS = .false.
-
-C If clearly outside Conus
-
- if (fi>fi_max.or.fi<fi_min.or.la>la_max.or.la<la_min) then
- return
- else
- am_I_in_or_near_CONUS = .true.
- return
- endif
-
- return
- end
-C-----------------------------------------------------------------------------------------------------------
- logical function am_I_in_or_near_AK(fi,la)
-
-C Given your latitude and longitude, this little routine tells you if you
-C are in Alaska (AK) or within 10 km of its boundaries.
-
-C "AK_direct_cell_by_cell_1min" is an unformatted direct access file of nowrs*ncols records
-C each record is of length 2 bytes (integer*2), which contains a geographic code defined as follows:
-
-C 1) The AK code is 278
-C 2) The codes for Canada are 265 to 276
-C 4) The code for sea is 0
-
-C Geographic conditions to be in or near AK:
-
-C 1) The point is on land in AK
-
-C a) code is 278
-
-C 2) In the Canada near the AK:
-
-C a) code = 265 to 276
-C c) Point is no more than 10km from AK
-
-C 3) In the sea near AK:
-
-C a) code = 0
-C c) Point is no more than 10km from AK
-
- implicit none
-
- integer*4 nrows,ncols,xcell,ycell,rec_num
- integer*2 sea,code,code_UL,code_UR,code_LL,code_LR
- real*8 fi,la,fi_max,dlamda,dfi,la_max
- real*8 fi1,la1,fi2,la2,la_min,fi_min
-
- character grid*27,path*46
-c logical am_I_in_or_near_AK,AK_on_land
- logical AK_on_land
-
-C Constants
-
- parameter (nrows = 1291,
- & ncols = 3511,
- & dfi = 1.d0/60.d0,
- & dlamda = 1.d0/60.d0,
- & fi_max = 71.5d0,
- & fi_min = 50.d0,
- & la_min = 172.d0,
- & la_max = 230.5d0,
- & sea = 0)
-
-C Initialize this function
-
- am_I_in_or_near_AK = .false.
-
-C When it is clearly not AK
-
- if (fi>fi_max.or.fi<fi_min.or.la>la_max.or.la<la_min) then
- return
- else
- am_I_in_or_near_AK = .true.
- return
- endif
-
-C On 1/22/2016 I disabled the following code following Giovanni's suggestion
-C and for simplicity and portability
-
- return
- end
-C----------------------------------------------------------------------------------------------
- logical function am_I_in_or_near_HI(fi,la)
-
-C Given your latitude and longitude, this little routine tells you if you
-C are in the Hawaian Islands (Hawaii, Kahoolawe,Kauai,Lanai,Maui,Molokai, Nihau and Oahu)
-C or within 5 km of their coastlines.
-
-C "HI_Hawaii.gmt", "HI_Kahoolawe.gmt", "HI_Kauai.gmt", "HI_Lanai.gmt", "HI_Maui.gmt", "HI_Molokai.gmt",
-C "HI_Nihau.gmt" and "HI_Oahu.gmt" are ASCII files that contain coastline polygons for the islands.
-C Each polygon is closed, starts and ends at the same point.
-C File format: (East) longitude and latitude in decimal degrees.
-
- implicit none
-
- integer*4 i,NPC,n_Hawaii,n_Kahoolawe,n_Kauai,n_Lanai,n_Maui
- integer*4 n_Molokai,n_Nihau,n_Oahu
-
- real*8 fi,la,fi1,la1,fi2,la2,fi_max,fi_min,la_max,la_min
-c logical am_I_in_or_near_HI,Hawaii,Kahoolawe,Kauai,Lanai
- logical Hawaii,Kahoolawe,Kauai,Lanai
- logical Maui,Molokai,Nihau,Oahu
- logical UL,UR,LL,LR
-
-C Constants
-
- parameter (n_Hawaii = 329,
- & n_Kahoolawe = 143,
- & n_Kauai = 107,
- & n_Lanai = 52,
- & n_Maui = 205,
- & n_Molokai = 114,
- & n_Nihau = 68,
- & n_Oahu = 123,
- & fi_max = 24.d0,
- & fi_min = 18.d0,
- & la_min = 199.d0,
- & la_max = 207.d0)
-
- real*8 X1(n_Hawaii) ,Y1(n_Hawaii) !I am not sure the cheap compilers in subversion can handle dynamic memory
- real*8 X2(n_Kahoolawe) ,Y2(n_Kahoolawe)
- real*8 X3(n_Kauai) ,Y3(n_Kauai)
- real*8 X4(n_Lanai) ,Y4(n_Lanai)
- real*8 X5(n_Maui) ,Y5(n_Maui)
- real*8 X6(n_Molokai) ,Y6(n_Molokai)
- real*8 X7(n_Nihau) ,Y7(n_Nihau)
- real*8 X8(n_Oahu) ,Y8(n_Oahu)
-
-C Initialize this function
-
- am_I_in_or_near_HI = .false.
-
-C When it is clearly not HI
-
- if (fi>fi_max.or.fi<fi_min.or.la>la_max.or.la<la_min) then
- return
- else
- am_I_in_or_near_HI = .true.
- return
- endif
-
-C On 1/22/2016 I disabled the following code following Giovanni's suggestion
-C and to simplify.
-
- return
- end
-C-------------------------------------------------------------------------------------------------
- logical function am_I_in_or_near_PR(fi,la)
-
-C Given your latitude and longitude, this little routine tells you if you
-C are in Puerto Rico Islands (the main Island, Culebra, Desecheo, Mona or Viequez)
-C or within 10 km of their coastlines.
-
-C "PR_PuertoRico.gmt", "PR_Culebra", "PR_Mona.gmt", "PR_Viequez.gmt", and PR_"Desecheo.gmt"
-C are ASCII files that contain coastline polygons for each one of the 5 PR islands.
-C Each polygon is closed, starts and ends at the same point.
-C File format: (East) longitude and latitude in decimal degrees.
-
-
- implicit none
-
- integer*4 i,NPC,n_PR,n_Culebra,n_Mona,n_Desecheo,n_Viequez
-
- real*8 fi,la,fi1,la1,fi2,la2,fi_max,fi_min,la_max,la_min
-c logical am_I_in_or_near_PR,PR
- logical PR
- logical Culebra,Mona,Desecheo,Viequez
- logical UL,UR,LL,LR
-
-C Constants
-
- parameter (n_PR = 228,
- & n_Culebra = 185,
- & n_Mona = 52,
- & n_Desecheo = 34,
- & n_Viequez = 309,
- & fi_max = 19.d0,
- & fi_min = 17.d0,
- & la_max = 295.d0,
- & la_min = 292.d0)
-
- real*8 X1(n_PR) ,Y1(n_PR) !I am not sure the cheap compilers in subversion can handle dynamic memory
- real*8 X2(n_Culebra) ,Y2(n_Culebra)
- real*8 X3(n_Mona) ,Y3(n_Mona)
- real*8 X4(n_Desecheo),Y4(n_Desecheo)
- real*8 X5(n_Viequez) ,Y5(n_Viequez)
-
-C Initialize this function
-
- am_I_in_or_near_PR = .false.
-
-C When it is clearly not PR
-
- if (fi>fi_max.or.fi<fi_min.or.la>la_max.or.la<la_min) then
- return
- else
- am_I_in_or_near_PR = .true.
- return
- endif
-
-C On 1/22/2016 I disabled the following code following Giovanni's suggestion
-C and for simplicity.
-
- return
- end
-C-------------------------------------------------------------------------------------------------------------
- logical function am_I_in_or_near_VQ(fi,la)
-
-C Given your latitude and longitude, this little routine tells you if you are in
-C the Virgin Islands (St. Croix, St John and St Thomas) or within 10 km of their coastlines.
-
-C "VQ_StCroix.gmt", "VQ_StJohn.gmt" and "VQ_StThomas.gmt" are ASCII files that
-C contain coastline polygons for each one of the 3 VQ islands.
-C Each polygon is closed, starts and ends at the same point.
-C File format: (East) longitude and latitude in decimal degrees.
-
-
- implicit none
-
- integer*4 i,NPC,n_VQ,n_StCroix,n_StJohn,n_StThomas
-
- real*8 fi,la,fi1,la1,fi2,la2,fi_max,fi_min,la_max,la_min
-c logical am_I_in_or_near_VQ
- logical StCroix,StJohn,StThomas
- logical UL,UR,LL,LR
-
-C Constants
-
- parameter (n_StCroix = 142,
- & n_StJohn = 356,
- & n_StThomas = 304,
- & fi_max = 18.4d0,
- & fi_min = 15.5d0,
- & la_max = 295.6d0,
- & la_min = 295.d0)
-
- real*8 X1(n_StCroix) ,Y1(n_StCroix) !I am not sure the cheap compilers in subversion can handle dynamic memory
- real*8 X2(n_StJohn ) ,Y2(n_StJohn )
- real*8 X3(n_StThomas),Y3(n_StThomas)
-
-C Initialize this function
-
- am_I_in_or_near_VQ = .false.
-
-C When it is clearly not VQ
-
- if (fi>fi_max.or.fi<fi_min.or.la>la_max.or.la<la_min) then
- return
- else
- am_I_in_or_near_VQ = .true.
- return
- endif
-
-C On 1/22/2016 the following code was disabled following Giovanni's suggestion
-C and for simplicity
-
- return
- end
-C-------------------------------------------------------------------------------------------
- logical function am_I_in_or_near_CQ (fi,la)
-
-C Given your latitude and longitude, this little routine tells you if you are in
-C the North Mariana Islands (Saipan, Tinian and Rota) or within 10 km of their coastlines.
-
-C "CQ_Rota.gmt", "CQ_Saipan.gmt" and "CQ_Tinian.gmt" are ASCII files that
-C contain coastline polygons for each one of the 3 CQ islands.
-C Each polygon is closed, starts and ends at the same point.
-C File format: (East) longitude and latitude in decimal degrees.
-
-
- implicit none
-
- integer*4 i,NPC,n_CQ,n_Saipan ,n_Tinian,n_Rota
-
- real*8 fi,la,fi1,la1,fi2,la2,fi_max,fi_min,la_max,la_min
-c logical am_I_in_or_near_CQ
- logical Saipan,Tinian,Rota
- logical UL,UR,LL,LR
-
-C Constants
-
- parameter (n_Saipan = 122,
- & n_Tinian = 70,
- & n_Rota = 80,
- & fi_max = 15.6d0,
- & fi_min = 13.8d0,
- & la_max = 146.d0,
- & la_min = 144.8d0)
-
- real*8 X1(n_Saipan ),Y1(n_Saipan ) !I am not sure the cheap compilers in subversion can handle dynamic memory
- real*8 X2(n_Tinian ),Y2(n_Tinian )
- real*8 X3(n_Rota ),Y3(n_Rota )
-
-C Initialize this function
-
- am_I_in_or_near_CQ = .false.
-
-C When it is clearly not CQ
-
- if (fi>fi_max.or.fi<fi_min.or.la>la_max.or.la<la_min) then
- return
- else
- am_I_in_or_near_CQ = .true.
- return
- endif
-
-C On 1/22/2016 the following code was disabled following Giovanni's suggestion
-C and for simplicity
-
- return
- end
-C-------------------------------------------------------------------------------------------
- logical function am_I_in_or_near_AS(fi,la)
-
-C Given your latitude and longitude, this little routine tells you if you are in
-C the American Samoa Islands (Ofu, Rose, Tau and Tutila) or within 10 km of their coastlines.
-
-C "AS_Ofu.gmt", "AS_Rose.gmt" and " AS_Tau.gmt" and "AS_Tutila.gmt" are ASCII files that
-C contain coastline polygons for each one of the 4 AS islands.
-C Each polygon is closed, starts and ends at the same point.
-C File format: (East) longitude and latitude in decimal degrees.
-
-
- implicit none
-
- integer*4 i,NPC,n_AS,n_Ofu,n_Rose,n_Tau,n_Tutila
-
- real*8 fi,la,fi1,la1,fi2,la2,fi_max,fi_min,la_max,la_min
-c logical am_I_in_or_near_AS
- logical Ofu,Rose,Tau,Tutila
- logical UL,UR,LL,LR
-
-C Constants
-
- parameter (n_Ofu = 64,
- & n_Rose = 8,
- & n_Tau = 76,
- & n_Tutila = 239,
- & fi_max = -13.7d0,
- & fi_min = -14.7d0,
- & la_max = 190.8d0,
- & la_min = 189.d0)
-
- real*8 X1(n_Ofu ) ,Y1(n_Ofu ) !not sure the cheap compilers in subversion can handle dynamic memory
- real*8 X2(n_Rose) ,Y2(n_Rose)
- real*8 X3(n_Tau ) ,Y3(n_Tau )
- real*8 X4(n_Tutila),Y4(n_Tutila)
-
-C Initialize this function
-
- am_I_in_or_near_AS = .false.
-
-C When it is clearly not AS
-
- if (fi>fi_max.or.fi<fi_min.or.la>la_max.or.la<la_min) then
- return
- else
- am_I_in_or_near_AS = .true.
- return
- endif
-
-C On 1/22/2016 the following code was disabled following Giovanni's suggestion
-C and for simplicity
-
- return
- end
-C-------------------------------------------------------------------------------------------------
- logical function am_I_in_or_near_Guam(fi,la)
-
-C Given your latitude and longitude, this little routine tells you if you are in
-C the Guam Island or within 5 km of its coastlines.
-
-C "GQ_Guam.gmt", is an ASCII file that contains coastline polygons Guam.
-C This polygon is closed, starts and ends at the same point.
-C File format: (East) longitude and latitude in decimal degrees.
-
-
- implicit none
-
- integer*4 i,NPC,n_GQ
- real*8 fi,la,fi1,la1,fi2,la2,fi_max,fi_min,la_max,la_min
-c logical am_I_in_or_near_Guam
- logical GQ
- logical UL,UR,LL,LR
-
-C Constants
-
- parameter (n_GQ = 300,
- & fi_max = 13.7d0,
- & fi_min = 13.d0,
- & la_max = 145.d0,
- & la_min = 144.5d0)
-
- real*8 X1(n_GQ) ,Y1(n_GQ) !I am not sure the cheap compilers in subversion can handle dynamic memory
-
-C Initialize this function
-
- am_I_in_or_near_Guam = .false.
-
-C When it is clearly not Guam
-
- if (fi>fi_max.or.fi<fi_min.or.la>la_max.or.la<la_min) then
- return
- else
- am_I_in_or_near_Guam = .true.
- return
- endif
-
-C On 1/22/2016 the following code was disabled following Giovanni's suggestion
-C and for simplicity
-
- return
- end
-C----------------------------------------------------------------------------------------------
- logical function am_I_in_or_near_KW(fi,la)
-
-C Given your latitude and longitude, this little routine tells you if you are in
-C the a little square around Kwajalein of the Marshal islands
-
-C "Kwajalein.gmt", is an ASCII file that contains a rectangle around Kwajalein.
-C This polygon is closed, starts and ends at the same point.
-C File format: (East) longitude and latitude in decimal degrees.
-
-
- implicit none
-
- integer*4 i,NPC,n_KW
-
- real*8 fi,la,fi1,la1,fi2,la2,fi_max,fi_min,la_max,la_min
-
-c logical am_I_in_or_near_KW
- logical KW
- logical UL,UR,LL,LR
-
-C Constants
-
- parameter (n_KW = 5,
- & fi_max = 10.5d0,
- & fi_min = 5.d0 ,
- & la_max = 174.d0,
- & la_min = 165.7d0)
-
- real*8 X1(n_KW) ,Y1(n_KW) !I am not sure the cheap compilers in subversion can handle dynamic memory
-
-C Initialize this function
-
- am_I_in_or_near_KW = .false.
-
-C When it is clearly not KW
-
- if (fi>fi_max.or.fi<fi_min.or.la>la_max.or.la<la_min) then
- return
- else
- am_I_in_or_near_KW = .true.
- return
- endif
-
-C On 1/22/2016 the following code was disabled following Giovanni's suggestion
-C and for simplicity
-
- return
- end
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-27 12:36:37 +0000