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
|
subroutine storeglobal(id,k)
c Copyright INRIA
INCLUDE '../stack.h'
logical update
integer iadr
integer id(nsiz)
c
logical eqid,new
integer v,vk
c
iadr(l)=l+l-1
il=iadr(lstk(k))
kg=istk(il+2)
if (.not.eqid(idstk(1,kg),id)) then
c . global variable had moved look for it by name (is it possible?)
k=vsiz+1
10 continue
k=k+1
if(k.gt.gtop) then
call error(4)
return
endif
if (.not.eqid(idstk(1,k),id)) goto 10
kg=k
endif
c
if(istk(iadr(lstk(top))).eq.0) then
c replace null variable by an empty matrix
top=top-1
call defmat
endif
c
vk=lstk(kg+1)-lstk(kg)
v=lstk(top+1)-lstk(top)
c
update=.false.
if (v.ne.vk) then
c . new variable does not fit the size of the old one
if (kg .lt. gtop) then
c . make room to install new variable
ls = lstk(kg+1)
ll = ls + v - vk
if(v.gt.vk) then
c . new is bigger, move bottom down
if (lstk(gtop+1)+v-vk.gt.lstk(gbot)) then
c . not enought memory, realloc
mem=lstk(gbot)-lstk(isiz+2)+max(v+1,10000)
call reallocglobal(mem)
if(err.gt.0) return
ls=lstk(kg+1)
ll = ls + v - vk
endif
call unsfdcopy(lstk(gtop+1)-lstk(kg+1),stk(ls),-1,
$ stk(ll),-1)
c . update pointer
else
c . new is smaller, move bottom up
call unsfdcopy(lstk(gtop+1)-lstk(kg+1),stk(ls),1,
$ stk(ll),1)
endif
update=.true.
else
if(v.gt.vk) then
if (lstk(gtop+1)+v-vk.gt.lstk(gbot)) then
c . not enought memory, realloc
mem=lstk(gbot)-lstk(isiz+2)+max(v+1,10000)
call reallocglobal(mem)
if(err.gt.0) return
endif
endif
endif
c . update pointers on variables
do 20 i=kg+1,gtop+1
lstk(i)=lstk(i) + v - vk
20 continue
if(update) then
c . following lines are necessary because of use of
c . il=iadr(istk(il+1)) to get variable pointed by an indirect
c . variable.
c . it should be no more useful with il=iadr(lstk(istk(il+2)))
do 22 i = kg+1, gtop
c . update pointers in variables which refer this global var
do 21 j=bot,isiz-1
if(infstk(j).eq.2) then
if(eqid(idstk(1,j),idstk(1,i))) then
c . variable j refers this global var
ilj=iadr(lstk(j))
istk(ilj+1)=lstk(i)
istk(ilj+2)=i
endif
endif
21 continue
22 continue
endif
endif
c copy new value
25 call unsfdcopy(v,stk(lstk(top)),1,stk(lstk(kg)),1)
c update type of the local pointer
istk(il)=-abs(istk(iadr(lstk(top))))
fin=kg
top=top-1
return
end
subroutine reallocglobal(mem)
c Copyright INRIA
INCLUDE '../stack.h'
integer offset
logical eqid
integer iadr
c
iadr(l)=l+l-1
c
l=lstk(gtop+1)-lstk(isiz+2)
call scigmem(mem+1,offset)
if(offset.eq.0) then
call error(112)
return
endif
offset=offset+1
call unsfdcopy(l,stk(lstk(isiz+2)),1,stk(offset),1)
kd=offset-lstk(isiz+2)
do 05 k=isiz+2,gtop+1
lstk(k)=lstk(k)+kd
05 continue
call freegmem()
lstk(gbot)=lstk(isiz+2)+mem
c following lines are necessary because of use of il=iadr(istk(il+1))
c to get variable pointed by an indirect variable.
c it should be no more useful with il=iadr(lstk(istk(il+2)))
do 09 i = isiz+2, gtop
c update pointers in variables which refer this global var
do 07 j=bot,isiz-1
if(infstk(j).eq.2) then
if(eqid(idstk(1,j),idstk(1,i))) then
c . variable j refers this global var
ilj=iadr(lstk(j))
istk(ilj+1)=lstk(i)
istk(ilj+2)=i
endif
endif
07 continue
09 continue
return
end
|
