LCOV - code coverage report
Current view: top level - io - calculator.f (source / functions) Hit Total Coverage
Test: combined.info Lines: 125 300 41.7 %
Date: 2019-09-08 04:53:50 Functions: 13 22 59.1 %

          Line data    Source code
       1             : !--------------------------------------------------------------------------------
       2             : ! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
       3             : ! This file is part of FLEUR and available as free software under the conditions
       4             : ! of the MIT license as expressed in the LICENSE file in more detail.
       5             : !--------------------------------------------------------------------------------
       6             : 
       7             :       MODULE m_calculator
       8             :       use m_juDFT
       9             :       !
      10             :       !  This module implements a parser able to evaluate expressions in
      11             :       !  input files
      12             :       !
      13             :       IMPLICIT NONE
      14             : 
      15             :       PRIVATE
      16             :       PUBLIC :: evaluateList,evaluate,ASSIGN_var,delete_vars,
      17             :      $     evaluatefirst,
      18             :      $          makenumberstring,show,evaluateFirstOnly,
      19             :      $          evaluateFirstIntOnly,evaluateFirstBoolOnly
      20             : 
      21             :       CHARACTER(len = 10),SAVE,ALLOCATABLE :: var_names(:)
      22             :       REAL,ALLOCATABLE,SAVE                :: var_values(:)
      23             :       INTEGER,SAVE                         :: n_vars
      24             :       INTEGER,PARAMETER                    :: num_predef = 6
      25             :       LOGICAL,SAVE                         :: initialized=.false.
      26             : 
      27             :       CONTAINS
      28             : 
      29             : 
      30             :       !<-- S: priv_error(m)
      31           0 :       SUBROUTINE show( )
      32             : !-----------------------------------------------
      33             : !
      34             : !           (last modified: 2012-05-22) pbaum
      35             : !-----------------------------------------------
      36             :       IMPLICIT NONE
      37             : 
      38             :       !<-- Locals
      39             :       INTEGER             :: n
      40             :       !>
      41             : 
      42           0 :       WRITE(*,*) "Defined variables:"
      43             : 
      44           0 :       DO n = 1,n_vars
      45           0 :          WRITE(*,"(9a)") TRIM(var_names(n)), ' = '
      46           0 :      $     ,makenumberstring(var_values(n))
      47             :       ENDDO
      48             : 
      49           0 :       END SUBROUTINE
      50             :       !>
      51             : 
      52             : 
      53             :       !<-- S: priv_error(m)
      54           0 :       SUBROUTINE priv_error(m)
      55             : !-----------------------------------------------
      56             : !
      57             : !           (last modified: 2004-00-00) D. Wortmann
      58             : !-----------------------------------------------
      59             :       IMPLICIT NONE
      60             : 
      61             :       !<--Arguments
      62             :       CHARACTER(len =*), INTENT(in) :: m
      63             :       !>
      64             :       !<-- Locals
      65             :       INTEGER             :: ierr,n
      66             :       !>
      67             : 
      68           0 :       WRITE(*,*) m
      69           0 :       WRITE(6,*) m
      70           0 :       WRITE(*,*) "Defined variables:"
      71             : 
      72           0 :       DO n = 1,n_vars
      73           0 :          WRITE(*,"(2a,f0.10)") TRIM(var_names(n)),' = ',var_values(n)
      74             :       ENDDO
      75             : 
      76           0 :       CALL juDFT_error("Error in expression",calledby="calculator")
      77           0 :       END SUBROUTINE
      78             :       !> 
      79          27 :       SUBROUTINE priv_init()
      80             :       IMPLICIT NONE
      81          27 :       initialized=.true.
      82          27 :       ALLOCATE(var_values(num_predef))
      83          27 :       ALLOCATE(var_names(num_predef))
      84          27 :       n_vars=num_predef
      85          27 :       var_names (1) = 'Pi'
      86          27 :       var_values(1) = 3.1415926535897932384626433832795
      87          27 :       var_names (2) = 'Deg'
      88          27 :       var_values(2) = 17.453292519943295E-3
      89          27 :       var_names (3) = 'Ang'
      90          27 :       var_values(3) =   1.8897261247728981
      91          27 :       var_names (4) = 'nm'
      92          27 :       var_values(4) =   18.897261247728981
      93          27 :       var_names (5) = 'pm'
      94          27 :       var_values(5) = 0.018897261247728981
      95          27 :       var_names (6) = 'Bohr'
      96          27 :       var_values(6) = 1.0
      97          27 :       END subroutine priv_init
      98             :       
      99             :       !<-- S: priv_increase_storage()
     100           0 :       SUBROUTINE priv_increase_storage()
     101             : !-----------------------------------------------
     102             : !    increase the storage for the variables if needed
     103             : !    This is a very slow procedure, so be careful to
     104             : !    adjust the buffer size if it is called very often
     105             : !           (last modified: 2004-00-00) D. Wortmann
     106             : !-----------------------------------------------
     107             :       IMPLICIT NONE
     108             : 
     109             :       !<-- Locals
     110           0 :       CHARACTER(len = 10),ALLOCATABLE :: tmp_names(:)
     111           0 :       REAL   ,ALLOCATABLE             :: tmp_values(:)
     112             :       INTEGER,PARAMETER :: min_buffer = 5 
     113             :       INTEGER :: i
     114             :       !>
     115             : 
     116           0 :       IF (.not.initialized) CALL priv_init()
     117           0 :       IF (n_vars+1 < SIZE(var_names)) RETURN !nothing to be done
     118             :  
     119             : 
     120             :       !<-- copy old data
     121           0 :       IF (ALLOCATED(var_names)) THEN
     122           0 :          ALLOCATE(tmp_names(SIZE(var_names)))
     123           0 :          tmp_names(:) = var_names
     124           0 :          ALLOCATE(tmp_values(SIZE(var_values)))
     125           0 :          tmp_values(:) = var_values
     126           0 :          DEALLOCATE(var_values,var_names)
     127             :       ENDIF
     128             :       !>
     129             : 
     130           0 :       ALLOCATE(var_values(n_vars+min_buffer))
     131           0 :       ALLOCATE(var_names(n_vars+min_buffer))
     132             : 
     133             :       !<-- Copy data back
     134           0 :       IF (ALLOCATED(tmp_names)) THEN
     135           0 :          var_names(:SIZE(tmp_names)) = tmp_names
     136           0 :          var_values(:SIZE(tmp_values)) = tmp_values
     137           0 :          DEALLOCATE(tmp_names,tmp_values)
     138             :       ENDIF
     139             :       !>
     140           0 :       END SUBROUTINE
     141             :       !> 
     142             : 
     143             :       !<-- S: delete_vars()
     144           0 :       SUBROUTINE delete_vars()
     145             : !-----------------------------------------------
     146             : !    
     147             : !           (last modified: 2004-00-00) D. Wortmann
     148             : !-----------------------------------------------
     149             :       IMPLICIT NONE
     150           0 :       IF (ALLOCATED(var_names)) THEN
     151           0 :          DEALLOCATE(var_names)
     152           0 :          DEALLOCATE(var_values)
     153           0 :          n_vars = 0
     154             :       ENDIF
     155           0 :       END SUBROUTINE
     156             :       !> 
     157             : 
     158             :       !<-- S: assign_var(var,value)
     159           0 :       SUBROUTINE ASSIGN_var(var,value)
     160             : !-----------------------------------------------
     161             : !  assign a value to a variable
     162             : !           (last modified: 2004-00-00) D. Wortmann
     163             : !-----------------------------------------------
     164             :       IMPLICIT NONE
     165             : 
     166             :       !<--Arguments
     167             :       CHARACTER(len = *),INTENT(IN) :: var
     168             :       REAL   ,INTENT(IN)            :: value
     169             :       !>
     170             : 
     171             :       !<-- Locals
     172             :       INTEGER             :: n
     173             :       CHARACTER(len = 10) :: s
     174             :       !>
     175           0 :       IF (.not.initialized) CALL priv_init()
     176             :    
     177           0 :       s = TRIM(ADJUSTL(var))
     178             : 
     179           0 :       DO n = 1,n_vars
     180           0 :          IF (s == var_names(n)) THEN
     181           0 :             IF (n > num_predef) THEN
     182             :                !variable exists, new value assigned
     183           0 :                var_values(n) = value
     184           0 :                RETURN
     185             :             ELSE
     186             :                CALL priv_error(
     187           0 :      $           'attempt to override predefined constant!')
     188             :             END IF
     189             :          ENDIF
     190             :       ENDDO
     191             : 
     192             :       !this is a new variable
     193           0 :       CALL priv_increase_storage()
     194           0 :       n_vars = n_vars+1
     195           0 :       var_names(n_vars) = s
     196           0 :       var_values(n_vars) = value
     197           0 :       END SUBROUTINE
     198             :       !> 
     199             : 
     200             :       !<-- F: priv_number(string) result(number)
     201        2005 :       FUNCTION priv_number(string) result(number)
     202             : !-----------------------------------------------
     203             : !    read the first part of string as a number
     204             : !             (last modified: 06-04-11) D. Wortmann
     205             : !-----------------------------------------------
     206             :       IMPLICIT NONE
     207             : 
     208             :       !<-- Arguments
     209             :       CHARACTER(len =*), INTENT(inout) :: string
     210             :       REAL                             :: number
     211             :       !>
     212             : 
     213             :       !<-- Locals
     214             :       INTEGER             :: pos
     215             :       LOGICAL             :: dot
     216             :       !>
     217             : 
     218        2005 :       number = 0.0
     219        2005 :       pos = 0
     220        2005 :       dot = .false.
     221             :       loop:DO
     222       14290 :          pos = pos+1
     223       14290 :          IF (pos>LEN(string)) THEN
     224             :             EXIT
     225             :          ENDIF
     226        1506 :          SELECT CASE(string(pos:pos))
     227             :              CASE ('0':'9') 
     228           0 :                 CYCLE loop
     229             :              CASE ('+','-')
     230        1429 :                 IF(pos /= 1) EXIT loop
     231             :              CASE ('.') 
     232        1429 :                 IF(dot) THEN
     233             :                    EXIT loop
     234             :                 ELSE
     235             :                    dot = .TRUE.
     236             :                 ENDIF
     237             :              CASE default
     238       12784 :                 EXIT loop
     239             :          END SELECT
     240             :       ENDDO loop
     241             : 
     242             :       IF (pos == 0) RETURN 
     243        2005 :       READ(string(:pos-1),*)number
     244        2005 :       IF (pos>LEN(string)) THEN
     245        1506 :          string=' '
     246             :       ELSE
     247         499 :          string = string(pos:)
     248             :       ENDIF
     249        4010 :       END function
     250             :       !>
     251             : 
     252             :       !<-- S: priv_text(string, command, number)
     253           0 :       SUBROUTINE  priv_text(string, command, number)
     254             : !-----------------------------------------------
     255             : !
     256             : !           (last modified: 2004-00-00) D. Wortmann
     257             : !-----------------------------------------------
     258             :       IMPLICIT NONE
     259             : 
     260             :       !<--Arguments
     261             :       CHARACTER(len =*), INTENT(inout) :: string
     262             :       CHARACTER(len = 10), INTENT(out) :: command
     263             :       REAL, INTENT(out)                :: number
     264             :       !>
     265             : 
     266             :       !<-- Locals
     267             :       INTEGER  :: n,l
     268             :       CHARACTER(len = 5),DIMENSION(13), PARAMETER :: functions = (/
     269             :      $     'cos( ','sin( ','tan( ','exp( ','log( ','abs( ','sqrt('
     270             :      $     ,'acos(','asin(','atan(','cosh(','sinh(','tanh('/)
     271             :       !>
     272             : 
     273           0 :       command = ' '
     274           0 :       number = 0.0
     275             : 
     276             :       !<--check if this is a function call
     277           0 :       DO n = 1,SIZE(functions)
     278           0 :          l = len_TRIM(functions(n))
     279           0 :          IF (len_TRIM(string) <= l) CYCLE
     280           0 :          IF (string(:l) == functions(n)(:l)) THEN
     281           0 :             command = functions(n)(:l)
     282           0 :             string=string(l:)
     283             :             RETURN
     284             :          ENDIF
     285             :       ENDDO
     286             :       !>
     287             : 
     288             :       !<-- it must be a variable
     289             :       !separate the name of the variable
     290             : 
     291             :       l = 1
     292             :       DO 
     293           0 :          l = l+1
     294           0 :          IF (l>len_TRIM(string)) EXIT
     295           0 :          SELECT CASE (string(l:l)) 
     296             :          CASE ('*','+','-','/',')',' ','^','%')
     297           0 :             EXIT
     298             :          END SELECT
     299             :       ENDDO
     300             : 
     301           0 :       l = l-1
     302           0 :       DO n = 1,n_vars
     303           0 :          IF (l /= len_TRIM(var_names(n))) CYCLE
     304           0 :          IF (string(:l) == var_names(n)(:l)) THEN
     305           0 :             command = 'variable'
     306           0 :             number  = var_values(n)
     307           0 :             IF (len_TRIM(string)>l) THEN
     308           0 :                string = string(l+1:)
     309             :             ELSE
     310           0 :                string=' '
     311             :             ENDIF
     312             :             RETURN
     313             :          ENDIF
     314             :       ENDDO
     315             :       !>
     316             :       CALL priv_error("Unknown character string found: "//TRIM(string
     317           0 :      $     ))
     318           0 :       END SUBROUTINE
     319             :       !> 
     320             : 
     321             :       !<-- F: priv_operator(string)
     322         251 :       FUNCTION priv_operator(string) result(command)
     323             : !-----------------------------------------------
     324             : !
     325             : !             (last modified: 2004-00-00) D. Wortmann
     326             : !-----------------------------------------------
     327             :       IMPLICIT NONE
     328             : 
     329             :       !<--Arguments
     330             :       CHARACTER(len =*), INTENT(inout) :: string
     331             :       CHARACTER                        :: command
     332             :       !>
     333             : 
     334         251 :       IF (len_TRIM(string)<2)
     335           0 :      $   CALL priv_error("Parsing error (operator): "//trim(string))
     336             : 
     337         251 :       SELECT CASE( string(1:1) )
     338             :          CASE( '+', '-', '/', '%', '^', '*' )
     339         251 :             command = string(1:1)
     340             :             !<-- see if the 2nd char is also an operator
     341           0 :             SELECT CASE( string(2:2) )
     342             :                CASE( '*' )
     343           0 :                   command = '^' ! convert ** to ^
     344           0 :                   string = string(2:) ! cut away the 1st '*'
     345             :                CASE( '+', '-', '/', '%', '^' )
     346             :                   CALL priv_error(
     347         251 :      $               'Operator following operator '//TRIM(string))
     348             :             END SELECT
     349             :          CASE default
     350         251 :             CALL priv_error('Unknown operator: '//TRIM(string))
     351             :       END SELECT
     352         251 :       string = string(2:) ! cut away the 1st char
     353             : 
     354         502 :       END FUNCTION
     355             :       !>
     356             : 
     357             :       !<-- F: priv_bracket(string)
     358           0 :       FUNCTION priv_bracket(string)RESULT(substring)
     359             : !-----------------------------------------------
     360             : !
     361             : !             (last modified: 2004-00-00) D. Wortmann
     362             : !-----------------------------------------------
     363             :       IMPLICIT NONE
     364             : 
     365             :       !<--Arguments
     366             :       CHARACTER(len =*), INTENT(inout) :: string
     367             :       CHARACTER(len = LEN(string)) :: substring
     368             :       !>
     369             : 
     370             :       !<-- Locals
     371             :       INTEGER             :: n,pos,cnt
     372             :       !>
     373             : 
     374           0 :       pos = 0
     375           0 :       cnt = 0
     376             : 
     377             :       loop:DO
     378           0 :          pos = pos+1
     379           0 :          IF (pos>len_TRIM(string)) CALL priv_error("Unbalanced brackets"
     380           0 :      $        )
     381           0 :          SELECT CASE(string(pos:pos))
     382             :             CASE('(')
     383           0 :               cnt = cnt+1
     384             :             CASE(')')
     385           0 :               cnt = cnt-1
     386             :          END SELECT
     387           0 :          IF (cnt == 0) EXIT loop
     388             :       ENDDO loop
     389             : 
     390           0 :       substring = TRIM(string(2:pos-1))
     391           0 :       IF (len_TRIM(substring) == 0) CALL priv_error
     392           0 :      $     ("Empty brackets found")
     393           0 :       IF (len_TRIM(string) < pos+1) THEN
     394           0 :          string = ' '
     395             :       ELSE
     396           0 :          string = string(pos+1:)
     397             :       END IF
     398           0 :       END FUNCTION
     399             :       !> 
     400             : 
     401             :       !<-- F: priv_calc(string,command,value)
     402        3704 :       RECURSIVE FUNCTION priv_calc(string,value,command)
     403             :      $     RESULT(number)
     404             : !-----------------------------------------------
     405             : !
     406             : !             (last modified: 2004-00-00) D. Wortmann
     407             : !-----------------------------------------------
     408             :       IMPLICIT NONE
     409             : 
     410             :       !<--Arguments
     411             :       CHARACTER(len=*), INTENT(inout) :: string
     412             :       CHARACTER(len = 10), INTENT(in) :: command
     413             :       REAL, INTENT(in)                :: value
     414             :       REAL                            :: number
     415             :       !>
     416             : 
     417             :       !<-- Locals
     418             :       CHARACTER(len = 10) :: nextcommand
     419             :       REAL                :: nextnumber
     420             :       !>
     421             : 
     422        3482 :       SELECT CASE(command)
     423             :          CASE('number','variable','end')
     424        3482 :             number = value
     425             :          CASE('bracket')
     426           0 :             number = evaluate(priv_bracket(string))
     427             :          CASE('+')
     428           0 :             number = value + priv_evaluateblock(string, command)
     429             :          CASE('-')
     430         138 :             number = value - priv_evaluateblock(string, command)
     431             :          CASE('*')
     432           0 :             number = value * priv_evaluateblock(string, command)
     433             :          CASE('%')
     434           0 :             number = modulo(value,priv_evaluateblock(string, command))
     435             :          CASE('/')
     436          84 :             number = priv_evaluateblock(string, command)
     437          84 :             IF (number == 0.0) CALL priv_error("Divide by zero")
     438          84 :             number = value/number
     439             :          CASE('^','**')
     440           0 :             number = priv_evaluateblock(string, command)
     441           0 :             IF (number > 0.0) THEN
     442           0 :                number = value ** number
     443           0 :             ELSEIF (value < 0.0) THEN
     444           0 :                IF (INT(number) == number) THEN
     445           0 :                   number = value ** INT(number)
     446             :                ELSE
     447           0 :                   CALL priv_error('x^y, x<0 and y not integer')
     448             :                END IF
     449           0 :             ELSEIF (number /= 0.0) THEN
     450             :                number = 0.0
     451             :             ELSE
     452           0 :                CALL priv_error('Undefined result 0^0')
     453             :             END IF     
     454             :          CASE('cos(','sin(','exp(','log(','abs(','sqrt(','acos(','
     455             :      $           asin(','atan(','cosh(','tanh(','tan(')
     456           0 :             call priv_getnextatom(string, nextnumber, nextcommand)
     457           0 :             number = priv_calc(string, nextnumber, nextcommand)
     458           0 :             SELECT CASE (command)
     459             :                CASE('sin(')
     460           0 :                   number = SIN(number)
     461             :                CASE('cos(')
     462           0 :                   number = COS(number)
     463             :                CASE('tan(')
     464           0 :                   number = TAN(number)
     465             :                CASE('exp(')
     466           0 :                   number = EXP(number)
     467             :                CASE('log(')
     468           0 :                   IF (number <= 0) CALL priv_error("log(x),x <= 0 ")
     469           0 :                   number = LOG(number)
     470             :                CASE('abs(')
     471           0 :                   number = ABS(number)
     472             :                CASE('sqrt(')
     473           0 :                   IF (number < 0) CALL priv_error("sqrt(x),x <0 ")
     474           0 :                   number = SQRT(number)
     475             :                CASE('acos(')
     476           0 :                   IF (ABS(number)>1) CALL priv_error("acos(x), |x|>1")
     477           0 :                   number = ACOS(number)
     478             :                CASE('asin(')
     479           0 :                   IF (ABS(number)>1) CALL priv_error("asin(x), |x|>1")
     480           0 :                   number = ASIN(number)
     481             :                CASE('atan(')
     482           0 :                   number = ATAN(number)
     483             :                CASE('cosh(')
     484           0 :                   number = COSH(number)
     485             :                CASE('sinh(')
     486           0 :                   number = SINH(number)
     487             :                CASE('tanh(')
     488           0 :                   number = TANH(number)
     489             :             END SELECT
     490             :          CASE default
     491        3704 :             CALL priv_error("Parsing error: "//command)
     492             :       END SELECT
     493        3704 :       END FUNCTION
     494             :       !> 
     495             : 
     496             :       !<-- S: priv_getnextatom(func, number, command)
     497        4177 :       SUBROUTINE priv_getnextatom(string, number, command)
     498             : !-----------------------------------------------
     499             : !
     500             : !           (last modified: 2004-00-00) D. Wortmann
     501             : !-----------------------------------------------
     502             :       IMPLICIT NONE
     503             : 
     504             :       !<--Arguments
     505             :       CHARACTER(len =*), INTENT(inout) :: string
     506             :       REAL, INTENT(inout)              :: number
     507             :       CHARACTER(len = 10), INTENT(out) :: command
     508             :       !>
     509             : 
     510        2005 :       SELECT CASE(string(1:1))
     511             :       CASE('0':'9', '.')
     512        2005 :          number = priv_number(string)
     513        2005 :          command = 'number'
     514             :       CASE('+', '-', '/', '*', '%', '^')
     515         251 :          command = priv_OPERATOR(string)
     516             :       CASE('a':'z','A':'Z')
     517           0 :          CALL priv_text(string, command, number)
     518             :       CASE('(')
     519           0 :          command = 'bracket'
     520             :       CASE default
     521        1921 :          IF (len_TRIM(string) > 1) CALL
     522           0 :      $        priv_error('Unknowninput:'//TRIM(string))
     523        6098 :          command = 'end'
     524             :       END SELECT
     525        4177 :       END SUBROUTINE
     526             :       !>
     527             : 
     528             :       !<-- F: priv_order(command) 
     529             : 
     530         502 :       FUNCTION priv_order(command) result(order)
     531             : !-----------------------------------------------
     532             : !
     533             : !             (last modified: 2004-00-00) D. Wortmann
     534             : !-----------------------------------------------
     535             :       IMPLICIT NONE
     536             : 
     537             :       !<--Arguments
     538             :       CHARACTER(len =*), INTENT(in) :: command
     539             :       INTEGER                       :: order
     540             :       !>
     541             : 
     542         502 :       order = 0
     543             : 
     544         502 :       SELECT CASE(TRIM(command))
     545             :          CASE('+','-')
     546             :             order = 10
     547             :          CASE('*','/','%')
     548             :             order = 100
     549             :          CASE('**','^')
     550         502 :             order = 1000
     551             :       END SELECT
     552         502 :       END FUNCTION
     553             :       !> 
     554             : 
     555             :       !<-- S: priv_peeknextatom(string, number, command)
     556         473 :       SUBROUTINE priv_peeknextatom(string, number, command)
     557             : !-----------------------------------------------
     558             : !
     559             : !           (last modified: 2004-00-00) D. Wortmann
     560             : !-----------------------------------------------
     561             :       IMPLICIT NONE
     562             : 
     563             :       !<--Arguments
     564             :       CHARACTER(len =*), INTENT(in) :: string
     565             :       REAL, INTENT(inout)           :: number
     566             :       CHARACTER(len = 10), INTENT(inout) :: command
     567             :       !>
     568             : 
     569             :       !<-- Locals
     570         473 :       CHARACTER(len   = LEN(string)) :: s
     571             :       !>
     572             : 
     573         473 :       s=string
     574         473 :       CALL priv_getnextatom(s,number,command)
     575         946 :       END SUBROUTINE
     576             :       !> 
     577             : 
     578             :       !<-- F: priv_evaluateblock(func, blockcommand) result(number)
     579         222 :       RECURSIVE FUNCTION priv_evaluateblock(string, blockcommand)
     580             :      $     RESULT(number)
     581             : !-----------------------------------------------
     582             : !
     583             : !             (last modified: 2004-00-00) D. Wortmann
     584             : !-----------------------------------------------
     585             :       IMPLICIT NONE
     586             : 
     587             :       !<--Arguments
     588             :       CHARACTER(len =*), INTENT(inout) :: string
     589             :       CHARACTER(len=*), INTENT(in)     :: blockcommand
     590             :       REAL                             :: number
     591             :       !>
     592             : 
     593             :       !<-- Locals
     594             :       CHARACTER(len = 10) :: command, nextcommand
     595             :       REAL                :: nextnumber
     596             :       !>
     597         222 :       IF (.not.initialized) CALL priv_init()
     598             :    
     599         222 :       number = 0
     600             : 
     601         222 :       CALL priv_peeknextatom(string, nextnumber, nextcommand)
     602             : 
     603         222 :       IF (TRIM(nextcommand) == 'end') CALL priv_error
     604           0 :      $     ('Premature end of function')
     605             : 
     606             :       DO WHILE((priv_order(nextcommand) == 0 .OR.
     607         473 :      $     (priv_order(nextcommand) >priv_order(blockcommand))) .AND.
     608         724 :      $     TRIM(nextcommand) /= 'end')
     609         251 :          CALL priv_getnextatom(string, number, command)
     610         251 :          number = priv_calc(string, number, command)
     611         251 :          CALL priv_peeknextatom(string, nextnumber, nextcommand)
     612             :       END DO
     613         222 :       END FUNCTION
     614             :       !> 
     615             : 
     616             :       !<-- F: evaluate(s) 
     617        1699 :       RECURSIVE FUNCTION evaluate(s) RESULT(number)
     618             : !-----------------------------------------------
     619             : !
     620             : !             (last modified: 2004-00-00) D. Wortmann
     621             : !-----------------------------------------------
     622             :       IMPLICIT NONE
     623             : 
     624             :       !<--Arguments
     625             :       CHARACTER(len =*), INTENT(in  ) :: s
     626             :       REAL                            :: number
     627             :       !>
     628             : 
     629             :       !<-- Locals
     630             :       CHARACTER(len = 10) :: command
     631        1699 :       CHARACTER(len = len_trim(s)) :: tmp_s
     632             :       !>
     633             : 
     634        1699 :       tmp_s  = TRIM(ADJUSTL(s))
     635        1699 :       number = 0
     636        1699 :       command = ' '
     637        1699 :       IF (.not.initialized) CALL priv_init()
     638             :    
     639        8605 :       DO WHILE(command /= 'end')
     640        3453 :          CALL priv_getnextatom(tmp_s, number, command)
     641        5152 :          number = priv_calc(tmp_s, number, command)
     642             :       END DO
     643        3398 :       END FUNCTION
     644             :       !> 
     645             : 
     646             :       !<-- F: makenumberstring(x)
     647           0 :       FUNCTION makenumberstring(x) result( str )
     648             : !-----------------------------------------------
     649             : !
     650             : !             (last modified: 2004-00-00) D. Wortmann
     651             : !             (last modified: 2012-05-22) pbaum
     652             : !-----------------------------------------------
     653             :       IMPLICIT NONE
     654             : 
     655             :       !<--Arguments
     656             :       REAL   ,INTENT(IN)     :: x
     657             :       CHARACTER(len=20)      :: str
     658             :       !>
     659             : 
     660             :       !<-- Locals
     661             :       INTEGER                :: n, i, m
     662             :       REAL                   :: xx, xm
     663             :       CHARACTER(len =10)     :: fn ! function string
     664             :       CHARACTER              :: p2 ! closing parenthesis
     665             :       CHARACTER              :: sg ! sign
     666             :       !>
     667             : 
     668           0 :       DO i = 0,2
     669             :          !<-- assume that xx = fn(x)
     670             :          !<-- apply the inverse function x = fn^{-1}(xx)
     671           0 :          SELECT CASE (i)
     672           0 :          CASE ( 2 )   ; fn = 'tan('   ; p2 = ')' ; xx = atan(abs(x))
     673           0 :          CASE ( 1 )   ; fn = 'sqrt('  ; p2 = ')' ; xx = x*x
     674           0 :          CASE DEFAULT ; fn = ''       ; p2 = ' ' ; xx = abs(x)
     675             :          END SELECT
     676             : 
     677             :          !<-- restore the sign to appear in front of the function
     678           0 :          sg = ' ' ; IF (x < 0.) sg = '-'
     679             : 
     680             :          !<-- check if xx is a simple fraction
     681           0 :          n = 0 ! 0: not found
     682           0 :          m = 0 ! init
     683           0 :          DO WHILE (m < 25)
     684           0 :            m = m+1
     685           0 :            xm = xx*m
     686           0 :            IF (ABS(xm-NINT(xm))<1E-6) THEN
     687           0 :              n = m
     688           0 :              EXIT
     689             :            END IF
     690             :          END DO
     691             : 
     692           0 :          IF (n == 1) THEN
     693             :             WRITE(str,"(2a,i0,a)")
     694           0 :      $         TRIM(sg), TRIM(fn), NINT(xx), TRIM(p2)
     695           0 :          ELSE IF (n > 1) THEN
     696             :             WRITE(str,"(2a,i0,a,i0,a)")
     697           0 :      $         TRIM(sg), TRIM(fn), NINT(xx*n), '/', n, TRIM(p2)
     698             :          ENDIF
     699           0 :          IF (n > 0) RETURN
     700             :       END DO
     701             :       !>
     702             : 
     703             :       !ok nothing found
     704           0 :       WRITE(str,"(f20.12)") x
     705           0 :       i = LEN(str)
     706           0 :       DO WHILE( str(i:i) == '0' )
     707           0 :          str(i:i) = ' '
     708           0 :          i = i-1
     709             :       END DO
     710           0 :       str = ADJUSTL(str)
     711             :       END FUNCTION
     712             :       !> 
     713             :       
     714           0 :       SUBROUTINE evaluateList(array,s)
     715             :       IMPLICIT NONE
     716             :       REAL,ALLOCATABLE,INTENT(INOUT) ::array(:)
     717             :       CHARACTER(len=*),INTENT(inout) ::s
     718             :       
     719             :       REAL    :: tmp(10)
     720             :       INTEGER :: n
     721           0 :       n=0
     722           0 :       DO WHILE(LEN_TRIM(ADJUSTL(s))>1)
     723           0 :          n=n+1
     724           0 :          if (n>10) call judft_error("List too long",
     725           0 :      +        calledby="calculator")
     726           0 :          tmp(n)=evaluatefirst(s)
     727             :       END DO
     728           0 :       if (allocated(array)) deallocate(array)
     729           0 :       ALLOCATE(array(n))
     730           0 :       array=tmp(:n)
     731           0 :       END SUBROUTINE
     732             :      
     733             :    
     734             :       !<-- F: evaluateFirst(string)
     735         342 :       FUNCTION evaluateFirst(s,n)result(number)
     736             : !-----------------------------------------------
     737             : !
     738             : !             (last modified: 2004-00-00) D. Wortmann
     739             : !-----------------------------------------------
     740             :       IMPLICIT NONE
     741             : 
     742             :       !<--Arguments
     743             :       CHARACTER(len =*), INTENT(inout) :: s
     744             :       INTEGER,OPTIONAL                 :: n
     745             :       REAL                             :: number
     746             :       !>
     747             : 
     748             :       !<-- Locals
     749             :       INTEGER             :: pos
     750             :       !>
     751         342 :       IF (.not.initialized) CALL priv_init()
     752             :    
     753         342 :       s = ADJUSTL(s)
     754         342 :       IF (len_TRIM(s) == 0) THEN
     755             :          number = 0
     756             :          RETURN
     757             :       ENDIF
     758         339 :       pos = INDEX(s," ")
     759         339 :       IF (pos == 0) pos = LEN(s)
     760         339 :       IF (PRESENT(n)) pos = MAX(pos,n)
     761         339 :       number  = evaluate(s(:pos))
     762         339 :       IF (pos<LEN_TRIM(s)) THEN
     763         224 :          s = s(pos:)
     764             :       ELSE
     765         115 :          s =" "
     766             :       ENDIF
     767         342 :       END FUNCTION
     768             :       !> 
     769             : 
     770             : 
     771         798 :       FUNCTION evaluateFirstOnly(s)result(number)
     772             : 
     773             :       IMPLICIT NONE
     774             : 
     775             :       CHARACTER(len =*), INTENT(IN)    :: s
     776             :       REAL                             :: number
     777             : 
     778             :       !<-- Locals
     779         798 :       CHARACTER(len=LEN(s)) :: tempS
     780             :       INTEGER               :: pos
     781             :       !>
     782             : 
     783         798 :       tempS = ADJUSTL(s)
     784         798 :       IF (len_TRIM(tempS) == 0) THEN
     785             :          number = 0
     786             :          RETURN
     787             :       ENDIF
     788         798 :       pos = INDEX(tempS," ")
     789         798 :       IF (pos == 0) pos = LEN(tempS)
     790         798 :       number  = evaluate(tempS(:pos))
     791             : 
     792        1596 :       END FUNCTION
     793             : 
     794             : 
     795         562 :       FUNCTION evaluateFirstIntOnly(s)result(number)
     796             : 
     797             :       IMPLICIT NONE
     798             : 
     799             :       CHARACTER(len =*), INTENT(in) :: s
     800             :       INTEGER                          :: number
     801             : 
     802             :       !<-- Locals
     803             :       INTEGER               :: pos
     804         562 :       CHARACTER(len=LEN(s)) :: tempS
     805             :       !>
     806             : 
     807         562 :       tempS = ADJUSTL(s)
     808         562 :       IF (len_TRIM(tempS) == 0) THEN
     809             :          number = 0
     810             :          RETURN
     811             :       END IF
     812         562 :       pos = INDEX(tempS," ")
     813         562 :       IF (pos == 0) pos = LEN(tempS)
     814         562 :       number = NINT(evaluate(tempS(:pos)))
     815             : 
     816        1124 :       END FUNCTION
     817             : 
     818         925 :       FUNCTION evaluateFirstBoolOnly(s)result(bool)
     819             : 
     820             :       IMPLICIT NONE
     821             : 
     822             :       CHARACTER(len =*), INTENT(in)    :: s
     823             :       LOGICAL                          :: bool
     824             : 
     825             :       !<-- Locals
     826             :       INTEGER               :: pos
     827         925 :       CHARACTER(len=LEN(s)) :: tempS
     828             :       !>
     829             : 
     830         925 :       tempS = ADJUSTL(s)
     831         925 :       IF (len_TRIM(tempS) == 0) THEN
     832             :          CALL juDFT_error("String is empty.",
     833           0 :      +                    calledby ="calculator")
     834           0 :          RETURN
     835             :       END IF
     836             : 
     837         925 :       pos = INDEX(tempS," ")
     838         925 :       IF (pos == 0) pos = LEN(tempS)
     839             :       SELECT CASE (tempS(:pos))
     840             :          CASE ('F','f','false','FALSE')
     841             :             bool = .FALSE.
     842             :          CASE ('T','t','true','TRUE')
     843           0 :             bool = .TRUE.
     844             :          CASE DEFAULT
     845             :             CALL juDFT_error('No valid bool at start of: ' // tempS,
     846         925 :      +                       calledby ="calculator")
     847             :       END SELECT
     848             : 
     849         925 :       END FUNCTION
     850             : 
     851             :       END MODULE m_calculator

Generated by: LCOV version 1.13