Translating Mathematica expression to High Performance Fortran

Evaluate this

Unprotect[FortranForm]
SetAttributes[FortranForm, HoldFirst]
SetAttributes[NewVariables, HoldFirst]
SetAttributes[LeftHand, HoldFirst]
\(\(\(Clear[HPFForm, NewVariables, \ LeftHand, \ ListablePure]\)\(
\)
    \)\)
\(\(HPFForm[ls_] := 
        StringJoin\  @@ \ \((ToString\  /@ \ ls)\);\)
\)
\(\(LeftHand[name_, 
          indexes_List] := 
	\(ToString[HoldForm[name]] <> "(" <> 
                Fold[#1 <> "," <> #2 &, First[#1], Rest[#1]] &\)[
            indexes] <> ")";\)
\)
\(\(LeftHand[name_, index1_String, dims_Integer] := 

        LeftHand[name, 
          Prepend[Table[":", {dims}], index1]];\)
	\)
\(\(FortranForm[Set[ls_, rs_]] := 
        HPFForm[{FortranForm[HoldForm[ls]], "=", 
            FortranForm[HoldForm[rs]]}];\)
\)
\(\(FortranForm[Dimensions[ls_]] := 
        HPFForm[{StringTake[
              ToString[Dimensions[ls]], {2, \(-2\)}]}];\)
\)
\(\(FortranForm[Set[ls1_, Table[f_, iterators__]]] := 
	
        Module[{lefthand, righthand, iters, forall}, 
\ \ \ iters = \ 
            Map[\((#1 <> "=" <> #2 <> ":" <> #3 &\ )\) @@ \ \(ToString /@ #1\) &, {iterators}]; 
	\ lefthand = 
            LeftHand[
              ls1, \(ToString[
                    First[#1]] &\) /@ \ {iterators}]; 
		righthand = 
            FortranForm[
              f]; 
	\ forall = \("forall(" <> 
                    Fold[#1 <> "," <> #2 &, First[#1], Rest[#1]] &\)[
                iters] <> ")"; 
	\ HPFForm[{"!hpf$ INDEPENDENT
", 
              forall, " ", lefthand, "=", 
              righthand}]
\ ];\)
\)
FortranForm[Set[ls1_, Transpose[rs_]]] := 
        HPFForm[{If[Head[ls1] === String, ls1, 
              HoldForm[ls1]], "=", "transpose(", 
            If[Head[rs] === String, rs, HoldForm[rs]], ")"}];
\(NewVariables[Transpose[ls_]] := ""
\)
\(\(FortranForm[Set[ls1_, Map[f_, ls_]]] := 
	
        Module[{lefthand, righthand}, 

          lefthand		 = 
            LeftHand[ls1, "i", 
              Length[Dimensions[ls]] - 1]; 
		righthand = 
            LeftHand[ls, "i", Length[Dimensions[ls]] - 1]; 
          HPFForm[{\("!hpf$ INDEPENDENT, NEW(i" <> 
                      If[#1 != "", "," <> #1, #1] &\)[
                  NewVariables[
                    f[righthand]]] <> \ ")
", "do i=1,size(" <> 
                ToString[HoldForm[ls]] <> ",1)
", 
              FortranForm[
                Evaluate[lefthand] = 
                  f[Evaluate[
                      righthand]]], "
", "end do"}]
	];\)
\)
\(ListablePure[body_] := 

      And\  @@ \ Map[MemberQ[#1, Listable] &, 
          Cases[Map[Attributes, 
              Cases[body, 
                s_Symbol /; \ \((\ 
                    AtomQ[s] && \(! \ \((s === Slot\  || \ 
                            s === HoldForm\  || \ s === Function)\)\))\), 
                Infinity, Heads -> True]], s_ /; s != {}]]
\)
\(\(FortranForm[
          Set[ls1_, \(Function[body_]\)[
                arg_] /; \((MemberQ[{{Slot[1]}, {}}, 
                    Union[Cases[HoldForm[body], Slot[_], Infinity]]]\  && \ 
                  ListablePure[HoldForm[body]])\)]] := 

        Module[{lefthand, righthand, forall, lendim, indexes}, 
		If[
            Head[arg] === String, 
			lendim = 
              Length[StringPosition[arg, ":"]], 
			lendim = 
              Length[Dimensions[arg]]\ 
		]; 
		indexes = 
            StringDrop[\(Nest[{#1[\([1]\)] <> "i" <> 
                        ToString[#1[\([2]\)]] <> ",", #1[\([2]\)] + 
                        1} &, {"", 1}, 
                  lendim]\)[\([1]\)], \(-1\)]; 
		If[
            Head[ls1] === String, 
			lefthand = 
              StringTake[
                  ls1, \(StringPosition[ls1, ":"]\)[\([1, 1]\)] - 1] <> 
                indexes <> ")", 
			lefthand = 
              ToString[HoldForm[ls1]] <> "(" <> 
                indexes <> ")"
		]; 
		If[
            Head[arg] === String, 
			arghand = 
              StringTake[
                  arg, \(StringPosition[ls1, ":"]\)[\([1, 1]\)] - 1] <> 
                indexes <> ")", 
			arghand = 
              ToString[HoldForm[arg]] <> "(" <> 
                indexes <> ")"
		]; 
		If[
            Head[arg] === String, 
			argname = arg, 
			argname = 
              ToString[
                HoldForm[
                  arg]]
		]; 
		righthand = 
			StringReplace[
              ToString[
                FortranForm[body]], 
			{ToString[FortranForm[Slot[1]]] -> 
                  arghand}]; 
		forall = "forall(" <> 
			StringDrop[\(Nest[{#1[\([1]\)] <> "i" <> 
                          ToString[#1[\([2]\)]] <> "=1:size(" <> 
				argname <> "," <> ToString[#1[\([2]\)]] <> "),", #1[\([2]\)] + 
                          1} &, {"", 1}, 
                    lendim]\)[\([1]\)], \(-1\)] <> ")"; 
		HPFForm[{forall, "
", lefthand, "=", 
              righthand, "
", "end forall"}]
		];\)
\)
\(NewVariables[\(Function[body_]\)[arg_] /; 
          MemberQ[{{Slot[1]}, {}}, 
            Union[Cases[HoldForm[body], Slot[_], Infinity]]]] := 
      Module[{lendim, indexes}, 
		If[
          Head[arg] === String, 
			lendim = 
            Length[StringPosition[arg, ":"]], 
          lendim = Length[Dimensions[arg]]\ ]; 
		indexes = 
          StringDrop[\(Nest[{#1[\([1]\)] <> "i" <> 
                      ToString[#1[\([2]\)]] <> ",", #1[\([2]\)] + 
                      1} &, {"", 1}, 
                lendim]\)[\([1]\)], \(-1\)]; 
		indexes
\ \ ]
	\)
\(\(FortranForm[
          Set[ls1_, Partition[ls_, stride_]]] := 
		Module[{lefthand, 
            righthand, stridestr, \ distributee, \ 
            toblocks}, 
		stridestr = 
            ToString[HoldForm[stride]]; 
		toblocks = 
            Prepend[Table[
                1, {Length[Dimensions[ls]] - 1}], \(Dimensions[ls]\)[\([1]\)]/
                stride]; 
		lefthand = 
            LeftHand[ls1, "i,*", 
              Length[Dimensions[ls]] - 1]; 
		righthand = 
            LeftHand[
              ls, "(i-1)*" <> 
                ToString[\((Dimensions[ls]/toblocks)\)[\([1]\)]] <> "+1", 
              Length[Dimensions[ls]] - 1]; 
		distributee = 
            LeftHand[
              ls, \("BLOCK(" <> #1 <> ")" &\)\  /@ \((ToString\  /@ \ \((Dimensions[ls]/toblocks)\))\)]; 	
		AppendTo[HPFSPECIFICATIONS, 	
            HPFForm[{
		"!hpf$ PROCESSORS ", 
                LeftHand["squad", 
                  ToString /@ \ 
                    toblocks], "
", 	
		"!hpf$ DISTRIBUTE ", 
                distributee, " ONTO ", "squad", "
", 		
		"!hpf$ ALIGN ", 		\ lefthand, 	" WITH ", 		righthand		}]]; 
          lefthand = 
            LeftHand[ls1, "i", Length[Dimensions[ls]]]; 
		righthand = 
            LeftHand[ls, 
              stridestr <> "*(i-1)+1" <> ":" <> 
                stridestr <> "*i", 
              Length[Dimensions[ls]] - 
                1]; 
		HPFForm[{"!hpf$ INDEPENDENT, NEW(i)", "
", "do i=1,size(" <> ToString[HoldForm[ls]] <> ",1)/", 
		HoldForm[
                stride], 	"
", 		lefthand, 		"=", 		righthand, \ 		"
", 		"end do"}]
	];\)
					\)
\(\(FortranForm[Set[ls1_, Fold[f_, x0_, ls_]]] := 
	
        Module[{lefthanddecl, lefthand, 
            righthand}, 
		lefthand = \(If[#1 > 0, 
                  LeftHand[ls1, ":", #1], ToString[HoldForm[ls1]]] &\)[
              Length[Dimensions[ls]] - 2]; 
		righthand = 
            LeftHand[ls, "i", 
              Length[Dimensions[ls]] - 1]; 
		HPFForm[\ {\ 
              lefthand, "=", 
              FortranForm[
                x0], "
", 
			"", "!hpf$ INDEPENDENT, NEW(i), REDUCTION(" <> ToString[ls1] <> ")
", 
			"do i=1,size(" <> 
                ToString[
                  HoldForm[ls]] <> ",1)
", 
			lefthand, "=", 
              f @@ {lefthand\ , 
                  righthand}, "
", "end do"}]
	];\)
\)
\(\(FortranForm[Set[ls1_, \(Function[Fold[f_, x0_, ls_]]\)[arg_]]] := 
	
        Module[{lefthanddecl, lefthand, 
            righthand}, 
		lefthand = \(If[#1 > 0, 
                  LeftHand[ls1, ":", #1], ToString[HoldForm[ls1]]] &\)[
              Length[Dimensions[arg]] - 2]; 
		righthand = 
            LeftHand[arg, "i", 
              Length[Dimensions[arg]] - 1]; 
		HPFForm[\ {\ 
              lefthand, "=", 
              FortranForm[
                x0], "
", 
			"", "!hpf$ INDEPENDENT, NEW(i), REDUCTION(" <> ToString[
                  HoldForm[ls1]] <> ")
", 
			"do i=1,size(" <> 
                ToString[
                  HoldForm[arg]] <> ",1)
", 
			lefthand, "=", 
              f @@ {lefthand\ , 
                  righthand}, "
", "end do"}]
	];\)
\)
\(\(FortranForm[Set[ls1_, \(Composition[f1_, f2__]\)[arg_]]] := 
	
        Module[{lefthands, righthands, lp}, 
		righthands = 
            Prepend[List[f2], f1]; 
		lefthands = 
            MapIndexed[
              ToExpression["v" <> ToString[#2[\([1]\)]] <> 
                    StringTake[ToString[#1], 4]] &\ , 
              Head\  /@ \ righthands]; 
		lp = 
            MapThread[{"!hpf$ ON HOME(" <> 
                    ToString[Evaluate[#1]] <> "), RESIDENT, BEGIN 
", 
                  FortranForm[
                    Evaluate[#1] = #2[
                        arg]], "
", \ "!hpf$ END ON 
"} &, {lefthands, righthands}]; 
		lp = 
            Join[Take[lp, 1], 
              MapThread[
                StringReplace[#1, 
                    ToString[HoldForm[arg]] -> ToString[#2]] &, {Rest[lp], 
                  Take[lefthands, {1, \(-2\)}]}]]; 
		lp = 
            Transpose[{lp, 
                Map[ToString[#[\([2]\)]] <> "=" <> 
                      ToString[#[\([1]\)]] <> "
" &, 
                  Partition[Append[lefthands, ls1], 2, 1]]}]; 
		lp = 
            Flatten[lp]; 
		HPFForm[\ 
            Join[{\ "!hpf$ TASK_REGION 
"}, 
              lp, {"!hpf$ END TASK_REGION 
"}]]
	];\)
\)
\(\(FortranForm[
          Set[ls1_, Map[Function[Fold[f_, x0_, Slot[1]]], ls_]]] := 
	
        Module[{lefthand, righthand}, 
\ \ \ \ lefthand = 
            LeftHand[ls1, "i1", 
              Length[Dimensions[ls]] - 2]; 
		righthand = 
            LeftHand[ls, "i1", Length[Dimensions[ls]] - 1]; 
          HPFForm[{\("!hpf$ INDEPENDENT, NEW(i" <> 
                      If[#1 != "", "," <> #1, #1] &\)[
                  NewVariables[\(Function[Fold[f, x0, Slot[1]]]\)[
                      righthand]]] <> \ ")
", "do i=1,size(" <> 
                ToString[HoldForm[ls]] <> ",1)
", 
              StringReplace[
                FortranForm[
                  Evaluate[lefthand] = \(Function[Fold[f, x0, Slot[1]]]\)[
                      Evaluate[righthand]]], {LeftHand["", "i1", 
                        Length[Dimensions[ls]] - 1] <> "(i)" -> 
                    LeftHand["", "i1,i", 
                      Length[Dimensions[ls]] - 
                        2]}], "
", "end do"}]
	];\)
\)
bsize = 4
line = Table[i, {i, 8}]
image = Table[i, {i, 1, 8}, {j, 1, 8}];
image // MatrixForm
im1 = Partition[image, bsize];
im1 // MatrixForm
im2 = Map[Transpose, im1];
im2 // MatrixForm

Examples

HPFSPECIFICATIONS = {};

FortranForm[im1 = Partition[image, bsize]]FortranForm[im2 = Map[Transpose, im1]]FortranForm[im4 = #1^2&[im1]]FortranForm[im2 = Map[#1^2&, im1]]FortranForm[im2 = Map[Sin[#1]&, im1]]FortranForm[im3 = Fold[Plus, x0, im1]]

FortranForm[r1 = Composition[Sin[#1]& , Cos[#1]&, #1^2&][im2]]

Sample Session

bsize = 4
line = Table[i, {i, 1, 8}]
image = Table[i, {i, 1, 8}, {j, 1, 8}]
im1 = Partition[image, bsize]
im2 = Map[Transpose, im1]
im1 = Partition[image, bsize]
im2 = Map[Transpose, im1]
im2 = Map[#1^2 &, im1]
im3 = Fold[Plus, x0, im1]

Clear[PreFunction]
FORTRANPROGRAM = {};
HPFSPECIFICATIONS = {};
PreFunction[u___] := 
      Module[{}, AppendTo[FORTRANPROGRAM  , FortranForm[u]]; u;]
SetAttributes[PreFunction, HoldFirst]

FORTRANPROGRAM = {}; HPFSPECIFICATIONS = {};
\($Pre = PreFunction
\)
Clear[bsize, line, image, im1, im2, im3]
bsize = 4
line = Table[i, {i, 1, 8}]
image = Table[i, {i, 1, 8}, {j, 1, 8}]
im1 = Partition[image, bsize]
im2 = Map[Transpose, im1]
im2 = Map[#1^2 &, im2]
\(im3 = Fold[Plus, x0, im1]
\)
$Pre =. ;
FORTRANPROGRAM = 
        Join[HPFSPECIFICATIONS, Drop[FORTRANPROGRAM, -1]];

Map[Print, FORTRANPROGRAM];

fprog = OpenWrite["fprog.hpf"]
Map[(Write[fprog, OutputForm[#1]]; 
            Write[fprog, OutputForm[" "]]) &, 
        FORTRANPROGRAM];
Close[fprog]