Intel® Fortran Compiler
Build applications that can scale for the future with optimized code designed for Intel® Xeon® and compatible processors.

A reference to path//myDLL.dll could not be added.please make sure that the file is accessible,and that is a valid assembly or

John_C_
Beginner
6,645 Views

 1. have some Fortran .f90 files.

2 I installed visual Fortran compiler in visual studio 2015

  1. I created library DLL empty project.

  2. I added all .f90 and .f files to the project.

5 I compiled the project.

6 now I have myproject.dll file.

7.I created a web application.

8 I try to add myproject.dll to references.

9.I got this error in visual studio environment before compile. :

reference manager: A reference to path//myDLL.dll could not be added.please make sure that the file is accessible,and that is a valid assembly or COM component.

Which project type knows my dll?.is there any error in compile of my dll?therefore what should I do?

Best regards

0 Kudos
44 Replies
John_C_
Beginner
5,408 Views
Which version of Fortran dll is compatible with c# ASP.NET web application ,something like http://www.c-sharpcorner.com/UploadFile/1e050f/creating-and-using-dll-class-library-in-C-Sharp/ At all my question is that how could I use .dll files created with visual Fortran compiler >library>DLL? Any help Wil be appreciated
0 Kudos
FortranFan
Honored Contributor II
5,408 Views

John C. wrote:

Which version of Fortran dll is compatible with c# ASP.NET web application ,something like
http://www.c-sharpcorner.com/UploadFile/1e050f/creating-and-using-dll-cl...

Any help Wil be appreciated

@John C.,

Please note a Fortran DLL is similar to a C DLL or an unmanaged (Microsift terminology) C++ DLL.

Look up online on how to interoperate ASP.NET applications with a C DLL or an unmanaged C++ DLL using a P/Invoke layer, etc. the same concepts will apply to the Fortran libraries also.

By the way, look in Quote #2 of the thread below for an example of a .NET application working with Fortran; it's in Visual Basic but the same idea holds for a C# ASP.NET web application too, though with the latter you will likely have to consider thread safety and reentrancy.

https://software.intel.com/en-us/forums/intel-visual-fortran-compiler-for-windows/topic/509148

0 Kudos
John_C_
Beginner
5,408 Views
Dear @FortranFan Thanks for your attention.I saw the link.that was too complicated.Would you please give me a brief in some sentences,for more information.how should I do step by step in a few sentences. Is it possible to import such a this dll from reference add new reference in project explorer window and see the inner modules? Best regards
0 Kudos
John_C_
Beginner
5,408 Views
Dear @FortranFan your project works in VS2012 but not work in VS2015.it gets the error reference manager: A reference to path//myDLL.dll could not be added.please make sure that the file is accessible,and that is a valid assembly or COM component When trying to add dll to references.in VS2012 in VB there is no reference approach.you must import Fortran module manually coding. But the main problem reason still available.
0 Kudos
John_C_
Beginner
5,408 Views

Dear @FortranFan I did what you said (on the project as the topic) as same  as your link instruction but I got this errors

EntryPointNotFoundException was unhandled

Unable to find an entry point named 'endat3D' in DLL 'C:\Users\admin\Downloads\HW5 add mexfam with DLL VB B\HelloWorld\HelloWorld\electrostatic3D\Debug\electrostatic3D.DLL'.

on this line of code (VB):

        Call endat3D( _
              strMessage, _
              AddressOf RTBDisplayStatus)


this is my vb page:

Option Strict Off
Option Explicit On

Imports System.Text
Imports System.Runtime.InteropServices

Public Class frmHelloWorld

   <UnmanagedFunctionPointer(CallingConvention.Cdecl)> _
   Public Delegate Sub WriteDelegate(SomeString As StringBuilder, ByRef Irc As Integer)

    <DllImport("C:\Users\admin\Downloads\HW5 add mexfam with DLL VB B\HelloWorld\HelloWorld\electrostatic3D\Debug\electrostatic3D.DLL", CallingConvention:=CallingConvention.Cdecl)> _
    Public Shared Sub endat3D(MsgString As StringBuilder, _
                                        <MarshalAs(UnmanagedType.FunctionPtr)> fPtr As WriteDelegate)
    End Sub

   Private Sub btnRun_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnRun.Click

      Dim strMessage As StringBuilder
      Dim IRC As Integer

        strMessage = New StringBuilder("From VB.NET: Hello World")

      Call RTBDisplayStatus(New StringBuilder("From VB.NET: Starting Fortran"), IRC)
        Call endat3D( _
              strMessage, _
              AddressOf RTBDisplayStatus)

      Call RTBDisplayStatus(New StringBuilder("From VB.NET: Finished Fortran"), IRC)

   End Sub

   Public Sub RTBDisplayStatus(s1 As StringBuilder, ByRef irc As Integer)
      '
      'frmHelloWorld.vb / RTBDisplayStatus
      '
      RichTextBox1.Text += s1.ToString().Trim() & vbCrLf
      System.Windows.Forms.Application.DoEvents()
      '
   End Sub

End Class


and this is my endat3D.f90

!------------------------------------------------------------------------
!                            DATA INPUT                              
!------------------------------------------------------------------------

  subroutine endat3D( )

  use fich_electros3D
  use parametros_electros3D
  use electros3D
  use cargavol
  use cargacur
  use cargapun
  use permitividad
  use bloqueo
  use derivados3D
  use auxiliar_cargas

  implicit none

  integer :: temp       ! Dirichlte/Neumann : number of references per function
                        ! Volumic charges   : number of charged domains per function
  integer :: fnum       ! function numbers: Dirichlet (1 to 7) function(1) == User defined
                        !                   Neumann   (1 or 3) function(1) == User defined
  integer :: temp1      ! input via function for the volumic charge (1 Y 0 N)
  integer :: temp2      ! input via array for the volumic charge (1 Y 0 N)
  integer :: temp3      ! input via file for the volumic charge (1 Y 0 N)
  integer :: i,j

  dir%fun = 1
  neu%fun = 1
  vol%fun = 1
  sup%fun = 1
  cur%fun = 1

  nrn             = 0
  neuman%numero   = 0 
  nrd             = 0
  blofron%numero  = 0 
  blopun%numero   = 0 
  carvol%numero   = 0
  carsup%numero   = 0
  carcur%numero   = 0
  ncarpun         = 0 
  permirel%numero = 0 

  read*,fichma
  read*,fichsol
  read*,fichgradsol

  print*,'Strong imposition of Dirichlet conditions option (1 Yes 0 No)'
  read*,iopblo
  print*,iopblo
  
  opcion_bloqueo: if (iopblo.eq.1) then
  
     print*, 'Strong imposition of Dirichlet conditions'
     print*, 'Input via function (1 Yes 0 No)'
     read*,iopblo1
     print*,iopblo1
     print*, 'Strong imposition of Dirichlet conditions'
     print*, 'Input via constants in the boundaries (1 Yes 0 No)'
     read*,iopblo2
     print*,iopblo2
     print*, 'Strong imposition of Dirichlet conditions'
     print*, 'Input via punctual blocking (1 Yes 0 No)'
     read*,iopblo3
     print*,iopblo3

     entrada_por_funcion: if (iopblo1.eq.1) then
        print*, 'Strong imposition of Dirichlet conditions'
        print*, 'Input via function'
        do while (.TRUE.)
           print *, 'Number of references'
           read*,temp      
           print*,temp
           if (temp <= 0) exit
           print *, 'References'
           read*,(irefd(i),i=nrd+1,nrd+temp)
           print*,(irefd(i),i=nrd+1,nrd+temp)
           print *, 'Function associated to the references'
           read*, fnum
           print*,fnum
           dir%fun(nrd+1:nrd+temp) = fnum
           if (fnum<1 .or. fnum>7) stop 'incorrect function number'
           nrd = nrd + temp
        enddo
     endif entrada_por_funcion

     entrada_por_constantes: if (iopblo2.eq.1) then
        print*, 'Strong imposition of Dirichlet conditions'
        print*, 'Input via constants in the boundaries'
        print*, 'Number of references'
        read*,blofron%numero
        print*,blofron%numero
        if(blofron%numero.gt.0) then
           print*,'References and values'
           do i=1,blofron%numero
              read*,blofron%referencias(i)
              read*,blofron%valor(i)
           enddo
           print*,(blofron%referencias(i),i=1,blofron%numero)
           print*,(blofron%valor(i),i=1,blofron%numero)
        endif
     endif entrada_por_constantes

     entrada_por_puntos: if (iopblo3.eq.1) then
        print*, 'Strong imposition of Dirichlet conditions'
        print*, 'Input via punctual blocking'
        print*, 'Number of points'
        read*,blopun%numero
        print*,blopun%numero
        if (blopun%numero.gt.0) then
           print*,'References and values'
           do i=1,blopun%numero
              read*,blopun%referencias(i)
              read*,blopun%valor(i)
           enddo
           print*,(blopun%referencias(i),i=1,blopun%numero)
           print*,(blopun%valor(i),i=1,blopun%numero)
        endif
     endif  entrada_por_puntos

  endif  opcion_bloqueo

  print*, 'Neumann references option (1 Yes 0 No)'
  read*,iopneu
  print*,iopneu
  
  opcion_neuman:  if (iopneu.eq.1) then
  
     print*, 'Neumann references option'
     print*, 'Input via function (1 Yes 0 No)'
     read*,iopneu1
     print*,iopneu1
     print*, 'Neumann references option'
     print*, 'Input via constants in the boundaries (1 Yes 0 No)'
     read*,iopneu2
     print*,iopneu2

     entrada_por_funcion_neuman: if (iopneu1.eq.1) then
        print*, 'Neumann references option'
        print*, 'Input via function'
        do while (.TRUE.)
           print *, 'Number of references'
           read*,temp
           print *, temp
           if (temp <= 0) exit
           print *, 'References'
           read*,(irefn(i),i=nrn+1,nrn+temp)
           print*,(irefn(i),i=nrn+1,nrn+temp)
           print *, 'Function associated to the references'
           read*, fnum
           neu%fun(nrn+1:nrn+temp) = fnum
           if (fnum/=1 .and. fnum/=3) stop 'incorrect function number'
           print*,fnum,functions(fnum)
           nrn = nrn + temp
        enddo
     endif entrada_por_funcion_neuman

     entrada_por_constantes_neuman: if (iopneu2.eq.1) then
        print*, 'Neumann references option'
        print*, 'Input via constants in the boundaries'
        print*, 'Number of references'
        read*,neuman%numero
        print*,neuman%numero
        if (neuman%numero.gt.0) then
           print *, 'References and values'
           do i=1,neuman%numero
              read*,neuman%referencias(i)
              read*,neuman%valor(i)
           enddo
        endif
        print*,(neuman%referencias(i),i=1,neuman%numero)
        print*,(neuman%valor(i),i=1,neuman%numero)
     endif entrada_por_constantes_neuman

  endif  opcion_neuman

  print *, 'Quadrature formula for matrix and second member option'
  read*,iop
  print*,iop
  print *, 'Quadrature formula for the boundary terms'
  read*,iopf
  print*,iopf

  print *, 'Volumic charge option (1 Yes 0 No)'
  read*,iopvol
  print*,iopvol
  
  if (iopvol.eq.1) then
     print*, 'Volumic charge option'
     print*, 'Input via function (1 Yes 0 No)'
     read*, temp1
     print *, temp1
     print*, 'Volumic charge option'
     print*, 'Input via constants in the domains (1 Yes 0 No)'
     read*, temp2
     print *, temp2

     if (temp1.eq.1) then
        do while (.TRUE.)
           print *, 'Number of references'
           read*,temp
           print *, temp
           if (temp <= 0) exit   
           print*,'Domain references'
           read*,(carvol%referencias(i), i=carvol%numero+1,carvol%numero+temp)
           print*,(carvol%referencias(i), i=carvol%numero+1,carvol%numero+temp)
           carvol%valor(carvol%numero+1:carvol%numero+temp)=0.d0 
           carvol%constante(carvol%numero+1:carvol%numero+temp)=.FALSE.
           print*,'Type one of the function numbers below:'
           print*,1,': ',functions(1)
           print*,2,': ',functions(2)
           read*, fnum
           vol%fun(carvol%numero+1:carvol%numero+temp) = fnum
           if (fnum/=1 .and. fnum/=2) stop 'incorrect function number'
           print*,fnum,functions(fnum)
           carvol%numero = carvol%numero + temp
        enddo
     endif

     if (temp2.eq.1) then
        print*,'Number of charges by constant'
        read*,temp
        print*,temp
        if (temp.gt.0) then 
           do i=1,temp
              print*,'Domain references'
              read*,carvol%referencias(carvol%numero+i)
              print*,carvol%referencias(carvol%numero+i)
              print*,'Charge associated to the domain'
              read*,carvol%valor(carvol%numero+i)
              print*,carvol%valor(carvol%numero+i)
              carvol%constante(carvol%numero+i) = .TRUE.
           enddo
        carvol%numero = carvol%numero + temp
        endif
     end if
     
  end if

  print*,'Superficial charge option (1 Yes 0 No)'
  read*,iopsup
  print*,iopsup
  
  if (iopsup.eq.1) then
  
     print*,'Superficial charge option'
     print*, 'Input via function (1 Yes 0 No)'
     read*,temp1
     print*,temp1
     print*,'Superficial charge option'
     print*, 'Input via constants in the surfaces (1 Yes 0 No)'
     read*,temp2
     print*,temp2

     if (temp1.eq.1) then
        do while (.TRUE.)
           print*,'Number of surfaces'
           read*,temp
           print *, temp
           if (temp <= 0) exit   
           print*,'Surface references'
           read*,(carsup%referencias(i),i=carsup%numero+1,carsup%numero+temp)
           print*,(carsup%referencias(i),i=carsup%numero+1,carsup%numero+temp)
           carsup%valor(carsup%numero+1:carsup%numero+temp)=0.d0 
           carsup%constante(carsup%numero+1:carsup%numero+temp)=.FALSE.
           print*,'Type one of the function numbers below:'
           print*,1,': ',functions(1)
           print*,3,': ',functions(3)
           print*,4,': ',functions(4)
           read*, fnum
           sup%fun(carsup%numero+1:carsup%numero+temp) = fnum
           if (fnum/=1 .and. fnum/=3 .and. fnum/=4) stop 'incorrect function number'
           print*,fnum,functions(fnum)
           carsup%numero = carsup%numero + temp
        enddo
     endif

     if (temp2.eq.1) then
        print*,'Number of surfaces'
        read*,temp
        print *, temp
        if (temp.gt.0) then
           print *, 'Surface references and associated values'
           do i=1,temp
              read*,carsup%referencias(carsup%numero+i)
              read*,carsup%valor(carsup%numero+i)
              carsup%constante(carsup%numero+i) = .TRUE.
           enddo
           print *, (carsup%referencias(carsup%numero+i),i=1,temp)
           print *, (carsup%valor(carsup%numero+i),i=1,temp)
           carsup%numero = carsup%numero + temp
        endif               
     end if
     
  end if

  print*,'Curvilinear charge option (1 Yes 0 No)'
  read*,iopcur
  print*,iopcur
  
  if (iopcur.eq.1) then
  
     print*,'Curvilinear charge option'
     print*, 'Input via function (1 Yes 0 No)'
     read*,temp1
     print *, temp1
     print*,'Curvilinear charge option'
     print*, 'Input via constants in the curves (1 Yes 0 No)'
     read*,temp2
     print *, temp2

     if (temp1.eq.1) then
        do while (.TRUE.)
           print*,'Number of curves'
           read*,temp
           print*,temp
           if (temp <= 0) exit  
           print*,'Curve references'
           read*,(carcur%referencias(i),i=carcur%numero+1,carcur%numero+temp)
           print*,(carcur%referencias(i),i=carcur%numero+1,carcur%numero+temp)
           carcur%valor(carcur%numero+1:carcur%numero+temp)=0.d0 
           carcur%constante(carcur%numero+1:carcur%numero+temp)=.FALSE.
           print*,'Type one of the function numbers below:'
           print*,1,': ',functions(1)
           print*,5,': ',functions(5)
           read*, fnum
           cur%fun(carcur%numero+1:carcur%numero+temp) = fnum
           if (fnum/=1 .and. fnum/=5) stop 'incorrect function number'  
           print*,fnum,functions(fnum)
           carcur%numero = carcur%numero + temp
        enddo
     endif

     if (temp2.eq.1) then
           print*,'Number of curves'
           read*,temp
           print *, temp
           if(temp.gt.0) then
              print*, 'Curve references and associated charges' 
              do i=1,temp
                 read*,carcur%referencias(carcur%numero+i)
                 read*,carcur%valor(carcur%numero+i)
                 carcur%constante(carcur%numero+i) = .TRUE.
              enddo
              print *, (carcur%referencias(carcur%numero+i),i=1,temp)
              print *, (carcur%valor(carcur%numero+i),i=1,temp)
              carcur%numero = carcur%numero + temp
           endif               
        end if
        
     end if

  print*,'Punctual charge option (1 Yes 0 No)'
  read*,ioppun
  print*,ioppun
  
  if (ioppun.eq.1) then
     print*,'Number of charges'
     read*,ncarpun
     do i=1,ncarpun
        print*,'Point coordinates and associated charge'
        read*,xcarpun(i)
        read*,ycarpun(i)
        read*,zcarpun(i)
        read*,carpun(i)
        print*, xcarpun(i),ycarpun(i),zcarpun(i)
        print*, carpun(i)
     enddo
  end if

  iopteta=0

  print*,'Number of subdomains'
  read*,permirel%numero
  do i=1,permirel%numero
     print*,'Subdomain number'
     read*,permirel%referencias(i)
     print*,permirel%referencias(i)
     print*,'Relative electric permitivity option'
     print*,'1 --> Via function'
     print*,'2 --> Via constants per domain'
     print*,'3 --> Via array'
     read*,permirel%iopermir(i)
     print*,permirel%iopermir(i)
     if(permirel%iopermir(i).eq.1) then 
        print*,'Function name'
        !do j=1,size(functions_perm,1)
        !   print *, j,': ', functions_perm(j)
        !enddo
        read*,permirel%etiqueta(i)
        !print*,permirel%fun(i)
        if (permirel%fun(i)<1 .or. permirel%fun(i)> &
            size(functions_perm,1)) stop 'incorrect function number' 
     elseif(permirel%iopermir(i).eq.2) then
        print*,'Electric permitivity (x,y,z)' 
        read*,permirel%valorx(i), permirel%valory(i), permirel%valorz(i)
        print*,permirel%valorx(i), permirel%valory(i), permirel%valorz(i)
     elseif(permirel%iopermir(i).eq.3)then
        iopteta=1
        read*,permirel%ntab(i) 
        do j=1,permirel%ntab(i)
           read*,permirel%teta(i,j),permirel%valtabx(i,j),  &
                 permirel%valtaby(i,j),permirel%valtabz(i,j)
        enddo
     else
        stop 'Incorrect relative electric permitivity option: only 1 , 2 , 3'
     endif              
  enddo

  if (iopteta.eq.1) then
     print*,'Name of temperature file'
     read*,fichteta
     print*,fichteta
  endif
 
  print*,'Option for the linear system resolution'
  print*,'1: Direct method, 0 : Conjugate gradient'
  read*,iopsl
  print*,iopsl          
  if(iopsl.eq.0) then
     print*,'Corvengence error in CG'
     read* ,epscg
     print*,epscg
     print*,'Maximum number of iterations in CG'
     read*,nitcg
     print*,nitcg
  endif

  if(allocated(ncaras))deallocate(ncaras)
  allocate(ncaras(carsup%numero),stat=ierror)
  if (ierror.ne.0) then
     print*,'Error while allocating ncaras'
     stop 1
  endif      

  if(allocated(nodc1))deallocate(nodc1)
  if(allocated(nodc2))deallocate(nodc2)
  if(allocated(nodc3))deallocate(nodc3)
  allocate(nodc1(carsup%numero,ndcaras), &
           nodc2(carsup%numero,ndcaras), &
           nodc3(carsup%numero,ndcaras),stat=ierror)
  if (ierror.ne.0) then
     print*,'Error while allocating nodc1,2 o 3'
     stop 1
  endif

  if(allocated(naristas))deallocate(naristas)
  allocate(naristas(carcur%numero),stat=ierror)
  if (ierror.ne.0) then
     print*,'Error while allocating naristas'
     stop 1
  endif
  
  if(allocated(nod1))deallocate(nod1)
  if(allocated(nod2))deallocate(nod2)
  allocate(nod1(carcur%numero,ndar), &
           nod2(carcur%numero,ndar),stat=ierror)
  if (ierror.ne.0) then
     print*,'Error while allocating nod1 o nod2'
     stop 1
  endif

  return
  end


so what should I do?

best regards

0 Kudos
mecej4
Honored Contributor III
5,408 Views

It appears to be a simple name decoration issue. By default, the Fortran compiler creates an entry point ENDAT3D regardless of the case used for the name in the Fortran source. VB probably uses a different convention, so the names of the entry expected and the entry present differ in case and/or underscores. There are a number of ways of managing name decoration, ranging from compiler options to embedded DEC$ directives in the Fortran code. Find out what VB expects and make the Fortran match that (I don't use VB, so I don't know what it expects).

0 Kudos
Steve_Lionel
Honored Contributor III
5,408 Views

VB is case sensitive and doesn't "decorate" names. Also for 32-bit, VB uses the STDCALL convention by default, but I see you overrode that with Cdecl, so that part is ok.

0 Kudos
John_C_
Beginner
5,408 Views
perhaps maybe problems is there : 1.one probability is that compiler could not make a total DLL from my Fortran files . 2.and another maybe there is a mistake on calling dlls in my vb code . 3.and at last any modification in my .f90 Fortran files are needed. 4. Finally maybe confusing of the names(in .f90 ,in dll,in vb code and so far)...
0 Kudos
John_C_
Beginner
5,408 Views
Focusing on these lines: .... _ Public Shared Sub endat3D(MsgString As StringBuilder, _ fPtr As WriteDelegate) End Sub .... and ..... Call endat3D( _ strMessage, _ AddressOf RTBDisplayStatus)
0 Kudos
John_C_
Beginner
5,408 Views
My main .f90 file that I want to call via DLL is principal.f90 as below: !--------------------------------------------------------------------------- ! ! GOAL : Solve, by means of finite elements, the electrostatics 3D ! PDE with different boundary conditions and charges ! ! | -div(permi grad(V))=f ! (1) | V = V+ on Dirichlet boundary ! | permi d(V)/dn=g ! ! Dolores Gomez ! MC Muٌiz ! Jose Luis Ferrin Gonzalez ! !--------------------------------------------------------------------------- program ppalelectros3D use fich_electros3D use electros3D use cargavol use cargacur use cargapun use permitividad use bloqueo use derivados3D use malla_3DP1 use external_electros3D use module_writeVTU use comprobaciones use module_convers use module_fem_extract use module_conver3d, only: conver3d use LIB_VTK_IO_READ use module_readUNV use module_compiler_dependant implicit none integer :: i,istat, p, nnod,DIMS,LNN,LNV,LNE,LNF,nnd,nco,npieces,nverteta,iformat integer, allocatable :: nn(:,:) real(real64), allocatable :: evtun(:) !--------------------------------------------------------------------------- ! INPUT DATA !--------------------------------------------------------------------------- if (command_argument_count() == 0) then call endat3D() else call readxml() end if ! INPUT DATA VERIFICATION, FOR ENDAT & READXML if (.not. comprueba()) then write(error_unit,*) 'Input data check failed' stop 1 else write(output_unit,*) 'Input data check passed' endif call calculate_funs() ! 0.0 IS ASSIGNED TO THE LAST VERTEX IN CASE OF NOT HAVING DIRICHLET CONDITIONS if (blocking_node() < 0) then write(error_unit,*) 'Error assigning blocking node' stop 1 endif !--------------------------------------------------------------------------- ! ELECTROMAGNETIC MESH READING !--------------------------------------------------------------------------- call calindc(indc,inda) p = index(fichma, '.', back=.true.) if (p == 0) stop 'Mesh file has not extension: unable to identify mesh format' select case (lcase(fichma(p+1:len_trim(fichma)))) case('mfm') iformat=1 call leema3D(iformat) case('mum') iformat=2 call leema3D(iformat) case('unv') call readUNV(fichma,nel,nnod,nver,dims,LNN,LNV,LNE,LNF,nn,mm,nrc,nra,nrv,z,nsd) call conver3d(nel, nver, mm, z, nemm, det, binv, ib, jb) case default stop 'Unrecognized mesh file extension' end select call alloc_after_mesh() !--------------------------------------------------------------------------- ! TEMPERATURE READING !--------------------------------------------------------------------------- if (iopteta == 1) call leetmp() !--------------------------------------------------------------------------- ! COMPUTATIONS !--------------------------------------------------------------------------- if (iopblo.eq.1.and.iopblo1.eq.1) then call calprebloqueof(nrd,irefd) endif if (iopblo.eq.1.and.iopblo2.eq.1) then call calprebloqueoc(blofron%numero,blofron%referencias) endif call electrostatica3D() if(allocated(vexac))deallocate(vexac) allocate(vexac(nver),stat=ierror) if (ierror.ne.0) then print*,'Error while allocating array vexac',nver stop 1 endif if(allocated(err))deallocate(err) allocate(err(nver),stat=ierror) if (ierror.ne.0) then print*,'Error while allocating array err',nver stop 1 endif ! call wrtcmp(nver,sol,10,fichsol) ! call writeVTU(nel,nver,mm,z,'tetra',sol,'solucion','scalar', & ! 'node',trim(fichsol)//'.vtu') ! -1: mixed functions ! 0: no data ! 1: User defined / Function defined by user ! ... if (dir%funs > 1.or.& neu%funs > 1.or.& vol%funs > 1.or.& sup%funs > 1.or.& cur%funs > 1) then do i=1,nver vexac(i) = fexac(z(1,i),z(2,i),z(3,i)) err(i) = dabs(vexac(i)-sol(i)) enddo if (dir%funs == 7) then ! 'Example 6' vexac(376) = sol(376) vexac(193) = sol(193) err(193) = dabs(vexac(193)-sol(193)) err(376) = dabs(vexac(376)-sol(376)) elseif (dir%funs == 6) then ! 'Example 5' vexac(1292) = sol(1292) err(1292) = dabs(vexac(1292)-sol(1292)) endif call norl2_3D(sol,xnorexac) call norl2_3D(vexac,xnorexac) call norl2_3D(err,xnorerr) rel = xnorerr/xnorexac print*,'Relative error (%)',100*rel endif ! COMPUTATION OF THE ELECTRIC FIELD call ef() !--------------------------------------------------------------------------- ! RESULTS OUTPUT !--------------------------------------------------------------------------- call wrtcmp(nver,sol,10,fichsol) call writeVTU(nel,nver,mm,z,'tetra',sol,'Potential (V)','scalar', & 'node',trim(fichsol)//'.vtu') call wrtcmpv(nel,e,10,fichgradsol) if(allocated(evtu))deallocate(evtu) allocate(evtu(3*nel),STAT=istat) if (istat.ne.0) stop 'Error while allocating evtu in principal' evtu(1:nel*3:3)=e(1,1:nel) evtu(2:nel*3:3)=e(2,1:nel) evtu(3:nel*3:3)=e(3,1:nel) call cell2node(nver, mm, evtu, evtun) call writeVTU(nel,nver,mm,z,'tetra',evtun,'Electric field (V/m)',& 'vector','node',trim(fichgradsol)//'.vtu') deallocate(evtu,STAT=istat) if (istat.ne.0) stop 'Error while deallocating in principal' deallocate(sol,STAT=istat) if (istat.ne.0) stop 'Error while deallocating in principal' deallocate(e,STAT=istat) if (istat.ne.0) stop 'Error while deallocating in principal' stop 'End of the execution' end
0 Kudos
John_C_
Beginner
5,408 Views
As @FortranFan said in https://software.intel.com/en-us/forums/intel-visual-fortran-compiler-for-windows/topic/509148 Visit my vs2012 ell error page snapshot. At. https://i.stack.imgur.com/CnoTQ.jpg Everything is ok.but I have a lot of .f90 files as a dll project.how could I modify @FortranFan project with a little changes that cover my Fortran project? Regards
0 Kudos
FortranFan
Honored Contributor II
5,408 Views

John C. wrote:

As @FortranFan said in
https://software.intel.com/en-us/forums/intel-visual-fortran-compiler-fo...

.. how could I modify @FortranFan project with a little changes that cover my Fortran project ..

@John C.,

You seem to be taking the Visual Basic .NET and Fortran example from the above thread on this forum and literally using the Visual Basic code with only a name change to endat3D and hoping everything works out.  It's not as simple as that, at least as far as I know. 

It would appear you need to do a lot more research and investigate further because your posts above indicate issues at the very basic (no pun intended!) level: first, you do not seem to have paid attention to make the procedures in Fortran callable in a mixed language environment and whether as part of this, you have even looked into the interoperability aspects with a companion C processor; you do not seem to have looked into the method signatures i.e., matching the procedure declaration in Fortran with the interface in Visual Basic; also, it's unclear if you have setup your Fortran DLL project correctly with the necessary export definitions.

All I can suggest is for you to look up information online and apply the learnings to your situation and note the complete working example of Visual Basic .NET and Fortran from the above thread is a good guide, provided you pay attention to the relevant details:

  • Information on setting up of DLLs by Microsoft: https://msdn.microsoft.com/en-us/library/1ez7dh12.aspx
  • Also look into DLL example with Intel Fortran: https://software.intel.com/en-us/fortran-compiler-18.0-developer-guide-and-reference-using-the-intel-fortran-samples
  • Mixed-language programming for Fortran and C: https://software.intel.com/en-us/fortran-compiler-18.0-developer-guide-and-reference-mixed-language-programming
  • Pay particular attention to standard Fortran interoperability aspects: https://software.intel.com/en-us/fortran-compiler-18.0-developer-guide-and-reference-standard-fortran-and-c-interoperability

 

0 Kudos
John_C_
Beginner
5,408 Views
@FortranFan, I saw some pages of each link you introduced.but it takes a lot of time to study.I am looking for a more quick strategy.so what should I do? As the discussion issue Would you please introduce or send me a visual studio 2012 -Fortran application -dll .NET example which I could download and test them with vs2012? Really I want to mix Fortran with c# asp.net web application , but VB.NET Windows form application as the first step is good.actually c or c++ are a little far from my goal. Regards
0 Kudos
Steve_Lionel
Honored Contributor III
5,408 Views

There are two sample applications that mix VB with Fortran that you can find in the samples installed with your compiler version. (In some newer versions the samples are provided online only.) Unpack the samples ZIP file into a writable folder and look under Fortran > MixedLanguage. I don't know what the "stringbuilder" thing does.

0 Kudos
John_C_
Beginner
5,408 Views
@Steve Lionel (Ret) , I run them.could I use them for my purpose.means changing .f90 file into many .f90 files and call them via vb.net as the sample easily or as @FortranFan said it takes to study more.do you have any idea? Best regards
0 Kudos
Steve_Lionel
Honored Contributor III
5,408 Views

One or many .f90 files makes no difference. What matters is getting the expectations of VB and Fortran to match.

I see that your Fortran code that you want to call "as a DLL" has a main program. That won't work. You have to call a subroutine or a function, so you'll have to restructure the program as a function that can be called. You can test it first by calling from a Fortran main program, and then work out how to interface it to VB.  

I suggested the VB-Fortran samples as "case studies" for how to do this sort of thing. You'll see in both programs that there is no Fortran main program - instead there are functions. The VB code determines what data wants to be processed by the Fortran code and calls the Fortran function, which resides in a DLL. The call then returns to VB which does something with the result.

I fear that you think there's a simple edit to your existing program that will make it all work with VB - that is not the case.

0 Kudos
John_C_
Beginner
5,408 Views
@Steve Lionel (Ret) ,, Could I change VB-Calls-Fortran project (sample inside Intel Parallel package) ? as locally in C:\Users\admin\Documents\MixedLanguage\MixedLanguage\VB-Calls-Fortran... as to run my project with a few modification as below: the scripts below are originally as same as the package ,no modification applied. in fcall.90 : ... ! Fortran part of a VB-Fortran DLL example. This ! routine DLL_ROUT is called from a VB.NET executable ! program. SUBROUTINE DLL_ROUT (DBL_IN, STRING_IN, DBL_OUT) IMPLICIT NONE ... in Module1.vb ... Module Module1 REM Use ByVal to pass strings unless the called routine expects BSTR structures Public Declare Auto Sub DLL_ROUTMo Lib "FCALL.DLL" _ (ByVal DBL_IN() As Double, ByVal STR_IN As String, ByVal DBL_OUT() As Double) End Module ... in Form1.vb .... Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click Dim DBL_IN(4) As Double Dim DBL_OUT(4) As Double Dim MULTIPLIER As String ' Note that in VB, arrays are zero-based. DBL_IN(0) = 1.0 DBL_IN(1) = 2.0 DBL_IN(2) = 3.0 DBL_IN(3) = 4.0 MULTIPLIER = "2.0" Call DLL_ROUT(DBL_IN, MULTIPLIER, DBL_OUT) TextBox1.Text = DBL_OUT(0) TextBox2.Text = DBL_OUT(1) TextBox3.Text = DBL_OUT(2) TextBox4.Text = DBL_OUT(3) End Sub .... i want to add more .f90 files and now it's not important to send argument(in future maybe).In a fortran DLL librray could it make a DLL covering all .f90 subroutine (or function) files? the tree directory list is as below: C:. │ build.bat │ ReadMe.txt │ VB-Calls-Fortran.sln │ ├───FCALL │ │ fcall.f90 │ │ FCALL.vfproj │ │ │ └───Debug │ BuildLog.htm │ FCALL.dll │ FCALL.dll.intermediate.manifest │ FCALL.exp │ FCALL.lib │ fcall.obj │ FCALL.pdb │ vc110.pdb │ ├───README_FIRST │ README_FIRST.vfproj │ └───VBCallsFortran │ AssemblyInfo.vb │ Form1.resx │ Form1.vb │ Module1.vb │ VBCallsFortran.vbproj │ ├───bin │ FCALL.dll │ VBCallsFortran.exe │ VBCallsFortran.pdb │ VBCallsFortran.vshost.exe │ VBCallsFortran.vshost.exe.manifest │ VBCallsFortran.xml │ ├───My Project └───obj └───x86 └───Debug │ DesignTimeResolveAssemblyReferences.cache │ DesignTimeResolveAssemblyReferencesInput.cache │ VBCallsFortran.exe │ VBCallsFortran.Form1.resources │ VBCallsFortran.pdb │ VBCallsFortran.vbproj.FileListAbsolute.txt │ VBCallsFortran.vbproj.GenerateResource.Cache │ VBCallsFortran.xml │ └───TempPE When I changed DLL_ROUT to Mysubroutine in all files above and I add all my .f90 files I see this error: EntryPointNotFoundException was unhandled Unable to find an entry point named 'Mysubroutine' in DLL 'FCALL.DLL'. on this line: Call Mysubroutine() But When I changed back the Mysubroutine to it's original name DLL_ROUT everything works right.Is there any problem in making DLL or something else? any help will be appreciated Best Regards
0 Kudos
John_C_
Beginner
5,408 Views
A part of my problem solved as I use VB.NET-SafeArrays package and changing all ForCall statements to readxml and add this line of code: !dec$ attributes dllexport, stdcall, reference, alias : "readxml" :: readxml define readxml as subroutine readxml(VBArray) and adding integer(int_ptr_kind()), intent(inout) :: VBArray !Pointer to a SafeArray structure there is no error but nothing happen when I run the project , this is my readxml.f90 file contents: !----------------------------------------------------------------------- ! procedure for reading the solver variables !----------------------------------------------------------------------- subroutine readxml(VBArray) ! Set the attributes needed for compatibility with VB.NET. VB always uses STDCALL. ! !dec$ attributes dllexport, stdcall, reference, alias : "readxml" :: readxml use module_SO_DEPENDANT use module_REPORT use module_xml_parser !Solver modules use fich_electros3D use electros3D, DOUBLElocal1 => DOUBLE use cargavol, DOUBLElocal2 => DOUBLE use cargacur, DOUBLElocal3 => DOUBLE use cargapun, DOUBLElocal4 => DOUBLE use permitividad, DOUBLElocal5 => DOUBLE use bloqueo, DOUBLElocal6 => DOUBLE use derivados3D, DOUBLElocal7 => DOUBLE use auxiliar_cargas !use ifcom ! Declare SafeArray and BSTR interfaces implicit none !! !! implicit none !! integer(int_ptr_kind()), intent(inout) :: VBArray !Pointer to a SafeArray structure integer :: i, j, pos, ide, im, fnum real(DOUBLE) :: cval real(DOUBLE), dimension(:), allocatable :: xcp, aux character(len=MAXPATH) :: matxml, sval, tval character(len=MAXPATH), dimension(:), allocatable :: list, list2, list3, refs call set_SO() call set_report_level(REPORT_STDOUT) ! inicializacion de variables (array) ! fun_0 == User defined / Function defined by user dir%fun = 1 neu%fun = 1 vol%fun = 1 sup%fun = 1 cur%fun = 1 ide = fopen() !Mesh call fread(ide, '/Mesh/Open/Mesh file', fichma) !Boundary Condicions print*,'Neumann' !Neumann conditions iopneu = 0; iopneu1 = 0; iopneu2 = 0 nrn = 0 neuman%numero = 0 call flist(ide, '/Boundary conditions/Neumann/Conditions/', list) do i = 1, size(list,1) !loop for defined Neumann BC's call flist(ide, '/Boundary conditions/Neumann/Conditions/'//trim(list(i)), list2) do j = 1, size(list2,1) !loop for data type for each BC select case(trim(list2(j))) case('A function') !References call fread_alloc(ide, '/Boundary conditions/Neumann/Conditions/'//trim(list(i))//& &'/A function/Surface references', refs, realloc=.true.) if (size(refs,1)>0) then iopneu = 1 iopneu1 = 1 ! ok !Function call fread(ide, '/Boundary conditions/Neumann/Conditions/'//trim(list(i))//& &'/A function/Function name', sval) pos = nrn + 1 irefn(pos:pos+size(refs,1)-1) = int(refs) fnum = function_number(sval,functions) if (fnum == 0) call error('readxml: unknown function: '//sval) neu%fun(pos:pos+size(refs,1)-1) = fnum nrn = nrn + size(refs,1) else print * , 'Function Neumann B.C. with 0 references: skipping' endif case('A constant') !References call fread_alloc(ide, '/Boundary conditions/Neumann/Conditions/'//trim(list(i))//& &'/A constant/Surface references', refs, realloc=.true.) if (size(refs,1)>0) then iopneu = 1 iopneu2 = 1 ! ok !Constant value call fread(ide, '/Boundary conditions/Neumann/Conditions/'//trim(list(i))//& &'/A constant/Constant value', cval) pos = neuman%numero + 1 neuman%referencias(pos:pos+size(refs,1)-1) = int(refs) neuman%numero = neuman%numero + size(refs,1) neuman%valor(pos:pos+size(refs,1)-1) = cval else print * , 'Constant Neumann B.C. with 0 references: skipping' endif case default; call error('readxml: Case not implemented.') end select enddo enddo print*,'Dirichlet' !Potential (Dirichlet) conditions iopblo = 0; iopblo1 = 0; iopblo2 = 0; iopblo3 = 0 nrd = 0 blofron%numero = 0 blopun%numero = 0 call flist(ide, '/Boundary conditions/Dirichlet/Conditions', list) do i = 1, size(list,1) !loop for defined potential BC's call flist(ide, '/Boundary conditions/Dirichlet/Conditions/'//trim(list(i)), list2) do j = 1, size(list2,1) !loop for data type for each BC select case(trim(list2(j))) case('A function') !References call fread_alloc(ide, '/Boundary conditions/Dirichlet/Conditions/'//trim(list(i))//& &'/A function/Surface references', refs, realloc=.true.) if (size(refs,1)>0) then iopblo = 1 iopblo1 = 1 ! ok !Function call fread(ide, '/Boundary conditions/Dirichlet/Conditions/'//trim(list(i))//& &'/A function/Function name', sval) pos = nrd + 1 irefd(pos:pos+size(refs,1)-1) = int(refs) fnum = function_number(sval,functions) if (fnum == 0) call error('readxml: unknown function: '//sval) dir%fun(pos:pos+size(refs,1)-1) = fnum nrd = nrd + size(refs,1) else print * , 'Function Dirichlet B.C. with 0 references: skipping' endif case('A constant') !References call fread_alloc(ide, '/Boundary conditions/Dirichlet/Conditions/'//trim(list(i))//& &'/A constant/Surface references', refs, realloc=.true.) if (size(refs,1)>0) then iopblo = 1 iopblo2 = 1 ! ok !Constant value call fread(ide, '/Boundary conditions/Dirichlet/Conditions/'//trim(list(i))//& &'/A constant/Constant value', cval) pos = blofron%numero + 1 blofron%referencias(pos:pos+size(refs,1)-1) = int(refs) blofron%numero = blofron%numero + size(refs,1) blofron%valor(pos:pos+size(refs,1)-1) = cval else print * , 'Constant Dirichlet B.C. with 0 references: skipping' endif ! case('Point') ! iopblo3 = 1 ! ok ! !References ! call fread_alloc('/B.C./Define.../B.C. type/Potential/'//trim(list(i))//& ! &'/Point/Reference number(s)', refs, realloc=.true.) ! !Constant value ! call fread('/B.C./Define.../B.C. type/Potential/'//trim(list(i))//& ! &'/Point/Constant value', cval) ! if (size(refs,1)>0) ! iopblo3 = 1 ! ok ! pos = blopun%numero + 1 ! blopun%referencias(pos:pos+size(refs,1)-1) = int(refs) ! blopun%numero = blopun%numero + size(refs,1) ! blopun%valor(pos:pos+size(refs,1)-1) = cval ! else ! print * , 'Dirichlet B.C. with 0 references: skipping' ! endif case default; call error('readxml: Case not implemented.') end select enddo enddo ! 2010-02-08,11: Blocking node and Blocking value ! 2010-09-21: comentado !print*,'Blocking node and blocking value' ! call fread_alloc(ide, '/Data/Blocking for Neumann problem/'//& ! &'Blocking for Neumann problem/Blocking node', xcp, realloc=.true.) ! call fread_alloc(ide, '/Data/Blocking for Neumann problem/'//& ! &'Blocking for Neumann problem/Blocking value', aux, realloc=.true.) ! if ( size(xcp,1) > 1 ) call error('readxml: Only 0 or 1 blocking node allowed') ! if ( size(aux,1) > 1 ) call error('readxml: Only 0 or 1 blocking value allowed') ! if ( ( size(xcp,1) == 1 ) .and. ( size(aux,1) /= 1 ) )& ! &call error('readxml: Found blocking node but no blocking value') ! if ( ( size(aux,1) == 1 ) .and. ( size(xcp,1) /= 1 ) )& ! &call error('readxml: Found blocking value but no blocking node') ! if ( ( size(xcp,1) == 1 ) .and. ( size(aux,1) == 1 ) ) then ! iopblo = 1 ! iopblo3 = 1 ! blopun%numero = blopun%numero + 1 ! blopun%referencias(blopun%numero) = int(xcp(1)) ! blopun%valor(blopun%numero) = aux(1) ! end if !Sources print*,'Volume sources' !Volumic sources iopvol = 0 ! 1 => hai volumic sources carvol%numero = 0 call flist(ide, '/Sources/Volumetric/Volumetric sources', list) do i = 1, size(list,1) !loop for defined volumic sources call flist(ide, '/Sources/Volumetric/Volumetric sources/'//trim(list(i)), list2) if (size(list2,1)/=1) call error('readxml: Incorrect number of childs in volume source.') if (trim(list2(1)) == 'A function') then !References call fread_alloc(ide, '/Sources/Volumetric/Volumetric sources/'//trim(list(i))//& &'/A function/Domain references', refs, realloc=.true.) if (size(refs,1)>0) then iopvol = 1 !Function call fread(ide, '/Sources/Volumetric/Volumetric sources/'//trim(list(i))//& &'/A function/Function name', sval) pos = carvol%numero + 1 carvol%referencias(pos:pos+size(refs,1)-1) = int(refs) carvol%numero = carvol%numero + size(refs,1) carvol%valor(pos:pos+size(refs,1)-1) = 0.d0 fnum = function_number(sval,functions) if (fnum == 0) call error('readxml: unknown function: '//sval) vol%fun(pos:pos+size(refs,1)-1) = fnum carvol%constante(pos:pos+size(refs,1)-1) = .FALSE. else print * , 'Function volume source with 0 references: skipping' endif elseif (trim(list2(1)) == 'A constant') then !References call fread_alloc(ide, '/Sources/Volumetric/Volumetric sources/'//trim(list(i))//& &'/A constant/Domain references', refs, realloc=.true.) if (size(refs,1)>0) then iopvol = 1 !Constant value call fread(ide, '/Sources/Volumetric/Volumetric sources/'//trim(list(i))//& &'/A constant/Constant value', cval) pos = carvol%numero + 1 carvol%referencias(pos:pos+size(refs,1)-1) = int(refs) carvol%numero = carvol%numero + size(refs,1) carvol%valor(pos:pos+size(refs,1)-1) = cval carvol%constante(pos:pos+size(refs,1)-1) = .TRUE. else print * , 'Constant volume source with 0 references: skipping' endif else call error('readxml: Incorrect volume source child: '//trim(list2(1))//'.') endif enddo print*,'Surface sources' !Surface sources iopsup = 0 ! 1 => hai surface sources carsup%numero = 0 call flist(ide, '/Sources/Surface/Surface sources', list) do i = 1, size(list,1) !loop for defined surface sources call flist(ide, '/Sources/Surface/Surface sources/'//trim(list(i)), list2) if (size(list2,1)/=1) call error('readxml: Incorrect number of childs in surface source.') if (trim(list2(1)) == 'A function') then !References call fread_alloc(ide, '/Sources/Surface/Surface sources/'//trim(list(i))//& &'/A function/Surface references', refs, realloc=.true.) if (size(refs,1)>0) then iopsup = 1 !Function call fread(ide, '/Sources/Surface/Surface sources/'//trim(list(i))//& &'/A function/Function name', sval) pos = carsup%numero + 1 carsup%referencias(pos:pos+size(refs,1)-1) = int(refs) carsup%numero = carsup%numero + size(refs,1) carsup%valor(pos:pos+size(refs,1)-1) = 0.d0 fnum = function_number(sval,functions) if (fnum == 0) call error('readxml: unknown function: '//sval) sup%fun(pos:pos+size(refs,1)-1) = fnum carsup%constante(pos:pos+size(refs,1)-1) = .FALSE. else print * , 'Function surface source with 0 references: skipping' endif elseif (trim(list2(1)) == 'A constant') then !References call fread_alloc(ide, '/Sources/Surface/Surface sources/'//trim(list(i))//& &'/A constant/Surface references', refs, realloc=.true.) if (size(refs,1)>0) then iopsup = 1 !Constant value call fread(ide, '/Sources/Surface/Surface sources/'//trim(list(i))//& &'/A constant/Constant value', cval) pos = carsup%numero + 1 carsup%referencias(pos:pos+size(refs,1)-1) = int(refs) carsup%numero = carsup%numero + size(refs,1) carsup%valor(pos:pos+size(refs,1)-1) = cval carsup%constante(pos:pos+size(refs,1)-1) = .TRUE. else print * , 'Constant surface source with 0 references: skipping' endif else call error('readxml: Incorrect surface source child: '//trim(list2(1))//'.') endif enddo print*,'Line sources' !Curvilinear sources iopcur = 0 ! 1 => hai line sources carcur%numero = 0 call flist(ide, '/Sources/Line/Line sources', list) do i = 1, size(list,1) !loop for defined curvilinear sources call flist(ide, '/Sources/Line/Line sources/'//trim(list(i)), list2) if (size(list2,1)/=1) call error('readxml: Incorrect number of childs in line source.') if (trim(list2(1)) == 'A function') then !References call fread_alloc(ide, '/Sources/Line/Line sources/'//trim(list(i))//& &'/A function/Line references', refs, realloc=.true.) if (size(refs,1)>0) then iopcur = 1 !Function call fread(ide, '/Sources/Line/Line sources/'//trim(list(i))//& &'/A function/Function name', sval) pos = carcur%numero + 1 carcur%referencias(pos:pos+size(refs,1)-1) = int(refs) carcur%numero = carcur%numero + size(refs,1) carcur%valor(pos:pos+size(refs,1)-1) = 0.d0 fnum = function_number(sval,functions) if (fnum == 0) call error('readxml: unknown function: '//sval) cur%fun(pos:pos+size(refs,1)-1) = fnum carcur%constante(pos:pos+size(refs,1)-1) = .FALSE. else print * , 'Function line source with 0 references: skipping' endif elseif (trim(list2(1)) == 'A constant') then !References call fread_alloc(ide, '/Sources/Line/Line sources/'//trim(list(i))//& &'/A constant/Line references', refs, realloc=.true.) if (size(refs,1)>0) then iopcur = 1 !Constant value call fread(ide, '/Sources/Line/Line sources/'//trim(list(i))//& &'/A constant/Constant value', cval) pos = carcur%numero + 1 carcur%referencias(pos:pos+size(refs,1)-1) = int(refs) carcur%numero = carcur%numero + size(refs,1) carcur%valor(pos:pos+size(refs,1)-1) = cval carcur%constante(pos:pos+size(refs,1)-1) = .TRUE. else print * , 'Constant line source with 0 references: skipping' endif else call error('readxml: Incorrect surface source child: '//trim(list2(1))//'.') endif enddo print*,'Point sources' !Point sources ioppun = 0 ncarpun = 0 call flist(ide, '/Sources/Point/Point sources', list) if (size(list,1) > 0) ioppun = 1 do i = 1, size(list,1) !loop for defined point sources pos = ncarpun + 1 call fread_alloc(ide, '/Sources/Point/Point sources/'//trim(list(i))//'/X coordinates',xcp, realloc=.true.) xcarpun(pos:pos+size(xcp,1)-1) = xcp call fread_alloc(ide, '/Sources/Point/Point sources/'//trim(list(i))//'/Y coordinates',xcp, realloc=.true.) ycarpun(pos:pos+size(xcp,1)-1) = xcp call fread_alloc(ide, '/Sources/Point/Point sources/'//trim(list(i))//'/Z coordinates',xcp, realloc=.true.) zcarpun(pos:pos+size(xcp,1)-1) = xcp call fread_alloc(ide, '/Sources/Point/Point sources/'//trim(list(i))//'/Values',xcp, realloc=.true.) !val !para face ser se da un �nica valor na fonte para varios puntos ! alg�n outro sitio onde sexa necesario ? ! if (size(val,1) == 1) then extendemos val � lonxitude de xcp carpun(pos:pos+size(xcp,1)-1) = xcp ncarpun = ncarpun + size(xcp,1) enddo print*,'Materials database' !Open materials database call fread(ide, '/Materials file/Open/materialsDB', matxml) im = fopen(matxml) print*,'Magnitudes' !Magnitudes call flist(ide, '/Properties/Materials/Materials', list) permirel%numero = size(list,1) do i = 1, size(list,1) permirel%referencias(i) = int(list(i)) call fread(ide, '/Properties/Materials/Materials/'//trim(list(i)), sval) call flist(im, '/Materials database/Open/Materials/'//trim(sval)//'/Relative permittivity', list2) if (size(list2,1)==0) call error('readxml: missing relative permittivity type for material') select case(trim(list2(1))) case('A constant') call flist(im,'/Materials database/Open/Materials/'//trim(sval)//'/Relative permittivity/A constant', list3) if (size(list3,1)==0) call error('readxml: missing constant relative permittivity type for material') select case(trim(list3(1))) case('Isotropic') call fread(im, '/Materials database/Open/Materials/'//trim(sval)//'/Relative permittivity/A constant/Isotropic',& permirel%valorx(i)) permirel%valory(i) = permirel%valorx(i) permirel%valorz(i) = permirel%valorx(i) case('Orthotropic') call fread(im, '/Materials database/Open/Materials/' & //trim(sval)//'/Relative permittivity/A constant/Orthotropic/X Value',& permirel%valorx(i)) call fread(im, '/Materials database/Open/Materials/' & //trim(sval)//'/Relative permittivity/A constant/Orthotropic/Y Value',& permirel%valory(i)) call fread(im, '/Materials database/Open/Materials/' & //trim(sval)//'/Relative permittivity/A constant/Orthotropic/Z Value',& permirel%valorz(i)) case default; call error('readxml: Case not implemented.') end select permirel%iopermir(i) = 2 case('A temperature dependant table') call flist(im,'/Materials database/Open/Materials/' & //trim(sval)//'/Relative permittivity/A temperature dependant table', list3) if (size(list3,1)==0) call error('readxml: missing temperature dependant relative permittivity type for material') select case(trim(list3(1))) case('Isotropic') !utilizamos unha variable auxiliar (aux) allocatable para saber o n� de elementos call fread_alloc(im, '/Materials database/Open/Materials/' & //trim(sval)//'/Relative permittivity/A temperature dependant table/Isotropic/Temperatures', aux, realloc=.true.) call fread(im, '/Materials database/Open/Materials/' & //trim(sval)//'/Relative permittivity/A temperature dependant table/Isotropic/Values', permirel%valtabx(i,:)) permirel%ntab(i) = size(aux,1) permirel%teta(i,1:permirel%ntab(i)) = aux permirel%valtaby(i,1:permirel%ntab(i)) = permirel%valtabx(i,1:permirel%ntab(i)) permirel%valtabz(i,1:permirel%ntab(i)) = permirel%valtabx(i,1:permirel%ntab(i)) case('Orthotropic') call fread_alloc(im, '/Materials database/Open/Materials/'& &//trim(sval)//'/Relative permittivity/A temperature dependant table/Orthotropic/Temperatures', aux, realloc=.true.) call fread(im, '/Materials database/Open/Materials/'& &//trim(sval)//'/Relative permittivity/A temperature dependant table/Orthotropic/X values', permirel%valtabx(i,:)) call fread(im, '/Materials database/Open/Materials/'& &//trim(sval)//'/Relative permittivity/A temperature dependant table/Orthotropic/Y values', permirel%valtaby(i,:)) call fread(im, '/Materials database/Open/Materials/'& &//trim(sval)//'/Relative permittivity/A temperature dependant table/Orthotropic/Z values', permirel%valtabz(i,:)) permirel%ntab(i) = size(aux,1) permirel%teta(1,1:permirel%ntab(i)) = aux case default; call error('readxml: Case not implemented.') end select permirel%iopermir(i) = 3 iopteta = 1 case ('A function') !call fread(im, '/Materials database/Open/Materials/'//trim(sval)//& ! &'/Relative permittivity/'//trim(list2(1)), tval) !fnum = function_number(tval, functions_perm) !if (fnum == 0) call error('readxml: unknown function: '//tval) !permirel%fun(i) = fnum permirel%etiqueta(i) = trim(sval) permirel%iopermir(i) = 1 case default; call error('readxml: Case not implemented.') end select enddo !Se iopermir = 3 hai q ler un ficheiro de temperaturas fichteta if (iopteta == 1) then print*,'Temperature field' call fread(ide, '/Data/Temperature field for materials/Field', fichteta) endif call fclose(im) call fclose(ide) !Results (missing) fichsol = 'fichpot' fichgradsol = 'fichgradpot' !Quadrature options (missing) iop = 2 iopf = 1 !Another data (missing) iopej = 0 !fichvexac: usado solo si iopej != 0 ! todos os exemplos estan asi ! van fixas iopsl = 0 epscg = 1.d-50 nitcg = 1000 ! ncaras nodc1 nodc2 nodc3 naristas nod1 nod2 ! alojamiento de variables allocate(ncaras(carsup%numero),stat=ierror) if (ierror.ne.0) then print*,'error: no se ha podido reservar memoria para ncaras' stop 1 endif allocate(nodc1(carsup%numero,ndcaras),& nodc2(carsup%numero,ndcaras),& nodc3(carsup%numero,ndcaras),stat=ierror) if (ierror.ne.0) then print*,'error: no se ha podido reservar memoria para nodc1,2 o 3' stop 1 endif allocate(naristas(carcur%numero),stat=ierror) if (ierror.ne.0) then print*,'error: no se ha podido reservar memoria para naristas' stop 1 endif allocate(nod1(carcur%numero,ndar),& nod2(carcur%numero,ndar),stat=ierror) if (ierror.ne.0) then print*,'error: no se ha podido reservar memoria para nod1 o nod2' stop 1 endif end subroutine and this is the arrays.f90 file content: subroutine ForCall (VBArray) ! Set the attributes needed for compatibility with VB.NET. VB always uses STDCALL. ! !dec$ attributes dllexport, stdcall, reference, alias : "ForCall" :: ForCall use ifcom ! Declare SafeArray and BSTR interfaces implicit none integer(int_ptr_kind()), intent(inout) :: VBArray !Pointer to a SafeArray structure integer, parameter :: LONG_ENOUGH_BUFFER = 2048 ! Assume we won't get a string longer than this character(LEN=LONG_ENOUGH_BUFFER) mystring ! Fortran string converted to/from BSTR integer(int_ptr_kind()) :: BSTRptr ! Receives a pointer to a BSTR ! Array in which we will keep track of array bounds type bounds_type integer lb ! Lower Bound integer ub ! Upper Bound end type bounds_type integer nbounds ! Number of bounds type(bounds_type), allocatable :: bounds(:) integer, allocatable :: indexes(:) ! Array to hold current element indexes integer :: i, iRes, length ! First, we'll get the bounds of the array. This code makes no assumptions about the number of ! dimensions. ! nbounds = SafeArrayGetDim (VBArray) allocate (bounds(nbounds), indexes(nbounds)) do i=1,nbounds ires = SafeArrayGetLbound (VBArray, i, bounds(i)%lb) ires = SafeArrayGetUbound (VBArray, i, bounds(i)%ub) end do ! Example 1 - write to a text file (since we don't have a console) the ! bounds of the array. You'll find this file in the BIN subfolder of ! the VB.NET project folder. open (2, file="testout.txt", status="unknown") write (2, *) "Shape of the array passed by VB:" write (2,'(" (")',advance='no') do i=1,nbounds write (2,'(I0,":",I0)',advance='no') bounds(i) if (i < nbounds) write(2,'(",")',advance='no') end do write (2,'(")")') ! Example 2 - Write the values of the string elements to the file. This code ! also makes no assumptions about the number of dimensions. ! ! For each element we: ! 1) Call SafeArrayGetElement to return a pointer to a BSTR element ! 2) Convert the BSTR to a Fortran string (which we then write to the file) ! 3) Free the string which we retrieved ! ! Note that the current interface to SafeArrayGetElement has the second "indices" ! argument defined as a scalar - we work around that by passing the first element ! by reference. ! write (2, *) "Strings from the array:" indexes = bounds%lb ! Initialize to all lower bounds readloop: do ires = SafeArrayGetElement (VBArray, indexes(1), loc(BSTRPtr)) length = ConvertBSTRToString (BSTRPtr, mystring) call SysFreeString(BSTRPtr) write (2, '(" A(")', advance='no') write (2, '(100(I0,:,","))', advance='no') (indexes(i),i=1,nbounds) write (2, '(") = ", A)') mystring(1:length) ! Determine what the next element is. We increment the last index, ! and if it is greater than the upper bound, reset it to the lower bound and ! repeat for the next lower index. If we run out of indexes, we're done. do i = nbounds, 1, -1 indexes(i) = indexes(i) + 1 if (indexes(i) <= bounds(i)%ub) exit indexes(i) = bounds(i)%lb if (i == 1) exit readloop end do end do readloop close (2) ! We're done with the file ! Example 3 - Modifying BSTR elements in a SafeArray. Here we append ! " potato" to each of the elements. ! indexes = bounds%lb ! Initialize to all lower bounds writeloop: do ires = SafeArrayGetElement (VBArray, indexes(1), loc(BSTRPtr)) length = ConvertBSTRToString (BSTRPtr, mystring) call SysFreeString (BSTRPtr) ! Append "potato" to the element mystring = trim(mystring) // " potato" ! Convert it back to a BSTR BSTRptr = ConvertStringToBSTR (trim(mystring)) ! Write it back to the array ires = SafeArrayPutElement (VBArray, indexes(1), BSTRptr) call SysFreeString (BSTRPtr) ! Free our copy ! Determine what the next element is. We increment the last index, ! and if it is greater than the upper bound, reset it to the lower bound and ! repeat for the next lower index. If we run out of indexes, we're done. do i = nbounds, 1, -1 indexes(i) = indexes(i) + 1 if (indexes(i) <= bounds(i)%ub) exit indexes(i) = bounds(i)%lb if (i == 1) exit writeloop end do end do writeloop ! Deallocate our local arrays, though this would be done implicitly anyway ! deallocate (bounds) deallocate (indexes) return end subroutine ForCall what should I do to get an output result?
0 Kudos
gib
New Contributor II
5,407 Views

Why don't you test with a very small piece of Fortran code?  Why not try the VB-Fortran sample code as Steve has suggested?

0 Kudos
Steve_Lionel
Honored Contributor III
3,160 Views

Part of what is pasted there is the VB.NET-Safearrays code, which is far more complicated than is needed here. The other sample, VB-Calls-Fortran, is much simpler.

0 Kudos
Reply