C#======================================================================-------- subroutine juexpr(inline,outlin,mssg,slast,ierr) C @(#) The procedure juexpr acts like a calculator C C The goal is to create a procedure easily utilized from other C programs that takes a standard FORTRAN value statement and reduces C it down to a value, efficiently and using ANSI 77 FORTRAN C standards where ever feasible. C C Note that a block data called juinit is used which, on NOS, C requires a ldset,usep=juinit. when it is loaded from a library. C C Version 2.0: 03/13/87 C C o adjacent powers are done left to right, not right to left C o code does not prevent - and + beside another operator. C o no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C o allowing for ixy arguments in max and min seems too high. if reducing C array size helps significantly in costs, do so. C o no check on whether user input more characters than allowed. C o parentheses are required on a function call. C o square brackets [] are equivalent to parenthesis (). C=========================================================================== C NEXT: C 2. generic help function to list commands and functions C 3. allow multiple expressions per line with a semi-colon between them C (like the parse functions). C 4. make a function to fill x and y arrays, or to read values into them C from a file; and make some statistical functions that work on the C arrays. C 5. reduce use of commons to a minimum. is common zzrays necessary? C 6. allow user-written functions to be called from jufuns routine. C 7. allow for user-defined arrays and array operations. C 8. arbitrary precision C=========================================================================== C 12/07/87 --- put in an implicit real (a-h,o-z) statement in each C procedure so that it could quickly be changed to C implicit real*8 (a-h,o-z) for a vax. be careful of C type mismatch between external functions and the C real variables. C use following xedit commands where periods denote C spaces C c/implicit real../implicit real*8./ * C 12/11/87 --- changed ifix calls to int calls as ifix on vax does C not allow real*8 in ifix calls C 12/11/87 --- moving all prints out of column 1 so it is not picked C out by vax as carriage control. C 12/28/87 --- put bn format specifier into juator routine because C vax assumes zero fill C 06/23/88 --- making a first cut at allowing string variables. C 1. string variable names must start with a dollar-sign C 2. strings can only be up to (iclen) characters long C 3. they will be returned in the message string to C the calling program C 4. input strings must be delimited with double quotes. C to place a double quote into the string, put two C double quotes adjacent to each other. C 5. a flag value for ier to distinguish between string C and numeric output? C#======================================================================-------- implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC character*(icbuf) line,inline*(*) character last*(iclen) character outlin*(icname) character mssg*(iclen) character varnam*(iclen) , values(ic)*(iclen) character ix(ic)*(icname), ix2(ic)*(icname) dimension value(ic), valuer(ic) external juinit ! explicitly mention the block data or UNICOS segldr will not load it from a library 19960520 common/zzlast/last common/uvalue/ value common/uindex/ix common/uindx2/ix2 common/ustrng/values common /ustrln/valuer ! the lengths of the string variable values save /zzlast/,rlast,/uvalue/,/uindex/,/ustrng/,/uindx2/,/ustrln/ data rlast/0.0/ C======================================================================= line=inline ! set working string to initial input line imax=len(inline) ! determine the length of the input line 1 continue ! for $A=numeric and A=string ierr=1 ! set status flag to message mode mssg=' ' ! set returned message/error/string value string to a blank mssge=' ' ! set message/error/string value in common to a blank call jusqes(line,imax,nchard,varnam,nchar2,ierr) ! preprocess the string: remove blanks and process special characters C also remove all quoted strings and replace them with a token if(ierr.eq.-1)then !if an error occurred during preprocessing of the string, set returned message and quit slast=rlast !set returned real value to last good calculated value mssg=mssge !place internal message from common into message returned to user return elseif(nchard.eq.0)then ! if a blank input string was entered report it as an error and quit ierr=-1 mssg='*juexpr* input line was empty' elseif(line(1:nchard).eq.'dump')then ! process dump command print*,line(1:nchard) print*,'current value= ',last print*,' variable name variable value ' do 10 i10=1,ic if(ix(i10).ne.' ') $ write(*,'('' '',2a,g20.13e3)')ix(i10),' ',value(i10) 10 continue do 20 i20=1,ic i20x=max(1,int(valuer(i20))) if(ix2(i20).ne.' ') $ write(*,'('' '',3a)')ix2(i20),' ',values(i20)(:i20x) 20 continue mssg='*juexpr* variable listing complete' elseif(line(1:nchard).eq.'funcs') then ! process funcs command call jufind('funcs',idum1,0,idum3) mssg='*juexpr* see calculator document for details' else ! this is an input line to process call jupars(line,nchard,ierr) ! process the command if(ierr.eq.0)then ! if no errors occurred set output string, store the value as last, store any variable ! numeric value with no errors, assume nchard is 20 or less outlin=line(1:nchard) ! set string output value last=line(1:nchard) ! store last value (for use with question-mark token) call juator(last(1:nchard),rlast,idum) ! set real number output value if(nchar2.ne.0.and.varnam(1:1).ne.'$')then ! if the statement defines a variable make sure the variable name is stored call jubous(varnam,index,ix,ierr) ! determine storage placement of the variable and whether it is new if(ierr.eq.-1)then slast=rlast !set returned real value to last good calculated value mssg=mssge !place internal message from common into message returned to user return endif if(index.le.0)then ! if the variable needs added, add it call juaddr(varnam,nchar2,index,ierr) ! adding the new variable name to the variable name array if(ierr.eq.-1)then slast=rlast !set returned real value to last good calculated value mssg=mssge !place internal message from common into message returned to user return !report error endif endif call juator(last(1:nchard),value(iabs(index)),ierr)! store a defined variable's value elseif(nchar2.ne.0)then ! numeric value to string line(:)=' ' line=varnam(1:nchar2)//'="'//last(1:nchard)//'"' imax=julen(line) ! determine the length of the input line goto 1 endif elseif(ierr.eq.2)then ! returned output is not numeric, but alphanumeric (it is a string) C!!!!!! could return string values directly instead of thru message field C!!!!!! make sure normal output values are not left indeterminate mssg=mssge ! set returned string value to returned string value if(nchar2.ne.0.and.varnam(1:1).eq.'$')then ! if the statement defines a variable make sure the variable name is stored call jubous(varnam,index,ix2,ierr) ! determine storage placement of the variable and whether it is new if(ierr.eq.-1)then slast=rlast !set returned real value to last good calculated value mssg=mssge !place internal message from common into message returned to user return endif if(index.le.0)then ! if the variable needs added, add it call juadds(varnam,nchar2,index,ierr) ! adding the new variable name to the variable name array if(ierr.eq.-1)then slast=rlast !set returned real value to last good calculated value mssg=mssge !place internal message from common into message returned to user return endif endif values(iabs(index))=mssg valuer(iabs(index))=julen(mssg) rlast=valuer(iabs(index)) ! returned value is length of string when string is returned elseif(nchar2.ne.0)then ! string but being stored to numeric variable line=varnam(1:nchar2)//'='//mssg imax=julen(line) ! determine the length of the input line goto 1 else ! a string function with an assignment to it (for example "Hello" rlast=julen(mssg) ! probably should pass message length up from someplace endif endif mssg=mssge endif slast=rlast ! set returned value to last successfully calculated real value return end C#======================================================================-------- subroutine jupars(string,nchar,ier) C crack out the parenthesis and solve C sets and returns ier C 0=good numeric return C 2=good alphameric return C -1=error occurred, message is in /zzmssg/mssge implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC character*(icbuf) wstrng,dummy,string*(*) imax=nchar ier=0 1 continue do 2 i=imax,1,-1 ! find rightmost left paren ileft=i if(string(i:i).eq.'(') go to 3 2 continue if(index(string(:nchar),')').ne.0) then ! if here there are no left paren. check for an (unmatched) right paren ier=-1 mssge='*jupars* extraneous right parenthesis found' return else C no parenthesis left, reduce possible expression to a single value primitive and quit C a potential problem is that a blank string or () would end up here too. call jucals(string,nchar,rdum,ier) return endif 3 continue iright=index(string(ileft:nchar),')') ! find matching right paren if(iright.eq.0) then ier=-1 mssge='*jupars* right parenthesis missing' return endif iright=iright+ileft-1 !there was a matched set of paren remaining in the string iz=1 ! check now to see if this is a function call. search for an operator C if ileft is 1, then last set of parenthesis,(and for an expression) if(ileft.ne.1)then do 10 i=ileft-1,1,-1 iz=i if(index('#=*/(,',string(i:i)).ne.0)then iz=iz+1 go to 11 endif 10 continue C if here, a function call begins the string, as iz=1 but ileft doesn't endif C======================================================================= C iz=position beginning current primitive's string C ileft=position of opening parenthesis for this primitive C iright=position of end and right parenthesis for this string 11 continue if(iz.eq.ileft)then ! if ileft eq iz then a parenthesized expression, not a function call wstrng=string(ileft+1:iright-1) iwnchr=iright-1-(ileft+1)+1 call jucals(wstrng,iwnchr,rdum,ier) else wstrng=string(iz:iright) iwnchr=iright-iz+1 call jufuns(wstrng,iwnchr,ier) endif if(ier.eq.-1)return ! if an error occurred in jucals or jufuns, then return C restring the evaluated primitive back into the main string C remember that if an expression, iz=ileft C last set of -matched- parentheses, and entire string was evaluated if(iz.eq.1.and.iright.eq.nchar)then dummy=wstrng(:iwnchr) nchar=iwnchr C last set of -matched- parentheses, but other characters still to right elseif(iz.eq.1)then dummy=wstrng(:iwnchr)//string(iright+1:nchar) nchar=iwnchr+nchar-iright elseif(iright.eq.nchar)then C last expression evaluated was at end of string dummy=string(:iz-1)//wstrng(:iwnchr) nchar=iz-1+iwnchr else C last expression evaluated was in middle of string dummy=string(:iz-1)//wstrng(:iwnchr)//string(iright+1:nchar) nchar=iz-1+iwnchr+nchar-iright endif C set last place to look for a left parenthesis to one to the left C of the beginning of the primitive just reduced, or to a 1 so that C the loop looking for the left parenthesis doesn't look for a C parenthesis at position 0:0 imax=max(iz-1,1) string=dummy go to 1 end C#======================================================================-------- subroutine jufuns(wstrng,nchars,ier) C given a string of structure "name(p1,p2,p3,p4,p5)" where p(i) are C non-parenthesisized expressions, reduce the p(i) to real values if C numeric and call the procedure "name" with those values passed C as the parameters. implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC real r4 intrinsic acos,asin,atan,cos,cosh,sin,sinh,tan,tanh intrinsic abs,aint,anint,exp,nint,int,log,log10 intrinsic real,sqrt,atan2,dim,mod,sign,max,min external round external lowers character lowers*(iclen), wstrng2*(icname) dimension valuer(ic) character values(ic)*(iclen),ctmp*(iclen) character*(*) wstrng,cnum*(icname) parameter (iargs=100) dimension args(iargs),iargstp(iargs),x(ixy),y(ixy) character*(iclen) xc(ixyc), yc(ixyc), nc(ixyc) external ceil, floor real ceil, floor Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc logical ownon common/zzrays/x,y common/zzrayc/xc,yc,nc common/zzown1/ownon common/ustrng/values ! values contains the values of string variables common/ustrln/valuer ! the lengths of the string variable values save /zzrays/,/zzown1/,/ustrng/,/ustrln/,/zzrayc/ Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ctof(t)=(t+40.)*9./5. - 40. ftoc(t)=(t+40.)*5./9. - 40. Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C non-ANSI: C x(i) ---- the x-array values C y(i) ---- the y-array values C xstore(start,value1,value2,value3,....valuen) C ystore(start,value1,value2,value3,....valuen) C $x(i) ---- the $x-array values C $y(i) ---- the $y-array values C $xstore(start,value1,value2,value3,....valuen) C $ystore(start,value1,value2,value3,....valuen) C d2r - degrees to radians C r2d - radians to degrees C floor C ceil C $str(), str() Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc TRUE=0 FALSE=1 ier=0 iright=nchars-1 ileft=index(wstrng(1:nchars),'(')+1 iend=ileft-2 iflen=iright-ileft+1 C n=number of parameters found if(iright-ileft.lt.0)then ! if call such as fx() expression string is null n=0 else call juargs(wstrng(ileft:iright),iflen,args,iargstp,n,ier,100) ! take string of expressions separated by commas and place C their values into an array and return how many values were found endif if(ier.eq.-1)return C!!!!!!!!! jufind should determine if correct number of parameters has been used wstrng2=' ' wstrng2(:iend)=lowers(wstrng(:iend)) call jufind(wstrng2(:iend),i,n,ier) fval=0.0 if(ier.eq.-1)return if(i.gt.0.and.i.lt.35)then goto (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) i elseif(i.gt.0.and.i.lt.101)then goto (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) i-34 endif C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= mssge='*jufuns* function not found: '//wstrng(:iend) ier=-1 ! ya done blown it if you get here return C====================================================================== C should never get here C======================================================================= 1 continue fval= acos(args(1)) go to 5000 2 continue fval= asin(args(1)) go to 5000 3 continue fval= atan(args(1)) go to 5000 4 continue fval= cos(args(1)) go to 5000 5 continue fval= cosh(args(1)) go to 5000 6 continue fval= sin(args(1)) go to 5000 7 continue fval= sinh(args(1)) go to 5000 8 continue fval= tan(args(1)) go to 5000 9 continue fval= tanh(args(1)) go to 5000 10 continue fval= abs(args(1)) go to 5000 11 continue fval= aint(args(1)) go to 5000 12 continue fval= anint(args(1)) go to 5000 C======================================================================= 13 continue ivalue=int(args(1)+0.5) if(ivalue.lt.1.or.ivalue.gt.ixy)then ! if value not at least 1, or if not less than ixy, report it mssge='*jufuns* illegal subscript value for x array' ier=-1 return endif fval= x(ivalue) go to 5000 C======================================================================= 14 continue fval= exp(args(1)) ! exp go to 5000 C======================================================================= 15 continue fval=floor(real(args(1))) ! the floor function go to 5000 C======================================================================= 16 continue fval= args(1)-int(args(1)) ! next is the frac function go to 5000 C======================================================================= 17 continue fval= args(1) ! specify whether look for juown1 routine if(args(1).gt.0)then ownon=.true. else ownon=.false. endif go to 5000 C======================================================================= 18 continue fval= nint(args(1)) ! nint go to 5000 C======================================================================= 19 continue fval= int(args(1)) ! int go to 5000 C======================================================================= 20 continue if(args(1).gt.0.0)then fval= log(args(1)) else r4=args(1) !args(1) maybe real*8 and r4 real*4 call junr(4,'*jufuns* ERROR: cannot take log of ',r4) fval=0.0 endif go to 5000 C======================================================================= 21 continue if(args(1).gt.0.0)then fval= log(args(1)) else r4=args(1) !args(1) maybe real*8 and r4 real*4 call junr(4,'*jufuns* ERROR: cannot take log10 of ',r4) fval=0.0 endif go to 5000 C======================================================================= 22 continue fval= real(args(1)) go to 5000 C======================================================================= 23 continue fval= sqrt(args(1)) go to 5000 C======================================================================= 24 continue fval= args(1)*180.d0/acos(-1.0d0) !r2d go to 5000 C======================================================================= 25 continue fval=args(1)*acos(-1.0d0)/180.d0 go to 5000 C======================================================================= 26 continue ivalue=int(args(1)+0.5) !y C if value not at least 1, make it 1. if not less than ixy, make it ixy if(ivalue.lt.1.or.ivalue.gt.ixy)then mssge='*jufuns* illegal subscript value for y array' ier=-1 return endif fval= y(ivalue) go to 5000 C======================================================================= C functions with more than one parameter C C======================================================================= 27 continue fval=atan2(args(1),args(2)) !atan2 go to 5000 C======================================================================= 28 continue fval=dim(args(1),args(2)) !dim go to 5000 C======================================================================= 29 continue fval=mod(args(1),args(2)) !mod go to 5000 C======================================================================= 30 continue fval=sign(args(1),args(2)) !sign go to 5000 C======================================================================= 31 continue if(n.lt.1)goto 5009 fval=args(1) !max do 1901 i=2,n fval=max(fval,args(i)) 1901 continue go to 5000 C======================================================================= 32 continue if(n.lt.1)goto 5009 fval=args(1) !min do 1902 i=2,n fval=min(fval,args(i)) 1902 continue go to 5000 C======================================================================= 33 continue if(n.lt.2)goto 5009 ivalue=int(args(1)+0.5) !xstore C xstore function===>store x(where_to_start,value1,value2,value3...) C ignore -entire- function call if a bad subscript reference was made if(ivalue.lt.1.or.ivalue+n-2.gt.ixy)then mssge='*jufuns* illegal subscript value for x array in xstore(' ier=-1 return endif do 10331 i1033=ivalue,ivalue+n-2,1 isub=i1033-ivalue+2 x(i1033)=args(isub) 10331 continue C last value stored will become current value fval=args(isub) go to 5000 C======================================================================= 34 continue if(n.lt.2)goto 5009 ivalue=int(args(1)+0.5) !ystore C ystore function===>store y(where_to_start,value1,value2,value3...) C ignore -entire- function call if a bad subscript reference was made if(ivalue.lt.1.or.ivalue+n-2.gt.ixy)then mssge='*jufuns* illegal subscript value for y array in ystore(' ier=-1 return endif do 10341 i1034=ivalue,ivalue+n-2,1 isub=i1034-ivalue+2 y(i1034)=args(isub) 10341 continue C last value stored will become current value fval=args(isub) goto 5000 C======================================================================= 35 continue fval=ceil(real(args(1))) goto 5000 C======================================================================= 36 continue !c(curve_number) or c(curve_number,index) fval=-1 goto 5000 C======================================================================= 37 continue ! append numbers and strings into a new string 83 continue ! same as $str except return number IF string is a simple numeric value iend=0 ctmp=' ' do 1010 i1010=1,n istart=iend+1 if(iargstp(i1010).eq.2)then ! this parameter was a string in=args(i1010) ! the value of a string argument is the subscript for where the string is iend=istart+valuer(in)-1 ctmp(istart:iend)=values(in)(:int(valuer(in))) elseif(iargstp(i1010).eq.0)then ! this parameter was a number if(args(i1010).ne.0)then call jurtoa(args(i1010),cnum,ilen,ier) if(ier.eq.-1)return ilen=max(ilen,1) iend=istart+ilen-1 if(cnum(ilen:ilen).eq.'.')iend=iend-1 ! this number ends in a decimal iend=max(iend,istart) if(iend.gt.len(ctmp))then call jun(4,'*jufuncs* $str output string truncated') iend=len(ctmp) endif ctmp(istart:iend)=cnum(:ilen) else ctmp(istart:istart)='0' iend=iend+1 endif else mssge='*jufuns* parameter to function $str not interpretable' ier=-1 return endif 1010 continue if(i.eq.37)then goto 5002 ! $str function else ier=0 call juator(ctmp,fval,ier) ! str function goto 5000 endif mssge='*jufuns* internal error: should not get here' ier=-1 return C======================================================================= 38 continue !round fval=-1 goto 5000 C======================================================================= C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 39 continue !lle 40 continue !llt 41 continue !leq if any string matches the first string 42 continue !lge 43 continue !lgt 44 continue !lne if all strings do not match the first if(iargstp(1).eq.2.and.iargstp(2).eq.2)then do 2020 i2020=1,n if(args(i2020).le.0.or.args(i2020).gt.ic)then ier=-1 mssge='unacceptable locations for strings encountered' return endif 2020 continue fval=FALSE ! assume false unless proven true i1=args(1) i2=args(2) ier=0 else ier=-1 mssge='lexical functions must have character parameters' return endif goto(390,400,410,420,430,440)i-38 ier=-1 mssge='internal error in jufuns in lexical functions' return 390 if(values(i1).le.values(i2))fval=TRUE goto 5000 400 if(values(i1).lt.values(i2))fval=TRUE goto 5000 410 continue ! if any string matches the first do 4101 i410=2,n if(iargstp(i410).ne.2)then ! all parameters should be a string ier=-1 mssge='non-string value encountered' return elseif(values(i1).eq.values(int(args(i410)+.5)))then fval=TRUE goto 5000 endif 4101 continue goto 5000 420 if(values(i1).ge.values(i2))fval=TRUE goto 5000 430 if(values(i1).gt.values(i2))fval=TRUE goto 5000 440 continue do 4401 i440=2,n fval=TRUE if(iargstp(i440).ne.2)then ! all parameters should be a string ier=-1 mssge='non-string value encountered' return elseif(values(i1).eq.values(int(args(i440)+0.5)))then fval=FALSE goto 5000 endif 4401 continue goto 5000 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 45 continue ! ichar fval=ichar(values(int(args(1)))(1:1)) ier=0 goto 5000 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 46 continue !$char if(n.eq.0)then ier=-1 mssge='*char* must have at least one parameter' endif iend=0 do 3030 i3030=1,n ! unlike FORTRAN, can take multiple characters and mix strings and numbers ii=int(args(i3030)) if(iargstp(i3030).eq.2)then ! if parameter was a string leave it alone iend2=iend+int(valuer(ii)) ctmp(iend+1:iend2)=values(ii) iend=iend2 else ! convert numeric ADE to a character iend=iend+1 ctmp(iend:iend)=char(ii) endif 3030 continue goto 5002 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 47 continue ! le 48 continue ! lt 49 continue ! eq 50 continue ! ge 51 continue ! gt 52 continue ! ne fval=FALSE if(n.eq.2.or.n.eq.3)then if(n.eq.3)then idig=int(args(3)) if(idig.le.0.or.idig.gt.13)then mssge='*logical* precision must be between 1 and 13' ier=-1 goto 5000 endif write(*,*)'args=',args(1),args(2),args(3),idig arg1=round(args(1),idig) arg2=round(args(2),idig) write(*,*)'b. args=',args(1),args(2),args(3),idig,arg1,arg2 else arg1=args(1) arg2=args(2) endif call stuff('LOGICAL1',real(arg1),0) call stuff('LOGICAL2',real(arg2),0) call stuff('STATUS',real(arg2-arg1),0) goto(470,480,490,500,510,520)i-46 ier=-1 mssge='*logical* internal error in jufuns' goto 5000 470 continue if(arg1.le.arg2)fval=TRUE goto 5000 480 continue if(arg1.lt.arg2)fval=TRUE goto 5000 490 continue if(arg1.eq.arg2)fval=TRUE goto 5000 500 continue if(arg1.ge.arg2)fval=TRUE goto 5000 510 continue if(arg1.gt.arg2)fval=TRUE goto 5000 520 continue if(arg1.ne.arg2)fval=TRUE goto 5000 endif ier=-1 mssge='*logical* must have 2 or 3 parameters' goto 5000 Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 53 continue ! if if(args(1).eq. TRUE)then fval=args(2) else fval=args(3) endif goto 5000 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 54 continue !c2f fval=ctof(args(1)) goto 5000 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 55 continue !f2c fval=ftoc(args(1)) goto 5000 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 56 continue !in(a,b,c) ! is b in the range a to c inclusive fval=FALSE if(args(2).ge.args(1).and.args(2).le.args(3))fval=TRUE goto 5000 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 57 continue !$substr(string,start,end) if(n.eq.0)then ctmp=' ' else ii=int(args(1)) istart=1 iend1=int(valuer(ii)) ! maximum end is at end of string ctmp=' ' if(iargstp(1).eq.2)then if(n.gt.1)istart=min(max(1,int(args(2))),iend1) if(n.gt.2)iend1=max(min(int(args(3)),iend1),1) iend=iend1-istart+1 ctmp(:iend)=values(ii)(istart:iend1) endif endif goto 5002 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 58 continue ! unused fval=(-1) ier=-1 goto 5000 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 59 continue !index ii=int(args(1)) iii=int(args(2)) if(iargstp(1).eq.2.and.iargstp(2).eq.2)then ! if parameter was a string leave it alone iend1=int(valuer(ii)) iend2=int(valuer(iii)) fval=index(values(ii)(:iend1),values(iii)(:iend2)) endif ier=0 ! flag that returning a number, not a string goto 5000 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 60 continue if(n.lt.2)goto 5009 ivalue=int(args(1)+0.5) !$xstore C $xstore function===>store $x(where_to_start,value1,value2,value3...) C ignore -entire- function call if a bad subscript reference was made if(ivalue.lt.1.or.ivalue+n-2.gt.ixyc)then mssge='illegal subscript value for $x array in $xstore(' ier=-1 return endif do 10601 i1060=ivalue,ivalue+n-2,1 isub=i1060-ivalue+2 xc(i1060)=values(int(args(isub))) 10601 continue ctmp=values(isub) iend=julen(ctmp) ! very inefficient goto 5002 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 61 continue if(n.lt.2)goto 5009 ivalue=int(args(1)+0.5) !$ystore C $ystore function===>store $y(where_to_start,value1,value2,value3...) C ignore -entire- function call if a bad subscript reference was made if(ivalue.lt.1.or.ivalue+n-2.gt.ixyc)then mssge='illegal subscript value for y array in $ystore(' ier=-1 return endif do 10611 i1061=ivalue,ivalue+n-2,1 isub=i1061-ivalue+2 yc(i1061)=values(int(args(isub))) 10611 continue C last value stored will become current value ctmp=values(isub) iend=julen(ctmp) ! very inefficient goto 5002 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 62 continue ivalue=int(args(1)+0.5) if(ivalue.lt.1.or.ivalue.gt.ixyc)then ! if value not at least 1, or if not less than ixyc, report it mssge='illegal subscript value for $x array' ier=-1 return endif ctmp= xc(ivalue) iend=julen(ctmp) ! very inefficient goto 5002 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 63 continue ivalue=int(args(1)+0.5) if(ivalue.lt.1.or.ivalue.gt.ixyc)then ! if value not at least 1, or if not less than ixyc, report it mssge='illegal subscript value for $y array' ier=-1 return endif ctmp= yc(ivalue) iend=julen(ctmp) ! very inefficient goto 5002 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 64 continue ii=int(args(1)) iend1=int(valuer(ii)) fval=julen(values(ii)(:iend1)) ier=0 ! flag that returning a number, not a string goto 5000 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 65 continue ! $if function C check that 2nd and 3rd are acceptable string variables, should do generically at name lookup time if(args(1).eq. TRUE)then ii=args(2) else ii=args(3) endif ctmp=values(ii) iend=valuer(ii) goto 5002 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 66 continue 67 continue 68 continue 69 continue 70 continue 71 continue 72 continue 73 continue 74 continue 75 continue 76 continue 77 continue 78 continue 79 continue 80 continue 81 continue 82 continue 84 continue 85 continue 86 continue 87 continue 88 continue 89 continue 90 continue 91 continue fval=-1 ier=-1 mssge='unused function name' goto 5000 C ctmp=' ' C iend=1 C goto 5002 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 92 continue ! $f(format,value) Using single format specifier, return string if(n.eq.0)then ctmp=' ' else ctmp=' ' if(iargstp(1).eq.2)then ! if first field is a string ii=int(args(1)) ! get index into values() array iend1=int(valuer(ii)) ! maximum end is at end of string if(n.gt.1)fval=args(2) ! get the real value write(ctmp,'('// values(ii)(:iend1)//')',err=922)fval endif endif iend=julen(ctmp) goto 5002 922 ctmp='*' iend=1 goto 5002 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 93 continue 94 continue 95 continue 96 continue 97 continue 98 continue 99 continue 100 continue fval=0.0 ier=-1 goto 5000 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 5000 continue ! return a numeric string call jurtoa(fval,wstrng,nchars,idum) return C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 5002 continue ! return an alpha string call stufftok(fval,wstrng,nchars,ctmp(:iend),iend,ier) ! add a new token variable and assign string to it return C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= C process functions with variable number of parameters called with C an incorrect number of parameters 5009 continue ier=-1 mssge='incorrect number of parameters for '//wstrng(:iend) return end C#======================================================================-------- subroutine stufftok(fval,wstrng,nchars,string,iend,ier) C add a new token variable and assign string to it implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC character toknam*5, string*(*), wstrng*(*) common/ztoken/ktoken ! count of number of token strings assembled save /ztoken/ ktoken=ktoken+1 ! increment the counter of strings found to get a place to store into nchars=5 write(toknam,'(''$_'',i3.3)')ktoken ! build a unique name for the token string found for this output string wstrng=toknam call stuffa(toknam,string(:iend),ival,0) ! cannot do this earlier or indexs from call that defined args could be wrong if(ival.gt.0)then fval=ival ier=2 mssge=string(:iend) else mssge='*stufftok* could not store concatenated string' ier=-1 endif return end C#======================================================================-------- subroutine juargs(line,ilen,array,itype,iarray,ier,mx) C given a line of structure " par1,par2,par3,... par(n)" C store each par(n) into a separate variable in C real array. each par(n) may be any legal non-parenthesized C expression. the input string line is not altered. C up to mx par(i) will be extracted, if more are found an C error is generated. C ier=-1 if error occurs, ier undefined (not changed) if no error. C commas are only legal delimiters C extra or redundant delimiters are -ignored- implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC character*(*) line,delimc*1 ,wstrng*(icbuf) dimension array(mx), itype(mx) ! itype=0 for number, itype=2 for string parameter (delimc=',') iarray=0 if(ilen.eq.0)then ! check if input line (line) was totally blank return endif C there is at least one non-delimiter character in the command. C ilen is the column position of the last non-blank character C find next non-delimiter icol=1 do 100 ilook=1,mx,1 200 continue if(line(icol:icol).ne.delimc)then iarray=iarray+1 istart=icol iend=index(line(istart:ilen),delimc) if(iend.eq.0)then ! no delimiter left icalc=ilen-istart+1 wstrng=line(istart:ilen) ier=0 call jucals(wstrng,icalc,array(iarray),ier) itype(iarray)=ier return else iend=iend+istart-2 icalc=iend-istart+1 wstrng=line(istart:iend) ier=0 call jucals(wstrng,icalc,array(iarray),ier) itype(iarray)=ier if(ier.eq.-1)return endif icol=iend+2 else icol=icol+1 if(icol.gt.ilen)return ! last character in line was a delimiter, so no text left go to 200 endif if(icol.gt.ilen)return ! last character in line was a delimiter, so no text left 100 continue write(mssge,'(a,i4,a)')'more than ',mx,' arguments not allowed' ier=-1 return end C#======================================================================-------- subroutine jucals(string,nchar,value,ier) C resolve a series of terms into a single value and restring implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC external juatoa,jupows ,jurtoa,jufacs character*(*) string, dummy*(icbuf) ! no single term may be over (icbuf) characters C!!!! what happens if the returned string is longer than the input string? value=0.0 ! initialize sum value to be returned to 0 if(nchar.eq.0) return ! if this is a null string return C!!!!! first cut at handling string variables. assuming, with little checking, that the only string expression C!!!!! that can get here is a single variable name (or variable token) and that string variable names start with a $ C!!!!! and that the error flag should be set to the value 2 to indicate that a string, not a number, is being returned C!!!!! for the 2 to get back, it must not be changed by this routine or anything it calls if(string(1:1).eq.'$')then call juatoa(string,ier) if(ier.eq.-1)return ier=2 Cx return endif Cx!!!!! ista=1 ! initialize the position of the unary sum operator for the current term if(index('#=',string(1:1)).ne.0)then ! check if input string starts with a unary (+-) operator istat=2 ! a starting unary sum operator is present, so the first term starts in column 2 else ! input string does not start with a unary sum (-+) operator istat=1 ! no initial sum operator is present, so the first term starts in column 1 endif 1 continue iendp=index(string(istat:nchar),'#') ! find left-most addition operator iendm=index(string(istat:nchar),'=') ! find left-most subtraction operator iend=min(iendp,iendm) ! find left-most sum (+-) operator assuming at least one of each exists if(iend.eq.0)iend=max(iendm,iendp) ! if one of the sum operators is not remaining, find left-most of remaining type if(iend.eq.0)then ! if no more sum operators remain this is the last remaining term iend=nchar ! find end character of remaining term else ! more than one term remains iend=iend+istat-2 ! find end character position of this (left-most) term endif dummy=string(istat:iend) ! set string dummy to current(left-most) term nchar2=iend-istat+1 ! calculate number of characters in current term C given that the current term ( dummy) is an optionally signed string containing only the operators **, * an / and no C parenthesis, reduce the string to a single value and add it to the sum of terms (value). do not change the input string. call jupows(dummy,nchar2,ier) ! evaluate and remove ** operators and return the altered string (dummy) if(ier.eq.-1) return ! if an error occurred, return call jufacs(dummy,nchar2,temp,ier) ! evaluate and remove * and / operators, return the evaluated -value- temp if(ier.eq.-1)return ! if an error occurred, return if(string(ista:ista).eq.'=')then ! if term operator was a subtraction, subtract temp from value value=value-temp else ! operator was an addition (+) , add temp to value C!!! if first term was not signed, then first character will not be a subtraction, so addition is implied value=value+temp endif ista=iend+1 ! calculate where next sum operator (assuming there is one) will be positioned in (string) istat=ista+1 ! calculate where beginning character of next term will be (if another term remains) if(iend.ne.nchar)then if(istat.gt.nchar)then ! a trailing sum operation on end of string ier=-1 mssge='trailing sum operator' return endif go to 1 ! if last term was not the end of (string) terms remain. keep summing terms endif call jurtoa(value,string,nchar,ier) ! successfully completed. convert sum of terms (value) to a string and return return end C#======================================================================-------- subroutine jupows(wstrng,nchar,ier) C C do all power functions in a string, working from left to C right until done or an error occurs C C given an unparenthesisized string of form: C stringo opo fval1 ** fval2 opo2 stringo2 C where opo is a preceding optional operator from set /,* and C stringo is the string that would precede opo when it exists, C and opo2 is an optional trailing operator from set /,*,** C and stringo2 the string that would follow op2 when it exists, C evaluate the expression fval1**fval2 and restring it; repeating C from left to right until no power operators remain in the string C or an error occurs C C ip =position of beginning of first ** operator C iz =beginning of fval1 string C iright =end of fval2 string C wstrng=input string returned with power operators evaluated C nchar =input length of wstrng, returned corrected for new C wstrng returned. C implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC character tempch*(icname), dummy*(icbuf) character z*1, wstrng*(*) 1 continue C find first occurrence of operator, starting at left and moving right ip=index(wstrng(:nchar),'**') if(ip.eq.0) then return elseif(ip.eq.1) then ier=-1 mssge='power function "**" missing exponentiate' return elseif((ip+2).gt.nchar) then ier=-1 mssge='power function "**" missing power' return endif C C find beginning of fval1 for this operator. go back to C beginning of string or to any previous * or / operator do 10 i=ip-1,1,-1 iz=i z=wstrng(i:i) if(index('*/',z).ne.0)then ! note that use of index function was faster than .eq. on cyber iz=iz+1 go to 11 endif 10 continue iz=1 11 continue if(ip-iz.eq.0)then ier=-1 mssge='operator / is beside operator **' return endif C C now isolate beginning and end of fval2 string for current operator C note that looking for * also looks for ** operator, so checking C for * or / or ** to right C im2=index(wstrng((ip+2):nchar),'*') id2=index(wstrng((ip+2):nchar),'/') ip2=min0(im2,id2) if(ip2.eq.0)ip2=max0(im2,id2) if(ip2.eq.0)then iright=nchar elseif(ip2.eq.1)then ier=-1 mssge='two operators from set [*/**] are side by side' return else iright=ip2+ip endif call juator(wstrng(iz:ip-1),fval1,ier) if(ier.eq.-1)return call juator(wstrng(ip+2:iright),fval2,ier) if(ier.eq.-1)return if(fval1.lt.0.0)then C this form better/safe? if(abs( fval2-int(fval2)/fval2).le..0001) if(fval2-int(fval2).eq.0.0)then fval1=fval1**int(fval2) else mssge='negative to the real power not allowed' ier=-1 return endif else fval1=fval1**fval2 endif call jurtoa(fval1,tempch,nchart,idum) C place new value back into string and correct nchar. C note that not checking for nchar greater than (icbuf) C in dummy or greater than len(wstrng). if(iz.eq.1.and.iright.eq.nchar)then ! there was only one operator and routine is done dummy=tempch(1:nchart) nchar=nchart else if(iz.eq.1)then ! iz was 1, but iright was nchar so dummy=tempch(1:nchart)//wstrng(iright+1:nchar) nchar=nchart+nchar-(iright+1)+1 else if(iright.eq.nchar)then ! iz was not 1, but iright was nchar so dummy=wstrng(1:iz-1)//tempch(1:nchart) nchar=(iz-1)+nchart else ! iz was not 1, and iright was not nchar so dummy=wstrng(1:iz-1)//tempch(1:nchart)//wstrng(iright+1:nchar) nchar=(iz-1)+nchart+(nchar-(iright+1)+1) endif wstrng=dummy go to 1 end C#======================================================================-------- subroutine jufacs(wstrng,nchr,fval1,ier) C C given an unparenthesisized string containing only the operators * and / reduce it to a single value. the input string is C unaltered. for any single pass thru the routine, the string structure is assumed to be: C fval1 op fval2 op fval op fval op fval op fval C where no blanks are in the string (only significant if string structure is bad) and the only operators are * or /. C working from left to right: C 1. locate and place into a real variable the fval1 string C 2. if one exists, locate and place into a real variable the fval2 string C 3. perform the indicated operation between fval1 and fval2 C and store into fval1. C 3. repeat steps 2 thru 4 until no operators are left or C an error occurs. C C nchr = the position of the last non-blank character in the input string wstrng C ip = the position of the current operator to be used. C to the left of this is the fval1 string. C iright = the position of the last character in the fval2 string. C wstrng = the input string to be interpreted. C ier = is a flag indicating whether an error has occurred C implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC character*(*) wstrng if((nchr).eq.0)then ier=-1 mssge='trying to add/subtract a null string' return endif C find position of first operator im=index(wstrng(:nchr),'*') id=index(wstrng(:nchr),'/') C ip should be the position of the left-most operator ip=min0(im,id) C if one or both of the operators were not present, then C either im or id (or both) are zero, so look for max C instead of min for ip if(ip.eq.0) ip=max0(im,id) if( ip.eq.0 )then C no operator character (/ or *) left call juator(wstrng(1:nchr),fval1,ier) return elseif (ip.eq.1)then C if no string to left of operator, have a bad input string ier=-1 mssge='first factor or quotient for "*" or "/" missing or null' return endif C convert located string for fval1 into real variable fval1 call juator(wstrng(1:ip-1),fval1,ier) if(ier.eq.-1)return 2 if(ip.eq.nchr)then C if no string to left of operator, have a bad input string ier=-1 mssge='second factor or quotient for "*" or "/" missing or null' return endif C locate string to put into fval2 for current operator by starting just to right of operator and ending at end of current C string or at next operator note that because of previous checks we know there is something to right of the operator. im2=index(wstrng((ip+1):nchr),'*') id2=index(wstrng((ip+1):nchr),'/') ip2=min0(im2,id2) if(ip2.eq.0)ip2=max0(im2,id2) if(ip2.eq.0)then iright=nchr elseif(ip2.eq.1)then ier=-1 mssge='two operators from set [*/] are side by side' return else iright=ip2+ip-1 endif C place located string for fval2 into real variable fval2 call juator(wstrng(ip+1:iright),fval2,ier) if(ier.eq.-1)return C do specified operation between fval1 and fval2 if(wstrng(ip:ip).eq.'*') then fval1=fval1*fval2 else if(fval2.eq.0) then ier=-1 mssge='division by zero' return else fval1=fval1/fval2 endif if(iright.eq.nchr)return ip=iright+1 go to 2 end C#======================================================================-------- subroutine juator(chars,rval,ierr) ! CAREFUL: LAST is in common, but can be read from when also passed ! to this routine as CHARS. DO NOT CHANGE CHARS. C C returns a real value rval from a numeric character string chars. C C 1. if chars=? set rval to value stored as current value, return. C 2. if the string starts with a $ assume it is the name of a C string variable or token and return its location as a real number. C 3. try to read string into a real value. if successful, return. C 4. if not interpretable as a real value, see if it is a C defined variable name and use that name's value if it is. C 5. if no value can be associated to the string and/or if C an unexpected error has occurred, set error flag and C error message and set rval to zero and return. C 6. note that blanks are treated as null, not zero. C C o works with any g-format input, including integer, real, and C exponential forms. C o 07/15/86 j. s. urban C o 12/28/87 modified to specify bn in formats for reads. vax C defaults to zero-fill on internal files. j. s. urban C C chars is the input string C rval is the output real value C implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC character last*(iclen) character ix(ic)*(icname),ix2(ic)*(icname) character*(*) chars,frmt*13 dimension value(ic) common/zzlast/last ! last is string containing last answer (i.e. current value) common/uindex/ix ! ix contains the names of variables common/uvalue/value ! value contains the numeric values of variables common/uindx2/ix2 ! the array of string variable names save /zzlast/,/uvalue/,/uindex/,/uindx2/ ioerr=0 if(chars.eq.'?')then ! if string is a (unsigned) question mark, use value returned from last completed calculation read(last,'(bn,g20.0)',iostat=ioerr,err=9991)rval ! assuming cannot get a read error out of reading last elseif('$'.eq.chars(1:1))then ! string is a string variable name call jubous(chars,indx,ix2,ier) ! try to find the index in the character array for the string variable if(indx.le.0)then ! if indx is not .gt. 0 string was not a variable name ierr=-1 mssge= & 'undeclared string variable '//chars(:min(len(chars),(icname))) else rval=real(indx) ! set value to position of string in the string array C!!! flag via a value for ierr that a string, not a number, has been found endif return C no error on read on Sun on character string as a number, so make sure first character not numeric and try as variable name elseif(index('0123456789.-+',chars(1:1)).eq.0)then ! does not start with a numeric character. try as a variable name call jubous(chars,indx,ix,ier) if(indx.le.0)then ! if indx is not .gt. 0 string was not a variable name ierr=-1 mssge='undeclared variable '//chars(:min(len(chars),(icname))) else rval=value(indx) endif return else ! string is a number or a numeric variable name that starts with a numeric character write(frmt,101)len(chars) ! build a format statement to try and read the string as a number with 101 format( '(bn,g',i5,'.0)' ) read(chars,fmt=frmt,iostat=ioerr,err=999)rval ! try and read the string as a number endif return ! string has successfully been converted to a number 9991 continue ! string could not be read as number,so try as variable name that starts with number 999 continue ! string could not be read as number,so try as variable name that starts with number rval=0.0 indx=0 C either here because of a read error (too big, too small, bad characters in string) or this is a variable name C or otherwise unreadable. C!!!! look carefully at what happens with a possible null string call jubous(chars,indx,ix,ier) if(indx.le.0)then ! if indx is not .gt. 0 string was not a variable name mssge='bad variable name or unusable value = '//chars ierr=-1 else rval=value(indx) endif return end C#======================================================================-------- subroutine jurtoa(rval,chars,ilen,ierr) C C returns a numeric character string from a real value, C o left-justified with number of characters counted C o trailing zeros removed C o if an error occurs in the write, numeric character string is set C to '0.0' and ierr is set to -1 C do not use with len(chars) less than 20 C o if somehow fall thru loop (blank string or non-numeric string) C ierr=-1 C uses g format for output. if a number is output under the C gw.d specification without an exponent, four spaces are C inserted to the right of the field (these spaces are reserved C for the exponent field e+xx). C C 03/16/87 j. s. urban C implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC character*(*) chars, dummy*20 ioerr=0 chars=' ' C note that output is forced to far right of string C (d=13,e=3,d+e+6=13+3+4=20) write(dummy,fmt='(g20.13e3)',iostat=ioerr,err=999)rval iepos=index(dummy,'e') iepos2=index(dummy,'E') if(iepos.eq.0)iepos=iepos2 if(iepos.eq.0)then C======================================================================= C written with f-format. C remove trailing zeros and left-justify string and find it's C length . note that, written with the g format, output C should always contain a decimal place, so don't have to C special case a string of all zeros. C do 10 i10=20,1,-1 if(dummy(i10:i10).ne.'0'.and.dummy(i10:i10).ne.' ')then iend=i10 do 20 i20=iend-1,1,-1 if(dummy(i20:i20).eq.' ')then istart=i20+1 ilen=iend-istart+1 chars(1:ilen)=dummy(istart:iend) return endif 20 continue ilen=iend C chars is completely filled chars(1:ilen)=dummy(1:iend) return else endif 10 continue C error has occurred if fall out of loop instead of returning C if error was not do to write, ioerr is zero, but ierr will C still return as -1 else C=======================================================================-------- C written with e-format. C iende=iepos C find last non-blank character in e+xx field do 50 i50=20,iepos+1,-1 if(dummy(i50:i50).ne.' ')then iende=i50 go to 31 endif 50 continue 31 do 30 i30=iepos-1,1,-1 if(dummy(i30:i30).ne.'0'.and.dummy(i30:i30).ne.' ')then iend=i30 do 40 i40=iend-1,1,-1 if(dummy(i40:i40).eq.' ')then istart=i40+1 ilen=(iend-istart+1)+(iende-iepos+1) chars(1:ilen)=dummy(istart:iend)//dummy(iepos:iende) return endif 40 continue ilen=iend+(iende-iepos+1) C chars is completely filled chars(1:ilen)=dummy(1:iend)//dummy(iepos:iende) return else endif 30 continue endif C error has occurred if fall out of loop instead of returning C if error was not do to write, ioerr is zero, but ierr will C still return as -1 999 continue chars='0.0' mssge='cannot represent value using (g20.13e3) format ' ierr=-1 return end C#======================================================================-------- subroutine jusqes(string,imax,nchars,varnam,nchar2,ier) C C remove all blanks from input string and return position of last non-blank character in nchars using imax as the highest C column number to search in. return a zero in nchars if the string is blank. C C replace all + and - characters with the # and = characters which will be used to designate + and - operators, as opposed to C value signs. C C replace [] with () C C remove all strings from input string and replace them with string tokens and store the values for the string tokens. C assumes character strings are (iclen) characters max. C if string is delimited with double quotes, the double quote character may be represented inside the string by C putting two double quotes beside each other ("he said ""greetings"", i think" ==> he said "greetings", i think) C C!!!! if an equal sign is followed by a colon the remainder of the input line is placed into a string as-is C!!!! without the need for delimiting it. ($string1=: he said "greetings", i think ==> he said "greetings", i think) C C anything past an # is consider a comment and ignored C C assumes length of input string is less than (icbuf) characters C C if encounters more than one equal sign, uses right-most as the C end of variable name and replaces others with & and makes a C variable name out of it (ie a=b=10 ===> a&b=10) C C!!!!the length of string could actually be increased by converting quoted strings to tokens C C!!!!maybe change this to allow it or flag multiple equal signs? C C!!!!no check if varnam is a number or composed of characters C!!!!like ()+-*/. . maybe only allow a-z with optional numeric C!!!!suffix and underline character? C C!!!!variable names ending in letter e can be confused with C!!!!e-format numbers (is 2e+20 the variable 2e plus 20 or C!!!!the single number 200000000000000000000?). to reduce C!!!!amount of resources used to check for this, and since C!!!!words ending in e are so common, will assume + and - C!!!!following an e are part of an e-format number if the C!!!!character before the e is a period or digit (.0123456789). C!!!!and won't allow variable names of digit-e format). C C!!!!make sure variable called e and numbers like e+3 or .e+3 are handled satisfactorily C implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC parameter(ilen=(icbuf)+2) character*(*) string,dummy*(ilen),back1*1,back2*1 character currnt*1,varnam*(icname),ctoken*(iclen) character list*10,list2*10 character*5 toknam ,values(ic)*(iclen) ,ix2(ic)*(icname) dimension valuer(ic) common/uindx2/ix2 ! the array of string variable names common/ustrng/values ! the string variable values common /ustrln/valuer ! the lengths of the string variable values common/ztoken/ktoken ! count of number of token strings assembled save /ustrng/,/uindx2/, /ustrln/,/ztoken/ list =' +-="#[]{}' ! list of special characters list2=' #=& ()()' ! list of what to convert special characters too when appropriate C keep track of previous 2 non-blank characters in dummy for when trying to distinguish between e-format numbers C and variables ending in e. back1=' ' back2=' ' varnam=' ' !initialize output variable name to a blank string ivar=0 nchar2=0 nchars=0 !nchars will be the position of the last non-blank character in the output string (string) dummy(1:2)=' ' C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= C instead of just copy string to buffer, cut out rows of sign operators C dummy(3:)=string idum=3 instring=0 do 10 i10=1,len(string) ! if adjacent sign characters skip new character and maybe change sign of previous character if(string(i10:i10).eq.'"'.and.instring.eq.0 )then ! starting a string instring=1 elseif(string(i10:i10).eq.'"'.and.instring.eq.1)then ! ending a string instring=0 endif if(instring.ne.1)then if(string(i10:i10).eq.'+')then ! if found a + look to see if previous a + or - if(dummy(idum-1:idum-1).eq.'+')then ! last character stored was also a sign (it was +) goto 10 ! skip because ++ in a row elseif(dummy(idum-1:idum-1).eq.'-')then ! skip -+ and just leave - goto 10 endif elseif(string(i10:i10).eq.'-')then ! last character stored was also a sign (it was -) if(dummy(idum-1:idum-1).eq.'+')then ! +- in a row dummy(idum-1:idum-1)='-' ! change sign of previous plus goto 10 ! skip because +- in a row elseif(dummy(idum-1:idum-1).eq.'-')then ! skip but change sign of previous dummy(idum-1:idum-1)='+' ! change -- to + goto 10 endif endif endif ! character not skipped dummy(idum:idum)=string(i10:i10) ! simple copy of character idum=idum+1 10 continue C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= string=' ' ipoint=2 ! ipoint is the current character pointer for (dummy) ktoken=0 ! initialize the number of strings found in this string do 1 ilook=1,imax ipoint=ipoint+1 ! move current character pointer forward currnt=dummy(ipoint:ipoint) ! store current character into currnt itype=index(list,currnt) ! check to see if current character has special meaning and requires processing C!!!!!probably would be faster to use ichar instead of index function go to(1000,2000,2000,4000,5000,6000,7000,7000,7000,7000)itype C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= go to 2 !current is not one of the special characters in list C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 1000 continue go to 1 !current is a blank not in a string. ignore it C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 2000 continue !current is a plus or minus if(back1.eq.'e'.or.back1.eq.'E')then !if previous letter was an e it could be e-format sign or operator. C note not using dummy directly, as it may contain blanks letter before +- was an e. must decide if the +- is part of C an e-format number or intended to be the last character of a variable name. C!!!! what is effect on a---b or other +- combinations? if(index('0123456789.',back2).eq.0)then !if letter before e is not numeric this is a variable name and - is an operator currnt=list2(itype:itype) ! no digit before the e, so the e is the end of a variable name else ! digit before the e, so assume this is a number and do not change +- to #= operators endif else currnt=list2(itype:itype) ! previous letter was not an e, so +- is an operator so change +- to #= operators endif go to 2 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 4000 continue ! currnt is an equal sign currnt=list2(itype:itype) ivar=nchars+1 ! ivar is the position of an equal sign, if any go to 2 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 7000 continue ! currnt is [ or ], or { or }. Replace with () currnt=list2(itype:itype) go to 2 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 5000 continue ! if character starts a quoted string, extract it and replace it with a token C figure out length of string, find matching left double quote, reduce internal "" to " kstrln=0 ! initialize extracted string length ctoken=' ' ! initialize extracted string do 20 i20 = ipoint+1,imax+2 ! try to find a matching double quote to the right of the first ipoint=ipoint+1 if(dummy(ipoint:ipoint).eq.'"')then !!!!! caution : could look at dummy(imax+1:imax+1) if(dummy(ipoint+1:ipoint+1).ne.'"')then ! this is the end of the string go to 30 else ! this is being used to try and represent an internal double-quote kstrln=kstrln+1 ! determine length of string to remove ctoken(kstrln:kstrln)=dummy(ipoint:ipoint) ! store the character into the current string storage ipoint=ipoint+1 endif else ! this is an internal character of the current string kstrln=kstrln+1 ! determining length of string to remove ctoken(kstrln:kstrln)=dummy(ipoint:ipoint) ! store the character into the current string storage endif 20 continue ier=-1 ! if you get here an unmatched string delimiter (") has been detected mssge='unmatched quotes in a string' return 30 continue C!!!! check that current token string is not over (iclen) characters long . what about the string "" or """" or """ ? ktoken=ktoken+1 ! increment the counter of strings found write(toknam,'(''$_'',i3.3)')ktoken ! build a unique name for the token string found for this input string nchars=nchars+1 ! increment counter of characters stored string(nchars:nchars+4)=toknam ! replace original delimited string with its token nchars=nchars+4 C store the token name and value in the string variable arrays call jubous(toknam,indx,ix2,ier) ! determine storage placement of the variable and whether it is new if(ier.eq.-1)return if(indx.le.0)then ! check if the token name needs added or is already defined call juadds(toknam,5,indx,ier) ! adding the new variable name in the variable name array if(ier.eq.-1)return endif values(iabs(indx))=ctoken(1:max(1,kstrln)) ! store a defined variable's value valuer(iabs(indx))=kstrln ! store length of string C!!!! note that reserving variable names starting with $_ for storing character token strings go to 1 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 2 continue ! for all but blank characters and strings back2=back1 back1=currnt nchars=nchars+1 string(nchars:nchars)=currnt 1 continue 6000 continue if(ivar.ne.0)then ! check to see if a variable name was defined: nchar2=ivar-1! variable was declared nchar2 is the position of the last character in the variable name if(nchar2.gt.20)then ier=-1 mssge='new variable names must be 20 characters long or less' else if(nchar2.eq.0)then ier=-1 mssge='input starts with =; cannot define a null variable name' else ! split up variable name and expression C legal length variable name if(index('eE',string(nchar2:nchar2)).ne.0.and.nchar2.ne.1)then ! could be an unacceptable variable name if(index('0123456789',string(nchar2-1:nchar2-1)).ne.0)then C an unacceptable variable name if going to avoid conflict with C e-format numbers in a relatively straight-forward manner mssge='variable names ending in digit-e not allowed' ier=-1 endif endif dummy=string varnam=dummy(1:ivar-1) if(nchars.ge.ivar+1)then string=dummy(ivar+1:nchars) else string=' ' endif nchars=nchars-ivar endif endif return end C#======================================================================-------- subroutine jubous(varnam0,index,ixn,ier) C C assuming an alphabetized array of character strings, find the location (index) where that name can be found, unless it is not C found -- in which case report where it should be placed as a negative index number. it is assumed all variable names are C lexically greater than a blank string. C C finds the index assigned to a specific variable name. assumes that the user index array is sorted in descending order C (highest at top). if varnam is not found; return line number it should be placed at ; with a negative sign. C implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC character*(icname) ixn(ic), varnam*(icname) character varnam0*(*) integer maxtry varnam=varnam0(:) maxtry=int(log(float(ic))/log(2.0)+1.0) index=(ic+1)/2 imin=1 imax=ic do 10 i10=1,maxtry if(varnam.eq.ixn(index))then return else if(varnam.gt.ixn(index))then imax=index-1 else imin=index+1 endif if(imin.gt.imax)then index=-imin if(iabs(index).gt.ic)then mssge='error 03 in jubous' ier=-1 return endif return endif index=(imax+imin)/2 if(index.gt.ic.or.index.le.0)then mssge='error 01 in jubous' ier=-1 return endif 10 continue mssge='error 02 in jubous' return end C#======================================================================-------- subroutine juaddr(newnam,nchars,index,ier) C given a new variable name and place to put it, pull down the character and value arrays and initialize the new C variable's value to zero. variable names only up to (icname) characters maximum. implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC character*(icname) ix(ic), newnam*(*) dimension value(ic) common /uindex/ix common /uvalue/value save /uindex/,/uvalue/ if(ix(ic).ne.' ')then mssge='*juaddr* no room left on file to add more variable names' ier=-1 return endif if(newnam(1:1).eq.'$')then mssge='*juaddr* numeric variable names must not start with a $' ier=-1 return endif istart=iabs(index) C watch out when ic approaches istart that logic is correct. do 70 i70=ic-1,istart,-1 C pull down the array to make room for new value value(i70+1)=value(i70) ix(i70+1)=ix(i70) 70 continue value(istart)=0.0 ix(istart)=newnam(1:nchars) return end C#======================================================================-------- subroutine juadds(newnam,nchars,index,ier) C C given a new string variable name and place to put it, pull down C the character and value arrays and initialize the new C variable's value to a blank string. variable names only up to (icname) C characters maximum. stored strings up to only (iclen) characters long. C C newnam = (input) new variable name C nchar = (input) last non-blank character position in newnam C index = (input) position in array to place newnam, calculated C by jbounc. C ier = (output)error flag. set to -1 if an error occurs; C otherwise it is left undefined. C C commons C /uindx2/ix2 - storage for variable names C /ustrng/values - storage for variable string values C /zzmssg/mssge - message associated with error flag C C this routine is very similar to juaddr except that the values C to be stored are strings instead of real numbers. C it is essentially trusting of its input, and does very little C checking of input parameters. C C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C maximum number of string variables to be stored character*(icname) ix2(ic), newnam*(*) dimension valuer(ic) character*(iclen) values(ic) common /uindx2/ix2 common /ustrng/values common /ustrln/valuer ! the lengths of the string variable values save /uindx2/,/ustrng/,/ustrln/ C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= C if last position in the name array has already been used, then C report that no room is left and set error flag and error message. if(ix2(ic).ne.' ')then mssge='*juadds* no room left to add more string variable names' ier=-1 return endif C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= if(newnam(1:1).ne.'$')then mssge='*juadds* string variable names must start with a $' ier=-1 return endif C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= istart=iabs(index) C watch out when ic approaches istart that logic is correct. do 70 i70=ic-1,istart,-1 C pull down the array to make room for new value values(i70+1)=values(i70) valuer(i70+1)=valuer(i70) ix2(i70+1)=ix2(i70) 70 continue values(istart)=' ' valuer(istart)=0 ix2(istart)=newnam(1:nchars) return end C#======================================================================-------- subroutine juatoa(chars,ierr) C return the actual string when given a string variable name or token C the returned string is passed thru the message/string/error common C ierr is set and returned as C -1 an error occurs C 2 a string is returned implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC dimension valuer(ic) character*(*) ix2(ic)*(icname) ,values(ic)*(iclen) character*(*) chars common/uindx2/ix2 ! ix2 contains the names of string variables and tokens common/ustrng/values ! values contains the values of string variables common /ustrln/valuer ! the lengths of the string variable values save /ustrng/,/uindx2/, /ustrln/ ierr=0 index=0 call jubous(chars,index,ix2,ierr) if(ierr.eq.-1) return if(index.le.0)then ierr=-1 C!!! what if len(chars) is 0? look carefully at what happens with a possible null string mssge= & ' variable '//chars(:min(icname,len(chars)))//' is undefined' else ierr=2 mssge=values(index) endif return end C#======================================================================-------- subroutine jufind(varnam,index2,n,ier) C C assuming an alphabetized array of character strings, find the location (index) where that name can be found, unless it is not C found -- in which case report where it should be placed as a negative index number. it is assumed all variable names are C lexically greater than a blank string. C C if it is found, return the number extracted from the right side of the string C C finds the index assigned to a specific variable name. assumes that the user index array is sorted in descending order C (highest at top). if varnam is not found; return line number it should be placed at ; with a negative sign. C implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC intrinsic log external jshelc parameter(icf=111) ! the number of commands character*40 ixn(icf), varnam*(*) ,scrac integer nv(icf),gt(icf) integer maxtry save ixn, ncall, nv, gt data ncall/0/ if(ncall.eq.0)then ncall=1 C flag a check is not to be made by specifying a negative number for C the number of parameters C !function name !goto !number of parameters ixn( 1)='!!!!!!!!!!!!!!!!!!!!0000000000-111111111' ixn( 2)='acos 1 1 ' ixn( 3)='asin 2 1 ' ixn( 4)='atan 3 1 ' ixn( 5)='cos 4 1 ' ixn( 6)='cosh 5 1 ' ixn( 7)='sin 6 1 ' ixn( 8)='sinh 7 1 ' ixn( 9)='tan 8 1 ' ixn( 10)='tanh 9 1 ' ixn( 11)='abs 10 1 ' ixn( 12)='aint 11 1 ' ixn( 13)='anint 12 1 ' ixn( 14)='x 13 1 ' ixn( 15)='exp 14 1 ' ixn( 16)='floor 15 1 ' ixn( 17)='frac 16 1 ' ixn( 18)='~unusedf 17 1 ' ixn( 19)='nint 18 1 ' ixn( 20)='int 19 1 ' ixn( 21)='log 20 1 ' ixn( 22)='log10 21 1 ' ixn( 23)='real 22 1 ' ixn( 24)='sqrt 23 1 ' ixn( 25)='r2d 24 1 ' ixn( 26)='d2r 25 1 ' ixn( 27)='y 26 1 ' ixn( 28)='atan2 27 2 ' ixn( 29)='dim 28 2 ' ixn( 30)='mod 29 2 ' ixn( 31)='sign 30 2 ' ixn( 32)='max 31 -1 ' ixn( 33)='min 32 -1 ' ixn( 34)='xstore 33 -1 ' ixn( 35)='ystore 34 -1 ' ixn( 36)='ceil 35 1 ' ixn( 37)='~unusedf 36 -1 ' ixn( 38)='$ 37 -1 ' ixn( 39)='~unusedf 38 2 ' ixn( 40)='lle 39 -1 ' ixn( 41)='llt 40 -1 ' ixn( 42)='leq 41 -1 ' ixn( 43)='lge 42 -1 ' ixn( 44)='lgt 43 -1 ' ixn( 45)='lne 44 -1 ' ixn( 46)='ichar 45 -1 ' ixn( 47)='$char 46 -1 ' ixn( 48)='le 47 -1 ' ! ixn( 49)='lt 48 -1 ' ! ixn( 50)='eq 49 -1 ' ! ixn( 51)='ge 50 -1 ' ! ixn( 52)='gt 51 -1 ' ! ixn( 53)='ne 52 -1 ' ! ixn( 54)='if 53 3 ' ! ixn( 55)='c2f 54 1 ' ! ixn( 56)='f2c 55 1 ' ! ixn( 57)='in 56 3 ' ! ixn( 58)='$str 37 -1 ' ixn( 59)='$substr 57 -1 ' ixn( 60)='index 59 2 ' ! ixn( 61)='$xstore 60 -1 ' ! ixn( 62)='$ystore 61 -1 ' ! ixn( 63)='$x 62 -1 ' ! ixn( 64)='$y 63 -1 ' ! ixn( 65)='len 64 -1 ' ! ixn( 66)='$if 65 3 ' ! ixn( 67)='~unusedf 66 -1 ' ! ixn( 68)='~unusedf 67 -1 ' ! ixn( 71)='~unusedf 68 0 ' ! ixn( 70)='~unusedf 69 0 ' ! ixn( 69)='~unusedf 70 0 ' ! ixn( 72)='~unusedf 71 0 ' ! ixn( 73)='~unusedf 72 0 ' ! ixn( 74)='~unusedf 73 0 ' ! ixn( 75)='~unusedf 74 0 ' ! ixn( 76)='~unusedf 75 1 ' ! ixn( 77)='~unusedf 76 0 ' ! ixn( 78)='~unusedf 77 0 ' ! ixn( 79)='~unusedf 78 -1 ' ! ixn( 80)='~unusedf 79 -1 ' ! ixn( 81)='~unusedf 80 -1 ' ! ixn( 82)='~unusedf 58 -1 ' ! ixn( 83)='~unusedf 81 -1 ' ! ixn( 84)='~unusedf 82 -1 ' ! ixn( 85)='str 83 -1 ' ! ixn( 86)='~unusedf 85 2 ' ! ixn( 87)='~unusedf 86 2 ' ! ixn( 88)='~unusedf 87 1 ' ! ixn( 89)='~unusedf 88 1 ' ! ixn( 90)='~unusedf 89 2 ' ! ixn( 91)='~unusedf 90 -1 ' ! ixn( 92)='~unusedf 91 1 ' ! ixn( 93)='$f 92 2 ' ! ixn( 94)='~unusedf 93 -1 ' ! ixn( 95)='~unusedf 94 -1 ' ! ixn( 96)='~unusedf 95 -1 ' ! ixn( 97)='~unusedf 96 -1 ' ! ixn( 98)='~unusedf 97 -1 ' ! ixn( 99)='~unusedf 98 -1 ' ! ixn( 100)='~unusedf 99 -1 ' ! ixn( 101)='~unusedf 100 -1 ' ! ixn( 102)='~unusedf 101 -1 ' ! ixn( 103)='~unusedf 102 -1 ' ! ixn( 104)='~unusedf 103 -1 ' ! ixn( 105)='~unusedf 104 -1 ' ! ixn( 106)='~unusedf 105 -1 ' ! ixn( 107)='~unusedf 106 -1 ' ! ixn( 108)='~unusedf 107 -1 ' ! ixn( 109)='~unusedf 108 -1 ' ! ixn( 110)='~unusedf 109 -1 ' ! ixn(icf)='~~~~~~~~~~~~~~~~~~~~0000000000-111111111' imax1=icf call jshelc(ixn,imax1,scrac,1,icname) !sort name-goto-number of variable strings do 40 i40=1,icf read(ixn(i40)(21:30),'(bn,i10)')gt(i40) !fill array for goto numbers read(ixn(i40)(31:40),'(bn,i10)')nv(i40) !fill array for number of variables 40 continue endif if(varnam.eq.'funcs')then print*,'standard functions available:' print*,' ' C!!!! assuming function names are short C!!!! and that !!!!!!!!!!! and ~~~~~~~~~ are last and first !Solaris BUG if tab at end, and not just printing columns 1-7 !f77: SC4.0 18 Oct 1995 FORTRAN 77 4.0 !write(*,'('' '',a,t10,a,t20,a,t30,a,t40,a,t50,a,t60,a,t70)') write(*,'('' '',a7,t10,a7,t20,a7,t30,a7,t40,a7,t50,a7,t60,a7)') $ (ixn(i)(1:7),i=icf-1,2,-1) print*,' ' return endif C begin the standard call (not first, not a list of functions) C!!!! don't return error code if function not found,return some other value imin=1 imax=icf maxtry=int(log(float(icf))/log(2.0)+1.0) index=(icf+1)/2 do 10 i10=1,maxtry if( varnam.eq.ixn(index)(1:icname) )then ! found a match index2=gt(index) if(nv(index).ne.n.and.nv(index).ge.0)then ier=-1 mssge= & 'incorrect number of parameters for '//ixn(index)(1:icname) endif return else if(varnam.gt.ixn(index)(1:icname))then imax=index-1 else imin=index+1 endif if(imin.gt.imax)then index=-imin if(iabs(index).gt.icf)then ier=-1 mssge='error 03 in jubous' index2=index return endif index2=index return endif index=(imax+imin)/2 if(index.gt.icf.or.index.le.0)then ier=-1 mssge='error 01 in jubous' index2=index return endif 10 continue mssge='error 02 in jubous' ier=-1 index2=index return end C#======================================================================-------- real*8 function getvalue(varnam) C breaking the rule of only accessing the calculator thru juexpr: C should only be used from user juown1 routines to avoid recursion implicit real*8 (a-h,o-z) character varnam*(*) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC dimension value(ic) character*(icname) ix(ic) common/uvalue/value common/uindex/ix save /uvalue/,/uindex/ call jubous(varnam,index,ix,ierr) if(index.le.0)then ! need option to turn this on and off !call jun(4,'*stuff* error in getvalue') getvalue=0.0 else getvalue=value(index) endif return end C#======================================================================-------- subroutine stuff(varnam0,val4,ioflag) C directly store a number into calculator variable name table C C breaking the rule of only accessing the calculator thru juexpr: C C a direct deposit of a value into the calculator assumed to C be used only by friendly calls, for efficiency implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC real val4 character*(*) varnam0 ! assuming varnam is left justified character*(icname) varnam ! some trouble with variable length character strings on some machines character*(icname+20+1) pass character*(icname) ix(ic) common/uvalue/value common/uindex/ix dimension value(ic) save /uvalue/,/uindex/ C----------------------------------------------------------------------- C assuming friendly, not checking for null or too long varnam0 call jutrim(varnam0,varnam,ilen) ! some trouble with variable length character strings on some machines C----------------------------------------------------------------------- ierr=0 call jubous(varnam,index,ix,ierr) C----------------------------------------------------------------------- if(index.le.0)then call juaddr(varnam,ilen,index,ierr) if(ierr.eq.-1)then call jun(4,'*stuff* error in juaddr') return endif endif C----------------------------------------------------------------------- value(iabs(index))=val4 C----------------------------------------------------------------------- if(ioflag.ge.1)then ! display variable string to trail and output as indicated by ioflag write(pass,'(a,''='',g20.13e3)')varnam(:ilen),val4 call jun(ioflag,pass) endif C----------------------------------------------------------------------- return end C#======================================================================-------- subroutine stuffa(varnam0,string,index,ioflag) C directly store a string into calculator variable name table C C breaking the rule of only accessing the calculator thru juexpr: C C a direct deposit of a value into the calculator assumed to C be used only by friendly calls, for efficiency implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcmssge.h" character mssge*(iclen) common/zzmssg/mssge ! for error message/messages /returning string value save /zzmssg/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC character string*(*), varnam0*(*), varnam*(icname) ! assuming varnam left justified, some machines have trouble dimension valuer(ic) character ix2(ic)*(icname) ,values(ic)*(iclen) character*101 pass common/uindx2/ix2 ! ix2 contains the names of string variables and tokens common/ustrng/values ! values contains the values of string variables common /ustrln/valuer ! the lengths of the string variable values save /ustrng/,/uindx2/, /ustrln/ C----------------------------------------------------------------------- C assuming friendly, not checking for null or too long varnam0 call jutrim(varnam0,varnam,ilen) ! some trouble with variable length character strings on some machines C----------------------------------------------------------------------- ierr=0 call jubous(varnam,index,ix2,ierr) C----------------------------------------------------------------------- if(index.le.0)then call juadds(varnam,ilen,index,ierr) if(ierr.eq.-1)then call jun(4,'*stuffa* error in juadds') return endif endif C----------------------------------------------------------------------- if(ioflag.ge.1)then ! display variable string to trail and output as indicated by ioflag ibig=min(len(string),iclen) ! make sure pass string is not too long write(pass,'(a,''='',a)')varnam(:ilen),string(1:ibig) call jun(ioflag,pass) endif C----------------------------------------------------------------------- index=iabs(index) values(index)=string ilen=len(string) ilen=julen(string(:ilen)) valuer(index)=max(real(ilen),1.0) C----------------------------------------------------------------------- return end C#======================================================================-------- blockdata juinit implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC common /zzrays/x,y ! x and y arrays for procedure jufuns common/zzrayc/xc,yc,nc ! $x,$y and $n arrays common /zzlast/last ! current value (initially 0.0) common /uindex/ix ! numeric variable names common /uvalue/value ! numeric variable name values common /zzown1/ownon ! flag for whether to look for juown1 common /uindx2/ix2 ! string variable names common /ustrng/values ! string variable values common /ustrln/valuer ! lengths of the string variable values character last*(iclen) character*(icname) ix(ic),ix2(ic) ,values(ic)*(iclen) character*(iclen) xc(ixyc),yc(ixyc),nc(ixyc) dimension value(ic), x(ixy), y(ixy), valuer(ic) logical ownon save /zzrays/,/zzlast/,/zzown1/,/zzrayc/ save /uindex/,/uvalue/,/uindx2/,/ustrng/,/ustrln/ data ownon/.false./ data last/'0.0'/ data x/ixy*0.0/,y/ixy*0.0/ data xc/ixyc*' '/,yc/ixyc*' '/,nc/ixyc*' '/ data ix/ic*' '/ data value/ic*0.0/ data valuer/ic*0.0/ data values/ic*' '/ data ix2/ic*' '/ end C#======================================================================-------- subroutine jun(idum,string) C the calculator displays internal error messages using a routine C called jun. This creates a dummy that simply prints the messages. character*(*) string write(*,*)string return end C=======================================================================-------- integer function julen(string) C @(#) return position of last non-blank character in "string". C Copyright(C) 1984 John S. Urban all rights reserved C C if the string is blank, a length of 0 is returned. C C - consider: might like to ignore trailing carriage returns and C tabs and other white space too C C - mod 1: 1994 C added null (char(0)) because HP and some Suns not padding C strings with blank, but with null characters; 1994 JSU C C NB: F90 has an intrinsic called LEN_TRIM that makes julen obsolete. C character string*(*) character null*1 intrinsic len C null=char(0) C ilen=len(string) C if(ilen.ge.1)then ! check for null strings do 10 i10=ilen,1,-1 if(string(i10:i10).ne.' '.and.string(i10:i10).ne.null)then julen=i10 return endif 10 continue endif C julen=0 C return end C=======================================================================-------- character*(*) function lowers(linei) C @(#)lowers: return copy of string converted to lowercase character*(*) linei, let*1 intrinsic ichar, char, len iout=1 inlen=len(linei) do 10 i10=1,inlen,1 let=linei(i10:i10) ilet=ichar(let) C lowercase a-z on cray is 97 to 122 C uppercase a-z on cray is 65 to 90 if( (ilet.ge.65) .and. (ilet.le.90))then C convert uppercase a-z to lowercase a-z lowers(iout:iout)=char(ilet+32) else C character is not a lowercase a-z, just put it in output lowers(iout:iout)=let endif iout=iout+1 10 continue return end C=======================================================================-------- real function ceil(fval0) C@(#) return smallest integer not less than x as a real fval=fval0 if(fval.ne.float(int(fval))) then if(fval.gt.0.0) fval = int(fval)+1 if(fval.lt.0.0) fval = int(fval) endif ceil=fval return end C=======================================================================-------- real function floor(fval0) C@(#) return largest integer not greater than x as a real fval=fval0 if(fval.ne.float(int(fval))) then if(fval.gt.0.0) fval = int(fval) if(fval.lt.0.0) fval = int(fval)-1 endif floor=fval return end C=======================================================================-------- subroutine jutrim(strin,strout,ilen) C @(#) trim leading blanks from string, return last non-blank char. position C C Copyright(C) 1989 John S. Urban All Rights Reserved C C trim leading blanks from a string and return position of last C non-blank character in the string, assume *strout* can hold output C character*(*) strin, strout external julen strout=' ' ilen=julen(strin(1:len(strin))) ! ignore trailing spaces istart=1 do 10 i10=1, ilen istart=i10 if(strin(i10:i10).ne.' ')goto 100 10 continue ilen=0 ! string all blank return C 100 continue C unless VERY specific with line lengths, HP gets this wrong SOMETIMES longout=len(strout) longin=ilen-istart+1 if(longout.lt.longin)then call jun(4,'*jutrim*:error. output line truncated') ilen=istart+longout-1 endif strout(1:longout)=strin(istart:ilen) ilen=ilen-istart+1 ! length not counting trailing white-space return end C=======================================================================-------- subroutine jshelc(lines,n,ihold,istart,iend) C@(#) sorts a character array over a specified field C Copyright(c) 1989 John S. Urban All Rights Reserved C C this procedure sorts a character array over a specified field C C should carefully check for bad input values, C return flag indicating whether any strings to key by were equal, C C lines input character array C n number of elements in input character array(lines) C ihold scratch character variable C istart character position in strings which starts search field C iend character position in strings which ends search field C C lle to sort 'a-z', lge to sort 'z-a' C intrinsic lge character*(*) lines(n),ihold igap=n 1 igap=igap/2 if(igap.eq.0) return k=n-igap i=1 2 j=i 3 jg=j+igap if(lge(lines(j)(istart:iend),lines(jg)(istart:iend)))goto 4 ihold=lines(j) lines(j)=lines(jg) lines(jg)=ihold j=j-igap if(j.ge.1) goto 3 4 i=i+1 if(i.le.k) goto 2 goto 1 end C=======================================================================-------- function round(val,idigits0) C@(#) round val to specified number of significant digits C this does not work very well because of round-off errors make a C better one, probably have to use machine-dependent bit shifting implicit real*8 (a-h, o-z) ! make sure a reasonable number of digits has been requested idigits=max(1,idigits0) aval=abs(val) C select a power that will normalize the number C (put it in the range 1 > abs(val) <= 0) if(aval.ge.1)then ipow=log10(aval)+1 else ipow=log10(aval) endif rnormal=val/(10.0d0**ipow) if(rnormal.eq.1)then ipow=ipow+1 endif !normalize, multiply by 10*idigits to an integer, and so on round=real(anint(val*10.d0**(idigits-ipow)))*10.d0**(ipow-idigits) return end C#======================================================================-------- subroutine expression(inlin0,outval,outlin0,ierr,ilen) ! @(#) expression: call juexpr() calculator and display messages ! ! evaluate a FORTRAN-like string expression and return a numeric ! value and it's character equivalent or a string value ! as appropriate implicit real*8 (a-h,o-z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#include "calcsize.h" integer ic,ixy,ixyc,iclen,icname,icbuf C CHECK NSA.F and kim.f to change this value there also parameter(ic=2345) ! number of variable names allowed parameter(ixy=3333) ! number of variables in X() and Y() array parameter(ixyc=50) ! number of variables in $X() and $(Y) array parameter(iclen=255) ! max length of expression or variable value as a string parameter(icname=20) ! max length of a variable name parameter(icbuf=2580) ! buffer for string as it is expanded C C no check on whether line expansion ever causes line length to C exceed allowable number of characters. C number of characters to prevent over-expansion would currently be C 20 digits per number max*(input number of characters/2+1). C input=80 --> 820 character buffer C input=256 ==> 2580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC character*(iclen) event, inlin0*(*) ,outlin0*(*), line*(iclen) character outlin*20 real*8 rvalue integer julen external julen intrinsic len save rvalue data rvalue/0.0/ ! copy inlin0 to line and find position of last non-blank character ! in the string line(:)=inlin0(:len(inlin0)) ! if the line is blank set imax to 1, else set it to the ! least of the length of the input string or (iclen) ! NOTE: not checking if input expression is longer than (iclen) characters!! imax=max(min(len(line),len(inlin0)),1) ilen=julen(line(1:imax)) C if(ilen.eq.0)then ! command was totally blank ierr=-1 call jun(4,'*expression* warning===> blank expression') goto 999 elseif(line(:1).eq.'#')then ! line was a comment goto 999 endif ierr=0 ! evaluate the expression call juexpr(line(:ilen),outlin,event,rvalue,ierr) if(ierr.eq.-1)then ! trapped error, display error message call jun(4,'*expression* error===>') !call pdec(line(:ilen)) ! echo input string as is and in ASCII decimal call jun(4,event) ! display error message else if(ierr.eq.1)then ! general message, display message call jun(4,'*expression* message===>') call jun(4,event) else if(ierr.eq.0)then ! numeric output outlin0=outlin else if(ierr.eq.2)then ! string output outlin0=event ! assumes outlin is long enough to return the string into ilen=int(rvalue) ! in special mode where a string is returned, rvalue is the length of the string else call jun(4,'*expression* warning===> unexpected ierr value') endif 999 continue outval=rvalue ! return normal sized real value return end C#======================================================================-------- real*8 function rnum0(inline) C @(#) resolve a calculator string into a real number (return 0 on errors) C the special string '*' returns -99999.0 implicit real*8 (a-h,o-z) character*(*) inline,cdum20*20 if(inline.eq.' ')then rnum1=0.0 elseif(inline.eq.'*')then rnum1=-99999.0 else iend=len(inline) call expression(inline(:iend),rnum1,cdum20,ierr,ilen) if(ierr.ne.0)then rnum1=0.0 endif endif rnum0=rnum1 return end C#======================================================================-------- subroutine juni(icode,string,ival) C@(#) append integer to string and call jun() character*(*) string parameter(iclen=255) character*(iclen) temp1 C external julen integer julen C ! temp1 is only (iclen) characters imax=min(iclen-10,len(string)) C ! ANSI FORTRAN77 does not allow null strings, but it is a common ! extension and F90 does so check in F77-compatible way Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc-------- if(imax.ge.1)then ! write integer into string write(temp1,'(a,i10)')string(:imax),ival else write(temp1,'(i10)')ival endif Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc-------- call jun(icode,temp1(1:max(1,julen(temp1(1:imax+10))))) Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc-------- return end C#======================================================================-------- subroutine junr(icode,string,value) C@(#) append real to string and call jun() parameter(iclen=255) character*(*) string character*(iclen) temp1 imax=min(iclen-20-1,len(string)) if(imax.ge.1)then write(temp1,'(a,1x,g20.13)')string(:imax),value else write(temp1,'(g20.13)')value endif call jun(icode,temp1) return end C=======================================================================--------