![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to roots.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / spice|
Return to roots.f CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / spice |
1.1 root 1: program spice
2: implicit double precision (a-h,o-z)
3: c
4: c
5: c
6: c *** version VAX UNIX 2X.x (19aug79)
7: c developed from
8: c *** version 2d.2 (26sep76) ***
9: c *** version hp 2.0 (6dec77) ***
10: c
11: c by dick dowell - hewlett packard company
12: c richard newton - uc berkeley
13: c
14: c spice is an electronic circuit simulation program that was deve-
15: c loped by the integrated circuits group of the electronics research
16: c laboratory and the department of electrical engineering and computer
17: c sciences at the university of california, berkeley, california. the
18: c program spice is available free of charge to any interested party.
19: c the sale, resale, or use of this program for profit without the
20: c express written consent of the department of electrical engineering
21: c and computer sciences, university of california, berkeley, california,
22: c is forbidden.
23: c
24: c
25: c implementation notes:
26: c
27: c subroutines mclock and mdate return the time (as hh:mm:ss) and
28: c the date (as dd mmm yy), respectively. subroutine getcje returns in
29: c common block /cje/ various attributes of the current job environment.
30: c spice expects getcje to set /cje/ variables maxtim, itime, and icost.
31: c maxtim is the maximum cpu time in seconds, itime is the elapsed cpu
32: c time in seconds, and icost is the job cost in cents.
33: c subroutine memory is used to change the number of memory words
34: c allocated to spice. if the amount of memory allocated to a jobstep
35: c is fixed, subroutine memory need not be changed.
36: c ifamwa (set in a data statement below) should be set to the
37: c address of the first available word of memory (following overlays, if
38: c any). the proper value should be easily obtainable from any load map.
39: c with the exception of most flags, all data in spice is stored in
40: c the form of managed tables allocated in the /blank/ array value().
41: c spice is particularly well-suited to being run using a one-level
42: c overlay structure beginning with routines spice (the overlay root),
43: c readin, errchk, setup, dctran, dcop, acan, and ovtpvt. the order of
44: c the routines in this listing corresponds to that structure. note
45: c that if cdc-style overlay is to be used, an overlay directive card
46: c must be inserted before the first line of each of the just-named
47: c routines.
48: c
49: c
50: common /tabinf/ ielmnt,isbckt,nsbckt,iunsat,nunsat,itemps,numtem,
51: 1 isens,nsens,ifour,nfour,ifield,icode,idelim,icolum,insize,
52: 2 junode,lsbkpt,numbkp,iorder,jmnode,iur,iuc,ilc,ilr,numoff,isr,
53: 3 nmoffc,iseq,iseq1,neqn,nodevs,ndiag,iswap,iequa,macins,lvnim1,
54: 4 lx0,lvn,lynl,lyu,lyl,lx1,lx2,lx3,lx4,lx5,lx6,lx7,ld0,ld1,ltd,
55: 5 imynl,imvn,lcvn,loutpt,nsnod,nsmat,nsval,icnod,icmat,icval
56: common /miscel/ atime,aprog(3),adate,atitle(10),defl,defw,defad,
57: 1 defas,rstats(50),iwidth,lwidth,nopage
58: common /line/ achar,afield(15),oldlin(15),kntrc,kntlim
59: common /cirdat/ locate(50),jelcnt(50),nunods,ncnods,numnod,nstop,
60: 1 nut,nlt,nxtrm,ndist,ntlin,ibr,numvs
61: common /mosarg/ gamma,beta,vto,phi,cox,vbi,xnfs,xnsub,xd,xj,xl,
62: 1 xlamda,utra,uexp,vbp,von,vdsat,theta,vcrit,vtra,gleff,cdrain
63: common /status/ omega,time,delta,delold(7),ag(7),vt,xni,egfet,
64: 1 xmu,mode,modedc,icalc,initf,method,iord,maxord,noncon,iterno,
65: 2 itemno,nosolv,ipostp,iscrch
66: common /flags/ iprnta,iprntl,iprntm,iprntn,iprnto,limtim,limpts,
67: 1 lvlcod,lvltim,itl1,itl2,itl3,itl4,itl5,igoof,nogo,keof
68: common /knstnt/ twopi,xlog2,xlog10,root2,rad,boltz,charge,ctok,
69: 1 gmin,reltol,abstol,vntol,trtol,chgtol,eps0,epssil,epsox
70: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
71: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
72: 2 nwd8,nwd16
73: common /dc/ tcstar(2),tcstop(2),tcincr(2),icvflg,itcelm(2),kssop,
74: 1 kinel,kidin,kovar,kidout
75: common /ac/ fstart,fstop,fincr,skw2,refprl,spw2,jacflg,idfreq,
76: 1 inoise,nosprt,nosout,nosin,idist,idprt
77: common /tran/ tstep,tstop,tstart,delmax,tdmax,forfre,jtrflg
78: common /outinf/ xincr,string(15),xstart,yvar(8),itab(8),itype(8),
79: 1 ilogy(8),npoint,numout,kntr,numdgt
80: common /cje/ maxtim,itime,icost
81: c.. common for putwds
82: common /blank/ value(50000)
83: integer nodplc(64)
84: complex*16 cvalue(32)
85: equivalence (value(1),nodplc(1),cvalue(1))
86: integer*2 istats(200)
87: real*4 r4stat(100)
88: equivalence (rstats(1),istats(1),r4stat(1))
89: integer*2 inknt
90: c
91: dimension acctit(4)
92: dimension remain(4)
93: data amrje /4hmrje/
94: data ablnk /1h /
95: data acctit / 8hjob stat, 8histics s, 8hummary , 8h /
96: data ahdr1, ahdr2, ahdr3 / 8h spice 2,8h.Xx (vax,8h11/780) /
97: c
98: c
99: ipostp=0
100: maxtim=1e8
101: maxlin=50000
102: icost=0
103: ilines=0
104: c
105: c initialization
106: c
107: aprog(1)=ahdr1
108: aprog(2)=ahdr2
109: aprog(3)=ahdr3
110: achar=ablnk
111: keof=0
112: call mclock(atime)
113: call mdate(adate)
114: boltz=1.3806226d-23
115: charge=1.6021918d-19
116: ctok=273.15d0
117: eps0=8.854214871d-14
118: epssil=11.7d0*eps0
119: epsox=3.9d0*eps0
120: twopi=8.0d0*datan2(1.0d0,1.0d0)
121: rad=360.0d0/twopi
122: xlog2=dlog(2.0d0)
123: xlog10=dlog(10.0d0)
124: root2=dsqrt(2.0d0)
125: nodata=1
126: c
127: c begin job
128: c
129: 10 if (keof.eq.1) go to 1000
130: call getcje
131: call second(time1)
132: icost1=icost
133: igoof=0
134: mode=0
135: nogo=0
136: maxmem=100000
137: call setmem(nodplc(1),maxmem)
138: if (nogo.ne.0) go to 1000
139: call zero8(rstats,50)
140: c
141: c read remainder of data deck and check for input errors
142: c
143: call readin
144: if (nogo.ne.0) go to 300
145: if (keof.eq.1) go to 1000
146: nodata=0
147: call errchk
148: if (nogo.ne.0) go to 300
149: call setup
150: if (nogo.ne.0) go to 300
151: c
152: c cycle through temperatures
153: c
154: itemno=1
155: if (numtem.eq.1) go to 110
156: 100 if (itemno.eq.numtem) go to 320
157: itemno=itemno+1
158: call tmpupd
159: c
160: c dc transfer curves
161: c
162: 110 if (icvflg.eq.0) go to 150
163: c... see routine *dctran* for explanation of *mode*, etc.
164: mode=1
165: modedc=3
166: call dctran
167: call ovtpvt
168: if (nogo.ne.0) go to 300
169: c
170: c small signal operating point
171: c
172: 150 if (kssop.gt.0) go to 170
173: if (jacflg.ne.0) go to 170
174: if ((icvflg+jtrflg).gt.0) go to 250
175: 170 mode=1
176: modedc=1
177: call dctran
178: if (nogo.ne.0) go to 300
179: call dcop
180: if (nogo.ne.0) go to 300
181: c
182: c ac small signal analysis
183: c
184: 200 if (jacflg.eq.0) go to 250
185: mode=3
186: call acan
187: call ovtpvt
188: if (nogo.ne.0) go to 300
189: c
190: c transient analysis
191: c
192: 250 if (jtrflg.eq.0) go to 100
193: mode=1
194: modedc=2
195: call dctran
196: if (nogo.ne.0) go to 300
197: call dcop
198: if (nogo.ne.0) go to 300
199: mode=2
200: call dctran
201: call ovtpvt
202: if (nogo.ne.0) go to 300
203: go to 100
204: c
205: c job concluded
206: c
207: 300 write (6,301)
208: 301 format(1h0,9x,'***** job aborted')
209: nodata=0
210: c
211: c job accounting
212: c
213: 320 continue
214: numel=0
215: do 360 i=1,18
216: 360 numel=numel+jelcnt(i)
217: numtem=max0(numtem-1,1)
218: idist=min0(idist,1)
219: if (iprnta.eq.0) go to 800
220: call title(-1,lwidth,1,acctit)
221: write (6,361) nunods,ncnods,numnod,numel,(jelcnt(i),i=11,14)
222: 361 format(' nunods ncnods numnod numel diodes bjts jfets mfets'
223: 1 //,i9,2i7,i6,i8,i6,2i7)
224: write (6,371) numtem,icvflg,jtrflg,jacflg,inoise,idist,nogo
225: 371 format(/'0 numtem icvflg jtrflg jacflg inoise idist nogo'/,
226: 1 2h0 ,7i7)
227: write (6,381) rstats(20),rstats(21),rstats(22),rstats(23),
228: 1 rstats(26),rstats(27)
229: 381 format(/'0 nstop nttbr nttar ifill iops perspa'//,
230: 1 1x,5f8.0,f9.3)
231: write (6,391) rstats(30),rstats(31),rstats(32),maxmem,maxuse,
232: 1 cpyknt
233: 391 format(/'0 numttp numrtp numnit maxmem memuse copyknt',//,
234: 1 2x,3f8.0,2x,i6,2x,i6,2x,f8.0)
235: write (6,401) (rstats(i),i=1,11)
236: 401 format(/,
237: 1 1h0,9x,'readin ',12x,f10.2/,
238: 2 1h0,9x,'setup ',12x,f10.2/,
239: 3 1h0,9x,'trcurv ',12x,f10.2,10x,f6.0/,
240: 4 1h0,9x,'dcan ',12x,f10.2,10x,f6.0/,
241: 5 1h0,9x,'acan ',12x,f10.2,10x,f6.0/,
242: 6 1h0,9x,'tranan ',12x,f10.2,10x,f6.0/,
243: 7 1h0,9x,'output ',12x,f10.2)
244: 800 call getcje
245: call second(time2)
246: et=time2-time1
247: tcost=dfloat(icost-icost1)/100.0d0
248: if (iprnta.eq.0) go to 810
249: ohead=et-(rstats(1)+rstats(2)+rstats(3)+rstats(5)+rstats(7)
250: 1 +rstats(9)+rstats(11))
251: write (6,801) ohead
252: 801 format(1h0,9x,'overhead',12x,f10.2)
253: 810 write (6,811) et
254: 811 format(1h0,9x,'total job time ',f10.2)
255: tcost=tcost*11.5d0/23.0d0
256: c write(6,812) tcost
257: c 812 format(1h0,9x,'total job cost $',f8.2,
258: c 1 ' @ $11.50 per cpu minute',
259: c 2 /'0this lower rate applies for remainder of fiscal 79')
260: rstats(33)=cpyknt
261: rstats(34)=et
262: rstats(35)=tcost
263: rstats(36)=ohead
264: c.. convert dble to sgl - 72/2 is how many to convert
265: c call dblsgl(rstats(1),72)
266: istats(73)=nunods
267: istats(74)=ncnods
268: istats(75)=numnod
269: istats(76)=numel
270: istats(77)=jelcnt(11)
271: istats(78)=jelcnt(12)
272: istats(79)=jelcnt(13)
273: istats(80)=jelcnt(14)
274: istats(81)=numtem
275: istats(82)=icvflg
276: istats(83)=jtrflg
277: istats(84)=jacflg
278: istats(85)=inoise
279: istats(86)=idist
280: istats(87)=nogo
281: istats(88)=maxmem
282: istats(89)=maxuse
283: c do 820 i=1,36
284: c 820 r4stat(i)=rlconv(r4stat(i))
285: c call cadend(istats,100)
286: 900 if ((maxtim-itime).ge.limtim) go to 10
287: write (6,901)
288: 901 format('1warning: further analysis stopped due to cpu time limit'
289: 1/)
290: 1000 if(nodata.ne.0) write(6,1001)
291: 1001 format(/1x,'input deck (file) contains no data.')
292: stop
293: end
294: subroutine tmpupd
295: implicit double precision (a-h,o-z)
296: c
297: c this routine updates the temperature-dependent parameters in the
298: c device models. it also updates the values of temperature-dependent
299: c resistors. the updated values are printed.
300: c
301: common /tabinf/ ielmnt,isbckt,nsbckt,iunsat,nunsat,itemps,numtem,
302: 1 isens,nsens,ifour,nfour,ifield,icode,idelim,icolum,insize,
303: 2 junode,lsbkpt,numbkp,iorder,jmnode,iur,iuc,ilc,ilr,numoff,isr,
304: 3 nmoffc,iseq,iseq1,neqn,nodevs,ndiag,iswap,iequa,macins,lvnim1,
305: 4 lx0,lvn,lynl,lyu,lyl,lx1,lx2,lx3,lx4,lx5,lx6,lx7,ld0,ld1,ltd,
306: 5 imynl,imvn,lcvn,loutpt,nsnod,nsmat,nsval,icnod,icmat,icval
307: common /miscel/ atime,aprog(3),adate,atitle(10),defl,defw,defad,
308: 1 defas,rstats(50),iwidth,lwidth,nopage
309: common /cirdat/ locate(50),jelcnt(50),nunods,ncnods,numnod,nstop,
310: 1 nut,nlt,nxtrm,ndist,ntlin,ibr,numvs
311: common /status/ omega,time,delta,delold(7),ag(7),vt,xni,egfet,
312: 1 xmu,mode,modedc,icalc,initf,method,iord,maxord,noncon,iterno,
313: 2 itemno,nosolv,ipostp,iscrch
314: common /knstnt/ twopi,xlog2,xlog10,root2,rad,boltz,charge,ctok,
315: 1 gmin,reltol,abstol,vntol,trtol,chgtol,eps0,epssil,epsox
316: common /blank/ value(50000)
317: integer nodplc(64)
318: complex*16 cvalue(32)
319: equivalence (value(1),nodplc(1),cvalue(1))
320: c
321: c
322: dimension tmptit(4)
323: data tmptit / 8htemperat, 8hure-adju, 8hsted val, 8hues /
324: c
325: c
326: tempd=value(itemps+itemno)+ctok
327: xkt=boltz*tempd
328: oldvt=vt
329: vt=xkt/charge
330: ratio=tempd/(value(itemps+itemno-1)+ctok)
331: ratlog=dlog(ratio)
332: ratio1=ratio-1.0d0
333: delt=value(itemps+itemno)-value(itemps+1)
334: deltsq=delt*delt
335: reftmp=27.0d0+ctok
336: oldeg=egfet
337: egfet=1.16d0-(7.02d-4*tempd*tempd)/(tempd+1108.0d0)
338: oldxni=xni
339: arg=-egfet/(xkt+xkt)+1.1151d0/(boltz*(reftmp+reftmp))
340: factor=tempd/reftmp
341: factor=factor*dsqrt(factor)
342: xni=1.45d10*factor*dexp(charge*arg)
343: pbfact=(vt+vt)*dlog(oldxni/xni)
344: call title(0,lwidth,1,tmptit)
345: c
346: c resistors
347: c
348: loc=locate(1)
349: ititle=0
350: 10 if (loc.eq.0) go to 100
351: locv=nodplc(loc+1)
352: tc1=value(locv+3)
353: tc2=value(locv+4)
354: if (tc1.ne.0.0d0) go to 20
355: if (tc2.eq.0.0d0) go to 40
356: 20 if (ititle.ne.0) go to 30
357: write (6,21)
358: 21 format(//'0**** resistors',/,'0name',8x,'value',//)
359: ititle=1
360: 30 rnew=value(locv+2)*(1.0d0+tc1*delt+tc2*deltsq)
361: value(locv+1)=1.0d0/rnew
362: write (6,31) value(locv),rnew
363: 31 format(1x,a8,1p6d11.2)
364: 40 loc=nodplc(loc)
365: go to 10
366: c
367: c diode model
368: c
369: 100 loc=locate(21)
370: if (loc.eq.0) go to 200
371: write (6,101)
372: 101 format(//'0**** diode model parameters',/,'0name',9x,'is',9x,'pb',
373: 1//)
374: 110 if (loc.eq.0) go to 200
375: locv=nodplc(loc+1)
376: c... is(t2)=is(t1)*dexp(eg/(n*vt)*(t2/t1-1))*(t2/t1)^(pt/n)
377: xn=value(locv+3)
378: factor=ratio1*value(locv+8)/(xn*vt)+value(locv+9)/xn*ratlog
379: factor=dexp(factor)
380: value(locv+1)=value(locv+1)*factor
381: oldpb=value(locv+6)
382: value(locv+6)=ratio*oldpb+pbfact
383: value(locv+12)=value(locv+12)*value(locv+6)/oldpb
384: value(locv+15)=value(locv+15)*value(locv+6)/oldpb
385: vte=value(locv+3)*vt
386: value(locv+18)=vte*dlog(vte/(root2*value(locv+1)))
387: write (6,31) value(locv),value(locv+1),value(locv+6)
388: loc=nodplc(loc)
389: go to 110
390: c
391: c bipolar transistor model
392: c
393: 200 loc=locate(22)
394: if (loc.eq.0) go to 300
395: write (6,201)
396: 201 format(//'0**** bjt model parameters',/,'0name',9x,'js',8x,'bf ',
397: 1 7x,'jle',7x,'br ',7x,'jlc',7x,'vje',7x,'vjc',//)
398: 210 if (loc.eq.0) go to 300
399: locv=nodplc(loc+1)
400: c... is(t2)=is(t1)*dexp(eg/vt*(t2/t1-1))*(t2/t1)^pt
401: factln=ratio1*value(locv+42)/vt+value(locv+43)*ratlog
402: factor=dexp(factln)
403: value(locv+1)=value(locv+1)*factor
404: tb=value(locv+41)
405: bfactr=dexp(tb*ratlog)
406: value(locv+2)=value(locv+2)*bfactr
407: value(locv+8)=value(locv+8)*bfactr
408: value(locv+6)=value(locv+6)*dexp(factln/value(locv+7))/bfactr
409: value(locv+12)=value(locv+12)*dexp(factln/value(locv+13))
410: 1 /bfactr
411: oldpb=value(locv+22)
412: value(locv+22)=ratio*oldpb+pbfact
413: value(locv+46)=value(locv+46)*value(locv+22)/oldpb
414: value(locv+47)=value(locv+47)*value(locv+22)/oldpb
415: oldpb=value(locv+30)
416: value(locv+30)=ratio*oldpb+pbfact
417: value(locv+50)=value(locv+50)*value(locv+30)/oldpb
418: value(locv+51)=value(locv+51)*value(locv+30)/oldpb
419: value(locv+54)=vt*dlog(vt/(root2*value(locv+1)))
420: write (6,211) value(locv),value(locv+1),value(locv+2),
421: 1 value(locv+6),value(locv+8),value(locv+12),value(locv+22),
422: 2 value(locv+30)
423: 211 format(1x,a8,1p7d10.2)
424: loc=nodplc(loc)
425: go to 210
426: c
427: c jfet model
428: c
429: 300 loc=locate(23)
430: if (loc.eq.0) go to 400
431: write (6,301)
432: 301 format(//'0**** jfet model parameters',/,'0name',9x,'is',9x,'pb',
433: 1//)
434: 310 if (loc.eq.0) go to 400
435: locv=nodplc(loc+1)
436: value(locv+9)=value(locv+9)*dexp(ratio1*1.11d0/vt)
437: oldpb=value(locv+8)
438: value(locv+8)=ratio*oldpb+pbfact
439: value(locv+12)=value(locv+12)*value(locv+8)/oldpb
440: value(locv+13)=value(locv+13)*value(locv+8)/oldpb
441: value(locv+16)=vt*dlog(vt/(root2*value(locv+9)))
442: write (6,31) value(locv),value(locv+9),value(locv+8)
443: loc=nodplc(loc)
444: go to 310
445: c
446: c mosfet model
447: c
448: 400 loc=locate(24)
449: if (loc.eq.0) go to 1000
450: iprnt=1
451: 410 if (loc.eq.0) go to 1000
452: c.. no temperature effects have been coded for ga-as fets
453: if(nodplc(loc+2).eq.0) go to 430
454: locv=nodplc(loc+1)
455: if(iprnt.ne.0) write (6,401)
456: 401 format(//'0**** mosfet model parameters',/,'0name',8x,'vto',8x,
457: 1 'phi',9x,'pb',9x,'js',7x,'kp',//)
458: iprnt=0
459: ratio4=ratio*dsqrt(ratio)
460: value(locv+2)=value(locv+2)/ratio4
461: value(locv+23)=value(locv+23)/ratio4
462: oldphi=value(locv+4)
463: value(locv+4)=ratio*oldphi+pbfact
464: phi=value(locv+4)
465: type=nodplc(loc+2)
466: tps=value(locv+22)
467: vfb=value(locv+34)-type*oldphi
468: vstrip=vfb+0.5d0*type*oldphi
469: if(value(locv+21).ne.0.0d0) go to 415
470: vstrip=vstrip+0.5d0*(oldeg-egfet)
471: go to 420
472: 415 oldgat=oldvt*dlog(value(locv+21)/oldxni)
473: gatnew=vt*dlog(value(locv+21)/xni)
474: vstrip=vstrip+type*tps*(oldgat-gatnew)
475: 420 vfb=vstrip-0.5d0*type*phi
476: value(locv+34)=vfb+type*phi
477: value(locv+1)=value(locv+34)+type*value(locv+3)*dsqrt(phi)
478: value(locv+15)=value(locv+15)*dexp(-egfet/vt+oldeg/oldvt)
479: oldpb=value(locv+14)
480: value(locv+14)=ratio*oldpb+pbfact
481: pb=value(locv+14)
482: ratio2=oldpb/pb
483: ratio3=dsqrt(ratio2)
484: value(locv+11)=value(locv+11)*ratio3
485: value(locv+12)=value(locv+12)*ratio3
486: pbrat=1.0d0/ratio2
487: value(locv+29)=value(locv+29)*pbrat
488: value(locv+30)=value(locv+30)*pbrat
489: write (6,31) value(locv),value(locv+1),value(locv+4),
490: 1 value(locv+14),value(locv+15),value(locv+2)
491: 430 loc=nodplc(loc)
492: go to 410
493: c
494: c finished
495: c
496: 1000 return
497: end
498: subroutine find(aname,id,loc,iforce)
499: implicit double precision (a-h,o-z)
500: c
501: c this routine searches the list with number 'id' for an element
502: c with name 'aname'. loc is set to point to the element. if iforce is
503: c nonzero, then find expects to have to add the element to the list, and
504: c reports a fatal error if the element is found. if subcircuit defini-
505: c tion is in progress (nonzero value for nsbckt), then find searches the
506: c current subcircuit definition list rather than the nominal element
507: c list.
508: c
509: common /tabinf/ ielmnt,isbckt,nsbckt,iunsat,nunsat,itemps,numtem,
510: 1 isens,nsens,ifour,nfour,ifield,icode,idelim,icolum,insize,
511: 2 junode,lsbkpt,numbkp,iorder,jmnode,iur,iuc,ilc,ilr,numoff,isr,
512: 3 nmoffc,iseq,iseq1,neqn,nodevs,ndiag,iswap,iequa,macins,lvnim1,
513: 4 lx0,lvn,lynl,lyu,lyl,lx1,lx2,lx3,lx4,lx5,lx6,lx7,ld0,ld1,ltd,
514: 5 imynl,imvn,lcvn,loutpt,nsnod,nsmat,nsval,icnod,icmat,icval
515: common /cirdat/ locate(50),jelcnt(50),nunods,ncnods,numnod,nstop,
516: 1 nut,nlt,nxtrm,ndist,ntlin,ibr,numvs
517: common /flags/ iprnta,iprntl,iprntm,iprntn,iprnto,limtim,limpts,
518: 1 lvlcod,lvltim,itl1,itl2,itl3,itl4,itl5,igoof,nogo,keof
519: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
520: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
521: 2 nwd8,nwd16
522: common /blank/ value(50000)
523: integer nodplc(64)
524: complex*16 cvalue(32)
525: equivalence (value(1),nodplc(1),cvalue(1))
526: c
527: c index to the contents of the various lists:
528: c
529: c list contents
530: c ---- --------
531: c
532: c 1 resistors
533: c 2 nonlinear capacitors
534: c 3 nonlinear inductors
535: c 4 mutual inductors
536: c 5 nonlinear voltage controlled current sources
537: c 6 nonlinear voltage controlled voltage sources
538: c 7 nonlinear current controlled current sources
539: c 8 nonlinear current controlled voltage sources
540: c 9 independent voltage sources
541: c 10 independent current sources
542: c 11 diodes
543: c 12 bipolar junction transistors
544: c 13 junction field-effect transistors (jfets)
545: c 14 metal-oxide-semiconductor junction fets (mosfets)
546: c 15 s-parameter 2-port network
547: c 16 y-parameter 2-port network
548: c 17 transmission lines
549: c 18 <unused>
550: c 19 subcircuit calls
551: c 20 subcircuit definitions
552: c 21 diode model
553: c 22 bjt model
554: c 23 jfet model
555: c 24 mosfet model
556: c 25-30 <unused>
557: c 31 .print dc
558: c 32 .print tran
559: c 33 .print ac
560: c 34 .print noise
561: c 35 .print distortion
562: c 36 .plot dc
563: c 37 .plot tr
564: c 38 .plot ac
565: c 39 .plot noise
566: c 40 .plot distortion
567: c 41 outputs for dc
568: c 42 outputs for transient
569: c 43 outputs for ac
570: c 44 outputs for noise
571: c 45 outputs for distortion
572: c 46-50 <unused>
573: c
574: integer xxor
575: dimension lnod(50),lval(50)
576: data lnod / 9,13,15, 7,14,15,14,15,12, 7,
577: 1 17,37,26,34, 7, 7,34, 0, 5, 5,
578: 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
579: 3 21,21,21,21,21,21,21,21,21,21,
580: 4 8, 8, 8, 8, 8, 0, 0, 0, 0, 0 /
581: data lval / 5, 4, 4, 2, 1, 1, 1, 1, 4, 4,
582: 1 3, 4, 4,13, 1, 1, 9, 0, 1, 1,
583: 2 19,55,17,41, 0, 0, 0, 0, 0, 0,
584: 3 1, 1, 1, 1, 1,17,17,17,17,17,
585: 4 1, 1, 1, 1, 1, 0, 0, 0, 0, 0 /
586: data ndefin /2h.u/
587: c
588: c
589: anam=aname
590: call sizmem(ielmnt,isize)
591: locn=ielmnt+isize+2
592: if (nsbckt.eq.0) go to 10
593: loct=nodplc(isbckt+nsbckt)
594: loc=nodplc(loct+3)
595: if (loc.ne.0) go to 20
596: nodplc(loct+3)=locn
597: go to 60
598: 10 loc=locate(id)
599: if (loc.ne.0) go to 20
600: locate(id)=locn
601: go to 50
602: c
603: c search list for a name match
604: c
605: 20 locv=nodplc(loc+1)
606: if (xxor(anam,value(locv)).ne.0) go to 30
607: if (nsbckt.eq.0) go to 25
608: if (nodplc(loc-1).ne.id) go to 30
609: 25 if (nodplc(loc+2).eq.ndefin) go to 200
610: if (iforce.eq.0) go to 200
611: write (6,26) anam
612: 26 format('0*error*: above line attempts to redefine ',a8/)
613: nogo=1
614: 30 if (nodplc(loc).eq.0) go to 40
615: loc=nodplc(loc)
616: go to 20
617: c
618: c reserve space for this element
619: c
620: 40 nodplc(loc)=locn
621: if (nsbckt.ne.0) go to 60
622: 50 jelcnt(id)=jelcnt(id)+1
623: 60 loc=locn
624: itemp=loc+lnod(id)*nwd4-1
625: locv=nxtevn(itemp-1)+1
626: itemp=locv-itemp
627: ktmp=lnod(id)*nwd4+lval(id)*nwd8+itemp
628: call extmem(ielmnt,ktmp)
629: locv=(locv-1)/nwd8+1
630: iptr=0
631: if (nsbckt.eq.0) go to 80
632: iptr=id
633: 80 nodplc(loc-1)=iptr
634: nodplc(loc)=0
635: nodplc(loc+1)=locv
636: value(locv)=anam
637: c
638: c background storage
639: c
640: 100 nodplc(loc+2)=ndefin
641: nword=lnod(id)-4
642: if (nword.lt.1) go to 120
643: call zero4(nodplc(loc+3),nword)
644: 120 nword=lval(id)-1
645: if (nword.lt.1) go to 200
646: call zero8(value(locv+1),nword)
647: c
648: c exit
649: c
650: 200 return
651: end
652: subroutine title(ifold,len,icom,coment)
653: implicit double precision (a-h,o-z)
654: c
655: c this routine writes a title on the output file. ifold indicates
656: c whether the page eject should be to the next concave, convex, or any
657: c page fold depending on whether its value is <0, >0, or =0. the page
658: c eject is suppressed (as is much of the heading) if the variable nopage
659: c is nonzero.
660: c
661: common /tabinf/ ielmnt,isbckt,nsbckt,iunsat,nunsat,itemps,numtem,
662: 1 isens,nsens,ifour,nfour,ifield,icode,idelim,icolum,insize,
663: 2 junode,lsbkpt,numbkp,iorder,jmnode,iur,iuc,ilc,ilr,numoff,isr,
664: 3 nmoffc,iseq,iseq1,neqn,nodevs,ndiag,iswap,iequa,macins,lvnim1,
665: 4 lx0,lvn,lynl,lyu,lyl,lx1,lx2,lx3,lx4,lx5,lx6,lx7,ld0,ld1,ltd,
666: 5 imynl,imvn,lcvn,loutpt,nsnod,nsmat,nsval,icnod,icmat,icval
667: common /miscel/ atime,aprog(3),adate,atitle(10),defl,defw,defad,
668: 1 defas,rstats(50),iwidth,lwidth,nopage
669: common /status/ omega,time,delta,delold(7),ag(7),vt,xni,egfet,
670: 1 xmu,mode,modedc,icalc,initf,method,iord,maxord,noncon,iterno,
671: 2 itemno,nosolv,ipostp,iscrch
672: common /blank/ value(50000)
673: integer nodplc(64)
674: complex*16 cvalue(32)
675: equivalence (value(1),nodplc(1),cvalue(1))
676: c
677: c
678: dimension coment(4)
679: c
680: c
681: if(nopage.eq.1) go to 150
682: c
683: 30 if (len.le.80) go to 100
684: write (6,31) adate,aprog,atime,(atitle(i),i=1,10)
685: 31 format(1h1,9(2h* ),a10,1x,11(2h* ),3a8,11(2h* ),a10,9(2h *),//1h0,
686: 1 15a8/)
687: if (icom.eq.0) go to 40
688: write (6,36) coment,value(itemps+itemno)
689: 36 format(5h0****,17x,4a8,21x,'temperature =',f9.3,' deg c'/)
690: 40 write (6,41)
691: 41 format(1h0,63(2h* )//)
692: go to 200
693: c
694: c
695: 100 write (6,101) adate,aprog,atime,(atitle(i),i=1,10)
696: 101 format(1h1,5(1h*),a10,1x,8(1h*),3a8,8(1h*),a10,5(1h*)//1h0,10a8/)
697: if (icom.eq.0) go to 110
698: write (6,106) coment,value(itemps+itemno)
699: 106 format(10h0**** ,4a8,' temperature =',f9.3,' deg c'/)
700: 110 write (6,111)
701: 111 format(1h0,71(1h*)//)
702: go to 200
703: c
704: c
705: 150 if (icom.eq.0) go to 160
706: write (6,106) coment,value(itemps+itemno)
707: go to 200
708: 160 write (6,161) aprog
709: 161 format(1h0,3a8,/)
710: c
711: c finished
712: c
713: 200 return
714: end
715: subroutine dcdcmp
716: implicit double precision (a-h,o-z)
717: c
718: c this routine performs an in-place lu factorization of the coef-
719: c ficient matrix.
720: c
721: common /tabinf/ ielmnt,isbckt,nsbckt,iunsat,nunsat,itemps,numtem,
722: 1 isens,nsens,ifour,nfour,ifield,icode,idelim,icolum,insize,
723: 2 junode,lsbkpt,numbkp,iorder,jmnode,iur,iuc,ilc,ilr,numoff,isr,
724: 3 nmoffc,iseq,iseq1,neqn,nodevs,ndiag,iswap,iequa,macins,lvnim1,
725: 4 lx0,lvn,lynl,lyu,lyl,lx1,lx2,lx3,lx4,lx5,lx6,lx7,ld0,ld1,ltd,
726: 5 imynl,imvn,lcvn,loutpt,nsnod,nsmat,nsval,icnod,icmat,icval
727: common /cirdat/ locate(50),jelcnt(50),nunods,ncnods,numnod,nstop,
728: 1 nut,nlt,nxtrm,ndist,ntlin,ibr,numvs
729: common /flags/ iprnta,iprntl,iprntm,iprntn,iprnto,limtim,limpts,
730: 1 lvlcod,lvltim,itl1,itl2,itl3,itl4,itl5,igoof,nogo,keof
731: common /knstnt/ twopi,xlog2,xlog10,root2,rad,boltz,charge,ctok,
732: 1 gmin,reltol,abstol,vntol,trtol,chgtol,eps0,epssil,epsox
733: common /blank/ value(50000)
734: integer nodplc(64)
735: complex*16 cvalue(32)
736: equivalence (value(1),nodplc(1),cvalue(1))
737: data ikount /0/
738: c
739: c
740: do 100 i=2,nstop
741: io=nodplc(iorder+i)
742: if (dabs(value(lynl+io)).ge.gmin) go to 10
743: value(lynl+io)=gmin
744: igoof=igoof+1
745: if(ikount.gt.20) go to 10
746: ikount=ikount+1
747: if(io.le.nunods) write(6,9) nodplc(junode+io)
748: 9 format(' at node ',i5)
749: 10 jstart=nodplc(ilc+i)
750: jstop=nodplc(ilc+i+1)-1
751: if (jstart.gt.jstop) go to 100
752: do 90 j=jstart,jstop
753: value(lyl+j)=value(lyl+j)/value(lynl+io)
754: icol=nodplc(ilr+j)
755: kstart=nodplc(iur+i)
756: kstop=nodplc(iur+i+1)-1
757: if (kstart.gt.kstop) go to 90
758: do 80 k=kstart,kstop
759: irow=nodplc(iuc+k)
760: if (icol-irow) 20,60,40
761: c
762: c find (icol,irow) matrix term (upper triangle)
763: c
764: 20 l=nodplc(iur+icol+1)
765: 30 l=l-1
766: if (nodplc(iuc+l).ne.irow) go to 30
767: ispot=lyu+l
768: go to 70
769: c
770: c find (icol,irow) matrix term (lower triangle)
771: c
772: 40 l=nodplc(ilc+irow+1)
773: 50 l=l-1
774: if (nodplc(ilr+l).ne.icol) go to 50
775: ispot=lyl+l
776: go to 70
777: c
778: c find (icol,irow) matrix term (diagonal)
779: c
780: 60 ispot=lynl+nodplc(iorder+irow)
781: c
782: 70 value(ispot)=value(ispot)-value(lyl+j)*value(lyu+k)
783: 80 continue
784: 90 continue
785: 100 continue
786: return
787: end
788: subroutine dcsol
789: implicit double precision (a-h,o-z)
790: c
791: c this routine solves the system of circuit equations by performing
792: c a forward and backward substitution step using the previously-computed
793: c lu factors.
794: c
795: common /tabinf/ ielmnt,isbckt,nsbckt,iunsat,nunsat,itemps,numtem,
796: 1 isens,nsens,ifour,nfour,ifield,icode,idelim,icolum,insize,
797: 2 junode,lsbkpt,numbkp,iorder,jmnode,iur,iuc,ilc,ilr,numoff,isr,
798: 3 nmoffc,iseq,iseq1,neqn,nodevs,ndiag,iswap,iequa,macins,lvnim1,
799: 4 lx0,lvn,lynl,lyu,lyl,lx1,lx2,lx3,lx4,lx5,lx6,lx7,ld0,ld1,ltd,
800: 5 imynl,imvn,lcvn,loutpt,nsnod,nsmat,nsval,icnod,icmat,icval
801: common /cirdat/ locate(50),jelcnt(50),nunods,ncnods,numnod,nstop,
802: 1 nut,nlt,nxtrm,ndist,ntlin,ibr,numvs
803: common /blank/ value(50000)
804: integer nodplc(64)
805: complex*16 cvalue(32)
806: equivalence (value(1),nodplc(1),cvalue(1))
807: c
808: c forward substitution
809: c
810: do 20 i=2,nstop
811: jstart=nodplc(ilc+i)
812: jstop=nodplc(ilc+i+1)-1
813: if (jstart.gt.jstop) go to 20
814: io=nodplc(iorder+i)
815: if (value(lvn+io).eq.0.0d0) go to 20
816: do 10 j=jstart,jstop
817: jo=nodplc(ilr+j)
818: jo=nodplc(iorder+jo)
819: value(lvn+jo)=value(lvn+jo)-value(lyl+j)*value(lvn+io)
820: 10 continue
821: 20 continue
822: c
823: c back substitution
824: c
825: k=nstop+1
826: do 50 i=2,nstop
827: k=k-1
828: io=nodplc(iorder+k)
829: jstart=nodplc(iur+k)
830: jstop=nodplc(iur+k+1)-1
831: if (jstart.gt.jstop) go to 40
832: do 30 j=jstart,jstop
833: jo=nodplc(iuc+j)
834: jo=nodplc(iorder+jo)
835: value(lvn+io)=value(lvn+io)-value(lyu+j)*value(lvn+jo)
836: 30 continue
837: 40 value(lvn+io)=value(lvn+io)/value(lynl+io)
838: 50 continue
839: return
840: end
841: subroutine setmem(ipntr,ksize)
842: implicit double precision (a-h,o-z)
843: c
844: c this routine performs dynamic memory management. it is used in
845: c spice2, and useable in any program.
846: c
847: c memory is managed within an array selected by the calling program.
848: c one may either dimension this array to the 'maxmem' size, or more
849: c desirably, find the address of the first available word of memory
850: c above your program, and dimension your array to '1'. passing the
851: c address of the first data word available permits the manager to
852: c use 'illegal' indices into the data area.
853: c
854: c this routine must have access to an integer function called 'locf'
855: c which returns the address of its argument. addresses as used by this
856: c program refer to 'integer' addresses, not byte addresses.
857: c
858: c entry points:
859: c setmem - set initial memory
860: c getm4 - get block for table of integers
861: c getm8 - get block for table of floating point variables
862: c getm16 - get block for table of complex variables
863: c relmem - release part of block
864: c extmem - extend size of existing block
865: c sizmem - determine size of existing block
866: c clrmem - release block
867: c ptrmem - reset memory pointer
868: c crunch - force memory compaction
869: c avlm4 - amount of space available (integers)
870: c avlm8 - amount of space available (real)
871: c avlm16 - amount of space available (complex)
872: c
873: c calling sequences:
874: c call setmem(imem(1),maxmem)
875: c call setmem(imem(1),maxmem,kfamwa) non 3000 machines kfamwa is
876: c address of first available word
877: c of data
878: c call getm4 (ipntr,blksiz) where blksize is the number of entries
879: c call getm8 (ipntr,blksiz)
880: c call getm16(ipntr,blksiz)
881: c call relmem(ipntr,relsiz)
882: c call extmem(ipntr,extsiz) extsiz is the number of entries to be added
883: c call sizmem(ipntr,blksiz)
884: c call clrmem(ipntr)
885: c call ptrmem(ipntr1,ipntr2)
886: c call avlm4(ispace)
887: c call avlm8(ispace)
888: c call avlm16(ispace)
889: c call crunch
890: c
891: c
892: c general comments:
893: c for each block which is allocated, a 5-word entry is maintained
894: c in a table kept in high memory, of the form
895: c
896: c word contents
897: c ---- --------
898: c
899: c 1 index of imem(.) into origin of block
900: c i.e. contents of pointer (used for error check)
901: c 2 block size (in words)
902: c 3 number of words in use
903: c 4 address of variable containing block origin
904: c 5 number of words used per table entry
905: c
906: c all allocated blocks are an 'even' (nxtevn) number of words in length,
907: c where a 'word' is the storage unit required for an 'integer' variable.
908: c since block repositioning may be necessary, the convention that
909: c only one variable contain a block origin should be observed.
910: c for *getmem*, *ipntr* is set such that *array(ipntr+1)* is the
911: c first word of the allocated block. 'ipntr' is set to address the first
912: c entry of the table when used with the appropriate variable type, i.e.,
913: c nodplc(ipntr+1), value(ipntr+1), or cvalue(ipntr+1).
914: c for *clrmem*, *ipntr* is set to 'invalid' to enable rapid detection
915: c of an attempt to use a cleared block.
916: c if any fatal errors are found, a message is printed and a flag
917: c set inhibiting further action until *setmem* is called. (in this
918: c context, insufficient memory is considered a fatal error.)
919: c throughout this routine, *ldval* always contains the subscript of
920: c the last addressable word of memory, *memavl* always contains the
921: c number of available words of memory, *numblk* always contains the
922: c number of allocated blocks, and istack(*loctab* +1) always contains
923: c the first word of the block table.
924: c
925: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
926: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
927: 2 nwd8,nwd16
928: c
929: c.. arguments to memory manager are set up as arrays, even though
930: c.. the calling programs usually use simple variables for arguments.
931: c.. this is necessary if we are to guarantee that the parameters are
932: c.. passed by 'address' and not by 'value'. we must insure that locf(arg)
933: c.. returns the address of the argument, and not the address of a local
934: c.. copy of the argument. as currently configured, this subroutine should
935: c.. work on any ansi fortran compiler, provided the function 'locf' can
936: c.. be provided.
937: dimension ipntr(1)
938: c
939: logical memptr
940: c
941: c... approximate time required to copy *nwords* integer values
942: nwd4=1
943: nwd8=2
944: nwd16=4
945: memerr=0
946: nevn=nxtevn(1)
947: icheck=mod(nevn,nwd4)+mod(nevn,nwd8)+mod(nevn,nwd16)+
948: 1 mod(nxtmem(1),nevn)
949: if(icheck.eq.0) go to 2
950: memerr=1
951: call errmem(6,memerr,ipntr(1))
952: 2 cpyknt=0.0d0
953: ifamwa=locf(ipntr(1))
954: maxmem=ksize
955: ntab=nxtevn(5)
956: c... add 'lorg' to an address and you get the 'istack' index to that word
957: lorg=1-locf(istack(1))
958: ifwa=ifamwa+lorg-1
959: nwoff=locf(ipntr(1))+lorg-1
960: icore=nxtmem(1)
961: c... don't take chances, back off from 'end of memory' by nxtevn(1)
962: ldval=ifwa+nxtmem(1)-nxtevn(1)
963: memavl=ldval-ntab-ifwa
964: maxcor=0
965: maxuse=0
966: call memory
967: if(memerr.ne.0) call errmem(6,memerr,ipntr(1))
968: numblk=1
969: loctab=ldval-ntab
970: istack(loctab+1)=0
971: istack(loctab+2)=memavl
972: istack(loctab+3)=0
973: istack(loctab+4)=-1
974: istack(loctab+5)=1
975: return
976: end
977: subroutine getm4(ipntr,ksize)
978: implicit double precision (a-h,o-z)
979: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
980: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
981: 2 nwd8,nwd16
982: dimension ipntr(1)
983: iwsize=nwd4
984: call getmx(ipntr(1),ksize,iwsize)
985: return
986: end
987: subroutine getm8(ipntr,ksize)
988: implicit double precision (a-h,o-z)
989: dimension ipntr(1)
990: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
991: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
992: 2 nwd8,nwd16
993: iwsize=nwd8
994: call getmx(ipntr(1),ksize,iwsize)
995: return
996: end
997: subroutine getm16(ipntr,ksize)
998: implicit double precision (a-h,o-z)
999: dimension ipntr(1)
1000: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1001: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1002: 2 nwd8,nwd16
1003: iwsize=nwd16
1004: call getmx(ipntr(1),ksize,iwsize)
1005: return
1006: end
1007: subroutine getmx(ipntr,ksize,iwsize)
1008: implicit double precision (a-h,o-z)
1009: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1010: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1011: 2 nwd8,nwd16
1012: logical memptr
1013: dimension ipntr(1)
1014: c
1015: c*** getmem - get block
1016: c
1017: c
1018: isize=ksize*iwsize
1019: c... check for valid size
1020: if (isize.ge.0) go to 5
1021: memerr=2
1022: call errmem(3,memerr,ipntr(1))
1023: c... check for attempt to reallocate existing block
1024: 5 if (.not.memptr(ipntr(1))) go to 8
1025: memerr=3
1026: call errmem(3,memerr,ipntr(1))
1027: 8 jsize=nxtevn(isize)
1028: call comprs(0,ldval)
1029: c... check if enough space already there
1030: need=jsize+ntab-memavl
1031: if (need.le.0) go to 10
1032: c... insufficient space -- bump memory size
1033: need=nxtmem(need)
1034: icore=icore+need
1035: call memory
1036: if(memerr.ne.0) call errmem(3,memerr,ipntr(1))
1037: ltab1=ldval-ntab
1038: istack(ltab1+2)=istack(ltab1+2)+need
1039: c... relocate block entry table
1040: nwords=numblk*ntab
1041: cpyknt=cpyknt+dfloat(nwords)
1042: call copy4(istack(loctab+1),istack(loctab+need+1),nwords)
1043: loctab=loctab+need
1044: ldval=ldval+need
1045: memavl=memavl+need
1046: c... a block large enough now exists -- allocate it
1047: 10 ltab1=ldval-ntab
1048: morg=istack(ltab1+1)
1049: msiz=istack(ltab1+2)
1050: muse=istack(ltab1+3)
1051: muse=nxtevn(muse)
1052: madr=istack(ltab1+4)
1053: c... construct new table entry
1054: 15 istack(ltab1+2)=muse
1055: loctab=loctab-ntab
1056: nwords=numblk*ntab
1057: cpyknt=cpyknt+dfloat(nwords)
1058: call copy4(istack(loctab+ntab+1),istack(loctab+1),nwords)
1059: numblk=numblk+1
1060: memavl=memavl-ntab
1061: istack(ltab1+1)=morg+muse
1062: istack(ltab1+2)=msiz-muse-ntab
1063: c... set user size into table entry for this block
1064: 20 istack(ltab1+3)=isize
1065: istack(ltab1+4)=locf(ipntr(1))
1066: istack(ltab1+5)=iwsize
1067: memavl=memavl-jsize
1068: ipntr(1)=istack(ltab1+1)/iwsize
1069: call memadj
1070: return
1071: end
1072: subroutine avlm4(iavl)
1073: implicit double precision (a-h,o-z)
1074: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1075: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1076: 2 nwd8,nwd16
1077: c
1078: c*** avlmem - how much space is available ?
1079: c
1080: iavl=((maxmem-icore)/nxtmem(1))*nxtmem(1)-ntab+memavl
1081: iavl=iavl/nwd4
1082: return
1083: end
1084: subroutine avlm8(iavl)
1085: implicit double precision (a-h,o-z)
1086: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1087: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1088: 2 nwd8,nwd16
1089: iavl=((maxmem-icore)/nxtmem(1))*nxtmem(1)-ntab+memavl
1090: iavl=iavl/nwd8
1091: return
1092: end
1093: subroutine avlm16(iavl)
1094: implicit double precision (a-h,o-z)
1095: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1096: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1097: 2 nwd8,nwd16
1098: iavl=((maxmem-icore)/nxtmem(1))*nxtmem(1)-ntab+memavl
1099: iavl=iavl/nwd16
1100: return
1101: end
1102: subroutine relmem(ipntr,ksize)
1103: implicit double precision (a-h,o-z)
1104: dimension ipntr(1)
1105: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1106: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1107: 2 nwd8,nwd16
1108: logical memptr
1109: c
1110: c*** relmem - release part of block
1111: c
1112: c
1113: c... check for valid pointer
1114: if (memptr(ipntr(1))) go to 10
1115: memerr=5
1116: call errmem(5,memerr,ipntr(1))
1117: 10 isize=ksize*istack(ltab+5)
1118: c... check for valid size
1119: if (isize.ge.0) go to 20
1120: memerr=2
1121: call errmem(5,memerr,ipntr(1))
1122: 20 jsize=istack(ltab+3)
1123: if (isize.le.jsize) go to 30
1124: memerr=6
1125: call errmem(5,memerr,ipntr(1))
1126: 30 istack(ltab+3)=istack(ltab+3)-isize
1127: memavl=memavl+(nxtevn(jsize)-nxtevn(istack(ltab+3)))
1128: call memadj
1129: return
1130: end
1131: subroutine extmem(ipntr,ksize)
1132: implicit double precision (a-h,o-z)
1133: dimension ipntr(1)
1134: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1135: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1136: 2 nwd8,nwd16
1137: logical memptr
1138: c
1139: c*** extmem - extend size of existing block
1140: c
1141: c
1142: c... check for valid pointer
1143: if (memptr(ipntr(1))) go to 10
1144: memerr=5
1145: call errmem(2,memerr,ipntr(1))
1146: 10 isize=ksize*istack(ltab+5)
1147: c... check for valid size
1148: if (isize.ge.0) go to 20
1149: memerr=2
1150: call errmem(2,memerr,ipntr(1))
1151: c... check if enough space already there
1152: 20 if ((istack(ltab+2)-istack(ltab+3)).ge.isize) go to 40
1153: need=nxtevn(isize)-memavl
1154: if (need.le.0) go to 30
1155: c... insufficient space -- bump memory size
1156: need=nxtmem(need)
1157: icore=icore+need
1158: call memory
1159: if(memerr.ne.0) call errmem(2,memerr,ipntr(1))
1160: ltab1=ldval-ntab
1161: istack(ltab1+2)=istack(ltab1+2)+need
1162: c... relocate block entry table
1163: nwords=numblk*ntab
1164: cpyknt=cpyknt+dfloat(nwords)
1165: call copy4(istack(loctab+1),istack(loctab+need+1),nwords)
1166: loctab=loctab+need
1167: ldval=ldval+need
1168: memavl=memavl+need
1169: ltab=ltab+need
1170: c... move blocks to make space
1171: 30 continue
1172: call comprs(0,ltab)
1173: call comprs(1,ltab)
1174: 40 jsize=istack(ltab+3)
1175: istack(ltab+3)=istack(ltab+3)+isize
1176: memavl=memavl-(nxtevn(istack(ltab+3))-nxtevn(jsize))
1177: call memadj
1178: return
1179: end
1180: subroutine sizmem(ipntr,ksize)
1181: implicit double precision (a-h,o-z)
1182: dimension ipntr(1)
1183: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1184: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1185: 2 nwd8,nwd16
1186: logical memptr
1187: c
1188: c*** sizmem - determine size of existing block
1189: c
1190: c
1191: c... check for valid pointer
1192: if (memptr(ipntr(1))) go to 10
1193: memerr=5
1194: call errmem(7,memerr,ipntr(1))
1195: 10 ksize=istack(ltab+3)/istack(ltab+5)
1196: return
1197: end
1198: subroutine clrmem(ipntr)
1199: implicit double precision (a-h,o-z)
1200: dimension ipntr(1)
1201: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1202: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1203: 2 nwd8,nwd16
1204: logical memptr
1205: c
1206: c*** clrmem - release block
1207: c
1208: c
1209: c... check that pointer is valid
1210: if (memptr(ipntr(1))) go to 10
1211: memerr=5
1212: call errmem(1,memerr,ipntr(1))
1213: 10 msiz=istack(ltab+2)
1214: muse=istack(ltab+3)
1215: memavl=memavl+nxtevn(muse)
1216: c... assumption: first allocated block is never cleared.
1217: ltab1=ltab-ntab
1218: istack(ltab1+2)=istack(ltab1+2)+msiz
1219: c... reposition the block table
1220: nwords=ltab-loctab
1221: cpyknt=cpyknt+dfloat(nwords)
1222: call copy4(istack(loctab+1),istack(loctab+ntab+1),nwords)
1223: numblk=numblk-1
1224: loctab=loctab+ntab
1225: memavl=memavl+ntab
1226: ltab1=ldval-ntab
1227: istack(ltab1+2)=istack(ltab1+2)+ntab
1228: ipntr(1)=2**31-1
1229: call memadj
1230: return
1231: end
1232: subroutine ptrmem(ipntr,ipntr2)
1233: implicit double precision (a-h,o-z)
1234: dimension ipntr(1),ipntr2(1)
1235: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1236: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1237: 2 nwd8,nwd16
1238: logical memptr
1239: c
1240: c*** ptrmem - reset memory pointer
1241: c
1242: c... verify that pointer is valid
1243: if (memptr(ipntr(1))) go to 10
1244: memerr=5
1245: call errmem(4,memerr,ipntr(1))
1246: c... reset block pointer to be *ipntr2*
1247: 10 ipntr2(1)=ipntr(1)
1248: istack(ltab+4)=locf(ipntr2(1))
1249: call memadj
1250: return
1251: end
1252: subroutine crunch
1253: implicit double precision (a-h,o-z)
1254: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1255: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1256: 2 nwd8,nwd16
1257: c
1258: c*** crunch - force memory compaction
1259: c
1260: call comprs(0,ldval)
1261: call memadj
1262: return
1263: end
1264: subroutine errmem(inam,ierror,ipntr)
1265: implicit double precision (a-h,o-z)
1266: dimension ipntr(1)
1267: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1268: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1269: 2 nwd8,nwd16
1270: dimension errnam(7)
1271: data errnam /6hclrmem,6hextmem,6hgetmem,6hptrmem,6hrelmem,
1272: 1 6hsetmem,6hsizmem/
1273: c
1274: go to (200,410,420,300,510,530),ierror
1275: c
1276: c*** error(s) found ***
1277: c
1278: c.. nxtevn and/or nxtmem incompatible with nwd4, nwd8, and nwd16
1279: c
1280: 200 write(6,201)
1281: 201 format('0memory manager variables nwd4-8-16 incompatible with nxte
1282: 1vn and nxtmem')
1283: go to 900
1284: c
1285: c... memory needs exceed maximum available space
1286: 300 write (6,301) maxmem
1287: 301 format('0*error*: memory needs exceed',i6,/,
1288: 1 '0probable remedy, replace your "// exec spice" card with',/
1289: 2 '0// exec spice,region=2000k')
1290: go to 900
1291: c... *isize* < 0
1292: 410 write(6,411)
1293: 411 format('0size parameter negative')
1294: go to 900
1295: c... getmem: attempt to reallocate existing block
1296: 420 write(6,421)
1297: 421 format('0attempt to reallocate existing table')
1298: go to 900
1299: c... *ipntr* invalid
1300: 510 write(6,511)
1301: 511 format('0table pointer invalid')
1302: go to 900
1303: c... relmem: *isize* larger than indicated block
1304: 530 write(6,531)
1305: 531 format('0attempt to release more than total table')
1306: c... issue error message
1307: 900 write (6,901) errnam(inam)
1308: 901 format('0*abort*: internal memory manager error at entry ',
1309: 1 a7)
1310: 950 call dmpmem(ipntr(1))
1311: 1000 stop
1312: end
1313: subroutine memadj
1314: implicit double precision (a-h,o-z)
1315: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1316: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1317: 2 nwd8,nwd16
1318: c
1319: c*** adjust memory downward ***
1320: c
1321: 50 maxuse=max0(maxuse,ldval-memavl-ifwa)
1322: memdec=2*nxtmem(1)
1323: if (memavl.lt.memdec) return
1324: c... compress current allocations of memory
1325: call comprs(0,ldval)
1326: c... adjust memory size
1327: memdel=0
1328: 60 icore=icore-memdec
1329: memdel=memdel+memdec
1330: memavl=memavl-memdec
1331: if (memavl.ge.memdec) go to 60
1332: ltab1=ldval-ntab
1333: istack(ltab1+2)=istack(ltab1+2)-memdel
1334: c... relocate block entry table
1335: nwords=numblk*ntab
1336: cpyknt=cpyknt+dfloat(nwords)
1337: call copy4(istack(loctab+1),istack(loctab-memdel+1),nwords)
1338: loctab=loctab-memdel
1339: ldval=ldval-memdel
1340: call memory
1341: return
1342: end
1343: integer function nxtevn(n)
1344: c
1345: c.. function returns the smallest value nxtevn greater than or equal to
1346: c.. n which is evenly divisible by 'nwd4, nwd8, and nwd16' as defined
1347: c.. in setmem
1348: c
1349: nxtevn=((n+3)/4)*4
1350: return
1351: end
1352: integer function nxtmem(memwds)
1353: c
1354: c.. function returns the in nxtmem the next available memory size
1355: c.. (which must be evenly divisible by 'nwd4, nwd8, and nwd16' as
1356: c.. defined in setmem
1357: c
1358: nxtmem=((memwds+1999)/2000)*2000
1359: return
1360: end
1361: subroutine comprs(icode,limit)
1362: implicit double precision (a-h,o-z)
1363: c
1364: c this routine compresses all available memory into a single block.
1365: c if *icode* is zero, compression of memory from word 1 to *limit* is
1366: c done; otherwise, compression from *ldval* down to *limit* is done.
1367: c
1368: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1369: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1370: 2 nwd8,nwd16
1371: c
1372: c... approximate time required to copy *nwords* real values
1373: if (icode.ne.0) go to 100
1374: nblk=numblk
1375: ltab2=loctab
1376: 10 ltab1=ltab2
1377: if (ltab1.ge.limit) go to 200
1378: if (nblk.eq.1) go to 200
1379: nblk=nblk-1
1380: ltab2=ltab1+ntab
1381: morg=istack(ltab1+1)
1382: msiz=istack(ltab1+2)
1383: muse=istack(ltab1+3)
1384: muse=nxtevn(muse)
1385: if (msiz.eq.muse) go to 10
1386: c... move succeeding block down
1387: morg2=istack(ltab2+1)
1388: muse2=istack(ltab2+3)
1389: madr2=istack(ltab2+4)
1390: iwsize=istack(ltab2+5)
1391: if (madr2.ne.0) go to 15
1392: if (muse2.eq.0) go to 20
1393: 15 cpyknt=cpyknt+dfloat(muse2)
1394: call copy4(istack(nwoff+morg2+1),istack(nwoff+morg+muse+1),muse2)
1395: istack(lorg+madr2)=(morg+muse)/iwsize
1396: 20 istack(ltab1+2)=muse
1397: istack(ltab2+1)=morg+muse
1398: istack(ltab2+2)=istack(ltab2+2)+(msiz-muse)
1399: go to 10
1400: c
1401: c
1402: 100 nblk=numblk
1403: ltab2=ldval-ntab
1404: 110 ltab1=ltab2
1405: if (ltab1.le.limit) go to 200
1406: if (nblk.eq.1) go to 200
1407: nblk=nblk-1
1408: ltab2=ltab1-ntab
1409: morg=istack(ltab1+1)
1410: msiz=istack(ltab1+2)
1411: muse=istack(ltab1+3)
1412: muse=nxtevn(muse)
1413: madr=istack(ltab1+4)
1414: iwsize=istack(ltab1+5)
1415: mspc=msiz-muse
1416: if (mspc.eq.0) go to 110
1417: cpyknt=cpyknt+dfloat(muse)
1418: call copy4(istack(nwoff+morg+1),istack(nwoff+morg+mspc+1),muse)
1419: istack(ltab1+1)=morg+mspc
1420: istack(ltab1+2)=muse
1421: istack(ltab2+2)=istack(ltab2+2)+mspc
1422: if (madr.eq.0) go to 110
1423: istack(lorg+madr)=(morg+mspc)/iwsize
1424: go to 110
1425: c... all done
1426: 200 return
1427: end
1428: logical function memptr(ipntr)
1429: implicit double precision (a-h,o-z)
1430: c
1431: c this routine checks whether *ipntr* is a valid block pointer.
1432: c if it is valid, *ltab* is set to point to the corresponding entry in
1433: c the block table.
1434: c
1435: c... ipntr is an array to avoid 'call by value' problems (see setmem)
1436: dimension ipntr(1)
1437: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1438: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1439: 2 nwd8,nwd16
1440: c
1441: memptr=.false.
1442: ltab=loctab
1443: locpnt=locf(ipntr(1))
1444: do 20 i=1,numblk
1445: if (locpnt.ne.istack(ltab+4)) go to 10
1446: if (ipntr(1)*istack(ltab+5).ne.istack(ltab+1)) go to 10
1447: memptr=.true.
1448: go to 30
1449: 10 ltab=ltab+ntab
1450: 20 continue
1451: 30 return
1452: end
1453: subroutine dmpmem(ipntr)
1454: implicit double precision (a-h,o-z)
1455: c
1456: c this routine prints out the current memory allocation map.
1457: c *ipntr* is the table pointer of the current memory manager call
1458: c
1459: common /tabinf/ ielmnt,isbckt,nsbckt,iunsat,nunsat,itemps,numtem,
1460: 1 isens,nsens,ifour,nfour,ifield,icode,idelim,icolum,insize,
1461: 2 junode,lsbkpt,numbkp,iorder,jmnode,iur,iuc,ilc,ilr,numoff,isr,
1462: 3 nmoffc,iseq,iseq1,neqn,nodevs,ndiag,iswap,iequa,macins,lvnim1,
1463: 4 lx0,lvn,lynl,lyu,lyl,lx1,lx2,lx3,lx4,lx5,lx6,lx7,ld0,ld1,ltd,
1464: 5 imynl,imvn,lcvn,loutpt,nsnod,nsmat,nsval,icnod,icmat,icval
1465: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1466: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1467: 2 nwd8,nwd16
1468: c... ipntr is an array to avoid 'call by value' problems
1469: dimension ipntr(1)
1470: dimension aptr(61)
1471: data aptr /6hielmnt,6hisbckt,6hnsbckt,6hiunsat,6hnunsat,6hitemps,
1472: 1 6hnumtem,6hisens ,6hnsens ,6hifour ,6hnfour ,6hifield,
1473: 2 6hicode ,6hidelim,6hicolum,6hinsize,
1474: 3 6hjunode,6hlsbkpt,6hnumbkp,6hiorder,6hjmnode,
1475: 4 6hiur ,6hiuc ,6hilc ,6hilr ,6hnumoff,6hisr ,
1476: 5 6hnmoffc,6hiseq ,6hiseq1 ,6hneqn ,6hnodevs,
1477: 6 6hndiag ,6hiswap ,6hiequa ,6hmacins,6hlvnim1,
1478: 7 6hlx0 ,6hlvn ,6hlynl ,6hlyu ,6hlyl ,
1479: 8 6hlx1 ,6hlx2 ,6hlx3 ,6hlx4 ,6hlx5 ,6hlx6 ,
1480: 9 6hlx7 ,6hld0 ,6hld1 ,6hltd ,6himynl ,6himvn ,6hloutpt,
1481: * 6hnsnod ,6hnsmat ,6hnsval ,6hicnod ,6hicmat ,6hicval /
1482: data ablnk /1h /
1483: iaddr=locf(ielmnt)-1
1484: itemp=locf(ipntr(1))-iaddr
1485: anam=ablnk
1486: if(itemp.gt.0.and.itemp.le.61) anam=aptr(itemp)
1487: iadr=locf(ipntr(1))
1488: write (6,5) anam,iadr,icore,maxmem,memavl,ldval
1489: 5 format('0current pointer 'a6,'@ = z',z6,/' corsiz=',i7,
1490: 1 /' maxmem=',i7,/' avlspc=',i7,/' ldval=',i7,
1491: 2 /1h0,24x,'memory allocation map'/14x,'blknum memorg memsiz',
1492: 3 ' memuse usrptr addr name')
1493: ltab1=loctab
1494: do 20 i=1,numblk
1495: morg=istack(ltab1+1)
1496: msiz=istack(ltab1+2)
1497: muse=istack(ltab1+3)
1498: madr=istack(ltab1+4)
1499: anam=ablnk
1500: ndex=madr-iaddr
1501: if(ndex.gt.0.and.ndex.le.61) anam=aptr(ndex)
1502: jptr=0
1503: if (madr.gt.0) jptr=istack(lorg+madr)
1504: write (6,11) i,morg,msiz,muse,jptr,madr,anam
1505: 11 format(13x,5i7,3x,z7,'z',1x,a6)
1506: ltab1=ltab1+ntab
1507: 20 continue
1508: write (6,21)
1509: 21 format(1h0,24x,'end of allocation map'/)
1510: return
1511: end
1512: subroutine memory
1513: implicit double precision (a-h,o-z)
1514: common /memmgr/ cpyknt,istack(1),lorg,icore,maxcor,maxuse,memavl,
1515: 1 ldval,numblk,loctab,ltab,ifwa,nwoff,ntab,maxmem,memerr,nwd4,
1516: 2 nwd8,nwd16
1517: if(icore.le.maxmem) go to 10
1518: memerr=4
1519: return
1520: 10 continue
1521: return
1522: end
1523: subroutine magphs(cvar,xmag,xphs)
1524: implicit double precision (a-h,o-z)
1525: c
1526: c this routine computes the magnitude and phase of its complex arg-
1527: c ument cvar, storing the results in xmag and xphs.
1528: c
1529: common /knstnt/ twopi,xlog2,xlog10,root2,rad,boltz,charge,ctok,
1530: 1 gmin,reltol,abstol,vntol,trtol,chgtol,eps0,epssil,epsox
1531: complex*16 cvar
1532: c
1533: c
1534: xreal=dreal(cvar)
1535: ximag=dimag(cvar)
1536: xmag=dsqrt(xreal*xreal+ximag*ximag)
1537: if (xmag.ge.1.0d-20) go to 10
1538: xmag=1.0d-20
1539: xphs=0.0d0
1540: return
1541: 10 xphs=rad*datan2(ximag,xreal)
1542: return
1543: end
1544: integer function xxor(a,b)
1545: implicit double precision (a-h,o-z)
1546: c
1547: c this routine computes a single-precision integer result which is
1548: c the result of exclusive-or*ing the two real-valued arguments a and b
1549: c together.
1550: c
1551: xxor=1
1552: if(a.eq.b) xxor=0
1553: return
1554: end
1555: subroutine outnam(loc,ktype,string,ipos)
1556: implicit double precision (a-h,o-z)
1557: c
1558: c this routine constructs the 'name' for the output variable indi-
1559: c cated by loc, adding the characters to the character array 'string',
1560: c beginning with the position marked by ipos.
1561: c
1562: common /tabinf/ ielmnt,isbckt,nsbckt,iunsat,nunsat,itemps,numtem,
1563: 1 isens,nsens,ifour,nfour,ifield,icode,idelim,icolum,insize,
1564: 2 junode,lsbkpt,numbkp,iorder,jmnode,iur,iuc,ilc,ilr,numoff,isr,
1565: 3 nmoffc,iseq,iseq1,neqn,nodevs,ndiag,iswap,iequa,macins,lvnim1,
1566: 4 lx0,lvn,lynl,lyu,lyl,lx1,lx2,lx3,lx4,lx5,lx6,lx7,ld0,ld1,ltd,
1567: 5 imynl,imvn,lcvn,loutpt,nsnod,nsmat,nsval,icnod,icmat,icval
1568: common /blank/ value(50000)
1569: integer nodplc(64)
1570: complex*16 cvalue(32)
1571: equivalence (value(1),nodplc(1),cvalue(1))
1572: c
1573: dimension string(1)
1574: dimension aout(19),lenout(19),aopt(5),lenopt(5)
1575: data aout / 6hv , 6hvm , 6hvr , 6hvi , 6hvp ,
1576: 1 6hvdb , 6hi , 6him , 6hir , 6hii ,
1577: 2 6hip , 6hidb , 6honoise, 6hinoise, 6hhd2 ,
1578: 1 6hhd3 , 6hdim2 , 6hsim2 , 6hdim3 /
1579: data lenout / 1,2,2,2,2,3,1,2,2,2,2,3,6,6,3,3,4,4,4 /
1580: data aopt / 5hmag , 5hreal , 5himag , 5hphase, 5hdb /
1581: data lenopt / 3,4,4,5,2 /
1582: data alprn, acomma, arprn, ablnk / 1h(, 1h,, 1h), 1h /
1583: c
1584: c
1585: ioutyp=nodplc(loc+5)
1586: if (ioutyp.ge.2) go to 10
1587: lout=ktype+ioutyp*6
1588: go to 20
1589: 10 lout=ioutyp+11
1590: 20 call move(string,ipos,aout(lout),1,lenout(lout))
1591: ipos=ipos+lenout(lout)
1592: if (ioutyp.ge.2) go to 200
1593: call move(string,ipos,alprn,1,1)
1594: ipos=ipos+1
1595: if (ioutyp.ne.0) go to 100
1596: node1=nodplc(loc+2)
1597: call alfnum(nodplc(junode+node1),string,ipos)
1598: node2=nodplc(loc+3)
1599: if (node2.eq.1) go to 30
1600: call move(string,ipos,acomma,1,1)
1601: ipos=ipos+1
1602: call alfnum(nodplc(junode+node2),string,ipos)
1603: 30 call move(string,ipos,arprn,1,1)
1604: ipos=ipos+1
1605: go to 1000
1606: c
1607: 100 locv=nodplc(loc+1)
1608: anam=value(locv)
1609: achar=ablnk
1610: do 110 i=1,8
1611: call move(achar,1,anam,i,1)
1612: if (achar.eq.ablnk) go to 120
1613: call move(string,ipos,achar,1,1)
1614: ipos=ipos+1
1615: 110 continue
1616: 120 call move(string,ipos,arprn,1,1)
1617: ipos=ipos+1
1618: go to 1000
1619: c
1620: 200 if (ktype.eq.1) go to 1000
1621: call move(string,ipos,alprn,1,1)
1622: ipos=ipos+1
1623: call move(string,ipos,aopt(ktype-1),1,lenopt(ktype-1))
1624: ipos=ipos+lenopt(ktype-1)
1625: call move(string,ipos,arprn,1,1)
1626: ipos=ipos+1
1627: c
1628: c finished
1629: c
1630: 1000 return
1631: end
1632: subroutine alfnum(number,string,ipos)
1633: implicit double precision (a-h,o-z)
1634: c
1635: c this routine converts number into character form, storing the
1636: c characters in the character array string, beginning with the position
1637: c indicated by ipos.
1638: c
1639: c **** note that the 'ipos' variable is changed to indicate the position
1640: c of the next unwritten character. this could clobber constants if
1641: c ipos is not a variable in the calling program
1642: c
1643: dimension string(1)
1644: dimension adigit(10)
1645: data adigit / 1h0,1h1,1h2,1h3,1h4,1h5,1h6,1h7,1h8,1h9 /
1646: data aminus / 1h- /
1647: c
1648: c
1649: num=number
1650: c
1651: c check for number < 0
1652: c
1653: if (num.ge.0) go to 10
1654: num=-num
1655: c... negative number: insert minus sign
1656: call move(string,ipos,aminus,1,1)
1657: ipos=ipos+1
1658: c
1659: c convert number one digit at a time, in reverse order
1660: c
1661: 10 istart=ipos
1662: 20 numtmp=num/10
1663: idigit=num-numtmp*10
1664: call move(string,ipos,adigit(idigit+1),1,1)
1665: ipos=ipos+1
1666: num=numtmp
1667: if (num.ne.0) go to 20
1668: istop=ipos-1
1669: c
1670: c now reverse the order of the digits
1671: c
1672: 30 if (istop.le.istart) go to 40
1673: call move(tmpdgt,1,string,istart,1)
1674: call move(string,istart,string,istop,1)
1675: call move(string,istop,tmpdgt,1,1)
1676: istart=istart+1
1677: istop=istop-1
1678: go to 30
1679: c
1680: c conversion complete
1681: c
1682: 40 return
1683: end
1684: subroutine getcje
1685: implicit double precision (a-h,o-z)
1686: common /cje/ maxtim,itime,icost
1687: call second(xtime)
1688: itime=xtime
1689: icost=xtime*38.3333
1690: return
1691: end
1692: subroutine move(a,iposa,b,iposb,nchar)
1693: character a(1),b(1)
1694: do 10 i=1,nchar
1695: a(iposa+i-1)=b(iposb+i-1)
1696: 10 continue
1697: return
1698: end
1699: subroutine copy4(ifrom,ito,nwords)
1700: implicit double precision (a-h,o-z)
1701: c
1702: dimension ifrom(1),ito(1)
1703: c this routine copies a block of #nwords# words (of the appropriate
1704: c type) from the array #from# to the array #to#. it determines from
1705: c which end of the block to transfer first, to prevent over-stores which
1706: c might over-write the data.
1707: c
1708: if (nwords.eq.0) return
1709: if (locf(ifrom(1)).lt.locf(ito(1))) go to 20
1710: c... locf() returns as its value the address of its argument
1711: do 10 i=1,nwords
1712: ito(i)=ifrom(i)
1713: 10 continue
1714: return
1715: c
1716: 20 i=nwords
1717: 30 ito(i)=ifrom(i)
1718: i=i-1
1719: if (i.ne.0) go to 30
1720: return
1721: c
1722: c
1723: end
1724: subroutine copy8(rfrom,rto,nwords)
1725: implicit double precision (a-h,o-z)
1726: c
1727: dimension rfrom(1),rto(1)
1728: if (nwords.eq.0) return
1729: if (locf(rfrom(1)).lt.locf(rto(1))) go to 120
1730: do 110 i=1,nwords
1731: rto(i)=rfrom(i)
1732: 110 continue
1733: return
1734: c
1735: 120 i=nwords
1736: 130 rto(i)=rfrom(i)
1737: i=i-1
1738: if (i.ne.0) go to 130
1739: return
1740: c
1741: c
1742: end
1743: subroutine copy16(cfrom,cto,nwords)
1744: implicit double precision (a-h,o-z)
1745: c
1746: complex*16 cfrom(1),cto(1)
1747: if (nwords.eq.0) return
1748: if (locf(cfrom(1)).lt.locf(cto(1))) go to 220
1749: do 210 i=1,nwords
1750: cto(i)=cfrom(i)
1751: 210 continue
1752: return
1753: c
1754: 220 i=nwords
1755: 230 cto(i)=cfrom(i)
1756: i=i-1
1757: if (i.ne.0) go to 230
1758: return
1759: end
1760: subroutine zero4(iarray,length)
1761: implicit double precision (a-h,o-z)
1762: c
1763: dimension iarray(1)
1764: c this routine zeroes the memory locations indicated by array(1)
1765: c through array(length).
1766: c
1767: if (length.eq.0) return
1768: do 10 i=1,length
1769: iarray(i)=0
1770: 10 continue
1771: return
1772: end
1773: subroutine zero8(array,length)
1774: implicit double precision (a-h,o-z)
1775: c
1776: dimension array(1)
1777: c this routine zeroes the memory locations indicated by array(1)
1778: c through array(length).
1779: c
1780: if (length.eq.0) return
1781: do 10 i=1,length
1782: array(i)=0.0d0
1783: 10 continue
1784: return
1785: end
1786: subroutine zero16(carray,length)
1787: implicit double precision (a-h,o-z)
1788: complex*16 carray(1)
1789: c
1790: c this routine zeroes the memory locations indicated by array(1)
1791: c through array(length).
1792: c
1793: if (length.eq.0) return
1794: do 10 i=1,length
1795: carray(i)=dcmplx(0.0d0,0.0d0)
1796: 10 continue
1797: return
1798: c
1799: c
1800: c
1801: end
1802: integer function locf(ivar)
1803: iabsa=loc(ivar)
1804: locf=iabsa/4
1805: if(iabsa.eq.locf*4) return
1806: write(6,100) iabsa
1807: 100 format('0*error*: system 370 error..address ',t10,
1808: 1 ' is not on a 4-byte boundary')
1809: stop
1810: end
1811: subroutine mdate(anam)
1812: implicit double precision (a-h,o-z)
1813: call date(anam)
1814: return
1815: end
1816: subroutine mclock(anam)
1817: implicit double precision (a-h,o-z)
1818: call todalf(anam)
1819: 100 return
1820: end
1821: subroutine second(t1)
1822: implicit double precision (a-h,o-z)
1823: dimension ibuff(4)
1824: real*8 t1
1825: call times (ibuff)
1826: t1 = dfloat (ibuff(1)) / 60.d0
1827: return
1828: end
1829: subroutine todalf(anam)
1830: double precision anam
1831: anam=0.0d0
1832: return
1833: end
1834: double precision function cpusec(time)
1835: cpusec=0.0d0
1836: return
1837: end
1838: subroutine date(anam)
1839: double precision anam
1840: anam=1.0d0
1841: return
1842: end
1843: FUNCTION DREAL ( X )
1844: COMPLEX*16 X
1845: DREAL = REAL (X)
1846: RETURN
1847: END
1848: cunix FUNCTION DIMAG ( X )
1849: cunix COMPLEX*16 X
1850: cunix DIMAG = AIMAG (X)
1851: cunix RETURN
1852: cunix END
1853: cunix COMPLEX FUNCTION DCMPLX ( X , Y )
1854: cunix DCMPLX = CMPLX ( X , Y )
1855: cunix RETURN
1856: cunix END
1857: cunix COMPLEX FUNCTION DCONJG ( X )
1858: cunix COMPLEX*16 X
1859: cunix DCONJG = CONJG ( X )
1860: cunix RETURN
1861: cunix END
1862: FUNCTION IFIXD ( X )
1863: IFIXD = IFIX ( X )
1864: RETURN
1865: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.