00001
00002 c
00003 c Copyright (c) 1986,1987,1988,1989,1990,1991,1992,1993,
00004 c by Steve McMillan, Drexel University, Philadelphia, PA.
00005 c
00006 c All rights reserved.
00007 c
00008 c Redistribution and use in source and binary forms are permitted
00009 c provided that the above copyright notice and this paragraph are
00010 c duplicated in all such forms and that any documentation,
00011 c advertising materials, and other materials related to such
00012 c distribution and use acknowledge that the software was developed
00013 c by the author named above.
00014 c
00015 c THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
00016 c IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
00017 c WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
00018 c
00019
00020 subroutine sarith(input,istart,nin,arr,nmax,narr,register,
00021 & iprompt,*)
00022 save
00023 c
00024 c Perform scalar arithmetic (on arrays).
00025 c
00026 character*(*) input
00027 dimension arr(nmax,3),narr(3)
00028 c
00029 character*1 c2
00030 dimension iarg(3)
00031 c
00032 if (nin.le.istart) go to 1001
00033 c2 = input(2:2)
00034 c
00035 ibl=1
00036 narg=0
00037 do 450 i=istart,nin
00038 if (input(i:i).eq.' '.or.input(i:i).eq.',') then
00039 ibl=1
00040 else
00041 if (ibl.eq.1) then
00042 narg=narg+1
00043 if (narg.ne.2) then
00044 call decode(input(i:i),iarg(narg),*1001)
00045 else
00046 read(input(i:nin),*,err=1001,end=1001)s
00047 end if
00048 if (narg.eq.3) go to 451
00049 ibl=0
00050 end if
00051 end if
00052 450 continue
00053 c
00054 if (narg.lt.1) then
00055 go to 1001
00056 else if (narg.eq.1) then
00057 s = register
00058 end if
00059 c
00060 if (narg.le.2) iarg(3)=iarg(1)
00061 c
00062 451 n = narr(iarg(1))
00063 c
00064 if (n.le.0) return
00065 c
00066 narr(iarg(3)) = n
00067 c
00068 if (c2.eq.'+') then
00069 do 460 i=1,n
00070 460 arr(i,iarg(3))=arr(i,iarg(1))+s
00071 else if (c2.eq.'-') then
00072 do 470 i=1,n
00073 470 arr(i,iarg(3))=arr(i,iarg(1))-s
00074 else if (c2.eq.'*') then
00075 do 480 i=1,n
00076 480 arr(i,iarg(3))=arr(i,iarg(1))*s
00077 else if (c2.eq.'/') then
00078 if (s.eq.0.)go to 1001
00079 s=1./s
00080 do 490 i=1,n
00081 490 arr(i,iarg(3))=arr(i,iarg(1))*s
00082 else if (c2.eq.'^') then
00083 do 500 i=1,n
00084 500 if (arr(i,iarg(1)).gt.0.) arr(i,iarg(3))=arr(i,iarg(1))**s
00085 else if (c2.eq.'=') then
00086 do 510 i=1,n
00087 510 arr(i,iarg(3))=s
00088 else
00089 go to 1001
00090 end if
00091 c
00092 return
00093 1001 return 1
00094 c
00095 end
