** Name: ** gennavblk - make a navigation block ** ** Interface: ** integer function ** gennavblk( character*(*) projection, character*(*) pole, ** double precision parms(*), integer nav(*) ) ** ** Input: ** projection - projection name ** pole - NORTH or SOUTH pole of planet ** parms - navigation parameters ** ** Input and Output: ** none ** ** Output: ** nav - navigation block ** ** Return values: ** 0 - success ** -1 - failed: invalid planet ** -2 - failed: invalid projection ** ** Remarks: ** valid projections are MERC, PS and LAMB ** ** Categories: ** adde ** image integer function gennavblk( projection, pole, parms,res, nav ) implicit none c --- parameters character*(*) projection character*(*) pole double precision parms(*) integer res integer nav(*) c --- constants integer NUM_PLANET parameter (NUM_PLANET = 8) c --- external functions integer ilalo integer lit integer mccmdstr c --- internal variables character*12 planet ! planet name character*12 planet_name(NUM_PLANET) ! valid planets character*80 cwrite double precision planet_eccentricity(NUM_PLANET) ! plant eccentricities integer ipowlat integer ipowlon integer ipowlin integer ipowele integer ipowrad integer ipowecc integer eccentricity ! eccentricity integer i ! loop index integer radius ! planet radius integer status ! function status real degpkm ! degrees/kilometer real exp ! 10 to a power (temp) real planet_degpkm(NUM_PLANET) ! planet degrees/kilometer real planet_radius(NUM_PLANET) ! planet radi c --- plantery info data planet_name/'MERCURY','VENUS', 'EARTH','MARS','JUPITER', & 'SATURN', 'URANUS','NEPTUNE'/ data planet_radius/2440., 6120., 6378.137, 3393.5, 71400., & 60330., 25900., 24750./ data planet_eccentricity/0.D0, 0.D0, 0.08181919D0, 0.1333386D0, & 0.35412D0, 0.41019D0, 0.2086D0, 0.2D0/ data planet_degpkm/0.0, 0.0, 111.137, 0.0, 0.0, & 0.0, 0.0, 0.0/ c call sdest('INTO GENNAVBLK --- Kevin Code Version',0) c call sdest(' Projection='//projection(1:4),0) c --- get planet name status = mccmdstr('PLA.NET',1,'EARTH',planet) if( status.lt.0 ) then gennavblk = -1 return endif c --- check planet do 10 i=1,NUM_PLANET if( planet.eq.planet_name(i) ) then radius = NINT( planet_radius(i) * 1000. ) eccentricity = IDNINT( planet_eccentricity(i) * 1.0D6 ) degpkm = planet_degpkm(i) goto 11 endif 10 continue gennavblk = -1 return c --- Polar Sterographic 'PS' projection 11 if( projection(1:4).eq.'PS' ) then nav(1) = lit( 'PS ' ) nav(2) = IDINT( parms(1) ) nav(3) = IDINT( parms(2) ) nav(4) = ilalo( REAL( parms(3) ) ) if( parms(4).lt.1000.0D0 ) then nav(5) = IDNINT( parms(4) * 1000.0D0 ) else nav(5) = IDNINT( parms(4) * 0.00057D0 ) endif nav(6) = ilalo( REAL( parms(5) ) ) nav(7) = radius nav(8) = eccentricity if( planet_name(i).ne.'EARTH' ) then nav(9) = -1 nav(10) = -1 endif nav(11) = 900000 if( pole(1:1).eq.'S' ) nav(11) = -900000 c --- Lambert Conformal 'LAMB' projection elseif( projection(1:4).eq.'LAMB' ) then nav(1) = lit( 'LAMB' ) nav(2) = IDINT( parms(1) ) nav(3) = IDINT( parms(2) ) nav(4) = ilalo( REAL( parms(3) ) ) nav(5) = ilalo( REAL( parms(4) ) ) if( parms(5).lt.1000.0D0 ) then nav(6) = IDNINT( parms(5) * 1000.0D0 ) else nav(6) = IDNINT( parms(5) * 0.00057D0 ) endif nav(7) = ilalo( REAL( parms(6) ) ) nav(8) = radius nav(9) = eccentricity if( planet_name(i).ne.'EARTH' ) then nav(10) = -1 nav(11) = -1 endif nav(12) = 900000 if( pole(1:1).eq.'S' ) nav(12) = -900000 c --- Tangent Cone 'TANC' projection elseif( projection(1:4) .eq.'TANC' ) then nav(1) = lit( 'TANC' ) nav(2) = IDNINT( parms(1)*10000.D0) nav(3) = IDNINT( parms(2)*10000.D0) nav(5) = IDNINT( parms(4)*10000.D0) nav(6) = IDNINT( parms(5)*10000.D0) if( parms(3).lt.1000.0D0 ) then nav(4) = IDNINT(parms(3)*10000.D0) else nav(4) = IDNINT(parms(3)*0.0057D0) endif c --- Mercator 'MERC' projection elseif( projection(1:4).eq.'MERC' ) then nav(1) = lit( 'MERC' ) nav(2) = IDINT( parms(1) ) nav(3) = IDINT( parms(2) ) nav(4) = ilalo( REAL( parms(3) ) ) if( parms(5).lt.1000.0D0 ) then nav(5) = IDNINT( parms(5) * 1000.0D0 ) else nav(5) = IDNINT( parms(5) * .00057 ) endif nav(6) = ilalo( REAL( parms(4) ) ) nav(7) = radius nav(8) = eccentricity if( planet_name(i).ne.'EARTH' ) then nav(9) = -1 nav(10) = -1 endif c --- Mollweide 'MOLL' projection elseif( projection(1:4).eq.'MOLL' ) then nav(1) = lit( 'MOLL' ) nav(2) = IDINT( parms(1) ) nav(3) = IDINT( parms(2) ) nav(4) = IDINT( parms(3) ) nav(5) = IDINT( parms(4) ) nav(7) = radius nav(8) = eccentricity if( planet_name(i).ne.'EARTH' ) then nav(9) = -1 nav(10) = -1 endif c** KMPP (KiloMeters Per Pixel) nav(15) = LIT('KMPP') c --- Radar 'RADR' projection elseif( projection(1:4).eq.'RADA' ) then nav(1) = lit( 'RADR' ) nav(2) = IDNINT( parms(1) ) nav(3) = IDNINT( parms(2) ) nav(4) = ilalo( REAL(parms(3)) ) nav(5) = ilalo( REAL(parms(4)) ) nav(6) = ( REAL( parms(5))) * 1000. nav(7) = ( REAL( parms(6))) * 1000. c --- Rectilinear 'RECT' projection elseif( projection(1:4).eq.'RECT' ) then if (res.eq.4) then ipowlat=4 ipowlon=4 ipowlin=6 ipowele=6 ipowrad=3 ipowecc=6 elseif (res.eq.2) then ipowlat=4 ipowlon=4 c ipowlin=5 c ipowele=8 ipowlin=6 ipowele=6 ipowrad=3 ipowecc=6 elseif (res.eq.1) then ipowlat=4 ipowlon=4 ipowlin=6 ipowele=6 ipowrad=3 ipowecc=6 endif nav(1) = lit( 'RECT' ) nav(2) = IDNINT( parms(1) ) c nav(3) = ilalo( REAL(parms(2)) ) exp = 10.**ipowlat nav(3) = REAL(parms(2))*exp write(cwrite,'(2f11.6,i7)') & exp,parms(2),nav(3) call ddest(cwrite,0) nav(4) = IDNINT( parms(3) ) c nav(5) = ilalo( REAL(parms(4)) ) nav(5) = REAL(parms(4))*exp exp = 10.**ipowlin nav(6) = (exp*REAL( parms(5))/degpkm ) nav(7) = nav(6) nav(8) = radius nav(9) = eccentricity if( planet_name(i).ne.'EARTH' ) then nav(10) = -1 nav(11) = -1 endif nav(12)=ipowlat nav(13)=ipowlon nav(14)=ipowlin nav(15)=ipowele nav(16)=ipowrad nav(17)=ipowecc c --- Sinusoidal Equal Area 'SIN' projection elseif( projection(1:4).eq.'SIN' ) then nav(1) = lit( 'SIN' ) nav(2) = IDNINT( parms(1) ) nav(3) = IDNINT( parms(2) ) nav(4) = ilalo( REAL(parms(3)) ) nav(5) = ilalo( REAL(parms(4)) ) nav(6) = ( REAL( parms(5))) * 1000. nav(7) = radius nav(8) = eccentricity if( planet_name(i).ne.'EARTH' ) then nav(9) = -1 nav(10) = -1 endif c --- unsupported projection else gennavblk = -2 return endif gennavblk = 0 return end