← Back to branch summary

~ubuntu-branches/ubuntu/karmic/scilab/karmic

« back to all changes in this revision

Viewing changes to routines/int/i_mput.f

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2002-03-21 16:57:43 UTC
  • Revision ID: james.westby@ubuntu.com-20020321165743-e9mv12c1tb1plztg
Tags: upstream-2.6
Import upstream version 2.6

Show diffs side-by-side

added added

removed removed

Lines of Context:
routines/int/i_mput.f
 
1
       subroutine i_mput(fname)
 
2
c
 
3
       character*(*) fname
 
4
       integer topk,rhsk,topl,fd
 
5
       logical checkrhs,checklhs,getsmat,checkval,getscalar
 
6
       character*4 ityp
 
7
 
 
8
       include '../stack.h'
 
9
c
 
10
       integer iadr, sadr
 
11
       iadr(l)=l+l-1
 
12
       sadr(l)=(l/2)+1
 
13
       rhs = max(0,rhs)
 
14
c
 
15
       lbuf = 1
 
16
       topk = top 
 
17
       rhsk = rhs 
 
18
       if(.not.checkrhs(fname,1,3)) return
 
19
       if(.not.checklhs(fname,1,1)) return
 
20
c
 
21
c       checking variable fd (number 3)
 
22
c     
 
23
       if(rhs .le. 2) then
 
24
          fd=-1
 
25
       else
 
26
          if(.not.getscalar(fname,top,top-rhs+3,lr3)) return
 
27
          fd=stk(lr3)
 
28
       endif
 
29
 
 
30
c       checking variable res (number 1)
 
31
c       
 
32
       il=iadr(lstk(top-rhs+1))
 
33
       n1=istk(il+1)*istk(il+2)
 
34
       it=istk(il+3)
 
35
       l=il+4
 
36
 
 
37
c       checking variable type (number 2)
 
38
c 
 
39
       if(rhs .le. 1) then
 
40
          ityp(1:2)='l'//char(0)
 
41
          nlr2=1
 
42
       else
 
43
          if(.not.getsmat(fname,top,top-rhs+2,m2,n2,1,1,lr2,nlr2))
 
44
     $         return
 
45
          if(.not.checkval(fname,m2*n2,1)) return
 
46
          call cvstr(nlr2,istk(lr2),ityp,1)
 
47
          ityp(nlr2+1:nlr2+1)=char(0)
 
48
       endif
 
49
 
 
50
       if(ityp(1:1).eq.'u') then
 
51
          it1=10
 
52
          ik=2
 
53
       else
 
54
          it1=0
 
55
          ik=1
 
56
       endif
 
57
       if(nlr2.eq.3) ik=3
 
58
       if(ityp(ik:ik).eq.'c') then
 
59
          it1=it1+1
 
60
       elseif(ityp(ik:ik).eq.'s') then
 
61
          it1=it1+2
 
62
       elseif(ityp(ik:ik).eq.'l') then
 
63
          it1=it1+4
 
64
       else
 
65
          buf='Incorrect integer type: '//ityp
 
66
          call error(9991)
 
67
          return
 
68
       endif
 
69
c     converting data if necessary
 
70
       if(it1.ne.it) then
 
71
          inc=1
 
72
          if(mod(it,10).lt.mod(it1,10)) then
 
73
             inc=-1
 
74
             err=sadr(l+memused(it1,n1))-lstk(bot)
 
75
             if(err.gt.0) then
 
76
                call error(17)
 
77
                return
 
78
             endif
 
79
             call tpconv(it,it1,n1, istk(l),inc,istk(l),inc)
 
80
          endif
 
81
       endif
 
82
 
 
83
 
 
84
       call mputi(fd,istk(l),n1,ityp,err)
 
85
       if(err .gt. 0) then 
 
86
        buf = fname // ' Internal Error' 
 
87
        call error(999)
 
88
        return
 
89
       endif
 
90
c
 
91
       top=topk-rhs+1
 
92
       istk(il)=0
 
93
       lstk(top+1)=sadr(il+1)
 
94
       end