10996 lines
333 KiB
Fortran
10996 lines
333 KiB
Fortran
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
|