← Back to branch summary

~f-milthaler/fluidity/fsi-model-stationary-solid-with-velocity

« back to all changes in this revision

Viewing changes to libalgencan/uevalus.F

  • Committer: f.milthaler10 at uk
  • Date: 2013-11-06 13:43:56 UTC
  • mfrom: (3463.184.85 fluidity)
  • Revision ID: f.milthaler10@imperial.ac.ic.uk.-20131106134356-v3lw1dheesckywj0
merge from trunk

Show diffs side-by-side

added added

removed removed

Lines of Context:
libalgencan/uevalus.F
1
 
C     ADD REMOVED FIXED VARIABLES
2
 
 
3
 
C     ******************************************************************
4
 
C     ******************************************************************
5
 
 
6
 
      subroutine uinip(n,x,l,u,m,lambda,equatn,linear,coded,checkder,
7
 
     +inform)
8
 
 
9
 
      implicit none
10
 
 
11
 
C     SCALAR ARGUMENTS
12
 
      logical checkder
13
 
      integer inform,m,n
14
 
 
15
 
C     ARRAY ARGUMENTS
16
 
      logical coded(10),equatn(m),linear(m)
17
 
      double precision l(n),lambda(m),u(n),x(n)
18
 
 
19
 
#include "dim.par"
20
 
#include "fixvar.com"
21
 
#include "outtyp.com"
22
 
 
23
 
C     LOCAL SCALARS
24
 
      integer i
25
 
 
26
 
C     EXTERNAL SUBROUTINES
27
 
      external vinip
28
 
 
29
 
      call vinip(n,x,l,u,m,lambda,equatn,linear,coded,checkder,inform)
30
 
      if ( inform .lt. 0 ) return
31
 
 
32
 
C     Eliminate fixed variables (l=u) and save their values on y
33
 
 
34
 
      if ( rmfixv ) then
35
 
 
36
 
          yind(0) = n
37
 
 
38
 
          n = 0
39
 
          do i = 1,yind(0)
40
 
              if ( l(i) .lt. u(i) ) then
41
 
                  n = n + 1
42
 
                  yind(n) = i
43
 
                  ycor(i) = n
44
 
              else
45
 
                  y(i) = l(i)
46
 
                  ycor(i) = 0
47
 
              end if
48
 
          end do
49
 
 
50
 
          do i = 1,n
51
 
              x(i) = x(yind(i))
52
 
              l(i) = l(yind(i))
53
 
              u(i) = u(yind(i))
54
 
          end do
55
 
 
56
 
          if ( n .eq. yind(0) ) rmfixv = .false.
57
 
 
58
 
          if ( iprintctl(2) ) then
59
 
              write(* ,100) yind(0) - n
60
 
              write(file10_unit,100) yind(0) - n
61
 
          end if
62
 
      end if
63
 
 
64
 
C     NON-EXECUTABLE STATEMENTS
65
 
 
66
 
 100  format(/,1X,'Number of removed fixed variables : ',I7)
67
 
 
68
 
      end
69
 
 
70
 
C     ******************************************************************
71
 
C     ******************************************************************
72
 
 
73
 
      subroutine uendp(n,x,l,u,m,lambda,equatn,linear,inform)
74
 
 
75
 
      implicit none
76
 
 
77
 
C     SCALAR ARGUMENTS
78
 
      integer inform,m,n
79
 
 
80
 
C     ARRAY ARGUMENTS
81
 
      logical equatn(m),linear(m)
82
 
      double precision l(*),lambda(m),u(*),x(*)
83
 
 
84
 
#include "dim.par"
85
 
#include "fixvar.com"
86
 
 
87
 
C     LOCAL SCALARS
88
 
      integer i,ind
89
 
 
90
 
C     EXTERNAL SUBROUTINES
91
 
      external vendp
92
 
 
93
 
C     Restore original x, l, u and n
94
 
 
95
 
      if ( rmfixv ) then
96
 
          do i = yind(0),1,-1
97
 
              ind = ycor(i)
98
 
              if ( ind .ne. 0 ) then
99
 
                  l(i) = l(ind)
100
 
                  u(i) = u(ind)
101
 
                  x(i) = x(ind)
102
 
              else
103
 
                  l(i) = y(i)
104
 
                  u(i) = y(i)
105
 
                  x(i) = y(i)
106
 
              end if
107
 
          end do
108
 
 
109
 
          n = yind(0)
110
 
 
111
 
          rmfixv = .false.
112
 
      end if
113
 
 
114
 
      call vendp(n,x,l,u,m,lambda,equatn,linear,inform)
115
 
      if ( inform .lt. 0 ) return
116
 
 
117
 
      end
118
 
 
119
 
C     ******************************************************************
120
 
C     ******************************************************************
121
 
 
122
 
      subroutine uevalf(n,x,f,inform)
123
 
 
124
 
      implicit none
125
 
 
126
 
C     SCALAR ARGUMENTS
127
 
      integer inform,n
128
 
      double precision f
129
 
 
130
 
C     ARRAY ARGUMENTS
131
 
      double precision x(n)
132
 
 
133
 
#include "dim.par"
134
 
#include "fixvar.com"
135
 
 
136
 
C     LOCAL SCALARS
137
 
      integer i
138
 
 
139
 
C     EXTERNAL SUBROUTINES
140
 
      external vevalf
141
 
 
142
 
      if ( .not. rmfixv ) then
143
 
          call vevalf(n,x,f,inform)
144
 
          if ( inform .lt. 0 ) return
145
 
 
146
 
      else
147
 
          if ( .not. yset ) then
148
 
              write(*,*) 'uevalf: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
149
 
              do i = 1,n
150
 
                  y(yind(i)) = x(i)
151
 
              end do
152
 
          end if
153
 
 
154
 
          call vevalf(yind(0),y,f,inform)
155
 
          if ( inform .lt. 0 ) return
156
 
      end if
157
 
 
158
 
      end
159
 
 
160
 
C     ******************************************************************
161
 
C     ******************************************************************
162
 
 
163
 
      subroutine uevalg(n,x,g,inform)
164
 
 
165
 
      implicit none
166
 
 
167
 
C     SCALAR ARGUMENTS
168
 
      integer inform,n
169
 
 
170
 
#include "dim.par"
171
 
#include "fixvar.com"
172
 
 
173
 
C     ARRAY ARGUMENTS
174
 
      double precision g(*),x(*)
175
 
 
176
 
C     LOCAL SCALARS
177
 
      integer i
178
 
 
179
 
C     EXTERNAL SUBROUTINES
180
 
      external vevalg
181
 
 
182
 
      if ( .not. rmfixv ) then
183
 
          call vevalg(n,x,g,inform)
184
 
          if ( inform .lt. 0 ) return
185
 
 
186
 
      else
187
 
          if ( .not. yset ) then
188
 
              write(*,*) 'uevalg: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
189
 
              do i = 1,n
190
 
                  y(yind(i)) = x(i)
191
 
              end do
192
 
          end if
193
 
 
194
 
          call vevalg(yind(0),y,g,inform)
195
 
          if ( inform .lt. 0 ) return
196
 
 
197
 
          do i = 1,n
198
 
              g(i) = g(yind(i))
199
 
          end do
200
 
      end if
201
 
 
202
 
      end
203
 
 
204
 
C     ******************************************************************
205
 
C     ******************************************************************
206
 
 
207
 
      subroutine uevalh(n,x,hlin,hcol,hval,hnnz,inform)
208
 
 
209
 
      implicit none
210
 
 
211
 
C     SCALAR ARGUMENTS
212
 
      integer inform,n,hnnz
213
 
 
214
 
C     ARRAY ARGUMENTS
215
 
      integer hcol(*),hlin(*)
216
 
      double precision hval(*),x(n)
217
 
 
218
 
#include "dim.par"
219
 
#include "fixvar.com"
220
 
 
221
 
C     LOCAL SCALARS
222
 
      integer col,i,j,lin
223
 
 
224
 
C     EXTERNAL SUBROUTINES
225
 
      external vevalh
226
 
 
227
 
      if ( .not. rmfixv ) then
228
 
          call vevalh(n,x,hlin,hcol,hval,hnnz,inform)
229
 
          if ( inform .lt. 0 ) return
230
 
 
231
 
      else
232
 
          if ( .not. yset ) then
233
 
              write(*,*) 'uevalh: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
234
 
              do i = 1,n
235
 
                  y(yind(i)) = x(i)
236
 
              end do
237
 
          end if
238
 
 
239
 
          call vevalh(yind(0),y,hlin,hcol,hval,hnnz,inform)
240
 
          if ( inform .lt. 0 ) return
241
 
 
242
 
          j = 0
243
 
          do i = 1,hnnz
244
 
              lin = ycor(hlin(i))
245
 
              col = ycor(hcol(i))
246
 
              if ( lin .ne. 0 .and. col .ne. 0 ) then
247
 
                  j = j + 1
248
 
                  hlin(j) = lin
249
 
                  hcol(j) = col
250
 
                  hval(j) = hval(i)
251
 
              end if
252
 
          end do
253
 
 
254
 
          hnnz = j
255
 
      end if
256
 
 
257
 
      end
258
 
 
259
 
C     ******************************************************************
260
 
C     ******************************************************************
261
 
 
262
 
      subroutine uevalc(n,x,ind,c,inform)
263
 
 
264
 
      implicit none
265
 
 
266
 
C     SCALAR ARGUMENTS
267
 
      integer ind,inform,n
268
 
      double precision c
269
 
 
270
 
C     ARRAY ARGUMENTS
271
 
      double precision x(n)
272
 
 
273
 
#include "dim.par"
274
 
#include "fixvar.com"
275
 
 
276
 
C     LOCAL SCALARS
277
 
      integer i
278
 
 
279
 
C     EXTERNAL SUBROUTINES
280
 
      external vevalc
281
 
 
282
 
      if ( .not. rmfixv ) then
283
 
          call vevalc(n,x,ind,c,inform)
284
 
          if ( inform .lt. 0 ) return
285
 
 
286
 
      else
287
 
          if ( .not. yset ) then
288
 
              write(*,*) 'uevalc: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
289
 
              do i = 1,n
290
 
                  y(yind(i)) = x(i)
291
 
              end do
292
 
          end if
293
 
 
294
 
          call vevalc(yind(0),y,ind,c,inform)
295
 
          if ( inform .lt. 0 ) return
296
 
      end if
297
 
 
298
 
      end
299
 
 
300
 
C     ******************************************************************
301
 
C     ******************************************************************
302
 
 
303
 
      subroutine uevaljac(n,x,ind,jcvar,jcval,jcnnz,inform)
304
 
 
305
 
      implicit none
306
 
 
307
 
C     SCALAR ARGUMENTS
308
 
      integer inform,ind,n,jcnnz
309
 
 
310
 
#include "dim.par"
311
 
#include "fixvar.com"
312
 
 
313
 
C     ARRAY ARGUMENTS
314
 
      integer jcvar(*)
315
 
      double precision x(*),jcval(*)
316
 
 
317
 
C     LOCAL SCALARS
318
 
      integer i,j,var
319
 
 
320
 
C     EXTERNAL SUBROUTINES
321
 
      external vevaljac
322
 
 
323
 
      if ( .not. rmfixv ) then
324
 
          call vevaljac(n,x,ind,jcvar,jcval,jcnnz,inform)
325
 
          if ( inform .lt. 0 ) return
326
 
 
327
 
      else
328
 
          if ( .not. yset ) then
329
 
              write(*,*) 'uevaljac: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
330
 
              do i = 1,n
331
 
                  y(yind(i)) = x(i)
332
 
              end do
333
 
          end if
334
 
 
335
 
          call vevaljac(yind(0),y,ind,jcvar,jcval,jcnnz,inform)
336
 
          if ( inform .lt. 0 ) return
337
 
 
338
 
          j = 0
339
 
          do i = 1,jcnnz
340
 
              var = ycor(jcvar(i))
341
 
              if ( var .ne. 0 ) then
342
 
                  j = j + 1
343
 
                  jcvar(j) = var
344
 
                  jcval(j) = jcval(i)
345
 
              end if
346
 
          end do
347
 
 
348
 
          jcnnz = j
349
 
      end if
350
 
 
351
 
      end
352
 
 
353
 
C     ******************************************************************
354
 
C     ******************************************************************
355
 
 
356
 
      subroutine uevalhc(n,x,ind,hlin,hcol,hval,hnnz,inform)
357
 
 
358
 
      implicit none
359
 
 
360
 
C     SCALAR ARGUMENTS
361
 
      integer inform,ind,n,hnnz
362
 
 
363
 
C     ARRAY ARGUMENTS
364
 
      integer hcol(*),hlin(*)
365
 
      double precision hval(*),x(n)
366
 
 
367
 
#include "dim.par"
368
 
#include "fixvar.com"
369
 
 
370
 
C     LOCAL SCALARS
371
 
      integer col,i,j,lin
372
 
 
373
 
C     EXTERNAL SUBROUTINES
374
 
      external vevalhc
375
 
 
376
 
      if ( .not. rmfixv ) then
377
 
          call vevalhc(n,x,ind,hlin,hcol,hval,hnnz,inform)
378
 
          if ( inform .lt. 0 ) return
379
 
 
380
 
      else
381
 
          if ( .not. yset ) then
382
 
              write(*,*) 'uevalhc: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
383
 
              do i = 1,n
384
 
                  y(yind(i)) = x(i)
385
 
              end do
386
 
          end if
387
 
 
388
 
          call vevalhc(yind(0),y,ind,hlin,hcol,hval,hnnz,inform)
389
 
          if ( inform .lt. 0 ) return
390
 
 
391
 
          j = 0
392
 
          do i = 1,hnnz
393
 
              lin = ycor(hlin(i))
394
 
              col = ycor(hcol(i))
395
 
              if ( lin .ne. 0 .and. col .ne. 0 ) then
396
 
                  j = j + 1
397
 
                  hlin(j) = lin
398
 
                  hcol(j) = col
399
 
                  hval(j) = hval(i)
400
 
              end if
401
 
          end do
402
 
 
403
 
          hnnz = j
404
 
      end if
405
 
 
406
 
      end
407
 
 
408
 
C     ******************************************************************
409
 
C     ******************************************************************
410
 
 
411
 
      subroutine uevalhl(n,x,m,lambda,sf,sc,hlin,hcol,hval,hnnz,inform)
412
 
 
413
 
      implicit none
414
 
 
415
 
C     SCALAR ARGUMENTS
416
 
      integer hnnz,inform,m,n
417
 
      double precision sf
418
 
 
419
 
C     ARRAY ARGUMENTS
420
 
      integer hlin(*),hcol(*)
421
 
      double precision hval(*),lambda(m),sc(m),x(n)
422
 
 
423
 
#include "dim.par"
424
 
#include "fixvar.com"
425
 
 
426
 
C     LOCAL SCALARS
427
 
      integer col,i,j,lin
428
 
 
429
 
C     EXTERNAL SUBROUTINES
430
 
      external vevalhl
431
 
 
432
 
      if ( .not. rmfixv ) then
433
 
          call vevalhl(n,x,m,lambda,sf,sc,hlin,hcol,hval,hnnz,inform)
434
 
          if ( inform .lt. 0 ) return
435
 
 
436
 
      else
437
 
          if ( .not. yset ) then
438
 
              write(*,*) 'uevalhl: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
439
 
              do i = 1,n
440
 
                  y(yind(i)) = x(i)
441
 
              end do
442
 
          end if
443
 
 
444
 
          call vevalhl(yind(0),y,m,lambda,sf,sc,hlin,hcol,hval,hnnz,
445
 
     +    inform)
446
 
          if ( inform .lt. 0 ) return
447
 
 
448
 
          j = 0
449
 
          do i = 1,hnnz
450
 
              lin = ycor(hlin(i))
451
 
              col = ycor(hcol(i))
452
 
              if ( lin .ne. 0 .and. col .ne. 0 ) then
453
 
                  j = j + 1
454
 
                  hlin(j) = lin
455
 
                  hcol(j) = col
456
 
                  hval(j) = hval(i)
457
 
              end if
458
 
          end do
459
 
 
460
 
          hnnz = j
461
 
      end if
462
 
 
463
 
      end
464
 
 
465
 
C     ******************************************************************
466
 
C     ******************************************************************
467
 
 
468
 
      subroutine uevalhlp(n,x,m,lambda,sf,sc,p,hp,gothl,inform)
469
 
 
470
 
      implicit none
471
 
 
472
 
C     SCALAR ARGUMENTS
473
 
      logical gothl
474
 
      integer inform,m,n
475
 
      double precision sf
476
 
 
477
 
C     ARRAY ARGUMENTS
478
 
      double precision hp(*),lambda(m),p(n),sc(m),x(n)
479
 
 
480
 
#include "dim.par"
481
 
#include "fixvar.com"
482
 
 
483
 
C     LOCAL SCALARS
484
 
      integer i
485
 
 
486
 
C     LOCAL ARRAYS
487
 
      double precision w(nmax)
488
 
 
489
 
C     EXTERNAL SUBROUTINES
490
 
      external vevalhlp
491
 
 
492
 
      if ( .not. rmfixv ) then
493
 
          call vevalhlp(n,x,m,lambda,sf,sc,p,hp,gothl,inform)
494
 
          if ( inform .lt. 0 ) return
495
 
 
496
 
      else
497
 
          if ( .not. yset ) then
498
 
              write(*,*) 'uevalhlp: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
499
 
              do i = 1,n
500
 
                  y(yind(i)) = x(i)
501
 
              end do
502
 
          end if
503
 
 
504
 
          do i = 1,yind(0)
505
 
              w(i) = 0.0d0
506
 
          end do
507
 
 
508
 
          do i = 1,n
509
 
              w(yind(i)) = p(i)
510
 
          end do
511
 
 
512
 
          call vevalhlp(yind(0),y,m,lambda,sf,sc,w,hp,gothl,inform)
513
 
          if ( inform .lt. 0 ) return
514
 
 
515
 
          do i = 1,n
516
 
              hp(i) = hp(yind(i))
517
 
          end do
518
 
      end if
519
 
 
520
 
      end
521
 
 
522
 
C     ******************************************************************
523
 
C     ******************************************************************
524
 
 
525
 
      subroutine uevalfc(n,x,f,m,c,inform)
526
 
 
527
 
      implicit none
528
 
 
529
 
C     SCALAR ARGUMENTS
530
 
      integer inform,m,n
531
 
      double precision f
532
 
 
533
 
C     ARRAY ARGUMENTS
534
 
      double precision c(m),x(n)
535
 
 
536
 
#include "dim.par"
537
 
#include "fixvar.com"
538
 
 
539
 
C     LOCAL SCALARS
540
 
      integer i
541
 
 
542
 
C     EXTERNAL SUBROUTINES
543
 
      external vevalfc
544
 
 
545
 
      if ( .not. rmfixv ) then
546
 
          call vevalfc(n,x,f,m,c,inform)
547
 
          if ( inform .lt. 0 ) return
548
 
 
549
 
      else
550
 
          if ( .not. yset ) then
551
 
              write(*,*) 'uevaljac: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
552
 
              do i = 1,n
553
 
                  y(yind(i)) = x(i)
554
 
              end do
555
 
          end if
556
 
 
557
 
          call vevalfc(yind(0),y,f,m,c,inform)
558
 
          if ( inform .lt. 0 ) return
559
 
      end if
560
 
 
561
 
      end
562
 
 
563
 
C     ******************************************************************
564
 
C     ******************************************************************
565
 
 
566
 
      subroutine uevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,inform)
567
 
 
568
 
      implicit none
569
 
 
570
 
C     SCALAR ARGUMENTS
571
 
      integer inform,jcnnz,m,n
572
 
 
573
 
C     ARRAY ARGUMENTS
574
 
      integer jcfun(*),jcvar(*)
575
 
      double precision g(n),jcval(*),x(n)
576
 
 
577
 
#include "dim.par"
578
 
#include "fixvar.com"
579
 
 
580
 
C     LOCAL SCALARS
581
 
      integer i,j,var
582
 
 
583
 
C     EXTERNAL SUBROUTINES
584
 
      external vevalgjac
585
 
 
586
 
      if ( .not. rmfixv ) then
587
 
          call vevalgjac(n,x,g,m,jcfun,jcvar,jcval,jcnnz,inform)
588
 
          if ( inform .lt. 0 ) return
589
 
 
590
 
      else
591
 
          if ( .not. yset ) then
592
 
              write(*,*) 'uevaljac: Opa!!!!!!!!!!!!!!!!!!!!!!!!!'
593
 
              do i = 1,n
594
 
                  y(yind(i)) = x(i)
595
 
              end do
596
 
          end if
597
 
 
598
 
          call vevalgjac(yind(0),y,g,m,jcfun,jcvar,jcval,jcnnz,inform)
599
 
          if ( inform .lt. 0 ) return
600
 
 
601
 
          do i = 1,n
602
 
              g(i) = g(yind(i))
603
 
          end do
604
 
 
605
 
          j = 0
606
 
          do i = 1,jcnnz
607
 
              var = ycor(jcvar(i))
608
 
              if ( var .ne. 0 ) then
609
 
                  j = j + 1
610
 
                  jcfun(j) = jcfun(i)
611
 
                  jcvar(j) = var
612
 
                  jcval(j) = jcval(i)
613
 
              end if
614
 
          end do
615
 
 
616
 
          jcnnz = j
617
 
      end if
618
 
 
619
 
      end
620
 
 
621
 
C     ******************************************************************
622
 
C     ******************************************************************
623
 
 
624
 
      subroutine usetp(n,x)
625
 
 
626
 
      implicit none
627
 
 
628
 
C     SCALAR ARGUMENTS
629
 
      integer n
630
 
 
631
 
C     ARRAY ARGUMENTS
632
 
      double precision x(n)
633
 
 
634
 
#include "dim.par"
635
 
#include "fixvar.com"
636
 
 
637
 
C     LOCAL SCALARS
638
 
      integer i
639
 
 
640
 
C     EXTERNAL SUBROUTINES
641
 
      external vsetp
642
 
 
643
 
      if ( .not. rmfixv ) then
644
 
          call vsetp(n,x)
645
 
          return
646
 
      end if
647
 
 
648
 
      yset = .true.
649
 
 
650
 
      do i = 1,n
651
 
          y(yind(i)) = x(i)
652
 
      end do
653
 
 
654
 
      call vsetp(yind(0),y)
655
 
 
656
 
      end
657
 
 
658
 
C     ******************************************************************
659
 
C     ******************************************************************
660
 
 
661
 
      subroutine uunsetp()
662
 
 
663
 
      implicit none
664
 
 
665
 
#include "dim.par"
666
 
#include "fixvar.com"
667
 
 
668
 
C     EXTERNAL SUBROUTINES
669
 
      external vunsetp
670
 
 
671
 
      yset = .false.
672
 
 
673
 
      call vunsetp()
674
 
 
675
 
      end