1 |
guez |
166 |
SUBROUTINE ytp(imr, jnp, j1, j2, acosp, rcap, dq, p, vc, dc2, ymass, fx, a6, & |
2 |
|
|
ar, al, jord) |
3 |
|
|
DIMENSION p(imr, jnp), vc(imr, jnp), ymass(imr, jnp), dc2(imr, jnp), & |
4 |
|
|
dq(imr, jnp), acosp(jnp) |
5 |
|
|
! Work array |
6 |
|
|
DIMENSION fx(imr, jnp), ar(imr, jnp), al(imr, jnp), a6(imr, jnp) |
7 |
|
|
|
8 |
|
|
jmr = jnp - 1 |
9 |
|
|
len = imr*(j2-j1+2) |
10 |
|
|
|
11 |
|
|
IF (jord==1) THEN |
12 |
|
|
DO i = 1, len |
13 |
|
|
jt = float(j1) - vc(i, j1) |
14 |
|
|
fx(i, j1) = p(i, jt) |
15 |
|
|
END DO |
16 |
|
|
ELSE |
17 |
|
|
|
18 |
|
|
CALL ymist(imr, jnp, j1, p, dc2, 4) |
19 |
|
|
|
20 |
|
|
IF (jord<=0 .OR. jord>=3) THEN |
21 |
|
|
|
22 |
|
|
CALL fyppm(vc, p, dc2, fx, imr, jnp, j1, j2, a6, ar, al, jord) |
23 |
|
|
|
24 |
|
|
ELSE |
25 |
|
|
DO i = 1, len |
26 |
|
|
jt = float(j1) - vc(i, j1) |
27 |
|
|
fx(i, j1) = p(i, jt) + (sign(1.,vc(i,j1))-vc(i,j1))*dc2(i, jt) |
28 |
|
|
END DO |
29 |
|
|
END IF |
30 |
|
|
END IF |
31 |
|
|
|
32 |
|
|
DO i = 1, len |
33 |
|
|
fx(i, j1) = fx(i, j1)*ymass(i, j1) |
34 |
|
|
END DO |
35 |
|
|
|
36 |
|
|
DO j = j1, j2 |
37 |
|
|
DO i = 1, imr |
38 |
|
|
dq(i, j) = dq(i, j) + (fx(i,j)-fx(i,j+1))*acosp(j) |
39 |
|
|
END DO |
40 |
|
|
END DO |
41 |
|
|
|
42 |
|
|
! Poles |
43 |
|
|
sum1 = fx(imr, j1) |
44 |
|
|
sum2 = fx(imr, j2+1) |
45 |
|
|
DO i = 1, imr - 1 |
46 |
|
|
sum1 = sum1 + fx(i, j1) |
47 |
|
|
sum2 = sum2 + fx(i, j2+1) |
48 |
|
|
END DO |
49 |
|
|
|
50 |
|
|
sum1 = dq(1, 1) - sum1*rcap |
51 |
|
|
sum2 = dq(1, jnp) + sum2*rcap |
52 |
|
|
DO i = 1, imr |
53 |
|
|
dq(i, 1) = sum1 |
54 |
|
|
dq(i, jnp) = sum2 |
55 |
|
|
END DO |
56 |
|
|
|
57 |
|
|
IF (j1/=2) THEN |
58 |
|
|
DO i = 1, imr |
59 |
|
|
dq(i, 2) = sum1 |
60 |
|
|
dq(i, jmr) = sum2 |
61 |
|
|
END DO |
62 |
|
|
END IF |
63 |
|
|
|
64 |
|
|
RETURN |
65 |
|
|
END SUBROUTINE ytp |
66 |
|
|
|