#!/usr/bin/perl
#-*-perl-*-
#
# program to convert numerical recipes from
# a single precision version to a toggable
# single-double precision set up using pre-
# processor conditionals. the conditionals
# respond to the env variable CESR_F90_DOUBLE

@obj_list=('badluk.f90', 'fredex.f90', 'sfroid.f90', 'sphfpt.f90', 'sphoot.f90', 'xlinbcg.f90');
@exc_list=('shoot.f90', 'shootf.f90');
@demo_inc=('xlinbcg.f90');

get_recipes();
convert_and_distribute();
clean_up();

#------------------------------------------------------------------------------

sub clean_up
 {system("rm -fr recipes_f-90");
  system("rm -fr temp.out");
 }

sub get_recipes
 {
  system("cvs checkout recipes_f-90");
  system("mkdir recipes_f-90_LEPP");
  system("mkdir recipes_f-90_LEPP/lib_src");
  system("mkdir recipes_f-90_LEPP/obj_src");
  system("mkdir recipes_f-90_LEPP/scripts");
  system("cp -p conversion_script recipes_f-90_LEPP/scripts");
 }

sub convert_and_distribute
 {
  chdir("./recipes_f-90/demo/src");
  foreach $file (@demo_inc)
   {system("cp $file ../../recipes");}
  chdir("../../recipes");  
  foreach $file (@exc_list)
   {
    if(-e $file)
     {system("rm $file");}
   }
  foreach $file (@obj_list)
   {
    if(-e $file)
     {
      convert_file($file);
      system("mv temp.out ../../recipes_f-90_LEPP/obj_src/$file");
      system("rm $file");
     }
   } 
  while($file=<./*>)
   {
    convert_file($file);
    system("mv temp.out ../../recipes_f-90_LEPP/lib_src/$file");    
   }
  chdir("../..");
 }

#------------------------------------------------------
# convert to double routine.
# program/end program and module/end module statements must be outside the #if defined.

sub convert_file {

  $file_name=$_[0];
  print "Converting $file_name\n";
  open (F_in, $file_name) || die ("cannot open file");
  open (F_out, ">temp.out");

  $in_if = 0;
  @list = ();


  loop: while(<F_in>) {

# check for program or module lines
# delete from module procedure any double precision routines.
# geop_dv is an exception since for some strange reason there is no geop_rv.

    if ($procedure_here || /^\s*module procedure/i) {
      @list = (@list, $_);
      s/,[^,]*_ddv([,\s])/$1/i;
      if (/,[^,]*_dv([,\s])/i && ! /geop_dv/i) {s/,[^,]*_dv([,\s])/$1/i;}
      s/,[^,]*_dd([,\s])/$1/i;
      s/,[^,]*_d([,\s])/$1/i;
      s/,[^,]*_zv([,\s])/$1/i;
      s/,[^,]*_zm([,\s])/$1/i;
      s/,[^,]*_z([,\s])/$1/i;
      if (/&\w*$/) {
        $procedure_here = 1;
      } else {
        $procedure_here = 0;
      }

    } elsif (/^\s*program/i || /^\s*end\s*program/i || 
          /^\s*module/i || /^\s*end\s*module/i) {
      if ($in_if) {else_out();}
      print F_out;
      next loop;

    } elsif (/^\s$/ && !$in_if) {
      print F_out;
      next loop;

    } else {
      if (!$in_if) {print F_out ("#if defined(CESR_F90_DOUBLE)\n");}
      $in_if = 1;
      @list = (@list, $_);
    }

# remove sp and spc parameter defs

    if (/parameter :: sp/i) {next;}

# remove all type and subroutine parts whose name ends with _dp

    if (/^\s*type *\w*_dp/i) {         # match to: "type xxxx_dp"
      while (<F_in>) {
        @list = (@list, $_);
        if (/^\s*end type/i) {next loop;}
      }
    }

    if (/^\s*function *\w*_dp/i) {         # match to: "type xxxx_dp"
      while (<F_in>) {
        @list = (@list, $_);
        if (/^\s*end function/i) {next loop;}
      }
    }

    if (/^\s*subroutine *\w*_dp/i) {   # match to: "subroutine xxxx_dp"
      while (<F_in>) {
        @list = (@list, $_);
        if (/^\s*end subroutine/i) {next loop;}
      }
    }

# convert single to double

    s/_spc/_dpc/gi;
    s/\(spc\)/\(dpc\)/gi;
		s/ spc / dpc /gi;
		s/ spc\)/ dpc\)/gi;
		s/,spc\)/,dpc\)/gi;
    s/=spc\)/=dpc\)/gi; 

    s/_sp/_dp/gi;         # _sp               -> _dp
    s/\(sp\)/\(dp\)/gi;   # (sp)              -> (dp)
		s/ sp / dp /gi;       # <space>sp<space>  -> <space>dp<space>
		s/ sp\)/ dp\)/gi;     # <space>sp)        -> <space>dp)
		s/,sp\)/,dp\)/gi;     # ,sp)              -> ,dp)
    s/=sp\)/=dp\)/gi;     # =sp)              -> =sp)

    print (F_out);

  }

# straightforward transfer

  if ($in_if) {else_out();}

  close (F_in);
  close (F_out);

}

#------------------------------------------------------

sub else_out {
  print F_out ("#else\n");

  foreach $string (@list) {
    print F_out ($string);
  }

  print F_out ("#endif\n");
  $in_if = 0;
  @list = ();

}
#