C-------------------------------------------------------------------- C C This is a MATLAB MEX-file interface to IVP_Testset problems C C Call C mproblem('Prob'), mproblem(double('Prob')) C mproblem('Init'), mproblem(double('Init')) C mproblem('Feval'), mproblem(double('Feval')) C mproblem('Jeval'), mproblem(double('Jeval')) C mproblem('Meval'), mproblem(double('Meval')) C mproblem('Solut'), mproblem(double('Solut')) C C mproblem('Tolerance'), mproblem(double('Tolerance')) C mproblem('Report'), mproblem(double('Report')) C C mproblem('Help'), mproblem(double('Help')) C C--------------------------------------------------------------------- C This file is part of the Test Set for IVP solvers C http://www.dm.uniba.it/~testset/ C C C DISCLAIMER: see C http://www.dm.uniba.it/~testset/disclaimer.html C C The most recent version of this source file can be found at C http://www.dm.uniba.it/~testset/src/drivers/matlab_interface.f C C This is revision C C----------------------------------------------------------------------- C MATLAB/FORTRAN interface header file #include "fintrf.h" C Set array limits #define MAX_IPAR 100 #define MAX_NAME 32 #define MAX_NEQN 1000 #define MAX_DISC 100 #define MAX_FLAG 20 #define MAX_EMSG 100 #define MAX_WMSG 200 #define MAX_HELP 1000 #define NEWLN char(10) C The gateway routine subroutine mexFunction(nlhs, plhs, nrhs, prhs) implicit none integer*4 nlhs, nrhs mwpointer plhs(*), prhs(*) integer*4 mxGetNumberOfElements integer*4 mxIsChar integer*4 mxIsDouble integer*4 mxGetString real*8 mxGetScalar character*(MAX_FLAG) flag_str character flag integer*4 iflag integer*4 status character*(MAX_EMSG) err_msg C Check for proper number of arguments. if (nrhs .lt. 1) then err_msg = ' Not enough inputs...' call call_syntax_error(err_msg) return endif C Extract the flag (first letter only) iflag = -1 if (mxIsChar(prhs(1)) .eq. 1) then status = mxGetString(prhs(1), flag_str, MAX_FLAG) flag = flag_str(1:1) elseif (mxIsDouble(prhs(1)) .eq. 1) then C this is a work-arround ml7/win/mingw/gcc/gnumex defficiency flag = char(int(mxGetScalar(prhs(1)))) else err_msg = ' First argument (flag) must be a string '// & 'or double(string)' call call_syntax_error(err_msg) endif C Switch on the value of flag or iflag if ((flag .eq. 'f') .or. (flag .eq. 'F')) then C [f,ierr,rpar,ipar] = fcn('Feval',neq,t,y,yp,rpar,ipar) call call_feval(nlhs,plhs,nrhs,prhs) elseif ((flag .eq. 'j') .or. (flag .eq. 'J')) then C [J,ierr,rpar,ipar] = fcn('Jeval',ldim,neq,t,y,yp,rpar,ipar) call call_jeval(nlhs,plhs,nrhs,prhs) elseif ((flag .eq. 'm') .or. (flag .eq. 'M')) then C [M,ierr,rpar,ipar] = fcn('Meval',ldim,neq,t,y,yp,rpar,ipar) call call_meval(nlhs,plhs,nrhs,prhs) elseif ((flag .eq. 'p') .or. (flag .eq. 'P')) then C case probdef = mproblem('Problem') call call_problem(nlhs,plhs,nrhs,prhs) elseif ((flag .eq. 'i') .or. (flag .eq. 'I')) then C [y,yprime,consis] = fcn('Init',neq,t) call call_init(nlhs,plhs,nrhs,prhs) elseif ((flag .eq. 's') .or. (flag .eq. 'S')) then C [y] = fcn('Solut',neq,t) call call_solut(nlhs,plhs,nrhs,prhs) elseif ((flag .eq. 'r') .or. (flag .eq. 'R')) then C [mescd,scd] = fcn('Report',neq,yref,y,double(probnm),tolvec,atol,rtol) call call_report(nlhs,plhs,nrhs,prhs) elseif ((flag .eq. 't') .or. (flag .eq. 'T')) then C [atol,rtol] = fcn('Tolerance',neq,atol,rtol) call call_settolerances(nlhs,plhs,nrhs,prhs) elseif ((flag .eq. 'h') .or. (flag .eq. 'H')) then C fcn('Help') call call_help() else err_msg = ' Unrecognized flag passed. ' call call_syntax_error(err_msg) endif return end C ====================================================================== subroutine create_help_msg(msg) implicit none character*(*) msg msg = & 'Call PROBLEM_MINTERFACE using one of the following '// & 'options: '// NEWLN // & ' PROB = PROBLEM_MINTERFACE(''Prob'') '// NEWLN // & ' [Y0,YP0,CONSIST] = PROBLEM_MINTERFACE'// & '(''Init'',NEQ,T0) '// NEWLN // & ' [F,IERR,RPAR,IPAR] = PROBLEM_MINTERFACE'// & '(''Feval'',NEQ,T,Y,YP,RPAR,IPAR)'// NEWLN // & ' [J,IERR,RPAR,IPAR] = PROBLEM_MINTERFACE'// & '(''Jeval'',LDIM,NEQ,T,Y,YP,RPAR,IPAR)'// NEWLN// & ' [M,IERR,RPAR,IPAR] = PROBLEM_MINTERFACE'// & '(''Meval'',LDIM,NEQ,T,Y,YP,RPAR,IPAR)'// NEWLN// & ' YFINAL = PROBLEM_MINTERFACE(''Solut'',NEQ,T) '// NEWLN // & ' [ATOL,RTOL] = PROBLEM_MINTERFACE(''Tolerance'','// & 'NEQ,ATOL,RTOL) '// NEWLN // & ' [MESCD,SCD] = PROBLEM_MINTERFACE(''Report'','// & 'NEQ,YREF,Y,PROBNAME,TOLVEC,ATOL,RTOL)'// NEWLN// & ' or '// NEWLN // & ' PROBLEM_MINTERFACE(''Help'')'// NEWLN // & 'NOTE: Sometimes we found it necessary to convert ''flag'' '// & 'to doubles, i.e., '// NEWLN // & ' [...] = PROBLEM_MINTERFACE(double(''Feval''),...)'// & NEWLN return end C ====================================================================== subroutine call_help() implicit none character*(MAX_HELP) helpmsg integer*4 mexPrintf integer*4 nchar call create_help_msg(helpmsg) nchar = mexPrintf( NEWLN // helpmsg) return end C ====================================================================== subroutine call_syntax_error(msg) implicit none character*(MAX_EMSG) msg character*(MAX_HELP) helpmsg integer*4 mexPrintf integer*4 nchar C Report the error nchar = mexPrintf('Error detected:' // msg ) call create_help_msg(helpmsg) call mexErrMsgTxt( NEWLN // & 'Incorrect syntax of PROBLEM_MINTERFACE(flag,...). ' // & NEWLN // helpmsg) return end C ====================================================================== subroutine call_runtime_error(problem, msg) implicit none character*(MAX_NAME) problem character*(MAX_EMSG) msg integer*4 mexPrintf integer*4 nchar C Report the error nchar = mexPrintf('Runtime error detected in problem ' // & problem) call mexErrMsgTxt( NEWLN // msg // NEWLN) return end C ====================================================================== subroutine call_init(nlhs, plhs, nrhs, prhs) implicit none integer*4 nlhs, nrhs mwpointer plhs(*), prhs(*) mwpointer mxGetPr mwpointer mxCreateDoubleMatrix mwpointer mxCreateScalarDouble mwpointer mxDuplicateArray real*8 mxGetScalar integer*4 neqn,i real*8 t logical consis mwpointer out(3) character*(MAX_EMSG) err_msg C Syntax if (nrhs .ne. 3) then err_msg = ' Not enough inputs to call f(''Init'',NEQ,T0)' call call_syntax_error(err_msg) endif C Input neqn = int(mxGetScalar(prhs(2))) t = mxGetScalar(prhs(3)) C Output out(1) = mxCreateDoubleMatrix(neqn, 1, 0) out(2) = mxCreateDoubleMatrix(neqn, 1, 0) out(3) = mxCreateDoubleMatrix(1, 1, 0) C Call the problem (sub)routine consis = .false. call init(neqn,t,%val(mxGetPr(out(1))), & %val(mxGetPr(out(2))),consis) if (consis) then out(3) = mxCreateScalarDouble(1.0d0) else out(3) = mxCreateScalarDouble(0.0d0) endif do 10 i=1,nlhs plhs(i) = mxDuplicateArray(out(i)) 10 continue call mxDestroyArray(out(1)) call mxDestroyArray(out(2)) call mxDestroyArray(out(3)) return end C ====================================================================== subroutine call_feval(nlhs, plhs, nrhs, prhs) implicit none integer*4 nlhs, nrhs mwpointer plhs(*), prhs(*) integer*4 mxGetM, mxGetN, mxGetNumberOfElements mwpointer mxGetPr mwpointer mxCreateScalarDouble mwpointer mxCreateDoubleMatrix mwpointer mxDuplicateArray real*8 mxGetScalar integer*4 neqn,i real*8 t integer*4 ierr integer*4 ipar(MAX_IPAR) real*8 dipar(MAX_IPAR) integer*4 mipar,nipar mwpointer out(4) character*(MAX_EMSG) err_msg C Syntax if (nrhs .ne. 7) then err_msg = ' Not enough inputs ' // & 'to call f(''Feval'',neq,t,y,yp,rpar,ipar)' call call_syntax_error(err_msg) endif C Input t = mxGetScalar(prhs(3)) neqn = mxGetNumberOfElements(prhs(4)) if (neqn .ne. mxGetScalar(prhs(2))) then err_msg = ' Inconsistent neqn and length(y)' call call_syntax_error(err_msg) endif mipar = mxGetM(prhs(7)) nipar = mxGetN(prhs(7)) if ((mipar*nipar) .gt. MAX_IPAR) then err_msg = ' numel(ipar) must not exceed 100' call call_syntax_error(err_msg) endif C Output -- create out(1) = mxCreateDoubleMatrix(neqn, 1, 0) out(3) = mxDuplicateArray(prhs(6)) C Call the problem (sub)routine ierr = 0 call mxCopyPtrToReal8(mxGetPr(prhs(7)),dipar,mipar*nipar) do 10 i=1,(mipar*nipar) ipar(i) = int(dipar(i)) 10 continue call feval(neqn,t, & %val(mxGetPr(prhs(4))), & %val(mxGetPr(prhs(5))), & %val(mxGetPr(out(1))), & ierr, & %val(mxGetPr(out(3))), & ipar) out(2) = mxCreateScalarDouble(dble(ierr)) out(4) = mxCreateDoubleMatrix(mipar,nipar,0) do 20 i=1,(mipar*nipar) dipar(i) = dble(ipar(i)) 20 continue call mxCopyReal8ToPtr(dipar,mxGetPr(out(4)),mipar*nipar) do 30 i=1,nlhs plhs(i) = mxDuplicateArray(out(i)) 30 continue call mxDestroyArray(out(1)) call mxDestroyArray(out(2)) call mxDestroyArray(out(3)) call mxDestroyArray(out(4)) return end C ====================================================================== subroutine call_jeval(nlhs, plhs, nrhs, prhs) implicit none integer*4 nlhs, nrhs mwpointer plhs(*), prhs(*) integer*4 mxGetM, mxGetN, mxGetNumberOfElements mwpointer mxGetPr mwpointer mxCreateScalarDouble mwpointer mxCreateDoubleMatrix mwpointer mxDuplicateArray real*8 mxGetScalar integer*4 neqn,ldim,i real*8 t integer*4 ierr integer*4 ipar(MAX_IPAR) real*8 dipar(MAX_IPAR) integer*4 mipar,nipar mwpointer out(4) character*(MAX_EMSG) err_msg C Syntax if (nrhs .ne. 8) then err_msg = ' Not enough inputs ' // & 'to call f(''Jeval'',ldim,neq,t,y,yp,rpar,ipar)' call call_syntax_error(err_msg) endif C Input ldim = int(mxGetScalar(prhs(2))) t = mxGetScalar(prhs(4)) neqn = mxGetNumberOfElements(prhs(5)) if (neqn .ne. int(mxGetScalar(prhs(3)))) then err_msg = ' Inconsistent neqn and length(y)' call call_syntax_error(err_msg) endif mipar = mxGetM(prhs(8)) nipar = mxGetN(prhs(8)) if ((mipar*nipar) .gt. MAX_IPAR) then err_msg = ' numel(ipar) must not exceed 100' call call_syntax_error(err_msg) endif C Output -- create out(1) = mxCreateDoubleMatrix(ldim,neqn, 0) out(3) = mxDuplicateArray(prhs(7)) C Call the problem (sub)routine ierr = 0 call mxCopyPtrToReal8(mxGetPr(prhs(8)),dipar,mipar*nipar) do 10 i=1,(mipar*nipar) ipar(i) = int(dipar(i)) 10 continue call jeval(ldim,neqn,t, & %val(mxGetPr(prhs(5))), & %val(mxGetPr(prhs(6))), & %val(mxGetPr(out(1))), & ierr, & %val(mxGetPr(out(3))), & ipar) out(2) = mxCreateScalarDouble(dble(ierr)) out(4) = mxCreateDoubleMatrix(mipar,nipar,0) do 20 i=1,(mipar*nipar) dipar(i) = dble(ipar(i)) 20 continue call mxCopyReal8ToPtr(dipar,mxGetPr(out(4)),mipar*nipar) do 30 i=1,nlhs plhs(i) = mxDuplicateArray(out(i)) 30 continue call mxDestroyArray(out(1)) call mxDestroyArray(out(2)) call mxDestroyArray(out(3)) call mxDestroyArray(out(4)) return end C ====================================================================== subroutine call_meval(nlhs, plhs, nrhs, prhs) implicit none integer*4 nlhs, nrhs mwpointer plhs(*), prhs(*) integer*4 mxGetM, mxGetN, mxGetNumberOfElements mwpointer mxGetPr mwpointer mxCreateScalarDouble mwpointer mxCreateDoubleMatrix mwpointer mxDuplicateArray real*8 mxGetScalar integer*4 neqn,ldim,i real*8 t integer*4 ierr integer*4 ipar(MAX_IPAR) real*8 dipar(MAX_IPAR) integer*4 mipar,nipar mwpointer out(4) character*(MAX_EMSG) err_msg C Syntax if (nrhs .ne. 8) then err_msg = ' Not enough inputs ' // & 'to call f(''Meval'',ldim,neq,t,y,yp,rpar,ipar)' call call_syntax_error(err_msg) endif C Input ldim = int(mxGetScalar(prhs(2))) t = mxGetScalar(prhs(4)) neqn = mxGetNumberOfElements(prhs(5)) if (neqn .ne. int(mxGetScalar(prhs(3)))) then err_msg = ' Inconsistent neqn and length(y)' call call_syntax_error(err_msg) endif mipar = mxGetM(prhs(8)) nipar = mxGetN(prhs(8)) if ((mipar*nipar) .gt. MAX_IPAR) then err_msg = ' numel(ipar) must not exceed 100' call call_syntax_error(err_msg) endif C Output -- create out(1) = mxCreateDoubleMatrix(ldim,neqn, 0) out(3) = mxDuplicateArray(prhs(7)) C Call the problem (sub)routine ierr = 0 call mxCopyPtrToReal8(mxGetPr(prhs(8)),dipar,mipar*nipar) do 10 i=1,(mipar*nipar) ipar(i) = int(dipar(i)) 10 continue call meval(ldim,neqn,t, & %val(mxGetPr(prhs(5))), & %val(mxGetPr(prhs(6))), & %val(mxGetPr(out(1))), & ierr, & %val(mxGetPr(out(3))), & ipar) out(2) = mxCreateScalarDouble(dble(ierr)) out(4) = mxCreateDoubleMatrix(mipar,nipar,0) do 20 i=1,(mipar*nipar) dipar(i) = dble(ipar(i)) 20 continue call mxCopyReal8ToPtr(dipar,mxGetPr(out(4)),mipar*nipar) do 30 i=1,nlhs plhs(i) = mxDuplicateArray(out(i)) 30 continue call mxDestroyArray(out(1)) call mxDestroyArray(out(2)) call mxDestroyArray(out(3)) call mxDestroyArray(out(4)) return end C ====================================================================== subroutine call_problem(nlhs, plhs, nrhs, prhs) implicit none integer nlhs, nrhs mwpointer plhs(*), prhs(*) mwpointer mxGetPr mwpointer mxCreateString mwpointer mxCreateScalarDouble mwpointer mxCreateDoubleMatrix integer*4 neqn,ndisc real*8 t(0:MAX_DISC+1) logical numjac integer*4 mljac,mujac logical nummas integer*4 mlmas,mumas integer*4 ind(MAX_NEQN) real*8 dind(MAX_NEQN) integer*4 i mwpointer mxCreateStructMatrix mwpointer tmp character*(MAX_EMSG) err_msg character*512 fullnm character*(MAX_NAME) problm character*3 type character*8 fieldnames(13) fieldnames(1) = 'fullnm' fieldnames(2) = 'problm' fieldnames(3) = 'type' fieldnames(4) = 'neqn' fieldnames(5) = 'ndisc' fieldnames(6) = 't' fieldnames(7) = 'numjac' fieldnames(8) = 'mljac' fieldnames(9) = 'mujac' fieldnames(10) = 'nummas' fieldnames(11) = 'mlmas' fieldnames(12) = 'mumas' fieldnames(13) = 'ind' neqn = 0 ndisc = 0 numjac = .true. mljac = 0 mujac = 0 nummas = .true. mlmas = 0 mumas = 0 do 10 i=1,MAX_NEQN ind(i) = 0 10 continue call prob(fullnm,problm,type, & neqn,ndisc,t, & numjac,mljac,mujac, & nummas,mlmas,mumas, & ind) if (neqn .gt. MAX_NEQN) then write(err_msg,'(a,i0,a,i0,a)') & 'Problem reports ',neqn, ' equations,' // & ' while this MATLAB interface only supports' // & ' up to ', MAX_NEQN, ' equations.' call call_runtime_error(problm,err_msg) endif if (ndisc .gt. MAX_DISC) then write(err_msg,'(a,i0,a,i0,a)') & 'Problem reports ',ndisc, ' discontinuities,' // & ' while this MATLAB interface supports up to ', & MAX_DISC, ' discontinuities.' call call_runtime_error(problm,err_msg) endif plhs(1) = mxCreateStructMatrix(1,1,13,fieldnames) tmp = mxCreateString(fullnm) call mxSetFieldByNumber(plhs(1),1,1,tmp) tmp = mxCreateString(problm) call mxSetFieldByNumber(plhs(1),1,2,tmp) tmp = mxCreateString(type) call mxSetFieldByNumber(plhs(1),1,3,tmp) tmp = mxCreateScalarDouble(dble(neqn)) call mxSetFieldByNumber(plhs(1),1,4,tmp) tmp = mxCreateScalarDouble(dble(ndisc)) call mxSetFieldByNumber(plhs(1),1,5,tmp) tmp = mxCreateDoubleMatrix(1,ndisc+2,0) call mxCopyReal8ToPtr(t,mxGetPr(tmp),ndisc+2) call mxSetFieldByNumber(plhs(1),1,6,tmp) if (numjac) then tmp = mxCreateScalarDouble(1.0d0) else tmp = mxCreateScalarDouble(0.0d0) endif call mxSetFieldByNumber(plhs(1),1,7,tmp) tmp = mxCreateScalarDouble(dble(mljac)) call mxSetFieldByNumber(plhs(1),1,8,tmp) tmp = mxCreateScalarDouble(dble(mujac)) call mxSetFieldByNumber(plhs(1),1,9,tmp) if (nummas) then tmp = mxCreateScalarDouble(1.0d0) else tmp = mxCreateScalarDouble(0.0d0) endif call mxSetFieldByNumber(plhs(1),1,10,tmp) tmp = mxCreateScalarDouble(dble(mlmas)) call mxSetFieldByNumber(plhs(1),1,11,tmp) tmp = mxCreateScalarDouble(dble(mumas)) call mxSetFieldByNumber(plhs(1),1,12,tmp) tmp = mxCreateDoubleMatrix(neqn,1,0) do 20 i=1,neqn dind(i) = dble(ind(i)) 20 continue call mxCopyReal8ToPtr(dind,mxGetPr(tmp),neqn) call mxSetFieldByNumber(plhs(1),1,13,tmp) return end C ====================================================================== subroutine call_solut(nlhs, plhs, nrhs, prhs) implicit none integer*4 nlhs, nrhs mwpointer plhs(*), prhs(*) mwpointer mxGetPr mwpointer mxCreateDoubleMatrix real*8 mxGetScalar integer*4 neqn real*8 t character*(MAX_EMSG) err_msg C Syntax if (nrhs .ne. 3) then err_msg = ' Not enough inputs ' // & 'to call f(''Solut'',neq,t)' call call_syntax_error(err_msg) endif C Input neqn = int(mxGetScalar(prhs(2))) t = mxGetScalar(prhs(3)) C Output -- create plhs(1) = mxCreateDoubleMatrix(neqn, 1, 0) call solut(neqn,t, & %val(mxGetPr(plhs(1)))) return end C ====================================================================== subroutine call_report(nlhs, plhs, nrhs, prhs) implicit none integer*4 nlhs, nrhs mwpointer plhs(*), prhs(*) integer*4 mxIsChar, mxIsDouble integer*4 mxGetString integer*4 mxGetNumberOfElements mwpointer mxGetPr real*8 mxGetScalar mwpointer mxCreateScalarDouble real*8 atol(MAX_NEQN),rtol(MAX_NEQN) real*8 atol1,rtol1 real*8 y(MAX_NEQN),yref(MAX_NEQN) real*8 dname(MAX_NAME) integer*4 lenname,i integer*4 status logical tolvec real*8 tmp integer*4 neqn real*8 mescd,scd character*(MAX_NAME) problm character*(MAX_EMSG) err_msg character*(MAX_WMSG) warn_msg C Syntax if (nrhs .ne. 8) then err_msg = ' Not enough inputs ' // & 'to call f(''Report'',neq,yref,y,prbname,tolvec,atol,rtol)' call call_syntax_error(err_msg) endif C Input call mxCopyPtrToReal8(mxGetPr(prhs(2)),tmp,1) neqn = int(tmp) lenname = min( mxGetNumberOfElements(prhs(5)), MAX_NAME) if (mxIsChar(prhs(5)) .eq. 1) then status = mxGetString(prhs(5), problm, lenname) if (status .ne. 0) then warn_msg = 'In call to f(''Report'',neq,yref,y,' // & 'problem_name,tolvec,atol,rtol),' // NEWLN // & 'the problem name was truncated to '' ' // & problm // ' ''' call mexWarnMsgTxt(warn_msg) endif elseif (mxIsDouble(prhs(5)) .eq. 1) then C this is a work-arround ml7/win/mingw/gcc/gnumex defficiency call mxCopyPtrToReal8(mxGetPr(prhs(5)),dname,lenname) do 10 i=1,lenname problm(i:i) = char(int(dname(i))) 10 continue else err_msg = ' Fifth argument (problem_name) must be' // & ' a string or double(string)' call call_syntax_error(err_msg) endif call mxCopyPtrToReal8(mxGetPr(prhs(6)),tmp,1) tolvec = ( int(tmp) .ne. 0) if (tolvec) then call mxCopyPtrToReal8(mxGetPr(prhs(7)),atol,neqn) call mxCopyPtrToReal8(mxGetPr(prhs(8)),rtol,neqn) else call mxCopyPtrToReal8(mxGetPr(prhs(7)),atol1,1) call mxCopyPtrToReal8(mxGetPr(prhs(8)),rtol1,1) do 20 i=1,neqn atol(i) = atol1 rtol(i) = rtol1 20 continue endif C Output: initialize mescd = 0.0d0 scd = 0.0d0 call mxCopyPtrToReal8(mxGetPr(prhs(3)),yref,neqn) call mxCopyPtrToReal8(mxGetPr(prhs(4)),y,neqn) call getscd(mescd,scd,neqn, & yref, & y, & problm(1:lenname),tolvec, & atol, rtol,.false.) C Output: extract plhs(1) = mxCreateScalarDouble(mescd) if (nlhs .ge. 2) then plhs(2) = mxCreateScalarDouble(scd) endif return end C ====================================================================== subroutine call_settolerances(nlhs, plhs, nrhs, prhs) implicit none integer*4 nlhs, nrhs mwpointer plhs(*), prhs(*) integer*4 mxIsChar, mxIsDouble integer*4 mxGetString integer*4 mxGetNumberOfElements mwpointer mxGetPr real*8 mxGetScalar mwpointer mxCreateDoubleMatrix real*8 atol(MAX_NEQN),rtol(MAX_NEQN) real*8 atol1,rtol1 integer*4 ntol,neqn logical tolvec integer*4 i integer*4 status character*(MAX_EMSG) err_msg C Syntax if (nrhs .ne. 4) then err_msg = ' Not enough inputs' // & ' to call f(''Tolerance'',neq,atol,rtol) ' call call_syntax_error(err_msg) endif neqn = mxGetScalar(prhs(2)) atol1 = mxGetScalar(prhs(3)) rtol1 = mxGetScalar(prhs(4)) atol(1)=atol1 rtol(1)=rtol1 call settolerances(neqn,rtol,atol,tolvec) if (tolvec) then ntol = neqn else ntol = 1 end if plhs(1) = mxCreateDoubleMatrix(ntol, 1, 0) call mxCopyReal8ToPtr(atol,mxGetPr(plhs(1)),ntol) if (nlhs .eq. 2) then plhs(2) = mxCreateDoubleMatrix(ntol, 1, 0) call mxCopyReal8ToPtr(rtol,mxGetPr(plhs(2)),ntol) endif return end C [EOF] matlab_interface.F