#! /usr/bin/perl
#/*@@
#  @file      GridFuncStuff.pl
#  @date      Tue Jan 12 11:07:45 1999
#  @author    Tom Goodale
#  @desc
#
#  @enddesc
#  @version $Id$
#@@*/


#/*@@
#  @routine    CreateVariableBindings
#  @date       Thu Jan 28 15:14:20 1999
#  @author     Tom Goodale
#  @desc
#  Creates all the binding files for the variables.
#  @enddesc
#@@*/
sub CreateVariableBindings
{
  my($bindings_dir, $rhinterface_db, $rhparameter_db) = @_;
  my(@data);
  my($thorn, $line, $block, $filelist);

  if(! -d $bindings_dir)
  {
    mkdir("$bindings_dir", 0755) || die "Unable to create $bindings_dir";
  }
  $start_dir = `pwd`;
  chdir $bindings_dir;

  # Create the header files
  if(! -d "include")
  {
    mkdir("include", 0755) || die "Unable to create include directory";
  }

  foreach $thorn (split(" ",$rhinterface_db->{"THORNS"}))
  {
    @data = &CreateThornArgumentHeaderFile($thorn, $rhinterface_db);
    $dataout = join ("\n", @data);
    &WriteFile("include/$thorn\_arguments.h",\$dataout);
  }

  @data = ();
  push(@data, '/*@@');
  push(@data, '   @header  cctk_Arguments.h');
  push(@data, '   @author  Automatically generated by GridFuncStuff.pl');
  push(@data, '   @desc');
  push(@data, '            Defines the CCTK_ARGUMENTS macro for all thorns');
  push(@data, '   @enddesc');
  push(@data, ' @@*/');
  push(@data, '');
  push(@data, '');

  push(@data, '/* get the CCTK datatype definitions */');
  push(@data, '#include "cctk_Types.h"');
  push(@data, '');
  push(@data, '#ifdef CCODE');
  push(@data, '/* prototype for CCTKi_VarDataPtr() goes here');
  push(@data, '   because we don\'t want to include another CCTK header file */');
  push(@data, '#ifdef __cplusplus');
  push(@data, 'extern "C"');
  push(@data, '#endif');
  push(@data, 'void *CCTKi_VarDataPtr(const cGH *GH, int timelevel,');
  push(@data, '                       const char *implementation, const char *varname);');
  push(@data, '');

  push(@data, '#define PASS_GROUPSIZE(group, dir)  CCTKGROUPNUM_##group >= 0 ? \\');
  push(@data, '                                    CCTK_ArrayGroupSizeI(GH, dir, CCTKGROUPNUM_##group) : &_cctk_zero');
  push(@data, '');
  push(@data, '#define PASS_GROUPLEN(thorn, group) CCTKGROUPNUM_##group >= 0 ? \\');
  push(@data, '                                    CCTKi_GroupLengthAsPointer(#thorn "::" #group) : &_cctk_zero');
  push(@data, '');
  push(@data, '/*');
  push(@data, ' * References to non-existing or non-allocated variables should be passed');
  push(@data, ' * as NULL pointers in order to catch any invalid access immediately');
  push(@data, ' * However, this runtime debugging feature may cause problems');
  push(@data, ' * with some fortran compilers which require all fortran routine arguments');
  push(@data, ' * to refer to a valid memory location (eg. to enable the code optimizer');
  push(@data, ' * to generate conditional load/store instructions if applicable).');
  push(@data, ' * For this reason, we pass NULL pointers only for debugging configurations,');
  push(@data, ' * and a pointer to a user-accessable memory location (a local dummy variable)');
  push(@data, ' * otherwise.');
  push(@data, ' */');
  push(@data, '#ifdef CCTK_DEBUG');
  push(@data, '#define PASS_REFERENCE(var, level)  CCTKARGNUM_##var >= 0 ? \\');
  push(@data, '                                    GH->data[CCTKARGNUM_##var][level] : 0');
  push(@data, '#else');
  push(@data, '#define PASS_REFERENCE(var, level)  CCTKARGNUM_##var >= 0 && \\');
  push(@data, '                                    GH->data[CCTKARGNUM_##var][level] ? \\');
  push(@data, '                                    GH->data[CCTKARGNUM_##var][level] : _cctk_dummy_var');
  push(@data, '#endif');
  push(@data, '');

  push(@data, '#define CCTK_ARGUMENTS CCTK_CARGUMENTS');
  push(@data, '#define _CCTK_ARGUMENTS _CCTK_CARGUMENTS');
  push(@data, '#define DECLARE_CCTK_ARGUMENTS DECLARE_CCTK_CARGUMENTS USE_CCTK_CARGUMENTS');
  push(@data, '#endif');
  push(@data, '');
  push(@data, '#ifdef FCODE');
  push(@data, '#define CCTK_ARGUMENTS CCTK_FARGUMENTS');
  push(@data, '#define _CCTK_ARGUMENTS _CCTK_FARGUMENTS');
  push(@data, '#define DECLARE_CCTK_ARGUMENTS DECLARE_CCTK_FARGUMENTS');
  push(@data, '#endif');

  foreach $thorn (split(" ",$rhinterface_db->{"THORNS"}))
  {
    push(@data, '');
    push(@data, "#ifdef THORN_IS_$thorn");
    push(@data, "#include \"${thorn}_arguments.h\"");
    push(@data, "#define CCTK_FARGUMENTS \U$thorn" . '_FARGUMENTS');
    push(@data, "#define DECLARE_CCTK_FARGUMENTS DECLARE_\U$thorn" . '_FARGUMENTS');
    push(@data, "#define CCTK_CARGUMENTS \U$thorn" . '_CARGUMENTS');
    push(@data, "#define DECLARE_CCTK_CARGUMENTS DECLARE_\U$thorn" . '_CARGUMENTS');
    push(@data, "#define USE_CCTK_CARGUMENTS USE_\U$thorn" . '_CARGUMENTS');
    push(@data, '#endif');
  }
  push(@data, "\n");  # workaround for perl 5.004_04 to add a trailing newline

  $dataout = join ("\n", @data);
  &WriteFile("include/cctk_Arguments.h",\$dataout);

  if(! -d "Variables")
  {
    mkdir("Variables", 0755) || die "Unable to create Variables directory";
  }

  $filelist = "BindingsVariables.c";

  @data = ();
  push(@data, '/*@@');
  push(@data, '   @file    BindingsVariables.c');
  push(@data, '   @author  Automatically generated by GridFuncStuff.pl');
  push(@data, '   @desc');
  push(@data, '            Calls the variable binding routines for all thorns');
  push(@data, '   @enddesc');
  push(@data, ' @@*/');
  push(@data, '');
  push(@data, '');

  push(@data, '#include <string.h>');
  push(@data, '#include "cctk_ActiveThorns.h"');
  push(@data, '');

  foreach $thorn (split(" ",$rhinterface_db->{"THORNS"}))
  {
    push(@data, "int CactusBindingsVariables_${thorn}_Initialise(void);");
  }

  push(@data, '');
  push(@data, 'int CCTKi_BindingsVariablesInitialise(void);');
  push(@data, '');

  push(@data, 'int CCTKi_BindingsVariablesInitialise(void)');
  push(@data, '{');
  foreach $thorn (split(" ",$rhinterface_db->{"THORNS"}))
  {
    push(@data, "  if (CCTK_IsThornActive(\"$thorn\"))");
    push(@data, '  {');
    push(@data, "    CactusBindingsVariables_${thorn}_Initialise();");
    push(@data, '  }');
  }

  push(@data, '  return 0;');
  push(@data, '}');
  push(@data, "\n");  # workaround for perl 5.004_04 to add a trailing newline

  $dataout = join ("\n", @data);
  &WriteFile("Variables/BindingsVariables.c",\$dataout);

  foreach $thorn (split(" ",$rhinterface_db->{"THORNS"}))
  {
    @data = ();
    push(@data, '/*@@');
    push(@data, "   \@file    $thorn.c");
    push(@data, '   @author  Automatically generated by GridFuncStuff.pl');
    push(@data, '   @desc');
    push(@data, "            Creates the CCTK variables for thorn $thorn");
    push(@data, '   @enddesc');
    push(@data, ' @@*/');
    push(@data, '');
    push(@data, '');

    push(@data, "#define THORN_IS_$thorn 1");
    push(@data, '');
    push(@data, '#include "cctk.h"');
    push(@data, '#include "cctk_Arguments.h"');
    push(@data, '#include "cctk_Parameter.h"');
    push(@data, '#include "cctk_WarnLevel.h"');
    push(@data, '#include "cctki_Groups.h"');
    push(@data, '#include "cctki_FortranWrappers.h"');
    push(@data, '');

    push(@data, "int CactusBindingsVariables_${thorn}_Initialise(void);");
    push(@data, "static int CCTKi_BindingsFortranWrapper$thorn(void *_GH, void *fpointer);");
    push(@data, '');
    push(@data, "static int CCTKi_BindingsFortranWrapper$thorn(void *_GH, void *fpointer)");
    push(@data, '{');
    push(@data, '  cGH *GH = _GH;');
    push(@data, '  const int _cctk_zero = 0;');
    push(@data, '#ifndef CCTK_DEBUG');
    push(@data, '  CCTK_COMPLEX _cctk_dummy_var[4];');
    push(@data, '#endif');
    push(@data, "  void (*function)(\U$thorn\E_C2F_PROTO);");
    push(@data, "  DECLARE_\U$thorn\E_C2F");
    push(@data, "  INITIALISE_\U$thorn\E_C2F");
    push(@data, '  (void) (_cctk_zero + 0);');
    push(@data, '#ifndef CCTK_DEBUG');
    push(@data, '  (void) (_cctk_dummy_var + 0);');
    push(@data, '#endif');
    push(@data, '');
    push(@data, "  function = (void (*) (\U$thorn\E_C2F_PROTO)) fpointer;");
    push(@data, "  function (PASS_\U$thorn\E_C2F (GH));");
    push(@data, '');
    push(@data, '  return (0);');
    push(@data, '}');
    push(@data, '');

    push(@data, "int CactusBindingsVariables_${thorn}_Initialise(void)");
    push(@data, '{');
    push(@data, '  int warn_mixeddim_gfs;');
    push(@data, '  const CCTK_INT *allow_mixeddim_gfs;');
    push(@data, '');
    push(@data, '');
    push(@data, '  warn_mixeddim_gfs = 0;');
    push(@data, '  allow_mixeddim_gfs = CCTK_ParameterGet ("allow_mixeddim_gfs", "Cactus", 0);');
    push(@data, '');

    foreach $block ("PUBLIC", "PROTECTED", "PRIVATE")
    {
      push(@data, &CreateThornGroupInitialisers($thorn, $block, $rhinterface_db, $rhparameter_db));
    }
    push(@data, '');
    push(@data, '  if (warn_mixeddim_gfs)');
    push(@data, '  {');
    push(@data, '    if (allow_mixeddim_gfs && *allow_mixeddim_gfs)');
    push(@data, '    {');
    push(@data, '      CCTK_VWarn (2, __LINE__, __FILE__, "Cactus",');
    push(@data, '                  "CCTKi_CreateGroup: Working dimension already set, "');
    push(@data, "                  \"creating GF group '$group' with different dimension $rhinterface_db->{\"\U$thorn GROUP $group\E DIM\"}\");");
    push(@data, '    }');
    push(@data, '    else');
    push(@data, '    {');
    push(@data, '      CCTK_VWarn (0, __LINE__, __FILE__, "Cactus",');
    push(@data, '                  "CCTKi_CreateGroup: Working dimension already set,"');
    push(@data, "                  \" cannot create GF group $group with dimension $rhinterface_db->{\"\U$thorn GROUP $group\E DIM\"}\");");
    push(@data, '    }');
    push(@data, ' }');
    push(@data, '');
    push(@data, "  CCTKi_RegisterFortranWrapper(\"$thorn\", CCTKi_BindingsFortranWrapper$thorn);");

    push(@data, '');
    push(@data, '  return 0;');
    push(@data, '}');
    push(@data, "\n");  # workaround for perl 5.004_04 to add a trailing newline

    $dataout = join ("\n", @data);
    &WriteFile("Variables/$thorn.c",\$dataout);

    $filelist .= " $thorn.c";
  }

# TR 24 Jan 2003
# Fortran wrappers are now defined and registered in "Variables/$thorn.c"
#
# foreach $thorn (split(" ",$rhinterface_db->{"THORNS"}))
# {
#   @data = &CreateThornFortranWrapper($thorn);
#   push(@data, "\n");  # workaround for perl 5.004_04 to add a trailing newline
#
#   $dataout = join ("\n", @data);
#   &WriteFile("Variables/$thorn\_FortranWrapper.c",\$dataout);
#
#   $filelist .= " $thorn\_FortranWrapper.c";
# }

  $dataout = "SRCS = $filelist\n";
  &WriteFile("Variables/make.code.defn",\$dataout);

  chdir $start_dir;
}


#/*@@
#  @routine    GetThornArguments
#  @date       Thu Jan 28 14:31:38 1999
#  @author     Tom Goodale
#  @desc
#  Gets a list of all the variables available for a thorn in a
#  particular block.
#  @enddesc
#@@*/
sub GetThornArguments
{
  my($this_thorn, $block, $rhinterface_db) = @_;
  my(%arguments);
  my(@other_imps);
  my($my_imp, $imp, $thorn, $group, $variable, $vtype, $gtype, $type);

  $my_imp = $rhinterface_db->{"\U$this_thorn IMPLEMENTS"};

  if($block eq "PUBLIC")
  {
    @other_imps = split(" ",$rhinterface_db->{"IMPLEMENTATION \U$my_imp\E ANCESTORS"});
  }
  elsif($block eq "PROTECTED")
  {
    @other_imps = split(" ", $rhinterface_db->{"IMPLEMENTATION \U$my_imp\E FRIENDS"});
  }
  elsif($block eq "PRIVATE")
  {
    @other_imps = ();
  }
  else
  {
    die "Unknown block type $block!!!\n";
  }

#  print "Thorn is $this_thorn, implementation $my_imp, block is $block\n";
#  print "Other imps are @other_imps\n";

  foreach $imp (@other_imps,$my_imp)
  {

    next if (! defined $imp);

    if ($block eq "PRIVATE")
    {
      $thorn = $this_thorn;
    }
    else
    {
      $rhinterface_db->{"IMPLEMENTATION \U$imp\E THORNS"} =~ m:([^ ]*):;

      $thorn = $1;
    }

    foreach $group (split(" ",$rhinterface_db->{"\U$thorn $block GROUPS\E"}))
    {
      $vtype = $rhinterface_db->{"\U$thorn GROUP $group VTYPE\E"};
      $gtype = $rhinterface_db->{"\U$thorn GROUP $group GTYPE\E"};
      $ntimelevels = $rhinterface_db->{"\U$thorn GROUP $group TIMELEVELS\E"};

      $type = "$vtype";

      my $vararraysize = $rhinterface_db->{"\U$thorn GROUP $group\E VARARRAY_SIZE"};
      my $compactgroup = $rhinterface_db->{"\U$thorn GROUP $group\E COMPACT"};

      if($gtype eq 'GF' || $gtype eq 'ARRAY')
      {
        $type .= ' (';

        if(defined($vararraysize) && $compactgroup == 1)
        {
          $type .= "${group}_length";
          $sep = ',';
        }
        else
        {
          $sep = '';
        }

        for($dim =0; $dim < $rhinterface_db->{"\U$thorn GROUP $group DIM\E"}; $dim++)
        {
# FIXME: quick hack to shorten argument names
#          $type .= "${sep}cctkv$group$dim";
          $type .= "${sep}X$group$dim";
          $sep = ',';
          if($block eq 'PRIVATE')
          {
# FIXME: quick hack to shorten argument names
#            $arguments{"cctkv$group$dim"} = "(STORAGESIZE($thorn\::$group, $dim))";
            $arguments{"X$group$dim"} = "(STORAGESIZE($thorn\::$group, $dim))";
          }
          else
          {
# FIXME: quick hack to shorten argument names
#            $arguments{"cctkv$group$dim"} = "(STORAGESIZE($imp\::$group, $dim))";
            $arguments{"X$group$dim"} = "(STORAGESIZE($imp\::$group, $dim))";
          }
        }
        if(defined($vararraysize) && $compactgroup == 0)
        {
          $type .= "$sep${group}_length";
        }
        $type .= ')';

        if(defined($vararraysize))
        {
          if($block eq 'PRIVATE')
          {
            $arguments{"${group}_length"} = "(GROUPLENGTH($thorn\::$group)";
          }
          else
          {
            $arguments{"${group}_length"} = "(GROUPLENGTH($imp\::$group)";
          }
        }
      }

      if($block eq 'PRIVATE')
      {
        $type .= "!$thorn\::$group";
      }
      else
      {
        $type .= "!$imp\::$group";
      }

      $type .="!$ntimelevels";

      if(defined($vararraysize))
      {
        $type .= '![0]';
      }
      else
      {
        $type .= '!';
      }

#      print "Group is $group, resulting type is $type\n";

      foreach $variable (split(" ", $rhinterface_db->{"\U$thorn GROUP $group\E"}))
      {
        $arguments{$variable} = $type;
      }
    }
  }

  return %arguments;
}


#/*@@
#  @routine    CreateFortranArgumentDeclarations
#  @date       Thu Jan 28 14:32:57 1999
#  @author     Tom Goodale
#  @desc
#  Creates the requisite argument list declarations for Fortran.
#  @enddesc
#@@*/
sub CreateFortranArgumentDeclarations
{
  my(%arguments) = @_;
  my($argument);
  my(@declarations) = ();

  # Put all storage arguments first.
  foreach $argument (sort keys %arguments)
  {
    if($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:)
    {
      push(@declarations, "INTEGER $argument");
    }
  }

  # Now deal with the rest of the arguments
  foreach $argument (sort keys %arguments)
  {
    next if ($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:);

    $arguments{$argument} =~ m:^([^! ]+) ?([^!]*)?!([^!]*)!([^!]*):;

    $type        = $1;
    $dimensions  = $2;
    $ntimelevels = $4;

#     print "var $argument - type \"$arguments{$argument}\" - tl $ntimelevels \n";

    for($level = 0; $level < $ntimelevels; $level++)
    {
      push(@declarations, "CCTK_$type $argument$dimensions");

      # Modify the name for the time level
      $argument .= '_p';
    }

    if($type =~ /^(CHAR|BYTE|INT|INT2|INT4|INT8|REAL|REAL4|REAL8|REAL16|COMPLEX|COMPLEX8|COMPLEX16|COMPLEX32)$/)
    {
      # DEPRECATED IN BETA 10
      if($type eq 'CHAR')
      {
        &CST_error(1,"CCTK_CHAR is replaced by CCTK_BYTE, please change your code","",__LINE__,__FILE__);
      }
    }
    else
    {
      &CST_error(0,"Unknown argument type \"$type\"","",__LINE__,__FILE__);
    }
  }
  push(@declarations, '');

  return @declarations;

}


#/*@@
#  @routine    CreateCArgumentDeclarations
#  @date       Jun 29 1999
#  @author     Tom Goodale, Gabrielle Allen
#  @desc
#  Creates the requisite argument list declarations for C.
#  @enddesc
#@@*/
sub CreateCArgumentDeclarations
{
  my(%arguments) = @_;
  my($varname, $imp, $type, $fullname, $ntimelevels);
  my(@declarations) = ();


  # Now deal with the rest of the arguments
  foreach $varname (sort keys %arguments)
  {
    next if ($arguments{$varname} =~ m:STORAGESIZE|GROUPLENGTH:);

    $arguments{$varname} =~ m\^([^! ]+) ?([^!]*)?!([^!]*)::([^!]*)!([^!]*)!([^!]*)\;

    $type           = $1;
    $implementation = "\U\"$3\"";
    $ntimelevels    = $5;
    $var            = "\"$varname$6\"";

    for($level = 0; $level < $ntimelevels; $level++)
    {
      push(@declarations, "CCTK_$type *$varname = (CCTK_$type *) CCTKi_VarDataPtr(cctkGH, $level, $implementation, $var);");

      # Modify the name for the time level
      $varname .= '_p';
    }

    if($type =~ /^(CHAR|BYTE|INT|INT2|INT4|INT8|REAL|REAL4|REAL8|REAL16|COMPLEX|COMPLEX8|COMPLEX16|COMPLEX32)$/)
    {
      # DEPRECATED IN BETA 10 */
      if($type eq 'CHAR')
      {
        &CST_error(1,"CCTK_CHAR is replaced by CCTK_BYTE, please change your code","",__LINE__,__FILE__);
      }
    }
    else
    {
      &CST_error(0,"Unknown argument type $type","",__LINE__,__FILE__);
    }
  }

  return @declarations;

}

#/*@@
#  @routine    CreateCArgumentUses
#  @date       Nov 5 1999
#  @author     Gabrielle Allen
#  @desc
#  Creates the requisite argument list declarations for C.
#  @enddesc
#@@*/
sub CreateCArgumentUses
{
  my(%arguments) = @_;
  my($varname, $suffix, $imp);
  my(@declarations) = ();

  # Now deal with the rest of the arguments
  foreach $varname (sort keys %arguments)
  {
    next if ($arguments{$varname} =~ m:STORAGESIZE|GROUPLENGTH:);

    $arguments{$varname} =~ m\^([^! ]+) ?([^!]*)?!([^!]*)::([^!]*)!([^!]*)\;

    $ntimelevels = $5;

    for($level = 0; $level < $ntimelevels; $level++)
    {
      push(@declarations, "(void) ($varname + 0);");

      # Modify the name for the time level
      $varname .= '_p';
    }
  }

  return @declarations;
}


#/*@@
#  @routine    CreateFortranArgumentList
#  @date       Thu Jan 28 14:33:50 1999
#  @author     Tom Goodale
#  @desc
#  Creates the argument list a Fortran subroutine sees.
#  @enddesc
#@@*/
sub CreateFortranArgumentList
{
  my(%arguments) = @_;
  my($argument, $varname);
  my(@argumentlist) = ();

  # Put all storage arguments first.
  foreach $argument (sort keys %arguments)
  {
    if($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:)
    {
      push(@argumentlist, $argument);
    }
  }

  # Now deal with the rest of the arguments
  foreach $varname (sort keys %arguments)
  {
    next if ($arguments{$varname} =~ m:STORAGESIZE|GROUPLENGTH:);

    $arguments{$varname} =~ m:^([^! ]+) ?([^!]*)?!([^!]*)!([^!]*):;

    $ntimelevels = $4;

    for($level = 0; $level < $ntimelevels; $level++)
    {
      push(@argumentlist, $varname);

      # Modify the name for the time level
      $varname .= '_p';
    }
  }

  return join(',', @argumentlist);
}

#/*@@
#  @routine    CreateCArgumentStatics
#  @date       Thu Jan 28 14:33:50 1999
#  @author     Tom Goodale
#  @desc
#  Creates the declarations of static variables used to speed up
#  construction of arguments to pass to Fortran.
#  @enddesc
#@@*/
sub CreateCArgumentStatics
{
  my(%arguments) = @_;
  my($argument, $group, $allgroups);
  my(@declarations) = ();

  $allgroups = '';
  foreach $argument (sort keys %arguments)
  {
    next if ($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:);

    push(@declarations, "static int CCTKARGNUM_$argument = -1;");
    $arguments{$argument} =~ /::([^!]+)![0-9]+/;
    $group = $1;

#    print "ARG is $arguments{$argument}, group is $group\n";

    if ($allgroups !~ / $group /)
    {
      $allgroups .= " $group ";
      push(@declarations, "static int CCTKGROUPNUM_$group = -1;");
    }
  }

  return @declarations;
}


#/*@@
#  @routine    CreateCArgumentInitialisers
#  @date       Thu Jan 28 14:33:50 1999
#  @author     Tom Goodale
#  @desc
#  Creates the code to initialise the statics.
#  @enddesc
#@@*/
sub CreateCArgumentInitialisers
{
  my(%arguments) = @_;
  my($argument, $allgroups, $group, $qualifier);
  my(@initialisers) = ();

  $allgroups = '';
  foreach $argument (sort keys %arguments)
  {
    next if ($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:);

    $arguments{$argument} =~ m,^([^! ]+) ?([^!]*)?!([^!]*)\::([^!]*)!([^!]*)!([^!]*),;
    $qualifier = $3;
    $varsuffix = $6;

    push(@initialisers, "if(CCTKARGNUM_$argument == -1) CCTKARGNUM_$argument = CCTK_VarIndex(\"$qualifier\::$argument$varsuffix\");");

    $arguments{$argument} =~ /\::([^!]+)/;
    $group = $1;
    if ($allgroups !~ / $group /)
    {
      $allgroups .= " $group ";
      push(@initialisers, "if(CCTKGROUPNUM_$group == -1) CCTKGROUPNUM_$group = CCTK_GroupIndex(\"$qualifier\::$group\");");
    }
  }

  return @initialisers;
}

#/*@@
#  @routine    CreateCArgumentPrototype
#  @date       Thu Jan 28 14:36:25 1999
#  @author     Tom Goodale
#  @desc
#  Creates the prototype needed to call a Fortran function from C.
#  @enddesc
#@@*/
sub CreateCArgumentPrototype
{
  my(%arguments) = @_;
  my(@prototype) = ();
  my($argument, $type, $ntimelevels);

  # Put all storage arguments first.
  foreach $argument (sort keys %arguments)
  {
    if($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:)
    {
      push(@prototype, 'const int *');
    }
  }

  # Now deal with the rest of the arguments
  foreach $argument (sort keys %arguments)
  {
    next if ($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:);

    $arguments{$argument} =~ m:^([^! ]+) ?([^!]*)?!([^!]*):;

    if($arguments{$argument} !~ m:STORAGESIZE|GROUPLENGTH:)
    {
      $arguments{$argument} =~ m:^([^! ]+) ?([^!]*)?!([^!]*)!([^!]*):;

      $type        = $1;
      $ntimelevels = $4;

      for($level = 0; $level < $ntimelevels; $level++)
      {
        push(@prototype, "CCTK_$type *");
      }

      if($type !~ /^(CHAR|BYTE|INT|INT2|INT4|INT8|REAL|REAL4|REAL8|REAL16|COMPLEX|COMPLEX8|COMPLEX16|COMPLEX32)$/)
      {
        &CST_error(0,"Unknown argument type $type","",__LINE__,__FILE__);
      }
    }
  }

  return join(',', @prototype);
}



#/*@@
#  @routine    CreateCArgumentList
#  @date       Thu Jan 28 14:37:07 1999
#  @author     Tom Goodale
#  @desc
#  Creates the argument list used to call a Fortran function from C.
#  @enddesc
#@@*/
sub CreateCArgumentList
{
  my(%arguments) = @_;
  my(@arglist) = ();
  my(@argument, $type, $ntimelevels);


  # Put all storage arguments first.
  foreach $argument (sort keys %arguments)
  {
    if($arguments{$argument} =~ m/STORAGESIZE\([^,]*::([^,]*),\s*(\d+)/)
    {
      push(@arglist, "PASS_GROUPSIZE($1, $2)");
    }
    elsif($arguments{$argument} =~ m/GROUPLENGTH\(([^:]*)::([^)]*)\)/)
    {
      push(@arglist, "PASS_GROUPLEN($1, $2)");
    }
  }

  # Now deal with the rest of the arguments
  foreach $argument (sort keys %arguments)
  {
    next if ($arguments{$argument} =~ m:STORAGESIZE|GROUPLENGTH:);

    $arguments{$argument} =~ m:^([^! ]+) ?([^!]*)?!([^!]*)!([^!]*):;

    $type        = $1;
    $ntimelevels = $4;
    $arguments{$argument} =~ /\::([^!]+)/;
    $group = $1;

    for($level = 0; $level < $ntimelevels; $level++)
    {
      push(@arglist, "PASS_REFERENCE($argument, $level)");
    }

    if($type =~ /^(CHAR|BYTE|INT|INT2|INT4|INT8|REAL|REAL4|REAL8|REAL16|COMPLEX|COMPLEX8|COMPLEX16|COMPLEX32)$/)
    {
      # DEPRECATED IN BETA 10
      if($type eq 'CHAR')
      {
        &CST_error(1,"CCTK_CHAR is replaced by CCTK_BYTE, please change your code","",__LINE__,__FILE__);
      }
    }
    else
    {
      &CST_error(0,"Unknown argument type $type","",__LINE__,__FILE__);
    }
  }

  return join(",\\\n", @arglist);
}

#/*@@
#  @routine    CreateThornArgumentHeaderFile
#  @date       Thu Jan 28 14:37:58 1999
#  @author     Tom Goodale
#  @desc
#  Creates all the argument list stuff necessary to call Fortran from C
#  @enddesc
#@@*/
sub CreateThornArgumentHeaderFile
{
  my($this_thorn, $rhinterface_db) = @_;
  my($line, $thorn);
  my(@returndata) = ();
  my(%hasvars);

  # Header Data
  push(@returndata, '/*@@');
  push(@returndata, "   \@header  ${this_thorn}_arguments.h");
  push(@returndata, '   @author  Automatically generated by GridFuncStuff.pl');
  push(@returndata, '   @desc');
  push(@returndata, '            Defines macros to declare/define/pass function arguments');
  push(@returndata, "            in calls from C to Fortran for thorn $this_thorn");
  push(@returndata, '   @enddesc');
  push(@returndata, ' @@*/');
  push(@returndata, '');
  push(@returndata, '');

  $thorn = "\U$this_thorn";

  # Create the basic thorn block definitions
  foreach $block ("PRIVATE", "PROTECTED", "PUBLIC")
  {

    %data = &GetThornArguments($this_thorn, $block, $rhinterface_db);

#    $print_data = 1;
#    if ($print_data)
#    {
#      foreach $arg (keys %data)
#      {
#        print "$this_thorn data: $arg : $data{\"$arg\"}\n";
#      }
#    }
    # Remember if there actually are any arguments here.
    $hasvars{$block} = 1 if(keys %data > 0) ;

    # Do the fortran definitions
    push(@returndata, '#ifdef FCODE');

    # Create the fortran argument declarations
    push(@returndata, "#define DECLARE_${thorn}_${block}_FARGUMENTS \\");
    @data = &CreateFortranArgumentDeclarations(%data);
    push(@returndata, join ("&&\\\n", @data));
    push(@returndata, '');

    # Create the fortran argument list
    push(@returndata, "#define ${thorn}_${block}_FARGUMENTS \\");
    push(@returndata, &CreateFortranArgumentList(%data));
    push(@returndata, '');

    push(@returndata, '#endif /* FCODE */');
    push(@returndata, '');


    ##########################################################

    # Do the C definitions
    push(@returndata, '#ifdef CCODE');

    # Create the C argument declarations
    push(@returndata, "#define DECLARE_${thorn}_${block}_CARGUMENTS \\");
    @data = &CreateCArgumentDeclarations(%data);
    push(@returndata, join (" \\\n", @data));
    push(@returndata, '');

    # Create code to use each C argument variable
    push(@returndata, "#define USE_${thorn}_${block}_CARGUMENTS \\");
    @data = &CreateCArgumentUses(%data);
    push(@returndata, join (" \\\n", @data));
    push(@returndata, '');

    # Create the C argument variable number statics
    push(@returndata, "#define DECLARE_${thorn}_${block}_C2F \\");
    @data = &CreateCArgumentStatics(%data);
    push(@returndata, join (" \\\n", @data));
    push(@returndata, '');

    # Create the C argument variable number statics initialisers
    push(@returndata, "#define INITIALISE_${thorn}_${block}_C2F \\");
    @data = &CreateCArgumentInitialisers(%data);
    push(@returndata, join (" \\\n", @data));
    push(@returndata, '');

    # Create the C argument prototypes
    push(@returndata, "#define ${thorn}_${block}_C2F_PROTO \\");
    push(@returndata, &CreateCArgumentPrototype(%data));
    push(@returndata, '');

    # Create the C argument list
    push(@returndata, "#define PASS_${thorn}_${block}_C2F(GH) \\");
    push(@returndata, &CreateCArgumentList(%data));

    push(@returndata, '');
    push(@returndata, '#endif /* CCODE */');
    push(@returndata, '');
  }

  ################################################################

  # Create the final thorn argument macros

  $fortran_arguments = "#define ${thorn}_FARGUMENTS _CCTK_FARGUMENTS";
  $fortran_declarations = "#define DECLARE_${thorn}_FARGUMENTS _DECLARE_CCTK_FARGUMENTS";
  $c_declarations = "#define \UDECLARE_${thorn}_CARGUMENTS _DECLARE_CCTK_CARGUMENTS";
  $c_use_arguments = "#define \UUSE_${thorn}_CARGUMENTS _USE_CCTK_CARGUMENTS";
  $c_argument_prototypes = "#define \U${thorn}_C2F_PROTO _CCTK_C2F_PROTO";
  $c_argument_lists = "#define PASS_\U${thorn}_C2F(GH) _PASS_CCTK_C2F(GH)";
  $c_declare_statics = "#define DECLARE_\U${thorn}_C2F _DECLARE_CCTK_C2F";
  $c_initialize_statics = "#define INITIALISE_\U${thorn}_C2F _INITIALISE_CCTK_C2F";
  foreach $block ("PRIVATE", "PROTECTED", "PUBLIC")
  {
    if($hasvars{$block})
    {
      $fortran_arguments .= ", ${thorn}_${block}_FARGUMENTS";
      $fortran_declarations .= " DECLARE_${thorn}_${block}_FARGUMENTS";
      $c_declarations .= " DECLARE_${thorn}_${block}_CARGUMENTS";
      $c_use_arguments .= " USE_${thorn}_${block}_CARGUMENTS";
      $c_argument_prototypes .= ", ${thorn}_${block}_C2F_PROTO";
      $c_argument_lists .= ", PASS_${thorn}_${block}_C2F(GH)";
      $c_declare_statics .= " DECLARE_${thorn}_${block}_C2F";
      $c_initialize_statics .= " INITIALISE_${thorn}_${block}_C2F";
    }
  }

  # Do the Fortran argument lists
  push(@returndata, '#ifdef FCODE');
  push(@returndata, $fortran_arguments);
  push(@returndata, '');
  push(@returndata, $fortran_declarations);
  push(@returndata, '');
  push(@returndata, '#endif /* FCODE */');
  push(@returndata, '');

  # Do the Fortran argument lists
  push(@returndata, '#ifdef CCODE');
  push(@returndata, $c_declarations);
  push(@returndata, '');
  push(@returndata, $c_use_arguments);
  push(@returndata, '');
  push(@returndata, $c_argument_prototypes);
  push(@returndata, '');
  push(@returndata, $c_argument_lists);
  push(@returndata, '');
  push(@returndata, $c_declare_statics);
  push(@returndata, '');
  push(@returndata, $c_initialize_statics);
  push(@returndata, '');
  push(@returndata, "#define ${thorn}_CARGUMENTS cGH *cctkGH");
  push(@returndata, '');
  push(@returndata, '#endif /* CCODE */');

  push(@returndata, '');

  return @returndata;
}



#/*@@
#  @routine    CreateThornGroupInitialisers
#  @date       Thu Jan 28 14:38:56 1999
#  @author     Tom Goodale
#  @desc
#  Creates the calls used to setup groups for a particular thorn block.
#  @enddesc
#@@*/
sub CreateThornGroupInitialisers
{
  my($thorn, $block, $rhinterface_db, $rhparameter_db) = @_;
  my(@variables, @data);
  my($imp, $line, $group, $dim, $string, $numsize, $message, $type);

  $imp = $rhinterface_db->{"\U$thorn\E IMPLEMENTS"};

  foreach $group (split(" ", $rhinterface_db->{"\U$thorn $block GROUPS"}))
  {
    $type = $rhinterface_db->{"\U$thorn GROUP $group\E GTYPE"};

    # Check consistency for arrays
    if ($type eq "ARRAY")
    {
      $dim = $rhinterface_db->{"\U$thorn GROUP $group\E DIM"};
      $string = $rhinterface_db->{"\U$thorn GROUP $group\E SIZE"};
      &CheckArraySizes($string,$thorn,$rhparameter_db,$rhinterface_db);
      $numsize = ($string =~ s/,//g)+1;
      if ($dim != $numsize)
      {
        $message = "Array dimension $dim doesn't match the $numsize array sizes ";
        $message .= "\n     ($rhinterface_db->{\"\U$thorn GROUP $group\E SIZE\"}) for $group in $thorn";
        $message .= "\n     (Array sizes must be comma separated list of parameters)";
        &CST_error(0,$message,"",__LINE__,__FILE__);
      }
    }

    $line = "  if (CCTKi_CreateGroup (\"\U$group\", \"$thorn\", \"$imp\",";
    push(@data, $line);
    $line = '                         "'
          . $rhinterface_db->{"\U$thorn GROUP ${group}\E GTYPE"}
          . '", "'
          . $rhinterface_db->{"\U$thorn GROUP ${group}\E VTYPE"}
          . '", "'
          . $block
          . '",';
    push(@data, $line);
    $line = '                         '
          . $rhinterface_db->{"\U$thorn GROUP $group\E DIM"}
          . ', '
          . $rhinterface_db->{"\U$thorn GROUP $group\E TIMELEVELS"}
          . ',';
    push(@data, $line);
    $line = '                         "'
          . $rhinterface_db->{"\U$thorn GROUP $group\E STYPE"}
          . '", "'
          . $rhinterface_db->{"\U$thorn GROUP $group\E DISTRIB"}
          . '",';
    push(@data, $line);
    $line = '                         "'
          . $rhinterface_db->{"\U$thorn GROUP $group\E SIZE"}
          . '", "'
          . $rhinterface_db->{"\U$thorn GROUP $group\E GHOSTSIZE"}
          . '",';
    push(@data, $line);
    $line = '                         "'
          . $rhinterface_db->{"\U$thorn GROUP $group\E TAGS"}
          . '",';
    push(@data, $line);

    # Is it a vector group ?
    @variables = split(" ", $rhinterface_db->{"\U$thorn GROUP $group\E"});
    if(defined($rhinterface_db->{"\U$thorn GROUP $group\E VARARRAY_SIZE"}))
    {
      # Check that the size is allowed.
      &CheckArraySizes($rhinterface_db->{"\U$thorn GROUP $group\E VARARRAY_SIZE"},$thorn,$rhparameter_db,$rhinterface_db);
      # Flag Cactus that it is a vector group.
      $line = '                         -1';
    }
    else
    {
      $line = '                         ' . scalar(@variables);
    }

    foreach $variable (@variables)
    {
      $line .= ",\n                         \"$variable\"";
     }

    # Pass in the size of the GV array, which may be a valid parameter expression
    if(defined($rhinterface_db->{"\U$thorn GROUP $group\E VARARRAY_SIZE"}))
    {
      $line .= ',';
      push(@data, $line);
      $line  = '                        "';
      $line .= $rhinterface_db->{"\U$thorn GROUP $group\E VARARRAY_SIZE"};
      $line .= '"';
    }

    $line .= ') == 1)';
    push(@data, $line);

    push(@data, '  {');
    push(@data, '    warn_mixeddim_gfs = 1;');
    push(@data, '  }');
  }

  return @data;
}

# TR 24 Jan 2003
# Fortran wrappers are now defined and registered in "Variables/$thorn.c"
#
#sub CreateThornFortranWrapper
#{
#  my($thorn) = @_;
#  my(@data);
#
#  @data = ();
#  push(@data, '/*@@');
#  push(@data, "   \@file    ${thorn}_FortranWrapper.c");
#  push(@data, '   @author  Automatically generated by GridFuncStuff.pl');
#  push(@data, '   @desc');
#  push(@data, "            Defines the fortran wrappers for scheduled fortran routines of thorn $thorn");
#  push(@data, '   @enddesc');
#  push(@data, ' @@*/');
#  push(@data, '');
#  push(@data, '');
#
#  push(@data, "#define THORN_IS_$thorn 1");
#  push(@data, '');
#  push(@data, '#include "cctk.h"');
#  push(@data, '#include "cctk_Flesh.h"');
#  push(@data, '#include "cctk_Groups.h"');
#  push(@data, '#include "cctk_Comm.h"');
#  push(@data, '#include "cctk_Arguments.h"');
#  push(@data, '');
#
#  push(@data, "int CCTKi_BindingsFortranWrapper$thorn(cGH *GH, CCTK_FPOINTER fpointer);");
#  push(@data, '');
#  push(@data, "int CCTKi_BindingsFortranWrapper$thorn(cGH *GH, CCTK_FPOINTER fpointer)");
#  push(@data, '{');
#  push(@data, '  const int _cctk_zero = 0;');
#  push(@data, "  void (*function)(\U$thorn\E_C2F_PROTO);");
#  push(@data, "  DECLARE_\U$thorn\E_C2F");
#  push(@data, "  INITIALISE_\U$thorn\E_C2F");
#  push(@data, '  (void) (_cctk_zero + 0);');
#  push(@data, '');
#
#  push(@data, "  function = (void (*) (\U$thorn\E_C2F_PROTO)) fpointer;");
#  push(@data, "  function (PASS_\U$thorn\E_C2F (GH));");
#  push(@data, '');
#  push(@data, '  return 0;');
#  push(@data, '}');
#
#  return (@data);
#}


#/*@@
#  @routine    CheckArraySizes
#  @date       Thu May 10 2001
#  @author     Gabrielle Allen
#  @desc
#              Arrays sizes must be given as a comma-separated list of
#                - integer contants (no sign character)
#                - parameter names (either fullname or just the basename)
#                  optionally with a "+/-<integer constant>" postfix
#  @enddesc
#@@*/
sub CheckArraySizes
{
  my($size,$thornname,$rhparameter_db,$rhinterface_db) = @_;
  my($par,$thorn,$base);

  foreach $par (split(",",$size))
  {

#     # check for size to be a constant
#     next if $par =~ /^\d+$/;

#     # check for size to be a parameter
#     if ($par =~ /^([A-Za-z]\w*)(::([A-Za-z]\w*))?([+-]\d+)?$/)
#     {
#       if (defined $2)
#       {
#         $thorn = $1;
#         $base = $3;
#       }
#       else
#       {
#         $thorn = $thornname;
#         $base = $1;
#       }

#       # check if the parameter really exists
#       if ($rhparameter_db->{"\U$thorn Private\E variables"} !~ m:$base:i &&
#           $rhparameter_db->{"\U$thorn Global\E variables"} !~ m:$base:i &&
#           $rhparameter_db->{"\U$thorn Restricted\E variables"} !~ m:$base:i)
#       {
#         &CST_error(0,"Array size \'$par\' in $thornname is not a parameter",
#                    "",__LINE__,__FILE__);
#       }
#     }
#     else
#     {
#       &CST_error(0,"Array size \'$par\' in $thornname has invalid syntax",
#                  "",__LINE__,__FILE__);
#     }

    &VerifyParameterExpression($par,$thornname,$rhparameter_db,$rhinterface_db);
  }

}

#/*@@
#  @routine    VerifyParameterExpression
#  @date       Sat Oct 13 16:40:07 2001
#  @author     Tom Goodale
#  @desc
#  Does some sanity checking on an arithmetic expression
#  involving parameter values.
#  Parameter names can be bare, in which case they are assumed to be
#  from the current thorn, or qualified, in which case they should
#  refer either to the current thorn or a valid shared parameter.
#  @enddesc
#@@*/
sub VerifyParameterExpression
{
  my($expression,$thornname,$rhparameter_db,$rh_interface_db) = @_;
  my($i,$count,@fields);

  # Eliminate white space in expression
  $expression =~ s/\s+//g;

  # First do some global checks
  if($expression !~ m%^[-+*/a-zA-Z0-9_():\[\]]+$%)
  {
    &CST_error(0, "Array size in $thornname is an invalid arithmetic expression \n"
               .  "      '$expression' contains invalid characters");
  }

  $count = 0;

  for $i (split(//,$expression))
  {
    $count++ if($i eq "(");
    $count-- if($i eq ")");

    if($count < 0)
    {
      &CST_error(0, "Array size in $thornname is an invalid arithmetic expression \n"
                 .  "        '$expression' has too many closing parentheses",
                "",__LINE__,__FILE__);
    }
  }

    if($count > 0)
    {
      &CST_error(0, "Array size in $thornname is an invalid arithmetic expression \n"
                 .  "        '$expression' has unmatched parentheses",
                 "",__LINE__,__FILE__);
    }


  if($expression =~ m:[-+*/]$:)
  {
    &CST_error(0, "Array size in $thornname is an invalid arithmetic expression \n"
               .  "          '$expression' ends with an operator",
               "",__LINE__,__FILE__);

  }

  # Now split the string on operators and parentheses
  @fields = split(/([-+*\/()]+)/, $expression);

  for $i (@fields)
  {
    # Get rid of any empty tokens
    next if($i =~ m:^\s*$:);

    # Deal with the easy valid cases

    next if($i =~ m:^[-+/*]\(*$:);
    next if($i =~ m:^\)*[-+/*]$:);
    next if($i =~ m:^\(+$:);
    next if($i =~ m:^\)+$:);
    next if($i =~ m:^\d+$:);

    # Now check if it is a valid parameter name
    if($i =~ m:^([a-zA-Z][a-zA-Z0-9_]*)(\:\:([a-zA-Z][a-zA-Z0-9_]*))?:)
    {
      if (defined $2)
      {
        $thorn = $1;
        $base = $3;
      }
      else
      {
        $thorn = $thornname;
        $base = $1;
      }

      if($thorn =~ m/^$thornname$/i)
      {
        # check if the parameter really exists
        # FIXME: should also translate and check implementation for restricted and global params.
        if ($rhparameter_db->{"\U$thorn Private\E variables"} !~ m:$base:i &&
            $rhparameter_db->{"\U$thorn Global\E variables"} !~ m:$base:i &&
            $rhparameter_db->{"\U$thorn Restricted\E variables"} !~ m:$base:i)
        {
          &CST_error(0,"Array size \'$expression\' in $thornname contains a constant which isn\'t a parameter",
                     "",__LINE__,__FILE__);
        }
      }
      else
      {
        # Parameter is from a different implementation

        my $implementation = $thorn;

        if($rhparameter_db->{"\U$thornname SHARES\E implementations"} =~ m/\b$implementation\b/i)
        {
          # Ok, so it does share from this implementation
          if($rhparameter_db->{"\U$thornname SHARES $implementation\E variables"} !~ m/\b$base\b/i)
          {
            &CST_error(0,"Array size \'$expression\' in $thornname contains a reference to a parameter from $implementation" .
                       " which is neither USED nor EXTENDED",
                       "",__LINE__,__FILE__);
          }
        }
        else
        {
          &CST_error(0,"Array size \'$expression\' in $thornname contains a reference to a parameter from $implementation" .
                     " which is not shared",
                     "",__LINE__,__FILE__);
        }
      }
    }
    elsif($i =~ m:^\(\)$:)
    {
      # Empty parenthesis - bad
      &CST_error(0, "Array size in $thornname is an invalid arithmetic expression \n"
               .  "          '$expression' contains empty parentheses",
               "",__LINE__,__FILE__);
    }
    elsif($i =~ m:[-+/*]{2,}:)
    {
      # Two operators in a row - bad
      &CST_error(0, "Array size in $thornname is an invalid arithmetic expression \n"
               .  "          '$expression' contains two operators in a row",
               "",__LINE__,__FILE__);
    }
    elsif($i =~ m:[-+/*]\):)
    {
      # Operator followed by closing parenthesis - bad
      &CST_error(0, "Array size in $thornname is an invalid arithmetic expression \n"
               .  "          '$expression' has a missing operand",
               "",__LINE__,__FILE__);
    }
    elsif($i =~ m:\([-+/*]:)
    {
      # Opening parenthesis followed by operator - bad
      &CST_error(0, "Array size in $thornname is an invalid arithmetic expression \n"
               .  "          '$expression' has a missing operand",
               "",__LINE__,__FILE__);
    }
    else
    {
      # I've run out of imagination
      &CST_error(0, "Array size in $thornname is an invalid arithmetic expression \n"
               .  "          '$expression' contains unrecognised token '$i'",
               "",__LINE__,__FILE__);
    }
  }

}

1;