eiram_cgi.f90

Go to the documentation of this file.

!    Copyright (c) 2016  Forschungszentrum Juelich GmbH
!                        Markus Brenneis, Vladislav Kotov 
!
!    This file is part of EIRAM.
!
!    EIRAM is free software: you can redistribute it and/or modify
!    it under the terms of the GNU General Public License as published by
!    the Free Software Foundation, either version 3 of the License, or
!    (at your option) any later version.
!
!    EIRAM is distributed in the hope that it will be useful,
!    but WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!    GNU General Public License for more details.
!
!    You should have received a copy of the GNU General Public License
!    along with EIRAM.  If not, see <http://www.gnu.org/licenses/>.
!

program eiram_cgi

    use cgi_protocol
    use eiram
    implicit none
    integer                    :: unit
    type(dict_struct), pointer :: dict => null()
    character(*), parameter    :: HEADER = "Content-type: application/json; charset=utf-8"//char(10)//&
                                    "Content-Disposition: attachment; filename=data.json"//char(10)
    
    logical, parameter :: DEBUG = .false.
    integer, parameter :: DEBUG_UNIT = 0
    
    integer, parameter :: MAX_PARAM_LENGTH = 500
    integer, parameter :: TMP_UNIT = 142
    real(kind=EIRAM_DP) :: NEG_INF = -huge(1.d0)
    character(MAX_PARAM_LENGTH) :: input = ""
    character(MAX_PARAM_LENGTH), dimension(:), allocatable :: files, types, reactions, arg1s, arg2s
    integer :: nFiles, nTypes, nReactions, nArg1s, nArg2s
    integer :: i, err
    real(kind=EIRAM_DP), dimension(:), allocatable :: xs, ys
    real(kind=EIRAM_DP) :: epsfilter = 0d0
    integer, parameter :: MAX_POINTS = 1000000

    open(tmp_unit, iostat=err, status='scratch', action='readwrite')
    eiram_unit = tmp_unit
    write(tmp_unit, *) "BEGIN OF LOG"
    write(tmp_unit, *) "CGI: not initialized"
    
    call get_environment_variable("QUERY_STRING", input)
    if(index(input, '=') == 0) then
        call sendavailablereactions()
    end if
    
    call cgi_begin(output_no_header, dict, unit)
    
    call getcsvparameter(dict, "files", "no file names provided", files, nfiles)
    call getcsvparameter(dict, "types", "no type names provided", types, ntypes)
    call getcsvparameter(dict, "reactions", "no reaction indices provided", reactions, nreactions)
    call getcsvparameter(dict, "arg1s", "no first arguments provided", arg1s, narg1s)
    call getcsvparameter(dict, "arg2s", "no second arguments provided", arg2s, narg2s)
    call cgi_get(dict, "epsfilter", epsfilter)
    
    if(debug) write(debug_unit, *) nfiles, files
    if(debug) write(debug_unit, *) ntypes, types
    if(debug) write(debug_unit, *) nreactions, reactions
    if(debug) write(debug_unit, *) narg1s, arg1s
    if(debug) write(debug_unit, *) narg2s, arg2s
    
    if(.not.all((/nfiles, ntypes, nreactions, narg1s/) == narg2s)) then
        call cgi_error("esputr_cgi: all lists must have the same length")
    end if
    
    write(unit, '(A)') header
    
    call initallfiles()
    write(unit, '(A)'), "["
    do i = 1, nfiles
        if(i > 1) then
            write(unit, '(A)'), ","
        end if
        call getpoints(files(i), types(i), reactions(i), arg1s(i), arg2s(i), xs, ys)
        write(unit, '(A)') trim(pointstojsonstring(files(i), types(i), reactions(i), xs, ys))
        deallocate(xs, ys)
    end do
    write(unit, '(A)'), "]"
    
    call eiram_deallocate(err)
    call cgi_end()
    
    contains
    
    subroutine getpoints(fileName, reactionType, reactionIndex, arg1s_str, arg2s_str, xs, ys)

        character(*), intent(in) :: fileName
        character(*), intent(in) :: reactionType
        character(*), intent(in) :: reactionIndex
        character(*), intent(in) :: arg1s_str
        character(*), intent(in) :: arg2s_str
        real(kind=EIRAM_DP), allocatable, intent(out) :: xs(:)
        real(kind=EIRAM_DP), allocatable, intent(out) :: ys(:)
        real(kind=EIRAM_DP), allocatable :: ys0(:)
        real(kind=EIRAM_DP), allocatable :: arg1s(:), arg2s(:)
        logical,allocatable :: filterMask(:)
        integer :: err,n,i,lastITaken

        intrinsic pack,size


        err = 0
        
        call parsevector(arg1s_str, arg1s)
        call parsevector(arg2s_str, arg2s)
        if(size(arg2s) == 0 .or. size(arg1s) == 0) call cgi_error("esputr_cgi: invalid input vectors")

        if(arg2s(1) <= neg_inf) then
            allocate(ys0(size(arg1s)), stat=err)
            if(err /= 0) call cgi_error("esputr_cgi: memory allocation error"//getlastmessage())
            call eiram_matlab_calc1(ys0,arg1s, size(arg1s), filename, reactiontype, reactionindex, err)
           if(err /= 0) call cgi_error("esputr_cgi: error while calculating values"//getlastmessage())
        else
            allocate(ys0(size(arg2s)), stat=err)
            if(err /= 0) call cgi_error("esputr_cgi: memory allocation error"//getlastmessage())
            call eiram_matlab_calc2(ys0, arg1s(1), arg2s, 1, size(arg2s), filename, reactiontype, reactionindex, err)
            if(err /= 0) call cgi_error("esputr_cgi: error while calculating values"//getlastmessage())
        end if

        n=size(ys0)
        allocate(filtermask(n),stat=err)
        if(err /= 0) call cgi_error("esputr_cgi: memory allocation error"//getlastmessage())     

        filtermask(1) = .true.
        lastitaken = 1
        do i = 2, n-1
            filtermask(i) = abs(ys0(i)-ys0(lastitaken)) > .5*epsfilter*(abs(ys0(i))+abs(ys0(lastitaken)))
            if(filtermask(i)) lastitaken = i
        end do
        filtermask(n) = .true.

        n=count(filtermask)
        if(allocated(xs)) deallocate(xs)   
        if(allocated(ys)) deallocate(ys)   
        allocate(xs(n),ys(n),stat=err)
        if(err /= 0) call cgi_error("esputr_cgi: memory allocation error"//getlastmessage())
        if(arg2s(1) <= neg_inf) then
         xs=pack(arg1s,filtermask)
        else 
         xs=pack(arg2s,filtermask)
        end if
        ys=pack(ys0,filtermask)

        deallocate(arg1s,arg2s,filtermask,ys0)

    end subroutine getpoints
    
    function pointstojsonstring(fileName, reactionType, reactionIndex, xs, ys)
        use json
        character(*), intent(in) :: fileName
        character(*), intent(in) :: reactionType
        character(*), intent(in) :: reactionIndex
        real(kind=EIRAM_DP), dimension(:), intent(in) :: xs
        real(kind=EIRAM_DP), dimension(:), intent(in) :: ys
        character(150+2*(14*size(xs)+2)) :: pointsToJsonString
        integer :: c, l
        pointstojsonstring(1:1) = "{"
        c = 2
       
        pointstojsonstring(c:c+3) = '"x":'
        c = c+4
        write(pointstojsonstring(c:), '(A)') eiram_json_getarrayasjson(xs, l, 5)
        c = c+l
        
        pointstojsonstring(c:c+4) = ',"y":'
        c = c+5
        write(pointstojsonstring(c:), '(A)') eiram_json_getarrayasjson(ys, l, 5)
        c = c+l
        
        call eiram_json_writejsonstringproperty("file", filename, pointstojsonstring, c)
        call eiram_json_writejsonstringproperty("type", reactiontype, pointstojsonstring, c)
        call eiram_json_writejsonstringproperty("index", reactionindex, pointstojsonstring, c)
        
        pointstojsonstring(c:c) = "}"
        c = c+1
    end function pointstojsonstring
    
    subroutine getcsvparameter(dict, parameterName, errMsg, values, nValues)

        type(dict_struct), pointer, intent(in) :: dict
        character(*), intent(in) :: parameterName
        character(*), intent(in) :: errMsg
        character(MAX_PARAM_LENGTH), dimension(:), allocatable, intent(inout) :: values
        integer, intent(out) :: nValues
        character(DICT_VALUE_LENGTH) :: input = ""
        call cgi_get(dict, parametername, input)
        if(input == "") call cgi_error("esputr_cgi: "//errmsg)
        call split(input, ",", values)
        nvalues = size(values)
    end subroutine
    
    subroutine sendavailablereactions()
        integer :: err,i,N
        type(eiram_data),allocatable :: REACTIONS(:)

        unit = 6
        
        call initallfiles()

        err=0 
        call eiram_create_image(reactions,err)
        if(err /= 0) then
         call cgi_error("esputr_cgi: cannot create the list of reactions")
         return
        end if 

        n=size(reactions)
        write(unit, '(A)') header
        write(unit, '(A)') trim(getreactionsasjson(reactions,n,err))
        
        if(err /= 0) call cgi_error("eiram_cgi: error while getting combinations "//getlastmessage())
        
        do i=1,n
         deallocate(reactions(i)%creac)
        end do  
        deallocate(reactions)

        call eiram_deallocate(err)
        call cgi_end()
    end subroutine sendavailablereactions

    subroutine initallfiles()
        call eiram_load("../data/", "H2VIBR", err)
        if(err /= 0) call cgi_error("eiram_cgi: initialization from H2VIBR failed"//getlastmessage())
        call eiram_load("../data/", "METHANE", err)
        if(err /= 0) call cgi_error("eiram_cgi: initialization from METHANE failed"//getlastmessage())
        call eiram_load("../data/", "AMJUEL", err)
        if(err /= 0) call cgi_error("eiram_cgi: initialization from AMJUEL failed"//getlastmessage())
        call eiram_load("../data/", "HYDHEL", err)
        if(err /= 0) call cgi_error("eiram_cgi: initialization from HYDHEL failed"//getlastmessage())
    end subroutine initallfiles
    
    character(DICT_VALUE_LENGTH*2) function getlastmessage()
        getlastmessage = ""
        backspace(tmp_unit, iostat=err)
        backspace(tmp_unit, iostat=err)
        read(tmp_unit, '(A)') getlastmessage(1:dict_value_length)
        read(tmp_unit, '(A)') getlastmessage(len_trim(getlastmessage)+1:dict_value_length*2)
    end function
    
    subroutine split(string, c, array)

        character(*), intent(in) :: string
        character(1), intent(in) :: c
        character(MAX_PARAM_LENGTH), dimension(:), allocatable, intent(out) :: array
        integer :: nSeps, i
        character(DICT_VALUE_LENGTH) :: str
        str = string
        nseps = count(transfer(str, 'a', dict_value_length) == c)
        allocate(array(nseps + 1))
        if(c /= ',') then
            do i=1, len(str)
                if(str(i:i) == c) then
                    str(i:i) = ","
                end if
            end do
        end if
        read(str, *) array(1:nseps+1)
    end subroutine split
    
    subroutine parsevector(strArr, realArr)

        character(*), intent(in) :: strArr
        real(kind=EIRAM_DP), dimension(:), allocatable, intent(out) :: realArr
        character(MAX_PARAM_LENGTH), dimension(:), allocatable :: strArrSplit
        real(kind=EIRAM_DP) :: start, delta, ende
        integer :: i, err, nValues
        
        if(allocated(realarr)) deallocate(realarr)

        if(strarr == "-") then
            allocate(realarr(1))
            realarr(1) = neg_inf
            return
        end if
          
        if(allocated(strarrsplit)) deallocate(strarrsplit)    
        call split(strarr, ":", strarrsplit)
        select case(size(strarrsplit))
            case (1)
                allocate(realarr(1))
                read(strarrsplit(1), *, iostat=err) realarr(1)
                if(err/=0) call cgi_error("esputr_cgi: invalid real value "//strarrsplit(1))
                return
            case (2)
                read(strarrsplit(1), *, iostat=err) start
                if(err/=0) call cgi_error("esputr_cgi: invalid real value "//strarrsplit(1))
                read(strarrsplit(2), *, iostat=err) ende
                if(err/=0) call cgi_error("esputr_cgi: invalid real value "//strarrsplit(2))
                delta = 1d0
            case (3)
                read(strarrsplit(1), *, iostat=err) start
                if(err/=0) call cgi_error("esputr_cgi: invalid real value "//strarrsplit(1))
                read(strarrsplit(2), *, iostat=err) delta
                if(err/=0) call cgi_error("esputr_cgi: invalid real value "//strarrsplit(2))
                read(strarrsplit(3), *, iostat=err) ende
                if(err/=0) call cgi_error("esputr_cgi: invalid real value "//strarrsplit(3))
            case default
                call cgi_error("esputr_cgi: invalid vector format "//strarr)
        end select
        nvalues = floor((ende-start)/delta) + 1
        if(nvalues>max_points) then 
         call cgi_error("eiram_cgi: too many data points are requested")
        end if 
        allocate(realarr(nvalues))
        realarr = (/ ( start + i*delta, i = 0, nvalues-1 ) /)
    end subroutine
    
    function getreactionsasjson(REACTIONS,N,err)
        use json
        character(1024*N) :: getReactionsAsJson
        type(eiram_data),intent(in) :: REACTIONS(n)
        integer,intent(in) :: N 
        character(EIRAM_FILE_NAME_LENGTH) :: lastFileName
        character(EIRAM_TYPE_LENGTH) :: lastTypeName
        integer, intent(out) :: err
        integer :: r, c, l, m

        err=0

        lastfilename = ""
        lasttypename = ""
        getreactionsasjson(1:10) = '{"files":['
        c = 11
        foreachreaction: do r = 1, size(reactions)
            
            if(lastfilename /= reactions(r)%FILE) then
                if(lastfilename /= "") then
                    getreactionsasjson(c:c+4) = "]}]},"
                    c = c+5
                end if
                lastfilename = reactions(r)%FILE
                lasttypename = ""
                getreactionsasjson(c:c+8) = '{"name":"'
                c = c+9
                getreactionsasjson(c:) = trim(reactions(r)%FILE)
                c = c+len_trim(reactions(r)%FILE)
                getreactionsasjson(c:c+10) = '","types":['
                c = c+11
            end if
            if(lasttypename /= reactions(r)%TYPE) then
                if(lasttypename /= "") then
                    getreactionsasjson(c:c+2) = "]},"
                    c = c+3
                end if
                lasttypename = reactions(r)%TYPE
                getreactionsasjson(c:c+8) = '{"name":"'
                c = c+9
                getreactionsasjson(c:) = trim(reactions(r)%TYPE)
                c = c+len_trim(reactions(r)%TYPE)
                getreactionsasjson(c:c) = '"'
                c = c+1
                
                call eiram_json_writejsonstringproperty("yUnit", reactions(r)%YUNITS, getreactionsasjson, c)
                call eiram_json_writejsonstringproperty("yQuantity", reactions(r)%YQUANTITY, getreactionsasjson, c)
                
                getreactionsasjson(c:c+11) = ',"xUnits":["'
                c = c+12
                getreactionsasjson(c:) = reactions(r)%X1UNITS
                c = c+len_trim(reactions(r)%X1UNITS)
                if(reactions(r)%M > 0) then
                    getreactionsasjson(c:c+2) = '","'
                    c = c+3
                    getreactionsasjson(c:) = reactions(r)%X2UNITS
                    c = c+len_trim(reactions(r)%X2UNITS)
                end if
                getreactionsasjson(c:c+1) = '"]'
                c = c+2
                
                getreactionsasjson(c:c+16) = ',"xQuantities":["'
                c = c+17
                getreactionsasjson(c:) = reactions(r)%X1QUANTITY
                c = c+len_trim(reactions(r)%X1QUANTITY)
                if(reactions(r)%M > 0) then
                    getreactionsasjson(c:c+2) = '","'
                    c = c+3
                    getreactionsasjson(c:) = reactions(r)%X2QUANTITY
                    c = c+len_trim(reactions(r)%X2QUANTITY)
                end if
                getreactionsasjson(c:c+1) = '"]'
                c = c+2
                
                getreactionsasjson(c:c+4) = ',"n":'
                c = c+5
                write(getreactionsasjson(c:c+1), '(I2)') reactions(r)%N
                c = c+2
                
                getreactionsasjson(c:c+4) = ',"m":'
                c = c+5
                write(getreactionsasjson(c:c+2), '(I2)') reactions(r)%M
                c = c+2
                
                getreactionsasjson(c:c+13) = ',"reactions":['
                c = c+14
            else if(r > 1) then
                getreactionsasjson(c:c) = ","
                c = c+1
            end if
            getreactionsasjson(c:c) = "{"
            c = c+1
            
            write(getreactionsasjson(c:c+7), '(A)') '"creac":'
            c = c+8
            if(allocated(reactions(r)%CREAC)) then
                if(reactions(r)%M == 0) then
                    write(getreactionsasjson(c:), '(A)') eiram_json_getarrayasjson(reactions(r)%CREAC(:,0), l, 12)
                    c = c+l
                else
                    write(getreactionsasjson(c:), '(A)') '['
                    c = c+1
                    do m = 0, reactions(r)%M
                        if(m > 0) then
                            getreactionsasjson(c:c) = ","
                            c = c+1
                        end if
                        write(getreactionsasjson(c:), '(A)') eiram_json_getarrayasjson(reactions(r)%CREAC(:,m), l, 12)
                        c = c+l
                    end do
                    write(getreactionsasjson(c:), '(A)') ']'
                    c = c+1
                end if
            else
                write(getreactionsasjson(c:c+3), '(A)') "null"
                c = c+4
            end if
            
            call eiram_json_writejsonstringproperty("equation", reactions(r)%REACTION, getreactionsasjson, c)
            call eiram_json_writejsonstringproperty("index", reactions(r)%INDEX, getreactionsasjson, c)
            
            getreactionsasjson(c:c+1) = "}"//char(10)
            c = c+2
        
        end do foreachreaction
        
        getreactionsasjson(c:c+5) = "]}]}]}"
        c = c + 6

        if(debug) print *, c, "/", len(getreactionsasjson), "chars written"
    end function getreactionsasjson

end program eiram_cgi