unit UnRowMul ; { to multiply two rows result to rowtre } interface uses UnTypVar ; { for TAmpDer type } procedure AmpFactor ( c : Extended ; var a : TAmpDer ); // UnTypVar procedure AmplMults ( a , b : TAmpDer ; var c : TAmpDer ) ; // UnTypVar procedure NextTerMem ( x : TRowVar ; { to find similar if it exists } var me : Word ; var ro : TRowPtr ) ; procedure ToMultRow ( ua , ub : TRowVar ) ; { simple records } { some terms in array row^ may has nullo amplitudes } procedure ForAmpNul ( var mec : word ; { number of terms } var row : TRowPtr ) ; { in this dynamic array } procedure MultForRow ( am : Extended ) ; { am * rowone * rowtwo = rowtre } implementation uses Windows , { function GetTickCount } UnRowIni , { for recnul nullo variable } UnRowLow ; { for procedure LowerTre } procedure AmpFactor ( c : Extended ; var a : TAmpDer ); // UnTypVar var // to multiply amplitudes with derivations by factor n : Byte ; begin for n:=1 to maxder do a[n]:=c*a[n]; // with the factor c end; procedure AmplMults ( a , b : TAmpDer ; var c : TAmpDer ) ; // UnTypVar begin c[1]:=a[1]*b[1]; // only amplitudes end; function BooMaxPower ( ma , mb : TDimSel ) : Boolean ; { UnTypVar } var m : Byte ; begin m:=ma[6]+mb[6]+ma[7]+mb[7]+2*(ma[8]+mb[8]); { for the giant planet } if m > maxsum { variable maxsum from UnTypVar } then BooMaxPower:=False { sum of powers is too large } else BooMaxPower:=True; { it is normal sum of powers } end; { to sum power for each parameter } procedure PowerParm ( a , b : TRowVar ; var c : TRowVar ) ; var // to analyse power of variables i : Byte ; { simple count } begin for i:=1 to numsel do // for each parameter numsel from UnTypVar c.mec[i]:=a.mec[i]+b.mec[i]; // sum of power for current parameter end; function BooCompare ( x , e : TRowVar ) : Boolean ; var j : Byte ; b : Boolean ; begin b:= ( x.fcs = e.fcs ) ; { to compare characters for functions 'C' or 'S'} j:=0; while ( b and ( j < numsel ) ) do begin j:=j+1; b:= ( x.mec[j] = e.mec[j] ) ; { the powers of variables } end; j:=0; while ( b and ( j < maxarg ) ) do begin j:=j+1; b:= ( x.mar[j] = e.mar[j] ) ; { the arguments of variables } end; BooCompare:=b; { true if it is similar term or false if it is not } end; procedure TheNextTerm ( x : TRowVar ) ; { to find similar if it exists } var n : Byte ; m : Word ; b : Boolean ; e : TRowVar ; { current record for compare } begin { to find similar terms for current term in array rowtre^[mectre] } b:=False; m:=0; { nullo } while ( ( not b ) and ( m < mectre ) ) do begin m:=m+1; { to try the next term } e:=rowtre^[m]; { current record for compare } b:=BooCompare(x,e); end; if b { there is similar term } then { to sum only amplitudes } for n:=1 to maxder do rowtre^[m].amp[n]:=rowtre^[m].amp[n]+x.amp[n] else { there is no similar term in current array } begin { it is our new term in result array } if mectre = maxarr then Exit ; { too many terms } mectre:=mectre+1; rowtre^[mectre]:=x; end; end; { to add new record to any temporary arrays of TRowPtr and to find similar term if it exists } procedure NextTerMem ( x : TRowVar ; { to find similar if it exists } var me : Word ; var ro : TRowPtr ) ; var n : Byte ; m : Word ; b : Boolean ; e : TRowVar ; { current record for compare } begin { to find similar terms for current term in array rowtre^[mectre] } b:=False; m:=0; { nullo } while ( ( not b ) and ( m < me ) ) do begin m:=m+1; { to try the next term } e:=ro^[m]; { current record for compare } b:=BooCompare(x,e); { function UnRowMul } end; if b { there is similar term } then { to sum only amplitudes } for n:=1 to maxder do ro^[m].amp[n]:=ro^[m].amp[n]+x.amp[n] else { there is no similar term in current array } begin { it is our new term in result array } if me = maxarr then Exit ; { too many terms } me:=me+1; ro^[me]:=x; end; end; procedure ToPositiveA ( var x : TRowVar ) ; var i,j : Byte ; begin { to positive for the first nonnullo argument } for j:=1 to maxarg do begin if x.mar[j] > 0 then Exit ; { well the argument is positive } if x.mar[j] < 0 { the argument may be negative } then begin for i:=j to maxarg do { to positive for the current argument } x.mar[i]:=-x.mar[i]; if x.fcs = 'S' { for sinus function minus for amplitude } then AmpFactor(-1.0,x.amp); // minus for amplitude Exit ; { well the argument is positive } end; end; end; procedure ForSinOrCos ( x , y : TRowVar ; var a , b : TAmpDer ; var c : Char ) ; begin { 2*cos(x)*sin(y) =-sin(x-y) + sin(x+y) } b:=a; { amlpitude may be minus } if x.fcs = y.fcs { 2*cos(x)*cos(y) = cos(x-y) + cos(x+y) } then { cos*cos or sin*sin } begin { +cos(x-y) } c:='C'; { cosinus function as result } if x.fcs = 'S' { sin*sin case } then { 2*sin(x)*sin(y) = cos(x-y) - cos(x+y) } AmpFactor(-1.0,b); { -cos(x+y) } end { 2*sin(x)*cos(y) = sin(x-y) + sin(x+y) } else { sin*cos or cos*sin } begin { +sin(x+y) } c:='S'; { sinus function as result } if x.fcs = 'C' { cos*sin case } then { 2*cos(x)*sin(y) =-sin(x-y) + sin(x+y) } AmpFactor(-1.0,a); { -sin(x-y) } end; end; procedure ToMultRow ( ua , ub : TRowVar ) ; { simple records } var { 2*cos(x)*cos(y) = cos(x-y) + cos(x+y) } j : Byte ; { 2*sin(x)*sin(y) = cos(x-y) - cos(x+y) } b : TAmpDer ; { 2*sin(x)*cos(y) = sin(x-y) + sin(x+y) } x : TRowVar ; { 2*cos(x)*sin(y) =-sin(x-y) + sin(x+y) } begin { from two record may be two new records } AmplMults(ua.amp,ub.amp,x.amp); { to multiply amplitudes } if ( ( not BooMaxPower(ua.mec,ub.mec) ) or ( Abs(x.amp[1]) < 1.0e-10 ) ) then { sum of powers may be too large } Exit ; { may be nearly nullo term } AmpFactor(0.5,x.amp); { factor 0.5 for amplitude } PowerParm(ua,ub,x); { to sum all powers } ForSinOrCos(ua,ub,x.amp,b,x.fcs); { amplitude function indentify } for j:=1 to maxarg do x.mar[j]:=ua.mar[j]-ub.mar[j]; { for the first all arguments minus } ToPositiveA(x); TheNextTerm(x); { for minus in argument x-y } x.amp:=b; { for plus in argument x+y } for j:=1 to maxarg do x.mar[j]:=ua.mar[j]+ub.mar[j]; { for the second all arguments plus } ToPositiveA(x); TheNextTerm(x); end; { some terms in array row^ may has nullo amplitudes } procedure ForAmpNul ( var mec : word ; { number of terms } var row : TRowPtr ) ; { in this dynamic array } var { before and after } k : longint ; { count } m : longint ; { number of terms } g : TRowPtr ; { dynamic array untypvar type } begin GetMem(g,SizeOf(TRowDim)); { memory for array temporary } m:=0; { initial nullo terms } for k:=1 to mec do { for all number of terms before } if ( Abs(row^[k].amp[1]) > 1.0e-10 ) then begin m:=m+1; { non nullo term } g^[m]:=row^[k]; { to memory } end; if m < mec then { to copy from } begin { temporary array to rowtre^ } mec:=m; { this is number of terms after } for k:=1 to m do { for all records } row^[k]:=g^[k]; { to copy to keep } end; FreeMem(g,SizeOf(TRowDim)); { without temporary memory } end; procedure MultForRow ( am : Extended ) ; { am * rowone * rowtwo = rowtre } var { with the factor am } ma,mb : Word ; ua,ub : TRowVar ; { type from UnTypVar } la,lb : longint ; { for TickCount in millisecond } begin la:=GetTickCount ; { Windows moment in millisecond } for ma:=1 to mecone do begin ua:=rowone^[ma]; { current record from the first row } AmpFactor(am,ua.amp); for mb:=1 to mectwo do begin ub:=rowtwo^[mb]; { current record from the second row } ToMultRow(ua,ub); { result to rowtre with the count mectre } lb:=GetTickCount ; { unit Windows } if ( (lb-la) > 10000 ) then begin writeln(ma:10,mb:10,mectre:10,' .',mecone:10,mectwo:10); la:=lb; end; end; end; ForAmpNul(mectre,rowtre); { in current array rowtre may be nullo amp } end; end.