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