SUBROUTINE LEGDRE(INORM,PHI,PN,NROW,NP1) C C C SUBROUTINE LEGDRE COMPUTES THE ASSOCIATED LEGENDRE FUNCTIONS C UP TO AND INCLUDING DEGREE AND ORDER N TO BE SPECIFIED. THE C DIMENSION OF PN IS PN(N+1,N+1). THE ASSOCIATED LEGENDRE POLY- C NOMIAL OF DEGREE A AND ORDER B IS STORED IN PN(A+1,B+1) IF A.NE.B C (ZONAL AND TESSERAL) AND IN PN(A+1,A+1) IF A = B (SECTORIAL) C C INORM = FLAG FOR NORMALIZATION: 1 = YES; 0 = NO C PHI = LATITUDE IN DEGREES C NROW = ROW DIMENSION OF PN IN THE CALLING PROGRAM C NP1= N + 1 = THE DIMENSION OF PN IN THE SUBROUTINE. SEE N BELOW C N = DEGREE OF LEGENDRE POLYNOMIAL C C C IMPLICIT REAL*8(A-H,O-Z) DOUBLE PRECISION PN(NROW,NP1) DATA DR/0.017453293D0/ N=NP1-1 N1=NP1 PHI=PHI*DR X =DSIN(PHI) DO 9 I=1,NROW DO 9 J=1,NP1 9 PN(I,J) = 0.0D0 PN(1,1) = 1.0D0 PN(2,1) = X PN(2,2) = 1.0D0 DO 15 I = 2,N I1 = I + 1 DO 10 J = 1,I1 IF(J .NE. 1) GO TO 11 PN(I1,J) = (1./I)*(X*(2.*I-1)*PN(I1-1,J) - (I-1)*PN(I1-2,J)) GO TO 10 11 IF(J.NE.2 .AND. I.NE.2) GO TO 12 PN(I1,J) = PN(I1-2,J) + (2.*I-1)*PN(I1-1,J-1) GO TO 10 12 IF(J.NE.(I1-1).AND.J.NE.I1) GO TO 13 PN(I1,J) = (2.*I-1)*PN(I1-1,J-1) GO TO 10 13 PN(I1,J) = PN(I1-2,J) + (2.*I-1)*PN(I1-1,J-1) 10 CONTINUE 15 CONTINUE DO 16 I = 1,N I1 = I + 1 DO 16 J = 1,I J1 = J + 1 COSPHI = DCOS(PHI) IF(COSPHI.EQ.0.D0) GO TO 20 GO TO 21 20 PN(I1,J1) = 0.D0 GO TO 16 21 PN(I1,J1) = (COSPHI**J)*PN(I1,J1) 16 CONTINUE IF(INORM.EQ.0) GO TO 14 N1 = N + 1 DO 17 I = 1,N1 17 PN(I,1) = DSQRT(2.D0*(I-1) + 1)*PN(I,1) DO 18 I = 1,N I1 = I + 1 DO 18 J = 1,I J1 = J + 1 NMM = I - J NPM = I + J FTERM = FACT(NMM) / FACT(NPM) NPOWER = NMM - NPM IF(MOD(NPOWER,2).EQ.0) GO TO 502 NPOWER = NPOWER + 1 FTERM = FTERM / 10D0 502 FTERM = DSQRT(FTERM) NPOWER = NPOWER / 2 FTERM = FTERM*10.**NPOWER 18 PN(I1,J1) = DSQRT(2.D0*(2.D0*I+1.D0))*FTERM*PN(I1,J1) 14 RETURN END FUNCTION FACT(N) IMPLICIT REAL*8(A-H,O-Z) DIMENSION FA(59),FB(59),FMAN(118),NEXP(118) EQUIVALENCE (FA(1),FMAN(1)),(FB(1),FMAN(60)) DATA FA/0.1,0.2,0.6,0.24,0.12,0.72,0.504,0.4032,0.36288,0.36288, &0.399168,0.4790016,0.62270208,0.871782912,0.1307674368, &0.20922789888,0.355687428096,0.6402373705728,0.1216451004088320, &0.2432902008176640,0.5109094217170944,0.1124000727777608, &0.2585201673888497,0.6204484017332395,0.1551121004333098, &0.4032914611266056,0.1088886945041835,0.3048883446117138, &0.8841761993739699,0.2652528598121910,0.8222838654177920, &0.2631308369336934,0.8683317618811883,0.2952327990396040, &0.1033314796638614,0.3719933267899011,0.1376375309122634, &0.5230226174666009,0.2039788208119743,0.8159152832478973, &0.3345252661316379,0.1405006117752879,0.6041526306337380, &0.2658271574788447,0.1196222208654801,0.5502622159812085, &0.2586232415111680,0.1241391559253606,0.6082818640342671, &0.3041409320171335,0.1551118753287381,0.8065817517094379, &0.4274883284060022,0.2308436973392412,0.1269640335365826, &0.7109985878048627,0.4052691950487717,0.2350561331282876, &0.1386831185456896/ DATA FB/0.8320987112741378,0.5075802138772241,0.3146997326038789, &0.1982608315404437,0.1268869321858840,0.8247650592082458, &0.5443449390774422,0.3647111091818862,0.2480035542436826, &0.1711224524281410,0.1197857166996987,0.8504785885678606, &0.6123445837688597,0.4470115461512676,0.3307885441519380, &0.2480914081139535,0.1885494701666046,0.1451830920282856, &0.1332428117820627,0.8946182130782955,0.7156945704626364, &0.5797126020747355,0.4753643337012831,0.3945523969720649, &0.3314240134565345,0.2817104114380543,0.2422709538367267, &0.2107757298379522,0.1854826422573979,0.1650795516090842, &0.1485715964481757,0.1352001527678399,0.1243841405464127, &0.1156772507081638,0.1087366156656740,0.1032997848823903, &0.9916779348709466,0.9619275968248181,0.9426890448883216, &0.9332621544394384,0.9332621544394384,0.9425947759838328, &0.9614466715035094,0.9902900716486147,0.1029901674514559, &0.1081396758240287,0.1146280563734704,0.1226520203196134, &0.1324641819451824,0.1443859583202488,0.1588245541522737, &0.1762952551090238,0.1974506857221067,0.2231192748659805, &0.2543559733472178,0.2925093693493005,0.3393108684451886, &0.3969937160808705,0.4684525849754272/ DATA NEXP/1,1,1,2,3,3,4,5,6,7,8,9,10,11,13,14,15,16,17,19,20,22, &23,24,26,27,29,30,31,33,34,36,37,39,41,42,44,45,47,48,50,52,53, &55,57,58,60,62,63,65,67,68,70,72,74,75,77,79,81,82,84,86,88,90,91, &93,95,97,99,101,102,104,106,108,110,112,114,116,117,119,121,123, &125,127,129,131,133,135,137,139,141,143,145,147,148,150,152,154, &156,158,160,162,164,167,169,171,173,175,177,179,181,183,185,187, &189,191,193,195/ C IF(N.LT.0) GO TO 51 IF(N.EQ.0) N = 1 IF(N.GT.118) GO TO 52 FACT = FMAN(N) N = NEXP(N) RETURN 51 WRITE(6,301) N 301 FORMAT(/////,'FACTORIAL FUNCTION HAS BEEN GIVEN A NEGATIVE ARGUMEN #T: N=',I6) STOP 52 WRITE(6,302) N 302 FORMAT(/////,'ARGUMENT OF THE FACTORIAL FUNCTION IS GREATER THAN #118: N=',I10) STOP END