C   ANALS89 SUBROUTINES FOR NIP
C   AUTHOR: RODGER STADEN
C  11-8-92 Fixed bug in x version: use of gtstr and opratr='all' when
C          using feature tables: xversion returns default, fortran returns
C          lin=0: now check for both.
C  29-7-92 Added routines for finding repeated words
C   6-8-92 trna: previously did not allow for case in conserved base check
C   29-5-92 set max open reading frame to idim/3 in opentr
C   27-5-92 trnad made max intron length default = min intron length (was 0)
C   21-5-92 fixed bug in restriction enzyme search: if 4 cutter file was 
C   selected it always got listed!
C   16-4-92 fixed bug in find inverted repeats: the second position was out!
C   8-1-90
C   Changed all kstran to jstran
C   Changed all mstran to jstran
C   Replaced calls codid1 by trand1 and deleted codid1
C   Added clos(unit=ideve) to tran3,codimp
C   Changed format statement in trpiro to produce embl ft output
C   26-3-90 TRNA changed it to allow intron lengths from 0 to N (previously
C   by mistake, had to be M to N where M is non zero).
C   29-3-90 Minor change to CODTDK call to CODTBO was erroneously sent ANST
C   not ANSTO. Now sent ANSTO.
C   2-4-90 Major change to codtdk: normalised data not written to disk!
C   3-5-90 Minor change to inverted repeat search for case when a pallindrome
C          is found: stop the subtraction of 2 from position for listed
C          results by making intx1=intx2
C   9-7-90 Removed menu routine
C   21-8-90 Changed getpar for option 39 to use completely new routines
C           Changed TRPIRP and TRPIR and their callers
C   5-11-90 Changed calls to rdwmt to include flag for show/not show title
C   7-11-90 Huge number of changes to replace radio by radion, including
C           writing new routine gstrnd. This has increased the returned 
C           value of the choice flag by 1 and so is a potential source
C           of minor cockup
C  21-12-90 Changed weight matrix searches so that text output gives position
C           as middle + i (was i)
C  11-1-91  Greatly modified positional base preferences method adding 
C           facility to read codon table from disk.
C  19-2-91  Modified s2 to accomodate longer restriction enzyme recognition 
C           seqs, and moved a write statement from findl4, findl5 to s2.
C           For output from s2 names are now limited to 15 chars 
C           recognition seqs to 35 chars.
C  22-2-91  trpir had forgotten to reverse translations from the complementary
C           strand. Added call to sqrev.
C  11-4-91 modified trand7 to make 6 phase translation more obvious
C  18-4-91  Replaced splice search and changed setpar
C  23-4-91  Minor change to trand8 to allow both strands
C           New routines: trnpir, trndop, trndom, openfr, trndp, trndm,
C           wpair, pstop, mstop, minil. For translating open frames to disk
C           and finding open frames
C 11-6-91 Following routines replaced or added.Changes relating to new fts
C 24-2-92 Bracketed the factor of -1 in MBPRIM
C 2-3-92    set   FILNAM = ' ' for all openf1 calls
C      SUBROUTINE OPENTR(SEQ,IDIM,KSTART,IDEV,KBIN,KBOUT,PAA,
C      SUBROUTINE TRANEM(SEQ,IDIM,J1,J2,FRAMEC,
C      SUBROUTINE TRAND8(IDIM,J1,J2,KSTRAN,IP1,IP2,PROMPT,
C      SUBROUTINE TRAND7(KBIN,KBOUT,I1,I2,
C      SUBROUTINE EMBLF(IDEVE,FILNAM,
C      SUBROUTINE TRAND9(KBIN,KBOUT,IDEVE,FILNAM,OPRATR,
C      SUBROUTINE TRANEN(SEQ,IDIM,J1,J2,FRAMEC,JSTRAN,IDEVE,
C      SUBROUTINE TRAND1(JSTRAN,ANSE,IDEVE,FILNAM,
C      SUBROUTINE TRANDK(SEQ1,IDIM1,OUTP1,IDIMP,ISTART,ISTOP,IDIMT,
C      SUBROUTINE TRNEMB(SEQ,IDIM,J1,J2,SEQW,PAA,JSTRAN,IDEVE,IDEV,
C      SUBROUTINE CODTDK(SEQ,IDIM,J1,J2,IDEVE,FILNAM,KBIN,KBOUT,
C      SUBROUTINE CODND1(JSTRAN,NORM,ANSE,IDEVE,FILNAM,OPRATR,
C      SUBROUTINE CTDEMB(SEQ,IDIM,J1,J2,SEQW,PAA,JSTRAN,IDEVE,
C      SUBROUTINE CODEMB(SEQ,IDIM,J1,J2,SEQW,PAA,JSTRAN,IDEVE,IDEV,
C      SUBROUTINE CODONS(SEQ,IDIM,J1,J2,IDEV,IDEVE,FILNAM,KBIN,KBOUT,
C      SUBROUTINE CODIMP(SEQ,IDIM,FTABLE,IDFTAB,IDEVE,FILNAM,
C      SUBROUTINE CDIEMB(SEQ,IDIM,J1,J2,SEQW,JSTRAN,IDEVE,IDEV,
C      SUBROUTINE PLTEMB(JSTRAN,IDEVE,
C      SUBROUTINE PLTMAQ(IDEV,FILNAM,POSNS,MAXPOS,
C      SUBROUTINE PLTBAR(POSNL,POSNR,YF,YF,BLIPB,BLIPT,
C      SUBROUTINE MBPRIM(FRAMEC,IDIMS,J1,J2,PRIME)
C 17-7-91 trndom replced line to write out title! which had disapeared
      SUBROUTINE GETPAR(IOPT,NPAM,IOK,
     +I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,
     +I11,I12,I13,I14,I15,I16,I17,I18,I19,I20,
     +I21,I22,I23,I24,I25,I26,I27,I28,I29,I30,
     +I31,I32,I33,I34,I35)
      PARAMETER (MINOPT = 17,
     +           MAXOPT = 68,
     +           NUMBER = 35)
      INTEGER VALUES(NUMBER,MINOPT:MAXOPT)
      COMMON /PAMDEF/VALUES
      IOK = 0
      IF((IOPT.GE.MINOPT).AND.(IOPT.LE.MAXOPT)) THEN
        I = 1
        I1 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I2 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I3 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I4 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I5 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I6 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I7 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I8 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I9 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I10 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I11 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I12 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I13 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I14 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I15 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I16 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I17 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I18 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I19 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I20 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I21 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I22 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I23 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I24 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I25 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I26 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I27 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I28 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I29 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I30 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I31 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I32 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I33 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I34 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
        I = I + 1
        I35 = VALUES(I,IOPT)
        IF(I.EQ.NPAM) RETURN
      END IF
      IOK = 1
      END
      SUBROUTINE SETPAR(IOK)
      PARAMETER (MINOPT = 17,
     +           MAXOPT = 68,
     +           NUMBER = 35)
      INTEGER VALUES(NUMBER,MINOPT:MAXOPT)
C      INTEGER TEMP(NUMBER)
      COMMON /PAMDEF/VALUES
      SAVE /PAMDEF/
      IOK = 0
C  SEARCH
C      CALL GETPAR(17,14,IOK,
C     +MINLEN,MAXLEN,LINLEN,MNCUT,MAXCUT,MINCUT,
C     +OPTION,OPTOUT,IFILE,JTRAN,ITRAN,IROUND,IDEF)
      VALUES(1,17) = 10
      VALUES(2,17) = 100
      VALUES(3,17) = 60
      VALUES(4,17) = 0
      VALUES(5,17) = 100
      VALUES(6,17) = 0
      VALUES(7,17) = 0
      VALUES(8,17) = 0
      VALUES(9,17) = 2
      VALUES(10,17) = 0
      VALUES(11,17) = 0
      VALUES(12,17) = 0
      VALUES(13,17) = 0
C  PERCENT MATCH
      VALUES(1,18) = 0
      VALUES(2,18) = 70
C  SCORE MATRIX MATCH
      VALUES(1,19) = 0
C  WEIGHT MATRIX
      VALUES(1,20) = 0
C      WRITE(KBOUT,*)' CALCULATE CODON USAGE, BASE COMPOSITION'
C      WRITE(KBOUT,*)' AND AMINO ACID COMPOSITION'
C      CALL GETPAR(23,3,IOK,JSTRAN,NORM,ANSE)
      VALUES(1,23) = 0
      VALUES(2,23) = 0
      VALUES(3,23) = 0
C
C  PLOT BASE COMPOSITION
C
C      CALL GETPAR(24,10,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
C     +SCORES(1),SCORES(2),SCORES(3),SCORES(4))
C
      VALUES(1,24) = 1
      VALUES(2,24) = 201
      VALUES(3,24) = 31
      VALUES(4,24) = 1
      VALUES(5,24) = 11
      VALUES(6,24) = 5
      VALUES(7,24) = 1
      VALUES(8,24) = 0
      VALUES(9,24) = 1
      VALUES(10,24) = 0
C      WRITE(KBOUT,*)' PLOT BASE COMPOSITION DIFFERENCES AS CHI SQUARED'
C      CALL GETPAR(25,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT)
      VALUES(1,25) = 11
      VALUES(2,25) = 301
      VALUES(3,25) = 33
      VALUES(4,25) = 1
      VALUES(5,25) = 21
      VALUES(6,25) = 5
C      WRITE(KBOUT,*)' PLOT DI COMPOSITION DIFFERENCES AS CHI SQUARED'
C      CALL GETPAR(26,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT)
      VALUES(1,26) = 11
      VALUES(2,26) = 301
      VALUES(3,26) = 33
      VALUES(4,26) = 1
      VALUES(5,26) = 21
      VALUES(6,26) = 5
C      WRITE(KBOUT,*)' PLOT TRI COMPOSITION DIFFERENCES AS CHI SQUARED'
C      CALL GETPAR(27,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT)
      VALUES(1,27) = 11
      VALUES(2,27) = 301
      VALUES(3,27) = 33
      VALUES(4,27) = 1
      VALUES(5,27) = 21
      VALUES(6,27) = 5
C      WRITE(KBOUT,*)' CALCULATE CODON IMPROBABILITY'
C      CALL GETPAR(28,2,IOK,JSTRAN,ANSE)
      VALUES(1,28) = 0
      VALUES(2,28) = 0
C      WRITE(KBOUT,*)' SEARCH FOR HAIRPIN LOOPS'
C      CALL GETPAR(30,10,IOK,MINLPI,MAXLPI,MINLP,
C     +MINLPX,MAXLPX,MAXLP,MINBP,MAXBP,MININ,IGON)
      VALUES(1,30) = 1
      VALUES(2,30) = 30
      VALUES(3,30) = 1
      VALUES(4,30) = 3
      VALUES(5,30) = 120
      VALUES(6,30) = 3
      VALUES(7,30) = 2
      VALUES(8,30) = 20
      VALUES(9,30) = 6
      VALUES(10,30) = 0
C      WRITE(KBOUT,*)' PLOT INVERTED REPEATS'
C      CALL GETPAR(31,4,IOK,MINRP,MAXRP,MINREP,IGON)
      VALUES(1,31) = 6
      VALUES(2,31) = 30
      VALUES(3,31) = 12
      VALUES(4,31) = 0
C      WRITE(KBOUT,*)' PLOT REPEATS'
C      CALL GETPAR(32,4,IOK,MINRP,MAXRP,MINREP,IGON)
      VALUES(1,32) = 6
      VALUES(2,32) = 30
      VALUES(3,32) = 12
      VALUES(4,32) = 0
C      WRITE(KBOUT,*)' PLOT Z DNA POTENTIAL '
C      CALL GETPAR(33,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT)
      VALUES(1,33) = 3
      VALUES(2,33) = 33
      VALUES(3,33) = 15
      VALUES(4,33) = 1
      VALUES(5,33) = 21
      VALUES(6,33) = 3
C      WRITE(KBOUT,*)' PLOT Z DNA POTENTIAL '
C      CALL GETPAR(34,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT)
      VALUES(1,34) = 3
      VALUES(2,34) = 33
      VALUES(3,34) = 21
      VALUES(4,34) = 1
      VALUES(5,34) = 11
      VALUES(6,34) = 1
C      WRITE(KBOUT,*)' PLOT Z DNA POTENTIAL '
C      CALL GETPAR(35,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT)
      VALUES(1,35) = 5
      VALUES(2,35) = 33
      VALUES(3,35) = 15
      VALUES(4,35) = 1
      VALUES(5,35) = 21
      VALUES(6,35) = 1
C      WRITE(KBOUT,*)' SEARCH FOR LOCAL SIMILARITY OR COMPLEMENTARITY'
C      CALL GETPAR(36,15,IOK,MINSP,MAXSP,SPAN,MINPR,MAXPR,IPR,
C     +MNIR1,MXIR1,IRAN1,MNIR2,MXIR2,IRAN2,
C     +ANSRV,ANSC,IGON)
      VALUES(1,36) = 5
      VALUES(2,36) = 200
      VALUES(3,36) = 15
      VALUES(4,36) = 5
      VALUES(5,36) = 100
      VALUES(6,36) = 70
      VALUES(7,36) = 1
      VALUES(8,36) = 50
      VALUES(9,36) = 1
      VALUES(10,36) = 1
      VALUES(11,36) = 50
      VALUES(12,36) = 1
      VALUES(13,36) = 0
      VALUES(14,36) = 0
      VALUES(15,36) = 0
C      WRITE(KBOUT,*)' LIST TRANSLATION (UP TO 3 PHASES)'
C      CALL GETPAR(38,6,IOK,MINLEN,MAXLEN,LINLEN,JSTRAN,ANSE,ITRAN)
      VALUES(1,38) = 30
      VALUES(2,38) = 120
      VALUES(3,38) = 60
      VALUES(4,38) = 0
      VALUES(5,38) = 0
      VALUES(6,38) = 0
C      WRITE(KBOUT,*)' TRANSLATE IN SIX PHASES'
C      CALL GETPAR(39,11,IOK,MINLEN,MAXLEN,LINLEN,ITRAN,
C     CALL GETPAR(39,10,IOK,MINO,MINOPN,JSTRAN,
C     MINLEN,MAXLEN,LINLEN,ITRAN,JTRAN,INUM,ANSE,
      VALUES(1,39) = 0
      VALUES(2,39) = 30
      VALUES(3,39) = 0
      VALUES(4,39) = 30
      VALUES(5,39) = 120
      VALUES(6,39) = 60
      VALUES(7,39) = 0
      VALUES(8,39) = 0
      VALUES(9,39) = 0
      VALUES(10,39) = 3
C      WRITE(KBOUT,*)' TRANSLATION AND WRITE PROTEIN SEQUENCE TO DISK'
C      CALL GETPAR(40,7,IOK,JSTRAN,ANSE,IOPEN,MINO,MAXO,MINOPN,JSTRAN)
      VALUES(1,40) = 0
      VALUES(2,40) = 0
      VALUES(3,40) = 0
      VALUES(4,40) = 5
      VALUES(5,40) = 1000
      VALUES(6,40) = 30
      VALUES(7,40) = 0
C      WRITE(KBOUT,*)' CALCULATE AND WRITE CODON TABLE TO DISK'
C      CALL GETPAR(41,5,IOK,JSTRAN,NORM,ANSE,ANST,ANSTO)
      VALUES(1,41) = 0
      VALUES(2,41) = 0
      VALUES(3,41) = 0
      VALUES(4,41) = 0
      VALUES(5,41) = 0
C      WRITE(KBOUT,*)'STADEN AND MCLACHLAN CODON USAGE METHOD'
C      CALL GETPAR(42,7,IOK,MINSP,MAXSP,LENW,MINIW,MAXIW,IWRIT,ANSTY)
      VALUES(1,42) = 11
      VALUES(2,42) = 101
      VALUES(3,42) = 25
      VALUES(4,42) = 1
      VALUES(5,42) = 11
      VALUES(6,42) = 5
      VALUES(7,42) = 0
C      WRITE(KBOUT,*)' POSITIONAL BASE PREFERENCES METHOD TO FIND',
C     +' PROTEIN GENES'
C      CALL GETPAR(43,9,IOK,MINSP,MAXSP,LENW,MINIW,MAXIW,IWRIT,
C     +ANSABS,ANSTY,ANSS)
      VALUES(1,43) = 31
      VALUES(2,43) = 101
      VALUES(3,43) = 67
      VALUES(4,43) = 1
      VALUES(5,43) = 11
      VALUES(6,43) = 5
      VALUES(7,43) = 0
      VALUES(8,43) = 0
      VALUES(9,43) = 0
C      WRITE(KBOUT,*)' UNEVEN POSITIONAL BASE FREQUENCIES METHOD'
C      CALL GETPAR(44,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT)
      VALUES(1,44) = 11
      VALUES(2,44) = 101
      VALUES(3,44) = 67
      VALUES(4,44) = 1
      VALUES(5,44) = 21
      VALUES(6,44) = 5
C      WRITE(KBOUT,*)' SEARCH FOR PROTEIN GENES USING MCLACHLAN, STADEN'
C      WRITE(KBOUT,*)' AND BOSWELL IMPROBABILITY METHOD'
C      WRITE(KBOUT,*)' EXPECTING CODON COMPOSITION TO DEPEND ON'
C      WRITE(KBOUT,*)' BASE COMPOSITION'
C      CALL GETPAR(45,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT)
      VALUES(1,45) = 67
      VALUES(2,45) = 99
      VALUES(3,45) = 99
      VALUES(4,45) = 1
      VALUES(5,45) = 21
      VALUES(6,45) = 5
C      WRITE(KBOUT,*)' SEARCH FOR PROTEIN GENES USING MCLACHLAN, STADEN'
C      WRITE(KBOUT,*)' AND BOSWELL IMPROBABILITY METHOD'
C      WRITE(KBOUT,*)' EXPECTING CODON COMPOSITION TO DEPEND ON'
C      WRITE(KBOUT,*)' AMINO ACID COMPOSITION'
C      CALL GETPAR(46,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT)
      VALUES(1,46) = 67
      VALUES(2,46) = 99
      VALUES(3,46) = 99
      VALUES(4,46) = 1
      VALUES(5,46) = 21
      VALUES(6,46) = 5
C      WRITE(KBOUT,*)' SHEPHERDS METHOD'
C      CALL GETPAR(47,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT)
      VALUES(1,47) = 11
      VALUES(2,47) = 101
      VALUES(3,47) = 67
      VALUES(4,47) = 1
      VALUES(5,47) = 21
      VALUES(6,47) = 5
C      WRITE(KBOUT,*)' FICKETTS METHOD'
C      CALL GETPAR(48,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT)
      VALUES(1,48) = 11
      VALUES(2,48) = 101
      VALUES(3,48) = 67
      VALUES(4,48) = 1
      VALUES(5,48) = 21
      VALUES(6,48) = 5
C      WRITE(KBOUT,*)' TRNA SEARCH '
C      CALL GETPAR(49,35,IOK,
C     +MNLEN,MXLEN,MAXLNT,
C     +MNAC,MXAC,MINACL,
C     +MNTU,MXTU,MINTU,
C     +MNAN,MXAN,MINANT,
C     +MND,MXD,MIND,
C     +MNI1,MXI1,INT1,
C     +MNI2,MXI2,INT2,
C     +MNTUL1,MXTUL1,LTUMIN,
C     +MNTUL2,MXTUL2,LTUMAX,
C     +MNB,MXB,MINBAS,
C     +MNC,MXC,MINCON,IGON,ANSCON)
      VALUES(1,49) = 70
      VALUES(2,49) = 130
      VALUES(3,49) = 92
      VALUES(4,49) = 0
      VALUES(5,49) = 14
      VALUES(6,49) = 11
      VALUES(7,49) = 0
      VALUES(8,49) = 10
      VALUES(9,49) = 8
      VALUES(10,49) = 0
      VALUES(11,49) = 10
      VALUES(12,49) = 8
      VALUES(13,49) = 0
      VALUES(14,49) = 8
      VALUES(15,49) = 3
      VALUES(16,49) = 0
      VALUES(17,49) = 30
      VALUES(18,49) = 0
      VALUES(19,49) = 30
      VALUES(20,49) = 30
      VALUES(21,49) = 0
      VALUES(22,49) = 4
      VALUES(23,49) = 12
      VALUES(24,49) = 6
      VALUES(25,49) = 6
      VALUES(26,49) = 12
      VALUES(27,49) = 9
      VALUES(28,49) = 0
      VALUES(29,49) = 44
      VALUES(30,49) = 0
      VALUES(31,49) = 0
      VALUES(32,49) = 0
      VALUES(33,49) = 0
      VALUES(34,49) = 0
      VALUES(35,49) = 1
C      WRITE(KBOUT,*)' FIND OPEN READING FRAMES'
C      CALL GETPAR(54,4,IOK,MINO,MAXO,MINOPN,JSTRAN)
      VALUES(1,54) = 5
      VALUES(2,54) = 1000
      VALUES(3,54) = 30
      VALUES(4,54) = 0
C      WRITE(KBOUT,*)' PLOT NEGENTROPY'
C      CALL GETPAR(29,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT)
      VALUES(1,59) = 11
      VALUES(2,59) = 301
      VALUES(3,59) = 33
      VALUES(4,59) = 1
      VALUES(5,59) = 21
      VALUES(6,59) = 5
C  SPLICE SEARCH
      VALUES(1,62) = 0
C      WRITE(KBOUT,*)'PLOT COMPOSITION DIFFERENCES (OBS-EXP))'
C      CALL GETPAR(64,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT)
      VALUES(1,64) = 3
      VALUES(2,64) = 401
      VALUES(3,64) = 101
      VALUES(4,64) = 1
      VALUES(5,64) = 20
      VALUES(6,64) = 5
C  PATTERNS TO DO
C      OPEN(UNIT=99,FILE='ANALYSEP.PAR',STATUS ='OLD')
C10    CONTINUE
C      READ(99,*,ERR=100,END=200)TEMP
C      IF((TEMP(1).GE.MINOPT).AND.(TEMP(1).LE.MAXOPT)) THEN
C        DO 20 I = 1,NUMBER-1
C          VALUES(I,TEMP(1)) = TEMP(I+1)
C          WRITE(*,*)TEMP(1),TEMP(I+1)
C20      CONTINUE
C      END IF
C      GO TO 10
C100   CONTINUE
C      WRITE(*,*)'ERROR IN PARMS FILE'
C      GO TO 10
C200   CONTINUE
C      CLOSE(UNIT = 99)
      IOK = 0
      END
      SUBROUTINE SEARCH(SEQ,IDSEQ,J1,J2,KSTART,
     +RENZYM,MAXREN,RECSEQ,MAXREC,
     +NAMES,MAXNAM,CUTADD,PSAVE,NSAVE,SORTA,MAXMAT,
     +NAMEP,NAMLEN,NUMREC,LENEN,RECSTR,NAMLST,
     +CUTSIT,PCUT,MAXENZ,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IDEV,
     +IDEVEN,FILNAM,FILE4,FILE6,FILEA,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,PAA,POSN,WORDP,MAXDIC,DIALOG)
C   AUTHOR: RODGER STADEN
      CHARACTER FILNAM*(*),FILEA*(*),FILE4*(*),FILE6*(*),HELPF*(*)
      CHARACTER SEQ(IDSEQ),RENZYM(MAXREN),RECSEQ(MAXREC),NAMES(MAXNAM)
      CHARACTER PAA(125)
      INTEGER OPTION,OPTOUT
      INTEGER CUTSIT(MAXENZ),PCUT(MAXENZ)
      INTEGER CUTADD(MAXMAT),PSAVE(MAXMAT),NSAVE(MAXMAT),SORTA(MAXMAT)
      INTEGER NAMEP(MAXENZ),NAMLEN(MAXENZ),NUMREC(MAXENZ)
      INTEGER LENEN(MAXENZ)
      INTEGER RECSTR(MAXENZ),NAMLST(MAXENZ),DIALOG
      INTEGER POSN(IDSEQ),WORDP(MAXDIC),CONST(0:24)
      PARAMETER (IBH=256)
      CALL SHOWFU(KBOUT,'Search for restriction enzyme sites')
      CALL GETPAR(17,13,IOK,
     +MINLEN,MAXLEN,LINLEN,MNCUT,MAXCUT,MINCUT,
     +OPTION,OPTOUT,IFILE,JTRAN,KTRAN,IROUND,IDEF,
     +IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      INC = 1
      IDNDEX = 1024
      LENW = 5
      LENC = 4*LENW
      CALL SETCN(CONST,LENW,5,LENC)
      ITRAN = KTRAN
10    CONTINUE
      IDREN  = MAXREN
      IDRSEQ = MAXREC
      IDNAML = MAXNAM
      IDNLST = MAXENZ
      MAXEN  = MAXENZ
      IDMAT  = MAXMAT
      LEVEL = 0
      CALL SERCHD(RENZYM,IDREN,RECSEQ,IDRSEQ,
     +NAMES,IDNAML,MARGT,
     +NAMEP,NAMLEN,NUMREC,LENEN,RECSTR,MAXEN,NAMLST,IDNLST,
     +IDEVEN,FILNAM,FILE4,FILE6,FILEA,KBIN,KBOUT,
     +OPTION,OPTOUT,NOPOUT,IFILE,DIALOG,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK,CUTSIT,PCUT,MAXS,LINLEN,ITRAN,
     +JTRAN,MINLEN,MAXLEN,IROUND,IDEF,MINCUT,MNCUT,MAXCUT)
      IF(IOK.NE.0) RETURN
      CALL BUSY(KBOUT)
      CALL CONNUM(SEQ(J1),POSN(J1),J2-J1+1)
      CALL ENCOND(POSN(J1),J2-J1+1,WORDP,IDNDEX,5,CONST,LENW,LENC)
      IF(OPTOUT.EQ.2) THEN
        CALL FINDL1(SEQ,IDSEQ,J1,J2,KSTART,RECSEQ,IDRSEQ,NAMES,IDNAML,
     +  NAMEP,NAMLEN,
     +  NUMREC,LENEN,RECSTR,MAXEN,NAMLST,IDNLST,OPTION,OPTOUT,
     +  PCUT,CUTSIT,MAXS,IROUND,
     +  PSAVE,NSAVE,CUTADD,SORTA,IDMAT,NOPOUT,IBH,LEVEL,
     +  MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,INC,KBIN,KBOUT,IDEV,
     +  IHELPS,IHELPE,HELPF,IDEVH,MINCUT,IDEF,
     +  POSN(J1),WORDP,IDNDEX,CONST,LENW,LENC,IOK)
      ELSE IF((OPTOUT.EQ.0).AND.(NOPOUT.EQ.1)) THEN
        CALL FINDL2(SEQ,IDSEQ,J1,J2,KSTART,RECSEQ,IDRSEQ,NAMES,IDNAML,
     +  NAMEP,NAMLEN,
     +  NUMREC,LENEN,RECSTR,MAXEN,NAMLST,IDNLST,OPTION,OPTOUT,
     +  PCUT,CUTSIT,MAXS,IROUND,
     +  PSAVE,NSAVE,CUTADD,SORTA,IDMAT,NOPOUT,IBH,LEVEL,
     +  MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,INC,KBIN,KBOUT,IDEV,
     +  IHELPS,IHELPE,HELPF,IDEVH,IDEF,
     +  POSN(J1),WORDP,IDNDEX,CONST,LENW,LENC,IOK)
      ELSE IF((OPTOUT.EQ.1).AND.(NOPOUT.EQ.1)) THEN
        CALL FINDL3(SEQ,IDSEQ,J1,J2,KSTART,RECSEQ,IDRSEQ,NAMES,IDNAML,
     +  NAMEP,NAMLEN,
     +  NUMREC,LENEN,RECSTR,MAXEN,NAMLST,IDNLST,OPTION,OPTOUT,
     +  PCUT,CUTSIT,MAXS,IROUND,
     +  PSAVE,NSAVE,CUTADD,SORTA,IDMAT,NOPOUT,IBH,LEVEL,
     +  MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,INC,KBIN,KBOUT,IDEV,
     +  IHELPS,IHELPE,HELPF,IDEVH,IDEF,
     +  POSN(J1),WORDP,IDNDEX,CONST,LENW,LENC,IOK)
      ELSE IF((OPTOUT.EQ.0).AND.(NOPOUT.EQ.0)) THEN
        CALL FINDL4(SEQ,IDSEQ,J1,J2,KSTART,RECSEQ,IDRSEQ,NAMES,IDNAML,
     +  NAMEP,NAMLEN,
     +  NUMREC,LENEN,RECSTR,MAXEN,NAMLST,IDNLST,OPTION,OPTOUT,
     +  PCUT,CUTSIT,MAXS,IROUND,
     +  PSAVE,NSAVE,CUTADD,SORTA,IDMAT,NOPOUT,IBH,LEVEL,
     +  MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,INC,KBIN,KBOUT,IDEV,
     +  IHELPS,IHELPE,HELPF,IDEVH,IDEF,
     +  POSN(J1),WORDP,IDNDEX,CONST,LENW,LENC,IOK)
      ELSE IF((OPTOUT.EQ.1).AND.(NOPOUT.EQ.0)) THEN
        CALL FINDL5(SEQ,IDSEQ,J1,J2,KSTART,RECSEQ,IDRSEQ,NAMES,IDNAML,
     +  NAMEP,NAMLEN,
     +  NUMREC,LENEN,RECSTR,MAXEN,NAMLST,IDNLST,OPTION,OPTOUT,
     +  PCUT,CUTSIT,MAXS,IROUND,
     +  PSAVE,NSAVE,CUTADD,SORTA,IDMAT,NOPOUT,IBH,LEVEL,
     +  MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,INC,KBIN,KBOUT,IDEV,
     +  IHELPS,IHELPE,HELPF,IDEVH,IDEF,
     +  POSN(J1),WORDP,IDNDEX,CONST,LENW,LENC,IOK)
      ELSE IF((OPTOUT.EQ.3).AND.(NOPOUT.EQ.0)) THEN
        CALL FINDL6(SEQ,IDSEQ,J1,J2,KSTART,RECSEQ,IDRSEQ,NAMES,IDNAML,
     +  NAMEP,NAMLEN,
     +  NUMREC,LENEN,RECSTR,MAXEN,NAMLST,IDNLST,OPTION,OPTOUT,
     +  PCUT,CUTSIT,MAXS,IROUND,
     +  PSAVE,NSAVE,CUTADD,SORTA,IDMAT,NOPOUT,IBH,LEVEL,
     +  MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,INC,KBIN,KBOUT,IDEV,
     +  IHELPS,IHELPE,HELPF,IDEVH,ITRAN,LINLEN,PAA,IDEF,
     +  POSN(J1),WORDP,IDNDEX,CONST,LENW,LENC,IOK)
      END IF
      CALL BPAUSE(KBIN,KBOUT,IOK)
      IF(IOK.NE.0) RETURN
      DIALOG = 1
      GO TO 10
      END
      SUBROUTINE SERCHD(RENZYM,IDREN,RECSEQ,IDRSEQ,
     +NAMES,IDNAML,MARGT,
     +NAMEP,NAMLEN,NUMREC,LENEN,RECSTR,MAXEN,NAMLST,IDNLST,
     +IDEVEN,FILNAM,FILE4,FILE6,FILEA,KBIN,KBOUT,
     +OPTION,OPTOUT,NOPOUT,IFILE,DIALOG,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK,CUTSIT,PCUT,MAXS,LINLEN,ITRAN,
     +JTRAN,MINLEN,MAXLEN,IROUND,IDEF,MINCUT,MNCUT,MAXCUT)
C   AUTHOR: RODGER STADEN
      CHARACTER FILNAM*(*),FILEA*(*),FILE4*(*),FILE6*(*),HELPF*(*)
      CHARACTER RENZYM(IDREN),RECSEQ(IDRSEQ),NAMES(IDNAML)
      INTEGER OPTION,OPTOUT
      INTEGER NAMEP(MAXEN),NAMLEN(MAXEN),NUMREC(MAXEN)
      INTEGER LENEN(MAXEN)
      INTEGER RECSTR(MAXEN),NAMLST(IDNLST),DIALOG
      INTEGER CUTSIT(IDNLST),PCUT(IDNLST)
      PARAMETER (MAXPRM = 30)
      CHARACTER PROMPT(4)*(MAXPRM)
      IOK = 0
      NOPOUT = 0
      CALL GETREN(RENZYM,IDREN,IDEVEN,FILNAM,FILE4,FILE6,FILEA,
     +IOK,KBIN,KBOUT,IFILE,DIALOG,
     +IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.NE.0)RETURN
      IF(IDREN.LT.5) THEN
        IOK = 1
        RETURN
      END IF
      CALL DECREN(RENZYM,IDREN,RECSEQ,IDRSEQ,NAMES,IDNAML,
     +NAMEP,NAMLEN,NUMREC,LENEN,RECSTR,MAXEN,KBOUT,CUTSIT,PCUT,MAXS)
      IF(MAXEN.LT.1) THEN
        IOK = 1
        RETURN
      END IF
      IF(DIALOG.EQ.0) RETURN
      IOP = OPTION
      CALL YESONO(IOP,'Search for all names','select names',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IOP.LT.0) THEN
        IOK = 1
        RETURN
      END IF
      OPTION = IOP
      IF(OPTION.EQ.1)THEN
        CALL GETNAM(NAMLST,IDNLST,NAMES,IDNAML,NAMEP,NAMLEN,
     +  MAXEN,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH)
        IF(IDNLST.LT.1) THEN
          IOK = 1
          RETURN
        END IF
      END IF
      IOP = OPTOUT + 1
      PROMPT(1) = 'Order results enzyme by enzyme'
      PROMPT(2) = 'Order results by position'
      PROMPT(3) = 'Show only infrequent cutters'
      PROMPT(4) = 'Show names above the sequence'
      CALL RADION('Select results display mode',PROMPT,4,IOP,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IOP.LT.1) THEN
        IOK = 1
        RETURN
      END IF
      OPTOUT = IOP - 1
      IF(OPTOUT.EQ.2) THEN
        CALL GETINT(MNCUT,MAXCUT,MINCUT,'Maximum number of cuts',
     +  IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        MINCUT = IVAL
      END IF
      IF(OPTOUT.EQ.3) THEN
        IOP = JTRAN
        CALL YESONO(IOP,'Hide translation','Show translation',
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(IOP.LT.0) THEN
          IOK = 1
          RETURN
        END IF
        JTRAN = IOP
        IF(JTRAN.EQ.1) THEN
          IOP = ITRAN
          IF(IOP.EQ.3) IOP = 1
          CALL YESONO(IOP,'Use 1 letter codes',
     +    'Use 3 letter codes',
     +    IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
          IF(IOP.LT.0) THEN
            IOK = 1
            RETURN
          END IF
          IF(IOP.EQ.1) ITRAN = 3
          IF(IOP.EQ.0) ITRAN = 0
        ELSE IF(JTRAN.EQ.0) THEN
          ITRAN = 1
        END IF
        IF(ITRAN.NE.1) THEN
          MAXLEN = 90
          MINLEN = 30
        END IF
        LENDEF = LINLEN
        CALL GETINT(MINLEN,MAXLEN,LENDEF,'Line length',
     +  IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        LINLEN = IVAL
        IF((ITRAN.NE.1).AND.(MOD(LINLEN,3).NE.0)) LINLEN = 60
      END IF
      IOP = NOPOUT
      IF((OPTOUT.EQ.0).OR.(OPTOUT.EQ.1)) THEN
        CALL YESONO(IOP,'List matches','Plot matches',
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(IOP.LT.0) THEN
          IOK = 1
          RETURN
        END IF
        NOPOUT = IOP
      END IF
C      IF(NOPOUT.EQ.1)THEN
C        LEVEL = LEVELI
C        CALL SD2(IBLIPH,IBH,LEVEL,MARGT,
C     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,IOK)
C        LEVELI = LEVEL
C        IF(IOK.NE.0) RETURN
C      END IF
C      CALL GETINT(MININC,MAXINC,INC,'Step',
C     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
C      IF(IOK.NE.0) RETURN
C      INC = IVAL
      IOP = IROUND
      CALL YESONO(IOP,'The sequence is linear',
     +'The sequence is circular',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IOP.LT.0) THEN
        IOK = 1
        RETURN
      END IF
      IROUND = IOP
      IOP = IDEF
      CALL YESONO(IOP,'Search for definite matches',
     +'Search for possible matches',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IOP.LT.0) THEN
        IOK = 1
        RETURN
      END IF
      IDEF = IOP
      END
      SUBROUTINE FINDL1(SEQ,IDSEQ,J1,J2,KSTART,RECSEQ,IDRSEQ,
     +NAMES,IDNAML,NAMEP,NAMLEN,
     +NUMREC,LENEN,RECSTR,MAXEN,NAMLST,IDNLST,OPTION,OPTOUT,
     +  PCUT,CUTSIT,MAXS,IROUND,
     +PSAVE,NSAVE,CUTADD,SORTA,MAXMAT,NOPOUT,IBH,LEVEL,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,INC,KBIN,KBOUT,IDEV,
     +IHELPS,IHELPE,HELPF,IDEVH,MINCUT,IDEF,
     +POSN,WORDP,IDNDEX,
     +CONST,LENW,LENC,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDSEQ),NAMES(IDNAML),RECSEQ(IDRSEQ)
      INTEGER NAMEP(MAXEN),NAMLEN(MAXEN),NUMREC(MAXEN),LENEN(MAXS)
      INTEGER RECSTR(MAXEN),NAMLST(IDNLST),PSAVE(MAXMAT)
      INTEGER NSAVE(MAXMAT),OPTION,OPTOUT
      INTEGER CUTSIT(MAXS),PCUT(MAXEN),CUTADD(MAXMAT),SORTA(MAXMAT)
      CHARACTER HELPF*(*)
      INTEGER POSN(IDSEQ),WORDP(IDNDEX),CONST(0:LENC)
C   OPTOUT=0 ENZYME BY ENZYME
C   LOW FREQUENCY CUTTERS
C   names max length 20 chars, strings 20 chars
      LAST=MAXEN
      IF(OPTION.EQ.1)LAST=IDNLST
      DO 100 IEN=1,LAST
        IFOUND=0
        JEN=IEN
        IF(OPTION.EQ.1)JEN=NAMLST(IEN)
        NREC=NUMREC(JEN)
        IF(IDEF.EQ.0) THEN
          CALL S1D0(SEQ,IDSEQ,NREC,JEN,IREC,J1,J2,INC,KSTART,
     +    RECSTR,MAXEN,PSAVE,NSAVE,MAXMAT,RECSEQ,IDRSEQ,IFOUND,
     +    PCUT,CUTSIT,LENEN,MAXS,CUTADD,IROUND,
     +    POSN,WORDP,IDNDEX,
     +    CONST,LENW,LENC,KBOUT,IOK)
        ELSE
          CALL S1D1(SEQ,IDSEQ,NREC,JEN,IREC,J1,J2,INC,KSTART,
     +    RECSTR,MAXEN,PSAVE,NSAVE,MAXMAT,RECSEQ,IDRSEQ,IFOUND,
     +    PCUT,CUTSIT,LENEN,MAXS,CUTADD,IROUND,KBOUT,IOK)
        END IF
        IF(IOK.NE.0) RETURN
        IF(IFOUND.LE.MINCUT) THEN
          K1=NAMEP(JEN)
          K2=K1+NAMLEN(JEN)-1
          WRITE(IDEV,1009)IFOUND,(NAMES(K),K=K1,K2)
1009      FORMAT(' ',I6,' ',20A1)
        END IF
100   CONTINUE
      END
      SUBROUTINE FINDL2(SEQ,IDSEQ,J1,J2,KSTART,RECSEQ,IDRSEQ,
     +NAMES,IDNAML,NAMEP,NAMLEN,
     +NUMREC,LENEN,RECSTR,MAXEN,NAMLST,IDNLST,OPTION,OPTOUT,
     +  PCUT,CUTSIT,MAXS,IROUND,
     +PSAVE,NSAVE,CUTADD,SORTA,MAXMAT,NOPOUT,IBH,LEVEL,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,INC,KBIN,KBOUT,IDEV,
     +IHELPS,IHELPE,HELPF,IDEVH,IDEF,
     +POSN,WORDP,IDNDEX,
     +CONST,LENW,LENC,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDSEQ),NAMES(IDNAML),RECSEQ(IDRSEQ)
      INTEGER NAMEP(MAXEN),NAMLEN(MAXEN),NUMREC(MAXEN),LENEN(MAXS)
      INTEGER RECSTR(MAXEN),NAMLST(IDNLST),PSAVE(MAXMAT)
      INTEGER NSAVE(MAXMAT),OPTION,OPTOUT
      INTEGER CUTSIT(MAXS),PCUT(MAXEN),CUTADD(MAXMAT),SORTA(MAXMAT)
      CHARACTER HELPF*(*)
      CHARACTER*20 ATOS
      INTEGER POSN(IDSEQ),WORDP(IDNDEX),CONST(0:LENC)
      EXTERNAL ATOS
C   OPTOUT=0 ENZYME BY ENZYME
C   NOPOUT=1 GRAPHICAL OUTPUT
C   FOR GRAPHICS NEED TO CHECK FOR END OF SCREEN
      CALL CLEARV
      CALL VECTOM
      LEVEL1=LEVEL
      LEVELM=MARGT-IBH
C   names max length 20 chars, strings 20 chars
      LAST=MAXEN
      IF(OPTION.EQ.1)LAST=IDNLST
      DO 100 IEN=1,LAST
        IFOUND=0
        JEN=IEN
        IF(OPTION.EQ.1)JEN=NAMLST(IEN)
        NREC=NUMREC(JEN)
        IF(IDEF.EQ.0) THEN
          CALL S1D0(SEQ,IDSEQ,NREC,JEN,IREC,J1,J2,INC,KSTART,
     +    RECSTR,MAXEN,PSAVE,NSAVE,MAXMAT,RECSEQ,IDRSEQ,IFOUND,
     +    PCUT,CUTSIT,LENEN,MAXS,CUTADD,IROUND,
     +    POSN,WORDP,IDNDEX,
     +    CONST,LENW,LENC,KBOUT,IOK)
        ELSE
          CALL S1D1(SEQ,IDSEQ,NREC,JEN,IREC,J1,J2,INC,KSTART,
     +    RECSTR,MAXEN,PSAVE,NSAVE,MAXMAT,RECSEQ,IDRSEQ,IFOUND,
     +    PCUT,CUTSIT,LENEN,MAXS,CUTADD,IROUND,KBOUT,IOK)
        END IF
        IF(IOK.NE.0) THEN
          CALL VT100M
          RETURN
        END IF
        IF(IFOUND.GT.0) THEN
          IF(LEVEL.GE.LEVELM)THEN
            CALL PSRCHX(LEVEL1,LEVEL,KBIN,KBOUT,IQUIT,
     +      IHELPS,IHELPE,HELPF,IDEVH)
            IF(IQUIT.EQ.1) THEN
              CALL VT100M
              RETURN
            END IF
          END IF
          CALL PLSRCH(J1-KSTART+1,J2-KSTART+1,
     +    PSAVE,IFOUND,IBH,LEVEL,
     +    ATOS(NAMES(NAMEP(JEN)),NAMLEN(JEN)),
     +    NAMLEN(JEN),
     +    MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
        END IF
100   CONTINUE
      CALL VT100M
      END
      SUBROUTINE FINDL3(SEQ,IDSEQ,J1,J2,KSTART,RECSEQ,IDRSEQ,
     +NAMES,IDNAML,NAMEP,NAMLEN,
     +NUMREC,LENEN,RECSTR,MAXEN,NAMLST,IDNLST,OPTION,OPTOUT,
     +  PCUT,CUTSIT,MAXS,IROUND,
     +PSAVE,NSAVE,CUTADD,SORTA,MAXMAT,NOPOUT,IBH,LEVEL,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,INC,KBIN,KBOUT,IDEV,
     +IHELPS,IHELPE,HELPF,IDEVH,IDEF,
     +POSN,WORDP,IDNDEX,
     +CONST,LENW,LENC,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDSEQ),NAMES(IDNAML),RECSEQ(IDRSEQ)
      INTEGER NAMEP(MAXEN),NAMLEN(MAXEN),NUMREC(MAXEN),LENEN(MAXS)
      INTEGER RECSTR(MAXEN),NAMLST(IDNLST),PSAVE(MAXMAT)
      INTEGER NSAVE(MAXMAT),OPTION,OPTOUT
      INTEGER CUTSIT(MAXS),PCUT(MAXEN),CUTADD(MAXMAT),SORTA(MAXMAT)
      CHARACTER HELPF*(*)
      INTEGER POSN(IDSEQ),WORDP(IDNDEX),CONST(0:LENC)
C   OPTOUT=1 ALL ENZYMES TOGETHER
C   NOPOUT=1 GRAPHICAL OUTPUT
C   FOR GRAPHICS NEED TO CHECK FOR END OF SCREEN
      CALL CLEARV
      CALL VECTOM
      LEVEL1=LEVEL
      LEVELM=MARGT-IBH
      LAST=MAXEN
      IF(OPTION.EQ.1)LAST=IDNLST
      IFOUND=0
      DO 100 IEN=1,LAST
        JEN=IEN
        IF(OPTION.EQ.1)JEN=NAMLST(IEN)
        NREC=NUMREC(JEN)
        IF(IDEF.EQ.0) THEN
          CALL S1D0(SEQ,IDSEQ,NREC,JEN,IREC,J1,J2,INC,KSTART,
     +    RECSTR,MAXEN,PSAVE,NSAVE,MAXMAT,RECSEQ,IDRSEQ,IFOUND,
     +    PCUT,CUTSIT,LENEN,MAXS,CUTADD,IROUND,
     +    POSN,WORDP,IDNDEX,
     +    CONST,LENW,LENC,KBOUT,IOK)
        ELSE
          CALL S1D1(SEQ,IDSEQ,NREC,JEN,IREC,J1,J2,INC,KSTART,
     +    RECSTR,MAXEN,PSAVE,NSAVE,MAXMAT,RECSEQ,IDRSEQ,IFOUND,
     +    PCUT,CUTSIT,LENEN,MAXS,CUTADD,IROUND,KBOUT,IOK)
        END IF
        IF(IOK.NE.0) THEN
          CALL VT100M
          RETURN
        END IF
100   CONTINUE
      IF(IFOUND.GT.0)THEN
        CALL PLSRCH(J1-KSTART+1,J2-KSTART+1,
     +  PSAVE,IFOUND,IBH,LEVEL,'ALL',3,
     +  MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      END IF
      CALL VT100M
      IF(IFOUND.EQ.0)WRITE(IDEV,3000)
3000  FORMAT(' No matches found')
      END
      SUBROUTINE FINDL4(SEQ,IDSEQ,J1,J2,KSTART,RECSEQ,IDRSEQ,
     +NAMES,IDNAML,NAMEP,NAMLEN,
     +NUMREC,LENEN,RECSTR,MAXEN,NAMLST,IDNLST,OPTION,OPTOUT,
     +  PCUT,CUTSIT,MAXS,IROUND,
     +PSAVE,NSAVE,CUTADD,SORTA,MAXMAT,NOPOUT,IBH,LEVEL,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,INC,KBIN,KBOUT,IDEV,
     +IHELPS,IHELPE,HELPF,IDEVH,IDEF,
     +POSN,WORDP,IDNDEX,
     +CONST,LENW,LENC,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDSEQ),NAMES(IDNAML),RECSEQ(IDRSEQ)
      INTEGER NAMEP(MAXEN),NAMLEN(MAXEN),NUMREC(MAXEN),LENEN(MAXS)
      INTEGER RECSTR(MAXEN),NAMLST(IDNLST),PSAVE(MAXMAT)
      INTEGER NSAVE(MAXMAT),OPTION,OPTOUT
      INTEGER CUTSIT(MAXS),PCUT(MAXEN),CUTADD(MAXMAT),SORTA(MAXMAT)
      CHARACTER HELPF*(*)
      INTEGER POSN(IDSEQ),WORDP(IDNDEX),CONST(0:LENC)
C   OPTOUT=0 ENZYME BY ENZYME
C   names max length 20 chars, strings 20 chars
      LAST=MAXEN
      IF(OPTION.EQ.1)LAST=IDNLST
      DO 100 IEN=1,LAST
        IFOUND=0
        JEN=IEN
        IF(OPTION.EQ.1)JEN=NAMLST(IEN)
        NREC=NUMREC(JEN)
        IF(IDEF.EQ.0) THEN
          CALL S1D0(SEQ,IDSEQ,NREC,JEN,IREC,J1,J2,INC,KSTART,
     +    RECSTR,MAXEN,PSAVE,NSAVE,MAXMAT,RECSEQ,IDRSEQ,IFOUND,
     +    PCUT,CUTSIT,LENEN,MAXS,CUTADD,IROUND,
     +    POSN,WORDP,IDNDEX,
     +    CONST,LENW,LENC,KBOUT,IOK)
        ELSE
          CALL S1D1(SEQ,IDSEQ,NREC,JEN,IREC,J1,J2,INC,KSTART,
     +    RECSTR,MAXEN,PSAVE,NSAVE,MAXMAT,RECSEQ,IDRSEQ,IFOUND,
     +    PCUT,CUTSIT,LENEN,MAXS,CUTADD,IROUND,KBOUT,IOK)
        END IF
        IF(IOK.NE.0) RETURN
        IF(IFOUND.GT.0) THEN
          WRITE(IDEV,1010)IFOUND
1010      FORMAT('  Matches found=',I6)
          CALL BUB3AS(PSAVE,NSAVE,CUTADD,IFOUND)
C         calc lengths
          IF(IROUND.EQ.0) THEN
            LENN = J1 - KSTART + 1
            SORTA(1) = PSAVE(1) - LENN
          ELSE IF(IROUND.EQ.1) THEN
            LENN = J2 - PSAVE(IFOUND) + 1
            SORTA(1) = LENN + PSAVE(1) - (J1 - KSTART + 1)
            LENN = 1 - LENN
          END IF
          DO 45 KOUT=2,IFOUND
            SORTA(KOUT)=PSAVE(KOUT)-PSAVE(KOUT-1)
45        CONTINUE
C         do length to end
          IFP1 = IFOUND
          IF(IROUND.EQ.0) THEN
            SORTA(IFOUND+1)=J2-KSTART+1-PSAVE(IFOUND)+1
            IFP1=IFOUND+1
          END IF
          CALL BUBBLE(SORTA,IFP1)
          CALL S2(SEQ,IDSEQ,IFOUND,NAMEP,NAMLEN,LENEN,MAXEN,
     +    NSAVE,PSAVE,SORTA,MAXMAT,NAMES,IDNAML,
     +    CUTSIT,MAXS,CUTADD,IROUND,
     +    LENN,IDEV,J2,KSTART,0)
        END IF
100   CONTINUE
      END
      SUBROUTINE FINDL5(SEQ,IDSEQ,J1,J2,KSTART,RECSEQ,IDRSEQ,
     +NAMES,IDNAML,NAMEP,NAMLEN,
     +NUMREC,LENEN,RECSTR,MAXEN,NAMLST,IDNLST,OPTION,OPTOUT,
     +  PCUT,CUTSIT,MAXS,IROUND,
     +PSAVE,NSAVE,CUTADD,SORTA,MAXMAT,NOPOUT,IBH,LEVEL,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,INC,KBIN,KBOUT,IDEV,
     +IHELPS,IHELPE,HELPF,IDEVH,IDEF,
     +POSN,WORDP,IDNDEX,
     +CONST,LENW,LENC,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDSEQ),NAMES(IDNAML),RECSEQ(IDRSEQ)
      INTEGER NAMEP(MAXEN),NAMLEN(MAXEN),NUMREC(MAXEN),LENEN(MAXS)
      INTEGER RECSTR(MAXEN),NAMLST(IDNLST),PSAVE(MAXMAT)
      INTEGER NSAVE(MAXMAT),OPTION,OPTOUT
      INTEGER CUTSIT(MAXS),PCUT(MAXEN),CUTADD(MAXMAT),SORTA(MAXMAT)
      CHARACTER HELPF*(*)
      INTEGER POSN(IDSEQ),WORDP(IDNDEX),CONST(0:LENC)
C   OPTOUT=1 ALL ENZYMES TOGETHER 
C   names max length 20 chars, strings 20 chars
      LAST=MAXEN
      IF(OPTION.EQ.1)LAST=IDNLST
      IFOUND=0
      DO 100 IEN=1,LAST
        JEN=IEN
        IF(OPTION.EQ.1)JEN=NAMLST(IEN)
        NREC=NUMREC(JEN)
        IF(IDEF.EQ.0) THEN
          CALL S1D0(SEQ,IDSEQ,NREC,JEN,IREC,J1,J2,INC,KSTART,
     +    RECSTR,MAXEN,PSAVE,NSAVE,MAXMAT,RECSEQ,IDRSEQ,IFOUND,
     +    PCUT,CUTSIT,LENEN,MAXS,CUTADD,IROUND,
     +    POSN,WORDP,IDNDEX,
     +    CONST,LENW,LENC,KBOUT,IOK)
        ELSE
          CALL S1D1(SEQ,IDSEQ,NREC,JEN,IREC,J1,J2,INC,KSTART,
     +    RECSTR,MAXEN,PSAVE,NSAVE,MAXMAT,RECSEQ,IDRSEQ,IFOUND,
     +    PCUT,CUTSIT,LENEN,MAXS,CUTADD,IROUND,KBOUT,IOK)
        END IF
        IF(IOK.NE.0) RETURN
100   CONTINUE
      IF(IFOUND.GT.0) THEN
        CALL BUB3AS(PSAVE,NSAVE,CUTADD,IFOUND)
        IF(IROUND.EQ.0) THEN
          LENN = J1 - KSTART + 1
          SORTA(1) = PSAVE(1) - LENN
        ELSE IF(IROUND.EQ.1) THEN
          LENN = J2 - PSAVE(IFOUND) + 1
          SORTA(1) = LENN + PSAVE(1) - (J1 - KSTART + 1)
          LENN = 1 - LENN
        END IF
        DO 45 KOUT=2,IFOUND
          SORTA(KOUT)=PSAVE(KOUT)-PSAVE(KOUT-1)
45      CONTINUE
        CALL S2(SEQ,IDSEQ,IFOUND,NAMEP,NAMLEN,LENEN,MAXEN,
     +  NSAVE,PSAVE,SORTA,MAXMAT,NAMES,IDNAML,
     +  CUTSIT,MAXS,CUTADD,IROUND,
     +  LENN,IDEV,J2,KSTART,1)
      ELSE
        WRITE(IDEV,1010)
1010    FORMAT(' No matches found')
      END IF
      END
      SUBROUTINE FINDL6(SEQ,IDSEQ,J1,J2,KSTART,RECSEQ,IDRSEQ,
     +NAMES,IDNAML,NAMEP,NAMLEN,
     +NUMREC,LENEN,RECSTR,MAXEN,NAMLST,IDNLST,OPTION,OPTOUT,
     +  PCUT,CUTSIT,MAXS,IROUND,
     +PSAVE,NSAVE,CUTADD,SORTA,MAXMAT,NOPOUT,IBH,LEVEL,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,INC,KBIN,KBOUT,IDEV,
     +IHELPS,IHELPE,HELPF,IDEVH,ITRAN,LINLEN,PAA,IDEF,
     +POSN,WORDP,IDNDEX,
     +CONST,LENW,LENC,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDSEQ),NAMES(IDNAML),RECSEQ(IDRSEQ)
      INTEGER NAMEP(MAXEN),NAMLEN(MAXEN),NUMREC(MAXEN),LENEN(MAXS)
      INTEGER RECSTR(MAXEN),NAMLST(IDNLST),PSAVE(MAXMAT)
      INTEGER NSAVE(MAXMAT),OPTION,OPTOUT
      INTEGER CUTSIT(MAXS),PCUT(MAXEN),CUTADD(MAXMAT),SORTA(MAXMAT)
      CHARACTER HELPF*(*),PAA(125)
      INTEGER POSN(IDSEQ),WORDP(IDNDEX),CONST(0:LENC)
C   OPTOUT=3 NAMES ABOVE SEQUENCE
C   names max length 20 chars, strings 20 chars
      LAST=MAXEN
      IF(OPTION.EQ.1)LAST=IDNLST
      IFOUND=0
      DO 100 IEN=1,LAST
        JEN=IEN
        IF(OPTION.EQ.1)JEN=NAMLST(IEN)
        NREC=NUMREC(JEN)
        IF(IDEF.EQ.0) THEN
          CALL S1D0(SEQ,IDSEQ,NREC,JEN,IREC,J1,J2,INC,KSTART,
     +    RECSTR,MAXEN,PSAVE,NSAVE,MAXMAT,RECSEQ,IDRSEQ,IFOUND,
     +    PCUT,CUTSIT,LENEN,MAXS,CUTADD,IROUND,
     +    POSN,WORDP,IDNDEX,
     +    CONST,LENW,LENC,KBOUT,IOK)
        ELSE
          CALL S1D1(SEQ,IDSEQ,NREC,JEN,IREC,J1,J2,INC,KSTART,
     +    RECSTR,MAXEN,PSAVE,NSAVE,MAXMAT,RECSEQ,IDRSEQ,IFOUND,
     +    PCUT,CUTSIT,LENEN,MAXS,CUTADD,IROUND,KBOUT,IOK)
        END IF
        IF(IOK.NE.0) RETURN
100   CONTINUE
      IF(IFOUND.GT.0) THEN
        CALL BUB2AS(PSAVE,NSAVE,IFOUND)
        CALL PETER(SEQ,IDSEQ,J1,J2,KSTART,
     +  NAMES,IDNAML,NAMEP,NAMLEN,MAXEN,
     +  PSAVE,NSAVE,IDEV,IFOUND,LINLEN,PAA,ITRAN)
      ELSE
        WRITE(IDEV,1010)
1010    FORMAT(' No matches')
      END IF
      END
      SUBROUTINE S1D0(SEQ,IDSEQ,NREC,JEN,IREC,J1,J2,INC,KSTART,
     +RECSTR,MAXEN,PSAVE,NSAVE,MAXMAT,RECSEQ,IDRSEQ,IFOUND,
     +PCUT,CUTSIT,LENEN,MAXS,CUTADD,IROUND,POSN,WORDP,IDNDEX,
     +CONST,LENW,LENC,KBOUT,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDSEQ),RECSEQ(IDRSEQ),TEMP3(40)
      INTEGER RECSTR(MAXEN),PSAVE(MAXMAT),NSAVE(MAXMAT)
      INTEGER PCUT(MAXEN),CUTSIT(MAXS),CUTADD(MAXMAT),SPOINT
      INTEGER LENEN(MAXS)
      INTEGER POSN(IDSEQ),WORDP(IDNDEX),CONST(0:LENC),GENRCI
      EXTERNAL MC,GENRCI
      IOK = 1
      LREC = 0
      DO 50 IREC=1,NREC
C       POINT TO START OF STRING
        ISTR=RECSTR(JEN)+(IREC-1)*(LREC)
        SPOINT = PCUT(JEN) + IREC - 1
        LREC = LENEN (SPOINT)
C       FIND FIRST AND LAST NON N CHARS IN STRING
        CALL GETNON(RECSEQ(ISTR),LREC,INON,LNON)
C       CHECK FOR ALL N'S IN STRING!!
        IF(LNON.GT.0)THEN
          ISTR = ISTR + INON - 1
          IENTRY = 0
5         CONTINUE
          NINDEX = GENRCI(RECSEQ(ISTR),LNON,LENW,CONST,LENC,IENTRY)
          IF(NINDEX.NE.0) THEN
            K1 = WORDP(NINDEX)
            IF(K1.NE.0) THEN
              IMATCH = 0
              K2 = K1 + J1 - 1
              IF(LNON.GT.LENW) THEN
                IF((K2+LNON-1).LE.IDSEQ) THEN
                  IMATCH = MC(SEQ(K2+LENW),RECSEQ(ISTR+LENW),
     +            LNON-LENW)
                ELSE
                  IMATCH = 1
                END IF
              END IF
              IF(IMATCH.EQ.0) THEN
                IFOUND = IFOUND + 1
                IF(IFOUND.GT.MAXMAT)THEN
                  CALL ERROM(KBOUT,'Too many matches')
                  RETURN
                END IF
                NSAVE(IFOUND) = JEN
C  NEED THE CUTPOINT FOR THIS STRING; THE FIRST ONE THIS NAME
C  IS AT PCUT(JEN) IN ARRAY CUTSIT, SO THIS ONE IS AT
C  PCUT(JEN)+IREC-1 = SPOINT IN CUTSIT
                CUTADD(IFOUND) = SPOINT
C               SAVE POSITION RELATIVE TO ARRAY
                KT = K2 + CUTSIT(SPOINT) - INON + 1
                IF(KT.GT.IDSEQ)KT = KT - IDSEQ
                IF(KT.LT.0)KT = ABS(KT) + 1
                PSAVE(IFOUND) = KT
              END IF
10            CONTINUE
              K3 = K1
              K1 = POSN(K3)
              IF(K1.NE.0) THEN
                IMATCH = 0
                K2 = K1 + J1 - 1
                IF(LNON.GT.LENW) THEN
                  IF((K2+LNON-1).LE.IDSEQ) THEN
                    IMATCH = MC(SEQ(K2+LENW),RECSEQ(ISTR+LENW),
     +              LNON-LENW)
                  ELSE
                    IMATCH = 1
                  END IF
                END IF
                IF(IMATCH.EQ.0) THEN
                  IFOUND = IFOUND + 1
                  IF(IFOUND.GT.MAXMAT)THEN
                    CALL ERROM(KBOUT,'Too many matches')
                    RETURN
                  END IF
                  NSAVE(IFOUND) = JEN
                  CUTADD(IFOUND) = SPOINT
                  KT = K2 + CUTSIT(SPOINT) - INON + 1
                  IF(KT.GT.IDSEQ)KT = KT - IDSEQ
                  IF(KT.LT.0)KT = ABS(KT) + 1
                  PSAVE(IFOUND) = KT
                END IF
                GO TO 10  
              END IF
            END IF
            GO TO 5
          END IF
          IF(LNON.GE.IDSEQ)GO TO 50
          IF(IROUND.NE.1)GO TO 50
          IAT = 0
          LNONM1 = LNON - 1
          IF(LNONM1.GT.0)THEN
            CALL SQCOPY(SEQ(IDSEQ-LNON+2),TEMP3,LNONM1)
            CALL SQCOPY(SEQ,TEMP3(LNON),LNONM1)
          END IF
51        CONTINUE
          IAT = IAT + 1
          ILEFT = 2 * LNONM1 - IAT + 1
          IF(ILEFT.GT.0)THEN
            CALL FIND6(TEMP3(IAT),ILEFT,RECSEQ(ISTR),LNON,INC,IMATCH)
            IF(IMATCH.GT.0)THEN
              IFOUND = IFOUND + 1
              IF(IFOUND.GT.MAXMAT)THEN
                CALL ERROM(KBOUT,'Too many matches')
                RETURN
              END IF
              NSAVE(IFOUND)=JEN
C  NEED THE CUTPOINT FOR THIS STRING; THE FIRST ONE THIS NAME
C  IS AT PCUT(JEN) IN ARRAY CUTSIT, SO THIS ONE IS AT
C  PCUT(JEN)+IREC-1 = SPOINT IN CUTSIT
              CUTADD(IFOUND) = SPOINT
              IAT = IAT + IMATCH - 1
              KT=IDSEQ - LNON + 1 + IAT + CUTSIT(SPOINT) - INON + 1
              IF(KT.GT.IDSEQ) KT = KT - IDSEQ
              IF(KT.LT.1) KT = ABS(KT) + 1
              PSAVE(IFOUND) = KT
            END IF
            GO TO 51
          END IF
        END IF
50    CONTINUE
      IOK = 0
      END
      SUBROUTINE S1D1(SEQ,IDSEQ,NREC,JEN,IREC,J1,J2,INC,KSTART,
     +RECSTR,MAXEN,PSAVE,NSAVE,MAXMAT,RECSEQ,IDRSEQ,IFOUND,
     +PCUT,CUTSIT,LENEN,MAXS,CUTADD,IROUND,KBOUT,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDSEQ),RECSEQ(IDRSEQ),TEMP3(40)
      INTEGER RECSTR(MAXEN),PSAVE(MAXMAT),NSAVE(MAXMAT)
      INTEGER PCUT(MAXEN),CUTSIT(MAXS),CUTADD(MAXMAT),SPOINT
      INTEGER LENEN(MAXS)
      IOK = 1
      LREC = 0
      DO 50 IREC=1,NREC
C       POINT TO START OF STRING
        ISTR=RECSTR(JEN)+(IREC-1)*(LREC)
C       NOTE WE NEED TO POINT TO THE CORRECT ARRAY ELEMENT BUT
C       TO REMEMBER THE SEQUENCE ELEMENT FOR OUTPUT
C       IAT IS THE ARRAY ELEMENT
        IAT = J1-INC-KSTART+1
        SPOINT = PCUT(JEN) + IREC - 1
        LREC = LENEN (SPOINT)
C       FIND FIRST AND LAST NON N CHARS IN STRING
        CALL GETNON(RECSEQ(ISTR),LREC,INON,LNON)
C       CHECK FOR ALL N'S IN STRING!!
        IF(LNON.GT.0)THEN
          ISTR = ISTR + INON - 1
10        CONTINUE
          IAT = IAT+INC
          ILEFT = J2-IAT+1-KSTART+1
          IF(ILEFT.GT.0)THEN
            CALL FIND7(SEQ(IAT),ILEFT,
     +      RECSEQ(ISTR),LNON,INC,IMATCH)
            IF(IMATCH.GT.0)THEN
              IFOUND = IFOUND + 1
              IF(IFOUND.GT.MAXMAT)THEN
                CALL ERROM(KBOUT,'Too many matches')
                RETURN
              END IF
              IAT = IAT + IMATCH - 1
              NSAVE(IFOUND) = JEN
C  NEED THE CUTPOINT FOR THIS STRING; THE FIRST ONE THIS NAME
C  IS AT PCUT(JEN) IN ARRAY CUTSIT, SO THIS ONE IS AT
C  PCUT(JEN)+IREC-1 = SPOINT IN CUTSIT
              CUTADD(IFOUND) = SPOINT
C             SAVE POSITION RELATIVE TO ARRAY
              KT = IAT + CUTSIT(SPOINT) - INON + 1
              IF(KT.GT.IDSEQ)KT = KT - IDSEQ
              IF(KT.LT.0)KT = ABS(KT) + 1
              PSAVE(IFOUND) = KT
              GO TO 10
            END IF
          END IF
          IF(LNON.GE.IDSEQ)GO TO 50
          IF(IROUND.NE.1)GO TO 50
          IAT = 0
          LNONM1 = LNON - 1
          IF(LNONM1.GT.0)THEN
            CALL SQCOPY(SEQ(IDSEQ-LNON+2),TEMP3,LNONM1)
            CALL SQCOPY(SEQ,TEMP3(LNON),LNONM1)
          END IF
51        CONTINUE
          IAT = IAT + 1
          ILEFT = 2 * LNONM1 - IAT + 1
          IF(ILEFT.GT.0)THEN
            CALL FIND7(TEMP3(IAT),ILEFT,RECSEQ(ISTR),LNON,INC,IMATCH)
            IF(IMATCH.GT.0)THEN
              IFOUND = IFOUND + 1
              IF(IFOUND.GT.MAXMAT)THEN
                CALL ERROM(KBOUT,'Too many matches')
                RETURN
              END IF
              NSAVE(IFOUND)=JEN
C  NEED THE CUTPOINT FOR THIS STRING; THE FIRST ONE THIS NAME
C  IS AT PCUT(JEN) IN ARRAY CUTSIT, SO THIS ONE IS AT
C  PCUT(JEN)+IREC-1 = SPOINT IN CUTSIT
              CUTADD(IFOUND) = SPOINT
              IAT = IAT + IMATCH - 1
              KT=IDSEQ - LNON + 1 + IAT + CUTSIT(SPOINT) - INON + 1
              IF(KT.GT.IDSEQ) KT = KT - IDSEQ
              IF(KT.LT.1) KT = ABS(KT) + 1
              PSAVE(IFOUND) = KT
            END IF
            GO TO 51
          END IF
        END IF
50    CONTINUE
      IOK = 0
      END
      SUBROUTINE DECREN(RENZYM,IDREN,RECSEQ,IDRSEQ,NAMES,IDNAML,
     +NAMEP,NAMLEN,NUMREC,LENEN,RECSTR,MAXEN,KBOUT,CUTSIT,PCUT,MAXS)
C   ROUTINE TO DECODE A RESTRICTION ENZYME FILE ARRAY RENZYM IDREN
C   INTO THE FOLLOWING:
C   A CONCATENATED ARRAY OF RECOGNITION SEQUENCES RECSEQ IDRSEQ PREC
C   A CONCATENATED ARRAY OF ENZYME NAMES NAMES IDNAML,PNAM
C   A LIST OF POINTERS TO ENZYME NAMES IN NAMES NAMEP MAXEN ITOTEN
C   A LIST OF ENZYME NAME LENGTHS NAMLEN MAXEN ITOTEN
C   A LIST OF NUMBERS OF RECOGNITION SEQUENCES PER ENZYME NUMREC MAXEN
C   A LIST OF LENGHTS OF RECOGNITION SEQUENCES PER RECOGNITION SEQUENCE
C   LENEN MAXEN ITOTEN
C   A LIST OF POINTERS TO THE FIRST CHARACTER OF THE FIRST RECOGNITION
C   SEQUENCE PER ENZYME RECSTR MAXEN ITOTEN
C   A LIST OF CUTSITES PER SEQUENCE CUTSIT
C   A LIST OF START POSITIONS FOR CUTSITES PER NAME PCUT (ALSO USED
C   FOR LENGTHS OF RECOGNITION SEQUENCES)
C   AUTHOR: RODGER STADEN
      CHARACTER RENZYM(IDREN),RECSEQ(IDRSEQ),NAMES(IDNAML)
      INTEGER NAMEP(MAXEN),NAMLEN(MAXEN),NUMREC(MAXEN),LENEN(MAXEN)
      INTEGER RECSTR(MAXEN),TOTEN,PREC,PREN,PNAM
      INTEGER CUTSIT(MAXEN),PCUT(MAXEN)
      CHARACTER CUT
      EXTERNAL INDEXA
      SAVE CUT
      DATA CUT/''''/
C NB CUTSIT SHOULD REALLY BE DIMENSIONED TO BE LARGER THAN THE 
C MAX NUMBER OF ENZYMES AS IT WILL BE LONGER
C
C   set enzyme count to zero
      TOTEN=0
C   point to string store
      PREC=1
C   point to renzym
      PREN=0
C   point to names array
      PNAM=1
C   SET NUMBER OF CUTPOINTS TO ZERO. IT IS EQUAL TO THE NUMBER OF 
C   OF RECOGNITION SEQUENCES. NOTE THEY CAN ALMOST ALL BE CODED AS SINGLE
C   SEQUENCES USING THE NC-IUB CODES, BUT SOMETIMES, IF THE CUTSITE IS
C   NON-SYMMETRICAL TWO ARE NEEDED
      ICUT = 0
C
10    CONTINUE
      PREN=PREN+1
      IF(PREN.LT.IDREN)THEN
C   some data left
C   should be pointing at start of name, count its chars
        CALL CHARCT(RENZYM,IDREN,PREN,NCHAR)
        IF(NCHAR.GT.0)THEN
C   found a name
C   increment number of enzymes
          TOTEN=TOTEN+1
          IF(TOTEN.LT.MAXEN)THEN
C   space left for enzymes
            IF((PNAM+NCHAR-1).GT.IDNAML)THEN
              CALL ERROM(KBOUT,'Names array full')
              GO TO 101
            END IF
C   space for name
C   store name start position, length of name
            NAMEP(TOTEN)=PNAM
            NAMLEN(TOTEN)=NCHAR
            CALL SQCOPY(RENZYM(PREN),NAMES(PNAM),NCHAR)
            PNAM=PNAM+NCHAR
C   count number of strings this enzyme
            NREC=0
20          CONTINUE
C   point to first char of string
            PREN=PREN+NCHAR+1
C   count chars in string
            NCHAR=0
            IF(PREN.LT.IDREN)CALL CHARCT(RENZYM,IDREN,PREN,NCHAR)
            IF(NCHAR.EQ.0)THEN
C   no chars in string. If first string then error, else no more strings
              IF(NREC.EQ.0)THEN
                CALL ERROM(KBOUT,'Name with no strings')
C   decrease number of enzymes
                TOTEN=TOTEN-1
                GO TO 100
              END IF
C   some strings
C   save number of strings this enzyme
              NUMREC(TOTEN)=NREC
C
              GO TO 10
            END IF
C   nonzero string length
            NREC=NREC+1
******************************************
C   SAVE ITS START POSITION IN RECSEQ IF FIRST THIS NAME
            IF(NREC.EQ.1)RECSTR(TOTEN)=PREC
C FIND CUTSITE
            JCUT=INDEXA(RENZYM(PREN),NCHAR,CUT)
C IF JCUT IS ZERO THEN NO CUTSITE MARKED
            IF(ICUT.GE.MAXEN)GO TO 200
            ICUT = ICUT + 1
            CUTSIT(ICUT) = 0
C IF FIRST CUTSITE THIS NAME SAVE ITS POINTER
            IF(NREC.EQ.1)PCUT(TOTEN) = ICUT
            IF(JCUT.GT.0)THEN
              NL = JCUT - 1
              NR = NCHAR - JCUT
              CUTSIT(ICUT) = NL
C  COPY UP TO CUT
              IF(NL.GT.0)THEN
                CALL SQCOPY(RENZYM(PREN),RECSEQ(PREC),NL)
                PREC = PREC + NL
              END IF
C  COPY AFTER CUT
              IF(NR.GT.0)THEN
                IPREN = PREN + NL + 1
                CALL SQCOPY(RENZYM(IPREN),RECSEQ(PREC),NR)
                PREC = PREC + NR
              END IF
              LENEN(ICUT) = NCHAR - 1
C  (REDUCED NCHAR BY 1 TO ALLOW FOR CUT)
            ELSE
C
C  NO CUT SITE MARKED, USE OLD CODE
******************************************
C   copy string to recseq
              CALL SQCOPY(RENZYM(PREN),RECSEQ(PREC),NCHAR)
C
              PREC=PREC+NCHAR
              LENEN(ICUT) = NCHAR
            END IF
C   now look for next string
            GO TO 20
          END IF
C   too many enzymes
          CALL ERROM(KBOUT,'Too many names')
          GO TO 100
        END IF
C   deal with name of zero length
        CALL ERROM(KBOUT,'Error in names and strings file')
      END IF
C   now at end of file
100   CONTINUE
101   CONTINUE
C   return length of names array
      IDNAML=PNAM-1
C   return number of enzymes
      MAXEN=TOTEN
C   return length of recseq
      IDRSEQ=PREC
C  RETURN NUMBER OF RECOGNITION SEQUENCES
      MAXS = ICUT
      RETURN
200   CONTINUE
C  COME HERE WITH OVERFLOW OF CUTSITES
C
C  REDUCE NUMBER OF NAMES BY 1
      MAXEN = TOTEN - 1
      IDNAML = PNAM - 1
      IDRSEQ = PREC
C  RETURN NUMBER OF RECOGNITION SEQUENCES
      MAXS = ICUT
      END
      SUBROUTINE GETREN(RENZYM,IDREN,IDEV,FILNAM,FILE4,FILE6,FILEA,
     + IOK,KBIN,KBOUT,IFILE,DIALOG,
     +IHELPS,IHELPE,HELPF,IDEVH)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER FILNAM*(*),FILE4*(*),FILE6*(*),FILEA*(*),RENZYM(IDREN)
      INTEGER DIALOG
      PARAMETER (MAXPRM = 16)
      CHARACTER PROMPT(5)*(MAXPRM)
      IOK = 1
      IF(DIALOG.EQ.0) NOPT = IFILE
      IOP = 1
1     CONTINUE
      IF(DIALOG.EQ.1) THEN
        IOP = 1
        PROMPT(1) = 'Search'
        PROMPT(2) = 'List enzyme file'
        PROMPT(3) = 'Clear text'
        PROMPT(4) = 'Clear graphics'
        CALL RADION('Select operation',PROMPT,4,IOP,
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(IOP.LT.1) THEN
          IOK = 1
          RETURN
        END IF
        IF(IOP.EQ.3) THEN
          CALL CLEARV
          CALL BPAUSE(KBIN,KBOUT,IOK)
          IF(IOK.NE.0) RETURN
          GO TO 1
        END IF
        IF(IOP.EQ.4) THEN
          CALL CLEARG
          CALL BPAUSE(KBIN,KBOUT,IOK)
          IF(IOK.NE.0) RETURN
          GO TO 1
        END IF
        IF((IOP.EQ.1).OR.(IOP.EQ.2)) THEN
          NOPT = IFILE
          PROMPT(1) = 'All enzymes file'
          PROMPT(2) = 'Six cutter file'
          PROMPT(3) = 'Four cutter file'
          PROMPT(4) = 'Personal file'
          PROMPT(5) = 'Keyboard'
          CALL RADION('Select input source',PROMPT,5,NOPT,
     +    IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
          IF(NOPT.LT.1) THEN
              IOK = 1
            RETURN
          END IF
        END IF
      END IF
      IF(NOPT.EQ.3)THEN
        CALL OPENRS(IDEV,FILE4,IOK,LRECL,2)
        IF(IOK.NE.0)GO TO 100
        IF(IOP.EQ.2)THEN
          CALL TTEXT1(IDEV,KBIN,KBOUT,
     +    IHELPS,IHELPE,HELPF,IDEVH,IQUIT)
          GO TO 1
        END IF
        CALL ARRFIL(IDEV,RENZYM,IDREN,KBOUT)
        CLOSE(UNIT=IDEV)
        RETURN
      END IF
      IF(NOPT.EQ.2)THEN
        CALL OPENRS(IDEV,FILE6,IOK,LRECL,2)
        IF(IOK.NE.0)GO TO 100
        IF(IOP.EQ.2)THEN
          CALL TTEXT1(IDEV,KBIN,KBOUT,
     +    IHELPS,IHELPE,HELPF,IDEVH,IQUIT)
          GO TO 1
        END IF
        CALL ARRFIL(IDEV,RENZYM,IDREN,KBOUT)
        CLOSE(UNIT=IDEV)
        RETURN
      END IF
      IF(NOPT.EQ.1)THEN
        CALL OPENRS(IDEV,FILEA,IOK,LRECL,2)
        IF(IOK.NE.0)GO TO 100
        IF(IOP.EQ.2)THEN
          CALL TTEXT1(IDEV,KBIN,KBOUT,
     +    IHELPS,IHELPE,HELPF,IDEVH,IQUIT)
          GO TO 1
        END IF
        CALL ARRFIL(IDEV,RENZYM,IDREN,KBOUT)
        CLOSE(UNIT=IDEV)
        RETURN
      END IF
      IF(NOPT.EQ.4)THEN
10      CONTINUE
        FILNAM = ' '
        CALL OPENF1(IDEV,FILNAM,0,IOK,KBIN,KBOUT,
     +  'Restriction enzyme file',
     +  IHELPS,IHELPE,HELPF,IDEVH)
        IF(IOK.EQ.2) GO TO 1
        IF(IOK.NE.0)GO TO 100
        IF(IOP.EQ.2)THEN
          CALL TTEXT1(IDEV,KBIN,KBOUT,
     +    IHELPS,IHELPE,HELPF,IDEVH,IQUIT)
          GO TO 1
        END IF
        CALL ARRFIL(IDEV,RENZYM,IDREN,KBOUT)
        CLOSE(UNIT=IDEV)
        RETURN
      END IF
      IF(NOPT.EQ.5)THEN
        CALL GETRKB(RENZYM,IDREN,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,
     +  IOK)
        RETURN
      END IF
      GO TO 1
100   CONTINUE
      CALL ERROM(KBOUT,'Error opening file')
      IOK=1
      GO TO 1
      END
      SUBROUTINE FIND6(SEQ,IDIM1,STRING,IDIM2,INC,IMATCH)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1),STRING(IDIM2)
      INTEGER PSEQ,PSTR
      EXTERNAL IUBM1
      PSEQ=1-1*INC
      PSTR=1
      IMATCH=0
100   CONTINUE
        PSEQ=PSEQ+1-PSTR
        PSEQ=PSEQ+INC-1
        PSTR=0
500     CONTINUE
          PSEQ=PSEQ+1
          IF(PSEQ.GT.IDIM1)RETURN
          PSTR=PSTR+1
          IUBMAT = IUBM1(STRING(PSTR),SEQ(PSEQ))
        IF(IUBMAT.EQ.0)GO TO 100
      IF(PSTR.LT.IDIM2)GO TO 500
      IMATCH=PSEQ-IDIM2+1
      END
      SUBROUTINE FIND7(SEQ,IDIM1,STRING,IDIM2,INC,IMATCH)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1),STRING(IDIM2)
      INTEGER PSEQ,PSTR
      EXTERNAL IUBM2
      PSEQ=1-1*INC
      PSTR=1
      IMATCH=0
100   CONTINUE
        PSEQ=PSEQ+1-PSTR
        PSEQ=PSEQ+INC-1
        PSTR=0
500     CONTINUE
          PSEQ=PSEQ+1
          IF(PSEQ.GT.IDIM1)RETURN
          PSTR=PSTR+1
          IUBMAT = IUBM2(STRING(PSTR),SEQ(PSEQ))
        IF(IUBMAT.EQ.0)GO TO 100
      IF(PSTR.LT.IDIM2)GO TO 500
      IMATCH=PSEQ-IDIM2+1
      END
      SUBROUTINE GETNON(STRING,IDS,LNOTN,RNOTN)
C   AUTHOR: RODGER STADEN
      CHARACTER STRING(IDS),CHAR
      INTEGER RNOTN
      EXTERNAL NNDEXL,NNDEXR
      PARAMETER (CHAR='N')
C  FIND ENDS OF CHARACTER STRING THAT ARE NOT N
C  RNOTN IS RETURNED AS THE LENGTH OF THE STRING WITHOUT N'S
C  IT WILL BE < 1 IF THE WHOLE STRING IS N'S
      LNOTN = NNDEXL(STRING,IDS,CHAR)
      RNOTN = NNDEXR(STRING,IDS,CHAR)
      RNOTN = RNOTN - LNOTN + 1
      END
      INTEGER FUNCTION NNDEXL(STRING,ID,CHAR)
      CHARACTER STRING(ID),CHAR
C  FUNCTION TO FIND FIRST NON-OCCURRENCE OF CHAR IN STRING
      DO 10 I = 1,ID
        IF(STRING(I).NE.CHAR)THEN
          NNDEXL = I
          RETURN
        END IF
10    CONTINUE
      NNDEXL = ID + 1
      END
      INTEGER FUNCTION NNDEXR(STRING,ID,CHAR)
      CHARACTER STRING(ID),CHAR
C  FUNCTION TO FIND FIRST NON-OCCURRENCE OF CHAR IN STRING
      DO 10 I = ID,1,-1
        IF(STRING(I).NE.CHAR)THEN
          NNDEXR = I
          RETURN
        END IF
10    CONTINUE
      NNDEXR = 0
      END
      SUBROUTINE S2(SEQ,IDSEQ,IFOUND,NAMEP,NAMLEN,LENEN,MAXEN,
     +NSAVE,PSAVE,LENGTH,MAXMAT,NAMES,IDNAML,
     +CUTSIT,MAXS,CUTADD,IROUND,
     +LENN,IDEV,J2,KSTART,JOB)
C 19-2-91 Changed idt and idtrs from 20 each to 15 and 35
C         so names have max length 15 chars and recognition seqs 35
C         for this part of the code.
      PARAMETER (IDT = 15, IDTRS = 35)
      CHARACTER SEQ(IDSEQ),TEMP1(IDT),TEMP2(IDTRS),NAMES(IDNAML),CUTSYM
      INTEGER NAMEP(MAXEN),NAMLEN(MAXEN),LENEN(MAXS)
      INTEGER NSAVE(MAXMAT),PSAVE(MAXMAT),LENGTH(MAXMAT)
      INTEGER CUTSIT(MAXS),CUTADD(MAXMAT)
      EXTERNAL LWRAP3
      SAVE CUTSYM
      DATA CUTSYM/''''/
      WRITE(IDEV,1011)
1011  FORMAT(
     +'      Name            Sequence',
     +'                          Position',
     +' Fragment lengths')
      DO 60 KOUT=1,IFOUND
        KR1=NAMEP(NSAVE(KOUT))
        KS1=PSAVE(KOUT) - CUTSIT(CUTADD(KOUT))
        CALL FILLC(TEMP1,IDT,' ')
        CALL FILLC(TEMP2,IDTRS,' ')
        KR2 = NAMLEN(NSAVE(KOUT))
        CALL SQCOPY(NAMES(KR1),TEMP1,KR2)
        ITEMP1 = 0
        DO 58 ITEMP = 1,CUTSIT(CUTADD(KOUT))
          ITEMP1 = ITEMP
          KS2 = LWRAP3(J2,KS1)
          TEMP2(ITEMP) = SEQ(KS2)
          KS1 = KS1 + 1
58      CONTINUE
        ITEMP1 = ITEMP1 + 1
        TEMP2(ITEMP1) = CUTSYM
        ITEMP1 = ITEMP1 + 1
        DO 59 ITEMP = ITEMP1,LENEN(CUTADD(KOUT))+1
          KS2 = LWRAP3(J2,KS1)
          TEMP2(ITEMP) = SEQ(KS2)
          KS1 = KS1 + 1
59      CONTINUE
        LENN=PSAVE(KOUT)-LENN
        IF(JOB.EQ.0) THEN
          WRITE(IDEV,1008)KOUT,
     +    TEMP1,TEMP2,PSAVE(KOUT)+KSTART-1,LENN,LENGTH(KOUT)
        ELSE IF(JOB.EQ.1) THEN
          WRITE(IDEV,1008)KOUT,
     +    TEMP1,TEMP2,PSAVE(KOUT)+KSTART-1,LENGTH(KOUT)
        END IF
        LENN=PSAVE(KOUT)
1008    FORMAT(' ',I4,' ',15A1,1X,35A1,1X,I6,1X,I6,1X,I6)
60    CONTINUE
      IF(IROUND.EQ.0)THEN
C       need length to end
        LEND = J2-PSAVE(IFOUND)+1-KSTART+1
        IF(JOB.EQ.0)WRITE(IDEV,1020)LEND,LENGTH(IFOUND+1)
        IF(JOB.EQ.1)WRITE(IDEV,1020)LEND
1020    FORMAT(' ',64X,I6,1X,I6)
      END IF
      END
      SUBROUTINE PETER(SEQ,IDSEQ,J1,J2,KSTART,
     +NAMES,IDNAML,NAMEP,NAMLEN,MAXEN,
     +PSAVE,NSAVE,IDEV,IFOUND,LINLEN,PAA,ITRAN)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDSEQ),NAMES(IDNAML),TEMP1*130
      INTEGER NAMEP(MAXEN),NAMLEN(MAXEN),PSAVE(IFOUND),NSAVE(IFOUND)
      CHARACTER TRANF3*3,PAA(125)
      EXTERNAL TRANF3
      EXTERNAL NOTIRL
C  KSTART = SEQ ELEMENT IN SEQ(1)
C  J1 = START OF ACTIVE REGION RELATIVE TO SEQ(1)
C  PSAVE ARE RELATIVE TO SEQ(1)
C  WORK RELATIVE TO ARRAY SEQ
      NLINES = 1 + (J2 - J1)/LINLEN
      I1 = J1
      I2 = MIN(J2,I1+LINLEN-1)
      NEXTE = 1
      ITMAX = J2 - 2
      DO 100 KK = 1,NLINES
        TEMP1 = ' '
        LP1 = 0
        DO 50 I = NEXTE,IFOUND
          KS1=PSAVE(I)
          IF(KS1.GT.I2)THEN
            NEXTES = I
            GO TO 51
          END IF
            KR1=NAMEP(NSAVE(I))
            LP = KS1 - I1 + 1
C TRAP FOR CUTSITE OUT OF RANGE!!!!!!
            IF(LP.LT.0)THEN
              WRITE(IDEV,1004)(NAMES(K),K=KR1,KR1+NAMLEN(NSAVE(I))-1)
1004          FORMAT(' WARNING:',
     +        ' Recognition site with cut off end for enzyme ',20A1)
              WRITE(IDEV,1005)
1005          FORMAT(//)
            END IF
            IF(LP.GT.0)THEN
            IF(LP.LE.LP1)THEN
              WRITE(IDEV,1000)TEMP1(1:MAX(1,NOTIRL(TEMP1,130,' ')))
1000          FORMAT(' ',A)
              CALL DOTTY(TEMP1)
            END IF
            DO 66 ITEMP=1,NAMLEN(NSAVE(I))
              TEMP1(LP:LP)=NAMES(KR1)
              KR1=KR1+1
              LP = LP + 1
66          CONTINUE
            LP1 = LP
            END IF
            NEXTES = I + 1
50       CONTINUE
51       CONTINUE
         WRITE(IDEV,1000)TEMP1(1:MAX(1,NOTIRL(TEMP1,130,' ')))
         NEXTE = NEXTES
         WRITE(IDEV,1001)(SEQ(K),K=I1,I2)
         WRITE(IDEV,1002)(K,K=I1+9+KSTART-1,I2+KSTART-1,10)
         IF(ITRAN.NE.1)THEN
           WRITE(IDEV,1010)(TRANF3(SEQ(K),PAA,ITRAN),
     +     K=I1,MIN(ITMAX,I2-1),3)
           WRITE(IDEV,1011)(TRANF3(SEQ(K),PAA,ITRAN),
     +     K=I1+1,MIN(ITMAX,I2),3)
           WRITE(IDEV,1012)(TRANF3(SEQ(K),PAA,ITRAN),
     +     K=I1+2,MIN(ITMAX,I2+1),3)
         END IF
         WRITE(IDEV,1003)
1003     FORMAT(' ')
1002     FORMAT(' ',10I10)
1001     FORMAT(' ',100A1)
1010  FORMAT(1X,40(A))
1011  FORMAT(2X,40(A))
1012  FORMAT(3X,40(A))
         I1 = I2 + 1
         I2 = MIN((I1+LINLEN-1),J2)
100    CONTINUE
       END
       SUBROUTINE DOTTY(TEMP)
       CHARACTER TEMP*(*),DOT
       PARAMETER (DOT='.')
       DO 10 I = LEN(TEMP),2,-1
         IF(TEMP(I:I).NE.' ')THEN
           IF(TEMP(I:I).NE.DOT)THEN
             IF((TEMP(I-1:I-1).EQ.' ').OR.(TEMP(I-1:I-1).EQ.DOT))THEN
               TEMP(I:I) = DOT
             ELSE
               TEMP(I:I) = ' '
             END IF
           END IF
         END IF
10     CONTINUE
       IF(TEMP(1:1).NE.' ')TEMP(1:1) = DOT
       END
      SUBROUTINE SEQFIT(SEQNCE,IDIM1,SEQ2,IDIM3I,ITOT,ITOTEL,ITOTID,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,
     +IDEV,IDEVIN,FILE2,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,DIALOG)
C   AUTHOR: RODGER STADEN
      INTEGER DIALOG
      PARAMETER (MAXSTR = 50)
      CHARACTER HELPF*(*)
      CHARACTER SEQNCE(IDIM1),STRING(MAXSTR)
      CHARACTER SEQ2(IDIM3I),FILE2*(*)
      CHARACTER MATCH(MAXSTR)
      INTEGER ITOT(ITOTID),ITOTEL(ITOTID)
      INTEGER ANSTY
      CALL SHOWFU(KBOUT,'Find percentage matches')
      IDIM2 = 0
      IDIM2I = MAXSTR
      IDIM3 = IDIM3I
      IS = J1
      IE = J2
      ISS = 1
      ISE = 10
      CALL GETPAR(18,2,IOK,ANSTY,IPR,
     +IPAR3,IPAR4,IPAR5,
     +IPAR6,IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      PR = REAL(IPR)
5     CONTINUE
      IF(DIALOG.EQ.1) THEN
        CALL SQPFD1(SEQ2,IDIM3I,IDIM3,ANSTY,IDEVIN,FILE2,
     +  KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
10    CONTINUE
      CALL SQPFD2(SEQ2,IDIM3,MATCH,STRING,
     +J1,J2,KSTART,ISS,ISE,IS,IE,IDIM2I,IDIM2,MAXSTR,PR,ANSTY,MINP,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      CALL SQPF6(SEQNCE,IDIM1,STRING,IDIM2,ITOT,ITOTEL,ITOTID,
     +IS,IE,MINP,ITOTP,KSTART,J1,J2,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IOK)
      IF(IOK.EQ.2)THEN
        WRITE(KBOUT,1017)ITOTID
1017    FORMAT(/,' More than',I6,' matches.',
     +  ' Try changing percentage or region'/)
        GO TO 10
      END IF
      IF(IOK.NE.0) RETURN
      CALL SQPF7(SEQNCE,IDIM1,STRING,IDIM2,MATCH,ITOT,ITOTEL,ITOTID,
     +ITOTP,KSTART,J1,J2,ISS,PR,IDEV,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,IOK)
      IF(IOK.NE.0) RETURN
      GO TO 10
      END
      SUBROUTINE SQPFD2(SEQ2,IDIM3,MATCH,STRING,
     +J1,J2,KSTART,ISS,ISE,IS,IE,IDIM2I,IDIM2,MAXSTR,PR,ANSTY,MINP,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER HELPF*(*)
      CHARACTER STRING(MAXSTR)
      CHARACTER SEQ2(IDIM3)
      CHARACTER MATCH(MAXSTR)
      INTEGER ANSC,ANSTY
      IOK = 1
      CALL YESNO(ANSC,'Keep picture',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(ANSC.LT.0)RETURN
      IF(ANSC.EQ.1)CALL CLEARG
      IF(ANSTY.EQ.1) THEN
        CALL SQPF2(SEQ2,IDIM3,STRING,IDIM2I,IDIM2,ISS,ISE,
     +  KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      IF(ANSTY.EQ.0) THEN
        CALL SQPF3(STRING,MATCH,IDIM2I,IDIM2,
     +  KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      CALL SQPF8(STRING,IDIM2,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
C      CALL SQPF4(KBIN,KBOUT,J1,J2,IS,IE,
C     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
C      IF(IOK.NE.0) RETURN
      CALL SQPF5(IDIM2,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,PR,MINP,IOK)
C      IF(IOK.NE.0) RETURN
      RETURN
      END
      SUBROUTINE SQPF6(SEQNCE,IDIM1,STRING,IDIM2,ITOT,ITOTEL,ITOTID,
     +IS,IE,MINP,ITOTP,KSTART,J1,J2,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IOK)
      CHARACTER SEQNCE(IDIM1),STRING(IDIM2)
      INTEGER ITOT(ITOTID),ITOTEL(ITOTID)
      IOK = 1
      CALL FILLI(ITOT,ITOTID,0)
      CALL FILLI(ITOTEL,ITOTID,0)
      CALL SQFIT6(SEQNCE,IDIM1,STRING,IDIM2,ITOT,ITOTEL,ITOTID,
     +IS,IE,MINP,ITOTP,KSTART)
      IF(ITOTP.GT.ITOTID)THEN
        IOK = 2
        RETURN
      END IF
      IF(ITOTP.GT.0)THEN
        XMIN=J1
        XMAX=J2
        YMIN=0.
        YMAX=IDIM2
        CALL CLEARV
        CALL VECTOM
        CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
        DO 203 I=1,ITOTP
          X=ITOTEL(I)
          Y=ITOT(I)
          CALL LINE(X,X,YMIN,Y,XMAX,XMIN,YMAX,YMIN,
     +    MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
203     CONTINUE
      END IF
      CALL VT100M
      IOK = 0
      END
      SUBROUTINE SQPF8(STRING,LENGTH,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER STRING(LENGTH)
      IOK = 1
      IANSC = 0
      WRITE(KBOUT,1000)(STRING(K),K=1,LENGTH)
1000  FORMAT(' STRING=',50A1)
      CALL YESNO(IANSC,'This sense',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IANSC.LT.0)RETURN
      IF(IANSC.EQ.1)THEN
        CALL SQREV(STRING,LENGTH)
        CALL SQCOM2(STRING,LENGTH)
        WRITE(KBOUT,1000)(STRING(K),K=1,LENGTH)
      END IF
      IOK = 0
      END
      SUBROUTINE SEPFIT(SEQNCE,IDIM1,SEQ2,IDIM3I,ITOT,ITOTEL,ITOTID,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,
     +IDEV,IDEVIN,FILE2,KBIN,KBOUT,MATRIX,IDM,
     +IHELPS,IHELPE,HELPF,IDEVH,DIALOG)
C   AUTHOR: RODGER STADEN
      INTEGER DIALOG
      PARAMETER (MAXSTR = 50)
      CHARACTER HELPF*(*)
      CHARACTER SEQNCE(IDIM1),STRING(MAXSTR)
      CHARACTER SEQ2(IDIM3I),FILE2*(*)
      CHARACTER MATCH(MAXSTR)
      INTEGER ITOT(ITOTID),ITOTEL(ITOTID),MATRIX(IDM,IDM)
      INTEGER ANSTY,SMIN,SMAX
      CALL SHOWFU(KBOUT,'Find matches using a score matrix')
      MINP = 0
      IDIM2 = 0
      IDIM2I = MAXSTR
      IDIM3 = IDIM3I
      IS = J1
      IE = J2
      ISS = 1
      ISE = 10
      CALL GETPAR(19,1,IOK,ANSTY,
     +IPAR2,IPAR3,IPAR4,IPAR5,
     +IPAR6,IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
5     CONTINUE
      IF(DIALOG.EQ.1) THEN
        CALL SQPFD1(SEQ2,IDIM3I,IDIM3,ANSTY,IDEVIN,FILE2,
     +  KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
10    CONTINUE
      CALL SEPFD2(SEQ2,IDIM3,MATCH,STRING,
     +J1,J2,KSTART,ISS,ISE,IS,IE,IDIM2I,IDIM2,MAXSTR,ANSTY,MINP,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,MATRIX,IDM,
     +SMIN,SMAX,IOK)
      IF(IOK.NE.0) RETURN
      CALL SEPF6(SEQNCE,IDIM1,STRING,IDIM2,ITOT,ITOTEL,ITOTID,
     +IS,IE,MINP,ITOTP,KSTART,J1,J2,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,MATRIX,IDM,
     +SMIN,SMAX,IOK)
      IF(IOK.EQ.2)THEN
        WRITE(KBOUT,1017)ITOTID
1017    FORMAT(/,' More than',I6,' matches.',
     +  ' Try changing score or region'/)
        GO TO 10
      END IF
      IF(IOK.NE.0) RETURN
      CALL SEPF7(SEQNCE,IDIM1,STRING,IDIM2,MATCH,ITOT,ITOTEL,ITOTID,
     +ITOTP,MINP,KSTART,J1,J2,ISS,IDEV,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,IOK)
      IF(IOK.NE.0) RETURN
      GO TO 10
      END
      SUBROUTINE SEPFD2(SEQ2,IDIM3,MATCH,STRING,
     +J1,J2,KSTART,ISS,ISE,IS,IE,IDIM2I,IDIM2,MAXSTR,ANSTY,MINP,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,MATRIX,IDM,
     +SMIN,SMAX,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER HELPF*(*)
      CHARACTER STRING(MAXSTR)
      CHARACTER SEQ2(IDIM3)
      CHARACTER MATCH(MAXSTR)
      INTEGER ANSC,ANSTY,MATRIX(IDM,IDM),SMIN,SMAX
      IOK = 1
      CALL YESNO(ANSC,'Keep picture',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(ANSC.LT.0)RETURN
      IF(ANSC.EQ.1)CALL CLEARG
      IF(ANSTY.EQ.1) THEN
        CALL SQPF2(SEQ2,IDIM3,STRING,IDIM2I,IDIM2,ISS,ISE,
     +  KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      IF(ANSTY.EQ.0) THEN
        CALL SQPF3(STRING,MATCH,IDIM2I,IDIM2,
     +  KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      CALL SQPF8(STRING,IDIM2,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
C      CALL SEPF4(KBIN,KBOUT,J1,J2,IS,IE,
C     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
C      IF(IOK.NE.0) RETURN
      CALL SEPF5(IDIM2,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,MINP,MATRIX,IDM,
     +SMIN,SMAX,STRING,IOK)
C      IF(IOK.NE.0) RETURN
      RETURN
      END
      SUBROUTINE SEPF5(IDIM2,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,MINP,MATRIX,IDM,
     +SMIN,SMAX,STRING,IOK)
      CHARACTER HELPF*(*)
      CHARACTER STRING(IDIM2)
      INTEGER MATRIX(IDM,IDM),SMIN,SMAX,VALUE
      IOK = 1
      CALL GTSCR(STRING,IDIM2,MATRIX,IDM,SMIN,SMAX)
      WRITE(KBOUT,1000)SMIN,SMAX
1000  FORMAT(' Minimum score=',I6,' Maximum score=',I6)
      MININ = SMIN
      MAXIN = SMAX
      IF(MINP.EQ.0) MINP = SMAX
      CALL GETINT(MININ,MAXIN,MINP,'Score',VALUE,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MINP = VALUE
      IOK = 0
      END
      SUBROUTINE SEPF6(SEQNCE,IDIM1,STRING,IDIM2,ITOT,ITOTEL,ITOTID,
     +IS,IE,MINP,ITOTP,KSTART,J1,J2,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,MATRIX,IDM,
     +SMIN,SMAX,IOK)
      CHARACTER SEQNCE(IDIM1),STRING(IDIM2)
      INTEGER ITOT(ITOTID),ITOTEL(ITOTID),MATRIX(IDM,IDM)
      INTEGER SMIN,SMAX
      IOK = 1
      CALL FILLI(ITOT,ITOTID,0)
      CALL FILLI(ITOTEL,ITOTID,0)
      CALL SPFIT(SEQNCE,IDIM1,STRING,IDIM2,ITOT,ITOTEL,ITOTID,
     +IS,IE,MINP,ITOTP,MATRIX,IDM,KSTART)
      IF(ITOTP.GT.ITOTID)THEN
        IOK = 2
        RETURN
      END IF
      IF(ITOTP.GT.0)THEN
        XMIN = J1
        XMAX = J2
        YMIN = SMIN
        YMAX = SMAX
        CALL CLEARV
        CALL VECTOM
        CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
        DO 203 I=1,ITOTP
          X=ITOTEL(I)
          Y=ITOT(I)
          CALL LINE(X,X,YMIN,Y,XMAX,XMIN,YMAX,YMIN,
     +    MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
203     CONTINUE
      END IF
      CALL VT100M
      IOK = 0
      END
C      SQFITP
      SUBROUTINE SQFITP(SEQ,IDIM1,STRING,IDIM2,ITOT,ITOTEL,ITOTID,
     +IS,IE,MINP,ITOTP,KSTART)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1),STRING(IDIM2)
      INTEGER ITOT(ITOTID),ITOTEL(ITOTID)
      IDIF=(IE-IS+2)-IDIM2
      IPSEQ=IS-KSTART+1
      ITOTP=0
      DO 200 I=1,IDIF
        NTOT=0
        IP=IPSEQ
        DO 100 J=1,IDIM2
          IF(SEQ(IP).EQ.STRING(J))THEN
            NTOT=NTOT+1
          ELSE IF (STRING(J).EQ.'-')THEN
            NTOT=NTOT+1
          END IF
          IP=IP+1
100     CONTINUE
        IF(NTOT.GE.MINP)THEN
          ITOTP=ITOTP+1
          IF(ITOTP.GT.ITOTID)RETURN
          ITOT(ITOTP)=NTOT
          ITOTEL(ITOTP)=IP-IDIM2+KSTART-1
        END IF
        IPSEQ=IPSEQ+1
200   CONTINUE
      END
      SUBROUTINE SIGNAL(SEQ,IDIM,MARGL,MARGR,MARGB,MARGT,
     +ISXMAX,ISYMAX,J1,J2,IDEV,FILNAM,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IDEVOT,
     +SUM,WT,TOT,IDM,MAXLEN,LINE,CHRSET,DIALOG,JOB)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),FILNAM*(*),HELPF*(*)
      CHARACTER LINE(MAXLEN),CHRSET(IDM)
      INTEGER SUM(IDM,MAXLEN),TOT(MAXLEN),DIALOG
      REAL WT(IDM,MAXLEN)
      CALL SHOWFU(KBOUT,'Motif search using weight matrix')
C      IF(JOB.EQ.2)CALL SHOWFU(KBOUT,'on complementary strand')
      CALL GETPAR(20,1,IOK,IGON,
     +IPAR2,IPAR3,IPAR4,IPAR5,
     +IPAR6,IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      CALL SIGNLD(IDEV,FILNAM,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,
     +SUM,IDM,MAXLEN,TOT,WT,LENGTH,MIDDLE,YMIN,YMAX,
     +IGON,JOB,IDEVOT,LINE,CHRSET,DIALOG,IOK)
      IF(IOK.NE.0) RETURN
      CALL SIGNLP(SEQ,IDIM,MARGL,MARGR,MARGB,MARGT,
     +ISXMAX,ISYMAX,J1,J2,IDEVOT,WT,IDM,MAXLEN,LENGTH,
     +YMIN,YMAX,IGON,MIDDLE)
      END
      SUBROUTINE SIGNLD(IDEV,FILNAM,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,
     +SUM,IDM,MAXLEN,TOT,WT,LENGTH,MIDDLE,YMIN,YMAX,
     +IGON,JOB,IDEVOT,LINE,CHRSET,DIALOG,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER FILNAM*(*),HELPF*(*),LINE(MAXLEN),CHRSET(IDM)
      INTEGER SUM(IDM,MAXLEN),TOT(MAXLEN),DIALOG
      REAL WT(IDM,MAXLEN)
      PARAMETER (MAXPRM = 21)
      CHARACTER PROMPT(3)*(MAXPRM)
      IOK = 1
      IDO = 1
      PROMPT(1) = 'Use weight matrix'
      PROMPT(2) = 'Make weight matrix'
      PROMPT(3) = 'Rescale weight matrix'
      CALL RADION('Select operation',PROMPT,3,IDO,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IDO.LT.1) RETURN
      IF(IDO.GT.1) THEN
        CALL MKWT(WT,SUM,TOT,CHRSET,IDM,MAXLEN,
     +  IDEV,IDEVOT,KBIN,KBOUT,LINE,
     +  FILNAM,IDO,IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IOK = 1
        RETURN
      END IF
      FILNAM = ' '
      CALL OPENF1(IDEV,FILNAM,0,IOK,KBIN,KBOUT,
     +'Motif weight matrix file',
     +IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.NE.0)RETURN
      LENGTH=MAXLEN
      CALL RDWMT(TOT,SUM,MIDDLE,LENGTH,MAXLEN,YMIN,YMAX,IDEV,
     +  IOK,IDM,KBOUT,0)
      IF(IOK.NE.0)THEN
        CALL ERROM(KBOUT,'Error in weight matrix')
        RETURN
      END IF
      IF(DIALOG.EQ.1) THEN
        AMN = -9999.
        AMX = 9999.
        CALL GETRL(AMN,AMX,YMIN,'Cutoff score',VAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        YMIN = VAL
      END IF
      IF(YMIN.LT.0.0)CALL GETW(TOT,SUM,WT,LENGTH,IDM,MAXLEN)
      IF(YMIN.GE.0.0)CALL GETW2(SUM,WT,LENGTH,IDM,MAXLEN)
      IF(JOB.EQ.2)CALL COMPWM(WT,LENGTH,MAXLEN,IDM)
      CALL YESONO(IGON,'Plot results','List results',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IGON.LT.0)RETURN
      IOK = 0
      END
      SUBROUTINE SIGNLP(SEQ,IDIM,MARGL,MARGR,MARGB,MARGT,
     +ISXMAX,ISYMAX,J1,J2,IDEVOT,WT,IDM,MAXLEN,LENGTH,
     +YMIN,YMAX,IGON,MIDDLE)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      REAL WT(IDM,MAXLEN)
      INTEGER CTONUM
      EXTERNAL CTONUM
      XMAX=J2
      XMIN=J1
      IF(IGON.EQ.0)THEN
        CALL CLEARV
        CALL VECTOM
        CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      END IF
      DO 10 I=J1,J2-LENGTH+1
        SUM1=0.
        K=0
        DO 5 J=I,I+LENGTH-1
          K=K+1
          SUM1=SUM1+WT(CTONUM(SEQ(J)),K)
5       CONTINUE
        IF(SUM1.GE.YMIN)THEN
          IF(IGON.EQ.0)THEN
            X=I+MIDDLE
            CALL LINE(X,X,YMIN,SUM1,XMAX,XMIN,YMAX,YMIN,
     +      MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
          END IF
          IF(IGON.EQ.1)THEN
            CALL VT100M
            WRITE(IDEVOT,1010)I+MIDDLE,SUM1,(SEQ(K),K=I,I+LENGTH-1)
1010        FORMAT(' ',I7,F10.2,' ',120A1)
          END IF
        END IF
10    CONTINUE
      CALL VT100M
      RETURN
      END
      SUBROUTINE COMPWM(WTR,LENGTH,MAXL,IDM)
C   AUTHOR: RODGER STADEN
      REAL WTR(IDM,MAXL)
C   COMPLEMENT THE WEIGHT MATRIX
      DO 60 I=1,LENGTH
       DO 60 J=1,2
         T = WTR(J,I)
         WTR(J,I)=WTR(J+2,I)
         WTR(J+2,I)=T
60    CONTINUE
      L = LENGTH/2
      DO 70 I=1,L
       L1 = 1 + LENGTH-I
       DO 70 J=1,IDM
         T = WTR(J,L1)
         WTR(J,L1)=WTR(J,I)
         WTR(J,I)=T
70    CONTINUE
      END
C     AACOMP
      SUBROUTINE AACOMP(SUM,IDEV,PAA)
C   AUTHOR: RODGER STADEN
      REAL SUM(4,4,4),AAWTS(20),EXPERC(20),APERC(20),ASUM(20)
      REAL HYDRO(20)
      CHARACTER PAA(5,5,5),AA(20)
      SAVE AA,AAWTS,EXPERC,HYDRO
      DATA AA/'A','C','D','E','F',
     +'G','H','I','K','L',
     +'M','N','P','Q','R',
     +'S','T','V','W','Y'/
      DATA AAWTS/71.09,103.15,115.10,129.13,147.19,
     +57.07,137.16,113.17,128.19,113.17,
     +131.21,114.12,97.13,128.15,156.20,
     +87.09,101.12,99.15,186.23,163.19/
C  ARGOS VALUES
      DATA EXPERC/8.3,1.7,5.3,6.2,3.9,7.2,2.2,5.2,5.7,
     +9.0,2.4,4.4,5.1,4.0,5.7,6.9,5.8,6.6,1.3,3.2/
C DAYHOFF VALUES
C      DATA EXPERC/8.6,2.9,5.5,6.0,3.6,8.4,2.0,4.5,6.6,
C     17.4,1.7,4.3,5.2,3.9,4.9,7.0,6.1,6.6,1.3,3.4/
      DATA HYDRO/-0.4,0.17,-1.31,-1.22,1.92,
     +-0.67,-0.64,1.25,-0.67,1.22,
     +1.02,-0.92,-0.49,-0.91,-0.59,
     +-0.55,-0.28,0.91,0.50,1.67/
C   hydrophobicity values from r. m. sweet and d. eisenberg, j mol. biol
C   (1983) 171, 479-488
C
C   calc amino acid composition
      CALL FILLR(ASUM,20,0.0)
      TOTAL=0.
      ATOT=0.
      DO 200 I=1,4
      DO 200 J=1,4
      DO 200 K=1,4
      DO 150 L=1,20
        IF(PAA(K,J,I).EQ.AA(L)) THEN
          ASUM(L)=ASUM(L)+SUM(I,J,K)
          ATOT=ATOT+SUM(I,J,K)
          GO TO 151
        END IF
150   CONTINUE
151   CONTINUE
200   CONTINUE
C  set hydrophobicity to zero
      HYDROP=0.
      DO 300 I=1,20
        HYDROP=HYDROP+ASUM(I)*HYDRO(I)
        IF(ATOT.NE.0.)APERC(I)=100.*((100.*ASUM(I)/ATOT)-EXPERC(I))
     +  /EXPERC(I)
C   botch-up to allow use of dayhoff aawts-18.0 (H2O really=18.015)
        TOTAL=TOTAL+ASUM(I)*(AAWTS(I)-0.015)
300   CONTINUE
C   add on one water molecule
      TOTAL=TOTAL+18.015
      WRITE(IDEV,1002)(AA(K),K=1,10)
      WRITE(IDEV,1003)(ASUM(K),K=1,10)
      WRITE(IDEV,1005)(APERC(K),K=1,10)
      WRITE(IDEV,1002)(AA(K),K=11,20)
      WRITE(IDEV,1003)(ASUM(K),K=11,20)
      WRITE(IDEV,1005)(APERC(K),K=11,20)
1005  FORMAT(' O-E % ',10F5.0)
1006  FORMAT(' EXP % ',10F4.0)
1002  FORMAT(/'       ',10(3X,A1,1X))
1003  FORMAT('       ',10F5.0)
      WRITE(IDEV,1004)ATOT,TOTAL,HYDROP
1004  FORMAT(' Total acids=',F6.0,' Molecular weight=',F10.0,
     +' Hydrophobicity=',F6.1)
      END
C     BCOMPC
      SUBROUTINE BCOMPC(SUM,IDEV)
C   AUTHOR: RODGER STADEN
      REAL SUM(4,4,4),COMP(4,3),COMPO(4,3),BCOMP(4),BCOMPX(4)
      CHARACTER BASE(4)
      SAVE BASE
      DATA BASE/'T','C','A','G'/
C   calc base composition
      TCOMP=0.
      DO 50 I=1,4
        BCOMP(I)=0.
        DO 50 J=1,3
          COMPO(I,J)=0.
          COMP(I,J)=0.
50    CONTINUE
      DO 55 J=1,4
      DO 55 K=1,4
      DO 55 L=1,4
        TCOMP=TCOMP+SUM(J,K,L)
        BCOMP(J)=BCOMP(J)+SUM(J,K,L)+SUM(K,J,L)+SUM(K,L,J)
        COMP(J,1)=COMP(J,1)+SUM(J,K,L)
        COMP(J,2)=COMP(J,2)+SUM(K,J,L)
        COMP(J,3)=COMP(J,3)+SUM(K,L,J)
55    CONTINUE
      WRITE(IDEV,1013)TCOMP
1013  FORMAT('  Total codons=',F10.0)
C   calc % composition
      DO 60 I=1,4
      DO 60 J=1,3
        IF(TCOMP.NE.0.)COMPO(I,J)=COMP(I,J)*100./TCOMP
        IF(BCOMP(I).NE.0.)COMP(I,J)=COMP(I,J)*100./BCOMP(I)
60    CONTINUE
      WRITE(IDEV,1010)BASE
1010  FORMAT(4(10X,A1))
      WRITE(IDEV,1011)(J,(COMP(I,J),I=1,4),J=1,3)
      WRITE(IDEV,1000)
1000  FORMAT('  ',4('      -----'))
      WRITE(IDEV,1002)
1002  FORMAT('  =',4('     100%  '))
      WRITE(IDEV,1001)(J,(COMPO(I,J),I=1,4),J=1,3)
1011  FORMAT(3(/2X,I1,(4(F10.2,1X))))
1001  FORMAT(3(/2X,I1,(4(F10.2,1X)),' = 100%'))
      DO 65 I=1,4
        IF(TCOMP.NE.0.)BCOMP(I)=BCOMP(I)*33.3333/TCOMP
65    CONTINUE
      WRITE(IDEV,1012)BCOMP
1012  FORMAT(2X,'%',4(F10.2,1X),' Observed, overall totals')
1014  FORMAT(2X,'%',4(F10.2,1X),' Expected, even codons per acid')
      CALL BCOMPE(SUM,BCOMPX)
      WRITE(IDEV,1014)BCOMPX
      END
      SUBROUTINE BCOMPE(FABC,BCOMP)
C   AUTHOR: RODGER STADEN
      INTEGER NCODON(21),IACID(4,4,4)
      REAL FABC(4,4,4),FA(21),BCOMP(4)
C    array with number of codons per acid
      SAVE IACID,NCODON
      DATA IACID/
     +  1,2,3,5,6,7,8,9,
     +  10,12,14,16,18,20,6,21,
     +  1,2,3,5,6,7,8,9,
     +  10,12,14,16,18,20,6,21,
     +  2,2,3,5,6,7,8,9,
     +  11,13,15,17,11,20,20,21,
     +  2,2,4,5,6,7,8,9,
     +  11,13,15,17,19,20,20,21/
      DATA NCODON/
     +  2,6,3,1,4,6,4,4,4,2,3,2,2,2,2,2,2,2,1,6,4/
      TOTAL=0.
      CALL FILLR(BCOMP,4,0.)
      CALL FILLR(FA,21,0.)
      DO 20 I=1,4
      DO 20 J=1,4
      DO 20 K=1,4
C   point to this acid
        JACID=IACID(I,J,K)
C   sum its codons
        FA(JACID)=FA(JACID)+FABC(I,J,K)
        TOTAL=TOTAL+FABC(I,J,K)
20    CONTINUE
C   calculate even usage of each acids codons
C   need to look up the acids number, its composition is divided by
C   its number of codons
      DO 21 I=1,4
      DO 21 J=1,4
      DO 21 K=1,4
C   get acid number this codon
        JACID=IACID(I,J,K)
        BCOMP(I)=BCOMP(I)+FA(JACID)/(REAL(NCODON(JACID)))
        BCOMP(J)=BCOMP(J)+FA(JACID)/(REAL(NCODON(JACID)))
        BCOMP(K)=BCOMP(K)+FA(JACID)/(REAL(NCODON(JACID)))
21    CONTINUE
      DO 22 I=1,4
        IF(TOTAL.NE.0.)BCOMP(I)=BCOMP(I)*33.3333/TOTAL
22    CONTINUE
      END
      SUBROUTINE CALCOD(SUM,SEQ,IDIM)
C   AUTHOR: RODGER STADEN
C   calculates codon totals for defined region
      REAL SUM(4,4,4)
      CHARACTER SEQ(IDIM)
      INTEGER CTONUM
      EXTERNAL CTONUM
      MIN=IDIM/3
      J=1
      DO 100 I=1,MIN
C   test for bad chars
        DO 50 L=1,3
          IP=J-1+L
          IF(CTONUM(SEQ(IP)).EQ.5)GO TO 59
50      CONTINUE
        JP0=J
        JP1=J+1
        JP2=J+2
        JP0=CTONUM(SEQ(JP0))
        JP1=CTONUM(SEQ(JP1))
        JP2=CTONUM(SEQ(JP2))
        SUM(JP0,JP1,JP2)=SUM(JP0,JP1,JP2)+1.
59      CONTINUE
        J=J+3
100   CONTINUE
      END
C   codcom
C   complements a codon table
      SUBROUTINE CODCOM(SUM)
C   AUTHOR: RODGER STADEN
      REAL SUM(4,4,4),TEMP(4,4,4)
      INTEGER IP(4)
      SAVE IP
      DATA IP/3,4,1,2/
      DO 10 I=1,4
      DO 10 J=1,4
      DO 10 K=1,4
        IC=IP(I)
        JC=IP(J)
        KC=IP(K)
        TEMP(I,J,K)=SUM(KC,JC,IC)
10    CONTINUE
      DO 20 I=1,4
      DO 20 J=1,4
      DO 20 K=1,4
        SUM(I,J,K)=TEMP(I,J,K)
20    CONTINUE
      END
      SUBROUTINE CODTBL(IDEV,FILNAM,S2,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,ANSE,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER FILNAM*(*),HELPF*(*)
      INTEGER ANSE
      REAL S2(64)
      IOK = 1
      IOP = ANSE
      CALL YESONO(IOP,'Start with empty table',
     +'Start with an existing table',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IOP.LT.0) RETURN
      ANSE = IOP
      IF(ANSE.EQ.1) THEN
        FILNAM = ' '
        CALL OPENF1(IDEV,FILNAM,0,IOK,KBIN,KBOUT,
     +  'Name of codon table file',
     +  IHELPS,IHELPE,HELPF,IDEVH)
        IF(IOK.NE.0) RETURN
        CALL REDCOD(S2,IDEV)
        CLOSE(UNIT=IDEV)
      END IF
      IOK = 0
      END
      SUBROUTINE LSTSEQ(SEQ,IDIM,IDEV,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,J1,J2,IDIMT,DIALOG)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      INTEGER DIALOG
C   J1 IS THE FIRST BASE IN THE RAM BUFFER
C   J2 IS THE LAST BASE IN THE RAM BUFFER
C   IDIM=J2-J1+1
C   IDIMT IS THE ACTUAL SEQUENCE LENGTH
C   WRAP AROUND IS ONLY POSSIBLE IF J1=1, AND J2=IDIMT
      CALL SHOWFU(KBOUT,'List the sequence')
      I1 = J1
      I2 = J2
      LENGTH = 60
      NSTRND = 0
      IF(DIALOG.EQ.1) THEN
        CALL LSTSQD(IDIM,KBIN,KBOUT,J1,J2,IDIMT,NSTRND,
     +  IHELPS,IHELPE,HELPF,IDEVH,I1,I2,LENGTH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      CALL FMTSEQ(SEQ,IDIM,I1,I2,NSTRND,LENGTH,IDEV,J1,IDIMT)
      END
      SUBROUTINE FMTSEQ(SEQNCE,IDIM,IS1,IE1,NSTRND,LENGTH,IDEV,KSTART,
     +IDIMT)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQNCE(IDIM),SCOMP
      INTEGER K(12)
      EXTERNAL LWRAP,SCOMP
      IS=IS1
      IE=IE1
      LD10=LENGTH/10
      ITOT=IE-IS+1
      IF(IE.LT.IS)ITOT=IDIMT+ITOT
      IDONE=0
      N=IS-1
      WRITE(IDEV,1005)
50    CONTINUE
      IF(IDONE.GE.ITOT)RETURN
      DO 20 I=1,LD10
        N=N+10
        K(I)=N
        IF(K(I).GT.IDIMT)K(I)=K(I)-IDIMT
20    CONTINUE
C   need to find end of this line
      IADD=LENGTH
      IF((IDONE+IADD).GT.ITOT)IADD=ITOT-IDONE
      IE=IS+IADD-1
      LD10M=MIN(LD10,(IE-IS+1)/10)
      IDONE=IDONE+IADD
1001  FORMAT(' ',(12(5X,I6)))
      WRITE(IDEV,1002)
     +(SEQNCE(LWRAP(IDIMT,M)),M=IS-KSTART+1,IE-KSTART+1)
      IF(NSTRND.EQ.1)WRITE(IDEV,1002)(SCOMP(
     1(SEQNCE(LWRAP(IDIMT,M)))),M=IS-KSTART+1,IE-KSTART+1)
      WRITE(IDEV,1001)(K(I),I=1,LD10M)
1002  FORMAT( '  ',12(10A1,1X))
      IS=IE+1
      WRITE(IDEV,1005)
1005  FORMAT(' ')
      GO TO 50
      END
      SUBROUTINE LSTSQD(IDIM,KBIN,KBOUT,J1,J2,IDIMT,NSTRND,
     +IHELPS,IHELPE,HELPF,IDEVH,I1,I2,LENGTH,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER HELPF*(*)
      INTEGER VALUE
      IOK = 1
1     CONTINUE
      VALUE = I1
      CALL GETINT(I1,I2,VALUE,
     +'List from ',
     +VALUE,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0)RETURN
      I1 = VALUE
      VALUE = I2
      CALL GETINT(1,I2,VALUE,
     +'List to ',
     +VALUE,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0)RETURN
      I2 = VALUE
C  IS WRAP AROUND ALLOWED?
      IF(I2.LT.I1)THEN
        IF((J1.NE.1).OR.(J2.NE.IDIMT))THEN
          WRITE(KBOUT,1004)
1004      FORMAT(' A sequence of this length cannot be treated as a',
     +           ' circle')
          GO TO 1
        END IF
      END IF
      IOP = NSTRND
      CALL YESONO(IOP,'Single stranded','Double stranded',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IOP.LT.0) RETURN
      NSTRND = IOP
      MININ = 10
      MAXIN = 120
      LENGTH = 60
      CALL GETINT(MININ,MAXIN,LENGTH,
     +'Line length',
     +VALUE,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0)RETURN
      IF(MOD(VALUE,10).NE.0)VALUE = LENGTH
      LENGTH = VALUE
      END
      SUBROUTINE COMPN(SEQ,IDIM1P,MXSPAN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,DIALOG)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P)
      INTEGER SPAN,SCORES(5),DIALOG
      CALL SHOWFU(KBOUT,'Plot base composition')
      SCORES(5) = 0
      CALL GETPAR(24,10,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +SCORES(1),SCORES(2),SCORES(3),SCORES(4),
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      MAXSP = MIN(MXSPAN,MAXSP,J2-J1+1)
      IF(DIALOG.EQ.1) THEN
        CALL COMPD(MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +  SCORES,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN      
      END IF
      CALL COMPP(SEQ,IDIM1P,MXSPAN,SPAN,IWRIT,SCORES,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2)
      CALL VT100M
      END
      SUBROUTINE COMPD(MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +SCORES,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      CHARACTER HELPF*(*)
      INTEGER SCORES(5)
      CALL CHECK4('T','C','A','G',
     +SCORES(1),SCORES(2),SCORES(3),SCORES(4),
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,IOK)
      IF(IOK.NE.0) RETURN
      CALL GSPIN(MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      END
      SUBROUTINE COMPP(SEQ,IDIM1P,MXSPAN,SPAN,IWRIT,SCORES,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P)
      INTEGER SPAN,SCORES(5),CTONUM
      EXTERNAL CTONUM
C   length forward and back
      LF=SPAN/2
      LB=1+SPAN/2
      SCRMAX=1.
      I1INM1=1+MXSPAN/2
      J1P=J1+I1INM1
      J2P=J2+I1INM1
      XMIN=J1
      XMAX=J2
C   set ymax
      YMAX=SPAN*SCRMAX
      YMIN=0.
C   do edge
      CALL START(SEQ(J1P-LB),IDIM1P,SCORES,5,SPAN,SUM)
      CALL CLEARV
      CALL VECTOM
      CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
C   do rest
      IDONE=0
      XF=J1
      YF=SUM
      DO 100 I=J1P,J2P
        IDONE=IDONE+1
        SUM=SUM+SCORES(CTONUM(SEQ(I+LF)))
     +  -SCORES(CTONUM(SEQ(I-LB)))
        IF(MOD(I,IWRIT).EQ.0)THEN
          XT=I-I1INM1
          CALL LINE(XF,XT,YF,SUM,XMAX,XMIN,YMAX,YMIN,
     +    MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
          XF=XT
          YF=SUM
        END IF
100   CONTINUE
      END
      SUBROUTINE START(SEQ,IDIM,SCORES,IDIMS,LENW,SUM)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      INTEGER SCORES(IDIMS),CTONUM
      EXTERNAL CTONUM
      SUM=0.
      DO 10 I=1,LENW
        SUM=SUM+SCORES(CTONUM(SEQ(I)))
10    CONTINUE
      END
      SUBROUTINE CCHI(SEQ,IDIM1P,MXSPAN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,IENDB,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,WORK,DIALOG)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P)
      PARAMETER (ISIZE = 5)
      INTEGER SPAN,DIALOG
      REAL EXPEC(ISIZE),AVER(ISIZE),OBS(ISIZE),WORK(IDIM1P)
C   NOTE J1 J2 IS THE ACTIVE REGION, KSTART IS THE NUMBER OF THE 
C   BASE IN ELEMENT 1 OF SEQ, AND IDIM1 IS THE LENGTH FROM KSTART
C   TO THE END OF SEQ. PLOTS ARE FROM J1 TO J2 BUT STANDARDS CAN
C   BE TAKEN FROM KSTART TO KSTART+IDIM1-1 = IENDB
C   CHANGED TO ALLOW USER TO DEFINE REGION FOR STANDARD
C   AND TO DO SCALING ONLY OVER REAL SEQUENCE (NOT EDGE) 23-08-84
      CALL SHOWFU(KBOUT,
     +'Plot base composition differences as chi squared')
      CALL GETPAR(25,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      K1 = KSTART
      K2 = IENDB
      IF(DIALOG.EQ.1) THEN
        CALL CHID(KSTART,IENDB,MINSP,MAXSP,SPAN,
     +  MINIW,MAXIW,IWRIT,K1,K2,
     +  KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      CALL CCHIP1(SEQ,IDIM1P,MXSPAN,EXPEC,OBS,AVER,ISIZE,
     +SPAN,IWRIT,K1,K2,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,IENDB,
     +KBOUT,WORK)
      END
      SUBROUTINE CCHIP1(SEQ,IDIM1P,MXSPAN,EXPEC,OBS,AVER,ISIZE,
     +SPAN,IWRIT,K1,K2,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,IENDB,
     +KBOUT,WORK)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P)
      INTEGER SPAN,CTONUM
      REAL EXPEC(ISIZE),AVER(ISIZE),OBS(ISIZE),WORK(IDIM1P)
      EXTERNAL CTONUM,CIE
      DIF = K2 - K1 + 1
      IF(DIF.LT.1.) RETURN
      CALL FILLR(AVER,ISIZE,0.)
      I1INM1= 1 + (MXSPAN/2)-KSTART+1
      CALL CHI1(SEQ(I1INM1+1),IDIM1P,K1,K2,AVER)
      DO 3 I=1,ISIZE
        AVER(I)=AVER(I) / DIF
3     CONTINUE
C   length forward and back
      LF=SPAN/2
      LB=1+SPAN/2
      J1P=J1+I1INM1
      J2P=J2+I1INM1
C   calc expected scores
      DO 29 I=1,ISIZE
        EXPEC(I)=AVER(I)*SPAN
29    CONTINUE
      CALL BUSY(KBOUT)
C   do edge
      CALL FILLR(OBS,ISIZE,0.)
      CALL CHI1(SEQ,IDIM1P,J1P,J1P+SPAN-1,OBS)
C   do rest
      SUMMAX=-99999.
      SUMMIN=999999.
      J = 1
      WORK(J) = CIE(OBS,EXPEC)
      DO 200 I=J1P+LB,J2P-LF
        ISF=CTONUM(SEQ(I+LF))
        ISB=CTONUM(SEQ(I-LB))
        OBS(ISF)=OBS(ISF)+1.
        OBS(ISB)=OBS(ISB)-1.
        SUM = CIE(OBS,EXPEC)
        SUMMAX = MAX(SUMMAX,SUM)
        SUMMIN = MIN(SUMMIN,SUM)
        J = J + 1
        WORK(J) = SUM
200   CONTINUE
      CALL CLEARV
      CALL VECTOM
      IDIMW = J2 - J1 + 1 - SPAN
      XMIN = -LB
      XMAX = IDIMW + LB
      YMAX = SUMMAX
      YMIN = SUMMIN
      CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      CALL PLOTR(WORK,IDIMW,XMAX,XMIN,YMAX,YMIN,IWRIT,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      CALL VT100M
      WRITE(KBOUT,4444)SUMMAX,SUMMIN
4444  FORMAT(' Observed range=',2F12.6)
      END
      REAL FUNCTION CIE(OBS,EXPEC)
      REAL OBS(4),EXPEC(4)
      SUM = 0.
      DO 10 K = 1,4
        TE = EXPEC(K)
        IF(TE.EQ.0.0) GO TO 10
        TO = OBS(K)
        D = TO - TE
        SUM = SUM + D*D/TE
10    CONTINUE
      CIE = SUM
      END
      SUBROUTINE PLOTR(POINTS,IDIMP,XMAX,XMIN,YMAX,YMIN,IWRIT,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      REAL POINTS(IDIMP)
      XF = XMIN
      YF = POINTS(1)
      DO 100 I=1,IDIMP,IWRIT
        XT = I
        YT = POINTS(I)
        CALL LINE(XF,XT,YF,YT,XMAX,XMIN,YMAX,YMIN,
     +  MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
        XF = XT
        YF = YT
100   CONTINUE
      END
      SUBROUTINE CHI1(SEQ,IDIM1P,J1P,J2P,OBS)
      REAL OBS(5)
      CHARACTER SEQ(IDIM1P)
      INTEGER CTONUM
      EXTERNAL CTONUM
      DO 10 I=J1P,J2P
        IS = CTONUM(SEQ(I))
        OBS(IS) = OBS(IS) + 1.
10    CONTINUE
      END
      SUBROUTINE DICHI(SEQ,IDIM1P,MXSPAN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,IENDB,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,WORK,DIALOG)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P)
      PARAMETER (ISIZE = 25)
      INTEGER SPAN,DIALOG
      REAL EXPEC1(ISIZE),AVER1(ISIZE),OBS1(ISIZE)
      REAL EXPEC(5,5),AVER(5,5),OBS(5,5),WORK(IDIM1P)
      EQUIVALENCE (EXPEC1,EXPEC),(AVER1,AVER),(OBS1,OBS)
C   NOTE J1 J2 IS THE ACTIVE REGION, KSTART IS THE NUMBER OF THE 
C   BASE IN ELEMENT 1 OF SEQ, AND IDIM1 IS THE LENGTH FROM KSTART
C   TO THE END OF SEQ. PLOTS ARE FROM J1 TO J2 BUT STANDARDS CAN
C   BE TAKEN FROM KSTART TO KSTART+IDIM1-1 = IENDB
      CALL SHOWFU(KBOUT,
     +'Plot dinucleotide composition differences as chi squared')
C   CHANGED TO ALLOW USER TO DEFINE REGION FOR STANDARD
C   AND TO DO SCALING ONLY OVER REAL SEQUENCE (NOT EDGE) 23-08-84
      CALL GETPAR(26,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      K1 = KSTART
      K2 = IENDB
      IF(DIALOG.EQ.1) THEN
        CALL CHID(KSTART,IENDB,MINSP,MAXSP,SPAN,
     +  MINIW,MAXIW,IWRIT,K1,K2,
     +  KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      CALL DCHIP1(SEQ,IDIM1P,MXSPAN,EXPEC,OBS,AVER,ISIZE,
     +EXPEC1,OBS1,AVER1,
     +SPAN,IWRIT,K1,K2,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,IENDB,
     +KBOUT,WORK)
      END
      SUBROUTINE DCHI1(SEQ,IDIM1P,J1P,J2P,OBS)
      REAL OBS(5,5)
      CHARACTER SEQ(IDIM1P)
      INTEGER CTONUM
      EXTERNAL CTONUM
      DO 10 I=J1P,J2P
        IS = CTONUM(SEQ(I))
        IS1 = CTONUM(SEQ(I+1))
        OBS(IS,IS1) = OBS(IS,IS1) + 1.
10    CONTINUE
      END
      SUBROUTINE DCHIP1(SEQ,IDIM1P,MXSPAN,EXPEC,OBS,AVER,ISIZE,
     +EXPEC1,OBS1,AVER1,
     +SPAN,IWRIT,K1,K2,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,IENDB,
     +KBOUT,WORK)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P)
      INTEGER SPAN,CTONUM
      REAL EXPEC1(ISIZE),AVER1(ISIZE),OBS1(ISIZE)
      REAL EXPEC(5,5),AVER(5,5),OBS(5,5),WORK(IDIM1P)
      EXTERNAL CTONUM,CED
      DIF = K2 - K1
      IF(DIF.LT.2.) RETURN
      CALL BUSY(KBOUT)
      CALL FILLR(AVER1,ISIZE,0.)
      I1INM1=1+(MXSPAN/2)-KSTART+1
      CALL DCHI1(SEQ(I1INM1+1),IDIM1P,K1,K2-1,AVER)
      DO 3 I=1,5
      DO 3 J=1,5
        AVER(I,J)=AVER(I,J) / DIF
3     CONTINUE
C   length forward and back
      LF=SPAN/2
      LB=1+SPAN/2
      J1P=J1+I1INM1
      J2P=J2+I1INM1
C   calc expected scores
      DO 29 I=1,5
      DO 29 J=1,5
        EXPEC(I,J)=AVER(I,J)*SPAN
29    CONTINUE
C   set ymax
C   do edge
      CALL FILLR(OBS1,ISIZE,0.)
      CALL DCHI1(SEQ,IDIM1P,J1P,J1P+SPAN-1,OBS)
      J = 1
      WORK(J) = CED(OBS,EXPEC)
C   do rest
      SUMMAX=-999999.
      SUMMIN=9999999.
      DO 200 I=J1P+LB,J2P-1-LF
        ISF=CTONUM(SEQ(I+LF))
        ISF1=CTONUM(SEQ(I+LF+1))
        ISB=CTONUM(SEQ(I-LB))
        ISB1=CTONUM(SEQ(I-LB+1))
        OBS(ISF,ISF1)=OBS(ISF,ISF1)+1.
        OBS(ISB,ISB1)=OBS(ISB,ISB1)-1.
        SUM = CED(OBS,EXPEC)
        J = J + 1
        WORK(J) = SUM
        SUMMAX=MAX(SUMMAX,SUM)
        SUMMIN=MIN(SUMMIN,SUM)
200   CONTINUE
      CALL CLEARV
      CALL VECTOM
      CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      IDIMW = J2 - J1 - SPAN
      XMIN = -LB
      XMAX = IDIMW + LB
      YMAX = SUMMAX
      YMIN = SUMMIN
      CALL PLOTR(WORK,IDIMW,XMAX,XMIN,YMAX,YMIN,IWRIT,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      CALL VT100M
      WRITE(KBOUT,4444)SUMMAX,SUMMIN
4444  FORMAT(' Observed range=',2F12.6)
      RETURN
      END
      REAL FUNCTION CED(OBS,EXPEC)
      REAL OBS(5,5),EXPEC(5,5)
      SUM = 0.
      DO 10 K=1,4
      DO 10 J=1,4
        TE = EXPEC(K,J)
        IF(TE.EQ.0.) GO TO 10
        TO = OBS(K,J)
        D = TO - TE
        SUM = SUM + D*D/TE
10    CONTINUE
      CED = SUM
      END
      SUBROUTINE TRICHI(SEQ,IDIM1P,MXSPAN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,IENDB,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,WORK,DIALOG)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P)
      PARAMETER (ISIZE = 125)
      INTEGER SPAN,DIALOG
      REAL EXPEC1(ISIZE),AVER1(ISIZE),OBS1(ISIZE)
      REAL EXPEC(5,5,5),AVER(5,5,5),OBS(5,5,5),WORK(IDIM1P)
      EQUIVALENCE (EXPEC1,EXPEC),(AVER1,AVER),(OBS1,OBS)
C   NOTE J1 J2 IS THE ACTIVE REGION, KSTART IS THE NUMBER OF THE 
C   BASE IN ELEMENT 1 OF SEQ, AND IDIM1 IS THE LENGTH FROM KSTART
C   TO THE END OF SEQ. PLOTS ARE FROM J1 TO J2 BUT STANDARDS CAN
C   BE TAKEN FROM KSTART TO KSTART+IDIM1-1 = IENDB
      CALL SHOWFU(KBOUT,
     +'Plot trinucleotide composition differences as chi squared')
C   CHANGED TO ALLOW USER TO DEFINE REGION FOR STANDARD
C   AND TO DO SCALING ONLY OVER REAL SEQUENCE (NOT EDGE) 23-08-84
      CALL GETPAR(27,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      K1 = KSTART
      K2 = IENDB
      IF(DIALOG.EQ.1) THEN
        CALL CHID(KSTART,IENDB,MINSP,MAXSP,SPAN,
     +  MINIW,MAXIW,IWRIT,K1,K2,
     +  KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      CALL TCHIP1(SEQ,IDIM1P,MXSPAN,EXPEC,OBS,AVER,ISIZE,
     +EXPEC1,OBS1,AVER1,
     +SPAN,IWRIT,K1,K2,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,IENDB,
     +KBOUT,WORK)
      END
      SUBROUTINE TCHIP1(SEQ,IDIM1P,MXSPAN,EXPEC,OBS,AVER,ISIZE,
     +EXPEC1,OBS1,AVER1,
     +SPAN,IWRIT,K1,K2,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,IENDB,
     +KBOUT,WORK)
      CHARACTER SEQ(IDIM1P)
      INTEGER SPAN,CTONUM
      REAL EXPEC1(ISIZE),AVER1(ISIZE),OBS1(ISIZE)
      REAL EXPEC(5,5,5),AVER(5,5,5),OBS(5,5,5),WORK(IDIM1P)
      EXTERNAL CTONUM,CET
      DIF = K2 - K1 - 2
      IF(DIF.LT.3.) RETURN
      CALL BUSY(KBOUT)
      CALL FILLR(AVER1,ISIZE,0.)
      I1INM1 = 1 + (MXSPAN/2) - KSTART + 1
      CALL TCHI1(SEQ(I1INM1+1),IDIM1P,K1,K2-2,AVER)
      DO 3 I=1,5
      DO 3 J=1,5
      DO 3 L=1,5
        AVER(I,J,L)=AVER(I,J,L) / DIF
3     CONTINUE
C   length forward and back
      LF=SPAN/2
      LB=1+SPAN/2
      J1P=J1+I1INM1
      J2P=J2+I1INM1
C   calc expected scores
      DO 29 I=1,5
      DO 29 J=1,5
      DO 29 L=1,5
        EXPEC(I,J,L)=AVER(I,J,L)*SPAN
29    CONTINUE
C   do edge
      CALL FILLR(OBS1,ISIZE,0.)
      CALL TCHI1(SEQ,IDIM1P,J1P,J1P+SPAN-1,OBS)
      J = 1
      WORK(J) = CET(OBS,EXPEC)
C   do rest
      SUMMAX=-99999.
      SUMMIN=999999.
      DO 200 I=J1P+LB,J2P-2-LF
        IS=CTONUM(SEQ(I+LF))
        IS1=CTONUM(SEQ(I+LF+1))
        IS2=CTONUM(SEQ(I+LF+2))
        IB=CTONUM(SEQ(I-LB))
        IB1=CTONUM(SEQ(I-LB+1))
        IB2=CTONUM(SEQ(I-LB+2))
        OBS(IS,IS1,IS2)=OBS(IS,IS1,IS2)+1.
        OBS(IB,IB1,IB2)=OBS(IB,IB1,IB2)-1.
        SUM = CET(OBS,EXPEC)
        J = J + 1
        WORK(J) = SUM
        SUMMAX=MAX(SUMMAX,SUM)
        SUMMIN=MIN(SUMMIN,SUM)
200   CONTINUE
      CALL FILLR(OBS1,ISIZE,0.)
      CALL TCHI1(SEQ,IDIM1P,J1P,J1P+SPAN-1,OBS)
      J = 1
      WORK(J) = CET(OBS,EXPEC)
      CALL CLEARV
      CALL VECTOM
      CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      IDIMW = J2 - J1 - 1 - SPAN
      XMIN = -LB
      XMAX = IDIMW + LB
      YMAX = SUMMAX
      YMIN = SUMMIN
      CALL PLOTR(WORK,IDIMW,XMAX,XMIN,YMAX,YMIN,IWRIT,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      CALL VT100M
      WRITE(KBOUT,4444)SUMMAX,SUMMIN
4444  FORMAT(' Observed range=',2F12.6)
      RETURN
      END
      REAL FUNCTION CET(OBS,EXPEC)
      REAL OBS(5,5,5),EXPEC(5,5,5)
      SUM=0.
      DO 10 K=1,4
      DO 10 J=1,4
      DO 10 L=1,4
        TEXP=EXPEC(K,J,L)
        IF(TEXP.EQ.0.)GO TO 10
        TOBS=OBS(K,J,L)
        OME=TOBS-TEXP
        SUM=SUM+(OME*OME)/TEXP
10    CONTINUE
      CET = SUM
      END
      SUBROUTINE TCHI1(SEQ,IDIM1P,J1P,J2P,OBS)
      CHARACTER SEQ(IDIM1P)
      REAL OBS(5,5,5)
      INTEGER CTONUM
      EXTERNAL CTONUM
      DO 10 I=J1P,J2P
        IS=CTONUM(SEQ(I))
        IS1=CTONUM(SEQ(I+1))
        IS2=CTONUM(SEQ(I+2))
        OBS(IS,IS1,IS2)=OBS(IS,IS1,IS2)+1.
10    CONTINUE
      END
      SUBROUTINE NEGP1(SEQ,IDIM1P,MXSPAN,OBS,AVER,
     +SPAN,IWRIT,K1,K2,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,IENDB,
     +KBOUT,WORK)
      CHARACTER SEQ(IDIM1P)
      INTEGER SPAN,OBS(5),CTONUM
      REAL AVER(5),WORK(IDIM1P)
      REAL NEI
      EXTERNAL CTONUM,NEI
      I1INM1=1+(MXSPAN/2)-KSTART+1
      J1P=J1+I1INM1
      J2P=J2+I1INM1
      DIF = K2 - K1 + 1
      IF(DIF.LT.1.) RETURN
      CALL FILLR(AVER,5,0.)
      CALL NEG1(SEQ(I1INM1+1),IDIM1P,K1,K2,AVER)
      DIF = DIF * SPAN
      DO 3 I=1,5
        AVER(I)=AVER(I) / DIF
3     CONTINUE
C   length forward and back
      LF=SPAN/2
      LB=1+SPAN/2
      CALL BUSY(KBOUT)
C   calc expected scores
C   do edge
      CALL FILLI(OBS,5,0)
      DO 166 I=J1P,J1P+SPAN-1
        ISF=CTONUM(SEQ(I+LF))
        ISB=CTONUM(SEQ(I-LB))
        OBS(ISF)=OBS(ISF)+1
        OBS(ISB)=OBS(ISB)-1
166   CONTINUE
      SUMMAX=-99999.
      SUMMIN=999999.
      WIND=SPAN
      J = 1
      WORK(J) = NEI(OBS,AVER,WIND)
      DO 200 I=J1P+LB,J2P-LF
        ISF=CTONUM(SEQ(I+LF))
        ISB=CTONUM(SEQ(I-LB))
        OBS(ISF)=OBS(ISF)+1
        OBS(ISB)=OBS(ISB)-1
        SUM = NEI(OBS,AVER,WIND)
        J = J + 1
        WORK(J) = SUM
        SUMMAX=MAX(SUMMAX,SUM)
        SUMMIN=MIN(SUMMIN,SUM)
200   CONTINUE
C   set ymax
      CALL CLEARV
      CALL VECTOM
      IDIMW = J2 - J1 + 1 - SPAN
      XMIN = -LB
      XMAX = IDIMW + LB
      YMAX = SUMMAX
      YMIN = SUMMIN
      CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      CALL PLOTR(WORK,IDIMW,XMAX,XMIN,YMAX,YMIN,IWRIT,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      CALL VT100M
      WRITE(KBOUT,4444)SUMMAX,SUMMIN
4444  FORMAT(' Observed range=',2F12.6)
      END
      REAL FUNCTION NEI(OBS,AVER,WIND)
      REAL AVER(5)
      INTEGER OBS(5)
      SUM=0.
      DO 10 K=1,4
        TEMP=REAL(OBS(K))*AVER(K)
        IF(TEMP.GT.0.) TEMP1 = TEMP*LOG(TEMP)
        SUM=SUM-TEMP1
10    CONTINUE
      SUM=SUM/WIND
      NEI = SUM
      END
      SUBROUTINE NEG1(SEQ,IDIM1P,K1,K2,AVER)
      CHARACTER SEQ(IDIM1P)
      REAL AVER(5)
      INTEGER CTONUM
      EXTERNAL CTONUM
      DO 2 I=K1,K2
        IS=CTONUM(SEQ(I))
        AVER(IS)=AVER(IS)+1.
2     CONTINUE
      END
      SUBROUTINE NEGENT(SEQ,IDIM1P,MXSPAN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,IENDB,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,WORK,DIALOG)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P)
      PARAMETER (ISIZE = 5)
      INTEGER SPAN,DIALOG
      REAL AVER(ISIZE),WORK(IDIM1P)
      INTEGER OBS(ISIZE)
C   NOTE J1 J2 IS THE ACTIVE REGION, KSTART IS THE NUMBER OF THE 
C   BASE IN ELEMENT 1 OF SEQ, AND IDIM1 IS THE LENGTH FROM KSTART
C   TO THE END OF SEQ. PLOTS ARE FROM J1 TO J2 BUT STANDARDS CAN
C   BE TAKEN FROM KSTART TO KSTART+IDIM1-1 = IENDB
C   CHANGED TO ALLOW USER TO DEFINE REGION FOR STANDARD
C   AND TO DO SCALING ONLY OVER REAL SEQUENCE (NOT EDGE) 23-08-84
      CALL SHOWFU(KBOUT,'Plot negentropy')
      CALL GETPAR(59,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      K1 = KSTART
      K2 = IENDB
      IF(DIALOG.EQ.1) THEN
        CALL CHID(KSTART,IENDB,MINSP,MAXSP,SPAN,
     +  MINIW,MAXIW,IWRIT,K1,K2,
     +  KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      CALL NEGP1(SEQ,IDIM1P,MXSPAN,OBS,AVER,
     +SPAN,IWRIT,K1,K2,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,IENDB,
     +KBOUT,WORK)
      END
      SUBROUTINE CHID(KSTART,IENDB,MINSP,MAXSP,SPAN,
     +MINIW,MAXIW,IWRIT,K1,K2,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      INTEGER SPAN
      IOK = 1
      CALL GTREG(KBIN,KBOUT,KSTART,IENDB,K1,K2,
     +'Define region for standard',
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      CALL GSPIN(MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
C      IF(IOK.NE.0) RETURN
      RETURN
      END
      SUBROUTINE ZDNA(SEQ,IDIM1P,MXSPAN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,DIALOG)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P)
      INTEGER SPAN,SCORE(5,5),CTONUM,DIALOG
      REAL OBS(5,5)
      EXTERNAL CTONUM
      CALL SHOWFU(KBOUT,'Plot z dna potential')
      CALL GETPAR(33,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(DIALOG.EQ.1) THEN
        CALL GSPIN(MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      I1INM1=1+MXSPAN/2
      DO 1 I=1,5
      DO 1 J=1,5
        SCORE(I,J)=0
1     CONTINUE
C  at
      SCORE(3,1)=1
      SCORE(1,3)=1
C  cg
      SCORE(2,4)=1
      SCORE(4,2)=1
C  gt
      SCORE(4,1)=1
      SCORE(1,4)=1
C  ac
      SCORE(3,2)=1
      SCORE(2,3)=1
      J1P=J1+I1INM1
      J2P=J2+I1INM1
      XMIN=J1
      XMAX=J2
C   length forward and back
      LF=SPAN/2
      LB=1+SPAN/2
C   calc expected scores
      YMAX=SPAN
      YMIN=0.
C   do edge
      DO 65 I=1,5
      DO 65 J=1,5
        OBS(I,J)=0.
65    CONTINUE
      DO 66 I=J1P-LB,J1P-LB+SPAN-1
        IS=CTONUM(SEQ(I))
        IS1=CTONUM(SEQ(I+1))
        OBS(IS,IS1)=OBS(IS,IS1)+1.
66    CONTINUE
      CALL CLEARV
      CALL VECTOM
      CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
C   do rest
      XF=J1
      YF=SUM
      DO 100 I=J1P,J2P-1
        ILF=CTONUM(SEQ(I+LF))
        ILF1=CTONUM(SEQ(I+LF+1))
        ILB=CTONUM(SEQ(I-LB))
        ILB1=CTONUM(SEQ(I-LB+1))
        OBS(ILF,ILF1)=OBS(ILF,ILF1)+1.
        OBS(ILB,ILB1)=OBS(ILB,ILB1)-1.
        IF(MOD(I,IWRIT).EQ.0)THEN
          SUM=0.
          DO 99 K=1,4
          DO 99 J=1,4
            SUM=SUM+SCORE(K,J)*OBS(K,J)
99        CONTINUE
          XT=I-I1INM1
          CALL LINE(XF,XT,YF,SUM,XMAX,XMIN,YMAX,YMIN,
     +    MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
          XF=XT
          YF=SUM
        END IF
100   CONTINUE
      CALL VT100M
      END
      SUBROUTINE ZDNARD(SEQ,IDIM1P,MXSPAN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,DIALOG)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P)
      INTEGER SPAN,RVAL(5),YVAL(5),CTONUM,DIALOG
      EXTERNAL CTONUM
      SAVE RVAL,YVAL
      DATA RVAL/0,0,1,1,0/,YVAL/1,1,0,0,0/
      CALL SHOWFU(KBOUT,'Plot z dna potential')
      CALL GETPAR(35,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(DIALOG.EQ.1) THEN
        CALL GSPIN(MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      I1INM1=1+MXSPAN/2
      J1P=J1+I1INM1
      J2P=J2+I1INM1
      XMIN=J1
      XMAX=J2
C   length forward and back
      LF=SPAN/2
      LB=1+SPAN/2
C   calc expected scores
      YMAX=SPAN+1
      YMIN=LF+1
C   do edge
      RSUM1=0.
      YSUM1=0.
      RSUM2=0.
      YSUM2=0.
      DO 66 I=J1P-LB,J1P-LB+SPAN-1,2
        IS=CTONUM(SEQ(I))
        IS1=CTONUM(SEQ(I+1))
        RSUM1=RSUM1+RVAL(IS)
        YSUM1=YSUM1+YVAL(IS1)
        RSUM2=RSUM2+RVAL(IS1)
        YSUM2=YSUM2+YVAL(IS)
66    CONTINUE
      CALL CLEARV
      CALL VECTOM
      CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
C   do rest
      XF=J1
      YF=SUM
      DO 100 I=J1P,J2P-1,2
        ILB=CTONUM(SEQ(I-LB))
        ILB1=CTONUM(SEQ(I-LB+1))
        ILF1=CTONUM(SEQ(I+LF+1))
        ILF2=CTONUM(SEQ(I+LF+2))
        RSUM1=RSUM1-RVAL(ILB)+RVAL(ILF1)
        YSUM1=YSUM1-YVAL(ILB1)+YVAL(ILF2)
        RSUM2=RSUM2-RVAL(ILB1)+RVAL(ILF2)
        YSUM2=YSUM2-YVAL(ILB)+YVAL(ILF1)
        IF(MOD(I,IWRIT).EQ.0)THEN
          SUM=MAX((RSUM1+YSUM1),(RSUM2+YSUM2))
          XT=I-I1INM1
          CALL LINE(XF,XT,YF,SUM,XMAX,XMIN,YMAX,YMIN,
     +    MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
          XF=XT
          YF=SUM
        END IF
100   CONTINUE
      CALL VT100M
      END
      SUBROUTINE ZDNARN(SEQ,IDIM1,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,DIALOG)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1)
      INTEGER SPAN,CTONUM,DIALOG
      EXTERNAL CTONUM
      CALL SHOWFU(KBOUT,'Plot z dna potential')
      CALL GETPAR(34,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(DIALOG.EQ.1) THEN
        CALL GSPIN(MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      XMIN=J1
      XMAX=J2
      YMAX=SPAN
      YMIN=0.
      CALL CLEARV
      CALL VECTOM
      CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
C   do rest
      XF=J1
      YF=0.
      I=J1-1
100   CONTINUE
C
      I=I+1
      IF(I.GT.J2)GO TO 500
      IS=CTONUM(SEQ(I))
      IF(IS.EQ.5)GO TO 100
      SUM=0.
      IF(IS.LT.3)GO TO 300
C   must be a or g
200   CONTINUE
C   want c or t
      I=I+1
      IF(I.GT.J2)GO TO 500
      IS=CTONUM(SEQ(I))
      IF(IS.EQ.5)GO TO 100
      IF(IS.GT.2)GO TO 100
C  have c or t
      SUM=SUM+1.
      IF(MOD(I,IWRIT).EQ.0)THEN
        XT=I
        CALL LINE(XF,XT,YF,SUM,XMAX,XMIN,YMAX,YMIN,
     +  MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
        XF=XT
        YF=SUM
      END IF
C   now want a or g
300   CONTINUE
      I=I+1
      IF(I.GT.J2)GO TO 500
      IS=CTONUM(SEQ(I))
      IF(IS.EQ.5)GO TO 100
      IF(IS.LT.3)GO TO 100
C  have a or g
      SUM=SUM+1.
      IF(MOD(I,IWRIT).EQ.0)THEN
        XT=I
        CALL LINE(XF,XT,YF,SUM,XMAX,XMIN,YMAX,YMIN,
     +  MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
        XF=XT
        YF=SUM
      END IF
C   want c or t
      GO TO 200
500   CONTINUE
      CALL VT100M
      END
      SUBROUTINE GETRC1(KBIN,KBOUT,J1,J2,IDIMT,I1,I2,IDIM1,
     +P,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER HELPF*(*),P*(*)
      INTEGER VALUE
C  VERSION FOR LIST REGION
      IOK = 1
      WRITE(KBOUT,1000)P
1000  FORMAT(' ',A)
1     CONTINUE
      VALUE = J1
      I1 = J1
      I2 = J2
      CALL GETINT(I1,I2,VALUE,
     +'From',
     +VALUE,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0)RETURN
      I1 = VALUE
      VALUE = I2
      K1 = MIN(1,J1)
      CALL GETINT(K1,J2,VALUE,
     +'To',
     +VALUE,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0)RETURN
      I2 = VALUE
C  IS WRAP AROUND ALLOWED?
      IF(I2.LT.I1)THEN
        IF((J1.NE.1).OR.(J2.NE.IDIMT))THEN
          WRITE(KBOUT,1001)
1001      FORMAT(' a sequence of this length cannot be treated as a',
     +    ' circle')
          GO TO 1
        END IF
        I2 = I2 + IDIM1
      END IF
      END
      SUBROUTINE GETRC2(KBIN,KBOUT,J1,J2,IDIMT,I1,I2,
     +P,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER HELPF*(*),P*(*)
      INTEGER VALUE
C  VERSION FOR TRANSLATE REGION
      IOK = 1
      WRITE(KBOUT,1000)P
1000  FORMAT(' ',A)
1     CONTINUE
      VALUE = 0
      I1 = 0
      I2 = J2
      CALL GETINT(I1,I2,VALUE,
     +'From',
     +VALUE,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0)RETURN
      I1 = VALUE
      IF(I1.EQ.0) THEN
        IOK = 0
        RETURN
      END IF
      VALUE = J2
      I2 = J2
      CALL GETINT(1,I2,VALUE,
     +'To',
     +VALUE,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0)RETURN
      I2 = VALUE
C  IS WRAP AROUND ALLOWED?
      IF(I2.LT.I1)THEN
        IF((J1.NE.1).OR.(J2.NE.IDIMT))THEN
          WRITE(KBOUT,1001)
1001      FORMAT(' A sequence of this length cannot be treated as a',
     +    ' circle')
          GO TO 1
        END IF
      END IF
      END
      SUBROUTINE FMTRAN(SEQ,IDIM1,IS,IE,OUTP,IDMP,LENGTH,IDEV,
     + KSTART,IDIMT,CODE)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1),OUTP(IDMP,3),BLANK
      INTEGER IO1(12),CODE
      CHARACTER IT,OUTLIN(132),THREEL*3,THREE*3
      EXTERNAL LWRAP,THREEL
      SAVE BLANK
      DATA BLANK/' '/
      LD10 = LENGTH/10
      ITOT = IE - IS + 1
      IF(IE.LE.IS)ITOT = IDIMT - ITOT
      IDONE = 0
C   SET POINTER TO ELEMENT NUMBERS (TREATING ARRAY AS LINEAR) TO
C   START POINTER
      IBEG = IS - KSTART + 1
      I1 = IS - 1
      WRITE(IDEV,1000)
50    CONTINUE
      IF(IDONE.GE.ITOT)RETURN
C   NEED TO FIND END OF THIS LINE AND  ADD TO COUNT
      IADD = LENGTH
      IF((IDONE + IADD).GT.ITOT)IADD = ITOT - IDONE
      IEND = IBEG + IADD - 1
      IDONE = IDONE + IADD
      LD10M = MIN(LD10,(IEND - IBEG + 1)/10)
      DO 200 J = 1,3
        IBEGP = IBEG + J - 1
        IENDP = IEND + J - 1
C   NUMBER OF CODONS THIS LINE?
        NP = (IENDP - IBEGP + 1)/3
C   TEST FOR NO CODONS
        IF(NP.GT.0)THEN
C   THIS LINE STARTS AT IBEG AND ENDS AT IEND (TREATING ARRAY AS
C   LINEAR) NEED TO KNOW IF THERE ARE ANY AA'S TO OUTPUT.
C   TRANSLATE POINTERS AND TEST THEM
C   FILL OUTP WITH BLANKS
          CALL FILLC(OUTLIN,132,' ')
          IEMPT = 0
          ITMPCS = IBEGP
          L = J - 2
          DO 100 I = 1,NP
            IOUT = LWRAP(IDIM1,ITMPCS)/3 + 1
            ITMPCS = ITMPCS + 3
            IT = OUTP(IOUT,J)
            IF(IT.NE.BLANK)IEMPT = 1
            L = L + 3
            IF(CODE.EQ.3)THEN
              THREE = THREEL(IT)
              OUTLIN(L - 1) = THREE(1:1)
              OUTLIN(L) = THREE(2:2)
              OUTLIN(L + 1) = THREE(3:3)
            ELSE
              OUTLIN(L) = IT
            END IF
100       CONTINUE
          IF(IEMPT.GT.0)
     +     WRITE(IDEV,1002)(OUTLIN(K),K = 1,LENGTH + 6)
        END IF
200   CONTINUE
      WRITE(IDEV,1002)(SEQ(LWRAP(IDIM1,K)),K = IBEG,IEND)
1002  FORMAT(' ',132A1)
      DO 300 K = 1,LD10
        I1 = I1 + 10
        IO1(K) = I1
        IF(IO1(K).GT.IDIMT)IO1(K) = IO1(K) - IDIMT
300   CONTINUE
      WRITE(IDEV,1001)(IO1(K),K = 1,LD10M)
1001  FORMAT( ' ',12(4X,I6))
      IBEG = IEND + 1
      WRITE(IDEV,1000)
1000  FORMAT(/)
      GO TO 50
      END
      SUBROUTINE TRAND4(MINO,MAXO,MINOPN,JSTRAN,FILNAM,IDEV,IOK,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH)
      CHARACTER HELPF*(*),FILNAM*(*)
      IOK = 1
      CALL GETINT(MINO,MAXO,MINOPN,
     +'Minimum open frame in amino acids',
     +IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MINOPN = IVAL
      IVAL = JSTRAN + 1
      CALL GSTRND(IVAL,IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IVAL.LT.1) THEN
        IOK = 1
        RETURN
      END IF
      JSTRAN = IVAL - 1
30    CONTINUE
      FILNAM = ' '
      CALL OPENF1(IDEV,FILNAM,1,IOK,KBIN,KBOUT,
     +'File name for translation',
     +IHELPS,IHELPE,HELPF,IDEVH)
      END
      SUBROUTINE TRAND5(MINO,MAXO,MINOPN,JSTRAN,IOK,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH)
      CHARACTER HELPF*(*)
      IOK = 1
      CALL GETINT(MINO,MAXO,MINOPN,
     +'Minimum open frame in amino acids',
     +IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MINOPN = IVAL
      IVAL = JSTRAN + 1
      CALL GSTRND(IVAL,IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IVAL.LT.1) THEN
        IOK = 1
        RETURN
      END IF
      JSTRAN = IVAL - 1
      END
      SUBROUTINE TRNPIR(SEQ,IDIM,I1,I2,KSTART,KBIN,KBOUT,IDEV,PAA,
     +OUTP,IDIMP,FILNAM,MINO,MAXO,MINOPN,JSTRAN,
     +IHELPS,IHELPE,HELPF,IDEVH)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIMP),PAA(125),OUTP(IDIMP)
      CHARACTER FILNAM*(*),HELPF*(*)
      CALL TRAND4(MINO,MAXO,MINOPN,JSTRAN,FILNAM,IDEV,IOK,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.NE.0) THEN
        CLOSE(UNIT=IDEV)
        RETURN
      END IF
      MINOPD = 3 * MINOPN
      IF(JSTRAN.EQ.0) THEN
        CALL TRNDOP(SEQ,IDIM,I1,I2,OUTP,IDIMP,PAA,MINOPD,IDEV)
      ELSE IF (JSTRAN.EQ.1) THEN
        CALL TRNDOM(SEQ,IDIM,I1,I2,OUTP,IDIMP,PAA,MINOPD,IDEV)
      ELSE IF (JSTRAN.EQ.2) THEN
        CALL TRNDOP(SEQ,IDIM,I1,I2,OUTP,IDIMP,PAA,MINOPD,IDEV)
        CALL TRNDOM(SEQ,IDIM,I1,I2,OUTP,IDIMP,PAA,MINOPD,IDEV)
      END IF
      CLOSE(UNIT=IDEV)
      END
      SUBROUTINE TRNDOP(SEQ,IDDNA,J1,J2,
     +ACIDS,IDACID,PAA,MINOPN,IDEV)
      CHARACTER SEQ(IDDNA),ACIDS(IDACID),PAA(5,5,5)
      CHARACTER LINE*60
      INTEGER STEP(3),FRAME,PSTOP,WPAIR
      EXTERNAL PSTOP,MINIL,WPAIR,ITOSL
C Find open reading frames in their order of occurrence
C For each of 3 frames remember next position to try
      STEP(3) = J1 + 2
      STEP (1) = J1
      STEP(2) = J1 + 1
 10   CONTINUE
      FRAME = MINIL(STEP,3)
      I = STEP(FRAME)
      IF(I.LT.J2) THEN
        J = PSTOP(SEQ,IDDNA,I,J2,ACIDS,IDACID,PAA,IACID)
        STEP(FRAME) = J + 4
        IF((J-I+1).GE.MINOPN) THEN
          LINE(1:) = '>'
          IF (ITOSL(LINE(2:),I).EQ.0) WRITE(*,*)'Scream: ITOSL'
          IF(WPAIR(LINE(22:),I,J).NE.0) WRITE(*,*)'Scream: WPAIR'
            WRITE(IDEV,1001)LINE
            IACID = IACID + 1
            ACIDS(IACID) = '*'
            CALL FMTDKN(IDEV,ACIDS,IACID)
        END IF
        GO TO 10
      END IF
 1001 FORMAT(A)
      END
      SUBROUTINE TRNDOM(SEQ,IDDNA,J1,J2,ACIDS,IDACID,PAA,MINOPN,IDEV)
      CHARACTER SEQ(IDDNA),ACIDS(IDACID),PAA(5,5,5),LINE*60
      INTEGER STEP(3),FRAME,MSTOP,WPAIR
      EXTERNAL MSTOP,MINIL,WPAIR,ITOSL
C 17-7-91 replced line to write out title! which had disapeared
C Find open reading frames in their order of occurrence
C For each of 3 frames remember next position to try
      STEP(3) = J1 + 2
      STEP (1) = J1
      STEP(2) = J1 + 1
 10   CONTINUE
      FRAME = MINIL(STEP,3)
      I = STEP(FRAME)
      IF(I.LT.J2) THEN
        J = MSTOP(SEQ,IDDNA,I,J2,ACIDS,IDACID,PAA,IACID)
        STEP(FRAME) = J + 4
        IF((J-I+1).GE.MINOPN) THEN
          LINE(1:) = '>                    complement('
          IF (ITOSL(LINE(2:),I).EQ.0) WRITE(*,*)'Scream: ITOSL'
          IF(WPAIR(LINE(33:),I,J).NE.0) WRITE(*,*)'Scream: WPAIR'
          LINE(32+INDEX(LINE(33:),' '):) = ')'
          WRITE(IDEV,1001)LINE
          CALL SQREV(ACIDS,IACID)
          IACID = IACID + 1
          ACIDS(IACID) = '*'
          CALL FMTDKN(IDEV,ACIDS,IACID)
        END IF
        GO TO 10
      END IF
 1001 FORMAT(A)
      END
      SUBROUTINE OPENFR(SEQ,IDIM,I1,I2,KSTART,IDEV,KBIN,KBOUT,PAA,
     +OUTP,IDIMP,
     +IHELPS,IHELPE,HELPF,IDEVH)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIMP),PAA(125),OUTP(IDIMP)
      CHARACTER HELPF*(*)
      CALL SHOWFU(KBOUT,'Find open reading frames')
      CALL GETPAR(54,4,IOK,MINO,MAXO,MINOPN,JSTRAN,
     +IPAR5,
     +IPAR6,IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      CALL TRAND5(MINO,MAXO,MINOPN,JSTRAN,IOK,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.NE.0) RETURN
      MINOPD = 3* MINOPN
      IF(JSTRAN.EQ.0) THEN
        CALL TRNDP(SEQ,IDIM,I1,I2,OUTP,IDIMP,PAA,MINOPD,IDEV)
      ELSE IF (JSTRAN.EQ.1) THEN
        CALL TRNDM(SEQ,IDIM,I1,I2,OUTP,IDIMP,PAA,MINOPD,IDEV)
      ELSE IF (JSTRAN.EQ.2) THEN
        CALL TRNDP(SEQ,IDIM,I1,I2,OUTP,IDIMP,PAA,MINOPD,IDEV)
        CALL TRNDM(SEQ,IDIM,I1,I2,OUTP,IDIMP,PAA,MINOPD,IDEV)
      END IF
      END
      SUBROUTINE TRNDP(SEQ,IDDNA,J1,J2,
     +ACIDS,IDACID,PAA,MINOPN,IDEV)
      CHARACTER SEQ(IDDNA),ACIDS(IDACID),PAA(5,5,5)
      CHARACTER LINE*60
      INTEGER STEP(3),FRAME,PSTOP,WPAIR
      EXTERNAL PSTOP,MINIL,WPAIR
C Find open reading frames in their order of occurrence
C For each of 3 frames remember next position to try
      STEP(3) = J1 + 2
      STEP (1) = J1
      STEP(2) = J1 + 1
 10   CONTINUE
      FRAME = MINIL(STEP,3)
      I = STEP(FRAME)
      IF(I.LT.J2) THEN
        J = PSTOP(SEQ,IDDNA,I,J2,ACIDS,IDACID,PAA,IACID)
        STEP(FRAME) = J + 4
        IF((J-I+1).GE.MINOPN) THEN
          LINE(1:) = 'FT   CDS'
          IF(WPAIR(LINE(22:),I,J).NE.0) WRITE(*,*)'Scream: WPAIR'
            WRITE(IDEV,1001)LINE
        END IF
        GO TO 10
      END IF
 1001 FORMAT(A)
      END
      SUBROUTINE TRNDM(SEQ,IDDNA,J1,J2,ACIDS,IDACID,PAA,MINOPN,IDEV)
      CHARACTER SEQ(IDDNA),ACIDS(IDACID),PAA(5,5,5),LINE*60
      INTEGER STEP(3),FRAME,MSTOP,WPAIR
      EXTERNAL MSTOP,MINIL,WPAIR
C Find open reading frames in their order of occurrence
C For each of 3 frames remember next position to try
      STEP(3) = J1 + 2
      STEP (1) = J1
      STEP(2) = J1 + 1
 10   CONTINUE
      FRAME = MINIL(STEP,3)
      I = STEP(FRAME)
      IF(I.LT.J2) THEN
        J = MSTOP(SEQ,IDDNA,I,J2,ACIDS,IDACID,PAA,IACID)
        STEP(FRAME) = J + 4
        IF((J-I+1).GE.MINOPN) THEN
          LINE(1:) = 'FT   CDS             complement('
          IF(WPAIR(LINE(33:),I,J).NE.0) WRITE(*,*)'Scream: WPAIR'
            LINE(32+INDEX(LINE(33:),' '):) = ')'
            WRITE(IDEV,1001)LINE
        END IF
        GO TO 10
      END IF
 1001 FORMAT(A)
      END
      INTEGER FUNCTION PSTOP(SEQ,IDDNA,IDNA1,IDNA2,
     +ACIDS,IDACID,PAA,IACID)
      CHARACTER PAA(5,5,5),SEQ(IDDNA),ACIDS(IDACID),TRANF,ACID
      EXTERNAL TRANF
C Returns position of next stop codon or IDNA2 if end reached
C Also the number of acids excluding any stop codon
C Also the acids
      IACID = 0
      DO 10 IDNA=IDNA1,IDNA2-2,3
        ACID = TRANF(SEQ(IDNA),PAA)
        IF(ACID.EQ.'*') THEN
          PSTOP = IDNA - 1
          RETURN
        ELSE
          IACID = IACID + 1
          ACIDS(IACID) = ACID
        END IF
 10     CONTINUE
      PSTOP = IDNA2
      END
      INTEGER FUNCTION MSTOP(SEQ,IDDNA,IDNA1,IDNA2,
     +ACIDS,IDACID,PAA,IACID)
      CHARACTER PAA(5,5,5),SEQ(IDDNA),ACIDS(IDACID),TRANB,ACID
      EXTERNAL TRANB
C Returns position of next stop codon or IDNA2 if end reached
C Also the number of acids excluding any stop codon
C Also the acids
      IACID = 0
      DO 10 IDNA=IDNA1,IDNA2-2,3
        ACID = TRANB(SEQ(IDNA),PAA)
        IF(ACID.EQ.'*') THEN
          MSTOP = IDNA - 1
          RETURN
        ELSE
          IACID = IACID + 1
          ACIDS(IACID) = ACID
        END IF
 10     CONTINUE
      MSTOP = IDNA2
      END
      INTEGER FUNCTION MINIL(LIST,NLIST)
      INTEGER LIST(NLIST)
C sent list, return element number of first element whose
C value equals the minimum value in the list.
      MX = LIST(1)
      DO 10 I=2,NLIST
        MX = MIN(MX,LIST(I))
 10     CONTINUE
      DO 20 I=1,NLIST
        IF(MX.EQ.LIST(I)) THEN
          MINIL = I
          RETURN
        END IF
 20     CONTINUE
C Should never get here!
      WRITE(*,*)'Scream: MINIL'
      MINIL = 1
      END
      INTEGER FUNCTION WPAIR(LINE,I,J)
      CHARACTER LINE*(*)
      EXTERNAL ITOSL
C puts a pair of integers into string line, as for a feature table
      WPAIR = 1
      IF(ITOSL(LINE,I).EQ.0) RETURN
      K = INDEX(LINE,' ')
      LINE(K:) = '..'
      IF(ITOSL(LINE(K+2:),J).EQ.0) RETURN
      WPAIR = 0
      END
      SUBROUTINE TRPIRP(SEQ,IDIM,I1,I2,KSTART,MINOP,IDEV,PAA,
     +JSTRAN,OUTP,FRAMEC,IDIMP)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIMP),PAA(125),OUTP(IDIMP)
      INTEGER B,FRAME,FRAMEC(IDIM)
      EXTERNAL IPDNA
      MINOPN = MINOP + 1
      DO 200 FRAME = 1,3
        B = I1 - KSTART + FRAME
        LAA = IDIMP
        CALL TRANSD(SEQ,IDIM,
     +  B,I2-KSTART+1,OUTP,LAA,PAA,JSTRAN)
        LAA = (I2 - B + 1) / 3
      B = 1
      I = 0
20    CONTINUE
      I = I + 1      
      IF(I.LE.LAA) THEN
        IF(OUTP(I).EQ.'*') THEN
          LENGTH = I - B + 1
          IF(LENGTH.GE.MINOPN) THEN
            IF(JSTRAN.EQ.0) THEN
               IP1 = IPDNA(B,FRAME,JSTRAN) + I1 - KSTART
               IP2 = IPDNA(I,FRAME,JSTRAN) + I1 - KSTART
               IP2 = MIN(IP2,IDIM)
C              WRITE(IDEV,1002)IP1,IP2,SENSE(1),FRAME,IP2-IP1+1
              CALL MBPRIM(FRAMEC,IDIM,IP1,IP2,2)
            ELSE IF(JSTRAN.EQ.1) THEN
               IP1 = IPDNA(B,FRAME,JSTRAN) + I1 - KSTART
               IF(B.NE.1) IP1 = IP1 - 3
               IP2 = IPDNA(I,FRAME,JSTRAN) + I1 - KSTART - 3
               IP2 = MIN(IP2,IDIM)
C              WRITE(IDEV,1002)IP2,IP1,SENSE(2),FRAME,IP2-IP1+1
              CALL MBPRIM(FRAMEC,IDIM,IP1,IP2,3)
            END IF
          END IF
          B = I + 1
        END IF
        GO TO 20
      END IF
      LENGTH = I - B
      IF(LENGTH.GE.MINOPN) THEN
        IF(JSTRAN.EQ.0) THEN
           IP1 = IPDNA(B,FRAME,JSTRAN) + I1 - KSTART
           IP2 = IPDNA(I,FRAME,JSTRAN) + I1 - KSTART
           IP2 = MIN(IP2,IDIM)
C          WRITE(IDEV,1002)IP1,IP2,SENSE(1),FRAME,IP2-IP1+1
          CALL MBPRIM(FRAMEC,IDIM,IP1,IP2,2)
          LENGTH = LENGTH + 1
        ELSE IF(JSTRAN.EQ.1) THEN
           IP1 = IPDNA(B,FRAME,JSTRAN) + I1 - KSTART
           IF(B.NE.1) IP1 = IP1 - 3
           IP2 = IPDNA(I,FRAME,JSTRAN) + I1 - KSTART
           IP2 = MIN(IP2,IDIM)
C          WRITE(IDEV,1002)IP2,IP1,SENSE(2),FRAME,IP2-IP1+1
          CALL MBPRIM(FRAMEC,IDIM,IP1,IP2,3)
        END IF
      END IF
200   CONTINUE
C 1002 FORMAT(' FT ',I7,I7,'  ',A,I4,I7)
      END
      SUBROUTINE TRAN6X(SEQ,IDIM,JDEV,I1,I2,PAA,ITRAN,JSTRAN,
     +INUM,LINLEN,FC)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),TRANF4*3,TRANB4*3,SCOMP,PAA(125)
      CHARACTER LN*133,TICKS*120
      INTEGER FC(IDIM)
      EXTERNAL TRANF4,TRANB4,SCOMP,NOTRL
      SAVE TICKS
      DATA TICKS(1:60)/
     +'    .    :    .    :    .    :    .    :    .    :    .    :'/
      DATA TICKS(61:120)/
     +'    .    :    .    :    .    :    .    :    .    :    .    :'/
      K1=I1
      K2=I1+LINLEN-1
      K2 = MIN(K2,I2)
      LN = ' '
20    CONTINUE
      WRITE(JDEV,1004)
      WRITE(LN,1000)(TRANF4(SEQ(K),PAA,ITRAN,FC(K)),K=K1,K2-1,3)
      IF(NOTRL(LN,133,' ').NE.0)WRITE(JDEV,1006)LN(1:NOTRL(LN,133,' '))
      WRITE(LN,1001)(TRANF4(SEQ(K),PAA,ITRAN,FC(K)),K=K1+1,K2,3)
      IF(NOTRL(LN,133,' ').NE.0)WRITE(JDEV,1006)LN(1:NOTRL(LN,133,' '))
      IF(K1.NE.1) THEN
        WRITE(LN,1002)(TRANF4(SEQ(K),PAA,ITRAN,FC(K)),
     +  K=K1-1,K2-2,3)
        IF(NOTRL(LN,133,' ').NE.0)WRITE(JDEV,1006)
     +  LN(1:NOTRL(LN,133,' '))
      ELSE
        WRITE(LN,1008)(TRANF4(SEQ(K),PAA,ITRAN,FC(K)),K=3,K2-2,3)
        IF(NOTRL(LN,133,' ').NE.0)WRITE(JDEV,1006)
     +  LN(1:NOTRL(LN,133,' '))
      END IF
      IF(INUM.NE.0) THEN
        WRITE(JDEV,1003)(SEQ(K),K=K1,K2)
        WRITE(JDEV,1005)(N,N=K1+9,K2,10)
      ELSE
        WRITE(LN,1003)(SEQ(K),K=K1,K2)
        WRITE(LN(NOTRL(LN,133,' ')+2:),1007)K2
        WRITE(JDEV,1006)LN(1:NOTRL(LN,133,' '))
        IF(JSTRAN.NE.0) WRITE(JDEV,1009)TICKS(1:K2-K1+1)
      END IF
      IF(JSTRAN.NE.0)WRITE(JDEV,1003)(SCOMP(SEQ(K)),K=K1,K2)
      WRITE(LN,1000)(TRANB4(SEQ(K),PAA,ITRAN,FC(K)),K=K1,K2-1,3)
      IF(NOTRL(LN,133,' ').NE.0)WRITE(JDEV,1006)LN(1:NOTRL(LN,133,' '))
      WRITE(LN,1001)(TRANB4(SEQ(K),PAA,ITRAN,FC(K)),K=K1+1,K2,3)
      IF(NOTRL(LN,133,' ').NE.0)WRITE(JDEV,1006)LN(1:NOTRL(LN,133,' '))
      IF(K1.NE.1) THEN
        WRITE(LN,1002)(TRANB4(SEQ(K),PAA,ITRAN,FC(K)),K=K1-1,K2-2,3)
        IF(NOTRL(LN,133,' ').NE.0)WRITE(JDEV,1006)
     +  LN(1:NOTRL(LN,133,' '))
      ELSE
        WRITE(LN,1008)(TRANB4(SEQ(K),PAA,ITRAN,FC(K)),K=3,K2-2,3)
        IF(NOTRL(LN,133,' ').NE.0)WRITE(JDEV,1006)
     +  LN(1:NOTRL(LN,133,' '))
      END IF
      IF(K2.EQ.I2) RETURN
      K1=K2+1
      K2=K2+LINLEN
      K2 = MIN(K2,I2)
      GO TO 20
1000  FORMAT(4X,40(A))
1001  FORMAT(5X,40(A))
1002  FORMAT(3X,40(A))
1003  FORMAT(4X,120A1)
1004  FORMAT( )
1005  FORMAT(4X,12I10)
 1006 FORMAT(A)
 1007 FORMAT(I7)
 1008 FORMAT(6X,40(A))
 1009 FORMAT(4X,A)
      END
      INTEGER FUNCTION IPDNA(IACID,FRAME,ISTRAN)
      INTEGER FRAME
C     returns a dna position for an amino acid in a translation
C     frames on opposing strands: 123123123
C                                 123123123
      IPDNA = FRAME + (IACID-1)*3
      END
      CHARACTER*3 FUNCTION TRANF4(CODON,PAA,CODE,FRAMEC)
C   AUTHOR RODGER STADEN
      CHARACTER CODON(3),PAA(5,5,5),THREEL*3,TRANF,THREE*3
      INTEGER CODE,FRAMEC
      EXTERNAL THREEL,TRANF
      THREE(1:3)='   '
      IF(MOD(FRAMEC,2).EQ.0) THEN
        IF(CODE.EQ.3)THEN
          THREE(1:3)=THREEL(TRANF(CODON,PAA))
        ELSE
          THREE(2:2)=TRANF(CODON,PAA)
        END IF
      END IF
      TRANF4 = THREE
      END
C   TRANB3
      CHARACTER*3 FUNCTION TRANB4(CODON,PAA,CODE,FRAMEC)
C   AUTHOR RODGER STADEN
      CHARACTER CODON(3),PAA(5,5,5),THREEL*3,TRANB,THREE*3
      INTEGER CODE,FRAMEC
      EXTERNAL THREEL,TRANB
      THREE='   '
      IF(MOD(FRAMEC,3).EQ.0) THEN
        IF(CODE.EQ.3)THEN
          THREE(1:3)=THREEL(TRANB(CODON,PAA))
        ELSE
          THREE(2:2)=TRANB(CODON,PAA)
        END IF
      END IF
      TRANB4 = THREE(1:3)
      END
      SUBROUTINE HAIRPN(SEQ,IDIM,ITOT,ITOTEL,ITOTAL,IDTOT,
     +MARGL,MARGR,MARGB,MARGT,
     +ISXMAX,ISYMAX,J1,J2,KSTART,IDEV,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      INTEGER ITOT(IDTOT),ITOTEL(IDTOT),ITOTAL(IDTOT)
      CALL SHOWFU(KBOUT,'Search for hairpin loops')
      CALL GETPAR(30,10,IOK,MINLPI,MAXLPI,MINLP,
     +MINLPX,MAXLPX,MAXLP,MINBP,MAXBP,MININ,IGON,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      CALL HAIRPD(J1,J2,KBIN,KBOUT,
     +MINLPI,MAXLPI,MINLP,MINLPX,MAXLPX,MAXLP,MINBP,MAXBP,MININ,
     +IGON,IOK,
     +IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.NE.0) RETURN
      CALL HAIRPP(SEQ,IDIM,ITOT,ITOTEL,ITOTAL,IDTOT,
     +MINLP,MAXLP,MININ,IGON,
     +MARGL,MARGR,MARGB,MARGT,
     +ISXMAX,ISYMAX,J1,J2,KSTART,IDEV,KBOUT)
      END
      SUBROUTINE HAIRPP(SEQ,IDIM,ITOT,ITOTEL,ITOTAL,IDTOT,
     +MINLP,MAXLP,MININ,IGON,
     +MARGL,MARGR,MARGB,MARGT,
     +ISXMAX,ISYMAX,IS,IN,KSTART,IDEV,KBOUT)
C   AUTHOR: RODGER STADEN
      INTEGER SCORES(30)
      CHARACTER SEQ(IDIM)
      INTEGER ITOT(IDTOT),ITOTEL(IDTOT),ITOTAL(IDTOT)
      INTEGER CTONUM
      EXTERNAL CTONUM,LWRAP2
      CALL BUSY(KBOUT)
C   set scores as at=1,gc=1,gt=1
C   could make gt selectable
      DO 1 I=1,30
1       SCORES(I)=0
      SCORES(16)=1
      SCORES(21)=1
      SCORES(22)=1
      SCORES(8)=1
      SCORES(9)=1
      SCORES(14)=1
      IDO=IN-IS+1
      I=IS-1
      IP=0
      DO 301 K=1,IDO
        I=I+1
        DO 300 J=MINLP,MAXLP
          N=0
100     CONTINUE
        IMN=I-N
        IPNPJ=I+N+J
        IT=CTONUM(SEQ(LWRAP2(IN,IMN)))+
     +  5*CTONUM(SEQ(LWRAP2(IN,IPNPJ)))
        IT=SCORES(IT)
        IF(IT.NE.0)THEN
          N=N+IT
          GO TO 100
        END IF
C   IS THIS LOOP WORTH KEEPING?
        IF(N.GE.MININ)THEN
          IP=IP+1
          IF(IP.GT.IDTOT)THEN
            WRITE(KBOUT,1234)IP,I
1234        FORMAT(' Maximum of',I5,
     +      ' loops found up to',I6,' No more searching')
            GO TO 302
          END IF
          ITOT(IP)=N
          ITOTEL(IP)=LWRAP2(IN,I)
          ITOTAL(IP)=J-1
        END IF
300     CONTINUE
301   CONTINUE
302   CONTINUE
      IF(IP.GT.0)THEN
        NOUT=0
        DO 700 J=1,IP
          JP1=J+1
          ID1 = ITOTEL(J) + ITOTAL(J)/2
          DO 690 I=JP1,IP
            ID2 = ITOTEL(I) + ITOTAL(I)/2
            IF(ID1.NE.ID2)GO TO 690
            LP2=ITOTAL(I)+2*ITOT(I)
            IF(ITOTAL(J).GT.LP2)GO TO 690
            ITOT(J)=0
            ITOTAL(J)=0
            ITOTEL(J)=0
            NOUT=NOUT+1
            GO TO 700
690       CONTINUE
700     CONTINUE
        CALL BUB3AS(ITOTEL,ITOT,ITOTAL,IP)
        IF(IGON.EQ.0)THEN
          XMAX=IN
          XMIN=IS
C   PLOT ON SCALE 0 TO 4*MININ IN Y
          YMIN=0.
          YMAX=MININ*4
          YF=0.
          CALL CLEARV
          CALL VECTOM
          CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
          DO 800 I=NOUT+1,IP
            XF=ITOTEL(I)+ITOTAL(I)/2
            XT=XF
            YT=ITOT(I)
            CALL LINE(XF,XT,YF,YT,XMAX,XMIN,YMAX,YMIN,
     +      MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
800       CONTINUE
          CALL VT100M
        ELSE IF(IGON.EQ.1) THEN
          DO 900 I=NOUT+1,IP
            CALL DRAWPN(
     +      SEQ,IDIM,ITOT(I),ITOTAL(I),ITOTEL(I),
     +      IDEV,IN,KSTART)
900       CONTINUE
        END IF
      END IF
      WRITE(KBOUT,1005)IP-NOUT
1005  FORMAT(' Total loops found=',I6)
      END
      SUBROUTINE HAIRPD(IS,IN,KBIN,KBOUT,
     +MINLPI,MAXLPI,MINLP,MINLPX,MAXLPX,MAXLP,MINBP,MAXBP,MININ,
     +IGON,IOK,
     +IHELPS,IHELPE,HELPF,IDEVH)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      WRITE(KBOUT,1004)
1004  FORMAT(' Define the range of loop sizes')
      CALL GETINT(MINLPI,MAXLPI,MINLP,'Minimum loop size',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MINLP = IVAL
      MINLPX = MAX(MINLPX,MINLP)
      MAXLP = MINLPX
      CALL GETINT(MINLPX,MAXLPX,MAXLP,'Maximum loop size',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MAXLP = IVAL
      MINLP = MINLP + 1
      MAXLP = MAXLP + 1
      CALL GETINT(MINBP,MAXBP,MININ,'Minimum number of basepairs',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MININ = IVAL
      CALL YESONO(IGON,'Plot results','List results',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
C      IF(IGON.LT.0)RETURN
      END
C
C   subroutine to draw hairpin loops on device idev
C   hairpins are defined by:
C   1) nstem the number of basepairs in the stem
C   2) nloop the number of bases in the loop
C   3) ip the position of the rightmost base in the left side of the stem
C
C   draw the stems very simply, just standing up with a few bases
C   before and after
C   maximum size is 20 up and 14 across
      SUBROUTINE DRAWPN(SEQ,IDIM,NSTEM,NLOOP,IP,IDEV,IN,KSTART)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),ARRAY(14,20),SCORE(5,5),SPACE
      INTEGER CTONUM
      EXTERNAL CTONUM
      SAVE SPACE
      DATA SPACE/' '/
C   CHECK FOR WRAP AROUND
      IF((IP-NSTEM).LT.0)RETURN
      IF((IP+NLOOP+NSTEM+1).GT.IN)RETURN
      DO 1 I=1,5
      DO 1 J=1,5
        SCORE(I,J)=' '
1     CONTINUE
      SCORE(1,3)='-'
      SCORE(3,1)='-'
      SCORE(2,4)='-'
      SCORE(4,2)='-'
      SCORE(1,4)='.'
      SCORE(4,1)='.'
      DO 2 I=1,14
      DO 2 J=1,20
        ARRAY(I,J)=SPACE
2     CONTINUE
C   point to left stem start
      IPL=IP-NSTEM
C   point to right stem start
      IPR=IP+NSTEM+NLOOP+1
C   point to temporary array
      IAL=6
      IAR=8
      KA=1
C   fill in stem and loop
      DO 10 I=1,MIN(NSTEM+NLOOP/2,19)
        IPL=IPL+1
        IPR=IPR-1
        KA=KA+1
        ARRAY(IAL,KA)=SEQ(IPL)
        ARRAY(IAR,KA)=SEQ(IPR)
C   basepaired?
        ARRAY(IAL+1,KA)=
     +  SCORE(CTONUM(SEQ(IPL)),CTONUM(SEQ(IPR)))
10    CONTINUE
C   odd number of bases in loop?
      IF(MOD(NLOOP,2).NE.0)THEN
C   put in extra base
        IF((KA+1).LE.20)ARRAY((IAL+1),KA+1)=SEQ(IPL+1)
      END IF
C20    CONTINUE
C   now do 6 bases before the stem and 7 after
      IPL=IP-NSTEM-6
      DO 30 I=1,6
        IPL=IPL+1
        IF(IPL.GT.0)ARRAY(I,1)=SEQ(IPL)
30    CONTINUE
      IPR=IP+NSTEM+NLOOP
      DO 40 I=8,14
        IPR=IPR+1
        IF(IPR.LT.IN)ARRAY(I,1)=SEQ(IPR)
40    CONTINUE
      DO 50 I=1,20
        K=21-I
        WRITE(IDEV,1000)(ARRAY(L,K),L=1,14)
50    CONTINUE
1000  FORMAT(' ',5X,14A1)
1001  FORMAT(' ',5X,I6)
      WRITE(IDEV,1001)IP-NSTEM+KSTART-1
      RETURN
      END
      SUBROUTINE WORDFP(SEQ,IDIM1P,IDIM1,MXSPAN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,IENDB,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH)
C   AUTHOR: RODGER STADEN
C   ROUTINE TO COMPARE OBSERVED WITH EXPECTED 'WORD' FREQUENCIES
C   WORDS MAY BE UP TO 10 CHARACTERS IN LENGTH ALTHOUGH, AS THE
C   EXPECTED FREQUENCIES ARE CALCULATED SIMPLY BY MULTIPLYING
C   THE BASE FREQUENCIES TOGETHER, THE LONGER THE WORD THE MORE
C   INAPPROPRIATE THE MODEL. USERS ARE SIMPLY PROMPTED FOR THE WORD
C   TO SEARCH FOR - E.G CG - AND A WINDOW LENGTH TO COUNT OVER. 
C   THE PROGRAM PLOTS (OBSERVED - EXPECTED)
C   IF IT IS TOO SLOW, FASTER ALGORITHMS ARE POSSIBLE.
      CHARACTER SEQ(IDIM1P),WORD(10),HELPF*(*)
      INTEGER SPAN
      CALL SHOWFU(KBOUT,'Plot composition differences (obs-exp))')
      WORD(1) = 'C'
      WORD(2) = 'G'
      LENGTH = 2
      CALL GETPAR(64,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      CALL WORDFD(WORD,LENGTH,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +YMIN,YMAX,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      CALL WRDFP(SEQ,IDIM1P,IDIM1,MXSPAN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,
     +YMIN,YMAX,SPAN,IWRIT,WORD,LENGTH)
      END
      SUBROUTINE WORDFD(WORD,LENGTH,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +YMIN,YMAX,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER WORD(10),WORDA(10),HELPF*(*)
      INTEGER SPAN
      CALL SQPF3(WORD,WORDA,10,LENGTH,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      CALL GSPIN(MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      YMAX1 = REAL(SPAN)/(4**LENGTH)
      YMIN1 = -1.0*YMAX1
      YMIN2 = 4.*YMIN1
      YMAX2 = 4.*YMAX1
      CALL GETRL(YMIN1,YMAX2,YMAX1,
     +'Maximum plot value',VALUE,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      YMAX = VALUE
      CALL GETRL(YMIN2,YMAX,YMIN1,
     +'Minimum plot value',VALUE,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      YMIN = VALUE
      IOK = 0
      END
      SUBROUTINE WRDFP(SEQ,IDIM1P,IDIM1,MXSPAN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,
     +YMIN,YMAX,SPAN,IWRIT,WORD,LENGTH)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P),WORD(10)
      INTEGER SPAN,CTONUM,IP(10),OBS(5)
      EXTERNAL CTONUM
      CALL CLEARV
      CALL FILLI(OBS,5,0)
      DO 15 I = 1,LENGTH
        IP(I) = CTONUM(WORD(I))
15    CONTINUE
      I1INM1=1+(MXSPAN/2)-KSTART+1
      INC = 1
      J1P=J1+I1INM1
      J2P=J2+I1INM1
      XMIN=J1
      XMAX=J2
      LF=SPAN/2
      LB=1+SPAN/2
      DO 66 I=J1P,J1P+SPAN-1
        IS=CTONUM(SEQ(I))
        OBS(IS)=OBS(IS)+1
66    CONTINUE
      CALL VECTOM
      CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      XF = J1
      XT = J2
      YF = YMIN + (YMAX-YMIN)/2.
      YT = YF
      CALL LINE(XF,XT,YF,YT,XMAX,XMIN,YMAX,YMIN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      MARG = NINT(0.05*MARGT)
      MARGB1 = MARGB+MARG
      MARGT1 = MARGT - 2*MARG
      XF=J1
      YF=0.
      DO 100 I=J1P+LB,J2P-(LENGTH-1)
        ISF=CTONUM(SEQ(I+LF))
        ISB=CTONUM(SEQ(I-LB))
        OBS(ISF)=OBS(ISF)+1
        OBS(ISB)=OBS(ISB)-1
        IF(MOD(I,IWRIT).EQ.0)THEN
          EXPEC = 1.0
          DO 80 J=1,LENGTH
            EXPEC = EXPEC * REAL(OBS(IP(J)))/SPAN
80        CONTINUE
          EXPEC = EXPEC * SPAN
          NFOUND = 0
          IAT=I-LB
          IEND = I+LF
90        CONTINUE
            IAT=IAT+INC
            IDIM = IEND - IAT + 1
            IF(IDIM.GT.0)THEN
            CALL FIND6(SEQ(IAT),IDIM,WORD,LENGTH,INC,JMATCH)
            IF(JMATCH.NE.0)THEN
              IAT=IAT+JMATCH-1
              NFOUND = NFOUND + 1
              GO TO 90
            END IF
          END IF
          SUM = NFOUND - EXPEC
          XT=I-I1INM1
          CALL LINE(XF,XT,YF,SUM,XMAX,XMIN,YMAX,YMIN,
     +    MARGL,MARGR,MARGB1,MARGT1,ISXMAX,ISYMAX)
          XF=XT
          YF=SUM
        END IF
100   CONTINUE
      CALL VT100M
      END
      SUBROUTINE BPHASE(SEQ,IDIM1P,IDIM1,MXSPAN,
     +ISXMAX,ISYMAX,MARGL1,MARGR1,MARGB1,MARGT1,J1,J2,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,DIALOG)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P)
      INTEGER SPAN,DIALOG
      CALL SHOWFU(KBOUT,'Uneven positional base frequencies method')
      CALL GETPAR(44,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      MAXSP = MIN(MAXSP,IDIM1/3)
      SPAN = MIN(MAXSP,SPAN)
      IF(DIALOG.EQ.1) THEN
        CALL GSPIN(MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      CALL BPHASP(SEQ,IDIM1P,IDIM1,MXSPAN,
     +ISXMAX,ISYMAX,MARGL1,MARGR1,MARGB1,MARGT1,J1,J2,SPAN,IWRIT)
      END
      SUBROUTINE BPHASP(SEQ,IDIM1P,IDIM1,MXSPAN,
     +ISXMAX,ISYMAX,MARGL1,MARGR1,MARGB1,MARGT1,J1,J2,LENW,IWRIT)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P)
      REAL POS(5,3),COMP(5),POS1(15)
      EQUIVALENCE (POS,POS1)
      I1IN=2+MXSPAN/2
      I1INM1=I1IN-1
      YMIN=0.4
      YMAX=1.34
      IDIMJ=J2-J1+1
      J1P=J1+I1INM1
      J2P=J2+I1INM1
      LB=1+LENW/2
      LB=3*LB
      LF=LENW/2
      LF=3*LF
      LENW3=3*LENW
      IDONE=0
      XMIN=J1
      XMAX=J2
      CALL CLEARV
      CALL VECTOM
      XP=J1
      YP=0.
      X=J2
      CALL FRAME(MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
C   SET UP MARGINS
      MARGB=MARGB1+NINT(0.006*ISYMAX)
      MARGT=MARGT1-NINT(0.012*ISYMAX)
      CALL LINE(XP,X,.78,.78,XMAX,XMIN,YMAX,YMIN,
     +MARGL1,MARGR1,MARGB,MARGT,ISXMAX,ISYMAX)
      CALL TEXT(XMIN,0.78,'76%',3,0,XMAX,XMIN,YMAX,YMIN,
     +MARGL1,MARGR1,MARGB,MARGT,ISXMAX,ISYMAX)
      CALL BPHAS1(SEQ(J1P-LB),IDIM1,POS,COMP,LENW3,POS1)
      DO 300 IP=J1P,J2P,3
        IDONE=IDONE+1
        TESTC=ROTPHS(SEQ,IDIM1P,IP,LB,LF,POS,COMP)
        IF(MOD(IDONE,IWRIT).EQ.0)THEN
          X=IP-I1INM1
          CALL LINE(XP,X,YP,TESTC,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB,MARGT,ISXMAX,ISYMAX)
          YP=TESTC
          XP=X
        END IF
300   CONTINUE
      CALL VT100M
      END
      REAL FUNCTION ROTPHS(SEQ,IDIM,IAT,LB,LF,POS,BCOMP)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      REAL POS(5,3),BCOMP(5),DIFF(5,3),DIFF1(15)
      INTEGER CTONUM
      EXTERNAL CTONUM
      EQUIVALENCE (DIFF,DIFF1)
C   zero variables
      CALL FILLR(DIFF1,15,0.)
C   LOOK BACK TO SUBTRACT A CODON
      IPB=IAT-LB
C   sum for each base for each codon position
      K=0
      DO 10 J=IPB,IPB+2
        K=K+1
        JJ=CTONUM(SEQ(J))
        BCOMP(JJ)=BCOMP(JJ)-1.
        POS(JJ,K)=POS(JJ,K)-1.
10    CONTINUE
C   look forwards and add a value
      IPF=IAT+LF
      K=0
      DO 20 J=IPF,IPF+2
        K=K+1
        JJ=CTONUM(SEQ(J))
        BCOMP(JJ)=BCOMP(JJ)+1.
        POS(JJ,K)=POS(JJ,K)+1.
20    CONTINUE
      DO 30 I=1,4
        TEMP=BCOMP(I)/3.
        DO 30 J=1,3
          DIFF(I,J)=ABS(POS(I,J)-TEMP)
30    CONTINUE
      R=0.
      DO 60 I=1,4
      DO 60 J=1,3
        IF(BCOMP(I).NE.0.)R=R+DIFF(I,J)/BCOMP(I)
60    CONTINUE
      ROTPHS=R
      END
      SUBROUTINE BPHAS1(SEQ,IDIM,POS,COMP,LWIND3,POS1)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      REAL POS(5,3),COMP(5),POS1(15)
      INTEGER CTONUM
      EXTERNAL CTONUM
      CALL FILLR(POS1,15,0.)
      CALL FILLR(COMP,5,0.)
      DO 10 I=1,LWIND3-1,3
        K=0
        I1=I
        I2=I1+2
        DO 9 J=I1,I2
          K=K+1
          JJ=CTONUM(SEQ(J))
          COMP(JJ)=COMP(JJ)+1.
          POS(JJ,K)=POS(JJ,K)+1.
9       CONTINUE
10    CONTINUE
      END
      SUBROUTINE FICKET(SEQ,IDIM1P,IDIM1,MXSPAN,
     +ISXMAX,ISYMAX,MARGL1,MARGR1,MARGB1,MARGT1,J1,J2,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,DIALOG)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P)
      INTEGER SPAN,DIALOG
      CALL SHOWFU(KBOUT,'Ficketts method to find protein genes')
      CALL GETPAR(48,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      IF(DIALOG.EQ.1) THEN
        CALL GSPIN(MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      CALL FICKTP(SEQ,IDIM1P,IDIM1,MXSPAN,
     +ISXMAX,ISYMAX,MARGL1,MARGR1,MARGB1,MARGT1,J1,J2,SPAN,IWRIT)
      END
      SUBROUTINE FICKTP(SEQ,IDIM1P,IDIM1,MXSPAN,
     +ISXMAX,ISYMAX,MARGL1,MARGR1,MARGB1,MARGT1,J1,J2,LENW,IWRIT)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P)
      REAL POS(5,3),COMP(5),POS1(15)
      EQUIVALENCE (POS,POS1)
      EXTERNAL ROTFCK
      I1IN=2+MXSPAN/2
      I1INM1=I1IN-1
      IDIMJ=J2-J1+1.
      J1P=J1+I1INM1
      J2P=J2+I1INM1
      YMIN=0.
      YMAX=1.
      XMIN=J1
      XMAX=J2
      LB=1+LENW/2
      LB=3*LB
      LF=LENW/2
      LF=3*LF
      LENW3=3*LENW
C   calc fraction of window length for composition
      FRAC=1./LENW3
      IDONE=0
      CALL CLEARV
      CALL VECTOM
C   set initial values
      XP=J1
      YP=0.
      X=J2
      CALL FRAME(MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
      CALL LINE(XP,X,.4,.4,XMAX,XMIN,YMAX,YMIN,
     +MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
      CALL LINE(XP,X,.77,.77,XMAX,XMIN,YMAX,YMIN,
     +MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
      CALL FCKSTR(SEQ(J1P-LB),IDIM1,POS,COMP,LENW3,POS1)
      DO 300 IP=J1P,J2P,3
        IDONE=IDONE+1
        TESTC=ROTFCK(SEQ,IDIM1P,IP,LB,LF,POS,COMP,FRAC)
        IF(MOD(IDONE,IWRIT).EQ.0)THEN
          X=IP-I1INM1
          CALL LINE(XP,X,YP,TESTC,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
          YP=TESTC
          XP=X
        END IF
300   CONTINUE
      CALL VT100M
      END
      REAL FUNCTION ROTFCK(SEQ,IDIM,IAT,LB,LF,POS,BCOMP,FRAC)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      REAL POS(5,3),BASMAX(4),BASMIN(4),BPOS(4),BCOMP(5),BCOMPT(5)
      REAL WCOMP(4),WPOS(4),PCODP(10,4),PCODC(10,4),PCODCR(10)
      REAL PCODPR(10)
      INTEGER CTONUM
      EXTERNAL CTONUM
      SAVE WCOMP,WPOS,PCODCR,PCODPR,PCODP,PCODC
      DATA WCOMP/.14,.12,.11,.15/
      DATA WPOS/.33,.18,.26,.31/
      DATA PCODCR/.17,.19,.21,.23,.25,.27,.29,.31,.33,.99/
      DATA PCODPR/1.1,1.2,1.3,1.4,1.5,1.6,1.7,1.8,1.9,99./
      DATA PCODC/.58,.51,.69,.56,.75,.55,.40,.39,.24,.28,
     1.31,.39,.44,.43,.59,.59,.64,.51,.64,.82,.21,.81,.65,.67,
     2.49,.62,.55,.44,.49,.28,.29,.33,.41,.41,.73,.64,.64,.47,
     3.54,.40/
      DATA PCODP/.09,.09,.20,.54,.44,.69,.68,.91,.97,.97,
     1.23,.30,.33,.51,.48,.66,.81,.70,.70,.80,
     2.22,.20,.34,.45,.68,.58,.93,.84,.68,.94,
     3.08,.08,.16,.27,.48,.53,.64,.74,.88,.90/
C      DATA TESTCP/.00,.04,.07,.29,.40,.77,.92,.98,1.0,1.0/
C      DATA TESTCR/.43,.53,.64,.74,.84,.95,1.05,1.16,1.26,99./
      DO 5 I=1,4
        BASMAX(I)=0.
        BASMIN(I)=IDIM
        BPOS(I)=0.
5     CONTINUE
C   look back to subtract a codon
      IPB=IAT-LB
C   sum for each base for each codon position
      K=0
      DO 10 J=IPB,IPB+2
        K=K+1
        JS=CTONUM(SEQ(J))
        BCOMP(JS)=BCOMP(JS)-FRAC
        POS(JS,K)=POS(JS,K)-1.
10    CONTINUE
C   look forwards and add a value
      IPF=IAT+LF
      K=0
      DO 20 J=IPF,IPF+2
        K=K+1
        JS=CTONUM(SEQ(J))
        BCOMP(JS)=BCOMP(JS)+FRAC
        POS(JS,K)=POS(JS,K)+1.
20    CONTINUE
C   get max and min values for each base in each codon position
      DO 30 J=1,3
      DO 30 I=1,4
        IF(POS(I,J).GT.BASMAX(I))BASMAX(I)=POS(I,J)
        IF(POS(I,J).LT.BASMIN(I))BASMIN(I)=POS(I,J)
30    CONTINUE
      DO 40 I=1,4
        BPOS(I)=BASMAX(I)/(BASMIN(I)+1.)
40    CONTINUE
C   look up prob of coding
      DO 46 I=1,4
      DO 45 J=1,10
        IF(BCOMP(I).GT.PCODCR(J))GO TO 45
C   lt current so set prob
        BCOMPT(I)=PCODC(J,I)
        GO TO 46
45    CONTINUE
46    CONTINUE
      DO 48 I=1,4
      DO 47 J=1,10
        IF(BPOS(I).GT.PCODPR(J))GO TO 47
C   lt current so set prob
        BPOS(I)=PCODP(J,I)
        GO TO 48
47    CONTINUE
48    CONTINUE
C   apply weights
      DO 50 I=1,4
        BCOMPT(I)=BCOMPT(I)*WCOMP(I)
        BPOS(I)=BPOS(I)*WPOS(I)
50    CONTINUE
C   calc testcode
      TESTC=0.
      DO 60 I=1,4
        TESTC=TESTC+BPOS(I)+BCOMPT(I)
60    CONTINUE
      ROTFCK=TESTC
      END
      SUBROUTINE FCKSTR(SEQ,IDIM,POS,COMP,LWIND3,POS1)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      REAL POS(5,3),COMP(5),POS1(15)
      INTEGER CTONUM
      EXTERNAL CTONUM
C   calc fraction to add ie window length recip
      FRAC=1./LWIND3
C   zero variables
      CALL FILLR(COMP,5,0.)
      CALL FILLR(POS1,15,0.)
C   sum for each base for each codon position
      DO 10 I=1,LWIND3-1,3
        K=0
        I1=I
        I2=I1+2
        DO 9 J=I1,I2
          K=K+1
          JS=CTONUM(SEQ(J))
          COMP(JS)=COMP(JS)+FRAC
          POS(JS,K)=POS(JS,K)+1.
9       CONTINUE
10    CONTINUE
      END
      SUBROUTINE SHEPED(SEQ,IDIM1P,IDIM1,MXSPAN,
     +ISXMAX,ISYMAX,J1,J2,MARGL,MARGR,MARGB,MARGT,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,PAA,DIALOG)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1P),PAA(5,5,5)
      INTEGER SPAN,DIALOG
      CALL SHOWFU(KBOUT,'Shepherds method to find protein genes')
      CALL GETPAR(47,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      IF(DIALOG.EQ.1) THEN
        CALL GSPIN(MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      CALL SHEPP(SEQ,IDIM1P,IDIM1,MXSPAN,
     +ISXMAX,ISYMAX,J1,J2,MARGL,MARGR,MARGB,MARGT,PAA,SPAN,IWRIT)
      END
      SUBROUTINE SHEPP(SEQ,IDIM1P,IDIM1,MXSPAN,
     +ISXMAX,ISYMAX,J1,J2,MARGL,MARGR,MARGB,MARGT,PAA,LENW,IWRIT)
C   AUTHOR: RODGER STADEN
      REAL SUMW(3),PROB(3)
      CHARACTER SEQ(IDIM1P),PAA(5,5,5)
      CHARACTER SPACE,RLINE(3),STAR
      SAVE SPACE,STAR
      DATA SPACE,STAR/' ','*'/
      IMH=NINT(0.005*ISYMAX)
      I1IN=2+MXSPAN/2
      I1INM1=I1IN-1
      IDIMJ=J2-J1+1.
      J1P=J1+I1INM1
      J2P=J2+I1INM1
      YMIN=0.2
      YMAX=0.4
      YMID=YMIN+(YMAX-YMIN)/2.
      XMIN=J1
      XMAX=J2
C   SORT OUT MARGIN IE FIND MAX AND DIVIDE BY THREE
      IMARG=NINT(MARGT/3.)
      MARGL1=MARGL
      MARGR1=MARGR
      MARGB1=MARGB
      MARGB2=MARGB+IMARG
      MARGB3=MARGB+2*IMARG
      MARGT3=IMARG
      MARGT2=IMARG
      MARGT1=IMARG
      LB=1+LENW/2
      LB=3*LB
      LF=LENW/2
      LF=3*LF
      LENW3=3*LENW
      CALL FILLR(SUMW,3,0.)
      IDONE=0
      CALL CLEARV
      CALL VECTOM
      CALL FRAME(MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
      CALL FRAME(MARGL1,MARGR1,MARGB2,MARGT2,ISXMAX,ISYMAX)
      CALL FRAME(MARGL1,MARGR1,MARGB3,MARGT3,ISXMAX,ISYMAX)
      CALL SHEPST(SEQ(J1P-LB),IDIM1,LENW3,SUMW(1))
      CALL SHEPST(SEQ(J1P+1-LB),IDIM1,LENW3,SUMW(2))
      CALL SHEPST(SEQ(J1P+2-LB),IDIM1,LENW3,SUMW(3))
C   set initial values
      XP=J1
      YP1=0.5
      YP2=0.5
      YP3=0.5
      DO 300 IP=J1P,J2P,3
        IDONE=IDONE+1
        IP0=IP
        IP1=IP+1
        IP2=IP+2
        CALL RTSHEP(SEQ,IDIM1P,IP0,LB,LF,SUMW(1))
        CALL RTSHEP(SEQ,IDIM1P,IP1,LB,LF,SUMW(2))
        CALL RTSHEP(SEQ,IDIM1P,IP2,LB,LF,SUMW(3))
        IF(MOD(IDONE,IWRIT).EQ.0)THEN
          T=SUMW(1)+SUMW(2)+SUMW(3)
          PROB(1)=SUMW(1)/T
          PROB(2)=SUMW(2)/T
          PROB(3)=SUMW(3)/T
C   get largest
          DO 302 II=1,3
            RLINE(II)=SPACE
302       CONTINUE
          TP=MAX(SUMW(1),SUMW(2),SUMW(3))
          DO 303 II=1,3
            IF(SUMW(II).EQ.TP)RLINE(II)=STAR
303       CONTINUE
C   set actual ip
          IPA=IP-I1INM1
          X=IPA
          Y1=PROB(1)
          Y2=PROB(2)
          Y3=PROB(3)
          CALL LINE(XP,X,YP1,Y1,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1+IMH,MARGT1-2*IMH,ISXMAX,ISYMAX)
          CALL LINE(XP,X,YP2,Y2,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB2+IMH,MARGT2-2*IMH,ISXMAX,ISYMAX)
          CALL LINE(XP,X,YP3,Y3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB3+IMH,MARGT3-2*IMH,ISXMAX,ISYMAX)
          IF(RLINE(1).EQ.STAR)
     +    CALL POINT(X,YMID,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
          IF(RLINE(2).EQ.STAR)
     +    CALL POINT(X,YMID,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB2,MARGT2,ISXMAX,ISYMAX)
          IF(RLINE(3).EQ.STAR)
     +    CALL POINT(X,YMID,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB3,MARGT3,ISXMAX,ISYMAX)
          YP1=Y1
          YP2=Y2
          YP3=Y3
          XP=X
        END IF
300   CONTINUE
      CALL STARTS(SEQ,IDIM1P,J1P,J2P,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,PAA)
      CALL STOPS(SEQ,IDIM1P,J1P,J2P,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,PAA)
      CALL VT100M
      END
      SUBROUTINE SHEPST(SEQ,IDIM,LENW,SUM)
C   AUTHOR: RODGER STADEN
      REAL SUM
      CHARACTER SEQ(IDIM)
      INTEGER SCORER(5),SCOREY(5),CTONUM
      EXTERNAL CTONUM
      SAVE SCORER,SCOREY
      DATA SCORER,SCOREY/0,0,1,1,0,1,1,0,0,0/
      SUM=0.
      DO 100 I=1,LENW,3
        SUM=SUM+SCORER(CTONUM(SEQ(I)))+SCOREY(CTONUM(SEQ(I+2)))
100   CONTINUE
      END
      SUBROUTINE RTSHEP(SEQ,IDIM1,I,LB,LF,H)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1)
      INTEGER SCORER(4),SCOREY(4),CTONUM
      EXTERNAL CTONUM
      SAVE SCORER,SCOREY
      DATA SCORER,SCOREY/0,0,1,1,1,1,0,0/
C   set up dummy values
      XS=0.
      XA=0.
C   look back
      IPB=I-LB-1
      DO 10 J=1,3
        IF(CTONUM(SEQ(IPB+J)).EQ.5)GO TO 30
10    CONTINUE
C   set value to subtract
      IPB=IPB+1
      IT1=CTONUM(SEQ(IPB))
      IT2=CTONUM(SEQ(IPB+2))
      XS=SCORER(IT1)+SCOREY(IT2)
C   now look forward
30    CONTINUE
      IPB=I+LF-1
C   look for bad char
      DO 45 J=1,3
        IF(CTONUM(SEQ(IPB+J)).EQ.5)GO TO 50
45    CONTINUE
C   ok so use
      IPB=IPB+1
      IT1=CTONUM(SEQ(IPB))
      IT2=CTONUM(SEQ(IPB+2))
      XA=SCORER(IT1)+SCOREY(IT2)
50    CONTINUE
      H=H-XS+XA
      END
      SUBROUTINE IMPBC(SEQ,IDIM1P,IDIM1,MXSPAN,FTABLE,IDFTAB,
     +ISXMAX,ISYMAX,J1,J2,MARGL,MARGR,MARGB,MARGT,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,PAA,DIALOG)
      CHARACTER HELPF*(*),PAA(5,5,5)
C   AUTHOR: RODGER STADEN
      INTEGER SPAN,DIALOG
      REAL FTABLE(IDFTAB)
      CHARACTER SEQ(IDIM1P)
      CALL SHOWFU(KBOUT,'McLachlan,Staden,Boswell codon improbability')
C      WRITE(KBOUT,*)' Search for protein genes using McLachlan, Staden'
C      WRITE(KBOUT,*)' and Boswell improbability method'
C      WRITE(KBOUT,*)' expecting codon composition to depend on'
C      WRITE(KBOUT,*)' base composition'
      CALL GETPAR(45,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(DIALOG.EQ.1) THEN
        CALL GSPIN(MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      CALL IMPBCP(SEQ,IDIM1P,IDIM1,MXSPAN,FTABLE,IDFTAB,
     +ISXMAX,ISYMAX,J1,J2,MARGL,MARGR,MARGB,MARGT,PAA,SPAN,IWRIT)
      END
      SUBROUTINE IMPBCP(SEQ,IDIM1P,IDIM1,MXSPAN,FTABLE,IDFTAB,
     +ISXMAX,ISYMAX,J1,J2,MARGL,MARGR,MARGB,MARGT,PAA,LENW,IWRIT)
      CHARACTER PAA(5,5,5)
C   AUTHOR: RODGER STADEN
      REAL RNBASE(4)
      REAL W(3),RNFAC(3),COMP(3),FTABLE(IDFTAB),FACN
      INTEGER NBASE1(4),NBASE2(4),NBASE3(4)
      INTEGER NCOD1(4,4,4),NCOD2(4,4,4),NCOD3(4,4,4)
      CHARACTER SEQ(IDIM1P),RLINE(3),STAR
      SAVE STAR
      DATA STAR/'*'/
C   SORT OUT MARGIN IE FIND MAX AND DIVIDE BY THREE
      IMARG=NINT(MARGT/3.)
      MARGL1=MARGL
      MARGR1=MARGR
      MARGB1=MARGB
      MARGB2=MARGB+IMARG
      MARGB3=MARGB+2*IMARG
      MARGT3=IMARG
      MARGT2=IMARG
      MARGT1=IMARG
      IMH=NINT(0.005*ISYMAX)
      SD=4.1
      EXPM=0.
      YMIN=EXPM
      YMAX=EXPM+12.*SD
      IBH=NINT(0.005*ISXMAX)
C  ONLY CALC FACTORS UPTO 99!
      CALL FACTAB(FTABLE,99)
      I1IN=2+MXSPAN/2
      I1INM1=I1IN-1
      IDIMJ=J2-J1+1.
      J1P=J1+I1INM1
      J2P=J2+I1INM1
      LB=1+LENW/2
      LB=3*LB
      LF=LENW/2
      LF=3*LF
      LENW3=3*LENW
      RLENW3=LENW3
      FACN=FACTOR(LENW,FTABLE,IDFTAB)
      XMIN=J1
      XMAX=J2
      CALL CLEARV
      CALL VECTOM
      CALL FRAME(MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
      CALL FRAME(MARGL1,MARGR1,MARGB2,MARGT2,ISXMAX,ISYMAX)
      CALL FRAME(MARGL1,MARGR1,MARGB3,MARGT3,ISXMAX,ISYMAX)
      CALL SCALES(XMAX,XMIN,YMAX,YMIN,MARGL1,MARGR1,
     +MARGB1,MARGT1,ISXMAX,ISYMAX,SD,IBH,YMIN,2)
      CALL SCALES(XMAX,XMIN,YMAX,YMIN,MARGL1,MARGR1,
     +MARGB2,MARGT2,ISXMAX,ISYMAX,SD,IBH,YMIN,2)
      CALL SCALES(XMAX,XMIN,YMAX,YMIN,MARGL1,MARGR1,
     +MARGB3,MARGT3,ISXMAX,ISYMAX,SD,IBH,YMIN,2)
      CALL ROT1(SEQ(J1P-LB),IDIM1,NCOD1,RNFAC(1),FTABLE,
     +IDFTAB,NBASE1,LENW3)
      CALL ROT1(SEQ(J1P+1-LB),IDIM1,NCOD2,RNFAC(2),FTABLE,
     +IDFTAB,NBASE2,LENW3)
      CALL ROT1(SEQ(J1P+2-LB),IDIM1,NCOD3,RNFAC(3),FTABLE,
     +IDFTAB,NBASE3,LENW3)
C   set initial values
      XP=J1
      YP1=0.
      YP2=0.
      YP3=0.
      IDONE=0
      DO 300 IP=J1P,J2P,3
        IDONE=IDONE+1
        IP0=IP
        IP1=IP+1
        IP2=IP+2
        CALL ROTFAC(SEQ,IDIM1P,IP0,LB,LF,NCOD1,RNFAC(1),
     +  FTABLE,IDFTAB,NBASE1,COMP(1),LENW3)
        CALL ROTFAC(SEQ,IDIM1P,IP1,LB,LF,NCOD2,RNFAC(2),
     +  FTABLE,IDFTAB,NBASE2,COMP(2),LENW3)
        CALL ROTFAC(SEQ,IDIM1P,IP2,LB,LF,NCOD3,RNFAC(3),
     +  FTABLE,IDFTAB,NBASE3,COMP(3),LENW3)
        DO 200 K=1,3
          W(K)=RNFAC(K)-COMP(K)-FACN
200     CONTINUE
        IF(MOD(IDONE,IWRIT).EQ.0)THEN
          DO 302 II=1,3
            RLINE(II)=' '
302       CONTINUE
          T=MAX(W(1),W(2),W(3))
          DO 303 II=1,3
            IF(W(II).EQ.T)RLINE(II)=STAR
303       CONTINUE
          IPA=IP-I1INM1
          DO 787 JJJ=1,4
            RNBASE(JJJ)=FLOAT(NBASE1(JJJ))/RLENW3
787       CONTINUE
          CALL POISON(LENW,RNBASE,RNBASE,EW,WD,1)
          YMAX=EXPM+12.*WD
          WD3=WD*6.
          X=IPA
          Y1=W(1)-EW
          Y2=W(2)-EW
          Y3=W(3)-EW
          CALL LINE(XP,X,YP1,Y1,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1+IMH,MARGT1-2*IMH,ISXMAX,ISYMAX)
          CALL LINE(XP,X,YP2,Y2,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB2+IMH,MARGT2-2*IMH,ISXMAX,ISYMAX)
          CALL LINE(XP,X,YP3,Y3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB3+IMH,MARGT3-2*IMH,ISXMAX,ISYMAX)
          IF(RLINE(1).EQ.STAR)CALL POINT(X,WD3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
          IF(RLINE(2).EQ.STAR)CALL POINT(X,WD3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB2,MARGT2,ISXMAX,ISYMAX)
          IF(RLINE(3).EQ.STAR)CALL POINT(X,WD3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB3,MARGT3,ISXMAX,ISYMAX)
          YP1=Y1
          YP2=Y2
          YP3=Y3
          XP=X
        END IF
300   CONTINUE
      CALL STARTS(SEQ,IDIM1P,J1P,J2P,
     +MARGL1,MARGR1,MARGB,MARGT,ISXMAX,ISYMAX,PAA)
      CALL STOPS(SEQ,IDIM1P,J1P,J2P,
     +MARGL1,MARGR1,MARGB,MARGT,ISXMAX,ISYMAX,PAA)
      CALL VT100M
      END
      SUBROUTINE IMPAC(SEQ,IDIM1P,IDIM1,MXSPAN,FTABLE,IDFTAB,
     +ISXMAX,ISYMAX,J1,J2,MARGL,MARGR,MARGB,MARGT,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,PAA,DIALOG)
      CHARACTER HELPF*(*),PAA(5,5,5)
C   AUTHOR: RODGER STADEN
      REAL FTABLE(IDFTAB)
      CHARACTER SEQ(IDIM1P)
      INTEGER SPAN,DIALOG
      CALL SHOWFU(KBOUT,'McLachlan,Staden,Boswell codon improbability')
C      WRITE(KBOUT,*)' Search for protein genes using McLachlan, Staden'
C      WRITE(KBOUT,*)' and Boswell improbability method'
C      WRITE(KBOUT,*)' expecting codon composition to depend on'
C      WRITE(KBOUT,*)' amino acid composition'
      CALL GETPAR(46,6,IOK,MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,
     +IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(DIALOG.EQ.1) THEN
        CALL GSPIN(MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      CALL IMPACP(SEQ,IDIM1P,IDIM1,MXSPAN,FTABLE,IDFTAB,
     +ISXMAX,ISYMAX,J1,J2,MARGL,MARGR,MARGB,MARGT,PAA,SPAN,IWRIT)
      END
      SUBROUTINE IMPACP(SEQ,IDIM1P,IDIM1,MXSPAN,FTABLE,IDFTAB,
     +ISXMAX,ISYMAX,J1,J2,MARGL,MARGR,MARGB,MARGT,PAA,LENW,IWRIT)
      CHARACTER PAA(5,5,5)
C   AUTHOR: RODGER STADEN
      REAL W(3),RNFAC(3),COMP(3),FTABLE(IDFTAB),FACN
      INTEGER NBASE1(4),NBASE2(4),NBASE3(4)
      INTEGER NCOD1(4,4,4),NCOD2(4,4,4),NCOD3(4,4,4)
      INTEGER NCODON(21),IACID(4,4,4)
      REAL FABC1(4,4,4),FA1(21)
      REAL FABC2(4,4,4),FA2(21)
      REAL FABC3(4,4,4),FA3(21)
      CHARACTER SEQ(IDIM1P),RLINE(3),STAR
      SAVE IACID,NCODON,STAR
      DATA STAR/'*'/
C    array with number of codons per acid
      DATA IACID/
     +1,2,3,5,6,7,8,9,
     +10,12,14,16,18,20,6,21,
     +1,2,3,5,6,7,8,9,
     +10,12,14,16,18,20,6,21,
     +2,2,3,5,6,7,8,9,
     +11,13,15,17,11,20,20,21,
     +2,2,4,5,6,7,8,9,
     +11,13,15,17,19,20,20,21/
      DATA NCODON/
     +2,6,3,1,4,6,4,4,4,2,3,2,2,2,2,2,2,2,1,6,4/
C   SORT OUT MARGIN IE FIND MAX AND DIVIDE BY THREE
      IMARG=NINT(MARGT/3.)
      MARGL1=MARGL
      MARGR1=MARGR
      MARGB1=MARGB
      MARGB2=MARGB+IMARG
      MARGB3=MARGB+2*IMARG
      MARGT3=IMARG
      MARGT2=IMARG
      MARGT1=IMARG
      SD=4.1
      EXPM=0.
      YMIN=EXPM
      YMAX=EXPM+15.*SD
      IBH=NINT(0.005*ISXMAX)
      IMH=NINT(0.005*ISYMAX)
C  ONLY CALC FACTORS UPTO 99!
      CALL FACTAB(FTABLE,99)
      I1IN=2+MXSPAN/2
      I1INM1=I1IN-1
      IDIMJ=J2-J1+1.
      J1P=J1+I1INM1
      J2P=J2+I1INM1
      LB=1+LENW/2
      LB=3*LB
      LF=LENW/2
      LF=3*LF
      LENW3=3*LENW
      XLENW=LENW
      FACN=FACTOR(LENW,FTABLE,IDFTAB)
      XMIN=J1
      XMAX=J2
      CALL CLEARV
      CALL VECTOM
      CALL FRAME(MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
      CALL FRAME(MARGL1,MARGR1,MARGB2,MARGT2,ISXMAX,ISYMAX)
      CALL FRAME(MARGL1,MARGR1,MARGB3,MARGT3,ISXMAX,ISYMAX)
      CALL SCALES(XMAX,XMIN,YMAX,YMIN,MARGL1,MARGR1,
     +MARGB1,MARGT1,ISXMAX,ISYMAX,SD,IBH,YMIN,2)
      CALL SCALES(XMAX,XMIN,YMAX,YMIN,MARGL1,MARGR1,
     +MARGB2,MARGT2,ISXMAX,ISYMAX,SD,IBH,YMIN,2)
      CALL SCALES(XMAX,XMIN,YMAX,YMIN,MARGL1,MARGR1,
     +MARGB3,MARGT3,ISXMAX,ISYMAX,SD,IBH,YMIN,2)
      CALL ROT2(SEQ(J1P-LB),IDIM1,NCOD1,RNFAC(1),FTABLE,
     +IDFTAB,NBASE1,LENW3,FA1,FABC1,NCODON,IACID)
      CALL ROT2(SEQ(J1P+1-LB),IDIM1,NCOD2,RNFAC(2),FTABLE,
     +IDFTAB,NBASE2,LENW3,FA2,FABC2,NCODON,IACID)
      CALL ROT2(SEQ(J1P+2-LB),IDIM1,NCOD3,RNFAC(3),FTABLE,
     +IDFTAB,NBASE3,LENW3,FA3,FABC3,NCODON,IACID)
C   set initial values
      XP=J1
      YP1=0.
      YP2=0.
      YP3=0.
      IDONE=0
      DO 300 IP=J1P,J2P,3
        IDONE=IDONE+1
        IP0=IP
        IP1=IP+1
        IP2=IP+2
        CALL ROTFAK(SEQ,IDIM1P,IP0,LB,LF,NCOD1,RNFAC(1),
     +FTABLE,IDFTAB,NBASE1,COMP(1),LENW3,XLENW,FA1,FABC1,NCODON,IACID)
        CALL ROTFAK(SEQ,IDIM1P,IP1,LB,LF,NCOD2,RNFAC(2),
     +FTABLE,IDFTAB,NBASE2,COMP(2),LENW3,XLENW,FA2,FABC2,NCODON,IACID)
        CALL ROTFAK(SEQ,IDIM1P,IP2,LB,LF,NCOD3,RNFAC(3),
     +FTABLE,IDFTAB,NBASE3,COMP(3),LENW3,XLENW,FA3,FABC3,NCODON,IACID)
        DO 200 K=1,3
          W(K)=RNFAC(K)-COMP(K)-FACN
200     CONTINUE
        IF(MOD(IDONE,IWRIT).EQ.0)THEN
          DO 302 II=1,3
            RLINE(II)=' '
302       CONTINUE
          T=MAX(W(1),W(2),W(3))
          DO 303 II=1,3
            IF(W(II).EQ.T)RLINE(II)=STAR
303       CONTINUE
          IPA=IP-I1INM1
          CALL POISON(LENW,FABC1,FABC1,EW1,WD1,2)
          CALL POISON(LENW,FABC2,FABC2,EW2,WD2,2)
          CALL POISON(LENW,FABC3,FABC3,EW3,WD3,2)
          WDT3=(WD1+WD2+WD3)/3.
          YMAX=EXPM+15.*WDT3
          WDT3=(YMAX-YMIN)/2.
          X=IPA
          Y1=W(1)-EW1
          Y2=W(2)-EW2
          Y3=W(3)-EW3
          CALL LINE(XP,X,YP1,Y1,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1+IMH,MARGT1-2*IMH,ISXMAX,ISYMAX)
          CALL LINE(XP,X,YP2,Y2,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB2+IMH,MARGT2-2*IMH,ISXMAX,ISYMAX)
          CALL LINE(XP,X,YP3,Y3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB3+IMH,MARGT3-2*IMH,ISXMAX,ISYMAX)
          IF(RLINE(1).EQ.STAR)CALL POINT(X,WDT3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
          IF(RLINE(2).EQ.STAR)CALL POINT(X,WDT3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB2,MARGT2,ISXMAX,ISYMAX)
          IF(RLINE(3).EQ.STAR)CALL POINT(X,WDT3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB3,MARGT3,ISXMAX,ISYMAX)
          YP1=Y1
          YP2=Y2
          YP3=Y3
          XP=X
        END IF
300   CONTINUE
      CALL STARTS(SEQ,IDIM1P,J1P,J2P,
     +MARGL1,MARGR1,MARGB,MARGT,ISXMAX,ISYMAX,PAA)
      CALL STOPS(SEQ,IDIM1P,J1P,J2P,
     +MARGL1,MARGR1,MARGB,MARGT,ISXMAX,ISYMAX,PAA)
      CALL VT100M
      END
      SUBROUTINE ROT1(SEQ,IDIM,NCOD,RNFAC,FTABLE,IDFTAB,
     +NBASE,SPAN3)
C   AUTHOR: RODGER STADEN
      REAL RNFAC,FTABLE(IDFTAB),FACTOR
      INTEGER NCOD(4,4,4),NBASE(4),SPAN3,CTONUM
      CHARACTER SEQ(IDIM)
      EXTERNAL FACTOR,CTONUM
C   zero values
      DO 1 I=1,4
      NBASE(I)=0
      DO 1 J=1,4
      DO 1 K=1,4
1     NCOD(I,J,K)=0
C   loop for span length
      DO 10 I=1,SPAN3-1,3
      IP=I-1
C   check for bad chars
      DO 5 J=1,3
5     IF(CTONUM(SEQ(IP+J)).EQ.5)GO TO 10
C   ok
      IS=CTONUM(SEQ(I))
      IS1=CTONUM(SEQ(I+1))
      IS2=CTONUM(SEQ(I+2))
      NCOD(IS,IS1,IS2)=NCOD(IS,IS1,IS2)+1
      NBASE(IS)=NBASE(IS)+1
      NBASE(IS1)=NBASE(IS1)+1
      NBASE(IS2)=NBASE(IS2)+1
10    CONTINUE
C   set up rnfac
      RNFAC=0.
      DO 20 I=1,4
      DO 20 J=1,4
      DO 20 K=1,4
20    RNFAC=RNFAC+FACTOR(NCOD(I,J,K),FTABLE,IDFTAB)
      END
C   rotate factor
      SUBROUTINE ROTFAC(SEQ,IDIM,I,LB,LF,NCOD,RNFAC,FTABLE,
     +IDFTAB,NBASE,COMP,SPAN3)
C   AUTHOR: RODGER STADEN
      REAL RNFAC,FTABLE(IDFTAB),FACTOR
      INTEGER NCOD(4,4,4),NBASE(4),SPAN3,CTONUM
      CHARACTER SEQ(IDIM)
      EXTERNAL FACTOR,CTONUM
C   look back
      IPB=I-LB-1
C   look for bad char (it will not have been used)
      DO 10 J=1,3
10    IF(CTONUM(SEQ(IPB+J)).EQ.5)GO TO 30
C   ok
      IPB=IPB+1
      IS1=CTONUM(SEQ(IPB))
      IS2=CTONUM(SEQ(IPB+1))
      IS3=CTONUM(SEQ(IPB+2))
C   subtract the current factorial value from rotated score
      RNFAC=RNFAC-FACTOR(NCOD(IS1,IS2,IS3),FTABLE,IDFTAB)
C   subtract from codon table
      NCOD(IS1,IS2,IS3)=NCOD(IS1,IS2,IS3)-1
C   add this new value to the rotated score
      RNFAC=RNFAC+FACTOR(NCOD(IS1,IS2,IS3),FTABLE,IDFTAB)
C   now do the composition part
      NBASE(IS1)=NBASE(IS1)-1
      NBASE(IS2)=NBASE(IS2)-1
      NBASE(IS3)=NBASE(IS3)-1
30    CONTINUE
C   now look forwards
      IPB=I+LF-1
C   look for bad char
      DO 40 J=1,3
40    IF(CTONUM(SEQ(IPB+J)).EQ.5)GO TO 50
C   ok
      IPB=IPB+1
      IS1=CTONUM(SEQ(IPB))
      IS2=CTONUM(SEQ(IPB+1))
      IS3=CTONUM(SEQ(IPB+2))
C   subtract the current factorial value from rotated score
      RNFAC=RNFAC-FACTOR(NCOD(IS1,IS2,IS3),FTABLE,IDFTAB)
      NCOD(IS1,IS2,IS3)=NCOD(IS1,IS2,IS3)+1
C   add this new value to the rotated score
      RNFAC=RNFAC+FACTOR(NCOD(IS1,IS2,IS3),FTABLE,IDFTAB)
C   now do the composition part
      NBASE(IS1)=NBASE(IS1)+1
      NBASE(IS2)=NBASE(IS2)+1
      NBASE(IS3)=NBASE(IS3)+1
50    CONTINUE
      COMP=0.
      DO 60 J=1,4
      FREQ=FLOAT(NBASE(J))/FLOAT(SPAN3)
      IF(FREQ.GT.0.)THEN
              COMP=COMP+FLOAT(NBASE(J))*LOG(FREQ)
      GO TO 60
      END IF
60    CONTINUE
      END
      REAL FUNCTION FACTOR(N,FTABLE,IDFTAB)
C   AUTHOR: RODGER STADEN
      REAL FTABLE(IDFTAB)
      FACTOR=0.0
C   in range?
      IF(N.LT.1)GO TO 10
      IF(N.GT.IDFTAB)GO TO 20
      FACTOR=FTABLE(N)
      RETURN
10    CONTINUE
      FACTOR=1.
      RETURN
20    CONTINUE
      WRITE(*,1000)N
1000  FORMAT(' ERROR IN FACTOR, N=',I6)
      END
C   factorial table set up
      SUBROUTINE FACTAB(FTABLE,IDFTAB)
C   AUTHOR: RODGER STADEN
      REAL FTABLE(IDFTAB),X1,LOG2PI
      LOG2PI=0.5*LOG(6.2832)
      X1=1.
      DO 10 I=1,20
      X1=X1*FLOAT(I)
10    FTABLE(I)=LOG(X1)
C   stirlings formula:
C   lni!=(i+.5)*lni-i+0.5ln2pi
C
      DO 20 I=21,IDFTAB
      X1=I
20    FTABLE(I)=(X1+0.5)*LOG(X1)-X1+LOG2PI
      END
      SUBROUTINE ROT2(SEQ,IDIM,NCOD,RNFAC,FTABLE,IDFTAB,
     +NBASE,SPAN3,FA,FABC,NCODON,IACID)
C   AUTHOR: RODGER STADEN
      REAL RNFAC,FTABLE(IDFTAB),FACTOR,FA(21),FABC(4,4,4)
      INTEGER NCOD(4,4,4),NBASE(4),NCODON(21),IACID(4,4,4),SPAN3
      INTEGER CTONUM
      CHARACTER SEQ(IDIM)
      EXTERNAL FACTOR,CTONUM
      SPAN=SPAN3/3.
C   zero values
      DO 1 I=1,4
      NBASE(I)=0
      DO 1 J=1,4
      DO 1 K=1,4
      FABC(I,J,K)=0.
1     NCOD(I,J,K)=0
      DO 2 I=1,21
      FA(I)=0.0
2     CONTINUE
C   loop for span length
      DO 10 I=1,SPAN3-1,3
      IP=I-1
C   check for bad chars
      DO 5 J=1,3
5     IF(CTONUM(SEQ(IP+J)).EQ.5)GO TO 10
C   ok
      IS=CTONUM(SEQ(I))
      IS1=CTONUM(SEQ(I+1))
      IS2=CTONUM(SEQ(I+2))
      NCOD(IS,IS1,IS2)=NCOD(IS,IS1,IS2)+1
      NBASE(IS)=NBASE(IS)+1
      NBASE(IS1)=NBASE(IS1)+1
      NBASE(IS2)=NBASE(IS2)+1
10    CONTINUE
C   set up rnfac
      RNFAC=0.
      DO 20 I=1,4
      DO 20 J=1,4
      DO 20 K=1,4
      JACID=IACID(I,J,K)
      FA(JACID)=FA(JACID)+NCOD(I,J,K)
20    RNFAC=RNFAC+FACTOR(NCOD(I,J,K),FTABLE,IDFTAB)
C   CALC EVEN USE OF EACH ACIDS CODONS
      DO 21 I=1,4
      DO 21 J=1,4
      DO 21 K=1,4
      JACID=IACID(I,J,K)
      FABC(I,J,K)=FA(JACID)/(SPAN*NCODON(JACID))
21    CONTINUE
      END
C   rotate factor
      SUBROUTINE ROTFAK(SEQ,IDIM,I,LB,LF,NCOD,RNFAC,FTABLE,
     +IDFTAB,NBASE,COMP,SPAN3,SPAN,FA,FABC,NCODON,IACID)
C   AUTHOR: RODGER STADEN
      REAL RNFAC,FTABLE(IDFTAB),FACTOR,FABC(4,4,4),FA(21)
      INTEGER NCOD(4,4,4),NBASE(4),SPAN3,NCODON(21),IACID(4,4,4)
      INTEGER CTONUM
      CHARACTER SEQ(IDIM)
      EXTERNAL FACTOR,CTONUM
C   look back
      IPB=I-LB-1
C   look for bad char (it will not have been used)
      DO 10 J=1,3
10    IF(CTONUM(SEQ(IPB+J)).EQ.5)GO TO 30
C   ok
      IPB=IPB+1
      IS1=CTONUM(SEQ(IPB))
      IS2=CTONUM(SEQ(IPB+1))
      IS3=CTONUM(SEQ(IPB+2))
C   subtract the current factorial value from rotated score
      RNFAC=RNFAC-FACTOR(NCOD(IS1,IS2,IS3),FTABLE,IDFTAB)
C   subtract from codon table
      NCOD(IS1,IS2,IS3)=NCOD(IS1,IS2,IS3)-1
C   add this new value to the rotated score
      RNFAC=RNFAC+FACTOR(NCOD(IS1,IS2,IS3),FTABLE,IDFTAB)
C   now do the composition part
      NBASE(IS1)=NBASE(IS1)-1
      NBASE(IS2)=NBASE(IS2)-1
      NBASE(IS3)=NBASE(IS3)-1
      JACID=IACID(IS1,IS2,IS3)
      FA(JACID)=FA(JACID)-1.
      TOTA=FA(JACID)/(SPAN*NCODON(JACID))
      CALL NORMA2(FABC,JACID,TOTA)
30    CONTINUE
C   now look forwards
      IPB=I+LF-1
C   look for bad char
      DO 40 J=1,3
40    IF(CTONUM(SEQ(IPB+J)).EQ.5)GO TO 50
C   ok
      IPB=IPB+1
      IS1=CTONUM(SEQ(IPB))
      IS2=CTONUM(SEQ(IPB+1))
      IS3=CTONUM(SEQ(IPB+2))
C   subtract the current factorial value from rotated score
      RNFAC=RNFAC-FACTOR(NCOD(IS1,IS2,IS3),FTABLE,IDFTAB)
      NCOD(IS1,IS2,IS3)=NCOD(IS1,IS2,IS3)+1
C   add this new value to the rotated score
      RNFAC=RNFAC+FACTOR(NCOD(IS1,IS2,IS3),FTABLE,IDFTAB)
C   now do the composition part
      NBASE(IS1)=NBASE(IS1)+1
      NBASE(IS2)=NBASE(IS2)+1
      NBASE(IS3)=NBASE(IS3)+1
      JACID=IACID(IS1,IS2,IS3)
      FA(JACID)=FA(JACID)+1.
      TOTA=FA(JACID)/(SPAN*NCODON(JACID))
      CALL NORMA2(FABC,JACID,TOTA)
50    CONTINUE
      COMP=0.
      DO 60 J=1,4
      FREQ=FLOAT(NBASE(J))/FLOAT(SPAN3)
      IF(FREQ.GT.0.)THEN
        COMP=COMP+FLOAT(NBASE(J))*LOG(FREQ)
      GO TO 60
      END IF
60    CONTINUE
      END
      SUBROUTINE POISON(LCOD,F,FABC,OUTW,OUTWD,JOB)
C   AUTHOR: D. R BOSWELL AND RODGER STADEN
      REAL F(4),FABC(4,4,4)
C
C  modified by rs 2-2-83 to include correction of -.5*ln(2piN) where
C  N is no of codons (lcod). This is required because I calc using
C  multinomial distribution and poisson uses poisson distributon.
C  maybe later I should also use poisson.
C  Modified 25 Jan 83 to include corrections for lack of restriction
C   of total codon number inherent in the Poisson model
C   (see Andrew's notes of 7 Jan 83)
C
C  The following arrays contain values of <W> and <(delta W)**2>
C   computed for Poisson distributions for nu from 0.0 to 10.0 in
C   steps of 0.1
C  The functions are sufficiently smooth to allow linear interpolation
C   between these values
C
      REAL W(0:100),DW2(0:100),W10(10),DW210(10)
      SAVE W10,DW2,W,DW210
      DATA   W/ 0.0,0.333677,  0.535378,  0.691144, 0.819071,0.927637,
     1  1.021753,  1.104597,  1.178383,  1.244725,  1.304842,
     1  1.359685,  1.410006,  1.456414,  1.499409,  1.539405,
     1  1.576749,  1.611735,  1.644613,  1.675600,  1.704883,
     1  1.732621,  1.758958,  1.784016,  1.807907,  1.830726,
     1  1.852561,  1.873487,  1.893574,  1.912883,  1.931471,
     1  1.949385,  1.966674,  1.983377,  1.999532,  2.015173,
     1  2.030330,  2.045035,  2.059310,  2.073183,  2.086673,
     1  2.099801,  2.112587,  2.125048,  2.137200,  2.149058,
     1  2.160635,  2.171947,  2.183003,  2.193815,  2.204396,
     1  2.214752,  2.224895,  2.234834,  2.244576,  2.254128,
     1  2.263500,  2.272696,  2.281723,  2.290591,  2.299299,
     1  2.307859,  2.316271,  2.324544,  2.332680,  2.340684,
     1  2.348562,  2.356317,  2.363950,  2.371470,  2.378875,
     1  2.386173,  2.393366,  2.400454,  2.407444,  2.414335,
     1  2.421134,  2.427840,  2.434457,  2.440988,  2.447433,
     1  2.453796,  2.460078,  2.466282,  2.472411,  2.478464,
     1  2.484445,  2.490354,  2.496194,  2.501966,  2.507673,
     1  2.513316,  2.518894,  2.524412,  2.529868,  2.535266,
     1  2.540605,  2.545888,  2.551117,  2.556289,  2.561411/
      DATA DW2/ 0.0,0.564147,  0.615536,  0.604980,0.578119,0.548425,
     1  0.520633,  0.496362,  0.475974,  0.459312,  0.446008,
     1  0.435632,  0.427759,  0.421991,  0.417978,  0.415411,
     1  0.414025,  0.413597,  0.413938,  0.414884,  0.416304,
     1  0.418091,  0.420146,  0.422401,  0.424790,  0.427265,
     1  0.429780,  0.432308,  0.434822,  0.437301,  0.439725,
     1  0.442090,  0.444380,  0.446592,  0.448719,  0.450763,
     1  0.452725,  0.454593,  0.456378,  0.458077,  0.459696,
     1  0.461236,  0.462698,  0.464085,  0.465401,  0.466650,
     1  0.467835,  0.468958,  0.470021,  0.471033,  0.471987,
     1  0.472895,  0.473758,  0.474571,  0.475347,  0.476081,
     1  0.476778,  0.477444,  0.478074,  0.478669,  0.479243,
     1  0.479780,  0.480300,  0.480791,  0.481261,  0.481711,
     1  0.482136,  0.482542,  0.482935,  0.483305,  0.483668,
     1  0.484009,  0.484333,  0.484652,  0.484950,  0.485244,
     1  0.485518,  0.485790,  0.486046,  0.486291,  0.486531,
     1  0.486763,  0.486985,  0.487203,  0.487408,  0.487606,
     1  0.487800,  0.487990,  0.488172,  0.488348,  0.488517,
     1  0.488678,  0.488844,  0.488993,  0.489148,  0.489290,
     1  0.489438,  0.489575,  0.489704,  0.489840,  0.489961/
C
C  The next two arrays are for nu from 10.0 to 100.0 in steps of 10.0
C
      DATA   W10/
     1  2.561411,  2.912526,  3.116712,  3.261270,  3.373267,
     1  3.464711,  3.541987,  3.608907,  3.667911,  3.720688/
      DATA DW210/
     1  0.489961,  0.495480,  0.497065,  0.497826,  0.498281,
     1  0.498570,  0.498778,  0.498917,  0.499063,  0.499146/
C
C  rs correction factor
      CORREC=0.5*LOG(6.2832*LCOD)
C
C
C  Initialise accumulators to zero
C   (Note that SDW will accumulate the sum of squares of DW, and
C   we will need to take its square root at the end
C
      SW=0.0
      SDW=0.0
C  Step through all 64 codons
      DO 200 I=1,4
      DO 200 J=1,4
      DO 200 K=1,4
C  V (=nu) is the expected codon frequency in this slot of the table
      IF(JOB.EQ.1)THEN
                V=REAL(LCOD)*F(I)*F(J)*F(K)
      ELSE IF(JOB.EQ.2)THEN
                V=REAL(LCOD)*FABC(I,J,K)
      END IF
C  V<0.0 is a fatal error (implies bad parameters)
      IF(V.LT.0.0)GO TO 900
C  V>=10.0 requires separate handling
      IF(V.GE.10.0)GOTO 100
C  Now we can interpolate in the tables and accumulate the appropriate values
      IV=IFIX(V*10.0)
      DV=V*10.0-IV
      SW=SW+W(IV)+DV*(W(IV+1)-W(IV))
      SDW=SDW+DW2(IV)+DV*(DW2(IV+1)-DW2(IV))
      GO TO 200
C  Come here if V>=10.0
100   IF(V.GT.100.0)GOTO 110
      IV=IFIX(V/10.0)
      DV=V/10.0-IV
      SW=SW+W10(IV)+DV*(W10(IV+1)-W10(IV))
      SDW=SDW+DW210(IV)+DV*(DW210(IV+1)-DW210(IV))
      GO TO 200
C  If V>100.0 we're quite justified in using the "large V" approximations
110   SW=SW+0.5*(LOG(2.0*3.1415926536)+LOG(V)+1.0)
      SDW=SDW+0.5
200   CONTINUE
C  Include correction factors
      OUTW=MAX(0.0,SW-64.0/(4.0*REAL(LCOD)))
      OUTWD=SQRT(MAX(0.0,SDW-64.0*64.0/(4.0*REAL(LCOD))))
C  rs correction
      OUTW=OUTW-CORREC
      RETURN
C  Come here if there's an error in the parameters
900   WRITE(*,1)LCOD,F
1     FORMAT(' POISSON ERROR -- INVALID PARAMETERS'/,
     1' SEQUENCE LENGTH: ',I5,'   BASE FREQUENCIES: ',4F8.3)
      OUTW=0.0
      OUTWD=0.0
      END
      SUBROUTINE NORMA2(SUM,JACID,TOTA)
C   AUTHOR: RODGER STADEN
C     routine to set all the values for any acid to one
C   particular value=tota for a table of codon freqs
C   ncods is number of cods per acid numbering from f to g
C   codnos are pointers to the values of codon usage in sum
C   (which is 4,4,4) for each set of codons for each acid in
C   turn from f to g (* is acid 11)
C   codnos are pointers to the first element in codp for each
C   acids set of codons
C   if jacid gt 0 process only acid jacid, else process all
C   tota is the total value each acid should sum to
      REAL SUM(64)
      INTEGER NCODS(21),CODNOS(21),CODP(64)
      SAVE NCODS,CODNOS,CODP
      DATA NCODS/2,6,3,1,4,6,4,4,4,2,3,2,2,2,2,2,2,2,1,6,4/
      DATA CODNOS/1,3,9,12,13,17,23,27,31,35,37,40,42,44,46,
     +48,50,52,54,55,61/
      DATA CODP/1,17,33,49,2,18,34,50,3,19,35,51,
     +4,20,36,52,5,21,37,53,15,31,6,22,38,54,
     +7,23,39,55,8,24,40,56,9,25,41,57,45,
     +10,26,42,58,11,27,43,59,12,28,44,60,
     +13,29,61,14,30,46,62,47,63,16,32,48,64/
      IACID=1
      IF(JACID.NE.0)IACID=JACID
1     CONTINUE
C   loop for acid iacid from codnos to codnos+ncods-1
      DO 20 J=CODNOS(IACID),CODNOS(IACID)+NCODS(IACID)-1
      SUM(CODP(J))=TOTA
20    CONTINUE
      IF(JACID.NE.0)RETURN
      IACID=IACID+1
      IF(IACID.LT.22)GO TO 1
      END
      SUBROUTINE PCODUS(SEQ,IDIM1P,IEND,MXSPAN,
     +ISXMAX,ISYMAX,J1,J2,KSTART,MARGL,MARGR,MARGB,MARGT,IDEV,FILNAM,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,PAA)
      CHARACTER HELPF*(*),PAA(5,5,5)
C   AUTHOR: RODGER STADEN
      REAL FREQ(64),SUM(64),LOGFRQ(64)
      CHARACTER SEQ(IDIM1P),FILNAM*(*)
      INTEGER ANSTY
C   NOTE J1 J2 IS THE ACTIVE REGION, KSTART IS THE NUMBER OF THE 
C   BASE IN ELEMENT 1 OF SEQ, AND IEND IS THE SEQUENCE NUMBER OF THELAST 
C   ELEMENT IN THE RAM BUFFER
C   PLOTS ARE FROM J1 TO J2 BUT STANDARDS CAN
C   BE TAKEN FROM KSTART TO IEND
      CALL SHOWFU(KBOUT,'Staden and McLachlan codon usage')
C      WRITE(KBOUT,*)'Staden and McLachlan codon usage method'
C      WRITE(KBOUT,*)'Codon tables for standards may be read from disk'
C      WRITE(KBOUT,*)'or calculated from parts of the current sequence'
      CALL GETPAR(42,7,IOK,MINSP,MAXSP,LENW,MINIW,MAXIW,IWRIT,ANSTY,
     +IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      CALL PCODD(SEQ,IDIM1P,IEND,MXSPAN,
     +KSTART,IDEV,FILNAM,FREQ,SUM,LOGFRQ,ANSTY,
     +MINSP,MAXSP,LENW,MINIW,MAXIW,IWRIT,P1,P2,P3,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,PAA,IOK)
      IF(IOK.NE.0) RETURN
      CALL PCODPP(SEQ,IDIM1P,MXSPAN,
     +ISXMAX,ISYMAX,J1,J2,KSTART,MARGL,MARGR,MARGB,MARGT,PAA,
     +LOGFRQ,LENW,IWRIT,P1,P2,P3)
      END
      SUBROUTINE PCODD(SEQ,IDIM1P,IEND,MXSPAN,
     +KSTART,IDEV,FILNAM,FREQ,SUM,LOGFRQ,ANSTY,
     +MINSP,MAXSP,LENW,MINIW,MAXIW,IWRIT,P1,P2,P3,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,PAA,IOK)
      CHARACTER HELPF*(*),PAA(5,5,5)
C   AUTHOR: RODGER STADEN
      REAL FREQ(64),SUM(64),LOGFRQ(64)
      CHARACTER SEQ(IDIM1P),FILNAM*(*)
      INTEGER ANSTY
      CALL FILLR(FREQ,64,0.)
      CALL PCODD1(ANSTY,PAA,FREQ,IDEV,FILNAM,IOK,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IOK.NE.0) RETURN
      I1INM1 = 1+(MXSPAN/2)-KSTART+1
      IF(ANSTY.EQ.0) THEN
6       CONTINUE
        I1 = 0
        I2 = 0
        CALL GTREG(KBIN,KBOUT,0,IEND,I1,I2,
     +  'Define standard',
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        IF(I1.NE.0) THEN
          IDIM=I2-I1+1
          IF(IDIM.GT.3) THEN
            CALL FILLR(SUM,64,0.)
            CALL CALCOD(SUM,SEQ(I1+I1INM1),IDIM)
            CALL ADDR(SUM,FREQ,64)
            CALL WRTCOD(SUM,KBOUT,PAA)
            GO TO 6
          END IF
        END IF
      END IF
      SUMCOD=0.
      DO 50 I=1,64
        SUMCOD=SUMCOD+FREQ(I)
50    CONTINUE
      WRITE(KBOUT,1006)SUMCOD
1006  FORMAT(' Total codons in standard= ',F8.0)
C     DONT CONTINUE IF LESS THAN 64. CODONS SPECIFIED
      IF(SUMCOD.LT.64.)THEN
        CALL ERROM(KBOUT,'At least 64 codons required in standard')
        IOK = 1
        RETURN
      END IF
      CALL AACODM(KBIN,KBOUT,FREQ,PAA,SUMCOD,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.LT.0)RETURN
      CALL WRTCOD(FREQ,KBOUT,PAA)
      SUMCOD=0.
      DO 51 I=1,64
        SUMCOD=SUMCOD+FREQ(I)
51    CONTINUE
C     NORMALIZE, DO STOP CODONS AND ZERO CODONS
      CALL PCOD2(FREQ,LOGFRQ,SUMCOD,LOGFRQ,PAA)
C      CALL WRTCOD(LOGFRQ,KBOUT,PAA)
C   CALC EXPECTED FREQS FRAME S AND T CODONS AND EXPECTED P'S FOR ALL FRAMES
      LENWT = 11
      DO 60 I = 1,3
        LENWT = LENWT + 10
        CALL PCOD3(FREQ,LOGFRQ,LENWT,P1,P2,P3)
        WRITE(KBOUT,2000)LENWT,P1,P2,P3
60    CONTINUE
2000  FORMAT(' Span length ',I3,' expected mean values:',3(F6.1))
      CALL GSPIN(MINSP,MAXSP,LENW,MINIW,MAXIW,IWRIT,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      CALL PCOD3(FREQ,LOGFRQ,LENW,P1,P2,P3)
      END
      SUBROUTINE PCODPP(SEQ,IDIM1P,MXSPAN,
     +ISXMAX,ISYMAX,J1,J2,KSTART,MARGL,MARGR,MARGB,MARGT,PAA,
     +LOGFRQ,LENW,IWRIT,P1,P2,P3)
      CHARACTER PAA(5,5,5)
C   AUTHOR: RODGER STADEN
      REAL LOGFRQ(64),SUMW(3)
      CHARACTER SEQ(IDIM1P),RFRAME(3)
      LB=1+LENW/2
      LB=3*LB
      LF=LENW/2
      LF=3*LF
      LENW3=3*LENW
      EPS=0.0000001
      IMARG=NINT(MARGT/3.)
      MARGL1=MARGL
      MARGR1=MARGR
      MARGB1=MARGB
      MARGB2=MARGB+IMARG
      MARGB3=MARGB+2*IMARG
      MARGT3=IMARG
      MARGT2=IMARG
      MARGT1=IMARG
      I1IN=2+(MXSPAN/2)-KSTART+1
      I1INM1=I1IN-1
      IDIMJ=J2-J1+1.
      J1P=J1+I1INM1
      J2P=J2+I1INM1
      XMIN=J1
      XMAX=J2
      IBH=NINT(0.005*ISXMAX)
      IMH=NINT(0.005*ISYMAX)
      SD=1.
      CALL FILLR(SUMW,3,0.)
      IDONE=0
      YMIN=MIN(P2,P3)
      YMIN=YMIN
      YMAX=P1
      CALL CLEARV
      CALL VECTOM
      CALL FRAME(MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
      CALL FRAME(MARGL1,MARGR1,MARGB2,MARGT2,ISXMAX,ISYMAX)
      CALL FRAME(MARGL1,MARGR1,MARGB3,MARGT3,ISXMAX,ISYMAX)
      YFIRST=INT(YMIN)
      CALL SCALES(XMAX,XMIN,YMAX,YMIN,MARGL1,MARGR1,
     +MARGB1,MARGT1,ISXMAX,ISYMAX,SD,IBH,YFIRST,2)
      CALL SCALES(XMAX,XMIN,YMAX,YMIN,MARGL1,MARGR1,
     +MARGB2,MARGT2,ISXMAX,ISYMAX,SD,IBH,YFIRST,2)
      CALL SCALES(XMAX,XMIN,YMAX,YMIN,MARGL1,MARGR1,
     +MARGB3,MARGT3,ISXMAX,ISYMAX,SD,IBH,YFIRST,2)
      CALL CODSTR(SEQ(J1P-LB),IDIM1P,LOGFRQ,LENW3,SUMW(1))
      CALL CODSTR(SEQ(J1P+1-LB),IDIM1P,LOGFRQ,LENW3,SUMW(2))
      CALL CODSTR(SEQ(J1P+2-LB),IDIM1P,LOGFRQ,LENW3,SUMW(3))
      XP=J1
      YP1=0.
      YP2=0.
      YP3=0.
      DO 300 IP=J1P,J2P,3
        IDONE=IDONE+1
        IP0=IP
        IP1=IP+1
        IP2=IP+2
        CALL ROTCOD(SEQ,IDIM1P,IP0,LB,LF,LOGFRQ,SUMW(1))
        CALL ROTCOD(SEQ,IDIM1P,IP1,LB,LF,LOGFRQ,SUMW(2))
        CALL ROTCOD(SEQ,IDIM1P,IP2,LB,LF,LOGFRQ,SUMW(3))
        IF(MOD(IDONE,IWRIT).EQ.0)THEN
          CALL PCOD1(SUMW,Y1,Y2,Y3,RFRAME)
C         CHECK FOR OVERFLOW SHOWN BY VALUES =0.
          IF(ABS(Y1).LT.EPS)Y1=YP1
          IF(ABS(Y2).LT.EPS)Y2=YP2
          IF(ABS(Y3).LT.EPS)Y3=YP3
          IPA=IP-I1INM1
          X=IPA
          CALL LINE(XP,X,YP1,Y1,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1+IMH,MARGT1-2*IMH,ISXMAX,ISYMAX)
          CALL LINE(XP,X,YP2,Y2,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB2+IMH,MARGT2-2*IMH,ISXMAX,ISYMAX)
          CALL LINE(XP,X,YP3,Y3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB3+IMH,MARGT3-2*IMH,ISXMAX,ISYMAX)
          IF(RFRAME(1).EQ.'*')
     +    CALL POINT(X,0.,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
          IF(RFRAME(2).EQ.'*')
     +    CALL POINT(X,0.,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB2,MARGT2,ISXMAX,ISYMAX)
          IF(RFRAME(3).EQ.'*')
     +    CALL POINT(X,0.,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB3,MARGT3,ISXMAX,ISYMAX)
C         SAVE CURRENT VALUES
          YP1=Y1
          YP2=Y2
          YP3=Y3
          XP=X
        END IF
300   CONTINUE
C   STARTS
      CALL STARTS(SEQ,IDIM1P,J1P,J2P,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,PAA)
C   STOPS
      CALL STOPS(SEQ,IDIM1P,J1P,J2P,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,PAA)
      CALL VT100M
      END
      SUBROUTINE PCODD1(ANSTY,PAA,FREQ,IDEV,FILNAM,IOK,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      REAL FREQ(64)
      CHARACTER PAA(125),HELPF*(*),FILNAM*(*)
      INTEGER CHOICE,ANSTY
      IOK = 1
      CHOICE = ANSTY
      CALL YESONO(CHOICE,'Define internal standard',
     +'Read standard from file',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(CHOICE.LT.0) RETURN
      ANSTY = CHOICE
      IF(ANSTY.EQ.1) THEN
        FILNAM = ' '
        CALL OPENF1(IDEV,FILNAM,0,IOK,KBIN,KBOUT,
     +  'File name of standard',
     +  IHELPS,IHELPE,HELPF,IDEVH)
        IF(IOK.NE.0) RETURN
        CALL REDCOD(FREQ,IDEV)
        CLOSE(UNIT=IDEV)
        CALL WRTCOD(FREQ,KBOUT,PAA)
      END IF
      IOK = 0
      END
      SUBROUTINE AACODM(KBIN,KBOUT,FREQ,PAA,SUMCOD,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      REAL FREQ(64)
      CHARACTER PAA(5,5,5)
      CHARACTER HELPF*(*)
      INTEGER CHOICE
      PARAMETER (MAXPRM = 43)
      CHARACTER PROMPT(3)*(MAXPRM)
      CHOICE = 1
      PROMPT(1) = 'Use observed frequencies'
      PROMPT(2) = 'Normalize to average amino acid composition'
      PROMPT(3) = 'Normalize to no amino acid bias'
      CALL RADION('Select normalization',PROMPT,3,CHOICE,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(CHOICE.LT.1) THEN
        IOK = 1
        RETURN
      END IF
      SUMC = SUMCOD/64.
      IF(CHOICE.EQ.2) CALL APLAAC(FREQ,PAA)
      IF(CHOICE.EQ.3) CALL NORMAA(FREQ,SUMC,PAA)
      IOK = 0
      END
      SUBROUTINE APLAAC(SUM,PAA)
      CHARACTER PAA(5,5,5),AA(21)
      REAL SUM(4,4,4),EXPERC(21)
C  ARGOS VALUES
      SAVE EXPERC,AA
      DATA EXPERC/8.3,1.7,5.3,6.2,3.9,7.2,2.2,5.2,5.7,
     +9.0,2.4,4.4,5.1,4.0,5.7,6.9,5.8,6.6,1.3,3.2,0.0/
      DATA AA/'A','C','D','E','F',
     1'G','H','I','K','L',
     2'M','N','P','Q','R',
     3'S','T','V','W','Y','*'/
C   LOOP FOR EACH ACID
      DO 150 L=1,21
        ASUM=0.
C   LOOP FOR EACH CODON
        DO 200 I=1,4
          DO 200 J=1,4
            DO 200 K=1,4
C             COUNT CODONS
              IF(PAA(K,J,I).EQ.AA(L))ASUM=ASUM+SUM(I,J,K)
200     CONTINUE
        IF(ASUM.GT.0.0)ASUM = 6.4 / ASUM
C   LOOP FOR EACH CODON
        DO 100 I=1,4
          DO 100 J=1,4
            DO 100 K=1,4
C             NORMALIZE
        IF(PAA(K,J,I).EQ.AA(L))SUM(I,J,K)=SUM(I,J,K)*ASUM*EXPERC(L)
100     CONTINUE
150   CONTINUE
      END
      SUBROUTINE PCOD3(FREQ,LOGFRQ,LENW,P11,P22,P33)
C   AUTHOR: RODGER STADEN
      PARAMETER (SMALL = 1.0E-30)
      DOUBLE PRECISION U,V,W,SL,UL,VL,WL,P1,P2,P3
      REAL FREQ(64),LOGFRQ(64),S2(64),S3(64)
      CALL F2FF1(FREQ,S2)
      CALL F3FF1(FREQ,S3)
C   CALC EXPECTED MEAN SCORES FOR THIS WINDOW LENGTH AND STANDARD
      U=0.
      V=0.
      W=0.
      DO 62 I=1,64
        U=U+FREQ(I)*LOGFRQ(I)
        V=V+S2(I)*LOGFRQ(I)
        W=W+S3(I)*LOGFRQ(I)
62    CONTINUE
      SL=U+V+W
      SL=SL/3.
      U=U-SL
      V=V-SL
      W=W-SL
      UL=EXP(U*LENW)
      VL=EXP(V*LENW)
      WL=EXP(W*LENW)
      SL=UL+VL+WL
      P1=UL/SL
      P2=VL/SL
      P3=WL/SL
      IF(ABS(P1-1.0).GT.SMALL)P11=LOG10(P1/(1.-P1))
      IF(ABS(P2-1.0).GT.SMALL)P22=LOG10(P2/(1.-P2))
      IF(ABS(P3-1.0).GT.SMALL)P33=LOG10(P3/(1.-P3))
      END
      SUBROUTINE PCOD2(FREQ,LOGFRQ,SUMCOD,LOGFR3,PAA)
C   AUTHOR: RODGER STADEN
      CHARACTER PAA(5,5,5)
      REAL FREQ(64),LOGFRQ(64),LOGFR3(4,4,4)
C   NORMALIZE
      DO 51 I=1,64
        FREQ(I)=FREQ(I)/SUMCOD
51    CONTINUE
C   TAKE LOGS
      DO 52 I=1,64
        LOGFRQ(I)=0.0
        IF(FREQ(I).NE.0.)LOGFRQ(I)=LOG(FREQ(I))
52    CONTINUE
C   NEED TO DEAL WITH STOP CODONS AND ZERO FREQS
      ODX=1./SUMCOD
      ODXL=LOG(ODX)
      STOPT=0.
      NSTOP=0
C   LOOK FOR STOPS IN PAA
      DO 10 I=1,4
      DO 10 J=1,4
      DO 10 K=1,4
        IF(PAA(K,J,I).EQ.'*')THEN
          LOGFR3(I,J,K)=99.
          STOPT=STOPT+99.
          NSTOP=NSTOP+1
        END IF
10    CONTINUE
C   SET ZEROES TO LOG(1/TOTAL)
      DO 53 I=1,64
        IF(LOGFRQ(I).EQ.0.)LOGFRQ(I)=ODXL
53    CONTINUE
C   SET STOPS TO MEAN
      X1=0.
      DO 54 I=1,64
        X1=X1+LOGFRQ(I)
54    CONTINUE
      IF(NSTOP.NE.64)X1=(X1-STOPT)/(64-NSTOP)
C   LOOK FOR STOPS IN PAA
      DO 20 I=1,4
      DO 20 J=1,4
      DO 20 K=1,4
        IF(PAA(K,J,I).EQ.'*')LOGFR3(I,J,K)=X1
20    CONTINUE
      END
      SUBROUTINE PCOD1(SUMW,Y1,Y2,Y3,LINE)
C   AUTHOR: RODGER STADEN
      DOUBLE PRECISION SUMWT(3),T,T1
      REAL SUMW(3)
      CHARACTER LINE(3)
C   calc mean of sums to add to each
      T=SUMW(1)+SUMW(2)+SUMW(3)
      T=T/3.
      T=-1.*T
      DO 80 II=1,3
C   add mean to each
        SUMWT(II)=SUMW(II)+T
C   calc exponential of each
        SUMWT(II)=EXP(SUMWT(II))
80    CONTINUE
C   calc sum of exponentials
      T=SUMWT(1)+SUMWT(2)+SUMWT(3)
      DO 298 II=1,3
C   divide each by sum of exponetials
        IF(T.NE.0.)SUMWT(II)=SUMWT(II)/T
        T1=1.-SUMWT(II)
        IF(T1.NE.0.)SUMWT(II)=SUMWT(II)/T1
        IF(SUMWT(II).GT.0.)SUMWT(II)=LOG10(SUMWT(II))
298   CONTINUE
C   get largest
      CALL FILLC(LINE,3,' ')
      T=MAX(SUMWT(1),SUMWT(2),SUMWT(3))
      DO 10 I=1,3
        IF(T.EQ.SUMWT(I))LINE(I)='*'
10    CONTINUE
      Y1=SUMWT(1)
      Y2=SUMWT(2)
      Y3=SUMWT(3)
      END
      SUBROUTINE CODSTR(SEQ,IDIM,LOGFRQ,LWIND3,SUM)
C   AUTHOR: RODGER STADEN
      REAL LOGFRQ(4,4,4)
      CHARACTER SEQ(IDIM)
      INTEGER CTONUM,IVAL(3)
      EXTERNAL CTONUM
      SUM=0.
C   LOOP FOR WINDOW LENGTH
      DO 100 I=1,LWIND3-1,3
        IP=I-1
C   CHECK FOR NULL CHARS
        DO 10 J=1,3
          IVAL(J)=CTONUM(SEQ(IP+J))
          IF(IVAL(J).EQ.5)GO TO 100
10      CONTINUE
        SUM=SUM+LOGFRQ(IVAL(1),IVAL(2),IVAL(3))
100   CONTINUE
      END
      SUBROUTINE F2FF1(SUM1,SUM2)
C   AUTHOR: RODGER STADEN
      REAL SUM1(4,4,4),SUM2(4,4,4),SXAB(4,4),SCXX(4)
      DO 1 I=1,4
      DO 1 J=1,4
      DO 1 K=1,4
        SUM2(K,J,I)=0.
1     CONTINUE
C     CALC FROM XABCXX ABC IE XAB * CXX
C   XAB
      DO 10 J=1,4
      DO 10 K=1,4
        SXAB(J,K)=0.
        DO 10 I=1,4
          SXAB(J,K)=SXAB(J,K)+SUM1(I,J,K)
10    CONTINUE
C   CXX
      DO 20 I=1,4
        SCXX(I)=0.
        DO 20 J=1,4
        DO 20 K=1,4
          SCXX(I)=SCXX(I)+SUM1(I,J,K)
20    CONTINUE
C   SUM2= XAB * CXX
      DO 30 I=1,4
      DO 30 J=1,4
      DO 30 K=1,4
        SUM2(I,J,K)=SXAB(I,J)*SCXX(K)
30    CONTINUE
      END
C    F3FF1
      SUBROUTINE F3FF1(SUM1,SUM3)
C   AUTHOR: RODGER STADEN
      REAL SUM1(4,4,4),SUM3(4,4,4),SXXA(4),SBCX(4,4)
      DO 1 I=1,4
      DO 1 J=1,4
      DO 1 K=1,4
        SUM3(K,J,I)=0.
1     CONTINUE
C   CALC ABC FROM XXABCXX  IE XXA * BCX
C   XXA
      DO 10 K=1,4
        SXXA(K)=0.
        DO 10 I=1,4
        DO 10 J=1,4
          SXXA(K)=SXXA(K)+SUM1(I,J,K)
10    CONTINUE
C   BCX
      DO 20 I=1,4
      DO 20 J=1,4
        SBCX(I,J)=0.
        DO 20 K=1,4
          SBCX(I,J)=SBCX(I,J)+SUM1(I,J,K)
20    CONTINUE
C  XXA * BCX
      DO 30 I=1,4
      DO 30 J=1,4
      DO 30 K=1,4
        SUM3(I,J,K)=SXXA(I)*SBCX(J,K)
30    CONTINUE
      END
C   THIS ROUTINE DOES NOT CHECK FOR GOING OUT OF ARRAY
      SUBROUTINE ROTCOD(SEQ,IDIM1,I,LB,LF,LOGFRQ,H)
C   AUTHOR: RODGER STADEN
      REAL LOGFRQ(4,4,4)
      CHARACTER SEQ(IDIM1)
      INTEGER CTONUM,IVAL(3)
      EXTERNAL CTONUM
      XS=0.
      XA=0.
C   LOOK BACK
      IPB=I-LB-1
      DO 10 J=1,3
        IVAL(J)=CTONUM(SEQ(IPB+J))
        IF(IVAL(J).EQ.5)GO TO 30
10    CONTINUE
C   SET VALUE TO SUBTRACT
      XS=LOGFRQ(IVAL(1),IVAL(2),IVAL(3))
C   NOW LOOK FORWARD
30    CONTINUE
      IPB=I+LF-1
      DO 45 J=1,3
        IVAL(J)=CTONUM(SEQ(IPB+J))
        IF(IVAL(J).EQ.5)GO TO 50
45    CONTINUE
C   OK SO USE
      XA=LOGFRQ(IVAL(1),IVAL(2),IVAL(3))
50    H=H-XS+XA
      RETURN
      END
C    PSRCH
      SUBROUTINE PSRCH(SEQ,IDIM1,J1,J2,STRING,IDIMS,INC,
     +XMAX,XMIN,YMAX,YMIN,MARGL,MARGR,MARGB,MARGT,ISXMAX,
     +ISYMAX,Y,BH)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1),STRING(IDIMS)
      YP=Y+BH
      IAT=J1-INC
10    CONTINUE
      IAT=IAT+INC
      IDIM=J2-IAT
      IF(IDIM.GT.0)THEN
        CALL FIND6(SEQ(IAT),IDIM,STRING,IDIMS,INC,JMATCH)
        IF(JMATCH.NE.0)THEN
          IAT=IAT+JMATCH-1
          X=IAT
          CALL LINE(X,X,YP,Y,XMAX,XMIN,YMAX,YMIN,
     +    MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
          GO TO 10
        END IF
      END IF
      END
      SUBROUTINE PBASEP(SEQ,IDIM1P,MXSPAN,
     +ISXMAX,ISYMAX,J1,J2,KSTART,IENDB,
     +MARGL1,MARGR1,MARGB,MARGT,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,PAA,IDEV,FILNAM,DIALOG)
      CHARACTER HELPF*(*),PAA(5,5,5),FILNAM*(*)
C   AUTHOR: RODGER STADEN
C 11-1-91 Added facility to read standard in the form of codon table
C         and greatly reorganised code! and added new routines.
      REAL EXPEC(5,3),SCORES(5,3),WT(3),S(3)
      CHARACTER SEQ(IDIM1P)
      INTEGER ANSTY,ANSABS,ANSS,DIALOG
C  ARGOS VALUES
      SAVE EXPEC
       DATA EXPEC/0.1768,0.2108,0.2767,0.3357,0.,
     + 0.2707,0.2378,0.3097,0.1818,0.,
     + 0.2506,0.2506,0.2396,0.2592,0./
C  ORIGINAL DAYHOFF VALUES
C      DATA EXPEC/0.1835,0.1932,0.2719,0.3514,0.,
C     10.2382,0.2459,0.3173,0.1985,0.,
C     20.2548,0.2548,0.2377,0.2527,0./
C   NOTE J1 J2 IS THE ACTIVE REGION, KSTART IS THE NUMBER OF THE 
C   BASE IN ELEMENT 1 OF SEQ, AND IDIM1 IS THE LENGTH FROM KSTART
C   TO THE END OF SEQ. PLOTS ARE FROM J1 TO J2 BUT STANDARDS CAN
C   BE TAKEN FROM KSTART TO KSTART+IDIM1-1 = IENDB
      CALL SHOWFU(KBOUT,
     +'Positional base preferences method to find protein genes')
      CALL GETPAR(43,9,IOK,MINSP,MAXSP,LENW,MINIW,MAXIW,IWRIT,
     +ANSABS,ANSTY,ANSS,
     +IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      CALL PBASPD(SEQ,IDIM1P,MXSPAN,
     +KSTART,IENDB,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,
     +ANSTY,ANSABS,ANSS,MINSP,MAXSP,LENW,MINIW,MAXIW,IWRIT,
     +EXPEC,SCORES,WT,S,SMIN,SMAX,DIALOG,PAA,IDEV,FILNAM,IOK)
      IF(IOK.NE.0) RETURN
      CALL PBASPP(SEQ,IDIM1P,MXSPAN,
     +ISXMAX,ISYMAX,J1,J2,KSTART,ANSABS,LENW,IWRIT,
     +EXPEC,SCORES,WT,S,SMIN,SMAX,
     +MARGL1,MARGR1,MARGB,MARGT,PAA)
      END
      SUBROUTINE PBASPD(SEQ,IDIM1P,MXSPAN,
     +KSTART,IENDB,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,
     +ANSTY,ANSABS,ANSS,MINSP,MAXSP,LENW,MINIW,MAXIW,IWRIT,
     +EXPEC,SCORES,WT,S,SMIN,SMAX,DIALOG,PAA,IDEV,FILNAM,IOK)
C   AUTHOR: RODGER STADEN
      REAL EXPEC(5,3),SCORES(5,3),WT(3),S(3)
      CHARACTER SEQ(IDIM1P)
      INTEGER ANSTY,ANSABS,ANSS,CHOICE,DIALOG
      REAL FREQ(64)
      CHARACTER PAA(125),HELPF*(*),FILNAM*(*)
      PARAMETER (MAXPRM = 28)
      CHARACTER PROMPT(3)*(MAXPRM)
      IOK = 1
      DO 30 J=1,3
      WT(J)=1.0
      DO 30 I=1,5
        SCORES(I,J)=EXPEC(I,J)
30    CONTINUE
      IF(DIALOG.EQ.0) THEN
        CALL PBEXP(SCORES,WT,S)
        CALL PBSCAL(SMIN,SMAX,S,ANSABS,LENW,SMIN5,SMAX5,DIF)
        IOK = 0
        RETURN
      END IF
C
C  Select source of standard
C
      PROMPT(1) = 'Use global standard'
      PROMPT(2) = 'Use internal standard'
      PROMPT(3) = 'Use codon usage table'
      IOK = 1
      CHOICE = 1
      CALL RADION('Select standard source',PROMPT,3,CHOICE,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(CHOICE.LT.1) RETURN
      ANSTY = CHOICE
      IF(ANSTY.EQ.3) THEN
C
C  Get standard from a codon table
C
        FILNAM = ' '
        CALL OPENF1(IDEV,FILNAM,0,IOK,KBIN,KBOUT,
     +  'File name of standard',
     +  IHELPS,IHELPE,HELPF,IDEVH)
        IF(IOK.NE.0) RETURN
        CALL REDCOD(FREQ,IDEV)
        CLOSE(UNIT=IDEV)
        CALL WRTCOD(FREQ,KBOUT,PAA)
        CALL GETPBS(FREQ,SCORES)
      ELSE IF(ANSTY.EQ.2) THEN
C
C  Get standard from a section of the sequence
C
        CALL PBD1(SEQ,IDIM1P,MXSPAN,KSTART,IENDB,KBIN,KBOUT,
     +  SCORES,IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      IF(ANSTY.NE.1) THEN
C
C  Allow combination with global standard
C
        PROMPT(1) = 'Use observed frequencies'
        PROMPT(2) = 'Combine with global standard'
        IOK = 1
        CHOICE = 1
        CALL RADION('Select normalisation',PROMPT,2,CHOICE,
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(CHOICE.LT.1) RETURN
        IF(CHOICE.EQ.2)THEN
          DO 36 I=1,2
          DO 36 K=1,4
            SCORES(K,I)=EXPEC(K,I)
36        CONTINUE
        END IF
      END IF
      WRITE(KBOUT,1004)
1004  FORMAT('           T      C      A      G      Range')
      DO 4 I=1,3
        BIG=0.0
        SMALL=99999.0
        DO 5 K=1,4
          BIG = MAX(SCORES(K,I),BIG)
          SMALL = MIN(SCORES(K,I),SMALL)
5       CONTINUE
        RANGE=BIG-SMALL
        WRITE(KBOUT,1005)I,(SCORES(K,I),K=1,4),RANGE
1005    FORMAT('     ',I3,4(1X,F6.3),1X,F6.3)
4     CONTINUE
C
C  Allow different weights for each position
C
      IOK = 1
      CHOICE = 0
      CALL YESONO(CHOICE,
     +'Use 1.0 for positional weights',
     +'Change positional weights',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(CHOICE.LT.0) RETURN
      IOK = 0
      IF(CHOICE.EQ.1)  CALL PBPD2(WT,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      CALL PBEXP(SCORES,WT,S)
        WRITE(KBOUT,1001)S
1001    FORMAT(
     +  ' Expected scores per codon in each frame',/,'   ',3F10.3)
        CALL GSPIN(MINSP,MAXSP,LENW,MINIW,MAXIW,IWRIT,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
C
C  Select relative or absolute values
C
        IOK = 1
        CHOICE = ANSABS
        CALL YESONO(CHOICE,
     +  'Plot relative scores',
     +  'Plot absolute scores',
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(CHOICE.LT.0) RETURN
        ANSABS = CHOICE
      CALL PBSCAL(SMIN,SMAX,S,ANSABS,LENW,SMIN5,SMAX5,DIF)
      WRITE(KBOUT,1002)SMIN,SMAX,DIF
1002  FORMAT(' Scaling values:',/,
     +'    Minimum  maximum    range',/,2X,3F9.4)
C
C  Allow plot scaling
C
      IOK = 1
      CHOICE = ANSS
      CALL YESONO(CHOICE,
     +'Leave scaling values unchanged',
     +'Change scaling values',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(CHOICE.LT.0) RETURN
      ANSS = CHOICE
      IF(ANSS.EQ.1) THEN
        CALL GETRL(SMIN5,SMAX5,SMIN,'Minimum',VALUE,
     +  KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        SMIN = VALUE
        CALL GETRL(SMIN,SMAX5,SMAX,'Maximum',VALUE,
     +  KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        SMAX = VALUE
      END IF
      IOK = 0
      END
      SUBROUTINE PBSCAL(SMIN,SMAX,S,ANSABS,LENW,SMIN5,SMAX5,DIF)
C   AUTHOR: RODGER STADEN
      REAL S(3)
      INTEGER ANSABS
      SM=0.
      IF(ANSABS.EQ.0) THEN
        DO 25 I=1,3
          SM=SM+S(I)
25      CONTINUE
        DO 26 I=1,3
          S(I)=S(I)/SM
26      CONTINUE
      ELSE
        DO 27 I=1,3
          S(I)=S(I)*LENW
27      CONTINUE
      END IF
      SMAX=MAX(S(1),S(2),S(3))
      SMIN=MIN(S(1),S(2),S(3))
      DIF=SMAX-SMIN
      D20=DIF*0.2
      SMAX=SMAX+D20
      SMIN=SMIN-D20
      D50 = DIF*0.5
      SMAX5 = SMAX + D50
      SMIN5 = SMIN - D50
      END
      SUBROUTINE PBPD2(WT,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      REAL WT(3)
      CHARACTER HELPF*(*)
        WRITE(KBOUT,1000)
1000    FORMAT(' Give weights between 0.0 and 1.0',/,
     +  ' to each of the 3 codon positions')
        WMIN = 0.
        WMAX = 1.
        DEF = 1.
9       CONTINUE
        CALL GETRL(WMIN,WMAX,DEF,'Position 1',VALUE,
     +  KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        WT(1) = VALUE
        CALL GETRL(WMIN,WMAX,DEF,'Position 2',VALUE,
     +  KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        WT(2) = VALUE
        CALL GETRL(WMIN,WMAX,DEF,'Position 3',VALUE,
     +  KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        WT(3) = VALUE
C   CHECK FOR ZERO
        X=WT(1)+WT(2)+WT(3)
        IF(X.LT.0.0000001)THEN
         WRITE(KBOUT,*)
     +   'All weights zero, at least one must be non-zero'
         GO TO 9
        END IF
      IOK = 0
      END
      SUBROUTINE PBD1(SEQ,IDIM1P,MXSPAN,KSTART,IENDB,KBIN,KBOUT,
     +SCORES,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      CHARACTER SEQ(IDIM1P)
      REAL SCORES(5,3)
      CHARACTER HELPF*(*)
      INTEGER CTONUM
      EXTERNAL CTONUM
C       NOTE KSTART IS THE NUMBER OF THE 
C       BASE IN ELEMENT 1 OF SEQ, AND IDIM1 IS THE LENGTH FROM KSTART
C       STANDARDS CAN
C       BE TAKEN FROM KSTART TO KSTART+IDIM1-1 = IENDB
        I1INM1=1+(MXSPAN/2)-KSTART+1
        IPASS = 0
11      CONTINUE
        IPASS = IPASS + 1
        K1 = 0
        K2 = 0
        KS1 = KSTART-1
        CALL GTREG(KBIN,KBOUT,KS1,IENDB,K1,K2,
     +  'Define region for standard',
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        IF((K2-K1).LT.191) THEN
          CALL ERROM(KBOUT,'At least 64 codons required in standard')
          IF(IPASS.LT.2) GO TO 11
          IOK = 1
          RETURN
        END IF
        DO 1 I=1,5
          DO 1 J=1,3
            SCORES(I,J)=0.
1         CONTINUE
          NELTS=0
          DO 2 I=K1,K2-2,3
            NELTS=NELTS+1
            IS=CTONUM(SEQ(I+I1INM1))  
            IS1=CTONUM(SEQ(I+I1INM1+1))
            IS2=CTONUM(SEQ(I+I1INM1+2))
            SCORES(IS,1)=SCORES(IS,1)+1.
            SCORES(IS1,2)=SCORES(IS1,2)+1.
            SCORES(IS2,3)=SCORES(IS2,3)+1.
2         CONTINUE
          DO 3 I=1,5
          DO 3 J=1,3
            SCORES(I,J)=SCORES(I,J)/NELTS
3         CONTINUE
      IOK = 0
      END
      SUBROUTINE GETPBS(SUM,COMP)
C   AUTHOR: RODGER STADEN
      REAL SUM(4,4,4),COMP(5,3)
      TCOMP=0.
      DO 50 I=1,5
      DO 50 J=1,3
        COMP(I,J)=0.
50    CONTINUE
      DO 55 J=1,4
      DO 55 K=1,4
      DO 55 L=1,4
        TCOMP=TCOMP+SUM(J,K,L)
        COMP(J,1)=COMP(J,1)+SUM(J,K,L)
        COMP(J,2)=COMP(J,2)+SUM(K,J,L)
        COMP(J,3)=COMP(J,3)+SUM(K,L,J)
55    CONTINUE
      IF(TCOMP.NE.0) THEN
        DO 60 I=1,4
        DO 60 J=1,3
          COMP(I,J)=COMP(I,J)/TCOMP
60      CONTINUE
      END IF
      END
      SUBROUTINE PBASPP(SEQ,IDIM1P,MXSPAN,
     +ISXMAX,ISYMAX,J1,J2,KSTART,ANSABS,LENW,IWRIT,
     +EXPEC,SCORES,WT,S,SMIN,SMAX,
     +MARGL1,MARGR1,MARGB,MARGT,PAA)
      CHARACTER PAA(5,5,5)
C   AUTHOR: RODGER STADEN
      REAL SUMW(3),PROB(3),EXPEC(5,3),SCORES(5,3),WT(3),S(3)
      CHARACTER SEQ(IDIM1P)
      CHARACTER TLINE(3),STAR
      INTEGER ANSABS
      SAVE STAR
      DATA STAR/'*'/
      CALL FILLR(SUMW,3,0.)
      IDONE=0
      IMARG=NINT(MARGT/3.)
      MARGB1=MARGB
      MARGB2=MARGB+IMARG
      MARGB3=MARGB+2*IMARG
      MARGT3=IMARG
      MARGT2=IMARG
      MARGT1=IMARG
      I1IN=2+(MXSPAN/2)-KSTART+1
      I1INM1=I1IN-1
      IDIMJ=J2-J1+1.
      J1P=J1+I1INM1
      J2P=J2+I1INM1
      IMH=NINT(0.005*ISYMAX)
      LB=1+LENW/2
      LB=3*LB
      LF=LENW/2
      LF=3*LF
      LENW3=3*LENW
      YMIN=SMIN
      YMAX=SMAX
      XMIN=J1
      XMAX=J2
C   set initial values
      XP=J1
      YMID=YMIN+(YMAX-YMIN)/2.
      YP1=YMID
      YP2=YMID
      YP3=YMID
      CALL CLEARV
      CALL VECTOM
      XMAX1=XMIN+(XMAX-XMIN)/80.
      CALL LINE(XMIN,XMAX1,S(1),S(1),XMAX,XMIN,YMAX,YMIN,
     +MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
      CALL LINE(XMIN,XMAX1,S(2),S(2),XMAX,XMIN,YMAX,YMIN,
     +MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
      CALL LINE(XMIN,XMAX1,S(3),S(3),XMAX,XMIN,YMAX,YMIN,
     +MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
      CALL LINE(XMIN,XMAX1,S(1),S(1),XMAX,XMIN,YMAX,YMIN,
     +MARGL1,MARGR1,MARGB2,MARGT2,ISXMAX,ISYMAX)
      CALL LINE(XMIN,XMAX1,S(2),S(2),XMAX,XMIN,YMAX,YMIN,
     +MARGL1,MARGR1,MARGB2,MARGT2,ISXMAX,ISYMAX)
      CALL LINE(XMIN,XMAX1,S(3),S(3),XMAX,XMIN,YMAX,YMIN,
     +MARGL1,MARGR1,MARGB2,MARGT2,ISXMAX,ISYMAX)
      CALL LINE(XMIN,XMAX1,S(1),S(1),XMAX,XMIN,YMAX,YMIN,
     +MARGL1,MARGR1,MARGB3,MARGT3,ISXMAX,ISYMAX)
      CALL LINE(XMIN,XMAX1,S(2),S(2),XMAX,XMIN,YMAX,YMIN,
     +MARGL1,MARGR1,MARGB3,MARGT3,ISXMAX,ISYMAX)
      CALL LINE(XMIN,XMAX1,S(3),S(3),XMAX,XMIN,YMAX,YMIN,
     +MARGL1,MARGR1,MARGB3,MARGT3,ISXMAX,ISYMAX)
      CALL FRAME(MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
      CALL FRAME(MARGL1,MARGR1,MARGB2,MARGT2,ISXMAX,ISYMAX)
      CALL FRAME(MARGL1,MARGR1,MARGB3,MARGT3,ISXMAX,ISYMAX)
      CALL PBASES(SEQ(J1P-LB),IDIM1P,LENW3,SUMW(1),SCORES,WT)
      CALL PBASES(SEQ(J1P+1-LB),IDIM1P,LENW3,SUMW(2),SCORES,WT)
      CALL PBASES(SEQ(J1P+2-LB),IDIM1P,LENW3,SUMW(3),SCORES,WT)
      DO 300 IP=J1P,J2P,3
        IDONE=IDONE+1
        IP0=IP
        IP1=IP+1
        IP2=IP+2
        CALL ROTPB1(SEQ,IDIM1P,IP0,LB,LF,SUMW(1),SCORES,WT)
        CALL ROTPB1(SEQ,IDIM1P,IP1,LB,LF,SUMW(2),SCORES,WT)
        CALL ROTPB1(SEQ,IDIM1P,IP2,LB,LF,SUMW(3),SCORES,WT)
        IF(MOD(IDONE,IWRIT).EQ.0)THEN
          PROB(1)=SUMW(1)
          PROB(2)=SUMW(2)
          PROB(3)=SUMW(3)
          IF(ANSABS.EQ.0) THEN
            T=SUMW(1)+SUMW(2)+SUMW(3)
            PROB(1)=PROB(1)/T
            PROB(2)=PROB(2)/T
            PROB(3)=PROB(3)/T
          END IF
          CALL FILLC(TLINE,3,' ')
          T=MAX(PROB(1),PROB(2),PROB(3))
          DO 303 II=1,3
            IF(PROB(II).EQ.T)TLINE(II)=STAR
303       CONTINUE
          IPA=IP-I1INM1
          X=IPA
          CALL LINE(XP,X,YP1,PROB(1),XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1+IMH,MARGT1-2*IMH,ISXMAX,ISYMAX)
          CALL LINE(XP,X,YP2,PROB(2),XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB2+IMH,MARGT2-2*IMH,ISXMAX,ISYMAX)
          CALL LINE(XP,X,YP3,PROB(3),XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB3+IMH,MARGT3-2*IMH,ISXMAX,ISYMAX)
          YP1=PROB(1)
          YP2=PROB(2)
          YP3=PROB(3)
          IF(TLINE(1).EQ.STAR)CALL POINT(
     +    X,YMID,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
          IF(TLINE(2).EQ.STAR)CALL POINT(
     +    X,YMID,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB2,MARGT2,ISXMAX,ISYMAX)
          IF(TLINE(3).EQ.STAR)CALL POINT(
     +    X,YMID,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB3,MARGT3,ISXMAX,ISYMAX)
          XP=X
        END IF
300   CONTINUE
      CALL STARTS(SEQ,IDIM1P,J1P,J2P,
     +MARGL1,MARGR1,MARGB,MARGT,ISXMAX,ISYMAX,PAA)
      CALL STOPS(SEQ,IDIM1P,J1P,J2P,
     +MARGL1,MARGR1,MARGB,MARGT,ISXMAX,ISYMAX,PAA)
      CALL VT100M
      END
      SUBROUTINE PBASES(SEQ,IDIM,LENW,SUM,SCORES,WT)
C   AUTHOR: RODGER STADEN
      REAL SUM
      CHARACTER SEQ(IDIM)
      REAL SCORES(5,3),WT(3)
      INTEGER CTONUM
      EXTERNAL CTONUM
      SUM=0.
      DO 100 I=1,LENW,3
        SUM=SUM+SCORES(CTONUM(SEQ(I)),1)*WT(1)+
     +  SCORES(CTONUM(SEQ(I+1)),2)*WT(2)
     +  +SCORES(CTONUM(SEQ(I+2)),3)*WT(3)
100   CONTINUE
      RETURN
      END
      SUBROUTINE ROTPB1(SEQ,IDIM1,I,LB,LF,H,SCORES,WT)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1)
      INTEGER CTONUM
      REAL SCORES(5,3),WT(3)
      EXTERNAL CTONUM
C   set up dummy values
      XS=0.
      XA=0.
C   look back
      IPB=I-LB-1
      DO 10 J=1,3
        IF(CTONUM(SEQ(IPB+J)).EQ.5)GO TO 30
10    CONTINUE
C   set value to subtract
      IPB=IPB+1
      XS=SCORES(CTONUM(SEQ(IPB)),1)*WT(1)+
     +SCORES(CTONUM(SEQ(IPB+1)),2)*WT(2)
     ++SCORES(CTONUM(SEQ(IPB+2)),3)*WT(3)
C   now look forward
30    CONTINUE
      IPB=I+LF-1
C   look for bad char
      DO 45 J=1,3
        IF(CTONUM(SEQ(IPB+J)).EQ.5)GO TO 50
45    CONTINUE
C   ok so use
      IPB=IPB+1
      XA=SCORES(CTONUM(SEQ(IPB)),1)*WT(1)+
     +SCORES(CTONUM(SEQ(IPB+1)),2)*WT(2)
     ++SCORES(CTONUM(SEQ(IPB+2)),3)*WT(3)
50    H=H-XS+XA
      END
      SUBROUTINE PBEXP(SCORES,WT,S)
C   AUTHOR: RODGER STADEN
      REAL SCORES(5,3),S(3),WT(3)
      DO 50 I=1,3
        S(I)=0.
50    CONTINUE
      DO 60 I=1,4
        S(1)=S(1)+SCORES(I,1)*SCORES(I,1)*WT(1)
     +  +SCORES(I,2)*SCORES(I,2)*WT(2)
     +  +SCORES(I,3)*SCORES(I,3)*WT(3)
        S(2)=S(2)+SCORES(I,2)*SCORES(I,1)*WT(1)
     +  +SCORES(I,3)*SCORES(I,2)*WT(2)
     +  +SCORES(I,1)*SCORES(I,3)*WT(3)
        S(3)=S(3)+SCORES(I,3)*SCORES(I,1)*WT(1)
     +  +SCORES(I,1)*SCORES(I,2)*WT(2)
     +  +SCORES(I,2)*SCORES(I,3)*WT(3)
60    CONTINUE
      END
      SUBROUTINE TRNA(SEQ,IDIM,ISS,ISE,KSTART,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IDEV,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,DIALOG)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      INTEGER CONSC(18)
      INTEGER ANSCON,DIALOG
      CALL SHOWFU(KBOUT,'tRNA search ')
      CALL GETPAR(49,35,IOK,
     +MNLEN,MXLEN,MAXLNT,
     +MNAC,MXAC,MINACL,
     +MNTU,MXTU,MINTU,
     +MNAN,MXAN,MINANT,
     +MND,MXD,MIND,
     +MNI1,MXI1,INT1,
     +MNI2,MXI2,JNT2,
     +MNTUL1,MXTUL1,LTUMIN,
     +MNTUL2,MXTUL2,LTUMAX,
     +MNB,MXB,MINBAS,
     +MNC,MXC,MINCON,IGON,ANSCON)
      IF(IOK.NE.0) RETURN
      IF(DIALOG.EQ.1) CALL TRNAD(
     +MNLEN,MXLEN,MAXLNT,
     +MNAC,MXAC,MINACL,
     +MNTU,MXTU,MINTU,
     +MNAN,MXAN,MINANT,
     +MND,MXD,MIND,
     +MNI1,MXI1,INT1,
     +MNI2,MXI2,JNT2,
     +MNTUL1,MXTUL1,LTUMIN,
     +MNTUL2,MXTUL2,LTUMAX,
     +MNB,MXB,MINBAS,
     +MINCON,IGON,ANSCON,
     +CONSC,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      CALL TRNAP(SEQ,IDIM,ISS,ISE,KSTART,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IDEV,KBOUT,
     +MAXLNT,MINACL,MINTU,MINANT,MIND,INT1,JNT2,
     +LTUMIN,LTUMAX,MINBAS,MINCON,IGON,ANSCON,CONSC)
      CALL VT100M
      END
      SUBROUTINE TRNAP(SEQ,IDIM,ISS,ISE,KSTART,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IDEV,KBOUT,
     +MAXLNT,MINACL,MINTU,MINANT,MIND,INT1,JNT2,
     +LTUMIN,LTUMAX,MINBAS,MINCON,IGON,ANSCON,CONSC)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      INTEGER RAM,RAN,RTU
      INTEGER SCORES(5,5)
      INTEGER CONSC(18),TOTCON,CTONUM
      INTEGER ANSCON
      EXTERNAL CTONUM
      SAVE SCORES
      DATA SCORES/25*0/
      SCORES(1,3)=2
      SCORES(3,1)=2
      SCORES(1,4)=1
      SCORES(4,1)=1
      SCORES(2,4)=2
      SCORES(4,2)=2
      CALL CLEARV
      CALL BUSY(KBOUT)
      IF(IGON.EQ.0)THEN
        XMIN=ISS
        XMAX=ISE
C       ymin= half stems base-paired, ymax= all stems base-paired
        YMIN=18.
        YMAX=42.
        CALL VECTOM
        CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      END IF
C     loop for all stem start points
      DO 300 N=ISS,ISE
        IS=N+60+INT1
        IE=N+MAXLNT+JNT2
        IF(IE.GT.ISE)IE=ISE
        IF(IE.LT.IS)RETURN
C       STEM LEFT END IS N,RIGHT END RANGES FROM IS TO IE
C       LOOP FOR ALL POSITIONS THIS STEM START POINT
        DO 200 I=IS,IE
C         SET UP POINTER TO LEFT STEM
          LAM=N-1
C         SET IANALL TO 0 AS FLAG FOR RE-ENTRY TO ANLOOP
          IANALL=0
          ISUM=0
C         LOOP FOR STEM LENGTH 7
          DO 100 J=1,7
C           POINTER TO STEM LEFT END
            LAM=LAM+1
C           RIGHT HAND POINTER (MOVES BACKWARDS)
            RAM=I-J
            ISUM=ISUM+SCORES(
     +      CTONUM(SEQ(LAM)),CTONUM(SEQ(RAM)))
100       CONTINUE
          IF(ISUM.LT.MINACL)GO TO 200
C         SET TULOOP START POINT
          MTU=0
140       CONTINUE
          IANALL=0
          CALL TULOOP(SEQ,IDIM,RAM,LTUMIN,
     +    LTUMAX,MINTU,ISUMTU,SCORES,RTU,LTU,MTU)
          IF(ISUMTU.LT.MINTU)GO TO 200
150       CONTINUE
          CALL ANLOOP(SEQ,IDIM,MINANT,ISUMAN,N,
     +    RTU,SCORES,JNT2,RAN,LAN,IANALL,INT1)
          IF(ISUMAN.LT.MINANT)GO TO 140
          CALL DLOOP(SEQ,IDIM,ISUMD,LAM,LAN,SCORES)
          IF(ISUMD.GE.MIND)THEN
C         HIGH ENOUGH OVERALL SCORE?
            ITOTBS=ISUM+ISUMTU+ISUMAN+ISUMD
            IF(ITOTBS.GE.MINBAS)THEN
C             FILTER ON CONSERVED BASES
              IF(ANSCON.EQ.0)THEN
                CALL CONSCR(SEQ,IDIM,N,
     +          LAN,RTU,CONSC,TOTCON)
                IF(TOTCON.LT.MINCON)
     +          GO TO 150
              END IF
              ISUMD=ISUMD-MIND
              ISUMAN=ISUMAN-MINANT
              IF(IGON.EQ.0)THEN
                X=N
                Y=ITOTBS
                CALL LINE(X,X,0.,Y,XMAX,XMIN,
     +          YMAX,YMIN,MARGL,MARGR,MARGB,
     +          MARGT,ISXMAX,ISYMAX)
              END IF
              IF(IGON.EQ.1) CALL TRNADR(SEQ,IDIM,I,N,LAN,
     +        RAN,LTU,RTU,IDEV,KSTART)
C             HAVE ALL POSSIBLE ANTICODONS BEEN TRIED?
            END IF
          END IF
          GO TO 150
200     CONTINUE
300   CONTINUE
      END
      SUBROUTINE TRNAD(
     +MNLEN,MXLEN,MAXLNT,
     +MNAC,MXAC,MINACL,
     +MNTU,MXTU,MINTU,
     +MNAN,MXAN,MINANT,
     +MND,MXD,MIND,
     +MNI1,MXI1,INT1,
     +MNI2,MXI2,JNT2,
     +MNTUL1,MXTUL1,LTUMIN,
     +MNTUL2,MXTUL2,LTUMAX,
     +MNB,MXB,MINBAS,
     +MINCON,IGON,ANSCON,
     +CONSC,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      INTEGER CONSC(18),ANSCON
      CHARACTER HELPF*(*)
      IOK = 1
      CALL GETINT(MNLEN,MXLEN,MAXLNT,
     +'Maximum trna length',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MAXLNT = IVAL
      CALL GETINT(MNAC,MXAC,MINACL,
     +'Aminoacyl stem score',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MINACL = IVAL
      CALL GETINT(MNTU,MXTU,MINTU,
     +'Tu stem score',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MINTU = IVAL
      CALL GETINT(MNAN,MXAN,MINANT,
     +'Anticodon stem score',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MINANT = IVAL
      CALL GETINT(MND,MXD,MIND,
     +'D stem score',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MIND = IVAL
      MNB = MIND + MINTU + MINACL + MINANT
C      MXB = MXD + MXTU + MXAC + MNAN
      MINBAS = MNB
      CALL GETINT(MNB,MXB,MINBAS,
     +'Minimum base pairing total',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MINBAS = IVAL
      CALL GETINT(MNI1,MXI1,INT1,
     +'Minimum intron length',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      INT1 = IVAL
      MNI2 = INT1
      JNT2 = INT1
C      IF(INT1.GT.0) THEN
        CALL GETINT(MNI2,MXI2,JNT2,
     +  'Maximum intron length',
     +  IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        JNT2 = IVAL
C      END IF
      CALL GETINT(MNTUL1,MXTUL1,LTUMIN,
     +'Minimum length for TU loop',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      LTUMIN = IVAL
      MNTUL2 = LTUMIN
      CALL GETINT(MNTUL2,MXTUL2,LTUMAX,
     +'Maximum length for TU loop',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      LTUMAX = IVAL
C   conserved bases
      CALL YESONO(ANSCON,
     +'Search for conserved bases',
     +'Skip search for conserved bases',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(ANSCON.LT.0) THEN
        IOK = 1
        RETURN
      END IF
      IOK = 1
      IF(ANSCON.EQ.0)CALL CONSET(CONSC,MINCON,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH)
      IF(MINCON.LT.0)RETURN
      CALL YESONO(IGON,'Plot results','List results',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IGON.LT.0)RETURN
      IOK = 0
      END
C
C     conset
      SUBROUTINE CONSET(CONSC,MINCON,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      INTEGER CONSC(18),NUM(18),CONSER(18)
      CHARACTER CONBAS(18)
      CHARACTER STRING*35
      SAVE NUM,CONSER,CONBAS
      DATA NUM/8,10,11,14,15,21,32,33,37,48,53,54,55,56,57,
     +58,60,61/
      DATA CONSER/100,95,96,100,100,97,100,98,91,100,100,
     +95,97,100,100,100,92,100/
      DATA CONBAS/'T','G','Y','A','R','A','Y','T','A','Y',
     +'G','T','T','C','R','A','Y','C'/
C   SET FLAG FOR RETURN
      MINCON=-9
      ITOT = 0
      MN = 0
      MX = 100
      MNT = 0
      WRITE(KBOUT,1002)
1002  FORMAT(' Give a score for each base, then a minimum',
     +' total at the end')
      DO 10 J=1,18
        STRING = ' '
        WRITE(STRING,1000)NUM(J),CONBAS(J),CONSER(J)
        CALL GETINT(MN,MX,MN,
     +  STRING,
     +  IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        CONSC(J) = IVAL
1000    FORMAT( 'Base ',I2,', ',A1,' is ',I3,'% conserved.',
     +  ' Score')
        ITOT = ITOT + CONSC(J)
10    CONTINUE
      CALL GETINT(MNT,ITOT,MNT,
     +'Minimum total conserved base score',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MINCON = IVAL
      END
      SUBROUTINE CONSCR(SEQ,IDIM,N,LAN,RTU,CONSC,TOTCON)
C   AUTHOR: RODGER STADEN
C bug fix 6-8-92: previously did not allow for case!
      CHARACTER SEQ(IDIM)
      INTEGER CONSC(18),NUMS(18),TOTCON,RTU,B,CHAR1(18),CHAR2(18)
      INTEGER CTONUM
      EXTERNAL CTONUM
      SAVE CHAR1,CHAR2,NUMS
      DATA CHAR1/1,4,2,3,3,3,2,1,3,2,4,1,1,2,3,3,2,2/
      DATA CHAR2/1,4,1,3,4,3,1,1,3,1,4,1,1,2,4,3,1,2/
      DATA NUMS/7,9,10,13,14,-10,1,2,6,-5,0,1,2,3,4,5,7,8/
C      DATA CHAR1/'T','G','C','A','A','A','C','T','A','C','G',
C     +           'T','T','C','A','A','C','C'/
C      DATA CHAR2/'T','G','T','A','G','A','T','T','A','T','G',
C     +           'T','T','C','G','A','T','C'/
C
C   test those from left end
      TOTCON=0
      DO 10 J=1,5
        K=N+NUMS(J)
        B = CTONUM(SEQ(K))
        IF((B.EQ.CHAR1(J)).OR.(B.EQ.CHAR2(J)))
     +  TOTCON=TOTCON+CONSC(J)
10    CONTINUE
C   those from anticodon
      DO 20 J=6,9
        K=LAN+NUMS(J)
        B = CTONUM(SEQ(K))
        IF((B.EQ.CHAR1(J)).OR.(B.EQ.CHAR2(J)))
     +  TOTCON=TOTCON+CONSC(J)
20    CONTINUE
C   THOSE FROM TU LOOP
      DO 30 J=10,18
        K=RTU+NUMS(J)
        B = CTONUM(SEQ(K))
        IF((B.EQ.CHAR1(J)).OR.(B.EQ.CHAR2(J)))
     +  TOTCON=TOTCON+CONSC(J)
30    CONTINUE
      END
      SUBROUTINE ANLOOP(SEQ,IDIM,MINANT,ISUMAN,N,RTU,SCORES,JNT2,
     +RAN,LAN,IANALL,INT1)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      INTEGER SCORES(5,5),RTU,RAN,CTONUM
      EXTERNAL CTONUM
C   NEED TO TEST FLAG FOR MULTIPLE ENTRY TO THIS SUBROUTINE
C   WHEN SEARCHING FOR BEST ANTICODON.  IANALL =0 MEANS NO
C   POSITIONS TRIED FOR THIS START, IANALL=1 MEANS SOME TRIED
C   MIN DIST FROM N TO FIRST BASE IS 6+2+3+4+3+1=19
C   MAX IS TUSTEM-3=RTU-8
C   ALLOWING 3 IN VARIABLE LOOP
      IAS=N+19
C     allow 2 in variable loop to be sure
      IEND=RTU-7
C     restrict max d loop size to 17
      IAE=N+36
      IF(IAE.GT.IEND)IAE=IEND
C   LOOP FOR ALL LEFT STEM STARTS
C   NN IS EFFECTIVELY THE LEFT STEM START
C   RIGHT STEM RANGE FROM NEAREST TO NEAREST + INTRON
C   IE NN+16 TO NN+16+INTRON
C   IAS TO IAE DEFINES THE REGION TO THRU  TRYING ALL START
C   POSITIONS AND ALL INTRON LENGTHS
C   TEST FLAG FOR MULTIPLE ENTRY. IF SET START SEARCHING 1 ON FROM
C   LAST ANTICODON
      IF(IANALL.EQ.1)IAS=LAN-3
C   reset flag
      IANALL=1
      ISUMAN=0
      IF(IAE.LT.IAS)RETURN
      DO 750 NN=IAS,IAE
        IIS=NN+16+INT1
        IIE=NN+16+JNT2
        IF(IIE.GT.IEND)IIE=IEND
        IF(IIE.LT.IIS)RETURN
C
C   try all positions for the right stem from this left stem start
C
        DO 740 I=IIS,IIE
C
C   will only try one position if intron=0
C   or intron max=intron min
          LAN=NN-1
          ISUMAN=0
          RAN=I+1
C
C   loop for stem
C
          DO 730 J=1,5
            LAN=LAN+1
            RAN=RAN-1
            ISUMAN=ISUMAN+SCORES
     +      (CTONUM(SEQ(RAN)),CTONUM(SEQ(LAN)))
730       CONTINUE
C   score high enough?
          IF(ISUMAN.GE.MINANT)RETURN
740     CONTINUE
750   CONTINUE
      END
C
C    dloop
      SUBROUTINE DLOOP(SEQ,IDIM,ISUMD,LAM,LAN,SCORES)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      INTEGER SCORES(5,5),RD,CTONUM
      EXTERNAL CTONUM
C   first base left end is lam+3
C   first base right end is lan-6
C
      LD=LAM+2
      RD=LAN-5
      ISUMD=0
C
      DO 10 I=1,4
        LD=LD+1
        RD=RD-1
        ISUMD=ISUMD+SCORES(CTONUM(SEQ(LD)),CTONUM(SEQ(RD)))
10    CONTINUE
      END
C    trnadr
      SUBROUTINE TRNADR(SEQ,IDIM,I,N,LAN,RAN,LTU,RTU,IDEV,KSTART)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      CHARACTER BLANK
      CHARACTER ARRAY(30,30)
      INTEGER RAN,RTU
      CHARACTER SCORES(5,5),SCOREZ(5,5)
      INTEGER CTONUM
      EXTERNAL CTONUM
      SAVE SCORES,SCOREZ,BLANK
      DATA BLANK/' '/
      DATA SCORES/25*' '/,SCOREZ/25*' '/
      SCORES(1,3)='-'
      SCORES(3,1)='-'
      SCORES(2,4)='-'
      SCORES(4,2)='-'
      SCORES(1,4)='+'
      SCORES(4,1)='+'
      SCOREZ(1,3)='!'
      SCOREZ(3,1)='!'
      SCOREZ(2,4)='!'
      SCOREZ(4,2)='!'
      SCOREZ(1,4)='+'
      SCOREZ(4,1)='+'
C
C   blank arrays
      DO 10 J=1,30
      DO 10 K=1,30
        ARRAY(K,J)=BLANK
10    CONTINUE
C   aminoacyl
      ARRAY(16,5)=(SEQ(I))
      J=I-1
      K=N
      DO 20 L=6,12
        ARRAY(14,L)=(SEQ(K))
        ARRAY(16,L)=(SEQ(J))
        ARRAY(15,L)=SCORES(CTONUM(SEQ(K)),CTONUM(SEQ(J)))
        K=K+1
        J=J-1
20    CONTINUE
C
C   gap between aminoacyl d stem
      ARRAY(13,13)=(SEQ(N+7))
      ARRAY(12,14)=(SEQ(N+8))
C
C
C   anticodon
      K=LAN-4
      J=RAN+4
      DO 30 L=19,23
        ARRAY(13,L)=(SEQ(K))
        ARRAY(15,L)=(SEQ(J))
        ARRAY(14,L)=SCORES(CTONUM(SEQ(K)),CTONUM(SEQ(J)))
        K=K+1
        J=J-1
30    CONTINUE
C
C   anticodon loop
      ARRAY(12,24)=(SEQ(LAN+1))
      ARRAY(12,25)=(SEQ(LAN+2))
      ARRAY(16,25)=(SEQ(LAN+6))
      ARRAY(16,24)=(SEQ(RAN-1))
      K=LAN+3
      DO 35 L=13,15
        ARRAY(L,26)=(SEQ(K))
        K=K+1
35    CONTINUE
C
C   gap between dstem and anticodon
      ARRAY(12,18)=(SEQ(LAN-5))
C
C   tustem
      K=LTU+4
      L=RTU-4
      DO 40 J=17,21
        ARRAY(J,13)=(SEQ(K))
        ARRAY(J,15)=(SEQ(L))
        ARRAY(J,14)=SCOREZ(CTONUM(SEQ(K)),CTONUM(SEQ(L)))
        K=K-1
        L=L+1
40    CONTINUE
C   tu loop
C   length of loop
      LNGTH=K-L+1
      IF(LNGTH.GT.18)RETURN
C   return if loop length lt 3
      IF(LNGTH.LT.3)RETURN
C   number in outer
      LU=(LNGTH-1)/2
      M=22
      DO 45 J=1,LU
        ARRAY(M,12)=(SEQ(K))
        ARRAY(M,16)=(SEQ(L))
        K=K-1
        L=L+1
        M=M+1
45    CONTINUE
C
      ARRAY(M,15)=(SEQ(L))
      L=L+1
      IF(MOD(LNGTH,2).EQ.0)ARRAY(M,14)=(SEQ(L))
C
C
46    CONTINUE
C   dstem
      K=N+9
      L=LAN-6
      LNGTH=L-K+1
      J2=4
      M=11
      IF(LNGTH.GT.10)GO TO 47
C   need stem of 3 not 4
      M=10
      J2=3
47    CONTINUE
      DO 50 J=1,J2
        ARRAY(M,15)=(SEQ(K))
        ARRAY(M,17)=(SEQ(L))
        ARRAY(M,16)=SCOREZ(CTONUM(SEQ(K)),CTONUM(SEQ(L)))
        K=K+1
        L=L-1
        M=M-1
50    CONTINUE
C
C   dloop
C   length of loop
      LNGTH=L-K+1
      IF(LNGTH.GT.14)RETURN
C   if loop length lt 3 return
      IF(LNGTH.LT.3)RETURN
C   number in outer
      LU=(LNGTH-1)/2
      DO 80 J=1,LU
        ARRAY(M,14)=(SEQ(K))
        ARRAY(M,18)=(SEQ(L))
        K=K+1
        L=L-1
        M=M-1
80    CONTINUE
      ARRAY(M,17)=(SEQ(L))
      L=L-1
      IF(MOD(LNGTH,2).EQ.0)ARRAY(M,16)=(SEQ(L))
C
C
85    CONTINUE
C   variable loop
      LNGTH=(RTU-5)-(RAN+5)+1
      IF(LNGTH.GT.26)RETURN
      IF(LNGTH.LT.3)RETURN
C   number of elements in lower diagonal
      LL=(LNGTH/2)-1
C   correction made in june 81 for lngthg=3
      IF(LL.EQ.0)LL=1
C   lsi must go thru loops even with 0!
C   number in upper
      LU=(LNGTH+1)/2
C   do lower
      K=16
      L=19
      M=RAN+5
      DO 60 J=1,LL
        ARRAY(K,L)=(SEQ(M))
        K=K+1
        L=L+1
        M=M+1
60    CONTINUE
C   check for silly loop size
      IF(LNGTH.LT.3)RETURN
C   put in extra base
      K=K+1
      L=L-1
      IF(LNGTH.GT.3)ARRAY(K,L)=(SEQ(M))
C do upper
      K=17
      L=16
      M=RTU-5
      DO 70 J=1,LU
        ARRAY(K,L)=(SEQ(M))
        K=K+1
        L=L+1
        M=M-1
70    CONTINUE
C
C   output
      WRITE(IDEV,1002)N+KSTART-1
1002  FORMAT(/5X,I6)
      DO 200 M=1,30
        DO 100 J=1,30
          IF(ARRAY(J,M).EQ.BLANK)GO TO 100
          WRITE(IDEV,1000)(ARRAY(L,M),L=1,30)
          GO TO 200
100     CONTINUE
200   CONTINUE
1000  FORMAT(5X,30A)
      END
      SUBROUTINE TULOOP(SEQ,IDIM,RAM,LTUMIN,LTUMAX,MINTU,ISUMTU,
     +SCORES,RTU,LTU,MTU)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      INTEGER SCORES(5,5)
      INTEGER RAM,RTU,RAMM2,CTONUM
      EXTERNAL CTONUM
      ISUMTU=0
C   loop must start at ram-1
C   vary loop from ltumin to ltumax
      RAMM2=RAM-2
      M=LTUMIN+9
      N=LTUMAX+9
C   is this first pass thru this aminoacyl?
      IF(MTU.GT.0)M=MTU+1
C   all done?
      IF(M.GT.N)RETURN
C
      DO 650 I=M,N
        ISUMTU=0
        RTU=RAMM2-I
        DO 640 J=1,5
          LTU=RAM-J
          RTU=RTU+1
          ISUMTU=ISUMTU+SCORES(
     +    CTONUM(SEQ(RTU)),CTONUM(SEQ(LTU)))
640     CONTINUE
        MTU=I
C   score high enough?
        IF(ISUMTU.GE.MINTU)RETURN
650   CONTINUE
      END
      SUBROUTINE CODMPP(SEQ,IDIM,FTABLE,IDFTAB,
     +KBOUT,J1,J2,I1,I2,IDIM1,IDEV)
C   AUTHOR: RODGER STADEN
      REAL RNFAC,FTABLE(IDFTAB),FACTOR,FACN
      INTEGER NBASE(4),NCOD(4,4,4)
      EXTERNAL FACTOR
      CHARACTER SEQ(IDIM)
      INTEGER NCODON(21),IACID(4,4,4)
      REAL FABC(4,4,4),FA(21)
C    array with number of codons per acid
      SAVE IACID,NCODON
      DATA IACID/
     +1,2,3,5,6,7,8,9,
     +10,12,14,16,18,20,6,21,
     +1,2,3,5,6,7,8,9,
     +10,12,14,16,18,20,6,21,
     +2,2,3,5,6,7,8,9,
     +11,13,15,17,11,20,20,21,
     +2,2,4,5,6,7,8,9,
     +11,13,15,17,19,20,20,21/
      DATA NCODON/
     +2,6,3,1,4,6,4,4,4,2,3,2,2,2,2,2,2,2,1,6,4/
      LB=150
      LF=147
      IF(IDIM1.GT.310)THEN
        CALL BUSY(KBOUT)
        FACN=FACTOR(99,FTABLE,IDFTAB)
        SUMY=0.
C  do calc
        CALL ROT2(SEQ(I1-J1+1),IDIM1,NCOD,RNFAC,FTABLE,IDFTAB,
     +  NBASE,297,FA,FABC,NCODON,IACID)
        COMP=0.
        DO 90 J=I1+LB-J1+1,I2-LF-2-J1+1,3
          CALL ROTFAK(SEQ,IDIM,J,LB,LF,
     +    NCOD,RNFAC,FTABLE,IDFTAB,
     +    NBASE,COMP,297,99.,
     +    FA,FABC,NCODON,IACID)
          W=RNFAC-COMP-FACN
          CALL POISON(99,FABC,FABC,EW,EWD,2)
          Y=(W-EW)/EWD
          SUMY=SUMY+Y
90      CONTINUE
        SUMY=SUMY/((I2-LF-2-(I1+LB))/3.)
        WRITE(IDEV,5555)SUMY
5555    FORMAT('  Mean (W-EW)/EWD, window 99 ',F10.1)
      END IF
      END
      SUBROUTINE PREPT1(SEQ,POSNS,IDIM,J1IN,J2IN,KSTART,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IDEV,DIALOG,
     +WORDP,WORDN,MAXWRD,MAXDIC)
      INTEGER WORDP(MAXDIC),WORDN(MAXDIC)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      INTEGER POSNS(IDIM),DIALOG
      CHARACTER SEQ(IDIM)
      INTEGER R
      CALL SHOWFU(KBOUT,'Plot repeats')
      CALL GETPAR(32,4,IOK,MINRP,MAXRP,MINREP,IGON,
     +IPAR5,
     +IPAR6,IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      L = J1IN
      R = J2IN
      IF(DIALOG.EQ.1) THEN
      CALL YESONO(IGON,'Plot results','List results',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IGON.LT.0)RETURN
      CALL GTREG(KBIN,KBOUT,J1IN,J2IN,L,R,
     +'Define restricted region',
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      CALL GETINT(MINRP,MAXRP,MINREP,
     +'Minimum repeat',
     +IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MINREP = IVAL
      END IF
      IDIM1=R-L+1
      IDIM2=J2IN-J1IN+1
      L1=L-J1IN+1
      CALL BUSY(KBOUT)
      CALL REPEAT(SEQ(L-KSTART+1),
     +POSNS,IDIM1,MINREP,L1,J1IN,IDIM2,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IDEV,IGON,
     +WORDP,WORDN,MAXWRD,MAXDIC)
      CALL VT100M
      END
C   REPEAT
      SUBROUTINE REPEAT(SEQ,POSNS,IDIM,MINR,L,KSTART,IDIM1,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IDEV,IGON,
     +WORDP,WORDN,MAXWRD,MAXDIC)
      INTEGER WORDP(MAXDIC),WORDN(MAXDIC)
C   AUTHOR: RODGER STADEN
      INTEGER POSNS(IDIM),CONST(6)
      CHARACTER SEQ(IDIM)
      LENGTH=MAXWRD
      LE4=MAXDIC
      CALL ENCO(SEQ,IDIM,POSNS,CONST,LENGTH)
      CALL ENCONA(POSNS,IDIM,WORDP,WORDN,LE4,LENGTH)
      CALL REPT1(SEQ,IDIM,IDIM1,L,KSTART,
     +POSNS,WORDN,WORDP,LENGTH,LE4,MINR,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IDEV,IGON)
      END
      SUBROUTINE REPT1(SEQ,IDIM,IDIM1,LEFT,KSTART,
     +POSNS,WORDN,WORDP,LENGTH,LE4,MINR,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IDEV,IGON)
C   AUTHOR: RODGER STADEN
      INTEGER POSNS(IDIM),WORDP(LE4)
      INTEGER WORDN(LE4)
      CHARACTER SEQ(IDIM)
C   POSNS CONTAIN THE WORD NUMBERS ENCODED BY 4**LENGTH
C   WORDN CONTAINS THE NUMBER OF OCCURENCES OF EACH POSSIBLE WORD
C   WORDP CONTAINS THE POINTERS TO THE FIRST OCCURRENCE OF THE WORDS
C   ENCODED--- EG POINTER TO FIRST OCCURRENCE OF THE WORD ENCODED AS 101
C   WILL BE STORED IN ELEMENT 101
      IF(IGON.EQ.0) CALL VECTOM
      XMIN=1.
      XMAX=IDIM1
      YMIN=0.
      YMAX=1.
      X1=LEFT
      Y1=0.
      YINC=1./IDIM1
C   LOOK FOR MATCHES BY THOSE ELEMENTS OF WORDN>1
      DO 100 I=1,LE4
        IF(WORDN(I).GT.1)THEN
C   POINT TO FIRST POSITION AS ITS IN WORDP
          IP=WORDP(I)
C   A MATCH, TRY ALL PAIRS
          DO 50 J=1,WORDN(I)
C   COMPARE THIS POSITION WITH ALL OTHERS
            IPS=IP
            DO 40 K=J+1,WORDN(I)
C   FIND LENGTH OF MATCH
              L=LENGTH
              IP1=IP+LENGTH
              IPS=POSNS(IPS)
              IP2=IPS+LENGTH
20            CONTINUE
              IF((IP1.LE.IDIM).AND.(IP2.LE.IDIM))THEN
                IF(SEQ(IP1).EQ.SEQ(IP2))THEN
                  IP1=IP1+1
                  IP2=IP2+1
                  L=L+1
                  GO TO 20
                END IF
              END IF
C   END OF MATCH, IS IT LONG ENOUGH?
              IF(L.GE.MINR)THEN
                X1=LEFT+IP-1
                X2=LEFT+IPS-1
                Y2=Y1+YINC*ABS(X2-X1)
                IF(IGON.EQ.0)THEN
                  CALL LINE(X1,X1,Y1,Y2,
     +            XMAX,XMIN,YMAX,YMIN,MARGL,MARGR,
     +            MARGB,MARGT,ISXMAX,ISYMAX)
                  CALL LINE(X1,X2,Y2,Y2,
     +            XMAX,XMIN,YMAX,YMIN,MARGL,MARGR,
     +            MARGB,MARGT,ISXMAX,ISYMAX)
                  CALL LINE(X2,X2,Y2,Y1,
     +            XMAX,XMIN,YMAX,YMIN,MARGL,MARGR,
     +            MARGB,MARGT,ISXMAX,ISYMAX)
                END IF
                IF(IGON.EQ.1)THEN
                  INTX1=X1+KSTART-1
                  INTX2=X2+KSTART-1
                  WRITE(IDEV,1000)INTX1,INTX2,L,(SEQ(KK),KK=IP,IP+L-1)
                END IF
              END IF
1000          FORMAT(' ',I6,2X,I6,2X,I6,('  ',50A1))
40          CONTINUE
            IP=POSNS(IP)
50        CONTINUE
        END IF
100   CONTINUE
      END
      SUBROUTINE PREPT2(SEQ,POSNS,IDIM,J1IN,J2IN,KSTART,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IDEV,DIALOG,
     +WORDP,WORDN,MAXWRD,MAXDIC)
      INTEGER WORDP(MAXDIC),WORDN(MAXDIC)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      INTEGER POSNS(IDIM),DIALOG
      CHARACTER SEQ(IDIM)
      INTEGER R
      CALL SHOWFU(KBOUT,'Plot long-range inverted repeats')
      CALL GETPAR(31,4,IOK,MINRP,MAXRP,MINREP,IGON,
     +IPAR5,
     +IPAR6,IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      L = J1IN
      R = J2IN
      IF(DIALOG.EQ.1) THEN
      CALL YESONO(IGON,'Plot results','List results',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IGON.LT.0)RETURN
      CALL GTREG(KBIN,KBOUT,J1IN,J2IN,L,R,
     +'Define restricted region',
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      CALL GETINT(MINRP,MAXRP,MINREP,
     +'Minimum inverted repeat',
     +IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MINREP = IVAL
      END IF
      IDIM1=R-L+1
      IDIM2=J2IN-J1IN+1
      L1=L-J1IN+1
      CALL BUSY(KBOUT)
      CALL REPT2(SEQ(L-KSTART+1),POSNS,IDIM1,MINREP,L1,J1IN,IDIM2,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IDEV,IGON,
     +WORDP,WORDN,MAXWRD,MAXDIC)
      CALL VT100M
      END
C   REPT2
      SUBROUTINE REPT2(SEQ,POSNS,IDIM,MINR,L,KSTART,IDIM1,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IDEV,IGON,
     +WORDP,WORDN,MAXWRD,MAXDIC)
      INTEGER WORDP(MAXDIC),WORDN(MAXDIC)
C   AUTHOR: RODGER STADEN
      INTEGER POSNS(IDIM),CONST(6)
      CHARACTER SEQ(IDIM)
      LENGTH=MAXWRD
      LE4=MAXDIC
      CALL ENCO(SEQ,IDIM,POSNS,CONST,LENGTH)
      CALL ENCONA(POSNS,IDIM,WORDP,WORDN,LE4,LENGTH)
      CALL REPT3(SEQ,IDIM,IDIM1,L,KSTART,
     +POSNS,WORDN,WORDP,LENGTH,LE4,MINR,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IDEV,IGON)
      END
      SUBROUTINE REPT3(SEQ,IDIM,IDIM1,LEFT,KSTART,
     +POSNS,WORDN,WORDP,LENGTH,LE4,MINR,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IDEV,IGON)
C   AUTHOR: RODGER STADEN
      INTEGER POSNS(IDIM),WORDP(LE4)
      INTEGER WORDN(LE4),CONST(6)
      CHARACTER SEQ(IDIM),SCOMP
      EXTERNAL SCOMP
C   POSNS CONTAIN THE WORD NUMBERS ENCODED BY 4**LENGTH
C   WORDN CONTAINS THE NUMBER OF OCCURENCES OF EACH POSSIBLE WORD
C   WORDP CONTAINS THE POINTERS TO THE FIRST OCCURRENCE OF THE WORDS
C   ENCODED--- EG POINTER TO FIRST OCCURRENCE OF THE WORD ENCODED AS 101
C   WILL BE STORED IN ELEMENT 101
      IF(IGON.EQ.0) CALL VECTOM
      XMIN=1.
      XMAX=IDIM1
      YMIN=0.
      YMAX=1.
      X1=LEFT
      Y1=0.
      YINC=1./IDIM1
C   SET UP CONST FOR ROUTINE THAT LOOKS FOR COMPLEMENTARY WORD POINTERS
      ISTART=1
      DO 1 I=1,LENGTH
        CONST(I)=4**(I-1)
        ISTART=ISTART-CONST(I)
1     CONTINUE
C
C   LOOK FOR MATCHES BY THOSE ELEMENTS OF WORDN>1
      DO 100 I=1,LE4
        IF(WORDN(I).GE.1)THEN
C   POINT TO FIRST POSITION AS ITS IN WORDP
          IP=WORDP(I)
C   DOES ITS COMPLEMENT EXIST?
          JCOMPN=ICOMPN(SEQ,IDIM,IP,CONST,LENGTH,ISTART)
          NCOMP=WORDN(JCOMPN)
          IF(NCOMP.NE.0)THEN
C       YES, NEED TO COMPARE ALL PAIRS IE COMPARE WORDN(I) POSITIONS
C       WITH NCOMP POSITIONS. POINT TO FIRST OCCURRENCE
            IPN=WORDP(JCOMPN)
C   A MATCH, TRY ALL PAIRS
            DO 50 J=1,WORDN(I)
C   COMPARE THIS POSITION WITH ALL OTHERS
              IPN1=IPN
              DO 40 K=1,NCOMP
C   FIND LENGTH OF MATCH
                L=LENGTH
                IP1=IP+LENGTH
                IP2=IPN1-1
20              CONTINUE
                IF((IP1.LE.IDIM).AND.(IP2.GT.1))THEN
                  IF(SEQ(IP1).EQ.SCOMP(SEQ(IP2)))THEN
                    IP1=IP1+1
                    IP2=IP2-1
                    L=L+1
                    GO TO 20
                  END IF
                END IF
                IF(L.GE.MINR)THEN
                  X1=LEFT+IP-1
                  X2 = LEFT + IP2
C                  X2=LEFT+IPN1-3
                  Y2=Y1+YINC*ABS(X2-X1)
                  IF(IGON.EQ.0)THEN
                    CALL LINE(X1,X1,Y1,Y2,
     +              XMAX,XMIN,YMAX,YMIN,MARGL,MARGR,
     +              MARGB,MARGT,ISXMAX,ISYMAX)
                    CALL LINE(X1,X2,Y2,Y2,
     +              XMAX,XMIN,YMAX,YMIN,MARGL,MARGR,
     +              MARGB,MARGT,ISXMAX,ISYMAX)
                    CALL LINE(X2,X2,Y2,Y1,
     +              XMAX,XMIN,YMAX,YMIN,MARGL,MARGR,
     +              MARGB,MARGT,ISXMAX,ISYMAX)
                  END IF
                  IF(IGON.EQ.1)THEN
                    INTX1=X1+KSTART-1
                    INTX2=X2+KSTART-1
                    IF(IP.EQ.IPN1) INTX2 = INTX1
                    WRITE(IDEV,1000)INTX1,INTX2,L,(SEQ(KK),KK=IP,IP+L-1)
                  END IF
                END IF
                IPN1=POSNS(IPN1)
1000            FORMAT(' ',I6,2X,I6,2X,I6,('  ',50A1))
40            CONTINUE
C   POINT TO NEXT WORD
              IP=POSNS(IP)
50          CONTINUE
            WORDN(JCOMPN)=0
          END IF
C   SET THIS WORD TO ZERO SO WE DONT USE IT AGAIN
          WORDN(I)=0
        END IF
100   CONTINUE
      END
      INTEGER FUNCTION ICOMPN(SEQ,IDIM,IP,CONST,LENGTH,ISTART)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      INTEGER CONST(LENGTH),CTONUM
      EXTERNAL CTONUM,ICOMP
      N=ISTART
      L=IP+LENGTH
      K=0
      DO 1 J=1,LENGTH
        K=K+1
        L=L-1
        N=N+CONST(K)*ICOMP(CTONUM(SEQ(L)))
1     CONTINUE
      ICOMPN=N
      END
      SUBROUTINE DISIG(SEQ,IDIM,MARGL,MARGR,MARGB,MARGT,
     +ISXMAX,ISYMAX,J1,J2,IDEV,FILNAM,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IDEVOT,
     +SUM,WT,TOT,IDM,MAXLEN,LINE,CHRSET,DIALOG)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),FILNAM*(*),HELPF*(*)
      CHARACTER LINE(MAXLEN),CHRSET(IDM)
      INTEGER SUM(IDM,IDM,MAXLEN),TOT(MAXLEN),DIALOG
      REAL WT(IDM,IDM,MAXLEN)
      CALL SHOWFU(KBOUT,
     +'Motif search using dinucleotide weight matrix')
      CALL GETPAR(60,1,IOK,IGON,
     +IPAR2,IPAR3,IPAR4,IPAR5,
     +IPAR6,IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      CALL DISIGD(IDEV,FILNAM,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,
     +SUM,IDM,MAXLEN,TOT,WT,LENGTH,MIDDLE,YMIN,YMAX,
     +IGON,IDEVOT,LINE,CHRSET,DIALOG,IOK)
      IF(IOK.NE.0) RETURN
      CALL DISIGP(SEQ,IDIM,MARGL,MARGR,MARGB,MARGT,
     +ISXMAX,ISYMAX,J1,J2,IDEVOT,WT,IDM,MAXLEN,LENGTH,
     +YMIN,YMAX,IGON,MIDDLE)
      END
      SUBROUTINE DISIGD(IDEV,FILNAM,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,
     +SUM,IDM,MAXLEN,TOT,WT,LENGTH,MIDDLE,YMIN,YMAX,
     +IGON,IDEVOT,LINE,CHRSET,DIALOG,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER FILNAM*(*),HELPF*(*),LINE(MAXLEN),CHRSET(IDM)
      INTEGER SUM(IDM,IDM,MAXLEN),TOT(MAXLEN),DIALOG
      REAL WT(IDM,IDM,MAXLEN)
      PARAMETER (MAXPRM = 21)
      CHARACTER PROMPT(3)*(MAXPRM)
      IOK = 1
      IDO = 1
      PROMPT(1) = 'Use weight matrix'
      PROMPT(2) = 'Make weight matrix'
      PROMPT(3) = 'Rescale weight matrix'
      CALL RADION('Select operation',PROMPT,3,IDO,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IDO.LT.1) RETURN
      IF(IDO.GT.1) THEN
        CALL MKWTD(WT,SUM,TOT,CHRSET,IDM,MAXLEN,
     +  IDEV,IDEVOT,KBIN,KBOUT,LINE,
     +  FILNAM,IDO,IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IOK = 1
        RETURN
      END IF
      FILNAM = ' '
      CALL OPENF1(IDEV,FILNAM,0,IOK,KBIN,KBOUT,
     +'Motif weight matrix file',
     +IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.NE.0)RETURN
      LENGTH=MAXLEN
      CALL RDWMTD(TOT,SUM,MIDDLE,LENGTH,MAXLEN,YMIN,YMAX,IDEV,
     +  IOK,IDM,KBOUT)
      IF(IOK.NE.0)THEN
        CALL ERROM(KBOUT,'Error in weight matrix')
        RETURN
      END IF
      IF(DIALOG.EQ.1) THEN
        AMN = -9999.
        AMX = 9999.
        CALL GETRL(AMN,AMX,YMIN,'Cutoff score',VAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        YMIN = VAL
      END IF
      IF(YMIN.LT.0.0)CALL GETWD(TOT,SUM,WT,LENGTH,IDM,MAXLEN)
      IF(YMIN.GE.0.0)CALL GETW2D(SUM,WT,LENGTH,IDM,MAXLEN)
      CALL YESONO(IGON,'Plot results','List results',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IGON.LT.0)RETURN
      IOK = 0
      END
      SUBROUTINE GETCD(TOT,SUM,LINE,IDM,MAXLEN,IDEV,KBOUT,LENGTH,
     +IOK)
      INTEGER TOT(MAXLEN),SUM(IDM,IDM,MAXLEN)
      CHARACTER LINE(MAXLEN)
      INTEGER CTONUM
      EXTERNAL CTONUM
      IOK = 1
      DO 2 I=1,MAXLEN
        TOT(I)=0
        DO 1 J=1,IDM
        DO 1 K=1,IDM
          SUM(K,J,I)=0
1       CONTINUE
2     CONTINUE
      N=0
10    CONTINUE
1003  FORMAT(1X,120A1)
1004  FORMAT(' ',I6,' ',120A1)
      READ(IDEV,1003,END=100)LINE
      N=N+1
      WRITE(KBOUT,1004)N,LINE
      DO 20 I=1,MAXLEN
        IF(LINE(I).EQ.' ')GO TO 10
        J = CTONUM(LINE(I+1))
        K = CTONUM(LINE(I))
        SUM(K,J,I) = SUM(K,J,I) + 1
20    CONTINUE
      GO TO 10
100   CONTINUE
      IF(N.EQ.0)THEN
        CALL ERROM(KBOUT,'Empty file of aligned sequences')
        RETURN
      END IF
C   NOW FIND LENGTH OF MOTIF
      DO 40 I=1,MAXLEN
        K=0
        L=I
        DO 30 J=1,IDM
        DO 30 M=1,IDM
          K=K+SUM(M,J,I)
30      CONTINUE
        IF(K.EQ.0)GO TO 50
        TOT(I)=TOT(I)+K
40    CONTINUE
50    CONTINUE
      LENGTH=L-2
      IOK = 0
      END
      SUBROUTINE GETWD(TOT,SUM,FREQ,LENGTH,MAXCHR,MAXLEN)
      INTEGER TOT(LENGTH),SUM(MAXCHR,MAXCHR,MAXLEN)
      REAL FREQ(MAXCHR,MAXCHR,MAXLEN)
      DO 70 I=1,LENGTH
        DO 60 J=1,MAXCHR
        DO 60 K=1,MAXCHR
          FREQ(K,J,I)=LOG((REAL(SUM(K,J,I)+1)/REAL(TOT(I)+MAXCHR)))
60      CONTINUE
70    CONTINUE
      END
      SUBROUTINE GETW2D(SUM,FREQ,LENGTH,MAXCHR,MAXLEN)
      INTEGER SUM(MAXCHR,MAXCHR,MAXLEN)
      REAL FREQ(MAXCHR,MAXCHR,MAXLEN)
      DO 70 I=1,LENGTH
        DO 60 J=1,MAXCHR
        DO 60 K=1,MAXCHR
          FREQ(K,J,I)=REAL(SUM(K,J,I))
60      CONTINUE
70    CONTINUE
      END
      SUBROUTINE MKWTD(FREQ,SUM,TOT,CHRSET,IDM,MAXLEN,
     +IDEV2,IDEV3,KBIN,KBOUT,LINE,
     +FILNAM,IOPT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
C   AUTHOR RODGER STADEN
      CHARACTER FILNAM*(*),HELPF*(*)
      CHARACTER LINE(MAXLEN),TITLE*60,CHRSET(IDM)
      INTEGER SUM(IDM,IDM,MAXLEN),TOT(MAXLEN)
      REAL FREQ(IDM,IDM,MAXLEN)
      IOK = 1
      IF(IOPT.EQ.3)THEN
        FILNAM = ' '
        CALL OPENF1(IDEV2,FILNAM,0,IOK,KBIN,KBOUT,
     +  'Name of existing weight matrix file',
     +  IHELPS,IHELPE,HELPF,IDEVH)
        IF(IOK.NE.0) RETURN
        CALL RDWMTD(TOT,SUM,MIDDLE,LENGTH,MAXLEN,
     +  CUTMIN,CUTMAX,IDEV2,
     +  IOK,IDM,KBOUT)
        IF(IOK.NE.0) RETURN
      END IF
      FILNAM = ' '
      CALL OPENF1(IDEV2,FILNAM,0,IOK,KBIN,KBOUT,
     +'Name of aligned sequences file',
     +IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.NE.0)RETURN
      IF(IOPT.EQ.2) THEN
        CALL GETCD(TOT,SUM,LINE,IDM,MAXLEN,IDEV2,
     +  KBOUT,LENGTH,IOK)
        IF(IOK.NE.0)RETURN
      END IF
      WRITE(KBOUT,1006)LENGTH
1006  FORMAT(' Length of motif',I6)
      IOK = 1
      CALL YESNO(IOPT,'Sum logs of weights',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IOPT.LT.0) RETURN
      CUTMIN = -10.0
      IF(IOPT.EQ.1)CUTMIN = 10.
      CALL MASKWD(SUM,LENGTH,IDM,MAXLEN,KBIN,KBOUT,TITLE,
     +IOPT,IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOPT.LT.0) RETURN
C     NOW CALC WEIGHTS
      IF(CUTMIN.LT.0.0)CALL GETWD(TOT,SUM,FREQ,LENGTH,IDM,MAXLEN)
      IF(CUTMIN.GE.0.0)CALL GETW2D(SUM,FREQ,LENGTH,IDM,MAXLEN)
C     NOW APPLY THE WEIGHTS
      REWIND IDEV2
      CALL APPLWD(FREQ,IDM,LENGTH,IDEV2,IDEV3,KBIN,KBOUT,LINE,MAXLEN,
     +BOT,TOP,TITLE,MIDDLE,IOK)
      CLOSE(UNIT=IDEV2)
      IF(IOK.NE.0) RETURN
      FILNAM = ' '
      CALL OPENF1(IDEV2,FILNAM,1,IOK,KBIN,KBOUT,
     +'Name for new weight matrix file',
     +IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.NE.0) RETURN
      CALL WRTSCD(TITLE,LENGTH,MIDDLE,BOT,TOP,IDM,
     +TOT,SUM,CHRSET,IDEV2,MAXLEN)
      CLOSE(UNIT=IDEV2)
      RETURN
      END
      SUBROUTINE MASKWD(SUM,LENGTH,IDM,MAXLEN,KBIN,KBOUT,MASK,
     +IOPT,IHELPS,IHELPE,HELPF,IDEVH)
      INTEGER SUM(IDM,IDM,MAXLEN)
      CHARACTER MASK*(*),HELPF*(*)
      CALL YESNO(IOPT,'Use all motif positions',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IOPT.LT.0) RETURN
5     CONTINUE
      IF(IOPT.EQ.1)THEN
        WRITE(KBOUT,1002)
1002    FORMAT(' x means use, - means ignore',/,
     +         ' e.g. xx-x---x-x means use positions 1,2,4,8,10')
        LIN = 0
        CALL GTSTR('Mask',' ',MASK,LIN,KBOUT,KBIN,INFLAG)
        IF(INFLAG.EQ.1) THEN
          CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
          GO TO 5
        END IF
        IF(INFLAG.EQ.2) RETURN
        IF(LIN.EQ.0) RETURN
        DO 70 I=1,LENGTH
          IF(MASK(I:I).EQ.'-')THEN
            DO 60 J=1,IDM
            DO 60 K=1,IDM
              SUM(K,J,I) = 0
60          CONTINUE
          END IF
70      CONTINUE
      END IF
      END
      SUBROUTINE APPLWD(FREQ,IDM,LENGTH,IDEV,IDEV3,KBIN,KBOUT,
     +LINE,MAXLEN,BOT,TOP,TITLE,MIDDLE,IOK)
      REAL FREQ(IDM,IDM,MAXLEN)
      CHARACTER LINE(MAXLEN),TITLE*(*)
      INTEGER CTONUM
      EXTERNAL CTONUM
      IOK = 1
      N=0
      TOP=-99999.
      BOT=9999999.
      WRITE(KBOUT,*)' Applying weights to input sequences'
      SMEAN = 0.
      SUMSQ = 0.
1003  FORMAT(1X,120A1)
1004  FORMAT(' ',I4,' ',F12.3,' ',120A1)
200   CONTINUE
      READ(IDEV,1003,END=300)LINE
      N=N+1
      SCORE=0.
      DO 210 I=1,LENGTH
        J = CTONUM(LINE(I+1))
        K = CTONUM(LINE(I))
        SCORE=SCORE+FREQ(K,J,I)
210   CONTINUE
      WRITE(IDEV3,1004)N,SCORE,(LINE(K),K=1,LENGTH)
      IF(SCORE.GT.TOP)TOP=SCORE
      IF(SCORE.LT.BOT)BOT=SCORE
      SMEAN=SMEAN+SCORE
      SUMSQ=SUMSQ+SCORE*SCORE
      GO TO 200
300   CONTINUE
      IF(N.LT.1)THEN
        CALL ERROM(KBOUT,'Error: empty sequence file')
        RETURN
      END IF
      SMEAN=SMEAN/N
      SM=SMEAN
      SMEAN=SMEAN*SMEAN
      SUMSQ=SUMSQ/N
      SD = 0.
      T = SUMSQ - SMEAN
      IF(T.GT.0.)SD = SQRT(T)
      SMM3=SM-3*SD
      SMP3=SM+3*SD
      WRITE(KBOUT,1000)TOP,BOT
1000  FORMAT(' Top score',F12.3,'  Bottom score',F12.3)
      WRITE(KBOUT,1001)SM,SD
1001  FORMAT(' Mean',F12.3,'  Standard deviation',F12.3)
      WRITE(KBOUT,1002)SMM3,SMP3
1002  FORMAT(' Mean minus 3.sd',F12.3,'  Mean plus 3.sd',F12.3)
      BOT=SMM3
      TOP=SMP3
      XMN = -999.
      XMX = 9999.
      CALL GETRL(XMN,XMX,BOT,'Cutoff score',VAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      BOT = VAL
      XMN = BOT
      XMX = 999.
      CALL GETRL(XMN,XMX,TOP,'Top score for scaling plots',
     +VAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      TOP = VAL
      MN = 0
      MX = LENGTH
      MIDDLE = 1
      CALL GETINT(MN,MX,MIDDLE,'Position to identify',IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
       MIDDLE = IVAL
305   CONTINUE 
      LIN = 0
      CALL GTSTR('Title',' ',TITLE,LIN,KBOUT,KBIN,INFLAG)
      IF(INFLAG.EQ.1) THEN
        CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        GO TO 305
      END IF
      IF(INFLAG.EQ.2) RETURN
      IOK = 0
      END
      SUBROUTINE GETW1D(SUM,FREQ,LENGTH,MAXCHR,MAXLEN)
      INTEGER SUM(MAXCHR,MAXCHR,MAXLEN)
      REAL FREQ(MAXCHR,MAXCHR,MAXLEN)
      DO 70 I=1,LENGTH
        DO 60 J=1,MAXCHR
        DO 60 K=1,MAXCHR
          FREQ(K,J,I) = 0.
          IF(SUM(K,J,I).GT.0)FREQ(K,J,I) = 1.
60      CONTINUE
70    CONTINUE
      END
      SUBROUTINE WRTSCD(TITLE,LENGTH,MIDDLE,BOT,TOP,IDM,
     +TOT,SUM,CHRSET,IDEV,MAXLEN)
      INTEGER TOT(LENGTH),SUM(IDM,IDM,MAXLEN)
      CHARACTER CHRSET(IDM),TITLE*(*)
C   PROTEIN MATRICES DONT WRITE ROWS FOR -X? AND SPACE SO SET DIMENSION
C   TO IDM-4
      MINUS = 1
      IF(IDM.EQ.26)MINUS = 4
      WRITE(IDEV,1018)TITLE
1018  FORMAT(' ',A)
1019  FORMAT('  P',20I4)
1020  FORMAT('  N',20I4)
1021  FORMAT(' ',A,A,20I4)
1022  FORMAT(' ',2I6,2F10.3)
      WRITE(IDEV,1022)LENGTH,MIDDLE,BOT,TOP
      NLINES=1+(LENGTH-1)/20
      K1=1
      DO 400 J=1,NLINES
        K2=MIN((K1+19),LENGTH)
        WRITE(IDEV,1019)(K,K=K1-MIDDLE,K2-MIDDLE)
        WRITE(IDEV,1020)(TOT(K),K=K1,K2)
        DO 390 I=1,IDM-MINUS
        DO 390 K=1,IDM-MINUS
          WRITE(IDEV,1021)CHRSET(K),CHRSET(I),(SUM(K,I,KK),KK=K1,K2)
390     CONTINUE
        K1=K1+20
        IF(K1.GT.LENGTH)K1=LENGTH
400   CONTINUE
      CLOSE(UNIT=IDEV)
      END
      SUBROUTINE RDWMTD(TOT,WT,MIDDLE,LENGTH,MAXLEN,YMIN,YMAX,IDEV,
     +IFAIL,IDM,KBOUT)
C   AUTHOR: RODGER STADEN
      INTEGER WT(5,5,MAXLEN),TOT(MAXLEN)
      CHARACTER LINE*79
C   SET FAIL FLAG
      IFAIL=1
1000  FORMAT( )
1001  FORMAT(3X,20I4)
1002  FORMAT(1X,2I6,2F10.3)
1003  FORMAT(A)
1004  FORMAT(' ',A)
      DO 3 I = 1,MAXLEN
        TOT(I) = 0
        DO 2 J = 1,5
          DO 1 K = 1,5
            WT(K,J,I) = 0
1         CONTINUE
2       CONTINUE
3     CONTINUE
C   READ TITLE
      READ(IDEV,1003,ERR=100,END=100)LINE
      WRITE(KBOUT,1004)LINE
C   READ PLOT VALUES ETC
      READ(IDEV,1002,ERR=100,END=100)
     +LENGTH,MIDDLE,YMIN,YMAX
C   HOW MANY LINES TO READ?
      NLINES=1+(LENGTH-1)/20
      K1=1
      DO 10 JJ=1,NLINES
        READ(IDEV,1000,ERR=100,END=100)
        K2=MIN((K1+19),LENGTH)
C        READ(IDEV,1001,ERR=100,END=100)(TOT(K),K=K1,K2)
        READ(IDEV,1000,ERR=100,END=100)
        DO 5 I=1,4
        DO 5 J=1,4
          READ(IDEV,1001,ERR=100,END=100)(WT(J,I,K),K=K1,K2)
          DO 6 K=K1,K2
            TOT(K) = TOT(K) + WT(J,I,K)
6         CONTINUE
5       CONTINUE
        K1=K1+20
        IF(K1.GT.LENGTH)K1=LENGTH
10    CONTINUE
      CLOSE(UNIT=IDEV)
C   SET FAIL FLAG TO GOOD
      IFAIL=0
      RETURN
100   CONTINUE
      END
      SUBROUTINE DISIGP(SEQ,IDIM,MARGL,MARGR,MARGB,MARGT,
     +ISXMAX,ISYMAX,J1,J2,IDEVOT,WT,IDM,MAXLEN,LENGTH,
     +YMIN,YMAX,IGON,MIDDLE)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      REAL WT(IDM,IDM,MAXLEN)
      INTEGER CTONUM
      EXTERNAL CTONUM
      XMAX=J2
      XMIN=J1
      IF(IGON.EQ.0)THEN
        CALL CLEARV
        CALL VECTOM
        CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      END IF
      DO 10 I=J1,J2-LENGTH
        SUM1=0.
        K=0
        DO 5 J=I,I+LENGTH-1
          K=K+1
          KT1=CTONUM(SEQ(J))
          KT2=CTONUM(SEQ(J+1))
          SUM1 = SUM1 + WT(KT1,KT2,K)
5       CONTINUE
        IF(SUM1.GE.YMIN)THEN
          IF(IGON.EQ.0)THEN
            X=I+MIDDLE
            CALL LINE(X,X,YMIN,SUM1,XMAX,XMIN,YMAX,YMIN,
     +      MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
          END IF
          IF(IGON.EQ.1)THEN
            CALL VT100M
            WRITE(IDEVOT,1010)I+MIDDLE,SUM1,(SEQ(K),K=I,I+LENGTH-1)
1010        FORMAT(' ',I7,F10.2,' ',120A1)
          END IF
        END IF
10    CONTINUE
      CALL VT100M
      RETURN
      END
C  LOCALF
      SUBROUTINE LOCALF(SEQNCE,IDIM1,STRING,MATCH,IDIM3I,
     +ITOT,ITOTEL,ITOTID,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,J1,J2,KSTART,
     +IDEV,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,DIALOG)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQNCE(IDIM1),STRING(IDIM3I),MATCH(IDIM3I)
      INTEGER ITOT(ITOTID),ITOTEL(ITOTID)
      INTEGER ANSRV,ANSC
      INTEGER SPAN,DIALOG
      CALL SHOWFU(KBOUT,
     +'Search for local similarity or complementarity')
      CALL GETPAR(36,15,IOK,MINSP,MAXSP,SPAN,MINPR,MAXPR,IPR,
     +MNIR1,MXIR1,IRAN1,MNIR2,MXIR2,IRAN2,
     +ANSRV,ANSC,IGON,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      PR = REAL(IPR)
10    CONTINUE
      CALL LOCALD(
     +ANSRV,ANSC,IOK,MINSP,MAXSP,SPAN,MINPR,MAXPR,IPR,PR,
     +MNIR1,MXIR1,IRAN1,MNIR2,MXIR2,IRAN2,IGON,
     +J1,J2,IS,IE,KBIN,KBOUT,MINS,
     +IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.NE.0) RETURN
      CALL LOCALP(SEQNCE,IDIM1,STRING,MATCH,
     +ITOT,ITOTEL,ITOTID,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,KSTART,
     +ANSRV,SPAN,IRAN1,IRAN2,IGON,MINS,
     +J1,J2,IS,IE,KBIN,KBOUT,IDEV)
      DIALOG = 1
      GO TO 10
      END
      SUBROUTINE LOCALD(
     +ANSRV,ANSC,IOK,MINSP,MAXSP,SPAN,MINPR,MAXPR,IPR,PR,
     +MNIR1,MXIR1,IRAN1,MNIR2,MXIR2,IRAN2,IGON,
     +J1,J2,IS,IE,KBIN,KBOUT,MINS,
     +IHELPS,IHELPE,HELPF,IDEVH)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      INTEGER ANSRV,ANSC
      INTEGER CHOICE,SPAN
      IOK = 1
      CHOICE = ANSRV
      CALL YESONO(CHOICE,'Find direct repeats',
     +'Find inverted repeats',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(CHOICE.LT.0) RETURN
      ANSRV = CHOICE
      CALL YESNO(ANSC,'Keep picture',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(ANSC.LT.0) RETURN
      IF(ANSC.EQ.1)CALL CLEARG
      CALL GETINT(MINSP,MAXSP,SPAN,'Span',IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      SPAN = IVAL
      IS = J1
      IE = J2
      CALL GTREG(KBIN,KBOUT,0,J2,IS,IE,'Define restricted region',
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      CALL SQPF5(SPAN,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,PR,MINS,IOK)
      IF(IOK.NE.0) RETURN
      CALL GETINT(MNIR1,MXIR1,IRAN1,'Range start',IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      IRAN1 = IVAL
      MNIR2 = MAX(MNIR2,IRAN1)
      MXIR2 = MAX(MNIR2,MXIR2)
      IRAN2 = MAX(IRAN2,MNIR2)
      CALL GETINT(MNIR2,MXIR2,IRAN2,'Range end',IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      IRAN2 = IVAL
      CALL YESONO(IGON,'Plot results','List results',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IGON.LT.0)RETURN
      IOK = 0
      END
      SUBROUTINE LOCALP(SEQNCE,IDIM1,STRING,MATCH,
     +ITOT,ITOTEL,ITOTID,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,KSTART,
     +ANSRV,SPAN,IRAN1,IRAN2,IGON,MINS,
     +J1,J2,IS,IE,KBIN,KBOUT,IDEV)
C   AUTHOR: RODGER STADEN
      INTEGER SPAN
      CHARACTER SEQNCE(IDIM1),STRING(SPAN),MATCH(SPAN)
      INTEGER ITOT(ITOTID),ITOTEL(ITOTID)
      INTEGER ANSRV
      XMIN=J1
      XMAX=J2
      YMIN=0.
      YMAX=SPAN
      CALL BUSY(KBOUT)
      IF(IGON.EQ.0)THEN
        CALL CLEARV
        CALL VECTOM
        CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      END IF
C LAST START POSITION
      ILAST=IE-SPAN+1
C   HOW MANY LOOPS?
      IT1=IRAN1+SPAN-1
      IT2=IRAN2+SPAN+SPAN-2
      DO 50 J=IS,IE
        IS1=J+IT1
        IE1=J+IT2
        IF(IE1.GT.IE)IE1=IE
        IF(IS1.GT.ILAST)GO TO 51
        CALL SQCOPY(SEQNCE(J-KSTART+1),STRING,SPAN)
        IF(ANSRV.EQ.1)THEN
          CALL SQREV(STRING,SPAN)
          CALL SQCOM(STRING,SPAN)
        END IF
        CALL SQFIT(SEQNCE,IDIM1,STRING,SPAN,ITOT,ITOTEL,ITOTID,
     +  IS1,IE1,MINS,ITOTP,KSTART)
        IF(ITOTP.GT.ITOTID) THEN
          IF(IGON.EQ.0)CALL VT100M
          WRITE(KBOUT,1017)ITOTID
1017      FORMAT(/10X,'More than',I4,' matches.',
     +    ' Try changing percentage or region'/)
          RETURN
        END IF
        IF(ITOTP.GT.0)THEN
          IF(IGON.EQ.0)THEN
            X1=J
            DO 41 I=1,ITOTP
              X=ITOTEL(I)
              Y=ITOT(I)
              CALL LINE(X1,X,Y,YMIN,
     +        XMAX,XMIN,YMAX,YMIN,MARGL,MARGR,MARGB,
     +        MARGT,ISXMAX,ISYMAX)
41          CONTINUE
          END IF
          IF(IGON.EQ.1)THEN
            DO 49 I=1,ITOTP
              K=ITOTEL(I)-KSTART+1
              WRITE(IDEV,1008)
1008          FORMAT(/)
              CALL SQMTCH(SEQNCE(K),STRING,MATCH,SPAN)
              CALL FMT4LN(SEQNCE(K),STRING,MATCH,
     +        SPAN,ITOTEL(I),J,IDEV)
49          CONTINUE
          END IF
        END IF
50    CONTINUE
51    CONTINUE
      IF(IGON.EQ.0)CALL VT100M
      END
C  SETGEN
      SUBROUTINE SETGEN(PAAS,PAA,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH)
      CHARACTER PAAS(5,5,5),PAA(5,5,5)
C   AUTHOR: RODGER STADEN
      CHARACTER HELPF*(*),UGA(3),AUA(3),CUA(3),AGA(3),AGG(3)
      INTEGER CTONUM
      PARAMETER (MAXPRM = 23)
      CHARACTER PROMPT(4)*(MAXPRM)
      EXTERNAL CTONUM
      SAVE UGA,AUA,CUA,AGA,AGG
      DATA UGA,AUA,CUA,AGA,AGG/'T','G','A','A','T','A','C','T','A',
     +'A','G','A','A','G','G'/
      NUM = 1
C   SET STANDARD CODE
      DO 10 I=1,5
      DO 10 J=1,5
      DO 10 K=1,5
        PAA(I,J,K)=PAAS(I,J,K)
10    CONTINUE
      PROMPT(1) = 'Standard'
      PROMPT(2) = 'Mammalian mitochondrial'
      PROMPT(3) = 'Yeast mitochondrial'
      PROMPT(4) = 'Personal'
      CALL RADION('Select genetic code',PROMPT,4,NUM,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(NUM.LT.2) RETURN
      IF(NUM.EQ.2)THEN
         PAA(CTONUM(AUA(3)),CTONUM(AUA(2)),CTONUM(AUA(1)))='M'
         PAA(CTONUM(UGA(3)),CTONUM(UGA(2)),CTONUM(UGA(1)))='W'
         PAA(CTONUM(AGA(3)),CTONUM(AGA(2)),CTONUM(AGA(1)))='*'
         PAA(CTONUM(AGG(3)),CTONUM(AGG(2)),CTONUM(AGG(1)))='*'
      ELSE IF(NUM.EQ.3)THEN
         PAA(CTONUM(CUA(3)),CTONUM(CUA(2)),CTONUM(CUA(1)))='T'
         PAA(CTONUM(AUA(3)),CTONUM(AUA(2)),CTONUM(AUA(1)))='M'
         PAA(CTONUM(UGA(3)),CTONUM(UGA(2)),CTONUM(UGA(1)))='W'
      ELSE IF(NUM.EQ.4)THEN
         CALL GETCOD(PAA,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH)
      END IF
      END
      SUBROUTINE GETCOD(PAA,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH)
C   AUTHOR: RODGER STADEN
      CHARACTER HELPF*(*)
      CHARACTER PAA(5,5,5),AA,CODON*3,AIN,AAA
      INTEGER CTONUM
      EXTERNAL CTONUM
      WRITE(KBOUT,1004)
1004  FORMAT(' Define genetic code by typing a codon',
     +/,' followed by a 1 letter amino acid symbol')
1     CONTINUE
      L = 0
      CALL GTSTR('Codon',' ',CODON,L,KBOUT,KBIN,INFLAG)
      IF(INFLAG.EQ.1) THEN
         CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
         GO TO 1
      END IF
      IF(INFLAG.EQ.2) RETURN
      IF(INFLAG.EQ.3) RETURN
      AA = 
     +PAA(CTONUM(CODON(3:3)),CTONUM(CODON(2:2)),CTONUM(CODON(1:1)))
      IF(AA.NE.'-')THEN
2       CONTINUE
         L = 1
         AAA = AA
         CALL GTSTR('Amino acid symbol',AAA,AIN,L,KBOUT,KBIN,INFLAG)
         IF(INFLAG.EQ.1) THEN
           CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
           GO TO 2
        END IF
        IF(INFLAG.EQ.2) RETURN
        IF(L.GT.0) AAA = AIN
        PAA(CTONUM(CODON(3:3)),CTONUM(CODON(2:2)),
     +  CTONUM(CODON(1:1))) = AAA
        GO TO 1
      END IF
      GO TO 1
      END
      SUBROUTINE DINUCF(SEQ,IDIM,J1,J2,IDEV,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),BASE(4)
      REAL OBS(5,5),EXPEC(5,5),COMP(5)
      INTEGER CTONUM
      EXTERNAL CTONUM
      SAVE BASE
      DATA BASE/'T','C','A','G'/
      CALL SHOWFU(KBOUT,'Calculate dinucleotide frequencies')
      DO 10 I=1,5
        COMP(I)=0.
        DO 10 J=1,5
          EXPEC(I,J)=0.
          OBS(I,J)=0.
10    CONTINUE
      DO 20 I=J1,J2-1
        K0=CTONUM(SEQ(I))
        K1=CTONUM(SEQ(I+1))
        COMP(K0)=COMP(K0)+1.
        OBS(K0,K1)=OBS(K0,K1)+1.
20    CONTINUE
      TOT=J2-J1
      DO 25 I=1,5
        COMP(I)=COMP(I)/TOT
25    CONTINUE
      TOT=TOT/100.
      DO 26 I=1,5
      DO 26 J=1,5
        EXPEC(I,J)=COMP(I)*COMP(J)
26    CONTINUE
      DO 30 I=1,5
      DO 30 J=1,5
        EXPEC(I,J)=EXPEC(I,J)*100.
        OBS(I,J)=OBS(I,J)/TOT
30    CONTINUE
      WRITE(IDEV,1002)BASE
      WRITE(IDEV,1001)
1002  FORMAT(/10X,4(4X,A1,9X))
1001  FORMAT(' ',7X,4(' Obs  Expected'))
      DO 40 K=1,4
        WRITE(IDEV,1000)BASE(K),(OBS(K,J),EXPEC(K,J),J=1,4)
1000    FORMAT('     ',A1,8F7.2)
40    CONTINUE
      END
      INTEGER FUNCTION ICOMP(IN)
C   AUTHOR: RODGER STADEN
      INTEGER COMPS(5)
      SAVE COMPS
      DATA COMPS/3,4,1,2,5/
      ICOMP=COMPS(IN)
      END
C   lwrap2
      INTEGER FUNCTION LWRAP2(IDIM,I)
C   AUTHOR: RODGER STADEN
      LWRAP2=I
      IF(LWRAP2.LT.1)LWRAP2=LWRAP2+IDIM+1
      IF(LWRAP2.GT.IDIM)LWRAP2=LWRAP2-IDIM
      END
C   LWRAP3
      INTEGER FUNCTION LWRAP3(IDIM,I)
C   AUTHOR: RODGER STADEN
      LWRAP3=I
      IF(LWRAP3.LT.1)LWRAP3=LWRAP3+IDIM
      IF(LWRAP3.GT.IDIM)LWRAP3=LWRAP3-IDIM
      END
      SUBROUTINE NORMAA(SUM,TOTA,PAA)
      CHARACTER PAA(5,5,5),AA(21)
      REAL SUM(4,4,4)
      SAVE AA
      DATA AA/'A','C','D','E','F',
     +'G','H','I','K','L',
     +'M','N','P','Q','R',
     +'S','T','V','W','Y','*'/
C   LOOP FOR EACH ACID
      DO 150 L=1,21
        ASUM=0.
C   LOOP FOR EACH CODON
        DO 200 I=1,4
        DO 200 J=1,4
        DO 200 K=1,4
C   COUNT CODONS
          IF(PAA(K,J,I).EQ.AA(L))ASUM=ASUM+SUM(I,J,K)
200     CONTINUE
        IF(ASUM.NE.0.0)ASUM=TOTA/ASUM
C   LOOP FOR EACH CODON
        DO 100 I=1,4
        DO 100 J=1,4
        DO 100 K=1,4
C   NORMALIZE
          IF(PAA(K,J,I).EQ.AA(L))SUM(I,J,K)=SUM(I,J,K)*ASUM
100     CONTINUE
150   CONTINUE
      END
      SUBROUTINE PPROM1(SEQ,IDIM,ISXMAX,ISYMAX,I1,I2,MARGL,MARGR,
     + MARGB,MARGT,IDEV,FILEIN,KBOUT)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),FILEIN*(*)
      INTEGER CTONUM
      REAL WTM35(25,5),WTM10(19,5),WTP1(12,5),PENALT(7)
      EXTERNAL CTONUM
      CALL SHOWFU(KBOUT,'E coli promoter search')
      CALL RPPROM(WTM35,WTM10,WTP1,IDEV,FILEIN,IFAIL)
      IF(IFAIL.NE.0)THEN
        CALL ERROM(KBOUT,'Error in weight matrix')
        RETURN
      END IF
      IMARG=NINT(MARGT/2.0)
      MARGB2=MARGB+IMARG
      MARGT2=IMARG
      MARGB1=MARGB
      MARGT1=IMARG
      PENALT(1)=0.02
      PENALT(2)=0.2
      PENALT(3)=1.0
      PENALT(4)=0.2
      PENALT(5)=0.05
      PENALT(6)=0.02
      PENALT(7)=0.01
      DO 1 I=1,7
        PENALT(I)=LOG(PENALT(I))
1     CONTINUE
      CUTM35=-36.85
      CUTM10=-28.13
      CUTP1=-21.8
      XMAX=I2
      XMIN=I1
      YMIN=-77.3
      YMAX=-60.4
      YMIN1=-77.3*0.01
      YMAX1=-60.4*0.01
      YMIN1=-77.3
      YMAX1=-60.4
      CALL CLEARV
      CALL VECTOM
      CALL FRAME(MARGL,MARGR,MARGB1,MARGT1,ISXMAX,ISYMAX)
      CALL FRAME(MARGL,MARGR,MARGB2,MARGT2,ISXMAX,ISYMAX)
      DO 100 I=I1,I2-65
C   DO -35 REGION
        SUMM35=0.
        K=0
        DO 5 J=I,I+24
          K=K+1
          SUMM35=SUMM35+WTM35(K,CTONUM(SEQ(J)))
5       CONTINUE
C  HIGH ENOUGH?
        IF(SUMM35.GE.CUTM35)THEN
C  YES, TRY -10 REGION
          BESTM1=-99999.
          DO 20 J=I+25,I+25+6
            K=0
            SUMM10=0.
            DO 10 L=J,J+18
              K=K+1
              SUMM10=SUMM10 + WTM10(K,CTONUM(SEQ(L)))
10          CONTINUE
C   IS THIS -10 SCORE HIGH ENOUGH?
            IF((SUMM10).GE.CUTM10)THEN
C   YES, IS IT THE HIGHEST?
              IF(SUMM10.GT.BESTM1)THEN
                BESTM1=SUMM10
                IBEST=J
                IBESTA=IBEST-I-24
              END IF
            END IF
20        CONTINUE
C   -10 DONE, HIGH ENOUGH SCORE?
          IF(BESTM1.GE.CUTM10)THEN
C   YES, DO +1 REGION
            BESTP1=-99999.
            DO 40 J=IBEST+19,IBEST+19+4
              SUMP1=0.
              K=0
              DO 30 L=J,J+11
                K=K+1
                SUMP1=SUMP1 + WTP1(K,CTONUM(SEQ(L)))
30            CONTINUE
C   HIGH ENOUGH?
              IF(SUMP1.GE.CUTP1)THEN
C   YES, HIGHEST?
                IF(SUMP1.GT.BESTP1)THEN
                  BESTP1=SUMP1
                  JBEST=J
                END IF
              END IF
40          CONTINUE
C   +1 REGION DONE, HIGH ENOUGH SCORE?
            IF(BESTP1.GE.CUTP1)THEN
C   YES, SO ALL HIGH ENOUGH
              X=JBEST+2
              Y=SUMM35+BESTM1+BESTP1
              CALL LINE(X,X,YMIN,Y,XMAX,XMIN,
     +        YMAX,YMIN,
     +        MARGL,MARGR,MARGB2,MARGT2,
     +        ISXMAX,ISYMAX)
              Y=Y+PENALT(IBESTA)
              CALL LINE(X,X,YMIN1,Y,XMAX,XMIN,
     +        YMAX1,YMIN1,
     +        MARGL,MARGR,MARGB1,MARGT1,
     +        ISXMAX,ISYMAX)
            END IF
          END IF
        END IF
100   CONTINUE
      CALL VT100M
      END
      SUBROUTINE RPPROM(WTM35,WTM10,WTP1,IDEV,FILEIN,IFAIL)
C   AUTHOR: RODGER STADEN
      REAL WTM35(25,5),WTM10(19,5),WTP1(12,5)
      INTEGER WT(25),TOT(25)
      CHARACTER FILEIN*(*)
      IFAIL=0
1001  FORMAT(2X,25I3)
      CALL OPENRS(IDEV,FILEIN,IOK,LRECL,2)
      IF(IOK.NE.0)GO TO 100
C   READ SPACE,P
      READ(IDEV,1000,ERR=100)
      READ(IDEV,1000,ERR=100)
      READ(IDEV,1000,ERR=100)
1000  FORMAT()
      READ(IDEV,1001,ERR=100)TOT
      DO 5 I=1,4
        READ(IDEV,1001,ERR=100)(WT(K),K=1,25)
        DO 5 J=1,25
          IF(WT(J).NE.0)THEN
            WTM35(J,I) = LOG(FLOAT(WT(J))/FLOAT(TOT(J)))
          ELSE
            WTM35(J,I)=LOG(0.5/FLOAT(TOT(J)))
          END IF
5     CONTINUE
C   DO 5'S
      DO 20 I=1,25
        WTM35(I,5)=LOG(0.25/TOT(I))
20    CONTINUE
C   do -10 region
      READ(IDEV,1000,ERR=100)
      READ(IDEV,1000,ERR=100)
      READ(IDEV,1001)(TOT(K),K=1,19)
      DO 30 I=1,4
        READ(IDEV,1001,ERR=100)(WT(K),K=1,19)
        DO 30 J=1,19
          IF(WT(J).NE.0)THEN
            WTM10(J,I) = LOG(FLOAT(WT(J))/FLOAT(TOT(J)))
          ELSE
            WTM10(J,I)=LOG(0.5/FLOAT(TOT(J)))
          END IF
30    CONTINUE
C   do 5's
      DO 35 I=1,19
        WTM10(I,5)=LOG(0.25/TOT(I))
35    CONTINUE
C   DO +1 REGION
      READ(IDEV,1000,ERR=100)
      READ(IDEV,1000,ERR=100)
      READ(IDEV,1001,ERR=100)(TOT(K),K=1,12)
      DO 40 I=1,4
        READ(IDEV,1001,ERR=100)(WT(K),K=1,12)
        DO 40 J=1,12
          IF(WT(J).NE.0)THEN
            WTP1(J,I) = LOG(FLOAT(WT(J))/FLOAT(TOT(J)))
          ELSE
            WTP1(J,I)=LOG(0.5/FLOAT(TOT(J)))
          END IF
40    CONTINUE
C   DO 5'S
      DO 45 I=1,12
        WTP1(I,5)=LOG(0.25/TOT(I))
45    CONTINUE
      CLOSE(UNIT=IDEV)
      RETURN
100   CONTINUE
      IFAIL=1
      END
      SUBROUTINE PPROM2(SEQ,IDIM,ISXMAX,ISYMAX,I1,I2,MARGL,MARGR,
     +MARGB,MARGT,IDEV,FILEIN,KBOUT)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),FILEIN*(*)
      REAL WTM35(25,5),WTM10(19,5),WTP1(12,5)
      INTEGER CTONUM
      EXTERNAL CTONUM
      CALL SHOWFU(KBOUT,'E coli promoter -35 and -10 regions search')
      CALL RPPROM(WTM35,WTM10,WTP1,IDEV,FILEIN,IFAIL)
      IF(IFAIL.NE.0)THEN
        CALL ERROM(KBOUT,'Error in weight matrix')
        RETURN
      END IF
      IMARG=NINT(MARGT/2.0)
      MARGB2=MARGB+IMARG
      MARGT2=IMARG
      MARGB1=MARGB
      MARGT1=IMARG
      XMAX=I2
      XMIN=I1
      YMIN35=-38.0
      YMAX35=-23.5
      YMIN1=-29.0
      YMAX1=-18.4
      YMID35=YMIN35+(YMAX35-YMIN35)/2.
      YMID1=YMIN1+(YMAX1-YMIN1)/2.
      CALL CLEARV
      CALL VECTOM
      CALL FRAME(MARGL,MARGR,MARGB1,MARGT1,ISXMAX,ISYMAX)
      CALL FRAME(MARGL,MARGR,MARGB2,MARGT2,ISXMAX,ISYMAX)
      CALL TEXT(XMIN,YMID35,'-35',3,0,XMAX,XMIN,YMAX35,YMIN35,
     +MARGL,MARGR,MARGB1,MARGT1,ISXMAX,ISYMAX)
      CALL TEXT(XMIN,YMID1,'-10',3,0,XMAX,XMIN,YMAX1,YMIN1,
     +MARGL,MARGR,MARGB2,MARGT2,ISXMAX,ISYMAX)
C
      DO 100 I=I1,I2-25
C   DO -35 REGION
        SUMM35=0.
        K=0
        DO 5 J=I,I+24
          K=K+1
          SUMM35=SUMM35+WTM35(K,CTONUM(SEQ(J)))
5       CONTINUE
        X=I+48
        Y=SUMM35
        CALL LINE(X,X,YMIN35,Y,XMAX,XMIN,YMAX35,YMIN35,
     +  MARGL,MARGR,MARGB2,MARGT2,ISXMAX,ISYMAX)
100   CONTINUE
      DO 200 I=I1,I2-19
        SUMM10=0.
        K=0
        DO 20 J=I,I+18
          K=K+1
          SUMM10=SUMM10+WTM10(K,CTONUM(SEQ(J)))
20      CONTINUE
        X=I+22
        Y=SUMM10
        CALL LINE(X,X,YMIN1,Y,XMAX,XMIN,YMAX1,YMIN1,
     +  MARGL,MARGR,MARGB1,MARGT1,ISXMAX,ISYMAX)
200   CONTINUE
      CALL VT100M
      END
C  PROMOTERS ON THE COMPLEMENTARY STRAND
      SUBROUTINE PPROM3(SEQ,IDIM,ISXMAX,ISYMAX,I1,I2,MARGL1,MARGR1,
     +MARGB1,MARGT1,IDEV,FILEIN,KBOUT)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),FILEIN*(*)
      REAL WTM35(25,5),WTM10(19,5),WTP1(12,5)
      REAL WTM35C(25,5),WTM10C(19,5),WTP1C(12,5)
      INTEGER CTONUM
      EXTERNAL CTONUM
      CALL SHOWFU(KBOUT,'E coli promters on the complementary strand')
      CALL RPPROM(WTM35,WTM10,WTP1,IDEV,FILEIN,IFAIL)
      IF(IFAIL.NE.0)THEN
        CALL ERROM(KBOUT,'Error in weight matrix')
        RETURN
      END IF
C   REVERSE AND COMPLEMENT MATRICES
      DO 5 I=1,25
      DO 5 J=1,2
        WTM35C(I,J+2)=WTM35(26-I,J)
        WTM35C(I,J)=WTM35(26-I,J+2)
5     CONTINUE
      DO 6 I=1,19
      DO 6 J=1,2
        WTM10C(I,J+2)=WTM10(20-I,J)
        WTM10C(I,J)=WTM10(20-I,J+2)
6     CONTINUE
      DO 7 I=1,12
      DO 7 J=1,2
        WTP1C(I,J+2)=WTP1(13-I,J)
        WTP1C(I,J)=WTP1(13-I,J+2)
7     CONTINUE
      DO 1 I = 1,25
        WTM35C(I,5)=WTM35(26-I,5)
1     CONTINUE
      DO 2 I = 1,19
        WTM10C(I,5)=WTM10(20-I,5)
2     CONTINUE
      DO 3 I = 1,12
        WTP1C(I,5)=WTP1(13-I,5)
3     CONTINUE
      CUTM35=-36.85
      CUTM10=-28.13
      CUTP1=-21.8
      XMAX=I2
      XMIN=I1
      YMIN=-77.3
      YMAX=-60.4
      CALL CLEARV
      CALL VECTOM
      CALL FRAME(MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX)
      DO 100 I=I1,I2-65
C   DO +1 REGION
        SUMP1=0.
        K=0
        DO 8 J=I,I+11
          K=K+1
          SUMP1=SUMP1+WTP1C(K,CTONUM(SEQ(J)))
8       CONTINUE
C  HIGH ENOUGH?
        IF(SUMP1.GE.CUTP1)THEN
C  YES, TRY -10 REGION
          BESTM1=-99999.
          DO 20 J=I+12,I+12+4
            K=0
            SUMM10=0.
            DO 10 L=J,J+18
              K=K+1
              SUMM10=SUMM10 + WTM10C(K,CTONUM(SEQ(L)))
10          CONTINUE
C   IS THIS -10 SCORE HIGH ENOUGH?
            IF(SUMM10.GE.CUTM10)THEN
C   YES, IS IT THE HIGHEST?
              IF(SUMM10.GT.BESTM1)THEN
                BESTM1=SUMM10
                IBEST=J
              END IF
            END IF
20        CONTINUE
C   -10 DONE, HIGH ENOUGH SCORE?
          IF(BESTM1.GE.CUTM10)THEN
C   YES, DO -35 REGION
            BESTM3=-99999.
            DO 40 J=IBEST+19,IBEST+19+6
              SUMM35=0.
              K=0
              DO 30 L=J,J+24
                K=K+1
                SUMM35=SUMM35+WTM35C(K,CTONUM(SEQ(L)))
30            CONTINUE
C   HIGH ENOUGH?
              IF(SUMM35.GE.CUTM35)THEN
C   YES, HIGHEST?
                IF(SUMM35.GT.BESTM3)THEN
                  BESTM3=SUMM35
                END IF
              END IF
40          CONTINUE
C   -35 REGION DONE, HIGH ENOUGH SCORE?
            IF(BESTM3.GE.CUTM35)THEN
C   YES, SO ALL HIGH ENOUGH
              X=I+10
              Y=SUMP1+BESTM3+BESTM1
              CALL LINE(X,X,YMIN,Y,
     +        XMAX,XMIN,YMAX,YMIN,
     +        MARGL1,MARGR1,MARGB1,
     +        MARGT1,ISXMAX,ISYMAX)
            END IF
          END IF
        END IF
100   CONTINUE
      CALL VT100M
      END
      SUBROUTINE PRIBS(SEQ,IDIM,MARGL,MARGR,MARGB,MARGT,
     +ISXMAX,ISYMAX,I1,I2,IDEV,FILE1,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),FILE1*(*)
      INTEGER WEIGHT(505),MARGB1(3),MARGT1(3),CTONUM
      EXTERNAL CTONUM
      CALL SHOWFU(KBOUT,'Search for E coli ribosome binding sites')
C   SORT OUT MARGIN IE FIND MAX AND DIVIDE BY THREE
      IMARG=NINT(MARGT/3.)
      MARGL1=MARGL
      MARGR1=MARGR
      MARGB1(1)=MARGB
      MARGB1(2)=MARGB+IMARG
      MARGB1(3)=MARGB+2*IMARG
      MARGT1(1)=IMARG
      MARGT1(2)=IMARG
      MARGT1(3)=IMARG
      YMAX=100.
      YMIN=0.
      CALL RPRIBS(IDEV,FILE1,WEIGHT,IOK,KBOUT)
      IF(IOK.NE.0)RETURN
      MINSMN = -50
      MINSMX = 100
      MINSI = 2
      CALL GETINT(MINSMN,MINSMX,MINSI,'Minimum score',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MINS = IVAL
      XMAX=I2
      XMIN=I1
      Y=0.
      YP=20.0
      CALL CLEARV
      CALL BUSY(KBOUT)
      CALL VECTOM
      DO 10 I=I1,I2-100
        ISUM=0
        K=0
        II=I
        III=I+100
        DO 5 J=II,III
          K=K+1
          KK=CTONUM(SEQ(J))-1
          KK=KK*101
          IP=K+KK
          ISUM=ISUM+WEIGHT(IP)
5       CONTINUE
        IF(ISUM.GT.MINS)THEN
          X=I+60
          IMARG=1+MOD((II-I1),3)
          CALL LINE(X,X,Y,YP,XMAX,XMIN,YMAX,YMIN,
     +    MARGL,MARGR,MARGB1(IMARG),MARGT1(IMARG),
     +    ISXMAX,ISYMAX)
        END IF
10    CONTINUE
      CALL VT100M
      END
      SUBROUTINE RPRIBS(IDEV,FILE1,WT,IOK,KBOUT)
C   AUTHOR: RODGER STADEN
      INTEGER WT(505)
      CHARACTER FILE1*(*)
1001  FORMAT(2X,25I3)
      CALL OPENRS(IDEV,FILE1,IOK,LRECL,2)
      IF(IOK.NE.0)GO TO 100
      DO 20 J=1,4
C   read space,p
        READ(IDEV,1000,END=200,ERR=200)
        READ(IDEV,1000,END=200,ERR=200)
1000    FORMAT()
        JJ=(J-1)*25
        DO 5 I=1,4
          II=(I-1)*101
          K1=JJ+II+1
          READ(IDEV,1001,END=200,ERR=200)(WT(K),K=K1,K1+24)
5       CONTINUE
20    CONTINUE
C   do last bit
      READ(IDEV,1000,END=200,ERR=200)
      READ(IDEV,1000,END=200,ERR=200)
      K1=101
1002  FORMAT(2X,I3)
      DO 30 I=1,4
        READ(IDEV,1002,ERR=200,END=200)WT(K1)
        K1=K1+101
30    CONTINUE
      CLOSE(UNIT=IDEV)
      DO 40 I=405,505
        WT(I)=0
40    CONTINUE
      RETURN
100   CONTINUE
      CALL ERROM(KBOUT,'Error opening file')
      RETURN
200   CONTINUE
      CALL ERROM(KBOUT,'Error reading file')
      IOK = 1
      END
C   SCANS FOR EUKARYOTIC RIBOSOME BINDING SITES
      SUBROUTINE RIBEUK(SEQ,IDIM,ISXMAX,ISYMAX,J1,J2,
     +MARGL,MARGR,MARGB,MARGT,IDEV,FILEIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),FILEIN*(*)
      REAL WT(10,5)
      INTEGER CTONUM,MARGB1(3),MARGT1(3)
      EXTERNAL CTONUM
      CALL SHOWFU(KBOUT,'Search for eukaryotic ribosome binding sites')
      CALL RRIBEU(WT,IDEV,FILEIN,IFAIL)
      IF(IFAIL.NE.0)THEN
        CALL ERROM(KBOUT,'Error in weight matrix')
        RETURN
      END IF
C   SORT OUT MARGIN IE FIND MAX AND DIVIDE BY THREE
      IMARG=NINT(MARGT/3.)
      MARGL1=MARGL
      MARGR1=MARGR
      MARGB1(1)=MARGB
      MARGB1(2)=MARGB+IMARG
      MARGB1(3)=MARGB+2*IMARG
      MARGT1(1)=IMARG
      MARGT1(2)=IMARG
      MARGT1(3)=IMARG
      YMIN=-9.0
      YMAX=0.0
      XMAX=J2
      XMIN=J1
      CALL CLEARV
      CALL VECTOM
C   ADD 2 TO MAKE PHASE CORRECT
      I1=J1+1
      DO 20 II=1,3
        DO 10 I=I1+II,J2-10,3
          IF((SEQ(I+7).EQ.'A').AND.(SEQ(I+8).EQ.'T').
     +    AND.(SEQ(I+9).EQ.'G'))THEN
            SUM=0.
            K=0
            DO 5 J=I,I+9
              K=K+1
              SUM=SUM+WT(K,CTONUM(SEQ(J)))
5           CONTINUE
            X=I+7
            CALL LINE(X,X,YMIN,SUM,XMAX,
     +      XMIN,YMAX,YMIN,
     +      MARGL1,MARGR1,MARGB1(II),
     +      MARGT1(II),ISXMAX,ISYMAX)
          END IF
10      CONTINUE
20    CONTINUE
      CALL VT100M
      END
      SUBROUTINE RRIBEU(WTR,IDEV,FILEIN,IFAIL)
C   AUTHOR: RODGER STADEN
      CHARACTER FILEIN*(*)
      REAL WTR(10,5)
      INTEGER WT(10),TOT(10)
      IFAIL=0
1001  FORMAT(2X,10I3)
      CALL OPENRS(IDEV,FILEIN,IOK,LRECL,2)
      IF(IOK.NE.0)GO TO 50
C   read space,p
      READ(IDEV,1000,ERR=50)
      READ(IDEV,1000,ERR=50)
1000  FORMAT()
      READ(IDEV,1001,ERR=50)TOT
      DO 6 I=1,4
        READ(IDEV,1001,ERR=50)(WT(K),K=1,10)
        DO 5 J=1,10
          IF(WT(J).NE.0)THEN
            WTR(J,I)=LOG(FLOAT(WT(J))/FLOAT(TOT(J)))
          ELSE
            WTR(J,I)=LOG(1./FLOAT(TOT(J)))
          END IF
5       CONTINUE
6     CONTINUE
      CLOSE(UNIT=IDEV)
      Z=LOG(1./102.)
      DO 40 I=1,10
        WTR(I,5)=Z
40    CONTINUE
      RETURN
50    CONTINUE
      IFAIL=1
      END
      SUBROUTINE FSPLIC(SEQ,IDIM,MARGL,MARGR,MARGB,MARGT,
     +ISXMAX,ISYMAX,J1,J2,IDEV,DEFFIL,FILNAM,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IDEVOT,
     +SUM,WTD,WTA,CEXACD,CEXACA,PEXACD,PEXACA,
     +TOT,IDM,MAXLEN,LINE,CHRSET,DIALOG)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),FILNAM*(*),HELPF*(*),DEFFIL*(*)
      CHARACTER LINE(MAXLEN),CHRSET(IDM)
      INTEGER SUM(IDM,MAXLEN),TOT(MAXLEN),DIALOG,ANSFIL
      REAL WTA(IDM,MAXLEN),WTD(IDM,MAXLEN)
      INTEGER CEXACD(MAXLEN),PEXACD(MAXLEN)
      INTEGER CEXACA(MAXLEN),PEXACA(MAXLEN)
      CALL SHOWFU(KBOUT,'Splice search using weight matrix')
      CALL GETPAR(62,1,IOK,IGON,
     +IPAR2,IPAR3,IPAR4,IPAR5,
     +IPAR6,IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      CALL SPLICD(IDEV,DEFFIL,FILNAM,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,
     +SUM,IDM,MAXLEN,TOT,WTD,LENGTD,MIDDLD,YMIND,YMAXD,
     +WTA,LENGTA,MIDDLA,YMINA,YMAXA,
     +IGON,IDEVOT,LINE,CHRSET,DIALOG,ANSFIL,IOK,
     +CEXACD,PEXACD,IEXACD,CEXACA,PEXACA,IEXACA)
      IF(IOK.NE.0) RETURN
      MARGTD = MARGT/2
      CALL SPLICP(SEQ,IDIM,MARGL,MARGR,MARGB,MARGTD,
     +ISXMAX,ISYMAX,J1,J2,IDEVOT,WTD,IDM,MAXLEN,LENGTD,
     +YMIND,YMAXD,IGON,MIDDLD,0,
     +CEXACD,PEXACD,IEXACD)
      MARGBA = MARGB + MARGTD
      CALL SPLICP(SEQ,IDIM,MARGL,MARGR,MARGBA,MARGTD,
     +ISXMAX,ISYMAX,J1,J2,IDEVOT,WTA,IDM,MAXLEN,LENGTA,
     +YMINA,YMAXA,IGON,MIDDLA,1,
     +CEXACA,PEXACA,IEXACA)
      END
      SUBROUTINE SPLICD(IDEV,DEFFIL,FILNAM,
     +KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,
     +SUM,IDM,MAXLEN,TOT,WTD,LENGTD,MIDDLD,YMIND,YMAXD,
     +WTA,LENGTA,MIDDLA,YMINA,YMAXA,
     +IGON,IDEVOT,LINE,CHRSET,DIALOG,ANSFIL,IOK,
     +CEXACD,PEXACD,IEXACD,CEXACA,PEXACA,IEXACA)
C   AUTHOR: RODGER STADEN
      CHARACTER FILNAM*(*),HELPF*(*),DEFFIL*(*)
      CHARACTER LINE(MAXLEN),CHRSET(IDM)
      INTEGER SUM(IDM,MAXLEN),TOT(MAXLEN),DIALOG,ANSFIL
      INTEGER CEXACD(MAXLEN),PEXACD(MAXLEN)
      INTEGER CEXACA(MAXLEN),PEXACA(MAXLEN)
      REAL WTA(IDM,MAXLEN),WTD(IDM,MAXLEN)
      IOK = 1
      ANSFIL = 0
      IF(DIALOG.EQ.1) THEN
        CALL YESNO(ANSFIL,'Use default weights file',
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(ANSFIL.LT.0) RETURN
      END IF
      IF(ANSFIL.EQ.1) THEN
        FILNAM = ' '
        CALL OPENF1(IDEV,FILNAM,0,IOK,KBIN,KBOUT,
     +  'Splice site weight matrix file',
     +  IHELPS,IHELPE,HELPF,IDEVH)
        IF(IOK.NE.0)RETURN
      ELSE
        CALL OPENRS(IDEV,DEFFIL,IOK,LRECL,2)
        IF(IOK.NE.0) RETURN
      END IF
      LENGTD=MAXLEN
      CALL RDWMTN(TOT,SUM,MIDDLD,LENGTD,MAXLEN,YMIND,YMAXD,IDEV,
     +  IOK,IDM,KBOUT,0)
      IF(IOK.NE.0)THEN
        CALL ERROM(KBOUT,'Error in weight matrix')
        CLOSE(UNIT=IDEV)
        RETURN
      END IF
      CALL GETWC(TOT,SUM,LENGTD,IDM,MAXLEN,CEXACD,PEXACD,IEXACD)
      IF(YMIND.LT.0.0)CALL GETW(TOT,SUM,WTD,LENGTD,IDM,MAXLEN)
      IF(YMIND.GE.0.0)CALL GETW2(SUM,WTD,LENGTD,IDM,MAXLEN)
      LENGTA=MAXLEN
      CALL RDWMTN(TOT,SUM,MIDDLA,LENGTA,MAXLEN,YMINA,YMAXA,IDEV,
     +  IOK,IDM,KBOUT,0)
        CLOSE(UNIT=IDEV)
      IF(IOK.NE.0)THEN
        CALL ERROM(KBOUT,'Error in weight matrix')
        RETURN
      END IF
      CALL GETWC(TOT,SUM,LENGTA,IDM,MAXLEN,CEXACA,PEXACA,IEXACA)
      IF(YMINA.LT.0.0)CALL GETW(TOT,SUM,WTA,LENGTA,IDM,MAXLEN)
      IF(YMINA.GE.0.0)CALL GETW2(SUM,WTA,LENGTA,IDM,MAXLEN)
C assume donors in first file: and that the first and last bases in
C exons are marked as middle. Subtract 1 from middla to make frames
C equivalent, but send midc to splicp as a correction so that positions
C of matches are positions on first and last bases in exons. midc=0 for
C donors and 1 for acceptors
      MIDDLA = MIDDLA - 1
      IF(DIALOG.EQ.1) THEN
        AMN = -9999.
        AMX = 9999.
        CALL GETRL(AMN,AMX,YMIND,'Donor cutoff score',VAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        YMIND = VAL
        CALL GETRL(AMN,AMX,YMINA,'Acceptor cutoff score',VAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        YMINA = VAL
        IOK = 1
        CALL YESONO(IGON,'Plot results','List results',
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(IGON.LT.0)RETURN
      END IF
      IOK = 0
      END
      SUBROUTINE SPLICP(SEQ,IDIM,MARGL,MARGR,MARGB,MARGT,
     +ISXMAX,ISYMAX,J1,J2,IDEVOT,WT,IDM,MAXLEN,LENGTH,
     +YMIN,YMAX,IGON,MIDDLE,MIDC,CEXACT,PEXACT,IEXACT)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      REAL WT(IDM,MAXLEN)
      INTEGER CEXACT(IEXACT),PEXACT(IEXACT)
      INTEGER CTONUM
      EXTERNAL CTONUM,MATWTC
      XMAX=J2
      XMIN=J1
      IF(IGON.EQ.0)THEN
        CALL CLEARV
        CALL VECTOM
        IMARG = MARGT/3
        CALL FRAME(MARGL,MARGR,MARGB,IMARG,ISXMAX,ISYMAX)
        CALL FRAME(MARGL,MARGR,MARGB+IMARG,IMARG,ISXMAX,ISYMAX)
        CALL FRAME(MARGL,MARGR,MARGB+(2*IMARG),IMARG,ISXMAX,ISYMAX)
      END IF
      I = J1 - 1
 1    CONTINUE
      I = I + 1
      IF(IEXACT.GT.0) I = MATWTC(SEQ,IDIM,J1,J2,I,CEXACT,PEXACT,IEXACT)
      IF((I+LENGTH-2).LT.J2) THEN
        SUM1=0.
        K=0
        DO 5 J=I,I+LENGTH-1
          K=K+1
          SUM1=SUM1+WT(CTONUM(SEQ(J)),K)
5       CONTINUE
        IF(SUM1.GE.YMIN)THEN
          IF(IGON.EQ.0)THEN
            M = I + MIDDLE
            X = M + MIDC
            M = MARGB + (MOD(M,3)*IMARG)
            CALL LINE(X,X,YMIN,SUM1,XMAX,XMIN,YMAX,YMIN,
     +      MARGL,MARGR,M,IMARG,ISXMAX,ISYMAX)
          END IF
          IF(IGON.EQ.1)THEN
            CALL VT100M
            M = MOD((I+MIDDLE),3)
            WRITE(IDEVOT,1010)I+MIDDLE+MIDC,M,SUM1,
     +      (SEQ(K),K=I,I+LENGTH-1)
1010        FORMAT(' ',I7,I2,F10.2,' ',120A1)
          END IF
        END IF
        GO TO 1
      END IF
      CALL VT100M
      END
      SUBROUTINE SQCOM2(SEQ,IDIM)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),COMP*17
      INTEGER DTONUM
      EXTERNAL DTONUM
      SAVE COMP
      DATA COMP/'AGTC-YRWSKMDVBHN-'/
      DO 100 I=1,IDIM
        J = DTONUM(SEQ(I))
        SEQ(I) = COMP(J:J)
100   CONTINUE
      END
C      SQFIT
      SUBROUTINE SQFIT(SEQ,IDIM1,STRING,IDIM2,ITOT,ITOTEL,ITOTID,
     +IS,IE,MIN,ITOTP,KSTART)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1),STRING(IDIM2)
      INTEGER ITOT(ITOTID),ITOTEL(ITOTID)
C   ALLOWS R,Y AND - SPECIAL CHARACTERS
      IDIF=(IE-IS+2)-IDIM2
C   IDIF IS THE NUMBER OF POSNS TO TRY
C   IPSTR GOES FROM 1 TO IDIM2 IDIF TIMES
C   TRY ALL POSSIBLE POSITIONS FOR MATCHING AND SCORE FOR EACH
C   POINT TO ARRAY ELEMENT CORRESPONDING TO FIRST BASE
      IPSEQ=IS-KSTART+1
      ITOTP=0
      DO 200 I=1,IDIF
        NTOT=0
        IP=IPSEQ
        DO 100 J=1,IDIM2
          IF(SEQ(IP).EQ.STRING(J))THEN
            NTOT=NTOT+1
          ELSE IF (STRING(J).EQ.'R')THEN
            IF((SEQ(IP).EQ.'A').OR.(SEQ(IP).EQ.'G')) NTOT=NTOT+1
          ELSE IF (STRING(J).EQ.'Y')THEN
            IF((SEQ(IP).EQ.'C').OR.(SEQ(IP).EQ.'T')) NTOT=NTOT+1
          ELSE IF (STRING(J).EQ.'-')THEN
            NTOT=NTOT+1
          END IF
          IP=IP+1
100     CONTINUE
C   END OF COUNTING FOR THIS POSITION.IS TOTAL HIGH ENOUGH?
        IF(NTOT.GE.MIN)THEN
          ITOTP=ITOTP+1
C   TEST FOR OVERFLOW
          IF(ITOTP.GT.ITOTID)RETURN
C   SAVE TOTAL AND POSITION
          ITOT(ITOTP)=NTOT
          ITOTEL(ITOTP)=IP-IDIM2+KSTART-1
        END IF
        IPSEQ=IPSEQ+1
200   CONTINUE
      END
C      SQFIT6
      SUBROUTINE SQFIT6(SEQ,IDIM1,STRING,IDIM2,ITOT,ITOTEL,ITOTID,
     +IS,IE,MINS,ITOTP,KSTART)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1),STRING(IDIM2)
      INTEGER ITOT(ITOTID),ITOTEL(ITOTID)
      INTEGER IUBM1
      EXTERNAL IUBM1
      IDIF=(IE-IS+2)-IDIM2
      IPSEQ=IS-KSTART+1
      ITOTP=0
      DO 200 I=1,IDIF
        NTOT = 0
        IP=IPSEQ
        DO 100 J=1,IDIM2
          NTOT = NTOT + IUBM1(STRING(J),SEQ(IP))
          IP=IP+1
100     CONTINUE
        IF(NTOT.GE.MINS)THEN
          ITOTP=ITOTP+1
          IF(ITOTP.GT.ITOTID)RETURN
          ITOT(ITOTP)=NTOT
          ITOTEL(ITOTP)=IP-IDIM2+KSTART-1
        END IF
        IPSEQ=IPSEQ+1
200   CONTINUE
      END
      SUBROUTINE SRCHP(SEQ,IDIM1,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,
     +ISYMAX,J1,J2,KBOUT)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1),STRING(6)
      SAVE STRING
      DATA STRING/'A','A','T','A','A','A'/
      CALL SHOWFU(KBOUT,'PolyA search. i.e. AATAAA search')
      XMIN=J1
      XMAX=J2
      YMIN=0.
      YMAX=MARGT
      Y0=0.
      IBH=MARGT
      CALL VECTOM
      CALL SRCHP1(SEQ,IDIM1,J1,J2,STRING,6,1,
     +XMAX,XMIN,YMAX,YMIN,MARGL,MARGR,MARGB,MARGT,ISXMAX,
     +ISYMAX,Y0,IBH)
      CALL VT100M
      END
      SUBROUTINE SRCHP1(SEQ,IDIM1,J1,J2,STRING,IDIMS,INC,
     +XMAX,XMIN,YMAX,YMIN,MARGL,MARGR,MARGB,MARGT,ISXMAX,
     +ISYMAX,Y,IBH)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1),STRING(6)
      YP=Y+IBH
      IAT=J1-INC
10    CONTINUE
      IAT=IAT+INC
      IDIM=J2-IAT+1
      IF(IDIM.LE.0)RETURN
      CALL FIND6(SEQ(IAT),IDIM,STRING,IDIMS,INC,JMATCH)
      IF(JMATCH.EQ.0)RETURN
      IAT=IAT+JMATCH-1
      X=IAT
      CALL LINE(X,X,YP,Y,XMAX,XMIN,YMAX,YMIN,MARGL,MARGR,MARGB,
     +MARGT,ISXMAX,ISYMAX)
      GO TO 10
      END
      SUBROUTINE STOPSB(SEQ,IDIM1,J1,J2,MARGL,MARGR,MARGB,MARGT,
     +ISXMAX,ISYMAX,PAA)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM1),PAA(5,5,5)
      IMARG=NINT(MARGT/2.)
      MARGB3=MARGB
      MARGB5=MARGB+IMARG
      MARGT3=IMARG
      MARGT5=IMARG
      CALL STOPS(SEQ,IDIM1,J1,J2,
     +MARGL,MARGR,MARGB5,MARGT5,
     +ISXMAX,ISYMAX,PAA)
      CALL STOPSC(SEQ,IDIM1,J1,J2,MARGL,MARGR,
     +MARGB3,MARGT3,
     +ISXMAX,ISYMAX,PAA)
      END
C
C   STOPS
      SUBROUTINE STOPS(SEQ,IDIM1,J1,J2,
     +MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX,PAA)
C   AUTHOR: RODGER STADEN
      CHARACTER STOP(3),SEQ(IDIM1),PAA(5,5,5),BASE(5)
      SAVE BASE
      DATA BASE/'T','C','A','G','-'/
      CALL VECTOM
      XMIN=J1
      XMAX=J2
      YMIN=0.
C   DIVIDE SCREEN INTO 3 STRIPS AND PUT BLIPS AT 1/6,3/6,5/6
      YMAX=ISYMAX-(MARGB1+MARGT1)
      YMAX3=YMAX/3.
      BLIPH=YMAX*0.02
      DO 10 ICOD=1,5
      DO 10 JCOD=1,5
      DO 10 KCOD=1,5
        IF(PAA(KCOD,JCOD,ICOD).EQ.'*')THEN
C         NEED TO KNOW THE CODON
          STOP(1)=BASE(ICOD)
          STOP(2)=BASE(JCOD)
          STOP(3)=BASE(KCOD)
          BLIPF=YMAX3/2.0
          CALL PSRCH(SEQ,IDIM1,J1,J2,STOP,3,3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX,BLIPF,BLIPH)
          BLIPF=BLIPF+YMAX3
          J11=J1+1
          CALL PSRCH(SEQ,IDIM1,J11,J2,STOP,3,3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX,BLIPF,BLIPH)
          BLIPF=BLIPF+YMAX3
          J11=J1+2
          CALL PSRCH(SEQ,IDIM1,J11,J2,STOP,3,3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX,BLIPF,BLIPH)
        END IF
10    CONTINUE
      CALL VT100M
      END
C   STOPSC
      SUBROUTINE STOPSC(SEQ,IDIM1,J1,J2,
     +MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX,PAA)
C   AUTHOR: RODGER STADEN
      CHARACTER STOP(3),SEQ(IDIM1),PAA(5,5,5),BASE(5)
      SAVE BASE
      DATA BASE/'A','G','T','C','-'/
      CALL VECTOM
      XMIN=J1
      XMAX=J2
      YMIN=0.
C   DIVIDE SCREEN INTO 3 STRIPS AND PUT BLIPS AT 1/12,5/12,9/12
      YMAX=ISYMAX-(MARGB1+MARGT1)
      YMAX3=YMAX/3.
      BLIPH=YMAX*0.02
      DO 10 ICOD=1,5
      DO 10 JCOD=1,5
      DO 10 KCOD=1,5
        IF(PAA(KCOD,JCOD,ICOD).EQ.'*')THEN
C         NEED TO KNOW THE CODON
          STOP(1)=BASE(KCOD)
          STOP(2)=BASE(JCOD)
          STOP(3)=BASE(ICOD)
          BLIPF=YMAX3/4.0
          CALL PSRCH(SEQ,IDIM1,J1,J2,STOP,3,3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX,BLIPF,BLIPH)
          BLIPF=BLIPF+YMAX3
          J11=J1+1
          CALL PSRCH(SEQ,IDIM1,J11,J2,STOP,3,3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX,BLIPF,BLIPH)
          BLIPF=BLIPF+YMAX3
          J11=J1+2
          CALL PSRCH(SEQ,IDIM1,J11,J2,STOP,3,3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX,BLIPF,BLIPH)
        END IF
10    CONTINUE
      CALL VT100M
      END
C
C   STARTS
      SUBROUTINE STARTS(SEQ,IDIM1,J1,J2,
     +MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX,PAA)
C   AUTHOR: RODGER STADEN
      CHARACTER CODON(3),SEQ(IDIM1),PAA(5,5,5),BASE(5)
      SAVE BASE
      DATA BASE/'T','C','A','G','-'/
      CALL VECTOM
      XMIN=J1
      XMAX=J2
C   DIVIDE SCREEN INTO 3 STRIPS AND PUT BLIPS AT 0.0,1/3,2/3
      YMAX=ISYMAX-(MARGB1+MARGT1)
      YMAX3=YMAX/3.
      BLIPH=YMAX*0.013
      YMIN=0.
      DO 10 ICOD=1,5
      DO 10 JCOD=1,5
      DO 10 KCOD=1,5
        IF(PAA(KCOD,JCOD,ICOD).EQ.'M')THEN
C         NEED TO KNOW THE CODON
          CODON(1)=BASE(ICOD)
          CODON(2)=BASE(JCOD)
          CODON(3)=BASE(KCOD)
          BLIPF=0.0
          CALL PSRCH(SEQ,IDIM1,J1,J2,CODON,3,3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX,BLIPF,BLIPH)
          BLIPF=BLIPF+YMAX3
          J11=J1+1
          CALL PSRCH(SEQ,IDIM1,J11,J2,CODON,3,3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX,BLIPF,BLIPH)
          BLIPF=BLIPF+YMAX3
          J11=J1+2
          CALL PSRCH(SEQ,IDIM1,J11,J2,CODON,3,3,XMAX,XMIN,YMAX,YMIN,
     +    MARGL1,MARGR1,MARGB1,MARGT1,ISXMAX,ISYMAX,BLIPF,BLIPH)
        END IF
10    CONTINUE
      CALL VT100M
      END
      CHARACTER*1 FUNCTION SCOMP(CHAR1)
C   AUTHOR: RODGER STADEN
      CHARACTER CHAR1,CHARSU(5),CHARSL(5)
      INTEGER CTONUM
      EXTERNAL CTONUM,ICOMP
      SAVE CHARSU,CHARSL
      DATA CHARSU/'T','C','A','G','-'/
      DATA CHARSL/'t','c','a','g','-'/
      JCHAR=CTONUM(CHAR1)
      IF(CHAR1.EQ.CHARSU(JCHAR)) THEN
        SCOMP=CHARSU(ICOMP(JCHAR))
      ELSE
        SCOMP=CHARSL(ICOMP(JCHAR))
      END IF
      END
C    TRANS
C   SUBROUTINE TO TRANSLATE A SEQUENCE IN 1 PHASE GIVEN START & STOP
C   POSITIONS AND A SEQUENCE
      SUBROUTINE TRANS(SEQNCE,IDIM1,IS,IE,OUTP,PAA,IDIM2,KSTART,
     +JSTRAN)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQNCE(IDIM1),PAA(125),OUTP(IDIM2),CODON(3),TRANF,TRANB
      INTEGER POUT
      EXTERNAL LWRAP,TRANF,TRANB
      IX2=IE
C   ADD ON TO END IF OVER JOIN. REALLY A COUNTER OF
C   NUMBER OF ELEMENTS TO TRANSLATE. LWRAP TAKES CARE OF OVERFLOW.
C   WRAP AROUND IF OVER JOIN
      IF(IX2.LE.IS)IX2=IX2+IDIM1
      DO 500 I=IS-KSTART+1,IX2-KSTART+1,3
         DO 400 J=1,3
           IP1=I+J-1
           IP1=LWRAP(IDIM1,IP1)
           CODON(J)=SEQNCE(IP1)
400      CONTINUE
         IP=I
         IP=LWRAP(IDIM1,IP)
         POUT=IP/3+1
         IF(JSTRAN.EQ.0)OUTP(POUT)=TRANF(CODON,PAA)
         IF(JSTRAN.EQ.1)OUTP(POUT)=TRANB(CODON,PAA)
500   CONTINUE
      END
      SUBROUTINE TRANSD(SEQNCE,IDIM1,IS,IE,OUTP,IDIM2,PAA,JSTRAN)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQNCE(IDIM1),PAA(125),OUTP(IDIM2),CODON(3),TRANF,TRANB
      INTEGER POUT
      EXTERNAL JCODNO,TRANF,TRANB,LWRAP
      POUT=0
C   SET UP LOOP VALUE
      IX2=IE
C   ADD ON TO END IF OVER JOIN. REALLY A COUNTER OF
C   NUMBER OF ELEMENTS TO TRANSLATE. LWRAP TAKES CARE OF OVERFLOW.
C   WRAP AROUND IF OVER JOIN
      IF(IX2.LE.IS)IX2=IX2+IDIM1
      DO 500 I=IS,IX2,3
         DO 400 J=1,3
           IP1=I+J-1
           IP1=LWRAP(IDIM1,IP1)
           CODON(J)=SEQNCE(IP1)
400      CONTINUE
         POUT=POUT+1
         IF(JSTRAN.EQ.0)OUTP(POUT)=TRANF(CODON,PAA)
         IF(JSTRAN.EQ.1)OUTP(POUT)=TRANB(CODON,PAA)
500   CONTINUE
      IDIM2=POUT
      END
      INTEGER FUNCTION JCODNO(SEQ,IDIM,I)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      INTEGER CTONUM
      EXTERNAL CTONUM,LWRAP
C   DECODE NEXT 3 CHARS TO GIVE POINTERS TO AMINO ACIDS
      J0=I
      J0=LWRAP(IDIM,J0)
      J1=LWRAP(IDIM,J0+1)
      J2=LWRAP(IDIM,J1+1)
      K0=CTONUM(SEQ(J0))*25
      K1=CTONUM(SEQ(J1))*5
      K2=CTONUM(SEQ(J2))
      JCODNO=K0+K1+K2-30
      END
      SUBROUTINE OPENTR(SEQ,IDIM,KSTART,IDEV,KBIN,KBOUT,PAA,
     +OUTP,IDIMP,FRAMEC,POSNS,MAXPS,IDEVE,FILNAM,
     +IHELPS,IHELPE,HELPF,IDEVH,DIALOG)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIMP),PAA(125),OUTP(IDIMP)
      CHARACTER HELPF*(*),FILNAM*(*),OPRATR*20
      INTEGER FRAMEC(IDIMP),POSNS(MAXPS),ANSE,DIALOG
      CALL SHOWFU(KBOUT,
     +'Find open reading frames, translate and list')
      CALL GETPAR(39,10,IOK,MINO,MINOPN,JSTRAN,
     +MINLEN,MAXLEN,LINLEN,ITRAN,JTRAN,INUM,ANSE,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      MAXPOS = MAXPS
      MAXO = IDIM/3
      I1 = 1
      I2 = IDIM
      IF(DIALOG.EQ.1)CALL TRAND7(KBIN,KBOUT,I1,I2,ITRAN,
     +MINLEN,MAXLEN,LINLEN,
     +MINO,MAXO,MINOPN,JSTRAN,INUM,IDEVE,ANSE,JTRAN,FILNAM,
     +IOK,OPRATR,
     +IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.NE.0) RETURN
      CALL FILLI(FRAMEC,IDIM,1)
      SEQ(IDIM+1) = SEQ(1)
      SEQ(IDIM+2) = SEQ(2)
      IF(JTRAN.EQ.0) THEN
        IF(ANSE.EQ.1) THEN
          CALL TRANEM(SEQ,IDIM,I1,I2,FRAMEC,
     +    IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,IOK)
          IF(IOK.NE.0) RETURN
        ELSE IF(ANSE.EQ.2) THEN
          CALL TRANEN(SEQ,IDIM,I1,I2,FRAMEC,JSTRAN,IDEVE,
     +    POSNS,MAXPOS,KBOUT,OPRATR,IOK)
        ELSE
          IF((JSTRAN.EQ.0).OR.(JSTRAN.EQ.1))THEN
            CALL TRPIRP(SEQ,IDIM,I1,I2,KSTART,MINOPN,IDEV,PAA,
     +      JSTRAN,OUTP,FRAMEC,IDIMP)
          ELSE IF (JSTRAN.EQ.2) THEN
            CALL TRPIRP(SEQ,IDIM,I1,I2,KSTART,MINOPN,IDEV,PAA,
     +      0,OUTP,FRAMEC,IDIMP)
            CALL TRPIRP(SEQ,IDIM,I1,I2,KSTART,MINOPN,IDEV,PAA,
     +      1,OUTP,FRAMEC,IDIMP)
          END IF
        END IF
      END IF
      CALL TRAN6X(SEQ,IDIMP,IDEV,I1,I2,PAA,ITRAN,JSTRAN,INUM,LINLEN,
     +FRAMEC)
      END
      SUBROUTINE TRANEM(SEQ,IDIM,J1,J2,FRAMEC,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,IOK)
C get start and end points for translation, then set up
C the integer array for tran6x
      CHARACTER SEQ(IDIM)
      INTEGER FRAMEC(IDIM),FRAME
      KSTRAN = 0
 50   CONTINUE
      KSTRAN = 0
      CALL TRAND8(IDIM,J1,J2,KSTRAN,IP1,IP2,'Translate',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,IOK)
        IF(IOK.NE.0) RETURN
        IF(IP1.EQ.0) RETURN
      FRAME = MOD(IP1,3)
      IF(FRAME.EQ.0) FRAME = 3
      IF(KSTRAN.EQ.0) THEN
        CALL MBPRIM(FRAMEC,IDIM,IP1,IP2,2)
      ELSE
        CALL MBPRIM(FRAMEC,IDIM,IP1,IP2,3)
      END IF
      GO TO 50
      END
      SUBROUTINE TRAND8(IDIM,J1,J2,KSTRAN,IP1,IP2,PROMPT,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,IOK)
C get start and end points and strand for translation
      CHARACTER PROMPT*(*),HELPF*(*)
        CALL GETRC2(KBIN,KBOUT,J1,J2,IDIM,IP1,IP2,PROMPT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        IF(IP1.EQ.0) RETURN
        IOK = 1
        IOP = KSTRAN
        CALL YESONO(IOP,'+ strand','- strand',
     +    IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(IOP.LT.0) RETURN
        KSTRAN = IOP
      IOK = 0
      END
      SUBROUTINE TRAND7(KBIN,KBOUT,I1,I2,
     +ITRAN,MINLEN,MAXLEN,LINLEN,MINO,MAXO,MINOPN,JSTRAN,INUM,
     +IDEVE,ANSE,JTRAN,FILNAM,IOK,OPRATR,
     +IHELPS,IHELPE,HELPF,IDEVH)
C   AUTHOR: RODGER STADEN
C organise user interaction for translation to screen
      CHARACTER HELPF*(*),FILNAM*(*)
      PARAMETER (MAXPRM = 25)
      CHARACTER PROMPT(4)*(MAXPRM),OPRATR*(*)
      INTEGER ANSE
C  Modified 11-4-91 to make 6 phase translation more obvious
C   Translate if JTRAN = 0
C   Keyboard input if ANSE = 1
C   feature table input if ANSE = 2
C   open reading frames is ANSE = 3
C   + strand if JSTRAN = 0
C   - strand if JSTRAN = 1
C   both strands JSTRAN = 2
C   one letter codes if ITRAN = 0
C   three letter codes if ITRAN = 3
C   number ends of lines if INUM = 0
C   Display I1 to I2
      IOK = 1
      J1 = I1
      J2 = I2
      IOP =  0
      CALL YESONO(IOP,'Show translation','Hide translation',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(IOP.LT.0) THEN
          IOK = 1
          RETURN
        END IF
      JTRAN = IOP
      IF(JTRAN.EQ.0) THEN
        PROMPT(1) = 'Typed on the keyboard'
        PROMPT(2) = 'Read from a feature table'
        PROMPT(3) = 'Open reading frames'
        PROMPT(4) = 'All six frames'
        CALL RADION('The segments to translate can be',
     +  PROMPT,4,ANSE,
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(ANSE.LT.1) RETURN
        IF(ANSE.EQ.2) THEN
          CALL TRAND9(KBIN,KBOUT,IDEVE,FILNAM,OPRATR,
     +    IHELPS,IHELPE,HELPF,IDEVH,IOK)
          IF(IOK.NE.0) RETURN
        END IF
        IF(ANSE.EQ.3) THEN
          CALL GETINT(MINO,MAXO,MINOPN,
     +    'Minimum open frame in amino acids',
     +    IVAL,KBIN,KBOUT,
     +    IHELPS,IHELPE,HELPF,IDEVH,IOK)
          IF(IOK.NE.0) RETURN
          MINOPN = IVAL
        END IF
        IF(ANSE.EQ.4) THEN
          MINOPN = 0
          JSTRAN = 2
        END IF
        IOP = ITRAN
        IF(IOP.EQ.3) IOP = 1
        CALL YESONO(IOP,'Use 1 letter codes',
     +  'Use 3 letter codes',
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(IOP.LT.0) THEN
          IOK = 1
          RETURN
        END IF
        IF(IOP.EQ.1) ITRAN = 3
        IF(IOP.EQ.0) ITRAN = 0
      END IF
      CALL GTREG(KBIN,KBOUT,J1,J2,I1,I2,
     +'Define section of DNA to display',
     + IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      CALL GETINT(MINLEN,MAXLEN,LINLEN,'Line length',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      LINLEN = IVAL
      IF(JTRAN.EQ.0) THEN
        IF(MOD(LINLEN,3).NE.0) LINLEN = 60
      END IF
      IF(ANSE.NE.4) THEN
        IVAL = JSTRAN + 1
        CALL GSTRND(IVAL,IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(IVAL.LT.1) THEN
          IOK = 1
          RETURN
        END IF
        JSTRAN = IVAL - 1
      END IF
      IOP = INUM
      CALL YESONO(IOP,'Number ends of lines',
     +'Number every tenth base',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IOP.LT.0) THEN
        IOK = 1
        RETURN
      END IF
      INUM = IOP
      IOK = 0
      END
      SUBROUTINE EMBLF(IDEVE,FILNAM,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,ANSE,OPRATR,IOK)
C   AUTHOR: RODGER STADEN
C ask about keyboard or ft input. If ft open file and anse = 1
      CHARACTER FILNAM*(*),HELPF*(*),OPRATR*(*)
      INTEGER ANSE
      IOK = 1
      IOP = ANSE
      CALL YESONO(IOP,'Define segments using keyboard',
     +'Define segments using embl feature table',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IOP.LT.0) RETURN
      ANSE = IOP
      IF(ANSE.EQ.1) THEN
          CALL TRAND9(KBIN,KBOUT,IDEVE,FILNAM,OPRATR,
     +    IHELPS,IHELPE,HELPF,IDEVH,IOK)
          IF(IOK.NE.0) RETURN
      END IF
      IOK = 0
      END
      SUBROUTINE TRAND9(KBIN,KBOUT,IDEVE,FILNAM,OPRATR,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
C open feature table file and get ft operator
      CHARACTER FILNAM*(*),HELPF*(*)
      CHARACTER OPRATR*(*)
      FILNAM = ' '
      CALL OPENF1(IDEVE,FILNAM,0,IOK,KBIN,KBOUT,
     +'Feature table file name',
     +IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.NE.0) RETURN
 20   CONTINUE
      IOK = 1
      LIN = 3
      CALL GTSTR('Operator','all',OPRATR,LIN,
     +KBOUT,KBIN,INFLAG)
      IF(INFLAG.EQ.2) RETURN
      CALL CCASE(OPRATR,1)
      IF((LIN.EQ.0).OR.(OPRATR(1:3).EQ.'ALL')) OPRATR(1:1) = ' '
      IF(INFLAG.EQ.1) THEN
        CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        GO TO 20
      END IF
      IOK = 0
      END
      SUBROUTINE TRANEN(SEQ,IDIM,J1,J2,FRAMEC,JSTRAN,IDEVE,
     +POSNS,MAXPOS,KBOUT,OPRATR,IOK)
C use ft to set up array for tran6x
      CHARACTER SEQ(IDIM),OPRATR*(*)
      INTEGER POSNS(MAXPOS),FRAMEC(IDIM)
      INTEGER EMBLFT
      EXTERNAL EMBLFT
      ISTRAN = 0
      IF(JSTRAN.EQ.1) ISTRAN = 1
10    CONTINUE
      NOBJ = 0
      IOK = EMBLFT(IDEVE,KBOUT,'CDS',OPRATR,ISTRAN,
     +POSNS,MAXPOS,NPOS,NOBJ)
      IF(IOK.NE.0) THEN
        CLOSE(UNIT=IDEVE)
        RETURN
      END IF
      IF(ISTRAN.EQ.0) THEN
      K = NPOS
      DO 100 I=1,NOBJ
        NSEG = POSNS(K)
        IADD = 0
        ITOT = 0
        DO 50 J=K-NSEG,K-1,2
          IP1 = POSNS(J)
          IP2 = POSNS(J+1)
          ITOT = ITOT + IP2 - IP1 + 1
          IP1 = IP1 - IADD
          CALL MBPRIM(FRAMEC,IDIM,IP1,IP2,2)
          IADD = MOD(ITOT,3)
 50       CONTINUE
          K = K - NSEG - 1
 100      CONTINUE
      ELSE
      K = NPOS
      DO 200 I=1,NOBJ
        NSEG = POSNS(K)
        IADD = 0
        ITOT = 0
        DO 60 J=K-1,K-NSEG,-2
          IP1 = POSNS(J-1)
          IP2 = POSNS(J)
          ITOT = ITOT + IP2 - IP1 + 1
          IP2 = IP2 + IADD
C mbprim expect complementary strand codon positions to start
C from the same position as their counterparts on the other strand
C ie the first position should correspond to the third
C + strand 123
C - strand 123
          CALL MBPRIM(FRAMEC,IDIM,IP1,IP2,-3)
          IADD = MOD(ITOT,3)
 60       CONTINUE
          K = K - NSEG - 1
 200      CONTINUE
      END IF
      IF((JSTRAN.EQ.2).AND.(ISTRAN.EQ.0)) THEN
        ISTRAN = 1
        REWIND(IDEVE)
        GO TO 10
      END IF
      CLOSE(UNIT=IDEVE)
      END
      SUBROUTINE TRAND1(JSTRAN,ANSE,IDEVE,FILNAM,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,OPRATR,IOK)
C   AUTHOR: RODGER STADEN
C ask for ft or kb input, get operator and strand
      INTEGER ANSE
      CHARACTER FILNAM*(*),HELPF*(*),OPRATR*(*)
      IOK = 1
      CALL EMBLF(IDEVE,FILNAM,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,ANSE,OPRATR,IOK)
      IF(IOK.NE.0)RETURN
      IF(ANSE.EQ.1)THEN
        IOP = JSTRAN + 1
        CALL GSTRND(IOP,IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(IOP.LT.1) THEN
          IOK = 1
          RETURN
        END IF
        JSTRAN = IOP - 1
      END IF
      IOK = 0
      END
      SUBROUTINE TRANDK(SEQ1,IDIM1,OUTP1,IDIMP,ISTART,ISTOP,IDIMT,
     +IDEVE,IDEV,FILNAM,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,PAA,J1,J2,POSNS,MAXPOS)
      CHARACTER HELPF*(*),OPRATR*20
      INTEGER ANSE,POSNS(MAXPOS)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ1(IDIM1),OUTP1(IDIMP),PAA(125),FILNAM*(*)
C   J1 IS THE FIRST BASE IN THE RAM BUFFER
C   J2 IS THE LAST BASE IN THE RAM BUFFER
C   IDIMT IS THE ACTUAL SEQUENCE LENGTH
C   WRAP AROUND IS ONLY POSSIBLE IF J1=1, AND J2=IDIMT
      CALL SHOWFU(KBOUT,'Translate and write protein sequence to disk')
      CALL GETPAR(40,7,IOK,JSTRAN,ANSE,IOPEN,MINO,MAXO,MINOPN,JSTRAN,
     +IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IOP = IOPEN
      CALL YESONO(IOP,'Translate selected regions',
     +'Translate open reading frames',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IOP.LT.0) RETURN
      IF(IOP.EQ.1) THEN
        CALL TRNPIR(SEQ1,IDIM1,J1,J2,ISTART,KBIN,KBOUT,IDEVE,PAA,
     +  OUTP1,IDIMP,FILNAM,MINO,MAXO,MINOPN,JSTRAN,
     +  IHELPS,IHELPE,HELPF,IDEVH)
        RETURN
      END IF
      CALL TRAND1(JSTRAN,ANSE,IDEVE,FILNAM,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,OPRATR,IOK)
      IF(IOK.NE.0) THEN
        IF(ANSE.EQ.1) CLOSE(UNIT=IDEVE)
        RETURN
      END IF
      IF(ANSE.EQ.1) THEN
        FILNAM = ' '
        CALL OPENF1(IDEV,FILNAM,1,IOK,KBIN,KBOUT,
     +  'Output file name',
     +  IHELPS,IHELPE,HELPF,IDEVH)
        IF(IOK.NE.0) RETURN
        CALL TRNEMB(SEQ1,IDIM1,J1,J2,OUTP1,PAA,JSTRAN,IDEVE,IDEV,
     +  POSNS,MAXPOS,KBOUT,OPRATR,IOK)
        RETURN
      END IF
      IOUT = -4
      CALL FILLC(OUTP1,IDIMP,'-')
C
50    CONTINUE
C
      CALL TRAND8(IDIMT,J1,J2,JSTRAN,I1,N1,'Translate',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,IOK)
      IF(IOK.NE.0) RETURN
      IF(I1.NE.0) THEN
        IB = N1 - I1 + 1
        IF(N1.LT.I1) IB = IB + IDIM1
        IAA = IB/3 + 1
        IF(IAA.GE.2) THEN
          IOUT = IOUT + 5
          CALL TRANSD(SEQ1,IDIM1,
     +    I1-ISTART+1,N1-ISTART+1,OUTP1(IOUT),IAA,PAA,JSTRAN)
          IF(JSTRAN.EQ.1) CALL SQREV(OUTP1(IOUT),IAA)
          IOUT = IOUT + IAA - 1
        END IF
        GO TO 50
      END IF
      IF(IOUT.GT.0) THEN
        FILNAM = ' '
        CALL OPENF1(IDEVE,FILNAM,1,IOK,KBIN,KBOUT,
     +  'Output file name',
     +  IHELPS,IHELPE,HELPF,IDEVH)
        IF(IOK.NE.0) RETURN
        CALL FMTDKN(IDEVE,OUTP1,IOUT)
        CLOSE(UNIT=IDEVE)
        RETURN
      END IF
      END
      SUBROUTINE TRNEMB(SEQ,IDIM,J1,J2,SEQW,PAA,JSTRAN,IDEVE,IDEV,
     +POSNS,MAXPOS,KBOUT,OPRATR,IOK)
C translate to disk using ft
      CHARACTER SEQ(IDIM),OPRATR*(*),SEQW(IDIM),PAA(125),LINE*60
      INTEGER POSNS(MAXPOS)
      INTEGER EMBLFT,WPAIR
      EXTERNAL EMBLFT,ITOSL,WPAIR
      ISTRAN = 0
      IF(JSTRAN.EQ.1) ISTRAN = 1
10    CONTINUE
      NOBJ = 0
      IOK = EMBLFT(IDEVE,KBOUT,'CDS',OPRATR,ISTRAN,
     +POSNS,MAXPOS,NPOS,NOBJ)
      IF(IOK.NE.0) THEN
        CLOSE(UNIT=IDEVE)
        RETURN
      END IF
      IF(ISTRAN.EQ.0) THEN
      K = NPOS
      DO 100 I=1,NOBJ
        NSEG = POSNS(K)
        IB = 1
        IF((POSNS(K-NSEG).GE.J1).AND.(POSNS(K-1).LE.J2)) THEN
        DO 50 J=K-NSEG,K-1,2
          L = POSNS(J+1) - POSNS(J) + 1
          CALL SQCOPY(SEQ(POSNS(J)),SEQW(IB),L)
          IB = IB + L
 1001     FORMAT(A)
 50       CONTINUE
          IB = IB - 1
          IACIDS = IB/3 + 1
          CALL TRANSD(SEQW,IDIM,1,IB,SEQW,IACIDS,PAA,ISTRAN)
          LINE(1:) = '>'
          IF(ITOSL(LINE(2:),POSNS(K-NSEG)).EQ.0)
     +     WRITE(*,*)'Scream: ITOSL'
          IF(WPAIR(LINE(22:),POSNS(K-NSEG),POSNS(K-1)).NE.0) 
     +    WRITE(*,*)'Scream: WPAIR'
          WRITE(IDEV,1001)LINE
          IF (SEQW(IACIDS).NE.'*') THEN
            IACIDS = IACIDS + 1
            SEQW(IACIDS) = '*'
          END IF
          CALL FMTDKN(IDEV,SEQW,IACIDS)
        END IF
          K = K - NSEG - 1
 100      CONTINUE
      ELSE
      K = NPOS
      DO 200 I=1,NOBJ
        NSEG = POSNS(K)
        IB = 1
        IF((POSNS(K-NSEG).GE.J1).AND.(POSNS(K-1).LE.J2)) THEN
        DO 60 J=K-NSEG,K-1,2
          L = POSNS(J+1) - POSNS(J) + 1
          CALL SQCOPY(SEQ(POSNS(J)),SEQW(IB),L)
          IB = IB + L
 60       CONTINUE
          IB = IB - 1
          CALL SQREV(SEQW,IB)
          CALL SQCOM2(SEQW,IB)
          IACIDS = IB/3 + 1
          CALL TRANSD(SEQW,IDIM,1,IB,SEQW,IACIDS,PAA,0)
          IF (SEQW(IACIDS).NE.'*') THEN
            IACIDS = IACIDS + 1
            SEQW(IACIDS) = '*'
          END IF
          LINE(1:) = '>                    complement('
          IF (ITOSL(LINE(2:),POSNS(K-1)).EQ.0) WRITE(*,*)'Scream: ITOSL'
          IF(WPAIR(LINE(33:),POSNS(K-NSEG),POSNS(K-1)).NE.0) 
     +    WRITE(*,*)'Scream: WPAIR'
          LINE(32+INDEX(LINE(33:),' '):) = ')'
          WRITE(IDEV,1001)LINE
          CALL FMTDKN(IDEV,SEQW,IACIDS)
        END IF
          K = K - NSEG - 1
 200      CONTINUE
      END IF
      IF((JSTRAN.EQ.2).AND.(ISTRAN.EQ.0)) THEN
        ISTRAN = 1
        REWIND(IDEVE)
        GO TO 10
      END IF
      CLOSE(UNIT=IDEVE)
      CLOSE(UNIT=IDEV)
      END
      SUBROUTINE CODTDK(SEQ,IDIM,J1,J2,IDEVE,FILNAM,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,PAA,POSNS,MAXPOS,SEQW)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),FILNAM*(*),PAA(5,5,5),OPRATR*20
      REAL S1(64),S2(64)
      CHARACTER SEQW(IDIM)
      INTEGER POSNS(MAXPOS)
      INTEGER NORM,ANSE,ANST,ANSTO
      CALL SHOWFU(KBOUT,'Calculate codon table and write it to disk')
      CALL GETPAR(41,5,IOK,JSTRAN,NORM,ANSE,ANST,ANSTO,
     +IPAR6,IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      JSTRAN = 0
      NORM = 0
      ANSE = 0
      ANST = 0
      ANSTO = 0
C ANSTO REDUNDANT
      CALL FILLR(S2,64,0.0)
      CALL CODTBL(IDEVE,FILNAM,S2,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,ANST,IOK)
      IF(IOK.NE.0) RETURN
      CALL CODND1(JSTRAN,NORM,ANSE,IDEVE,FILNAM,OPRATR,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,IOK)
      IF(IOK.NE.0) RETURN
      IF(ANSE.EQ.1) THEN
        CALL CTDEMB(SEQ,IDIM,J1,J2,SEQW,PAA,JSTRAN,IDEVE,
     +  POSNS,MAXPOS,KBIN,KBOUT,OPRATR,S1,S2,NORM,FILNAM,IOK)
      RETURN
      END IF
100   CONTINUE
      CALL FILLR(S1,64,0.0)
      CALL TRAND8(IDIM,J1,J2,JSTRAN,I1,I2,'Count over',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,IOK)
      IF(IOK.NE.0) RETURN
      IF(I1.EQ.0) GO TO 200
      IDIM1 = I2-I1+1
      CALL CALCOD(S1,SEQ(I1),IDIM1)
      IF(JSTRAN.EQ.1)CALL CODCOM(S1)
      CALL ADDR(S1,S2,64)
      IF(NORM.EQ.1)CALL NORMAA(S1,100.,PAA)
      CALL WRTCOD(S1,KBOUT,PAA)
      GO TO 100
200   CONTINUE
      WRITE(KBOUT,9991)
9991  FORMAT(5X,'Codon totals over all genes')
      IF(NORM.EQ.1) CALL NORMAA(S2,100.,PAA)
      CALL WRTCOD(S2,KBOUT,PAA)
      FILNAM = ' '
      CALL OPENF1(IDEVE,FILNAM,1,IOK,KBIN,KBOUT,
     +  'Name for codon table file',
     +  IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.NE.0) RETURN
      CALL WRTCOD(S2,IDEVE,PAA)
      CLOSE(UNIT=IDEVE)
      END
      SUBROUTINE CODND1(JSTRAN,NORM,ANSE,IDEVE,FILNAM,OPRATR,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,IOK)
C   AUTHOR: RODGER STADEN
C get observed or normalised, kb or ft, operator, strand
      INTEGER ANSE
      CHARACTER FILNAM*(*),HELPF*(*),OPRATR*(*)
      IOK = 1
      IOP = NORM
      CALL YESONO(IOP,'Show observed counts',
     +'Normalize counts',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IOP.LT.0) RETURN
      NORM = IOP
      CALL TRAND1(JSTRAN,ANSE,IDEVE,FILNAM,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,OPRATR,IOK)
      IF(IOK.NE.0) THEN
        IF(ANSE.EQ.1) CLOSE(UNIT=IDEVE)
        RETURN
      END IF
      IOK = 0
      END
      SUBROUTINE CTDEMB(SEQ,IDIM,J1,J2,SEQW,PAA,JSTRAN,IDEVE,
     +POSNS,MAXPOS,KBIN,KBOUT,OPRATR,S1,S2,NORM,FILNAM,IOK)
C codons to disk using ft
      CHARACTER SEQ(IDIM),OPRATR*(*),SEQW(IDIM),PAA(125)
      INTEGER POSNS(MAXPOS)
      REAL S1(64),S2(64)
      CHARACTER FILNAM*(*)
      INTEGER EMBLFT
      EXTERNAL EMBLFT
      ISTRAN = 0
      IF(JSTRAN.EQ.1) ISTRAN = 1
10    CONTINUE
      NOBJ = 0
      IOK = EMBLFT(IDEVE,KBOUT,'CDS',OPRATR,ISTRAN,
     +POSNS,MAXPOS,NPOS,NOBJ)
      IF(IOK.NE.0) THEN
        CLOSE(UNIT=IDEVE)
        RETURN
      END IF
      IF(ISTRAN.EQ.0) THEN
      K = NPOS
      DO 100 I=1,NOBJ
        NSEG = POSNS(K)
        IB = 1
        IF((POSNS(K-NSEG).GE.J1).AND.(POSNS(K-1).LE.J2)) THEN
          WRITE(KBOUT,*)'Data from end point ',POSNS(K-NSEG)
        DO 50 J=K-NSEG,K-1,2
          L = POSNS(J+1) - POSNS(J) + 1
          CALL SQCOPY(SEQ(POSNS(J)),SEQW(IB),L)
          IB = IB + L
C note not checking for within j1,j2
 50       CONTINUE
          IB = IB - 1
          IB = 3*(IB/3)
          CALL FILLR(S1,64,0.0)
          CALL CALCOD(S1,SEQW,IB)
          CALL ADDR(S1,S2,64)
          IF(NORM.EQ.1)CALL NORMAA(S1,100.,PAA)
          CALL WRTCOD(S1,KBOUT,PAA)
        END IF
          K = K - NSEG - 1
 100      CONTINUE
      ELSE
      K = NPOS
      DO 200 I=1,NOBJ
        NSEG = POSNS(K)
        IB = 1
        IF((POSNS(K-NSEG).GE.J1).AND.(POSNS(K-1).LE.J2)) THEN
          WRITE(KBOUT,*)'Data from end point ',POSNS(K-1)
        DO 60 J=K-NSEG,K-1,2
          L = POSNS(J+1) - POSNS(J) + 1
          CALL SQCOPY(SEQ(POSNS(J)),SEQW(IB),L)
          IB = IB + L
 60       CONTINUE
          IB = IB - 1
          CALL SQREV(SEQW,IB)
          CALL SQCOM2(SEQW,IB)
          IB = 3*(IB/3)
          CALL FILLR(S1,64,0.0)
          CALL CALCOD(S1,SEQW,IB)
          CALL ADDR(S1,S2,64)
          IF(NORM.EQ.1)CALL NORMAA(S1,100.,PAA)
          CALL WRTCOD(S1,KBOUT,PAA)
        END IF
          K = K - NSEG - 1
 200      CONTINUE
      END IF
      IF((JSTRAN.EQ.2).AND.(ISTRAN.EQ.0)) THEN
        ISTRAN = 1
        REWIND(IDEVE)
        GO TO 10
      END IF
      CLOSE(UNIT=IDEVE)
      WRITE(KBOUT,9991)
9991  FORMAT(5X,'Codon totals over all genes')
      IF(NORM.EQ.1) CALL NORMAA(S2,100.,PAA)
      CALL WRTCOD(S2,KBOUT,PAA)
      FILNAM = ' '
      CALL OPENF1(IDEVE,FILNAM,1,IOK,KBIN,KBOUT,
     +  'Name for codon table file',
     +  IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.NE.0) RETURN
      CALL WRTCOD(S2,IDEVE,PAA)
      CLOSE(UNIT=IDEVE)
      END
      SUBROUTINE CODEMB(SEQ,IDIM,J1,J2,SEQW,PAA,JSTRAN,IDEVE,IDEV,
     +POSNS,MAXPOS,KBIN,KBOUT,OPRATR,S1,S2,S3,NORM,FILNAM,IOK)
C codons, acids, bases to screen using ft
      CHARACTER SEQ(IDIM),OPRATR*(*),SEQW(IDIM),PAA(125)
      INTEGER POSNS(MAXPOS)
      REAL S1(64),S2(64),S3(64)
      CHARACTER FILNAM*(*)
      INTEGER EMBLFT
      EXTERNAL EMBLFT
      CALL FILLR(S2,64,0.0)
      ISTRAN = 0
      IF(JSTRAN.EQ.1) ISTRAN = 1
10    CONTINUE
      NOBJ = 0
      IOK = EMBLFT(IDEVE,KBOUT,'CDS',OPRATR,ISTRAN,
     +POSNS,MAXPOS,NPOS,NOBJ)
      IF(IOK.NE.0) THEN
        CLOSE(UNIT=IDEVE)
        RETURN
      END IF
      IF(ISTRAN.EQ.0) THEN
      K = NPOS
      DO 100 I=1,NOBJ
        NSEG = POSNS(K)
        IB = 1
        IF((POSNS(K-NSEG).GE.J1).AND.(POSNS(K-1).LE.J2)) THEN
          WRITE(KBOUT,*)'Data from end point ',POSNS(K-NSEG)
        DO 50 J=K-NSEG,K-1,2
          L = POSNS(J+1) - POSNS(J) + 1
          CALL SQCOPY(SEQ(POSNS(J)),SEQW(IB),L)
          IB = IB + L
C note not checking for within j1,j2
 50       CONTINUE
          IB = IB - 1
          IB = 3*(IB/3)
          CALL FILLR(S1,64,0.0)
          CALL CALCOD(S1,SEQW,IB)
          CALL ADDR(S1,S2,64)
          IF(NORM.EQ.1)THEN
            CALL COPYR(S1,S3,64)
            CALL NORMAA(S3,100.,PAA)
            CALL WRTCOD(S3,IDEV,PAA)
          ELSE
            CALL WRTCOD(S1,IDEV,PAA)
          END IF
          IF(IDEV.EQ.KBOUT)THEN
            CALL BPAUSE(KBIN,KBOUT,IOK)
            IF(IOK.NE.0) RETURN
          END IF
          CALL BCOMPC(S1,IDEV)
          CALL AACOMP(S1,IDEV,PAA)
          IF(IDEV.EQ.KBOUT)THEN
            CALL BPAUSE(KBIN,KBOUT,IOK)
            IF(IOK.NE.0) RETURN
          END IF
          END IF
          K = K - NSEG - 1
 100      CONTINUE
      ELSE
      K = NPOS
      DO 200 I=1,NOBJ
        NSEG = POSNS(K)
        IB = 1
        IF((POSNS(K-NSEG).GE.J1).AND.(POSNS(K-1).LE.J2)) THEN
          WRITE(KBOUT,*)'Data from end point ',POSNS(K-1)
        DO 60 J=K-NSEG,K-1,2
          L = POSNS(J+1) - POSNS(J) + 1
          CALL SQCOPY(SEQ(POSNS(J)),SEQW(IB),L)
          IB = IB + L
 60       CONTINUE
          IB = IB - 1
          CALL SQREV(SEQW,IB)
          CALL SQCOM2(SEQW,IB)
          IB = 3*(IB/3)
          CALL FILLR(S1,64,0.0)
          CALL CALCOD(S1,SEQW,IB)
          CALL ADDR(S1,S2,64)
          IF(NORM.EQ.1)THEN
            CALL COPYR(S1,S3,64)
            CALL NORMAA(S3,100.,PAA)
            CALL WRTCOD(S3,IDEV,PAA)
          ELSE
            CALL WRTCOD(S1,IDEV,PAA)
          END IF
          IF(IDEV.EQ.KBOUT)THEN
            CALL BPAUSE(KBIN,KBOUT,IOK)
            IF(IOK.NE.0) RETURN
          END IF
          CALL BCOMPC(S1,IDEV)
          CALL AACOMP(S1,IDEV,PAA)
          IF(IDEV.EQ.KBOUT)THEN
            CALL BPAUSE(KBIN,KBOUT,IOK)
            IF(IOK.NE.0) RETURN
          END IF
          END IF
          K = K - NSEG - 1
 200      CONTINUE
      END IF
      IF((JSTRAN.EQ.2).AND.(ISTRAN.EQ.0)) THEN
        ISTRAN = 1
        REWIND(IDEVE)
        GO TO 10
      END IF
      WRITE(IDEV,9991)
9991  FORMAT(5X,'Codon totals over all genes')
      IF(NORM.EQ.1)THEN
        CALL COPYR(S2,S3,64)
        CALL NORMAA(S3,100.,PAA)
        CALL WRTCOD(S3,IDEV,PAA)
      ELSE
        CALL WRTCOD(S2,IDEV,PAA)
      END IF
      IF(IDEV.EQ.KBOUT)THEN
        CALL BPAUSE(KBIN,KBOUT,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      CALL BCOMPC(S2,IDEV)
      CALL AACOMP(S2,IDEV,PAA)
      END
      SUBROUTINE CODONS(SEQ,IDIM,J1,J2,IDEV,IDEVE,FILNAM,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,PAA,POSNS,MAXPOS,SEQW)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),FILNAM*(*),PAA(5,5,5),SEQW(IDIM),OPRATR*20
      REAL S1(64),S2(64),S3(64)
      INTEGER NORM,ANSE,POSNS(MAXPOS)
      CALL SHOWFU(KBOUT,
     +'Calculate base, codon and amino acid compositions')
      CALL GETPAR(23,3,IOK,JSTRAN,NORM,ANSE,
     +IPAR4,IPAR5,
     +IPAR6,IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      JSTRAN = 0
      NORM = 0
      ANSE = 0
      CALL CODND1(JSTRAN,NORM,ANSE,IDEVE,FILNAM,OPRATR,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,IOK)
      IF(IOK.NE.0) RETURN
      IF(ANSE.EQ.1) THEN
        CALL CODEMB(SEQ,IDIM,J1,J2,SEQW,PAA,JSTRAN,IDEVE,IDEV,
     +  POSNS,MAXPOS,KBIN,KBOUT,OPRATR,S1,S2,S3,NORM,FILNAM,IOK)
        CLOSE(UNIT=IDEVE)
      RETURN
      END IF
      CALL FILLR(S2,64,0.0)
100   CONTINUE
      CALL FILLR(S1,64,0.0)
      CALL TRAND8(IDIM,J1,J2,JSTRAN,I1,I2,'Count over',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,IOK)
      IF(IOK.NE.0) RETURN
      IF(I1.EQ.0) GO TO 200
      IDIM1 = I2-I1+1
      CALL CALCOD(S1,SEQ(I1),IDIM1)
      IF(JSTRAN.EQ.1)CALL CODCOM(S1)
      CALL ADDR(S1,S2,64)
      IF(NORM.EQ.1)THEN
        CALL COPYR(S1,S3,64)
        CALL NORMAA(S3,100.,PAA)
        CALL WRTCOD(S3,IDEV,PAA)
      ELSE
        CALL WRTCOD(S1,IDEV,PAA)
      END IF
      IF(IDEV.EQ.KBOUT)THEN
        CALL BPAUSE(KBIN,KBOUT,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      CALL BCOMPC(S1,IDEV)
      CALL AACOMP(S1,IDEV,PAA)
      IF(IDEV.EQ.KBOUT)THEN
        CALL BPAUSE(KBIN,KBOUT,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      GO TO 100
200   CONTINUE
      WRITE(IDEV,9991)
9991  FORMAT(5X,'Codon totals over all genes')
      IF(NORM.EQ.1)THEN
        CALL COPYR(S2,S3,64)
        CALL NORMAA(S3,100.,PAA)
        CALL WRTCOD(S3,IDEV,PAA)
      ELSE
        CALL WRTCOD(S2,IDEV,PAA)
      END IF
      IF(IDEV.EQ.KBOUT)THEN
        CALL BPAUSE(KBIN,KBOUT,IOK)
        IF(IOK.NE.0) RETURN
      END IF
      CALL BCOMPC(S2,IDEV)
      CALL AACOMP(S2,IDEV,PAA)
      END
      SUBROUTINE CODIMP(SEQ,IDIM,FTABLE,IDFTAB,IDEVE,FILNAM,
     +KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,J1,J2,IDEV,POSNS,MAXPOS,SEQW)
      CHARACTER HELPF*(*)
C   AUTHOR: RODGER STADEN
      REAL FTABLE(IDFTAB)
      CHARACTER SEQ(IDIM),FILNAM*(*),OPRATR*20,SEQW(IDIM)
      INTEGER ANSE,POSNS(MAXPOS)
      CALL FACTAB(FTABLE,99)
      CALL SHOWFU(KBOUT,'Calculate codon improbability')
      CALL GETPAR(28,2,IOK,JSTRAN,ANSE,
     +IPAR3,IPAR4,IPAR5,
     +IPAR6,IPAR7,IPAR8,IPAR9,IPAR10,
     +IPAR11,IPAR12,IPAR13,IPAR14,IPAR15,
     +IPAR16,IPAR17,IPAR18,IPAR19,IPAR20,
     +IPAR21,IPAR22,IPAR23,IPAR24,IPAR25,
     +IPAR26,IPAR27,IPAR28,IPAR29,IPAR30,
     +IPAR31,IPAR32,IPAR33,IPAR34,IPAR35)
      IF(IOK.NE.0) RETURN
      CALL TRAND1(JSTRAN,ANSE,IDEVE,FILNAM,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,OPRATR,IOK)
      IF(IOK.NE.0) THEN
        IF(ANSE.EQ.1)CLOSE(UNIT=IDEVE)
        RETURN
      END IF
      IF(ANSE.EQ.1) THEN
        CALL CDIEMB(SEQ,IDIM,J1,J2,SEQW,JSTRAN,IDEVE,IDEV,
     +  POSNS,MAXPOS,KBOUT,FTABLE,IDFTAB,OPRATR,IOK)
        CLOSE(UNIT=IDEVE)
      RETURN
      END IF
100   CONTINUE
      CALL TRAND8(IDIM,J1,J2,JSTRAN,I1,I2,'Count over',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT,IOK)
      IF(IOK.NE.0) RETURN
      IF(I1.EQ.0) RETURN
      IDIM1 = I2-I1+1
      IF(JSTRAN.EQ.1) THEN
        CALL SQCOPY(SEQ(I1),SEQW,IDIM1)
        CALL SQREV(SEQW,IDIM1)
        CALL SQCOM2(SEQW,IDIM1)
        CALL CODMPP(SEQW,IDIM,FTABLE,IDFTAB,KBOUT,1,IDIM1,1,IDIM1,
     +  IDIM1,IDEV)
      ELSE
        CALL CODMPP(SEQ,IDIM,FTABLE,IDFTAB,
     +  KBOUT,1,IDIM,I1,I2,IDIM1,IDEV)
      END IF
      GO TO 100
      END
      SUBROUTINE CDIEMB(SEQ,IDIM,J1,J2,SEQW,JSTRAN,IDEVE,IDEV,
     +POSNS,MAXPOS,KBOUT,FTABLE,IDFTAB,OPRATR,IOK)
C codon improbability using ft
      CHARACTER SEQ(IDIM),OPRATR*(*),SEQW(IDIM)
      INTEGER POSNS(MAXPOS)
      REAL FTABLE(IDFTAB)
      INTEGER EMBLFT
      EXTERNAL EMBLFT
      ISTRAN = 0
      IF(JSTRAN.EQ.1) ISTRAN = 1
10    CONTINUE
      NOBJ = 0
      IOK = EMBLFT(IDEVE,KBOUT,'CDS',OPRATR,ISTRAN,
     +POSNS,MAXPOS,NPOS,NOBJ)
      IF(IOK.NE.0) THEN
        CLOSE(UNIT=IDEVE)
        RETURN
      END IF
      IF(ISTRAN.EQ.0) THEN
      K = NPOS
      DO 100 I=1,NOBJ
        NSEG = POSNS(K)
        IB = 1
        IF((POSNS(K-NSEG).GE.J1).AND.(POSNS(K-1).LE.J2)) THEN
          WRITE(KBOUT,*)'Data from end point ',POSNS(K-NSEG)
        DO 50 J=K-NSEG,K-1,2
          L = POSNS(J+1) - POSNS(J) + 1
          CALL SQCOPY(SEQ(POSNS(J)),SEQW(IB),L)
          IB = IB + L
C note not checking for within j1,j2
 50       CONTINUE
          IB = IB - 1
          IB = 3*(IB/3)
          CALL CODMPP(SEQW,IDIM,FTABLE,IDFTAB,KBOUT,1,IB,1,IB,IB,IDEV)
        END IF
          K = K - NSEG - 1
 100      CONTINUE
      ELSE
      K = NPOS
      DO 200 I=1,NOBJ
        NSEG = POSNS(K)
        IB = 1
        IF((POSNS(K-NSEG).GE.J1).AND.(POSNS(K-1).LE.J2)) THEN
          WRITE(KBOUT,*)'Data from end point ',POSNS(K-1)
        DO 60 J=K-NSEG,K-1,2
          L = POSNS(J+1) - POSNS(J) + 1
          CALL SQCOPY(SEQ(POSNS(J)),SEQW(IB),L)
          IB = IB + L
 60       CONTINUE
          IB = IB - 1
          CALL SQREV(SEQW,IB)
          CALL SQCOM2(SEQW,IB)
          IB = 3*(IB/3)
          CALL CODMPP(SEQW,IDIM,FTABLE,IDFTAB,KBOUT,1,IB,1,IB,IB,IDEV)
        END IF
          K = K - NSEG - 1
 200      CONTINUE
      END IF
      IF((JSTRAN.EQ.2).AND.(ISTRAN.EQ.0)) THEN
        ISTRAN = 1
        REWIND(IDEVE)
        GO TO 10
      END IF
      END
      SUBROUTINE PLTEMB(JSTRAN,IDEVE,
     +POSNS,MAXPOS,KBOUT,KEYWRD,OPRATR,YF,BLIPB,BLIPT,
     +    XMAX,XMIN,YMAX,YMIN,
     +    MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
C plot features
      CHARACTER OPRATR*(*),KEYWRD*(*)
      INTEGER POSNS(MAXPOS)
      INTEGER EMBLFT
      EXTERNAL EMBLFT
      ISTRAN = 0
      IF(JSTRAN.EQ.1) ISTRAN = 1
10    CONTINUE
      NOBJ = 0
      IOK = EMBLFT(IDEVE,KBOUT,KEYWRD,OPRATR,ISTRAN,
     +POSNS,MAXPOS,NPOS,NOBJ)
      IF(IOK.NE.0) THEN
        CLOSE(UNIT=IDEVE)
        RETURN
      END IF
      IF(ISTRAN.EQ.0) THEN
      K = NPOS
      DO 100 I=1,NOBJ
        NSEG = POSNS(K)
        DO 50 J=K-NSEG,K-1,2
          CALL PLTBAR(REAL(POSNS(J)),REAL(POSNS(J+1)),
     +    YF,BLIPB,BLIPT,
     +    XMAX,XMIN,YMAX,YMIN,
     +    MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
C note not checking for within j1,j2
 50       CONTINUE
          K = K - NSEG - 1
 100      CONTINUE
      ELSE
      K = NPOS
      DO 200 I=1,NOBJ
        NSEG = POSNS(K)
        DO 60 J=K-NSEG,K-1,2
          CALL PLTBAR(REAL(POSNS(J)),REAL(POSNS(J+1)),
     +    YF,BLIPB,BLIPT,
     +    XMAX,XMIN,YMAX,YMIN,
     +    MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
 60       CONTINUE
          K = K - NSEG - 1
 200      CONTINUE
      END IF
      IF((JSTRAN.EQ.2).AND.(ISTRAN.EQ.0)) THEN
        ISTRAN = 1
        REWIND(IDEVE)
        GO TO 10
      END IF
      END
C    PLOTMAP
      SUBROUTINE PLTMAQ(IDEV,FILNAM,POSNS,MAXPOS,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IS,IE,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH)
      CHARACTER HELPF*(*)
      INTEGER POSNS(MAXPOS)
C   AUTHOR: RODGER STADEN
      CHARACTER FILNAM*(*),OPRATR*20,KEYWRD*15
      PARAMETER (IBLIPH=128)
      CALL SHOWFU(KBOUT,
     +'Display a map using a feature table file')
      XMAX=IE
      XMIN=IS
      YMIN=0.
      YMAX=ISYMAX
      IY = IBLIPH
      FILNAM = ' '
      CALL OPENF1(IDEV,FILNAM,0,IOK,KBIN,KBOUT,
     +'Feature table file name',
     +IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.NE.0)RETURN
10    CONTINUE
      REWIND IDEV
      LIN = 3
      CALL GTSTR('Feature code','CDS',KEYWRD,LIN,
     +KBOUT,KBIN,INFLAG)
      IF(LIN.EQ.0) KEYWRD(1:3) = 'CDS'
      CALL CCASE(KEYWRD,1)
      IF(INFLAG.EQ.1) THEN
        CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        GO TO 10
      END IF
      IF(INFLAG.EQ.2) GO TO 900
      IF(KEYWRD.EQ.' ') GO TO 900
 20   CONTINUE
      LIN = 3
      CALL GTSTR('Operator','all',OPRATR,LIN,
     +KBOUT,KBIN,INFLAG)
      IF(INFLAG.EQ.2) GO TO 900
      CALL CCASE(OPRATR,1)
      IF((LIN.EQ.0).OR.(OPRATR(1:3).EQ.'ALL')) OPRATR(1:1) = ' '
      IF(INFLAG.EQ.1) THEN
        CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        GO TO 20
      END IF
      JSTRAN = 1
      CALL GSTRND(JSTRAN,IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      JSTRAN = JSTRAN - 1
      IF(JSTRAN.LT.0) GO TO 900
      MININ = 0
      MAXIN = MARGT
      CALL GETINT(MININ,MAXIN,IY,
     +'level',IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) GO TO 900
      IY = IVAL
C      YBASE=IBASE
      YF=IY
      CALL CLEARV
      CALL VECTOM
C   NEED BARS AT ENDS OF FEATURES FROM BLIPB TO BLIPT
      BLIPB=YF-IBLIPH/2
      BLIPT=YF+IBLIPH/2
      CALL PLTEMB(JSTRAN,IDEV,
     +POSNS,MAXPOS,KBOUT,KEYWRD,OPRATR,YF,BLIPB,BLIPT,
     +    XMAX,XMIN,YMAX,YMIN,
     +    MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      CALL VT100M
      GO TO 10
900   CONTINUE
      CLOSE(UNIT=IDEV)
      END
      SUBROUTINE PLTBAR(POSNL,POSNR,YF,BLIPB,BLIPT,
     +XMAX,XMIN,YMAX,YMIN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
C plot a bar for a feature
      CALL LINE(POSNL,POSNR,YF,YF,XMAX,XMIN,YMAX,YMIN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      CALL LINE(POSNL,POSNL,BLIPB,BLIPT,XMAX,XMIN,YMAX,YMIN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      CALL LINE(POSNR,POSNR,BLIPB,BLIPT,XMAX,XMIN,YMAX,YMIN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      END
      SUBROUTINE MBPRIM(FRAMEC,IDIMS,J1,J2,PRIME)
      INTEGER FRAMEC(IDIMS),PRIME,FROTAT(0:2,0:2)
      SAVE FROTAT
      DATA FROTAT/3,2,1,1,3,2,2,1,3/
C  AUTHOR RODGER STADEN
C     multiplies array framec(i1-i2) by 2 or 3 
C     frame rotation depends on frame and sequence length
C     on - strand only works for complete codons
      IF(PRIME.LT.0) THEN
C special case for ft input
        DO 1 I = J2-2,J1,-3
          FRAMEC(I) = FRAMEC(I) * PRIME * (-1)
1       CONTINUE
        RETURN
      END IF
      I1 = J1
      I2 = J2
      IF(J1.GT.J2) THEN
        I2 = IDIMS
        DO 5 I = I1,I2,3
          FRAMEC(I) = FRAMEC(I) * PRIME
 5      CONTINUE
        LFRAME = MOD(IDIMS,3)
        IFRAME = MOD(J1,3)
        I1 = FROTAT(LFRAME,IFRAME)
        I2 = J2
        DO 10 I = I1,I2,3
          FRAMEC(I) = FRAMEC(I) * PRIME
 10     CONTINUE
      ELSE
        DO 20 I = I1,I2,3
          FRAMEC(I) = FRAMEC(I) * PRIME
 20     CONTINUE
      END IF
      END
      SUBROUTINE SQTREE(SEQ,SEQN,IDIM,WORDP,IDE,TREE,MAXTRE,
     +LEVELS,MAXLEV,IDM,KSTART,
     +IDEV,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH)
      CHARACTER SEQ(IDIM),HELPF*(*)
      INTEGER SEQN(IDIM),WORDP(IDE),TREE(MAXTRE)
      INTEGER LEVELS(MAXLEV)
      PARAMETER (MAXLEN = 6,
     +           MAXCON = 4*MAXLEN)
      INTEGER IALPHA(5)
      INTEGER CONSTS(0:MAXCON)
C      INTEGER CONSTS(MAXLEN)
C    PROGRAM TO REPRESENT A SEQUENCE AS A TREE
C    THE FIRST LEVEL OF THE TREE IS THE SEQUENCE COMPOSITION
C    THE SECOND LEVEL CONTAINS ALL THE TWO LETTER WORDS PRESENT
C    AND SO ON. AS THE WORD LENGTH INCREASES THE NUMBER OF
C    DIFFERENT WORDS PRESENT DECREASES, AS DOES THE NUMBER
C    OF OCCURRENCES OF EACH. THE ROUTINE FOLLOWS WORDS UNTIL
C    THEY ONLY OCCUR ONCE.
C    IN ITS SIMPLEST FORM THE ALGORITHM STARTS WITH THE COMPOSITION
C    AND FOLLOWS WORDS UNTIL THEY ONLY OCCUR ONCE. THE METHOD
C    ENCODED BELOW STARTS WITH SOME MINIMUM WORD LENGTH
C    USING THE HASHING METHOD OF THE SHOTGUN PROGRAMS. IT THEN
C    CONVERTS TO THE DATA STRUCTURE FOR THE TREE METHOD. THE CURRENT
C    DATA STRUCTURE IS AS FOLLOWS: FOR ANY WORD LENGTH THERE ARE
C    NWORD DIFFERENT REPEATED WORDS, FOR EACH OF THOSE WORDS
C    THERE ARE IWORD OCCURRENCES. THE TREE IS STORED IN AN ARRAY
C    NAMED TREE. THE FIRST ELEMENT FOR EACH LENGTH OF WORD CONTAINS
C    THE NUMBER OF DIFFERENT WORDS OF THAT LENGTH THAT ARE REPEATED,
C    THE NEXT ELEMENT THE NUMBER OF OCCURRENCES OF THE FIRST WORD, THE
C    NEXT ELEMENTS POINT TO THE STARTS OF THE INDIVIDUAL WORDS, UNTIL
C    THE COUNT FOR THE NEXT REPEATED WORD. THE START POSITION IN THE
C    TREE FOR EACH WORD LENGTH IS STORED IN ARRAY LEVEL.
C
C tree structure:
C
C    word length                                        = wordl
C    number of different repeated words of length wordl = nword
C    number of occurrences of each repeated word        = iword
C    positions of words in the sequence                 = pword
C
C for each length of word (level of the tree) store: 
C
C                 nword(wordl(level)),iword(1),pword(iword(1),1),pword(iword(1),2)
C                               ,,, [iword(1) elements],iword(2),pword(iword(2),1)
C                               ,,,
C
C we also store in array levels a pointer into tree: levels(n) points to the
C start of info for words of length n
C
      CALL CONNUM(SEQ,SEQN,IDIM)
C   COUNT OCCURENCES OF ALPHABET
      CALL FILLI(IALPHA,IDM,0)
      DO 10 I=1,IDIM
        IALPHA(SEQN(I))=IALPHA(SEQN(I))+1
10    CONTINUE
      NALPHA=0
      DO 11 I=1,IDM
        IF(IALPHA(I).NE.0)NALPHA=NALPHA+1
11    CONTINUE
C   CALC EXPECTED LONGEST DIRECT REPEAT
C   lN = 2LOGN/LOG(1/V) - [1+LOG(1-V)/LOGV) + 0.5772/LOGV] + LOG2/LOGV
C   WHERE V=SUM PI, I=1,NALPHA AND N=IDIM
      V=0.
      DO 12 I=1,NALPHA
        V1=REAL(IALPHA(I))/REAL(IDIM)
        V=V+V1*V1
12    CONTINUE
      VLOG=LOG(V)
      VLOGR=LOG(1.0/V)
      VLOG1M=LOG(1.0-V)
      REALLN=(2.*LOG(REAL(IDIM))/VLOGR)-(1+(VLOG1M/VLOG)+
     +        0.5772/VLOG)+LOG(2.)/VLOG
      LENEXP = NINT(REALLN)
      WRITE(KBOUT,1010)LENEXP
 1010 FORMAT(' Expected length of longest repeat',I6)
      LENGTH = MIN(MAXLEN,LENEXP)
      MN = 1
      MX = LENGTH
      JLEVEL = MX
      CALL GETINT(MN,MX,JLEVEL,'Minumim word length',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF (IOK.NE.0) RETURN
      LENGTH = IVAL
      CALL BUSY(KBOUT)
      IF (LENGTH.EQ.1) THEN
        CALL SQTRE1(SEQN,IDIM,TREE,MAXTRE,IALPHA,IDM,IENDT)
      ELSE
        CALL SETCN(CONSTS,LENGTH,IDM,MAXCON)
        CALL ENCOND(SEQN,IDIM,WORDP,IDE,IDM,CONSTS,LENGTH,MAXCON)
        CALL CONV(SEQN,IDIM,WORDP,IDE,TREE,MAXTRE,IENDT,LENGTH)
        CALL CONNUM(SEQ,SEQN,IDIM)
      END IF
C
      LEVEL = LENGTH
      LEVELS(LEVEL) = 1
      IENDT = IENDT + 1
C
C
C
300   CONTINUE
C
C
      LEVEL=LEVEL+1
      IF(LEVEL.GT.MAXLEV)GO TO 650
      LEVELS(LEVEL)=IENDT
      IENDT=IENDT+1
      NODES=TREE(LEVELS(LEVEL-1))
      NBRAN=0
      ITREE=LEVELS(LEVEL-1)+1
      DO 400 I=1,NODES
        NBRAN1=TREE(ITREE)
        ITREE=ITREE+1
        CALL NEWBRA(TREE,MAXTRE,IALPHA,NALPHA,NBRAN1,ITREE,
     +  NBRAN2,SEQN,IDIM,IENDT,IOK)
        IF(IOK.NE.0)GO TO 600
        NBRAN=NBRAN+NBRAN2
        ITREE=ITREE+NBRAN1
400   CONTINUE
      TREE(LEVELS(LEVEL))=NBRAN
      IF(NBRAN.LT.2) THEN
        IF(NBRAN.EQ.0) LEVEL = LEVEL - 1
        GO TO 700
      END IF
      GO TO 300
C
C Come here with problems
C
600   CONTINUE
      CALL ERROM(KBOUT,'Not enough memory')
      LEVEL = LEVEL - 1
      GO TO 700
650   CONTINUE
      CALL ERROM(KBOUT,'Maximum repeat length too long')
      LEVEL = LEVEL - 1
C
C Come here to show results
C
700   CONTINUE
      WRITE(KBOUT,1006)4*(IENDT-1),LEVEL
 1006 FORMAT(' Memory used in bytes',I8,'. Length of longest repeat',I6)
      MN = LENGTH
      MX = LEVEL
      JLEVEL = MX
      CALL GETINT(MN,MX,JLEVEL,
     +'Show repeat frequencies for words of at least length',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF (IOK.NE.0) RETURN
      JLEVEL = IVAL
      ITREE=LEVELS(JLEVEL)
      DO 800 ILEVEL=JLEVEL,LEVEL
        ITREE=LEVELS(ILEVEL)
        WRITE(IDEV,1008)ILEVEL,TREE(ITREE)
 1008   FORMAT(' For length',I6,
     +  ' the number of different repeated words is',I6)
C   find numbers of each word
        INODES=TREE(ITREE)
        ITREE=ITREE+1
        IWORD=TREE(ITREE)
        DO 750 NODE=1,INODES
          ITREE=ITREE+IWORD+1
          IWORD=TREE(ITREE)
750     CONTINUE
800   CONTINUE
C
C
801   CONTINUE
C
C
      MN = LENGTH
      MX = LEVEL
      JLEVEL = MX
      CALL GETINT(MN,MX,JLEVEL,'Show repeats for words of length',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF (IOK.NE.0) RETURN
      JLEVEL = IVAL
      MN = 2
      MX = 9999
      NOCCUR = MN
      CALL GETINT(MN,MX,NOCCUR,
     +'Show repeats for words occuring with frequency',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF (IOK.NE.0) RETURN
      NOCCUR = IVAL
Ccccccccccccccccccccccccccccccccccccccccccccc
      ITREE=LEVELS(JLEVEL)
C   find numbers of different words
      INODES=TREE(ITREE)
      ITREE=ITREE+1
C   find number of occurences of first word
      IWORD=TREE(ITREE)
C   loop for each of the different words
      DO 850 NODE=1,INODES
        IF(IWORD.LT.NOCCUR)GO TO 876
C  note this last line used to go to 850 not 876
C   enough occurences so output
        WRITE(IDEV,1014)(SEQ(K),K=TREE(ITREE+1)-(JLEVEL-1),
     +TREE(ITREE+1))
1014  FORMAT(' ',50A1)
        JJ=ITREE
        DO 875 J=1,IWORD
          JJ=JJ+1
          WRITE(IDEV,1015)(TREE(JJ)-JLEVEL+1)+KSTART-1
1015      FORMAT(' occurs at ',I6)
875     CONTINUE
876     CONTINUE
C   move tree pointer on to next word
        ITREE=ITREE+IWORD+1
C   point to next node
        IWORD=TREE(ITREE)
850   CONTINUE
900   CONTINUE
      GO TO 801
      END
      SUBROUTINE NEWBRA(TREE,IDTREE,IALPHA,NALPHA,NBRAN1,ITREE,
     +NBRAN2,SEQ,IDSEQ,IENDT,IOK)
      INTEGER IALPHA(NALPHA),TREE(IDTREE)
      INTEGER SEQ(IDSEQ)
      DO 10 I=1,NALPHA
        IALPHA(I)=0
10    CONTINUE
C   loop for all elements this node
      DO 20 I=ITREE,ITREE+NBRAN1-1
C        WRITE(*,*)'I',I
C   point to seq
        K=TREE(I)+1
C        WRITE(*,*)'K',K
        IF(K.LE.IDSEQ)IALPHA(SEQ(K))=IALPHA(SEQ(K))+1
20    CONTINUE
C   zero number of branches next level
      NBRAN2=0
C   how many new branches?
      DO 30 I=1,NALPHA
        IF(IALPHA(I).GT.1)NBRAN2=NBRAN2+1
30    CONTINUE
      IF(NBRAN2.LT.1)RETURN
C
C   now store the values
      DO 50 ICHAR=1,NALPHA
        IF(IALPHA(ICHAR).LT.2)GO TO 50
C   save thickness
        IF(IENDT.GT.IDTREE)GO TO 100
        TREE(IENDT)=IALPHA(ICHAR)
        IENDT=IENDT+1
C   now look thru sequence and save relevent pointers
        DO 40 I=ITREE,ITREE+NBRAN1-1
          K=TREE(I)+1
          IF(K.GT.IDSEQ)GO TO 40
          IF(SEQ(K).NE.ICHAR)GO TO 40
C   save pointer
          IF(IENDT.GT.IDTREE)GO TO 100
          TREE(IENDT)=K
          IENDT=IENDT+1
40      CONTINUE
50    CONTINUE
      IOK = 0
      RETURN
100   CONTINUE
      IOK = 1
      END
      SUBROUTINE CONV(POSN,IDIM,WORDP,IDE,TREE,MAXTRE,IENDT,LENGTH)
      INTEGER POSN(IDIM),WORDP(IDE),TREE(MAXTRE)
      IENDT = 1
      NWORD = 0
      DO 20 I = 1,IDE
        IF(WORDP(I).NE.0)THEN
          IP = WORDP(I)
          IF(POSN(IP).NE.0)THEN
            IWORD = 1
            IENDT = IENDT + 1
            IT = IENDT
            NWORD = NWORD + 1
            K = IP
            IENDT = IENDT + 1
            TREE(IENDT) = K + LENGTH - 1
10          CONTINUE
            IF(POSN(K).NE.0)THEN
              K = POSN(K)
              IENDT =IENDT + 1
              TREE(IENDT) = K + LENGTH - 1
              IWORD = IWORD + 1
              GO TO 10
            END IF
            TREE(IT) = IWORD
          END IF
        END IF
20    CONTINUE
      TREE(1) = NWORD
      END
      SUBROUTINE SQTRE1(SEQN,IDIM,TREE,MAXTRE,IALPHA,IDM,IENDT)
      INTEGER SEQN(IDIM),TREE(MAXTRE),IALPHA(IDM)
      IENDT = 2
      TREE(1) = IDM - 1
      DO 200 I = 1,IDM - 1
        TREE(IENDT) = IALPHA(I)
        IENDT = IENDT + 1
        DO 100 J = 1,IDIM
          IF(SEQN(J).EQ.I) THEN
            TREE(IENDT) = J
            IENDT = IENDT + 1
          END IF
 100    CONTINUE
 200  CONTINUE
      IENDT = IENDT - 1
      END
