#!/usr/local/bin/perl
# $Id: irtoc.pl,v 1.5 1997/02/26 16:55:17 haupt Exp $
# Author Tomasz Haupt  (haupt@npac.syr.edu) 1996
#===========================================================================
sub eliminate_dup{
    my ($list)=@_;

    %duplist=0;
    @dup=split(/,/,$list);
    for ($i=0;$i<$#dup+1;$i++){
	if($duplist{$dup[$i]}){
	    $dup[$i]=$dup[$i]."v".$duplist{$dup[$i]};
	    $duplist{$dup[$i]}++;
	}
	else {
	    $duplist{$dup[$i]}=1;
	}
   }
    $list=join(",",@dup);
    return $list;
}

sub eliminate_dup_assign{
    my ($list)=@_;
    my $temp1;
    my $temp2;
    print "$list\n";

    %duplist=0;
    @dup=split(/\n/,$list);
#    for ($i=0;$i<$#dup+1;$i++){
    for ($i=0;$i<$#dup;$i++){
     if($dup[$i]) {      #skip empty lines
        print "read: $dup[$i]\n";
        $dup[$i] =~ /(.+) => (.+)/;
        $temp1 = $1;
        $temp2 = $2;
        print "decomp: $temp1..$temp2..$duplist{$temp2}\n";
	if($duplist{$temp2}){
            print "modify ---> $temp2\n";
	    $temp2=$temp2."v".$duplist{$temp2};
	    $duplist{$temp2}++;
            $dup[$i]=$temp1." => ".$temp2;
	}
	else {
	    $duplist{$temp2}=1;
            print "$temp2 $duplist{$temp2}\n";
	}
    }
   }
    $list=join("\n",@dup);
    $list=$list."\n\n";
    return $list;
}

sub write_fortran{
# $args1="parameters froms C++ goes here"; --> formatted as $alist
# $args2="parameters to fortran goes here";
# $args3="list of grid functions to be delcared"; --> formatted as $clist
# $blist ="other declaration (integer, dimension, etc)"; 

#eliminate duplicates

    local $flag=0;
    %duplist=0;
    local @dup=split(/\n/,$tensors);
    for ($i=0;$i<$#dup;$i++){
        $dup[$i] =~ /.*::\s(\w*)/;
        $dup1=$1;
        $dup2=$1;
	if($duplist{$dup1} != 0){
	    $dup1=$dup1."v".$duplist{$dup1};
	    $duplist{$dup1}++;
            $dup[$i] =~ s/$dup2/$dup1/;
            $flag=1;
	}
	else {
	    $duplist{$dup1}=1;
	}
   }
    $tensors=join("\n",@dup);

    if($flag) {
#modify $assignment
	%duplist=0;
        @dup=split(/\n/,$assignment);
        for ($i=0;$i<$#dup;$i++){
	    if($dup[$i]) {
               $dup[$i] =~ /\s*(\w*\(.*\))%d\s=>\s(\w*)/;
               $dup1=$1;
               $dup2=$1;
               $dup3=$2;
               $dup4=$2;
	         if($duplist{$dup1} != 0){
		     $dup1 =~ /(\w+)(.*)/;
                     $dup5=$1;
                     $dup1 = $1."v".$duplist{$dup2};
                    $dup3=$dup3."v".$duplist{$dup2}; 
	            $duplist{$dup2}++;
                    $dup[$i] =~ s/$dup5/$dup1/;
                    $dup[$i] =~ s/$dup4/$dup3/;
	         }
	         else {
	         $duplist{$dup1}=1;
	    }
        }
    }
    $assignment=join("\n",@dup);
    }

    $args1=eliminate_dup($args1);
    $args2=eliminate_dup($args2);
    $args3=eliminate_dup($args3);
#    $assignment=eliminate_dup_assign($assignment);

# get rid off the trailing "," in the argument lists
#chop($args1); 
#chop($args2);
#chop($args3);

# format argument (arg1) list
local $alist="      ".$args1;
local $l=length($alist);
local $comma=0;

if($l>61) {
 local $newlist="";
 local @aw=split(//,$alist);
 for($i=0;$i<$l;$i++) {
  $newlist=$newlist.$aw[$i];
  if($i>0 && $i%60 == 0) {
     $comma=1;
  }
  if(($comma==1) && ($aw[$i] eq ",")) {
       $newlist=$newlist." &\n     ";
       $comma=0;
  }
 }
$alist=$newlist;
} 

# format argument (args2) list
local $l=length($args2);
local $comma=0;

if($l>41) {
 local $newlist="";
 local @aw=split(//,$args2);
 for($i=0;$i<$l;$i++) {
  $newlist=$newlist.$aw[$i];
  if($i>0 && $i%40 == 0) {
     $comma=1;
  }
  if(($comma==1) && ($aw[$i] eq ",")) {
       $newlist=$newlist." &\n     ";
       $comma=0;
  }
 }
$args2=$newlist;
} 

# format argument (args3) list
local $clist="      ".$args3;
      $l=length($clist);
      $comma=0;

if($l>61) {
 $newlist="";
 local @cw=split(//,$clist);
 for($i=0;$i<$l;$i++) {
  $newlist=$newlist.$cw[$i];
  if($i>0 && $i%60 == 0) {
     $comma=1;
  }
  if(($comma==1) && ($cw[$i] eq ",")) {
       $newlist=$newlist." &\n     ";
       $comma=0;
  }
 }
$clist=$newlist;
} 


local $fname=">f_".$funcname.".f90";

open(FORTRAN,$fname);
print FORTRAN "  subroutine f_$funcname(lb,ub,s, &\n";
print FORTRAN "  $alist)\n";
print FORTRAN "  use tensors\n";
print FORTRAN "  use input_params\n";
print FORTRAN "  use $org_funcname";
print FORTRAN "_i !F90 interface blok for $funcname\n";
print FORTRAN "  implicit none\n";
print FORTRAN "  integer, dimension(3)         :: lb,ub,s\n";
print FORTRAN "  real*8, dimension(s(1),s(2),s(3)), target :: & \n";
print FORTRAN "  $clist \n";
print FORTRAN "  $blist \n";
print FORTRAN "  $tensors \n";

if($params) {
print FORTRAN "  real*8 h,dt\n";
}

if($flg) {
print FORTRAN "  logical init\n";
}

if($alist =~ /init1/) {
print FORTRAN "  logical init\n";
}

if($params) {
print FORTRAN "  h=params(98)\n  dt=params(99)\n\n";
}

    if($alist =~ /params/) {
    print FORTRAN "  params(P_LOCAL_LOWER_X)=lb(1)\n";
    print FORTRAN "  params(P_LOCAL_LOWER_Y)=lb(2)\n";
    print FORTRAN "  params(P_LOCAL_LOWER_Z)=lb(3)\n";
    print FORTRAN "  params(P_LOCAL_UPPER_X)=ub(1)\n";
    print FORTRAN "  params(P_LOCAL_UPPER_Y)=ub(2)\n";
    print FORTRAN "  params(P_LOCAL_UPPER_Z)=ub(3)\n\n";
}

if($flg) {
print FORTRAN "  if(flg==1) then \n     init=.true.\n";
print FORTRAN "  else \n     init=.false.\n  endif\n";
} 

if($alist =~ /init1/) {
    print FORTRAN "  init=.false.\n";
    $args2 =~ s/init1/init/;
}

print FORTRAN "  $assignment";
print FORTRAN "call $org_funcname($args2)\n";
print FORTRAN "  return\n";
print FORTRAN "  end\n";
close(FORTRAN);
}

sub add_params {
 if($varname eq "params") {
    $args2=$args2."params,";
 }  
 if(!$params){
    print OUTFH ",\n       params";
    print HFH   ",\n   double *";
    $args1=$args1."params,";
    $blist=$blist."real*8,dimension(100) :: params\n  ";
    $params=1;
 }


}

sub add_integer {
 local $intname=$amp.$varname;

 if($varname eq "init") {
#   a small trick here: C++ integer is converted to FORTRAN logical
    $flg=1;
    $args1=$args1."flg,";
    $args2=$args2."init,"; 
    $blist=$blist."integer flg\n  ";
    print OUTFH ",\n       $intname";
    print HFH   ",\n   int *";
 }
 elsif($varname =~ /params([0-9]+)/) {
     local $num=$1+1;
     $args1=$args1."params".$num.",";
     $args2=$args2."params".$num.",";
     $blist=$blist."integer params".$num."\n  ";
     
     print OUTFH ",\n       (int*) $amp params[".$1."]";
     print HFH   ",\n   int *";
 }    
 else {
    $args1=$args1.$varname.",";
    $args2=$args2.$varname.",";
    $blist=$blist."integer ".$varname."\n  ";
    print OUTFH ",\n       $intname";
    print HFH   ",\n   int *";
 }
}

sub add_double {

 if($type eq "double") {
     $time="t";
 }
 elsif($type eq "double-1") { 
     $time="t-idt";
 }
 else {
     die "error 39 wrong type $type of $varname\n";
 } 
  
 if($varname eq "params"){
     &add_params;
 }

 elsif($varname eq "h") {
# trick: do not pass h, pass parameters instead
    $args2=$args2.$varname.",";
    if(!$params) {
        &add_params;
    }
 }

 elsif($varname eq "dt") {
# trick: do not pass dt, pass parameters instead
    $args2=$args2.$varname.",";
    if(!$params) {
      &add_params;
    }
 }

 elsif($compstring =~ /%(.*)%.*/) {
            # e.g tempt_[%i]%d
            chop $varname;
            print OUTFH ",\n       (*(*$varname).spacetime[$1])(t,Level,cg,DAGH_Main).data()";
            $args1=$args1.$varname.$i.","; 
            $args2=$args2.$varname.$i.","; 
            $args3=$args3.$varname.$i.",";
            print HFH   ",\n   double *";
 }


 elsif($varname =~ /_%d/) {

     if($varname =~ /mask_%d/) {

            print OUTFH ",\n       (*(*theMask).mask)(t,Level,cg,DAGH_Main).data()";
            $args1=$args1.mask.","; 
            $args2=$args2.mask.","; 
            $args3=$args3.mask.",";
            print HFH   ",\n   double *";
     }

     elsif($varname =~ /mask_old_%d/) {

            print OUTFH ",\n       (*(*theMask).mask)(t-idt,Level,cg,DAGH_Main).data()";
            $args1=$args1.maskold.","; 
            $args2=$args2.maskold.","; 
            $args3=$args3.maskold.",";
            print HFH   ",\n   double *";
     }

     else {

# for example: double:interpolator_shift%_d{scalar:c[0]}

	 if($sub_varname) {
	     $name=$sub_varname;
	 }
	 else {
	     $name=$varname;
	 }


	 if($sub_compstring || ($sub_compstring eq "0")){
               print OUTFH ",\n       (*(*$name).spacetime[".$sub_compstring."])($time,Level,cg,DAGH_Main).data()";
	     $varname =~ s/_%d//;
	       if($sub_compstring eq "0") {
#                     $args1=$args1.$name."0,";
                     $args1=$args1.$varname.",";
                     $args2=$args2.$varname.",";
                     $args3=$args3.$name."0,";
#                     $args3=$args3.$name."0,";
                     $args3=$args3.$varname.",";
#                     $ass=$varname." => ".$name."0\n  ";
		 }
               else { 
#                     $args1=$args1.$name.$sub_compstring.",";
                     $args1=$args1.$varname.",";
                     $args2=$args2.$varname.",";
#                     $args3=$args3.$name.$sub_compstring.",";
                     $args3=$args3.$varname.",";
#                     $ass=$varname." => ".$name."$sub_compstring\n  ";
		 }
#               $assignment=$assignment.$ass;
#               $varname =~ s/%d//;
#               $tensors=$tensors."type(GridFunction)          ::".$varname."\n  ";
	 }
	 else {
	     $name =~ s/_%d//;
               print OUTFH ",\n       (*(*$name).spacetime[0])($time,Level,cg,DAGH_Main).data()";
         $args3=$args3.$name.",";
         $args1=$args1.$name.","; 
         $args2=$args2.$name.","; 
         }
         print HFH   ",\n   double *";
	}
 }
  elsif((!$sub_varname) && ($compstring =~ /[0-9]/)) {
# for example: double:k[3]
            print OUTFH ",\n       (*(*$varname).spacetime[$compstring])($time,Level,cg,DAGH_Main).data()";
	    $args1=$args1.$varname."$compstring,";
	    $args2=$args2.$varname."$compstring,";
	    $args3=$args3.$varname."$compstring,";
            print HFH   ",\n   double *";
 
 }

 elsif($varname =~ /params([0-9]+)/) {
     local $num=$1+1;
     $args1=$args1."params".$num.",";
     $args2=$args2."params".$num.",";
     $blist=$blist."real*8 params".$num."\n  ";
     
     print OUTFH ",\n        $amp params[".$1."]";
     print HFH   ",\n   double *";
 }    
 else {
  local $doublename=$amp.$varname;
  print OUTFH ",\n       $doublename";
  print HFH   ",\n   double *";

    $args1=$args1.$varname.",";
    $args2=$args2.$varname.",";
    $blist=$blist."  real*8 ".$varname."\n";
 }
}

sub add_vector {
if($sub_varname) {
   $name=$sub_varname
   }
else {
   $name=$varname
}

if($compstring) {
   die "error 33 cannot process components of a vector\n";
}

local $t="t";

if($type eq "vector-1") {
    $t="t-idt";
    $type="vector";
}
elsif($type eq "vector+1") {
    $t="t+idt";
    $type="vector";
}

if($sub_type eq "vector-1") {
 $t="t-idt";
 $sub_type="";
}
elsif($sub_type eq "vector+1") {
 $t="t+idt";
 $sub_type="";
}

if($sub_type) {
     
   if ($sub_type eq "scalar") {
    local @varg=split(/\+/,$sub_varname);
    if($#varg != 2) {

     die "error 36: vector got to have 3 components!\n";
    }

    local $as="";

    if($sub_varname =~ /\[/) { 

#  scalar:gf[2]+gf[3]+gf[4]     
    

    for ($i=0;$i<3;$i++) {
	$varg[$i] =~ /(.*)\[(.*)\]/;
       print OUTFH ",\n       (*(*$1).spacetime[$2])(t,Level,cg,DAGH_Main).data()";
	$j=$i+1;
        $as=$as.$varname."_(".$j.")%d => ".$1.$2."\n  "; 
        $args1=$args1.$1.$2.",";
        $args3=$args3.$1.$2.",";
   }
        $assignment=$assignment.$as;

   }
   else {

#  scalar: tmp1+tmp2+tmp3  

       print OUTFH ",\n       (*(*$varg[0]).spacetime[0])(t,Level,cg,DAGH_Main).data()";
       print OUTFH ",\n       (*(*$varg[1]).spacetime[0])(t,Level,cg,DAGH_Main).data()";
       print OUTFH ",\n       (*(*$varg[2]).spacetime[0])(t,Level,cg,DAGH_Main).data()";
    
       $as=$as."$varname"."_(1)%d => ".$varg[0]."\n  "; 
       $as=$as."$varname"."_(2)%d => ".$varg[1]."\n  "; 
       $as=$as."$varname"."_(3)%d => ".$varg[2]."\n\n  "; 
       $assignment=$assignment.$as;

       $args1=$args1.$varg[0].",";
       $args3=$args3.$varg[0].",";
       $args1=$args1.$varg[1].",";
       $args3=$args3.$varg[1].",";
       $args1=$args1.$varg[2].",";
       $args3=$args3.$varg[2].",";
   } 
       print HFH ",\n   double *, double *, double *";
       $args2=$args2.$varname."_,";
       $tensors=$tensors."type(GridFunction),dimension(3)       :: ".$varname."_\n  "; 

   }
   elsif($sub_type eq "vector") {
       for($i=0;$i<3;$i++) {

    print OUTFH ",\n       (*(*$name).spacetime[$i])($t,Level,cg,DAGH_Main).data()";
    $args1=$args1.$name.$i.",";
    $args3=$args3.$name.$i.",";
   }
   print HFH ",\n   double *, double *, double *";
   $args2=$args2.$varname."_,";
   $tensors=$tensors."type(GridFunction),dimension(3)     :: ".$varname."_\n  "; 
   local $as="";
   $as=$as."$varname"."_(1)%d => ".$name."0\n  "; 
   $as=$as."$varname"."_(2)%d => ".$name."1\n  "; 
   $as=$as."$varname"."_(3)%d => ".$name."2\n\n  "; 
   $assignment=$assignment.$as;
   }

   else {
    die "error 35 only vector or scalar allowed as a substitute type for $varname\n";
   }
}

else {

for ($i=0;$i<3;$i++) {
 print OUTFH ",\n       (*(*$name).spacetime[$i])($t,Level,cg,DAGH_Main).data()";
 $args1=$args1.$varname.$i.",";
 $args3=$args3.$varname.$i.",";
}
 print HFH ",\n   double *, double *, double *";
 $args2=$args2.$varname."_,";
 $tensors=$tensors."type(GridFunction),dimension(3)     :: ".$varname."_\n  "; 
local $as="";
$as=$as."$varname"."_(1)%d => ".$varname."0\n  "; 
$as=$as."$varname"."_(2)%d => ".$varname."1\n  "; 
$as=$as."$varname"."_(3)%d => ".$varname."2\n\n  "; 
$assignment=$assignment.$as;
}
}


sub add_gf {
print "gf is not yet implemented\n";
}

sub add_SArray {

local $name="";

if($varname =~ /o$/) {
    $name="shift_po";
    #add one bounding box
    if(!$sarro) {
       print OUTFH ",\n       FBA(*(*shift_po).shift_p1[cg])";
       print HFH   ",\n BI";
       $args1=$args1."slbo,subo,sso,";
       $blist=$blist."integer,dimension(1)      :: slbo,subo,sso\n  ";
       $sarro=1;
   }
}
else {
    $name="shift_p";
    #add one bounding box
    if(!$sarr) {
       print OUTFH ",\n       FBA(*(*shift_p).shift_p1[cg])";
       print HFH   ",\n BI";
       $args1=$args1."slb,sub,ss,";
       $blist=$blist."integer,dimension(1)      :: slb,sub,ss\n  ";
       $sarr=1;
   }
}

$dummy=$varname;
$dummy =~ s/o$//;

if($dummy =~ /shift/) {
    $dummy=$dummy."[cg]";
    print OUTFH ",\n       FDA(*(*$name).$dummy)";
    print HFH   ",\n int *";
    $args1=$args1.$varname.",";
    $args2=$args2.$varname.",";
    if($varname =~ /o$/) {
       $blist=$blist."integer,dimension(sso(1))  :: $varname\n  ";
    }
    else {
       $blist=$blist."integer,dimension(ss(1))  :: $varname\n  ";
   }
}
else {
    #must be number of points
    print OUTFH ",\n        &$dummy";
    print HFH ",\n   int *";
    $args1=$args1.$varname.",";
    $args2=$args2.$varname.","; 
    $blist=$blist."integer $varname\n  ";
}
}

sub add_TArray {

local $name="shift_t";

    if(!$tarr) {
       print OUTFH ",\n       FBA(*(*shift_t).shift_p1[cg])";
       print HFH   ",\n BI";
       $args1=$args1."tlb,tub,ts,";
       $blist=$blist."integer,dimension(1)      :: tlb,tub,ts\n  ";
       $tarr=1;
}

$dummy=$varname;
if($dummy =~ /shift/) {
    $dummy =~ s/tshift/shift/;
    $dummy=$dummy."[cg]";
    print OUTFH ",\n       FDA(*(*$name).$dummy)";
    print HFH   ",\n int *";
    $args1=$args1.$varname.",";
    $args2=$args2.$varname.",";
    $blist=$blist."integer,dimension(ts(1))  :: $varname\n  ";
}
else {
    #must be number of points
    print OUTFH ",\n        &$dummy";
    print HFH ",\n   int *";
    $args1=$args1.$dummy.",";
    $args2=$args2.$dummy.","; 
    $blist=$blist."integer $dummy\n  ";
}
}

sub add_tensor {

if($sub_varname) {
   $name=$sub_varname
   }
else {
   $name=$varname
}

if($compstring) {
   die "error 33 cannot process components of a symmetric tensors\n";
}

if($sub_type && $sub_type ne "tensor") {

     
   if ($sub_type eq "scalar") {
    local @varg=split(/\+/,$sub_varname);
    if($#varg != 8) {

     die "error 46:  tensor got to have 9 components!\n";
    }

   local $as="";

   for($i=0;$i<9;$i++) {
    @aa=split("",$varg[$i]);
      $name="";
      $c="";
      $switch=1;
      for($j=0;$j<$#aa;$j++) {
        if($switch){
         if($aa[$j] ne "[") {
           $name=$name.$aa[$j];
         }
         else {
           $switch=0;
         }
        }
        else{
         $c=$c.$aa[$j];
        }
      } #for j
       print OUTFH ",\n       (*(*$name).spacetime[$c])(t,Level,cg,DAGH_Main).data()";
       $as=$as.$varname.$TIDX[$i]." => ".$name.$c."\n  "; 
       $args1=$args1.$name.$c.",";
       $args3=$args3.$name.$c.",";
       
   } #for i<9


       print HFH ",\n   double *, double *, double *, double *, double *, double *";
       print HFH ",\n   double *, double *, double *";
       $args2=$args2.$varname."_,";
       $tensors=$tensors."type(GridFunction),dimension(3,3)     :: ".$varname."_\n  "; 

       $assignment=$assignment.$as;

   }
   else {
    die "error 45 only tensor or scalar allowed as a substitute type for $varname\n";
   }  #scalar
}     #subtype

else {
  die "type tensor is not yet implemented\n";

for ($i=0;$i<9;$i++) {
   print OUTFH ",\n       (*(*$varname).spacetime[$i])(t,Level,cg,DAGH_Main).data()";
   $args1=$args1.$name.$i.",";
   $args3=$args3.$name.$i.",";
   }
 print HFH ",\n   double *, double *, double *, double *, double *, double *";
 $args2=$args2.$varname."_,";
 $tensors=$tensors."type(GridFunction),dimension(3,3)     :: ".$varname."_\n  "; 
local $as="";
$as=$as."$varname"."_(1,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,2)%d => ".$name."1\n  "; 
$as=$as."$varname"."_(1,3)%d => ".$name."2\n  "; 
$as=$as."$varname"."_(2,1)%d => ".$name."1\n  "; 
$as=$as."$varname"."_(2,2)%d => ".$name."3\n  "; 
$as=$as."$varname"."_(2,3)%d => ".$name."4\n  "; 
$as=$as."$varname"."_(3,1)%d => ".$name."2\n  "; 
$as=$as."$varname"."_(3,2)%d => ".$name."4\n  "; 
$as=$as."$varname"."_(3,3)%d => ".$name."5\n\n  "; 
$assignment=$assignment.$as;


} #else
} #sub add_tensor

sub add_stensor {

if($sub_varname) {
   $name=$sub_varname
   }
else {
   $name=$varname
}

if($compstring) {
   die "error 33 cannot process components of a symmetric tensors\n";
}

local $as="";
local @name1=();

if($sub_type && $sub_type eq "scalar") {
#  something like $name=gf[3]+gf[4]+... expected here
    if($name =~ /\+/) {
	@ar4=split(/\+/,$name);
        if($#ar4 != 5) {
          die "error 51: symmetric tensor got to have 6 components\n $varname,
          $name\n";
        }
        for ($i=0;$i<$#ar4+1;$i++) {
            @ar5=split(/\[/,$ar4[$i]);
            chop($ar5[1]);  # chop "]"
            print OUTFH ",\n       (*(*$ar5[0]).spacetime[$ar5[1]])(t,Level,cg,DAGH_Main).data()";
            @name1 = (@name1,$ar5[0].$ar5[1]);   
            $args1=$args1.$ar5[0].$ar5[1].",";
            $args3=$args3.$ar5[0].$ar5[1].",";
        } 
        $args2=$args2.$varname."_,";
        print HFH ",\n   double *, double *, double *, double *, double *, double *";
        $tensors=$tensors."type(GridFunction),dimension(3,3)     :: ".$varname."_\n  "; 

       $as=$as."$varname"."_(1,1)%d => ".$name1[0]."\n  "; 
       $as=$as."$varname"."_(1,2)%d => ".$name1[1]."\n  "; 
       $as=$as."$varname"."_(1,3)%d => ".$name1[2]."\n  "; 
       $as=$as."$varname"."_(2,1)%d => ".$name1[1]."\n  "; 
       $as=$as."$varname"."_(2,2)%d => ".$name1[3]."\n  "; 
       $as=$as."$varname"."_(2,3)%d => ".$name1[4]."\n  "; 
       $as=$as."$varname"."_(3,1)%d => ".$name1[2]."\n  "; 
       $as=$as."$varname"."_(3,2)%d => ".$name1[4]."\n  "; 
       $as=$as."$varname"."_(3,3)%d => ".$name1[5]."\n\n  "; 
       $assignment=$assignment.$as;
    }
    else {
        die "error 52: incompatible types $type : $varname 
                       <- $sub_type : $name\n";
    }
}

elsif($sub_type && !($sub_type =~ /stensor/)) {
#   allow for stensor-1 and stensor+1
    die "error 34 only stensor allowed as a substitute type now ($name)\n";
}

else {
    $t="t";
    $name1=$name;
    if($sub_type =~ /-1/) {$t="t-idt"; $name=$name."m1";}
    if($sub_type =~ /\+1/) {$t="t+idt"; $name=$name."p1";}
    for ($i=0;$i<6;$i++) {
      print OUTFH ",\n       (*(*$name1).spacetime[$i])($t,Level,cg,DAGH_Main).data()";
    $args1=$args1.$name.$i.",";
    $args3=$args3.$name.$i.",";
    }
 print HFH ",\n   double *, double *, double *, double *, double *, double *";
 $args2=$args2.$varname."_,";
 $tensors=$tensors."type(GridFunction),dimension(3,3)     :: ".$varname."_\n  "; 
 $as=$as."$varname"."_(1,1)%d => ".$name."0\n  "; 
 $as=$as."$varname"."_(1,2)%d => ".$name."1\n  "; 
 $as=$as."$varname"."_(1,3)%d => ".$name."2\n  "; 
 $as=$as."$varname"."_(2,1)%d => ".$name."1\n  "; 
 $as=$as."$varname"."_(2,2)%d => ".$name."3\n  "; 
 $as=$as."$varname"."_(2,3)%d => ".$name."4\n  "; 
 $as=$as."$varname"."_(3,1)%d => ".$name."2\n  "; 
 $as=$as."$varname"."_(3,2)%d => ".$name."4\n  "; 
 $as=$as."$varname"."_(3,3)%d => ".$name."5\n\n  "; 
 $assignment=$assignment.$as;
}
}

sub add_ctensor {

for ($i=0;$i<18;$i++) {
 print OUTFH ",\n       (*(*$varname).spacetime[$i])(t,Level,cg,DAGH_Main).data()";
 $args1=$args1.$varname.$i.",";
 $args3=$args3.$varname.$i.",";
}
 print HFH ",\n   double *, double *, double *, double *, double *, double *";
 print HFH ",\n   double *, double *, double *, double *, double *, double *";
 print HFH ",\n   double *, double *, double *, double *, double *, double *";
 $args2=$args2.$varname."_,";
 $tensors=$tensors."type(GridFunction),dimension(3,3,3)   :: ".$varname."_\n  "; 
local $as="";
$as=$as."$varname"."_(1,1,1)%d => ".$varname."0\n  "; 
$as=$as."$varname"."_(1,1,2)%d => ".$varname."1\n  "; 
$as=$as."$varname"."_(1,1,3)%d => ".$varname."2\n  "; 
$as=$as."$varname"."_(1,2,1)%d => ".$varname."1\n  "; 
$as=$as."$varname"."_(1,2,2)%d => ".$varname."3\n  "; 
$as=$as."$varname"."_(1,2,3)%d => ".$varname."4\n  "; 
$as=$as."$varname"."_(1,3,1)%d => ".$varname."2\n  "; 
$as=$as."$varname"."_(1,3,2)%d => ".$varname."4\n  "; 
$as=$as."$varname"."_(1,3,3)%d => ".$varname."5\n  "; 
$as=$as."$varname"."_(2,1,1)%d => ".$varname."6\n  "; 
$as=$as."$varname"."_(2,1,2)%d => ".$varname."7\n  "; 
$as=$as."$varname"."_(2,1,3)%d => ".$varname."8\n  "; 
$as=$as."$varname"."_(2,2,1)%d => ".$varname."7\n  "; 
$as=$as."$varname"."_(2,2,2)%d => ".$varname."9\n  "; 
$as=$as."$varname"."_(2,2,3)%d => ".$varname."10\n  "; 
$as=$as."$varname"."_(2,3,1)%d => ".$varname."8\n  "; 
$as=$as."$varname"."_(2,3,2)%d => ".$varname."10\n  "; 
$as=$as."$varname"."_(2,3,3)%d => ".$varname."11\n  "; 
$as=$as."$varname"."_(3,1,1)%d => ".$varname."12\n  "; 
$as=$as."$varname"."_(3,1,2)%d => ".$varname."13\n  "; 
$as=$as."$varname"."_(3,1,3)%d => ".$varname."14\n  "; 
$as=$as."$varname"."_(3,2,1)%d => ".$varname."13\n  "; 
$as=$as."$varname"."_(3,2,2)%d => ".$varname."15\n  "; 
$as=$as."$varname"."_(3,2,3)%d => ".$varname."16\n  "; 
$as=$as."$varname"."_(3,3,1)%d => ".$varname."14\n  "; 
$as=$as."$varname"."_(3,3,2)%d => ".$varname."16\n  "; 
$as=$as."$varname"."_(3,3,3)%d => ".$varname."17\n\n  "; 
$assignment=$assignment.$as;

}

sub add_rtensor {

if($sub_varname) {
   $name=$sub_varname
   }
else {
   $name=$varname
}

if($compstring) {
   die "error 31 cannot process components of the riemann tensors\n";
}

if($sub_type eq "stensor") {


for ($i=0;$i<6;$i++) {
 print OUTFH ",\n       (*(*$name).spacetime[$i])(t,Level,cg,DAGH_Main).data()";
 $args1=$args1.$name.$i.",";
 $args3=$args3.$name.$i.",";
}
 print HFH ",\n   double *, double *, double *, double *, double *, double *";
 $args2=$args2.$varname."_,";
 $tensors=$tensors."type(GridFunction),dimension(3,3,3,3) :: ".$varname."_\n  "; 
local $as="";
$as=$as."$varname"."_(1,1,1,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,1,1,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,1,1,3)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,1,2,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,1,2,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,1,2,3)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,1,3,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,1,3,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,1,3,3)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,2,1,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,2,1,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,2,1,3)%d => ".$name."1\n  "; 
$as=$as."$varname"."_(1,2,2,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,2,2,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,2,2,3)%d => ".$name."2\n  "; 
$as=$as."$varname"."_(1,2,3,1)%d => ".$name."1\n  "; 
$as=$as."$varname"."_(1,2,3,2)%d => ".$name."2\n  "; 
$as=$as."$varname"."_(1,2,3,3)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,3,1,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,3,1,2)%d => ".$name."1\n  "; 
$as=$as."$varname"."_(1,3,1,3)%d => ".$name."3\n  "; 
$as=$as."$varname"."_(1,3,2,1)%d => ".$name."1\n  "; 
$as=$as."$varname"."_(1,3,2,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(1,3,2,3)%d => ".$name."4\n  "; 
$as=$as."$varname"."_(1,3,3,1)%d => ".$name."3\n  "; 
$as=$as."$varname"."_(1,3,3,2)%d => ".$name."4\n  "; 
$as=$as."$varname"."_(1,3,3,3)%d => ".$name."0\n  "; 
$assignment=$assignment.$as;

local $as="";
$as=$as."$varname"."_(2,1,1,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,1,1,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,1,1,3)%d => ".$name."1\n  "; 
$as=$as."$varname"."_(2,1,2,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,1,2,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,1,2,3)%d => ".$name."2\n  "; 
$as=$as."$varname"."_(2,1,3,1)%d => ".$name."1\n  "; 
$as=$as."$varname"."_(2,1,3,2)%d => ".$name."2\n  "; 
$as=$as."$varname"."_(2,1,3,3)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,2,1,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,2,1,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,2,1,3)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,2,2,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,2,2,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,2,2,3)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,2,3,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,2,3,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,2,3,3)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,3,1,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,3,1,2)%d => ".$name."2\n  "; 
$as=$as."$varname"."_(2,3,1,3)%d => ".$name."4\n  "; 
$as=$as."$varname"."_(2,3,2,1)%d => ".$name."2\n  "; 
$as=$as."$varname"."_(2,3,2,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(2,3,2,3)%d => ".$name."5\n  "; 
$as=$as."$varname"."_(2,3,3,1)%d => ".$name."4\n  "; 
$as=$as."$varname"."_(2,3,3,2)%d => ".$name."5\n  "; 
$as=$as."$varname"."_(2,3,3,3)%d => ".$name."0\n  "; 
$assignment=$assignment.$as;

local $as="";
$as=$as."$varname"."_(3,1,1,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(3,1,1,2)%d => ".$name."1\n  "; 
$as=$as."$varname"."_(3,1,1,3)%d => ".$name."3\n  "; 
$as=$as."$varname"."_(3,1,2,1)%d => ".$name."1\n  "; 
$as=$as."$varname"."_(3,1,2,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(3,1,2,3)%d => ".$name."4\n  "; 
$as=$as."$varname"."_(3,1,3,1)%d => ".$name."3\n  "; 
$as=$as."$varname"."_(3,1,3,2)%d => ".$name."4\n  "; 
$as=$as."$varname"."_(3,1,3,3)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(3,2,1,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(3,2,1,2)%d => ".$name."2\n  "; 
$as=$as."$varname"."_(3,2,1,3)%d => ".$name."4\n  "; 
$as=$as."$varname"."_(3,2,2,1)%d => ".$name."2\n  "; 
$as=$as."$varname"."_(3,2,2,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(3,2,2,3)%d => ".$name."5\n  "; 
$as=$as."$varname"."_(3,2,3,1)%d => ".$name."4\n  "; 
$as=$as."$varname"."_(3,2,3,2)%d => ".$name."5\n  "; 
$as=$as."$varname"."_(3,2,3,3)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(3,3,1,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(3,3,1,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(3,3,1,3)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(3,3,2,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(3,3,2,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(3,3,2,3)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(3,3,3,1)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(3,3,3,2)%d => ".$name."0\n  "; 
$as=$as."$varname"."_(3,3,3,3)%d => ".$name."0\n\n  "; 
$assignment=$assignment.$as;
}

else {
die "error 32: only stensor substitution for the riemann tensor allowed now\n";
}
}

sub add_scalar {
local $name=$varname;
$i=0;
if($compstring) {
   $i=$compstring;
}
if($paramstring) {
   $name=$sub_varname;
   if($sub_compstring) {
     $i=$sub_compstring;
   }
}
else {
   $name=$varname;
}

$t="t";
$name1=$name;
if($sub_type =~ /-1/)  {$t="t-idt"; $name=$name."m"; $paramstring="";}
if($sub_type =~ /\+1/) {$t="t+idt"; $name=$name."p"; $paramstring="";}

print OUTFH ",\n       (*(*$name1).spacetime[$i])($t,Level,cg,DAGH_Main).data()";

if($sub_compstring eq "0") {
          $args1=$args1.$name."[0],";
          $args3=$args3.$name."[0],";
}
elsif($sub_compstring) {
          $args1=$args1.$name."[".$sub_compstring."],";
          $args3=$args3.$name."[".$sub_compstring."],";
}
else { 
          $args1=$args1.$name.",";
          $args3=$args3.$name.",";
}

print HFH ",\n   double *";
if($compstring) {
  $args2=$args2.$varname.$compstring.",";
}
elsif($paramstring) {
  $args2=$args2.$varname."_,";
}
else {
    $args2=$args2.$varname.",";
}

local $as="";
if($compstring){ 
  if(!$sub_compstring) {
    if($sub_compstring eq "0") {
      $as=$as."$varname".$compstring." => ".$sub_varname."[0]\n\n  ";
      }
    else {
     $as=$as."$varname".$compstring." => ".$sub_varname.$compstring."\n\n  ";
     } 
  }
  else {
    $as=$as."$varname".$compstring." => ".$sub_varname."[".$sub_compstring."]\n\n  "; 
  }
}
elsif($paramstring) {
  if($sub_compstring eq "0") {
      $as=$as."$varname"." => ".$name."[0]\n\n  ";
     }
  elsif($sub_compstring) { 
     $as=$as."$varname"." => ".$name."[".$i."]\n\n  ";
     }
  else { 
      $as=$as."$varname"."_%d => ".$name."\n\n  "; 
      $tensors=$tensors."type(GridFunction) :: ".$varname."_\n  "; 
  }
}
$assignment=$assignment.$as;
}

sub add_mask {
if($compstring) {
 die " mask cannot have components\n";
}

local $name=$varname;
if($sub_varname){
  $name=$sub_varname
}

local $t = "t";

if($type eq "mask-1") {
    $t="t-idt";
}

if($sub_type) {
  if($sub_type eq "mask-1"){
     $t="t-idt";
  }
  else {
    die " mask cannot be substituted by $paramstring\n";
  }
}

    print OUTFH ",\n       (*(*theMask).mask)($t,Level,cg,DAGH_Main).data()";
    $args1=$args1.$name.",";
    $args3=$args3.$name.",";
    print HFH ",\n   double *";
    $args2=$args2.$name."_,";
    $assignment=$assignment."mask_%d  => mask\n\n  ";
    $tensors=$tensors."type(GridFunction) :: ".$name."_\n  "; 

}

sub add_m {
    print OUTFH ",\n        FBA(*(*theMask).m[cg]),FDA(*(*theMask).m[cg])";
    print HFH ",\n   BI, int *";
    $args1=$args1."mlb,mub,ms,m,";
    $args2=$args2."m,";
    $blist=$blist."integer, dimension(1)     :: mlb,mub,ms\n  ";
    $blist=$blist."integer, dimension(ms(1)) :: m\n  "; 
}

sub add_d {
    print OUTFH ",\n        FBA(*(*theMask).d[cg]),FDA(*(*theMask).d[cg])";
    print HFH ",\n   BI, double *";
    $args1=$args1."dlb,dub,ds,d,";
    $args2=$args2."d,";
    $blist=$blist."integer, dimension(1)     :: dlb,dub,ds\n  ";
    $blist=$blist."real*8, dimension(ds(1))    :: d\n  "; 
}

sub add_nl {
    print OUTFH ",\n        &nl";
    print HFH ",\n   int *";
    $args1=$args1."nl,";
    $args2=$args2."nl,"; 
    $blist=$blist."integer nl\n  ";
}
#========================================== PARSE SUBSTITUTION LIST
sub parse_subst {
local ($argument) = @_;

#EXTRACT TYPE

local @wpc=split(/:/,$argument);

if($#wpc<1) {
 die " error 13: no type specified for substituted argument $argument\n";
} 

$sub_type=shift(@wpc);

local $sarg=join(':',@wpc);

# verify type

local $OK=1;
for ($i=0;$i<$#VALID_TYPES+1;$i++) {
    if($sub_type eq $VALID_TYPES[$i]) {
       $OK=0; 
    }
}

if($OK) {
die " error 14: unknown type $type for substitute argument $argument\n";
}

#EXTRACT NAME AND ARGUMENTS IF ANY
# ARGUMENTS: [] - component of a tensor or vector

$sub_varname="";
$sub_compstring ="";
local $switch=0;

if($sarg =~ /\+/) {
#  there is more than 1 parameter; leave it unparsed
   $sub_varname="$sarg";
}

else {  

local @wpd=split("",$sarg);

for($i=0; $i<$#wpd+1; $i++) {

 if($switch==0) {
#     variable name

     if($wpd[$i] =~ /\w/ || $wpd[$i] =~ /\+/) {
       $sub_varname=$sub_varname.$wpd[$i]
     }
     if($wpd[$i] eq "[") {
       $switch = 1;
     }
# no brackets of any kind is OK
     
 }
 else {
#     component list
      if($wpc[$i] ne "]") {
          $sub_compstring=$sub_compstring.$wpd[$i]
        }
      }
 }
if($sub_compstring) {
  chop($sub_compstring);
}
}
}


#========================================== PARSE ARGUMENT
sub parse_argument {
local ($argument) = @_;


#EXTRACT TYPE

local @wpa=split(/:/,$argument);

if($#wpa<1) {
 die " error 03: no type specified for argument $argument\n";
} 

$type=shift(@wpa);
local $sarg=join(':',@wpa);

# verify type

local $OK=1;
for ($i=0;$i<$#VALID_TYPES+1;$i++) {
    if($type eq $VALID_TYPES[$i]) {
       $OK=0; 
    }
}

if($OK) {
die "$OK error 04: unknown type $type for argument $argument\n";
}

#EXTRACT NAME AND ARGUMENTS IF ANY
# ARGUMENTS: [] - component of a tensor or vector
#            {} - list of substitutions

$varname="";
$compstring ="";
$paramstring = "";
local $switch=0;

local @wpb=split("",$sarg);

for($i=0; $i<$#wpb+1; $i++) {

 if($switch==0) {
#     variable name

     if($wpb[$i] =~ /\w/ || $wpb[$i] =~ /%/) {
       $varname=$varname.$wpb[$i]
     }
     if($wpb[$i] eq "[") {
       $switch = 1;
     }
     if($wpb[$i] eq "{") {
       $switch = 2;
     }
# no brackets of any kind is OK
     
 }
 elsif($switch==1) {
#     component list
      if($wpb[$i] ne "]") {
        if($wpb[$i] eq "{") {
          $switch = 2;
        }
        else {
          $compstring=$compstring.$wpb[$i]
        }
      }
 }
 else {
#     substitution list
      if($wpb[$i] ne "}") {
        $paramstring=$paramstring.$wpb[$i]
      }
 }

}

if($paramstring) {
  &parse_subst($paramstring);
  }
}


#=====================================================ADMCALL==============
sub admcall {
local ($admline) = @_;

# ----- parse admline -------------

# strip ADMCALL
local @ws = split(/\s/,$admline);

$args1="";
$args2="";
$args3="";
$tensors="";
$assignment="";
$blist="";
$params=0;
$flg=0;
$sarr=0;
$sarro=0;
$tarr=0;

#get rid off leading blanks
if(!$ws[0]) {
  local $test=" ";
  while (!$ws[0]) {
    $test=shift(@ws);
  }
}

$junk=shift(@ws);

if($junk ne "ADMCALL") {
 die "error 01:\n Something wrong with the following call \n $admline \n";
 }
$admline=join("",@ws);

#extract name of the function and list of arguments

$funcname="";
$argstring ="";
$switch=1;

@ws=split("",$admline);

for($i=0; $i<$#ws; $i++) {

 if($switch) {
#     function name
 
     if($ws[$i] =~ /\w/) {
       $funcname=$funcname.$ws[$i]
     }
     if($ws[$i] eq "(") {
       $switch = 0;
     }
     if($i > $#ws) {
         die "error 02: \n No left paranthesis in the following string \n $admline\n";
     }
 }
 else {
#     argument list
      if($ws[$i] ne ")") {
        $argstring=$argstring.$ws[$i]
      }
 }

}

# the same function may be called more than once with different arguments.
# each call require different interface - but ultimately calls the same
# fortran function $org_funcname

$org_funcname=$funcname;
$n=$func_list{$funcname};
if($n) {
    $funcname=$funcname.$n;
}
$n++;
$func_list{$org_funcname}=$n;

# ------ the actual call -----------------------------------------------
print OUTFH "     forall(st,t,Level,cg){\n";

# using 1d mask arrays?
if($admline =~ /mask:nl/) {
print OUTFH " \n";
print OUTFH "     nl=ntmp[cg];\n";
print OUTFH " \n";
}

#using SArrays?
if($admline =~ /SArray/) {
print OUTFH " \n";
print OUTFH "     num_int_points=ni[cg];\n";
print OUTFH "     num_int_pointso=nio[cg];\n";
print OUTFH " \n";
}

#using TArrays?
if($admline =~ /TArray/) {
print OUTFH " \n";
print OUTFH "     np=npi[cg];\n";
print OUTFH " \n";
}

print OUTFH "       f_$funcname(FBA(st(t,Level,cg,DAGH_Main))";

if($platform eq "SGI") {
    $capitalf = "f_".$funcname;
    $uscoref = $capitalf."_";
    $capitalf =~ tr/[a-z]/[A-Z]/;
    print HFH "#define f_$funcname FORTRAN_NAME";
    print HFH "($uscoref,$capitalf,f_$funcname)\n";  
}

print HFH " $fortran void f_$funcname(BI";

$makestr=$makestr." f_".$funcname.".o";

%subnames=0;
#split the argument list 
@args=split(/,/,$argstring);

foreach $a (@args) {

$sub_type="";
$sub_varname="";
$sub_compstring="";


 &parse_argument($a);

# eliminate duplicte $sub_names 
#
#   if($sub_varname) {
#       $org_sub_varname=$sub_varname;
#       if(!($subnames{$sub_varname})) {
#	     $subnames{$sub_varname}=1;
#       }
#       else {
#           $sub_varname=$sub_varname.$subnames{$sub_varname};
#	   $subnames{$sub_varname}++;
#       }
#   } # if(sub_varname)

 if($type eq "int") {
    &add_integer;
 }

 elsif($type eq "double" || $type eq "double-1") {
    &add_double;
 }

 elsif($type eq "tensor") {
    &add_tensor;
 }

 elsif($type =~ /stensor/) {
    &add_stensor;
 }

 elsif($type eq "ctensor") {
    &add_ctensor;
 }

 elsif($type eq "rtensor") {
    &add_rtensor;
 }

 elsif($type =~ /vector/) {
    &add_vector;
 }

 elsif($type =~ /scalar/) {
    &add_scalar;
 }

 elsif($type eq "gf") {
    &add_gf;
 }

 elsif($type eq "SArray") {
    &add_SArray;
 }
 elsif($type eq "TArray") {
    &add_TArray;
 }

 elsif($type =~ /mask/) {
    if($varname eq "mask" || $varname eq "maskold") {
       &add_mask;
    }
    elsif($varname eq "m") {
       &add_m;
    }
    elsif($varname eq "d") {
       &add_d;
    }
    elsif($varname eq "nl") {
       &add_nl;
    }
    else {
      die "error 17a: illegal name of mask variable $varname\n";
    }
 }
 else {
      die "error 177: illegal type $type of $varname\n";
 }


#print "VARIABLE NAME: $varname\n";
#print "COMPONENT: $compstring\n";
#print "SUBSTITUTION: $paramstring\n";

}

print OUTFH ");\n";

# using 1d mask arrays?
if($admline =~ /mask:nl/) {
print OUTFH " \n";
print OUTFH "     ntmp[cg]=nl;\n";
print OUTFH " \n";
}

#using SArrays?
if($admline =~ /SArray/) {
print OUTFH " \n";
print OUTFH "     ni[cg]=num_int_points;\n";
print OUTFH "     nio[cg]=num_int_pointso;\n";
print OUTFH " \n";
}

#using TArrays?
if($admline =~ /TArray/) {
print OUTFH " \n";
print OUTFH "     npi[cg]=np;\n";
print OUTFH " \n";
}

print OUTFH "     } end_forall;\n\n";

print HFH ");\n";
&write_fortran;

}

#============ DAGH DIRECTIVE WITH ARGUMENT LIST  =============

sub dir_list {
    local ($synline,$keyword)=@_;
    local $type="";
    local $varname="";

    $synline =~ /$keyword\((.*)\)/;
    local @ar1=split(/,/,$1);
    for ($i=0;$i<$#ar1+1;$i++) {
	$ar1[$i]=~/(.*):(.*)/;
        $type=$1;
        $varname=$2;
        $varname =~ s/_$//;

        if($type =~ /\s*scalar/ || $type eq "mask") {
	    $ncomp=1;
	}
	elsif($type =~ /vector/) {
	    $ncomp=3;
	}
	elsif($type =~ /stensor/) {
	    $ncomp=6;
	}
	elsif($type eq "ctensor") {
	    $ncomp=18;
	}
	else {
	    die "Error 401: ($keyword) illegal type $type of $varname\n";
	}

        if($type =~ /-1/) {$t="t-idt";}
        elsif($type =~ /\+1/) {$t="t+idt";}
        else {$t="t";}

        if($type eq "mask") {
           print OUTFH "    (*(*theMask).mask).$DAGH_fun{$keyword}($t,Level,DAGH_Main);\n\n";
           }
        else {
	print OUTFH "  for (itc=0;itc<$ncomp;itc++) {\n";
        print OUTFH "    (*(*$varname).spacetime[itc]).$DAGH_fun{$keyword}($t,Level,DAGH_Main);\n";
        print OUTFH "  }\n\n";
        }
    }
}

#============ DAGH DIRECTIVE WITH 1 ARGUMENT ===================

sub dir_1 {
    local ($synline,$keyword)=@_;
    local $type="";
    local $varname="";

    $synline =~ /$keyword\((.*)\)/;
    local @ar1=split(/,/,$1);

    local $ret_val=$ar1[0];
    $ret_val=~/(.*):(.*)/;
    $ret_val=$2;

    local $inp_val=$ar1[1];

	$inp_val=~/(.*):(.*)/;
        $type=$1;
        $varname=$2;
        $varname =~ s/_$//;

        if($type eq "scalar" || $type eq "mask") {
	    $ncomp=1;
	}
#	elsif($type eq "vector") {
#	    $ncomp=3;
#	}
#	elsif($type eq "stensor") {
#	    $ncomp=6;
#	}
#	elsif($type eq "ctensor") {
#	    $ncomp=18;
#	}
	else {
	    die "Error 402: ($keyword) illegal type $type of $varname\n";
	}
#	print OUTFH "  for (itc=0;itc<$ncomp;itc++) {\n";
#        print OUTFH "    (*(*$varname).spacetime[itc]).$DAGH_fun{$keyword}(t,Level,DAGH_Main);\n";
#        print OUTFH "  }\n\n";

        if($type eq "mask") {
        print OUTFH "  $ret_val = (*(*theMask).mask).$DAGH_fun{$keyword}(t,Level,DAGH_Main);\n\n";
        }
        else { 
        print OUTFH "  $ret_val = (*(*$varname).spacetime[0]).$DAGH_fun{$keyword}(t,Level,DAGH_Main);\n\n";
    }
}

#============ DAGH DIRECTIVE WITH 2 ARGUMENTS ================

sub dir_2 {
    local ($synline,$keyword)=@_;
    local $type="";
    local $varname="";
    local @types=();
    local @varnames=();
    local @time=();

    $synline =~ /$keyword\((.*)\)/;

    local @ar1=split(/,/,$1);
    if($#ar1 != 1) {
        $dummy=$#ar1+1;
	die "Error 04a $keyword requires exactly 2 arguments and got $dummy\n";
    }

    for($i=0;$i<2;$i++) {
	$ar1[$i]=~/(.*):(.*)/;

        $types[$i]=$1;
        $varnames[$i] = $2;

        if($types[$i] =~ /-1/) {
	    $time[$i] = "t-idt";
            $types[$i] =~ s/-1//;
        }
        elsif($types[$i] =~ /\+1/) {
	    $time[$i] = "t+idt";
            $types[$i] =~ s/\+1//;
        }
        else {
            $time[$i] = "t";
        }  

        $varnames[$i] =~ s/_$//;

        if($varnames[$i] eq "mask" || $varnames[$i] eq "maskold") {
	    $varnames[$i]="*(*theMask).mask";
        }
        else {
          if($types[1] ne "double") {
            if($varnames[$i] =~ /\[/) {
                $varnames[$i] =~ /(.*)\[(.*)\]/;
                $varnames[$i] = "*(*".$1.").spacetime[".$2."]";
	    }
            else {
	        $varnames[$i]="*(*".$varnames[$i].").spacetime[itc]";
	    }
	  }
        }
    }

    $type=$types[0];

    if($types[0] ne $types[1] && $types[1] ne "double") {
           if($types[1] ne "mask"){ 
	       print "..$types[0]...$types[1]..\n";
	       die "Error 405: Cannot $keyword $types[0] $types[1]\n";
           }
    }

        if($type eq "scalar" || $type eq "mask") {
	    $ncomp=1;            
	}
	elsif($type eq "vector") {
	    $ncomp=3;
	}
	elsif($type eq "stensor") {
	    $ncomp=6;
	}
	elsif($type eq "ctensor") {
	    $ncomp=18;
	}
	else {
	    die "Error 401: ($keyword) illegal type $type of $varname\n";
	}

	print OUTFH "  for (itc=0;itc<$ncomp;itc++) {\n";
        print OUTFH "    ($varnames[0]).$DAGH_fun{$keyword}";
    if($types[1] eq "double") {
        print OUTFH "($time[0],Level,$varnames[1],DAGH_Main);\n";
    }
    else {
        print OUTFH "($time[0],Level,$varnames[1],$time[1],Level,DAGH_Main);\n";
    }
        print OUTFH "  }\n\n";
}



# ------- main routine starts here
# ------- process input arguments ------------------------

$platform = "SGI";


if($#ARGV != 0) { 
    print "\nirtoc usage:\n"; 
    print "    irtoc.pl name  \n"; 
    print "where name is either init, tstep or all\n";
    exit(1);
}

    @infile=();
    @outfile=();
    @headerfile=();

if($ARGV[0] eq "init") {
    $infile[0] = "init.ir";
    $outfile[0] =">init.C";
    $headerfile[0]=">initfortran.h";
    $nfiles=1;
}
elsif($ARGV[0] eq "tstep") {
    $infile[0] = "tstep.ir";
    $outfile[0] =">tstep.C";
    $headerfile[0]=">fortran.h";
    $nfiles=1;
}
elsif($ARGV[0] eq "all") {
    $infile[0] = "init.ir";
    $outfile[0] =">init.C";
    $headerfile[0]=">initfortran.h";
    $infile[1] = "tstep.ir";
    $outfile[1] =">tstep.C";
    $headerfile[1]=">fortran.h";
    $nfiles=2;
}
else {
    print "\nirtoc usage:\n"; 
    print "    irtoc.pl name  \n"; 
    print "where name is init, tstep or all\n";
    exit(1);
}
    
print "irtoc: converting $ARGV[0] to be run on $platform \n";


# ----------- constants ------------------------------

$quote = '"';
if($platform eq "SP2") {
   $fortran = "extern ".$quote."FORTRAN".$quote;
}
elsif($platform eq "SGI") {
   $fortran = "extern ".$quote."C".$quote;
}
else {
    die "unknown target machine $platform \n";
}

$amp = "&";
@VALID_TYPES = ("int","double","scalar","vector", "stensor","tensor",
                "ctensor","rtensor","mask","SArray","TArray", "vector-1",
                "stensor-1","stensor+1","mask-1","double-1","scalar-1",
                "scalar+1");
@TIDX = ("_(1,1)%d","_(1,2)%d","_(1,3)%d","_(2,1)%d","_(2,2)%d",
         "_(2,3)%d","_(3,1)%d","_(3,2)%d","_(3,3)%d");


%DAGH_fun = (
       "sync"       , "GF_Sync",
       "copy"       , "GF_Copy",
       "add"        , "GF_plus",
       "subtract"   , "GF_minus",
       "multiply"   , "GF_multiply",
       "equals"     , "GF_equals",
       "sum"        , "GF_sum",
       "maxval"     , "GF_maxval",
       "minval"     , "GF_minval",
       "swap"       , "GF_SwapTimeLevels"
);   

%DAGH_funpar = (
       "sync"       , "list",
       "copy"       , "2",
       "add"        , "2",
       "subtract"   , "2",
       "multiply"   , "2",
       "equals"     , "2",
       "sum"        , "1",
       "maxval"     , "1",
       "minval"     , "1",
       "swap"       , "list"
);        


$makestr="";
$incfort=1;
$buffer="";
$func_table=();


$makefile=">>ffiles";
$ifce_list=">>ifiles";

open(MAKE,$makefile)  || die "cannot open $makefile: $! \n";


for($inf=0;$inf<$nfiles;$inf++) {

$outname=">".$outfile[$inf];

open(INFH,$infile[$inf])    || die "cannot open $infile[$inf]: $! \n";
open(OUTFH,$outfile[$inf])  || die "cannot open $outfile[$inf]: $! \n";
open(HFH,$headerfile[$inf]) || die "cannot open $headerfile[$inf]: $! \n";




# ----------------------------------------------------
# copy infile to outfile
# detect presence of include fortran.h
# spawn action whenever keyward ADMCALL is found
# ---------------------------------------------------- 


while(<INFH>) {
 $line=$_;

 if($buffer) {
        $line=$buffer.$line;
 }

 if($line =~ /DAGH\$/) {
   $line =~ s/!//;
   if($line =~ /!/) {
    print "the following line is commented out! - ignore\n";
    print "$line\n";
   }  
   else {
     if($line =~ /$amp/) {
       $buffer=$line;
#       get rid off end-of-line
       chop($buffer);
#       get rid off &
    while($buffer =~ /$amp/) {chop($buffer)};
     }
     else {
        print "-------------------------\n processing line:\n $line";
        $line =~ s/DAGH\$//;
        if($line =~ /ADMCALL/) { 
            &admcall($line);
        }
        else { 
	    $line =~ /(\s*)(.*)(\s*)\(/;
            $npar=$DAGH_funpar{$2};
            if($npar eq "list") {
                &dir_list($line,$2);
            }
            elsif($npar eq "2") {
                &dir_2($line,$2);
            }
            elsif($npar eq "1") {
                &dir_1($line,$2);
            }
            else {
		die "error 500: $2 $npar\n THIS SHOULD NOT HAPPEN - ask Tom\n";
	    }
	}
        $buffer="";
     }
   }
}
 else {
   print OUTFH $line;
}   


}

 close INFH;
 close OUTFH;
 close HFH;

} 

# ------- end of INFH processing --------------------- 
  
#write list of f_files generated by this program 
print MAKE $makestr;

#write list of functions that require explicit interfaces

open(INTRF,$ifce_list) || die "cannot open $ifce_list $! \n";
foreach $subroutine (sort keys(%func_list)) {
    print INTRF "$subroutine ";
}
close INTRF;

close(MAKE);
