Patchwork [Fortran] FINAL (prep patches 4/5): Support noncontiguous arrays in the finalization wrapper function

login
register
mail settings
Submitter Tobias Burnus
Date Dec. 31, 2012, 2:11 p.m.
Message ID <50E19D2B.9000004@net-b.de>
Download mbox | patch
Permalink /patch/208862/
State New
Headers show

Comments

Tobias Burnus - Dec. 31, 2012, 2:11 p.m.
Dear all,

this lengthy patch supports noncontiguous arrays in the finalization 
wrapper. That encompasses bother the scalarizer (used for finalizing the 
components and for an ELEMENTAL FINAL subroutine) and calling array 
FINAL subroutines. For the latter, the subroutine is directly called if 
possible. Namely, when the element size of the actual type is the same 
as the one of the declared type - and the the FINAL subroutine is either 
assumed-shape without the contiguous attribute or the actual argument is 
contiguous. Otherwise, the code packs the array.

The code is written such that it works for any array rank. I explicitly 
avoided using GFC_MAX_DIMENSIONS to allow for more ranks without 
breaking the ABI.

The code consists of two new blocks of code. The new function 
"finalization_get_offset" which generates the code to translate from an 
element index to the byte offset - and in generate_finalization_wrapper 
to fill the array "strides" and "sizes", where the latter contains the 
multiplied up size, i.e. sizes(0) == 1, sizes(1) = size(array,dim=1), 
sizes(2) = sizes(1)*size(array,dim=2) etc.

Note: Without patch 5/5, this code is never executed.

Build and regtested on x86-64-gnu-linux - and tested (with the not 
submitted patch for invoking the finalizer).
OK for the trunk?

Tobias
Paul Richard Thomas - Jan. 5, 2013, 8:48 a.m.
Dear Tobias,

I think that the patch would be much less opaque if repeated operation
to produce code were turned into functions, as I did for the defined
assignment patch; eg resolve.c(build_assignment, add_code_to_chain)?
What you have done is OK but it is HEAVY, as is much of the content of
class.c.  However, unless your intestinal fortitude is of a very high
order, I suggest that this be left as a latter clean up operation :-)

A nit:
+     do idx2 = 1, rank
+       offset = offset + mod (idx, sizes(idx2)) / size(idx2-1) * strides(idx2)
+     end do

s/size(idx2-1)/sizes(idx2-1)/

Apart from that, the patch is OK for trunk.

Thanks


Paul

On 31 December 2012 15:11, Tobias Burnus <burnus@net-b.de> wrote:
> Dear all,
>
> this lengthy patch supports noncontiguous arrays in the finalization
> wrapper. That encompasses bother the scalarizer (used for finalizing the
> components and for an ELEMENTAL FINAL subroutine) and calling array FINAL
> subroutines. For the latter, the subroutine is directly called if possible.
> Namely, when the element size of the actual type is the same as the one of
> the declared type - and the the FINAL subroutine is either assumed-shape
> without the contiguous attribute or the actual argument is contiguous.
> Otherwise, the code packs the array.
>
> The code is written such that it works for any array rank. I explicitly
> avoided using GFC_MAX_DIMENSIONS to allow for more ranks without breaking
> the ABI.
>
> The code consists of two new blocks of code. The new function
> "finalization_get_offset" which generates the code to translate from an
> element index to the byte offset - and in generate_finalization_wrapper to
> fill the array "strides" and "sizes", where the latter contains the
> multiplied up size, i.e. sizes(0) == 1, sizes(1) = size(array,dim=1),
> sizes(2) = sizes(1)*size(array,dim=2) etc.
>
> Note: Without patch 5/5, this code is never executed.
>
> Build and regtested on x86-64-gnu-linux - and tested (with the not submitted
> patch for invoking the finalizer).
> OK for the trunk?
>
> Tobias

Patch

2012-12-31  Tobias Burnus  <burnus@net-b.de>

	* class.c (finalize_component): Used passed offset expr.
	(finalization_get_offset): New static function.
	(finalizer_insert_packed_call, generate_finalization_wrapper): Use it
	to handle noncontiguous arrays.

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 61d65e7..dae1adc 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -924,14 +924,14 @@  finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
 
 /* Generate code equivalent to
    CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
-		     + idx * stride, c_ptr), ptr).  */
+		     + offset, c_ptr), ptr).  */
 
 static gfc_code *
-finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
-			 gfc_expr *stride, gfc_namespace *sub_ns)
+finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
+			 gfc_expr *offset, gfc_namespace *sub_ns)
 {
   gfc_code *block;
-  gfc_expr *expr, *expr2, *expr3;
+  gfc_expr *expr, *expr2;
 
   /* C_F_POINTER().  */
   block = XCNEW (gfc_code);
@@ -961,6 +961,7 @@  finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
 	    = gfc_intrinsic_function_by_id (GFC_ISYM_TRANSFER);
   /* Set symtree for -fdump-parse-tree.  */
   gfc_get_sym_tree ("transfer", sub_ns, &expr2->symtree, false);
+  expr2->symtree->n.sym->intmod_sym_id = GFC_ISYM_TRANSFER;
   expr2->symtree->n.sym->attr.flavor = FL_PROCEDURE;
   expr2->symtree->n.sym->attr.intrinsic = 1;
   gfc_commit_symbol (expr2->symtree->n.sym);
@@ -995,21 +996,12 @@  finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
   expr->ts.kind = gfc_index_integer_kind;
   expr2->value.function.actual->expr = expr;
 
-  /* Offset calculation: idx * stride (in bytes).  */
-  block->ext.actual->expr = gfc_get_expr ();
-  expr3 = block->ext.actual->expr;
-  expr3->expr_type = EXPR_OP;
-  expr3->value.op.op = INTRINSIC_TIMES;
-  expr3->value.op.op1 = gfc_lval_expr_from_sym (idx);
-  expr3->value.op.op2 = stride;
-  expr3->ts = expr->ts;
-
   /* <array addr> + <offset>.  */
   block->ext.actual->expr = gfc_get_expr ();
   block->ext.actual->expr->expr_type = EXPR_OP;
   block->ext.actual->expr->value.op.op = INTRINSIC_PLUS;
   block->ext.actual->expr->value.op.op1 = expr2;
-  block->ext.actual->expr->value.op.op2 = expr3;
+  block->ext.actual->expr->value.op.op2 = offset;
   block->ext.actual->expr->ts = expr->ts;
 
   /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=.  */
@@ -1021,39 +1013,183 @@  finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
 }
 
 
+/* Calculates the offset to the (idx+1)th element of an array, taking the
+   stride into account. It generates the code:
+     offset = 0
+     do idx2 = 1, rank
+       offset = offset + mod (idx, sizes(idx2)) / size(idx2-1) * strides(idx2)
+     end do
+     offset = offset * byte_stride.  */
+
+static gfc_code*
+finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
+			 gfc_symbol *strides, gfc_symbol *sizes,
+			 gfc_symbol *byte_stride, gfc_expr *rank,
+			 gfc_code *block, gfc_namespace *sub_ns)
+{
+  gfc_iterator *iter;
+  gfc_expr *expr, *expr2;
+
+  /* offset = 0.  */
+  block->next = XCNEW (gfc_code);
+  block = block->next;
+  block->op = EXEC_ASSIGN;
+  block->loc = gfc_current_locus;
+  block->expr1 = gfc_lval_expr_from_sym (offset);
+  block->expr2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+
+  /* Create loop.  */
+  iter = gfc_get_iterator ();
+  iter->var = gfc_lval_expr_from_sym (idx2);
+  iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  iter->end = gfc_copy_expr (rank);
+  iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  block->next = XCNEW (gfc_code);
+  block = block->next;
+  block->op = EXEC_DO;
+  block->loc = gfc_current_locus;
+  block->ext.iterator = iter;
+  block->block = gfc_get_code ();
+  block->block->op = EXEC_DO;
+
+  /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
+				  * strides(idx2).  */
+
+  /* mod (idx, sizes(idx2)).  */
+  expr = gfc_get_expr ();
+  expr->expr_type = EXPR_FUNCTION;
+  expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_MOD);
+  gfc_get_sym_tree ("mod", sub_ns, &expr->symtree, false);
+  expr->symtree->n.sym->intmod_sym_id = GFC_ISYM_MOD;
+  expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  expr->symtree->n.sym->attr.intrinsic = 1;
+  gfc_commit_symbol (expr->symtree->n.sym);
+  expr->value.function.actual = gfc_get_actual_arglist ();
+  expr->value.function.actual->expr = gfc_lval_expr_from_sym (idx);
+  expr->value.function.actual->next = gfc_get_actual_arglist ();
+  expr->value.function.actual->next->expr = gfc_lval_expr_from_sym (sizes);
+  expr->value.function.actual->next->expr->ref = gfc_get_ref ();
+  expr->value.function.actual->next->expr->ref->type = REF_ARRAY;
+  expr->value.function.actual->next->expr->ref->u.ar.as = sizes->as;
+  expr->value.function.actual->next->expr->ref->u.ar.type = AR_ELEMENT;
+  expr->value.function.actual->next->expr->ref->u.ar.dimen = 1;
+  expr->value.function.actual->next->expr->ref->u.ar.dimen_type[0]
+	= DIMEN_ELEMENT;
+  expr->value.function.actual->next->expr->ref->u.ar.start[0]
+	= gfc_lval_expr_from_sym (idx2);
+  expr->ts = idx->ts;
+
+  /* (...) / sizes(idx2-1).  */
+  expr2 = gfc_get_expr ();
+  expr2->expr_type = EXPR_OP;
+  expr2->value.op.op = INTRINSIC_DIVIDE;
+  expr2->value.op.op1 = expr;
+  expr2->value.op.op2 = gfc_lval_expr_from_sym (sizes);
+  expr2->value.op.op2->ref = gfc_get_ref ();
+  expr2->value.op.op2->ref->type = REF_ARRAY;
+  expr2->value.op.op2->ref->u.ar.as = sizes->as;
+  expr2->value.op.op2->ref->u.ar.type = AR_ELEMENT;
+  expr2->value.op.op2->ref->u.ar.dimen = 1;
+  expr2->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  expr2->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
+  expr2->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
+  expr2->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
+  expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1
+	= gfc_lval_expr_from_sym (idx2);
+  expr2->value.op.op2->ref->u.ar.start[0]->value.op.op2
+	= gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  expr2->value.op.op2->ref->u.ar.start[0]->ts
+	= expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
+  expr2->ts = idx->ts;
+
+  /* ... * strides(idx2).  */
+  expr = gfc_get_expr ();
+  expr->expr_type = EXPR_OP;
+  expr->value.op.op = INTRINSIC_TIMES;
+  expr->value.op.op1 = expr2;
+  expr->value.op.op2 = gfc_lval_expr_from_sym (strides);
+  expr->value.op.op2->ref = gfc_get_ref ();
+  expr->value.op.op2->ref->type = REF_ARRAY;
+  expr->value.op.op2->ref->u.ar.type = AR_ELEMENT;
+  expr->value.op.op2->ref->u.ar.dimen = 1;
+  expr->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  expr->value.op.op2->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
+  expr->value.op.op2->ref->u.ar.as = strides->as;
+  expr->ts = idx->ts;
+
+  /* offset = offset + ...  */
+  block->block->next = XCNEW (gfc_code);
+  block->block->next->op = EXEC_ASSIGN;
+  block->block->next->loc = gfc_current_locus;
+  block->block->next->expr1 = gfc_lval_expr_from_sym (offset);
+  block->block->next->expr2 = gfc_get_expr ();
+  block->block->next->expr2->expr_type = EXPR_OP;
+  block->block->next->expr2->value.op.op = INTRINSIC_PLUS;
+  block->block->next->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
+  block->block->next->expr2->value.op.op2 = expr;
+  block->block->next->expr2->ts = idx->ts;
+
+  /* After the loop:  offset = offset * byte_stride.  */
+  block->next = XCNEW (gfc_code);
+  block = block->next;
+  block->op = EXEC_ASSIGN;
+  block->loc = gfc_current_locus;
+  block->expr1 = gfc_lval_expr_from_sym (offset);
+  block->expr2 = gfc_get_expr ();
+  block->expr2->expr_type = EXPR_OP;
+  block->expr2->value.op.op = INTRINSIC_TIMES;
+  block->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
+  block->expr2->value.op.op2 = gfc_lval_expr_from_sym (byte_stride);
+  block->expr2->ts = block->expr2->value.op.op1->ts;
+  return block;
+}
+
+
 /* Insert code of the following form:
 
-   if (stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
-       || 0 == STORAGE_SIZE (array)) then
-     call final_rank3 (array)
-   else
-     block
-       type(t) :: tmp(shape (array))
-
-       do i = 0, size (array)-1
-	 addr = transfer (c_loc (array), addr) + i * stride
-	 call c_f_pointer (transfer (addr, cptr), ptr)
-
-	 addr = transfer (c_loc (tmp), addr)
-			  + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
-	 call c_f_pointer (transfer (addr, cptr), ptr2)
-	 ptr2 = ptr
-       end do
-       call final_rank3 (tmp)
-     end block
-   end if  */
+   block
+     integer(c_intptr_t) :: i
+
+     if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
+	  && (is_contiguous || !final_rank3->attr.contiguous
+	      || final_rank3->as->type != AS_ASSUMED_SHAPE))
+         || 0 == STORAGE_SIZE (array)) then
+       call final_rank3 (array)
+     else
+       block
+         integer(c_intptr_t) :: offset, j
+         type(t) :: tmp(shape (array))
+
+         do i = 0, size (array)-1
+	   offset = obtain_offset(i, strides, sizes, byte_stride)
+	   addr = transfer (c_loc (array), addr) + offset
+	   call c_f_pointer (transfer (addr, cptr), ptr)
+
+	   addr = transfer (c_loc (tmp), addr)
+			    + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
+	   call c_f_pointer (transfer (addr, cptr), ptr2)
+	   ptr2 = ptr
+         end do
+         call final_rank3 (tmp)
+       end block
+     end if
+   block  */
 
 static void
 finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
-			      gfc_symbol *array, gfc_symbol *stride,
+			      gfc_symbol *array, gfc_symbol *byte_stride,
 			      gfc_symbol *idx, gfc_symbol *ptr,
 			      gfc_symbol *nelem, gfc_symtree *size_intr,
+			      gfc_symbol *strides, gfc_symbol *sizes,
+			      gfc_symbol *idx2, gfc_symbol *offset,
+			      gfc_symbol *is_contiguous, gfc_expr *rank,
 			      gfc_namespace *sub_ns)
 {
   gfc_symbol *tmp_array, *ptr2;
-  gfc_expr *size_expr;
+  gfc_expr *size_expr, *offset2, *expr;
   gfc_namespace *ns;
   gfc_iterator *iter;
+  gfc_code *block2;
   int i;
 
   block->next = XCNEW (gfc_code);
@@ -1080,6 +1216,8 @@  finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
                = gfc_intrinsic_function_by_id (GFC_ISYM_STORAGE_SIZE);
   gfc_get_sym_tree ("storage_size", sub_ns, &size_expr->value.op.op1->symtree,
 		    false);
+  size_expr->value.op.op1->symtree->n.sym->intmod_sym_id
+	= GFC_ISYM_STORAGE_SIZE;
   size_expr->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
   size_expr->value.op.op1->symtree->n.sym->attr.intrinsic = 1;
   gfc_commit_symbol (size_expr->value.op.op1->symtree->n.sym);
@@ -1096,32 +1234,53 @@  finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
   size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
   size_expr->ts = size_expr->value.op.op1->ts;
 
-  /* IF condition: stride == size_expr || 0 == size_expr.  */
+  /* IF condition: (stride == size_expr
+		    && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
+			|| is_contiguous)
+		   || 0 == size_expr.  */
   block->expr1 = gfc_get_expr ();
   block->expr1->expr_type = EXPR_FUNCTION;
   block->expr1->ts.type = BT_LOGICAL;
-  block->expr1->ts.kind = 4;
+  block->expr1->ts.kind = gfc_default_logical_kind;
   block->expr1->expr_type = EXPR_OP;
   block->expr1->where = gfc_current_locus;
 
   block->expr1->value.op.op = INTRINSIC_OR;
 
-  /* stride == size_expr */
-  block->expr1->value.op.op1 = gfc_get_expr ();
-  block->expr1->value.op.op1->expr_type = EXPR_FUNCTION;
-  block->expr1->value.op.op1->ts.type = BT_LOGICAL;
-  block->expr1->value.op.op1->ts.kind = 4;
-  block->expr1->value.op.op1->expr_type = EXPR_OP;
-  block->expr1->value.op.op1->where = gfc_current_locus;
-  block->expr1->value.op.op1->value.op.op = INTRINSIC_EQ;
-  block->expr1->value.op.op1->value.op.op1 = gfc_lval_expr_from_sym (stride);
-  block->expr1->value.op.op1->value.op.op2 = size_expr;
+  /* byte_stride == size_expr */
+  expr = gfc_get_expr ();
+  expr->ts.type = BT_LOGICAL;
+  expr->ts.kind = gfc_default_logical_kind;
+  expr->expr_type = EXPR_OP;
+  expr->where = gfc_current_locus;
+  expr->value.op.op = INTRINSIC_EQ;
+  expr->value.op.op1
+	= gfc_lval_expr_from_sym (byte_stride);
+  expr->value.op.op2 = size_expr;
+
+  /* If strides aren't allowd (not assumed shape or CONTIGUOUS),
+     add is_contiguous check.  */
+  if (fini->proc_tree->n.sym->formal->sym->as->type != AS_ASSUMED_SHAPE
+      || fini->proc_tree->n.sym->formal->sym->attr.contiguous)
+    {
+      gfc_expr *expr2;
+      expr2 = gfc_get_expr ();
+      expr2->ts.type = BT_LOGICAL;
+      expr2->ts.kind = gfc_default_logical_kind;
+      expr2->expr_type = EXPR_OP;
+      expr2->where = gfc_current_locus;
+      expr2->value.op.op = INTRINSIC_AND;
+      expr2->value.op.op1 = expr;
+      expr2->value.op.op2 = gfc_lval_expr_from_sym (is_contiguous);
+      expr = expr2;
+    }
+
+  block->expr1->value.op.op1 = expr;
 
   /* 0 == size_expr */
   block->expr1->value.op.op2 = gfc_get_expr ();
-  block->expr1->value.op.op2->expr_type = EXPR_FUNCTION;
   block->expr1->value.op.op2->ts.type = BT_LOGICAL;
-  block->expr1->value.op.op2->ts.kind = 4;
+  block->expr1->value.op.op2->ts.kind = gfc_default_logical_kind;
   block->expr1->value.op.op2->expr_type = EXPR_OP;
   block->expr1->value.op.op2->where = gfc_current_locus;
   block->expr1->value.op.op2->value.op.op = INTRINSIC_EQ;
@@ -1168,7 +1327,6 @@  finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
   tmp_array->ts.type = BT_DERIVED;
   tmp_array->ts.u.derived = array->ts.u.derived;
   tmp_array->attr.flavor = FL_VARIABLE;
-  tmp_array->attr.contiguous = 1;
   tmp_array->attr.dimension = 1;
   tmp_array->attr.artificial = 1;
   tmp_array->as = gfc_get_array_spec();
@@ -1217,22 +1375,36 @@  finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
   block->block = gfc_get_code ();
   block->block->op = EXEC_DO;
 
+  /* Offset calculation for the new array: idx * size of type (in bytes).  */
+  offset2 = gfc_get_expr ();
+  offset2 = block->ext.actual->expr;
+  offset2->expr_type = EXPR_OP;
+  offset2->value.op.op = INTRINSIC_TIMES;
+  offset2->value.op.op1 = gfc_lval_expr_from_sym (idx);
+  offset2->value.op.op2 = gfc_copy_expr (size_expr);
+  offset2->ts = byte_stride->ts;
+
+  /* Offset calculation of "array".  */
+  block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
+				    byte_stride, rank, block->block, sub_ns);
+
   /* Create code for
      CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
 		       + idx * stride, c_ptr), ptr).  */
-  block->block->next = finalization_scalarizer (idx, array, ptr,
-						gfc_lval_expr_from_sym (stride),
-						sub_ns);
-  block->block->next->next = finalization_scalarizer (idx, tmp_array, ptr2,
-						      gfc_copy_expr (size_expr),
-						      sub_ns);
+  block2->next = finalization_scalarizer (array, ptr,
+					  gfc_lval_expr_from_sym (offset),
+					  sub_ns);
+  block2 = block2->next;
+  block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns);
+
   /* ptr2 = ptr.  */
-  block->block->next->next->next = XCNEW (gfc_code);
-  block->block->next->next->next->op = EXEC_ASSIGN;
-  block->block->next->next->next->loc = gfc_current_locus;
-  block->block->next->next->next->expr1 = gfc_lval_expr_from_sym (ptr2);
-  block->block->next->next->next->expr2 = gfc_lval_expr_from_sym (ptr);
+  block2->next = XCNEW (gfc_code);
+  block2->next->op = EXEC_ASSIGN;
+  block2->next->loc = gfc_current_locus;
+  block2->next->expr1 = gfc_lval_expr_from_sym (ptr2);
+  block2->next->expr2 = gfc_lval_expr_from_sym (ptr);
 
+  /* Call now the user's final subroutine. */
   block->next  = XCNEW (gfc_code);
   block = block->next;
   block->op = EXEC_CALL;
@@ -1262,21 +1434,26 @@  finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
   block->block = gfc_get_code ();
   block->block->op = EXEC_DO;
 
+  /* Offset calculation of "array".  */
+  block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
+				    byte_stride, rank, block->block, sub_ns);
+
   /* Create code for
      CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
-		       + idx * stride, c_ptr), ptr).  */
-  block->block->next = finalization_scalarizer (idx, array, ptr,
-						gfc_lval_expr_from_sym (stride),
-						sub_ns);
-  block->block->next->next = finalization_scalarizer (idx, tmp_array, ptr2,
-						      gfc_copy_expr (size_expr),
-						      sub_ns);
+		       + offset, c_ptr), ptr).  */
+  block2->next = finalization_scalarizer (array, ptr,
+					  gfc_lval_expr_from_sym (offset),
+					  sub_ns);
+  block2 = block2->next;
+  block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns);
+  block2 = block2->next;
+
   /* ptr = ptr2.  */
-  block->block->next->next->next = XCNEW (gfc_code);
-  block->block->next->next->next->op = EXEC_ASSIGN;
-  block->block->next->next->next->loc = gfc_current_locus;
-  block->block->next->next->next->expr1 = gfc_lval_expr_from_sym (ptr);
-  block->block->next->next->next->expr2 = gfc_lval_expr_from_sym (ptr2);
+  block2->next = XCNEW (gfc_code);
+  block2->next->op = EXEC_ASSIGN;
+  block2->next->loc = gfc_current_locus;
+  block2->next->expr1 = gfc_lval_expr_from_sym (ptr);
+  block2->next->expr2 = gfc_lval_expr_from_sym (ptr2);
 }
 
 
@@ -1300,16 +1477,17 @@  static void
 generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 			       const char *tname, gfc_component *vtab_final)
 {
-  gfc_symbol *final, *array, *nelem, *fini_coarray, *stride;
-  gfc_symbol *ptr = NULL, *idx = NULL;
+  gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides;
+  gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem;
   gfc_symtree *size_intr;
   gfc_component *comp;
   gfc_namespace *sub_ns;
-  gfc_code *last_code;
+  gfc_code *last_code, *block;
   char name[GFC_MAX_SYMBOL_LEN+1];
   bool finalizable_comp = false;
   bool expr_null_wrapper = false;
-  gfc_expr *ancestor_wrapper = NULL;
+  gfc_expr *ancestor_wrapper = NULL, *rank;
+  gfc_iterator *iter;
 
   /* Search for the ancestor's finalizers. */
   if (derived->attr.extension && derived->components
@@ -1423,22 +1601,22 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   gfc_commit_symbol (array);
 
   /* Set up formal argument.  */
-  gfc_get_symbol ("stride", sub_ns, &stride);
-  stride->ts.type = BT_INTEGER;
-  stride->ts.kind = gfc_index_integer_kind;
-  stride->attr.flavor = FL_VARIABLE;
-  stride->attr.dummy = 1;
-  stride->attr.value = 1;
-  stride->attr.artificial = 1;
-  gfc_set_sym_referenced (stride);
+  gfc_get_symbol ("byte_stride", sub_ns, &byte_stride);
+  byte_stride->ts.type = BT_INTEGER;
+  byte_stride->ts.kind = gfc_index_integer_kind;
+  byte_stride->attr.flavor = FL_VARIABLE;
+  byte_stride->attr.dummy = 1;
+  byte_stride->attr.value = 1;
+  byte_stride->attr.artificial = 1;
+  gfc_set_sym_referenced (byte_stride);
   final->formal->next = gfc_get_formal_arglist ();
-  final->formal->next->sym = stride;
-  gfc_commit_symbol (stride);
+  final->formal->next->sym = byte_stride;
+  gfc_commit_symbol (byte_stride);
 
   /* Set up formal argument.  */
   gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray);
   fini_coarray->ts.type = BT_LOGICAL;
-  fini_coarray->ts.kind = 4;
+  fini_coarray->ts.kind = 1;
   fini_coarray->attr.flavor = FL_VARIABLE;
   fini_coarray->attr.dummy = 1;
   fini_coarray->attr.value = 1;
@@ -1457,6 +1635,90 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
       return;
     }
 
+  /* Local variables.  */
+
+  gfc_get_symbol ("idx", sub_ns, &idx);
+  idx->ts.type = BT_INTEGER;
+  idx->ts.kind = gfc_index_integer_kind;
+  idx->attr.flavor = FL_VARIABLE;
+  idx->attr.artificial = 1;
+  gfc_set_sym_referenced (idx);
+  gfc_commit_symbol (idx);
+
+  gfc_get_symbol ("idx2", sub_ns, &idx2);
+  idx2->ts.type = BT_INTEGER;
+  idx2->ts.kind = gfc_index_integer_kind;
+  idx2->attr.flavor = FL_VARIABLE;
+  idx2->attr.artificial = 1;
+  gfc_set_sym_referenced (idx2);
+  gfc_commit_symbol (idx2);
+
+  gfc_get_symbol ("offset", sub_ns, &offset);
+  offset->ts.type = BT_INTEGER;
+  offset->ts.kind = gfc_index_integer_kind;
+  offset->attr.flavor = FL_VARIABLE;
+  offset->attr.artificial = 1;
+  gfc_set_sym_referenced (offset);
+  gfc_commit_symbol (offset);
+
+  /* Create RANK expression.  */
+  rank = gfc_get_expr ();
+  rank->expr_type = EXPR_FUNCTION;
+  rank->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_RANK);
+  gfc_get_sym_tree ("rank", sub_ns, &rank->symtree, false);
+  rank->symtree->n.sym->intmod_sym_id = GFC_ISYM_RANK;
+  rank->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  rank->symtree->n.sym->attr.intrinsic = 1;
+  gfc_commit_symbol (rank->symtree->n.sym);
+  rank->value.function.actual = gfc_get_actual_arglist ();
+  rank->value.function.actual->expr = gfc_lval_expr_from_sym (array);
+  rank->ts = rank->value.function.isym->ts;
+  gfc_convert_type (rank, &idx->ts, 2);
+
+  /* Create is_contiguous variable.  */
+  gfc_get_symbol ("is_contiguous", sub_ns, &is_contiguous);
+  is_contiguous->ts.type = BT_LOGICAL;
+  is_contiguous->ts.kind = gfc_default_logical_kind;
+  is_contiguous->attr.flavor = FL_VARIABLE;
+  is_contiguous->attr.artificial = 1;
+  gfc_set_sym_referenced (is_contiguous);
+  gfc_commit_symbol (is_contiguous);
+
+  /* Create "sizes(0..rank)" variable, which contains the multiplied
+     up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
+     sizes(2) = sizes(1) * extent(dim=2) etc.  */
+  gfc_get_symbol ("sizes", sub_ns, &sizes);
+  sizes->ts.type = BT_INTEGER;
+  sizes->ts.kind = gfc_index_integer_kind;
+  sizes->attr.flavor = FL_VARIABLE;
+  sizes->attr.dimension = 1;
+  sizes->attr.artificial = 1;
+  sizes->as = gfc_get_array_spec();
+  sizes->attr.intent = INTENT_INOUT;
+  sizes->as->type = AS_EXPLICIT;
+  sizes->as->rank = 1;
+  sizes->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+  sizes->as->upper[0] = gfc_copy_expr (rank);
+  gfc_set_sym_referenced (sizes);
+  gfc_commit_symbol (sizes);
+
+  /* Create "strides(1..rank)" variable, which contains the strides per
+     dimension.  */
+  gfc_get_symbol ("strides", sub_ns, &strides);
+  strides->ts.type = BT_INTEGER;
+  strides->ts.kind = gfc_index_integer_kind;
+  strides->attr.flavor = FL_VARIABLE;
+  strides->attr.dimension = 1;
+  strides->attr.artificial = 1;
+  strides->as = gfc_get_array_spec();
+  strides->attr.intent = INTENT_INOUT;
+  strides->as->type = AS_EXPLICIT;
+  strides->as->rank = 1;
+  strides->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  strides->as->upper[0] = gfc_copy_expr (rank);
+  gfc_set_sym_referenced (strides);
+  gfc_commit_symbol (strides);
+
 
   /* Set return value to 0.  */
   last_code = XCNEW (gfc_code);
@@ -1466,6 +1728,206 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
   sub_ns->code = last_code;
 
+  /* Set:  is_contiguous = .true.  */
+  last_code->next = XCNEW (gfc_code);
+  last_code = last_code->next;
+  last_code->op = EXEC_ASSIGN;
+  last_code->loc = gfc_current_locus;
+  last_code->expr1 = gfc_lval_expr_from_sym (is_contiguous);
+  last_code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
+					   &gfc_current_locus, true);
+
+  /* Set:  sizes(0) = 1.  */
+  last_code->next = XCNEW (gfc_code);
+  last_code = last_code->next;
+  last_code->op = EXEC_ASSIGN;
+  last_code->loc = gfc_current_locus;
+  last_code->expr1 = gfc_lval_expr_from_sym (sizes);
+  last_code->expr1->ref = gfc_get_ref ();
+  last_code->expr1->ref->type = REF_ARRAY;
+  last_code->expr1->ref->u.ar.type = AR_ELEMENT;
+  last_code->expr1->ref->u.ar.dimen = 1;
+  last_code->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  last_code->expr1->ref->u.ar.start[0]
+		= gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+  last_code->expr1->ref->u.ar.as = sizes->as;
+  last_code->expr2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+
+  /* Create:
+     DO idx = 1, rank
+       strides(idx) = _F._stride (array, dim=idx)
+       sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
+       if (strides(idx) /= sizes(i-1)) is_contiguous = .false.
+     END DO.  */
+
+  /* Create loop.  */
+  iter = gfc_get_iterator ();
+  iter->var = gfc_lval_expr_from_sym (idx);
+  iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  iter->end = gfc_copy_expr (rank);
+  iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  last_code->next = XCNEW (gfc_code);
+  last_code = last_code->next;
+  last_code->op = EXEC_DO;
+  last_code->loc = gfc_current_locus;
+  last_code->ext.iterator = iter;
+  last_code->block = gfc_get_code ();
+  last_code->block->op = EXEC_DO;
+
+  /* strides(idx) = _F._stride(array,dim=idx). */
+  last_code->block->next = XCNEW (gfc_code);
+  block = last_code->block->next;
+  block->op = EXEC_ASSIGN;
+  block->loc = gfc_current_locus;
+
+  block->expr1 = gfc_lval_expr_from_sym (strides);
+  block->expr1->ref = gfc_get_ref ();
+  block->expr1->ref->type = REF_ARRAY;
+  block->expr1->ref->u.ar.type = AR_ELEMENT;
+  block->expr1->ref->u.ar.dimen = 1;
+  block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
+  block->expr1->ref->u.ar.as = strides->as;
+
+  block->expr2 = gfc_get_expr ();
+  block->expr2->expr_type = EXPR_FUNCTION;
+  block->expr2->value.function.isym
+	= gfc_intrinsic_function_by_id (GFC_ISYM_STRIDE);
+  gfc_get_sym_tree (GFC_PREFIX ("stride"), sub_ns,
+		    &block->expr2->symtree, false);
+  block->expr2->symtree->n.sym->intmod_sym_id = GFC_ISYM_STRIDE;
+  block->expr2->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  block->expr2->symtree->n.sym->attr.intrinsic = 1;
+  gfc_commit_symbol (block->expr2->symtree->n.sym);
+  block->expr2->value.function.actual = gfc_get_actual_arglist ();
+  block->expr2->value.function.actual->expr = gfc_lval_expr_from_sym (array);
+  /* dim=idx. */
+  block->expr2->value.function.actual->next = gfc_get_actual_arglist ();
+  block->expr2->value.function.actual->next->expr
+	= gfc_lval_expr_from_sym (idx);
+  block->expr2->ts = block->expr2->value.function.isym->ts;
+
+  /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
+  block->next = XCNEW (gfc_code);
+  block = block->next;
+  block->op = EXEC_ASSIGN;
+  block->loc = gfc_current_locus;
+
+  /* sizes(idx) = ... */
+  block->expr1 = gfc_lval_expr_from_sym (sizes);
+  block->expr1->ref = gfc_get_ref ();
+  block->expr1->ref->type = REF_ARRAY;
+  block->expr1->ref->u.ar.type = AR_ELEMENT;
+  block->expr1->ref->u.ar.dimen = 1;
+  block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
+  block->expr1->ref->u.ar.as = sizes->as;
+
+  block->expr2 = gfc_get_expr ();
+  block->expr2->expr_type = EXPR_OP;
+  block->expr2->value.op.op = INTRINSIC_TIMES;
+
+  /* sizes(idx-1). */
+  block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
+  block->expr2->value.op.op1->ref = gfc_get_ref ();
+  block->expr2->value.op.op1->ref->type = REF_ARRAY;
+  block->expr2->value.op.op1->ref->u.ar.as = sizes->as;
+  block->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
+  block->expr2->value.op.op1->ref->u.ar.dimen = 1;
+  block->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  block->expr2->value.op.op1->ref->u.ar.start[0] = gfc_get_expr ();
+  block->expr2->value.op.op1->ref->u.ar.start[0]->expr_type = EXPR_OP;
+  block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
+  block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1
+	= gfc_lval_expr_from_sym (idx);
+  block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op2
+	= gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  block->expr2->value.op.op1->ref->u.ar.start[0]->ts
+	= block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1->ts;
+
+  /* size(array, dim=idx, kind=index_kind).  */
+  block->expr2->value.op.op2 = gfc_get_expr ();
+  block->expr2->value.op.op2->expr_type = EXPR_FUNCTION;
+  block->expr2->value.op.op2->value.function.isym
+	= gfc_intrinsic_function_by_id (GFC_ISYM_SIZE);
+  gfc_get_sym_tree ("size", sub_ns, &block->expr2->value.op.op2->symtree,
+		    false);
+  size_intr = block->expr2->value.op.op2->symtree;
+  block->expr2->value.op.op2->symtree->n.sym->intmod_sym_id = GFC_ISYM_SIZE;
+  block->expr2->value.op.op2->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  block->expr2->value.op.op2->symtree->n.sym->attr.intrinsic = 1;
+  gfc_commit_symbol (block->expr2->value.op.op2->symtree->n.sym);
+  block->expr2->value.op.op2->value.function.actual
+	= gfc_get_actual_arglist ();
+  block->expr2->value.op.op2->value.function.actual->expr
+	= gfc_lval_expr_from_sym (array);
+  /* dim=idx. */
+  block->expr2->value.op.op2->value.function.actual->next
+	= gfc_get_actual_arglist ();
+  block->expr2->value.op.op2->value.function.actual->next->expr
+	= gfc_lval_expr_from_sym (idx);
+  /* kind=c_intptr_t. */
+  block->expr2->value.op.op2->value.function.actual->next->next
+	= gfc_get_actual_arglist ();
+  block->expr2->value.op.op2->value.function.actual->next->next->expr
+	= gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+  block->expr2->value.op.op2->ts = idx->ts;
+  block->expr2->ts = idx->ts;
+
+  /* if (strides(idx) /= sizes(idx-1)) is_contiguous = .false.  */
+  block->next = XCNEW (gfc_code);
+  block = block->next;
+  block->loc = gfc_current_locus;
+  block->op = EXEC_IF;
+
+  block->block = XCNEW (gfc_code);
+  block = block->block;
+  block->loc = gfc_current_locus;
+  block->op = EXEC_IF;
+
+  /* if condition: strides(idx) /= sizes(idx-1).  */
+  block->expr1 = gfc_get_expr ();
+  block->expr1->ts.type = BT_LOGICAL;
+  block->expr1->ts.kind = gfc_default_logical_kind;
+  block->expr1->expr_type = EXPR_OP;
+  block->expr1->where = gfc_current_locus;
+  block->expr1->value.op.op = INTRINSIC_NE;
+
+  block->expr1->value.op.op1 = gfc_lval_expr_from_sym (strides);
+  block->expr1->value.op.op1->ref = gfc_get_ref ();
+  block->expr1->value.op.op1->ref->type = REF_ARRAY;
+  block->expr1->value.op.op1->ref->u.ar.type = AR_ELEMENT;
+  block->expr1->value.op.op1->ref->u.ar.dimen = 1;
+  block->expr1->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  block->expr1->value.op.op1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
+  block->expr1->value.op.op1->ref->u.ar.as = strides->as;
+
+  block->expr1->value.op.op2 = gfc_lval_expr_from_sym (sizes);
+  block->expr1->value.op.op2->ref = gfc_get_ref ();
+  block->expr1->value.op.op2->ref->type = REF_ARRAY;
+  block->expr1->value.op.op2->ref->u.ar.as = sizes->as;
+  block->expr1->value.op.op2->ref->u.ar.type = AR_ELEMENT;
+  block->expr1->value.op.op2->ref->u.ar.dimen = 1;
+  block->expr1->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  block->expr1->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
+  block->expr1->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
+  block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
+  block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1
+	= gfc_lval_expr_from_sym (idx);
+  block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op2
+	= gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+  block->expr1->value.op.op2->ref->u.ar.start[0]->ts
+	= block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
+
+  /* if body: is_contiguous = .false.  */
+  block->next = XCNEW (gfc_code);
+  block = block->next;
+  block->op = EXEC_ASSIGN;
+  block->loc = gfc_current_locus;
+  block->expr1 = gfc_lval_expr_from_sym (is_contiguous);
+  block->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
+				       &gfc_current_locus, false);
+
   /* Obtain the size (number of elements) of "array" MINUS ONE,
      which is used in the scalarization.  */
   gfc_get_symbol ("nelem", sub_ns, &nelem);
@@ -1476,7 +1938,7 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   gfc_set_sym_referenced (nelem);
   gfc_commit_symbol (nelem);
 
-  /* Generate: nelem = SIZE (array) - 1.  */
+  /* nelem = sizes (rank) - 1.  */
   last_code->next = XCNEW (gfc_code);
   last_code = last_code->next;
   last_code->op = EXEC_ASSIGN;
@@ -1491,32 +1953,14 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 	= gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
   last_code->expr2->ts = last_code->expr2->value.op.op2->ts;
 
-  last_code->expr2->value.op.op1 = gfc_get_expr ();
-  last_code->expr2->value.op.op1->expr_type = EXPR_FUNCTION;
-  last_code->expr2->value.op.op1->value.function.isym
-	= gfc_intrinsic_function_by_id (GFC_ISYM_SIZE);
-  gfc_get_sym_tree ("size", sub_ns, &last_code->expr2->value.op.op1->symtree,
-		    false);
-  size_intr = last_code->expr2->value.op.op1->symtree;
-  last_code->expr2->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
-  last_code->expr2->value.op.op1->symtree->n.sym->attr.intrinsic = 1;
-  gfc_commit_symbol (last_code->expr2->value.op.op1->symtree->n.sym);
-  last_code->expr2->value.op.op1->value.function.actual
-	= gfc_get_actual_arglist ();
-  last_code->expr2->value.op.op1->value.function.actual->expr
-	= gfc_lval_expr_from_sym (array);
-  /* dim=NULL. */
-  last_code->expr2->value.op.op1->value.function.actual->next
-	= gfc_get_actual_arglist ();
-  /* kind=c_intptr_t. */
-  last_code->expr2->value.op.op1->value.function.actual->next->next
-	= gfc_get_actual_arglist ();
-  last_code->expr2->value.op.op1->value.function.actual->next->next->expr
-	= gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
-  last_code->expr2->value.op.op1->ts
-	= last_code->expr2->value.op.op1->value.function.isym->ts;
-
-  sub_ns->code = last_code;
+  last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
+  last_code->expr2->value.op.op1->ref = gfc_get_ref ();
+  last_code->expr2->value.op.op1->ref->type = REF_ARRAY;
+  last_code->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
+  last_code->expr2->value.op.op1->ref->u.ar.dimen = 1;
+  last_code->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+  last_code->expr2->value.op.op1->ref->u.ar.start[0] = gfc_copy_expr (rank);
+  last_code->expr2->value.op.op1->ref->u.ar.as = sizes->as;
 
   /* Call final subroutines. We now generate code like:
      use iso_c_binding
@@ -1539,15 +1983,6 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   if (derived->f2k_derived && derived->f2k_derived->finalizers)
     {
       gfc_finalizer *fini, *fini_elem = NULL;
-      gfc_code *block = NULL;
-
-      gfc_get_symbol ("idx", sub_ns, &idx);
-      idx->ts.type = BT_INTEGER;
-      idx->ts.kind = gfc_index_integer_kind;
-      idx->attr.flavor = FL_VARIABLE;
-      idx->attr.artificial = 1;
-      gfc_set_sym_referenced (idx);
-      gfc_commit_symbol (idx);
 
       gfc_get_symbol ("ptr", sub_ns, &ptr);
       ptr->ts.type = BT_DERIVED;
@@ -1563,20 +1998,8 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
       last_code = last_code->next;
       last_code->op = EXEC_SELECT;
       last_code->loc = gfc_current_locus;
-
-      last_code->expr1 = gfc_get_expr ();
-      last_code->expr1->expr_type = EXPR_FUNCTION;
-      last_code->expr1->value.function.isym
-	    = gfc_intrinsic_function_by_id (GFC_ISYM_RANK);
-      gfc_get_sym_tree ("rank", sub_ns, &last_code->expr1->symtree,
-			false);
-      last_code->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
-      last_code->expr1->symtree->n.sym->attr.intrinsic = 1;
-      gfc_commit_symbol (last_code->expr1->symtree->n.sym);
-      last_code->expr1->value.function.actual = gfc_get_actual_arglist ();
-      last_code->expr1->value.function.actual->expr
-	    = gfc_lval_expr_from_sym (array);
-      last_code->expr1->ts = last_code->expr1->value.function.isym->ts;
+      last_code->expr1 = gfc_copy_expr (rank);
+      block = NULL;
 
       for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next)
 	{
@@ -1613,8 +2036,10 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 
 	  /* CALL fini_rank (array) - possibly with packing.  */
           if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
-	    finalizer_insert_packed_call (block, fini, array, stride, idx, ptr,
-					  nelem, size_intr, sub_ns);
+	    finalizer_insert_packed_call (block, fini, array, byte_stride,
+					  idx, ptr, nelem, size_intr, strides,
+					  sizes, idx2, offset, is_contiguous,
+					  rank, sub_ns);
 	  else
 	    {
 	      block->next = XCNEW (gfc_code);
@@ -1630,8 +2055,6 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
       /* Elemental call - scalarized.  */
       if (fini_elem)
 	{
-	  gfc_iterator *iter;
-
 	  /* CASE DEFAULT.  */
 	  if (block)
 	    {
@@ -1661,14 +2084,19 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 	  block->block = gfc_get_code ();
 	  block->block->op = EXEC_DO;
 
+	  /* Offset calculation.  */
+	  block = finalization_get_offset (idx, idx2, offset, strides, sizes,
+					   byte_stride, rank, block->block,
+					   sub_ns);
+
 	  /* Create code for
 	     CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
-			       + idx * stride, c_ptr), ptr).  */
-	  block->block->next
-			= finalization_scalarizer (idx, array, ptr,
-						   gfc_lval_expr_from_sym (stride),
-						   sub_ns);
-	  block = block->block->next;
+			       + offset, c_ptr), ptr).  */
+	  block->next
+		= finalization_scalarizer (array, ptr,
+					   gfc_lval_expr_from_sym (offset),
+					   sub_ns);
+	  block = block->next;
 
 	  /* CALL final_elemental (array).  */
 	  block->next = XCNEW (gfc_code);
@@ -1689,18 +2117,6 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
     {
       gfc_symbol *stat;
       gfc_code *block = NULL;
-      gfc_iterator *iter;
-
-      if (!idx)
-	{
-	  gfc_get_symbol ("idx", sub_ns, &idx);
-	  idx->ts.type = BT_INTEGER;
-	  idx->ts.kind = gfc_index_integer_kind;
-	  idx->attr.flavor = FL_VARIABLE;
-	  idx->attr.artificial = 1;
-	  gfc_set_sym_referenced (idx);
-	  gfc_commit_symbol (idx);
-	}
 
       if (!ptr)
 	{
@@ -1736,14 +2152,18 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
       last_code->block = gfc_get_code ();
       last_code->block->op = EXEC_DO;
 
+      /* Offset calculation.  */
+      block = finalization_get_offset (idx, idx2, offset, strides, sizes,
+				       byte_stride, rank, last_code->block,
+				       sub_ns);
+
       /* Create code for
 	 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
 			   + idx * stride, c_ptr), ptr).  */
-      last_code->block->next
-		= finalization_scalarizer (idx, array, ptr,
-					   gfc_lval_expr_from_sym (stride),
-					   sub_ns);
-      block = last_code->block->next;
+      block->next = finalization_scalarizer (array, ptr,
+					     gfc_lval_expr_from_sym(offset),
+					     sub_ns);
+      block = block->next;
 
       for (comp = derived->components; comp; comp = comp->next)
 	{
@@ -1772,12 +2192,13 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
       last_code->ext.actual = gfc_get_actual_arglist ();
       last_code->ext.actual->expr = gfc_lval_expr_from_sym (array);
       last_code->ext.actual->next = gfc_get_actual_arglist ();
-      last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (stride);
+      last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (byte_stride);
       last_code->ext.actual->next->next = gfc_get_actual_arglist ();
       last_code->ext.actual->next->next->expr
 			= gfc_lval_expr_from_sym (fini_coarray);
     }
 
+  gfc_free_expr (rank);
   vtab_final->initializer = gfc_lval_expr_from_sym (final);
   vtab_final->ts.interface = final;
 }