!********************************************** !* COMPLEX CALCULATOR * !* ------------------------------------------ * !* Ref.: "Mathématiques en Turbo-Pascal By * !* M. Ducamp and A. Reverchon (vol 2), * !* Eyrolles, Paris, 1988" [BIBLI 05]. * !* ------------------------------------------ * !* SAMPLE RUN: * !* * !* Calculate: sqrt((5-i)*Ln(3+2i)) * !* * !* Enter operation: xa Real part: 5 * !* Imaginary part: -1 * !* Enter operation: sto0 * !* Enter operation: xa Real part: 3 * !* Imaginary part: 2 * !* Enter operation: sto1 * !* Enter operation: ln * !* Enter operation: sto2 * !* Enter operation: '*' * !* Enter operation: sto3 * !* Enter operation: sqr * !* Enter operation: sto4 * !* * !* (result is: 2.6640487 + i 0.3110939) * !* * !* F90 version by J-P Moreau, Paris. * !* (www.jpmoreau.fr) * !********************************************** ! The screen should look like that: ! COMPLEX NUMBERS CALCULATOR IN INVERSE POLISH NOTATION ! ------------------------------------------------------------------- ! ALGEBRAIC FORM POLAR FORM ! T 0.0000000 ! Z 0.0000000 ! Y 0.0000000 ! X 2.6640487 + i 0.3110939 2.6821511 EXP+i 0.1162483 ! ------------------------------------------------------------------- ! M0 5.0000000 - i 1.0000000 5.0990195 EXP-i 0.1973956 ! M1 3.0000000 + i 2.0000000 3.6055513 EXP+i 0.5880026 ! M2 1.2824747 + i 0.5880026 1.4108467 EXP+i 0.4298922 ! M3 7.0003760 + i 1.6575383 7.1939348 EXP+i 0.2324967 ! M4 2.6640487 + i 0.3110939 2.6821511 EXP+i 0.1162483 ! M5 0.0000000 ! M6 0.0000000 ! M7 0.0000000 ! M8 0.0000000 ! M9 0.0000000 ! ------------------------------------------------------------------- ! + - * / 1/X X^2 SQR ^ EXP LN ! SIN COS TAN SH CH TH ARCSIN ARCCOS ARCTAN ARGCH ! ARGSH ARGTH XA XP CLX CLS CLM STOx RCLx Q ! ------------------------------------------------------------------- ! Enter operation: ! ! ! Command explanations: ! XA: enter a complex number x+iy, by giving x and y. ! XP: enter a complex number r*exp(i*t), by giving r and t. ! CLX: stack register X is set to 0 and stack is shifted downwards. ! This allows to correct an input mistake. ! CLS: All four stack registers are set to 0. ! STOx: x from 0 to 9. stores X content in memory number x. ! RCLx: x from 0 to 9, recalls content of memory x in X register. ! The stack is previously shifted upwards. ! CLM: All ten memories are set to 0. ! Q: Quit program. !---------------------------------------------------------------------- PROGRAM Complex_calculator USE COMPLEX1 parameter(NBSTACK=4, NBMEM=9) !Zcomplex type is defined in module comlex1.f90 type(Zcomplex) stack(1:NBSTACK), memory(0:NBMEM) character*6 Cmd !name of command do i=1,4 call Empty(stack(i)) !set stack to zero end do do i=0,9 call Empty(memory(i)) !set memory to zero end do call InitDisplay(stack,memory) !initial display do while(Cmd.ne.'q') !main loop write(*,100,advance='no') read *, Cmd !enter command if (Cmd.ne.'q') then call Compute(Cmd,stack,memory) !execute command} call InitDisplay(stack,memory) !display result endif end do stop 100 format(' Enter operation: ') END !of main program Subroutine DownStack(n,stack) Use COMPLEX1 parameter(NBSTACK=4) Type(Zcomplex) stack(NBSTACK) if (n<1) n=1 do i=n, NBSTACK-1 call Zcopy(stack(i+1),stack(i)) end do call Empty(stack(NBSTACK)) return End Subroutine UpStack(stack) Use COMPLEX1 parameter(NBSTACK=4) Type(Zcomplex) stack(NBSTACK) do i=NBSTACK, 2, -1 call Zcopy(stack(i-1),stack(i)) end do call Empty(stack(1)) return End Subroutine InitDisplay(stack,memory) Use COMPLEX1 Type(Zcomplex) stack(1:4),memory(0:9) print *,' COMPLEX NUMBERS CALCULATOR IN INVERSE POLISH NOTATION ' print *,'--------------------------------------------------------------' print *,' ALGEBRAIC FORM POLAR FORM ' write(*,100,advance='no'); call DisplayNumber(stack(4)) write(*,101,advance='no'); call DisplayNumber(stack(3)) write(*,102,advance='no'); call DisplayNumber(stack(2)) write(*,103,advance='no'); call DisplayNumber(stack(1)) print *,'--------------------------------------------------------------' write(*,105,advance='no'); call DisplayNumber(memory(0)) write(*,106,advance='no'); call DisplayNumber(memory(1)) write(*,107,advance='no'); call DisplayNumber(memory(2)) write(*,108,advance='no'); call DisplayNumber(memory(3)) write(*,109,advance='no'); call DisplayNumber(memory(4)) write(*,110,advance='no'); call DisplayNumber(memory(5)) write(*,111,advance='no'); call DisplayNumber(memory(6)) write(*,112,advance='no'); call DisplayNumber(memory(7)) write(*,113,advance='no'); call DisplayNumber(memory(8)) write(*,114,advance='no'); call DisplayNumber(memory(9)) print *,'--------------------------------------------------------------' print *,' + - * / 1/X X^2 SQR ^ EXP LN ' print *,' SIN COS TAN SH CH TH ARCSIN ARCCOS ARCTAN ARGCH' print *,' ARGSH ARGTH XA XP CLX CLS CLM STOx RCLx Q ' print *,'--------------------------------------------------------------' return 100 format(' T') 101 format(' Z') 102 format(' Y') 103 format(' X') 105 format(' M0') 106 format(' M1') 107 format(' M2') 108 format(' M3') 109 format(' M4') 110 format(' M5') 111 format(' M6') 112 format(' M7') 113 format(' M8') 114 format(' M9') End subroutine num(c,i) character*1 c if (c.eq.'0') i=0 if (c.eq.'1') i=1 if (c.eq.'2') i=2 if (c.eq.'3') i=3 if (c.eq.'4') i=4 if (c.eq.'5') i=5 if (c.eq.'6') i=6 if (c.eq.'7') i=7 if (c.eq.'8') i=8 if (c.eq.'9') i=9 return end !execute command calling elementary routines of module complex1 Subroutine Compute(Cmd,stack,memory) Use COMPLEX1 Type(Zcomplex) stack(1:4),memory(0:9) character*6 Cmd if (Cmd(1:2).eq.'xa') then call UpStack(stack) write(*,10,advance='no') read *, stack(1)%x, stack(1)%y call RectPol(stack(1)) return endif if (Cmd(1:2).eq.'xp') then call UpStack(stack) write(*,20,advance='no') read *, stack(1)%r, stack(1)%t call PolRect(stack(1)) return endif if (Cmd(1:3).eq.'clx') then call DownStack(1,stack) return endif if (Cmd(1:3).eq.'cls') then do i=1,4 call Empty(stack(i)) end do return endif if (Cmd(1:3).eq.'clm') then do i=0,9 call Empty(memory(i)) end do return endif if(Cmd(1:3).eq.'sto') then call num(Cmd(4:4),i) if(i>-1.and.i<10) call Zcopy(stack(1),memory(i)) return endif if(Cmd(1:3).eq.'rcl') then call num(Cmd(4:4),i) if(i>-1.and.i<10) then call UpStack(stack) call Zcopy(memory(i),stack(1)) endif return endif if (Cmd.eq.'+') then if (ZSum(stack(2),stack(1),stack(1)).eq.1) then call DownStack(2,stack) return endif endif if (Cmd.eq.'-') then if (ZMinus(stack(2),stack(1),stack(1)).eq.1) then call DownStack(2,stack) return endif endif if (Cmd(1:1).eq.'*') then if (ZMult(stack(2),stack(1),stack(1)).eq.1) then call DownStack(2,stack) return endif endif if (Cmd(1:1).eq.'/') then if (ZDiv(stack(2),stack(1),stack(1)).eq.1) then call DownStack(2,stack) return endif endif if (Cmd(1:1).eq.'^') then if (ZPower(stack(2),stack(1),stack(1)).eq.1) then call DownStack(2,stack) return endif endif if (Cmd(1:3).eq.'exp') then if (ZExp(stack(1),stack(1)).eq.1) return endif if (Cmd(1:2).eq.'ln') then if (ZLn(stack(1),stack(1)).eq.1) return endif if (Cmd(1:3).eq.'1/x') then if (ZInv(stack(1),stack(1)).eq.1) return endif if (Cmd(1:3).eq.'x^2') then if (ZSqr(stack(1),stack(1)).eq.1) return endif if (Cmd(1:3).eq.'sqr') then if (ZSqrt(stack(1),stack(1)).eq.1) return endif if (Cmd(1:3).eq.'sin') then if (ZSin(stack(1),stack(1)).eq.1) return endif if (Cmd(1:3).eq.'cos') then if (ZCos(stack(1),stack(1)).eq.1) return endif if (Cmd(1:3).eq.'tan') then if (ZTan(stack(1),stack(1)).eq.1) return endif if (Cmd(1:2).eq.'sh') then if (ZSh(stack(1),stack(1)).eq.1) return endif if (Cmd(1:2).eq.'ch') then if (ZCh(stack(1),stack(1)).eq.1) return endif if (Cmd(1:2).eq.'th') then if (ZTh(stack(1),stack(1)).eq.1) return endif if (Cmd(1:6).eq.'arcsin') then if (ZArcsin(stack(1),stack(1)).eq.1) return endif if (Cmd(1:6).eq.'arccos') then if (ZArccos(stack(1),stack(1)).eq.1) return endif if (Cmd(1:6).eq.'arctan') then if (ZArctan(stack(1),stack(1)).eq.1) return endif if (Cmd(1:5).eq.'argsh') then if (ZArgsh(stack(1),stack(1)).eq.1) return endif if (Cmd(1:5).eq.'argch') then if (ZArgch(stack(1),stack(1)).eq.1) return endif if (Cmd(1:5).eq.'argth') then if (ZArgth(stack(1),stack(1)).eq.1) return endif return 10 format(' Real part, imaginary part: ') 20 format(' Modulus, argument: ') End !of compute() ! end of file ucomplex.f90