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