← Back to branch summary

~ubuntu-branches/ubuntu/hoary/scilab/hoary

« back to all changes in this revision

Viewing changes to routines/scicos/intcos.f

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2005-01-09 22:58:21 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20050109225821-473xr8vhgugxxx5j
Tags: 3.0-12
http://bugs.debian.org/255869
changed configure.in to build scilab's own malloc.o, closes: #255869

Show diffs side-by-side

added added

removed removed

Lines of Context:
routines/scicos/intcos.f
6
6
      integer start,run,finish,flag,linear
7
7
      parameter (start=28,run=27,finish=15,linear=21)
8
8
      integer id(nsiz)
9
 
      double precision simpar(5)
 
9
      double precision simpar(7)
10
10
      integer pointi
11
11
      integer funnum
12
12
      external funnum
 
13
c
 
14
      integer solver
13
15
 
14
16
      common /dbcos/ idb
15
17
 
55
57
        n1e3 = istk(il1e3+1)
56
58
        l1e3 = sadr(il1e3+4)
57
59
c      
58
 
c       --   subvariable iz0(state)  NO MORE USED --
 
60
c       --   subvariable work(state) --
59
61
        il1e4=iadr(l1+istk(il1+5)-1)
60
62
        n1e4 = istk(il1e4+1)
61
63
        l1e4 = sadr(il1e4+4)
80
82
        n1e8 = istk(il1e8+1)
81
83
        nout = n1e8
82
84
        l1e8 = sadr(il1e8+4)
 
85
 
 
86
c      
83
87
c       checking variable tcur (number 2)
84
88
c       
85
89
        il2 = iadr(lstk(top-rhs+2))
139
143
        n4e4 = istk(il4e4+1)
140
144
        l4e4 = sadr(il4e4+4)
141
145
c      
142
 
c       --   subvariable izptr (sim) NO MORE USED --
 
146
c       --   subvariable zcptr (sim) 
143
147
        il4e5=iadr(l4+istk(il4+6)-1)
144
148
        n4e5 = istk(il4e5+1)
145
149
        l4e5 = sadr(il4e5+4)
241
245
        n4e22 = istk(il4e22+1)
242
246
        l4e22 = sadr(il4e22+4)
243
247
c      
244
 
c       --   subvariable nblk(sim) --
 
248
c       --   subvariable nb(sim) --
245
249
        il4e23=iadr(l4+istk(il4+24)-1)
246
250
        l4e23 = sadr(il4e23+4)
247
251
c
301
305
           nlab=1
302
306
           call iset(n4e30,1,istk(labptr),1)
303
307
        endif
 
308
 
 
309
c       --   subvariable modptr(sim) --
 
310
        il4e31=iadr(l4+istk(il4+32)-1)
 
311
        n4e31 = istk(il4e31+1)
 
312
        l4e31 = sadr(il4e31+4)
 
313
c      
 
314
c 
 
315
 
304
316
c
305
317
c       checking variable flag (number 5)
306
318
        il5 = iadr(lstk(top-rhs+5))
329
341
        endif
330
342
 
331
343
        if(rhs.ge.6) then
332
 
c     checking variable simpar (number 6) [atol  rtol ttol, deltat, scale]
 
344
c     checking variable simpar (number 6) 
 
345
c      [atol  rtol ttol, deltat, scale, impl, hmax]
333
346
c     
334
347
           il6 = iadr(lstk(top-rhs+6))
335
348
           if (istk(il6) .ne. 1) then
338
351
              return
339
352
           endif
340
353
           m6 = istk(il6+1)*istk(il6+2)
341
 
           if (m6 .ne. 5.and. m6.ne.4) then
 
354
           if (m6 .ne. 5.and. m6.ne.4.and. m6.ne.6.and. m6.ne.7) then
342
355
              err = 6
343
356
              call error(89)
344
357
              return
356
369
          call error(42)
357
370
          return
358
371
        endif
 
372
        if (n4e3 .ne. n4e5) then
 
373
          call error(42)
 
374
          return
 
375
        endif
359
376
        if (n4e3 .ne. n4e6) then
360
377
          call error(42)
361
378
          return
413
430
c       not implemented yet
414
431
        call entier(n4e3,stk(l4e3),istk(iadr(l4e3)))
415
432
        call entier(n4e4,stk(l4e4),istk(iadr(l4e4)))
416
 
c        call entier(n1e4,stk(l1e4),istk(iadr(l1e4)))
417
 
c        call entier(n4e5,stk(l4e5),istk(iadr(l4e5)))
 
433
        call entier(n4e5,stk(l4e5),istk(iadr(l4e5)))
418
434
        call entier(n1e6,stk(l1e6),istk(iadr(l1e6)))
419
435
        call entier(n4e6,stk(l4e6),istk(iadr(l4e6)))
420
436
        call entier(n4e7,stk(l4e7),istk(iadr(l4e7)))
426
442
        call entier(n4e14,stk(l4e14),istk(iadr(l4e14)))
427
443
        call entier(n4e15,stk(l4e15),istk(iadr(l4e15)))
428
444
        call entier(n4e16,stk(l4e16),istk(iadr(l4e16)))
429
 
c        call entier(n4e17*m4e17,stk(l4e17),istk(iadr(l4e17)))
 
445
        call entier(n4e31,stk(l4e31),istk(iadr(l4e31)))
430
446
        call entier(n4e18*m4e18,stk(l4e18),istk(iadr(l4e18)))
431
447
        call entier(n4e19*m4e19,stk(l4e19),istk(iadr(l4e19)))
432
448
        call entier(n4e20*m4e20,stk(l4e20),istk(iadr(l4e20)))
445
461
        if(m6.eq.4) then
446
462
           call dcopy(4,stk(l6),1,simpar,1)
447
463
           simpar(5)=  0.d0
448
 
        else
 
464
           simpar(6)=  0.d0
 
465
           simpar(7)=  0.d0
 
466
        elseif(m6.eq.5) then
449
467
           call dcopy(5,stk(l6),1,simpar,1)
 
468
           simpar(6)=  0.d0
 
469
           simpar(7)=  0.d0
 
470
        elseif(m6.eq.6) then
 
471
           call dcopy(6,stk(l6),1,simpar,1)
 
472
           simpar(7)=  0.d0
 
473
        else
 
474
           call dcopy(7,stk(l6),1,simpar,1)
450
475
        endif
 
476
        solver=simpar(6)
451
477
c
452
478
        lfunpt=iadr(lw)
453
479
        lw=sadr(lfunpt+nblk)
454
480
c
455
 
        ncst = n1e2
456
 
        ndst = n1e3
457
481
        linpptr=iadr(l4e6)
458
 
        linplnk=iadr(l4e8)
459
482
        llnkptr=iadr(l4e10)
460
483
        iloutptr=iadr(l4e7)
461
484
c
462
 
c        niz = n1e4
463
 
c        liz0=iadr(l1e4)
464
 
 
465
 
        ng=0
466
 
c        do 02 kfun = ncblk+ndblk+1,nblk
467
 
        do 02 kfun = 1,nblk
468
 
           if(istk(ilztyp+kfun-1).eq.1) then
469
 
c     .    loop on block input ports
470
 
              do 01 kport=istk(linpptr-1+kfun),istk(linpptr+kfun)-1
471
 
c     .       get corresponding link pointer 
472
 
                 klink=istk(linplnk-1+kport)
473
 
                 ng=ng+istk(llnkptr+klink)-istk(llnkptr-1+klink)
474
 
 01           continue
475
 
           endif
476
 
 02     continue
477
 
c     
478
 
c     maximum block state and input sizes      
479
 
c        ilst=iadr(l4e3)
 
485
 
 
486
c
 
487
c        ng=istk(iadr(l4e5)+n4e5-1)-1
 
488
 
480
489
        ilinp=iadr(l4e4)
481
 
c        ilout=iadr(l4e5)
482
 
c        ilclk=iadr(l4e11)
483
 
        
484
 
 
485
 
        nn42=nout+22+ncst*max(16,ncst + 9)+3*ng 
486
 
        lw42=lw
487
 
        lw=lw+nn42
488
 
        nn43= 20 + ncst + 2*ng
489
 
        lw43=lw
490
 
        lw=lw+nn43
491
 
        nn44=2*nblk
492
 
        lw44=lw
493
 
        lw=lw+sadr(nn44)+1
494
 
 
495
490
        err=lw-lstk(bot)
496
491
        if (err .gt. 0) then
497
492
          call error(17)
540
535
c
541
536
        if(ddt.ne.0) idb=1
542
537
c
543
 
        call scicos(stk(l1e2),istk(iadr(l4e3)),stk(l1e3),istk(ilinp),
 
538
        call scicos(stk(l1e2),istk(iadr(l4e3)),stk(l1e3),
 
539
     $       stk(l1e4),istk(ilinp),
 
540
     $       istk(iadr(l4e31)),
544
541
     &       istk(llab),istk(labptr),stk(l2),stk(l3),stk(l1e5),
545
542
     $       istk(iadr(l1e6)),n1e5,pointi,stk(l1e8),nout,
546
543
     $       istk(lfunpt),istk(iadr(l4e28)),istk(linpptr),
551
548
     $       istk(iadr(l4e18)),istk(iadr(l4e19)),n4e19,
552
549
     $       istk(iadr(l4e29)),n4e29,
553
550
     $       istk(iadr(l4e20)),n4e20,istk(iadr(l4e21)),n4e21,
554
 
     $       istk(iadr(l4e22)),nblk,istk(iadr(l4e24)),ng,
555
 
     $       istk(iadr(l4e27)),n4e27,simpar,stk(lw42),stk(lw43),
556
 
     $       stk(lw44),flag,ierr)
 
551
     $       istk(iadr(l4e22)),nblk,istk(iadr(l4e24)),istk(iadr(l4e5)),
 
552
     $       istk(iadr(l4e27)),n4e27,simpar,flag,ierr)
557
553
        idb=0
558
554
        if (ierr .gt. 0 ) then
559
555
           if(ierr.eq.1) then
583
579
           elseif(ierr.eq.4) then
584
580
              buf='algrebraic loop detected'
585
581
              kfun=0
 
582
           elseif(ierr.eq.5) then
 
583
              buf='cannot allocate memory'
 
584
              kfun=0
 
585
           elseif(ierr.eq.21) then
 
586
              write(buf,'(''cannot allocate memory in block='',i5)') 
 
587
     $             kfun
 
588
              kfun=0
 
589
           elseif(ierr.eq.22) then
 
590
              buf='sliding mode condition, cannot integrate'
 
591
              kfun=0
586
592
           else
587
593
              buf='scicos unexpected error,please report...'
588
594
              kfun=0
691
697
      logical putlhsvar,checkrhs,checklhs
692
698
      character*(nlgh) fname
693
699
c
694
 
      goto (1,2,3,4,5) fin 
 
700
      goto (1,2,3,4,5,6,7,8) fin 
695
701
      return
696
702
 1    call intsscicos
697
703
      return
718
724
      if(.not.checkrhs(fname,5,5)) return
719
725
      call intree4(fname)
720
726
      goto 9988
 
727
 6    continue
 
728
      fname='realtimeinit'
 
729
      call intsrealtimeinit(fname)
 
730
      goto 9988
 
731
 7    continue
 
732
      fname='realtime'
 
733
      call intsrealtime(fname) 
 
734
      goto 9988
 
735
 8    continue
 
736
c     scicos_debug(i)
 
737
      if(.not.checklhs(fname,1,1)) return
 
738
      if(.not.checkrhs(fname,1,1)) return
 
739
      fname='scicos_debug'
 
740
      call scicosdebug(fname)
 
741
      goto 9988
721
742
 9988 if(.not.putlhsvar())return
722
743
      end
723
744
 
812
833
      istk(iadr(iwhere(7))+2)=nr
813
834
      end
814
835
 
815
 
 
 
836
c     ********************
 
837
      subroutine  scicosdebug(fname)
 
838
c     
 
839
      include '../stack.h'
 
840
c     
 
841
      common /cosdebug/ cosd
 
842
      logical getrhsvar
 
843
      integer cosd
 
844
      character*(*) fname
 
845
c
 
846
      if(.not.getrhsvar(1,'i',n,m,i)) return
 
847
      cosd=istk(i)
 
848
      lhsvar(1)=0
 
849
      end