CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C	PROGRAM   VOLUME   
C
C	Fortran program to calculate the voronoi volume of a protein 
C	from atomic coordinate data.
C
C	Copyright (c) Apr 1983 Yale University
C
C	Author:  F.M. Richards
C
C	References:
C		1) F.M.Richards, J.Mol. Biol. 82: 1-14 (1974)
C			The Interpretation of Protein Structures: Total
C			Volume, Group Volume Distributions and Packing 
C			Density.
C
C		2) F.M.Richards, Methods in Enzymology, 115: 440-464 (1985)
C			Calculation of Molecular Volumes and Areas for 
C			Structures of known Geometry
C
C	This program was developed in the Department of Molecular
C	Biophysics and Biochemistry at Yale University. Its use is
C	subject to the following conditions.
C
C 	a) Use of the program is restricted to the laboratory or
C	organization to which it has been supplied. The program may
C	not be sold nor may copies be distributed to third parties
C	without the express permission of Yale University.
C
C     	b) This program is provided on an "as is" basis. Yale in
C	no way warrants the program or its results.
C
C     	c) Yale is under no obligation to provide any services by
C	way of maintenance, update, or otherwise. However, if a cost
C	recovery fee has been collected, future updates, if any, will be
C	supplied free of charge.
C
C     	d) Reports or publications based on this program
C	should contain an acknowledgement in a form commonly used in
C	academic research.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C	PROGRAM VOLUME  (CORRECTED TO 14 APR 83)
C
C		(THE OPTION TO CALCULATE CAVITY VOLUMES IS NOT ACTIVATED IN THIS
C		VERSION OF THE PROGRAM.)
C
C		TO CALCULATE THE VOLUME OF A SERIES OF SPECIFIED ATOMS IN A LIST OF 
C		COORDINATES BY THE VORONOI, OR VARIOUS MODIFIED VORONOI, PROCEDURES.
C
C		THE INPUT FILE FOR THIS PROGRAM IS ASSUMED TO HAVE BEEN PREPARED
C		THROUGH THE PROGRAM ACCESS WITH OR WITHOUT ACTUAL CALCULATION OF
C		THE ACCESSIBLE AREAS OF THE ATOMS.  THE KEY ARRAY IN THIS FILE
C		INDICATES THE ATOMS TO BE EXCLUDED OR INCLUDED IN THE CALCULATION
C 		AND WHICH INCLUDED ATOMS ARE TO HAVE THEIR VOLUMES CALCULATED.
C
C		FUNCTIONS OR SUBROUTINES CALLED: ASKFIL,GETNUM,SPRAY,BLOCK
C			(WITH D_LINES ONLY PRNTBX,PRNTPN)
C			SHELL, FILBOX, ATMPOL, POLVOL
C
C	INCLUDE 'VOL.CMN'
#include "vol.cmn"
C
C	INCLUDE 'TEST.CMN'
#include "test.cmn"
C
	COMMON/FILES/ FNAME,GNAME
C
	CHARACTER*30 FNAME,GNAME
	CHARACTER*6 KEYWRD
	BYTE BLINE(74)
C
	DATA CE/2.80/              ! DEFAULT VALUE
	DATA ARANGE/6.50/          ! DEFAULT VALUE
	DATA RDELTA/0.0/           ! DEFAULT VALUE
C
C***********************************************************************

4600	FORMAT( ' PROGRAM:   VOLUME',/,
     1	' AUTHOR :   Frederic M. Richards',/,
     2	' PURPOSE:   To calculate atomic volumes in a protein',/,
     3	' 	     by various Voronoi procedures from a list',/,
     4	'	     of atomic coordinates.',/,
     5	' COPYWRITE (C) Yale University, April 1983')

C	WRITE(2,4600)

	PRINT 4600

C		ASSIGN INPUT AND OUTPUT FILE NAMES
C		LOCAL UNIT #1 - INPUT FILE
C		LOCAL UNIT #2 - OUTPUT FILE : NOTES AND DATA
C		LOCAL UNIT #3 - OUTPUT FILE : ERROR MESSAGES
C
	PRINT *,'  What is the name of the input file for data? ---->'
	READ 101, GNAME
101	FORMAT(A30)

	OPEN(UNIT=1,NAME=GNAME, STATUS='OLD')
C
	PRINT *,'  What is the name of the output file for data? ---->'
	READ 101, FNAME
	OPEN(UNIT=2,NAME=FNAME, STATUS='NEW')
C
	WRITE(2,5103) GNAME
	WRITE(2,5100) FNAME
5103	FORMAT('        INPUT FILE NAME IS :',A30,/)
5100	FORMAT(' DATA  OUTPUT FILE NAME IS :',A30)
C
	PRINT *,'  What is the name of the output file for error? ---->'
	READ 101, FNAME
	OPEN(UNIT=3,NAME=FNAME, STATUS='NEW')
C
	WRITE(3,5103) GNAME
	WRITE(2,5101) FNAME
	WRITE(3,5101) FNAME
5101	FORMAT(' ERROR OUTPUT FILE NAME IS :',A30)
C*************************************************************************
C		SELECT SHELL PARAMETER
	PRINT*,' CURRENT VALUE FOR LENGTH OF THE EDGE OF THE "SHELL"'
	PRINT 5002, CE
5002	FORMAT('  LATTICE, CE, IS :',F5.2)
	PRINT*,' DO YOU WANT TO CHANGE THIS VALUE? ENTER Y/N'
	READ 5003, KEYWRD
5003	FORMAT(A6)
	IF(KEYWRD.EQ.'N     ') GO TO 60
	PRINT*,' ENTER NEW VALUE (X.XX)'
	READ 5004, CE
5004	FORMAT(F5.2)
60	WRITE(2,5011) CE
5011	FORMAT(' THE VALUE OF CE IS:',F5.2)
C*************************************************************************
C		PICK SEARCH RADIUS,ARANGE.
C
	PRINT 5010,ARANGE
5010	FORMAT(' CURRENT VALUE OF SEARCH RADIUS, ARANGE, IS:',F5.2)
	PRINT*,'DO YOU WANT TO CHANGE THIS VALUE? ENTER Y/N'
	READ 5003,KEYWRD
	IF(KEYWRD.EQ.'N     ') GO TO 70
	PRINT*,' ENTER NEW VALUE (X.XX)'
	READ 5004,ARANGE
70	WRITE(2,5012) ARANGE
5012	FORMAT(' THE VALUE OF ARANGE IS:',F5.2)
C********************************************************************
C		DECIDE METHOD TO BE USED FOR VOLUME CALCULATION
C
	PRINT*,' DECIDE METHOD TO BE USED FOR VOLUME CALCULATION. '
	PRINT*,'      ENTER: 1,2,OR 3.'
	PRINT*,'		1) STANDARD VORONOI PROCEDURE'
	PRINT*,'		2) RICHARDS" METHOD B'
	PRINT*,'		3) RADICAL PLANE PROCEDURE'
	READ 5102, METHOD
5102	FORMAT(I1)
	WRITE(2,5106) METHOD
5106	FORMAT(/,' THE METHOD OF CALCULATION IS:',I2)
C************************************************************************
C		PICK VALUE TO POSITION OUTER SURFACE
	PRINT 5020,RDELTA
5020	FORMAT(' FOR SURFACE VOLUME ADJUSTMENT,',
     1' CURRENT VALUE OF RDELTA IS:',F5.2)
	PRINT*,' DO YOU WANT TO CHANGE THIS VALUE? ENTER Y/N'
	READ 5003, KEYWRD
	IF(KEYWRD.EQ.'N     ') GO TO 80
	PRINT *,' ENTER NEW VALUE X.XX'
	READ 5004, RDELTA
80	WRITE(2,5013) RDELTA
5013	FORMAT(' THE VALUE OF RDELTA IS:',F5.2)
C***********************************************************************
C		INITIALIZE ERROR VARIABLES
C
      JLEVEL=1
      DO 90 J=JLEVEL,5
      DO 90 I=1,2
   90 IERROR(I,J)=0
      ICHK=0
      IMSG=1
      IERROR(1,JLEVEL)=19
C
C          LOAD COMMON BLOCK /COORDS/ FROM INPUT FILE
C
100	READ(1,5001,END=5200) KEYWRD, BLINE
5001	FORMAT(A6,74A1)
	IF(KEYWRD.NE.'BEGIN ') GO TO 100
	GO TO 150
C
C		ERROR WRITE
C
5200	PRINT*,' ERROR IN FILE FORMAT. NO "BEGIN" FOUND'
	STOP
C
150	LSTATM=0
	LAST=0
	NEXT=0
	DO 200 I=1,MAXATM
	READ(1,5000,END=300) KEY(I),NUMCHN(I),NUMFIL(I),
     1	ATM(I),RES3(I),SEQNUM(I),X(I),Y(I),Z(I),RVDW(I),
     2	RCOV(I),AAREA,CAREA,FRCACC
5000	FORMAT(I2,1X,I2,1X,I2,1X,A4,2X,A4,2X,I4,F8.3,F8.3,F8.3,2X,
     1	F5.2,2X,F5.2,2X,F8.3,2X,F8.3,1X,F4.2)
C		2X,F6.3 -> F8.3 CHANGED, DAVID ARNDT, NOV 23 2007.
C		CHECK FOR AND RESET SEQNUM TO INCREASE CONSTANTLY FROM
C		BEGINNING OF FILE TO END. BNL FILES HAVE SOME ODD ENTRIES
C		FOR HEME,HOH,ETC.
C
	NOW=SEQNUM(I)
	IF(NOW.EQ.LAST) THEN
			SEQNUM(I)=NEXT
	ELSE IF(NOW.GT.LAST.OR.NOW.LT.LAST) THEN
			NEXT=NEXT+1
			SEQNUM(I)=NEXT
			LAST=NOW
	END IF
	LSTATM=LSTATM+1
200	CONTINUE
C
C		ALL ARRAYS HAVE NOW BEEN LOADED FROM INPUT FILE
C		DETERMINE  MIN AND MAX VALUES OF COORD LIST.
C
300	LSTRES=SEQNUM(LSTATM)
	XMIN=9999
	YMIN=9999
	ZMIN=9999
	XMAX=-9999
	YMAX=-9999
	ZMAX=-9999
	DO 350 I=1,LSTATM
	IF(X(I).LT.XMIN) XMIN=X(I)
	IF(Y(I).LT.YMIN) YMIN=Y(I)
	IF(Z(I).LT.ZMIN) ZMIN=Z(I)
	IF(X(I).GT.XMAX) XMAX=X(I)
	IF(Y(I).GT.YMAX) YMAX=Y(I)
	IF(Z(I).GT.ZMAX) ZMAX=Z(I)
350	CONTINUE
C
	WRITE(2,5104) LSTATM
	WRITE(*,5104) LSTATM
5104	FORMAT(/,' TOTAL NUMBER OF PROTEIN ATOMS IN INPUT LIST IS:',I5)
C
	PRINT *,' INPUT DATA LOADING COMPLETE'
C******************************************************************************
C
C		THE PROTEIN IS CONSIDERED TO CONSIST OF ALL ATOMS FLAGGED WITH
C		KEY(I) = 0 OR 1. (I.E. ALL ATOMS IN THE LIST FLAGED WITH -1
C		ARE SIMPLY DELETED COMPLETELY FROM SHELL AND ALL SUBSEQUENT 
C		CALCULATIONS IN THIS RUN.
C
C		SET UP HYPOTHETICAL 'SOLVENT' SHELL TO DEFINE THE PROTEIN
C		SURFACE. THE CUBIC LATTICE USED FOR THIS PURPOSE HAS AN
C		EDGE LENGTH OF CE.
C
400	CE2=CE/2.
	CALL SHELL
C
	PRINT *, ' SHELL LOADING COMPLETE'
C****************************************************************************
C
C		START VOLUME CALCULATION FOR ALL ATOMS FLAGGED WITH KEY(I)=0
C
	WRITE(2,5105)
5105	FORMAT(/,'    #    SER   #    CH  FI   ATM   RES  RES#',4X,'X',7X,'Y',7X,'Z',
     1	3X,' RVDW RCOV  VOLUME NSOL',/)
	WRITE(2,5107)
5107	FORMAT(' BEGIN')
	NCALC=0
	TOTVOL=0
	DO 1000 I=1,LSTATM
	IF(KEY(I).NE.0) GO TO 1000
C
C		LOAD AO(3) WITH THE COORDINATES OF THE ATOM WHOSE VOLUME IS
C		TO BE CALCULATED (I.E. THE "ORIGIN" ATOM.).
C		ALSO LOAD OTHER PARAMETERS OF AO.
C
	AO(1)=X(I)
	AO(2)=Y(I)
	AO(3)=Z(I)
	AOVDW=RVDW(I)
	AOCOV=RCOV(I)
	AOSEQ=SEQNUM(I)
	CALL GETNUM(I,NRES,AONUM)
C
C		ERROR WRITE
C
	IF(AONUM.EQ.0.AND.METHOD.EQ.2) THEN
				WRITE(3,5108) 
5108				FORMAT(' VOLUME: AONUM=0')
				GO TO 621
	END IF
C
C          INITIALIZE THE ARRAYS BOX,IBOX,POLYHN,IPOLYH,VERVOL
C
      IMSG=1
      ICHK=0
      NASPHR=0
      CALL SPRAY(IBOX,200,0,0)
      CALL SPRAY1(BOX,500, 0.0, 0.0)
      CALL SPRAY(IPOLYH,400,0,0)
      CALL SPRAY1(POLYHN,300,0.0, 0.0)
      CALL SPRAY1(VERVOL,100,0.0, 0.0)
C
500	CALL FILBOX 
      IF(ICHK.NE.-1) GO TO 520
C
C		ERROR WRITE
C
      WRITE(3,5005) I
5005	 FORMAT(' BOX CAPACITY EXCEEDED IN FILBOX FOR ATOM NO.',I10)
      GO TO 621
520	 CONTINUE
C
      JVMAX=100
      IERROR(2,JLEVEL)=600
C
  600 CALL ATMPOL(JVMAX)
C
      IF(IMSG.EQ.6) GO TO 900
      IF(IMSG.EQ.7) GO TO 900
      IF(IMSG.EQ.8) GO TO 900
      IF(ICHK.NE.-1) GO TO 650
C
C		ERROR WRITE
C
  621 WRITE(3,5006) I
5006	 FORMAT(/,' CALCULATION OMITTED FOR ATOM NO.',I10,' GO TO NEXT ATO,
     1M IN INPUT LIST.')
C
      GO TO 900
  650 CONTINUE
C
C		CALCULATE THE VOLUME OF THE LIMITING POLYHEDRON
C
700	CALL POLVOL(JVMAX)
C
	NCALC=NCALC + 1
	TOTVOL=TOTVOL+VOLUME
C
C          DETERMINE THE NUMBER OF SOLVENT MOLECULES
C          USED IN FORMING THE POLYHEDRON AROUND AO.
C
      NS=0
      DO 750 JJ=1,100
      IF(.NOT.VRTATM(JJ)) GO TO 750
	IF(IBOX(2,JJ).EQ.1) NS=NS+1
  750 CONTINUE
C
C     WRITE TO OUTPUT FILE FOR EACH ATOM.
C
C     (NOTE THAT IF PROGRAM ERROR OCCURS
C     EARLIER, VOLUME AND NSOL ARE BOTH SET
C     EQUAL TO 1000. IN NORMAL CALCULATION ACTUAL
C     VALUES ARE ENTERED.)
C
      GO TO 950
900	 VOLUME = 1000.
	 NSOL = 1000
950	 WRITE(2,5007) NCALC,I,NUMCHN(I),NUMFIL(I),ATM(I),RES3(I),
     1	SEQNUM(I),X(I),Y(I),Z(I),RVDW(I),RCOV(I),VOLUME,NS
5007	 FORMAT (2(I8, 1X),2(I3, 1X),2X,A4,2X,A4,I5,3F8.3,2F5.2,  F8.3,I5)
C
	IF(MOD(NCALC,100).EQ.0) PRINT 5008,NCALC
5008	FORMAT(1X,I5,'  ATOMS COMPLETED')
C
1000	CONTINUE
C
	WRITE(2,5030) TOTVOL
5030	FORMAT(' TOTAL VOLUME OF CALCULATED ATOMS =',F10.2)
C
	STOP
C
	END
C
C=======================================================================
	SUBROUTINE ASKFIL(LUNIT,CHAR)
C
	COMMON/FILES/ FNAME,GNAME
C
	CHARACTER*(*)  CHAR
	CHARACTER*30   FNAME,GNAME
C
C		THE SIZE OF THE MESSAGE BUFFER IS DEFINED AT RUN TIME
C		SINCE IT IS USED AS A PASSED LENGTH STRING. FNAME IS 
C		A LOCALLY DEFINED CONSTANT CURRENTLY SET AT 30.
C
	PRINT 10, CHAR
10	FORMAT(5X,A,'---->')
C
	READ 100, FNAME
100	FORMAT(A30)
C
	OPEN(UNIT=LUNIT,NAME=FNAME, STATUS='UNKNOWN')
C
	RETURN
C
	END
C
      BLOCK DATA
C
C		REVISED 15 APR 83
C
C	INCLUDE 'VOL.CMN'
#include "vol.cmn"
C
C          THE ARRAY INDX1(I) PROVIDES A POINTER TO THE LOCATION IN
C          ARRAY ATNAMA WHERE THE DATA FOR RESIDUE I START.
C
      DATA INDX1/ 1, 6, 10, 15, 20, 28, 33, 39, 45, 53, 56, 60,
C
     1 69, 74, 85, 94, 105, 107, 110, 123, 127, 132, 134, 136,
C
     2 138,140,185, 3*0/
C
C
C          THE ARRAY INDX2(I) PROVIDES A POINTER TO THE LOCATION IN
C          ARRAY IBND1(1) WHERE THE DATA FOR RESIDUE I START.
C
      DATA INDX2/1,6,10,15,20,29,34,40,46,54,57,61,71,76,89,98,
     1 109,111,114,129,134,140,190,7*0/
C
C	   FOR THE ARRAYS IBND1() AND ATNAMA():
C          NOTE THAT FOR ASN,GLN,HIS 2 SIDE CHAIN LISTS ARE GIVEN
C          FIRST FOR THE 'A'DESIGNATION,SECOND FOR THE COMPLETE N,C,O
C          DESIGNATION. NOTE THAT INCREMENT NUMBER WILL ONLY GIVE THE
C	   'USUAL' ATOM NUMBER FOR THE FIRST LIST IN EACH CASE.		
C
C          IN THE ARRAY IBND1(I) THE FIRST ENTRY FOR EACH RESIDUE
C          GIVES THE INCREMENT IN THE INDEX I FOR THE LAST ENTRY
C          FOR THAT RESIDUE. OTHER ENTRIES GIVE BOND CODES FOR EACH
C          BOND IN THE MAIN OR SIDE CHAINS.
C          BOND CODE=RESIDUE DIFFERENCE(0 OR 1)*10 000+ LOWER NUMBERED
C          ATOM IN BOND PAIR * 100 + HIGHER NUMBERED ATOM IN BOND PAIR.
C
      DATA IBND1/4,102,103,304,10203,3,105,506,507,4,105,506,607,608,
     1 4,105,506,507,608,8,105,506,607,608,709,810,911,1011,
     2 4,105,506,607,608,5,105,506,607,708,709,5,105,506,607,708,809,
     3 7,105,506,607,708,809,910,911,2,105,506,3,105,506,507,
     4 9,105,506,607,608,709,810,911,1011,1112,4,105,506,607,708,
     5 12,105,506,607,608,709,810,811,910,1012,1113,1214,1314,
     6 8,105,506,607,608,109,910,1011,1012,
     7 10,105,506,607,708,709,110,1011,1112,1213,1214,1,105,2,105,506,
     8 14,105,506,607,608,709,810,910,111,1112,1213,1214,1315,1416,1516,
     9 4,105,207,506,607,5,105,207,506,607,608,49,106,117,125,133,207,
     1 237,310,318,421,426,529,534,607,610,708,809,812,910,911,1213,
     2 1314,1415,1416,1718,1721,1819,1920,1922,2021,2023,2324,2526,2529,
     3 2627,2728,2730,2829,2831,3132,3334,3337,3435,3536,3538,3637,3940,
     4 4041,4142,4143,2,103,304,8*0/
C
C
C          THE ARRAY RESTYP(I) CONTAINS THE THREE LETTER NAME OF THE
C          RESIDUE I.
C
      DATA RESTYP/4HGLY ,4HVAL ,4HLEU ,4HILE ,4HPHE ,4HASP ,4HGLU ,
     1 4HLYS ,4HARG ,4HSER ,4HTHR ,4HTYR ,4HMET ,4HTRP ,4HASN ,4HGLN ,
     2 4HALA ,4HCYS ,4HHIS ,4HPRO ,4HHYP ,4HEXT ,4HDUM ,4HWAT ,
     3 4HHOH ,4HHEM ,4HACE ,3*0.0/
C
C          IN THE ARRAY ATNAMA(I) THE FIRST ENTRY FOR EACH RESIDUE
C          GIVES THE INCREMENT IN THE INDEX I FOR THE LAST ENTRY
C          FOR THAT RESIDUE. OTHER ENTRIES GIVE THE ATOM NAMES IN
C          1-4 ALPHAMERIC CHARACHTERS.(SEE DESCRIPTION OF ITYP1)
C
      DATA ATNAMA/4.,4HCA  ,4HN   ,4HC   ,4HO   , 3.,4HCB  ,
     1 4HCG1 ,4HCG2 , 4.,4HCB  ,4HCG  ,4HCD1 ,4HCD2 , 4.,
     2 4HCB  ,4HCG1 ,4HCG2 ,4HCD1 , 7.,4HCB  ,4HCG  ,
     3 4HCD1 ,4HCD2 ,4HCE1 ,4HCE2 ,4HCZ  , 4.,4HCB  ,
     4 4HCG  ,4HOD1 ,4HOD2 , 5.,4HCB  ,4HCG  ,4HCD  ,
     5 4HOE1 ,4HOE2 , 5.,4HCB  ,4HCG  ,4HCD  ,4HCE  ,
     6 4HNZ  , 7.,4HCB  ,4HCG  ,4HCD  ,4HNE  ,4HCZ  ,
     7 4HNH1 ,4HNH2 , 2.,4HCB  ,4HOG  , 3.,4HCB  ,4HOG1 ,
     8 4HCG2 , 8.,4HCB  ,4HCG  ,4HCD1 ,4HCD2 ,4HCE1 ,
     9 4HCE2 ,4HCZ  ,4HOH  , 4.,4HCB  ,4HCG  ,4HSD  ,
     1 4HCE  , 10.,4HCB  ,4HCG  ,4HCD1 ,4HCD2 ,4HNE1 ,
     2 4HCE2 ,4HCE3 ,4HCZ2 ,4HCZ3 ,4HCH2 , 8.,4HCB  ,4HCG  ,
     3 4HAD1 ,4HAD2 ,4HCB  ,4HCG  ,4HOD1 ,4HND2 , 10.,
     4 4HCB  ,4HCG  ,4HCD  ,4HAE1 ,4HAE2 ,4HCB  ,4HCG  ,
     5 4HCD  ,4HOE1 ,4HNE2 , 1.,4HCB  , 2.,4HCB  ,4HSG  ,
     6 12.,4HCB  ,4HCG  ,4HAD1 ,4HAD2 ,4HAE1 ,4HAE2 ,
     7 4HCB  ,4HCG  ,4HND1 ,4HCD2 ,4HCE1 ,4HNE2 , 3.,
     8 4HCB  ,4HCG  ,4HCD  , 4.,4HCB  ,4HCG  ,4HCD  ,
     9 4HOD  , 1.,4HEXT , 1.,4HDUM , 1.,4HWAT , 1.,4HHOH ,
     1 43.,4HFE  ,4HCHA ,4HCHB ,4HCHC ,4HCHD ,4HN A ,4HC1A ,
     2 4HC2A ,4HC3A ,4HC4A ,4HCMA ,4HCAA ,4HCBA ,4HCGA ,4HO1A ,
     3 4HO2A ,4HN B ,4HC1B ,4HC2B ,4HC3B ,4HC4B ,4HCMB ,4HCAB ,
     4 4HCBB ,4HN C ,4HC1C ,4HC2C ,4HC3C ,4HC4C ,4HCMC ,4HCAC ,
     5 4HCBC ,4HN D ,4HC1D ,4HC2D ,4HC3D ,4HC4D ,4HCMD ,4HCAD ,
     6 4HCBD ,4HCGD ,4HO1D ,4HO2D ,1.,4HCH3 ,15*0/
      END
C
	SUBROUTINE GETNUM(J,NRES,NATM)
C
C		RETURNS RESIDUE TIPE NUMBER,NRES, AND ATOM TIPE NUMBER
C		WITHIN THAT RESIDUE, NATM, FOR AN ATOM IDENTIFIED BY
C		THE SERIAL NUMBER J.
C
C		FUNCTIONS OR SUBROUTINES CALLED:  NONE
C
C	INCLUDE 'VOL.CMN'
#include "vol.cmn"
C
	NRES=0
	NATM=0
	RESTMP=RES3(J)
	DO 100 I=1,30
	IF(RESTMP.NE.RESTYP(I)) GO TO 100
	NRES=I
	GO TO 150
100	CONTINUE
C
	WRITE(3,1000) RESTMP
1000	FORMAT(/,' ERROR: RESIDUE NOT FOUND IN GETNUM:',2X,A4)
C
150	ATMTMP=ATM(J)
	IF(ATMTMP.EQ.ATNAMA(2)) THEN
				NATM=1
				GO TO 500
	ELSE IF(ATMTMP.EQ.ATNAMA(3)) THEN
				NATM=2
				GO TO 500
	ELSE IF(ATMTMP.EQ.ATNAMA(4)) THEN
				NATM=3
				GO TO 500
	ELSE IF(ATMTMP.EQ.ATNAMA(5)) THEN
				NATM=4
				GO TO 500
	END IF
C
	IN=INDX1(NRES)
	INCR=ATNAMA(IN)
	IB=IN+1
	IE=IN+INCR
	DO 300 I=IB,IE
	IF(ATMTMP.NE.ATNAMA(I)) GO TO 300
	NATM=I-IB+1
	IF(NRES.LT.22) NATM=NATM+4
	GO TO 500
300	CONTINUE
C
	WRITE(3,1100) J,ATMTMP
1100	FORMAT(/,' ERROR: ATM NOT FOUND IN GETNUM. SERIAL # =',I5,
     1	'  NAME =',2X,A4)
C
500	RETURN
C
	END
C
		SUBROUTINE SPRAY1(LINE,N,IN,IDEL)
C
C          INSERTS CHARACTER 'IN' INTO ARRAY 'LINE' IN LOCATIONS 1 TO
C          'N' AND INCREMENTS 'IN' BY 'IDEL' BETWEEN SUCCESSIVE ENTRIES
C
	integer N
	real LINE, IN, IDEL
      	DIMENSION LINE(1)
C
      	IF(N.EQ.0) GO TO 900
      	K=IN
      	DO 100 J=1,N
      	LINE(J)=K
  100 	K=K+IDEL
  900 	RETURN
      	END

      SUBROUTINE SPRAY(LINE,N,IN,IDEL)
C
C          INSERTS CHARACTER 'IN' INTO ARRAY 'LINE' IN LOCATIONS 1 TO
C          'N' AND INCREMENTS 'IN' BY 'IDEL' BETWEEN SUCCESSIVE ENTRIES
C
      DIMENSION LINE(1)
C
      IF(N.EQ.0) GO TO 900
      K=IN
      DO 100 J=1,N
      LINE(J)=K
  100 K=K+IDEL
  900 RETURN
      END
C
           SUBROUTINE ERROR
C
C          THIS SUBROUTINE RECEIVES ALL ERROR CALLS FROM ALL OTHER
C          SUBROUTINES AND THE MAIN PROGRAM.  THE ARRAY IERROR(I,J)
C          KEEPS TRACK OF THE HEIRARCHY OF CALLING PROGRAMS. J=1
C          IDENTIFIES THE MAIN PROGRAM, J=2,--IDENTIFY EACH SUBSEQUENTLY
C          CALLED SUBROUTINE IN SEQUENCE WITH THE LAST ENTRY BEING THE
C          ROUTINE CALLING ERROR. I=1 CONTAINS A CODE NUMBER PROVIDING
C          THE NAME OF THE SUBROUTINE REQUIRED BY J. I=2 CONTAINS THE
C          STATEMENT NUMBER THAT PRODUCED THE ERROR IN THE CALLING PGM.
C
C          IMSG IS A CODE NUMBER FOR THE MESSAGE TO BE PRINTED.
C          JCHK IS DISREGARDED AT THIS TIME
C          WHERE USED ICHK IS SET IN PROGRAM DETECTING AND ACTUAL OR
C          POSSIBLE ERROR AND IS TESTED AT HIGHER LEVELS.
C          ICHK=0= NO ERROR
C          ICHK=1=ERROR FOUND BUT PROGRAM TO CONTINUE WITH OR WITHOUT
C          MESSAGE
C          ICHK=-1= ERROR FOUND INDEX USED TO ABORT PROGRAM IF NECESSARY
C          AFTER RETURN FROM ERROR.
C
C          THE ONLY SUBROUTINES WITH /FMRTST/ AT THIS TIME ARE:
C          SAMSID,INSIDE,POINT,PLANE,VERTEX,MAIN,ERROR,ATVOL
C          ONLY POINT,PLANE,ATVOL CALL ERROR DIRECTLY
C
C          FUNCTIONS OR SUBROUTINES CALLED:  NONE
C
C	INCLUDE 'TEST.CMN'
#include "test.cmn"
C
      DIMENSION NAME(50)
      DATA NAME/4H    ,4H    ,4HDET3,4HC   ,4HDET3,4HR   ,
     1          4HRELR,4HAD  ,4HSAMS,4HID  ,4HCENT,4HRD  ,
     2          4HDPTP,4HLN  ,4HINSI,4HDE  ,4HPOIN,4HT   ,
     3          4HPLAN,4HE   ,4HVOLT,4HET  ,4HSELE,4HCT  ,
     4          4HREST,4HAK  ,4HORDE,4HR   ,4HVERT,4HEX  ,
     5          4HNCAL,4HLS  ,4HERRO,4HR   ,4HATVO,4HL   ,
     6          4HPRIN,4HT1  ,4HMAIN,4H    ,10*4H    /
C
      WRITE(3,1)
    1 FORMAT(/,' ERROR ROUTINE CALLED',/)
C
      DO 100 J=1,5
      INAME1=(IERROR(1,J)*2)+1
      INAME2=INAME1+1
      WRITE(3,2) NAME(INAME1),NAME(INAME2),IERROR(2,J)
    2 FORMAT(1X,5(A4,A4,2X,I5),/)
  100 CONTINUE
  200 CONTINUE
C
      GO TO (200,200,300,400,500,600,700,800),IMSG
C
  300 WRITE(3,3)
    3 FORMAT(' THE PLANE IS INDETERMINATE. THE THREE DEFINING POINTS ARE
     1 COLINEAR.')
      GO TO 1000
C
  400 WRITE(3,4)
    4 FORMAT(' NO POINT OF INTERSECTION. PLANES ARE PARALLEL, INTERSECT'
     1,/,' IN A LINE OR INTERSECT IN PAIRS TO GIVE 3 LINES.')
      GO TO 1000
C
  500 GO TO 1000
C
  600 WRITE(3,6)
    6 FORMAT(' THE PROGRAM CANNOT FIND 3 ATOMS IN BOX TO DEFINE A ',/,
     1' PLANE MORE THAN 0.5 A FROM AO, AND ON OPPOSITE SIDE OF AO',/,
     2' FROM ATOM 1 IN BOX. PICK NEXT ATOM IN INPUT LIST.')
      GO TO 1000
C
  700 WRITE(3,7)
    7 FORMAT(' THE PROGRAM CANNOT FIND 3 ATOMS IN BOX TO COMBINE',/,
     1' WITH ATOM NUMBER 1 TO DEFINE A TETRAHEDRON WHICH SURROUNDS',/,
     2' THE ORIGIN ATOM AO. PICK NEXT ATOM IN INPUT LIST.')
      GO TO 1000
C
  800 WRITE(3,8)
    8 FORMAT(' THE NUMBER OF VERTICES IN THE PRESENT POLYHEDRON TO ',
     1/,' BE ELIMINATED BY THE PLANE ASSOCIATED WITH THE NEXT ATOM ',
     2/,' IN BOX IS GREATER THAN 10, THE PRESENT MAXIMUM OF NELIM.',/,
     3' PICK NEXT ATOM IN INPUT LIST.')
C
 1000 RETURN
      END
C
      SUBROUTINE PRNTPN(JVMAX)
C
C          PRINTS OUT CURRENT CONTENTS OF ARRAYS IPOLYH AND POLYHN.
C
C          FUNCTIONS OR SUBROUTINES CALLED: NONE
C
C	INCLUDE 'VOL.CMN'
#include "vol.cmn"
C
      WRITE(3,5)
    5 FORMAT(//,' IPOLYH(I,J),POLYHN(I,J),I=1-3,J=1-JVMAX')
C
      WRITE(3,6)
    6 FORMAT(/,' NO.',4X,'JA',8X,'JB',8X,'JC',8X,'X',9X,'Y',9X,'Z',/)
C
      DO 200 J=1,JVMAX
  200 WRITE(3,7)J,(IPOLYH(I,J),I=1,3),(POLYHN(I,J),I=1,3)
    7 FORMAT(I4,3(4X,I2,4X),3F10.5)
C
      RETURN
      END
C
      SUBROUTINE PRNTBX(ID)
C
C          PRINTS OUT CURRENT CONTENTS OF ARANGE,ID,AO(3),
C          IBOX(JJ),BOX(I=1-11,JJ) WHERE JJ=1-NACUBE OR 1-NASPHR.
C
C          FUNCTIONS OR SUBROUTINES CALLED: NONE
C
C	INCLUDE 'VOL.CMN'
#include "vol.cmn"
C
      WRITE(3,1) ARANGE,ID,AO(1),AO(2),AO(3)
    1 FORMAT(  //,' MAXIMUM RADIUS=',F8.3,', ID=', I5,' AO: X=',F8.3,
     1', Y=',F8.3,', Z=',F8.3)
C
      WRITE(3,2)
    2 FORMAT(/,' IBOX(1-2,J),BOX(I,J),I=1,5,J=1-NASPHR')
C
      WRITE(3,3)
    3 FORMAT(/,' NO.',5X,'ID',3X,' SOLV',5X,
     1'DIST',7X,'NX',
     28X,'NY',8X,'NZ',8X,'D',/)
C
   60 DO 100 J=1,NASPHR
  100 WRITE(3,4)J,IBOX(1,J),IBOX(2,J),(BOX(I,J),I=1,5)
    4 FORMAT(I4,I10,I5,5F10.5)
C
      WRITE(3,5)
    5 FORMAT (//)
      DO 200 J = 97,100
  200 WRITE(3,4)J,IBOX(1,J),IBOX(2,J),(BOX(I,J),I=1,5)
      WRITE (3,5)
C
      RETURN
      END
C
	SUBROUTINE SHELL	
C
C     		PROGRAM TO PUT A ROUGH SOLVENT SHELL AROUND A PROTEIN MOLECULE.
C     		THE SHELL IS BASED ON A CUBIC LATTICE OF EDGE DIMENSION CE.
C
C	INCLUDE 'VOL.CMN'
#include "vol.cmn"
C
        DIMENSION NCOUNT(10),NC(30),MC(20),IC(20)
	CHARACTER*2 NC
C
      DO 50 I=1,MAXSIZ
  50	ICL(I)= 0
C
	NPAT=LSTATM
C
C		THE ARRAY ICL IS SET UP AS A ONE DIMENSIONAL ARRAY BUT
C		IS THOUGHT OF AS A THREE DIMENSIONAL ARRAY IN DESCRIBING
C		THE OPERATION OF THE PROGRAM.
C		SET UP THE MAXIMUM DIMENSIONS OF THE REQUIRED ARRAY IN 
C		THE THREE AXIAL DIRECTIONS.
C
	IMAX=(XMAX-XMIN)/CE+5.
	JMAX=(YMAX-YMIN)/CE+5.
	KMAX=(ZMAX-ZMIN)/CE+5.
C
	IM=IMAX
	JIM=JMAX*IMAX
C
	IF(IMAX*JMAX*KMAX.GT.MAXSIZ) GO TO 5000
C
C		XM2,YM2,ZM2 ARE THE CENTER OF THE FIRST CUBE IN THE ICL ARRAY
C
	XM2=XMIN+CE2
	YM2=YMIN+CE2
	ZM2=ZMIN+CE2
C
C          	LOAD ATOMS INTO CUBES IN ARRAY ICL(L) .SMALLEST STARTING
C          	INDEX FOR EACH AXIS =3.
C
      DO 150 I = 1,NPAT
	IF(KEY(I).LT.0) GO TO 150
	IN=(X(I)-XMIN)/CE+3.
	JN=(Y(I)-YMIN)/CE+3.
	KN=(Z(I)-ZMIN)/CE+3.
	L= (KN-1)*JIM + (JN-1)*IM + IN
	ICL(L)=ICL(L)+1
  150   CONTINUE
C
C          	ICL ENTRIES NOW EQUAL ZERO OR THE NUMBER OF PROTEIN ATOMS
C           	IN THAT CUBE.
C
      LCNT = 0
      DO 200 K = 1,KMAX
	KM = (K-1)*JIM
      DO 200 J = 1,JMAX
	JM = (J-1)*IM
      DO 200 I = 1,IMAX
	L = KM + JM + I
      IF (ICL(L).LE.0) GO TO 200
      LDEL=ICL(L)
      L1 = LCNT + 1
      ICL(L) = L1
      JSERN(L1) = LDEL + 10000*LDEL
      LCNT = L1 + LDEL
  200 CONTINUE
      LLAST = LCNT
C
C          ICL NOW CONTAINS POINTER TO THE JSERN LOCATION FOR CUBE(I,J,K) WHICH
C          GIVES THE TOTAL NUMBER  OF ENTRIES FOR THAT CUBE.  ATOM ID
C          NUMBERS FOR THAT CUBE ARE TO FOLLOW AS NEXT ENTRIES IN JSERN.
C
      DO 300 I = 1,NPAT
	IF(KEY(I).LT.0) GO TO 300
	IN=(X(I)-XMIN)/CE+3.
	JN=(Y(I)-YMIN)/CE+3.
	KN=(Z(I)-ZMIN)/CE+3.
	L = (KN-1)*JIM + (JN-1)*IM + IN
        INDX = ICL (L)
        J = INDX + MOD(JSERN(INDX),10000)
        JSERN (J) = I
        JSERN(INDX) = JSERN(INDX) -1
        IF(MOD(JSERN(INDX),10000).GT.1000) GO TO 320
  300   CONTINUE
      GO TO 350
C
C		ERROR WRITE
C
  320 WRITE (3,17)
	write(*,17)
   17 FORMAT(' STOP SHELL ERROR AT STATEMENT 320')
      STOP
C
C          	RESET JSERN INDX POINTS
C
350	CONTINUE
      DO 400 K = 1,KMAX
	KM = (K-1)*JIM
      DO 400 J = 1,JMAX
	JM = (J-1)*IM
      DO 400 I = 1,IMAX
	L = KM + JM + I
      IF (ICL(L).LE.0) GO TO 400
      INDX = ICL(L)
      JSERN(INDX)=JSERN(INDX)/10000
  400 CONTINUE
C
C          	LOAD -1 INTO ICL(L) IF ALL NEIGHBORS ARE 0 OR -1
C
	DO 700 K=1,KMAX
	KB = K-1
	IF(KB.LT.1) KB=1
	KE = K+1
	IF(KE.GT.KMAX) KE=KMAX
	DO 700 J=1,JMAX
	JB = J-1
	IF(JB.LT.1) JB=1
	JE = J+1
	IF(JE.GT.JMAX) JE=JMAX
	DO 700 I=1,IMAX
	IB = I-1
	IF(IB.LT.1) IB=1
	IE = I+1
	IF(IE.GT.IMAX) IE=IMAX
      M=0
	DO 600 KK=KB,KE
		KN=(KK-1)*JIM
	DO 600 JJ=JB,JE
 		JN=(JJ-1)*IM
	DO 600 II=IB,IE
		LL = KN + JN + II
      IF(ICL(LL).LE.0) GO TO 600
      M=M+1
  600 CONTINUE
      IF(M.EQ.0) GO TO 650
      GO TO 700
650	L= (K-1)*JIM + (J-1)*IM + I
        ICL(L)=-1
  700 CONTINUE
C
C          	POTENTIAL SOLVENT MOLECULES NOW RESTRICTED TO POSITIONS
C          	LABELLED 0.  SEARCH FOR CHANNEL TO SURFACE IN EACH CASE.
C
  841 IMAX1=IMAX-1
      JMAX1=JMAX-1
      KMAX1=KMAX-1
      DO 1000 K=2,KMAX1
		KM=(K-1)*JIM
      DO 1000 J=2,JMAX1
		JM=(J-1)*IM
      DO 1000 I=2,IMAX1
		L = KM + JM + I
      IF(ICL(L).NE.0) GO TO 1000
C
C          	EXAMINE 26 SITES AROUND POSITION I, J, K.
C
      DO 950 KK=1,3
	KN=K+KK-2
      DO 950 JJ=1,3
	JN=J+JJ-2
      DO 950 II=1,3
	IN=I+II-2
      IF(II.EQ.2.AND.JJ.EQ.2.AND.KK.EQ.2) GO TO 950
	LL=(KN-1)*JIM+(JN-1)*IM+IN
      IF(ICL(LL).LE.0) GO TO 950
C
C          	TEST IF OPPOSING PAIRS IN LATTICE SITES AROUND TARGET
C          	ATOM ARE BOTH OCCUPIED. IF YES, LABEL CUBE AS A POTENTIAL
C	   	CAVITY (-2).
C
      INOP=IN+2*(2-II)
      JNOP=JN+2*(2-JJ)
      KNOP=KN+2*(2-KK)
	LL= (KNOP-1)*JIM + (JNOP-1)*IM + INOP
      IF(ICL(LL).LE.0) GO TO 950
      ICL(L)=-2
      GO TO 1000
  950 CONTINUE
 1000 CONTINUE
C
C          	TEST THIS ATOM AGAINST SURROUNDING 26 NEIGHBOR CUBES
C
C          	CHECK IF ANY SOLVENT OR -2 POSITIONS ARE INSIDE PROTEIN
C          	VDW ENVELOPES.IF YES,SET EQUAL TO -3 OR -4.
C
      DO 2200 I=1,NPAT
	IF(KEY(I).LT.0) GO TO 2200
	R=RVDW(I)
	RSQ=R**2
	IN=(X(I)-XMIN)/CE+3.
	JN=(Y(I)-YMIN)/CE+3.
	KN=(Z(I)-ZMIN)/CE+3.
      IS=IN-1
      JS=JN-1
      KS=KN-1
      IE=IS+2
      JE=JS+2
      KE=KS+2
      DO 2120 KK=KS,KE
		KM = (KK-1)*JIM
      DO 2120 JJ=JS,JE
		JM = (JJ-1)*IM
      DO 2120 II=IS,IE
	AX=XM2+CE*FLOAT(II-3)
	AY=YM2+CE*FLOAT(JJ-3)
	AZ=ZM2+CE*FLOAT(KK-3)
	DIFX=ABS(AX-X(I))
	DIFY=ABS(AY-Y(I))
	DIFZ=ABS(AZ-Z(I))
      IF(DIFX.GT.R.OR.DIFY.GT.R.OR.DIFZ.GT.R) GO TO 2120
      CHKSQ=DIFX**2+DIFY**2+DIFZ**2
      IF(CHKSQ.GT.RSQ) GO TO 2120
	LL = KM + JM + II
      IF(ICL(LL).EQ.0) ICL(LL)=-3
      IF(ICL(LL).EQ.-2) ICL(LL)=-4
 2120 CONTINUE
 2200 CONTINUE
C
C
 2000 NZERO= 0
      MIN2 = 0
      MIN3 = 0
      MIN4 = 0
      NPROT= 0
      DO 1090 N=1,10
 1090 NCOUNT(N)=0
      DO 1100 K=1,KMAX
		KM = (K-1)*JIM
      DO 1100 J=1,JMAX
		JM = (J-1)*IM
      DO 1100 I=1,IMAX
	L = KM + JM + I
      JCL = ICL(L)
      IF(JCL.EQ.0) NZERO = NZERO+1
      IF(JCL.EQ.-2) MIN2 = MIN2 + 1
      IF(JCL.EQ.-3) MIN3 = MIN3 + 1
      IF(JCL.EQ.-4) MIN4 = MIN4+1
      IF(JCL.GT.0) NPROT = NPROT + 1
      IF(JCL.LE.0) GO TO 1100
      N=JSERN(JCL)
      NCOUNT(N)=NCOUNT(N) + 1
 1100 CONTINUE
C
C              	WRITE TO OUT PUT TAPE
C
      WRITE(2,8) NZERO,MIN3,MIN2,MIN4,NPROT,(NCOUNT(N),N=1,10)
	WRITE(*,8) NZERO,MIN3,MIN2,MIN4,NPROT,(NCOUNT(N),N=1,10)
    8 FORMAT(/,' NUMBER OF SOLVENT MOLECULES REMAINING =',I10,/,
     1' NUMBER OF SOLVENT MOLECULES REMOVED   =',I10/,
     2' NUMBER OF INTERIOR CAVITIES REMAINING =',I10,/,
     3' NUMBER OF INTERIOR CAVITIES REMOVED   =',I10/,
     2' NUMBER OF CELLS WITH PROTEIN ATOMS    =',I10,/,
     3' NUMBER OF CELLS WITH 1,2,3,ETC PROTEIN ATOMS = ',10I5,/)
C
C     		LOAD SOLVENT 'ATOMS' INTO COORDINATE ARRAYS
C
      NSOL=0
      IX = LSTATM
      DO 3000 K = 1, KMAX
		KM = (K-1)*JIM
      DO 3000 J = 1, JMAX
		JM = (J-1)*IM
      DO 3000 I = 1, IMAX
	L = KM + JM + I
      IF (ICL(L) .NE. 0) GO TO 3000
      IRSDEL = NSOL/100
      IRES = LSTRES + 1 + IRSDEL
      NATM = MOD(NSOL,100)
	IX=IX+1
      NSOL = NSOL + 1
      LTST=LSTATM+NSOL
C
      IF (LTST .GT. MAXATM) GO TO 4500
C
	KEY(IX)=1
	RES3(IX)=RESTYP(25)
	ATM(IX)=RESTYP(25)
	SEQNUM(IX)= IRES
	X(IX)=XM2+CE*FLOAT(I-3)
	Y(IX)=YM2+CE*FLOAT(J-3)
	Z(IX)=ZM2+CE*FLOAT(K-3)
 3000 CONTINUE
C
	MAXSOL=IRES
C
C		LOAD CUBES LABELED -2 AT END OF COORDINATE ARRAYS
C
	NMIN2=0
      DO 3100 K = 1, KMAX
		KM = (K-1)*JIM
      DO 3100 J = 1, JMAX
		JM = (J-1)*IM
      DO 3100 I = 1, IMAX
	L = KM + JM + I
      IF (ICL(L) .NE. -2) GO TO 3100
      IRSDEL = NMIN2/100
      IRES = MAXSOL + 1 + IRSDEL
      NATM = MOD(NMIN2,100)
	IX=IX+1
      NMIN2 = NMIN2 + 1
      LTST= LSTATM + NSOL + NMIN2
C
      IF (LTST .GT. MAXATM) GO TO 4500
C
	KEY(IX)=1
	RES3(IX)=RESTYP(23)
	ATM(IX)=RESTYP(23)
	SEQNUM(IX)= IRES
	X(IX)=XM2+CE*FLOAT(I-3)
	Y(IX)=YM2+CE*FLOAT(J-3)
	Z(IX)=ZM2+CE*FLOAT(K-3)
 3100 CONTINUE
      NTOT = LSTATM + NSOL + NMIN2
	NPAT=LSTATM
C
      GO TO 7000
C
C		ERROR WRITE
C
 4500 WRITE(3,4510) LTST
	  WRITE(*,4510) LTST
 4510 FORMAT ('NUMBER OF PROTEIN + SOLVENT ATOMS GREATER THAN',I10)
C
      GO TO 6000
C
C		ERROR WRITE
C
 5000 WRITE(6,5010) IMAX,JMAX,KMAX,ICLX,ICLY,ICLZ
	  WRITE(*,5010) IMAX,JMAX,KMAX,ICLX,ICLY,ICLZ
 5010 FORMAT(' ICL ARRAY TOO SMALL',/,' IMAX,JMAX,KMAX =',3I6,/,
     1' ICLX,ICLY,ICLZ = ',3I6)
C
 6000 STOP
C
7000	CONTINUE
C
	RETURN
C
      END
      SUBROUTINE FILBOX 
C
C          	LOADS ARRAYS BOX AND IBOX WITH COORDINATES AND IDS OF ATOMS
C          	WITHIN THE SPHERE OF NOMINAL RADIUS ARANGE
C          	CENTERED ON THE POSITION OF THE ORIGIN ATOM AO.
C
C		TEMP(1,KK)= BOX(1,J)= DISTANCE OF ATOM (KK OR J) FROM ORIGIN ATOM AO.
C		TEMP(2,KK)= BOX(2,J)= DELTA X ( KK OR J FROM AO )
C		TEMP(3,KK)= BOX(3,J)= DELTA Y ( KK OR J FROM AO )
C		TEMP(4,KK)= BOX(4,J)= DELTA Z ( KK OR J FROM AO )
C		    	    BOX(5,J)= CONSTANT FACTOR IN EQUATION OF PLANE (D).
C
C		ITEMP(1,KK)= IBOX(1,J)= SERIAL NUMBER OF ATOM OR 'SOLVENT' IN COORD LST
C		ITEMP(2,KK)= IBOX(2,J)= 0 FOR PROTEIN ATOM, 1 FOR SOLVENT 'ATOM'
C
C		EQUATION FOR PLANE: A*X + B*Y + C*Z + D = 0
C
C		A,B,C ARE THE DIRECTION COMPONENTS OF THE PLANE NORMAL
C		X,Y,Z ARE THE COORDINATES OF ANY POINT IN THE PLANE
C		BUT IN THIS SUBROUTINE IT IS THE POINT OF INTERSECTION OF THE 
C		PLANE AND THE INTERATOMIC VECTOR TO WHICH IT IS NORMAL.
C
C          	FUNCTIONS OR SUBROUTINES CALLED: SPRAY,BXLOAD,GETNUM
C
C	INCLUDE 'VOL.CMN'
#include "vol.cmn"
C

       DIMENSION  AL(3),ITEMP(2,MAXATM)
       DIMENSION NX(3),XC(3),XCL(3),XCH(3)
C***************************************************
	VDWDFT=1.70         !DEFAULT VAN DER WAALS RADIUS
C***************************************************
	NX(1)=(AO(1)-XMIN)/CE
	NX(2)=(AO(2)-YMIN)/CE
	NX(3)=(AO(3)-ZMIN)/CE
C
	XC(1)=(FLOAT(NX(1))+0.5)*CE+XMIN
	XC(2)=(FLOAT(NX(2))+0.5)*CE+YMIN
	XC(3)=(FLOAT(NX(3))+0.5)*CE+ZMIN
C
      DO 30 J=1,3
      XCL(J)=XC(J)-CE-0.1
   30 XCH(J)=XC(J)+CE+0.1
C
C		NX(I) = INDICES OF ICL CUBE CONTAINING AO.
C		XC(I) = FLOATING POINT COORDINATES OF THIS CUBE.
C		XCL(I) AND XCH(I) DEFINE THE LIMITS OF THE 26 SURROUNDING CUBES.
C		THE CUBE EDGE IS CE, THE SAME NUMBER USED IN DEFINING THE 
C		ORIGINAL SOLVENT LATTICE.
C
      IPASS=0
      CALL SPRAY(ITEMP,2*MAXATM,0,0)
      RNGSQ1=ARANGE*ARANGE
	NTEST=NPAT+NSOL
      KK=1
      I=0
   50 I=I+1
      IF(I.GT.NTEST) GO TO 305
	IF(I.LE.NPAT.AND.KEY(I).LT.0) GO TO 300     !DELETE ALL PROTEIN ATOMS WITH KEY=-1
      AL(1)=X(I)-AO(1)
      AL(2)=Y(I)-AO(2)
      AL(3)=Z(I)-AO(3)
	SUMSQ=0.0
      DO 100 J=1,3
  100 SUMSQ=SUMSQ+AL(J)*AL(J)
      JSEQN=SEQNUM(I)
C
C          	LSTRES IS USED AS THE MAXIMUM SEQUENCE NUMBER OF PROTEIN
C          	ATOMS IN COORDINATE LIST. HIGHER NUMBERS REFER TO
C          	HYPOTHETICAL SOLVENT MOLECULES
C
      IF(JSEQN.GT.LSTRES) GO TO 150
      IF(SUMSQ.GT.RNGSQ1) GO TO 300
C
C          	ELIMINATE AO ITSELF FROM LIST
C
      IF(SUMSQ.LT.0.0001) THEN
			ID=I
			GO TO 300
	END IF
      GO TO 250
  150 CONTINUE
C
C          	LOAD SOLVENT ATOM IN TEMP IF IT IS ANY OF 26 NEAREST
C          	NEIGHBORS OF SPHERICAL AO.
C
      IF(X(I).LT.XCL(1).OR.X(I).GT.XCH(1)) GO TO 300
      IF(Y(I).LT.XCL(2).OR.Y(I).GT.XCH(2)) GO TO 300
      IF(Z(I).LT.XCL(3).OR.Z(I).GT.XCH(3)) GO TO 300
C
  250 CONTINUE
C
C		SEE NOTES IN HEADER TO SUBROUTINE
C
      TEMP(1,KK)=SQRT(SUMSQ)
      TEMP(2,KK)=AL(1)
      TEMP(3,KK)=AL(2)
      TEMP(4,KK)=AL(3)
      ITEMP(1,KK)=I
       IF(JSEQN.GT.LSTRES) ITEMP(2,KK)=1
      KK=KK+1
  300 CONTINUE
      GO TO 50
  305 CONTINUE
      KK=KK-1
	NASPHR=KK
C
C          	TOTAL NUMBER OF ATOMS IN SPHERE AROUND AO = NASPHR.(SYMBOL
C          	KK IS USED INTERNALLY IN THIS SUBROUTINE.)
      VDIAM = (AOVDW + RDELTA) * 2.0
	AOVDW2=AOVDW**2
C
C           	IF SECOND ATOM IS SOLVENT MOLECULE, ARBITRARILY SET
C          	DIVIDING PLANE AT THE VAN DER WAALS SURFACE OF AO.
C		OR AT A SURFACE RDELTA OUTSIDE OF THE ACTUAL VANDER
C		WAALS SURFACE.
C
      DO 309 I = 1,KK
      IF (ITEMP (2,I) .EQ. 0) GO TO 309
      RATIO = VDIAM/TEMP (1,I)
      TEMP (1,I) = VDIAM
      DO 308 K = 2,4
  308 TEMP (K,I) = TEMP (K,I) * RATIO
  309 CONTINUE
C
C          	PUT ATOMS IN BOX IN ORDER OF INCREASING DISTANCE FROM AO.
C
C          	LL = INDEX FOR ARRAY BOX
C          	L = INDEX FOR ARRAY TEMP
C
      LL=1
      L=KK
  310 CONTINUE
      DNEXT=1000.0
      DO 320 I=1,L
      IF(DNEXT.LE.TEMP(1,I)) GO TO 320
      DNEXT=TEMP(1,I)
      INEXT=I
  320 CONTINUE
      DO 340 J=1,4
  340 BOX(J,LL)=TEMP(J,INEXT)
      IBOX(1,LL)=ITEMP(1,INEXT)
      IBOX(2,LL)=ITEMP(2,INEXT)
  350 LL=LL+1
C
C          	REMOVE SELECTED ATOM FROM TEMP.
C
      IF(INEXT.EQ.L) GO TO 380
      DO 360 J=1,4
  360 TEMP(J,INEXT)=TEMP(J,L)
      ITEMP(1,INEXT)=ITEMP(1,L)
      ITEMP(2,INEXT)=ITEMP(2,L)
  380 IF(L.LE.1) GO TO 390
      L=L-1
      GO TO 310
  390 CONTINUE
C***************************************************************************
	GO TO (400,500,600), METHOD
C***************************************************************************
C          	LOAD BOX(5,J) BY NORMAL VORONOI PROCEDURE
C	 	( RICHARDS METHOD A ) (I.E. DIVIDING PLANE BISECTS
C		INTERATOMIC VECTORS)
C
400	F=0.5
	DO 440 J=1,KK
440	CALL BXLOAD(J,F)
	GO TO 700
C**************************************************************************
C	   	LOAD BOX(5,J) BY RICHARDS METHOD B (I.E. DIVIDING
C		PLANE POSITIONED BY RADII RATIOS)
500	DO  540 J=1,KK
	JID=IBOX(1,J)
C		IF J IS A 'SOLVENT' ATOM, BYPASS COVALENT CHECK
	IF(SEQNUM(JID).GT.LSTRES) THEN
					F=0.5
					GO TO 530
	ENDIF
C		DETERMINE IF J IS COVALENTLY BONDED TO AO OR NOT.
	SEQDIF=SEQNUM(JID) - AOSEQ
C		GET RESIDUE TIPE NUMBER AND ATOM NUMBER
	CALL GETNUM (JID,NRES,JNUM)
C
C		ERROR WRITE
C
	IF(NRES.EQ.0.OR.JNUM.EQ.0) THEN
		WRITE(3,5000) NRES,JNUM,J
		WRITE(*,5000) NRES,JNUM,J
5000		FORMAT(' FILBOX: NRES =',I5,' NATM =',I5,' BOX ATOM =',I5,
     1	'  DEFAULT VDW RADIUS USED')	
		GO TO 515
	END IF
C
	IF(AONUM.EQ.2.AND.SEQDIF.EQ.-1.AND.JNUM.EQ.3) GO TO 520
	IF(AONUM.EQ.3.AND.SEQDIF.EQ. 1.AND.JNUM.EQ.2) GO TO 520
C		SET UP BOND CODE
	BNDCOD=AONUM*100 + JNUM
	IF(AONUM.GT.JNUM) BNDCOD=JNUM*100 + AONUM
C		CHECK BOND CODE LIST
	IN=INDX2(NRES)
	INCR=IBND1(IN)
	IB=IN+1
	IE=IN+INCR
	DO 510 I=IB,IE
	IF(BNDCOD.NE.IBND1(I)) GO TO 510
	GO TO 520
510	CONTINUE
C		SET UP PLANE BASED ON DIVISION BY VANDERWAALS RADII.
	F=(BOX(1,J) + AOVDW - RVDW(JID))/(2.*BOX(1,J))
	CALL BXLOAD(J,F)
	GO TO 540
515	F=(BOX(1,J) + AOVDW - VDWDFT)/(2.*BOX(1,J))
	CALL BXLOAD(J,F)
	GO TO 540
C		SET UP PLANE BASED ON DIVISION BY COVALENT RADII.
520	F= AOCOV/(AOCOV+RCOV(JID))
530	CALL BXLOAD(J,F)
540	CONTINUE
	GO TO 700
C*****************************************************************************
C	   	LOAD BOX(5,J) BY THE RADICAL PLANE PROCEDURE
C		(SEE GELLATLY AND FINNEY J.MOL.BIOL.161,305-322 (1982))
C
600	DO 640 J=1,KK
	IF(IBOX(2,J).EQ.0) GO TO 620
C		WHEN ATOM J IS A 'SOLVENT'ATOM, THE PLANE IS DRAWN
C		TANGENT TO THE VDW SPHERE OF AO ( SEE EARLIER STATEMENTS
C		IN THIS SUBROUTINE WHICH RESET TEMP((1-4,J) FOR THIS 
C		EVENTUALITY.)
	F=0.5
	CALL BXLOAD(J,F)
	GO TO 640
C		WHEN ATOM J IS A PROTEIN ATOM, THE RADICAL PLANE PROCEDURE
C		PROVIDES THE LOCUS OF POINTS EQUIDISTANT FROM THE TANGENTS TO  
C		THE VANDERWAALS SPHERES.
620	R2SQ=RVDW(IBOX(1,J))**2
	DSQ=BOX(1,J)**2
	F=(DSQ + AOVDW2 - R2SQ)/(2*DSQ)
	CALL BXLOAD(J,F)
640	CONTINUE
C******************************************************************************
C          	LOAD BOX POSITIONS 97-100 WITH HYPOTHETICAL TETRAHEDRON
C          	SURROUNDING AO .TO BE USED AS STARTING POLYHN IN ATPOL.
C
700	CONTINUE
      IF(NASPHR.GT.96) ICHK=-1
      BOX(2,97) =+10.0
      BOX(2,98) =+10.0
      BOX(2,99) =-10.0
      BOX(2,100)=-10.0
      BOX(3,97) =+10.0
      BOX(3,98) =-10.0
      BOX(3,99) =+10.0
      BOX(3,100)=-10.0
      BOX(4,97) =+10.0
      BOX(4,98) =-10.0
      BOX(4,99) =-10.0
      BOX(4,100)=+10.0
C
      DO 800 J=97,100
  800 BOX(1,J)=17.3205
C
	F=0.5
      DO 820 J=97,100
820	CALL BXLOAD(J,F)
C*************************************************************************
C
      RETURN
C
      END
C
	SUBROUTINE BXLOAD(J,F)
C
C		LOADS CONSTANT FACTOR, D,FOR EQUATION FOR A PLANE
C		INTO BOX(5,J). A*X + B*Y + C*Z + D = 0.
C
C	INCLUDE 'VOL.CMN'
#include "vol.cmn"
C
	SUMNP=0.0
	DO 100 K=1,3
	K1=K+1
	DF=AO(K) + F*BOX(K1,J)
100	SUMNP=SUMNP + BOX(K1,J)*DF
C
	BOX(5,J)= -SUMNP
C
	RETURN
C
	END
C
C
      SUBROUTINE ATMPOL(JVMAX)
C
C          ESTABLISHES THE VERTICES OF THE MINIMUM REQUIRED POLYHEDRON
C          AROUND THE ORIGIN ATOM AO.
C          DATA TAKEN FROM THE ORDERED ATOM LIST IN ARRAYS IBOX AND BOX.
C          THE RESULTS ARE LOADED INTO THE ARRAYS IPOLYH(I,J) I=1,3 (ID
C          NUMBERS OF ATOMS IN BOX CONTRIBUTING TO THE VERTEX J), AND
C          POLYHN(I,J) I=1,3 (XYZ COORDINATES OF VERTEX J).
C
C          FUNCTIONS OR SUBROUTINES CALLED: ERROR,VERTEX,SAMSID
C
C	INCLUDE 'VOL.CMN'
#include "vol.cmn"
C
C	INCLUDE 'TEST.CMN'
#include "test.cmn"
C
      DIMENSION P1(3),PLN(4)
      DIMENSION JELIM(20),LINES(2,60),ITEMP(4,100)
C
      EQUIVALENCE(TEMP(1,1),ITEMP(1,1))
C
C          INITIALIZE ERROR VARIABLES
C
      JLEVEL=JLEVEL+1
      DO 90 J=JLEVEL,5
      DO 90 I=1,2
   90 IERROR(I,J)=0
      IERROR(1,JLEVEL)=17
C
      DO 91 I=1,100
   91 VRTATM(I)=.FALSE.
C
C          LOAD IPOLYH AND POLYHN WITH VERTICES FROM 4 HYPOTHETICAL
C          ATOMS CONTAINED IN BOX(I,J=97-100).
C
      CALL VERTEX(97,98,99,1)
      CALL VERTEX(98,99,100,2)
      CALL VERTEX(99,100,97,3)
      CALL VERTEX(100,97,98,4)
C
C          IPOLYH(I,J) IS LOADED WITH THE INDEX NUMBERS OF ATOMS IN BOX
C          WHOSE PLANES INTERSECT AT VERTEX J. POLYHN(I,J) IS LOADED
C          WITH THE XYZ COORDINATES OF VERTEX J.
C
      DO 100 I=97,100
  100 VRTATM(I)=.TRUE.
C
C          JVMAX= TOTAL NUMBER OF VERTICES INCLUDED IN POLYHN
C          JATADD= NUMBER  IN BOX OF ATOM WHOSE PLANE IS TO PRODUCE
C                  NEW VERTICES.
C          NELIM= NUMBER OF VERTICES IN PRESENT LIST TO BE REMOVED BY
C                  THE PLANE OF JATADD.
C          JELIM(I)= INDEX IN IPOLYH AND POLYHN OF A VERTEX TO BE
C          ELIMINATED FROM THE LIST. I=1,NELIM.
C
      JVMAX=4
      IATMIN=5
C
C          START CHECKING VERTICES AGAINST REST OF ATOMS IN BOX.
C
  495 DO 500 I=1,20
  500 JELIM(I)=0
      NELIM=0
      JVERT=1
C          CYCLE THRU ALL ATOMS IN BOX OR TO NEXT ATOM WITH PLANE THAT
C          ELIMINATES 1 OR MORE VERTICES.
      DO 560 JJ=1,NASPHR
C          SKIP ATOM IF IN VERTEX LIST OR PREVIOUSLY CHECKED.
      IF(VRTATM(JJ)) GO TO 560
C          LOAD PLANE FOR THIS ATOM
      DO 510 I=1,4
  510 PLN(I)=BOX(I+1,JJ)
      DD1 = 0.0
      DD2 = 0.0
C          CHECK EACH VERTEX AGAINST THIS PLANE
C
      DO 550 J=1,JVMAX
C          LOAD VERTEX
      DO 520 I=1,3
  520 P1(I)=POLYHN(I,J)
      IERROR(2,JLEVEL)=525
C          CHECK VERTEX
  525 SAME=SAMSID(PLN,AO,P1,DD1,DD2)
      IF(SAME) GO TO 530
      IF(JVERT.GT.20) GO TO 590
C          IDENTIFY VERTEX TO BE ELIMINATED
      JELIM(JVERT)=J
      JVERT=JVERT+1
  530 IF(J.NE.JVMAX) GO TO 550
      IF(JELIM(1).EQ.0) GO TO 555
C          IDENTIFY PLANE PROVIDING NEW VERTEX OR VERTICES.
      JATADD=JJ
C          FLAG JJ AS A TESTED ATOM
      VRTATM(JJ)=.TRUE.
      NELIM=JVERT-1
      GO TO 600
  550 CONTINUE
C          FLAG JJ AS A TESTED ATOM.
  555 VRTATM(JJ)=.TRUE.
  560 CONTINUE
C
C          IF NELIM=0 THERE ARE NO INTERSECTING PLANES AND NO VERTICES
C          TO BE ELIMINATED.
C
      GO TO 800
  590 IERROR(2,JLEVEL)=590
      IMSG=8
      CALL ERROR
      GO TO 2000
C
C          REMOVE AND ADD VERTICES AS INDICATED.
C
C          LOAD LINES(2,30) WITH ATOM PAIRS DERIVED FROM IPOLYH(I,J)
C          AT VERTICES J GIVEN BY CONTENTS OF JELIM.
C
  600 DO 660 J=1,NELIM
      JE=JELIM(J)
      J3=3*J
      J2=J3-1
      J1=J3-2
      IF(IPOLYH(1,JE).GT.IPOLYH(2,JE)) GO TO 610
      LINES(1,J1)=IPOLYH(1,JE)
      LINES(2,J1)=IPOLYH(2,JE)
      GO TO 620
  610 LINES(1,J1)=IPOLYH(2,JE)
      LINES(2,J1)=IPOLYH(1,JE)
  620 IF(IPOLYH(1,JE).GT.IPOLYH(3,JE)) GO TO 630
      LINES(1,J2)=IPOLYH(1,JE)
      LINES(2,J2)=IPOLYH(3,JE)
      GO TO 640
  630 LINES(1,J2)=IPOLYH(3,JE)
      LINES(2,J2)=IPOLYH(1,JE)
  640 IF(IPOLYH(2,JE).GT.IPOLYH(3,JE)) GO TO 650
      LINES(1,J3)=IPOLYH(2,JE)
      LINES(2,J3)=IPOLYH(3,JE)
      GO TO 660
  650 LINES(1,J3)=IPOLYH(3,JE)
      LINES(2,J3)=IPOLYH(2,JE)
  660 CONTINUE
C
C          CHECK EACH PAIR IN LINES(I=1-2,J) WITH REST OF ARRAY AHEAD
C          OF IT. IF ANY IDENTITY IS FOUND REPLACE THE PAIR JJ WITH
C          ZEROS. OTHERWISE COMPUTE NEW VERTEX.
C
C          JVMAX1 IDENTIFIES THE FIRST EMPTY SLOT IN POLYHN BEYOND BLOCK
C          OF VERTICES NOW LISTED AND BEFORE PRESENT ELIMINATION CYCLE.
      JVMAX1=JVMAX+1
      JE=1
      NELIM3=3*NELIM
      DO 710 JJ=1,NELIM3
C
C          HAS THE PAIR JJ BEEN MATCHED PREVIOUSLY.
C
      IF(LINES(1,JJ).EQ.0) GO TO 710
      JJ1=JJ+1
      IF(JJ1.GT.NELIM3) GO TO 680
      DO 670 I=JJ1,NELIM3
      IF(LINES(1,JJ).NE.LINES(1,I)) GO TO 670
      IF(LINES(2,JJ).NE.LINES(2,I)) GO TO 670
      LINES(1,I)=0
      LINES(2,I)=0
      GO TO 710
  670 CONTINUE
C
C          IF THE PROGRAM GETS THRU THE PREVIOUS STATEMENT THEN PAIR JJ
C          IS UNIQUE. PROCEED TO FORM NEW VERTEX WITH THIS LINE AND
C          PLANE ASSOCIATED WITH JATADD.
C
  680 IF(JE.GT.NELIM) GO TO 690
      JVERT=JELIM(JE)
      GO TO 700
  690 IF(JVERT.GE.JVMAX1) GO TO 695
      JVERT=JVMAX1
      GO TO 700
  695 JVERT=JVERT+1
  700 JE=JE+1
      JA=LINES(1,JJ)
      JB=LINES(2,JJ)
      IERROR(2,JLEVEL)=705
  705 CALL VERTEX(JA,JB,JATADD,JVERT)
      IF(ICHK.EQ.-1) GO TO 2000
  710 CONTINUE
      JVMAXC=JVMAX-NELIM+JE-1
C
C          ALL ENTRIES IN ILINES HAVE NOW BEEN CHECKED AND ALL VERTICES
C          REMOVED OR ADDED AS REQUIRED. IF NUMBER ADDED IS LESS THAN
C          NUMBER REMOVED THEN SOME ILLEGAL ENTRIES IN IPOLYH AND POLYHN
C          NEED TO BE REMOVED AND THE ARRAYS CONTRACTED.
C
  720 IF(JE.GT.NELIM) GO TO 770
C
C          JE IS INDEX IN JELIM(I) OF NEXT VERTEX TO BE ELIMINATED.
C
      JE1=JELIM(JE)
      JE=JE+1
      IF(JE.GT.NELIM) GO TO 735
      DO 730 J=JE,NELIM
      JE2=JELIM(J)
      DO 730 I=1,3
      IPOLYH(I,JE2)=0
  730 POLYHN(I,JE2)=0.0
C
C          CONTRACT ARRAYS IPOLYH AND POLYHN.
C
  735 J1=JE1+1
      DO 750 J=J1,JVMAX
      IF(IPOLYH(1,J).EQ.0) GO TO 750
      DO 740 I=1,3
      IPOLYH(I,JE1)=IPOLYH(I,J)
  740 POLYHN(I,JE1)=POLYHN(I,J)
      JE1=JE1+1
  750 CONTINUE
C
C          CLEAR HIGH ENDS OF CONTRACTED ARRAYS.
C
      DO 760 J=JE1,JVMAX
      DO 760 I=1,3
      IPOLYH(I,J)=0
  760 POLYHN(I,J)=0.0
C
C          RESET JVMAX TO LAST ENTRY IN NEW ARRAY.
C          GO BACK AND CHECK ATOM LIST IN BOX
C
  770 JVMAX=JVMAXC
C
      GO TO 495
  800 CONTINUE
C
C          SET VRTATM=.TRUE. FOR ALL ATOMS WHICH APPEAR
C          IN FINAL IPOLYH LIST.
C
      DO 900 J=1,100
  900 VRTATM(J)=.FALSE.
      DO 910 J=1,JVMAX
      DO 910 I=1,3
      JJ=IPOLYH(I,J)
  910 VRTATM(JJ)=.TRUE.
C
C          CHECK IF ANY OF VERTICES 97-100 ARE IN FINAL LIST . IF YES
C          RETURN ERROR
C
      DO 920 J=97,100
      IF(.NOT.VRTATM(J)) GO TO 920
      ICHK=-1
C
C		ERROR WRITE
C
      WRITE(3,5)
    5 FORMAT(' ONE OR MORE OF VERTICES 97-100 STILL IN POLYHN')
C
      GO TO 2000
  920 CONTINUE
C
 2000 JLEVEL=JLEVEL-1
C
      RETURN
      END
C
    	SUBROUTINE POLVOL(JVMAX)
C
C    		CALCULATES THE VOLUME OF THE IRREGULAR POLYHEDRON WHOSE
C          	VERTICES ARE LISTED IN THE ARRAYS IPOLYH AND POLYHN.
C
C		THE PROCEDURE DIVIDES EACH FACE OF THE POLYHEDRON INTO
C		TRIANGLES. COMPUTES THE VOLUME OF THE LITTLE TETRAHEDRON
C		FORMED BY EACH TRIANGLE AND THE CENTRAL ATOM AO. THEN SUMS
C		ALL THE TETRAHEDRAL VOLUMES TO GET THE VOLUME OF THE 
C		POLYHEDRON.
C
C          	FUNCTIONS OR SUBROUTINES CALLED: VOLTET
C
C	INCLUDE 'VOL.CMN'
#include "vol.cmn"
C
      	DIMENSION VERT(3,4),ITEMP(4,100)
C
      	EQUIVALENCE (TEMP(1,1),ITEMP(1,1))
C 
	VOLUME=0.0
C
C          	LOAD THE COMMON VERTEX AO INTO ARRAY VERT(I=1-3,1)
C
      DO 100 I=1,3
  100 VERT(I,1)=AO(I)
C
      DO 1000 NXTAT=1,100
C
C          	CHECK THAT THE ATOM TO BE USED IS IN THE VERTEX LIST.
C
      IF(.NOT.VRTATM(NXTAT)) GO TO 1000
C
C          	LOAD ITEMP WITH ALL VERTICES FROM IPOLYH CONTAINING NXTAT.
C
      JJ=1
      DO 200 J=1,JVMAX
      DO 180 I=1,3
      IF(IPOLYH(I,J).NE.NXTAT) GO TO 180
      ITEMP(1,JJ)=IPOLYH(1,J)
      ITEMP(2,JJ)=IPOLYH(2,J)
      ITEMP(3,JJ)=IPOLYH(3,J)
      ITEMP(4,JJ)=J
      JJ=JJ+1
      GO TO 200
  180 CONTINUE
  200 CONTINUE
      JN=JJ-1
      IF(JN.EQ.0) GO TO 1500
C
C          	ALL ENTRIES IN ITEMP(I,JJ) CONTAIN NXTAT IN LOCATIONS 1,2, OR
C          	3 FOR EACH VALUE OF JJ.
C          	JN=TOTAL NUMBER OF VERTICES LOADED INTO ITEMP.
C
C          	FIRST ENTRY IN ITEMP IS THE SECOND VERTEX FOR THIS ROUND
C          	OF CALCULATION
C
      ID2=ITEMP(4,1)
      DO 210 I=1,3
  210 VERT(I,2)=POLYHN(I,ID2)
C
C          	DETERMINE EITHER OF THE OTHER TWO ATOMS,=N2, IN FIRST ENTRY
C          	THAT IS NOT NXTAT.
C
      DO 220 I=1,3
      N2=ITEMP(I,1)
      IF(N2.NE.NXTAT) GO TO 240
  220 CONTINUE
C          	IDENTIFY THIRD VERTEX USING N2
  240 DO 250 J=2,JN
      J3= J
      DO 250 I=1,3
      IF(ITEMP(I,J).EQ.N2) GO TO 260
  250 CONTINUE
C          	LOAD THIRD VERTEX INTO VERT.
  260 ID3=ITEMP(4,J3)
      DO 270 I=1,3
  270 VERT(I,3)=POLYHN(I,ID3)
      NLAST=N2
      JNOW=J3
      IDNOW=ID3
      IX=1
C
C          	IDENTIFY ATOM WHICH IS NOT NXTAT OR NLAST IN VERTEX JNOW.
C
  300 DO 380 I=1,3
      NNOW=ITEMP(I,JNOW)
      IF(NNOW.EQ.NXTAT) GO TO 380
      IF(NNOW.EQ.NLAST) GO TO 380
      GO TO 400
  380 CONTINUE
C
C          	IDENTIFY VERTEX JNEXT USING NNOW.
C
  400 DO 450 J=2,JN
      JNEXT=J
      DO 450 I=1,3
      IF(ITEMP(I,J).NE.NNOW) GO TO 450
      IF(ITEMP(4,J).EQ.IDNOW) GO TO 450
      GO TO 460
  450 CONTINUE
C
C          	LOAD VERTEX JNEXT INTO ARRAY VERT.
C
  460 IDNEXT=ITEMP(4,JNEXT)
      JALT=3+MOD(IX,2)
      DO 470 I=1,3
  470 VERT(I,JALT)=POLYHN(I,IDNEXT)
C
C          	CALCULATE VOLUME OF THIS TETRAHEDRAL SEGMENT.
C
  660 VOLI=VOLTET(VERT)
      VOLUME=VOLUME+VOLI
      IF((IX+2).EQ.JN) GO TO 1000
      NLAST=NNOW
      JNOW=JNEXT
      IDNOW=IDNEXT
      IX=IX+1
      GO TO 300
 1000 CONTINUE
      GO TO 2000
C
C		ERROR WRITE
C
 1500 WRITE(3,6)
    6 FORMAT(' ERROR IN VRTATM OR IPOLYH SUPPLIED TO POLVOL')
 2000 RETURN
      END
C
C
C
	SUBROUTINE VERTEX(JA,JB,JC,JVERT)
C
C		TAKES THE TETRAHEDRON FORMED BY THE ATOM AO AND THE THREE
C		ATOMS IN BOX(I,J) NUMBERED J=JA,JB,JC. COMPUTES THE
C		INTERSECTION OF THE 3 PLANES BETWEEN JA,JB,JC,AND AO.
C		THIS VERTEX IS STORED IN THE ARRAY POLYHN(I,JVERT).
C		I=1-3=XYZ, I=4-6=JA,JB,JC. JVERT=SERIAL NUMBER OF CALCULATED
C		VERTEX.
C
C		FUNCTIONS OR SUBROUTINES USED: POINT
C
C	INCLUDE 'VOL.CMN'
#include "vol.cmn"
C
C	INCLUDE 'TEST.CMN'
#include "test.cmn"
C
	DIMENSION PLANES(4,3),P(3)
C
C		INITIALIZE ERROR VARIABLES
C
80 	JLEVEL=JLEVEL+1
      	DO 90 J=JLEVEL,5
      	DO 90 I=1,2
90 	IERROR(I,J)=0
      	IERROR(1,JLEVEL)=14
C
C          	LOAD ARRAY PLANES(I,J) WITH DATA FROM THE ARRAY BOX
C          	CONCERNING AO AND THE ATOMS IDENTIFIED BY JA,JB,JC.
C
      	DO 100 I=1,4
      	PLANES(I,1)=BOX(I+1,JA)
      	PLANES(I,2)=BOX(I+1,JB)
100 	PLANES(I,3)=BOX(I+1,JC)
C
C          	CALCULATE THE INTERSECTION OF PLANES
C
1450 	IERROR(2,JLEVEL)=1450
      	CALL POINT(PLANES,P)
      	IF(ICHK) 1455,1510,1510
1455 	WRITE(3,1)
1	FORMAT(' ERROR IN POINT.VERTEX INDETERMINATE.RETURN TO ATVOL',/)
      	GO TO 1610
C
1510 	DO 1520 I=1,3
1520 	POLYHN(I,JVERT)=P(I)
      	IPOLYH(1,JVERT)=JA
      	IPOLYH(2,JVERT)=JB
      	IPOLYH(3,JVERT)=JC
1610 	JLEVEL=JLEVEL-1
5000 	RETURN
      	END
C
C
C
C
C
      	LOGICAL FUNCTION INSIDE(A,B,P)
C
C          	IS POINT P INSIDE THE TETRAHEDRON FORMED BY THE PLANES OF
C          	ARRAY A ? : YES = TRUE  ,  NO = FALSE
C          	ARRAY A(1-3,J)=DIRECTION COMPONENTS (NX,NY,NZ) OF PLANE J,
C          	A(4,J)= D= CONSTANT TERM FOR PLANE J. NX*X +NY*Y +NZ*Z +D =0
C          	ARRAY B(1-3,J)= XYZ COMPONENTS OF VERTEX J OPPOSITE PLANE J
C
C          	IF 'SAMSID' SETS ICHK=1,'INSIDE' IS SET EQUAL TO .FALSE.
C          	EVENTHOUGH ALL 4 'SAMSID CHECKS RETURNED .TRUE.
C
C          	FUNCTIONS OR SUBROUTINES CALLED : SAMSID
C
C	INCLUDE 'TEST.CMN'
#include "test.cmn"
C
      	DIMENSION A(4,4),B(3,4),P(3),P2(3),TEST(4),PLANE1(4)
      	LOGICAL TEST,SAMSID
C
      	IMSG=0
      	DO 300 J=1,4
      	DO 100 I=1,4
  100 	PLANE1(I)=A(I,J)
  120 	DO 200 I=1,3
  200 	P2(I)=B(I,J)
      	DD1 = 0.0
      	DD2 = 0.0
      	TEST(J)=SAMSID(PLANE1,P,P2,DD1,DD2)
      	IF(ICHK.EQ.1) IMSG=1
  300 	CONTINUE
      	DO 350 I=1,4
      	IF(.NOT.TEST(I)) GO TO 400
  350 	CONTINUE
      	IF(IMSG.EQ.1) GO TO 400
      	INSIDE=.TRUE.
      	RETURN
  400 	INSIDE=.FALSE.
      	RETURN
      	END
C
C
C
C
C
      	LOGICAL FUNCTION SAMSID(PLANE1,P1,P2,DD1,DD2)
C
C          	DETERMINES WHETHER POINTS P1 AND P2 ARE ON SAME SIDE OF A
C          	GIVEN PLANE,'PLANE1'.   YES=.TRUE. , NO=.FALSE.
C          	PLANE1(1-3)= DIRECTION COMPONENTS OF PLANE NORMAL
C          	PLANE1(4)= CONSTANT TERM
C          	P1(1-3),P2(1-3) ARE THE XYZ COORDINATES OF THE TWO POINTS
C
C          	NOTE THAT IF ONE OF THE POINTS TESTED BY SAMSID IS IN THE
C          	PLANE, THE RESULT IS INDETERMINATE.THE FUNCTION IS SET
C          	EQUAL TO .TRUE. AND ICHK IS SET EQUAL TO 1. NORMALLY ICHK=0
C
C          	FUNCTIONS OR SUBROUTINES CALLED : NONE
C
C	INCLUDE 'TEST.CMN'
#include "test.cmn"
C
      	DIMENSION PLANE1(4),P1(3),P2(3)
C
      	ICHK=0
C
      	D1=0.0
      	D2=0.0
C
C          	CALCULATE CONSTANT TERM FOR PLANES PARALLEL TO PLANE BUT
C          	PASSING THROUGH P1 AND P2
C
      	DO 100 I = 1,3
  100 	D1 = D1-PLANE1 (I) * P1(I)
      	DD1 = PLANE1(4) -D1
  140 	DO 150 I = 1,3
  150 	D2 = D2-PLANE1(I)*P2(I)
      	DD2 = PLANE1(4)-D2
C
C          	TEST CONSTANTS AGAINST THAT OF PLANE
C
      	DD1SQ = DD1 * DD1
      	DD2SQ = DD2 * DD2
      	IF (DD1SQ .LT. 0.0001) GO TO 300
      	IF (DD2SQ .LT. 0.0001) GO TO 300
      	IF(DD1*DD2) 200,300,400
  200 	SAMSID=.FALSE.
      	RETURN
C
  300 	ICHK=1
  400 	SAMSID=.TRUE.
      	RETURN
C
      	END
C
C
C
C
C
C
C
C
C
C
C
      FUNCTION VOLTET (A)
C
C          RETURNS THE VOLUME OF THE TETRAHEDRON DEFINED BY THE VERTICES
C          GIVEN IN THE ARRAY A(3,4).  A(I=1,3,J) ARE THE X,Y,Z
C          COORDINATES OF THE POINT J.
C
C          FUNCTIONS OR SUBROUTINES CALLED: DET3C
C
      DIMENSION A(3,4)
C
      CALL DET3C(A,B1,B2,B3,B4)
      VOLTET= ABS((-B1+B2-B3+B4)/6.)
      RETURN
      END
C
C
C
C
      SUBROUTINE PLANE (P1,P2,P3,PLN)
C
C          SUBROUTINE RETURNS THE EQUATION OF THE PLANE PLN(1-4)=
C          (NX,NY,NZ,CONST) DETERMINED BY THE THREE POINTS P1,P2,P3.
C          IF THE THREE POINTS ARE COLINEAR THE PLANE IS INDETERMINATE
C          AND ICHK IS SET EQUAL TO-1. FOR NORMAL RETURN ICHK=0.
C
C          FUNCTIONS OR SUBROUTINES CALLED DET3R,ERROR
C
C	INCLUDE 'TEST.CMN'
#include "test.cmn"

C
      DIMENSION A(4,3),P1(3),P2(3),P3(3),PLN(4)
C
C          INITIALIZE ERROR VARIABLES
C
      JLEVEL=JLEVEL+1
      DO 90 J=JLEVEL,5
      DO 90 I=1,2
   90 IERROR(I,J)=0
      IERROR(1,JLEVEL)=9
      ICHK=0
C
C          LOAD ARRAY A(4,3)
C
      DO 100 I=1,3
      A(I,1)=P1(I)
      A(I,2)=P2(I)
  100 A(I,3)=P3(I)
      DO 200 J=1,3
  200 A(4,J)=1.0
C
      CALL DET3R(A,B1,B2,B3,B4)
      PLN(1)=B1
      PLN(2)=-B2
      PLN(3)=B3
      PLN(4)=-B4
C
      IMSG=3
      IERROR(2,JLEVEL)=250
  250 IF(PLN(1).NE.0) GO TO 300
      IF(PLN(2).NE.0) GO TO 300
      IF(PLN(3).NE.0) GO TO 300
  260 CALL ERROR
      ICHK=-1
      WRITE(3,2)
    2 FORMAT(/,6X,'X',12X,'Y',12X,'Z',/)
      WRITE(3,3)(P1(I),I=1,3)
      WRITE(3,3)(P2(I),I=1,3)
      WRITE(3,3)(P3(I),I=1,3)
    3 FORMAT(3F12.6)
C
  300 JLEVEL=JLEVEL-1
      RETURN
      END
C
C
C
C
C
      SUBROUTINE POINT (PLANES,P)
C
C          PLANES IS A 4X3 ARRAY REPRESENTING EQUATIONS OF 3 PLANES.
C          THE SUBROUTINE CALCULATES THEIR POINT OF INTERSECTION P.
C          PLANES(1-3,J)= DIRECTION COMPONENTS OF PLANE J,
C          PLANE(4,J)= CONSTANT TERM OF PLANE J.
C          THE VALUE OF ICHK = 0 IF THE PLANES HAVE A POINT OF
C          INTERSECTION, ICHK=-1 IF NO POINT OF INTERSECTION (I.E.
C          PLANES ARE PARALLEL, INTERSECT IN A LINE, OR INTERSECT IN
C          3 LINES IN PAIRS)
C
C          FUNCTIONS OR SUBROUTINES CALLED DET3R , ERROR
C
C	INCLUDE 'TEST.CMN'
#include "test.cmn"
C
      DIMENSION PLANES(4,3), P(3)
C
C          INITIALIZE ERROR VARIABLES
C
      JLEVEL=JLEVEL+1
      DO 90 J=JLEVEL,5
      DO 90 I=1,2
   90 IERROR(I,J)=0
      IERROR(1,JLEVEL)=8
      ICHK=0
C
      CALL DET3R(PLANES,B1,B2,B3,B4)
      IF(B4.NE.0) GO TO 100
C
      IMSG=4
      IERROR(2,JLEVEL)=50
   50 CALL ERROR
      ICHK=-1
      WRITE(3,2)
    2 FORMAT(6X,'NX',12X,'NY',12X,'NZ',12X,'D',/)
      DO 60 J=1,3
      WRITE(3,3)(PLANES(I,J),I=1,4)
    3 FORMAT(4F12.6)
   60 CONTINUE
      GO TO 1000
  100 P(1)=-B1/B4
      P(2)=B2/B4
      P(3)=-B3/B4
 1000 JLEVEL=JLEVEL-1
      RETURN
      END
C
C
C
C
C
      SUBROUTINE CENTRD(TETRON, CGT)
C
C          DETERMINES THE CENTROID OF THE TETRAHEDRON
C          TETRON(I=XYZ,J=1-4) AND RETURNS THE CENTROID CGT(I=XYZ)).
C
C          FUNCTIONS OR SUBROUTINES USED:  NONE
C
      DIMENSION TETRON(3,4),CGT(3)
C
      DO 100 I=1,3
  100 CGT(I)=0.0
      DO 300 I=1,3
      DO 200 J=1,4
  200 CGT(I)=CGT(I)+TETRON(I,J)
  300 CGT(I)=CGT(I)/4.0
C
      RETURN
      END
C
C
C
C
C
C
C
      SUBROUTINE DET3C(A,B1,B2,B3,B4)
C
C          A IS A 3X4 ARRAY. B1 IS THE VALUE OF THE DETERMINANT
C          COMPOSED OF COLUMNS 2,3,4; B2 OF COLUMNS 1,3,4; B3 OF COLUMNS
C          1,2,4; B4 OF COLUMNS 1,2,3.
C
C          FUNCTIONS OR SUBROUTINES CALLED:  NONE
C
      DIMENSION A(3,4)
	do  10   j = 1, 4
 	do  10   i = 1, 3
		if  (A(i,j).GT.0.AND.A(i,j)*10000.LT.0.00001) A(i,j) = 0.0
10    continue
C
      A12=A(2,1)*A(3,2)-A(2,2)*A(3,1)
      A13=A(2,1)*A(3,3)-A(2,3)*A(3,1)
      A14=A(2,1)*A(3,4)-A(2,4)*A(3,1)
      A23=A(2,2)*A(3,3)-A(2,3)*A(3,2)
      A24=A(2,2)*A(3,4)-A(2,4)*A(3,2)
      A34=A(2,3)*A(3,4)-A(2,4)*A(3,3)
      B1=A23*A(1,4)-A24*A(1,3)+A34*A(1,2)
      B2=A13*A(1,4)-A14*A(1,3)+A34*A(1,1)
      B3=A12*A(1,4)-A14*A(1,2)+A24*A(1,1)
      B4=A12*A(1,3)-A13*A(1,2)+A23*A(1,1)
      RETURN
      END
C
C
C
C
C
      SUBROUTINE DET3R(A,B1,B2,B3,B4)
C
C          A IS A 4X3 ARRAY. B1 IS THE VALUE OF THE DETERMINANT
C          COMPOSED OF ROWS 2,3,4; B2 OF ROWS 1,3,4; B3 OF ROWS 1,2,4;
C          B4 OF ROWS 1,2,3.
C
C          FUNCTIONS OR SUBROUTINES CALLED:  NONE
C
      DIMENSION A(4,3)
	do  10   j = 1, 3
 	do  10   i = 1, 4
		if (A(i,j).GT.0.AND.A(i,j)*10000.LT.0.00001) A(i,j) = 0.0
10    continue
C
      A12=A(1,1)*A(2,2)-A(2,1)*A(1,2)
      A13=A(1,1)*A(3,2)-A(3,1)*A(1,2)
      A14=A(1,1)*A(4,2)-A(4,1)*A(1,2)
      A23=A(2,1)*A(3,2)-A(3,1)*A(2,2)
      A24=A(2,1)*A(4,2)-A(4,1)*A(2,2)
      A34=A(3,1)*A(4,2)-A(4,1)*A(3,2)
      B1=A23*A(4,3)-A24*A(3,3)+A34*A(2,3)
      B2=A13*A(4,3)-A14*A(3,3)+A34*A(1,3)
      B3=A12*A(4,3)-A14*A(2,3)+A24*A(1,3)
      B4=A12*A(3,3)-A13*A(2,3)+A23*A(1,3)
      RETURN
      END
C

