eiram_matlab.F

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/>.
!

#include "fintrf.h"


      subroutine mexfunction(nlhs, plhs, nrhs, prhs)
      use eiram
      implicit none
      integer :: nlhs
      integer :: nrhs
      mwpointer, dimension(*) :: plhs
      mwpointer, dimension(*) :: prhs
      
      mwpointer :: mxgetpr, mxcreatedoublematrix, mxgetstring
      integer :: mxIsNumeric, mxIsChar
      mwsize :: mxgetm, mxgetn
      
      mwsize :: narg1s, narg2s
      integer :: err,err0
      mwpointer :: arg1s_pr, arg2s_pr, ys_pr
      real(kind=8),allocatable :: Arg1s(:), Arg2s(:)
      real(kind=8),allocatable :: Ys(:,:,:)
      integer, parameter :: MAX_STR_LEN = 1024
      character(MAX_STR_LEN) :: filePath,reactionIndexStr
      character(EIRAM_FILE_NAME_LENGTH) :: fileName
      character(EIRAM_TYPE_LENGTH) :: reactionType
      character(EIRAM_INDEX_LENGTH),allocatable :: reactionIndex(:)

      integer :: numberOfArgs,n_reactions,reactions_length,i,j,ind
      logical :: lPath,fileExists
      intrinsic trim,min

      if (nrhs < 4) 
     f    call mexerrmsgtxt('More than three inputs required.')


      if( mxisnumeric(prhs(1)) /= 1 ) 
     f    call mexerrmsgtxt('Input # 1 must be a numeric array.')
      if( mxisnumeric(prhs(2)) == 1 ) then 
        numberofargs = 2
      else 
        numberofargs = 1
      end if

      if( numberofargs == 1 ) then
       if (nrhs > 5) 
     f     call mexerrmsgtxt('Four or five inputs required.')
       if(mxischar(prhs(2)) /= 1) 
     f    call mexerrmsgtxt('Input # 2 must be a string.')
       if(mxischar(prhs(3)) /= 1) 
     f    call mexerrmsgtxt('Input # 3 must be a string.')
       if(mxischar(prhs(4)) /= 1) 
     f    call mexerrmsgtxt('Input # 4 must be a string.')
       if (nrhs > 4) then  
        if(mxischar(prhs(5)) /= 1) 
     f    call mexerrmsgtxt('Input # 5 must be a string.')      
         lpath=.true.
       else
         lpath=.false.  
       end if 
      end if 

      if( numberofargs == 2 ) then
       if (nrhs > 6 .or. nrhs < 5) 
     f     call mexerrmsgtxt('Five or six inputs required.')
       if(mxischar(prhs(3)) /= 1) 
     f    call mexerrmsgtxt('Input # 3 must be a string.')
       if(mxischar(prhs(4)) /= 1) 
     f    call mexerrmsgtxt('Input # 4 must be a string.')
       if(mxischar(prhs(5)) /= 1) 
     f    call mexerrmsgtxt('Input # 5 must be a string.')
       if (nrhs > 5) then  
        if(mxischar(prhs(6)) /= 1) 
     f    call mexerrmsgtxt('Input # 6 must be a string.')      
         lpath=.true.
       else
         lpath=.false.  
       end if 
      end if 
      
      narg1s = mxgetn(prhs(1))
      if(mxgetm(prhs(1)) /= 1) then
          call mexerrmsgtxt('Input #1 must be a row vector.')
      endif

      arg1s_pr = mxgetpr(prhs(1))
      if(numberofargs == 2) then
          arg2s_pr = mxgetpr(prhs(2))
          narg2s = mxgetn(prhs(2))
          if(mxgetm(prhs(2)) /= 1) then
              call mexerrmsgtxt('Input #2 must be a row vector.')
          endif
      else
          narg2s = 0
      endif

      n_reactions = mxgetm(prhs(numberofargs+3))
      reactions_length = mxgetn(prhs(numberofargs+3))

      allocate(reactionindex(n_reactions))

      err=mxgetstring(prhs(numberofargs+1),filename,
     ,                eiram_file_name_length)
      err=mxgetstring(prhs(numberofargs+2),
     ,                     reactiontype,eiram_type_length)
      err=mxgetstring(prhs(numberofargs+3),
     ,                     reactionindexstr,max_str_len)
      if(lpath) then 
       err=mxgetstring(prhs(numberofargs+4),filepath, max_str_len)
      else
       filepath=""
      end if
      !for reaction index divide long string into substrings
      reactionindex = " "
      do i = 1, n_reactions
        do j = 1, min(reactions_length,eiram_index_length)
           ind = (j-1)*n_reactions+i
           reactionindex(i)(j:j) = reactionindexstr(ind:ind)
        end do 
      end do

      !convert 1st (and 2nd - if required) argument into array of reals
      allocate(arg1s(narg1s))
      call mxcopyptrtoreal8(arg1s_pr, arg1s, narg1s)
      if(narg2s >0) then
         allocate(arg2s(narg2s))
         call mxcopyptrtoreal8(arg2s_pr, arg2s, narg2s)
      end if
            
      eiram_unit = 0
      
      call eiram_load(filepath, filename, err)
      if(err /= 0) then
        call eiram_deallocate(err0)
        select case(err)
         case(310) 
           call mexerrmsgtxt('Input file '//trim(filepath)
     /                      //trim(filename)//' is not found.')
         case(300)
           call mexerrmsgtxt('Cannot read input file '
     /                     //trim(filepath)//trim(filename))
         case default
          call mexerrmsgtxt("error during initialization of EIRAM")
        end select 
      end if
      
      if (narg2s>0) then
       allocate(ys(narg2s,narg1s,n_reactions))
      else
       allocate(ys(narg1s,1,n_reactions))
      end if

      do i=1,n_reactions      
       if(narg2s > 0) then  
        call eiram_matlab_calc2(ys(:,:,i),arg1s,arg2s,narg1s,narg2s,
     &                    filename,reactiontype,reactionindex(i),err)
       else 
         call eiram_matlab_calc1(ys(:,1,i),arg1s,narg1s,
     &               filename,reactiontype,reactionindex(i),err)
       end if ! if(nArg2s > 0) then  
       if(err /= 0) call eiram_deallocate(err0)
       select case(err)
       case(11)
         call mexerrmsgtxt("error : negative argument")
       case(12)
         call mexerrmsgtxt("error : negative 1st argument")
       case(13)
         call mexerrmsgtxt("error : negative 2nd argument")
       case(110)
         call mexerrmsgtxt("error: requested reaction "
     /            //trim(filename)//" "//trim(reactiontype)//" "
     /           //trim(reactionindex(i))//" is not found")
       case(120)
         call mexerrmsgtxt("error: double fit is requested for reaction"
     /                     //" described by a single fit")
       case(130)
         call mexerrmsgtxt("error: single fit is requested for reaction"
     /                    //" described by a double fit")
       case default
         if(err/=0) call mexerrmsgtxt("error in EIRAM")
       end select
      end do !do i=1,n_combinations

      do i=1,n_reactions
       if(narg2s > 0) then  
        plhs(i) = mxcreatedoublematrix(narg2s,narg1s,0)
       else
        plhs(i) = mxcreatedoublematrix(narg1s,1,0)
       end if
       ys_pr = mxgetpr(plhs(i))
       call mxcopyreal8toptr(ys(:,:,i), ys_pr, max(1,narg2s)*narg1s)
      end do 

      call eiram_deallocate(err)

      deallocate(reactionindex)      
      deallocate(arg1s)
      if(allocated(arg2s)) deallocate(arg2s)
      deallocate(ys)
      
      end subroutine mexfunction