C SccsID = "@(#)mercat.f 1.1 07/23/03" SUBROUTINE MERCAT (ICODE,I,IC,P,E,X,Y,DA,XK) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION TMDATA(196),TM1(64),TM2(64),TM3(68) CHARACTER*4 IGP,IPC,ICODE EQUIVALENCE (TMDATA(1),TM1(1)),(TMDATA(65),TM2(1)), * (TMDATA(129),TM3(1)) DATA IPC/'PCGP'/ C 06NOV72 C THESE CONSTANTS ARE TAKEN FROM *STATE PLANE COORDINATES BY AUTOMATIC C DATA PROCESSING* BY CHARLES N. CLAIRE, C+GS PUBLICATION 62-4. C DATA TM1 / 06NOV72 * 3.090D5, 109341.00903D0, 0.9999600000D0, 0.3817065D0, 06NOV72 * 3.150D5, 107545.53386D0, 0.9999333333D0, 0.3817477D0, 06NOV72 * 3.966D5, 111136.62358D0, 0.9999000000D0, 0.3816485D0, 06NOV72 * 4.029D5, 111136.62358D0, 0.9999000000D0, 0.3816485D0, 06NOV72 * 4.095D5, 111136.62358D0, 0.9999333333D0, 0.3815948D0, 06NOV72 * 2.715D5, 136290.53702D0, 0.9999950281D0, 0.3811454D0, 06NOV72 * 2.916D5, 87206.09287D0, 0.9999411765D0, 0.3821090D0, 06NOV72 * 2.952D5, 87206.09287D0, 0.9999411765D0, 0.3821090D0, 06NOV72 * 2.958D5, 107545.53386D0, 0.9999000000D0, 0.3817593D0, 06NOV72 * 3.030D5, 107545.53386D0, 0.9999000000D0, 0.3817593D0, 06NOV72 * 5.598D5, 67479.52714D0, 0.9999666667D0, 0.3826496D0, 06NOV72 * 5.640D5, 72858.21554D0, 0.9999666667D0, 0.3825762D0, 06NOV72 * 5.688D5, 75846.77497D0, 0.9999900000D0, 0.3825176D0, 06NOV72 * 5.742D5, 78237.83623D0, 0.9999900000D0, 0.3824812D0, 06NOV72 * 5.766D5, 77640.05280D0, 0.9999999999D0, 0.3824867D0, 06NOV72 * 4.038D5, 149478.35156D0, 0.9999473684D0, 0.3807624D0/ DATA TM2 / 06NOV72 * 4.104D5, 149478.35156D0, 0.9999473684D0, 0.3807624D0, 06NOV72 * 4.167D5, 149478.35156D0, 0.9999333333D0, 0.3806227D0, 06NOV72 * 3.180D5, 131497.04639D0, 0.9999750000D0, 0.3811074D0, 06NOV72 * 3.246D5, 131497.04639D0, 0.9999411765D0, 0.3811332D0, 06NOV72 * 3.084D5, 134492.84965D0, 0.9999666667D0, 0.3811064D0, 06NOV72 * 3.135D5, 134492.84965D0, 0.9999666667D0, 0.3811064D0, 06NOV72 * 2.466D5, 157275.15187D0, 0.9999000000D0, 0.3806180D0, 06NOV72 * 2.526D5, 153676.25668D0, 0.9999666667D0, 0.3806575D0, 06NOV72 * 3.012D5, 148878.72150D0, 0.9999428571D0, 0.3807283D0, 06NOV72 * 3.087D5, 148878.72150D0, 0.9999090909D0, 0.3807541D0, 06NOV72 * 3.195D5, 148878.72150D0, 0.9999090909D0, 0.3805361D0, 06NOV72 * 3.198D5, 106348.62716D0, 0.9999600000D0, 0.3817257D0, 06NOV72 * 3.252D5, 109341.00903D0, 0.9999411765D0, 0.3816986D0, 06NOV72 * 3.258D5, 128501.66790D0, 0.9999333333D0, 0.3812643D0, 06NOV72 * 3.330D5, 128501.66790D0, 0.9999333333D0, 0.3812422D0, 06NOV72 * 3.402D5, 129699.76857D0, 0.9999411765D0, 0.3812362D0/ DATA TM3 / 06NOV72 * 4.161D5, 124608.30429D0, 0.9999000000D0, 0.3812311D0, 06NOV72 * 4.200D5, 124608.30429D0, 0.9999000000D0, 0.3812311D0, 06NOV72 * 4.269D5, 124608.30429D0, 0.9999000000D0, 0.3812311D0, 06NOV72 * 2.580D5, 152476.76677D0, 0.9999666667D0, 0.3807327D0, 06NOV72 * 2.688D5, 139287.02745D0, 0.9999750295D0, 0.3810845D0, 06NOV72 * 3.756D5, 111136.62358D0, 0.9999090909D0, 0.3816135D0, * 3.825D5, 111136.62358D0, 0.9999000000D0, 0.3816204D0, * 3.882D5, 111136.62358D0, 0.9999166667D0, 0.3816288D0, 06NOV72 * 2.676D5, 143482.84247D0, 0.9999666667D0, 0.3808377D0, 06NOV72 * 2.757D5, 143482.84247D0, 0.9999375000D0, 0.3808450D0, 06NOV72 * 2.829D5, 143482.84247D0, 0.9999375000D0, 0.3808750D0, 06NOV72 * 2.574D5, 147379.72344D0, 0.9999937500D0, 0.3809220D0, 06NOV72 * 2.610D5, 152476.76677D0, 0.9999642857D0, 0.3807420D0, 06NOV72 * 3.786D5, 145880.83533D0, 0.9999411765D0, 0.3808422D0, 06NOV72 * 3.864D5, 145880.83533D0, 0.9999411765D0, 0.3808422D0, 06NOV72 * 3.915D5, 145880.83533D0, 0.9999411765D0, 0.3808422D0, 06NOV72 * 3.963D5, 145880.83533D0, 0.9999411765D0, 0.3808422D0/ C DATA ESQ,C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,EPSQ,RHOSEC/ PLANEC 1 6.768658D-3,3.092241724D01,3.9174D00,4.0831D00,3.28083333D00, 2 2.552381D-9,1.012794065D02,1.052893882D03,4.483344D0,2.352D-2, 3 1.9587D-12,8.81749162D02,6.8147849D-3,2.062648062471D05/ DATA D1,D2,D3,D4,D5,D6,D7,D8,D9/ 1 0.3048006099D00,0.9873675553D-2,1.047546710D03, 2 6.192760D00,5.0912D-2,2.552381D01,4.0831D00,3.092241724D01, 3 3.9174D00/ C PLANEC T1=0.5D6 C NEW JERSEY PLANEC IF (IC.EQ.340) T1=2.0D6 C L=I*4 T2=TMDATA(L-3) T34=TMDATA(L-2) T5=TMDATA(L-1) T6=TMDATA(L) C IF (ICODE.EQ.IPC) GO TO 10 C PLANEC SINP=DSIN(P) COSP=DCOS(P) COSP2=COSP*COSP PLANEC SINP2=SINP*SINP PLANEC TANP=DTAN(P) W2=1.D0-ESQ*SINP2 V2=1.D0+EPSQ*COSP2 PSEC=P*RHOSEC PLANEC ESEC=E*RHOSEC PLANEC C PLANEC S1=C1*COSP*(T2-ESEC-C2*((T2-ESEC)/1.D04)**3)/DSQRT(W2) SM=S1+C3*(S1*1.D-5)**3 X=T1+C4*SM*T5+T6*((C4*SM*T5*1.D-5)**3) P1SEC=PSEC+C5*SM*SM*W2*W2*TANP PLANEC P1=P1SEC/RHOSEC PLANEC SINP1=DSIN(P1) TANP1=DTAN(P1) W2=1.D0-ESQ*SINP1*SINP1 P2SEC=PSEC+C5*SM*SM*W2*W2*TANP1 PLANEC P2=P2SEC/RHOSEC PLANEC COSP2=DCOS(P2) COSP2S=COSP2*COSP2 PLANEC SINP2=DSIN(P2) SINM=DSIN((P+P2)/2.D0) COSM=DCOS((P+P2)/2.D0) TMS=T2-ESEC PLANEC Y=C6*T5*(P2SEC-T34-(C7-(C8-C9*COSP2S)*COSP2S)*SINP2*COSP2) PLANEC DASEC=TMS*SINM*(1.D0+C10*TMS*TMS*COSM*COSM) DA=DASEC/RHOSEC PLANEC XK=T5*(1.D0+(V2*V2*((X-T1)*1.D-6)**2)/(C11*T5*T5)) RETURN PLANEC C 10 CONTINUE SG1=(X-T1)*(1.D0-T6*1.D-15*(X-T1)*(X-T1)) SM=D1*(X-T1-T6*1.D-15*SG1**3)/T5 OMSEC=T34+D2*Y/T5 OMEGA=OMSEC/RHOSEC SINO=DSIN(OMEGA) COSO=DCOS(OMEGA) COS2O=COSO*COSO P1SEC=OMSEC+(D3+(D4+D5*COS2O)*COS2O)*SINO*COSO P1RAD=P1SEC/RHOSEC SINP1=DSIN(P1RAD) SIN2P1=SINP1*SINP1 TANP1=DTAN(P1RAD) W=1.D0-ESQ*SIN2P1 PSEC=P1SEC-D6*W*W*TANP1*SM*SM*1.D-10 SA=SM*(1.D0-D7*SM*SM*1.D-15) S1=SM-D7*1.D-15*SA**3 P=PSEC/RHOSEC SINP=DSIN(P) COSP=DCOS(P) W=DSQRT(1.D0-ESQ*SINP*SINP) DL1SEC=S1*W/(D8*COSP) DLASEC=DL1SEC*(1.D0+D9*DL1SEC*DL1SEC*1.D-12) ESEC=T2-DL1SEC-D9*1.D-12*DLASEC**3 E=ESEC/RHOSEC RETURN PLANEC END PLANEC