![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to Dgl.out CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 40BSD / cmd / efl / efltest|
Return to Dgl.out CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / efl / efltest |
1.1 root 1: subroutine dglsbp(nu, order, bc, e)
2: integer nu
3: integer order(nu, nu, 2), bc(nu, 2, 2), e(nu, 2, 2)
4: common /cstak/ ds
5: double precision ds(500)
6: integer ice, istkgt, max0, i, j, l
7: integer ipps, inow, imaord, inoold, is(1000)
8: real rs(1000)
9: logical allero, ls(1000)
10: complex cs(500)
11: double precision ws(500)
12: integer temp, temp1
13: equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
14: c To determine which ODE should use which boundary condition.
15: c Mnemonic - Double precision Galerkin's method for Linear Systems,
16: c Boundary condition Placement.
17: c Scratch Space Allocated -
18: c S(DglsBP) <= Nu*(4*Nu+15)
19: c Integer words.
20: c Define Node = Is(inow) -> Nodei
21: c Check the input for errors.
22: if (nu .lt. 1) call seterr(16hDglsBP - Nu.lt.1, 16, 1, 2)
23: do 3 l = 1, 2
24: do 2 i = 1, nu
25: c Is Order(i,.,l) = (-1,...,-1)?
26: allero = .true.
27: do 1 j = 1, nu
28: allero = allero .and. order(i, j, l) .eq. (-1)
29: if (order(i, j, l) .lt. (-1) .or. order(i, j, l) .gt. 2)
30: 1 call seterr(
31: 2 41hDglsBP - Order(i,j,l) not one of -1,0,1,2, 41, 2, 2
32: 3 )
33: 1 continue
34: if (bc(i, 1, l) .ne. (-2) .and. bc(i, 1, l) .ne. 0 .or. bc(i
35: 1 , 2, l) .ne. (-2) .and. bc(i, 2, l) .ne. 1) call seterr(
36: 2 36hDglsBP - BC(i,.,l) not one of -2,0,1, 36, 3, 2)
37: if (allero) call seterr(
38: 1 33hDglsBP - Order(i,.,l)=(-1,...,-1), 33, 4, 2)
39: 2 continue
40: 3 continue
41: call enter(1)
42: c Complement of E.
43: ice = istkgt(nu, 2)
44: c Maxord(i,l) = Max over j=1,...,Nu Order(i,j,l).
45: imaord = istkgt(2*nu, 2)
46: call seti(2*nu, -1, is(imaord))
47: do 6 l = 1, 2
48: do 5 i = 1, nu
49: do 4 j = 1, nu
50: temp1 = imaord+i-1+(l-1)*nu
51: temp = imaord+i-1+(l-1)*nu
52: is(temp1) = max0(is(temp), order(i, j, l))
53: 4 continue
54: 5 continue
55: 6 continue
56: i = 0
57: ipps = 1
58: 7 if (i .ge. 4*nu .and. ipps .eq. 1) goto 15
59: goto 12
60: c Make a node.
61: 8 inoold = inow
62: i = i+1
63: inow = istkgt(nu+3, 2)
64: is(inow) = inoold
65: c Get the candidates for E(i).
66: call d6lsbp(i, nu, order, bc, e, is(imaord), is(ice), is(
67: 1 inow+3), is(inow+1))
68: is(inow+2) = 0
69: ipps = 0
70: goto 13
71: goto 13
72: c Searching a node.
73: 9 is(inow+2) = is(inow+2)+1
74: if (is(inow+2) .le. is(inow+1)) goto 10
75: ipps = -1
76: c Back-up.
77: goto 7
78: 10 temp = inow+2+is(inow+2)-1
79: e(i, 1, 1) = is(temp+1)
80: ipps = 1
81: goto 13
82: goto 13
83: c Backing up a Node.
84: 11 inow = is(inow)
85: call istkrl(1)
86: i = i-1
87: ipps = 0
88: goto 13
89: goto 13
90: 12 temp = ipps+2
91: if (temp .gt. 0 .and. temp .le. 3) goto ( 11, 9, 8), temp
92: c End Switch.
93: 13 if (i .ne. 0) goto 14
94: call seterr(37hDglsBP - Improper Boundary Conditions, 37, 5,
95: 1 1)
96: goto 15
97: 14 continue
98: goto 7
99: c End While.
100: 15 call leave
101: return
102: end
103: subroutine d6lsbp(i, nu, order, bc, e, maxord, ce, r, n)
104: integer nu
105: integer i, order(nu, nu, 2), bc(1), e(1), maxord(nu, 2), ce(nu)
106: integer r(nu), n
107: integer mod, max0, j, l, nbcs, dm
108: integer ii, lr
109: integer temp
110: c BC(Nu,2,2),E(Nu,2,2),
111: c E(i-1),R(N).
112: if (bc(i) .ge. 0) goto 1
113: n = 1
114: r(n) = 0
115: return
116: c LR = 1 for left, LR = 2 for right.
117: 1 lr = (i-1)/(2*nu)+1
118: c DM = 1 for Dirichlet, DM = 2 for Mixed boundary conditions.
119: dm = mod((i-1)/nu, 2)+1
120: ii = mod(i, nu)
121: if (ii .eq. 0) ii = nu
122: c B(i) = B(ii,DM,LR).
123: n = 0
124: do 2 j = 1, nu
125: ce(j) = j
126: 2 continue
127: c CE = Complement of E.
128: if (i .gt. 2*nu) goto 7
129: j = 1
130: goto 4
131: 3 j = j+1
132: 4 if (j .ge. i) goto 6
133: if (bc(j) .lt. 0) goto 5
134: temp = e(j)
135: ce(temp) = 0
136: 5 continue
137: goto 3
138: 6 continue
139: goto 12
140: 7 j = 2*nu+1
141: goto 9
142: 8 j = j+1
143: 9 if (j .ge. i) goto 11
144: if (bc(j) .lt. 0) goto 10
145: temp = e(j)
146: ce(temp) = 0
147: 10 continue
148: goto 8
149: 11 continue
150: 12 do 18 j = 1, nu
151: if (ce(j) .eq. 0) goto 18
152: nbcs = 0
153: l = 1
154: goto 14
155: 13 l = l+1
156: 14 if (l .ge. i) goto 15
157: if (e(l) .eq. j .and. bc(l) .ge. 0) nbcs = nbcs+1
158: goto 13
159: 15 if ((dm .ne. 1 .or. maxord(j, lr) .le. bc(i)) .and. (dm .ne. 2
160: 1 .or. order(j, ii, lr) .le. bc(i))) goto 17
161: if (nbcs .ge. max0(maxord(j, 1), maxord(j, 2))) goto 16
162: n = n+1
163: r(n) = j
164: 16 continue
165: 17 continue
166: 18 continue
167: return
168: end
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.