Evaluate_r4fp32 Function

private function Evaluate_r4fp32(parser, x) result(f)

Arguments

TypeIntentOptionalAttributesName
class(EquationParser) :: parser
real(kind=real32) :: x(:,:,:,:,:)

Return Value real(kind=real32)(lbound(x,1):ubound(x,1),lbound(x,2):ubound(x,2),lbound(x,3):ubound(x,3),lbound(x,4):ubound(x,4))


Contents

Source Code


Source Code

  function Evaluate_r4fp32(parser,x) result(f)
    class(EquationParser) :: parser
    real(real32) :: x(:,:,:,:,:)
    real(real32) :: f(lbound(x,1):ubound(x,1), &
                      lbound(x,2):ubound(x,2), &
                      lbound(x,3):ubound(x,3), &
                      lbound(x,4):ubound(x,4))
    ! Local
    integer :: i,k
    type(Token) :: t
    type(r4fp32Stack) :: stack
    real(real32) :: vnumber
    real(real32),allocatable :: v(:,:,:,:)
    real(real32),allocatable :: a(:,:,:,:)
    real(real32),allocatable :: b(:,:,:,:)
    real(real32),allocatable :: c(:,:,:,:)
    integer :: l1,l2,l3,l4,u1,u2,u3,u4

    l1 = lbound(x,1)
    l2 = lbound(x,2)
    l3 = lbound(x,3)
    l4 = lbound(x,3)
    u1 = ubound(x,1)
    u2 = ubound(x,2)
    u3 = ubound(x,3)
    u4 = ubound(x,4)
    allocate(v(l1:u1,l2:u2,l3:u3,l4:u4), &
             a(l1:u1,l2:u2,l3:u3,l4:u4), &
             b(l1:u1,l2:u2,l3:u3,l4:u4), &
             c(l1:u1,l2:u2,l3:u3,l4:u4))

    call stack%Construct(Stack_Length,v)

    do k = 1,parser%postfix%top_index

      t = parser%postfix%tokens(k)%Copy()

      select case(t%tokenType)

      case(Number_Token)
        if(t%tokenString == 'pi' .or. t%tokenString == 'PI') then
          v = pi_real32
        else
          read(t%tokenString,*) vnumber
          v = vnumber
        endif

        call stack%Push(v)

      case(Variable_Token)

        do i = 1,parser%nIndepVars
          if(trim(t%tokenString) == parser%indepVars(i)%value) then
            call stack%Push(x(:,:,:,:,i))
            exit
          endif
        enddo

      case(Operator_Token)

        call stack%Pop(a)
        call stack%Pop(b)

        select case(trim(t%tokenString))

        case('+')

          c = a+b

        case('-')

          c = b-a

        case('*')

          c = a*b

        case('/')

          c = b/a

        case('^')

          c = b**a
        case default

        endselect

        call stack%Push(c)

      case(Function_Token)

        call stack%Pop(a)

        b = Functions(t%tokenIndex)%invoke(a)

        call stack%Push(b)

      case(Monadic_Token)

        if(trim(t%tokenString) == '-') then

          call stack%Pop(a)
          a = -a
          call stack%Push(a)

        endif

      case default

      endselect

    enddo

    call stack%Pop(a)
    f = a

    deallocate(v,a,b,c)

  endfunction Evaluate_r4fp32