IMPLICIT REAL * 8 (A-H,O-Z) DIMENSION Q(64,64),XX(64),YY(64) C INPUT OF LAT. AND LONG. OF THE REQUIRED POINT GEOIDAL UNDULATION. C C C DESIRED COMPUTATED POINTS C M=64 RHO=90.0/DARSIN(1.D0) MM=8 XINC=2.0 XLAT=40.0/RHO XLON=288.0/RHO DO 25 J=1,MM XLON=XLON+XINC/RHO XINCA=0.0 II=MM*(J-1)+1 III=II+MM-1 DO 25 I=II,III XINCA=XINCA+2.0/RHO XLATI=XLAT+XINCA YY(I)=XLON 25 XX(I)=XLATI CALL GEVACO(XX,YY,Q,64,25) C C PRINT OUT THE SM-MATRIX C WRITE(6,81) M,M 81 FORMAT(/,5X,'THE VARIANCE-COVARIANCE MATRIX-Q'/,10X,'DIMENSION:(', *I3,','I3,')') CALL MATRIT(Q,64,64,64) STOP END SUBROUTINE GEVACO(XLT,XLN,Q,NRP,NDO) C THIS SUBROUTINE COMPUTE THE RESIDUALS OF GEOIDAL UNDULATIONS. C.. IMPLICIT REAL * 8(A-H,O-Z) DIMENSION XJ(348),P(26,26),XLT(1),XLN(1) DIMENSION Q(64,64),UNDSOM(348,64) DIMENSION W1(54),W2(54),W3(54),W4(54),W5(54),W6(54),W7(24) EQUIVALENCE (XJ(1),W1(1)),(XJ(55),W2(1)),(XJ(109),W3(1)) EQUIVALENCE (XJ(163),W4(1)),(XJ(217),W5(1)),(XJ(271),W6(1)) EQUIVALENCE (XJ(325),W7(1)) C...XJ CONTAINS THE FORMAL "ESTIMATED" RESIDUAL COEFFICIENTS OF C...GSFC/GEM8 FROM DEGREE N AND ORDER M (25,25) C...NDO IS THE DEGREE UP TO WHICH THE QUANTITIES ARE EVALUATED. DATA W1/ *1.0D-09, 3.0D-09, 5.0D-09, *2.0D-09, 7.0D-09, 1.1D-08, *1.4D-08, 1.0D-09, 5.0D-09, *6.0D-09, 6.0D-09, 1.1D-08, *2.0D-09, 8.0D-09, 1.2D-08, *1.3D-08, 1.4D-08, 1.8D-08, *2.0D-09, 7.0D-09, 9.0D-09, *9.0D-09, 1.2D-08, 1.0D-08, *1.5D-08, 3.0D-09, 1.0D-08, *1.4D-08, 1.5D-08, 1.6D-08, *1.6D-08, 1.6D-08, 2.2D-08, *2.0D-09, 9.0D-09, 1.2D-08, *1.2D-08, 1.4D-08, 1.2D-08, *1.6D-08, 1.2D-08, 1.7D-08, *2.0D-09, 1.2D-08, 1.6D-08, *1.8D-08, 2.0D-08, 1.7D-08, *1.9D-08, 1.8D-08, 1.7D-08, *1.1D-08, 2.0D-09, 1.0D-08/ DATA W2/ *1.5D-08, 1.6D-08, 1.7D-08, *1.6D-08, 1.7D-08, 1.4D-08, *1.7D-08, 1.1D-08, 1.6D-08, *3.0D-09, 1.4D-08, 1.7D-08, *2.1D-08, 2.0D-08, 2.1D-08, *2.0D-08, 1.8D-08, 1.9D-08, *1.2D-08, 1.6D-08, 1.7D-08, *3.0D-09, 1.1D-08, 1.5D-08, *1.9D-08, 1.8D-08, 2.1D-08, *1.8D-08, 1.8D-08, 1.8D-08, *1.1D-08, 1.5D-08, 8.0D-09, *7.0D-09, 5.0D-09, 1.4D-08, *1.9D-08, 2.1D-08, 2.2D-08, *2.2D-08, 2.0D-08, 2.1D-08, *1.8D-08, 1.3D-08, 1.7D-08, *1.2D-08, 3.0D-09, 4.0D-09, *4.0D-09, 1.4D-08, 1.6D-08, *2.1D-08, 2.0D-08, 2.2D-08/ DATA W3/ *2.1D-08, 2.1D-08, 1.7D-08, *1.4D-08, 1.6D-08, 1.0D-08, *5.0D-09, 3.0D-09, 3.0D-09, *6.0D-09, 1.3D-08, 2.1D-08, *2.1D-08, 2.3D-08, 2.4D-08, *2.1D-08, 2.3D-08, 2.0D-08, *1.6D-08, 1.7D-08, 1.4D-08, *4.0D-09, 4.0D-09, 2.0D-09, *7.0D-09, 5.0D-09, 1.5D-08, *1.9D-08, 1.9D-08, 2.4D-08, *2.2D-08, 2.3D-08, 2.4D-08, *2.1D-08, 1.6D-08, 1.6D-08, *1.5D-08, 6.0D-09, 5.0D-09, *6.0D-09, 1.2D-08, 1.9D-08, *5.0D-09, 1.7D-08, 1.9D-08, *2.6D-08, 2.5D-08, 2.4D-08, *2.9D-08, 2.4D-08, 3.0D-08, *2.1D-08, 1.9D-08, 1.7D-08/ DATA W4/ *5.0D-09, 4.0D-09, 5.0D-09, *8.0D-09, 1.2D-08, 2.2D-08, *4.0D-09, 1.6D-08, 2.1D-08, *2.8D-08, 2.4D-08, 2.8D-08, *3.0D-08, 2.6D-08, 3.1D-08, *2.6D-08, 2.0D-08, 1.7D-08, *8.0D-09, 5.0D-09, 7.0D-09, *1.9D-08, 2.3D-08, 2.4D-08, *2.8D-08, 5.0D-09, 1.8D-08, *2.5D-08, 2.5D-08, 2.8D-08, *2.9D-08, 2.8D-08, 2.8D-08, *3.0D-08, 2.7D-08, 2.6D-08, *1.8D-08, 9.0D-09, 6.0D-09, *4.0D-09, 1.5D-08, 2.1D-08, *2.3D-08, 2.5D-08, 2.7D-08, *5.0D-09, 1.6D-08, 2.5D-08, *2.1D-08, 2.7D-08, 2.8D-08, *2.7D-08, 2.8D-08, 2.8D-08/ DATA W5/ *2.6D-08, 2.7D-08, 2.0D-08, *8.0D-09, 7.0D-09, 6.0D-09, *1.8D-08, 2.1D-08, 2.3D-08, *2.4D-08, 2.7D-08, 2.8D-08, *5.0D-09, 2.0D-08, 2.2D-08, *2.3D-08, 2.6D-08, 2.7D-08, *2.6D-08, 2.6D-08, 2.6D-08, *2.6D-08, 2.6D-08, 2.2D-08, *9.0D-09, 4.0D-09, 6.0D-09, *1.5D-08, 2.0D-08, 2.1D-08, *2.1D-08, 2.5D-08, 2.6D-08, *2.7D-08, 6.0D-09, 1.7D-08, *2.2D-08, 2.4D-08, 2.3D-08, *2.5D-08, 2.5D-08, 2.5D-08, *2.4D-08, 2.4D-08, 2.4D-08, *2.2D-08, 1.0D-08, 6.0D-09, *7.0D-09, 1.6D-08, 1.9D-08, *2.0D-08, 1.8D-08, 2.2D-08/ DATA W6/ *2.4D-08, 2.5D-08, 2.6D-08, *6.0D-09, 1.5D-08, 2.1D-08, *2.2D-08, 2.1D-08, 2.3D-08, *2.4D-08, 2.3D-08, 2.3D-08, *2.3D-08, 2.3D-08, 2.2D-08, *1.3D-08, 7.0D-09, 5.0D-09, *1.3D-08, 1.8D-08, 1.9D-08, *1.6D-08, 1.9D-08, 2.1D-08, *2.2D-08, 2.3D-08, 2.3D-08, *7.0D-09, 1.6D-08, 1.9D-08, *2.0D-08, 2.0D-08, 2.0D-08, *2.1D-08, 2.2D-08, 2.1D-08, *2.1D-08, 2.1D-08, 2.0D-08, *1.5D-08, 9.0D-09, 9.0D-09, *1.4D-08, 1.9D-08, 1.8D-08, *1.5D-08, 1.7D-08, 1.8D-08, *1.9D-08, 2.0D-08, 1.9D-08, *1.8D-08, 7.0D-09, 1.5D-08/ DATA W7/ *1.5D-08, 1.6D-08, 1.6D-08, *1.6D-08, 1.6D-08, 1.6D-08, *1.5D-08, 1.6D-08, 1.5D-08, *1.5D-08, 1.3D-08, 9.0D-09, *9.0D-09, 1.1D-08, 1.4D-08, *1.4D-08, 1.3D-08, 1.4D-08, *1.5D-08, 1.5D-08, 1.6D-08, *1.6D-08, 8.0D-09, 1.7D-08/ C C CONSTANT PARAMETERS C AA=6378139.D0 F=0.33528203723803D-02 EE=0.669439934033112D-02 RMEAN=6378160.D0 C...UNDGC ARE EVALUATED USING V-C COEFF. OF GEM8(25,25) DO 60 IJK=1,348 DO 60 K=1,NRP 60 UNDSOM(IJK,K)=0.D0 DO 70 K=1,NRP XLATT=XLT(K) XLONG=XLN(K) C CALCULATE GEOCENTRIC LATITUDE XLATG XLATG=DATAN((1.D0-EE)*DTAN(XLATT)) SINLTG=DSIN(XLATG) COSLTG=DCOS(XLATG) CALL SMALL(NDO,SINLTG,COSLTG,P) IJK=0 NNN=NDO+1 DO 50 N=3,NNN NA = N - 2 DO 50 MA=1,N M = MA - 1 IJK = IJK + 1 XLONGM=XLONG*M COSM=DCOS(XLONGM) SINM=DSIN(XLONGM) UNDSOM(IJK,K)=(COSM+SINM)*P(N,MA) 50 CONTINUE 70 CONTINUE DO 100 I=1,NRP DO 100 K=1,NRP Q(I,K)=0.D0 DO 120 IJK=1,348 Q(I,K)=Q(I,K)+UNDSOM(IJK,I)*UNDSOM(IJK,K)*XJ(IJK)*XJ(IJK) 120 CONTINUE 100 Q(I,K)=RMEAN*RMEAN*Q(I,K) RETURN END SUBROUTINE SMALL(N,SINLTG,COSLTG,P) C SMALL.- THIS SUBROUTINE COMPUTE THE ASSOCIATE LEGENGRE FUNCTIONS C WHICH ARE CUMPUTED AS "FULLY NORMALIZED LEGENDRE FUNCTIONS" FOR A SET C OF HARMONIC COEFFICIENTS OF GRADE N AND ORDER M. C IMPLICIT REAL * 8 (A-H,O-Z) DIMENSION P(26,26) N1=N+1 DO 40 I=1,N1 DO 40 J=1,N1 40 P(I,J) =0.D0 P(1,1)=1.0 P(1,2)=COSLTG*1.732050808 P(2,1)=SINLTG*1.732050808 P(2,2)=P(1,2) C C COMPUTATION OF SECTORIAL FUNCTIONS C N=M C P2=2.0 COSP=COSLTG DO 50 I=3,N1 N2=I-1 P2=P2*2.0 COSP=COSP*COSLTG T=(4.0*N2+2.0)*FACT(2*N2,N2-1)/FACT(N2-1,0) P(I,I)=DSQRT(T/(N2*N2))*COSP/P2 50 CONTINUE C C COMPUTATION OF ZONAL ZND TESSERAL FUNCTIONS. C DO 70 I=3,N1 N2=I-1 DO 70 J=1,N2 M=J-1 70 P(I,J)=DSQRT((2.D0*N2-1.0)*(2*N2+1.0)/((N2-M)*(N2+M)))*SINLTG*P(I- *1,J)-DSQRT((2.D0*N2+1.0)*(N2+M-1.0)*(N2-M-1)/((2.0*N2-3)*(N2-M)*(N *2+M)))*P(I-2,J) RETURN END DOUBLE PRECISION FUNCTION FACT(N,M) C CALCULATE FACT N/FACT M. C RESTRICTION.- N MUST BE GREATER OR EQUAL TO M C IF((N.EQ.0).OR.(N.EQ.1).OR.(N.EQ.M)) GOTO 20 FACT=N N1=N K=N-M-1 DO 10 I=1,K N1=N1-1 10 FACT=FACT*N1 RETURN 20 FACT=1.0 RETURN