@z
This file was created by Aleksandar Donev as part of the Sphere Packing Project.
Feel free to use any portion of it and contact me at adonev@princeton.edu
@x

\Title{Support for F2x feature emulation in F95}
\author{Aleksandar Donev}
\date{\today}
\maketitle

@*0 Module |Composite_Datatypes|.

@a
MODULE Composite_Datatypes @;
      USE Precision @;
      USE ISO_C_BINDING @;
      USE Array_Descriptors @;      
      IMPLICIT NONE @;      
      PRIVATE @;

      PUBLIC :: ExtractComponent @;

      @<Component_Pointer@>@;
      
      @<ExtractComponent\_Generic@>@;   
      
CONTAINS @;

      @<ExtractComponent\_Implementation@>@;
            
END MODULE Composite_Datatypes @;      

@*1 Component pointers.

@m _Component_Pointer_Body(type_,kind_) @;
   _TYPE, PUBLIC :: Component_Pointer_@e@&kind_ @; 
      type_(KIND=kind_), DIMENSION(:), POINTER :: component @;
   ENDTYPE @;

@m _Component_Pointer_Body_TK(tk_number_) @;
   _Component_Pointer_Body(_AllIntrinsicTypes(tk_number_),_AllIntrinsicKinds(tk_number_)) @;

@<Component_Pointer@>=   
   _GenerateBody_TK(N_TK_ALL,_Component_Pointer_Body_TK) @;
   
@*1 Array pointer bounds remapping.

@m _ExtractComponent_Body(type_,kind_,rank_) @;
SUBROUTINE ExtractComponent_@e@&kind_@e@&rank_(components,component_pointer) @;
   TYPE(Component_Pointer_@e@&kind_), DIMENSION(rank_), INTENT(IN) :: components @;
   type_(KIND=kind_), DIMENSION(_FullExtent(rank_)), POINTER :: component_pointer @;

   INTEGER(KIND=C_INT) :: lower_bounds[rank_],upper_bounds[rank_],strides[rank_] @;
   INTEGER :: dim @;
   _C_PTR :: base_address @;
  
   base_address=C_LOC(components[1]%component) @;

   DO dim=1,rank_ @;
      IF(_SIZE(components[dim]%component,i_wp)>1) THEN @;
	      strides[dim]=C_STRIDE(var1=components[dim]%component[1],var2=components[dim]%component[2]) @;
      ELSE @;
         strides[dim]=1 @;
      END IF @;  
      WRITE(*,*) "dim=",dim," stride=",strides[dim] @;
   END DO @;

   DO dim=1,rank_ @;      
      lower_bounds[dim]=_LBOUND(components[dim]%component,i_wp) @;
      upper_bounds[dim]=_UBOUND(components[dim]%component,i_wp) @;      
   END DO @;

   CALL MakeArrayDescriptor(component_pointer, base_address, &
           lower_bounds, upper_bounds, strides) @;

END SUBROUTINE @;

@m _ExtractComponent_Body_TKR(tk_number_,rank_,...) @;
   _ExtractComponent_Body(_AllIntrinsicTypes(tk_number_),_AllIntrinsicKinds(tk_number_),rank_) @;
   
@
@<ExtractComponent\_Generic@>=
_GenerateInterface_TKR_Array(N_TK_ALL,ExtractComponent) @;

@
@<ExtractComponent\_Implementation@>=
_GenerateBody_TKR_Array(N_TK_ALL,_ExtractComponent_Body_TKR) @;

@
@I C_Interop.hweb
@I Macros.hweb

@%% EOF