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 varith(input,istart,nin,arr,nmax,narr,iprompt,*)
00021 save
00022 c
00023 c Vector arithmetic.
00024 c
00025 character*(*) input
00026 dimension arr(nmax,3),narr(3)
00027 c
00028 character*1 c2
00029 dimension iarg(3)
00030 c
00031 if (nin.lt.istart) go to 1001
00032 c2 = input(2:2)
00033 c
00034 ibl=1
00035 narg=0
00036 c
00037 c Decode the argument list
00038 c
00039 do 70 i=istart,nin
00040 if (input(i:i).eq.' '.or.input(i:i).eq.',') then
00041 ibl=1
00042 else
00043 if (ibl.eq.1) then
00044 narg=narg+1
00045 if (narg.ge.2.and.c2.eq.'c') then
00046 call readrq(input(i:nin),2,
00047 & x1,x2,dum,dum,*69)
00048 go to 71
00049 c
00050 69 call readrq(input(i:nin),1,
00051 & x1,dum,dum,dum,*1001)
00052 x2=1.e30
00053 go to 71
00054 c
00055 else if (narg.ge.2.and.c2.eq.'o') then
00056 call readiq(input(i:nin),1,
00057 & noff,idum,idum,idum,*1001)
00058 go to 71
00059 c
00060 else if (narg.ge.2.and.c2.eq.'!') then
00061 call readiq(input(i:nin),1,
00062 & nskip,idum,idum,idum,*1001)
00063 if (nskip.lt.0) go to 1001
00064 go to 71
00065 else
00066 call decode(input(i:i),iarg(narg),*1001)
00067 if (narg.eq.3)go to 71
00068 end if
00069 ibl=0
00070 end if
00071 end if
00072 70 continue
00073 71 continue
00074 c
00075 if (narg.lt.2) then
00076 if (c2.ne.'i'
00077 1 .and.c2.ne.'a'
00078 2 .and.c2.ne.'c'
00079 3 .and.c2.ne.'o'
00080 4 .and.c2.ne.'\\') go to 1001
00081 else if (narg.eq.2) then
00082 iarg(3)=iarg(2)
00083 end if
00084 c
00085 n = narr(iarg(1))
00086 c
00087 c Apply the appropriate operation:
00088 c
00089 if (c2.eq.'+') then
00090 do 75 i=1,n
00091 75 arr(i,iarg(3))=arr(i,iarg(1)) + arr(i,iarg(2))
00092 narr(iarg(3)) = n
00093 else if (c2.eq.'-') then
00094 do 76 i=1,n
00095 76 arr(i,iarg(3))=arr(i,iarg(1)) - arr(i,iarg(2))
00096 narr(iarg(3)) = n
00097 else if (c2.eq.'*') then
00098 do 77 i=1,n
00099 77 arr(i,iarg(3))=arr(i,iarg(1)) * arr(i,iarg(2))
00100 narr(iarg(3)) = n
00101 else if (c2.eq.'/') then
00102 nerr=0
00103 do 78 i=1,n
00104 s=arr(i,iarg(2))
00105 if (s.eq.0.) then
00106 nerr=nerr+1
00107 else
00108 arr(i,iarg(3))=arr(i,iarg(1))/s
00109 end if
00110 78 continue
00111 narr(iarg(3)) = n
00112 if (nerr.gt.0) then
00113 call devoff
00114 if (iprompt.eq.1) write(6,'(i5,'' error(s)'')')nerr
00115 end if
00116 else if (c2.eq.'^') then
00117 nerr=0
00118 do 79 i=1,n
00119 if (arr(i,iarg(1)).le.0.) then
00120 nerr=nerr+1
00121 else
00122 arr(i,iarg(3))=arr(i,iarg(1))**arr(i,iarg(2))
00123 end if
00124 79 continue
00125 narr(iarg(3)) = n
00126 if (nerr.gt.0) then
00127 call devoff
00128 if (iprompt.eq.1) write(6,'(i5,'' error(s)'')')nerr
00129 end if
00130 else if (c2.eq.'i') then
00131 do 80 i=1,n
00132 80 if (arr(i,iarg(1)).ne.0.) arr(i,iarg(1))=1./arr(i,iarg(1))
00133 else if (c2.eq.'a') then
00134 do 81 i=1,n
00135 81 arr(i,iarg(1))=abs(arr(i,iarg(1)))
00136 else if (c2.eq.'c') then
00137 do 82 i=1,n
00138 82 arr(i,iarg(1))=min(x2,max(x1,arr(i,iarg(1))))
00139 else if (c2.eq.'=') then
00140 do 83 i=1,n
00141 83 arr(i,iarg(2))=arr(i,iarg(1))
00142 narr(iarg(2)) = n
00143 else if (c2.eq.'o') then
00144 if (noff.gt.0) then
00145 if (narr(iarg(1))+noff.gt.nmax) then
00146 if (iprompt.eq.1) write(6,*)'Array overflow'
00147 go to 1001
00148 else
00149 do 84 i=narr(iarg(1)),1,-1
00150 84 arr(i+noff,iarg(1)) = arr(i,iarg(1))
00151 do 85 i=1,noff
00152 85 arr(i,iarg(1)) = 0.
00153 end if
00154 else if (noff.lt.0) then
00155 do 86 i=1-noff,narr(iarg(1))
00156 86 arr(i+noff,iarg(1)) = arr(i,iarg(1))
00157 end if
00158 narr(iarg(1)) = narr(iarg(1)) + noff
00159 else if (c2.eq.'\\') then
00160 do 87 i=1,n/2
00161 temp = arr(i,iarg(1))
00162 arr(i,iarg(1)) = arr(n+1-i,iarg(1))
00163 arr(n+1-i,iarg(1)) = temp
00164 87 continue
00165 else if (c2.eq.'>') then
00166 do 88 i=1,n
00167 88 arr(i,iarg(3))=max(arr(i,iarg(1)), arr(i,iarg(2)))
00168 narr(iarg(3)) = n
00169 else if (c2.eq.'<') then
00170 do 89 i=1,n
00171 89 arr(i,iarg(3))=max(arr(i,iarg(1)), arr(i,iarg(2)))
00172 narr(iarg(3)) = n
00173 else if (c2.eq.'!') then
00174 if (nskip.gt.0) then
00175 n1 = 0
00176 do 90 i=1,n,nskip+1
00177 n1 = n1 + 1
00178 arr(n1,iarg(1)) = arr(i,iarg(1))
00179 90 continue
00180 narr(iarg(1)) = n1
00181 end if
00182 else
00183 go to 1001
00184 end if
00185 c
00186 return
00187 1001 return 1
00188 c
00189 end
00190
00191
00192 subroutine negate(n,a)
00193 save
00194 c
00195 c Replace array a by -a.
00196 c
00197 dimension a(1)
00198 c
00199 do 10 i=1,n
00200 10 a(i) = -a(i)
00201 c
00202 end
