nma_v5.tar

nma/0000755000175000017500000000000014147460013010671 5ustar  guestguestnma/nma_pdbmat.pl0000755000175000017500000000733313560574345013355 0ustar  guestguest#!/usr/bin/perl -w

open(A,"$ARGV[0]");

use Getopt::Long;

$debug = 1;

$pdb    = 'in.pdb';
$cutoff = 20.0;
$c_bond = 0;
$ignore_pair = undef;

# Read the input dat file
while($lineb = <A>){
     $lineb =~ s/,/ /g;
     ($a1,$b1) = split(" ", $lineb);
     $pdb=$a1;
     $cutoff=$b1;
     last;
}

if(defined $ignore_pair){
  ($a,$b) = split(' ',$ignore_pair);
  ($lb,$hb)=split('-',$a);
  foreach $n ($lb..$hb){
    $A{$n}=undef;
  }
  
  ($lb,$hb)=split('-',$b);
  foreach $n ($lb..$hb){
    $B{$n}=undef;
  }
}

print "group a ",join(' ',sort {$a<=>$b} keys %A),"\n" if $debug > 0;
print "group b ",join(' ',sort {$a<=>$b} keys %B),"\n" if $debug > 0;

open(OUT,"> matrice.sdijf") or die;
open(PDB,"$pdb") or die "failed to open $pdb, ";

print "cutoff      : $cutoff\n";
print "pdb         : $pdb\n";
print "ignore pair : $ignore_pair\n" if defined $ignore_pair;

$n=0;
while(<PDB>){
  next unless /^ATOM/;
  $n++;
  $x[$n] = substr($_,30,8);
  $y[$n] = substr($_,38,8);
  $z[$n] = substr($_,46,8);
}

$N = $n;

if($c_bond == 1){
  system("printf \"bond\nquit\n\" | rdparm 4ake.parm > blist 2>/dev/null");
  open(BOND,"blist") or die;
  while(<BOND>){
    $bond[$1][$2] = 1 if /\((\d+),(\d+)\)/;
  }
  
  print "# constant of bond     $c_bond\n";
  print "# constant of non bond 1.0\n";
}else{
  print "# sprint constant : 1.0\n";
}

$count=0;
$count_bond=0;
$count_nbond=0;
for $n (1..$N){
  for $m ($n+1..$N){

    if( defined $bond[$n][$m] ){
      $k = $c_bond;
      $count_bond++;
    }else{
      $k = 1;
      $count_nbond++;
    }
    $dx = $x[$n] - $x[$m];
    next if( abs($dx) > $cutoff);
    $dy = $y[$n] - $y[$m];
    next if( abs($dy) > $cutoff );
    $dz = $z[$n] - $z[$m];
    next if( abs($dz) > $cutoff );
    $rr = $dx**2 + $dy**2 + $dz**2;
    next if( $rr > $cutoff**2);

    if( defined $ignore_pair  &&
	(exists $A{$n} && exists $B{$m}) ||
	(exists $A{$m} && exists $B{$n}) ){
      print "cut $n <-> $m\n" if $debug >0;
      next;
    }

    $r = sqrt($rr);
    if ($r==0)
    {
       $drdx = 0.;
       $drdy = 0.;
       $drdz = 0.;
    }
    else
    {
       $drdx = $dx / $r;
       $drdy = $dy / $r;
       $drdz = $dz / $r;
    }
    
    $H[3*$n-2][3*$n-2] += $k*$drdx*$drdx;
    $H[3*$n-2][3*$n-1] += $k*$drdx*$drdy;
    $H[3*$n-2][3*$n  ] += $k*$drdx*$drdz;
    $H[3*$n-1][3*$n-1] += $k*$drdy*$drdy;
    $H[3*$n-1][3*$n  ] += $k*$drdy*$drdz;
    $H[3*$n  ][3*$n  ] += $k*$drdz*$drdz;
    
    $H[3*$m-2][3*$m-2] += $k*$drdx*$drdx;
    $H[3*$m-2][3*$m-1] += $k*$drdx*$drdy;
    $H[3*$m-2][3*$m  ] += $k*$drdx*$drdz;
    $H[3*$m-1][3*$m-1] += $k*$drdy*$drdy;
    $H[3*$m-1][3*$m  ] += $k*$drdy*$drdz;
    $H[3*$m  ][3*$m  ] += $k*$drdz*$drdz;
    
    $H[3*$n-2][3*$m-2] += -$k*$drdx*$drdx;
    $H[3*$n-2][3*$m-1] += -$k*$drdx*$drdy;
    $H[3*$n-2][3*$m  ] += -$k*$drdx*$drdz;
    $H[3*$n-1][3*$m-2] += -$k*$drdy*$drdx;
    $H[3*$n-1][3*$m-1] += -$k*$drdy*$drdy;
    $H[3*$n-1][3*$m  ] += -$k*$drdy*$drdz;
    $H[3*$n  ][3*$m-2] += -$k*$drdz*$drdx;
    $H[3*$n  ][3*$m-1] += -$k*$drdz*$drdy;
    $H[3*$n  ][3*$m  ] += -$k*$drdz*$drdz;
    
    $count++;
  }
}

print "# number of interactions $count, $count_bond(bond), $count_nbond(nonbond)\n";

$count=0;
for $n ( 0 .. ( 3*$N+2 ) ){
  for $m ($n..( 3*$N+2 )){
    if( defined $H[$n][$m] && $H[$n][$m] != 0 ){
      $count++;
    }
  }
}
print "# number of non-zero elements $count\n";

$count=0;
for $n ( 0 .. ( 3*$N+2 ) ){
  if( defined $H[$n][$n] && $H[$n][$n] != 0 ){
    $count+=$H[$n][$n];
    }
}
print "# matrix trace $count\n";

$count=0;
for $n ( 0 .. ( 3*$N+2 ) ){
  for $m ($n..( 3*$N+2 )){
    if( defined $H[$n][$m] && $H[$n][$m] != 0 ){
      printf(OUT "%6d %5d %15.12f\n",$n,$m,$H[$n][$m]);
    }
  }
}

sub distance {
  return sqrt( ($_[0]-$_[3])**2 + ($_[1]-$_[4])**2 + ($_[2]-$_[5])**2 );
}
nma/nma_record_info.py0000775000175000017500000000072013711226210014366 0ustar  guestguest#!/usr/bin/env python3

import sys

def diag(n_mode):
	f=open('diag_arpack.in', 'w')
	f.write('&inputs\n')
	f.write('nev =%3d, \n' %(n_mode))
	ncv=n_mode*2
		
	f.write('ncv =%4d,\n' %ncv)
	f.write('tol = 1e-12/')
	f.write('\n')
	f.close()	


def pdbmat(fichier,cutoff):
	f = open('pdbmat.dat', 'w')
	f.write('%10s %3d' %(fichier,cutoff))
	f.close()


# Main
if __name__ == '__main__':
	diag(int(sys.argv[1]))
	pdbmat( sys.argv[2],int(sys.argv[3]))
	sys.exit()




nma/nma_prepare_for_animate.py0000775000175000017500000000063713711226210016106 0ustar  guestguest#!/usr/bin/env python3

import pickle
import numpy
import re

if __name__ == '__main__':
    vec = open( "vec_ani.txt", "r" )
    data= []
    line_number=0
    for aLine in vec:
        fields= re.split("[ ]+",aLine)
        line_number+=1
        #print line_number, fields[0], fields[1]
        data.append( fields )
    vec.close()
    f = open( "vec_ani.pkl", "wb" )
    pickle.dump(data, f)
    f.close()




nma/nma_reformat_vector_foranimate.pl0000755000175000017500000000106513560574345017510 0ustar  guestguest#!/usr/bin/perl -w

@ARGV==2 or print "usage: reformat_vector_foranimate.pl natom org_vector\n";

$natom = $ARGV[0];
$orgvec = $ARGV[1];

open(IN,$orgvec) or die;

$clm=0;
$row=0;
$vec=100001;
open(OUT,">vec.$vec") or die;
while(){
    if( @F == 0 ){
	$_=<IN>;
	defined $_ or exit;
	chomp;
	@F = split;
    }

    if($row==$natom){
        print OUT "\n";
	$vec++;
	open(OUT,">vec.$vec") or die;
	$row=0;
    }
    
    $a = shift(@F);
    
    print OUT $a;
    if($clm==0 or $clm==1){
	print OUT " ";
	$clm++;
    }else{
	print OUT " ";
	$clm=0;
	$row++;
    }
}
nma/m_inout_Bfact.py0000775000175000017500000002562614035561127014040 0ustar  guestguest#!/usr/bin/env python3
# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#
# m_inout.py  - Library for coordinate input and output
# Part of the ModeHunter package, http://modehunter.biomachina.org
#
# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#
# Request to cite published literature:
#
# When using this software in scholarly work please cite the publications(s)
# posted at http://modehunter.biomachina.org/fref.html
# 
# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#
# Legal notice:
# 
# This software is copyrighted, (c) 2009, by Joseph N. Stember and Willy Wriggers
# under the following terms:
#
# The authors hereby grant permission to use, copy, modify, and re-distribute this
# software and its documentation for any purpose, provided that existing copyright
# notices are retained in all copies and that this notice is included verbatim in
# any distributions. No written agreement, license, or royalty fee is required for
# any of the authorized uses.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT,
# INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE
# OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE
# AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING,
# BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A
# PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE IS PROVIDED ON AN "AS
# IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE
# MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
#
# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

import numpy
import sys
import copy

# global list with chemical element names
element_name = ["H", "HE", "LI", "BE", "B", "C", "N", "O", "F", "NE",
                "NA", "MG", "AL", "SI", "P", "S", "CL", "AR", "K", "CA",
                "SC", "TI", "V", "CR", "MN", "FE", "CO", "NI", "CU", "ZN"]

# global list with corresponding atom masses
element_mass = [1.008, 4.003, 6.940, 9.012, 10.810, 12.011, 14.007, 16.000, 18.998, 20.179,
                22.990, 24.305, 26.982, 28.086, 30.974, 32.060, 35.453, 39.948, 39.102, 40.080,
                44.956, 47.880, 50.942, 51.996, 54.938, 55.847, 58.933, 58.700, 63.546, 65.380]


# global PDB class with data required structure
class PDB(object):
    def __init__(self, recd="ATOM  ", serial=1, type="  ", loc="  ", alt=" ", res="    ", chain=" ", seq=1, icode=" ",
                 x=0.0, y=0.0, z=0.0, occupancy=0.0, beta=0.0, footnote=0, segid="    ", element="  ", charge="  ",
                 weight=0.0):
        self.recd = recd  # 1- 6
        self.serial = serial  # 7-11
        self.type = type  # 13-14
        self.loc = loc  # 15-16
        self.alt = alt  # 17
        self.res = res  # 18-21
        self.chain = chain  # 22
        self.seq = seq  # 23-26
        self.icode = icode  # 27
        self.x = x  # 31-38
        self.y = y  # 39-46
        self.z = z  # 47-54
        self.occupancy = occupancy  # 55-60
        self.beta = beta  # 61-66
        self.footnote = footnote  # 68-70
        self.segid = segid  # 73-76
        self.element = element  # 77-78
        self.charge = charge  # 79-80
        self.weight = weight  # mass of atom assigned by read_pdb


# functions

def m_inout_read_pdb(filename):
    "Situs 2.x style pdb parser"

    pdb_list = []
    f = open(filename, 'r')
    for line in f:
        test_recd = line[0:5]

        # if test_recd.upper().strip() == "ATOM" or test_recd.upper() == "HETATM":
        if ((test_recd.upper().strip() == "ATOM") or (test_recd.upper().strip() == "HETATM")):
            # create new atom and assign standard fields
            new_atom = PDB()
            new_atom.recd = test_recd
            try:
                new_atom.serial = int(line[4:11])
            except:
                pass
            try:
                new_atom.type = line[12:14]
            except:
                pass
            try:
                new_atom.loc = line[14:16]
            except:
                pass
            try:
                new_atom.alt = line[16]
            except:
                pass
            try:
                new_atom.res = line[17:21]
            except:
                pass
            try:
                new_atom.chain = line[21]
            except:
                pass
            try:
                new_atom.seq = int(line[22:26])
            except:
                pass
            try:
                new_atom.icode = line[26]
            except:
                pass
            try:
                new_atom.x = float(line[30:38])
            except:
                pass
            try:
                new_atom.y = float(line[38:46])
            except:
                pass
            try:
                new_atom.z = float(line[46:54])
            except:
                pass
            try:
                new_atom.occupancy = float(line[54:60])
            except:
                pass
            try:
                new_atom.beta = float(line[60:66])
            except:
                pass
            try:
                new_atom.footnote = int(line[67:70])
            except:
                pass
            try:
                new_atom.segid = line[72:76]
            except:
                pass
            try:
                new_atom.element = line[76:78]
            except:
                pass
            try:
                new_atom.charge = line[78:80]
            except:
                pass
            # compute robust Situs 2.x style mass weight and append atom
            if (new_atom.type == "QV" and new_atom.loc == "OL") or (new_atom.type == "QP" and new_atom.loc == "DB"):
                new_atom.weight = 0.0  # codebook vectors have zero mass
            elif (new_atom.type == "DE" and new_atom.loc == "NS"):
                new_atom.weight = new_atom.occupancy  # volumetric map density mass assigned from occupancy field
            elif (new_atom.type.lstrip()[0] == "H"):
                new_atom.weight = element_mass[0]  # quick hack for hydrogens, may return false positives for Hg, Hf, Ho
            elif (new_atom.type.strip in element_name):
                new_atom.weight = element_mass[element_name.index(new_atom.type.strip)]  # standard element
            elif (new_atom.type.strip()[0] in element_name):
                new_atom.weight = element_mass[
                    element_name.index(new_atom.type.strip()[0])]  # catches frequent elements, C N O P S
            else:
                # Slavica: Mass of other atoms (eg, 1H,2H,3H, 1HH1, 2HH1, 1HD2, 2HD2 etc) to be incorporated later
                # print "Warning: atom %i: unable to identify atom type %s, assigning carbon mass" % (len(pdb_list)+1,new_atom.type)
                new_atom.weight = element_mass[5]
            pdb_list.append(new_atom)

    f.close()
    return pdb_list


def m_inout_write_pdb(pdb_list, filename, remarks):
    "pdb writer, Situs 2.x convention, renumbering atoms"

    f = open(filename, 'w')
    f.write("REMARKS " + remarks + "\n")

    for i in range(len(pdb_list)):
        f.write(pdb_list[i].recd.strip()[:6].ljust(6))
        # renumber atoms, ignoring .serial
        if ((i + 1) // 100000 == 0):
            f.write("%5d" % (i + 1))
        else:
            f.write("%05d" % (i + 1 - ((i + 1) // 100000) * 100000))
        f.write(" ")
        f.write(pdb_list[i].type.strip()[:2].rjust(2))
        f.write(pdb_list[i].loc.strip()[:2].ljust(2))
        f.write(pdb_list[i].alt.strip()[:1].ljust(1))
        if (len(pdb_list[i].res) < 4):
            f.write(pdb_list[i].res.strip().rjust(3))
            f.write(" ")
        else:
            f.write(pdb_list[i].res[:4])
        f.write(pdb_list[i].chain.strip()[:1].ljust(1))
        f.write("%4d" % pdb_list[i].seq)
        f.write(pdb_list[i].icode.strip()[:1].ljust(1))
        f.write("   ")
        f.write("%8.3f" % pdb_list[i].x)
        f.write("%8.3f" % pdb_list[i].y)
        f.write("%8.3f" % pdb_list[i].z)
        f.write("%6.2f" % pdb_list[i].occupancy)
        f.write("%6.2f" % pdb_list[i].beta)
        f.write(" ")
        f.write("%3d" % pdb_list[i].footnote)
        f.write("  ")
        f.write(pdb_list[i].segid.strip()[:4].ljust(4))
        f.write(pdb_list[i].element.strip()[:2].rjust(2))
        f.write(pdb_list[i].charge.strip()[:2].rjust(2))
        f.write("\n")
    f.close()


def m_inout_write_pdb_sampled(pdb_name, filename, step, thr_mass):
    "pdb writer, Situs 2.x convention, renumbering atoms"

    f = open(filename, 'w')

    pdb_list = m_inout_read_pdb(pdb_name)

    for i in range(0, len(pdb_list), step):
        if pdb_list[i].beta > thr_mass:
            f.write(pdb_list[i].recd.strip()[:6].ljust(6))
            # renumber atoms, ignoring .serial
            if ((i + 1) // 100000 == 0):
                f.write("%5d" % (i + 1))
            else:
                f.write("%05d" % (i + 1 - ((i + 1) // 100000) * 100000))
            f.write(" ")
            f.write(pdb_list[i].type.strip()[:2].rjust(2))
            f.write(pdb_list[i].loc.strip()[:2].ljust(2))
            f.write(pdb_list[i].alt.strip()[:1].ljust(1))
            if (len(pdb_list[i].res) < 4):
                f.write(pdb_list[i].res.strip().rjust(3))
                f.write(" ")
            else:
                f.write(pdb_list[i].res[:4])
            f.write(pdb_list[i].chain.strip()[:1].ljust(1))
            f.write("%4d" % pdb_list[i].seq)
            f.write(pdb_list[i].icode.strip()[:1].ljust(1))
            f.write("   ")
            f.write("%8.3f" % pdb_list[i].x)
            f.write("%8.3f" % pdb_list[i].y)
            f.write("%8.3f" % pdb_list[i].z)
            f.write("%6.2f" % pdb_list[i].occupancy)
            f.write("%6.2f" % pdb_list[i].beta)
            f.write(" ")
            f.write("%3d" % pdb_list[i].footnote)
            f.write("  ")
            f.write(pdb_list[i].segid.strip()[:4].ljust(4))
            f.write(pdb_list[i].element.strip()[:2].rjust(2))
            f.write(pdb_list[i].charge.strip()[:2].rjust(2))
            f.write("\n")
    f.close()


def m_inout_carbon_alphas(pdb_list):
    "return 0-based indices of carbon alphas in pdb_list"

    cas = []
    for i in range(len(pdb_list)):
        if (pdb_list[i].type == " C" and pdb_list[i].loc == "A "):
            cas.append(i)
    return cas


def m_inout_import_coords(filename):
    "get x y z coords from PDB file"
    coords = numpy.array([])
    pdb_list = m_inout_read_pdb(filename)
    for i in numpy.arange(len(pdb_list)):
        coords = numpy.append(coords, [pdb_list[i].x, pdb_list[i].y, pdb_list[i].z])
    return coords


def m_inout_import_bfact(filename):
    "get Bfactor from PDB file"
    bfact = numpy.array([])
    pdb_list = m_inout_read_pdb(filename)
    for i in numpy.arange(len(pdb_list)):
        bfact = numpy.append(bfact, [pdb_list[i].beta])
    return bfact
nma/NMA_cart/0000755000175000017500000000000014147457702012330 5ustar  guestguestnma/NMA_cart/diag_arpack.f0000644000175000017500000004702713560574345014737 0ustar  guestguest      program diag_arpack
c
c "NMA calculation based on ARPACK library by Florence Tama & Osamu Miyashita (AICS).
c
c Lehoucq, R.B., Sorensen, D.C., Yang, C. (1998). ARPACK Users Guide: Solution of Large-Scale Eigenvalue Problems with Implicitly Restarted Arnoldi Methods. Philadelphia: SIAM. ISBN 978-0-89871-407-4."

c
c-----------------------------------------------------------------------
c
c     %------------------------------------------------------%
c     | Storage Declarations:                                |
c     |                                                      |
c     | The maximum dimensions for all arrays are            |
c     | set here to accommodate a problem size of            |
c     | N .le. MAXN                                          |
c     |                                                      |
c     | NEV is the number of eigenvalues requested.          |
c     |     See specifications for ARPACK usage below.       |
c     |                                                      |
c     | NCV is the largest number of basis vectors that will |
c     |     be used in the Implicitly Restarted Arnoldi      |
c     |     Process.  Work per major iteration is            |
c     |     proportional to N*NCV*NCV.                       |
c     |                                                      |
c     | You must set:                                        |
c     |                                                      |
c     | MAXNZ:  Maximum number of nonzero elements           |
c     | MAXN:   Maximum dimension of the A allowed.          |
c     | MAXNEV: Maximum NEV allowed.                         |
c     | MAXNCV: Maximum NCV allowed.                         |
c     %------------------------------------------------------%
c
      integer          maxnz, maxn, maxnev, maxncv, ldv
      parameter       (maxnz=90000000,maxn=50000,maxnev=200,maxncv=1000, 
     $                 ldv=maxn )
c
c     %--------------%
c     | Local Arrays |
c     %--------------%
c
      Double precision
     &                 v(ldv,maxncv), workl(maxncv*(maxncv+8)),
     &                 workd(3*maxn), d(maxncv,2), resid(maxn),
     &                 ax(maxn)
      logical          select(maxncv)
      integer          iparam(11), ipntr(11)

      integer          n_nz
      integer          element_i(maxnz), element_j(maxnz)
      double precision element_s(maxnz)
c     
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      character        bmat*1, which*2
      integer          ido, n, nev, ncv, lworkl, info, ierr,
     &                 j, ishfts, maxitr, mode1, nconv
      logical          rvec
      Double precision      
     &                 tol, sigma
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Double precision
     &                 zero
      parameter        (zero = 0.0D+0)
c  
c     %-----------------------------%
c     | BLAS & LAPACK routines used |
c     %-----------------------------%
c
      Double precision           
     &                 dnrm2
      external         dnrm2, daxpy
c
c     %-----------------------------%
c     | routines used |
c     %-----------------------------%
c
      Double precision matrix_tr
      integer          matrix_dim
c
c     %--------------------%
c     | Intrinsic function |
c     %--------------------%
c
      intrinsic        abs
      intrinsic        cpu_time
      real*8           sec

      namelist /inputs/ nev, ncv, tol
c     
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
c     %-------------------------------------------------%
c     | The following include statement and assignments |
c     | initiate trace output from the internal         |
c     | actions of ARPACK.  See debug.doc in the        |
c     | DOCUMENTS directory for usage.  Initially, the  |
c     | most useful information will be a breakdown of  |
c     | time spent in the various stages of computation |
c     | given by setting msaupd = 1.                    |
c     %-------------------------------------------------%
c
      include 'debug.h'
      ndigit = -3
      logfil = 6
      msgets = 0
      msaitr = 0 
      msapps = 0
      msaupd = 1
      msaup2 = 0
      mseigt = 0
      mseupd = 0
c     
c     %-------------------------------------------------%
c     | The following sets dimensions for this problem. |
c     %-------------------------------------------------%
c
      call read_matrix(n_nz, element_i,element_j,element_s)
      print *, 'number of data record', n_nz
      n = matrix_dim(n_nz, element_i, element_j, element_s)
      print *, 'dimension of matrix  ', n
      print *, 'trace of the matrix  ',
     $     matrix_tr(n_nz, element_i, element_j, element_s)
      call cpu_time(sec)
      write(*,*) 'cpu time for reading the matrix', sec

      
c
c     %-----------------------------------------------%
c     |                                               | 
c     | Specifications for ARPACK usage are set       | 
c     | below:                                        |
c     |                                               |
c     |    1) NEV = 4  asks for 4 eigenvalues to be   |  
c     |       computed.                               | 
c     |                                               |
c     |    2) NCV = 20 sets the length of the Arnoldi |
c     |       factorization                           |
c     |                                               |
c     |    3) This is a standard problem              |
c     |         (indicated by bmat  = 'I')            |
c     |                                               |
c     |    4) Ask for the NEV eigenvalues of          |
c     |       largest magnitude                       |
c     |         (indicated by which = 'LM')           |
c     |       See documentation in DSAUPD for the     |
c     |       other options SM, LA, SA, LI, SI.       | 
c     |                                               |
c     | Note: NEV and NCV must satisfy the following  |
c     | conditions:                                   |
c     |              NEV <= MAXNEV                    |
c     |          NEV + 1 <= NCV <= MAXNCV             |
c     %-----------------------------------------------%
c
c     %-----------------------------------------------%
c     |               default parameters              |
c     %-----------------------------------------------%
      nev  =  56
      ncv  = 100
      tol  = 0.0

c     %-----------------------------------------------%
c     |               read parameters                 |
c     %-----------------------------------------------%
      open(unit=20,file='diag_arpack.in', status='OLD',form='FORMATTED')
      read(unit=20,nml=inputs)
      write(*,*) 'number of eigenvalues to be computed: nev = ', nev
      write(*,*) 'length of the Arnoldi factorization:  ncv = ', ncv
      write(*,*) 'the stopping criterion:               tol = ', tol


      bmat  = 'I'
      which = 'SM'
c
c     The following condition was put by Ruben Nogales @ CNB to avoid
c     the "Error with _saupd, info = -3" problem  
c      if ( ncv .gt. n) then
c          ncv = n
c      end if
c
      if ( n .gt. maxn ) then
         print *, ' ERROR with _SSIMP: N=', n, ' is greater than MAXN '
         go to 9000
      else if ( nev .gt. maxnev ) then
         print *, ' ERROR with _SSIMP: NEV=', nev,
     $        ' is greater than MAXNEV '
         go to 9000
      else if ( ncv .gt. maxncv ) then
         print *, ' ERROR with _SSIMP: NCV=', ncv,
     $        ' is greater than MAXNCV '
         go to 9000
      end if

c
c     %-----------------------------------------------------%
c     |                                                     |
c     | Specification of stopping rules and initial         |
c     | conditions before calling DSAUPD                    |
c     |                                                     |
c     | TOL  determines the stopping criterion.             |
c     |                                                     |
c     |      Expect                                         |
c     |           abs(lambdaC - lambdaT) < TOL*abs(lambdaC) |
c     |               computed   true                       |
c     |                                                     |
c     |      If TOL .le. 0,  then TOL <- macheps            |
c     |           (machine precision) is used.              |
c     |                                                     |
c     | IDO  is the REVERSE COMMUNICATION parameter         |
c     |      used to specify actions to be taken on return  |
c     |      from DSAUPD. (See usage below.)                |
c     |                                                     |
c     |      It MUST initially be set to 0 before the first |
c     |      call to DSAUPD.                                | 
c     |                                                     |
c     | INFO on entry specifies starting vector information |
c     |      and on return indicates error codes            |
c     |                                                     |
c     |      Initially, setting INFO=0 indicates that a     | 
c     |      random starting vector is requested to         |
c     |      start the ARNOLDI iteration.  Setting INFO to  |
c     |      a nonzero value on the initial call is used    |
c     |      if you want to specify your own starting       |
c     |      vector (This vector must be placed in RESID.)  | 
c     |                                                     |
c     | The work array WORKL is used in DSAUPD as           | 
c     | workspace.  Its dimension LWORKL is set as          |
c     | illustrated below.                                  |
c     |                                                     |
c     %-----------------------------------------------------%
c
      lworkl = ncv*(ncv+8)

      info = 0
      ido = 0
c
c     %---------------------------------------------------%
c     | Specification of Algorithm Mode:                  |
c     |                                                   |
c     | This program uses the exact shift strategy        |
c     | (indicated by setting PARAM(1) = 1).              |
c     | IPARAM(3) specifies the maximum number of Arnoldi |
c     | iterations allowed.  Mode 1 of DSAUPD is used     |
c     | (IPARAM(7) = 1). All these options can be changed |
c     | by the user. For details see the documentation in |
c     | DSAUPD.                                           |
c     %---------------------------------------------------%
c
      ishfts = 1
      maxitr = 300 
      mode1  = 1
c
      iparam(1) = ishfts
      iparam(3) = maxitr
      iparam(7) = mode1
c
c     %------------------------------------------------%
c     | M A I N   L O O P (Reverse communication loop) |
c     %------------------------------------------------%
c
 10   continue
c
c        %---------------------------------------------%
c        | Repeatedly call the routine DSAUPD and take | 
c        | actions indicated by parameter IDO until    |
c        | either convergence is indicated or maxitr   |
c        | has been exceeded.                          |
c        %---------------------------------------------%
c
         call dsaupd ( ido, bmat, n, which, nev, tol, resid, 
     &                 ncv, v, ldv, iparam, ipntr, workd, workl,
     &                 lworkl, info )
c
         if (ido .eq. -1 .or. ido .eq. 1) then
c
c           %--------------------------------------%
c           | Perform matrix vector multiplication |
c           |              y <--- OP*x             |
c           | The user should supply his/her own   |
c           | matrix vector multiplication routine |
c           | here that takes workd(ipntr(1)) as   |
c           | the input, and return the result to  |
c           | workd(ipntr(2)).                     |
c           %--------------------------------------%
c
            call av(n, workd(ipntr(1)), workd(ipntr(2)),
     $           n_nz, element_i, element_j, element_s)
c
c           %-----------------------------------------%
c           | L O O P   B A C K to call DSAUPD again. |
c           %-----------------------------------------%
c
            go to 10
c
         end if 
c
c     %----------------------------------------%
c     | Either we have convergence or there is |
c     | an error.                              |
c     %----------------------------------------%
c
      if ( info .lt. 0 ) then
c
c        %--------------------------%
c        | Error message. Check the |
c        | documentation in DSAUPD. |
c        %--------------------------%
c
         print *, ' '
         print *, ' Error with _saupd, info = ', info
         print *, ' Check documentation in _saupd '
         print *, ' '
c
      else 
c
c        %-------------------------------------------%
c        | No fatal errors occurred.                 |
c        | Post-Process using DSEUPD.                |
c        |                                           |
c        | Computed eigenvalues may be extracted.    |  
c        |                                           |
c        | Eigenvectors may be also computed now if  |
c        | desired.  (indicated by rvec = .true.)    | 
c        |                                           |
c        | The routine DSEUPD now called to do this  |
c        | post processing (Other modes may require  |
c        | more complicated post processing than     |
c        | mode1.)                                   |
c        |                                           |
c        %-------------------------------------------%
c           
          rvec = .true.
c
          call dseupd ( rvec, 'All', select, d, v, ldv, sigma, 
     &         bmat, n, which, nev, tol, resid, ncv, v, ldv, 
     &         iparam, ipntr, workd, workl, lworkl, ierr )
c
c         %----------------------------------------------%
c         | Eigenvalues are returned in the first column |
c         | of the two dimensional array D and the       |
c         | corresponding eigenvectors are returned in   |
c         | the first NCONV (=IPARAM(5)) columns of the  |
c         | two dimensional array V if requested.        |
c         | Otherwise, an orthogonal basis for the       |
c         | invariant subspace corresponding to the      |
c         | eigenvalues in D is returned in V.           |
c         %----------------------------------------------%
c
          if ( ierr .ne. 0) then
c
c            %------------------------------------%
c            | Error condition:                   |
c            | Check the documentation of DSEUPD. |
c            %------------------------------------%
c
             print *, ' '
             print *, ' Error with _seupd, info = ', ierr
             print *, ' Check the documentation of _seupd. '
             print *, ' '
c
          else
c
             nconv =  iparam(5)
             do 20 j=1, nconv
c
c               %---------------------------%
c               | Compute the residual norm |
c               |                           |
c               |   ||  A*x - lambda*x ||   |
c               |                           |
c               | for the NCONV accurately  |
c               | computed eigenvalues and  |
c               | eigenvectors.  (iparam(5) |
c               | indicates how many are    |
c               | accurate to the requested |
c               | tolerance)                |
c               %---------------------------%
c
                call av(n, v(1,j), ax,
     $               n_nz, element_i, element_j, element_s)
                call daxpy(n, -d(j,1), v(1,j), 1, ax, 1)
                d(j,2) = dnrm2(n, ax, 1)
                d(j,2) = d(j,2) / abs(d(j,1))
c
 20          continue
c
c            %-----------------------------%
c            | Display computed residuals. |
c            %-----------------------------%
c
             call dmout(6, nconv, 2, d, maxncv, -6,
     &            'Ritz values and relative residuals')

c            %-----------------------------%
c            | Output vector to UNIT 11    |
c            %-----------------------------%

             do j=1, nconv
                do i=1, n
                write(11,*) v(i,j)
                end do
             end do
          end if
c
c         %-------------------------------------------%
c         | Print additional convergence information. |
c         %-------------------------------------------%
c
          if ( info .eq. 1) then
             print *, ' '
             print *, ' Maximum number of iterations reached.'
             print *, ' '
          else if ( info .eq. 3) then
             print *, ' ' 
             print *, ' No shifts could be applied during implicit',
     &                ' Arnoldi update, try increasing NCV.'
             print *, ' '
          end if      
c
          print *, ' '
          print *, ' _SSIMP '
          print *, ' ====== '
          print *, ' '
          print *, ' Size of the matrix is ', n
          print *, ' The number of Ritz values requested is ', nev
          print *, ' The number of Arnoldi vectors generated',
     &             ' (NCV) is ', ncv
          print *, ' What portion of the spectrum: ', which
          print *, ' The number of converged Ritz values is ', 
     &               nconv 
          print *, ' The number of Implicit Arnoldi update',
     &             ' iterations taken is ', iparam(3)
          print *, ' The number of OP*x is ', iparam(9)
          print *, ' The convergence criterion is ', tol
          print *, ' '
c
      end if
c
c     %---------------------------%
c     | Done with program dssimp. |
c     %---------------------------%
c
 9000 continue
c
      end
c 
c ------------------------------------------------------------------
c     matrix vector subroutine
c
c     Computes w <--- OP*v, where OP is the n*n by n*n block 
c     tridiagonal matrix
c
      subroutine av(n, v, w, n_nz, ei, ej, es)
      integer          n, n_nz
      integer          ei(n_nz), ej(n_nz)
      double precision es(n_nz)
      double precision v(n), w(n)
c     
      integer k, i, j
      
      do k = 1, n
         w(k)=0
      enddo
c$$$      print *,'w', w(1:n)
c$$$      print *,'v', v(1:n)
      do k = 1, n_nz
         i = ei(k)
         j = ej(k)
         if( i .eq. j ) then
            w(i) = w(i)+es(k)*v(i)
         else
            w(i) = w(i)+es(k)*v(j)
            w(j) = w(j)+es(k)*v(i)
         endif
      enddo

      return
      end
c
c-------------------------------------------------------------------
      subroutine read_matrix(n_nz, ei, ej, es)
c
      integer         n_nz, ei(*), ej(*)
      double precision            es(*)
      
      integer         m

c      open(UNIT=10,FILE='matrice.sdij',STATUS='OLD',FORM='UNFORMATTED')
       open(UNIT=10,FILE='matrice.sdijf',STATUS='OLD',FORM='FORMATTED')

      m=1
      do
         read(10,*,END=900) ei(m), ej(m), es(m)
c         read(10,END=900) ei(m), ej(m), es(m)
         m=m+1
      end do
 900  continue
c     finish to read data
      
      n_nz= m
      return
      end


      
      function matrix_dim( n_nz, ei, ej, es )
      integer          matrix_dim
      integer          n_nz, ei(*), ej(*)
      double precision es(*)
      
      integer          m, max

      max=0
      do m=1, n_nz
         if( max .lt. ei(m) ) then
            max = ei(m)
         endif
         if( max .lt. ej(m) ) then
            max = ej(m)
         endif
      enddo
      matrix_dim = max

      end

      function matrix_tr( n_nz, ei, ej, es )
      double precision matrix_tr
      integer          n_nz, ei(*), ej(*)
      double precision es(*)
      
      integer          m, max
      double precision tr

      tr=0
      do m=1, n_nz
         if( ei(m) .eq. ej(m) ) then
            tr = tr + es(m)
         endif
      enddo
      matrix_tr = tr

      end

      
nma/NMA_cart/Makefile0000644000175000017500000000027513560574345013775 0ustar  guestguestFC=gfortran
FFLAGS=-O3

all:nma_diag_arpack

nma_diag_arpack:diag_arpack.o
	$(FC) $(FFLAGS) $(LDFLAGS) -m64 -o $@ diag_arpack.o -larpack -lblas -llapack
.f.o:
	$(FC) $(FFLAGS) -c $*.f -m64
nma/NMA_cart/debug.h0000644000175000017500000000135113560574345013570 0ustar  guestguestc
c\SCCS Information: @(#) 
c FILE: debug.h   SID: 2.3   DATE OF SID: 11/16/95   RELEASE: 2 
c
c     %---------------------------------%
c     | See debug.doc for documentation |
c     %---------------------------------%
      integer  logfil, ndigit, mgetv0,
     &         msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd,
     &         mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd,
     &         mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd
      common /debug/ 
     &         logfil, ndigit, mgetv0,
     &         msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd,
     &         mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd,
     &         mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd
nma/nma_reformatForElNemo.sh0000755000175000017500000000047613561777223015475 0ustar  guestguest#!/bin/bash

dirmodes=modes
out=diag_arpack.eigenfacs
headerfile=header.txt
end=$1

echo " VECTOR    1       VALUE  2.2318E-08" >  $headerfile
echo " -----------------------------------" >> $headerfile
rm -f $out

i=1
while [ $i -le $end ]
do
cat $headerfile $dirmodes/vec.$i >> $out
((i=i+1))
done

rm -f $headerfile
nma/nma_animate_atoms.py0000775000175000017500000001416613711226210014727 0ustar  guestguest#!/usr/bin/env python3
# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#
# animate.py  - oscillating animation of normal modes
# Modified script from the ModeHunter package, http://modehunter.biomachina.org
#
# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#
# Request to cite published literature:
#
# When using this software in scholarly work please cite the publications(s)
# posted at http://modehunter.biomachina.org/fref.html
# 
#
# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


import numpy 
import pickle
import sys
import string
import copy
from m_inout_Bfact import *

def compute_animation(pdb_name,pickle_name,start_mode,end_mode,amplitude,outname,numframes):
    "top level function for writing animated traectories in PDB format"
 
    # process the input files, sanity checks
    f = open(pickle_name, 'rb')
    eigvecs = pickle.load(f)
    f.close()
    s1,s2 = numpy.shape(eigvecs)
    s2=s2-1
    #assert s1 / 3.0 == s1 // 3.0, "animate> Error: pickle length not a multiple of 3"
    #assert s2 / 3.0 == s2 // 3.0, "animate> Error: pickle width not a multiple of 3"
    print('animate> Mode pickle file %s read, containing %i modes for %i atoms' % (pickle_name, s1, s2 / 3))

    #get x y z coords from PDB file
    coords = numpy.array([])
    pdb_list = m_inout_read_pdb(pdb_name)
    for i in numpy.arange(len(pdb_list)):
        coords = numpy.append(coords,[pdb_list[i].x,pdb_list[i].y,pdb_list[i].z])

    natoms = len(coords)/3
    print(natoms)


    assert natoms == s2/3, "animate> Error: number of atoms in PDB does not match input pickle number of columns"
    #assert s1 > 6, "animate> Error: pickle file contains insufficient number of modes"
    if start_mode <= 0:
        print("animate> Did not recognize start mode index, reset to 7")
        start_mode = 7
    if start_mode > s1:
        print("animate> Start mode index set to max possible value, %i" % s1)
        start_mode = s1
    if end_mode < start_mode:
        print("animate> Did not recognize end mode index, reset to %i" % start_mode)
        end_mode = start_mode
    if end_mode > s1:
        print("animate> End mode index set to max possible value, %i" % s1)
        end_mode = s1

    # prepare a list of elongations
    elongation = numpy.array([])
    for i in numpy.arange(numframes):
        elongation = numpy.append(elongation,amplitude * numpy.math.cos(i*(2*numpy.math.pi)/numframes))

    # create animations for selected range of modes
    nummodes = end_mode - start_mode + 1
    animations = numpy.zeros((nummodes,s2,numframes))
    for i in numpy.arange(nummodes):
        for j in numpy.arange(s2):
            for k in numpy.arange(int(numframes)):
                animations[i][j][k] = coords[j]+float(eigvecs[i+start_mode-1][j])*elongation[k]

        # output the animations
    for i in numpy.arange(nummodes):
        f_name = outname + ('_%03d' % (i+start_mode)) + '.pdb'
        print("animate> Writing %i steps of animation to file %s" % (numframes, f_name))
        f=open(f_name,'w')
        for k in numpy.arange(numframes):
            inodenum = 0
            for j in numpy.arange(0,int(3*natoms),3):
                f.write(pdb_list[inodenum].recd.strip()[:6].ljust(6))
                # renumber atoms, ignoring .serial
                if ((inodenum+1)//100000 == 0):
                    f.write("%5d" % (inodenum+1))
                else:
                    f.write("%05d" % (inodenum+1-((inodenum+1)//100000)*100000))
                f.write(" ")
                f.write(pdb_list[inodenum].type.strip()[:2].rjust(2))
                f.write(pdb_list[inodenum].loc.strip()[:2].ljust(2))
                f.write(pdb_list[inodenum].alt.strip()[:1].ljust(1))
                if (len(pdb_list[inodenum].res)<4):
                    f.write(pdb_list[inodenum].res.strip().rjust(3))
                    f.write(" ")
                else:
                    f.write(pdb_list[inodenum].res[:4])
                f.write(pdb_list[inodenum].chain.strip()[:1].ljust(1))
                f.write("%4d" % pdb_list[inodenum].seq)
                f.write(pdb_list[inodenum].icode.strip()[:1].ljust(1))
                f.write("   ")
                f.write('%8.3f' % animations[i][j][k])
                f.write('%8.3f' % animations[i][j+1][k])
                f.write('%8.3f' % animations[i][j+2][k])
                f.write("%6.2f" % pdb_list[inodenum].occupancy)
                f.write("%6.2f" % pdb_list[inodenum].beta)
                f.write(" ")
                f.write("%3d" % pdb_list[inodenum].footnote)
                f.write("  ")
                f.write(pdb_list[inodenum].segid.strip()[:4].ljust(4))
                f.write(pdb_list[inodenum].element.strip()[:2].rjust(2))
                f.write(pdb_list[inodenum].charge.strip()[:2].rjust(2))
                f.write("\n")
                inodenum += 1
            f.write('TER')
            f.write('\n')
            f.write('ENDMDL')
            f.write('\n')
        f.close()
    print("animate> All done")

# Main
  
if __name__ == '__main__':
    if len(sys.argv) < 7 or len(sys.argv) > 8:
        print('Usage: ./animate.py inpdb inpickle start end amplitude outname steps')
        print(' ')
        print('Input:')
        print('  inpdb:       PDB file containing N atoms')
        print('  inpickle:    Existing python pickle file containing 3M modes for the N atoms')
        print('  start:       User-specified start index of desired mode range (1 <= start <= 3M)')
        print('  end:         User-specified end index of desired mode range (start <= end <= 3M)')
        print('  amplitude:   Mode amplitude as root-mean-square deviation from inpdb (in Angstrom)')
        print('  outname:     User-defined text string for output file names, see below')
        print('  steps:       User-defined number of frames saved in output files below')
        print(' ')
        print('Output:')
        print('  outname_#.pdb: Oscillating trajectories in PDB format corresponding to mode range')
    else:
        compute_animation(sys.argv[1],sys.argv[2],int(sys.argv[3]),int(sys.argv[4]),float(sys.argv[5]),sys.argv[6],int (sys.argv[7]))
    sys.exit()
nma/nma_animate.py0000775000175000017500000001123313711226210013514 0ustar  guestguest#!/usr/bin/env python3
# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#
# animate.py  - oscillating animation of normal modes
# Modified script from the ModeHunter package, http://modehunter.biomachina.org
#
# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#
# Request to cite published literature:
#
# When using this software in scholarly work please cite the publications(s)
# posted at http://modehunter.biomachina.org/fref.html
# 
#
# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
import numpy 
import pickle
import sys
import string
import copy
from .m_inout_Bfact import *

def compute_animation(pdb_name,pickle_name,start_mode,end_mode,amplitude,outname,numframes,step,thr_mass):
	"top level function for writing animated traectories in PDB format"
 
	# process the input files, sanity checks
	f = open(pickle_name, 'r')
	eigvecs = pickle.load(f)
	f.close()
	s1,s2 = numpy.shape(eigvecs)
	s2=s2-1
	#assert s1 / 3.0 == s1 // 3.0, "animate> Error: pickle length not a multiple of 3"
	#assert s2 / 3.0 == s2 // 3.0, "animate> Error: pickle width not a multiple of 3"
	print('animate> Mode pickle file %s read, containing %i modes for %i atoms' % (pickle_name, s1, s2 / 3))

	bfact = m_inout_import_bfact(pdb_name)

	coords = m_inout_import_coords(pdb_name)
	natoms = len(coords)/3
	assert natoms == s2/3, "animate> Error: number of atoms in PDB does not match input pickle number of columns"
	#assert s1 > 6, "animate> Error: pickle file contains insufficient number of modes"
	if start_mode <= 0:
		print("animate> Did not recognize start mode index, reset to 7")
		start_mode = 7
	if start_mode > s1:
		print("animate> Start mode index set to max possible value, %i" % s1)
		start_mode = s1
	if end_mode < start_mode:
		print("animate> Did not recognize end mode index, reset to %i" % start_mode)
		end_mode = start_mode
	if end_mode > s1:
		print("animate> End mode index set to max possible value, %i" % s1)
		end_mode = s1

	# prepare a list of elongations
	elongation = numpy.array([])
	for i in numpy.arange(numframes):
		elongation = numpy.append(elongation,amplitude * numpy.math.cos(i*(2*numpy.math.pi)/numframes))

	# create animations for selected range of modes
	nummodes = end_mode - start_mode + 1
	animations = numpy.zeros((nummodes,s2,numframes))
	for i in numpy.arange(nummodes):
		print("animate> Computing %i steps of animation of mode %i" % (numframes, i + start_mode))
		for j in numpy.arange(s2):
			for k in numpy.arange(numframes):
				animations[i][j][k] = coords[j]+float(eigvecs[i+start_mode-1][j])*elongation[k]

	# output the animations
	for i in numpy.arange(nummodes):
		f_name = outname + ('_%03d' % (i+start_mode)) + '.pdb'
		print("animate> Writing %i steps of animation to file %s" % (numframes, f_name))
		f=open(f_name,'w')
		for k in numpy.arange(numframes):
			inodenum = 0
			index_atom_accept = 0
			for j in numpy.arange(0,3*natoms,3*step):
				inodenum += 1
				if bfact[inodenum-1] > thr_mass:
					index_atom_accept += 1
					f.write('ATOM  ')
					f.write('%5s' % index_atom_accept)
					f.write(' QPDB')
					f.write(' QPDB')
					f.write('%5s    ' % index_atom_accept)
					f.write('%8.3f' % animations[i][j][k])
					f.write('%8.3f' % animations[i][j+1][k])
					f.write('%8.3f' % animations[i][j+2][k])
					f.write('%6.2f' % 1.00)
					f.write('%6.2f' % bfact[inodenum-1])
					f.write('\n')
			f.write('TER')
			f.write('\n')
			f.write('ENDMDL')
			f.write('\n')
		f.close()
	print("animate> All done")

# Main
  
if __name__ == '__main__':
	if len(sys.argv) < 9 or len(sys.argv) > 10:
		print('Usage: ./nma_animate.py pdb_name pickle_name start_mode end_mode amplitude outname numframes step thr_mass')
		print(' ')
		print('Input:')
		print('  inpdb:       PDB file containing N atoms')
		print('  inpickle:    Existing python pickle file containing 3M modes for the N atoms')
		print('  start:       User-specified start index of desired mode range (1 <= start <= 3M)')
		print('  end:         User-specified end index of desired mode range (start <= end <= 3M)')
		print('  amplitude:   Mode amplitude as root-mean-square deviation from inpdb (in Angstrom)')
		print('  outname:     User-defined text string for output file names, see below')
		print('  step:     Step for reducing the number of atoms')
		print('  massthr:     Threshold on atom mass for reducing the number of atoms')
		print(' ')
		print('Output:')
		print('  outname_#.pdb: Oscillating trajectories in PDB format corresponding to mode range')
	else:
		compute_animation(sys.argv[1],sys.argv[2],int(sys.argv[3]),int(sys.argv[4]),float(sys.argv[5]),sys.argv[6],int(sys.argv[7]),int(sys.argv[8]),float(sys.argv[9]))
	sys.exit()



nma/nma_animate_pseudoatoms.py0000775000175000017500000001240113711226210016135 0ustar  guestguest#!/usr/bin/env python3
# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#
# animate.py  - oscillating animation of normal modes
# Modified script from the ModeHunter package, http://modehunter.biomachina.org
#
# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#
# Request to cite published literature:
#
# When using this software in scholarly work please cite the publications(s)
# posted at http://modehunter.biomachina.org/fref.html
# 
#
# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


import numpy 
import pickle
import sys
import string
import copy
from m_inout_Bfact import *

def compute_animation(pdb_name,pickle_name,start_mode,end_mode,amplitude,outname,numframes,step,thr_mass):
    "top level function for writing animated traectories in PDB format"
 
    # process the input files, sanity checks
    #f = open(pickle_name, 'r')
    f = open(pickle_name, 'rb')
    eigvecs = pickle.load(f)
    f.close()
    s1,s2 = numpy.shape(eigvecs)
    s2=s2-1
    #assert s1 / 3.0 == s1 // 3.0, "animate> Error: pickle length not a multiple of 3"
    #assert s2 / 3.0 == s2 // 3.0, "animate> Error: pickle width not a multiple of 3"
    print('animate> Mode pickle file %s read, containing %i modes for %i atoms' % (pickle_name, s1, s2 / 3))

    bfact = m_inout_import_bfact(pdb_name)
    coords = m_inout_import_coords(pdb_name)
    natoms = len(coords)/3
    assert natoms == s2/3, "animate> Error: number of atoms in PDB does not match input pickle number of columns"
    #assert s1 > 6, "animate> Error: pickle file contains insufficient number of modes"
    if start_mode <= 0:
        print("animate> Did not recognize start mode index, reset to 7")
        start_mode = 7
    if start_mode > s1:
        print("animate> Start mode index set to max possible value, %i" % s1)
        start_mode = s1
    if end_mode < start_mode:
        print("animate> Did not recognize end mode index, reset to %i" % start_mode)
        end_mode = start_mode
    if end_mode > s1:
        print("animate> End mode index set to max possible value, %i" % s1)
        end_mode = s1

    # prepare a list of elongations
    elongation = numpy.array([])
    for i in numpy.arange(numframes):
        elongation = numpy.append(elongation,amplitude * numpy.math.cos(i*(2*numpy.math.pi)/numframes))

    # create animations for selected range of modes
    nummodes = end_mode - start_mode + 1
    animations = numpy.zeros((nummodes,s2,numframes))
    for i in numpy.arange(nummodes):
        print("animate> Computing %i steps of animation of mode %i" % (numframes, i + start_mode))
        for j in numpy.arange(s2):
            for k in numpy.arange(numframes):
                animations[i][j][k] = coords[j]+float(eigvecs[i+start_mode-1][j])*elongation[k]

    # output the animations
    for i in numpy.arange(nummodes):
        f_name = outname + ('_%03d' % (i+start_mode)) + '.pdb'
        print("animate> Writing %i steps of animation to file %s" % (numframes, f_name))
        f=open(f_name,'w')
        for k in numpy.arange(numframes):
            inodenum = 0
            index_atom_accept = 0
            for j in numpy.arange(0,int(3*natoms),int(3*step)):
                inodenum += 1
                if bfact[inodenum-1] > thr_mass:
                    index_atom_accept += 1
                    f.write('ATOM  ')
                    f.write('%5s' % index_atom_accept)
                    f.write(' QPDB')
                    f.write(' QPDB')
                    f.write('%5s    ' % index_atom_accept)
                    f.write('%8.3f' % animations[i][j][k])
                    f.write('%8.3f' % animations[i][j+1][k])
                    f.write('%8.3f' % animations[i][j+2][k])
                    f.write('%6.2f' % 1.00)
                    f.write('%6.2f' % bfact[inodenum-1])
                    f.write('\n')
            f.write('TER')
            f.write('\n')
            f.write('ENDMDL')
            f.write('\n')
        f.close()
    print("animate> All done")


# Main
  
if __name__ == '__main__':
    if len(sys.argv) < 9 or len(sys.argv) > 10:
        print('Usage: ./nma_animate.py pdb_name pickle_name start_mode end_mode amplitude outname numframes step thr_mass')
        print(' ')
        print('Input:')
        print('  inpdb:       PDB file containing N atoms')
        print('  inpickle:    Existing python pickle file containing 3M modes for the N atoms')
        print('  start:       User-specified start index of desired mode range (1 <= start <= 3M)')
        print('  end:         User-specified end index of desired mode range (start <= end <= 3M)')
        print('  amplitude:   Mode amplitude as root-mean-square deviation from inpdb (in Angstrom)')
        print('  outname:     User-defined text string for output file names, see below')
        print('  step:     Step for reducing the number of atoms')
        print('  massthr:     Threshold on atom mass for reducing the number of atoms')
        print(' ')
        print('Output:')
        print('  outname_#.pdb: Oscillating trajectories in PDB format corresponding to mode range')
    else:
        compute_animation(sys.argv[1],sys.argv[2],int(sys.argv[3]),int(sys.argv[4]),float(sys.argv[5]),sys.argv[6],int(sys.argv[7]),int(sys.argv[8]),float(sys.argv[9]))
    sys.exit()



nma/nma_reformat_vector.pl0000755000175000017500000000101613560574345015277 0ustar  guestguest#!/usr/bin/perl -w

@ARGV==2 or print "usage: reformat_vector.pl natom org_vector\n";

$natom = $ARGV[0];
$orgvec = $ARGV[1];

open(IN,$orgvec) or die;

$clm=0;
$row=0;
$vec=1;
open(OUT,">vec.$vec") or die;
while(){
    if( @F == 0 ){
	$_=<IN>;
	defined $_ or exit;
	chomp;
	@F = split;
    }

    if($row==$natom){
	$vec++;
	open(OUT,">vec.$vec") or die;
	$row=0;
    }
    
    $a = shift(@F);
    
    print OUT $a;
    if($clm==0 or $clm==1){
	print OUT " ";
	$clm++;
    }else{
	print OUT "\n";
	$clm=0;
	$row++;
    }
}
nma/nma_reformatForElNemo.csh0000755000175000017500000000057613560574345015640 0ustar  guestguest#!/usr/bin/env csh

set dirmodes = modes
set out = diag_arpack.eigenfacs
set headerfile = header.txt
set end = $1

echo " VECTOR    1       VALUE  2.2318E-08" >  $headerfile
echo " -----------------------------------" >> $headerfile
rm -f $out

set i = 0
beginloop:

if ($i < $end) then
@ i = $i + 1

cat $headerfile $dirmodes/vec.$i >> $out
goto beginloop
endif

rm -f $headerfile
nma/ElNemo/0000755000175000017500000000000014147457660012066 5ustar  guestguestnma/ElNemo/pdbmat_aux.f0000644000175000017500000016062614030637474014366 0ustar  guestguest      program pdbmat
      implicit none
      integer natmax, nresmx, nvoismx
 
   
      parameter( NATMAX=250000 )
      parameter( NRESMX=250000 )
      parameter( NVOISMX=1000000 )
    

c     YHS-Nov-1996: Version 1.00.
c     Versions released at http://ecole-modelisation.free.fr/modes.html
c     YHS-Mar-2001: Version 3.31. 
c     YHS-Feb-2004: Version 3.50. 
c     YHS-Feb-2008: Version 3.73. 
c     Version used by the ELNEMO Web site (http://www.elnemo.org):
c     YHS-Feb-2004: Version 3.46.
c
      integer nmotsmax, ntopmax
      parameter(ntopmax=10*natmax,nmotsmax=100)
 
      integer fatres(nresmx+1), 
     .        i, idmax, idres(nresmx), ii, imax, imin, ires, 
     .        iresat(natmax), iseed, ivois(nvoismx),
     .        j, jangle(ntopmax), jat, jbond(ntopmax), jdihe(ntopmax), 
     .        jj, jsomang(ntopmax), jvois(nvoismx), 
     .        k, kcom, kk, klist, 
     .        l, ll, lmot, lnom, lnomlst, lnommls, lnommtx, lnompdb, 
     .        lnomvmd,
     .        namax, namin, nangle(ntopmax), nangles, natom, 
     .        nbig, nbmax, nbmin, nbond(ntopmax), nbonds, ndat, 
     .        ndihe(ntopmax), ndihs, nl, nmax, nmin, nmots, nntr, 
     .        nnzero, nres, nunit, nunknown, nvois, nvoisat(natmax), 
     .        prtlev, uninp, unlst, unmol, unout, unpdb, unrsd, unvmd
      double precision cutbnd, cutoff, ddf, der2(3,3*natmax), 
     .        dist, dist2, dmax, dmin, dmoy, drms, 
     .        elemnt, elmax, fvois(natmax), 
     .        kangle, kbond, kdihe, kfce, kij, knonb, kvois(natmax),
     .        levelshft, massat(natmax), nmoy, nrms,
     .        random, rave, rbig, rdev, rinput, rkh, rmax, rmin, rsmall, 
     .        rx, ry, rz, 
     .        trace, unknown, xat(natmax), yat(natmax), zat(natmax) 
      logical qbinary, qerror, qexist, qfread, qinter, qlist, 
     .        qmasse, qmtx, qok, qpdb, qvois(natmax)
      character atonam(natmax)*4, cformat*32, csep*1, cstatus*32, 
     .        lign80*80, motinp*80, mots(nmotsmax)*132, 
     .        nomfich*64, nomlst*64, nommls*64, nommtx*64, nompdb*64, 
     .        nomvmd*64,
     .        program*8, progrer*11, progrwn*11, 
     .        residus_standards*132, residus_stshort*21, 
     .        resnam(natmax)*4, segid(natmax)*4, ssunam(natmax)*1, 
     .        ssusel*1, typbond*80, typmas*80, typout*80, version*32
      parameter(rbig=1e10,rsmall=1e-10,unknown=9999.d9)
c.......................................................................
      version=' Version 3.73, February 2008.'
c.......................................................................
      idmax=21
      residus_standards='   ILE PHE TRP LEU CYS VAL MET TYR ALA HIS '//
     .                     'GLY THR SER PRO ARG GLN ASN ASP GLU LYS '
      residus_stshort='IFWLCVMYAHGTSPRQNDEKX'
 
      program=' Pdbmat>'
      progrer='%Pdbmat-Er>'
      progrwn='%Pdbmat-Wn>'

      write(6,'(2A)') program,
     .' Computes the Hessian matrix, using an Elastic Network Model.'
      write(6,'(2A)') program,version

c     ===============================================
c     Ouverture et Lecture du fichier d'instructions:
c     ===============================================
 
c     Default values:
      nompdb='pdbmat.ent'
      cutoff=10.d0
c     Neighbor list:
      nomlst='NONE'
      qlist=.false.
c     Typical distance for Hinsen's weigth:
c    (negative value means 1/rkh=0)
      rkh=-1.d0
      qfread=.false.
      nommls='NONE'
      nomvmd='NONE'
      typmas='CONS'
      qmasse=.false.
      knonb=1.0d0
c     Topological terms (like in ref.6):
      typbond='NONE'
c     Distance-cutoff value for defining covalent (chemical) bonds:
      cutbnd=4.0d0
      kangle=0.0d0
      kbond=1000.0d0
      kdihe=0.0d0
c     Others:
      typout='  FREE'
      qmtx=.false.
      qbinary=.false.
      prtlev=0
      levelshft=1e-8
c     Used only with a levelshift, to add some noise (not useful ?).
      iseed=27041961

      nunit=10
      uninp=nunit
      nunit=nunit+1
      nomfich='pdbmat.dat'
      cformat="FORMATTED"
      cstatus="old"
      call openam(nomfich,cformat,cstatus,uninp,.false.,
     .     qinter,qexist)
      if (qinter.or..not.qexist) then 
          write(6,'(/2A/(2A))') progrwn,
     .  ' No pdbmat.dat command file found.',
     .    progrwn,' Defaults assumed for all options. ',
     .    progrwn,' See the pdbmat.dat_run file if you need an example.'
          goto 110
      else
          write(6,'(/2A)') program,
     .  ' Options to be read in pdbmat.dat file.'
      endif
 
 50   continue
      read(uninp,'(A)',end=100) lign80
 
      kcom=index(lign80,'!')
      k=index(lign80,'=') 
      motinp=' '
      if (k.gt.0.and.(kcom.le.0.or.kcom.gt.k)) then 
          motinp=lign80(1:k)
      else
          if (k.le.0.and.kcom.gt.1) then
          write(6,'(/2A/A)') progrwn,
     .  ' No separator (=) in command ligne:',
     .    lign80
          write(6,'(2A)') progrwn,' This ligne is skipped.'
          endif
          goto 50
      endif
      call mintomaj(motinp)

      kcom=index(lign80(k+1:80),'!')
      if (kcom.gt.0) lign80(k+kcom:80)=' '
      klist=index(lign80(k+1:80),'?')

      if (index(motinp,' FILENAME').gt.0.or.
     .    index(motinp,' SCRIPT').gt.0) then 
          if (index(motinp,'MATRI').gt.0) then
              nommtx=lign80(k+1:80)
              qmtx=.true.
          elseif (index(motinp,'LIST ').gt.0.or.
     .            index(motinp,'NEIGH').gt.0) then
              nomlst=lign80(k+1:80)
              qlist=.true.
          elseif (index(motinp,'MOLS').gt.0) then
              nommls=lign80(k+1:80)
          elseif (index(motinp,'VMD').gt.0) then
              nomvmd=lign80(k+1:80)
          else
              nompdb=lign80(k+1:80)
          endif
      else if (index(motinp,' DEFINITION').gt.0) then
          typbond=lign80(k+1:80)
          call mintomaj(typbond)
          call stringcl(typbond,lnom)
          if (typbond(1:3).eq.'ALL') then 
              typbond=' ALL'
          else if (typbond(1:3).eq.'NON') then 
              typbond='NONE'
          else if (typbond(1:3).eq.'CON') then
              typbond='CONSECUTIF'
          else
              write(6,'(/3A)') progrwn,' Bond definition :',
     .        typbond(1:4)
              if (klist.le.0)
     .        write(6,'(2A)') progrwn,' This is not a known keyword.'
              write(6,'(2A)') progrwn,
     .      ' Valid options are: NONe, ALL, CONsecutive.'
              write(6,'(A)') ' Default assumed.'
              typbond='NONE'
          endif
      else if (index(motinp,'MASS').gt.0) then
          typmas=lign80(k+1:80)
          call mintomaj(typmas)
          call stringcl(typmas,lnom)
          if (typmas(1:3).eq.'PDB'.or.typmas(1:3).eq.'COO') then
              qmasse=.true.
              typmas='COOR'
          else if (typmas(1:3).ne.'CON') then
              write(6,'(/3A)') progrwn,' Origin of mass values :',
     .        typmas(1:3)
              if (klist.le.0)
     .        write(6,'(2A)') progrwn,' This is not a known keyword.'
              write(6,'(2A)') progrwn,
     .      ' Valid options are: CONstant, COOr, PDB.'
              write(6,'(A)') ' Default assumed.'
              qmasse=.false.
              typmas='CONS'
          endif
      else if (index(motinp,'FORMAT').gt.0) then
          typout=lign80(k+1:80)
          call mintomaj(typout)
          call stringcl(typout,lnom)
          if (typout(1:1).eq.'B'.or.typout(1:1).eq.'U') then
              qbinary=.true.
              typout='BINARY'
          else if (typout(1:1).ne.'F') then
              write(6,'(/3A)') progrwn,' Kind of matrix format :',
     .        typout(1:1)
              if (klist.le.0)
     .        write(6,'(2A)') progrwn,' This is not a known keyword.'
              write(6,'(2A)') progrwn,
     .      ' Valid options are: Free, Binary, Formatted, Unformatted.'
              write(6,'(A)') ' Default assumed.'
              qbinary=.false.
              typout='  FREE'
          else
              qbinary=.false.
              typout='  FREE'
          endif
      else 
          qok=.false.
          read(lign80(k+1:80),*,end=90,err=90) rinput
          if (index(motinp,'SHIFT ').gt.0) then 
               qok=.true.
               levelshft=rinput
          else if (index(motinp,'CUTOF').gt.0.or.
     .             index(motinp,'DISTANCE').gt.0) then
               qok=.true.
               cutoff=rinput
          else if (index(motinp,'HINSEN').gt.0) then
               qok=.true.
               rkh=rinput
          else if (index(motinp,'INTERAC').gt.0) then
               if (index(motinp,' FORCE ').gt.0.or.
     .             index(motinp,' CONST').gt.0) then
                   qok=.true.
                   knonb=rinput
               endif
               if (index(motinp,' CUTOF').gt.0.or.
     .             index(motinp,' DIST').gt.0) then
                   qok=.true.
                   cutoff=rinput
               endif 
          else if (index(motinp,'BOND').gt.0.and.
     .        (index(motinp,' FORCE ').gt.0.or.
     .         index(motinp,' CONST').gt.0)) then
               qok=.true.
               kbond=rinput
          else if (index(motinp,' LENGTH').gt.0) then
               qok=.true.
               cutbnd=rinput
          else if (index(motinp,'PRINT').gt.0) then
               qok=.true.
               prtlev=int(rinput)
          else if (index(motinp,'ANGLE').gt.0) then
               if (index(motinp,' FORCE ').gt.0.or.
     .             index(motinp,' CONST').gt.0) then
                   qok=.true.
                   kangle=rinput
               endif
          else if (index(motinp,'DIHE').gt.0) then
               if (index(motinp,' FORCE ').gt.0.or.
     .             index(motinp,' CONST').gt.0) then
                   qok=.true.
                   kdihe=rinput
               endif
          endif
  90      continue
          if (.not.qok) then
               write(6,'(/2A/A)') progrwn,
     .       ' No known or incomplete set of keywords in ligne:',
     .         motinp
               write(6,'(2A)') progrwn,
     .       ' This command ligne is skipped.'
          endif
      endif
      goto 50
 
 100  continue
      close(uninp)
 110  continue

      call stringcl(nompdb,lnompdb)
      call stringcl(nomlst,lnomlst)
      call stringcl(nommls,lnommls)
      call stringcl(nomvmd,lnomvmd)
      if (nomlst.eq.'none'.or.nomlst.eq.'NONE') qlist=.false.
      if (nommls.eq.'none') nommls='NONE'
      if (nomvmd.eq.'none') nomvmd='NONE'
      
      if (.not.qmtx) then
      if (qbinary) then
        nommtx="pdbmat.sdijb"
      else
        nommtx="pdbmat.sdijf"
      endif
      endif
      call stringcl(nommtx,lnommtx)

c     Resume des commandes:
c     ---------------------

      write(6,'(/3A)') program,' Coordinate filename     = ',
     .      nompdb(1:lnompdb)
      if (qlist) then
      write(6,'(3A)') program,' Neighbor-list filename  = ',
     .      nomlst(1:lnomlst)
      else
      write(6,'(/2A,F10.2)') program,
     .        ' Distance cutoff         = ',cutoff
      endif
      if (rkh.gt.0.d0)
     .write(6,'(8X,A,F10.2)') " Hinsen's typical range  = ",rkh
      write(6,'(A,F10.2)') 
     .'         Force constant          = ',knonb
      if (typbond.ne.'NONE') then
      write(6,'(A,6X,A)') 
     .'         Kind of bond definition = ',typbond(1:4)
      write(6,'(A,F10.2)') 
     .'         Maximum bond length     = ',cutbnd,
     .'         Bond force constant     = ',kbond,
     .'         Angle force constant    = ',kangle,
     .'         Dihedral force constant = ',kdihe
      endif
      write(6,'(A,6X,A)') 
     .'         Origin of mass values   = ',typmas(1:4)
      write(6,'(3A)') program,' Matrix filename         = ',
     .      nommtx(1:lnommtx)
      if (prtlev.gt.0) then
      write(6,'(2A,1PG10.1)') program,
     .        ' Levelshift              = ',levelshft
      write(6,'(A,3X,I7)') 
     .'         PRINTing level          = ',prtlev
      endif
      if (nommls.ne.'NONE')
     .write(6,'(3A)') program,' Molscript filename      = ',
     .      nommls(1:lnommls)
      if (nomvmd.ne.'NONE')
     .write(6,'(3A)') program,' VMD script filename     = ',
     .      nomvmd(1:lnomvmd)

c     Sauvegarde du fichier de commandes complet:
c     -------------------------------------------

      uninp=nunit
      nunit=nunit+1
      nomfich='pdbmat.dat_run'
      cformat="FORMATTED"
      cstatus="ove"
      call openam(nomfich,cformat,cstatus,uninp,.false.,
     .     qinter,qexist)

c     Pour etre plus clair:
      if (typbond.eq.'NONE') then
          cutbnd=0.d0
          kbond=0.d0
          kangle=0.d0
          kdihe=0.d0
      endif
      if (qlist) cutoff=-1

      write(uninp,'(2A)') 
     .'! This file can be modified and used as a command file',
     .' (named pdbmat.dat) for pdbmat.'
      write(uninp,'(2A)') ' Coordinate FILENAME        = ',
     .      nompdb(1:lnompdb)
      write(uninp,'(2A)') ' MATRIx FILENAME            = ',
     .      nommtx(1:lnommtx)
      write(uninp,'(A,F10.3,A)') ' INTERACtion DISTance CUTOF = ',
     .      cutoff,' ! For defining the list of interacting atoms.'
      write(uninp,'(A,F10.3,A)') ' INTERACtion FORCE CONStant = ',
     .      knonb,' ! For specifying frequency units.'
      if (prtlev.gt.0.or.rkh.gt.0.d0)
     .write(uninp,'(A,F10.3,A)') " HINSEN's typical range     = ",
     .      rkh,' ! Force constant weighting (if negative: none).'
      if (prtlev.gt.0.or.nomlst(1:lnomlst).ne.'NONE')
     .write(uninp,'(3A)') ' NEIGHbor-list FILENAME     = ',
     .      nomlst(1:lnomlst),
     .  ' ! For defining this list yourself.'
      write(uninp,'(A,6X,2A)') ' Origin of MASS values      = ',
     .      typmas(1:4),' ! CONstant, or from COOrdinate file.'
      write(uninp,'(A,8X,I2,A)') ' Output PRINTing level      = ',
     .      prtlev,' ! =1: more detailled. =2: debug level.'
c     Not often used:
      if (prtlev.gt.0.or.nommls(1:lnommls).ne.'NONE') 
     .write(uninp,'(3A)') ' MOLScript command FILEname = ',
     .      nommls(1:lnommls),
     .  ' ! To draw the network with Molscript.'
      if (prtlev.gt.0.or.nomvmd(1:lnomvmd).ne.'NONE') 
     .write(uninp,'(3A)') ' VMD command FILEname       = ',
     .      nomvmd(1:lnomvmd),
     .  ' ! vmd -e this-file (to visualize the network with VMD).'
c     Rarely used:
      if (prtlev.gt.0.or.typbond.ne.'NONE') then
      write(uninp,'(A,6X,2A)') ' Bond DEFINITION            = ',
     .      typbond(1:4),' ! NONe, ALL, or between CONsecutive atoms.'
      write(uninp,'(A,F10.3)') ' Maximum bond LENGTH        = ',cutbnd
      write(uninp,'(A,F10.3)') ' BOND FORCE CONStant        = ',kbond
      write(uninp,'(A,F10.3)') ' ANGLE FORCE CONStant       = ',kangle
      write(uninp,'(A,F10.3)') ' DIHEdral FORCE CONStant    = ',kdihe
      write(uninp,'(A,1PG10.1,A)') ' LevelSHIFT                 = ',
     .      levelshft,
     .  ' ! Non-zero value often required (numerical reasons).'
      write(uninp,'(A,4X,2A)') ' Matrix FORMAT              = ',
     .      typout(1:6),' ! Free, or Binary, matrix saved.'
      endif
      close(uninp)

c     Tests:
      if ((.not.qlist.and.cutoff.lt.0.d0.and.rkh.lt.0.d0).or.
     .    knonb.lt.0.d0.or.
     .   (typbond(1:4).ne.'NONE'.and.(cutbnd.lt.0.d0.or.kbond.lt.0.d0
     .   .or.kangle.lt.0.d0.or.kdihe.lt.0.d0))) then
          write(6,'(/2A)') progrer,
     .  ' Distances and force constants can not have negative values !' 
          stop '*Commands are not consistent*'
      endif

c     On recherche l'information/sous-unite:
 
      call string_split(nompdb,lnompdb,":",
     .                  mots,nmotsmax,nmots)
      call stringcl(mots(1),lnom)
 
      if (nmots.gt.1) then
          call stringcl(mots(2),lnom)
          ssusel=mots(nmots)
          write(6,'(3A)') program,' Subunit to be selected: ',ssusel
          if (nmots.gt.2) then
              write(6,'(4A)') progrwn,' The end of filename, ',
     .        nompdb(1:lnompdb),', was not understood.'
          endif
      else
          ssusel=' '
      endif
      nompdb=mots(1)
      call stringcl(nompdb,lnompdb)
c                                          
c     Lecture du fichier de coordonnees:
c     ==================================

      if (prtlev.gt.0)
     .  write(6,'(/(4A))') program,
     .' Coordinate file ',nompdb(1:lnompdb),' to be opened.'

      unpdb=nunit
      nunit=nunit+1
      cformat="FORMATTED"
      cstatus="old"
      call openam(nompdb,cformat,cstatus,unpdb,.true.,
     .     qinter,qexist)
      if (qinter) stop '*No readable coordinate file found*'

c     Format pdb ?

      nl=0
      qpdb=.false.
 120  continue
      read(unpdb,'(A)',end=130) lign80
      if (lign80(1:5).eq.'ATOM '.or.lign80(1:6).eq.'HETATM') then
          qpdb=.true.
          goto 130
      else
          nl=nl+1
      endif
      goto 120
 130  continue
      rewind(unpdb)

      do i=1,natmax
         xat(i)=unknown
         yat(i)=unknown
         zat(i)=unknown
         massat(i)=unknown
         iresat(i)=i
      enddo

      if (qpdb) then
          write(6,'(/2A)') program,
     .  ' Coordinate file in PDB format.'
          call rdatompdb(unpdb,ssusel,xat,yat,zat,massat,
     .         atonam,iresat,resnam,ssunam,segid,natmax,natom,
     .         fatres,nresmx,nres,qerror,prtlev)
          if (natom.eq.nres) then
              write(6,'(/2A)') program,' Study of a standard ENM model.'
          else
              write(6,'(/2A)') progrwn,
     .      ' Study of a several-atom-per-residue model '//
     .      '(this is not that standard).'
          endif
      else
          if (nl.eq.0) then
              write(6,'(/2A)') progrer,' Empty coordinate file.'
              stop
          endif
          write(6,'(/2A)') program,
     .  ' Coordinate file in Free format.'

          call readxyz(unpdb,xat,yat,zat,massat,iresat,natmax,natom,
     .         ndat,qerror,prtlev)

          if (qmasse.and.ndat.lt.4) then
              write(6,'(/2A)') progrer,
     .      ' Masses were not all found, as expected.'
              qmasse=.false.
          endif
      endif

c     Tests:
c     ======

      if (qerror) stop
      if (natom.le.1) then
          write(6,'(2A)') progrer,
     .  ' Not enough atoms found in file. Nothing done.'
          stop
      endif

      write(6,'(/2A)') program,' Coordinate statistics: '

      call vecstat(xat,natom,rmin,rmax,rave,rdev)
      write(6,'(4(A,F12.6))') 
     .' <x>= ',rave,' +/- ',rdev,' From: ',rmin,' To: ',rmax

      call vecstat(yat,natom,rmin,rmax,rave,rdev)
      write(6,'(4(A,F12.6))') 
     .' <y>= ',rave,' +/- ',rdev,' From: ',rmin,' To: ',rmax

      call vecstat(zat,natom,rmin,rmax,rave,rdev)
      write(6,'(4(A,F12.6))') 
     .' <z>= ',rave,' +/- ',rdev,' From: ',rmin,' To: ',rmax

      if (qmasse) then
          write(6,'(/2A)') program,' Mass statistics: '
          call vecstat(massat,natom,rmin,rmax,rave,rdev)
          write(6,'(4(A,F12.6))') 
     .  ' <m>= ',rave,' +/- ',rdev,' From: ',rmin,' To: ',rmax

          if (rmin.le.0.d0) then
              write(6,'(2A)') progrer,
     .      ' Negative or null masses found !'
              qmasse=.false.
          endif
      endif

      if (.not.qmasse) then
          write(6,'(2A)') program,' Masses are all set to one.'
          do i=1,natom
             massat(i)=1.d0
          enddo
      endif
 
c     Test/identification des residus.
 
      if (qpdb) then
      nunknown=0
      do i=1,nres
         ires=fatres(i)
         idres(i)=index(residus_standards,resnam(ires))/4
         if (idres(i).le.0) then
             nunknown=nunknown+1
             if (nunknown.lt.10) then
                 write(6,'(4A)') progrwn," residue:'",
     .           resnam(ires),"' is not a well known amino-acid."
                 idres(i)=idmax
             else if (nunknown.eq.10) then
                 write(6,'(2A)') progrwn,' ........'
                 idres(i)=idmax
             endif
         endif
      enddo
      if (nunknown.gt.0) 
     .write(6,'(/A,I6,A)') progrwn,nunknown,' residue(s) not known.'
      endif
 
c     Bonds i-j and j-i are stored, because below the matrix is
c     calculated and saved three lines at a time.
 
      nbonds=0
      if (typbond.ne.' ALL'.and.typbond.ne.'CONSECUTIF') goto 200
 
      if (typbond.eq.' ALL') then
         nbmax=0
         nbmin=999
         imax=-1
         imin=-1
         k=1
         nbond(1)=1
         do i=1,natom
            do j=1,natom
               if (i.ne.j) then
                   rx=xat(i)-xat(j)
                   ry=yat(i)-yat(j)
                   rz=zat(i)-zat(j)
                   dist=dsqrt(rx*rx + ry*ry + rz*rz)
                   if (dist.le.cutbnd) then
                       jbond(k)=j
                       k=k+1
                   endif
               endif
            enddo
            nbond(i+1)=k
            if (nbond(i+1)-nbond(i).gt.nbmax) then
                nbmax=nbond(i+1)-nbond(i)
                imax=i
            endif
            if (nbond(i+1)-nbond(i).lt.nbmin) then
                nbmin=nbond(i+1)-nbond(i)
                imin=i
            endif
            if (k-1.gt.ntopmax) then
                write(6,'(/2A,I12)') progrer,
     .        ' Too many bonds. Maximum is: ',ntopmax
                stop
            endif
         enddo
         nbonds=k-1
      else if (typbond.eq.'CONSECUTIF') then
 
c        On fait attention aux distances...
c        Il peut y avoir plusieurs molecules,
c        plusieurs chaines, dans le systeme.
 
         k=1
         do i=1,natom
            nbond(i)=k
            if (i.gt.1) then
            j=i-1
            rx=xat(i)-xat(j)
            ry=yat(i)-yat(j)
            rz=zat(i)-zat(j)
            dist=dsqrt(rx*rx + ry*ry + rz*rz)
            if (dist.le.cutbnd) then
                jbond(k)=j
                k=k+1
            endif
            endif
            if (i.lt.natom) then
            j=i+1
            rx=xat(i)-xat(j)
            ry=yat(i)-yat(j)
            rz=zat(i)-zat(j)
            dist=dsqrt(rx*rx + ry*ry + rz*rz)
            if (dist.le.cutbnd) then
                jbond(k)=j
                k=k+1
            endif
            endif
            if (k.gt.ntopmax) then
                write(6,'(/2A,I12)') progrer,
     .        ' Too many bonds. Maximum is: ',ntopmax
                stop
            endif
         enddo
         nbond(natom+1)=k
         imax=2
         imin=1
         nbmin=1
         nbmax=2
         nbonds=k
      endif
 
      if (nbonds.eq.0) then
          write(6,'(/2A/)') progrwn,' No bond found.'
          goto 200
      endif
 
      if (prtlev.gt.0)
     .write(6,'(A,I6,A,F5.2,A)') program,
     .  nbonds/2,' covalent bonds, i.e.,',
     .  float(nbonds)/float(2*natom),' per atom.'

      if (prtlev.gt.1)
     .write(6,'(A,I3,A,I6)') 
     .'         Maximum number found =',nbmax,' for atom ',imax,
     .'         Minimum number found =',nbmin,' for atom ',imin
 
 
      nangles=0
      if (kangle.le.0.d0) then
          write(6,'(/2A)') program,' BOND but no ANGLe energy term.'
          goto 200
      endif

      namax=0
      namin=9999
      imax=-1
      imin=-1
      ii=1
      nangle(1)=1
      do i=1,natom
         if (nbond(i+1).gt.nbond(i)) then
         do jj=nbond(i),nbond(i+1)-1
            j=jbond(jj)
            if (nbond(j+1).gt.nbond(j)) then
            do kk=nbond(j),nbond(j+1)-1
               k=jbond(kk)
               if (k.ne.i) then
                   jangle(ii)=k
                   jsomang(ii)=j
                   ii=ii+1
               endif
            enddo
            endif
         enddo
         endif
         nangle(i+1)=ii
         if (nangle(i+1)-nangle(i).gt.namax) then
             namax=nangle(i+1)-nangle(i)
             imax=i
         endif
         if (nangle(i+1)-nangle(i).lt.namin) then
             namin=nangle(i+1)-nangle(i)
             imin=i
         endif
         if (ii.gt.ntopmax) then
             write(6,'(/2A,I12)') progrer,
     .     ' Too many angles. Maximum is: ',ntopmax
             stop
         endif
      enddo
      nangles=ii-1
 
      if (nangles.eq.0) then
          write(6,'(/2A/)') progrwn,' No bond-angle found.'
          goto 200
      endif
 
      if (prtlev.gt.0)
     .write(6,'(A,I6,A,F5.2,A)') program,
     .  nangles/2,' valence angles, i.e.,',
     .  float(nangles)/float(2*natom),' per atom.'

      if (prtlev.gt.1)
     .write(6,'(A,I3,A,I6)') 
     .'         Maximum number found =',namax,' for atom ',imax,
     .'         Minimum number found =',namin,' for atom ',imin

 
      ndihs=0
      if (kdihe.le.0.d0) then
         write(6,'(/2A)') program,' ANGLes but no DIHEdral energy term.'
         goto 200
      endif

      namax=0
      namin=9999
      imax=-1
      imin=-1
      ii=1
      ndihe(1)=1
c     For each atom:
      do i=1,natom
c        All angles where it is the first atom:
         if (nangle(i+1).gt.nangle(i)) then
         do jj=nangle(i),nangle(i+1)-1
c           For the "top-atom" of this angle:
            j=jsomang(jj)
c           All angles where it is the first atom:
            if (nangle(j+1).gt.nangle(j)) then
            do kk=nangle(j),nangle(j+1)-1
               k=jangle(kk)
               if (k.ne.i.and.j.ne.jsomang(kk).and.i.ne.jsomang(kk))then
                   jdihe(ii)=k
                   ii=ii+1
               endif
            enddo
            endif
         enddo
         endif
         ndihe(i+1)=ii
         if (ndihe(i+1)-ndihe(i).gt.namax) then
             namax=ndihe(i+1)-ndihe(i)
             imax=i
         endif
         if (ndihe(i+1)-ndihe(i).lt.namin) then
             namin=ndihe(i+1)-ndihe(i)
             imin=i
         endif
         if (ii.gt.ntopmax) then
             write(6,'(/2A,I12)') progrer,
     .     ' Too many dihes. Maximum is: ',ntopmax
             stop
         endif
      enddo
      ndihs=ii-1
 
      if (ndihs.eq.0) then
          write(6,'(/2A/)') progrwn,' No bond-dihedral found.'
          goto 200
      endif
 
      if (prtlev.gt.0)
     .write(6,'(A,I6,A,F5.2,A)') program,
     .  ndihs/2,' dihedral angles, i.e.,',
     .  float(ndihs)/float(2*natom),' per atom.'

      if (prtlev.gt.1)
     .write(6,'(A,I3,A,I6)') 
     .'         Maximum number found =',namax,' for atom ',imax,
     .'         Minimum number found =',namin,' for atom ',imin

c     ==============================
c     Matrice des derivees secondes:
c     ==============================                                
 200  continue

c     Lecture eventuelle de la liste des voisins:
c     -------------------------------------------
c     Formats possibles: 
c     atom-number atom-number 
c     atom-number atom-number force-constant

      if (qlist) then
      write(6,'(/2A)') program,' Neighbor list to be read.'
      unlst=nunit
      nunit=nunit+1
      cformat="FORMATTED"
      cstatus="old"
      call openam(nomlst,cformat,cstatus,unlst,.true.,
     .     qinter,qexist)

      nvois=0
      ndat=0
 210  continue
      read(unlst,'(A)',end=230,err=220) lign80

c     Les commentaires ne sont pas pris en compte:
      kcom=index(lign80,'!') 
      if (kcom.le.0) kcom=index(lign80,'#')
      if (kcom.gt.0) then
          if (kcom.eq.1) then
              write(6,'(2A)') lign80(1:50),' ...'
              goto 210
          else
              lign80=lign80(1:kcom-1)
          endif
      endif

c     Plusieurs separateurs sont possibles: , ; ou blanc
      csep=","
      k=index(lign80,csep)
      if (k.le.0) then
          csep=";"
          k=index(lign80,csep)
      endif
      if (k.le.0) csep=" "

      call string_split(lign80,80,csep,
     .     mots,nmotsmax,nmots)
      if (nmots.lt.2) goto 225 
      if (ndat.eq.0) then
          ndat=min(nmots,3)
          if (ndat.eq.3) qfread=.true.
      endif
      if (nmots.lt.ndat) then
          write(6,'(/A,I3,A/A)') progrer,ndat,
     .  ' data per ligne until ligne: ',lign80
          goto 220
      endif

c     Lecture de: i, j (kij le cas echeant).

      read(mots(1),*) ii
      read(mots(2),*) jj
      if (qfread) read(mots(3),*) kfce

      if (ii.le.0.or.jj.le.0) then
          write(6,'(/2A)') progrer,
     .        ' Null or negative atom number found.'
          goto 225
      endif
      if (ii.gt.natom.or.jj.gt.natom) then
          write(6,'(/2A,I6,A,I6,A)') progrer,
     .  ' Atom number: ',ii,' or ',jj,
     .  ' larger than the number of atoms.'
          stop '*Wrong file*'
      endif

      nvois=nvois+1
      if (nvois.gt.nvoismx) then
          write(6,'(/2A,I6,A)') progrer,' More than ',nvoismx,
     .  ' pairs of neighbors, the maximum allowed. Sorry.'
          stop '*Recompile with larger array*'
      endif

      ivois(nvois)=ii
      jvois(nvois)=jj
      if (qfread) fvois(nvois)=kfce

c     Ligne suivante:
      goto 210

c     Probleme de lecture:
 220  continue
      write(6,'(2A,I6)') progrer,
     .    ' While reading neigbors pair: ',nvois+1
      stop '*Wrong or corrupted file*'

 225  continue
      write(6,'(2A/A)') progrer,
     .' No (or wrong) pair of atom numbers found in ligne: ',lign80
      stop '*Wrong or corrupted file*'

c     Fin du fichier:
 230  continue     
      write(6,'(/A,I6,A)') program,nvois,' pairs of neighbors.' 
      endif

c     Coordonnees et masses utilisees, sauvegardees:
c     ----------------------------------------------

      unout=nunit
      nunit=nunit+1
      nomfich="pdbmat.xyzm"
      cformat="FORMATTED"
      cstatus="ove"
      call openam(nomfich,cformat,cstatus,unout,.true.,
     .     qinter,qexist)

      do i=1,natom
         write(unout,'(4(1PG20.12),I9)')  
     .   xat(i), yat(i), zat(i), massat(i), iresat(i)
      enddo
      close(unout) 
      if (prtlev.gt.0)
     .write(6,'(2A)') program,
     .    ' Coordinates and masses considered are saved.'

c     Fichier de commandes pour VMD:
c     ------------------------------

      unvmd=-1
      if (nomvmd.ne.'NONE') then
      unvmd=nunit
      nunit=nunit+1
      nomfich=nomvmd
      cformat="FORMATTED"
      cstatus="ove"
      call openam(nomfich,cformat,cstatus,unvmd,.true.,
     .     qinter,qexist)

      write(unvmd,'(A)') '#!/usr/local/bin/vmd'
      write(unvmd,'(A)') '# script for VMD (Visual Molecular Dynamics)'
      write(unvmd,'(A)') '# Goal: visualizing the elastic network'
      write(unvmd,'(A)') '# Type: vmd -e this-file'
      write(unvmd,'(A)') 'color Display {Background} white'
      write(unvmd,'(A)') 'mol new'
      write(unvmd,'(A)') 'draw color black'
      endif

c     Fichier de commandes pour Molscript:
c     ------------------------------------

      unmol=-1
      if (nommls.ne.'NONE') then
      unmol=nunit
      nunit=nunit+1
      nomfich=nommls
      cformat="FORMATTED"
      cstatus="ove"
      call openam(nomfich,cformat,cstatus,unmol,.true.,
     .     qinter,qexist)

      write(unmol,'(A)') '! Script for Molscript (Kraulis, 1993)'
      write(unmol,'(A)') '! Goal: visualizing the elastic network'
      write(unmol,'(A)')  ' set bonddistance 99.0 ;'
      endif

c     Matrice:
c     --------

      if (qbinary) then
        if (.not.qmtx) nommtx="pdbmat.sdijb"
        cformat="UNFORMATTED"
      else
        if (.not.qmtx) nommtx="pdbmat.sdijf"
        cformat="FORMATTED"
      endif
      unout=nunit
      nunit=nunit+1
      cstatus="ove"
      call openam(nommtx,cformat,cstatus,unout,.true.,
     .     qinter,qexist)

c     ========================================
c     Les atomes sont tous lies deux a deux,
c     par un potentiel "universel" (M.Tirion).
c     ========================================
 
      elmax=0.d0
      trace=0.d0
      dmin=0.d0
      dmax=0.d0
      dmoy=0.d0
      drms=0.d0
      nnzero=0
      nntr=0
      nbig=0
      ll=0

      do i=1,natom
         ii=3*i-2
         nvoisat(i)=0

c        Liste eventuelle des voisins de i:
c        ----------------------------------

         if (qlist) then
             do j=1,natom
                qvois(j)=.false.
                kvois(j)=0.d0
             enddo
             do j=1,nvois
                if (ivois(j).eq.i) then
                    qvois(jvois(j))=.true.
                    if (qfread) kvois(jvois(j))=fvois(j)
                endif
                if (jvois(j).eq.i) then
                    qvois(ivois(j))=.true.
                    if (qfread) kvois(ivois(j))=fvois(j)
                endif
             enddo
         endif
 
c        On calcule trois lignes de la matrice a la fois:
c        -----------------------------------------------
         do j=1,3*natom
            der2(1,j)=0.d0
            der2(2,j)=0.d0
            der2(3,j)=0.d0
         enddo
 
         do j=1,natom
            if (.not.qlist.or.(qlist.and.qvois(j))) then
            if (i.ne.j) then
            jj=3*j-2
            kij=knonb
            if (qfread) kij=kvois(j) 

            rx=xat(i)-xat(j)
            ry=yat(i)-yat(j)
            rz=zat(i)-zat(j)
            dist2=rx*rx + ry*ry + rz*rz
            dist=dsqrt(dist2)
 
            if (dist.lt.rsmall) then
                write(6,'(/2A,1PG10.4,A/2(I6,2A,I6,A,1X,2A))') 
     .          progrer,' Too small distance = ',dist,
     .        ' between following atoms.',
     .          i,': ',resnam(i),iresat(i),ssunam(i),atonam(i),' and ',
     .          j,': ',resnam(j),iresat(j),ssunam(j),atonam(j)
                stop '*Wrong coordinates*'
            endif

            if (rkh.gt.0.d0) kij=kij*exp(-(dist/rkh)**2.d0)

c           Constantes de force topologiques:
 
            if (nbonds.gt.0) then
            if (nbond(i+1).gt.nbond(i)) then
                do k=nbond(i),nbond(i+1)-1
                   if (jbond(k).eq.j) then
                       kij=kbond
                       goto 300
                   endif
                enddo
            endif
            else
            goto 300
            endif
 
            if (nangles.gt.0) then
            if (nangle(i+1).gt.nangle(i)) then
                do k=nangle(i),nangle(i+1)-1
                   if (jangle(k).eq.j) then
                       kij=kangle
                       goto 300
                   endif
                enddo
            endif
            else
            goto 300
            endif

            if (ndihs.gt.0) then
            if (ndihe(i+1).gt.ndihe(i)) then
                do k=ndihe(i),ndihe(i+1)-1
                   if (jdihe(k).eq.j) then
                       kij=kdihe
                       goto 300
                   endif
                enddo
            endif
            else
            goto 300
            endif

 300        continue
 
c           Calcul des elements: (potentiel harmonique)
c           -------------------------------------------
            if (dist.le.cutoff.or.qlist.or.
     .         (cutoff.le.0.d0.and.rkh.gt.0.d0)) then

                ll=ll+1
                nvoisat(i)=nvoisat(i)+1
                if (j.gt.i) then
                   if (unvmd.gt.0) then
                   write(unvmd,'(A,3F12.4,A,3F12.4,A)') 'draw line {',
     .             xat(i),yat(i),zat(i),'} {',xat(j),yat(j),zat(j),'}'
                   endif
                   if (unmol.gt.0) then
                   write(unmol,'(A,I6,3A)')  
     .           ' bonds require in residue ',iresat(i),', atom ',
     .             atonam(i),' and in molecule mol1 ',
     .           ' require in residue ',iresat(j),', atom ',
     .             atonam(j),' and in molecule mol1 ; '
                   endif
c                  Potentiel harmonique: 1/eval*knonb*(d - rval)**eval
                endif

                if (ll.eq.1.or.dist.lt.dmin) dmin=dist
                if (ll.eq.1.or.dist.gt.dmax) dmax=dist
                dmoy=dmoy+dist
                drms=drms+dist2

c               Elements diagonaux des blocs i et j:
c               -----------------------------------
                ddf=kij/dist2
                elemnt=rx*rx*ddf
                der2(1,ii)=der2(1,ii)+elemnt
                der2(1,jj)=der2(1,jj)-elemnt
                elemnt=ry*ry*ddf
                der2(2,ii+1)=der2(2,ii+1)+elemnt
                der2(2,jj+1)=der2(2,jj+1)-elemnt
                elemnt=rz*rz*ddf
                der2(3,ii+2)=der2(3,ii+2)+elemnt
                der2(3,jj+2)=der2(3,jj+2)-elemnt
 
c               Elements extra-diagonaux des deux blocs:
c               ---------------------------------------
                elemnt=rx*ry*ddf
                der2(1,ii+1)=der2(1,ii+1)+elemnt
                der2(2,ii)=der2(2,ii)+elemnt
                der2(1,jj+1)=der2(1,jj+1)-elemnt
                der2(2,jj)=der2(2,jj)-elemnt
                elemnt=rx*rz*ddf
                der2(1,ii+2)=der2(1,ii+2)+elemnt
                der2(3,ii)=der2(3,ii)+elemnt
                der2(1,jj+2)=der2(1,jj+2)-elemnt
                der2(3,jj)=der2(3,jj)-elemnt
                elemnt=ry*rz*ddf
                der2(2,ii+2)=der2(2,ii+2)+elemnt
                der2(3,ii+1)=der2(3,ii+1)+elemnt
                der2(2,jj+2)=der2(2,jj+2)-elemnt
                der2(3,jj+1)=der2(3,jj+1)-elemnt
            endif
            endif
            endif
         enddo
 
c        Sortie de la matrice-bande calculee:
c        -----------------------------------
c       (Uniquement la demi-matrice superieure)
 
c        Level-shift, pour eviter les zeros numeriques,
c        lors de la diagonalisation a venir 
c       (la minimisation est parfaite, par definition).
c        Le hasard est la pour lever la degenerescence
c        des six valeurs propres nulles, et differencier
c        rotations et translations.
 
         der2(1,ii)  =der2(1,ii)   + levelshft*random(iseed)
         der2(2,ii+1)=der2(2,ii+1) + levelshft*random(iseed)
         der2(3,ii+2)=der2(3,ii+2) + levelshft*random(iseed)
 
         do j=ii,3*natom
            jat=(j-1)/3+1
            if (der2(1,j).ne.0.d0) then
                nnzero=nnzero+1
                if (qbinary) then
                write(unout) 
     .          ii,j,der2(1,j)/dsqrt(massat(i)*massat(jat))
                else
                write(unout,'(2I10,1PG20.12)') 
     .          ii,j,der2(1,j)/dsqrt(massat(i)*massat(jat))
                endif
                if (dabs(der2(1,j)).gt.rbig)  nbig=nbig+1
                if (dabs(der2(1,j)).gt.elmax) elmax=dabs(der2(1,j))
            endif
         enddo
         do j=ii+1,3*natom
            jat=(j-1)/3+1
            if (der2(2,j).ne.0.d0) then
                nnzero=nnzero+1
                if (qbinary) then
                write(unout) 
     .          ii+1,j,der2(2,j)/dsqrt(massat(i)*massat(jat))
                else
                write(unout,'(2I10,1PG20.12)') 
     .          ii+1,j,der2(2,j)/dsqrt(massat(i)*massat(jat))
                endif
                if (dabs(der2(2,j)).gt.rbig) nbig=nbig+1
                if (dabs(der2(2,j)).gt.elmax) elmax=dabs(der2(2,j))
            endif
         enddo
         do j=ii+2,3*natom
            jat=(j-1)/3+1
            if (der2(3,j).ne.0.d0) then
                nnzero=nnzero+1
                if (qbinary) then
                write(unout) 
     .          ii+2,j,der2(3,j)/dsqrt(massat(i)*massat(jat))
                else
                write(unout,'(2I10,1PG20.12)') 
     .          ii+2,j,der2(3,j)/dsqrt(massat(i)*massat(jat))
                endif
                if (dabs(der2(3,j)).gt.rbig) nbig=nbig+1
                if (dabs(der2(3,j)).gt.elmax) elmax=dabs(der2(3,j))
            endif
         enddo
         elemnt=(der2(1,ii)+der2(2,ii+1)+der2(3,ii+2))/massat(i)
         if (elemnt.eq.0.d0) then
             write(6,'(2A,I6,A)') progrwn,
     .     ' Atom ',i,' has a null second derivatives...'
         else
             nntr=nntr+1
         endif
         trace=trace+elemnt
      enddo
      close(unout)

      if (unvmd.gt.0) then
          write(unvmd,'(2A)') 'mol load pdb ',nompdb(1:lnompdb)
          close(unvmd)
      endif
      if (unmol.gt.0) close(unmol)
      if (unrsd.gt.0) close(unrsd)
 
      nmoy=0.d0
      nrms=0.d0
      nmin=natom
      nmax=0
      do i=1,natom
         if (nvoisat(i).gt.nmax) nmax=nvoisat(i)
         if (nvoisat(i).lt.nmin) nmin=nvoisat(i)
         nmoy=nmoy+nvoisat(i)
         nrms=nrms+nvoisat(i)**2.d0
      enddo
      nmoy=nmoy/float(natom)
      nrms=nrms/float(natom)-nmoy**2.d0
      if (nrms.gt.0.d0) nrms=dsqrt(nrms)
 
      if (ll.eq.0) then
          write(6,'(/2A,I12,A)') progrer,
     .  ' No atom-atom interaction found. Too short cutoff ?'
          stop '*Empty matrix*'
      else
          dmoy=dmoy/float(ll)
          drms=drms/float(ll)-dmoy**2.d0
          if (drms.gt.0.d0) drms=dsqrt(drms)
      endif

      if (prtlev.gt.0)
     .write(6,'(/2A)') program,' Matrix statistics:'

      write(6,'(/2A,F8.4,A)') program,' The matrix is ',
     .  100.d0*dfloat(nnzero)/dfloat(3*natom*(3*natom+1)/2),' % Filled.'
      write(6,'(A,I12,A)') program,nnzero,'  non-zero elements.'

      if (prtlev.gt.0) then
      write(6,'(A,I12,A)') program,ll/2,' atom-atom interactions.'
      write(6,'(/2A,F9.2,A,F9.2/(A,I6))') program,
     .        ' Number per atom= ',nmoy,' +/- ',nrms,
     .'         Maximum number = ',nmax,
     .'         Minimum number = ',nmin
      write(6,'(/2A,F9.2,A,F9.2/(A,F9.2))') program,
     .        ' Average dist.  = ',dmoy,' +/- ',drms,
     .'         Maximum dist.  = ',dmax,
     .'         Minimum dist.  = ',dmin
      endif
 
      write(6,'(/2A,1PG12.6)') program,' Matrix trace   = ',trace

      if (prtlev.gt.0) then
      write(6,'(2A,1PG12.6)') program,' Larger element = ',elmax
      write(6,'(A,I6,A,1PG8.1)') program,
     .      nbig,' elements larger than +/- ',rbig
      endif
 
      write(6,'(/2A)') program,' Hessian matrix ready.'
      write(6,'(2A)') program,
     .' To diagonalize it (and get the modes),'//
     .' you may use diagstd, blzpack, diagrtb...'

      write(6,'(/2A)') program,' Normal end.'
      stop
      end
c-----------------------------------------------------------------------
      subroutine stringcl(chaine,nonblancs)
c
c     Les caracteres "blancs" de la CHAINE sont retires 
c    (a gauche et au milieu).
c     L'entier NONBLANCS donne la position du dernier caractere.
c
c     YHS-Jan-95, Toulouse.
c I/O:
      integer nonblancs
      character*(*) chaine
c Local:
      integer icar, ncar, taille
c Begin:
      taille=len(chaine)
c
      if (index(chaine(1:taille),' ').le.0) then
          nonblancs=taille
          return
      endif
c
c*****Nettoyage des blancs a gauche.
c     Premier non-blanc:
c
      do icar=1,taille
         if (chaine(icar:icar).ne.' ') goto 150
      enddo
 150  continue
      chaine=chaine(icar:taille)
c
c*****Nettoyage des blancs au milieu.
c
          icar=1
          ncar=1
 170      continue
          icar=icar+1
          ncar=ncar+1
          if (chaine(icar:icar).eq.' ') then
              chaine=chaine(1:icar-1)//chaine(icar+1:taille) 
              icar=icar-1
          endif
          if (ncar.lt.taille-1) goto 170
c
      nonblancs=index(chaine,' ')-1
c
      return
      end
c-----------------------------------------------------------------------
      subroutine string_split(chaine,taille,delimiteur,
     .                        souschaine,nbremax,nbre)
c
c     "Chaine" est coupee en "nbre" "souschaine" de part et d'autre du
c     "delimiteur"
c      YHS-Sep-93, Uppsala
c I/O:
      integer taille, nbremax, nbre
      character*(*) chaine, souschaine(*), delimiteur
c Local:
      integer icar, iprev
c
      nbre=1
      iprev=1
      souschaine(1)=chaine
      do icar=1,taille
         if (chaine(icar:icar).eq.delimiteur) then
            if (icar-1.ge.iprev) then
               souschaine(nbre)=chaine(iprev:icar-1)
               nbre=nbre+1
               if (nbre.le.nbremax) then
                  if (icar+1.le.taille.and.
     .               chaine(icar+1:taille).ne.' ') then
                     souschaine(nbre)=chaine(icar+1:taille) 
                  else
                     nbre=nbre-1
                     return
                  endif
               else
                  write(6,'(A,I6,A/A)') 
     .               ' %String_split-Err: more than ',nbremax,
     .               ' substrings in : ',chaine
                  return
               endif
            endif
            iprev=icar+1
         endif
      enddo
c
      return
      end
c-----------------------------------------------------------------------
      subroutine openam(namfil,cformat,cstatus,unit,qverbos,
     .                  qinterr,qexist)
c
c     Ouverture d'un fichier de nom NAMFIL, sur l'unite UNIT,
c     a priori suite a une interrogation...
c
c     input:
c        namfil: nom du fichier a ouvrir. 
c        "stop", "end", "fin", "quit" : arretent le programme.
c        cstatus: mots-cles fortran... ou "OVE" pour overwrite.
c     output: 
c        qexist: flag / existence du fichier 
c        qinterr: Pas de nom pour le fichier cherche.
c I/O:
      logical qinterr, qverbos, qexist
      integer unit
      character*(*) namfil, cformat, cstatus
c Local
      integer lnom
      character*132 ordrunix
c begin:
      if (cstatus.eq.'old') cstatus='OLD'
      if (cstatus.eq.'new') cstatus='NEW'
      if (cstatus.eq.'ove') cstatus='OVE'
      if (cstatus.eq.'unknown') cstatus='UNKNOWN'
c
      qinterr=.false.
      qexist=.false.
c
      if (namfil.eq.' ') then 
          qinterr=.true.
          write(6,'(A)') '%Openam-Err> No filename.'
          return
      endif
c
      if (namfil.eq.'stop'.or.namfil.eq.'end'                         
     &    .or.namfil.eq.'fin'.or.namfil.eq.'quit') then 
         write(6,'(2A)') 'Openam> Program is stopping on user request.'
         stop                                                                   
      endif 
 
c     Checks if filename is consistent with the opening:

      call stringcl(namfil,lnom)

      inquire(file=namfil,exist=qexist)
      if (.not.qexist.and.cstatus.eq.'OLD') then
          qinterr=.true.
          if (qverbos) then
              write(6,'(/2A)') '%Openam-Err> File: ',namfil(1:lnom)
              write(6,'(A)') 
     .      ' Expected in the current directory, but not found.'
          endif
          return
      endif

      if (qexist.and.cstatus.eq.'NEW') then
         write(6,'(/2A)') 
     .      '%Openam-Err> This file exists:',namfil(1:lnom)
         stop
      else if (qexist.and.cstatus.eq.'OVE') then
         ordrunix='rm '//namfil
         call system(ordrunix)
      endif
      if (cstatus.eq.'OVE') cstatus='NEW'

      open(file=namfil,form=cformat,
     .     status=cstatus,unit=unit)                

      if (qverbos) then
         write(6,'(/2A)') ' Openam> File opened: ',namfil(1:lnom)
      endif

      return                                                                       
      end
c-----------------------------------------------------------------------
      subroutine rdatompdb(unpdb,ssusel,xat,yat,zat,binfo,
     .           atonam,iresat,resnam,ssunam,segid,natmax,natom,
     .           fatres,nresmx,nres,qerror,prtlev)
 
c     Lecture ligne a ligne d'un fichier pdb.
c     Uniquement les lignes commencant par 'ATOM'.
c     Uniquement ceux de la sous-unite selectionnee.
 
c     fatres(i): numero du premier atome du residu i.
 
c     YHS-nov-1996: version 1.0 (Toulouse).
c     YHS-sep-2004: version 1.1 (Lyon).
 
      implicit none
cI/O:
      integer unpdb, natmax, iresat(*), natom,  lnom,
     .        nresmx, nres, fatres(*), prtlev
      double precision xat(*), yat(*), zat(*), binfo(*)
      logical qerror
      character*4 atonam(*), resnam(*), segid(*)
      character*1 ssusel, ssunam(*)
cLocal:
      integer iatom, irs, irsprev, nerr, ntit,
     .        i, j, k, ii
      double precision bfact, x, y, z
      character*1  ssu
      character*4  ren, segat
      character*5  atncur
      character*80 lign80
cBegin:
      if (prtlev.gt.0)
     .write(6,'(/A)') ' Rdatompdb> Reading pdb file.'

      qerror=.false.
      nerr=0
 
      irsprev=-1
      ntit=0
      nres=0
      iatom=0
 105  continue   
      read(unpdb,'(A)',end=200,err=110) lign80 
  
      goto 120                                
 110  continue
      nerr=nerr+1                            
 
 120  continue                              
c     if (lign80(1:4).eq.'ATOM') then
      if (lign80(1:4).eq.'ATOM'.or.lign80(1:6).eq.'HETATM') then
      read(lign80,'(12X,A4,1X,A4,A1,I4,4X,3F8.3,6X,F6.2,6X,A4)',
     .            end=130,err=130) 
     .            atncur, ren, ssu, irs, x, y, z, 
     .            bfact, segat 
 130  continue
      if (iatom.lt.natmax) then
          if (ssu.eq.ssusel.or.ssusel.eq.' ') then
          iatom=iatom+1
          xat(iatom)=x
          yat(iatom)=y
          zat(iatom)=z
          binfo(iatom)=bfact
 
          call stringcl(atncur,lnom)
          atonam(iatom)=atncur
          call stringcl(ren,lnom)
          resnam(iatom)=ren
          iresat(iatom)=irs
          ssunam(iatom)=ssu
          segid(iatom)=segat
 
          if (irs.ne.irsprev) then
              nres=nres+1
              if (nres.gt.nresmx) then
                  write(6,'(A/A,I6)') 
     .          '%Rdatompdb-Er> Too many residues in this file.',
     .          ' Maximum allowed is = ',nresmx
                  stop
              endif
              irsprev=irs
              fatres(nres)=iatom
          endif
          endif
      else
          write(6,'(A/A,I6)') 
     .      '%Rdatompdb-Er> Too many atoms in this file.',
     .      ' Maximum allowed is = ',natmax
          stop
      endif
      else if (lign80(1:6).eq.'REMARK'.and.prtlev.gt.0) then
          ntit=ntit+1
          if (ntit.le.10) then
              write(6,'(A)') lign80
          else if (ntit.eq.11) then
              write(6,'(A)') ' .... '
          endif
      endif
 
c     2) Ligne suivante du fichier pdb :
 
      goto 105
 
c     3) Fin de la lecture du fichier pdb :
 
 200  continue 
      if (prtlev.gt.1) then
      write(6,*) 'Rdatompdb> End of file reached.'
      write(6,*) 'Rdatompdb> Number of I/O errors: ',
     .            nerr
      endif
 
      natom=iatom
      fatres(nres+1)=natom+1
      irs=0
      if (natom.gt.0) irs=iresat(natom)
 
      write(6,'(/(A,I6))') 
     .' Rdatompdb> Number of residues found = ',nres,
     .'            First residue number     = ',iresat(1),
     .'            Last  residue number     = ',irs,
     .'            Number of atoms found    = ',natom
      if (prtlev.gt.0)
     .write(6,'(A,F8.1)') 
     .'            Mean number per residue  = ',float(natom)/float(nres)
 
      if (natom.eq.0) then
          write(6,'(A)')
     .  '%Rdatompdb-Er> No atom found in file.'
          qerror=.true.
      endif
      if (nres.eq.0) then
          write(6,'(A)')
     .  '%Rdatompdb-Er> No residue found in file.'
          qerror=.true.
      endif
 
      return
      end
c-----------------------------------------------------------------------
      subroutine mintomaj(chaine)
 
c     Les caracteres minuscules sont mis en MAJUSCULES.
c     Les autres ne sont pas touches.
 
c     YHS-Oct-98: Premiere version (Toulouse).
c     YHS-Sep-03: Dernieres modifications (Lyon).
 
      character*(*) chaine
c Local:
      integer icar, ilettre, taille
      character*26  carmaj, carmin
 
      carmin='qwertyuiopasdfghjklzxcvbnm'
      carmaj='QWERTYUIOPASDFGHJKLZXCVBNM'
 
      taille=len(chaine)
      if (taille.le.0) return

      do icar=1,taille
         ilettre=index(carmin,chaine(icar:icar))
         if (ilettre.gt.0) then
             chaine(icar:icar)=carmaj(ilettre:ilettre)
         endif
      enddo
 
      return
      end
c-----------------------------------------------------------------------
      subroutine readxyz(uninp,x,y,z,w,ic,nmax,ncoor,ndat,qerror,prtlev)

c     Reads at most NMAX coordinates in free format. 

c     Either:
c     x, y, z
c     or:
c     x, y, z, w
c     or:
c     x, y, z, w, ic

c     If first word in ligne is not a number, the whole ligne is
c     assumed to be a title or a commentary.

c     YHS-Sep-03: First version (Lyon).

cI/O:
      logical qerror
      integer ic(*), ncoor, ndat, nmax, prtlev, uninp
      double precision w(*), x(*), xc, y(*), yc, z(*), zc
cLocal:
      integer nmotsmax
      parameter(nmotsmax=255)

      integer i, lmot, nchi, nlmax, nl, nlu, nmots, stats(0:nmotsmax)
      double precision rlu
      character chiffres*15, lignlg*(nmotsmax), 
     .        mots(nmotsmax)*(nmotsmax), program*9, progrer*11, 
     .        progrwn*11

cBegin:
      program=' Readxyz>'
      progrer='%Readxyz-Er>'
      progrwn='%Readxyz-Wn>'

      chiffres='1234567890.eE+-'

      do i=1,nmotsmax
         stats(i)=0
      enddo

c     Lecture ligne a ligne:
c     ----------------------

      if (prtlev.gt.1) write(6,'(/2A)') program,
     .  ' Comments, or lignes with less than three numbers: '

      qerror=.false.
      ncoor=0
      nl=0
 100  continue
      read(uninp,'(A)',end=200) lignlg 
      nl=nl+1
      call string_split(lignlg,nmotsmax," ",mots,nmotsmax,nmots)

      nfound=0
      do i=1,nmots
         call stringcl(mots(i),lmot)
         if (lmot.le.0) goto 150

c        Commentaire ?
         if (mots(i)(1:1).eq.'!') goto 150

c        Chiffre ?

         do k=1,lmot
            if (index(chiffres,mots(i)(k:k)).le.0) goto 110
         enddo

         nfound=nfound+1

         if (nfound.le.4) then
             read(mots(i)(1:lmot),*,err=110) rlu
             if (nfound.eq.1) xc=rlu
             if (nfound.eq.2) yc=rlu
             if (nfound.eq.3) zc=rlu
             if (nfound.eq.4) wc=rlu
         else if (nfound.eq.5) then 
             read(mots(i)(1:lmot),*,err=110) nlu
         endif

c        Mot suivant:
 110     continue

c        Le premier mot n'est pas un chiffre => ligne de commentaires

         if (nfound.eq.0) goto 150
      enddo
 150  continue

c     Stockage des coordonnees:
c     -------------------------

      stats(nfound)=stats(nfound)+1

      if (nfound.ge.3) then
          ncoor=ncoor+1
          if (ncoor.le.nmax) then
              x(ncoor)=xc
              y(ncoor)=yc
              z(ncoor)=zc
              if (nfound.eq.4) then
                  w(ncoor)=wc
              else
                  w(ncoor)=wc
                  ic(ncoor)=nlu 
              endif
          else
              write(6,'(/2A,I9,A)') progrer,' More than ',
     .        nmax,' particles in file.'
              write(6,'(2A)') progrer,
     .      ' Please increase program memory limits (Sorry for that).'
              stop
          endif
      else
          if (prtlev.gt.1) then
              write(6,'(2A)') lignlg(1:72),'...'
          endif
      endif
      
c     Ligne suivante:
      goto 100
 200  continue
      if (prtlev.gt.1.and.nl.eq.ncoor) write(6,'(2A)') program,' None.'

      write(6,'(/2A,I7)') program,
     .' Number of particles in file (with x,y,z coordinates): ',ncoor
 
      if (ncoor.eq.0) then
          write(6,'(/2A)') progrer,' No coordinate found in file.'
          qerror=.true.
      endif

      nchi=0
      ndat=0
      nlmax=0
      do i=1,nmotsmax
         if (stats(i).gt.0) nchi=nchi+1
         if (stats(i).gt.nlmax) then
             nlmax=stats(i)
             ndat=i
         endif
      enddo

      do i=0,nmotsmax
         if (stats(i).gt.0.and.(prtlev.gt.1.or.nchi.gt.1)) then
            write(6,'(A,I6,A,I7,A)') program,i,
     .    ' numbers found in ',stats(i),' lignes.'  
         endif
      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine vecstat(vect,nmax,rmin,rmax,rave,rdev)

c     Statistics for vector Vect(NMAX):
c     minimum, maximum, average (rave) and standard deviation (rdev).

c     YHS-Sep-03: First version (Lyon).

cI/O:
      integer nmax
      double precision rave, rdev, rmax, rmin, vect(*)
cLocal:
      integer i
      character program*9, progrer*11, progrwn*11

cBegin:
      program=' Vecstat>'
      progrer='%Vecstat-Er>'
      progrwn='%Vecstat-Wn>'

      rave=0.d0
      rdev=0.d0
      rmin=-9999.d0
      rmax=9999.d0

      if (nmax.le.0) then
          write(6,'(2A)') progrer,' Zero-length vector.'
          return
      endif

      do i=1,nmax
         if (vect(i).gt.rmax.or.i.eq.1) rmax=vect(i)
         if (vect(i).lt.rmin.or.i.eq.1) rmin=vect(i)
         rave=rave+vect(i)
         rdev=rdev+vect(i)**2.0
      enddo

      rave=rave/dfloat(nmax) 
      rdev=rdev/dfloat(nmax)-rave*rave
      if (rdev.gt.0.d0) rdev=dsqrt(rdev)

      return
      end
C-----------------------------------------------------------------------
      REAL*8 FUNCTION RANDOM(ISEED)
C-----------------------------------------------------------------------
C     RANDOM NUMBER GENERATOR: UNIFORM DISTRIBUTION (0,1)
C     ISEED: SEED FOR GENERATOR. ON THE FIRST CALL THIS HAS TO
C     HAVE A VALUE IN THE EXCLUSIVE RANGE (1, 2147483647)
C     AND WILL BE REPLACED BY A NEW VALUE TO BE USED IN
C     FOLLOWING CALL.
C
C     REF: Lewis, P.A.W., Goodman, A.S. & Miller, J.M. (1969)
C     "Pseudo-random number generator for the System/360", IBM
C     Systems Journal 8, 136.
C
C     This is a "high-quality" machine independent generator.
C     INTEGERS are supposed to be 32 bits or more.
C     The same algorithm is used as the basic IMSL generator.
C
C     Author: Lennart Nilsson
C
      implicit none
      INTEGER ISEED
      REAL*8 DSEED,DIVIS,DENOM,MULTIP
      DATA  DIVIS/2147483647.D0/
      DATA  DENOM /2147483711.D0/
      DATA  MULTIP/16807.D0/
C
      IF(ISEED.LE.1) ISEED=314159
      DSEED=MULTIP*ISEED
      DSEED=MOD(DSEED,DIVIS)
      RANDOM=DSEED/DENOM
      ISEED=DSEED
C
      RETURN
      END
nma/ElNemo/pdbmat.f0000644000175000017500000017746614030637520013513 0ustar  guestguestDoC=====================================================================
DoC   Pdbmat:
DoC
DoC   Computes the mass-weighted second derivatives energy matrix,
DoC   using Tirion's model, that is, an elastic network model (ENM).
DoC   In such models, close particles (atoms) are linked by springs.
DoC
DoC   In Tirions's model, springs are set between atoms less than 
DoC   CUToff Angstroms away from each others.
DoC
DoC   In Hinsen's version, springs are weighted by exp(-dij/rkh)**2.
DoC   Herein, both kind of typical distances (cutoff & rkh) can be mixed.
DoC
DoC   Goal: Computing the low-frequency (collective) normal modes 
DoC   of vibration of the system.
DoC
DoC   To do so, the matrix produced by pdbmat has to be diagonalized
DoC   with a program like DIAGSTD or, for large systems, DIAGRTB,
DoC   BLZPACK, etc.
DoC
DoC=====================================================================
DoC
DoC   INPUT: 
DoC   ******
DoC  -A parameter file named pdbmat.dat.  
DoC
DoC   Note that each run of pdbmat produces a pdbmat.dat_run file,
DoC   where parameter values are shown (and shortly commented).
DoC   pdbmat.dat_run can be modified and used as a pdbmat.dat file, 
DoC   for further runs. 
DoC   So, the simplest is to compile and run pdbmat...
DoC   and have a look at the pdbmat.dat_run file so produced.
DoC   If you want to see there the syntax of other available commands,
DoC   just raise the PRINting level.
DoC
DoC  -Among the parameters: 
DoC
DoC  *The name of a file with the coordinates of the system, 
DoC   in FREE or PDB (protein data bank) format.
DoC
DoC   Free format: x, y, z, mass.
DoC   PDB  format: Only lignes with the ATOM keyword are considered.
DoC        Masses can be given in the Bfactors column.
DoC   Note that masses can be read, but they are not required.
DoC   In the later case, they are all set to 1.0 (as often done).
DoC
DoC  *A way to identify pairs of neighbors:
DoC   Either a CUTOFF value (standard Tirion's model)
DoC   Or a file with a list of pairs of neighbors.
DoC   Format of each ligne of this later file: atom-number atom-number
DoC
DoC   Alternatively, Hinsen's version can be used.
DoC
DoC   For one-atom-per-residue protein models, typical values are:
DoC   Tirion's distance cutoff = 10-12 Angstroms.
DoC   Hinsen's typical range   = 3 Angstroms.
DoC
DoC   OUTPUT:
DoC   *******
DoC
DoC  -Default output matrix filename:
DoC   Formatted file: pdbmat.sdijf 
DoC   Binary    file: pdbmat.sdijb 
DoC
DoC   This is a matrix in format: i, j, non-zero-i-j-matrix-element
DoC
DoC  -Output coordinate filename (in free format):
DoC   pdbmat.xyzm
DoC
DoC   This is a coordinate file with, for each atom: 
DoC   x, y, z, mass, block-number
DoC   For a pdb file, the block-number is the amino-acid residue number
DoC  (it is of use only in other programs like DIAGRTB).
DoC
DoC   More specialized ones:
DoC   ----------------------
DoC
DoC  -VMD-command filename: 
DoC   pdbmat.vmd
DoC
DoC   This is a command file for vizualising the elastic network
DoC   with VMD, the Visual Molecular Dynamics program (v1.8):
DoC   vmd -e pdbmat.vmd 
DoC   But if you just want to vizualise a standard ENM (defined with
DoC   a cutoff distance), there are more efficient (faster) ways.
DoC
DoC  -Molscript-command-file:
DoC   pdbmat.molscript
DoC
DoC   This is a command file for vizualising the elastic network
DoC   with Molscript (v2.1).
DoC   molscript < pdbmat.molscript > pdbmat.ps
DoC   But if you just want to vizualise a standard ENM (defined with
DoC   a cutoff distance) with Molscript, there are much faster ways.
DoC
DoC.....................................................................
      program pdbmat
      implicit none
      integer natmax, nresmx, nvoismx
 
DoC   This is a fortran 77 program, so it has predefined:
DoC
DoC   **************
DoC   MEMORY LIMITS:
DoC   **************
DoC
DoC   NATMAX  :  Maximum number of atoms (particles).
DoC   NRESMX  :  Maximum number of residues (groups of particles).
DoC   NVOISMX :  Maximum number of pairs of neighbors.  
   
      parameter( NATMAX=250000 )
      parameter( NRESMX=250000 )
      parameter( NVOISMX=1000000 )
    
DoC   Increase them if needed. To (re)compile pdbmat, type:
DoC   make pdbmat
DoC   or:
DoC   g77 -o pdbmat pdbmat.f
DoC   or use your favorite fortran compiler (instead of g77).
DoC.....................................................................
DoC
DoC   ABOUT Tirion's model:
DoC   *********************
DoC
DoC   Principe du modele (Tirion, 1996): 
DoC   
DoC   Tous les atomes a moins de "cutoff" les uns des autres 
DoC   sont supposes lies par des ressorts, qui ont tous
DoC   la meme raideur.
DoC   Simplification supplementaire par rapport au modele initial: 
DoC   les atomes sont supposes avoir tous la meme taille
DoC  (le cutoff est le meme pour toutes les paires d'atomes).
DoC   On peut de plus poser qu'ils ont tous la meme masse.
DoC   Sinon, celles-ci sont lues dans la colonne des 
DoC   facteurs B du fichier pdb.
DoC
DoC   Principaux resultats:
DoC
DoC   Les modes de vibration de basse frequence obtenus
DoC   a partir d'un tel modele sont tres voisins de ceux
DoC   obtenus avec un modele beaucoup plus detaille, tels
DoC   ceux utilises lors des etudes de Dynamique Moleculaire.
DoC
DoC   Dans le cas ou le mouvement fonctionnel d'une proteine est un 
DoC   mouvement d'ensemble (collectif), on constate qu'il peut tres 
DoC   souvent etre decrit comme une combinaison lineaire de quelques
DoC   uns de ces modes (de un a trois).
DoC
DoC   Principaux avantages:
DoC
DoC   Pas besoin de prendre en compte tous les atomes.
DoC   Pas besoin de minimisation d'energie prealablement
DoC   au calcul des modes de vibration (E=0 par construction).
DoC
DoC.....................................................................
DoC
DoC   MAIN REFERENCES:
DoC   ****************
DoC
DoC   1) M.M. Tirion (1996):
DoC  "Large amplitude elastic motions in proteins from
DoC   a single-parameter, atomic analysis",
DoC   Phys. Rev. letters vol.77(9), p1905-1908.
DoC
DoC   2) K. Hinsen (1998):
DoC  "Analysis of domain motions by approximate normal mode calculations"
DoC   Proteins vol.33, p417-429.
DoC
DoC   3) F. Tama, Y.H. Sanejouand (2001):
DoC  "Conformational change of proteins arising 
DoC   from normal modes calculations"
DoC   Protein Engineering vol.14, p1-6.
DoC
DoC   4) A.R. Atilgan, S.R. Durell, R.L. Jernigan, M.C. Demirel,
DoC   O. Keskin, I. Bahar (2001):
DoC  "Anisotropy of Fluctuation Dynamics of Proteins with an Elastic 
DoC   Network Model"
DoC   Biophys Journal vol.80, p.505-515.
DoC
DoC   5) S. Nicolay, Y.H. Sanejouand (2006):
DoC  "Functional modes of proteins are among the most robust"
DoC   Phys. Rev. letters vol.96, p078104.
DoC
DoC   In case of problem, feel free to contact: 
DoC   Yves-Henri.Sanejouand@ens-lyon.fr
DoC  (bug reports may help you, but also others)
DoC
DoC.....................................................................

c     YHS-Nov-1996: Version 1.00.
c     Versions released at http://ecole-modelisation.free.fr/modes.html
c     YHS-Mar-2001: Version 3.31. 
c     YHS-Feb-2004: Version 3.50. 
c     YHS-Feb-2008: Version 3.73. 
c     Version used by the ELNEMO Web site (http://www.elnemo.org):
c     YHS-Feb-2004: Version 3.46.
c
DoC   New features since the previously released version (v3.50):
DoC  -The list of pairs of neighbors can be read in a file.
DoC  -The elastic network can be visualized, using VMD or Molscript.
DoC  -The output format has been extended.
DoC  -Hinsen's weight added.
DoC  -Bond-dihedral energy term added (1-4 bond, dihedral-like). 
DoC  -DoCumentation included in the code.
DoC
DoC.....................................................................
      integer nmotsmax, ntopmax
      parameter(ntopmax=10*natmax,nmotsmax=100)
 
      integer fatres(nresmx+1), 
     .        i, idmax, idres(nresmx), ii, imax, imin, ires, 
     .        iresat(natmax), iseed, ivois(nvoismx),
     .        j, jangle(ntopmax), jat, jbond(ntopmax), jdihe(ntopmax), 
     .        jj, jsomang(ntopmax), jvois(nvoismx), 
     .        k, kcom, kk, klist, 
     .        l, ll, lmot, lnom, lnomlst, lnommls, lnommtx, lnompdb, 
     .        lnomvmd,
     .        namax, namin, nangle(ntopmax), nangles, natom, 
     .        nbig, nbmax, nbmin, nbond(ntopmax), nbonds, ndat, 
     .        ndihe(ntopmax), ndihs, nl, nmax, nmin, nmots, nntr, 
     .        nnzero, nres, nunit, nunknown, nvois, nvoisat(natmax), 
     .        prtlev, uninp, unlst, unmol, unout, unpdb, unrsd, unvmd
      double precision cutbnd, cutoff, ddf, der2(3,3*natmax), 
     .        dist, dist2, dmax, dmin, dmoy, drms, 
     .        elemnt, elmax, fvois(natmax), 
     .        kangle, kbond, kdihe, kfce, kij, knonb, kvois(natmax),
     .        levelshft, massat(natmax), nmoy, nrms,
     .        random, rave, rbig, rdev, rinput, rkh, rmax, rmin, rsmall, 
     .        rx, ry, rz, 
     .        trace, unknown, xat(natmax), yat(natmax), zat(natmax) 
      logical qbinary, qerror, qexist, qfread, qinter, qlist, 
     .        qmasse, qmtx, qok, qpdb, qvois(natmax)
      character atonam(natmax)*4, cformat*32, csep*1, cstatus*32, 
     .        lign80*80, motinp*80, mots(nmotsmax)*132, 
     .        nomfich*64, nomlst*64, nommls*64, nommtx*64, nompdb*64, 
     .        nomvmd*64,
     .        program*8, progrer*11, progrwn*11, 
     .        residus_standards*132, residus_stshort*21, 
     .        resnam(natmax)*4, segid(natmax)*4, ssunam(natmax)*1, 
     .        ssusel*1, typbond*80, typmas*80, typout*80, version*32
      parameter(rbig=1e10,rsmall=1e-10,unknown=9999.d9)
c.......................................................................
      version=' Version 3.73, February 2008.'
c.......................................................................
      idmax=21
      residus_standards='   ILE PHE TRP LEU CYS VAL MET TYR ALA HIS '//
     .                     'GLY THR SER PRO ARG GLN ASN ASP GLU LYS '
      residus_stshort='IFWLCVMYAHGTSPRQNDEKX'
 
      program=' Pdbmat>'
      progrer='%Pdbmat-Er>'
      progrwn='%Pdbmat-Wn>'

      write(6,'(2A)') program,
     .' Computes the Hessian matrix, using an Elastic Network Model.'
      write(6,'(2A)') program,version

c     ===============================================
c     Ouverture et Lecture du fichier d'instructions:
c     ===============================================
 
c     Default values:
      nompdb='pdbmat.ent'
      cutoff=10.d0
c     Neighbor list:
      nomlst='NONE'
      qlist=.false.
c     Typical distance for Hinsen's weigth:
c    (negative value means 1/rkh=0)
      rkh=-1.d0
      qfread=.false.
      nommls='NONE'
      nomvmd='NONE'
      typmas='CONS'
      qmasse=.false.
      knonb=1.0d0
c     Topological terms (like in ref.6):
      typbond='NONE'
c     Distance-cutoff value for defining covalent (chemical) bonds:
      cutbnd=4.0d0
      kangle=0.0d0
      kbond=1000.0d0
      kdihe=0.0d0
c     Others:
      typout='  FREE'
      qmtx=.false.
      qbinary=.false.
      prtlev=0
      levelshft=1e-8
c     Used only with a levelshift, to add some noise (not useful ?).
      iseed=27041961

      nunit=10
      uninp=nunit
      nunit=nunit+1
      nomfich='pdbmat.dat'
      cformat="FORMATTED"
      cstatus="old"
      call openam(nomfich,cformat,cstatus,uninp,.false.,
     .     qinter,qexist)
      if (qinter.or..not.qexist) then 
          write(6,'(/2A/(2A))') progrwn,
     .  ' No pdbmat.dat command file found.',
     .    progrwn,' Defaults assumed for all options. ',
     .    progrwn,' See the pdbmat.dat_run file if you need an example.'
          goto 110
      else
          write(6,'(/2A)') program,
     .  ' Options to be read in pdbmat.dat file.'
      endif
 
 50   continue
      read(uninp,'(A)',end=100) lign80
 
      kcom=index(lign80,'!')
      k=index(lign80,'=') 
      motinp=' '
      if (k.gt.0.and.(kcom.le.0.or.kcom.gt.k)) then 
          motinp=lign80(1:k)
      else
          if (k.le.0.and.kcom.gt.1) then
          write(6,'(/2A/A)') progrwn,
     .  ' No separator (=) in command ligne:',
     .    lign80
          write(6,'(2A)') progrwn,' This ligne is skipped.'
          endif
          goto 50
      endif
      call mintomaj(motinp)

      kcom=index(lign80(k+1:80),'!')
      if (kcom.gt.0) lign80(k+kcom:80)=' '
      klist=index(lign80(k+1:80),'?')

      if (index(motinp,' FILENAME').gt.0.or.
     .    index(motinp,' SCRIPT').gt.0) then 
          if (index(motinp,'MATRI').gt.0) then
              nommtx=lign80(k+1:80)
              qmtx=.true.
          elseif (index(motinp,'LIST ').gt.0.or.
     .            index(motinp,'NEIGH').gt.0) then
              nomlst=lign80(k+1:80)
              qlist=.true.
          elseif (index(motinp,'MOLS').gt.0) then
              nommls=lign80(k+1:80)
          elseif (index(motinp,'VMD').gt.0) then
              nomvmd=lign80(k+1:80)
          else
              nompdb=lign80(k+1:80)
          endif
      else if (index(motinp,' DEFINITION').gt.0) then
          typbond=lign80(k+1:80)
          call mintomaj(typbond)
          call stringcl(typbond,lnom)
          if (typbond(1:3).eq.'ALL') then 
              typbond=' ALL'
          else if (typbond(1:3).eq.'NON') then 
              typbond='NONE'
          else if (typbond(1:3).eq.'CON') then
              typbond='CONSECUTIF'
          else
              write(6,'(/3A)') progrwn,' Bond definition :',
     .        typbond(1:4)
              if (klist.le.0)
     .        write(6,'(2A)') progrwn,' This is not a known keyword.'
              write(6,'(2A)') progrwn,
     .      ' Valid options are: NONe, ALL, CONsecutive.'
              write(6,'(A)') ' Default assumed.'
              typbond='NONE'
          endif
      else if (index(motinp,'MASS').gt.0) then
          typmas=lign80(k+1:80)
          call mintomaj(typmas)
          call stringcl(typmas,lnom)
          if (typmas(1:3).eq.'PDB'.or.typmas(1:3).eq.'COO') then
              qmasse=.true.
              typmas='COOR'
          else if (typmas(1:3).ne.'CON') then
              write(6,'(/3A)') progrwn,' Origin of mass values :',
     .        typmas(1:3)
              if (klist.le.0)
     .        write(6,'(2A)') progrwn,' This is not a known keyword.'
              write(6,'(2A)') progrwn,
     .      ' Valid options are: CONstant, COOr, PDB.'
              write(6,'(A)') ' Default assumed.'
              qmasse=.false.
              typmas='CONS'
          endif
      else if (index(motinp,'FORMAT').gt.0) then
          typout=lign80(k+1:80)
          call mintomaj(typout)
          call stringcl(typout,lnom)
          if (typout(1:1).eq.'B'.or.typout(1:1).eq.'U') then
              qbinary=.true.
              typout='BINARY'
          else if (typout(1:1).ne.'F') then
              write(6,'(/3A)') progrwn,' Kind of matrix format :',
     .        typout(1:1)
              if (klist.le.0)
     .        write(6,'(2A)') progrwn,' This is not a known keyword.'
              write(6,'(2A)') progrwn,
     .      ' Valid options are: Free, Binary, Formatted, Unformatted.'
              write(6,'(A)') ' Default assumed.'
              qbinary=.false.
              typout='  FREE'
          else
              qbinary=.false.
              typout='  FREE'
          endif
      else 
          qok=.false.
          read(lign80(k+1:80),*,end=90,err=90) rinput
          if (index(motinp,'SHIFT ').gt.0) then 
               qok=.true.
               levelshft=rinput
          else if (index(motinp,'CUTOF').gt.0.or.
     .             index(motinp,'DISTANCE').gt.0) then
               qok=.true.
               cutoff=rinput
          else if (index(motinp,'HINSEN').gt.0) then
               qok=.true.
               rkh=rinput
          else if (index(motinp,'INTERAC').gt.0) then
               if (index(motinp,' FORCE ').gt.0.or.
     .             index(motinp,' CONST').gt.0) then
                   qok=.true.
                   knonb=rinput
               endif
               if (index(motinp,' CUTOF').gt.0.or.
     .             index(motinp,' DIST').gt.0) then
                   qok=.true.
                   cutoff=rinput
               endif 
          else if (index(motinp,'BOND').gt.0.and.
     .        (index(motinp,' FORCE ').gt.0.or.
     .         index(motinp,' CONST').gt.0)) then
               qok=.true.
               kbond=rinput
          else if (index(motinp,' LENGTH').gt.0) then
               qok=.true.
               cutbnd=rinput
          else if (index(motinp,'PRINT').gt.0) then
               qok=.true.
               prtlev=int(rinput)
          else if (index(motinp,'ANGLE').gt.0) then
               if (index(motinp,' FORCE ').gt.0.or.
     .             index(motinp,' CONST').gt.0) then
                   qok=.true.
                   kangle=rinput
               endif
          else if (index(motinp,'DIHE').gt.0) then
               if (index(motinp,' FORCE ').gt.0.or.
     .             index(motinp,' CONST').gt.0) then
                   qok=.true.
                   kdihe=rinput
               endif
          endif
  90      continue
          if (.not.qok) then
               write(6,'(/2A/A)') progrwn,
     .       ' No known or incomplete set of keywords in ligne:',
     .         motinp
               write(6,'(2A)') progrwn,
     .       ' This command ligne is skipped.'
          endif
      endif
      goto 50
 
 100  continue
      close(uninp)
 110  continue

      call stringcl(nompdb,lnompdb)
      call stringcl(nomlst,lnomlst)
      call stringcl(nommls,lnommls)
      call stringcl(nomvmd,lnomvmd)
      if (nomlst.eq.'none'.or.nomlst.eq.'NONE') qlist=.false.
      if (nommls.eq.'none') nommls='NONE'
      if (nomvmd.eq.'none') nomvmd='NONE'
      
      if (.not.qmtx) then
      if (qbinary) then
        nommtx="pdbmat.sdijb"
      else
        nommtx="pdbmat.sdijf"
      endif
      endif
      call stringcl(nommtx,lnommtx)

c     Resume des commandes:
c     ---------------------

      write(6,'(/3A)') program,' Coordinate filename     = ',
     .      nompdb(1:lnompdb)
      if (qlist) then
      write(6,'(3A)') program,' Neighbor-list filename  = ',
     .      nomlst(1:lnomlst)
      else
      write(6,'(/2A,F10.2)') program,
     .        ' Distance cutoff         = ',cutoff
      endif
      if (rkh.gt.0.d0)
     .write(6,'(8X,A,F10.2)') " Hinsen's typical range  = ",rkh
      write(6,'(A,F10.2)') 
     .'         Force constant          = ',knonb
      if (typbond.ne.'NONE') then
      write(6,'(A,6X,A)') 
     .'         Kind of bond definition = ',typbond(1:4)
      write(6,'(A,F10.2)') 
     .'         Maximum bond length     = ',cutbnd,
     .'         Bond force constant     = ',kbond,
     .'         Angle force constant    = ',kangle,
     .'         Dihedral force constant = ',kdihe
      endif
      write(6,'(A,6X,A)') 
     .'         Origin of mass values   = ',typmas(1:4)
      write(6,'(3A)') program,' Matrix filename         = ',
     .      nommtx(1:lnommtx)
      if (prtlev.gt.0) then
      write(6,'(2A,1PG10.1)') program,
     .        ' Levelshift              = ',levelshft
      write(6,'(A,3X,I7)') 
     .'         PRINTing level          = ',prtlev
      endif
      if (nommls.ne.'NONE')
     .write(6,'(3A)') program,' Molscript filename      = ',
     .      nommls(1:lnommls)
      if (nomvmd.ne.'NONE')
     .write(6,'(3A)') program,' VMD script filename     = ',
     .      nomvmd(1:lnomvmd)

c     Sauvegarde du fichier de commandes complet:
c     -------------------------------------------

      uninp=nunit
      nunit=nunit+1
      nomfich='pdbmat.dat_run'
      cformat="FORMATTED"
      cstatus="ove"
      call openam(nomfich,cformat,cstatus,uninp,.false.,
     .     qinter,qexist)

c     Pour etre plus clair:
      if (typbond.eq.'NONE') then
          cutbnd=0.d0
          kbond=0.d0
          kangle=0.d0
          kdihe=0.d0
      endif
      if (qlist) cutoff=-1

      write(uninp,'(2A)') 
     .'! This file can be modified and used as a command file',
     .' (named pdbmat.dat) for pdbmat.'
      write(uninp,'(2A)') ' Coordinate FILENAME        = ',
     .      nompdb(1:lnompdb)
      write(uninp,'(2A)') ' MATRIx FILENAME            = ',
     .      nommtx(1:lnommtx)
      write(uninp,'(A,F10.3,A)') ' INTERACtion DISTance CUTOF = ',
     .      cutoff,' ! For defining the list of interacting atoms.'
      write(uninp,'(A,F10.3,A)') ' INTERACtion FORCE CONStant = ',
     .      knonb,' ! For specifying frequency units.'
      if (prtlev.gt.0.or.rkh.gt.0.d0)
     .write(uninp,'(A,F10.3,A)') " HINSEN's typical range     = ",
     .      rkh,' ! Force constant weighting (if negative: none).'
      if (prtlev.gt.0.or.nomlst(1:lnomlst).ne.'NONE')
     .write(uninp,'(3A)') ' NEIGHbor-list FILENAME     = ',
     .      nomlst(1:lnomlst),
     .  ' ! For defining this list yourself.'
      write(uninp,'(A,6X,2A)') ' Origin of MASS values      = ',
     .      typmas(1:4),' ! CONstant, or from COOrdinate file.'
      write(uninp,'(A,8X,I2,A)') ' Output PRINTing level      = ',
     .      prtlev,' ! =1: more detailled. =2: debug level.'
c     Not often used:
      if (prtlev.gt.0.or.nommls(1:lnommls).ne.'NONE') 
     .write(uninp,'(3A)') ' MOLScript command FILEname = ',
     .      nommls(1:lnommls),
     .  ' ! To draw the network with Molscript.'
      if (prtlev.gt.0.or.nomvmd(1:lnomvmd).ne.'NONE') 
     .write(uninp,'(3A)') ' VMD command FILEname       = ',
     .      nomvmd(1:lnomvmd),
     .  ' ! vmd -e this-file (to visualize the network with VMD).'
c     Rarely used:
      if (prtlev.gt.0.or.typbond.ne.'NONE') then
      write(uninp,'(A,6X,2A)') ' Bond DEFINITION            = ',
     .      typbond(1:4),' ! NONe, ALL, or between CONsecutive atoms.'
      write(uninp,'(A,F10.3)') ' Maximum bond LENGTH        = ',cutbnd
      write(uninp,'(A,F10.3)') ' BOND FORCE CONStant        = ',kbond
      write(uninp,'(A,F10.3)') ' ANGLE FORCE CONStant       = ',kangle
      write(uninp,'(A,F10.3)') ' DIHEdral FORCE CONStant    = ',kdihe
      write(uninp,'(A,1PG10.1,A)') ' LevelSHIFT                 = ',
     .      levelshft,
     .  ' ! Non-zero value often required (numerical reasons).'
      write(uninp,'(A,4X,2A)') ' Matrix FORMAT              = ',
     .      typout(1:6),' ! Free, or Binary, matrix saved.'
      endif
      close(uninp)

c     Tests:
      if ((.not.qlist.and.cutoff.lt.0.d0.and.rkh.lt.0.d0).or.
     .    knonb.lt.0.d0.or.
     .   (typbond(1:4).ne.'NONE'.and.(cutbnd.lt.0.d0.or.kbond.lt.0.d0
     .   .or.kangle.lt.0.d0.or.kdihe.lt.0.d0))) then
          write(6,'(/2A)') progrer,
     .  ' Distances and force constants can not have negative values !' 
          stop '*Commands are not consistent*'
      endif

c     On recherche l'information/sous-unite:
 
      call string_split(nompdb,lnompdb,":",
     .                  mots,nmotsmax,nmots)
      call stringcl(mots(1),lnom)
 
      if (nmots.gt.1) then
          call stringcl(mots(2),lnom)
          ssusel=mots(nmots)
          write(6,'(3A)') program,' Subunit to be selected: ',ssusel
          if (nmots.gt.2) then
              write(6,'(4A)') progrwn,' The end of filename, ',
     .        nompdb(1:lnompdb),', was not understood.'
          endif
      else
          ssusel=' '
      endif
      nompdb=mots(1)
      call stringcl(nompdb,lnompdb)
c                                          
c     Lecture du fichier de coordonnees:
c     ==================================

      if (prtlev.gt.0)
     .  write(6,'(/(4A))') program,
     .' Coordinate file ',nompdb(1:lnompdb),' to be opened.'

      unpdb=nunit
      nunit=nunit+1
      cformat="FORMATTED"
      cstatus="old"
      call openam(nompdb,cformat,cstatus,unpdb,.true.,
     .     qinter,qexist)
      if (qinter) stop '*No readable coordinate file found*'

c     Format pdb ?

      nl=0
      qpdb=.false.
 120  continue
      read(unpdb,'(A)',end=130) lign80
      if (lign80(1:5).eq.'ATOM '.or.lign80(1:6).eq.'HETATM') then
          qpdb=.true.
          goto 130
      else
          nl=nl+1
      endif
      goto 120
 130  continue
      rewind(unpdb)

      do i=1,natmax
         xat(i)=unknown
         yat(i)=unknown
         zat(i)=unknown
         massat(i)=unknown
         iresat(i)=i
      enddo

      if (qpdb) then
          write(6,'(/2A)') program,
     .  ' Coordinate file in PDB format.'
          call rdatompdb(unpdb,ssusel,xat,yat,zat,massat,
     .         atonam,iresat,resnam,ssunam,segid,natmax,natom,
     .         fatres,nresmx,nres,qerror,prtlev)
          if (natom.eq.nres) then
              write(6,'(/2A)') program,' Study of a standard ENM model.'
          else
              write(6,'(/2A)') progrwn,
     .      ' Study of a several-atom-per-residue model '//
     .      '(this is not that standard).'
          endif
      else
          if (nl.eq.0) then
              write(6,'(/2A)') progrer,' Empty coordinate file.'
              stop
          endif
          write(6,'(/2A)') program,
     .  ' Coordinate file in Free format.'

          call readxyz(unpdb,xat,yat,zat,massat,iresat,natmax,natom,
     .         ndat,qerror,prtlev)

          if (qmasse.and.ndat.lt.4) then
              write(6,'(/2A)') progrer,
     .      ' Masses were not all found, as expected.'
              qmasse=.false.
          endif
      endif

c     Tests:
c     ======

      if (qerror) stop
      if (natom.le.1) then
          write(6,'(2A)') progrer,
     .  ' Not enough atoms found in file. Nothing done.'
          stop
      endif

      write(6,'(/2A)') program,' Coordinate statistics: '

      call vecstat(xat,natom,rmin,rmax,rave,rdev)
      write(6,'(4(A,F12.6))') 
     .' <x>= ',rave,' +/- ',rdev,' From: ',rmin,' To: ',rmax

      call vecstat(yat,natom,rmin,rmax,rave,rdev)
      write(6,'(4(A,F12.6))') 
     .' <y>= ',rave,' +/- ',rdev,' From: ',rmin,' To: ',rmax

      call vecstat(zat,natom,rmin,rmax,rave,rdev)
      write(6,'(4(A,F12.6))') 
     .' <z>= ',rave,' +/- ',rdev,' From: ',rmin,' To: ',rmax

      if (qmasse) then
          write(6,'(/2A)') program,' Mass statistics: '
          call vecstat(massat,natom,rmin,rmax,rave,rdev)
          write(6,'(4(A,F12.6))') 
     .  ' <m>= ',rave,' +/- ',rdev,' From: ',rmin,' To: ',rmax

          if (rmin.le.0.d0) then
              write(6,'(2A)') progrer,
     .      ' Negative or null masses found !'
              qmasse=.false.
          endif
      endif

      if (.not.qmasse) then
          write(6,'(2A)') program,' Masses are all set to one.'
          do i=1,natom
             massat(i)=1.d0
          enddo
      endif
 
c     Test/identification des residus.
 
      if (qpdb) then
      nunknown=0
      do i=1,nres
         ires=fatres(i)
         idres(i)=index(residus_standards,resnam(ires))/4
         if (idres(i).le.0) then
             nunknown=nunknown+1
             if (nunknown.lt.10) then
                 write(6,'(4A)') progrwn," residue:'",
     .           resnam(ires),"' is not a well known amino-acid."
                 idres(i)=idmax
             else if (nunknown.eq.10) then
                 write(6,'(2A)') progrwn,' ........'
                 idres(i)=idmax
             endif
         endif
      enddo
      if (nunknown.gt.0) 
     .write(6,'(/A,I6,A)') progrwn,nunknown,' residue(s) not known.'
      endif
 
DoC   Covalent bond detection: through a distance-cutoff criterium.
c     Bonds i-j and j-i are stored, because below the matrix is
c     calculated and saved three lines at a time.
 
      nbonds=0
      if (typbond.ne.' ALL'.and.typbond.ne.'CONSECUTIF') goto 200
 
      if (typbond.eq.' ALL') then
         nbmax=0
         nbmin=999
         imax=-1
         imin=-1
         k=1
         nbond(1)=1
         do i=1,natom
            do j=1,natom
               if (i.ne.j) then
                   rx=xat(i)-xat(j)
                   ry=yat(i)-yat(j)
                   rz=zat(i)-zat(j)
                   dist=dsqrt(rx*rx + ry*ry + rz*rz)
                   if (dist.le.cutbnd) then
                       jbond(k)=j
                       k=k+1
                   endif
               endif
            enddo
            nbond(i+1)=k
            if (nbond(i+1)-nbond(i).gt.nbmax) then
                nbmax=nbond(i+1)-nbond(i)
                imax=i
            endif
            if (nbond(i+1)-nbond(i).lt.nbmin) then
                nbmin=nbond(i+1)-nbond(i)
                imin=i
            endif
            if (k-1.gt.ntopmax) then
                write(6,'(/2A,I12)') progrer,
     .        ' Too many bonds. Maximum is: ',ntopmax
                stop
            endif
         enddo
         nbonds=k-1
      else if (typbond.eq.'CONSECUTIF') then
 
DoC      Even when the CONsecutif keyword is used.
c        On fait attention aux distances...
c        Il peut y avoir plusieurs molecules,
c        plusieurs chaines, dans le systeme.
 
         k=1
         do i=1,natom
            nbond(i)=k
            if (i.gt.1) then
            j=i-1
            rx=xat(i)-xat(j)
            ry=yat(i)-yat(j)
            rz=zat(i)-zat(j)
            dist=dsqrt(rx*rx + ry*ry + rz*rz)
            if (dist.le.cutbnd) then
                jbond(k)=j
                k=k+1
            endif
            endif
            if (i.lt.natom) then
            j=i+1
            rx=xat(i)-xat(j)
            ry=yat(i)-yat(j)
            rz=zat(i)-zat(j)
            dist=dsqrt(rx*rx + ry*ry + rz*rz)
            if (dist.le.cutbnd) then
                jbond(k)=j
                k=k+1
            endif
            endif
            if (k.gt.ntopmax) then
                write(6,'(/2A,I12)') progrer,
     .        ' Too many bonds. Maximum is: ',ntopmax
                stop
            endif
         enddo
         nbond(natom+1)=k
         imax=2
         imin=1
         nbmin=1
         nbmax=2
         nbonds=k
      endif
 
      if (nbonds.eq.0) then
          write(6,'(/2A/)') progrwn,' No bond found.'
          goto 200
      endif
 
      if (prtlev.gt.0)
     .write(6,'(A,I6,A,F5.2,A)') program,
     .  nbonds/2,' covalent bonds, i.e.,',
     .  float(nbonds)/float(2*natom),' per atom.'

      if (prtlev.gt.1)
     .write(6,'(A,I3,A,I6)') 
     .'         Maximum number found =',nbmax,' for atom ',imax,
     .'         Minimum number found =',nbmin,' for atom ',imin
 
DoC   Bond-ANGLes are allowed only if there are BONDs.
 
      nangles=0
      if (kangle.le.0.d0) then
          write(6,'(/2A)') program,' BOND but no ANGLe energy term.'
          goto 200
      endif

      namax=0
      namin=9999
      imax=-1
      imin=-1
      ii=1
      nangle(1)=1
      do i=1,natom
         if (nbond(i+1).gt.nbond(i)) then
         do jj=nbond(i),nbond(i+1)-1
            j=jbond(jj)
            if (nbond(j+1).gt.nbond(j)) then
            do kk=nbond(j),nbond(j+1)-1
               k=jbond(kk)
               if (k.ne.i) then
                   jangle(ii)=k
                   jsomang(ii)=j
                   ii=ii+1
               endif
            enddo
            endif
         enddo
         endif
         nangle(i+1)=ii
         if (nangle(i+1)-nangle(i).gt.namax) then
             namax=nangle(i+1)-nangle(i)
             imax=i
         endif
         if (nangle(i+1)-nangle(i).lt.namin) then
             namin=nangle(i+1)-nangle(i)
             imin=i
         endif
         if (ii.gt.ntopmax) then
             write(6,'(/2A,I12)') progrer,
     .     ' Too many angles. Maximum is: ',ntopmax
             stop
         endif
      enddo
      nangles=ii-1
 
      if (nangles.eq.0) then
          write(6,'(/2A/)') progrwn,' No bond-angle found.'
          goto 200
      endif
 
      if (prtlev.gt.0)
     .write(6,'(A,I6,A,F5.2,A)') program,
     .  nangles/2,' valence angles, i.e.,',
     .  float(nangles)/float(2*natom),' per atom.'

      if (prtlev.gt.1)
     .write(6,'(A,I3,A,I6)') 
     .'         Maximum number found =',namax,' for atom ',imax,
     .'         Minimum number found =',namin,' for atom ',imin

DoC   Bond-DIHEdrals are allowed only if there are BONDs and ANGLes.
 
      ndihs=0
      if (kdihe.le.0.d0) then
         write(6,'(/2A)') program,' ANGLes but no DIHEdral energy term.'
         goto 200
      endif

      namax=0
      namin=9999
      imax=-1
      imin=-1
      ii=1
      ndihe(1)=1
c     For each atom:
      do i=1,natom
c        All angles where it is the first atom:
         if (nangle(i+1).gt.nangle(i)) then
         do jj=nangle(i),nangle(i+1)-1
c           For the "top-atom" of this angle:
            j=jsomang(jj)
c           All angles where it is the first atom:
            if (nangle(j+1).gt.nangle(j)) then
            do kk=nangle(j),nangle(j+1)-1
               k=jangle(kk)
               if (k.ne.i.and.j.ne.jsomang(kk).and.i.ne.jsomang(kk))then
                   jdihe(ii)=k
                   ii=ii+1
               endif
            enddo
            endif
         enddo
         endif
         ndihe(i+1)=ii
         if (ndihe(i+1)-ndihe(i).gt.namax) then
             namax=ndihe(i+1)-ndihe(i)
             imax=i
         endif
         if (ndihe(i+1)-ndihe(i).lt.namin) then
             namin=ndihe(i+1)-ndihe(i)
             imin=i
         endif
         if (ii.gt.ntopmax) then
             write(6,'(/2A,I12)') progrer,
     .     ' Too many dihes. Maximum is: ',ntopmax
             stop
         endif
      enddo
      ndihs=ii-1
 
      if (ndihs.eq.0) then
          write(6,'(/2A/)') progrwn,' No bond-dihedral found.'
          goto 200
      endif
 
      if (prtlev.gt.0)
     .write(6,'(A,I6,A,F5.2,A)') program,
     .  ndihs/2,' dihedral angles, i.e.,',
     .  float(ndihs)/float(2*natom),' per atom.'

      if (prtlev.gt.1)
     .write(6,'(A,I3,A,I6)') 
     .'         Maximum number found =',namax,' for atom ',imax,
     .'         Minimum number found =',namin,' for atom ',imin

c     ==============================
c     Matrice des derivees secondes:
c     ==============================                                
 200  continue

c     Lecture eventuelle de la liste des voisins:
c     -------------------------------------------
c     Formats possibles: 
c     atom-number atom-number 
c     atom-number atom-number force-constant

      if (qlist) then
      write(6,'(/2A)') program,' Neighbor list to be read.'
      unlst=nunit
      nunit=nunit+1
      cformat="FORMATTED"
      cstatus="old"
      call openam(nomlst,cformat,cstatus,unlst,.true.,
     .     qinter,qexist)

      nvois=0
      ndat=0
 210  continue
      read(unlst,'(A)',end=230,err=220) lign80

c     Les commentaires ne sont pas pris en compte:
      kcom=index(lign80,'!') 
      if (kcom.le.0) kcom=index(lign80,'#')
      if (kcom.gt.0) then
          if (kcom.eq.1) then
              write(6,'(2A)') lign80(1:50),' ...'
              goto 210
          else
              lign80=lign80(1:kcom-1)
          endif
      endif

c     Plusieurs separateurs sont possibles: , ; ou blanc
      csep=","
      k=index(lign80,csep)
      if (k.le.0) then
          csep=";"
          k=index(lign80,csep)
      endif
      if (k.le.0) csep=" "

      call string_split(lign80,80,csep,
     .     mots,nmotsmax,nmots)
      if (nmots.lt.2) goto 225 
      if (ndat.eq.0) then
          ndat=min(nmots,3)
          if (ndat.eq.3) qfread=.true.
      endif
      if (nmots.lt.ndat) then
          write(6,'(/A,I3,A/A)') progrer,ndat,
     .  ' data per ligne until ligne: ',lign80
          goto 220
      endif

c     Lecture de: i, j (kij le cas echeant).

      read(mots(1),*) ii
      read(mots(2),*) jj
      if (qfread) read(mots(3),*) kfce

      if (ii.le.0.or.jj.le.0) then
          write(6,'(/2A)') progrer,
     .        ' Null or negative atom number found.'
          goto 225
      endif
      if (ii.gt.natom.or.jj.gt.natom) then
          write(6,'(/2A,I6,A,I6,A)') progrer,
     .  ' Atom number: ',ii,' or ',jj,
     .  ' larger than the number of atoms.'
          stop '*Wrong file*'
      endif

      nvois=nvois+1
      if (nvois.gt.nvoismx) then
          write(6,'(/2A,I6,A)') progrer,' More than ',nvoismx,
     .  ' pairs of neighbors, the maximum allowed. Sorry.'
          stop '*Recompile with larger array*'
      endif

      ivois(nvois)=ii
      jvois(nvois)=jj
      if (qfread) fvois(nvois)=kfce

c     Ligne suivante:
      goto 210

c     Probleme de lecture:
 220  continue
      write(6,'(2A,I6)') progrer,
     .    ' While reading neigbors pair: ',nvois+1
      stop '*Wrong or corrupted file*'

 225  continue
      write(6,'(2A/A)') progrer,
     .' No (or wrong) pair of atom numbers found in ligne: ',lign80
      stop '*Wrong or corrupted file*'

c     Fin du fichier:
 230  continue     
      write(6,'(/A,I6,A)') program,nvois,' pairs of neighbors.' 
      endif

c     Coordonnees et masses utilisees, sauvegardees:
c     ----------------------------------------------

      unout=nunit
      nunit=nunit+1
      nomfich="pdbmat.xyzm"
      cformat="FORMATTED"
      cstatus="ove"
      call openam(nomfich,cformat,cstatus,unout,.true.,
     .     qinter,qexist)

      do i=1,natom
         write(unout,'(4(1PG20.12),I9)')  
     .   xat(i), yat(i), zat(i), massat(i), iresat(i)
      enddo
      close(unout) 
      if (prtlev.gt.0)
     .write(6,'(2A)') program,
     .    ' Coordinates and masses considered are saved.'

c     Fichier de commandes pour VMD:
c     ------------------------------

      unvmd=-1
      if (nomvmd.ne.'NONE') then
      unvmd=nunit
      nunit=nunit+1
      nomfich=nomvmd
      cformat="FORMATTED"
      cstatus="ove"
      call openam(nomfich,cformat,cstatus,unvmd,.true.,
     .     qinter,qexist)

      write(unvmd,'(A)') '#!/usr/local/bin/vmd'
      write(unvmd,'(A)') '# script for VMD (Visual Molecular Dynamics)'
      write(unvmd,'(A)') '# Goal: visualizing the elastic network'
      write(unvmd,'(A)') '# Type: vmd -e this-file'
      write(unvmd,'(A)') 'color Display {Background} white'
      write(unvmd,'(A)') 'mol new'
      write(unvmd,'(A)') 'draw color black'
      endif

c     Fichier de commandes pour Molscript:
c     ------------------------------------

      unmol=-1
      if (nommls.ne.'NONE') then
      unmol=nunit
      nunit=nunit+1
      nomfich=nommls
      cformat="FORMATTED"
      cstatus="ove"
      call openam(nomfich,cformat,cstatus,unmol,.true.,
     .     qinter,qexist)

      write(unmol,'(A)') '! Script for Molscript (Kraulis, 1993)'
      write(unmol,'(A)') '! Goal: visualizing the elastic network'
      write(unmol,'(A)')  ' set bonddistance 99.0 ;'
      endif

c     Matrice:
c     --------

      if (qbinary) then
        if (.not.qmtx) nommtx="pdbmat.sdijb"
        cformat="UNFORMATTED"
      else
        if (.not.qmtx) nommtx="pdbmat.sdijf"
        cformat="FORMATTED"
      endif
      unout=nunit
      nunit=nunit+1
      cstatus="ove"
      call openam(nommtx,cformat,cstatus,unout,.true.,
     .     qinter,qexist)

c     ========================================
c     Les atomes sont tous lies deux a deux,
c     par un potentiel "universel" (M.Tirion).
c     ========================================
 
      elmax=0.d0
      trace=0.d0
      dmin=0.d0
      dmax=0.d0
      dmoy=0.d0
      drms=0.d0
      nnzero=0
      nntr=0
      nbig=0
      ll=0

      do i=1,natom
         ii=3*i-2
         nvoisat(i)=0

c        Liste eventuelle des voisins de i:
c        ----------------------------------

         if (qlist) then
             do j=1,natom
                qvois(j)=.false.
                kvois(j)=0.d0
             enddo
             do j=1,nvois
                if (ivois(j).eq.i) then
                    qvois(jvois(j))=.true.
                    if (qfread) kvois(jvois(j))=fvois(j)
                endif
                if (jvois(j).eq.i) then
                    qvois(ivois(j))=.true.
                    if (qfread) kvois(ivois(j))=fvois(j)
                endif
             enddo
         endif
 
c        On calcule trois lignes de la matrice a la fois:
c        -----------------------------------------------
         do j=1,3*natom
            der2(1,j)=0.d0
            der2(2,j)=0.d0
            der2(3,j)=0.d0
         enddo
 
         do j=1,natom
            if (.not.qlist.or.(qlist.and.qvois(j))) then
            if (i.ne.j) then
            jj=3*j-2
            kij=knonb
            if (qfread) kij=kvois(j) 

            rx=xat(i)-xat(j)
            ry=yat(i)-yat(j)
            rz=zat(i)-zat(j)
            dist2=rx*rx + ry*ry + rz*rz
            dist=dsqrt(dist2)
 
            if (dist.lt.rsmall) then
                write(6,'(/2A,1PG10.4,A/2(I6,2A,I6,A,1X,2A))') 
     .          progrer,' Too small distance = ',dist,
     .        ' between following atoms.',
     .          i,': ',resnam(i),iresat(i),ssunam(i),atonam(i),' and ',
     .          j,': ',resnam(j),iresat(j),ssunam(j),atonam(j)
                stop '*Wrong coordinates*'
            endif

DoC         Hinsen's version: force constant * exp(-(dist/rkh)**2.d0)
DoC        (except for topological bond force constants, e.g. ANGLes).
            if (rkh.gt.0.d0) kij=kij*exp(-(dist/rkh)**2.d0)

c           Constantes de force topologiques:
 
            if (nbonds.gt.0) then
            if (nbond(i+1).gt.nbond(i)) then
                do k=nbond(i),nbond(i+1)-1
                   if (jbond(k).eq.j) then
                       kij=kbond
                       goto 300
                   endif
                enddo
            endif
            else
            goto 300
            endif
 
            if (nangles.gt.0) then
            if (nangle(i+1).gt.nangle(i)) then
                do k=nangle(i),nangle(i+1)-1
                   if (jangle(k).eq.j) then
                       kij=kangle
                       goto 300
                   endif
                enddo
            endif
            else
            goto 300
            endif

            if (ndihs.gt.0) then
            if (ndihe(i+1).gt.ndihe(i)) then
                do k=ndihe(i),ndihe(i+1)-1
                   if (jdihe(k).eq.j) then
                       kij=kdihe
                       goto 300
                   endif
                enddo
            endif
            else
            goto 300
            endif

 300        continue
 
c           Calcul des elements: (potentiel harmonique)
c           -------------------------------------------
            if (dist.le.cutoff.or.qlist.or.
     .         (cutoff.le.0.d0.and.rkh.gt.0.d0)) then

                ll=ll+1
                nvoisat(i)=nvoisat(i)+1
                if (j.gt.i) then
                   if (unvmd.gt.0) then
                   write(unvmd,'(A,3F12.4,A,3F12.4,A)') 'draw line {',
     .             xat(i),yat(i),zat(i),'} {',xat(j),yat(j),zat(j),'}'
                   endif
                   if (unmol.gt.0) then
                   write(unmol,'(A,I6,3A)')  
     .           ' bonds require in residue ',iresat(i),', atom ',
     .             atonam(i),' and in molecule mol1 ',
     .           ' require in residue ',iresat(j),', atom ',
     .             atonam(j),' and in molecule mol1 ; '
                   endif
c                  Potentiel harmonique: 1/eval*knonb*(d - rval)**eval
                endif

                if (ll.eq.1.or.dist.lt.dmin) dmin=dist
                if (ll.eq.1.or.dist.gt.dmax) dmax=dist
                dmoy=dmoy+dist
                drms=drms+dist2

c               Elements diagonaux des blocs i et j:
c               -----------------------------------
                ddf=kij/dist2
                elemnt=rx*rx*ddf
                der2(1,ii)=der2(1,ii)+elemnt
                der2(1,jj)=der2(1,jj)-elemnt
                elemnt=ry*ry*ddf
                der2(2,ii+1)=der2(2,ii+1)+elemnt
                der2(2,jj+1)=der2(2,jj+1)-elemnt
                elemnt=rz*rz*ddf
                der2(3,ii+2)=der2(3,ii+2)+elemnt
                der2(3,jj+2)=der2(3,jj+2)-elemnt
 
c               Elements extra-diagonaux des deux blocs:
c               ---------------------------------------
                elemnt=rx*ry*ddf
                der2(1,ii+1)=der2(1,ii+1)+elemnt
                der2(2,ii)=der2(2,ii)+elemnt
                der2(1,jj+1)=der2(1,jj+1)-elemnt
                der2(2,jj)=der2(2,jj)-elemnt
                elemnt=rx*rz*ddf
                der2(1,ii+2)=der2(1,ii+2)+elemnt
                der2(3,ii)=der2(3,ii)+elemnt
                der2(1,jj+2)=der2(1,jj+2)-elemnt
                der2(3,jj)=der2(3,jj)-elemnt
                elemnt=ry*rz*ddf
                der2(2,ii+2)=der2(2,ii+2)+elemnt
                der2(3,ii+1)=der2(3,ii+1)+elemnt
                der2(2,jj+2)=der2(2,jj+2)-elemnt
                der2(3,jj+1)=der2(3,jj+1)-elemnt
            endif
            endif
            endif
         enddo
 
c        Sortie de la matrice-bande calculee:
c        -----------------------------------
c       (Uniquement la demi-matrice superieure)
 
c        Level-shift, pour eviter les zeros numeriques,
c        lors de la diagonalisation a venir 
c       (la minimisation est parfaite, par definition).
c        Le hasard est la pour lever la degenerescence
c        des six valeurs propres nulles, et differencier
c        rotations et translations.
 
         der2(1,ii)  =der2(1,ii)   + levelshft*random(iseed)
         der2(2,ii+1)=der2(2,ii+1) + levelshft*random(iseed)
         der2(3,ii+2)=der2(3,ii+2) + levelshft*random(iseed)
 
         do j=ii,3*natom
            jat=(j-1)/3+1
            if (der2(1,j).ne.0.d0) then
                nnzero=nnzero+1
                if (qbinary) then
                write(unout) 
     .          ii,j,der2(1,j)/dsqrt(massat(i)*massat(jat))
                else
                write(unout,'(2I10,1PG20.12)') 
     .          ii,j,der2(1,j)/dsqrt(massat(i)*massat(jat))
                endif
                if (dabs(der2(1,j)).gt.rbig)  nbig=nbig+1
                if (dabs(der2(1,j)).gt.elmax) elmax=dabs(der2(1,j))
            endif
         enddo
         do j=ii+1,3*natom
            jat=(j-1)/3+1
            if (der2(2,j).ne.0.d0) then
                nnzero=nnzero+1
                if (qbinary) then
                write(unout) 
     .          ii+1,j,der2(2,j)/dsqrt(massat(i)*massat(jat))
                else
                write(unout,'(2I10,1PG20.12)') 
     .          ii+1,j,der2(2,j)/dsqrt(massat(i)*massat(jat))
                endif
                if (dabs(der2(2,j)).gt.rbig) nbig=nbig+1
                if (dabs(der2(2,j)).gt.elmax) elmax=dabs(der2(2,j))
            endif
         enddo
         do j=ii+2,3*natom
            jat=(j-1)/3+1
            if (der2(3,j).ne.0.d0) then
                nnzero=nnzero+1
                if (qbinary) then
                write(unout) 
     .          ii+2,j,der2(3,j)/dsqrt(massat(i)*massat(jat))
                else
                write(unout,'(2I10,1PG20.12)') 
     .          ii+2,j,der2(3,j)/dsqrt(massat(i)*massat(jat))
                endif
                if (dabs(der2(3,j)).gt.rbig) nbig=nbig+1
                if (dabs(der2(3,j)).gt.elmax) elmax=dabs(der2(3,j))
            endif
         enddo
         elemnt=(der2(1,ii)+der2(2,ii+1)+der2(3,ii+2))/massat(i)
         if (elemnt.eq.0.d0) then
             write(6,'(2A,I6,A)') progrwn,
     .     ' Atom ',i,' has a null second derivatives...'
         else
             nntr=nntr+1
         endif
         trace=trace+elemnt
      enddo
      close(unout)

      if (unvmd.gt.0) then
          write(unvmd,'(2A)') 'mol load pdb ',nompdb(1:lnompdb)
          close(unvmd)
      endif
      if (unmol.gt.0) close(unmol)
      if (unrsd.gt.0) close(unrsd)
 
      nmoy=0.d0
      nrms=0.d0
      nmin=natom
      nmax=0
      do i=1,natom
         if (nvoisat(i).gt.nmax) nmax=nvoisat(i)
         if (nvoisat(i).lt.nmin) nmin=nvoisat(i)
         nmoy=nmoy+nvoisat(i)
         nrms=nrms+nvoisat(i)**2.d0
      enddo
      nmoy=nmoy/float(natom)
      nrms=nrms/float(natom)-nmoy**2.d0
      if (nrms.gt.0.d0) nrms=dsqrt(nrms)
 
      if (ll.eq.0) then
          write(6,'(/2A,I12,A)') progrer,
     .  ' No atom-atom interaction found. Too short cutoff ?'
          stop '*Empty matrix*'
      else
          dmoy=dmoy/float(ll)
          drms=drms/float(ll)-dmoy**2.d0
          if (drms.gt.0.d0) drms=dsqrt(drms)
      endif

      if (prtlev.gt.0)
     .write(6,'(/2A)') program,' Matrix statistics:'

      write(6,'(/2A,F8.4,A)') program,' The matrix is ',
     .  100.d0*dfloat(nnzero)/dfloat(3*natom*(3*natom+1)/2),' % Filled.'
      write(6,'(A,I12,A)') program,nnzero,'  non-zero elements.'

      if (prtlev.gt.0) then
      write(6,'(A,I12,A)') program,ll/2,' atom-atom interactions.'
      write(6,'(/2A,F9.2,A,F9.2/(A,I6))') program,
     .        ' Number per atom= ',nmoy,' +/- ',nrms,
     .'         Maximum number = ',nmax,
     .'         Minimum number = ',nmin
      write(6,'(/2A,F9.2,A,F9.2/(A,F9.2))') program,
     .        ' Average dist.  = ',dmoy,' +/- ',drms,
     .'         Maximum dist.  = ',dmax,
     .'         Minimum dist.  = ',dmin
      endif
 
      write(6,'(/2A,1PG12.6)') program,' Matrix trace   = ',trace

      if (prtlev.gt.0) then
      write(6,'(2A,1PG12.6)') program,' Larger element = ',elmax
      write(6,'(A,I6,A,1PG8.1)') program,
     .      nbig,' elements larger than +/- ',rbig
      endif
 
      write(6,'(/2A)') program,' Hessian matrix ready.'
      write(6,'(2A)') program,
     .' To diagonalize it (and get the modes),'//
     .' you may use diagstd, blzpack, diagrtb...'

      write(6,'(/2A)') program,' Normal end.'
      stop
      end
c-----------------------------------------------------------------------
      subroutine stringcl(chaine,nonblancs)
c
c     Les caracteres "blancs" de la CHAINE sont retires 
c    (a gauche et au milieu).
c     L'entier NONBLANCS donne la position du dernier caractere.
c
c     YHS-Jan-95, Toulouse.
c I/O:
      integer nonblancs
      character*(*) chaine
c Local:
      integer icar, ncar, taille
c Begin:
      taille=len(chaine)
c
      if (index(chaine(1:taille),' ').le.0) then
          nonblancs=taille
          return
      endif
c
c*****Nettoyage des blancs a gauche.
c     Premier non-blanc:
c
      do icar=1,taille
         if (chaine(icar:icar).ne.' ') goto 150
      enddo
 150  continue
      chaine=chaine(icar:taille)
c
c*****Nettoyage des blancs au milieu.
c
          icar=1
          ncar=1
 170      continue
          icar=icar+1
          ncar=ncar+1
          if (chaine(icar:icar).eq.' ') then
              chaine=chaine(1:icar-1)//chaine(icar+1:taille) 
              icar=icar-1
          endif
          if (ncar.lt.taille-1) goto 170
c
      nonblancs=index(chaine,' ')-1
c
      return
      end
c-----------------------------------------------------------------------
      subroutine string_split(chaine,taille,delimiteur,
     .                        souschaine,nbremax,nbre)
c
c     "Chaine" est coupee en "nbre" "souschaine" de part et d'autre du
c     "delimiteur"
c      YHS-Sep-93, Uppsala
c I/O:
      integer taille, nbremax, nbre
      character*(*) chaine, souschaine(*), delimiteur
c Local:
      integer icar, iprev
c
      nbre=1
      iprev=1
      souschaine(1)=chaine
      do icar=1,taille
         if (chaine(icar:icar).eq.delimiteur) then
            if (icar-1.ge.iprev) then
               souschaine(nbre)=chaine(iprev:icar-1)
               nbre=nbre+1
               if (nbre.le.nbremax) then
                  if (icar+1.le.taille.and.
     .               chaine(icar+1:taille).ne.' ') then
                     souschaine(nbre)=chaine(icar+1:taille) 
                  else
                     nbre=nbre-1
                     return
                  endif
               else
                  write(6,'(A,I6,A/A)') 
     .               ' %String_split-Err: more than ',nbremax,
     .               ' substrings in : ',chaine
                  return
               endif
            endif
            iprev=icar+1
         endif
      enddo
c
      return
      end
c-----------------------------------------------------------------------
      subroutine openam(namfil,cformat,cstatus,unit,qverbos,
     .                  qinterr,qexist)
c
c     Ouverture d'un fichier de nom NAMFIL, sur l'unite UNIT,
c     a priori suite a une interrogation...
c
c     input:
c        namfil: nom du fichier a ouvrir. 
c        "stop", "end", "fin", "quit" : arretent le programme.
c        cstatus: mots-cles fortran... ou "OVE" pour overwrite.
c     output: 
c        qexist: flag / existence du fichier 
c        qinterr: Pas de nom pour le fichier cherche.
c I/O:
      logical qinterr, qverbos, qexist
      integer unit
      character*(*) namfil, cformat, cstatus
c Local
      integer lnom
      character*132 ordrunix
c begin:
      if (cstatus.eq.'old') cstatus='OLD'
      if (cstatus.eq.'new') cstatus='NEW'
      if (cstatus.eq.'ove') cstatus='OVE'
      if (cstatus.eq.'unknown') cstatus='UNKNOWN'
c
      qinterr=.false.
      qexist=.false.
c
      if (namfil.eq.' ') then 
          qinterr=.true.
          write(6,'(A)') '%Openam-Err> No filename.'
          return
      endif
c
      if (namfil.eq.'stop'.or.namfil.eq.'end'                         
     &    .or.namfil.eq.'fin'.or.namfil.eq.'quit') then 
         write(6,'(2A)') 'Openam> Program is stopping on user request.'
         stop                                                                   
      endif 
 
c     Checks if filename is consistent with the opening:

      call stringcl(namfil,lnom)

      inquire(file=namfil,exist=qexist)
      if (.not.qexist.and.cstatus.eq.'OLD') then
          qinterr=.true.
          if (qverbos) then
              write(6,'(/2A)') '%Openam-Err> File: ',namfil(1:lnom)
              write(6,'(A)') 
     .      ' Expected in the current directory, but not found.'
          endif
          return
      endif

      if (qexist.and.cstatus.eq.'NEW') then
         write(6,'(/2A)') 
     .      '%Openam-Err> This file exists:',namfil(1:lnom)
         stop
      else if (qexist.and.cstatus.eq.'OVE') then
         ordrunix='rm '//namfil
         call system(ordrunix)
      endif
      if (cstatus.eq.'OVE') cstatus='NEW'

      open(file=namfil,form=cformat,
     .     status=cstatus,unit=unit)                

      if (qverbos) then
         write(6,'(/2A)') ' Openam> File opened: ',namfil(1:lnom)
      endif

      return                                                                       
      end
c-----------------------------------------------------------------------
      subroutine rdatompdb(unpdb,ssusel,xat,yat,zat,binfo,
     .           atonam,iresat,resnam,ssunam,segid,natmax,natom,
     .           fatres,nresmx,nres,qerror,prtlev)
 
c     Lecture ligne a ligne d'un fichier pdb.
c     Uniquement les lignes commencant par 'ATOM'.
c     Uniquement ceux de la sous-unite selectionnee.
 
c     fatres(i): numero du premier atome du residu i.
 
c     YHS-nov-1996: version 1.0 (Toulouse).
c     YHS-sep-2004: version 1.1 (Lyon).
 
      implicit none
cI/O:
      integer unpdb, natmax, iresat(*), natom,  lnom,
     .        nresmx, nres, fatres(*), prtlev
      double precision xat(*), yat(*), zat(*), binfo(*)
      logical qerror
      character*4 atonam(*), resnam(*), segid(*)
      character*1 ssusel, ssunam(*)
cLocal:
      integer iatom, irs, irsprev, nerr, ntit,
     .        i, j, k, ii
      double precision bfact, x, y, z
      character*1  ssu
      character*4  ren, segat
      character*5  atncur
      character*80 lign80
cBegin:
      if (prtlev.gt.0)
     .write(6,'(/A)') ' Rdatompdb> Reading pdb file.'

      qerror=.false.
      nerr=0
 
      irsprev=-1
      ntit=0
      nres=0
      iatom=0
 105  continue   
      read(unpdb,'(A)',end=200,err=110) lign80 
  
      goto 120                                
 110  continue
      nerr=nerr+1                            
 
 120  continue                              
c     if (lign80(1:4).eq.'ATOM') then
      if (lign80(1:4).eq.'ATOM'.or.lign80(1:6).eq.'HETATM') then
      read(lign80,'(12X,A4,1X,A4,A1,I4,4X,3F8.3,6X,F6.2,6X,A4)',
     .            end=130,err=130) 
     .            atncur, ren, ssu, irs, x, y, z, 
     .            bfact, segat 
 130  continue
      if (iatom.lt.natmax) then
          if (ssu.eq.ssusel.or.ssusel.eq.' ') then
          iatom=iatom+1
          xat(iatom)=x
          yat(iatom)=y
          zat(iatom)=z
          binfo(iatom)=bfact
 
          call stringcl(atncur,lnom)
          atonam(iatom)=atncur
          call stringcl(ren,lnom)
          resnam(iatom)=ren
          iresat(iatom)=irs
          ssunam(iatom)=ssu
          segid(iatom)=segat
 
          if (irs.ne.irsprev) then
              nres=nres+1
              if (nres.gt.nresmx) then
                  write(6,'(A/A,I6)') 
     .          '%Rdatompdb-Er> Too many residues in this file.',
     .          ' Maximum allowed is = ',nresmx
                  stop
              endif
              irsprev=irs
              fatres(nres)=iatom
          endif
          endif
      else
          write(6,'(A/A,I6)') 
     .      '%Rdatompdb-Er> Too many atoms in this file.',
     .      ' Maximum allowed is = ',natmax
          stop
      endif
      else if (lign80(1:6).eq.'REMARK'.and.prtlev.gt.0) then
          ntit=ntit+1
          if (ntit.le.10) then
              write(6,'(A)') lign80
          else if (ntit.eq.11) then
              write(6,'(A)') ' .... '
          endif
      endif
 
c     2) Ligne suivante du fichier pdb :
 
      goto 105
 
c     3) Fin de la lecture du fichier pdb :
 
 200  continue 
      if (prtlev.gt.1) then
      write(6,*) 'Rdatompdb> End of file reached.'
      write(6,*) 'Rdatompdb> Number of I/O errors: ',
     .            nerr
      endif
 
      natom=iatom
      fatres(nres+1)=natom+1
      irs=0
      if (natom.gt.0) irs=iresat(natom)
 
      write(6,'(/(A,I6))') 
     .' Rdatompdb> Number of residues found = ',nres,
     .'            First residue number     = ',iresat(1),
     .'            Last  residue number     = ',irs,
     .'            Number of atoms found    = ',natom
      if (prtlev.gt.0)
     .write(6,'(A,F8.1)') 
     .'            Mean number per residue  = ',float(natom)/float(nres)
 
      if (natom.eq.0) then
          write(6,'(A)')
     .  '%Rdatompdb-Er> No atom found in file.'
          qerror=.true.
      endif
      if (nres.eq.0) then
          write(6,'(A)')
     .  '%Rdatompdb-Er> No residue found in file.'
          qerror=.true.
      endif
 
      return
      end
c-----------------------------------------------------------------------
      subroutine mintomaj(chaine)
 
c     Les caracteres minuscules sont mis en MAJUSCULES.
c     Les autres ne sont pas touches.
 
c     YHS-Oct-98: Premiere version (Toulouse).
c     YHS-Sep-03: Dernieres modifications (Lyon).
 
      character*(*) chaine
c Local:
      integer icar, ilettre, taille
      character*26  carmaj, carmin
 
      carmin='qwertyuiopasdfghjklzxcvbnm'
      carmaj='QWERTYUIOPASDFGHJKLZXCVBNM'
 
      taille=len(chaine)
      if (taille.le.0) return

      do icar=1,taille
         ilettre=index(carmin,chaine(icar:icar))
         if (ilettre.gt.0) then
             chaine(icar:icar)=carmaj(ilettre:ilettre)
         endif
      enddo
 
      return
      end
c-----------------------------------------------------------------------
      subroutine readxyz(uninp,x,y,z,w,ic,nmax,ncoor,ndat,qerror,prtlev)

c     Reads at most NMAX coordinates in free format. 

c     Either:
c     x, y, z
c     or:
c     x, y, z, w
c     or:
c     x, y, z, w, ic

c     If first word in ligne is not a number, the whole ligne is
c     assumed to be a title or a commentary.

c     YHS-Sep-03: First version (Lyon).

cI/O:
      logical qerror
      integer ic(*), ncoor, ndat, nmax, prtlev, uninp
      double precision w(*), x(*), xc, y(*), yc, z(*), zc
cLocal:
      integer nmotsmax
      parameter(nmotsmax=255)

      integer i, lmot, nchi, nlmax, nl, nlu, nmots, stats(0:nmotsmax)
      double precision rlu
      character chiffres*15, lignlg*(nmotsmax), 
     .        mots(nmotsmax)*(nmotsmax), program*9, progrer*11, 
     .        progrwn*11

cBegin:
      program=' Readxyz>'
      progrer='%Readxyz-Er>'
      progrwn='%Readxyz-Wn>'

      chiffres='1234567890.eE+-'

      do i=1,nmotsmax
         stats(i)=0
      enddo

c     Lecture ligne a ligne:
c     ----------------------

      if (prtlev.gt.1) write(6,'(/2A)') program,
     .  ' Comments, or lignes with less than three numbers: '

      qerror=.false.
      ncoor=0
      nl=0
 100  continue
      read(uninp,'(A)',end=200) lignlg 
      nl=nl+1
      call string_split(lignlg,nmotsmax," ",mots,nmotsmax,nmots)

      nfound=0
      do i=1,nmots
         call stringcl(mots(i),lmot)
         if (lmot.le.0) goto 150

c        Commentaire ?
         if (mots(i)(1:1).eq.'!') goto 150

c        Chiffre ?

         do k=1,lmot
            if (index(chiffres,mots(i)(k:k)).le.0) goto 110
         enddo

         nfound=nfound+1

         if (nfound.le.4) then
             read(mots(i)(1:lmot),*,err=110) rlu
             if (nfound.eq.1) xc=rlu
             if (nfound.eq.2) yc=rlu
             if (nfound.eq.3) zc=rlu
             if (nfound.eq.4) wc=rlu
         else if (nfound.eq.5) then 
             read(mots(i)(1:lmot),*,err=110) nlu
         endif

c        Mot suivant:
 110     continue

c        Le premier mot n'est pas un chiffre => ligne de commentaires

         if (nfound.eq.0) goto 150
      enddo
 150  continue

c     Stockage des coordonnees:
c     -------------------------

      stats(nfound)=stats(nfound)+1

      if (nfound.ge.3) then
          ncoor=ncoor+1
          if (ncoor.le.nmax) then
              x(ncoor)=xc
              y(ncoor)=yc
              z(ncoor)=zc
              if (nfound.eq.4) then
                  w(ncoor)=wc
              else
                  w(ncoor)=wc
                  ic(ncoor)=nlu 
              endif
          else
              write(6,'(/2A,I9,A)') progrer,' More than ',
     .        nmax,' particles in file.'
              write(6,'(2A)') progrer,
     .      ' Please increase program memory limits (Sorry for that).'
              stop
          endif
      else
          if (prtlev.gt.1) then
              write(6,'(2A)') lignlg(1:72),'...'
          endif
      endif
      
c     Ligne suivante:
      goto 100
 200  continue
      if (prtlev.gt.1.and.nl.eq.ncoor) write(6,'(2A)') program,' None.'

      write(6,'(/2A,I7)') program,
     .' Number of particles in file (with x,y,z coordinates): ',ncoor
 
      if (ncoor.eq.0) then
          write(6,'(/2A)') progrer,' No coordinate found in file.'
          qerror=.true.
      endif

      nchi=0
      ndat=0
      nlmax=0
      do i=1,nmotsmax
         if (stats(i).gt.0) nchi=nchi+1
         if (stats(i).gt.nlmax) then
             nlmax=stats(i)
             ndat=i
         endif
      enddo

      do i=0,nmotsmax
         if (stats(i).gt.0.and.(prtlev.gt.1.or.nchi.gt.1)) then
            write(6,'(A,I6,A,I7,A)') program,i,
     .    ' numbers found in ',stats(i),' lignes.'  
         endif
      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine vecstat(vect,nmax,rmin,rmax,rave,rdev)

c     Statistics for vector Vect(NMAX):
c     minimum, maximum, average (rave) and standard deviation (rdev).

c     YHS-Sep-03: First version (Lyon).

cI/O:
      integer nmax
      double precision rave, rdev, rmax, rmin, vect(*)
cLocal:
      integer i
      character program*9, progrer*11, progrwn*11

cBegin:
      program=' Vecstat>'
      progrer='%Vecstat-Er>'
      progrwn='%Vecstat-Wn>'

      rave=0.d0
      rdev=0.d0
      rmin=-9999.d0
      rmax=9999.d0

      if (nmax.le.0) then
          write(6,'(2A)') progrer,' Zero-length vector.'
          return
      endif

      do i=1,nmax
         if (vect(i).gt.rmax.or.i.eq.1) rmax=vect(i)
         if (vect(i).lt.rmin.or.i.eq.1) rmin=vect(i)
         rave=rave+vect(i)
         rdev=rdev+vect(i)**2.0
      enddo

      rave=rave/dfloat(nmax) 
      rdev=rdev/dfloat(nmax)-rave*rave
      if (rdev.gt.0.d0) rdev=dsqrt(rdev)

      return
      end
C-----------------------------------------------------------------------
      REAL*8 FUNCTION RANDOM(ISEED)
C-----------------------------------------------------------------------
C     RANDOM NUMBER GENERATOR: UNIFORM DISTRIBUTION (0,1)
C     ISEED: SEED FOR GENERATOR. ON THE FIRST CALL THIS HAS TO
C     HAVE A VALUE IN THE EXCLUSIVE RANGE (1, 2147483647)
C     AND WILL BE REPLACED BY A NEW VALUE TO BE USED IN
C     FOLLOWING CALL.
C
C     REF: Lewis, P.A.W., Goodman, A.S. & Miller, J.M. (1969)
C     "Pseudo-random number generator for the System/360", IBM
C     Systems Journal 8, 136.
C
C     This is a "high-quality" machine independent generator.
C     INTEGERS are supposed to be 32 bits or more.
C     The same algorithm is used as the basic IMSL generator.
C
C     Author: Lennart Nilsson
C
      implicit none
      INTEGER ISEED
      REAL*8 DSEED,DIVIS,DENOM,MULTIP
      DATA  DIVIS/2147483647.D0/
      DATA  DENOM /2147483711.D0/
      DATA  MULTIP/16807.D0/
C
      IF(ISEED.LE.1) ISEED=314159
      DSEED=MULTIP*ISEED
      DSEED=MOD(DSEED,DIVIS)
      RANDOM=DSEED/DENOM
      ISEED=DSEED
C
      RETURN
      END
nma/ElNemo/README_checkmode0000644000175000017500000000520413560574345014747 0ustar  guestguest_______________________

Analyzing normal modes.
_______________________

The normal mode file format must be the "CERFACS" one,
as produced by the programs diagstd, diagrtb or Blzpack.
(diagstd is provided with pdbmat, for computing modes
using Tirion's model)

*****************
A few references:
*****************

M.M. Tirion (1996):
"Large amplitude elastic motions in proteins from
a single-parameter, atomic analysis",
Phys. Rev. letters vol.77(9), p1905-1908.

I. Bahar, A.R., Atilgan, B. Erman, B (1997):
"Direct evaluation of thermal fluctuations in proteins
using a single-parameter harmonic potential",
Folding & Design vol.2, p173-181.

K. Hinsen (1998):
"Analysis of domain motions by approximate normal mode calculations",
Proteins vol.33, p417-429.

F. Tama, Y.H. Sanejouand (2001):
"Conformational change of proteins arising 
from normal modes calculations"
Protein Engineering vol.14, p1-6.

M. Delarue , Y.H. Sanejouand (2002): 
"Simplified normal mode analysis of conformational transitions in
DNA-dependant polymerases: the Elastic Network Model", 
J. Mol. Biol. vol.320, p1011-1024. 
 
*********
PROGRAMS: 
*********

To compile them:
----------------
Under Linux, just type:
COMPILE
Otherwise, you have to modify the Makefile:
Get rid of the "#" corresponding to your computer, and add some
to the lines corresponding to the Linux case.

What they do:
-------------

bfactors:
       Harmonic B-factors from modes.
       Output: "bfactors.pred".

rms_mode:
       Pick a normal mode.
       Outputs: "rmsmod.res" and "eigvec.res".

proj_modes: 
       Project a "reference structure->other conformer vector" on modes.
       Can displace a structure along a given normal mode.
       Outputs: "dr.res" and "projmod.res".

       Remember that if the reference structure is the one for which 
       modes have been calculated -with the same associated atomic masses !-
       and if there is not net global translation or rotation
       between the "other conformer" and the "reference structure",
       that is, if the "other conformer" has been fitted on the
       "reference structure", using the Profit program for instance,
       which is available on the Web, then, projections on the six 
       rotation-tranlation modes should be numerically null)

check_modes:
       Check eigenvector norms (has to be one).
       Yields the degree of collectivity for each eigenvector. 
       Output: "Chkmod.res".

traj_modes:
       Yields trajectories corresponding to normal mode motions,
       in "CHARMM" format (.DCD).
      (this is an old program, presently in a bad shape)

trans_modes:
       Translates a "CHARMM" normal mode file into a "CERFACS" one.

nma/ElNemo/README_diagrtb0000644000175000017500000000747013560574345014450 0ustar  guestguest    ----------------------------------------------------------------
    DIAGRTB: DIAGonalisation of a matrix with the RTB approximation.
    ----------------------------------------------------------------

    Principles:
    ***********
    Required eigenvectors are supposed to be well
    described by rigid body motions (Rotations-Translations)
    of blocks of atoms buildt with sets of consecutive
    residues, as defined in the corresponding coordinate 
    file. 
    
    Coordinates are necessary in order to define this new set of 
    coordinates (the rotations and translations of the rigid bodies).
 
    The program was designed for treating mass-weighted second-derivatives
    of the potential energy matrix (the Hessian), obtained
    for proteins (hence the PDB format for the coordinates).     
    It should work for any kind of system where consecutive
    particules (in the coordinate file) are expected to move
    almost in the same direction and with almost the same amplitude
    in the modes corresponding to the lowest (or highest) eigenvalues
    (that is, modes with a collective character). 

    To compile diagrtb: 
    *******************
    If you are under Linux, with a FORTRAN compiler available, 
    just type "make diagrtb". 
    Otherwise, compile diagrtb.f as you are used to...

    Next, to test the executable, go to the Try_diagrtb directory,
    and type "TRYME".

    Note that:
    **********
    Diagrtb reads its commands in the diagrtb.dat file.
    Also, each run of diagrtb produces a diagrtb.dat_run file,
    where all parameter values are given (and commented).
    diagrtb.dat_run can be used as a diagrtb.dat file,
    in further runs.

    The input matrix is assumed to be:
    a) real, square and symmetrical.
    b) in the following format: i, j, i-j-matrix-element

    The input coordinate file can be in:
    a) Protein DataBank (PDB) format.
    b) x, y, z, mass, block-number format.

    Output: 
    *******
    diagrtb.eigenrtb, with the eigenvalues and
    eigenvectors, in x,y,z "CERFACS" format.
 
    Memory requirements:
    ********************
    Though diagrtb is designed to handle large matrices,
    there are some memory limits, mainly related to the
    size of the largest block in your system.

    Here, in diagrtb.f, "lrwork" has been set to 32000000.
    You may have to lower this value, if your computer has
    too little memory. If your system is too large, 
    you may try to increase "lrwork", or "liwork" 
    if the program complains about it. 
    But you may also try to modify the number of residues 
    per block in diagrtb.dat.

    WARNING:
    ********
    Temporary diagrtb_work.* files are created during each
    program run.

    So, avoid running several diagrtb simultaneously, in the same
    directory !

    References: 
    ***********
    1) P. Durand, G. Trinquier, Y.H. Sanejouand (1994):
   "A new approach for determining low-frequency
    normal modes in macromolecules", 
    Biopolymers vol.34, p759-771.
 
    2) F. Tama, F.X. Gadea, O. Marques, Y.H. Sanejouand (2000):
   "Building-block approach for determining 
    low-frequency normal modes of macromolecules", 
    Proteins: Structure, Function, and Genetics vol.41(1), p1-7.

    3) G. Li, Q. Cui (2002):
   "A coarse-grained normal mode approach for macromolecules: an
    efficient implementation and application to Ca(2+)-ATPase",
    Biophys. J. vol.83, p2457-2474.

    In the later paper, RTB is called BNM (for Block-Normal-Modes).
    It is more general (flexible blocks are allowed).
    It is now available in the CHARMm package (since version 32).

    Version 2000 by Florence Tama (ftama@scripps.edu).
    Modified since then by: Osni Marques, Yves-Henri Sanejouand.
    November 2004: last modifications.
 
    In case of problem, feel free to contact: 
    Yves-Henri.Sanejouand@ens-lyon.fr
nma/ElNemo/README_pdbmat0000644000175000017500000002120613560574345014274 0ustar  guestguest=====================================================================
   To compute an hessian for an ENM: use pdbmat.
   To diagonalize the hessian: use diagstd.
   To look at one of the so calculated normal modes: use rms_mode.
   Try them in that order in the ../Try_ENM_v3.73 directory.
=====================================================================
   -------
   Pdbmat:
   -------
   Computes the mass-weighted second derivatives energy matrix,
   using Tirion's model, that is, an elastic network model (ENM).
   In such models, close particles (atoms) are linked by springs.

   In Tirions's model, springs are set between atoms less than 
   CUToff Angstroms away from each others.

   In Hinsen's version, springs are weighted by exp(-dij/rkh)**2.
   Herein, both kind of typical distances (cutoff & rkh) can be mixed.

   Goal: Computing the low-frequency (collective) normal modes 
   of vibration of the system.

   To do so, the matrix produced by pdbmat has to be diagonalized
   with a program like DIAGSTD or, for large systems, DIAGRTB,
   BLZPACK, etc.

=====================================================================

   INPUT: 
   ******
  -A parameter file named pdbmat.dat.  

   Note that each run of pdbmat produces a pdbmat.dat_run file,
   where parameter values are shown (and shortly commented).
   pdbmat.dat_run can be modified and used as a pdbmat.dat file, 
   for further runs. 
   So, the simplest is to compile and run pdbmat...
   and have a look at the pdbmat.dat_run file so produced.
   If you want to see there the syntax of other available commands,
   just raise the PRINting level.

  -Among the parameters: 

  *The name of a file with the coordinates of the system, 
   in FREE or PDB (protein data bank) format.

   Free format: x, y, z, mass.
   PDB  format: Only lignes with the ATOM keyword are considered.
        Masses can be given in the Bfactors column.
   Note that masses can be read, but they are not required.
   In the later case, they are all set to 1.0 (as often done).

  *A way to identify pairs of neighbors:
   Either a CUTOFF value (standard Tirion's model)
   Or a file with a list of pairs of neighbors.
   Format of each ligne of this later file: atom-number atom-number

   Alternatively, Hinsen's version can be used.

   For one-atom-per-residue protein models, typical values are:
   Tirion's distance cutoff = 10-12 Angstroms.
   Hinsen's typical range   = 3 Angstroms.

   OUTPUT:
   *******

  -Default output matrix filename:
   Formatted file: pdbmat.sdijf 
   Binary    file: pdbmat.sdijb 

   This is a matrix in format: i, j, non-zero-i-j-matrix-element

  -Output coordinate filename (in free format):
   pdbmat.xyzm

   This is a coordinate file with, for each atom: 
   x, y, z, mass, block-number
   For a pdb file, the block-number is the amino-acid residue number
  (it is of use only in other programs like DIAGRTB).

   More specialized ones:
   ----------------------

  -VMD-command filename: 
   pdbmat.vmd

   This is a command file for vizualising the elastic network
   with VMD, the Visual Molecular Dynamics program (v1.8):
   vmd -e pdbmat.vmd 
   But if you just want to vizualise a standard ENM (defined with
   a cutoff distance), there are more efficient (faster) ways.

  -Molscript-command-file:
   pdbmat.molscript

   This is a command file for vizualising the elastic network
   with Molscript (v2.1).
   molscript < pdbmat.molscript > pdbmat.ps
   But if you just want to vizualise a standard ENM (defined with
   a cutoff distance) with Molscript, there are much faster ways.

.....................................................................
   This is a fortran 77 program, so it has predefined:

   **************
   MEMORY LIMITS:
   **************

   NATMAX  :  Maximum number of atoms (particles).
   NRESMX  :  Maximum number of residues (groups of particles).
   NVOISMX :  Maximum number of pairs of neighbors.  

   Increase them if needed. To (re)compile pdbmat, type:
   make pdbmat
   or:
   g77 -o pdbmat pdbmat.f
   or use your favorite fortran compiler (instead of g77).
.....................................................................

   ABOUT Tirion's model:
   *********************

   Principe du modele (Tirion, 1996): 
   
   Tous les atomes a moins de "cutoff" les uns des autres 
   sont supposes lies par des ressorts, qui ont tous
   la meme raideur.
   Simplification supplementaire par rapport au modele initial: 
   les atomes sont supposes avoir tous la meme taille
  (le cutoff est le meme pour toutes les paires d'atomes).
   On peut de plus poser qu'ils ont tous la meme masse.
   Sinon, celles-ci sont lues dans la colonne des 
   facteurs B du fichier pdb.

   Principaux resultats:

   Les modes de vibration de basse frequence obtenus
   a partir d'un tel modele sont tres voisins de ceux
   obtenus avec un modele beaucoup plus detaille, tels
   ceux utilises lors des etudes de Dynamique Moleculaire.

   Dans le cas ou le mouvement fonctionnel d'une proteine est un 
   mouvement d'ensemble (collectif), on constate qu'il peut tres 
   souvent etre decrit comme une combinaison lineaire de quelques
   uns de ces modes (de un a trois).

   Principaux avantages:

   Pas besoin de prendre en compte tous les atomes.
   Pas besoin de minimisation d'energie prealablement
   au calcul des modes de vibration (E=0 par construction).

.....................................................................

   MAIN REFERENCES:
   ****************

   1) M.M. Tirion (1996):
  "Large amplitude elastic motions in proteins from
   a single-parameter, atomic analysis",
   Phys. Rev. letters vol.77(9), p1905-1908.

   2) K. Hinsen (1998):
  "Analysis of domain motions by approximate normal mode calculations"
   Proteins vol.33, p417-429.

   3) F. Tama, Y.H. Sanejouand (2001):
  "Conformational change of proteins arising 
   from normal modes calculations"
   Protein Engineering vol.14, p1-6.

   4) A.R. Atilgan, S.R. Durell, R.L. Jernigan, M.C. Demirel,
   O. Keskin, I. Bahar (2001):
  "Anisotropy of Fluctuation Dynamics of Proteins with an Elastic 
   Network Model"
   Biophys Journal vol.80, p.505-515.

   5) S. Nicolay, Y.H. Sanejouand (2006):
  "Functional modes of proteins are among the most robust"
   Phys. Rev. letters vol.96, p078104.

   In case of problem, feel free to contact: 
   Yves-Henri.Sanejouand@ens-lyon.fr
  (bug reports may help you, but also others)

.....................................................................
   New features since the previously released version (v3.50):
  -The list of pairs of neighbors can be read in a file.
  -The elastic network can be visualized, using VMD or Molscript.
  -The output format has been extended.
  -Hinsen's weight added.
  -Bond-dihedral energy term added (1-4 bond, dihedral-like). 
  -DoCumentation included in the code.
.....................................................................
   Specific details:
   Covalent bond detection: through a distance-cutoff criterium.
      Even when the CONsecutif keyword is used.
   Bond-ANGLes are allowed only if there are BONDs.
   Bond-DIHEdrals are allowed only if there are BONDs and ANGLes.
         Hinsen's version: force constant * exp(-(dist/rkh)**2.d0)
        (except for topological bond force constants, e.g. ANGLes).
====================================================================
   --------
   diagstd:
   --------
   Diagonalization of a matrix, real, symmetrical.

   Diagonalization routine: TQLI (EISPACK).
  -simple, public domain, but slow (ALL eigenvectors are computed).

====================================================================

   INPUT matrix filename (expected from, e.g., PDBMAT program):
   ************************************************************
   CERFACS -Formatted : matrix.sdijf
   CERFBIN -Binary    : matrix.sdijb

   Input matrix format: i, j, non-zero-ij-element.

   It can start with a title, recognized by: 
   !,# in first column, or 'program-name>' as first word.

   OUTPUT:
   *******
   Eigenvector filename: matrix.eigenfacs (in CERFACS format)

.....................................................................

   MEMORY LIMITS:
   **************
   NATMAX: Maximum number of atoms allowed.

.....................................................................
   Eigenvector are given by increasing eigenvalues (LOWE).

   TRED2 and TQLI (based on the original EISPACK library) 
   perform a diagonalization of a real symmetric matrix based 
   on the QL algorithm. 
=====================================================================
   ---------
   rms_mode:
   ---------
   For a set of CERFACS vectors.
   Extracts one of them. 
   Gives the amplitude of each atom displacement.

=====================================================================
nma/ElNemo/check_modes.f0000644000175000017500000003177014030637620014474 0ustar  guestguest      program Chkmod
c
c     Pour un ensemble de vecteurs CERFACS.
c     Collectivite des modes=f(frequence)
c
c     YHS-Mai-2001: Premiere version, from rms_mode, v1.16.
c
      implicit none
      integer  natmax, nvecmx
      parameter(natmax=250000,nvecmx=200)
      integer i, ii, ivec, j, jj, k,
     .        lnomeig, natom, nddl,
     .        numvec(natmax), nunit, nvec,
     .        uneig, unout 
      double precision coll, freq(3*natmax), 
     .       matvec(3*natmax,nvecmx),
     .       norme, normtot, rsmall
      logical qinter, qexist, qok
      character*8  program
      character*10 cformat, cstatus
      character*11 progrwn, progrer
      character*40 version
      character*64 namfil, nomeig
c
      version=' Version 1.00, Bordeaux.'
      program=' Chkmod>'
      progrwn='%Chkmod-Wn>'
      progrer='%Chkmod-Er>'
c
      rsmall=1e-4
c
      write(6,'(2A)') program,version
c
      call getnam('Eigenvector filename ?',nomeig,lnomeig,qok)
      if (.not.qok) stop
c
      nunit=10
      uneig=nunit
      nunit=nunit+1
      cformat="FORMATTED"
      cstatus="old"
      call openam(nomeig,cformat,cstatus,uneig,.true.,
     .            qinter,qexist)
      if (qinter.or..not.qexist) stop
c
c     Lecture:
c     -------
      call rdmodfacs(uneig,3*natmax,nvecmx,numvec,freq,
     .               matvec,nddl,nvec)
      natom=nddl/3
c
      write(6,'(/A,I5,A,I6,A)') program,
     .      nvec,' vectors, ',nddl,' coordinates in file.'
      write(6,'(A,5X,A,I6,A)') program,
     .    ' That is: ',natom,' cartesian points.'
c
      if (nvec.le.0.or.natom.le.0) then
          write(6,'(2A)') progrer,' Wrong vector file.'
          stop
      endif
c
c     Sortie:
c     ------
      namfil='Chkmod.res'
      unout=nunit
      nunit=nunit+1
      cformat="FORMATTED"
      cstatus="ove"
      call openam(namfil,cformat,cstatus,unout,.true.,
     .            qinter,qexist)
c
      write(6,'(2A)') program,
     .' Collectivity=f(frequency) to be written in this file.'
c
      do ivec=1,nvec
c
      normtot=0.d0
      do i=1,natom
         ii=3*i-2
         norme=matvec(ii,ivec)**2.d0+
     .         matvec(ii+1,ivec)**2.d0+
     .         matvec(ii+2,ivec)**2.d0
         normtot=normtot+norme
      enddo
c
      if (normtot.le.rsmall) then
         write(6,'(2A,I5,A)') progrer,
     . ' Vector ',ivec,' has a null norm.'
         stop
      endif 
      if (dabs(normtot-1.d0).gt.rsmall) then
         write(6,'(2A,I5,A,F8.4,A)') progrwn,
     . ' Norm of vector ',ivec,' is: ',normtot,
     .' (instead of 1.0000). '
      endif 
c     
      coll=0.d0
      do i=1,natom
         ii=3*i-2
         norme=matvec(ii,ivec)**2.d0+
     .         matvec(ii+1,ivec)**2.d0+
     .         matvec(ii+2,ivec)**2.d0
         norme=norme/normtot
         coll=coll+norme*log(norme)
      enddo
      coll=exp(-coll)/dfloat(natom)
c
      write(unout,'(2F12.4)') freq(ivec), coll
c
c     Vecteur suivant: 
      enddo
c
      write(6,'(/2A)') program,' Normal end.'
c
      stop
      end
c
c     Questions/reponses.
c     Serie de routines utilitaires:
c     getnam
c     Version 1.3, Bordeaux.
c
      subroutine getnam(message,nomlu,lnomlu,qok)
c
c     NOMLU obtenu en reponse au MESSAGE.
c     NTRYMX essais en cas de probleme.
c     YHS-oct-96
c
      implicit none
cI/O:
      integer lnomlu
      logical qok
      character*(*) message, nomlu
cLocal:
      integer ntry, ntrymx
cBegin:
      ntrymx=5
c
      qok=.false.
      ntry=0
c
 100  continue
      ntry=ntry+1
      if (ntry.ge.ntrymx) return
c
      write(6,'(A,A)') ' Getnam> ',message
      read(5,'(A)',end=200,err=100) nomlu
c
      call stringcl(nomlu,lnomlu)
      write(6,'(A,A)') ' Getnam> ',nomlu(1:lnomlu)
c
      qok=.true.
      return
 200  continue
      return
      end 
c
      subroutine rdmodfacs(uneig,nddlmax,nvecmx,numvec,freq,
     .           matvec,nddl,nvec)
c
c     Lecture de modes CERFACS.
c     Devra remplacer rdcerfacs.
c     Difference: comptage de l'ordre de la matrice.
c    (et pas des atomes)
c
c     Premieres versions (rdcerfacs):
c     YHS-Nov-1996.
c     Dernieres modifications:
c     YHS-Jan-2001.
cI/O:
      integer numvec(*), nvecmx, nddlmax, nvec, nddl, uneig
      double precision freq(*), matvec(nddlmax,*)
cLocal:
      integer nmotsmax
      parameter(nmotsmax=100)
      integer nerr, ivec, indnm_cfacs, nmots,
     .        i, ii, j, jj, k, kk
      double precision wtofreq
      logical qfound, qold, qfirst
      character*1 carnum
      character*132 lign132, mots(nmotsmax)
cDefaut:
c     Facteur de conversion (2*pi*f)**2 -> f (cm-1):
      wtofreq=108.586698
c
      nerr=0
      qfirst=.true.
      qold=.false.
      qfound=.false.
 100  continue
      read (uneig,'(A)',end=300,err=110) lign132
      goto 120
 110  continue
      nerr=nerr+1
 120  continue
c
      qfound=qfound.or.
     .      (index(lign132,' value ').gt.0.and.
     .       index(lign132,' vector ').gt.0.and.
     .       index(lign132,' residual ').le.0)
      qold=qold.or.
     .      (index(lign132,' VALUE ').gt.0.and.
     .       index(lign132,' VECTOR ').gt.0)
c
      if (.not.qfound.and..not.qold) goto 100
c________________________________________
c
c     Lecture des frequences des modes :
c________________________________________
c
      if (qfirst) then
          if (qold) then
          write(6,'(/A)') 
     .  ' Rdmodfacs> Old Blzpack file format detected.'
          else
          write(6,'(/A)') 
     .  ' Rdmodfacs> Blzpack file format detected.'
          endif
          qfirst=.false.
      endif
c
      ivec=0
      nvec=0
 250  continue
      ivec=ivec+1
      if (ivec.gt.nvecmx) then
          write(6,'(/A,I5,A)') 
     .  '%Rdmodfacs-Err> More than ',nvecmx,' vectors in file.'
          return
      endif
c
      read(lign132,'(7X,I5,12X,G12.4)',end=240,err=240)
     .     numvec(ivec), freq(ivec)
      freq(ivec)=wtofreq*dsqrt(abs(freq(ivec)))
c
      goto 255
 240  continue
      write(6,'(/3A)')
     .    '%Rdmodfacs-W> Pb with ligne: ',lign132(1:36),'...'
 255  continue
c
      nvec=ivec
      write(6,'(/A,I6)')
     .    ' Rdmodfacs> Numero du vecteur CERFACS en lecture:',
     .      numvec(ivec)
      write(6,'(A,1PG12.4)')
     .    ' Rdmodfacs> Frequence du vecteur en lecture:',
     .      freq(ivec)
c
      if (numvec(ivec).le.0)
     .    write(6,'(/A/A)')
     .  '%Rdmodfacs-W> Vector number was expected in:',
     .    lign132
c
      read(uneig,'(A)',end=230,err=230) lign132
 230  continue
      read(lign132,'(1X,A1)',end=232,err=232) carnum
 232  continue
      if ((qfound.and.carnum.ne.'=').or.
     .    (qold.and.carnum.ne.'-')) then
          write(6,'(2A/A)')
     .       ' %Rdmodfacs-Warning> Unexpected character ',
     .       ' in second column of line:',
     .    lign132
      endif
c____________________________________________________
c
c     2) Lecture des coordonnees des modes CERFACS :
c        Format libre.
c____________________________________________________
c
      k=0
 257  continue
      if (k.ge.nddlmax) then
          write(6,'(/A,I6,A,I5)') 
     .  '%Rdmodfacs-Err> More than ',nddlmax,
     .  ' coordinates for vector ',ivec
          return
      endif
c
      read(uneig,'(A)',end=300,err=270) lign132
c
c     Nombre de coordonnees par ligne:
      call string_split(lign132,132,' ',
     .                  mots,nmotsmax,nmots)
c
      if (lign132.eq.' ') then
          read(uneig,'(A)',end=300,err=260) lign132
      else if (.not.qold.or.index(lign132,' VALUE ').le.0) then
          read(lign132,*,end=258)
     .   (matvec(k+ii,ivec),ii=1,nmots)
          k=k+nmots
          goto 257
 258      continue
      endif
      nddl=k
c
 260  continue
      indnm_cfacs=index(lign132,'       VALUE')
      if (indnm_cfacs.le.0)
     .    indnm_cfacs=index(lign132,'       value')
      if (indnm_cfacs.gt.0) then
          goto 250
      else
          write(6,'(A,A/A/A)')
     .  ' Rdmodfacs: Lecture des modes CERFACS terminee.',
     .  ' Item VALUE non trouve dans la ligne:',lign132
          goto 300
      endif
c
 270  continue
      write(6,'(A,I6,A)')
     .   ' %Rdmodfacs-Error: durant la lecture de la coordonnee ',
     .      i,' du mode.'
      stop
c
 220  continue
c*****Ligne suivante de la lecture du fichier des modes en cours :
c
      goto 100
c
c     Fin de la lecture du fichier des modes :
c
 300  continue
      return
      end
c
c     Lecture de noms de fichier + Ouverture.
c     Serie de routines utilitaires:
c     openam
c     stringcl
c     string_split
c     Version 1.11, Bordeaux.
c
      SUBROUTINE openam(namfil,cformat,cstatus,unit,qverbos,
     .                  qinterr,qexist)
c
c     Ouverture d'un fichier de nom NAMFIL, sur l'unite UNIT.
c
c     input:
c        namfil: nom du fichier a ouvrir. 
c        "stop", "end", "fin", "quit" : arretent le programme.
c        cstatus: mots-cles fortran... ou "OVE" pour overwrite.
c     output: 
c        qexist: flag / existence du fichier 
c        qinterr: Pas de nom pour le fichier cherche.
c
c     YHS-oct-1993: Premiere version.
c     YHS-jan-2000: Derniere modification.
c I/O:
      logical qinterr, qverbos, qexist
      integer unit
      character*10 cformat, cstatus
      character*64 namfil
c Local
      character*132 ordrunix
c begin:
      if (cstatus.eq.'old') cstatus='OLD'
      if (cstatus.eq.'new') cstatus='NEW'
      if (cstatus.eq.'ove') cstatus='OVE'
      if (cstatus.eq.'unknown') cstatus='UNKNOWN'
c
      qinterr=.false.
      qexist=.false.
c
      if (namfil.eq.' ') then 
          qinterr=.true.
          write(6,'(A)') '%Openam-Err> No filename.'
          return
      endif
c
      if (namfil.eq.'stop'.or.namfil.eq.'end'                         
     &    .or.namfil.eq.'fin'.or.namfil.eq.'quit') then 
         write(*,*) 'Openam> Program is stopping on user request.'
         stop                                                                   
      endif 
c
c     Checks if filename is consistent with the opening:
c
      inquire(file=namfil,exist=qexist)
      if (.not.qexist.and.cstatus.eq.'OLD') then
          qinterr=.true.
          write(6,'(A)') '%Openam-Err> File not found.'
          return
      endif
c
      if (qexist.and.cstatus.eq.'NEW') then
         write(*,'(/A)') 
     .      '%Openam-Err> This file exists:',namfil
         stop
      else if (qexist.and.cstatus.eq.'OVE') then
         ordrunix='rm '//namfil
         call system(ordrunix)
      endif
      if (cstatus.eq.'OVE') cstatus='NEW'
c                                                                   
      if (qverbos) then
         write(*,'(/A,I6,A)')
     .           ' Openam> file on opening on unit ',unit,':'
         write(*,*) namfil
      endif
      open(file=namfil,form=cformat,
     .     status=cstatus,unit=unit)                
c        
      return                                                                       
      end
c
      subroutine string_split(chaine,taille,delimiteur,
     .                        souschaine,nbremax,nbre)
c
c     "Chaine" est coupee en "nbre" "souschaine" de part et d'autre du
c     "delimiteur"
c      YHS-Sep-93, Uppsala
c I/O:
      integer taille, nbremax, nbre
      character*(*) chaine, souschaine(*), delimiteur
c Local:
      integer icar, iprev
c
      nbre=1
      iprev=1
      souschaine(1)=chaine
      do icar=1,taille
         if (chaine(icar:icar).eq.delimiteur) then
            if (icar-1.ge.iprev) then
               souschaine(nbre)=chaine(iprev:icar-1)
               nbre=nbre+1
               if (nbre.le.nbremax) then
                  if (icar+1.le.taille.and.
     .               chaine(icar+1:taille).ne.' ') then
                     souschaine(nbre)=chaine(icar+1:taille) 
                  else
                     nbre=nbre-1
                     return
                  endif
               else
                  write(6,'(A,I6,A/A)') 
     .               ' %String_split-Err: more than ',nbremax,
     .               ' substrings in : ',chaine
                  return
               endif
            endif
            iprev=icar+1
         endif
      enddo
c
      return
      end
c
      subroutine stringcl(chaine,nonblancs)
c
c     Les caracteres "blancs" de la CHAINE sont retires (a gauche et au milieu).
c     L'entier NONBLANCS donne la position du dernier caractere.
c
c     YHS-Jan-95, Toulouse.
c     YHS-Oct-00, Bordeaux.
c I/O:
      integer nonblancs
      character*(*) chaine
c Local:
      integer icar, ncar, taille
c Begin:
      nonblancs=0
      taille=len(chaine)
      if (taille.le.0) return
c
      if (index(chaine(1:taille),' ').le.0) then
          nonblancs=taille
          return
      endif
c
c*****Nettoyage des blancs a gauche.
c     Premier non-blanc:
c
      do icar=1,taille
         if (chaine(icar:icar).ne.' ') goto 150
      enddo
      icar=taille
 150  continue
      chaine=chaine(icar:taille)
c
c*****Nettoyage des blancs au milieu.
c
          icar=1
          ncar=1
 170      continue
          icar=icar+1
          ncar=ncar+1
          if (chaine(icar:icar).eq.' ') then
              chaine=chaine(1:icar-1)//chaine(icar+1:taille) 
              icar=icar-1
          endif
          if (ncar.lt.taille-1) goto 170
c
      nonblancs=index(chaine,' ')-1
c
      return
      end
nma/ElNemo/Makefile0000644000175000017500000000064014143757351013522 0ustar  guestguestFC=gfortran
FFLAGS=-O3

all:nma_check_modes nma_diagrtb nma_elnemo_pdbmat

nma_check_modes:check_modes.o
	$(FC) $(FFLAGS) -m64 -mcmodel=large -o $@ check_modes.o
nma_diagrtb:diagrtb.o
	$(FC) $(FFLAGS) -m64 -mcmodel=large -o $@ diagrtb.o
nma_elnemo_pdbmat:pdbmat_aux.o
# grep -v '^DoC' pdbmat.f > pdbmat_aux.f
	$(FC) $(FFLAGS) -m64 -mcmodel=large -o $@ pdbmat_aux.o
.f.o:
	$(FC) $(FFLAGS) -c $*.f -m64 -mcmodel=large
nma/ElNemo/diagrtb.f0000644000175000017500000030677214146440034013652 0ustar  guestguest      Program diagrtb
c======================================================================

c     DIAGonalisation of a matrix, using the RTB approximation.

c     The method rests upon the approximation that the
c     required matrix eigenvectors are well described by 
c     rigid body motions (Rotations and Translations)
c     of Blocks of particles buildt with sets of consecutive
c     ones, as found in the corresponding coordinate file.
c     (See references below for more details)

c     In the case of proteins, typically, one amino-acid is put in one 
c     block. 

c======================================================================

c     INPUT: 
c     ******
c     A parameter, or command, file, called diagrtb.dat.  

c     Note that each run of diagrtb produces a diagrtb.dat_run file,
c     where all parameter values are given (and commented).
c     diagrtb.dat_run can be used as a diagrtb.dat file, 
c     in further runs. 

c     Among the parameters: 

c    *The name of a file with the coordinates of the system, 
c     in FREE or PDB (Protein Data Bank) format.

c     PDB  format: Masses can be given in the Bfactors column.
c     Free format: x, y, z, mass, block-number.

c    *The name of a file with the matrix, assumed to be:
c     a) real, square and symmetrical.
c     b) in the following format: i, j, i-j-matrix-element

c     OUTPUT: 
c     *******
c     The eigenvalues and eigenvectors of the matrix, 
c     in x,y,z "CERFACS" format.
 
c     In the present state of the program, the matrix
c     is first re-written in a block-by-block form.

c     ATTENTION: 
c     **********
c     Temporary diagrtb_work.* files are created during each 
c     program run.

c     So, avoid running several diagrtb simultaneously, in the same 
c     directory !

c......................................................................

c     MEMORY LIMITS:
c     **************

c     The computer memory required (LIWORK and LRWORK) can be large, 
c     in particular when the size of the largest block is large.
     
c     NATMAX    = maximum number of particles in the system.
c     LLWORK    = size of the LOGICAL working array.

c     LIWORK    = size of the INTEGER working array.
c     LRWORK    = size of the DOUBLE PRECISION working array.
 
      implicit         none
      integer          liwork, llwork, lrwork, natmax
 
      parameter        (natmax =   250000)
      parameter        (llwork =3*natmax)

c     ===================================
c      parameter        (LIWORK = 5000000)
c      parameter        (LRWORK =32000000)
      parameter        (LIWORK = 100000000)
      parameter        (LRWORK = 1000000000)
c     ====================================
c......................................................................

c     REFERENCES: 
c     ***********

c     1) P. Durand, G. Trinquier, Y.H. Sanejouand (1994):
c    "A new approach for determining low-frequency
c     normal modes in macromolecules", 
c     Biopolymers vol.34, p759-771.
 
c     2) F. Tama, F.X. Gadea, O. Marques, Y.H. Sanejouand (2000):
c    "Building-block approach for determining 
c     low-frequency normal modes of macromolecules", 
c     Proteins: Structure, Function, and Genetics vol.41(1), p1-7.

c     3) G. Li, Q. Cui (2002):
c    "A coarse-grained normal mode approach for macromolecules: an
c     efficient implementation and application to Ca(2+)-ATPase",
c     Biophys. J. vol.83, p2457-2474.

c     In the later paper, RTB is called BNM (for Block-Normal-Modes). 
c     It is more general (flexible blocks are allowed). 
c     It is now available in the CHARMm package (since version 32). 

c......................................................................

c     1994: version 1.0, by Georges Trinquier, Philippe Durand
c           and Yves-Henri Sanejouand.
c     2001: version 2.0, by Florence Tama, Florent-Xavier Gadea, 
c           Osni Marques and Yves-Henri Sanejouand.

c     Further modifications (2002-2004): by Yves-Henri Sanejouand.

c     In case of problem, feel free to contact: 
c     Yves-Henri.Sanejouand@ens-lyon.fr

c......................................................................

      logical          LWORK(llwork)
      integer          IWORK(liwork)
      double precision RWORK(lrwork)
 
c     nbrt: Number of degrees of freedom of each block.
c          (3 translations and 3 rotations)

      integer   nbrt, nmotsmax, nresmax      
      parameter (nbrt=6,nresmax=natmax,nmotsmax=100)

      character cformat*12, clean*4, cstatus*12, eige*4, feig*128, 
     .          field*128, fmtx*128, fpdb*128, macro*4, mass*4, 
     .          namfich*128, mots(nmotsmax)*128, motinp*128, program*9, 
     .          progrer*12, progrwn*12, resname(natmax)*4, string*128, 
     .          ssu(natmax)*1, ssusel*1, sstr*4, typf*4, version*30
      logical   alive, qerror, qexist, qinter, qstop, qverbos
      integer   i, iiwkm1, iiwkm2, iiwkove, iiwkp1, iiwkp2, iiwkp3, 
     .          iiwrk1, iiwrk2, iiwrk3, irwkd1, irwkd2, irwkd3, irwkd4, 
     .          irwkm1, irwkm2, irwkm3, irwkm4, irwkm5, iiwkmx, irwkove, 
     .          irwkp1, irwkp2, irwkmx, irwrk1, irwrk2, irwrk3, irwrk4, 
     .          irwrk5, irwrk6, irwrk7, irwrk8, irwrk9, k, klist, ksep, 
     .          lmot, lnomeig, lnommtx, lnompdb, natblocs, natom, nb, 
     .          nddres, nddres2, ndim, nmots, nrbl, nunit, nvec, prtlev, 
     .          undat, uninp
 
c-----------------------------------------------------------------------
      version=' Version 2.52, November 2004.'
      program=' Diagrtb>'
 
      write(6,'(2A)') program,
     .    ' Diagonalizes a matrix, using the RTB/BNM approximation.'
      write(6,'(2A)') program, version

      progrwn='%Diagrtb-Wn>'
      progrer='%Diagrtb-Er>'

c.... Defaults .........................................................
c     Can be modified in 'diagrtb.dat'.
 
c     Number of residues per block:
      nrbl = 1
      
c     Substructuring:
c     --------------
c    (Chain breaks interrupt blocks in RESIdue case)

c     SECO: Whole secondary structures are put in blocks
c     DOMA: Whole domains are put in blocks
c     SUBU: Whole subunits are put in blocks
c     RESI: Only the number of residues per block is taken into account
c     NONE:       "                       "                   "
 
c     Structures are defined in the coordinate file, by the
c     HELIX, SHEET, LOOP or DOMAIN keywords 
c    (the two laters are not standard).
c     Non-specified portions of the sequence are split
c     into blocks, according to the NRBL value.
      
      sstr = 'NONE'

c     Atomic masses:
c     PDB : Look for masses in the B-factors column of the pdb file.
c     CONS: Set them to a constant value (mass=1).
      mass = 'CONS'
 
c     Number of eigenvectors to compute:
      nvec = 56
      
c     LOWE: The lowest-eigenvalues ones.
c     HIGH: The highest-eigenvalues ones.
      eige = 'LOWE'
 
c     ALL: Work files are deleted at the end of the job.
c     NO : They are kept.
      clean= 'ALL'
 
c     PDB default filename with the coordinates of the system.
      fpdb = 'structure.pdb'
 
c     Matrix default filename with the non-zero elements.
      fmtx = 'pdbmat.sdijf'
      typf = 'FREE'
 
c     Eigenvector output filename.
      feig = 'diagrtb.eigenfacs'

c     PRINTing level:
      prtlev=0

C.... read options from file diagrtb.dat ..............................

      nunit=10

      namfich='diagrtb.dat'
      undat=nunit
      nunit=nunit+1
      cformat="FORMATTED"
      cstatus="old"

      qverbos=.false.
      if (prtlev.gt.1) qverbos=.true.

      call openam(namfich,cformat,cstatus,undat,qverbos,
     .            qinter,qexist)

      if (.not.qexist) then
          write(6,'(2A)') progrwn,
     .  ' No diagrtb.dat file. Defaults assumed for all options.'
          goto 15
      else
          write(6,'(2A)') program,
     .  ' Options to be read in diagrtb.dat file.'
      endif
 
 5    continue 
      read (undat,end=10,err=20,fmt='(a)') string

      if (string(1:1).eq.'!'.or.string(1:1).eq.'*'.or.
     .    string(1:1).eq.'#') goto 5

      ksep=index(string,'=')

      motinp=' '
      if (ksep.gt.0) then 
          motinp=string(1:ksep)
          field=string(ksep+1:80)
          k=index(field,'!')
          if (k.gt.0) field=field(1:k-1)
          call stringcl(field,lmot)
          klist=-1
          if (field(1:1).eq.'?') klist=1
      else
          write(6,'(/2A/A)') progrwn,
     .  ' No separator (=) in command ligne:',
     .    string
          write(6,'(2A)') progrwn,' This ligne is skipped.'
          goto 5
      endif
      call mintomaj(motinp)

      macro='XXXX'
      if (index(motinp,'NRBL').gt.0.or.
     .    index(motinp,'BLOC').gt.0) macro='NRBL'
      if (index(motinp,'NVEC').gt.0.or.
     .    index(motinp,' VECT').gt.0) macro='NVEC'
      if (index(motinp,'FPDB').gt.0.or.
     .    index(motinp,'COOR').gt.0) macro='FPDB'
      if (index(motinp,'FMTX').gt.0.or.
     .    index(motinp,'MATR').gt.0) macro='FMTX'
      if (index(motinp,'FEIG').gt.0.or.
     .    index(motinp,' OUTP').gt.0) macro='FEIG'
      if (index(motinp,'MASS').gt.0) macro='MASS'
      if (index(motinp,'SUBS').gt.0) macro='SUBS'
      if (index(motinp,'NVAL').gt.0.or.
     .    index(motinp,' FREQ').gt.0) macro='EIGE'
      if (index(motinp,'CLEA').gt.0) macro='CLEA'
      if (index(motinp,'PRIN').gt.0) macro='PRTL'
      if (index(motinp,'FORM').gt.0.and.index(motinp,'MATR').gt.0)
     .    macro='FORM'

      if (macro.ne.'FMTX'.and.macro.ne.'FPDB'.and.
     .    macro.ne.'FEIG') call mintomaj(field)

      if      ( macro.eq.'NRBL' ) then
                read (field,'(i16)') nrbl 
      else if ( macro.eq.'NVEC' ) then
                read (field,'(i16)') nvec 
      else if ( macro.eq.'PRTL' ) then
                read (field,'(i16)') prtlev
      else if ( macro.eq.'FPDB' ) then
                read (field,'(a)') fpdb 
      else if ( macro.eq.'FMTX' ) then
                read (field,'(a)') fmtx 
      else if ( macro.eq.'FORM' ) then
                read (field,'(a)') typf 
                call mintomaj(typf)
                if (typf.ne.'FREE'.and.typf.ne.'BINA') then
                    write(6,'(3A)') program,
     .            ' Matrix FORMat: ',typf 
                    if (klist.le.0) write(6,'(2A)') progrwn,
     .                ' This is not a known keyword.'
                    write(6,'(2A)') program,
     .            ' Valid options are: FREE, BINAry.'
                    write(6,'(2A)') program,' Default assumed (FREE).'
                    typf='FREE'
                endif
      else if ( macro.eq.'FEIG' ) then
                read (field,'(a)') feig 
      else if ( macro.eq.'MASS' ) then
                read (field,'(a)') mass 
                call mintomaj(mass)
                if (mass.ne.'PDB'.and.mass.ne.'CONS'.and.
     .              mass.ne.'COOR') then
                    write(6,'(3A)') program,
     .            ' Origin of MASS values: ',mass 
                    if (klist.le.0) write(6,'(2A)') progrwn,
     .                ' This is not a known keyword.'
                    write(6,'(2A)') program,
     .            ' Valid options are: CONStant, COORdinate, PDB.'
                    write(6,'(2A)') program,' Default assumed (CONS).'
                    mass='CONS'
                endif
      else if ( macro.eq.'SUBS' ) then
                read (field,'(a)') sstr 
                call mintomaj(sstr)
                if (sstr.eq.'RESI') sstr='NONE'
                if (sstr.ne.'SECO'.and.sstr.ne.'SUBU'.and.
     .              sstr.ne.'DOMA'.and.sstr.ne.'NONE') then
                    write(6,'(3A)') program,
     .            ' Type of SUBStructures: ',sstr 
                    if (klist.le.0) write(6,'(2A)') progrwn,
     .                ' This is not a known keyword.'
                    write(6,'(2A)') program,
     .            ' Valid options are:'//
     .            ' RESIdues, SECOndary, SUBUnits, DOMAins, NONE.'
                    write(6,'(2A)') program,' Default assumed (NONE).'
                    sstr='NONE'
                endif
      else if ( macro.eq.'EIGE' ) then
                read (field,'(a)') eige 
                call mintomaj(eige)
                if (eige.ne.'LOWE'.and.eige.ne.'HIGH') then
                    write(6,'(3A)') program,
     .            ' Selected EIGEnvalues : ',eige 
                    if (klist.le.0) write(6,'(2A)') progrwn,
     .                ' This is not a known keyword.'
                    write(6,'(2A)') program,
     .            ' Valid options are: LOWEst, HIGHest.'
                    write(6,'(2A)') program,' Default assumed (LOWE).'
                    eige='LOWE'
                endif
      else if ( macro.eq.'CLEA' ) then
                read (field,'(a)') clean
                call mintomaj(clean)
                if (clean.ne.'ALL'.and.clean(1:2).ne.'NO') then
                    write(6,'(3A)') program,
     .            ' Temp. files CLEAning : ',clean
                    if (klist.le.0) write(6,'(2A)') progrwn,
     .                ' This is not a known keyword.'
                    write(6,'(2A)') program,
     .            ' Valid options are: ALL, NOne.'
                    write(6,'(2A)') program,' Default assumed (ALL).'
                    clean='ALL'
                endif
      else    
                write(6,'(/2A/A)') progrwn,
     .        ' No known keyword in ligne:',string
                write(6,'(2A)') progrwn,
     .        ' This command ligne is skipped.'
      end if
 
      goto 5
   10 close (10)
   15 continue
      close(undat)
 
      call stringcl(fpdb,lnompdb)
      call stringcl(fmtx,lnommtx)
      call stringcl(feig,lnomeig)

      if (prtlev.le.0) then
      write(6,'(/2A)')  program,' Main options:'
      else
      write(6,'(/2A)')  program,' Options taken into account:'
      endif

      write(6,'(/2A)')   ' MATRix filename          = ',fmtx(1:lnommtx)
      write(6,'(2A)')   ' COORdinates filename     = ',fpdb(1:lnompdb)
      write(6,'(2A)')   ' Eigenvector OUTPut file  = ',feig(1:lnomeig)
      write(6,'(A,I10)') ' Nb of VECTors required   = ',nvec
      write(6,'(A,6X,A)') ' EigeNVALues chosen       = ',eige
      if (sstr.ne.'NONE'.or.prtlev.gt.0)
     .write(6,'(A,6X,A)')   ' Type of SUBStructuring   = ',sstr
      write(6,'(A,I10)') ' Nb of residues per BLOck = ',nrbl
      write(6,'(A,6X,A)')   ' Origin of MASS values    = ',mass
      if (typf.ne.'FREE'.or.prtlev.gt.0)
     .write(6,'(A,6X,A)')   ' MATRix FORMat            = ',typf 
      if (prtlev.gt.0) then
      write(6,'(A,6X,A)')   ' Temporary files cleaning = ',clean
      write(6,'(A,I10)') ' Output PRINting level    = ',prtlev
      endif

c     Sauvegarde du fichier de commandes complet:

      uninp=nunit
      nunit=nunit+1
      namfich='diagrtb.dat_run'
      cformat="FORMATTED"
      cstatus="ove"
      call openam(namfich,cformat,cstatus,uninp,qverbos,
     .     qinter,qexist)

      write(uninp,'(2A)') 
     .'! This file can be modified and used as a command file',
     .' (named diagrtb.dat) for diagrtb.'

      write(uninp,'(2A)')   ' MATRix filename            = ',
     .      fmtx(1:lnommtx)
      write(uninp,'(2A)')   ' COORdinates filename       = ',
     .      fpdb(1:lnompdb)
      write(uninp,'(2A)')   ' Eigenvector OUTPut filename= ',
     .      feig(1:lnomeig)
      write(uninp,'(A,I10)') ' Nb of VECTors required     = ',nvec
      write(uninp,'(A,6X,2A)') ' EigeNVALues chosen         = ',eige,
     .            '   ! LOWEst, HIGHest.'
      write(uninp,'(A,6X,2A)')   ' Type of SUBStructuring     = ',sstr,
     .            '   ! RESIdues, SECOndary, SUBUnits, DOMAins, NONE.'
      write(uninp,'(A,I10)') ' Nb of residues per BLOck   = ',nrbl
      write(uninp,'(A,6X,2A)')   ' Origin of MASS values      = ',mass,
     .            '   ! CONStant, COORdinate, PDB.'
      write(uninp,'(A,6X,2A)')   ' Temporary files cleaning   = ',clean,
     .            '   ! ALL, NOne.'
      write(uninp,'(A,6X,2A)')   ' MATRix FORMat              = ',typf, 
     .            '   ! FREE, BINAry.'
      write(uninp,'(A,I10,A)') ' Output PRINting level      = ',prtlev,
     .            '   ! =1: More detailed; =2: Debug level.'
      close(uninp)

c     On recherche l'information/sous-unite:
 
      call string_split(fpdb,lnompdb,":",
     .                  mots,nmotsmax,nmots)
      call stringcl(mots(1),lmot)
 
      if (nmots.gt.1) then
          call stringcl(mots(2),lmot)
          ssusel=mots(2)
          write(6,'(/3A)') program,' Selected (pdb) subunit: ',ssusel
          if (nmots.gt.2.or.lmot.gt.1) then
              write(6,'(4A)') progrwn,
     .      ' The end of name: ',
     .        fpdb(1:lnompdb),', was not understood.'
          endif
      else
          ssusel='*'
      endif
      fpdb=mots(1)
      call stringcl(fpdb,lnompdb)

C     Premiers tests:

      qerror=.false.

      inquire(file=fpdb,exist=qexist)

      if (.not.qexist) then
      write(6,'(/2A)') progrer,' Coordinate file not found. Required !'
      qerror=.true.
      endif

      if (nvec.le.0) then
      write(6,'(/2A)') progrer,' No eigenvector required...'
      qerror=.true.
      endif

      if (qerror) stop '*Command error. Check diagrtb.dat file*'

C.... pointers for BLOCPDB .............................................
 
      iiwkove=-1
      irwkove=-1
      qstop=.false.

      if (prtlev.gt.1)
     .write(6,'(/2A)') program,' Memory allocation for Blocpdb.'

      iiwrk1 = 1
      iiwrk2 = iiwrk1 + nresmax
      iiwrk3 = iiwrk2 + natmax
      iiwkmx = iiwrk3 + natmax
      if ( iiwkmx.gt.liwork ) then
          write(6,'(/A,2(A,I12))') progrer,' IIWKMX= ',IIWKMX,
     .  ' Maximum allowed is LIWORK= ',liwork
          qstop=.true.
      endif
      
      irwrk1 = 1
      irwrk2 = irwrk1 + 3*natmax
      irwkmx = irwrk2 + 3*natmax
      if ( irwkmx.gt.lrwork ) then
          write(6,'(/A,2(A,I12))') progrer,' IRWKMX= ',IRWKMX,
     .  ' Maximum allowed is LRWORK= ',lrwork
          qstop=.true.
      endif

      if (qstop) then
          write(6,'(/2A/A/A)') progrer,
     .  ' Not enough memory allowed for working arrays. Sorry.',
     .  ' Recompile DIAGRTB with smaller NATMAX and/or NRESMAX.'
          stop '*Working arrays allocation error*'
      endif
 
      CALL BLOCPDB ( fpdb, ssusel, sstr, mass, natmax, nrbl, nresmax, 
     .               IWORK(iiwrk2), IWORK(iiwrk3), IWORK(iiwrk1), 
     .               RWORK(irwrk1), RWORK(irwrk2), 
     .               resname, ssu, natblocs, natom, nb, prtlev )

C.... pointers for PREPMAT .............................................
 
C     Note: The first nresmax entries of IWORK (on output from BLOCPDB)
C           are required in PREPMAT, so we don't change iiwrk2.
 
      if (prtlev.gt.1)
     .write(6,'(/2A)') program,' Memory allocation for Prepmat.'
      iiwkp1 = iiwrk1
      iiwkp2 = iiwrk2
      iiwkp3 = iiwkp2 + 9*natblocs**2
      iiwkmx = iiwkp3 + 9*natblocs**2
      if ( iiwkmx.gt.liwork ) then
          if ( iiwkmx.gt.iiwkove ) iiwkove=iiwkmx
          qstop=.true.
      endif
 
      irwkp1 = 1
      irwkp2 = irwkp1 + 9*natblocs*natom
      irwkmx = irwkp2 + 9*natblocs*natblocs
      if ( irwkmx.gt.lrwork ) then
          if ( irwkmx.gt.irwkove ) irwkove=irwkmx
          qstop=.true.
      endif
 
C.... pointers for RTB .................................................
 
      if (prtlev.gt.1)
     .write(6,'(2A)') program,' Memory allocation for RTB.'
      nddres = 3*natblocs
      nddres2 = nddres**2
 
      iiwrk1 = 1
      iiwrk2 = iiwrk1 + nddres2
      iiwrk3 = iiwrk2 + nddres2 
      iiwkmx = iiwrk3 + nb
      if ( iiwkmx.gt.liwork ) then
          if ( iiwkmx.gt.iiwkove ) iiwkove=iiwkmx
          qstop=.true.
      endif
 
      irwrk1 = 1
      irwrk2 = irwrk1 + 3*natom
      irwrk3 = irwrk2 + 3*natom
      irwrk4 = irwrk3 + nbrt*nddres
      irwrk5 = irwrk4 + nddres2
      irwrk6 = irwrk5 + nddres*nbrt 
      irwrk7 = irwrk6 + nddres2
      irwrk8 = irwrk7 + 36*nb**2 
      irwrk9 = irwrk8 + nbrt*nddres*nb
      irwkmx = irwrk9 + nbrt*nbrt
      if ( irwkmx.gt.lrwork ) then
          if ( irwkmx.gt.irwkove ) irwkove=irwkmx
          qstop=.true.
      endif
 
C.... pointers for DIAGSTD .............................................
 
      if (prtlev.gt.1)
     .write(6,'(2A)') program,' Memory allocation for Diagstd.'
      ndim = 6*nb
 
      iiwkmx = ndim
      if ( iiwkmx.gt.liwork ) then
          if ( iiwkmx.gt.iiwkove ) iiwkove=iiwkmx
          qstop=.true.
      endif

      irwkd1 = 1
      irwkd2 = irwkd1 + ndim*ndim
      irwkd3 = irwkd2 + ndim
      irwkd4 = irwkd3 + ndim
      irwkmx = irwkd4 + ndim
      if ( irwkmx.gt.lrwork ) then
          if ( irwkmx.gt.irwkove ) irwkove=irwkmx
          qstop=.true.
      endif
 
      if (ndim.lt.nvec) then
          nvec = ndim
          write(6,'(/A,I10,A)') progrwn,
     .    nvec,' eigenvectors, only, can be determined.'
      endif
 
C.... pointers for RTBTOMODES ..........................................
 
      if (prtlev.gt.1)
     .write(6,'(2A)') program,' Memory allocation for RTB_to_modes.'
      iiwkm1 = 1
      iiwkm2 = iiwkm1 + nb
      iiwkmx = iiwkm2 + nvec
      if ( iiwkmx.gt.liwork ) then
          if ( iiwkmx.gt.iiwkove ) iiwkove=iiwkmx
          qstop=.true.
      endif
 
      irwkm1 = 1
      irwkm2 = irwkm1 + 3*natom*nvec
      irwkm3 = irwkm2 + nvec
      irwkm4 = irwkm3 + 6*nb*nvec
      irwkm5 = irwkm4 + nvec
      irwkmx = irwkm5 + nbrt*nddres*nb
      if ( irwkmx.gt.lrwork ) then
          if ( irwkmx.gt.irwkove ) irwkove=irwkmx
          qstop=.true.
      endif
 
      if (qstop) then
          if ( iiwkove.gt.liwork ) then
          write(6,'(/A,2(A,I12))') progrer,' IIWKMX up to: ',IIWKove,
     .  ' Maximum allowed is LIWORK= ',liwork
          endif
          if ( irwkove.gt.lrwork ) then
          write(6,'(/A,2(A,I12))') progrer,' IRWKMX up to: ',IRWKove,
     .  ' Maximum allowed is LRWORK= ',lrwork
          endif
          write(6,'(/2A/A/A)') progrer,
     .  ' Not enough memory allowed for working arrays. Sorry.',
     .  ' Lower the number of blocks, the sizes of the largest ones...',
     .  ' Or recompile DIAGRTB with larger WORKing arrays.'
          stop '*Working arrays allocation error*'
      endif

      inquire(file=fmtx,exist=qexist)
      if (.not.qexist) then
          write(6,'(/2A)') progrer,' Matrix not found. Required !'
          stop '*Nothing to do*'
      endif

      CALL PREPMAT ( fmtx, typf, natblocs, natom, nb, 
     &               LWORK, IWORK(iiwkp2), IWORK(iiwkp3), IWORK(iiwkp1), 
     &               RWORK(irwkp1), RWORK(irwkp2), prtlev )
 
      CALL RTB     ( natom, nb, nbrt, nddres, nddres2, IWORK(iiwrk1),
     &               IWORK(iiwrk2), IWORK(iiwrk3), RWORK(irwrk1),
     &               RWORK(irwrk2), RWORK(irwrk3), RWORK(irwrk4),
     &               RWORK(irwrk5), RWORK(irwrk6), RWORK(irwrk7),
     &               RWORK(irwrk8), RWORK(irwrk9), prtlev )
 
      CALL DIAGSTD ( ndim, nvec, eige, IWORK, 
     &               RWORK(irwkd1), RWORK(irwkd2),
     &               RWORK(irwkd3), RWORK(irwkd4), prtlev )

      CALL RTBTOMODES ( natom, nb, nbrt, nddres, nvec, IWORK(iiwkm1),
     &                  IWORK(iiwkm2), RWORK(irwkm1), RWORK(irwkm2),
     &                  RWORK(irwkm3), RWORK(irwkm4), RWORK(irwkm5),
     &                  prtlev, feig )
 
C.... clean up .........................................................
 
      if (clean.eq.'ALL') then
      inquire (file='diagrtb_work.xyzm',exist=alive)
      if ( alive ) then
         open  (10,file='diagrtb_work.xyzm')
         close (10,status='delete')
      end if
      inquire (file='diagrtb_work.blocs',exist=alive)
      if ( alive ) then
         open  (10,file='diagrtb_work.blocs')
         close (10,status='delete')
      end if
      inquire (file='diagrtb_work.matblocs',exist=alive)
      if ( alive ) then
         open  (10,file='diagrtb_work.matblocs')
         close (10,status='delete')
      end if
      inquire (file='diagrtb_work.sdijb',exist=alive)
      if ( alive ) then
         open  (10,file='diagrtb_work.sdijb')
         close (10,status='delete')
      end if
      inquire (file='diagrtb_work.eigenfacs',exist=alive)
      if ( alive ) then
         open  (10,file='diagrtb_work.eigenfacs')
         close (10,status='delete')
      end if
      end if
 
C.... End of diagrtb ..................................................
 
      write(6,'(/2A)') program,' Normal end.'
      stop
   20 stop '*Command error. Check diagrtb.dat file*'
      end
c----------------------------------------------------------------------
      SUBROUTINE BLOCPDB ( fpdb, ssusel, sstr, mass, natmax, nbb, 
     &                     nblocmx, resi, numbloc, tabb, amass, corlin, 
     &                     resname, ssu, natbmax, natom, nb, prtlev )
      implicit none

c     Scalar Arguments
 
      character        fpdb*(*), mass*(*), sstr*(*), ssusel*(*)
      integer          natbmax, natmax, natom, nb, nbb, nblocmx, prtlev 
 
c     Array Arguments
 
      integer          numbloc(natmax), resi(natmax), tabb(nblocmx)
      double precision amass(3*natmax), corlin(3*natmax), unknown 
      character        resname(natmax)*4, ssu(natmax)*1
      parameter       (unknown=9999.999999)
 
c     Purpose:
c     =======
 
c     -------------------------------------------------------------
c     Atomic coordinates are read and block lengths are determined,
c     as a consequence of the number of residues per block and/or
c     of the substructuring requirements (SSTR command).
c     -------------------------------------------------------------
c    (The peptidic bond between residues is simply split)
 
c     Arguments
c     =========
 
c     fpdb      : Pdb filename (with the x,y,z coordinates)
c     sstr      : keyword for substructuring
c     mass      : keyword for choosing masses 
c     natmax    : maximum number of atoms in the system.
c     nbb       : number of residues per block.
c     nblocmx   : maximum number of blocks.
c     resi      : residue number each atom belongs to.
c     numbloc   : block number each atom belong to.
c     tabb      : block lengths.
c     amass     : coordinate masses.
c     corlin    : coordinates (x1, y1, z1, x2, y2, ...).
c     resname   : residue name each atom belong to.
c     ssu       : subunit name each atom belong to.
c     natbmax   : maximum number of atoms found in blocks.
c     natom     : number of atoms in the system.
c     nb        : number of blocks the system is split into.
  
c-----------------------------------------------------------------------
 
c     Local variables
 
      character aa1*4, aa2*4, atname*4, cformat*12, cstatus*12, 
     .          lign80*80, namfil*20, program*9, progrer*12, progrwn*12, 
     .          ssu1*1, ssu2*1, ssuch*4
      logical   qerror, qexist, qinterr, qmass, qok, qpdb, qverbos
      integer   at, i, ii, j, k, lnompdb, natbloc, natbmin, ndat, 
     .          nl, noff, nres, nresb, nssu, num1, num2, nunit, 
     .          uninp, unrtb
      double precision rave, rdev, rmax, rmin, tot
 
C-----------------------------------------------------------------------
 
      program=' Blocpdb>'
      progrwn='%Blocpdb-Wn>'
      progrer='%Blocpdb-Er>'

      if (prtlev.gt.1)
     .    write(6,'(/2A)') program,' Entering in.'
 
      if (sstr.eq.'NONE'.and.nbb.le.0) then
          write(6,'(/A,I6,A)') progrer,nbb,
     .  ' residues per bloc required. Not a positive number !'
          stop '*Command error. Check diagrtb.dat file*'
      endif
 
      nunit=10

c     Fichier de sortie
c     -----------------
      namfil='diagrtb_work.xyzm'
      cformat='UNFORMATTED'
      cstatus='ove'
      unrtb=nunit
      nunit=nunit+1

      qverbos=.false.
      if (prtlev.gt.1) qverbos=.true.

      call openam(namfil,cformat,cstatus,unrtb,qverbos,
     .            qinterr,qexist)
      if (qinterr) stop

c     ----------------------------
c     The coordinate file is read:
c     ----------------------------

      cformat='FORMATTED'
      cstatus='OLD'
      uninp=nunit
      nunit=nunit+1

      if (prtlev.gt.1) then
        call stringcl(fpdb,lnompdb)
        write(6,'(/4A)') program,
     .' Coordinate file ',fpdb(1:lnompdb),' to be opened.'
      endif

      call openam(fpdb,cformat,cstatus,uninp,qverbos,
     .            qinterr,qexist)
      if (qinterr) stop

c     Format pdb pour les coordonnees ?

      nl=0
      qpdb=.false.
 120  continue
      read(uninp,'(A)',end=130) lign80
      if (lign80(1:5).eq.'ATOM '.or.lign80(1:6).eq.'HETATM') then
          qpdb=.true.
          goto 130
      else
          nl=nl+1
      endif
      goto 120
 130  continue
      rewind(uninp)

      qmass=.true.
      if (mass.eq.'CONS') qmass=.false.
 
      do i=1,natmax
         ii=3*i-2
         corlin(ii)=unknown
         corlin(ii+1)=unknown
         corlin(ii+2)=unknown
         amass(ii)=unknown
         amass(ii+1)=unknown
         amass(ii+2)=unknown
         resi(i)=i
         ssu(i)='*'
      enddo

      if (.not.qpdb) then
          if (nl.eq.0) then
              write(6,'(/2A)') progrer,' Empty coordinate file.'
              stop '*I/O error*'
          endif
          if (prtlev.gt.1)
     .    write(6,'(2A)') program,
     .  ' Coordinate file in Free format.'

          call readrlin(uninp,corlin,amass,resi,natmax,natom,
     .         ndat,qerror,prtlev)
          if (qerror) stop '*I/O error*'

          if (qmass.and.ndat.lt.4) then
              write(6,'(/2A)') progrer,
     .      ' Masses have not been all found, as they should.'
              qmass=.false.
          else if (mass.eq.'PDB'.and..not.qpdb) then
              write(6,'(2A)') progrwn,
     .      ' PDB keyword instead of COOR, for masses ? '
              mass='COOR' 
          endif
          goto 35
      endif

      if (prtlev.gt.1)
     .write(6,'(/2A)') program,' Coordinate file in PDB format.'

      i=0
      noff=0
 25   continue
      read(uninp,'(A)',end=30) lign80
      if (lign80(1:5).ne.'ATOM '.and.lign80(1:6).ne.'HETATM') goto 25
      i=i+1
      if (i.gt.natmax) then
          write(6,'(/2A,I6,A)') progrer,' More than ',natmax,
     .        ' atoms, the maximum allowed. Sorry.'
          stop '*Too large system*'
      endif

c     Coordinates are read according to the "pdb" format.
c     Masses can be in the B-factors column.

      ii=3*i-2
      read(lign80,'(6X,I5,1X,A4,1X,A4,A1,I4,4X,F8.3,F8.3,
     .     F8.3,1X,F5.2,F6.2,6X,A4)')
     .     at,atname,resname(i),ssu(i),resi(i),corlin(ii),corlin(ii+1),
     .     corlin(ii+2),tot,amass(ii),ssuch

      if (ssu(i).ne.ssusel.and.ssusel.ne.'*') then
          noff=noff+1
          goto 25
      endif

      if (amass(ii).le.0.and.qmass) then
          write(6,'(2A,I6,A,F8.2)') progrwn,' Atom ',i,
     .  ' Mass read in B-factor column= ',amass(ii)
          qmass=.false.
      endif
      amass(ii+1)=amass(ii)
      amass(ii+2)=amass(ii)
      goto 25
 30   continue
      natom=i
 
      write(6,'(/A,I6,A)') program,natom,' atoms picked in pdb file.'
      if (noff.gt.0)
     .write(6,'(A,I6,A)') program,noff,
     .  ' skipped, because they belong to other subunit(s).'
 35   continue

c     Tests:

      if (natom.lt.3) then
          write(6,'(/2A)') progrer,
     .  ' Not enough atoms found in file. Nothing done.'
          stop '*Too small system*'
      endif

      if (qmass) then
          write(6,'(/2A)') program,
     .        ' Masses were read in coordinate file.'

          write(6,'(/2A)') program,' Mass statistics: '
          call vecstat(amass,3*natom,rmin,rmax,rave,rdev)
          write(6,'(4(A,F12.6))') 
     .  ' <m>= ',rave,' +/- ',rdev,' From: ',rmin,' To: ',rmax

          if (rmin.le.0.d0) then
              write(6,'(/2A)') progrer,
     .      ' Negative or null masses found !'
              qmass=.false.
          endif
      endif

      if (.not.qmass) then
         do i=1,3*natom
            amass(i)=1.d0
         enddo
         write(6,'(2A)') program,'   All masses set to unity.'
         if (mass.eq.'COOR'.or.mass.eq.'PDB') then
             write(6,'(/2A)') progrwn,
     .     ' If the matrix was mass-weighted,'//
     .     ' wrong results are expected.'
         endif
      endif

      if (sstr.eq.'SUBU'.and..not.qpdb) then
          write(6,'(/2A)') progrer,
     .  ' SUBUnit information can be found in PDB files only.'
          stop '*Not consistent commands*'
      endif

c     ---------------------------------------------------------
c     Creation du fichier diagrtb_work.xyzm
c     Ce fichier contient:
c          1- les coordonnes (x1, y1, z1, x2, y2, z2, ...)
c          2- les masses associees
c     ---------------------------------------------------------

      if (prtlev.gt.1) 
     .write(6,'(2A)') program,' Coordinate file is rewritten.'
      write(unrtb) natom
      write(unrtb) (corlin(ii),ii=1,3*natom)
      write(unrtb) (amass(ii),ii=1,3*natom)
      close(unrtb)
 
c     --------------------------------------------------------
c     Substructuring information is picked in coordinate file:
c     --------------------------------------------------------

      nb=0
      do i=1,natom
         numbloc(i)=0
      enddo

      if (prtlev.gt.0.or.(sstr.eq.'DOMA'.or.sstr.eq.'SECO')) 
     .write(6,'(/2A)') program,' Substructuring:'
      if (prtlev.gt.1) then
      if (sstr.eq.'DOMA') then
      write(6,'(2A)') program,
     .  ' DOMAIN keyword expected in coordinate file.' 
      else if (sstr.eq.'SECO') then
      write(6,'(2A)') program,
     .  ' HELIX or SHEET keyword expected in coordinate file.' 
      endif
      endif

      if (sstr.eq.'SECO'.or.sstr.eq.'DOMA') then
          rewind(uninp)
 40       continue
          read(uninp,'(A)',end=45) lign80
          if ((sstr.eq.'DOMA'.and.lign80(1:6).ne.'DOMAIN').or.
     .        (sstr.eq.'SECO'.and.lign80(1:5).ne.'HELIX'.and.
     .         lign80(1:5).ne.'SHEET')) goto 40

          nb=nb+1

          if (lign80(1:5).eq.'HELIX'.or.sstr.eq.'DOMA') 
     .        read(lign80,'(15X,A4,A1,I5,2X,A4,A1,I5)',err=70) 
     .        aa1,ssu1,num1,aa2,ssu2,num2
          if (lign80(1:5).eq.'SHEET') 
     .        read(lign80,'(17X,A4,A1,I4,2X,A4,A1,I4)',err=70) 
     .        aa1,ssu1,num1,aa2,ssu2,num2

          write(6,'(6A,I5,3A,I5)') program,' ',lign80(1:6),' from ',
     .          aa1,ssu1,num1,' to ',aa2,ssu2,num2

          if (ssu1.ne.ssu2.or.num2.lt.num1) then
              write(6,'(/2A)') progrer,' Not coherent.'
              goto 70
          endif

          natbloc=0
          do i=1,natom
             if ((ssu(i).eq.'*'.or.ssu1.eq.ssu(i)).and.
     .          resi(i).ge.num1.and.resi(i).le.num2) then
                if (numbloc(i).gt.0) then
                   write(6,'(2A,I6,A)') progrwn,' Atom ',i,
     .           ' is already assigned block ',numbloc(i)
                endif
                natbloc=natbloc+1
                numbloc(i)=nb
             endif
          enddo

          if (natbloc.eq.0) then
              write(6,'(2A)') progrwn,
     .      ' Substructuring information ignored.'
              nb=nb-1
          endif
          goto 40

c         Split the loops into blocks: 

 45       continue
          if (prtlev.gt.0.or.nb.le.0) then
          if (nb.le.0) then
          write(6,'(/2A)') progrwn,
     .  ' Substructuring information not found. NONE assumed.'
          else
          if (sstr.eq.'SECO') then
          write(6,'(A,I6,A)') program,nb,
     .        ' secondary structure elements, each in its own block.'
          else
          write(6,'(A,I6,A)') program,nb,
     .        ' domains, each in its own block.'
          endif
          write(6,'(A,I6,A)') program,nbb,
     .  ' residue(s) per block, otherwise.'
          endif
          endif
       
          do i=1,natom

c            Fin d'une serie de blocs:

             if (i.ne.natom.and.numbloc(i+1).gt.0) then
               if (numbloc(i).eq.0) then
                   if (natbloc.eq.0) then
                      write(6,'(2A)') progrwn,
     .              ' Substructuring information ignored.'
                      nb=nb-1
                   endif
               else
                   goto 50
               endif
             elseif (i.eq.1) then
               nresb=1
               natbloc=0
               nb=nb+1
             endif

c            Debut d'une serie de blocs:

             if (i.ne.natom.and.numbloc(i).gt.0.and.
     .           numbloc(i+1).eq.0) then
                 nresb=0
                 natbloc=0
                 nb=nb+1
                 goto 50
             endif

             if (i.gt.1.and.resi(i).ne.resi(i-1)) then
                 nresb=nresb+1
             endif

c           "Saut" de numerotation => Fin de bloc.

             qok=.true.
             if (i.gt.1) 
     .       qok=(resi(i).eq.resi(i-1).and.ssu(i).eq.ssu(i-1)).or.
     .           (resi(i)-resi(i-1).eq.1.and.ssu(i).eq.ssu(i-1))

             if (nresb.gt.nbb.or..not.qok) then
                 if (natbloc.eq.0) then
                     write(6,'(2A)') progrwn,
     .             ' Substructuring information ignored.'
                     nb=nb-1
                 endif
                 natbloc=1
                 nresb=1
                 nb=nb+1
             elseif (i.eq.natom) then
                 if (natbloc.eq.0) then
                     write(6,'(2A)') progrwn,
     .             ' Substructuring information ignored.'
                     nb=nb-1
                 endif
             else
                 natbloc=natbloc+1
             endif

             numbloc(i)=nb

 50          continue
          enddo

          goto 100
 70       continue
          write(6,'(/2A/A)') progrer,
     .  ' While reading substructuring information in :',lign80
          stop '*Wrong data*'

c     Subunits are supposed to be written one after the other:

      elseif (sstr.eq.'SUBU') then
          nssu=0
          natbloc=0

          do i=1,natom

c           "Saut-arriere" de numerotation => Fin de bloc.

             qok=.true.
             if (i.gt.1) 
     .       qok=resi(i).gt.resi(i-1).and.ssu(i).eq.ssu(i-1)

             if (.not.qok) then
                nssu=nssu+1
                if (nb.gt.0) then
                    if (natbloc.eq.0) then
                        write(6,'(2A)') progrwn,
     .                ' Substructuring information ignored.'
                        nb=nb-1
                    endif
                endif
                nb=nb+1
                natbloc=0
             endif
             natbloc=natbloc+1
             numbloc(i)=nb
          enddo

          if (prtlev.gt.0)
     .    write(6,'(A,I6,A)') program,nssu,' subunits.'
 
c     sstr='NONE'
c     ----------
c     nbb residue(s) per block:
c    (Residues are supposed to be written one after the other)

      else
          if (prtlev.gt.0)
     .    write(6,'(A,I6,A)') program,nbb,' residue(s) per block.'
          nb=1
          nres=1
          nresb=1
          natbloc=0

          do i=1,natom
             if (i.gt.1.and.resi(i).ne.resi(i-1)) then
                 nres=nres+1
                 nresb=nresb+1
             endif

c           "Saut" de numerotation => Fin de bloc.

             qok=.true.
             if (i.gt.1) 
     .       qok=(resi(i).eq.resi(i-1).and.ssu(i).eq.ssu(i-1)).or.
     .           (resi(i)-resi(i-1).eq.1.and.ssu(i).eq.ssu(i-1))

             if (nresb.gt.nbb.or..not.qok) then
                 if (natbloc.eq.0) then
                     write(6,'(2A)') progrwn,
     .             ' Substructuring information ignored.'
                     nb=nb-1
                 endif
                 natbloc=1
                 nresb=1
                 nb=nb+1
             else
                 natbloc=natbloc+1
             endif
             numbloc(i)=nb
          enddo
          if (natbloc.eq.0) then
              write(6,'(2A)') progrwn,
     .      ' Substructuring information ignored.'
              nb=nb-1
          endif

          if (prtlev.gt.0)
     .    write(6,'(A,I6,A)') program,nres,' residues.'
      endif

 100  continue
      close(uninp)

c     ---------------------
c     Length of each block:    
c     ---------------------
      k=1
      natbloc=1

      do i=2,natom
         if (i.eq.natom.or.numbloc(i).ne.numbloc(i-1)) then
             if (i.eq.natom) natbloc=natbloc+1

             if (natbloc.lt.3) then
                 write(6,'(/A,I2,A,I4,A)') progrwn,
     .           natbloc,' atoms in block ',k,
     .         ' i.e., less than what is required for a rigid body.'

                 if (i.eq.natom) then
                     write(6,'(2A,I6,2A,I6)') progrwn,
     .             ' Last atom in this block is the ',i,
     .              'th, in residue ',ssu(i),resi(i)
                     write(6,'(2A)') progrwn,
     .             ' It is merged with last block.'

                     k=k-1
                     TABB(k)=TABB(k)+3*natbloc
                     if (k.eq.1.or.TABB(k).lt.natbmin) natbmin=TABB(k)
                     if (k.eq.1.or.TABB(k).gt.natbmax) natbmax=TABB(k) 

                 elseif (ssu(i).ne.ssu(i-1)) then
                     write(6,'(2A,I6,2A,I6)') progrwn,
     .             ' Last atom in this block is the ',i-1,
     .              'th, in residue ',ssu(i-1),resi(i-1)
                     write(6,'(2A)') progrwn,
     .             ' It is merged with the previous one.'

                     k=k-1
                     TABB(k)=TABB(k)+3*natbloc

                     if (k.eq.1.or.TABB(k).lt.natbmin) natbmin=TABB(k)
                     if (k.eq.1.or.TABB(k).gt.natbmax) natbmax=TABB(k) 

                     if (prtlev.gt.1) 
     .               write(6,'(A,I6,A,I6)') program,TABB(k)/3,
     .             ' atoms in block ',k 

                     k=k+1
                     natbloc=1
                 else
                     write(6,'(2A,I6,2A,I6)') progrwn,
     .             ' Last atom in this block is the ',i-1,
     .              'th, in residue ',ssu(i-1),resi(i-1)
                     write(6,'(2A)') progrwn,
     .             ' It will be merged with next block.'
                     natbloc=natbloc+1
                 endif
             else
                 TABB(k)=3*natbloc

                 if (k.eq.1.or.TABB(k).lt.natbmin) natbmin=TABB(k)
                 if (k.eq.1.or.TABB(k).gt.natbmax) natbmax=TABB(k) 

                 if (prtlev.gt.1) then 
                 write(6,'(A,I6,A,I6)') program,natbloc,
     .         ' atoms in block ',k 
                 write(6,'(A,I6)') ' Block first atom: ',i-natbloc
                 endif

                 if (i.ne.natom) then
                     k=k+1
                     natbloc=1
                 endif
             endif
         else
             natbloc=natbloc+1
         endif
      enddo
      nb=k
      natbmax=natbmax/3
      natbmin=natbmin/3
 
      write(6,'(/A,I6,A)') program,nb,' blocks.'

      if (prtlev.gt.0) then
      write(6,'(/2A,I6,A)') program,' At most, ',
     .   natbmax,' atoms in each of them.'
      write(6,'(2A,I6,A)') program,' At least,',
     .   natbmin,' atoms in each of them.'
      endif

      if (prtlev.gt.1) 
     .write(6,'(/2A)') program,' Normal end of Blocpdb.'

      RETURN
      END

c----------------------------------------------------------------------

      SUBROUTINE DIAGSTD(ndim,nvecout,eige,evord,amat,ev,evsort,work,
     .           prtlev)

c     ------------------------------------------------
c     Diagonalisation d'une matrice reelle symetrique.
c     ------------------------------------------------
c     Format de la matrice lue: i, j, element-ij-non-nul.
c     CERFBIN -Matrice binaire   (creuse)  : diagrtb_work.sdijb
c     Valeurs et vecteurs propres -> diagrtb_work.eigenfacs
c    (format CERFACS aussi) 
c
c     Routine de diagonalisation: TQLI (EISPACK).
c    -simple, et dans le domaine public...
c
c     --------------------------------
c     Ndim: maximum size of the matrix
c     --------------------------------
 
      implicit none

      logical qcrois, qexist, qinterr, qverbos
      integer evord(*), i, ii, j, jj, k, natom, nbig, nbelow, ndim, 
     .        nord, nredond, ntrace, nvec, nvecout, nunit, nzero, 
     .        prtlev, rdunit, unmess, unmodes
      double precision amat(ndim,*), bigzero, eigvalmin, 
     .       ev(*), evsort(*), matrd, trace, work(*)
      character cformat*20, cstatus*20, eige*4, matrice*20, nomfich*40, 
     .       program*9, progrer*12, progrwn*12
 
      program=' Diagstd>'
      progrer='%Diagstd-Er>'
      progrwn='%Diagstd-Wn>'
 
      if (prtlev.gt.1)
     .write(6,'(/2A)') program,' Entering in.'

c     Sortie standard: 
      unmess=6
      nvec=ndim
 
c     Detection de la matrice d'entree:
c     --------------------------------
      qverbos=.false.
      if (prtlev.gt.1) qverbos=.true.
      
      nunit=10
      rdunit=nunit
      nunit=nunit+1
      cformat='UNFORMATTED'
      cstatus='OLD'
      nomfich='diagrtb_work.sdijb'

      call openam(nomfich,cformat,cstatus,
     .     rdunit,qverbos,qinterr,qexist)

      if (qexist) then
          matrice='CERFBIN'
      else
          matrice='NONE'
          write(unmess,'(/2A)') progrer,
     .' Projected matrix not found. Expected name: diagrtb_work.sdijb '
          stop '*Projected matrix lost*'
      endif
 
      if (prtlev.gt.1)
     .write(unmess,'(3A)') program,
     .    ' Projected matrix to be read from file: ',nomfich
 
c     Lecture matrice d'entree (CERFACS, CERFBIN):
c     --------------------------------------------
 
      if (prtlev.gt.1)
     .write(unmess,'(2A)') program,
     .     ' CERFACS matrix format.'
 
c     1) Ordre de la matrice, nombre de lignes:
c     -----------------------------------------
      k=0
      nord=0
  90  continue
      if (matrice.eq.'CERFACS') then
      read(rdunit,*,end=100) i,j
      else
      read(rdunit,end=100) i,j
      endif
      k=k+1
      if (i.le.0.or.j.le.0) then
          write(unmess,'(/2A,I9,2(A,I6))')
     .    progrer,' in ligne: ',k,' I= ',i,' J= ',j
          stop '*Wrong matrix*'
      endif
      if (i.gt.nord) nord=i
      if (j.gt.nord) nord=j
      goto 90
 100  continue
 
      if (prtlev.gt.0)
     .write(unmess,'(2A,I9)')
     .     program,' Projected matrix order =',nord
      if (prtlev.gt.1)
     .write(unmess,'(2A,I9)')
     .     program,' Nb of non-zero elements:',k
 
      if (nord.gt.ndim) then
          write(unmess,'(/2A)')
     .    progrer,' Matrix can not be read.'
          if (nord.gt.ndim) write(unmess,'(2(A,I9))')
     .   ' Nord=  ',nord,' > Ndim=  ',ndim
          stop '*Wrong matrix*'
      endif
 
c     2) Lecture de la matrice:
c     -------------------------
      rewind(rdunit)
 
      nredond=0
      ntrace=0
      trace=0.d0
      nbig=0
      do i=1,nord
        do j=1,nord
         amat(i,j)=0.d0
        enddo
      enddo

      do jj=1,k
         if (matrice.eq.'CERFACS') then
         read(rdunit,*,err=95) i,j,matrd
         else
         read(rdunit,err=95) i,j,matrd
         endif
 
         if (dabs(matrd).gt.0.d0) then
             amat(i,j)=matrd
             amat(j,i)=matrd
             if (i.eq.j) then 
                trace=trace+matrd
                ntrace=ntrace+1
             endif
             if (matrd.gt.1E+10) then
                 nbig=nbig+1
                 if (nbig.lt.10) then
                     write(unmess,'(2A,2I12,A,G12.3)') 
     .               progrwn,' Element: ',i,j,' = ',matrd
                 else 
                     if (nbig.eq.10) write(unmess,*) '...'
                 endif
             endif
         else
             nredond=nredond+1
         endif
      enddo
      goto 105
  95  continue
      write(unmess,'(/2A,I6)')
     .     progrer,' while reading ligne ',k
      write(unmess,'(2I6,F16.8)') ' i, j, matrd= ',i,j,matrd
      stop '*Wrong matrix*'
 105  continue
 
      if (nredond.gt.0)
     .write(unmess,'(2A,I9)') progrwn,
     .    ' Nb of matrix elements found twice: ',nredond
      if (nbig.gt.0)
     .write(unmess,'(2A,I9)') progrwn,
     .    ' Nb of elements    > 1E+10 :',nbig
      if (prtlev.gt.1)
     .write(6,'(2A,F12.4)') program,' Projected matrix trace = ',trace
      if (nord-ntrace.ne.0)
     .write(unmess,'(2A,I11)') progrwn,
     .    ' Nb on zero elements on the trace:',nord-ntrace
 
c     Diagonalisation:
c     ----------------
      nomfich='diagrtb_work.eigenfacs'
      cformat='FORMATTED'
      cstatus='ove'
      unmodes=nunit
      nunit=nunit+1
      call openam(nomfich,cformat,cstatus,
     .     unmodes,qverbos,qinterr,qexist)
 
      if (prtlev.gt.1)
     .write(unmess,'(2A)') program,' Diagonalization.'
 
      if (nvec.gt.nord) nvec=nord
      write(unmess,'(/A,I7,A)') program,
     .      nvec,' eigenvectors are computed. '
      if (nvecout.gt.nvec) nvecout=nvec

      if (prtlev.gt.1)
     .write(unmess,'(A,I7,A)') program,
     .    nvecout,' of them to be saved. '
 
c     Initialisations:
      do i=1,ndim
         ev(i)=0.d0
      enddo
 
c     Eigenvalues/Matrix Diagonalization

c     The following routines (from the original EISPACK library) 
c     perform a diagonalization of a real symmetric matrix based 
c     on the QL algorithm. 

      CALL TRED2(amat,nord,ndim,ev,work)
      CALL TQLI(ev,work,nord,ndim,amat)
 
      trace=0.d0
      do i=1,nvec
         trace=trace+ev(i)
      enddo
      if (prtlev.gt.0)
     .write(unmess,'(/2A,F12.4)') program,
     .     ' Sum of eigenvalues =',trace
 
c     Compter les modes a Valeur propre "nulle":
c     a) Valeur propre la plus proche de la nullite.
c     b) Valeur propres "proches" de cette valeur (a un facteur 100 pres).
 
      do i=1,nvec
         if (i.eq.1.or.dabs(ev(i)).lt.eigvalmin) 
     .   eigvalmin=dabs(ev(i))
      enddo 
      if (prtlev.gt.1)
     .write(6,'(2A,F13.6)') program,
     .' Best zero-eigenvalue found  :',eigvalmin
 
      nbelow=0
      nzero=0
      do i=1,nvec
         if (dabs(ev(i)).lt.100*eigvalmin) then
             if (dabs(ev(i)).gt.bigzero) bigzero=dabs(ev(i))
             nzero=nzero+1
         endif
         if (ev(i).lt.-eigvalmin) then
             nbelow=nbelow+1
         endif
      enddo 
 
      if (prtlev.gt.0.or.nzero.ne.6) 
     .write(6,'(/A,I7,A,F13.7)') program,nzero,
     . ' zero-eigenvalues, that is, below or equal to:',bigzero
      if (nbelow.gt.0) 
     .write(6,'(/A,I7,A,F10.4)') program,nbelow,
     . ' negative eigenvalues, that is, below: ',-eigvalmin

      if (nzero.ne.6.or.nbelow.gt.0) then
          if (nbelow.gt.0.or.nzero.lt.6) then
              write(6,'(/2A)') progrwn,
     .      ' The studied structure is not a minimum-energy one ?'
              write(6,'(A)') 
     .'(Otherwise: coordinates, masses and matrix are not consistent ?)'
          else
              write(6,'(2A)') progrwn,
     .     ' Six expected. Parts of the structure interact too little ?'
          endif
      endif

c     Par ordre croissant ou decroissant:
      qcrois=.true.
      if (eige.eq.'HIGH') qcrois=.false.

      call trier(ev,nvec,ndim,evsort,evord,qcrois)

      write(unmess,'(/2A/(5F15.7))') program,
     .    ' Selected eigenvalues: ',(ev(evord(i)),i=1,nvecout)

      if (prtlev.gt.0)
     .WRITE(unmess,'(/2A/(5F15.7))') program,
     .    ' Frequencies (cm-1, '//
     .     'if the input matrix is a hessian in CHARMM units):',
     .    (sqrt(dabs(ev(evord(i))))*108.591365,i=1,nvecout)
 
c     Ecriture des modes normaux au format 'CERFACS':
c     -----------------------------------------------
      do j=1,nvecout
         i=evord(j)
         write(unmodes,'(A,I5,7X,A,1PG12.4)') 
     .       ' VECTOR',j,'VALUE',ev(i)
         write(unmodes,'(1X,35(1H-))') 
         write(unmodes,'(3(1PG12.4))') 
     .        (amat(k,i),k=1,nord)
      enddo
      close(unmodes)
 
      if (prtlev.gt.1)
     .write(unmess,'(/2A)')
     .      program,' Normal end.'
 
      return
      end
c----------------------------------------------------------------------
      SUBROUTINE TRED2(A,N,NP,D,E)

c     Reduce the matrix to tridiagonal form.

      integer i, j, k, l, n, np
      double precision A(NP,NP), D(NP), E(NP), f, g, h, hh, 
     .  scale

      IF(N.GT.1)THEN
        DO 18 I=N,2,-1
          L=I-1
          H=0.
          SCALE=0.
          IF(L.GT.1)THEN
            DO 11 K=1,L
              SCALE=SCALE+ABS(A(I,K))
11          CONTINUE
            IF(SCALE.EQ.0.)THEN
              E(I)=A(I,L)
            ELSE
              DO 12 K=1,L
                A(I,K)=A(I,K)/SCALE
                H=H+A(I,K)**2
12            CONTINUE
              F=A(I,L)
              G=-SIGN(SQRT(H),F)
              E(I)=SCALE*G
              H=H-F*G
              A(I,L)=F-G
              F=0.
              DO 15 J=1,L
                A(J,I)=A(I,J)/H
                G=0.
                DO 13 K=1,J
                  G=G+A(J,K)*A(I,K)
13              CONTINUE
                IF(L.GT.J)THEN
                  DO 14 K=J+1,L
                    G=G+A(K,J)*A(I,K)
14                CONTINUE
                ENDIF
                E(J)=G/H
                F=F+E(J)*A(I,J)
15            CONTINUE
              HH=F/(H+H)
              DO 17 J=1,L
                F=A(I,J)
                G=E(J)-HH*F
                E(J)=G
                DO 16 K=1,J
                  A(J,K)=A(J,K)-F*E(K)-G*A(I,K)
16              CONTINUE
17            CONTINUE
            ENDIF
          ELSE
            E(I)=A(I,L)
          ENDIF
          D(I)=H
18      CONTINUE
      ENDIF
      D(1)=0.
      E(1)=0.
      DO 23 I=1,N
        L=I-1
        IF(D(I).NE.0.)THEN
          DO 21 J=1,L
            G=0.
            DO 19 K=1,L
              G=G+A(I,K)*A(K,J)
19          CONTINUE
            DO 20 K=1,L
              A(K,J)=A(K,J)-G*A(K,I)
20          CONTINUE
21        CONTINUE
        ENDIF
        D(I)=A(I,I)
        A(I,I)=1.
        IF(L.GE.1)THEN
          DO 22 J=1,L
            A(I,J)=0.
            A(J,I)=0.
22        CONTINUE
        ENDIF
23    CONTINUE
      RETURN
      END
c----------------------------------------------------------------------
      SUBROUTINE TQLI(D,E,N,NP,Z)

c     Finds the eigenvalues and eigenvectors of a tridiagonal matrix:

      integer i, iter, j, k, l, m, n, np
      double precision b, c, D(NP), dd, E(NP), f, g, p, r, s, 
     .       Z(NP,NP)

      IF (N.GT.1) THEN
        DO 11 I=2,N
          E(I-1)=E(I)
11      CONTINUE
        E(N)=0.
        DO 15 L=1,N
          ITER=0
1         DO 12 M=L,N-1
            DD=ABS(D(M))+ABS(D(M+1))
            IF (ABS(E(M))+DD.EQ.DD) GO TO 2
12        CONTINUE
          M=N
2         IF(M.NE.L)THEN
            IF(ITER.EQ.30)PAUSE 'too many iterations'
            ITER=ITER+1
            G=(D(L+1)-D(L))/(2.*E(L))
            R=SQRT(G**2+1.)
            G=D(M)-D(L)+E(L)/(G+SIGN(R,G))
            S=1.
            C=1.
            P=0.
            DO 14 I=M-1,L,-1
              F=S*E(I)
              B=C*E(I)
              IF(ABS(F).GE.ABS(G))THEN
                C=G/F
                R=SQRT(C**2+1.)
                E(I+1)=F*R
                S=1./R
                C=C*S
              ELSE
                S=F/G
                R=SQRT(S**2+1.)
                E(I+1)=G*R
                C=1./R
                S=S*C
              ENDIF
              G=D(I+1)-P
              R=(D(I)-G)*S+2.*C*B
              P=S*R
              D(I+1)=G+P
              G=C*R-B
              DO 13 K=1,N
                F=Z(K,I+1)
                Z(K,I+1)=S*Z(K,I)+C*F
                Z(K,I)=C*Z(K,I)-S*F
13            CONTINUE
14          CONTINUE
            D(L)=D(L)-P
            E(L)=G
            E(M)=0.
            GO TO 1
          ENDIF
15      CONTINUE
      ENDIF
      RETURN
      END
c----------------------------------------------------------------------
      SUBROUTINE PREPMAT ( fmtx, typf, natblocs, natom, nb, qtrace,
     &                     indexi, indexj, tabb, a, hw, prtlev)
 
c     Scalar Arguments
 
      character        fmtx*(*), typf*(*)
      integer          natblocs, natom, nb 
 
c     Array Arguments
 
      logical          qtrace(3*natom)
      integer          indexi(9*natblocs*natblocs),
     &                 indexj(9*natblocs*natblocs), 
     &                 prtlev, tabb(nb)
      double precision a(3*natblocs,3*natom), hw(9*natblocs*natblocs)
 
c     Purpose:
c     =======
 
c     --------------------------------------------
c     Matrix preparation: it is split into blocks.
c     --------------------------------------------
c
c     Arguments
c     =========
c
c     natblocs  : maximum number of atoms found in a block.
c     natom     : number of atoms in the system.
c     nb        : number of blocks the system is split into.
c     qtrace    : flag to remember that a given diagonal element is known.
c     indexi    : i-index of non-zero elements in block hw.
c     indexj    : j-index of non-zero elements in block hw.
c     tabb      : block lengths.
c     a         : band-matrix corresponding to a given block.
c     hw        : block being filled.
c 
C-----------------------------------------------------------------------
c
c     Local variables
 
      logical          qinit
      integer          bloc, i, ii, iii, imax, j, jbloc, k, kk, 
     &                 nblocs, nbnnul, nempty, ni1, ni2, nj1, nj2, 
     &                 nlign, nn, nread, ntotn1, tbloc, tt
      double precision toto, trace
      character        program*9, progrer*12, progrwn*12
c
C-----------------------------------------------------------------------
      program=' Prepmat>'
      progrwn='%Prepmat-Wn>'
      progrer='%Prepmat-Er>'
 
      if (prtlev.gt.1)
     .write(6,'(/2A)') program,' Entering in.'

      nblocs=nb
 
c     Fichiers d'entree 
c     -----------------
      if (typf.eq.'FREE') then
      open(unit=50,file=fmtx,status='old',form='formatted')
      else
      open(unit=50,file=fmtx,status='old',form='unformatted')
      endif
      
c     Fichiers de sortie
c     ------------------
      open(unit=51,file='diagrtb_work.matblocs',status='unknown',
     .     form='unformatted')

c    --------------------------------------------------------------
c    Creation du fichier diagrtb_work.matblocs => matrice ecrite par bloc
c    Ce fichier contient
c       1- la longueur de chaque bloc
c       2- les elements de la matrice correspondant a chaque bloc 
c    --------------------------------------------------------------

      if (prtlev.gt.1)
     .write(6,'(2A)') program,' Rewriting of the matrix begins.'

      write(51) natom,NB,(TABB(k),k=1,NB)
      nlign=1
      nempty=0
      
c     ----------------------------      
c     Initialisation compteur
c     ----------------------------

      NI1=1
      NTOTN1=0
      nn=1
      NI2=TABB(nn)
      qinit=.true.
      TBLOC=0
 
      imax=-1
      trace=0.d0
      do i=1,natom
         qtrace(i)=.false.
      enddo

      nread=1
 50   continue

c     NI1,NI2 bornes du residue vertical
c     ----------------------------------

c        Matrice-bande A(i,j)=0.d0:
c        -------------------------
	 if (qinit) then
         do i=1,TABB(nn)
            kk=NTOTN1+1
            do j=kk,3*natom
               A(i,j)=0.d0
            enddo
         enddo
         endif

         if (typf.eq.'FREE') then
         READ(50,*,end=99,err=900) i,j,toto
         else
         READ(50,end=99,err=900) i,j,toto
         endif
         nread=nread+1

         if (i.gt.3*natom.or.j.gt.3*natom) then
             write(6,'(/2A,I6,A,I6,A/A,I6,A)') progrer,
     .     ' Matrix element ',i,' j= ',j,
     .     ' found.',' More than ',natom,' atoms in matrix file !'
             stop '*Wrong matrix or wrong coordinate file*'
         endif

         if (i.eq.j) then
         if (.not.qtrace(i)) then
             trace=trace+toto
             qtrace(i)=.true. 
         endif
         endif

         if (i.gt.imax) imax=i
         if (j.gt.imax) imax=j

         IF (i.le.NI2) then
            iii=i-NTOTN1
            A(iii,j)=toto
	    qinit=.false.
         endif
 
c        Decoupage de la matrice-bande lue,
c        et sortie des blocs, a raison d'un bloc par ligne:
 
         if (i.gt.NI2) then
c           On a depasse NI2, on remonte d'un cran:
            backspace 50
	    NJ1=NI1
	    NJ2=NI2

c    NJ1,NJ2 borne du residue en horizontal
c    --------------------------------------
c    au depart NJ1 et NJ2 = NI1 et NI2
c    TBLOC pour TABB 
c    a chaque fois il faut decaler de un pour avoir
c    la longueur du bon bloc

	 tt=0
	 TBLOC=TBLOC+1
	 BLOC=TBLOC
 
c    Boucle sur les blocs pour une bande NI1-NI2
c    NI1 et NI2 constant dans la boucle
c    -------------------------------------------
         do JBLOC=1,NB
	    nbnnul=0
            ii=0
	    tt=tt+1
c
c    Si premier bloc, seulement une partie donc on
c    cree la partie inferieure
c    ici NJ1 et NJ2 sont egaux a NI1 et NI2
c    ---------------------------------------------

         if (tt.eq.1) then
               do i=1,TABB(nn)
                  do j=kk,NI2   
                     A(j-NTOTN1,i+NTOTN1)=A(i,j)
                  enddo
               enddo
               do i=1,TABB(nn)
                  do j=NJ1,NJ2
                     if (A(i,j).ne.0.d0) then
                        ii=ii+1
                        HW(ii)=0.d0
                        nbnnul=ii
                        HW(ii)=A(i,j)
                        indexi(ii)=i+NTOTN1
                        indexj(ii)=j
                     endif
                  enddo
              enddo
         if (nbnnul.gt.9*natblocs*natblocs) then
             write(6,'(/2A/2(A,I12))') progrer,
     .     ' Too many matrix elements in a single block: ',
     .     ' Nbnnul= ',nbnnul,' Max= ',9*natblocs*natblocs
             stop '*Too large block*'
         endif
         if (nbnnul.le.0) nempty=nempty+1
         nlign=nlign+1
         write(51) nbnnul,(indexi(ii),indexj(ii),HW(ii),ii=1,nbnnul) 
         endif
c
c    Pour les autres blocs de la bande
c    NJ1 et NJ2 different de NI1 et NI2
c    on decale au bloc suivant
c    bloc suivant=> bloc+1 sachant que la valeur de depart
c    pour bloc est tbloc
c    ----------------------------------
         if (tt.gt.1) then
	       BLOC=BLOC+1
	       NJ1=NJ2+1
	       NJ2=NJ2+TABB(BLOC)
               do i=1,TABB(nn)
                  do j=NJ1,NJ2
                     if (A(i,j).ne.0.d0) then
                        ii=ii+1
                        HW(ii)=0.d0
                        nbnnul=ii
                        HW(ii)=A(i,j)
                        indexi(ii)=i+NTOTN1
                        indexj(ii)=j
                     endif
                  enddo
               enddo
         if (nbnnul.gt.9*natblocs*natblocs) then
             write(6,'(/2A/2(A,I12))') progrer,
     .     ' Too many matrix elements in a single block: ',
     .     ' Nbnnul= ',nbnnul,' Max= ',9*natblocs*natblocs
             stop '*Too large block*'
         endif
         if (nbnnul.le.0) nempty=nempty+1
         nlign=nlign+1
          write(51) nbnnul,(indexi(ii),indexj(ii),HW(ii),ii=1,nbnnul)
	 endif
        enddo
 
c       fin boucle sur les blocs => initialisation de A
c       necessaire donc qinit=vrai
c       on aura un bloc en moins => nb=nb-1
c       changement des bornes verticales
c       ------------------------------------------------------
	qinit=.true.
        NTOTN1=NTOTN1+TABB(nn)
	NB=NB-1
	nn=nn+1
	NI1=NI2+1
	NI2=NI2+TABB(nn)
       endif

      goto 50
 99   continue

      if (prtlev.gt.0) 
     .write(6,'(/A,I13,A)') program,nread,' matrix lines read.'

      if (prtlev.gt.0)
     .write(6,'(/2A,I10)') program,' Matrix order    = ',imax
      write(6,'(/2A,F15.4)') program,' Matrix trace    = ',trace

      if (imax/3.ne.natom) then
          write(6,'(/A,I6,A/A,I6,A)') progrer,imax,
     .  ' coordinates found in this matrix, ',
     .  ' instead of ',natom,'*3, as expected. Not the right one ?'
          stop '*Wrong matrix or wrong coordinate file*'
      endif

      if (prtlev.gt.1)
     .write(6,'(2A,2I7,F15.4)') program,' Last element read: ',i,j,toto

            iii=i-NTOTN1
            A(iii,j)=toto
            NJ1=NI1
            NJ2=NI2
	    ii=0
               do i=1,TABB(nn)
                  do j=kk,NJ2
                     A(j-NTOTN1,i+NTOTN1)=A(i,j)
                  enddo
               enddo
               do i=1,TABB(nn)
                  do j=NJ1,NJ2
                     if (A(i,j).ne.0.d0) then
                        ii=ii+1
                        HW(ii)=0.d0
                        nbnnul=ii
                        HW(ii)=A(i,j)
                        indexi(ii)=i+NTOTN1
                        indexj(ii)=j
                     endif
                  enddo
               enddo
         if (nbnnul.gt.9*natblocs*natblocs) then
             write(6,'(/2A/2(A,I12))') progrer,
     .     ' Too many matrix elements in a single block: ',
     .     ' Nbnnul= ',nbnnul,' Max= ',9*natblocs*natblocs
             stop '*Too large block*'
         endif
         if (nbnnul.le.0) nempty=nempty+1

      nlign=nlign+1
      write(51) nbnnul,(indexi(ii),indexj(ii),HW(ii),ii=1,nbnnul)
 
      nb=nblocs 
      if (prtlev.gt.1) then
          write(6,'(A,I13,A)') program,nlign,' lines saved.'
          write(6,'(A,I13,A)') program,nempty,' empty lines.'
      endif

      if (nlign.ne.nb*(nb+1)/2+1) then
          write(6,'(/A,I6,A)') progrer,
     .    nb*(nb+1)/2+1,' lines are expected on output !'
          stop '*Unexpected big problem*'
      else if (prtlev.gt.1) then
          write(6,'(2A)') program, 
     .  ' Number of lines on output is as expected.'
      endif
 
      close(50)
      close(51)

      if (prtlev.gt.1) 
     .    write(6,'(2A)') program,' Normal end of Prepmat.'

      RETURN
 900  write(6,'(/2A,I9)') progrer,' While reading matrix ligne ',nread
      stop '*Wrong matrix*'
      END
c----------------------------------------------------------------------
      SUBROUTINE RTB ( natom, nb, nbrt, nddres, nddres2, indexi, indexj,
     &           n, amass, corlin, d, h, hd, hh, mat, rt, s, prtlev )
c
c     Scalar Arguments
      integer          natom, nb, nbrt, nddres, nddres2
c
c     Array Arguments
      integer          indexi(nddres2), indexj(nddres2), n(nb), prtlev
      double precision amass(3*natom), corlin(3*natom), 
     &                 d(nbrt,nddres), h(nddres2), hd(nddres,nbrt),
     &                 hh(nddres,nddres), mat(6*nb,6*nb),
     &                 rt(nbrt,nddres,nb), s(nbrt,nbrt) 
c
c     Purpose:
c     =======
c
c     ------------------
c     Matrix projection.
c     ------------------
c
c     Lit les fichiers produits par "prepmat", c'est-a-dire:
c     Les coordonnes et les masses ("diagrtb_work.xyzm")
c     La matrice re-ecrite bloc par bloc ("diagrtb_work.matblocs")
c
c     Ecrit la matrice projetee ("diagrtb_work.sdijb")
c    -format i,j, element-non-nul.
c
c     Decrit les rotation-translations de
c     chaque element de chaque bloc ("diagrtb_work.blocs")
c
c     A faire: taux de remplissage de la matrice projetee.
c
c     Arguments
c     =========
c
c     natom   : number of atoms in the system.
c     nb      : number of blocks the system is split into.
c     nbrt    : number of degrees of freedom of each block.
c     nddres  : size of largest block.
c     nddres2 : nddres**2
c     indexi  : i-index of non-zero elements in block hw.
c     indexj  : j-index of non-zero elements in block hw.
c     n       : block lengths.
c     amass   : masses.
c     corlin  : coordinates.
c     d       : tranlation and rotation vectors of each block.
c     h       : block being considered.
c     hd      : working matrix for projection of a given block.
c     hh      : working matrix for projection of a given block.
c     mat     : projected matrix.
c     rt      : tranlation and rotation vectors of all blocks.
c     s       : working matrix for projection of a given block.
c
C-----------------------------------------------------------------------
c
c     Local variables
c
      logical          qok
      integer          i, ibloc, ii, indxi, indxj, j, jbloc, k, kk, kr,
     &                 mmm, natcur, nbcur, nbnnul, nempty, ni, nj,
     &                 nlign, nnskip, nnuls, nskip, ntot, ntoti, ntotj
      double precision amasstot, trace, xg, yg, zg
      character        program*5, progrer*8, progrwn*8
C
C     ------------------------- CHANGEMENT D'ORIGINE DES COORDONNEES CARTESIENNES
 
      program=' RTB>'
      progrwn='%RTB-Wn>'
      progrer='%RTB-Er>'

      if (prtlev.gt.1)
     .write(6,'(/2A)') program,' Entering in.'

c     Fichier d'entree
c     ----------------

      open(unit=74,file='diagrtb_work.xyzm',status='old',
     .     form='unformatted')
      open(unit=51,file='diagrtb_work.matblocs',status='old',
     .     form='unformatted')
 
c     Fichier de sortie
c     -----------------

      open(unit=52,file='diagrtb_work.sdijb',status='unknown',
     .     form='unformatted')
      open(unit=35,file='diagrtb_work.blocs',status='unknown',
     .     form='unformatted')

c     Lectures + Tests:
c     -----------------

      natcur=natom
      read(74) natom

      if (prtlev.gt.1)
     .write(6,'(2A,I6)') program,
     .  ' Number of atoms found in temporary coordinate file:',natom
      if (natom.ne.natcur) then
          write(6,'(/A,I6,A)') progrer,natcur,' atoms... up to now.'
          stop '*Unexpected big problem*'
      endif
       
      read(74) (corlin(ii),ii=1,3*natom)
      read(74) (amass(ii),ii=1,3*natom)
 
      qok=.true.
       AMASSTOT = 0.D0 
       DO I=1,3*natom
	 AMASSTOT = AMASSTOT + AMASS(I)
         if (amass(i).lt.0) qok=.false.
       ENDDO      
      AMASSTOT = AMASSTOT / 3.D0 

      if (.not.qok) then
          write(6,'(2A)') progrer,
     .  ' Masses with negative values read in temporary file.'
          stop '*Unexpected big problem*'
      endif
      if (prtlev.gt.1)
     .write(6,'(2A,F16.4)') program,' Total mass = ',AMASSTOT
C
      natcur=natom
      nbcur=nb
      read(51) natom,NB,(N(k),k=1,NB)

      if (prtlev.gt.1)
     .write(6,'(2A,I6)') program,
     .  ' Number of atoms found in matrix:',natom
      if (natom.ne.natcur) then
          write(6,'(2A)') progrer,
     .  ' Pdb file and matrix are not consistent any more !'
          stop '*Unexpected big problem*'
      endif
 
      if (prtlev.gt.1)
     .write(6,'(2A,I6)') program,' Number of blocks =',nbcur
      if (nb.ne.nbcur) then
          write(6,'(/A,I6,A)') progrer,nbcur,' blocks... up to now !'
          stop '*Unexpected big problem*'
      endif
      write(35) natom,NB,(N(k),k=1,NB)

      natcur=0
      do i=1,nb
         natcur=natcur+n(i)
      enddo
      if (natcur.ne.3*natom) then
          write(6,'(2A,I6,A,I6)') progrer,
     .  ' Sum of block lengths: ',natcur,
     .  ' instead of ',3*natom
          stop '*Unexpected big problem*'
      endif

      nlign=1
      nempty=0
      nskip=0

C     <------------------------------------------ DEBUT DE BOUCLE SUR LES BLOCS
C
      if (prtlev.gt.1)
     .write(6,'(2A)') program,' Projection begins.'
      kk=0
      NTOT=0

      DO IBLOC=1,NB  
C
C     REMPLISSAGE DES BLOCS
C
      nbnnul=0

      read(51,end=895,err=900) 
     .     nbnnul,(indexi(ii),indexj(ii),H(ii),ii=1,nbnnul)
      nlign=nlign+1

      if (nbnnul.gt.nddres2) then
          write(6,'(A,I6,A,I6,A,I6)') progrer,
     .    nbnnul,' elements in bloc ',ibloc,
     .  ' Maximum allowed: ',nddres2
          stop '*Too large block*'
      endif
      if (nbnnul.le.0) then
          nempty=nempty+1
      else
      do i=1,nbnnul
         if (indexi(i).le.NTOT.or.indexj(i).le.NTOT) then
             write(6,'(A,5(A,I6))') progrer,
     .     ' Ntot=',ntot,' but i= ',indexi(i),' j= ',
     .       indexj(i),' for element ',i,' of bloc ',ibloc 
             stop '*Unexpected big problem*'
         endif
      enddo
      endif
     
c     <------------------------------------------On se place au bloc suivant 

      kk=kk+1
      do kr=1,NB-kk
      read(51,end=905,err=905) nnskip
      if (nnskip.le.0) nempty=nempty+1
      nskip=nskip+1
      enddo
 
c     <------------------------------------------Initialisation du bloc

      if (n(ibloc).gt.nddres.or.n(ibloc).le.0) then
          write(6,'(A,I6,A,I6,A,I6)') progrer,' N(ibloc)= ',n(ibloc),
     .  ' for bloc ',ibloc,
     .  ' Maximum allowed: ',nddres
          stop '*Too large block*'
      endif

      do i=1,N(IBLOC)
         do j=1,N(IBLOC)
         HH(i,j)=0.d0
         enddo
      enddo

c     <------------------------------------------Remplissage du bloc

      do ii=1,nbnnul
      i=indexi(ii)-NTOT
      j=indexj(ii)-NTOT
      HH(i,j)=H(ii)
      enddo

C 
C     CHANGEMENT D'ORIGINE DANS CHAQUE BLOC (CDG DU BLOC)
c     ---------------------------------------------------------

        AMASSTOT = 0.D0
        DO I=1,N(IBLOC)
         AMASSTOT = AMASSTOT + AMASS(NTOT+I)
        ENDDO      
	AMASSTOT=AMASSTOT/3.d0

C
        XG = 0.D0
        YG = 0.D0  
        ZG = 0.D0

        DO I=0,( (N(IBLOC)/3)-1 )
         XG = XG + AMASS(NTOT+3*I+1)*corlin(NTOT+3*I+1)
         YG = YG + AMASS(NTOT+3*I+2)*corlin(NTOT+3*I+2)
         ZG = ZG + AMASS(NTOT+3*I+3)*corlin(NTOT+3*I+3)
        ENDDO

       XG = XG / AMASSTOT
       YG = YG / AMASSTOT
       ZG = ZG / AMASSTOT
C
       DO I=0,( (N(IBLOC)/3)-1)      
        corlin(NTOT+3*I+1)= corlin(NTOT+3*I+1) - XG
        corlin(NTOT+3*I+2)= corlin(NTOT+3*I+2) - YG
        corlin(NTOT+3*I+3)= corlin(NTOT+3*I+3) - ZG
       ENDDO

C
C     PROJECTION DES TRANSLATIONS ET ROTATIONS --------------------------
C

      DO I=1,6
       DO J=1,N(IBLOC)
        D(I,J) = 0.D0 
       ENDDO
      ENDDO
C
      DO I=1, N(IBLOC)/3
       II=NTOT 
       D(1,1+3*(I-1))= DSQRT(AMASS(II+1+3*(I-1)))
       D(2,2+3*(I-1))= DSQRT(AMASS(II+2+3*(I-1)))
       D(3,3+3*(I-1))= DSQRT(AMASS(II+3+3*(I-1)))
       D(4,2+3*(I-1))=-DSQRT(AMASS(II+2+3*(I-1)))*corlin(II+3+3*(I-1))
       D(4,3+3*(I-1))= DSQRT(AMASS(II+3+3*(I-1)))*corlin(II+2+3*(I-1))
       D(5,1+3*(I-1))= DSQRT(AMASS(II+1+3*(I-1)))*corlin(II+3+3*(I-1))
       D(5,3+3*(I-1))=-DSQRT(AMASS(II+3+3*(I-1)))*corlin(II+1+3*(I-1))
       D(6,1+3*(I-1))=-DSQRT(AMASS(II+1+3*(I-1)))*corlin(II+2+3*(I-1))
       D(6,2+3*(I-1))= DSQRT(AMASS(II+2+3*(I-1)))*corlin(II+1+3*(I-1))
      ENDDO
C

      MMM=6

      CALL SCHMIDT(MMM,N(IBLOC),D ) 
C
      do i=1,6
         do j=1,N(IBLOC)
            RT(i,j,ibloc)=D(i,j)
	    write(35) i,j,ibloc,rt(i,j,ibloc)
         enddo
      enddo

      NTOT=NTOT+N(IBLOC)
      ENDDO
C   <-------------------------------------------FIN DE BOUCLE SUR LES BLOCS

      close(51)

      open(unit=51,file='diagrtb_work.matblocs',status='old',
     .     form='unformatted')

      read(51) natom,NB,(N(k),k=1,NB)

      ni=0
      nj=0
      indxi=0
      indxj=0
      NTOTI=0
      NTOTJ=0

      do IBLOC=1,NB
         do JBLOC=IBLOC,NB

         read(51,end=910,err=910) 
     .   nbnnul,(indexi(ii),indexj(ii),H(ii),ii=1,nbnnul)


         do i=1,N(IBLOC)
              do j=1,N(JBLOC)
               HH(i,j)=0.d0
              enddo
         enddo

         do ii=1,nbnnul
              i=indexi(ii)-NTOTI
              j=indexj(ii)-NTOTJ
              HH(i,j)=H(ii)
         enddo


         do j=1,N(IBLOC)
              do i=1,6
                HD(j,i)=0.d0
                 do k=1,N(JBLOC)
                  HD(j,i)=HD(j,i)+HH(j,k)*RT(i,k,jbloc)   
                 enddo
              enddo
         enddo

         do i=1,6
             do j=1,6
	       s(i,j)=0.d0
               do k=1,N(IBLOC)
                  s(i,j)=s(i,j)+RT(i,k,ibloc)*HD(k,j)
               enddo
                  ni=i+indxi
                  nj=j+indxj
                  mat(ni,nj)=0.d0
		  mat(ni,nj)=s(i,j)
             enddo
         enddo


      NTOTJ=NTOTJ+N(JBLOC)

      indxj=indxj+6

      ENDDO

      indxi=indxi+6
      indxj=indxi 
      NTOTI=NTOTI+N(IBLOC)
      NTOTJ=NTOTI

      ENDDO

c     Ecriture de la matrice projetee:

      if (prtlev.gt.1) 
     .write(6,'(2A)') program,' Projected matrix is being saved.'

      trace=0.d0
      nnuls=0
      do i=1,6*nb
	 do j=i,6*nb
         if (mat(i,j).ne.0.d0) then
            nnuls=nnuls+1
            write(52) i,j,mat(i,j)
            if (i.eq.j) trace=trace+mat(i,j)
         endif
	 enddo
      enddo

      close (35)
      close (51)
      close (52)
      close (74)

      if (prtlev.gt.0) 
     .write(6,'(2A,F12.4)') program,' Projected matrix trace = ',trace

      if (prtlev.gt.1) then
      write(6,'(A,I10,A)') program,nnuls,' non-zero elements.'
      write(6,'(2A)') program,' Normal end of RTB.'
      endif

      return
 895  continue
      write(6,'(2A,I3,A,I3)') progrer,
     .    ' End-of-file while reading I-bloc: ',ibloc,
     .    ' nbnnul= ',nbnnul
      goto 990
 900  continue
      write(6,'(2A,I3,A,I3)') progrer,
     .    ' Error while reading I-bloc: ',ibloc,
     .    ' nbnnul= ',nbnnul
      goto 990
 905  continue
      write(6,'(A,3(A,I3))') progrer,
     .    ' Error after reading I-bloc: ',ibloc, 
     .    ' NB= ',NB,' kk= ',kk 
      goto 990
 910  continue 
      write(6,'(2A,I3,A,I3)') progrer,
     .    ' Error while reading J-bloc: ',jbloc,
     .    ' for band: ',ibloc
 990  continue
      write(6,'(A,I6,A)') program,nlign,' lines read.'
      write(6,'(A,I6,A)') program,nempty,' empty lines found.'
      write(6,'(A,I6,A)') program,nskip,' lines skipped.'
      stop '*Matrix i/o error*'

      END

c -----------------------------------------------
      SUBROUTINE SCHMIDT(M,N,C)
c ----------------------------------------------- 
C
C     ORTHOGONALISATION PAR GRAM-SCHMIDT
C
      integer   I,J,K,M,N
      double precision aaa, anorm, C(6,*), REC(6,6)
C
      ANORM = 0.D0
      DO I=1,N
       ANORM = ANORM + C(1,I)*C(1,I)
      ENDDO
      ANORM = 1.D0 / ( DSQRT(ANORM) )
C
      DO I=1,N
       C(1,I) = ANORM * C(1,I)
      ENDDO
C 
      DO  I=2,M      
       DO J=1,I-1
        REC(J,I) = 0.D0
        DO K=1,N
         REC(J,I) = REC(J,I) + C(J,K)*C(I,K)
        ENDDO
       ENDDO
       DO K=1,N
        AAA = 0.D0
        DO J=1,I-1
         AAA = AAA + C(J,K)*REC(J,I)
        ENDDO
        C(I,K) = C(I,K) - AAA
       ENDDO
C
       ANORM = 0.D0
       DO K=1,N
        ANORM = ANORM + C(I,K)*C(I,K)
       ENDDO 
       ANORM = 1.D0 / ( DSQRT(ANORM) )
C
       DO K=1,N
        C(I,K) = ANORM*C(I,K)
       ENDDO
C
      ENDDO
      RETURN
      END  
c----------------------------------------------------------------------
      SUBROUTINE RTBTOMODES ( natom, nb, nbrt, nddres, nvec, n, numvec1,
     &                        covec, freq1, matvec1, norm, rt, prtlev,
     &                        feig )
c
c     Scalar Arguments
c
      integer          natom, nb, nbrt, nddres, nvec
c
c     Array Arguments
c
      integer          n(*), numvec1(*), prtlev
      double precision covec(3*natom,nvec), freq1(nvec),
     &                 matvec1(6*nb,nvec), norm(nvec),
     &                 rt(nbrt,nddres,nb)
      character        feig*(*)
c
c     Purpose:
c     =======
c
c     -----------------------------------------------------------
c     From eigenvectors in block-rotation-translation coordinates
c     to eigenvectors in cartesian coordinates.
c     -----------------------------------------------------------
c
c     Input : matrix file 'diagrtb_work.eigenfacs'
c     Output: matrix file feig
c
c     Arguments
c     =========
c
c     natom     : maximum number of atoms in the system.
c     nresmax   : maximum number of residues and of blocks.
c     ntab      : working array.
c     resi      : residue number each atom belongs to.
c     tabb      : block lengths.
c     amass     : coordinate masses.
c     corlin    : coordinates.
c     massat    : atomic masses.
c     xat       : atomic x-coordinate.
c     yat       : atomic y-coordinate.
c     zat       : atomic z-coordinate.
c     natblocs  : maximum number of atoms found in blocks.
c     natom     : number of atoms in the system.
c     nb        : number of blocks the system is split into.
c
C-----------------------------------------------------------------------
c
c     Local variables
c
      character*40     cformat, cstatus, nomeig1, nomeig2 
      logical          qinter, qexist, qverbos
      integer          i, ibloc, ii, ivec, j, k, natcur, nbcur,
     .                 nbread, nddl1,
     .                 ntot, nunit, uneig1, uneig2
      double precision dvec
      character        program*14, progrer*17, progrwn*17
c
C-----------------------------------------------------------------------
 
      program=' Rtb_to_modes>'
      progrer='%Rtb_to_modes-Er>'
      progrer='%Rtb_to_modes-Wn>'

      if (prtlev.gt.1)
     .write(6,'(/2A)') program,' Entering in.'

c     Fichier en lecture
c      -------------------

      nunit=10
      open (unit=35,file='diagrtb_work.blocs',status='old',
     .      form='unformatted')
 
      natcur=natom
      nbcur=nb
      read(35) natom,nb,(n(i),i=1,nb)

      if (prtlev.gt.1)
     .write(6,'(/2A,I6)') program,
     .  ' Number of atoms in temporary block-file = ',natom
      if (natom.ne.natcur) then
          write(6,'(/A,I6,A)') progrer,natcur,' atoms... up to now.'
          stop '*Unexpected big problem*'
      endif

      if (prtlev.gt.1)
     .write(6,'(2A,I6)') program,' Number of blocs = ',nb
      if (nb.ne.nbcur) then
          write(6,'(/A,I6,A)') progrer,nbcur,' blocks... up to now.'
          stop '*Unexpected big problem*'
      endif

      qverbos=.false.
      if (prtlev.gt.1) qverbos=.true.

c     Matrice-input:

      nomeig1="diagrtb_work.eigenfacs"
      uneig1=nunit
      nunit=nunit+1
      cformat="FORMATTED"
      cstatus="old"
      call openam(nomeig1,cformat,cstatus,uneig1,qverbos,
     .            qinter,qexist)
      if (qinter.or..not.qexist) stop
 
c     Matrice-output:

      nomeig2=feig
      uneig2=nunit
      nunit=nunit+1
      cformat="FORMATTED"
      cstatus="ove"
      call openam(nomeig2,cformat,cstatus,uneig2,qverbos,
     .            qinter,qexist)
      if (qinter) stop

c     Lecture des fichiers:
c     --------------------

      call rdmodfacs(uneig1,6*nb,nvec,numvec1,freq1,
     .               matvec1,nddl1,prtlev)
 
      if (prtlev.gt.1)
     .write(6,'(/A,I5,A,I6,A)') program,
     .nvec,' vectors, with ',nddl1,' coordinates in vector file.'

      if (nddl1.ne.6*nb) then
          write(6,'(/2A,I6,A)') progrer,' Vectors of length: ',6*nb,
     .  ' were expected. Block and vector files are not consistent.'
          stop '*Unexpected big problem*'
      endif
c
      if (prtlev.gt.1) then
      do ivec=1,nvec
         norm(ivec)=0.d0
         do i=1,nddl1
         dvec=matvec1(i,ivec)**2
         norm(ivec)=norm(ivec)+dvec
         enddo
         norm(ivec)=dsqrt(norm(ivec))
      enddo
      write(6,'(/A)') 
     .' Norm of eigenvectors in projected coordinates (one expected):'
       write(6,'(5F8.5)') (norm(ivec),ivec=1,nvec)
      endif
c
      if (prtlev.gt.1)
     .write(6,'(/2A)') program,' RTB block-file is being read.'
c
      nbread=0
      do i=1,nbrt
       do j=1,nddres
         do k=1,nb
           rt(i,j,k)=0.d0
         enddo
       enddo
      enddo
c
   90 continue
      read(35,end=99) i,j,ibloc,rt(i,j,ibloc)
      nbread=nbread+1
      if (i.gt.nbrt.or.i.le.0) then
          write(6,'(A,I6,A,I1,A,I4)') progrer,i,
     .  ' rigid body ddl instead of ',nbrt,' for block ',ibloc
          stop '*Unexpected big problem*'
      endif
      if (j.gt.nddres.or.j.le.0) then
          write(6,'(A,I6,A,I6,A,I6)') progrer,j,
     .  ' ddl for block ',ibloc,'. Maximum allowed is: ',nddres
          stop '*Unexpected big problem*'
      endif
      if (ibloc.gt.nb.or.ibloc.le.0) then
          write(6,'(A,I4,A,I4)') progrer,ibloc,
     .  ' blocks at least. Maximum allowed is: ',nb
          stop '*Unexpected big problem*'
      endif
      goto 90
   99 continue
 
      if (prtlev.gt.1) 
     .write(6,'(A,I9,A)') program,nbread,' lines found in RTB file.'
 
      do ivec=1,nvec
	 do i=1,3*natom
	    covec(i,ivec)=0.d0
         enddo
      enddo
 
      do ivec=1,nvec
       ntot=0
       ii=0
       do ibloc=1,nb
	 do j=1,n(ibloc)
	   covec(j+ntot,ivec)=0.d0
	   do i=1,6
	   covec(j+ntot,ivec)=covec(j+ntot,ivec)+
     .     rt(i,j,ibloc)*matvec1(i+ii,ivec)
	   enddo
          enddo
	   ii=ii+6
           ntot=ntot+n(ibloc)
       enddo
       enddo
 
      if (prtlev.gt.1) then
      write(6,'(/A)') 
     .' Norm of eigenvectors in cartesian coordinates (one expected):'
      do ivec=1,nvec
         norm(ivec)=0.d0
         do i=1,natom
         ii=3*i-2
         dvec=covec(ii,ivec)**2+covec(ii+1,ivec)**2
     .       +covec(ii+2,ivec)**2
         norm(ivec)=norm(ivec)+dvec
         enddo
         norm(ivec)=dsqrt(norm(ivec))
       enddo
       write(6,'(5F8.5)') (norm(ivec),ivec=1,nvec)
      endif
 
      if (prtlev.gt.1) then
      write(6,'(/A)') 
     .' Orthogonality of first eigenvectors (zero expected):'
      do i=2,min(10,nvec)
         do j=1,i-1
            norm(j)=0.d0
            do k=1,natom
               ii=3*k-2
               norm(j)=norm(j)+
     .         covec(ii,i)*covec(ii,j)+covec(ii+1,i)*covec(ii+1,j)+
     .         covec(ii+2,i)*covec(ii+2,j)
            enddo
         enddo
         write(6,'(A,I3,A,10F6.3)') 
     .       ' Vector ',i,':',(norm(j),j=1,i-1)
      enddo
      endif

      do i=1,nvec
         write(uneig2,'(A,I5,7X,A,1PG12.4)')
     .       ' VECTOR',i,'VALUE',freq1(i)
         write(uneig2,'(1X,35(1H-))')
         write(uneig2,'(3(1PG12.4))')
     .  (covec(ii,i),covec(ii+1,i),covec(ii+2,i),ii=1,3*natom,3)
      enddo
 
      close(35)
      close(uneig1)
      close(uneig2)

      write(6,'(/A,I6,A)') program,nvec,
     .    ' eigenvectors saved.'

      if (prtlev.gt.1) 
     .write(6,'(/2A)') program,' Normal end.'
      return
      end
c
      subroutine rdmodfacs(uneig,nddlmax,nvec,numvec,freq,
     .           matvec,nddl,prtlev)
c
c     Lecture de modes au format "CERFACS".
c
cI/O:
      integer numvec(*), nddlmax, nvec, nddl, uneig
      double precision freq(*), matvec(nddlmax,*)
cLocal:
      integer nmotsmax
      parameter(nmotsmax=100)
      integer nerr, ivec, indnm_cfacs, nmots,
     .        i, ii, k, prtlev
      logical qfound, qold, qfirst
      character*1 carnum
      character program*11, progrer*14, progrwn*14
      character*132 lign132, mots(nmotsmax)
cDefaut:
      program=' Rdmodfacs>'
      progrwn='%Rdmodfacs-Wn>'
      progrer='%Rdmodfacs-Er>'

      if (prtlev.gt.1)
     .    write(6,'(/2A)') program,' Entering in.'

      nerr=0
      qfirst=.true.
      qold=.false.
      qfound=.false.
 100  continue
      read (uneig,'(A)',end=300,err=110) lign132
      goto 120
 110  continue
      nerr=nerr+1
 120  continue
 
      qfound=qfound.or.
     .      (index(lign132,' value ').gt.0.and.
     .       index(lign132,' vector ').gt.0.and.
     .       index(lign132,' residual ').le.0)
      qold=qold.or.
     .      (index(lign132,' VALUE ').gt.0.and.
     .       index(lign132,' VECTOR ').gt.0)
 
      if (.not.qfound.and..not.qold) goto 100
c________________________________________
c
c     Lecture des frequences des modes :
c________________________________________
 
      if (qfirst) then
          if (prtlev.gt.1) then
          if (qold) then
          write(6,'(/A)') 
     .  ' Rdmodfacs> Old Blzpack file format detected.'
          else
          write(6,'(/A)') 
     .  ' Rdmodfacs> Blzpack file format detected.'
          endif
          endif
          qfirst=.false.
      endif
c
      ivec=0
 250  continue
      ivec=ivec+1
      if (ivec.gt.nvec) then
          write(6,'(/A,I5,A)') 
     .  '%Rdmodfacs-Wn> More than ',nvec,' vectors in file.'
          return
      endif
c
      read(lign132,'(7X,I5,12X,G12.4)',end=240,err=240)
     .     numvec(ivec), freq(ivec)
 
      goto 255
 240  continue
      write(6,'(/3A)')
     .    '%Rdmodfacs-W> Pb with ligne: ',lign132(1:36),'...'
 255  continue
c
      if (prtlev.gt.1) then
      write(6,'(/A,I6)')
     .' Rdmodfacs> Eigenvector number:',
     .  numvec(ivec)
      write(6,'(A,1PG12.4)')
     .' Rdmodfacs> Corresponding eigenvalue:',
     .  freq(ivec)
      endif
c
      if (numvec(ivec).le.0)
     .    write(6,'(/A/A)')
     .  '%Rdmodfacs-W> Vector number was expected in:',
     .    lign132
c
      read(uneig,'(A)',end=230,err=230) lign132
 230  continue
      read(lign132,'(1X,A1)',end=232,err=232) carnum
 232  continue
      if ((qfound.and.carnum.ne.'=').or.
     .    (qold.and.carnum.ne.'-')) then
          write(6,'(2A/A)')
     .       ' %Rdmodfacs-Warning> Unexpected character ',
     .       ' in second column of line:',
     .    lign132
      endif
c____________________________________________________
c
c     2) Lecture des coordonnees des modes:
c        Format libre.
c____________________________________________________
c
      k=0
 257  continue
      if (k.gt.nddlmax) then
          write(6,'(/A,I6,A,I5)') 
     .  '%Rdmodfacs-Err> More than ',nddlmax,
     .  ' coordinates for vector ',ivec
          return
      endif
c
      read(uneig,'(A)',end=300,err=270) lign132
c
c     Nombre de coordonnees par ligne:
      call string_split(lign132,132,' ',
     .                  mots,nmotsmax,nmots)
c
      if (lign132.eq.' ') then
          read(uneig,'(A)',end=300,err=260) lign132
      else if (.not.qold.or.index(lign132,' VALUE ').le.0) then
          read(lign132,*,end=258)
     .   (matvec(k+ii,ivec),ii=1,nmots)
          k=k+nmots
          goto 257
 258      continue
      endif
      nddl=k
c
 260  continue
      indnm_cfacs=index(lign132,'       VALUE')
      if (indnm_cfacs.le.0)
     .    indnm_cfacs=index(lign132,'       value')
      if (indnm_cfacs.gt.0) then
          goto 250
      else
          write(6,'(A,A/A/A)')
     .  ' Rdmodfacs> Modes read.',
     .  ' Item VALUE not found in ligne :',lign132
          goto 300
      endif
c
 270  continue
      write(6,'(A,I6)')
     .   ' %Rdmodfacs-Er> While reading coordinate ',
     .      i
      stop '*Wrong matrix*'
c
 220  continue
c*****Ligne suivante de la lecture du fichier des modes en cours :
c
      goto 100
c
c     Fin de la lecture du fichier des modes :
c
 300  continue
      return
      end
c
      subroutine string_split(chaine,taille,delimiteur,
     .                        souschaine,nbremax,nbre)
c
c     "Chaine" est coupee en "nbre" "souschaine" de part et d'autre du
c     "delimiteur"
c I/O:
      integer taille, nbremax, nbre
      character*(*) chaine, souschaine(*), delimiteur
c Local:
      integer icar, iprev
c
      nbre=1
      iprev=1
      souschaine(1)=chaine
      do icar=1,taille
         if (chaine(icar:icar).eq.delimiteur) then
            if (icar-1.ge.iprev) then
               souschaine(nbre)=chaine(iprev:icar-1)
               nbre=nbre+1
               if (nbre.le.nbremax) then
                  if (icar+1.le.taille.and.
     .               chaine(icar+1:taille).ne.' ') then
                     souschaine(nbre)=chaine(icar+1:taille) 
                  else
                     nbre=nbre-1
                     return
                  endif
               else
                  write(6,'(A,I6,A/A)') 
     .               ' %String_split-Err: more than ',nbremax,
     .               ' substrings in : ',chaine
                  return
               endif
            endif
            iprev=icar+1
         endif
      enddo
c
      return
      end

      subroutine mintomaj(chaine)
 
c     Les caracteres minuscules sont mis en MAJUSCULES.
c     Les autres ne sont pas touches.
 
      character*(*) chaine
c Local:
      integer icar, ilettre, taille
      character*26  carmaj, carmin
 
      carmin='qwertyuiopasdfghjklzxcvbnm'
      carmaj='QWERTYUIOPASDFGHJKLZXCVBNM'
 
      taille=len(chaine)
      if (taille.le.0) return

      do icar=1,taille
         ilettre=index(carmin,chaine(icar:icar))
         if (ilettre.gt.0) then
             chaine(icar:icar)=carmaj(ilettre:ilettre)
         endif
      enddo
 
      return
      end
c----------------------------------------------------------------------
      SUBROUTINE openam(namfil,cformat,cstatus,unit,qverbos,
     .                  qinterr,qexist)
c
c     Ouverture d'un fichier de nom NAMFIL, sur l'unite UNIT,
c     a priori suite a une interrogation...
c
c     input:
c        namfil: nom du fichier a ouvrir. 
c        "stop", "end", "fin", "quit" : arretent le programme.
c        cstatus: mots-cles fortran... ou "OVE" pour overwrite.
c     output: 
c        qexist: flag / existence du fichier 
c        qinterr: Pas de nom pour le fichier cherche.
c I/O:
      logical qinterr, qverbos, qexist
      integer unit
      character*(*) namfil, cformat, cstatus
c Local
      character*132 ordrunix
c begin:
      if (cstatus.eq.'old') cstatus='OLD'
      if (cstatus.eq.'new') cstatus='NEW'
      if (cstatus.eq.'ove') cstatus='OVE'
      if (cstatus.eq.'unknown') cstatus='UNKNOWN'
 
      qinterr=.false.
      qexist=.false.
 
      if (namfil.eq.' ') then 
          qinterr=.true.
          write(6,'(A)') '%Openam-Err> No filename.'
          return
      endif
 
      if (namfil.eq.'stop'.or.namfil.eq.'end'                         
     &    .or.namfil.eq.'fin'.or.namfil.eq.'quit') then 
         write(6,'(A)') 'Openam> Program is stopping on user request.'
         stop                                                                   
      endif 
 
c     Checks if filename is consistent with the opening:
 
      inquire(file=namfil,exist=qexist)
      if (.not.qexist.and.cstatus.eq.'OLD') then
          qinterr=.true.
          if (qverbos) write(6,'(A)') '%Openam-Err> File not found.'
          return
      endif
 
      if (qexist.and.cstatus.eq.'NEW') then
         write(6,'(/A)') 
     .      '%Openam-Err> This file exists:',namfil
         stop
      else if (qexist.and.cstatus.eq.'OVE') then
         ordrunix='rm '//namfil
         call system(ordrunix)
      endif
      if (cstatus.eq.'OVE') cstatus='NEW'
                                                                    
      if (qverbos) then
         write(6,'(/A,I6,A)')
     .           ' Openam> file on opening on unit ',unit,':'
         write(6,*) namfil
      endif
      open(file=namfil,form=cformat,
     .     status=cstatus,unit=unit)                
         
      return  
      end

      subroutine trier(y,npoint,nmax,ysort,iord,qcrois)
c
c     Tri par ordre croissant (qcrois=T) ou non.

      implicit none
      logical qcrois
      integer i, icur, iord(*), j, nmax, npoint
      double precision y(*), ycur, ysort(*)
      character progrer*10

      progrer='%Trier-Er>'

      if (npoint.gt.nmax) then
          write(6,'(/A,I9,A,I9,A)') progrer,npoint,
     .  ' points to be sorted, i.e., more than ',nmax,' Sorry.'
          stop '*Unexpected big problem*'
      endif

      do i=1,npoint
         ysort(i)=y(i)
         iord(i)=i
      enddo

      do i=1,npoint
        do j=1,npoint
          if (qcrois) then
            if (ysort(i).lt.ysort(j)) then
                ycur=ysort(i)
                icur=iord(i)
                ysort(i)=ysort(j)
                ysort(j)=ycur
                iord(i)=iord(j)
                iord(j)=icur
            endif
          else
            if (ysort(i).gt.ysort(j)) then
                ycur=ysort(i)
                icur=iord(i)
                ysort(i)=ysort(j)
                ysort(j)=ycur
                iord(i)=iord(j)
                iord(j)=icur
            endif
          endif
        enddo
      enddo

      return
      end
 
      subroutine stringcl(chaine,nonblancs)
c
c     Les caracteres "blancs" de la CHAINE sont retires (a gauche et au milieu).
c     L'entier NONBLANCS donne la position du dernier caractere.
c
c I/O:
      integer nonblancs
      character*(*) chaine
c Local:
      integer icar, ncar, taille
c Begin:
      taille=len(chaine)
c
      if (index(chaine(1:taille),' ').le.0) then
          nonblancs=taille
          return
      endif
c
c*****Nettoyage des blancs a gauche.
c     Premier non-blanc:
c
      do icar=1,taille
         if (chaine(icar:icar).ne.' ') goto 150
      enddo
 150  continue
      chaine=chaine(icar:taille)
c
c*****Nettoyage des blancs au milieu.
c
          icar=1
          ncar=1
 170      continue
          icar=icar+1
          ncar=ncar+1
          if (chaine(icar:icar).eq.' ') then
              chaine=chaine(1:icar-1)//chaine(icar+1:taille) 
              icar=icar-1
          endif
          if (ncar.lt.taille-1) goto 170
c
      nonblancs=index(chaine,' ')-1
c
      return
      end
c-----------------------------------------------------------------------------
      subroutine vecstat(vect,nmax,rmin,rmax,rave,rdev)

c     Statistics for vector Vect(NMAX):
c     minimum, maximum, average (rave) and standard deviation (rdev).

cI/O:
      integer nmax
      double precision rave, rdev, rmax, rmin, vect(*)
cLocal:
      integer i
      character program*9, progrer*11, progrwn*11

cBegin:
      program=' Vecstat>'
      progrer='%Vecstat-Er>'
      progrwn='%Vecstat-Wn>'

      rave=0.d0
      rdev=0.d0
      rmin=-9999.d0
      rmax=9999.d0

      if (nmax.le.0) then
          write(6,'(/2A)') progrer,' Zero-length vector.'
          return
      endif

      do i=1,nmax
         if (vect(i).gt.rmax.or.i.eq.1) rmax=vect(i)
         if (vect(i).lt.rmin.or.i.eq.1) rmin=vect(i)
         rave=rave+vect(i)
         rdev=rdev+vect(i)**2.0
      enddo

      rave=rave/dfloat(nmax) 
      rdev=rdev/dfloat(nmax)-rave*rave
      if (rdev.gt.0.d0) rdev=dsqrt(rdev)

      return
      end
c-----------------------------------------------------------------------------
      subroutine readrlin(uninp,x,w,ic,nmax,ncoor,ndat,qerror,prtlev)

c     Reads at most NMAX coordinates in free format. 
c     They are stored in a linear array.

c     Either:
c     x, y, z
c     or:
c     x, y, z, w
c     or:
c     x, y, z, w, ic

c     If first word in ligne is not a number, the whole ligne is
c     assumed to be a title or a commentary.

cI/O:
      logical qerror
      integer ic(*), ncoor, ndat, nmax, prtlev, uninp
      double precision w(*), x(*), xc, yc, zc
cLocal:
      integer nmotsmax
      parameter(nmotsmax=255)

      integer i, lmot, nchi, nlmax, nl, nlu, nmots, stats(0:nmotsmax)
      double precision rlu
      character chiffres*15, lignlg*(nmotsmax), 
     .        mots(nmotsmax)*(nmotsmax), program*9, progrer*11, 
     .        progrwn*11

cBegin:
      program=' Readxyz>'
      progrer='%Readxyz-Er>'
      progrwn='%Readxyz-Wn>'

      chiffres='1234567890.eE+-'

      do i=1,nmotsmax
         stats(i)=0
      enddo

c     Lecture ligne a ligne:
c     ----------------------

      if (prtlev.gt.1) write(6,'(/2A)') program,
     .  ' Comments, or lines with less than three numbers: '

      qerror=.false.
      ncoor=0
      nl=0
 100  continue
      read(uninp,'(A)',end=200) lignlg 
      nl=nl+1
      call string_split(lignlg,nmotsmax," ",mots,nmotsmax,nmots)

      nfound=0
      do i=1,nmots
         call stringcl(mots(i),lmot)
         if (lmot.le.0) goto 150

c        Commentaire ?
         if (mots(i)(1:1).eq.'!') goto 150

c        Chiffre ?

         do k=1,lmot
            if (index(chiffres,mots(i)(k:k)).le.0) goto 110
         enddo

         nfound=nfound+1

         if (nfound.le.4) then
             read(mots(i)(1:lmot),*,err=110) rlu
             if (nfound.eq.1) xc=rlu
             if (nfound.eq.2) yc=rlu
             if (nfound.eq.3) zc=rlu
             if (nfound.eq.4) wc=rlu
         else if (nfound.eq.5) then 
             read(mots(i)(1:lmot),*,err=110) nlu
         endif

c        Mot suivant:
 110     continue

c        Le premier mot n'est pas un chiffre => ligne de commentaires

         if (nfound.eq.0) goto 150
      enddo
 150  continue

c     Stockage des coordonnees:
c     -------------------------

      stats(nfound)=stats(nfound)+1

      if (nfound.ge.3) then
          ncoor=ncoor+1
          if (ncoor.le.nmax) then
              n3=3*ncoor-2
              x(n3)  =xc
              x(n3+1)=yc
              x(n3+2)=zc
              if (nfound.eq.4) then
                  w(n3)=wc
                  w(n3+1)=wc
                  w(n3+2)=wc
              else
                  w(n3)=wc
                  w(n3+1)=wc
                  w(n3+2)=wc
                  ic(ncoor)=nlu 
              endif
          else
              write(6,'(/2A,I9,A)') progrer,' More than ',
     .        nmax,' particles in file.'
              write(6,'(2A)') progrer,
     .      ' Please increase program memory limits (Sorry for that).'
              stop '*Too large system*'
          endif
      else
          if (prtlev.gt.1) then
              write(6,'(2A)') lignlg(1:72),'...'
          endif
      endif
      
c     Ligne suivante:
      goto 100
 200  continue
      if (prtlev.gt.1.and.nl.eq.ncoor) write(6,'(2A)') program,' None.'

      write(6,'(/2A,I7)') program,
     .' Number of particles in file (with x,y,z coordinates): ',ncoor
 
      if (ncoor.eq.0) then
          write(6,'(/2A)') progrer,' No coordinate found in file.'
          qerror=.true.
      endif

      nchi=0
      ndat=0
      nlmax=0
      do i=1,nmotsmax
         if (stats(i).gt.0) nchi=nchi+1
         if (stats(i).gt.nlmax) then
             nlmax=stats(i)
             ndat=i
         endif
      enddo

      do i=0,nmotsmax
         if (stats(i).gt.0.and.(prtlev.gt.1.or.nchi.gt.1)) then
            write(6,'(A,I6,A,I7,A)') program,i,
     .    ' numbers found in ',stats(i),' lines.'  
         endif
      enddo

      return
      end
c-----------------------------------------------------------------------------
nma/nma_record_info_PDB.py0000775000175000017500000000326313711226210015060 0ustar  guestguest#!/usr/bin/env python3

import sys


def diag(fnPDB, n_mode, rtbBlockSize):
    f = open('diagrtb.dat', 'w')
    content = """! This file can be modified and used as a command file (named diagrtb.dat) for diagrtb.
 MATRix filename            =   pdbmat.sdijf
 COORdinates filename       =     %s
 Eigenvector OUTPut filename= diagrtb.eigenfacs
 Nb of VECTors required     =         %d
 EigeNVALues chosen         =       LOWE   ! LOWEst, HIGHest.
 Type of SUBStructuring     =       NONE   ! RESIdues, SECOndary, SUBUnits, DOMAins, NONE.
 Nb of residues per BLOck   =         %d 
 Origin of MASS values      =       CONS   ! CONStant, COORdinate, PDB.
 Temporary files cleaning   =       ALL    ! ALL, NOne.
 MATRix FORMat              =       FREE   ! FREE, BINAry.
 Output PRINting level      =          2   ! =1: More detailed; =2: Debug level.
""" % (fnPDB, n_mode, rtbBlockSize)
    f.write(content)
    f.close()


def pdbmat(fnPDB, cutoff, forceConstant):
    f = open('pdbmat.dat', 'w')
    content = """! This file can be modified and used as a command file (named pdbmat.dat) for pdbmat.
 Coordinate FILENAME        = %s
 MATRIx FILENAME            = pdbmat.sdijf
 INTERACtion DISTance CUTOF = %f ! For defining the list of interacting atoms.
 INTERACtion FORCE CONStant = %f ! For specifying frequency units.
 Origin of MASS values      =    CON ! CONstant, or from COOrdinate file.
 Output PRINTing level      =      2 ! =1: more detailled. =2: debug level.
""" % (fnPDB, cutoff, forceConstant)
    f.write(content)
    f.close()


# Main
if __name__ == '__main__':
    diag(sys.argv[3], int(sys.argv[1]), int(sys.argv[2]))
    pdbmat(sys.argv[3], float(sys.argv[4]), float(sys.argv[5]))
    sys.exit()