From e1fc5ad517ae4dc12c532841abe9e28b0486c954 Mon Sep 17 00:00:00 2001 From: SriReddy-NOAA Date: Fri, 9 Apr 2021 00:11:44 -0400 Subject: Version 3.2.8 --- License.txt | 6 - Makefile | 2 + README.md | 22 - htdp.f | 9123 ++++++++ htdp.for | 9123 -------- initbd.f | 3143 +++ initeq.f | 19947 +++++++++++++++++ initps.f | 11876 +++++++++++ initvl.f | 65835 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ pc_build.txt | 15 + 10 files changed, 109941 insertions(+), 9151 deletions(-) delete mode 100644 License.txt delete mode 100644 README.md create mode 100644 htdp.f delete mode 100644 htdp.for create mode 100644 initbd.f create mode 100644 initeq.f create mode 100644 initps.f create mode 100644 initvl.f create mode 100644 pc_build.txt diff --git a/License.txt b/License.txt deleted file mode 100644 index a3c453f..0000000 --- a/License.txt +++ /dev/null @@ -1,6 +0,0 @@ -“Software code created by U.S. Government employees is not subject to copyright in the United States (17 U.S.C. -§105). The United States/Department of Commerce reserve all rights to seek and obtain copyright protection in -countries other than the United States for Software authored in its entirety by the Department of Commerce. To -this end, the Department of Commerce hereby grants to Recipient a royalty-free, nonexclusive license to use, -copy, and create derivative works of the Software outside of the United States.” - diff --git a/Makefile b/Makefile index 63bbf05..2080cd7 100644 --- a/Makefile +++ b/Makefile @@ -28,3 +28,5 @@ initps.o: initps.f htdp: htdp.o initvl.o initeq.o initbd.o initps.o $(FC) $(CFLAGS) $(INCLUDES) -o $@ $? $(LIBS) + +#MADE diff --git a/README.md b/README.md deleted file mode 100644 index c0eef9a..0000000 --- a/README.md +++ /dev/null @@ -1,22 +0,0 @@ -# HTDP -Horizontal Time-Dependent Positioning (HTDP) is a utility that allows users to transform positional coordinates across time and between spatial reference frames. - -For additional information, contact: -NOAA National Geodetic Survey, -ngs.infocenter@noaa.gov - -Visit: -https://geodesy.noaa.gov/TOOLS/Htdp/Htdp.shtml - -## NOAA Open Source Disclaimer - -This repository is a scientific product and is not official communication of the National Oceanic and Atmospheric Administration, or the United States Department of Commerce. All NOAA GitHub project code is provided on an ?as is? basis and the user assumes responsibility for its use. Any claims against the Department of Commerce or Department of Commerce bureaus stemming from the use of this GitHub project will be governed by all applicable Federal law. Any reference to specific commercial products, processes, or services by service mark, trademark, manufacturer, or otherwise, does not constitute or imply their endorsement, recommendation or favoring by the Department of Commerce. The Department of Commerce seal and logo, or the seal and logo of a DOC bureau, shall not be used in any manner to imply endorsement of any commercial product or activity by DOC or the United States Government. - -Please note that there is no confidentiality on any code submitted through pull requests to NOAA National Geodetic Survey. If the pull requests are accepted and merged into the master branch then they become part of publicly accessible code. - -## License - -Software code created by U.S. Government employees is not subject to copyright in the United States (17 U.S.C. �105). The United States/Department of Commerce reserve all rights to seek and obtain copyright protection in countries other than the United States for Software authored in its entirety by the Department of Commerce. To this end, the Department of Commerce hereby grants to Recipient a royalty-free, nonexclusive license to use, copy, and create derivative works of the Software outside of the United States. - -## IMPORTANT NOTICE -*** HTDP should NOT be used to transform between NAD 83 realizations (2011, NSRS2007, HARN, etc.). It will not give correct results. To transform between NAD 83 realizations, use the NGS Coordinate Conversion and Transformation Tool (NCAT) instead. *** diff --git a/htdp.f b/htdp.f new file mode 100644 index 0000000..56926a4 --- /dev/null +++ b/htdp.f @@ -0,0 +1,9123 @@ + 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.8' + +*** 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 + drz1(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.fila_max.or.lafi_max.or.fila_max.or.lafi_max.or.fila_max.or.lafi_max.or.fila_max.or.lafi_max.or.fila_max.or.lafi_max.or.fila_max.or.lafi_max.or.fila_max.or.lafi_max.or.fila_max.or.lafi_max.or.fila_max.or.la 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.fila_max.or.lafi_max.or.fila_max.or.lafi_max.or.fila_max.or.lafi_max.or.fila_max.or.lafi_max.or.fila_max.or.lafi_max.or.fila_max.or.lafi_max.or.fila_max.or.lafi_max.or.fila_max.or.lafi_max.or.fila_max.or.la