| 1 | SUBROUTINE ZWGL (Z,W,NP)
|
|---|
| 2 | C--------------------------------------------------------------------
|
|---|
| 3 | C
|
|---|
| 4 | C Generate NP Gauss Legendre points (Z) and weights (W)
|
|---|
| 5 | C associated with Jacobi polynomial P(N)(alpha=0,beta=0).
|
|---|
| 6 | C The polynomial degree N=NP-1.
|
|---|
| 7 | C Z and W are in single precision, but all the arithmetic
|
|---|
| 8 | C operations are done in double precision.
|
|---|
| 9 | C
|
|---|
| 10 | C--------------------------------------------------------------------
|
|---|
| 11 | REAL Z(1),W(1)
|
|---|
| 12 | ALPHA = 0.
|
|---|
| 13 | BETA = 0.
|
|---|
| 14 | CALL ZWGJ (Z,W,NP,ALPHA,BETA)
|
|---|
| 15 | RETURN
|
|---|
| 16 | END
|
|---|
| 17 | C
|
|---|
| 18 | SUBROUTINE ZWGLL (Z,W,NP)
|
|---|
| 19 | C--------------------------------------------------------------------
|
|---|
| 20 | C
|
|---|
| 21 | C Generate NP Gauss-Lobatto Legendre points (Z) and weights (W)
|
|---|
| 22 | C associated with Jacobi polynomial P(N)(alpha=0,beta=0).
|
|---|
| 23 | C The polynomial degree N=NP-1.
|
|---|
| 24 | C Z and W are in single precision, but all the arithmetic
|
|---|
| 25 | C operations are done in double precision.
|
|---|
| 26 | C
|
|---|
| 27 | C--------------------------------------------------------------------
|
|---|
| 28 | REAL Z(1),W(1)
|
|---|
| 29 | ALPHA = 0.
|
|---|
| 30 | BETA = 0.
|
|---|
| 31 | CALL ZWGLJ (Z,W,NP,ALPHA,BETA)
|
|---|
| 32 | RETURN
|
|---|
| 33 | END
|
|---|
| 34 | C
|
|---|
| 35 | SUBROUTINE ZWGJ (Z,W,NP,ALPHA,BETA)
|
|---|
| 36 | C--------------------------------------------------------------------
|
|---|
| 37 | C
|
|---|
| 38 | C Generate NP GAUSS JACOBI points (Z) and weights (W)
|
|---|
| 39 | C associated with Jacobi polynomial P(N)(alpha>-1,beta>-1).
|
|---|
| 40 | C The polynomial degree N=NP-1.
|
|---|
| 41 | C Single precision version.
|
|---|
| 42 | C
|
|---|
| 43 | C--------------------------------------------------------------------
|
|---|
| 44 | PARAMETER (NMAX=84)
|
|---|
| 45 | PARAMETER (lzd = NMAX)
|
|---|
| 46 | REAL*8 ZD(lzd),WD(lzd),ALPHAD,BETAD
|
|---|
| 47 | REAL Z(1),W(1),ALPHA,BETA
|
|---|
| 48 | C
|
|---|
| 49 | NPMAX = lzd
|
|---|
| 50 | IF (NP.GT.NPMAX) THEN
|
|---|
| 51 | WRITE (6,*) 'Too large polynomial degree in ZWGJ'
|
|---|
| 52 | WRITE (6,*) 'Maximum polynomial degree is',NMAX
|
|---|
| 53 | WRITE (6,*) 'Here NP=',NP
|
|---|
| 54 | call exitt
|
|---|
| 55 | ENDIF
|
|---|
| 56 | ALPHAD = ALPHA
|
|---|
| 57 | BETAD = BETA
|
|---|
| 58 | CALL ZWGJD (ZD,WD,NP,ALPHAD,BETAD)
|
|---|
| 59 | DO 100 I=1,NP
|
|---|
| 60 | Z(I) = ZD(I)
|
|---|
| 61 | W(I) = WD(I)
|
|---|
| 62 | 100 CONTINUE
|
|---|
| 63 | RETURN
|
|---|
| 64 | END
|
|---|
| 65 | C
|
|---|
| 66 | SUBROUTINE ZWGJD (Z,W,NP,ALPHA,BETA)
|
|---|
| 67 | C--------------------------------------------------------------------
|
|---|
| 68 | C
|
|---|
| 69 | C Generate NP GAUSS JACOBI points (Z) and weights (W)
|
|---|
| 70 | C associated with Jacobi polynomial P(N)(alpha>-1,beta>-1).
|
|---|
| 71 | C The polynomial degree N=NP-1.
|
|---|
| 72 | C Double precision version.
|
|---|
| 73 | C
|
|---|
| 74 | C--------------------------------------------------------------------
|
|---|
| 75 | IMPLICIT REAL*8 (A-H,O-Z)
|
|---|
| 76 | REAL*8 Z(1),W(1),ALPHA,BETA
|
|---|
| 77 | C
|
|---|
| 78 | N = NP-1
|
|---|
| 79 | DN = ((N))
|
|---|
| 80 | ONE = 1.
|
|---|
| 81 | TWO = 2.
|
|---|
| 82 | APB = ALPHA+BETA
|
|---|
| 83 | C
|
|---|
| 84 | IF (NP.LE.0) THEN
|
|---|
| 85 | WRITE (6,*) 'ZWGJD: Minimum number of Gauss points is 1',np
|
|---|
| 86 | call exitt
|
|---|
| 87 | ENDIF
|
|---|
| 88 | IF ((ALPHA.LE.-ONE).OR.(BETA.LE.-ONE)) THEN
|
|---|
| 89 | WRITE (6,*) 'ZWGJD: Alpha and Beta must be greater than -1'
|
|---|
| 90 | call exitt
|
|---|
| 91 | ENDIF
|
|---|
| 92 | C
|
|---|
| 93 | IF (NP.EQ.1) THEN
|
|---|
| 94 | Z(1) = (BETA-ALPHA)/(APB+TWO)
|
|---|
| 95 | W(1) = GAMMAF(ALPHA+ONE)*GAMMAF(BETA+ONE)/GAMMAF(APB+TWO)
|
|---|
| 96 | $ * TWO**(APB+ONE)
|
|---|
| 97 | RETURN
|
|---|
| 98 | ENDIF
|
|---|
| 99 | C
|
|---|
| 100 | CALL JACG (Z,NP,ALPHA,BETA)
|
|---|
| 101 | C
|
|---|
| 102 | NP1 = N+1
|
|---|
| 103 | NP2 = N+2
|
|---|
| 104 | DNP1 = ((NP1))
|
|---|
| 105 | DNP2 = ((NP2))
|
|---|
| 106 | FAC1 = DNP1+ALPHA+BETA+ONE
|
|---|
| 107 | FAC2 = FAC1+DNP1
|
|---|
| 108 | FAC3 = FAC2+ONE
|
|---|
| 109 | FNORM = PNORMJ(NP1,ALPHA,BETA)
|
|---|
| 110 | RCOEF = (FNORM*FAC2*FAC3)/(TWO*FAC1*DNP2)
|
|---|
| 111 | DO 100 I=1,NP
|
|---|
| 112 | CALL JACOBF (P,PD,PM1,PDM1,PM2,PDM2,NP2,ALPHA,BETA,Z(I))
|
|---|
| 113 | W(I) = -RCOEF/(P*PDM1)
|
|---|
| 114 | 100 CONTINUE
|
|---|
| 115 | RETURN
|
|---|
| 116 | END
|
|---|
| 117 | C
|
|---|
| 118 | SUBROUTINE ZWGLJ (Z,W,NP,ALPHA,BETA)
|
|---|
| 119 | C--------------------------------------------------------------------
|
|---|
| 120 | C
|
|---|
| 121 | C Generate NP GAUSS LOBATTO JACOBI points (Z) and weights (W)
|
|---|
| 122 | C associated with Jacobi polynomial P(N)(alpha>-1,beta>-1).
|
|---|
| 123 | C The polynomial degree N=NP-1.
|
|---|
| 124 | C Single precision version.
|
|---|
| 125 | C
|
|---|
| 126 | C--------------------------------------------------------------------
|
|---|
| 127 | PARAMETER (NMAX=84)
|
|---|
| 128 | PARAMETER (lzd = NMAX)
|
|---|
| 129 | REAL*8 ZD(lzd),WD(lzd),ALPHAD,BETAD
|
|---|
| 130 | REAL Z(1),W(1),ALPHA,BETA
|
|---|
| 131 | C
|
|---|
| 132 | NPMAX = lzd
|
|---|
| 133 | IF (NP.GT.NPMAX) THEN
|
|---|
| 134 | WRITE (6,*) 'Too large polynomial degree in ZWGLJ'
|
|---|
| 135 | WRITE (6,*) 'Maximum polynomial degree is',NMAX
|
|---|
| 136 | WRITE (6,*) 'Here NP=',NP
|
|---|
| 137 | call exitt
|
|---|
| 138 | ENDIF
|
|---|
| 139 | ALPHAD = ALPHA
|
|---|
| 140 | BETAD = BETA
|
|---|
| 141 | CALL ZWGLJD (ZD,WD,NP,ALPHAD,BETAD)
|
|---|
| 142 | DO 100 I=1,NP
|
|---|
| 143 | Z(I) = ZD(I)
|
|---|
| 144 | W(I) = WD(I)
|
|---|
| 145 | 100 CONTINUE
|
|---|
| 146 | RETURN
|
|---|
| 147 | END
|
|---|
| 148 | C
|
|---|
| 149 | SUBROUTINE ZWGLJD (Z,W,NP,ALPHA,BETA)
|
|---|
| 150 | C--------------------------------------------------------------------
|
|---|
| 151 | C
|
|---|
| 152 | C Generate NP GAUSS LOBATTO JACOBI points (Z) and weights (W)
|
|---|
| 153 | C associated with Jacobi polynomial P(N)(alpha>-1,beta>-1).
|
|---|
| 154 | C The polynomial degree N=NP-1.
|
|---|
| 155 | C Double precision version.
|
|---|
| 156 | C
|
|---|
| 157 | C--------------------------------------------------------------------
|
|---|
| 158 | IMPLICIT REAL*8 (A-H,O-Z)
|
|---|
| 159 | REAL*8 Z(NP),W(NP),ALPHA,BETA
|
|---|
| 160 | C
|
|---|
| 161 | N = NP-1
|
|---|
| 162 | NM1 = N-1
|
|---|
| 163 | ONE = 1.
|
|---|
| 164 | TWO = 2.
|
|---|
| 165 | C
|
|---|
| 166 | IF (NP.LE.1) THEN
|
|---|
| 167 | WRITE (6,*) 'ZWGLJD: Minimum number of Gauss-Lobatto points is 2'
|
|---|
| 168 | WRITE (6,*) 'ZWGLJD: alpha,beta:',alpha,beta,np
|
|---|
| 169 | call exitt
|
|---|
| 170 | ENDIF
|
|---|
| 171 | IF ((ALPHA.LE.-ONE).OR.(BETA.LE.-ONE)) THEN
|
|---|
| 172 | WRITE (6,*) 'ZWGLJD: Alpha and Beta must be greater than -1'
|
|---|
| 173 | call exitt
|
|---|
| 174 | ENDIF
|
|---|
| 175 | C
|
|---|
| 176 | IF (NM1.GT.0) THEN
|
|---|
| 177 | ALPG = ALPHA+ONE
|
|---|
| 178 | BETG = BETA+ONE
|
|---|
| 179 | CALL ZWGJD (Z(2:NP),W(2:NP ),NM1,ALPG,BETG)
|
|---|
| 180 | ENDIF
|
|---|
| 181 | Z(1) = -ONE
|
|---|
| 182 | Z(NP) = ONE
|
|---|
| 183 | DO 100 I=2,NP-1
|
|---|
| 184 | W(I) = W(I)/(ONE-Z(I)**2)
|
|---|
| 185 | 100 CONTINUE
|
|---|
| 186 | CALL JACOBF (P,PD,PM1,PDM1,PM2,PDM2,N,ALPHA,BETA,Z(1))
|
|---|
| 187 | W(1) = ENDW1 (N,ALPHA,BETA)/(TWO*PD)
|
|---|
| 188 | CALL JACOBF (P,PD,PM1,PDM1,PM2,PDM2,N,ALPHA,BETA,Z(NP))
|
|---|
| 189 | W(NP) = ENDW2 (N,ALPHA,BETA)/(TWO*PD)
|
|---|
| 190 | C
|
|---|
| 191 | RETURN
|
|---|
| 192 | END
|
|---|
| 193 | C
|
|---|
| 194 | REAL*8 FUNCTION ENDW1 (N,ALPHA,BETA)
|
|---|
| 195 | IMPLICIT REAL*8 (A-H,O-Z)
|
|---|
| 196 | REAL*8 ALPHA,BETA
|
|---|
| 197 | ZERO = 0.
|
|---|
| 198 | ONE = 1.
|
|---|
| 199 | TWO = 2.
|
|---|
| 200 | THREE = 3.
|
|---|
| 201 | FOUR = 4.
|
|---|
| 202 | APB = ALPHA+BETA
|
|---|
| 203 | IF (N.EQ.0) THEN
|
|---|
| 204 | ENDW1 = ZERO
|
|---|
| 205 | RETURN
|
|---|
| 206 | ENDIF
|
|---|
| 207 | F1 = GAMMAF(ALPHA+TWO)*GAMMAF(BETA+ONE)/GAMMAF(APB+THREE)
|
|---|
| 208 | F1 = F1*(APB+TWO)*TWO**(APB+TWO)/TWO
|
|---|
| 209 | IF (N.EQ.1) THEN
|
|---|
| 210 | ENDW1 = F1
|
|---|
| 211 | RETURN
|
|---|
| 212 | ENDIF
|
|---|
| 213 | FINT1 = GAMMAF(ALPHA+TWO)*GAMMAF(BETA+ONE)/GAMMAF(APB+THREE)
|
|---|
| 214 | FINT1 = FINT1*TWO**(APB+TWO)
|
|---|
| 215 | FINT2 = GAMMAF(ALPHA+TWO)*GAMMAF(BETA+TWO)/GAMMAF(APB+FOUR)
|
|---|
| 216 | FINT2 = FINT2*TWO**(APB+THREE)
|
|---|
| 217 | F2 = (-TWO*(BETA+TWO)*FINT1 + (APB+FOUR)*FINT2)
|
|---|
| 218 | $ * (APB+THREE)/FOUR
|
|---|
| 219 | IF (N.EQ.2) THEN
|
|---|
| 220 | ENDW1 = F2
|
|---|
| 221 | RETURN
|
|---|
| 222 | ENDIF
|
|---|
| 223 | DO 100 I=3,N
|
|---|
| 224 | DI = ((I-1))
|
|---|
| 225 | ABN = ALPHA+BETA+DI
|
|---|
| 226 | ABNN = ABN+DI
|
|---|
| 227 | A1 = -(TWO*(DI+ALPHA)*(DI+BETA))/(ABN*ABNN*(ABNN+ONE))
|
|---|
| 228 | A2 = (TWO*(ALPHA-BETA))/(ABNN*(ABNN+TWO))
|
|---|
| 229 | A3 = (TWO*(ABN+ONE))/((ABNN+TWO)*(ABNN+ONE))
|
|---|
| 230 | F3 = -(A2*F2+A1*F1)/A3
|
|---|
| 231 | F1 = F2
|
|---|
| 232 | F2 = F3
|
|---|
| 233 | 100 CONTINUE
|
|---|
| 234 | ENDW1 = F3
|
|---|
| 235 | RETURN
|
|---|
| 236 | END
|
|---|
| 237 | C
|
|---|
| 238 | REAL*8 FUNCTION ENDW2 (N,ALPHA,BETA)
|
|---|
| 239 | IMPLICIT REAL*8 (A-H,O-Z)
|
|---|
| 240 | REAL*8 ALPHA,BETA
|
|---|
| 241 | ZERO = 0.
|
|---|
| 242 | ONE = 1.
|
|---|
| 243 | TWO = 2.
|
|---|
| 244 | THREE = 3.
|
|---|
| 245 | FOUR = 4.
|
|---|
| 246 | APB = ALPHA+BETA
|
|---|
| 247 | IF (N.EQ.0) THEN
|
|---|
| 248 | ENDW2 = ZERO
|
|---|
| 249 | RETURN
|
|---|
| 250 | ENDIF
|
|---|
| 251 | F1 = GAMMAF(ALPHA+ONE)*GAMMAF(BETA+TWO)/GAMMAF(APB+THREE)
|
|---|
| 252 | F1 = F1*(APB+TWO)*TWO**(APB+TWO)/TWO
|
|---|
| 253 | IF (N.EQ.1) THEN
|
|---|
| 254 | ENDW2 = F1
|
|---|
| 255 | RETURN
|
|---|
| 256 | ENDIF
|
|---|
| 257 | FINT1 = GAMMAF(ALPHA+ONE)*GAMMAF(BETA+TWO)/GAMMAF(APB+THREE)
|
|---|
| 258 | FINT1 = FINT1*TWO**(APB+TWO)
|
|---|
| 259 | FINT2 = GAMMAF(ALPHA+TWO)*GAMMAF(BETA+TWO)/GAMMAF(APB+FOUR)
|
|---|
| 260 | FINT2 = FINT2*TWO**(APB+THREE)
|
|---|
| 261 | F2 = (TWO*(ALPHA+TWO)*FINT1 - (APB+FOUR)*FINT2)
|
|---|
| 262 | $ * (APB+THREE)/FOUR
|
|---|
| 263 | IF (N.EQ.2) THEN
|
|---|
| 264 | ENDW2 = F2
|
|---|
| 265 | RETURN
|
|---|
| 266 | ENDIF
|
|---|
| 267 | DO 100 I=3,N
|
|---|
| 268 | DI = ((I-1))
|
|---|
| 269 | ABN = ALPHA+BETA+DI
|
|---|
| 270 | ABNN = ABN+DI
|
|---|
| 271 | A1 = -(TWO*(DI+ALPHA)*(DI+BETA))/(ABN*ABNN*(ABNN+ONE))
|
|---|
| 272 | A2 = (TWO*(ALPHA-BETA))/(ABNN*(ABNN+TWO))
|
|---|
| 273 | A3 = (TWO*(ABN+ONE))/((ABNN+TWO)*(ABNN+ONE))
|
|---|
| 274 | F3 = -(A2*F2+A1*F1)/A3
|
|---|
| 275 | F1 = F2
|
|---|
| 276 | F2 = F3
|
|---|
| 277 | 100 CONTINUE
|
|---|
| 278 | ENDW2 = F3
|
|---|
| 279 | RETURN
|
|---|
| 280 | END
|
|---|
| 281 | C
|
|---|
| 282 | REAL*8 FUNCTION GAMMAF (X)
|
|---|
| 283 | IMPLICIT REAL*8 (A-H,O-Z)
|
|---|
| 284 | REAL*8 X
|
|---|
| 285 | ZERO = 0.0
|
|---|
| 286 | HALF = 0.5
|
|---|
| 287 | ONE = 1.0
|
|---|
| 288 | TWO = 2.0
|
|---|
| 289 | FOUR = 4.0
|
|---|
| 290 | PI = FOUR*ATAN(ONE)
|
|---|
| 291 | GAMMAF = ONE
|
|---|
| 292 | IF (X.EQ.-HALF) GAMMAF = -TWO*SQRT(PI)
|
|---|
| 293 | IF (X.EQ. HALF) GAMMAF = SQRT(PI)
|
|---|
| 294 | IF (X.EQ. ONE ) GAMMAF = ONE
|
|---|
| 295 | IF (X.EQ. TWO ) GAMMAF = ONE
|
|---|
| 296 | IF (X.EQ. 1.5 ) GAMMAF = SQRT(PI)/2.
|
|---|
| 297 | IF (X.EQ. 2.5) GAMMAF = 1.5*SQRT(PI)/2.
|
|---|
| 298 | IF (X.EQ. 3.5) GAMMAF = 0.5*(2.5*(1.5*SQRT(PI)))
|
|---|
| 299 | IF (X.EQ. 3. ) GAMMAF = 2.
|
|---|
| 300 | IF (X.EQ. 4. ) GAMMAF = 6.
|
|---|
| 301 | IF (X.EQ. 5. ) GAMMAF = 24.
|
|---|
| 302 | IF (X.EQ. 6. ) GAMMAF = 120.
|
|---|
| 303 | RETURN
|
|---|
| 304 | END
|
|---|
| 305 | C
|
|---|
| 306 | REAL*8 FUNCTION PNORMJ (N,ALPHA,BETA)
|
|---|
| 307 | IMPLICIT REAL*8 (A-H,O-Z)
|
|---|
| 308 | REAL*8 ALPHA,BETA
|
|---|
| 309 | ONE = 1.
|
|---|
| 310 | TWO = 2.
|
|---|
| 311 | DN = ((N))
|
|---|
| 312 | CONST = ALPHA+BETA+ONE
|
|---|
| 313 | IF (N.LE.1) THEN
|
|---|
| 314 | PROD = GAMMAF(DN+ALPHA)*GAMMAF(DN+BETA)
|
|---|
| 315 | PROD = PROD/(GAMMAF(DN)*GAMMAF(DN+ALPHA+BETA))
|
|---|
| 316 | PNORMJ = PROD * TWO**CONST/(TWO*DN+CONST)
|
|---|
| 317 | RETURN
|
|---|
| 318 | ENDIF
|
|---|
| 319 | PROD = GAMMAF(ALPHA+ONE)*GAMMAF(BETA+ONE)
|
|---|
| 320 | PROD = PROD/(TWO*(ONE+CONST)*GAMMAF(CONST+ONE))
|
|---|
| 321 | PROD = PROD*(ONE+ALPHA)*(TWO+ALPHA)
|
|---|
| 322 | PROD = PROD*(ONE+BETA)*(TWO+BETA)
|
|---|
| 323 | DO 100 I=3,N
|
|---|
| 324 | DINDX = ((I))
|
|---|
| 325 | FRAC = (DINDX+ALPHA)*(DINDX+BETA)/(DINDX*(DINDX+ALPHA+BETA))
|
|---|
| 326 | PROD = PROD*FRAC
|
|---|
| 327 | 100 CONTINUE
|
|---|
| 328 | PNORMJ = PROD * TWO**CONST/(TWO*DN+CONST)
|
|---|
| 329 | RETURN
|
|---|
| 330 | END
|
|---|
| 331 | C
|
|---|
| 332 | SUBROUTINE JACG (XJAC,NP,ALPHA,BETA)
|
|---|
| 333 | C--------------------------------------------------------------------
|
|---|
| 334 | C
|
|---|
| 335 | C Compute NP Gauss points XJAC, which are the zeros of the
|
|---|
| 336 | C Jacobi polynomial J(NP) with parameters ALPHA and BETA.
|
|---|
| 337 | C ALPHA and BETA determines the specific type of Gauss points.
|
|---|
| 338 | C Examples:
|
|---|
| 339 | C ALPHA = BETA = 0.0 -> Legendre points
|
|---|
| 340 | C ALPHA = BETA = -0.5 -> Chebyshev points
|
|---|
| 341 | C
|
|---|
| 342 | C--------------------------------------------------------------------
|
|---|
| 343 | IMPLICIT REAL*8 (A-H,O-Z)
|
|---|
| 344 | REAL*8 XJAC(1)
|
|---|
| 345 | DATA KSTOP /10/
|
|---|
| 346 | DATA EPS/1.0e-12/
|
|---|
| 347 | N = NP-1
|
|---|
| 348 | one = 1.
|
|---|
| 349 | DTH = 4.*ATAN(one)/(2.*((N))+2.)
|
|---|
| 350 | DO 40 J=1,NP
|
|---|
| 351 | IF (J.EQ.1) THEN
|
|---|
| 352 | X = COS((2.*(((J))-1.)+1.)*DTH)
|
|---|
| 353 | ELSE
|
|---|
| 354 | X1 = COS((2.*(((J))-1.)+1.)*DTH)
|
|---|
| 355 | X2 = XLAST
|
|---|
| 356 | X = (X1+X2)/2.
|
|---|
| 357 | ENDIF
|
|---|
| 358 | DO 30 K=1,KSTOP
|
|---|
| 359 | CALL JACOBF (P,PD,PM1,PDM1,PM2,PDM2,NP,ALPHA,BETA,X)
|
|---|
| 360 | RECSUM = 0.
|
|---|
| 361 | JM = J-1
|
|---|
| 362 | DO 29 I=1,JM
|
|---|
| 363 | RECSUM = RECSUM+1./(X-XJAC(NP-I+1))
|
|---|
| 364 | 29 CONTINUE
|
|---|
| 365 | DELX = -P/(PD-RECSUM*P)
|
|---|
| 366 | X = X+DELX
|
|---|
| 367 | IF (ABS(DELX) .LT. EPS) GOTO 31
|
|---|
| 368 | 30 CONTINUE
|
|---|
| 369 | 31 CONTINUE
|
|---|
| 370 | XJAC(NP-J+1) = X
|
|---|
| 371 | XLAST = X
|
|---|
| 372 | 40 CONTINUE
|
|---|
| 373 | DO 200 I=1,NP
|
|---|
| 374 | XMIN = 2.
|
|---|
| 375 | DO 100 J=I,NP
|
|---|
| 376 | IF (XJAC(J).LT.XMIN) THEN
|
|---|
| 377 | XMIN = XJAC(J)
|
|---|
| 378 | JMIN = J
|
|---|
| 379 | ENDIF
|
|---|
| 380 | 100 CONTINUE
|
|---|
| 381 | IF (JMIN.NE.I) THEN
|
|---|
| 382 | SWAP = XJAC(I)
|
|---|
| 383 | XJAC(I) = XJAC(JMIN)
|
|---|
| 384 | XJAC(JMIN) = SWAP
|
|---|
| 385 | ENDIF
|
|---|
| 386 | 200 CONTINUE
|
|---|
| 387 | RETURN
|
|---|
| 388 | END
|
|---|
| 389 | C
|
|---|
| 390 | SUBROUTINE JACOBF (POLY,PDER,POLYM1,PDERM1,POLYM2,PDERM2,
|
|---|
| 391 | $ N,ALP,BET,X)
|
|---|
| 392 | C--------------------------------------------------------------------
|
|---|
| 393 | C
|
|---|
| 394 | C Computes the Jacobi polynomial (POLY) and its derivative (PDER)
|
|---|
| 395 | C of degree N at X.
|
|---|
| 396 | C
|
|---|
| 397 | C--------------------------------------------------------------------
|
|---|
| 398 | IMPLICIT REAL*8 (A-H,O-Z)
|
|---|
| 399 | APB = ALP+BET
|
|---|
| 400 | POLY = 1.
|
|---|
| 401 | PDER = 0.
|
|---|
| 402 | IF (N .EQ. 0) RETURN
|
|---|
| 403 | POLYL = POLY
|
|---|
| 404 | PDERL = PDER
|
|---|
| 405 | POLY = (ALP-BET+(APB+2.)*X)/2.
|
|---|
| 406 | PDER = (APB+2.)/2.
|
|---|
| 407 | IF (N .EQ. 1) RETURN
|
|---|
| 408 | DO 20 K=2,N
|
|---|
| 409 | DK = ((K))
|
|---|
| 410 | A1 = 2.*DK*(DK+APB)*(2.*DK+APB-2.)
|
|---|
| 411 | A2 = (2.*DK+APB-1.)*(ALP**2-BET**2)
|
|---|
| 412 | B3 = (2.*DK+APB-2.)
|
|---|
| 413 | A3 = B3*(B3+1.)*(B3+2.)
|
|---|
| 414 | A4 = 2.*(DK+ALP-1.)*(DK+BET-1.)*(2.*DK+APB)
|
|---|
| 415 | POLYN = ((A2+A3*X)*POLY-A4*POLYL)/A1
|
|---|
| 416 | PDERN = ((A2+A3*X)*PDER-A4*PDERL+A3*POLY)/A1
|
|---|
| 417 | PSAVE = POLYL
|
|---|
| 418 | PDSAVE = PDERL
|
|---|
| 419 | POLYL = POLY
|
|---|
| 420 | POLY = POLYN
|
|---|
| 421 | PDERL = PDER
|
|---|
| 422 | PDER = PDERN
|
|---|
| 423 | 20 CONTINUE
|
|---|
| 424 | POLYM1 = POLYL
|
|---|
| 425 | PDERM1 = PDERL
|
|---|
| 426 | POLYM2 = PSAVE
|
|---|
| 427 | PDERM2 = PDSAVE
|
|---|
| 428 | RETURN
|
|---|
| 429 | END
|
|---|
| 430 | |
|---|
