C SccsID = "@(#)lamber.f 1.1 07/23/03" SUBROUTINE LAMBER (ICODE,I,IC,P,E,X,Y,THETA,XK) IMPLICIT REAL*8 (A-H,O-Z) CHARACTER*4 IGP,IPC,ICODE REAL*8 LCDATA,LC1,LC2,LC3,LC4,LC5,LC6,LC7,LC8,LC9,LC0,L1,L2,L3, 1 L4,L5,L6,L78,L9,L10,L11 DIMENSION LCDATA(600),LC1(64),LC2(64),LC3(64),LC4(64),LC5(64), * LC6(64),LC7(64),LC8(64),LC9(64),LC0(24),S(4) EQUIVALENCE (LCDATA( 1),LC1(1)),(LCDATA( 65),LC2(1)), * (LCDATA(129),LC3(1)),(LCDATA(193),LC4(1)), * (LCDATA(257),LC5(1)),(LCDATA(321),LC6(1)), * (LCDATA(385),LC7(1)),(LCDATA(449),LC8(1)), * (LCDATA(513),LC9(1)),(LCDATA(577),LC0(1)) DATA IPC/'PCGP'/ C 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 LC1 / * 6.3360D5,15.89395036D6,16.56462877D6,.9998480641D0,.7969223940D0, 40 * 1.8970787068D5,3.79919D0,5.91550D0, 40 * 3.3120D5,29.27759361D6,29.73288287D6,.9999359370D0,.5818991407D0, 51 * 1.2760635656D5,3.81452D0,3.26432D0, 51 * 3.3120D5,31.01403923D6,31.51172420D6,.9999184698D0,.5596906871D0, 52 * 1.2203694711D5,3.81550D0,3.08256D0, 52 * 4.3920D5,24.24535805D6,24.79243623D6,.9998946358D0,.6538843192D0, 61 * 1.4648675847D5,3.80992D0,3.93575D0, 61 * 4.3920D5,25.79585031D6,26.31225765D6,.9999146793D0,.6304679732D0, 62 * 1.4019081964D5,3.81147D0,3.70114D0, 62 * 4.3380D5,27.05747585D6,27.51299204D6,.9999291792D0,.6122320427D0, 63 * 1.3539552018D5,3.81265D0,3.52998D0, 63 * 4.2840D5,28.18240533D6,28.65293196D6,.9999407628D0,.5965871443D0, 64 * 1.3135035494D5,3.81362D0,3.39020D0, 64 * 4.2480D5,30.19414554D6,30.64942427D6,.9999221277D0,.5700119219D0, 65 * 1.2461210305D5,3.81523D0,3.16593D0/ DATA LC2 / * 4.1850D5,31.84657092D6,32.27126772D6,.9999541438D0,.5495175982D0, 66 * 1.1952016335D5,3.81642D0,3.00292D0, 66 * 4.2600D5,30.89138210D6,35.05539631D6,.9999885350D0,.5612432071D0, 67 * 1.2242288096D5,3.81572D0,3.09520D0, 67 * 3.7980D5,24.75189768D6,25.08606820D6,.9999568475D0,.6461334829D0, 81 * 1.4438462308D5,3.81044D0,3.85610D0, 81 * 3.7980D5,25.78137691D6,26.24305274D6,.9999359117D0,.6306895773D0, 82 * 1.4024965162D5,3.81146D0,3.70326D0, 82 * 3.7980D5,26.97713389D6,27.40223182D6,.9999453995D0,.6133780528D0, 83 * 1.3569426662D5,3.81257D0,3.54046D0, 83 * 2.6190D5,23.65923356D6,23.91438902D6,.9999831405D0,.6630594147D0, 90 * 1.4899967980D5,3.80929D0,4.03278D0, 90 * 3.0420D5,36.03044305D6,36.45492453D6,.9999484343D0,.5025259000D0, 123 * 1.0814611701D5,3.81898D0,2.65643D0, 123 * 3.3660D5,22.73695034D6,23.16246159D6,.9999453686D0,.6777445518D0, 191 * 1.5308002265D5,3.80827D0,4.19479D0/ DATA LC3/ * 3.3660D5,23.93658511D6,24.37409667D6,.9999483705D0,.6587010213D0, 192 * 1.4780259905D5,3.80959D0,3.98630D0, 192 * 3.5280D5,25.64495912D6,25.97906857D6,.9999568556D0,.6327148646D0, 201 * 1.4078797215D5,3.81133D0,3.72376D0, 201 * 3.5460D5,26.89602448D6,27.35152150D6,.9999359200D0,.6145281068D0, 202 * 1.3599441020D5,3.81250D0,3.55102D0, 202 * 3.0330D5,26.37182068D6,26.72405182D6,.9999620817D0,.6220672671D0, 211 * 1.3797063364D5,3.81202D0,3.62113D0, 211 * 3.0870D5,27.46786075D6,27.83223564D6,.9999453808D0,.6064623718D0, 212 * 1.3389657874D5,3.81301D0,3.47771D0, 212 * 3.3300D5,33.62456836D6,34.07962933D6,.9999147417D0,.5287006734D0, 221 * 1.1443268515D5,3.81758D0,2.84511D0, 221 * 3.2880D5,36.27138935D6,36.75655345D6,.9999257458D0,.5000126971D0, 222 * 1.0754855026D5,3.81911D0,2.63885D0, 222 * 3.2880D5,41.09174954D6,41.57676239D6,.9998947956D0,.4540068519D0, 223 * .9677930342D5,3.82138D0,2.27436D0/ DATA LC4 / * 2.7720D5,25.98947499D6,26.36911276D6,.9999498485D0,.6276341196D0, 240 * 1.3943969369D5,3.81166D0,3.67392D0, 240 * 2.5740D5,23.11197514D6,23.54947732D6,.9999645506D0,.6717286561D0, 251 * 1.5139953138D5,3.80870D0,4.12738D0, 251 * 2.5380D5,23.78467844D6,23.92439802D6,.9999984844D0,.6610953994D0, 252 * 1.4845947463D5,3.80943D0,4.01174D0, 252 * 3.1320D5,20.04171618D6,20.58942009D6,.9999410344D0,.7227899381D0, 264 * 1.6610225085D5,3.80501D0,4.68430D0, 264 * 3.0360D5,21.00171522D6,21.59476840D6,.9999509058D0,.7064074100D0, 265 * 1.6127076661D5,3.80622D0,4.46875D0, 265 * 3.0360D5,22.56484851D6,23.06959722D6,.9999450783D0,.6805292633D0, 266 * 1.5386223938D5,3.80808D0,4.15706D0, 266 * 3.3516D5,18.98431962D6,19.47139875D6,.9999028166D0,.7412196637D0, 271 * 1.7168463011D5,3.80362D0,5.01609D0, 271 * 3.3930D5,20.00667972D6,20.49345715D6,.9999220223D0,.7233880702D0, 272 * 1.6628089747D5,3.80497D0,4.76197D0/ DATA LC5 / * 3.3840D5,21.32700606D6,21.87434914D6,.9999220448D0,.7009277824D0, 273 * 1.5968012517D5,3.80662D0,4.46959D0, 273 * 3.9420D5,18.68949840D6,19.15787426D6,.9999714855D0,.7464518080D0, 301 * 1.7330021285D5,3.80322D0,5.09490D0, 301 * 3.9420D5,19.43293976D6,19.91980636D6,.9999220151D0,.7333538278D0, 302 * 1.6928196779D5,3.80422D0,4.90135D0, 302 * 3.9420D5,20.50065051D6,21.09682093D6,.9999107701D0,.7149012442D0, 303 * 1.6376115820D5,3.80560D0,4.64814D0, 303 * 3.6000D5,23.00434629D6,23.36897746D6,.9999645501D0,.6734507906D0, 311 * 1.5187930504D5,3.80858D0,4.14653D0, 311 * 3.5820D5,24.10456106D6,24.59078186D6,.9999220725D0,.6560764003D0, 312 * 1.4708468139D5,3.80977D0,3.95865D0, 312 * 2.6640D5,24.23500080D6,24.46254530D6,.9999949000D0,.6540820950D0, 364 * 1.4654064240D5,3.80990D0,3.93780D0, 364 * 2.8440D5,29.63705947D6,30.18361125D6,.9998725510D0,.5771707700D0, 370 * 1.2641160353D5,3.81480D0,3.22483D0/ DATA LC6 / * 3.6180D5,18.81984905D6,19.21551601D6,.9999358426D0,.7441333961D0, 381 * 1.7258257950D5,3.80339D0,5.05972D0, 381 * 3.6180D5,19.66102779D6,20.08697718D6,.9999358523D0,.7293826040D0, 382 * 1.6808045445D5,3.80452D0,4.84504D0, 382 * 2.9700D5,24.04873851D6,24.55915847D6,.9999391411D0,.6569503193D0, 391 * 1.4732348125D5,3.80971D0,3.96783D0, 391 * 2.9700D5,25.52287581D6,26.02707112D6,.9999359346D0,.6345195439D0, 392 * 1.4126863705D5,3.81121D0,3.74048D0, 392 * 3.5280D5,28.65787166D6,29.08283170D6,.9999454101D0,.5901470744D0, 401 * 1.2970256887D5,3.81402D0,3.33440D0, 401 * 3.5280D5,30.38283106D6,30.83803296D6,.9999359432D0,.5676166827D0, 402 * 1.2401248935D5,3.81537D0,3.14645D0, 402 * 4.3380D5,20.83625094D6,21.38385248D6,.9998945810D0,.7091860222D0, 411 * 1.6208208858D5,3.80602D0,4.57382D0, 411 * 4.3380D5,22.34130943D6,22.88866715D6,.9998946058D0,.6841473833D0, 412 * 1.5488274104D5,3.80782D0,4.26823D0/ DATA LC 7 / * 2.7990D5,23.75535127D6,24.21105037D6,.9999568410D0,.6615397363D0, 421 * 1.4858157953D5,3.80940D0,4.01753D0, 421 * 2.7990D5,24.57780067D6,24.98482643D6,.9999595012D0,.6487931668D0, 422 * 1.4510387979D5,3.81026D0,3.88319D0, 422 * 2.9160D5,30.63012553D6,31.12772475D6,.9999454207D0,.5644973800D0, 451 * 1.2323344099D5,3.81555D0,3.12127D0, 451 * 2.9160D5,32.25212630D6,32.67688765D6,.9999326284D0,.5446515700D0, 452 * 1.1832357839D5,3.81669D0,2.94381D0, 452 * 3.6000D5,20.92270409D6,21.36669703D6,.9999391116D0,.7077381841D0, 461 * 1.6165893392D5,3.80612D0,4.55529D0, 461 * 3.6120D5,21.99357561D6,22.46193705D6,.9999068931D0,.6898519579D0, 462 * 1.5650154370D5,3.80742D0,4.33519D0, 462 * 3.0960D5,29.01023109D6,29.53514991D6,.9999484030D0,.5854397296D0, 470 * 1.2850428313D5,3.81431D0,3.29422D0, 470 * 3.6540D5,29.45690729D6,29.97295994D6,.9999108771D0,.5795358654D0, 481 * 1.2700858548D5,3.81466D0,3.24452D0/ DATA LC8 / * 3.5100D5,32.18780958D6,32.69165454D6,.9998726224D0,.5453944146D0, 482 * 1.1850595074D5,3.81665D0,2.97107D0, 482 * 3.6120D5,34.85170346D6,35.33712123D6,.9998817443D0,.5150588857D0, 483 * 1.1114162181D5,3.81832D0,2.74550D0, 483 * 3.5640D5,37.26150920D6,37.80744038D6,.9998632433D0,.4899126408D0, 484 * 1.0515719059D5,3.81962D0,2.56899D0, 484 * 3.5460D5,41.09174954D6,41.57676239D6,.9998947956D0,.4540068519D0, 485 * .9677930342D5,3.82138D0,2.33094D0, 485 * 4.0140D5,23.89487245D6,24.22911029D6,.9999568422D0,.6593554910D0, 491 * 1.4798196231D5,3.80955D0,3.99323D0, 491 * 4.0140D5,25.11717675D6,25.66411442D6,.9998988207D0,.6405785926D0, 492 * 1.4288930066D5,3.81081D0,3.80024D0, 492 * 4.0140D5,27.02595535D6,27.43281288D6,.9999512939D0,.6126873424D0, 493 * 1.3551416878D5,3.81262D0,3.53414D0, 493 * 2.8260D5,26.23020009D6,26.57644445D6,.9999483859D0,.6241178597D0, 511 * 1.3851078682D5,3.81189D0,3.64047D0/ DATA LC9 / * 2.8260D5,27.43480006D6,27.81131271D6,.9999454027D0,.6069248249D0, 512 * 1.3401641072D5,3.81298D0,3.48187D0, 512 * 4.3500D5,18.79808167D6,19.20586343D6,.9999422551D0,.7445203390D0, 531 * 1.7270215711D5,3.80336D0,5.06556D0, 531 * 4.3380D5,19.83265352D6,20.28911960D6,.9999145875D0,.7263957947D0, 532 * 1.6718172121D5,3.80474D0,4.80336D0, 532 * 2.8620D5,25.30502912D6,25.71512655D6,.9999407460D0,.6377729696D0, 541 * 1.4213752979D5,3.81099D0,3.77244D0, 541 * 2.9160D5,26.63932345D6,27.07062078D6,.9999256928D0,.6181953936D0, 542 * 1.3695382207D5,3.81227D0,3.58491D0, 542 * 3.2400D5,20.12413305D6,20.48917967D6,.9999453461D0,.7213707913D0, 551 * 1.6567904034D5,3.80511D0,4.73451D0, 551 * 3.2400D5,21.05074699D6,21.43091391D6,.9999407059D0,.7055766312D0, 552 * 1.6102881363D5,3.80628D0,4.52782D0, 552 * 3.2400D5,22.16143225D6,22.67213466D6,.9999325474D0,.6871032423D0, 553 * 1.5572001691D5,3.80761D0,4.30274D0/ DATA LC0 / * 2.3916D5,63.54222166D6,63.68747944D6,.9999939449D0,.3128882281D0, 431 * .6532844933D5,3.82699D0,1.51030D0, 431 * 2.3916D5,63.54222166D6,63.78747944D6,.9999939449D0,.3128882281D0, 432 * .6532844933D5,3.82699D0,1.51030D0, 432 * 6.1200D5,-82.31223465D6,-82.0D6,.9999999999D0,-.2464352205D0, * -.5110953291D5,3.82892D0,-1.16664D0/ C DATA C1/1.012794065D2/,C2/1.052893882D3/,C3/4.483344D0/, * C4/2.352D-2/,C5/2.092583216D7/,D1/9.873675553D-3/, * D2/1.04754671D3/,D3/6.19276D0/,D4/5.0912D-2/,ESQR/6.768658D-3/, * RHOSEC/2.062648062471D5/ C IF (IC.EQ.30) P = -P C L1 = 2.0D6 C ALASKA, ZONE 0 IF (IC.EQ.20) L1 = 3.0D6 C CALIFORNIA, ZONE 7 PLANEC IF (IC.EQ.67) L1 = 4.18669258D6 C CONN MASS, ZONE 1 PLANEC IF (IC.EQ.90 .OR. IC.EQ.251) L1 = 6.0D5 C MARYLAND PLANEC IF (IC.EQ.110 .OR. IC.EQ.240) L1 = 8.0D5 C MASS, ZONE 2 PLANEC IF (IC.EQ.252) L1 = 2.0D5 C PUERTO RICO SAMOA IF (IC.EQ.431.OR.IC.EQ.432 .OR. IC.EQ.30) L1 = 5.0D5 C L11 = 0.0 C ALASKA, ZONE 0 IF (IC.EQ.20) L11 = 44.D0 C LOUISIANA, ZONE 3 IF (IC.EQ.223) L11 = 25.D0 C MICHIGAN, ZONES 4 - 6 IF (IC.EQ.264) L11 = 36.D0 IF (IC.EQ.265) L11 = 35.D0 IF (IC.EQ.266) L11 = 33.D0 C L=I*8 L2=LCDATA(L-7) L3=LCDATA(L-6) L4=LCDATA(L-5) L5=LCDATA(L-4) L6=LCDATA(L-3) L78=LCDATA(L-2) L9=LCDATA(L-1) L10=LCDATA(L) C IF (ICODE.EQ.IPC) GO TO 10 SINP=DSIN(P) COSP=DCOS(P) COSP2=COSP*COSP SS=C1*(L78-P*RHOSEC+(C2-(C3-C4*COSP2)*COSP2)*SINP*COSP) S8=SS*1.0D-8 S82=S8*S8 R=L3+SS*L5*(1.D0+S82*(L9-S8*L10+S82*L11)) THETA=L6*(L2-E*RHOSEC)/RHOSEC X=L1+R*DSIN(THETA) Y=L4-R+2.D0*R*DSIN(THETA*0.5D0)**2 XK=L6*R*DSQRT(1.D0-ESQR*SINP*SINP)/C5/COSP IF (IC.EQ.264 .OR. IC.EQ.265 .OR. IC.EQ.266) XK = XK/1.0000382D0 RETURN C 10 CONTINUE THETA=DATAN((X-L1)/(L4-Y)) THSEC=THETA*RHOSEC ESEC=L2-THSEC/L6 E=ESEC/RHOSEC COSTH=DCOS(THETA) SHLFT=(DSIN(THETA/2.D0))**2 R=(L4-Y)/COSTH S1=(L4-L3-Y+2.D0*R*SHLFT)/L5 S(1)=S1 DO 20 I=1,3 FAR=S(I)*1.D-8 S(I+1)=S1/(1.D0+FAR*FAR*(L9-FAR*L10+FAR*FAR*L11)) 20 CONTINUE OMSEC=L78-D1*S(4) OMEGA=OMSEC/RHOSEC SINO=DSIN(OMEGA) COSO=DCOS(OMEGA) COS2O=COSO*COSO PSEC=OMSEC+(D2+(D3+D4*COS2O)*COS2O)*SINO*COSO P=PSEC/RHOSEC RETURN END