1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
|
subroutine fcoldg(i,z,dg)
c colnew external calling
c=====================================
include '../stack.h'
double precision z(*), dg(*)
integer i,it1
character*6 nam1,efsub,edfsub,egsub,edgsub,eguess
integer iero
common /iercol/ iero
common / colname / efsub,edfsub,egsub,edgsub,eguess
c
iero=0
call majmin(6,edgsub,nam1)
c INSERT YOUR OWN ROUTINE HERE:
c+
if(nam1.eq.'dg') then
call dg1(i,z,dg)
return
endif
c+
c dynamic link
call tlink(edgsub,0,it1)
if(it1.le.0) goto 2000
call dyncall(it1-1,i,z,dg)
cc fin
return
c
2000 iero=1
buf=edgsub
call error(50)
return
end
subroutine fcolg(i,z,g)
c colnew external calling
c=====================================
include '../stack.h'
double precision z(*), g(*)
integer i,it1
character*6 nam1,efsub,edfsub,egsub,edgsub,eguess
integer iero
common /iercol/ iero
common / colname / efsub,edfsub,egsub,edgsub,eguess
c
iero=0
call majmin(6,egsub,nam1)
c INSERT YOUR OWN ROUTINE HERE:
c+
if(nam1.eq.'g') then
call g1(i,z,g)
return
endif
c+
c dynamic link
call tlink(egsub,0,it1)
if(it1.le.0) goto 2000
call dyncall(it1-1,i,z,g)
cc fin
return
c
2000 iero=1
buf=egsub
call error(50)
return
end
subroutine fcoldf(x,z,df)
c colnew external calling
c=====================================
include '../stack.h'
double precision z(*), df(*),x
integer it1
character*6 nam1,efsub,edfsub,egsub,edgsub,eguess
integer iero
common /iercol/ iero
common / colname / efsub,edfsub,egsub,edgsub,eguess
c
iero=0
call majmin(6,edfsub,nam1)
c INSERT YOUR OWN ROUTINE HERE
c+
if(nam1.eq.'df') then
call df11(x,z,df)
return
endif
c+
c dynamic link
call tlink(edfsub,0,it1)
if(it1.le.0) goto 2000
call dyncall(it1-1,x,z,df)
cc fin
return
c
2000 iero=1
buf=edfsub
call error(50)
return
end
subroutine fcolf(x,z,f)
c colnew external calling
c=====================================
include '../stack.h'
double precision z(*), f(*),x
integer it1
character*6 nam1,efsub,edfsub,egsub,edgsub,eguess
integer iero
common /iercol/ iero
common / colname / efsub,edfsub,egsub,edgsub,eguess
c
iero=0
call majmin(6,efsub,nam1)
c INSERT YOUR ROUTINE HERE:
c+
if(nam1.eq.'f') then
call f11(x,z,f)
return
endif
c+
c dynamic link
call tlink(efsub,0,it1)
if(it1.le.0) goto 2000
call dyncall(it1-1,x,z,f)
cc fin
return
c
2000 iero=1
buf=efsub
call error(50)
return
end
subroutine fcolgu(x,z,dmval)
c colnew external calling
c=====================================
include '../stack.h'
double precision z(*), dmval(*),x
integer it1
character*6 nam1,efsub,edfsub,egsub,edgsub,eguess
integer iero
common /iercol/ iero
common / colname / efsub,edfsub,egsub,edgsub,eguess
c
iero=0
call majmin(6,eguess,nam1)
c INSERT YOUR OWN ROUTINE HERE:
c+
if(nam1.eq.'gu') then
call solutn(x,z,dmval)
return
endif
c+
c dynamic link
call tlink(eguess,0,it1)
if(it1.le.0) goto 2000
call dyncall(it1-1,x,z,dmval)
return
c
2000 iero=1
buf=eguess
call error(50)
return
end
c................................................................
subroutine solutn (x, z, dmval)
implicit double precision (a-h,o-z)
dimension z(4) , dmval(2)
double precision gamma, xt
data gamma/1.1d0/, xt/1/
xt = dsqrt(2.d0*(gamma-1.d0)/gamma)
cons = gamma * x * (1.d0-.5d0*x*x)
dcons = gamma * (1.d0 - 1.5d0*x*x)
d2cons = -3.d0 * gamma * x
if (x .gt. xt) go to 10
z(1) = 2.d0 * x
z(2) = 2.d0
z(3) = -2.d0*x + cons
z(4) = -2.d0 + dcons
dmval(2) = d2cons
go to 20
10 z(1) = 0.d0
z(2) = 0.d0
z(3) = -cons
z(4) = -dcons
dmval(2) = -d2cons
20 dmval(1) = 0.d0
return
end
c................................................................
subroutine f11 (x, z, f)
implicit double precision (a-h,o-z)
dimension z(4), f(2)
double precision eps, dmu, eps4mu, gamma, xt
data eps/.01d0/, dmu/.01d0/, eps4mu/1.0/, gamma/1.1d0/, xt/1/
eps4mu =eps**4/dmu
xt = dsqrt(2.d0*(gamma-1.d0)/gamma)
f(1) = z(1)/x/x - z(2)/x + (z(1) - z(3)*(1.d0-z(1)/x) -
. gamma*x*(1.d0-x*x/2.)) / eps4mu
f(2) = z(3)/x/x - z(4)/x + z(1)*(1.d0-z(1)/2.d0/x) / dmu
return
end
c................................................................
subroutine df11 (x, z, df)
implicit double precision (a-h,o-z)
dimension z(4), df(2,4)
double precision eps, dmu, eps4mu, gamma, xt
data eps/.01d0/, dmu/.01d0/, eps4mu/1/, gamma/1.1d0/, xt/1/
eps4mu =eps**4/dmu
xt = dsqrt(2.d0*(gamma-1.d0)/gamma)
df(1,1) = 1.d0/x/x +(1.d0 + z(3)/x) / eps4mu
df(1,2) = -1.d0/x
df(1,3) = -(1.d0-z(1)/x) / eps4mu
df(1,4) = 0.d0
df(2,1) = (1.d0 - z(1)/x) / dmu
df(2,2) = 0.d0
df(2,3) = 1.d0/x/x
df(2,4) = -1.d0/x
return
end
c................................................................
subroutine g1 (i, z, g)
implicit double precision (a-h,o-z)
dimension z(4)
go to (1, 2, 1, 3), i
1 g = z(1)
return
2 g = z(3)
return
3 g = z(4) - .3d0*z(3) + .7d0
return
end
c................................................................
subroutine dg1 (i, z, dg)
implicit double precision (a-h,o-z)
dimension z(4), dg(4)
do 10 j=1,4
10 dg(j) = 0. d0
go to (1, 2, 1, 3), i
1 dg(1) = 1.d0
return
2 dg(3) = 1.d0
return
3 dg(4) = 1.d0
dg(3) = -.3d0
return
end
c
c----------------------------------------------------------------
c
|
