#!/usr/local/bin/perl -w

# Author: Jan Labanowski, done on:  97.03.23
#
# this utility converts auxilliary fitting sets from DGauss format
# deMon format. It has to be used as a filter, e.g.: 
#     cat DGauss.abas | DGauss2deMon-a.pl > deMon.abas
# Remember that first line in this scripy has to point to the location or perl
# interpreter, and this very file has to have execute permission  bit(s) set.
# DGauss.abas is a file containing a single definition of an auxilliary
# fitting basis set for some element, and deMon.abas is a file which will
# contain the same basis in the deMon format.
# If you find bugs, please bug Jan Labanowski, jkl@ccl.net

%elements = (
 'H',  'HYDROGEN',
 'HE', 'HELIUM',
 'LI', 'LITHIUM',
 'BE', 'BERYLLIUM',
 'B',  'BORON',
 'C',  'CARBON',
 'N',  'NITROGEN',
 'O',  'OXYGEN',
 'F',  'FLURINE',
 'NE', 'NEON',
 'NA', 'SODIUM',
 'MG', 'MAGNESIUM',
 'AL', 'ALUMINIUM',
 'SI', 'SILICON',
 'P',  'PHOSPHORUS',
 'S',  'SULFUR',
 'CL', 'CHLORINE',
 'AR', 'ARGON',
 'K',  'POTASSIUM',
 'CA', 'CALCIUM',
 'SC', 'SCANDIUM',
 'TI', 'TITANIUM',
 'V',  'VANADIUM',
 'CR', 'CHROMIUM',
 'MN', 'MANGANESE',
 'FE', 'IRON',
 'CO', 'COLBALT',
 'NI', 'NICKEL',
 'CU', 'COPPER',
 'ZN', 'ZINC',
 'GA', 'GALLIUM',
 'GE', 'GERMANIUM',
 'AS', 'ARSENIC',
 'SE', 'SELENIUM',
 'BR', 'BROMIUM',
 'KR', 'KRYPTON',
 'RB', 'RUBIDIUM',
 'SR', 'STRONTIUM',
 'Y',  'YTtRIUM',
 'ZR', 'ZIRCONIUM',
 'NB', 'NOBIUM',
 'MO', 'MOLYBDENUM',
 'TC', 'TECHNICIUM',
 'RU', 'RUTHENIUM',
 'RH', 'RHODIUM',
 'PD', 'PALLADIUM',
 'AG', 'SILVER',
 'CD', 'CADIUM',
 'IN', 'INDIUM',
 'SN', 'TIN',
 'SB', 'ANTYMONIUM',
 'TE', 'TELLIUM',
 'I',  'IODINE',
 'XE', 'XENON');

for($i = 1; $i <= 3; $i++) {
  $ctypes[$i] = 0;
  $xtypes[$i] = 0;
  }
$line = &getline();
if($line !~ /^(\S+)\s+(\S+)/) {
  die "This line should have a format\nEL  BASISTYPE\n";
  }
$symbol = $1;
$basis = $2;
# Now get number of uncontracted gaussian for charge fit
$line = &getline();
$line =~ s/^\s+//;
@fields = split(/\s+/, $line);
$n_ctypes = 0;
for($i = 0; $i <= $#fields; $i++) {
  if($fields[$i] =~ /(\d+)/) {
    $n_ctypes++;
    $ctypes[$n_ctypes] = $1 + 0;
    }
  }
if($n_ctypes <= 0) {
  die "The line with number of s,p,d for charge fit not given:\n$line\n";
  }

$n_cexp = 0;
for ($n = 1; $n <= $n_ctypes; $n++) {
  for ($j = 1; $j <= $ctypes[$n]; $j++) {
    $n_cexp++;
    $line = &getline();
    $cexponents[$n_cexp] = $line + 0.0;
    }
  }

      
$line = &getline();
$line =~ s/^\s+//;
@fields = split(/\s+/, $line);
$n_xtypes = 0;
for($i = 0; $i <= $#fields; $i++) {
  if($fields[$i] =~ /(\d+)/) {
    $n_xtypes++;
    $xtypes[$n_xtypes] = $1 + 0;
    }
  }
if($n_xtypes <= 0) {
  die "The line with number s,p,d for XC fit not given:\n$line\n";
  }

$n_xexp = 0;
for ($n = 1; $n <= $n_xtypes; $n++) {
  for ($j = 1; $j <= $xtypes[$n]; $j++) {
    $n_xexp++;
    $line = &getline();
    $xexponents[$n_xexp] = $line + 0.0;
    }
  }

$label = 'A-' . $elements{$symbol} . ' (';
for ($n = 1; $n <= $n_ctypes; $n++) {
  if($ctypes[$n] > 0) {
    $label .= sprintf("%1d", $ctypes[$n]);
    }
  if($n < $n_ctypes) {
    $label .= ',';
    }
  }
$label .= ';';
for ($n = 1; $n <= $n_xtypes; $n++) {
  if($xtypes[$n] > 0) {
    $label .= sprintf("%1d", $xtypes[$n]);
    }
  if($n < $n_xtypes) {
    $label .= ',';
    }
  }
$label .= ')';


print STDOUT "# $basis\n";
print STDOUT "$label\n";

$n_cexp = 0;
for ($n = 1; $n <= 3; $n++) {  # print number of s, p, & d primitives
  if($ctypes[$n] > 0) {
    printf STDOUT "%5d\n", $ctypes[$n];
    for ($j = 1; $j <= $ctypes[$n]; $j++) {
      $n_cexp++;
      printf STDOUT "%18.8f\n", $cexponents[$n_cexp];
      }
    }
  }

$n_xexp = 0;
for ($n = 1; $n <= 3; $n++) {  # print number of s, p, & d primitives
  if($xtypes[$n] > 0) {
    printf STDOUT "%5d\n", $xtypes[$n];
    for ($j = 1; $j <= $xtypes[$n]; $j++) {
      $n_xexp++;
      printf STDOUT "%18.8f\n", $xexponents[$n_xexp];
      }
    }
  }


# =====================================================
sub getline {
  local ($inpl);
  local (@tokens);
  local ($nt);
   while($inpl = <STDIN>) {
     if(($inpl !~ /\S/) || ($inpl =~ /^\s*:/)) {
       next;
       }
     else {
       chop($inpl);
       $inpl =~ s/^\s+//;
       $inpl =~ s/\s+$//;
       @tokens = split(/\s+/, $inpl);
       $inpl = "";
       for($nt = 0; $nt <= $#tokens; $nt++) {
         if($tokens[$nt] =~ /:$/) {
           next;
           }
         else {
           if($inpl ne "") {
             $inpl = $inpl . " ";
             }
           $inpl = $inpl . $tokens[$nt];
           }
         }
       if($inpl ne "") {
         last;
         }
       else {
         next;
         }
       }
     }
   return($inpl);
   }