Перейти из форума на сайт.

НовостиФайловые архивы
ПоискАктивные темыТоп лист
ПравилаКто в on-line?
Вход Забыли пароль? Первый раз на этом сайте? Регистрация
Компьютерный форум Ru.Board » Компьютеры » Прикладное программирование » Вопросы программирования на FORTRAN (ФОРТРАН)

Модерирует : ShIvADeSt

 Версия для печати • ПодписатьсяДобавить в закладки
На первую страницук этому сообщениюк последнему сообщению

Открыть новую тему     Написать ответ в эту тему

unni



Newbie
Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору


Код:
 
module mcadincl
 
    use ifwin    
 
    ! Источник: http://rosettacode.org/wiki/Variadic_function
    abstract interface
 
!        integer ( LRESULT ) function LPCFUNCTION( arglist )
!        !DEC$ ATTRIBUTES C :: LPCFUNCTION
!            
!            use ifwin
!            
!            implicit none
!            
!            integer (4), dimension(:), intent(in) :: arglist
!        
!        end function
 
        ! Внимание. В этом шаблоне подразумевается, что параметры передаются по ссылке
        integer ( LRESULT ) function LPCFUNCTION( ReturnValue, Arg0 )
             
            use ifwin
             
            implicit none
             
            ! Здесь мы используем встроенный тип, т.к. он полностью совпадает
            ! с описанием типа COMPLEXSCALAR в mcadincl.h            
            double complex, intent(in) :: ReturnValue
            double complex, intent(in) :: Arg0
         
        end function
 
    end interface
 
    ! Константы для задания типов аргументов функций и результата
     
    ! Скаляр
    integer, parameter :: COMPLEX_SCALAR = 1
     
    ! Массив
    integer, parameter :: COMPLEX_ARRAY = 2
 
    ! Строка
    integer, parameter :: MATHCAD_STRING = 8
     
    ! Максимальное число аргументов функции    
    integer, parameter :: MAX_ARGS = 10  
         
    ! Скалярная величина
    type COMPLEXSCALAR
 
        real (8) Re
        real (8) Im
         
    end type
 
    ! Массив в MathCAD
    type COMPLEXARRAY
     
        integer ( UINT ) rows ! число строк
        integer ( UINT ) cols ! число столбцов
!        hReal: tPtrToMatrix; // действительная часть = NIL, если отсутствует
!        hImag: tPtrToMatrix; // мнимая часть = NIL, если отсутствует
 
    end type
   
    ! Информация для регистрации функции
    type FUNCTIONINFO
         
        ! Имя, под которым будет использоваться внутри Mathcad (чувствительно к регистру букв)
        character ( 256 ), pointer :: lpstrName
         
        ! Перечень параметров (только как информационное сообщение)
        character ( 256 ), pointer :: lpstrParameters
         
        ! Описание (только как информационное сообщение)
        character ( 256 ), pointer :: lpstrDescription
         
        ! Указатель на функцию
        ! Источник: http://scicomp.stackexchange.com/questions/285/how-to-work-with-function-pointers-in-fortran-in-scientific-programs
        procedure ( LPCFUNCTION ), nopass, pointer :: lpfnMyCFunction
         
        ! Тип возвращаемого значения
        integer ( UINT ) :: returnType
         
        ! Число аргументов
        integer ( UINT ) :: nArgs
         
        ! Типы аргументов
        integer ( UINT ), dimension ( MAX_ARGS ) :: argType
         
    end type    
         
    contains
     
!    ! Источник: http://rosettacode.org/wiki/Variadic_function
!    integer ( LRESULT ) function mcad_TestFunc1( arglist )
!    !DEC$ ATTRIBUTES C :: mcad_TestFunc1
!        
!        use ifwin
!        
!        implicit none
!
!        integer (4), dimension(:), intent(in) :: arglist
!        
!        ! Инициализируем значение функции признаком успешного завершения
!        ! работы (см. The Developer's Reference в справке Mathcad)
!        mcad_TestFunc1 = 0
!        
!    end function
 
    integer ( LRESULT ) function mcad_TestFunc1( ReturnValue, Arg0 )
 
        use ifwin
         
        implicit none
         
        double complex, intent(out) :: ReturnValue
        double complex, intent(in) :: Arg0
         
        ReturnValue = Arg0
       
        ! Инициализируем значение функции признаком успешного завершения
        ! работы (см. The Developer's Reference в справке Mathcad)
        mcad_TestFunc1 = 0
         
    end function mcad_TestFunc1
 
end module mcadincl    
     
 
!********************************************************************
!*   FUNCTION: DllMain(HANDLE, DWORD, LPVOID)
!*
!*   PURPOSE:  DllMain is called by Windows when
!*     the DLL is initialized, Thread Attached, and other times.
!*     Refer to SDK documentation, as to the different ways this
!*     may be called.
!*
!*     The DllMain function should perform additional initialization
!*     tasks required by the DLL.  DllMain should return a value of 1
!*     if the initialization is successful.
!*
!* Источник: http://h21007.www2.hp.com/portal/download/files/unprot/Fortran/docs/vf-html/pg/pgmindll.htm
!* Источник: http://objectmix.com/fortran/351982-issues-c-fortran-loadlibrary-getprocaddress.html
!*
!*********************************************************************
 
logical(BOOL) function DllMain( hinstDll, fdwReason, lpvReserved )
 
    !DEC$ IF DEFINED(_X86_)
    !DEC$ ATTRIBUTES DEFAULT, STDCALL, ALIAS : '_DllMain@12' :: DllMain
    !DEC$ ELSE
    !DEC$ ATTRIBUTES DEFAULT, STDCALL, ALIAS : 'DllMain' :: DllMain
    !DEC$ ENDIF
   
    use ifwin
    use mcadincl
     
    implicit none
 
 
    ! Описание прототипов функций библиотеки mcaduser.dll
    interface            
         
        ! const void * CreateUserFunction( HINSTANCE, FUNCTIONINFO * );
        integer( LPVOID ) function CreateUserFunction( hInstance, pFunctionInfo )  
        !DEC$ ATTRIBUTES C :: CreateUserFunction
         
            use ifwin  
            use mcadincl
             
            integer( HANDLE ), intent( in ) :: hInstance
            type ( FUNCTIONINFO ), pointer, intent( in ) :: pFunctionInfo
             
        end function  
 
!        void MathcadFree( char * address );
        subroutine MathcadFree( address )  
         
            use ifwin  
 
            integer( LPVOID ), intent( in ) :: address
             
        end subroutine  
         
!        function CreateUserErrorMessageTable( hInstance, nErrorMessages, ErrorMessageTable )
!            
!            use ifwinty
!            
!            logical( BOOL ) PCREATEUSERERRORMESSAGETABLE
!            integer( HANDLE ), intent( in ) :: hInstance
!            integer( DWORD ), intent( in ) :: nErrorMessages
!            integer( LPVOID ), intent( in ) :: ErrorMessageTable
!            
!        end function CreateUserErrorMessageTable
!        
        logical( BOOL ) function isUserInterrupted()
             
            use ifwinty
 
        end function isUserInterrupted
         
    end interface  
 
    ! Назначение указателей
    pointer( PCREATE_USER_FUNCTION, CreateUserFunction )
!    pointer( PCREATE_USERERROR_MESSAGE_TABLE, CreateUserErrorMessageTable )
!    pointer( PMATHCADALLOCATE, MathcadAllocate )
    pointer( PMATHCADFREE, MathcadFree )
!    pointer( PMATHCADARRAYALLOCATE, MathcadArrayAllocate )
!    pointer( PMATHCADARRAYFREE, MathcadArrayFree )
    pointer( PIS_USER_INTERRUPTED, isUserInterrupted )
 
    integer( HANDLE ), intent( in ) :: hinstDll
    integer( DWORD ), intent( in ) :: fdwReason
    integer( LPVOID ), intent( in ) :: lpvReserved
     
 
    integer ( HANDLE ) hMathcadUserDll
    integer( LPVOID ) Res
     
    character (256), target :: FuncName = "TestFunc1"C
    character (256), target :: FuncParameters = "(x) - parameter"C
    character (256), target :: FuncDescription = "Fortran test function"C
     
    type( FUNCTIONINFO ), target :: Info_mcad_TestFunc1
    type ( FUNCTIONINFO ), pointer :: pInfo
 
    select case ( fdwReason )
     
        ! DLL проецируется на адресное пространство процесса
        case ( DLL_PROCESS_ATTACH )
 
            ! 'C' в конце добавляет нулевой байт в стиле Си
            hMathcadUserDll = LoadLibrary( "mcaduser.dll"C )
             
            ! Инициализация указателей функций
            PCREATE_USER_FUNCTION = GetProcAddress( hMathcadUserDll, "CreateUserFunction"C )
            PMATHCADFREE = GetProcAddress( hMathcadUserDll, "MathcadFree"C )
            PIS_USER_INTERRUPTED = GetProcAddress( hMathcadUserDll, "isUserInterrupted"C )            
             
            Info_mcad_TestFunc1%lpstrName => FuncName
            Info_mcad_TestFunc1%lpstrParameters => FuncParameters
            Info_mcad_TestFunc1%lpstrDescription => FuncDescription            
            Info_mcad_TestFunc1%returnType = COMPLEX_SCALAR            
            Info_mcad_TestFunc1%nArgs = 1            
            Info_mcad_TestFunc1%argType(1) = COMPLEX_SCALAR            
            Info_mcad_TestFunc1%lpfnMyCFunction => mcad_TestFunc1                        
 
            pInfo => Info_mcad_TestFunc1  
                   
            ! Регистрируем функции библиотеки (пользовательские)
            Res = CreateUserFunction( hinstDll, pInfo )
             
           
        ! создаётся поток  
        case ( DLL_THREAD_ATTACH )
 
        ! поток корректно завершается
        case ( DLL_THREAD_DETACH )
         
         
        case ( DLL_PROCESS_DETACH )
         
             
    end select
 
    DllMain = .TRUE.
 
end function
 
 


Всего записей: 28 | Зарегистр. 12-09-2006 | Отправлено: 02:17 19-08-2012
Открыть новую тему     Написать ответ в эту тему

На первую страницук этому сообщениюк последнему сообщению

Компьютерный форум Ru.Board » Компьютеры » Прикладное программирование » Вопросы программирования на FORTRAN (ФОРТРАН)


Реклама на форуме Ru.Board.

Powered by Ikonboard "v2.1.7b" © 2000 Ikonboard.com
Modified by Ru.Board
© Ru.Board 2000-2020

BitCoin: 1NGG1chHtUvrtEqjeerQCKDMUi6S6CG4iC

Рейтинг.ru