Commit 3d682c21 authored by thomas.forbriger's avatar thomas.forbriger Committed by thomas.forbriger
Browse files

Fortran 77 interface test works with dierct access to common

This is a legacy commit from before 2015-03-01.
It may be incomplete as well as inconsistent.
See COPYING.legacy and README.history for details.


SVN Path:     http://gpitrsvn.gpi.uni-karlsruhe.de/repos/TFSoftware/trunk
SVN Revision: 1236
SVN UUID:     67feda4a-a26e-11df-9d6e-31afc202ad0c
parent 9eb7fc96
......@@ -3,7 +3,7 @@
*
* ----------------------------------------------------------------------------
*
* $Id: README.changelog,v 1.20 2002-12-23 16:43:39 forbrig Exp $
* $Id: README.changelog,v 1.21 2002-12-23 18:07:32 forbrig Exp $
*
* Copyright (c) 2002 by Thomas Forbriger (IMG Frankfurt)
*
......@@ -21,7 +21,7 @@
/*! \page page_changelog ChangeLog (AFF)
$Id: README.changelog,v 1.20 2002-12-23 16:43:39 forbrig Exp $
$Id: README.changelog,v 1.21 2002-12-23 18:07:32 forbrig Exp $
\sa \ref page_project_status
......@@ -36,7 +36,7 @@
- aff::Array::copyin() and aff::Array::copyout() work
- introduced fortranshape.h and fortranshape.cc and herein
aff::FortranArray and aff::util::FortranShape
- first Test of Fortran 77 interface works
- Test of Fortran 77 interface works
- \b 22/12/2002 (thof)
- started test for interface to Fortran 77 code
......@@ -93,7 +93,7 @@
/*! \page page_project_status Project status (AFF)
$Id: README.changelog,v 1.20 2002-12-23 16:43:39 forbrig Exp $
$Id: README.changelog,v 1.21 2002-12-23 18:07:32 forbrig Exp $
\sa \ref page_changelog
......@@ -253,12 +253,12 @@
<TD>does not check pathological cases</TD>
</TR>
<TR><TD>libaff/tests/f77common.inc</TD>
<TD>23/12/02</TD><TD> </TD><TD> </TD>
<TD>23/12/02</TD><TD> </TD><TD>23/12/02</TD>
<TD> </TD>
</TR>
<TR><TD>libaff/tests/f77interface.cc</TD>
<TD>23/12/02</TD><TD> </TD><TD>23/12/02</TD>
<TD>common block test is missing</TD>
<TD> </TD>
</TR>
<TR><TD>libaff/tests/f77procs.f</TD>
<TD>23/12/02</TD><TD> </TD><TD>23/12/02</TD>
......
# this is <Makefile>
# ----------------------------------------------------------------------------
# $Id: Makefile,v 1.8 2002-12-23 16:43:39 forbrig Exp $
# $Id: Makefile,v 1.9 2002-12-23 18:07:32 forbrig Exp $
#
# Copyright (c) 2002 by Thomas Forbriger (IMG Frankfurt)
#
......@@ -58,19 +58,23 @@ $(addsuffix .run,$(EXECUTABLES)): %.run: %; $< $(ARG); rm -fv $< $<.o
FC=g77
F2C=f2c
%.o: %.f
%.o: %.f f77common.inc
$(F2C) -C++ -f -u $<
$(CXX) -c -o $@ $(<:.f=.c) $(CXXFLAGS) $(CPPFLAGS) $(FLAGS)
/bin/rm -fv $(<:.f=.c)
%.P: %.f
%.code: %.f f77common.inc
$(F2C) -C++ -f -u $<
-/bin/mv -v $(patsubst %.f,%.c,$<) $(patsubst %.f,%.code,$<)
%.P: %.f f77common.inc
$(F2C) -C++ -f -u -P -\!c $<
/bin/mv -v $(patsubst %.f,%.c,$<) $(patsubst %.f,%.code,$<)
-/bin/mv -v $(patsubst %.f,%.c,$<) $(patsubst %.f,%.code,$<)
f77common_com.P: f77procs.f
f77common_com.P: f77procs.f f77common.inc
$(F2C) -C++ -f -u -ec $<
/bin/mv -v $(patsubst %.P,%.c,$@) $@
/bin/rm -fv $(patsubst %.f,%.c,$<)
sed -e 's/^struct/extern struct/' $(patsubst %.P,%.c,$@) > $@
f77interface.o: f77interface.cc f77proto.h f77procs.P f77common_com.P
$(CXX) -c -o $@ $< $(CXXFLAGS) $(CPPFLAGS) $(FLAGS)
......
......@@ -3,7 +3,7 @@
*
* ----------------------------------------------------------------------------
*
* $Id: f77interface.cc,v 1.1 2002-12-23 16:43:39 forbrig Exp $
* $Id: f77interface.cc,v 1.2 2002-12-23 18:07:32 forbrig Exp $
* \author Thomas Forbriger
* \date 23/12/2002
*
......@@ -19,12 +19,14 @@
#define AFF_F77INTERFACE_CC_VERSION \
"AFF_F77INTERFACE_CC V1.0 "
#define AFF_F77INTERFACE_CC_CVSID \
"$Id: f77interface.cc,v 1.1 2002-12-23 16:43:39 forbrig Exp $"
"$Id: f77interface.cc,v 1.2 2002-12-23 18:07:32 forbrig Exp $"
// include assertions
#include<aff/lib/error.h>
// include FortranArray stuff
#include<aff/fortranshape.h>
#include<aff/subarray.h>
#include<aff/shaper.h>
/*----------------------------------------------------------------------*/
......@@ -34,7 +36,7 @@
/*----------------------------------------------------------------------*/
// get common block
// #include"f77common_com.P"
#include"f77common_com.P"
/*----------------------------------------------------------------------*/
......@@ -81,6 +83,61 @@ int fill(const aff::Array<int>& a)
return(fill_(pa, &l1, &n1, &l2, &n2, &l3, &n3));
}
/*----------------------------------------------------------------------*/
//! fill common block through Fortran subroutine
int fillarray(const aff::Array<float>& v1,
const aff::Array<float>& v2)
{
aff::FortranArray<float> fv1(v1),fv2(v2);
AFF_assert((sizeof(real)==sizeof(float)),
"ERROR (f77interface::fillarray): illegal type size!");
real* p1=reinterpret_cast<real *>(fv1.pointer());
real* p2=reinterpret_cast<real *>(fv2.pointer());
integer n1=fv1.last(0);
integer n2=fv2.last(0);
return(fillarray_(p1, p2, &n1, &n2));
}
/*----------------------------------------------------------------------*/
//! read from common block through Fortran subroutine
Tcarray sums()
{
typedef Tcarray::Tvalue Tcvalue;
// prepare array that is large enough
integer maxa,maxb;
comdim_(&maxa, &maxb);
Tcarray result(maxa);
// prepare Fortran view
aff::FortranArray<Tcvalue> fa(result);
AFF_assert((sizeof(complex)==sizeof(Tcvalue)),
"ERROR (f77interface::sums): illegal type size!");
complex* p=reinterpret_cast<complex *>(fa.pointer());
integer size;
sums_(p, &maxa, &size);
return(aff::Subarray<Tcvalue>(result)(size));
}
/*----------------------------------------------------------------------*/
//! create view from common
Tzarray viewcommon()
{
typedef Tzarray::Tvalue Tzvalue;
integer maxa,maxb;
comdim_(&maxa, &maxb);
AFF_assert((sizeof(doublecomplex)==sizeof(Tzvalue)),
"ERROR (f77interface::viewcommon): illegal type size!");
Tzvalue* p=reinterpret_cast<Tzvalue *>(f77common_.array);
// create a shape
aff::Strided shape(aff::Shaper(1,f77common_.na,maxa)(1,f77common_.nb,maxb));
// create a representation
aff::SharedHeap<Tzvalue> repr(p, shape.memory_size());
// create array and return
return Tzarray(shape, repr);
}
} // namespace f77interface
/* ----- END OF f77interface.cc ----- */
c this is <f77procs.f>
c ----------------------------------------------------------------------------
c ($Id: f77procs.f,v 1.3 2002-12-23 16:43:39 forbrig Exp $)
c ($Id: f77procs.f,v 1.4 2002-12-23 18:07:32 forbrig Exp $)
c
c Copyright (c) 2002 by Thomas Forbriger (IMG Frankfurt)
c
......@@ -64,6 +64,8 @@ c
c----------------------------------------------------------------------
c
double complex function total(i)
c
c returns a value derived from common block
c
include 'f77common.inc'
c
......@@ -84,6 +86,8 @@ c
c----------------------------------------------------------------------
c
subroutine fill(a, ld1, n1, ld2, n2, ld3, n3)
c
c fill a three-domensional array that was passed to the subroutine
c
integer ld1,n1,ld2,n2,ld3,n3
integer a(ld1,ld2,ld3)
......@@ -101,4 +105,21 @@ c
return
end
c
c----------------------------------------------------------------------
c
subroutine comdim(maxa, maxb)
c
c we have no access to the defined dimensions of the common block
c this subroutines passes the values to the rest of the world
c
integer maxa,maxb
c
include 'f77common.inc'
c
maxa=amax
maxb=bmax
c
return
end
c
c ----- END OF f77procs.f -----
......@@ -3,7 +3,7 @@
*
* ----------------------------------------------------------------------------
*
* $Id: f77proto.h,v 1.2 2002-12-23 16:43:39 forbrig Exp $
* $Id: f77proto.h,v 1.3 2002-12-23 18:07:32 forbrig Exp $
* \author Thomas Forbriger
* \date 22/12/2002
*
......@@ -23,13 +23,23 @@
#define AFF_F77PROTO_H_VERSION \
"AFF_F77PROTO_H V1.0 "
#define AFF_F77PROTO_H_CVSID \
"$Id: f77proto.h,v 1.2 2002-12-23 16:43:39 forbrig Exp $"
"$Id: f77proto.h,v 1.3 2002-12-23 18:07:32 forbrig Exp $"
#include<aff/array.h>
#include<complex>
//! This namespace collects all test functions for interfacing Fortran 77
namespace f77interface {
typedef aff::Array<std::complex<float> > Tcarray;
typedef aff::Array<std::complex<double> > Tzarray;
int fill(const aff::Array<int>& fa);
int fillarray(const aff::Array<float>& v1,
const aff::Array<float>& v2);
Tcarray sums();
Tzarray viewcommon();
} // namespace f77interface
......
......@@ -3,7 +3,7 @@
*
* ----------------------------------------------------------------------------
*
* $Id: f77test.cc,v 1.3 2002-12-23 16:43:39 forbrig Exp $
* $Id: f77test.cc,v 1.4 2002-12-23 18:07:32 forbrig Exp $
* \author Thomas Forbriger
* \date 22/12/2002
*
......@@ -28,7 +28,7 @@
#define AFF_F77TEST_CC_VERSION \
"AFF_F77TEST_CC V1.0 "
#define AFF_F77TEST_CC_CVSID \
"$Id: f77test.cc,v 1.3 2002-12-23 16:43:39 forbrig Exp $"
"$Id: f77test.cc,v 1.4 2002-12-23 18:07:32 forbrig Exp $"
#include <aff/array.h>
#include <aff/fortranshape.h>
......@@ -96,15 +96,43 @@ int main()
section("Pass array to Fortran via subroutine arguments:", '=');
{
// create an array
// create an array and fill it
CODE(Array<int> A(Shaper(-3,3)(9)(-1,1)));
CODE(A=-55);
// create a subarray view and fill this through Fortran
CODE(Array<int> B=Subarray<int>(A)(-2,2)(3,7)(0));
CODE(f77interface::fill(B));
// dump the result
CODE(dump_array(A));
// do it again for a slice
CODE(f77interface::fill(Slice<int>(A)()(2)));
CODE(dump_array(A));
}
/*----------------------------------------------------------------------*/
section("Access to common block:", '=');
{
// prepare to vectors to pass to fillarray
CODE(Array<float> v1(5));
CODE(Array<float> v2(3));
CODE(for(int i=v1.f(0); i<=v1.l(0); i++) { v1(i)=2.*i; });
CODE(for(int i=v2.f(0); i<=v2.l(0); i++) { v2(i)=.5*i; });
// fill common block through Fortran 77 subroutine
CODE(f77interface::fillarray(v1, v2));
// get a view on the common block and dump it
CODE(f77interface::Tzarray Z(f77interface::viewcommon()));
CODE(dump_array(Z));
// call Fortran subroutine sum and dump result
CODE(dump_array(f77interface::sums()));
CODE(typedef f77interface::Tzarray::Tvalue Tzvalue);
// write directly to common block through a subarray
CODE(Subarray<Tzvalue> SZ);
CODE(SZ(Z)(2,4)=Tzvalue(-10.));
// and dump the effect
CODE(dump_array(Z));
CODE(dump_array(f77interface::sums()));
}
} // main
/* ----- END OF f77test.cc ----- */
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment