← Back to branch summary

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

« back to all changes in this revision

Viewing changes to routines/interf/matsys.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/interf/matsys.f
52
52
c     19      20       21       22       23     24      25
53
53
c     funcprot whereis where   timer         havewindow stacksize
54
54
c     26         27    28      29       30       31       32
55
 
c     mtlb_mode  link     ulink  c_link addinter  fhelp  fapropos
 
55
c     mtlb_mode  link     ulink  c_link addinter <free>   <free>
56
56
c     33         34        35     36    37       38        39
57
 
c     fclear    what    sciargs  chdir getcwd ieee typename
 
57
c     fclear    what    sciargs  chdir getwd ieee typename
58
58
c     40         41       42     43     44     45    46
59
59
c     global   clearglobal isglobal gstacksize getdate intppty
60
60
c     47         48          49        50        51       52
61
 
c     lasterror version
62
 
c     53         54
63
 
 
 
61
c     lasterror version loadhistory savehistory gethistory resethistory sendtobrowser macr2tree
 
62
c     53         54        55          56         57          58        59            60
 
63
c     hidetoolbar use_as_command    
 
64
c     61             62
64
65
      if (ddt .eq. 4) then
65
66
         write(buf(1:4),'(i4)') fin
66
67
         call basout(io,wte,' matsys '//buf(1:4))
74
75
     +      251,300,320,350,370,380,390,400,410,420,
75
76
     +      450,500,510,600,610,620,630,640,650,660,
76
77
     +      670,680,681,682,683,684,690,691,692,693,
77
 
     +      694,695,697,698),fin
 
78
     +      694,695,697,698,699,700,701,702,703,704,
 
79
     +      705,706),fin
78
80
c     
79
81
c     debug
80
82
 10   call intdebug()
215
217
      goto 999
216
218
 630  call scidint("addinter")
217
219
      goto 999
218
 
 640  call scifhelp("fhelp")
 
220
 640  return
219
221
      goto 999
220
 
 650  call scifapr("fapropos")
 
222
 650  return
221
223
      goto 999
222
224
 660  call intclear("clear")
223
225
      goto 999
249
251
      goto 999
250
252
 698  call intversion('version')
251
253
      goto 999
 
254
 699  call loadhistory('loadhistory')
 
255
      goto 999
 
256
 700  call savehistory('savehistory')
 
257
      goto 999
 
258
 701  call gethistory('gethistory')
 
259
      goto 999
 
260
 702  call resethistory('resethistory')
 
261
      goto 999
 
262
 703  call openbrowser('openbrowser')
 
263
      goto 999    
 
264
 704  call macr2tree('macr2tree')
 
265
      goto 999
 
266
 705  call hidetoolbar('hidetoolbar')
 
267
      goto 999             
 
268
 706  call useascommand('use_as_command')
 
269
      goto 999             
252
270
 
253
271
 998  continue
254
272
c     fake calls : only to force the 
275
293
 999  return
276
294
      end
277
295
 
278
 
 
279
 
 
280
296
      subroutine scilink(fname) 
281
297
C     ================================================================
282
298
C    link function  
370
386
      character*(*) fname
371
387
cc    implicit undefined (a-z)
372
388
      include '../stack.h'
373
 
      integer topk,iadr
374
 
      logical getwsmat,checkrhs,getsmat,lib_cpp
375
 
 
 
389
      integer topk,iadr,gettype
 
390
      logical getwsmat,checkrhs,getsmat,lib_cpp,getscalar
376
391
      character strf*25, c_cpp*10
377
392
 
378
393
      iadr(l)=l+l-1
434
449
      strf(nlr2+1:nlr2+1)=char(0)
435
450
      top=top-1
436
451
C     first argument 
437
 
      if (.not.getwsmat(fname,topk,top,m1,n1,il1,ild1)) return
438
 
      call addinter(istk(il1),istk(ild1),m1*n1,strf,
439
 
     $     istk(il3),istk(ild3),m3*n3,c_cpp,lib_cpp,ierr)
 
452
C     jpc on accepte un entier 
 
453
      itop = gettype(top)
 
454
      if ( itop .eq. 1 ) then 
 
455
         if (.not.getscalar(fname,topk,top,il1)) return
 
456
         ilib=int(stk(il1))
 
457
         call addinter(ilib,iv,iv,iv,strf,
 
458
     $        istk(il3),istk(ild3),m3*n3,c_cpp,lib_cpp,ierr)
 
459
      else
 
460
         if (.not.getwsmat(fname,topk,top,m1,n1,il1,ild1)) return
 
461
         ilib=-1
 
462
         call addinter(ilib,istk(il1),istk(ild1),m1*n1,strf,
 
463
     $        istk(il3),istk(ild3),m3*n3,c_cpp,lib_cpp,ierr)
 
464
      endif
440
465
      if(ierr.ne.0) then
441
466
         if (ierr.eq.-1) then
442
467
            call error(236)
494
519
      integer topk,iadr
495
520
c      integer m3,n3,lr3,nlr3,m2,n2,il2,ild2,m1,n1,il1,ild1
496
521
      integer ilib,iv ,l1
497
 
      logical checkrhs,crebmat,getscalar,getsmat,cremat
 
522
      logical checkrhs,checklhs,crebmat,getscalar,getsmat,cremat
498
523
      iadr(l)=l+l-1
499
524
      if (.not.checkrhs(fname,1,2)) return
500
 
      if (.not.checkrhs(fname,1,2)) return
 
525
      if (.not.checklhs(fname,1,2)) return
501
526
      topk=top
502
527
      if (rhs.eq.2) then 
503
528
         if(.not.getscalar(fname,topk,top,lr))return
509
534
      if(.not.getsmat(fname,topk,top,m3,n3,1,1,lr3,nlr3))return
510
535
      call cvstr(nlr3,istk(lr3),buf,1)
511
536
      buf(nlr3+1:nlr3+1)=char(0)
512
 
      call iislink(buf,ilib,irep)
 
537
      call iislink(buf,ilib)
513
538
      if (.not.crebmat(fname,top,1,1,lr)) return
514
539
      if (ilib.eq.-1)  then 
515
540
         istk(lr) = 0
525
550
      end
526
551
 
527
552
 
528
 
      subroutine scifhelp(fname)
529
 
c     =============================
530
 
c     fhelp(name)
531
 
      character*(*) fname
532
 
      character*80 h
533
 
      logical checkrhs,checklhs,getsmat,checkval,cresmat2,bufstore
534
 
      include '../stack.h'
535
 
      integer a, blank,percent
536
 
      data a/10/,blank/40/,percen/56/
537
 
c
538
 
      rhs = max(0,rhs)
539
 
      lbuf = 1
540
 
      if(.not.checkrhs(fname,0,1)) return
541
 
      if(rhs.eq.0) then
542
 
         h='help'
543
 
         h(5:5)= char(0)
544
 
         call iscihelp(buf,h,ierr)
545
 
      else
546
 
         if(.not.getsmat(fname,top,top-rhs+1,m1,n1,1,1,lr1,nlr1)) return
547
 
         if(.not.checkval(fname,m1*n1,1)) return
548
 
         if(nlr1.gt.0) then
549
 
            ic=abs(istk(lr1))
550
 
            if(.not.((ic.ge.a.and.ic.lt.blank) .or. ic.eq.percen)) then
551
 
               h='symbols'
552
 
               h(8:8)= char(0)
553
 
               call iscihelp(buf,h,ierr)
554
 
            else
555
 
               if(.not.bufstore(fname,lbuf,lbufi1,lbuff1,lr1,nlr1))
556
 
     $              return
557
 
               call iscihelp(buf,buf(lbufi1:lbuff1),ierr)
558
 
            endif
559
 
         endif
560
 
      endif
561
 
      call objvide(fname,top)
562
 
      return
563
 
      end
564
 
c
565
 
      subroutine scifapr(fname)
566
 
c     =============================
567
 
c     fapropos(name)
568
 
      character*(*) fname
569
 
      logical checkrhs,checklhs,getsmat,checkval,cresmat2,bufstore
570
 
      include '../stack.h'
571
 
      rhs = max(0,rhs)
572
 
      lbuf = 1
573
 
      if(.not.checkrhs(fname,1,1)) return
574
 
      if(.not.getsmat(fname,top,top-rhs+1,m1,n1,1,1,lr1,nlr1)) return
575
 
      if(.not.checkval(fname,m1*n1,1)) return
576
 
c     conversion to lower case
577
 
      do 10 i=0,nlr1-1
578
 
         istk(lr1+i)=abs(istk(lr1+i))
579
 
 10   continue
580
 
      if(.not.bufstore(fname,lbuf,lbufi1,lbuff1,lr1,nlr1)) return
581
 
      call isciap(buf,buf(lbufi1:lbuff1),ierr)
582
 
      call objvide(fname,top)
583
 
      return
584
 
      end
585
553
 
586
554
      subroutine intfort(fname)
587
555
c     =====================================
895
863
c     sciargs()
896
864
      character*(*) fname
897
865
      logical checkrhs,checklhs
898
 
      integer iadr,sadr,ciargc
 
866
      integer iadr,sadr,sciiargc
899
867
      include '../stack.h'
900
868
c
901
869
      iadr(l)=l+l-1
907
875
      if(.not.checkrhs(fname,0,0)) return
908
876
      if(.not.checklhs(fname,1,1)) return
909
877
 
910
 
      nargs = iargc()
911
 
 
 
878
      nargs = sciiargc()
912
879
      top=top+1
913
880
      il=iadr(lstk(top))
914
881
      l=il+5+nargs+1
924
891
      istk(il+4)=1
925
892
 
926
893
      do 20 k=0,nargs
927
 
         call fgetarg(k,buf)
 
894
         call scigetarg(k,buf)
928
895
         l1=len(buf)+1
929
896
 10      l1=l1-1
930
897
         if(buf(l1:l1).eq.' ') goto 10
945
912
      subroutine intschdir(fname)
946
913
      character*(*) fname
947
914
      logical createvar,  putlhsvar
948
 
      logical checkrhs,checklhs,getsmat
 
915
      logical checkrhs,checklhs,getrhsvar
949
916
      include '../stack.h'
950
917
      nbvars=0
951
 
      if(.not.checkrhs(fname,1,1)) return
 
918
      if(.not.checkrhs(fname,0,1)) return
952
919
      if(.not.checklhs(fname,1,1)) return
953
 
 
954
 
      if(.not.getsmat(fname,top,top,m1,n1,1,1,lr,m)) return
955
 
      call cvstr(m,istk(lr),buf,1)
 
920
      if(rhs.eq.0) then
 
921
         if(.not.createvar(1,'i',1,1,l2)) return
 
922
         istk(l2)=0
 
923
         lhsvar(1)=1
 
924
         if(.not.putlhsvar()) return
 
925
         return 
 
926
      endif
 
927
 
 
928
      if(.not.getrhsvar(1,'c',m1,n1,lr)) return 
 
929
      call cluni0(cstk(lr:lr+m1*n1), buf,lp)
 
930
      buf(lp+1:lp+1)=char(0)
956
931
      if(.not.createvar(2,'i',1,1,l2)) return
957
 
      buf(m+1:m+1)=char(0)
958
 
      call scichdir(buf(1:m+1),istk(l2))
 
932
      call scichdir(buf(1:lp+1),istk(l2))
959
933
      if(istk(l2) .gt. 0) then 
960
934
         buf = fname // ': Internal Error' 
961
935
         call error(998)
1233
1207
c     .  clear all variable
1234
1208
 
1235
1209
c     .  preserve %help and scicos_pal variables
 
1210
         i1=bbot
 
1211
         fin=-1
 
1212
         call stackg(helps)
 
1213
         if(err.gt.0) return
 
1214
         if (fin.gt.0) i1=min(fin,i1)
 
1215
 
 
1216
         fin=-1
 
1217
         call stackg(scspal)
 
1218
         if(err.gt.0) return
 
1219
         if (fin.gt.0) i1=min(fin,i1)
 
1220
         bot = i1
 
1221
         if(bot.eq.bbot) goto 02
 
1222
         
1236
1223
         fin=0
1237
1224
         call stackg(helps)
1238
1225
         if(err.gt.0) return
1327
1314
      if(.not.checklhs(fname,1,1)) return
1328
1315
 
1329
1316
      if(rhs.le.0) then
1330
 
c     clear all variable
1331
 
         call iset(gtop-(isiz+1)*nsiz,0,idstk(1,isiz+2),1)
1332
 
         gtop=isiz+1
 
1317
c     clear all variable but those created by the startup
 
1318
         nprotect=6
 
1319
         nv=gtop-(isiz+1)-nprotect
 
1320
         if(nv.gt.0) then 
 
1321
            call iset(nv*nsiz,0,idstk(1,isiz+2+nprotect),1)
 
1322
            gtop=isiz+1+nprotect
 
1323
         endif
1333
1324
         goto 100
1334
1325
      endif
1335
1326
     
1405
1396
      subroutine intcomp
1406
1397
c     Copyright INRIA
1407
1398
      include '../stack.h'
1408
 
      integer cmode,topk
 
1399
      integer cmode,topk,p
1409
1400
      logical checkrhs,checklhs,getscalar,cremat
1410
1401
      integer iadr,sadr
1411
1402
c    
1413
1404
      sadr(l)=(l/2)+1
1414
1405
c
1415
1406
      call ref2val
1416
 
      if(rstk(pt).eq.901) goto 71
 
1407
      if(rstk(pt).eq.901) goto 61
1417
1408
c
1418
1409
      rhs=max(0,rhs)
1419
1410
      if(.not.checklhs('comp',1,1)) return
1467
1458
      icall=5
1468
1459
c     *call* parse  macro
1469
1460
      return
1470
 
 71   l=ids(1,pt)
 
1461
 61   l=ids(1,pt)
1471
1462
      pt=pt-1
1472
1463
      if(err1.ne.0) then
1473
1464
         comp(3)=0
1474
1465
         comp(2)=0
1475
1466
         comp(1)=0
 
1467
         if (rstk(pt).eq.904) then
 
1468
            top=toperr
 
1469
            return
 
1470
         endif
1476
1471
         il=iadr(lstk(top))
1477
1472
         istk(il)=0
1478
1473
         lhs=0
1479
1474
         err2=err1
1480
 
         err1=0
 
1475
         if(errct.eq.0) then
 
1476
            err1=0
 
1477
         else
 
1478
            top=top-1
 
1479
         endif
1481
1480
         return
1482
1481
      endif
1483
1482
      il=iadr(lstk(top))
1559
1558
     $           bptlg(lgptrs(kmac)),1)
1560
1559
            do 356 kk=kmac,nmacs-1
1561
1560
               call icopy(nsiz,macnms(1,kk+1),1,macnms(1,kk),1)
1562
 
               lgptrs(kk)=lgptrs(kk+1)
 
1561
c Francois VOGEL, May 2004
 
1562
c the following statement was wrong - replaced with the next line
 
1563
c               lgptrs(kk)=lgptrs(kk+1)
 
1564
               lgptrs(kk+1)=lgptrs(kk)+lgptrs(kk+2)-lgptrs(kk+1)
1563
1565
 356        continue
1564
 
            lgptrs(nmacs)=lgptrs(nmacs+1)
 
1566
c            lgptrs(nmacs)=lgptrs(nmacs+1)
 
1567
            lgptrs(nmacs+1)=0
 
1568
c FV, May 2004
 
1569
c else part (just these two lines) added to cure bugzilla #718
 
1570
         else
 
1571
            lgptrs(nmacs+1)=0
1565
1572
         endif
1566
1573
         nmacs=nmacs-1
1567
1574
      else
1575
1582
 357     continue
1576
1583
         if(kk.eq.kk1) goto 360
1577
1584
 
 
1585
         kk2=kk-kk1-1
1578
1586
         if(kmac.lt.nmacs) then
1579
1587
            l0=lgptrs(kmac+1)
1580
1588
            do 358 kk=kmac+1,nmacs
1581
 
               call icopy(lgptrs(kk+1)-l0,bptlg(l0),1,bptlg(l0-1),1)
 
1589
c FV, May 2004
 
1590
c changed to remove at once multiple breakpoints on a single line
 
1591
c               call icopy(lgptrs(kk+1)-l0,bptlg(l0),1,bptlg(l0-1),1)
 
1592
               call icopy(lgptrs(kk+1)-l0,bptlg(l0),1,bptlg(l0-kk2),1)
1582
1593
               l0=lgptrs(kk+1)
1583
 
               lgptrs(kk+1)=lgptrs(kk+1)-1
 
1594
c               lgptrs(kk+1)=lgptrs(kk+1)-1
 
1595
               lgptrs(kk)=lgptrs(kk)-kk2
1584
1596
 358        continue
1585
1597
         endif
1586
 
         lgptrs(kmac+1)=lgptrs(kmac+1)-1
 
1598
c         lgptrs(kmac+1)=lgptrs(kmac+1)-1
 
1599
         lgptrs(nmacs+1)=lgptrs(nmacs+1)-kk2
 
1600
         lgptrs(nmacs+2)=0
1587
1601
         if(lgptrs(kmac+1).eq.lgptrs(kmac)) then
1588
1602
            if(kmac.lt.nmacs) then
1589
1603
               do 359 kk=kmac,nmacs-1
1592
1606
 359           continue
1593
1607
            endif
1594
1608
            lgptrs(nmacs)=lgptrs(nmacs+1)
 
1609
            lgptrs(nmacs+1)=0
1595
1610
            nmacs=nmacs-1
1596
1611
         endif
1597
1612
      endif
1985
2000
         fin=-5
1986
2001
         call stackg(id)
1987
2002
         if(err.gt.0) return
1988
 
         if (gtop+1.gt.isizt) then
 
2003
         if (gtop+2.gt.isizt) then
1989
2004
            call error(262)
1990
2005
            return
1991
2006
         endif
1997
2012
            if(err.gt.0) return
1998
2013
            if(fin.eq.0) then
1999
2014
c     .        no, create an empty variable in the global area
 
2015
               vol=5
 
2016
               if (lstk(gtop+1)+vol.gt.lstk(gbot)) then
 
2017
c     .           not enought memory, realloc
 
2018
                  mem=lstk(gbot)-lstk(isiz+2)+max(vol+1,10000)
 
2019
                  call reallocglobal(mem)
 
2020
                  if(err.gt.0) return
 
2021
               endif
2000
2022
               gtop=gtop+1
2001
2023
               call putid(idstk(1,gtop),id)
2002
2024
               infstk(gtop)=0
2009
2031
            else
2010
2032
c     .        yes, move it to the global area
2011
2033
               vol=lstk(fin+1)-lstk(fin)
2012
 
               if (lstk(gtop+1)+vol.gt.lstk(gbot)) then
2013
 
                  mem=lstk(gbot)-lstk(isiz+2)+vol+1
 
2034
               if (lstk(gtop+1)+vol+10.ge.lstk(gbot)) then
 
2035
c     .           max(vol+1,100000) to avoid too many reallocation
 
2036
                  mem=lstk(gbot)-lstk(isiz+2)+max(vol+1,10000)
2014
2037
                  call reallocglobal(mem)
2015
2038
                  if(err.gt.0) return
2016
2039
               endif
2396
2419
c     .     mark n oldest current variables as protected
2397
2420
            if(.not.getscalar('predef',top,top,l)) return
2398
2421
            is=isiz
2399
 
            bbot=max(bot,isiz-max( nint(stk(l)),(isiz-bot0) ) )
 
2422
            bbot=max(bot,min(isiz-nint(stk(l)),bot0))
2400
2423
         elseif(ityp.eq.10) then
2401
2424
            if(.not.getsmat('predef',top,top,m,n,1,1,l,n1)) return
2402
2425
            if(.not.checkval('predef',m*n,1) ) return
2405
2428
               bbot=bot
2406
2429
            elseif(abs(istk(l)).eq.12) then
2407
2430
c     .        unmark all 
2408
 
               bbot=max(bot,isiz-max(0,(isiz-bot0) ) )
 
2431
               bbot=bot0
2409
2432
            else
2410
2433
               buf='Unknown option'
2411
2434
               call error(901)
2441
2464
      count=0
2442
2465
      pt0=pt+1
2443
2466
 151  pt0=pt0-1
2444
 
      if(pt0.le.0) goto 156
2445
 
       if(rstk(pt0).eq.802.or.rstk(pt0).eq.612 .or.
 
2467
      if(pt0.le.0) return
 
2468
         
 
2469
      if(rstk(pt0).eq.802.or.rstk(pt0).eq.612 .or.
2446
2470
     &     (rstk(pt0).eq.805.and.eqid(ids(1,pt0),sel)).or.
2447
2471
     &     (rstk(pt0).eq.616.and.pstk(pt0).eq.10)) count=count+1
2448
2472
      if(int(rstk(pt0)/100).ne.5) goto 151
2454
2478
         pstk(pt0+2)=count
2455
2479
      elseif(rstk(pt0).eq.502) then
2456
2480
c     resume in an uncompiled macro or an exec or an execstr
2457
 
         if(rstk(pt0-1).eq.903) then
 
2481
         if(rstk(pt0-1).eq.903.or.rstk(pt0-1).eq.706) then
2458
2482
c     .  in an execstr, check execstr calling context
2459
 
 
 
2483
            ip0=pt0+1
2460
2484
            pt0=pt0-2
2461
2485
 153        pt0=pt0-1
2462
 
            if(pt0.le.0) goto 156
 
2486
            if(pt0.le.0) return
2463
2487
            if(rstk(pt0).eq.802.or.rstk(pt0).eq.612 .or.
2464
2488
     &           (rstk(pt0).eq.805.and.eqid(ids(1,pt0),sel)).or.
2465
2489
     &           (rstk(pt0).eq.616.and.pstk(pt0).eq.10)) count=count+1
2466
 
            if(rstk(pt0).ne.501.and.rstk(pt0).ne.502) goto 153
2467
 
            if(paus.ne.0.and.rstk(pt0).eq.201) then
 
2490
            if(rstk(pt0).lt.501.or.rstk(pt0).gt.503) goto 153
 
2491
            if(rstk(pt0).eq.503.and.rio.eq.rte.and.pause.ne.0) then
 
2492
c     .       resume appele dans par un execstr sous pause
 
2493
               k=lpt(1)-(13+nsiz)
 
2494
               lpt(1)=lin(k+1)
 
2495
               macr=macr-1
 
2496
 
 
2497
               k=lpt(1)-(13+nsiz)
 
2498
               bot=lin(k+5)
 
2499
               mrhs=rhs
 
2500
               rhs=0
 
2501
               paus=paus-1
 
2502
               do 154 i=1,mrhs
 
2503
                  call stackp(ids(1,ip0),0)
 
2504
                  ip0=ip0-1
 
2505
 154           continue
 
2506
               paus=paus+1
 
2507
               lin(k+5)=bot
 
2508
               top=top-count
 
2509
               pt=pt0
 
2510
               goto 999
 
2511
            elseif(paus.ne.0.and.rstk(pt0).eq.201) then
2468
2512
c     .        ???
2469
2513
               r=rstk(pt0-4)
2470
2514
               if (r.eq.701.or.r.eq.604) goto 156
2501
2545
         pt=pt-3
2502
2546
         k=lpt(1)-(13+nsiz)
2503
2547
         bot=lin(k+5)
 
2548
         if(macr.ne.0.or.paus.ne.0) then
 
2549
            lpts=lpt(1)
 
2550
            lpt(1)=lin(k+1)
 
2551
         endif
2504
2552
         mrhs=rhs
2505
2553
         rhs=0
2506
2554
         paus=paus-1
2509
2557
            pt=pt-1
2510
2558
 155     continue
2511
2559
         paus=paus+1
 
2560
         if(macr.ne.0.or.paus.ne.0) then
 
2561
            lpt(1)=lpts
 
2562
         endif
2512
2563
         lin(k+5)=bot
2513
2564
         top=top-count
2514
2565
      else
2550
2601
c      if(rhs.eq.1) lnb=1
2551
2602
      if(nmacs.gt.0) then
2552
2603
         do 323 kmac=1,nmacs
2553
 
            if(eqid(macnms(1,kmac),id)) goto 325
 
2604
c Francois VOGEL, May 2004
 
2605
c            if(eqid(macnms(1,kmac),id)) goto 325
 
2606
            if(eqid(macnms(1,kmac),id)) goto 324
2554
2607
 323     continue
2555
2608
      endif
 
2609
C Serge Steer May 2004
 
2610
      if (nmacs.ge.maxdb) then
 
2611
         buf='Too many functions contain breakpoints'
 
2612
         call error(9999)
 
2613
         return
 
2614
      endif
 
2615
 
2556
2616
      nmacs=nmacs+1
2557
2617
      call putid(macnms(1,nmacs),id)
 
2618
C Serge Steer May 2004
 
2619
      if (lgptrs(nmacs)+1.gt.maxbpt) then
 
2620
         buf='Too many defined  breakpoints'
 
2621
         call error(9998)
 
2622
         return
 
2623
      endif
 
2624
  
2558
2625
      lgptrs(nmacs+1)=lgptrs(nmacs)+1
2559
2626
      bptlg(lgptrs(nmacs))=lnb
2560
2627
      goto 330
 
2628
c FV, May 2004
 
2629
c do statement added to avoid definition of duplicate bpts
 
2630
 324  do 3241 kk=lgptrs(kmac),lgptrs(kmac+1)-1
 
2631
          if (bptlg(kk).eq.lnb) goto 330
 
2632
 3241 continue
2561
2633
 325  if(kmac.eq.nmacs) then
2562
2634
         lgptrs(nmacs+1)=lgptrs(nmacs+1)+1
 
2635
C Serge Steer May 2004
 
2636
         if (lgptrs(nmacs+1)-1.gt.maxbpt) then
 
2637
            buf='Too many defined  breakpoints'
 
2638
            call error(9998)
 
2639
            return
 
2640
         endif
2563
2641
         bptlg(lgptrs(nmacs+1)-1)=lnb
2564
2642
      else
 
2643
C Serge Steer May 2004
 
2644
        if (lgptrs(nmacs+1)-1.gt.maxbpt) then
 
2645
            buf='Too many defined  breakpoints'
 
2646
            call error(9998)
 
2647
            return
 
2648
         endif
 
2649
  
2565
2650
         do 326 kk=nmacs,kmac,-1
2566
2651
            l0=lgptrs(kk)
2567
2652
            call icopy(lgptrs(kk+1)-l0,bptlg(l0),-1,bptlg(l0+1),-1)
2568
2653
            lgptrs(kk+1)=lgptrs(kk+1)+1
2569
2654
 326     continue
2570
 
         bptlg(lgptrs(kmac+1)-1)=lnb
 
2655
c FV, May 2004
 
2656
c this statement was wrong - replaced with next line
 
2657
c         bptlg(lgptrs(kmac+1)-1)=lnb
 
2658
         bptlg(lgptrs(kmac))=lnb
2571
2659
      endif
2572
2660
 330  continue
2573
2661
      call objvide('setbpt',top)
2577
2665
      subroutine intstacksize
2578
2666
c     Copyright INRIA
2579
2667
      include '../stack.h'
2580
 
      integer offset
 
2668
      integer offset,p
2581
2669
      logical checkrhs,checklhs,cremat,getscalar
2582
2670
      integer iadr,sadr
2583
2671
c
2599
2687
 
2600
2688
      if(.not.getscalar('stacksize',top,top,l)) return
2601
2689
      top=top-1
2602
 
      if (top.ne.0) then
2603
 
         buf='stacksize cannot be used in this context'
2604
 
         call error(1502)
 
2690
c
 
2691
      if (stk(l).lt.1000.or.stk(l).gt.2.0d0**31) then
 
2692
         buf='Out of bounds value for stacksize argument'
 
2693
         call error(1504)
2605
2694
         return
2606
2695
      endif
2607
2696
      mem=stk(l)
2608
2697
      memold=lstk(isiz)-lstk(1)
2609
 
      if (mem.eq.memold) goto 502
2610
 
      l=lstk(isiz)-lstk(bot)
2611
 
      if (mem.lt.l) then
 
2698
      if (mem.eq.memold) goto 50
 
2699
      lbot=lstk(isiz)-lstk(bot)
 
2700
      ltop=0
 
2701
      if (top.gt.0) ltop=lstk(top+1)-lstk(1)
 
2702
      if (mem.lt.lbot+ltop) then
2612
2703
         buf='Required memory too small for defined data'
2613
2704
         call error(1503)
2614
2705
         return
2619
2710
         return
2620
2711
      endif
2621
2712
      offset=offset+1
2622
 
      call unsfdcopy(l,stk(lstk(bot)),1,stk(offset+mem-l),1)
2623
 
      kd=offset-lstk(1)+mem-memold
2624
 
      do 501 k=bot,isiz
2625
 
         lstk(k)=lstk(k)+kd
2626
 
 501  continue 
 
2713
      l1=lstk(1)
 
2714
      l2=lstk(bot)
 
2715
c     copy the top of the stack
 
2716
      if (top.gt.0) call unsfdcopy(ltop,stk(l1),1,stk(offset),1)
 
2717
      kd1=offset-l1
 
2718
      do 30 k=1,top+1
 
2719
         lstk(k)=lstk(k)+kd1
 
2720
 30   continue
 
2721
 
 
2722
c     copy the bottom of the stack
 
2723
      call unsfdcopy(lbot,stk(l2),1,stk(offset+mem-lbot),1)
 
2724
      kd2=offset+mem-lbot-l2
 
2725
      do 40 k=bot,isiz
 
2726
         lstk(k)=lstk(k)+kd2
 
2727
 40   continue
 
2728
 
2627
2729
      call freemem()
2628
 
      lstk(1)=offset
 
2730
c     update reference variables
 
2731
      do 41 i=1,top
 
2732
         if(infstk(i).ne.2) then
 
2733
            il=iadr(lstk(i))
 
2734
            if(istk(il).lt.0) istk(il+1)=istk(il+1)+kd1
 
2735
         endif
 
2736
 41   continue
 
2737
      do 42 i=bot,isiz-1
 
2738
         if(infstk(i).ne.2) then
 
2739
            il=iadr(lstk(i))
 
2740
            if(istk(il).lt.0) istk(il+1)=istk(il+1)+kd2
 
2741
         endif
 
2742
 42   continue
 
2743
 
 
2744
c     rebuild asolute pointers if necessary see macro.f  and run.f
 
2745
      if(macr.gt.0) then
 
2746
         lpt1=lpt(1)
 
2747
c     Check if a compiled macro is running
 
2748
         p=pt+1
 
2749
 45      p=p-1
 
2750
         if((rstk(p).ge.601.and.rstk(p).le.603).or.rstk(p).eq.605) then
 
2751
            call adjuststkptr(pstk(p),kd1,kd2,l2)
 
2752
         elseif(rstk(p).eq.604.or.rstk(p).eq.606) then
 
2753
            call adjuststkptr(ids(1,p),kd1,kd2,l2)
 
2754
            if(rstk(p).le.606) call adjuststkptr(ids(2,p),kd1,kd2,l2)
 
2755
         elseif(rstk(p).ge.611.and.rstk(p).le.616) then
 
2756
             call adjuststkptr(ids(1,p),kd1,kd2,l2)
 
2757
             if(rstk(p).ge.614) call adjuststkptr(pstk(p),kd1,kd2,l2)
 
2758
         elseif(rstk(p).eq.501.or.rstk(p).eq.502.or.rstk(p).eq.503) then
 
2759
            k = lpt1 - (13+nsiz)
 
2760
            lpt1 = lin(k+1)
 
2761
            if(rstk(p).eq.501.or.rstk(p).eq.502) then
 
2762
               call adjuststkptr(lin(k+6),kd1,kd2,l2)
 
2763
               call adjuststkptr(lin(k+7),kd1,kd2,l2)
 
2764
               call adjuststkptr(ids(3,p),kd1,kd2,l2)
 
2765
            endif
 
2766
         endif
 
2767
         if(p.gt.0) goto 45
 
2768
      endif
 
2769
 
2629
2770
      leps=sadr(iadr(lstk(isiz-5)) +4)
2630
2771
 
2631
 
 502  continue
2632
 
      top=top+1
 
2772
 50   top=top+1
2633
2773
      call objvide('stacksize',top)
2634
2774
      return
2635
2775
      end
 
2776
      subroutine adjuststkptr(p,topoffset,botoffset,lbot)
 
2777
c     routine for intstacksize
 
2778
      integer p,topoffset,botoffset,lbot
 
2779
      if(p.ge.2*lbot) then
 
2780
         p=p+2*botoffset
 
2781
      else
 
2782
         p=p+2*topoffset
 
2783
      endif
 
2784
      end
 
2785
 
2636
2786
      subroutine inttimer
2637
2787
c     Copyright INRIA
2638
2788
      include '../stack.h'
2885
3035
      subroutine intgetdate()
2886
3036
c     Copyright INRIA
2887
3037
      include '../stack.h'
2888
 
      parameter (nf=9)
 
3038
      parameter (nf=10)
2889
3039
      integer w(nf),dt
2890
 
      logical checkrhs,checklhs,cremat,getscalar
 
3040
      logical checkrhs,checklhs,cremat,getscalar,getrmat
2891
3041
      integer gettype
2892
3042
c
2893
3043
      rhs=max(0,rhs)
2899
3049
            job=0
2900
3050
            top=top-1
2901
3051
            n=1
2902
 
         else
2903
 
            if(.not.getscalar('getdate', top,top, lr)) return
2904
 
            dt=stk(lr)
2905
 
            call convertdate(dt,w)
2906
 
            n=nf
 
3052
         else 
 
3053
            if(.not.getrmat('getdate', top, top, m1, n1, lr)) return
 
3054
            top=top+1
 
3055
            if(.not.cremat('getdate',top,0,m1*n1,nf,l,lc)) return
 
3056
            do 05 i=0,m1*n1-1
 
3057
               dt=stk(lr+i)
 
3058
               call convertdate(dt,w)
 
3059
c     .         dt contains a number of seconds, number of milliseconds
 
3060
C     .         w(10) must be 0
 
3061
               w(10)=0
 
3062
               call int2db(nf,w,1,stk(l+i),m1*n1)
 
3063
 05         continue
 
3064
            call copyobj('getdate',top,top-1)
2907
3065
            top=top-1
2908
 
            goto 10
 
3066
            return
2909
3067
         endif
2910
3068
      else
2911
3069
         job=1
2963
3121
      endif
2964
3122
      return
2965
3123
      end
 
3124
 
 
3125
      subroutine useascommand(fname)
 
3126
c     Copyright INRIA
 
3127
      include '../stack.h'
 
3128
      logical checkrhs,checklhs,cremat,getscalar,getsmat,checkval
 
3129
      integer topk,id(nsiz)
 
3130
      integer iadr,sadr
 
3131
      character*1 opt
 
3132
      character*(*) fname
 
3133
c
 
3134
c    
 
3135
      iadr(l)=l+l-1
 
3136
      sadr(l)=(l/2)+1
 
3137
c
 
3138
      rhs=max(0,rhs)
 
3139
      if(.not.checkrhs(fname,1,2)) return
 
3140
      if(.not.checklhs(fname,1,1)) return
 
3141
 
 
3142
      job=1
 
3143
      topk=top
 
3144
      
 
3145
      if(rhs.eq.2) then
 
3146
         if(.not.getsmat(fname,topk,top,m,n,1,1,l,nl))return
 
3147
         if (nl.ne.1) then
 
3148
            err=2
 
3149
            call error(36)
 
3150
            return
 
3151
         endif
 
3152
         call cvstr(nl,istk(l),opt,1)
 
3153
         top=top-1
 
3154
 
 
3155
         if(opt.eq.'a') then
 
3156
            job=1
 
3157
         elseif (opt.eq.'d') then
 
3158
            job=2
 
3159
         else
 
3160
            err=2
 
3161
            call error(36)
 
3162
            return
 
3163
         endif
 
3164
      endif
 
3165
      if(.not.getsmat(fname,topk,top,m,n,1,1,l,n1)) return
 
3166
      if(.not.checkval(fname,m*n,1) ) return
 
3167
      call namstr(id,istk(l),n1,0)
 
3168
      call comand(id,job)
 
3169
      if(err.gt.0) return
 
3170
      il=iadr(lstk(top))
 
3171
      istk(il)=0
 
3172
      lstk(top+1)=lstk(top)+1
 
3173
      return
 
3174
      end