program makedb
C
C  Create binary seqence file for the PDBsearch program
C
C  Input:  PDBLIST (create with DCL directory command)
C  Intermediate:  PDB.SEQRES (deleted)
C  Output:  PDBSEQ
C
C  v 1.1   13-Dec-1987
C
C  Dan Bloch
C  Molecular Biology Dept.   MB13
C  Research Institute of Scripps Clinic
C  La Jolla, CA  92037
C
	implicit none
	integer len
	character*80 filename
	character*4 protein,newprot
	character*1 chain,newchain
	character*3 tlc(13)
	character*1 olc(2000)
	integer i,n
	logical tlc2olc,bad_residues,good_residues
C
C  (1) Extract SEQRES records
C
	open(1,status='old',name='pdblist',shared,readonly)
	open(2,status='scratch',name='pdb.seqres',carriagecontrol='list')

	do while (.true.)
	   read(1,210,end=300)len,filename
210	   format (q,a)
	   call extract(filename(1:len))
	enddo

300	write (*,310)
310	format (' SEQRES records extracted')
C
C  (2) Convert to one-letter code, make binary sequence file
C
	rewind 2
	open(3,status='new',name='pdbseq',form='unformatted')

	read (2,410) newchain,tlc,newprot
410	format(11x,a1,7x,13(a3,1x),1x,a4)

	do while (.true.)
425	   protein=newprot
	   chain=newchain
	   bad_residues = .false.
	   good_residues = .false.
	   n=0
	   do while (protein.eq.newprot .and. chain.eq.newchain)
	      do i=1,13
		 if (tlc(i).ne.'   ') then
		    n=n+1
		    if (tlc2olc(tlc(i),olc(n))) then
		       good_residues = .true.
		    else
		       if(tlc(i).eq.'  A'.or.tlc(i).eq.'  T'.or.
	1		  tlc(i).eq.'  U'.or.tlc(i).eq.'  C'.or.
	2		  tlc(i).eq.'  G') goto 450
		       call pack(tlc(i))
		       if (.not. bad_residues)	then		! first bad res
			  bad_residues = .true.
			  write (*,*) protein,' ',chain
		       endif
		    endif
		 endif
	      enddo
	      read (2,410,end=888) newchain,tlc,newprot
	   enddo
	   if (good_residues) write (3) protein,chain,n,(olc(i),i=1,n)
	   if (bad_residues) call dump
	enddo

C Here on nucleic acid
C
450	if (.not.bad_residues) then
	   write(*,*) protein
	   write(*,460)
460	   format('  Nucleic Acid')
	else		! if already found some non-CGATU nucleic acid
	   write(*,460)
	   call zero
	endif

	do while (protein.eq.newprot)
	   read (2,410,end=999) newchain,tlc,newprot
	enddo
	goto 425

C Here on end of file
C
888	if (good_residues) write (3) protein,chain,n,(olc(i),i=1,n)
	if (bad_residues) call dump

999	write (*,*) 'makedb complete'
	end
C----------------------------------------------------------------------------
	subroutine extract(filename)
C
C  Extract SEQRES records from PDB file
C
	implicit none
	character*(*) filename
	character*80 line
C
	open(11,status='old',shared,readonly,name=filename)

	line=' '
	do while (line(1:6).ne.'SEQRES')
	   read(11,10,end=99)line
10	   format (a80)
	enddo

	do while (line(1:6).eq.'SEQRES')
	   write(2,10)line
	   read(11,10)line
	enddo

99	close(11)
	return
	end
C----------------------------------------------------------------------------
	subroutine pack(code)
C
C  Type out codes, 20 to a line.
C
	character*3 code,codes(20)
	integer ncodes /0/

	if (ncodes .eq. 20) then
	   write (*,10) codes
10	   format (x,20(x,a3))
	   ncodes=0
	endif

	ncodes=ncodes+1
	codes(ncodes)=code
	return
C------------------------------
	entry dump	!  Type out any codes in buffer and empty it
C
	write (*,10) (codes(i) ,i=1,ncodes)
C
	entry zero	!  Empty buffer without typing it out
C
	ncodes=0
	return

	end
C----------------------------------------------------------------------------
	logical function tlc2olc(tlc,olc)
C
C  Convert a three-letter amino acid code to a one-letter code.
C  Return false if bad residue.
C
	implicit none
	character*3 tlc
	character*1 olc

	tlc2olc = .true.

	if (tlc .eq. 'ALA') then
	   olc='A'
	else if (tlc .eq. 'ASN') then
	   olc='N'
	else if (tlc .eq. 'ASP') then
	   olc='D'
	else if (tlc .eq. 'ASX') then
	   olc='B'
	else if (tlc .eq. 'ARG') then
	   olc='R'
	else if (tlc .eq. 'CYS') then
	   olc='C'
	else if (tlc .eq. 'GLN') then
	   olc='Q'
	else if (tlc .eq. 'GLU') then
	   olc='E'
	else if (tlc .eq. 'GLX') then
	   olc='Z'
	else if (tlc .eq. 'GLY') then
	   olc='G'
	else if (tlc .eq. 'HIS') then
	   olc='H'
	else if (tlc .eq. 'ILE') then
	   olc='I'
	else if (tlc .eq. 'LEU') then
	   olc='L'
	else if (tlc .eq. 'LYS') then
	   olc='K'
	else if (tlc .eq. 'MET') then
	   olc='M'
	else if (tlc .eq. 'PHE') then
	   olc='F'
	else if (tlc .eq. 'PRO') then
	   olc='P'
	else if (tlc .eq. 'SER') then
	   olc='S'
	else if (tlc .eq. 'THR') then
	   olc='T'
	else if (tlc .eq. 'TRP') then
	   olc='W'
	else if (tlc .eq. 'TYR') then
	   olc='Y'
	else if (tlc .eq. 'VAL') then
	   olc='V'
	else if (tlc .eq. 'UNK') then
	   olc='X'
	else
	   tlc2olc = .false.
	   olc='*'
	endif

	return
	end