LCOV - code coverage report
Current view: | top level - hemco/HEMCO/src/Core - interpreter.F90 (source / functions) |  |  | Hit | Total | Coverage
Test: | coverage.info |  | Lines: | 0 | 789 | 0.0 %
Date: | 2024-12-17 17:57:11 |  | Functions: | 0 | 16 | 0.0 %

              Line data    Source code
           1             : !------------------------------------------------------------------------------
           2             : !                   Harmonized Emissions Component (HEMCO)                    !
           3             : !------------------------------------------------------------------------------
           4             : !BOP
           5             : !
           6             : ! !MODULE: interpreter
           7             : !
           8             : ! !DESCRIPTION: Module interpreter is a third-party module that parses and
           9             : ! evaluates mathematical functions, e.g. 2*sin(MM).
          10             : ! downloaded on May 12, 2017 from http://zeus.df.ufcg.edu.br/labfit/functionparser.htm
          11             : !\\
          12             : !\\
          13             : !
          14             : ! !REVISION HISTORY:
          15             : !  12 May 2017 - C. Keller   - Modified for use in HEMCO: use hp instead of realkind.
          16             : !  See https://github.com/geoschem/hemco for complete history
          17             : !EOP
          18             : !------------------------------------------------------------------------------
          19             :
          20             : !module functp_precision
          21             : ! !Precision:
          22             : ! !All real variables defaulted to double precision
          23             : ! integer, parameter  :: realkind = selected_real_kind(p=13,r=200)
          24             : !end module functp_precision
          25             :
          26             : module interpreter
          27             :  !
          28             :  ! This module interprets the function, builds it to be evaluated
          29             :  ! next
          30             :  !
          31             :  !use functp_precision
          32             :   use hco_error_mod
          33             :
          34             :   implicit none
          35             :
          36             :   public :: init
          37             :   public :: evaluate
          38             :   public :: destroyfunc
          39             :
          40             :   character(len=10),   dimension(:), allocatable, private :: varnames
          41             :   character(len=255),  dimension(:), allocatable, private :: stokens
          42             :   integer,             dimension(:), allocatable, private :: operations
          43             :   integer,                                        private :: n
          44             :   integer,                                        private :: ntokens = 0
          45             :   character,           dimension(:), pointer,     private :: opaddsub   !Operador
          46             :   integer,                                        private :: isaddsub = 1
          47             :   character,           dimension(:), pointer,     private :: opmuldiv   !Operador
          48             :   integer,                                        private :: ismuldiv = 1
          49             :   character(len=255),                             private :: toke
          50             :   integer,                                        private :: itoke = 1
          51             :   integer,                                        private :: ioperations = 1
          52             :   integer,                                        private :: numberk = 1
          53             :   real(kind=hp),       dimension(:), pointer,     private :: pdata
          54             :   real(kind=hp),       dimension(:), pointer,     private :: number
          55             :   character(len=5),                               public  :: statusflagparser = 'ok'
          56             :
          57             :   ! Need this to convert degrees to radians, because SIND, COSD, etc
          58             :   ! functions are not supported in GNU Fortran (bmy, 5/16/17)
          59             :   real(kind=hp),       parameter,                 private :: PI_180 = 3.14159265358979323e+0
          60             :
          61             : contains
          62             :
          63           0 :   subroutine init (func, variablenames, statusflag)
          64             :     !
          65             :     !  This subroutine shifts all characters of the function
          66             :     !  expression to lowercase and converts exponents signals ** to ^
          67             :     !
          68             :     character(len=*),                intent(inout)  :: func
          69             :     character(len=10), dimension(:), intent(inout)  :: variablenames
          70             :     character(len=26)                               :: lower = 'abcdefghijklmnopqrstuvwxyz'
          71             :     character(len=26)                               :: upper = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
          72             :     integer                                         :: i, k, funclen
          73             :     character(len=5),  intent(out)                  :: statusflag
          74             :
          75             :     !detects errors
          76           0 :     call identifica(func)
          77           0 :     call convert_b(func)
          78             :
          79             :
          80             :     !Shift all characters to lowercase and converts ** to ^
          81           0 :     funclen = len_trim(func)
          82           0 :     do i = 1, funclen
          83           0 :        k = index(upper,func(i:i))
          84           0 :        if ( k /= 0) then
          85           0 :           func(i:i) = lower(k:k)
          86             :        end if
          87           0 :        k = index(func,'**')
          88           0 :        if (k /= 0) then
          89           0 :           func = func(:k-1) // '^' // func(k+2:)
          90             :        end if
          91             :     end do
          92           0 :     call blanks(func)
          93           0 :     call recog_variables (func, variablenames)
          94           0 :     statusflag = statusflagparser
          95             :
          96             :
          97           0 :   end subroutine init
          98             :
          99             :  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         100             :
         101           0 :   subroutine recog_variables (func, variablenames)
         102             :     !
         103             :     ! This subroutine recognizes the variables and set their values
         104             :     !
         105             :     character(len=10), dimension(:), intent(in)     :: variablenames
         106             :     character(len=*), intent(inout)     :: func
         107             :
         108           0 :     n = size(variablenames)
         109           0 :     allocate(varnames(n))
         110           0 :     varnames = variablenames
         111           0 :     call tokens_analyzer (func)
         112             :
         113           0 :   end subroutine recog_variables
         114             :
         115             :  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         116             :
         117           0 :   subroutine tokens_analyzer (func)
         118             :     !
         119             :     ! This subroutine scans the func string storing its basic elements
         120             :     !
         121             :     character(len=*), intent(in)     :: func
         122             :     character(len=11)        :: numbers = '.0123456789'
         123             :     character(len=26)        :: chars = 'abcdefghijklmnopqrstuvwxyz'
         124             :     character(len=7)        :: operators = '+-*/^()'
         125             :     integer           :: k = 1, i = 1
         126             :     integer           :: irightbrackets = 1, ileftbrackets = 1
         127             :     logical           :: status = .true.
         128             :
         129           0 :     k = 1
         130           0 :     i = 1
         131           0 :     irightbrackets = 1
         132           0 :     ileftbrackets = 1
         133           0 :     ntokens = 0
         134           0 :     status = .true.
         135             :
         136           0 :     do while (k <= len_trim(func))
         137             :        !It's a variable, or function  name
         138           0 :        if (index(chars,func(k:k)) /= 0) then
         139           0 :           status = .true.
         140           0 :           do while (status)
         141           0 :              if (index(operators, func(k+1:k+1)) == 0 .and. func(k+1:k+1) /= ' ') then
         142           0 :                 k = k + 1
         143             :              else
         144           0 :                 status = .false.
         145           0 :                 k = k + 1
         146             :              end if
         147             :           end do
         148           0 :           ntokens = ntokens + 1
         149             :
         150             :           !It's a number
         151           0 :        else if (index(numbers,func(k:k)) /= 0) then
         152           0 :           status = .true.
         153           0 :           do while (status)
         154           0 :              if ((index(operators, func(k+1:k+1)) == 0 .and. func(k+1:k+1) /= ' ') .or. func(k+1:k+1) == 'e' .or. func(k+1:k+1) == 'd') then
         155           0 :                 k = k + 1
         156             :              else
         157           0 :                 if(func(k:k) == 'e' .or. func(k:k) == 'd') then
         158           0 :                    k = k + 1
         159             :                 else
         160           0 :                    status = .false.
         161           0 :                    k = k + 1
         162             :                 end if
         163             :              end if
         164             :           end do
         165           0 :           ntokens = ntokens + 1
         166             :
         167             :           !It's an operator or delimitator
         168             :        else
         169           0 :           k = k + 1
         170           0 :           ntokens = ntokens + 1
         171             :        end if
         172             :     end do
         173             :
         174           0 :     allocate(stokens(ntokens))
         175             :
         176           0 :     k = 1
         177             :     i = 1
         178             :
         179           0 :     do while (k <= len_trim(func))
         180             :        !It's a variable, or function  name
         181           0 :        if (index(chars,func(k:k)) /= 0) then
         182           0 :           stokens(i) = func(k:k)
         183           0 :           status = .true.
         184           0 :           do while (status)
         185           0 :              if (index(operators, func(k+1:k+1)) == 0 .and. func(k+1:k+1) /= ' ') then
         186           0 :                 stokens(i) = trim(stokens(i)) // func(k+1:k+1)
         187           0 :                 k = k + 1
         188             :              else
         189           0 :                 status = .false.
         190           0 :                 k = k + 1
         191           0 :                 i = i + 1
         192             :              end if
         193             :           end do
         194             :
         195             :           !It's a number
         196           0 :        else if (index(numbers,func(k:k)) /= 0) then
         197           0 :           stokens(i) = func(k:k)
         198           0 :           status = .true.
         199           0 :           do while (status)
         200           0 :              if ((index(operators, func(k+1:k+1)) == 0 .and. func(k+1:k+1) /= ' ') .or. func(k+1:k+1) == 'e' .or. func(k+1:k+1) == 'd') then
         201           0 :                 stokens(i) = trim(stokens(i)) // func(k+1:k+1)
         202           0 :                 k = k + 1
         203             :              else
         204           0 :                 if(func(k:k) == 'e' .or. func(k:k) == 'd') then
         205           0 :                    stokens(i) = trim(stokens(i)) // func(k+1:k+1)
         206           0 :                    k = k + 1
         207             :                 else
         208           0 :                    status = .false.
         209           0 :                    i = i + 1
         210           0 :                    k = k + 1
         211             :                 end if
         212             :              end if
         213             :           end do
         214             :
         215             :           !It's an operator or delimitator
         216             :        else
         217           0 :           stokens(i) = func(k:k)
         218           0 :           if(stokens(i) == '(')then
         219           0 :              irightbrackets = irightbrackets + 1
         220           0 :           else if(stokens(i) == ')') then
         221           0 :              ileftbrackets = ileftbrackets + 1
         222             :           end if
         223           0 :           i = i + 1
         224           0 :           k = k + 1
         225             :        end if
         226             :     end do
         227             :
         228           0 :     if (irightbrackets /= ileftbrackets) then
         229           0 :        statusflagparser = 'error'
         230           0 :        return
         231             :     end if
         232             :
         233           0 :     itoke = 1
         234           0 :     isaddsub = 1
         235           0 :     ismuldiv = 1
         236           0 :     ioperations = 1
         237           0 :     numberk = 1
         238           0 :     toke = stokens(itoke)
         239           0 :     allocate(opaddsub(2))
         240           0 :     allocate(opmuldiv(2))
         241           0 :     allocate(number(ntokens))
         242           0 :     allocate(pdata(ntokens))
         243           0 :     allocate(operations(ntokens))
         244             :
         245           0 :     call add_sub()
         246           0 :     ioperations = ioperations - 1
         247             :
         248             :   end subroutine tokens_analyzer
         249             :
         250             :   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         251             :   !The following subroutines call themselves recursively
         252             :   !to build the expression to be parsed based on an algorithm
         253             :   !called Recursive Descendent Parsing
         254             :   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         255             :
         256           0 :   subroutine add_sub ()
         257             :     !
         258             :     ! Enter description here
         259             :     !
         260             :
         261           0 :     call mul_div ()
         262             :
         263           0 :     do while (trim(toke) == '+' .or. trim(toke) == '-')
         264           0 :        opaddsub(isaddsub) = trim(toke)
         265           0 :        isaddsub = isaddsub + 1
         266           0 :        itoke = itoke + 1
         267           0 :        toke = stokens(itoke)
         268           0 :        call mul_div()
         269             :
         270           0 :        selectcase(opaddsub(isaddsub-1))
         271             :        case('+')
         272           0 :           isaddsub = isaddsub - 1
         273           0 :           operations(ioperations) = 3
         274           0 :           ioperations = ioperations + 1
         275             :
         276             :        case('-')
         277           0 :           isaddsub = isaddsub - 1
         278           0 :           operations(ioperations) = 4
         279           0 :           ioperations = ioperations + 1
         280             :        end select
         281             :     end do
         282             :
         283           0 :   end subroutine add_sub
         284             :
         285           0 :   subroutine mul_div ()
         286             :     !
         287             :     ! Enter description here
         288             :     !
         289             :
         290           0 :     call unary()
         291             :
         292           0 :     do while (trim(toke) == '*' .or. trim(toke) == '/')
         293           0 :        opmuldiv(ismuldiv) = trim(toke)
         294           0 :        ismuldiv = ismuldiv + 1
         295           0 :        itoke = itoke + 1
         296           0 :        toke = stokens(itoke)
         297           0 :        call unary()
         298             :
         299           0 :        selectcase(opmuldiv(ismuldiv-1))
         300             :        case('*')
         301           0 :           ismuldiv = ismuldiv - 1
         302           0 :           operations(ioperations) = 5
         303           0 :           ioperations = ioperations + 1
         304             :        case('/')
         305           0 :           ismuldiv = ismuldiv - 1
         306           0 :           operations(ioperations) = 6
         307           0 :           ioperations = ioperations + 1
         308             :        end select
         309             :     end do
         310             :
         311           0 :   end subroutine mul_div
         312             :
         313           0 :   subroutine unary()
         314             :     !
         315             :     ! Enter description here
         316             :     !
         317             :
         318           0 :     if (trim(toke) == '-') then
         319           0 :        itoke = itoke + 1
         320           0 :        toke = stokens(itoke)
         321           0 :        call pow()
         322           0 :        operations(ioperations) = 2
         323           0 :        ioperations = ioperations + 1
         324           0 :     else if (trim(toke) == '+') then
         325           0 :        itoke = itoke + 1
         326           0 :        toke = stokens(itoke)
         327           0 :        call pow()
         328             :     else
         329           0 :        call pow()
         330             :     end if
         331             :
         332           0 :   end subroutine unary
         333             :
         334           0 :   subroutine pow ()
         335             :     !
         336             :     ! Enter description here
         337             :     !
         338             :
         339           0 :     call functions()
         340             :
         341           0 :     if (trim(toke) == '^') then
         342           0 :        itoke = itoke + 1
         343           0 :        toke = stokens(itoke)
         344           0 :        call functions()
         345           0 :        operations(ioperations) = 7
         346           0 :        ioperations = ioperations + 1
         347             :     end if
         348             :
         349           0 :   end subroutine pow
         350             :
         351           0 :   subroutine functions ()
         352             :     !
         353             :     ! Enter description here
         354             :     !
         355           0 :     if (trim(toke) == 'sin') then
         356           0 :        itoke = itoke + 1
         357           0 :        toke = stokens(itoke)
         358           0 :        call brackets()
         359           0 :        operations(ioperations) = 8
         360           0 :        ioperations = ioperations + 1
         361             :
         362           0 :     else if(trim(toke) == 'cos') then
         363           0 :        itoke = itoke + 1
         364           0 :        toke = stokens(itoke)
         365           0 :        call brackets()
         366           0 :        operations(ioperations) = 9
         367           0 :        ioperations = ioperations + 1
         368             :
         369           0 :     else if(trim(toke) == 'tan') then
         370           0 :        itoke = itoke + 1
         371           0 :        toke = stokens(itoke)
         372           0 :        call brackets()
         373           0 :        operations(ioperations) = 10
         374           0 :        ioperations = ioperations + 1
         375             :
         376           0 :     else if(trim(toke) == 'asin') then
         377           0 :        itoke = itoke + 1
         378           0 :        toke = stokens(itoke)
         379           0 :        call brackets()
         380           0 :        operations(ioperations) = 11
         381           0 :        ioperations = ioperations + 1
         382             :
         383           0 :     else if(trim(toke) == 'acos') then
         384           0 :        itoke = itoke + 1
         385           0 :        toke = stokens(itoke)
         386           0 :        call brackets()
         387           0 :        operations(ioperations) = 12
         388           0 :        ioperations = ioperations + 1
         389             :
         390           0 :     else if(trim(toke) == 'atan') then
         391           0 :        itoke = itoke + 1
         392           0 :        toke = stokens(itoke)
         393           0 :        call brackets()
         394           0 :        operations(ioperations) = 13
         395           0 :        ioperations = ioperations + 1
         396             :
         397           0 :     else if(trim(toke) == 'sinh') then
         398           0 :        itoke = itoke + 1
         399           0 :        toke = stokens(itoke)
         400           0 :        call brackets()
         401           0 :        operations(ioperations) = 14
         402           0 :        ioperations = ioperations + 1
         403             :
         404           0 :     else if(trim(toke) == 'cosh') then
         405           0 :        itoke = itoke + 1
         406           0 :        toke = stokens(itoke)
         407           0 :        call brackets()
         408           0 :        operations(ioperations) = 15
         409           0 :        ioperations = ioperations + 1
         410             :
         411           0 :     else if(trim(toke) == 'tanh') then
         412           0 :        itoke = itoke + 1
         413           0 :        toke = stokens(itoke)
         414           0 :        call brackets()
         415           0 :        operations(ioperations) = 16
         416           0 :        ioperations = ioperations + 1
         417             :
         418           0 :     else if(trim(toke) == 'sind') then
         419           0 :        itoke = itoke + 1
         420           0 :        toke = stokens(itoke)
         421           0 :        call brackets()
         422           0 :        operations(ioperations) = 17
         423           0 :        ioperations = ioperations + 1
         424             :
         425           0 :     else if(trim(toke) == 'cosd') then
         426           0 :        itoke = itoke + 1
         427           0 :        toke = stokens(itoke)
         428           0 :        call brackets()
         429           0 :        operations(ioperations) = 18
         430           0 :        ioperations = ioperations + 1
         431             :
         432           0 :     else if(trim(toke) == 'tand') then
         433           0 :        itoke = itoke + 1
         434           0 :        toke = stokens(itoke)
         435           0 :        call brackets()
         436           0 :        operations(ioperations) = 19
         437           0 :        ioperations = ioperations + 1
         438             :
         439           0 :     else if (trim(toke) == 'log') then
         440           0 :        itoke = itoke + 1
         441           0 :        toke = stokens(itoke)
         442           0 :        call brackets()
         443           0 :        operations(ioperations) = 20
         444           0 :        ioperations = ioperations + 1
         445             :
         446           0 :     else if (trim(toke) == 'log10') then
         447           0 :        itoke = itoke + 1
         448           0 :        toke = stokens(itoke)
         449           0 :        call brackets()
         450           0 :        operations(ioperations) = 21
         451           0 :        ioperations = ioperations + 1
         452             :
         453           0 :     else if (trim(toke) == 'nint') then
         454           0 :        itoke = itoke + 1
         455           0 :        toke = stokens(itoke)
         456           0 :        call brackets()
         457           0 :        operations(ioperations) = 22
         458           0 :        ioperations = ioperations + 1
         459             :
         460           0 :     else if (trim(toke) == 'anint') then
         461           0 :        itoke = itoke + 1
         462           0 :        toke = stokens(itoke)
         463           0 :        call brackets()
         464           0 :        operations(ioperations) = 23
         465           0 :        ioperations = ioperations + 1
         466             :
         467           0 :     else if (trim(toke) == 'aint') then
         468           0 :        itoke = itoke + 1
         469           0 :        toke = stokens(itoke)
         470           0 :        call brackets()
         471           0 :        operations(ioperations) = 24
         472           0 :        ioperations = ioperations + 1
         473             :
         474           0 :     else if (trim(toke) == 'exp') then
         475           0 :        itoke = itoke + 1
         476           0 :        toke = stokens(itoke)
         477           0 :        call brackets()
         478           0 :        operations(ioperations) = 25
         479           0 :        ioperations = ioperations + 1
         480             :
         481           0 :     else if (trim(toke) == 'sqrt') then
         482           0 :        itoke = itoke + 1
         483           0 :        toke = stokens(itoke)
         484           0 :        call brackets()
         485           0 :        operations(ioperations) = 26
         486           0 :        ioperations = ioperations + 1
         487             :
         488           0 :     else if (trim(toke) == 'abs') then
         489           0 :        itoke = itoke + 1
         490           0 :        toke = stokens(itoke)
         491           0 :        call brackets()
         492           0 :        operations(ioperations) = 27
         493           0 :        ioperations = ioperations + 1
         494             :
         495           0 :     else if (trim(toke) == 'floor') then
         496           0 :        itoke = itoke + 1
         497           0 :        toke = stokens(itoke)
         498           0 :        call brackets()
         499           0 :        operations(ioperations) = 28
         500           0 :        ioperations = ioperations + 1
         501             :
         502             :     else
         503           0 :        call brackets()
         504             :
         505             :     end if
         506             :
         507           0 :   end subroutine functions
         508             :
         509           0 :   subroutine brackets()
         510             :     !
         511             :     ! Enter description here
         512             :     !
         513           0 :     if (trim(toke) == '(') then
         514           0 :        itoke = itoke + 1
         515           0 :        toke = stokens(itoke)
         516           0 :        call add_sub()
         517           0 :        if (trim(toke) /= ')') then
         518           0 :           statusflagparser =  'error'
         519           0 :           return
         520             :        end if
         521           0 :        if (itoke < ntokens) then
         522           0 :           itoke = itoke + 1
         523           0 :           toke = stokens(itoke)
         524             :        end if
         525           0 :        if (trim(toke) == '(') then
         526           0 :           statusflagparser =  'error'
         527           0 :           return
         528             :        end if
         529             :     else
         530           0 :        call recog_vars ()
         531             :     end if
         532             :
         533             :   end subroutine brackets
         534             :
         535           0 :   subroutine recog_vars ()
         536             :     !
         537             :     ! Enter description here
         538             :     !
         539             :
         540             :     integer          :: i
         541             :     integer          :: ierror
         542             :     character(len=7) :: operators = '+-*/^()'
         543             :
         544             :     !Expression has an error
         545           0 :     if (index(operators, trim(toke)) /= 0) then
         546           0 :        statusflagparser = 'error'
         547           0 :        return
         548             :     end if
         549             :
         550           0 :     do i = 1, n
         551             :        !It's a variable
         552           0 :        if (trim(toke) == varnames(i)) then
         553           0 :           operations(ioperations) = 28+i
         554           0 :           ioperations = ioperations + 1
         555           0 :           if (itoke < ntokens) then
         556           0 :              itoke = itoke + 1
         557           0 :              toke = stokens(itoke)
         558             :           end if
         559           0 :           return
         560             :        end if
         561             :     end do
         562             :
         563             :     !It's a number
         564           0 :     toke = trim(toke)
         565           0 :     read(toke, *, iostat = ierror) number(numberk)
         566           0 :     if (ierror /= 0) then
         567           0 :        statusflagparser = 'error'
         568           0 :        return
         569             :     else
         570           0 :        operations(ioperations) = 1
         571           0 :        ioperations = ioperations + 1
         572           0 :        if (itoke < ntokens) then
         573           0 :           itoke = itoke + 1
         574           0 :           toke = stokens(itoke)
         575             :        end if
         576           0 :        numberk = numberk + 1
         577             :     end if
         578             :
         579             :   end subroutine recog_vars
         580             :
         581             :
         582           0 :   function evaluate (vars) result (answer)
         583             :
         584             :     !
         585             :     ! This function will evaluate the expression supplied
         586             :     !
         587             :
         588             :     real(kind = hp), dimension(:), intent(in)  :: vars
         589             :     real(kind = hp)                            :: answer
         590             :     integer                                    :: st = 0
         591             :     integer                                    :: dt = 1
         592             :     integer                                    :: i
         593             :
         594           0 :     st = 0
         595           0 :     dt = 1
         596             :
         597           0 :     do i = 1, ioperations
         598           0 :        select case(operations(i))
         599             :        case (1)
         600           0 :           st = st + 1
         601           0 :           pdata(st) = number(dt)
         602           0 :           dt = dt + 1
         603             :        case (2)
         604           0 :           pdata(st) = - pdata(st)
         605             :        case (3)
         606           0 :           pdata(st-1) = pdata(st-1) + pdata(st)
         607           0 :           st = st - 1
         608             :        case (4)
         609           0 :           pdata(st-1) = pdata(st-1) - pdata(st)
         610           0 :           st = st - 1
         611             :        case (5)
         612           0 :           pdata(st-1) = pdata(st-1) * pdata(st)
         613           0 :           st = st - 1
         614             :        case (6)
         615           0 :           pdata(st-1) = pdata(st-1) / pdata(st)
         616           0 :           st = st - 1
         617             :        case (7)
         618           0 :           pdata(st-1) = pdata(st-1) ** pdata(st)
         619           0 :           st = st - 1
         620             :        case (8)
         621           0 :           pdata(st) = sin(pdata(st))
         622             :        case (9)
         623           0 :           pdata(st) = cos(pdata(st))
         624             :        case (10)
         625           0 :           pdata(st) = tan(pdata(st))
         626             :        case (11)
         627           0 :           pdata(st) = asin(pdata(st))
         628             :        case (12)
         629           0 :           pdata(st) = acos(pdata(st))
         630             :        case (13)
         631           0 :           pdata(st) = atan(pdata(st))
         632             :        case (14)
         633           0 :           pdata(st) = sinh(pdata(st))
         634             :        case (15)
         635           0 :           pdata(st) = cosh(pdata(st))
         636             :        case (16)
         637           0 :           pdata(st) = tanh(pdata(st))
         638             :        case (17)
         639           0 :           pdata(st) = sin(pdata(st)*PI_180)  ! Equivalent to SIND (bmy, 5/16/17)
         640             :        case (18)
         641           0 :           pdata(st) = cos(pdata(st)*PI_180)  ! Equivalent to COSD (bmy, 5/16/17)
         642             :        case (19)
         643           0 :           pdata(st) = tan(pdata(st)*PI_180)  ! Equivalent to TAND (bmy, 5/16/17)
         644             :        case (20)
         645           0 :           pdata(st) = log(pdata(st))
         646             :        case (21)
         647           0 :           pdata(st) = log10(pdata(st))
         648             :        case (22)
         649           0 :           pdata(st) = nint(pdata(st))
         650             :        case (23)
         651           0 :           pdata(st) = anint(pdata(st))
         652             :        case (24)
         653           0 :           pdata(st) = aint(pdata(st))
         654             :        case (25)
         655           0 :           pdata(st) = exp(pdata(st))
         656             :        case (26)
         657           0 :           pdata(st) = sqrt(pdata(st))
         658             :        case (27)
         659           0 :           pdata(st) = abs(pdata(st))
         660             :        case (28)
         661           0 :           pdata(st) = floor(pdata(st))
         662             :        case default
         663           0 :           st = st + 1
         664           0 :           pdata(st) = vars(operations(i)-28)
         665             :        end select
         666             :     end do
         667             :
         668           0 :     answer = pdata(1)
         669             :
         670           0 :   end function evaluate
         671             :
         672             :
         673           0 :   function evaluate_detalhes (vars) result (answer)
         674             :     !
         675             :     ! This function will evaluate the expression supplied
         676             :     !
         677             :
         678             :     real(kind = hp), dimension(:), intent(in)  :: vars
         679             :     real(kind = hp)                            :: answer
         680             :     integer                                    :: st = 0
         681             :     integer                                    :: dt = 1
         682             :     integer                                    :: i
         683             :
         684           0 :     st = 0
         685           0 :     dt = 1
         686             :
         687           0 :     do i = 1, ioperations
         688           0 :        select case(operations(i))
         689             :
         690             :        case (1)
         691           0 :           st = st + 1
         692           0 :           pdata(st) = number(dt)
         693           0 :           dt = dt + 1
         694             :
         695             :        case (2)
         696           0 :           pdata(st) = - pdata(st)
         697             :
         698             :        case (3)
         699           0 :           pdata(st-1) = pdata(st-1) + pdata(st)
         700           0 :           st = st - 1
         701             :
         702             :        case (4)
         703           0 :           pdata(st-1) = pdata(st-1) - pdata(st)
         704           0 :           st = st - 1
         705             :
         706             :        case (5)
         707           0 :           pdata(st-1) = pdata(st-1) * pdata(st)
         708           0 :           st = st - 1
         709             :
         710             :        case (6)
         711           0 :           if(abs(pdata(st)) < 1.0e-30) then
         712           0 :              answer = -7.093987e-35
         713             :              return
         714             :           end if
         715           0 :           pdata(st-1) = pdata(st-1) / pdata(st)
         716           0 :           st = st - 1
         717             :
         718             :        case (7)
         719           0 :           if(pdata(st-1) < 0.0 .AND. (pdata(st)-int(pdata(st))) /= 0.0) then
         720           0 :              answer = -7.093987e-35
         721             :              return
         722             :           end if
         723           0 :           if(pdata(st)*log(abs(pdata(st-1)+1.0E-15)) > 65.0) then
         724           0 :              answer = -7.093987e-35
         725             :              return
         726             :           end if
         727           0 :           pdata(st-1) = pdata(st-1) ** pdata(st)
         728           0 :           st = st - 1
         729             :
         730             :        case (8)
         731           0 :           pdata(st) = sin(pdata(st))
         732             :
         733             :        case (9)
         734           0 :           pdata(st) = cos(pdata(st))
         735             :
         736             :        case (10)
         737           0 :           if((abs(pdata(st)) > 89.99*3.141593/180. .and. abs(pdata(st)) < 90.01*3.141593/180)&
         738           0 :                .or. (abs(pdata(st)) > 269.99*3.141593/180. .and. abs(pdata(st)) < 270.01*3.141593/180)) then
         739           0 :              answer = -7.093987e-35
         740             :              return
         741             :           end if
         742           0 :           pdata(st) = tan(pdata(st))
         743             :
         744             :        case (11)
         745           0 :           if(abs(pdata(st)) > 1.0) then
         746           0 :              answer = -7.093987e-35
         747             :              return
         748             :           end if
         749           0 :           pdata(st) = asin(pdata(st))
         750             :
         751             :        case (12)
         752           0 :           if(abs(pdata(st)) > 1.0) then
         753           0 :              answer = -7.093987e-35
         754             :              return
         755             :           end if
         756           0 :           pdata(st) = acos(pdata(st))
         757             :
         758             :        case (13)
         759           0 :           if(abs(pdata(st)) > 1.0e+10) then
         760           0 :              answer = -7.093987e-35
         761             :              return
         762             :           end if
         763           0 :           pdata(st) = atan(pdata(st))
         764             :
         765             :        case (14)
         766           0 :           if(pdata(st) > 60) then
         767           0 :              answer = -7.093987e-35
         768             :              return
         769             :           end if
         770           0 :           pdata(st) = sinh(pdata(st))
         771             :
         772             :        case (15)
         773           0 :           if(pdata(st) > 60) then
         774           0 :              answer = -7.093987e-35
         775             :              return
         776             :           end if
         777           0 :           pdata(st) = cosh(pdata(st))
         778             :
         779             :        case (16)
         780           0 :           pdata(st) = tanh(pdata(st))
         781             :
         782             :        case (17)
         783           0 :           pdata(st) = sin(pdata(st)*PI_180)  ! Equivalent to SIND (bmy, 5/16/17)
         784             :
         785             :        case (18)
         786           0 :           pdata(st) = cos(pdata(st)*PI_180)  ! Equivalent to COSD (bmy, 5/16/17)
         787             :
         788             :        case (19)
         789           0 :           pdata(st) = tan(pdata(st)*PI_180)  ! Equivalent to TAND (bmy, 5/16/17)
         790             :
         791             :        case (20)
         792           0 :           if(pdata(st) <= 1.0e-15) then
         793           0 :              answer = -7.093987e-35
         794             :              return
         795             :           end if
         796           0 :           pdata(st) = log(pdata(st))
         797             :
         798             :        case (21)
         799           0 :           if(pdata(st) <= 1.0e-15) then
         800           0 :              answer = -7.093987e-35
         801             :              return
         802             :           end if
         803           0 :           pdata(st) = log10(pdata(st))
         804             :
         805             :        case (22)
         806           0 :           pdata(st) = nint(pdata(st))
         807             :
         808             :        case (23)
         809           0 :           pdata(st) = anint(pdata(st))
         810             :
         811             :        case (24)
         812           0 :           pdata(st) = aint(pdata(st))
         813             :
         814             :        case (25)
         815           0 :           if(pdata(st) > 55) then
         816           0 :              answer = -7.093987e-35
         817             :              return
         818             :           end if
         819           0 :           pdata(st) = exp(pdata(st))
         820             :
         821             :        case (26)
         822           0 :           if(pdata(st) < 0) then
         823           0 :              answer = -7.093987e-35
         824             :              return
         825             :           end if
         826           0 :           pdata(st) = sqrt(pdata(st))
         827             :
         828             :        case (27)
         829           0 :           pdata(st) = abs(pdata(st))
         830             :
         831             :        case (28)
         832           0 :           pdata(st) = floor(pdata(st))
         833             :
         834             :        case default
         835           0 :           st = st + 1
         836           0 :           pdata(st) = vars(operations(i)-28)
         837             :
         838             :        end select
         839             :
         840           0 :        if(abs(pdata(st)) > 1.0d+60) then
         841           0 :           answer = -7.093987e-35
         842             :           return
         843             :        end if
         844             :
         845             :     end do
         846             :
         847           0 :     answer = pdata(1)
         848             :
         849           0 :   end function evaluate_detalhes
         850             :
         851             :
         852           0 :   subroutine destroyfunc()
         853             :
         854           0 :     if (allocated(stokens)) then
         855           0 :        deallocate(stokens)
         856             :     end if
         857           0 :     if (associated(opaddsub)) then
         858           0 :        deallocate(opaddsub)
         859             :     end if
         860           0 :     if (associated(opmuldiv)) then
         861           0 :        deallocate(opmuldiv)
         862             :     end if
         863           0 :     if (associated(number)) then
         864           0 :        deallocate(number)
         865             :     end if
         866           0 :     if (associated(pdata)) then
         867           0 :        deallocate(pdata)
         868             :     end if
         869           0 :     if (allocated(operations)) then
         870           0 :        deallocate(operations)
         871             :     end if
         872           0 :     if (allocated(varnames)) then
         873           0 :        deallocate(varnames)
         874             :     end if
         875           0 :     statusflagparser = 'ok'
         876             :
         877           0 :   end subroutine destroyfunc
         878             :
         879             :  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         880             :
         881           0 :   recursive subroutine blanks(func)
         882             :     !
         883             :     ! This subroutine removes unnecessary blank spaces
         884             :     !
         885             :     character(len=*), intent(inout)  :: func
         886             :     integer        :: k
         887             :
         888           0 :     func = adjustl(func)
         889           0 :     k = index(trim(func), ' ')
         890           0 :     if (k /= 0) then
         891           0 :        func = func(:k-1) // func(k+1:)
         892           0 :        call blanks(func)
         893             :     end if
         894             :
         895           0 :   end subroutine blanks
         896             :
         897             : end module interpreter
         898             :
         899             :
         900             :
         901             :
         902             :
         903           0 : subroutine identifica(funcao)
         904             :   character (255) funcao
         905             :   character (36) variav
         906             :
         907           0 :   variav = '0123456789abcdefghijklmnopqrstuvwxyz'
         908             :
         909           0 :   nchar = len(trim(funcao))
         910             :
         911           0 :   do i = 1,nchar
         912           0 :      if(funcao(i:i) == 'A')funcao(i:i) = 'a'
         913           0 :      if(funcao(i:i) == 'B')funcao(i:i) = 'b'
         914           0 :      if(funcao(i:i) == 'C')funcao(i:i) = 'c'
         915           0 :      if(funcao(i:i) == 'D')funcao(i:i) = 'd'
         916           0 :      if(funcao(i:i) == 'E')funcao(i:i) = 'e'
         917           0 :      if(funcao(i:i) == 'F')funcao(i:i) = 'f'
         918           0 :      if(funcao(i:i) == 'G')funcao(i:i) = 'g'
         919           0 :      if(funcao(i:i) == 'H')funcao(i:i) = 'h'
         920           0 :      if(funcao(i:i) == 'I')funcao(i:i) = 'i'
         921           0 :      if(funcao(i:i) == 'J')funcao(i:i) = 'j'
         922           0 :      if(funcao(i:i) == 'K')funcao(i:i) = 'k'
         923           0 :      if(funcao(i:i) == 'L')funcao(i:i) = 'l'
         924           0 :      if(funcao(i:i) == 'M')funcao(i:i) = 'm'
         925           0 :      if(funcao(i:i) == 'N')funcao(i:i) = 'n'
         926           0 :      if(funcao(i:i) == 'O')funcao(i:i) = 'o'
         927           0 :      if(funcao(i:i) == 'P')funcao(i:i) = 'p'
         928           0 :      if(funcao(i:i) == 'Q')funcao(i:i) = 'q'
         929           0 :      if(funcao(i:i) == 'R')funcao(i:i) = 'r'
         930           0 :      if(funcao(i:i) == 'S')funcao(i:i) = 's'
         931           0 :      if(funcao(i:i) == 'T')funcao(i:i) = 't'
         932           0 :      if(funcao(i:i) == 'U')funcao(i:i) = 'u'
         933           0 :      if(funcao(i:i) == 'V')funcao(i:i) = 'v'
         934           0 :      if(funcao(i:i) == 'W')funcao(i:i) = 'w'
         935           0 :      if(funcao(i:i) == 'X')funcao(i:i) = 'x'
         936           0 :      if(funcao(i:i) == 'Y')funcao(i:i) = 'y'
         937           0 :      if(funcao(i:i) == 'Z')funcao(i:i) = 'z'
         938             :   end do
         939             :
         940             :
         941             :
         942           0 :   if(funcao(nchar:nchar) == '-' .or. funcao(nchar:nchar) == '+' .or. funcao(nchar:nchar) == '/' .or. funcao(nchar:nchar) == '*') then
         943           0 :      funcao = 'erro'
         944           0 :      return
         945             :   end if
         946             :
         947           0 :   if(funcao(1:1) == '*' .or. funcao(1:1) == '/') then
         948           0 :      funcao = 'erro'
         949           0 :      return
         950             :   end if
         951             :
         952           0 :   do i = 1, nchar-1
         953           0 :      if(funcao(i:i+1) == '--' .or. funcao(i:i+1) == '-+' .or. funcao(i:i+1) == '-/' .or. funcao(i:i+1) == '-*') funcao = 'erro'
         954           0 :      if(funcao(i:i+1) == '+-' .or. funcao(i:i+1) == '++' .or. funcao(i:i+1) == '+/' .or. funcao(i:i+1) == '+*') funcao = 'erro'
         955           0 :      if(funcao(i:i+1) == '*-' .or. funcao(i:i+1) == '*+' .or. funcao(i:i+1) == '*/') funcao = 'erro'
         956           0 :      if(funcao(i:i+1) == '/-' .or. funcao(i:i+1) == '/+' .or. funcao(i:i+1) == '//' .or. funcao(i:i+1) == '/*') funcao = 'erro'
         957             :   end do
         958           0 :   if(trim(funcao) == 'erro') return
         959             :
         960           0 :   do i = 1, nchar-1
         961           0 :      do j = 1, 36
         962           0 :         if(funcao(i:i+1) == ')'//variav(j:j)) funcao = 'erro'
         963             :      end do
         964             :   end do
         965           0 :   if(trim(funcao) == 'erro') return
         966             :
         967           0 :   do i = 1, nchar-1
         968           0 :      do j = 1, 36
         969           0 :         if(funcao(i:i) == '0' .or. funcao(i:i) == 'n' .or. funcao(i:i) == 's' .or. funcao(i:i) == 'h' .or. funcao(i:i) == 'd' .or. funcao(i:i) == 'g' .or. funcao(i:i) == 't' .or. funcao(i:i) == 'p' .or. funcao(i:i) == 'r') then
         970             :            !não testa, pode ser uma das funções definidas
         971             :         else
         972           0 :            if(funcao(i:i+1) == variav(j:j)//'(') funcao = 'erro'
         973             :         end if
         974             :      end do
         975             :   end do
         976           0 :   if(trim(funcao) == 'erro') return
         977             :
         978             :
         979           0 :   if(nchar >= 5) then
         980           0 :      do i = 1,nchar-4
         981             :
         982           0 :         if(funcao(i:i+4) == 'log10') then
         983           0 :            j = i+5
         984             : 19         continue
         985           0 :            if(j >= nchar) then
         986           0 :               funcao = 'erro'
         987           0 :               return
         988             :            end if
         989           0 :            if(funcao(j:j) == ' ') then
         990           0 :               j = j + 1
         991           0 :               goto 19
         992             :            end if
         993           0 :            if(funcao(j:j) /= '(') then
         994           0 :               funcao = 'erro'
         995           0 :               return
         996             :            end if
         997             :         end if
         998             :
         999           0 :         if(funcao(i:i+4) == 'anint') then
        1000           0 :            j = i+5
        1001             : 20         continue
        1002           0 :            if(j >= nchar) then
        1003           0 :               funcao = 'erro'
        1004           0 :               return
        1005             :            end if
        1006           0 :            if(funcao(j:j) == ' ') then
        1007           0 :               j = j + 1
        1008           0 :               goto 20
        1009             :            end if
        1010           0 :            if(funcao(j:j) /= '(') then
        1011           0 :               funcao = 'erro'
        1012           0 :               return
        1013             :            end if
        1014             :         end if
        1015             :
        1016           0 :         if(funcao(i:i+4) == 'floor') then
        1017           0 :            j = i+5
        1018             : 21         continue
        1019           0 :            if(j >= nchar) then
        1020           0 :               funcao = 'erro'
        1021           0 :               return
        1022             :            end if
        1023           0 :            if(funcao(j:j) == ' ') then
        1024           0 :               j = j + 1
        1025           0 :               goto 21
        1026             :            end if
        1027           0 :            if(funcao(j:j) /= '(') then
        1028           0 :               funcao = 'erro'
        1029           0 :               return
        1030             :            end if
        1031             :         end if
        1032             :
        1033             :      end do
        1034             :   end if
        1035             :
        1036             :
        1037             :
        1038             :
        1039           0 :   if(nchar >= 4) then
        1040           0 :      do i = 1,nchar-3
        1041             :
        1042           0 :         if(funcao(i:i+3) == 'asin') then
        1043           0 :            j = i+4
        1044             : 7          continue
        1045           0 :            if(j >= nchar) then
        1046           0 :               funcao = 'erro'
        1047           0 :               return
        1048             :            end if
        1049           0 :            if(funcao(j:j) == ' ') then
        1050           0 :               j = j + 1
        1051           0 :               goto 7
        1052             :            end if
        1053           0 :            if(funcao(j:j) /= '(') then
        1054           0 :               funcao = 'erro'
        1055           0 :               return
        1056             :            end if
        1057             :         end if
        1058             :
        1059           0 :         if(funcao(i:i+3) == 'acos') then
        1060           0 :            j = i+4
        1061             : 8          continue
        1062           0 :            if(j >= nchar) then
        1063           0 :               funcao = 'erro'
        1064           0 :               return
        1065             :            end if
        1066           0 :            if(funcao(j:j) == ' ') then
        1067           0 :               j = j + 1
        1068           0 :               goto 8
        1069             :            end if
        1070           0 :            if(funcao(j:j) /= '(') then
        1071           0 :               funcao = 'erro'
        1072           0 :               return
        1073             :            end if
        1074             :         end if
        1075             :
        1076           0 :         if(funcao(i:i+3) == 'atan') then
        1077           0 :            j = i+4
        1078             : 9          continue
        1079           0 :            if(j >= nchar) then
        1080           0 :               funcao = 'erro'
        1081           0 :               return
        1082             :            end if
        1083           0 :            if(funcao(j:j) == ' ') then
        1084           0 :               j = j + 1
        1085           0 :               goto 9
        1086             :            end if
        1087           0 :            if(funcao(j:j) /= '(') then
        1088           0 :               funcao = 'erro'
        1089           0 :               return
        1090             :            end if
        1091             :         end if
        1092             :
        1093           0 :         if(funcao(i:i+3) == 'sinh') then
        1094           0 :            j = i+4
        1095             : 10         continue
        1096           0 :            if(j >= nchar) then
        1097           0 :               funcao = 'erro'
        1098           0 :               return
        1099             :            end if
        1100           0 :            if(funcao(j:j) == ' ') then
        1101           0 :               j = j + 1
        1102           0 :               goto 10
        1103             :            end if
        1104           0 :            if(funcao(j:j) /= '(') then
        1105           0 :               funcao = 'erro'
        1106           0 :               return
        1107             :            end if
        1108             :         end if
        1109             :
        1110           0 :         if(funcao(i:i+3) == 'cosh') then
        1111           0 :            j = i+4
        1112             : 11         continue
        1113           0 :            if(j >= nchar) then
        1114           0 :               funcao = 'erro'
        1115           0 :               return
        1116             :            end if
        1117           0 :            if(funcao(j:j) == ' ') then
        1118           0 :               j = j + 1
        1119           0 :               goto 11
        1120             :            end if
        1121           0 :            if(funcao(j:j) /= '(') then
        1122           0 :               funcao = 'erro'
        1123           0 :               return
        1124             :            end if
        1125             :         end if
        1126             :
        1127           0 :         if(funcao(i:i+3) == 'tanh') then
        1128           0 :            j = i+4
        1129             : 12         continue
        1130           0 :            if(j >= nchar) then
        1131           0 :               funcao = 'erro'
        1132           0 :               return
        1133             :            end if
        1134           0 :            if(funcao(j:j) == ' ') then
        1135           0 :               j = j + 1
        1136           0 :               goto 12
        1137             :            end if
        1138           0 :            if(funcao(j:j) /= '(') then
        1139           0 :               funcao = 'erro'
        1140           0 :               return
        1141             :            end if
        1142             :         end if
        1143             :
        1144           0 :         if(funcao(i:i+3) == 'sind') then
        1145           0 :            j = i+4
        1146             : 13         continue
        1147           0 :            if(j >= nchar) then
        1148           0 :               funcao = 'erro'
        1149           0 :               return
        1150             :            end if
        1151           0 :            if(funcao(j:j) == ' ') then
        1152           0 :               j = j + 1
        1153           0 :               goto 13
        1154             :            end if
        1155           0 :            if(funcao(j:j) /= '(') then
        1156           0 :               funcao = 'erro'
        1157           0 :               return
        1158             :            end if
        1159             :         end if
        1160             :
        1161           0 :         if(funcao(i:i+3) == 'cosd') then
        1162           0 :            j = i+4
        1163             : 14         continue
        1164           0 :            if(j >= nchar) then
        1165           0 :               funcao = 'erro'
        1166           0 :               return
        1167             :            end if
        1168           0 :            if(funcao(j:j) == ' ') then
        1169           0 :               j = j + 1
        1170           0 :               goto 14
        1171             :            end if
        1172           0 :            if(funcao(j:j) /= '(') then
        1173           0 :               funcao = 'erro'
        1174           0 :               return
        1175             :            end if
        1176             :         end if
        1177             :
        1178           0 :         if(funcao(i:i+3) == 'tand') then
        1179           0 :            j = i+4
        1180             : 15         continue
        1181           0 :            if(j >= nchar) then
        1182           0 :               funcao = 'erro'
        1183           0 :               return
        1184             :            end if
        1185           0 :            if(funcao(j:j) == ' ') then
        1186           0 :               j = j + 1
        1187           0 :               goto 15
        1188             :            end if
        1189           0 :            if(funcao(j:j) /= '(') then
        1190           0 :               funcao = 'erro'
        1191           0 :               return
        1192             :            end if
        1193             :         end if
        1194             :
        1195           0 :         if(funcao(i:i+3) == 'nint') then
        1196           0 :            j = i+4
        1197             : 16         continue
        1198           0 :            if(j >= nchar) then
        1199           0 :               funcao = 'erro'
        1200           0 :               return
        1201             :            end if
        1202           0 :            if(funcao(j:j) == ' ') then
        1203           0 :               j = j + 1
        1204           0 :               goto 16
        1205             :            end if
        1206           0 :            if(funcao(j:j) /= '(') then
        1207           0 :               funcao = 'erro'
        1208           0 :               return
        1209             :            end if
        1210             :         end if
        1211             :
        1212           0 :         if(funcao(i:i+3) == 'aint') then
        1213           0 :            j = i+4
        1214             : 17         continue
        1215           0 :            if(j >= nchar) then
        1216           0 :               funcao = 'erro'
        1217           0 :               return
        1218             :            end if
        1219           0 :            if(funcao(j:j) == ' ') then
        1220           0 :               j = j + 1
        1221           0 :               goto 17
        1222             :            end if
        1223           0 :            if(funcao(j:j) /= '(') then
        1224           0 :               funcao = 'erro'
        1225           0 :               return
        1226             :            end if
        1227             :         end if
        1228             :
        1229           0 :         if(funcao(i:i+3) == 'sqrt') then
        1230           0 :            j = i+4
        1231             : 18         continue
        1232           0 :            if(j >= nchar) then
        1233           0 :               funcao = 'erro'
        1234           0 :               return
        1235             :            end if
        1236           0 :            if(funcao(j:j) == ' ') then
        1237           0 :               j = j + 1
        1238           0 :               goto 18
        1239             :            end if
        1240           0 :            if(funcao(j:j) /= '(') then
        1241           0 :               funcao = 'erro'
        1242           0 :               return
        1243             :            end if
        1244             :         end if
        1245             :
        1246             :      end do
        1247             :   end if
        1248             :
        1249             :
        1250             :
        1251             :
        1252           0 :   if(nchar >= 3) then
        1253           0 :      do i = 1,nchar-2
        1254             :
        1255           0 :         if(funcao(i:i+2) == 'sin') then
        1256           0 :            j = i+3
        1257             : 1          continue
        1258           0 :            if(j >= nchar) then
        1259           0 :               funcao = 'erro'
        1260           0 :               return
        1261             :            end if
        1262           0 :            if(funcao(j:j) == ' ') then
        1263           0 :               j = j + 1
        1264           0 :               goto 1
        1265             :            end if
        1266           0 :            if(funcao(j:j) == 'd' .or. funcao(j:j) == 'h') goto 51
        1267           0 :            if(funcao(j:j) /= '(') then
        1268           0 :               funcao = 'erro'
        1269           0 :               return
        1270             :            end if
        1271             : 51         continue
        1272             :         end if
        1273             :
        1274           0 :         if(funcao(i:i+2) == 'cos') then
        1275           0 :            j = i+3
        1276             : 2          continue
        1277           0 :            if(j >= nchar) then
        1278           0 :               funcao = 'erro'
        1279           0 :               return
        1280             :            end if
        1281           0 :            if(funcao(j:j) == ' ') then
        1282           0 :               j = j + 1
        1283           0 :               goto 2
        1284             :            end if
        1285           0 :            if(funcao(j:j) == 'd' .or. funcao(j:j) == 'h') goto 52
        1286           0 :            if(funcao(j:j) /= '(') then
        1287           0 :               funcao = 'erro'
        1288           0 :               return
        1289             :            end if
        1290             : 52         continue
        1291             :         end if
        1292             :
        1293           0 :         if(funcao(i:i+2) == 'tan') then
        1294           0 :            j = i+3
        1295             : 3          continue
        1296           0 :            if(j >= nchar) then
        1297           0 :               funcao = 'erro'
        1298           0 :               return
        1299             :            end if
        1300           0 :            if(funcao(j:j) == ' ') then
        1301           0 :               j = j + 1
        1302           0 :               goto 3
        1303             :            end if
        1304           0 :            if(funcao(j:j) == 'd' .or. funcao(j:j) == 'h') goto 53
        1305           0 :            if(funcao(j:j) /= '(') then
        1306           0 :               funcao = 'erro'
        1307           0 :               return
        1308             :            end if
        1309             : 53         continue
        1310             :         end if
        1311             :
        1312           0 :         if(funcao(i:i+2) == 'log') then
        1313           0 :            j = i+3
        1314             : 4          continue
        1315           0 :            if(j >= nchar) then
        1316           0 :               funcao = 'erro'
        1317           0 :               return
        1318             :            end if
        1319           0 :            if(funcao(j:j) == ' ') then
        1320           0 :               j = j + 1
        1321           0 :               goto 4
        1322             :            end if
        1323           0 :            if(j < (nchar-1) .and. funcao(j:j+1) == '10') goto 54
        1324           0 :            if(funcao(j:j) /= '(') then
        1325           0 :               funcao = 'erro'
        1326           0 :               return
        1327             :            end if
        1328             : 54         continue
        1329             :         end if
        1330             :
        1331           0 :         if(funcao(i:i+2) == 'exp') then
        1332           0 :            j = i+3
        1333             : 5          continue
        1334           0 :            if(j >= nchar) then
        1335           0 :               funcao = 'erro'
        1336           0 :               return
        1337             :            end if
        1338           0 :            if(funcao(j:j) == ' ') then
        1339           0 :               j = j + 1
        1340           0 :               goto 5
        1341             :            end if
        1342           0 :            if(funcao(j:j) /= '(') then
        1343           0 :               funcao = 'erro'
        1344           0 :               return
        1345             :            end if
        1346             :         end if
        1347             :
        1348           0 :         if(funcao(i:i+2) == 'abs') then
        1349           0 :            j = i+3
        1350             : 6          continue
        1351           0 :            if(j >= nchar) then
        1352           0 :               funcao = 'erro'
        1353           0 :               return
        1354             :            end if
        1355           0 :            if(funcao(j:j) == ' ') then
        1356           0 :               j = j + 1
        1357           0 :               goto 6
        1358             :            end if
        1359           0 :            if(funcao(j:j) /= '(') then
        1360           0 :               funcao = 'erro'
        1361           0 :               return
        1362             :            end if
        1363             :         end if
        1364             :
        1365             :      end do
        1366             :   endif
        1367             :
        1368             :
        1369             :   return
        1370             : end subroutine identifica
        1371             :
        1372             :
        1373             :
        1374           0 : subroutine convert_b(text)
        1375             : character (255) text
        1376             : INTENT(INOUT)::text
        1377             :
        1378             :
        1379           0 : ilength = len(trim(text))
        1380             :
        1381           0 : do k = 1,ilength
        1382           0 :    if(text(k:k) == '[' .or. text(k:k) == '{') text(k:k)='('
        1383           0 :    if(text(k:k) == ']' .or. text(k:k) == '}') text(k:k)=')'
        1384             : end do
        1385             :
        1386             :
        1387             : 10 continue
        1388           0 : item = 0
        1389           0 : ilength = len(trim(text))
        1390             :
        1391           0 :  if(ilength > 1) then
        1392             :
        1393           0 :   do k = 1,(ilength-1)
        1394             :
        1395             :    !converte ^ em **, caso o usuário digite ^
        1396           0 :    if(text(k:k) == '^') then
        1397           0 :     text = text(1:k-1)//'**'//text(k+1:ilength)
        1398           0 :  ilength = ilength + 1
        1399           0 :  item = 1
        1400             :    end if
        1401             :
        1402             :    !converte ln em log
        1403           0 :    if(text(k:k+1) == 'ln' .or. text(k:k+1) == 'Ln' .or.text(k:k+1) == 'lN' .or.text(k:k+1) == 'LN') then
        1404           0 :     text = text(1:k-1)//'log'//text(k+2:ilength)
        1405           0 :  ilength = ilength + 1
        1406           0 :  item = 1
        1407             :    end if
        1408             :
        1409             :    !converte pi em 3.14159
        1410           0 :    if(text(k:k+1) == 'pi' .or. text(k:k+1) == 'Pi' .or. text(k:k+1) == 'pI' .or. text(k:k+1) == 'PI') then
        1411           0 :     text = text(1:k-1)//'3.14159'//text(k+2:ilength)
        1412           0 :  ilength = ilength + 5
        1413           0 :  item = 1
        1414             :    end if
        1415             :
        1416             :    !converte vírgula em ponto, caso o usuário digite vírgula
        1417           0 :    if(text(k:k) == ',') then
        1418           0 :     text = text(1:k-1)//'.'//text(k+1:ilength)
        1419           0 :  item = 1
        1420             :    end if
        1421             :
        1422             :   end do
        1423             :
        1424             :  end if
        1425             :
        1426             :
        1427             :
        1428           0 :  if(ilength > 2) then
        1429             :
        1430             :    !penúltimo
        1431           0 :    if(text((ilength-1):(ilength-1)) == '^') then
        1432           0 :     text = text(1:ilength-2)//'**'//text(ilength:ilength)
        1433           0 :  item = 1
        1434             :    end if
        1435             :
        1436             :    !penúltimo
        1437           0 :    if(text((ilength-1):(ilength-1)) == ',') then
        1438           0 :     text = text(1:ilength-2)//'.'//text(ilength:ilength)
        1439           0 :  item = 1
        1440             :    end if
        1441             :
        1442             :  end if
        1443             :
        1444             :
        1445           0 :  if(ilength > 1) then
        1446             :
        1447             :    !último
        1448           0 :    if(text((ilength):(ilength)) == ',') then
        1449           0 :     text = text(1:ilength-1)//'.'
        1450           0 :  item = 1
        1451             :    end if
        1452             :
        1453             :  end if
        1454             :
        1455           0 : if(item == 1) goto 10
        1456             :
        1457           0 : return
        1458             :
        1459             : end subroutine

Generated by: LCOV version 1.14