← Back to branch summary

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

« back to all changes in this revision

Viewing changes to routines/metanet/minty.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/metanet/minty.f
 
1
      subroutine minty(coderk,ex,gamma,i1,infr,j1,la2,lp2,ma,
 
2
     &     mm,n,or,pile,piv,predw,sufval,type,u0)
 
3
      implicit integer (a-z)
 
4
      dimension lp2(*),la2(mm),or(ma),ex(ma)
 
5
      dimension type(ma),predw(n),pile(n)
 
6
      doubleprecision sufval(n),cumul,infr
 
7
      doubleprecision gamma(ma),sf,piv(n),eps
 
8
      coderk=0
 
9
      cumul=0.
 
10
      do 50 i=1,n
 
11
         predw (i)=0
 
12
         sufval(i)=infr
 
13
         pile(i)=0
 
14
 50   continue
 
15
      predw(j1)=u0
 
16
      sufval(j1)=cumul
 
17
      top=1
 
18
      bottom=0
 
19
      pile(top)=j1
 
20
 100  continue
 
21
      bottom=bottom+1
 
22
      ii=pile(bottom)
 
23
      if(lp2(ii).eq.lp2(ii+1))goto 145
 
24
      do 140 ll=lp2(ii),lp2(ii+1)-1
 
25
         u=la2(ll)
 
26
         if(ii.eq.ex(u)) goto 105
 
27
         jj=ex(u)
 
28
         if(predw(jj).gt.0) go to 140
 
29
         goto 108
 
30
 105     jj=or(u)
 
31
         if(predw(jj).gt.0) go to 140
 
32
         goto 120
 
33
 108     continue
 
34
         goto (110,115,140,115,140,115,112,110,115,140),type(u)
 
35
 110     continue
 
36
         sf=gamma(u)-piv(jj)+piv(ii)+sufval(ii)
 
37
         if(sf.ge.sufval(jj)) go to 140
 
38
         predw(jj)=-u
 
39
         sufval(jj)=sf
 
40
         go to 140
 
41
 112     continue
 
42
         sf=piv(ii)-piv(jj)+gamma(u)+sufval(ii)
 
43
         if(sf.gt.sufval(jj)) go to 140
 
44
         predw(jj)=-u
 
45
 113     sufval(jj)=sf
 
46
         go to 140
 
47
 115     continue
 
48
         top=top+1
 
49
         if(top.le.n) goto 119
 
50
         coderk=1
 
51
         return
 
52
 119     pile(top)=jj
 
53
         predw(jj)=u
 
54
         sufval(jj)=cumul
 
55
         goto 140
 
56
 120     continue
 
57
         goto (140,130,135,140,130,125,130,135,140,130),type(u)
 
58
 125     continue
 
59
         sf=piv(ii)-piv(jj)-gamma(u)+sufval(ii)
 
60
         if(sf.gt.sufval(jj)) go to 140
 
61
         predw(jj)=-u
 
62
 128     sufval(jj)=sf
 
63
         go to 140
 
64
 130     continue
 
65
         top=top+1
 
66
         if(top.le.n) goto 132
 
67
         coderk=1
 
68
         return
 
69
 132     pile(top)=jj
 
70
         predw(jj)=u
 
71
         sufval(jj)=cumul
 
72
         go to 140
 
73
 135     continue
 
74
         sf=piv(ii)-piv(jj)-gamma(u)+sufval(ii)
 
75
         if(sf.ge.sufval(jj)) go to 140
 
76
         sufval(jj)=sf
 
77
         predw(jj)=-u
 
78
         go to 140
 
79
 140  continue
 
80
 145  continue
 
81
      if(predw(i1).gt.0) goto 300
 
82
      if(bottom.ge.top) goto 200
 
83
      goto 100
 
84
 200  continue
 
85
      eps=infr
 
86
      do 240 i=1,n
 
87
         if(predw(i).ge.0)go to 240
 
88
         if(sufval(i).gt.eps)go to 240
 
89
         umin=-predw(i)
 
90
         if(type(umin).eq.6.or.type(umin).eq.7)goto 230
 
91
         if(sufval(i).ge.eps)goto 240
 
92
 230     eps=sufval(i)
 
93
         imin=i
 
94
 240  continue
 
95
      if(eps.lt.infr) goto 245
 
96
      coderk = 2
 
97
      return
 
98
 245  continue
 
99
      umin=-predw(imin)
 
100
      if(type(umin).ne.6.and.type(umin).ne.7)goto 250
 
101
      cumul=eps
 
102
      goto 300
 
103
 250  continue
 
104
      predw(imin)=-predw(imin)
 
105
      cumul=eps
 
106
      top=top+1
 
107
      if(top.le.n)goto 260
 
108
      coderk=1
 
109
      return
 
110
 260  pile(top)=imin
 
111
      go to 100
 
112
 300  continue
 
113
      do 350 i=1,n
 
114
         if(predw(i).gt.0)go to 330
 
115
         piv(i)=piv(i)+cumul
 
116
         go to 350
 
117
 330     piv(i)=piv(i)+sufval(i)
 
118
 350  continue
 
119
      end