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

# Author: Jan Labanowski, done on 97.03.23
#
# this utility converts orbital basis sets from DGauss ver 4 format
# deMon format. It has to be used as # a filter, e.g.: 
#     cat DGauss.bas | DGauss2deMon-ov4.pl > deMon.bas
# Remember that first line of this file has to point to the location of perl
# interpreter, and this very file has to have execute permission  bit(s) set.
# The DGauss.bas is a file containing a single definition of a basis
# set for some element, and deMon.bas 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');

%L = ('S',  0, 
      'P',  1, 
      'D',  2, 
      'F',  3, 
      'G',  4);

$line = &getline();
if($line !~ /^(\S+)\s+(\S+)/) {
  die "This line should have a format\nEL  BASISTYPE\n";
  }
$symbol = $1;
$symbol =~ tr/a-z/A-Z/;
$basis = $2;
$line = &getline();
$line =~ s/^\s+//;
@fields = split(/\s+/, $line);
$n_contr = $fields[0];

$max_type = 0;
$n_expn = 0;
for($n = 0; $n < $n_contr; $n++) {
  $line = &getline();
  @fields = split(/\s+/, $line);
  $type = $L{$fields[0]};
  if($type > $max_type) {
    $max_type = $type;
    }
  $n_prim = $fields[1] + 0;
  $n_type[$n] = $type;
  $n_size[$n] = $n_prim;
  $shell_start[$n] = $n_expn+1;
  for($i = 0; $i < $n_prim; $i++) {
    $line = &getline();
    @fields = split(/\s+/, $line);
    $n_expn++;
    $expn[$n_expn] = $fields[0] + 0.0;
    if($#fields == 0) {
      $coef[$n_expn] = 1.0;
      }
    else {
      $coef[$n_expn] =  $fields[1] + 0.0;
      }
    }
  $shell_end[$n] = $n_expn;
  }

for ($n = 0; $n <= 4; $n++) {   # if no p's and/or d's
  $n_shells[$n] = 0;
  }

$label = 'O-' . $elements{$symbol} . ' (';
for($type = 0; $type <= $max_type; $type++) {
  $n = 0;
  for($i = 0; $i < $n_contr; $i++) {
    if($type == $n_type[$i]) {
      $label .= sprintf("%1d", $n_size[$i]);
      $n++
      }
    }
  $n_shells[$type] = $n;
  if($type != $max_type) {
    $label .= '/';
    }
  else {
    $label .= ')';
    }
  }

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


for ($n = 0; $n < 3; $n++) {  # print number of s, p, & d contractions
  printf STDOUT "%5d", $n_shells[$n];
  }

print STDOUT "\n";

for ($type = 0; $type <= $max_type; $type++) {
  for($i = 0; $i < $n_contr; $i++) {
    if($n_type[$i] == $type) {
      printf STDOUT "%5d\n", $n_size[$i];
      for($j = $shell_start[$i]; $j <= $shell_end[$i]; $j++) {
        printf STDOUT "%20.10f%20.10f\n", $expn[$j], $coef[$j];
        }
      }
    }
  }



# =====================================================
sub getline {
  local ($inpl);
  local (@tokens);
  local ($nt);
   while($inpl = ) {
     if(($inpl !~ /\S/) || ($inpl =~ /^\s*#/)) {
       next;
       }
     else {
       chop($inpl);
       $inpl =~ tr/a-z/A-Z/;
       $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);
   }